From 55490f06fedc08c6705931ea9aa2ac406c2ebf5c Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 12:26:07 +0100 Subject: [PATCH 01/47] removed test program --- src/libAtoms/test_iostat_vals.f90 | 47 ------------------------------- 1 file changed, 47 deletions(-) delete mode 100755 src/libAtoms/test_iostat_vals.f90 diff --git a/src/libAtoms/test_iostat_vals.f90 b/src/libAtoms/test_iostat_vals.f90 deleted file mode 100755 index eb814ac962..0000000000 --- a/src/libAtoms/test_iostat_vals.f90 +++ /dev/null @@ -1,47 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program t -implicit none - integer stat, n_read - character(len=1024) line - - open (unit=12, file="test_iostat_file", status="UNKNOWN") - write(unit=12, fmt=*) "BOB" - close(unit=12) - - open (unit=12, file="test_iostat_file", status="OLD") - read (unit=12, fmt='(A)', iostat=stat, advance='no', size=n_read) line - print *, stat - read (unit=12, fmt='(A)', iostat=stat, advance='no', size=n_read) line - print *, stat - close(unit=12) - -end program From 8a6cad4deff93bf17613a3fa1207803d07fc9aee Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:48:56 +0100 Subject: [PATCH 02/47] remove references of F95 --- Makefile.config | 1 - 1 file changed, 1 deletion(-) diff --git a/Makefile.config b/Makefile.config index dfdcc62e45..f792d4e8e5 100644 --- a/Makefile.config +++ b/Makefile.config @@ -41,7 +41,6 @@ ifneq (${shell [ -f ${BUILDDIR}/Makefile.inc ] && echo 1 || echo 0},1) @echo "# " >> ${BUILDDIR}/Makefile.inc @echo "# F77=${F77}" >> ${BUILDDIR}/Makefile.inc @echo "# F90=${F90}" >> ${BUILDDIR}/Makefile.inc - @echo "# F95=${F95}" >> ${BUILDDIR}/Makefile.inc @echo "# CC=${CC}" >> ${BUILDDIR}/Makefile.inc @echo "# CPLUSPLUS=${CPLUSPLUS}" >> ${BUILDDIR}/Makefile.inc @echo "# FPP=${FPP}" >> ${BUILDDIR}/Makefile.inc From 52ad26408691240e3a6b29fddd65a65f2a81bf65 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:49:50 +0100 Subject: [PATCH 03/47] changed references of F95 to F90 --- Makefile.fox | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.fox b/Makefile.fox index 4562c2662c..83d8c7afce 100644 --- a/Makefile.fox +++ b/Makefile.fox @@ -26,6 +26,6 @@ ifeq (${QUIP_ARCH},) @echo @exit 1 endif - if [ -e arch.make ]; then make distclean; fi && rm -rf objs.${QUIP_ARCH} && FCFLAGS="-fPIC" FC="${F95}" CC="${CC}" /bin/bash ./configure ${HOST_ARGS} --disable-dom && make && mv objs objs.${QUIP_ARCH} + if [ -e arch.make ]; then make distclean; fi && rm -rf objs.${QUIP_ARCH} && FCFLAGS="-fPIC" FC="${F90}" CC="${CC}" /bin/bash ./configure ${HOST_ARGS} --disable-dom && make && mv objs objs.${QUIP_ARCH} From 6cb56fadadc49fedfcb094852f91c1e7ba4bb143 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:50:20 +0100 Subject: [PATCH 04/47] changed references of F95 to F90 --- Makefile.rules | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/Makefile.rules b/Makefile.rules index 0c9c666415..851d936e3d 100644 --- a/Makefile.rules +++ b/Makefile.rules @@ -28,7 +28,7 @@ # H0 X # H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -.SUFFIXES: .c .h .f .f95 .f90 .fpp +.SUFFIXES: .c .h .f .f95 .f90 .fpp .F90 .F FOX_LIBS = -lFoX_sax -lFoX_wxml -lFoX_utils -lFoX_common -lFoX_fsys FX_LIB = -lfx @@ -52,7 +52,7 @@ ifeq (${CDEBUG},) endif DEFINES += ${GIT_VERSION} ${GAP_VERSION} -D'QUIP_ARCH="${QUIP_ARCH}"' -D'SIZEOF_FORTRAN_T=${SIZEOF_FORTRAN_T}' -F95FLAGS += ${INCLUDES} ${OPTIM} ${DEBUG} ${DEFINES} ${CUSTOM_F95FLAGS} +F90FLAGS += ${INCLUDES} ${OPTIM} ${DEBUG} ${DEFINES} ${CUSTOM_F90FLAGS} F77FLAGS += ${INCLUDES} ${OPTIM} ${DEBUG} ${DEFINES} ${CUSTOM_F77FLAGS} CPLUSPLUSFLAGS += ${INCLUDES} ${COPTIM} ${CDEBUG} ${DEFINES} ${CUSTOM_CPLUSPLUSFLAGS} CFLAGS += ${INCLUDES} ${COPTIM} ${CDEBUG} ${DEFINES} ${CUSTOM_CFLAGS} @@ -176,7 +176,7 @@ SYSLIBS += ${MATH_LINKOPTS} ${EXTRA_LINKOPTS} LINKOPTS += ${OPTIM} ${DEBUG} ${SYSLIBS} ${CUSTOM_LINKOPTS} -.f.o: +.F.o: ${F77} ${F77FLAGS} -c $< -o $@ .c.o: @@ -185,16 +185,16 @@ LINKOPTS += ${OPTIM} ${DEBUG} ${SYSLIBS} ${CUSTOM_LINKOPTS} .cpp.o: ${CPLUSPLUS} ${CPLUSPLUSFLAGS} -c $< -o $@ -.f95.o: - ${F95} ${F95FLAGS} -c ${F95_PRE_FILENAME_FLAG} $< -o $@ +.F90.o: + ${F90} ${F90FLAGS} -c ${F90_PRE_FILENAME_FLAG} $< -o $@ .f90.o: - ${F95} ${F95FLAGS} -c ${F95_PRE_FILENAME_FLAG} $< -o $@ + ${F90} ${F90FLAGS} -c ${F90_PRE_FILENAME_FLAG} $< -o $@ FPP_PRE_TARGET_STRING ?= > -.f95.fpp: - ${FPP} ${F95FLAGS} ${F95_PRE_FILENAME_FLAG} $< ${FPP_PRE_TARGET_STRING} $@ +.F90.fpp: + ${FPP} ${F90FLAGS} ${F90_PRE_FILENAME_FLAG} $< ${FPP_PRE_TARGET_STRING} $@ %.o : %.mod From 78dcd4f0cd900681bc61be0f9731d8b5cd4e6f10 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:50:31 +0100 Subject: [PATCH 05/47] changed references of F95 to F90 --- arch/Makefile.Kaiju | 3 +-- arch/Makefile.altix | 5 ++--- arch/Makefile.altix-mpi | 2 +- arch/Makefile.archer2 | 1 - arch/Makefile.archer2_mpich | 2 +- arch/Makefile.archer2_openmp | 2 +- arch/Makefile.bgq_gfortran | 1 - arch/Makefile.bgq_gfortran_fen | 3 +-- arch/Makefile.cray_xt3 | 3 +-- arch/Makefile.cray_xt3-mpi | 1 - arch/Makefile.csd3_x86_64_gfortran_openmp | 2 +- arch/Makefile.darwin_arm64_gfortran | 5 ++--- arch/Makefile.darwin_arm64_gfortran_openmp | 2 +- arch/Makefile.darwin_arm64_gfortran_openmpi | 1 - arch/Makefile.darwin_x86_32_gfortran | 5 ++--- arch/Makefile.darwin_x86_64_gfortran | 5 ++--- arch/Makefile.darwin_x86_64_gfortran_openmp | 2 +- arch/Makefile.darwin_x86_64_gfortran_openmpi | 1 - arch/Makefile.darwin_x86_64_ifort_icc | 7 +++---- arch/Makefile.linux_x86_32_gfortran | 3 +-- arch/Makefile.linux_x86_64_gfortran | 3 +-- arch/Makefile.linux_x86_64_gfortran_CrayXC30 | 1 - arch/Makefile.linux_x86_64_gfortran_CrayXC30_mpi | 1 - arch/Makefile.linux_x86_64_gfortran_Sulis_openmp | 2 +- arch/Makefile.linux_x86_64_gfortran_Sulis_openmpi | 1 - arch/Makefile.linux_x86_64_gfortran_openmp | 2 +- arch/Makefile.linux_x86_64_gfortran_openmpi | 1 - arch/Makefile.linux_x86_64_gfortran_openmpi+openmp | 3 +-- arch/Makefile.linux_x86_64_ifort_gcc | 5 ++--- arch/Makefile.linux_x86_64_ifort_gcc_openmp | 2 +- arch/Makefile.linux_x86_64_ifort_gcc_openmpi | 1 - arch/Makefile.linux_x86_64_ifort_icc | 5 ++--- arch/Makefile.linux_x86_64_ifort_icc_avon_intelmpi | 1 - arch/Makefile.linux_x86_64_ifort_icc_intelmpi+openmp | 3 +-- arch/Makefile.linux_x86_64_ifort_icc_mpi | 1 - arch/Makefile.linux_x86_64_ifort_icc_openmp | 2 +- arch/Makefile.linux_x86_64_ifort_icc_serial | 5 ++--- arch/Makefile.linux_x86_64_nvfortran | 5 ++--- 38 files changed, 36 insertions(+), 64 deletions(-) diff --git a/arch/Makefile.Kaiju b/arch/Makefile.Kaiju index bb272b9bf8..ee29e66380 100644 --- a/arch/Makefile.Kaiju +++ b/arch/Makefile.Kaiju @@ -32,7 +32,6 @@ F77 = gfortran F90 = gfortran -F95 = gfortran CC = gcc CPLUSPLUS = g++ LINKER = gfortran @@ -43,7 +42,7 @@ DEBUG= -g -DDUMP_CORE_ON_ABORT OPTIM = -O3 DEFINES += -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -DFORTRAN_UNDERSCORE -F95FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC +F90FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC F77FLAGS += -x f77-cpp-input -fno-second-underscore -fPIC CFLAGS += -fPIC CPLUSPLUSFLAGS += -fPIC diff --git a/arch/Makefile.altix b/arch/Makefile.altix index e9d80486d9..eb3bf22be0 100644 --- a/arch/Makefile.altix +++ b/arch/Makefile.altix @@ -32,7 +32,6 @@ F77 = ifort F90 = ifort -F95 = ifort CC = icc CPLUSPLUS = icpc LINKER = ifort -nofor_main @@ -41,11 +40,11 @@ FPP = ifort -E OPTIM = -O3 -ip DEFINES = -DFORTRAN_UNDERSCORE -F95FLAGS += -fpp -FR +F90FLAGS += -fpp -FR F77FLAGS += -fpp AR_ADD = src # rules -F95_PRE_FILENAME_FLAG = -Tf +F90_PRE_FILENAME_FLAG = -Tf diff --git a/arch/Makefile.altix-mpi b/arch/Makefile.altix-mpi index 7f23fc8270..ae07bf85c2 100644 --- a/arch/Makefile.altix-mpi +++ b/arch/Makefile.altix-mpi @@ -29,7 +29,7 @@ # H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX include arch/Makefile.altix -F95FLAGS += -D_MPI +F90FLAGS += -D_MPI F77FLAGS = -D_MPI CFLAGS = -D_MPI CPLUSPLUSFLAGS = -D_MPI diff --git a/arch/Makefile.archer2 b/arch/Makefile.archer2 index de4029de4f..2abb896861 100644 --- a/arch/Makefile.archer2 +++ b/arch/Makefile.archer2 @@ -43,7 +43,6 @@ include arch/Makefile.linux_x86_64_gfortran # compiler settings, make sure this is GNU! F77 = ftn F90 = ftn -F95 = ftn CC = cc CPLUSPLUS = cc LINKER = ftn diff --git a/arch/Makefile.archer2_mpich b/arch/Makefile.archer2_mpich index 91c06eb2f4..ff99ddc810 100644 --- a/arch/Makefile.archer2_mpich +++ b/arch/Makefile.archer2_mpich @@ -34,7 +34,7 @@ include arch/Makefile.archer2 # needed for MPI in gcc11 -F95FLAGS += -fallow-argument-mismatch +F90FLAGS += -fallow-argument-mismatch DEFINES += -D_MPI QUIPPY_LDFLAGS=`ftn --cray-print-opts all` diff --git a/arch/Makefile.archer2_openmp b/arch/Makefile.archer2_openmp index acf56b013c..d9760ae1bd 100644 --- a/arch/Makefile.archer2_openmp +++ b/arch/Makefile.archer2_openmp @@ -41,7 +41,7 @@ include arch/Makefile.archer2 # OpenMP DEFINES += -D_OPENMP -F95FLAGS += -fopenmp +F90FLAGS += -fopenmp F77FLAGS += -fopenmp CFLAGS += -fopenmp LINKOPTS += -fopenmp diff --git a/arch/Makefile.bgq_gfortran b/arch/Makefile.bgq_gfortran index ed3c6eebc0..af1e0c8a8d 100644 --- a/arch/Makefile.bgq_gfortran +++ b/arch/Makefile.bgq_gfortran @@ -34,7 +34,6 @@ include arch/Makefile.linux_x86_64_gfortran_openmp F77 = mpif77 F90 = mpif90 -F95 = mpif90 CC = mpicc CPLUSPLUS = mpicxx LINKER = mpif90 diff --git a/arch/Makefile.bgq_gfortran_fen b/arch/Makefile.bgq_gfortran_fen index df2dfbf5cc..3ed4c82ac7 100644 --- a/arch/Makefile.bgq_gfortran_fen +++ b/arch/Makefile.bgq_gfortran_fen @@ -34,14 +34,13 @@ include arch/Makefile.linux_x86_64_gfortran F77 = /usr/bin/gfortran -m64 F90 = /usr/bin/gfortran -m64 -F95 = /usr/bin/gfortran -m64 CC = /usr/bin/gcc -m64 CPLUSPLUS = /usr/bin/g++ -m64 LINKER = /usr/bin/gfortran -m64 FPP = /usr/bin/gfortran -m64 -E -x f95-cpp-input DEFINES += -D_OPENMP -F95FLAGS += -fopenmp +F90FLAGS += -fopenmp F77FLAGS += -fopenmp CFLAGS += -fopenmp LINKOPTS += -fopenmp diff --git a/arch/Makefile.cray_xt3 b/arch/Makefile.cray_xt3 index 942edfcbf9..a21c39beae 100644 --- a/arch/Makefile.cray_xt3 +++ b/arch/Makefile.cray_xt3 @@ -32,7 +32,6 @@ F77 = pgf77 F90 = pgf90 -F95 = pgf95 CC = pgcc CPLUSPLUS = pgCC LINKER = pgCC -pgf90libs @@ -40,7 +39,7 @@ LINKER = pgCC -pgf90libs OPTIM = -fast -fastsse DEFINES = -DFORTRAN_UNDERSCORE -F95FLAGS += -Mpreprocess -Mfree +F90FLAGS += -Mpreprocess -Mfree F77FLAGS += -Mpreprocess AR_ADD = src diff --git a/arch/Makefile.cray_xt3-mpi b/arch/Makefile.cray_xt3-mpi index 5e001d3b3b..c4ca9cf454 100644 --- a/arch/Makefile.cray_xt3-mpi +++ b/arch/Makefile.cray_xt3-mpi @@ -34,7 +34,6 @@ include arch/Makefile.cray_xt3 F77 = f77 F90 = ftn -F95 = ftn CC = cc CPLUSPLUS = CC LINKER = ftn -Mnomain diff --git a/arch/Makefile.csd3_x86_64_gfortran_openmp b/arch/Makefile.csd3_x86_64_gfortran_openmp index 88009eec49..f31108374a 100644 --- a/arch/Makefile.csd3_x86_64_gfortran_openmp +++ b/arch/Makefile.csd3_x86_64_gfortran_openmp @@ -33,7 +33,7 @@ include arch/Makefile.linux_x86_64_gfortran DEFINES += -D_OPENMP -F95FLAGS += -fopenmp +F90FLAGS += -fopenmp F77FLAGS += -fopenmp CFLAGS += -fopenmp LINKOPTS += -fopenmp diff --git a/arch/Makefile.darwin_arm64_gfortran b/arch/Makefile.darwin_arm64_gfortran index 9998bc79d7..e67b83c258 100644 --- a/arch/Makefile.darwin_arm64_gfortran +++ b/arch/Makefile.darwin_arm64_gfortran @@ -32,7 +32,6 @@ F77 = gfortran F90 = gfortran -F95 = gfortran CC = gcc CPLUSPLUS = g++ LINKER = gfortran @@ -43,8 +42,8 @@ SAMPLE_DEBUG = -O0 -g -fbounds-check -DDUMP_CORE_ON_ABORT DEBUG = OPTIM = -O3 -DEFINES += -DFORTRAN_UNDERSCORE -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -DDARWIN -fPIC -F95FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs +DEFINES += -DFORTRAN_UNDERSCORE -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -fPIC +F90FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs F77FLAGS += -x f77-cpp-input -fno-second-underscore -fPIC -fno-realloc-lhs CFLAGS += -fPIC diff --git a/arch/Makefile.darwin_arm64_gfortran_openmp b/arch/Makefile.darwin_arm64_gfortran_openmp index de2751fdaa..3dbc1811d8 100644 --- a/arch/Makefile.darwin_arm64_gfortran_openmp +++ b/arch/Makefile.darwin_arm64_gfortran_openmp @@ -33,7 +33,7 @@ include arch/Makefile.darwin_x86_64_gfortran DEFINES += -D_OPENMP -F95FLAGS += -fopenmp +F90FLAGS += -fopenmp F77FLAGS += -fopenmp LINKOPTS += -fopenmp diff --git a/arch/Makefile.darwin_arm64_gfortran_openmpi b/arch/Makefile.darwin_arm64_gfortran_openmpi index 87871c5b1c..1b491116f5 100644 --- a/arch/Makefile.darwin_arm64_gfortran_openmpi +++ b/arch/Makefile.darwin_arm64_gfortran_openmpi @@ -34,7 +34,6 @@ include arch/Makefile.darwin_x86_64_gfortran F77 = mpif77 F90 = mpif90 -F95 = mpif90 CC = mpicc CPLUSPLUS = mpic++ LINKER = mpif90 diff --git a/arch/Makefile.darwin_x86_32_gfortran b/arch/Makefile.darwin_x86_32_gfortran index 4b91d60e02..751ab6372e 100644 --- a/arch/Makefile.darwin_x86_32_gfortran +++ b/arch/Makefile.darwin_x86_32_gfortran @@ -32,7 +32,6 @@ F77 = gfortran -m32 F90 = gfortran -m32 -F95 = gfortran -m32 CC = gcc -m32 CPLUSPLUS = g++ -m32 LINKER = gfortran -m32 @@ -43,8 +42,8 @@ SAMPLE_DEBUG = -g -fbounds-check -DDUMP_CORE_ON_ABORT DEBUG = OPTIM = -O3 -DEFINES += -DFORTRAN_UNDERSCORE -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -DDARWIN -fPIC -F95FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs +DEFINES += -DFORTRAN_UNDERSCORE -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -fPIC +F90FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs F77FLAGS += -x f77-cpp-input -fno-second-underscore -fPIC -fno-realloc-lhs CFLAGS += -fPIC diff --git a/arch/Makefile.darwin_x86_64_gfortran b/arch/Makefile.darwin_x86_64_gfortran index 23cc3d88a7..eb05ad561a 100644 --- a/arch/Makefile.darwin_x86_64_gfortran +++ b/arch/Makefile.darwin_x86_64_gfortran @@ -32,7 +32,6 @@ F77 = gfortran F90 = gfortran -F95 = gfortran CC = gcc CPLUSPLUS = g++ LINKER = gfortran @@ -43,8 +42,8 @@ SAMPLE_DEBUG = -O0 -g -fbounds-check -DDUMP_CORE_ON_ABORT DEBUG = OPTIM = -O3 -DEFINES += -DFORTRAN_UNDERSCORE -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -DDARWIN -fPIC -F95FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs +DEFINES += -DFORTRAN_UNDERSCORE -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -fPIC +F90FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs F77FLAGS += -x f77-cpp-input -fno-second-underscore -fPIC -fno-realloc-lhs CFLAGS += -fPIC diff --git a/arch/Makefile.darwin_x86_64_gfortran_openmp b/arch/Makefile.darwin_x86_64_gfortran_openmp index f96c41a379..42d2818e38 100644 --- a/arch/Makefile.darwin_x86_64_gfortran_openmp +++ b/arch/Makefile.darwin_x86_64_gfortran_openmp @@ -33,7 +33,7 @@ include arch/Makefile.darwin_x86_64_gfortran DEFINES += -D_OPENMP -F95FLAGS += -fopenmp +F90FLAGS += -fopenmp F77FLAGS += -fopenmp LINKOPTS += -fopenmp -static-libgcc diff --git a/arch/Makefile.darwin_x86_64_gfortran_openmpi b/arch/Makefile.darwin_x86_64_gfortran_openmpi index e1f5427133..fc0e8de665 100644 --- a/arch/Makefile.darwin_x86_64_gfortran_openmpi +++ b/arch/Makefile.darwin_x86_64_gfortran_openmpi @@ -34,7 +34,6 @@ include arch/Makefile.darwin_x86_64_gfortran F77 = openmpif77 F90 = openmpif90 -F95 = openmpif90 CC = openmpicc CPLUSPLUS = openmpic++ LINKER = openmpif90 diff --git a/arch/Makefile.darwin_x86_64_ifort_icc b/arch/Makefile.darwin_x86_64_ifort_icc index 9b1b5bf6ec..c3caf49cd1 100644 --- a/arch/Makefile.darwin_x86_64_ifort_icc +++ b/arch/Makefile.darwin_x86_64_ifort_icc @@ -2,7 +2,6 @@ F77 = ifort F90 = ifort -F95 = ifort CC = icc CPLUSPLUS = icpc -Kc++ LINKER = ifort @@ -13,8 +12,8 @@ OPTIM = -O3 -vec-report0 -unroll -xP -p CDEBUG = -g -DDUMP_CORE_ON_ABORT COPTIM = -O3 -DEFINES = -DGETARG_F2003 -DFORTRAN_UNDERSCORE -DDARWIN -F95FLAGS += -fpp -free +DEFINES = -DGETARG_F2003 -DFORTRAN_UNDERSCORE +F90FLAGS += -fpp -free F77FLAGS += -fixed LINKOPTS += -nofor-main @@ -24,4 +23,4 @@ AR_ADD = src # rules -F95_PRE_FILENAME_FLAG = -Tf +F90_PRE_FILENAME_FLAG = -Tf diff --git a/arch/Makefile.linux_x86_32_gfortran b/arch/Makefile.linux_x86_32_gfortran index f420f398e4..ef8e04aeb2 100644 --- a/arch/Makefile.linux_x86_32_gfortran +++ b/arch/Makefile.linux_x86_32_gfortran @@ -32,7 +32,6 @@ F77 = gfortran -m32 F90 = gfortran -m32 -F95 = gfortran -m32 CC = gcc -m32 CPLUSPLUS = g++ -m32 #LINKER = gfortran -m32 @@ -43,7 +42,7 @@ DEBUG = -g -DDUMP_CORE_ON_ABORT OPTIM = -O3 DEFINES += -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -DFORTRAN_UNDERSCORE -F95FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -Wunused -fPIC -fno-realloc-lhs +F90FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -Wunused -fPIC -fno-realloc-lhs F77FLAGS += -x f77-cpp-input -fno-second-underscore -fPIC -fno-realloc-lhs CFLAGS += -fPIC diff --git a/arch/Makefile.linux_x86_64_gfortran b/arch/Makefile.linux_x86_64_gfortran index b871e1f002..9d09499947 100644 --- a/arch/Makefile.linux_x86_64_gfortran +++ b/arch/Makefile.linux_x86_64_gfortran @@ -32,7 +32,6 @@ F77 = gfortran F90 = gfortran -F95 = gfortran CC = gcc CPLUSPLUS = g++ LINKER = gfortran @@ -43,7 +42,7 @@ DEBUG= OPTIM = -O3 DEFINES += -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -DFORTRAN_UNDERSCORE -F95FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs +F90FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs F77FLAGS += -x f77-cpp-input -fno-second-underscore -fPIC -fno-realloc-lhs CFLAGS += -fPIC CPLUSPLUSFLAGS += -fPIC diff --git a/arch/Makefile.linux_x86_64_gfortran_CrayXC30 b/arch/Makefile.linux_x86_64_gfortran_CrayXC30 index 45faf3a3cf..ea4bdc85d2 100644 --- a/arch/Makefile.linux_x86_64_gfortran_CrayXC30 +++ b/arch/Makefile.linux_x86_64_gfortran_CrayXC30 @@ -37,7 +37,6 @@ include arch/Makefile.linux_x86_64_gfortran F77 = ftn F90 = ftn -F95 = ftn CC = cc CPLUSPLUS = CC LINKER = ftn diff --git a/arch/Makefile.linux_x86_64_gfortran_CrayXC30_mpi b/arch/Makefile.linux_x86_64_gfortran_CrayXC30_mpi index 257b7dff98..f32e993c96 100644 --- a/arch/Makefile.linux_x86_64_gfortran_CrayXC30_mpi +++ b/arch/Makefile.linux_x86_64_gfortran_CrayXC30_mpi @@ -37,7 +37,6 @@ include arch/Makefile.linux_x86_64_gfortran F77 = ftn F90 = ftn -F95 = ftn CC = cc CPLUSPLUS = CC LINKER = ftn diff --git a/arch/Makefile.linux_x86_64_gfortran_Sulis_openmp b/arch/Makefile.linux_x86_64_gfortran_Sulis_openmp index fe1c8108ae..1793e97a65 100644 --- a/arch/Makefile.linux_x86_64_gfortran_Sulis_openmp +++ b/arch/Makefile.linux_x86_64_gfortran_Sulis_openmp @@ -39,7 +39,7 @@ include arch/Makefile.linux_x86_64_gfortran_Sulis # DEFINES += -D_OPENMP # -fopenmp sets this with gcc/gfortran -F95FLAGS += -fopenmp +F90FLAGS += -fopenmp F77FLAGS += -fopenmp CFLAGS += -fopenmp LINKOPTS += -fopenmp diff --git a/arch/Makefile.linux_x86_64_gfortran_Sulis_openmpi b/arch/Makefile.linux_x86_64_gfortran_Sulis_openmpi index 3e2b1f267b..dab70ac0b9 100644 --- a/arch/Makefile.linux_x86_64_gfortran_Sulis_openmpi +++ b/arch/Makefile.linux_x86_64_gfortran_Sulis_openmpi @@ -41,7 +41,6 @@ include arch/Makefile.linux_x86_64_gfortran_Sulis F77 = mpif90 F90 = mpif90 -F95 = mpif90 CC = mpicc CPLUSPLUS = mpicc LINKER = mpif90 diff --git a/arch/Makefile.linux_x86_64_gfortran_openmp b/arch/Makefile.linux_x86_64_gfortran_openmp index 977c283c4b..2fcea0134a 100644 --- a/arch/Makefile.linux_x86_64_gfortran_openmp +++ b/arch/Makefile.linux_x86_64_gfortran_openmp @@ -33,7 +33,7 @@ include arch/Makefile.linux_x86_64_gfortran DEFINES += -D_OPENMP -F95FLAGS += -fopenmp +F90FLAGS += -fopenmp F77FLAGS += -fopenmp CFLAGS += -fopenmp LINKOPTS += -fopenmp diff --git a/arch/Makefile.linux_x86_64_gfortran_openmpi b/arch/Makefile.linux_x86_64_gfortran_openmpi index 6050e07546..5808984f83 100644 --- a/arch/Makefile.linux_x86_64_gfortran_openmpi +++ b/arch/Makefile.linux_x86_64_gfortran_openmpi @@ -34,7 +34,6 @@ include arch/Makefile.linux_x86_64_gfortran F77 = mpif77 F90 = mpif90 -F95 = mpif90 CC = mpicc CPLUSPLUS = mpiCC LINKER = mpif90 diff --git a/arch/Makefile.linux_x86_64_gfortran_openmpi+openmp b/arch/Makefile.linux_x86_64_gfortran_openmpi+openmp index ddea6dfb40..13fa170575 100644 --- a/arch/Makefile.linux_x86_64_gfortran_openmpi+openmp +++ b/arch/Makefile.linux_x86_64_gfortran_openmpi+openmp @@ -34,7 +34,6 @@ include arch/Makefile.linux_x86_64_gfortran F77 = mpif77 F90 = mpif90 -F95 = mpif90 CC = mpicc CPLUSPLUS = mpiCC LINKER = mpif90 @@ -45,7 +44,7 @@ QUIPPY_LDFLAGS=`mpif90 --showme:link` # OpenMP declarations -F95FLAGS += -fopenmp +F90FLAGS += -fopenmp F77FLAGS += -fopenmp CFLAGS += -fopenmp LINKOPTS += -fopenmp diff --git a/arch/Makefile.linux_x86_64_ifort_gcc b/arch/Makefile.linux_x86_64_ifort_gcc index 7199db1560..8ef8ad3ca5 100644 --- a/arch/Makefile.linux_x86_64_ifort_gcc +++ b/arch/Makefile.linux_x86_64_ifort_gcc @@ -32,7 +32,6 @@ F77 = ifort F90 = ifort -F95 = ifort CC = gcc CPLUSPLUS = g++ LINKER = ifort @@ -46,7 +45,7 @@ CDEBUG = -g -DDUMP_CORE_ON_ABORT COPTIM = -O3 -fPIC DEFINES += -DGETARG_F2003 -DFORTRAN_UNDERSCORE -DF2008 -F95FLAGS += -fpp -free -warn unused -fPIC +F90FLAGS += -fpp -free -warn unused -fPIC F77FLAGS += -fpp -fixed -fPIC CFLAGS += -fPIC CPLUSPLUSFLAGS += -fPIC @@ -67,4 +66,4 @@ FARCH= # rules -F95_PRE_FILENAME_FLAG = -Tf +F90_PRE_FILENAME_FLAG = -Tf diff --git a/arch/Makefile.linux_x86_64_ifort_gcc_openmp b/arch/Makefile.linux_x86_64_ifort_gcc_openmp index 283a0fdac2..d0a908cd8d 100644 --- a/arch/Makefile.linux_x86_64_ifort_gcc_openmp +++ b/arch/Makefile.linux_x86_64_ifort_gcc_openmp @@ -33,7 +33,7 @@ include arch/Makefile.linux_x86_64_ifort_gcc DEFINES += -D_OPENMP -F95FLAGS += -openmp +F90FLAGS += -openmp F77FLAGS += -openmp LINKOPTS += -openmp diff --git a/arch/Makefile.linux_x86_64_ifort_gcc_openmpi b/arch/Makefile.linux_x86_64_ifort_gcc_openmpi index 9ea02ada0b..2f1dca4372 100644 --- a/arch/Makefile.linux_x86_64_ifort_gcc_openmpi +++ b/arch/Makefile.linux_x86_64_ifort_gcc_openmpi @@ -34,7 +34,6 @@ include arch/Makefile.linux_x86_64_ifort_gcc F77 = mpif77 F90 = mpif90 -F95 = mpif90 CC = mpicc CPLUSPLUS = mpiCC LINKER = mpif90 diff --git a/arch/Makefile.linux_x86_64_ifort_icc b/arch/Makefile.linux_x86_64_ifort_icc index a442852c38..7ed0295cb0 100644 --- a/arch/Makefile.linux_x86_64_ifort_icc +++ b/arch/Makefile.linux_x86_64_ifort_icc @@ -32,7 +32,6 @@ F77 = ifort F90 = ifort -F95 = ifort CC = icc CPLUSPLUS = icpc -Kc++ FPP = ifort -E @@ -45,7 +44,7 @@ CDEBUG = -g -traceback -DDUMP_CORE_ON_ABORT COPTIM = -O3 DEFINES += -DGETARG_F2003 -DFORTRAN_UNDERSCORE -F95FLAGS += -fpp -free -warn unused -fPIC +F90FLAGS += -fpp -free -warn unused -fPIC F77FLAGS += -fpp -fixed -fPIC CFLAGS += -fPIC CPLUSPLUSFLAGS += -fPIC @@ -61,4 +60,4 @@ QUIPPY_F90FLAGS = -fpp -free QUIPPY_F77FLAGS = -fpp -fixed QUIPPY_CPP = ifort -EP -F95_PRE_FILENAME_FLAG = -Tf +F90_PRE_FILENAME_FLAG = -Tf diff --git a/arch/Makefile.linux_x86_64_ifort_icc_avon_intelmpi b/arch/Makefile.linux_x86_64_ifort_icc_avon_intelmpi index 78358b686f..61fec457ec 100644 --- a/arch/Makefile.linux_x86_64_ifort_icc_avon_intelmpi +++ b/arch/Makefile.linux_x86_64_ifort_icc_avon_intelmpi @@ -51,7 +51,6 @@ export DEFAULT_MATH_LINKOPTS = -L${MKLROOT}/lib/intel64 -lmkl_scalapack_lp64 \ # Invoke wrappers which use Intel MPI with Intel compilers F77 = mpiifort F90 = mpiifort -F95 = mpiifort CC = mpiicc CPLUSPLUS = mpiicpc LINKER = mpiifort diff --git a/arch/Makefile.linux_x86_64_ifort_icc_intelmpi+openmp b/arch/Makefile.linux_x86_64_ifort_icc_intelmpi+openmp index 9ed4fd4580..c25c509b30 100644 --- a/arch/Makefile.linux_x86_64_ifort_icc_intelmpi+openmp +++ b/arch/Makefile.linux_x86_64_ifort_icc_intelmpi+openmp @@ -41,12 +41,11 @@ export DEFAULT_MATH_LINKOPTS = \ F77 = mpiifort F90 = mpiifort -F95 = mpiifort CC = mpiicc CPLUSPLUS = mpiicpc LINKER = mpiifort -F95FLAGS += -qopenmp +F90FLAGS += -qopenmp F77FLAGS += -qopenmp CFLAGS += -qopenmp CPLUSPLUSFLAGS += -qopenmp diff --git a/arch/Makefile.linux_x86_64_ifort_icc_mpi b/arch/Makefile.linux_x86_64_ifort_icc_mpi index 21c6b435be..481d1fbbf0 100644 --- a/arch/Makefile.linux_x86_64_ifort_icc_mpi +++ b/arch/Makefile.linux_x86_64_ifort_icc_mpi @@ -34,7 +34,6 @@ include arch/Makefile.linux_x86_64_ifort_icc F77 = mpif77 F90 = mpif90 -F95 = mpif90 CC = mpicc CPLUSPLUS = mpiCC LINKER = mpif90 diff --git a/arch/Makefile.linux_x86_64_ifort_icc_openmp b/arch/Makefile.linux_x86_64_ifort_icc_openmp index 9568c85056..eb97932a20 100644 --- a/arch/Makefile.linux_x86_64_ifort_icc_openmp +++ b/arch/Makefile.linux_x86_64_ifort_icc_openmp @@ -33,7 +33,7 @@ include arch/Makefile.linux_x86_64_ifort_icc DEFINES += -D_OPENMP -F95FLAGS += -openmp -fPIC +F90FLAGS += -openmp -fPIC F77FLAGS += -openmp -fPIC CFLAGS += -openmp -fPIC CPLUSPLUSFLAGS += -openmp -fPIC diff --git a/arch/Makefile.linux_x86_64_ifort_icc_serial b/arch/Makefile.linux_x86_64_ifort_icc_serial index f416b5bc07..f50f2ea478 100644 --- a/arch/Makefile.linux_x86_64_ifort_icc_serial +++ b/arch/Makefile.linux_x86_64_ifort_icc_serial @@ -32,7 +32,6 @@ F77 = ifort F90 = ifort -F95 = ifort CC = icc CPLUSPLUS = icpc -Kc++ FPP = ifort -E @@ -45,7 +44,7 @@ CDEBUG = -g -DDUMP_CORE_ON_ABORT COPTIM = -O3 DEFINES += -DGETARG_F2003 -DFORTRAN_UNDERSCORE -F95FLAGS += -fpp -free -warn unused -fPIC +F90FLAGS += -fpp -free -warn unused -fPIC F77FLAGS += -fpp -fixed -fPIC CFLAGS += -fPIC CPLUSPLUSFLAGS += -fPIC @@ -61,4 +60,4 @@ QUIPPY_F90FLAGS = -fpp -free QUIPPY_F77FLAGS = -fpp -fixed QUIPPY_CPP = ifort -EP -F95_PRE_FILENAME_FLAG = -Tf +F90_PRE_FILENAME_FLAG = -Tf diff --git a/arch/Makefile.linux_x86_64_nvfortran b/arch/Makefile.linux_x86_64_nvfortran index ebc86279a1..9c9ed563c2 100644 --- a/arch/Makefile.linux_x86_64_nvfortran +++ b/arch/Makefile.linux_x86_64_nvfortran @@ -32,7 +32,6 @@ F77 = nvfortran F90 = nvfortran -F95 = nvfortran CC = nvc CPLUSPLUS = nvc++ LINKER = nvc @@ -49,8 +48,8 @@ DEBUG= -O0 ##OPTIM = -O3 DEFINES += -DGETARG_F2003 -DGETENV_F2003 -DGFORTRAN -DFORTRAN_UNDERSCORE -DNO_FORTRAN_ISNAN -F95FLAGS += -Mbackslash -Mlarge_arrays -fPIC -x f95-cpp-input -#F95FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs +F90FLAGS += -Mbackslash -Mlarge_arrays -fPIC -x f95-cpp-input +#F90FLAGS += -x f95-cpp-input -ffree-line-length-none -ffree-form -fno-second-underscore -fPIC -fno-realloc-lhs #F77FLAGS += -x f77-cpp-input -fno-second-underscore -fPIC -fno-realloc-lhs F77FLAGS += -fPIC -x f77-cpp-input CFLAGS += From ac810215963a917cb425c07f3e45fe1e12e3e300 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:51:15 +0100 Subject: [PATCH 06/47] renamed source files to have F90 extension --- src/libAtoms/Atoms.f95 | 3546 ---------- src/libAtoms/Atoms_ll.f95 | 391 -- src/libAtoms/Atoms_types.f95 | 1779 ----- src/libAtoms/Barostat.f95 | 682 -- src/libAtoms/CInOutput.f95 | 1090 --- src/libAtoms/Connection.f95 | 2239 ------ src/libAtoms/Constraints.f95 | 1828 ----- src/libAtoms/Dictionary.f95 | 3198 --------- src/libAtoms/DomainDecomposition.f95 | 1605 ----- src/libAtoms/DynamicalSystem.f95 | 3287 --------- src/libAtoms/ExtendableStr.f95 | 716 -- src/libAtoms/Group.f95 | 812 --- src/libAtoms/LinkedList.f95 | 957 --- src/libAtoms/MPI_context.f95 | 1834 ----- src/libAtoms/Matrix.f95 | 1722 ----- src/libAtoms/ParamReader.f95 | 1061 --- src/libAtoms/PeriodicTable.f95 | 204 - src/libAtoms/Quaternions.f95 | 782 --- src/libAtoms/RigidBody.f95 | 885 --- src/libAtoms/ScaLAPACK.f95 | 1662 ----- src/libAtoms/SocketTools.f95 | 326 - src/libAtoms/Sparse.f95 | 724 -- src/libAtoms/Spline.f95 | 463 -- src/libAtoms/Structures.f95 | 3499 ---------- src/libAtoms/System.f95 | 3779 ---------- src/libAtoms/Table.f95 | 2134 ------ src/libAtoms/Thermostat.f95 | 1929 ------ src/libAtoms/Topology.f95 | 3462 ---------- src/libAtoms/Units.f95 | 150 - src/libAtoms/angular_functions.f95 | 710 -- src/libAtoms/clusters.f95 | 4304 ------------ src/libAtoms/error.f95 | 425 -- src/libAtoms/f90wrap_stub.f95 | 8 - src/libAtoms/find_surface_atoms.f95 | 333 - src/libAtoms/frametools.f95 | 240 - src/libAtoms/gamma_functions.f95 | 244 - src/libAtoms/histogram1d.f95 | 1991 ------ src/libAtoms/histogram2d.f95 | 826 --- src/libAtoms/k_means_clustering.f95 | 245 - src/libAtoms/kind_module.f95 | 25 - src/libAtoms/libAtoms.f95 | 78 - src/libAtoms/libAtoms_misc_utils.f95 | 56 - src/libAtoms/libAtoms_utils_no_module.f95 | 409 -- src/libAtoms/linearalgebra.f95 | 7677 --------------------- src/libAtoms/lobpcg.f95 | 686 -- src/libAtoms/minimal_md.f95 | 102 - src/libAtoms/minimization.f95 | 6246 ----------------- src/libAtoms/nye_tensor.f95 | 310 - src/libAtoms/partition.f95 | 413 -- src/libAtoms/ringstat.f95 | 469 -- src/libAtoms/statistics.f95 | 83 - src/libAtoms/steinhardt_nelson_qw.f95 | 243 - src/libAtoms/task_manager.f95 | 358 - src/libAtoms/test_gamma.f95 | 76 - 54 files changed, 73303 deletions(-) delete mode 100644 src/libAtoms/Atoms.f95 delete mode 100644 src/libAtoms/Atoms_ll.f95 delete mode 100644 src/libAtoms/Atoms_types.f95 delete mode 100644 src/libAtoms/Barostat.f95 delete mode 100644 src/libAtoms/CInOutput.f95 delete mode 100644 src/libAtoms/Connection.f95 delete mode 100644 src/libAtoms/Constraints.f95 delete mode 100644 src/libAtoms/Dictionary.f95 delete mode 100644 src/libAtoms/DomainDecomposition.f95 delete mode 100644 src/libAtoms/DynamicalSystem.f95 delete mode 100644 src/libAtoms/ExtendableStr.f95 delete mode 100644 src/libAtoms/Group.f95 delete mode 100644 src/libAtoms/LinkedList.f95 delete mode 100644 src/libAtoms/MPI_context.f95 delete mode 100644 src/libAtoms/Matrix.f95 delete mode 100644 src/libAtoms/ParamReader.f95 delete mode 100644 src/libAtoms/PeriodicTable.f95 delete mode 100644 src/libAtoms/Quaternions.f95 delete mode 100644 src/libAtoms/RigidBody.f95 delete mode 100644 src/libAtoms/ScaLAPACK.f95 delete mode 100644 src/libAtoms/SocketTools.f95 delete mode 100644 src/libAtoms/Sparse.f95 delete mode 100644 src/libAtoms/Spline.f95 delete mode 100644 src/libAtoms/Structures.f95 delete mode 100644 src/libAtoms/System.f95 delete mode 100644 src/libAtoms/Table.f95 delete mode 100644 src/libAtoms/Thermostat.f95 delete mode 100644 src/libAtoms/Topology.f95 delete mode 100644 src/libAtoms/Units.f95 delete mode 100644 src/libAtoms/angular_functions.f95 delete mode 100644 src/libAtoms/clusters.f95 delete mode 100644 src/libAtoms/error.f95 delete mode 100644 src/libAtoms/f90wrap_stub.f95 delete mode 100644 src/libAtoms/find_surface_atoms.f95 delete mode 100644 src/libAtoms/frametools.f95 delete mode 100644 src/libAtoms/gamma_functions.f95 delete mode 100644 src/libAtoms/histogram1d.f95 delete mode 100644 src/libAtoms/histogram2d.f95 delete mode 100644 src/libAtoms/k_means_clustering.f95 delete mode 100644 src/libAtoms/kind_module.f95 delete mode 100644 src/libAtoms/libAtoms.f95 delete mode 100644 src/libAtoms/libAtoms_misc_utils.f95 delete mode 100644 src/libAtoms/libAtoms_utils_no_module.f95 delete mode 100644 src/libAtoms/linearalgebra.f95 delete mode 100644 src/libAtoms/lobpcg.f95 delete mode 100644 src/libAtoms/minimal_md.f95 delete mode 100644 src/libAtoms/minimization.f95 delete mode 100644 src/libAtoms/nye_tensor.f95 delete mode 100644 src/libAtoms/partition.f95 delete mode 100644 src/libAtoms/ringstat.f95 delete mode 100644 src/libAtoms/statistics.f95 delete mode 100644 src/libAtoms/steinhardt_nelson_qw.f95 delete mode 100644 src/libAtoms/task_manager.f95 delete mode 100644 src/libAtoms/test_gamma.f95 diff --git a/src/libAtoms/Atoms.f95 b/src/libAtoms/Atoms.f95 deleted file mode 100644 index 85c0d1b1e5..0000000000 --- a/src/libAtoms/Atoms.f95 +++ /dev/null @@ -1,3546 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Atoms module -!X -!% An atoms object contains atomic numbers, all dynamical variables -!% and connectivity information for all the atoms in the simulation cell. -!% It is initialised like this: -!%> call initialise(MyAtoms,N,lattice) -!% where 'N' is the number of atoms to allocate space for and 'lattice' is a $3\times3$ -!% matrix of lattice vectors given as column vectors, so that lattice(:,i) is the i-th lattice vector. -!% -!% Atoms also contains a Connection object, which stores distance information about -!% the atom neighbours after 'calc_connect' has been called. Rather than using a minimum -!% image convention, all neighbours are stored up to a radius of 'cutoff', including images. -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module atoms_module - - use error_module - use system_module - use units_module - use mpi_context_module - use linearalgebra_module - use extendable_str_module - use dictionary_module - use table_module - use paramreader_module - use periodictable_module - use Atoms_types_module - use Connection_module - use DomainDecomposition_module - use minimization_module - use Quaternions_module - - implicit none - private - public :: atoms, initialise, initialise_ptr, is_initialised, is_domain_decomposed, shallowcopy, finalise - public :: finalise_ptr, zero, assignment(=), deepcopy, set_cutoff_minimum, set_cutoff - public :: add_atoms, remove_atoms, get_param_value, set_param_value, has_property, remove_property - public :: print, set_lattice, select, cell_volume, map_into_cell, unskew_cell - public :: bcast, copy_properties, transform_basis, rotate, index_to_z_index, z_index_to_index - public :: calc_connect, calc_connect_hysteretic, is_min_image, set_comm_property, set_Zs, sort - public :: shuffle, n_neighbours, neighbour, centre_of_mass, atoms_copy_without_connect - public :: calc_dists, atoms_repoint, is_nearest_neighbour, is_nearest_neighbour_abs_index - public :: termination_bond_rescale, make_lattice, neighbour_index, cosine, cosine_neighbour, direction_cosines - public :: directionality, closest_atom, set_atoms, get_lattice_params, list_matching_prop - public :: coalesce_in_one_periodic_image, prop_names_string, parse_atom_mask, complement - public :: direction_cosines_min_image, difference, set_map_shift - public :: undo_pbc_jumps, undo_com_motion, calc_msd, fake_smooth_pos - - integer, parameter :: NOT_NEIGHBOUR = 0 !% Returned by 'Find_Neighbour' if unsuccessful - - logical :: printed_stack_warning = .false. !% OMIT - - real(dp), allocatable, target, private, save :: save_prev_pos(:,:), save_orig_pos(:,:), save_smooth_pos(:,:) - real(dp) :: save_smooth_lattice(3,3) - real(dp), allocatable, private, save :: save_orig_CoM(:) - - private :: ess_max_len - - private :: atoms_initialise - interface initialise - module procedure atoms_initialise - end interface initialise - - !% Initialise type(Atoms), pointer objects. Shallow copies of these will - !% survive even if the initial declaration goes out of scope. The object will - !% automatically deallocate upon calling finalise_ptr when the last shallow - !% copy goes out of scope - private :: atoms_initialise_ptr - interface initialise_ptr - module procedure atoms_initialise_ptr - endinterface initialise_ptr - - private :: atoms_is_initialised - interface is_initialised - module procedure atoms_is_initialised - end interface is_initialised - - private :: atoms_is_domain_decomposed - interface is_domain_decomposed - module procedure atoms_is_domain_decomposed - endinterface is_domain_decomposed - - private :: atoms_shallowcopy - interface shallowcopy - module procedure atoms_shallowcopy - end interface shallowcopy - - !% Free up the memory associated with one or more objects. - private :: atoms_finalise,atoms_finalise_multi - interface finalise - module procedure atoms_finalise, atoms_finalise_multi - end interface finalise - - !% Finalise type(Atoms), pointer objects. Shallow copies of these will - !% The object will when ref_count == 0. - private :: atoms_finalise_ptr - interface finalise_ptr - module procedure atoms_finalise_ptr - endinterface finalise_ptr - - private :: atoms_zero - interface zero - module procedure atoms_zero - end interface - - !% Overloaded assigment operators for Atoms objects. - private :: atoms_assignment - interface assignment(=) - module procedure atoms_assignment - end interface assignment(=) - interface deepcopy - module procedure atoms_assignment - endinterface - - private :: atoms_set_atoms, atoms_set_atoms_singlez - - !% Set atomic numbers (in the 'z' integer property), species names - !% (in 'species' string property) and optionally masses (if 'mass' - !% property exists in the Atoms object). - interface set_atoms - module procedure atoms_set_atoms, atoms_set_atoms_singlez - end interface - - !% increase cutoff - private :: atoms_set_cutoff_minimum - interface set_cutoff_minimum - module procedure atoms_set_cutoff_minimum - end interface - - !% set a uniform cutoff - private :: atoms_set_cutoff - interface set_cutoff - module procedure atoms_set_cutoff - end interface - - !% Add one or more atoms to an Atoms object. - !% To add a single atom, 'pos' should be an array of size 3 and 'z a - !% single integer. To add multiple atoms either arrays of length - !% 'n_new' should be passed, or another Atoms from which to copy data - !% should be given as the 'from' argument. - private :: add_atom_single, add_atom_multiple, atoms_join - interface add_atoms - module procedure add_atom_single, add_atom_multiple, atoms_join - end interface add_atoms - - !% Remove one or more atoms from an Atoms object. - private :: remove_atom_single, remove_atom_multiple - interface remove_atoms - module procedure remove_atom_single, remove_atom_multiple - module procedure remove_atom_multiple_mask - end interface remove_atoms - - !% get a (per-configuration) value from the atoms%params dictionary - private :: atoms_get_param_value_int, atoms_get_param_value_int_a - private :: atoms_get_param_value_real, atoms_get_param_value_real_a, atoms_get_param_value_real_a2 - private :: atoms_get_param_value_str, atoms_get_param_value_es - private :: atoms_get_param_value_logical - interface get_param_value - module procedure atoms_get_param_value_int, atoms_get_param_value_int_a - module procedure atoms_get_param_value_real, atoms_get_param_value_real_a, atoms_get_param_value_real_a2 - module procedure atoms_get_param_value_str, atoms_get_param_value_es - module procedure atoms_get_param_value_logical - end interface get_param_value - - !% set a (per-configuration) value from the atoms%params dictionary - private :: atoms_set_param_value_int, atoms_set_param_value_int_a - private :: atoms_set_param_value_real, atoms_set_param_value_real_a, atoms_set_param_value_real_a2 - private :: atoms_set_param_value_str - private :: atoms_set_param_value_logical - interface set_param_value - module procedure atoms_set_param_value_int, atoms_set_param_value_int_a - module procedure atoms_set_param_value_real, atoms_set_param_value_real_a, atoms_set_param_value_real_a2 - module procedure atoms_set_param_value_str - module procedure atoms_set_param_value_logical - end interface set_param_value - - !% Convenience function to test if a property is present. No checking - !% of property type is done. Property names are case-insensitive. - private :: atoms_has_property - interface has_property - module procedure atoms_has_property - end interface - - !% Remove a property from this atoms object - private :: atoms_remove_property - interface remove_property - module procedure atoms_remove_property - end interface - - !% Print a verbose textual description of an Atoms object to the default logger or to - !% a specificied Inoutput object. - private :: atoms_print - interface print - module procedure atoms_print - end interface print - - !% set the lattice of an atoms object - please use this, rather than setting atoms%lattice - !% directly, because it also set up reciprocal lattice and orthorhombic/periodic logical flags - private :: atoms_set_lattice - interface set_lattice - module procedure atoms_set_lattice - end interface set_lattice - - !% Select a subset of the atoms in an atoms object, either using a logical - !% mask array or a Table, in which case the first 'int' column is taken to - !% be a list of the atoms that should be retained. - private :: atoms_select - interface select - module procedure atoms_select - end interface select - - !% calculate volume of unit cell - private :: atoms_cell_volume - interface cell_volume - module procedure atoms_cell_volume - end interface - - private :: atoms_map_into_cell - !% Map atomic positions into the unit cell so that lattice - !% coordinates satisfy $-0.5 \le t_x,t_y,t_z < 0.5$ - interface map_into_cell - module procedure atoms_map_into_cell - end interface - - private :: atoms_unskew_cell - !% Unskew lattice so the cosines of the lattice angles fall between - !% $-0.5$ and $0.5$ - interface unskew_cell - module procedure atoms_unskew_cell - end interface - - private :: atoms_bcast - interface bcast - module procedure atoms_bcast - end interface - - private :: atoms_copy_properties - interface copy_properties - module procedure atoms_copy_properties - endinterface copy_properties - - private :: atoms_transform_basis - interface transform_basis - module procedure atoms_transform_basis - end interface transform_basis - - private :: atoms_rotate - interface rotate - module procedure atoms_rotate - end interface rotate - - private :: atoms_index_to_z_index - interface index_to_z_index - module procedure atoms_index_to_z_index - end interface index_to_z_index - - private :: atoms_z_index_to_index - interface z_index_to_index - module procedure atoms_z_index_to_index - end interface z_index_to_index - - private :: atoms_calc_connect - interface calc_connect - module procedure atoms_calc_connect - endinterface - - private :: atoms_calc_dists - interface calc_dists - module procedure atoms_calc_dists - end interface calc_dists - - private :: atoms_calc_connect_hysteretic - interface calc_connect_hysteretic - module procedure atoms_calc_connect_hysteretic - endinterface - - private :: atoms_is_min_image - interface is_min_image - module procedure atoms_is_min_image - endinterface - - private :: atoms_set_comm_property - interface set_comm_property - module procedure atoms_set_comm_property - endinterface set_comm_property - - private :: atoms_set_Zs - interface set_Zs - module procedure atoms_set_Zs - endinterface - - private :: atoms_sort_by_rindex - interface sort - module procedure atoms_sort, atoms_sort_by_rindex - endinterface - - private :: atoms_shuffle - interface shuffle - module procedure atoms_shuffle - endinterface - - !% Neighbour list stuff - interface n_neighbours - module procedure atoms_n_neighbours - endinterface - - !% Neighbour list stuff - interface neighbour_index - module procedure atoms_neighbour_index - endinterface - - interface neighbour - module procedure atoms_neighbour - endinterface - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Initialisation and Finalisation - ! - ! N : number of atoms - ! lattice: 3x3 matrix of lattice vectors as column vectors - ! data: optional initial values for data table - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Initialise an Atoms object to store 'N' atoms and specify the initial lattice. - subroutine atoms_initialise(this,N,lattice,& - properties,params,fixed_size,Nbuffer,error) - - type(Atoms), intent(inout) :: this - integer, intent(in) :: N - real(dp), dimension(3,3), intent(in) :: lattice - type(Dictionary), optional, intent(in) :: properties, params - logical, optional, intent(in) :: fixed_size - integer, optional, intent(in) :: Nbuffer - integer, optional, intent(out) :: error - - integer :: stack_size, stack_size_err, i, type - - INIT_ERROR(error) - !call atoms_finalise(this) - - if (present(params)) then - this%params = params ! deep copy - else - call initialise(this%params) - end if - - call initialise(this%domain, error=error) - PASS_ERROR(error) - - this%N = N - this%Ndomain = N - this%Nbuffer = N - - if (present(Nbuffer)) this%Nbuffer = Nbuffer - - this%fixed_size = optional_default(.false., fixed_size) - - if (present(properties)) then - ! check types and sizes of properties passed in - do i=1,properties%N - type = properties%entries(i)%type - if (type == T_INTEGER_A .or. type == T_REAL_A .or. type == T_LOGICAL_A) then - if (properties%entries(i)%len /= this%Nbuffer) then - RAISE_ERROR('atoms_initialise: bad array size for array key='//string(properties%keys(i))//' size('//properties%entries(i)%len//') != this%Nbuffer('//this%Nbuffer//')', error) - end if - else if (type == T_INTEGER_A2 .or. type == T_REAL_A2 .or. type == T_CHAR_A) then - if (properties%entries(i)%len2(2) /= this%Nbuffer) then - RAISE_ERROR('atoms_initialise: bad array size for array key='//properties%keys(i)//' shape='//properties%entries(i)%len2, error) - end if - else - RAISE_ERROR('atoms_initialise: bad property type='//type//' in properties argument', error) - end if - end do - - this%properties = properties ! deep copy of data from properties argument - else - ! By default, we just add properties for Z, species name and position - call initialise(this%properties) - - call add_property(this, 'Z', 0, error=error) - PASS_ERROR(error) - call add_property(this, 'pos', 0.0_dp, n_cols=3, error=error) - PASS_ERROR(error) - call add_property(this, 'species', repeat(' ', TABLE_STRING_LENGTH), & - error=error) - PASS_ERROR(error) - end if - - call set_comm_property(this, 'Z', & - comm_atoms=.true., comm_ghosts=.true.) - call set_comm_property(this, 'pos', & - comm_atoms=.true., comm_ghosts=.true.) - call set_comm_property(this, 'species', & - comm_atoms=.true.) - - call atoms_repoint(this) - - stack_size = 3*N*8/1024 - if (stack_size > 4000 .and. .not. printed_stack_warning) then - call print('Atoms_Initialise: Stack size must be at least '//stack_size//& - ' kb, or we get seg faults when functions return arrays.') - printed_stack_warning = .true. - call print('Atoms_Initialise: trying to increase stack limit') - stack_size = int(stack_size/1024)*1024 - stack_size_err = increase_stack(stack_size) - if (stack_size_err /= 0) then - call print("Atoms_Initialise: error calling increase_stack err = "// stack_size_err) - endif - end if - - call atoms_set_lattice(this, lattice, .false.) - - this%ref_count = 1 - - call print("atoms_initialise: Initialised, " // & - "ref_count = " // this%ref_count, PRINT_ANALYSIS) - - end subroutine atoms_initialise - - - subroutine atoms_initialise_ptr(this,N,lattice,& - properties,params,fixed_size,Nbuffer,error) - type(Atoms), pointer :: this - integer, intent(in) :: N - real(dp), dimension(3,3), intent(in) :: lattice - type(Dictionary), optional, intent(in) :: properties, params - logical, optional, intent(in) :: fixed_size - integer, optional, intent(in) :: Nbuffer - integer, optional, intent(out) :: error - - ! --- - - INIT_ERROR(error) - - if (associated(this)) then - this%own_this = .false. - else - allocate(this) - this%own_this = .true. - endif - - call initialise(this, N, lattice, properties, params, fixed_size, & - Nbuffer, error) - PASS_ERROR(error) - - endsubroutine atoms_initialise_ptr - - - !% Is this atoms object initialised? - logical function atoms_is_initialised(this) - type(Atoms), intent(in) :: this - atoms_is_initialised = this%ref_count > 0 - end function atoms_is_initialised - - - !% Is this atoms object domain decomposed? - logical function atoms_is_domain_decomposed(this) - type(Atoms), intent(in) :: this - atoms_is_domain_decomposed = this%domain%decomposed - end function atoms_is_domain_decomposed - - - !% Shallow copy of this Atoms object - subroutine atoms_shallowcopy(this, from) - !NB gfortran 4.3.4 seg faults if this is intent(out) - !NB type(Atoms), pointer, intent(out) :: this - type(Atoms), pointer :: this - !NB - type(Atoms), target :: from - - ! --- - - this => from - this%ref_count = this%ref_count + 1 - - call print("atoms_shallowcopy: Created shallow copy, " // & - "ref_count = " // this%ref_count, PRINT_ANALYSIS) - - end subroutine atoms_shallowcopy - - - subroutine atoms_finalise(this) - type(Atoms), intent(inout) :: this - - this%ref_count = this%ref_count - 1 - ! Note: this has to be == 0, rather than <= 0. Otherwise it will fail if - ! finalise is called more than once - if (this%ref_count == 0) then - - call print("atoms_finalise: ref_count = 0, finalising", PRINT_ANALYSIS) - - call finalise(this%domain) - - call finalise(this%properties) - call finalise(this%params) - - ! Nullify pointers - nullify(this%Z, this%travel, this%mass) - nullify(this%move_mask, this%thermostat_region, this%damp_mask) - nullify(this%pos, this%velo, this%acc, this%avgpos, this%oldpos, this%avg_ke) - - call finalise(this%connect) - call finalise(this%hysteretic_connect) - - this%N = 0 - this%Ndomain = 0 - this%Nbuffer = 0 - - else - if (this%ref_count > 0) then - call print("atoms_finalise: Not yet finalising, " // & - "ref_count = " // this%ref_count, PRINT_ANALYSIS) - endif - endif - - call print("atoms_finalise: ref_count = " // this%ref_count, PRINT_ANALYSIS) - - end subroutine atoms_finalise - - - subroutine atoms_finalise_ptr(this) - type(Atoms), pointer :: this - - ! --- - - call finalise(this) - if (this%own_this .and. this%ref_count == 0) then - deallocate(this) - this => NULL() - endif - - endsubroutine atoms_finalise_ptr - - !Quick multiple finalisations - subroutine atoms_finalise_multi(at1,at2,at3,at4,at5,at6,at7,at8,at9,at10) - type(Atoms), intent(inout) :: at1,at2 - type(Atoms), optional, intent(inout) :: at3,at4,at5,at6,at7,at8,at9,at10 - call atoms_finalise(at1) - call atoms_finalise(at2) - if (present(at3)) call atoms_finalise(at3) - if (present(at4)) call atoms_finalise(at4) - if (present(at5)) call atoms_finalise(at5) - if (present(at6)) call atoms_finalise(at6) - if (present(at7)) call atoms_finalise(at7) - if (present(at8)) call atoms_finalise(at8) - if (present(at9)) call atoms_finalise(at9) - if (present(at10)) call atoms_finalise(at10) - end subroutine atoms_finalise_multi - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Overloaded Assignment - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_assignment(to,from) - - type(Atoms), intent(inout) :: to - type(Atoms), intent(in) :: from - - ! We do not fail if *from* is unitialised, since overloaded operator - ! routines are outside scope of error handling mechanism. - if(.not. is_initialised(from)) then - call finalise(to) -! to%ref_count = 0 - return - end if - - call atoms_initialise(to, from%N, from%lattice, from%properties, from%params, from%fixed_size, from%Nbuffer) - - to%cutoff = from%cutoff - to%cutoff_skin = from%cutoff_skin - to%nneightol = from%nneightol - to%is_orthorhombic = from%is_orthorhombic - to%is_periodic = from%is_periodic - to%fixed_size = from%fixed_size - - call deepcopy(to%connect, from%connect) - call deepcopy(to%hysteretic_connect, from%hysteretic_connect) - call deepcopy(to%domain, from%domain) - - end subroutine atoms_assignment - - - pure function ess_max_len(ess) - type(extendable_str), intent(in) :: ess(:) - integer :: ess_max_len - - integer :: i - - ess_max_len = 0 - do i=1, size(ess) - if (ess(i)%len > ess_max_len) ess_max_len = ess(i)%len - end do - end function ess_max_len - - !% Make a copy of the atoms object 'from' without including - !% connectivity information. Useful for saving the state of a - !% dynamical simulation without incurring too great a memory - !% cost. - subroutine atoms_copy_without_connect(to, from, properties, properties_array, error) - - type(Atoms), intent(inout) :: to - type(Atoms), intent(in) :: from - character(len=*), optional, intent(in) :: properties - character(len=*), optional, intent(in) :: properties_array(:) - integer, intent(out), optional :: error - character(len=ess_max_len(from%properties%keys)) :: tmp_properties_array(from%properties%n) - integer n_properties - - INIT_ERROR(error) - ASSERT(is_initialised(from), "atoms_copy_without_connect: 'from' object is not initialised", error) - - to%N = from%N - to%Nbuffer = from%Nbuffer - to%Ndomain = from%Ndomain - call set_lattice(to, from%lattice, .false.) - - if (present(properties) .or. present(properties_array)) then - if (present(properties_array)) then - call subset(from%properties, properties_array, to%properties, error=error) - PASS_ERROR(error) - else - call parse_string(properties, ':', tmp_properties_array, n_properties, error=error) - PASS_ERROR(error) - call subset(from%properties, tmp_properties_array(1:n_properties), to%properties, error=error) - PASS_ERROR(error) - end if - else - call deepcopy(to%properties, from%properties, error=error) - PASS_ERROR(error) - endif - to%params = from%params - to%fixed_size = from%fixed_size - to%cutoff = from%cutoff - to%cutoff_skin = from%cutoff_skin - to%nneightol = from%nneightol - to%is_orthorhombic = from%is_orthorhombic - to%is_periodic = from%is_periodic - to%fixed_size = from%fixed_size - - call deepcopy(to%domain, from%domain) - - call atoms_repoint(to) - to%ref_count = 1 - - end subroutine atoms_copy_without_connect - - subroutine atoms_select(to, from, mask, list, orig_index, error) - type(Atoms), intent(inout) :: to - type(Atoms), intent(in) :: from - logical, intent(in), optional :: mask(:) - integer, intent(in), optional, target :: list(:) - logical, optional, intent(in) :: orig_index - integer, intent(out), optional :: error - - integer :: i, n_list - integer, allocatable, dimension(:), target :: my_list - integer, pointer, dimension(:) :: orig_index_ptr, use_list - logical :: do_orig_index - - INIT_ERROR(error) - - do_orig_index = optional_default(.true., orig_index) - - if ((.not. present(list) .and. .not. present(mask)) .or. (present(list) .and. present(mask))) then - RAISE_ERROR('atoms_select: either list or mask must be present (but not both)', error) - end if - - if (present(mask)) then - if (size(mask) /= from%N) then - RAISE_ERROR("atoms_select: mismatched sizes of from " // from%N // " and mask " // size(mask), error) - end if - call atoms_initialise(to, count(mask), from%lattice) - else - call atoms_initialise(to, size(list), from%lattice) - end if - - call finalise(to%params) - to%params = from%params - to%fixed_size = from%fixed_size - to%cutoff = from%cutoff - to%cutoff_skin = from%cutoff_skin - to%nneightol = from%nneightol - - if(present(mask)) then - allocate(my_list(count(mask))) - ! build up a list - N_list = 1 - do i=1, from%N - if (mask(i)) then - my_list(n_list) = i - n_list = n_list + 1 - endif - end do - use_list => my_list - else - use_list => list - end if - - do i=1,from%properties%N - select case (from%properties%entries(i)%type) - - case(T_INTEGER_A) - call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%i_a(use_list)) - - case(T_REAL_A) - call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%r_a(use_list)) - - case(T_LOGICAL_A) - call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%l_a(use_list)) - - case(T_INTEGER_A2) - call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%i_a2(:,use_list)) - - case(T_REAL_A2) - call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%r_a2(:,use_list)) - - case(T_CHAR_A) - call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%s_a(:,use_list)) - - case default - RAISE_ERROR('atoms_select: bad property type '//from%properties%entries(i)%type//' key='//from%properties%keys(i), error) - - end select - end do - call atoms_repoint(to) - - if (do_orig_index) then - call add_property(to, 'orig_index', 0, ptr=orig_index_ptr, error=error) - PASS_ERROR(error) - orig_index_ptr(:) = use_list(:) - end if - if (allocated(my_list)) deallocate(my_list) - - call atoms_repoint(to) - end subroutine atoms_select - - subroutine atoms_remove_property(this, name, error) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: name - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if (.not. has_property(this, name)) then - RAISE_ERROR('atoms_remove_property: no such property "'//trim(name)//'" exists', error) - end if - call remove_value(this%properties, name) - - end subroutine atoms_remove_property - - function atoms_has_property(this, name) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - logical :: atoms_has_property - - atoms_has_property = has_key(this%properties, name) - - end function atoms_has_property - - subroutine atoms_set_param_value_int(this, key, value) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value - - call set_value(this%params, key, value) - end subroutine atoms_set_param_value_int - subroutine atoms_set_param_value_int_a(this, key, value) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value(:) - - call set_value(this%params, key, value) - end subroutine atoms_set_param_value_int_a - subroutine atoms_set_param_value_real(this, key, value) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value - - call set_value(this%params, key, value) - end subroutine atoms_set_param_value_real - subroutine atoms_set_param_value_real_a(this, key, value) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value(:) - - call set_value(this%params, key, value) - end subroutine atoms_set_param_value_real_a - subroutine atoms_set_param_value_real_a2(this, key, value) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value(:,:) - - call set_value(this%params, key, value) - end subroutine atoms_set_param_value_real_a2 - subroutine atoms_set_param_value_logical(this, key, value) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: key - logical, intent(in) :: value - - call set_value(this%params, key, value) - end subroutine atoms_set_param_value_logical - - subroutine atoms_set_param_value_str(this, key, value) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - - call set_value(this%params, key, value) - end subroutine atoms_set_param_value_str - - subroutine atoms_get_param_value_int(this, key, value, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: key - integer, intent(out) :: value - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. get_value(this%params, key, value)) then - RAISE_ERROR("atoms_get_param_value failed to get int value for key='"//trim(key)//"' from this%params", error) - endif - end subroutine atoms_get_param_value_int - subroutine atoms_get_param_value_int_a(this, key, value, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: key - integer, intent(out) :: value(:) - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. get_value(this%params, key, value)) then - RAISE_ERROR("atoms_get_param_value failed to get int array value for key='"//trim(key)//"' from this%params", error) - endif - end subroutine atoms_get_param_value_int_a - subroutine atoms_get_param_value_real(this, key, value, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: key - real(dp), intent(out) :: value - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. get_value(this%params, key, value)) then - call verbosity_push(PRINT_ANALYSIS) - call print(this) - RAISE_ERROR("atoms_get_param_value failed to get real value for key='"//trim(key)//"' from this%params", error) - endif - end subroutine atoms_get_param_value_real - subroutine atoms_get_param_value_real_a(this, key, value, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: key - real(dp), intent(out) :: value(:) - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. get_value(this%params, key, value)) then - RAISE_ERROR("atoms_get_param_value failed to get real array value for key='"//trim(key)//"' from this%params", error) - endif - end subroutine atoms_get_param_value_real_a - subroutine atoms_get_param_value_real_a2(this, key, value, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: key - real(dp), intent(out) :: value(:,:) - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. get_value(this%params, key, value)) then - RAISE_ERROR("atoms_get_param_value failed to get real array value for key='"//trim(key)//"' from this%params", error) - endif - end subroutine atoms_get_param_value_real_a2 - subroutine atoms_get_param_value_str(this, key, value, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: key - character(STRING_LENGTH), intent(out) :: value - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. get_value(this%params, key, value)) then - RAISE_ERROR("atoms_get_param_value failed to get str value for key='"//trim(key)//"' from this%params", error) - endif - end subroutine atoms_get_param_value_str - subroutine atoms_get_param_value_es(this, key, value, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: key - type(Extendable_Str), intent(inout) :: value - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. get_value(this%params, key, value)) then - RAISE_ERROR("atoms_get_param_value failed to get es value for key='"//trim(key)//"' from this%params", error) - endif - end subroutine atoms_get_param_value_es - subroutine atoms_get_param_value_logical(this, key, value, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: key - logical, intent(out) :: value - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. get_value(this%params, key, value)) then - RAISE_ERROR("atoms_get_param_value failed to get logical value for key='"//trim(key)//"' from this%params", error) - endif - end subroutine atoms_get_param_value_logical - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Set the cutoff to at least the requested value - !% Optionally set 'cutoff_skin' at the same time. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_set_cutoff_minimum(this, cutoff, cutoff_skin) - type(Atoms), intent(inout) :: this - real(dp), intent(in) :: cutoff - real(dp), optional, intent(in) :: cutoff_skin - - this%cutoff = max(this%cutoff, cutoff) - this%cutoff_skin = max(this%cutoff_skin, cutoff_skin) - - end subroutine atoms_set_cutoff_minimum - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Specify a uniform neighbour cutoff throughout the system. - !% Optionally set 'cutoff_skin' at the same time. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_set_cutoff(this, cutoff, cutoff_skin) - type(Atoms), intent(inout) :: this - real(dp), intent(in) :: cutoff - real(dp), optional, intent(in) :: cutoff_skin - - this%cutoff = cutoff - if (present(cutoff_skin)) then - this%cutoff_skin = cutoff_skin - end if - - end subroutine atoms_set_cutoff - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Zero data in an Atoms structure --- - !% this doesn\'t finalise it or change it\'s size. We zero 'this%pos', - !% 'this%Z' and 'this%species'. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_zero(this,indices) - - type(Atoms), intent(inout) :: this - integer, optional, intent(in) :: indices !% Optionally only zero the specified indices. - - if(present(indices)) then - this%pos(:,indices) = 0.0_dp - this%Z(indices) = 0 - this%species(:,indices) = ' ' - else - this%pos = 0.0_dp - this%Z = 0 - this%species = ' ' - end if - - end subroutine atoms_zero - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Change the lattice vectors, keeping the inverse lattice vectors - !% up to date. Optionally map the existing atoms into the new cell - !% and recalculate connectivity. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_set_lattice(this,new_lattice,scale_positions,remap,reconnect) - - type(Atoms), intent(inout) :: this - real(dp), dimension(3,3), intent(in) :: new_lattice - logical, intent(in) :: scale_positions - logical, optional, intent(in) :: remap, reconnect - real(dp), dimension(:,:), allocatable :: frac - real(dp) :: zeros(3,3), test_lattice(3,3), x, y - - ! only do the allocation if needed - if(scale_positions) then - allocate(frac(3,this%N)) - frac = matmul(this%g,this%pos) - end if - - this%lattice = new_lattice - - if(scale_positions) then - this%pos = matmul(this%lattice,frac) - deallocate(frac) - end if - - call matrix3x3_inverse(this%lattice,this%g) - - if (present(reconnect)) then - if (reconnect) then - call calc_connect(this) - return - end if - end if - - if (present(remap)) then - if (remap) call set_map_shift(this) - end if - - zeros(:,:) = 0.0_dp - test_lattice = this%lattice - test_lattice(1,1) = 0.0_dp ! zero diagonal elements - test_lattice(2,2) = 0.0_dp - test_lattice(3,3) = 0.0_dp - this%is_orthorhombic = test_lattice .feq. zeros - - !write (*,*) x, y, (abs(x-y) <= NUMERICAL_ZERO * (abs(x)+abs(y))/2.0_dp) .or. (abs(x-y) <= NUMERICAL_ZERO), x .feq. y, TINY(1.0_dp) - - test_lattice = 0.0_dp - test_lattice(:,1) = this%lattice(:,1) - this%is_periodic(1) = test_lattice .fne. zeros - - test_lattice = 0.0_dp - test_lattice(:,2) = this%lattice(:,2) - this%is_periodic(2) = test_lattice .fne. zeros - - test_lattice = 0.0_dp - test_lattice(:,3) = this%lattice(:,3) - this%is_periodic(3) = test_lattice .fne. zeros - - end subroutine atoms_set_lattice - - subroutine atoms_set_atoms_singlez(this, Z) - type(Atoms), intent(inout) :: this - integer, intent(in) :: Z - integer, allocatable, dimension(:) :: Zarray - - allocate(Zarray(this%N)) - Zarray = Z - call atoms_set_atoms(this, Zarray) - deallocate(Zarray) - end subroutine atoms_set_atoms_singlez - - !% Set atomic numbers and optionally masses (if mass property is present) - !% If 'mass' is not specified then 'ElementMass(Z)' is used. - subroutine atoms_set_atoms(this, Z, mass) - type(Atoms), intent(inout) :: this - integer, dimension(:), intent(in) :: Z - real(dp), optional, dimension(:), intent(in) :: mass - - integer i - - this%Z = Z - if (has_property(this, 'mass')) then - this%mass = ElementMass(Z) - ! Optionally override with user specified masses - if (present(mass)) this%mass = mass - end if - if (has_property(this, 'species')) then - do i=1,this%N - this%species(:,i) = ' ' - this%species(1:len(ElementName(Z(i))),i) = s2a(ElementName(Z(i))) - end do - end if - - end subroutine atoms_set_atoms - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Simple query functions - ! - !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx - - !% Return the number of neighbour that atom 'i' has. If the - !% optional arguments max_dist or max_factor are present then only - !% neighbours closer than this cutoff are included. Do not use - !% 'max_dist' when iterating only over neighbours within a certain - !% distance; instead, iterate over the full list and discard - !% unnecessary neighbours in 'atoms_neighbour'. - !% - !% 'alt_connect' - !% can be set to another Connection object to use alternative - !% connectivity information, for example 'hysteretic_connect'. - function atoms_n_neighbours(this, i, max_dist, max_factor, alt_connect, error) result(n) - type(Atoms), intent(in) :: this - integer, intent(in) :: i - real(dp), optional, intent(in) :: max_dist, max_factor - type(Connection), optional, intent(in), target :: alt_connect - integer, intent(out), optional :: error - integer :: n - - INIT_ERROR(error) - if (present(alt_connect)) then - n = n_neighbours(alt_connect, this, i, max_dist, max_factor, error) - PASS_ERROR(error) - else - n = n_neighbours(this%connect, this, i, max_dist, max_factor, error) - PASS_ERROR(error) - endif - - end function atoms_n_neighbours - - function atoms_neighbour_index(this, i, n, index, t, is_j, alt_connect, error) result(j) - type(Atoms), intent(in) :: this - integer, intent(in) :: i, n - integer, intent(out) :: index - type(Table), pointer, intent(out) :: t - logical, intent(out) :: is_j - type(Connection), optional, intent(in), target :: alt_connect - integer, intent(out), optional :: error - integer :: j - - INIT_ERROR(error) - if (present(alt_connect)) then - j = neighbour_index(alt_connect, & - i, n, index, t, is_j, error) - PASS_ERROR(error) - else - j = neighbour_index(this%connect, & - i, n, index, t, is_j, error) - PASS_ERROR(error) - endif - - end function atoms_neighbour_index - - function atoms_neighbour_minimal(this, i, n, shift, index, alt_connect) result(j) - type(Atoms), intent(in), target :: this - integer ::i, j, n - integer, intent(out) :: shift(3) - integer, intent(out) :: index - type(Connection), optional, intent(in), target :: alt_connect - - if (present(alt_connect)) then - j = neighbour_minimal(alt_connect, i, n, shift, index) - else - j = neighbour_minimal(this%connect, i, n, shift, index) - endif - - end function atoms_neighbour_minimal - - !% Return the index of the $n^\mathrm{th}$ neighbour of atom $i$. Together with the - !% previous function, this facilites a loop over the neighbours of atom $i$. Optionally, we - !% return other geometric information, such as distance, direction cosines and difference vector, - !% and also a direct index into the neighbour tables. If $i <= j$, this is an index into 'neighbour1(i)'; - !% if $i > j$, it is an index into 'neighbour1(j)'. - !% - !%> do n = 1,atoms_n_neighbours(at, i) - !%> j = atoms_neighbour(at, i, n, distance, diff, cosines, shift, index) - !%> - !%> ... - !%> end do - !% - !% If distance $>$ 'max_dist', return 0, and do not waste time calculating other quantities. - !% This enables efficient iteration over the subset of neighbours located within the radius - !% 'max_dist'. However, as the neighbour list is not sorted, - !% you must first iterate over the whole list (i.e. do *not* use the - !% 'max_dist' parameter in 'atoms_n_neighbours'), then skip those - !% neighbours where this function returns 0. - !% - !% 'alt_connect' has the same meaning as in 'n_neighbours'. - !% - !% Here's a typical loop construct in Python. Note how `r` and `u` - !% are created before the loop: arguments which are both optional - !% and ``intent(out)`` in Fortran are converted to ``intent(in,out)`` for quippy. :: - !%> - !%> r = farray(0.0) - !%> u = fzeros(3) - !%> for i in frange(at.n): - !%> for n in frange(at.n_neighbours(i)): - !%> j = at.neighbour(i, n, distance=r, diff=u) - function atoms_neighbour(this, i, n, distance, diff, cosines, shift, index, max_dist, jn, alt_connect, error) result(j) - type(Atoms), intent(in) :: this - integer ::i, j, n - real(dp), optional, intent(out) :: distance - real(dp), dimension(3), optional, intent(out) :: diff - real(dp), optional, intent(out) :: cosines(3) - integer, optional, intent(out) :: shift(3) - integer, optional, intent(out) :: index - real(dp), optional, intent(in) :: max_dist - integer, optional, intent(out) :: jn - type(Connection), optional, intent(in), target :: alt_connect - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (present(alt_connect)) then - j = neighbour(alt_connect, this, & - i, n, distance, diff, cosines, shift, index, max_dist, jn, error) - PASS_ERROR(error) - else - j = neighbour(this%connect, this, & - i, n, distance, diff, cosines, shift, index, max_dist, jn, error) - PASS_ERROR(error) - endif - - end function atoms_neighbour - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Adding and Removing atoms: adding/removing single or multiple atoms - ! For the atoms variable in Dynamical System, this should be called - ! shift there to avoid inconsistencies with DS's data - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine add_atom_single(this, pos, Z, mass, travel, error) - - type(Atoms), intent(inout) :: this - real(dp), intent(in), dimension(3) :: pos - integer, intent(in) :: Z - real(dp), optional, intent(in) :: mass - integer, optional, intent(in), dimension(3) :: travel - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(present(travel)) then - if(present(mass)) then - call add_atom_multiple(this, pos=reshape(pos, (/3,1/)), Z=(/Z/), mass=(/mass/), travel=reshape(travel, (/3,1/)), error=error) - else - call add_atom_multiple(this, pos=reshape(pos, (/3,1/)), Z=(/Z/), travel=reshape(travel, (/3,1/)), error=error) - end if - else - if(present(mass)) then - call add_atom_multiple(this, pos=reshape(pos, (/3,1/)), Z=(/Z/), mass=(/mass/), error=error) - else - call add_atom_multiple(this, pos=reshape(pos, (/3,1/)), Z=(/Z/), error=error) - end if - end if - PASS_ERROR(error) - - end subroutine add_atom_single - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine add_atom_multiple(this, pos, Z, mass, velo, acc, travel, error) - - type(Atoms), intent(inout) :: this - real(dp), intent(in), dimension(:,:) :: pos - integer, intent(in), dimension(:) :: Z - real(dp), optional, intent(in), dimension(:) :: mass - integer, optional, intent(in), dimension(:,:) :: travel - real(dp),optional, intent(in), dimension(:,:) :: velo, acc - integer, intent(out), optional :: error - - integer :: oldN,i - integer, allocatable, dimension(:) :: tmp_int - integer, allocatable, dimension(:,:) :: tmp_int2 - real(dp), allocatable, dimension(:) :: tmp_real - real(dp), allocatable, dimension(:,:) :: tmp_real2 - logical, allocatable, dimension(:) :: tmp_logical - character, allocatable, dimension(:,:) :: tmp_char - - logical :: has_mass, has_velo, has_acc, has_travel - - INIT_ERROR(error) - - if (this%fixed_size) then - RAISE_ERROR("add_atom_multiple: Atoms object cannot be resized (this%fixed_size = .true.)", error) - end if - - oldN = this%N - this%N = this%N + size(Z) - this%Ndomain = this%N - - !Check the sizes of the input arrays for consistency - call check_size('Pos',pos,(/3,size(Z)/),'Add_Atom',error) - PASS_ERROR(error) - - ! If we pass a NULL() pointer as an optional argument, the argument - ! shows up as present but has size == 0. - - has_mass = .false. - has_travel = .false. - has_velo = .false. - has_acc = .false. - - if (present(mass)) then - if (size(mass) > 0) then - has_mass = .true. - call check_size('Mass',mass,size(Z), 'Add_Atom', error) - PASS_ERROR(error) - endif - end if - - if (present(travel)) then - if (size(travel, 1) > 0 .and. size(travel, 2) > 0) then - has_travel = .true. - call check_size('Travel',travel,(/3,size(Z)/),'Add_Atom', error) - PASS_ERROR(error) - endif - end if - - if (present(velo)) then - if (size(velo, 1) > 0 .and. size(velo, 2) > 0) then - has_velo = .true. - call check_size('Velo', velo, (/3,size(Z)/), 'Add_Atom', error) - PASS_ERROR(error) - endif - end if - - if (present(acc)) then - if (size(acc, 1) > 0 .and. size(acc, 2) > 0) then - has_acc = .true. - call check_size('Acc', acc, (/3,size(Z)/), 'Add_Atom', error) - PASS_ERROR(error) - endif - end if - - ! Only resize if the actual number of particles is now larger than the - ! buffer size. - if (this%N > this%Nbuffer) then - - ! Resize property data arrays, copying old data. - ! this will break any existing pointers so we call atoms_repoint() immediately after - ! (note that user-held pointers will stay broken, there is no way to fix this - ! since Fortran does not allow pointer-to-pointer types) - do i=1,this%properties%N - select case (this%properties%entries(i)%type) - - case(T_INTEGER_A) - allocate(tmp_int(this%n)) - tmp_int(1:oldN) = this%properties%entries(i)%i_a - tmp_int(oldn+1:this%n) = 0 - call set_value(this%properties, string(this%properties%keys(i)), tmp_int) - deallocate(tmp_int) - - case(T_REAL_A) - allocate(tmp_real(this%n)) - tmp_real(1:oldN) = this%properties%entries(i)%r_a - tmp_real(oldn+1:this%n) = 0.0_dp - call set_value(this%properties, string(this%properties%keys(i)), tmp_real) - deallocate(tmp_real) - - case(T_LOGICAL_A) - allocate(tmp_logical(this%n)) - tmp_logical(1:oldN) = this%properties%entries(i)%l_a - tmp_logical(oldn+1:this%n) = .false. - call set_value(this%properties, string(this%properties%keys(i)), tmp_logical) - deallocate(tmp_logical) - - case(T_INTEGER_A2) - allocate(tmp_int2(this%properties%entries(i)%len2(1),this%n)) - tmp_int2(:,1:oldN) = this%properties%entries(i)%i_a2 - tmp_int2(:,oldn+1:this%n) = 0 - call set_value(this%properties, string(this%properties%keys(i)), tmp_int2) - deallocate(tmp_int2) - - case(T_REAL_A2) - allocate(tmp_real2(this%properties%entries(i)%len2(1),this%n)) - tmp_real2(:,1:oldN) = this%properties%entries(i)%r_a2 - tmp_real2(:,oldn+1:this%n) = 0.0_dp - call set_value(this%properties, string(this%properties%keys(i)), tmp_real2) - deallocate(tmp_real2) - - case(T_CHAR_A) - allocate(tmp_char(this%properties%entries(i)%len2(1),this%n)) - tmp_char(:,1:oldN) = this%properties%entries(i)%s_a - tmp_char(:,oldn+1:this%n) = ' ' - call set_value(this%properties, string(this%properties%keys(i)), tmp_char) - deallocate(tmp_char) - - case default - RAISE_ERROR('atoms_add: bad property type '//this%properties%entries(i)%type//' key='//this%properties%keys(i), error) - - end select - end do - endif - - ! We need to repoint even if the buffers are not reallocated. Otherwise - ! ifort will complain the array sizes are too small if compiled with - ! -check bounds - call atoms_repoint(this) - - this%Nbuffer = max(this%N, this%Nbuffer) - - ! First check the integer properties... - if (.not. has_key(this%properties, 'Z')) then - RAISE_ERROR('Atoms_Add: this atoms has no Z property', error) - end if - this%z(oldN+1:this%N) = Z - - ! set species from Z - if (.not. has_key(this%properties, 'species')) then - RAISE_ERROR('Atoms_Add: this atoms has no species property', error) - end if - do i=1,size(Z) - this%species(:,oldN+i) = ' ' - this%species(1:len(ElementName(Z(i))),oldN+i) = s2a(ElementName(Z(i))) - end do - - if (has_travel) then - if (.not. has_key(this%properties, 'travel')) then - RAISE_ERROR('Atoms_Add: this atoms has no travel property', error) - end if - this%travel(:,oldN+1:this%N) = travel - else - if (has_key(this%properties, 'travel')) then - this%travel(:,oldN+1:this%N) = 0 - end if - end if - - ! Set masks to 1 if properties for them exist - if (has_key(this%properties, 'move_mask')) & - this%move_mask(oldN+1:this%N) = 1 - if (has_key(this%properties, 'damp_mask')) & - this%damp_mask(oldN+1:this%N) = 1 - if (has_key(this%properties, 'thermostat_region')) & - this%thermostat_region(oldN+1:this%N) = 1 - - ! ... and now the real properties - if (has_key(this%properties, 'mass')) then - if (has_mass) then - this%mass(oldN+1:this%N) = mass - else - this%mass(oldN+1:this%N) = ElementMass(Z) - end if - else if (has_mass) then - ! mass specified but property doesn't yet exist, so create it... - call add_property(this, 'mass', ElementMass(this%Z), ptr=this%mass, error=error) - PASS_ERROR(error) - call set_comm_property(this, 'mass', & - comm_atoms=.true.) - ! ... and then override for new atoms - this%mass(oldN+1:this%N) = mass - end if - - if (.not. has_key(this%properties, 'pos')) then - RAISE_ERROR('Atoms_Add: this atoms has no pos property', error) - end if - this%pos(:,oldN+1:this%N) = pos - - if (has_velo .and. has_key(this%properties, 'velo')) & - this%velo(:,oldN+1:this%N) = velo - - if (has_acc .and. has_key(this%properties, 'acc')) & - this%acc(:,oldN+1:this%N) = acc - - call finalise(this%connect) - - end subroutine add_atom_multiple - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_join(this, from, error) - type(Atoms), intent(inout) :: this - type(Atoms), intent(inout) :: from - integer, optional, intent(out) :: error - - ! --- - - INIT_ERROR(error) - - call atoms_repoint(from) - - call add_atom_multiple(this, pos=from%pos, Z=from%Z, mass=from%mass, & - velo=from%velo, acc=from%acc, travel=from%travel, error=error) - PASS_ERROR(error) - - endsubroutine atoms_join - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine remove_atom_single(this, i, error) - - type(Atoms), intent(inout) :: this - integer, intent(in) :: i - integer, intent(out), optional :: error - - INIT_ERROR(error) - call remove_atom_multiple(this,(/i/),error) - PASS_ERROR(error) - - end subroutine remove_atom_single - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - !% Reshuffle the order of the atomic indices to new_indices. - subroutine atoms_shuffle(this, new_indices, error) - type(Atoms), intent(inout) :: this - integer, dimension(this%N), intent(in) :: new_indices - integer, optional, intent(out) :: error - - ! --- - - integer, allocatable, dimension(:) :: tmp_int - integer, allocatable, dimension(:,:) :: tmp_int2 - real(dp), allocatable, dimension(:) :: tmp_real - real(dp), allocatable, dimension(:,:) :: tmp_real2 - logical, allocatable, dimension(:) :: tmp_logical - character, allocatable, dimension(:,:) :: tmp_char - - integer :: i - - ! --- - - INIT_ERROR(error) - - ! Resize property data arrays, copying old data. - ! this will break any existing pointers so we call atoms_repoint() - ! immediately after (note that user-held pointers will stay broken, there - ! is no way to fix this since Fortran does not allow pointer-to-pointer - ! types) - do i=1,this%properties%N - select case (this%properties%entries(i)%type) - - case(T_INTEGER_A) - allocate(tmp_int(this%n)) - tmp_int(:) = this%properties%entries(i)%i_a(new_indices) - call set_value(this%properties, string(this%properties%keys(i)), tmp_int) - deallocate(tmp_int) - - case(T_REAL_A) - allocate(tmp_real(this%n)) - tmp_real(:) = this%properties%entries(i)%r_a(new_indices) - call set_value(this%properties, string(this%properties%keys(i)), tmp_real) - deallocate(tmp_real) - - case(T_LOGICAL_A) - allocate(tmp_logical(this%n)) - tmp_logical(:) = this%properties%entries(i)%l_a(new_indices) - call set_value(this%properties, string(this%properties%keys(i)), tmp_logical) - deallocate(tmp_logical) - - case(T_INTEGER_A2) - allocate(tmp_int2(this%properties%entries(i)%len2(1),this%n)) - tmp_int2(:,:) = this%properties%entries(i)%i_a2(:,new_indices) - call set_value(this%properties, string(this%properties%keys(i)), tmp_int2) - deallocate(tmp_int2) - - case(T_REAL_A2) - allocate(tmp_real2(this%properties%entries(i)%len2(1),this%n)) - tmp_real2(:,:) = this%properties%entries(i)%r_a2(:,new_indices) - call set_value(this%properties, string(this%properties%keys(i)), tmp_real2) - deallocate(tmp_real2) - - case(T_CHAR_A) - allocate(tmp_char(this%properties%entries(i)%len2(1),this%n)) - tmp_char(:,:) = this%properties%entries(i)%s_a(:,new_indices) - call set_value(this%properties, string(this%properties%keys(i)), tmp_char) - deallocate(tmp_char) - - case default - RAISE_ERROR('remove_atom_multiple: bad property type '//this%properties%entries(i)%type//' key='//this%properties%keys(i), error) - end select - end do - call atoms_repoint(this) - - endsubroutine atoms_shuffle - - - subroutine remove_atom_multiple(this, atom_indices, error) - type(Atoms), intent(inout) :: this - integer, intent(in), dimension(:) :: atom_indices - integer, intent(out), optional :: error - - integer i, copysrc - integer, allocatable, dimension(:) :: new_indices - integer, dimension(size(atom_indices)) :: sorted - integer, dimension(:), allocatable :: uniqed - - INIT_ERROR(error) - - if (this%fixed_size) then - RAISE_ERROR("remove_atom_multiple: Atoms object cannot be resized (this%fixed_size = .true.)", error) - end if - - !Delete the connection data because the atomic indices become mangled - call finalise(this%connect) - - ! Permute new_indices, following algorithm in table_record_delete_multiple, - ! so that atom ordering is same as it was under old scheme when properties were - ! stored as columns in Table this%data. - ! (we find first atomc to be removed and last atom to not be removed - ! and swap them. Repeat until all atoms to be removed are at the end.) - - sorted = atom_indices ! Get our own copy of the indices so we can sort them - call heap_sort(sorted) - call uniq(sorted, uniqed) ! remove duplicates from sorted indices - - allocate(new_indices(this%N)) - do i=1,this%N - new_indices(i) = i - end do - - copysrc = this%N - do i = size(uniqed), 1, -1 - if (uniqed(i) < copysrc) then - new_indices(uniqed(i)) = new_indices(copysrc) - else if (uniqed(i) > copysrc) then - RAISE_ERROR("remove_atom_multiple: Fatal internal error: uniqed(i) > copysrc, should not happen", error) - endif - - copysrc = copysrc - 1 - end do - - ! update N - this%N = this%N - size(uniqed) - this%Ndomain = this%N - this%Nbuffer = this%N - - if (this%N /= copysrc) then - RAISE_ERROR("remove_atom_multiple: Fatal internal error: this%N /= copysrc, should not happen", error) - endif - - ! This will reallocate all buffers to the new size (i.e. this%N) - call shuffle(this, new_indices(1:this%N), error=error) - PASS_ERROR(error) - - deallocate(uniqed, new_indices) - - end subroutine remove_atom_multiple - - - subroutine remove_atom_multiple_mask(this, mask, error) - - type(Atoms), intent(inout) :: this - logical, dimension(this%N), intent(in) :: mask - integer, optional, intent(out) :: error - - ! --- - - integer :: i, j - - integer, allocatable :: new_indices(:) - - ! --- - - INIT_ERROR(error) - - if (this%fixed_size) then - RAISE_ERROR("remove_atom_multiple_mask: Atoms object cannot be resized (this%fixed_size = .true.)", error) - end if - - !Delete the connection data because the atomic indices become mangled - call finalise(this%connect) - - allocate(new_indices(this%N)) - - j = 1 - do i = 1, this%N - if (.not. mask(i)) then - ! Keep this atom - new_indices(j) = i - j = j + 1 - endif - enddo - - ! update N - this%N = j-1 - this%Ndomain = this%N - this%Nbuffer = this%N - - ! This will reallocate all buffers to the new size (i.e. this%N) - call shuffle(this, new_indices(1:this%N), error=error) - PASS_ERROR(error) - - deallocate(new_indices) - - endsubroutine remove_atom_multiple_mask - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Map atomic fractional positions back into the unit cell - !% $-0.5 \le t_x,t_y,t_z < 0.5$ - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_map_into_cell(this) - type(Atoms), intent(inout) :: this - - integer :: i,j, n, m - integer :: shift(3) - logical :: mapped - integer, pointer :: map_shift(:,:) - - - ! Loop over all atoms - ! Convert cartesians to lattice co-ords - ! If outside unit cell: - ! add lattice vectors to get back into cell - ! update travel - ! update shifts - - if (.not. has_property(this, 'travel')) then - call add_property(this, 'travel', 0, n_cols=3, ptr2=this%travel) - call set_comm_property(this, 'travel', & - comm_atoms=.true.) - end if - - do i=1,this%N - call map_into_cell(this%pos(:,i), this%lattice, this%g, shift, mapped) - if (mapped) then - this%travel(:,i) = this%travel(:,i) - shift - if (this%connect%initialised) then - do n=1,atoms_n_neighbours(this, i) ! Loop over all atom i's neighbours - - j = atoms_neighbour(this, i, n, index=m) ! get neighbour - - ! now update the data for atom i and the current neighbour - if (i < j) then - this%connect%neighbour1(i)%t%int(2:4,m) = this%connect%neighbour1(i)%t%int(2:4,m) + shift - else if (i > j) then - this%connect%neighbour1(j)%t%int(2:4,m) = this%connect%neighbour1(j)%t%int(2:4,m) - shift - else - ! do nothing when i == j - end if - end do - end if ! this%connect%initialised - end if ! mapped - end do ! i=1..N - - if (assign_pointer(this, 'map_shift', map_shift)) map_shift = 0 - - end subroutine atoms_map_into_cell - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Unskew lattice so the cosines of the lattice angles fall between - !% $-0.5$ and $0.5$ - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_unskew_cell(this, error) - type(Atoms), intent(inout) :: this - integer, intent(out), optional :: error - - real(dp), dimension(3,3) :: lattice - real(dp), dimension(3) :: lengths, angles - integer :: i, j, k, tmp_i, max_angle(1) - - INIT_ERROR(error) - - lattice = this%lattice - - do - do i = 1, 3 - lengths(i) = sqrt(sum(lattice(:,i)**2)) - enddo - - k = 0 - - do i = 1, 3 - do j = i+1, 3 - k = k+1 - angles(k) = dot_product(lattice(:,i),lattice(:,j)) / lengths(i) / lengths(j) - enddo - enddo - - if( all( abs(angles) <= 0.5_dp ) ) exit - - max_angle = maxloc(abs(angles)) - - selectcase(max_angle(1)) - case(1) - i = 1 - j = 2 - case(2) - i = 1 - j = 3 - case(3) - i = 2 - j = 3 - case default - RAISE_ERROR("atoms_unskew_cell: max_angle not between 1 and 3", error) - endselect - - if(lengths(i) > lengths(j)) then - tmp_i = j - j = i - i = tmp_i - endif - - lattice(:,j) = lattice(:,j) - nint(angles(max_angle(1))) * lattice(:,i) - - enddo - - call set_lattice(this,lattice,scale_positions=.false.,remap=.true.,reconnect=.true.) - - - end subroutine atoms_unskew_cell - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Cosine of the angle j--i--k - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function cosine(this,i,j,k,error) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i,j,k - real(dp) :: cosine - real(dp), dimension(3) :: ij, ik - integer, intent(out), optional :: error - - INIT_ERROR(error) - if ((i == j) .or. (i == k)) then - RAISE_ERROR('Cosine: i == j or i == k', error) - end if - - ij = diff_min_image(this,i,j) - ik = diff_min_image(this,i,k) - cosine = (ij .dot. ik) / (norm(ij)*norm(ik)) - - end function cosine - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Cosine of the angle n--i--m where {$n,m$} are the {$n$th, $m$th} neighbours of i - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function cosine_neighbour(this,i,n,m) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i,n,m - real(dp) :: cosine_neighbour - real(dp), dimension(3) :: in, im - integer::j - - if(n == m) then - cosine_neighbour = 1.0_dp - return - end if - j = atoms_neighbour(this, i, n, diff=in) - j = atoms_neighbour(this, i, m, diff=im) - cosine_neighbour = (in .dot. im) / (norm(in)*norm(im)) - - end function cosine_neighbour - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Direction cosines - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Given two atoms $i$ and $j$ and a shift returns the direction - !% cosines of the differnece vector from $i$ to $j$. - function direction_cosines(this,i,j,shift) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i,j, shift(3) - real(dp), dimension(3) :: direction_cosines, diffv - - diffv = diff(this,i,j,shift) - direction_cosines = diffv / norm(diffv) - - end function direction_cosines - - !% Direction cosines of the difference vector from $i$ to $j$ - function direction_cosines_min_image(this,i,j,error) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i,j - real(dp), dimension(3) :: direction_cosines_min_image, diffv - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (i == j) then - RAISE_ERROR('Cosines: i == j', error) - end if - - diffv = diff_min_image(this,i,j) - direction_cosines_min_image = diffv / norm(diffv) - - end function direction_cosines_min_image - - subroutine set_map_shift(this, error) - type(Atoms), intent(inout) :: this - integer, intent(out), optional :: error - - integer, pointer :: map_shift(:,:) - integer n - real(dp) :: lat_pos(3) - - INIT_ERROR(error) - if (.not. assign_pointer(this, 'map_shift', map_shift)) then - call add_property(this, 'map_shift', 0, 3) - if (.not. assign_pointer(this, 'map_shift', map_shift)) then - RAISE_ERROR("partition_atoms impossibly failed to assign map_shift pointer", error) - end if - endif - - do n = 1, this%N - lat_pos = this%g .mult. this%pos(:,n) - map_shift(:,n) = - floor(lat_pos+0.5_dp) - end do - end subroutine set_map_shift - - ! - !% Returns the (unsigned) volume of the simulation cell of this Atoms - ! - function atoms_cell_volume(this) - type(Atoms), intent(in) :: this - real(dp) :: atoms_Cell_Volume - - atoms_cell_volume = cell_volume(this%lattice) - end function atoms_cell_volume - - - ! - ! Make_Lattice - ! - !% Make a matrix of lattice vectors from the lengths 'a','b','c' - !% and the angles 'alpha', 'beta' and 'gamma'. - !% One length must be supplied. Any missing angle is assumed to be 90 degrees - !% and any missing length is assumed to be 'a'. - !% The vectors are created in a right-handed order. - ! - function make_lattice(a,b,c,alpha,beta,gamma,error) result(lattice) - - real(dp), intent(in) :: a - real(dp), optional, intent(in) :: b,c - real(dp), optional, intent(in) :: alpha,beta,gamma - integer, intent(out), optional :: error - real(dp), dimension(3,3) :: lattice - real(dp) :: my_b, my_c, & - cos_alpha, cos2_alpha, & - cos_beta, cos2_beta, & - cos_gamma, cos2_gamma, & - sin_gamma, sin2_gamma, & - my_alpha, my_beta,my_gamma - INIT_ERROR(error) - my_b = a - my_c = a - - if (present(b)) my_b = b - if (present(c)) my_c = c - - my_alpha = PI/2.0_dp - my_beta = PI/2.0_dp - my_gamma = PI/2.0_dp - - if (present(alpha)) my_alpha = alpha - if (present(beta)) my_beta = beta - if (present(gamma)) my_gamma = gamma - - if ( (my_alpha <= 0.0_dp) .or. (my_alpha <= 0.0_dp) .or. (my_gamma <= 0.0_dp) ) then - RAISE_ERROR('Make_Lattice: Negative angles are not permitted', error) - end if - - if ( (my_alpha + my_beta) < my_gamma ) then - RAISE_ERROR('Make_Lattice: alpha + beta < gamma', error) - end if - if ( (my_beta + my_gamma) < my_alpha ) then - RAISE_ERROR('Make_Lattice: beta + gamma < alpha', error) - end if - if ( (my_gamma + my_alpha) < my_beta ) then - RAISE_ERROR('Make_Lattice: gamma + alpha < beta', error) - end if - - cos_alpha = cos(my_alpha); cos2_alpha = cos_alpha*cos_alpha - cos_beta = cos(my_beta); cos2_beta = cos_beta *cos_beta - cos_gamma = cos(my_gamma); cos2_gamma = cos_gamma*cos_gamma - sin_gamma = sin(my_gamma); sin2_gamma = sin_gamma*sin_gamma - - ! a - lattice(1,1) = a - lattice(2,1) = 0.0_dp - lattice(3,1) = 0.0_dp - ! b - lattice(1,2) = my_b * cos_gamma - lattice(2,2) = my_b * sin_gamma - lattice(3,2) = 0.0_dp - ! c - lattice(1,3) = my_c * cos_beta - lattice(2,3) = my_c * (cos_alpha - cos_beta*cos_gamma) / sin_gamma - lattice(3,3) = my_c * sqrt(1.0_dp - (cos2_alpha + cos2_beta - 2.0_dp*cos_alpha*cos_beta*cos_gamma)/ sin2_gamma) - - end function make_lattice - - ! - !% Opposite of Make_Lattice. - !% Given a lattice, return a,b,c,alpha,beta and gamma (if needed) - ! - subroutine get_lattice_params(lattice,a,b,c,alpha,beta,gamma) - - real(dp), dimension(3,3), intent(in) :: lattice - real(dp), optional, intent(out) :: a,b,c,alpha,beta,gamma - !local variables - real(dp), dimension(3) :: a_1,a_2,a_3 - - a_1 = lattice(:,1) - a_2 = lattice(:,2) - a_3 = lattice(:,3) - - if (present(a)) a = norm(a_1) - if (present(b)) b = norm(a_2) - if (present(c)) c = norm(a_3) - - if (present(alpha)) alpha = acos( (a_2 .dot. a_3) / (norm(a_2)*norm(a_3)) ) - if (present(beta)) beta = acos( (a_3 .dot. a_1) / (norm(a_3)*norm(a_1)) ) - if (present(gamma)) gamma = acos( (a_1 .dot. a_2) / (norm(a_1)*norm(a_2)) ) - - end subroutine get_lattice_params - - ! - ! Centre_Of_Mass - ! - !% Calculate the centre of mass of an atoms object, using the closest images to the origin atom, - !% or first atom if this is not specified. If origin is zero, use actual position, not minimum image. - !% If an 'index_list' is present, just calculate it for that subset of atoms (then the origin atom is - !% the first in this list unless it is specified separately). - !% - !% Note: Because the origin can be specified separately it need not be one of the atoms in the - !% calculation. - function centre_of_mass(at,index_list,mask,origin,error) result(CoM) - - type(atoms), intent(in) :: at - integer, optional, intent(in) :: origin - integer, dimension(:), optional, intent(in) :: index_list - logical, dimension(:), optional, intent(in) :: mask - integer, optional, intent(out) :: error - real(dp), dimension(3) :: CoM - - !local variables - integer :: i, my_origin - real(dp) :: M_Tot - - INIT_ERROR(error) - if (.not. has_property(at, 'mass')) then - RAISE_ERROR('centre_of_mass: Atoms has no mass property', error) - end if - - if (present(index_list) .and. present(mask)) then - RAISE_ERROR('centre_of_mass: Cannot take both index_list and mask arguments', error) - endif - - if (present(origin)) then - if (origin > at%N .or. origin < 0) then - RAISE_ERROR('centre_of_mass: Invalid origin atom', error) - end if - my_origin = origin - else - if (present(index_list)) then - my_origin = index_list(1) - else if (present(mask)) then - i = 1 - do while (.not. mask(i) .and. i <= at%N) - i = i+1 - enddo - if (i > at%N) then - RAISE_ERROR('centre_of_mass: No atoms specified in mask.', error) - endif - my_origin = i - else - my_origin = 1 - endif - end if - - CoM = 0.0_dp - M_Tot = 0.0_dp - - if (present(index_list)) then - - do i = 1, size(index_list) - if (index_list(i) > at%N .or. index_list(i) < 1) then - RAISE_ERROR('centre_of_mass: Invalid atom in index_list', error) - end if - if (my_origin > 0) then - CoM = CoM + at%mass(index_list(i)) * diff_min_image(at,my_origin,index_list(i)) - else - CoM = CoM + at%mass(index_list(i)) * at%pos(:,index_list(i)) - endif - M_Tot = M_Tot + at%mass(index_list(i)) - end do - - else - - do i = 1, at%N - if (present(mask)) then - if (.not. mask(i)) cycle - endif - if (my_origin > 0) then - CoM = CoM + at%mass(i) * diff_min_image(at,my_origin,i) - else - CoM = CoM + at%mass(i) * at%pos(:,i) - endif - M_Tot = M_Tot + at%mass(i) - end do - - end if - - CoM = CoM / M_Tot - if (my_origin > 0) then - CoM = CoM + at%pos(:,my_origin) - endif - - end function centre_of_mass - - ! - ! Directionality ellipsoid: - ! - !% Given an origin atom and a list of other atoms, give information as to whether the other atoms - !% are distributed roughly linearly, planar or spherically around the origin atom. - !% - !% The most notable use is to check that the splines in adjustable potential will be able to reproduce - !% a randomly oriented force difference well. - !% - !% The information returned is the set of eigenvectors and associated eigenvalues of the directionality - !% ellipsoid. One large e-value suggests roughly linear clustering, two similar and one small e-values suggest - !% a planar distribution, while three similar e-values suggests almost spherical distribution (when copies of - !% the atoms reflected through the origin atom are also considered). - !% - !% To acheive a more spherical distribution, atoms along the e-vector(s) with the smallest e-value(s) should be - !% added to the index list (See 'CosAngle_To_Line' below). - !% - !% The matrix which is diagonalised is an average of the outer products of the unit vectors from the origin - !% atom to the other atoms. - !% - !% An outer product has 1 eigenvector which is the vector it was constructed from with - !% eigenvalue 1 and the other eigenvectors have eigenvalue 0. - !% - !% The eigenvalues of the averaged matrix sum to 1. - !% - subroutine directionality(this,origin,list,evalues,evectors,method,error) - - type(Atoms), intent(in) :: this !% The input atoms structure - integer, intent(in) :: origin !% The origin atom - type(table), intent(in) :: list !% Indices and shifts of the other atoms relative to origin - real(dp), dimension(3), intent(out) :: evalues !% Eigenvalues of the directionality matrix - real(dp), dimension(3,3), intent(out) :: evectors !% Eigenvectors of the directionality matrix - integer, optional, intent(in) :: method !% 'METHOD = 1' Directionality ellipsoid method. - !% 'METHOD = 2' Singular Value Decomposition method (default) - integer, intent(out), optional :: error - - !local variables - integer :: i, j, k, l, n, my_method, lwork, info, jshift(3) - real(dp), dimension(3) :: r_ij,rhat_ij - real(dp), dimension(3,3) :: A, B - real(dp), allocatable, dimension(:,:) :: vectors, u - real(dp), allocatable, dimension(:) :: work - - INIT_ERROR(error) - my_method = 2 - - if (present(method)) then - if (method < 1 .or. method > 2) then - write(line,'(a,i0,a)')'Directionality: Method = ',method,' does not exist' - call system_abort(line) - end if - my_method = method - end if - - if (list%intsize /= 4) then - RAISE_ERROR('Directionality: list must have 4 int columns for indices and shifts', error) - end if - if (list%N == 0) then - RAISE_ERROR('Directionality: list table has no entries', error) - end if - - i = origin - - select case(my_method) - - case(1) ! **** Directionality Ellipsoid method **** - - B = 0.0_dp - - !Construct the directionality matrix - do n = 1, list%N - j = list%int(1,n) - jshift = list%int(2:4,n) - if (j > this%N) then - RAISE_ERROR('Directionality: Atom '//j//' is out of range ('//this%N//')', error) - end if - r_ij = diff(this,i,j,jshift) - rhat_ij = r_ij / norm(r_ij) - forall(k=1:3,l=1:3) A(k,l) = rhat_ij(k)*rhat_ij(l) - B = B + A - end do - - B = B / real(list%N,dp) - - !Find eigenvalues/eigenvectors of the directionality matrix - call diagonalise(B,evalues,evectors) - - case(2) ! **** Singular Value Decomposition method **** - - lwork = 2 * max(3*min(3,list%N)+max(3,list%N),5*min(3,list%N)) - - allocate(work(lwork), vectors(list%N,3), u(list%N,3)) - - !Fill 'vectors' with unit vectors - do n = 1, list%N - j = list%int(1,n) - jshift = list%int(2:4,n) - if (j > this%N) then - RAISE_ERROR('Directionality: Atom '//j//' is out of range ('//this%N//')', error) - end if - r_ij = diff(this,i,j,jshift) - vectors(n,:) = r_ij / norm(r_ij) - end do - - call dgesvd('N','A',list%N,3,vectors,list%N,evalues,u,list%N,evectors,3,work,lwork,info) - !No left singular vectors, all right singular vectors - - if (info/=0) then - if (info < 0) then - RAISE_ERROR('Directionality: Problem with argument '//-info//' passed to DGESVD', error) - else - RAISE_ERROR('Directionality: DBDSQR (called from DGESVD) did not converge', error) - end if - end if - - deallocate(work, vectors, u) - - evectors = transpose(evectors) - - end select - - end subroutine directionality - - ! - ! CosAngle_To_Line - ! - !% For use with the 'Directionality' routine above. - !% Given an atom ('atom') and a direction ('dir') return the absolute value of the cosine of the angle - !% between the the line running through 'atom' in direction 'dir' and the line - !% between 'atom' and 'test_atom' - !% - !% The idea is that this will be called with the origin atom from 'Directionality' as 'atom', - !% the eigenvector associated with the smallest eigenvalue as 'dir' and a potentially new - !% atom to connect to 'atom' with a spline as 'test_atom'. - !% - !% If the result is close to 1 then accept the 'test_atom', and reject if close to zero - - function cosangle_to_line(this,atom,dir,test_atom,error) - - type(atoms), intent(in) :: this - integer, intent(in) :: atom - real(dp), dimension(3), intent(in) :: dir - integer, intent(in) :: test_atom - real(dp) :: CosAngle_To_Line - integer, intent(out), optional :: error - !local variables - real(dp), dimension(3) :: r_ab - - INIT_ERROR(error) - !Sanity checks - if (atom > this%N) then - RAISE_ERROR('CosAngle_To_Line: Atom '//atom//' out of range ('//this%N//')', error) - end if - - if (test_atom > this%N) then - RAISE_ERROR('CosAngle_To_Line: Test atom '//test_atom//' out of range ('//this%N//')', error) - end if - - if (normsq(dir) .feq. 0.0_dp) then - RAISE_ERROR('CosAngle_To_Line: A non-zero direction is required', error) - end if - - r_ab = diff_min_image(this,atom,test_atom) - - CosAngle_To_Line = abs(dir .dot. r_ab) / (norm(dir)*norm(r_ab)) - - end function cosangle_to_line - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! I/O procedures - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_print(this,file,error) - type(Atoms), intent(in) :: this - type(Inoutput), intent(inout),optional, target :: file - integer, intent(out), optional :: error - - type(Inoutput), pointer :: my_out - - INIT_ERROR(error) - if(.not. is_initialised(this)) then - RAISE_ERROR('Atoms_Print: Atoms structure not initialised', error) - end if - - if(current_verbosity() <= PRINT_SILENT) return ! for efficiency - - if (present(file)) then - my_out => file - else - my_out => mainlog - end if - - call print('Atoms Structure: ', PRINT_NORMAL, my_out) - call print('Number of atoms = '//this%N, PRINT_NORMAL, my_out) - - call print('Cutoff radius = '//this%cutoff//' Angstroms', PRINT_NORMAL, my_out) - - call print('Lattice vectors:', PRINT_NORMAL, my_out) - call print('a = ('//this%lattice(:,1)//')', PRINT_NORMAL, my_out) - call print('b = ('//this%lattice(:,2)//')', PRINT_NORMAL, my_out) - call print('c = ('//this%lattice(:,3)//')', PRINT_NORMAL, my_out) - - call print('Params') - call print(this%params) - - call print('Properties') - call print(this%properties) - - if (this%connect%initialised) then - call verbosity_push_decrement() - call print(this%connect, my_out) - call verbosity_pop() - end if - - call print('',PRINT_NORMAL, my_out) - end subroutine atoms_print - - function prop_names_string(this, with_types, error) - type(Atoms), intent(in) :: this - logical, optional, intent(in) :: with_types - integer, intent(out), optional :: error - character(len=STRING_LENGTH) :: prop_names_string - - INIT_ERROR(error) - prop_names_string=dict_prop_names_string(this%properties, with_types) - PASS_ERROR(error) - - end function prop_names_string - - function dict_prop_names_string(this,with_types,error) - type(Dictionary), intent(in) :: this - logical, intent(in), optional :: with_types - integer, intent(out), optional :: error - character(len=STRING_LENGTH) :: dict_prop_names_string - - character(len=1) :: prop_type - character(len=STRING_LENGTH) :: tmp - integer :: i, n_cols, type - logical :: my_with_types - - INIT_ERROR(error) - my_with_types = optional_default(.false., with_types) - - dict_prop_names_string = "" - do i=1,this%N - if (my_with_types) then - - select case(this%entries(i)%type) - case(T_INTEGER_A) - prop_type = 'I' - n_cols = 1 - case(T_REAL_A) - prop_type = 'R' - n_cols = 1 - case(T_LOGICAL_A) - prop_type = 'L' - n_cols = 1 - case(T_CHAR_A) - prop_type = 'S' - n_cols = 1 - case(T_INTEGER_A2) - prop_type = 'I' - n_cols = this%entries(i)%len2(1) - case(T_REAL_A2) - prop_type = 'R' - n_cols = this%entries(i)%len2(1) - case default - RAISE_ERROR('dict_prop_names_string: bad property type='//type//' in properties argument', error) - end select - - write(tmp,'(i0)') n_cols ! Number of columns for this property - dict_prop_names_string=trim(dict_prop_names_string)//string(this%keys(i))//':'// & - prop_type//':'//trim(tmp)//':' - else - dict_prop_names_string=trim(dict_prop_names_string)//string(this%keys(i))//':' - endif - end do - ! Remove trailing ':' - dict_prop_names_string = dict_prop_names_string(1:len_trim(dict_prop_names_string)-1) - end function dict_prop_names_string - - !Termination_Bond_Rescale - !% Calculates the rescale ratio of a Z1--H bond - !% generate from a Z1--Z2 bond. - function termination_bond_rescale(z1,z2) - integer, intent(in) :: z1, z2 - real(dp) :: termination_bond_rescale - termination_bond_rescale = (ElementCovRad(z1) + ElementCovRad(1)) & - / (ElementCovRad(z1) + ElementCovRad(z2)) - end function termination_bond_rescale - - !% Parses an atom_mask, which is string consisting of the '@' symbol followed by a comma separated - !% list of indices or ranges into a table containing all the indices it represents. - !% E.g. '@1,37-39,54,99-102' is expanded to a table with 1, 37, 38, 39, 54, 99, 100, - !% 101, 102 as its first integer column. There must be no spaces in the mask. - subroutine parse_atom_mask(mask_in,atom_indices,error) - - character(*), intent(in) :: mask_in - type(Table), intent(out) :: atom_indices - integer, intent(out), optional :: error - - character(len(mask_in)) :: mask - character(20), dimension(50) :: fields - integer :: Nfields, i, j, n, a, b, c - - INIT_ERROR(error) - call allocate(atom_indices,1,0,0,0,100) - - mask = adjustl(mask_in) - - if (mask(1:1)=='@') then !Found atom mask - !Remove @ symbol - mask = mask(2:) - !Parse into comma separated numbers or ranges - call parse_string(mask,',',fields,Nfields) - if (Nfields==0) then - RAISE_ERROR('parse_atom_mask: Atom mask contained no indices', error) - end if - do i = 1, Nfields - !Is this field a single atom or a contiguous range? - n = scan(fields(i),'-') - if (n /= 0) then - !it's a range. get start number - a = string_to_int(fields(i)(:n-1)) - !get end number - b = string_to_int(fields(i)(n+1:)) - if (a > b) then - c = b - b = a - a = c - end if - !add all these atoms to the list - do j = a, b - if (.not.is_in_array(int_part(atom_indices,1),j)) call append(atom_indices,j) - end do - else - !it's a single atom. - a = string_to_int(fields(i)) - if (.not.is_in_array(int_part(atom_indices,1),j)) call append(atom_indices,a) - end if - end do - else - RAISE_ERROR('parse_atom_mask: Invalid atom mask: '//mask_in, error) - end if - - end subroutine parse_atom_mask - - !% Find atoms which have integer property 'prop' set to - !% true (i.e. set to 1) and return them in the Table 'list'. - subroutine property_to_list(at, prop, list, error) - type(Atoms), intent(in) :: at - character(*), intent(in) :: prop - type(Table), intent(inout) :: list - integer, intent(out), optional :: error - - integer :: i - integer, dimension(:), pointer :: p - - INIT_ERROR(error) - if (.not. assign_pointer(at, prop, p)) then - RAISE_ERROR('property_to_list: at does not have property "'//trim(prop)//'".', error) - end if - - call allocate(list, 1, 0, 0, 0) - call append(list, pack((/ (i, i=1,size(p)) /), p == 1)) - - end subroutine property_to_list - - !% Convert the Table 'list' to a single column integer property in 'at', - !% with atoms in list marked with a 1 and absent - subroutine list_to_property(at, list, prop, error) - type(Atoms), intent(inout) :: at - type(Table), intent(in) :: list - character(*), intent(in) :: prop - integer, intent(out), optional :: error - - integer, dimension(:), pointer :: p - - INIT_ERROR(error) - ! Add property if necessary - call add_property(at, prop, 0) - - if (.not. assign_pointer(at, prop, p)) then - RAISE_ERROR('list_to_property: at does not have property "'//trim(prop)//'".', error) - end if - - p = 0 ! Set all entries to zero - p(int_part(list,1)) = 1 ! Set entries in 'list' to 1 - - end subroutine list_to_property - - !% Find atoms which have integer property 'prop' with value 'value' - !% and return them in a table 'list'. - subroutine list_matching_prop(at,list,name,value,error) - - type(atoms), intent(in) :: at - type(table), intent(inout) :: list - character(*), intent(in) :: name - integer, intent(in) :: value - integer, intent(out), optional :: error - - integer :: i - integer, pointer, dimension(:) :: ptr - - INIT_ERROR(error) - !find property - if (.not. assign_pointer(at%properties,name,ptr)) then - RAISE_ERROR('Property "'//name//'" not found', error) - end if - - call wipe(list) - - do i = 1, at%N - if (ptr(i)==value) call append(list,(/i/)) - end do - - end subroutine list_matching_prop - - !% Return the complement of a list, i.e. all those atoms not included - !% in list. Result is in outlist on exit. - subroutine complement(at, inlist, outlist) - type(Atoms), intent(in) :: at - type(Table), intent(in) :: inlist - type(Table), intent(out) :: outlist - - integer :: i - integer, allocatable, dimension(:) :: inarray - - call allocate(outlist,1,0,0,0) - - allocate(inarray(inlist%N)) - inarray = int_part(inlist,1) - - do i=1,at%N - if (.not. is_in_array(inarray,i)) & - call append(outlist,i) - end do - - deallocate(inarray) - - end subroutine complement - - - !% Return the difference between list1 and list2 in outlist. - !% That is, those elements in list1 but not in list2 - subroutine difference(list1, list2, outlist, error) - type(Table), intent(in) :: list1, list2 - type(Table), intent(out) :: outlist - integer, intent(out), optional :: error - - integer :: i - integer, dimension(:), allocatable :: array1, array2 - - INIT_ERROR(error) - if (list1%N <= list2%N) then - RAISE_ERROR('difference: list1%N ('//(list1%N)//') <= list2%N ('//(list2%N)//').', error) - end if - - call allocate(outlist, 1, 0, 0, 0) - - allocate(array1(list1%N),array2(list2%N)) - array1 = int_part(list1,1) - array2 = int_part(list2,1) - - do i=1,list1%N - if (.not. is_in_array(array2, array1(i))) & - call append(outlist,list1%int(1,i)) - end do - - deallocate(array1,array2) - - end subroutine difference - - !% move atoms around following neighbor list bonds so that all are in the same periodic image - !% (that of 'seed', if present) - !% poorly tested, especially for situations where not all atoms are in one connected clump - !% probably needs a better subroutine name - subroutine coalesce_in_one_periodic_image(this, seed, is_periodic, error) - type(Atoms), intent(inout) :: this - integer, intent(in), optional :: seed - logical, optional, intent(in) :: is_periodic(3) - integer, intent(out), optional :: error - - integer :: i, ji, jji, j, shift(3), delta_shift(3), jj, k, ki - integer :: n_neighbours, max_n_neighbours - integer, allocatable :: shifts(:,:,:), cluster_list(:) - logical, allocatable :: touched(:), is_in_cluster(:) - integer :: seed_val, last_n_in_cluster - logical :: dir_mask(3) - integer, allocatable, dimension(:) :: dir_indices - - INIT_ERROR(error) - seed_val=optional_default(1, seed) - - if (present(is_periodic)) then - dir_mask = .not. is_periodic - allocate(dir_indices(count(dir_mask))) - dir_indices(:) = pack((/1,2,3/), dir_mask) - else - allocate(dir_indices(3)) - dir_mask = .true. - dir_indices = (/1,2,3/) - end if - - max_n_neighbours = 0 - do i=1, this%N - n_neighbours = atoms_n_neighbours(this, i) - if (n_neighbours > max_n_neighbours) max_n_neighbours = n_neighbours - end do - allocate(shifts(3,max_n_neighbours,this%N)) - shifts = 0 - - ! find which atoms are in cluster that includes seed - allocate(is_in_cluster(this%N)) - is_in_cluster = .false. - last_n_in_cluster = 0 - is_in_cluster(seed_val) = .true. - do while (count(is_in_cluster) /= last_n_in_cluster) - last_n_in_cluster = count(is_in_cluster) - do i=1, this%N - if (is_in_cluster(i)) then - do ji=1, atoms_n_neighbours(this, i) - j = atoms_neighbour(this, i, ji, shift=shift) - is_in_cluster(j) = .true. - end do - end if - end do - end do - allocate(cluster_list(count(is_in_cluster))) - ji = 0 - do i=1, this%N - if (is_in_cluster(i)) then - ji = ji + 1 - cluster_list(ji) = i - endif - end do - - ! initialize shifts - do i=1, this%N - do ji=1, atoms_n_neighbours(this, i) - j = atoms_neighbour(this, i, ji, shift=shift) - shifts(:,ji,i) = shift - end do - end do - - allocate(touched(this%N)) - touched = .false. - touched(seed_val) = .true. - - do while (any(shifts(dir_indices,:,cluster_list(:)) /= 0)) - ! look for atoms i that have been touched - do i=1, this%N - if (.not. is_in_cluster(i)) cycle - if (touched(i)) then - ! look at neighbors of i - do ji=1, atoms_n_neighbours(this,i) - j = atoms_neighbour(this, i, ji) - ! if neighbor has 0 shift, it doesn't need to move - if (any(shifts(dir_indices,ji,i) /= 0)) then - ! atom j does need to move - ! atoms with non-zero shift should not have been touched before - if (touched(j)) then - RAISE_ERROR("coalesce_in_one_periodic_image tried to move atom " // j // " twice", error) - endif - - ! shift atom to zero out shift - do k=1,3 - if (dir_mask(k)) this%pos(:,j) = this%pos(:,j) + shifts(k,ji,i) * this%lattice(:,k) - end do - - ! fix shifts of j's neighbours - delta_shift = merge(shifts(:,ji,i), (/0, 0, 0/), dir_mask) - do jji=1, atoms_n_neighbours(this, j) - ! fix shifts from j to its neighbors - jj = atoms_neighbour(this, j, jji) - shifts(:,jji,j) = shifts(:,jji,j) + delta_shift(:) - ! fix shifts from j's neighbours to it - do ki=1, atoms_n_neighbours(this, jj) - k = atoms_neighbour(this, jj, ki) - if (k == j) then - shifts(:,ki,jj) = shifts(:,ki,jj) - delta_shift(:) - endif - end do ! ki - end do ! jji - ! shifts(:,ji,i) = 0 - touched(j) = .true. - else - ! atom j doesn't need to move - touched(j) = .true. - endif ! any(shift) /= 0 - end do ! ji - endif ! touched i - end do ! i - end do ! some shift isn't zero - - deallocate(touched) - deallocate(shifts) - deallocate(is_in_cluster) - deallocate(cluster_list) - deallocate(dir_indices) - - end subroutine coalesce_in_one_periodic_image - - function closest_atom(this, r, cell_image_Na, cell_image_Nb, cell_image_Nc, mask, dist, diff, error) - type(Atoms), intent(in) :: this - real(dp), intent(in) :: r(3) - integer, intent(in) :: cell_image_Na, cell_image_Nb, cell_image_Nc - logical, intent(in), optional, dimension(:) :: mask - real(dp), intent(out), optional :: dist, diff(3) - integer :: closest_atom - integer, intent(out), optional :: error - - integer :: i, j, k - integer i2, j2, k2, i3, j3, k3, i4, j4, k4, n2, atom_i - integer :: cellsNa, cellsNb, cellsNc - real(dp) :: pos(3), cur_dist, cur_diff(3), min_dist, min_diff(3) - integer :: min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc - - INIT_ERROR(error) - if (.not. this%connect%initialised) then - RAISE_ERROR("closest_atom must have initialised connection object", error) - end if - - call cell_of_pos(this%connect, this%g .mult. r, i, j, k) - - cellsNa = this%connect%cellsNa - cellsNb = this%connect%cellsNb - cellsNc = this%connect%cellsNc - - call get_min_max_images(this%is_periodic, cellsNa, cellsNb, cellsNc,& - cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k, .true., .true., .true., & - min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc) - - k3 = 1; k4 = 1; j3 = 1; j4 = 1; i3 = 1; i4 = 1 - - min_dist = 1.0e38_dp - closest_atom = 0 - ! Loop over neighbouring cells, applying PBC - do k2 = min_cell_image_Nc, max_cell_image_Nc - - ! the stored cell we are in - if(cellsNc > 1) k3 = mod(k+k2-1+cellsNc,cellsNc)+1 - - ! the shift we need to get to the cell image - k4 = (k+k2-k3)/cellsNc - - do j2 = min_cell_image_Nb, max_cell_image_Nb - ! the stored cell we are in - if(cellsNb > 1) j3 = mod(j+j2-1+cellsNb,cellsNb)+1 - - ! the shift we need to get to the cell image - j4 = (j+j2-j3)/cellsNb - - do i2 = min_cell_image_Na, max_cell_image_Na - ! the stored cell we are in - if(cellsNa > 1) i3 = mod(i+i2-1+cellsNa,cellsNa)+1 - - ! the shift we need to get to the cell image - i4 = (i+i2-i3)/cellsNa - - ! The cell we are currently testing atom1 against is cell(i3,j3,k3) - ! with shift (i4,j4,k4) - ! loop over it's atoms and test connectivity if atom1 < atom2 - - atom_i = this%connect%cell_heads(i3, j3, k3) - atom_i_loop: do while (atom_i > 0) - if (present(mask)) then - if (.not. mask(atom_i)) then - atom_i = this%connect%next_atom_in_cell(atom_i) - cycle atom_i_loop - endif - end if - pos = this%pos(:,atom_i) + ( this%lattice .mult. (/ i4, j4, k4 /) ) - cur_diff = pos - r - cur_dist = norm(cur_diff) - if (cur_dist < min_dist) then - min_dist = cur_dist - min_diff = cur_diff - closest_atom = atom_i - endif - - atom_i = this%connect%next_atom_in_cell(atom_i) - end do atom_i_loop - - end do - end do - end do - - if (present(dist)) dist = min_dist - if (present(diff)) diff = min_diff - - end function closest_atom - - function atoms_is_min_image(this, i, alt_connect, error) result(is_min_image) - type(Atoms), target, intent(in) :: this - integer, intent(in) ::i - type(Connection), intent(inout), target, optional :: alt_connect - integer, intent(out), optional :: error - - logical :: is_min_image - integer :: n, m, NN - type(Connection), pointer :: use_connect - - INIT_ERROR(error) - if (present(alt_connect)) then - use_connect => alt_connect - else - use_connect => this%connect - endif - - is_min_image = .true. - ! First we give the neighbour1 (i <= j) then the neighbour2 entries (i > j) - if (use_connect%initialised) then - - if (.not. associated(use_connect%neighbour1(i)%t)) then - RAISE_ERROR('is_min_image: atoms structure has no connectivity data for atom '//i, error) - end if - - nn = use_connect%neighbour1(i)%t%N - do n=1,nn - if (use_connect%neighbour1(i)%t%int(1,n) == i) then - is_min_image = .false. - return - end if - do m=n+1,nn - if (use_connect%neighbour1(i)%t%int(1,n) == use_connect%neighbour1(i)%t%int(1,m)) then - is_min_image = .false. - return - end if - end do - end do - - nn = use_connect%neighbour2(i)%t%N - do n=1,nn - if (use_connect%neighbour2(i)%t%int(1,n) == i) then - is_min_image = .false. - return - end if - do m=n+1,nn - if (use_connect%neighbour2(i)%t%int(1,n) == use_connect%neighbour2(i)%t%int(1,m)) then - is_min_image = .false. - return - end if - end do - end do - - else - RAISE_ERROR('is_min_image: Atoms structure has no connectivity data. Call calc_connect first.', error) - end if - - endfunction atoms_is_min_image - - subroutine atoms_bcast(mpi, at, test_out, error) - type(MPI_context), intent(in) :: mpi - type(Atoms), intent(inout) :: at - type(Atoms), intent(out), optional :: test_out - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - ! Serial test of atoms_bcast by copying into test_out - ! If test fails add new data elements to ALL THREE sections below - if (present(test_out)) then - call finalise(test_out) - test_out%n = at%n - test_out%ndomain = at%ndomain - test_out%nbuffer = at%nbuffer - test_out%cutoff = at%cutoff - test_out%cutoff_skin = at%cutoff_skin - test_out%nneightol = at%nneightol - test_out%lattice = at%lattice - test_out%is_orthorhombic = at%is_orthorhombic - test_out%is_periodic = at%is_periodic - test_out%fixed_size = at%fixed_size - test_out%properties = at%properties - test_out%params = at%params - call matrix3x3_inverse(test_out%lattice,test_out%g) - call atoms_repoint(test_out) - test_out%ref_count = 1 - end if - - if (.not. mpi%active) return - - if (mpi%my_proc == 0) then - call print('atoms_bcast: bcasting from proc '//mpi%my_proc, PRINT_NERD) - call bcast(mpi, at%n) - call bcast(mpi, at%Ndomain) - call bcast(mpi, at%Nbuffer) - call bcast(mpi, at%cutoff) - call bcast(mpi, at%cutoff_skin) - call bcast(mpi, at%nneightol) - call bcast(mpi, at%lattice) - call bcast(mpi, at%is_orthorhombic) - call bcast(mpi, at%is_periodic) - call bcast(mpi, at%fixed_size) - call bcast(mpi, at%properties) - call bcast(mpi, at%params) - else - call print('atoms_bcast: bcasting to proc '//mpi%my_proc, PRINT_NERD) - call finalise(at) - call bcast(mpi, at%n) - call bcast(mpi, at%Ndomain) - call bcast(mpi, at%Nbuffer) - call bcast(mpi, at%cutoff) - call bcast(mpi, at%cutoff_skin) - call bcast(mpi, at%nneightol) - call bcast(mpi, at%lattice) - call bcast(mpi, at%is_orthorhombic) - call bcast(mpi, at%is_periodic) - call bcast(mpi, at%fixed_size) - call bcast(mpi, at%properties) - call bcast(mpi, at%params) - - call matrix3x3_inverse(at%lattice,at%g) - call initialise(at%domain, error=error) - PASS_ERROR(error) - call atoms_repoint(at) - at%ref_count = 1 - end if - - end subroutine atoms_bcast - - - !% Find the indices of the atoms within the cone with its point at the atom 'origin', - !% defined by direction 'dir' and opening angle with cosine 'cos_theta'. The indices - !% are returned in the Table 'output' which has a single integer column. - subroutine atoms_filter_cone(this, origin, dir, cos_theta, output) - type(Atoms), intent(in) :: this - integer, intent(in) :: origin - real(dp), intent(in), dimension(3) :: dir - real(dp), intent(in) :: cos_theta - type(Table), intent(out) :: output - - real(dp) :: d(3), ndir(3), p - integer :: i - - ndir = dir/norm(dir) - p = ndir .dot. this%pos(:,origin) - - call allocate(output, 1,0,0,0) - do i=1,this%n - if (i == origin) cycle - d = this%pos(:,i) - this%pos(:, origin) - if ((d .dot. ndir) < p .and. (d .dot. ndir)/(norm(d)) > cos_theta) call append(output, i) - end do - - end subroutine atoms_filter_cone - - !% Copy some properties from one atoms struct to another - !% The destination will be overriden. - subroutine atoms_copy_properties(this, from, property_list, case_sensitive, error) - type(Atoms), intent(inout) :: this - type(Atoms), intent(in) :: from - character(len=*), intent(in) :: property_list - logical, optional, intent(in) :: case_sensitive - integer, optional, intent(out) :: error - - character(len=len_trim(property_list)) :: property_a(100) - integer :: property_a_n - - INIT_ERROR(error) - - call split_string_simple(trim(property_list), property_a, property_a_n, ':', error) - PASS_ERROR(error) - call subset(from%properties, property_a(1:property_a_n), this%properties, case_sensitive=case_sensitive, out_no_initialise=.true., error=error) - PASS_ERROR(error) - - end subroutine atoms_copy_properties - - - !% sort atoms according to an externally provided field - subroutine atoms_sort_by_rindex(this, sort_index, error) - type(Atoms), intent(inout) :: this - real(DP), dimension(this%N), intent(in) :: sort_index - integer, optional, intent(out) :: error - - ! --- - - real(DP), allocatable :: my_sort_index(:) - integer, allocatable :: atom_index(:) - - integer :: i - - ! --- - - INIT_ERROR(error) - - allocate(my_sort_index(this%N), atom_index(this%N)) - - do i = 1, this%N - my_sort_index(i) = sort_index(i) - atom_index(i) = i - enddo - - call heap_sort(my_sort_index, i_data=atom_index) - - call shuffle(this, atom_index, error=error) - PASS_ERROR(error) - - deallocate(my_sort_index, atom_index) - - endsubroutine atoms_sort_by_rindex - - - !% Basis transformation of rank 0, 1 and 2 tensors real values in Atoms object. - !% This routine transforms rank 1 and rank 2 tensors in this%params and - !% this%properties. Tensors are identified by having the correct type - !% (real arrays) and shape (i.e. 3, (3, 3), (3, this%N) (9, this%N) for - !% vector paramters, tensor parameters, vector properties and tensor - !% properties respectively), and by having a name which is included in - !% the relevant list. Extra names can be added to the lists with the - !% rank1 and rank2 arguments. - subroutine atoms_transform_basis(this, L, rank1, rank2, error) - type(Atoms), intent(inout) :: this - real(dp), dimension(3,3) :: L - character(len=*), optional, intent(in) :: rank1, rank2 - integer, optional, intent(out) :: error - - character(len=*), parameter :: default_rank1 = "pos:velo:acc:avgpos:oldpos:force:efield:dipoles" - character(len=*), parameter :: default_rank2 = "virial:local_virial" - - character(len=STRING_LENGTH) :: all_rank1, all_rank2 - character(len=C_KEY_LEN) :: fields(100) - integer i, j, n_fields - type(Dictionary) :: rank1_d, rank2_d - real(dp), pointer :: v(:), v2(:,:) - - INIT_ERROR(error) - - if (.not. is_orthogonal(L)) then - call print('L=') - call print(L) - RAISE_ERROR("atoms_transform_basis: transformation matrix L is not orthogonal", error) - end if - - all_rank1 = default_rank1 - if (present(rank1)) all_rank1 = trim(all_rank1)//':'//rank1 - call split_string_simple(all_rank1, fields, n_fields, ':', error) - PASS_ERROR(error) - call initialise(rank1_d) - do i=1,n_fields - call set_value(rank1_d, fields(i), .true.) - end do - - all_rank2 = default_rank2 - if (present(rank2)) all_rank2 = trim(all_rank2)//':'//rank2 - call split_string_simple(all_rank2, fields, n_fields, ':', error) - PASS_ERROR(error) - call initialise(rank2_d) - do i=1,n_fields - call set_value(rank2_d, fields(i), .true.) - end do - - ! Special case: transform lattice as 3 separate rank 1 tensors - call set_lattice(this,(L .mult. this%lattice), scale_positions=.false.) - - ! First we consider entries in at%params - do i=1, this%params%n - ! Is it a real 3-vector? - if (assign_pointer(this%params, string(this%params%keys(i)), v)) then - if (has_key(rank1_d, string(this%params%keys(i))) .and. size(v) == 3) then - call print('atoms_transform_basis: transforming '//this%params%keys(i)//' as a rank 1 tensor', PRINT_VERBOSE) - v = L .mult. v - end if - end if - - ! Is it a real 3x3 matrix? - if (assign_pointer(this%params, string(this%params%keys(i)), v2)) then - if (has_key(rank2_d, string(this%params%keys(i))) .and. all(shape(v2) == (/3,3/))) then - call print('atoms_transform_basis: transforming '//this%params%keys(i)//' as a rank 2 tensor', PRINT_VERBOSE) - v2 = L .mult. v2 .mult. transpose(L) - end if - end if - end do - - ! Now for the atomic properties in at%properties - do i=1, this%properties%n - ! Is it a per-atom 3-vector - if (assign_pointer(this%properties, string(this%properties%keys(i)), v2)) then - if (has_key(rank1_d, string(this%properties%keys(i))) .and. size(v2,1) == 3) then - call print('atoms_transform_basis: transforming '//this%properties%keys(i)//' as a rank 1 tensor', PRINT_VERBOSE) - do j=1,this%n - v2(:,j) = L .mult. v2(:,j) - end do - end if - end if - - ! Is it a per-atom 3x3 matrix, arranged as a 9 column property? - if (assign_pointer(this%properties, string(this%properties%keys(i)), v2)) then - if (has_key(rank2_d, string(this%properties%keys(i))) .and. size(v2, 1) == 9) then - call print('atoms_transform_basis: transforming '//this%properties%keys(i)//' as a rank 2 tensor', PRINT_VERBOSE) - do j=1,this%n - v2(:,j) = reshape(L .mult. reshape(v2(:,j),(/3,3/)) .mult. transpose(L), (/9/)) - end do - end if - end if - end do - - call finalise(rank1_d) - call finalise(rank2_d) - - end subroutine atoms_transform_basis - - !% Rotate this Atoms object, transforming all rank 1 and rank 2 tensors parameters and properties - subroutine atoms_rotate(this, axis, angle, rank1, rank2) - type(Atoms), intent(inout) :: this - real(dp), intent(in) :: axis(3), angle - character(len=*), optional, intent(in) :: rank1, rank2 - - type(Quaternion) :: q - real(dp) :: R(3,3) - - q = rotation(axis, angle) - R = rotation_matrix(q) - call transform_basis(this, R, rank1, rank2) - - end subroutine atoms_rotate - - !% Convert from a single index in range 1..this%N to a CASTEP-style (element, index) pair - function atoms_index_to_z_index(this, index) result(z_index) - type(Atoms), intent(in) :: this - integer, intent(in) :: index - integer :: z_index - integer :: j - - z_index = 0 - do j=1,index - if (this%z(index) == this%z(j)) z_index = z_index + 1 - end do - - end function atoms_index_to_z_index - - !% Inverse of atoms_index_to_z_index - function atoms_z_index_to_index(this, z, z_index, error) result(index) - type(Atoms), intent(in) :: this - integer, intent(in) :: z, z_index - integer, intent(out), optional :: error - integer :: index - integer :: nz - - INIT_ERROR(error) - - nz = 0 - do index=1,this%N - if(this%z(index) == z) nz = nz + 1 - if (nz == z_index) return - end do - - RAISE_ERROR('atoms_z_index_to_index: index pair ('//z//','//z_index//') not found', error) - - end function atoms_z_index_to_index - - - !% Test if an atom 'j' is one of 'i's nearest neighbours - function is_nearest_neighbour_abs_index(this,i,j, alt_connect) - type(Atoms), intent(in), target :: this - integer, intent(in) :: i,j - type(Connection), intent(in), optional, target :: alt_connect - logical :: is_nearest_neighbour_abs_index - - integer :: ji - real(dp) :: d - - is_nearest_neighbour_abs_index = .false. - do ji=1, atoms_n_neighbours(this, i) - if (atoms_neighbour(this, i, ji, distance=d, alt_connect=alt_connect) == j) then - if (d < bond_length(this%Z(i),this%Z(j))*this%nneightol) then - is_nearest_neighbour_abs_index = .true. - return - endif - endif - end do - end function is_nearest_neighbour_abs_index - - - !% Test if an atom's $n$th neighbour is one if its nearest neighbours - function is_nearest_neighbour(this,i,n, alt_connect) - - type(Atoms), intent(in), target :: this - integer, intent(in) :: i,n - type(Connection), intent(in), optional, target :: alt_connect - logical :: is_nearest_neighbour - - real(dp) :: d - integer :: j - - is_nearest_neighbour = .false. - - j = atoms_neighbour(this, i, n, distance=d, alt_connect=alt_connect) - if (d < (bond_length(this%Z(i),this%Z(j))*this%nneightol)) & - is_nearest_neighbour = .true. - - end function is_nearest_neighbour - - - !% As for 'calc_connect', but perform the connectivity update - !% hystertically: atoms must come within a relative distance of - !% 'cutoff_factor' to be considered neighbours, and then will remain - !% connected until them move apart further than a relative distance - !% of 'cutoff_break_factor' (all cutoff factors are relative - !% to covalent radii). - !% - !% Typically 'alt_connect' should be set to the - !% 'hysteretic_connect' attribute. 'origin' and 'extent' - !% vectors can be used to restrict the hysteretic region to only - !% part of the entire system -- the 'estimate_origin_extent()' - !% routine in clusters.f95 can be used to guess suitable values. - subroutine atoms_calc_connect_hysteretic(this, cutoff_factor, cutoff_break_factor, alt_connect, & - origin, extent, own_neighbour, store_is_min_image, store_n_neighb, error) - type(Atoms), intent(inout), target :: this - real(dp), intent(in) :: cutoff_factor, cutoff_break_factor - type(Connection), intent(inout), target, optional :: alt_connect - real(dp), optional, intent(in) :: origin(3), extent(3,3) - logical, optional, intent(in) :: own_neighbour, store_is_min_image, store_n_neighb - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if (this%pot_should_do_nn) this%pot_needs_new_connect = .true. - - if (present(alt_connect)) then - call calc_connect_hysteretic(alt_connect, this, cutoff_factor, cutoff_break_factor, & - origin, extent, own_neighbour, store_is_min_image, store_n_neighb, error) - PASS_ERROR(error) - else - call calc_connect_hysteretic(this%connect, this, cutoff_factor, cutoff_break_factor, & - origin, extent, own_neighbour, store_is_min_image, store_n_neighb, error) - PASS_ERROR(error) - endif - - end subroutine atoms_calc_connect_hysteretic - - - !% Fast $O(N)$ connectivity calculation routine. It divides the unit - !% cell into similarly shaped subcells, of sufficient size that - !% sphere of radius 'cutoff' is contained in a subcell, at least in - !% the directions in which the unit cell is big enough. For very - !% small unit cells, there is only one subcell, so the routine is - !% equivalent to the standard $O(N^2)$ method.> - !% If 'own_neighbour' is true, atoms can be neighbours with their - !% own periodic images. - !% If 'cutoff_skin' is present, effective cutoff is increased by this - !% amount, and full recalculation of connectivity is only done when - !% any atom has moved more than 0.5*cutoff_skin - otherwise - !% calc_dists() is called to update the stored distance tables. - subroutine atoms_calc_connect(this, alt_connect, own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb, max_pos_change, did_rebuild, error) - type(Atoms), intent(inout) :: this - type(Connection), optional, intent(inout) :: alt_connect - logical, optional, intent(in) :: own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb - real(dp), optional, intent(out) :: max_pos_change - logical, optional, intent(out) :: did_rebuild - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if (this%pot_should_do_nn) this%pot_needs_new_connect = .true. - - if (present(alt_connect)) then - call calc_connect(alt_connect, this, & - own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb, this%cutoff_skin, & - max_pos_change, did_rebuild, error) - PASS_ERROR(error) - else - call calc_connect(this%connect, this, & - own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb, this%cutoff_skin, & - max_pos_change, did_rebuild, error) - PASS_ERROR(error) - endif - - end subroutine atoms_calc_connect - - - !% Update stored distance tables. To be called after moving atoms, in between calls to calc_connect(). - subroutine atoms_calc_dists(this, alt_connect, parallel, error) - type(Atoms), intent(inout) :: this - type(Connection), optional, intent(inout) :: alt_connect - logical, optional, intent(in) :: parallel - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if (this%pot_should_do_nn) this%pot_needs_new_dists = .true. - - if (present(alt_connect)) then - call calc_dists(alt_connect, this, parallel, error) - PASS_ERROR(error) - else if (this%connect%initialised) then - call calc_dists(this%connect, this, parallel, error) - PASS_ERROR(error) - end if - - end subroutine atoms_calc_dists - - - !% Set which properties to communicate when - !% comm_atoms: Communicate when atom is moved to different domain. - !% Forces, for example, may be excluded since they are updated - !% on every time step. - !% comm_ghosts: Communicate when atom is dublicated as a ghost on a domain. - !% Masses, for example, might be excluded since atoms are - !% propagated on the domain they reside in only. - !% comm_reverse: Communicate back from ghost atoms to the original domain atom - !% and accumulate - !% By default, properties are not communicated. - subroutine atoms_set_comm_property(this, propname, & - comm_atoms, comm_ghosts, comm_reverse) - implicit none - - type(Atoms), intent(inout) :: this - character(*), intent(in) :: propname - logical, optional, intent(in) :: comm_atoms - logical, optional, intent(in) :: comm_ghosts - logical, optional, intent(in) :: comm_reverse - - ! --- - - call set_comm_property(this%domain, propname, & - comm_atoms, comm_ghosts, comm_reverse) - - endsubroutine atoms_set_comm_property - - - !% set Zs from species - subroutine atoms_set_Zs(this, error) - type(Atoms), intent(inout) :: this - integer, intent(out), optional :: ERROR - - integer i, ii - - INIT_ERROR(error) - - do i=1, this%N - ii = find_in_array(ElementName, a2s(this%species(:,i))) - if (ii < 1) then - RAISE_ERROR("failed to match name of atom "//i//" '"//a2s(this%species(:,i))//"'", error) - endif - this%Z(i) = ii-1 - end do - end subroutine atoms_set_Zs - - !% undo pbc jumps, assuming nearest periodic image, with or without persistent atoms object - !% without persistent atoms object, global storage is used, and calling on multiple trajcetories - !% interspersed will not work - subroutine undo_pbc_jumps(at, persistent) - type(Atoms), intent(inout) :: at - logical, optional, intent(in) :: persistent - - logical :: my_persistent - real(dp), pointer :: prev_pos_p(:,:) - - my_persistent = optional_default(.true., persistent) - if (.not. my_persistent) then - if (.not. allocated(save_prev_pos)) then - allocate(save_prev_pos(3, at%N)) - save_prev_pos = at%pos - else - if (size(save_prev_pos,2) /= at%N) then - call system_abort("undo_pbc_jumps got not persistent, but shape(save_prev_pos) "//shape(save_prev_pos)//" does not match shape(at%pos) "//shape(at%pos)) - endif - endif - prev_pos_p => save_prev_pos - else - if (.not. assign_pointer(at, 'prev_pos', prev_pos_p)) then - call add_property(at, 'prev_pos', 0.0_dp, n_cols=3, ptr2=prev_pos_p) - prev_pos_p = at%pos - endif - end if - - at%pos = at%pos - (at%lattice .mult. floor((at%g .mult. (at%pos-prev_pos_p))+0.5_dp)) - prev_pos_p = at%pos - end subroutine undo_pbc_jumps - - !% undo center of mass motion, with or without persistent atoms object - !% without persistent atoms object, global storage is used, and calling on multiple trajcetories - !% interspersed will not work - subroutine undo_CoM_motion(at, persistent) - type(Atoms), intent(inout) :: at - logical, optional, intent(in) :: persistent - - integer :: i - real(dp) :: orig_CoM(3), CoM(3), delta_CoM(3) - logical :: my_persistent - - my_persistent = optional_default(.true., persistent) - - ! calc current CoM - if (.not. has_property(at, 'mass')) then - call add_property(at, 'mass', 0.0_dp) - at%mass = ElementMass(at%Z) - endif - CoM = centre_of_mass(at, origin=0) - - if (my_persistent) then - ! get orig_CoM from at%params - if (.not. get_value(at%params, 'orig_CoM', orig_CoM)) then - orig_CoM = CoM - call set_value(at%params, 'orig_CoM', orig_CoM) - endif - else - ! get orig_CoM from save_orig_CoM - if (.not. allocated(save_orig_CoM)) then - allocate(save_orig_CoM(3)) - save_orig_CoM = CoM - orig_CoM = CoM - else - orig_CoM = save_orig_CoM - endif - endif - - delta_CoM = orig_CoM - CoM - do i=1, at%N - at%pos(:,i) = at%pos(:,i) + delta_CoM - end do - - end subroutine undo_CoM_motion - - !% calculate mean squared displacement, with or without persistent atoms object - !% without persistent atoms object, global storage is used, and calling on multiple trajcetories - !% interspersed will not work. - !% usually desirable to call undo_pbc_jumps and undo_CoM_motion first - subroutine calc_msd(at, mask, reset_msd, persistent) - type(Atoms), intent(inout) :: at - logical, optional, intent(in) :: mask(:), reset_msd, persistent - - logical :: my_reset_msd, my_persistent - real(dp), pointer :: orig_pos_p(:,:), msd_displ_p(:,:), msd_displ_mag_p(:) - - my_reset_msd = optional_default(.false., reset_msd) - my_persistent = optional_default(.true., persistent) - - ! get/save orig_pos - if (.not. my_persistent) then - if (.not. allocated(save_orig_pos)) then - allocate(save_orig_pos(3, at%N)) - save_orig_pos = at%pos - else - if (size(save_orig_pos,2) /= at%N) then - call system_abort("calc_msd got not persistent, but shape(save_orig_pos) "//shape(save_orig_pos)//" does not match shape(at%pos) "//shape(at%pos)) - endif - endif - orig_pos_p => save_orig_pos - else - if (.not. assign_pointer(at, 'orig_pos', orig_pos_p)) then - call add_property(at, 'orig_pos', 0.0_dp, n_cols=3, ptr2=orig_pos_p) - orig_pos_p = at%pos - endif - end if - if (my_reset_msd) orig_pos_p = at%pos - - if (.not. assign_pointer(at, 'msd_displ', msd_displ_p)) then - call add_property(at, 'msd_displ', 0.0_dp, n_cols=3, ptr2 = msd_displ_p) - endif - if (.not. assign_pointer(at, 'msd_displ_mag', msd_displ_mag_p)) then - call add_property(at, 'msd_displ_mag', 0.0_dp, n_cols=1, ptr = msd_displ_mag_p) - endif - - msd_displ_p = at%pos - orig_pos_p - msd_displ_mag_p = sum(msd_displ_p**2, 1) - - if (present(mask)) then - call set_value(at%params, 'msd', sum(msd_displ_mag_p,mask=mask)/real(count(mask),dp)) - else - call set_value(at%params, 'msd', sum(msd_displ_mag_p)/real(at%N,dp)) - endif - - end subroutine calc_msd - - subroutine fake_smooth_pos(at, mix, persistent) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: mix - logical, optional, intent(in) :: persistent - - logical :: my_persistent - real(dp), pointer :: smooth_pos_p(:,:) - real(dp) :: smooth_lattice(3,3) - - my_persistent = optional_default(.true., persistent) - - if (.not. my_persistent) then - if (.not. allocated(save_smooth_pos)) then ! first config - allocate(save_smooth_pos(3, at%N)) - save_smooth_pos = at%pos - save_smooth_lattice = at%lattice - else ! later config - if (size(save_smooth_pos,2) /= at%N) then - call system_abort("calc_msd got not persistent, but shape(save_smooth_pos) "//shape(save_smooth_pos)//" does not match shape(at%pos) "//shape(at%pos)) - endif - endif - smooth_pos_p => save_smooth_pos - call add_property_from_pointer(at, 'smooth_pos', smooth_pos_p) - else ! persistent - if (.not. assign_pointer(at, 'smooth_pos', smooth_pos_p)) then - call add_property(at, 'smooth_pos', 0.0_dp, n_cols=3, ptr2=smooth_pos_p) - smooth_pos_p = at%pos - endif - call get_param_value(at, 'smooth_lattice', save_smooth_lattice) - end if - - smooth_pos_p = (1.0_dp-mix)*smooth_pos_p + mix*at%pos - smooth_lattice = (1.0_dp-mix)*save_smooth_lattice + mix*at%lattice - call set_param_value(at, 'smooth_lattice', smooth_lattice) - - if (.not. my_persistent) save_smooth_lattice = smooth_lattice - - end subroutine fake_smooth_pos - -end module atoms_module diff --git a/src/libAtoms/Atoms_ll.f95 b/src/libAtoms/Atoms_ll.f95 deleted file mode 100644 index 0852c97dc7..0000000000 --- a/src/libAtoms/Atoms_ll.f95 +++ /dev/null @@ -1,391 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!% Atoms_ll_module -!% linked list of Atoms structures, read in from one or more xyz files, with -!% some automatic time sorting/clean-up capability - -#include "error.inc" - -module Atoms_ll_module -use error_module -use system_module -use extendable_str_module -use dictionary_module -use atoms_module -use cinoutput_module -implicit none -private - -public :: atoms_ll, atoms_ll_entry - -type atoms_ll - type (atoms_ll_entry), pointer :: first => null() - type (atoms_ll_entry), pointer :: last => null() -end type atoms_ll - -type atoms_ll_entry - type(atoms) :: at - type(atoms_ll_entry), pointer :: next => null() - type(atoms_ll_entry), pointer :: prev => null() - real(dp) :: r_index = -1.0_dp -end type atoms_ll_entry - -public :: initialise, finalise, print_xyz, read_xyz, new_entry, remove_last_entry - -interface initialise - module procedure atoms_ll_initialise, atoms_ll_entry_initialise -end interface initialise - -interface finalise - module procedure atoms_ll_finalise, atoms_ll_entry_finalise -end interface finalise - -!% print all configs in atoms_ll object -interface print_xyz - module procedure atoms_ll_print_xyz -end interface - -!% read configs into atoms_ll object -interface read_xyz - module procedure atoms_ll_read_xyz_filename -end interface - -!% add new entry to atoms linked list structure -interface new_entry - module procedure atoms_ll_new_entry -end interface new_entry - -!% remove last entry from atoms linked list structure -interface remove_last_entry - module procedure atoms_ll_remove_last_entry -end interface remove_last_entry - -contains - - subroutine atoms_ll_initialise(this) - type(Atoms_ll), intent(inout) :: this - - call finalise(this) - end subroutine atoms_ll_initialise - - subroutine atoms_ll_finalise(this) - type(Atoms_ll), intent(inout) :: this - - type(atoms_ll_entry), pointer :: entry, next - - entry => this%first - do while (associated(entry)) - next => entry%next - call finalise(entry) - entry => next - end do - this%first => null() - this%last => null() - end subroutine atoms_ll_finalise - - subroutine atoms_ll_entry_initialise(this) - type(Atoms_ll_entry), intent(inout) :: this - - call finalise(this) - end subroutine atoms_ll_entry_initialise - - subroutine atoms_ll_entry_finalise(this) - type(Atoms_ll_entry), intent(inout) :: this - - call finalise(this%at) - this%next => null() - this%prev => null() - end subroutine atoms_ll_entry_finalise - - subroutine atoms_ll_new_entry(this, atoms_p, before, after) - type(atoms_ll), target, intent(inout) :: this !% this: atoms_ll object to add to - type(atoms), intent(inout), pointer :: atoms_p !% atoms_p: pointer to atoms object to insert - type(atoms_ll_entry), intent(in), target, optional :: before, after !% before, after: if present, put in new entry before/after this one - !% before and after are mutually exclusive - - type(atoms_ll_entry), pointer :: my_before, my_after - type(atoms_ll_entry), pointer :: entry - - if (present(before) .and. present(after)) call system_abort("atoms_ll_new_entry got both before and after") - - if (present(before)) then - my_before => before - my_after => before%prev - else if (present(after)) then - my_before => after%next - my_after => after - else - my_after => this%last - my_before => null() - endif - - allocate(entry) - if (associated(my_before)) then - my_before%prev => entry - entry%next => my_before - else - this%last => entry - endif - if (associated(my_after)) then - my_after%next => entry - entry%prev => my_after - else - this%first => entry - endif - - atoms_p => entry%at - end subroutine atoms_ll_new_entry - - subroutine atoms_ll_remove_last_entry(this) - type(atoms_ll), target, intent(inout) :: this - - if (associated(this%last)) then - call finalise(this%last%at) - if (associated(this%last%prev)) nullify(this%last%prev%next) - this%last => this%last%prev - if (.not. associated (this%last)) nullify(this%first) - endif - - end subroutine atoms_ll_remove_last_entry - - - subroutine atoms_ll_print_xyz(this, xyzfile, comment, properties, real_format, mask) - type(Atoms_ll), intent(inout) :: this !% Atoms_ll object to print - type(CInoutput), intent(inout) :: xyzfile !% CInOutput object to write to - character(*), optional, intent(in) :: properties !% List of properties to print - character(*), optional, intent(in) :: comment !% Comment line (line #2 of xyz file) - character(len=*), optional, intent(in) :: real_format !% format of real numbers in output - logical, optional, intent(in) :: mask(:) !% mask of which atoms to print - - - type(extendable_str) :: my_comment - type(atoms_ll_entry), pointer :: entry - integer :: i - - call initialise(my_comment) - if (present(comment)) call concat(my_comment, comment) - - if (present(mask)) call system_abort('atoms_ll_print_xyz: mask argument not currently supported. if you need it, please reimplement!') - - entry => this%first - i = 1 - do while (associated(entry)) - call set_value(entry%at%params, 'comment', my_comment) - call set_value(entry%at%params, 'atoms_ll_i', i) - call write(xyzfile, entry%at, properties, real_format=real_format) - entry => entry%next - i = i + 1 - end do - call finalise(my_comment) - - end subroutine atoms_ll_print_xyz - - !% reads a sequence of configurations with cinoutput, optionally skipping every decimation frames, - !% ignoring things outside of min_time--max_time, sorting by Time value and eliminating configs with - !% duplicate Time values. - subroutine atoms_ll_read_xyz_filename(this, filename, file_is_list, decimation, min_time, max_time, sort_Time, no_Time_dups, quiet, no_compute_index, & - properties, all_properties, error) - type(atoms_ll) :: this !% object to read configs into - character(len=*), intent(in) :: filename !% file name to read from - logical, intent(in) :: file_is_list !% is true, file is list of files to read from rather than xyz file - integer, intent(in), optional :: decimation !% only read one out of every decimation frames - real(dp), intent(in), optional :: min_time, max_time !% ignore frames before min_time or after max_time - character(len=*), intent(in), optional :: properties !% properties to include in objects in list - logical, intent(in), optional :: sort_Time, no_Time_dups, quiet, no_compute_index, all_properties - integer, intent(out), optional :: error - !% sort_time: if true, sort configurations by time - !% no_Times_dups: if true, eliminate configs that have same time value - !% quiet: if true, don't output progress bar - !% no_compute_index: if true, don't compute index for xyz file - !% do_all_properties: if true, include all properties in save Atoms structures - - integer :: status - integer :: frame_count, last_file_frame_n - type(CInOutput) :: cfile - type(Inoutput) file_list - character(len=len(filename)) my_filename - type(Atoms) :: structure_in - type(Atoms), pointer :: structure - logical :: skip_frame - real(dp) :: cur_time, entry_time, entry_PREV_time - integer :: do_decimation - real(dp) :: do_min_time, do_max_time - logical :: do_sort_Time, do_no_Time_dups, do_quiet, do_no_compute_index - type(Atoms_ll_entry), pointer :: entry - logical :: is_a_dup, do_all_properties - character(len=STRING_LENGTH) :: my_properties - integer :: initial_frame_count - integer :: l_error - - INIT_ERROR(error) - my_properties = optional_default("species:pos:Z", properties) - do_all_properties = optional_default(.false., all_properties) - do_decimation = optional_default(1, decimation) - do_min_time = optional_default(-1.0_dp, min_time) - do_max_time = optional_default(-1.0_dp, max_time) - do_sort_Time = optional_default(.false., sort_Time) - do_no_Time_dups = optional_default(.false., no_Time_dups) - do_quiet = optional_default(.false., quiet) - do_no_compute_index = optional_default(.false., no_compute_index) - - if (len_trim(my_properties) == 0) then - call print("WARNING: len_trim(my_properties) == 0, doing all_properties") - do_all_properties=.true. - endif - - if (do_no_Time_dups .and. .not. do_sort_Time) then - RAISE_ERROR("ERROR: atoms_ll_read_xyz no_Times_dups requires sort_Time", error) - endif - - if (do_decimation /= 1 .and. do_no_Time_dups) then - RAISE_ERROR("ERROR: atoms_ll_read_xyz decimation="//do_decimation//" /= 1 and no_Time_dups=T conflict", error) - endif - - if (file_is_list) then - call initialise(file_list, trim(filename), INPUT) - my_filename = read_line(file_list) - else - my_filename = trim(filename) - endif - - cur_time = 1.0_dp - last_file_frame_n = 0 - frame_count = 1 - status = 0 - l_error = ERROR_NONE - do while (l_error == ERROR_NONE) ! loop over files - call initialise(cfile,trim(my_filename),action=INPUT, no_compute_index=do_no_compute_index) - initial_frame_count = frame_count - do while (l_error == ERROR_NONE) ! loop over frames in this file - if (.not. do_quiet) write(mainlog%unit,'(4a,i0,a,i0,$)') achar(13), 'Read file ',trim(my_filename), & - ' Frame ',frame_count,' which in this file is frame (zero based) ',(frame_count-1-last_file_frame_n) - ! if (.not. do_quiet) write(mainlog%unit,'(3a,i0,a,i0)') 'Read file ',trim(my_filename), & - ! ' Frame ',frame_count,' which in this file is frame (zero based) ',(frame_count-1-last_file_frame_n) - call read(cfile, structure_in, frame=frame_count-1-last_file_frame_n, error=l_error) - - if (l_error == ERROR_NONE) then ! we succesfully read a structure - skip_frame = .false. - is_a_dup = .false. - if (do_min_time > 0.0_dp .or. do_max_time > 0.0_dp .or. do_sort_Time .or. no_Time_dups) then ! we need Time value - if (get_value(structure_in%params,"Time",cur_time, case_sensitive=.false.)) then - if ((do_min_time >= 0.0_dp .and. cur_time < do_min_time) .or. (do_max_time >= 0.0_dp .and. cur_time > do_max_time)) skip_frame = .true. - else - RAISE_ERROR("ERROR: min_time="//do_min_time//" < 0 or max_time="//do_max_time//" < 0 or sort_Time="//do_sort_Time//", but Time field wasn't found in config " // frame_count, error) - endif - endif - if (.not. skip_frame) then ! frame is in appropriate time range - if (do_sort_Time) then ! sort by Time value - ! look at LAST entry - if (associated(this%LAST)) then - entry => this%LAST - !NB if (.not. get_value(entry%at%params, "Time", entry_time, case_sensitive=.false.)) call system_abort("atoms_ll_read_xyz sort missing Time for LAST entry") - entry_time = entry%r_index - !NB - else ! no structure list yet, fake entry_time - entry_time = -1.0e38_dp - nullify(entry) - endif - if (cur_time <= entry_time) then ! new frame is at or BEFORE LAST entry - do while (associated(entry)) - !NB if (.not. get_value(entry%at%params, "Time", entry_time, case_sensitive=.false.)) call system_abort("atoms_ll_read_xyz sort missing Time for entry") - entry_time = entry%r_index - !NB - if (do_no_Time_dups .and. (cur_time == entry_time)) then ! entries match in time, i.e. duplicates - is_a_dup = .true. - exit - endif - ! check time of PREV entry - if (associated(entry%PREV)) then - !NB if (.not. get_value(entry%PREV%at%params, "Time", entry_PREV_time, case_sensitive=.false.)) call system_abort("atoms_ll_read_xyz sort missing Time for entry%PREV") - entry_PREV_time = entry%PREV%r_index - !NB - ! if cur_time is <= entry, and cur_time > entry%PREV, we want to insert AFTER entry%prev, so decrement entry and exit now - if ((cur_time <= entry_time) .and. (cur_time > entry_PREV_time)) then - entry => entry%PREV - exit - endif - endif - ! otherwise we keep on going - entry => entry%PREV ! entry will be unassociated, and therefore loop will end, if we got to beginning of list - end do ! associated(entry) - end if ! cur frame was BEFORE last entry - ! we skipped previous section if cur_time > entry_time for LAST entry, so we want to insert AFTER entry=this%LAST - else ! no sorting in time, so always insert AFTER last - entry => this%last - endif - if (.not. is_a_dup) then - if (associated(entry)) then ! we want to insert AFTER entry - call new_entry(this, structure, AFTER=entry) - entry%NEXT%r_index = cur_time - else ! entry is unassociated, therefore we insert and the BEGINNING of the list - call new_entry(this, structure, BEFORE=this%FIRST) - this%FIRST%r_index = cur_time - endif - ! actually copy the structure - if (do_all_properties) then - call atoms_copy_without_connect(structure, structure_in) - else - call atoms_copy_without_connect(structure, structure_in, properties=my_properties) - endif - endif - if (.not. do_quiet) write (mainlog%unit,'(a,$)') " " - ! if (.not. do_quiet) write (mainlog%unit,'(a)') " " - else ! skip_frame was true, we're skipping - if (.not. do_quiet) write (mainlog%unit,'(a,$)') " skip " - ! if (.not. do_quiet) write (mainlog%unit,'(a)') " skip" - endif ! skip_frame - frame_count = frame_count + do_decimation - else - CLEAR_ERROR(error) - endif ! l_error == 0 for reading this structure - - end do ! while l_error == 0 for frames in this file - if (cfile%got_index) then - last_file_frame_n = last_file_frame_n + cfile%n_frame - else - last_file_frame_n = last_file_frame_n + cfile%current_frame - endif - !call print("at end of file, frame_count " // frame_count // " last_file_frame_n " // last_file_frame_n) - call finalise(cfile) - - if (file_is_list) then - my_filename = read_line(file_list, status) - if (status /= 0) call finalise(file_list) - else - status = 1 - endif - - end do ! while status == 0 for each file - - if (.not. quiet) call print("") - end subroutine atoms_ll_read_xyz_filename - -end module Atoms_ll_module diff --git a/src/libAtoms/Atoms_types.f95 b/src/libAtoms/Atoms_types.f95 deleted file mode 100644 index c6b56db8ff..0000000000 --- a/src/libAtoms/Atoms_types.f95 +++ /dev/null @@ -1,1779 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Atoms_types module -!X -!X 'Header' module that contains the data structures for -!X 1. Atoms -!X 2. Connection -!X 3. DomainDecomposition -!X plus methods for manipulating properties. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module Atoms_types_module - - use error_module - use system_module - use units_module - use periodictable_module - use linearalgebra_module - use MPI_context_module - use extendable_str_module - use dictionary_module - use table_module - - implicit none - private - - public :: DEFAULT_NNEIGHTOL - real(dp), parameter :: DEFAULT_NNEIGHTOL = 1.2_dp !% Default value for 'atoms%nneightol' - - public :: DD_WRAP_TO_CELL, DD_WRAP_TO_DOMAIN - - integer, parameter :: DD_WRAP_TO_CELL = 1 !% All particles, including ghosts, are wrapped into the cell - integer, parameter :: DD_WRAP_TO_DOMAIN = 2 !% Particles are wrapped into the domain, ghost particles are - !% located next to the domain. - - public :: Table_pointer - type Table_pointer - type(Table), pointer :: t => null() - end type Table_pointer - - public :: Connection - type Connection - !% The Connection type stores the topology of a set of Atoms - !% - !% We do not use a minimum image convention, rather, collect all the images of a neigbouring atoms - !% that fall within the neighbour cutoff. The different images are made distinct in the connection list - !% by having different 'shift' vectors associated with them. - !% - !% To save storage, the 'neighbour1' table contains all information about the connection - !% but is only filled in for $i <= j$. 'neighbour2' is just a list of those of $i$'s neighbours - !% with $i > j$ together with an index into the 'neighbour1' table of atom $j$. - !% - !% In normal use (i.e. outside this module) you don\'t need direct access to the tables - !% so you should use the interface functions 'atoms_n_neighbours' and 'atoms_neighbour' which - !% hide the distiction between the cases $i <= j$ and $i > j$. - !% - !% :class:`Table` :attr:`neighbour1` (i): $i \le j$ for all $j$ in table, ``intsize=4``, ``realsize=1`` - !% - !% 'connect%neighbour1(i)%int' - !% - !%> +----------+----------+----------+----------+ - !%> | 1 | 2 | 3 | 4 | - !%> +----------+----------+----------+----------+ - !%> | j | shift_a | shift_b | shift_c | - !%> +----------+----------+----------+----------+ - !% - !% 'connect%neighbour1(i)%real' - !% - !%> +----------+ - !%> | 1 | - !%> +----------+ - !%> | r_ij | - !%> +----------+ - !% - !% :class:`Table` :attr:`neighbour2` (i): $i > j$ for all $j$ in table, ``intsize =2``, ``realsize=0`` - !% - !% 'connect%neighbour2(i)%int' - !% - !%> +----------+----------+ - !%> | 1 | 2 | - !%> +----------+----------+ - !%> | j | n | - !%> +----------+----------+ - !% - !% :class:`Table` :attr:`cell` (i,j,k) with ``intsize = 1``, ``realsize = 0`` - !% - !% 'connect%cell(i,j,k)2%int' - !% - !%> +----------+ - !%> | 1 | - !%> +----------+ - !%> | atom | - !%> +----------+ - !% - !% N.B. If $i$ and $j$ are neighbours with shift 'shift', then - !% 'norm(atoms%pos(j) - atoms%pos(i) + shift)' is a minimum. - !% Mnemonic: 'shift' is added to $j$ to get closer to $i$. - - logical :: initialised = .false. - logical :: cells_initialised = .false. - logical :: too_few_cells_warning_issued = .false. - - integer :: cellsNa !% no. of cells in the lattice directions - integer :: cellsNb, cellsNc - - integer :: N = -1 !% no. of atoms at last calc_connect - - type(table_pointer), allocatable, dimension(:) :: neighbour1 !% Neighbour information for pairs $i <= j$. - !% Contains full details of $j$, $r_{ij}$ and shift. - type(table_pointer), allocatable, dimension(:) :: neighbour2 !% Neighbour information for pairs $i > j$. - !% Simply contains $j$ and a reference to $j$'s - !% 'neighbour1' table. - - integer, allocatable, dimension(:,:,:) :: cell_heads !% First entry in cell atoms structure - integer, allocatable, dimension(:) :: next_atom_in_cell !% List of atoms, terminated by zero - - logical, allocatable, dimension(:) :: is_min_image !% True if i is a minimum image - - real(dp) :: last_connect_cutoff !% Value of cutoff used last time connectivity was updated - real(dp), allocatable, dimension(:,:) :: last_connect_pos !% Positions of atoms last time connnectivity was updated - real(dp), dimension(3,3) :: last_connect_lattice !% Lattice last time connectivity was updated - - end type Connection - - - public :: DomainDecomposition - type DomainDecomposition - - integer :: Ntotal = 0 !% Number of total particles in this simulation - integer, pointer :: local_to_global(:) => NULL() !% Local index to global index - integer, allocatable :: global_to_local(:) !% Global index to local index - - integer :: decomposition(3) = (/ 1, 1, 1 /) !% Type of decomposition - - integer :: mode = DD_WRAP_TO_CELL - - logical :: decomposed = .false. !% True if domain decomposition is active - - real(dp) :: requested_border = 0.0_DP - real(dp) :: border(3) = 0.0_DP - real(dp) :: verlet_shell = 0.0_DP - - logical :: communicate_forces = .false. - - real(dp) :: lower(3) = 0.0_DP !% Lower domain boundary, in fraction of the total cell - real(dp) :: upper(3) = 0.0_DP !% Upper domain boundary, in fraction of the total cell - real(dp) :: center(3) = 0.0_DP !% Center of the domain - real(dp) :: lower_with_border(3) = 0.0_DP !% Lower domain boundary, including border - real(dp) :: upper_with_border(3) = 0.0_DP !% Upper domain boundary, including border - - type(MPI_context) :: mpi !% MPI communicator - logical :: periodic(3) = .true. !% Periodicity for domain decomposition - integer :: l(3) = 0 !% Ranks of left domains in x-, y- and z-direction - integer :: r(3) = 0 !% Ranks of right domains in x-, y- and z-direction - real(dp) :: off_l(3) = 0.0_DP !% Distance vector to left domain - real(dp) :: off_r(3) = 0.0_DP !% Distance vector to right domain - - type(Dictionary) :: atoms_properties !% Fields to communicate if for particles - type(Dictionary) :: ghost_properties !% Fields to communicate for ghosts - type(Dictionary) :: reverse_properties !% Back-communication after force computations - - logical, allocatable :: atoms_mask(:) - logical, allocatable :: ghost_mask(:) - logical, allocatable :: reverse_mask(:) - - integer :: atoms_buffer_size = 0 - integer :: ghost_buffer_size = 0 - integer :: reverse_buffer_size = 0 - - character(1), allocatable :: send_l(:) !% buffer for sending to the left - character(1), allocatable :: send_r(:) !% buffer for sending to the right - character(1), allocatable :: recv_l(:) !% buffer for receiving from the left - character(1), allocatable :: recv_r(:) !% buffer for receiving from the right - - integer :: n_ghosts_r(3) = 0 !% length of the ghost particle lists (right) - integer :: n_ghosts_l(3) = 0 !% length of the ghost particle lists (left) - - integer, allocatable :: ghosts_r(:) !% particles send to the right (where they become ghosts) - integer, allocatable :: ghosts_l(:) !% particles send to the left (where they become ghosts) - - integer :: n_send_p_tot !% Statistics: Number of total particles send - integer :: n_recv_p_tot !% Statistics: Number of total particles received - integer :: n_send_g_tot !% Statistics: Number of total ghosts send - integer :: n_recv_g_tot !% Statistics: Number of total ghosts received - integer :: nit_p !% Statistics: Number of particle send events - integer :: nit_g !% Statistics: Number of ghost send events - - endtype DomainDecomposition - - - public :: Atoms - type Atoms - !% Representation of an atomic configuration and its associated properties - !% - !% An atoms object contains atomic numbers, all dynamical variables - !% and connectivity information for all the atoms in the simulation cell. - !% It is initialised like this: - !%> call initialise(MyAtoms,N,lattice) - !% where 'N' is the number of atoms to allocate space for and 'lattice' is a $3\times3$ - !% matrix of lattice vectors given as column vectors, so that 'lattice(:,i)' is the i-th lattice vector. - !% - !% Atoms also contains a Connection object, which stores distance information about - !% the atom neghbours after 'calc_connect' has been called. Rather than using a minimum - !% image convention, all neighbours are stored up to a radius of 'cutoff', including images - - ! Self-deallocating object - logical :: own_this = .false. !% Do I own myself? - integer :: ref_count = 0 !% Reference counter - - logical :: fixed_size = .false. !% Can the number of atoms be changed after initialisation? - integer :: N = 0 !% The number of atoms held (including ghost particles) - integer :: Ndomain = 0 !% The number of atoms held by the local process (excluding ghost particles) - integer :: Nbuffer = 0 !% The number of atoms that can be stored in the buffers of this Atoms object - - real(dp) :: cutoff = -1.0_dp !% Cutoff distance for neighbour calculations. Default -1.0 (unset). - real(dp) :: cutoff_skin = 0.0_dp !% If set, increase cutoff by this amount to reduce calc_connect() frequency - logical :: pot_should_do_nn = .false., pot_needs_new_connect = .false., pot_needs_new_dists = .false. - real(dp) :: nneightol = DEFAULT_NNEIGHTOL - !% Count as nearest neighbour if sum of covalent radii - !% times 'this%nneightol' greater than distance between atoms. - !% Used in cluster carving. - - real(dp), dimension(3,3) :: lattice !% Lattice vectors, as columns: - !%\begin{displaymath} - !%\left( - !%\begin{array}{ccc} - !% | & | & | \\ \mathbf{a} & \mathbf{b} & \mathbf{c} \\ | & | & | \\ \end{array} - !%\right) - !% = \left( - !%\begin{array}{ccc} - !% R_{11} & R_{12} & R_{13} \\ R_{21} & R_{22} & R_{23} \\ R_{31} & R_{32} & R_{33} \\ \end{array} - !%\right) - !%\end{displaymath} - !% i.e. $\mathbf{a}$ = 'lattice(:,1)', $\mathbf{b}$ = 'lattice(:,2)' and - !% $\mathbf{c}$ 'lattice(:,3)'. - - ! ( | | | | | | ) ( (1,1) (1,2) (1,3) ) - ! ( | | | | | | ) ( ) - ! ( |a| |b| |c| ) = ( (2,1) (2,2) (2,3) ) - ! ( | | | | | | ) ( ) - ! ( | | | | | | ) ( (3,1) (3,2) (3,3) ) - logical :: is_orthorhombic, is_periodic(3) - - - real(dp), dimension(3,3) :: g !% Inverse lattice (stored for speed) - - type(Dictionary) :: properties !% :class:`~.Dictionary` of atomic properties. A property is an array - !% of shape (`m`,`n`) where `n` is the number of atoms and `m` is - !% either one (for scalar properties) or three (vector - !% properties). Properties can be integer, real, string or logical. - !% String properties have a fixed length of ``TABLE_STRING_LENGTH=10`` - !% characters. - !% - !% From Fortran, the following default properties are aliased with - !% arrays within the Atoms type: - !% - !% * ``Z`` - Atomic numbers, dimension is actually $(N)$ - !% * ``species`` Names of elements - !% * ``move_mask`` Atoms with 'move_mask' set to zero are fixed - !% * ``damp_mask`` Damping is only applied to those atoms with 'damp_mask' set to 1. By default this is set to 1 for all atoms. - !% * ``thermostat_region`` Which thermostat is applied to each atoms. By default this is set to 1 for all atoms. - !% * ``travel`` Travel across periodic conditions. $(3,N)$ integer array. See meth:`map_into_cell` below. - !% * ``pos`` $(3,N)$ array of atomic positions, in $\mathrm{\AA}$. Position of atom $i$ is 'pos(:,i)' - !% * ``mass`` Atomic masses, dimension is $(N)$ - !% * ``velo`` $(3,N)$ array of atomic velocities, in $\mathrm{AA}$/fs. - !% * ``acc`` $(3,N)$ array of accelerations in $\mathrm{AA}$/fs$^2$ - !% * ``avgpos`` $(3,N)$ array of time-averaged atomic positions. - !% * ``oldpos`` $(3,N)$ array of positions of atoms at previous time step. - !% * ``avg_ke`` Time-averaged atomic kinetic energy - !% - !% Custom properties are most conveniently accessed by assign a pointer to - !% them with the :meth:`assign_pointer` routines. - !% - !% From Python, each property is automatically visible as a - !% array attribute of the :class:`Atoms` object, - !% for example the atomic positions are stored in a real vector - !% property called `pos`, and can be accessed as ``at.pos``. - !% - !% Properties can be added with the :meth:`add_property` method and - !% removed with :meth:`remove_property`. - - type(Dictionary) :: params !% :class:`~.Dictionary` of parameters. Useful for storing data about this - !% Atoms object, for example the temperature, total energy or - !% applied strain. The data stored here is automatically saved to - !% and loaded from XYZ and NetCDF files. - - integer, pointer, dimension(:) :: Z => null() !% Atomic numbers, dimension is actually $(N)$ - character(1), pointer, dimension(:,:) :: species => null() !% Names of elements - - integer, pointer, dimension(:) :: move_mask => null() !% Atoms with 'move_mask' set to false are fixed - integer, pointer, dimension(:) :: damp_mask => null() !% Damping is only applied to those atoms with - !% 'damp_mask' set to 1. - !% By default this is set to 1 for all atoms. - - integer, pointer, dimension(:) :: thermostat_region => null() !% Which thermostat is applied to each atoms. - !% By default this is set to 1 for all atoms. - - integer, pointer, dimension(:,:) :: travel => null() !% Travel across periodic conditions. Actually $(3,N)$ array. - !% See 'map_into_cell' below. - real(dp), pointer, dimension(:,:) :: pos => null() !% $(3,N)$ array of atomic positions, in $\mathrm{AA}$. - !% Position of atom $i$ is 'pos(:,i)' - real(dp), pointer, dimension(:) :: mass => null() !% Atomic masses, dimension is actually $(N)$ - - real(dp), pointer, dimension(:,:) :: velo => null() !% $(3,N)$ array of atomic velocities, in $\mathrm{AA}$/fs. - real(dp), pointer, dimension(:,:) :: acc => null() !% $(3,N)$ array of accelerations in $\mathrm{AA}$/fs$^2$ - real(dp), pointer, dimension(:,:) :: avgpos => null() !% $(3,N)$ array of time-averaged atomic positions. - real(dp), pointer, dimension(:,:) :: oldpos => null() !% $(3,N)$ array of positions of atoms at previous time step. - real(dp), pointer, dimension(:) :: avg_ke => null() !% Time-averaged atomic kinetic energy - - type(Connection) :: connect !% :class:`~.Connection` object - type(Connection) :: hysteretic_connect !% Hysteretic :class:`~.Connection` object - - type(DomainDecomposition) :: domain !% Domain decomposition object - - end type Atoms - - - !% Add a per-atom property to this atoms object, as extra entry with columns of - !% integers, reals, logical, or strings in the 'properties' dictionary. For example, - !% this interface is used by the DynamicalSystems module to create the 'velo', 'acc', - !% etc. properties. - !% Optionally, a pointer to the new property is returned. - public :: add_property - interface add_property - module procedure atoms_add_property_int, atoms_add_property_int_a - module procedure atoms_add_property_real, atoms_add_property_real_a - module procedure atoms_add_property_str, atoms_add_property_str_2da - module procedure atoms_add_property_str_a - module procedure atoms_add_property_logical, atoms_add_property_logical_a - module procedure atoms_add_property_int_2Da - module procedure atoms_add_property_real_2Da - end interface - - !% Add a per-atom property to this atoms object, but point to existing space - !% rather than allocating new space for it (as add_property does). - public :: add_property_from_pointer - interface add_property_from_pointer - module procedure atoms_add_property_p_int, atoms_add_property_p_int_a - module procedure atoms_add_property_p_real, atoms_add_property_p_real_a - module procedure atoms_add_property_p_str - module procedure atoms_add_property_p_logical - end interface - - - !% This is a convenience interface to assign pointers to custom properties of this - !% Atoms object. The pointer is simply directed to the relevant array in the - !% 'this%properties' Dictionary. Adding or removing atoms will invalidate these pointers. - !% Returns true if successful, false if property doesn't exist or - !% if property type and type of pointer don't match. - !% OUTDATED - replace by subroutine assign_property_pointer with error handling - public :: assign_pointer - interface assign_pointer - module procedure atoms_assign_pointer_int1D, atoms_assign_pointer_int2D - module procedure atoms_assign_pointer_real1D, atoms_assign_pointer_real2D - module procedure atoms_assign_pointer_str - module procedure atoms_assign_pointer_logical - end interface - - - !% This is a convenience interface to assign pointers to custom properties of this - !% Atoms object. The pointer is simply directed to the relevant array in the - !% 'this%properties' Dictionary. Adding or removing atoms will invalidate these pointers. - !% Raises error for failure - public :: assign_property_pointer - interface assign_property_pointer - module procedure atoms_assign_prop_ptr_int1D, atoms_assign_prop_ptr_int2D - module procedure atoms_assign_prop_ptr_real1D, atoms_assign_prop_ptr_real2D - module procedure atoms_assign_prop_ptr_str - module procedure atoms_assign_prop_ptr_logical - end interface - - - !% Copy an atom to a different index - public :: copy_entry - interface copy_entry - module procedure atoms_copy_entry - endinterface copy_entry - - - ! Note: These are Atoms unrelated, and could be easily move somewhere else - ! (linearalgebra?) - public :: map_into_cell - interface map_into_cell - module procedure vec_map_into_cell, array_map_into_cell - end interface - - public :: cell_volume - interface cell_volume - module procedure lattice_cell_volume - end interface - - !% This interface calculates the distance between the nearest periodic images of two points (or atoms). - - !% Return minimum image distance between two atoms or positions. - !% End points can be specified by any combination of atoms indices - !% 'i' and 'j' and absolute coordinates 'u' and 'w'. If 'shift' is - !% present the periodic shift between the two atoms or points will - !% be returned in it. - interface distance_min_image - module procedure distance8_atom_atom, distance8_atom_vec, distance8_vec_atom, distance8_vec_vec - end interface - - !% Return the minimum image difference vector between two atoms or - !% positions. End points can be specified by any combination of - !% atoms indices 'i' and 'j' and absolute coordinates 'u' and - !% 'w'. - interface diff_min_image - module procedure diff_atom_atom, diff_atom_vec, diff_vec_atom, diff_vec_vec - end interface - - public :: atoms_repoint, atoms_sort, bond_length, distance, diff, realpos, distance_min_image, diff_min_image - -contains - - !% OMIT - ! Initialise pointers for convenient access to special columns of this%properties - subroutine atoms_repoint(this) - type(Atoms), target, intent(inout) :: this - integer :: i - - if(this%N == 0) return - - nullify(this%Z, this%travel, this%pos, this%move_mask, this%damp_mask, & - this%thermostat_region, this%pos, this%velo, this%acc, this%avgpos, & - this%oldpos) - - ! Loop over all properties looking for those with special names - ! which we have pointers for - do i = 1,this%properties%N - - ! If this%N is zero then point at zero length arrays - if (this%N == 0) then - - select case(trim(lower_case(string(this%properties%keys(i))))) - - ! Integer properties - case('z') - if (this%properties%entries(i)%type /= T_INTEGER_A) & - call system_abort('Confused by Atoms property "Z" not of type T_INTEGER_A') - this%Z => this%properties%entries(i)%i_a(:) - case('travel') - if (this%properties%entries(i)%type /= T_INTEGER_A2) & - call system_abort('Confused by Atoms property "travel" not of type T_INTEGER_A2') - this%travel => this%properties%entries(i)%i_a2(:,:) - case('move_mask') - if (this%properties%entries(i)%type /= T_INTEGER_A) & - call system_abort('Confused by Atoms property "move_mask" not of type T_INTEGER_A') - this%move_mask => this%properties%entries(i)%i_a(:) - case('damp_mask') - if (this%properties%entries(i)%type /= T_INTEGER_A) & - call system_abort('Confused by Atoms property "damp_mask" not of type T_INTEGER_A') - this%damp_mask => this%properties%entries(i)%i_a(:) - case('thermostat_region') - if (this%properties%entries(i)%type /= T_INTEGER_A) & - call system_abort('Confused by Atoms property "thermostat_mask" not of type T_INTEGER_A') - this%thermostat_region => this%properties%entries(i)%i_a(:) - - ! Real properties - case('mass') - if (this%properties%entries(i)%type /= T_REAL_A) & - call system_abort('Confused by Atoms property "mass" not of type T_REAL_A') - this%mass => this%properties%entries(i)%r_a(:) - case('pos') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "mass" not of type T_REAL_A2') - this%pos => this%properties%entries(i)%r_a2(:,:) - case('velo') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "velo" not of type T_REAL_A2') - this%velo => this%properties%entries(i)%r_a2(:,:) - case('acc') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "acc" not of type T_REAL_A2') - this%acc => this%properties%entries(i)%r_a2(:,:) - case('avgpos') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "avgpos" not of type T_REAL_A2') - this%avgpos => this%properties%entries(i)%r_a2(:,:) - case('oldpos') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "oldpos" not of type T_REAL_A2') - this%oldpos => this%properties%entries(i)%r_a2(:,:) - case('avg_ke') - if (this%properties%entries(i)%type /= T_REAL_A) & - call system_abort('Confused by Atoms property "avg_ke" not of type T_REAL_A') - this%avg_ke => this%properties%entries(i)%r_a(:) - - ! String properties - case('species') - if (this%properties%entries(i)%type /= T_CHAR_A) & - call system_abort('Confused by Atoms property "species" not of type T_CHAR_A') - this%species => this%properties%entries(i)%s_a(:,:) - - end select - - - else - - select case(trim(lower_case(string(this%properties%keys(i))))) - - ! Integer properties - case('z') - if (this%properties%entries(i)%type /= T_INTEGER_A) & - call system_abort('Confused by Atoms property "Z" not of type T_INTEGER_A') - this%Z => this%properties%entries(i)%i_a(1:this%n) - case('travel') - if (this%properties%entries(i)%type /= T_INTEGER_A2) & - call system_abort('Confused by Atoms property "travel" not of type T_INTEGER_A2') - this%travel => this%properties%entries(i)%i_a2(:,1:this%n) - case('move_mask') - if (this%properties%entries(i)%type /= T_INTEGER_A) & - call system_abort('Confused by Atoms property "move_mask" not of type T_INTEGER_A') - this%move_mask => this%properties%entries(i)%i_a(1:this%n) - case('damp_mask') - if (this%properties%entries(i)%type /= T_INTEGER_A) & - call system_abort('Confused by Atoms property "damp_mask" not of type T_INTEGER_A') - this%damp_mask => this%properties%entries(i)%i_a(1:this%n) - case('thermostat_region') - if (this%properties%entries(i)%type /= T_INTEGER_A) & - call system_abort('Confused by Atoms property "thermostat_mask" not of type T_INTEGER_A') - this%thermostat_region => this%properties%entries(i)%i_a(1:this%n) - - ! Real properties - case('mass') - if (this%properties%entries(i)%type /= T_REAL_A) & - call system_abort('Confused by Atoms property "mass" not of type T_REAL_A') - this%mass => this%properties%entries(i)%r_a(1:this%n) - case('pos') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "mass" not of type T_REAL_A2') - this%pos => this%properties%entries(i)%r_a2(:,1:this%N) - case('velo') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "velo" not of type T_REAL_A2') - this%velo => this%properties%entries(i)%r_a2(:,1:this%N) - case('acc') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "acc" not of type T_REAL_A2') - this%acc => this%properties%entries(i)%r_a2(:,1:this%N) - case('avgpos') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "avgpos" not of type T_REAL_A2') - this%avgpos => this%properties%entries(i)%r_a2(:,1:this%N) - case('oldpos') - if (this%properties%entries(i)%type /= T_REAL_A2) & - call system_abort('Confused by Atoms property "oldpos" not of type T_REAL_A2') - this%oldpos => this%properties%entries(i)%r_a2(:,1:this%N) - case('avg_ke') - if (this%properties%entries(i)%type /= T_REAL_A) & - call system_abort('Confused by Atoms property "avg_ke" not of type T_REAL_A') - this%avg_ke => this%properties%entries(i)%r_a(1:this%n) - - ! String properties - case('species') - if (this%properties%entries(i)%type /= T_CHAR_A) & - call system_abort('Confused by Atoms property "species" not of type T_CHAR_A') - this%species => this%properties%entries(i)%s_a(:,1:this%N) - - end select - - end if - - end do - - end subroutine atoms_repoint - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Add new properties - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine atoms_add_property_p_int(this, name, ptr, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - integer, intent(in), target :: ptr(:) - integer, intent(out), optional :: error - - integer :: use_n_cols, i - - INIT_ERROR(error) - if (size(ptr,1) /= this%Nbuffer) then - RAISE_ERROR("atoms_add_property_p_int_a: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) - endif - use_n_cols = 1 - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then - RAISE_ERROR("atoms_add_property_p_int: incompatible property "//trim(name)//" already present", error) - end if - end if - call set_value_pointer(this%properties, name, ptr) - call atoms_repoint(this) - end subroutine atoms_add_property_p_int - - subroutine atoms_add_property_p_int_a(this, name, ptr, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - integer, intent(in), target :: ptr(:,:) - integer, intent(out), optional :: error - - integer :: use_n_cols, i - - INIT_ERROR(error) - if (size(ptr,2) /= this%Nbuffer) then - RAISE_ERROR("atoms_add_property_p_int_a: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) - endif - use_n_cols = size(ptr,1) - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then - RAISE_ERROR("atoms_add_property_p_int_a: incompatible property "//trim(name)//" already present", error) - end if - if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_INTEGER_A2) then - RAISE_ERROR("atoms_add_property_p_int_a: incompatible property "//trim(name)//" already present", error) - end if - end if - call set_value_pointer(this%properties, name, ptr) - call atoms_repoint(this) - end subroutine atoms_add_property_p_int_a - - subroutine atoms_add_property_p_real(this, name, ptr, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - real(dp), intent(in), target :: ptr(:) - integer, intent(out), optional :: error - - integer :: use_n_cols, i - - INIT_ERROR(error) - if (size(ptr,1) /= this%Nbuffer) then - RAISE_ERROR("atoms_add_property_p_real_a: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) - endif - use_n_cols = 1 - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then - RAISE_ERROR("atoms_add_property_p_real: incompatible property "//trim(name)//" already present", error) - end if - end if - call set_value_pointer(this%properties, name, ptr) - call atoms_repoint(this) - end subroutine atoms_add_property_p_real - - subroutine atoms_add_property_p_real_a(this, name, ptr, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - real(dp), intent(in), target :: ptr(:,:) - integer, intent(out), optional :: error - - integer :: use_n_cols, i - - INIT_ERROR(error) - if (size(ptr,2) /= this%Nbuffer) then - RAISE_ERROR("atoms_add_property_p_real_a: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) - endif - use_n_cols = size(ptr,1) - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then - RAISE_ERROR("atoms_add_property_p_real_a: incompatible property "//trim(name)//" already present", error) - end if - if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_REAL_A2) then - RAISE_ERROR("atoms_add_property_p_real_a: incompatible property "//trim(name)//" already present", error) - end if - end if - call set_value_pointer(this%properties, name, ptr) - call atoms_repoint(this) - end subroutine atoms_add_property_p_real_a - - - subroutine atoms_add_property_p_logical(this, name, ptr, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - logical, intent(in), target :: ptr(:) - integer, intent(out), optional :: error - - integer :: use_n_cols, i - - INIT_ERROR(error) - if (size(ptr,1) /= this%Nbuffer) then - RAISE_ERROR("atoms_add_property_p_logical: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) - endif - use_n_cols = 1 - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_LOGICAL_A) then - RAISE_ERROR("atoms_add_property_p_logical: incompatible property "//trim(name)//" already present", error) - end if - end if - call set_value_pointer(this%properties, name, ptr) - call atoms_repoint(this) - end subroutine atoms_add_property_p_logical - - subroutine atoms_add_property_p_str(this, name, ptr, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - character(1), intent(in), target :: ptr(:,:) - integer, intent(out), optional :: error - - integer :: use_n_cols, i - - INIT_ERROR(error) - if (size(ptr,2) /= this%N) then - RAISE_ERROR("atoms_add_property_p_str: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) - endif - use_n_cols = 1 - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_CHAR_A) then - RAISE_ERROR("atoms_add_property_p_str: incompatible property "//trim(name)//" already present", error) - end if - end if - call set_value_pointer(this%properties, name, ptr) - call atoms_repoint(this) - end subroutine atoms_add_property_p_str - - subroutine atoms_add_property_int(this, name, value, n_cols, ptr, ptr2, overwrite, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - integer, intent(in) :: value - integer, intent(in), optional :: n_cols - integer, intent(out), optional, dimension(:), pointer :: ptr - integer, intent(out), optional, dimension(:,:), pointer :: ptr2 - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer :: use_n_cols, i - - INIT_ERROR(error) - use_n_cols = optional_default(1, n_cols) - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then - RAISE_ERROR("atoms_add_property_int: incompatible property "//trim(name)//" already present", error) - end if - - if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_INTEGER_A2) then - RAISE_ERROR("atoms_add_property_int: incompatible property "//trim(name)//" already present", error) - end if - end if - - if (use_n_cols == 1) then - call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) - else - call add_array(this%properties, name, value, (/n_cols, this%Nbuffer/), ptr2, overwrite) - end if - - call atoms_repoint(this) - end subroutine atoms_add_property_int - - subroutine atoms_add_property_int_a(this, name, value, n_cols, ptr, ptr2, overwrite, error) - type(Atoms), intent(inout),target :: this - character(len=*), intent(in) :: name - integer, intent(in), dimension(:) :: value - integer, intent(in), optional :: n_cols - integer, optional, intent(out), dimension(:), pointer :: ptr - integer, optional, intent(out), dimension(:,:), pointer :: ptr2 - logical, optional, intent(in) :: overwrite - integer, optional, intent(out) :: error - - integer :: use_n_cols, i - integer, allocatable, dimension(:,:) :: tmp_value - - INIT_ERROR(error) - use_n_cols = optional_default(1, n_cols) - - if (size(value) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_int_a: size(value) ('//size(value)//') /= this%Nbuffer ('//this%Nbuffer//')', error) - end if - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then - RAISE_ERROR("atoms_add_property_int_a: incompatible property "//trim(name)//" already present", error) - end if - - if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_INTEGER_A2) then - RAISE_ERROR("atoms_add_property_int_a: incompatible property "//trim(name)//" already present", error) - end if - end if - - if (use_n_cols == 1) then - call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) - else - allocate(tmp_value(n_cols, size(value))) - do i=1,n_cols - tmp_value(i,:) = value - end do - call add_array(this%properties, name, tmp_value, (/n_cols, this%Nbuffer/), ptr2, overwrite) - deallocate(tmp_value) - end if - - call atoms_repoint(this) - end subroutine atoms_add_property_int_a - - - subroutine atoms_add_property_real(this, name, value, n_cols, ptr, ptr2, overwrite, error) - type(Atoms), intent(inout),target :: this - character(len=*), intent(in) :: name - real(dp), intent(in) :: value - integer, intent(in), optional :: n_cols - real(dp), optional, dimension(:), pointer, intent(out) :: ptr - real(dp), optional, dimension(:,:), pointer, intent(out) :: ptr2 - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer use_n_cols, i - - INIT_ERROR(error) - use_n_cols = optional_default(1, n_cols) - - if (present(ptr) .and. present(ptr2)) then - RAISE_ERROR('atoms_add_property_real_a got both ptr and ptr2', error) - endif - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then - RAISE_ERROR("atoms_add_property_real: incompatible property "//trim(name)//" already present", error) - end if - - if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_REAL_A2) then - RAISE_ERROR("atoms_add_property_real: incompatible property "//trim(name)//" already present", error) - end if - end if - - if (use_n_cols == 1 .and. .not. present(ptr2)) then - call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) - else - call add_array(this%properties, name, value, (/n_cols, this%Nbuffer/), ptr2, overwrite) - end if - - call atoms_repoint(this) - end subroutine atoms_add_property_real - - - subroutine atoms_add_property_real_a(this, name, value, n_cols, ptr, ptr2, overwrite, error) - type(Atoms), intent(inout),target :: this - character(len=*), intent(in) :: name - real(dp), intent(in), dimension(:) :: value - integer, intent(in), optional :: n_cols - real(dp), optional, dimension(:), pointer, intent(out) :: ptr - real(dp), optional, dimension(:,:), pointer, intent(out) :: ptr2 - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer :: use_n_cols, i - real(dp), allocatable, dimension(:,:) :: tmp_value - - INIT_ERROR(error) - use_n_cols = optional_default(1, n_cols) - - if (present(ptr) .and. present(ptr2)) then - RAISE_ERROR('atoms_add_property_real_a got both ptr and ptr2', error) - endif - - if (size(value) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_real_a: size(value) ('//size(value)//') /= this%Nbuffer ('//this%Nbuffer//')', error) - end if - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then - RAISE_ERROR("atoms_add_property_real_a: incompatible property "//trim(name)//" already present", error) - end if - - if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_REAL_A2) then - RAISE_ERROR("atoms_add_property_real_a: incompatible property "//trim(name)//" already present", error) - end if - end if - - if (use_n_cols == 1 .and. .not. present(ptr2)) then - call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) - else - allocate(tmp_value(n_cols, size(value))) - do i=1,n_cols - tmp_value(i,:) = value - end do - call add_array(this%properties, name, tmp_value, (/n_cols, this%Nbuffer/), ptr2, overwrite) - deallocate(tmp_value) - end if - - call atoms_repoint(this) - end subroutine atoms_add_property_real_a - - subroutine atoms_add_property_int_2Da(this, name, value, ptr, overwrite, error) - type(Atoms), intent(inout),target :: this - character(len=*), intent(in) :: name - integer, intent(in) :: value(:,:) - integer, optional, dimension(:,:), pointer, intent(out) :: ptr - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer i - - INIT_ERROR(error) - - if (size(value,2) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_int_2Da: size(value,2) ('//size(value,2)//') /= this%Nbuffer ('//this%Nbuffer//')', error) - end if - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (size(value,1) == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then - RAISE_ERROR("atoms_add_property_int_2Da: incompatible property "//trim(name)//" already present", error) - end if - - if (size(value,1) /= 1 .and. this%properties%entries(i)%type /= T_INTEGER_A2) then - RAISE_ERROR("atoms_add_property_int_2Da: incompatible property "//trim(name)//" already present", error) - end if - end if - - if (size(value,2) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_int_2Da: size(value,2)='//size(value,2)//' != this%Nbuffer ='//this%Nbuffer, error) - end if - - call add_array(this%properties, name, value, (/size(value,1), this%Nbuffer/), ptr, overwrite) - - call atoms_repoint(this) - end subroutine atoms_add_property_int_2Da - - - subroutine atoms_add_property_real_2Da(this, name, value, ptr, overwrite, error) - type(Atoms), intent(inout),target :: this - character(len=*), intent(in) :: name - real(dp), intent(in) :: value(:,:) - real(dp), optional, dimension(:,:), pointer, intent(out) :: ptr - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer i - - INIT_ERROR(error) - - if (size(value,2) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_real_2Da: size(value,2) ('//size(value,2)//') /= this%Nbuffer ('//this%Nbuffer//')', error) - end if - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (size(value,1) == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then - RAISE_ERROR("atoms_add_property_real_2Da: incompatible property "//trim(name)//" already present", error) - end if - - if (size(value,1) /= 1 .and. this%properties%entries(i)%type /= T_REAL_A2) then - RAISE_ERROR("atoms_add_property_real_2Da: incompatible property "//trim(name)//" already present", error) - end if - end if - - if (size(value,2) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_real_2Da: size(value,2)='//size(value,2)//' != this%Nbuffer ='//this%Nbuffer, error) - end if - - call add_array(this%properties, name, value, (/size(value,1), this%Nbuffer/), ptr, overwrite) - - call atoms_repoint(this) - end subroutine atoms_add_property_real_2Da - - - subroutine atoms_add_property_str(this, name, value, ptr, overwrite, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - character(len=*), intent(in) :: value - character(1), intent(out), optional, dimension(:,:), pointer :: ptr - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer i - - INIT_ERROR(error) - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (this%properties%entries(i)%type /= T_CHAR_A) then - RAISE_ERROR("atoms_add_property_str: incompatible property "//trim(name)//" already present", error) - end if - end if - - ! temporary hack - string length fixed to TABLE_STRING_LENGTH - if (len(value) /= TABLE_STRING_LENGTH) then - RAISE_ERROR("atoms_add_property_str: string properties much have string length TABLE_STRING_LENGTH but got "//len(value), error) - end if - call add_array(this%properties, name, value, (/TABLE_STRING_LENGTH, this%Nbuffer/), ptr, overwrite) - - call atoms_repoint(this) - end subroutine atoms_add_property_str - - - subroutine atoms_add_property_str_2da(this, name, value, ptr, overwrite, error) - type(Atoms), intent(inout),target :: this - character(len=*), intent(in) :: name - character(1), dimension(:,:) :: value - character(1), intent(out), optional, dimension(:,:), pointer :: ptr - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer :: i - - INIT_ERROR(error) - - if (size(value,2) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_str_2da: size(value,2) ('//size(value,2)//') /= this%Nbuffer ('//this%Nbuffer//')', error) - end if - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (this%properties%entries(i)%type /= T_CHAR_A) then - RAISE_ERROR("atoms_add_property_str: incompatible property "//trim(name)//" already present", error) - end if - end if - - ! temporary hack - string length fixed to TABLE_STRING_LENGTH - if (size(value,1) /= TABLE_STRING_LENGTH) then - RAISE_ERROR("atoms_add_property_str: string properties much have string length TABLE_STRING_LENGTH", error) - end if - - call add_array(this%properties, name, value, (/TABLE_STRING_LENGTH, this%Nbuffer/), ptr, overwrite) - - call atoms_repoint(this) - end subroutine atoms_add_property_str_2da - - subroutine atoms_add_property_str_a(this, name, value, ptr, overwrite, error) - type(Atoms), intent(inout),target :: this - character(len=*), intent(in) :: name - character(len=*), dimension(:) :: value - character(1), intent(out), optional, dimension(:,:), pointer :: ptr - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - character(1), allocatable, dimension(:,:) :: tmp_value - integer :: i, j - - INIT_ERROR(error) - - if (size(value) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_str_a: size(value) ('//size(value)//') /= this%Nbuffer ('//this%Nbuffer//')', error) - end if - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (this%properties%entries(i)%type /= T_CHAR_A) then - RAISE_ERROR("atoms_add_property_str: incompatible property "//trim(name)//" already present", error) - end if - end if - - ! temporary hack - string length fixed to TABLE_STRING_LENGTH - if (len(value(1)) /= TABLE_STRING_LENGTH) then - RAISE_ERROR("atoms_add_property_str: string properties much have string length TABLE_STRING_LENGTH", error) - end if - - allocate(tmp_value(len(value),this%n)) - do i=1,this%Nbuffer - do j=1,len(value) - tmp_value(j,i) = value(i)(j:j) - end do - end do - call add_array(this%properties, name, tmp_value, (/TABLE_STRING_LENGTH, this%Nbuffer/), ptr, overwrite) - deallocate(tmp_value) - - call atoms_repoint(this) - end subroutine atoms_add_property_str_a - - subroutine atoms_add_property_logical(this, name, value, ptr, overwrite, error) - type(Atoms), intent(inout), target :: this - character(len=*), intent(in) :: name - logical, intent(in) :: value - logical, intent(out), optional, dimension(:), pointer :: ptr - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer i - - INIT_ERROR(error) - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (this%properties%entries(i)%type /= T_LOGICAL_A) then - RAISE_ERROR("atoms_add_property_logical: incompatible property "//trim(name)//" already present", error) - end if - end if - - call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) - - call atoms_repoint(this) - end subroutine atoms_add_property_logical - - - subroutine atoms_add_property_logical_a(this, name, value, ptr, overwrite, error) - type(Atoms), intent(inout),target :: this - character(len=*), intent(in) :: name - logical, dimension(:) :: value - logical, intent(out), optional, dimension(:), pointer :: ptr - logical, optional, intent(in) :: overwrite - integer, intent(out), optional :: error - - integer i - - INIT_ERROR(error) - - if (size(value) /= this%Nbuffer) then - RAISE_ERROR('atoms_add_property_logical_a: size(value) ('//size(value)//') /= this%Nbuffer ('//this%Nbuffer//')', error) - end if - - ! Check for incompatible property - i = lookup_entry_i(this%properties, name) - if (i /= -1) then - if (this%properties%entries(i)%type /= T_LOGICAL_A) then - RAISE_ERROR("atoms_add_property_logical_a: incompatible property "//trim(name)//" already present", error) - end if - end if - - call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) - - call atoms_repoint(this) - end subroutine atoms_add_property_logical_a - - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Assigning pointers to properties - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function atoms_assign_pointer_int1D(this, name, ptr) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - integer, pointer :: ptr(:) - logical :: atoms_assign_pointer_int1D - - atoms_assign_pointer_int1D = assign_pointer(this%properties, name, ptr) - end function atoms_assign_pointer_int1D - - function atoms_assign_pointer_int2D(this, name, ptr) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - integer, pointer :: ptr(:,:) - logical :: atoms_assign_pointer_int2D - - atoms_assign_pointer_int2D = assign_pointer(this%properties, name, ptr) - end function atoms_assign_pointer_int2D - - function atoms_assign_pointer_real1D(this, name, ptr) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - real(dp), pointer :: ptr(:) - logical :: atoms_assign_pointer_real1D - - atoms_assign_pointer_real1D = assign_pointer(this%properties, name, ptr) - end function atoms_assign_pointer_real1D - - function atoms_assign_pointer_real2D(this, name, ptr) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - real(dp), pointer :: ptr(:,:) - logical :: atoms_assign_pointer_real2D - - atoms_assign_pointer_real2D = assign_pointer(this%properties, name, ptr) - end function atoms_assign_pointer_real2D - - function atoms_assign_pointer_str(this, name, ptr) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - character(1), pointer :: ptr(:,:) - logical :: atoms_assign_pointer_str - - atoms_assign_pointer_str = assign_pointer(this%properties, name, ptr) - end function atoms_assign_pointer_str - - function atoms_assign_pointer_logical(this, name, ptr) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - logical, pointer :: ptr(:) - logical :: atoms_assign_pointer_logical - - atoms_assign_pointer_logical = assign_pointer(this%properties, name, ptr) - end function atoms_assign_pointer_logical - - subroutine atoms_assign_prop_ptr_int1D(this, name, ptr, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - integer, pointer :: ptr(:) - integer, intent(out), optional :: error - - logical :: res - - INIT_ERROR(error) - - res = assign_pointer(this%properties, name, ptr) - if (.not. res) then - RAISE_ERROR("atoms_assign_prop_ptr_int1d failed to assign pointer to "//trim(name)//" in this%properties", error) - endif - end subroutine atoms_assign_prop_ptr_int1D - - subroutine atoms_assign_prop_ptr_int2D(this, name, ptr, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - integer, pointer :: ptr(:,:) - integer, intent(out), optional :: error - - logical :: res - - INIT_ERROR(error) - - res = assign_pointer(this%properties, name, ptr) - if (.not. res) then - RAISE_ERROR("atoms_assign_prop_ptr_int2d failed to assign pointer to "//trim(name)//" in this%properties", error) - endif - end subroutine atoms_assign_prop_ptr_int2D - - subroutine atoms_assign_prop_ptr_real1D(this, name, ptr, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - real(dp), pointer :: ptr(:) - integer, intent(out), optional :: error - - logical :: res - - INIT_ERROR(error) - - res = assign_pointer(this%properties, name, ptr) - if (.not. res) then - RAISE_ERROR("atoms_assign_prop_ptr_real1d failed to assign pointer to "//trim(name)//" in this%properties", error) - endif - end subroutine atoms_assign_prop_ptr_real1D - - subroutine atoms_assign_prop_ptr_real2D(this, name, ptr, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - real(dp), pointer :: ptr(:,:) - integer, intent(out), optional :: error - - logical :: res - - INIT_ERROR(error) - - res = assign_pointer(this%properties, name, ptr) - if (.not. res) then - RAISE_ERROR("atoms_assign_prop_ptr_real2d failed to assign pointer to "//trim(name)//" in this%properties", error) - endif - end subroutine atoms_assign_prop_ptr_real2D - - subroutine atoms_assign_prop_ptr_str(this, name, ptr, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - character(1), pointer :: ptr(:,:) - integer, intent(out), optional :: error - - logical :: res - - INIT_ERROR(error) - - res = assign_pointer(this%properties, name, ptr) - if (.not. res) then - RAISE_ERROR("atoms_assign_prop_ptr_str failed to assign pointer to "//trim(name)//" in this%properties", error) - endif - end subroutine atoms_assign_prop_ptr_str - - subroutine atoms_assign_prop_ptr_logical(this, name, ptr, error) - type(Atoms), intent(in) :: this - character(len=*), intent(in) :: name - logical, pointer :: ptr(:) - integer, intent(out), optional :: error - - logical :: res - - INIT_ERROR(error) - - res = assign_pointer(this%properties, name, ptr) - if (.not. res) then - RAISE_ERROR("atoms_assign_prop_ptr_logical failed to assign pointer to "//trim(name)//" in this%properties", error) - endif - end subroutine atoms_assign_prop_ptr_logical - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Copying individual atoms and sorting - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Move a single atom from one location to another one. - !% The destination will be overriden. - subroutine atoms_copy_entry(this, src, dst, swap, error) - - type(Atoms), intent(inout) :: this - integer, intent(in) :: src - integer, intent(in) :: dst - logical, intent(in), optional :: swap - integer, optional, intent(out) :: error - - integer i - - logical :: my_swap - integer :: t_i - integer, allocatable :: t_i_a(:) - real(dp) :: t_r - real(dp), allocatable :: t_r_a(:) - logical :: t_l - character(len=1), allocatable :: t_c(:) - - ! --- - - INIT_ERROR(error) - my_swap = optional_default(.false., swap) - - if (src < 1 .or. src > this%N) then - RAISE_ERROR('atoms_copy_entry: src='//src//' out of range 1 <= src <= '//this%n, error) - end if - if (dst < 1 .or. dst > this%N) then - RAISE_ERROR('atoms_copy_entry: dst='//dst//' out of range 1 <= dst <= '//this%n, error) - end if - - do i=1,this%properties%N - select case (this%properties%entries(i)%type) - - case(T_INTEGER_A) - if (my_swap) then - t_i = this%properties%entries(i)%i_a(dst) - this%properties%entries(i)%i_a(dst) = this%properties%entries(i)%i_a(src) - this%properties%entries(i)%i_a(src) = t_i - else - this%properties%entries(i)%i_a(dst) = this%properties%entries(i)%i_a(src) - endif - - case(T_REAL_A) - if (my_swap) then - t_r = this%properties%entries(i)%r_a(dst) - this%properties%entries(i)%r_a(dst) = this%properties%entries(i)%r_a(src) - this%properties%entries(i)%r_a(src) = t_r - else - this%properties%entries(i)%r_a(dst) = this%properties%entries(i)%r_a(src) - endif - - case(T_LOGICAL_A) - if (my_swap) then - t_l = this%properties%entries(i)%l_a(dst) - this%properties%entries(i)%l_a(dst) = this%properties%entries(i)%l_a(src) - this%properties%entries(i)%l_a(src) = t_l - else - this%properties%entries(i)%l_a(dst) = this%properties%entries(i)%l_a(src) - endif - - case(T_INTEGER_A2) - if (my_swap) then - allocate(t_i_a(size(this%properties%entries(i)%i_a2,1))) - t_i_a = this%properties%entries(i)%i_a2(:,dst) - this%properties%entries(i)%i_a2(:,dst) = this%properties%entries(i)%i_a2(:,src) - this%properties%entries(i)%i_a2(:,src) = t_i_a - deallocate(t_i_a) - else - this%properties%entries(i)%i_a2(:,dst) = this%properties%entries(i)%i_a2(:,src) - endif - - case(T_REAL_A2) - if (my_swap) then - allocate(t_r_a(size(this%properties%entries(i)%r_a2,1))) - t_r_a = this%properties%entries(i)%r_a2(:,dst) - this%properties%entries(i)%r_a2(:,dst) = this%properties%entries(i)%r_a2(:,src) - this%properties%entries(i)%r_a2(:,src) = t_r_a - deallocate(t_r_a) - else - this%properties%entries(i)%r_a2(:,dst) = this%properties%entries(i)%r_a2(:,src) - endif - - case(T_CHAR_A) - if (my_swap) then - allocate(t_c(size(this%properties%entries(i)%s_a,1))) - t_c = this%properties%entries(i)%s_a(:,dst) - this%properties%entries(i)%s_a(:,dst) = this%properties%entries(i)%s_a(:,src) - this%properties%entries(i)%s_a(:,src) = t_c - deallocate(t_c) - else - this%properties%entries(i)%s_a(:,dst) = this%properties%entries(i)%s_a(:,src) - endif - - case default - RAISE_ERROR('atoms_copy_entry: bad property type '//this%properties%entries(i)%type//' key='//this%properties%keys(i), error) - - end select - end do - - endsubroutine atoms_copy_entry - - - !% sort atoms by one or more (max 2 now) integer or real properties - subroutine atoms_sort(this, prop1, prop2, prop3, error) - type(Atoms), intent(inout) :: this - character(len=*), intent(in) :: prop1 - character(len=*), intent(in), optional :: prop2, prop3 - integer, intent(out), optional :: error - - integer, pointer :: i_p1(:) => null(), i_p2(:) => null(), i_p3(:) => null() - real(dp), pointer :: r_p1(:) => null(), r_p2(:) => null(), r_p3(:) => null() - integer :: cur_place, i_a, smallest_i_a - logical :: is_lt - - INIT_ERROR(error) - - if (.not. assign_pointer(this, prop1, i_p1)) then - if (.not. assign_pointer(this, prop1, r_p1)) then - RAISE_ERROR("atoms_sort can't find 1st integer or real property '" // prop1 //"'", error) - endif - endif - if (present(prop2)) then - if (.not. assign_pointer(this, prop2, i_p2)) then - if (.not. assign_pointer(this, prop2, r_p2)) then - RAISE_ERROR("atoms_sort can't find 2nd integer or real property '" // prop2 //"'", error) - endif - endif - endif - if (present(prop3)) then - if (.not. assign_pointer(this, prop3, i_p3)) then - if (.not. assign_pointer(this, prop3, r_p3)) then - RAISE_ERROR("atoms_sort can't find 3rd integer or real property '" // prop3 //"'", error) - endif - endif - endif - - do cur_place=1, this%N-1 - smallest_i_a = cur_place - do i_a = cur_place+1, this%N - is_lt = arrays_lt(i_a, smallest_i_a, i_p1=i_p1, r_p1=r_p1, i_p2=i_p2, r_p2=r_p2, i_p3=i_p3, r_p3=r_p3, error=error) - PASS_ERROR(error) - if (is_lt) then - smallest_i_a = i_a - endif - end do - if (smallest_i_a /= cur_place) then - call copy_entry(this, cur_place, smallest_i_a, swap=.true., error=error) - PASS_ERROR(error) - endif - end do - end subroutine atoms_sort - - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Atoms indepedent convenince stuff - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !Bond_Length - !% Returns the sum of the covalent radii of two atoms - function bond_length(z1,z2) - integer, intent(in) :: z1,z2 - real(dp) :: bond_length - bond_length = ElementCovRad(z1) + ElementCovRad(z2) - end function bond_length - - subroutine array_map_into_cell(pos, lattice, g) - real(dp), intent(inout) :: pos(:,:) - real(dp), intent(in) :: lattice(3,3), g(3,3) - - integer :: i - - do i=1, size(pos, 2) - call map_into_cell(pos(:,i), lattice, g) - end do - end subroutine array_map_into_cell - - subroutine vec_map_into_cell(pos, lattice, g, shift, mapped) - real(dp), intent(inout) :: pos(3) - real(dp), intent(in) :: lattice(3,3), g(3,3) - integer, intent(out), optional :: shift(3) - logical, intent(out), optional :: mapped - - integer n, k - real(dp) :: lattice_coord(3) - logical :: my_mapped - - lattice_coord = g .mult. pos(:) - my_mapped = .false. - if (present(shift)) shift = 0 - - do n=1,3 - if ((lattice_coord(n) < -0.5_dp) .or. (lattice_coord(n) >= 0.5_dp)) then - k = floor(lattice_coord(n)+0.5_dp) - lattice_coord(n) = lattice_coord(n) - k - if (present(shift)) shift(n) = -k - my_mapped = .true. - end if - end do - - ! if this atom has been mapped then recalculate its position and shifts for its neighbours - if (my_mapped) then - pos(:) = lattice .mult. lattice_coord - end if - if (present(mapped)) mapped = my_mapped - end subroutine vec_map_into_cell - - - !% Returns the (unsigned) volume of the simulation cell of lattice - function lattice_cell_volume(lattice) - real(dp), intent(in) :: lattice(3,3) - real(dp) :: lattice_Cell_Volume - - real(dp), dimension(3) :: a, b, c - - a = lattice(:,1) - b = lattice(:,2) - c = lattice(:,3) - - lattice_Cell_Volume = abs(Scalar_Triple_Product(a,b,c)) - - end function lattice_cell_volume - - - !% Difference vector between atoms $i$ and $j$ if they are separated by a shift of 'shift' - !% \begin{displaymath} - !% \mathbf{u}_{ij} = \mathbf{r}_j - \mathbf{r}_i + \mathbf{R} \cdot \mathbf{s} - !% \end{displaymath} - !% where $\mathbf{R}$ is the 'lattice' matrix and $\mathbf{s}$ the shift - function diff(this, i, j, shift) - type(Atoms), intent(in) :: this - integer, intent(in) :: i,j - integer, dimension(3) :: shift - real(dp), dimension(3) :: diff - - diff = this%pos(:,j) - this%pos(:,i) + (this%lattice .mult. shift) - - end function diff - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! diff_min_image interface - ! - ! return relative vector from one position to another, adhering to PBC - ! and minimum image conventions - ! - ! Flavours are: atom-atom, vector-atom, atom-vector, vector-vector - ! - ! All are accessible using the 'diff_min_image' interface - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - function diff_atom_atom(this, i, j, shift) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i,j - integer, dimension(3), optional :: shift - real(dp), dimension(3) :: diff_atom_atom - real(dp) :: dummy - - integer, dimension(3) :: myshift - - dummy = distance_min_image(this,i,j, shift=myshift) - - diff_atom_atom = this%pos(:,j) - this%pos(:,i) + (this%lattice .mult. myshift) - - if (present(shift)) shift = myshift - - end function diff_atom_atom - - - function diff_vec_atom(this, v, j) - - type(Atoms), intent(in) :: this - real(dp), dimension(3) :: v - integer, intent(in) :: j - real(dp), dimension(3) :: diff_vec_atom - integer, dimension(3) :: shift - real(dp) :: dummy - - dummy = distance_min_image(this,v,j, shift=shift) - - diff_vec_atom = this%pos(:,j) - v + (this%lattice .mult. shift) - - end function diff_vec_atom - - function diff_atom_vec(this, i, w) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i - real(dp), dimension(3) :: w - real(dp), dimension(3) :: diff_atom_vec - integer, dimension(3) :: shift - real(dp) :: dummy - - dummy = distance_min_image(this,i,w, shift=shift) - - diff_atom_vec = w - this%pos(:,i) + (this%lattice .mult. shift) - - end function diff_atom_vec - - function diff_vec_vec(this, v, w) - - type(Atoms), intent(in) :: this - real(dp), dimension(3) :: v, w - real(dp), dimension(3) :: diff_vec_vec - integer, dimension(3) :: shift - real(dp) :: dummy - - dummy = distance_min_image(this,v,w, shift=shift) - - diff_vec_vec = w - v + (this%lattice .mult. shift) - - end function diff_vec_vec - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Return the real position of atom 'i', taking into account the - !% stored travel across the periodic boundary conditions. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function realpos(this,i) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i - real(dp), dimension(3) :: realpos - - if (associated(this%travel)) then - realpos = (this%lattice .mult. this%travel(:,i)) + this%pos(:,i) - else - realpos = this%pos(:,i) - endif - - end function realpos - - - !% Return distance between atoms 'i' and 'j' if they are separated by a shift - !% of 'shift'. - !% - !% \begin{displaymath} - !% r_{ij} = \left| \mathbf{r}_j - \mathbf{r}_i + \mathbf{R} \cdot \mathbf{s} \right| - !% \end{displaymath} - !% where $\mathbf{R}$ is the 'lattice' matrix and $\mathbf{s}$ the shift. - - function distance(this, i, j, shift) - type(Atoms), intent(in)::this - integer, intent(in)::i, j, shift(3) - real(dp)::distance - - distance = norm(this%pos(:,j)+(this%lattice .mult. shift)-this%pos(:,i)) - end function distance - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! distance_min_image interface - ! - ! Actual distance computing routines. - ! - ! The real work is done in the function that computes the distance - ! of two general vector positions. when atomic indices are - ! specified, they are first converted to vector positions. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function distance8_atom_atom(this,i,j,shift) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i,j - integer, optional, dimension(3), intent(out) :: shift - real(dp) :: distance8_atom_atom - - distance8_atom_atom = distance8_vec_vec(this,this%pos(:,i),this%pos(:,j),shift) - - end function distance8_atom_atom - - function distance8_atom_vec(this,i,v,shift) - - type(Atoms), intent(in) :: this - integer, intent(in) :: i - real(dp), dimension(3), intent(in) :: v - integer, optional, dimension(3), intent(out) :: shift - real(dp) :: distance8_atom_vec - - distance8_atom_vec = distance8_vec_vec(this,this%pos(:,i),v,shift) - - end function distance8_atom_vec - - function distance8_vec_atom(this,v,j,shift) - - type(Atoms), intent(in) :: this - real(dp), dimension(3), intent(in) :: v - integer, intent(in) :: j - integer, optional, dimension(3), intent(out) :: shift - real(dp) :: distance8_vec_atom - - distance8_vec_atom = distance8_vec_vec(this,v,this%pos(:,j),shift) - - end function distance8_vec_atom - - ! This is the general function - - function distance8_vec_vec(this,v,w,shift) - - type(Atoms), intent(in) :: this - real(dp), dimension(3), intent(in) :: v,w - integer, optional, dimension(3), intent(out) :: shift - real(dp) :: distance8_vec_vec, dist2, tmp - real(dp), dimension(3) :: dvw, lattice_coord - integer, dimension(3) :: init_val - integer :: i,j,k, i_shift(3) - - !get the difference vector and convert to lattice co-ordinates - !use the precomputed matrix inverse if possible - dvw = w - v - call map_into_cell(dvw, this%lattice, this%g, i_shift) - lattice_coord = this%g .mult. dvw - - init_val = (/0,0,0/) - - !work out which block of 8 cells we are testing - where (lattice_coord > 0.0_dp) init_val = -1 - - dist2 = huge(1.0_dp) ! effectively +ve infinity - - !now loop over the cells and test - do k=init_val(3), init_val(3)+1 - do j=init_val(2), init_val(2)+1 - do i=init_val(1), init_val(1)+1 - - !construct the shifted vector - tmp = normsq(dvw + this%lattice(:,1)*i +this%lattice(:,2)*j + this%lattice(:,3)*k) - !test if it is the smallest so far and store the shift if necessary - if (tmp < dist2) then - dist2 = tmp - if (present(shift)) shift = (/i,j,k/) + i_shift - end if - - end do - end do - end do - - distance8_vec_vec = sqrt(dist2) - - end function distance8_vec_vec - - -endmodule Atoms_types_module diff --git a/src/libAtoms/Barostat.f95 b/src/libAtoms/Barostat.f95 deleted file mode 100644 index da776b8003..0000000000 --- a/src/libAtoms/Barostat.f95 +++ /dev/null @@ -1,682 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Barostat module -!X -!% This module contains the implementations for all the barostats available -!% in libAtoms: Langevin thermalized Hoover -!% -!% With $Q > 0$, use adaptive (aka open) Langevin, from Jones \& Leimkuhler -!% preprint ``Adaptive Stochastic Methods for Nonequilibrium Sampling" -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module barostat_module - - use system_module - use units_module - use linearalgebra_module - use atoms_module - - implicit none - private - public :: barostat, initialise, finalise, print, update_barostat, set_degrees_of_freedom, barostat_mass - public :: BAROSTAT_NONE, BAROSTAT_HOOVER_LANGEVIN - public :: barostat_pre_vel1, barostat_post_vel1_pre_pos, barostat_post_pos_pre_calc, barostat_post_calc_pre_vel2, barostat_post_vel2 - - real(dp), parameter :: BAROSTAT_MIN_TEMP = 1.0_dp - - integer, parameter :: BAROSTAT_NONE = 0, & - BAROSTAT_HOOVER_LANGEVIN = 1 - - !% Langevin barostat - fluctuation/dissipation --- - !% originally implemented for hydrostatic strain using - !% EOM from Quigley, D. and Probert, M.I.J., \emph{J. Chem. Phys.}, - !% {\bfseries 120} 11432 - !% rediscretized by Noam Bernstein based on ideas from and discussion - !% with B. Leimkuhler. - !% modified for arbitrary strain based on (but not exactly using) - !% formulation in E. Tadmor and R. Miller Modeling Materials: Continuum, Atomistic and Multiscale - !% Techniques (Cambridge University Press, 2011). Chap 9.5. Their - !% definition of stress (factors of $F$, $F^T$, $J$, and $F^{-T}$) for finite strain is - !% optionally used, but certain terms in EOM are excluded, and their discretization - !% is entirely ignored. - - type barostat - - integer :: type = BAROSTAT_NONE !% One of the types listed above - real(dp) :: gamma_epsilon = 0.0_dp !% Friction coefficient for Langevin part - real(dp) :: T = -1.0_dp !% Temperature for Langevin part - real(dp) :: Ndof = 0.0_dp !% The number of degrees of freedom of atoms attached to this barostat - real(dp) :: stress_ext(3,3) = 0.0_dp !% External applied stress - real(dp) :: W_epsilon = 0.0_dp !% Fictious cell mass in Langevin NPT - real(dp) :: epsilon_v(3,3) = 0.0_dp !% Velocity of deformation gradient for barostat - real(dp) :: epsilon_f(3,3) = 0.0_dp !% Force on deformation gradient - real(dp) :: epsilon_r(3,3) = reshape( (/ 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp /), (/ 3, 3 /) ) !% Value of deformation gradient - logical :: hydrostatic_strain = .true., diagonal_strain = .true., finite_strain_formulation=.false. - - real(dp) :: lattice0(3,3), lattice0_inv(3,3), F_tmp_norm - logical :: lattice0_initialised = .false. - - end type barostat - - interface initialise - module procedure barostat_initialise - end interface initialise - - interface finalise - module procedure barostat_finalise - end interface finalise - - interface assignment(=) - module procedure barostat_assignment - end interface assignment(=) - - interface print - module procedure barostat_print - end interface - - interface update_barostat - module procedure barostat_update_barostat - end interface update_barostat - - interface set_degrees_of_freedom - module procedure set_degrees_of_freedom_int, set_degrees_of_freedom_real - end interface set_degrees_of_freedom - - interface barostat_mass - module procedure barostat_mass_int, barostat_mass_real - end interface barostat_mass - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X INITIALISE / FINALISE - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine barostat_initialise(this,type,p_ext,stress_ext,hydrostatic_strain,diagonal_strain,finite_strain_formulation,deformation_grad,cell_volume,W_epsilon,Ndof,gamma_epsilon,T,W_epsilon_factor, thermalise) - - type(barostat), intent(inout) :: this - integer, intent(in) :: type - real(dp), optional, intent(in) :: p_ext - real(dp), optional, intent(in) :: stress_ext(3,3) - logical, optional, intent(in) :: hydrostatic_strain, diagonal_strain - logical, optional, intent(in) :: finite_strain_formulation - real(dp), optional, intent(in) :: deformation_grad(3,3) - real(dp), optional, intent(in) :: cell_volume - real(dp), optional, intent(in) :: W_epsilon - real(dp), optional, intent(in) :: Ndof - real(dp), optional, intent(in) :: gamma_epsilon - real(dp), optional, intent(in) :: T - real(dp), optional, intent(in) :: W_epsilon_factor - logical, optional, intent(in) :: thermalise - - real(dp) :: use_T - logical :: use_thermalise - - if (type /= BAROSTAT_NONE .and. .not.present(p_ext) .and. .not. present(stress_ext)) & - call system_abort('barostat_initialise: p_ext or stress_ext must be specified when turning on a barostat') - - if (present(p_ext) .and. present(stress_ext)) & - call system_abort('barostat_initialise: got both p_ext and stress_ext') - - this%type = type - this%epsilon_v = 0.0_dp - this%epsilon_f = 0.0_dp - if (present(deformation_grad)) then - this%epsilon_r = deformation_grad - else - this%epsilon_r = 0.0_dp; call add_identity(this%epsilon_r) - endif - this%lattice0_initialised = .false. - - select case(this%type) - - case(BAROSTAT_NONE) - - this%stress_ext = 0.0_dp - this%gamma_epsilon = 0.0_dp - this%W_epsilon = 0.0_dp - this%Ndof = 0.0_dp - this%T = -1.0_dp - - case(BAROSTAT_HOOVER_LANGEVIN) - - if (.not.present(p_ext) .and. .not. present(stress_ext)) call system_abort('barostat initialise: p_ext or stress_ext is required for Hoover-Langevin barostat') - if (present(p_ext) .and. present(stress_ext)) call system_abort('barostat initialise: p_ext and stress_ext conflict for Hoover-Langevin barostat') - if (.not.present(gamma_epsilon)) call system_abort('barostat initialise: gamma_epsilon is required for Hoover-Langevin barostat') - if (gamma_epsilon <= 0.0_dp) call system_abort('barostat initialise: gamma_epsilon must be > 0.0 for Hoover-Langevin') - if (.not.present(Ndof)) call system_abort('barostat initialise: Ndof is required for Hoover-Langevin barostat') - if (Ndof <= 0.0_dp) call system_abort('barostat initialise: Ndof must be > 0.0 for Hoover-Langevin') - - if (.not.present(W_epsilon) .and. .not. present(cell_volume)) call system_abort('barostat initialise: W_epsilon or cell_volume is required for Hoover-Langevin barostat') - if (present(W_epsilon)) then - if (W_epsilon <= 0.0_dp) call system_abort('barostat initialise: W must be > 0.0 for Hoover-Langevin') - endif - if (present(cell_volume)) then - if (cell_volume <= 0.0_dp) call system_abort('barostat initialise: cell_volume must be > 0.0 for Hoover-Langevin') - endif - - if (present(p_ext)) then ! S = - p_ext I - this%stress_ext = 0.0_dp - call add_identity(this%stress_ext) - this%stress_ext = -p_ext * this%stress_ext - else - this%stress_ext = stress_ext - endif - - if (present(hydrostatic_strain)) this%hydrostatic_strain = hydrostatic_strain - if (present(diagonal_strain)) this%diagonal_strain = diagonal_strain - if (present(finite_strain_formulation)) this%finite_strain_formulation = finite_strain_formulation - - this%Ndof = Ndof - if (present(W_epsilon)) then - this%W_epsilon = W_epsilon - else - this%W_epsilon = barostat_mass(maxval(abs(this%stress_ext)), cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor) - endif - use_T = optional_default(-1.0_dp, T) - use_thermalise = optional_default(.true., thermalise) - if (use_thermalise .and. use_T > 0.0_dp) then - this%gamma_epsilon = gamma_epsilon - else - this%gamma_epsilon = 0.0_dp - endif - this%T = use_T - - case default - call system_abort("Invalid barostat type " // type) - - end select - - end subroutine barostat_initialise - - subroutine barostat_finalise(this) - - type(barostat), intent(inout) :: this - - this%type = BAROSTAT_NONE - this%gamma_epsilon = 0.0_dp - this%stress_ext = 0.0_dp - this%hydrostatic_strain = .true. - this%diagonal_strain = .true. - this%finite_strain_formulation = .false. - this%Ndof = 0.0_dp - this%W_epsilon = 0.0_dp - this%epsilon_v = 0.0_dp - this%epsilon_f = 0.0_dp - this%epsilon_r = 0.0_dp; call add_identity(this%epsilon_r) - this%T = -1.0_dp - this%lattice0_initialised = .false. - - end subroutine barostat_finalise - - subroutine barostat_assignment(to,from) - - type(barostat), intent(out) :: to - type(barostat), intent(in) :: from - - to%type = from%type - to%gamma_epsilon = from%gamma_epsilon - to%stress_ext = from%stress_ext - to%hydrostatic_strain = from%hydrostatic_strain - to%diagonal_strain = from%diagonal_strain - to%finite_strain_formulation = from%finite_strain_formulation - to%W_epsilon = from%W_epsilon - to%epsilon_v = from%epsilon_v - to%epsilon_f = from%epsilon_f - to%epsilon_r = from%epsilon_r - to%T = from%T - - end subroutine barostat_assignment - - subroutine barostat_update_barostat(this,p_ext,stress_ext,hydrostatic_strain,diagonal_strain,finite_strain_formulation,W_epsilon,T) - - type(barostat), intent(inout) :: this - real(dp), optional, intent(in) :: p_ext - real(dp), optional, intent(in) :: stress_ext(3,3) - logical, optional, intent(in) :: hydrostatic_strain, diagonal_strain - logical, optional, intent(in) :: finite_strain_formulation - real(dp), optional, intent(in) :: W_epsilon - real(dp), optional, intent(in) :: T - - if( present(p_ext) .and. present(stress_ext)) call system_abort("barostat_update_barostat: got both p_ext and stress_ext, conflict") - if( present(p_ext) ) then - this%stress_ext = 0.0_dp - call add_identity(this%stress_ext) - this%stress_ext = -p_ext * this%stress_ext - endif - if( present(stress_ext) ) this%stress_ext = stress_ext - if( present(hydrostatic_strain) ) this%hydrostatic_strain = hydrostatic_strain - if( present(diagonal_strain) ) this%diagonal_strain = diagonal_strain - if( present(finite_strain_formulation) ) this%finite_strain_formulation = finite_strain_formulation - if( present(W_epsilon) ) this%W_epsilon = W_epsilon - if( present(T) ) this%T = T - - endsubroutine barostat_update_barostat - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X PRINTING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine barostat_print(this,file) - - type(barostat), intent(in) :: this - type(inoutput), optional, intent(in) :: file - - select case(this%type) - - case(BAROSTAT_NONE) - call print('Barostat off',file=file) - - case(BAROSTAT_HOOVER_LANGEVIN) - call print('Hoover-Langevin, stress_ext = '// & - round(this%stress_ext(1,1)/EV_A3_IN_GPA,5)//' '// & - round(this%stress_ext(1,2)/EV_A3_IN_GPA,5)//' '// & - round(this%stress_ext(1,3)/EV_A3_IN_GPA,5)//' '// & - round(this%stress_ext(2,1)/EV_A3_IN_GPA,5)//' '// & - round(this%stress_ext(2,2)/EV_A3_IN_GPA,5)//' '// & - round(this%stress_ext(2,3)/EV_A3_IN_GPA,5)//' '// & - round(this%stress_ext(3,1)/EV_A3_IN_GPA,5)//' '// & - round(this%stress_ext(3,2)/EV_A3_IN_GPA,5)//' '// & - round(this%stress_ext(3,3)/EV_A3_IN_GPA,5)//' GPa , hydrostatic_strain = '//this%hydrostatic_strain//& - ' diagonal_strain = '//this%diagonal_strain//' finite_strain_formulation = '//this%finite_strain_formulation//& - ' gamma_epsilon = '//round(this%gamma_epsilon,5)//' fs^-1, '// & - ' W_epsilon = '//round(this%W_epsilon,5)//' eV/fs, T = '//round(this%T,2)//' K, Ndof = '// round(this%Ndof,1),file=file) - - end select - - end subroutine barostat_print - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X SETTING Ndof - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine set_degrees_of_freedom_int(this,Ndof) - - type(barostat), intent(inout) :: this - integer, intent(in) :: Ndof - - this%Ndof = real(Ndof,dp) - - end subroutine set_degrees_of_freedom_int - - subroutine set_degrees_of_freedom_real(this,Ndof) - - type(barostat), intent(inout) :: this - real(dp), intent(in) :: Ndof - - this%Ndof = Ndof - - end subroutine set_degrees_of_freedom_real - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X CHOOSING NOSE-HOOVER(-LANGEVIN) MASS - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - pure function barostat_mass_int(p_ext, cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor) result(W_epsilon) - - real(dp), intent(in) :: p_ext, cell_volume - integer, intent(in) :: Ndof - real(dp), intent(in) :: gamma_epsilon - real(dp), intent(in), optional :: T - real(dp), intent(in), optional :: W_epsilon_factor - real(dp) :: W_epsilon ! result - - W_epsilon = barostat_mass_real(p_ext, cell_volume, real(Ndof,dp), gamma_epsilon, T, W_epsilon_factor) - - end function barostat_mass_int - - pure function barostat_mass_real(p_ext, cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor) result(W_epsilon) - - real(dp), intent(in) :: p_ext, cell_volume - real(dp), intent(in) :: Ndof - real(dp), intent(in) :: gamma_epsilon - real(dp), intent(in), optional :: T - real(dp), intent(in), optional :: W_epsilon_factor - real(dp) :: W_epsilon ! result - - real(dp) :: use_T, use_W_epsilon_factor - - use_T = optional_default(BAROSTAT_MIN_TEMP, T) - if (use_T <= 0.0_dp) use_T = BAROSTAT_MIN_TEMP - - use_W_epsilon_factor=optional_default(1.0_dp, W_epsilon_factor) - - W_epsilon = use_W_epsilon_factor*max( 9.0_dp*abs(p_ext)*cell_volume/((gamma_epsilon*2.0_dp*PI)**2), & - (Ndof+3.0_dp)*BOLTZMANN_K*use_T/((gamma_epsilon*2.0_dp*PI)**2) ) - - end function barostat_mass_real - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X BAROSTAT ROUTINES - !X - !X These routines interleave the usual velocity Verlet steps and thermostat steps - !X should modify the velocities accelerations, and positions as required: - !X - !X advance_verlet1 - !X 00 (barostat_pre_vel1) * - !X 10 (thermostat_pre_vel1) * - !X 20 v(t+dt/2) = v(t) + a(t)dt/2 - !X 30 (thermostat_post_vel1_pre_pos) - !X 40 r(t+dt) = r(t) + v(t+dt/2)dt - !X 50 (thermostat_post_pos_pre_calc) - !X 60 (barostat_post_pos_pre_calc) * - !X calc F, virial - !X advance_verlet2 - !X 70 (thermostat_post_calc_pre_vel2) * - !X 80 v(t+dt) = v(t+dt/2) + a(t+dt)dt/2 - !X 90 (thermostat_post_vel2) * - !X 100 (barostat_post_vel2) * - !X - !X * marks routines that are needed in the refactored barostat/thermostat plan - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine barostat_pre_vel1(this,at,dt,virial) - - type(barostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - real(dp), dimension(3,3), optional, intent(in) :: virial - - real(dp) :: vel_decay(3,3), pos_scale(3,3), lattice_p(3,3), F_inv(3,3), F_tmp(3,3) - - select case(this%type) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X HOOVER-LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(BAROSTAT_HOOVER_LANGEVIN) - !TIME_PROPAG_TEX 00 - !TIME_PROPAG_TEX 00 {\color {blue} - !TIME_PROPAG_TEX 00 before all Verlet and thermostat steps (barostat\_pre\_vel1) - !TIME_PROPAG_TEX 00 - !TIME_PROPAG_TEX 00 $$ \epsilon_v = \epsilon_v \exp\left( -(\tau/2) \gamma_\epsilon \epsilon_r^{-1}\right)^T$$ - !TIME_PROPAG_TEX 00 $$ \epsilon_v = \epsilon_v + (\tau/2) \epsilon_f/W_\epsilon $$ - !TIME_PROPAG_TEX 00 $$ v = \exp \left( -(\tau/2) (1 + 3/N_d) \epsilon_v \right) v $$ - !TIME_PROPAG_TEX 00 $$ (r,h) = \exp\left( (\tau/2) \epsilon_v \right) (r,h) $$ - !TIME_PROPAG_TEX 00 } - !TIME_PROPAG_TEX 00 - - if (.not. present(virial)) call system_abort("barostat_pre_vel1 needs virial") - - if (.not. this%lattice0_initialised) then - this%lattice0_initialised = .true. - this%lattice0 = at%lattice - call matrix3x3_inverse(this%lattice0, this%lattice0_inv) - this%F_tmp_norm = 0.0_dp - endif - - ! half step epsilon_v drag - if (this%finite_strain_formulation) then - call matrix3x3_inverse(this%epsilon_r, F_inv) - vel_decay = transpose(matrix_exp(-0.5_dp*dt*this%gamma_epsilon*F_inv)) - vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay)) - this%epsilon_v = this%epsilon_v .mult. vel_decay - else - this%epsilon_v = this%epsilon_v * exp(-0.5_dp*dt*this%gamma_epsilon) - endif - ! half step epsilon_v force (from last step) parts - this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_epsilon - - ! half step barostat drag part of v - vel_decay = matrix_exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) - vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay)) - at%velo = vel_decay .mult. at%velo - - ! half step position affine defomration - pos_scale = matrix_exp(0.5_dp*dt*this%epsilon_v) - pos_scale = 0.5_dp*(pos_scale + transpose(pos_scale)) - lattice_p = pos_scale .mult. at%lattice - ! remove any rotation from new lattice - F_tmp = lattice_p .mult. this%lattice0_inv - F_tmp = 0.5_dp*(F_tmp + transpose(F_tmp)) - if (abs(deviation_from_identity(F_tmp) - this%F_tmp_norm) > 5.0e-2) then - call print_message('WARNING', "barostat transformation projecting away rotations is very different from previous one. Did the lattice change?") - endif - this%F_tmp_norm = deviation_from_identity(F_tmp) - lattice_p = F_tmp .mult. this%lattice0 - call set_lattice(at, lattice_p, scale_positions=.true.) - - end select - - end subroutine barostat_pre_vel1 - - subroutine barostat_post_vel1_pre_pos(this,at,dt,virial) - - type(barostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - real(dp), dimension(3,3), optional, intent(in) :: virial - - end subroutine barostat_post_vel1_pre_pos - - subroutine barostat_post_pos_pre_calc(this,at,dt,virial) - - type(barostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - real(dp), dimension(3,3), optional, intent(in) :: virial - - real(dp) :: pos_scale(3,3), lattice_p(3,3), F_tmp(3,3) - - select case(this%type) - - case(BAROSTAT_HOOVER_LANGEVIN) - !TIME_PROPAG_TEX 60 - !TIME_PROPAG_TEX 60 {\color {blue} - !TIME_PROPAG_TEX 60 after Verlet pos step, before force calc (barostat\_post\_pos\_pre\_calc) - !TIME_PROPAG_TEX 60 - !TIME_PROPAG_TEX 60 $$ (r,h) = \exp\left( (\tau/2) \epsilon_v \right) (r,h) $$ - !TIME_PROPAG_TEX 60 } - !TIME_PROPAG_TEX 60 - if (.not. present(virial)) call system_abort("barostat_post_pos_pre_calc needs virial") - - ! half step position affine defomration - pos_scale = matrix_exp(0.5_dp*dt*this%epsilon_v) - pos_scale = 0.5_dp*(pos_scale + transpose(pos_scale)) - lattice_p = pos_scale .mult. at%lattice - ! remove any rotation from new lattice - F_tmp = lattice_p .mult. this%lattice0_inv - F_tmp = 0.5_dp*(F_tmp + transpose(F_tmp)) - if (abs(deviation_from_identity(F_tmp) - this%F_tmp_norm) > 5.0e-2) then - call print_message('WARNING', "barostat transformation projecting away rotations is very different from previous one. Did the lattice change?") - endif - this%F_tmp_norm = deviation_from_identity(F_tmp) - lattice_p = F_tmp .mult. this%lattice0 - call set_lattice(at, lattice_p, scale_positions=.true.) - - end select - - end subroutine barostat_post_pos_pre_calc - - function deviation_from_identity(a) - real(dp), intent(in) :: a(:, :) - real(dp) :: deviation_from_identity - - integer :: i, j - - deviation_from_identity = 0.0_dp - do i=1, size(a, 1) - do j=1, size(a, 2) - if (i == j) then - deviation_from_identity = deviation_from_identity + (a(i,j)-1.0_dp)**2 - else - deviation_from_identity = deviation_from_identity + (a(i,j))**2 - endif - end do - end do - - deviation_from_identity = sqrt(deviation_from_identity) - - end function deviation_from_identity - - subroutine barostat_post_calc_pre_vel2(this,at,dt,virial) - - type(barostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - real(dp), dimension(3,3), optional, intent(in) :: virial - - end subroutine barostat_post_calc_pre_vel2 - - subroutine barostat_post_vel2(this,at,dt,virial) - - type(barostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - real(dp), dimension(3,3), optional, intent(in) :: virial - - integer :: i, j - real(dp) :: vel_decay(3,3), volume_p, rand_f_cell(3,3), kinetic_virial(3,3), F_det, F_T_inv(3,3), F_inv(3,3), epsilon_f_hydrostatic - real(dp) :: rand_f_scale - - select case(this%type) - - case(BAROSTAT_HOOVER_LANGEVIN) - !TIME_PROPAG_TEX 100 - !TIME_PROPAG_TEX 100 {\color {blue} - !TIME_PROPAG_TEX 100 after all Verlet and thermostat steps (barostat\_post\_vel2) - !TIME_PROPAG_TEX 100 - !TIME_PROPAG_TEX 100 $$ v = \exp \left( -(\tau/2) (1 + 3/N_d) \epsilon_v \right) v $$ - !TIME_PROPAG_TEX 100 $$ \epsilon_r = \epsilon_r + \tau \epsilon_v $$ - !TIME_PROPAG_TEX 100 $r.v.$ is symmetric matrix, normal distribution entries, variance 3 on diagonal and 6 off diagonal - !TIME_PROPAG_TEX 100 \begin{eqnarray*} - !TIME_PROPAG_TEX 100 \epsilon_f & = & \left[ 3 \left( \mathrm{vir} + \sum_i m_i v_i \otimes v_i + - !TIME_PROPAG_TEX 100 3 V \epsilon_r \sigma \epsilon_r^T / \left|\epsilon_r\right| + - !TIME_PROPAG_TEX 100 3/N_d \sum_i m_i v_i \otimes v_i \right) + \right. - !TIME_PROPAG_TEX 100 \\ & & \sqrt{2 k_B T \gamma_\epsilon W_\epsilon/\tau} r.v. \bigg] F^{-T} - !TIME_PROPAG_TEX 100 \end{eqnarray*} - !TIME_PROPAG_TEX 100 $$ \epsilon_v = \epsilon_v + (\tau/2) \epsilon_f/W_\epsilon $$ - !TIME_PROPAG_TEX 100 $$ \epsilon_v = \epsilon_v \exp\left( -(\tau/2) \gamma_\epsilon \epsilon_r^{-1}\right)^T$$ - !TIME_PROPAG_TEX 100 } - !TIME_PROPAG_TEX 100 - if (.not. present(virial)) call system_abort("barostat_pre_vel1 needs virial") - - call system_resync_rng() - - !Decay the velocities for dt/2 again barostat part - vel_decay = matrix_exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) - vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay)) - at%velo(:,:) = vel_decay .mult. at%velo(:,:) - - this%epsilon_r = this%epsilon_r + dt*this%epsilon_v - - ! calc epsilon force - volume_p = cell_volume(at) - rand_f_cell = 0.0_dp - do i=1, 3 - do j=i, 3 - if (i == j) then - rand_f_scale = 3.0_dp - else - ! empirical - maybe have something to do with fact that matrix is symmetric so there are - ! fewer degrees of freedom than first appears? - rand_f_scale = 6.0_dp - endif - rand_f_cell(i,j) = sqrt(rand_f_scale)*sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_epsilon*this%W_epsilon/dt)*ran_normal() - end do - end do - - ! symmetrize rand_f_cell - rand_f_cell(2,1) = rand_f_cell(1,2) - rand_f_cell(3,1) = rand_f_cell(1,3) - rand_f_cell(3,2) = rand_f_cell(2,3) - - kinetic_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) - kinetic_virial = 0.5_dp*(kinetic_virial + transpose(kinetic_virial)) - if (this%finite_strain_formulation) then - F_det = matrix3x3_det(this%epsilon_r) - call matrix3x3_inverse(transpose(this%epsilon_r), F_T_inv) - - this%epsilon_f = (3.0_dp*(virial+kinetic_virial+volume_p*(this%epsilon_r .mult. this%stress_ext .mult. transpose(this%epsilon_r))/F_det + & - 3.0_dp/this%Ndof*kinetic_virial) + rand_f_cell) .mult. F_T_inv - else - this%epsilon_f = 3.0_dp*(virial+kinetic_virial+volume_p*this%stress_ext + & - 3.0_dp/this%Ndof*kinetic_virial) + rand_f_cell - endif - - if (this%diagonal_strain .or. this%hydrostatic_strain) then - this%epsilon_f(1,2) = 0.0_dp - this%epsilon_f(1,3) = 0.0_dp - this%epsilon_f(2,3) = 0.0_dp - this%epsilon_f(2,1) = 0.0_dp - this%epsilon_f(3,1) = 0.0_dp - this%epsilon_f(3,2) = 0.0_dp - if (this%hydrostatic_strain) then - epsilon_f_hydrostatic = (this%epsilon_f(1,1)+ this%epsilon_f(2,2)+ this%epsilon_f(3,3)) / 3.0_dp - this%epsilon_f(1,1) = epsilon_f_hydrostatic - this%epsilon_f(2,2) = epsilon_f_hydrostatic - this%epsilon_f(3,3) = epsilon_f_hydrostatic - endif - endif - - ! half step with epsilon force - this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_epsilon - ! half step with epsilon drag - if (this%finite_strain_formulation) then - call matrix3x3_inverse(this%epsilon_r, F_inv) - vel_decay = transpose(matrix_exp(-0.5_dp*dt*this%gamma_epsilon*F_inv)) - vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay)) - this%epsilon_v = this%epsilon_v .mult. vel_decay - else - this%epsilon_v = this%epsilon_v * exp(-0.5_dp*dt*this%gamma_epsilon) - endif - - call print("BAROSTAT_KE "//barostat_KE(this)) - - end select - - end subroutine barostat_post_vel2 - - function barostat_KE(this) - type(barostat), intent(in) :: this - real(dp) :: barostat_KE - - select case(this%type) - case(BAROSTAT_HOOVER_LANGEVIN) - barostat_KE = 0.5_dp*this%W_epsilon*sum(this%epsilon_v*transpose(this%epsilon_v)) - end select - end function barostat_KE - -end module barostat_module diff --git a/src/libAtoms/CInOutput.f95 b/src/libAtoms/CInOutput.f95 deleted file mode 100644 index ce942e07fd..0000000000 --- a/src/libAtoms/CInOutput.f95 +++ /dev/null @@ -1,1090 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module CInOutput_module - - !% Interface to C routines for reading and writing Atoms objects to and from XYZ and NetCDF files. - - use iso_c_binding - use error_module - use linearalgebra_module, only: print, operator(.mult.), operator(.fne.) - use Extendable_str_module, only: Extendable_str, operator(//), string, concat, assignment(=) - use System_module, only: dp, current_verbosity, optional_default, s2a, a2s, parse_string, print, & - PRINT_NORMAL, PRINT_VERBOSE, PRINT_ALWAYS, PRINT_NERD, INPUT, OUTPUT, INOUT, lower_case, print_message - use PeriodicTable_module, only: atomic_number_from_symbol, ElementName - use Table_module, only: Table, allocate, append, TABLE_STRING_LENGTH - use Dictionary_module, only: Dictionary, has_key, get_value, set_value, print, subset, swap, lookup_entry_i, & - T_INTEGER, T_CHAR, T_REAL, T_LOGICAL, T_INTEGER_A, T_REAL_A, T_INTEGER_A2, T_REAL_A2, T_LOGICAL_A, T_CHAR_A, & - print_keys, c_dictionary_ptr_type, assignment(=) - use Atoms_module, only: Atoms, initialise, is_initialised, is_domain_decomposed, finalise, set_lattice, & - atoms_repoint, transform_basis, bcast, has_property, set_cutoff - use Atoms_types_module, only : add_property - use MPI_Context_module, only: MPI_context - use DomainDecomposition_module, only: allocate, comm_atoms_to_all - - implicit none - - private - - interface - - subroutine read_netcdf(filename, params, properties, selected_properties, lattice, cell_lengths, cell_angles, cell_rotated, & - n_atom, frame, zero, range, irep, rrep, error) bind(c) - use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename - integer(kind=C_INT), dimension(SIZEOF_FORTRAN_T), intent(in) :: params, properties, selected_properties - real(kind=C_DOUBLE), dimension(3,3), intent(out) :: lattice - real(kind=C_DOUBLE), dimension(3), intent(out) :: cell_lengths, cell_angles - integer(kind=C_INT), intent(out) :: cell_rotated, n_atom - integer(kind=C_INT), intent(in), value :: frame, zero, irep - integer(kind=C_INT), intent(in) :: range(2) - real(kind=C_DOUBLE), intent(in), value :: rrep - integer(kind=C_INT), intent(out) :: error - end subroutine read_netcdf - - subroutine write_netcdf(filename, params, properties, selected_properties, lattice, cell_lengths, cell_angles, cell_rotated, & - n_atom, n_label, n_string, frame, netcdf4, append, & - shuffle, deflate, deflate_level, error) bind(c) - use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename - integer(kind=C_INT), dimension(SIZEOF_FORTRAN_T), intent(in) :: params, properties, selected_properties - real(kind=C_DOUBLE), dimension(3,3), intent(in) :: lattice - real(kind=C_DOUBLE), dimension(3), intent(in) :: cell_lengths(3), cell_angles(3) - integer(kind=C_INT), intent(in), value :: cell_rotated, n_atom, n_label, n_string, frame, netcdf4, append, shuffle, deflate, deflate_level - integer(kind=C_INT), intent(out) :: error - end subroutine write_netcdf - - subroutine query_netcdf(filename, n_frame, n_atom, n_label, n_string, error) bind(c) - use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename - integer(kind=C_INT), intent(out) :: n_frame, n_atom, n_label, n_string - integer(kind=C_INT), intent(out) :: error - end subroutine query_netcdf - - subroutine read_xyz(filename, params, properties, selected_properties, lattice, n_atom, compute_index, frame, range, & - string, string_length, n_index, indices, error) bind(c) - use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename - integer(kind=C_INT), dimension(SIZEOF_FORTRAN_T), intent(in) :: params, properties, selected_properties - real(kind=C_DOUBLE), dimension(3,3), intent(out) :: lattice - integer(kind=C_INT), intent(inout) :: n_atom - integer(kind=C_INT), intent(in), value :: compute_index, frame, string, string_length - - integer(kind=C_INT), intent(in) :: range(2) - integer(kind=C_INT), intent(in), value :: n_index - integer(kind=C_INT), intent(in), dimension(n_index) :: indices - integer(kind=C_INT), intent(out) :: error - end subroutine read_xyz - - subroutine write_xyz(filename, params, properties, selected_properties, lattice, n_atom, append, prefix, & - int_format, real_format, str_format, logical_format, string, estr, update_index, error) bind(c) - use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename - integer(kind=C_INT), dimension(SIZEOF_FORTRAN_T), intent(in) :: params, properties, selected_properties, estr - real(kind=C_DOUBLE), dimension(3,3), intent(in) :: lattice - integer(kind=C_INT), intent(in), value :: n_atom, append, update_index - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: prefix, int_format, real_format, str_format, logical_format - integer(kind=C_INT), intent(in), value :: string - integer(kind=C_INT), intent(out) :: error - end subroutine write_xyz - - subroutine query_xyz(filename, compute_index, frame, n_frame, n_atom, error) bind(c) - use iso_c_binding, only: C_CHAR, C_INT - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename - integer(kind=C_INT), intent(in), value :: compute_index, frame - integer(kind=C_INT), intent(out) :: n_frame, n_atom - integer(kind=C_INT), intent(out) :: error - end subroutine query_xyz - - subroutine quip_getcwd_wrapper(getcwd_return,getcwd_size) bind(c,name="fgetcwd_") - use, intrinsic :: iso_c_binding, only : c_char, c_int, c_null_char - implicit none - integer(kind=c_int), intent(in) :: getcwd_size - character(kind=c_char), dimension(getcwd_size) :: getcwd_return - endsubroutine quip_getcwd_wrapper - - function quip_getcwd_size_wrapper() bind(c,name="fgetcwd_size_") - use, intrinsic :: iso_c_binding, only : c_int - implicit none - integer(kind=c_int) :: quip_getcwd_size_wrapper - endfunction quip_getcwd_size_wrapper - - subroutine quip_chdir_wrapper(path) bind(c,name="fchdir_") - use, intrinsic :: iso_c_binding - implicit none - character(kind=c_char), dimension(*) :: path - endsubroutine quip_chdir_wrapper - - function quip_dirname_size_wrapper(path) bind(c,name="fdirname_size_") - use, intrinsic :: iso_c_binding, only : c_int, c_char - implicit none - integer(kind=c_int) :: quip_dirname_size_wrapper - character(kind=c_char), dimension(*) :: path - endfunction quip_dirname_size_wrapper - - subroutine quip_dirname_wrapper(path,dirname,dirname_size) bind(c,name="fdirname_") - use, intrinsic :: iso_c_binding - implicit none - integer(kind=c_int) :: dirname_size - character(kind=c_char), dimension(*) :: path - character(kind=c_char), dimension(*) :: dirname - endsubroutine quip_dirname_wrapper - - function quip_basename_size_wrapper(path) bind(c,name="fbasename_size_") - use, intrinsic :: iso_c_binding, only : c_int, c_char - implicit none - integer(kind=c_int) :: quip_basename_size_wrapper - character(kind=c_char), dimension(*) :: path - endfunction quip_basename_size_wrapper - - subroutine quip_basename_wrapper(path,basename,basename_size) bind(c,name="fbasename_") - use, intrinsic :: iso_c_binding - implicit none - integer(kind=c_int) :: basename_size - character(kind=c_char), dimension(*) :: path - character(kind=c_char), dimension(*) :: basename - endsubroutine quip_basename_wrapper - - function fmd5sum(filename,md5sum) bind(c,name="fmd5sum_") - use, intrinsic :: iso_c_binding, only : c_int, c_char - implicit none - integer(kind=c_int) :: fmd5sum - character(kind=c_char), dimension(*) :: filename - character(kind=c_char), dimension(33) :: md5sum - endfunction fmd5sum - - end interface - - integer, parameter :: XYZ_FORMAT = 1 - integer, parameter :: NETCDF_FORMAT = 2 - real(dp), parameter :: LATTICE_TOL = 1.0e-8_dp - - type CInOutput - logical :: initialised = .false. - character(len=1024) :: filename, basename, extension - integer :: action - integer :: format - logical :: got_index - logical :: netcdf4 - logical :: append - logical :: one_frame_per_file - integer :: current_frame - integer :: n_frame - integer :: n_atom - integer :: n_label - integer :: n_string - integer :: n_digit - type(MPI_Context) :: mpi - end type CInOutput - - interface initialise - !% Open a file for reading or writing. File type (Extended XYZ or NetCDF) is guessed from - !% filename extension. Filename 'stdout' with action 'OUTPUT' to write XYZ to stdout. - module procedure CInOutput_initialise - end interface - - interface finalise - !% Close file and free memory. Calls close() interface. - module procedure CInOutput_finalise - end interface - - interface close - !% Close file. After a call to close(), you can can call initialise() again - !% to reopen a new file. - module procedure CInOutput_close - end interface - - interface read - !% Read an Atoms object from this CInOutput stream. - !% - !% Important :attr:`~.Atoms.properties` which may be present (non-exhaustive list): - !% - !% * **species**, str, 1 col -- atomic species, e.g. Si or H - !% * **pos**, real, 3 cols -- cartesian positions, in A - !% * **Z**, int, 1 col -- atomic numbers - !% * **mass**, real, 1 col -- atomic masses, in A,eV,fs units system - !% * **velo**, real, 3 cols -- velocities, in A/fs - !% * **acc**, real, 3 cols -- accelerations, in A/fs$^2$ - !% * **hybrid**, int, 1 col -- one for QM atoms and zero for hybrid atoms - !% * **frac_pos**, real, 3 cols -- fractional positions of atoms - !% - !% Along with all :attr:`~Atoms.params` entries, the - !% :attr:`~.Atoms.lattice`, :attr:`~.Atoms.cutoff`, and - !% attr:`~Atoms.nneightol` attributes are read from the comment - !% line of XYZ file, or from special variables in NetCDF files - module procedure CInOutput_read - module procedure atoms_read - module procedure atoms_read_cinoutput - end interface - - interface write - !% Write an Atoms object to this CInOutput stream. - ! - !% Along with all atomic :attr:`~.Atoms.properties` and - !% :attr:`~Atoms.params` entries, the :attr:`~.Atoms.lattice`, - !% :attr:`~.Atoms.cutoff` and attr:`~Atoms.nneightol` attributes - !% are written to the comment line of XYZ file, or from special - !% variables in NetCDF files - module procedure CInOutput_write - module procedure atoms_write - module procedure atoms_write_cinoutput - end interface - - interface quip_chdir - module procedure quip_chdir_char - module procedure quip_chdir_extendable_str - end interface quip_chdir - - interface quip_dirname - module procedure quip_dirname_char - module procedure quip_dirname_extendable_str - end interface quip_dirname - - interface quip_basename - module procedure quip_basename_char - module procedure quip_basename_extendable_str - end interface quip_basename - - public :: CInOutput, initialise, finalise, close, read, write - public :: quip_getcwd, quip_chdir, quip_dirname, quip_basename, quip_md5sum - -contains - - subroutine cinoutput_initialise(this, filename, action, append, netcdf4, no_compute_index, frame, one_frame_per_file, mpi, error) - use iso_c_binding, only: C_INT - type(CInOutput), intent(inout) :: this - character(*), intent(in), optional :: filename - integer, intent(in), optional :: action - logical, intent(in), optional :: append - logical, optional, intent(in) :: netcdf4 - logical, optional, intent(in) :: no_compute_index - logical, optional, intent(in) :: one_frame_per_file - integer, optional, intent(in) :: frame - type(MPI_context), optional, intent(in) :: mpi - integer, intent(out), optional :: error - - character(len=1024) :: my_filename - character(len=100) :: fmt - integer :: compute_index, n_file, dot_index - logical :: file_exists - - INIT_ERROR(error) - - this%action = optional_default(INPUT, action) - this%append = optional_default(.false., append) - this%netcdf4 = optional_default(.false., netcdf4) - this%filename = optional_default('', filename) - this%one_frame_per_file = optional_default(.false., one_frame_per_file) - compute_index = 1 - if (present(no_compute_index)) then - if (no_compute_index) compute_index = 0 - end if - if (present(mpi)) this%mpi = mpi - - dot_index = index(filename,'.',.true.) - if (dot_index == 0) then - this%basename = this%filename - this%extension = '' - else - this%basename = filename(:dot_index-1) - this%extension = filename(dot_index:) - end if - this%n_digit = 0 - if (this%one_frame_per_file) then - compute_index = 0 - do - if (this%filename(dot_index-1-this%n_digit:dot_index-1-this%n_digit) /= '0') exit - this%n_digit = this%n_digit + 1 - this%basename = this%filename(:dot_index-1-this%n_digit) - end do - if (this%n_digit == 0) then - RAISE_ERROR("one_frame_per_file=T but no zeros found in filename - use e.g. file_00000.xyz", error) - end if - fmt = '(a,i'//this%n_digit//'.'//this%n_digit//',a)' - end if - - ! Guess format from file extension - if (trim(filename) == '') then - this%format = XYZ_FORMAT - else - if (trim(this%extension) == '.nc') then - this%format = NETCDF_FORMAT - else - this%format = XYZ_FORMAT - end if - end if - - this%n_frame = 0 - this%n_atom = 0 - this%n_label = 0 - this%n_string = 0 - this%current_frame = optional_default(0, frame) - this%got_index = .false. - - ! Should we do an initial query to count number of frames/atoms? - if (.not. this%mpi%active .or. (this%mpi%active .and. this%mpi%my_proc == 0)) then - if (this%one_frame_per_file) then - n_file = 0 - do - write (my_filename, fmt) trim(this%basename), n_file, trim(this%extension) - inquire(file=my_filename, exist=file_exists) - if (.not. file_exists) exit - n_file = n_file + 1 - end do - write (my_filename, fmt) trim(this%basename), 0, trim(this%extension) ! do query on frame 0 - file_exists = n_file > 0 - else - my_filename = this%filename - inquire(file=my_filename, exist=file_exists) - end if - my_filename = trim(my_filename)//C_NULL_CHAR - if (file_exists) then - if (this%format == NETCDF_FORMAT) then - call query_netcdf(my_filename, this%n_frame, this%n_atom, this%n_label, this%n_string, error) - BCAST_PASS_ERROR(error, this%mpi) - this%got_index = .true. - else - if (this%action /= OUTPUT .and. trim(this%filename) /= '' .and. trim(this%filename) /= 'stdin' .and. trim(this%filename) /= 'stdout') then - call query_xyz(my_filename, compute_index, this%current_frame, this%n_frame, this%n_atom, error) - BCAST_PASS_ERROR(error, this%mpi) - this%got_index = .false. - if (compute_index == 1) this%got_index = .true. - else - this%got_index = .false. - end if - end if - end if - if (this%one_frame_per_file) this%n_frame = n_file - end if - - if (this%mpi%active) then - BCAST_CHECK_ERROR(error, this%mpi) - call bcast(this%mpi, this%n_frame) - call bcast(this%mpi, this%n_atom) - call bcast(this%mpi, this%n_label) - call bcast(this%mpi, this%n_string) - end if - - if (this%action /= INPUT .and. this%append) this%current_frame = this%n_frame - - this%initialised = .true. - - end subroutine cinoutput_initialise - - subroutine cinoutput_close(this) - type(CInOutput), intent(inout) :: this - - this%initialised = .false. - - end subroutine cinoutput_close - - subroutine cinoutput_finalise(this) - type(CInOutput), intent(inout) :: this - - call cinoutput_close(this) - - end subroutine cinoutput_finalise - - - subroutine cinoutput_read(this, at, properties, properties_array, frame, zero, range, str, estr, indices, error) - use iso_c_binding, only: C_INT - type(CInOutput), intent(inout) :: this - type(Atoms), target, intent(inout) :: at - character(*), intent(in), optional :: properties - character(*), intent(in), optional :: properties_array(:) - integer, optional, intent(in) :: frame - logical, optional, intent(in) :: zero - integer, optional, intent(in) :: range(2) - character(*), intent(in), optional :: str - type(extendable_str), intent(in), optional :: estr - integer, dimension(:), intent(in), optional :: indices - integer, intent(out), optional :: error - - type(Dictionary) :: empty_dictionary - type(Dictionary), target :: selected_properties, tmp_params - integer :: i, j, k, n_properties - integer(C_INT) :: do_zero, do_compute_index, do_frame, i_rep, do_range(2), cell_rotated, n_index - integer(C_INT), dimension(:), allocatable :: c_indices - real(C_DOUBLE) :: r_rep - real(dp) :: lattice(3,3), maxlen(3), sep(3), cell_lengths(3), cell_angles(3), orig_lattice(3,3), cutoff, nneightol - type(c_dictionary_ptr_type) :: params_ptr, properties_ptr, selected_properties_ptr - integer, dimension(SIZEOF_FORTRAN_T) :: params_ptr_i, properties_ptr_i, selected_properties_ptr_i - integer n_atom - character(len=100) :: tmp_properties_array(100), fmt - character(len=1024) :: filename - type(Extendable_Str), dimension(:), allocatable :: filtered_keys - logical, dimension(3) :: pbc - - real, parameter :: vacuum = 10.0_dp ! amount of vacuum to add if no lattice found in file - - INIT_ERROR(error) - - if (.not. this%initialised) then - RAISE_ERROR_WITH_KIND(ERROR_IO,"This CInOutput object is not initialised", error) - endif - if (this%action /= INPUT .and. this%action /= INOUT) then - RAISE_ERROR_WITH_KIND(ERROR_IO,"Cannot read from action=OUTPUT CInOutput object", error) - endif - - if (present(str) .and. present(estr)) then - RAISE_ERROR('CInOutput_read: only one of "str" and "estr" may be present, not both', error) - end if - - if (present(range) .and. is_domain_decomposed(at)) then - RAISE_ERROR("atoms_read_cinoutput: Please provide either *range* only if the system is not domain decomposed.", error) - endif - - call finalise(at) - - n_atom = 0 - - if (.not. this%mpi%active .or. (this%mpi%active .and. this%mpi%my_proc == 0)) then - - call print('cinoutput_read: doing read on proc '//this%mpi%my_proc, PRINT_NERD) - - do_frame = optional_default(this%current_frame, frame) - - if (this%n_frame /= 0) then - if (do_frame < 0) do_frame = this%n_frame + do_frame ! negative frames count backwards from end - if (do_frame < 0 .or. do_frame >= this%n_frame) then - BCAST_RAISE_ERROR_WITH_KIND(ERROR_IO_EOF,"cinoutput_read: frame "//int(do_frame)//" out of range 0 <= frame < "//int(this%n_frame), error, this%mpi) - end if - end if - - do_zero = 0 - if (present(zero)) then - if (zero) do_zero = 1 - end if - - do_range(:) = 0 - if (present(range)) do_range = range - if (is_domain_decomposed(at)) then - ! Only read part of the files... - do_range = (/ & - at%domain%mpi%my_proc*this%n_atom/at%domain%mpi%n_procs+1, & - (at%domain%mpi%my_proc+1)*this%n_atom/at%domain%mpi%n_procs & - /) - n_atom = this%n_atom - endif - - n_index = -1 - if (present(indices)) then - if (this%format == NETCDF_FORMAT) then - RAISE_ERROR('cinoutput_read: indices argument not yet supported for NetCDF files', error) - end if - n_index = size(indices) - allocate(c_indices(n_index)) - c_indices(:) = indices - else - allocate(c_indices(0)) - end if - - call initialise(selected_properties) - if (present(properties) .or. present(properties_array)) then - if (present(properties_array)) then - do i=1,size(properties_array) - call set_value(selected_properties, properties_array(i), 1) - end do - PASS_ERROR(error) - else ! we've got a colon-separated string - call parse_string(properties, ':', tmp_properties_array, n_properties, error=error) - PASS_ERROR(error) - if (n_properties > size(tmp_properties_array)) then - RAISE_ERROR('cinoutput_read: too many properties given in "properties" argument', error) - end if - do i=1,n_properties - call set_value(selected_properties, tmp_properties_array(i), 1) - end do - end if - end if - - lattice = 0.0_dp - lattice(1,1) = 1.0_dp - lattice(2,2) = 1.0_dp - lattice(3,3) = 1.0_dp - call initialise(empty_dictionary) ! pass an empty dictionary to prevent pos, species, z properties being created - call initialise(at, 0, lattice, & - Nbuffer=this%n_atom, properties=empty_dictionary) - call finalise(empty_dictionary) - - call initialise(tmp_params) - params_ptr%p => tmp_params - properties_ptr%p => at%properties - selected_properties_ptr%p => selected_properties - params_ptr_i = transfer(params_ptr, params_ptr_i) - properties_ptr_i = transfer(properties_ptr, properties_ptr_i) - selected_properties_ptr_i = transfer(selected_properties_ptr, selected_properties_ptr_i) - - if (this%one_frame_per_file) then - fmt = '(a,i'//this%n_digit//'.'//this%n_digit//',a)' - write (filename, fmt) trim(this%basename), do_frame, trim(this%extension) - do_frame = 0 - else - filename = this%filename - end if - filename = trim(filename)//C_NULL_CHAR - - if (this%format == NETCDF_FORMAT) then - i_rep = 0 - r_rep = 0.0_dp - - call read_netcdf(filename, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & - orig_lattice, cell_lengths, cell_angles, cell_rotated, n_atom, do_frame, do_zero, do_range, i_rep, r_rep, error) - else - do_compute_index = 1 - if (.not. this%got_index) do_compute_index = 0 - if (present(str)) then - call read_xyz(str, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & - orig_lattice, n_atom, do_compute_index, do_frame, do_range, 1, len_trim(str), & - n_index, c_indices, error) - else if(present(estr)) then - call read_xyz(estr%s, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & - orig_lattice, n_atom, do_compute_index, do_frame, do_range, 1, estr%len, & - n_index, c_indices, error) - else - call read_xyz(filename, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & - orig_lattice, n_atom, do_compute_index, do_frame, do_range, 0, 0, & - n_index, c_indices, error) - end if - end if - BCAST_PASS_ERROR(error, this%mpi) - call finalise(selected_properties) - deallocate(c_indices) - - if (get_value(tmp_params, 'cutoff', cutoff)) then - call set_cutoff(at, cutoff) - end if - - if (get_value(tmp_params, 'pbc', pbc)) then - at%is_periodic = pbc - end if - - if (get_value(tmp_params, 'nneightol', nneightol)) at%nneightol = nneightol - - ! Copy tmp_params into at%params, removing "Lattice", "Properties", "cutoff", - ! "pbc" and "nneightol"entries - allocate(filtered_keys(tmp_params%N)) - j = 1 - do i=1,tmp_params%N - if (string(tmp_params%keys(i)) == 'Lattice' .or. & - string(tmp_params%keys(i)) == 'Properties' .or. & - string(tmp_params%keys(i)) == 'cutoff' .or. & - string(tmp_params%keys(i)) == 'nneightol' .or. & - string(tmp_params%keys(i)) == 'pbc') cycle - - call initialise(filtered_keys(j), tmp_params%keys(i)) - j = j + 1 - end do - - call subset(tmp_params, filtered_keys(1:j-1), at%params) - call finalise(tmp_params) - do i=1,size(filtered_keys) - call finalise(filtered_keys(i)) - end do - deallocate(filtered_keys) - - at%N = n_atom - at%Ndomain = at%N - if (is_domain_decomposed(at)) then - ! XXX FIXME For now: Buffer size it total number of atoms - at%Nbuffer = this%n_atom - else - at%Nbuffer = at%N - endif - at%ref_count = 1 - call atoms_repoint(at) - - if (this%format == XYZ_FORMAT) then - at%lattice = orig_lattice - ! read_xyz() sets all lattice components to 0.0 if no lattice was present - - if (all(abs(at%lattice) < 1e-5_dp)) then - at%lattice(:,:) = 0.0_dp - - maxlen = 0.0_dp - do i=1,at%N - do j=1,at%N - sep = at%pos(:,i)-at%pos(:,j) - do k=1,3 - if (abs(sep(k)) > maxlen(k)) maxlen(k) = abs(sep(k)) - end do - end do - end do - - do k=1,3 - at%lattice(k,k) = maxlen(k) + vacuum - end do - end if - call set_lattice(at, at%lattice, scale_positions=.false.) - else - ! NetCDF format. We may have to undo rotation of positions and lattice - - ! First construct lattice from cell_lengths and cell_angles - ! By construction, this lattice will have cell vector a parallel to x axis - ! and cell vector b in x-y plane - call lattice_abc_to_xyz(cell_lengths, cell_angles, lattice) - call set_lattice(at, lattice, scale_positions=.false.) - - ! If a rotation was applied, now revert to original stored lattice, rotating positions - if (cell_rotated == 1) then - call transform_basis(at, orig_lattice .mult. at%g) - end if - end if - - if (.not. has_property(at,"Z") .and. .not. has_property(at, "species")) then - call print ("at%properties keys", PRINT_ALWAYS) - call print_keys(at%properties, PRINT_ALWAYS) - BCAST_RAISE_ERROR('cinoutput_read: atoms object read from file has neither Z nor species', error, this%mpi) - else if (.not. has_property(at,"species") .and. has_property(at,"Z")) then - call add_property(at, "species", repeat(" ",TABLE_STRING_LENGTH)) - call atoms_repoint(at) - do i=1,at%N - at%species(1:len(ElementName(at%Z(i))),i) = s2a(ElementName(at%Z(i))) - end do - else if (.not. has_property(at,"Z") .and. has_property(at, "species")) then - call add_property(at, "Z", 0) - call atoms_repoint(at) - do i=1,at%n - at%Z(i) = atomic_number_from_symbol(a2s(at%species(:,i))) - end do - end if - - this%current_frame = this%current_frame + 1 - - end if - - if (this%mpi%active) then - BCAST_CHECK_ERROR(error,this%mpi) - call bcast(this%mpi, at) - end if - - if (is_domain_decomposed(at)) then - call allocate(at%domain, at, range=do_range, error=error) - PASS_ERROR(error) - ! Set global indices - call comm_atoms_to_all(at%domain, at, error=error) - PASS_ERROR(error) - endif - - end subroutine cinoutput_read - - - subroutine cinoutput_write(this, at, properties, properties_array, prefix, int_format, real_format, frame, & - shuffle, deflate, deflate_level, estr, update_index, error) - type c_extendable_str_ptr_type - type(Extendable_str), pointer :: p - end type c_extendable_str_ptr_type - type(CInOutput), intent(inout) :: this - type(Atoms), target, intent(inout) :: at - character(*), intent(in), optional :: properties - character(*), intent(in), optional :: properties_array(:) - character(*), intent(in), optional :: prefix - character(*), intent(in), optional :: int_format, real_format - integer, intent(in), optional :: frame - logical, intent(in), optional :: shuffle, deflate, update_index - integer, intent(in), optional :: deflate_level - type(Extendable_Str), intent(inout), optional, target :: estr - integer, intent(out), optional :: error - - logical :: file_exists - integer :: i - integer(C_INT) :: do_frame, n_label, n_string, do_netcdf4, do_update_index - type(Dictionary), target :: selected_properties, tmp_params - character(len=100) :: do_prefix, do_int_format, do_real_format, do_str_format, do_logical_format, fmt - character(len=1024) :: filename - integer(C_INT) :: do_shuffle, do_deflate, do_deflate_level, append - character(len=100) :: tmp_properties_array(at%properties%n) - integer n_properties - type(c_dictionary_ptr_type) :: params_ptr, properties_ptr, selected_properties_ptr - integer, dimension(SIZEOF_FORTRAN_T) :: params_ptr_i, properties_ptr_i, selected_properties_ptr_i, estr_ptr_i - type(c_extendable_str_ptr_type) :: estr_ptr - real(dp) :: cell_lengths(3), cell_angles(3), orig_lattice(3,3), new_lattice(3,3) - integer :: cell_rotated - - INIT_ERROR(error) - - if (.not. this%initialised) then - RAISE_ERROR("cinoutput_write: this CInOutput object is not initialised", error) - endif - if (this%action /= OUTPUT .and. this%action /= INOUT) then - RAISE_ERROR("cinoutput_write: cannot write to action=INPUT CInOutput object", error) - endif - if (.not. is_initialised(at)) then - RAISE_ERROR("cinoutput_write: atoms object not initialised", error) - end if - - if (this%mpi%active .and. this%mpi%my_proc /= 0) return - - ! These are C-strings and thus must be terminated with '\0' - do_prefix = trim(optional_default('', prefix))//C_NULL_CHAR - do_int_format = trim(optional_default('%8d', int_format))//C_NULL_CHAR - do_real_format = trim(optional_default('%16.8f', real_format))//C_NULL_CHAR - do_str_format = '%.10s'//C_NULL_CHAR - do_logical_format = '%5c'//C_NULL_CHAR - - do_frame = optional_default(this%current_frame, frame) - - do_shuffle = transfer(optional_default(.true., shuffle),do_shuffle) - do_deflate = transfer(optional_default(.true., deflate),do_shuffle) - do_deflate_level = optional_default(6, deflate_level) - do_update_index = transfer(optional_default(.true., update_index), do_update_index) - - append = 0 - inquire(file=this%filename, exist=file_exists) - if (file_exists .and. this%append .or. (.not. this%one_frame_per_file .and. this%current_frame /= 0)) append = 1 - - do_netcdf4 = 0 - if (this%netcdf4) do_netcdf4 = 1 - - - if (present(properties) .and. present(properties_array)) then - RAISE_ERROR('cinoutput_write: "properties" and "properties_array" cannot both be present.', error) - end if - - if (this%format == NETCDF_FORMAT) then - ! Since lattice is stored in NetCDF file as cell lengths and angles, - ! we may need to rotate atomic positions to align cell vector a - ! with x axis and cell vector b lies in x-y plane. - ! This transformation preserves the fractional coordinates. - - orig_lattice = at%lattice - call lattice_xyz_to_abc(at%lattice, cell_lengths, cell_angles) - call lattice_abc_to_xyz(cell_lengths, cell_angles, new_lattice) - - cell_rotated = 0 - if (maxval(abs(orig_lattice - new_lattice)) > LATTICE_TOL) then - cell_rotated = 1 - call transform_basis(at, new_lattice .mult. at%g) - end if - end if - - call initialise(selected_properties) - if (.not. present(properties) .and. .not. present(properties_array)) then - do i=1,at%properties%N - call set_value(selected_properties, string(at%properties%keys(i)), 1) - end do - else - if (present(properties_array)) then - do i=1,size(properties_array) - call set_value(selected_properties, properties_array(i), 1) - end do - else ! we've got a colon-separated string - call parse_string(properties, ':', tmp_properties_array, n_properties, error=error) - PASS_ERROR(error) - do i=1,n_properties - call set_value(selected_properties, tmp_properties_array(i), 1) - end do - end if - end if - - tmp_params = at%params ! Make a copy since write_xyz() adds "Lattice" and "Properties" keys - - call set_value(tmp_params, 'cutoff', at%cutoff) - call set_value(tmp_params, 'nneightol', at%nneightol) - call set_value(tmp_params, 'pbc', at%is_periodic) - - params_ptr%p => tmp_params - properties_ptr%p => at%properties - selected_properties_ptr%p => selected_properties - params_ptr_i = transfer(params_ptr, params_ptr_i) - properties_ptr_i = transfer(properties_ptr, properties_ptr_i) - selected_properties_ptr_i = transfer(selected_properties_ptr, selected_properties_ptr_i) - if (present(estr)) then - estr_ptr%p => estr - estr_ptr_i = transfer(estr_ptr, estr_ptr_i) - end if - - n_label = 10 - n_string = 1024 - - if (this%one_frame_per_file) then - fmt = '(a,i'//this%n_digit//'.'//this%n_digit//',a)' - write (filename, fmt) trim(this%basename), do_frame, trim(this%extension) - do_frame = 0 - do_update_index = 0 - else - filename = this%filename - end if - filename = trim(filename)//C_NULL_CHAR - - if (this%format == NETCDF_FORMAT) then - - call write_netcdf(filename, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & - orig_lattice, cell_lengths, cell_angles, cell_rotated, at%n, n_label, n_string, do_frame, & - do_netcdf4, append, do_shuffle, do_deflate, do_deflate_level, error) - PASS_ERROR(error) - - if (cell_rotated == 1) then - ! Revert to original basis - call transform_basis(at, orig_lattice .mult. at%g) - end if - - else - ! Put "species" in first column and "pos" in second - if (selected_properties%n > 1) then - if (has_key(selected_properties, 'species')) & - call swap(selected_properties, 'species', string(selected_properties%keys(1))) - if (has_key(selected_properties, 'pos')) & - call swap(selected_properties, 'pos', string(selected_properties%keys(2))) - end if - - if (present(estr)) then - call write_xyz(''//C_NULL_CHAR, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & - at%lattice, at%n, append, do_prefix, do_int_format, do_real_format, do_str_format, do_logical_format, 1, estr_ptr_i, 0, error) - else - call write_xyz(filename, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & - at%lattice, at%n, append, do_prefix, do_int_format, do_real_format, do_str_format, do_logical_format, 0, estr_ptr_i, & - do_update_index, error) - end if - PASS_ERROR(error) - end if - - call finalise(selected_properties) - call finalise(tmp_params) - this%current_frame = this%current_frame + 1 - - end subroutine cinoutput_write - - subroutine atoms_read(this, filename, properties, properties_array, frame, zero, range, str, estr, no_compute_index, mpi, error) - !% Read Atoms object from XYZ or NetCDF file. - type(Atoms), intent(inout) :: this - character(len=*), intent(in), optional :: filename - character(*), intent(in), optional :: properties - character(*), intent(in), optional :: properties_array(:) - integer, optional, intent(in) :: frame - logical, optional, intent(in) :: zero - integer, optional, intent(in) :: range(2) - character(len=*), intent(in), optional :: str - type(extendable_str), intent(in), optional :: estr - logical, optional, intent(in) :: no_compute_index - type(MPI_context), optional, intent(inout) :: mpi - integer, intent(out), optional :: error - - type(CInOutput) :: cio - - INIT_ERROR(error) - - if (present(mpi) .and. is_domain_decomposed(this)) then - RAISE_ERROR("atoms_read: Please provide *mpi* only if the Atoms object is not domain decomposed.", error) - endif - - call initialise(cio, filename, INPUT, no_compute_index=no_compute_index, mpi=mpi, error=error) - PASS_ERROR_WITH_INFO('While reading "' // filename // '".', error) - call read(cio, this, properties, properties_array, frame, zero, range, str, estr, error=error) - PASS_ERROR_WITH_INFO('While reading "' // filename // '".', error) - call finalise(cio) - - end subroutine atoms_read - - subroutine atoms_read_cinoutput(this, cio, properties, properties_array, frame, zero, range, str, estr, error) - type(Atoms), target, intent(inout) :: this - type(CInOutput), intent(inout) :: cio - character(*), intent(in), optional :: properties - character(*), intent(in), optional :: properties_array(:) - integer, optional, intent(in) :: frame - logical, optional, intent(in) :: zero - integer, optional, intent(in) :: range(2) - character(len=*), intent(in), optional :: str - type(extendable_str), intent(in), optional :: estr - integer, intent(out), optional :: error - - INIT_ERROR(error) - call cinoutput_read(cio, this, properties, properties_array, frame, zero, range, str, estr, error=error) - PASS_ERROR(error) - - end subroutine atoms_read_cinoutput - - subroutine atoms_write(this, filename, append, properties, properties_array, prefix, int_format, real_format, estr, error) - !% Write Atoms object to XYZ or NetCDF file. Use filename "stdout" to write to terminal. - use iso_fortran_env - type(Atoms), intent(inout) :: this - character(len=*), intent(in), optional :: filename - logical, optional, intent(in) :: append - character(*), intent(in), optional :: properties - character(*), intent(in), optional :: properties_array(:) - character(*), intent(in), optional :: prefix - character(*), intent(in), optional :: int_format, real_format - type(extendable_str), intent(inout), optional :: estr - integer, intent(out), optional :: error - - type(CInOutput) :: cio - type(MPI_context) :: mpi - - if (trim(filename) == 'stdout') then - if (PRINT_NORMAL > current_verbosity()) return - call initialise(mpi) - if (mpi%active .and. mpi%my_proc /= 0) return - flush(output_unit) - end if - - INIT_ERROR(error) - call initialise(cio, filename, OUTPUT, append, error=error) - PASS_ERROR_WITH_INFO('While writing "' // filename // '".', error) - call write(cio, this, properties, properties_array, prefix, int_format, real_format, estr=estr, error=error) - PASS_ERROR_WITH_INFO('While writing "' // filename // '".', error) - call finalise(cio) - - end subroutine atoms_write - - subroutine atoms_write_cinoutput(this, cio, properties, properties_array, prefix, int_format, real_format, frame, shuffle, deflate, deflate_level, estr, error) - type(Atoms), target, intent(inout) :: this - type(CInOutput), intent(inout) :: cio - character(*), intent(in), optional :: properties - character(*), intent(in), optional :: properties_array(:) - character(*), intent(in), optional :: prefix, int_format, real_format - integer, intent(in), optional :: frame - logical, intent(in), optional :: shuffle, deflate - integer, intent(in), optional :: deflate_level - type(extendable_str), intent(inout), optional :: estr - integer, intent(out), optional :: error - - INIT_ERROR(error) - call cinoutput_write(cio, this, properties, properties_array, prefix, int_format, real_format, frame, shuffle, deflate, deflate_level, estr, error=error) - PASS_ERROR(error) - - end subroutine atoms_write_cinoutput - - function quip_getcwd() - type(extendable_str) :: quip_getcwd - - integer :: i, n - character(len=1), dimension(:), allocatable :: c - - n = quip_getcwd_size_wrapper() - allocate(c(n)) - call quip_getcwd_wrapper(c,n) - - call initialise(quip_getcwd) - quip_getcwd = "" - do i = 1, n - if( c(i) == C_NULL_CHAR ) exit - call concat(quip_getcwd,c(i),no_trim=.true.) - enddo - - deallocate(c) - - endfunction quip_getcwd - - subroutine quip_chdir_char(path) - character(len=*), intent(in) :: path - - call quip_chdir_wrapper(trim(path)//C_NULL_CHAR) - - endsubroutine quip_chdir_char - - subroutine quip_chdir_extendable_str(path) - type(extendable_str), intent(in) :: path - - call quip_chdir_char(string(path)) - endsubroutine quip_chdir_extendable_str - - function quip_basename_char(path) - type(extendable_str) :: quip_basename_char - character(len=*), intent(in) :: path - - integer :: i, n - character(len=1), dimension(:), allocatable :: c - - n = quip_basename_size_wrapper(trim(path)//C_NULL_CHAR) - allocate(c(n)) - call quip_basename_wrapper(trim(path)//C_NULL_CHAR,c,n) - - call initialise(quip_basename_char) - quip_basename_char = "" - do i = 1, n - if( c(i) == C_NULL_CHAR ) exit - call concat(quip_basename_char,c(i),no_trim=.true.) - enddo - - deallocate(c) - - endfunction quip_basename_char - - function quip_basename_extendable_str(path) - type(extendable_str) :: quip_basename_extendable_str - type(extendable_str), intent(in) :: path - - quip_basename_extendable_str = quip_basename_char(string(path)) - endfunction quip_basename_extendable_str - - function quip_dirname_char(path) - type(extendable_str) :: quip_dirname_char - character(len=*), intent(in) :: path - - integer :: i, n - character(len=1), dimension(:), allocatable :: c - - n = quip_dirname_size_wrapper(trim(path)//C_NULL_CHAR) - allocate(c(n)) - call quip_dirname_wrapper(trim(path)//C_NULL_CHAR,c,n) - - call initialise(quip_dirname_char) - quip_dirname_char = "" - do i = 1, n - if( c(i) == C_NULL_CHAR ) exit - call concat(quip_dirname_char,c(i),no_trim=.true.) - enddo - - deallocate(c) - - endfunction quip_dirname_char - - function quip_dirname_extendable_str(path) - type(extendable_str) :: quip_dirname_extendable_str - type(extendable_str), intent(in) :: path - - quip_dirname_extendable_str = quip_dirname(string(path)) - endfunction quip_dirname_extendable_str - - subroutine quip_md5sum(filename,md5sum,stat) - character(len=*), intent(in) :: filename - character(len=32), intent(out) :: md5sum - integer, intent(out), optional :: stat - - integer :: my_stat - character(len=33) :: tmp_md5sum - logical :: l - - my_stat = fmd5sum(trim(filename)//C_NULL_CHAR,tmp_md5sum) - if( my_stat /= 0 ) then - call print_message('WARNING', "quip_md5sum: could not obtain md5 sum of "//trim(filename)) - call print_message('WARNING', "quip_md5sum: fmd5sum returned with code "//my_stat) - md5sum = "" - else - md5sum = tmp_md5sum(1:32) - endif - - if(present(stat)) stat = my_stat - - endsubroutine quip_md5sum - -end module CInOutput_module diff --git a/src/libAtoms/Connection.f95 b/src/libAtoms/Connection.f95 deleted file mode 100644 index 2ec1592851..0000000000 --- a/src/libAtoms/Connection.f95 +++ /dev/null @@ -1,2239 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Connection module -!X -!% A Connection object stores the connectivity information (i.e. -!% list) for a specific Atoms object. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module Connection_module - - use error_module - use system_module - use units_module - use periodictable_module - use linearalgebra_module - use dictionary_module - use table_module - use Atoms_types_module - -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif - implicit none -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif - private - - real(dp), parameter :: CONNECT_LATTICE_TOL = 1e-8_dp - - public :: Connection - - public :: initialise - interface initialise - module procedure connection_initialise - end interface initialise - - public :: finalise - interface finalise - module procedure connection_finalise - end interface finalise - - public :: wipe - interface wipe - module procedure connection_wipe - end interface wipe - - !% Print a verbose textual description of a Connection object to the default - !% logger or to a specificied Inoutput object. - public :: print - interface print - module procedure connection_print - end interface print - - !% Overloaded assigment operators for Connection objects. - public :: assignment(=) - interface assignment(=) - module procedure connection_assignment - end interface assignment(=) - - public :: deepcopy - interface deepcopy - module procedure connection_assignment - endinterface deepcopy - - public :: calc_connect - interface calc_connect - module procedure connection_calc_connect - endinterface - - public :: calc_dists - interface calc_dists - module procedure connection_calc_dists - end interface calc_dists - - public :: calc_connect_hysteretic - interface calc_connect_hysteretic - module procedure connection_calc_connect_hysteretic - endinterface - - public :: n_neighbours - interface n_neighbours - module procedure connection_n_neighbours, connection_n_neighbours_with_dist - end interface - - public :: n_neighbours_total - interface n_neighbours_total - module procedure connection_n_neighbours_total - endinterface - - public :: is_min_image - interface is_min_image - module procedure connection_is_min_image - end interface - - public :: neighbour - interface neighbour - module procedure connection_neighbour, connection_neighbour_minimal - endinterface - - public :: neighbour_index - interface neighbour_index - module procedure connection_neighbour_index - endinterface - - public :: neighbour_minimal - interface neighbour_minimal - module procedure connection_neighbour_minimal - endinterface - - public :: add_bond, remove_bond, remove_bonds, cell_of_pos, connection_cells_initialise - public :: connection_fill, divide_cell, fit_box_in_cell, get_min_max_images - public :: max_cutoff, partition_atoms, cell_n - public :: is_in_subregion - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Connectivity procedures: Initialise and Finalise - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - !% Initialise a Connection object for a given number of atoms 'N'. - !% If the optional Atoms argument is present then we calculate - !% the atomic density to initialise the default lengths of the neighbour - !% list for efficient memory usage. - subroutine connection_initialise(this, N, Nbuffer, pos, lattice, g, origin, extent, nn_guess, store_rij, fill) - type(Connection), intent(inout) :: this - integer, intent(in) :: N ! No. of atoms - integer, intent(in) :: Nbuffer ! Buffer size - real(dp), optional, intent(in) :: pos(:,:), lattice(3,3), g(3,3) - real(dp), optional, intent(in) :: origin(3), extent(3,3) - integer, optional, intent(in) :: nn_guess - logical, optional, intent(in) :: store_rij - logical, optional, intent(in) :: fill - - logical :: do_fill - - do_fill = optional_default(.true., fill) - - ! If already initialised, destroy the existing data and start again - if (this%initialised) call connection_finalise(this) - - if (do_fill) call connection_fill(this, N, Nbuffer, pos, lattice, g, origin, extent, nn_guess, store_rij) - - this%last_connect_cutoff = 0.0_dp - this%last_connect_lattice(:,:) = 0.0_dp - - end subroutine connection_initialise - - subroutine connection_fill(this, N, Nbuffer, pos, lattice, g, origin, extent, nn_guess, store_rij, error) - type(Connection), intent(inout) :: this - integer, intent(in) :: N ! No. of atoms - integer, intent(in) :: Nbuffer ! Buffer size - real(dp), optional, intent(in) :: pos(:,:), lattice(3,3), g(3,3) - real(dp), optional, intent(in) :: origin(3), extent(3,3) - integer, optional, intent(in) :: nn_guess - logical, optional, intent(in) :: store_rij - integer, intent(out), optional :: error - - integer :: i, do_nn_guess - real(dp) :: extent_inv(3,3), subregion_center(3) - logical :: do_subregion, do_store_rij - - INIT_ERROR(error) - do_nn_guess = optional_default(5, nn_guess) - - if (present(origin) .and. present(extent)) then - if (.not.present(lattice) .or. .not.present(g)) then - RAISE_ERROR("connection_fill got origin and extent, so trying to do subregion, but lattice or g are missing", error) - end if - do_subregion = .true. - call matrix3x3_inverse(extent,extent_inv) - subregion_center = origin + 0.5_dp*sum(extent,2) - else - do_subregion = .false. - endif - - if (allocated(this%neighbour1)) then - if (size(this%neighbour1, 1) < Nbuffer) deallocate(this%neighbour1) - endif - if (allocated(this%neighbour2)) then - if (size(this%neighbour2, 1) < Nbuffer) deallocate(this%neighbour2) - endif - - if (.not. allocated(this%neighbour1)) allocate(this%neighbour1(Nbuffer)) - if (.not. allocated(this%neighbour2)) allocate(this%neighbour2(Nbuffer)) - do i=1,Nbuffer - if (do_subregion .and. i <= N) then - if (.not. is_in_subregion(pos(:,i), subregion_center, lattice, g, extent_inv)) then - if (associated(this%neighbour1(i)%t)) then - call connection_remove_atom(this, i, error) - PASS_ERROR(error) - call finalise(this%neighbour1(i)%t) - call finalise(this%neighbour2(i)%t) - deallocate(this%neighbour1(i)%t) - deallocate(this%neighbour2(i)%t) - endif - cycle - endif - endif - if (.not. associated(this%neighbour1(i)%t)) then - allocate(this%neighbour1(i)%t) - do_store_rij = optional_default(.false., store_rij) - if (do_store_rij) then - call allocate(this%neighbour1(i)%t,4,4, 0, 0, max(do_nn_guess, 1)) - else - call allocate(this%neighbour1(i)%t,4,1, 0, 0, max(do_nn_guess, 1)) - endif - this%neighbour1(i)%t%increment = max(do_nn_guess/2, 1) - - allocate(this%neighbour2(i)%t) - call allocate(this%neighbour2(i)%t,2,0, 0, 0, max(do_nn_guess, 1)) - this%neighbour2(i)%t%increment = max(do_nn_guess/2, 1) - endif - end do - - this%initialised = .true. - - end subroutine connection_fill - - function is_in_subregion(p, center, lattice, lattice_inv, extent_inv) - real(dp), intent(in) :: p(3), center(3) - real(dp), intent(in) :: lattice(3,3), lattice_inv(3,3), extent_inv(3,3) - logical :: is_in_subregion - - real(dp) :: relative_p(3), extent_lattice_relative_p(3) - - relative_p = p - center - call map_into_cell(relative_p, lattice, lattice_inv) - - extent_lattice_relative_p = extent_inv .mult. relative_p - - if (any(extent_lattice_relative_p < -0.5_dp) .or. any(extent_lattice_relative_p > 0.5_dp)) then - is_in_subregion = .false. - else - is_in_subregion = .true. - endif - - end function is_in_subregion - - - !% OMIT - subroutine connection_cells_initialise(this,cellsNa,cellsNb,cellsNc,Natoms) - - type(Connection), intent(inout) :: this - integer, intent(in) :: cellsNa,cellsNb,cellsNc ! No. cells in a,b,c directions - integer, optional, intent(in) :: Natoms ! Number of atoms - integer :: i,j,k,av_atoms,stdev_atoms,Ncells - - if (this%cells_initialised) call connection_cells_finalise(this) - - !Set length and increment based on binomial statistics (if possible) - Ncells = cellsNa * cellsNb * cellsNc - if (present(Natoms)) then - av_atoms = Natoms / Ncells - stdev_atoms = int(sqrt(real(Natoms,dp) * (real(Ncells,dp) - 1.0_dp) / (real(Ncells,dp) * real(Ncells,dp)))) - else - av_atoms = 100 !defaults if number of atoms is not given - stdev_atoms = 10 - end if - - allocate(this%cell_heads(cellsNa, cellsNb, cellsNc)) - this%cell_heads = 0 - - this%cellsNa = cellsNa - this%cellsNb = cellsNb - this%cellsNc = cellsNc - - this%cells_initialised = .true. - - end subroutine connection_cells_initialise - - - !% Finalise this connection object - subroutine connection_finalise(this) - - type(Connection), intent(inout) :: this - integer :: i - - !do nothing if not initialised / already finalised - if (.not.this%initialised) return - - if (allocated(this%neighbour1)) then - do i=1,size(this%neighbour1) - if (associated(this%neighbour1(i)%t)) then - call finalise(this%neighbour1(i)%t) - deallocate(this%neighbour1(i)%t) - endif - end do - endif - - if (allocated(this%neighbour2)) then - do i=1,size(this%neighbour2) - if (associated(this%neighbour2(i)%t)) then - call finalise(this%neighbour2(i)%t) - deallocate(this%neighbour2(i)%t) - endif - end do - endif - - - if(allocated(this%neighbour1)) deallocate(this%neighbour1) - if(allocated(this%neighbour2)) deallocate(this%neighbour2) - - if (allocated(this%is_min_image)) deallocate(this%is_min_image) - - if (allocated(this%last_connect_pos)) deallocate(this%last_connect_pos) - - call connection_cells_finalise(this) - - this%initialised = .false. - - end subroutine connection_finalise - - !% Wipe the contents of the connection tables, but keep the allocation - subroutine connection_wipe(this) - - type(Connection), intent(inout) :: this - integer :: i - - !do nothing if not initialised / already finalised - if (.not.this%initialised) return - - do i=1,size(this%neighbour1) - call wipe(this%neighbour1(i)%t) - end do - - do i=1,size(this%neighbour2) - call wipe(this%neighbour2(i)%t) - end do - - call wipe_cells(this) - - end subroutine connection_wipe - - !% OMIT - subroutine connection_cells_finalise(this) - - type(Connection), intent(inout) :: this - integer :: i,j,k - - if (.not.this%cells_initialised) return - - deallocate(this%cell_heads) - if (allocated(this%next_atom_in_cell)) then - deallocate(this%next_atom_in_cell) - endif - - this%cells_initialised = .false. - - end subroutine connection_cells_finalise - - subroutine connection_assignment(to,from) - - type(Connection), intent(inout) :: to - type(Connection), intent(in) :: from - integer :: i,j,k - - call connection_finalise(to) - - if (.not.from%initialised) return - - - call connection_initialise(to,size(from%neighbour1),size(from%neighbour1)) - - - ! Use Append to append the source tables to our (empty) destination tables - do i=1,size(from%neighbour1) - call append(to%neighbour1(i)%t,from%neighbour1(i)%t) - end do - - do i=1,size(from%neighbour2) - call append(to%neighbour2(i)%t,from%neighbour2(i)%t) - end do - - - !If cell data is present then copy that too - if (from%cells_initialised) then - call connection_cells_initialise(to,from%cellsNa,from%cellsNb,from%cellsNc) - to%cell_heads = from%cell_heads - if (allocated(to%next_atom_in_cell) .and. allocated(from%next_atom_in_cell)) then - to%next_atom_in_cell = from%next_atom_in_cell - endif - end if - - end subroutine connection_assignment - - !% OMIT - subroutine wipe_cells(this) - - type(Connection) :: this - integer :: i,j,k - - if (this%cells_initialised) then - this%cell_heads = 0 - end if - - end subroutine wipe_cells - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Connectivity procedures - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Test if atom $i$ is a neighbour of atom $j$ and update 'this%connect' as necessary. - !% Called by 'calc_connect'. The 'shift' vector is added to the position of the $j$ atom - !% to get the correct image position. - subroutine test_form_bond(this, cutoff, use_uniform_cutoff, Z, pos, lattice, i,j, shift, check_for_dup, error) - - type(Connection), intent(inout) :: this - real(dp), intent(in) :: cutoff - logical, intent(in) :: use_uniform_cutoff - integer, intent(in) :: Z(:) - real(dp), intent(in) :: pos(:,:), lattice(3,3) - integer, intent(in) :: i,j - integer, intent(in) :: shift(3) - logical, intent(in) :: check_for_dup - integer, intent(out), optional :: error - - integer :: index, m, k - real(dp) :: d, dd(3) - real(dp) :: use_cutoff - - INIT_ERROR(error) - if (i > j) return - - if (.not. associated(this%neighbour1(i)%t) .or. .not. associated(this%neighbour1(j)%t)) return - -#ifdef DEBUG - if(current_verbosity() >= PRINT_ANALYSIS) then - call print('Entering test_form_bond, i = '//i//' j = '//j, PRINT_ANALYSIS) - call print('use_uniform_cutoff = '//use_uniform_cutoff, PRINT_ANALYSIS) - call print('cutoff = '//cutoff, PRINT_ANALYSIS) - end if -#endif - - !Determine what cutoff distance to use - if (use_uniform_cutoff) then - use_cutoff = cutoff - else - use_cutoff = bond_length(Z(i),Z(j)) * cutoff - end if - - !d = norm(pos(:,j)+(lattice .mult. shift) - pos(:,i)) - !OPTIM - dd = pos(:,j) - pos(:,i) - do m=1,3 - forall(k=1:3) dd(k) = dd(k) + lattice(k,m) * shift(m) - end do - - if (.not. check_for_dup) then - do m=1,3 - if (dd(m) > use_cutoff) return - end do - end if - - d = sqrt(dd(1)*dd(1) + dd(2)*dd(2) + dd(3)*dd(3)) - - if (check_for_dup) then - index = find(this%neighbour1(i)%t, (/ j, shift /)) - if (index /= 0) then ! bond is already in table -#ifdef DEBUG - if (current_verbosity() >= PRINT_ANALYSIS) call print('test_form_bond had check_for_dup=T, found bond already in table', PRINT_ANALYSIS) -#endif - this%neighbour1(i)%t%real(1,index) = d - if (size(this%neighbour1(i)%t%real,1) == 4) then ! store_rij was set - this%neighbour1(i)%t%real(2:4,index) = pos(1:3,j) + (lattice .mult. shift) - pos(1:3,i) - endif - return - endif - endif - -#ifdef DEBUG - if(current_verbosity() >= PRINT_ANALYSIS) call print('d = '//d, PRINT_ANALYSIS) -#endif - - if (d < use_cutoff) then - call add_bond(this, pos, lattice, i, j, shift, d, error=error) - PASS_ERROR(error) - end if - -#ifdef DEBUG - if(current_verbosity() >= PRINT_ANALYSIS) call print('Leaving test_form_bond', PRINT_ANALYSIS) -#endif - - end subroutine test_form_bond - - !% Test if atom $i$ is no longer neighbour of atom $j$ with shift $s$, and update 'this%connect' as necessary. - !% Called by 'calc_connect'. The 'shift' vector is added to the position of the $j$ atom - !% to get the correct image position. - function test_break_bond(this, cutoff_break, use_uniform_cutoff, Z, pos, lattice, i,j, shift, error) - type(Connection), intent(inout) :: this - real(dp), intent(in) :: cutoff_break - logical, intent(in) :: use_uniform_cutoff - integer, intent(in) :: Z(:) - real(dp), intent(in) :: pos(:,:), lattice(3,3) - integer, intent(in) :: i,j - integer, intent(in) :: shift(3) - logical test_break_bond - integer, intent(out), optional :: error - - real(dp) :: d - real(dp) :: cutoff - - INIT_ERROR(error) - test_break_bond = .false. - if (i > j) return - - if (.not. associated(this%neighbour1(i)%t) .or. .not. associated(this%neighbour1(j)%t)) return - -#ifdef DEBUG - if(current_verbosity() >= PRINT_ANALYSIS) then - call print('Entering test_break_bond, i = '//i//' j = '//j, PRINT_ANALYSIS) - call print(" cutoff_break = "// cutoff_break, PRINT_ANALYSIS) - call print(" use_uniform_cutoff ="//use_uniform_cutoff, PRINT_ANALYSIS) - end if -#endif - - !Determine what cutoff distance to use - if (use_uniform_cutoff) then - cutoff = cutoff_break - else - cutoff = bond_length(Z(i),Z(j)) * cutoff_break - end if - - d = norm(pos(:,j)+(lattice .mult. shift) - pos(:,i)) -#ifdef DEBUG - if(current_verbosity() >= PRINT_ANALYSIS) call print('d = '//d//' cutof = '//cutoff//' i = '//i//' j = '//j, PRINT_ANALYSIS) -#endif - if (d > cutoff) then -#ifdef DEBUG - if(current_verbosity() >= PRINT_ANALYSIS) call print('removing bond from tables', PRINT_ANALYSIS) -#endif - call remove_bond(this, i, j, shift, error) - PASS_ERROR(error) - test_break_bond = .true. - end if - -#ifdef DEBUG - if(current_verbosity() >= PRINT_ANALYSIS) call print('Leaving test_break_bond', PRINT_ANALYSIS) -#endif - - end function test_break_bond - - subroutine add_bond(this, pos, lattice, i, j, shift, d, dv, error) - type(Connection), intent(inout) :: this - real(dp), intent(in) :: pos(:,:), lattice(3,3) - integer, intent(in) :: i,j - integer, intent(in) :: shift(3) - real(dp), intent(in) :: d - real(dp), intent(in), optional :: dv(3) - integer, intent(out), optional :: error - - real(dp) :: ddv(3) - integer :: ii, jj, index - - INIT_ERROR(error) - if (.not.this%initialised) then - RAISE_ERROR("add_bond called on uninitialized connection", error) - endif - - if (.not. associated(this%neighbour1(i)%t) .or. .not. associated(this%neighbour1(j)%t)) then - RAISE_ERROR("tried to add_bond for atoms i " // i // " j " // j // " which have associated(neighbour1()%t "//associated(this%neighbour1(i)%t) // " " // associated(this%neighbour1(j)%t) // " one of which is false", error) - endif - - if (i > j) then - ii = j - jj = i - else - ii = i - jj = j - endif - - if (present(dv)) then - ddv = dv*sign(1,j-i) - else ! dv not present - if (size(this%neighbour1(i)%t%real,1) == 4) then - ddv = pos(:,jj) + (lattice .mult. shift) - pos(:,ii) - endif - endif - - ! Add full details to neighbour1 for smaller of i and j - if (size(this%neighbour1(i)%t%real,1) == 4) then ! store_rij was set - call append(this%neighbour1(ii)%t, (/jj, shift /), (/ d, ddv /)) - else - call append(this%neighbour1(ii)%t, (/jj, shift /), (/ d /)) - endif - if(ii .ne. jj) then - index = this%neighbour1(min(ii,jj))%t%N - ! Put a reference to this in neighbour2 for larger of i and j - call append(this%neighbour2(jj)%t, (/ ii, index/)) - end if - - end subroutine add_bond - - - subroutine remove_bond(this, i, j, shift, error) - type(Connection), intent(inout) :: this - integer, intent(in) :: i,j - integer, intent(in), optional :: shift(3) - integer, intent(out), optional :: error - - - integer :: ii, jj, iii, jjj, jjjj, r_index, n_removed, my_shift(3) - - INIT_ERROR(error) - if (.not. associated(this%neighbour1(i)%t) .or. .not. associated(this%neighbour1(j)%t)) then - RAISE_ERROR("tried to remove_bond for atoms i " // i // " j " // j // " which have associated(neighbour1()%t " //associated(this%neighbour1(i)%t) // " " // associated(this%neighbour1(j)%t) // " one of which is false", error) - endif - - if (i > j) then - ii = j - jj = i - if (present(shift)) my_shift = -shift - else - ii = i - jj = j - if (present(shift)) my_shift = shift - endif - ! now ii <= jj - - r_index = 1 - n_removed = 0 - do while (r_index /= 0) - ! remove entry from neighbour1(ii) - if (present(shift)) then - r_index = find(this%neighbour1(ii)%t, (/ jj, my_shift /) ) - else - r_index = find(this%neighbour1(ii)%t, (/ jj, 0, 0, 0 /), (/ .true., .false., .false., .false./) ) - endif - if (r_index == 0) then - if (n_removed == 0) then - if (present(shift)) then - call print("WARNING: remove bond called for i " // i // " j " // j // " shift " // shift // & - " couldn't find a bond to remove", PRINT_ALWAYS) - else - call print("WARNING: remove bond called for i " // i // " j " // j // & - " couldn't find a bond to remove", PRINT_ALWAYS) - endif - endif - else ! r_index /= 0 - n_removed = n_removed + 1 - - call delete(this%neighbour1(ii)%t, r_index, keep_order = .true.) - ! remove entry from neighbour2(jj) - if (ii /= jj) then - call delete(this%neighbour2(jj)%t, (/ ii, r_index /), keep_order = .true.) - endif - ! renumber other neighbour2 entries - do iii=r_index, this%neighbour1(ii)%t%N - ! jjj is another neighbour of ii - jjj = this%neighbour1(ii)%t%int(1,iii) - if (jjj > ii) then - ! jjjj is r_index in jjj's neighbour2 of pointer back to ii's neighbour1 - jjjj = find(this%neighbour2(jjj)%t, (/ ii, iii+1 /) ) - if (jjjj /= 0) then - ! decrement reference in jjj's neighbour2 table - this%neighbour2(jjj)%t%int(:,jjjj) = (/ ii, iii /) - else - RAISE_ERROR("remove_bond: Couldn't find neighbor to fix neighbour2 of", error) - endif - endif - end do - end if ! r_index == 0 - end do ! while r_index /= 0 - - end subroutine remove_bond - - - !% Remove all bonds listed in the Table `bonds` from connectivity - subroutine remove_bonds(this, at, bonds, error) - type(Connection), intent(inout) :: this - type(Atoms), intent(in) :: at - type(Table), intent(in) :: bonds - integer, intent(out), optional :: error - - logical :: bond_exists - integer :: i, j, ji - integer :: shift(3) - - INIT_ERROR(error) - - do i=1,bonds%N - bond_exists = .false. - do ji=1, n_neighbours(this,bonds%int(1,i)) - j = neighbour(this, at, bonds%int(1,i), ji, shift=shift) - if (j == bonds%int(2,i)) then - bond_exists = .true. - exit - endif - end do - if (bond_exists) then - call remove_bond(this, bonds%int(1,i), bonds%int(2,i), shift, error=error) - PASS_ERROR(error) - endif - end do - end subroutine remove_bonds - - - subroutine calc_lat_eff(at, lat_eff, lat_eff_inv, lat_offset) - type(Atoms), intent(in) :: at - real(dp), intent(out) :: lat_eff(3,3), lat_eff_inv(3,3), lat_offset(3) - - integer :: i - real(dp) :: lat_extent - real(dp), allocatable :: lat_pos(:,:) - - lat_eff = at%lattice - lat_offset = 0.0 - if (any(.not. at%is_periodic)) then - allocate(lat_pos(3,at%N)) - lat_pos = at%g .mult. at%pos - do i=1,3 - if (.not. at%is_periodic(i) .and. (minval(lat_pos(i,:)) <= 0.5 .or. maxval(lat_pos(i,:)) >= 0.5)) then - lat_extent = (maxval(lat_pos(i,:)) - minval(lat_pos(i,:))) * 1.1 - lat_eff(:,i) = lat_eff(:,i)/norm(lat_eff(:,i)) * lat_extent - lat_offset(i) = minval(lat_pos(i,:)) - 0.05 - endif - end do - deallocate(lat_pos) - endif - call matrix3x3_inverse(lat_eff,lat_eff_inv) - end subroutine - - - !% As for 'calc_connect', but perform the connectivity update - !% hystertically: atoms must come within 'cutoff' to be considered - !% neighbours, and then will remain connect until them move apart - !% further than 'cutoff_break'. - subroutine connection_calc_connect_hysteretic(this, at, cutoff_factor, cutoff_break_factor, & - origin, extent, own_neighbour, store_is_min_image, store_n_neighb, error) - type(Connection), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: cutoff_factor, cutoff_break_factor - real(dp), optional :: origin(3), extent(3,3) - logical, optional, intent(in) :: own_neighbour, store_is_min_image, store_n_neighb - integer, intent(out), optional :: error - - integer :: cellsNa,cellsNb,cellsNc - integer :: i,j,k,i2,j2,k2,i3,j3,k3,i4,j4,k4,atom1,atom2 -! integer :: n1, n2 - integer :: cell_image_Na, cell_image_Nb, cell_image_Nc - integer :: min_cell_image_Na - integer :: max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb - integer :: min_cell_image_Nc, max_cell_image_Nc - real(dp) :: cutoff ! absolute cutoffs - integer :: ji, s_ij(3), nn_guess - logical my_own_neighbour, my_store_is_min_image, my_store_n_neighb - logical :: change_i, change_j, change_k, broken - integer, pointer :: map_shift(:,:), n_neighb(:) - real(dp) :: lat_eff(3,3), lat_eff_inv(3,3), lat_offset(3) - - INIT_ERROR(error) - - this%N = at%N - - my_own_neighbour = optional_default(.false., own_neighbour) - my_store_is_min_image = optional_default(.true., store_is_min_image) - my_store_n_neighb = optional_default(.true., store_n_neighb) - - !Find the maximum covalent radius of all the atoms in the structure, double it - !and multiple by cutoff. At makes sure we can deal with the worst case scenario of big atom - !bonded to big atom - cutoff = 0.0_dp - do i = 1, at%N - if (ElementCovRad(at%Z(i)) > cutoff) cutoff = ElementCovRad(at%Z(i)) - end do - cutoff = (2.0_dp * cutoff) * cutoff_factor - - call print("calc_connect_hysteretic: cutoff_factor " // cutoff_factor, PRINT_NERD) - call print("calc_connect_hysteretic: cutoff_break_factor " // cutoff_break_factor, PRINT_NERD) - call print("calc_connect_hysteretic: cutoff " // cutoff, PRINT_NERD) - - if (present(origin) .and. present(extent)) then - cellsNa = 1 - cellsNb = 1 - cellsNc = 1 - else - call calc_lat_eff(at, lat_eff, lat_eff_inv, lat_offset) - call divide_cell(lat_eff, cutoff, cellsNa, cellsNb, cellsNc) - endif - - call print("calc_connect: cells_N[abc] " // cellsNa // " " // cellsNb // " " // cellsNc, PRINT_NERD) - - ! If the lattice has changed, then the cells need de/reallocating - if (this%cells_initialised) then - if ((cellsNa /= this%cellsNa) .or. & - (cellsNb /= this%cellsNb) .or. & - (cellsNc /= this%cellsNc)) call connection_cells_finalise(this) - end if - - ! figure out how many unit cell images we will need to loop over in each direction - call fit_box_in_cell(cutoff, cutoff, cutoff, at%lattice, cell_image_Na, cell_image_Nb, cell_image_Nc) - ! cell_image_N{a,b,c} apply to a box of side 2*cutoff. Since we loop from -cell_image_N to - ! +cell_image_N we can reduce them as follows - - cell_image_Na = max(1,(cell_image_Na+1)/2) - cell_image_Nb = max(1,(cell_image_Nb+1)/2) - cell_image_Nc = max(1,(cell_image_Nc+1)/2) - - ! Estimate number of neighbours of each atom. Factor of 1/2 assumes - ! half will go in neighbour1, half in neighbour2. - nn_guess = int(0.5_dp*4.0_dp/3.0_dp*PI*cutoff**3*at%N/cell_volume(at%lattice)*cell_image_Na*cell_image_Nb*cell_image_Nc) - - call print('calc_connect: image cells '//cell_image_Na//'x'//cell_image_Nb//'x'//cell_image_Nc, PRINT_NERD) - - ! Allocate space for the connection object if needed - if (present(origin) .and. present(extent)) then - if (.not.this%initialised) then - call connection_initialise(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, origin, extent, nn_guess) - else - call connection_fill(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, origin, extent, nn_guess) - end if - else - if (.not.this%initialised) then - call connection_initialise(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, nn_guess=nn_guess) - else - call connection_fill(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, nn_guess=nn_guess) - end if - endif - - if (.not.this%cells_initialised) then - call connection_cells_initialise(this, cellsNa, cellsNb, cellsNc,at%N) - endif - - ! Partition the atoms into cells - call partition_atoms(this, at, lat_eff_inv, lat_offset, error=error) - PASS_ERROR(error) - if (.not. assign_pointer(at, 'map_shift', map_shift)) then - RAISE_ERROR("calc_connect impossibly failed to assign map_shift pointer", error) - end if - - ! look for bonds that have been broken, and remove them - do i=1, at%N - ji = 1 - do - if (ji > n_neighbours(this, i)) exit - j = connection_neighbour(this, at, i, ji, shift = s_ij) - broken = test_break_bond(this, cutoff_break_factor, .false., & - at%Z, at%pos, at%lattice, i, j, s_ij, error) - PASS_ERROR(error) - if (.not. broken) then - ji = ji + 1 ! we didn't break at bond, so go to next one - ! if we did break a bond, ji now points to a different bond, so don't increment it - endif - end do - end do - - ! Here is the main loop: - ! Go through each cell and update the connectivity between atoms in at cell and neighbouring cells - ! N.B. test_form_bond updates both atoms i and j, so only update if i <= j to avoid doubling processing - - ! defaults for cellsNx = 1 - k3 = 1; k4 = 1; j3 = 1; j4 = 1; i3 = 1; i4 = 1 - ! Loop over all cells - do k = 1, cellsNc - change_k = .true. - do j = 1, cellsNb - change_j = .true. - do i = 1, cellsNa - change_i = .true. - call get_min_max_images(at%is_periodic, cellsNa, cellsNb, cellsNc, & - cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k, change_i, change_j, change_k, & - min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc) - change_i = .false. - change_j = .false. - change_k = .false. - - !Loop over atoms in cell(i,j,k) - atom1 = this%cell_heads(i, j, k) - atom1_loop: do while (atom1 > 0) - - ! Loop over neighbouring cells, applying PBC - do k2 = -cell_image_Nc, +cell_image_Nc - - ! the stored cell we are in - if(cellsNc > 1) k3 = mod(k+k2-1+cellsNc,cellsNc)+1 - - ! the shift we need to get to the cell image - k4 = (k+k2-k3)/cellsNc - - do j2 = -cell_image_Nb, +cell_image_Nb - ! the stored cell we are in - if(cellsNb > 1) j3 = mod(j+j2-1+cellsNb,cellsNb)+1 - - ! the shift we need to get to the cell image - j4 = (j+j2-j3)/cellsNb - - do i2 = -cell_image_Na, +cell_image_Na - ! the stored cell we are in - if(cellsNa > 1) i3 = mod(i+i2-1+cellsNa,cellsNa)+1 - - ! the shift we need to get to the cell image - i4 = (i+i2-i3)/cellsNa - - ! The cell we are currently testing atom1 against is cell(i3,j3,k3) - ! with shift (i4,j4,k4) - ! loop over it's atoms and test connectivity if atom1 < atom2 - - atom2 = this%cell_heads(i3,j3,k3) - atom2_loop: do while (atom2 > 0) - - ! omit atom2 < atom1 - if (atom1 > atom2) then - atom2 = this%next_atom_in_cell(atom2) - cycle atom2_loop - endif - ! omit self in the same cell without shift - if (.not. my_own_neighbour .and. (atom1 == atom2 .and. & - (i4==0 .and. j4==0 .and. k4==0) .and. & - (i==i3 .and. j==j3 .and. k==k3))) then - atom2 = this%next_atom_in_cell(atom2) - cycle atom2_loop - endif - - call test_form_bond(this, cutoff_factor, .false., & - at%Z, at%pos, at%lattice, atom1,atom2, & - (/i4-map_shift(1,atom1)+map_shift(1,atom2),j4-map_shift(2,atom1)+map_shift(2,atom2),k4-map_shift(3,atom1)+map_shift(3,atom2)/), & - .true., error) - PASS_ERROR(error) - - atom2 = this%next_atom_in_cell(atom2) - end do atom2_loop ! atom2 - - end do ! i2 - end do ! j2 - end do ! k2 - - atom1 = this%next_atom_in_cell(atom1) - end do atom1_loop ! atom1 - - end do ! i - end do ! j - end do ! k - - if (my_store_is_min_image) then - if (allocated(this%is_min_image)) deallocate(this%is_min_image) - allocate(this%is_min_image(at%n)) - do i=1,at%n - if (associated(this%neighbour1(i)%t)) then - this%is_min_image(i) = is_min_image(this, i) - else - this%is_min_image(i) = .false. - end if - end do - end if - - if (my_store_n_neighb) then - call add_property(at, 'n_neighb', 0, ptr=n_neighb, overwrite=.true.) - do i=1,at%n - n_neighb(i) = n_neighbours(this, i) - end do - end if - - - end subroutine connection_calc_connect_hysteretic - - subroutine connection_remove_atom(this, i, error) - type(Connection), intent(inout) :: this - integer, intent(in) :: i - integer, intent(out), optional :: error - - integer :: ji, j, jj, s_ij(3), n_entries - - INIT_ERROR(error) - n_entries=this%neighbour1(i)%t%N - do ji=n_entries, 1, -1 - j = this%neighbour1(i)%t%int(1,ji) - s_ij = this%neighbour1(i)%t%int(2:4,ji) - call remove_bond(this, i, j, s_ij, error) - PASS_ERROR(error) - end do - - n_entries=this%neighbour2(i)%t%N - do ji=n_entries, 1, -1 - j = this%neighbour2(i)%t%int(1,ji) - jj = this%neighbour2(i)%t%int(2,ji) - s_ij = this%neighbour1(j)%t%int(2:4,jj) - call remove_bond(this, j, i, s_ij, error) - PASS_ERROR(error) - end do - - end subroutine connection_remove_atom - - - !% Fast $O(N)$ connectivity calculation routine. It divides the unit - !% cell into similarly shaped subcells, of sufficient size that - !% sphere of radius 'cutoff' is contained in a subcell, at least in - !% the directions in which the unit cell is big enough. For very - !% small unit cells, there is only one subcell, so the routine is - !% equivalent to the standard $O(N^2)$ method. If 'cutoff_skin' is - !% present, effective cutoff is increased by this amount, and full - !% recalculation of connectivity is only done when any atom has - !% moved more than 0.5*cutoff_skin. - subroutine connection_calc_connect(this, at, own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb, cutoff_skin, max_pos_change, did_rebuild, error) - type(Connection), intent(inout) :: this - type(Atoms), intent(inout) :: at - logical, optional, intent(in) :: own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb - real(dp), intent(in), optional :: cutoff_skin - real(dp), intent(out), optional :: max_pos_change - logical, intent(out), optional :: did_rebuild - integer, intent(out), optional :: error - - integer :: cellsNa,cellsNb,cellsNc - integer :: i,j,k,i2,j2,k2,i3,j3,k3,i4,j4,k4,atom1,atom2 -! integer :: n1,n2 - integer :: cell_image_Na, cell_image_Nb, cell_image_Nc, nn_guess, n_occ - integer :: min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb - integer :: max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc - real(dp) :: cutoff, density, volume_per_cell, pos_change, my_max_pos_change - logical my_own_neighbour, my_store_is_min_image, my_skip_zero_zero_bonds, my_store_n_neighb, do_fill - logical :: change_i, change_j, change_k - integer, pointer :: map_shift(:,:), n_neighb(:) - real(dp) :: lat_eff(3,3), lat_eff_inv(3,3), lat_offset(3) - real(dp), allocatable :: lat_pos(:,:) - - - INIT_ERROR(error) - - call system_timer('calc_connect') - - this%N = at%N - - my_own_neighbour = optional_default(.false., own_neighbour) - my_store_is_min_image = optional_default(.true., store_is_min_image) - my_skip_zero_zero_bonds = optional_default(.false., skip_zero_zero_bonds) - my_store_n_neighb = optional_default(.true., store_n_neighb) - - if (at%cutoff < 0.0_dp) then - RAISE_ERROR('calc_connect: Negative cutoff radius ' // at%cutoff, error) - end if - - ! The default is -1.0, so catch the unset-cutoff case explicitly - if ((at%cutoff .feq. -1.0_dp)) then - RAISE_ERROR('calc_connect: at%cutoff==-1.0. Call set_cutoff() first!', error) - endif - - ! The value 0.0 means "don't compute neighbours" - should this still output a message? - if ((at%cutoff .feq. 0.0_dp)) then - return - endif - - !Calculate the cutoff value we should use in dividing up the simulation cell - cutoff = at%cutoff - if (present(cutoff_skin)) then - if (cutoff_skin .fne. 0.0_dp) then - call print('calc_connect: increasing cutoff from '//cutoff//' by cutoff_skin='//cutoff_skin ,PRINT_NERD) - cutoff = cutoff + cutoff_skin - - if (.not. allocated(this%last_connect_pos) .or. & - (cutoff > this%last_connect_cutoff) .or. & - (size(this%last_connect_pos, 2) /= at%n) .or. & - (at%lattice .fne. this%last_connect_lattice)) then - call print('calc_connect: forcing a rebuild: either first time, atom number mismatch or lattice mismatch', PRINT_NERD) - call print('calc_connect: maxval(abs(at%lattice - this%last_connect_lattice)) = '//(maxval(abs(at%lattice - this%last_connect_lattice))), PRINT_NERD) - if (allocated(this%last_connect_pos)) deallocate(this%last_connect_pos) - allocate(this%last_connect_pos(3, at%n)) - my_max_pos_change = huge(1.0_dp) - else - ! FIXME 1. we should also take into account changes in lattice here - for - ! now we force a reconnect whenever lattice changes. - ! 2. it may be possible to further speed up calculation of delta_pos by - ! not calling distance_min_image() every time - my_max_pos_change = 0.0_dp - do i=1, at%N - pos_change = distance_min_image(at, i, this%last_connect_pos(:, i)) - if (pos_change > my_max_pos_change) my_max_pos_change = pos_change - end do - end if - - if (present(max_pos_change)) max_pos_change = my_max_pos_change - - if (my_max_pos_change < 0.5_dp*cutoff_skin) then - call print('calc_connect: max pos change '//my_max_pos_change//' < 0.5*cutoff_skin, doing a calc_dists() only', PRINT_NERD) - call calc_dists(this, at) - call system_timer('calc_connect') - if (present(did_rebuild)) did_rebuild = .false. - return - end if - - ! We need to do a full recalculation of connectivity. Store the current pos and lattice. - call print('calc_connect: max pos change '//my_max_pos_change//' >= 0.5*cutoff_skin, doing a full rebuild', PRINT_NERD) - if (present(did_rebuild)) did_rebuild = .true. - this%last_connect_pos(:,:) = at%pos - this%last_connect_lattice(:,:) = at%lattice - this%last_connect_cutoff = cutoff - end if - end if - - call print("calc_connect: cutoff calc_connect " // cutoff, PRINT_NERD) - - call calc_lat_eff(at, lat_eff, lat_eff_inv, lat_offset) - call divide_cell(lat_eff, cutoff, cellsNa, cellsNb, cellsNc) - - call print("calc_connect: cells_N[abc] " // cellsNa // " " // cellsNb // " " // cellsNc, PRINT_NERD) - - ! If the lattice has changed, then the cells need de/reallocating - if (this%cells_initialised) then - if ((cellsNa /= this%cellsNa) .or. & - (cellsNb /= this%cellsNb) .or. & - (cellsNc /= this%cellsNc)) call connection_finalise(this) - end if - - ! figure out how many unit cell images we will need to loop over in each direction - call fit_box_in_cell(cutoff, cutoff, cutoff, at%lattice, cell_image_Na, cell_image_Nb, cell_image_Nc) - ! cell_image_N{a,b,c} apply to a box of side 2*cutoff. Since we loop from -cell_image_N to - ! +cell_image_N we can reduce them as follows - - cell_image_Na = max(1,(cell_image_Na+1)/2) - cell_image_Nb = max(1,(cell_image_Nb+1)/2) - cell_image_Nc = max(1,(cell_image_Nc+1)/2) - - call print('calc_connect: image cells '//cell_image_Na//'x'//cell_image_Nb//'x'//cell_image_Nc, PRINT_NERD) - - ! Allocate space for the connection object if needed - if (.not.this%initialised) then - call connection_initialise(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, fill=.false.) - do_fill = .true. - else - ! otherwise just wipe the connection table - call wipe(this) - do_fill = .false. - end if - - if (.not.this%cells_initialised) & - call connection_cells_initialise(this, cellsNa, cellsNb, cellsNc,at%N) - - ! Partition the atoms into cells - call partition_atoms(this, at, lat_eff_inv, lat_offset, error=error) - PASS_ERROR(error) - if (.not. assign_pointer(at, 'map_shift', map_shift)) then - RAISE_ERROR("calc_connect impossibly failed to assign map_shift pointer", error) - end if - - if (do_fill) then - volume_per_cell = cell_volume(at%lattice)/real(cellsNa*cellsNb*cellsNc,dp) - - ! Count the occupied cells so vacuum does not contribute to average number density - n_occ = 0 - do k=1,cellsNc - do j=1,cellsNb - do i=1,cellsNa - if (this%cell_heads(i, j, k) > 0) & - n_occ = n_occ + 1 - end do - end do - end do - density = at%n/(n_occ*volume_per_cell) - - ! Sphere of radius "cutoff", assume roughly half neighbours in neighbour1 and half in neighbour2 - nn_guess = int(4.0_dp/3.0_dp*PI*cutoff**3*density)/2 - - call print('calc_connect: occupied cells '//n_occ//'/'//(cellsNa*cellsNb*cellsNc)//' = '//(n_occ/real(cellsNa*cellsNb*cellsNc,dp)), PRINT_NERD) - call print('calc_connect: estimated number of neighbours per atom = '//nn_guess, PRINT_NERD) - - call connection_fill(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, nn_guess=nn_guess) - end if - - ! Here is the main loop: - ! Go through each cell and update the connectivity between atoms in at cell and neighbouring cells - ! N.B. test_form_bond updates both atoms i and j, so only update if i <= j to avoid doubling processing - - ! defaults for cellsNx = 1 - k3 = 1; k4 = 1; j3 = 1; j4 = 1; i3 = 1; i4 = 1 - - ! loop over all cells i,j,k, and all atoms in each cell n1 - do k = 1, cellsNc - change_k = .true. - do j = 1, cellsNb - change_j = .true. - do i = 1, cellsNa - change_i = .true. - call get_min_max_images(at%is_periodic, cellsNa, cellsNb, cellsNc, & - cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k, change_i, change_j, change_k, & - min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc) - change_i = .false. - change_j = .false. - change_k = .false. - atom1 = this%cell_heads(i, j, k) - atom1_loop: do while (atom1 > 0) - - ! Loop over neighbouring cells, applying PBC - - do k2 = min_cell_image_Nc, max_cell_image_Nc - - ! the stored cell we are in - if(cellsNc > 1) k3 = mod(k+k2-1+cellsNc,cellsNc)+1 - - ! the shift we need to get to the cell image - k4 = (k+k2-k3)/cellsNc - - do j2 = min_cell_image_Nb, max_cell_image_Nb - ! the stored cell we are in - if(cellsNb > 1) j3 = mod(j+j2-1+cellsNb,cellsNb)+1 - - ! the shift we need to get to the cell image - j4 = (j+j2-j3)/cellsNb - - do i2 = min_cell_image_Na, max_cell_image_Na - ! the stored cell we are in - if(cellsNa > 1) i3 = mod(i+i2-1+cellsNa,cellsNa)+1 - - ! the shift we need to get to the cell image - i4 = (i+i2-i3)/cellsNa - - ! The cell we are currently testing atom1 against is cell(i3,j3,k3) - ! with shift (i4,j4,k4) - ! loop over it's atoms and test connectivity if atom1 < atom2 - - atom2 = this%cell_heads(i3, j3, k3) - atom2_loop: do while (atom2 > 0) - - ! omit atom2 < atom1 - if (atom1 > atom2) then - atom2 = this%next_atom_in_cell(atom2) - cycle atom2_loop - endif - - if (my_skip_zero_zero_bonds .and. & - at%z(atom1) == 0 .and. at%z(atom2) == 0) then - atom2 = this%next_atom_in_cell(atom2) - cycle atom2_loop - endif - - ! omit self in the same cell without shift - if (.not. my_own_neighbour .and. & - (atom1 == atom2 .and. & - (i4==0 .and. j4==0 .and. k4==0) .and. & - (i==i3 .and. j==j3 .and. k==k3))) then - atom2 = this%next_atom_in_cell(atom2) - cycle atom2_loop - endif - call test_form_bond(this, cutoff, .true., & - at%Z, at%pos, at%lattice, atom1,atom2, & - (/i4-map_shift(1,atom1)+map_shift(1,atom2),j4-map_shift(2,atom1)+map_shift(2,atom2),k4-map_shift(3,atom1)+map_shift(3,atom2)/), & - .false., error) - PASS_ERROR(error) - - atom2 = this%next_atom_in_cell(atom2) - end do atom2_loop ! atom2 - - end do ! i2 - end do ! j2 - end do ! k2 - - atom1 = this%next_atom_in_cell(atom1) - end do atom1_loop ! atom1 - end do ! i - end do ! j - end do ! k - - if (my_store_is_min_image) then - if (allocated(this%is_min_image)) deallocate(this%is_min_image) - allocate(this%is_min_image(at%n)) - do i=1,at%n - this%is_min_image(i) = is_min_image(this, i, error=error) - PASS_ERROR(error) - end do - end if - - if (my_store_n_neighb) then - call add_property(at, 'n_neighb', 0, ptr=n_neighb, overwrite=.true.) - do i=1,at%n - n_neighb(i) = n_neighbours(this, i) - end do - end if - - call system_timer('calc_connect') - - end subroutine connection_calc_connect - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% The subroutine 'calc_dists' updates the stored distance tables using - !% the stored connectivity and shifts. This should be called every time - !% any atoms are moved (e.g. it is called by 'DynamicalSystem%advance_verlet'). - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine connection_calc_dists(this, at, parallel, error) - type(Connection), intent(inout) :: this - type(Atoms), intent(inout) :: at - logical, optional, intent(in) :: parallel - integer, optional, intent(out) :: error - integer :: i, j, n, index - real(dp) :: r_ij - integer, dimension(3) :: shift - real(dp), dimension(3) :: j_pos - logical :: do_parallel - - real(dp), parameter :: small_number = 1.0e-10_dp -#ifdef _MPI - integer:: Nelements, mpi_pos, mpi_old_pos - real(dp), allocatable :: mpi_send(:), mpi_recv(:) - integer err -#endif - INIT_ERROR(error) - - call system_timer('calc_dists') - - ! Flag to specify whether or not to parallelise calculation. - ! Only actually run in parallel if parallel==.true. AND - ! _MPI is #defined. Default to serial mode. - do_parallel = .false. - if (present(parallel)) do_parallel = parallel - -#ifdef _MPI - if (do_parallel) then - ! Nelements = sum(this%connect%neighbour1(i)%t%N) - Nelements = 0 - do i=1,at%N - Nelements = Nelements + this%neighbour1(i)%t%N - end do - - allocate(mpi_send(Nelements)) - allocate(mpi_recv(Nelements)) - if (Nelements > 0) then - mpi_send = 0.0_dp - mpi_recv = 0.0_dp - end if - mpi_pos = 1 - end if -#endif - - if (.not.this%initialised) then - RAISE_ERROR('CalcDists: Connect is not yet initialised', error) - endif - - if (at%N > 0) then - if (size(this%neighbour1(1)%t%real,1) == 4) then ! store_rij was set - RAISE_ERROR("CalcDists: can't have store_rij set", error) - endif - endif - - do i = 1, at%N - -#ifdef _MPI - if (do_parallel) then - mpi_old_pos = mpi_pos - mpi_pos = mpi_pos + this%neighbour1(i)%t%N - - ! cycle loop if processor rank does not match - if(mod(i, mpi_n_procs()) .ne. mpi_id()) cycle - end if -#endif - - do n = 1, connection_n_neighbours(this, i) - - j = connection_neighbour_minimal(this, i, n, shift=shift, index=index) - - ! j_pos = at%pos(:,j) + ( at%lattice .mult. shift ) - j_pos(:) = at%pos(:,j) + ( at%lattice(:,1) * shift(1) + at%lattice(:,2) * shift(2) + at%lattice(:,3) * shift(3) ) - - r_ij = norm(j_pos - at%pos(:,i)) - if( r_ij < small_number ) then - RAISE_ERROR("connection_calc_dists: atoms "//i//" and "//j//" overlap exactly.",error) - endif - - if (i <= j) then - this%neighbour1(i)%t%real(1,index) = r_ij - else - this%neighbour1(j)%t%real(1,index) = r_ij - end if - - end do - -#ifdef _MPI - if (do_parallel) then - if (mpi_old_pos <= mpi_pos-1) then - mpi_send(mpi_old_pos:mpi_pos-1) = & - this%neighbour1(i)%t%real(1,1:this%neighbour1(i)%t%N) - end if - end if -#endif - - end do - -#ifdef _MPI - if (do_parallel) then - ! collect mpi results - if (Nelements > 0) then - call mpi_allreduce(mpi_send, mpi_recv, & - size(mpi_send), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, err) - call abort_on_mpi_error(err, "Calc_Dists: MPI_ALL_REDUCE()") - end if - - mpi_pos = 1 - do i=1, at%N - if (this%neighbour1(i)%t%N > 0) then - this%neighbour1(i)%t%real(1,1:this%neighbour1(i)%t%N) = & - mpi_recv(mpi_pos:mpi_pos+this%neighbour1(i)%t%N-1) - mpi_pos = mpi_pos + this%neighbour1(i)%t%N - endif - end do - - if (Nelements > 0) then - deallocate(mpi_send, mpi_recv) - end if - end if -#endif - - call system_timer('calc_dists') - - end subroutine connection_calc_dists - - - subroutine get_min_max_images(is_periodic, cellsNa, cellsNb, cellsNc, cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k, do_i, do_j, do_k, & - min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc) - logical, intent(in) :: is_periodic(3) - integer, intent(in) :: cellsNa, cellsNb, cellsNc, cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k - logical, intent(in) :: do_i, do_j, do_k - integer, intent(out) :: min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc - - if (do_i) then - if (is_periodic(1)) then - min_cell_image_Na = -cell_image_Na - max_cell_image_Na = cell_image_Na - else - if (cell_image_Na < i) then - min_cell_image_Na = -cell_image_Na - else - min_cell_image_Na = -i+1 - endif - if (cell_image_Na < cellsNa-i) then - max_cell_image_Na = cell_image_Na - else - max_cell_image_Na = cellsNa - i - endif - endif - endif - if (do_j) then - if (is_periodic(2)) then - min_cell_image_Nb = -cell_image_Nb - max_cell_image_Nb = cell_image_Nb - else - if (cell_image_Nb < j) then - min_cell_image_Nb = -cell_image_Nb - else - min_cell_image_Nb = -j+1 - endif - if (cell_image_Nb < cellsNb-j) then - max_cell_image_Nb = cell_image_Nb - else - max_cell_image_Nb = cellsNb - j - endif - endif - endif - if (do_k) then - if (is_periodic(3)) then - min_cell_image_Nc = -cell_image_Nc - max_cell_image_Nc = cell_image_Nc - else - if (cell_image_Nc < k) then - min_cell_image_Nc = -cell_image_Nc - else - min_cell_image_Nc = -k+1 - endif - if (cell_image_Nc < cellsNc-k) then - max_cell_image_Nc = cell_image_Nc - else - max_cell_image_Nc = cellsNc - k - endif - endif - endif - - if (current_verbosity() >= PRINT_ANALYSIS) then - call print('get_min_max_images cell_image_Na min='//min_cell_image_Na//' max='//max_cell_image_Na, PRINT_ANALYSIS) - call print('get_min_max_images cell_image_Nb min='//min_cell_image_Nb//' max='//max_cell_image_Nb, PRINT_ANALYSIS) - call print('get_min_max_images cell_image_Nc min='//min_cell_image_Nc//' max='//max_cell_image_Nc, PRINT_ANALYSIS) - end if - - end subroutine get_min_max_images - - ! - !% Spatially partition the atoms into cells. The number of cells in each dimension must already be - !% set (cellsNa,b,c). Pre-wiping of the cells can be skipped (e.g. if they are already empty). - ! - subroutine partition_atoms(this, at, lat_eff_inv, lat_offset, dont_wipe, error) - - type(Connection), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: lat_eff_inv(3,3), lat_offset(3) - logical, optional, intent(in) :: dont_wipe - integer, intent(out), optional :: error - - logical :: my_dont_wipe, neighbour1_allocated - integer :: i,j,k,n - real(dp) :: lat_pos(3) - integer, pointer :: map_shift(:,:) - - INIT_ERROR(error) - ! Check inputs - if (.not.this%cells_initialised) then - RAISE_ERROR('Partition_Atoms: Cells have not been initialised', error) - end if - my_dont_wipe = .false. - if (present(dont_wipe)) my_dont_wipe = dont_wipe - - ! Wipe the cells - if (.not.my_dont_wipe) then - call wipe_cells(this) - else - RAISE_ERROR("Partition_Atoms: dont_wipe=.true. not supported", error) - endif - -!! ! Make sure all atomic positions are within the cell -!! call map_into_cell(at) - if (.not. assign_pointer(at, 'map_shift', map_shift)) then - call add_property(at, 'map_shift', 0, 3) - if (.not. assign_pointer(at, 'map_shift', map_shift)) then - RAISE_ERROR("partition_atoms impossibly failed to assign map_shift pointer", error) - end if - endif - - neighbour1_allocated = allocated(this%neighbour1) - - if (allocated(this%next_atom_in_cell)) then - if (size(this%next_atom_in_cell) < this%N) then - deallocate(this%next_atom_in_cell) - endif - endif - if (.not. allocated(this%next_atom_in_cell) .and. this%N > 0) then - allocate(this%next_atom_in_cell(this%N)) - endif - - do n = 1, at%N - if (neighbour1_allocated) then - if (.not. associated(this%neighbour1(n)%t)) cycle ! not in active subregion - end if - - ! figure out shift to map atom into cell - lat_pos = (lat_eff_inv .mult. at%pos(:,n)) - lat_offset - map_shift(:,n) = - floor(lat_pos+0.5_dp) - where (.not. at%is_periodic) - map_shift(:,n) = 0.0 - end where - ! do the mapping - lat_pos = lat_pos + map_shift(:,n) - - call cell_of_pos(this, lat_pos, i, j, k) - !Add the atom to this cell - this%next_atom_in_cell(n) = this%cell_heads(i, j, k) - this%cell_heads(i, j, k) = n - end do - - end subroutine partition_atoms - - subroutine cell_of_pos(this, lat_pos, i, j, k) - type(Connection), intent(in) :: this - real(dp), intent(in) :: lat_pos(3) - integer, intent(out) :: i, j, k - - real(dp) :: t(3) - - t = lat_pos - i = floor(real(this%cellsNa,dp) * (t(1)+0.5_dp)) + 1 - j = floor(real(this%cellsNb,dp) * (t(2)+0.5_dp)) + 1 - k = floor(real(this%cellsNc,dp) * (t(3)+0.5_dp)) + 1 - - ! Very small numerical errors in the lattice inverse can lead to bad i,j,k values. - ! Test for this: - if (i < 1) then - i = 1 - else if (i > this%cellsNa) then - i = this%cellsNa - end if - - if (j < 1) then - j = 1 - else if (j > this%cellsNb) then - j = this%cellsNb - end if - - if (k < 1) then - k = 1 - else if (k > this%cellsNc) then - k = this%cellsNc - end if - - end subroutine cell_of_pos - - - function cell_n(this, i, j, k, error) - type(Connection), intent(in) :: this - integer, intent(in) :: i, j, k - integer :: cell_n - integer :: a - integer, intent(out), optional :: error - - INIT_ERROR(error) - if (.not. this%cells_initialised) then - RAISE_ERROR('cell_n: cells are not initialised', error) - end if - - cell_n = 0 - a = this%cell_heads(i, j, k) - do while (a > 0) - cell_n = cell_n + 1 - a = this%next_atom_in_cell(a) - enddo - - end function cell_n - -! Don't understand what this is doing, and doesn't seem to be used -! anywhere - Lars -! function cell_contents(this, i, j, k, n, error) -! type(Connection), intent(in) :: this -! integer, intent(in) :: i, j, k, n -! integer :: cell_contents -! integer, intent(out), optional :: error -! -! INIT_ERROR(error) -! if (.not. this%cells_initialised) then -! RAISE_ERROR('cell_n: cells are not initialised', error) -! end if -! -! cell_contents = this%cell(i,j,k)%int(1,n) -! -! end function cell_contents - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Geometry procedures - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - !% Given a simulation cell defined by lattice vectors, how many - !% times can the cell be divided along the lattice vectors into - !% subcells such that a sphere of radius 'cutoff' with centre in - !% one subcell does not spill out of the surrounding $3 \times 3$ subcell block? - ! - subroutine divide_cell(lattice,cutoff,Na,Nb,Nc) - - real(dp), dimension(3,3), intent(in) :: lattice !% Box defined by lattice vectors - real(dp), intent(in) :: cutoff !% Radius of sphere - integer, intent(out) :: Na,Nb,Nc !% Number of supercells required along $x$, $y$ and $z$ - real(dp) :: cellVol - real(dp), dimension(3) :: a, b, c - - a = lattice(:,1); b = lattice(:,2); c = lattice(:,3) - cellVol = abs( scalar_triple_product(a,b,c) ) - - Na = max(1,int( cellVol / (cutoff * norm(b .cross. c) ) )) ! round down to nearest int >= 1 - Nb = max(1,int( cellVol / (cutoff * norm(c .cross. a) ) )) - Nc = max(1,int( cellVol / (cutoff * norm(a .cross. b) ) )) - - call print('divide_cell: '//Na//'x'//Nb//'x'//Nc//' cells.', PRINT_NERD) - - end subroutine divide_cell - - ! - !% Returns the maximum cutoff radius for 'calc_connect', given the lattice if we want to avoid image neghbours - ! - function max_cutoff(lattice, error) - - real(dp), dimension(3,3), intent(in) :: lattice - real(dp) :: Max_Cutoff - real(dp), dimension(3) :: a,b,c - real(dp) :: cellVol, ra, rb, rc - integer, intent(out), optional :: error - - INIT_ERROR(error) - a = lattice(:,1); b = lattice(:,2); c = lattice(:,3) - cellVol = abs( scalar_triple_product(a,b,c) ) - - if(cellVol == 0.0_dp) then - RAISE_ERROR("Max_cutoff(): cell volume is exactly 0.0!", error) - end if - - ra = cellVol / norm(b .cross. c) - rb = cellVol / norm(c .cross. a) - rc = cellVol / norm(a .cross. b) - - Max_Cutoff = 0.5_dp * min(ra,rb,rc) - - end function max_cutoff - - subroutine connection_print(this,file,error) - - type(Connection), intent(in) :: this - type(Inoutput), optional, intent(inout) :: file - integer, intent(out), optional :: error - integer :: i,j,k,n,a - integer :: ndata(10) - - INIT_ERROR(error) - if (.not.this%initialised) then - RAISE_ERROR('Connection_Print: Connection object not initialised', error) - end if - - call print('Connectivity data:',file=file) - call print('-------------------------------------------------',file=file) - call print('| I | J | Shift | Distance |',file=file) - call print('-------------------------------------------------',file=file) - - do i = 1, size(this%neighbour1) - - if (.not. associated(this%neighbour1(i)%t)) cycle - - if ((this%neighbour1(i)%t%N + this%neighbour2(i)%t%N) > 0) then - write(line,'(a47)')'| Neighbour1 (i <= j) |' - call print(line, file=file) - endif - - do j = 1, this%neighbour1(i)%t%N - if(j == 1) then - write(line,'(a2,i7,a3,i7,a3,3i4,a3,f10.5,a2)')'| ', & - & i, ' | ', this%neighbour1(i)%t%int(1,j),' | ',this%neighbour1(i)%t%int(2:4,j),& - &' | ',this%neighbour1(i)%t%real(1,j),' |' - else - write(line,'(a12,i7,a3,3i4,a3,f10.5,a2)')'| | ', & - this%neighbour1(i)%t%int(1,j),' | ',this%neighbour1(i)%t%int(2:4,j),' | ',this%neighbour1(i)%t%real(1,j),' |' - end if - call print(line,file=file) - end do - - if (this%neighbour2(i)%t%N > 0) then - - write(line,'(a47)')'-----------------------------------------------' - call print(line, file=file) - write(line,'(a47)')'| Neighbour2 (i > j) |' - call print(line, file=file) - - - do j = 1, this%neighbour2(i)%t%N - - if(j == 1) then - write(line,'(a2,i7,a3,i7,a3,i7,a)') '| ', i, ' | ', this%neighbour2(i)%t%int(1,j),' | ',& - &this%neighbour2(i)%t%int(2,j),' |' - else - write(line,'(a12,i7,a3,i7,a)') '| | ', this%neighbour2(i)%t%int(1,j),' | ',& - &this%neighbour2(i)%t%int(2,j),' |' - end if - call print(line,file=file) - end do - - end if - - if ((this%neighbour1(i)%t%N + this%neighbour2(i)%t%N) > 0) then - write(line,'(a47)')'-----------------------------------------------' - call print(line,file=file) - endif - - end do - - write(line,'(a47)')'' - call print(line,file=file) - - - !Print the cell lists if they exist - if (this%cells_initialised .and. current_verbosity() > PRINT_NORMAL) then - call verbosity_push_decrement() - - write(line,'(a11)')'Cell Lists:' - call print(line,file=file) - write(line,'(a70)')'----------------------------------------------------------------------' - call print(line,file=file) - - ! Write atomic indices 10 per line - do k = 1, this%cellsNc - do j = 1, this%cellsNb - do i = 1, this%cellsNa - write(line,'(a7,i0,a1,i0,a1,i0,a3)')'Cell ( ',i,' ',j,' ',k,' ):' - call print(line,file=file) - - a = this%cell_heads(i, j, k) - n = 0 - do while (a > 0) - n = n + 1 - ndata(n) = a - if (n == 10) then - write (line, '(10i7)') ndata - call print(line,file=file) - n = 0 - endif - a = this%next_atom_in_cell(a) - enddo - if (n > 0) then - write (line, '(10i7)') ndata(1:n) - call print(line,file=file) - endif - - write(line,'(a70)')'----------------------------------------------------------------------' - call print(line,file=file) - end do - end do - end do - - call verbosity_pop() - - end if - - end subroutine connection_print - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Simple query functions - ! - !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx - - !% Return the total number of neighbour that atom $i$ has. - function connection_n_neighbours(this, i, error) result(n) - type(Connection), intent(in) :: this - integer, intent(in) :: i - integer, optional, intent(out) :: error - - integer :: n - - INIT_ERROR(error) - - if (.not. this%initialised) then - RAISE_ERROR('connection_n_neighbours: Connection structure has no connectivity data. Call calc_connect first.', error) - end if - - if (.not. associated(this%neighbour1(i)%t)) then - n = 0 - return - endif - - ! All neighbours - n = this%neighbour1(i)%t%N + this%neighbour2(i)%t%N - - end function connection_n_neighbours - - - !% Return the total number of neighbour, i.e. the number of bonds in the system - function connection_n_neighbours_total(this, error) result(n) - type(Connection), intent(in) :: this - integer, optional, intent(out) :: error - - integer :: i, n - - INIT_ERROR(error) - - if (.not. this%initialised) then - RAISE_ERROR('connection_n_neighbours: Connection structure has no connectivity data. Call calc_connect first.', error) - end if - - ! All neighbours - n = 0 - do i = 1, this%N - if (.not. associated(this%neighbour1(i)%t)) cycle - n = n + this%neighbour1(i)%t%N + this%neighbour2(i)%t%N - enddo - - end function connection_n_neighbours_total - - - !% Return the number of neighbour that atom $i$ has. - !% If the optional arguments max_dist or max_factor are present - !% then only neighbours closer than this cutoff are included. - function connection_n_neighbours_with_dist(this, at, i, max_dist, max_factor, error) result(n) - type(Connection), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp), optional, intent(in) :: max_dist, max_factor - integer, optional, intent(out) :: error - - integer :: n - - integer :: j, m - real(dp) :: r_ij - - INIT_ERROR(error) - - if (.not. this%initialised) then - RAISE_ERROR('connection_n_neighbours: Connection structure has no connectivity data. Call calc_connect first.', error) - end if - - if (.not. associated(this%neighbour1(i)%t)) then - n = 0 - return - endif - - if (.not. present(max_dist) .and. .not. present(max_factor)) then - ! All neighbours - n = this%neighbour1(i)%t%N + this%neighbour2(i)%t%N - else if (present(max_dist)) then - ! Only count neighbours within max_dist distance of i - n = 0 - do m=1,this%neighbour1(i)%t%N+this%neighbour2(i)%t%N - j = connection_neighbour(this, at, i, m, distance=r_ij) - if (r_ij < max_dist) n = n + 1 - end do - else if (present(max_factor)) then - ! Only count neighbours within max_factor of i - n = 0 - do m=1,this%neighbour1(i)%t%N+this%neighbour2(i)%t%N - j = connection_neighbour(this, at, i, m, distance=r_ij) - if (r_ij < bond_length(at%Z(i),at%Z(j))*max_factor) n = n + 1 - end do - else - RAISE_ERROR('connection_n_neighbours: optional arguments max_dist and max_factor must not both be present', error) - end if - - end function connection_n_neighbours_with_dist - - function connection_neighbour_index(this, i, n, index, t, is_j, error) result(j) - type(Connection), intent(in) :: this - integer :: i, n - integer, intent(out) :: index - !NB gfortran 4.3.4 seg faults if this is intent(out) - !NB type(Table), pointer, intent(out) :: t - type(Table), pointer :: t - !NB - logical, intent(out) :: is_j - integer, intent(out), optional :: error - integer :: j - - integer :: i_n1n, j_n1n - - INIT_ERROR(error) - - if (this%initialised) then - i_n1n = n-this%neighbour2(i)%t%N - if (n <= this%neighbour2(i)%t%N) then - j = this%neighbour2(i)%t%int(1,n) - j_n1n = this%neighbour2(i)%t%int(2,n) - index = j_n1n - t => this%neighbour1(j)%t - is_j = .true. - else if (i_n1n <= this%neighbour1(i)%t%N) then - j = this%neighbour1(i)%t%int(1,i_n1n) - index = i_n1n - t => this%neighbour1(i)%t - is_j = .false. - else - RAISE_ERROR('connection_neighbour_index: '//n//' out of range for atom '//i//' Should be in range 1 < n <= '//n_neighbours(this, i), error) - end if - else - RAISE_ERROR('connection_neighbour_index: Connect structure not initialized. Call calc_connect first.', error) - end if - - end function connection_neighbour_index - - function connection_neighbour_minimal(this, i, n, shift, index) result(j) - type(Connection), intent(in) :: this - integer :: i, j, n - integer, intent(out) :: shift(3) - integer, intent(out) :: index - - type(Table), pointer :: t - logical :: is_j - - j = connection_neighbour_index(this, i, n, index, t, is_j) - - if (is_j) then - shift = - t%int(2:4,index) - else - shift = t%int(2:4,index) - endif - - end function connection_neighbour_minimal - - !% Return the index of the $n^{\mbox{\small{th}}}$ neighbour of atom $i$. Together with the - !% previous function, this facilites a loop over the neighbours of atom $i$. Optionally, we - !% return other geometric information, such as distance, direction cosines and difference vector, - !% and also an direct index into the neighbour tables. If $i <= j$, this is an index into 'neighbour1(i)', - !% if $i > j$, it is an index into 'neighbour1(j)' - !% - !%> do n = 1,atoms_n_neighbours(at, i) - !%> j = atoms_neighbour(at, i, n, distance, diff, cosines, shift, index) - !%> - !%> ... - !%> end do - !% - !% if distance $>$ max_dist, return 0, and do not waste time calculating other quantities - function connection_neighbour(this, at, i, n, distance, diff, cosines, shift, index, max_dist, jn, error) result(j) - type(Connection), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i, n - real(dp), optional, intent(out) :: distance - real(dp), dimension(3), optional, intent(out) :: diff - real(dp), optional, intent(out) :: cosines(3) - integer, optional, intent(out) :: shift(3) - integer, optional, intent(out) :: index - real(dp), optional, intent(in) :: max_dist - integer, optional, intent(out) :: jn - integer, optional, intent(out) :: error - - real(dp)::mydiff(3), norm_mydiff - integer ::myshift(3) - integer ::j, i_n1n, j_n1n, i_njn, m - - INIT_ERROR(error) - - if (.not. this%initialised) then - RAISE_ERROR('connection_n_neighbours: Connection structure has no connectivity data. Call calc_connect first.', error) - end if - - if (.not. associated(this%neighbour1(i)%t)) then - RAISE_ERROR("called atoms_neighbour on atom " // i // " which has no allocated neighbour1 table", error) - endif - - ! First we give the neighbour2 entries (i > j) then the neighbour1 (i <= j) - ! This order chosen to give neighbours in approx numerical order but doesn't matter - if (this%initialised) then - i_n1n = n-this%neighbour2(i)%t%N - if (n <= this%neighbour2(i)%t%N) then - j = this%neighbour2(i)%t%int(1,n) - j_n1n = this%neighbour2(i)%t%int(2,n) - if(present(index)) index = j_n1n - else if (i_n1n <= this%neighbour1(i)%t%N) then - j = this%neighbour1(i)%t%int(1,i_n1n) - if(present(index)) index = i_n1n - else - RAISE_ERROR('atoms_neighbour: '//n//' out of range for atom '//i//' Should be in range 1 < n <= '//n_neighbours(this, i), error) - end if - else - RAISE_ERROR('atoms_neighbour: Atoms structure has no connectivity data. Call calc_connect first.', error) - end if - - if(present(jn)) then - if(i < j) then - do i_njn = 1, this%neighbour2(j)%t%N - if( (this%neighbour2(j)%t%int(1,i_njn)==i) .and. & - (this%neighbour2(j)%t%int(2,i_njn)==i_n1n) ) jn = i_njn - enddo - elseif(i > j) then - jn = j_n1n + this%neighbour2(j)%t%N - else - do i_njn = 1, this%neighbour1(j)%t%N - if( (this%neighbour1(j)%t%int(1,i_njn) == i) .and. & - all(this%neighbour1(j)%t%int(2:4,i_njn) == -this%neighbour1(i)%t%int(2:4,i_n1n))) & - jn = i_njn + this%neighbour2(j)%t%N - enddo - endif - endif - - ! found neighbour, now check for optional requests - if(present(distance)) then - if(i <= j) then - distance = this%neighbour1(i)%t%real(1,i_n1n) - else - distance = this%neighbour1(j)%t%real(1,j_n1n) - end if - if (present(max_dist)) then - if (distance > max_dist) then - j = 0 - return - endif - endif - else - if (present(max_dist)) then - if (i <= j) then - if (this%neighbour1(i)%t%real(1,i_n1n) > max_dist) then - j = 0 - return - endif - else - if (this%neighbour1(j)%t%real(1,j_n1n) > max_dist) then - j = 0 - return - endif - endif - endif - end if - - if(present(diff) .or. present(cosines) .or. present(shift)) then - if (i <= j) then - myshift = this%neighbour1(i)%t%int(2:4,i_n1n) - else - myshift = -this%neighbour1(j)%t%int(2:4,j_n1n) - end if - - if(present(shift)) shift = myshift - - if(present(diff) .or. present(cosines)) then - !mydiff = this%pos(:,j) - this%pos(:,i) + (this%lattice .mult. myshift) - if (size(this%neighbour1(i)%t%real,1) == 4) then - if (i <= j) then - mydiff = this%neighbour1(i)%t%real(2:4,i_n1n) - else - mydiff = -this%neighbour1(j)%t%real(2:4,j_n1n) - endif - else - mydiff = at%pos(:,j) - at%pos(:,i) - endif - do m=1,3 - ! forall(k=1:3) mydiff(k) = mydiff(k) + this%lattice(k,m) * myshift(m) - mydiff(1:3) = mydiff(1:3) + at%lattice(1:3,m) * myshift(m) - end do - if(present(diff)) diff = mydiff - if(present(cosines)) then - norm_mydiff = sqrt(mydiff(1)*mydiff(1) + mydiff(2)*mydiff(2) + mydiff(3)*mydiff(3)) - if (norm_mydiff > 0.0_dp) then - cosines = mydiff / norm_mydiff - else - cosines = 0.0_dp - endif - endif - end if - end if - - end function connection_neighbour - - function connection_is_min_image(this, i, error) result(is_min_image) - type(Connection), intent(in) :: this - integer, intent(in) :: i - integer, optional, intent(out) :: error - - logical :: is_min_image - integer :: n, m, NN - - INIT_ERROR(error) - - is_min_image = .true. - ! First we give the neighbour1 (i <= j) then the neighbour2 entries (i > j) - if (this%initialised) then - - if (.not. associated(this%neighbour1(i)%t)) then - RAISE_ERROR('is_min_image: atoms structure has no connectivity data for atom '//i, error) - end if - - nn = this%neighbour1(i)%t%N - do n=1,nn - if (this%neighbour1(i)%t%int(1,n) == i) then - is_min_image = .false. - return - end if - do m=n+1,nn - if (this%neighbour1(i)%t%int(1,n) == this%neighbour1(i)%t%int(1,m)) then - is_min_image = .false. - return - end if - end do - end do - - nn = this%neighbour2(i)%t%N - do n=1,nn - if (this%neighbour2(i)%t%int(1,n) == i) then - is_min_image = .false. - return - end if - do m=n+1,nn - if (this%neighbour2(i)%t%int(1,n) == this%neighbour2(i)%t%int(1,m)) then - is_min_image = .false. - return - end if - end do - end do - - else - RAISE_ERROR('is_min_image: Atoms structure has no connectivity data. Call calc_connect first.', error) - end if - - endfunction connection_is_min_image - - - ! - ! Fit_Box_In_Cell - ! - !% Given an orthogonal box, oriented along the cartesian axes with lengths '2*rx', '2*ry' and '2*rz' - !% and centred on the origin, what parameters must we pass to supercell to make a system big - !% enough from our original cell defined by lattice for the box to fit inside? - !% - !% The required supercell parameters are returned in 'Na', 'Nb', 'Nc' respectively. If, e.g. 'Na = 1' - !% then we don\'t need to supercell in the a direction. 'Na > 1' means we must supercell by 'Na' times - !% in the $x$ direction. - ! - subroutine fit_box_in_cell(rx,ry,rz,lattice,Na,Nb,Nc) - - real(dp), intent(in) :: rx, ry, rz - real(dp), dimension(3,3), intent(in) :: lattice - integer, intent(out) :: Na, Nb, Nc - !local variables - real(dp), dimension(3,3) :: g !inverse of lattice - real(dp) :: maxa, maxb, maxc !the current maximum in the a,b,c directions - real(dp), dimension(3) :: lattice_coords !the coordinates of a corner in terms of a,b,c - integer :: i,j,k - !This subroutine works by calculating the coordinates of the corners of the box - !in terms of the lattice vectors, taking the maximum in the lattice directions and - !rounding up to the nearest integer. - - call matrix3x3_inverse(lattice,g) - maxa = 0.0_dp; maxb=0.0_dp; maxc=0.0_dp - - !For the time being, do all eight corners. This is most likely overkill, but it's still quick. - do k = -1, 1, 2 - do j = -1, 1, 2 - do i = -1, 1, 2 - lattice_coords = g .mult. (/i*rx,j*ry,k*rz/) - if (abs(lattice_coords(1)) > maxa) maxa = abs(lattice_coords(1)) - if (abs(lattice_coords(2)) > maxb) maxb = abs(lattice_coords(2)) - if (abs(lattice_coords(3)) > maxc) maxc = abs(lattice_coords(3)) - end do - end do - end do - - Na = ceiling(2.0_dp*maxa) - Nb = ceiling(2.0_dp*maxb) - Nc = ceiling(2.0_dp*maxc) - - end subroutine fit_box_in_cell - -endmodule Connection_module diff --git a/src/libAtoms/Constraints.f95 b/src/libAtoms/Constraints.f95 deleted file mode 100644 index 567cd17b75..0000000000 --- a/src/libAtoms/Constraints.f95 +++ /dev/null @@ -1,1828 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Constraints module -!X -!% Contains the Constraint type and constraint subroutines -!% -!% Constraints are applied using the RATTLE algorithm: -!% H. C. Andersen, JCompPhys 52 24-34 (1983) -!% This itself is based on the SHAKE algorithm: -!% J. P. Ryckaert et al., JCompPhys 23 327-341 (1977) -!% -!% To integrate the system with constraints Newtons equations of motion have to be modified to -!% \begin{displaymath} -!% m\mathbf{a} = \mathbf{F} - \lambda\nabla\sigma -!% \end{displaymath} -!% where $\sigma$ is a constraint function (see below) and -!% $\lambda$ is a Lagrange multiplier which is dependent upon atomic positions -!% and velocities. -!% -!% When the equations of motion are discretised two separate approximation to $\lambda$ must be -!% made so that the positions and velocities both obey the constraint exactly (or to within a -!% specified precision) at each time step. -!% -!% During the position updates, a Lagrange multiplier $\lambda_j$ attached to a constraint -!% $\sigma_j$, which involves particles $i=1 \ldots N$ is solved for iteratively by the following: -!% \begin{displaymath} -!% \lambda_j^S = \frac{2\sigma_j}{(\Delta t)^2 \sum_i \frac{1}{m_i} \nabla_i \sigma_j(t+\Delta t) \cdot -!% \nabla_i \sigma_j(t)} -!% \end{displaymath} -!% -!% The velocity updates also include the $\lambda_j^S\nabla\sigma_j$ term, plus an additional -!% $\lambda_j^R\nabla\sigma_j$ term where $\lambda_j^R$ is solved for via: -!% \begin{displaymath} -!% \lambda_j^R = \frac{2\dot{\sigma}_j}{\Delta t \sum_i \frac{1}{m_i} |\nabla_i \sigma_j(t+\Delta t)|^2} -!% \end{displaymath} -!% -!% The full, non-specialised form of the iterative solver is present in the code for added flexibility and -!% to allow users to write and use their own constraint functions, which can be time dependent. -!% -!% -!% \textbf{Writing extra constraint subroutines} -!% -!% A constraint subroutine evaluates a constraint function ('C'), its derivatives with respect to all -!% coordinates ('dC_dr') and its full time derivative ('dC_dt'). A constraint function is a function which -!% evaluates to zero when the constraint is satisfied. -!% -!% Probably the easiest way of constructing a new subroutine is to copy the following and fill in the gaps: -!% -!%> subroutine CONSTRAINT(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt) -!%> -!%> real(dp), dimension(:), intent(in) :: pos, velo, mass, data -!%> real(dp), intent(in) :: lattice(3,3) -!%> real(dp), intent(in) :: t -!%> real(dp), intent(out) :: C -!%> real(dp), dimension(size(pos)), intent(out) :: dC_dr -!%> real(dp), intent(out) :: dC_dt -!%> if(size(pos) /= ?) & -!%> call System_Abort('CONSTRAINT: Exactly ? atoms must be specified') -!%> if(size(data) /= ?) & -!%> call System_Abort('CONSTRAINT: "data" must contain exactly ? value(s)') -!%> C = ? -!%> dC_dr = ? -!%> dC_dt = ? -!%> -!%> end subroutine CONSTRAINT -!% -!% A few notes: -!% \begin{itemize} -!% \item The subroutine must make its own checks on the sizes of the input arguments (as shown) -!% -!% \item dC_dr should not be zero when the constraint is satisfied, since then no force can be applied to -!% enforce the constraint. For example, the plane constraint could have been defined as the squared -!% distance from the plane, but that would cause it to suffer from this problem, so the signed -!% distance was used instead. -!% -!% \item Currently, a constraint function can only depend explicitly on positions and time, so the kinetic -!% energy of a group of particles cannot be constrained for example. -!% -!% \item dC_dt will usually be dC_dr .dot. velo, except in the case where the constraint depends explicitly -!% on time; then there will be an extra partial d/dt term. -!% -!% \item If a constraint contains one particle only, then the absolute position of that particle is passed -!% in 'pos'. If more than one particle is in the constraint then the relative positions are passed -!% (with the first particle at the origin), so periodic boundary conditions should not be a worry. -!% -!% \item When a constraint is added to a DynamicalSystem its number of degrees of freedom is decreased by 1. -!% A constraint should only attempt to remove one degree of freedom MAXIMUM. Constraints which try to, -!% for examples, keep a particle on a line (removing 2 degrees of freedom) are doomed to failure since -!% the particle will not always be able to return to the line by the application of forces in the direction -!% from the particle to the nearest point on the line. Instead, implement the line as the intersection of -!% two planes, which makes the removal of two degrees of freedom more explicit, and allows the algorithm -!% to use two directions to construct the constraint force. -!% -!% \item Some constraints will be extraneous (e.g. constraining a bond length which, by the action of many -!% other constraints, is already fixed implicitly), and the decrease of ds%Ndof will be wrong, in which -!% case it should be correctly set by hand. Also, the algorithm will fail if the 'explicit' constraint -!% is not the same as the 'implicit' one. -!% \end{itemize} -!% -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module constraints_module - - use system_module - use units_module - use linearalgebra_module - use atoms_types_module - use atoms_module - use group_module - use dictionary_module - - implicit none - private - - public :: constraint, initialise, finalise, print, register_constraint, add_restraint_forces - public :: BONDANGLECOS, BONDLENGTH, BONDLENGTH_SQ, BONDLENGTH_DEV_POW, BONDLENGTH_DIFF, GAP_ENERGY, PLANE - public :: CRACK_TIP_CURVATURE, CRACK_TIP_GRADIENT, CRACK_TIP_POSITION - public :: STRUCT_FACTOR_LIKE_MAG, STRUCT_FACTOR_LIKE_R, STRUCT_FACTOR_LIKE_I - public :: CUBIC_BONDLENGTH_SQ - public :: CONSTRAINT_WARNING_TOLERANCE, LOWER_BOUND, UPPER_BOUND, BOTH_UPPER_AND_LOWER_BOUNDS, BOUND_STRING - public :: constraint_store_gradient, constraint_calculate_values_at, constraint_amend, shake, rattle - - integer, parameter :: MAX_CONSTRAINT_SUBS = 20 !% This must be consistent with Constraint_Pointers.c - integer :: REGISTERED_CONSTRAINTS = 0 !% Stores the number of registered constraint functions - - integer, parameter :: RATTLE_MAX_ITERATIONS = 3000 !% Max iterations before failure (same as AMBER) - real(dp), parameter :: DEFAULT_CONSTRAINT_TOLERANCE = 1.0E-10_dp !% Default tolerance of constraints - real(dp), parameter :: CONSTRAINT_WARNING_TOLERANCE = 1.0E-3_dp !% Warn if a constraint is added which is not obeyed - !% to within this tolerance - - integer, parameter :: LOWER_BOUND = -1 !% Restraint should only act if the instantaneous value is larger than the equilibrium restraint value - integer, parameter :: BOTH_UPPER_AND_LOWER_BOUNDS = 0 !% Restraint acts independently from the instantaneous value of the restraint - integer, parameter :: UPPER_BOUND = 1 !% Restraint should only act if the instantaneous value is larger than the equilibrium restraint value - character(len=32), parameter :: BOUND_STRING(-1:1) = (/"LOWER_BOUND ","UPPER_AND_LOWER_BOUNDS","UPPER_BOUND "/) - - type Constraint - - integer :: N = 0 !% Number of atoms in the constraint - integer, allocatable, dimension(:) :: atom !% Indices of the atoms in the constraint - real(dp), allocatable, dimension(:) :: data !% Data to be passed to the constraint function - integer :: func !% Pointer to the constraint function - real(dp) :: lambdaR !% Lagrange multipler for position constraint forces - real(dp) :: dlambdaR !% Last computed correction to lambdaR - real(dp) :: lambdaV !% Lagrange multipler for velocity constraint forces - real(dp) :: dlambdaV !% Last computed correction to lambdaV - real(dp) :: C !% Value of the constraint - real(dp) :: target_v !% Target value of the collective coordinate - real(dp), allocatable, dimension(:) :: dC_dr !% Gradient of the constraint at the start of the timestep - real(dp) :: dC_dt !% Time derivative of the constraint - real(dp), allocatable, dimension(:) :: old_dC_dr !% Value of 'dC_dr' at the beginning of the algorithm - real(dp) :: tol !% Convergence tolerance of the constraint - logical :: initialised = .false. - real(dp), allocatable, dimension(:) :: dcoll_dr !% The derivative of the collective coordinate ($\xi$) wrt. the positions (x), - !% needed to calculate the Fixman determinant. - !% For constraints $\xi - \xi_0$ it is the same as dC_dr - real(dp) :: Z_coll !% Fixman determinant of the constraint - !% $ Z_\xi = \sum_i frac{1}{m_i} \left( \frac{\partial \xi}{\partial x_i} \right)^2 $ - !% $ A (\xi) = \int \langle \lambda_R \rangle_\xi \mathrm{d} \xi - k_B T \ln \langle Z_{\xi}^{-1/2} \rangle_\xi$ - - real(dp) :: k !% spring constant for restraint - integer :: bound !% for onesided restraint (upper/lower) - real(dp) :: E !% restraint energy - real(dp), allocatable, dimension(:) :: dE_dr !% restraint force (on atoms) - real(dp) :: dE_dcoll !% derivative of restraint energy w.r.t. collective coordinate, for Umbrella Integration w.r.t. pos - real(dp) :: dE_dk !% derivative of restraint energy w.r.t. stifness, for Umbrella Integration w.r.t. stiffness - logical :: print_summary=.true. !% if true, print in summary - - end type Constraint - - interface initialise - module procedure constraint_initialise - end interface initialise - - interface finalise - module procedure constraint_finalise, constraints_finalise - end interface finalise - - interface assignment(=) - module procedure constraint_assignment, constraints_assignment - end interface assignment(=) - - interface print - module procedure constraint_print, constraints_print - end interface print - - ! - ! interface blocks for the C functions - ! - !% OMIT - interface - subroutine register_constraint_sub(sub) - interface - subroutine sub(pos,velo,mass, lattice,t,data,C,dC_dr,dC_dt,dcoll_dr,Z_coll,target_v) - use system_module !for dp definition - real(dp), dimension(:), intent(in) :: pos,velo,mass,data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr,dcoll_dr - real(dp), intent(out) :: dC_dt,Z_coll - real(dp), intent(out) :: target_v - end subroutine sub - end interface - end subroutine register_constraint_sub - end interface - - !% OMIT - interface - subroutine call_constraint_sub(i,pos,velo,mass, lattice,t,data,C,dC_dr,dC_dt,dcoll_dr,Z_coll,target_v) - use system_module - integer :: i - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr,dcoll_dr - real(dp), intent(out) :: dC_dt,Z_coll - real(dp), intent(out) :: target_v - end subroutine call_constraint_sub - end interface - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X INITIALISE - !% - !% Initialise this Constraint. - !% - !% NOTE: the atomic indices are not sorted into ascending order, because - !% a three body constraint (for example) may depend on the order - !% (and the wrong angle could be constrained). - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine constraint_initialise(this,indices,func,data,k,bound,tol) - - type(Constraint), intent(inout) :: this - integer, dimension(:), intent(in) :: indices - integer, intent(in) :: func - real(dp), dimension(:), intent(in) :: data - real(dp), optional, intent(in) :: k, tol - integer, optional, intent(in) :: bound - - - if (this%initialised) call constraint_finalise(this) - - if (size(indices) == 0) & - call system_abort('Constraint_Initialise: There must be at least one particle in the constraint') - - this%N = size(indices) - allocate(this%atom(this%N)) - this%atom = indices - - allocate(this%data(size(data))) - this%data = data - - if (func < 0 .or. func >= REGISTERED_CONSTRAINTS) then - write(line,'(a,i0,a)')'Constraint_Initialised: Invalid constraint subroutine (',func,')' - call System_Abort(line) - end if - - this%func = func - this%lambdaR = 0.0_dp - this%lambdaV = 0.0_dp - this%C = 0.0_dp - this%dC_dt = 0.0_dp - this%tol = DEFAULT_CONSTRAINT_TOLERANCE - if (present(tol)) then - if (tol>0._dp) this%tol = tol - endif - - allocate(this%dC_dr(3*size(indices))) - this%dC_dr = 0.0_dp - allocate(this%old_dC_dr(3*size(indices))) - this%old_dC_dr = 0.0_dp - - allocate(this%dcoll_dr(3*size(indices))) - this%dcoll_dr = 0.0_dp - this%Z_coll = 0.0_dp - - if (present(k)) then - this%k = k - this%bound = optional_default(BOTH_UPPER_AND_LOWER_BOUNDS,bound) - this%E = 0.0_dp - this%dE_dcoll = 0.0_dp - this%dE_dk = 0.0_dp - allocate(this%dE_dr(3*size(indices))) - this%dE_dr = 0.0_dp - else - this%k = -1.0_dp - endif - - !initialised - this%initialised = .true. - - end subroutine constraint_initialise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X FINALISE - !X - !% Finalise this Constraint object. - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine constraint_finalise(this) - - type(Constraint), intent(inout) :: this - - this%N = 0 - this%func = 0 - this%lambdaR = 0.0_dp - this%lambdaV = 0.0_dp - this%C = 0.0_dp - this%dC_dt = 0.0_dp - this%tol = 0.0_dp - if (allocated(this%atom)) deallocate(this%atom) - if (allocated(this%data)) deallocate(this%data) - if (allocated(this%dC_dr)) deallocate(this%dC_dr) - if (allocated(this%old_dC_dr)) deallocate(this%old_dC_dr) - if (allocated(this%dcoll_dr)) deallocate(this%dcoll_dr) - this%Z_coll = 0.0_dp - this%k = -1.0_dp - this%k = 0 - this%E = 0.0_dp - this%dE_dcoll = 0.0_dp - this%dE_dk = 0.0_dp - if (allocated(this%dE_dr)) deallocate(this%dE_dr) - this%initialised = .false. - - end subroutine constraint_finalise - - subroutine constraints_finalise(this) - - type(Constraint), dimension(:), allocatable, intent(inout) :: this - integer :: i - - if (allocated(this)) then - do i = 1, size(this) - call finalise(this(i)) - end do - deallocate(this) - end if - - end subroutine constraints_finalise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X AMEND A CONSTRAINT: - !% Change constraint data and/or constraint function - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine constraint_amend(this,func,data,k,bound) - - type(Constraint), intent(inout) :: this - integer, optional, intent(in) :: func - real(dp), dimension(:), optional, intent(in) :: data - real(dp), optional, intent(in) :: k - integer, optional, intent(in) :: bound - - if (present(data)) then - call reallocate(this%data,size(data)) - this%data = data - end if - - if (present(func)) then - if (func < 0 .or. func >= REGISTERED_CONSTRAINTS) then - write(line,'(a,i0,a)')'Constraint_Amend: Invalid constraint subroutine (',func,')' - call System_Abort(line) - end if - - this%func = func - end if - - if (present(k)) this%k = k - if (present(bound)) this%bound = bound - - end subroutine constraint_amend - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X ASSIGNMENT - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine constraint_assignment(to,from) - - type(Constraint), intent(inout) :: to - type(Constraint), intent(in) :: from - - !First wipe the target of the assignment - call Finalise(to) - - if (from%initialised) then - - !Allocate target arrays - allocate(to%atom(size(from%atom)), & - to%data(size(from%data)), & - to%dC_dr(size(from%dC_dr)), & - to%old_dC_dr(size(from%old_dC_dr)), & - to%dcoll_dr(size(from%dcoll_dr))) - - !Then copy over the members one by one - to%N = from%N - to%atom = from%atom - to%data = from%data - to%func = from%func - to%lambdaR = from%lambdaR - to%lambdaV = from%lambdaV - to%C = from%C - to%dC_dr = from%dC_dr - to%dC_dt = from%dC_dt - to%old_dC_dr = from%old_dC_dr - to%dcoll_dr = from%dcoll_dr - to%Z_coll = from%Z_coll - to%tol = from%tol - to%k = from%k - to%bound = from%bound - to%E = from%E - to%dE_dcoll = from%dE_dcoll - to%dE_dk = from%dE_dk - if (allocated(from%dE_dr)) allocate(to%dE_dr(size(from%dE_dr))) - to%initialised = from%initialised - end if - - end subroutine constraint_assignment - - subroutine constraints_assignment(to,from) - - type(Constraint), dimension(:), intent(inout) :: to - type(Constraint), dimension(:), intent(in) :: from - integer :: i - - do i = 1, size(from) - to(i) = from(i) - end do - - end subroutine constraints_assignment - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X CALCULATE CONSTRAINT VALUES - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine constraint_calculate_values(this,pos,velo,mass, lattice,t) - - type(Constraint), intent(inout) :: this - real(dp), dimension(:), intent(in) :: pos, velo, mass - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - - call call_constraint_sub(this%func,pos,velo,mass,lattice,t,this%data,this%C,this%dC_dr,this%dC_dt,this%dcoll_dr,this%Z_coll,this%target_v) - if (this%k >= 0.0_dp) then ! restraint -!call print("RESTRAINT C "//this%C) - if ( (this%bound==BOTH_UPPER_AND_LOWER_BOUNDS) .or. & !apply anyway - (this%bound==UPPER_BOUND .and. this%C>this%target_v) .or. & !apply when exceeding the target value - (this%bound==LOWER_BOUND .and. this%C 1) then - pos(1:3) = 0.0_dp - do n = 2, this%N - i = this%atom(n) - pos(3*n-2:3*n) = diff_min_image(at,o,i) - velo(3*n-2:3*n) = at%velo(:,i) - mass(n) = mass_ptr(i) - end do - else - pos = at%pos(:,o) - end if - - call constraint_calculate_values(this,pos,velo,mass,at%lattice,t) - - end subroutine constraint_calculate_values_at - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X STORE THE GRADIENT AT THE START OF THE ALGORITHM - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine constraint_store_gradient(this) - - type(Constraint), intent(inout) :: this - - this%old_dC_dr = this%dC_dr - - end subroutine constraint_store_gradient - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X REGISTERING A CONSTRAINT - !X - !% Wrapper for constraint registering. Allows error catching - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function register_constraint(sub) result(p) - - integer :: p - interface - subroutine sub(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - use system_module - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - end subroutine sub - end interface - - if ((REGISTERED_CONSTRAINTS+1) == MAX_CONSTRAINT_SUBS) & - call system_abort('Register_Constraint: Pointer table is full') - call register_constraint_sub(sub) - p = REGISTERED_CONSTRAINTS - REGISTERED_CONSTRAINTS = REGISTERED_CONSTRAINTS + 1 - - end function register_constraint - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X I/O - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine constraint_print(this,verbosity,file,index) - - type(Constraint), intent(in) :: this - integer, optional, intent(in) :: verbosity - type(Inoutput), optional, intent(inout) :: file - integer, optional, intent(in) :: index - integer :: i - character(len=20) :: type - - if (this%k < 0.0_dp) then - type="Constraint" - else - type="Restraint" - endif - - call print('================', verbosity, file) - if (present(index)) then - call print(' '//trim(type)//' '// index, verbosity, file) - else - call print(' '//trim(type), verbosity, file) - endif - call print('================', verbosity, file) - call print('', verbosity, file) - if (this%initialised) then - call print('Number of atoms = '//this%N, verbosity, file) - call print('Atoms: '//this%atom, verbosity, file) - call print('Data: '//this%data, verbosity, file) - if (this%k >= 0.0_dp) call print(trim(type)//' k = '//this%k, verbosity, file) - call print(trim(type)//' function = '//this%func, verbosity, file) - call print(trim(type)//' target_value = '//this%target_v, verbosity, file) - call print(trim(type)//' value = '//this%C, verbosity, file) - call print(trim(type)//' gradients :') - do i = 1, this%N - call print(this%dC_dr(3*i-2:3*i), verbosity, file) - end do - call print('Time Derivative = '// this%dC_dt, verbosity, file) - if (this%k >= 0.0) then ! restraint - call print('restraint spring constant(k) = '// this%k, verbosity, file) - call print('spring acts as (bound) = '// trim(BOUND_STRING(this%bound)), verbosity, file) - else ! constraint - call print('Constraint - k value not used') - call print('Lagrange multiplier(R) = '// this%lambdaR, verbosity, file) - call print('Lagrange multiplier(V) = '// this%lambdaV, verbosity, file) - endif - call print('Fixman determinant(Z_xi) = '// this%Z_coll, verbosity, file) - call print(' gradients of collective coordinate:') - do i = 1, this%N - call print(this%dcoll_dr(3*i-2:3*i), verbosity, file) - end do - else - call print('(uninitialised)', verbosity, file) - end if - call print('', verbosity, file) - call print('================', verbosity, file) - - end subroutine constraint_print - - ! - !% Print an array of constraints, with optional first index - ! - subroutine constraints_print(this,verbosity,file,first) - - type(Constraint), dimension(:), intent(in) :: this - integer, optional, intent(in) :: verbosity - type(Inoutput), optional, intent(inout) :: file - integer, optional, intent(in) :: first - integer :: my_first, i - - my_first = 1 - if (present(first)) my_first = first - - do i = 1, size(this) - call print(this(i),verbosity,file,i-1+my_first) - call print('',verbosity,file) - end do - - end subroutine constraints_print - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X SHAKE/RATTLE ROUTINES - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% This is the SHAKE part of the SHAKE/RATTLE algorithm. It - !% adds forces to each atom which are in the directions of the - !% gradients of the constraint functions such that the constraints - !% are obeyed to within the preset tolerance at the new positions. - subroutine shake(at,g,constraints,t,dt,store_constraint_force) - - type(atoms), intent(inout) :: at !% the atoms object - type(group), intent(in) :: g !% the constrained group - type(constraint), intent(inout) :: constraints(:) !% an array of all the dynamicalsystem's constraints - real(dp), intent(in) :: t, dt !% the current time, and the time step - logical, optional, intent(in) :: store_constraint_force - - integer :: i,j,n, nn, Nobj, Nat, iterations - real(dp) :: da(3), m, df(3) - real(dp), dimension(:,:), pointer :: constraint_force - logical :: converged, do_store - - do i=1, size(constraints) - if (constraints(i)%k >= 0.0_dp) & - call system_abort("Called shake on constraint " // i // " which is actually a restraint") - end do - - Nobj = group_n_objects(g) - Nat = group_n_atoms(g) - do_store = optional_default(.false.,store_constraint_force) - - !Check for "constraint_force" property - if (do_store) then - if (assign_pointer(at,'constraint_force',constraint_force)) then - !zero the constraint forces - do n = 1, Nat - i = group_nth_atom(g,n) - constraint_force(:,i) = 0.0_dp - end do - else - call system_abort('shake: cannot find "constraint_force" property') - end if - end if - - !Calculate the constraint functions and store their values - the derivatives at this point will be - !used as the directions of the forces - - do n = 1, Nobj - i = group_nth_object(g,n) - call constraint_calculate_values_at(constraints(i),at,t) - constraints(i)%old_dC_dr = constraints(i)%dC_dr - constraints(i)%dlambdaR = 0.0_dp - constraints(i)%lambdaR = 0.0_dp - end do - - !Make the usual velocity Verlet step - do n = 1, Nat - i = group_nth_atom(g,n) - at%pos(:,i) = at%pos(:,i) + at%velo(:,i)*dt - end do - - iterations = 0 - do - ! update the accelerations, velocities, and positions using dlambdaR - do n = 1, Nobj - i = group_nth_object(g,n) - do nn = 1, constraints(i)%N - j = constraints(i)%atom(nn) - da = -constraints(i)%dlambdaR*constraints(i)%old_dC_dr(3*nn-2:3*nn)/at%mass(j) - at%acc(:,j) = at%acc(:,j) + da - at%velo(:,j) = at%velo(:,j) + 0.5_dp*dt*da - at%pos(:,j) = at%pos(:,j) + 0.5_dp*dt*dt*da - end do - end do - - ! recalculate constraints at the new positions (and new time) and test for convergence - converged = .true. - do n = 1, Nobj - i = group_nth_object(g,n) - call constraint_calculate_values_at(constraints(i),at,t+dt) -!call print("CONSTRAINTS%C "//constraints(i)%C) - if (abs(constraints(i)%C) > constraints(i)%tol) converged = .false. - end do - - if (converged .or. iterations > RATTLE_MAX_ITERATIONS) exit - - !Not converged, so calculate an update to the Lagrange multiplers (dlambdaR) - do n = 1, Nobj - i = group_nth_object(g,n) - m = 0.0_dp - do nn = 1, constraints(i)%N !Loop over each particle in the constraint - j = constraints(i)%atom(nn) - m = m + (constraints(i)%dC_dr(3*nn-2:3*nn) .dot. constraints(i)%old_dC_dr(3*nn-2:3*nn)) / at%mass(j) - end do - constraints(i)%dlambdaR = 2.0_dp * constraints(i)%C / (m * dt * dt) -!call print("CONSTRAINTS%dlambdaR"//constraints(i)%dlambdaR) - constraints(i)%lambdaR = constraints(i)%lambdaR + constraints(i)%dlambdaR -!call print("CONSTRAINTS%lambdaR"//constraints(i)%lambdaR) - end do - - iterations = iterations + 1 - - end do - - ! Store first part of the constraint force - if (do_store) then - do n = 1, Nobj - i = group_nth_object(g,n) - do nn = 1, constraints(i)%N - j = constraints(i)%atom(nn) - df = -constraints(i)%lambdaR*constraints(i)%old_dC_dr(3*nn-2:3*nn) - constraint_force(:,j) = constraint_force(:,j) + df - end do - end do - end if - - if (.not.converged) then - call print('shake: could not converge in '//RATTLE_MAX_ITERATIONS//& - ' iterations for this group:') - call print(g) - call system_abort('shake convergence problem') - end if - - end subroutine shake - - !% This is the RATTLE part of the SHAKE/RATTLE algorithm. It - !% adds forces to each atom which are in the directions of the - !% gradients of the constraint functions (evaluated at the NEW positions) - !% such that the constraints are obeyed to within the preset tolerance - !% by the new velocities. - subroutine rattle(at,g,constraints,t,dt,store_constraint_force) - - type(atoms), intent(inout) :: at - type(group), intent(in) :: g - type(constraint), intent(inout) :: constraints(:) - real(dp), intent(in) :: t - real(dp), intent(in) :: dt - logical, optional, intent(in) :: store_constraint_force - - real(dp), dimension(:,:), pointer :: constraint_force - integer :: i,j,n, nn, Nobj, Nat, iterations - real(dp) :: da(3), m, df(3) - logical :: converged, do_store - - do i=1, size(constraints) - if (constraints(i)%k >= 0.0_dp) & - call system_abort("Called rattle on constraint " // i // " which is actually a restraint") - end do - - Nobj = group_n_objects(g) - Nat = group_n_atoms(g) - do_store = optional_default(.false.,store_constraint_force) - - !Check for "constraint_force" property - if (do_store) then - if (.not. assign_pointer(at%properties,'constraint_force',constraint_force)) then - call system_abort('rattle: cannot find "constraint_force" property') - end if - end if - - !Make the usual velocity Verlet step - do n = 1, Nat - i = group_nth_atom(g,n) - at%velo(:,i) = at%velo(:,i) + 0.5_dp*at%acc(:,i)*dt - end do - - !Calculate the constraint functions and store their values - the derivatives at this point will be - !used as the directions of the forces - - do n = 1, Nobj - i = group_nth_object(g,n) - call constraint_calculate_values_at(constraints(i),at,t+dt) - constraints(i)%old_dC_dr = constraints(i)%dC_dr - constraints(i)%dlambdaV = 0.0_dp - constraints(i)%lambdaV = 0.0_dp - end do - - iterations = 0 - do - ! update the accelerations, and velocities using dlambdaV - do n = 1, Nobj - i = group_nth_object(g,n) - do nn = 1, constraints(i)%N - j = constraints(i)%atom(nn) - da = -constraints(i)%dlambdaV*constraints(i)%old_dC_dr(3*nn-2:3*nn)/at%mass(j) - at%acc(:,j) = at%acc(:,j) + da - at%velo(:,j) = at%velo(:,j) + 0.5_dp*dt*da - end do - end do - - ! recalculate constraints using new velocities and test for convergence - converged = .true. - do n = 1, Nobj - i = group_nth_object(g,n) - call constraint_calculate_values_at(constraints(i),at,t+dt) - if (abs(constraints(i)%dC_dt) > constraints(i)%tol) converged = .false. - end do - - if (converged .or. iterations > RATTLE_MAX_ITERATIONS) exit - - !Not converged, so calculate an update to the Lagrange multiplers (dlambdaV) - do n = 1, Nobj - i = group_nth_object(g,n) - m = 0.0_dp - do nn = 1, constraints(i)%N !Loop over each particle in the constraint - j = constraints(i)%atom(nn) - m = m + normsq(constraints(i)%dC_dr(3*nn-2:3*nn)) / at%mass(j) - end do - constraints(i)%dlambdaV = 2.0_dp * constraints(i)%dC_dt / (m * dt) - constraints(i)%lambdaV = constraints(i)%lambdaV + constraints(i)%dlambdaV - end do - - iterations = iterations + 1 - - end do - - ! Store second poart of the constraint force - if (do_store) then - do n = 1, Nobj - i = group_nth_object(g,n) - do nn = 1, constraints(i)%N - j = constraints(i)%atom(nn) - df = -constraints(i)%lambdaV*constraints(i)%old_dC_dr(3*nn-2:3*nn) - constraint_force(:,j) = constraint_force(:,j) + df - end do - end do - end if - - if (.not.converged) then - call print('rattle: could not converge in '//RATTLE_MAX_ITERATIONS//& - ' iterations for this group:') - call print(g) - call system_abort('rattle convergence problem') - end if - - end subroutine rattle - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X START OF CONSTRAINT SUBROUTINES - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X BONDANGLECOS: - !X - !% Constrain a cosine of a bond angle - !% 'data' should contain the required cosine value - !% The minimum image convention is used. - !% - !% The function used is $C = |\hat{\mathbf{r}}_{21} \cdot \hat{\mathbf{r}}_{23}| - c$ - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine BONDANGLECOS(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp), dimension(3) :: d21_hat, d23_hat - real(dp) :: d21_norm, d23_norm, dot_123 - integer :: i - - if(size(pos) /= 9) call system_abort('BONDANGLECOS: Exactly 3 atom positions must be specified') - if(size(velo) /= 9) call system_abort('BONDANGLECOS: Exactly 3 atom velocities must be specified') - if(size(mass) /= 3) call system_abort('BONDANGLECOS: Exactly 3 atom velocities must be specified') - if(size(data) /= 1) call system_abort('BONDANGLECOS: "data" must contain exactly one value') - - d21_hat = pos(1:3)-pos(4:6) - d21_norm = norm(d21_hat) - d21_hat = d21_hat/d21_norm - - d23_hat = pos(7:9)-pos(4:6) - d23_norm = norm(d23_hat) - d23_hat = d23_hat/d23_norm - - dot_123 = (d21_hat .dot. d23_hat) - - C = dot_123 - data(1) - target_v = data(1) - - dC_dr(1:3) = +(d23_hat - d21_hat*dot_123)/d21_norm - dC_dr(4:6) = - (d23_hat - d21_hat*dot_123)/d21_norm - (d21_hat - d23_hat*dot_123)/d23_norm - dC_dr(7:9) = +(d21_hat - d23_hat*dot_123)/d23_norm - - dC_dt = dC_dr .dot. velo - - dcoll_dr(1:9) = dC_dr(1:9) - Z_coll = 0._dp - do i=1,3 - Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) - enddo - - end subroutine BONDANGLECOS - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X BONDLENGTH: - !X - !% Exponentially decay a bond length towards a final value. - !% - !% \begin{itemize} - !% \item data(1) = initial bond length - !% \item data(2) = final bond length - !% \item data(3) = initial time - !% \item data(4) = relaxation time - !% \end{itemize} - !% - !% Constraint function is $C = |\mathbf{r}_1 - \mathbf{r}_2| - d$, where - !% \begin{displaymath} - !% d = d_{final} + (d_{init} - d_{final})\exp\left(-\frac{t-t_{init}}{t_{relax}}\right) - !% \end{displaymath} - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine BONDLENGTH(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: r(3), d, diff, efact - integer :: i - - if(size(pos) /= 6) call system_abort('BONDLENGTH: Exactly 2 atoms must be specified') - if(size(velo) /= 6) call system_abort('BONDLENGTH: Exactly 2 atoms must be specified') - if(size(mass) /= 2) call system_abort('BONDLENGTH: Exactly 2 atoms must be specified') - if(size(data) /= 4) call system_abort('BONDLENGTH: "data" must contain exactly four values') - - r = pos(1:3)-pos(4:6) - diff = data(1) - data(2) - efact = exp(-(t-data(3))/data(4)) - d = data(2) + diff * efact - - C = norm(r) - d - target_v = d - - dC_dr(1:3) = r/norm(r) - dC_dr(4:6) = -r/norm(r) - - dC_dt = (dC_dr .dot. velo) + diff * efact / data(4) - - dcoll_dr(1:6) = dC_dr(1:6) - Z_coll = 0._dp - do i=1,2 - Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) - enddo - - end subroutine BONDLENGTH - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X BONDLENGTH_SQ: - !X - !% Exponentially decay a bond length towards a final value. - !% - !% \begin{itemize} - !% \item data(1) = initial bond length - !% \item data(2) = final bond length - !% \item data(3) = initial time - !% \item data(4) = relaxation time - !% \end{itemize} - !% - !% Constraint function is $C = |\mathbf{r}_1 - \mathbf{r}_2|^2 - d^2$, where - !% \begin{displaymath} - !% d = d_{final} + (d_{init} - d_{final})\exp\left(-\frac{t-t_{init}}{t_{relax}}\right) - !% \end{displaymath} - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine BONDLENGTH_SQ(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: r(3), d, diff, efact - integer :: i - - if(size(pos) /= 6) call system_abort('BONDLENGTH_SQ: Exactly 2 atoms must be specified') - if(size(velo) /= 6) call system_abort('BONDLENGTH_SQ: Exactly 2 atoms must be specified') - if(size(mass) /= 2) call system_abort('BONDLENGTH_SQ: Exactly 2 atoms must be specified') - if(size(data) /= 4) call system_abort('BONDLENGTH_SQ: "data" must contain exactly four values') - - r = pos(1:3)-pos(4:6) - diff = data(1) - data(2) - efact = exp(-(t-data(3))/data(4)) - d = data(2) + diff * efact - - C = normsq(r) - d*d - target_v = d*d - dC_dr(1:3) = 2.0_dp * r - dC_dr(4:6) = -2.0_dp * r - dC_dt = (dC_dr .dot. velo) + 2.0_dp * d * diff * efact / data(4) - - dcoll_dr(1:6) = dC_dr(1:6) - Z_coll = 0._dp - do i=1,2 - Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) - enddo - - end subroutine BONDLENGTH_SQ - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X BONDLENGTH_DEV_POW: - !X - !% Exponentially decay an arbitrary power of the deviation of a bond length towards a final value. - !% - !% \begin{itemize} - !% \item data(1) = initial bond length - !% \item data(2) = final bond length - !% \item data(3) = exponent - !% \item data(4) = initial time - !% \item data(5) = relaxation time - !% \end{itemize} - !% - !% Constraint function is $C = (|\mathbf{r}_1 - \mathbf{r}_2| - d)^p$, where - !% \begin{displaymath} - !% d = d_{final} + (d_{init} - d_{final})\exp\left(-\frac{t-t_{init}}{t_{relax}}\right) - !% \end{displaymath} - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine BONDLENGTH_DEV_POW(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: ri, rf, p, t0, tau - real(dp) :: dr(3), cur_d, diff, efact, norm_dr - integer :: i - - if(size(pos) /= 6) call system_abort('BONDLENGTH_DEV_POW: Exactly 2 atoms must be specified') - if(size(velo) /= 6) call system_abort('BONDLENGTH_DEV_POW: Exactly 2 atoms must be specified') - if(size(mass) /= 2) call system_abort('BONDLENGTH_DEV_POW: Exactly 2 atoms must be specified') - if(size(data) /= 5) call system_abort('BONDLENGTH_DEV_POW: "data" must contain exactly five values') - - ri = data(1) - rf = data(2) - p = data(3) - t0 = data(4) - tau = data(5) - - dr = pos(1:3)-pos(4:6) - diff = ri - rf - efact = exp(-(t-t0)/tau) - cur_d = rf + diff * efact - - norm_dr = norm(dr) - C = (norm_dr-cur_d)**p - target_v = cur_d - dC_dr(1:3) = p*(norm_dr-cur_d)**(p-1.0_dp)*dr/norm_dr - dC_dr(4:6) = -p*(norm_dr-cur_d)**(p-1.0_dp)*dr/norm_dr - dC_dt = (dC_dr .dot. velo) + p * (norm_dr-cur_d)**(p-1.0_dp) * diff * efact / tau - - dcoll_dr(1:6) = dC_dr(1:6) - Z_coll = 0._dp - do i=1,2 - Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) - enddo - - end subroutine BONDLENGTH_DEV_POW - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X CUBIC_BONDLENGTH_SQ: - !X - !% Constrain a bond length to the time dependent quantity - !% \begin{displaymath} - !% at^3 + bt^2 + ct + d - !% \end{displaymath} - !% where $t$ is clamped to the range $[t_{init},t_{final}]$ - !% - !% \begin{itemize} - !% \item 'data(1:4) = (/ a,b,c,d /)' - !% \item 'data(5) =' initial time $t_{init}$ - !% \item 'data(6) =' final time $t_{final}$ - !% \end{itemize} - !% - !% The constraint function is: - !% \begin{displaymath} - !% \begin{array}{l} - !% C = |\mathbf{r}_1 - \mathbf{r}_2|^2 - l^2 \\ l = at^3 + bt^2 + ct + d - !% \end{array} - !% \end{displaymath} - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine CUBIC_BONDLENGTH_SQ(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: r(3), t_clamped, l, dl_dt, x, x2, x3 - integer :: i - - if(size(pos) /= 6) call system_abort('CUBIC_BONDLENGTH_SQ: Exactly 2 atoms must be specified') - if(size(velo) /= 6) call system_abort('CUBIC_BONDLENGTH_SQ: Exactly 2 atoms must be specified') - if(size(mass) /= 2) call system_abort('CUBIC_BONDLENGTH_SQ: Exactly 2 atoms must be specified') - if(size(data) /= 6) call system_abort('CUBIC_BONDLENGTH_SQ: "data" must contain exactly six values') - - r = pos(1:3)-pos(4:6) - t_clamped = t - if (t_clamped > data(6)) then - t_clamped = data(6) - else if (t_clamped < data(5)) then - t_clamped = data(5) - end if - - x = t_clamped; x2 = x*x; x3 = x2 * x - l = data(1)*x3 + data(2)*x2 + data(3)*x + data(4) - dl_dt = 3.0_dp*data(1)*x2 + 2.0_dp*data(2)*x + data(3) - - C = normsq(r) - l*l - target_v = l*l - dC_dr(1:3) = 2.0_dp * r - dC_dr(4:6) = -2.0_dp * r - if (t >= data(5) .and. t <= data(6)) then - dC_dt = (dC_dr .dot. velo) - 2.0_dp * l * dl_dt - else - dC_dt = dC_dr .dot. velo - endif - - dcoll_dr(1:6) = dC_dr(1:6) - Z_coll = 0._dp - do i=1,2 - Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) - enddo - - end subroutine CUBIC_BONDLENGTH_SQ - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X PLANE - !X - !% Constrain a particle to the plane $ax+by+cz=d$. - !% 'data' should contain '(/a, b, c, d/)'. Periodic boundary conditions - !% are not applied (the plane only cuts the - !% cell once, if at all). - !% - !% The function used is $C = \mathbf{r} \cdot \hat{\mathbf{n}} - d$ - !% where $\mathbf{n} = (a,b,c)$ - !% - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine PLANE(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: d, n(3), n_hat(3) - integer :: i - - if(size(data) /= 4 ) call system_abort('PLANE: "data" must be of length 4') - if(size(pos) /= 3) call system_abort('PLANE: Exactly 1 atom must be specified') - if(size(velo) /= 3) call system_abort('PLANE: Exactly 1 atom must be specified') - if(size(mass) /= 1) call system_abort('PLANE: Exactly 1 atom must be specified') - - n = data(1:3) !Normal to the plane - n_hat = n / norm(n) !Unit normal - d = data(4) / norm(n) !Distance from plane to origin - C = (pos .dot. n_hat) - d !Distance of atom from plane - target_v = d - dC_dr = n_hat - dC_dt = dC_dr .dot. velo - - dcoll_dr(1:3) = dC_dr(1:3) - Z_coll = 0._dp - Z_coll = 1/mass(1) * normsq(dcoll_dr(1:3)) - - end subroutine PLANE - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X BONDLENGTH_DIFF: - !X - !% Constrain the difference of 2 bond length of 3 atoms. - !% The second atom is common in the 2 bonds. - !% 'data' should contain the required bond length - !% The minimum image convention is used. - !% - !% The function used is $C = |\mathbf{r}_1 - \mathbf{r}_2| - |\mathbf{r}_3 - \mathbf{r}_2| - d $ - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine BONDLENGTH_DIFF(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp), dimension(3) :: d1, d2 - real(dp) :: norm_d1,norm_d2 - integer :: i - real(dp) :: target_dd, target_dd_i, target_dd_f, t0, tau, efact - - if(size(pos) /= 9) call system_abort('BONDLENGTH_DIFF: Exactly 3 atoms must be specified') - if(size(velo) /= 9) call system_abort('BONDLENGTH_DIFF: Exactly 3 atoms must be specified') - if(size(mass) /= 3) call system_abort('BONDLENGTH_DIFF: Exactly 3 atoms must be specified') - if(size(data) /= 4) call system_abort('BONDLENGTH_DIFF: "data" must contain exactly four values') - - d1 = pos(1:3)-pos(4:6) - d2 = pos(7:9)-pos(4:6) - - norm_d1 = norm(d1) - norm_d2 = norm(d2) - - target_dd_i = data(1) - target_dd_f = data(2) - t0 = data(3) - tau = data(4) - efact = exp(-(t-t0)/tau) - target_dd = target_dd_f + (target_dd_i-target_dd_f)*efact - - C = norm_d1 - norm_d2 - target_dd - target_v = target_dd - - dC_dr(1:3) = d1(1:3) / norm_d1 - dC_dr(7:9) = - d2(1:3) / norm_d2 - dC_dr(4:6) = - dC_dr(1:3) - dC_dr(7:9) - - dC_dt = dC_dr .dot. velo + (target_dd_i-target_dd_f)*efact/tau - - dcoll_dr(1:9) = dC_dr(1:9) - Z_coll = 0._dp - do i=1,3 - Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) - enddo - - end subroutine BONDLENGTH_DIFF - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X GAP ENERGY: - !X - !% Constrain the GAP energy defined by two resonance structures, - !% where 1 bond breaks and/or another bond forms. - !% 'data' should contain the required value of the gap energy. - !% - !% The function used is $C = E_\mathbf{GAP} - data $ - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine GAP_ENERGY(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: E_GAP, EVB1_energy, EVB2_energy - real(dp), pointer :: EVB1_forces(:,:), EVB2_forces(:,:) - real(dp), dimension(size(pos)) :: F_GAP - type(atoms) :: dummy,dummy2 - type(InOutput) :: inoutfile - integer :: stat - integer :: i - real(dp) :: posmax, posmin - integer :: gap_energy_index, gap_energy_index1, gap_energy_index2 - integer :: num_fields - character(len=STRING_LENGTH) :: comment - character(len=STRING_LENGTH) :: fields(3) - logical :: exists - integer :: jobid - character(len=30) :: jobid_str - - !check if required properties are present - if (mod(size(pos),3)/=0) call system_abort("GAP_ENERGY: pos must have 3N coordinates") - if(size(data) /= 1) call system_abort('GAP_ENERGY: "data" must contain exactly one value') - - !print pos info into an xyz file (no lattice and species info) - posmax=maxval(pos) - posmin=minval(pos) - !CInoutPut is on a higher level, cannot call print_xyz and read_xyz - - !get $JOBID if running i/o on /tmp - jobid=0 - call get_env_var("JOBID", jobid_str, stat) - if (stat==0) read (jobid_str,*) jobid - - if (jobid>0) then - call system_command("mv /tmp/cp2k_run_"//jobid//"/only_pos.xyz /tmp/cp2k_run_"//jobid//"/only_pos.xyz.bak",stat) - call initialise(inoutfile,filename="/tmp/cp2k_run_"//jobid//"/only_pos.xyz",action=OUTPUT) - else - call system_command("mv only_pos.xyz only_pos.xyz.bak",stat) - call initialise(inoutfile,filename="only_pos.xyz",action=OUTPUT) - endif - call print((size(pos)/3),file=inoutfile) - call print('Lattice="'//(posmax-posmin)//' 0. 0. 0. '//(posmax-posmin)//' 0. 0. 0. '//(posmax-posmin)//'" Properties=species:S:1:pos:R:3',file=inoutfile) - do i=1,size(pos),3 - call print("H "//pos(i)//" "//pos(i+1)//" "//pos(i+2),file=inoutfile) - enddo - call finalise(inoutfile) - - !calc evb from an external filepot - if (jobid>0) then - call system_command("~/bin/egap_from_pos_tmp pos=/tmp/cp2k_run_"//jobid//"/only_pos.xyz only_GAP=T out=/tmp/cp2k_run_"//jobid//"/only_pos.out", status=stat) - else - call system_command("~/bin/egap_from_pos pos=only_pos.xyz only_GAP=T out=only_pos.out", status=stat) - endif - - !read evb forces and energies - !CInoutPut is on a higher level, cannot call print_xyz or read_xyz - if (jobid>0) then - inquire(file="/tmp/cp2k_run_"//jobid//"/only_pos.out", exist=exists) - if (.not.exists) call system_abort("No /tmp/cp2k_run_"//jobid//"/only_pos.out file found. EVB filepot probably aborted.") - call initialise(inoutfile,filename="/tmp/cp2k_run_"//jobid//"/only_pos.out",action=INPUT) - else - inquire(file="only_pos.out", exist=exists) - if (.not.exists) call system_abort("No only_pos.out file found. EVB filepot probably aborted.") - call initialise(inoutfile,filename="only_pos.out",action=INPUT) - endif - !Natoms - call parse_line(inoutfile," ",fields,num_fields,stat) - if (stat/=0) call system_abort("GAP_ENERGY: Something wrong while reaing only_pos.out number of atoms.") - if (num_fields>1) call system_abort("GAP_ENERGY: More information than GAP forces was found in only_pos.out.") - if (size(pos)/=3*string_to_int(fields(1))) call system_abort("GAP_ENERGY: Number of atoms mismatch.") - !comment - comment=read_line(inoutfile,stat) - if (stat/=0) call system_abort("GAP_ENERGY: Something wrong while reaing only_pos.out.") - !find gap energy - gap_energy_index=index(comment,"gap=") !find where "gap=..." starts - if (gap_energy_index/=0) then !not the first one - gap_energy_index=index(comment," gap=")+1 !find where "gap=..." starts - endif - if (gap_energy_index==0) call system_abort("GAP_ENERGY: Could not find gap energy in only_pos.out comment line.") - gap_energy_index1=index(comment(gap_energy_index:),"=") !find the position of "=" in "gap=..." - if (gap_energy_index1/=4) call system_abort("GAP_ENERGY: Something wrong with energy value in only_pos.out.") - gap_energy_index2=index(comment(gap_energy_index:)," ") !find the position of " " in "gap=..." - if (gap_energy_index2==0) then !it is at the end of line - E_GAP=string_to_real(comment((gap_energy_index+gap_energy_index1):)) !read from the character after "=" - else !there is something else behind - E_GAP=string_to_real(comment((gap_energy_index+gap_energy_index1):(gap_energy_index+gap_energy_index2-1))) !read from the character after "=" to the one before " " - endif - !GAP forces - do i=1,size(pos),3 - call parse_line(inoutfile," ",fields,num_fields,stat) - if (stat/=0) call system_abort("GAP_ENERGY: Something wrong while reaing only_pos.out.") - if (num_fields>3) call system_abort("GAP_ENERGY: More information than GAP forces was found in only_pos.out.") - F_GAP(i:i+2) = (/string_to_real(fields(1)),string_to_real(fields(2)),string_to_real(fields(3))/) - enddo - call finalise(inoutfile) - -!call print("GAP_ENERGY "//E_GAP) - C = E_GAP - data(1) - target_v = data(1) - - dC_dr(1:size(pos)) = -F_GAP(1:size(pos)) - - dC_dt = dC_dr .dot. velo - - dcoll_dr(1:size(pos)) = dC_dr(1:size(pos)) - Z_coll = 0._dp - do i=1,(size(pos)/3) - Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) - enddo - - call finalise(dummy) - call finalise(dummy2) - - end subroutine GAP_ENERGY - - subroutine PARABOLIC_FIT(x,afunc) - real(dp) :: x, afunc(:) - - afunc(1) = x*x - afunc(2) = x - afunc(3) = 1 - - end subroutine PARABOLIC_FIT - - subroutine LINEAR_FIT(x,afunc) - real(dp) :: x, afunc(:) - - afunc(1) = x*x - afunc(2) = x - afunc(3) = 1 - - end subroutine LINEAR_FIT - - - subroutine CRACK_TIP_CURVATURE(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: a(3), am(3), ap(3), chisq, a_target - real(dp), allocatable :: xp(:,:), xm(:,:), x(:,:), sig(:), da1_dR(:,:), da2_dR(:,:), da3_dR(:,:) - integer :: i, n, k, constraint_type - real(dp), parameter :: eps = 1e-4_dp - - n = size(pos)/3 - allocate(x(3,n), xp(3,n), xm(3,n), sig(n), da1_dR(3,n)) - sig(:) = 0.0_dp - x = reshape(pos, (/3,n/)) - a_target = data(1) ! target curvature - - call least_squares(x(2,:), x(1,:), sig, a, chisq, PARABOLIC_FIT) - call print('CRACK_TIP_CURVATURE coefficients '//a) - call print('CRACK_TIP_CURVATURE target '//a_target) - - do k=1,3 - do i=1,n - xp = x - xm = x - - xp(k,i) = xp(k,i) + eps - call least_squares(xp(2,:), xp(1,:), sig, ap, chisq, PARABOLIC_FIT) - - xm(k,i) = xm(k,i) - eps - call least_squares(xm(2,:), xm(1,:), sig, am, chisq, PARABOLIC_FIT) - - da1_dR(k,i) = (ap(1) - am(1))/(2.0_dp*eps) - end do - end do - - ! C = a - a_target - ! dC_dR = da_dR - C = a(1) - a_target - target_v = a_target - dC_dR = reshape(da1_dR, (/3*N/)) - call print('CRACK_TIP_CURVATURE C '//C) - call print('CRACK_TIP_CURVATURE dC_dR '//dC_dR) - - dC_dt = dC_dr .dot. velo - - end subroutine CRACK_TIP_CURVATURE - - subroutine CRACK_TIP_GRADIENT(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: a(2), am(2), ap(2), chisq, a_target - real(dp), allocatable :: xp(:,:), xm(:,:), x(:,:), sig(:), da1_dR(:,:), da2_dR(:,:), da3_dR(:,:) - integer :: i, n, k, constraint_type - real(dp), parameter :: eps = 1e-4_dp - - n = size(pos)/3 - allocate(x(3,n), xp(3,n), xm(3,n), sig(n), da1_dR(3,n)) - sig(:) = 0.0_dp - x = reshape(pos, (/3,n/)) - a_target = data(1) ! target gradient - - call least_squares(x(1,:), x(2,:), sig, a, chisq, LINEAR_FIT) - call print('CRACK_TIP_GRADIENT coefficients '//a) - call print('CRACK_TIP_GRADIENT target '//a_target) - - do k=1,3 - do i=1,n - xp = x - xm = x - - xp(k,i) = xp(k,i) + eps - call least_squares(xp(1,:), xp(2,:), sig, ap, chisq, LINEAR_FIT) - - xm(k,i) = xm(k,i) - eps - call least_squares(xm(1,:), xm(2,:), sig, am, chisq, LINEAR_FIT) - - da1_dR(k,i) = (ap(1) - am(1))/(2.0_dp*eps) - end do - end do - - ! C = a - a_target - ! dC_dR = da_dR - C = a(1) - a_target - target_v = a_target - dC_dR = reshape(da1_dR, (/3*N/)) - call print('CRACK_TIP_GRADIENT C '//C) - call print('CRACK_TIP_GRADIENT dC_dR '//dC_dR) - - dC_dt = dC_dr .dot. velo - - end subroutine CRACK_TIP_GRADIENT - - subroutine CRACK_TIP_POSITION(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - real(dp) :: a(3), am(3), ap(3), chisq, dC_da1, dC_da2, dC_da3, pos_target - real(dp), allocatable :: xp(:,:), xm(:,:), x(:,:), sig(:), da1_dR(:,:), da2_dR(:,:), da3_dR(:,:) - real(dp), parameter :: eps = 1e-4_dp - integer i, k, n - - n = size(pos)/3 - allocate(x(3,n), xp(3,n), xm(3,n), sig(n), da1_dR(3,n), da2_dR(3,n), da3_dR(3,n)) - sig(:) = 0.0_dp - x = reshape(pos, (/3,n/)) - pos_target = data(1) ! target position - - call least_squares(x(2,:), x(1,:), sig, a, chisq, PARABOLIC_FIT) - call print('CRACK_TIP_POSITION coefficients '//a) - call print('CRACK_TIP_POSITION target '//pos_target) - - do k=1,3 - do i=1,n - xp = x - xm = x - - xp(k,i) = xp(k,i) + eps - call least_squares(xp(2,:), xp(1,:), sig, ap, chisq, PARABOLIC_FIT) - - xm(k,i) = xm(k,i) - eps - call least_squares(xm(2,:), xm(1,:), sig, am, chisq, PARABOLIC_FIT) - - da1_dR(k,i) = (ap(1) - am(1))/(2.0_dp*eps) - da2_dR(k,i) = (ap(2) - am(2))/(2.0_dp*eps) - da3_dR(k,i) = (ap(3) - am(3))/(2.0_dp*eps) - - end do - end do - - ! C = y0 - pos_target - ! dC_dR = dC_da*da_dR + dC_db*db_dR + dC_dc*dc_dR - ! x0 = -b/2*a - ! y0 = a*x0**2 + b*x0 + c = c - b**2/(4*a) - C = (a(3) - a(2)**2/(4.0_dp*a(1))) - pos_target - target_v = pos_target - - dC_da1 = a(2)**2/(4.0_dp*a(1)**2) - dC_da2 = -a(2)/(2*a(1)) - dC_da3 = 1.0_dp - - dC_dR = dC_da1*reshape(da1_dR, (/3*N/)) + & - dC_da2*reshape(da2_dR, (/3*N/)) + & - dC_da3*reshape(da3_dR, (/3*N/)) - - dC_dt = dC_dr .dot. velo - - call print('CRACK_TIP_POSITION C '//C) - call print('CRACK_TIP_POSITION dC_dR '//dC_dR) - - end subroutine CRACK_TIP_POSITION - - subroutine STRUCT_FACTOR_LIKE_MAG(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - integer :: i, n - real(dp) :: target_SF_r, target_SF_i - real(dp) :: SF_Q(3), frac_pos(3), lattice_inv(3,3) - real(dp) :: SF_real, SF_imag, SF_mag - - if (size(data) /= 4) call system_abort("STRUCT_FACTOR_LIKE_MAG needs data of 3 q components and target value") - SF_Q(1:3) = data(1:3)*2.0_dp*PI - target_v = data(4) - - n = size(pos)/3 - - call matrix3x3_inverse(lattice, lattice_inv) - SF_real = 0.0_dp - SF_imag = 0.0_dp - do i=0, n-1 - frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) - SF_real = SF_real + cos(frac_pos .dot. SF_Q) - SF_imag = SF_imag + sin(frac_pos .dot. SF_Q) - end do - SF_real = SF_real/real(n,dp) - SF_imag = SF_imag/real(n,dp) - SF_mag = sqrt(SF_real**2 + SF_imag**2) - C = SF_mag - target_v - do i=0, n-1 - frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) - dC_dR(i*3+1:i*3+3) = (0.5_dp/SF_mag)*( & - -2.0_dp/real(n,dp)*SF_real*sin(frac_pos .dot. SF_Q)*matmul(SF_Q, lattice_inv) + & - 2.0_dp/real(n,dp)*SF_imag*cos(frac_pos .dot. SF_Q)*matmul(SF_Q, lattice_inv) ) - end do - - dC_dt = dC_dR .dot. velo - - call print ("STRUCT_FACTOR_LIKE_MAG SF "//SF_real//" "//SF_imag//" |SF| "//SF_mag) - - end subroutine STRUCT_FACTOR_LIKE_MAG - - subroutine STRUCT_FACTOR_LIKE_R(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - integer :: i, n - real(dp) :: target_SF_r, target_SF_i - real(dp) :: SF_Q(3), frac_pos(3), lattice_inv(3,3) - real(dp) :: SF_real - - if (size(data) /= 4) call system_abort("STRUCT_FACTOR_LIKE_R needs data of 3 q components and target value") - SF_Q(1:3) = data(1:3)*2.0_dp*PI - target_v = data(4) - - n = size(pos)/3 - - call matrix3x3_inverse(lattice, lattice_inv) - SF_real = 0.0_dp - do i=0, n-1 - frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) - SF_real = SF_real + cos(frac_pos .dot. SF_Q) - end do - SF_real = SF_real/real(n,dp) - C = SF_real - target_v - do i=0, n-1 - frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) - dC_dR(i*3+1:i*3+3) = -1.0_dp/real(n,dp)*sin(frac_pos .dot. SF_Q)*matmul(SF_Q, lattice_inv) - end do - - dC_dt = dC_dR .dot. velo - - call print ("STRUCT_FACTOR_LIKE_R SF "//SF_real) - - end subroutine STRUCT_FACTOR_LIKE_R - - subroutine STRUCT_FACTOR_LIKE_I(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) - - real(dp), dimension(:), intent(in) :: pos, velo, mass, data - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: t - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr - real(dp), intent(out) :: dC_dt, Z_coll - real(dp), intent(out) :: target_v - !local variables - integer :: i, n - real(dp) :: target_SF_r, target_SF_i - real(dp) :: SF_Q(3), frac_pos(3), lattice_inv(3,3) - real(dp) :: SF_imag - - if (size(data) /= 4) call system_abort("STRUCT_FACTOR_LIKE_I needs data of 3 q components and target value") - SF_Q(1:3) = data(1:3)*2.0_dp*PI - target_v = data(4) - - n = size(pos)/3 - - call matrix3x3_inverse(lattice, lattice_inv) - SF_imag = 0.0_dp - do i=0, n-1 - frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) - SF_imag = SF_imag + sin(frac_pos .dot. SF_Q) - end do - SF_imag = SF_imag/real(n,dp) - C = SF_imag - target_v - do i=0, n-1 - frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) - dC_dR(i*3+1:i*3+3) = 1.0_dp/real(n,dp)*cos(frac_pos .dot. SF_Q)*matmul(SF_Q, lattice_inv) - end do - - dC_dt = dC_dR .dot. velo - - call print ("STRUCT_FACTOR_LIKE_I "//SF_imag) - - end subroutine STRUCT_FACTOR_LIKE_I - - - subroutine add_restraint_forces(at, Nrestraints, restraints, t, f, E, store_restraint_force) - type(Atoms), intent(inout) :: at - integer, intent(in) :: Nrestraints - type(Constraint), intent(inout) :: restraints(:) - real(dp), intent(in) :: t - real(dp), intent(inout) :: f(:,:) - real(dp), optional, intent(inout) :: E - logical, optional :: store_restraint_force - - integer :: i_r, ii_a, i_a - logical :: do_store - real(dp), pointer :: constraint_force(:,:) - real(dp) :: restraint_E - real(dp) :: df(3) - - do_store = optional_default(.false., store_restraint_force) - - !Check for "constraint_force" property - if (do_store) then - if (assign_pointer(at,'constraint_force',constraint_force)) then - constraint_force = 0.0_dp - else - call system_abort('add_restraint_force: cannot find "constraint_force" property') - end if - end if - - restraint_E = 0.0_dp - do i_r=1, Nrestraints - if (restraints(i_r)%k < 0.0_dp) then - call system_abort("add_restraint_force for restraint " // i_r // " got invalid spring_constant " // restraints(i_r)%k) - endif - if (restraints(i_r)%k >= 0.0_dp) then - call constraint_calculate_values_at(restraints(i_r),at,t) - restraint_E = restraint_E + restraints(i_r)%E - do ii_a=1, restraints(i_r)%N - i_a = restraints(i_r)%atom(ii_a) - df = -restraints(i_r)%dE_dr((ii_a-1)*3+1:(ii_a-1)*3+3) - if (do_store) constraint_force(:,i_a) = constraint_force(:,i_a) + df - f(:,i_a) = f(:,i_a) + df - end do - endif - end do - - if (present(E)) E = E + restraint_E - if (do_store) call set_value(at%params, "restraint_energy", restraint_E) - end subroutine add_restraint_forces - -end module constraints_module diff --git a/src/libAtoms/Dictionary.f95 b/src/libAtoms/Dictionary.f95 deleted file mode 100644 index adcc11fe87..0000000000 --- a/src/libAtoms/Dictionary.f95 +++ /dev/null @@ -1,3198 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!% A Dictionary object contains a list of keys (strings) and corresponding entries. -!% Entries are a variable type, containing one of: -!% 'integer', 'real(dp)', 'complex(dp)', 'logical', extendable_str -!% or a 1-D array of any of those. 2-D arrays of integers and reals are also supported. - -#include "error.inc" - -module dictionary_module - - use error_module - use system_module - use linearalgebra_module - use mpi_context_module - use extendable_str_module - - implicit none - - private - - public :: T_NONE, T_INTEGER, T_REAL, T_COMPLEX, T_LOGICAL, & - T_INTEGER_A, T_REAL_A, T_COMPLEX_A, T_LOGICAL_A, & - T_CHAR, T_CHAR_A, T_DATA, T_INTEGER_A2, T_REAL_A2, T_DICT - integer, parameter :: & - T_NONE = 0, & - T_INTEGER = 1, T_REAL =2, T_COMPLEX = 3, T_LOGICAL=4, & - T_INTEGER_A = 5, T_REAL_A = 6, T_COMPLEX_A = 7, T_LOGICAL_A = 8, & - T_CHAR = 9, T_CHAR_A = 10, T_DATA = 11, T_INTEGER_A2 = 12, T_REAL_A2 = 13, T_DICT = 14 !% OMIT - - ! Maintained for backwards compatibility with old NetCDF files using type attribute - public :: PROPERTY_INT, PROPERTY_REAL, PROPERTY_STR, PROPERTY_LOGICAL - integer, parameter :: & - PROPERTY_INT = 1, PROPERTY_REAL = 2, PROPERTY_STR = 3, PROPERTY_LOGICAL = 4 - - public :: C_KEY_LEN, STRING_LENGTH, STRING_LENGTH_SHORT, DICT_N_FIELDS - integer, parameter :: C_KEY_LEN = 256 -#ifdef STRING_LENGTH_OVERRIDE - integer, parameter :: STRING_LENGTH = STRING_LENGTH_OVERRIDE !% Maximum string length -#else - integer, parameter :: STRING_LENGTH = 30000 !% Maximum string length -#endif - integer, parameter :: STRING_LENGTH_SHORT = 32 !% a shorter string length, for when there are LOTS of strings - integer, parameter :: DICT_N_FIELDS = 1000 !% Maximum number of fields during parsing - - public :: dictdata - type DictData - integer, dimension(:), allocatable :: d - end type DictData - - public :: dictentry - type DictEntry - !% OMIT - integer :: type = T_NONE - integer :: len = 1 - integer :: len2(2) = (/0, 0/) - - logical :: own_data = .true. !% True if we own the data and should free it in finalise() - - integer i - real(dp) r - complex(dp) c - logical l - type(extendable_str) s - - integer, pointer :: i_a(:) => null() - real(dp), pointer :: r_a(:) => null() - complex(dp), pointer :: c_a(:) => null() - logical, pointer :: l_a(:) => null() - character(len=1), pointer :: s_a(:,:) => null() - - integer, pointer :: i_a2(:,:) => null() - real(dp), pointer :: r_a2(:,:) => null() - - type(DictData) :: d - - end type DictEntry - - integer, parameter :: n_entry_block = 10 !% OMIT - - public Dictionary - type Dictionary - !% Fortran implementation of a dictionary to store key/value pairs of the following types: - !% - !% - Integer - !% - Real - !% - String - !% - Complex - !% - Logical - !% - 1D integer array - !% - 1D real array - !% - 1D complex array - !% - 1D logical array - !% - 2D integer array - !% - 2D real array - !% - Arbitrary data, via Fortran ``transform()`` intrinsic - - integer :: N = 0 !% number of entries in use - type(extendable_str), allocatable :: keys(:) !% array of keys - type(DictEntry), allocatable :: entries(:) !% array of entries - integer :: cache_invalid !% non-zero on exit from set_value(), set_value_pointer(), add_array(), remove_entry() if any array memory locations changed - integer :: key_cache_invalid !% non-zero on exit from set_value(), set_value_pointer(), add_array(), remove_entry() if any keys changed - end type Dictionary - - public c_dictionary_ptr_type - type c_dictionary_ptr_type - type(Dictionary), pointer :: p - end type c_dictionary_ptr_type - - !% Initialise a new empty dictionary - public initialise - interface initialise - module procedure dictionary_initialise - end interface initialise - - !% Finalise dictionary - public finalise - interface finalise - module procedure dictionary_finalise, dictentry_finalise - end interface finalise - - !% Print a DictEntry or a Dictionary - public print - interface print - module procedure dictentry_print, dictionary_print - end interface print - - public print_keys - interface print_keys - module procedure dictionary_print_keys - end interface print_keys - - !% Set a value in a Dictionary - public set_value - interface set_value - module procedure dictionary_set_value_none - module procedure dictionary_set_value_i, dictionary_set_value_r, dictionary_set_value_c, dictionary_set_value_l - module procedure dictionary_set_value_i_a, dictionary_set_value_r_a, dictionary_set_value_c_a, dictionary_set_value_l_a - module procedure dictionary_set_value_s, dictionary_set_value_s_es, dictionary_set_value_s_a2 - module procedure dictionary_set_value_s_a - module procedure dictionary_set_value_d - module procedure dictionary_set_value_i_a2 - module procedure dictionary_set_value_r_a2 - module procedure dictionary_set_value_dict - end interface set_value - - public set_value_pointer - interface set_value_pointer - module procedure dictionary_set_value_pointer_i - module procedure dictionary_set_value_pointer_r - module procedure dictionary_set_value_pointer_c - module procedure dictionary_set_value_pointer_l - module procedure dictionary_set_value_pointer_s - module procedure dictionary_set_value_pointer_i2 - module procedure dictionary_set_value_pointer_r2 - end interface set_value_pointer - - !% Get a value from a Dictionary - public get_value - interface get_value - module procedure dictionary_get_value_i, dictionary_get_value_r, dictionary_get_value_c, dictionary_get_value_l - module procedure dictionary_get_value_i_a, dictionary_get_value_r_a, dictionary_get_value_c_a, dictionary_get_value_l_a - module procedure dictionary_get_value_s, dictionary_get_value_s_es, dictionary_get_value_s_a, dictionary_get_value_s_a2 - module procedure dictionary_get_value_d - module procedure dictionary_get_value_i_a2 - module procedure dictionary_get_value_r_a2 - module procedure dictionary_get_value_dict - end interface get_value - - public assign_pointer - interface assign_pointer - module procedure dictionary_assign_pointer_r0 - module procedure dictionary_assign_pointer_i - module procedure dictionary_assign_pointer_r - module procedure dictionary_assign_pointer_c - module procedure dictionary_assign_pointer_l - module procedure dictionary_assign_pointer_s - module procedure dictionary_assign_pointer_i2 - module procedure dictionary_assign_pointer_r2 - end interface assign_pointer - - public add_array - interface add_array - module procedure dictionary_add_array_i - module procedure dictionary_add_array_r - module procedure dictionary_add_array_c - module procedure dictionary_add_array_l - module procedure dictionary_add_array_s - module procedure dictionary_add_array_i2 - module procedure dictionary_add_array_r2 - module procedure dictionary_add_array_i_a - module procedure dictionary_add_array_r_a - module procedure dictionary_add_array_c_a - module procedure dictionary_add_array_l_a - module procedure dictionary_add_array_s_a - module procedure dictionary_add_array_i2_a - module procedure dictionary_add_array_r2_a - end interface add_array - - !% Remove an entry from a Dictionary - public remove_value - interface remove_value - module procedure dictionary_remove_value - end interface remove_value - - !% Write a string representation of this dictionary - public write_string - interface write_string - module procedure dictionary_write_string - end interface write_string - - !% Read into this dictionary from a string - public read_string - interface read_string - module procedure dictionary_read_string - end interface read_string - - public subset - interface subset - module procedure dictionary_subset - module procedure dictionary_subset_es - end interface subset - - public swap - interface swap - module procedure dictionary_swap - end interface swap - - public has_key - interface has_key - module procedure dictionary_has_key - end interface has_key - - public bcast - interface bcast - module procedure dictionary_bcast - end interface bcast - - public expand_string - interface expand_string - module procedure dictionary_expand_string - end interface expand_string - - public deepcopy - interface deepcopy - module procedure dictionary_deepcopy - endinterface deepcopy - - public assignment(=) - interface assignment(=) - module procedure dictionary_deepcopy_no_error -#ifdef POINTER_COMPONENT_MANUAL_COPY - module procedure dictentry_assign - module procedure dictdata_assign -#endif - end interface assignment(=) - - public :: dictionary_get_key, dictionary_get_type_and_size, dictionary__array__, lookup_entry_i - -contains - - ! **************************************************************************** - ! * - ! * DictEntry methods - ! * - ! **************************************************************************** - - subroutine dictentry_print(this, key, verbosity, file) - type(DictEntry), intent(in) :: this - character(len=*), intent(in) :: key - integer, intent(in), optional :: verbosity - type(Inoutput), intent(inout), optional :: file - integer :: i, j - - if (this%type == T_NONE) then - call print("Dict entry NONE", verbosity, file) - else if (this%type == T_INTEGER) then - write (line,'("Dict entry integer ", A,1x,I0)') trim(key), this%i - call print(line, verbosity,file) - else if (this%type == T_REAL) then - write (line, '("Dict entry real ", A,1x,F30.20)') trim(key), this%r - call print(line, verbosity,file) - else if (this%type == T_COMPLEX) then - write (line,'("Dict entry complex ", A,1x,2F30.20)') trim(key), this%c - call print(line, verbosity,file) - else if (this%type == T_LOGICAL) then - write (line, '("Dict entry logical ", A,1x,L2)') trim(key), this%l - call print(line, verbosity,file) - else if (this%type == T_CHAR) then - write (line,'("Dict entry string ", A,1x,A)') trim(key), string(this%s) - call print(line, verbosity,file) - else if (this%type == T_INTEGER_A) then - write (line, '("Dict entry integer array ",A,1x,I0)') trim(key), size(this%i_a) - call print(line, verbosity,file) - call print(this%i_a, verbosity,file) - else if (this%type == T_REAL_A) then - write (line, '("Dict entry real array ",A,1x,I0)') trim(key), size(this%r_a) - call print(line, verbosity,file) - call print(this%r_a, verbosity,file) - else if (this%type == T_COMPLEX_A) then - write (line,'("Dict entry complex array ",A,1x,I0)') trim(key), size(this%c_a) - call print(line, verbosity,file) - call print(this%c_a,verbosity,file) - else if (this%type == T_LOGICAL_A) then - write (line,'("Dict entry logical array ",A,1x,I0)') trim(key), size(this%l_a) - call print(line, verbosity,file) - do i=1,size(this%l_a) - call print(this%l_a(i),verbosity,file) - end do - else if (this%type == T_CHAR_A) then - write (line,'("Dict entry string array ",A,1x,I0)') trim(key), size(this%s_a) - call print(line, verbosity,file) - do i=1,size(this%s_a,1) - do j=1,size(this%s_a,2) - call print(this%s_a(i,j),verbosity,file) - end do - end do - else if (this%type == T_INTEGER_A2) then - call print("Dict entry integer array "//shape(this%i_a2), verbosity,file) - call print(this%i_a2, verbosity,file) - else if (this%type == T_REAL_A2) then - call print("Dict entry real array "//shape(this%r_a2), verbosity,file) - call print(this%r_a2, verbosity,file) - else if (this%type == T_DATA .or. this%type == T_DICT) then - print '("Dict entry arbitary data ",A,1x,I0)', trim(key), size(this%d%d) - call print(line, verbosity,file) - endif - end subroutine dictentry_print - - subroutine dictionary_print_keys(this, verbosity, file) - type(Dictionary), intent(in) :: this - integer, intent(in), optional :: verbosity - type(Inoutput), intent(inout), optional :: file - - integer :: i - type(extendable_str) :: es - - call initialise(es) - do i=1,this%N - if (i < this%N) then - call concat(es, string(this%keys(i))//":") - else - call concat(es, string(this%keys(i))) - endif - end do - call print(es, verbosity=verbosity, file=file) - call finalise(es) - end subroutine dictionary_print_keys - - subroutine dictionary_print(this, verbosity, file) - type(Dictionary), intent(in) :: this - integer, intent(in), optional :: verbosity - type(Inoutput), intent(inout), optional :: file - type(extendable_str) :: str - - call print("Dictionary, allocated "// size(this%entries) //" n_entries " // this%N, verbosity=verbosity,file=file) - call print('', verbosity=verbosity,file=file) - call print(write_string(this,entry_sep=quip_new_line),verbosity=verbosity,file=file) - call finalise(str) - - end subroutine dictionary_print - - - ! **************************************************************************** - ! * - ! * Dictionary methods - ! * - ! **************************************************************************** - - subroutine dictionary_initialise(this) - type(Dictionary), intent(inout) :: this - - call finalise(this) - - call extend_entries(this, n_entry_block) - this%cache_invalid = 1 - this%key_cache_invalid = 1 - end subroutine dictionary_initialise - - subroutine dictionary_finalise(this) - type(Dictionary), intent(inout) :: this - - integer :: i - - ! Don't trust ifort to dellocate properly - if (allocated(this%entries)) then - ! only finalise entries up to this%n, not size(entries): - ! entries beyond this have been used in the past if some have now been removed, - ! but they won't point to any different data since remove_entry() does a shallow copy - do i=1,this%n -! call print('finalising entry i='//i//' key='//this%keys(i)//' type='//this%entries(i)%type) - call finalise(this%entries(i)) - end do - deallocate(this%entries) - end if - if (allocated(this%keys)) then - do i=1,size(this%keys) - call finalise(this%keys(i)) - end do - deallocate(this%keys) - end if - this%N = 0 - this%cache_invalid = 1 - this%key_cache_invalid = 1 - - end subroutine dictionary_finalise - - subroutine dictentry_finalise(this) - type(DictEntry), intent(inout) :: this - - if (allocated(this%d%d)) deallocate(this%d%d) - - if (.not. this%own_data) return - - if (associated(this%i_a)) deallocate(this%i_a) - this%i_a => null() - - if (associated(this%r_a)) deallocate(this%r_a) - this%r_a => null() - - if (associated(this%c_a)) deallocate(this%c_a) - this%c_a => null() - - if (associated(this%l_a)) deallocate(this%l_a) - this%l_a => null() - - if (associated(this%s_a)) deallocate(this%s_a) - this%s_a => null() - - if (associated(this%i_a2)) deallocate(this%i_a2) - this%i_a2 => null() - - if (associated(this%r_a2)) deallocate(this%r_a2) - this%r_a2 => null() - - call finalise(this%s) - - end subroutine dictentry_finalise - - subroutine dictionary_get_key(this, i, key, error) - type(Dictionary), intent(in) :: this - integer, intent(in) :: i - character(len=C_KEY_LEN), intent(out) :: key - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if (i < 1 .or. 1 > this%n) then - RAISE_ERROR('dictionary_get_key: index '//i//' out of range/', error) - end if - key = string(this%keys(i)) - - end subroutine dictionary_get_key - - subroutine dictionary_get_type_and_size(this, key, type, thesize, thesize2, error) - type(Dictionary), intent(in) :: this - character(len=*), intent(in) :: key - integer, intent(out) :: type, thesize, thesize2(2) - integer :: entry_i - integer, intent(out), optional :: error - - INIT_ERROR(error) - - entry_i = lookup_entry_i(this, key) - - if (entry_i <= 0) then - RAISE_ERROR('dictionary_get_type_and_size: key "'//key//'" not found', error) - end if - - type = this%entries(entry_i)%type - thesize = this%entries(entry_i)%len - thesize2 = this%entries(entry_i)%len2 - - end subroutine dictionary_get_type_and_size - - ! **************************************************************************** - ! * - ! * set_value() interface - ! * - ! **************************************************************************** - - subroutine dictionary_set_value_none(this, key) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_NONE - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - - end subroutine dictionary_set_value_none - - subroutine dictionary_set_value_i(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_INTEGER - entry%i = value - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - - end subroutine dictionary_set_value_i - - subroutine dictionary_set_value_r(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_REAL - entry%r = value - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - - end subroutine dictionary_set_value_r - - subroutine dictionary_set_value_c(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - complex(dp), intent(in) :: value - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_COMPLEX - entry%c = value - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - - end subroutine dictionary_set_value_c - - subroutine dictionary_set_value_l(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - logical, intent(in) :: value - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_LOGICAL - entry%l = value - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - - end subroutine dictionary_set_value_l - - subroutine dictionary_set_value_s(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_CHAR - call initialise(entry%s) - call concat(entry%s, value) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - - end subroutine dictionary_set_value_s - - subroutine dictionary_set_value_s_es(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - type(extendable_str), intent(in) :: value - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_CHAR - call initialise(entry%s, value) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - - end subroutine dictionary_set_value_s_es - - subroutine dictionary_set_value_i_a(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value(:) - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc - - entry%type = T_INTEGER_A - entry%len = size(value) - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%i_a(size(value))) - this%cache_invalid = 1 - end if - this%entries(entry_i)%i_a = value - call finalise(entry) - - - end subroutine dictionary_set_value_i_a - - subroutine dictionary_set_value_r_a(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value(:) - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc - - entry%type = T_REAL_A - entry%len = size(value) - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%r_a(size(value))) - this%cache_invalid = 1 - end if - this%entries(entry_i)%r_a = value - call finalise(entry) - - end subroutine dictionary_set_value_r_a - - subroutine dictionary_set_value_i_a2(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value(:,:) - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc - - entry%type = T_INTEGER_A2 - entry%len = 0 - entry%len2 = shape(value) - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%i_a2(size(value,1),size(value,2))) - this%cache_invalid = 1 - end if - this%entries(entry_i)%i_a2 = value - call finalise(entry) - - end subroutine dictionary_set_value_i_a2 - - subroutine dictionary_set_value_r_a2(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value(:,:) - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc - - entry%type = T_REAL_A2 - entry%len = 0 - entry%len2 = shape(value) - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%r_a2(size(value,1),size(value,2))) - this%cache_invalid = 1 - end if - this%entries(entry_i)%r_a2 = value - call finalise(entry) - - end subroutine dictionary_set_value_r_a2 - - subroutine dictionary_set_value_c_a(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - complex(dp), intent(in) :: value(:) - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc - - entry%type = T_COMPLEX_A - entry%len = size(value) - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%c_a(size(value))) - this%cache_invalid = 1 - end if - this%entries(entry_i)%c_a = value - call finalise(entry) - - end subroutine dictionary_set_value_c_a - - subroutine dictionary_set_value_l_a(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - logical, intent(in) :: value(:) - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc - - entry%type = T_LOGICAL_A - entry%len = size(value) - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%l_a(size(value))) - this%cache_invalid = 1 - end if - this%entries(entry_i)%l_a = value - call finalise(entry) - - end subroutine dictionary_set_value_l_a - - subroutine dictionary_set_value_s_a(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value(:) - - type(DictEntry) entry - integer entry_i, i, j - logical new_key - logical do_alloc - - entry%type = T_CHAR_A - entry%len = 0 - entry%len2 = (/len(value(1)), size(value) /) - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%s_a(entry%len2(1), entry%len2(2))) - this%cache_invalid = 1 - end if - do i=1,entry%len2(1) - do j=1,entry%len2(2) - this%entries(entry_i)%s_a(i,j) = value(j)(i:i) - end do - end do - call finalise(entry) - - end subroutine dictionary_set_value_s_a - - subroutine dictionary_set_value_s_a2(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - character, intent(in) :: value(:,:) - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc - - entry%type = T_CHAR_A - entry%len = 0 - entry%len2 = shape(value) - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%s_a(entry%len2(1), entry%len2(2))) - this%cache_invalid = 1 - end if - this%entries(entry_i)%s_a = value - call finalise(entry) - - end subroutine dictionary_set_value_s_a2 - - subroutine dictionary_set_value_d(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - type(DictData), intent(in) :: value - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_DATA - entry%d = value - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_d - - - subroutine dictionary_set_value_dict(this, key, value) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - type(Dictionary), intent(in) :: value - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_DICT - allocate(entry%d%d(size(transfer(value,entry%d%d)))) - entry%d%d = transfer(value, entry%d%d) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_dict - - - ! **************************************************************************** - ! * - ! * get_value() interface - ! * - ! **************************************************************************** - - function dictionary_get_value_i(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - integer, intent(out) :: v - logical :: dictionary_get_value_i - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_i = .false. - return - endif - - if (this%entries(entry_i)%type == T_INTEGER) then - v = this%entries(entry_i)%i - dictionary_get_value_i = .true. - else - dictionary_get_value_i = .false. - endif - end function dictionary_get_value_i - - function dictionary_get_value_r(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - real(dp), intent(out) :: v - logical :: dictionary_get_value_r - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_r = .false. - return - endif - - if (this%entries(entry_i)%type == T_REAL) then - v = this%entries(entry_i)%r - dictionary_get_value_r = .true. - else - dictionary_get_value_r = .false. - endif - end function dictionary_get_value_r - - - function dictionary_get_value_c(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - complex(dp), intent(out) :: v - logical :: dictionary_get_value_c - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_c = .false. - return - endif - - if (this%entries(entry_i)%type == T_COMPLEX) then - v = this%entries(entry_i)%c - dictionary_get_value_c = .true. - else - dictionary_get_value_c = .false. - endif - end function dictionary_get_value_c - - function dictionary_get_value_l(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - logical, intent(out) :: v - logical :: dictionary_get_value_l - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_l = .false. - return - endif - - if (this%entries(entry_i)%type == T_LOGICAL) then - v = this%entries(entry_i)%l - dictionary_get_value_l = .true. - else - dictionary_get_value_l = .false. - endif - end function dictionary_get_value_l - - - function dictionary_get_value_s(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - character(len=*), intent(out) :: v - logical :: dictionary_get_value_s - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_s = .false. - return - endif - - v="" ! fill with blanks first - if (this%entries(entry_i)%type == T_CHAR) then - v(1:this%entries(entry_i)%s%len) = string(this%entries(entry_i)%s) - dictionary_get_value_s = .true. - else - dictionary_get_value_s = .false. - endif - end function dictionary_get_value_s - - function dictionary_get_value_s_es(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - type(extendable_str), intent(out) :: v - logical :: dictionary_get_value_s_es - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_s_es = .false. - return - endif - - if (this%entries(entry_i)%type == T_CHAR) then - call initialise(v, this%entries(entry_i)%s) - dictionary_get_value_s_es = .true. - else - dictionary_get_value_s_es = .false. - endif - - end function dictionary_get_value_s_es - - - function dictionary_get_value_i_a(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - integer, intent(out) :: v(:) - logical :: dictionary_get_value_i_a - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_i_a = .false. - return - endif - - if (this%entries(entry_i)%type == T_INTEGER_A) then - if (size(v) >= size(this%entries(entry_i)%i_a)) then - v(1:size(this%entries(entry_i)%i_a)) = this%entries(entry_i)%i_a - dictionary_get_value_i_a = .true. - else - dictionary_get_value_i_a = .false. - endif - else - dictionary_get_value_i_a = .false. - endif - end function dictionary_get_value_i_a - - function dictionary_get_value_r_a(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - real(dp), intent(out) :: v(:) - logical :: dictionary_get_value_r_a - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_r_a = .false. - return - endif - - if (this%entries(entry_i)%type == T_REAL_A) then - if (size(v) >= size(this%entries(entry_i)%r_a)) then - v(1:size(this%entries(entry_i)%r_a)) = this%entries(entry_i)%r_a - dictionary_get_value_r_a = .true. - else - dictionary_get_value_r_a = .false. - endif - else - dictionary_get_value_r_a = .false. - endif - end function dictionary_get_value_r_a - - function dictionary_get_value_i_a2(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - integer, intent(out) :: v(:,:) - logical :: dictionary_get_value_i_a2 - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_i_a2 = .false. - return - endif - - if (this%entries(entry_i)%type == T_INTEGER_A2) then - if (size(v,1) >= size(this%entries(entry_i)%i_a2,1) .and. & - size(v,2) >= size(this%entries(entry_i)%i_a2,2)) then - v(1:size(this%entries(entry_i)%i_a2,1),1:size(this%entries(entry_i)%i_a2,2)) = this%entries(entry_i)%i_a2 - dictionary_get_value_i_a2 = .true. - else - dictionary_get_value_i_a2 = .false. - endif - else - dictionary_get_value_i_a2 = .false. - endif - end function dictionary_get_value_i_a2 - - function dictionary_get_value_r_a2(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - real(dp), intent(out) :: v(:,:) - logical :: dictionary_get_value_r_a2 - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_r_a2 = .false. - return - endif - - if (this%entries(entry_i)%type == T_REAL_A2) then - if (size(v,1) >= size(this%entries(entry_i)%r_a2,1) .and. & - size(v,2) >= size(this%entries(entry_i)%r_a2,2) ) then - v(1:size(this%entries(entry_i)%r_a2,1),1:size(this%entries(entry_i)%r_a2,2)) = this%entries(entry_i)%r_a2 - dictionary_get_value_r_a2 = .true. - else - dictionary_get_value_r_a2 = .false. - endif - else - dictionary_get_value_r_a2 = .false. - endif - end function dictionary_get_value_r_a2 - - - function dictionary_get_value_c_a(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - complex(dp), intent(out) :: v(:) - logical :: dictionary_get_value_c_a - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_c_a = .false. - return - endif - - if (this%entries(entry_i)%type == T_COMPLEX_A) then - if (size(v) >= size(this%entries(entry_i)%c_a)) then - v(1:size(this%entries(entry_i)%c_a)) = this%entries(entry_i)%c_a - dictionary_get_value_c_a = .true. - else - dictionary_get_value_c_a = .false. - endif - else - dictionary_get_value_c_a = .false. - endif - end function dictionary_get_value_c_a - - function dictionary_get_value_l_a(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - logical, intent(out) :: v(:) - logical :: dictionary_get_value_l_a - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_l_a = .false. - return - endif - - if (this%entries(entry_i)%type == T_LOGICAL_A) then - if (size(v) >= size(this%entries(entry_i)%l_a)) then - v(1:size(this%entries(entry_i)%l_a)) = this%entries(entry_i)%l_a - dictionary_get_value_l_a = .true. - else - dictionary_get_value_l_a = .false. - endif - else - dictionary_get_value_l_a = .false. - endif - end function dictionary_get_value_l_a - - - function dictionary_get_value_s_a(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - character(len=*), intent(out) :: v(:) - logical :: dictionary_get_value_s_a - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i, j, k - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_s_a = .false. - return - endif - - if (this%entries(entry_i)%type == T_CHAR_A) then - if (len(v(1)) >= size(this%entries(entry_i)%s_a,1) .and. size(v) >= size(this%entries(entry_i)%s_a,2)) then - do k=1,this%entries(entry_i)%len2(1) - do j=1,this%entries(entry_i)%len2(2) - v(j)(k:k) = this%entries(entry_i)%s_a(k,j) - end do - end do - dictionary_get_value_s_a = .true. - else - dictionary_get_value_s_a = .false. - endif - else - dictionary_get_value_s_a = .false. - endif - end function dictionary_get_value_s_a - - function dictionary_get_value_s_a2(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - character, intent(out) :: v(:,:) - logical :: dictionary_get_value_s_a2 - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_s_a2 = .false. - return - endif - - if (this%entries(entry_i)%type == T_CHAR_A) then - if (size(v,1) >= size(this%entries(entry_i)%s_a,1) .and. size(v,2) >= size(this%entries(entry_i)%s_a,2)) then - v(1:size(this%entries(entry_i)%s_a,1),1:size(this%entries(entry_i)%s_a,2)) = this%entries(entry_i)%s_a - dictionary_get_value_s_a2 = .true. - else - dictionary_get_value_s_a2 = .false. - endif - else - dictionary_get_value_s_a2 = .false. - endif - - end function dictionary_get_value_s_a2 - - - function dictionary_get_value_d(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - type(DictData), intent(out) :: v - logical :: dictionary_get_value_d - logical, optional :: case_sensitive - integer, optional :: i - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_d = .false. - return - endif - - if (this%entries(entry_i)%type == T_DATA) then - v = this%entries(entry_i)%d - dictionary_get_value_d = .true. - else - dictionary_get_value_d = .false. - endif - end function dictionary_get_value_d - - function dictionary_get_value_dict(this, key, v, case_sensitive, i) - type(Dictionary), intent(in) :: this - character(len=*) key - type(Dictionary), intent(out) :: v - logical :: dictionary_get_value_dict - logical, optional :: case_sensitive - integer, optional :: i - - type(dictionary) :: tmp_dict - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - if (present(i)) i = entry_i - - if (entry_i <= 0) then - dictionary_get_value_dict = .false. - return - endif - - if (this%entries(entry_i)%type == T_DICT) then - ! bug: overloaded assignment operator is invoked - call initialise(tmp_dict) - tmp_dict = transfer(this%entries(entry_i)%d%d, v) - v = tmp_dict - call finalise(tmp_dict) - dictionary_get_value_dict = .true. - else - dictionary_get_value_dict = .false. - endif - end function dictionary_get_value_dict - - - - ! **************************************************************************** - ! * - ! * assign_pointer() interface - ! * - ! **************************************************************************** - - function dictionary_assign_pointer_r0(this, key, v, case_sensitive) - type(Dictionary), intent(in), target :: this - character(len=*) key - real(dp), intent(out), pointer :: v - logical :: dictionary_assign_pointer_r0 - logical, optional :: case_sensitive - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - - if (entry_i <= 0) then - dictionary_assign_pointer_r0 = .false. - return - endif - - if (this%entries(entry_i)%type == T_REAL) then - v => this%entries(entry_i)%r - dictionary_assign_pointer_r0 = .true. - else - dictionary_assign_pointer_r0 = .false. - endif - end function dictionary_assign_pointer_r0 - - function dictionary_assign_pointer_i(this, key, v, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) key - integer, intent(out), pointer, dimension(:) :: v - logical :: dictionary_assign_pointer_i - logical, optional :: case_sensitive - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - - if (entry_i <= 0) then - dictionary_assign_pointer_i = .false. - return - endif - - if (this%entries(entry_i)%type == T_INTEGER_A) then - v => this%entries(entry_i)%i_a - dictionary_assign_pointer_i = .true. - else - dictionary_assign_pointer_i = .false. - endif - end function dictionary_assign_pointer_i - - function dictionary_assign_pointer_r(this, key, v, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) key - real(dp), intent(out), pointer, dimension(:) :: v - logical :: dictionary_assign_pointer_r - logical, optional :: case_sensitive - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - - if (entry_i <= 0) then - dictionary_assign_pointer_r = .false. - return - endif - - if (this%entries(entry_i)%type == T_REAL_A) then - v => this%entries(entry_i)%r_a - dictionary_assign_pointer_r = .true. - else - dictionary_assign_pointer_r = .false. - endif - end function dictionary_assign_pointer_r - - function dictionary_assign_pointer_c(this, key, v, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) key - complex(dp), intent(out), pointer, dimension(:) :: v - logical :: dictionary_assign_pointer_c - logical, optional :: case_sensitive - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - - if (entry_i <= 0) then - dictionary_assign_pointer_c = .false. - return - endif - - if (this%entries(entry_i)%type == T_COMPLEX_A) then - v => this%entries(entry_i)%c_a - dictionary_assign_pointer_c = .true. - else - dictionary_assign_pointer_c = .false. - endif - end function dictionary_assign_pointer_c - - function dictionary_assign_pointer_l(this, key, v, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) key - logical, intent(out), pointer, dimension(:) :: v - logical :: dictionary_assign_pointer_l - logical, optional :: case_sensitive - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - - if (entry_i <= 0) then - dictionary_assign_pointer_l = .false. - return - endif - - if (this%entries(entry_i)%type == T_LOGICAL_A) then - v => this%entries(entry_i)%l_a - dictionary_assign_pointer_l = .true. - else - dictionary_assign_pointer_l = .false. - endif - end function dictionary_assign_pointer_l - - function dictionary_assign_pointer_s(this, key, v, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) key - character(1), intent(out), pointer, dimension(:,:) :: v - logical :: dictionary_assign_pointer_s - logical, optional :: case_sensitive - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - - if (entry_i <= 0) then - dictionary_assign_pointer_s = .false. - return - endif - - if (this%entries(entry_i)%type == T_CHAR_A) then - v => this%entries(entry_i)%s_a - dictionary_assign_pointer_s = .true. - else - dictionary_assign_pointer_s = .false. - endif - end function dictionary_assign_pointer_s - - function dictionary_assign_pointer_i2(this, key, v, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) key - integer, intent(out), pointer, dimension(:,:) :: v - logical :: dictionary_assign_pointer_i2 - logical, optional :: case_sensitive - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - - if (entry_i <= 0) then - dictionary_assign_pointer_i2 = .false. - return - endif - - if (this%entries(entry_i)%type == T_INTEGER_A2) then - v => this%entries(entry_i)%i_a2 - dictionary_assign_pointer_i2 = .true. - else - dictionary_assign_pointer_i2 = .false. - endif - end function dictionary_assign_pointer_i2 - - function dictionary_assign_pointer_r2(this, key, v, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) key - real(dp), intent(out), pointer, dimension(:,:) :: v - logical :: dictionary_assign_pointer_r2 - logical, optional :: case_sensitive - - integer entry_i - - entry_i = lookup_entry_i(this, key, case_sensitive) - - if (entry_i <= 0) then - dictionary_assign_pointer_r2 = .false. - return - endif - - if (this%entries(entry_i)%type == T_REAL_A2) then - v => this%entries(entry_i)%r_a2 - dictionary_assign_pointer_r2 = .true. - else - dictionary_assign_pointer_r2 = .false. - endif - end function dictionary_assign_pointer_r2 - - - ! **************************************************************************** - ! * - ! * set_value_pointer() interface - ! * - ! **************************************************************************** - - subroutine dictionary_set_value_pointer_i(this, key, ptr) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in), target :: ptr(:) - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_INTEGER_A - entry%own_data = .false. ! force any possible previous entry with same key to be finalised - entry%len = size(ptr) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - this%entries(entry_i)%i_a => ptr - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_pointer_i - - subroutine dictionary_set_value_pointer_r(this, key, ptr) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in), target :: ptr(:) - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_REAL_A - entry%own_data = .false. ! force any possible previous entry with same key to be finalised - entry%len = size(ptr) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - this%entries(entry_i)%r_a => ptr - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_pointer_r - - subroutine dictionary_set_value_pointer_c(this, key, ptr) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - complex(dp), intent(in), target :: ptr(:) - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_COMPLEX_A - entry%own_data = .false. ! force any possible previous entry with same key to be finalised - entry%len = size(ptr) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - this%entries(entry_i)%c_a => ptr - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_pointer_c - - subroutine dictionary_set_value_pointer_l(this, key, ptr) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - logical, intent(in), target :: ptr(:) - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_LOGICAL_A - entry%own_data = .false. ! force any possible previous entry with same key to be finalised - entry%len = size(ptr) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - this%entries(entry_i)%l_a => ptr - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_pointer_l - - subroutine dictionary_set_value_pointer_s(this, key, ptr) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - character(1), intent(in), target :: ptr(:,:) - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_CHAR_A - entry%own_data = .false. ! force any possible previous entry with same key to be finalised - entry%len = 0 - entry%len2 = size(ptr) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - this%entries(entry_i)%s_a => ptr - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_pointer_s - - subroutine dictionary_set_value_pointer_i2(this, key, ptr) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in), target :: ptr(:,:) - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_INTEGER_A2 - entry%own_data = .false. ! force any possible previous entry with same key to be finalised - entry%len = 0 - entry%len2 = shape(ptr) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - this%entries(entry_i)%i_a2 => ptr - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_pointer_i2 - - subroutine dictionary_set_value_pointer_r2(this, key, ptr) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in), target :: ptr(:,:) - - type(DictEntry) entry - integer entry_i - logical new_key - - entry%type = T_REAL_A2 - entry%own_data = .false. ! force any possible previous entry with same key to be finalised - entry%len = 0 - entry%len2 = shape(ptr) - entry_i = add_entry(this, key, entry, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - this%entries(entry_i)%r_a2 => ptr - call finalise(entry) - this%cache_invalid = 1 - - end subroutine dictionary_set_value_pointer_r2 - - - ! **************************************************************************** - ! * - ! * add_array() interface - ! * - ! **************************************************************************** - - subroutine dictionary_add_array_i(this, key, value, len, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value - integer, intent(in) :: len - integer, pointer, optional, intent(out) :: ptr(:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_INTEGER_A - entry%len = len - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%i_a(len)) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%i_a(:) = value - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%i_a - - end subroutine dictionary_add_array_i - - subroutine dictionary_add_array_r(this, key, value, len, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value - integer, intent(in) :: len - real(dp), intent(out), pointer, optional :: ptr(:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_REAL_A - entry%len = len - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%r_a(len)) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%r_a(:) = value - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%r_a - - end subroutine dictionary_add_array_r - - subroutine dictionary_add_array_c(this, key, value, len, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - complex(dp), intent(in) :: value - integer, intent(in) :: len - complex(dp), pointer, optional, intent(out) :: ptr(:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_COMPLEX_A - entry%len = len - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%c_a(len)) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%c_a(:) = value - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%c_a - - end subroutine dictionary_add_array_c - - subroutine dictionary_add_array_l(this, key, value, len, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - logical, intent(in) :: value - integer, intent(in) :: len - logical, pointer, optional, intent(out) :: ptr(:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_LOGICAL_A - entry%len = len - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%l_a(len)) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%l_a(:) = value - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%l_a - - end subroutine dictionary_add_array_l - - subroutine dictionary_add_array_s(this, key, value, len2, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - character(1), intent(in) :: value - integer, intent(in) :: len2(2) - character(1), pointer, optional, intent(out) :: ptr(:,:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_CHAR_A - entry%len = 0 - entry%len2 = len2 - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%s_a(len2(1),len2(2))) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%s_a(:,:) = value - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%s_a - - end subroutine dictionary_add_array_s - - subroutine dictionary_add_array_i2(this, key, value, len2, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value - integer, intent(in) :: len2(2) - integer, pointer, optional, intent(out) :: ptr(:,:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_INTEGER_A2 - entry%len = 0 - entry%len2 = len2 - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%i_a2(len2(1),len2(2))) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%i_a2(:,:) = value - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%i_a2 - - end subroutine dictionary_add_array_i2 - - subroutine dictionary_add_array_r2(this, key, value, len2, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value - integer, intent(in) :: len2(2) - real(dp), intent(out), pointer, optional :: ptr(:,:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_REAL_A2 - entry%len = 0 - entry%len2 = len2 - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%r_a2(len2(1),len2(2))) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%r_a2(:,:) = value - call finalise(entry) - - if (present(ptr)) ptr => this%entries(entry_i)%r_a2 - - end subroutine dictionary_add_array_r2 - - - subroutine dictionary_add_array_i_a(this, key, value, len, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value(:) - integer, intent(in) :: len - integer, pointer, optional, intent(out) :: ptr(:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_INTEGER_A - entry%len = len - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%i_a(len)) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%i_a(:) = value - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%i_a - - end subroutine dictionary_add_array_i_a - - subroutine dictionary_add_array_r_a(this, key, value, len, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value(:) - integer, intent(in) :: len - real(dp), intent(out), pointer, optional :: ptr(:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_REAL_A - entry%len = len - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%r_a(len)) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%r_a(:) = value(:) - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%r_a - - end subroutine dictionary_add_array_r_a - - subroutine dictionary_add_array_c_a(this, key, value, len, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - complex(dp), intent(in) :: value(:) - integer, intent(in) :: len - complex(dp), pointer, optional, intent(out) :: ptr(:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_COMPLEX_A - entry%len = len - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%c_a(len)) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%c_a(:) = value(:) - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%c_a - - end subroutine dictionary_add_array_c_a - - subroutine dictionary_add_array_l_a(this, key, value, len, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - logical, intent(in) :: value(:) - integer, intent(in) :: len - logical, pointer, optional, intent(out) :: ptr(:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_LOGICAL_A - entry%len = len - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%l_a(len)) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%l_a(:) = value(:) - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%l_a - - end subroutine dictionary_add_array_l_a - - subroutine dictionary_add_array_s_a(this, key, value, len2, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - character(1), intent(in) :: value(:,:) - integer, intent(in) :: len2(2) - character(1), pointer, optional, intent(out) :: ptr(:,:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_CHAR_A - entry%len = 0 - entry%len2 = len2 - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%s_a(len2(1),len2(2))) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%s_a(:,:) = value(:,:) - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%s_a - - end subroutine dictionary_add_array_s_a - - subroutine dictionary_add_array_i2_a(this, key, value, len2, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer, intent(in) :: value(:,:) - integer, intent(in) :: len2(2) - integer, pointer, optional, intent(out) :: ptr(:,:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_INTEGER_A2 - entry%len = 0 - entry%len2 = len2 - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%i_a2(len2(1),len2(2))) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%i_a2(:,:) = value(:,:) - call finalise(entry) - if (present(ptr)) ptr => this%entries(entry_i)%i_a2 - - end subroutine dictionary_add_array_i2_a - - subroutine dictionary_add_array_r2_a(this, key, value, len2, ptr, overwrite) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - real(dp), intent(in) :: value(:,:) - integer, intent(in) :: len2(2) - real(dp), intent(out), pointer, optional :: ptr(:,:) - logical, optional, intent(in) :: overwrite - - type(DictEntry) entry - integer entry_i - logical new_key - logical do_alloc, do_overwrite - - do_overwrite = optional_default(.false., overwrite) - entry%type = T_REAL_A2 - entry%len = 0 - entry%len2 = len2 - entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) - if (new_key) this%key_cache_invalid = 1 - if (do_alloc) then - allocate(this%entries(entry_i)%r_a2(len2(1),len2(2))) - this%cache_invalid = 1 - end if - if (do_alloc .or. do_overwrite) this%entries(entry_i)%r_a2(:,:) = value(:,:) - call finalise(entry) - - if (present(ptr)) ptr => this%entries(entry_i)%r_a2 - - end subroutine dictionary_add_array_r2_a - - ! **************************************************************************** - ! * - ! * Miscellaneous routines - ! * - ! **************************************************************************** - - subroutine dictionary_remove_value(this, key) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - integer entry_i - - entry_i = lookup_entry_i(this, key) - if (entry_i > 0) then - call remove_entry(this, entry_i) - else - call print("WARNING: dictionary_remove_value() could not find entry `"//key//"' in dictionary", PRINT_ANALYSIS) - end if - - end subroutine dictionary_remove_value - - subroutine dictionary_read_string(this, str, append, error) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: str - logical, optional, intent(in) :: append !% If true, append to dictionary (default false) - integer, intent(out), optional :: error - - logical :: do_append - character(len=STRING_LENGTH) :: field - integer equal_pos - character(len=STRING_LENGTH), dimension(dict_n_fields) :: final_fields - character(len=C_KEY_LEN) :: key - character(len=STRING_LENGTH) :: value - integer :: i, num_pairs - - INIT_ERROR(error); - do_append = optional_default(.false., append) - - if (.not. do_append) then - call initialise(this) - end if - - call split_string(str, ' ,', '""'//"''"//'{}', final_fields, num_pairs, matching=.true.) - - ! Set the new entries - do i=1,num_pairs - field = final_fields(i) - equal_pos = index(trim(field),'=') - if (equal_pos == 0) then - key=field - value='' - else if (equal_pos == 1) then - RAISE_ERROR("dictionary_read_string: Malformed field '"//trim(field)//"'", error) - else - key = field(1:equal_pos-1) - value = field(equal_pos+1:len(trim(field))) - endif - call print("dictionary_read_string: key='"//trim(key)//"' value='"//trim(value)//"'", PRINT_NERD) - - if (.not. dictionary_parse_value(this,key,value)) then - RAISE_ERROR('dictionary_read_string: error parsing '//trim(key)//'='//trim(value), error) - end if - - end do - - end subroutine dictionary_read_string - - - !% Parse a string corresponding to a dictionary value and - !% attempt to work out what type it should be, then set it - function dictionary_parse_value(this, key, strvalue, char_a_sep) result(status) - type(Dictionary), intent(inout) :: this - character(*), intent(in) :: key - character(*), intent(in) :: strvalue - character(1), optional, intent(in) :: char_a_sep - logical :: status - - character(len=STRING_LENGTH), dimension(dict_n_fields) :: fields - character(len=len(strvalue)) :: datastr, shapestr, myvalue - integer :: num_fields, i, j - real(dp) :: r - logical :: l, all_int, all_real, all_logical - type(DictData) :: data - integer, allocatable, dimension(:) :: i_a - real(dp), allocatable, dimension(:) :: r_a - logical, allocatable, dimension(:) :: l_a - integer, allocatable, dimension(:,:) :: i_a2 - real(dp), allocatable, dimension(:,:) :: r_a2 - character(1) :: my_char_a_sep - logical got_2d - integer shape_2d(2) - integer :: parse_status - integer :: error - - my_char_a_sep = optional_default(',',char_a_sep) - - ! First, let's check if value is arbitrary data, represented - ! as 'DATA"i1 i2 i3 i4"' with i1,i2, etc. integers - if (strvalue(1:4) == 'DATA') then - datastr = strvalue(5:len(trim(strvalue))) - call parse_string(datastr, ' ',fields, num_fields) - - allocate(data%d(num_fields)) - do j=1,num_fields - data%d(j) = string_to_int(fields(j),error) - if (error /= ERROR_NONE) then - CLEAR_ERROR(error) - status = .false. - return - end if - end do - - call set_value(this,key,data) - deallocate(data%d) - status = .true. - return - end if - - ! 2D arrays are represented with shape in ()s at beginning of value string - got_2d = .false. - if (strvalue(1:1) == '(') then - got_2d = .true. - shapestr = strvalue(2:index(strvalue,')')-1) - read (shapestr, *) shape_2d - myvalue = strvalue(index(strvalue,')')+1:len_trim(strvalue)) - else - myvalue = strvalue - end if - - ! Otherwise, start by splitting value into fields - call parse_string(myvalue, ' ', fields, num_fields, error=parse_status) - - if (parse_status /= 0) then - ! parsing failed, treat as string - call set_value(this,key,myvalue) - status = .true. - return - else if (num_fields == 0) then - ! Nothing there, so type is T_NONE - call set_value(this, key) - status = .true. - return - - else if (num_fields == 1) then - - ! Scalar data, try to guess type - - do i=1, len_trim(fields(1)) - if (fields(1)(i:i) == '/') then - ! slash is technically a delimiter, but we don't like that, so we'll call it a string manually (otherswise string_to_real will be confused) - call set_value(this,key,fields(1)) - status = .true. - return - endif - end do - - ! Is it an integer? - i = string_to_int(fields(1),error) - if (error == ERROR_NONE) then - call set_value(this, key, i) - status = .true. - return - end if - CLEAR_ERROR(error) - - ! Is it a logical? - l = string_to_logical(fields(1),error) - if (error == ERROR_NONE) then - call set_value(this, key, l) - status = .true. - return - endif - CLEAR_ERROR(error) - - ! How about a real? - r = string_to_real(fields(1),error) - if (error == ERROR_NONE) then - call set_value(this, key, r) - status = .true. - return - end if - CLEAR_ERROR(error) - - ! Add complex scalar here... - - ! Does it contain one or more array separator characters? - if (scan(fields(1),my_char_a_sep) /= 0) then - call parse_string(myvalue, my_char_a_sep, fields, num_fields) - call set_value(this,key,fields(1:num_fields)) - status = .true. - return - else - ! All else has failed, treat it as a single string - call set_value(this,key,fields(1)) - status = .true. - return - end if - - else - ! Array data, again have to guess type - - allocate(i_a(num_fields),r_a(num_fields),l_a(num_fields)) - - ! Are all fields integers? - all_int = .true. - do j=1,num_fields - i_a(j) = string_to_int(fields(j),error) - - if (error /= ERROR_NONE) then - CLEAR_ERROR(error) - all_int = .false. - exit ! Found something that's not an integer - end if - end do - - if (all_int) then - if (got_2d) then - allocate(i_a2(shape_2d(1), shape_2d(2))) - i_a2 = reshape(i_a, shape_2d) - call set_value(this,key,i_a2) - else - call set_value(this,key,i_a) - end if - status = .true. - deallocate(i_a,r_a,l_a) - if (allocated(i_a2)) deallocate(i_a2) - return - end if - - ! Are all fields logicals? - all_logical = .true. - do j=1,num_fields - l_a(j) = string_to_logical(fields(j),error) - if (error /= ERROR_NONE) then - CLEAR_ERROR(error) - all_logical = .false. - exit ! Found something that's not a logical - end if - end do - - if (all_logical) then - call set_value(this,key,l_a) - status = .true. - deallocate(i_a,r_a,l_a) - return - end if - - ! Are all fields real numbers? - all_real = .true. - do j=1,num_fields - r_a(j) = string_to_real(fields(j),error) - - if (error /= ERROR_NONE) then - CLEAR_ERROR(error) - all_real = .false. - exit - end if - end do - - if (all_real) then - if (got_2d) then - allocate(r_a2(shape_2d(1), shape_2d(2))) - r_a2 = reshape(r_a, shape_2d) - call set_value(this,key,r_a2) - else - call set_value(this,key,r_a) - end if - status = .true. - deallocate(i_a,r_a,l_a) - if (allocated(r_a2)) deallocate(r_a2) - return - end if - - ! Add complex array here... - - ! We're left with strings. Does it contain array seperator? - if (scan(myvalue,my_char_a_sep) /= 0) then - call parse_string(myvalue, my_char_a_sep, fields, num_fields) - call set_value(this,key,fields(1:num_fields)) - status = .true. - return - else - ! Fall back option: treat entire myvalue as single string - call set_value(this,key,myvalue) - status =.true. - return - end if - end if - - end function dictionary_parse_value - - function dictionary_write_string(this, real_format, entry_sep, char_a_sep, quote_char, error) - type(Dictionary), intent(in) :: this - character(len=*), optional, intent(in) :: real_format !% Output format for reals, default is 'f9.3' - character(1), optional, intent(in) :: entry_sep !% Entry seperator, default is single space - character(1), optional, intent(in) :: char_a_sep !% Output separator for character arrays, default is ',' - character(1), optional, intent(in) :: quote_char !% Character to use to quote output fields containing whitespace, default is '"' - type(extendable_str) :: str - character(len=STRING_LENGTH) :: dictionary_write_string - integer, intent(out), optional :: error - - integer :: i, j, k - character(1) :: my_char_a_sep, my_entry_sep, my_quote_char - character(255) :: my_real_format, tmp_string - - INIT_ERROR(error) - call initialise(str) - - my_real_format = optional_default('f9.3',real_format) - my_char_a_sep = optional_default(',',char_a_sep) - my_entry_sep = optional_default(' ',entry_sep) - my_quote_char = optional_default('"', quote_char) - - do i=1,this%N - - if (i == 1) then - call concat(str, string(this%keys(i))) - else - call concat(str, my_entry_sep//string(this%keys(i))) - end if - - if (this%entries(i)%type /= T_NONE) call concat(str, '=') - - select case(this%entries(i)%type) - - case(T_NONE) - ! no value to write - - case(T_INTEGER) - call concat(str, ''//this%entries(i)%i) - - case(T_REAL) - write (line,'('//my_real_format//')') this%entries(i)%r - call concat(str, trim(adjustl(line))) - - case(T_COMPLEX) - call concat(str, ''//this%entries(i)%c) - - case(T_LOGICAL) - call concat(str, ''//this%entries(i)%l) - - case(T_CHAR) - if (index(string(this%entries(i)%s), ' ') == 0) then - call concat(str, string(this%entries(i)%s)) - else - call concat(str, my_quote_char//string(this%entries(i)%s)//my_quote_char) - end if - - case(T_INTEGER_A) - call concat(str, my_quote_char//this%entries(i)%i_a//my_quote_char) - - case(T_REAL_A) - write (line, '('//size(this%entries(i)%r_a)//trim(my_real_format)//')') this%entries(i)%r_a - call concat(str, my_quote_char//trim(adjustl(line))//my_quote_char) - - case(T_COMPLEX_A) - call concat(str, my_quote_char//this%entries(i)%c_a//my_quote_char) - - case(T_LOGICAL_A) - call concat(str, my_quote_char//this%entries(i)%l_a//my_quote_char) - - case(T_CHAR_A) - call concat(str,my_quote_char) - do j=1,size(this%entries(i)%s_a,2) - tmp_string = '' - do k=1,size(this%entries(i)%s_a,1) - tmp_string(k:k) = this%entries(i)%s_a(k,j) - end do - call concat(str, trim(tmp_string)//my_char_a_sep) - end do - call concat(str,my_quote_char) - - case(T_INTEGER_A2) - call concat(str, my_quote_char//'('//shape(this%entries(i)%i_a2)//') ') - call concat(str, ' '//reshape(this%entries(i)%i_a2,(/size(this%entries(i)%i_a2)/))//my_quote_char) - - case(T_REAL_A2) - call concat(str, my_quote_char//'('//shape(this%entries(i)%r_a2)//') ') - call concat(str, reshape(this%entries(i)%r_a2,(/size(this%entries(i)%r_a2)/))//my_quote_char) - - case(T_DATA) - call concat(str, 'DATA'//my_quote_char//this%entries(i)%d%d//my_quote_char) - - case(T_DICT) - call concat(str, 'DATA'//my_quote_char//this%entries(i)%d%d//my_quote_char) - end select - end do - - if (str%len > len(dictionary_write_string)) then - RAISE_ERROR('dictionary_write_string: string too long (' // str%len // ' > ' // len(dictionary_write_string) // ')', error) - end if - - dictionary_write_string = ''//str - call finalise(str) - - end function dictionary_write_string - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !% OMIT - subroutine remove_entry(this, entry_i, error) - type(Dictionary), intent(inout) :: this - integer, intent(in) :: entry_i - integer, intent(out), optional :: error - integer i - - INIT_ERROR(error) - - if (entry_i <= 0 .or. entry_i > this%N) then - RAISE_ERROR("remove_entry: Called remove_entry with invalid entry number", error) - end if - - if (entry_i < this%N) then - do i=entry_i,this%n-1 - call dictionary_swap(this, string(this%keys(i)), string(this%keys(i+1))) - end do - endif - - call finalise(this%keys(this%n)) - call finalise(this%entries(this%n)) - - this%N = this%N - 1 - this%cache_invalid = 1 - this%key_cache_invalid = 1 - - end subroutine remove_entry - - !% OMIT - function add_entry(this, key, entry, array_alloc, new_key) result(entry_i) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key - type(DictEntry), intent(in) :: entry - logical, intent(out), optional :: array_alloc - logical, intent(out), optional :: new_key - - integer entry_i - - ! must test separately because size(this%entries) is undefined if allocated(this%entries) is false - if (.not. allocated(this%entries)) call extend_entries(this, n_entry_block) - if (this%N >= size(this%entries)) call extend_entries(this, n_entry_block) - - entry_i = lookup_entry_i(this, key) - if (present(new_key)) new_key = entry_i == -1 - if (present(array_alloc)) array_alloc = .true. - - if (entry_i > 0) then - ! we only free entry if new type/size/shape is incompatible with existing entry - ! or if new entry will not be allocated by us (i.e. entry%own_data == .false.) - if (.not. entry%own_data .or. & - this%entries(entry_i)%type == T_DATA .or. & - this%entries(entry_i)%type == T_DICT .or. & - this%entries(entry_i)%type /= entry%type .or. & - this%entries(entry_i)%len /= entry%len .or. & - any(this%entries(entry_i)%len2 /= entry%len2)) then - call finalise(this%entries(entry_i)) - this%entries(entry_i) = entry - else - if (present(array_alloc)) array_alloc = .false. - ! we're keeping allocation, so we overwrite only scalar components of entry - this%entries(entry_i)%type = entry%type - this%entries(entry_i)%len = entry%len - this%entries(entry_i)%len2 = entry%len2 - this%entries(entry_i)%i = entry%i - this%entries(entry_i)%r = entry%r - this%entries(entry_i)%c = entry%c - this%entries(entry_i)%l = entry%l - this%entries(entry_i)%s = entry%s - end if - else - this%N = this%N + 1 - entry_i = this%N - call initialise(this%keys(entry_i)) - call concat(this%keys(entry_i), key) - this%entries(entry_i) = entry - endif - end function add_entry - - - !% OMIT - subroutine extend_entries(this, n) - type(Dictionary), intent(inout) :: this - integer, intent(in) :: n - - type(DictEntry), allocatable :: t_entries(:) - type(Extendable_str), allocatable :: t_keys(:) - integer old_size -#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY - integer :: i -#endif - - - if (allocated(this%entries)) then - allocate(t_entries(size(this%entries))) - allocate(t_keys(size(this%entries))) -#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY - allocate(t_keys(size(this%keys))) - do i=1,size(this%entries) - t_entries(i) = this%entries(i) - t_keys(i) = this%keys(i) - end do -#else - t_entries = this%entries - t_keys = this%keys -#endif - - old_size = size(this%entries) - - deallocate(this%entries) - deallocate(this%keys) - - allocate(this%entries(old_size + n)) - allocate(this%keys(old_size + n)) - -#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY - do i=1, size(t_entries) - this%entries(i) = t_entries(i) - this%keys(i) = t_keys(i) - end do -#else - this%entries(1:this%N) = t_entries(1:this%N) - this%keys(1:this%N) = t_keys(1:this%N) -#endif - - if (allocated(t_entries)) deallocate(t_entries) - deallocate (t_keys) - else - allocate(this%entries(n)) - allocate(this%keys(n)) - this%N = 0 - endif - - end subroutine extend_entries - - !% OMIT - function lookup_entry_i(this, key, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) :: key - logical, optional :: case_sensitive - integer :: lookup_entry_i - - logical :: do_case_sensitive - integer i - - do_case_sensitive = optional_default(.false., case_sensitive) - - lookup_entry_i = -1 - do i=1, this%N - if(do_case_sensitive) then - if (string(this%keys(i)) == trim(key)) then - lookup_entry_i = i - return - endif - else - if (lower_case(string(this%keys(i))) == trim(lower_case(key))) then - lookup_entry_i = i - return - endif - end if - end do - end function lookup_entry_i - - !% Return true if 'key' is in Dictionary or false if not - function dictionary_has_key(this, key, case_sensitive) - type(Dictionary), intent(in) :: this - character(len=*) :: key - logical :: dictionary_has_key - logical, optional :: case_sensitive - - dictionary_has_key = lookup_entry_i(this, key, case_sensitive) /= -1 - - end function dictionary_has_key - - subroutine dictionary_subset(this, keys, out, case_sensitive, out_no_initialise, error) - type(Dictionary), intent(in) :: this - character(len=*), dimension(:) :: keys - type(Dictionary), intent(inout) :: out - logical, intent(in), optional :: case_sensitive, out_no_initialise - integer, intent(out), optional :: error - - type(extendable_str), dimension(:), allocatable :: tmp_keys - integer i - - INIT_ERROR(error) - - allocate(tmp_keys(size(keys))) - do i=1,size(keys) - call initialise(tmp_keys(i)) - call concat(tmp_keys(i), keys(i)) - end do - - call dictionary_subset_es(this, tmp_keys, out, case_sensitive, out_no_initialise, error) - PASS_ERROR(error) - - do i=1,size(tmp_keys) - call finalise(tmp_keys(i)) - end do - deallocate(tmp_keys) - - end subroutine dictionary_subset - - - !% Return a dictionary that is a subset of this in 'out' - !% with only the keys in the arrays 'keys' present. - subroutine dictionary_subset_es(this, keys, out, case_sensitive, out_no_initialise, error) - type(Dictionary), intent(in) :: this - type(extendable_str), dimension(:), intent(in) :: keys - type(Dictionary), intent(inout) :: out - logical, intent(in), optional :: case_sensitive, out_no_initialise - integer, intent(out), optional :: error - - type(Dictionary) :: tmp_dict - logical :: my_out_no_initialise - integer :: i, j, io - - INIT_ERROR(error) - - - my_out_no_initialise = optional_default(.false., out_no_initialise) - if (.not. my_out_no_initialise) call initialise(out) - - do j=1,size(keys) - - i = lookup_entry_i(this, string(keys(j)), case_sensitive) - if (i == -1) then - RAISE_ERROR('dictionary_subset_es: key '//string(keys(j))//' not in dictionary', error) - end if - if (my_out_no_initialise) then - io = lookup_entry_i(out, string(keys(j)), case_sensitive) - if (io >= 1) then - if (this%entries(i)%type /= out%entries(io)%type) then - RAISE_ERROR('entry type for key '//string(keys(i))//' does not match in this, out', error) - endif - select case(this%entries(i)%type) - case(T_INTEGER_A) - if (any(shape(this%entries(i)%i_a) /= shape(out%entries(io)%i_a))) then - RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) - endif - case(T_REAL_A) - if (any(shape(this%entries(i)%r_a) /= shape(out%entries(io)%r_a))) then - RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) - endif - case(T_COMPLEX_A) - if (any(shape(this%entries(i)%c_a) /= shape(out%entries(io)%c_a))) then - RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) - endif - case(T_LOGICAL_A) - if (any(shape(this%entries(i)%l_a) /= shape(out%entries(io)%l_a))) then - RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) - endif - case(T_CHAR_A) - if (any(shape(this%entries(i)%s_a) /= shape(out%entries(io)%s_a))) then - RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) - endif - case(T_INTEGER_A2) - if (any(shape(this%entries(i)%i_a2) /= shape(out%entries(io)%i_a2))) then - RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) - endif - case(T_REAL_A2) - if (any(shape(this%entries(i)%r_a2) /= shape(out%entries(io)%r_a2))) then - RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) - endif - case(T_DATA) - if (any(shape(this%entries(i)%d) /= shape(out%entries(io)%d))) then - RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) - endif - end select - call remove_entry(out, io) - endif ! io >= 1 - endif ! my_out_no_initialise - - select case(this%entries(i)%type) - case(T_NONE) - call set_value(out, string(this%keys(i))) - - case(T_INTEGER) - call set_value(out, string(this%keys(i)), this%entries(i)%i) - - case(T_REAL) - call set_value(out, string(this%keys(i)), this%entries(i)%r) - - case(T_COMPLEX) - call set_value(out, string(this%keys(i)), this%entries(i)%c) - - case(T_LOGICAL) - call set_value(out, string(this%keys(i)), this%entries(i)%l) - - case(T_CHAR) - call set_value(out, string(this%keys(i)), this%entries(i)%s) - - case(T_INTEGER_A) - call set_value(out, string(this%keys(i)), this%entries(i)%i_a) - - case(T_REAL_A) - call set_value(out, string(this%keys(i)), this%entries(i)%r_a) - - case(T_COMPLEX_A) - call set_value(out, string(this%keys(i)), this%entries(i)%c_a) - - case(T_LOGICAL_A) - call set_value(out, string(this%keys(i)), this%entries(i)%l_a) - - case(T_CHAR_A) - call set_value(out, string(this%keys(i)), this%entries(i)%s_a) - - case(T_INTEGER_A2) - call set_value(out, string(this%keys(i)), this%entries(i)%i_a2) - - case(T_REAL_A2) - call set_value(out, string(this%keys(i)), this%entries(i)%r_a2) - - case(T_DATA) - call set_value(out, string(this%keys(i)), this%entries(i)%d) - - case(T_DICT) - if (.not. get_value(this, string(this%keys(i)), tmp_dict)) then - RAISE_ERROR('dictionary_subset_es: cannot get_value() as Dictionary type.', error) - end if - call set_value(out, string(this%keys(i)), tmp_dict) - call finalise(tmp_dict) - - end select - end do - - end subroutine dictionary_subset_es - - - !% Swap the positions of two entries in the dictionary. Arrays are not moved in memory. - subroutine dictionary_swap(this, key1, key2, case_sensitive, error) - type(Dictionary), intent(inout) :: this - character(len=*), intent(in) :: key1, key2 - logical, optional :: case_sensitive - integer, intent(out), optional :: error - - integer :: i1,i2 - type(DictEntry) :: tmp_entry - type(Extendable_str) :: tmp_key - - INIT_ERROR(error); - - i1 = lookup_entry_i(this,key1,case_sensitive) - i2 = lookup_entry_i(this,key2,case_sensitive) - - if (i1 <= 0) then - RAISE_ERROR('dictionary_swap: key '//key1//' not in dictionary', error) - end if - if (i2 <= 0) then - RAISE_ERROR('dictionary_swap: key '//key2//' not in dictionary', error) - end if - - tmp_entry = this%entries(i2) - tmp_key = this%keys(i2) - this%entries(i2) = this%entries(i1) - this%keys(i2) = this%keys(i1) - this%entries(i1) = tmp_entry - this%keys(i1) = tmp_key - - ! Avoid memory leaks by freeing Extanable_str memory - ! (other entry types are shallow copied). - call finalise(tmp_key) - if (tmp_entry%type == T_CHAR) call finalise(tmp_entry%s) - - this%key_cache_invalid = 1 - - end subroutine dictionary_swap - - subroutine dictionary_bcast(mpi, dict, error) - type(MPI_context), intent(in) :: mpi - type(Dictionary), intent(inout) :: dict - integer, intent(out), optional :: error - - integer :: i, size_tmp, shape_tmp(2) - - INIT_ERROR(error) - - if (.not. mpi%active) return - - if (mpi%my_proc == 0) then - call bcast(mpi, dict%n) - do i=1,dict%n - call bcast(mpi, dict%entries(i)%type) - call bcast(dict%keys(i), mpi%communicator, mpi%my_proc) - - if (dict%entries(i)%type == T_NONE) then - ! nothing to do - else if (dict%entries(i)%type == T_INTEGER) then - call bcast(mpi, dict%entries(i)%i) - else if (dict%entries(i)%type == T_REAL) then - call bcast(mpi, dict%entries(i)%r) - else if (dict%entries(i)%type == T_COMPLEX) then - call bcast(mpi, dict%entries(i)%c) - else if (dict%entries(i)%type == T_LOGICAL) then - call bcast(mpi, dict%entries(i)%l) - else if (dict%entries(i)%type == T_CHAR) then - call bcast(dict%entries(i)%s, mpi%communicator, mpi%my_proc) - else if (dict%entries(i)%type == T_INTEGER_A) then - !size_tmp = size(dict%entries(i)%i_a) - call bcast(mpi, dict%entries(i)%len) - call bcast(mpi, dict%entries(i)%i_a) - else if (dict%entries(i)%type == T_REAL_A) then - !size_tmp = size(dict%entries(i)%r_a) - call bcast(mpi, dict%entries(i)%len) - call bcast(mpi, dict%entries(i)%r_a) - else if (dict%entries(i)%type == T_COMPLEX_A) then - !size_tmp = size(dict%entries(i)%c_a) - call bcast(mpi, dict%entries(i)%len) - call bcast(mpi, dict%entries(i)%c_a) - else if (dict%entries(i)%type == T_LOGICAL_A) then - !size_tmp = size(dict%entries(i)%l_a) - call bcast(mpi, dict%entries(i)%len) - call bcast(mpi, dict%entries(i)%l_a) - else if (dict%entries(i)%type == T_CHAR_A) then - !shape_tmp = shape(dict%entries(i)%s_a) - call bcast(mpi, dict%entries(i)%len2) - call bcast(mpi, dict%entries(i)%s_a) - else if (dict%entries(i)%type == T_INTEGER_A2) then - !shape_tmp = shape(dict%entries(i)%i_a2) - call bcast(mpi, dict%entries(i)%len2) - call bcast(mpi, dict%entries(i)%i_a2) - else if (dict%entries(i)%type == T_REAL_A2) then - !shape_tmp = shape(dict%entries(i)%r_a2) - call bcast(mpi, dict%entries(i)%len2) - call bcast(mpi, dict%entries(i)%r_a2) - else if (dict%entries(i)%type == T_DATA) then - size_tmp = size(dict%entries(i)%d%d) - call bcast(mpi, size_tmp) - call bcast(mpi, dict%entries(i)%d%d) - end if - end do - else - call finalise(dict) - call bcast(mpi, dict%n) - allocate(dict%keys(dict%n)) - allocate(dict%entries(dict%n)) - do i=1,dict%n - call bcast(mpi, dict%entries(i)%type) - call bcast(dict%keys(i), mpi%communicator, mpi%my_proc) - - if (dict%entries(i)%type == T_NONE) then - ! nothing to do - else if (dict%entries(i)%type == T_INTEGER) then - call bcast(mpi, dict%entries(i)%i) - else if (dict%entries(i)%type == T_REAL) then - call bcast(mpi, dict%entries(i)%r) - else if (dict%entries(i)%type == T_COMPLEX) then - call bcast(mpi, dict%entries(i)%c) - else if (dict%entries(i)%type == T_LOGICAL) then - call bcast(mpi, dict%entries(i)%l) - else if (dict%entries(i)%type == T_CHAR) then - call bcast(dict%entries(i)%s, mpi%communicator, mpi%my_proc) - else if (dict%entries(i)%type == T_INTEGER_A) then - !size_tmp = size(dict%entries(i)%i_a) - call bcast(mpi, size_tmp) - dict%entries(i)%len = size_tmp - dict%entries(i)%len2 = (/0, 0/) - allocate(dict%entries(i)%i_a(size_tmp)) - call bcast(mpi, dict%entries(i)%i_a) - else if (dict%entries(i)%type == T_REAL_A) then - !size_tmp = size(dict%entries(i)%r_a) - call bcast(mpi, size_tmp) - dict%entries(i)%len = size_tmp - dict%entries(i)%len2 = (/0, 0/) - allocate(dict%entries(i)%r_a(size_tmp)) - call bcast(mpi, dict%entries(i)%r_a) - else if (dict%entries(i)%type == T_COMPLEX_A) then - !size_tmp = size(dict%entries(i)%c_a) - call bcast(mpi, size_tmp) - dict%entries(i)%len = size_tmp - dict%entries(i)%len2 = (/0, 0/) - allocate(dict%entries(i)%c_a(size_tmp)) - call bcast(mpi, dict%entries(i)%c_a) - else if (dict%entries(i)%type == T_LOGICAL_A) then - !size_tmp = size(dict%entries(i)%l_a) - call bcast(mpi, size_tmp) - dict%entries(i)%len = size_tmp - dict%entries(i)%len2 = (/0, 0/) - allocate(dict%entries(i)%l_a(size_tmp)) - call bcast(mpi, dict%entries(i)%l_a) - else if (dict%entries(i)%type == T_CHAR_A) then - !shape_tmp = shape(dict%entries(i)%s_a) - call bcast(mpi, shape_tmp) - dict%entries(i)%len = 0 - dict%entries(i)%len2 = shape_tmp - allocate(dict%entries(i)%s_a(shape_tmp(1),shape_tmp(2))) - call bcast(mpi, dict%entries(i)%s_a) - else if (dict%entries(i)%type == T_INTEGER_A2) then - !shape_tmp = shape(dict%entries(i)%i_a2) - call bcast(mpi, shape_tmp) - dict%entries(i)%len = 0 - dict%entries(i)%len2 = shape_tmp - allocate(dict%entries(i)%i_a2(shape_tmp(1),shape_tmp(2))) - call bcast(mpi, dict%entries(i)%i_a2) - else if (dict%entries(i)%type == T_REAL_A2) then - !shape_tmp = shape(dict%entries(i)%r_a2) - call bcast(mpi, shape_tmp) - dict%entries(i)%len = 0 - dict%entries(i)%len2 = shape_tmp - allocate(dict%entries(i)%r_a2(shape_tmp(1),shape_tmp(2))) - call bcast(mpi, dict%entries(i)%r_a2) - else if (dict%entries(i)%type == T_DATA) then - size_tmp = size(dict%entries(i)%d%d) - call bcast(mpi, size_tmp) - allocate(dict%entries(i)%d%d(size_tmp)) - call bcast(mpi, dict%entries(i)%d%d) - end if - end do - end if - - end subroutine dictionary_bcast - - !% Copy extendable string from 'in' to 'out', expanding variables formatted - !% as '\$KEY' or '\$\{KEY\}' using values in this Dictionary. An error - !% is raised if a key is not found, or if the string ends with a dollar sign or braces aren't matched - !XXX backslashes are for f90doc.py; of course it actually means '$KEY' and '${KEY}' - subroutine dictionary_expand_string(this, in, out, error) - type(Dictionary), intent(in) :: this - type(Extendable_str), intent(inout) :: in - type(Extendable_str), intent(out) :: out - integer, intent(out), optional :: error - - integer s, e, save_cur - character(len=C_KEY_LEN) :: key - character(len=STRING_LENGTH) :: val - character(len=63), parameter :: valid_chars = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_' - logical got_brace - - INIT_ERROR(error) - - save_cur = in%cur - in%cur = 1 - call initialise(out) - do - s = index(in, '$') - if (s == 0) then - call concat(out, substr(in, in%cur, in%len)) - exit - end if - if (s > in%len-1) then - RAISE_ERROR('dictionary_expand_string: $ found at end of input string "'//in//'"', error) - end if - - if (in%s(s+1) == '{') then - got_brace = .true. - e = index(in, '}') - if (e == 0) then - RAISE_ERROR('dictionary_expand_string: unmatched { in input string "'//in//'"', error) - end if - key = substr(in, s+2, e-1, error) - PASS_ERROR(error); - else - got_brace = .false. - e = s+1 - do while (all(verify(in%s(e:e), valid_chars) == 0)) - e = e + 1 - if (e > in%len) exit - end do - e = e - 1 - key = substr(in, s+1, e, error) - PASS_ERROR(error); - end if - - if (.not. get_value(this, key, val)) then - RAISE_ERROR('dictionary_expand_string: unknown key "'//trim(key)//'" or value is not of type T_CHAR', error) - end if - - call concat(out, substr(in, in%cur, s-1, error)) - PASS_ERROR(error); - call concat(out, val) - in%cur = e+1 - end do - - in%cur = save_cur - - end subroutine dictionary_expand_string - - - !% Make a deep copy of 'from' in 'this', allocating new memory for array components - subroutine dictionary_deepcopy(this, from, error) - type(Dictionary), intent(inout) :: this - type(Dictionary), intent(in) :: from - integer, optional, intent(out) :: error - - INIT_ERROR(error) - call subset(from, from%keys(1:from%n), this, error=error) - PASS_ERROR(error) - - end subroutine dictionary_deepcopy - - - !% Make a deep copy of 'from' in 'this', allocating new memory for array components; no error passing, for the assignment operator - subroutine dictionary_deepcopy_no_error(this, from) - type(Dictionary), intent(inout) :: this - type(Dictionary), intent(in) :: from - - call deepcopy(this, from) - - end subroutine dictionary_deepcopy_no_error - - subroutine dictionary__array__(this, key, nd, dtype, dshape, dloc) - use iso_c_binding, only: c_intptr_t - type(Dictionary), intent(in) :: this - character(len=*), intent(in) :: key - integer, intent(out) :: nd - integer, intent(out) :: dtype - integer, dimension(10), intent(out) :: dshape - integer(c_intptr_t), intent(out) :: dloc - - integer entry_i - - nd = 0 - dtype = 0 - dshape(:) = 0 - dloc = 0 - - entry_i = lookup_entry_i(this, key) - if (entry_i == -1) return - - select case(this%entries(entry_i)%type) - case(T_INTEGER_A) - nd = 1 - dshape(1) = size(this%entries(entry_i)%i_a) - dloc = loc(this%entries(entry_i)%i_a) - dtype = 5 - - case(T_REAL_A) - nd = 1 - dshape(1) = size(this%entries(entry_i)%r_a) - dloc = loc(this%entries(entry_i)%r_a) - dtype = 12 - - case(T_COMPLEX_A) - nd = 1 - dshape(1) = size(this%entries(entry_i)%c_a) - dloc = loc(this%entries(entry_i)%c_a) - dtype = 14 - - case(T_LOGICAL_A) - nd = 1 - dshape(1) = size(this%entries(entry_i)%l_a) - dloc = loc(this%entries(entry_i)%l_a) - dtype = 5 - - case(T_CHAR_A) - nd = 2 - dshape(1) = size(this%entries(entry_i)%s_a,1) - dshape(2) = size(this%entries(entry_i)%s_a,2) - dloc = loc(this%entries(entry_i)%s_a) - dtype = 18 - - case(T_INTEGER_A2) - nd = 2 - dshape(1) = size(this%entries(entry_i)%i_a2, 1) - dshape(2) = size(this%entries(entry_i)%i_a2, 2) - dloc = loc(this%entries(entry_i)%i_a2) - dtype = 5 - - case(T_REAL_A2) - nd = 2 - dshape(1) = size(this%entries(entry_i)%r_a2, 1) - dshape(2) = size(this%entries(entry_i)%r_a2, 2) - dloc = loc(this%entries(entry_i)%r_a2) - dtype = 12 - end select - - end subroutine dictionary__array__ - - -#ifdef POINTER_COMPONENT_MANUAL_COPY -subroutine dictentry_assign(to, from) - type(DictEntry), intent(inout) :: to - type(DictEntry), intent(in) :: from - - to%type = from%type - to%len = from%len - to%len2 = from%len2 - - to%own_data = from%own_data - to%i = from%i - to%r = from%r - to%c = from%c - - to%s = from%s - - to%i_a => from%i_a - to%r_a => from%r_a - to%c_a => from%c_a - to%l_a => from%l_a - to%s_a => from%s_a - - to%i_a2 => from%i_a2 - to%r_a2 => from%r_a2 - - to%d = from%d -end subroutine dictentry_assign - -subroutine dictdata_assign(to, from) - type(DictData), intent(inout) :: to - type(DictData), intent(in) :: from - - if (allocated(to%d)) deallocate(to%d) - if (allocated(from%d)) then - allocate(to%d(size(from%d))) - to%d = from%d - endif -end subroutine dictdata_assign -#endif - -end module dictionary_module diff --git a/src/libAtoms/DomainDecomposition.f95 b/src/libAtoms/DomainDecomposition.f95 deleted file mode 100644 index c780ed58ea..0000000000 --- a/src/libAtoms/DomainDecomposition.f95 +++ /dev/null @@ -1,1605 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module DomainDecomposition_module - use error_module - use system_module - use extendable_str_module - use MPI_context_module - use linearalgebra_module - use table_module - use atoms_types_module - use dictionary_module - - implicit none - - private - - public :: DomainDecomposition - - public :: initialise - interface initialise - module procedure domaindecomposition_initialise - endinterface - - public :: finalise - interface finalise - module procedure domaindecomposition_finalise - endinterface - - interface update_sendrecv_masks - module procedure domaindecomposition_update_sendrecv_masks - endinterface - - public :: enable - interface enable - module procedure domaindecomposition_enable - endinterface enable - - public :: disable - interface disable - module procedure domaindecomposition_disable - endinterface disable - - public :: allocate - interface allocate - module procedure domaindecomposition_allocate - endinterface allocate - - interface is_in_domain - module procedure domaindecomposition_is_in_domain - endinterface is_in_domain - - interface sdompos - module procedure sdompos1, sdompos3 - endinterface - - public :: set_comm_property - interface set_comm_property - module procedure domaindecomposition_set_comm_property - endinterface set_comm_property - - public :: set_border - interface set_border - module procedure domaindecomposition_set_border - endinterface - - public :: comm_atoms - interface comm_atoms - module procedure domaindecomposition_comm_atoms - endinterface - - public :: comm_ghosts - interface comm_ghosts - module procedure domaindecomposition_comm_ghosts - endinterface - - public :: comm_reverse - interface comm_reverse - module procedure domaindecomposition_comm_reverse - endinterface - - public :: comm_atoms_to_all - interface comm_atoms_to_all - module procedure domaindecomposition_comm_atoms_to_all - endinterface - - public :: deepcopy - interface deepcopy - module procedure domaindecomposition_deepcopy - endinterface deepcopy - - - ! - ! Supplement to the Dictionary class required by the domain - ! decomposition module. - ! Move it do Dictionary.f95? - ! - - interface keys_to_mask - module procedure dictionary_keys_to_mask - endinterface keys_to_mask - - interface pack_buffer - module procedure dictionary_pack_buffer - endinterface - - interface unpack_buffer - module procedure dictionary_unpack_buffer - endinterface - -contains - - !% Initialize the domain decomposition module - subroutine domaindecomposition_initialise(this, & - decomposition, verlet_shell, mode, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - integer, optional, intent(in) :: decomposition(3) - real(dp), optional, intent(in) :: verlet_shell - integer, optional, intent(in) :: mode - integer, optional, intent(out) :: error - - ! --- - - INIT_ERROR(error) - - call print("DomainDecomposition : initialise", PRINT_NERD) - - this%decomposition = (/ 1, 1, 1 /) - if (present(decomposition)) then - this%decomposition = decomposition - endif - - this%verlet_shell = 0.0_DP - if (present(verlet_shell)) then - this%verlet_shell = verlet_shell - endif - - this%mode = DD_WRAP_TO_CELL - if (present(mode)) then - if (mode /= DD_WRAP_TO_CELL .and. mode /= DD_WRAP_TO_DOMAIN) then - RAISE_ERROR("Unknown domain decomposition mode '" // mode // "'.", error) - endif - - this%mode = mode - else - this%mode = DD_WRAP_TO_CELL - endif - - this%decomposed = .false. - this%requested_border = 0.0_DP - - this%n_send_p_tot = 0 - this%n_recv_p_tot = 0 - this%n_send_g_tot = 0 - this%n_recv_g_tot = 0 - this%nit_p = 0 - this%nit_g = 0 - - ! Initialise property lists - call initialise(this%atoms_properties) - call initialise(this%ghost_properties) - call initialise(this%reverse_properties) - - endsubroutine domaindecomposition_initialise - - - !% Update send and receive masks, only necessary after properties have - !% been added to or removed from the Atoms object - subroutine domaindecomposition_update_sendrecv_masks(this, at, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(out), optional :: error - - ! --- - - integer :: s - - ! --- - - INIT_ERROR(error) - - ! XXX FIXME This should become unecessary if DynamicalSystem only - ! pointer to an atoms object - if (.not. assign_pointer(at%properties, "local_to_global", & - this%local_to_global)) then - RAISE_ERROR("Could not find 'local_to_global'", error) - endif - - if (allocated(this%atoms_mask)) then - if (size(this%atoms_mask) < at%properties%N) then - deallocate(this%atoms_mask) - this%atoms_buffer_size = 0 - endif - endif - - if (allocated(this%ghost_mask)) then - if (size(this%ghost_mask) < at%properties%N) then - deallocate(this%ghost_mask) - this%ghost_buffer_size = 0 - endif - endif - - if (allocated(this%reverse_mask)) then - if (size(this%reverse_mask) < at%properties%N) then - deallocate(this%reverse_mask) - this%reverse_buffer_size = 0 - endif - endif - - if (.not. allocated(this%atoms_mask) .and. this%atoms_properties%N > 0) then - allocate(this%atoms_mask(at%properties%N)) - call keys_to_mask( & - at%properties, this%atoms_properties, this%atoms_mask, & - s = this%atoms_buffer_size, error = error) - PASS_ERROR(error) - - call print("DomainDecomposition : atoms_buffer_size = " // & - this%atoms_buffer_size, PRINT_VERBOSE) - endif - if (.not. allocated(this%ghost_mask) .and. this%ghost_properties%N > 0) then - allocate(this%ghost_mask(at%properties%N)) - call keys_to_mask( & - at%properties, this%ghost_properties, this%ghost_mask, & - s = this%ghost_buffer_size, error = error) - PASS_ERROR(error) - - call print("DomainDecomposition : ghost_buffer_size = " // & - this%ghost_buffer_size, PRINT_VERBOSE) - endif - if (.not. allocated(this%reverse_mask) .and. this%reverse_properties%N > 0) then - allocate(this%reverse_mask(at%properties%N)) - call keys_to_mask( & - at%properties, this%reverse_properties, this%reverse_mask, & - s = this%reverse_buffer_size, error = error) - PASS_ERROR(error) - - call print("DomainDecomposition : reverse_buffer_size = " // & - this%reverse_buffer_size, PRINT_VERBOSE) - endif - - s = max(this%atoms_buffer_size, this%ghost_buffer_size) * at%Nbuffer - - if (allocated(this%send_l)) then - if (s > size(this%send_l, 1)) then - deallocate(this%send_l) - deallocate(this%send_r) - deallocate(this%recv_l) - deallocate(this%recv_r) - endif - endif - - if (.not. allocated(this%send_l)) then - allocate(this%send_l(s)) - allocate(this%send_r(s)) - allocate(this%recv_l(s)) - allocate(this%recv_r(s)) - endif - - endsubroutine domaindecomposition_update_sendrecv_masks - - - !% Enable domain decomposition, after this call every process - !% remains only with the atoms in its local domain. - subroutine domaindecomposition_enable(this, at, & - mpi, decomposition, verlet_shell, mode, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - type(MPI_context), optional, intent(in) :: mpi - integer, optional, intent(in) :: decomposition(3) - real(dp), optional, intent(in) :: verlet_shell - integer, optional, intent(in) :: mode - integer, optional, intent(out) :: error - - ! --- - - integer :: i, j - - ! --- - - INIT_ERROR(error) - - call print("DomainDecomposition : enable", PRINT_VERBOSE) - - if (present(decomposition)) then - this%decomposition = decomposition - endif - - if (present(verlet_shell)) then - this%verlet_shell = verlet_shell - endif - - if (present(mode)) then - if (mode /= DD_WRAP_TO_CELL .and. mode /= DD_WRAP_TO_DOMAIN) then - RAISE_ERROR("Unknown domain decomposition mode '" // mode // "'.", error) - endif - - this%mode = mode - else - this%mode = DD_WRAP_TO_CELL - endif - - call print("DomainDecomposition : Parallelisation using domain decomposition over " // & - this%decomposition // "domains.", PRINT_NORMAL) - - call initialise(this%mpi, & - context = mpi, & - dims = this%decomposition, & - error = error) - PASS_ERROR(error) - - call print("DomainDecomposition : " // this%mpi%n_procs // " MPI processes available.", PRINT_NORMAL) - - if (this%decomposition(1)*this%decomposition(2)*this%decomposition(3) /= & - this%mpi%n_procs) then - RAISE_ERROR("Decomposition geometry requires " // this%decomposition(1)*this%decomposition(2)*this%decomposition(3) // " processes, however, MPI returns " // this%mpi%n_procs // " processes.", error) - endif - -! For now this needs to be true -! this%periodic = at%periodic - this%periodic = .true. - this%requested_border = 0.0_DP - - call print("DomainDecomposition : coords = ( " // this%mpi%my_coords // ")", PRINT_VERBOSE) - - do i = 1, 3 - call cart_shift( & - this%mpi, i-1, 1, this%l(i), this%r(i), error) - PASS_ERROR(error) - enddo - - this%lower = (1.0_DP*this%mpi%my_coords) / this%decomposition - this%upper = (1.0_DP*(this%mpi%my_coords+1)) / this%decomposition - this%center = (this%lower + this%upper)/2 - - call print("DomainDecomposition : lower = ( " // this%lower // " )", PRINT_VERBOSE) - call print("DomainDecomposition : upper = ( " // this%upper // " )", PRINT_VERBOSE) - call print("DomainDecomposition : center = ( " // this%center // " )", PRINT_VERBOSE) - - this%n_send_p_tot = 0 - this%n_recv_p_tot = 0 - this%n_send_g_tot = 0 - this%n_recv_g_tot = 0 - this%nit_p = 0 - this%nit_g = 0 - - ! allocate internal buffers - call allocate(this, at, error=error) - PASS_ERROR(error) - - ! at is initialised, this means we need to retain only the atoms that - ! are in the current domain. - j = 0 - do i = 1, at%N - ! If this is in the domain, keep it - if (is_in_domain(this, at, at%pos(:, i))) then - j = j+1 - if (i /= j) then - call copy_entry(at, i, j) - endif - endif - enddo - at%N = j - at%Ndomain = j - - this%decomposed = .true. - - endsubroutine domaindecomposition_enable - - - !% Disable domain decomposition, after this call every process - !% retains an identical copy of the system. - subroutine domaindecomposition_disable(this, at, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, intent(out), optional :: error - - ! --- - - INIT_ERROR(error) - - if (.not. this%decomposed) then - RAISE_ERROR("DomainDecomposition-object is not in a domain-decomposed state. Cannot disable domain decomposition.", error) - endif - - call comm_atoms_to_all(this, at, error=error) - PASS_ERROR(error) - - this%decomposed = .false. - - this%local_to_global = 0 - - if (allocated(this%global_to_local)) deallocate(this%global_to_local) - if (allocated(this%ghosts_r)) deallocate(this%ghosts_r) - if (allocated(this%ghosts_l)) deallocate(this%ghosts_l) - - endsubroutine domaindecomposition_disable - - - !% Allocate internal buffer - subroutine domaindecomposition_allocate(this, at, range, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, optional, intent(in) :: range(2) - integer, optional, intent(inout) :: error - - ! --- - - integer :: i, d, my_range(2) - real(dp) :: l(3) - - ! --- - - if ((at%lattice(:, 1) .dot. at%lattice(:, 2)) > 1e-6 .or. & - (at%lattice(:, 2) .dot. at%lattice(:, 3)) > 1e-6 .or. & - (at%lattice(:, 3) .dot. at%lattice(:, 1)) > 1e-6) then - RAISE_ERROR("Only orthorhombic lattices are support for now.", error) - endif - - l = (/ at%lattice(1, 1), at%lattice(2, 2), at%lattice(3, 3) /) - - this%off_r = 0.0_DP - this%off_l = 0.0_DP - - do d = 1, 3 -! if (at%periodic(d) .and. this%decomposition(d) > 1) then - if (this%decomposition(d) > 1) then - ! No periodicity in binning because we explicitly copy the atoms - ! from the other processors -! this%locally_periodic(d) = .false. - else - this%periodic(d) = .false. - endif - - if (this%mpi%my_coords(d) == 0) then - this%off_l(d) = -l(d) - else if (this%mpi%my_coords(d) == this%decomposition(d)-1) then - this%off_r(d) = l(d) - endif - enddo - -! call print("periodic (global) = ( " // at%periodic // " )", PRINT_VERBOSE) - call print("DomainDecomposition : periodic (par.) = ( " // this%periodic // " )", PRINT_VERBOSE) -! call print("periodic (local) = ( " // this%locally_periodic // " )", PRINT_VERBOSE) - - if (this%mode == DD_WRAP_TO_CELL) then - this%off_l = 0.0_DP - this%off_r = 0.0_DP - endif - - call print("DomainDecomposition : off_l = ( " // this%off_l // " )", PRINT_VERBOSE) - call print("DomainDecomposition : off_r = ( " // this%off_r // " )", PRINT_VERBOSE) - - if (present(range)) then - my_range = range - if (my_range(2) - my_range(1) + 1 /= at%N) then - RAISE_ERROR("*range* and number of atoms do not match.", error) - endif - else - my_range = (/ 1, at%N /) - endif - - ! Additional properties (integers) - call add_property(at, "local_to_global", 0, & - ptr=this%local_to_global, error=error) - PASS_ERROR(error) - - ! Allocate local buffers - allocate(this%global_to_local(at%Nbuffer)) - allocate(this%ghosts_r(at%Nbuffer)) - allocate(this%ghosts_l(at%Nbuffer)) - - do i = 1, at%N - !% Assign global indices - this%local_to_global(i) = i+my_range(1)-1 - this%global_to_local(i+my_range(1)-1) = i - enddo - - this%Ntotal = sum(this%mpi, at%N, error) - PASS_ERROR(error) - - call print("DomainDecomposition : Ntotal = " // this%Ntotal, PRINT_VERBOSE) - - call set_border(this, at, this%requested_border, error=error) - PASS_ERROR(error) - - endsubroutine domaindecomposition_allocate - - - !% Is the position in the current domain? - function domaindecomposition_is_in_domain(this, at, r) result(id) - implicit none - - type(DomainDecomposition), intent(in) :: this - type(Atoms), intent(in) :: at - real(dp), intent(in) :: r(3) - - logical :: id - - ! --- - - real(dp) :: s(3) - - ! --- - - s = at%g .mult. r - id = all(s >= this%lower) .and. all(s < this%upper) - - endfunction domaindecomposition_is_in_domain - - - !% Set which properties to communicate on which events - !% comm_atoms: Communicate when atom is moved to different domain. - !% Forces, for example, may be excluded since they are updated - !% on every time step. - !% comm_ghosts: Communicate when atoms becomes a ghost on some domain - !% Masses, for example, might be excluded since atoms are - !% propagated on the domain they reside in only. - !% comm_reverse: Communicate back from ghost atoms to the original domain atom - !% and accumulate - subroutine domaindecomposition_set_comm_property(this, propname, & - comm_atoms, comm_ghosts, comm_reverse) - implicit none - - type(DomainDecomposition), intent(inout) :: this - character(*), intent(in) :: propname - logical, optional, intent(in) :: comm_atoms - logical, optional, intent(in) :: comm_ghosts - logical, optional, intent(in) :: comm_reverse - - ! --- - - if (present(comm_atoms)) then - if (comm_atoms) then - call set_value(this%atoms_properties, propname, .true.) - else - call remove_value(this%atoms_properties, propname) - endif - endif - if (present(comm_ghosts)) then - if (comm_ghosts) then - call set_value(this%ghost_properties, propname, .true.) - else - call remove_value(this%ghost_properties, propname) - endif - endif - if (present(comm_reverse)) then - if (comm_reverse) then - call set_value(this%reverse_properties, propname, .true.) - else - call remove_value(this%reverse_properties, propname) - endif - endif - - endsubroutine domaindecomposition_set_comm_property - - - !% Set the communication border - subroutine domaindecomposition_set_border(this, at, & - border, verlet_shell, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(in) :: border - real(dp), intent(in), optional :: verlet_shell - integer, intent(out), optional :: error - - ! --- - - integer :: d - - ! --- - - INIT_ERROR(error) - - call print("DomainDecomposition : set_border", PRINT_VERBOSE) - - if (present(verlet_shell)) then - this%verlet_shell = verlet_shell - endif - - this%requested_border = max(this%requested_border, border) - this%border = this%requested_border + this%verlet_shell - - call print("DomainDecomposition : requested_border = " // this%requested_border, PRINT_VERBOSE) - call print("DomainDecomposition : verlet_shell = " // this%verlet_shell, PRINT_VERBOSE) - call print("DomainDecomposition : border = " // this%border, PRINT_VERBOSE) - - if (any(((at%lattice .mult. (this%upper - this%lower)) < 2*this%border) .and. this%periodic)) then - RAISE_ERROR("Domain smaller than twice the border. This does not work (yet). border = " // this%border // ", lattice = " // at%lattice(:, 1) // ", " // at%lattice(:, 2) // ", " // at%lattice(:, 3) // ", lower = " // this%lower // ", upper = " // this%upper, error) - endif - - do d = 1, 3 - if (this%periodic(d) .or. this%mpi%my_coords(d) /= 0) then - this%lower_with_border(d) = this%lower(d) - (at%g(d, :) .dot. this%border) - else - this%lower_with_border(d) = this%lower(d) - endif - if (this%periodic(d) .or. this%mpi%my_coords(d) /= this%decomposition(d)-1) then - this%upper_with_border(d) = this%upper(d) + (at%g(d, :) .dot. this%border) - else - this%upper_with_border(d) = this%upper(d) - endif - enddo - - call print("DomainDecomposition : lower_with_border = ( " // this%lower_with_border // " )", PRINT_VERBOSE) - call print("DomainDecomposition : upper_with_border = ( " // this%upper_with_border // " )", PRINT_VERBOSE) - - endsubroutine domaindecomposition_set_border - - - !% Free memory, clean up - subroutine domaindecomposition_finalise(this) - implicit none - - type(DomainDecomposition), intent(inout) :: this - - ! --- - - call print("DomainDecomposition : finalise", PRINT_NERD) - - if (allocated(this%send_l)) deallocate(this%send_l) - if (allocated(this%send_r)) deallocate(this%send_r) - if (allocated(this%recv_l)) deallocate(this%recv_l) - if (allocated(this%recv_r)) deallocate(this%recv_r) - - if (allocated(this%global_to_local)) deallocate(this%global_to_local) - if (allocated(this%ghosts_r)) deallocate(this%ghosts_r) - if (allocated(this%ghosts_l)) deallocate(this%ghosts_l) - - if (allocated(this%atoms_mask)) deallocate(this%atoms_mask) - if (allocated(this%ghost_mask)) deallocate(this%ghost_mask) - if (allocated(this%reverse_mask)) deallocate(this%reverse_mask) - - if (this%n_send_p_tot > 0 .and. this%n_recv_p_tot > 0 .and. & - this%n_send_g_tot > 0 .and. this%n_recv_g_tot > 0) then - call print("DomainDecomposition : Average number of particles sent/received per iteration:", PRINT_NERD) - call print("DomainDecomposition : Particles send = " // (1.0_DP*this%n_send_p_tot)/this%nit_p, PRINT_NERD) - call print("DomainDecomposition : Particles recv = " // (1.0_DP*this%n_recv_p_tot)/this%nit_p, PRINT_NERD) - call print("DomainDecomposition : Ghosts send = " // (1.0_DP*this%n_send_g_tot)/this%nit_g, PRINT_NERD) - call print("DomainDecomposition : Ghosts recv = " // (1.0_DP*this%n_recv_g_tot)/this%nit_g, PRINT_NERD) - endif - - call finalise(this%atoms_properties) - call finalise(this%ghost_properties) - call finalise(this%reverse_properties) - - call finalise(this%mpi) - - endsubroutine domaindecomposition_finalise - - - !% Compute the scaled position as the minimum image from the domain center - !% for a single coordinate only - function sdompos1(this, at, r, d) - implicit none - - type(DomainDecomposition), intent(in) :: this - type(Atoms), intent(in) :: at - real(dp), intent(in) :: r(3) - integer, intent(in) :: d - - real(dp) :: sdompos1 - - ! --- - - real(dp) :: s - - ! --- - - ! center is in scaled coordinates - s = (at%g(d, :) .dot. r) - this%center(d) - sdompos1 = s - nint(s) + this%center(d) - - endfunction sdompos1 - - - !% Compute the scaled position as the minimum image from the domain center - function sdompos3(this, at, r) - implicit none - - type(DomainDecomposition), intent(in) :: this - type(Atoms), intent(in) :: at - real(dp), intent(in) :: r(3) - - real(dp) :: sdompos3(3) - - ! --- - - real(dp) :: s(3) - - ! --- - - ! center is in scaled coordinates - s = (at%g .mult. r) - this%center - sdompos3 = s - nint(s) + this%center - - endfunction sdompos3 - - - !% Add particle data to the send buffer - subroutine pack_atoms_buffer(this, at, i, n, buffer) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, intent(in) :: i - integer, intent(inout) :: n - character(1), intent(inout) :: buffer(:) - - ! --- - -! write (*, *) "Packing: i = " // i // ", n = " // n // ", index = " // this%local_to_global(i) // ", pos = " // at%pos(:, i) - - call pack_buffer(at%properties, this%atoms_mask, i, n, buffer) - this%global_to_local(this%local_to_global(i)) = 0 ! This one is gone - - endsubroutine pack_atoms_buffer - - - !% Copy particle data from the receive buffer - subroutine unpack_atoms_buffer(this, at, n, buffer) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, intent(in) :: n - character(1), intent(in) :: buffer(:) - - ! --- - - integer :: i -! real(dp), pointer :: pos(:, :) - - ! --- - -! if (.not. assign_pointer(at%properties, "pos", pos)) then -! call system_abort("...") -! endif - -! do i = 1, n - i = 0 - do while (i < n) - at%Ndomain = at%Ndomain+1 - - call unpack_buffer(at%properties, this%atoms_mask, i, buffer, at%Ndomain) -! write (*, *) "Unpacked: n = " // at%Ndomain // ", index = " // this%local_to_global(at%Ndomain) // ", pos = " // pos(:, at%Ndomain) - this%global_to_local(this%local_to_global(at%Ndomain)) = at%Ndomain - -! call print("n = " // at%Ndomain // ", pos = " // at%pos(:, at%Ndomain)) - enddo - - endsubroutine unpack_atoms_buffer - - - !% Copy particle data from the receive buffer - subroutine unpack_atoms_buffer_if_in_domain(this, at, n, buffer, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, intent(in) :: n - character(1), intent(in) :: buffer(:) - integer, optional, intent(out) :: error - - ! --- - - integer :: i - real(dp) :: s(3) - real(dp), pointer :: pos(:, :) - - ! --- - - INIT_ERROR(error) - - if (.not. assign_pointer(at%properties, "pos", pos)) then - RAISE_ERROR("Property 'pos' not found.", error) - endif - - i = 0 - do while (i < n) - at%Ndomain = at%Ndomain+1 - - call unpack_buffer(at%properties, this%atoms_mask, i, buffer, at%Ndomain) - - s = sdompos(this, at, pos(1:3, at%Ndomain)) - if (all(s >= this%lower) .and. all(s < this%upper)) then - this%global_to_local(this%local_to_global(at%Ndomain)) = at%Ndomain - else - at%Ndomain = at%Ndomain-1 - endif - enddo - - endsubroutine unpack_atoms_buffer_if_in_domain - - - !% Communicate particles which left the domains - !% to the neighboring domains (former order routine) - subroutine domaindecomposition_comm_atoms(this, at, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, optional, intent(out) :: error - - ! --- - - ! - ! General and auxiliary variables - ! - - integer :: i, d - integer :: last_N - - ! - ! Structure variables, mpi and system structure - ! - - integer :: n_send_l, n_send_r, n_recv_l, n_recv_r - - real(dp) :: off_l(3), off_r(3), s - - ! --- - - INIT_ERROR(error) - - call print("DomainDecomposition : comm_atoms", PRINT_VERBOSE) - - call system_timer("domaindecomposition_comm_atoms") - - ! Update internal buffers - call update_sendrecv_masks(this, at) - - this%nit_p = this%nit_p + 1 - - do i = at%Ndomain+1, at%N - this%global_to_local(this%local_to_global(i)) = 0 - enddo - - ! - ! Loop over dimensions and distribute particle in the - ! respective direction - ! - - do d = 1, 3 - - if (this%decomposition(d) > 1) then - - last_N = at%Ndomain - at%Ndomain = 0 - - n_send_r = 0 - n_send_l = 0 - - do i = 1, last_N - - s = sdompos(this, at, at%pos(:, i), d) -! call print("d = " // d // ", i = " // i // ", s = " // s // ", lower = " // this%lower(d) // ", upper = " // this%upper(d)) - if (s >= this%upper(d)) then - ! Send to the right - - call pack_atoms_buffer(this, at, i, n_send_r, this%send_r) - - else if (s < this%lower(d)) then - ! Send to the left - - call pack_atoms_buffer(this, at, i, n_send_l, this%send_l) - - else - ! Keep on this processor and reorder - - at%Ndomain = at%Ndomain+1 - - if (at%Ndomain /= i) then - call copy_entry(at, i, at%Ndomain) - endif - - endif - - enddo - - this%n_send_p_tot = this%n_send_p_tot + n_send_r + n_send_l - - call sendrecv(this%mpi, & - this%send_r(1:n_send_r), this%r(d), 0, & - this%recv_l, this%l(d), 0, & - n_recv_l, error) - PASS_ERROR(error) - - call sendrecv(this%mpi, & - this%send_l(1:n_send_l), this%l(d), 1, & - this%recv_r, this%r(d), 1, & - n_recv_r, error) - PASS_ERROR(error) - - call print("DomainDecomposition : Send state buffers. Sizes: l = " // n_send_l/this%atoms_buffer_size // ", r = " // n_send_r/this%atoms_buffer_size, PRINT_NERD) - - call print("DomainDecomposition : Received state buffers. Sizes: l = " // n_recv_l/this%atoms_buffer_size // ", r = " // n_recv_r/this%atoms_buffer_size, PRINT_NERD) - - this%n_recv_p_tot = this%n_recv_p_tot + n_recv_r/this%atoms_buffer_size + n_recv_l/this%atoms_buffer_size - - off_l = 0.0_DP - ! This will be done by inbox - off_l(d) = this%off_l(d) - - off_r = 0.0_DP - ! This will be done by inbox - off_r(d) = this%off_r(d) - - call unpack_atoms_buffer(this, at, n_recv_l, this%recv_l) - call unpack_atoms_buffer(this, at, n_recv_r, this%recv_r) - - endif - - enddo - - at%N = at%Ndomain - if (at%Ndomain /= last_N) then - call print("DomainDecomposition : Repointing atoms object", PRINT_ANALYSIS) - call atoms_repoint(at) - endif - - this%Ntotal = sum(this%mpi, at%N, error) - -! call print("DomainDecomposition : Total number of atoms = " // this%Ntotal, PRINT_VERBOSE) - - call system_timer("domaindecomposition_comm_atoms") - - endsubroutine domaindecomposition_comm_atoms - - - !% Communicate all particles from this domain to all other domains - subroutine domaindecomposition_comm_atoms_to_all(this, at, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, optional, intent(out) :: error - - ! --- - - ! - ! General and auxiliary variables - ! - - integer :: i, j - integer :: last_N - - ! - ! Structure variables, mpi and system structure - ! - - integer :: n_send, n_recv - - real(dp) :: s(3) - - ! --- - - INIT_ERROR(error) - - call print("DomainDecomposition : comm_atoms_to_all", PRINT_VERBOSE) - call print("DomainDecomposition : decomposed = " // this%decomposed, & - PRINT_VERBOSE) - - ! Update internal buffers - call update_sendrecv_masks(this, at) - - ! - ! Loop over dimensions and distribute particle in the - ! respective direction - ! - - last_N = at%Ndomain - at%Ndomain = 0 - - n_send = 0 - - do i = 1, last_N - - ! Send always - call pack_atoms_buffer(this, at, i, n_send, this%send_r) - - s = sdompos(this, at, at%pos(:, i)) - if (.not. this%decomposed .or. & - all(s >= this%lower) .and. all(s < this%upper)) then - ! Keep on this processor and reorder - - at%Ndomain = at%Ndomain+1 - - if (at%Ndomain /= i) then - call copy_entry(at, i, at%Ndomain) - endif - - endif - - enddo - - do j = 0, this%mpi%n_procs-1 - - if (j == this%mpi%my_proc) then - call bcast(this%mpi, n_send, root=j, error=error) - PASS_ERROR(error) - -! call print("n_send = " // n_send // ", size(send_r) = " // size(this%send_r), PRINT_ALWAYS) - - call bcast(this%mpi, this%send_r(1:n_send), root=j, error=error) - PASS_ERROR(error) - else - call bcast(this%mpi, n_recv, root=j, error=error) - PASS_ERROR(error) - -! call print("n_recv = " // n_recv // ", size(recv_r) = " // size(this%recv_r), PRINT_ALWAYS) -! call print("n = " // (n_recv/this%atoms_buffer_size), PRINT_ALWAYS) - - call bcast(this%mpi, this%recv_r(1:n_recv), root=j, error=error) - PASS_ERROR(error) - - if (this%decomposed) then - call unpack_atoms_buffer_if_in_domain(this, at, & - n_recv, this%recv_r, & - error = error) - PASS_ERROR(error) - else - call unpack_atoms_buffer(this, at, n_recv, this%recv_r) - endif - endif - - enddo - - call print("DomainDecomposition : " // & - "Ndomain = " // at%Ndomain // ", Nbuffer = " // at%Nbuffer, & - PRINT_VERBOSE) - - if (this%decomposed) then - call print("DomainDecomposition : total number of atoms = " // & - sum(this%mpi, at%Ndomain), PRINT_VERBOSE) - endif - - at%N = at%Ndomain - if (at%Ndomain /= last_N) then - call print("DomainDecomposition : Repointing atoms object", PRINT_ANALYSIS) - call atoms_repoint(at) - endif - - call print("DomainDecomposition : Sorting atoms object", PRINT_ANALYSIS) - - ! Sort atoms by global index - call atoms_sort(at, "local_to_global", error=error) - PASS_ERROR(error) - - endsubroutine domaindecomposition_comm_atoms_to_all - - - !% Copy particle data from the (ghost) receive buffer - subroutine unpack_ghost_buffer(this, at, n, buffer, off) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, intent(in) :: n - character(1), intent(in) :: buffer(:) - real(dp), intent(in) :: off(3) - - ! --- - - integer :: i - - ! --- - - i = 0 - do while (i < n) - at%N = at%N+1 - call unpack_buffer(at%properties, this%ghost_mask, i, buffer, at%N) - at%pos(:, at%N) = at%pos(:, at%N) + off - this%global_to_local(this%local_to_global(at%N)) = at%N - enddo - - endsubroutine unpack_ghost_buffer - - - !% Communicate ghost particles to neighboring domains - !% (former prebinning routine). *bwidth* is the width of - !% the border. - subroutine domaindecomposition_comm_ghosts(this, at, new_list, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - logical, intent(in) :: new_list - integer, intent(out), optional :: error - - ! --- - - real(dp) :: upper(3), lower(3) - integer :: i, d, list_off_r, list_off_l, last_N - integer :: n_send_r, n_send_l, n_recv_r, n_recv_l - - real(dp) :: off_l(3), off_r(3), s - - ! --- - - INIT_ERROR(error) - - call print("DomainDecomposition : comm_ghosts", PRINT_NERD) - - call update_sendrecv_masks(this, at) - - call system_timer("domaindecomposition_comm_ghosts") - - this%nit_g = this%nit_g + 1 - - do d = 1, 3 - - if (this%periodic(d) .or. this%mpi%my_coords(d) /= 0) then - lower(d) = this%lower(d) + (at%g(d, :) .dot. this%border) - else - lower(d) = this%lower(d) - endif - - if (this%periodic(d) .or. this%mpi%my_coords(d) /= this%decomposition(d)-1) then - upper(d) = this%upper(d) - (at%g(d, :) .dot. this%border) - else - upper(d) = this%upper(d) - endif - - enddo - - call print("DomainDecomposition : upper = " // upper, PRINT_NERD) - call print("DomainDecomposition : lower = " // lower, PRINT_NERD) - - last_N = at%n - do i = at%Ndomain+1, at%N - this%global_to_local(this%local_to_global(i)) = 0 - enddo - at%N = at%Ndomain - - ! - ! Loop over dimensions and distribute particle in the - ! respective direction - ! - - list_off_r = 0 - list_off_l = 0 - do d = 1, 3 - - if (this%decomposition(d) > 1) then - - n_send_r = 0 - n_send_l = 0 - - if (new_list) then - - this%n_ghosts_r(d) = 0 - this%n_ghosts_l(d) = 0 - - do i = 1, at%N - s = sdompos(this, at, at%pos(:, i), d) - if (s >= upper(d)) then - call pack_buffer(at%properties, this%ghost_mask, & - i, & - n_send_r, this%send_r) - this%n_ghosts_r(d) = this%n_ghosts_r(d)+1 - this%ghosts_r(list_off_r+this%n_ghosts_r(d)) = this%local_to_global(i) - - else if (s < lower(d)) then - call pack_buffer(at%properties, this%ghost_mask, & - i, & - n_send_l, this%send_l) - - this%n_ghosts_l(d) = this%n_ghosts_l(d)+1 - this%ghosts_l(list_off_l+this%n_ghosts_l(d)) = this%local_to_global(i) - - endif - enddo - - else - - do i = 1, this%n_ghosts_r(d) - call pack_buffer(at%properties, this%ghost_mask, & - this%global_to_local(this%ghosts_r(list_off_r+i)), & - n_send_r, this%send_r) - enddo - - do i = 1, this%n_ghosts_l(d) - call pack_buffer(at%properties, this%ghost_mask, & - this%global_to_local(this%ghosts_l(list_off_l+i)), & - n_send_l, this%send_l) - enddo - - endif - - this%n_send_g_tot = this%n_send_g_tot + this%n_ghosts_r(d) + this%n_ghosts_l(d) - - call sendrecv(this%mpi, & - this%send_r(1:n_send_r), this%r(d), 0, & - this%recv_l, this%l(d), 0, & - n_recv_l, error) - PASS_ERROR(error) - - call sendrecv(this%mpi, & - this%send_l(1:n_send_l), this%l(d), 1, & - this%recv_r, this%r(d), 1, & - n_recv_r, error) - PASS_ERROR(error) - - call print("DomainDecomposition : Send ghost buffers. Sizes: l = " // n_send_l/this%ghost_buffer_size // ", r = " // n_send_r/this%ghost_buffer_size, PRINT_NERD) - call print("DomainDecomposition : Received ghost buffers. Sizes: l = " // n_recv_l/this%ghost_buffer_size // ", r = " // n_recv_r/this%ghost_buffer_size, PRINT_NERD) - - this%n_recv_g_tot = this%n_recv_g_tot + & - n_recv_r/this%ghost_buffer_size + & - n_recv_l/this%ghost_buffer_size - - off_l = 0.0_DP - off_l(d) = this%off_l(d) - - off_r = 0.0_DP - off_r(d) = this%off_r(d) - - call unpack_ghost_buffer(this, at, n_recv_r, this%recv_r, off_r) - call unpack_ghost_buffer(this, at, n_recv_l, this%recv_l, off_l) - - list_off_r = list_off_r + this%n_ghosts_r(d) - list_off_l = list_off_l + this%n_ghosts_l(d) - - endif - - enddo - - if (at%N /= last_N) then - call print("DomainDecomposition : Repointing atoms object", PRINT_ANALYSIS) - call atoms_repoint(at) - endif - - call system_timer("domaindecomposition_comm_ghosts") - - endsubroutine domaindecomposition_comm_ghosts - - - !% Copy forces to the (ghost) send buffer - subroutine copy_forces_to_send_ghosts(this, at, i, n, buffer) - implicit none - - type(DomainDecomposition), intent(in) :: this - type(Atoms), intent(inout) :: at - integer, intent(in) :: i - integer, intent(in) :: n - character(1), intent(inout) :: buffer(:) - - ! --- - - integer :: m - - ! --- - - m = n - call pack_buffer(at%properties, this%reverse_mask, i, m, buffer) - - endsubroutine copy_forces_to_send_ghosts - - - !% Copy particle data from the (ghost) receive buffer - subroutine copy_forces_from_recv_ghosts(this, at, cur, n, buffer) - implicit none - - type(DomainDecomposition), intent(in) :: this - type(Atoms), intent(inout) :: at - integer, intent(inout) :: cur - integer, intent(in) :: n - character(1), intent(in) :: buffer(:) - - ! --- - - integer :: i - - ! --- - - i = 0 - do while (i < n) - cur = cur+1 - - call unpack_buffer(at%properties, this%reverse_mask, i, buffer, cur) - enddo - - endsubroutine copy_forces_from_recv_ghosts - - - !% Communicate forces of ghost particles back. - !% This is needed for rigid object (i.e., water) or to reduce the - !% border size in BOPs. - subroutine domaindecomposition_comm_reverse(this, at, error) - implicit none - - type(DomainDecomposition), intent(inout) :: this - type(Atoms), intent(inout) :: at - integer, intent(out), optional :: error - - ! --- - - integer :: i, d, list_off_r, list_off_l, n_recv_r, n_recv_l, cur - - ! --- - - INIT_ERROR(error) - - call print("DomainDecomposition : comm_ghosts", PRINT_NERD) - - call update_sendrecv_masks(this, at) - - call system_timer("domaindecomposition_comm_reverse") - - ! - ! Loop over dimensions and distribute particle in the - ! respective direction - ! - - list_off_r = 0 - list_off_l = 0 - cur = at%Ndomain - do d = 1, 3 - - if (this%decomposition(d) > 1) then - - do i = 1, this%n_ghosts_r(d) - call copy_forces_to_send_ghosts(this, at, this%global_to_local(this%ghosts_r(list_off_r+i)), (i-1)*this%reverse_buffer_size, this%send_r) - enddo - - do i = 1, this%n_ghosts_l(d) - call copy_forces_to_send_ghosts(this, at, this%global_to_local(this%ghosts_l(list_off_l+i)), (i-1)*this%reverse_buffer_size, this%send_l) - enddo - - call sendrecv(this%mpi, & - this%send_r(1:this%reverse_buffer_size*this%n_ghosts_r(d)), & - this%r(d), 0, & - this%recv_l, this%l(d), 0, & - n_recv_l, error) - PASS_ERROR(error) - - call sendrecv(this%mpi, & - this%send_l(1:this%reverse_buffer_size*this%n_ghosts_l(d)), & - this%l(d), 1, & - this%recv_r, this%r(d), 1, & - n_recv_r, error) - PASS_ERROR(error) - - call copy_forces_from_recv_ghosts(this, at, cur, n_recv_l, this%recv_l) - call copy_forces_from_recv_ghosts(this, at, cur, n_recv_r, this%recv_r) - - list_off_r = list_off_r + this%n_ghosts_r(d) - list_off_l = list_off_l + this%n_ghosts_l(d) - - endif - - enddo - - call system_timer("domaindecomposition_comm_reverse") - - endsubroutine domaindecomposition_comm_reverse - - - !% Create a deep copy - subroutine domaindecomposition_deepcopy(to, from) - implicit none - - type(DomainDecomposition), intent(out) :: to - type(DomainDecomposition), intent(in) :: from - - ! --- - - to = from - - endsubroutine domaindecomposition_deepcopy - - ! - ! Supplement to the Dictionary object - ! - - !% Convert a list of keys to a mask - subroutine dictionary_keys_to_mask(this, keys, mask, s, error) - implicit none - - type(Dictionary), intent(in) :: this !% Dictionary object - type(Dictionary), intent(in) :: keys !% List of keys - logical, intent(out) :: mask(this%N) !% True if in keys - integer, intent(out), optional :: s !% Size of the buffer - integer, intent(out), optional :: error - - ! --- - - integer :: i, entry_i - - ! --- - - INIT_ERROR(error) - - mask = .false. - s = 0 - do i = 1, keys%N - entry_i = lookup_entry_i(this, string(keys%keys(i))) - if (entry_i == -1) then -! RAISE_ERROR("Could not find key '" // keys%keys(i) // "'.", error) - call print("DomainDecomposition : WARNING - Could not find key '" // keys%keys(i) // "', this property will not be communicated.", PRINT_ANALYSIS) - else - - select case(this%entries(entry_i)%type) - - case (T_REAL_A) - s = s + sizeof(this%entries(entry_i)%r_a(1)) - - case (T_INTEGER_A) - s = s + sizeof(this%entries(entry_i)%i_a(1)) - - case (T_LOGICAL_A) - s = s + sizeof(this%entries(entry_i)%l_a(1)) - - case (T_REAL_A2) - s = s + sizeof(this%entries(entry_i)%r_a2(:, 1)) - - case (T_INTEGER_A2) - s = s + sizeof(this%entries(entry_i)%i_a2(:, 1)) - - case default - RAISE_ERROR("Don't know how to handle entry type " // this%entries(entry_i)%type // " (key '" // this%keys(entry_i) // "').", error) - - endselect - - mask(entry_i) = .true. - - endif - enddo - - endsubroutine dictionary_keys_to_mask - - - !% Pack buffer, copy all entries with for which tag is true to the buffer - subroutine dictionary_pack_buffer(this, mask, & - data_i, buffer_i, buffer, error) - implicit none - - type(Dictionary), intent(in) :: this - logical, intent(in) :: mask(:) - integer, intent(in) :: data_i - integer, intent(inout) :: buffer_i - character(1), intent(inout) :: buffer(:) - integer, intent(out), optional :: error - - ! --- - - integer :: i, s - - ! --- - - INIT_ERROR(error) - - do i = 1, this%N - if (mask(i)) then - - select case(this%entries(i)%type) - - case (T_REAL_A) - s = sizeof(this%entries(i)%r_a(1)) - buffer(buffer_i+1:buffer_i+s) = & - transfer(this%entries(i)%r_a(data_i), buffer) - buffer_i = buffer_i + s - - case (T_INTEGER_A) - s = sizeof(this%entries(i)%i_a(1)) - buffer(buffer_i+1:buffer_i+s) = & - transfer(this%entries(i)%i_a(data_i), buffer) - buffer_i = buffer_i + s - - case (T_LOGICAL_A) - s = sizeof(this%entries(i)%l_a(1)) - buffer(buffer_i+1:buffer_i+s) = & - transfer(this%entries(i)%l_a(data_i), buffer) - buffer_i = buffer_i + s - - case (T_REAL_A2) - s = sizeof(this%entries(i)%r_a2(:, 1)) - buffer(buffer_i+1:buffer_i+s) = & - transfer(this%entries(i)%r_a2(:, data_i), buffer) - buffer_i = buffer_i + s - - case (T_INTEGER_A2) - s = sizeof(this%entries(i)%i_a2(:, 1)) - buffer(buffer_i+1:buffer_i+s) = & - transfer(this%entries(i)%i_a2(:, data_i), buffer) - buffer_i = buffer_i + s - - case default - RAISE_ERROR("Don't know how to handle entry type " // this%entries(i)%type // " (key '" // this%keys(i) // "').", error) - - endselect - - endif - enddo - - endsubroutine dictionary_pack_buffer - - - !% Unpack buffer, copy all entries with for which mask is true from the buffer - subroutine dictionary_unpack_buffer(this, mask, & - buffer_i, buffer, data_i, error) - implicit none - - type(Dictionary), intent(inout) :: this - logical, intent(in) :: mask(:) - integer, intent(inout) :: buffer_i - character(1), intent(in) :: buffer(:) - integer, intent(in) :: data_i - integer, intent(out), optional :: error - - ! --- - - integer :: i, ndims, s - - ! --- - - INIT_ERROR(error) - - do i = 1, this%N - if (mask(i)) then - - select case(this%entries(i)%type) - - case (T_REAL_A) - s = sizeof(this%entries(i)%r_a(1)) - this%entries(i)%r_a(data_i) = & - transfer(buffer(buffer_i+1:buffer_i+s), 1.0_DP) - buffer_i = buffer_i + s - - case (T_INTEGER_A) - s = sizeof(this%entries(i)%i_a(1)) - this%entries(i)%i_a(data_i) = & - transfer(buffer(buffer_i+1:buffer_i+s), 1) - buffer_i = buffer_i + s - - case (T_LOGICAL_A) - this%entries(i)%l_a(data_i) = & - transfer(buffer(buffer_i+1:), .true.) - buffer_i = buffer_i + sizeof(this%entries(i)%l_a(1)) - - case (T_REAL_A2) - s = sizeof(this%entries(i)%r_a2(:, 1)) - ndims = size(this%entries(i)%r_a2, 1) - this%entries(i)%r_a2(:, data_i) = & - transfer(buffer(buffer_i+1:buffer_i+s), 1.0_DP, ndims) - buffer_i = buffer_i + s - - case (T_INTEGER_A2) - s = sizeof(this%entries(i)%i_a2(:, 1)) - ndims = size(this%entries(i)%i_a2, 1) - this%entries(i)%i_a2(:, data_i) = & - transfer(buffer(buffer_i+1:buffer_i+s), 1.0_DP, ndims) - buffer_i = buffer_i + s - - case default - RAISE_ERROR("Don't know how to handle entry type " // this%entries(i)%type // " (key '" // this%keys(i) // "').", error) - - endselect - - endif - enddo - - endsubroutine dictionary_unpack_buffer - -endmodule DomainDecomposition_module diff --git a/src/libAtoms/DynamicalSystem.f95 b/src/libAtoms/DynamicalSystem.f95 deleted file mode 100644 index 3e218a752f..0000000000 --- a/src/libAtoms/DynamicalSystem.f95 +++ /dev/null @@ -1,3287 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Dynamical System module -!X -!% A DynamicalSystem object contains an Atoms object, which holds infomation about -!% velocities and accelerations of each atom, scalar quantities such as -!% thermostat settings, and logical masks so that thermostatting can be applied -!% to selected atoms etc. -!% -!% In Fortran code, initialise a DynamicalSystem object like this: -!%> call initialise(MyDS, MyAtoms) -!% which (shallowly) copies MyAtoms into the internal atoms structure (and so -!% MyAtoms is not required by MyDS after this call and can be finalised). In Python, -!% a DynamicalSystem can be initialised from an Atoms instance: -!%> MyDS = DynamicalSystem(MyAtoms) -!% -!% -!% A DynamicalSystem is constructed from an Atoms object -!% 'atoms'. The initial velocities and accelerations can optionally be -!% specificed as '(3,atoms.n)' arrays. The 'constraints' and -!% 'rigidbodies' arguments can be used to specify the number of -!% constraints and rigid bodies respectively (the default is zero in -!% both cases). -!% -!% DynamicalSystem has an integrator, -!%> call advance_verlet(MyDS,dt,forces) -!% which takes a set of forces and integrates the equations of motion forward -!% for a time 'dt'. -!% -!% All dynamical variables are stored inside the Atoms' :attr:`~quippy.atoms.Atoms.properties` Dictionary. -!% -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module dynamicalsystem_module - - use error_module - use system_module - use mpi_context_module - use units_module - use linearalgebra_module - use table_module - use periodictable_module - use dictionary_module, only: STRING_LENGTH - use atoms_types_module - use atoms_module - use rigidbody_module - use group_module - use constraints_module - use thermostat_module - use barostat_module - -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif - implicit none -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif - private - - public :: dynamicalsystem, add_atoms, remove_atoms, print, initialise, finalise - public :: kinetic_energy, kinetic_virial, angular_momentum, momentum, n_thermostat, add_thermostat, remove_thermostat, print_thermostats - public :: set_barostat, add_thermostats, update_thermostat, gaussian_velocity_component - public :: TYPE_CONSTRAINED, TYPE_ATOM, ds_print_status, rescale_velo, zero_momentum - public :: advance_verlet1, advance_verlet2, advance_verlet, distance_relative_velocity, ds_amend_constraint - public :: torque, temperature, zero_angular_momentum, is_damping_enabled, get_damping_time, enable_damping, disable_damping, moment_of_inertia_tensor, thermostat_temperatures - public :: ds_add_constraint, ds_save_state, ds_restore_state - - public :: constrain_bondanglecos, & - constrain_bondlength, & - constrain_bondlength_sq, & - constrain_bondlength_dev_pow, & - constrain_bondlength_diff, & - constrain_gap_energy, & - constrain_atom_plane, & - constrain_struct_factor_like_mag, & - constrain_struct_factor_like_r, & - constrain_struct_factor_like_i - - !Different integration types. Stored in group%type. Used by advance_verlet to integrate - !the equations of motion in different ways. - integer, parameter :: TYPE_IGNORE = 0 - integer, parameter :: TYPE_ATOM = 1 - integer, parameter :: TYPE_CONSTRAINED = 2 - integer, parameter :: TYPE_RIGID = 3 - - type DynamicalSystem - - ! Scalar members - integer :: N = 0 !% Number of atoms - integer :: nSteps = 0 !% Number of integration steps - integer :: Nrigid = 0 !% Number of rigid bodies - integer :: Nconstraints = 0 !% Number of constraints - integer :: Nrestraints = 0 !% Number of restraints - integer :: Ndof = 0 !% Number of degrees of freedom - real(dp) :: t = 0.0_dp !% Time - real(dp) :: dt = 1.0_dp !% Last time step - real(dp) :: avg_temp = 0.0_dp !% Time-averaged temperature - real(dp) :: cur_temp = 0.0_dp !% Current temperature - real(dp) :: avg_time = 100.0_dp !% Averaging time, in fs - real(dp) :: dW = 0.0_dp !% Increment of work done this time step - real(dp) :: work = 0.0_dp !% Total work done - real(dp) :: Epot = 0.0_dp !% Total potential energy - real(dp) :: Ekin = 0.0_dp !% Current kinetic energy - real(dp) :: Wkin(3, 3) = 0.0_dp !% Current kinetic contribution to the virial - real(dp) :: ext_energy = 0.0_dp !% Extended energy - real(dp) :: thermostat_dW = 0.0_dp !% Increment of work done by thermostat - real(dp) :: thermostat_work = 0.0_dp !% Total work done by thermostat - logical :: initialised = .false. - - integer :: random_seed !% RNG seed, used by 'ds_save_state' and 'ds_restore_state' only. - - ! Array members - integer, pointer, dimension(:) :: group_lookup !% Stores which group atom $i$ is in - - ! Derived type members - type(Atoms), pointer :: atoms => NULL() - - ! Derived Type array members - type(Constraint), allocatable, dimension(:) :: constraint, restraint - type(RigidBody), allocatable, dimension(:) :: rigidbody - type(Group), allocatable, dimension(:) :: group - type(thermostat), allocatable, dimension(:) :: thermostat - type(barostat) :: barostat - logical :: print_thermostat_temps = .true. - - end type DynamicalSystem - - interface assignment(=) - module procedure DS_Assignment - end interface - - !% Add one or more atoms to this DynamicalSystem. Equivalent to 'Atoms%add_atoms', - !% but also appends the number of degrees of freedom correctly. - interface add_atoms - module procedure ds_add_atom_single, ds_add_atom_multiple - end interface add_atoms - - !% Remove one or more atoms from this DynamicalSystem. Equivalent of 'Atoms%remove_atoms', - !%but also amends the number of degrees of freedom correctly. - interface remove_atoms - module procedure ds_remove_atom_single, ds_remove_atom_multiple - end interface remove_atoms - - interface print - module procedure ds_print - end interface - - !% Initialise this DynamicalSystem from an Atoms object - interface initialise - module procedure ds_initialise - end interface initialise - - !% Free up the memory used by this DynamicalSystem - interface finalise - module procedure ds_finalise - end interface finalise - - interface kinetic_energy - module procedure single_kinetic_energy, arrays_kinetic_energy, atoms_kinetic_energy, ds_kinetic_energy - end interface kinetic_energy - - interface kinetic_virial - module procedure single_kinetic_virial, arrays_kinetic_virial - module procedure atoms_kinetic_virial, ds_kinetic_virial - endinterface kinetic_virial - - interface angular_momentum - module procedure arrays_angular_momentum, atoms_angular_momentum, ds_angular_momentum - end interface angular_momentum - - interface momentum - module procedure arrays_momentum, atoms_momentum, ds_momentum - end interface momentum - - !% Add a new thermostat to this DynamicalSystem. 'type' should - !% be one of the following thermostat types: - !% - !% * 'THERMOSTAT_NONE' - !% * 'THERMOSTAT_LANGEVIN' - !% * 'THERMOSTAT_NOSE_HOOVER' - !% * 'THERMOSTAT_NOSE_HOOVER_LANGEVIN' - !% * 'THERMOSTAT_LANGEVIN_NPT' - !% * 'THERMOSTAT_LANGEVIN_PR' - !% * 'THERMOSTAT_NPH_ANDERSEN' - !% * 'THERMOSTAT_NPH_PR' - !% * 'THERMOSTAT_LANGEVIN_OU' - !% * 'THERMOSTAT_LANGEVIN_NPT_NB' - !% - !% 'T' is the target temperature. 'Q' is the Nose-Hoover coupling constant. Only one - !% of 'tau' or 'gamma' should be given. 'p' is the external - !% pressure for the case of Langevin NPT. - interface add_thermostat - module procedure ds_add_thermostat - end interface add_thermostat - - interface remove_thermostat - module procedure ds_remove_thermostat - end interface remove_thermostat - - interface print_thermostats - module procedure ds_print_thermostats - end interface print_thermostats - - interface set_barostat - module procedure ds_set_barostat - end interface set_barostat - - interface add_thermostats - module procedure ds_add_thermostats - end interface add_thermostats - - interface update_thermostat - module procedure ds_update_thermostat - end interface update_thermostat - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X INITIALISE AND FINALISE - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine ds_initialise(this,atoms_in,velocity,acceleration,constraints,restraints,rigidbodies,error) - - type(DynamicalSystem), intent(inout) :: this - type(Atoms), target :: atoms_in - real(dp), dimension(:,:), optional, intent(in) :: velocity - real(dp), dimension(:,:), optional, intent(in) :: acceleration - integer, optional, intent(in) :: constraints, restraints - integer, optional, intent(in) :: rigidbodies - integer :: i,N - integer, optional, intent(out) :: error - - logical :: added_avgpos, added_avgke - - ! --- - - INIT_ERROR(error) - - ! Check to see if the object has already been initialised - if (this%initialised) call ds_finalise(this) - - N = atoms_in%Nbuffer - this%N = N - - ! Check the atomic numbers - do i = 1, atoms_in%N - if (atoms_in%Z(i) < 1) then - RAISE_ERROR('DS_Initialise: Atom '//i//' has not had its atomic number set', error) - end if - end do - - ! 'group_lookup' needs to be in the Atoms object in order to be - ! distributed properly with domain decomposition enabled. - ! XXX FIXME this crashes in quippy - !call add_property(this%atoms, 'group_lookup', 0, & - ! ptr=this%group_lookup, error=error) - !PASS_ERROR(error) - ! XXX FIXME this is the temporary fix - allocate(this%group_lookup(N)) - ! allocate local arrays - allocate(this%group(N)) - - ! Now point to the atoms - call shallowcopy(this%atoms, atoms_in) - - ! Add single valued properties to this%atoms - ! XXX FIXME also not quippy compatible, check - !call set_value(this%atoms%properties, 'time', 0.0_DP) - !if (.not. assign_pointer(this%atoms%properties, 'time', this%t)) then - ! RAISE_ERROR("Could not assign property 'time'.", error) - !endif - - ! Add properties for the dynamical variables to this%atoms if they don't - ! already exist - call add_property(this%atoms, 'mass', 0.0_DP, error=error) - PASS_ERROR(error) - call set_comm_property(this%atoms, 'mass', & - comm_atoms=.true.) - call add_property(this%atoms, 'travel', 0, n_cols=3, error=error) - PASS_ERROR(error) - call set_comm_property(this%atoms, 'travel', & - comm_atoms=.true.) - - call add_property(this%atoms, 'move_mask', 1, error=error) - PASS_ERROR(error) - call set_comm_property(this%atoms, 'move_mask', & - comm_atoms=.true.) - call add_property(this%atoms, 'damp_mask', 1, error=error) - PASS_ERROR(error) - call set_comm_property(this%atoms, 'damp_mask', & - comm_atoms=.true.) - call add_property(this%atoms, 'thermostat_region', 1, error=error) - PASS_ERROR(error) - call set_comm_property(this%atoms, 'thermostat_region', & - comm_atoms=.true.) - - added_avgke = .not. has_property(this%atoms, 'avg_ke') - call add_property(this%atoms, 'avg_ke', 0.0_dp, error=error) - PASS_ERROR(error) - call set_comm_property(this%atoms, 'avg_ke', & - comm_atoms=.true.) - call add_property(this%atoms, 'velo', 0.0_dp, n_cols=3, error=error) - PASS_ERROR(error) - call set_comm_property(this%atoms, 'velo', & - comm_atoms=.true.) - call add_property(this%atoms, 'acc', 0.0_dp, n_cols=3, error=error) - PASS_ERROR(error) - added_avgpos = .not. has_property(this%atoms, 'avgpos') - call add_property(this%atoms, 'avgpos', 0.0_dp, n_cols=3, error=error) - PASS_ERROR(error) - call set_comm_property(this%atoms, 'avgpos', & - comm_atoms=.true.) - call add_property(this%atoms, 'oldpos', 0.0_dp, n_cols=3, error=error) - PASS_ERROR(error) - - ! Update pointers in this%atoms so we can use this%atoms%velo etc. - call atoms_repoint(this%atoms) - - ! Set mass - unless already specified - if (maxval(abs(this%atoms%mass)) < 1e-5_dp) then - this%atoms%mass = ElementMass(this%atoms%Z) - end if - - ! The input arrays must have 3N components if they are present - ! if not, local arrays are set to zero - - if(present(velocity)) then - call check_size('Velocity',velocity,(/3,N/),'DS_Initialise',error) - PASS_ERROR(error) - this%atoms%velo = velocity - end if - - if(present(acceleration)) then - call check_size('Acceleration',acceleration,(/3,N/),'DS_Initialise',error) - PASS_ERROR(error) - this%atoms%acc = acceleration - end if - - ! Initialize oldpos and avgpos - if (added_avgpos) then - do i = 1, this%N - this%atoms%avgpos(:,i) = realpos(this%atoms,i) - end do - endif - this%atoms%oldpos = this%atoms%avgpos - if (added_avgke) then - do i=1, this%atoms%N - this%atoms%avg_ke(i) = 0.5_dp*this%atoms%mass(i)*normsq(this%atoms%velo(:,i)) - end do - endif - - ! Check for constraints - if (present(constraints)) then - if (constraints > 0) then - allocate(this%constraint(constraints)) - this%Nconstraints = 0 - end if - end if - - ! Check for restraints - if (present(restraints)) then - if (restraints > 0) then - allocate(this%restraint(restraints)) - this%Nrestraints = 0 - end if - end if - - ! Check for rigid bodies - if (present(rigidbodies)) then - if (rigidbodies > 0) then - allocate(this%rigidbody(rigidbodies)) - this%Nrigid = 0 - end if - end if - - ! Initialise all the groups, default to TYPE_ATOM - do i = 1, this%N - call initialise(this%group(i),TYPE_ATOM, atoms = (/i/)) - this%group_lookup(i) = i - end do - - this%Ndof = 3 * this%N - - allocate(this%thermostat(0:0)) - call initialise(this%thermostat(0),THERMOSTAT_NONE,0.0_dp) !a dummy thermostat, which is turned into - !a langevin thermostat if damping is needed - call initialise(this%barostat,BAROSTAT_NONE) - this%cur_temp = temperature(this, include_all=.true., instantaneous=.true.) - this%avg_temp = this%cur_temp - - this%initialised = .true. - - call verbosity_push_decrement(PRINT_ANALYSIS) - call print(this) - call verbosity_pop() - - end subroutine ds_initialise - - - subroutine ds_finalise(this, error) - - type(DynamicalSystem), intent(inout) :: this - integer, optional, intent(out) :: error - - ! --- - - INIT_ERROR(error) - - if (this%initialised) then - call finalise_ptr(this%atoms) - call finalise(this%group) - deallocate(this%group_lookup) - - !Finalise constraints - if (allocated(this%constraint)) call finalise(this%constraint) - - !Finalise restraints - if (allocated(this%restraint)) call finalise(this%restraint) - - !Finalise rigid bodies - if (allocated(this%rigidbody)) call finalise(this%rigidbody) - - call finalise(this%thermostat) - call finalise(this%barostat) - - this%N = 0 - this%nSteps = 0 - this%Nrigid = 0 - this%Nconstraints = 0 - this%Nrestraints = 0 - this%Ndof = 0 - this%t = 0.0_dp - this%avg_temp = 0.0_dp - this%dW = 0.0_dp - this%work = 0.0_dp - this%thermostat_dW = 0.0_dp - this%thermostat_work = 0.0_dp - this%ext_energy = 0.0_dp - this%Epot = 0.0_dp - - this%initialised = .false. - - end if - - end subroutine ds_finalise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X FREE EXCESS MEMORY USED BY GROUPS - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Free up excess memory used by Groups - subroutine ds_free_groups(this) - - type(DynamicalSystem), intent(inout) :: this - - call tidy_groups(this%group) - call groups_create_lookup(this%group,this%group_lookup) - - end subroutine ds_free_groups - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X ASSIGNMENT - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Overloaded assignment operator for DynamicalSystems - subroutine ds_assignment(to,from) - - type(DynamicalSystem), intent(inout) :: to - type(DynamicalSystem), intent(in) :: from - - integer :: from_constraint_size, from_restraint_size, from_rigidbody_size - - ! Re-initialise the destination object to be the correct size. - ! Note: size(from%constraint) in general is not equal to from%Nconstraints etc. - ! Also, the constraints aren't added using add_constraint etc. since this - ! will automatically evaluate the constraints at the current positions, which may not - ! correspond to the values currently stored. Same for rigid bodies. - - from_constraint_size = 0 - if (allocated(from%constraint)) from_constraint_size = size(from%constraint) - from_restraint_size = 0 - if (allocated(from%restraint)) from_restraint_size = size(from%restraint) - from_rigidbody_size = 0 - if (allocated(from%rigidbody)) from_rigidbody_size = size(from%rigidbody) - - call initialise(to, from%atoms, constraints=from_constraint_size, restraints=from_restraint_size, rigidbodies=from_rigidbody_size) - - ! Copy over scalar members - ! to%N is set in the initialisation 1 - to%nSteps = from%nSteps !2 - to%Nrigid = from%Nrigid !4 - to%Nconstraints = from%Nconstraints !5 - to%Nrestraints = from%Nrestraints !5 - to%Ndof = from%Ndof !6 - - to%t = from%t !8 - to%avg_temp = from%avg_temp !11 - to%avg_time = from%avg_time !12 - to%dW = from%dW !18 - to%work = from%work !19 - to%Epot = from%Epot !20 - to%ext_energy = from%ext_energy !21 - to%thermostat_dW = from%thermostat_dW !22 - to%thermostat_work = from%thermostat_work !23 - ! to%initialised is set in initialisation - - ! Copy over array members - to%group_lookup = from%group_lookup - - ! Derived type members - ! to%atoms already set - if (from%Nconstraints /= 0) to%constraint = from%constraint - if (from%Nrestraints /= 0) to%restraint = from%restraint - if (from%Nrigid /= 0) to%rigidbody = from%rigidbody - if (size(to%group)/=size(from%group)) then - deallocate(to%group) - allocate(to%group(size(from%group))) - end if - to%group = from%group - - ! Copy thermostats - will have been wiped by ds_initialise - ! (uses overloaded routine to copy array of thermostats) - ! to%thermostat = from%thermostat - call thermostat_array_assignment(to%thermostat, from%thermostat) - to%barostat = from%barostat - - end subroutine ds_assignment - - !% Save the state of a DynamicalSystem. The output object - !% cannot be used as an initialised DynamicalSystem since - !% connectivity and group information is not copied to save - !% memory. Only scalar members and the 'ds%atoms' object - !% (minus 'ds%atoms%connect') are copied. The current - !% state of the random number generator is also saved. - subroutine ds_save_state(to, from, error) - - type(DynamicalSystem), intent(inout) :: to - type(DynamicalSystem), intent(in) :: from - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if (.not. to%initialised) then - RAISE_ERROR('ds_save_state: target DynamicalSystem "to" not initialised', error) - end if - - if (associated(to%atoms, from%atoms)) then - ! Both DynamicalSystem object point to the same Atoms object, so we - ! need to allocate our own buffer. - allocate(to%atoms) - to%atoms%own_this = .true. - endif - - ! Copy over scalar members - to%N = from%N !1 - to%nSteps = from%nSteps !2 - to%Nrigid = from%Nrigid !4 - to%Nconstraints = from%Nconstraints !5 - to%Nrestraints = from%Nrestraints !6 - to%Ndof = from%Ndof !7 - - to%t = from%t !8 - to%avg_temp = from%avg_temp !11 - to%avg_time = from%avg_time !12 - to%dW = from%dW !18 - to%work = from%work !19 - to%Epot = from%Epot !20 - to%ext_energy = from%ext_energy !21 - to%thermostat_dW = from%thermostat_dW !22 - to%thermostat_work = from%thermostat_work !23 - - to%random_seed = system_get_random_seed() - - call atoms_copy_without_connect(to%atoms, from%atoms, error=error) - PASS_ERROR(error) - - end subroutine ds_save_state - - !% Restore a DynamicalSystem to a previously saved state. - !% Only scalar members and 'ds%atoms' (minus 'ds%atoms%connect') - !% are copied back; 'to' should be a properly initialised - !% DynamicalSystem object. The saved state of the random - !% number generator is also restored. 'calc_dists()' is - !% called on the restored atoms object. - subroutine ds_restore_state(to, from) - - type(DynamicalSystem), intent(inout) :: to - type(DynamicalSystem), intent(in) :: from - - ! Copy over scalar members - to%N = from%N !1 - to%nSteps = from%nSteps !2 - to%Nrigid = from%Nrigid !4 - to%Nconstraints = from%Nconstraints !5 - to%Nrestraints = from%Nrestraints !6 - to%Ndof = from%Ndof !7 - - to%t = from%t !8 - to%avg_temp = from%avg_temp !11 - to%avg_time = from%avg_time !12 - to%dW = from%dW !18 - to%work = from%work !19 - to%Epot = from%Epot !20 - to%ext_energy = from%ext_energy !21 - to%thermostat_dW = from%thermostat_dW !22 - to%thermostat_work = from%thermostat_work !23 - - call system_reseed_rng(from%random_seed) - - call atoms_copy_without_connect(to%atoms, from%atoms) - call calc_dists(to%atoms) - - end subroutine ds_restore_state - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X ADDING / REMOVING ATOMS - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine ds_add_atom_single(this,z,mass,p,v,a,t, error) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: z - real(dp), optional, intent(in) :: mass - real(dp), optional, dimension(3), intent(in) :: p,v,a - integer, optional, dimension(3), intent(in) :: t - integer, optional, intent(out) :: error - - real(dp) :: my_mass, my_p(3), my_v(3), my_a(3) - integer :: my_t(3) - - INIT_ERROR(error) - - my_mass = optional_default(ElementMass(Z),mass) - my_p = optional_default((/0.0_dp,0.0_dp,0.0_dp/),p) - my_v = optional_default((/0.0_dp,0.0_dp,0.0_dp/),v) - my_a = optional_default((/0.0_dp,0.0_dp,0.0_dp/),a) - my_t = optional_default((/0,0,0/),t) - - call ds_add_atom_multiple(this, (/z/), (/my_mass/), & - reshape(my_p, (/3,1/)), & - reshape(my_v, (/3,1/)), & - reshape(my_a, (/3,1/)), & - reshape(my_t, (/3,1/)), error) - PASS_ERROR(error) - - end subroutine ds_add_atom_single - - ! - ! Updated to work with groups. NEEDS TESTING - ! - subroutine ds_add_atom_multiple(this,z,mass,p,v,a,t,error) - - type(DynamicalSystem), intent(inout) :: this - integer, dimension(:), intent(in) :: z - real(dp), dimension(:), optional, intent(in) :: mass - real(dp), dimension(:,:), optional, intent(in) :: p,v,a - integer, dimension(:,:), optional, intent(in) :: t - integer, optional, intent(out) :: error - - integer :: oldN, newN, n, f, i - integer, dimension(this%N) :: tmp_group_lookup - type(Group), dimension(:), allocatable :: tmp_group - - INIT_ERROR(error) - - oldN = this%N - - ! Check the sizes are ok - n = size(z) - call check_size('Position',p,(/3,n/),'DS_Add_Atoms',error) - PASS_ERROR(error) - - call check_size('Velocity',v,(/3,n/),'DS_Add_Atoms', error) - PASS_ERROR(error) - - call check_size('Acceleration',a,(/3,n/),'DS_Add_Atoms', error) - PASS_ERROR(error) - - newN = oldN + n - - !Copy all non-scalar data into the temps - tmp_group_lookup = this%group_lookup - - !Adjust the size of the dynamical system's arrays - deallocate(this%group_lookup) - allocate(this%group_lookup(newN)) - - ! Implement the changes in Atoms - call add_atoms(this%atoms,pos=p,Z=z,mass=mass,velo=v,acc=a,travel=t) - - !update the scalars (if needed) - this%N = newN - this%Ndof = this%Ndof + 3*n - - !See if there are enough free groups to accommodate the new atoms - f = Num_Free_Groups(this%group) - if (f < n) then - !We need more groups: - !Make a copy of the current groups - allocate(tmp_group(size(this%group))) - tmp_group = this%group - !Resize the group array - call finalise(this%group) - allocate(this%group(size(tmp_group) + n - f)) - !Copy the groups back - this%group(1:size(tmp_group)) = tmp_group - call finalise(tmp_group) - end if - - !Add the new groups - do i = oldN+1, newN - f = Free_Group(this%group) - call group_add_atom(this%group(f),i) - call set_type(this%group(f),TYPE_ATOM) !default to TYPE_ATOM - end do - - !Rebuild the lookup table - call groups_create_lookup(this%group,this%group_lookup) - - end subroutine ds_add_atom_multiple - - - subroutine ds_remove_atom_single(this,i,error) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i - integer, intent(out), optional :: error - - INIT_ERROR(error) - call ds_remove_atom_multiple(this,(/i/),error) - PASS_ERROR(error) - - end subroutine ds_remove_atom_single - - - - subroutine ds_remove_atom_multiple(this,atomlist_in,error) - - type(DynamicalSystem), intent(inout) :: this - integer, dimension(:), intent(in) :: atomlist_in - integer, intent(out), optional :: error - - integer, dimension(size(atomlist_in)) :: atomlist - integer :: oldN, newN, g, i, copysrc - - INIT_ERROR(error) - - !Make our own copy of the indices so that we can sort them - atomlist = atomlist_in - call insertion_sort(atomlist) - - !Check for repeated indices, and non-TYPE_ATOM atoms - do i = 1, size(atomlist) - if (Atom_Type(this,atomlist(i)) /= TYPE_ATOM) then - RAISE_ERROR('Remove_Atoms: Atom '//atomlist(i)//' is not a normal atom', error) - end if - if (i > 1) then - if (atomlist(i) == atomlist(i-1)) then - RAISE_ERROR('Remove_Atoms: Tried to remove the same atom twice ('//atomlist(i)//')', error) - end if - end if - end do - - oldN = this%N - newN = this%N - size(atomlist) - - ! Implement the data changes in the atoms structure - ! Since we're mangling the atom indices and some atoms are being removed, the - ! connection data will no longer be valid after this - call remove_atoms(this%atoms,atomlist) - - !Make sure the group lookup table is up-to-date - call groups_create_lookup(this%group,this%group_lookup) - - !Delete all atoms in atomlist from their respective groups - do i = 1, size(atomlist) - g = this%group_lookup(atomlist(i)) - call group_delete_atom(this%group(g),atomlist(i)) - end do - - ! Algorithm: Find first atom to be removed and last atom to not be removed - ! and swap them. Repeat until all atoms to be removed are at the end. - ! note: this loop must be logically identical to the corresponding one in - ! Atoms - copysrc = oldN - do i=1,size(atomlist) - - do while(Is_in_array(atomlist,copysrc)) - copysrc = copysrc - 1 - end do - - if (atomlist(i) > copysrc) exit - - !Relabel copysrc to atomlist(i) in copysrc's group - - g = this%group_lookup(copysrc) - call group_delete_atom(this%group(g),copysrc) - call group_add_atom(this%group(g),atomlist(i)) - - copysrc = copysrc - 1 - - end do - - !Resize dynamical system's arrays - deallocate(this%group_lookup) - allocate(this%group_lookup(newN)) - - !Update scalars - this%N = newN - this%Ndof = this%Ndof - 3*size(atomlist) - - !Rebuild the group lookup table - call groups_create_lookup(this%group,this%group_lookup) - - end subroutine ds_remove_atom_multiple - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Atom - Group lookup - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - !% Look up the type of the group that atom i belongs to - ! - pure function atom_type(this,i) - - type(DynamicalSystem), intent(in) :: this - integer, intent(in) :: i - integer :: atom_type - - atom_type = this%group(this%group_lookup(i))%type - - end function atom_type - - ! - !% If an atom is in the list, add the rest of its group - ! - subroutine add_group_members(this,list) - - type(dynamicalsystem), intent(in) :: this - type(table), intent(inout) :: list - - integer :: i, j, n, g, nn, jn - - do n = 1, list%N - - i = list%int(1,n) - g = this%group_lookup(i) - do nn = 1, Group_N_Atoms(this%group(g)) - j = Group_Nth_Atom(this%group(g),nn) - jn = find_in_array(int_part(list,1),j) - if (jn == 0) call append(list,(/j,list%int(2:,n)/)) - end do - - end do - - end subroutine add_group_members - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Adding a thermostat - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine ds_set_barostat(this,type,p_ext,hydrostatic_strain,diagonal_strain,finite_strain_formulation,tau_epsilon,W_epsilon,T,W_epsilon_factor,thermalise) - type(dynamicalsystem), intent(inout) :: this - integer, intent(in) :: type - real(dp), intent(in) :: p_ext - logical, intent(in) :: hydrostatic_strain, diagonal_strain, finite_strain_formulation - real(dp), intent(in) :: tau_epsilon - real(dp), optional, intent(in) :: W_epsilon, T, W_epsilon_factor - logical, optional, intent(in) :: thermalise - - real(dp) :: gamma_epsilon - - if (tau_epsilon > 0.0_dp) then - gamma_epsilon = 1.0_dp/tau_epsilon - else - gamma_epsilon = 0.0_dp - endif - - call initialise(this%barostat, type=type, p_ext=p_ext, hydrostatic_strain=hydrostatic_strain, diagonal_strain=diagonal_strain, & - finite_strain_formulation=finite_strain_formulation, cell_volume=cell_volume(this%atoms), W_epsilon=W_epsilon, & - Ndof=real(this%Ndof,dp), gamma_epsilon=gamma_epsilon, T=T, W_epsilon_factor=W_epsilon_factor, thermalise=thermalise) - - end subroutine ds_set_barostat - - function n_thermostat(this) - type(dynamicalsystem), intent(in) :: this - integer n_thermostat - - n_thermostat = size(this%thermostat) - - end function n_thermostat - - subroutine ds_remove_thermostat(this, index) - type(dynamicalsystem), intent(inout) :: this - integer, intent(in) :: index - - call remove_thermostat(this%thermostat, index) - - end subroutine ds_remove_thermostat - - subroutine ds_add_thermostat(this,type,T,gamma,Q,tau,tau_cell, p, bulk_modulus_estimate, cell_oscillation_time, NHL_tau, NHL_mu, massive, region_i) - - type(dynamicalsystem), intent(inout) :: this - integer, intent(in) :: type - real(dp), intent(in) :: T - real(dp), optional, intent(in) :: gamma - real(dp), optional, intent(in) :: Q - real(dp), optional, intent(in) :: tau - real(dp), optional, intent(in) :: tau_cell - real(dp), optional, intent(in) :: bulk_modulus_estimate - real(dp), optional, intent(in) :: cell_oscillation_time - real(dp), optional, intent(in) :: p - real(dp), optional, intent(in) :: NHL_tau, NHL_mu - logical, optional, intent(in) :: massive - integer, optional, intent(out) :: region_i - - real(dp) :: w_p, gamma_cell, volume_0, my_bulk_modulus_estimate, my_cell_oscillation_time !, mass1, mass2 - real(dp) :: gamma_eff, NHL_gamma_eff - - if (.not. present(Q)) then - if (count( (/present(gamma), present(tau) /) ) /= 1 ) & - call system_abort('ds_add_thermostat: exactly one of gamma, tau must be present if Q is not') - endif - - if (present(gamma)) then - gamma_eff = gamma - if (present(tau)) call print("WARNING: ds_add_thermostat got gamma and tau, gamma overriding tau", PRINT_ALWAYS) - else - gamma_eff = 0.0_dp - if (present(tau)) then - if (tau /= 0.0_dp) then - gamma_eff = 1.0_dp/tau - endif - endif - endif - - NHL_gamma_eff = 0.0_dp - if (present(NHL_tau)) then - if (NHL_tau > 0.0_dp) NHL_gamma_eff = 1.0_dp/NHL_tau - endif - - volume_0 = cell_volume(this%atoms) - - if(present(p)) then - if(present(tau_cell)) then - gamma_cell = 1.0_dp / tau_cell - else - gamma_cell = gamma_eff * 0.1_dp - endif - - my_cell_oscillation_time = optional_default(10.0_dp/gamma_cell,cell_oscillation_time) - my_bulk_modulus_estimate = optional_default(100.0_dp/EV_A3_IN_GPA,bulk_modulus_estimate) - - w_p = 3.0_dp * my_bulk_modulus_estimate * volume_0 * my_cell_oscillation_time**2 / ((2.0_dp*PI)**2) - - endif - call add_thermostat(this%thermostat,type,T,gamma_eff,Q,p,gamma_cell,w_p,volume_0, & - NHL_gamma=NHL_gamma_eff, NHL_mu=NHL_mu, massive=massive, region_i=region_i) - - end subroutine ds_add_thermostat - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Adding many thermostats - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine ds_add_thermostats(this,type,n,T,T_a,gamma,gamma_a,Q,Q_a,tau,tau_a,region_i) - - type(dynamicalsystem), intent(inout) :: this - integer, intent(in) :: type - integer, intent(in) :: n - real(dp), optional, target, intent(in) :: T, T_a(:) - real(dp), optional, target, intent(in) :: gamma, gamma_a(:) - real(dp), optional, target, intent(in) :: Q, Q_a(:) - real(dp), optional, intent(in) :: tau, tau_a(:) - integer, optional, intent(out) :: region_i - - real(dp), allocatable :: gamma_eff_a(:) - real(dp), pointer :: use_T_a(:), use_Q_a(:) - - if (count( (/present(T), present(T_a) /) ) /= 1 ) & - call system_abort('ds_add_thermostat: exactly one of T, T_a must be present') - - if (count( (/present(Q), present(Q_a) /) ) > 1 ) & - call system_abort('ds_add_thermostat: at most one of Q, Q_a must be present') - - if (count( (/present(gamma), present(gamma_a), present(tau), present(tau_a) /) ) /= 1 ) & - call system_abort('ds_add_thermostat: exactly one of gamma, gamma_a, tau, tau_a must be present') - - if (present(T)) then - allocate(use_T_a(n)) - use_T_a = T - else - use_T_a => T_a - endif - - if (present(Q)) then - allocate(use_Q_a(n)) - use_Q_a = Q - else if (present(Q_a)) then - use_Q_a => Q_a - end if - - allocate(gamma_eff_a(n)) - if (present(gamma)) then - gamma_eff_a = gamma - else ! tau or tau_a - if (present(tau)) then - gamma_eff_a = 1.0_dp/tau - else - gamma_eff_a = 1.0_dp/tau_a - endif - endif - - if (associated(use_Q_a)) then - call add_thermostats(this%thermostat,type,n,use_T_a,gamma_eff_a,use_Q_a,region_i=region_i) - else - call add_thermostats(this%thermostat,type,n,use_T_a,gamma_eff_a,region_i=region_i) - endif - - deallocate(gamma_eff_a) - if (present(Q)) deallocate(use_Q_a) - if (present(T)) deallocate(use_T_a) - - end subroutine ds_add_thermostats - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Updating a thermostat - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine ds_update_thermostat(this,T,p,i) - - type(dynamicalsystem), intent(inout) :: this - real(dp), optional, intent(in) :: T - real(dp), optional, intent(in) :: p - integer, optional, intent(in) :: i - - !real(dp) :: w_p, mass1, mass2, my_T - integer :: my_i - - my_i = optional_default(1,i) - - call update_thermostat(this%thermostat(my_i),T=T,p=p) - - end subroutine ds_update_thermostat - - subroutine ds_update_barostat(this,p,T) - type(dynamicalsystem), intent(inout) :: this - real(dp), optional, intent(in) :: p, T - - if (.not. present(p)) call system_abort("ds_upadte_barostat needs p") - call update_barostat(this%barostat, p_ext=p, W_epsilon=barostat_mass(p, cell_volume(this%atoms), this%Ndof, this%barostat%gamma_epsilon, T)) - end subroutine ds_update_barostat - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X enable/disable damping - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function is_damping_enabled(this) - type(DynamicalSystem), intent(in) :: this - logical is_damping_enabled - - if (this%thermostat(0)%type == THERMOSTAT_NONE) then - is_damping_enabled = .false. - else - is_damping_enabled = .true. - end if - - end function is_damping_enabled - - function get_damping_time(this) - type(DynamicalSystem), intent(in) :: this - real(dp) :: get_damping_time - - if (.not. is_damping_enabled(this)) & - call system_abort('get_damping_time: damping is not enabled') - get_damping_time = 1.0_dp/this%thermostat(0)%gamma - - end function get_damping_time - - !% Enable damping, with damping time set to `damp_time`. Only atoms - !% flagged in the `damp_mask` property will be affected. - subroutine enable_damping(this,damp_time) - - type(dynamicalsystem), intent(inout) :: this - real(dp), intent(in) :: damp_time - - if (damp_time <= 0.0_dp) call system_abort('enable_damping: damp_time must be > 0') - call initialise(this%thermostat(0),THERMOSTAT_LANGEVIN,0.0_dp,gamma=1.0_dp/damp_time) - - end subroutine enable_damping - - subroutine disable_damping(this) - - type(dynamicalsystem), intent(inout) :: this - call initialise(this%thermostat(0),THERMOSTAT_NONE) - - end subroutine disable_damping - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Procedures for returning/changing the state of the system - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Return the total momentum $\mathbf{p} = \sum_i \mathbf{m_i} \mathbf{v_i}$. - !% Optionally only include the contribution of a subset of atoms. - pure function ds_momentum(this,indices) result(p) ! sum(mv) - type(DynamicalSystem), intent(in) :: this - integer, optional, dimension(:), intent(in) :: indices - real(dp) :: p(3) - - p = momentum(this%atoms, indices) - end function ds_momentum - - !% Return the total momentum $\mathbf{p} = \sum_i \mathbf{m_i} \mathbf{v_i}$. - !% Optionally only include the contribution of a subset of atoms. - pure function atoms_momentum(this,indices) result(p) ! sum(mv) - type(Atoms), intent(in) :: this - integer, optional, dimension(:), intent(in) :: indices - real(dp) :: p(3) - - p = momentum(this%mass, this%velo, indices) - end function atoms_momentum - - !% Return the total momentum $\mathbf{p} = \sum_i \mathbf{m_i} \mathbf{v_i}$. - !% Optionally only include the contribution of a subset of atoms. - pure function arrays_momentum(mass, velo, indices) result(p) ! sum(mv) - real(dp), intent(in) :: mass(:) - real(dp), intent(in) :: velo(:,:) - integer, optional, dimension(:), intent(in) :: indices - - real(dp) :: p(3) - integer :: i, N - - N = size(mass) - p = 0.0_dp - if (present(indices)) then - do i = 1,size(indices) - p = p + velo(:,indices(i)) * mass(indices(i)) - end do - else - do i = 1,N - p = p + velo(:,i) * mass(i) - end do - end if - end function arrays_momentum - - !% Return the angular momentum of all the atoms in this DynamicalSystem, defined by - !% $\mathbf{L} = \sum_{i} \mathbf{r_i} \times \mathbf{v_i}$. - pure function ds_angular_momentum(this, origin, indices) result(L) - type(DynamicalSystem), intent(in) :: this - real(dp), intent(in), optional :: origin(3) - integer, intent(in), optional :: indices(:) - real(dp) :: L(3) - - L = angular_momentum(this%atoms, origin, indices) - end function ds_angular_momentum - - !% Return the angular momentum of all the atoms in this DynamicalSystem, defined by - !% $\mathbf{L} = \sum_{i} \mathbf{r_i} \times \mathbf{v_i}$. - pure function atoms_angular_momentum(this, origin, indices) result(L) - type(Atoms), intent(in) :: this - real(dp), intent(in), optional :: origin(3) - integer, intent(in), optional :: indices(:) - real(dp) :: L(3) - - L = angular_momentum(this%mass, this%pos, this%velo, origin, indices) - end function atoms_angular_momentum - - !% Return the angular momentum of all the atoms in this DynamicalSystem, defined by - !% $\mathbf{L} = \sum_{i} \mathbf{r_i} \times \mathbf{v_i}$. - pure function arrays_angular_momentum(mass, pos, velo, origin, indices) result(L) - real(dp), intent(in) :: mass(:) - real(dp), intent(in) :: pos(:,:), velo(:,:) - real(dp), intent(in), optional :: origin(3) - integer, intent(in), optional :: indices(:) - real(dp) :: L(3) - - integer :: ii, i, N - - if (present(indices)) then - N = size(indices) - else - N = size(mass) - endif - - L = 0.0_dp - do ii = 1, N - if (present(indices)) then - i = indices(ii) - else - i = ii - end if - if (present(origin)) then - L = L + mass(i) * ((pos(:,i)-origin) .cross. velo(:,i)) - else - L = L + mass(i) * (pos(:,i) .cross. velo(:,i)) - endif - end do - - end function arrays_angular_momentum - - !% Return the moment of inertia of all the atoms in this DynamicalSystem about a particular axis - !% placed at (optional) origin - !% $I = \sum_{i} m_i |\mathbf{r_i}-\mathbf{o}|^2 $. - pure function moment_of_inertia(this,axis,origin) result (MoI) - type(Atoms), intent(in) :: this - real(dp), intent(in) :: axis(3) - real(dp), intent(in), optional :: origin(3) - real(dp) :: MoI - - real(dp) :: my_origin(3) - integer i - real(dp) :: dr_proj(3), dr(3), dr_normal(3) - real(dp) :: axis_hat(3) - - if (present(origin)) then - my_origin = origin - else - my_origin = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - end if - - axis_hat = axis/norm(axis) - - MoI = 0.0_dp - do i=1, this%N - dr = (this%pos(:,i)-my_origin) - dr_proj = (dr.dot.axis_hat)*axis_hat - dr_normal = dr - dr_proj - MoI = MoI + this%mass(i)*normsq(dr_normal) - end do - end function moment_of_inertia - - pure function moment_of_inertia_tensor(this,origin) result (MoI) - type(Atoms), intent(in) :: this - real(dp), intent(in), optional :: origin(3) - real(dp) :: MoI(3,3) - - real(dp) :: dr(3) - real(dp) :: m - integer i, ii, jj - - MoI = 0.0_dp - do i=1, this%N - m = this%mass(i) - if (present(origin)) then - dr = this%pos(:,i)-origin - else - dr = this%pos(:,i) - endif - do ii=1,3 - do jj=1,3 - if (ii == jj) MoI(ii,jj) = MoI(ii,jj) + m*normsq(dr) - MoI(ii,jj) = MoI(ii,jj) - m*dr(ii)*dr(jj) - end do - end do - end do - end function moment_of_inertia_tensor - - !% Return the total kinetic energy $E_k = \sum_{i} \frac{1}{2} m v^2$ - function DS_kinetic_energy(this, mpi_obj, local_ke, error) result(ke) ! sum(0.5mv^2) - type(DynamicalSystem), intent(in) :: this - type(MPI_context), optional, intent(in) :: mpi_obj - logical, optional, intent(in) :: local_ke - integer, optional, intent(out) :: error - real(dp) :: ke - - INIT_ERROR(error) - ke = kinetic_energy(this%atoms, mpi_obj, local_ke, error=error) - PASS_ERROR(error) - end function DS_kinetic_energy - - !% Return the total kinetic energy $E_k = \sum_{i} \frac{1}{2} m v^2$ - function atoms_kinetic_energy(this, mpi_obj, local_ke, error) result(ke) ! sum(0.5mv^2) - type(atoms), intent(in) :: this - type(MPI_context), optional, intent(in) :: mpi_obj - logical, optional, intent(in) :: local_ke - integer, optional, intent(out) :: error - real(dp) :: ke - - real(dp), pointer :: local_ke_p(:) - - logical :: do_local_ke - - INIT_ERROR(error) - if (.not. associated(this%mass)) call system_abort("atoms_kinetic_energy called on atoms without mass property") - if (.not. associated(this%velo)) call system_abort("atoms_kinetic_energy called on atoms without velo property") - - do_local_ke = optional_default(.false., local_ke) - if (do_local_ke) then - if (.not. assign_pointer(this, 'local_ke', local_ke_p)) then - RAISE_ERROR("atoms_kinetic_energy got local_ke but no local_ke property", error) - endif - local_ke_p = 0.0_dp - ke = kinetic_energy(this%mass(1:this%Ndomain), this%velo(1:3, 1:this%Ndomain), local_ke_p(1:this%Ndomain)) - else - ke = kinetic_energy(this%mass(1:this%Ndomain), this%velo(1:3, 1:this%Ndomain)) - endif - - if (present(mpi_obj)) then - call sum_in_place(mpi_obj, ke, error=error) - PASS_ERROR(error) - if (do_local_ke) then - call sum_in_place(mpi_obj, local_ke_p, error=error) - PASS_ERROR(error) - endif - endif - end function atoms_kinetic_energy - - !% Return the kinetic energy given a mass and a velocity - pure function single_kinetic_energy(mass, velo) result(ke) - real(dp), intent(in) :: mass, velo(3) - real(dp) :: ke - - ke = 0.5_dp*mass * normsq(velo) - end function single_kinetic_energy - - !% Return the total kinetic energy given atomic masses and velocities - function arrays_kinetic_energy(mass, velo, local_ke) result(ke) - real(dp), intent(in) :: mass(:) - real(dp), intent(in) :: velo(:,:) - real(dp), intent(inout), optional :: local_ke(:) - real(dp) :: ke - - if (present(local_ke)) then - local_ke = 0.5_dp * sum(velo**2,dim=1)*mass - endif - ke = 0.5_dp * sum(sum(velo**2,dim=1)*mass) - end function arrays_kinetic_energy - - !% Return the total kinetic virial $w_ij = \sum_{k} \frac{1}{2} m v_i v_j$ - function DS_kinetic_virial(this, mpi_obj, error) result(kv) ! sum(0.5mv^2) - type(DynamicalSystem), intent(in) :: this - type(MPI_context), optional, intent(in) :: mpi_obj - integer, optional, intent(out) :: error - real(dp), dimension(3,3) :: kv - - INIT_ERROR(error) - kv = kinetic_virial(this%atoms, mpi_obj, error=error) - PASS_ERROR(error) - end function DS_kinetic_virial - - !% Return the total kinetic virial $w_ij = \sum_{k} \frac{1}{2} m v_i v_j$ - function atoms_kinetic_virial(this, mpi_obj, error) result(kv) ! sum(0.5mv^2) - type(atoms), intent(in) :: this - type(MPI_context), optional, intent(in) :: mpi_obj - integer, optional, intent(out) :: error - real(dp), dimension(3,3) :: kv - - INIT_ERROR(error) - if (.not. associated(this%mass)) call system_abort("atoms_kinetic_virial called on atoms without mass property") - if (.not. associated(this%velo)) call system_abort("atoms_kinetic_virial called on atoms without velo property") - kv = kinetic_virial(this%mass(1:this%Ndomain), this%velo(1:3, 1:this%Ndomain)) - - if (present(mpi_obj)) then - call sum_in_place(mpi_obj, kv, error=error) - PASS_ERROR(error) - endif - end function atoms_kinetic_virial - - !% Return the kinetic virial given a mass and a velocity - pure function single_kinetic_virial(mass, velo) result(kv) - real(dp), intent(in) :: mass, velo(3) - real(dp), dimension(3,3) :: kv - - kv = mass * (velo .outer. velo) - end function single_kinetic_virial - - !% Return the total kinetic virial given atomic masses and velocities - pure function arrays_kinetic_virial(mass, velo) result(kv) - real(dp), intent(in) :: mass(:) - real(dp), intent(in) :: velo(:,:) - real(dp), dimension(3,3) :: kv - - kv = matmul(velo*spread(mass,dim=1,ncopies=3),transpose(velo)) - end function arrays_kinetic_virial - - pure function torque(pos, force, origin) result(tau) - real(dp), intent(in) :: pos(:,:), force(:,:) - real(dp), intent(in), optional :: origin(3) - real(dp) :: tau(3) - - integer i, N - - N = size(pos,2) - tau = 0.0_dp - do i=1, N - if (present(origin)) then - tau = tau + ((pos(:,i)-origin).cross.force(:,i)) - else - tau = tau + (pos(:,i).cross.force(:,i)) - endif - end do - end function torque - - subroutine thermostat_temperatures(this, temps) - type(DynamicalSystem), intent(in) :: this - real(dp), intent(out) :: temps(:) - - integer :: i - - if (size(temps) /= size(this%thermostat)) & - call system_abort("thermostat_temperatures needs a temps array to match size of this%thermostat() " //size(this%thermostat)) - - temps = -1.0_dp - if (this%thermostat(0)%type == THERMOSTAT_LANGEVIN) then - temps(1) = temperature(this, property='damp_mask', value=1, instantaneous=.true.) - endif - do i=1, size(this%thermostat)-1 - if (this%thermostat(i)%type /= THERMOSTAT_NONE) temps(i+1) = temperature(this, property='thermostat_region', value=i, instantaneous=.true.) - end do - end subroutine thermostat_temperatures - - !% Return the temperature, assuming each degree of freedom contributes - !% $\frac{1}{2}kT$. By default only moving and thermostatted atoms are - !% included --- this can be overriden by setting 'include_all' to true. - !% 'region' can be used to restrict - !% the calculation to a particular thermostat - !% region. 'instantaneous' controls whether the calculation should - !% be carried out using the current values of the velocities and - !% masses, or whether to return the value at the last Verlet step - !% (the latter is the default). - function temperature(this, property, value, include_all, instantaneous, & - mpi_obj, error) - type(DynamicalSystem), intent(in) :: this - character(len=*), intent(in), optional :: property - integer, intent(in), optional :: value - logical, intent(in), optional :: include_all - logical, intent(in), optional :: instantaneous - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - real(dp) :: temperature - - logical :: my_include_all, my_instantaneous - integer :: i, N - real(dp) :: Ndof - integer, pointer :: property_p(:) - - my_instantaneous = optional_default(.false., instantaneous) - my_include_all = optional_default(.false., include_all) - - if (my_instantaneous) then - nullify(property_p) - if (present(property)) then - if (.not. present(value)) then - RAISE_ERROR("temperature called with property but no value to match", error) - endif - if (.not. assign_pointer(this%atoms, trim(property), property_p)) then - RAISE_ERROR("temperature failed to assign integer pointer for property '"//trim(property)//"'", error) - endif - endif - - temperature = 0.0_dp - N = 0 - Ndof = 0.0_dp - do i = 1,this%atoms%Ndomain - if (associated(property_p)) then - if (property_p(i) == value .and. this%atoms%move_mask(i) == 1) then - temperature = temperature + this%atoms%mass(i) * normsq(this%atoms%velo(:,i)) - N = N + 1 - Ndof = Ndof + degrees_of_freedom(this,i) - end if - else - if (my_include_all .or. (this%atoms%move_mask(i) == 1)) then - temperature = temperature + this%atoms%mass(i) * normsq(this%atoms%velo(:,i)) - N = N + 1 - Ndof = Ndof + degrees_of_freedom(this,i) - end if - end if - end do - - if (present(mpi_obj)) then - call sum_in_place(mpi_obj, temperature, error=error) - PASS_ERROR(error) - call sum_in_place(mpi_obj, N, error=error) - PASS_ERROR(error) - call sum_in_place(mpi_obj, Ndof, error=error) - PASS_ERROR(error) - endif - - if (N /= 0) temperature = temperature / ( Ndof * BOLTZMANN_K ) - else - temperature = this%cur_temp - endif - - end function temperature - - !% Add or remove heat from the system by scaling the atomic velocities - subroutine add_heat(this, heat, Ekin) - - type(DynamicalSystem), intent(inout) :: this - real(dp), intent(in) :: heat, Ekin - real(dp) :: r - - if ( Ekin + heat < 0.0_dp ) call System_Abort('AddHeat: Tried to remove too much heat') - - r = sqrt((Ekin+heat)/Ekin) - - this%atoms%velo = this%atoms%velo * r - this%Wkin = kinetic_virial(this) - this%Ekin = trace(this%Wkin)/2 - - end subroutine add_heat - - !% Rescale the atomic velocities to temperature 'temp'. If the - !% current temperature is zero, we first randomise the velocites. - !% If 'mass_weighted' is true, then the velocites are weighted by - !% $1/sqrt{m}$. Linear momentum is zeroed automatically. If - !% 'zero_l' is true then the angular momentum is also zeroed. - subroutine rescale_velo(this, temp, mass_weighted, zero_L) - type(DynamicalSystem), intent(inout) :: this - real(dp), intent(in) :: temp - logical, intent(in), optional :: mass_weighted, zero_L - - logical :: my_mass_weighted, my_zero_L - real(dp) :: r, currTemp - - my_mass_weighted = optional_default(.true., mass_weighted) - my_zero_L = optional_default(.false., zero_L) - currTemp = temperature(this, instantaneous=.true.) - call print("Rescaling velocities from "//currTemp//" K to "//temp//" K") - - if ( currTemp .feq. 0.0_dp ) then - call print('Randomizing velocities') - if (my_mass_weighted) then - call randomise(this%atoms%velo, 1.0_dp/sqrt(this%atoms%mass)) - else - call randomise(this%atoms%velo, 1.0_dp) - endif - call print('Zeroing total momentum') - call zero_momentum(this) - if (my_zero_L) then - call print('Zeroing angular momentum') - call zero_angular_momentum(this%atoms) - endif - currTemp = temperature(this, instantaneous=.true.) - end if - - r = sqrt(temp/currTemp) - this%atoms%velo = this%atoms%velo * r - - this%Wkin = kinetic_virial(this) - this%Ekin = trace(this%Wkin)/2 - end subroutine rescale_velo - - !% Reinitialise the atomic velocities to temperature 'temp'. - !% We first randomise the velocites. - subroutine reinitialise_velo_normal(this, temp, mass_weighted, zero_L) - type(DynamicalSystem), intent(inout) :: this - real(dp), intent(in) :: temp - logical, intent(in), optional :: mass_weighted, zero_L - - logical :: my_mass_weighted, my_zero_L - real(dp) :: r, currTemp - integer :: i - - my_mass_weighted = optional_default(.true., mass_weighted) - my_zero_L = optional_default(.false., zero_L) - currTemp = temperature(this, instantaneous=.true.) - - !call print('Randomizing velocities') - if (my_mass_weighted) then - do i=1,this%atoms%N - this%atoms%velo(1:3,i) = ran_normal3()/sqrt(this%atoms%mass(i)) - enddo - else - do i=1,this%atoms%N - this%atoms%velo(1:3,i) = ran_normal3() - enddo - endif - !call print('Zeroing total momentum') - call zero_momentum(this) - if (my_zero_L) then - call print('Zeroing angular momentum') - call zero_angular_momentum(this%atoms) - endif - currTemp = temperature(this, instantaneous=.true.) - - r = sqrt(temp/currTemp) - this%atoms%velo = this%atoms%velo * r - end subroutine reinitialise_velo_normal - - !% Draw a velocity component from the correct Gaussian distribution for - !% a degree of freedom with (effective) mass 'm' at temperature 'T' - function gaussian_velocity_component(m,T) result(v) - - real(dp), intent(in) :: m, T - real(dp) :: v - - v = sqrt(BOLTZMANN_K * T / m) * ran_normal() - - end function gaussian_velocity_component - - !% Construct a velocity vector for a particle of mass 'm' - !% at temperature 'T' from Gaussian distributed components - function gaussian_velocity(m,T) result(v) - - real(dp), intent(in) :: m,T - real(dp), dimension(3) :: v - - v(1) = gaussian_velocity_component(m,T) - v(2) = gaussian_velocity_component(m,T) - v(3) = gaussian_velocity_component(m,T) - - end function gaussian_velocity - - !% Change velocities to those that the system would have in the zero momentum frame. - !% Optionalally zero the total momentum of a subset of atoms, specified by 'indices'. - subroutine zero_momentum(this,indices) - - type(DynamicalSystem), intent(inout) :: this - integer, optional, dimension(:), intent(in) :: indices - real(dp) :: p(3) - integer :: i - - if (present(indices)) then - p = momentum(this,indices)/size(indices) - forall(i=1:size(indices)) this%atoms%velo(:,indices(i)) = & - this%atoms%velo(:,indices(i)) - p/this%atoms%mass(indices(i)) - else - p = momentum(this)/real(this%N,dp) - forall(i=1:this%N) this%atoms%velo(:,i) = this%atoms%velo(:,i)-p/this%atoms%mass(i) - end if - - end subroutine zero_momentum - - !% give the system a rigid body rotation so as to zero the angular momentum about the centre of mass - subroutine zero_angular_momentum(this) - type(Atoms) :: this - - real(dp) :: CoM(3), L(3), MoI(3,3), MoI_inv(3,3), angular_vel(3) - real(dp) :: axis(3), angular_vel_mag - real(dp) :: dr(3), dr_parallel(3), dr_normal(3), v(3) - - integer i - - CoM = centre_of_mass(this) - L = angular_momentum(this,CoM) - MoI = moment_of_inertia_tensor(this,CoM) - call inverse(MoI, MoI_inv) - angular_vel = matmul(MoI_inv,L) - - angular_vel_mag = norm(angular_vel) - axis = angular_vel/angular_vel_mag - - if (angular_vel_mag .fne. 0.0_dp) then - do i=1, this%N - dr = this%pos(:,i)-CoM - dr_parallel = axis*(dr.dot.axis) - dr_normal = dr - dr_parallel - v = angular_vel_mag*(axis .cross. dr_normal) - this%velo(:,i) = this%velo(:,i) - v - end do - end if - end subroutine zero_angular_momentum - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Centre of Mass calculations - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Calculates the velocity of the centre of mass c.f. 'centre_of_mass' in Atoms module. No origin atom required. - pure function centre_of_mass_velo(this,index_list) result(V_CoM) - - type(DynamicalSystem), intent(in) :: this - integer, dimension(:), optional, intent(in) :: index_list - real(dp), dimension(3) :: V_CoM - !local variables - integer :: i - real(dp) :: M_tot - - V_CoM = 0.0_dp - M_tot = 0.0_dp - if (present(index_list)) then - do i = 1, size(index_list) - V_CoM = V_CoM + this%atoms%velo(:,index_list(i)) * this%atoms%mass(index_list(i)) - M_tot = M_tot + this%atoms%mass(index_list(i)) - end do - else - do i = 1, this%N - V_CoM = V_CoM + this%atoms%velo(:,i) * this%atoms%mass(i) - M_tot = M_tot + this%atoms%mass(i) - end do - end if - - V_CoM = V_CoM / M_tot - - end function centre_of_mass_velo - - !% Calculates the acceleration of the centre of mass c.f. 'centre_of_mass' in Atoms module. No origin atom required - pure function centre_of_mass_acc(this,index_list) result(A_CoM) - - type(DynamicalSystem), intent(in) :: this - integer, dimension(:), optional, intent(in) :: index_list - real(dp), dimension(3) :: A_CoM - !local variables - integer :: i - real(dp) :: M_tot - - A_CoM = 0.0_dp - M_tot = 0.0_dp - - if (present(index_list)) then - do i = 1, size(index_list) - A_CoM = A_CoM + this%atoms%acc(:,index_list(i)) * this%atoms%mass(index_list(i)) - M_tot = M_tot + this%atoms%mass(index_list(i)) - end do - else - do i = 1, this%N - A_CoM = A_CoM + this%atoms%acc(:,i) * this%atoms%mass(i) - M_tot = M_tot + this%atoms%mass(i) - end do - end if - - A_CoM = A_CoM / M_tot - - end function centre_of_mass_acc - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXX - !XXX ADVANCE VERLET 1 - !XXX - !XXX This is the first step of the integration algorithm. - !XXX - !XXX On entry we have r(t), v(t) and a(t). - !XXX - !XXX For normal atoms this routine performs the following steps of velocity - !XXX Verlet: - !XXX - !XXX p(t+dt/2) = p(t) + F(t)dt/2 -> v(t+dt/2) = v(t) + a(t)dt/2 - !XXX - !XXX r(t+dt) = r(t) + (1/m)p(t+dt/2)dt -> r(t+dt) = r(t) + v(t+dt/2)dt - !XXX - !XXX Integration algorithms for other types of atoms fit around this. After this - !XXX routine, the user code must calculate F(t+dt) and call advance_verlet2 to - !XXX complete the integration step. - !XXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - !% Advance the velocities by half the time-step 'dt' and the - !% positions by a full time-step. A typical MD loop should - !% resemble the following code (Python example, Fortran is similar): - !% - !%> ds.atoms.calc_connect() - !%> for n in range(n_steps): - !%> ds.advance_verlet1(dt) - !%> pot.calc(ds.atoms, force=True, energy=True) - !%> ds.advance_verlet2(dt, ds.atoms.force) - !%> ds.print_status(epot=ds.atoms.energy) - !%> if n % connect_interval == 0: - !%> ds.atoms.calc_connect() - subroutine advance_verlet1(this,dt,virial,parallel,store_constraint_force,do_calc_dists,mpi_obj,error) - - type(dynamicalsystem), intent(inout) :: this - real(dp), intent(in) :: dt -!NB real(dp), intent(in) :: f(:,:) - real(dp),dimension(3,3), intent(in), optional :: virial - logical, optional, intent(in) :: parallel - logical, optional, intent(in) :: store_constraint_force, do_calc_dists - type(MPI_context), optional, intent(in) :: mpi_obj - integer, optional, intent(out) :: error - - logical :: do_parallel, do_store, my_do_calc_dists - integer :: i, j, g, n, ntherm - real(dp), allocatable :: therm_ndof(:) - -#ifdef _MPI - real(dp), dimension(:,:), allocatable :: mpi_pos, mpi_velo, mpi_acc, mpi_constraint_force - real(dp), dimension(:,:), pointer :: constraint_force - integer :: error_code -#endif - - - INIT_ERROR(error) - - this%dt = dt - - do_parallel = optional_default(.false.,parallel) - do_store = optional_default(.false.,store_constraint_force) - my_do_calc_dists = optional_default(.true., do_calc_dists) -!NB call check_size('Force',f,(/3,this%N/),'advance_verlet1') - - this%dW = 0.0_dp - ntherm = size(this%thermostat)-1 - allocate(therm_ndof(ntherm)) - -#ifdef _MPI - if (do_parallel) then - allocate(mpi_pos(3,this%N), mpi_velo(3,this%N), mpi_acc(3,this%N)) - mpi_pos = 0.0_dp - mpi_velo = 0.0_dp - mpi_acc = 0.0_dp - if (do_store) then - allocate(mpi_constraint_force(3,this%N)) - mpi_constraint_force = 0.0_dp - if (.not. assign_pointer(this%atoms,'constraint_force', constraint_force)) then - RAISE_ERROR('advance_verlet1: no constraint_force property found', error) - end if - end if - end if -#endif - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X CALCULATE AND SET DEGREES OF FREEDOM FOR EACH THERMOSTAT - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - call barostat_pre_vel1(this%barostat,this%atoms,dt,virial) - - therm_ndof = 0.0_dp - do i = 1, this%atoms%Ndomain - j = this%atoms%thermostat_region(i) - if (j>0 .and. j<=ntherm) therm_ndof(j) = therm_ndof(j) + degrees_of_freedom(this,i) - end do - if (present(mpi_obj)) then - call sum_in_place(mpi_obj, therm_ndof, error=error) - PASS_ERROR(error) - endif - do i = 1, ntherm - call set_degrees_of_freedom(this%thermostat(i),therm_ndof(i)) - end do - deallocate(therm_ndof) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X DAMPING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then - call thermostat_pre_vel1(this%thermostat(0),this%atoms,dt,'damp_mask',1) - end if - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTATTING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - do i = 1, ntherm - call thermostat_pre_vel1(this%thermostat(i),this%atoms,dt,'thermostat_region',i,virial) - end do - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X VELOCITY UPDATE - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !TIME_PROPAG_TEX 20 - !TIME_PROPAG_TEX 20 Verlet vel step 1 (advance\_verlet1) - !TIME_PROPAG_TEX 20 $$ v = v + (\tau/2) f/m $$ - !TIME_PROPAG_TEX 20 - - do g = 1, size(this%group) - -#ifdef _MPI - if (do_parallel .and. mod(g,mpi_n_procs()) /= mpi_id()) cycle -#endif - - select case(this%group(g)%type) - - case(TYPE_ATOM, TYPE_CONSTRAINED) ! Constrained atoms undergo the usual verlet step here - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X v(t+dt/2) = v(t) + a(t)dt/2 - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXX - do n = 1, group_n_atoms(this%group(g)) - i = group_nth_atom(this%group(g),n) - - if (i <= this%atoms%Ndomain) then -#ifdef _MPI - if (do_parallel) then - if (this%atoms%move_mask(i)==0) then - mpi_velo(:,i) = 0.0_dp - else - mpi_velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt - end if - else - if (this%atoms%move_mask(i)==0) then - this%atoms%velo(:,i) = 0.0_dp - else - this%atoms%velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt - end if - end if -#else - if (this%atoms%move_mask(i)==0) then - this%atoms%velo(:,i) = 0.0_dp - else - this%atoms%velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt - end if -#endif - endif - end do - - end select - - end do -! call print("advance_verlet1 "//(0.5_dp*dt*sum(norm(this%atoms%acc,1))/real(this%atoms%N,dp))) - -#ifdef _MPI - ! Broadcast the new velocities - if (do_parallel) then - call MPI_ALLREDUCE(mpi_velo,this%atoms%velo,size(mpi_velo),MPI_DOUBLE_PRECISION,& - MPI_SUM,MPI_COMM_WORLD,error_code) - call abort_on_mpi_error(error_code,'advance_verlet1 - velocity update') - end if -#endif - - call barostat_post_vel1_pre_pos(this%barostat,this%atoms,dt,virial) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X DAMPING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then - call thermostat_post_vel1_pre_pos(this%thermostat(0),this%atoms,dt,'damp_mask',1) - end if - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTATTING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - do i=1, ntherm - call thermostat_post_vel1_pre_pos(this%thermostat(i),this%atoms,dt,'thermostat_region',i) - end do - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X POSITION UPDATE - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !TIME_PROPAG_TEX 40 - !TIME_PROPAG_TEX 40 Verlet pos step (advance\_verlet1) - !TIME_PROPAG_TEX 40 $$ r = r + \tau v $$ - !TIME_PROPAG_TEX 40 - - do g = 1, size(this%group) - -#ifdef _MPI - if (do_parallel .and. mod(g,mpi_n_procs()) /= mpi_id()) cycle -#endif - - select case(this%group(g)%type) - - case(TYPE_ATOM) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X r(t+dt) = r(t) + v(t+dt/2)dt - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - do n = 1, group_n_atoms(this%group(g)) - i = group_nth_atom(this%group(g),n) - - if (i <= this%atoms%Ndomain) then -#ifdef _MPI - if (do_parallel) then - if (this%atoms%move_mask(i)==0) then - mpi_pos(:,i) = this%atoms%pos(:,i) - mpi_velo(:,i) = 0.0_dp - mpi_acc(:,i) = 0.0_dp - else - mpi_pos(:,i) = this%atoms%pos(:,i) + this%atoms%velo(:,i)*dt - mpi_velo(:,i) = this%atoms%velo(:,i) - mpi_acc(:,i) = this%atoms%acc(:,i) - end if - else - if (this%atoms%move_mask(i)==0) then - this%atoms%velo(:,i) = 0.0_dp - this%atoms%acc(:,i) = 0.0_dp - else - this%atoms%pos(:,i) = this%atoms%pos(:,i) + this%atoms%velo(:,i)*dt - end if - end if -#else - if (this%atoms%move_mask(i)==0) then - this%atoms%velo(:,i) = 0.0_dp - this%atoms%acc(:,i) = 0.0_dp - else - this%atoms%pos(:,i) = this%atoms%pos(:,i) + this%atoms%velo(:,i)*dt - end if -#endif - endif - end do - - case(TYPE_CONSTRAINED) - - !We don't test move_mask here: constrained atoms are fixed by extra constraints. - call shake(this%atoms,this%group(g),this%constraint,this%t,dt,store_constraint_force) -#ifdef _MPI - if (do_parallel) then - do n = 1, group_n_atoms(this%group(g)) - i = group_nth_atom(this%group(g),n) - mpi_pos(:,i) = this%atoms%pos(:,i) - mpi_velo(:,i) = this%atoms%velo(:,i) - mpi_acc(:,i) = this%atoms%acc(:,i) - if (do_store) mpi_constraint_force(:,i) = constraint_force(:,i) - end do - end if -#endif - - end select - - end do - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X DAMPING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then - call thermostat_post_pos_pre_calc(this%thermostat(0),this%atoms,dt,'damp_mask',1) - end if - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTATTING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - do i=1, ntherm - call thermostat_post_pos_pre_calc(this%thermostat(i),this%atoms,dt,'thermostat_region',i) - end do - - call barostat_post_pos_pre_calc(this%barostat,this%atoms,dt,virial) - -#ifdef _MPI - ! Broadcast the new positions, velocities, accelerations and possibly constraint forces - if (do_parallel) then - call MPI_ALLREDUCE(mpi_pos,this%atoms%pos,size(mpi_pos),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) - call abort_on_mpi_error(error_code,'advance_verlet1 - position update') - call MPI_ALLREDUCE(mpi_velo,this%atoms%velo,size(mpi_velo),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) - call abort_on_mpi_error(error_code,'advance_verlet1 - velocity update 2') - call MPI_ALLREDUCE(mpi_acc,this%atoms%acc,size(mpi_acc),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) - call abort_on_mpi_error(error_code,'advance_verlet1 - acceleration update') - if (do_store) then - call MPI_ALLREDUCE(mpi_constraint_force, constraint_force, size(mpi_constraint_force),& - MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) - call abort_on_mpi_error(error_code,'advance_verlet1 - constraint force update') - end if - end if -#endif - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X BOOKKEEPING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#ifdef _MPI - if (do_parallel) then - deallocate(mpi_pos, mpi_velo, mpi_acc) - if (do_store) deallocate(mpi_constraint_force) - end if -#endif - - if (my_do_calc_dists) then - call calc_dists(this%atoms,parallel=do_parallel,error=error) - PASS_ERROR(error) - endif - - end subroutine advance_verlet1 - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXX - !XXX ADVANCE VERLET 2 - !XXX - !XXX This is the second step of the integration algorithm. - !XXX - !XXX On entry we have r(t+dt), v(t+dt/2) and a(t). F(t+dt) is calculated by the - !XXX user code between calls to advance_verlet1 and advance_verlet2, and passed - !XXX in as the argument 'f' - !XXX - !XXX For normal atoms this routine performs the last step of velocity Verlet: - !XXX - !XXX p(t+dt) = p(t+dt/2) + F(t+dt)dt/2 -> v(t+dt) = v(t+dt/2) + a(t+dt)dt/2 - !XXX - !XXX where a(t+dt) = (1/m) F(t+dt) - !XXX - !XXX Integration algorithms for other types of atoms fit around this. - !XXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Advances the velocities by the second half time-step - subroutine advance_verlet2(this,dt,f,virial,E,parallel,store_constraint_force,error) - - type(dynamicalsystem), intent(inout) :: this - real(dp), intent(in) :: dt - real(dp), intent(inout) :: f(:,:) - real(dp),dimension(3,3), intent(in), optional :: virial - real(dp), optional, intent(inout) :: E - logical, optional, intent(in) :: parallel - logical, optional, intent(in) :: store_constraint_force - integer, optional, intent(out) :: error - - logical :: do_parallel, do_store - integer :: i, g, n, ntherm - real(dp) :: decay - -#ifdef _MPI - real(dp), dimension(:,:), allocatable :: mpi_velo, mpi_acc, mpi_constraint_force - real(dp), dimension(:,:), pointer :: constraint_force - integer :: error_code -#endif - - INIT_ERROR(error) - - this%dt = dt - - do_parallel = optional_default(.false.,parallel) - do_store = optional_default(.false.,store_constraint_force) - ntherm = size(this%thermostat)-1 - call check_size('Force',f,(/3,this%N/),'advance_verlet2', error=error) - PASS_ERROR(error) - -#ifdef _MPI - if (do_parallel) then - allocate(mpi_velo(3,this%N), mpi_acc(3,this%N)) - mpi_velo = 0.0_dp - mpi_acc = 0.0_dp - if (do_store) then - allocate(mpi_constraint_force(3,this%N)) - mpi_constraint_force = 0.0_dp - if (.not. assign_pointer(this%atoms,'constraint_force', constraint_force)) then - RAISE_ERROR('advance_verlet2: no constraint_force property found', error) - end if - end if - end if -#endif - - call add_restraint_forces(this%atoms, this%Nrestraints, this%restraint, this%t, f, E, store_restraint_force=store_constraint_force) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X CONVERT FORCES TO ACCELERATIONS - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - forall (i=1:this%atoms%Ndomain) this%atoms%acc(:,i) = f(:,i) / this%atoms%mass(i) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X DAMPING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then - call thermostat_post_calc_pre_vel2(this%thermostat(0),this%atoms,dt,'damp_mask',1) - end if - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTATTING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - do i = 1, ntherm - call thermostat_post_calc_pre_vel2(this%thermostat(i),this%atoms,dt,'thermostat_region',i) - end do - - call barostat_post_calc_pre_vel2(this%barostat,this%atoms,dt,virial) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X VELOCITY UPDATE - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !TIME_PROPAG_TEX 80 - !TIME_PROPAG_TEX 80 Verlet vel step 2 (advance\_verlet2) - !TIME_PROPAG_TEX 80 $$ v = v + (\tau/2) f/m $$ - !TIME_PROPAG_TEX 80 - - do g = 1, size(this%group) - -#ifdef _MPI - if (do_parallel .and. mod(g,mpi_n_procs()) /= mpi_id()) cycle -#endif - - select case(this%group(g)%type) - - case(TYPE_ATOM) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X v(t+dt) = v(t+dt/2) + a(t+dt)dt/2 - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - do n = 1, group_n_atoms(this%group(g)) - i = group_nth_atom(this%group(g),n) - - if (i <= this%atoms%Ndomain) then -#ifdef _MPI - if (do_parallel) then - if (this%atoms%move_mask(i)==0) then - mpi_velo(:,i) = 0.0_dp - mpi_acc(:,i) = 0.0_dp - else - mpi_velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt - mpi_acc(:,i) = this%atoms%acc(:,i) - end if - else - if (this%atoms%move_mask(i)==0) then - this%atoms%velo(:,i) = 0.0_dp - this%atoms%acc(:,i) = 0.0_dp - else - this%atoms%velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt - end if - end if -#else - if (this%atoms%move_mask(i)==0) then - this%atoms%velo(:,i) = 0.0_dp - this%atoms%acc(:,i) = 0.0_dp - else - this%atoms%velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt - end if -#endif - endif - end do - - case(TYPE_CONSTRAINED) - - !As with shake, we don't test move_mask here - call rattle(this%atoms,this%group(g),this%constraint,this%t,dt,store_constraint_force) -#ifdef _MPI - if (do_parallel) then - do n = 1, group_n_atoms(this%group(g)) - i = group_nth_atom(this%group(g),n) - mpi_velo(:,i) = this%atoms%velo(:,i) - mpi_acc(:,i) = this%atoms%acc(:,i) - if (do_store) mpi_constraint_force(:,i) = constraint_force(:,i) - end do - end if -#endif - - end select - - end do -! call print("advance_verlet2 "//(0.5_dp*dt*sum(norm(this%atoms%acc,1))/real(this%atoms%N,dp))) - -#ifdef _MPI - ! Broadcast the new velocities, accelerations and possibly constraint forces - if (do_parallel) then - call MPI_ALLREDUCE(mpi_velo,this%atoms%velo,size(mpi_velo),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) - call abort_on_mpi_error(error_code,'advance_verlet1 - velocity update 2') - call MPI_ALLREDUCE(mpi_acc,this%atoms%acc,size(mpi_acc),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) - call abort_on_mpi_error(error_code,'advance_verlet1 - acceleration update') - if (do_store) then - call MPI_ALLREDUCE(mpi_constraint_force,constraint_force,size(mpi_constraint_force),& - MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) - call abort_on_mpi_error(error_code,'advance_verlet1 - constraint force update') - end if - end if -#endif - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X DAMPING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then - call thermostat_post_vel2(this%thermostat(0),this%atoms,dt,'damp_mask',1) - end if - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTATTING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - do i = 1, ntherm - call thermostat_post_vel2(this%thermostat(i),this%atoms,dt,'thermostat_region',i,virial) - end do - - call barostat_post_vel2(this%barostat,this%atoms,dt,virial) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X BOOKKEEPING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - this%t = this%t + dt - this%nSteps = this%nSteps + 1 - this%work = this%work + this%dW ! Not currently calculated - - this%cur_temp = temperature(this, instantaneous=.true.) - - if (this%avg_time > 0.0_dp) then - decay = dt/this%avg_time - call update_exponential_average(this%avg_temp,decay,this%cur_temp) - do i = 1, this%atoms%Ndomain - call update_exponential_average(this%atoms%avgpos(:,i),decay,realpos(this%atoms,i)) - call update_exponential_average(this%atoms%avg_ke(i),decay,0.5_dp*this%atoms%mass(i)*normsq(this%atoms%velo(:,i))) - end do - end if - -#ifdef _MPI - if (do_parallel) then - deallocate(mpi_velo, mpi_acc) - if (do_store) deallocate(mpi_constraint_force) - end if -#endif - - this%Wkin = kinetic_virial(this, error=error) - PASS_ERROR(error) - this%Ekin = trace(this%Wkin)/2 - - end subroutine advance_verlet2 - - !% Calls' advance_verlet2' followed by 'advance_verlet1'. Outside this routine the - !% velocities will be half-stepped. This allows a simpler MD loop: - !%> for n in range(n_steps): - !%> pot.calc(ds.atoms, force=True, energy=True) - !%> ds.advance_verlet(dt, ds.atoms.force) - !%> ds.print_status(epot=ds.atoms.energy) - !%> if n % connect_interval == 0: - !%> ds.atoms.calc_connect() - subroutine advance_verlet(ds,dt,f,virial,E,parallel,store_constraint_force,do_calc_dists,error) - - type(dynamicalsystem), intent(inout) :: ds - real(dp), intent(in) :: dt - real(dp), intent(inout) :: f(:,:) - real(dp),dimension(3,3), intent(in), optional :: virial - real(dp), intent(inout), optional :: E - logical, optional, intent(in) :: parallel - logical, optional, intent(in) :: store_constraint_force, do_calc_dists - logical, save :: first_call = .true. - integer, optional, intent(out) :: error - - INIT_ERROR(error) - if (first_call) then - call print_title('SINGLE STEP VERLET IN USE') - call print('Consider changing to the two-step integrator') - call print_title('=') - first_call = .false. - end if - call advance_verlet2(ds,dt,f,virial,E,parallel,store_constraint_force,error=error) - PASS_ERROR(error) - call advance_verlet1(ds,dt,virial,parallel,store_constraint_force,do_calc_dists,error=error) - PASS_ERROR(error) - - end subroutine advance_verlet - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X I/O - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Print a status line showing the current time, temperature, the mean temperature - !% the total energy and the total momentum for this DynamicalSystem. If present, the optional - !% 'label' parameter should be a one character label for the log lines and is printed - !% in the first column of the output. 'epot' should be the potential energy - !% if this is available. 'instantaneous' has the same meaning as in 'temperature' routine. - subroutine ds_print_status(this, label, epot, instantaneous, mpi_obj, file, error) - type(DynamicalSystem), intent(in) :: this - character(*), optional, intent(in) :: label - real(dp), optional, intent(in) :: epot - logical, optional, intent(in) :: instantaneous - type(MPI_context), optional, intent(in) :: mpi_obj - type(InOutput), optional, intent(inout) :: file - integer, optional, intent(out) :: error - - character(len=STRING_LENGTH) :: string - logical, save :: firstcall = .true. - real(dp) :: temp, my_epot, my_ekin - real(dp) :: region_temps(size(this%thermostat)) - integer :: i - - INIT_ERROR(error) - - string = "" - if(present(label)) string = label - - if(firstcall) then - if(present(epot)) then - write(line, '(a14,a12,a12,a12,5a20)') "Time", "Temp", "Mean temp", & - "Norm(p)","Total work","Thermo work", & - "Ekin", "Etot", "Eext"; call print(line, file=file) - else - write(line, '(a14,a12,a12,a12,a12,2a20)') "Time", "Temp", "Mean temp", & - "Norm(p)", "Total work","Thermo work"; call print(line, file=file) - end if - firstcall = .false. - end if - - if (present(epot)) then - if (present(mpi_obj)) then - my_epot = sum(mpi_obj, epot, error=error) - PASS_ERROR(error) - else - my_epot = epot - endif - endif - - temp = temperature(this, instantaneous=instantaneous, & - mpi_obj=mpi_obj, error=error) - PASS_ERROR(error) - call thermostat_temperatures(this, region_temps) - - my_ekin = kinetic_energy(this, mpi_obj, error=error) - PASS_ERROR(error) - - if(present(epot)) then - write(line, '(a,f12.2,2f12.4,e12.2,5e20.8)') trim(string), this%t, & - temp, this%avg_temp, norm(momentum(this)),& - this%work, this%thermostat_work, my_ekin, & - my_epot+my_ekin,my_epot+my_ekin+this%ext_energy - else - write(line, '(a,f12.2,2f12.4,e12.2,2e20.8)') trim(string), this%t, & - temp, this%avg_temp, norm(momentum(this)), & - this%work, this%thermostat_work - - end if - call print(line, file=file) - - if (this%print_thermostat_temps) then - if (any(region_temps >= 0.0_dp)) then - call print("T "//this%t, nocr=.true., file=file) - do i=0, size(region_temps)-1 - if (this%thermostat(i)%type /= THERMOSTAT_NONE) then - call print(" "// i // " " // round(this%thermostat(i)%T,2) // " " // round(region_temps(i+1),2), nocr=.true., file=file) - else - call print(" "// i // " type=NONE", nocr=.true., file=file) - endif - end do - call print("", file=file) - endif - endif - - end subroutine ds_print_status - - - subroutine ds_print_thermostats(this) - type(DynamicalSystem), intent(inout) :: this - - call print(this%thermostat) - - end subroutine ds_print_thermostats - - - !% Print lots of information about this DynamicalSystem in text format. - subroutine ds_print(this,file) - - type(DynamicalSystem), intent(inout) :: this - type(Inoutput),optional,intent(inout) :: file - integer :: i - - call Print('DynamicalSystem:',file=file) - - if (.not.this%initialised) then - - call Print(' (not initialised)',file=file) - return - end if - - call print('Number of atoms = '//this%N) - call print('Simulation Time = '//this%t) - call print('Averaging Time = '//this%avg_time) - call print("") - - call print('Thermostat') - call print(this%thermostat) - - call print('-------------------------------------------------------------------------------', PRINT_VERBOSE, file) - call print('| Index | Average Position | Velocity | Acceleration |', PRINT_VERBOSE, file) - call print('-------------------------------------------------------------------------------', PRINT_VERBOSE, file) - do i = 1, this%N - call print('| '//i//' |'//this%atoms%avgpos(:,i)//' |'//this%atoms%velo(:,i)//' |'//this%atoms%acc(:,i)//' |', PRINT_VERBOSE, file) - end do - call print('-------------------------------------------------------------------------------', PRINT_VERBOSE,file) - - call verbosity_push_decrement() - call print(this%atoms,file) - call verbosity_pop() - - end subroutine ds_print - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X CONSTRAINED DYNAMICS ROUTINES - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - ! Routines to make adding constraints easier - ! - !% Constrain the bond angle cosine between atoms i, j, and k - subroutine constrain_bondanglecos(this,i,j,k,c,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i,j,k - real(dp), optional, intent(in) :: c, restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: BONDANGLECOS_FUNC - real(dp) :: use_c - real(dp) :: r_ji(3), r_jk(3) - - !Do nothing for i==j - if (i==j .or. i == k .or. j == k) then - call print_message('WARNING', 'Constrain_bondanglecos: Tried to constrain bond angle cosine '//i//'--'//j//'--'//k) - return - end if - - !Report bad atom indices - if ( i>this%N .or. i<1 .or. j>this%N .or. j<1 .or. k > this%N .or. k<1) then - call system_abort('Constrain_bondanglecos: Cannot constrain bond angle cosine '//i//'--'//j//'--'//k// & - ' : Atom out of range (N='//this%N//')') - end if - - !Register the constraint function if this is the first call - if (first_call) then - BONDANGLECOS_FUNC = register_constraint(BONDANGLECOS) - first_call = .false. - end if - - !Add the constraint - if (present(c)) then - use_c = c - else - r_ji = diff_min_image(this%atoms,j,i) - r_jk = diff_min_image(this%atoms,j,k) - use_c = (r_ji .dot. r_jk)/(norm(r_ji)*norm(r_jk)) - endif - call ds_add_constraint(this,(/i,j,k/),BONDANGLECOS_FUNC,(/use_c/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - - end subroutine constrain_bondanglecos - - !% Constrain the bond between atoms i and j - subroutine constrain_bondlength(this,i,j,d,di,t0,tau,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i,j - real(dp), intent(in) :: d - real(dp), optional, intent(in) :: di, t0, tau - real(dp), optional, intent(in) :: restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: BOND_FUNC - real(dp) :: use_di - - !Do nothing for i==j - if (i==j) then - call print_message('WARNING', 'Constrain_bondlength: Tried to constrain bond '//i//'--'//j) - return - end if - - !Report bad atom indices - if ( (i>this%N) .or. (i<1) .or. (j>this%N) .or. (j<1) ) then - call system_abort('Constrain_bondlength: Cannot constrain bond '//i//'--'//j//& - ': Atom out of range (N='//this%N//')') - end if - - if (count( (/ present(di), present(t0), present(tau) /) ) /= 3 .and. & - count( (/ present(di), present(t0), present(tau) /) ) /= 0) then - call system_abort("constrain_bondlength needs all or none of di, t0, and tau for relaxing bond length to final value") - endif - - !Register the constraint function if this is the first call - if (first_call) then - BOND_FUNC = register_constraint(BONDLENGTH) - first_call = .false. - end if - - !Add the constraint - if (present(di)) then - ! relaxing bond length to final value - if (di < 0.0_dp) then - use_di = distance_min_image(this%atoms,i,j) - else - use_di = di - endif - call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/use_di,d,t0,tau/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - else ! constant restraint - call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/d,d,0.0_dp,1.0_dp/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - endif - - end subroutine constrain_bondlength - - !% Constrain the bond between atoms i and j - subroutine constrain_bondlength_sq(this,i,j,d,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i,j - real(dp), optional, intent(in) :: d, restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: BOND_FUNC - real(dp) :: use_d - - !Do nothing for i==j - if (i==j) then - call print_message('WARNING', 'Constrain_bondlength_sq: Tried to constrain bond '//i//'--'//j) - return - end if - - !Report bad atom indices - if ( (i>this%N) .or. (i<1) .or. (j>this%N) .or. (j<1) ) then - call system_abort('Constrain_bondlength_sq: Cannot constrain bond '//i//'--'//j//& - ': Atom out of range (N='//this%N//')') - end if - - !Register the constraint function if this is the first call - if (first_call) then - BOND_FUNC = register_constraint(BONDLENGTH_SQ) - first_call = .false. - end if - - !Add the constraint - use_d = optional_default(distance_min_image(this%atoms,i,j), d) - call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/use_d/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - - end subroutine constrain_bondlength_sq - - !% Constrain the bond between atoms i and j - subroutine constrain_bondlength_dev_pow(this,i,j,p,d,di,t0,tau,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i,j - real(dp), intent(in) :: p, d - real(dp), optional, intent(in) :: di, t0, tau - real(dp), optional, intent(in) :: restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: BOND_FUNC - real(dp) :: use_di - - !Do nothing for i==j - if (i==j) then - call print_message('WARNING', 'Constrain_bondlength_dev_pow: Tried to constrain bond '//i//'--'//j) - return - end if - - !Report bad atom indices - if ( (i>this%N) .or. (i<1) .or. (j>this%N) .or. (j<1) ) then - call system_abort('Constrain_bondlength_dev_pow: Cannot constrain bond '//i//'--'//j//& - ': Atom out of range (N='//this%N//')') - end if - - if (count( (/ present(di), present(t0), present(tau) /) ) /= 3 .and. & - count( (/ present(di), present(t0), present(tau) /) ) /= 0) then - call system_abort("constrain_bondlength_dev_pow needs all or none of di, t0, and tau for relaxing bond length to final value") - endif - - !Register the constraint function if this is the first call - if (first_call) then - BOND_FUNC = register_constraint(BONDLENGTH_DEV_POW) - first_call = .false. - end if - - !Add the constraint - if (present(di)) then - ! relaxing bond length to final value - if (di < 0.0_dp) then - use_di = distance_min_image(this%atoms,i,j) - else - use_di = di - endif - call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/use_di,d,p,t0,tau/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - else - call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/d,d,p,0.0_dp,1.0_dp/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - endif - - end subroutine constrain_bondlength_dev_pow - - ! - ! Routines to make adding constraints easier - ! - !% Constrain the difference of bond length between atoms i--j and j--k - subroutine constrain_bondlength_diff(this,i,j,k,d,di,t0,tau,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i,j,k - real(dp), intent(in) :: d - real(dp), optional, intent(in) :: di, t0, tau - real(dp), optional, intent(in) :: restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: BOND_DIFF_FUNC - - !Do nothing for i==j or i==k or j==k - if (i==j.or.i==k.or.j==k) then - call print_message('WARNING', 'Constrain_bondlength_Diff: Tried to constrain bond '//i//'--'//j//'--'//k) - return - end if - - !Report bad atom indices - if ( (i>this%N) .or. (i<1) .or. (j>this%N) .or. (j<1) .or. (k>this%N) .or. (k<0) ) then - call system_abort('Constrain_bondlength_Diff: Cannot constrain bond '//i//'--'//j//'--'//k//& - ': Atom out of range (N='//this%N//')') - end if - - if (count( (/ present(di), present(t0), present(tau) /) ) /= 3 .and. & - count( (/ present(di), present(t0), present(tau) /) ) /= 0) then - call system_abort("constrain_bondlength_diff needs all or none of di, t0, and tau for relaxing bond length to final value") - endif - - !Register the constraint function if this is the first call - if (first_call) then - BOND_DIFF_FUNC = register_constraint(BONDLENGTH_DIFF) - first_call = .false. - end if - - !Add the constraint - if (present(di)) then - call ds_add_constraint(this,(/i,j,k/),BOND_DIFF_FUNC,(/di,d,t0,tau/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - else - call ds_add_constraint(this,(/i,j,k/),BOND_DIFF_FUNC,(/d,d,0.0_dp,1.0_dp/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - endif - - end subroutine constrain_bondlength_diff - - ! - ! Routines to make adding constraints easier - ! - !% Constrain the energy gap of two resonance structures - subroutine constrain_gap_energy(this,d,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - real(dp), intent(in) :: d - real(dp), optional, intent(in) :: restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: GAP_ENERGY_FUNC - integer, allocatable :: all_atoms(:) - integer :: i - - !Register the constraint function if this is the first call - if (first_call) then - GAP_ENERGY_FUNC = register_constraint(GAP_ENERGY) - first_call = .false. - end if - - !Add the constraint - allocate(all_atoms(this%atoms%N)) - do i=1,this%atoms%N - all_atoms(i) = i - enddo - call ds_add_constraint(this,all_atoms,GAP_ENERGY_FUNC,(/d/), restraint_k=restraint_k,bound=bound, tol=tol, print_summary=print_summary) - deallocate(all_atoms) - - end subroutine constrain_gap_energy - - !% Constrain an atom to lie in a particluar plane - subroutine constrain_atom_plane(this,i,plane_n,d,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i - real(dp), intent(in) :: plane_n(3) - real(dp), optional, intent(in) :: d, restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: PLANE_FUNC - real(dp) :: use_d, plane_n_hat(3) - - !Report bad atom indices - if ( (i>this%N) .or. (i<1)) then - call system_abort('Constrain_atom_plane: Cannot constrain atom '//i// & - ': Atom out of range (N='//this%N//')') - end if - - !Register the constraint function if this is the first call - if (first_call) then - PLANE_FUNC = register_constraint(PLANE) - first_call = .false. - end if - - plane_n_hat = plane_n/norm(plane_n) - use_d = optional_default((this%atoms%pos(:,i) .dot. plane_n_hat),d) - - !Add the constraint - call ds_add_constraint(this,(/i/),PLANE_FUNC,(/plane_n,use_d/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - - end subroutine constrain_atom_plane - - !% Constrain an atom to lie in a particluar plane - subroutine constrain_struct_factor_like_mag(this,Z,q,SF,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: Z - real(dp), intent(in) :: q(3) - real(dp), intent(in) :: SF - real(dp), optional, intent(in) :: restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: STRUCT_FACTOR_LIKE_MAG_FUNC - - integer :: i, ii - integer, allocatable :: atom_indices(:) - - !Report bad atom indices - if ( Z /= 0) then - if (count(this%atoms%Z == Z) == 0) then - call system_abort('Constrain_struct_factor_like_mag: No atoms (out of '//this%atoms%N//') with Z='//Z) - end if - end if - - !Register the constraint function if this is the first call - if (first_call) then - STRUCT_FACTOR_LIKE_MAG_FUNC = register_constraint(STRUCT_FACTOR_LIKE_MAG) - first_call = .false. - end if - - if (Z == 0) then - allocate(atom_indices(this%atoms%n)) - do i=1, this%atoms%N - atom_indices(i) = i - end do - else - allocate(atom_indices(count(this%atoms%Z == Z))) - ii = 0 - do i=1, this%atoms%N - if (Z == 0) then - ii = ii + 1 - atom_indices(ii) = i - else - if (this%atoms%Z(i) == Z) then - ii = ii + 1 - atom_indices(ii) = i - endif - endif - end do - endif - - !Add the constraint - call ds_add_constraint(this,atom_indices,STRUCT_FACTOR_LIKE_MAG_FUNC,(/q(1),q(2),q(3),SF/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - - deallocate(atom_indices) - - end subroutine constrain_struct_factor_like_mag - - !% Constrain an atom to lie in a particluar plane - subroutine constrain_struct_factor_like_r(this,Z,q,SF,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: Z - real(dp), intent(in) :: q(3) - real(dp), intent(in) :: SF - real(dp), optional, intent(in) :: restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: STRUCT_FACTOR_LIKE_R_FUNC - - integer :: i, ii - integer, allocatable :: atom_indices(:) - - !Report bad atom indices - if ( Z /= 0) then - if (count(this%atoms%Z == Z) == 0) then - call system_abort('Constrain_struct_factor_like_r: No atoms (out of '//this%atoms%N//') with Z='//Z) - end if - end if - - !Register the constraint function if this is the first call - if (first_call) then - STRUCT_FACTOR_LIKE_R_FUNC = register_constraint(STRUCT_FACTOR_LIKE_R) - first_call = .false. - end if - - if (Z == 0) then - allocate(atom_indices(this%atoms%n)) - do i=1, this%atoms%N - atom_indices(i) = i - end do - else - allocate(atom_indices(count(this%atoms%Z == Z))) - ii = 0 - do i=1, this%atoms%N - if (Z == 0) then - ii = ii + 1 - atom_indices(ii) = i - else - if (this%atoms%Z(i) == Z) then - ii = ii + 1 - atom_indices(ii) = i - endif - endif - end do - endif - - !Add the constraint - call ds_add_constraint(this,atom_indices,STRUCT_FACTOR_LIKE_R_FUNC,(/q(1),q(2),q(3),SF/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - - deallocate(atom_indices) - - end subroutine constrain_struct_factor_like_r - - !% Constrain an atom to lie in a particluar plane - subroutine constrain_struct_factor_like_i(this,Z,q,SF,restraint_k,bound,tol,print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: Z - real(dp), intent(in) :: q(3) - real(dp), intent(in) :: SF - real(dp), optional, intent(in) :: restraint_k, tol - integer, optional, intent(in) :: bound - logical, optional, intent(in) :: print_summary - - logical, save :: first_call = .true. - integer, save :: STRUCT_FACTOR_LIKE_I_FUNC - - integer :: i, ii - integer, allocatable :: atom_indices(:) - - !Report bad atom indices - if ( Z /= 0) then - if (count(this%atoms%Z == Z) == 0) then - call system_abort('Constrain_struct_factor_like_i: No atoms (out of '//this%atoms%N//') with Z='//Z) - end if - end if - - !Register the constraint function if this is the first call - if (first_call) then - STRUCT_FACTOR_LIKE_I_FUNC = register_constraint(STRUCT_FACTOR_LIKE_I) - first_call = .false. - end if - - if (Z == 0) then - allocate(atom_indices(this%atoms%n)) - do i=1, this%atoms%N - atom_indices(i) = i - end do - else - allocate(atom_indices(count(this%atoms%Z == Z))) - ii = 0 - do i=1, this%atoms%N - if (Z == 0) then - ii = ii + 1 - atom_indices(ii) = i - else - if (this%atoms%Z(i) == Z) then - ii = ii + 1 - atom_indices(ii) = i - endif - endif - end do - endif - - !Add the constraint - call ds_add_constraint(this,atom_indices,STRUCT_FACTOR_LIKE_I_FUNC,(/q(1),q(2),q(3),SF/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) - - deallocate(atom_indices) - - end subroutine constrain_struct_factor_like_i - - !% Add a constraint to the DynamicalSystem and reduce the number of degrees of freedom, - !% unless 'update_Ndof' is present and false. - subroutine ds_add_constraint(this,atoms,func,data,update_Ndof, restraint_k, bound, tol, print_summary) - - type(DynamicalSystem), intent(inout) :: this - integer, dimension(:), intent(in) :: atoms - integer, intent(in) :: func - integer, optional, intent(in) :: bound - real(dp), dimension(:), intent(in) :: data - logical, optional, intent(in) :: update_Ndof - real(dp), optional, intent(in) :: restraint_k, tol - logical, optional, intent(in) :: print_summary - - integer :: i, type, g1, g2, n, new_constraint - logical :: do_update_Ndof, do_print_summary - - do_update_Ndof = optional_default(.true., update_Ndof) - do_print_summary = optional_default(.true., print_summary) - - !Have constraints been declared when the dynamicalsystem was initialised? - - if (present(restraint_k)) then ! restraint - - if (.not.allocated(this%restraint)) & - call system_abort('ds_add_constraint: Restraints array has not been allocated') - - this%Nrestraints = this%Nrestraints + 1 - new_constraint = this%Nrestraints - if (this%Nrestraints > size(this%restraint)) call system_abort('ds_add_constraint: Restraint array size '//size(this%restraint)//' not enough space for '//this%Nrestraints//' restraints') - if (present(tol)) call print("ds_add_constraint: Restraints will ignore the explicitly given constraint tolerance.",PRINT_ALWAYS) - call initialise(this%restraint(new_constraint),atoms,func,data,restraint_k,bound=bound) - call constraint_calculate_values_at(this%restraint(new_constraint),this%atoms,this%t) - this%restraint(new_constraint)%print_summary = do_print_summary - - else ! constraint - - if (.not.allocated(this%constraint)) & - call system_abort('ds_add_constraint: Constraints array has not been allocated') - - !First make sure the atoms are of TYPE_ATOM or TYPE_CONSTRAINED. If they are of - !TYPE_ATOM they must be in a group on their own, otherwise all the other atoms will - !be added to the CONSTRAINED group, but never be integrated. - do i = 1, size(atoms) - type = Atom_Type(this,atoms(i)) - if ((type /= TYPE_ATOM) .and. (type /= TYPE_CONSTRAINED)) then - call system_abort('ds_add_constraint: Atom '//i// & - ' is not a normal or constrained atom (type = '//type//')') - end if - if (type == TYPE_ATOM) then - g1 = this%group_lookup(atoms(i)) - if (Group_N_Atoms(this%group(g1)) > 1) call system_abort(& - 'ds_add_constraint: A normal atom must be in its own group when added to a constraint') - end if - end do - - !Merge all the groups containing the atoms in this constraint - g1 = this%group_lookup(atoms(1)) - call set_type(this%group(g1),TYPE_CONSTRAINED) - do i = 2, size(atoms) - g2 = this%group_lookup(atoms(i)) - - call set_type(this%group(g2),TYPE_CONSTRAINED) - call merge_groups(this%group(g1),this%group(g2)) - end do - - !Increase the constraint counter and initialise the new constraint - this%Nconstraints = this%Nconstraints + 1 - new_constraint = this%Nconstraints - if (this%Nconstraints > size(this%constraint)) call system_abort('ds_add_constraint: Constraint array full') - call initialise(this%constraint(new_constraint),atoms,func,data,tol=tol) - this%constraint(new_constraint)%print_summary = do_print_summary - - !Update the group_lookups - do n = 1, Group_N_atoms(this%group(g1)) - i = Group_Nth_Atom(this%group(g1),n) - this%group_lookup(i) = g1 - end do - - !Add the constraint as an object for this group - call group_add_object(this%group(g1),new_constraint) - - !Reduce the number of degrees of freedom - if (do_update_Ndof) this%Ndof = this%Ndof - 1 - - !Call the constraint subroutine to fill in variables: - call constraint_calculate_values_at(this%constraint(new_constraint),this%atoms,this%t) - - !Give warning if they constraint is not being satisfied - if (abs(this%constraint(new_constraint)%C) > CONSTRAINT_WARNING_TOLERANCE) & - call print_message('WARNING', 'ds_add_constraint: This constraint ('//new_constraint//') is not currently obeyed: C = '// & - round(this%constraint(new_constraint)%C,5)) - - call constraint_store_gradient(this%constraint(new_constraint)) - endif - - end subroutine ds_add_constraint - - ! - !% Replace a constraint involving some atoms with a different constraint involving - !% the same atoms - ! - subroutine ds_amend_constraint(this,constraint,func,data,k) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: constraint, func - real(dp), dimension(:), intent(in) :: data - real(dp), optional, intent(in) :: k - - call constraint_amend(this%constraint(constraint),func,data,k) - - end subroutine ds_amend_constraint - - ! - !% Return the distance between two atoms and the relative velocity - !% between them projected along the bond direction. - !% This is useful for time dependent constraints. - ! - subroutine distance_relative_velocity(at,i,j,dist,rel_velo) - - type(Atoms), intent(in) :: at - integer, intent(in) :: i,j - real(dp), intent(out) :: dist,rel_velo - real(dp), dimension(3) :: r,v - - r = diff_min_image(at,i,j) !rj - ri - dist = norm(r) - - v = at%velo(:,j) - at%velo(:,i) - - rel_velo = (v .dot. r) / dist - - end subroutine distance_relative_velocity - -! subroutine accumulate_kinetic_energy(this,i,ek,Ndof) -! -! type(dynamicalsystem), intent(in) :: this -! integer, intent(in) :: i -! real(dp), intent(inout) :: ek, Ndof -! -! integer :: g -! -! g = this%group_lookup(i) -! -! select case(this%group(g)%type) -! -! case(TYPE_ATOM) -! ek = eK + 0.5_dp*this%atoms%mass(i)*normsq(this%atoms%velo(:,i)) -! Ndof = Ndof + 3.0_dp -! -! case(TYPE_CONSTRAINED) -! ek = ek + 0.5_dp*this%atoms%mass(i)*normsq(this%atoms%velo(:,i)) -! Ndof = Ndof + 3.0_dp - (real(group_n_objects(this%group(g)),dp) / real(group_n_atoms(this%group(g)),dp)) -! -! case default -! call system_abort('accumulate_kinetic_energy: cannot handle atoms with type = '//this%group(g)%type) -! -! end select -! -! end subroutine accumulate_kinetic_energy - - function degrees_of_freedom(ds,i) result(Ndof) - - type(dynamicalsystem), intent(in) :: ds - integer, intent(in) :: i - real(dp) :: Ndof - - integer :: g - - if (ds%atoms%move_mask(i) == 0) then - Ndof = 0.0_dp - return - end if - - g = ds%group_lookup(i) - - select case(ds%group(g)%type) - - case(TYPE_ATOM) - Ndof = 3.0_dp - - case(TYPE_CONSTRAINED) - Ndof = 3.0_dp - (real(group_n_objects(ds%group(g)),dp) / real(group_n_atoms(ds%group(g)),dp)) - - case default - call system_abort('degrees_of_freedom: cannot handle atoms with type = '//ds%group(g)%type) - - end select - - end function degrees_of_freedom - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X FIXING ATOMS - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% This subroutine fixes a list of atoms. If the atoms are unconstrained then it - !% simply sets move_mask to 0 and advance_verlet does nothing with them. - !% If the atom is constrained then the situation is more complicated: if only one - !% atom in a constrained group is fixed then this must be implemented as 3 - !% constraints (the atom is constrained to the intersection of 3 planes). This is - !% required so that the shake and rattle algorithms work correctly with any further - !% constraints of which the atom is a part. Move_mask is also zeroed in this case. - - subroutine fix_atoms(this,index,restraint_k) - - type(dynamicalsystem), intent(inout) :: this - integer, dimension(:), intent(in) :: index - real(dp), optional, intent(in) :: restraint_k - - integer :: i, g, n - logical, save :: plane_registered = .false. - integer, save :: PLANE_FUNC - - do n = 1, size(index) - - !Zero the move_mask - i = index(n) - - if (this%atoms%move_mask(i) == 0) cycle - - this%atoms%move_mask(i) = 0 - - !Update the number of DoF - this%Ndof = this%Ndof - 3 - - !See if constraints need adding - g = this%group_lookup(i) - if (this%group(g)%type == TYPE_CONSTRAINED) then - - ! Make sure the PLANE constraint function is registered - if (.not.plane_registered) then - PLANE_FUNC = register_constraint(PLANE) - plane_registered = .true. - end if - - !Add the constraints for three intersecting planes - call ds_add_constraint(this,(/i/),PLANE_FUNC,(/1.0_dp,0.0_dp,0.0_dp,this%atoms%pos(1,i)/),restraint_k=restraint_k) - call ds_add_constraint(this,(/i/),PLANE_FUNC,(/0.0_dp,1.0_dp,0.0_dp,this%atoms%pos(2,i)/),restraint_k=restraint_k) - call ds_add_constraint(this,(/i/),PLANE_FUNC,(/0.0_dp,0.0_dp,1.0_dp,this%atoms%pos(3,i)/),restraint_k=restraint_k) - - end if - - end do - - end subroutine fix_atoms - -end module DynamicalSystem_module diff --git a/src/libAtoms/ExtendableStr.f95 b/src/libAtoms/ExtendableStr.f95 deleted file mode 100644 index 2ae0bc7719..0000000000 --- a/src/libAtoms/ExtendableStr.f95 +++ /dev/null @@ -1,716 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Extendable string module -!X -!% Defines strings that can extend as required, using a character array -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module extendable_str_module - -use error_module -use system_module -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif -implicit none - -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif - -private - -integer, parameter :: EXTENDABLE_STRING_LENGTH_INCREMENT = 10240 !% Increment of extendable string -integer, parameter :: extendable_string_reading_buffer = 1024 !% Read ext_string by chunks of this size - -public :: extendable_str -type extendable_str - character(len=1), allocatable :: s(:) - integer :: len = 0 - integer :: increment = EXTENDABLE_STRING_LENGTH_INCREMENT - integer :: cur = 0 -end type extendable_str - - -public :: concat -interface concat - module procedure extendable_str_concat -end interface concat - -public :: string -interface string - module procedure extendable_str_string -end interface string - -public :: substr -interface substr - module procedure extendable_str_substr -end interface substr - -public :: substr_replace -interface substr_replace - module procedure extendable_str_substr_replace -end interface substr_replace - -public :: read -interface read - module procedure extendable_str_read_unit, extendable_str_read_file -end interface read - -public :: initialise -interface initialise - module procedure extendable_str_initialise -end interface initialise - -public :: zero -interface zero - module procedure extendable_str_zero -end interface zero - -public :: finalise -interface finalise - module procedure extendable_str_finalise -end interface finalise - -public :: print -interface print - module procedure extendable_str_print -end interface print - -!public :: len -!interface len -! module procedure extendable_str_len -!endinterface - -public :: read_line -interface read_line - module procedure extendable_str_read_line -end interface read_line - -public :: parse_line -interface parse_line - module procedure extendable_str_parse_line -end interface parse_line - -public :: index -interface index - module procedure extendable_str_index -end interface index - -public :: bcast -interface bcast - module procedure extendable_str_bcast -end interface bcast - -public :: operator(//) -interface operator(//) - module procedure extendable_str_cat_string, string_cat_extendable_str - module procedure extendable_str_cat_extendable_str - module procedure string_cat_extendable_str_array -end interface operator(//) - -public :: assignment(=) -interface assignment(=) - module procedure extendable_str_assign_string - module procedure string_assign_extendable_str -#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY - module procedure extendable_str_assign_extendable_str -#endif -endinterface - -contains - -subroutine extendable_str_initialise(this, copy_from) - type(extendable_str), intent(inout) :: this - type(extendable_str), intent(in), optional :: copy_from - - call finalise(this) - - if (present(copy_from)) then - this%len = copy_from%len - this%increment = copy_from%increment - this%cur = copy_from%cur - allocate(this%s(this%len)) - this%s = copy_from%s - endif -end subroutine extendable_str_initialise - -subroutine extendable_str_finalise(this) - type(extendable_str), intent(inout) :: this - - if (allocated(this%s)) deallocate(this%s) - this%cur = 0 - this%len = 0 - this%increment = EXTENDABLE_STRING_LENGTH_INCREMENT -end subroutine extendable_str_finalise - -subroutine extendable_str_zero(this) - type(extendable_str), intent(inout) :: this - - this%len = 0 -end subroutine extendable_str_zero - -subroutine extendable_str_print(this,verbosity,file) - use iso_c_binding - implicit none - type(extendable_str), intent(in) :: this - integer, intent(in), optional :: verbosity - type(Inoutput), intent(inout),optional:: file - - if (allocated(this%s)) then - call print ("extendable_str, len " // this%len // " size(s) " // size(this%s), verbosity, file) - call print(this%s(1:this%len)) -! OLD IMPLEMENTATION -! do i=1, this%len -! call print (this%s(i), verbosity, out) -! end do - else - call print("extendable_str, len " // this%len // " not allocated", verbosity, file) - endif -end subroutine extendable_str_print - -pure function extendable_str_len(this) - type(extendable_str), intent(in) :: this - integer :: extendable_str_len - extendable_str_len = this%len -end function extendable_str_len - -subroutine extendable_str_concat(this, str, keep_lf, add_lf_if_missing, no_trim, lf_to_whitespace) - type(extendable_str), intent(inout) :: this - character(len=*), intent(in) :: str - logical, intent(in), optional :: keep_lf, add_lf_if_missing, no_trim, lf_to_whitespace - - character, allocatable :: t(:) - integer str_len - integer add_len, new_len - integer i - logical my_keep_lf, my_add_lf_if_missing, my_no_trim, my_lf_to_whitespace - logical :: add_lf - - my_keep_lf = optional_default(.true., keep_lf) - my_add_lf_if_missing = optional_default(.false., add_lf_if_missing) - my_no_trim = optional_default(.false., no_trim) - my_lf_to_whitespace = optional_default(.false., lf_to_whitespace) - - if (my_no_trim) then - str_len = len(str) - else - str_len = len_trim(str) - endif - add_lf = .false. - if (str_len > 0) then - if (my_add_lf_if_missing .and. str(str_len:str_len) /= quip_new_line) add_lf = .true. - else - add_lf = my_add_lf_if_missing - endif - add_len = str_len - if (add_lf) add_len = add_len + 1 - if (add_len > 0) then - if (allocated(this%s)) then ! already allocated contents - new_len = this%len + add_len - if (new_len > size(this%s)) then ! new length too big for current allocated array - if (this%increment > 0) then - new_len = size(this%s) - do while(new_len < this%len + add_len) - new_len = new_len + this%increment - this%increment = this%increment*2 - enddo - endif - if (this%len > 0) then ! need to save old data - allocate(t(size(this%s))) - t = this%s - deallocate(this%s) - allocate(this%s(new_len)) - this%s(1:this%len) = t(1:this%len) - deallocate(t) - else ! don't need to save old data - if (this%increment > 0) then - new_len = this%increment - this%increment = this%increment*2 - do while (new_len < this%len + add_len) - new_len = new_len + this%increment - this%increment = this%increment*2 - enddo - endif - deallocate(this%s) - allocate(this%s(new_len)) - endif - endif - else ! array not already allocated - allocate(this%s(add_len)) - this%len = 0 - endif - - do i=1, str_len - if ( ( .not. my_keep_lf .or. my_lf_to_whitespace ) .and. str(i:i) == quip_new_line) then - if(my_lf_to_whitespace) then - this%s(this%len+1) = " " - else - cycle - endif - else - this%s(this%len+1) = str(i:i) - endif - this%len = this%len + 1 - end do - - if (add_lf) then - this%s(this%len+1) = quip_new_line - this%len = this%len + 1 - endif - - endif - - if (this%len > 0 .and. this%cur <= 0) this%cur = 1 - -end subroutine extendable_str_concat - -function extendable_str_string(this) - type(extendable_str), intent(in) :: this - character(len=this%len) :: extendable_str_string - integer i - - do i=1, this%len - extendable_str_string(i:i) = this%s(i) - end do - -end function extendable_str_string - -function extendable_str_substr(this, start, end, error) - type(extendable_str), intent(in) :: this - integer, intent(in) :: start, end - integer, optional, intent(out) :: error - character(len=(end-start+1)) :: extendable_str_substr - integer i, j - - INIT_ERROR(error) - - if (start < 1 .or. start > this%len) then - RAISE_ERROR('extendable_str_substr: start('//start//') < 1 or > this%len='//this%len, error) - end if - if (end < 1 .or. end > this%len) then - RAISE_ERROR('extendable_str_substr: end('//end//') < 1 or > this%len='//this%len, error) - end if - if (end < start) then - RAISE_ERROR('extendable_str_substr: end('//end//') < start('//start//')', error) - endif - - j = 1 - do i=start, end - extendable_str_substr(j:j) = this%s(i) - j = j + 1 - end do - -end function extendable_str_substr - -subroutine extendable_str_substr_replace(this, start, end, replace, error) - type(extendable_str), intent(inout) :: this - integer, intent(in) :: start, end - character(len=*), intent(in) :: replace - integer, optional, intent(out) :: error - - integer :: j, old_len, substr_len - - INIT_ERROR(error) - - if (start < 0 .or. start > this%len+1) then - RAISE_ERROR('extendable_str_substr_replace: start('//start//') < 1 or > thi%len="//this%len', error) - end if - if (end < 0 .or. end > this%len+1) then - RAISE_ERROR('extendable_str_substr_replace: end('//end//') < 1 or > thi%len="//this%len', error) - end if - if (end < start) then - RAISE_ERROR('extendable_str_substr_replace: end('//end//') < start('//start//')', error) - endif - - if ((start == 0 .and. end /= 0) .or. (end == 0 .and. start /= 0)) then - RAISE_ERROR('extendable_str_substr_replace: start('//start//') == 0 and end('//end//') /= 0, or vice versa', error) - endif - if ((start == this%len+1 .and. end /= this%len+1) .or. (end == this%len+1 .and. start /= this%len+1)) then - RAISE_ERROR('extendable_str_substr_replace: start('//start//') < n+1 and end('//end//') /= n+1, or vice versa', error) - endif - - if (start == 0 .or. start == this%len+1) then - substr_len = 0 - else - substr_len = end-start+1 - endif - - if (len(replace) <= substr_len) then ! no need to extend length - ! do replacement - do j=start, start+len(replace)-1 - this%s(j) = replace(j-start+1:j-start+1) - end do - ! move rest of string back if needed - if (len(replace) < substr_len) then ! - do j=1, this%len-(end+1)+1 - this%s(start+len(replace)-1+j) = this%s(end+j) - end do - this%len = this%len - (substr_len - len(replace)) - endif - else ! need to extend length - old_len = this%len - ! extend length - call concat(this, replace(1:len(replace)-substr_len)) - ! move trailing part of string - do j=1, old_len - end - this%s(this%len-j+1) = this%s(old_len-j+1) - end do - ! replace - if (start == 0) then - do j=1, len(replace) - this%s(j) = replace(j:j) - end do - else - do j=start, start+len(replace)-1 - this%s(j) = replace(j-start+1:j-start+1) - end do - endif - endif - -end subroutine extendable_str_substr_replace - -subroutine extendable_str_read_file(this, file, convert_to_string, mpi_comm, mpi_id, keep_lf) - type(extendable_str), intent(inout) :: this - character(len=*), intent(in) :: file - logical, intent(in), optional :: convert_to_string - integer, intent(in), optional :: mpi_comm, mpi_id - logical, intent(in), optional :: keep_lf - - type(inoutput) :: in - logical do_read - - do_read = .true. - if (present(mpi_comm)) then - if (.not. present(mpi_id)) then - call system_abort("extendable_str_read_file got mpi_comm but not mpi_id") - endif - if (mpi_id /= 0) do_read = .false. - end if - - if (do_read) call initialise(in, trim(file), INPUT) - call read(this, in%unit, convert_to_string, mpi_comm, mpi_id, keep_lf) - if (do_read) call finalise(in) - -end subroutine extendable_str_read_file - -#ifdef PGI_IOSTAT_FUNCS -function is_iostat_end(stat) - integer, intent(in) :: stat - logical :: is_iostat_end - - if (stat == -1) then - is_iostat_end = .true. - else - is_iostat_end = .false. - endif -end function is_iostat_end - -function is_iostat_eor(stat) - integer, intent(in) :: stat - logical :: is_iostat_eor - - if (stat == -2) then - is_iostat_eor = .true. - else - is_iostat_eor = .false. - endif -end function is_iostat_eor - -#endif - -subroutine extendable_str_read_unit(this, unit, convert_to_string, mpi_comm, mpi_id, keep_lf) - type(extendable_str), intent(inout) :: this - integer, intent(in) :: unit - logical, intent(in), optional :: convert_to_string - integer, intent(in), optional :: mpi_comm, mpi_id - logical, intent(in), optional :: keep_lf - - character(len=EXTENDABLE_STRING_READING_BUFFER) :: line - integer n_read - integer stat - logical last_was_incomplete - logical done - logical my_convert_to_string - integer stack_size, stack_size_err - logical do_read - logical my_keep_lf - - this%len = 0 - my_convert_to_string = optional_default(.false., convert_to_string) - my_keep_lf = optional_default(.false., keep_lf) - - do_read = .true. - if (present(mpi_comm)) then - if (.not. present(mpi_id)) then - call system_abort("extendable_str_read_unit got mpi_comm but not mpi_id") - endif - if (mpi_id /= 0) do_read = .false. - end if - - if (do_read) then - if (.not. is_open(unit)) call system_abort("Trying to read into extendable_str from unopened unit "//unit//".") - - done = .false. - last_was_incomplete = .true. - do while (.not. done) - read (unit=unit, fmt='(A)', iostat=stat, advance='no', size=n_read) line - if (.not. is_iostat_end(stat)) then - if (n_read == 0 .and. .not. is_iostat_eor(stat) ) cycle - if (.not.last_was_incomplete .and. .not. my_keep_lf) then - call concat(this, " " // trim(line)) - else - call concat(this, trim(line)) - endif - if(is_iostat_eor(stat)) then - if(my_keep_lf) then - call concat(this, quip_new_line) - elseif(n_read == 0) then - call concat(this, " ") - endif - endif - last_was_incomplete = (stat == 0) - else - done = .true. ! EOF - endif - end do - endif - - call extendable_str_bcast(this, mpi_comm, mpi_id) - - if (my_convert_to_string) then - stack_size = floor(this%len/1024.0_dp) + 10 - stack_size_err = increase_stack(stack_size) - if (stack_size_err /= 0) then - call print("extendable_str_read_unit: error calling c_increase_stack size = " // stack_size // & - " err = "// stack_size_err) - endif - endif - - if (this%len > 0) this%cur = 1 - -end subroutine extendable_str_read_unit - -subroutine extendable_str_bcast(this, mpi_comm, mpi_id) - type(extendable_str), intent(inout) :: this - integer, intent(in), optional :: mpi_comm, mpi_id - -#ifdef _MPI - integer err, size_this_s - - if (present(mpi_comm)) then - if (.not. present(mpi_id)) then - call system_abort("extendable_str_bcast got mpi_comm but not mpi_id") - endif - if (mpi_id == 0) then - call mpi_bcast(size(this%s), 1, MPI_INTEGER, 0, mpi_comm, err) - call mpi_bcast(this%len, 1, MPI_INTEGER, 0, mpi_comm, err) - call mpi_bcast(this%increment, 1, MPI_INTEGER, 0, mpi_comm, err) - call mpi_bcast(this%s, this%len, MPI_CHARACTER, 0, mpi_comm, err) - else - call finalise(this) - call mpi_bcast(size_this_s, 1, MPI_INTEGER, 0, mpi_comm, err) - call mpi_bcast(this%len, 1, MPI_INTEGER, 0, mpi_comm, err) - call mpi_bcast(this%increment, 1, MPI_INTEGER, 0, mpi_comm, err) - allocate(this%s(size_this_s)) - call mpi_bcast(this%s, this%len, MPI_CHARACTER, 0, mpi_comm, err) - endif - endif -#endif - - return -end subroutine extendable_str_bcast - -pure function extendable_str_index(this, substr) - type(extendable_str), intent(in) :: this - character(len=*), intent(in) :: substr - integer extendable_str_index - - logical found_it - integer i, j - - if (this%cur <= 0 .or. size(this%s) <= 0) return - - extendable_str_index = 0 - - do i=this%cur, this%len-len(substr)+1 - found_it = .true. - do j=0, len(substr)-1 - if (this%s(i+j) /= substr(j+1:j+1)) found_it = .false. - if (.not. found_it) exit - end do - if (found_it) then - extendable_str_index = i - return - endif - end do - -end function extendable_str_index - -function extendable_str_read_line(this, status) - type(extendable_str), intent(inout) :: this - integer, intent(out), optional :: status - character(len=max(1,index(this,quip_new_line)-this%cur)) :: extendable_str_read_line - - integer line_len - integer i - - line_len = index(this,quip_new_line)-this%cur - - if (this%cur <= this%len) then - do i=1, line_len - extendable_str_read_line(i:i) = this%s(this%cur+i-1) - end do - this%cur = this%cur + max(line_len+1,0) - endif - - if (present(status)) then - if (line_len < 1) then - status = -1 - else - status = 0 - endif - endif - -end function extendable_str_read_line - -subroutine extendable_str_parse_line(this, delimiters, fields, num_fields, status) - type(extendable_str), intent(inout) :: this - character(*), intent(in) :: delimiters - character(*), dimension(:), intent(inout) :: fields - integer, intent(out) :: num_fields - integer, optional, intent(out) :: status - - integer my_status - character(len=EXTENDABLE_STRING_LENGTH_INCREMENT) :: local_line - - local_line = read_line(this, my_status) - if (present(status)) status = my_status - if (my_status == 0) then - call parse_string(local_line, delimiters, fields, num_fields) - endif -end subroutine extendable_str_parse_line - -function extendable_str_cat_string(this, str) - type(extendable_str), intent(in) :: this - character(*), intent(in) :: str - - type(extendable_str) :: extendable_str_cat_string - - ! --- - - call initialise(extendable_str_cat_string, this) - call concat(extendable_str_cat_string, str) -end function extendable_str_cat_string - -function string_cat_extendable_str(str, this) - character(*), intent(in) :: str - type(extendable_str), intent(in) :: this - - character(len(str)+this%len) :: string_cat_extendable_str - - ! --- - - string_cat_extendable_str = str - string_cat_extendable_str(max(1,len(str)+1):) = string(this) -end function string_cat_extendable_str - -pure function sumlen(this) - type(extendable_str), intent(in) :: this(:) - integer :: sumlen, i - sumlen = 0 - do i = lbound(this, 1), ubound(this, 1) - sumlen = sumlen + this(i)%len - enddo -endfunction sumlen - -function string_cat_extendable_str_array(str, this) - character(*), intent(in) :: str - type(extendable_str), intent(in) :: this(:) - character(len(str)+sumlen(this)+3*size(this)) :: string_cat_extendable_str_array - integer :: i, c - - string_cat_extendable_str_array = str - c = max(1,len(str)+1) - do i = lbound(this, 1), ubound(this, 1) - call print("i = " // i // ", c = " // c // ", len(str) = " // this(i)%len // ", str = " // this(i)) - string_cat_extendable_str_array(c:c+this(i)%len+2) = "'" // string(this(i)) // "'" - c = c+this(i)%len+3 - enddo -end function string_cat_extendable_str_array - -function extendable_str_cat_extendable_str(this, str) - type(extendable_str), intent(in) :: this - type(extendable_str), intent(in) :: str - - type(extendable_str) :: extendable_str_cat_extendable_str - - ! --- - - call initialise(extendable_str_cat_extendable_str, this) - call concat(extendable_str_cat_extendable_str, string(str)) -end function extendable_str_cat_extendable_str - -subroutine extendable_str_assign_string(to, from) - type(extendable_str), intent(out) :: to - character(*), intent(in) :: from - - call initialise(to) - call concat(to, from) -end subroutine extendable_str_assign_string - -#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY -subroutine extendable_str_assign_extendable_str(to, from) - type(extendable_str), intent(out) :: to - type(extendable_str), intent(in) :: from - - call initialise(to) - call concat(to, string(from)) -end subroutine extendable_str_assign_extendable_str -#endif - -subroutine string_assign_extendable_str(to, from) - type(extendable_str), intent(in) :: from - character(from%len), intent(out) :: to - - to = string(from) -end subroutine string_assign_extendable_str - - -end module extendable_str_module diff --git a/src/libAtoms/Group.f95 b/src/libAtoms/Group.f95 deleted file mode 100644 index 099612f285..0000000000 --- a/src/libAtoms/Group.f95 +++ /dev/null @@ -1,812 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Group module -!X -!% A Group is a collection of atoms, with an optional list of objects. These -!% objects can be anything, e.g. rigid bodies, constraints, residues... etc. -!% The idea is that different groups of atoms will require their equations of -!% motion integrating in different ways, so currently AdvanceVerlet loops over all -!% groups, checks the type of the group and integrates the equations of motion -!% for the atoms in that group in the appropriate way. -!% -!% Two examples: -!% -!% \begin{itemize} -!% \item A methane molecule with all C-H bonds fixed would have all 5 of its atoms in one -!% group, which would also contain (the indices of) four constraints. During -!% AdvanceVerlet the RATTLE algorithm can find the correct constraint objects to -!% enforce the fixed bond lengths -!% -!% \item A rigid ammonia molecule could be treated as a rigid body, in which case the -!% group would contain the indices of all 4 of the atoms, and the index of 1 rigid body -!% in the 'objects' array. Then, during AdvanceVerlet, the NO_SQUISH algorithm would -!% propagate these atoms rigidly all at the same time. -!% \end{itemize} -!% -!% Initially, when a DynamicalSystem is initialised each atom is put into its own -!% group. As constraints and rigid bodies are added the number of groups remains -!% the same but some of them become empty. These empty groups can be used if extra -!% atoms are added to the system, or they can be left without a problem. If more -!% memory is needed then DS_Free_Groups can be called, which deletes all the empty groups -!% and recreates the group_lookup array inside DynamicalSystem. This is most useful -!% if all the constraints/rigid bodies are set up before a simulation and are known -!% to never change. -!% -!% A few notes: -!% -!% \begin{itemize} -!% \item Groups aren't necessarily limited to the usage described here -!% -!% \item The 'atom' and 'object' arrays are self extensible, but are always exactly -!% the right size (unlike a Table). This is based on the assumption that they will -!% not change much (if at all) after they have been initially set up. -!% -!% \item Each group has a 'type', which defines how its atoms are integrated. Currently -!% the types are 'TYPE_IGNORE' (numerically zero, and atoms in it are not integrated, -!% which could replace the move_mask variable(?)), 'TYPE_ATOM' (a normal atom), -!% 'TYPE_CONSTRAINED' and 'TYPE_RIGID'. The idea is that if other ways of integrating -!% atoms is required (e.g. linear molecules, positional restraints, belly atoms, etc.) -!% then an new type will be defined and the new will be added to the 'select case' -!% constructs in AdvanceVerlet. -!% \end{itemize} -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module group_module - - use system_module - use linearalgebra_module - - implicit none - private - - public :: group, print, initialise, finalise, set_type - public :: group_n_objects, group_nth_object, group_n_atoms, group_nth_atom - public :: num_free_groups, free_group, tidy_groups, groups_create_lookup - public :: group_add_atom, group_delete_atom, group_add_object, merge_groups - - type Group - - integer :: type !% a 'TYPE_' label for all the atoms in the group - integer, allocatable, dimension(:) :: atom !% a list of atoms in the group in ascending order - integer, allocatable, dimension(:) :: object !% a list of objects these atoms are contained in, e.g. - !% a single rigid body for the whole group, or - !% the subset of the constraints involving these atoms - end type Group - - interface print - module procedure group_print, groups_print - end interface print - - interface initialise - module procedure group_initialise - end interface initialise - - interface finalise - module procedure group_finalise, groups_finalise - end interface finalise - - interface assignment(=) - module procedure group_assign_group, groups_assign_groups - end interface assignment(=) - - interface set_type - module procedure set_type_group - end interface set_type - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Initialise - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine group_initialise(this,type,atoms,objects) - - type(Group), intent(inout) :: this - integer, intent(in) :: type - integer, optional, dimension(:), intent(in) :: atoms - integer, optional, dimension(:), intent(in) :: objects - - this%type = type - - if (allocated(this%atom)) deallocate(this%atom) - if (present(atoms)) then - if (size(atoms)>0) then - allocate(this%atom(size(atoms))) - this%atom = atoms - call insertion_sort(this%atom) - end if - end if - - if (allocated(this%object)) deallocate(this%object) - if (present(objects)) then - if (size(objects)>0) then - allocate(this%object(size(objects))) - this%object = objects - call insertion_sort(this%object) - end if - end if - - end subroutine group_initialise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Finalise - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine group_finalise(this) - - type(Group), intent(inout) :: this - - this%type = 0 - - if (allocated(this%atom)) deallocate(this%atom) - if (allocated(this%object)) deallocate(this%object) - - end subroutine group_finalise - - ! - !% Finalise and deallocate an array of groups - ! - subroutine groups_finalise(this) - - type(Group), dimension(:), allocatable, intent(inout) :: this - integer :: i - - if (allocated(this)) then - do i = 1, size(this) - call group_finalise(this(i)) - end do - deallocate(this) - end if - - end subroutine groups_finalise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Assignment - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine group_assign_group(to,from) - - type(Group), intent(inout) :: to - type(Group), intent(in) :: from - - call group_finalise(to) - - to%type = from%type - if (allocated(from%atom)) then - allocate(to%atom(size(from%atom))) - to%atom = from%atom - end if - if (allocated(from%object)) then - allocate(to%object(size(from%object))) - to%object = from%object - end if - - end subroutine group_assign_group - - subroutine groups_assign_groups(to,from) - - type(Group), dimension(:), intent(inout) :: to - type(Group), dimension(:), intent(in) :: from - integer :: i - - if (size(to) /= size(from)) call system_abort('Groups_Assign_Groups: Target and source sizes differ') - - do i = 1, size(from) - to(i) = from(i) - end do - - end subroutine groups_assign_groups - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Setting the type - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine set_type_group(this,type) - - type(Group), intent(inout) :: this - integer, intent(in) :: type - - this%type = type - - end subroutine set_type_group - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !% Merge: $g1 + g2 \to g1$. If $g2 = g1$ then the result is $g1$ - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine merge_groups(g1,g2) - - type(Group), intent(inout) :: g1,g2 - integer :: type ! - integer, allocatable, dimension(:) :: atom ! Temporary storage - integer, allocatable, dimension(:) :: object ! - integer :: atom_size, object_size, i - - if (g1%type /= g2%type) call system_abort('Merge_Groups: Groups are of different types') - - type = g1%type - - !Allocate the temporary 'atom' array to the max required - atom_size = 0 - if (allocated(g1%atom)) atom_size = atom_size + size(g1%atom) - if (allocated(g2%atom)) atom_size = atom_size + size(g2%atom) - allocate(atom(atom_size)) - !Put each atom into the array only once, - atom_size = 0 - if (allocated(g1%atom)) then - do i = 1, size(g1%atom) - if (.not. is_in_array(atom(1:atom_size),g1%atom(i))) then - atom_size = atom_size + 1 - atom(atom_size) = g1%atom(i) - end if - end do - end if - if (allocated(g2%atom)) then - do i = 1, size(g2%atom) - if (.not. is_in_array(atom(1:atom_size),g2%atom(i))) then - atom_size = atom_size + 1 - atom(atom_size) = g2%atom(i) - end if - end do - end if - - !Now do the same for 'object' - object_size = 0 - if (allocated(g1%object)) object_size = object_size + size(g1%object) - if (allocated(g2%object)) object_size = object_size + size(g2%object) - allocate(object(object_size)) - object_size = 0 - if (allocated(g1%object)) then - do i = 1, size(g1%object) - if (.not. is_in_array(object(1:object_size),g1%object(i))) then - object_size = object_size + 1 - object(object_size) = g1%object(i) - end if - end do - end if - if (allocated(g2%object)) then - do i = 1, size(g2%object) - if (.not. is_in_array(object(1:object_size),g2%object(i))) then - object_size = object_size + 1 - object(object_size) = g2%object(i) - end if - end do - end if - - !Finalise the groups - call finalise(g1) - call finalise(g2) - - !Re-initialise g1 with the new data - call initialise(g1,type,atom(:atom_size),object(:object_size)) - - end subroutine merge_groups - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !% Deleting from a group - !% - !% NOTE: It is, for example, the atom with index 'i' (not 'this%atom(i)') which is deleted - !% Also, if atom/object is empty after deletion it is deallocated - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine group_delete_atom(this,i) - - type(Group), intent(inout) :: this - integer, intent(in) :: i - integer :: pos - integer, allocatable, dimension(:) :: temp_atom - - if (allocated(this%atom)) then - if (size(this%atom) == 0) call system_abort('Group_Delete_Atom: Group has no atoms') - !Find the atoms positions in the array - pos = find_in_array(this%atom,i) - if (pos == 0) then - write(line,'(a,i0,a)')'Group_Delete_Atom: Atom ',i,' is not in this group' - call system_abort(line) - end if - !Copy the others into the temporary - this%atom(pos) = this%atom(size(this%atom)) - if (size(this%atom) > 1) then - allocate(temp_atom(size(this%atom)-1)) - temp_atom = this%atom(1:size(this%atom)-1) - call insertion_sort(temp_atom) - !Copy back the remaining sorted data into the correctly sized atom array - deallocate(this%atom) - allocate(this%atom(size(temp_atom))) - this%atom = temp_atom - deallocate(temp_atom) - else - deallocate(this%atom) - end if - else - call system_abort('Group_Delete_Atom: Group has no atoms') - end if - - end subroutine group_delete_atom - - subroutine group_delete_object(this,i) - - type(Group), intent(inout) :: this - integer, intent(in) :: i - integer :: pos - integer, allocatable, dimension(:) :: temp_object - - if (allocated(this%object)) then - if (size(this%object) == 0) call system_abort('Group_Delete_Object: Group has no objects') - !Find the objects positions in the array - pos = find_in_array(this%object,i) - if (pos == 0) then - write(line,'(a,i0,a)')'Group_Delete_Object: Object ',i,' is not in this group' - call system_abort(line) - end if - !Copy the others into the temporary - this%object(pos) = this%object(size(this%object)) - if (size(this%object) > 1) then - allocate(temp_object(size(this%object)-1)) - temp_object = this%object(1:size(this%object)-1) - call insertion_sort(temp_object) - !Copy back the remaining sorted data into the correctly sized object array - deallocate(this%object) - allocate(this%object(size(temp_object))) - this%object = temp_object - deallocate(temp_object) - else - deallocate(this%object) - end if - else - call system_abort('Group_Delete_Object: Group has no objects') - end if - - end subroutine group_delete_object - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !% Adding objects to a group - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine group_add_atom(this,atom) - - type(Group), intent(inout) :: this - integer, intent(in) :: atom - integer, allocatable, dimension(:) :: temp_atom - - if (allocated(this%atom)) then - if (.not. is_in_array(this%atom,atom)) then - allocate(temp_atom(size(this%atom)+1)) - temp_atom = (/this%atom,atom/) - call insertion_sort(temp_atom) - deallocate(this%atom) - allocate(this%atom(size(temp_atom))) - this%atom = temp_atom - deallocate(temp_atom) - end if - else - allocate(this%atom(1)) - this%atom(1) = atom - end if - - end subroutine group_add_atom - - subroutine group_add_object(this,object) - - type(Group), intent(inout) :: this - integer, intent(in) :: object - integer, allocatable, dimension(:) :: temp_object - - if (allocated(this%object)) then - if (.not. is_in_array(this%object,object)) then - allocate(temp_object(size(this%object)+1)) - temp_object = (/this%object,object/) - call insertion_sort(temp_object) - deallocate(this%object) - allocate(this%object(size(temp_object))) - this%object = temp_object - deallocate(temp_object) - end if - else - allocate(this%object(1)) - this%object(1) = object - end if - - end subroutine group_add_object - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !% Inquiring about the size of a group - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - pure function group_n_atoms(this) - - type(Group), intent(in) :: this - integer :: group_n_atoms - - if (allocated(this%atom)) then - group_n_atoms = size(this%atom) - else - group_n_atoms = 0 - end if - - end function group_n_atoms - - function group_nth_atom(this,n) - - type(Group), intent(in) :: this - integer, intent(in) :: n - integer :: group_nth_atom - - if (allocated(this%atom)) then - if (n > size(this%atom)) then - write(line,'(2(a,i0),a)')'Group_Nth_Atom: Requested atom (',n, & - ') is greater than size of group (',size(this%atom),')' - call system_abort(line) - else - group_nth_atom = this%atom(n) - end if - else - call system_abort('Group_Nth_Atom: Group contains no atoms') - end if - - end function group_nth_atom - - pure function group_n_objects(this) - - type(Group), intent(in) :: this - integer :: group_n_objects - - if (allocated(this%object)) then - group_n_objects = size(this%object) - else - group_n_objects = 0 - end if - - end function group_n_objects - - function group_nth_object(this,n) - - type(Group), intent(in) :: this - integer, intent(in) :: n - integer :: group_nth_object - - if (allocated(this%object)) then - if (n > size(this%object)) then - write(line,'(2(a,i0),a)')'Group_Nth_Object: Requested object (',n, & - ') is greater than number of objects (',size(this%object),')' - call system_abort(line) - else - Group_Nth_Object = this%object(n) - end if - else - call system_abort('Group_Nth_Object: Group contains no objects') - end if - - end function group_nth_object - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X I/O - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine group_print(this,verbosity,out,index) - - type(Group), intent(in) :: this - integer, intent(in), optional :: verbosity - type(Inoutput), intent(inout), optional :: out - integer, optional, intent(in) :: index - integer :: i, nbloc, nrest - logical :: have_atoms, have_objects - character(10) :: form - - if (allocated(this%atom)) then - if (size(this%atom) > 0) then - have_atoms = .true. - else - have_atoms = .false. - end if - else - have_atoms = .false. - end if - - if (allocated(this%object)) then - if (size(this%object) > 0) then - have_objects = .true. - else - have_objects = .false. - end if - else - have_objects = .false. - end if - - call print('=========',verbosity,out) - if (present(index)) then - write(line,'(a,i0)')'Group ',index - call print(line,verbosity,out) - else - call print(' Group ',verbosity,out) - end if - call print('=========',verbosity,out) - - call print('',verbosity,out) - - write(line,'(a,i0)')' Type = ',this%type - call print(line,verbosity,out) - - call print('Atoms:',verbosity,out) - - if (have_atoms) then - nbloc=size(this%atom)/5 - nrest=mod(size(this%atom),5) - do i = 1,nbloc - write(line,'(5(1x,i0))') this%atom((i-1)*5+1:(i*5)) - call print(line,verbosity,out) - end do - if (nrest /= 0) then - write(form,'(a,i0,a)') '(',nrest,'(1x,i0))' - write(line,form) this%atom((i-1)*5+1:(i-1)*5+nrest) - call print(line,verbosity,out) - end if - else - call print('(none)',verbosity,out) - end if - - call print('Objects:',verbosity,out) - - if (have_objects) then - nbloc=size(this%object)/5 - nrest=mod(size(this%object),5) - do i = 1,nbloc - write(line,'(5(1x,i0))') this%object((i-1)*5+1:(i*5)) - call print(line,verbosity,out) - end do - if (nrest /= 0) then - write(form,'(a,i0,a)') '(',nrest,'(1x,i0))' - write(line,form) this%object((i-1)*5+1:(i-1)*5+nrest) - call print(line,verbosity,out) - end if - else - call print('(none)',verbosity,out) - end if - - call print('',verbosity,out) - - call print('=========',verbosity,out) - - end subroutine group_print - - ! - !% Printing arrays of groups, with optional first group index - ! - subroutine groups_print(this,verbosity,file,first) - - type(Group), dimension(:), intent(in) :: this - integer, intent(in), optional :: verbosity - type(Inoutput), intent(inout), optional :: file - integer, optional, intent(in) :: first - integer :: my_first, i - - my_first = 1 !default - if (present(first)) my_first = first - - do i = 1, size(this) - call print(this(i),verbosity,file,i-1+my_first) - call print('', verbosity, file) - end do - - end subroutine groups_print - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Working with arrays of Group objects - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - !% Create an atom lookup table: The supplied lookup table will be filled with the - !% group number that atom i belongs to, with an error if it belongs to multiple groups - !% or if an atom is ungrouped (unless ungrouped errors are turned off). - !% - !% The first group is 1 by default, but can be overridden with the 'first' argument - ! - subroutine groups_create_lookup(this,lookup,first,ungrouped_error) - - type(Group), dimension(:), intent(in) :: this - integer, dimension(:), intent(inout) :: lookup - integer, optional, intent(in) :: first - logical, optional, intent(in) :: ungrouped_error - !local variables - integer :: i, g, n, my_first, ungrouped - logical :: ok, my_ungrouped_error - - my_ungrouped_error = .true. - if (present(ungrouped_error)) my_ungrouped_error = ungrouped_error - - !Set the index of the first group correctly - my_first = 1 !default - if (present(first)) my_first = first - - !Initialise all lookups to a non-existent group number - ungrouped = my_first - 1 - lookup = ungrouped - - do g = 1, size(this) - do n = 1, Group_N_Atoms(this(g)) - i = Group_Nth_Atom(this(g),n) - if (i > size(lookup)) then - write(line,'(2(a,i0))')'Groups_Create_Lookup: Tried to store lookup for atom ',i, & - ' but lookup table only has length ',size(lookup) - call system_abort(line) - end if - if (lookup(i) == ungrouped) then - lookup(i) = g - 1 + my_first - else - write(line,'(3(a,i0))')'Groups_Create_Lookup: Atom ',i,' is in groups ',lookup(i),' and ',(g - 1 + my_first) - call system_abort(line) - end if - end do - end do - - !Now check for ungrouped atoms - if (my_ungrouped_error) then - ok = .true. - do i = 1, size(lookup) - if (lookup(i) == ungrouped) then - write(line,'(a,i0,a)')'Groups_Create_Lookup: Atom ',i,' is ungrouped' - call print_message('WARNING', line) - ok = .false. - end if - end do - if (.not.ok) call system_abort('Refresh_Group_Lookups: Ungrouped atoms found') - end if - - end subroutine groups_create_lookup - - ! - !% Tidy up / free memory used by allocatable group array, optionally leaving 'spare' groups empty. - !% Lookups will need to be refreshed after this. - ! - subroutine tidy_groups(this,spare) - - type(Group), dimension(:), allocatable, intent(inout) :: this - integer, optional, intent(in) :: spare - type(Group), dimension(:), allocatable :: temp_group - integer :: Ngroups, i, g - - !Count the number of groups in use (have atoms in them) - Ngroups = 0 - do i = 1, size(this) - if (allocated(this(i)%atom)) then - if (size(this(i)%atom) > 0) Ngroups = Ngroups + 1 - end if - end do - - !Allocate temporary space - allocate(temp_group(Ngroups)) - - !Copy non-empty groups into temp space - g = 0 - do i = 1, size(this) - if (allocated(this(i)%atom)) then - if (size(this(i)%atom) > 0) then - !Copy the group - g = g + 1 - if (allocated(this(i)%object)) then - call initialise(temp_group(g),this(i)%type,this(i)%atom,this(i)%object) - else - call initialise(temp_group(g),this(i)%type,this(i)%atom) - end if - end if - end if - end do - - !Finalise and deallocate the input groups - call finalise(this) - - !Reallocate to the correct size - if (present(spare)) then - allocate(this(Ngroups + spare)) - else - allocate(this(Ngroups)) - end if - - !Copy over the data - this(1:Ngroups) = temp_group !should work with or without 'spare' - - !Deallocate temporary space - call finalise(temp_group) - - end subroutine tidy_groups - - ! - !% Given an array of groups, return the index of an empty one or the lowest index minus 1 (i.e. zero by default) - !% if none are free. If the first index of the array is not 1, then supply it in 'first' - ! - function free_group(this,first) result(n) - - type(Group), dimension(:), intent(in) :: this - integer, optional, intent(in) :: first - integer :: i, n, my_first - logical :: atom_free, object_free, free_found - - my_first = 1 - if (present(first)) my_first = first - free_found = .false. - - do i = 1, size(this) - - atom_free = .not.allocated(this(i)%atom) - object_free = .not.allocated(this(i)%object) - if (atom_free .and. object_free) then - n = i - 1 + my_first - free_found = .true. - exit - end if - - end do - - if (.not.free_found) n = my_first - 1 - - end function free_group - - ! - !% Count the number of free groups in an array - ! - function num_free_groups(this) result(n) - - type(Group), dimension(:), intent(in) :: this - integer :: i,n - logical :: atom_free, object_free - - n = 0 - do i = 1, size(this) - atom_free = .not.allocated(this(i)%atom) - object_free = .not.allocated(this(i)%object) - if (atom_free .and. object_free) n = n + 1 - end do - - end function num_free_groups - -end module group_module diff --git a/src/libAtoms/LinkedList.f95 b/src/libAtoms/LinkedList.f95 deleted file mode 100644 index 6b296e6efd..0000000000 --- a/src/libAtoms/LinkedList.f95 +++ /dev/null @@ -1,957 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Linked list module -!X -!X -!% The linked list module contains linked list implementations and retrieval routines. -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module linkedlist_module - use error_module - use system_module - implicit none - - type LinkedList_i - integer :: data - type(LinkedList_i), pointer :: next => null() - endtype LinkedList_i - - type LinkedList_i1d - integer, dimension(:), allocatable :: data - type(LinkedList_i1d), pointer :: next => null() - endtype LinkedList_i1d - - type LinkedList_i2d - integer, dimension(:,:), allocatable :: data - type(LinkedList_i2d), pointer :: next => null() - endtype LinkedList_i2d - - interface initialise - module procedure initialise_LinkedList_i, initialise_LinkedList_i1d, initialise_LinkedList_i2d - endinterface initialise - - interface finalise - module procedure finalise_LinkedList_i, finalise_LinkedList_i1d, finalise_LinkedList_i2d - endinterface finalise - - interface insert - module procedure insert_LinkedList_i, insert_LinkedList_i1d, insert_LinkedList_i2d - endinterface insert - - interface delete_node - module procedure delete_node_LinkedList_i, delete_node_LinkedList_i1d, delete_node_LinkedList_i2d - endinterface delete_node - - interface update - module procedure update_LinkedList_i, update_LinkedList_i1d, update_LinkedList_i2d - endinterface update - - interface retrieve_node - module procedure retrieve_node_LinkedList_i, retrieve_node_LinkedList_i1d, retrieve_node_LinkedList_i2d - endinterface retrieve_node - - interface retrieve - module procedure retrieve_LinkedList_i, retrieve_LinkedList_i1d, retrieve_LinkedList_i2d - endinterface retrieve - - !interface next - ! module procedure next_LinkedList_i1d, next_LinkedList_i2d - !endinterface next - - interface last - module procedure last_LinkedList_i, last_LinkedList_i1d, last_LinkedList_i2d - endinterface last - - interface append - module procedure append_LinkedList_i, append_LinkedList_i1d, append_LinkedList_i2d - endinterface append - - interface size_LinkedList - module procedure size_LinkedList_i, size_LinkedList_i1d, size_LinkedList_i2d - endinterface size_LinkedList - - interface is_in_LinkedList - module procedure is_in_LinkedList_i, is_in_LinkedList_i1d, is_in_LinkedList_i2d - endinterface is_in_LinkedList - - contains - - ! integers - - subroutine initialise_LinkedList_i(this,data,error) - - type(LinkedList_i), pointer, intent(inout) :: this - integer, intent(in), optional :: data - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(associated(this)) call finalise(this) - - allocate(this) - if( present(data) ) then - this%data = data - endif - this%next => null() - - endsubroutine initialise_LinkedList_i - - subroutine finalise_LinkedList_i(this,error) - type(LinkedList_i), pointer, intent(inout) :: this - integer, intent(out), optional :: error - - type(LinkedList_i), pointer :: current, next - - INIT_ERROR(error) - - if( .not. associated(this) ) return - - current => this - do while( associated(current) ) - next => current%next - deallocate(current) - current => next - enddo - this => null() - - endsubroutine finalise_LinkedList_i - - subroutine insert_LinkedList_i(this,data,error) - type(LinkedList_i), pointer, intent(inout) :: this - integer, intent(in), optional :: data - integer, intent(out), optional :: error - - type(LinkedList_i), pointer :: current - - INIT_ERROR(error) - - if( .not. associated(this)) then - call initialise(this,data,error) - else - allocate(current) - if(present(data)) then - current%data = data - endif - - current%next => this%next - this%next => current - endif - - endsubroutine insert_LinkedList_i - - subroutine delete_node_LinkedList_i(this,node,error) - type(LinkedList_i), pointer, intent(inout) :: this - type(LinkedList_i), pointer, intent(inout) :: node - integer, intent(out), optional :: error - - type(LinkedList_i), pointer :: delete_node => null(), previous => null() - - INIT_ERROR(error) - - if( .not. associated(this) ) return - - if( associated(this,node) ) then - ! remove first node - delete_node => this - this => this%next - deallocate(delete_node) - else - delete_node => this - do - if(associated(delete_node,node)) then - previous%next => delete_node%next - deallocate(delete_node) - exit - endif - previous => delete_node - delete_node => delete_node%next - if( .not. associated(delete_node) ) exit - enddo - endif - - endsubroutine delete_node_LinkedList_i - - function is_in_LinkedList_i(this,data,error) result(found) - type(LinkedList_i), pointer, intent(in) :: this - integer, intent(in), optional :: data - integer, intent(out), optional :: error - - logical :: found - - type(LinkedList_i), pointer :: current - - INIT_ERROR(error) - - found = .false. - if( associated(this)) then - current => this - do - if( associated(current) ) then - if( current%data == data ) then - found = .true. - exit - endif - current => current%next - else - exit - endif - enddo - endif - - endfunction is_in_LinkedList_i - - subroutine update_LinkedList_i(this,data,error) - type(LinkedList_i), pointer, intent(inout) :: this - integer, intent(in) :: data - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if( .not. associated(this)) then - RAISE_ERROR("update_LinkedList_i: linked list not initialised yet.",error) - endif - - this%data = data - - endsubroutine update_LinkedList_i - - function retrieve_node_LinkedList_i(this,error) result(data) - type(LinkedList_i), pointer, intent(in) :: this - integer, intent(out), optional :: error - - integer, pointer :: data - - INIT_ERROR(error) - - if( .not. associated(this)) then - RAISE_ERROR("retrieve_node_LinkedList_i1d: linked list not initialised yet.",error) - endif - - data => this%data - - endfunction retrieve_node_LinkedList_i - - function next_LinkedList_i(this,error) result(next) - type(LinkedList_i), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i), pointer :: next - - if( .not. associated(this)) then - RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) - endif - - next => this%next - - endfunction next_LinkedList_i - - function last_LinkedList_i(this,error) result(last) - type(LinkedList_i), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i), pointer :: last - - if( .not. associated(this)) then - RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) - endif - - last => this - do while( associated(last%next) ) - last => last%next - enddo - - endfunction last_LinkedList_i - - subroutine append_LinkedList_i(this,data,error) - type(LinkedList_i), pointer, intent(inout) :: this - integer, intent(in), optional :: data - integer, intent(out), optional :: error - - type(LinkedList_i), pointer :: current, new - - INIT_ERROR(error) - - if( .not. associated(this)) then - call initialise(this,data,error) - else - allocate(new) - if(present(data)) then - new%data = data - endif - new%next => null() - - current => this - do while( associated(current%next) ) - current => current%next - enddo - current%next => new - endif - - endsubroutine append_LinkedList_i - - subroutine retrieve_LinkedList_i(this,data,error) - type(LinkedList_i), pointer, intent(inout) :: this - integer, dimension(:), allocatable, intent(out) :: data - integer, intent(out), optional :: error - - type(LinkedList_i), pointer :: current - integer :: i, d1 - - INIT_ERROR(error) - - if( .not. associated(this)) then - call reallocate(data,0) - return - endif - - d1 = size_LinkedList(this,error) - - call reallocate(data,d1) - current => this - i = 0 - do - if( associated(current) ) then - i = i + 1 - data(i) = current%data - current => current%next - else - exit - endif - enddo - - endsubroutine retrieve_LinkedList_i - - function size_LinkedList_i(this,error) result(n) - type(LinkedList_i), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i), pointer :: current - - integer :: n - - n = 0 - if( associated(this) ) then - current => this - do - if( associated(current) ) then - n = n + 1 - current => current%next - else - exit - endif - enddo - endif - - endfunction size_LinkedList_i - - ! 1D integer arrays - - subroutine initialise_LinkedList_i1d(this,data,error) - - type(LinkedList_i1d), pointer, intent(inout) :: this - integer, dimension(:), intent(in), optional :: data - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(associated(this)) call finalise(this) - - allocate(this) - if( present(data) ) then - allocate( this%data(size(data,1)) ) - this%data = data - endif - this%next => null() - - endsubroutine initialise_LinkedList_i1d - - subroutine finalise_LinkedList_i1d(this,error) - type(LinkedList_i1d), pointer, intent(inout) :: this - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: current, next - - INIT_ERROR(error) - - if( .not. associated(this) ) return - - current => this - do while( associated(current) ) - next => current%next - if( allocated(current%data) ) deallocate(current%data) - deallocate(current) - current => next - enddo - this => null() - - endsubroutine finalise_LinkedList_i1d - - subroutine insert_LinkedList_i1d(this,data,error) - type(LinkedList_i1d), pointer, intent(inout) :: this - integer, dimension(:), intent(in), optional :: data - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: current - - INIT_ERROR(error) - - if( .not. associated(this)) then - call initialise(this,data,error) - else - allocate(current) - if(present(data)) then - allocate( current%data(size(data,1)) ) - current%data = data - endif - - current%next => this%next - this%next => current - endif - - endsubroutine insert_LinkedList_i1d - - subroutine delete_node_LinkedList_i1d(this,node,error) - type(LinkedList_i1d), pointer, intent(inout) :: this - type(LinkedList_i1d), pointer, intent(inout) :: node - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: delete_node => null(), previous => null() - - INIT_ERROR(error) - - if( .not. associated(this) ) return - - if( associated(this,node) ) then - ! remove first node - delete_node => this - this => this%next - if( allocated(delete_node%data) ) deallocate(delete_node%data) - deallocate(delete_node) - else - delete_node => this - do - if(associated(delete_node,node)) then - previous%next => delete_node%next - if( allocated(delete_node%data) ) deallocate(delete_node%data) - deallocate(delete_node) - exit - endif - previous => delete_node - delete_node => delete_node%next - if( .not. associated(delete_node) ) exit - enddo - endif - - endsubroutine delete_node_LinkedList_i1d - - function is_in_LinkedList_i1d(this,data,error) result(found) - type(LinkedList_i1d), pointer, intent(in) :: this - integer, dimension(:), intent(in), optional :: data - integer, intent(out), optional :: error - - logical :: found - - type(LinkedList_i1d), pointer :: current - - INIT_ERROR(error) - - found = .false. - if( associated(this)) then - current => this - do - if( associated(current) ) then - if( all( shape(current%data) == shape(data) ) ) then - if( all( current%data == data ) ) then - found = .true. - exit - endif - endif - current => current%next - else - exit - endif - enddo - endif - - endfunction is_in_LinkedList_i1d - - subroutine update_LinkedList_i1d(this,data,error) - type(LinkedList_i1d), pointer, intent(inout) :: this - integer, dimension(:), intent(in) :: data - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if( .not. associated(this)) then - RAISE_ERROR("update_LinkedList_i1d: linked list not initialised yet.",error) - endif - - call reallocate( this%data, size(data,1) ) - this%data = data - - endsubroutine update_LinkedList_i1d - - function retrieve_node_LinkedList_i1d(this,error) result(data) - type(LinkedList_i1d), pointer, intent(in) :: this - integer, intent(out), optional :: error - - integer, dimension(:), pointer :: data - - INIT_ERROR(error) - - if( .not. associated(this)) then - RAISE_ERROR("retrieve_node_LinkedList_i1d: linked list not initialised yet.",error) - endif - - data => this%data - - endfunction retrieve_node_LinkedList_i1d - - function next_LinkedList_i1d(this,error) result(next) - type(LinkedList_i1d), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: next - - if( .not. associated(this)) then - RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) - endif - - next => this%next - - endfunction next_LinkedList_i1d - - function last_LinkedList_i1d(this,error) result(last) - type(LinkedList_i1d), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: last - - if( .not. associated(this)) then - RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) - endif - - last => this - do while( associated(last%next) ) - last => last%next - enddo - - endfunction last_LinkedList_i1d - - subroutine append_LinkedList_i1d(this,data,error) - type(LinkedList_i1d), pointer, intent(inout) :: this - integer, dimension(:), intent(in), optional :: data - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: current, new - - INIT_ERROR(error) - - if( .not. associated(this)) then - call initialise(this,data,error) - else - allocate(new) - if(present(data)) then - allocate( new%data(size(data,1)) ) - new%data = data - endif - new%next => null() - - current => this - do while( associated(current%next) ) - current => current%next - enddo - current%next => new - endif - - endsubroutine append_LinkedList_i1d - - subroutine retrieve_LinkedList_i1d(this,data,error) - type(LinkedList_i1d), pointer, intent(inout) :: this - integer, dimension(:,:), allocatable, intent(out) :: data - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: current - integer :: i, d1, d2 - - INIT_ERROR(error) - - if( .not. associated(this)) then - call reallocate(data,0,0) - return - endif - - d2 = size_LinkedList(this,error) - if( allocated(this%data) ) then - d1 = size(this%data,1) - else - RAISE_ERROR("retrieve_LinkedList_i1d: no data content in head node.", error) - endif - - call reallocate(data,d1,d2) - current => this - i = 0 - do - if( associated(current) ) then - i = i + 1 - if( .not. allocated(current%data) ) then - RAISE_ERROR("retrieve_LinkedList_i1d: data missing from node "//i, error) - endif - if( any( (/d1/) /= shape(current%data) ) ) then - RAISE_ERROR("retrieve_LinkedList_i1d: data array inconsistency in node "//i, error) - endif - data(:,i) = current%data - current => current%next - else - exit - endif - enddo - - endsubroutine retrieve_LinkedList_i1d - - function size_LinkedList_i1d(this,error) result(n) - type(LinkedList_i1d), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i1d), pointer :: current - - integer :: n - - n = 0 - if( associated(this) ) then - current => this - do - if( associated(current) ) then - n = n + 1 - current => current%next - else - exit - endif - enddo - endif - - endfunction size_LinkedList_i1d - - ! 2D integer arrays - - subroutine initialise_LinkedList_i2d(this,data,error) - - type(LinkedList_i2d), pointer, intent(inout) :: this - integer, dimension(:,:), intent(in), optional :: data - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(associated(this)) call finalise(this) - - allocate(this) - if( present(data) ) then - allocate( this%data(size(data,1),size(data,2)) ) - this%data = data - endif - this%next => null() - - endsubroutine initialise_LinkedList_i2d - - subroutine finalise_LinkedList_i2d(this,error) - type(LinkedList_i2d), pointer, intent(inout) :: this - integer, intent(out), optional :: error - - type(LinkedList_i2d), pointer :: current, next - - INIT_ERROR(error) - - if( .not. associated(this) ) return - - current => this - do while( associated(current) ) - next => current%next - if( allocated(current%data) ) deallocate(current%data) - deallocate(current) - current => next - enddo - - this => null() - - endsubroutine finalise_LinkedList_i2d - - subroutine insert_LinkedList_i2d(this,data,error) - type(LinkedList_i2d), pointer, intent(inout) :: this - integer, dimension(:,:), intent(in), optional :: data - integer, intent(out), optional :: error - - type(LinkedList_i2d), pointer :: current - - INIT_ERROR(error) - - if( .not. associated(this)) then - call initialise(this,data,error) - else - allocate(current) - if(present(data)) then - allocate( current%data(size(data,1), size(data,2)) ) - current%data = data - endif - - current%next => this%next - this%next => current - endif - - endsubroutine insert_LinkedList_i2d - - subroutine delete_node_LinkedList_i2d(this,node,error) - type(LinkedList_i2d), pointer, intent(inout) :: this - type(LinkedList_i2d), pointer, intent(inout) :: node - integer, intent(out), optional :: error - - type(LinkedList_i2d), pointer :: delete_node => null(), previous => null() - - INIT_ERROR(error) - - if( .not. associated(this) ) return - - if( associated(this,node) ) then - ! remove first node - delete_node => this - this => this%next - if( allocated(delete_node%data) ) deallocate(delete_node%data) - deallocate(delete_node) - else - delete_node => this - do - if(associated(delete_node,node)) then - previous%next => delete_node%next - if( allocated(delete_node%data) ) deallocate(delete_node%data) - deallocate(delete_node) - exit - endif - previous => delete_node - delete_node => delete_node%next - if( .not. associated(delete_node) ) exit - enddo - endif - - endsubroutine delete_node_LinkedList_i2d - - function is_in_LinkedList_i2d(this,data,error) result(found) - type(LinkedList_i2d), pointer, intent(in) :: this - integer, dimension(:,:), intent(in), optional :: data - integer, intent(out), optional :: error - - logical :: found - - type(LinkedList_i2d), pointer :: current - - INIT_ERROR(error) - - found = .false. - if( associated(this)) then - current => this - do - if( associated(current) ) then - if( all( shape(current%data) == shape(data) ) ) then - if( all( current%data == data ) ) then - found = .true. - exit - endif - endif - current => current%next - else - exit - endif - enddo - endif - - endfunction is_in_LinkedList_i2d - - subroutine update_LinkedList_i2d(this,data,error) - type(LinkedList_i2d), pointer, intent(inout) :: this - integer, dimension(:,:), intent(in) :: data - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if( .not. associated(this)) then - RAISE_ERROR("update_LinkedList_i2d: linked list not initialised yet.",error) - endif - - call reallocate( this%data, size(data,1), size(data,2) ) - this%data = data - - endsubroutine update_LinkedList_i2d - - function retrieve_node_LinkedList_i2d(this,error) result(data) - type(LinkedList_i2d), pointer, intent(in) :: this - integer, intent(out), optional :: error - - integer, dimension(:,:), pointer :: data - - INIT_ERROR(error) - - if( .not. associated(this)) then - RAISE_ERROR("retrieve_node_LinkedList_i2d: linked list not initialised yet.",error) - endif - - data => this%data - - endfunction retrieve_node_LinkedList_i2d - - function next_LinkedList_i2d(this,error) result(next) - type(LinkedList_i2d), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i2d), pointer :: next - - if( .not. associated(this)) then - RAISE_ERROR("next_LinkedList_i2d: linked list not initialised yet.",error) - endif - - next => this%next - - endfunction next_LinkedList_i2d - - function last_LinkedList_i2d(this,error) result(last) - type(LinkedList_i2d), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i2d), pointer :: last - - if( .not. associated(this)) then - RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) - endif - - last => this - do while( associated(last%next) ) - last => last%next - enddo - endfunction last_LinkedList_i2d - - subroutine append_LinkedList_i2d(this,data,error) - type(LinkedList_i2d), pointer, intent(inout) :: this - integer, dimension(:,:), intent(in), optional :: data - integer, intent(out), optional :: error - - type(LinkedList_i2d), pointer :: current, new - - INIT_ERROR(error) - - if( .not. associated(this)) then - call initialise(this,data,error) - else - allocate(new) - if(present(data)) then - allocate( new%data(size(data,1), size(data,2)) ) - new%data = data - endif - new%next => null() - - current => this - do while( associated(current%next) ) - current => current%next - enddo - current%next => new - endif - - endsubroutine append_LinkedList_i2d - - subroutine retrieve_LinkedList_i2d(this,data,error) - type(LinkedList_i2d), pointer, intent(inout) :: this - integer, dimension(:,:,:), allocatable, intent(out) :: data - integer, intent(out), optional :: error - - type(LinkedList_i2d), pointer :: current - integer :: i, d1, d2, d3 - - INIT_ERROR(error) - - if( .not. associated(this)) then - call reallocate(data,0,0,0) - return - endif - - d3 = size_LinkedList(this,error) - if( allocated(this%data) ) then - d1 = size(this%data,1) - d2 = size(this%data,2) - else - RAISE_ERROR("retrieve_LinkedList_i2d: no data content in head node.", error) - endif - - call reallocate(data,d1,d2,d3) - current => this - i = 0 - do - if( associated(current) ) then - i = i + 1 - if( .not. allocated(current%data) ) then - RAISE_ERROR("retrieve_LinkedList_i2d: data missing from node "//i, error) - endif - if( any( (/d1,d2/) /= shape(current%data) ) ) then - RAISE_ERROR("retrieve_LinkedList_i2d: data array inconsistency in node "//i, error) - endif - data(:,:,i) = current%data - current => current%next - else - exit - endif - enddo - - endsubroutine retrieve_LinkedList_i2d - - function size_LinkedList_i2d(this,error) result(n) - type(LinkedList_i2d), pointer, intent(in) :: this - integer, intent(out), optional :: error - - type(LinkedList_i2d), pointer :: current - - integer :: n - - n = 0 - if( associated(this) ) then - current => this - do - if( associated(current) ) then - n = n + 1 - current => current%next - else - exit - endif - enddo - endif - - endfunction size_LinkedList_i2d - -endmodule linkedlist_module diff --git a/src/libAtoms/MPI_context.f95 b/src/libAtoms/MPI_context.f95 deleted file mode 100644 index 3c77fd9779..0000000000 --- a/src/libAtoms/MPI_context.f95 +++ /dev/null @@ -1,1834 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module MPI_context_module -use error_module -use system_module - -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif -implicit none -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif - -private - -public :: ROOT, ROOT_ -integer, parameter :: ROOT = 0 -integer, parameter :: ROOT_ = ROOT ! use if ROOT is shadowed locally - -public :: MPI_context -type MPI_context - logical :: active = .false. - integer :: communicator = 0 - integer :: n_procs = 1 - integer :: my_proc = 0 - integer :: n_hosts = 1 - integer :: my_host = 0 - character(len=:), allocatable :: hostname - logical :: is_cart = .false. - integer :: my_coords(3) = 0 -end type MPI_context - -public :: Initialise -interface Initialise - module procedure MPI_context_Initialise -end interface - -public :: Finalise -interface Finalise - module procedure MPI_context_Finalise -end interface - -public :: is_root -interface is_root - module procedure MPI_context_is_root -end interface - -public :: Print -interface Print - module procedure MPI_context_Print -end interface - -public :: Split_context -interface Split_context - module procedure MPI_context_Split_context -end interface - -public :: free_context -interface free_context - module procedure MPI_context_free_context -end interface - -public :: bcast -interface bcast - module procedure MPI_context_bcast_real, MPI_context_bcast_real1, MPI_context_bcast_real2 - module procedure MPI_context_bcast_c, MPI_context_bcast_c1, MPI_context_bcast_c2 - module procedure MPI_context_bcast_int, MPI_context_bcast_int1, MPI_context_bcast_int2 - module procedure MPI_context_bcast_logical, MPI_context_bcast_logical1, MPI_context_bcast_logical2 - module procedure MPI_context_bcast_char, MPI_context_bcast_char1, MPI_context_bcast_char2 -end interface -public :: min -interface min - module procedure MPI_context_min_real, MPI_context_min_int -end interface -public :: max -interface max - module procedure MPI_context_max_real, MPI_context_max_int -end interface -public :: all -interface all - module procedure MPI_context_all -endinterface -public :: any -interface any - module procedure MPI_context_any -endinterface -public :: sum -interface sum - module procedure MPI_context_sum_int - module procedure MPI_context_sum_real - module procedure MPI_context_sum_complex -end interface -public :: sum_in_place -interface sum_in_place - module procedure MPI_context_sum_in_place_int0 - module procedure MPI_context_sum_in_place_int1 - module procedure MPI_context_sum_in_place_real0 - module procedure MPI_context_sum_in_place_real1 - module procedure MPI_context_sum_in_place_real2 - module procedure MPI_context_sum_in_place_real3 - module procedure MPI_context_sum_in_place_complex1 - module procedure MPI_context_sum_in_place_complex2 -end interface - -public :: gather -interface gather - module procedure MPI_context_gather_char0 -end interface gather - -public :: gatherv -interface gatherv - module procedure MPI_context_gatherv_int1 - module procedure MPI_context_gatherv_real1 - module procedure MPI_context_gatherv_real2 -end interface gatherv - -public :: allgatherv -interface allgatherv - module procedure MPI_context_allgatherv_real2 -end interface allgatherv - -public :: scatter -interface scatter - module procedure MPI_context_scatter_int0 -end interface scatter - -public :: scatterv -interface scatterv - module procedure MPI_context_scatterv_int1 - module procedure MPI_context_scatterv_real1 - module procedure MPI_context_scatterv_real2 -end interface scatterv - -public :: mpi_print - -public :: barrier -interface barrier - module procedure MPI_context_barrier -end interface barrier - -public :: cart_shift -interface cart_shift - module procedure MPI_context_cart_shift -end interface cart_shift - -public :: sendrecv -interface sendrecv - module procedure MPI_context_sendrecv_c1a - module procedure MPI_context_sendrecv_r, MPI_context_sendrecv_ra -end interface sendrecv - -public :: push_MPI_error - -contains - -subroutine MPI_context_Initialise(this, communicator, context, dims, periods, error) - type(MPI_context), intent(inout) :: this - integer, intent(in), optional :: communicator - type(MPI_context), intent(in), optional :: context - integer, intent(in), optional :: dims(3) - logical, intent(in), optional :: periods(3) - integer, intent(out), optional :: error - -#ifdef _MPI - integer :: err - logical :: is_initialized - integer :: comm - logical :: my_periods(3) -#endif - - INIT_ERROR(error) - - if (present(communicator) .and. present(context)) then - RAISE_ERROR("Please specify either *communicator* or *context* upon call to MPI_context_Initialise.", error) - endif - - call Finalise(this) - - this%active = .false. - this%is_cart = .false. - -#ifndef _MPI - allocate(character(1) :: this%hostname) - this%hostname = ' ' -#endif - -#ifdef _MPI - if (present(communicator) .or. present(context)) then - - if (present(communicator)) then - comm = communicator - else if (present(context)) then - comm = context%communicator - endif - - else - - comm = MPI_COMM_WORLD - call mpi_initialized(is_initialized, err) - PASS_MPI_ERROR(err, error) - if (.not. is_initialized) then - call mpi_init(err) - PASS_MPI_ERROR(err, error) - endif - - endif - this%communicator = comm - - if (present(dims)) then - my_periods = .true. - if (present(periods)) then - my_periods = periods - endif - - this%is_cart = .true. - call mpi_cart_create(comm, 3, dims, my_periods, .true., & - this%communicator, err) - PASS_MPI_ERROR(err, error) - endif - - call mpi_comm_set_errhandler(this%communicator, MPI_ERRORS_RETURN, err) - PASS_MPI_ERROR(err, error) - - call mpi_comm_size(this%communicator, this%n_procs, err) - PASS_MPI_ERROR(err, error) - call mpi_comm_rank(this%communicator, this%my_proc, err) - PASS_MPI_ERROR(err, error) - this%active = .true. - - if (this%is_cart) then - call mpi_cart_coords(this%communicator, this%my_proc, 3, & - this%my_coords, err) - PASS_MPI_ERROR(err, error) - - call print("MPI_context_Initialise : Cart created, coords = " // this%my_coords, PRINT_VERBOSE) - endif - - call MPI_context_init_hostname(this, err) - PASS_MPI_ERROR(err, error) - call MPI_context_scatter_hosts(this, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_Initialise - -subroutine MPI_context_Finalise(this, end_of_program, error) - type(MPI_context), intent(inout) :: this - logical, optional, intent(in) :: end_of_program - integer, intent(out), optional :: error - -#ifdef _MPI - integer :: err - logical :: is_initialized -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - if (present(end_of_program)) then - if (end_of_program) then - call mpi_initialized(is_initialized, err) - PASS_MPI_ERROR(err, error) - if (.not. is_initialized) then - call mpi_finalize(err) - PASS_MPI_ERROR(err, error) - endif - endif - endif -#endif -end subroutine MPI_context_Finalise - -!% Set hostname with max length among all MPI processes -subroutine MPI_context_init_hostname(this, error) - type(MPI_context), intent(inout) :: this - integer, intent(out), optional :: error - -#ifdef _MPI - integer :: err, my_len, max_len - character(MPI_MAX_PROCESSOR_NAME) :: hostname -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - call mpi_get_processor_name(hostname, my_len, err) - PASS_MPI_ERROR(err, error) - - max_len = max(this, my_len, err) - PASS_MPI_ERROR(err, error) - - if (allocated(this%hostname)) deallocate(this%hostname) - allocate(character(my_len) :: this%hostname) - this%hostname = hostname(1:max_len) -#endif -end subroutine MPI_context_init_hostname - -!% Set host index and total for each MPI process -subroutine MPI_context_scatter_hosts(this, error) - type(MPI_context), intent(inout) :: this - integer, intent(out), optional :: error - - integer :: err, i - character(:), allocatable :: hostnames(:) - integer, allocatable :: refs(:), hosts(:) - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - if (.not. allocated(this%hostname)) then - call mpi_context_init_hostname(this) - end if - - if (is_root(this)) then - allocate(character(len(this%hostname)) :: hostnames(0:this%n_procs-1)) - else - allocate(character(1) :: hostnames(0:0)) - end if - - call gather(this, this%hostname, hostnames, error=err) - PASS_MPI_ERROR(err, error) - - if (is_root(this)) then - call get_uniqs_refs(hostnames, hosts, refs, lbound(hostnames, 1)) - this%n_hosts = size(hosts) - else - allocate(hosts(1), source=0) - allocate(refs(1), source=0) - end if - - call scatter(this, refs, this%my_host, error=err) - PASS_MPI_ERROR(err, error) - call bcast(this, this%n_hosts, error=err) - PASS_MPI_ERROR(err, error) - - if (is_root(this)) then - call print("MPI hostnames :: "//join(hostnames(hosts), " ")) - call print("MPI host refs :: "//refs) - end if - call print("MPI my_host : "//this%my_host) - call print("MPI hostname : "//this%hostname) -#endif -end subroutine MPI_context_scatter_hosts - -function MPI_context_is_root(this, root) result(res) - type(MPI_context), intent(in) :: this - integer, intent(in), optional :: root - logical :: res - if (this%active) then - res = (this%my_proc == optional_default(ROOT_, root)) - else - res = .true. - end if -end function MPI_context_is_root - -subroutine MPI_context_free_context(this, error) - type(MPI_context), intent(inout) :: this - integer, intent(out), optional :: error - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - call mpi_comm_free(this%communicator, err) - PASS_MPI_ERROR(err, error) - this%active = .false. -#endif -end subroutine MPI_context_free_context - -subroutine MPI_context_Split_context(this, split_index, new_context, error) - type(MPI_context), intent(in) :: this - integer, intent(in) :: split_index - type(MPI_context), intent(out) :: new_context - integer, intent(out), optional :: error - -#ifdef _MPI - integer err -#endif - integer new_comm - - INIT_ERROR(error) - - if (.not. this%active) then - new_context = this - return - endif - - new_comm = this%communicator - -#ifdef _MPI - call mpi_comm_split(this%communicator, split_index, this%my_proc, new_comm, err) - PASS_MPI_ERROR(err, error) -#endif - - call Initialise(new_context, new_comm) - -end subroutine MPI_context_Split_context - -function MPI_context_min_real(this, v, error) - type(MPI_context), intent(in) :: this - real(dp), intent(in) :: v - integer, intent(out), optional :: error - real(dp) :: MPI_context_min_real - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_min_real = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_min_real, 1, MPI_DOUBLE_PRECISION, MPI_MIN, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_min_real = v -#endif -end function MPI_context_min_real - -function MPI_context_min_int(this, v, error) - type(MPI_context), intent(in) :: this - integer, intent(in) :: v - integer, intent(out), optional :: error - integer :: MPI_context_min_int - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_min_int = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_min_int, 1, MPI_INTEGER, MPI_MIN, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_min_int = v -#endif -end function MPI_context_min_int - -function MPI_context_max_real(this, v, error) - type(MPI_context), intent(in) :: this - real(dp), intent(in) :: v - integer, intent(out), optional :: error - real(dp) :: MPI_context_max_real - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_max_real = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_max_real, 1, MPI_DOUBLE_PRECISION, MPI_MAX, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_max_real = v -#endif -end function MPI_context_max_real - -function MPI_context_max_int(this, v, error) - type(MPI_context), intent(in) :: this - integer, intent(in) :: v - integer, intent(out), optional :: error - integer :: MPI_context_max_int - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_max_int = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_max_int, 1, MPI_INTEGER, MPI_MAX, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_max_int = v -#endif -end function MPI_context_max_int - -function MPI_context_all(this, v, error) - type(MPI_context), intent(in) :: this - logical, intent(in) :: v - integer, intent(out), optional :: error - logical :: MPI_context_all - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_all = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_all, 1, MPI_LOGICAL, MPI_LAND, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_all = v -#endif -end function MPI_context_all - -function MPI_context_any(this, v, error) - type(MPI_context), intent(in) :: this - logical, intent(in) :: v - integer, intent(out), optional :: error - logical :: MPI_context_any - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_any = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_any, 1, MPI_LOGICAL, MPI_LOR, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_any = v -#endif -end function MPI_context_any - -function MPI_context_sum_int(this, v, error) - type(MPI_context), intent(in) :: this - integer, intent(in) :: v - integer, intent(out), optional :: error - integer :: MPI_context_sum_int - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_sum_int = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_sum_int, 1, MPI_INTEGER, MPI_SUM, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_sum_int = v -#endif -end function MPI_context_sum_int - -function MPI_context_sum_real(this, v, error) - type(MPI_context), intent(in) :: this - real(dp), intent(in) :: v - integer, intent(out), optional :: error - real(dp) :: MPI_context_sum_real - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_sum_real = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_sum_real, 1, MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_sum_real = v -#endif -end function MPI_context_sum_real - -function MPI_context_sum_complex(this, v, error) - type(MPI_context), intent(in) :: this - complex(dp), intent(in) :: v - integer, intent(out), optional :: error - complex(dp) :: MPI_context_sum_complex - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) then - MPI_context_sum_complex = v - return - endif - -#ifdef _MPI - call MPI_allreduce(v, MPI_context_sum_complex, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) - PASS_MPI_ERROR(err, error) -#else - MPI_context_sum_complex = v -#endif -end function MPI_context_sum_complex - -subroutine MPI_context_sum_in_place_real2(this, v, error) - type(MPI_context), intent(in) :: this - real(dp), intent(inout) :: v(:,:) - integer, intent(out), optional :: error - -#ifdef MPI_1 - real(dp), allocatable :: v_sum(:,:) -#endif -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI -#ifdef MPI_1 - allocate(v_sum(size(v,1),size(v,2))) - call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) - v = v_sum -#else - call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) -#endif - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_sum_in_place_real2 - -subroutine MPI_context_sum_in_place_real3(this, v, error) - type(MPI_context), intent(in) :: this - real(dp), intent(inout) :: v(:,:,:) - integer, intent(out), optional :: error - -#ifdef MPI_1 - real(dp), allocatable :: v_sum(:,:,:) -#endif -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI -#ifdef MPI_1 - allocate(v_sum(size(v,1),size(v,2),size(v,3))) - call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) - v = v_sum -#else - call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) -#endif - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_sum_in_place_real3 - -subroutine MPI_context_sum_in_place_complex2(this, v, error) - type(MPI_context), intent(in) :: this - complex(dp), intent(inout) :: v(:,:) - integer, intent(out), optional :: error - -#ifdef MPI_1 - complex(dp), allocatable :: v_sum(:,:) -#endif -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI -#ifdef MPI_1 - allocate(v_sum(size(v,1),size(v,2))) - call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) - v = v_sum -#else - call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) -#endif - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_sum_in_place_complex2 - -subroutine MPI_context_sum_in_place_int0(this, v, error) - type(MPI_context), intent(in) :: this - integer, intent(inout) :: v - integer, intent(out), optional :: error - -#ifdef MPI_1 - integer :: v_sum -#endif -#ifdef _MPI - integer :: err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI -#ifdef MPI_1 - call MPI_allreduce(v, v_sum, 1, MPI_INTEGER, MPI_SUM, this%communicator, err) - v = v_sum -#else - call MPI_allreduce(MPI_IN_PLACE, v, 1, MPI_INTEGER, MPI_SUM, this%communicator, err) -#endif - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_sum_in_place_int0 - -subroutine MPI_context_sum_in_place_int1(this, v, error) - type(MPI_context), intent(in) :: this - integer, intent(inout) :: v(:) - integer, intent(out), optional :: error - -#ifdef MPI_1 - integer, allocatable :: v_sum(:) -#endif -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI -#ifdef MPI_1 - allocate(v_sum(size(v,1))) - call MPI_allreduce(v, v_sum, size(v), MPI_INTEGER, MPI_SUM, this%communicator, err) - v = v_sum -#else - call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_INTEGER, MPI_SUM, this%communicator, err) -#endif - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_sum_in_place_int1 - -subroutine MPI_context_sum_in_place_real0(this, v, error) - type(MPI_context), intent(in) :: this - real(dp), intent(inout) :: v - integer, intent(out), optional :: error - -#ifdef MPI_1 - real(dp) :: v_sum -#endif -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI -#ifdef MPI_1 - call MPI_allreduce(v, v_sum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) - v = v_sum -#else - call MPI_allreduce(MPI_IN_PLACE, v, 1, MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) -#endif - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_sum_in_place_real0 - -subroutine MPI_context_sum_in_place_real1(this, v, error) - type(MPI_context), intent(in) :: this - real(dp), intent(inout) :: v(:) - integer, intent(out), optional :: error - -#ifdef MPI_1 - real(dp), allocatable :: v_sum(:) -#endif -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI -#ifdef MPI_1 - allocate(v_sum(size(v,1))) - call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) - v = v_sum -#else - call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) -#endif - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_sum_in_place_real1 - -subroutine MPI_context_sum_in_place_complex1(this, v, error) - type(MPI_context), intent(in) :: this - complex(dp), intent(inout) :: v(:) - integer, intent(out), optional :: error - -#ifdef MPI_1 - complex(dp), allocatable :: v_sum(:) -#endif -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI -#ifdef MPI_1 - allocate(v_sum(size(v,1))) - call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) - v = v_sum -#else - call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) -#endif - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_sum_in_place_complex1 - -subroutine MPI_context_bcast_int(this, v, root, error) - type(MPI_context), intent(in) :: this - integer, intent(inout) :: v - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, 1, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_int - -subroutine MPI_context_bcast_int1(this, v, root, error) - type(MPI_context), intent(in) :: this - integer, intent(inout) :: v(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, size(v), MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_int1 - -subroutine MPI_context_bcast_int2(this, v, root, error) - type(MPI_context), intent(in) :: this - integer, intent(inout) :: v(:,:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, size(v), MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_int2 - - -subroutine MPI_context_bcast_logical(this, v, root, error) - type(MPI_context), intent(in) :: this - logical, intent(inout) :: v - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, 1, MPI_LOGICAL, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_logical - -subroutine MPI_context_bcast_logical1(this, v, root, error) - type(MPI_context), intent(in) :: this - logical, intent(inout) :: v(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, size(v), MPI_LOGICAL, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_logical1 - -subroutine MPI_context_bcast_logical2(this, v, root, error) - type(MPI_context), intent(in) :: this - logical, intent(inout) :: v(:,:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, size(v), MPI_LOGICAL, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_logical2 - - -subroutine MPI_context_bcast_c(this, v, root, error) - type(MPI_context), intent(in) :: this - complex(dp), intent(inout) :: v - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, 1, MPI_DOUBLE_COMPLEX, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_c - -subroutine MPI_context_bcast_c1(this, v, root, error) - type(MPI_context), intent(in) :: this - complex(dp), intent(inout) :: v(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, size(v), MPI_DOUBLE_COMPLEX, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_c1 - -subroutine MPI_context_bcast_c2(this, v, root, error) - type(MPI_context), intent(in) :: this - complex(dp), intent(inout) :: v(:,:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, size(v), MPI_DOUBLE_COMPLEX, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_c2 - -subroutine MPI_context_bcast_real(this, v, root, error) - type(MPI_context), intent(in) :: this - real(dp), intent(inout) :: v - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, 1, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_real - -subroutine MPI_context_bcast_real1(this, v, root, error) - type(MPI_context), intent(in) :: this - real(dp), intent(inout) :: v(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, size(v), MPI_DOUBLE_PRECISION, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_real1 - -subroutine MPI_context_bcast_real2(this, v, root, error) - type(MPI_context), intent(in) :: this - real(dp), intent(inout) :: v(:,:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, size(v), MPI_DOUBLE_PRECISION, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_real2 - -subroutine MPI_context_bcast_char(this, v, root, error) - type(MPI_context), intent(in) :: this - character(*), intent(inout) :: v - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, len(v), MPI_CHARACTER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_char - -subroutine MPI_context_bcast_char1(this, v, root, error) - type(MPI_context), intent(in) :: this - character(*), intent(inout) :: v(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, len(v(1))*size(v), MPI_CHARACTER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_char1 - -subroutine MPI_context_bcast_char2(this, v, root, error) - type(MPI_context), intent(in) :: this - character(*), intent(inout) :: v(:,:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - -#ifdef _MPI - integer err - integer my_root -#endif - - INIT_ERROR(error) - - if (.not. this%active) return - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - call MPI_Bcast(v, len(v(1,1))*size(v), MPI_CHARACTER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_bcast_char2 - -subroutine MPI_Context_Print(this, file) - type(MPI_context), intent(in) :: this - type(Inoutput), intent(inout), optional :: file - - call print("MPI_Context : active " // this%active, file=file) - if (this%active) then - call print("communicator " // this%communicator, file=file) - call print("n_procs " // this%n_procs // " my_proc " // this%my_proc, file=file) - endif -end subroutine MPI_Context_Print - -subroutine MPI_Print(this, lines, file) - type(MPI_context), intent(in) :: this - character(len=*), intent(in) :: lines(:) - type(Inoutput), intent(inout), optional :: file - - integer i - - if (.not. this%active) then - do i=1, size(lines) - call Print(trim(lines(i)), file=file) - end do -#ifdef _MPI - else - call parallel_print(lines, this%communicator, file=file) -#endif - endif - -end subroutine MPI_Print - -subroutine MPI_context_gather_char0(this, v_in, v_out, root, error) - type(MPI_context), intent(in) :: this - character(*), intent(in) :: v_in - character(*), intent(out) :: v_out(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: my_root, err, my_len - - INIT_ERROR(error) - - if (.not. this%active) then - if (size(v_out) < 1) then - RAISE_ERROR("MPI_context_gather_char0 size(v_out) < 1: " // size(v_out), error) - end if - - if (len(v_in) /= len(v_out(1))) then - RAISE_ERROR("MPI_context_gather_char0 lengths differ: len(v_in) " // len(v_in) // " len(v_out(1)) " // len(v_out), error) - end if - - v_out(1) = v_in - return - end if - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - - if (is_root(this)) then - if (size(v_out) /= this%n_procs) then - RAISE_ERROR("MPI_context_gather_char0 size(v_out) < %n_procs: " // size(v_out) // " " // this%n_procs, error) - end if - if (len(v_in) /= len(v_out(1))) then - RAISE_ERROR("MPI_context_gather_char0 lengths differ: len(v_in) " // len(v_in) // " len(v_out(1)) " // len(v_out), error) - end if - end if - - call mpi_gather(v_in, len(v_in), MPI_CHARACTER, v_out, len(v_in), MPI_CHARACTER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_gather_char0 - -subroutine MPI_context_gatherv_int1(this, v_in, v_out, counts, root, error) - type(MPI_context), intent(in) :: this - integer, intent(in) :: v_in(:) - integer, intent(out) :: v_out(:) - integer, intent(out), allocatable, optional :: counts(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: my_root, err, my_count - integer, allocatable :: displs(:), my_counts(:) - - INIT_ERROR(error) - - if (.not. this%active) then - if (any(shape(v_in) /= shape(v_out))) then - RAISE_ERROR("MPI_context_gatherv_int1 (no MPI) shape mismatch v_in " // shape(v_in) // " v_out " // shape(v_out), error) - endif - v_out = v_in - return - endif - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - if (is_root(this)) then - allocate(my_counts(this%n_procs)) - else - allocate(my_counts(1), source=0) - end if - - my_count = size(v_in) - call mpi_gather(my_count, 1, MPI_INTEGER, my_counts, 1, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (sum(my_counts) > size(v_out)) then - RAISE_ERROR("MPI_context_gatherv_int1 not enough space sum(my_counts) " // sum(my_counts) // " size(v_out) " // size(v_out), error) - endif - - if (is_root(this)) then - call get_displs(my_counts, displs) - else - allocate(displs(1), source=0) - end if - - call MPI_gatherv(v_in, my_count, MPI_INTEGER, v_out, my_counts, displs, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (present(counts)) then - allocate(counts, source=my_counts) - end if -#endif - -end subroutine MPI_context_gatherv_int1 - -subroutine MPI_context_gatherv_real1(this, v_in, v_out, counts, root, error) - type(MPI_context), intent(in) :: this - real(dp), intent(in) :: v_in(:) - real(dp), intent(out) :: v_out(:) - integer, intent(out), allocatable, optional :: counts(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: my_root, err, my_count - integer, allocatable :: displs(:), my_counts(:) - - INIT_ERROR(error) - - if (.not. this%active) then - if (any(shape(v_in) /= shape(v_out))) then - RAISE_ERROR("MPI_context_gatherv_real1 (no MPI) shape mismatch v_in " // shape(v_in) // " v_out " // shape(v_out), error) - endif - v_out = v_in - return - endif - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - if (is_root(this)) then - allocate(my_counts(this%n_procs)) - else - allocate(my_counts(1), source=0) - end if - - my_count = size(v_in) - call mpi_gather(my_count, 1, MPI_INTEGER, my_counts, 1, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (sum(my_counts) > size(v_out)) then - RAISE_ERROR("MPI_context_gatherv_real1 not enough space sum(my_counts) " // sum(my_counts) // " size(v_out) " // size(v_out), error) - endif - - if (is_root(this)) then - call get_displs(my_counts, displs) - else - allocate(displs(1), source=0) - end if - - call MPI_gatherv(v_in, my_count, MPI_DOUBLE_PRECISION, v_out, my_counts, displs, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (present(counts)) then - allocate(counts, source=my_counts) - end if -#endif - -end subroutine MPI_context_gatherv_real1 - -subroutine MPI_context_gatherv_real2(this, v_in, v_out, counts, root, error) - type(MPI_context), intent(in) :: this - real(dp), intent(in) :: v_in(:,:) - real(dp), intent(out) :: v_out(:,:) - integer, intent(out), allocatable, optional :: counts(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: my_root, err, my_count - integer, allocatable :: displs(:), my_counts(:) - - INIT_ERROR(error) - - if (.not. this%active) then - if (any(shape(v_in) /= shape(v_out))) then - RAISE_ERROR("MPI_context_gatherv_real2 (no MPI) shape mismatch v_in " // shape(v_in) // " v_out " // shape(v_out), error) - endif - v_out = v_in - return - endif - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - if (is_root(this)) then - allocate(my_counts(this%n_procs)) - else - allocate(my_counts(1), source=0) - end if - - my_count = size(v_in) - call mpi_gather(my_count, 1, MPI_INTEGER, my_counts, 1, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (sum(my_counts) > size(v_out)) then - RAISE_ERROR("MPI_context_gatherv_real2 not enough space sum(my_counts) " // sum(my_counts) // " size(v_out) " // size(v_out), error) - endif - - if (is_root(this)) then - call get_displs(my_counts, displs) - else - allocate(displs(1), source=0) - end if - - call MPI_gatherv(v_in, my_count, MPI_DOUBLE_PRECISION, v_out, my_counts, displs, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (present(counts)) then - allocate(counts, source=my_counts) - end if -#endif - -end subroutine MPI_context_gatherv_real2 - -subroutine MPI_context_allgatherv_real2(this, v_in, v_out, error) - type(MPI_context), intent(in) :: this - real(dp), intent(in) :: v_in(:,:) - real(dp), intent(out) :: v_out(:,:) - integer, intent(out), optional :: error - - integer err - integer my_count - integer, allocatable :: displs(:), counts(:) - - INIT_ERROR(error) - - if (.not. this%active) then - if (size(v_in,1) /= size(v_out,1) .or. & - size(v_in,2) /= size(v_out,2)) then - RAISE_ERROR("MPI_context_allgatherv_real (no MPI) size mismatch v_in " // shape(v_in) // " v_out " // shape(v_out), error) - endif - v_out = v_in - return - endif - -#ifdef _MPI - - my_count = size(v_in) - allocate(counts(this%n_procs)) - call mpi_allgather(my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (sum(counts) > size(v_out)) then - RAISE_ERROR("MPI_context_allgatherv_real2 not enough space sum(counts) " // sum(counts) // " size(v_out) " // size(v_out), error) - endif - - call get_displs(counts, displs) - call MPI_allgatherv(v_in, my_count, MPI_DOUBLE_PRECISION, & - v_out, counts, displs, MPI_DOUBLE_PRECISION, & - this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif - -end subroutine MPI_context_allgatherv_real2 - -subroutine MPI_context_scatter_int0(this, v_in, v_out, root, error) - type(MPI_context), intent(in) :: this - integer, intent(in) :: v_in(:) - integer, intent(out) :: v_out - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: my_root, err - - INIT_ERROR(error) - - if (.not. this%active) then - if (size(v_in) < 1) then - RAISE_ERROR("MPI_context_scatter_int0 size(v_in) < 1: " // size(v_in), error) - end if - - v_out = v_in(1) - return - end if - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - - if (is_root(this)) then - if (size(v_in) /= this%n_procs) then - RAISE_ERROR("MPI_context_scatter_int0 size(v_in) /= %n_procs: " // size(v_in) // " " // this%n_procs, error) - end if - end if - - call mpi_scatter(v_in, 1, MPI_INTEGER, v_out, 1, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_scatter_int0 - -subroutine MPI_context_scatterv_int1(this, v_in, v_out, counts, root, error) - type(MPI_context), intent(in) :: this - integer, intent(in) :: v_in(:) - integer, intent(out) :: v_out(:) - integer, intent(in) :: counts(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: my_root, err, count - integer, allocatable :: displs(:) - - INIT_ERROR(error) - - if (.not. this%active) then - if (any(shape(v_in) /= shape(v_out))) then - RAISE_ERROR("MPI_context_scatterv_int1 (no MPI) shape mismatch: v_in " // shape(v_in) // " v_out " // shape(v_out), error) - endif - v_out = v_in - return - endif - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - - call mpi_scatter(counts, 1, MPI_INTEGER, count, 1, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (count > size(v_out)) then - RAISE_ERROR("MPI_context_scatterv_int1 not enough space: count " // count // " size(v_out) " // size(v_out), error) - endif - - if (is_root(this, my_root)) then - call get_displs(counts, displs) - else - allocate(displs(1), source=0) - end if - - call MPI_scatterv(v_in, counts, displs, MPI_INTEGER, v_out, count, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif - -end subroutine MPI_context_scatterv_int1 - -subroutine MPI_context_scatterv_real1(this, v_in, v_out, counts, root, error) - type(MPI_context), intent(in) :: this - real(dp), intent(in) :: v_in(:) - real(dp), intent(out) :: v_out(:) - integer, intent(in) :: counts(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: my_root, err, count - integer, allocatable :: displs(:) - - INIT_ERROR(error) - - if (.not. this%active) then - if (any(shape(v_in) /= shape(v_out))) then - RAISE_ERROR("MPI_context_scatterv_real1 (no MPI) shape mismatch: v_in " // shape(v_in) // " v_out " // shape(v_out), error) - endif - v_out = v_in - return - endif - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - - call mpi_scatter(counts, 1, MPI_INTEGER, count, 1, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (count > size(v_out)) then - RAISE_ERROR("MPI_context_scatterv_real1 not enough space: count " // count // " size(v_out) " // size(v_out), error) - endif - - if (is_root(this, my_root)) then - call get_displs(counts, displs) - else - allocate(displs(1), source=0) - end if - - call MPI_scatterv(v_in, counts, displs, MPI_DOUBLE_PRECISION, v_out, count, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif - -end subroutine MPI_context_scatterv_real1 - -subroutine MPI_context_scatterv_real2(this, v_in, v_out, counts, root, error) - type(MPI_context), intent(in) :: this - real(dp), intent(in) :: v_in(:,:) - real(dp), intent(out) :: v_out(:,:) - integer, intent(in) :: counts(:) - integer, intent(in), optional :: root - integer, intent(out), optional :: error - - integer :: my_root, err, count - integer, allocatable :: displs(:) - - INIT_ERROR(error) - - if (.not. this%active) then - if (any(shape(v_in) /= shape(v_out))) then - RAISE_ERROR("MPI_context_scatterv_real2 (no MPI) shape mismatch: v_in " // shape(v_in) // " v_out " // shape(v_out), error) - endif - v_out = v_in - return - endif - -#ifdef _MPI - my_root = optional_default(ROOT_, root) - - call mpi_scatter(counts, 1, MPI_INTEGER, count, 1, MPI_INTEGER, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) - - if (count > size(v_out)) then - RAISE_ERROR("MPI_context_scatterv_real2 not enough space: count " // count // " size(v_out) " // size(v_out), error) - endif - - if (is_root(this, my_root)) then - call get_displs(counts, displs) - else - allocate(displs(1), source=0) - end if - - call MPI_scatterv(v_in, counts, displs, MPI_DOUBLE_PRECISION, v_out, count, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif - -end subroutine MPI_context_scatterv_real2 - -subroutine MPI_context_barrier(this, error) - type(MPI_context), intent(in) :: this - integer, intent(out), optional :: error - -#ifdef _MPI - integer err -#endif - - INIT_ERROR(error) - -#ifdef _MPI - call mpi_barrier(this%communicator, err) - PASS_MPI_ERROR(err, error) -#endif -end subroutine MPI_context_barrier - -subroutine MPI_context_cart_shift(this, direction, displ, source, dest, error) - type(MPI_context), intent(in) :: this - integer, intent(in) :: direction, displ - integer, intent(out) :: source, dest - integer, intent(out), optional :: error - - ! --- - -#ifdef _MPI - integer :: err -#endif - - INIT_ERROR(error) - -#ifdef _MPI - call mpi_cart_shift(this%communicator, direction, displ, source, dest, err) - PASS_MPI_ERROR(err, error) -#else - source = 0 - dest = 0 -#endif -end subroutine MPI_context_cart_shift - - -subroutine MPI_context_sendrecv_c1a(this, & - sendbuf, dest, sendtag, & - recvbuf, source, recvtag, & - nrecv, & - error) - type(MPI_context), intent(in) :: this - character(1), intent(in) :: sendbuf(:) - integer, intent(in) :: dest, sendtag - character(1), intent(out) :: recvbuf(:) - integer, intent(in) :: source, recvtag - integer, optional, intent(out) :: nrecv - integer, intent(out), optional :: error - - ! --- - -#ifdef _MPI - integer :: err - integer :: status(MPI_STATUS_SIZE) -#endif - - INIT_ERROR(error) - -#ifdef _MPI - call mpi_sendrecv( & - sendbuf, size(sendbuf), MPI_CHARACTER, dest, sendtag, & - recvbuf, size(recvbuf), MPI_CHARACTER, source, recvtag, & - this%communicator, status, err) - PASS_MPI_ERROR(err, error) - if (present(nrecv)) then - call mpi_get_count(status, MPI_CHARACTER, nrecv, err) - PASS_MPI_ERROR(err, error) - endif -#endif -endsubroutine MPI_context_sendrecv_c1a - - -subroutine MPI_context_sendrecv_r(this, & - sendbuf, dest, sendtag, & - recvbuf, source, recvtag, & - error) - type(MPI_context), intent(in) :: this - real(DP), intent(in) :: sendbuf - integer, intent(in) :: dest, sendtag - real(DP), intent(out) :: recvbuf - integer, intent(in) :: source, recvtag - integer, intent(out), optional :: error - - ! --- - -#ifdef _MPI - integer :: err - integer :: status(MPI_STATUS_SIZE) -#endif - - INIT_ERROR(error) - -#ifdef _MPI - call mpi_sendrecv( & - sendbuf, 1, MPI_DOUBLE_PRECISION, dest, sendtag, & - recvbuf, 1, MPI_DOUBLE_PRECISION, source, recvtag, & - this%communicator, status, err) - PASS_MPI_ERROR(err, error) -#endif -endsubroutine MPI_context_sendrecv_r - - -subroutine MPI_context_sendrecv_ra(this, & - sendbuf, dest, sendtag, & - recvbuf, source, recvtag, & - nrecv, & - error) - type(MPI_context), intent(in) :: this - real(DP), intent(in) :: sendbuf(:) - integer, intent(in) :: dest, sendtag - real(DP), intent(out) :: recvbuf(:) - integer, intent(in) :: source, recvtag - integer, optional, intent(out) :: nrecv - integer, intent(out), optional :: error - - ! --- - -#ifdef _MPI - integer :: err - integer :: status(MPI_STATUS_SIZE) -#endif - - INIT_ERROR(error) - -#ifdef _MPI - call mpi_sendrecv( & - sendbuf, size(sendbuf), MPI_DOUBLE_PRECISION, dest, sendtag, & - recvbuf, size(recvbuf), MPI_DOUBLE_PRECISION, source, recvtag, & - this%communicator, status, err) - PASS_MPI_ERROR(err, error) - if (present(nrecv)) then - call mpi_get_count(status, MPI_DOUBLE_PRECISION, nrecv, err) - PASS_MPI_ERROR(err, error) - endif -#endif -endsubroutine MPI_context_sendrecv_ra - - -subroutine push_MPI_error(info, fn, line) - integer, intent(inout) :: info !% MPI error code - character(*), intent(in) :: fn - integer, intent(in) :: line - - ! --- - -#ifdef _MPI - character(MPI_MAX_ERROR_STRING) :: err_str - integer :: err_len, err_status - - ! --- - - call mpi_error_string(info, err_str, err_len, err_status) - call push_error_with_info( & - "Call to MPI library failed. Error: " // trim(err_str), & - fn, line, ERROR_MPI) - -#endif - -endsubroutine push_MPI_error - -! Get displacements (start 0) from counts for gatherv/scatterv -subroutine get_displs(counts, displs) - integer, intent(in) :: counts(:) - integer, intent(out), allocatable :: displs(:) - - integer :: i - - allocate(displs(size(counts))) - displs(1) = 0 - do i = 2, size(displs) - displs(i) = displs(i-1) + counts(i-1) - end do -end subroutine get_displs - -end module MPI_context_module diff --git a/src/libAtoms/Matrix.f95 b/src/libAtoms/Matrix.f95 deleted file mode 100644 index 4475d26d7b..0000000000 --- a/src/libAtoms/Matrix.f95 +++ /dev/null @@ -1,1722 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Matrix module -!X -!% This module handles the math of real and complex matrices. -!% The objects 'MatrixD' and 'MatrixZ' correspond to real and complex matrices, -!% respectively. They can be used for parellel computing with ScaLAPACK. -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module matrix_module - -use error_module -use System_module -use linearalgebra_module - -use MPI_context_module -use ScaLAPACK_module - -implicit none -private - -public :: MatrixD -type MatrixD - logical :: use_allocate = .true. !> - integer :: N = 0 !> global rows - integer :: M = 0 !> global columns - integer :: l_N = 0 !> local rows - integer :: l_M = 0 !> local columns - real(dp), pointer :: data(:,:) => null() !> matrix values - type(Matrix_ScaLAPACK_Info) :: ScaLAPACK_Info_obj !> meta info for scalapack - contains - final :: MatrixD_Finalise -end type MatrixD - -public :: MatrixZ -type MatrixZ - integer :: N = 0, M = 0, l_N = 0, l_M = 0 - complex(dp), allocatable:: data(:,:) - type(Matrix_ScaLAPACK_Info) ScaLAPACK_Info_obj -end type MatrixZ - -public :: Initialise -interface Initialise - module procedure MatrixD_Initialise, MatrixZ_Initialise - module procedure MatrixD_Initialise_mat, MatrixZ_Initialise_mat -end interface Initialise - -public :: Finalise -interface Finalise - module procedure MatrixD_Finalise, MatrixZ_Finalise -end interface Finalise - -!% Nullify all the matrix elements. -public :: Wipe -interface Wipe - module procedure MatrixD_Wipe, MatrixZ_Wipe -end interface Wipe - -!% Set at zero some elements of real and complex matrices. -!% Adding the optional logical values (\texttt{d_mask} and \texttt{od_mask}), the diagonal and -!% off-diagonal elements are selected. -public :: Zero -interface Zero - module procedure MatrixD_Zero, MatrixZ_Zero -end interface Zero - -public :: Print -interface Print - module procedure MatrixD_Print, MatrixZ_Print -end interface Print - -!% Add a block to a given matrix. The block dimensions have to be specified. -public :: add_block -interface add_block - module procedure MatrixD_add_block, MatrixZ_add_block -end interface add_block - -!% Diagonalise a real or complex matrix. -public :: diagonalise -interface diagonalise - module procedure MatrixD_diagonalise, MatrixD_diagonalise_gen, MatrixZ_diagonalise, MatrixZ_diagonalise_gen -end interface diagonalise - -! public :: accum_col_outer_product -! interface accum_col_outer_product -! module procedure MatrixDD_accum_col_outer_product, MatrixZZ_accum_col_outer_product -! end interface accum_col_outer_product - -!% Compute the trace of the matrix obtained multiplying two input matrices \texttt{a} and \texttt{b}. -public :: TraceMult -interface TraceMult - module procedure Matrix_TraceMult_DD, Matrix_TraceMult_DZ, Matrix_TraceMult_ZZ, Matrix_TraceMult_ZD -end interface TraceMult - -public :: partial_TraceMult -interface partial_TraceMult - module procedure Matrix_partial_TraceMult_DD, Matrix_partial_TraceMult_DZ, Matrix_partial_TraceMult_ZZ, Matrix_partial_TraceMult_ZD -end interface partial_TraceMult - -public :: partial_TraceMult_spinor -interface partial_TraceMult_spinor - module procedure Matrix_partial_TraceMult_spinor_ZZ -end interface partial_TraceMult_spinor - -!% Make real the diagonal elements of a given matrix \texttt{a} . -public :: Re_diag -interface Re_diag - module procedure Matrix_Re_diagD, Matrix_Re_diagZ -end interface Re_diag - -!% Get diagonal 2x2 blocks a given matrix \texttt{a} . -public :: diag_spinor -interface diag_spinor - module procedure Matrix_diag_spinorD, Matrix_diag_spinorZ -end interface diag_spinor - -!% Compute the sum of two matrices (complex or real) \texttt{m$_1$} and \texttt{m$_2$} weighted by -!% complex factors \texttt{f1} and \texttt{f2}. The result is a complex matrix. -public :: scaled_sum -interface scaled_sum - module procedure Matrix_scaled_sum_ZZZ, Matrix_scaled_sum_ZDD -end interface scaled_sum - -!% Add to a given matrix the elements of an other matrix \texttt{m$_1$} weighted by a -!% complex factor \texttt{f1}. -public :: scaled_accum -interface scaled_accum - module procedure Matrix_scaled_accum_DZ, Matrix_scaled_accum_ZZ -end interface scaled_accum - -!% Compute the inverse of a given matrix. -public :: inverse -interface inverse - module procedure MatrixD_inverse, MatrixZ_inverse -end interface inverse - -public :: multDiag -interface multDiag - module procedure MatrixD_multDiag_d, MatrixZ_multDiag_d, MatrixZ_multDiag_z -end interface multDiag - -public :: multDiagRL -interface multDiagRL - module procedure MatrixD_multDiagRL_d, MatrixZ_multDiagRL_d -end interface multDiagRL - -public :: matrix_product_sub -interface matrix_product_sub - module procedure MatrixZ_matrix_product_sub_zz, MatrixZ_matrix_product_sub_dz, MatrixZ_matrix_product_sub_zd - module procedure MatrixD_matrix_product_sub_dr2, MatrixD_matrix_product_sub_dd -end interface matrix_product_sub - -!% Add the identity matrix. -public :: add_identity -interface add_identity - module procedure MatrixD_add_identity -end interface add_identity - -!% Scale the matrix elements for a real factor \texttt{scale}. -public :: scale -interface scale - module procedure MatrixD_scale -end interface scale - -public :: transpose_sub -interface transpose_sub - module procedure MatrixD_transpose_sub, MatrixZ_transpose_sub -end interface transpose_sub - -public :: make_hermitian -interface make_hermitian - module procedure MatrixD_make_hermitian, MatrixZ_make_hermitian -end interface make_hermitian - -public :: SP_Matrix_QR_Solve - -contains - -subroutine MatrixD_Initialise(this, N, M, NB, MB, scalapack_obj, use_allocate) - type(MatrixD), intent(out) :: this - integer, intent(in), optional :: N, M, NB, MB - type(ScaLAPACK), intent(in), optional :: scalapack_obj - logical, intent(in), optional :: use_allocate - - call Finalise(this) - - this%use_allocate = optional_default(.true., use_allocate) - - call matrixany_initialise(N, M, NB, MB, scalapack_obj, this%N, this%M, this%l_N, this%l_M, & - this%ScaLAPACK_Info_obj) - - if (.not. this%use_allocate) return - - if (this%l_N > 0 .and. this%l_M > 0) then - allocate(this%data(this%l_N, this%l_M)) - call ALLOC_TRACE("MatrixD_Initialise "//this%l_N//" "//this%l_M, size(this%data)*REAL_SIZE) - else - allocate(this%data(1,1)) - call ALLOC_TRACE("MatrixD_Initialise "//1//" "//1, size(this%data)*REAL_SIZE) - endif - -end subroutine MatrixD_Initialise - -subroutine MatrixD_Initialise_mat(this, from) - type(MatrixD), intent(out) :: this - type(MatrixD), intent(in) :: from - - call Finalise(this) - - this%N = from%N - this%M = from%M - this%l_N = from%l_N - this%l_M = from%l_M - this%ScaLAPACK_Info_obj = from%ScaLAPACK_Info_obj - - if (this%l_N > 0 .and. this%l_M > 0) then - allocate(this%data(this%l_N, this%l_M)) - call ALLOC_TRACE("MatrixD_Initialise_mat "//this%l_N//" "//this%l_M,size(this%data)*REAL_SIZE) - else - allocate(this%data(1,1)) - call ALLOC_TRACE("MatrixD_Initialise_mat "//1//" "//1, size(this%data)*REAL_SIZE) - endif - -end subroutine MatrixD_Initialise_mat - -subroutine MatrixD_to_array1d(this, array) - type(MatrixD), intent(inout) :: this - real(dp), intent(out), dimension(:) :: array - - integer :: nrows - - if (this%ScaLAPACK_Info_obj%active) then - call ScaLAPACK_to_array1d(this%ScaLAPACK_Info_obj, this%data, array) - else - nrows = min(this%N, size(array, 1)) - array(:nrows) = this%data(:nrows,1) - array(nrows+1:) = 0.0_dp - end if -end subroutine MatrixD_to_array1d - -subroutine MatrixD_to_MatrixD(A, B, M, N, ia, ja, ib, jb, UPLO) - ! Copy general submatrix A%data(ia:ia+M-1, ja:ja+N-1) to B%data(ib:ib+M-1, jb:jb+N-1) - ! For ScaLAPACK use, assumes the BLACS context of B is the same as (or a child of) the context of A - ! If UPLO is present, only copy upper (UPLO="U") or lower (UPLO="L") triangle - type(MatrixD), intent(in) :: A - type(MatrixD), intent(inout) :: B - integer, intent(in) :: M, N - integer, intent(in), optional:: ia, ja, ib, jb - character(1), intent(in), optional :: UPLO - - integer :: my_ia, my_ja, my_ib, my_jb - - character(1) :: my_uplo - - my_uplo = optional_default("F", UPLO) - - if (A%ScaLAPACK_Info_obj%active .and. B%ScaLAPACK_Info_obj%active) then ! ScaLAPACK - - if ((my_uplo /= "U") .and. (my_uplo /= "L")) then ! Assume full matrix copy - call ScaLAPACK_pdgemr2d_wrapper(A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, B%data, & - A%ScaLAPACK_Info_obj%ScaLAPACK_obj%blacs_context, M, N, ia, ja, ib, jb) - - else - ! Triangular matrix ScaLAPACK copy - call ScaLAPACK_pdtrmr2d_wrapper(my_uplo, "N", A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, B%data, & - A%ScaLAPACK_Info_obj%ScaLAPACK_obj%blacs_context, M, N, ia, ja, ib, jb) - endif - - else ! non-MPI - my_ia = optional_default(1, ia) - my_ja = optional_default(1, ja) - my_ib = optional_default(1, ib) - my_jb = optional_default(1, jb) - - ! my_uplo = "F" will be interpreted as default full copy - call dlacpy(my_uplo, M, N, A%data(my_ia:my_ia+M-1, my_ja:my_ja+N-1), M, B%data(my_ib:my_ib+M-1, my_jb:my_jb+N-1), M) - end if -end subroutine MatrixD_to_MatrixD - -subroutine MatrixD_QR_Solve(A_SP, B_SP, cheat_nb_A) - type(MatrixD), intent(inout) :: A_SP, B_SP - logical, intent(in) :: cheat_nb_A - - if (A_SP%ScaLAPACK_Info_obj%active .and. & - B_SP%ScaLAPACK_Info_obj%active) then - call ScaLAPACK_Matrix_QR_Solve(A_SP%ScaLAPACK_Info_obj, A_SP%data, & - B_SP%ScaLAPACK_Info_obj, B_SP%data, cheat_nb_A) - else - call system_abort("MatrixD_QR_Solve() without ScaLAPACK is not implemented.") - endif -end subroutine MatrixD_QR_Solve - -subroutine SP_Matrix_QR_Solve(A, B, X, ScaLAPACK_obj, mb_A, nb_A, R, do_export_R) - real(dp), intent(inout), dimension(:,:), target :: A - real(dp), intent(inout), dimension(:), target :: B - real(dp), intent(out), dimension(:) :: X - type(ScaLAPACK), intent(in) :: ScaLAPACK_obj - integer, intent(in) :: mb_A, nb_A - real(dp), intent(out), dimension(:, :), allocatable, optional :: R - logical, intent(in), optional :: do_export_R - - logical :: cheat_nb_A - integer :: mb, nb, ml, nl, mg, ng - type(MatrixD) :: A_SP, B_SP - - ml = size(A, 1) - nl = size(A, 2) - mg = ml * ScaLAPACK_obj%n_proc_rows - ng = nl * ScaLAPACK_obj%n_proc_cols - - mb = mb_A - nb = nb_A - - cheat_nb_A = .false. - if (mb /= nb) then - if (ScaLAPACK_obj%n_proc_cols > 1) & - call system_abort("SP_Matrix_QR_Solve: blocksizes differ: "//mb//" "//nb//char(16) & - // "Cannot cheat for more than one process column: "//ScaLAPACK_obj%n_proc_cols) - cheat_nb_A = .true. - end if - - if (ScaLAPACK_obj%my_proc_row+1 < ScaLAPACK_obj%n_proc_rows .and. mod(ml, mb) /= 0) & - call system_abort("SP_Matrix_QR_Solve: nrows is not a multiple of blocksize: "//ml//" "//mb) - if (ScaLAPACK_obj%my_proc_col+1 < ScaLAPACK_obj%n_proc_cols .and. mod(nl, nb) /= 0) & - call system_abort("SP_Matrix_QR_Solve: ncols is not a multiple of blocksize: "//nl//" "//nb) - - call initialise(A_SP, mg, ng, mb, nb, scalapack_obj=ScaLAPACK_obj, use_allocate=.false.) - call initialise(B_SP, mg, 1, mb, 1, scalapack_obj=ScaLAPACK_obj, use_allocate=.false.) - - A_SP%data => A - B_SP%data(lbound(B,1):ubound(B,1),1:1) => B(:) - - ! Scalapack needs mb == nb for p?trtrs, cheating if only single process column - call MatrixD_QR_Solve(A_SP, B_SP, cheat_nb_A) - call MatrixD_QR_Get_Weights(A_SP, B_SP, ng, X, R, do_export_R) - - call finalise(A_SP) - call finalise(B_SP) -end subroutine SP_Matrix_QR_Solve - -subroutine MatrixD_QR_Get_Weights(A, b, M, weights, R, do_export_R) - ! Extract weights from b after MatrixD_QR_Solve - ! Optionally extract R - type(MatrixD), intent(in) :: A, b - integer, intent(in) :: M - real(dp), dimension(M), intent(out), target :: weights - real(dp), dimension(:, :), intent(out), allocatable, target, optional :: R - logical, intent(in), optional :: do_export_R - - type(ScaLAPACK) :: wt_scalapack - type(MatrixD) :: wt_matrixD, R_matrixD - - ! Initialise 1x1 scalapack process grid - call initialise(wt_scalapack, b%ScaLAPACK_Info_obj%ScaLAPACK_obj%MPI_obj, 1, 1) - - call initialise(wt_matrixD, M, 1, M, 1, wt_scalapack, use_allocate=.false.) - - ! weights - weights(:) = 0.0_dp - wt_matrixd%data(1:M,1:1) => weights(:) - - call MatrixD_to_MatrixD(b, wt_matrixD, M, 1) - call Finalise(wt_matrixD) - - ! R - if (present(R) .and. present(do_export_R)) then - if (do_export_R) then - call print("Extracting Posterior Covariance", PRINT_VERBOSE) - if (wt_scalapack%blacs_context > -1) then - allocate(R(M, M)) - else - allocate(R(1, 1)) - end if - - R(:, :) = 0.0_dp - ! Reuse wt_scalapack, assuming context of A equal to context of B - call initialise(R_matrixD, M, M, M, M, wt_scalapack, use_allocate=.false.) - R_matrixd%data(1:ubound(R,1),1:ubound(R,2)) => R(:, :) - call MatrixD_to_MatrixD(A, R_matrixD, M, M, UPLO="U") - call Finalise(R_matrixD) - end if - end if - call Finalise(wt_scalapack) - -end subroutine MatrixD_QR_Get_Weights - - -subroutine MatrixZ_Initialise(this, N, M, NB, MB, scalapack_obj) - type(MatrixZ), intent(out) :: this - integer, intent(in), optional :: N, M, NB, MB - type(ScaLAPACK), intent(in), optional :: scalapack_obj - - call Finalise(this) - - call matrixany_initialise(N, M, NB, MB, scalapack_obj, this%N, this%M, this%l_N, this%l_M, & - this%ScaLAPACK_Info_obj) - - if (this%l_N > 0 .and. this%l_M > 0) then - allocate(this%data(this%l_N, this%l_M)) - call ALLOC_TRACE("MatrixZ_Initialise "//this%l_N//" "//this%l_M, size(this%data)*COMPLEX_SIZE) - else - allocate(this%data(1,1)) - call ALLOC_TRACE("MatrixZ_Initialise "//1//" "//1, size(this%data)*REAL_SIZE) - endif - -end subroutine MatrixZ_Initialise - -subroutine MatrixZ_Initialise_mat(this, from) - type(MatrixZ), intent(out) :: this - type(MatrixZ), intent(in) :: from - - call Finalise(this) - - this%N = from%N - this%M = from%M - this%l_N = from%l_N - this%l_M = from%l_M - this%ScaLAPACK_Info_obj = from%ScaLAPACK_Info_obj - - if (this%l_N > 0 .and. this%l_M > 0) then - allocate(this%data(this%l_N, this%l_M)) - call ALLOC_TRACE("MatrixZ_Initialise_mat "//this%l_N//" "//this%l_M, size(this%data)*COMPLEX_SIZE) - else - allocate(this%data(1,1)) - call ALLOC_TRACE("MatrixZ_Initialise_mat "//1//" "//1, size(this%data)*REAL_SIZE) - endif - -end subroutine MatrixZ_Initialise_mat - -subroutine matrixany_initialise(N, M, NB, MB, scalapack_obj, this_N, this_M, this_l_N, this_l_M, & - this_ScaLAPACK_Info_obj) - integer, intent(in), optional :: N, M, NB, MB - type(ScaLAPACK), intent(in), target, optional :: scalapack_obj - integer, intent(out) :: this_N, this_M, this_l_N, this_l_M - type(Matrix_ScaLAPACK_Info), intent(out) :: this_ScaLAPACK_Info_obj - - integer use_NB, use_MB - - this_N = 0 - this_M = 0 - this_l_N = 0 - this_l_M = 0 - - if (present(N)) then - this_N = N - if (present(M)) then - this_M = M - else - this_M = N - endif - - if (present(NB)) then - use_NB = NB - else - use_NB = 36 - endif - if (present(MB)) then - use_MB = MB - else - use_MB = 36 - endif - - if (present(scalapack_obj)) then - call Initialise(this_ScaLAPACK_Info_obj, this_N, this_M, use_NB, use_MB, scalapack_obj) - else - call Initialise(this_ScaLAPACK_Info_obj, N, M, use_NB, use_MB) - endif - if (this_ScaLAPACK_Info_obj%active) then - this_l_N = this_ScaLAPACK_Info_obj%l_N_R - this_l_M = this_ScaLAPACK_Info_obj%l_N_C - else - this_l_N = this_N - this_l_M = this_M - endif - endif -end subroutine matrixany_initialise - -subroutine MatrixD_Finalise(this) - type(MatrixD), intent(inout) :: this - - call Wipe(this) - call Finalise(this%ScaLAPACK_Info_obj) - -end subroutine MatrixD_Finalise - -subroutine MatrixD_Wipe(this) - type(MatrixD), intent(inout) :: this - - call Wipe(this%ScaLAPACK_Info_obj) - - if (this%use_allocate .and. associated(this%data)) then - call DEALLOC_TRACE("MatrixD_Wipe ", size(this%data)*REAL_SIZE) - deallocate(this%data) - endif - this%data => null() - - this%N = 0 - this%M = 0 - this%l_N = 0 - this%l_M = 0 - -end subroutine MatrixD_Wipe - -subroutine MatrixD_Zero(this, d_mask, od_mask) - type(MatrixD), intent(inout) :: this - logical, intent(in), optional :: d_mask(:), od_mask(:) - - integer i - - if (.not. associated(this%data)) return - - if (.not. present(d_mask) .and. .not. present(od_mask)) then - this%data = 0.0_dp - return - end if - - if (present(d_mask)) then - do i=1, min(size(d_mask), this%N, this%M) - if (d_mask(i)) this%data(i,i) = 0.0_dp - end do - end if - - if (present(od_mask)) then - do i=1, size(od_mask) - if (od_mask(i)) then - if (i <= this%M) this%data(:,i) = 0.0_dp - if (i <= this%N) this%data(i,:) = 0.0_dp - end if - end do - end if - -end subroutine - -subroutine MatrixZ_Finalise(this) - type(MatrixZ), intent(inout) :: this - - call MatrixZ_Wipe(this) - call Finalise(this%ScaLAPACK_Info_obj) - -end subroutine MatrixZ_Finalise - -subroutine MatrixZ_Wipe(this) - type(MatrixZ), intent(inout) :: this - - call Wipe(this%ScaLAPACK_Info_obj) - - if (allocated(this%data)) then - call DEALLOC_TRACE("MatrixZ_Wipe ", size(this%data)*COMPLEX_SIZE) - deallocate(this%data) - endif - - this%N = 0 - this%M = 0 - this%l_N = 0 - this%l_M = 0 - -end subroutine MatrixZ_Wipe - -subroutine MatrixZ_Zero(this, d_mask, od_mask) - type(MatrixZ), intent(inout) :: this - logical, intent(in), optional :: d_mask(:), od_mask(:) - - integer i - - if (allocated(this%data)) then - if (present(d_mask) .or. present(od_mask)) then - if (present(d_mask)) then - do i=1, min(size(d_mask), this%N, this%M) - if (d_mask(i)) this%data(i,i) = 0.0_dp - end do - end if - if (present(od_mask)) then - do i=1, size(od_mask) - if (od_mask(i)) then - if (i <= this%M) this%data(:,i) = 0.0_dp - if (i <= this%N) this%data(i,:) = 0.0_dp - end if - end do - end if - else - this%data = 0.0_dp - endif - endif - -end subroutine - -subroutine MatrixD_Print(this,file) - type(MatrixD), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - if (current_verbosity() < PRINT_NORMAL) return - - call Print ("MatrixD : ", file=file) - - call Print ("N M " // this%N // " " // this%M // " l_N l_M " // this%l_N // " " // this%l_M, file=file) - call Print (this%ScaLAPACK_Info_obj, file=file) - call Print ("MatrixD data:", file=file) - if (this%ScaLAPACK_Info_obj%active) then - call Print(this%ScaLAPACK_Info_obj, this%data, file=file) - else - if (associated(this%data)) then - call Print(this%data, file=file) - endif - endif - -end subroutine MatrixD_Print - -subroutine MatrixZ_Print(this,file) - type(MatrixZ), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - if (current_verbosity() < PRINT_NORMAL) return - - call Print ("MatrixZ : ", file=file) - - call Print ("N M " // this%N // " " // this%M // " l_N l_M " // this%l_N // " " // this%l_M, file=file) - call Print (this%ScaLAPACK_Info_obj, file=file) - call Print ("MatrixZ data:", file=file) - if (allocated(this%data)) then - if (this%ScaLAPACK_Info_obj%active) then - call Print(this%ScaLAPACK_Info_obj, this%data, file=file) - else - call Print(this%data, file=file) - endif - endif - -end subroutine MatrixZ_Print - -subroutine MatrixD_add_block(this, block, block_nr, block_nc, first_row, first_col) - type(MatrixD), intent(inout) :: this - real(dp), intent(in) :: block(:,:) - integer, intent(in) :: block_nr, block_nc !% Number of rows and columns of the block - integer, intent(in) :: first_row, first_col - - integer i, j, io, jo, li, lj - - if (this%ScaLAPACK_Info_obj%active) then - do jo=1, block_nc - j = first_col + jo - 1 - do io=1, block_nr - i = first_row + io - 1 - call coords_global_to_local(this%ScaLAPACK_Info_obj, i, j, li, lj) - if (li > 0 .and. lj > 0) then - this%data(li,lj) = this%data(li,lj) + block(io,jo) - endif - end do - end do - else - this%data(first_row:first_row+block_nr-1,first_col:first_col+block_nc-1) = & - this%data(first_row:first_row+block_nr-1,first_col:first_col+block_nc-1) + & - block(1:block_nr,1:block_nc) - endif - -end subroutine - -subroutine MatrixZ_add_block(this, block, block_nr, block_nc, first_row, first_col) - type(MatrixZ), intent(inout) :: this - complex(dp), intent(in) :: block(:,:) - integer, intent(in) :: block_nr, block_nc - integer, intent(in) :: first_row, first_col - - integer i, j, io, jo, li, lj - - if (this%ScaLAPACK_Info_obj%active) then - do jo=1, block_nc - j = first_col + jo - 1 - do io=1, block_nr - i = first_row + io - 1 - call coords_global_to_local(this%ScaLAPACK_Info_obj, i, j, li, lj) - if (li > 0 .and. lj > 0) then - this%data(li,lj) = this%data(li,lj) + block(io,jo) - endif - end do - end do - else - this%data(first_row:first_row+block_nr-1,first_col:first_col+block_nc-1) = & - this%data(first_row:first_row+block_nr-1,first_col:first_col+block_nc-1) + & - block(1:block_nr,1:block_nc) - endif -end subroutine - -subroutine MatrixD_diagonalise(this, evals, evecs, ignore_symmetry, error) - type(MatrixD), intent(in), target :: this - real(dp), intent(inout) :: evals(:) !% Eigenvalues - type(MatrixD), intent(inout), target, optional :: evecs !% Eigenvectors - logical, intent(in), optional :: ignore_symmetry - integer, intent(out), optional :: error - - real(dp), pointer :: u_evecs(:,:) - type(Matrix_ScaLAPACK_Info), pointer :: evecs_ScaLAPACK_Info - - INIT_ERROR(error) - - if (present(evecs)) then - u_evecs => evecs%data - evecs_ScaLAPACK_Info => evecs%ScaLAPACK_Info_obj - else - allocate(u_evecs(this%l_N,this%l_M)) - call ALLOC_TRACE("MatrixD_diagonalise evecs ", size(u_evecs)*REAL_SIZE) - evecs_ScaLAPACK_Info => this%ScaLAPACK_Info_obj - endif - - if (this%ScaLAPACK_Info_obj%active) then - call diagonalise(this%ScaLAPACK_Info_obj, this%data, evals, evecs_ScaLAPACK_Info, u_evecs, error = error) - else - call diagonalise(this%data, evals, u_evecs, ignore_symmetry = ignore_symmetry, error = error) - endif - - if (.not.present(evecs)) then - call DEALLOC_TRACE("MatrixD_diagonalise evecs ",-size(u_evecs)*REAL_SIZE) - deallocate(u_evecs) - endif - - PASS_ERROR(error) - -end subroutine MatrixD_diagonalise - -subroutine MatrixD_diagonalise_gen(this, overlap, evals, evecs, ignore_symmetry, error) - type(MatrixD), intent(in), target :: this - type(MatrixD), intent(in) :: overlap - real(dp), intent(inout) :: evals(:) - type(MatrixD), intent(inout), target, optional :: evecs - logical, intent(in), optional :: ignore_symmetry - integer, intent(out), optional :: error - - real(dp), pointer :: u_evecs(:,:) - type(Matrix_ScaLAPACK_Info), pointer :: evecs_ScaLAPACK_Info - - INIT_ERROR(error) - - if (present(evecs)) then - u_evecs => evecs%data - evecs_ScaLAPACK_Info => evecs%ScaLAPACK_Info_obj - else - allocate(u_evecs(this%l_N,this%l_M)) - call ALLOC_TRACE("MatrixD_diagonalise_gen evecs", size(u_evecs)*REAL_SIZE) - evecs_ScaLAPACK_Info => this%ScaLAPACK_Info_obj - endif - - if (this%ScaLAPACK_Info_obj%active) then - call diagonalise(this%ScaLAPACK_Info_obj, this%data, overlap%ScaLAPACK_Info_obj, & - overlap%data, evals, evecs_ScaLAPACK_Info, u_evecs, error) - else - call diagonalise(this%data, overlap%data, evals, u_evecs, error = error) - endif - - if (.not.present(evecs)) then - call DEALLOC_TRACE("MatrixD_diagonalise_gen u_evecs", size(u_evecs)*REAL_SIZE) - deallocate(u_evecs) - endif - - PASS_ERROR(error) - -end subroutine MatrixD_diagonalise_gen - -subroutine MatrixZ_diagonalise(this, evals, evecs, ignore_symmetry, error) - type(MatrixZ), intent(in), target :: this - real(dp), intent(inout) :: evals(:) - type(MatrixZ), intent(inout), target, optional :: evecs - logical, intent(in), optional :: ignore_symmetry - integer, intent(out), optional :: error - - complex(dp), pointer :: u_evecs(:,:) - type(Matrix_ScaLAPACK_Info), pointer :: evecs_ScaLAPACK_Info - - INIT_ERROR(error) - - if (present(evecs)) then - u_evecs => evecs%data - evecs_ScaLAPACK_Info => evecs%ScaLAPACK_Info_obj - else - allocate(u_evecs(this%l_N,this%l_M)) - call ALLOC_TRACE("MatrixZ_diagonalise u_evecs", size(u_evecs)*COMPLEX_SIZE) - evecs_ScaLAPACK_Info => this%ScaLAPACK_Info_obj - endif - - if (this%ScaLAPACK_Info_obj%active) then - call diagonalise(this%ScaLAPACK_Info_obj, this%data, evals, evecs_ScaLAPACK_Info, u_evecs, error) - else - call diagonalise(this%data, evals, u_evecs, ignore_symmetry = ignore_symmetry, error = error) - endif - - if (.not.present(evecs)) then - call DEALLOC_TRACE("MatrixZ_diagonalise u_evecs", size(u_evecs)*COMPLEX_SIZE) - deallocate(u_evecs) - endif - - PASS_ERROR(error) - -end subroutine MatrixZ_diagonalise - -subroutine MatrixZ_diagonalise_gen(this, overlap, evals, evecs, ignore_symmetry, error) - type(MatrixZ), intent(in), target :: this - type(MatrixZ), intent(in) :: overlap - real(dp), intent(inout) :: evals(:) - type(MatrixZ), intent(inout), target, optional :: evecs - logical, intent(in), optional :: ignore_symmetry - integer, intent(out), optional :: error - - complex(dp), pointer :: u_evecs(:,:) - type(Matrix_ScaLAPACK_Info), pointer :: evecs_ScaLAPACK_Info - - INIT_ERROR(error) - - if (present(evecs)) then - u_evecs => evecs%data - evecs_ScaLAPACK_Info => evecs%ScaLAPACK_Info_obj - else - allocate(u_evecs(this%l_N,this%l_M)) - call ALLOC_TRACE("MatrixZ_diagonalise_gen u_evecs", size(u_evecs)*COMPLEX_SIZE) - evecs_ScaLAPACK_Info => this%ScaLAPACK_Info_obj - endif - - if (this%ScaLAPACK_Info_obj%active) then - call diagonalise(this%ScaLAPACK_Info_obj, this%data, overlap%ScaLAPACK_Info_obj, & - overlap%data, evals, evecs_ScaLAPACK_Info, u_evecs, error) - else - call diagonalise(this%data, overlap%data, evals, u_evecs, error = error) - endif - - if (.not.present(evecs)) then - call DEALLOC_TRACE("MatrixZ_diagonalise_gen u_evecs", size(u_evecs)*COMPLEX_SIZE) - deallocate(u_evecs) - endif - - PASS_ERROR(error) - -end subroutine MatrixZ_diagonalise_gen - -!subroutine MatrixDD_accum_col_outer_product(this, mati, i, f) -! type(MatrixD), intent(inout) :: this -! type(MatrixD), intent(in) :: mati -! integer, intent(in) :: i -! real(dp), intent(in) :: f -! -! if (this%ScaLAPACK_Info_obj%active) then -! call system_abort ("No support for ScaLAPACK yet in MatrixD_accum_col_outer_product") -! else -! this%data = this%data + f*(mati%data(:,i) .outer. mati%data(:,i)) -! endif -!end subroutine MatrixDD_accum_col_outer_product -! -!subroutine MatrixZZ_accum_col_outer_product(this, mati, i, f) -! type(MatrixZ), intent(inout) :: this -! type(MatrixZ), intent(in) :: mati -! integer, intent(in) :: i -! real(dp), intent(in) :: f -! -! if (this%ScaLAPACK_Info_obj%active) then -! call system_abort ("No support for ScaLAPACK yet in MatrixZ_accum_col_outer_product") -! else -! this%data = this%data + f*(mati%data(:,i) .outer. mati%data(:,i)) -! endif -!end subroutine MatrixZZ_accum_col_outer_product - -function Matrix_partial_TraceMult_DD(a, b, a_T, b_T) - type(MatrixD), intent(in) :: a, b - logical, intent(in), optional :: a_T, b_T - real(dp) :: Matrix_partial_TraceMult_DD(a%N) - - logical u_a_T, u_b_T - integer i, j, g_i, g_j - - if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") - endif - - u_a_T = optional_default(.false., a_T) - u_b_T = optional_default(.false., b_T) - - if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then - if (u_a_T .and. .not. u_b_T) then - Matrix_partial_TraceMult_DD = 0.0_dp - do j=1, a%l_M - call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) - Matrix_partial_TraceMult_DD(g_j) = sum(a%data(:,j)*b%data(:,j)) - end do - else if (.not. u_a_T .and. u_b_T) then - Matrix_partial_TraceMult_DD = 0.0_dp - do i=1, a%l_N - call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) - Matrix_partial_TraceMult_DD(g_i) = sum(a%data(i,:)*b%data(i,:)) - end do - else - call system_abort("Can only do partial_TraceMult for ScaLAPACK matrices if one is transposed and the other not") - endif - else - if (.not. u_a_T .and. .not. u_b_T) then - do i=1, a%N - Matrix_partial_TraceMult_DD(i) = sum(a%data(i,:)*b%data(:,i)) - end do - else if (u_a_T .and. u_b_T) then - do i=1, a%N - Matrix_partial_TraceMult_DD(i) = sum(a%data(:,i)*b%data(i,:)) - end do - else if (.not. u_a_T .and. u_b_T) then - Matrix_partial_TraceMult_DD(:) = 0.0_dp - do i=1, a%N - Matrix_partial_TraceMult_DD(:) = Matrix_partial_TraceMult_DD(:) + a%data(:,i)*b%data(:,i) - end do - else - do i=1, a%N - Matrix_partial_TraceMult_DD(i) = sum(a%data(:,i)*b%data(:,i)) - end do - endif - endif - -end function Matrix_partial_TraceMult_DD - -function Matrix_partial_TraceMult_DZ(a, b, a_T, b_H) - type(MatrixD), intent(in) :: a - type(MatrixZ), intent(in) :: b - logical, intent(in), optional :: a_T, b_H - complex(dp) :: Matrix_partial_TraceMult_DZ(a%N) - - logical u_a_T, u_b_H - integer i, j, g_i, g_j - - if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") - endif - - u_a_T = optional_default(.false., a_T) - u_b_H = optional_default(.false., b_H) - - if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then - if (u_a_T .and. .not. u_b_H) then - Matrix_partial_TraceMult_DZ = 0.0_dp - do j=1, a%l_M - call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) - Matrix_partial_TraceMult_DZ(g_j) = sum(a%data(:,j)*b%data(:,j)) - end do - else if (.not. u_a_T .and. u_b_H) then - Matrix_partial_TraceMult_DZ = 0.0_dp - do i=1, a%l_N - call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) - Matrix_partial_TraceMult_DZ(g_i) = sum(a%data(i,:)*conjg(b%data(i,:))) - end do - else - call system_abort("Can only do partial_TraceMult for ScaLAPACK matrices if one is transposed and the other not") - endif - else ! no scalapack - if (.not. u_a_T .and. .not. u_b_H) then - do i=1, a%N - Matrix_partial_TraceMult_DZ(i) = sum(a%data(i,:)*b%data(:,i)) - end do - else if (u_a_T .and. u_b_H) then - do i=1, a%N - Matrix_partial_TraceMult_DZ(i) = sum(a%data(:,i)*conjg(b%data(i,:))) - end do - else if (.not. u_a_T .and. u_b_H) then - Matrix_partial_TraceMult_DZ(:) = 0.0_dp - do i=1, a%N - Matrix_partial_TraceMult_DZ(:) = Matrix_partial_TraceMult_DZ(:) + a%data(:,i)*conjg(b%data(:,i)) - end do - else - do i=1, a%N - Matrix_partial_TraceMult_DZ(i) = sum(a%data(:,i)*b%data(:,i)) - end do - endif - endif - -end function Matrix_partial_TraceMult_DZ - -function Matrix_partial_TraceMult_ZD(a, b, a_H, b_T) - type(MatrixZ), intent(in) :: a - type(MatrixD), intent(in) :: b - logical, intent(in), optional :: a_H, b_T - complex(dp) :: Matrix_partial_TraceMult_ZD(a%N) - - logical u_a_H, u_b_T - integer i, j, g_i, g_j - - if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") - endif - - u_a_H = optional_default(.false., a_H) - u_b_T = optional_default(.false., b_T) - - if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then - if (u_a_H .and. .not. u_b_T) then - Matrix_partial_TraceMult_ZD = 0.0_dp - do j=1, a%l_M - call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) - Matrix_partial_TraceMult_ZD(g_j) = sum(conjg(a%data(:,j))*b%data(:,j)) - end do - else if (.not. u_a_H .and. u_b_T) then - Matrix_partial_TraceMult_ZD = 0.0_dp - do i=1, a%l_N - call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) - Matrix_partial_TraceMult_ZD(g_i) = sum(a%data(i,:)*b%data(i,:)) - end do - else - call system_abort("Can only do partial_TraceMult for ScaLAPACK matrices if one is transposed and the other not") - endif - else - if (.not. u_a_H .and. .not. u_b_T) then - do i=1, a%N - Matrix_partial_TraceMult_ZD(i) = sum(a%data(i,:)*b%data(:,i)) - end do - else if (u_a_H .and. u_b_T) then - do i=1, a%N - Matrix_partial_TraceMult_ZD(i) = sum(conjg(a%data(:,i))*b%data(i,:)) - end do - else if (.not. u_a_H .and. u_b_T) then - Matrix_partial_TraceMult_ZD(:) = 0.0_dp - do i=1, a%N - Matrix_partial_TraceMult_ZD(:) = Matrix_partial_TraceMult_ZD(:) + a%data(:,i)*b%data(:,i) - end do - else - do i=1, a%N - Matrix_partial_TraceMult_ZD(i) = sum(conjg(a%data(:,i))*b%data(:,i)) - end do - endif - endif - -end function Matrix_partial_TraceMult_ZD - -function Matrix_partial_TraceMult_ZZ(a, b, a_H, b_H) - type(MatrixZ), intent(in) :: a - type(MatrixZ), intent(in) :: b - logical, intent(in), optional :: a_H, b_H - complex(dp) :: Matrix_partial_TraceMult_ZZ(a%N) - - logical u_a_H, u_b_H - integer i, j, g_i, g_j - - if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") - endif - - u_a_H = optional_default(.false., a_H) - u_b_H = optional_default(.false., b_H) - - if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then - if (u_a_H .and. .not. u_b_H) then - Matrix_partial_TraceMult_ZZ = 0.0_dp - do j=1, a%l_M - call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) - Matrix_partial_TraceMult_ZZ(g_j) = sum(conjg(a%data(:,j))*b%data(:,j)) - end do - else if (.not. u_a_H .and. u_b_H) then - Matrix_partial_TraceMult_ZZ = 0.0_dp - do i=1, a%l_N - call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) - Matrix_partial_TraceMult_ZZ(g_i) = sum(a%data(i,:)*conjg(b%data(i,:))) - end do - else - call system_abort("Can only do partial_TraceMult for ScaLAPACK matrices if one is transposed and the other not") - endif - else - if (.not. u_a_H .and. .not. u_b_H) then - do i=1, a%N - Matrix_partial_TraceMult_ZZ(i) = sum(a%data(i,:)*b%data(:,i)) - end do - else if (u_a_H .and. u_b_H) then - do i=1, a%N - Matrix_partial_TraceMult_ZZ(i) = sum(conjg(a%data(:,i))*conjg(b%data(i,:))) - end do - else if (.not. u_a_H .and. u_b_H) then - Matrix_partial_TraceMult_ZZ(:) = 0.0_dp - do i=1, a%N - Matrix_partial_TraceMult_ZZ(:) = Matrix_partial_TraceMult_ZZ(:) + a%data(:,i)*conjg(b%data(:,i)) - end do - else - do i=1, a%N - Matrix_partial_TraceMult_ZZ(i) = sum(conjg(a%data(:,i))*b%data(:,i)) - end do - endif - endif - -end function Matrix_partial_TraceMult_ZZ - -function Matrix_partial_TraceMult_spinor_ZZ(a, b, a_H, b_H) - type(MatrixZ), intent(in) :: a - type(MatrixZ), intent(in) :: b - logical, intent(in), optional :: a_H, b_H - complex(dp) :: Matrix_partial_TraceMult_spinor_ZZ(2,2,a%N/2) - - logical u_a_H, u_b_H - integer i, j, g_i, g_j - - if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") - endif - - u_a_H = optional_default(.false., a_H) - u_b_H = optional_default(.false., b_H) - - if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then - if (u_a_H .and. .not. u_b_H) then - Matrix_partial_TraceMult_spinor_ZZ = 0.0_dp - do j=1, a%l_M - call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) - Matrix_partial_TraceMult_spinor_ZZ(1,1,(g_j-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,j))*b%data(1:a%l_N:2,j)) - Matrix_partial_TraceMult_spinor_ZZ(1,2,(g_j-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,j))*b%data(2:a%l_N:2,j)) - Matrix_partial_TraceMult_spinor_ZZ(2,1,(g_j-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,j+1))*b%data(1:a%l_N:2,j+1)) - Matrix_partial_TraceMult_spinor_ZZ(2,2,(g_j-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,j+1))*b%data(2:a%l_N:2,j+1)) - end do - else if (.not. u_a_H .and. u_b_H) then - Matrix_partial_TraceMult_spinor_ZZ = 0.0_dp - do i=1, a%l_N, 2 - call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) - Matrix_partial_TraceMult_spinor_ZZ(1,1,(g_i-1)/2+1) = sum(a%data(i,1:a%l_M:2)*conjg(b%data(i,1:b%l_M:2))) - Matrix_partial_TraceMult_spinor_ZZ(1,2,(g_i-1)/2+1) = sum(a%data(i,2:a%l_M:2)*conjg(b%data(i,2:b%l_M:2))) - Matrix_partial_TraceMult_spinor_ZZ(2,1,(g_i-1)/2+1) = sum(a%data(i+1,1:a%l_M:2)*conjg(b%data(i+1,1:b%l_M:2))) - Matrix_partial_TraceMult_spinor_ZZ(2,2,(g_i-1)/2+1) = sum(a%data(i+1,2:a%l_M:2)*conjg(b%data(i+1,2:b%l_M:2))) - end do - else - call system_abort("Can only do partial_TraceMult_spinor for ScaLAPACK matrices if one is transposed and the other not") - endif - else - if (.not. u_a_H .and. .not. u_b_H) then - do i=1, a%N, 2 - Matrix_partial_TraceMult_spinor_ZZ(1,1,(i-1)/2+1) = sum(a%data(i,1:a%l_M:2)*b%data(1:b%l_N:2,i)) - Matrix_partial_TraceMult_spinor_ZZ(1,2,(i-1)/2+1) = sum(a%data(i,2:a%l_M:2)*b%data(2:b%l_N:2,i)) - Matrix_partial_TraceMult_spinor_ZZ(2,1,(i-1)/2+1) = sum(a%data(i+1,1:a%l_M:2)*b%data(1:b%l_N:2,i+1)) - Matrix_partial_TraceMult_spinor_ZZ(2,2,(i-1)/2+1) = sum(a%data(i+1,2:a%l_M:2)*b%data(2:b%l_N:2,i+1)) - end do - else if (u_a_H .and. u_b_H) then - do i=1, a%N, 2 - Matrix_partial_TraceMult_spinor_ZZ(1,1,(i-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,i))*conjg(b%data(i,1:b%l_M:2))) - Matrix_partial_TraceMult_spinor_ZZ(1,2,(i-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,i))*conjg(b%data(i,2:b%l_M:2))) - Matrix_partial_TraceMult_spinor_ZZ(2,1,(i-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,i+1))*conjg(b%data(i+1,1:b%l_M:2))) - Matrix_partial_TraceMult_spinor_ZZ(2,2,(i-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,i+1))*conjg(b%data(i+1,2:b%l_M:2))) - end do - else if (.not. u_a_H .and. u_b_H) then - Matrix_partial_TraceMult_spinor_ZZ(:,:,:) = 0.0_dp - do i=1, a%N, 2 - Matrix_partial_TraceMult_spinor_ZZ(1,1,:) = Matrix_partial_TraceMult_spinor_ZZ(1,1,:) + a%data(1:a%l_N:2,i)*conjg(b%data(1:b%l_N:2,i)) - Matrix_partial_TraceMult_spinor_ZZ(1,2,:) = Matrix_partial_TraceMult_spinor_ZZ(1,2,:) + a%data(1:a%l_N:2,i+1)*conjg(b%data(1:b%l_N:2,i+1)) - Matrix_partial_TraceMult_spinor_ZZ(2,1,:) = Matrix_partial_TraceMult_spinor_ZZ(2,1,:) + a%data(2:a%l_N:2,i)*conjg(b%data(2:b%l_N:2,i)) - Matrix_partial_TraceMult_spinor_ZZ(2,2,:) = Matrix_partial_TraceMult_spinor_ZZ(2,2,:) + a%data(2:a%l_N:2,i+1)*conjg(b%data(2:b%l_N:2,i+1)) - end do - else - do i=1, a%N, 2 - Matrix_partial_TraceMult_spinor_ZZ(1,1,(i-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,i))*b%data(1:b%l_N:2,i)) - Matrix_partial_TraceMult_spinor_ZZ(1,2,(i-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,i))*b%data(2:b%l_N:2,i)) - Matrix_partial_TraceMult_spinor_ZZ(2,1,(i-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,i+1))*b%data(1:b%l_N:2,i+1)) - Matrix_partial_TraceMult_spinor_ZZ(2,2,(i-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,i+1))*b%data(2:b%l_N:2,i+1)) - end do - endif - endif - -end function Matrix_partial_TraceMult_spinor_ZZ - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -function Matrix_TraceMult_DD(a, b, w, a_T, b_T) - type(MatrixD), intent(in) :: a, b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_T, b_T - real(dp) :: Matrix_TraceMult_DD - - if (present(w)) then - Matrix_TraceMult_DD = sum(partial_TraceMult(a, b, a_T, b_T)*w) - else - Matrix_TraceMult_DD = sum(partial_TraceMult(a, b, a_T, b_T)) - endif - -end function Matrix_TraceMult_DD - -function Matrix_TraceMult_DZ(a, b, w, a_T, b_H) - type(MatrixD), intent(in) :: a - type(MatrixZ), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_T, b_H - complex(dp) :: Matrix_TraceMult_DZ - - if (present(w)) then - Matrix_TraceMult_DZ = sum(partial_TraceMult(a, b, a_T, b_H)*w) - else - Matrix_TraceMult_DZ = sum(partial_TraceMult(a, b, a_T, b_H)) - endif - -end function Matrix_TraceMult_DZ - -function Matrix_TraceMult_ZD(a, b, w, a_H, b_T) - type(MatrixZ), intent(in) :: a - type(MatrixD), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_H, b_T - complex(dp) :: Matrix_TraceMult_ZD - - if (present(w)) then - Matrix_TraceMult_ZD = sum(partial_TraceMult(a, b, a_H, b_T)*w) - else - Matrix_TraceMult_ZD = sum(partial_TraceMult(a, b, a_H, b_T)) - endif - -end function Matrix_TraceMult_ZD - -function Matrix_TraceMult_ZZ(a, b, w, a_H, b_H) - type(MatrixZ), intent(in) :: a - type(MatrixZ), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_H, b_H - complex(dp) :: Matrix_TraceMult_ZZ - - if (present(w)) then - Matrix_TraceMult_ZZ = sum(partial_TraceMult(a, b, a_H, b_H)*w) - else - Matrix_TraceMult_ZZ = sum(partial_TraceMult(a, b, a_H, b_H)) - endif - -end function Matrix_TraceMult_ZZ - -function Matrix_Re_diagZ(a) - type(MatrixZ), intent(in) :: a - real(dp) :: Matrix_Re_diagZ(a%N) - - integer i - - if (a%ScaLAPACK_Info_obj%active) then - Matrix_Re_diagZ = Re_diag(a%ScaLAPACK_Info_obj, a%data) - else - do i=1, a%N - Matrix_Re_diagZ(i) = real(a%data(i,i)) - end do - endif -end function Matrix_Re_diagZ - -function Matrix_Re_diagD(a) - type(MatrixD), intent(in) :: a - real(dp) :: Matrix_Re_diagD(a%N) - - integer i - - if (a%ScaLAPACK_Info_obj%active) then - Matrix_Re_diagD = Re_diag(a%ScaLAPACK_Info_obj, a%data) - else - do i=1, a%N - Matrix_Re_diagD(i) = a%data(i,i) - end do - endif -end function Matrix_Re_diagD - -function Matrix_diag_spinorZ(a) - type(MatrixZ), intent(in) :: a - complex(dp) :: Matrix_diag_spinorZ(2,2,a%N/2) - - integer i - - if (a%ScaLAPACK_Info_obj%active) then - Matrix_diag_spinorZ = diag_spinor(a%ScaLAPACK_Info_obj, a%data) - else - Matrix_diag_spinorZ = 0.0_dp - do i=1, a%N,2 - Matrix_diag_spinorZ(:,:,(i-1)/2+1) = a%data(i:i+1,i:i+1) - end do - endif -end function Matrix_diag_spinorZ - -function Matrix_diag_spinorD(a) - type(MatrixD), intent(in) :: a - complex(dp) :: Matrix_diag_spinorD(2,2,a%N/2) - - integer i - - if (a%ScaLAPACK_Info_obj%active) then - Matrix_diag_spinorD = diag_spinor(a%ScaLAPACK_Info_obj, a%data) - else - Matrix_diag_spinorD = 0.0_dp - do i=1, a%N, 2 - Matrix_diag_spinorD(:,:,(i-1)/2+1) = a%data(i:i+1,i:i+1) - end do - endif -end function Matrix_diag_spinorD - -subroutine Matrix_scaled_sum_ZDD(this, f1, m1, f2, m2) - type(MatrixZ), intent(inout) :: this - complex(dp), intent(in) :: f1 - type(MatrixD), intent(in) :: m1 - complex(dp), intent(in) :: f2 - type(MatrixD), intent(in) :: m2 - - integer i - - if (m1%ScaLAPACK_Info_obj%active .neqv. m2%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do scaled_sum for mixed ScaLAPCAK non-ScaLAPACK matrices") - endif - - do i=1, size(this%data,2) - this%data(:,i) = f1*m1%data(:,i) + f2*m2%data(:,i) - end do - -end subroutine Matrix_scaled_sum_ZDD - -subroutine Matrix_scaled_sum_ZZZ(this, f1, m1, f2, m2) - type(MatrixZ), intent(inout) :: this - complex(dp), intent(in) :: f1 - type(MatrixZ), intent(in) :: m1 - complex(dp), intent(in) :: f2 - type(MatrixZ), intent(in) :: m2 - - integer i - - if (m1%ScaLAPACK_Info_obj%active .neqv. m2%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do scaled_sum for mixed ScaLAPCAK non-ScaLAPACK matrices") - endif - - do i=1, size(this%data,2) - this%data(:,i) = f1*m1%data(:,i) + f2*m2%data(:,i) - end do - -end subroutine Matrix_scaled_sum_ZZZ - -subroutine Matrix_scaled_accum_DZ(this, f1, m1) - type(MatrixD), intent(inout) :: this - complex(dp), intent(in) :: f1 - type(MatrixZ), intent(in) :: m1 - - integer i - - if (this%ScaLAPACK_Info_obj%active .neqv. m1%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do scaled_accum for mixed ScaLAPCAK non-ScaLAPACK matrices") - endif - - do i=1, size(this%data,2) - this%data(:,i) = this%data(:,i) + f1*m1%data(:,i) - end do - -end subroutine Matrix_scaled_accum_DZ - -subroutine Matrix_scaled_accum_ZZ(this, f1, m1) - type(MatrixZ), intent(inout) :: this - complex(dp), intent(in) :: f1 - type(MatrixZ), intent(in) :: m1 - - integer i - - if (this%ScaLAPACK_Info_obj%active .neqv. m1%ScaLAPACK_Info_obj%active) then - call system_abort("Can't do scaled_accum for mixed ScaLAPCAK non-ScaLAPACK matrices") - endif - - do i=1, size(this%data,2) - this%data(:,i) = this%data(:,i) + f1*m1%data(:,i) - end do - -end subroutine Matrix_scaled_accum_ZZ - - -subroutine MatrixD_inverse(this, inv, positive) - type(MatrixD), intent(inout) :: this - type(MatrixD), intent(out), optional :: inv - logical, intent(in), optional :: positive - - if (this%ScaLAPACK_Info_obj%active) then - if (present(inv)) then - call inverse(this%ScaLAPACK_Info_obj, this%data, inv%ScaLAPACK_Info_obj, inv%data, positive) - else - call inverse(this%ScaLAPACK_Info_obj, this%data, positive_in = positive) - endif - else - if (present(inv)) then - call inverse(this%data, inv%data, positive) - else - call inverse(this%data, positive_in = positive) - endif - endif -end subroutine MatrixD_inverse - -subroutine MatrixZ_inverse(this, inv, positive) - type(MatrixZ), intent(inout) :: this - type(MatrixZ), intent(out), optional :: inv - logical, intent(in), optional :: positive - - if (this%ScaLAPACK_Info_obj%active) then - if (present(inv)) then - call inverse(this%ScaLAPACK_Info_obj, this%data, inv%ScaLAPACK_Info_obj, inv%data, positive) - else - call inverse(this%ScaLAPACK_Info_obj, this%data, positive_in = positive) - endif - else - if (present(inv)) then - call inverse(this%data, inv%data, positive) - else - call inverse(this%data, positive_in = positive) - endif - endif - -end subroutine MatrixZ_inverse - -subroutine MatrixD_multDiag_d(this, A, diag) - type(MatrixD), intent(inout) :: this - type(MatrixD), intent(in) :: A - real(dp), intent(in) :: diag(:) - - if (this%M /= size(diag) .or. A%M /= size(diag)) & - call system_abort("Called MatrixD_multDiag_d with mismatched sizes") - - if (this%ScaLAPACK_Info_obj%active .and. A%ScaLAPACK_Info_obj%active) then - call matrix_product_vect_asdiagonal_sub(this%ScaLAPACK_Info_obj, this%data, A%ScaLAPACK_Info_obj, A%data, diag) - else if (.not.this%ScaLAPACK_Info_obj%active .and. .not.A%ScaLAPACK_Info_obj%active) then - call matrix_product_vect_asdiagonal_sub(this%data, A%data, diag) - else - call system_abort("Called MatrixD_multDiag_d with mix of ScaLAPACK and non-ScaLAPACK objects") - endif -end subroutine MatrixD_multDiag_d - -subroutine MatrixZ_multDiag_d(this, A, diag) - type(MatrixZ), intent(inout) :: this - type(MatrixZ), intent(in) :: A - real(dp), intent(in) :: diag(:) - - if (this%M /= size(diag) .or. A%M /= size(diag)) & - call system_abort("Called MatrixZ_multDiag_d with mismatched sizes") - - if (this%ScaLAPACK_Info_obj%active .and. A%ScaLAPACK_Info_obj%active) then - call matrix_product_vect_asdiagonal_sub(this%ScaLAPACK_Info_obj, this%data, A%ScaLAPACK_Info_obj, A%data, diag) - else if (.not.this%ScaLAPACK_Info_obj%active .and. .not.A%ScaLAPACK_Info_obj%active) then - call matrix_product_vect_asdiagonal_sub(this%data, A%data, diag) - else - call system_abort("Called MatrixZ_multDiag_d with mix of ScaLAPACK and non-ScaLAPACK objects") - endif -end subroutine MatrixZ_multDiag_d - -subroutine MatrixZ_multDiag_z(this, A, diag) - type(MatrixZ), intent(inout) :: this - type(MatrixZ), intent(in) :: A - complex(dp), intent(in) :: diag(:) - - if (this%M /= size(diag) .or. A%M /= size(diag)) & - call system_abort("Called MatrixZ_multDiag_z with mismatched sizes") - - if (this%ScaLAPACK_Info_obj%active .and. A%ScaLAPACK_Info_obj%active) then - call matrix_product_vect_asdiagonal_sub(this%ScaLAPACK_Info_obj, this%data, A%ScaLAPACK_Info_obj, A%data, diag) - else if (.not.this%ScaLAPACK_Info_obj%active .and. .not.A%ScaLAPACK_Info_obj%active) then - call matrix_product_vect_asdiagonal_sub(this%data, A%data, diag) - else - call system_abort("Called MatrixZ_multDiag_z with mix of ScaLAPACK and non-ScaLAPACK objects") - endif -end subroutine MatrixZ_multDiag_z - -subroutine MatrixD_multDiagRL_d(this, A, diag) - type(MatrixD), intent(inout) :: this - type(MatrixD), intent(in) :: A - real(dp), intent(in) :: diag(:) - - if (this%M /= size(diag) .or. A%M /= size(diag)) & - call system_abort("Called MatrixD_multDiagRL_d with mismatched sizes") - - call matrix_product_vect_asdiagonal_RL_sub(this%data, A%data, diag) -end subroutine MatrixD_multDiagRL_d - -subroutine MatrixZ_multDiagRL_d(this, A, diag) - type(MatrixZ), intent(inout) :: this - type(MatrixZ), intent(in) :: A - real(dp), intent(in) :: diag(:) - - if (this%M /= size(diag) .or. A%M /= size(diag)) & - call system_abort("Called MatrixZ_multDiagRL_d with mismatched sizes") - - call matrix_product_vect_asdiagonal_RL_sub(this%data, A%data, diag) -end subroutine MatrixZ_multDiagRL_d - -subroutine MatrixZ_matrix_product_sub_zz(C, A, B, a_transpose, a_conjugate, b_transpose, b_conjugate) - type(MatrixZ), intent(inout) :: C - type(MatrixZ), intent(in) :: A, B - logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose, b_conjugate - - if (a%ScaLAPACK_Info_obj%active .and. & - b%ScaLAPACK_Info_obj%active .and. & - c%ScaLAPACK_Info_obj%active) then - call matrix_product_sub(C%ScaLAPACK_Info_obj, C%data, A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, B%data, & - a_transpose, a_conjugate, b_transpose, b_conjugate) - else if (.not.a%ScaLAPACK_Info_obj%active .and. & - .not.b%ScaLAPACK_Info_obj%active .and. & - .not.c%ScaLAPACK_Info_obj%active) then - call matrix_product_sub(C%data, A%data, B%data, a_transpose, a_conjugate, b_transpose, b_conjugate) - else - call system_abort("Called MatrixZ_matric_product_sub_zz with a mix of ScaLAPACK and non-ScaLAPACK matrices") - endif -end subroutine MatrixZ_matrix_product_sub_zz - -subroutine MatrixZ_matrix_product_sub_dz(C, A, B, a_transpose, b_transpose, b_conjugate) - type(MatrixZ), intent(inout) :: C - type(MatrixD), intent(in) :: A - type(MatrixZ), intent(in) :: B - logical, intent(in), optional :: a_transpose, b_transpose, b_conjugate - - logical a_transp, b_transp, b_conjg - real(dp), allocatable :: tC(:,:), tB(:,:) - - allocate(tC(C%l_N, C%l_M)) - call ALLOC_TRACE("MatrixZ_product_sub_dz tC", size(tC)*REAL_SIZE) - allocate(tB(B%l_N, B%l_M)) - call ALLOC_TRACE("MatrixZ_product_sub_dz tB", size(tB)*REAL_SIZE) - - a_transp = optional_default(.false., a_transpose) - b_transp = optional_default(.false., b_transpose) - b_conjg = optional_default(.false., b_conjugate) - - if (a%ScaLAPACK_Info_obj%active .and. & - b%ScaLAPACK_Info_obj%active .and. & - c%ScaLAPACK_Info_obj%active) then - tB = dble(B%data) - call matrix_product_sub(C%ScaLAPACK_Info_obj, tC, A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, tB, & - a_transp, b_transp .or. b_conjg) - C%data = tC - if (b_conjg) then - tB = -aimag(B%data) - else - tB = aimag(B%data) - endif - call matrix_product_sub(C%ScaLAPACK_Info_obj, tC, A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, tB, & - a_transp, b_transp .or. b_conjg) - c%data = c%data + cmplx(0.0_dp, tC, dp) - else if (.not.a%ScaLAPACK_Info_obj%active .and. & - .not.b%ScaLAPACK_Info_obj%active .and. & - .not.c%ScaLAPACK_Info_obj%active) then - tB = dble(B%data) - call matrix_product_sub(tC, A%data, tB, a_transp, b_transp .or. b_conjg) - C%data = tC - if (b_conjg) then - tB = -aimag(B%data) - else - tB = aimag(B%data) - endif - call matrix_product_sub(tC, A%data, tB, a_transp, b_transp .or. b_conjg) - c%data = c%data + cmplx(0.0_dp, tC, dp) - else - call system_abort("Called MatrixZ_matric_product_sub_dz with a mix of ScaLAPACK and non-ScaLAPACK matrices") - endif - - call DEALLOC_TRACE("MatrixZ_product_sub_dz tC", size(tC)*REAL_SIZE) - deallocate(tC) - call DEALLOC_TRACE("MatrixZ_product_sub_dz tB", size(tB)*REAL_SIZE) - deallocate(tB) -end subroutine MatrixZ_matrix_product_sub_dz - -subroutine MatrixZ_matrix_product_sub_zd(C, A, B, a_transpose, a_conjugate, b_transpose) - type(MatrixZ), intent(inout) :: C - type(MatrixZ), intent(in) :: A - type(MatrixD), intent(in) :: B - logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose - - logical a_transp, a_conjg, b_transp - real(dp), allocatable :: tC(:,:), tA(:,:) - - allocate(tC(C%l_N, C%l_M)) - call ALLOC_TRACE("MatrixZ_product_sub_zd tC", size(tC)*REAL_SIZE) - allocate(tA(A%l_N, A%l_M)) - call ALLOC_TRACE("MatrixZ_product_sub_zd tA", size(tA)*REAL_SIZE) - - a_transp = optional_default(.false., a_transpose) - a_conjg = optional_default(.false., a_conjugate) - b_transp = optional_default(.false., b_transpose) - - if (a%ScaLAPACK_Info_obj%active .and. & - b%ScaLAPACK_Info_obj%active .and. & - c%ScaLAPACK_Info_obj%active) then - tA = dble(A%data) - call matrix_product_sub(C%ScaLAPACK_Info_obj, tC, A%ScaLAPACK_Info_obj, tA, B%ScaLAPACK_Info_obj, B%data, & - a_transp .or. a_conjg, b_transp) - C%data = tC - if (a_conjg) then - tA = -aimag(A%data) - else - tA = aimag(A%data) - endif - call matrix_product_sub(C%ScaLAPACK_Info_obj, tC, A%ScaLAPACK_Info_obj, tA, B%ScaLAPACK_Info_obj, B%data, & - a_transp .or. a_conjg, b_transp) - c%data = c%data + cmplx(0.0_dp, tC, dp) - else if (.not.a%ScaLAPACK_Info_obj%active .and. & - .not.b%ScaLAPACK_Info_obj%active .and. & - .not.c%ScaLAPACK_Info_obj%active) then - tA = dble(A%data) - call matrix_product_sub(tC, tA, B%data, a_transp .or. a_conjg, b_transp) - C%data = tC - if (a_conjg) then - tA = -aimag(A%data) - else - tA = aimag(A%data) - endif - call matrix_product_sub(tC, tA, B%data, a_transp .or. a_conjg, b_transp) - c%data = c%data + cmplx(0.0_dp, tC, dp) - else - call system_abort("Called MatrixZ_matric_product_sub_zd with a mix of ScaLAPACK and non-ScaLAPACK matrices") - endif - - call DEALLOC_TRACE("MatrixZ_product_sub_zd tC", size(tC)*REAL_SIZE) - deallocate(tC) - call DEALLOC_TRACE("MatrixZ_product_sub_zd tA", size(tA)*REAL_SIZE) - deallocate(tA) -end subroutine MatrixZ_matrix_product_sub_zd - -subroutine MatrixD_matrix_product_sub_dd(C, A, B, a_transpose, b_transpose) - type(MatrixD), intent(inout) :: C - type(MatrixD), intent(in) :: A, B - logical, intent(in), optional :: a_transpose, b_transpose - - if (a%ScaLAPACK_Info_obj%active .and. & - b%ScaLAPACK_Info_obj%active .and. & - c%ScaLAPACK_Info_obj%active) then - call matrix_product_sub(C%ScaLAPACK_Info_obj, C%data, A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, B%data, & - a_transpose, b_transpose) - else if (.not.a%ScaLAPACK_Info_obj%active .and. & - .not.b%ScaLAPACK_Info_obj%active .and. & - .not.c%ScaLAPACK_Info_obj%active) then - call matrix_product_sub(C%data, A%data, B%data, a_transpose, b_transpose) - else - call system_abort("Called MatrixD_matric_product_sub_dd with a mix of ScaLAPACK and non-ScaLAPACK matrices") - endif -end subroutine MatrixD_matrix_product_sub_dd - -subroutine MatrixD_matrix_product_sub_dr2(C, A, B, a_transpose, b_transpose) - type(MatrixD), intent(inout) :: C - type(MatrixD), intent(in) :: A - real(dp), intent(in) :: B(:,:) - logical, intent(in), optional :: a_transpose, b_transpose - - if (.not.a%ScaLAPACK_Info_obj%active .and. .not.c%ScaLAPACK_Info_obj%active) then - call matrix_product_sub(C%data, A%data, B, a_transpose, b_transpose) - else - call system_abort("Called MatrixZ_matric_product_sub_dr2 with a mix of ScaLAPACK and non-ScaLAPACK matrices") - endif - -end subroutine MatrixD_matrix_product_sub_dr2 - -subroutine MatrixD_add_identity(A) - type(MatrixD), intent(inout) :: A - - if (A%ScaLAPACK_Info_obj%active) then - call add_identity(A%ScaLAPACK_Info_obj, A%data) - else - call add_identity(A%data) - endif -end subroutine - -subroutine MatrixD_scale(A, scale) - type(MatrixD), intent(inout) :: A - real(dp), intent(in) :: scale - - A%data = A%data * scale -end subroutine - -subroutine MatrixD_transpose_sub(this, m) - type(MatrixD), intent(inout) :: this - type(MatrixD), intent(in) :: m - - if (this%N /= m%M .or. this%M /= m%N) call system_abort("Called MatrixD_transpose_sub with mismatched sizes "// & - "this " // this%N // " " // this%M // " m " // m%N // " " //m%M) - - - if (this%ScaLAPACK_Info_obj%active .and. m%ScaLAPACK_Info_obj%active) then - call system_abort("MatrixD_transpose_sub not yet implemented for ScaLAPACK matrices") - else - this%data = transpose(m%data) - endif -end subroutine MatrixD_transpose_sub - -subroutine MatrixZ_transpose_sub(this, m) - type(MatrixZ), intent(inout) :: this - type(MatrixZ), intent(in) :: m - - if (this%N /= m%M .or. this%M /= m%N) call system_abort("Called MatrixZ_transpose_sub with mismatched sizes "// & - "this " // this%N // " " // this%M // " m " // m%N // " " //m%M) - - - if (this%ScaLAPACK_Info_obj%active .and. m%ScaLAPACK_Info_obj%active) then - call system_abort("MatrixZ_transpose_sub not yet implemented for ScaLAPACK matrices") - else - this%data = transpose(m%data) - endif -end subroutine MatrixZ_transpose_sub - -subroutine MatrixD_make_hermitian(this) - type(MatrixD), intent(inout) :: this - - if (this%ScaLAPACK_Info_obj%active) then - call system_abort("MatrixD_make_hermitian not yet implemented for ScaLAPACK matrices") - else - call make_hermitian(this%data) - endif -end subroutine MatrixD_make_hermitian - -subroutine MatrixZ_make_hermitian(this) - type(MatrixZ), intent(inout) :: this - - if (this%ScaLAPACK_Info_obj%active) then - call system_abort("MatrixZ_make_hermitian not yet implemented for ScaLAPACK matrices") - else - call make_hermitian(this%data) - endif -end subroutine MatrixZ_make_hermitian - -end module matrix_module diff --git a/src/libAtoms/ParamReader.f95 b/src/libAtoms/ParamReader.f95 deleted file mode 100644 index 5cfa37f497..0000000000 --- a/src/libAtoms/ParamReader.f95 +++ /dev/null @@ -1,1061 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X ParamReader module -!X -!X James Kermode -!% The ParamReader module provides the facility to read parameters in the -!% form 'key = value' from files or from the command line. In typical -!% usage you would 'Param_Register' a series of parameters with default values, -!% then read some values from a parameter file overriding the defaults, -!% possibly then reading from the command line arguments to override the -!% options set by the parameter file. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module paramreader_module - - use system_module - use extendable_str_module - use dictionary_module - use table_module - - implicit none - private - - public :: param_register, PARAM_MANDATORY, param_read_line, param_read_args, param_print_help, param_print, param_check, param_write_string - - integer, parameter, private :: MAX_N_FIELDS = 1024 !% Maximum number of fields during parsing - - integer, parameter :: PARAM_NO_VALUE = 0 !% Special parameter type that doesn't get parsed - integer, parameter :: PARAM_REAL = 1 !% Real (double precision) parameter - integer, parameter :: PARAM_INTEGER = 2 !% Integer parameter - integer, parameter :: PARAM_STRING = 3 !% String parameter - integer, parameter :: PARAM_LOGICAL = 4 !% Logical parameter - - character(len=*), parameter :: PARAM_MANDATORY = '//MANDATORY//' !% If this is passed to 'Param_Register' - !% instead of a default value then - !% this parameter is not optional. - - type ParamEntry - !% OMIT - - character(len=STRING_LENGTH):: value - integer :: N, param_type - - real(dp), pointer :: real => null() - integer, pointer :: integer => null() - logical, pointer :: logical => null() - character(len=STRING_LENGTH), pointer :: string => null() - - real(dp), dimension(:), pointer :: reals => null() - integer, dimension(:), pointer :: integers => null() - - logical, pointer :: has_value - - character(len=STRING_LENGTH) :: help_string - character(len=STRING_LENGTH) :: altkey - end type ParamEntry - - !% Overloaded interface to register a parameter in a Dictionary object. - !% 'key' is the key name and 'value' the default value. For a mandatory - !% parameter use a value of 'PARAM_MANDATORY'. The last argument to Register - !% should be a pointer to the variable that the value of the parameter should - !% be copied to after parsing by 'param_read_line', 'param_read_file' - !% or 'param_read_args'. For a parameter which shouldn't be parsed, do not specify a target. - interface param_register - module procedure param_register_single_integer - module procedure param_register_multiple_integer - module procedure param_register_single_real - module procedure param_register_multiple_real - module procedure param_register_single_string - module procedure param_register_dontread - module procedure param_register_single_logical - end interface - -#ifdef POINTER_COMPONENT_MANUAL_COPY - interface assignment(=) - module procedure ParamEntry_assign - end interface -#endif - - contains - - ! Overloaded interface for registering parameter of type single logical - subroutine param_register_single_logical(dict, key, value, logical_target, help_string, has_value_target, altkey) - type(Dictionary), intent(inout) :: dict - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - logical, intent(inout), target :: logical_target - character(len=*), intent(in) :: help_string - logical, intent(inout), optional, target :: has_value_target - character(len=*), intent(in), optional :: altkey - call param_register_main(dict, key, value, 1, PARAM_LOGICAL, & - help_string=help_string, logical_target=logical_target, & - has_value_target=has_value_target, altkey=altkey) - if (present(altkey)) then - call param_register_main(dict, altkey, value, 1, PARAM_LOGICAL, & - help_string=help_string, logical_target=logical_target, & - has_value_target=has_value_target, altkey=key) - end if - - - end subroutine param_register_single_logical - - ! Overloaded interface for registering parameter of type single integer - subroutine param_register_single_integer(dict, key, value, int_target, help_string, has_value_target, altkey) - type(Dictionary), intent(inout) :: dict - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - integer, intent(inout), target :: int_target - character(len=*), intent(in) :: help_string - logical, intent(inout), optional, target :: has_value_target - character(len=*), intent(in), optional :: altkey - - call param_register_main(dict, key, value, 1, PARAM_INTEGER, & - help_string=help_string, int_target=int_target, & - has_value_target=has_value_target, altkey=altkey) - if (present(altkey)) then - call param_register_main(dict, altkey, value, 1, PARAM_INTEGER, & - help_string=help_string, int_target=int_target, & - has_value_target=has_value_target, altkey=key) - end if - end subroutine param_register_single_integer - - - ! Overloaded interface for registering parameter of type multiple integer - subroutine param_register_multiple_integer(dict, key, value, int_target_array, help_string, has_value_target, altkey) - type(Dictionary), intent(inout) :: dict - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - integer, dimension(:), intent(inout), target :: int_target_array - character(len=*), intent(in) :: help_string - logical, intent(inout), optional, target :: has_value_target - character(len=*), intent(in), optional :: altkey - - call param_register_main(dict, key, value, size(int_target_array), PARAM_INTEGER,& - help_string=help_string, int_target_array=int_target_array, & - has_value_target=has_value_target, altkey=altkey) - if (present(altkey)) then - call param_register_main(dict, altkey, value, size(int_target_array), PARAM_INTEGER,& - help_string=help_string, int_target_array=int_target_array, & - has_value_target=has_value_target, altkey=key) - end if - - end subroutine param_register_multiple_integer - - - ! Overloaded interface for registering parameter of type single real - subroutine param_register_single_real(dict, key, value, real_target, help_string, has_value_target, altkey) - type(Dictionary), intent(inout) :: dict - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - real(dp), intent(inout), target :: real_target - character(len=*), intent(in) :: help_string - logical, intent(inout), optional, target :: has_value_target - character(len=*), intent(in), optional :: altkey - - call param_register_main(dict, key, value, 1, PARAM_REAL, & - help_string=help_string, real_target=real_target, & - has_value_target=has_value_target, altkey=altkey) - if (present(altkey)) then - call param_register_main(dict, altkey, value, 1, PARAM_REAL, & - help_string=help_string, real_target=real_target, & - has_value_target=has_value_target, altkey=key) - end if - - end subroutine param_register_single_real - - - ! Overloaded interface for registering parameter of type multiple real - subroutine param_register_multiple_real(dict, key, value, real_target_array, help_string, has_value_target, altkey) - type(Dictionary), intent(inout) :: dict - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - real(dp), dimension(:), intent(inout), target :: real_target_array - character(len=*), intent(in) :: help_string - logical, intent(inout), optional, target :: has_value_target - character(len=*), intent(in), optional :: altkey - - call param_register_main(dict, key, value, size(real_target_array), PARAM_REAL, & - help_string=help_string, real_target_array=real_target_array, & - has_value_target=has_value_target, altkey=altkey) - if (present(altkey)) then - call param_register_main(dict, altkey, value, size(real_target_array), PARAM_REAL,& - help_string=help_string, real_target_array=real_target_array, & - has_value_target=has_value_target, altkey=key) - end if - - end subroutine param_register_multiple_real - - - ! Overloaded interface for registering parameter of type single string - subroutine param_register_single_string(dict, key, value, char_target, help_string, has_value_target, altkey) - type(Dictionary), intent(inout) :: dict - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - character(len=*), intent(inout), target :: char_target - character(len=*), intent(in) :: help_string - logical, intent(inout), optional, target :: has_value_target - character(len=*), intent(in), optional :: altkey - - if (len(char_target) /= STRING_LENGTH) & - call system_abort('param_register_single_string called for "'//trim(key)// & - '" has char_target(len='//len(char_target)//'), must be called with char_target(len=STRING_LENGTH)') - - - call param_register_main(dict, key, value, 1, PARAM_STRING, & - help_string=help_string, char_target=char_target, & - has_value_target=has_value_target, altkey=altkey) - if (present(altkey)) then - call param_register_main(dict, altkey, value, 1, PARAM_STRING, & - help_string=help_string, char_target=char_target, & - has_value_target=has_value_target, altkey=key) - end if - end subroutine param_register_single_string - - ! Overloaded interface for registering parameters which do not need parsing - subroutine param_register_dontread(dict, key, altkey) - type(Dictionary), intent(inout) :: dict - character(len=*), intent(in) :: key - character(len=*), intent(in), optional :: altkey - - call param_register_main(dict, key, '', 0, PARAM_NO_VALUE, help_string="NOT PARSED", altkey=altkey) - if (present(altkey)) then - call param_register_main(dict, altkey, '', 0, PARAM_NO_VALUE, help_string="NOT PARSED", altkey=key) - end if - end subroutine param_register_dontread - - - ! Helper routine called by all the registration interfaces - !%OMIT - subroutine param_register_main(dict, key, value, N, param_type, & - help_string, int_target, real_target, char_target, & - logical_target, int_target_array, real_target_array, has_value_target, altkey) - type(Dictionary), intent(inout) :: dict - - character(len=*), intent(in) :: key - character(len=*), intent(in) :: value - integer, intent(in) :: N, param_type - - character(len=*), intent(in) :: help_string - integer, intent(inout), optional, target :: int_target - integer, dimension(:), intent(inout), optional, target :: int_target_array - real(dp), intent(inout), optional, target :: real_target - real(dp), dimension(:), intent(inout), optional, target :: real_target_array - character(len=*), intent(inout), optional, target :: char_target - logical, intent(inout), optional, target :: logical_target - logical, intent(inout), optional, target :: has_value_target - character(len=*), intent(in), optional :: altkey - - type(ParamEntry) :: entry - type(DictData) :: data - - if (len_trim(value) > STRING_LENGTH) & - call system_abort("Param_Register: Value "//trim(value)//" too long") - - entry%value = value - entry%N = N - entry%param_type = param_type - - entry%help_string=trim(help_string) - - if(present(altkey)) then - entry%altkey = trim(altkey) - else - entry%altkey = '' - endif - -! call print("parser register entry " // trim(key) // " value " // trim(value), PRINT_ALWAYS) - - if (present(has_value_target)) then - entry%has_value => has_value_target - else - nullify(entry%has_value) - endif - - ! Check target type and size and set pointer to point to it - select case (param_type) - case(PARAM_NO_VALUE) - ! Do nothing - - case (PARAM_LOGICAL) - if (N == 1) then - if (present(logical_target)) then - entry%logical => logical_target - else - call system_abort('Param_Register: no target for single logical parameter') - endif - else - call system_abort('Param_Register: no support for logical array parameters') - endif - case (PARAM_INTEGER) - if (N == 1) then - if (present(int_target)) then - entry%integer => int_target - else - call system_abort('Param_Register: no target for single integer parameter') - end if - else - if (present(int_target_array)) then - if (size(int_target_array) == N) then - entry%integers => int_target_array - else - call system_abort('Param_Register: integer target array wrong size') - end if - else - call system_abort('Param_Register: no target for integer array parameter') - end if - end if - - case (PARAM_REAL) - if (N == 1) then - if (present(real_target)) then - entry%real => real_target - else - call system_abort('Param_Register: no target for single real parameter') - end if - else - if (present(real_target_array)) then - if (size(real_target_array) == N) then - entry%reals => real_target_array - else - call system_abort('Param_Register: real target array wrong size') - end if - else - call system_abort('Param_Register: no target for real array parameter') - end if - end if - - - case (PARAM_STRING) - if (N == 1) then - if (present(char_target)) then - entry%string => char_target - else - call system_abort('Param_Register: no target for single char parameter') - end if - else - call system_abort('Param_Register: multiple string param type not supported') - end if - - case default - write (line, '(a,i0)') 'Param_Register: unknown parameter type ', & - entry%param_type - call system_abort(line) - - end select - - ! Parse the default value string - if (.not. param_parse_value(entry)) then - call system_abort('Error parsing value '//trim(entry%value)) - end if - - ! Store the entry object in dictionary - allocate(data%d(size(transfer(entry,data%d)))) - data%d = transfer(entry,data%d) - call Set_Value(dict, key, data) - - end subroutine param_register_main - - - !% Read and parse line and update the key/value pairs stored by - !% in a Dictionary object. Returns false if an error is encountered parsing - !% the line. - function param_read_line(dict, myline, ignore_unknown, check_mandatory, task, did_help) result(status) - - type(Dictionary), intent(inout) :: dict !% Dictionary of registered key/value pairs - character(len=*), intent(in) :: myline !% Line to parse - logical, intent(in), optional :: ignore_unknown !% If true, ignore unknown keys in line - logical, intent(in), optional :: check_mandatory !% If true, check for missing mandatory parameters - character(len=*), intent(in), optional :: task - logical, intent(out), optional :: did_help - logical :: status - - character(len=STRING_LENGTH) :: field - integer equal_pos - character(len=STRING_LENGTH), dimension(:), allocatable :: final_fields - character(len=STRING_LENGTH) :: key, value - integer :: i, num_pairs - type(ParamEntry) :: entry - type(DictData) :: data - logical :: my_ignore_unknown - integer :: entry_i - logical, allocatable :: my_has_value(:) - logical :: my_check_mandatory - - my_ignore_unknown=optional_default(.false., ignore_unknown) - my_check_mandatory=optional_default(.true., check_mandatory) - - allocate(final_fields(MAX_N_FIELDS)) - - if(present(did_help)) did_help = .false. - - call split_string(myline," ,","''"//'""'//'{}', final_fields, num_pairs, matching=.true.) - - allocate(data%d(size(transfer(entry,data%d)))) - - allocate(my_has_value(dict%N)) - my_has_value = .false. - - ! zero out has_value pointers for entire dictionary - do i=1, dict%N - entry = transfer(dict%entries(i)%d%d,entry) - if (associated(entry%has_value)) then - entry%has_value = .false. - endif - end do - - if (present(task)) then - call print("parser doing "//trim(task), PRINT_VERBOSE) - else - call print("parser doing UNKNOWN", PRINT_VERBOSE) - endif - call print("parser input line: <"//trim(myline)//">", PRINT_VERBOSE) - ! Set the new entries - do i=1,num_pairs - field = final_fields(i) - equal_pos = index(trim(field),'=') - if (equal_pos == 0) then - key=field - value='' - else if (equal_pos == 1) then - call system_abort("Malformed field '"//trim(field)//"'") - else if (equal_pos == len(trim(field))) then - key = field(1:equal_pos-1) - value = '' - else - key = field(1:equal_pos-1) - value = field(equal_pos+1:len(trim(field))) - endif - call print("param_read_line key='"//trim(key)//"' value='"//trim(value)//"'", PRINT_NERD) - if (len_trim(value) > STRING_LENGTH) then - call print("param_read_line: value "//trim(value)//" too long") - status = .false. - return - end if - - if (trim(key) == "--help") then - if(present(did_help)) did_help = .true. - call param_print_help(dict) - cycle - endif - - ! Extract this value - if (.not. get_value(dict, key, data, i=entry_i)) then - if (.not. my_ignore_unknown) then - call print("param_read_line: unknown key "//trim(key)) - status = .false. - return - endif - else - entry = transfer(data%d,entry) - entry%value = value - my_has_value(entry_i) = .true. - if (associated(entry%has_value)) then - entry%has_value = .true. - endif - call print ("parser got: " // trim(paramentry_write_string(key, entry)), PRINT_VERBOSE) - if (equal_pos == 0) then - status = param_parse_value(entry, key) - else - status = param_parse_value(entry) - endif - if (.not. status) then - call Print('Error parsing value '//trim(entry%value)) - return - end if - - ! Put it back in dict - data%d = transfer(entry,data%d) - call set_value(dict,key,data) - end if - end do - - if (current_verbosity() >= PRINT_VERBOSE) then - do i=1, dict%N - entry = transfer(dict%entries(i)%d%d,entry) - if (.not. my_has_value(i)) then - call print ("parser defaulted: "//trim(paramentry_write_string(string(dict%keys(i)),entry)), PRINT_VERBOSE) - endif - end do - endif - - if (allocated(data%d)) deallocate(data%d) - status = .true. ! signal success to caller - - if (my_check_mandatory) status = param_check(dict) - if(allocated(final_fields)) deallocate(final_fields) - - end function param_read_line - - - !% Read lines from Inoutput object 'file', in format 'key = value' and set - !% entries in the Dictionary 'dict'. Skips lines starting with a '#'. If - !% 'check_mandatory' is true then finish by checking if all mandatory values have - !% been specified. Returns false if there was a problem reading the file, or - !% if the check for mandatory parameters fails. - function param_read_file(dict, file, check_mandatory,task) result(status) - type(Dictionary), intent(inout) :: dict !% Dictionary of registered key/value pairs - type(Inoutput), intent(in) :: file !% File to read from - logical, intent(in), optional :: check_mandatory !% Should we check if all mandatory parameters have been given - character(len=*), intent(in), optional :: task - logical :: status - - integer :: file_status - character(STRING_LENGTH) :: myline - logical :: my_check_mandatory - - my_check_mandatory=optional_default(.true., check_mandatory) - - do - myline = read_line(file, file_status) - if (file_status /= 0) exit ! Check for end of file - ! Discard empty and comment lines, otherwise parse the line - if (len_trim(myline) > 0 .and. myline(1:1) /= '#') then - status = param_read_line(dict, myline, task=task) - if (.not. status) then - call print('Error reading line: '//myline) - return - end if - end if - end do - - status = .true. - ! Should we check if all mandatory params have been specified? - if (my_check_mandatory) status = param_check(dict) - - end function param_read_file - - - !% Read 'key = value' pairs from command line and set entries in this - !% 'dict'. Array 'args' is a list of the indices of command line - !% arguments that we should look at, in order, if it's not given we look - !% at all arguments. Returns false if fails, or if optional check that - !% all mandatory values have been specified fails. - function param_read_args(dict, args, check_mandatory,ignore_unknown,task,command_line, did_help) result(status) - type(Dictionary), intent(inout) :: dict !% Dictionary of registered key/value pairs - integer, dimension(:), intent(in), optional :: args !% Argument indices to use - logical, intent(in), optional :: check_mandatory !% Should we check if all mandatory parameters have been given - logical, intent(in), optional :: ignore_unknown !% If true, ignore unknown keys in line - character(len=*), intent(in), optional :: task - character(len=*), intent(out), optional :: command_line - logical, intent(out), optional :: did_help - logical :: status - - integer :: i, nargs - character(len=STRING_LENGTH) :: this_arg - character(len=STRING_LENGTH) :: my_command_line - integer, dimension(:), allocatable :: xargs - logical :: my_ignore_unknown - integer :: eq_loc, this_len - logical :: my_check_mandatory - - my_ignore_unknown=optional_default(.false., ignore_unknown) - my_check_mandatory=optional_default(.true., check_mandatory) - - nargs = cmd_arg_count() - - ! If args was specified, make a local copy of it - ! Otherwise make a list of all command line arguments - if (present(args)) then - allocate(xargs(size(args))) - xargs = args - else - - allocate(xargs(nargs)) - xargs = (/ (i, i=1,size(xargs)) /) - end if - - ! Concatentate command line options into one string - my_command_line = '' - do i=1, size(xargs) - call get_cmd_arg(xargs(i), this_arg) - if (index(trim(this_arg),' ') /= 0) then - if (index(trim(this_arg),'=') /= 0) then - eq_loc = index(trim(this_arg),'=') - this_len = len_trim(this_arg) - if (scan(this_arg(eq_loc+1:eq_loc+1),"'{"//'"') <= 0) then - my_command_line = trim(my_command_line)//' '//this_arg(1:eq_loc)//'"'//this_arg(eq_loc+1:this_len)//'"' - else - my_command_line = trim(my_command_line)//' '//trim(this_arg) - endif - else - if (scan(this_arg(1:1),"{'"//'"') <= 0) then - my_command_line = trim(my_command_line)//' "'//trim(this_arg)//'"' - else - my_command_line = trim(my_command_line)//' '//trim(this_arg) - endif - endif - else - my_command_line = trim(my_command_line)//' '//trim(this_arg) - endif - end do - - call print("param_read_args got command_line '"//trim(my_command_line)//"'", PRINT_VERBOSE) - ! Free local copy before there's a chance we return - deallocate(xargs) - - ! Then parse this string, and return success or failure - status = param_read_line(dict, my_command_line,ignore_unknown=my_ignore_unknown, task=task, did_help=did_help) - if (.not. status) return - - status = .true. - ! Should we check if all mandatory params have been specified? - if (my_check_mandatory) status = param_check(dict) - - if(present(command_line)) command_line = trim(my_command_line) - - end function param_read_args - - - !% Process command line by looking for arguments in 'key=value' form and - !% parsing their values into 'dict'. Non option arguments - !% are returned in the array non_opt_args. Optionally check that - !% all mandatory parameters have been specified. - function process_arguments(dict, non_opt_args, n_non_opt_args, check_mandatory, task) result(status) - type(Dictionary) :: dict !% Dictionary of registered key/value pairs - character(len=*), dimension(:), intent(out) :: non_opt_args !% On exit, contains non option arguments - integer, intent(out) :: n_non_opt_args !% On exit, number of non option arguments - logical, intent(in), optional :: check_mandatory !% Should we check if all mandatory parameters have been given - character(len=*), intent(in), optional :: task - logical :: status - - character(len=255) :: args(100) - character(len=1000) :: options - type(Table) :: opt_inds - integer :: start, end, i, j, eqpos, n_args - logical :: my_check_mandatory - - n_args = cmd_arg_count() - if (n_args > size(args)) call system_abort('Too many command line arguments') - - my_check_mandatory=optional_default(.true., check_mandatory) - - ! Read command line args into array args - do i=1,n_args - call get_cmd_arg(i, args(i)) - end do - - ! Find the key=value pairs, skipping over non-option arguments - call allocate(opt_inds, 1, 0, 0, 0) - i = 1 - do - eqpos = scan(args(i), '=') - - if (eqpos == 0) then - i = i + 1 - if (i > n_args) exit - cycle ! Skip non option arguments - else if (eqpos == 1) then - ! Starts with '=', so previous argument is key name - if (i == 1) call system_abort('Missing option name in command line arguments') - start = i-1 - else if (eqpos > 1) then - ! Contains '=' but not at start so key name is in this arg - start = i - end if - end = i - - ! If last character of arg is '=' then value must be in next argument - eqpos = len_trim(args(i)) - if (args(i)(eqpos:eqpos) == '=') then - end = end + 1 - end if - - ! Get whole of quoted string - if (scan(args(end), '"''') /= 0) then - do - end = end + 1 - if (end > n_args) & - call system_abort('Mismatched quotes in command line arguments') - if (scan(args(end), '"''') /= 0) exit - end do - end if - - ! Add the indices of the arguments that make up this key/value pair - call append(opt_inds, (/ (j, j=start,end )/)) - - i = end + 1 - if (i > n_args) exit - end do - - ! Concatenate args and parse line - options = '' - do i=1,opt_inds%N - options = trim(options)//' '//trim(args(opt_inds%int(1,i))) - end do - status = param_read_line(dict, options, task=task) - if (.not. status) return - - status = .true. - ! Should we check if all mandatory params have been specified? - if (my_check_mandatory) status = param_check(dict) - - ! Find and return the non-option arguments - n_non_opt_args = 0 - do i=1,n_args - if (Find(opt_inds, i) == 0) then - n_non_opt_args = n_non_opt_args + 1 - if (n_non_opt_args > size(non_opt_args)) call system_abort('Too many non option arguments') - - non_opt_args(n_non_opt_args) = args(i) - end if - end do - - call finalise(opt_inds) - - end function process_arguments - - - !% Print key/value pairs. - subroutine param_print(dict, verbosity, out) - type(Dictionary), intent(in) :: dict !% Dictionary of registered key/value pairs - integer, intent(in), optional :: verbosity - type(Inoutput), intent(inout), optional :: out - - type(ParamEntry) :: entry - integer :: i - - type(DictData) :: data - allocate(data%d(size(transfer(entry,data%d)))) - - do i=1,dict%N - if (.not. get_value(dict, string(dict%keys(i)), data)) & - call system_abort('param_print: Key '//string(dict%keys(i))//' missing') - entry = transfer(data%d,entry) - ! Print value in quotes if it contains any spaces - if (index(trim(entry%value), ' ') /= 0) then - write (line, '(a,a,a,a)') & - string(dict%keys(i)), ' = "', trim(entry%value),'" ' - else - write (line, '(a,a,a,a)') & - string(dict%keys(i)), ' = ', trim(entry%value), ' ' - end if - call print(line,verbosity,out) - end do - - deallocate(data%d) - - end subroutine param_print - - subroutine param_print_help(dict, verbosity, out) - type(Dictionary), intent(in) :: dict !% Dictionary of registered key/value pairs - integer, intent(in), optional :: verbosity - type(Inoutput), intent(inout), optional :: out - - type(ParamEntry) :: entry - integer :: i - - type(DictData) :: data - character(len=10) type_str, param_dim_str - character(len=STRING_LENGTH) out_line - - allocate(data%d(size(transfer(entry,data%d)))) - - do i=1,dict%N - if (.not. get_value(dict, string(dict%keys(i)), data)) & - call system_abort('param_print: Key '//string(dict%keys(i))//' missing') - entry = transfer(data%d,entry) - - out_line=string(dict%keys(i)//" type=") - - param_dim_str = "unknown" - select case(entry%param_type) - case(PARAM_NO_VALUE) - out_line=trim(out_line)//"NO_VALUE" - case(PARAM_REAL) - out_line=trim(out_line)//"REAL" - if (associated(entry%real)) then - out_line=trim(out_line)//" scalar" - elseif (associated(entry%reals)) then - out_line=trim(out_line)//" dim="//size(entry%reals) - else - out_line=trim(out_line)//" ERROR-no-value-pointer-associated" - endif - case(PARAM_INTEGER) - out_line=trim(out_line)//"INTEGER" - if (associated(entry%integer)) then - out_line=trim(out_line)//" scalar" - elseif (associated(entry%integers)) then - out_line=trim(out_line)//" dim="//size(entry%integers) - else - out_line=trim(out_line)//" ERROR-no-value-pointer-associated" - endif - case(PARAM_STRING) - out_line=trim(out_line)//"STRING" - if (associated(entry%string)) then - out_line=trim(out_line)//" scalar" - else - out_line=trim(out_line)//" ERROR-no-value-pointer-associated" - endif - case(PARAM_LOGICAL) - out_line=trim(out_line)//"LOGICAL" - if (associated(entry%logical)) then - out_line=trim(out_line)//" scalar" - else - out_line=trim(out_line)//" ERROR-no-value-pointer-associated" - endif - case default - call system_abort("Unknown param_type "//entry%param_type//" for key " //string(dict%keys(i))) - end select - - ! Print value in quotes if it contains any spaces - if (index(trim(entry%value), ' ') /= 0) then - out_line=trim(out_line)//" current_value='"//trim(entry%value)//"'" - else - out_line=trim(out_line)//" current_value="//trim(entry%value) - end if - call print(trim(out_line), verbosity=PRINT_ALWAYS, file=out) - - call print(linebreak_string(trim(entry%help_string), 80), verbosity=PRINT_ALWAYS, file=out) - - call print("", verbosity=PRINT_ALWAYS, file=out) - end do - - deallocate(data%d) - - end subroutine param_print_help - - function paramentry_write_string(key,entry) result(s) - character(len=*) :: key - type(ParamEntry), intent(in) :: entry - character(len=STRING_LENGTH) :: s - - ! Print value in brackets if it contains any spaces - if (index(trim(entry%value), ' ') /= 0) then - write (s, '(a,a,a,a)') & - trim(key), '={', trim(entry%value),'} ' - else - if (len(trim(entry%value)) == 0 .and. entry%param_type == PARAM_LOGICAL) then - write (s, '(a,a,a,a)') & - trim(key), '=', 'T', ' ' - else - write (s, '(a,a,a,a)') & - trim(key), '=', trim(entry%value), ' ' - endif - end if - end function paramentry_write_string - - !% Return string representation of param dictionary, i.e. - !% 'key1=value1 key2=value2 quotedkey="quoted value"' - function param_write_string(dict) result(s) - type(Dictionary), intent(in) :: dict !% Dictionary of registered key/value pairs - character(STRING_LENGTH) :: s - - type(ParamEntry) :: entry - integer :: i - - type(DictData) :: data - allocate(data%d(size(transfer(entry,data%d)))) - - s="" - do i=1,dict%N - if (.not. get_value(dict, string(dict%keys(i)), data)) & - call system_abort('param_print: Key '//string(dict%keys(i))//' missing') - entry = transfer(data%d,entry) - s = trim(s)//trim(paramentry_write_string(string(dict%keys(i)),entry)) - end do - - deallocate(data%d) - - end function param_write_string - - - ! Parse the value according to its param_type and number of values - ! and set the targets to the values read. Called by Register and ReadLine - !%OMIT - function param_parse_value(entry, key) result(status) - type(ParamEntry) :: entry - character(len=*), optional :: key - logical :: status - - character(len=STRING_LENGTH), dimension(:), allocatable :: fields - integer :: num_fields, j - - allocate(fields(MAX_N_FIELDS)) - - if (entry%param_type == PARAM_NO_VALUE .or. & - trim(entry%value) == PARAM_MANDATORY) then - status = .true. - return - end if - - call parse_string(entry%value, ' ', fields, num_fields) - - ! jrk33 - commented out these lines as they stop zero length string - ! values from setting the associated target to an empty string, and - ! I can't think what good they do! -!!$ if (num_fields == 0 .and. entry%param_type /= PARAM_LOGICAL) then -!!$ status = .true. -!!$ return -!!$ end if - - if ((entry%param_type == PARAM_LOGICAL .and. num_fields /= 0 .and. num_fields /= entry%N) .or. & - (entry%param_type /= PARAM_STRING .and. entry%param_type /= PARAM_LOGICAL .and. num_fields /= entry%N) ) then - write (line, '(a,a,a)') 'Param_ParseValue: Number of value fields wrong: ', & - trim(entry%value) - call print(line) - status = .false. - return - end if - - select case(entry%param_type) - case (PARAM_LOGICAL) - if (entry%N == 1) then - if (num_fields == 0) then - entry%logical = .true. - else - entry%logical = String_to_Logical(fields(1)) - endif - else - call system_abort("param_parse_value no support for logical array yet") - end if - - case (PARAM_INTEGER) - if (entry%N == 1) then - entry%integer = String_to_Int(fields(1)) - else - do j=1,num_fields - entry%integers(j) = String_to_Int(fields(j)) - end do - end if - - case (PARAM_REAL) - if (entry%N == 1) then - entry%real = String_to_Real(fields(1)) - else - do j=1,num_fields - entry%reals(j) = String_to_Real(fields(j)) - end do - end if - - case (PARAM_STRING) - if (num_fields == 0 .and. present(key)) then - entry%string = trim(key) - else - entry%string = trim(entry%value) - endif - - case default - write (line, '(a,i0)') 'Param_ParseValue: unknown parameter type ', & - entry%param_type - call print(line) - status = .false. - return - end select - - if(allocated(fields)) deallocate(fields) - status = .true. - - end function param_parse_value - - - !% Explicity check if all mandatory values have now been specified - !% Returns true or false accordingly. Optionally return the list - !% of missing keys as a string. - function param_check(dict, missing_keys) result(status) - type(Dictionary), intent(in) :: dict !% Dictionary of registered key/value pairs - character(len=*), intent(out), optional :: missing_keys !% On exit, string list of missing mandatory keys, - !% separated by spaces. - logical :: status - integer :: i - type(ParamEntry) :: entry, altentry - type(DictData) :: data, altdata - logical :: valuemissing, altpresent, altvaluemissing - allocate(data%d(size(transfer(entry,data%d)))) - - if (present(missing_keys)) missing_keys = '' - - status = .true. - do i=1,dict%N - if (.not. get_value(dict, string(dict%keys(i)), data)) & - call system_abort('Param_Check: Key '//string(dict%keys(i))//' missing') - entry = transfer(data%d,entry) - - if (trim(entry%value) == PARAM_MANDATORY) then - valuemissing = .true. - else - valuemissing = .false. - endif - - ! see if we have an altkey for this key - if (entry%altkey /= '') then - altpresent = .true. - if (.not. get_value(dict, entry%altkey, altdata)) & - call system_abort('Param_Check: Key '//entry%altkey//' missing') - - altentry = transfer(altdata%d, altentry) - - if (trim(altentry%value) == PARAM_MANDATORY) then - altvaluemissing = .true. - else - altvaluemissing = .false. - endif - else - altpresent = .false. - altvaluemissing = .false. - endif - - ! now check for missing values, taking into account check of altentry - if (valuemissing .and. (.not. altpresent .or. (altpresent .and. altvaluemissing ))) then - status = .false. - if (present(missing_keys)) then - missing_keys = trim(missing_keys)//' '//string(dict%keys(i)) - else - call print('missing mandatory parameter '//string(dict%keys(i))) - endif - end if - end do - - deallocate(data%d) - - end function param_check - -#ifdef POINTER_COMPONENT_MANUAL_COPY - subroutine ParamEntry_assign(to, from) - type(ParamEntry) :: to, from - - to%value = from%value - to%N = from%N - to%param_type = from%param_type - to%real => from%real - to%integer => from%integer - to%logical => from%logical - to%string => from%string - to%reals => from%reals - to%integers => from%integers - - to%has_value => from%has_value - end subroutine ParamEntry_assign -#endif - -end module paramreader_module diff --git a/src/libAtoms/PeriodicTable.f95 b/src/libAtoms/PeriodicTable.f95 deleted file mode 100644 index cc8dec6333..0000000000 --- a/src/libAtoms/PeriodicTable.f95 +++ /dev/null @@ -1,204 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Periodic Table module -!X -!% This module contains a list of elements, their masses and covalent radii. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module periodictable_module - -use system_module ! for definition of real(dp) -use units_module -! -! The Periodic Table -! - -implicit none -private - -public :: ElementName, ElementMass, ElementValence, ElementCovRad, atomic_number, atomic_number_from_symbol, atomic_number_from_mass, & - total_elements - -integer, parameter :: total_elements = 118 - -! IUPAC 2017 element symbols -character(3),parameter,dimension(0:total_elements) :: ElementName = (/"xx ", & - "H ","He ", & - "Li ","Be ","B ","C ","N ","O ","F ","Ne ", & - "Na ","Mg ","Al ","Si ","P ","S ","Cl ","Ar ", & - "K ","Ca ","Sc ","Ti ","V ","Cr ","Mn ","Fe ","Co ","Ni ","Cu ","Zn ","Ga ","Ge ","As ","Se ","Br ","Kr ", & - "Rb ","Sr ","Y ","Zr ","Nb ","Mo ","Tc ","Ru ","Rh ","Pd ","Ag ","Cd ","In ","Sn ","Sb ","Te ","I ","Xe ", & - "Cs ","Ba ","La ","Ce ","Pr ","Nd ","Pm ","Sm ","Eu ","Gd ","Tb ","Dy ","Ho ","Er ","Tm ","Yb ","Lu ","Hf ", & - "Ta ","W ","Re ","Os ","Ir ","Pt ","Au ","Hg ","Tl ","Pb ","Bi ","Po ","At ","Rn ", & - "Fr ","Ra ","Ac ","Th ","Pa ","U ","Np ","Pu ","Am ","Cm ","Bk ","Cf ","Es ","Fm ","Md ","No ","Lr ","Rf ", & - "Db ","Sg ","Bh ","Hs ","Mt ","Ds ","Rg ","Cn ","Nh ","Fl ","Mc ","Lv ","Ts ","Og " & - /) !% Mapping of atomic number to element name - - -! Units: grams per Mole * MASSCONVERT (conforming to eV,A,fs system) -#ifdef LEGACY_MASSES -! Masses for pre-2017 code. Many of these have been updated, but some code may depend on these -! values. If used, tests will fail. -real(dp),parameter,dimension(total_elements) :: ElementMass = & -(/1.00794, 4.00260, 6.941, 9.012187, 10.811, 12.0107, 14.00674, 15.9994, 18.99840, 20.1797, 22.98977, & -24.3050, 26.98154, 28.0855, 30.97376, 32.066, 35.4527, 39.948, 39.0983, 40.078, 44.95591, 47.867, & -50.9415, 51.9961, 54.93805, 55.845, 58.93320, 58.6934, 63.546, 65.39, 69.723, 72.61, 74.92160, 78.96, & -79.904, 83.80, 85.4678, 87.62, 88.90585, 91.224, 92.90638, 95.94, 98.0, 101.07, 102.90550, 106.42, & -107.8682, 112.411, 114.818, 118.710, 121.760, 127.60, 126.90447, 131.29, 132.90545, 137.327, 138.9055, & -140.116, 140.90765, 144.24, 145.0, 150.36, 151.964, 157.25, 158.92534, 162.50, 164.93032, 167.26, & -168.93421, 173.04, 174.967, 178.49, 180.9479, 183.84, 186.207, 190.23, 192.217, 195.078, 196.96655, & -200.59, 204.3833, 207.2, 208.98038, 209.0, 210.0, 222.0, 223.0, 226.0, 227.0, 232.0381, 231.03588, & -238.0289, 237.0, 244.0, 243.0, 247.0, 247.0, 251.0, 252.0, 257.0, 258.0, 259.0, 262.0, 261.0, 262.0, & -263.0, 264.0, 265.0, 268.0, 271.0, 272.0, 285.0, 284.0, 289.0, 288.0, 292.0, 293.0, 294.0/)*MASSCONVERT -#else -! IUPAC2016 masses from: -! Meija, J., Coplen, T., Berglund, M., et al. (2016). Atomic weights of -! the elements 2013 (IUPAC Technical Report). Pure and Applied Chemistry, -! 88(3), pp. 265-291. Retrieved 30 Nov. 2016, -! from doi:10.1515/pac-2015-0305 -! Consistent with ase 3.14 onwards -real(dp),parameter,dimension(total_elements) :: ElementMass = (/ & -1.008_dp,4.002602_dp,6.94_dp,9.0121831_dp,10.81_dp,12.011_dp,14.007_dp,15.999_dp,18.998403163_dp, & -20.1797_dp,22.98976928_dp,24.305_dp,26.9815385_dp,28.085_dp,30.973761998_dp,32.06_dp,35.45_dp, & -39.948_dp,39.0983_dp,40.078_dp,44.955908_dp,47.867_dp,50.9415_dp,51.9961_dp,54.938044_dp,55.845_dp, & -58.933194_dp,58.6934_dp,63.546_dp,65.38_dp,69.723_dp,72.63_dp,74.921595_dp,78.971_dp,79.904_dp, & -83.798_dp,85.4678_dp,87.62_dp,88.90584_dp,91.224_dp,92.90637_dp,95.95_dp,97.90721_dp,101.07_dp, & -102.9055_dp,106.42_dp,107.8682_dp,112.414_dp,114.818_dp,118.71_dp,121.76_dp,127.6_dp,126.90447_dp, & -131.293_dp,132.90545196_dp,137.327_dp,138.90547_dp,140.116_dp,140.90766_dp,144.242_dp,144.91276_dp, & -150.36_dp,151.964_dp,157.25_dp,158.92535_dp,162.5_dp,164.93033_dp,167.259_dp,168.93422_dp,173.054_dp, & -174.9668_dp,178.49_dp,180.94788_dp,183.84_dp,186.207_dp,190.23_dp,192.217_dp,195.084_dp,196.966569_dp,& -200.592_dp,204.38_dp,207.2_dp,208.9804_dp,208.98243_dp,209.98715_dp,222.01758_dp,223.01974_dp, & -226.02541_dp,227.02775_dp,232.0377_dp,231.03588_dp,238.02891_dp,237.04817_dp,244.06421_dp, & -243.06138_dp,247.07035_dp,247.07031_dp,251.07959_dp,252.083_dp,257.09511_dp,258.09843_dp,259.101_dp, & -262.11_dp,267.122_dp,268.126_dp,271.134_dp,270.133_dp,269.1338_dp,278.156_dp,281.165_dp,281.166_dp, & -285.177_dp,286.182_dp,289.19_dp,289.194_dp,293.204_dp,293.208_dp,294.214_dp /)*MASSCONVERT -!% Element mass in grams per Mole $\times$ 'MASSCONVERT' (conforming to eV,\AA,fs unit system). -#endif - -! Units: Angstroms - -real(dp),parameter,dimension(total_elements) :: ElementCovRad = & -(/0.320,0.310,1.630,0.900,0.820,0.770,0.750,0.730,0.720,0.710,1.540,1.360,1.180,1.110,1.060,1.020, & -0.990,0.980,2.030,1.740,1.440,1.320,1.220,1.180,1.170,1.170,1.160,1.150,1.170,1.250,1.260,1.220,1.200, & -1.160,1.140,1.120,2.160,1.910,1.620,1.450,1.340,1.300,1.270,1.250,1.250,1.280,1.340,1.480,1.440,1.410, & -1.400,1.360,1.330,1.310,2.350,1.980,1.690,1.650,1.650,1.840,1.630,1.620,1.850,1.610,1.590,1.590,1.580, & -1.570,1.560,2.000,1.560,1.440,1.340,1.300,1.280,1.260,1.270,1.300,1.340,1.490,1.480,1.470,1.460,1.460, & -2.000,2.000,2.000,2.000,2.000,1.650,2.000,1.420,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000, & -2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000/) -!% Covalent radii in \AA. - -integer,parameter,dimension(total_elements) :: ElementValence = & -(/1,-1, 1, 2, 3, 4, 3, 2, 1,-1, 1, 2, 3, 4, 3, 2, & - 1,-1, 1, 2,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & - -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & - -1,-1,-1,-1,-1,-1/) - - -interface atomic_number - !% Do a reverse lookup of atomic number from either symbol or mass - module procedure atomic_number_from_symbol, atomic_number_from_mass -end interface atomic_number - -contains - - !Look up the atomic number for a given atomic symbol - elemental function atomic_number_from_symbol(atomic_symbol) - character(*), intent(in) :: atomic_symbol - integer :: atomic_number_from_symbol - integer :: i - - if (verify(trim(adjustl(atomic_symbol)),"0123456789") == 0) then ! an integer - read (atomic_symbol, *) atomic_number_from_symbol - if (atomic_number_from_symbol < 1 .or. atomic_number_from_symbol > size(ElementName)) then - atomic_number_from_symbol = 0 - endif - return - else ! not an integer, hopefully an element abbreviation - do i = 1, total_elements - if (trim(lower_case(adjustl(atomic_symbol)))==trim(lower_case(ElementName(i)))) then - atomic_number_from_symbol = i - return - end if - end do - end if - - !If unsuccessful, return 0 - atomic_number_from_symbol = 0 - - end function atomic_number_from_symbol - - !Look up the atomic number for a given atomic mass (IN GRAMS PER MOLE) - !Note: this may fail for some of the transuranic elements... - !so put those ununpentium simulations on hold for a while ;-) - function atomic_number_from_mass(atomic_mass) - real(dp), intent(in) :: atomic_mass - integer :: atomic_number_from_mass - integer :: i - real(dp), parameter :: TOL = 0.01_dp - - do i = 1, total_elements - if (abs(atomic_mass - ElementMass(i)/MASSCONVERT) < TOL) then - atomic_number_from_mass = i - return - end if - end do - - !If unsuccessful, return 0 - atomic_number_from_mass = 0 - - end function atomic_number_from_mass - - !ElementName formatting, used by atoms_read_xyz - !First leter uppercase, others lowercase - function ElementFormat(lower_UPPER) result(UPPER_lower) - character(*), intent(in) :: lower_UPPER - character(len=len_trim(lower_UPPER)) :: UPPER_lower - character(len=*), parameter :: lc = 'abcdefghijklmnopqrstuvwxyz', & - UC = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - integer :: i,j - - UPPER_lower = lower_UPPER - j = index(lc,lower_UPPER(1:1)) - if (j>0) UPPER_lower(1:1) = UC(j:j) - do i = 2, len_trim(lower_UPPER) - j = index(UC,lower_UPPER(i:i)) - if (j>0) UPPER_lower(i:i) = lc(j:j) - enddo - - end function ElementFormat - -end module periodictable_module diff --git a/src/libAtoms/Quaternions.f95 b/src/libAtoms/Quaternions.f95 deleted file mode 100644 index 9d5bf808ab..0000000000 --- a/src/libAtoms/Quaternions.f95 +++ /dev/null @@ -1,782 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!% Implementation of quaternion algebra. Primarily for use with -!% rigid body dynamics, although the 'Orientation', 'Rotation' -!% and 'Rotate' routines can be useful in many other situations. -!% -!% \begin{displaymath} -!% \begin{array}{c} -!% i^2 = j^2 = k^2 = ijk = -1 \\ ij = k \quad jk = i \quad ki = j -!% \end{array} -!% \end{displaymath} - -module quaternions_module - - use system_module ! for dp - use units_module ! for PI - use linearalgebra_module ! for .feq./.fne - - implicit none - private - - public :: quaternion, initialise, finalise, print - public :: rotate, rotation, rotation_matrix, orientation, assignment(=) - public :: rotation_parameters - public :: operator(.dot.), operator(*), operator(+), operator(.conj.) - - type Quaternion - - real(dp) :: a = 0.0_dp ! - real(dp) :: b = 0.0_dp ! - real(dp) :: c = 0.0_dp ! = a*1 + b*i + c*j + d*k - real(dp) :: d = 0.0_dp ! - - end type Quaternion - - private :: quaternion_initialise - interface initialise - module procedure quaternion_initialise - end interface initialise - - private :: quaternion_finalise - interface finalise - module procedure quaternion_finalise - end interface finalise - - private :: quaternion_norm - interface norm - module procedure quaternion_norm - end interface norm - - private :: quaternion_normsq - interface normsq - module procedure quaternion_normsq - end interface normsq - - private :: quat_plus_quat, quat_plus_vect - interface operator(+) - module procedure quat_plus_quat, quat_plus_vect - end interface - - private :: quat_minus_quat, quat_minus_vect - interface operator(-) - module procedure quat_minus_quat, quat_minus_vect - end interface - - private :: quat_mult_real, quat_mult_quat, real_mult_quat - interface operator(*) - module procedure quat_mult_real, quat_mult_quat, real_mult_quat - end interface - - private :: quat_divide_real, quat_divide_quat - interface operator(/) - module procedure quat_divide_real, quat_divide_quat - end interface - - private :: quat_assign_vect, vect_assign_quat, quat_assign_real - interface assignment(=) - module procedure quat_assign_vect, vect_assign_quat, quat_assign_real - end interface - - private :: quaternion_conjugate - interface operator(.conj.) - module procedure quaternion_conjugate - end interface - - private :: quat_eq_quat, quat_eq_vect - interface operator(.feq.) - module procedure quat_eq_quat, quat_eq_vect - end interface - - private :: quat_ne_quat, quat_ne_vect - interface operator(.fne.) - module procedure quat_ne_quat, quat_ne_vect - end interface - - private :: quat_dot_quat - interface operator(.dot.) - module procedure quat_dot_quat - end interface - - private :: rotate_vect, rotate_quat - interface rotate - module procedure rotate_vect, rotate_quat - end interface rotate - - private :: quaternion_print - interface print - module procedure quaternion_print - end interface print - -contains - - subroutine quaternion_initialise(this, a, b, c, d) - type(Quaternion), intent(out) :: this - real(dp), intent(in), optional :: a, b, c, d - - this%a = optional_default(0.0_dp, a) - this%b = optional_default(0.0_dp, b) - this%c = optional_default(0.0_dp, c) - this%d = optional_default(0.0_dp, d) - - end subroutine quaternion_initialise - - subroutine quaternion_finalise(this) - type(Quaternion), intent(inout) :: this - - this%a = 0.0_dp - this%b = 0.0_dp - this%c = 0.0_dp - this%d = 0.0_dp - - end subroutine quaternion_finalise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X Assignment - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine quat_assign_vect(this,vect) - - type(Quaternion), intent(out) :: this - real(dp), dimension(:), intent(in) :: vect - - select case(size(vect)) - - case(3) - this%a = 0.0_dp - this%b = vect(1) - this%c = vect(2) - this%d = vect(3) - - case(4) - this%a = vect(1) - this%b = vect(2) - this%c = vect(3) - this%d = vect(4) - - case default - call system_abort('Quat_Assign_Vect: Vector must have 3 or 4 components') - - end select - - end subroutine quat_assign_vect - - subroutine vect_assign_quat(vect,q) - - real(dp), dimension(:), intent(out) :: vect - type(Quaternion), intent(in) :: q - - select case(size(vect)) - - case(3) - vect = (/q%b,q%c,q%d/) - - case(4) - vect = (/q%a,q%b,q%c,q%d/) - - case default - call system_abort('Vect_Assign_Quat: Vector must have 3 or 4 components') - - end select - - end subroutine vect_assign_quat - - subroutine quat_assign_real(q,r) - - type(Quaternion), intent(out) :: q - real(dp), intent(in) :: r - - q%a = r - q%b = 0.0_dp - q%c = 0.0_dp - q%d = 0.0_dp - - end subroutine quat_assign_real - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X Simple arithmetic - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function quat_plus_quat(q1,q2) result(res) - - type(Quaternion), intent(in) :: q1,q2 - type(Quaternion) :: res - - res%a = q1%a + q2%a - res%b = q1%b + q2%b - res%c = q1%c + q2%c - res%d = q1%d + q2%d - - end function quat_plus_quat - - function quat_plus_vect(q,v) result(res) - - type(Quaternion), intent(in) :: q - real(dp), dimension(4), intent(in) :: v - type(Quaternion) :: res - - res%a = q%a + v(1) - res%b = q%b + v(2) - res%c = q%c + v(3) - res%d = q%d + v(4) - - end function quat_plus_vect - - function quat_minus_quat(q1,q2) result(res) - - type(Quaternion), intent(in) :: q1,q2 - type(Quaternion) :: res - - res%a = q1%a - q2%a - res%b = q1%b - q2%b - res%c = q1%c - q2%c - res%d = q1%d - q2%d - - end function quat_minus_quat - - function quat_minus_vect(q,v) result(res) - - type(Quaternion), intent(in) :: q - real(dp), dimension(4), intent(in) :: v - type(Quaternion) :: res - - res%a = q%a - v(1) - res%b = q%b - v(2) - res%c = q%c - v(3) - res%d = q%d - v(4) - - end function quat_minus_vect - - function quat_mult_quat(q1,q2) result(res) - - type(Quaternion), intent(in) :: q1,q2 - type(Quaternion) :: res - - res%a = q1%a * q2%a - q1%b * q2%b - q1%c * q2%c - q1%d * q2%d - res%b = q1%a * q2%b + q1%b * q2%a + q1%c * q2%d - q1%d * q2%c - res%c = q1%a * q2%c - q1%b * q2%d + q1%c * q2%a + q1%d * q2%b - res%d = q1%a * q2%d + q1%b * q2%c - q1%c * q2%b + q1%d * q2%a - - end function quat_mult_quat - - function quat_mult_real(q,r) result(res) - - type(Quaternion), intent(in) :: q - real(dp), intent(in) :: r - type(Quaternion) :: res - - res%a = q%a * r - res%b = q%b * r - res%c = q%c * r - res%d = q%d * r - - end function quat_mult_real - - function real_mult_quat(r,q) result(res) - - type(Quaternion), intent(in) :: q - real(dp), intent(in) :: r - type(Quaternion) :: res - - res%a = q%a * r - res%b = q%b * r - res%c = q%c * r - res%d = q%d * r - - end function real_mult_quat - - function quat_divide_real(q,r) result(res) - - type(Quaternion), intent(in) :: q - real(dp), intent(in) :: r - type(Quaternion) :: res - - res%a = q%a / r - res%b = q%b / r - res%c = q%c / r - res%d = q%d / r - - end function quat_divide_real - - function quat_divide_quat(q1,q2) result(res) - - type(Quaternion), intent(in) :: q1,q2 - type(Quaternion) :: res, q2c - real(dp) :: q2n - - q2c = .conj. q2 - q2n = normsq(q2) - - res = (q1 * q2c) / q2n - - end function quat_divide_quat - - !Dot product as if they were 4 component vectors - function quat_dot_quat(q1,q2) result(res) - - type(Quaternion), intent(in) :: q1,q2 - real(dp) :: res - - res = q1%a * q2%a + q1%b * q2%b + q1%c * q2%c + q1%d * q2%d - - end function quat_dot_quat - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X Comparison - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function quat_eq_quat(q1,q2) result(res) - - type(Quaternion), intent(in) :: q1,q2 - logical :: res - - res = .false. - - if (q1%a .fne. q2%a) return - if (q1%b .fne. q2%b) return - if (q1%c .fne. q2%c) return - if (q1%d .fne. q2%d) return - - res = .true. - - end function quat_eq_quat - - function quat_ne_quat(q1,q2) result(res) - - type(Quaternion), intent(in) :: q1,q2 - logical :: res - - res = .not. (q1 .feq. q2) - - end function quat_ne_quat - - function quat_eq_vect(q,v) result(res) - - type(Quaternion), intent(in) :: q - real(dp), dimension(:), intent(in) :: v - logical :: res - type(Quaternion) :: qv - - qv = v - - res = .false. - - if (q%a .fne. qv%a) return - if (q%b .fne. qv%b) return - if (q%c .fne. qv%c) return - if (q%d .fne. qv%d) return - - res = .true. - - end function quat_eq_vect - - function quat_ne_vect(q,v) result(res) - - type(Quaternion), intent(in) :: q - real(dp), dimension(:), intent(in) :: v - logical :: res - - res = .not. (q .feq. v) - - end function quat_ne_vect - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X Norms - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function quaternion_normsq(this) result(normsq) - - type(Quaternion), intent(in) :: this - real(dp) :: normsq - - normsq = this%a*this%a & - + this%b*this%b & - + this%c*this%c & - + this%d*this%d - - end function quaternion_normsq - - function quaternion_norm(this) result(norm) - - type(Quaternion), intent(in) :: this - real(dp) :: norm - - norm = sqrt(quaternion_normsq(this)) - - end function quaternion_norm - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X Quaternion conjugate - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function quaternion_conjugate(this) result(res) - - type(Quaternion), intent(in) :: this - type(Quaternion) :: res - - res%a = this%a - res%b = -this%b - res%c = -this%c - res%d = -this%d - - end function quaternion_conjugate - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X Printing - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine quaternion_print(this,file) - - type(Quaternion), intent(in) :: this - type(Inoutput), optional, intent(in) :: file - !local variables - character :: s2,s3,s4 - - s2 = '+'; s3 = '+'; s4 = '+' - if (this%b < 0.0_dp) s2 = '-' - if (this%c < 0.0_dp) s3 = '-' - if (this%d < 0.0_dp) s4 = '-' - - write(line,'(4(f0.5,a))') this%a,' '//s2//' ', & - abs(this%b),'i '//s3//' ', & - abs(this%c),'j '//s4//' ', & - abs(this%d),'k' - call Print(line,file=file) - - end subroutine quaternion_print - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X Rotation routines - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Many rotations can be collapsed into one, e.g. - !% to rotate using $q_1$ then $q_2$ : - !% rotate using $q_3 = q_2 \times q_1$ - !% - !% - !% Construct a rotation quaternion from axis and angle (in a righthanded sense) - ! - function rotation(axis,angle) result(res) - - real(dp), dimension(3), intent(in) :: axis - real(dp), intent(in) :: angle ! in radians - type(Quaternion) :: res - !local variables - real(dp) :: n - - n = norm(axis) - - res = (/ cos(angle/2.0_dp), sin(angle/2.0_dp)*axis/n /) - - end function rotation - - ! - !% Rotate a vector using the given quaternion - ! - subroutine rotate_vect(v,qr) - - real(dp), dimension(3), intent(inout) :: v - type(Quaternion), intent(in) :: qr - !local variables - type(Quaternion) :: qv - - qv = v - call rotate_quat(qv,qr) - v = qv - - end subroutine rotate_vect - - ! - !% Rotate a vector represented as a quaternion ('qv'), using a given rotation quaternion ('qr') - !% This assumes that the rotation quaternion is properly normalised - !% - !% 'qv = qr * qv * (.conj.qr)' - subroutine rotate_quat(qv,qr) - - type(Quaternion), intent(inout) :: qv - type(Quaternion), intent(in) :: qr - - qv = qr * qv * (.conj. qr) - - end subroutine rotate_quat - - ! - !% Given two vectors ('a1' and 'b1'), calculate the rotation quaternion - !% that must be used to rotate them into two other vectors ('a2' and 'b2'). - !% The angle between 'a1' and 'b1' must be the same as 'a2' and 'b2', - !% unless 'correct_angle' is present and true - ! - function orientation(a1, b1, a2, b2, correct_angle) - - real(dp), dimension(3), intent(in) :: a1,b1,a2,b2 - logical, optional, intent(in) :: correct_angle - type(Quaternion) :: Orientation - !local variables - type(Quaternion) :: r1, r2 !The two parts of the orientation - real(dp), dimension(3) :: n, p, q, a1_hat, b1_hat, a2_hat, b2_hat, b3_hat, zero3 - real(dp) :: theta - logical :: do_correct_angle - - do_correct_angle = .false. - if (present(correct_angle)) do_correct_angle = correct_angle - zero3 = (/0.0_dp,0.0_dp,0.0_dp/) - - !Normalise the vectors - a1_hat = a1 / norm(a1) - b1_hat = b1 / norm(b1) - a2_hat = a2 / norm(a2) - b2_hat = b2 / norm(b2) - - !Check the angles a1-b1 and a2-b2 match - if (.not. do_correct_angle .and. ((a1_hat .dot. b1_hat) .fne. (a2_hat .dot. b2_hat))) then - call system_abort('Orientation: Angle a1--b1 is not equal to angle a2--b2') - end if - - !Correct the a1--b1 angle to be the same as the a2--b2 angle by moving b1 - if (do_correct_angle) then - n = b1_hat - (a1_hat .dot. b1_hat)*a1_hat !Perpendicular to a1 in a1--b1 plane - n = n / norm(n) - theta = angle(a2_hat, b2_hat) - b1_hat = a1_hat * cos(theta) + n * sin(theta) - end if - - !Now construct the rotation quaternion needed to take a1 to a2 around an axis perpendicular to both - n = a1_hat .cross. a2_hat - - !Special case: The vectors could be almost (anti)parallel, in which case it we can choose any vector - !perpendicular to them as the first rotation axis - if (n .feq. zero3) then - do while(n .feq. zero3) !This is for the TINY possiblility that the random vector we choose - !is STILL (anti)parallel to a1 - !Create a random unit vector - p = random_unit_vector() - n = a1_hat .cross. p - end do - end if - - n = n / norm(n) - - theta = angle(a1_hat,a2_hat) - r1 = Rotation(n,theta) - - !Acting on b1 with r1 will take it to a new position, b3 - b3_hat = b1_hat - call Rotate(b3_hat,r1) - - !Now figure out the angle which we need to rotate around a2 (or -a2) to take b3 to b2 - ! -> Construct vectors perpendicular to a2, in the a2-b3 and a2-b2 planes, then find angle between them - p = b3_hat - (a2_hat .dot. b3_hat)*a2_hat - p = p / norm(p) - q = b2_hat - (a2_hat .dot. b2_hat)*a2_hat - q = q / norm(q) - n = p .cross. q ! This will be either in the a2 or the -a2 direction - - !Another Special case: Miraculously, p and q could be (anti) parallel, in which case we can just - !use a2_hat, then is doesn't matter if we rotate by 0 (or PI) clockwise or anticlockwise - if (n .feq. zero3) n = a2_hat - - n = n / norm(n) - theta = angle(p,q) - r2 = rotation(n,theta) - - !Combine the two rotations into one using quaternion multiplication - orientation = r2 * r1 - - end function orientation - - ! - !% Returns the angle and rotation axis of a (normalised) quaternion - ! - subroutine rotation_parameters(q,theta,axis) - - type(Quaternion), intent(in) :: q - real(dp), intent(out) :: theta - real(dp), dimension(3), intent(out) :: axis - - theta = 2.0_dp * acos(q%a) - - axis = (/q%b,q%c,q%d/) / (sqrt(1 - q%a*q%a)) - - end subroutine rotation_parameters - - ! - !% Return the equivalent rotation matrix of a (unit) quaternion - ! - function rotation_matrix(q_in) result(A) - - type(Quaternion), intent(in) :: q_in - real(dp), dimension(3,3) :: A - type(Quaternion) :: q - - !Normalise q_in - q = q_in / norm(q_in) - - !Now build A - A(1,1) = q%a*q%a+q%b*q%b-q%c*q%c-q%d*q%d; A(1,2) = 2.0_dp*(q%b*q%c-q%a*q%d); A(1,3) = 2.0_dp*(q%b*q%d+q%a*q%c) - A(2,1) = 2.0_dp*(q%b*q%c+q%a*q%d); A(2,2) = q%a*q%a-q%b*q%b+q%c*q%c-q%d*q%d; A(2,3) = 2.0_dp*(q%c*q%d-q%a*q%b) - A(3,1) = 2.0_dp*(q%b*q%d-q%a*q%c); A(3,2) = 2.0_dp*(q%c*q%d+q%a*q%b); A(3,3) = q%a*q%a-q%b*q%b-q%c*q%c+q%d*q%d - - end function rotation_matrix - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X Testing - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !%OMIT - subroutine quaternion_test - - type(Quaternion) :: q1, q2, q3 - real(dp) :: v3(3), v4(4), a(3), b(3), c(3), d(3), M(3,3) - - !Assignment - call Print('Testing assignment...') - call Print('q1 <- 4vector:') - q1 = (/1.0_dp,1.0_dp,1.0_dp,1.0_dp/) - call Print(q1) - call Print('q2 <- 3vector:') - q2 = (/2.0_dp,2.0_dp,2.0_dp/) - call Print(q2) - call Print('q1 -> 3vector:') - v3 = q1 - call Print(v3) - call Print('q2 -> 4vector:') - v4 = q2 - call Print(v4) - call Print('') - - !Algebra - call Print('Testing alegbra...') - call Print('q1 + q2:') - q3 = q1 + q2 - call Print(q3) - call Print('q1 - q2:') - q3 = q1 - q2 - call Print(q3) - call Print('q1 * q2:') - q3 = q1 * q2 - call Print(q3) - call Print('q1 / q2:') - q3 = q1 / q2 - call Print(q3) - call Print('') - - !Norms - call Print('Testing norms...') - call Print('normsq(q1):') - call Print(normsq(q1)) - call Print('normsq(q2):') - call Print(normsq(q2)) - call Print('norm(q1):') - call Print(norm(q1)) - call Print('norm(q2):') - call Print(norm(q2)) - call Print('') - - !Conjugate - call Print('Testing conjugates...') - call Print('q1*:') - call Print(.conj.q1) - call Print('q2*:') - call Print(.conj.q2) - call Print('') - - !Rotation - call Print('Testing Rotations...') - call Print('Setting q1 to x axis...') - q1 = (/1.0_dp,0.0_dp,0.0_dp/) - call Print('q1:') - call Print(q1) - call Print('Setting up q2 for rotation about z axis by 90deg...') - q2 = Rotation(unit_vector(0.0_dp,0.0_dp),PI/2.0_dp) - call Print('q2:') - call Print(q2) - call Print('Rotating...') - call Rotate(q1,q2) - q3 = q1 - call Print(q3) - v3 = q3 - call Print('Rotated vector:') - call Print(v3) - call Print('') - call Print('Rotating this by a further 90deg around z axis') - call Rotate(v3,q2) - call Print('Rotated vector:') - call Print(v3) - call Print('') - call Print('Creating random rotation quaternion...') - q1 = Rotation(random_unit_vector(),ran_uniform()*PI) - call Print(q1) - call Print('Calculating equivalent rotation matrix...') - M = Rotation_matrix(q1) - call Print(M) - call Print('Creating random vector...') - v3 = random_unit_vector() - call Print(v3) - call Print('Rotating with quaternion...') - a = v3 - call Rotate(a,q1) - call Print(a) - call Print('Rotating with matrix...') - b = M .mult. v3 - call Print(b) - call Print('') - - !Orientation - !NOTE: remember that q and -q represent the same rotation! - call Print('Testing orientation...') - call Print('Creating two random unit vectors...') - a = random_unit_vector() - b = random_unit_vector() - call Print('a:') - call Print(a) - call Print('b:') - call Print(b) - call Print('Creating random rotation quaternion...') - q1 = Rotation(random_unit_vector(),ran_uniform()*PI) - call Print(q1) - call Print('Rotating random vectors with random quaternion...') - c = a - call Rotate(c,q1) - d = b - call Rotate(d,q1) - call Print('a -> c:') - call Print(c) - call Print('b -> d:') - call Print(b) - call Print('Calculating rotation quaternion based on a,b,c,d:') - q2 = Orientation(a,b,c,d,.true.) - call Print(q2) - call Print('') - - end subroutine quaternion_test - -end module quaternions_module diff --git a/src/libAtoms/RigidBody.f95 b/src/libAtoms/RigidBody.f95 deleted file mode 100644 index b3eada677d..0000000000 --- a/src/libAtoms/RigidBody.f95 +++ /dev/null @@ -1,885 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!% Types and routines for rigid body dynamics. -!% -!% \textbf{The implementation of the NO_SQUISH algorithm in AdvanceVerlet still requires -!% some work, so rigid bodies should be constructed from constraints for the time -!% being.} -! -module rigidbody_module - - use system_module - use periodictable_module - use linearalgebra_module - use atoms_module - use quaternions_module - - implicit none - private - - public :: rigidbodymodel, rigidbody, initialise, finalise, print - - type RigidBodyModel - !% Object used as a reference by the RigidBody type. - !% Many RigidBodys can point to the same model - - type(Atoms) :: at !% The actual atoms - integer :: d1a, d1b, d2a, d2b !% Atoms used as reference directions, 'd1a$>$d1b' and 'd2a$>$d2b' - real(dp), dimension(3) :: I !% Moments of inertia along x,y,z axes (after reorientation) - real(dp) :: Mtot !% The total mass of the body - logical :: initialised = .false. - - end type RigidBodyModel - - - type RigidBody - !% Holds one rigid body (e.g. one water molecule) - - integer :: N = 0 !% Number of atoms in the rigid body - integer, allocatable, dimension(:) :: indices !% Atoms that make up the rigid body - type(RigidBodyModel), pointer :: model !% A model of the rigid body in its correct conformation - type(Quaternion) :: q !% The orientation of the body - type(Quaternion) :: p !% The momentum of the orientation - real(dp), dimension(3) :: RCoM !% The centre of mass position - real(dp), dimension(3) :: VCoM !% The centre of mass velocity - logical :: initialised = .false. - - end type RigidBody - - integer, parameter :: M_ROT = 10 !Increasing this number integrates the rigid rotations more accurately - - interface initialise - module procedure rigidbody_initialise - end interface initialise - - interface finalise - module procedure rigidbody_finalise, rigidbodies_finalise - end interface finalise - - interface assignment(=) - module procedure rigidbody_assignment, rigidbodies_assignment - end interface - - interface print - module procedure rigidbodymodel_print, rigidbody_print, rigidbodies_print - end interface print - - private P0, P1, P2, P3 - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X INITIALISATION / FINALISATION - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - !% Initialise a RigidBodyModel: - !% \begin{itemize} - !% \item Calculates total mass. - !% \item Shifts the centre of mass to the origin. - !% \item Calculates moments of inertia and rotates - !% the atoms so that the principal axes. - !% lie along cartesian directions. - !% \item Finds two reference directions which are - !% not (anti)parallel. - !% \end{itemize} - ! - subroutine rigidbodymodel_initialise(this,at) - - type(RigidBodyModel), intent(inout) :: this - type(Atoms), intent(in) :: at - !local variables - real(dp), dimension(3,3) :: I_matrix, I_vects - real(dp), dimension(3) :: XCoM, d1, d2 - real(dp) :: m - integer :: i - type(Quaternion) :: q - - !A rigid body must have at least 2 atoms - if (at%N < 3) call system_abort('RigidBodyModel_Initialise: A rigid body must have at least 3 atoms') - - if (this%initialised) call rigidbodymodel_finalise(this) - - !Copy the atomic info - call initialise(this%at,at%N,at%lattice) - this%at%Z = at%Z - this%at%pos = at%pos - - !Shift the model so that the centre of mass is at the origin (note: no periodic wrapping is assumed) - XCoM = 0.0_dp - this%Mtot = 0.0_dp - - do i = 1, this%at%N - m = this%at%mass(i) - XCoM = XCoM + m * this%at%pos(:,i) - this%Mtot = this%Mtot + m - end do - - XCoM = XCoM / this%Mtot - - do i = 1, this%at%N - this%at%pos(:,i) = this%at%pos(:,i) - XCoM - end do - - !Calculate the model's inertia tensor - I_matrix = Inertia_Tensor(this%at) - call diagonalise(I_matrix,this%I,I_vects) !Stores the moments of inertia in this%I - - !Rotate the model so that the principle axes point along the x,y,z directions. - !The positions are then stored in body-fixed coordinates - !Eigenvalues are already normalised and orthogonal. - q = Orientation(I_vects(:,1), I_vects(:,2), & !Go from where the eigenvalues point... - (/1.0_dp,0.0_dp,0.0_dp/),(/0.0_dp,1.0_dp,0.0_dp/),.true.)!... to the x and y axes - - do i = 1, this%at%N - call rotate(this%at%pos(:,i),q) - end do - - !Find two non-parallel reference directions within the structure - this%d1a = 1; this%d1b = 2 - this%d2a = 1; this%d2b = 3 - do - d1 = this%at%pos(:,this%d1b) - this%at%pos(:,this%d1a) - d2 = this%at%pos(:,this%d2b) - this%at%pos(:,this%d2a) - d1 = d1 / norm(d1) - d2 = d2 / norm(d2) - if (abs(d1 .dot. d2) .fne. 1.0_dp) exit - !Directions are parallel... try a different set. - this%d2b = this%d2b + 1 - if (this%d2b > this%at%N) then - this%d1b = this%d1b + 1 - this%d2b = this%d1b + 1 - if (this%d2b == this%at%N) call System_Abort('RigidBodyModel_Initialise: Structure is Linear!') - end if - end do - - !Now the object is initialised - this%initialised = .true. - - end subroutine rigidbodymodel_initialise - - subroutine rigidbodymodel_finalise(this) - - type(RigidBodyModel), intent(inout) :: this - - call finalise(this%at) - this%d1a = 0; this%d1b = 0 - this%d2a = 0; this%d2b = 0 - this%I = 0.0_dp - this%Mtot = 0.0_dp - - this%initialised = .false. - - end subroutine rigidbodymodel_finalise - - ! - !% Initialise: The atoms in 'indices' must be in the same order as in the RigidModel - ! - subroutine rigidbody_initialise(this,at,indices,RigidModel) - - type(RigidBody), intent(inout) :: this !% The rigid body object we are initialising - type(Atoms), intent(inout) :: at !% The atoms object to which the indices refer - integer, dimension(:), intent(in) :: indices !% The indices of the atoms which make up the rigid body - type(RigidBodyModel), target, intent(in) :: RigidModel !% A model of the rigid body in its proper conformation - !local variables - integer :: i - - !Check the model has been initialised - if (.not.RigidModel%initialised) call system_abort('RigidBody_Initialise: Model is not initialised') - - !Check for the correct number of atoms - if (size(indices) /= RigidModel%at%N) then - write(line,'(a,i0,a,i0,a)')'RigidBody_Initialise: The model contains ',RigidModel%at%N,' atoms but ', & - size(indices),' indices have been provided' - call system_abort(line) - end if - - !Check the atomic indices and atomic numbers - do i = 1, size(indices) - if (indices(i) > at%N) then - write(line,'(a,i0,a,i0,a)')'RigidBody_Initialise: Atom ',indices(i),' is out of range (',at%N,')' - call system_abort(line) - end if - if (RigidModel%at%Z(i) /= at%Z(indices(i))) then - write(line,'(4(a,i0),a)')'RigidBody_Initialise: Atom ',i, & - ' of model ('//trim(ElementName(RigidModel%at%Z(i)))//', Z=', & - RigidModel%at%Z(i),') does not match atom ',indices(i), & - ' of atoms object ('//trim(ElementName(at%Z(indices(i))))//', Z=', & - at%Z(indices(i)),')' - call system_abort(line) - end if - end do - - call reallocate(this%indices,size(indices)) - this%indices = indices - this%N = size(indices) - - this%model => RigidModel - - this%q = 0.0_dp - this%p = 0.0_dp - this%RCoM = 0.0_dp - this%VCoM = 0.0_dp - - !Now we are initialised! - this%initialised = .true. - - end subroutine rigidbody_initialise - - subroutine rigidbody_finalise(this) - - type(RigidBody), intent(inout) :: this - - this%N = 0 - if (allocated(this%indices)) deallocate(this%indices) - this%model => null() - - this%q = 0.0_dp - this%p = 0.0_dp - this%RCoM = 0.0_dp - this%VCoM = 0.0_dp - - this%initialised = .false. - - end subroutine rigidbody_finalise - - ! - !% Finalise an allocatable array of RigidBodys - ! - subroutine rigidbodies_finalise(this) - - type(RigidBody), dimension(:), allocatable, intent(inout) :: this - integer :: i - - if (allocated(this)) then - do i = 1, size(this) - call finalise(this(i)) - end do - deallocate(this) - end if - - end subroutine rigidbodies_finalise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X ASSIGNMENT - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine rigidbody_assignment(to,from) - - type(RigidBody), intent(inout) :: to - type(RigidBody), intent(in) :: from - - call finalise(to) - - if (from%initialised) then - - allocate(to%indices(size(from%indices))) - - to%N = from%N - to%indices = from%indices - to%model => from%model - to%q = from%q - to%p = from%p - to%RCoM = from%RCoM - to%VCoM = from%VCoM - to%initialised = from%initialised - - end if - - end subroutine rigidbody_assignment - - subroutine rigidbodies_assignment(to,from) - - type(RigidBody), dimension(:), intent(inout) :: to - type(RigidBody), dimension(:), intent(in) :: from - integer :: i - - if (size(to) /= size(from)) call system_abort('RigidBodies_Assignment: Target array has different length to source array') - - do i = 1, size(from) - to(i) = from(i) - end do - - end subroutine rigidbodies_assignment - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X I/O - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine rigidbodymodel_print(this, file) - - type(RigidBodyModel), intent(inout) :: this - type(Inoutput), intent(inout), optional :: file - - call print('================', file=file) - call print(' RigidBodyModel', file=file) - call print('================', file=file) - call print('', file=file) - if (this%initialised) then - call print('Atoms:', file=file) - call print('------------', file=file) - call print(this%at, file=file) - call print('------------', file=file) - call print('', file=file) - write(line,'(2(a,i0))') 'Reference direction 1: atom ',this%d1a,' --> atom ',this%d1b - call print(line, file=file) - write(line,'(2(a,i0))') 'Reference direction 2: atom ',this%d2a,' --> atom ',this%d2b - call print(line, file=file) - call print('', file=file) - call print('Inertia Tensor:', file=file) - call print(inertia_tensor(this%at), file=file) - call print('Stored moments of inertia:') - call print(this%I, file=file) - call print('', file=file) - call print('Total Mass:', file=file) - call print(this%Mtot, file=file) - else - call print('(uninitialised)', file=file) - end if - call print('', file=file) - call print('================', file=file) - - end subroutine rigidbodymodel_print - - subroutine rigidbody_print(this, file) - - type(RigidBody), intent(inout) :: this - type(Inoutput), intent(inout), optional :: file - - call print('XXXXXXXXXXXXXXXX', file=file) - call print(' Rigid Body', file=file) - call print('XXXXXXXXXXXXXXXX', file=file) - call print('', file=file) - if (this%initialised) then - write(line,'(a,i0)')'Number of atoms = ',this%N - call print(line, file=file) - call print('', file=file) - call print('Atomic indices:', file=file) - call print(this%indices, file=file) - call print('', file=file) - call print('Reference Model =>', file=file) - call print(this%model, file=file) - call print('', file=file) - call print('Orientation quaternion:', file=file) - call print(this%q, file=file) - call print('Conjugate momentum quaternion:', file=file) - call print(this%p, file=file) - call print('', file=file) - call print('Centre of mass position:', file=file) - call print(this%RCoM, file=file) - call print('Centre of mass velocity:', file=file) - call print(this%VCoM, file=file) - else - call print('(uninitialised)', file=file) - end if - call print('', file=file) - call print('XXXXXXXXXXXXXXXX', file=file) - - end subroutine rigidbody_print - - subroutine rigidbodies_print(this,file) - - type(Rigidbody), dimension(:), intent(inout) :: this - type(inoutput), optional, intent(inout) :: file - integer :: i - - do i = 1, size(this) - call print(this(i),file) - end do - - end subroutine rigidbodies_print - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X FUNCTIONS FOR WORKING WITH RIGID BODIES - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function inertia_tensor(this) result(I) - - type(Atoms), intent(in) :: this - real(dp), dimension(3,3) :: I - !local variables - integer :: j - real(dp) :: r(3), m, x2, xy, xz, y2, yz, z2 - - I = 0.0_dp - do j = 1, this%N - r = this%pos(:,j) - m = this%mass(j) - x2 = r(1)*r(1); y2 = r(2)*r(2); z2 = r(3)*r(3) - xy = r(1)*r(2); xz = r(1)*r(3); yz = r(2)*r(3) - I(1,1) = I(1,1) + m * (y2 + z2) - I(2,2) = I(2,2) + m * (x2 + z2) - I(3,3) = I(3,3) + m * (x2 + y2) - I(1,2) = I(1,2) - m * xy - I(1,3) = I(1,3) - m * xz - I(2,3) = I(2,3) - m * yz - end do - !Fill in symmetric bits - I(2,1) = I(1,2) - I(3,1) = I(1,3) - I(3,2) = I(2,3) - - end function inertia_tensor - - ! - ! Functions and routines required by NO_SQUISH - ! - ! From Miller et al.: - ! P_0 q = {q0,q1,q2,q3} P_1 q = {-q1,q0,q3,-q2} P_2 q = {-q2,-q3,q0,q1} P_3 q = {-q3,q2,-q1,q0} - ! - ! ( ( | ) ( | ) ( | ) ( | ) ) - ! Matrix S(q) = ( (P_0 q) (P_1 q) (P_2 q) (P_3 q) ) - ! ( ( | ) ( | ) ( | ) ( | ) ) - ! - - function P0(q) !does nothing, but here for completeness - type(Quaternion), intent(in) :: q - type(Quaternion) :: P0 - P0 = q - end function P0 - - function P1(q) - type(Quaternion), intent(in) :: q - type(Quaternion) :: P1 - P1 = (/-q%b,q%a,q%d,-q%c/) - end function P1 - - function P2(q) - type(Quaternion), intent(in) :: q - type(Quaternion) :: P2 - P2 = (/-q%c,-q%d,q%a,q%b/) - end function P2 - - function P3(q) - type(Quaternion), intent(in) :: q - type(Quaternion) :: P3 - P3 = (/-q%d,q%c,-q%b,q%a/) - end function P3 - - function no_squish_S(q) result(S) - type(Quaternion), intent(in) :: q - real(dp), dimension(4,4) :: S - S(1,1) = +q%a; S(1,2) = -q%b; S(1,3) = -q%c; S(1,4) = -q%d - S(2,1) = +q%b; S(2,2) = +q%a; S(2,3) = -q%d; S(2,4) = +q%c - S(3,1) = +q%c; S(3,2) = +q%d; S(3,3) = +q%a; S(3,4) = -q%b - S(4,1) = +q%d; S(4,2) = -q%c; S(4,3) = +q%b; S(4,4) = +q%a - end function no_squish_S - - function no_squish_A_dot_transpose(q,q_dot) result(A_t) - - type(Quaternion), intent(in) :: q,q_dot - real(dp), dimension(3,3) :: A_t - - A_t(1,1) = q%a*q_dot%a + q%b*q_dot%b - q%c*q_dot%c - q%d*q_dot%d - A_t(2,1) = q%b*q_dot%c + q%c*q_dot%b + q%a*q_dot%d + q%d*q_dot%a - A_t(3,1) = q%b*q_dot%d + q%d*q_dot%b - q%a*q_dot%c - q%c*q_dot%a - A_t(1,2) = q%b*q_dot%c + q%c*q_dot%b - q%a*q_dot%d - q%d*q_dot%a - A_t(2,2) = q%a*q_dot%a - q%b*q_dot%b + q%c*q_dot%c - q%d*q_dot%d - A_t(3,2) = q%c*q_dot%d + q%d*q_dot%c + q%a*q_dot%b + q%b*q_dot%a - A_t(1,3) = q%b*q_dot%d + q%d*q_dot%b + q%a*q_dot%c + q%c*q_dot%a - A_t(2,3) = q%c*q_dot%d + q%d*q_dot%c - q%a*q_dot%b - q%b*q_dot%a - A_t(3,3) = q%a*q_dot%a - q%b*q_dot%b - q%c*q_dot%c + q%d*q_dot%d - - A_t = 2.0_dp * A_t - - end function no_squish_A_dot_transpose - - ! - ! Free_Rotor: part of the NO_SQUISH algorithm - ! - subroutine no_squish_free_rotor(q,p,I,dt) - - type(Quaternion), intent(inout) :: q,p - real(dp), dimension(3), intent(in) :: I - real(dp) :: dt - !local variables - real(dp) :: zetadt_2, zetadt, delta_t - integer :: j - - !Free rotation in M_ROT steps - delta_t = dt / real(M_ROT,dp) - do j = 1, M_ROT - - zetadt_2 = delta_t * (p .dot. P3(q)) / (8.0_dp * I(3)) - q = cos(zetadt_2)*q + sin(zetadt_2)*P3(q) - p = cos(zetadt_2)*p + sin(zetadt_2)*P3(p) - - zetadt_2 = delta_t * (p .dot. P2(q)) / (8.0_dp * I(2)) - q = cos(zetadt_2)*q + sin(zetadt_2)*P2(q) - p = cos(zetadt_2)*p + sin(zetadt_2)*P2(p) - - zetadt = delta_t * (p .dot. P1(q)) / (4.0_dp * I(1)) - q = cos(zetadt_2)*q + sin(zetadt_2)*P1(q) - p = cos(zetadt_2)*p + sin(zetadt_2)*P1(p) - - zetadt_2 = delta_t * (p .dot. P2(q)) / (8.0_dp * I(2)) - q = cos(zetadt_2)*q + sin(zetadt_2)*P2(q) - p = cos(zetadt_2)*p + sin(zetadt_2)*P2(p) - - zetadt_2 = delta_t * (p .dot. P3(q)) / (8.0_dp * I(3)) - q = cos(zetadt_2)*q + sin(zetadt_2)*P3(q) - p = cos(zetadt_2)*p + sin(zetadt_2)*P3(p) - - end do - - end subroutine no_squish_free_rotor - -end module RigidBody_module - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X RIGID BODY ROUTINES - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !This is based on the NO_SQUISH algorithm - !Miller et al., JChemPhys 116(20) 8649 (2002) - - ! - !% From Positions and Velocities of individual atoms, calculate the - !% centre of mass, centre of mass velocity, the orientation, and the - !% orientation conjugate momentum. - ! -! subroutine rigidbody_calculate_variables(this,i) -! -! type(DynamicalSystem), intent(inout) :: this -! integer, intent(in) :: i -! integer :: j,k, d1s_a, d1s_b, d2s_a, d2s_b -! real(dp), dimension(3) :: VCoM,L,r,v, d1s,d2s,d1b,d2b -! real(dp), dimension(4,4) :: S -! real(dp), dimension(4) :: L4 -! real(dp) :: m -! type(Quaternion) :: q -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_CalculateVariables: Rigid Body ',i,' is out of range' -! call system_abort(line) -! end if -! -! !Work out which atoms the reference directions go bewteen in the full atomic system -! d1s_a = this%rigidbody(i)%indices(this%rigidbody(i)%model%d1a) -! d1s_b = this%rigidbody(i)%indices(this%rigidbody(i)%model%d1b) -! d2s_a = this%rigidbody(i)%indices(this%rigidbody(i)%model%d2a) -! d2s_b = this%rigidbody(i)%indices(this%rigidbody(i)%model%d2b) -! !Find the directions in body and space coordinates -! d1s = diff_min_image(this%atoms,d1s_a,d1s_b) -! d2s = diff_min_image(this%atoms,d2s_a,d2s_b) -! d1b = this%rigidbody(i)%model%at%pos(:,this%rigidbody(i)%model%d1b) - & -! this%rigidbody(i)%model%at%pos(:,this%rigidbody(i)%model%d1a) -! d2b = this%rigidbody(i)%model%at%pos(:,this%rigidbody(i)%model%d2b) - & -! this%rigidbody(i)%model%at%pos(:,this%rigidbody(i)%model%d2a) -! !Calculate the rotation quaternion to go from body to space coords -! q = Orientation(d1b,d2b,d1s,d2s,correct_angle = .true.) -! this%rigidbody(i)%q = q -! !Calculate its angular momentum in the body frame of reference -! VCoM = centre_of_mass_velo(this,this%rigidbody(i)%indices) -! L = 0.0_dp -! q = this%rigidbody(i)%q -! do j = 1, this%rigidbody(i)%N -! -! k = this%rigidbody(i)%indices(j) !index of the jth atom in rigid body i -! m = this%atoms%Z(k) !the mass of the jth atom -! r = this%rigidbody(i)%model%at%pos(:,j) !the body fixed coordinates of jth atom -! v = Rotate((this%atoms%velo(:,k) - VCoM),.conj.q) !body fixed velocity of jth atom -! L = L + m * (r .cross. v) -! -! end do -! -! !Calculate the momentum conjugate to the orientation quaternion -! L4 = (/0.0_dp,L/) !this is D^-1 omega(4) in equation 2.15 of Miller et al. -! S = no_squish_S(q) -! this%rigidbody(i)%p = 2.0_dp * (S .mult. L4) -! -! !Store the centre of mass position and velocity -! this%rigidbody(i)%RCoM = centre_of_mass(this%atoms,this%rigidbody(i)%indices) -! this%rigidbody(i)%VCoM = VCoM -! -! end subroutine rigidbody_calculate_variables -! -! subroutine rigidbody_write_positions(this,i) -! -! type(DynamicalSystem), intent(inout) :: this -! integer, intent(in) :: i -! !local variables -! integer :: j, k -! real(dp), dimension(3) :: r -! type(Quaternion) :: q -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_WritePositions: Rigid Body ',i,' is out of range' -! call system_abort(line) -! end if -! -! q = this%rigidbody(i)%q -! -! do j = 1, this%rigidbody(i)%model%at%N -! k = this%rigidbody(i)%indices(j) !jth atom of rigid body -! r = this%rigidbody(i)%model%at%pos(:,j) !body coords of jth atom -! this%atoms%pos(:,k) = this%rigidbody(i)%RCoM + Rotate(r,this%rigidbody(i)%q) -! end do -! -! end subroutine rigidbody_write_positions -! -! subroutine rigidbody_write_velocities(this,i) -! -! type(DynamicalSystem), intent(inout) :: this -! integer, intent(in) :: i -! !local variables -! integer :: j, k -! real(dp), dimension(3) :: r, omega -! type(Quaternion) :: q -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_WriteVelocities: Rigid Body ',i,' is out of range' -! call system_abort(line) -! end if -! -! q = this%rigidbody(i)%q -! omega = RigidBody_angular_velocity(this,i) -! -! do j = 1, this%rigidbody(i)%model%at%N -! k = this%rigidbody(i)%indices(j) !jth atom of rigid body -! r = this%rigidbody(i)%model%at%pos(:,j) !body coords of jth atom -! this%atoms%velo(:,k) = this%rigidbody(i)%VCoM + Rotate((omega .cross. r),q) -! end do -! -! end subroutine rigidbody_write_velocities -! -! ! -! !% Reconstitute a rigid body that has been split over periodic boundaries -! ! -! subroutine rigidbody_reconstitute(this,i) -! -! type(DynamicalSystem), intent(inout) :: this -! integer, intent(in) :: i -! integer :: j, k, n, t(3) -! real(dp), dimension(3) :: r -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_Reconstitute: Rigid Body ',i,' is out of range' -! call system_abort(line) -! end if -! -! !Map everything back into the cell of the first atom in the body -! j = this%rigidbody(i)%indices(1) -! r = this%atoms%pos(:,j) -! t = this%atoms%travel(:,j) -! do n = 2, this%rigidbody(i)%N -! k = this%rigidbody(i)%indices(n) -! !Alter the position -! this%atoms%pos(:,k) = r + diff_min_image(this%atoms,j,k) -! !Make the travel values agree... RIGID BODIES CANNOT SPAN MORE THAN ONE CELL (why would they?) -! this%atoms%travel(:,k) = t -! end do -! -! end subroutine rigidbody_reconstitute -! -! ! -! !% Calculate the current angular velocity of rigid body 'i', in body frame -! ! -! function rigidbody_angular_velocity(this,i) result(omega) -! -! type(DynamicalSystem), intent(in) :: this -! integer, intent(in) :: i -! real(dp), dimension(3) :: omega -! real(dp), dimension(4) :: p4, sTp -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_AngularVelocity: Rigid Body ',i,' is out of range' -! call System_Abort(line) -! end if -! -! p4 = this%rigidbody(i)%p -! !sTp(1) should always be zero -! sTp = transpose(no_squish_S(this%rigidbody(i)%q)) .mult. p4 -! omega = 0.5_dp * sTp(2:4) / this%rigidbody(i)%model%I -! -! end function rigidbody_angular_velocity -! -! ! -! !% Calculate the current angular velocity of rigid body 'i', in body frame -! ! -! function rigidbody_angular_momentum(this,i) result(L) -! -! type(DynamicalSystem), intent(in) :: this -! integer, intent(in) :: i -! real(dp), dimension(3) :: L -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_AngularMomentum: Rigid Body ',i,' is out of range' -! call system_abort(line) -! end if -! -! L = this%rigidbody(i)%model%I * RigidBody_Angular_Velocity(this,i) !elementwise multiplication since -! !I is a vector, not a matrix -! -! end function rigidbody_angular_momentum -! -! ! -! !% Calculate the current torque on the rigid body 'i', in body frame -! ! -! function rigidbody_torque(this,i) result(tau) -! -! type(DynamicalSystem), intent(in) :: this -! integer, intent(in) :: i -! real(dp), dimension(3) :: tau, ACoM, r, a -! real :: m -! integer :: j, k -! type(Quaternion) :: q -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_Torque: Rigid Body ',i,' is out of range' -! call system_abort(line) -! end if -! -! ACoM = centre_of_mass_acc(this,this%rigidbody(i)%indices) -! q = this%rigidbody(i)%q -! tau = 0.0_dp -! -! do j = 1, this%rigidbody(i)%model%at%N -! k = this%rigidbody(i)%indices(j) !jth atom of rigid body i -! m = this%rigidbody(i)%model%at%mass(j) -! r = this%rigidbody(i)%model%at%pos(:,j) !body coords of jth atom -! a = Rotate((this%atoms%acc(:,k) - ACoM), .conj.q) !Rotate the non-CoM acceleration into the body frame -! tau = tau + m * (r .cross. a) -! end do -! -! end function rigidbody_torque -! -! function rigidbody_rotational_energy(this,i) result(Erot) -! -! type(DynamicalSystem), intent(in) :: this -! integer, intent(in) :: i -! real(dp) :: Erot -! real(dp), dimension(3) :: Im, omega -! -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_RotationalEnergy: Rigid Body ',i,' is out of range' -! call system_abort(line) -! end if -! -! omega = RigidBody_Angular_Velocity(this,i) -! Im = this%rigidbody(i)%model%I -! Erot = 0.5_dp * (Im(1)*omega(1)*omega(1) + Im(2)*omega(2)*omega(2) + Im(3)*omega(3)*omega(3)) -! -! end function rigidbody_rotational_energy -! -! function rigidbody_translational_energy(this,i) result(Etrans) -! -! type(DynamicalSystem), intent(in) :: this -! integer, intent(in) :: i -! real(dp) :: Etrans -! -! if (i < 1 .or. i > this%Nrigid) then -! write(line,'(a,i0,a)')'RigidBody_TranslationalEnergy: Rigid Body ',i,' is out of range' -! call system_abort(line) -! end if -! -! Etrans = 0.5_dp*this%rigidbody(i)%model%Mtot * normsq(centre_of_mass_velo(this,this%rigidbody(i)%indices)) -! -! end function rigidbody_translational_energy -! -! ! -! !% Add rigid bodies to the DynamicalSystem -! ! -! subroutine ds_add_rigidbody(this,indices,model) -! -! type(DynamicalSystem), intent(inout) :: this -! integer, dimension(:), intent(in) :: indices -! type(RigidBodyModel), target, intent(in) :: model -! !local variables -! integer :: i, g1, g2 -! -! !Check if rigid bodies have been set up -! if (.not.allocated(this%rigidbody)) call system_abort('DS_AddRigidBody: Rigid Bodies have not been allocated') -! -! !Have we got space for another rigid body? -! if (this%Nrigid == size(this%rigidbody)) then -! write(line,'(a,i0,a)')'DS_AddRigidBody: Maximum number of rigid bodies reached (',this%Nrigid,')' -! call system_abort(line) -! end if -! -! !Initialise the rigid body and update the group variables -! this%Nrigid = this%Nrigid + 1 -! g1 = this%group_lookup(indices(1)) -! do i = 1, size(indices) -! if (Atom_Type(this,indices(i)) /= TYPE_ATOM) then -! write(line,'(a,i0,a)')'DS_AddRigidBody: Atom ',indices(i),& -! ' is already being treated by another integration method' -! call system_abort(line) -! end if -! g2 = this%group_lookup(indices(i)) -! call merge_groups(this%group(g1),this%group(g2)) -! end do -! -! !Make atoms belong to this rigid body -! call group_add_object(this%group(g1),this%Nrigid) -! call initialise(this%rigidbody(this%Nrigid),this%atoms,indices,model) -! -! !Calculate the dynamical variables -! call rigidbody_calculate_variables(this,this%Nrigid) -! -! !Reduce the number of degrees of freedom: -! !Subtract 3 translational DoF for each atom, then add on the 3 trans + 3 rot DoF for the body -! this%Ndof = this%Ndof - 3*size(indices) + 6 -! -! end subroutine ds_add_rigidbody -! -! ! -! !% Correct the positions of all the atoms in rigid bodies -! ! -! subroutine ds_correct_rigid_positions(this) -! -! type(DynamicalSystem), intent(inout) :: this -! integer :: i,j,n -! -! do i = 1, this%Nrigid -! -! call rigidbody_calculate_variables(this,i) -! -! do j = 1, this%rigidbody(i)%N -! n = this%rigidbody(i)%indices(j) -! this%atoms%pos(:,n) = Rotate(this%rigidbody(i)%model%at%pos(:,j), this%rigidbody(i)%q) & -! + this%rigidbody(i)%RCoM -! end do -! -! end do -! -! end subroutine ds_correct_rigid_positions diff --git a/src/libAtoms/ScaLAPACK.f95 b/src/libAtoms/ScaLAPACK.f95 deleted file mode 100644 index a8d33f4c51..0000000000 --- a/src/libAtoms/ScaLAPACK.f95 +++ /dev/null @@ -1,1662 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X ScaLAPACK module -!X -!% Module wrapping ScaLAPACK routines -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module ScaLAPACK_module - -use error_module -use System_module -use MPI_context_module - -implicit none -private - -#ifdef SCALAPACK -integer, external :: ilcm, indxg2p, indxl2g, numroc -#endif - -integer, parameter :: dlen_ = 50 - -public :: ScaLAPACK -type ScaLAPACK - logical :: active = .false. - type(MPI_context) :: MPI_obj - integer :: blacs_context ! BLACS context (process grid ID) - integer :: n_proc_rows = 1 ! number rows in process grid - integer :: n_proc_cols = 1 ! number columns in process grid - integer :: my_proc_row = 0 ! grid row index of this process - integer :: my_proc_col = 0 ! grid column index of this process -end type ScaLAPACK - -public :: Matrix_ScaLAPACK_Info -type Matrix_ScaLAPACK_Info - logical :: active = .false. - type(ScaLAPACK) :: ScaLAPACK_obj - integer :: N_R = 0 ! number of rows in global matrix - integer :: N_C = 0 ! number of columns in global matrix - integer :: NB_R = 0 ! number of rows per block - integer :: NB_C = 0 ! number of columns per block - integer :: desc(dlen_) ! descriptor for ScaLAPACK - integer :: l_N_R = 0 ! local number of rows for this process - integer :: l_N_C = 0 ! local number of columns for this process -end type Matrix_ScaLAPACK_Info - -public :: Initialise -interface Initialise - module procedure ScaLAPACK_Initialise - module procedure Matrix_ScaLAPACK_Info_Initialise -end interface Initialise - -public :: Finalise -interface Finalise - module procedure ScaLAPACK_Finalise - module procedure Matrix_ScaLAPACK_Info_Finalise -end interface Finalise - -public :: Wipe -interface Wipe - module procedure Matrix_ScaLAPACK_Info_Wipe -end interface Wipe - -public :: Print -interface Print - module procedure ScaLAPACK_Print, Matrix_ScaLAPACK_Info_Print - module procedure ScaLAPACK_Matrix_d_print - module procedure ScaLAPACK_Matrix_z_print -end interface Print - -public :: init_matrix_desc -interface init_matrix_desc - module procedure ScaLAPACK_init_matrix_desc -end interface init_matrix_desc - -public :: coords_local_to_global -interface coords_local_to_global - module procedure Matrix_ScaLAPACK_Info_coords_local_to_global -end interface coords_local_to_global - -public :: coords_global_to_local -interface coords_global_to_local - module procedure Matrix_ScaLAPACK_Info_coords_global_to_local -end interface coords_global_to_local - -public :: diagonalise -interface diagonalise - module procedure ScaLAPACK_diagonalise_r, ScaLAPACK_diagonalise_c - module procedure ScaLAPACK_diagonalise_gen_r, ScaLAPACK_diagonalise_gen_c -end interface - -public :: inverse -interface inverse - module procedure ScaLAPACK_inverse_r, ScaLAPACK_inverse_c -end interface - -public :: add_identity -interface add_identity - module procedure ScaLAPACK_add_identity_r -end interface - -public :: matrix_product_sub -interface matrix_product_sub - module procedure ScaLAPACK_matrix_product_sub_ddd, ScaLAPACK_matrix_product_sub_zzz -end interface - -public :: matrix_product_vect_asdiagonal_sub -interface matrix_product_vect_asdiagonal_sub - module procedure ScaLAPACK_matrix_product_vect_asdiagonal_sub_ddd - module procedure ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzd - module procedure ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzz -end interface matrix_product_vect_asdiagonal_sub - -public :: Re_diag -interface Re_diag - module procedure ScaLAPACK_Re_diagZ, ScaLAPACK_Re_diagD -end interface Re_diag - -public :: diag_spinor -interface diag_spinor - module procedure ScaLAPACK_diag_spinorZ, ScaLAPACK_diag_spinorD -end interface diag_spinor - -public :: get_lwork_pdgeqrf -interface get_lwork_pdgeqrf - module procedure get_lwork_pdgeqrf_i32o64 - module procedure ScaLAPACK_get_lwork_pdgeqrf - module procedure ScaLAPACK_matrix_get_lwork_pdgeqrf -end interface - -public :: get_lwork_pdormqr -interface get_lwork_pdormqr - module procedure get_lwork_pdormqr_i32o64 - module procedure ScaLAPACK_get_lwork_pdormqr - module procedure ScaLAPACK_matrix_get_lwork_pdormqr -end interface - -public :: ScaLAPACK_pdgeqrf_wrapper, ScaLAPACK_pdtrtrs_wrapper, ScaLAPACK_pdormqr_wrapper -public :: ScaLAPACK_pdgemr2d_wrapper, ScaLAPACK_pdtrmr2d_wrapper -public :: ScaLAPACK_matrix_QR_solve, ScaLAPACK_to_array1d, ScaLAPACK_to_array2d - -contains - -subroutine Matrix_ScaLAPACK_Info_Initialise(this, N_R, N_C, NB_R, NB_C, scalapack_obj) - type(Matrix_ScaLAPACK_Info), intent(inout) :: this - integer, intent(in) :: N_R, NB_R - integer, intent(in), optional :: N_C, NB_C - type(ScaLAPACK), intent(in), optional :: scalapack_obj - -#ifdef SCALAPACK - - call Finalise(this) - - this%N_R = N_R - this%NB_R = NB_R - - if (present(N_C)) then - this%N_C = N_C - else - this%N_C = N_R - endif - if (present(NB_C)) then - this%NB_C = NB_C - else - this%NB_C = NB_R - endif - - if (present(scalapack_obj)) then - if (scalapack_obj%active) then - this%ScaLAPACK_obj = scalapack_obj - call init_matrix_desc(this%ScaLAPACK_obj, this%N_R, this%N_C, this%NB_R, this%NB_C, & - this%desc, this%l_N_R, this%l_N_C) - endif - else - this%l_N_R = this%N_R - this%l_N_C = this%N_C - endif - - this%active = this%ScaLAPACK_obj%active -#endif -end subroutine Matrix_ScaLAPACK_Info_Initialise - -subroutine ScaLAPACK_Initialise(this, MPI_obj, np_r, np_c) - type(ScaLAPACK), intent(inout) :: this - type(MPI_context), intent(in), optional :: MPI_obj - integer, intent(in), optional :: np_r, np_c !> rows, cols in process grid - -#ifdef SCALAPACK - call Finalise(this) - - this%active = .false. - if (present(MPI_obj)) then - if (MPI_obj%active .and. MPI_obj%n_procs > 1) then - this%active = .true. - - this%MPI_obj = MPI_obj - this%blacs_context = MPI_obj%communicator - - if (present(np_r) .and. present(np_c)) then - this%n_proc_rows = np_r - this%n_proc_cols = np_c - else - call calc_n_proc_rows_cols(this%MPI_obj%n_procs, this%n_proc_rows, this%n_proc_cols) - end if - call print("ScaLAPACK_Initialise using proc grid " // this%n_proc_rows // " x " // this%n_proc_cols, PRINT_VERBOSE) - - call blacs_gridinit (this%blacs_context, 'R', this%n_proc_rows, this%n_proc_cols) - call blacs_gridinfo (this%blacs_context, this%n_proc_rows, this%n_proc_cols, this%my_proc_row, this%my_proc_col) - endif - endif - -#endif -end subroutine ScaLAPACK_Initialise - -subroutine Matrix_ScaLAPACK_Info_Finalise(this) - type(Matrix_ScaLAPACK_Info), intent(inout) :: this - -#ifdef SCALAPACK - this%active = .false. -#endif -end subroutine - -subroutine ScaLAPACK_Finalise(this) - type(ScaLAPACK), intent(inout) :: this - -#ifdef SCALAPACK - if (this%active .and. this%blacs_context > -1) then - call blacs_gridexit(this%blacs_context) - endif - this%active = .false. -#endif -end subroutine - -subroutine Matrix_ScaLAPACK_Info_Wipe(this) - type(Matrix_ScaLAPACK_Info), intent(inout) :: this - -#ifdef SCALAPACK - this%active = .false. -#endif -end subroutine Matrix_ScaLAPACK_Info_Wipe - - -subroutine Matrix_ScaLAPACK_Info_coords_global_to_local(this, i, j, l_i, l_j, l_row_p, l_col_p) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - integer, intent(in) :: i, j - integer, intent(out) :: l_i, l_j - integer, intent(out), optional :: l_row_p, l_col_p - -#ifdef SCALAPACK - integer :: l_row_p_use, l_col_p_use - - if (this%active) then - call infog2l(i, j, this%desc, this%ScaLAPACK_obj%n_proc_rows, this%ScaLAPACK_obj%n_proc_cols, & - this%ScaLAPACK_obj%my_proc_row, this%ScaLAPACK_obj%my_proc_col, & - l_i, l_j, l_row_p_use, l_col_p_use) - - if (l_row_p_use /= this%ScaLAPACK_obj%my_proc_row .or. l_col_p_use /= this%ScaLAPACK_obj%my_proc_col) then - l_i = -1 - l_j = -1 - endif - - if (present(l_row_p)) l_row_p = l_row_p_use - if (present(l_col_p)) l_col_p = l_col_p_use - else -#endif - l_i = i - l_j = j - if (present(l_row_p)) l_row_p = 0 - if (present(l_col_p)) l_col_p = 0 -#ifdef SCALAPACK - endif -#endif -end subroutine Matrix_ScaLAPACK_Info_coords_global_to_local - -subroutine Matrix_ScaLAPACK_Info_coords_local_to_global(this, l_i, l_j, i, j) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - integer, intent(in) :: l_i, l_j - integer, intent(out) :: i, j - -#ifdef SCALAPACK - - if (this%active) then - i = indxl2g(l_i, this%NB_R, this%ScaLAPACK_obj%my_proc_row, 0, this%ScaLAPACK_obj%n_proc_rows) - j = indxl2g(l_j, this%NB_C, this%ScaLAPACK_obj%my_proc_col, 0, this%ScaLAPACK_obj%n_proc_cols) - else -#endif - i = l_i - j = l_j -#ifdef SCALAPACK - endif -#endif - -end subroutine Matrix_ScaLAPACK_Info_coords_local_to_global - - -subroutine ScaLAPACK_init_matrix_desc(this, N_R, N_C, NB_R, NB_C, desc, l_N_R, l_N_C) - type(ScaLAPACK), intent(in) :: this - integer, intent(in) :: N_R, NB_R - integer, intent(in), optional :: N_C, NB_C - integer, intent(out) :: desc(dlen_) - integer, intent(out) :: l_N_R, l_N_C - -#ifdef SCALAPACK - integer err - integer use_N_C, use_NB_C - integer lld -#endif - - desc = 0 - l_N_R = 0 - l_N_C = 0 - -#ifdef SCALAPACK - if (this%active) then - if (present(N_C)) then - use_N_C = N_C - else - use_N_C = N_R - endif - - if (present(NB_C)) then - use_NB_C = NB_C - else - use_NB_C = NB_R - endif - - l_N_R = numroc(N_R, NB_R, this%my_proc_row, 0, this%n_proc_rows) - l_N_C = numroc(use_N_C, use_NB_C, this%my_proc_col, 0, this%n_proc_cols) - - lld = l_N_R - if (l_N_r < 1) lld = 1 - - if (this%blacs_context >-1) then - call descinit (desc, N_R, use_N_C, NB_R, use_NB_C, 0, 0, this%blacs_context, lld, err) - else - desc(:) = -1 - end if - endif -#endif -end subroutine ScaLAPACK_init_matrix_desc - - - -subroutine calc_n_proc_rows_cols(n_procs, n_proc_rows, n_proc_cols) - integer, intent(in) :: n_procs - integer, intent(out) :: n_proc_rows, n_proc_cols - -#ifdef SCALAPACK - integer n_proc_rows_t, n_proc_cols_t - - -! long and narrow, or short and wide -! do n_proc_cols_t=int(sqrt(dble(n_procs))), 1, -1 -! n_proc_rows_t = n_procs/n_proc_cols_t - do n_proc_rows_t=int(sqrt(dble(n_procs))), 1, -1 - n_proc_cols_t = n_procs/n_proc_rows_t - - if (n_proc_rows_t*n_proc_cols_t .eq. n_procs) then - n_proc_rows = n_proc_rows_t - n_proc_cols = n_proc_cols_t - exit - endif - end do -#else - n_proc_rows = 0 - n_proc_cols = 0 -#endif -end subroutine calc_n_proc_rows_cols - -subroutine ScaLAPACK_Print(this,file) - type(ScaLAPACK), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - -#ifdef SCALAPACK - - call Print("ScaLAPACK : ", file=file) - - call Print ('ScaLAPACK : active ' // this%active, file=file) - if (this%active) then - call Print ('ScaLAPACK : n_proc rows cols ' // this%n_proc_rows // " " // this%n_proc_cols, file=file) - call Print ('ScaLAPACK : my row col ' // this%my_proc_row // " " // this%my_proc_col, file=file) - endif -#endif -end subroutine ScaLAPACK_Print - -subroutine Matrix_ScaLAPACK_Info_Print(this,file) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - type(Inoutput), intent(inout),optional:: file -#ifdef SCALAPACK - - call Print('Matrix_ScaLAPACK_Info : ', file=file) - - call Print ('Matrix_ScaLAPACK_Info : active ' // this%active, file=file) - if (this%active) then - call Print(this%ScaLAPACK_obj, file=file) - call Print ('Matrix_ScaLAPACK_Info : N_R N_C ' // this%N_R // " " // this%N_C, file=file) - call Print ('Matrix_ScaLAPACK_Info : NB_R NB_C ' // this%NB_R // " " // this%NB_C, file=file) - call Print ('Matrix_ScaLAPACK_Info : l_N_R l_N_C ' // this%l_N_R // " " // this%l_N_C, file=file) - call Print ('Matrix_ScaLAPACK_Info : desc ' // this%desc, file=file) - endif -#endif -end subroutine Matrix_ScaLAPACK_Info_Print - -subroutine ScaLAPACK_inverse_r(this, data, inv_scalapack_info, inv_data, positive_in) - type(Matrix_ScaLAPACK_Info), intent(in), target :: this - real(dp), intent(inout), target :: data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in), target, optional :: inv_scalapack_info - real(dp), intent(out), target, optional :: inv_data(:,:) - logical, intent(in), optional :: positive_in - -#ifdef SCALAPACK - real(dp), pointer :: u_inv_data(:,:) - integer, pointer :: u_inv_desc(:) - integer, allocatable :: ipiv(:) - integer :: info - integer :: lwork, liwork - real(dp), allocatable :: work(:) - integer, allocatable :: iwork(:) - - if (present(inv_data)) then - u_inv_data => inv_data - u_inv_data = data - else - u_inv_data => data - endif - if (present(inv_scalapack_info)) then - if (.not. present(inv_data)) call system_abort("ScaLAPACK_inverse_r called with inv_scalapack_info but w/o inv_data") - u_inv_desc => inv_scalapack_info%desc - else - u_inv_desc => this%desc - endif - - allocate(ipiv(numroc(this%N_C, this%NB_C, this%scalapack_obj%my_proc_row, 0, this%scalapack_obj%n_proc_rows)+this%NB_C)) - call pdgetrf(this%N_R, this%N_C, u_inv_data, 1, 1, u_inv_desc, ipiv, info) - if (info /= 0) then - call system_abort("ScaLAPACK_inverse_r got pdgetrf info " // info) - endif - - allocate(work(1)) - allocate(iwork(1)) - lwork = -1 - liwork = -1 - call pdgetri(this%N_R, u_inv_data, 1, 1, u_inv_desc, & - ipiv, work, lwork, iwork, liwork, info) - lwork = work(1) - liwork = iwork(1) - deallocate(work) - deallocate(iwork) - - allocate(work(lwork)) - allocate(iwork(liwork)) - call pdgetri(this%N_R, u_inv_data, 1, 1, u_inv_desc, & - ipiv, work, lwork, iwork, liwork, info) - if (info /= 0) then - call system_abort("ScaLAPACK_inverse_r got pdgetrf info " // info) - endif - - deallocate(work) - deallocate(iwork) - deallocate(ipiv) -#endif - -end subroutine ScaLAPACK_inverse_r - -subroutine ScaLAPACK_inverse_c(this, data, inv_scalapack_info, inv_data, positive_in) - type(Matrix_ScaLAPACK_Info), intent(in), target :: this - complex(dp), intent(inout), target :: data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in), target, optional :: inv_scalapack_info - complex(dp), intent(out), target, optional :: inv_data(:,:) - logical, intent(in), optional :: positive_in - -#ifdef SCALAPACK - complex(dp), pointer :: u_inv_data(:,:) - integer, pointer :: u_inv_desc(:) - integer, allocatable :: ipiv(:) - integer :: info - - integer :: lwork, liwork - complex(dp), allocatable :: work(:) - integer, allocatable :: iwork(:) - -! call system_timer("ScaLAPACK_inverse_c") -! call system_timer("ScaLAPACK_inverse_c/prep") - if (present(inv_data)) then - u_inv_data => inv_data - u_inv_data = data - else - u_inv_data => data - endif - if (present(inv_scalapack_info)) then - if (.not. present(inv_data)) call system_abort("ScaLAPACK_inverse_r called with inv_scalapack_info but w/o inv_data") - u_inv_desc => inv_scalapack_info%desc - else - u_inv_desc => this%desc - endif - - allocate(ipiv(numroc(this%N_C, this%NB_C, this%scalapack_obj%my_proc_row, 0, this%scalapack_obj%n_proc_rows)+this%NB_C)) -! call system_timer("ScaLAPACK_inverse_c/prep") -! call system_timer("ScaLAPACK_inverse_c/pzgetrf") - call pzgetrf(this%N_R, this%N_C, u_inv_data, 1, 1, u_inv_desc, ipiv, info) -! call system_timer("ScaLAPACK_inverse_c/pzgetrf") -! call system_timer("ScaLAPACK_inverse_c/pzgetri_prep") - if (info /= 0) then - call system_abort("ScaLAPACK_inverse_r got pzgetrf info " // info) - endif - - allocate(work(1)) - allocate(iwork(1)) - lwork = -1 - liwork = -1 - call pzgetri(this%N_R, u_inv_data, 1, 1, u_inv_desc, & - ipiv, work, lwork, iwork, liwork, info) - lwork = work(1) - liwork = iwork(1) - deallocate(work) - deallocate(iwork) - - allocate(work(lwork)) - allocate(iwork(liwork)) -! call system_timer("ScaLAPACK_inverse_c/pzgetri_prep") -! call system_timer("ScaLAPACK_inverse_c/pzgetri") - call pzgetri(this%N_R, u_inv_data, 1, 1, u_inv_desc, & - ipiv, work, lwork, iwork, liwork, info) -! call system_timer("ScaLAPACK_inverse_c/pzgetri") -! call system_timer("ScaLAPACK_inverse_c/post") - if (info /= 0) then - call system_abort("ScaLAPACK_inverse_r got pzgetrf info " // info) - endif - - deallocate(work) - deallocate(iwork) - deallocate(ipiv) -! call system_timer("ScaLAPACK_inverse_c/post") -! call system_timer("ScaLAPACK_inverse_c") -#endif -end subroutine ScaLAPACK_inverse_c - -subroutine ScaLAPACK_diagonalise_r(this, data, evals, evecs_ScaLAPACK_obj, evecs_data, error) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - real(dp), intent(in) :: data(:,:) - real(dp), intent(out) :: evals(:) - type(Matrix_ScaLAPACK_Info), intent(in) :: evecs_ScaLAPACK_obj - real(dp), intent(out) :: evecs_data(:,:) - integer, intent(out), optional :: error - - integer liwork, lwork - real(dp), allocatable :: data_copy(:,:) - integer, allocatable :: iwork(:) - real(dp), allocatable :: work(:) - integer, allocatable :: icluster(:), ifail(:) - real(dp), allocatable :: gap(:) - - integer info - integer M, NZ, i - real(dp) :: orfac = 1.0e-4_dp - - INIT_ERROR(error) - - evals = 0.0_dp - evecs_data = 0.0_dp - -#ifdef SCALAPACK - allocate(icluster(2*this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) - allocate(gap(this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) - allocate(ifail(this%N_R)) - - allocate(data_copy(this%l_N_R, this%l_N_C)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_r data_copy", size(data_copy)*REAL_SIZE) - data_copy = data - - lwork = -1 - liwork = -1 - allocate(work(1)) - allocate(iwork(1)) - call pdsyevx('V', 'A', 'U', this%N_R, & - data_copy, 1, 1, this%desc, & - 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & - orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, work, lwork, & - iwork, liwork, ifail, icluster, gap, info) - lwork=work(1)*4 - liwork=iwork(1) - deallocate(work) - deallocate(iwork) - allocate(work(lwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_r work", size(work)*REAL_SIZE) - allocate(iwork(liwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_r iwork", size(iwork)*INTEGER_SIZE) - - call pdsyevx('V', 'A', 'U', this%N_R, & - data_copy, 1, 1, this%desc, & - 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & - orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, work, lwork, & - iwork, liwork, ifail, icluster, gap, info) - - if (info .ne. 0) then - call print("ScaLAPACK_diagonalise_r got info " // info, PRINT_ALWAYS) - if (mod(info,2) .ne. 0) then - call print(" eigenvectors failed to converge", PRINT_ALWAYS) - else if (mod(info/2,2) .ne. 0) then - call print(" eigenvectors failed to orthogonalize", PRINT_ALWAYS) - do i=1, size(icluster), 2 - if (icluster(i) /= 0) then - call print (" eval cluster " // icluster(i) // " " // icluster(i+1) // & - "("// (icluster(i+1)-icluster(i)+1) // ")", PRINT_ALWAYS) - else - exit - endif - end do - do i=1, this%N_R - call print(" eigenvalue " // i // " " // evals(i), PRINT_ANALYSIS) - end do - else if (mod(info/4,2) .ne. 0) then - call print(" not enough space for all eigenvectors in range", PRINT_ALWAYS) - else if (mod(info/8,2) .ne. 0) then - call print(" failed to compute eigenvalues", PRINT_ALWAYS) - else if (mod(info/16,2) .ne. 0) then - call print(" S was not positive definite "//ifail(1), PRINT_ALWAYS) - endif - endif - - deallocate (icluster, ifail, gap) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_r work", size(work)*REAL_SIZE) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_r iwork", size(iwork)*INTEGER_SIZE) - deallocate (iwork, work) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_r data_copy", size(data_copy)*REAL_SIZE) - deallocate (data_copy) - - if (M /= this%N_R .or. NZ /= this%N_R) then ! bad enough error to report - RAISE_ERROR("ScaLAPACK_diagonalise_r: Failed to diagonalise info="//info, error) - endif -#endif - -end subroutine ScaLAPACK_diagonalise_r - -subroutine ScaLAPACK_diagonalise_c(this, data, evals, evecs_ScaLAPACK_obj, evecs_data, error) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - complex(dp), intent(in) :: data(:,:) - real(dp), intent(out) :: evals(:) - type(Matrix_ScaLAPACK_Info), intent(in) :: evecs_ScaLAPACK_obj - complex(dp), intent(out) :: evecs_data(:,:) - integer, intent(out), optional :: error - - integer liwork, lrwork, lcwork - integer, allocatable :: iwork(:) - real(dp), allocatable :: rwork(:) - complex(dp), allocatable :: cwork(:) - integer, allocatable :: icluster(:), ifail(:) - real(dp), allocatable :: gap(:) - - complex(dp), allocatable :: data_copy(:,:) - - integer info - integer M, NZ, i - real(dp) :: orfac = 1.0e-4_dp - - INIT_ERROR(error) - - evals = 0.0_dp - evecs_data = 0.0_dp - -#ifdef SCALAPACK - allocate(icluster(2*this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) - allocate(gap(this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) - allocate(ifail(this%N_R)) - - allocate(data_copy(this%l_N_R, this%l_N_C)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_c data_copy", size(data_copy)*COMPLEX_SIZE) - data_copy = data - - lrwork = -1 - lcwork = -1 - liwork = -1 - allocate(rwork(1)) - allocate(cwork(1)) - allocate(iwork(1)) - call pzheevx('V', 'A', 'U', this%N_R, & - data_copy, 1, 1, this%desc, & - 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & - orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, cwork, lcwork, & - rwork, lrwork, iwork, liwork, ifail, icluster, gap, info) - lrwork=rwork(1)*4 - lcwork=cwork(1) - liwork=iwork(1) - deallocate(rwork) - deallocate(cwork) - deallocate(iwork) - allocate(rwork(lrwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_c rwork", size(rwork)*REAL_SIZE) - allocate(cwork(lcwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_c cwork", size(cwork)*COMPLEX_SIZE) - allocate(iwork(liwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_c iwork", size(iwork)*INTEGER_SIZE) - - call pzheevx('V', 'A', 'U', this%N_R, & - data_copy, 1, 1, this%desc, & - 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & - orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, cwork, lcwork, & - rwork, lrwork, iwork, liwork, ifail, icluster, gap, info) - - if (info .ne. 0) then - call print("ScaLAPACK_diagonlise_c got info " // info, PRINT_ALWAYS) - if (mod(info,2) .ne. 0) then - call print(" eigenvectors failed to converge", PRINT_ALWAYS) - else if (mod(info/2,2) .ne. 0) then - call print(" eigenvectors failed to orthogonalize", PRINT_ALWAYS) - do i=1, size(icluster), 2 - if (icluster(i) /= 0) then - call print (" eval cluster " // icluster(i) // " " // icluster(i+1) // & - "("// (icluster(i+1)-icluster(i)+1) // ")", PRINT_ALWAYS) - else - exit - endif - end do - do i=1, this%N_R - call print(" eigenvalue " // i // " " // evals(i), PRINT_ANALYSIS) - end do - else if (mod(info/4,2) .ne. 0) then - call print(" not enough space for all eigenvectors in range", PRINT_ALWAYS) - else if (mod(info/8,2) .ne. 0) then - call print(" failed to compute eigenvalues", PRINT_ALWAYS) - else if (mod(info/16,2) .ne. 0) then - call print(" S was not positive definite "//ifail(1), PRINT_ALWAYS) - endif - endif - - deallocate (icluster, ifail, gap) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_c iwork", size(iwork)*INTEGER_SIZE) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_c rwork", size(rwork)*REAL_SIZE) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_c cwork", size(cwork)*COMPLEX_SIZE) - deallocate (iwork, rwork, cwork) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_c data_copy", size(data_copy)*COMPLEX_SIZE) - deallocate (data_copy) - - if (M /= this%N_R .or. NZ /= this%N_R) then ! bad enough error to report - RAISE_ERROR("ScaLAPACK_diagonalise_r: Failed to diagonalise info="//info, error) - endif -#endif - -end subroutine ScaLAPACK_diagonalise_c - -subroutine ScaLAPACK_diagonalise_gen_r(this, data, overlap_ScaLAPACK_obj, overlap_data, & - evals, evecs_ScaLAPACK_obj, evecs_data, error) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - real(dp), intent(in) :: data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: overlap_ScaLAPACK_obj - real(dp), intent(in) :: overlap_data(:,:) - real(dp), intent(out) :: evals(:) - type(Matrix_ScaLAPACK_Info), intent(in) :: evecs_ScaLAPACK_obj - real(dp), intent(out) :: evecs_data(:,:) - integer, intent(out), optional :: error - - integer :: liwork, lwork - integer, allocatable :: iwork(:) - real(dp), allocatable :: work(:) - integer, allocatable :: icluster(:), ifail(:) - real(dp), allocatable :: gap(:) - - real(dp), allocatable :: data_copy(:,:), overlap_data_copy(:,:) - - integer info - integer M, NZ, i - real(dp) :: orfac = 1.0e-4_dp - - INIT_ERROR(error) - - evals = 0.0_dp - evecs_data = 0.0_dp - -#ifdef SCALAPACK - allocate(icluster(2*this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) - allocate(gap(this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) - allocate(ifail(this%N_R)) - - allocate(data_copy(this%l_N_R, this%l_N_C)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r data_copy", size(data_copy)*REAL_SIZE) - allocate(overlap_data_copy(overlap_ScaLAPACK_obj%l_N_R, overlap_ScaLAPACK_obj%l_N_C)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r overlap_data_copy", size(overlap_data_copy)*REAL_SIZE) - data_copy = data - overlap_data_copy = overlap_data - - lwork = -1 - liwork = -1 - allocate(work(1)) - allocate(iwork(1)) - call pdsygvx(1, 'V', 'A', 'U', this%N_R, & - data_copy, 1, 1, this%desc, & - overlap_data_copy, 1, 1, overlap_ScaLAPACK_obj%desc, & - 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & - orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, work, lwork, & - iwork, liwork, ifail, icluster, gap, info) - lwork = work(1)*4 - liwork = iwork(1) - deallocate(work) - deallocate(iwork) - - allocate(work(lwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r work", size(work)*REAL_SIZE) - allocate(iwork(liwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r iwork", size(iwork)*INTEGER_SIZE) - -! call print("calling pdsygv : NR " // this%N_R // " shape(data_copy) " // shape(data_copy) // & -! " shape(overlap_data_copy) " // shape(overlap_data_copy) // " shape(evals) " // shape(evals) // & -! " shape(evecs_data) " // shape(evecs_data) // " shape(work) " // shape(work) // " lwork " // lwork // & -! " shape(iwork) " // shape(iwork) // " liwork " // liwork // " shape(ifail) " // shape(ifail) // & -! " shape(icluster) " // shape(icluster), PRINT_ALWAYS) - call pdsygvx(1, 'V', 'A', 'U', this%N_R, & - data_copy, 1, 1, this%desc, & - overlap_data_copy, 1, 1, overlap_ScaLAPACK_obj%desc, & - 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & - orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, work, lwork, & - iwork, liwork, ifail, icluster, gap, info) -! call print("done pdsygvx", PRINT_ALWAYS) - - if (info .ne. 0) then - call print("ScaLAPACK_diagonlise_gen_r got info " // info, PRINT_ALWAYS) - if (mod(info,2) .ne. 0) then - call print(" eigenvectors failed to converge", PRINT_ALWAYS) - else if (mod(info/2,2) .ne. 0) then - call print(" eigenvectors failed to orthogonalize", PRINT_ALWAYS) - do i=1, size(icluster), 2 - if (icluster(i) /= 0) then - call print (" eval cluster " // icluster(i) // " " // icluster(i+1) // & - "("// (icluster(i+1)-icluster(i)+1) // ")", PRINT_ALWAYS) - else - exit - endif - end do - do i=1, this%N_R - call print(" eigenvalue " // i // " " // evals(i), PRINT_ANALYSIS) - end do - else if (mod(info/4,2) .ne. 0) then - call print(" not enough space for all eigenvectors in range", PRINT_ALWAYS) - else if (mod(info/8,2) .ne. 0) then - call print(" failed to compute eigenvalues", PRINT_ALWAYS) - else if (mod(info/16,2) .ne. 0) then - call print(" S was not positive definite "//ifail(1), PRINT_ALWAYS) - endif - endif - - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r iwork", size(iwork)*INTEGER_SIZE) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r work", size(work)*REAL_SIZE) - deallocate (iwork, work) - - deallocate (icluster, ifail, gap) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r data_copy", size(data_copy)*REAL_SIZE) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r overlap_data_copy", size(overlap_data_copy)*REAL_SIZE) - deallocate (data_copy, overlap_data_copy) - - if (M /= this%N_R .or. NZ /= this%N_R) then ! bad enough error to report - RAISE_ERROR("ScaLAPACK_diagonalise_r: Failed to diagonalise info="//info, error) - endif -#endif - -end subroutine ScaLAPACK_diagonalise_gen_r - -subroutine ScaLAPACK_diagonalise_gen_c(this, data, overlap_ScaLAPACK_obj, overlap_data, & - evals, evecs_ScaLAPACK_obj, evecs_data, error) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - complex(dp), intent(in) :: data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: overlap_ScaLAPACK_obj - complex(dp), intent(in) :: overlap_data(:,:) - real(dp), intent(out) :: evals(:) - type(Matrix_ScaLAPACK_Info), intent(in) :: evecs_ScaLAPACK_obj - complex(dp), intent(out) :: evecs_data(:,:) - integer, intent(out), optional :: error - - integer liwork, lrwork, lcwork - integer, allocatable :: iwork(:) - real(dp), allocatable :: rwork(:) - complex(dp), allocatable :: cwork(:) - integer, allocatable :: icluster(:), ifail(:) - real(dp), allocatable :: gap(:) - - complex(dp), allocatable :: data_copy(:,:), overlap_data_copy(:,:) - - integer info - integer M, NZ, i - real(dp) :: orfac = 1.0e-4_dp - - INIT_ERROR(error) - - evals = 0.0_dp - evecs_data = 0.0_dp - -#ifdef SCALAPACK - allocate(icluster(2*this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) - allocate(gap(this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) - allocate(ifail(this%N_R)) - - allocate(data_copy(this%l_N_R, this%l_N_C)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r data_copy", size(data_copy)*COMPLEX_SIZE) - allocate(overlap_data_copy(this%l_N_R, this%l_N_C)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r overlap_data_copy", size(overlap_data_copy)*COMPLEX_SIZE) - data_copy = data - overlap_data_copy = overlap_data - - lrwork = -1 - lcwork = -1 - liwork = -1 - allocate(rwork(1)) - allocate(cwork(1)) - allocate(iwork(1)) - call pzhegvx(1, 'V', 'A', 'U', this%N_R, & - data_copy, 1, 1, this%desc, & - overlap_data_copy, 1, 1, overlap_ScaLAPACK_obj%desc, & - 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & - orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, cwork, lcwork, & - rwork, lrwork, iwork, liwork, ifail, icluster, gap, info) - lrwork=rwork(1)*4 - lcwork=cwork(1) - liwork=iwork(1) - deallocate(rwork) - deallocate(cwork) - deallocate(iwork) - allocate(rwork(lrwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r rwork", size(rwork)*REAL_SIZE) - allocate(cwork(lcwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r cwork", size(cwork)*COMPLEX_SIZE) - allocate(iwork(liwork)) - call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r iwork", size(iwork)*INTEGER_SIZE) - - call pzhegvx(1, 'V', 'A', 'U', this%N_R, & - data_copy, 1, 1, this%desc, & - overlap_data_copy, 1, 1, overlap_ScaLAPACK_obj%desc, & - 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & - orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, cwork, lcwork, & - rwork, lrwork, iwork, liwork, ifail, icluster, gap, info) - - if (info .ne. 0) then - call print("ScaLAPACK_diagonlise_gen_c got info " // info, PRINT_ALWAYS) - if (mod(info,2) .ne. 0) then - call print(" eigenvectors failed to converge", PRINT_ALWAYS) - else if (mod(info/2,2) .ne. 0) then - call print(" eigenvectors failed to orthogonalize", PRINT_ALWAYS) - do i=1, size(icluster), 2 - if (icluster(i) /= 0) then - call print (" eval cluster " // icluster(i) // " " // icluster(i+1) // & - "("// (icluster(i+1)-icluster(i)+1) // ")", PRINT_ALWAYS) - else - exit - endif - end do - do i=1, this%N_R - call print(" eigenvalue " // i // " " // evals(i), PRINT_ANALYSIS) - end do - else if (mod(info/4,2) .ne. 0) then - call print(" not enough space for all eigenvectors in range", PRINT_ALWAYS) - else if (mod(info/8,2) .ne. 0) then - call print(" failed to compute eigenvalues", PRINT_ALWAYS) - else if (mod(info/16,2) .ne. 0) then - call print(" S was not positive definite "//ifail(1), PRINT_ALWAYS) - endif - endif - - deallocate (icluster, ifail, gap) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r iwork", size(iwork)*INTEGER_SIZE) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r rwork", size(rwork)*REAL_SIZE) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r cwork", size(cwork)*COMPLEX_SIZE) - deallocate (iwork, rwork, cwork) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r data_copy", size(data_copy)*COMPLEX_SIZE) - call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r overlap_data_copy", size(overlap_data_copy)*COMPLEX_SIZE) - deallocate (data_copy, overlap_data_copy) - - if (M /= this%N_R .or. NZ /= this%N_R) then ! bad enough error to report - RAISE_ERROR("ScaLAPACK_diagonalise_r: Failed to diagonalise info="//info, error) - endif -#endif - -end subroutine ScaLAPACK_diagonalise_gen_c - -subroutine ScaLAPACK_add_identity_r(this, data) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - real(dp), intent(inout) :: data(:,:) - -#ifdef SCALAPACK - integer g_i - integer l_i, l_j, p_i, p_j - - - do g_i=1, this%N_R - call coords_global_to_local(this, g_i, g_i, l_i, l_j, p_i, p_j) - if (p_i == this%ScaLAPACK_obj%my_proc_row .and. & - p_j == this%ScaLAPACK_obj%my_proc_col) & - data(l_i, l_j) = data(l_i, l_j) + 1.0_dp - end do -#endif -end subroutine ScaLAPACK_add_identity_r - -subroutine ScaLAPACK_Matrix_d_print(this, data, file, short_output) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - real(dp), intent(in) :: data(:,:) - type(Inoutput), intent(inout), optional :: file - logical, intent(in), optional :: short_output - -#ifdef SCALAPACK - logical :: short_output_opt - integer :: l_i, l_j, g_i, g_j, my_proc - character(len=200), allocatable :: lines(:) - - short_output_opt = optional_default(.false., short_output) - - if (this%l_N_R*this%l_N_c > 0) then - allocate(lines(this%l_N_R*this%l_N_C)) - - my_proc = this%ScaLAPACK_obj%MPI_obj%my_proc - - do l_i=1, this%l_N_R - do l_j=1, this%l_N_C - call coords_local_to_global(this, l_i, l_j, g_i, g_j) - if (short_output_opt) then - lines((l_i-1)*this%l_N_C + l_j) = g_i // " " // g_j // " " // data(l_i,l_j) - else - lines((l_i-1)*this%l_N_C + l_j) = my_proc // & - ": ScaLAPACK local_matrix li,j " // l_i // " " // l_j // " gi,j " // g_i // " " // g_j & - // " " // data(l_i,l_j) - end if - end do - end do - else - allocate(lines(1)) - lines(1) = "" - endif - - call mpi_print(this%ScaLAPACK_obj%mpi_obj, lines, file) - - deallocate(lines) -#endif -end subroutine ScaLAPACK_Matrix_d_print - -subroutine ScaLAPACK_Matrix_z_print(this, data, file, short_output) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - complex(dp), intent(in) :: data(:,:) - type(Inoutput), intent(inout), optional :: file - logical, intent(in), optional :: short_output - -#ifdef SCALAPACK - logical :: short_output_opt - integer :: l_i, l_j, g_i, g_j, my_proc - character(len=200), allocatable :: lines(:) - - short_output_opt = optional_default(.false., short_output) - - if (this%l_N_R*this%l_N_C > 0) then - allocate(lines(this%l_N_R*this%l_N_C)) - - my_proc = this%ScaLAPACK_obj%MPI_obj%my_proc - - do l_i=1, this%l_N_R - do l_j=1, this%l_N_C - call coords_local_to_global(this, l_i, l_j, g_i, g_j) - if (short_output_opt) then - lines((l_i-1)*this%l_N_C + l_j) = g_i // " " // g_j // " " // data(l_i,l_j) - else - lines((l_i-1)*this%l_N_C + l_j) = my_proc // & - ": ScaLAPACK local_matrix li,j " // l_i // " " // l_j // " gi,j " // g_i // " " // g_j & - // " " // data(l_i,l_j) - end if - end do - end do - else - allocate(lines(1)) - lines(1) = "" - endif - - call mpi_print(this%ScaLAPACK_obj%mpi_obj, lines) - - deallocate(lines) -#endif -end subroutine ScaLAPACK_Matrix_z_print - -subroutine ScaLAPACK_matrix_product_sub_ddd(c_scalapack, c_data, a_scalapack, a_data, b_scalapack, b_data, & - a_transpose, b_transpose, a_conjugate, b_conjugate) - type(Matrix_ScaLAPACK_Info), intent(in) :: c_scalapack - real(dp), intent(inout) :: c_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack - real(dp), intent(in) :: a_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: b_scalapack - real(dp), intent(in) :: b_data(:,:) - logical, intent(in), optional :: a_transpose, b_transpose, a_conjugate, b_conjugate - -#ifdef SCALAPACK - - logical a_transp, b_transp, a_conjg, b_conjg - character a_op, b_op - - a_transp = .false. - b_transp = .false. - a_conjg = .false. - b_conjg = .false. - if (present(a_transpose)) a_transp = a_transpose - if (present(b_transpose)) b_transp = b_transpose - if (present(a_conjugate)) a_conjg = a_conjugate - if (present(b_conjugate)) b_conjg = b_conjugate - - if (a_transp .or. a_conjg) then - a_op = 'T' - else - a_op = 'N' - endif - if (b_transp .or. b_conjg) then - b_op = 'T' - else - b_op = 'N' - endif - - call pdgemm(a_op, b_op, c_scalapack%N_R, c_scalapack%N_C, a_scalapack%N_C, & - 1.0_dp, a_data, 1, 1, a_scalapack%desc, b_data, 1, 1, b_scalapack%desc, & - 0.0_dp, c_data, 1, 1, c_scalapack%desc) - -#endif - -end subroutine ScaLAPACK_matrix_product_sub_ddd - -subroutine ScaLAPACK_matrix_product_sub_zzz(c_scalapack, c_data, a_scalapack, a_data, b_scalapack, b_data, & - a_transpose, b_transpose, a_conjugate, b_conjugate) - type(Matrix_ScaLAPACK_Info), intent(in) :: c_scalapack - complex(dp), intent(inout) :: c_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack - complex(dp), intent(in) :: a_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: b_scalapack - complex(dp), intent(in) :: b_data(:,:) - logical, intent(in), optional :: a_transpose, b_transpose, a_conjugate, b_conjugate - -#ifdef SCALAPACK - logical a_transp, b_transp, a_conjg, b_conjg - character a_op, b_op - - a_transp = .false. - b_transp = .false. - a_conjg = .false. - b_conjg = .false. - if (present(a_transpose)) a_transp = a_transpose - if (present(b_transpose)) b_transp = b_transpose - if (present(a_conjugate)) a_conjg = a_conjugate - if (present(b_conjugate)) b_conjg = b_conjugate - - if (a_transp .and. a_conjg) call system_abort("ScaLAPACK_matrix_product_sub_zzz called with a_transp and a_conjg") - if (b_transp .and. b_conjg) call system_abort("ScaLAPACK_matrix_product_sub_zzz called with b_transp and b_conjg") - - if (a_transp) then - a_op = 'T' - else if (a_conjg) then - a_op = 'C' - else - a_op = 'N' - endif - if (b_transp) then - b_op = 'T' - else if (b_conjg) then - b_op = 'C' - else - b_op = 'N' - endif - - call pzgemm(a_op, b_op, c_scalapack%N_R, c_scalapack%N_C, a_scalapack%N_C, & - cmplx(1.0_dp,0.0_dp,dp), a_data, 1, 1, a_scalapack%desc, b_data, 1, 1, b_scalapack%desc, & - cmplx(0.0_dp,0.0_dp,dp), c_data, 1, 1, c_scalapack%desc) -#endif - -end subroutine ScaLAPACK_matrix_product_sub_zzz - -subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_ddd(this_scalapack, this_data, a_scalapack, a_data, diag) - type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack - real(dp), intent(out) :: this_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack - real(dp), intent(in) :: a_data(:,:) - real(dp), intent(in) :: diag(:) - -#ifdef SCALAPACK - integer l_i, l_j, g_i, g_j - - do l_i=1, this_scalapack%l_N_R - do l_j=1, this_scalapack%l_N_C - call coords_local_to_global(this_scalapack, l_i, l_j, g_i, g_j) - this_data(l_i,l_j) = a_data(l_i,l_j) * diag(g_j) - end do - end do -#else - this_data = 0.0_dp -#endif -end subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_ddd - -subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzd(this_scalapack, this_data, a_scalapack, a_data, diag) - type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack - complex(dp), intent(out) :: this_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack - complex(dp), intent(in) :: a_data(:,:) - real(dp), intent(in) :: diag(:) - -#ifdef SCALAPACK - integer l_i, l_j, g_i, g_j - - do l_i=1, this_scalapack%l_N_R - do l_j=1, this_scalapack%l_N_C - call coords_local_to_global(this_scalapack, l_i, l_j, g_i, g_j) - this_data(l_i,l_j) = a_data(l_i,l_j) * diag(g_j) - end do - end do -#else - this_data = 0.0_dp -#endif -end subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzd - -subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzz(this_scalapack, this_data, a_scalapack, a_data, diag) - type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack - complex(dp), intent(out) :: this_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack - complex(dp), intent(in) :: a_data(:,:) - complex(dp), intent(in) :: diag(:) - -#ifdef SCALAPACK - integer l_i, l_j, g_i, g_j - - do l_i=1, this_scalapack%l_N_R - do l_j=1, this_scalapack%l_N_C - call coords_local_to_global(this_scalapack, l_i, l_j, g_i, g_j) - this_data(l_i,l_j) = a_data(l_i,l_j) * diag(g_j) - end do - end do -#else - this_data = 0.0_dp -#endif -end subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzz - -function ScaLAPACK_Re_diagZ(this_scalapack, this_data) - type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack - complex(dp), intent(in) :: this_data(:,:) - real(dp) :: ScaLAPACK_Re_diagZ(this_scalapack%N_R) - - integer :: g_i, l_i, l_j, p_i, p_j - ScaLAPACK_Re_diagZ = 0.0_dp - -#ifdef SCALAPACK - do g_i=1, this_scalapack%N_R - call coords_global_to_local(this_scalapack, g_i, g_i, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_Re_diagZ(g_i) = real(this_data(l_i, l_j)) - end do -#endif - -end function ScaLAPACK_Re_diagZ - -function ScaLAPACK_Re_diagD(this_scalapack, this_data) - type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack - real(dp), intent(in) :: this_data(:,:) - real(dp) :: ScaLAPACK_Re_diagD(this_scalapack%N_R) - - integer :: g_i, l_i, l_j, p_i, p_j - - ScaLAPACK_Re_diagD = 0.0_dp - -#ifdef SCALAPACK - do g_i=1, this_scalapack%N_R - call coords_global_to_local(this_scalapack, g_i, g_i, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_Re_diagD(g_i) = this_data(l_i, l_j) - end do -#endif - -end function ScaLAPACK_Re_diagD - -function ScaLAPACK_diag_spinorZ(this_scalapack, this_data) - type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack - complex(dp), intent(in) :: this_data(:,:) - complex(dp) :: ScaLAPACK_diag_spinorZ(2,2,this_scalapack%N_R/2) - - integer :: g_i, l_i, l_j, p_i, p_j - ScaLAPACK_diag_spinorZ = 0.0_dp - -#ifdef SCALAPACK - do g_i=1, this_scalapack%N_R,2 - call coords_global_to_local(this_scalapack, g_i, g_i, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_diag_spinorZ(1,1,(g_i-1)/2+1) = this_data(l_i, l_j) - call coords_global_to_local(this_scalapack, g_i+1, g_i, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_diag_spinorZ(2,1,(g_i-1)/2+1) = this_data(l_i, l_j) - call coords_global_to_local(this_scalapack, g_i, g_i+1, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_diag_spinorZ(1,2,(g_i-1)/2+1) = this_data(l_i, l_j) - call coords_global_to_local(this_scalapack, g_i+1, g_i+1, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_diag_spinorZ(2,2,(g_i-1)/2+1) = this_data(l_i, l_j) - end do -#endif - -end function ScaLAPACK_diag_spinorZ - -function ScaLAPACK_diag_spinorD(this_scalapack, this_data) - type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack - real(dp), intent(in) :: this_data(:,:) - complex(dp) :: ScaLAPACK_diag_spinorD(2,2,this_scalapack%N_R/2) - - integer :: g_i, l_i, l_j, p_i, p_j - - ScaLAPACK_diag_spinorD = 0.0_dp - -#ifdef SCALAPACK - do g_i=1, this_scalapack%N_R, 2 - call coords_global_to_local(this_scalapack, g_i, g_i, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_diag_spinorD(1,1,(g_i-1)/2+1) = this_data(l_i, l_j) - call coords_global_to_local(this_scalapack, g_i+1, g_i, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_diag_spinorD(2,1,(g_i-1)/2+1) = this_data(l_i, l_j) - call coords_global_to_local(this_scalapack, g_i, g_i+1, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_diag_spinorD(1,2,(g_i-1)/2+1) = this_data(l_i, l_j) - call coords_global_to_local(this_scalapack, g_i+1, g_i+1, l_i, l_j, p_i, p_j) - if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & - p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & - ScaLAPACK_diag_spinorD(2,2,(g_i-1)/2+1) = this_data(l_i, l_j) - end do -#endif - -end function ScaLAPACK_diag_spinorD - -subroutine ScaLAPACK_pdgeqrf_wrapper(this, data, tau, work) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - real(dp), intent(inout), dimension(:,:) :: data - real(dp), intent(out), dimension(:), allocatable :: tau - real(dp), intent(out), dimension(:), allocatable :: work - - integer :: m, n, k, lwork, info - -#ifdef SCALAPACK - m = this%N_R - n = this%N_C - k = min(m, n) - - call reallocate(tau, k) - call reallocate(work, 1) - call pdgeqrf(m, n, data, 1, 1, this%desc, tau, work, -1, info) - lwork = work(1) - call reallocate(work, lwork) - call pdgeqrf(m, n, data, 1, 1, this%desc, tau, work, lwork, info) -#endif -end subroutine ScaLAPACK_pdgeqrf_wrapper - -subroutine ScaLAPACK_pdormqr_wrapper(A_info, A_data, C_info, C_data, tau, work) - type(Matrix_ScaLAPACK_Info), intent(in) :: A_info, C_info - real(dp), intent(inout), dimension(:,:) :: A_data, C_data - real(dp), intent(inout), dimension(:), allocatable :: tau - real(dp), intent(inout), dimension(:), allocatable :: work - - integer :: m, n, k, lwork, info - -#ifdef SCALAPACK - m = C_info%N_R - n = C_info%N_C - k = size(tau) - - call reallocate(work, 1) - call pdormqr('L', 'T', m, n, k, A_data, 1, 1, A_info%desc, & - tau, C_data, 1, 1, C_info%desc, work, -1, info) - lwork = work(1) - call reallocate(work, lwork) - call pdormqr('L', 'T', m, n, k, A_data, 1, 1, A_info%desc, & - tau, C_data, 1, 1, C_info%desc, work, lwork, info) -#endif -end subroutine ScaLAPACK_pdormqr_wrapper - -subroutine ScaLAPACK_pdtrtrs_wrapper(A_info, A_data, B_info, B_data, cheat_nb_A) - type(Matrix_ScaLAPACK_Info), intent(inout) :: A_info, B_info - real(dp), intent(inout), dimension(:,:) :: A_data ! distributed triangular matrix - real(dp), intent(inout), dimension(:,:) :: B_data ! - logical, intent(in) :: cheat_nb_A - - integer, parameter :: mb_ = 5, nb_ = 6 - integer :: n, nrhs, info, nb - -#ifdef SCALAPACK - n = min(A_info%N_R, A_info%N_C) - nrhs = B_info%N_C - - if (cheat_nb_A) then - nb = A_info%desc(nb_) - A_info%desc(nb_) = A_info%desc(mb_) - end if - - ! A(lda,n+), B(ldb,nrhs+) - call pdtrtrs('U', 'N', 'N', n, nrhs, A_data, 1, 1, A_info%desc, & - B_data, 1, 1, B_info%desc, info) - - if (cheat_nb_A) then - A_info%desc(nb_) = nb - end if - -#endif -end subroutine ScaLAPACK_pdtrtrs_wrapper - -subroutine ScaLAPACK_pdgemr2d_wrapper(A_info, A_data, B_info, B_data, glob_cntxt, m, n, ia, ja, ib, jb) - ! Copy general distributed submatrix A_data(ia:ia+m, ja:ja+n) to B_data(ib:ib+m, jb:jb+n) - type(Matrix_ScaLAPACK_Info), intent(in) :: A_info, B_info - real(dp), intent(in), dimension(:,:) :: A_data ! input distributed matrix - real(dp), intent(inout), dimension(:,:) :: B_data ! target distributed matrix - integer :: glob_cntxt ! Context spanning both A and B - integer :: m, n ! size of submatrix - integer, optional :: ia, ja ! start coords in A; defaults to (1, 1) - integer, optional :: ib, jb ! start coords in B; defaults to (1, 1) - - integer :: my_ia, my_ja, my_ib, my_jb - -#ifdef SCALAPACK - my_ia = optional_default(1, ia) - my_ja = optional_default(1, ja) - my_ib = optional_default(1, ib) - my_jb = optional_default(1, jb) - - call pdgemr2d(m, n, A_data, my_ia, my_ja, A_info%desc, & - B_data, my_ib, my_jb, B_info%desc, glob_cntxt) - -#endif -end subroutine ScaLAPACK_pdgemr2d_wrapper - -subroutine ScaLAPACK_pdtrmr2d_wrapper(uplo, diag, A_info, A_data, B_info, B_data, glob_cntxt, m, n, ia, ja, ib, jb) - ! Copy trapezoidal distributed submatrix A_data(ia:ia+m, ja:ja+n) to B_data(ib:ib+m, jb:jb+n) - character(len=1), intent(in) :: uplo, diag ! copy upper/lower triangle; copy diag - type(Matrix_ScaLAPACK_Info), intent(in) :: A_info, B_info - real(dp), intent(in), dimension(:,:) :: A_data ! input distributed matrix - real(dp), intent(inout), dimension(:,:) :: B_data ! target distributed matrix - - integer :: glob_cntxt ! Context spanning both A and B - integer :: m, n ! size of submatrix - integer, optional :: ia, ja ! start coords in A; defaults to (1, 1) - integer, optional :: ib, jb ! start coords in B; defaults to (1, 1) - - integer :: my_ia, my_ja, my_ib, my_jb - -#ifdef SCALAPACK - my_ia = optional_default(1, ia) - my_ja = optional_default(1, ja) - my_ib = optional_default(1, ib) - my_jb = optional_default(1, jb) - - call pdtrmr2d(uplo, diag, m, n, A_data, my_ia, my_ja, A_info%desc, & - B_data, my_ib, my_jb, B_info%desc, glob_cntxt) - -#endif -end subroutine ScaLAPACK_pdtrmr2d_wrapper - -subroutine ScaLAPACK_matrix_QR_solve(A_info, A_data, B_info, B_data, cheat_nb_A) - type(Matrix_ScaLAPACK_Info), intent(inout) :: A_info, B_info - real(dp), intent(inout), dimension(:,:) :: A_data, B_data - logical, intent(in) :: cheat_nb_A - - real(dp), dimension(:), allocatable :: tau, work - - call ScaLAPACK_pdgeqrf_wrapper(A_info, A_data, tau, work) - call ScaLAPACK_pdormqr_wrapper(A_info, A_data, B_info, B_data, tau, work) - call ScaLAPACK_pdtrtrs_wrapper(A_info, A_data, B_info, B_data, cheat_nb_A) -end subroutine ScaLAPACK_matrix_QR_solve - -subroutine ScaLAPACK_to_array1d(A_info, A_data, array) - type(Matrix_ScaLAPACK_Info), intent(in) :: A_info - real(dp), intent(in), dimension(:,:) :: A_data - real(dp), intent(out), dimension(:) :: array - - integer :: info - integer :: nrows, ncols - integer, dimension(9) :: desc - -#ifdef SCALAPACK - nrows = min(A_info%N_R, size(array, 1)) - ncols = 1 - array(nrows+1:) = 0.0_dp - call descinit(desc, nrows, ncols, nrows, ncols, 0, 0, & - A_info%ScaLAPACK_obj%blacs_context, size(array, 1), info) - call pdgeadd("N", nrows, ncols, 1.0_dp, A_data, 1, 1, A_info%desc, & - 0.0_dp, array, 1, 1, desc) -#endif -end subroutine ScaLAPACK_to_array1d - -subroutine ScaLAPACK_to_array2d(A_info, A_data, array) - type(Matrix_ScaLAPACK_Info), intent(in) :: A_info - real(dp), intent(in), dimension(:,:) :: A_data - real(dp), intent(out), dimension(:,:) :: array - - integer :: info - integer, dimension(9) :: desc - -#ifdef SCALAPACK - call descinit(desc, A_info%N_R, A_info%N_C, A_info%N_R, A_info%N_C, 0, 0, & - A_info%ScaLAPACK_obj%blacs_context, A_info%N_R, info) - call pdgeadd("N", A_info%N_R, A_info%N_C, 1.0_dp, A_data, 1, 1, A_info%desc, & - 0.0_dp, array, 1, 1, desc) -#endif -end subroutine ScaLAPACK_to_array2d - -! returns 64bit minimal work array length for pdgeqrf from 32bit sources -! adapted from documentation of pdgeqrf -function get_lwork_pdgeqrf_i32o64(m, n, ia, ja, mb_a, nb_a, & - myrow, mycol, rsrc_a, csrc_a, nprow, npcol) result(lwork) - integer, intent(in) :: m, n, ia, ja, mb_a, nb_a - integer, intent(in) :: myrow, mycol, rsrc_a, csrc_a, nprow, npcol - integer(idp) :: lwork - - integer :: iarow, iacol, iroff, icoff - integer(idp) :: mp0, nq0, nb64 - - lwork = 0 - -#ifdef SCALAPACK - iroff = mod(ia-1, mb_a) - icoff = mod(ja-1, nb_a) - iarow = indxg2p(ia, mb_a, myrow, rsrc_a, nprow) - iacol = indxg2p(ja, nb_a, mycol, csrc_a, npcol) - mp0 = numroc(m+iroff, mb_a, myrow, iarow, nprow) - nq0 = numroc(n+icoff, nb_a, mycol, iacol, npcol) - - nb64 = int(nb_a, idp) - lwork = nb64 * (mp0 + nq0 + nb64) -#endif -end function get_lwork_pdgeqrf_i32o64 - -function ScaLAPACK_get_lwork_pdgeqrf(this, m, n, mb_a, nb_a) result(lwork) - type(ScaLAPACK), intent(in) :: this - integer, intent(in) :: m, n, mb_a, nb_a - integer(idp) :: lwork - - integer, parameter :: ia = 1, ja = 1, rsrc_a = 0, csrc_a = 0 - - lwork = 0 - -#ifdef SCALAPACK - lwork = get_lwork_pdgeqrf(m, n, ia, ja, mb_a, nb_a, & - this%my_proc_row, this%my_proc_col, rsrc_a, csrc_a, & - this%n_proc_rows, this%n_proc_cols) -#endif -end function ScaLAPACK_get_lwork_pdgeqrf - -function ScaLAPACK_matrix_get_lwork_pdgeqrf(this) result(lwork) - type(Matrix_ScaLAPACK_Info), intent(in) :: this - integer(idp) :: lwork - - lwork = 0 - -#ifdef SCALAPACK - lwork = get_lwork_pdgeqrf(this%ScaLAPACK_obj, this%N_R, this%N_C, this%NB_R, this%NB_C) -#endif -end function ScaLAPACK_matrix_get_lwork_pdgeqrf - -! returns 64bit minimal work array length for pdormqr from 32bit sources -! adapted from documentation of pdormqr -function get_lwork_pdormqr_i32o64(side, m, n, ia, ja, mb_a, nb_a, ic, jc, & - mb_c, nb_c, myrow, mycol, rsrc_a, csrc_a, rsrc_c, csrc_c, nprow, npcol) result(lwork) - character :: side - integer, intent(in) :: m, n, ia, ja, mb_a, nb_a - integer, intent(in) :: ic, jc, mb_c, nb_c - integer, intent(in) :: rsrc_a, csrc_a, rsrc_c, csrc_c - integer, intent(in) :: myrow, mycol, nprow, npcol - integer(idp) :: lwork - - integer :: lcm, lcmq - integer :: iarow, iroffa, icoffa, iroffc, icoffc, icrow, iccol - integer(idp) :: npa0, mpc0, nqc0, nr, nb64, lwork1, lwork2 - - lwork = 0 - -#ifdef SCALAPACK - iroffc = mod(ic-1, mb_c) - icoffc = mod(jc-1, nb_c) - icrow = indxg2p(ic, mb_c, myrow, rsrc_c, nprow) - iccol = indxg2p(jc, nb_c, mycol, csrc_c, npcol) - mpc0 = numroc(m+iroffc, mb_c, myrow, icrow, nprow) - nqc0 = numroc(n+icoffc, nb_c, mycol, iccol, npcol) - - nb64 = int(nb_a, idp) - lwork1 = (nb64 * (nb64 - 1)) / 2 - if (side == 'L') then - lwork2 = (nqc0 + mpc0) * nb64 - else if (side == 'R') then - iroffa = mod(ia-1, mb_a) - icoffa = mod(ja-1, nb_a) - iarow = indxg2p(ia, mb_a, myrow, rsrc_a, nprow) - npa0 = numroc(n+iroffa, mb_a, myrow, iarow, nprow) - - lcm = ilcm(nprow, npcol) - lcmq = lcm / npcol - nr = numroc(n+icoffc, nb_a, 0, 0, npcol) - nr = numroc(int(nr, isp), nb_a, 0, 0, lcmq) - nr = max(npa0 + nr, mpc0) - lwork2 = (nqc0 + nr) * nb64 - end if - lwork = max(lwork1, lwork2) + nb64 * nb64 -#endif -end function get_lwork_pdormqr_i32o64 - -function ScaLAPACK_get_lwork_pdormqr(this, side, m, n, mb_a, nb_a, mb_c, nb_c) result(lwork) - type(ScaLAPACK), intent(in) :: this - character :: side - integer, intent(in) :: m, n, mb_a, nb_a, mb_c, nb_c - integer(idp) :: lwork - - integer, parameter :: ia = 1, ja = 1, rsrc_a = 0, csrc_a = 0 - integer, parameter :: ic = 1, jc = 1, rsrc_c = 0, csrc_c = 0 - - lwork = 0 - -#ifdef SCALAPACK - lwork = get_lwork_pdormqr(side, m, n, ia, ja, mb_a, nb_a, ic, jc, mb_c, nb_c, & - this%my_proc_row, this%my_proc_col, rsrc_a, csrc_a, rsrc_c, csrc_c, & - this%n_proc_rows, this%n_proc_cols) -#endif -end function ScaLAPACK_get_lwork_pdormqr - -function ScaLAPACK_matrix_get_lwork_pdormqr(A_info, C_info, side) result(lwork) - type(Matrix_ScaLAPACK_Info), intent(in) :: A_info, C_info - character :: side - integer(idp) :: lwork - - lwork = 0 - -#ifdef SCALAPACK - lwork = get_lwork_pdormqr(A_info%ScaLAPACK_obj, side, C_info%N_R, & - C_info%N_C, A_info%NB_R, A_info%NB_C, A_info%NB_R, A_info%NB_C) -#endif -end function ScaLAPACK_matrix_get_lwork_pdormqr - -end module ScaLAPACK_module diff --git a/src/libAtoms/SocketTools.f95 b/src/libAtoms/SocketTools.f95 deleted file mode 100644 index b39b472e53..0000000000 --- a/src/libAtoms/SocketTools.f95 +++ /dev/null @@ -1,326 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -!% Routines to send and receive data via TCP/IP sockets - -module SocketTools_module - - use iso_c_binding - - use error_module - use system_module, only: dp, print, operator(//) - use extendable_str_module, only: Extendable_Str - use atoms_types_module, only: Atoms - use cinoutput_module, only: read, write - - implicit none - - private - - integer, parameter :: MSG_LEN_SIZE = 8 - integer, parameter :: MSG_END_MARKER_SIZE = 5 - character(MSG_END_MARKER_SIZE), parameter :: MSG_END_MARKER = 'done.' - character(6), parameter :: MSG_INT_FORMAT = 'i6' - character(6), parameter :: MSG_FLOAT_FORMAT = 'f25.16' - integer, parameter :: MSG_INT_SIZE = 6, MSG_FLOAT_SIZE = 25 - integer, parameter :: MAX_ATTEMPTS = 5 - - interface - function quip_recv_data(ip, port, client_id, request_code, data, data_len) bind(c) - use iso_c_binding - integer(kind=C_INT) :: quip_recv_data - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: ip - integer(kind=C_INT), intent(in), value :: port, client_id - character(kind=C_CHAR,len=1), intent(in) :: request_code - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: data - integer(kind=C_INT), intent(inout) :: data_len - end function quip_recv_data - - function quip_send_data(ip, port, client_id, request_code, data, data_len) bind(c) - use iso_c_binding - integer(kind=C_INT) :: quip_send_data - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: ip - integer(kind=C_INT), intent(in), value :: port, client_id - character(kind=C_CHAR,len=1), intent(in) :: request_code - character(kind=C_CHAR,len=1), dimension(*), intent(in) :: data - integer(kind=C_INT), intent(in), value :: data_len - end function quip_send_data - end interface - - public :: socket_send_reftraj, socket_recv_reftraj, socket_send_xyz, socket_recv_xyz - -contains - - subroutine socket_send_reftraj(ip, port, client_id, label, n_atoms, energy, force, virial, error) - character(*), intent(in) :: ip - integer, intent(in) :: port, client_id, label, n_atoms - real(dp), intent(in) :: energy, force(:,:), virial(3,3) - integer, optional, intent(out) :: error - - character(len_trim(ip)+1) :: c_ip - integer(kind=C_INT) :: c_port, c_client_id, data_len, status - character(kind=C_CHAR, len=1), dimension(:), pointer :: data - character(1024) :: line - integer i, j, n, attempt - - INIT_ERROR(error) - - c_ip = trim(ip)//C_NULL_CHAR - c_port = port - c_client_id = client_id - - ! space for label, n_atoms, 1 energy, 3*N force components and 6 virial components, separated by N+3 newlines - data_len = 2*MSG_INT_SIZE + MSG_FLOAT_SIZE*(1 + size(force) + 6) + size(force,2)+3 - allocate(data(data_len)) - i = 1 - - ! first line is label - write(line, '('//MSG_INT_FORMAT//')') label - do j=1,len_trim(line) - data(i) = line(j:j) - i = i + 1 - end do - data(i) = C_NEW_LINE - i = i + 1 - - ! second line is n_atoms - write(line, '('//MSG_INT_FORMAT//')') n_atoms - do j=1,len_trim(line) - data(i) = line(j:j) - i = i + 1 - end do - data(i) = C_NEW_LINE - i = i + 1 - - ! third line is energy - write(line, '('//MSG_FLOAT_FORMAT//')') energy - do j=1,len_trim(line) - data(i) = line(j:j) - i = i + 1 - end do - data(i) = C_NEW_LINE - i = i + 1 - - ! next are the 3*N forces, three components per line - do n = 1, size(force, 2) - write(line,'(3'//MSG_FLOAT_FORMAT//')') force(:, n) - do j=1,len_trim(line) - data(i) = line(j:j) - i = i + 1 - end do - data(i) = C_NEW_LINE - i = i + 1 - end do - - ! finally the virial, as six components in order xx yy zz xy yz xz (NB: not Voigt order) - write(line, '(6'//MSG_FLOAT_FORMAT//')') & - virial(1,1), virial(2,2), virial(3,3), virial(1,2), virial(2,3), virial(1,3) - do j=1,len_trim(line) - data(i) = line(j:j) - i = i + 1 - end do - ! no newline at end of data - - !write(*,*) 'after packing, i=', i, 'data_len=', data_len - !write (*,*) 'data=' - !write (*,*) data - - do attempt = 1, MAX_ATTEMPTS - ! Send data with request code 'R' (results) - status = quip_send_data(c_ip, c_port, c_client_id, 'R', data, data_len) - if (status == 0) exit - call fusleep(100000) ! wait 0.1 seconds - end do - if (status /= 0) then - RAISE_ERROR('fatal error sending data over socket', error) - end if - - deallocate(data) - - end subroutine socket_send_reftraj - - - subroutine socket_recv_reftraj(ip, port, client_id, buff_size, label, n_atoms, lattice, frac_pos, error) - character(*), intent(in) :: ip - integer, intent(in) :: port, client_id - integer, intent(in) :: buff_size - integer, intent(out) :: label, n_atoms - real(dp), intent(out), dimension(:,:) :: lattice, frac_pos - integer, optional, intent(out) :: error - - character(len_trim(ip)+1) :: c_ip - integer(kind=C_INT) :: c_port, c_client_id, data_len, status - character(kind=C_CHAR, len=1), dimension(:), pointer :: data - character(1024) :: line - integer i, j, lineno, attempt - - INIT_ERROR(error) - - c_ip = trim(ip)//C_NULL_CHAR - c_port = port - c_client_id = client_id - - data_len = buff_size - allocate(data(data_len)) - - do attempt = 1, MAX_ATTEMPTS - ! Receive data with request code 'A' (atoms in REFTRAJ format) - status = quip_recv_data(c_ip, c_port, c_client_id, 'A', data, data_len) - if (status == 0) exit - call fusleep(100000) ! wait 0.1 seconds - end do - if (status /= 0) then - RAISE_ERROR('fatal error receiving data over socket', error) - end if - - i = 1 - lineno = 0 - do while (i < data_len) - line = '' - j = 1 - do while (data(i) /= C_NEW_LINE) - line(j:j) = data(i) - i = i + 1 - j = j + 1 - end do - lineno = lineno + 1 - i = i + 1 ! skip the newline character - - if (lineno == 1) then - read (line,*) label - else if (lineno == 2) then - read (line,*) n_atoms - if (size(frac_pos, 2) < n_atoms) then - RAISE_ERROR('insufficient space to store received data', error) - end if - else if (lineno > 2 .and. lineno <= 5) then - read (line, *) lattice(lineno-2, :) - else if (lineno > 5 .and. lineno <= 5+n_atoms) then - read (line, *) frac_pos(1, lineno-5), frac_pos(2, lineno-5), frac_pos(3, lineno-5) - else - RAISE_ERROR('unexpected line '//trim(line), error) - end if - end do - deallocate(data) - - end subroutine socket_recv_reftraj - - - subroutine socket_send_xyz(ip, port, client_id, at, error, properties) - character(*), intent(in) :: ip - integer, intent(in) :: port, client_id - type(Atoms), intent(inout) :: at - integer, optional, intent(out) :: error - character(len=*), intent(in), optional :: properties - - character(len_trim(ip)+1) :: c_ip - integer(kind=C_INT) :: c_port, c_client_id, data_len, status - character(kind=C_CHAR, len=1), dimension(:), pointer :: data - integer i, j, n, attempt - type(Extendable_Str) :: estr - - INIT_ERROR(error) - - c_ip = trim(ip)//C_NULL_CHAR - c_port = port - c_client_id = client_id - - call write(at, estr=estr, properties=properties) ! write Atoms to extendable str - ! convert estr to C string - data_len = estr%len - allocate(data(data_len)) - do i=1, data_len - data(i) = estr%s(i) - end do - - do attempt = 1, MAX_ATTEMPTS - call print('socket_send_xyz() calling quip_send_data attempt='//attempt) - ! Send data with request code 'Y' (XYZ results) - status = quip_send_data(c_ip, c_port, c_client_id, 'Y', data, data_len) - if (status == 0) exit - call fusleep(100000) ! wait 0.1 seconds - end do - if (status /= 0) then - RAISE_ERROR('fatal error sending data over socket', error) - end if - - deallocate(data) - - end subroutine socket_send_xyz - - - subroutine socket_recv_xyz(ip, port, client_id, buff_size, at, error) - character(*), intent(in) :: ip - integer, intent(in) :: port, client_id - integer, intent(in) :: buff_size - type(Atoms), intent(out) :: at - integer, optional, intent(out) :: error - - character(len_trim(ip)+1) :: c_ip - integer(kind=C_INT) :: c_port, c_client_id, data_len, status - character(kind=C_CHAR, len=1), dimension(:), pointer :: data - character(len=buff_size) :: fdata - integer i, attempt - - INIT_ERROR(error) - - c_ip = trim(ip)//C_NULL_CHAR - c_port = port - c_client_id = client_id - - data_len = buff_size - allocate(data(data_len)) - - do attempt = 1, MAX_ATTEMPTS - call print('socket_recv_xyz() calling quip_recv_data attempt='//attempt) - ! Receive data with request code 'X' (receive atoms in XYZ format) - status = quip_recv_data(c_ip, c_port, c_client_id, 'X', data, data_len) - if (status == 0) exit - call fusleep(100000) ! wait 0.1 seconds - end do - if (status /= 0) then - RAISE_ERROR('fatal error receiving data over socket', error) - end if - ! convert from C to Fortran string - do i=1, data_len - fdata(i:i) = data(i) - end do - !call print('recieved data <'//fdata//'>') - ! read from fdata string into Atoms in XYZ format - call read(at, str=fdata, error=error) - PASS_ERROR(error) - deallocate(data) - - end subroutine socket_recv_xyz - - -end module SocketTools_Module diff --git a/src/libAtoms/Sparse.f95 b/src/libAtoms/Sparse.f95 deleted file mode 100644 index 445c7f5186..0000000000 --- a/src/libAtoms/Sparse.f95 +++ /dev/null @@ -1,724 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Sparse module -!X -!X Sparse matrix representation and algebra -!X -!X -!X Table: -!X int : [................] column indices -!X real: [................] nonzero elements -!X -!X rows: integer array that holds the starting indices of each row in -!X the table -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module sparse_module - use system_module - use linearalgebra_module - use table_module -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif - - implicit none -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif - private - SAVE - - public :: sparse, print, print_full, operator(.mult.), assignment(=), sparse_init, sparse_finalise - - type Sparse - type(table)::table ! values - integer,allocatable::rows(:) ! indexes - integer::Nrows ! number of rows - integer::Ncols ! number of colummns - end type Sparse - - real(dp), parameter :: SPARSITY_GUESS = 0.01_dp ! A guess at the sparsity of the input matrices - ! to sparse_assign_matrix - - interface assignment(=) - module procedure sparse_assign_matrix,matrix_assign_sparse,& - sparse_assign_sparse - end interface assignment(=) - - interface operator(.mult.) - module procedure sparse_mult_vector, vector_mult_sparse, sparse_mult_sparse - end interface - - interface print - module procedure sparse_print - end interface print - - interface print_full - module procedure sparse_print_full - end interface print_full - -contains - - ! just init - subroutine sparse_init(this,Nrows,Ncols,Nmax) - type(sparse):: this - integer, optional::Nmax ! maximum number of nonzero elements - integer::Nrows,Ncols ! size of the matrix - - call allocate(this%table,1,1,0,0,Nmax) - call reallocate(this%rows,Nrows+1) - this%Nrows = Nrows - this%Ncols = Ncols - this%rows = 1 - - end subroutine sparse_init - - subroutine sparse_finalise(this) - type(sparse)::this - call finalise(this%table) - if(allocated(this%rows))deallocate(this%rows) - end subroutine sparse_finalise - - - !overloading assignment - subroutine sparse_assign_sparse(this,other) - type(sparse),intent(OUT):: this - type(sparse),intent(IN):: other - this%Nrows = other%Nrows - this%Ncols = other%Ncols - this%table = other%table - call reallocate(this%rows,this%Nrows+1) - this%rows = other%rows - end subroutine sparse_assign_sparse - - ! assignment - subroutine sparse_assign_matrix(this,matrix) - type(sparse), intent(out) :: this - real(dp), intent(in) :: matrix(:,:) - integer :: Nmax, i, j - - Nmax = int( SPARSITY_GUESS * real(size(matrix),dp) ) - - call sparse_init(this, size(matrix,1), size(matrix,2), Nmax) - - do i=1,this%Nrows - this%rows(i) = this%table%N+1 - - do j=1,this%Ncols - - if (abs(matrix(i,j)) > NUMERICAL_ZERO ) then - call append(this%table,realpart=(matrix(i,j)),intpart=j) - end if - - end do - - end do - - ! last value in rows() - this%rows(this%Nrows+1) = this%table%N+1 - - if(this%table%N == 0) then ! give warning - call print('sparse_assign_matrix: no nonzero elements!') - end if - - ! now truncate the length - call allocate(this%table) - - end subroutine sparse_assign_matrix - - - subroutine matrix_assign_sparse(matrix,sp) - type(sparse),intent(IN):: sp - real(dp),intent(OUT)::matrix(sp%Nrows,sp%Ncols) - integer::i,j - - call sparse_check(sp,"matrix_assign_sparse") - - matrix=0.0_dp - do i = 1,sp%Nrows - do j = sp%rows(i),sp%rows(i+1)-1 - matrix(i,sp%table%int(1,j)) = sp%table%real(1,j) - end do - end do - end subroutine matrix_assign_sparse - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X X - !X Routines for constructing/reading sparse matrices X - !X X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - ! Return the (i,j)th element of the sparse matrix - ! - function sparse_element(this,i,j) - - type(sparse), intent(in) :: this - integer, intent(in) :: i, j - real(dp) :: sparse_element - integer :: n - - call sparse_check_bounds(this,i,j,'Sparse_Element') - - sparse_element = 0.0_dp - - do n = this%rows(i), this%rows(i+1) - 1 - if (this%table%int(1,n) > j) exit ! The requested element is 0.0 - if (this%table%int(1,n) == j) then ! The requested element is stored - sparse_element = this%table%real(1,n) - exit - end if - end do - - end function sparse_element - - ! - ! Return the number of stored elements - ! - function sparse_stored_elements(this) - - type(sparse), intent(in) :: this - integer :: sparse_stored_elements - - sparse_stored_elements = this%table%N - - end function sparse_stored_elements - - ! - ! Zero all elements of a sparse matrix (keeping storage) - ! - subroutine sparse_zero(this) - - type(sparse), intent(inout) :: this - - this%table%real = 0.0_dp - - - end subroutine sparse_zero - - ! - ! Copy 'val' into the (i,j)th element of the sparse matrix - ! - ! The optional logical 'nocheck', when present and true, supresses the deletion of an element - ! if we set it to zero. This can be used to insert placeholders for future non-zero values, but note - ! that these will be classed as 'non-zero' in sparse_non_zero - ! - subroutine sparse_set_element(this,i,j,val,nocheck) - - type(sparse), intent(inout) :: this - integer, intent(in) :: i,j - real(dp), intent(in) :: val - logical, optional, intent(in) :: nocheck - !local variables - integer :: n, table_pos, intpart, tmp_intpart - logical :: element_written, my_nocheck - real(dp) :: realpart, tmp_realpart - - if (present(nocheck)) then - my_nocheck = nocheck - else - my_nocheck = .false. - end if - - ! If we are setting a value to zero and nocheck is false then call delete_element instead - if (.not.my_nocheck) then - if (abs(val) < NUMERICAL_ZERO) then - call sparse_delete_element(this,i,j) - return - end if - end if - - ! Check the element we are setting is a valid one - call sparse_check_bounds(this,i,j,'Sparse_Set_Element') - - !**** SHOULD WE USE A BINARY SEARCH TO FIND THE CORRECT INSERTION POINT? **** - - ! First find the place in table where the element will be inserted, or where it already exists - table_pos = this%rows(i) - element_written = .false. - do n = this%rows(i), this%rows(i+1) - 1 - - if (this%table%int(1,table_pos) > j) exit ! We've found the insertion point - - if (this%table%int(1,n) == j) then - ! The element already exists, so just write the value - this%table%real(1,n) = val - element_written = .true. - exit - end if - - table_pos = table_pos + 1 - - end do - - ! Now, either the element has been written (so we can return) or the insertion point is in table_pos - if (element_written) return - - ! Append a blank element to 'table', insert the new value and shift the other entries down - call append(this%table,(/0/),(/0.0_dp/)) - intpart = j - realpart = val - do n = table_pos, this%table%N - !Make a temporary copy of the data that is already there - tmp_intpart = this%table%int(1,n) - tmp_realpart = this%table%real(1,n) - !Copy in the new elements - this%table%int(1,n) = intpart - this%table%real(1,n) = realpart - !Make the tmp_ variables the next to be written back to the table - intpart = tmp_intpart - realpart = tmp_realpart - end do - - ! Lastly, all the row pointers for rows i+1 upwards need incrementing - forall(n=i+1:this%Nrows+1) this%rows(n) = this%rows(n) + 1 - - end subroutine sparse_set_element - - ! - ! Search for the (i,j)th element and if it exists delete it (i.e. set it to zero) - ! - subroutine sparse_delete_element(this,i,j) - - type(sparse), intent(inout) :: this - integer, intent(in) :: i,j - integer :: n, table_pos - - call sparse_check_bounds(this,i,j,'Sparse_Delete_Element') - - table_pos = 0 - do n = this%rows(i), this%rows(i+1) - 1 - if (this%table%int(1,n) > j) return ! The element is already 0.0 - if (this%table%int(1,n) == j) then - ! We've found the element to be deleted - table_pos = n - exit - end if - end do - - if (table_pos==0) return !The element didn't exist - - ! Shift all the succeeding table entries back by one - do n = table_pos, this%table%N - 1 - this%table%int(1,n) = this%table%int(1,n+1) - this%table%real(1,n) = this%table%real(1,n+1) - end do - - ! Then delete the last entry - call delete(this%table,this%table%N) - - ! Decrement the row pointers for rows i+1 upwards by one - forall(n=i+1:this%Nrows+1) this%rows(n) = this%rows(n) - 1 - - end subroutine sparse_delete_element - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X X - !X BLAS X - !X X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function sparse_mult_vector(this,vectin) result (vectout) - real(dp),intent(IN)::vectin(:) - type(sparse),intent(IN)::this - real(dp)::vectout(this%Nrows) - integer::i,j -#ifdef _MPI - integer::mpi_size, mpi_rank, PRINT_ALWAYS - real(dp)::vectout_all(this%Nrows) - - vectout_all = 0.0_dp - call get_mpi_size_rank(MPI_COMM_WORLD, mpi_size, mpi_rank) -#endif - - call sparse_check(this, "sparse_mult_vector") - if (this%Ncols .ne. size(vectin)) then - write(line, *) 'sparse_mult_vector: mismatched matrix(',this%Nrows,',',this%Ncols,') and vector(',size(vectin),')!' - call System_Abort(line) - end if - - vectout=0.0_dp - do i=1,this%Nrows -#ifdef _MPI - ! cycle loop if processor rank does not match - if(mod(i, mpi_size) .ne. mpi_rank) cycle -#endif - do j= this%rows(i),this%rows(i+1)-1 - vectout(i)=vectout(i)+this%table%real(1,j)*vectin(this%table%int(1,j)) - end do - end do - -#ifdef _MPI - ! collect mpi results - call MPI_ALLREDUCE(vectout, vectout_all, & - size(vectout), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, PRINT_ALWAYS) - call abort_on_mpi_error(PRINT_ALWAYS, "Sparse .mult. vector: MPI_ALL_REDUCE()") - vectout = vectout_all -#endif - end function sparse_mult_vector - - - function vector_mult_sparse(vectin,this) result(vectout) - real(dp),intent(IN)::vectin(:) - type(sparse),intent(IN)::this - real(dp)::vectout(this%Ncols) - integer::N,i,k,M -#ifdef _MPI - integer::mpi_size, mpi_rank, PRINT_ALWAYS - real(dp)::vectout_all(this%Ncols) - - vectout_all = 0.0_dp - call get_mpi_size_rank(MPI_COMM_WORLD, mpi_size, mpi_rank) -#endif - - N=this%Nrows - M=this%Ncols - - call sparse_check(this, "vector_mult_sparse") - - if (N .NE. size(vectin)) then - call system_abort("sparse_product_vect:'mismatched vector and matrix!") - end if - - - vectout=0.0_dp - do i=1,N -#ifdef _MPI - ! cycle loop if processor rank does not match - if(mod(i, mpi_size) .ne. mpi_rank) cycle -#endif - do k= this%rows(i),this%rows(i+1)-1 - vectout(this%table%int(1,k))=vectout(this%table%int(1,k))+this%table%real(1,k)*vectin(i) - end do - end do -#ifdef _MPI - ! collect mpi results - call MPI_ALLREDUCE(vectout, vectout_all, & - size(vectout), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, PRINT_ALWAYS) - call abort_on_mpi_error(PRINT_ALWAYS, "Sparse .mult. vector: MPI_ALL_REDUCE()") - vectout = vectout_all -#endif - end function vector_mult_sparse - - - ! - ! Tr(sparse*matrix) - ! - function trace_sparse_mult_matrix(this,matrix) result(tr) - type(sparse),intent(IN)::this - real(dp),intent(IN)::matrix(:,:) - real(dp)::tr - integer::i,j - - call sparse_check(this,"sparce_tracemult_matrix") - if(this%Nrows .ne. size(matrix,1)) then - call system_abort("trace_sparse_mult_matrix: size of sparse and matrix mismatch ") - end if - - tr = 0.0_dp - - do i = 1,size(matrix,1) - do j = this%rows(i),this%rows(i+1)-1 - tr = tr +this%table%real(1,j) * matrix(i,this%table%int(1,j)) - end do - end do - - end function trace_sparse_mult_matrix - - ! - ! Sparse_CFCT : (Sparse matrix C) * (diagonal matrix F) * (Transpose of C) - ! - function sparse_cfct(c,f) result(res) - - type(Sparse), intent(in) :: c - real(dp), dimension(:), intent(in) :: f - type(Sparse) :: res - integer :: i,j,k,n - real(dp) :: val - - if (size(f) /= c%Ncols) call System_Abort('Sparse_CFCT: Number of elements in F is not equal to number of rows in C') - - ! Initialise the output matrix - call Sparse_Init(res,c%Nrows,c%Nrows) - - ! Sparse matrix storage stores elements in the same row together, so make the loop over - ! the columns go faster. Also, the matrix is symmetric so only half the working is needed - do i = 1, c%Nrows - - do j = 1, i - 1 ! Just copy the pre-worked out values into the lower triangle - val = sparse_element(res,j,i) - if (abs(val) > NUMERICAL_ZERO) call sparse_set_element(res,i,j,val) - end do - - do j = i, c%Nrows ! Actually work out the upper triangle of values - val = 0.0_dp - do n = c%rows(i), c%rows(i+1)-1 - k = c%table%int(1,n) - val = val + sparse_element(c,i,k) * f(k) * sparse_element(c,j,k) - end do - if (abs(val) > NUMERICAL_ZERO) call sparse_set_element(res,i,j,val) - end do - - end do - - end function sparse_cfct - - function sparse_mult_sparse(a,b) result(res) - - type(sparse), intent(in) :: a,b - type(sparse) :: res - !local variables - integer :: i,j,n - real(dp) :: val - - !Check sizes - if (a%Ncols /= b%Nrows) call System_Abort('Sparse_Mult_Sparse: Argument 1 rows /= argument 2 columns') - - call Sparse_Init(res,a%Nrows,b%Ncols) - - do i = 1, a%Nrows - do j = 1, b%Ncols - val = 0.0_dp - do n = a%rows(i), a%rows(i+1)-1 - val = val + a%table%real(1,n) * sparse_element(b, a%table%int(1,n), j) - end do - if (abs(val) > NUMERICAL_ZERO) call sparse_set_element(res,i,j,val) - end do - end do - - end function sparse_mult_sparse - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X X - !X Printing X - !X X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine sparse_print(this,verbosity,out) - type(sparse),intent(in)::this - integer, optional::verbosity - type(inoutput),intent(inout),optional::out - - call sparse_check(this,"sparse_print") - write(line,'(a,i0,a,i0)')'Sparse matrix: Nrows = ',this%Nrows,' Ncols = ',this%Ncols - call print(line,verbosity, out) - call print('row indices:', verbosity, out) - call print(this%rows, verbosity, out) - call print(' Column Value', verbosity, out) - call print(this%table, verbosity, out) - end subroutine sparse_print - - subroutine sparse_print_full(this,verbosity,out) - - type(sparse), intent(in) :: this - integer, optional :: verbosity - type(inoutput),intent(in), optional :: out - real(dp) :: row(this%Ncols) - integer :: i, j - character(13) :: format - - call sparse_check(this,"sparse_print_full") - if (this%Ncols >= 1e6) & - call system_abort('Sparse_Print_Full: Tried to print a matrix with > 1M columns. Are you crazy?!?') - write(format,'(a,i0,a)')'(',this%Ncols,'f14.5)' - - do j = 1, this%Nrows - row = 0.0_dp - do i = this%rows(j), this%rows(j+1) - 1 - row( this%table%int(1,i) ) = this%table%real(1,i) - end do - write(line,format) row - call Print(line,verbosity,out) - end do - - end subroutine sparse_print_full - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X X - !X Miscellaneous checking routines X - !X X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - ! Check if the element (i,j) is within the bounds of 'this'. caller is the calling routine - ! - subroutine sparse_check_bounds(this,i,j,caller) - - type(Sparse), intent(in) :: this - integer, intent(in) :: i,j - character(*), intent(in) :: caller - - if (i > this%Nrows .or. j > this%Ncols) then - write(line,'(4(a,i0),a)') caller//': Element (',i,',',j,') is out of range (',& - this%Nrows,',',this%Ncols,')' - call System_Abort(line) - end if - - end subroutine sparse_check_bounds - - ! - ! Check the input is a valid sparse matrix. caller is the calling routine. - ! - subroutine sparse_check(this,caller) - - type(sparse), intent(in) :: this - character(*) :: caller - integer :: m - - if (.not. allocated(this%rows)) then - write(line,'(a)')"In "//caller//":" - call Print(line) - call System_Abort("Sparse_check: sparse%rows is unallocated") - end if - - m = size(this%rows) - if( (this%rows(m) /= this%table%N+1) .or. (m /= this%Nrows+1) ) then - write(line,'(a)')"In "//caller//":" - call Print(line) - call System_Abort("Sparse_check: sparse rows and table size mismatch") - end if - - end subroutine sparse_check - - ! - ! Subroutine to test the sparse module is functioning properly - ! NOTE: does not include tests for all features - ! - subroutine sparse_test - type(sparse)::sparse1,sparse3 - real(dp),allocatable::a(:,:),b(:,:),c(:,:),vect(:),vectout(:) - allocate(a(5,5),b(5,5),c(5,5),vect(5)) - write(line,*) 'SPARSE TEST';call print(line) - - - a=0.0_dp - a(1,1)=3 - a(1,3)=1 - a(2,2)=4 - a(3,2)=7 - a(3,3)=5 - a(3,4)=9 - a(4,5)=2 - a(5,4)=6 - a(5,5)=5 - write(line,*) 'MATRIX A IS:';call print(line) - call print(a) - c=a - - write(line,*) 'Now we assign it to a sparse';call print(line) - ! call sparse_assign_matrix(sparse1,a) - sparse3=a - - write(line,*) 'Now we assign a sparse to a sparse';call print(line) - ! call sparse_assign_matrix(sparse1,a) - sparse1=sparse3 - - call sparse_check(sparse1,"This message should not be seen") - write(line,*) 'Structure of the sparse';call print(line) - write(line,*) 'And its content';call print(line) - call print(sparse1) - write(line,*) 'Now we assign it back to a matrix';call print(line) - call matrix_assign_sparse(b,sparse1) - b=sparse1 - call print(b) - if ( a .FNE. b) then - write(line,*) 'Something is wrong: a .NE. b';call print(line) - else - write(line,*) 'Everything seems alright!';call print(line) - end if - - write(line,*) 'Now we multiply our sparse with a unity vector';call print(line) - vect=1 - call print(vect) - allocate(vectout(size(vect))) - vectout = sparse_mult_vector(sparse1,vect) - write(line,*) 'Result should be 4 4 21 2 11';call print(line) - call print(vectout) - - write(line,*) 'Now we multiply the following vector for the sparse';call print(line) - vect(1)=5 - vect(2)=2 - vect(3)=3 - vect(4)=2 - vect(5)=1 - - call print(vect) - vectout = vector_mult_sparse(vect,sparse1) - write(line,*) 'Result should be 15 29 20 33 9';call print(line) - call print(vectout) - - - write(line,*) 'Lets check if it is working with empty rows ';call print(line) - a(2,2)=0.0 ! now row 2 has no elements - call print(a) - sparse1=a - call print(sparse1) - call matrix_assign_sparse(b,sparse1) - call print(b) - if ( a .FNE. b) then - write(line,*) 'Something is wrong: a .NE. b';call print(line) - else - write(line,*) 'Everything seems alright!';call print(line) - end if - - write(line,*) 'Now we check an empty matrix';call print(line) - a=0.0 - call print(a) - call sparse_assign_matrix(sparse1,a) - call print(sparse1) - call matrix_assign_sparse(b,sparse1) - call print(b) - if ( a .FNE. b) then - write(line,*) 'Something is wrong: a .NE. b';call print(line) - else - write(line,*) 'Everything seems alright!';call print(line) - end if - - write(line,*) 'Now we check tracemult';call print(line) - write(line,*) 'The matrix is a=1';call print(line) - a=1 - call sparse_assign_matrix(sparse1,c) - write(line,*) 'The following should be 42:',trace_sparse_mult_matrix(sparse1,a) - call print(line) - write(line,*) 'Now we check print_full'; call print(line) - call sparse_print_full(sparse1) - - end subroutine sparse_test - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -end module sparse_module diff --git a/src/libAtoms/Spline.f95 b/src/libAtoms/Spline.f95 deleted file mode 100644 index 93a132859a..0000000000 --- a/src/libAtoms/Spline.f95 +++ /dev/null @@ -1,463 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Spline module -!X -!% Defines derived type for a spline, and associated functions. -!% Code partially based on Numerical Recipes. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module spline_module - use system_module, only : dp, inoutput, print, optional_default, system_abort, verbosity_push_decrement, verbosity_pop - use linearalgebra_module - use table_module - implicit none - private - SAVE - - public :: spline, initialise, finalise, print, min_knot, max_knot, spline_value, spline_deriv - - - type Spline - integer ::n !% Number of knot points - real(dp), allocatable, dimension(:) ::x !% Knot positions - real(dp), allocatable, dimension(:) ::y !% Function values - real(dp), allocatable, dimension(:) ::y2 !% Second derivative - real(dp) ::yp1,ypn !% Endpoint derivatives - ! whether y2 has been initialised or not - logical ::y2_initialised = .false. - logical :: initialised = .false. - end type Spline - - interface initialise - module procedure spline_init - end interface - - interface finalise - module procedure spline_finalise - end interface - - interface print - module procedure spline_print - end interface - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X spline_init(this, x, y, yp1, ypn) - !X - !% Initialises a spline with given x and y values (and endpoint derivatives) - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - subroutine spline_init(this, x, y, yp1, ypn) - type(spline), intent(inout)::this - real(dp), dimension(:) :: x !% Knot points - real(dp), dimension(:) :: y !%Values of spline at the knot points - real(dp)::yp1 !% Derivative of the spline at 'x(1)' - real(dp)::ypn !% Derivative of the spline at 'x(n)' - - - call check_size('Y',y,size(x),'Spline_Init') - - ! first deallocate arrays if they have been allocated before - if(allocated(this%x)) deallocate(this%x) - if(allocated(this%y)) deallocate(this%y) - if(allocated(this%y2)) deallocate(this%y2) - - ! allocate new sizes - this%n = size(x); - allocate(this%x(this%n)) - allocate(this%y(this%n)) - allocate(this%y2(this%n)) - - ! copy data - this%x = x - this%y = y - call sort_array(this%x, r_data=this%y) - this%yp1 = yp1 - this%ypn = ypn - - ! compute y2 - call spline_y2calc(this) - this%initialised = .true. - end subroutine spline_init - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X spline_finalise(this) - !X - !% Deallocates a spline - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine spline_finalise(this) - type(spline), intent(inout)::this - if(allocated(this%x)) deallocate(this%x) - if(allocated(this%y)) deallocate(this%y) - if(allocated(this%y2)) deallocate(this%y2) - this%y2_initialised = .false. - this%initialised = .false. - end subroutine spline_finalise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X spline_y2calc(this) - !X - !% Takes a spline with $x$ and $y$ values, and computes the second derivates - !% this must be done before interpolation. - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - subroutine spline_y2calc(this) - type(spline),intent(inout)::this - real(dp), allocatable, dimension(:) ::u ! local temporary - real(dp)::sig,p,un,qn - integer::i,k, n - - if(.not.allocated(this%x)) call system_abort("spline_y2calc: x not allocated!") - if(.not.allocated(this%y)) call system_abort("spline_y2calc: y not allocated!") - - n = this%n - - if(.not.allocated(this%y2)) allocate(this%y2(n)) - - allocate(u(n)) - - if(this%yp1> 0.99e30_dp) then - ! natural spline with zero second derivative at first point - this%y2(1) = 0.0_dp - u(1) = 0.0_dp - else - this%y2(1) = -0.5_dp - - u(1) = (3.0_dp/(this%x(2)-this%x(1)))* & - ((this%y(2)-this%y(1))/(this%x(2)-this%x(1))-this%yp1) - end if - - do i=2,n-1 - sig = (this%x(i)-this%x(i-1))/(this%x(i+1)-this%x(i-1)) - p = sig*this%y2(i-1)+2.0_dp - this%y2(i) = (sig-1.0)/p - u(i) = (this%y(i+1)-this%y(i))/(this%x(i+1)-this%x(i)) - & - (this%y(i)-this%y(i-1))/(this%x(i)-this%x(i-1)) - u(i) = (6.0*u(i)/(this%x(i+1)-this%x(i-1))-sig*u(i-1))/p - end do - - if(this%ypn > 0.99e30_dp)then - ! natural spline with zero second derivative at last point - qn = 0.0_dp - un = 0.0_dp - else - qn = 0.5_dp - un = (3.0_dp/(this%x(n)-this%x(n-1)))* & - (this%ypn-(this%y(n)-this%y(n-1))/(this%x(n)-this%x(n-1))) - end if - - this%y2(n) = (un-qn*u(n-1))/(qn*this%y2(n-1)+1.0_dp) - - do k=n-1,1,-1 - this%y2(k) = this%y2(k)*this%y2(k+1)+u(k) - end do - - ! set the logical flag - this%y2_initialised = .true. - - deallocate(u) ! free temporary - - if( this%yp1 > 0.99e30_dp ) then - this%yp1 = spline_deriv(this,this%x(1)) - endif - - if( this%ypn > 0.99e30_dp ) then - this%ypn = spline_deriv(this,this%x(n)) - endif - - end subroutine spline_y2calc - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X y = spline_value(this, x) - !X - !% Interpolate the spline for a given $x$ point - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - function spline_value(this,x) result(y) - type(spline)::this - real(dp)::x,h,a,b,y - integer::klo,khi,k, n - - if(.NOT.this%y2_initialised) then - if(allocated(this%x).and.allocated(this%y)) then - call spline_y2calc(this) - else - call system_abort("spline_value: spline has not been initialised") - end if - end if - - n = this%n - if( x < this%x(1) ) then - y = this%y(1) + (x - this%x(1))*this%yp1 - elseif( x > this%x(n) ) then - y = this%y(n) + (x - this%x(n))*this%ypn - else - klo = 1 - khi = this%n - - do while(khi-klo > 1) - k = (khi+klo)/2 - if(this%x(k) > x) then - khi = k - else - klo = k - end if - end do - - h = this%x(khi)-this%x(klo) - if(h .EQ. 0.0_dp) then - call system_abort("spline_interpolate: h=0!!!") - end if - - a = (this%x(khi)-x)/h - b = (x-this%x(klo))/h - y = a*this%y(klo)+b*this%y(khi)+((a*a*a-a)*this%y2(klo)+(b*b*b-b)*this%y2(khi))*(h*h)/6.0 - endif - - end function spline_value - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X dy = spline_deriv(this, x) - !X - !% Interpolate the derivative of the spline at the given $x$ point - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - function spline_deriv(this,x) result(dy) - type(spline)::this - real(dp)::x,h,a,b,dy - integer::klo,khi,k,n - - if(.NOT.this%y2_initialised) then - if(allocated(this%x).and.allocated(this%y)) then - call spline_y2calc(this) - else - call system_abort("spline_deriv: spline has not been initialised") - end if - end if - - n = this%n - - if( x < this%x(1) ) then - dy = this%yp1 - elseif( x > this%x(n) ) then - dy = this%ypn - else - klo = 1 - khi = n - - do while(khi-klo > 1) - k = (khi+klo)/2 - if(this%x(k) > x) then - khi = k - else - klo = k - end if - end do - - h = this%x(khi)-this%x(klo) - if(h .EQ. 0.0) then - call system_abort("spline_deriv: h=0!!!") - end if - - a = (this%x(khi)-x)/h - b = (x-this%x(klo))/h - dy = (this%y(khi)-this%y(klo))/h+((3.0_dp*b*b-1.0_dp)*this%y2(khi)-(3.0_dp*a*a-1.0_dp)*this%y2(klo))*h/6.0_dp - endif - - end function spline_deriv - - function spline_nintegrate(this, x0, x, n_per_knot) result (y_int) - type(spline), intent(in) :: this - real(dp), intent(in) :: x0, x - integer, intent(in), optional :: n_per_knot - real(dp) :: y_int - - integer :: use_n, total_n, i - real(dp), allocatable :: int_x(:), int_y(:) - - use_n = optional_default(10, n_per_knot) - total_n = use_n*abs(x-x0)/minval(abs(this%x(2:this%n)-this%x(1:this%n-1))) - - allocate(int_x(total_n)) - allocate(int_y(total_n)) - - do i=1, total_n - int_x(i) = x0+real(i-1,dp)*(x-x0)/real(total_n-1,dp) - int_y(i) = spline_value(this, int_x(i)) - end do - - y_int = TrapezoidIntegral(int_x, int_y) - deallocate(int_x) - deallocate(int_y) - - end function spline_nintegrate - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X spline_compute_matrices(this) - !X - !% The y2 of the spline can also be computed using - !% linear algebra. Following Numerical Recipes, - !% - !% \begin{displaymath} - !% A Y'' = BY + C - !% \end{displaymath} - !% where $A$, $B$ are matrices, $C$ is a vector - !% so - !% \begin{displaymath} - !% Y'' = A^{-1} B Y + A^{-1} C - !% \end{displaymath} - !% - !% This subroutine computes these matrices, and stores them in - !% 'spline%y2_matrix1 = inv(A)*B' and 'spline%y2_matrix0 = inv(A)*C' - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine spline_compute_matrices(this, y2_matrix1, y2_matrix0) - type(spline), intent(in)::this - real(dp), dimension(:,:), intent(out)::y2_matrix1 - real(dp), dimension(:), intent(out)::y2_matrix0 - real(dp)::A(this%n,this%n) - real(dp)::B(this%n,this%n),C(this%n) - real(dp)::Ainv(this%n,this%n) - integer::i,n - - n = this%n - - ! Set matrix elements that correspond to - ! conditions on first derivative at x1 and xn - ! equation 3.3.5 of Numerical Recipes in c++ second edition pag. 117 - ! evaluated at x=x1 and x=xn - A=0.0_dp - B=0.0_dp - C=0.0_dp - A(1,1) = -(1.0_dp/3.0_dp)*(this%x(2)-this%x(1)) - A(1,2) = -(1.0_dp/6.0_dp)*(this%x(2)-this%x(1)) - A(2,n-1)= (1.0_dp/6.0_dp)*(this%x(n)-this%x(n-1)) - A(2,n) = (1.0_dp/3.0_dp)*(this%x(n)-this%x(n-1)) - - B(1,1) = 1.0_dp/(this%x(2)-this%x(1)) - B(1,2) = -1.0_dp/(this%x(2)-this%x(1)) - B(2,n-1)= 1.0_dp/(this%x(n)-this%x(n-1)) - B(2,n) = -1.0_dp/(this%x(n)-this%x(n-1)) - - C(1) = this%yp1 - C(n) = this%ypn - - ! Set the matrix elements corresponds to the - ! equations 3.3.7 of page 118 in Numerical Recipes - - do I=2,n-1 - A(I+1,I-1) =(this%x(i) -this%x(i-1))/6.0_dp - A(I+1,I) =(this%x(i+1)-this%x(i-1))/3.0_dp - A(I+1,I+1) =(this%x(i+1)-this%x(i) )/6.0_dp - - B(I+1,I-1) = 1.0_dp/(this%x(i) -this%x(i-1)) - B(I+1,I) = -1.0_dp/(this%x(i+1)-this%x(i))- & - 1.0_dp/(this%x(i) -this%x(i-1)) - B(I+1,I+1) = 1.0_dp/(this%x(i+1)-this%x(i)) - end do - - call inverse(A,Ainv) - - y2_matrix1 = Ainv .mult. B - - y2_matrix0 = Ainv .mult. C - - end subroutine spline_compute_matrices - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X spline_print(this) - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine spline_print(this, file) - type(Spline), intent(in)::this - type(Inoutput), optional, target, intent(inout) :: file - - real(dp), allocatable :: y2m1(:,:), y2m0(:), y2(:) - - call print("Spline ", file=file) - - call print(this%n, file=file) - call print(reshape( (/this%x,this%y/), (/this%n,2/)), file=file) - - call verbosity_push_decrement() - if(this%y2_initialised) then - call print(this%y2, file=file) - else - - allocate(y2m1(this%n, this%n)) - allocate(y2m0(this%n)) - allocate(y2(this%n)) - - call spline_compute_matrices(this, y2m1, y2m0) - y2 = (y2m1 .mult. this%y)+y2m0 - call print(y2, file=file) - - deallocate(y2m1) - deallocate(y2m0) - deallocate(y2) - endif - - call verbosity_pop() - end subroutine spline_print - - function min_knot(this) - type(Spline), intent(in) :: this - real(dp) :: min_knot - - min_knot = this%x(1) - end function min_knot - - function max_knot(this) - type(Spline), intent(in) :: this - real(dp) :: max_knot - - max_knot = this%x(size(this%x)) - end function max_knot - -end module spline_module - - - diff --git a/src/libAtoms/Structures.f95 b/src/libAtoms/Structures.f95 deleted file mode 100644 index 34c5d309b4..0000000000 --- a/src/libAtoms/Structures.f95 +++ /dev/null @@ -1,3499 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Structures module -!X -!% A collection of utility functions that generate useful Atoms structures -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module structures_module - use error_module - use system_module - use units_module - use periodictable_module - use linearalgebra_module - use table_module - use extendable_str_module - use dictionary_module - use connection_module - use atoms_types_module - use atoms_module - use cinoutput_module - use paramreader_module - use clusters_module - implicit none - private - - public :: slab, find_motif - public :: graphene_cubic, graphene_slab, graphene_sheet, graphene_tube, tube_radius, anatase_cubic, alpha_quartz, alpha_quartz_cubic, rutile, diamond, water, supercell, structure_from_file, fcc, fcc1, & - diamond2, graphite, graphite_rhombohedral, beta_tin, beta_tin4, bcc1, hcp, wurtzite, sh, sh2, imma, imma4, & - fcc_11b2_edge_disloc, fcc_disloc_malc, disloc_noam, fcc_z111_ortho, fcc_z111, fcc_z100, bulk, unit_slab, slab_width_height_nz, & - slab_nx_ny_nz, bcc, transform, arbitrary_supercell, find_compatible_supercells, bond_angle_mean_dev, map_nearest_atoms, & - delaunay_reduce, min_neighbour_dist, remove_too_close_atoms, surface_unit_cell, find_closest, void_analysis - - - interface slab - module procedure slab_width_height_nz, slab_nx_ny_nz - end interface - -contains - - !X - !X Edge dislocation generator - !X - subroutine fcc_11b2_edge_disloc(at, a0, n1, n2, n3) - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a0 ! cubic lattice constant - integer, intent(in) :: n1, n2, n3 ! supercell dimensions - - type(atoms) :: at1 - type(table) :: removelist - integer :: i - - call fcc_z111_ortho(at1, a0) - call supercell(at, at1, n1, n2, n3) - - call map_into_cell(at) - - do i= 1,at%N - if( at%pos(3,i) > 0.0_dp) then - if(abs(at%pos(1,i)) < 0.1_dp) then - call append(removelist, i) - else - at%pos(1,i) = at%pos(1,i)-sign(at%pos(1,i))*min(a0/sqrt(2.0_dp)/4.0_dp, at%pos(3,i)/10.0_dp) - at%pos(2,i) = at%pos(2,i)-sign(at%pos(1,i))*min(a0*sqrt(3.0_dp/2.0_dp)/4.0_dp, at%pos(3,i)/10.0_dp) - end if - end if - end do - - if(removelist%N > 0) then - call allocate(removelist) ! make the table size exact - call print('Removing '//removelist%N//' atoms') - call remove_atoms(at, int_part(removelist,1)) - end if - - - call set_lattice(at, at%lattice+reshape((/ & - 20.0_dp,0.0_dp,0.0_dp, & - 0.0_dp, 0.0_dp,0.0_dp, & - 0.0_dp, 0.0_dp,20.0_dp/), (/3, 3/)), scale_positions=.false.) - - call finalise(at1) - call finalise(removelist) - - end subroutine fcc_11b2_edge_disloc - - - !X - !X Dislocation generator, formulas from Malcolm Heggie - !X - subroutine fcc_disloc_malc(at, a0, nu, n1, n2, n3, d, type) - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a0, nu ! cubic lattice constant, poisson ratio - integer, intent(in) :: n1, n2, n3, d ! supercell dimensions, distance between partials - character(*) :: type - - type(atoms) :: at1 - type(table) :: removelist - real(dp) :: x, y, z, ux, uy, uz, r2, b_screw, b_edge, b_edge_p, theta, ox(2), r_ij - integer :: p, i, n, j - - call fcc_z111_ortho(at1, a0) - call supercell(at, at1, n1, n2, n3) - - ox(1) = -real(d)*sqrt(3.0_dp/2.0_dp)*a0 - ox(2) = real(d)*sqrt(3.0_dp/2.0_dp)*a0 - - if(type == 'edge') then - b_screw = a0*sqrt(3.0_dp/2.0_dp)/2.0_dp - b_edge = a0/sqrt(2.0_dp)/2.0_dp - else if (type == 'screw') then - b_screw = a0/2.0_dp/sqrt(2.0_dp) - b_edge = 0.0_dp - else - call system_abort("screw_disloc(): unknown type `"//type//"'") - end if - - do p=1,2 - b_edge_p = b_edge*0.5_dp + a0/2.0_dp/sqrt(6.0_dp)*sign(p-1.5_dp) - do i=1,at%N - x = at%pos(1,i)-ox(p)-0.1 - y = at%pos(2,i) - z = at%pos(3,i)-0.1 - theta = atan2(z,x) - r2 = x*x+z*z - ux = b_edge_p/(2.0_dp*PI)*(theta+0.5_dp*x*z/r2/(1.0_dp-nu)) - uy = b_screw/(2.0_dp*PI)*theta - uz = -0.25_dp*b_edge_p/(2.0_dp*PI)*((1.0_dp-2.0_dp*nu)*log(r2)+(x*x-z*z)/r2)/(1.0_dp-nu) - - at%pos(:,i) = at%pos(:,i)+(/ux, uy, uz/) - end do - end do - - call set_cutoff(at, 2.1_dp) - call calc_connect(at) - - do i= 1,at%N - do n = 1,n_neighbours(at, i) - j = neighbour(at, i, n, distance=r_ij) - if(r_ij < 2.0_dp .and. i > j) then - call print('i= '//i//' j= '//j//' r_ij = '//r_ij) - call append(removelist, j) - end if - end do - end do - - !call print(at) - - if(removelist%N > 0) then - call allocate(removelist) ! make the table size exact - call print('Removing '//removelist%N//' atoms') - call remove_atoms(at, int_part(removelist,1)) - call calc_connect(at) - end if - - call set_lattice(at, at%lattice+reshape((/ & - 20.0_dp,0.0_dp,0.0_dp, & - 0.0_dp, 0.0_dp,0.0_dp, & - 0.0_dp, 0.0_dp,20.0_dp/), (/3, 3/)), scale_positions=.false.) - - call finalise(at1) - call finalise(removelist) - end subroutine fcc_disloc_malc - - subroutine disloc_noam(at, p, l, b, close_threshold) - type(Atoms), intent(inout) :: at - real(dp) :: p(3), l(3), b(3) - real(dp), optional :: close_threshold - - real(dp) :: l_hat(3), b_hat(3), r1_hat(3), r2_hat(3) - real(dp) :: theta - real(dp) :: delta_p(3), delta_p_rot(3) - real(dp) :: r - - integer :: i_at, j_at, j - logical, allocatable :: atoms_remove(:) - integer, allocatable :: remove_list(:) - - l_hat = l/norm(l) - b_hat = b/norm(b) - - if (abs(l_hat .dot. b_hat) .feq. 1.0_dp) then ! screw - r1_hat = (/ 1.0_dp, 0.0_dp, 0.0_dp /) - r1_hat = r1_hat - l_hat * (r1_hat .dot. l_hat) - if (norm(r1_hat) .feq. 0.0_dp) then - r1_hat = (/ 0.0_dp, 1.0_dp, 0.0_dp /) - r1_hat = r1_hat - l_hat * (r1_hat .dot. l_hat) - endif - r1_hat = r1_hat / norm(r1_hat) - r2_hat = l_hat .cross. r1_hat - else - r2_hat = l_hat .cross. b_hat - r2_hat = r2_hat/norm(r2_hat) - r1_hat = r2_hat .cross. l_hat - endif - - call print("disloc_noam: r1_hat " // r1_hat, PRINT_VERBOSE) - call print("disloc_noam: r2_hat " // r2_hat, PRINT_VERBOSE) - call print("disloc_noam: l_hat " // l_hat, PRINT_VERBOSE) - - do i_at = 1, at%N - delta_p = diff_min_image(at, p, i_at) - if (norm(delta_p) .feq. 0.0_dp) then - theta = 0.0_dp - else - delta_p_rot(1) = delta_p .dot. r1_hat - delta_p_rot(2) = delta_p .dot. r2_hat - delta_p_rot(3) = delta_p .dot. l_hat - theta = atan2(delta_p_rot(2), delta_p_rot(1)) - endif - call print("atom " // i_at // " pos " // at%pos(:,i_at) // " delta_p " // delta_p // " theta " // theta, PRINT_ANALYSIS) - delta_p = b*theta/(2.0_dp*PI) - at%pos(:,i_at) = at%pos(:,i_at) + delta_p - end do - - allocate(atoms_remove(at%N)) - atoms_remove = .false. - - call calc_connect(at) - do i_at = 1, at%N - if (atoms_remove(i_at)) cycle - do j=1, n_neighbours(at, i_at) - j_at = neighbour(at, i_at, j, distance=r) - if (atoms_remove(j_at)) cycle - if (present(close_threshold)) then - if (r < close_threshold) then - if (j_at == i_at) then - call print("WARNING: disloc_noam found atom too close to itself", PRINT_ALWAYS) - else - atoms_remove(j_at) = .true. - endif - endif - else - if (r < 0.5_dp*bond_length(at%Z(i_at), at%Z(j_at))) then - if (i_at == j_at) then - call print("WARNING: disloc_noam found atom too close to itself", PRINT_ALWAYS) - else - atoms_remove(j_at) = .true. - endif - endif - endif ! present(close_threshold) - end do ! j - end do ! i_at - - if (count(atoms_remove) > 0) then - allocate(remove_list(count(atoms_remove))) - j_at = 0 - do i_at=1, at%N - if (atoms_remove(i_at)) then - j_at = j_at + 1 - remove_list(j_at) = i_at - endif - end do - call remove_atoms(at, remove_list) - - deallocate(remove_list) - end if - - deallocate(atoms_remove) - - end subroutine disloc_noam - - subroutine fcc_z111_ortho(at, a0) - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a0 ! cubic lattice constant - real(dp) :: lat(3,3), b - - b = a0*sqrt(2.0_dp)/2.0_dp - lat(:,1) = (/b, 0.0_dp, 0.0_dp/) - lat(:,2) = (/0.0_dp, b*sqrt(3.0_dp), 0.0_dp/) - lat(:,3) = (/0.0_dp, 0.0_dp, a0*sqrt(3.0_dp)/) - - call initialise(at, 6, lat) - at%pos(:,1) = lat .mult. (/0.0_dp,0.0_dp,0.0_dp/) - at%pos(:,2) = lat .mult. (/0.5_dp,0.5_dp,0.0_dp/) - at%pos(:,3) = lat .mult. (/0.0_dp, 2.0_dp/3.0_dp, 1.0_dp/3.0_dp/) - at%pos(:,4) = lat .mult. (/0.5_dp, 1.0_dp/6.0_dp, 1.0_dp/3.0_dp/) - at%pos(:,5) = lat .mult. (/0.0_dp, 1.0_dp/3.0_dp, 2.0_dp/3.0_dp/) - at%pos(:,6) = lat .mult. (/0.5_dp, 5.0_dp/6.0_dp, 2.0_dp/3.0_dp/) - end subroutine fcc_z111_ortho - - subroutine fcc_z111(at, a0) - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a0 ! cubic lattice constant - real(dp) :: lat(3,3), b - - b = a0*sqrt(2.0_dp)/2.0_dp - lat(:,1) = (/b, 0.0_dp, 0.0_dp/) - lat(:,2) = (/b*0.5_dp, b*sqrt(3.0_dp)/2.0_dp, 0.0_dp/) - lat(:,3) = (/0.0_dp, 0.0_dp, a0*sqrt(3.0_dp)/) - - call initialise(at, 3, lat) - at%pos(:,1) = lat .mult. (/0.0_dp,0.0_dp,0.0_dp/) - at%pos(:,2) = lat .mult. (/1.0_dp/3.0_dp, 1.0_dp/3.0_dp, 1.0_dp/3.0_dp/) - at%pos(:,3) = lat .mult. (/2.0_dp/3.0_dp, 2.0_dp/3.0_dp, 2.0_dp/3.0_dp/) - end subroutine fcc_z111 - - - !% Make an FCC 100 surface, such that the repeating squares of the - !% surface are aligned with the cell boundaries - subroutine fcc_z100(at, a0) - type(Atoms), intent(out) :: at - real(DP), intent(in) :: a0 ! cubic lattice constant - - real(DP) :: lat(3, 3) - - lat(:, 1) = (/ a0/sqrt(2.0), 0.0_DP, 0.0_DP /) - lat(:, 2) = (/ 0.0_DP, a0/sqrt(2.0_DP), 0.0_DP /) - lat(:, 3) = (/ 0.0_DP, 0.0_DP, a0 /) - - call initialise(at, 2, lat) - at%pos(:, 1) = lat .mult. (/ 0.0_DP, 0.0_DP, 0.0_DP /) - at%pos(:, 2) = lat .mult. (/ 0.5_DP, 0.5_DP, 0.5_DP /) - endsubroutine fcc_z100 - - !% Construct a bulk primitive cell with a given lattice type and lattice parameters - subroutine bulk(at, lat_type, a, c, u, x, y, z, atnum) - type(Atoms), intent(out) :: at - character(len=*), intent(in) :: lat_type !% One of 'diamond', 'bcc', 'fcc', 'alpha_quartz', 'anatase_cubic', 'anatase', or 'rutile' - real(dp), intent(in) :: a !% Principal lattice constant - real(dp), intent(in), optional :: c, u, x, y, z - integer, intent(in), optional :: atnum(:) !% Optionally specify atomic numbers - - if(trim(lat_type).eq.'diamond') then - call diamond(at, a, atnum) - elseif(trim(lat_type).eq.'bcc') then - call bcc(at, a, atnum(1)) - elseif(trim(lat_type).eq.'fcc') then - call fcc(at, a, atnum(1)) - elseif(trim(lat_type) .eq. 'alpha_quartz') then - if (.not. present(c) .or. .not. present(u) .or. .not. present(x) & - .or. .not. present(y) .or. .not. present(z)) call system_abort('bulk: alpha_quartz missing c, u, x, y or z') - call alpha_quartz_cubic(at, a, c, u, x, y, z) - elseif(trim(lat_type) .eq. 'anatase_cubic') then - if (.not. present(c) .or. .not. present(u) ) call system_abort('bulk: anatase_cubic missing c, u') - call anatase_cubic(at, a, c, u) - elseif(trim(lat_type) .eq. 'anatase') then - if (.not. present(c) .or. .not. present(u) ) call system_abort('bulk: anatase missing c, u') - call anatase(at, a, c, u) - elseif(trim(lat_type) .eq. 'rutile') then - if (.not. present(c) .or. .not. present(u) ) call system_abort('bulk: rutile missing c, u') - call rutile(at, a, c, u) - else - call system_abort('bulk: unknown lattice type '//lat_type) - endif - - end subroutine bulk - - - !% Return a slab of material with the x, y, and z axes desribed by the - !% Miller indices in the array axes (with ``x = axes[:,1])``, ``y = - !% axes[:,2]`` and ``z = axes[:,3]``). The extent of the slab should - !% be given either as ``(nx, ny, nz)`` unit cells or as ``(width, - !% height, nz)`` where `width` and `height` are measured in Angstrom - !% and `nz` is the number of cells in the `z` direction. - !% - !% `atnum` can be used to initialise the `z` and `species` properties. - !% `lat_type` should be of ``"diamond"```, ``"fcc"``, or ``"bcc"`` - !% (default is ``"diamond"``) - subroutine unit_slab(myatoms, axes, a, atnum, lat_type, c, u, x, y, z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in), dimension(3,3) :: axes - real(dp), intent(in) :: a ! Lattice vector - real(dp), intent(in), optional :: c, u, x, y, z ! Lattice vector - integer, intent(in), optional :: atnum(:) ! atomic numbers - character(len=*), intent(in), optional :: lat_type ! lattice type (diamond, bcc, fcc) - - integer :: i, Nrep(3) ! Number of repeats in x,y and z - real(dp), dimension(3) :: a1, a2, a3, t, d - real(dp), dimension(3,3) :: rot - type(Atoms) :: at - character(20) :: my_lat_type - - i = 0 - Nrep = (/ 1,1,1 /) - - my_lat_type = optional_default('diamond', lat_type) - call print("unit_slab : Lattice type " // trim(my_lat_type)) - call bulk(at, lat_type, a, c, u, x, y, z, atnum) - - ! Need special cases for some surfaces to ensure we only get one unit cell - if (all(axes(:,2) == (/ 1,1,1 /)) .and. all(axes(:,3) == (/ 1,-1,0 /))) & - Nrep = (/ 2,1,2 /) - if (all(axes(:,2) == (/ 1,1,0 /)) .and. all(axes(:,3) == (/ 0,0,-1 /))) & - Nrep = (/ 2,2,1 /) - if (all(axes(:,2) == (/ 1,1,0 /)) .and. all(axes(:,3) == (/ 1,-1,0 /))) & - Nrep = (/ 1,1,2 /) - - a1 = axes(:,1); a2 = axes(:,2); a3 = axes(:,3) - rot(1,:) = a1/norm(a1); rot(2,:) = a2/norm(a2); rot(3,:) = a3/norm(a3) - - ! Rotate atom positions and lattice - at%pos = rot .mult. at%pos - at%lattice = rot .mult. at%lattice - - call supercell(myatoms, at, 5, 5, 5) - call zero_sum(myatoms%pos) - - ! Project rotated lattice onto axes - do i=1,3 - myatoms%lattice(:,i) = (axes(1,i)*at%lattice(:,1) + & - axes(2,i)*at%lattice(:,2) + & - axes(3,i)*at%lattice(:,3))/Nrep(i) - end do - call set_lattice(myatoms, myatoms%lattice, scale_positions=.false.) - - ! Form primitive cell by discarding atoms with - ! lattice coordinates outside range [-0.5,0.5] - d = (/ 0.01_dp,0.02_dp,0.03_dp /) ! Small shift to avoid conincidental alignments - i = 1 - do - t = myatoms%g .mult. (myatoms%pos(:,i) + d) - if (any(t <= -0.5_dp) .or. any(t >= 0.5_dp)) then - call remove_atoms(myatoms, i) - i = i - 1 ! Retest since we've removed an atom - end if - if (i == myatoms%N) exit - i = i + 1 - end do - - call map_into_cell(myatoms) - - call finalise(at) - - end subroutine unit_slab - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Slab with dimensions width x height in xy plane and nz layers deep. - ! Origin is at centre of slab. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine slab_width_height_nz(myslab, axes, a, width, height, nz, atnum, lat_type, c, u, x, y, z, even_nx, even_ny) - type(Atoms), intent(out) :: myslab - real(dp), intent(in), dimension(3,3) :: axes - real(dp), intent(in) :: a, width, height - real(dp), intent(IN), optional :: c, u, x, y, z ! Lattice vector - integer, intent(in) :: nz ! Number of layers - integer, intent(in), optional :: atnum(:) ! atomic numbers to use - character(len=*), optional :: lat_type - logical, optional, intent(in) :: even_nx, even_ny ! round nx or ny to even numbers - - type(Atoms) :: unit, layer - integer nx, ny - logical :: do_even_nx, do_even_ny - - ! even_nx and even_ny default to true for lat_type="alpha_quartz", otherwise they default to false - if (present(lat_type)) then - if (trim(lat_type) == 'alpha_quartz') then - do_even_nx = optional_default(.true., even_nx) - do_even_ny = optional_default(.true., even_ny) - else - do_even_nx = optional_default(.false., even_nx) - do_even_ny = optional_default(.false., even_ny) - end if - else - do_even_nx = optional_default(.false., even_nx) - do_even_ny = optional_default(.false., even_ny) - end if - - call unit_slab(unit, axes, a, atnum, lat_type, c, u, x, y, z) - - nx = int(floor(width/unit%lattice(1,1))) - ny = int(floor(height/unit%lattice(2,2))) - - if (do_even_nx .and. mod(nx, 2) == 1) nx = nx - 1 - if (do_even_ny .and. mod(ny, 2) == 1) ny = ny - 1 - - if (.not. (nx > 0 .and. ny > 0 .and. nz > 0)) then - write(line,'(a, i0, i0, i0)') 'Error in slab: nx,ny,nz = ', nx, ny, nz - call system_abort(line) - end if - - call print('slab_width_height_nz: nx='//nx//' ny='//ny//' nz='//nz, PRINT_VERBOSE) - - call supercell(layer, unit, nx, ny, 1) - ! z layers last for symmetrise - call supercell(myslab, layer, 1, 1, nz) - call zero_sum(myslab%pos) - call finalise(unit, layer) - - end subroutine slab_width_height_nz - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! Slab of size nx x ny x nx primitive cells. - ! Origin is at centre of slab. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine slab_nx_ny_nz(myslab, axes, a, nx, ny, nz, atnum, lat_type, c, u, x, y, z) - type(Atoms), intent(out) :: myslab - real(dp), intent(in), dimension(3,3) :: axes - real(dp), intent(in) :: a - real(dp), intent(IN), optional :: c, u, x, y, z - integer, intent(in) :: nx, ny, nz - integer, intent(in), optional :: atnum(:) - character(len=*), intent(inout), optional :: lat_type - - type(Atoms) :: unit, layer - - call unit_slab(unit, axes, a, atnum, lat_type, c, u, x, y, z) - call supercell(layer, unit, nx, ny, 1) - ! z layers last for symmetrise - call supercell(myslab, layer, 1, 1, nz) - call zero_sum(myslab%pos) - call finalise(unit, layer) - - end subroutine slab_nx_ny_nz - - !% Cubic grapphene unit cell with lattice parameter 'a', this is the subroutine version - subroutine Graphene(cube, a) - type(Atoms), intent(out) :: cube - real(dp), intent(in) :: a - - ! call the function below - cube = Graphene_Cubic(a) - end subroutine Graphene - - !% Cubic graphene unit cell with lattice parameter 'a'. - function Graphene_Cubic(a) result(cube) - real(dp), intent(in) :: a - type(Atoms) :: cube - - call Initialise(cube, 4, & - reshape((/ 3.0_dp*a, 0.0_dp, 0.0_dp, & - 0.0_dp, sqrt(3.0_dp)*a, 0.0_dp, & - 0.0_dp, 0.0_dp, 10.0_dp/), (/3, 3/))) - - call set_atoms(cube, 6) - cube%pos(:,1) = a*(/0.0_dp, sqrt(3.0_dp)/2.0, 0.0_dp/) - cube%pos(:,2) = a*(/0.5_dp, 0.0_dp, 0.0_dp/) - cube%pos(:,3) = a*(/1.5_dp, 0.0_dp, 0.0_dp/) - cube%pos(:,4) = a*(/2.0_dp, sqrt(3.0_dp)/2.0, 0.0_dp/) - - end function Graphene_Cubic - - !% Construct a slab of graphene of a given with and height, at a given angle. - !% 'a' is lattice parameter. - subroutine Graphene_Slab(slab, a, theta, width, height) - real(dp), intent(in) :: a, theta, width, height - type(Atoms), intent(out) :: slab - - type(Atoms) :: unit, tmp_slab - type(Table) :: keep_list - integer :: i, nx, ny, nz - real(dp) :: rot(3,3), lattice(3,3), d(3), t(3) - - unit = Graphene_Cubic(a) - - rot = reshape((/ cos(theta), -sin(theta), 0.0_dp, & - sin(theta), cos(theta), 0.0_dp, & - 0.0_dp, 0.0_dp, 1.0_dp /), (/3,3/)) - - unit%pos = rot .mult. unit%pos - lattice = rot .mult. unit%lattice - call Set_Lattice(unit, lattice, scale_positions=.false.) - - ! Choose nx and ny so we can cut a width by height square out of the - ! rotated slab - call Fit_Box_in_Cell(width, height, norm(unit%lattice(:,3)), unit%lattice, nx, ny, nz) - call Supercell(tmp_slab, unit, nx, ny, 1) - call Zero_Sum(tmp_slab%pos) - - ! Final lattice for unitslab is width by height - lattice = 0.0_dp - lattice(1,1) = width - lattice(2,2) = height - lattice(3,3) = tmp_slab%lattice(3,3) - call Set_Lattice(tmp_slab, lattice, scale_positions=.false.) - - ! Form primitive cell by discarding atoms with - ! lattice coordinates outside range [-0.5,0.5] - d = (/ 0.01, 0.02, 0.03 /) - call Allocate(keep_list, 1, 0, 0, 0, tmp_slab%N) - - do i=1,tmp_slab%N - t = tmp_slab%g .mult. (tmp_slab%pos(:,i) + d) - if (.not. (any(t < -0.5_dp) .or. any(t >= 0.5_dp))) & - call Append(keep_list, i) - end do - - call Initialise(slab, keep_list%N, tmp_slab%lattice) - slab%Z = tmp_slab%Z(keep_list%int(1,1:keep_list%N)) - slab%species = tmp_slab%species(:,keep_list%int(1,1:keep_list%N)) - - if (has_property(slab, 'mass')) & - forall (i=1:slab%N) slab%mass(i) = ElementMass(slab%Z(i)) - - slab%pos = tmp_slab%pos(:,keep_list%int(1,1:keep_list%N)) - - call Finalise(unit) - call Finalise(tmp_slab) - call finalise(keep_list) - end subroutine Graphene_Slab - - !% Construct a graphene sheet of index $(n,m)$ with lattice constant 'a' with 'rep_x' - !% repeat units in the $x$ direction and 'rep_y' in the $y$ direction. - subroutine Graphene_Sheet(sheet, a, n, m, rep_x, rep_y) - type(Atoms), intent(out) :: sheet - real(dp), intent(in) :: a - integer, intent(in) :: n, m, rep_x, rep_y - - type(Atoms) :: unit, unitsheet - real(dp) :: a1(2), a2(2), x(2), y(2), lattice(3,3), theta, rot(3,3), d(3), t(3), normx, normy - integer :: nx, ny, nz, i - - unit = Graphene_Cubic(a) - - a1 = a*(/3.0_dp/2.0_dp, sqrt(3.0_dp)/2.0/) - a2 = a*(/3.0_dp/2.0_dp, -sqrt(3.0_dp)/2.0/) - - ! x gets mapped to circumference of tube - x = n*a1 + m*a2 - normx = norm(x) - - ! y is smallest vector perpendicular to x that can be written - ! in form a*a1 + b*a2 where a and b are integers, i.e. it is - ! the periodicity of nanotube along tube length - y = (2.0_dp*n + m)*a1 - (n + 2.0_dp*m)*a2 - y = y / real(gcd(2*n + m, n + 2*m), dp) - normy = norm(y) - - ! Rotate unit cell to align x axis with vector x - theta = -atan(x(2)/x(1)) - rot = reshape((/ cos(theta), -sin(theta), 0.0_dp, & - sin(theta), cos(theta), 0.0_dp, & - 0.0_dp, 0.0_dp, 1.0_dp /), (/3,3/)) - - unit%pos = rot .mult. unit%pos - lattice = rot .mult. unit%lattice - call Set_Lattice(unit, lattice, scale_positions=.false.) - - ! Choose nx and ny so we can cut an x by y square out of the - ! rotated unitsheet - call Fit_Box_in_Cell(normx, normy, norm(unit%lattice(:,3)), unit%lattice, nx, ny, nz) - call Supercell(unitsheet, unit, nx, ny, 1) - call Zero_Sum(unitsheet%pos) - - ! Final lattice for unitsheet is norm(x) by norm(y) - lattice = 0.0_dp - lattice(1,1) = normx - lattice(2,2) = normy - lattice(3,3) = unitsheet%lattice(3,3) - - call Set_Lattice(unitsheet, lattice, scale_positions=.false.) - - ! Form primitive cell by discarding atoms with - ! lattice coordinates outside range [-0.5,0.5] - d = (/ 0.01, 0.02, 0.03 /) - i = 1 - do - t = unitsheet%g .mult. (unitsheet%pos(:,i) + d) - if (any(t < -0.5_dp) .or. any(t >= 0.5_dp)) then - call Remove_Atoms(unitsheet, i) - i = i - 1 ! Retest since we've removed an atom - end if - if (i == unitsheet%N) exit - i = i + 1 - end do - - call Supercell(sheet, unitsheet, rep_x, rep_y, 1) - - call Finalise(unit) - call Finalise(unitsheet) - end subroutine Graphene_Sheet - - - !% Calcualte average radius of a nanotube - function Tube_Radius(tube) result(r) - type(Atoms), intent(in) :: tube - real(dp) :: r - - real(dp), dimension(2,tube%N) :: pos - real(dp) :: r_sum - integer :: i - - ! Collapse in z direction - pos(:,:) = tube%pos(1:2,:) - - ! Centre on (0,0) - call Zero_Sum(pos) - - r_sum = 0.0_dp - do i=1,tube%N - r_sum = r_sum + sqrt(pos(1,i)**2 + pos(2,i)**2) - end do - r = r_sum/tube%N ! Average radius - - end function Tube_Radius - - - - !% Euclidean algorithm for greatest common divisor of 'a' and 'b' - !% needed by 'graphene_tube' - function gcd(ai, bi) - integer, intent(in) :: ai, bi - integer :: gcd - - integer :: a, b, c - - a = ai - b = bi - do while (b /= 0) - c = b - b = mod(a,b) - a = c - end do - gcd = a - - end function gcd - - !% Construct a $(n,m)$ nanotube with lattice parameter 'a' and 'nz' - !% unit cells along the tube length. Also returns the radius of the tube. - function Graphene_Tube(tube, a, n, m, nz) result(r) - type(Atoms), intent(out) :: tube - real(dp), intent(in) :: a - integer, intent(in) :: n, m, nz - real(dp) :: r - - type(Atoms) :: unit, sheet, unittube - real(dp) :: a1(2), a2(2), x(2), lattice(3,3), normx - integer :: i - - real, parameter :: NANOTUBE_VACCUUM = 10.0_dp - - a1 = a*(/3.0_dp/2.0_dp, sqrt(3.0_dp)/2.0/) - a2 = a*(/3.0_dp/2.0_dp, -sqrt(3.0_dp)/2.0/) - - call Graphene_Sheet(sheet, a, n, m, 1, 1) - - ! x gets mapped to circumference of tube - x = n*a1 + m*a2 - normx = norm(x) - - ! Circumference of tube is norm(x) - r = normx/(2.0_dp*pi) - - ! Tube lattice - lattice = 0.0_dp - lattice(1,1) = 2*r + NANOTUBE_VACCUUM - lattice(2,2) = lattice(1,1) - lattice(3,3) = sheet%lattice(2,2) - - call Initialise(unittube, sheet%N, lattice) - unittube%Z = sheet%Z - unittube%species = sheet%species - - if (has_property(unittube,'mass')) & - forall(i=1:unittube%N) unittube%mass(i) = ElementMass(unittube%Z(i)) - - ! Roll up sheet to form tube - do i = 1,unittube%N - unittube%pos(1,i) = r*cos(2.0_dp*pi*sheet%pos(1,i)/normx) - unittube%pos(2,i) = r*sin(2.0_dp*pi*sheet%pos(1,i)/normx) - unittube%pos(3,i) = sheet%pos(2,i) - end do - - call Supercell(tube, unittube, 1, 1, nz) - call Finalise(unit) - call Finalise(sheet) - call Finalise(unittube) - - end function Graphene_Tube - - ! - !% Return an atoms object containing one TIP3P water molecule in a box - !% giving the correct density at 300K - ! - function water() - - type(Atoms) :: water - - call initialise(water,3,make_lattice(3.129058333_dp)) - - water%pos(:,1) = (/0.0_dp,0.0_dp,0.0_dp/) - water%pos(:,2) = (/0.9572_dp,0.0_dp,0.0_dp/) - water%pos(:,3) = (/-0.2399872084_dp,0.9266272065_dp,0.0_dp/) - - call set_atoms(water, (/8, 1, 1/)) - - end function water - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! supercell(lotsofatoms, atoms, n1, n2, n3) - ! - !% Replicates the unit cell 'n1*n2*n3' times along the lattice vectors. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine supercell(aa, a, n1, n2, n3, supercell_index_name, error) - type(Atoms), intent(out)::aa !% Output (big) cell - type(Atoms), intent(in)::a !% Input cell - integer, intent(in)::n1, n2, n3 - character(len=*), intent(in), optional :: supercell_index_name - integer, intent(out), optional :: error - - real(dp)::lattice(3,3), p(3) - integer::i,j,k,n,nn - - integer, pointer :: a_int_ptr(:), a_int2_ptr(:,:), aa_int_ptr(:), aa_int2_ptr(:,:), supercell_index(:,:) - real(dp), pointer :: a_real_ptr(:), a_real2_ptr(:,:), aa_real_ptr(:), aa_real2_ptr(:,:) - logical, pointer :: a_logical_ptr(:), aa_logical_ptr(:) - character, pointer :: a_char_ptr(:,:), aa_char_ptr(:,:) - - INIT_ERROR(error) - - lattice(:,1) = a%lattice(:,1)*n1 - lattice(:,2) = a%lattice(:,2)*n2 - lattice(:,3) = a%lattice(:,3)*n3 - call initialise(aa, a%N*n1*n2*n3, lattice) - call set_cutoff(aa, a%cutoff) - - do n=1,a%properties%n - select case(a%properties%entries(n)%type) - - case(T_INTEGER_A) - if (.not. assign_pointer(a, string(a%properties%keys(n)), a_int_ptr)) then - RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) - end if - call add_property(aa, string(a%properties%keys(n)), 0, ptr=aa_int_ptr, error=error, overwrite=.true.) - PASS_ERROR(error) - do i=0,n1-1 - do j=0,n2-1 - do k=0,n3-1 - aa_int_ptr(((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_int_ptr(:) - end do - end do - end do - - case(T_REAL_A) - if (.not. assign_pointer(a, string(a%properties%keys(n)), a_real_ptr)) then - RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) - end if - call add_property(aa, string(a%properties%keys(n)), 0.0_dp, ptr=aa_real_ptr, error=error, overwrite=.true.) - PASS_ERROR(error) - do i=0,n1-1 - do j=0,n2-1 - do k=0,n3-1 - aa_real_ptr(((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_real_ptr(:) - end do - end do - end do - - case(T_LOGICAL_A) - if (.not. assign_pointer(a, string(a%properties%keys(n)), a_logical_ptr)) then - RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) - end if - call add_property(aa, string(a%properties%keys(n)), .false., ptr=aa_logical_ptr, error=error, overwrite=.true.) - PASS_ERROR(error) - do i=0,n1-1 - do j=0,n2-1 - do k=0,n3-1 - aa_logical_ptr(((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_logical_ptr(:) - end do - end do - end do - - case(T_INTEGER_A2) - if (.not. assign_pointer(a, string(a%properties%keys(n)), a_int2_ptr)) then - RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) - end if - call add_property(aa, string(a%properties%keys(n)), 0, n_cols=size(a_int2_ptr,1), & - ptr2=aa_int2_ptr, error=error, overwrite=.true.) - PASS_ERROR(error) - do i=0,n1-1 - do j=0,n2-1 - do k=0,n3-1 - aa_int2_ptr(:,((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_int2_ptr(:,:) - end do - end do - end do - - case(T_REAL_A2) - if (.not. assign_pointer(a, string(a%properties%keys(n)), a_real2_ptr)) then - RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) - end if - call add_property(aa, string(a%properties%keys(n)), 0.0_dp, n_cols=size(a_real2_ptr,1), & - ptr2=aa_real2_ptr, error=error, overwrite=.true.) - PASS_ERROR(error) - do i=0,n1-1 - do j=0,n2-1 - do k=0,n3-1 - aa_real2_ptr(:,((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_real2_ptr(:,:) - end do - end do - end do - - case(T_CHAR_A) - if (.not. assign_pointer(a, string(a%properties%keys(n)), a_char_ptr)) then - RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) - end if - call add_property(aa, string(a%properties%keys(n)), repeat(' ', TABLE_STRING_LENGTH), ptr=aa_char_ptr, error=error, overwrite=.true.) - PASS_ERROR(error) - do i=0,n1-1 - do j=0,n2-1 - do k=0,n3-1 - aa_char_ptr(:,((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_char_ptr(:,:) - end do - end do - end do - - case default - RAISE_ERROR('supercell: bad property type '//a%properties%entries(i)%type, error) - end select - end do - - if(present(supercell_index_name)) then - if( has_property(aa, trim(supercell_index_name)) ) then - call print_message('WARNING', "supercell_index_name = "//trim(supercell_index_name)//" but it is already present in atoms object, it will be overwritten.") - endif - call add_property(aa, trim(supercell_index_name), 0, n_cols=3, ptr2=supercell_index, error=error, overwrite=.true.) - PASS_ERROR(error) - endif - - do i = 0,n1-1 - do j = 0,n2-1 - do k = 0,n3-1 - p = a%lattice .mult. (/i,j,k/) - do n = 1,a%N - nn = ((i*n2+j)*n3+k)*a%n+n - ! overwrite position with shifted pos - aa%pos(:,nn) = a%pos(:,n)+p - if(present(supercell_index_name)) supercell_index(:,nn) = (/i,j,k/) - end do - end do - end do - end do - - end subroutine supercell - - - !% Create a supercell of size sx and sy out of unit cell that are rotated - !% by phi in the x-y plane. - !% - !% The final cell might be distorted, but distortions become smaller then - !% sx and sy grow. The strain tensor that describes these distortions is - !% returned in the optional parameter eps. - !% - !% If phi_min is given, the angle that minimizes the norm of the strain - !% tensor will be determined using a downhill search starting from phi. - !% The minimum angle is then output in phi_min. - subroutine rotated_supercell(at, unitcell, sx, sy, phi, phi_min, eps, error) - implicit none - - type(Atoms), intent(inout) :: at - type(Atoms), intent(in) :: unitcell - real(DP), intent(in) :: sx, sy - real(DP), intent(in) :: phi - real(DP), optional, intent(out) :: phi_min - real(DP), optional, intent(out) :: eps(2, 2) - integer, optional, intent(out) :: error - - ! --- - - real(DP), parameter :: initial_step_size = 0.001_DP - - integer :: i, j, jn, n1, n2, m1, m2 - - real(DP) :: p1, p3, p5, en1, en3, en5, step_size, d, d0 - real(DP) :: x(3), T(2, 2), Tr(2, 2), lattice(3, 3) - - logical, allocatable :: mask(:) - - ! --- - - INIT_ERROR(error) - - ! - ! Determine nearest neighbor distance - ! - - d0 = sum(unitcell%lattice) - do i = 1, at%N-1 - do j = i+1, at%N - d0 = min(d0, distance_min_image(at, i, j)) - enddo - enddo - - ! - ! Determine parameters of the rotated supercell - ! - - if (present(phi_min)) then - step_size = initial_step_size - p3 = phi - call find_rotated_supercell(unitcell, sx, sy, p3, n1, n2, m1, m2, eps) - en3 = sqrt(sum(eps*eps)) - - do while (step_size > 1e-6) - p1 = p3-step_size - p5 = p3+step_size - - call find_rotated_supercell( & - unitcell, sx, sy, p1, n1, n2, m1, m2, eps) - en1 = sqrt(sum(eps*eps)) - call find_rotated_supercell( & - unitcell, sx, sy, p5, n1, n2, m1, m2, eps) - en5 = sqrt(sum(eps*eps)) - - if (en1 < en3 .and. en5 < en3) then - if (en1 < en5) then - p3 = p1 - en3 = en1 - else - p3 = p5 - en3 = en5 - endif - else if (en1 < en3) then - p3 = p1 - en3 = en1 - else if (en5 < en3) then - p3 = p5 - en3 = en5 - else - step_size = step_size * 0.1_DP - endif - enddo - - phi_min = p3 - call find_rotated_supercell( & - unitcell, sx, sy, phi_min, n1, n2, m1, m2, eps) - else - call find_rotated_supercell( & - unitcell, sx, sy, phi, n1, n2, m1, m2, eps) - endif - - ! - ! Create template supercell - ! - - call supercell( & - at, unitcell, & - abs(n1)+abs(m1)+2, & - abs(n2)+abs(m2)+2, & - 1, error=error) - PASS_ERROR(error) - - ! - ! Transform from unrotated to rotated cell - ! - - allocate(mask(at%N)) - mask = .true. - - ! n2 is negative for 0 < phi < pi/2 - at%pos(2, :) = at%pos(2, :) + n2*unitcell%lattice(2, 2) - - T(:, 1) = n1*unitcell%lattice(1:2, 1) + n2*unitcell%lattice(1:2, 2) - T(:, 2) = m1*unitcell%lattice(1:2, 1) + m2*unitcell%lattice(1:2, 2) - call inverse(T, Tr) - - do i = 1, at%N - x(1:2) = matmul(Tr, at%pos(1:2, i)) - - ! Allow for reasonable epsilon. Dublicates will be removed later. - if (x(1) > -0.01_DP .and. x(1)-1.0_DP < 0.01_DP .and. & - x(2) > -0.01_DP .and. x(2)-1.0_DP < 0.01_DP) then - at%pos(1, i) = modulo(x(1), 1.0_DP)*sx - at%pos(2, i) = modulo(x(2), 1.0_DP)*sy - mask(i) = .false. - endif - enddo - - call remove_atoms(at, mask, error=error) - PASS_ERROR(error) - - lattice = 0.0_DP - lattice(1, 1) = sx - lattice(2, 2) = sy - lattice(3, 3) = at%lattice(3, 3) - call set_lattice(at, lattice, .false.) - - ! - ! Remove dublicates. - ! Any better idea to do this is greatly appreciated. It seems that any - ! threshold above always leads to either dublicates or missing atoms - ! in some situations. - ! - - call set_cutoff(at, d0*1.1_DP) - call calc_connect(at) - mask(1:at%N) = .false. - d0 = 0.5_DP*d0 - do i = 1, at%N - do jn = 1, n_neighbours(at, i) - j = neighbour(at, i, jn, distance=d) - if (i < j) then - if (d < d0) then - mask(i) = .true. - endif - endif - enddo - enddo - call remove_atoms(at, mask(1:at%N), error=error) - PASS_ERROR(error) - - deallocate(mask) - - endsubroutine rotated_supercell - - - !% Find the lattice parameters for the rotated supercell - subroutine find_rotated_supercell( & - unitcell, sx, sy, phi, n1, n2, m1, m2, eps) - implicit none - - type(Atoms), intent(in) :: unitcell - real(DP), intent(in) :: sx, sy - real(DP), intent(in) :: phi - integer, intent(out) :: n1, n2 - integer, intent(out) :: m1, m2 - real(DP), optional, intent(out) :: eps(2, 2) !% strain - - ! --- - - ! / sx \ - ! n1 a1 + n2 a2 = | | - ! \ 0 / - ! - ! / 0 \ - ! m1 a1 + m2 a2 = | | - ! \ sy / - - real(DP) :: l1, l2, sphi, cphi, tphi, n2r, m2r - real(DP) :: a1(2), a2(2), b1(2), b2(2) - - ! --- - - l1 = unitcell%lattice(1, 1) - l2 = unitcell%lattice(2, 2) - - sphi = sin(phi) - cphi = cos(phi) - tphi = sphi/cphi - - n2r = - sx/(sphi + cphi/tphi) - m2r = sy/(cphi + sphi*tphi) - - n1 = - nint( n2r/(l1*tphi) ) - m1 = nint( m2r/l1 *tphi ) - - n2 = nint( n2r/l2 ) - m2 = nint( m2r/l2 ) - - if (present(eps)) then - ! Compute strain - - a1 = (/ cphi*l1, sphi*l1 /) - a2 = (/ -sphi*l2, cphi*l2 /) - - b1 = n1*a1 + n2*a2 - b2 = m1*a1 + m2*a2 - - eps(1, 1) = b1(1)/sx - 1.0_DP - eps(2, 1) = b1(2)/sx - eps(1, 2) = b2(1)/sy - eps(2, 2) = b2(2)/sy - 1.0_DP - endif - - endsubroutine find_rotated_supercell - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! diamond(myatoms, a) - ! - !% Creates an 8-atom diamond-structure with cubic lattice constant of 'a' - !% and atomic number 'Z', e.g. in Python:: - !% - !% a = diamond(5.44, 14) # Silicon unit cell - !% - !% Or, in Fortran:: - !% - !% type(Atoms) :: at - !% ... - !% call diamond(at, 5.44_dp, 14) - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine diamond(myatoms, a, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a - integer, intent(in), optional :: Z(:) - - call initialise(myatoms, 8, & - reshape((/a,0.0_dp,0.0_dp,0.0_dp,a,0.0_dp,0.0_dp,0.0_dp,a/), (/3,3/))) - - myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) ! sublattice 1 - myatoms%pos(:,2) = a*(/0.25_dp, 0.25_dp, 0.25_dp/) ! sublattice 2 - myatoms%pos(:,3) = a*(/0.50_dp, 0.50_dp, 0.00_dp/) ! sublattice 1 - myatoms%pos(:,4) = a*(/0.75_dp, 0.75_dp, 0.25_dp/) ! sublattice 2 - myatoms%pos(:,5) = a*(/0.50_dp, 0.00_dp, 0.50_dp/) ! sublattice 1 - myatoms%pos(:,6) = a*(/0.75_dp, 0.25_dp, 0.75_dp/) ! sublattice 2 - myatoms%pos(:,7) = a*(/0.00_dp, 0.50_dp, 0.50_dp/) ! sublattice 1 - myatoms%pos(:,8) = a*(/0.25_dp, 0.75_dp, 0.75_dp/) ! sublattice 2 - - if (present(Z)) then - if (size(Z) == 1) then - myatoms%Z = Z(1) - if (has_property(myatoms, 'mass')) & - myatoms%mass = ElementMass(Z(1)) - else if (size(Z) == 2) then - myatoms%Z(1:7:2) = Z(1) - if (has_property(myatoms, 'mass')) & - myatoms%mass(1:7:2) = ElementMass(Z(1)) - - myatoms%Z(2:8:2) = Z(2) - if (has_property(myatoms, 'mass')) & - myatoms%mass(2:8:2) = ElementMass(Z(2)) - else - call system_abort("diamond got passed Z with size="//size(Z)//" which isn't 1 or 2") - endif - - call set_atoms(myatoms,myatoms%Z) - endif - end subroutine diamond - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! diamond2(myatoms, a, Z) - ! - !% Creates a 2-atom diamond-structure with cubic lattice constant of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine diamond2(myatoms, a, Z1, Z2) - type(Atoms), intent(out) :: myatoms - real(dp) :: a - integer, intent(in), optional :: Z1, Z2 - integer :: my_Z1, my_Z2 - - my_Z1 = optional_default(6, Z1) - my_Z2 = optional_default(6, Z2) - - call initialise(myatoms, 2, & - reshape((/a/2,a/2,0.0_dp,0.0_dp,a/2,a/2,a/2,0.0_dp,a/2/), (/3,3/))) - - myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) - myatoms%pos(:,2) = a*(/0.25_dp, 0.25_dp, 0.25_dp/) - - call set_atoms(myatoms,(/my_Z1,my_Z2/)) - - end subroutine diamond2 - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! beta_tin(myatoms, a, c, Z) - ! - !% Creates a 2-atom beta-tin structure with lattice constants of a and c - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine beta_tin(myatoms, a, c, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a, c - integer, intent(in), optional :: Z - - call initialise(myatoms, 2, & - reshape((/ 0.5_dp*a,-0.5_dp*a,-0.5_dp*c, & - &-0.5_dp*a, 0.5_dp*a,-0.5_dp*c, & - & 0.5_dp*a, 0.5_dp*a, 0.5_dp*c /), (/3,3/) )) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ -0.125_dp, -0.375_dp, 0.25_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.125_dp, 0.375_dp, -0.25_dp /)) - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine beta_tin - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! beta_tin4(myatoms, a, c, Z) - ! - !% Creates a 4-atom beta-tin structure with lattice constants of a and c - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine beta_tin4(myatoms, a, c, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a, c - integer, intent(in), optional :: Z - - call initialise(myatoms, 4, & - reshape((/a, 0.0_dp, 0.0_dp, 0.0_dp, a, 0.0_dp, 0.0_dp, 0.0_dp, c/), (/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.00_dp, 0.00_dp, 0.00_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.50_dp, 0.50_dp, 0.50_dp /)) - myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 0.00_dp, 0.50_dp, 0.25_dp /)) - myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 0.50_dp, 0.00_dp, 0.75_dp /)) - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine beta_tin4 - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! fcc(myatoms, a, Z) - ! - !% Creates a 4-atom fcc-structure with cubic lattice constant of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine fcc(myatoms, a, Z) - type(Atoms), intent(out) :: myatoms - real(dp) :: a - integer, intent(in), optional :: Z - - call initialise(myatoms, 4, & - reshape((/a,0.0_dp,0.0_dp,0.0_dp,a,0.0_dp,0.0_dp,0.0_dp,a/), (/3,3/))) - - myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) - myatoms%pos(:,2) = a*(/0.50_dp, 0.50_dp, 0.00_dp/) - myatoms%pos(:,3) = a*(/0.50_dp, 0.00_dp, 0.50_dp/) - myatoms%pos(:,4) = a*(/0.00_dp, 0.50_dp, 0.50_dp/) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine fcc - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! fcc1(myatoms, a, Z) - ! - !% Creates a 1-atom fcc-structure with cubic lattice constant of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine fcc1(myatoms, a, Z) - type(Atoms), intent(out) :: myatoms - real(dp) :: a - integer, intent(in), optional :: Z - integer :: my_Z - - my_Z = optional_default(6, Z) - - call initialise(myatoms, 1, & - reshape((/a/2,a/2,0.0_dp,0.0_dp,a/2,a/2,a/2,0.0_dp,a/2/), (/3,3/))) - - myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) - - call set_atoms(myatoms,(/my_Z/)) - - end subroutine fcc1 - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! hcp(myatoms, a, Z) - ! - !% Creates a 2-atom hcp lattice with lattice constants of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine hcp(myatoms, a, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a - integer, intent(in), optional :: Z - - call initialise(myatoms, 2, & - reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.0_dp, 0.0_dp, a*sqrt(8.0_dp/3.0_dp) /),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 0.5_dp /)) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine hcp - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! sh(myatoms, a, Z) - ! - !% Creates a 1-atom simple hexagonal lattice with lattice constants of 'a' and 'c' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine sh(myatoms, a, c, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a, c - integer, intent(in), optional :: Z - - call initialise(myatoms, 1, & - reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.0_dp, 0.0_dp, c /),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine sh - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! sh2(myatoms, a, Z) - ! - !% Creates a 2-atom simple hexagonal lattice with lattice constants of 'a' and 'c' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine sh2(myatoms, a, c, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a, c - integer, intent(in), optional :: Z - - call initialise(myatoms, 2, & - reshape( (/ a, 0.0_dp, 0.0_dp, & - & 0.0_dp, sqrt(3.0_dp)*a, 0.0_dp, & - & 0.0_dp, 0.0_dp, c /),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.5_dp, 0.5_dp, 0.0_dp /)) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine sh2 - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! imma(myatoms, a, b, c, u, Z) - ! - !% Creates a 2-atom Imma cell - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine imma(myatoms, a, b, c, u, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a, b, c, u - integer, intent(in), optional :: Z - - call initialise(myatoms, 2, & - 0.5_dp * reshape( (/ a, b, -c, & - -a, b, c, & - a, -b, c /),(/3,3/))) - - !myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.25_dp, 0.25_dp+u, u /)) - !myatoms%pos(:,2) = -matmul(myatoms%lattice, (/ 0.25_dp, 0.25_dp+u, u /)) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.00_dp, 0.00_dp, 0.00_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.50_dp, 0.50_dp+u, u /)) - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine imma - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! imma4(myatoms, a, b, c, u, Z) - ! - !% Creates a 4-atom Imma cell - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine imma4(myatoms, a, b, c, u, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a, b, c, u - integer, intent(in), optional :: Z - - call initialise(myatoms, 4, & - reshape( (/ a, 0.0_dp, 0.0_dp, & - 0.0_dp, b, 0.0_dp, & - 0.0_dp, 0.0_dp, c /),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.00_dp, 0.00_dp, 0.00_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.50_dp, 0.50_dp, 0.50_dp /)) - myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 0.00_dp, 0.50_dp, u /)) - myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 0.50_dp, 0.00_dp, 0.50_dp + u /)) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine imma4 - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! sc(myatoms, a, Z) - ! - !% Creates a 1-atom simple cubic lattice with lattice constants of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine sc(myatoms, a, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a - integer, intent(in), optional :: Z - - call initialise(myatoms, 1, & - reshape( (/ a, 0.0_dp, 0.0_dp, & - & 0.0_dp, a, 0.0_dp, & - & 0.0_dp, 0.0_dp, a /),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine sc - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! bcc(myatoms, a, Z) - ! - !% Creates a 2-atom bcc-structure with cubic lattice constant of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine bcc(myatoms, a, Z) - type(Atoms), intent(out) :: myatoms - real(dp) :: a - integer, intent(in), optional :: Z - - call initialise(myatoms, 2, & - reshape((/a,0.0_dp,0.0_dp,0.0_dp,a,0.0_dp,0.0_dp,0.0_dp,a/), (/3,3/))) - - myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) - myatoms%pos(:,2) = a*(/0.50_dp, 0.50_dp, 0.50_dp/) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine bcc - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! bcc1(myatoms, a, Z) - ! - !% Creates a 1-atom primitive bcc-structure with cubic lattice constant of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine bcc1(myatoms, a, Z) - type(Atoms), intent(out) :: myatoms - real(dp) :: a - integer, intent(in), optional :: Z - - call initialise(myatoms, 1, & - & 0.5_dp*a*reshape( (/1.0_dp,-1.0_dp, 1.0_dp, & - & 1.0_dp, 1.0_dp,-1.0_dp, & - &-1.0_dp, 1.0_dp, 1.0_dp/),(/3,3/))) - - myatoms%pos(:,1) = (/0.00_dp, 0.00_dp, 0.00_dp/) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine bcc1 - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! zincblende2(myatoms, a, Z1, Z2) - ! - !% Creates a 2-atom zincblende lattice with lattice constants of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine zincblende(myatoms, a, Z1, Z2) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a - integer, intent(in), optional :: Z1, Z2 - - call initialise(myatoms, 2, & - reshape( (/0.0_dp, 0.5_dp*a, 0.5_dp*a, & - & 0.5_dp*a, 0.0_dp, 0.5_dp*a, & - & 0.5_dp*a, 0.5_dp*a, 0.0_dp /),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.00_dp, 0.00_dp, 0.00_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.25_dp, 0.25_dp, 0.25_dp /)) - - if (present(Z1).and.present(Z2)) call set_atoms(myatoms,(/Z1,Z2/)) - if (present(Z1).and. .not.present(Z2)) call set_atoms(myatoms,Z1) - if (.not. present(Z1).and. present(Z2)) call set_atoms(myatoms,Z2) - - end subroutine zincblende - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! wurtzite(myatoms, a, Z1, Z2) - ! - !% Creates a 4-atom wurtzite lattice with lattice constants of 'a' and 'c' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine wurtzite(myatoms, a, c, Z1, Z2, u) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a - real(dp), intent(in), optional :: c, u - integer, intent(in), optional :: Z1, Z2 - - real(dp) :: my_c, my_u - - my_c = optional_default(sqrt(8.0_dp/3.0_dp)*a,c) - my_u = optional_default(3.0_dp/8.0_dp,u) - - call initialise(myatoms, 4, & - reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.0_dp, 0.0_dp, my_c/),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 0.00_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 0.50_dp /)) - myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, my_u /)) - myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 0.50_dp+my_u /)) - - if (present(Z1).and.present(Z2)) call set_atoms(myatoms,(/Z1,Z1,Z2,Z2/)) - if (present(Z1).and. .not.present(Z2)) call set_atoms(myatoms,Z1) - if (.not. present(Z1).and. present(Z2)) call set_atoms(myatoms,Z2) - - end subroutine wurtzite - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! a15(myatoms, a, Z) - ! - !% Creates an 8-atom a15-structure with cubic lattice constant of 'a' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine a15(myatoms, a, Z) - type(Atoms), intent(out) :: myatoms - real(dp) :: a - integer, intent(in), optional :: Z - - call initialise(myatoms, 8, & - reshape((/a,0.0_dp,0.0_dp,0.0_dp,a,0.0_dp,0.0_dp,0.0_dp,a/), (/3,3/))) - - myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) - myatoms%pos(:,2) = a*(/0.50_dp, 0.50_dp, 0.50_dp/) - myatoms%pos(:,3) = a*(/0.25_dp, 0.50_dp, 0.00_dp/) - myatoms%pos(:,4) = a*(/0.75_dp, 0.50_dp, 0.00_dp/) - myatoms%pos(:,5) = a*(/0.00_dp, 0.25_dp, 0.50_dp/) - myatoms%pos(:,6) = a*(/0.00_dp, 0.75_dp, 0.50_dp/) - myatoms%pos(:,7) = a*(/0.50_dp, 0.00_dp, 0.25_dp/) - myatoms%pos(:,8) = a*(/0.50_dp, 0.00_dp, 0.75_dp/) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine a15 - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! graphite(myatoms, a, c, Z) - ! - !% Creates a 4-atom graphite lattice with lattice constants of 'a' and 'c' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine graphite(myatoms, a, c, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a, c - integer, intent(in), optional :: Z - - call initialise(myatoms, 4, & - reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.0_dp, 0.0_dp, c/),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.25_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.75_dp /)) - myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 0.25_dp /)) - myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 0.75_dp /)) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine graphite - - subroutine graphite_rhombohedral(myatoms, a, c, Z) - type(Atoms), intent(out) :: myatoms - real(dp), intent(in) :: a, c - integer, intent(in), optional :: Z - - call initialise(myatoms, 6, & - reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & - & 0.0_dp, 0.0_dp, c/),(/3,3/))) - - myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) - myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 0.0_dp /)) - myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 1.0_dp/3.0_dp /)) - myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 1.0_dp/3.0_dp /)) - myatoms%pos(:,5) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 2.0_dp/3.0_dp /)) - myatoms%pos(:,6) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 2.0_dp/3.0_dp /)) - - if (present(Z)) call set_atoms(myatoms,Z) - - end subroutine graphite_rhombohedral - - !% Primitive 9-atom trigonal alpha quartz cell, with lattice constants - !% `a` and `c` and internal coordinates `u` (Si), `x`, `y` and `z` (O). - subroutine alpha_quartz(at, a, c, u, x, y, z) - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a, c, u, x, y, z - - real(dp) :: lattice(3,3), a1(3), a2(3), a3(3) - - lattice = 0.0_dp - a1 = (/ 0.5_dp*a, -0.5_dp*sqrt(3.0_dp)*a, 0.0_dp /) - a2 = (/ 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp /) - a3 = (/ 0.0_dp, 0.0_dp, c /) - lattice(:,1) = a1 - lattice(:,2) = a2 - lattice(:,3) = a3 - - call initialise(at, n=9, lattice=lattice) - call set_atoms(at, (/14,14,14,8,8,8,8,8,8 /)) - - at%pos(:,1) = u*a1 + 2.0_dp/3.0_dp*a3 - at%pos(:,2) = u*a2 + 1.0_dp/3.0_dp*a3 - at%pos(:,3) = -u*a1 - u*a2 - at%pos(:,4) = x*a1 + y*a2 + (z + 2.0_dp/3.0_dp)*a3 - at%pos(:,5) = -y*a1 + (x-y)*a2 + (4.0_dp/3.0_dp + z)*a3 - at%pos(:,6) = (y-x)*a1 - x*a2 + (1.0_dp+ z)*a3 - at%pos(:,7) = y*a1 + x*a2 - (2.0_dp/3.0_dp + z)*a3 - at%pos(:,8) = -x*a1 + (y-x)*a2 - z*a3 - at%pos(:,9) = (x - y)*a1 - y*a2 - (1.0_dp/3.0_dp + z)*a3 - - call add_property(at, 'primitive_index', (/ 1,2,3,4,5,6,7,8,9 /)) - - end subroutine alpha_quartz - - !% Non-primitive 18-atom cubic quartz cell - subroutine alpha_quartz_cubic(at, a, c, u, x, y, z) - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a, c, u, x, y, z - - type(Atoms) :: a0, a1 - real(dp) :: lattice(3,3), g(3,3), t(3) - logical, allocatable, dimension(:) :: unit_cell - integer :: i - - call alpha_quartz(a0, a, c, u, x, y, z) - call supercell(a1, a0, 4, 4, 1) - call map_into_cell(a1) - - lattice = 0.0_dp - lattice(1,1) = a0%lattice(1,1)*2.0_dp - lattice(2,2) = a0%lattice(2,2)*2.0_dp - lattice(3,3) = a0%lattice(3,3) - call matrix3x3_inverse(lattice,g) - - allocate(unit_cell(a1%n)) - unit_cell = .false. - do i=1,a1%n - ! add small shift to avoid coincidental alignment - t = g .mult. a1%pos(:,i) + (/0.01_dp, 0.02_dp, 0.03_dp/) - if (all(t >= -0.5) .and. all(t < 0.5)) unit_cell(i) = .true. - end do - - call select(at, a1, mask=unit_cell) - call set_lattice(at, lattice, scale_positions=.false.) - - deallocate(unit_cell) - - end subroutine alpha_quartz_cubic - - subroutine rutile(at, a, c, u) -!For atomic coordinates see Ref. PRB 65, 224112 (2002). -!Experimental values: a=4.587, c=2.954, u=0.305 (Ref. JACS 109, 3639 (1987)). - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a, c, u - - real(dp) :: lattice(3,3), a1(3), a2(3), a3(3) - - lattice = 0.0_dp - a1 = (/ a, 0.0_dp, 0.0_dp /) - a2 = (/ 0.0_dp, a, 0.0_dp /) - a3 = (/ 0.0_dp, 0.0_dp, c /) - lattice(:,1) = a1 - lattice(:,2) = a2 - lattice(:,3) = a3 - - call initialise(at, n=6, lattice=lattice) - call set_atoms(at, (/22,22,8,8,8,8 /)) - - at%pos(:,1) = 0.0_dp - at%pos(:,2) = 0.5_dp * a1 + 0.5_dp*a2 + 0.5_dp*a3 - at%pos(:,3) = u*a1 + u*a2 - at%pos(:,4) = -u*a1 - u*a2 - at%pos(:,5) = (0.5_dp + u)*a1 + (0.5_dp - u)*a2 + 0.5_dp*a3 - at%pos(:,6) = (0.5_dp - u)*a1 + (0.5_dp + u)*a2 + 0.5_dp*a3 - - call add_property(at, 'primitive_index', (/ 1,2,3,4,5,6/)) - - end subroutine rutile - - subroutine anatase_cubic(at, a, c, u) -!Conventional 12 atoms unit cell defined as a function of a,c,u. -!Experimental values: a=3.782, c=9.502, u=0.208 (Ref. JACS 109, 3639 (1987)). - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a, c, u - - real(dp) :: lattice(3,3), a1(3), a2(3), a3(3) - - lattice = 0.0_dp - a1 = (/ a, 0.0_dp, 0.0_dp /) - a2 = (/ 0.0_dp, a, 0.0_dp /) - a3 = (/ 0.0_dp, 0.0_dp, c /) - lattice(:,1) = a1 - lattice(:,2) = a2 - lattice(:,3) = a3 - - call initialise(at, n=12, lattice=lattice) - call set_atoms(at, (/22,22,22,22,8,8,8,8,8,8,8,8 /)) - - at%pos(:,1) = (/0.0_dp*a, 0.5_dp*a, 0.0_dp /) - at%pos(:,2) = (/0.0_dp, 0.0_dp , 0.25_dp*c/) - at%pos(:,3) = (/0.5_dp*a, 0.5_dp*a, -0.25_dp*c/) - at%pos(:,4) = (/0.5_dp*a, 0.0_dp , 0.50_dp*c/) - at%pos(:,5) = (/0.0_dp , 0.5_dp*a, u * c /) - at%pos(:,6) = (/0.0_dp , 0.5_dp*a, -u * c /) - at%pos(:,7) = (/0.0_dp , 0.0_dp , (0.25_dp+u)*c /) - at%pos(:,8) = (/0.0_dp , 0.0_dp , (0.25_dp-u)*c /) - at%pos(:,9) = (/0.5_dp*a, 0.5_dp*a, (0.75_dp-u)*c /) - at%pos(:,10)= (/0.5_dp*a, 0.0_dp , (0.50_dp-u)*c /) - at%pos(:,11)= (/0.5_dp*a, 0.0_dp , -(0.50_dp-u)*c /) - at%pos(:,12)= (/0.5_dp*a, 0.5_dp*a, -(0.25_dp-u)*c /) - - call add_property(at, 'primitive_index', (/ 1,2,3,4,5,6,7,8,9,10,11,12/)) - - end subroutine anatase_cubic - -subroutine anatase(at, a, c, u) -!Conventional 6 atoms unit cell defined as a function of a,c,u. -!Experimental values: a=3.782, c=9.502, u=0.208 (Ref. JACS 109, 3639 (1987)). - type(Atoms), intent(out) :: at - real(dp), intent(in) :: a, c, u - real(dp) :: uu - - real(dp) :: lattice(3,3), a1(3), a2(3), a3(3) - - lattice = 0.0_dp - a1 = (/ a, 0.0_dp, 0.0_dp /) - a2 = (/ 0.0_dp, a, 0.0_dp /) - a3 = (/ 0.5_dp*a, 0.5_dp*a, 0.5_dp*c /) - lattice(:,1) = a1 - lattice(:,2) = a2 - lattice(:,3) = a3 - - call initialise(at, n=6, lattice=lattice) - call set_atoms(at, (/22, 22,8,8,8,8/)) - - uu = u - 1.0_dp/8.0_dp - at%pos(:,1) = (/0.0_dp , 0.75_dp*a, 0.125_dp*c/) - at%pos(:,2) = (/0.5_dp*a , 0.75_dp*a, 0.375_dp*c/) - at%pos(:,3) = (/0.0_dp , 0.25_dp*a, uu*c /) - at%pos(:,4) = (/0.0_dp , 0.75_dp*a, (0.25_dp+uu)*c/) - at%pos(:,5) = (/0.5_dp*a , 0.25_dp*a, (0.5_dp -uu)*c/) - at%pos(:,6) = (/0.5_dp*a , 0.75_dp*a, (0.25_dp-uu)*c/) - - call add_property(at, 'primitive_index', (/1,2,3,4,5,6/)) - - end subroutine anatase - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Given a lattice type ('P','I','F','A','B','C') and a motif, - !% creates an atoms object which consists of the motif - !% applied to each lattice point in one unit cell. - !% This object can then be supercelled. - !% - !% e.g. The following code creates the YBCO superconductor - !% structure, and allows the oxygen positions to be changed - !% by altering delta_O: - !% - !%> type(atoms) :: ybco - !%> type(atoms) :: big_ybco - !%> type(table) :: motif - !%> real(dp), dimension(3,3) :: lattice - !%> real(dp) :: delta_O = 0.03_dp - !%> - !%> lattice = make_lattice(3.8227_dp,3.8827_dp,11.6802_dp) - !%> - !%> call allocate(motif,1,3,0,0,13) - !%> - !%> call append(motif,Atomic_Number('Y'), & - !%> (/real(0.5,dp),real(0.5,dp),real(0.5,dp)/)) - !%> call append(motif,Atomic_Number('Ba'), - !%> (/real(0.5,dp),real(0.5,dp),real((1.0/6.0),dp)/)) - !%> call append(motif,Atomic_Number('Ba'), - !%> (/real(0.5,dp),real(0.5,dp),real((5.0/6.0),dp)/)) - !%> call append(motif,Atomic_Number('Cu'), - !%> (/real(0.0,dp),real(0.0,dp),real(0.0,dp)/)) - !%> call append(motif,Atomic_Number('Cu'), - !%> (/real(0.0,dp),real(0.0,dp),real((1.0/3.0),dp)/)) - !%> call append(motif,Atomic_Number('Cu'), - !%> (/real(0.0,dp),real(0.0,dp),real((2.0/3.0),dp)/)) - !%> call append(motif,Atomic_Number('O'), - !%> (/real(0.0,dp),real(0.0,dp),real((1.0/6.0),dp)/)) - !%> call append(motif,Atomic_Number('O'), - !%> (/real(0.0,dp),real(0.5,dp),real(0.0,dp)/)) - !%> call append(motif,Atomic_Number('O'), & - !%> (/real(0.5,dp),real(0.0,dp),real((1.0/3.0),dp)+delta_O/)) - !%> call append(motif,Atomic_Number('O'), & - !%> (/real(0.0,dp),real(0.5,dp),real((1.0/3.0),dp)+delta_O/)) - !%> call append(motif,Atomic_Number('O'), & - !%> (/real(0.5,dp),real(0.0,dp),real((2.0/3.0),dp)-delta_O/)) - !%> call append(motif,Atomic_Number('O'), & - !%> (/real(0.0,dp),real(0.5,dp),real((2.0/3.0),dp)-delta_O/)) - !%> call append(motif,Atomic_Number('O'), & - !%> (/real(0.0,dp),real(0.0,dp),real((5.0/6.0),dp)/)) - !%> - !%> ybco = make_structure(lattice,'P',motif) - !%> - !%> call supercell(big_ybco,ybco,2,2,2) - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function make_structure(lattice, type, motif) result(structure) - - real(dp), dimension(3,3), intent(in) :: lattice - type(table), intent(in) :: motif - character(1), intent(in) :: type ! P,I,F,A,B or C - type(Atoms) :: structure - !local variables - integer :: i, j, n - type(table) :: points - - !Check the motif - if (motif%N < 1) call system_abort('Make_Structure: Must have at least one atom in motif') - if (motif%intsize /= 1 .or. motif%realsize /= 3) & - call system_abort('Make_Structure: Motif must have 1 int and 3 reals') - - !Set up the lattice points - call allocate(points,0,3,0,0,4) - call append(points, realpart=(/0.0_dp,0.0_dp,0.0_dp/)) - - select case(type) - case('P') - !Primitive. No extra points - case('I') - !Body centred - call append(points, realpart=(/0.5_dp,0.5_dp,0.5_dp/)) - case('F') - !Face centred - call append(points, realpart=(/0.5_dp,0.5_dp,0.0_dp/)) - call append(points, realpart=(/0.5_dp,0.0_dp,0.5_dp/)) - call append(points, realpart=(/0.0_dp,0.5_dp,0.5_dp/)) - case('A') - call append(points, realpart=(/0.0_dp,0.5_dp,0.5_dp/)) - case('B') - call append(points, realpart=(/0.5_dp,0.0_dp,0.5_dp/)) - case('C') - call append(points, realpart=(/0.5_dp,0.5_dp,0.0_dp/)) - case default - call system_abort('Make_Structure: Unknown lattice type: '//type) - end select - - call initialise(structure,(motif%N * points%N),lattice) - - do j = 1, points%N - do i = 1, motif%N - - if (motif%int(1,i) < 1) call system_abort('Make_Structure: Atom '//i//' not recognised') - - n = (j-1)*motif%N + i - - structure%Z(n) = motif%int(1,i) - if (has_property(structure, 'mass')) & - structure%mass(n) = ElementMass(structure%Z(n)) - structure%pos(:,n) = lattice .mult. (motif%real(:,i) + points%real(:,j)) - - end do - end do - - call finalise(points) - - end function make_structure - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% create a supercell of a structure, read from a file, with chosen - !% volume per atom or volume per unit cell, with desired supercell - !% repeats, and specified Z values. - !% file may contain default Z values as a property Z_values='Z1 Z2 ...' - !% structures that begin with . or / are searched for as paths, - !% and everything else is searched for in 'QUIP_ARCH/structures/struct.xyz' - !% or in 'HOME/share/quip_structures/struct.xyz' - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function structure_from_file(struct, vol_per_atom, vol_per_unit_cell, repeat, Z_values_str, error) result(dup_cell) - character(len=*), intent(in) :: struct - real(dp), intent(in), optional :: vol_per_atom, vol_per_unit_cell - integer, intent(in), optional :: repeat(3) - character(len=*), intent(in), optional :: Z_values_str - integer, intent(out), optional :: error - type(Atoms) :: dup_cell - - character(len=STRING_LENGTH) :: struct_file - character(len=STRING_LENGTH) :: quip_structs_dir - type(Atoms) :: cell - real(dp) :: vol, scale - integer :: stat - character(len=STRING_LENGTH) :: Z_values_str_use - character(len=STRING_LENGTH), allocatable :: Z_values_a(:) - integer, allocatable :: Z_values(:), new_Z(:) - integer :: i, n_types, n_fields - real(dp) :: u_vol_per_atom, u_vol_per_unit_cell - integer :: l_error - - INIT_ERROR(error) - - if (minval(repeat) <= 0) & - call system_abort("all elements of repeat='"//repeat//"' must be >= 1") - - u_vol_per_atom = optional_default(-1.0_dp, vol_per_atom) - u_vol_per_unit_cell = optional_default(-1.0_dp, vol_per_unit_cell) - - if (u_vol_per_atom > 0.0_dp .and. u_vol_per_unit_cell > 0.0_dp) & - call system_abort("Only one of u_vol_per_atom="//u_vol_per_atom//" and u_vol_per_unit="//u_vol_per_unit_cell//" cell can be specified") - if (u_vol_per_atom <= 0.0_dp .and. u_vol_per_unit_cell <= 0.0_dp) & - call system_abort("One of u_vol_per_atom ="//u_vol_per_atom//"and u_vol_per_unit ="//u_vol_per_unit_cell//"cell must be specified") - - if (struct(1:1) == '.' .or. struct(1:1) == '/') then - struct_file = trim(struct) - else - call get_env_var("QUIP_STRUCTS_DIR", quip_structs_dir, stat) - if (stat /= 0) then - call get_env_var("QUIP_ROOT", quip_structs_dir, stat) - if (stat /= 0) then - call get_env_var("HOME", quip_structs_dir, stat) - if (stat /= 0) & - call system_abort("Could not get QUIP_STRUCTS_DIR or QUIP_ROOT or HOME env variables") - quip_structs_dir = trim(quip_structs_dir) // "/share/quip_structures" - else - quip_structs_dir = trim(quip_structs_dir) // "/structures" - endif - endif - struct_file = trim(quip_structs_dir)//"/"//trim(struct)//".xyz" - endif - call read(cell, struct_file, error=l_error) - if (l_error /= 0) then - call print("structure_from_file looks for structure files in this order:", PRINT_ALWAYS) - call print(" $QUIP_STRUCTS_DIR", PRINT_ALWAYS) - call print(" $QUIP_ROOT/structures", PRINT_ALWAYS) - call print(" $HOME/share/quip_structures", PRINT_ALWAYS) - RAISE_ERROR("file '"//trim(struct_file)//"' not found", error) - endif - - n_types=maxval(cell%Z)-minval(cell%Z) + 1 - allocate(Z_values(n_types)) - allocate(new_Z(cell%N)) - - if (present(Z_values_str)) then - Z_values_str_use = trim(Z_values_str) - endif - if (len_trim(Z_values_str_use) <= 0) then - if (.not. get_value(cell%params, "z_values", Z_values_str_use)) then - RAISE_ERROR("structure_from_file: no appropriate Z values in cell file or Z_values_str argument", error) - endif - endif - - allocate(Z_values_a(n_types+1)) - call split_string_simple(trim(Z_values_str_use), Z_values_a, n_fields, " ", error) - PASS_ERROR(error) - - if (n_fields /= n_types+1) then - RAISE_ERROR("structure_from_file: got n_types="//n_types//" but n_types+1 /= n_fields="//n_fields, error) - endif - - do i=1, n_types - read (unit=Z_values_a(i+1),fmt=*) Z_values(i) - end do - deallocate(Z_values_a) - - do i=1, n_types - where (cell%Z == i) - new_Z = Z_values(i) - end where - end do - call set_atoms(cell, new_Z) - - vol = cell_volume(cell) - if (u_vol_per_atom > 0.0_dp) then - scale = 1.0_dp/vol**(1.0_dp/3.0_dp) * (cell%N*u_vol_per_atom)**(1.0_dp/3.0_dp) - else - scale = 1.0_dp/vol**(1.0_dp/3.0_dp) * u_vol_per_unit_cell**(1.0_dp/3.0_dp) - endif - call set_lattice(cell, cell%lattice*scale, scale_positions=.true.) - call supercell(dup_cell, cell, repeat(1), repeat(2), repeat(3)) - - deallocate(Z_values) - deallocate(new_Z) - - end function structure_from_file - - !% Transform cell and lattice coordinates by the 3 x 3 matrix `t` - subroutine transform(at_out, at_in, t) - type(Atoms), intent(out)::at_out !% Output - type(Atoms), intent(in) ::at_in !% Input - real(dp), intent(in)::t(3,3) - - at_out = at_in - call set_lattice(at_out,(t .mult. at_in%lattice), scale_positions=.true.) - end subroutine transform - - - !% - !% Subgraph isomorphism identifier based on J.R. Ullmann, JACM 23(1) 31-42 (1976) - !% - !% Slight modifications are that if we include two unconnected vertices in the subgraph - !% then the corresponding vertices in the isomorphism MUST also be disconnected. - !% i.e. if we don\'t include a bond between two atoms it is because it really isn\'t there. - !% - !% Pattern matching problems are combinatorial in time required, so the routine itself - !% has seven different escape routes; the first six try to quickly fail and prevent the - !% main part of the algorithm from executing at all. - !% - !% 'at' is the atoms structure with connectivity data precalculated to at least first nearest neighbours - !% - !% 'motif' is an integer matrix describing the connectivity of the region you wish to match. - !% it has dimension (number of atoms, max number of neighbours + 1) - !% motif(i,1) is the atomic number of an atom - !% motif(i,2), motif(i,3) etc. are the indices of atoms to which this atom connects in this motif - !% or zero if there are no more neighbours. - !% - !% E.g. to match a water molecule we could use: - !% - !%> water_motif = reshape( (/ 8, 1, 1, & - !%> 2, 1, 1, & - !%> 3, 0, 0 /), (/3,3/) ) - !% - !% or, alternatively: - !%> water_motif2 = reshape( (/ 1, 8, 1, & - !%> 2, 1, 2, & - !%> 0, 3, 0/), (/3,3/) ) - !% - !% and for an alpha carbon - !%> O - !%> | - !%> N - C - C - !%> | - !%> H - !%> - !%> c_alpha = reshape( (/ 6,6,7,8,1, & - !%> 2,1,1,2,1, & - !%> 3,4,0,0,0, & - !%> 5,0,0,0,0/), (/5,4/) ) - !% - !% The routine will identify an optimum atom in the motif which it will try to find in the - !% atoms structure before doing any further matching. The optimum atom is the one which - !% minimises the total number of bond hops required to include all atoms in the motif - !% - !% 'matches' is a table containing one line for each match found in the atoms structure - !% or for optimum atoms with indices between 'start' and 'end'. The integers in each line - !% give the indices of the atoms, in the same order as in the motif, which consitute a single - !% match. - !% - !% 'mask' allows individual atoms to be selected for searching, e.g. for preventing a water - !% molecule from being re-identified as an OH, and then later as two hydrogens. - !% - !% if find_all_possible_matches is true, all possible matches, not just non-overlapping ones, - !% are returned. Useful for situations where things are ambiguous and need to be resolved - !% with more information outside this routine - !% - !% The routine could optionally find hysteretically defined connections between neighbours, - !% if the alt_connect's cutoff were the same as at%cutoff(_break) - !% - subroutine find_motif(at,motif,matches,start,end,mask,find_all_possible_matches,nneighb_only,alt_connect) !,hysteretic_neighbours) - - type(atoms), intent(in), target :: at !% The atoms structure to search - integer, intent(in) :: motif(:,:) !% The motif to search for - type(table), intent(out) :: matches !% All matches - integer, optional, intent(in) :: start, end !% Start and End atomic indices for search - logical, optional, intent(in) :: mask(:) !% If present only masked atoms are searched - logical, optional, intent(in) :: find_all_possible_matches !% if true, don't exclude matches that overlap - logical, intent(in), optional :: nneighb_only - type(Connection), intent(in), optional, target :: alt_connect -! logical, optional, intent(in) :: hysteretic_neighbours - - character(*), parameter :: me = 'find_motif: ' - - integer, allocatable :: A(:,:),B(:,:),C(:,:),depth(:), neighbour_Z(:), Z(:), M0(:,:), M(:,:), & - match_indices(:), depth_real(:) - integer :: i,j,k,p,q,N,max_depth,max_depth_real, my_start,my_end, opt_atom, ji - logical :: match - type(table) :: neighbours, core_raw, core, num_species_at, num_species_motif - logical, allocatable :: assigned_to_motif(:) - logical :: do_append - logical :: do_find_all_possible_matches - logical :: my_nneighb_only - - integer :: discards(7) -! logical :: use_hysteretic_neighbours -! real(dp) :: cutoff - - - call print("find_motif", verbosity=PRINT_ANALYSIS) - call print(motif, verbosity=PRINT_ANALYSIS) - if (present(mask)) then - call print("mask", verbosity=PRINT_ANALYSIS) - call print(mask, verbosity=PRINT_ANALYSIS) - endif - - my_nneighb_only = optional_default(.true., nneighb_only) - - discards = 0 - do_find_all_possible_matches = optional_default(.false., find_all_possible_matches) - - !XXXXXXXXXXXXXXXX - !X INITIALISATION - !XXXXXXXXXXXXXXXX - - ! Check atomic numbers - if (any(motif(:,1)<1)) call system_abort(me//'Bad atomic numbers ('//motif(:,1)//')') - - ! Check for atomic connectivity - if (present(alt_connect)) then - if (.not.alt_connect%initialised) call system_abort(me//'got alt_connect uninitialised') - else - if (.not.at%connect%initialised) call system_abort(me//'got at%connect uninitialised') - endif -! use_hysteretic_neighbours = optional_default(.false.,hysteretic_neighbours) -! - if (size(motif,1).eq.0) call system_abort(me//'zero motif size') - - ! Build adjacency matrix from motif - N = size(motif,1) - allocate(A(N,N),C(N,N),depth(N)) - A = 0 - do i = 1, N - do p = 2, size(motif,2) - j = motif(i,p) - if (j>N) call system_abort(me//'Undefined atom referenced in motif ('//j//')') - if (j>0) A(i,j) = 1 - end do - end do - - ! Make array of atomic numbers in motif - allocate(Z(N)) - Z = motif(:,1) - - ! Check symmetry - if (.not.is_symmetric(A)) then - call print_title('Non-symmetic adjacency matrix') - call print(A) - call print('bad rows/columns:') - do i = 1, size(A,1) - if (.not.all(A(:,i)==A(i,:))) call print(i) - end do - call system_abort(me//'Adjacency matrix for given motif is not symmetric!') - end if - - ! Allocate matches table: the ints are atomic indices which match, in order, the connectivity info - call allocate(matches,N,0,0,0,1) - - ! Find the best atom (opt_atom) to identify and grow clusters around in the real structure - call find_optimum_central_atom(A,opt_atom,depth) - max_depth = maxval(depth) - - !XXXXXXXXXXXXXXX - !X THE ALGORITHM - !XXXXXXXXXXXXXXX - - allocate(assigned_to_motif(at%N)) - assigned_to_motif = .false. - - !Loop over all atoms looking for candidates for the optimum atom 'opt_atom' - call allocate(core_raw,4,0,0,0,1) - allocate(neighbour_Z(count(A(opt_atom,:)==1))) - neighbour_Z = pack(Z,(A(opt_atom,:)==1)) - - call print("opt_atom " // opt_atom // " Z " // Z(opt_atom), verbosity=PRINT_ANALYSIS) - - my_start = 1 - if (present(start)) then - if (start < 1 .or. start > at%N) call system_abort(me//'Starting atom is out of range ('//start//')') - my_start = start - end if - my_end = at%N - if (present(end)) then - if (end < 1 .or. end > at%N) call system_abort(me//'Ending atom is out of range ('//start//')') - my_end = end - end if - - ! if end < start then no matches will be returned, a la do loops - - do i = my_start, my_end - - call print("check atom " // i // " Z " // at%Z(i), verbosity=PRINT_ANALYSIS) - - if (present(mask)) then - if (.not.mask(i)) then - call print(" i not in mask, skipping", verbosity=PRINT_ANALYSIS) - cycle - endif - end if - - !XXXXXXXXXXXXXXXXXXXX - !X ESCAPE ROUTE 1 - !XXXXXXXXXXXXXXXXXXXX - - ! Discard atoms which don't match the atomic number of the optimum atom - - if (at%Z(i) /= Z(opt_atom)) then - call print(" i has wrong Z to match opt_atom, skipping", verbosity=PRINT_ANALYSIS) - discards(1) = discards(1) + 1 - cycle - end if - - !--------------------- - - !XXXXXXXXXXXXXXXXXXXX - !X ESCAPE ROUTE 2 - !XXXXXXXXXXXXXXXXXXXX - - ! Check if the real atom's neighbours can be matched with those in the motif - - if (.not.atoms_compatible(at,i,A,Z,opt_atom,nneighb_only=nneighb_only,alt_connect=alt_connect)) then - discards(2) = discards(2) + 1 - call print(" i has incompatible neighbour list, skipping", verbosity=PRINT_ANALYSIS) - cycle - end if - - !--------------------- - - ! Grow a cluster around the real atom i which is max_depth hops deep - call wipe(core_raw) - call append(core_raw,(/i,0,0,0/)) - call bfs_grow(at,core_raw,max_depth,nneighb_only = nneighb_only, min_images_only = .true.,alt_connect=alt_connect) - call finalise(core) - if (present(mask)) then - call select(core, core_raw, mask(int_part(core_raw,1))) - else - core = core_raw - end if - - - !XXXXXXXXXXXXXXXXXXXX - !X ESCAPE ROUTE 3 - !XXXXXXXXXXXXXXXXXXXX - - ! If the number of atoms in the cluster is less than those in the motif we can't have a match - if (core%N < N) then - call print(" i's cluster is too small, skipping", verbosity=PRINT_ANALYSIS) - discards(3) = discards(3) + 1 - cycle - end if - - !--------------------- - - ! Count the number of each atomic species in the motif and in the cluster - call allocate(num_species_motif,2,0,0,0,6) - call allocate(num_species_at,2,0,0,0,6) - do k = 1, N - p = find_in_array(int_part(num_species_motif,1),Z(k)) - if (p == 0) then - call append(num_species_motif,(/Z(k),1/)) - else - num_species_motif%int(2,p) = num_species_motif%int(2,p) + 1 - end if - end do - do k = 1, core%N - p = find_in_array(int_part(num_species_at,1),at%Z(core%int(1,k))) - if (p == 0) then - call append(num_species_at,(/at%Z(core%int(1,k)),1/)) - else - num_species_at%int(2,p) = num_species_at%int(2,p) + 1 - end if - end do - - !XXXXXXXXXXXXXXXXXXXX - !X ESCAPE ROUTE 4 - !XXXXXXXXXXXXXXXXXXXX - - !Compare the tables: if there are more atoms of one type in motif than core then a fit is impossible - match = .true. - do k = 1, num_species_motif%N - p = find_in_array(int_part(num_species_at,1),num_species_motif%int(1,k)) - if (p == 0) then - match = .false. - exit - else if (num_species_at%int(2,p) < num_species_motif%int(2,k)) then - match = .false. - exit - end if - end do - call finalise(num_species_motif) - call finalise(num_species_at) - if (.not.match) then - call print(" i's cluster has mismatching atom numbers, skipping", verbosity=PRINT_ANALYSIS) - discards(4) = discards(4) + 1 - cycle - end if - - !--------------------- - - ! Create adjacency matrix - allocate(B(core%N,core%N)) - B = 0 - do p = 1, core%N - k = core%int(1,p) - do ji=1, n_neighbours(at, k, alt_connect=alt_connect) - j = neighbour(at, k, ji, alt_connect=alt_connect) - if (my_nneighb_only) then - if (.not. is_nearest_neighbour(at, k, ji, alt_connect=alt_connect)) cycle - endif - q = find_in_array(core%int(1,1:core%N),j) - if (q > 0) then - B(p,q) = 1 - B(q,p) = 1 - endif - end do ! ji - end do !p - - call print("core", verbosity=PRINT_ANALYSIS) - call print(core, verbosity=PRINT_ANALYSIS) - call print("adjacency mat", verbosity=PRINT_ANALYSIS) - call print(B, verbosity=PRINT_ANALYSIS) - - ! Find depth of connectivity for real atoms - allocate(depth_real(core%N)) - call find_connectivity_depth(B,1,depth_real) - max_depth_real = maxval(depth_real) - - !XXXXXXXXXXXXXXXXXX - !X ESCAPE ROUTE 5 - !XXXXXXXXXXXXXXXXXX - - ! If there are atoms which aren't deep enough in the real structure then a match is impossible - if (max_depth > max_depth_real) then - call print(" i's cluster isn't actually keep enough, skipping", verbosity=PRINT_ANALYSIS) - deallocate(B,depth_real) - discards(5) = discards(5) + 1 - cycle - end if - - !--------------------- - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X THE MAIN PART OF THE ALGORITHM - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! Create possibility matrix M0, with the optimum atom already matched - - ! ***** THINGS CAN BE SPED UP CONSIDERABLY BY LIMITING THE NUMBER OF 1'S IN M0 ***** - - allocate(M0(N,core%N)) - M0 = 0 - M0(opt_atom,1) = 1 - do q = 2, core%N - do p = 1, N - if (p==opt_atom) cycle - if (depth_real(q) == depth(p)) then - if (atoms_compatible(at,core%int(1,q),A,Z,p,nneighb_only=nneighb_only,alt_connect=alt_connect)) M0(p,q) = 1 - end if - end do - end do - - deallocate(depth_real) - - !XXXXXXXXXXXXXXXXXX - !X ESCAPE ROUTE 6 - !XXXXXXXXXXXXXXXXXX - - ! Check to see if any atoms have no possibilities - if (any(sum(M0,dim=2)==0)) then - call print(" i has some neighbor that doesn't match, skipping", verbosity=PRINT_ANALYSIS) - deallocate(M0,B) - discards(6) = discards(6) + 1 - cycle - end if - - !--------------------- - - ! Loop over all permuations - allocate(M(N,core%N)) - call first_trial_matrix(M0,M) - match = .false. - do - - call print(" check permutation loop start", verbosity=PRINT_ANALYSIS) - ! For each trial matrix create the permuted adjacency matrix - C = matmul(M,transpose(matmul(M,B))) ! ***** THIS LINE IS ANOTHER CANDIDATE FOR OPTIMISATION ***** - ! Use sparse matrices maybe? - - if (all(C==A)) then ! match - !decode trial matrix into atomic indices - allocate(match_indices(N)) - do j = 1, N - do k = 1, core%N - if (M(j,k)==1) then - match_indices(j) = core%int(1,k) - exit - end if - end do - end do - - do_append = .true. - ! if mask is present, make sure all atoms are in mask, otherwise skip - if (present(mask)) then - if (.not. all(mask(match_indices))) do_append = .false. - end if - if (do_find_all_possible_matches) then - ! if we're finding all possible matches, skip only if _all_ atoms are already in a motif - if(all(assigned_to_motif(match_indices))) do_append = .false. - else - ! if we're not, skip if _any_ atom is already in a motif - if (any(assigned_to_motif(match_indices))) do_append = .false. - endif - - if (do_append) then - call append(matches,match_indices) - assigned_to_motif(match_indices) = .true. - call print(" found match, indices " // match_indices, verbosity=PRINT_ANALYSIS) - endif - deallocate(match_indices) - - if (.not. do_find_all_possible_matches) then - call print(" not looking for _all_ matches, finished", verbosity=PRINT_ANALYSIS) - exit - endif - end if ! match - - call next_trial_matrix(M0,M) - - !XXXXXXXXXXXXXXXXXX - !X ESCAPE ROUTE 7 - !XXXXXXXXXXXXXXXXXX - - ! If next_trial_matrix deletes the only atom we know to be fitted then all - ! permutations have been exhausted - if (M(opt_atom,1)==0) then - call print(" i has no more premutations, leaving loop", verbosity=PRINT_ANALYSIS) - discards(7) = discards(7) + 1 - exit - end if - !--------------------- - - end do - - - deallocate(B,M0,M) - - end do - - deallocate(A,C,depth,Z,neighbour_Z) - call finalise(core) - call finalise(neighbours) - - !When debugging/improving this algorithm uncomment this line - !as it gives an indication of how successful the predetection - !of bad matches is - - !call print('find_motif: Discards by level: '//discards) - - end subroutine find_motif - - !% OMIT - ! Used by find_motif to generate the first permutation matrix - subroutine first_trial_matrix(M0,M) - - integer, dimension(:,:), intent(in) :: M0 - integer, dimension(:,:), intent(inout) :: M - integer, dimension(size(M0,2)) :: taken - integer :: A,B,i,j - - A = size(M0,1) - B = size(M0,2) - M = 0 - taken = 0 - - do i = 1, A - - do j = 1, B - - if (M0(i,j) == 1 .and. taken(j) == 0) then - M(i,j) = 1 - taken(j) = 1 - exit - end if - - end do - - end do - - end subroutine first_trial_matrix - - !% OMIT - ! Used by find_motif to generate the next permutation matrix given the current one - subroutine next_trial_matrix(M0,M) - - integer, dimension(:,:), intent(in) :: M0 - integer, dimension(:,:), intent(inout) :: M - integer, dimension(size(M0,2)) :: taken - - integer :: A,B,i,j - logical :: found, placed, l1, l2 - - A = size(M,1) - B = size(M,2) - - i = A - - taken = sum(M,dim=1) - do while (i<=A .and. i>0) - - !try to move the 1 in the ith row along, or place it if it isn't there - - !find the 1 - found = .false. - j = 1 - do while(j<=B) - if (M(i,j)==1) then - found = .true. - exit - else - j = j + 1 - end if - end do - if (found) then - M(i,j) = 0 - j = j + 1 - else - j = 1 - end if - - !place it - placed = .false. - taken = sum(M,dim=1) - do while (j<=B) - l1 = M0(i,j) == 1 - l2 = taken(j) == 0 - if (l1 .and. l2) then - M(i,j) = 1 - taken(j) = 1 - placed = .true. - exit - end if - j = j + 1 - end do - if (.not.placed) then - i = i - 1 - else - i = i + 1 - end if - - end do - - end subroutine next_trial_matrix - - !% OMIT - ! Used by find_motif - subroutine find_optimum_central_atom(A,i,depth) - - integer, dimension(:,:), intent(in) :: A ! The adjacency matrix - integer, intent(out) :: i ! The optimum central atom - integer, dimension(size(A,1)), intent(out) :: depth ! The connectivity depth using this atom - - integer :: n, max_depth, new_max_depth - integer, dimension(size(A,1)) :: new_depth - - ! Starting with each atom in turn, calculate the depth of the connectivity - ! The best is the one with the smallest maximum depth - - max_depth = huge(1) - - do n = 1, size(A,1) - - call find_connectivity_depth(A,n,new_depth) - new_max_depth = maxval(new_depth) - - if (new_max_depth < max_depth) then - max_depth = new_max_depth - depth = new_depth - i = n - end if - - end do - - end subroutine find_optimum_central_atom - - !% OMIT - ! Used by find_motif - subroutine find_connectivity_depth(A,i,depth) - - integer, dimension(:,:), intent(in) :: A ! The adjacency matrix - integer, intent(in) :: i ! The central atom - integer, dimension(size(A,1)), intent(out) :: depth ! The connectivity depth using this atom - - integer :: p, q, j - logical :: atom_marked - - depth = -1 - depth(i) = 0 - atom_marked = .true. - p = -1 - - do while(atom_marked) - - atom_marked = .false. - p = p + 1 - - do q = 1, size(A,1) - - if (depth(q) == p) then !...mark its neighbours with p+1 if unmarked - - do j = 1, size(A,1) - - if (A(q,j) == 1 .and. depth(j) == -1) then - depth(j) = p + 1 - atom_marked = .true. - end if - - end do - - end if - - end do - - end do - - if (any(depth == -1)) call system_abort('find_conectivity_depth: Adjacency matrix contains dijoint regions') - - end subroutine find_connectivity_depth - - !% OMIT - ! Used by find_motif - ! Added alt_connect. - function atoms_compatible(at,i,A,Z,j,nneighb_only,alt_connect) - - type(atoms), intent(in), target :: at !the atoms structure - integer, intent(in) :: i !the atom in the atoms structure we are testing - integer, dimension(:,:), intent(in) :: A !the adjacency matrix of the motif - integer, dimension(:), intent(in) :: Z !the atomic number of the motif - integer, intent(in) :: j !the atom in the motif we are testing - logical, intent(in), optional :: nneighb_only - type(Connection), intent(in), optional, target :: alt_connect - logical :: atoms_compatible - - type(table) :: core, neighbours - logical, allocatable, dimension(:) :: neighbour_used - integer, allocatable, dimension(:) :: neighbour_Z - integer :: p,q - logical :: match, found - - ! First check the atomic numbers of the two atoms to test - if (at%Z(i) /= Z(j)) then - atoms_compatible = .false. - return - end if - - ! find nearest neighbours of real atom - call allocate(core,4,0,0,0,1) - call append(core,(/i,0,0,0/)) - call bfs_step(at,core,neighbours,nneighb_only=nneighb_only,min_images_only=.true.,alt_connect=alt_connect) - - allocate(neighbour_used(neighbours%N)) - neighbour_used = .false. - - ! find the atomic numbers of the neighbours of atom j in the motif - allocate(neighbour_Z(count(A(j,:)==1))) - neighbour_Z = pack(Z,(A(j,:)==1)) - - ! see if a tentative match between the neighbours of atom i in at and atom j in - ! the adjacency matrix is possible, just using atomic numbers - - match = .true. - - do p = 1, size(neighbour_Z) - - found = .false. - - do q = 1, neighbours%N - - if (neighbour_used(q)) cycle - - if (at%Z(neighbours%int(1,q)) == neighbour_Z(p)) then - neighbour_used(q) = .true. - found = .true. - exit - end if - end do - - if (.not.found) then - match = .false. - exit - end if - - end do - - atoms_compatible = match - - deallocate(neighbour_used,neighbour_Z) - call finalise(core) - call finalise(neighbours) - - end function atoms_compatible - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% find supercells of two lattices that are compatible (i.e. - !% equal or parallel vectors to some tolerance) - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine find_compatible_supercells(l1, l2, match_tol, n1, n2, fix_l2, max_m1, max_m2, error) - real(dp), intent(in) :: l1(3,3), l2(3,3) !% lattices of 1st and 2nd structures - real(dp), intent(in) :: match_tol !% tolerange for good enough match. - integer, intent(out) :: n1(3,3), n2(3,3) !% output supercells of 1st and 2nd structures that match well enough (new lattices = lattice . n[12] ) - logical, intent(in), optional :: fix_l2 !% if true, don't allow supercells of l2 - integer, intent(in), optional :: max_m1, max_m2 !% max range of supercells to check (bigger is slower) - integer, intent(out), optional :: error !% if present, error status return - - logical :: my_fix_l2 - integer :: my_max_m1, my_max_m2 - - real(dp) :: l1_inv(3,3), l2_inv(3,3) - type(Atoms) :: a1, a1_sc, a2, a2_sc, matches - real(dp) :: new_lattice(3,3), new_lattice_1(3,3), new_lattice_2(3,3), r - logical :: better, match - real(dp) :: best_normsq, best_vol, t_normsq, t_vol - integer i, i1, i2, i3, ji, j - - INIT_ERROR(error) - - my_fix_l2 = optional_default(.false., fix_l2) - my_max_m1 = optional_default(10, max_m1) - my_max_m2 = optional_default(10, max_m2) - - call initialise(a1, N=1, lattice=l1, error=error) - PASS_ERROR(error) - a1%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - a1%Z(1) = 1 - call supercell(a1_sc, a1, 2*my_max_m1+1, 2*my_max_m1+1, 2*my_max_m1+1, error=error) - PASS_ERROR(error) - call remove_atoms(a1_sc, 1, error=error) - PASS_ERROR(error) - a1_sc%pos(1,:) = a1_sc%pos(1,:) - a1%lattice(1,1)*my_max_m1 - a1%lattice(1,2)*my_max_m1 - a1%lattice(1,3)*my_max_m1 - a1_sc%pos(2,:) = a1_sc%pos(2,:) - a1%lattice(2,1)*my_max_m1 - a1%lattice(2,2)*my_max_m1 - a1%lattice(2,3)*my_max_m1 - a1_sc%pos(3,:) = a1_sc%pos(3,:) - a1%lattice(3,1)*my_max_m1 - a1%lattice(3,2)*my_max_m1 - a1%lattice(3,3)*my_max_m1 - call finalise(a1) - - if (my_fix_l2) then - call initialise(a2_sc, N=3, lattice=l2, error=error) - PASS_ERROR(error) - a2_sc%pos(:,1) = l2(:,1) - a2_sc%pos(:,2) = l2(:,2) - a2_sc%pos(:,3) = l2(:,3) - a2_sc%Z(1:3) = 2 - a2_sc%species(1,1:3) = "H" - a2_sc%species(2,1:3) = "e" - else - call initialise(a2, N=1, lattice=l2) - a2%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - a2%Z(1) = 2 - a2_sc%species(1,1) = "H" - a2_sc%species(2,1) = "e" - call supercell(a2_sc, a2, 2*my_max_m2+1, 2*my_max_m2+1, 2*my_max_m2+1, error=error) - PASS_ERROR(error) - call remove_atoms(a2_sc, 1, error=error) - PASS_ERROR(error) - a2_sc%pos(1,:) = a2_sc%pos(1,:) - a2%lattice(1,1)*my_max_m2 - a2%lattice(1,2)*my_max_m2 - a2%lattice(1,3)*my_max_m2 - a2_sc%pos(2,:) = a2_sc%pos(2,:) - a2%lattice(2,1)*my_max_m2 - a2%lattice(2,2)*my_max_m2 - a2%lattice(2,3)*my_max_m2 - a2_sc%pos(3,:) = a2_sc%pos(3,:) - a2%lattice(3,1)*my_max_m2 - a2%lattice(3,2)*my_max_m2 - a2%lattice(3,3)*my_max_m2 - call finalise(a2) - endif - - call add_atoms(a2_sc, a1_sc%pos(1:3,1:a1_sc%N), a1_sc%Z(1:a1_sc%N), error=error) - PASS_ERROR(error) - call set_cutoff(a2_sc, max(norm(a2_sc%lattice(:,1))/5.0_dp, norm(a2_sc%lattice(:,2))/5.0_dp, norm(a2_sc%lattice(:,3))/5.0_dp ) ) - new_lattice = 0.0_dp - new_lattice(1,1) = max(norm(a2_sc%lattice(:,1)), norm(a1_sc%lattice(:,1)))*2.0_dp - new_lattice(2,2) = max(norm(a2_sc%lattice(:,2)), norm(a1_sc%lattice(:,2)))*2.0_dp - new_lattice(3,3) = max(norm(a2_sc%lattice(:,3)), norm(a1_sc%lattice(:,3)))*2.0_dp - call set_lattice(a2_sc, new_lattice, .false.) - - call initialise(matches, N=1, lattice=new_lattice) - call remove_atoms(matches, 1) - call calc_connect(a2_sc) - do i=1, a2_sc%N - if (a2_sc%Z(i) == 2) then - do ji=1, n_neighbours(a2_sc, i) - j = neighbour(a2_sc, i, ji, distance=r) - if (a2_sc%Z(j) /= 1) cycle - if (r/max(norm(a2_sc%pos(:,i)),norm(a2_sc%pos(:,j))) <= match_tol) then - call add_atoms(matches, a2_sc%pos(:,j), 1) - call add_atoms(matches, a2_sc%pos(:,i), 2) - endif - end do - endif - end do - - if (matches%N < 6) then - RAISE_ERROR("not enough points matched to be possible to get 3-D cell", error) - endif - - call matrix3x3_inverse(l1, l1_inv) - call matrix3x3_inverse(l2, l2_inv) - - match = .false. - best_normsq = 1.0e38_dp - best_vol = 1.0e38_dp - do i1=1, matches%N, 2 - do i2=i1+2, matches%N, 2 - do i3=i2+2, matches%N, 2 - if (i2 == i1) cycle - if (i3 == i1) cycle - if (i2 == i3) cycle - new_lattice_1(:,1) = matches%pos(:, i1) - new_lattice_1(:,2) = matches%pos(:, i2) - new_lattice_1(:,3) = matches%pos(:, i3) - if (cell_volume(new_lattice_1) .feq. 0.0_dp) cycle - new_lattice_2(:,1) = matches%pos(:, i1+1) - new_lattice_2(:,2) = matches%pos(:, i2+1) - new_lattice_2(:,3) = matches%pos(:, i3+1) - if (cell_volume(new_lattice_2) .feq. 0.0_dp) cycle - t_normsq = normsq(new_lattice_1(:,1)-new_lattice_2(:,1)) + & - normsq(new_lattice_1(:,2)-new_lattice_2(:,2)) + normsq(new_lattice_1(:,3)-new_lattice_2(:,3)) - t_vol = cell_volume(new_lattice_1) + cell_volume(new_lattice_2) - better = .false. - if (t_normsq < best_normsq) then - better = .true. - else if ((t_normsq .feq. best_normsq) .and. (t_vol < best_vol)) then - better = .true. - endif - if (better) then - best_normsq = t_normsq - best_vol = t_vol - n1(:,:) = floor(matmul(l1_inv,new_lattice_1)+0.5_dp) - n2(:,:) = floor(matmul(l2_inv,new_lattice_2)+0.5_dp) - match = .true. - endif - end do - end do - end do - - if (.not. match) then - RAISE_ERROR("no good enough match", error) - endif - - end subroutine find_compatible_supercells - - ! - !% construct an arbitrary supercell from a primitive structure and a combination of primitive vectors that form supercell - ! - subroutine arbitrary_supercell(a_out, a_in, i1, error) - type(Atoms), intent(out)::a_out !% Output (big) cell - type(Atoms), intent(in)::a_in !% Input (small) cell - integer, intent(in):: i1(3,3) !% combination of primitive lattice vectors to create supercell (a_out%lattice = a_in%lattice . i1). column i specifies output pbc vector i. - integer, intent(out), optional :: error !% if present, returned error status - - integer :: dup_n1, dup_n2, dup_n3 - integer :: max_n1, max_n2, max_n3 - integer :: min_n1, min_n2, min_n3 - type(Atoms) :: a_dup - real(dp) :: new_lat(3,3), t_p(3) - integer :: f1, f2, f3 - logical, allocatable :: is_good(:) - - integer :: i, ji, j - - INIT_ERROR(error) - - ! calculate how big a simple supercell we need to encompass new arbitrary supercell - new_lat = matmul(a_in%lattice, real(i1,dp)) - dup_n1 = 0; dup_n2 = 0; dup_n3 = 0 - max_n1 = -1000000 - max_n2 = -1000000 - max_n3 = -1000000 - min_n1 = 1000000 - min_n2 = 1000000 - min_n3 = 1000000 - do f1=0,1 - do f2=0,1 - do f3=0,1 - t_p = matmul(a_in%g,f1*new_lat(:,1)+f2*new_lat(:,2)+f3*new_lat(:,3)) - max_n1 = max(max_n1, int(t_p(1)+1.0)) - max_n2 = max(max_n2, int(t_p(2)+1.0)) - max_n3 = max(max_n3, int(t_p(3)+1.0)) - min_n1 = min(min_n1, int(t_p(1)+1.0)) - min_n2 = min(min_n2, int(t_p(2)+1.0)) - min_n3 = min(min_n3, int(t_p(3)+1.0)) - end do - end do - end do - dup_n1 = max_n1 - min_n1 + 2 - dup_n2 = max_n2 - min_n2 + 2 - dup_n3 = max_n3 - min_n3 + 2 - call supercell(a_dup, a_in, dup_n1, dup_n2, dup_n3, error=error) - PASS_ERROR(error) - - ! set the new lattice and map to [-0.5, 0.5) - call set_lattice(a_dup, matmul(a_in%lattice, real(i1,dp)), .false.) - call map_into_cell(a_dup) - - ! look for close atoms - call set_cutoff(a_dup, 2.0_dp) - call calc_connect(a_dup) - allocate(is_good(a_dup%N)) - is_good = .true. - do i=1, a_dup%N - if (is_good(i)) then - do ji=1, n_neighbours(a_dup, i) - j = neighbour(a_dup, i, ji, max_dist=0.01_dp) - if (j > i) is_good(j) = .false. - end do - endif - end do - - ! select good atoms - call select(a_out, a_dup, is_good) - - end subroutine arbitrary_supercell - - subroutine remove_too_close_atoms(at, distance, error) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: distance - integer, intent(out), optional :: error - - logical, pointer :: removable_p(:) - integer, allocatable :: remove_list(:) - integer :: n_remove - integer :: i, ji, j - real(dp) :: r - - INIT_ERROR(error) - - call assign_property_pointer(at, "removable", removable_p, error) - PASS_ERROR(error) - - allocate(remove_list(at%N)) - - n_remove = 1 - do while (n_remove > 0) - call calc_connect(at) - n_remove = 0 - remove_list = 0 - do i=1, at%N - if (any(remove_list == i)) cycle - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, distance=r) - if (.not. removable_p(j)) cycle - if (r < distance) then - if (n_remove > 0) then - if (any(remove_list == j)) cycle - endif - n_remove = n_remove + 1 - remove_list(n_remove) = j - endif - end do - end do - - if (n_remove > 0) then - call remove_atoms(at, remove_list(1:n_remove), error) - endif - PASS_ERROR(error) - end do - - deallocate(remove_list) - - end subroutine remove_too_close_atoms - - function min_neighbour_dist(at) - type(Atoms), intent(in) :: at - real(dp) :: min_neighbour_dist - - real(dp) :: r - integer :: i, ji, j - - min_neighbour_dist = 1.0e38_dp - do i=1, at%N - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, distance=r) - if (r < min_neighbour_dist) min_neighbour_dist = r - end do - end do - - end function min_neighbour_dist - - function torsion_angle(at, i1, i2, i3, i4, error) - type(Atoms), intent(in) :: at - integer, intent(in) :: i1, i2, i3, i4 - integer, optional, intent(out) :: error - real(dp) :: torsion_angle - - real(dp) :: v21(3), v23(3), v34(3) - - INIT_ERROR(error) - - if (any( (/ i1, i2, i3, i3 /) < 1) .or. & - any( (/ i1, i2, i3, i3 /) > at%N)) then - RAISE_ERROR("torsion angle atom index out of bounds", error) - endif - v21 = diff_min_image(at, i2, i1) - v23 = diff_min_image(at, i2, i3) - v34 = diff_min_image(at, i3, i4) - - v21 = v21 - v23*(v21.dot.v23)/(norm(v23)*norm(v23)) - v34 = v34 - v23*(v34.dot.v23)/(norm(v23)*norm(v23)) - - torsion_angle = acos((v21.dot.v34)/(norm(v21)*norm(v34))) - end function torsion_angle - - ! find a smaller unit cell, Int. Tables for Crystallography A, Sec 9.1.8 - function delaunay_reduce(lat) result(reduced_lat) - real(dp), intent(in) :: lat(3,3) - real(dp) :: reduced_lat(3,3) - - real(dp) :: m(3,4), inner_products(4,4), m_new(3,4), inner_products_new(4,4), m_aug(3,7), norms_aug(7) - real(dp) :: norm_sum, norm_sum_new - integer :: i, j, k, min_norm(1) - logical :: any_accepted - - ! create initial basis vectors from lattice and -(a1+a2+a3) - m(1:3,1:3) = lat(1:3,1:3) - m(1:3,4) = - (lat(:,1) + lat(:,2) + lat(:,3)) - inner_products = matmul(transpose(m),m) - norm_sum = inner_products(1,1) + inner_products(2,2) + inner_products(3,3) + inner_products(4,4) - inner_products(1,1) = -1.0_dp - inner_products(2,2) = -1.0_dp - inner_products(3,3) = -1.0_dp - inner_products(4,4) = -1.0_dp - - ! while any i /= j inner products are positive - any_accepted = .true. - do while (any(inner_products > NUMERICAL_ZERO) .and. any_accepted) - any_accepted = .false. - do i=1, 4 - do j=1, 4 - if (inner_products(i,j) > NUMERICAL_ZERO) then - ! i.j is negative, try to flip i - do k=1, 4 - if (k == i) then - m_new(:,k) = -1.0_dp * m(:,k) - else if (k == j) then - m_new(:,k) = m(:,k) - else - m_new(:,k) = m(:,k) + m(:,i) - endif - end do - inner_products_new = matmul(transpose(m_new),m_new) - norm_sum_new = inner_products_new(1,1) + inner_products_new(2,2) + inner_products_new(3,3) + inner_products_new(4,4) - inner_products_new(1,1) = -1.0_dp; inner_products_new(2,2) = -1.0_dp; inner_products_new(3,3) = -1.0_dp; inner_products_new(4,4) = -1.0_dp - if (norm_sum_new < norm_sum) then ! improvement, accept - m = m_new - inner_products = inner_products_new - norm_sum = norm_sum_new - any_accepted = .true. - endif - endif ! inner_products(i,j) > NUMERICAL_ZERO - end do - end do - end do - - if (.not. any_accepted) then - call system_abort("Did a whole scan and failed to accept a trial lattice change") - endif - - ! basis is contained by 4 vectors and a1+a2, a2+a3, a3+1 - m_aug(1:3,1:4) = m(1:3,1:4) - m_aug(1:3,5) = m(1:3,1) + m(1:3,2) - m_aug(1:3,6) = m(1:3,2) + m(1:3,3) - m_aug(1:3,7) = m(1:3,3) + m(1:3,1) - - do i=1, 7 - norms_aug(i) = sum(m_aug(1:3,i)**2) - end do - ! find first 2 PBC vectors - do i=1,2 - min_norm = minloc(norms_aug) - reduced_lat(1:3,i) = m_aug(1:3,min_norm(1)) - norms_aug(min_norm(1)) = HUGE(1.0_dp) - end do - ! find third that's independent (cell_volume > 0) - reduced_lat(1:3,3) = 0.0_dp - do while (cell_volume(reduced_lat) .feq. 0.0_dp) - min_norm = minloc(norms_aug) - reduced_lat(1:3,3) = m_aug(1:3,min_norm(1)) - norms_aug(min_norm(1)) = HUGE(1.0_dp) - end do - - end function delaunay_reduce - - function map_nearest_atoms(at1, at2, types) - type(Atoms), intent(inout) :: at1, at2 - integer, intent(in) :: types(:) - real(dp) :: map_nearest_atoms - - integer, pointer :: mapping1(:), mapping2(:) - real(dp), pointer :: mapping_diff1(:,:), mapping_diff2(:,:) - integer :: i, j, min_j - real(dp) :: dist, diff(3), min_dist, min_diff(3) - - call add_property(at1, "mapping", 0, ptr=mapping1, overwrite=.true.) - call add_property(at1, "mapping_diff", 0.0_dp, n_cols=3, ptr2=mapping_diff1, overwrite=.true.) - call add_property(at2, "mapping", 0, ptr=mapping2, overwrite=.true.) - call add_property(at2, "mapping_diff", 0.0_dp, n_cols=3, ptr2=mapping_diff2, overwrite=.true.) - - map_nearest_atoms = 0.0_dp - - do i=1, at1%N - if (mapping1(i) > 0) cycle - if (find_in_array(types, at1%Z(i)) <= 0) cycle - - min_dist = huge(1.0_dp) - do j=1, at2%N - if (mapping2(j) > 0) cycle - if (at1%Z(i) /= at2%Z(j)) cycle - if (find_in_array(types, at2%Z(j)) <= 0) cycle - - diff = diff_min_image(at1, i, at2%pos(:,j)) - dist = norm(diff) - if (dist < min_dist) then - min_dist = dist - min_diff = diff - min_j = j - end if - end do - mapping1(i) = min_j - mapping_diff1(:,i) = min_diff - mapping2(min_j) = i - mapping_diff2(:,min_j) = -min_diff - map_nearest_atoms = map_nearest_atoms + min_dist**2 - end do - end function map_nearest_atoms - - ! characterization from Demkowicz and Argon PRB _72_ 245205 (2005) - ! definition of "liquid-like" approximation of line in Fig. 6 - subroutine bond_angle_mean_dev(at) - type(Atoms), intent(inout) :: at - - real(dp), pointer :: ba_mean(:), ba_dev(:) - logical, pointer :: liquid_like(:) - real(dp) :: ba, ba_sum, ba_sum_sq - real(dp) :: i_rv(3), j_rv(3) - real(dp) :: n_angles - integer :: i, n_nn, i_nn, j_nn, ii - - if (.not. assign_pointer(at, "bond_angle_mean", ba_mean)) & - call add_property(at, "bond_angle_mean", 0.0_dp, ptr=ba_mean, overwrite=.true.) - if (.not. assign_pointer(at, "bond_angle_dev", ba_dev)) & - call add_property(at, "bond_angle_dev", 0.0_dp, ptr=ba_dev, overwrite=.true.) - if (.not. assign_pointer(at, "liquid_like", ba_dev)) & - call add_property(at, "liquid_like", .false., ptr=liquid_like, overwrite=.true.) - - do i=1, at%N - ba_sum = 0.0_dp - ba_sum_sq = 0.0_dp - n_nn = n_neighbours(at,i) - do i_nn=1, n_nn - ii = neighbour(at, i, i_nn, cosines=i_rv) - do j_nn=i_nn+1, n_nn - ii = neighbour(at, i, j_nn, cosines=j_rv) - ba = DEGREES_PER_RADIAN*acos(sum(i_rv*j_rv)) - ba_sum = ba_sum + ba - ba_sum_sq = ba_sum_sq + ba**2 - end do - end do - n_angles = n_nn*(n_nn-1)/2 - ba_mean(i) = ba_sum/n_angles - ba_dev(i) = sqrt(ba_sum_sq/n_angles-ba_mean(i)**2) - liquid_like(i) = (ba_mean(i) < 97.6_dp+(111.5_dp-97.6_dp)/35.0_dp*ba_dev(i)) - end do - - end subroutine bond_angle_mean_dev - - subroutine surface_unit_cell(i_out, surf_v, lat, third_vec_normal, tol, max_n) - integer, intent(out) :: i_out(3,3) !% combination of primitive lattice vectors to create supercell (surf_lattice = latt . i_out). column i specifies output pbc vector i. - real(dp), intent(in) :: surf_v(3) !% surface vector - real(dp), intent(in) :: lat(3,3) !% lattice - logical, intent(in), optional :: third_vec_normal - real(dp), intent(in), optional :: tol - integer, intent(in), optional :: max_n - - logical :: my_third_vec_normal - real(dp) :: my_tol - integer :: my_max_n - - integer :: i1, i2, i3, j1, j2, j3 - real(dp) :: v1(3), v2(3), v3(3), v1_cross_v2(3), v1_cross_v2_norm, surf_v_hat(3) - real(dp) :: smallest_so_far, most_normal_so_far - real(dp) :: cell(3,3), cell_vol - - my_max_n = optional_default(5, max_n) - my_tol = optional_default(1.0e-6_dp, tol) - my_third_vec_normal = optional_default(.false., third_vec_normal) - - surf_v_hat = surf_v/norm(surf_v) - - smallest_so_far = 1.0e38_dp - do i1 = -my_max_n, my_max_n - do i2 = -my_max_n, my_max_n - do i3 = -my_max_n, my_max_n - v1 = lat(:,1)*i1 + lat(:,2)*i2 + lat(:,3)*i3 - do j1 = -my_max_n, my_max_n - do j2 = -my_max_n, my_max_n - do j3 = -my_max_n, my_max_n - v2 = lat(:,1)*j1 + lat(:,2)*j2 + lat(:,3)*j3 - v1_cross_v2 = (v1 .cross. v2) - v1_cross_v2_norm = norm(v1_cross_v2) - - if (v1_cross_v2_norm <= my_tol) cycle ! v1 and v2 are parallel - if ((v1_cross_v2 .dot. surf_v_hat)/v1_cross_v2_norm < 1.0_dp-my_tol) cycle ! v1 cross v2 is not parallel to surf_v - - if (v1_cross_v2_norm < smallest_so_far-my_tol) then ! v1 cross v2 is smallest than best so far, pick it - i_out(:,1) = (/ i1, i2, i3 /) - i_out(:,2) = (/ j1, j2, j3 /) - smallest_so_far = v1_cross_v2_norm - most_normal_so_far = abs((v1 .dot. v2) / (norm(v1)*norm(v2))) - else if (v1_cross_v2_norm <= smallest_so_far + my_tol) then ! v1 cross v2 is as good as best so far, check for normalness - if (abs((v1 .dot. v2) / (norm(v1)*norm(v2))) < most_normal_so_far) then ! v1 more normal to v2, pick them - i_out(:,1) = (/ i1, i2, i3 /) - i_out(:,2) = (/ j1, j2, j3 /) - smallest_so_far = v1_cross_v2_norm - most_normal_so_far = abs((v1 .dot. v2) / (norm(v1)*norm(v2))) - endif - endif - end do - end do - end do - end do - end do - end do - - if (smallest_so_far >= 1.0e38_dp) then - call system_abort("failed to find a proper unit cell v1,v2") - endif - - v1 = matmul(lat, i_out(:,1)) - v2 = matmul(lat, i_out(:,2)) - cell(:,1) = v1 - cell(:,2) = v2 - v1_cross_v2 = (v1 .cross. v2) - v1_cross_v2_norm = norm(v1_cross_v2) - - smallest_so_far = 1.0e38_dp - do i1 = -my_max_n, my_max_n - do i2 = -my_max_n, my_max_n - do i3 = -my_max_n, my_max_n - v3 = lat(:,1)*i1 + lat(:,2)*i2 + lat(:,3)*i3 - - cell(:,3) = v3 - cell_vol = cell_volume(cell) - if (cell_vol < my_tol) cycle ! v3 is in v1-v2 plane - if (my_third_vec_normal .and. abs(v1_cross_v2 .dot. v3)/(v1_cross_v2_norm*norm(v3)) < 1.0_dp-my_tol) cycle ! need v3 normal to surface, and it's not sufficiently parallel to v1 x v2 - if (cell_vol < smallest_so_far-my_tol) then ! volume is smaller, pick it - i_out(:,3) = (/ i1, i2, i3 /) - smallest_so_far = cell_vol - most_normal_so_far = abs((v3 .dot. v1_cross_v2)/(norm(v3)*v1_cross_v2_norm)) - else if (cell_vol <= smallest_so_far+my_tol) then ! equal, check for normalness - if (abs((v3 .dot. v1_cross_v2)/(norm(v3)*v1_cross_v2_norm)) > most_normal_so_far) then ! this v3 more normal to surface (i.e. more parallel to v1_cross_v2), pick it - i_out(:,3) = (/ i1, i2, i3 /) - smallest_so_far = cell_vol - most_normal_so_far = abs((v3 .dot. v1_cross_v2)/(norm(v3)*v1_cross_v2_norm)) - endif - endif - end do - end do - end do - if (smallest_so_far >= 1.0e38_dp) then - call system_abort("failed to find a proper unit cell v3") - endif - - end subroutine surface_unit_cell - - -subroutine find_closest(at, r, closest_list) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: r(3) - integer, intent(out) :: closest_list(:) - - integer :: n_p, i_p, j - real(dp) :: prev_dist - real(dp), allocatable :: r_a(:) - real(dp), allocatable :: closest_r(:) - - n_p = size(closest_list) - - allocate(r_a(at%N)) - allocate(closest_r(n_p)) - - if (at%N < n_p) call system_abort("not enought points ("//at%N//") in atoms object (need "//n_p//")") - - do i_p=1, at%N - r_a(i_p) = distance_min_image(at, i_p, r) - end do - - prev_dist = -1e38_dp - do i_p=1, n_p - closest_r(i_p) = 1.0e38_dp - closest_list(i_p) = -1 - do j=1, at%N - if (r_a(j) < closest_r(i_p) .and. r_a(j) >= prev_dist .and. .not. any(j == closest_list(1:i_p-1))) then - closest_list(i_p) = j - closest_r(i_p) = r_a(j) - endif - end do - prev_dist = closest_r(i_p) - end do - - deallocate(r_a, closest_r) - -end subroutine find_closest - -subroutine void_analysis(at, grid_size, cutoff, grid, radii) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: grid_size, cutoff - - real(dp), intent(inout) :: grid(:,:), radii(:) - - real(dp) :: min_x, min_y, min_z, max_x, max_y, max_z, dx, dy, dz - integer :: nx, ny, nz, i, j, k, n, a(1) - logical changed - - min_x = minval(at%pos(1,:)) - min_y = minval(at%pos(2,:)) - min_z = minval(at%pos(3,:)) - - max_x = maxval(at%pos(1,:)) - max_y = maxval(at%pos(2,:)) - max_z = maxval(at%pos(3,:)) - - nx = int((max_x-min_x)/grid_size) - ny = int((max_y-min_y)/grid_size) - nz = int((max_z-min_z)/grid_size) - - dx = (max_x - min_x)/(real(nx-1, dp)) - dy = (max_y - min_y)/(real(ny-1, dp)) - dz = (max_z - min_z)/(real(nz-1, dp)) - - call print('nx='//nx//' dx='//dx) - call print('ny='//ny//' dy='//dy) - call print('nz='//nz//' dz='//dz) - - if (size(grid, 1) /= 3) then - call system_abort('void_analysis: size(grid, 2) /= 3') - end if - - if (.not. (size(grid, 2) >= nx*ny*nz)) then - call system_abort('void_analysis: size(grid, 1)='//(size(grid, 1))//' must be >= nx*ny*nz='//(nx*ny*nz)) - end if - - if (.not. (size(radii) >= nx*ny*nz)) then - call system_abort('void_analysis: size(radii)='//(size(radii, 1))//' must be >= nx*ny*nz='//(nx*ny*nz)) - end if - - !allocate(grid(nx*ny*nz,3), radii(nx*ny*nz)) - - ! populate grid - n = 1 - do i=1,nx - do j=1,ny - do k=1,nz - grid(:, n) = (/ min_x + (i-1)*dx, & - min_y + (j-1)*dy, & - min_z + (k-1)*dz /) - n = n + 1 - end do - end do - end do - - ! find distance from each grid point to nearest atom. That is void radius at that point. - do i=1, size(grid, 2) - call find_closest(at, grid(:, i), a) - radii(i) = distance_min_image(at, a(1), grid(:, i)) - end do - - ! Remove grid points with radii < cutoff - where (radii < cutoff) - radii = 0.0_dp - end where - - ! TODO agglomerative merging of overlapping grid points - - !deallocate(grid, radii) - -end subroutine void_analysis - -end module structures_module diff --git a/src/libAtoms/System.f95 b/src/libAtoms/System.f95 deleted file mode 100644 index 249218f3ba..0000000000 --- a/src/libAtoms/System.f95 +++ /dev/null @@ -1,3779 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X System module -!X -!X Basic system dependent functionality: -!X -!X mpi constants, default output objects, printing -!X random number generators -!X -!% The system module contains low-level routines for I/O, timing, random -!% number generation etc. The Inoutput type is used to abstract both -!% formatted and unformatted (i.e. binary) I/O. -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module system_module - use error_module - use kind_module -!$ use omp_lib -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif - implicit none -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif - -private - - logical, public :: system_always_flush = .false. - - logical, public :: system_use_fortran_random = .false. - - public :: isp, idp, iwp, dp, qp - - character, public :: quip_new_line - - integer, parameter, public :: INTEGER_SIZE = 4 - integer, parameter, public :: REAL_SIZE = dp - integer, parameter, public :: COMPLEX_SIZE = 2*dp - logical, public :: trace_memory = .false. - integer, public :: traced_memory = 0 - - logical, private :: system_do_timing = .false. - logical, private :: system_quippy_running = .false. - - type, public :: Stack - integer:: pos - integer, allocatable :: val(:) - end type Stack - - type, public :: InOutput - integer:: unit - character(256)::filename - character(256)::prefix, postfix - integer::default_real_precision - logical::formatted - logical::append - logical::active !% Does it print? - integer::action - logical::mpi_all_inoutput_flag = .false. - logical::mpi_print_id = .false. - type(Stack) :: verbosity_stack, verbosity_cascade_stack - logical::initialised = .false. - end type InOutput - - type, public :: allocatable_array_pointers - integer, allocatable :: i_a(:) - real(dp), allocatable :: r_a(:) - complex(dp), allocatable :: c_a(:) - logical, allocatable :: l_a(:) - end type allocatable_array_pointers - - integer,private :: mpi_n, mpi_myid ! Number of processes and local process ID - real(dp),private :: start_time ! Initial time - integer, parameter, private :: SYSTEM_STRING_LENGTH_SHORT = 32 !when a shorter strong is enough and we have lots of them - integer, parameter, private :: SYSTEM_STRING_LENGTH = 1024 !max line length read - integer, parameter, private :: SYSTEM_STRING_LENGTH_LONG = 102400 !max line length read - character(SYSTEM_STRING_LENGTH_LONG),public :: line ! 'line' is global and is used by other modules - character(SYSTEM_STRING_LENGTH_LONG),private :: local_line ! 'local_line' is private and System should use this instead - type(inoutput),target,save,public :: mainlog !% main output, connected to 'stdout' by default - type(inoutput),target,save,public :: errorlog !% error output, connected to 'stderr' by default - type(inoutput),target,save,public :: mpilog !% MPI output, written to by each mpi process - integer,private :: idum ! used in the random generator - !$omp threadprivate(idum) - real(dp),parameter, public :: NUMERICAL_ZERO = 1.0e-14_dp - - ! system dependent variables - integer, public::RAN_MAX - - - ! output labels - integer,parameter, public::PRINT_ALWAYS = -100000 - integer,parameter, public::PRINT_SILENT = -1 - integer,parameter, public::PRINT_NORMAL = 0 - integer,parameter, public::PRINT_VERBOSE = 1 - integer,parameter, public::PRINT_NERD = 1000 ! aleph0 - integer,parameter, public::PRINT_ANALYSIS = 10000 ! aleph1 - - integer,parameter, public::INPUT=0 - integer,parameter, public::OUTPUT=1 - integer,parameter, public::INOUT=2 - - - ! random number generator parameters - integer,parameter, public::ran_A=16807 - integer,parameter, public::ran_M=2147483647 - integer,parameter, public::ran_Q=127773 - integer,parameter, public::ran_R=2836 - - ! System_Timer stack size - integer, parameter, public :: TIMER_STACK = 500 - - ! Command argument variables - integer, public, save :: NUM_COMMAND_ARGS = 0 !% The number of arguments on the command line - integer, parameter, public :: MAX_READABLE_ARGS = 100 !% The maximum number of arguments that will be read - character(255), public, save :: EXEC_NAME !% The name of the executable - character(2550), public, dimension(MAX_READABLE_ARGS), save :: COMMAND_ARG !% The first 'MAX_READABLE_ARGS' command arguments - - -#ifdef NO_FORTRAN_ISNAN - public :: isnan -#endif - - private :: inoutput_initialise - public :: initialise - interface initialise - module procedure inoutput_initialise - end interface initialise - - private :: inoutput_finalise - public :: finalise - interface finalise - module procedure inoutput_finalise - end interface finalise - - private :: inoutput_activate - public :: activate - interface activate - module procedure inoutput_activate - end interface activate - - private :: inoutput_deactivate - public :: deactivate - interface deactivate - module procedure inoutput_deactivate - end interface deactivate - - public :: mpi_all_inoutput - interface mpi_all_inoutput - module procedure inoutput_mpi_all_inoutput - end interface mpi_all_inoutput - - public :: print_mpi_id - interface print_mpi_id - module procedure inoutput_print_mpi_id - end interface print_mpi_id - - private :: inoutput_print_string - private :: inoutput_print_integer, inoutput_print_real, inoutput_print_logical - - !% Overloaded interface for printing. With the - !% 'this' parameter omitted output goes to the default mainlog ('stdout'). The - !% 'verbosity' parameter controls whether the object is actually printed; - !% if the verbosity is greater than that currently at the top of the - !% verbosity stack then output is suppressed. Possible verbosity levels - !% range from 'ERROR' through 'NORMAL', 'VERBOSE', 'NERD' and 'ANALYSIS'. - !% Other user-defined types define the Print interface in the same way. - - public :: print - interface print - module procedure inoutput_print_string - module procedure inoutput_print_integer, inoutput_print_real, inoutput_print_logical - module procedure inoutput_print_char_array - module procedure print_inoutput - end interface print - - private :: reada_real_dim1, reada_int_dim1 - public :: read_ascii - interface read_ascii - module procedure reada_real_dim1, reada_int_dim1 - end interface read_ascii - - private :: inoutput_read_line - public :: read_line - interface read_line - module procedure inoutput_read_line - end interface read_line - - private :: inoutput_read_file - public :: read_file - interface read_file - module procedure inoutput_read_file - end interface read_file - - private :: inoutput_parse_line - public :: parse_line - interface parse_line - module procedure inoutput_parse_line - end interface parse_line - - private :: reallocate_int1d, reallocate_int2d, reallocate_int3d, reallocate_real1d, reallocate_real2d, reallocate_char1d, reallocate_log1d - public :: reallocate - interface reallocate - module procedure reallocate_int1d, reallocate_int2d, reallocate_int3d, reallocate_real1d, reallocate_real2d, reallocate_char1d, reallocate_log1d - end interface reallocate - - public :: operator(//) - - interface operator(//) - module procedure string_cat_logical, string_cat_isp, string_cat_idp, string_cat_real, string_cat_real_array - module procedure string_cat_complex, string_cat_int_array, string_cat_logical_array - module procedure string_cat_complex_array, string_cat_string_array -! module procedure logical_cat_string, logical_cat_logical, logical_cat_int, logical_cat_real - module procedure int_cat_string!, int_cat_logical, int_cat_int, int_cat_real - module procedure real_cat_string!, real_cat_logical, real_cat_int, real_cat_real - module procedure real_array_cat_string - end interface - - public :: system_command - interface system_command - !%> call system_command(command) - !% Interface to a C wrapper to the 'system(3)' system call for - !% executing external programs. Command can only be up to 1024 characters long. - !% \begin{description} - !% \item['character' --- character(*)] - !% \end{description} - subroutine system_command(command,status,error) - character(*), intent(in) :: command - integer, optional, intent(out) :: status - integer, optional, intent(out) :: error - end subroutine system_command - end interface - -#ifdef NO_FORTRAN_ISNAN - INTERFACE - elemental function fisnan(r) - real(8), intent(in)::r - integer::fisnan - end function fisnan - end INTERFACE -#endif - - public :: c_mem_info - interface c_mem_info - subroutine c_mem_info(total_mem,free_mem) - real(8), intent(out) :: total_mem, free_mem - endsubroutine c_mem_info - endinterface c_mem_info - - public :: mem_info - interface mem_info - module procedure mem_info_i, mem_info_r - end interface mem_info - - private :: Stack_Initialise - interface Initialise - module procedure Stack_Initialise - end interface Initialise - - private :: Stack_Finalise - interface Finalise - module procedure Stack_Finalise - end interface Finalise - - private :: Stack_push - public :: push - interface push - module procedure Stack_push - end interface push - - private :: Stack_pop - public :: pop - interface pop - module procedure Stack_pop - end interface pop - - private :: Stack_value - public :: value - interface value - module procedure Stack_value - end interface value - - private :: Stack_Print - interface Print - module procedure Stack_Print - end interface Print - - !% takes as arguments a default value and an optional argument, and - !% returns the optional argument value if it's present, otherwise - !% the default value - private :: optional_default_l, optional_default_i, optional_default_r - private :: optional_default_c, optional_default_ca, optional_default_z - private :: optional_default_ia, optional_default_ra - public :: optional_default - interface optional_default - module procedure optional_default_l, optional_default_i, optional_default_r - module procedure optional_default_c, optional_default_ca, optional_default_z - module procedure optional_default_ia, optional_default_ra - end interface optional_default - - private :: string_to_real_sub, string_to_integer_sub, string_to_logical_sub - private :: string_to_real1d, string_to_integer1d, string_to_logical1d - public :: string_to_numerical - interface string_to_numerical - module procedure string_to_real_sub, string_to_integer_sub, string_to_logical_sub - module procedure string_to_real1d, string_to_integer1d, string_to_logical1d - end interface string_to_numerical - - public :: int_format_length - interface int_format_length - module procedure int_format_length_isp, int_format_length_idp - end interface int_format_length - - public :: get_uniqs_refs - interface get_uniqs_refs - module procedure get_uniqs_refs_char1 - end interface - - public :: join - interface join - module procedure join_char1 - end interface - - integer, external :: pointer_to - public :: increase_stack - public :: ran_normal - public :: ran_uniform - public :: ran - public :: round - public :: current_verbosity - public :: string_to_real - public :: string_to_int - public :: string_to_logical - public :: upper_case - public :: lower_case - public :: replace - public :: split_string - public :: parse_string - public :: linebreak_string - public :: cmd_arg_count - public :: mpi_id - public :: mpi_n_procs - public :: a2s, s2a - public :: system_get_random_seed - public :: system_abort - public :: verbosity_push_decrement - public :: verbosity_pop - public :: print_message - public :: print_warning - public :: pad - public :: get_quippy_running - public :: system_timer - public :: split_string_simple - public :: num_fields_in_string_simple - public :: current_times - public :: progress - public :: progress_timer - public :: system_initialise - public :: verbosity_push - public :: abort_on_mpi_error - public :: verbosity_push_increment - public :: verbosity_of_str - public :: verbosity_to_str - public :: get_env_var - public :: system_resync_rng - public :: get_mpi_size_rank - public :: print_title - public :: parallel_print - public :: system_reseed_rng - public :: get_cmd_arg - public :: system_set_random_seeds - public :: system_finalise - public :: enable_timing - public :: verbosity_unset_minimum - public :: verbosity_set_minimum - public :: rewind - public :: th - public :: string_cat_string_array - public :: reference_true - public :: reference_false - public :: is_file_readable - public :: ALLOC_TRACE - public :: DEALLOC_TRACE - public :: make_run_directory - public :: link_run_directory - public :: wait_for_file_to_exist - public :: is_open - public :: increase_to_multiple - public :: i2si -contains - -#ifdef NO_FORTRAN_ISNAN - elemental function isnan(r) - real(dp), intent(in)::r - logical::isnan - select case(fisnan(r)) - case(0) - isnan = .false. - case(1) - isnan = .true. - case default - isnan = .true. - end select - end function isnan -#endif - - !% Open a file for reading or writing. The action optional parameter can - !% be one of 'INPUT' (default), 'OUTPUT' or 'INOUT'. - !% For unformatted output, the - !% 'isformatted' optional parameter must - !% be set to false. - subroutine inoutput_initialise(this,filename,action,isformatted,append,verbosity,verbosity_cascade,master_only,unit,error) - type(Inoutput), intent(inout)::this - character(*),intent(in),optional::filename - logical,intent(in),optional::isformatted - integer,intent(in),optional::action - logical,intent(in),optional::append - integer,intent(in),optional :: verbosity, verbosity_cascade - logical,intent(in),optional :: master_only - integer, intent(in), optional :: unit - integer,intent(out),optional :: error - - character(32)::formattedstr - character(32)::position_value - integer::stat - logical :: my_master_only - - INIT_ERROR(error) - - ! Default of optional parameters------------------------------- - - my_master_only = optional_default(.true., master_only) - call mpi_all_inoutput(this, .not. my_master_only) - - if(present(isformatted)) then - this%formatted=isformatted - else - this%formatted=.true. - endif - - if(.NOT.(this%formatted)) then - formattedstr = 'unformatted' - else - formattedstr = 'formatted' - end if - - if (present(action)) then - this%action=action - else - this%action=INPUT - end if - - if (present(append)) then - this%append=append - if(append) then - position_value="APPEND" - else - position_value="REWIND" - end if - - else - this%append=.false. - position_value="REWIND" - end if - - if(this%append .AND. .NOT.this%formatted) then - RAISE_ERROR(" Append not implemented for unformatted output",error) - end if - - if (present(filename)) then - if (present(unit)) then - RAISE_ERROR("got filename and unit simultaneously",error) - endif - if (trim(filename).eq.'stderr') then - this%filename=trim(filename) - this%unit=0 !standard error - this%action=OUTPUT - - else if (trim(filename).eq.'stdout' .or. trim(filename) .eq. '-') then - this%filename='stdout' - this%unit = 6 !standard output - this%action=OUTPUT - - else if (trim(filename).eq.'stdin') then - this%filename=trim(filename) - this%unit = 5 !standard input - this%action=INPUT - - else - this%filename=trim(filename) - this%unit=pick_up_unit() ! pick up available unit - - ! actually open the unit - if ((.not. my_master_only) .or. mpi_myid == 0) then - if (this%action == INPUT) then - open(unit=this%unit,file=trim(filename),form=formattedstr,position=position_value,status='OLD',iostat=stat) - else - open(unit=this%unit,file=trim(filename),form=formattedstr,position=position_value,iostat=stat) - endif - else - stat = 0 - endif - if(stat.NE.0)then - RAISE_ERROR('IO error opening "'//trim(filename)//'" on unit '//this%unit//', error number: '//stat,error) - end if - - end if - else ! no file name passed, so we go to passed-in unit if present, otherwise standard output - if (present(unit)) then - this%filename='from_unit_arg' - this%unit=unit - this%action=OUTPUT - else - this%filename='stdout' - this%unit = 6 !standard output - this%action = OUTPUT - endif - end if ! end default-------------------------------------------------- - - this%prefix = '' - this%postfix = '' - this%default_real_precision = 17 - - call initialise(this%verbosity_stack) - if (present(verbosity)) then - call push(this%verbosity_stack, verbosity) - else - call push(this%verbosity_stack, PRINT_NORMAL) - endif - - call initialise(this%verbosity_cascade_stack) - if (present(verbosity_cascade)) then - call push(this%verbosity_cascade_stack, verbosity_cascade) - else - call push(this%verbosity_cascade_stack, 0) - endif - - if ((.not. my_master_only) .or. mpi_myid == 0) then - call activate(this) ! now it is active - endif - - this%initialised = .true. - - end subroutine inoutput_initialise - - !% OMIT - function is_open(unit) - integer, intent(in) :: unit - logical :: is_open - inquire(unit, opened=is_open) - end function is_open - - !% OMIT - function pick_up_unit() result(unit) - integer::unit,i - do i=7,99 - if (.not. is_open(i)) then - unit=i - exit - end if - end do - end function pick_up_unit - - !% Deactivate an Inoutput object temporarily. - subroutine inoutput_deactivate(this) - type(Inoutput),intent(inout)::this - this%active=.false. - end subroutine inoutput_deactivate - - !% Activate an Inoutput object temporarily. - subroutine inoutput_activate(this) - type(Inoutput),intent(inout)::this - this%active=.true. - end subroutine inoutput_activate - - - !% Cleans everything and set members to default - subroutine inoutput_finalise(this) - type(Inoutput), intent(inout)::this - if (this%unit .ge. 7) close(this%unit) - call finalise(this%verbosity_stack) - call finalise(this%verbosity_cascade_stack) - call deactivate(this) - this%initialised = .false. - end subroutine inoutput_finalise - - !% Close file but don't finalise this Inoutput - subroutine inoutput_close(this) - type(Inoutput), intent(inout) :: this - - if (this%unit .ge. 7) close(this%unit) - call deactivate(this) - end subroutine inoutput_close - - subroutine inoutput_mpi_all_inoutput(this,value) - - type(inoutput), intent(inout) :: this - logical, optional, intent(in) :: value - - if (present(value)) then - this%mpi_all_inoutput_flag = value - else - this%mpi_all_inoutput_flag = .true. - end if - - end subroutine inoutput_mpi_all_inoutput - - subroutine inoutput_print_mpi_id(this,value) - - type(inoutput), intent(inout) :: this - logical, optional, intent(in) :: value - - if (present(value)) then - this%mpi_print_id = value - else - this%mpi_print_id = .true. - end if - - end subroutine inoutput_print_mpi_id - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Printing routines for intrinsic types - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine inoutput_print_string(string, verbosity, file, nocr, do_flush) - character(*), intent(in) :: string - integer, optional, intent(in) :: verbosity - type(Inoutput), optional, target, intent(in) :: file - logical, optional, intent(in) :: nocr, do_flush - - type(Inoutput), pointer :: myoutput - integer :: myverbosity - character(len=2) :: nocr_fmt - logical :: my_do_flush - - my_do_flush = optional_default(system_always_flush, do_flush) - - nocr_fmt = '' - if (present(nocr)) then - if (nocr) nocr_fmt = ',$' - endif - - ! check inoutput object - myoutput => mainlog - if(present(file)) myoutput => file - - ! check verbosity request - myverbosity = PRINT_NORMAL - if(present(verbosity)) myverbosity = verbosity - - ! if we are not active, do nothing - if(.not.myoutput%active) return - ! if request is above threshold, do nothing - if(myverbosity > value(myoutput%verbosity_stack) ) return - - if(myoutput%action .EQ. INPUT) then - call system_abort("inoutput_print: you cannot print to an INPUT object") - end if - - if(.NOT.myoutput%formatted) then - call system_abort("inoutput_print: this subroutine is not good for unformatted printing") - end if - - ! actually write the line, removing trailing blanks - if (inoutput_do_output(myoutput)) then - if (len_trim(myoutput%prefix) == 0) then - if (myoutput%mpi_all_inoutput_flag .and. myoutput%mpi_print_id) then - write(myoutput%unit,'(i0,": ",a'//trim(nocr_fmt)//')') mpi_id(), trim(string)//trim(myoutput%postfix) - else - write(myoutput%unit,'(a'//trim(nocr_fmt)//')') trim(string)//trim(myoutput%postfix) - endif - else - if (myoutput%mpi_all_inoutput_flag .and. myoutput%mpi_print_id) then - write(myoutput%unit,'(i0,": ",a'//trim(nocr_fmt)//')') mpi_id(), trim(myoutput%prefix)//" "//trim(string) & - // " " // trim(myoutput%postfix) - else - write(myoutput%unit,'(a'//trim(nocr_fmt)//')') trim(myoutput%prefix)//" "//trim(string)// " " // trim(myoutput%postfix) - endif - endif - endif - - if (my_do_flush) call flush(myoutput%unit) - end subroutine inoutput_print_string - - function inoutput_do_output(this) - type(inoutput), intent(in) :: this - logical :: inoutput_do_output - - if ((this%mpi_all_inoutput_flag .or. mpi_id() == 0) .and. this%unit >= 0) then - inoutput_do_output = .true. - else - inoutput_do_output = .false. - end if - end function inoutput_do_output - - subroutine inoutput_print_char_array(char_a, verbosity, file) - character(len=*) :: char_a(:) - integer, optional, intent(in) :: verbosity - type(Inoutput), optional, target, intent(in) :: file - - integer i - character(len=size(char_a)) :: str - - do i=1, size(char_a) - str(i:i) = char_a(i) - end do - - call print(str, verbosity, file) - end subroutine inoutput_print_char_array - - subroutine inoutput_print_logical(log, verbosity, file) - logical, intent(in) :: log - integer, optional, intent(in) :: verbosity - type(Inoutput), optional, intent(in) :: file - - write(local_line,'(l1)') log - call print(local_line, verbosity, file) - end subroutine inoutput_print_logical - - subroutine inoutput_print_integer(int, verbosity, file) - integer, intent(in) :: int - integer, optional, intent(in) :: verbosity - type(Inoutput), optional, intent(in) :: file - - write(local_line,'(i0)') int - call print(local_line, verbosity, file) - end subroutine inoutput_print_integer - - subroutine inoutput_print_real(real, verbosity, file, precision, format, nocr) - real(dp), intent(in) :: real - integer, optional, intent(in) :: verbosity - integer, optional, intent(in) :: precision ! number of decimal places - character(*), optional, intent(in) :: format - type(inoutput), optional, intent(in) :: file - logical, optional, intent(in) :: nocr - - character(7) :: myformat - - if(present(format)) then - write(local_line, format) real - else - if (present(precision)) then - if (precision > 99) then - call print_message('WARNING', 'Inoutput_Print_Real: Precision too high. Capping to 99.') - write(myformat,'(a)')'(f0.99)' - else - write(myformat,'(a,i0,a)')'(f0.',precision,')' - end if - else - if(present(file)) then - write(myformat,'(a,i0,a)')'(f0.',file%default_real_precision,')' - else - write(myformat,'(a,i0,a)')'(f0.',mainlog%default_real_precision,')' - end if - end if - - write(local_line,myformat) real - end if - - call print(local_line, verbosity, file, nocr=nocr) - end subroutine inoutput_print_real - - subroutine print_inoutput(this) - type(inoutput), intent(in) :: this - - call print_title("type(inoutput)") - call print("unit "//this% unit) - call print("filename "//this%filename) - call print("prefix "//this%prefix) - call print("postfix "//this%postfix) - call print("default_real_precision "//this%default_real_precision) - call print("formatted "//this%formatted) - call print("append "//this%append) - call print("active "//this%active) - call print("action "//this%action) - call print("mpi_all_inoutput_flag "//this%mpi_all_inoutput_flag) - call print("mpi_print_id "//this%mpi_print_id) - call print("verbosity_stack: ") - call print(this%verbosity_stack) - call print("verbosity_cascade_stack: ") - call print(this%verbosity_cascade_stack) - call print("initialised "//this%initialised) - call print_title("") - end subroutine print_inoutput - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Pretty print a title -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - !% Print a centred title, like this: - !% - !% '==================================== Title =====================================' - ! - subroutine print_title(title, verbosity) - - character(*), intent(in) :: title - integer, intent(in), optional :: verbosity - - character(len(title)) :: my_title - integer :: length, a,b - - my_title = adjustl(title) - length = len_trim(my_title) - - call print('', verbosity) - if (length < 76) then - a = (80 - length) / 2 - b = 80 - length - a - 2 - call print(repeat('=',a)//' '//trim(my_title)//' '//repeat('=',b), verbosity) - else - call print(title, verbosity) - end if - call print('',verbosity) - - end subroutine print_title - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Formatted reading -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !%Read a line of text from a file (up to a line break, or 1024 characters). - !%This can then be parsed by the calling routine (using 'parse_line' for example) - !% - !%Optionally, a status is returned which is: - !% - !%\begin{itemize} - !% \item $<0$ if the end of the file is reached - !% \item $=0$ if no problems were encountered - !% \item $>0$ if there was a read error - !%\end{itemize} - !% - !%The actual number returned is implementation specific - function inoutput_read_line(this,status) - - type(Inoutput), intent(in) :: this - integer, optional, intent(out) :: status - character(SYSTEM_STRING_LENGTH_LONG) :: inoutput_read_line - integer :: my_status - - if (this%action == OUTPUT) call system_abort('read_line: Cannot read from an output file ('//trim(adjustl(this%filename))//')') - - if (present(status)) then - read (this%unit,fmt='(a)',iostat=status) inoutput_read_line - else - read (this%unit,fmt='(a)',iostat=my_status) inoutput_read_line - if (my_status < 0) call system_abort('read_line: End of file when reading '//trim(adjustl(this%filename))) - if (my_status > 0) call system_abort('read_line: Error reading file '//trim(adjustl(this%filename))) - end if - - end function inoutput_read_line - - subroutine inoutput_read_file(this,line_array, n_lines, status) - type(Inoutput), intent(in) :: this - character(len=*), allocatable, intent(inout) :: line_array(:) - integer, intent(out) :: n_lines - integer, optional, intent(out) :: status - - integer :: my_status, line_no, line_array_size - - line_no = 0 - my_status = 0 - - do while (my_status == 0) - line_no = line_no + 1 - if (allocated(line_array)) then - line_array_size = size(line_array) - else - line_array_size = 0 - endif - if (line_no > line_array_size) call extend_char_array(line_array, 1.5_dp, 10) - line_array(line_no) = read_line(this, my_status) - end do - - n_lines = line_no - 1 - - if (my_status > 0) then - if (present(status)) then - status = my_status - return - else - call system_abort("ERROR inoutput_read_file reading file '"//trim(adjustl(this%filename))//"' status " // my_status) - endif - endif - - end subroutine inoutput_read_file - - subroutine extend_char_array(line_array, factor, minlen) - character(len=*), allocatable, intent(inout) :: line_array(:) - real(dp), intent(in), optional :: factor - integer, intent(in), optional :: minlen - - real(dp) :: my_factor - integer :: my_minlen - character, allocatable :: t_line_array(:,:) - integer old_n, i, j - - my_minlen = optional_default(10, minlen) - my_factor = optional_default(1.5_dp, factor) - - if (.not. allocated(line_array)) then - allocate(line_array(my_minlen)) - return - endif - - if (allocated(line_array)) then - old_n = size(line_array) - else - old_n = 0 - end if - allocate(t_line_array(len(line_array(1)), old_n)) - do i=1, old_n - do j=1, len(line_array(1)) - t_line_array(j,i) = line_array(i)(j:j) - end do - end do - deallocate(line_array) - allocate(line_array(int(old_n*my_factor))) - do i=1, old_n - do j=1, len(line_array(1)) - line_array(i)(j:j) = t_line_array(j,i) - end do - end do - deallocate(t_line_array) - end subroutine extend_char_array - - !% Call parse_string on the next line from a file - subroutine inoutput_parse_line(this,delimiters,fields,num_fields,status) - type(inoutput), intent(in) :: this - character(*), intent(in) :: delimiters - character(*), dimension(:), intent(inout) :: fields - integer, intent(out) :: num_fields - integer, optional, intent(out) :: status - integer :: my_status - - num_fields = 0 ! in case read gives non-zero status - local_line = read_line(this,my_status) - if (present(status)) status = my_status - if (my_status == 0) call split_string_simple(local_line, fields, num_fields, delimiters) - - end subroutine inoutput_parse_line - - !% split a string into fields separated by possible separators - !% no quoting, matching separators, just a simple split - subroutine split_string_simple(str, fields, n_fields, separators, error) - character(len=*), intent(in) :: str !% string to be split - character(len=*), intent(out) :: fields(:) !% on return, array of fields - integer, intent(out) :: n_fields !% on return, number of fields - character(len=*), intent(in) :: separators !% string of possible separators - integer, intent(out), optional :: error - - integer :: str_len, cur_pos, next_pos, cur_field - - INIT_ERROR(error) - - str_len = len_trim(str) - cur_pos = 0 - cur_field = 1 - do while (cur_pos <= str_len) - if (cur_field > size(fields)) then - RAISE_ERROR("split_string_simple str='"//trim(str)//"' no room for fields size(fields)="//size(fields)//" cur_field "//cur_field, error) - endif - next_pos = scan(str(cur_pos+1:str_len),separators) - if (next_pos > 0) then - if (next_pos == 1) then ! found another separator, skip it - cur_pos = cur_pos + 1 - else ! some stuff between us and separator, must be another field - fields(cur_field) = str(cur_pos+1:cur_pos+1+next_pos-2) - cur_pos = cur_pos + next_pos - cur_field = cur_field + 1 - endif - else ! end of string, last field - fields(cur_field) = str(cur_pos+1:str_len) - cur_field = cur_field + 1 - cur_pos = str_len+1 ! exit loop - endif - end do - n_fields = cur_field - 1 - - end subroutine split_string_simple - - function num_fields_in_string_simple(this,separators) - character(len=*), intent(in) :: this - character(len=*), intent(in) :: separators - integer :: num_fields_in_string_simple - - integer :: i, res - - res = 1 - - do i = 1, len_trim(this) - if( index(trim(separators),this(i:i)) > 0 ) res = res + 1 - enddo - - - num_fields_in_string_simple = res - - endfunction num_fields_in_string_simple - - !% split a string at separators, making sure not to break up bits that - !% are in quotes (possibly matching opening and closing quotes), and - !% also strip one level of quotes off, sort of like a shell would when - !% tokenizing - subroutine split_string(this, separators, quotes, fields, num_fields, matching) - character(len=*), intent(in) :: this - character(len=*), intent(in) :: separators, quotes - character(len=*), intent(inout) :: fields(:) - integer, intent(out) :: num_fields - logical, intent(in), optional :: matching - - integer :: i, length - integer :: n_quotes - character(len=len(quotes)) :: opening_quotes, closing_quotes - integer :: opening_quote_index, closing_quote_pos - logical :: do_matching - character(len=len(fields(1))) :: tmp_field - character(1) :: c - integer :: tmp_field_last, t_start, dist - logical :: in_token - - do_matching = optional_default(.false., matching) - - if (do_matching) then - if (mod(len(quotes),2) == 0) then - do i=1, len(quotes)/2 - opening_quotes(i:i) = quotes(2*(i-1)+1:2*(i-1)+1) - closing_quotes(i:i) = quotes(2*(i-1)+2:2*(i-1)+2) - end do - n_quotes = len(quotes)/2 - else - call system_abort("split_string called with matching=.true. but odd number of quotes " // (len(quotes))) - endif - else - n_quotes = len(quotes) - opening_quotes(1:n_quotes) = quotes(1:n_quotes) - closing_quotes(1:n_quotes) = quotes(1:n_quotes) - endif - - length = len_trim(this) - num_fields = 0 - tmp_field = "" - tmp_field_last = 0 - in_token = .false. - i = 1 - do - if (i > length) then ! last character - if (in_token) then - num_fields = num_fields + 1 - if (num_fields > size(fields)) call system_abort("split_string on '"//trim(this)//"' ran out of space for fields max " // size(fields)) - if (tmp_field_last > 0) then - if (t_start <= length) then - fields(num_fields) = tmp_field(1:tmp_field_last) // this(t_start:length) - else - fields(num_fields) = tmp_field(1:tmp_field_last) - endif - else - if (t_start <= length) then - fields(num_fields) = this(t_start:length) - else - endif - endif - endif - exit - else if (scan(this(i:i),opening_quotes(1:n_quotes)) > 0) then ! found an opening quote - opening_quote_index = index(opening_quotes,this(i:i)) - closing_quote_pos = find_closing_delimiter(this(i+1:length), closing_quotes(opening_quote_index:opening_quote_index), & - opening_quotes(1:n_quotes), closing_quotes(1:n_quotes), do_matching) - if (closing_quote_pos <= 0) then - call print("splitting string '"//trim(this)//"'", PRINT_ALWAYS) - call system_abort("split_string on '"//trim(this)//"' couldn't find closing quote matching opening at char " // i) - endif - if (in_token) then ! add string from t_start to tmp_field - if (tmp_field_last > 0) then - tmp_field = tmp_field(1:tmp_field_last) // this(t_start:i-1) - else - tmp_field = this(t_start:i-1) - endif - tmp_field_last = tmp_field_last + (i-1 - t_start + 1) - endif - if (tmp_field_last > 0) then ! add contents of quote to tmp_field - if (i+closing_quote_pos-1 >= i+1) tmp_field = tmp_field(1:tmp_field_last) // this(i+1:i+closing_quote_pos-1) - else - if (i+closing_quote_pos-1 >= i+1) tmp_field = this(i+1:i+closing_quote_pos-1) - endif - ! update tmp_field_last - tmp_field_last = tmp_field_last + closing_quote_pos - 1 - in_token = .true. - i = i + closing_quote_pos + 1 - ! reset t_start - t_start = i - else if (scan(this(i:i),separators) > 0) then ! found a separator - if (next_non_separator(this, i+1, length, separators, dist) == '=') then - if (in_token) then - ! add string from t_start to tmp_field - if (tmp_field_last > 0) then - tmp_field = tmp_field(1:tmp_field_last) // this(t_start:i-1)//'=' - else - tmp_field = this(t_start:i-1)//'=' - endif - tmp_field_last = tmp_field_last + (i-1)-t_start+1+1 - else - tmp_field = '=' - tmp_field_last = 1 - endif - in_token = .true. - ! update i and t_start to be after '=' - i = i + dist + 1 - t_start = i - if (i <= length) then - ! look for next non separator - c = next_non_separator(this, i, length, separators, dist) - if (dist > 0) then - i = i + dist-1 - t_start = i - endif - endif - else - if (in_token) then ! we were in a token before finding this separator - num_fields = num_fields + 1 - if (num_fields > size(fields)) call system_abort("split_string on '"//trim(this)//"' ran out of space for fields max " // size(fields)) - ! add string from t_start and tmp_field to fields(num_fields) - if (tmp_field_last > 0) then - fields(num_fields) = tmp_field(1:tmp_field_last) // this(t_start:i-1) - else - fields(num_fields) = this(t_start:i-1) - endif - tmp_field = "" - tmp_field_last = 0 - endif - in_token = .false. - i = i + 1 - endif - else ! plain character - if (.not. in_token) then - t_start = i - endif - in_token = .true. - i = i + 1 - endif - end do - end subroutine split_string - - function next_non_separator(this, start, end, separators, dist) result(c) - character(len=*), intent(in) :: this - integer, intent(in) :: start, end - character(len=*) :: separators - integer, intent(out) :: dist - character(1) :: c - - integer i - -! call print("finding next_non_sep in '"//this(start:end)//"'") - c='' - dist = 0 - do i=start, end - if (scan(this(i:i), separators) == 0) then ! found a non-separator - c = this(i:i) - dist = i-start+1 - exit - endif - end do -! call print("returning c='"//c//"' and dist "//dist) - end function next_non_separator - - !% outdated - please use split_string - !% Parse a string into fields delimited by certain characters. On exit - !% the 'fields' array will contain one field per entry and 'num_fields' - !% gives the total number of fields. 'status' will be given the error status - !% (if present) and so can be used to tell if an end-of-file occurred. - subroutine parse_string(this, delimiters, fields, num_fields, matching, error) - - character(*), intent(in) :: this - character(*), intent(in) :: delimiters - character(*), dimension(:), intent(inout) :: fields - integer, intent(out) :: num_fields - logical, optional, intent(in) :: matching - integer, optional, intent(out) :: error - - integer :: field_start, length - integer :: delim_pos - integer :: n_delims, i - character(len=len(delimiters)) :: opening_delims, closing_delims - character(len=1) :: opening_delim - integer :: opening_delim_index - logical :: do_matching - - - do_matching = optional_default(.false., matching) - - INIT_ERROR(error) - - field_start = 1 - num_fields = 0 - length = len_trim(this) - - if (do_matching) then - if (mod(len(delimiters),2) == 0) then - do i=1, len(delimiters)/2 - opening_delims(i:i) = delimiters(2*(i-1)+1:2*(i-1)+1) - closing_delims(i:i) = delimiters(2*(i-1)+2:2*(i-1)+2) - end do - n_delims = len(delimiters)/2 - else - RAISE_ERROR("parse_string called with matching=.true. but odd number of delimiters " // (len(delimiters)), error) - endif - else - n_delims = len(delimiters) - opening_delims(1:n_delims) = delimiters(1:n_delims) - closing_delims(1:n_delims) = delimiters(1:n_delims) - endif - - do - delim_pos = scan(this(field_start:length), opening_delims(1:n_delims)) - if (delim_pos == 0) then ! didn't find opening delimiter - if (len_trim(this(field_start:length)) == 0) then !...and the rest of the string is blank... - !... then we've finished - exit - else !otherwise, there's one field left to get - if (length >= field_start) then - num_fields = num_fields + 1 - if (num_fields > size(fields)) then - RAISE_ERROR("parse_string ran out of space for fields", error) - endif - fields(num_fields) = this(field_start:length) - endif - return - end if - endif - ! get here if we found an opening delimiter - delim_pos = delim_pos + field_start - 1 - if (delim_pos /= field_start) then ! found an opening delimiter after some text - ! save text in a field, and jump over it - if (delim_pos-1 >= field_start) then - num_fields = num_fields + 1 - if (num_fields > size(fields)) then - RAISE_ERROR("parse_string ran out of space for fields", error) - endif - fields(num_fields) = this(field_start:delim_pos-1) - end if - field_start = delim_pos - endif - field_start = field_start + 1 - if (do_matching) then - opening_delim = this(delim_pos:delim_pos) - opening_delim_index = index(opening_delims(1:n_delims), opening_delim) - delim_pos = find_closing_delimiter(this(field_start:length), closing_delims(opening_delim_index:opening_delim_index), opening_delims(1:n_delims), closing_delims(1:n_delims), do_matching) - else - delim_pos = find_closing_delimiter(this(field_start:length), closing_delims, opening_delims(1:n_delims), closing_delims(1:n_delims), do_matching) - endif - if (delim_pos == 0) then ! didn't find closing delimiter - if (do_matching) then - call print("parse_string failed to find closing delimiter to match opening delimiter at position " // (field_start-1), PRINT_ALWAYS) - call print("parse_string string='"//this//"'", PRINT_ALWAYS) - RAISE_ERROR("parse_string failed to find closing delimiter", error) - else - delim_pos = length-field_start+2 - endif - endif - delim_pos = delim_pos + field_start - 1 - if (delim_pos-1 >= field_start) then - num_fields = num_fields + 1 - if (num_fields > size(fields)) then - RAISE_ERROR("parse_string ran out of space for fields", error) - endif - fields(num_fields) = this(field_start:delim_pos-1) - endif - field_start = delim_pos+1 - if (field_start > length) return - end do - - end subroutine parse_string - - recursive function find_closing_delimiter(this, closing_delim, opening_delims, closing_delims, matching) result(pos) - character(len=*), intent(in) :: this - character(len=*), intent(in) :: closing_delim - character(len=*), intent(in) :: opening_delims, closing_delims - logical :: matching - integer :: pos - - integer :: length, first_matching_closing_delim, first_opening_delim - integer :: opening_delim_index - character(len=1) :: opening_delim - integer :: substring_end_pos - - pos = 0 - - do - if (matching) then - first_matching_closing_delim = scan(this, closing_delim) - else - first_matching_closing_delim = scan(this, closing_delims) - endif - first_opening_delim = scan(this, opening_delims) - if ((first_opening_delim > 0) .and. (first_opening_delim < first_matching_closing_delim)) then - length = len(this) - if (matching) then - opening_delim = this(first_opening_delim:first_opening_delim) - opening_delim_index = index(opening_delims, opening_delim) - substring_end_pos = find_closing_delimiter(this(first_opening_delim+1:length), & - closing_delims(opening_delim_index:opening_delim_index), opening_delims, closing_delims, matching) - else - substring_end_pos = find_closing_delimiter(this(first_opening_delim+1:length), & - closing_delims, opening_delims, closing_delims, matching) - endif - if (substring_end_pos == 0) & - call system_abort("find_closing_delimiter failed to find substring closing delimiter '"// & - closing_delims(opening_delim_index:opening_delim_index)//"' in string '"//this// & - "' for substring starting at "//(first_opening_delim+1)) - substring_end_pos = substring_end_pos + first_opening_delim+1 - 1 - pos = find_closing_delimiter(this(substring_end_pos+1:length), closing_delim, opening_delims, & - closing_delims, matching) + substring_end_pos+1 - 1 - return - else - pos=first_matching_closing_delim - return - endif - end do - - return - - end function find_closing_delimiter - - !% Parse a string into fields delimited by certain characters. On exit - !% the 'fields' array will contain one field per entry and 'num_fields' - !% gives the total number of fields. 'status' will be given the error status - !% (if present) and so can be used to tell if an end-of-file occurred. - subroutine parse_string_orig(this, delimiters, fields, num_fields) - - character(*), intent(in) :: this - character(*), intent(in) :: delimiters - character(*), dimension(:), intent(inout) :: fields - integer, intent(out) :: num_fields - - integer :: field_start,field_end,width,length - integer :: array_length - - field_start = 1 - num_fields = 0 - length = len_trim(this) - array_length = size(fields) - - do - !Try to find a delimiter - width = scan(this(field_start:length),delimiters) - !If delimiter not found... - if (width == 0) then - !...and the rest of the string is blank... - if (len_trim(this(field_start:length)) == 0) then - !... then we've finished - exit - else - !otherwise, there's one field left to get - field_end = length - end if - !On the other hand, if the delimiter is the first character... - else if (width == 1) then - !...then move past it and start the do loop again - field_start = field_start + 1 - cycle - !Otherwise calculate the end of the field, without the delimiter - else - field_end = field_start + width - 2 - end if - - num_fields = num_fields + 1 - - if (num_fields > array_length) then - call print(this) - call system_abort('inoutput_parse_line: Number of fields is greater than storage array size') - end if - - fields(num_fields) = adjustl(this(field_start:field_end)) - field_start = field_end + 1 - - end do - - end subroutine parse_string_orig - - !% Convert an input string into an integer. - function string_to_int(string,error) - character(*), intent(in) :: string - integer, optional, intent(out) :: error - integer :: string_to_int - integer stat - - INIT_ERROR(error) - - string_to_int = 0 - read(string,*,iostat=stat) string_to_int - if(stat /= 0) then - RAISE_ERROR("string_to_int: could not convert, iostat="//stat, error) - endif - - end function string_to_int - - !% Convert an input string into a logical. - function string_to_logical(string, error) - character(*), intent(in) :: string - integer, optional, intent(out) :: error - logical :: string_to_logical - - INIT_ERROR(error) - - select case(trim(lower_case(string))) - case("true","t") - string_to_logical = .true. - case("false","f") - string_to_logical = .false. - case default - RAISE_ERROR("string_to_logical: could not convert. Only true/false/t/f (or any uppercase variants) may be converted. String passed: "//trim(string), error) - endselect - - end function string_to_logical - - - !% Convert an input string into a real. - function string_to_real(string, error) - character(*), intent(in) :: string - integer, optional, intent(out) :: error - real(dp) :: string_to_real - integer stat - - INIT_ERROR(error) - - string_to_real = 0.0_dp - read(string,*,iostat=stat) string_to_real - - if(stat /= 0) then - RAISE_ERROR("string_to_real: could not convert, iostat="//stat, error) - endif - - end function string_to_real - - subroutine string_to_real_sub(string,real_number,error) - character(len=*), intent(in) :: string - real(dp), intent(out) :: real_number - integer, intent(out), optional :: error - - integer :: stat - - INIT_ERROR(error) - - real_number = 0.0_dp - read(string,*,iostat=stat) real_number - - if(stat /= 0) then - RAISE_ERROR("string_to_real_sub: could not convert, iostat="//stat, error) - endif - endsubroutine string_to_real_sub - - subroutine string_to_integer_sub(string,integer_number,error) - character(len=*), intent(in) :: string - integer, intent(out) :: integer_number - integer, intent(out), optional :: error - - integer :: stat - - INIT_ERROR(error) - - integer_number = 0 - read(string,*,iostat=stat) integer_number - - if(stat /= 0) then - RAISE_ERROR("string_to_integer_sub: could not convert, iostat="//stat, error) - endif - endsubroutine string_to_integer_sub - - subroutine string_to_logical_sub(string,logical_number,error) - character(len=*), intent(in) :: string - logical, intent(out) :: logical_number - integer, intent(out), optional :: error - - integer :: stat - - INIT_ERROR(error) - - logical_number = .false. - read(string,*,iostat=stat) logical_number - - if(stat /= 0) then - RAISE_ERROR("string_to_logical_sub: could not convert, iostat="//stat, error) - endif - endsubroutine string_to_logical_sub - - subroutine string_to_real1d(string,real1d,error) - character(len=*), intent(in) :: string - real(dp), dimension(:), intent(out) :: real1d - integer, intent(out), optional :: error - - integer :: stat - - INIT_ERROR(error) - - real1d = 0.0_dp - read(string,*,iostat=stat) real1d - - if(stat /= 0) then - RAISE_ERROR("string_to_real1d: could not convert, iostat="//stat, error) - endif - endsubroutine string_to_real1d - - subroutine string_to_integer1d(string,integer1d,error) - character(len=*), intent(in) :: string - integer, dimension(:), intent(out) :: integer1d - integer, intent(out), optional :: error - - integer :: stat - - INIT_ERROR(error) - - integer1d = 0 - read(string,*,iostat=stat) integer1d - - if(stat /= 0) then - RAISE_ERROR("string_to_integer1d: could not convert, iostat="//stat, error) - endif - endsubroutine string_to_integer1d - - subroutine string_to_logical1d(string,logical1d,error) - character(len=*), intent(in) :: string - logical, dimension(:), intent(out) :: logical1d - integer, intent(out), optional :: error - - integer :: stat - - INIT_ERROR(error) - - logical1d = .false. - read(string,*,iostat=stat) logical1d - - if(stat /= 0) then - RAISE_ERROR("string_to_logical1d: could not convert, iostat="//stat, error) - endif - endsubroutine string_to_logical1d - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Reallocation: used to reduce the need to deallocate and reallocate -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine reallocate_int1d(array, d1, zero, copy) - integer, allocatable, dimension(:), intent(inout) :: array - integer, intent(in) :: d1 - logical, optional, intent(in) :: zero, copy - - logical :: do_copy - integer, allocatable :: tmp(:) - - if (allocated(array)) then - if (size(array) /= d1) then - do_copy = optional_default(.false., copy) - if (do_copy) then - allocate(tmp(size(array))) - tmp = array - endif - deallocate(array) - allocate(array(d1)) - if (do_copy) then - array = 0 - array(1:min(size(tmp),size(array))) = tmp(1:min(size(tmp),size(array))) - deallocate(tmp) - endif - end if - else - allocate(array(d1)) - end if - - if (present(zero)) then - if (zero) array = 0 - end if - - end subroutine reallocate_int1d - - subroutine reallocate_real1d(array, d1, zero, copy) - real(dp), allocatable, dimension(:), intent(inout) :: array - integer, intent(in) :: d1 - logical, optional, intent(in) :: zero, copy - - logical :: do_copy - real(dp), allocatable :: tmp(:) - - if (allocated(array)) then - if (size(array) /= d1) then - do_copy = optional_default(.false., copy) - if (do_copy) then - allocate(tmp(size(array))) - tmp = array - endif - deallocate(array) - allocate(array(d1)) - if (do_copy) then - array = 0 - array(1:min(size(tmp),size(array))) = tmp(1:min(size(tmp),size(array))) - deallocate(tmp) - endif - end if - else - allocate(array(d1)) - end if - - if (present(zero)) then - if (zero) array = 0.0_dp - end if - - end subroutine reallocate_real1d - - - subroutine reallocate_int2d(array, d1, d2, zero, copy) - integer, allocatable, dimension(:,:), intent(inout) :: array - integer, intent(in) :: d1,d2 - logical, optional, intent(in) :: zero, copy - - logical :: do_copy - integer, allocatable :: tmp(:,:) - - if (allocated(array)) then - if (.not. all(shape(array) == (/d1,d2/))) then - do_copy = optional_default(.false., copy) - if (do_copy) then - allocate(tmp(size(array,1),size(array,2))) - tmp = array - endif - deallocate(array) - allocate(array(d1,d2)) - if (do_copy) then - array = 0 - array(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2))) = tmp(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2))) - deallocate(tmp) - endif - end if - else - allocate(array(d1,d2)) - end if - - if (present(zero)) then - if (zero) array = 0 - end if - - end subroutine reallocate_int2d - - subroutine reallocate_int3d(array, d1, d2, d3, zero, copy) - integer, allocatable, dimension(:,:,:), intent(inout) :: array - integer, intent(in) :: d1,d2,d3 - logical, optional, intent(in) :: zero, copy - - logical :: do_copy - integer, allocatable :: tmp(:,:,:) - - if (allocated(array)) then - if (.not. all(shape(array) == (/d1,d2,d3/))) then - do_copy = optional_default(.false., copy) - if (do_copy) then - allocate(tmp(size(array,1),size(array,2),size(array,3))) - tmp = array - endif - deallocate(array) - allocate(array(d1,d2,d3)) - if (do_copy) then - array = 0 - array(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2)),1:min(size(tmp,3),size(array,3))) = tmp(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2)),1:min(size(tmp,3),size(array,3))) - deallocate(tmp) - endif - end if - else - allocate(array(d1,d2,d3)) - end if - - if (present(zero)) then - if (zero) array = 0 - end if - - end subroutine reallocate_int3d - - subroutine reallocate_real2d(array, d1, d2, zero, copy) - real(dp), allocatable, dimension(:,:), intent(inout) :: array - integer, intent(in) :: d1,d2 - logical, optional, intent(in) :: zero, copy - - logical :: do_copy - real(dp), allocatable :: tmp(:,:) - - if (allocated(array)) then - if (.not. all(shape(array) == (/d1,d2/))) then - do_copy = optional_default(.false., copy) - if (do_copy) then - allocate(tmp(size(array,1),size(array,2))) - tmp = array - endif - deallocate(array) - allocate(array(d1,d2)) - if (do_copy) then - array = 0.0_dp - array(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2))) = tmp(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2))) - deallocate(tmp) - endif - end if - else - allocate(array(d1,d2)) - end if - - if (present(zero)) then - if (zero) array = 0.0_dp - end if - - end subroutine reallocate_real2d - - subroutine reallocate_char1d(array, d1, zero, copy) - character(len=*), allocatable, dimension(:), intent(inout) :: array - integer, intent(in) :: d1 - logical, optional, intent(in) :: zero, copy - - - if (allocated(array)) then - call reallocate_allocated_char1d(array,d1,copy) - else - allocate(array(d1)) - end if - - if (present(zero)) then - if (zero) array = "" - end if - - - end subroutine reallocate_char1d - - subroutine reallocate_allocated_char1d(array,d1,copy) - character(len=*), allocatable, dimension(:), intent(inout) :: array - integer, intent(in) :: d1 - logical, optional, intent(in) :: copy - - logical :: do_copy - character(len=len(array(lbound(array)))), allocatable, dimension(:) :: tmp - - if (size(array) /= d1) then - do_copy = optional_default(.false., copy) - if (do_copy) then - allocate(tmp(size(array))) - tmp = array - endif - deallocate(array) - allocate(array(d1)) - if (do_copy) then - array = "" - array(1:min(size(tmp),size(array))) = tmp(1:min(size(tmp),size(array))) - deallocate(tmp) - endif - end if - endsubroutine reallocate_allocated_char1d - - subroutine reallocate_log1d(array, d1, zero, copy) - logical, allocatable, dimension(:), intent(inout) :: array - integer, intent(in) :: d1 - logical, optional, intent(in) :: zero, copy - - logical :: do_copy - logical, allocatable :: tmp(:) - - if (allocated(array)) then - if (size(array) /= d1) then - do_copy = optional_default(.false., copy) - if (do_copy) then - allocate(tmp(size(array))) - tmp = array - endif - deallocate(array) - allocate(array(d1)) - if (do_copy) then - array = .false. - array(1:min(size(tmp),size(array))) = tmp(1:min(size(tmp),size(array))) - deallocate(tmp) - endif - end if - else - allocate(array(d1)) - end if - - if (present(zero)) then - if (zero) array = .false. - end if - - end subroutine reallocate_log1d - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Read scalar and array data from ascii files. These -!% interfaces are not yet heavily overloaded to cater for all intrinsic and most -!% derived types. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine reada_real_dim1(this,da,status) - type(Inoutput), intent(in) :: this - real(dp), intent(out) :: da(:) - integer, optional, intent(out) :: status - - integer :: my_status - - if (this%action == OUTPUT) call system_abort('read_line: Cannot read from an output file ('//trim(adjustl(this%filename))//')') - - if (present(status)) then - read (this%unit,fmt=*,iostat=status) da - else - read (this%unit,fmt=*,iostat=my_status) da - if (my_status < 0) call system_abort('read_line: End of file when reading '//trim(adjustl(this%filename))) - if (my_status > 0) call system_abort('read_line: Error reading file '//trim(adjustl(this%filename))) - end if - end subroutine reada_real_dim1 - - subroutine reada_int_dim1(this,ia,status) - type(Inoutput), intent(in) :: this - integer, intent(out) :: ia(:) - integer, optional, intent(out) :: status - - integer :: my_status - - if (this%action == OUTPUT) call system_abort('read_line: Cannot read from an output file ('//trim(adjustl(this%filename))//')') - - if (present(status)) then - read (this%unit,fmt=*,iostat=status) ia - else - read (this%unit,fmt=*,iostat=my_status) ia - if (my_status < 0) call system_abort('read_line: End of file when reading '//trim(adjustl(this%filename))) - if (my_status > 0) call system_abort('read_line: Error reading file '//trim(adjustl(this%filename))) - end if - end subroutine reada_int_dim1 - - !% Rewind to the start of this file. Works for both formatted and unformatted files. - subroutine rewind(this) - type(Inoutput), intent(inout) :: this - rewind this%unit - end subroutine rewind - - !% Move the file pointer back by 'n' (defaults to 1) records. Works for - !% formatted and unformatted files. - subroutine backspace(this,n) - type(Inoutput), intent(inout) :: this - integer, optional :: n - integer :: i - if (present(n)) then - do i=1,n - backspace this%unit - end do - else - backspace this%unit - end if - end subroutine backspace - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Concatenation functions. -!% Overloadings for the // operator to make strings from various other types. -!% In each case, we need to work out the exact length of the resultant string -!% in order to avoid printing excess spaces. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Return a string which is the real number 'r' rounded to 'digits' decimal digits - function round(r,digits) - - real(dp), intent(in) :: r - integer, intent(in) :: digits - ! below we work out the exact length of the resultant string - ! space for '-' sign or not + digits in integer part + space for . or not + decimal digits - character( int(0.5_dp-sign(0.5_dp,r)) + int(log10(max(1.0_dp,abs(r)+0.5_dp*10.0_dp**(-digits)))) + 1 + int(sign(0.5_dp,real(digits,dp)-0.5_dp)+0.5_dp) + max(0,digits)) :: round - character(8) :: format - - if (digits > 0) then - write(format,'(a,i0,a)')'(f0.',max(0,digits),')' - write(round,format) r - else - write(round,'(i0)') int(r) - end if - - end function round - - function string_cat_logical(string, log) - character(*), intent(in) :: string - logical, intent(in) :: log - character((len(string)+1)) :: string_cat_logical - write(string_cat_logical,'(a,l1)') string, log - end function string_cat_logical - - function string_cat_logical_array(string, log) - character(*), intent(in) :: string - logical, intent(in) :: log(:) - character((len(string)+2*size(log)-1)) :: string_cat_logical_array - character(len=32) format - - format = '(a,'//size(log)//'(l1,1x),l1)' - write(string_cat_logical_array,format) string, log - end function string_cat_logical_array - - elemental function int_format_length_isp(i) result(len) - integer(isp), intent(in)::i - integer::len - len = max(1,(-sign(1, i)+1)/2 + ceiling(log10(abs(real(i,dp))+0.01_dp))) - end function int_format_length_isp - - elemental function int_format_length_idp(i) result(len) - integer(idp), intent(in) :: i - integer :: len - len = max(1_idp,(-sign(1_idp, i)+1_idp)/2_idp + ceiling(log10(abs(real(i,dp))+0.01_dp), idp)) - end function int_format_length_idp - - function string_cat_isp(string, int) result(res) - character(*), intent(in) :: string - integer(isp), intent(in) :: int - ! below we work out the exact length of the resultant string - character(len(string)+int_format_length(int)) :: res - - write(res,'(a,i0)') string, int - end function string_cat_isp - - function string_cat_idp(string, int) result(res) - character(*), intent(in) :: string - integer(idp), intent(in) :: int - ! below we work out the exact length of the resultant string - character(len(string)+int_format_length(int)) :: res - - write(res,'(a,i0)') string, int - end function string_cat_idp - - function int_cat_string(int,string) - character(*), intent(in) :: string - integer, intent(in) :: int - ! below we work out the exact length of the resultant string - character(len(string)+int_format_length(int)) :: int_cat_string - - write(int_cat_string,'(i0,a)') int,string - end function int_cat_string - - function string_cat_int_array(string, values) - character(*), intent(in) :: string - integer, intent(in) :: values(:) - ! below we work out the exact length of the resultant string - character(len(string)+size(values)+sum(int_format_length(values)))::string_cat_int_array - - character(32) :: format - - if (size(values) == 1) then - format = '(a,i0)' - write(string_cat_int_array,format) string, values - else if (size(values)>1) then - format = '(a,' // (size(values)-1) //'(i0,1x),i0)' - write(string_cat_int_array,format) string, values - else - write(string_cat_int_array,'(a)') string - end if - - end function string_cat_int_array - - pure function real_sci_format_length() result(len) - integer::len - ! space sign 0. fractional part E+000 - len = 1 + 1 + 2 + max(0,mainlog%default_real_precision)+5 - end function real_sci_format_length - - - function string_cat_real_array(string, values) - character(*), intent(in) :: string - real(dp), intent(in) :: values(:) - ! we work out the exact length of the resultant string - character((len(string)+size(values)*real_sci_format_length())) :: string_cat_real_array - character(32) :: format - - if (size(values)>0) then - ! replaced concatenation with write... for PGI bug, NB 22/6/2007 - write(format,'("(a,",I0,"e",I0,".",I0,"e3)")') size(values), real_sci_format_length(), & - mainlog%default_real_precision - write(string_cat_real_array, format) string, values - else - write(string_cat_real_array, '(a)') string - end if - - end function string_cat_real_array - - function string_cat_complex_array(string, values) - character(*), intent(in) :: string - complex(dp), intent(in) :: values(:) - ! we work out the exact length of the resultant string - character((len(string)+2*size(values)*real_sci_format_length())) :: string_cat_complex_array - character(32) :: format - - if (size(values)>0) then - ! replaced concatenation with write... for PGI bug, NB 22/6/2007 - write(format,'("(a,",I0,"e",I0,".",I0,"e3)")') 2*size(values), real_sci_format_length(), & - mainlog%default_real_precision - write(string_cat_complex_array, format) string, values - else - write(string_cat_complex_array, '(a)') string - end if - - end function string_cat_complex_array - - function string_cat_string_array(string, values) - character(*), intent(in) :: string - character(*), intent(in) :: values(:) - ! we work out the exact length of the resultant string -#ifndef __PGI - character(len(string)+size(values)*len(values(1))) :: string_cat_string_array -#else -#warning temporal fix in size of string_cat_string_array - ! nvfortran: temporal fix - character(len(string)) :: string_cat_string_array -#endif - character(32) :: format - - if (size(values)>0) then - ! replaced concatenation with write... for PGI bug, NB 22/6/2007 - write(format,'("(a",I0,",",I0,"a",I0,")")') len(string), size(values)+1, len(values(1)) - write(string_cat_string_array, format) string, values - else - write(string_cat_string_array, '(a)') string - end if - - end function string_cat_string_array - - function real_array_cat_string(values, string) - character(*), intent(in) :: string - real(dp), intent(in) :: values(:) - ! we work out the exact length of the resultant string - character((len(string)+size(values)*real_sci_format_length())) :: real_array_cat_string - character(32) :: format - - if (size(values)>0) then - ! replaced concatenation with write... for PGI bug, NB 22/6/2007 - write(format,'("(",I0,"e",I0,".",I0,"e3,a)")') size(values), real_sci_format_length(), & - mainlog%default_real_precision - write(real_array_cat_string, format) values, string - else - write(real_array_cat_string, '(a)') string - end if - - end function real_array_cat_string - - pure function real_format_length(r) result(len) - real(dp), intent(in) :: r - integer :: len - integer :: space_for_sign, space_for_exponent - character(len=256) :: tmp - - if(isnan(r)) then - len = 3 - elseif( mainlog%default_real_precision > 0 .or. abs(r) > huge(1) / 10 ) then - space_for_sign = int(0.5_dp-sign(0.5_dp,r)) - space_for_exponent = merge(0,5,abs(r) > 0.1_dp .and. abs(r) < 10.0_dp**mainlog%default_real_precision ) - ! NULL/- . 12345 NULL/E-000 - len = space_for_sign + 1 + merge(mainlog%default_real_precision,15,mainlog%default_real_precision > 0) + space_for_exponent - else - write(tmp,'(i0)') int(r) - len = len_trim(tmp) - end if - -#ifdef GFORTRAN_ZERO_HACK - !gfortran hack - 0.0000... is printed as .00000000 - if (r == 0.0_dp) then len = len - 1 -#endif - - end function real_format_length - - pure function complex_format_length(c) result(len) - complex(dp), intent(in)::c - integer::len - - len = real_format_length(real(c))+1+real_format_length(imag(c)) - end function complex_format_length - - function real_cat_string(r, string) - character(*), intent(in) :: string - real(dp), intent(in) :: r - ! we work out the exact length of the resultant string - character( len(string)+real_format_length(r) ) :: real_cat_string - character(12) :: format - - integer :: len_r - - len_r = real_format_length(r) - - if (isnan(r)) then - write(real_cat_string,'(a,a)') "NaN", string - elseif( mainlog%default_real_precision > 0 .or. abs(r) > huge(1) / 10 ) then - if( abs(r) > 0.1_dp .and. abs(r) < 10.0_dp**mainlog%default_real_precision ) then - write(format,'(a,i0,a,i0,a)')'(f',len_r,'.',mainlog%default_real_precision-floor(log10(abs(r)))-1,',a)' - else - write(format,'(a,i0,a,i0,a)')'(e',len_r,'.',merge(mainlog%default_real_precision,15,mainlog%default_real_precision > 0),'E3,a)' - endif - write(real_cat_string,format) r, string - else - write(real_cat_string,'(i0,a)') int(r), string - endif - - end function real_cat_string - - function string_cat_real(string,r) - character(*), intent(in) :: string - real(dp), intent(in) :: r - ! we work out the exact length of the resultant string - character( len(string)+real_format_length(r) ) :: string_cat_real - character(12) :: format - - integer :: len_r - - len_r = real_format_length(r) - - if (isnan(r)) then - write(string_cat_real,'(a,a)') string, "NaN" - elseif( mainlog%default_real_precision > 0 .or. abs(r) > huge(1) / 10 ) then - if( abs(r) > 0.1_dp .and. abs(r) < 10.0_dp**mainlog%default_real_precision ) then - write(format,'(a,i0,a,i0,a)')'(a,f',len_r,'.',mainlog%default_real_precision-floor(log10(abs(r)))-1,')' - else - write(format,'(a,i0,a,i0,a)')'(a,e',len_r,'.',merge(mainlog%default_real_precision,15,mainlog%default_real_precision > 0),'E3)' - endif - write(string_cat_real,format) string, r - else - write(string_cat_real,'(a,i0)') string, int(r) - endif - - end function string_cat_real - - function string_cat_complex(string, c) - character(*), intent(in) :: string - complex(dp), intent(in) :: c - ! we work out the exact length of the resultant string - character( len(string)+complex_format_length(c)) :: string_cat_complex - character(24) :: format - - string_cat_complex = string//real(c)//","//aimag(c) - - end function string_cat_complex - - !% Returns a string with number shortened to 2 to 4 digits and si prefix appended - function i2si(number) result(res) - integer(idp), intent(in) :: number - character(:), allocatable :: res - character, parameter :: prefixes(0:*) = [' ', 'K', 'M', 'G', 'T', 'P', 'E'] - - integer :: i, l - integer(idp) :: num - character(5) :: str - - num = number - do i = lbound(prefixes, 1), ubound(prefixes, 1)-1 - if (num < 10000) exit - num = num / 1000 - end do - str = "" // num - - l = len_trim(str) - allocate(character(len=l+2) :: res) - res = str(1:l) // " " // prefixes(i) - end function i2si - - !% Return the mpi size and rank for the communicator 'comm'. - !% this routine aborts of _MPI is not defined - subroutine get_mpi_size_rank(comm, nproc, rank) - - integer, intent(in) :: comm !% MPI communicator - integer, intent(out) :: nproc !% Total number of processes - integer, intent(out) :: rank !% Rank of this process - -#ifdef _MPI - - integer::error_code - - call MPI_COMM_SIZE(comm, nproc, error_code) - if (error_code .ne. MPI_SUCCESS) then - rank=-1 - nproc=-1 - return - endif - call MPI_COMM_RANK(comm, rank, error_code) - if (error_code .ne. MPI_SUCCESS) then - rank=-1 - nproc=-1 - return - endif -#else - rank = 0 - nproc = 1 -#endif - end subroutine get_mpi_size_rank - - ! System initialiser - - !% Must be called at the start of all programs. Initialises MPI if present, - !% set the random number seed sets up the default Inoutput objects - !% logger and errorlog to point to stdout and stderr respectively. Calls - !% Hello_World to do some of the work and print a friendly welcome. If we're - !% using MPI, by default we set the same random seed for each process. - !% This also attempts to read the executable name, the number of command - !% arguments, and the arguments themselves. - subroutine system_initialise(verbosity,seed, mpi_all_inoutput, common_seed, enable_timing, quippy_running, mainlog_file, mainlog_unit) - integer,intent(in), optional::verbosity !% mainlog output verbosity - integer,intent(in), optional::seed !% Seed for the random number generator. - logical,intent(in), optional::mpi_all_inoutput !% Print on all MPI nodes (false by default) - logical,intent(in), optional::common_seed - logical,intent(in), optional::enable_timing !% Enable system_timer() calls - logical,intent(in), optional::quippy_running !% .true. if running under quippy (Python interface) - character(len=*),intent(in), optional :: mainlog_file - integer,intent(in), optional :: mainlog_unit - !% If 'common_seed' is true (default), random seed will be the same for each - !% MPI process. - character(30) :: arg - integer :: status, i, n - logical :: master_only - -#ifdef _MPI - integer::PRINT_ALWAYS - logical :: is_initialised - - call MPI_initialized(is_initialised, PRINT_ALWAYS) - call abort_on_mpi_error(PRINT_ALWAYS, "system_initialise, mpi_initialised()") - if (.not. is_initialised) then - call MPI_INIT(PRINT_ALWAYS) - call abort_on_mpi_error(PRINT_ALWAYS, "system_initialise, mpi_init()") - endif - call get_mpi_size_rank(MPI_COMM_WORLD, mpi_n, mpi_myid) - if (mpi_n < 1 .or. mpi_myid < 0) & - call system_abort("system_initialise Got bad size="//mpi_n// " or rank="//mpi_myid//" from get_mpi_size_rank") - error_mpi_myid = mpi_myid -#else - mpi_n = 1 ! default - mpi_myid = 0 ! default -#endif - - ! should really be in declaration, but ifort complains -#ifdef NO_F2003_NEW_LINE - quip_new_line = char(13) -#else - quip_new_line = new_line(' ') -#endif - - call cpu_time(start_time) - master_only = .not. optional_default(.false., mpi_all_inoutput) - - ! Initialise the verbosity stack and default logger - call initialise(mainlog, filename=mainlog_file, unit=mainlog_unit, verbosity=verbosity, & - action=OUTPUT, master_only=master_only) - call print_mpi_id(mainlog) - call initialise(errorlog, filename='stderr', master_only=master_only) - call print_mpi_id(errorlog) - error_unit = errorlog%unit - - call hello_world(seed, common_seed) - - RAN_MAX = huge(1) - - ! Query arguments and executable name - num_command_args = cmd_arg_count() - call get_cmd_arg(0, arg, status=status) - if (status == 0) then - EXEC_NAME = arg - else - EXEC_NAME ='' - end if - if (NUM_COMMAND_ARGS < MAX_READABLE_ARGS) then - n = NUM_COMMAND_ARGS - else - n = MAX_READABLE_ARGS - end if - do i = 1, n - call get_cmd_arg(i, COMMAND_ARG(i), status = status) - if (status /= 0) then - write(line,'(a,i0)')'system_initialise: Problem reading command argument ',i - call system_abort(line) - end if - end do - - system_do_timing = optional_default(.false., enable_timing) - if (system_do_timing) then - call print("Calls to system_timer will report times") - else - call print("Calls to system_timer will do nothing by default") - endif - call print('') - - system_quippy_running = optional_default(.false., quippy_running) - - end subroutine system_initialise - - subroutine get_mainlog_errorlog_ptr(mainlog_ptr, errorlog_ptr) - type inoutput_ptr - type(inoutput), pointer :: p - end type inoutput_ptr -#ifndef SIZEOF_FORTRAN_T -#error "SIZEOF_FORTRAN_T not defined. Check your build scripts, e.g. build/${QUIP_ARCH}/Makefile.inc" -#endif - integer, intent(out), dimension(SIZEOF_FORTRAN_T) :: mainlog_ptr, errorlog_ptr - type(inoutput_ptr) :: mainlog_p, errorlog_p - - mainlog_p%p => mainlog - mainlog_ptr = transfer(mainlog_p, mainlog_ptr) - errorlog_p%p => errorlog - errorlog_ptr = transfer(errorlog_p, errorlog_ptr) - - end subroutine get_mainlog_errorlog_ptr - - function cmd_arg_count() - integer :: cmd_arg_count - -#ifndef GETARG_F2003 - integer :: iargc - external iargc -#endif - -#ifndef GETARG_F2003 - cmd_arg_count = iargc() -#else - cmd_arg_count = command_argument_count() -#endif - end function cmd_arg_count - - subroutine get_cmd_arg(i,arg, status) - integer, intent(in) :: i - character(len=*), intent(out) :: arg - integer, intent(out), optional :: status - -#ifndef GETARG_F2003 - external getarg -#endif - -#ifndef GETARG_F2003 - call getarg(i, arg) - if (present(status)) status = 0 -#else - call get_command_argument(i, arg, status=status) -#endif - end subroutine get_cmd_arg - - subroutine get_env_var(name, arg, status) - character(len=*), intent(in) :: name - character(len=*), intent(out) :: arg - integer, intent(out), optional :: status - -#ifndef GETENV_F2003 - external getenv -#endif - -#ifndef GETENV_F2003 - call getenv(trim(name), arg) - if (present(status)) then - if( len_trim(arg) > 0 ) then - status = 0 - else - status = 1 - endif - endif -#else - call get_environment_variable(trim(name), arg, status=status) -#endif - end subroutine get_env_var - - !% Shut down gracefully, finalising system objects. - subroutine system_finalise() - integer :: values(8) -#ifdef _MPI - integer :: PRINT_ALWAYS -#endif - logical :: ltemp - integer, allocatable :: seeds(:), idums(:) - - call print("") - call system_get_random_seeds(seeds, idums) - ltemp = mainlog%mpi_all_inoutput_flag - mainlog%mpi_all_inoutput_flag = .true. - call print('libAtoms::Finalise: random seeds(:) = '//seeds, PRINT_VERBOSE) - call print('libAtoms::Finalise: random idums(:) = '//idums, PRINT_VERBOSE) - mainlog%mpi_all_inoutput_flag = ltemp - - call date_and_time(values=values) - call print('libAtoms::Finalise: '//date_and_time_string(values)) - call print("libAtoms::Finalise: Bye-Bye!") - call finalise(mainlog) - call finalise(errorlog) -#ifdef _MPI - call mpi_finalize(PRINT_ALWAYS) - call abort_on_mpi_error(PRINT_ALWAYS, "system_finalise, mpi_finalise()") -#endif - end subroutine system_finalise - - !% Backward compatible (replaced with print_message) routine to print a warning message to log - subroutine print_warning(message) - character(*), intent(in) :: message - !write (0,*) 'WARNING: '//message - call print_message('WARNING', message) - end subroutine print_warning - - !% Print a message to log - subroutine print_message(message_type, message, verbosity) - character(*), intent(in) :: message_type - character(*), intent(in) :: message - integer, intent(in), optional :: verbosity ! default passed to print() - !write (0,*) 'WARNING: '//message - call print(message_type // ': ' // message, verbosity=verbosity) - end subroutine print_message - - !% Take the values from 'date_and_time' and make a nice string - function date_and_time_string(values) - character(21) :: date_and_time_string - integer, intent(in) :: values(8) - character(2) :: time(7) - character(4) :: year - integer :: i - - write(year,'(i0)') values(1) - do i = 2, 7 - if (i==4) cycle ! We don't use the local adjustment to UTC - write(time(i),'(i0.2)') values(i) - end do - write(date_and_time_string,'(11a)') year,'-',time(2),'-',time(3),' ',time(5),':',time(6),':',time(7) - - end function date_and_time_string - - subroutine system_set_random_seeds(seed) -#ifdef _OPENMP - use omp_lib -#endif - integer, intent(in) :: seed - - integer :: n - integer, allocatable :: seed_a(:) - - integer :: i, ran_dummy - -#ifdef _OPENMP - !$omp parallel - idum=seed*(omp_get_thread_num()+1) - !$omp end parallel -#else - idum=seed !gabor generator -#endif - - call random_seed(size=n) - allocate(seed_a(n)) - seed_a = seed - call random_seed(put=seed_a) !fortran 90 generator - deallocate(seed_a) - - ! The first seed tends to give very small random numbers. The loop below decorrelates the seed from the initial value so it can be trusted to be uniform. -!$OMP parallel - do i = 1, 100 - ran_dummy = ran() - enddo -!$OMP end parallel - end subroutine system_set_random_seeds - - subroutine system_get_random_seeds(seeds, idums) - integer, intent(out), allocatable :: seeds(:), idums(:) - - integer :: n - - call random_seed(size=n) - call reallocate(seeds, n) - call random_seed(get=seeds) - -#ifdef _OPENMP - !$omp parallel shared(idums) - !$omp single - call reallocate(idums, omp_get_num_threads()) - idums = 0 - !$omp end single - idums(omp_get_thread_num()+1) = idum - !$omp end parallel -#else - call reallocate(idums, 1) - idums(1) = idum -#endif - end subroutine system_get_random_seeds - - !% Called by 'system_initialise' to print welcome messages and - !% seed the random number generator. - subroutine hello_world(seed, common_seed) - integer, optional::seed !% Seed for the random number generator. - logical, optional :: common_seed - !% If 'common_seed' is true (default), random seed will be the same for each - !% MPI process. -!$ character(len=SYSTEM_STRING_LENGTH) :: omp_stacksize - integer:: actual_seed - integer:: values(20) ! for time inquiry function - logical :: use_common_seed - integer :: np=1, myp=0 -#ifdef _MPI - integer :: PRINT_ALWAYS -#endif - - call date_and_time(values=values) - - call print('libAtoms::Hello World: '//date_and_time_string(values)) - call print('libAtoms::Hello World: git version '//current_version()) - call print('libAtoms::Hello World: QUIP_ARCH '//QUIP_ARCH) - call print('libAtoms::Hello World: compiled on '//__DATE__//' at '//__TIME__) -#ifdef _MPI - call print('libAtoms::Hello World: MPI parallelisation with '//mpi_n_procs()//' processes') -#endif -! Open MP stuff -!$OMP parallel -!$OMP master -!$ call print('libAtoms::Hello World: OpenMP parallelisation with '//OMP_get_num_threads()//' threads') -!$ call get_env_var('OMP_STACKSIZE',omp_stacksize) -!$ if(len_trim(omp_stacksize) == 0) then -!$ call print_message('WARNING', 'libAtoms::Hello World: environment variable OMP_STACKSIZE not set explicitly. The default value - system and compiler dependent - may be too small for some applications.') -!$ else -!$ call print('libAtoms::Hello World: OMP_STACKSIZE='//trim(omp_stacksize)) -!$ endif -!$OMP end master -!$OMP end parallel - if(present(seed)) then - actual_seed = seed - else -#ifdef _MPI - call get_mpi_size_rank(MPI_COMM_WORLD, np, myp) -#endif - actual_seed= (((values(5)*60+values(6))*60+values(7))*1000+values(8))*np+1+myp ! (number of ms since beginning of the day time) * np + rank - use_common_seed = optional_default(.true., common_seed) -#ifdef _MPI - if (.not. use_common_seed) then - call print('libAtoms::Hello World: MPI run with different seeds on each process') - else - call print('libAtoms::Hello World: MPI run with the same seed on each process') - - ! Broadcast seed from process 0 to all others - call MPI_Bcast(actual_seed, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, PRINT_ALWAYS) - call abort_on_mpi_error(PRINT_ALWAYS, 'Hello_World: MPI_Bcast()') - end if -#endif - end if - - call print('libAtoms::Hello World: Random Seed = '//actual_seed) - call system_set_random_seeds(actual_seed) - - call print('libAtoms::Hello World: global verbosity = '//value(mainlog%verbosity_stack)) - call print('') - end subroutine hello_world - - subroutine system_resync_rng -#ifdef _MPI -#ifdef _OPENMP - use omp_lib -#endif - integer :: PRINT_ALWAYS -#ifdef _OPENMP - integer, allocatable :: idum_buf(:) -#endif - call print('Resynchronising random number generator', PRINT_VERBOSE) - -#ifdef _OPENMP - allocate(idum_buf(omp_get_max_threads())) - ! Collect all seeds into continuous buffer - !$omp parallel default(none) shared(idum_buf) - idum_buf(omp_get_thread_num()+1) = idum - !$omp end parallel - ! Broadcast seed from process 0 to all others - call MPI_Bcast(idum_buf, omp_get_max_threads(), MPI_INTEGER, 0, & - MPI_COMM_WORLD, PRINT_ALWAYS) - call abort_on_mpi_error(PRINT_ALWAYS, 'system_resync_rng') - ! Set seeds on individual threads - !$omp parallel default(none) shared(idum_buf) - idum = idum_buf(omp_get_thread_num()+1) - !$omp end parallel - deallocate(idum_buf) -#else - ! Broadcast seed from process 0 to all others - call MPI_Bcast(idum, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, PRINT_ALWAYS) - call abort_on_mpi_error(PRINT_ALWAYS, 'system_resync_rng') -#endif -#endif - end subroutine system_resync_rng - - ! - !% Return the correct ordinal ending (st,nd,rd,th) for the given integer - ! - elemental function th(n) - - integer, intent(in) :: n - character(2) :: th - integer :: l,m - - l = mod(n,100) - m = mod(n,10) - - if (l > 10 .and. l < 20) then - th = 'th' - else - select case(m) - case(1) - th = 'st' - case(2) - th = 'nd' - case(3) - th = 'rd' - case default - th = 'th' - end select - end if - - end function th - - - !% Reseed the random number generator. Useful when restarting from check files. - subroutine system_reseed_rng(new_seed) - integer, intent(in) :: new_seed - - call print('libAtoms::Reseed_RNG: Reseeding random number generator, new seed = '//new_seed,PRINT_VERBOSE) - call system_set_random_seeds(new_seed) - end subroutine system_reseed_rng - - !% Return the current random number seed. - function system_get_random_seed() - integer :: system_get_random_seed - - system_get_random_seed = idum - end function system_get_random_seed - - !% Return a random integer - function ran() - integer::ran - integer:: k - real(dp):: dran - - if (system_use_fortran_random) then - call random_number(dran) - ran = dran*RAN_MAX - else - if (idum == 0) & - call system_abort("function ran(): linear-congruential random number generators fail with seed idum=0") - k = idum/ran_Q - idum = ran_A*(idum-k*ran_Q)-ran_R*k - if(idum < 0) idum = idum + ran_M - ran =idum - endif - end function ran - - !% Return a random real number uniformly distributed in the range [0,1] - function ran_uniform() - real(dp)::ran_uniform - - if (system_use_fortran_random) then - call random_number(ran_uniform) - else - ran_uniform = 1.1_dp - do while (ran_uniform > 1.0_dp) ! generating [0,1] - ran_uniform = real(ran(),dp)/RAN_MAX - end do - end if - end function ran_uniform - - !% Return random real from Normal distribution with mean zero and standard deviation one. - function ran_normal() - real(dp) :: ran_normal, r, v1, v2 - r = 2.0_dp - do while (r > 1.0_dp) - v1 = 2.0_dp * ran_uniform() - 1.0_dp - v2 = 2.0_dp * ran_uniform() - 1.0_dp - r = v1*v1 + v2*v2 - end do - ran_normal = v1 * sqrt(-2.0_dp * log(r) / r) - end function ran_normal - - !% Return a random real distributed exponentially between zero and positive infinity - !% with mean and variance of unity - function ran_exp() result(r) - real(dp) :: r - r = -log(ran_uniform()) - end function ran_exp - - !% Return a random string of length l containing the characters A-Z, a-z, and 0-9 - function ran_string(l) - - integer, intent(in) :: l - character(len=l) :: ran_string - integer :: i, n - - do i = 1, l - n = mod(ran(),62) - if (n < 10) then - ran_string(i:i) = achar(n+48) ! 0-9 - else if (n < 36) then - ran_string(i:i) = achar(n+55) ! A-Z - else - ran_string(i:i) = achar(n+61) ! a-z - end if - end do - - end function ran_string - - subroutine current_times(cpu_t, wall_t, mpi_t) - real(dp), intent(out), optional :: cpu_t, wall_t, mpi_t - integer(kind=8) wall_t_count, count_rate, max_count - if (present(cpu_t)) call cpu_time(cpu_t) - if (present(wall_t)) then - call system_clock(wall_t_count, count_rate, max_count) - wall_t = real(wall_t_count,dp) * 1.0_dp/real(count_rate,dp) - endif -#ifdef _MPI - if (present(mpi_t)) mpi_t = MPI_Wtime() -#else - if (present(mpi_t)) mpi_t = 0.0_dp -#endif - end subroutine current_times - - !% Measure elapsed CPU and wall clock time between pairs of calls with - !% matching 'name' parameter. Calls to 'system_timer' must be properly - !% nested (i.e. start and stop from different pairs can't overlap), and - !% maximum depth of calls is set by the 'TIMER_STACK' parameter. - !% - !%> call system_timer(name) start the clock - !%> ... do something - !%> call system_timer(name) stop clock and print elapsed time - !%> - !%> If optional do_always argument is true, routine will do its thing even - !%> if system_do_timing is false. - ! - subroutine system_timer(name, do_always, time_elapsed, do_print) -#ifdef _OPENMP - use omp_lib -#endif - character(len=*), intent(in) :: name !% Unique identifier for this timer - logical, intent(in), optional :: do_always - real(dp), intent(out), optional :: time_elapsed - logical, intent(in), optional :: do_print - - integer, save :: stack_pos = 0 - real(dp), save, dimension(TIMER_STACK) :: wall_t0, cpu_t0 - character(len=255), save, dimension(TIMER_STACK) :: names - character(len=50) :: out_name - - logical my_do_always, my_do_print - - logical :: found_name - real(dp) :: cpu_t1, wall_t1 -#ifdef _MPI - real(dp), save :: mpi_t0(TIMER_STACK) - real(dp) :: mpi_t1 -#endif - - my_do_always = optional_default(.false., do_always) - my_do_print = optional_default(.true., do_print) - - if (.not. my_do_always .and. .not. system_do_timing) return - -#ifdef _OPENMP - ! stacks are not thread safe, so if we're in an OpenMP parallel region do nothing - if (omp_get_num_threads() > 1) return -#endif - - found_name = .false. - if (stack_pos >= 1) found_name = trim(names(stack_pos)) == trim(name) - - if (.not. found_name) then - ! Start a new timer - stack_pos = stack_pos + 1 - if (stack_pos > TIMER_STACK) then - call print_message('WARNING', 'System_Timer: stack overflow, name ' // trim(name)) - return - end if - - names(stack_pos) = trim(name) - -#ifdef _MPI - call current_times(cpu_t0(stack_pos), wall_t0(stack_pos), mpi_t0(stack_pos)) -#else - call current_times(cpu_t0(stack_pos), wall_t0(stack_pos)) -#endif - - if (present(time_elapsed)) time_elapsed = 0.0_dp - - else - ! Stop the most recently started timer -#ifdef _MPI - call current_times(cpu_t1, wall_t1, mpi_t1) -#else - call current_times(cpu_t1, wall_t1) -#endif - - out_name = name -#ifndef _MPI - if (present(time_elapsed)) time_elapsed = wall_t1-wall_t0(stack_pos) - if (my_do_print) then - call print("TIMER: " // out_name // " done in " // (cpu_t1-cpu_t0(stack_pos)) // & - " cpu secs, " // (wall_t1-wall_t0(stack_pos))//" wall clock secs.") - endif -#else - if (present(time_elapsed)) time_elapsed = mpi_t1-mpi_t0(stack_pos) - if (my_do_print) then - call print("TIMER: " // out_name // " done in " // (cpu_t1-cpu_t0(stack_pos)) // & - " cpu secs, " // (wall_t1-wall_t0(stack_pos))//" wall clock secs, " // & - (mpi_t1-mpi_t0(stack_pos)) // " mpi wall secs.") - endif -#endif - - stack_pos = stack_pos - 1 - if (stack_pos < 0) & - call system_abort('System_Timer: stack underflow, name ' // trim(name)) - end if - - end subroutine system_timer - - - !% Test if the file 'filename' can be accessed. - function is_file_readable(filename) - character(len=*), intent(in) :: filename - logical :: is_file_readable - - integer myunit - integer stat - - myunit=pick_up_unit() - - open(file=filename,unit=myunit,status="OLD",iostat=stat) - - if(stat == 0)then - is_file_readable = .true. - close(unit=myunit) - else - is_file_readable = .false. - end if - - end function is_file_readable - - - subroutine Stack_Initialise(this, value) - type(stack), intent(inout) :: this - integer, optional::value - - call Finalise(this) - allocate(this%val(4)) - if(present(value)) then - this%val(1) = value - this%pos = 1 - else - this%pos = 0 - end if - - end subroutine Stack_Initialise - - subroutine Stack_Finalise(this) - type(stack), intent(inout) :: this - - if (allocated(this%val)) deallocate(this%val) - - end subroutine Stack_Finalise - - subroutine Stack_push(this, val) - type(Stack), intent(inout) :: this - integer, intent(in) :: val - - integer, allocatable :: val_t(:) - - if (.not. allocated(this%val)) then - allocate(this%val(4)) - endif - - if (this%pos+1 > size(this%val)) then - allocate(val_t(size(this%val))) - val_t = this%val - deallocate(this%val) - allocate(this%val(2*size(val_t))) - this%val(1:size(val_t)) = val_t - deallocate(val_t) - endif - - this%val(this%pos+1) = val - this%pos = this%pos + 1 - - end subroutine Stack_push - - subroutine Stack_pop(this) - type(Stack), intent(inout) :: this - - if (this%pos > 0) then - this%pos = this%pos - 1 - else - call system_abort("Underflow in Stack_pop") - endif - end subroutine Stack_pop - - function stack_value(this) - type(Stack), intent(in) :: this - integer :: stack_value - - if (this%pos > 0) then - stack_value = this%val(this%pos) - else - call system_abort("Called stack_value on empty stack, pos = " // this%pos) - endif - end function stack_value - - subroutine Stack_print(this, verbosity, out) - type(Stack), intent(in) :: this - integer, intent(in), optional :: verbosity - type(inoutput), intent(in), optional :: out - - call Print("Stack:", verbosity, out) - if (allocated(this%val)) then - call Print("Stack: size " // size(this%val), verbosity, out) - call Print("Stack: val " // this%val(1:this%pos), verbosity, out) - endif - end subroutine Stack_Print - - !% Map from verbsoity codes to descriptive strings - function verbosity_to_str(val) result(str) - integer, intent(in) :: val - character(10) :: str - - select case(val) - case(PRINT_ALWAYS) - str = 'ERROR' - case(PRINT_SILENT) - str = 'SILENT' - case(PRINT_NORMAL) - str = 'NORMAL' - case(PRINT_VERBOSE) - str = 'VERBOSE' - case(PRINT_NERD) - str = 'NERD' - case(PRINT_ANALYSIS) - str = 'ANALYSIS' - end select - end function verbosity_to_str - - !% Map from descriptive verbosity names ('NORMAL', 'VERBOSE' etc.) to numbers - function verbosity_of_str(str) result(val) - character(len=*), intent(in) :: str - integer :: val - - if (trim(str) == 'ERROR') then - val = PRINT_ALWAYS - else if (trim(str) == 'SILENT') then - val = PRINT_SILENT - else if (trim(str) == 'NORMAL') then - val = PRINT_NORMAL - else if (trim(str) == 'VERBOSE') then - val = PRINT_VERBOSE - else if (trim(str) == 'NERD') then - val = PRINT_NERD - else if (trim(str) == 'ANALYSIS') then - val = PRINT_ANALYSIS - else - call system_abort("verbosity_of_str failed to understand '"//trim(str)//"'") - end if - end function verbosity_of_str - - - !% Push a value onto the verbosity stack - !% Don't ever lower the verbosity if verbosity minimum is set, - !% but always push _something_ - subroutine verbosity_push(val) - integer, intent(in) :: val - - if ((value(mainlog%verbosity_cascade_stack) == 0) .or. & - val > value(mainlog%verbosity_stack)) then - call push(mainlog%verbosity_stack, val) - else - call push(mainlog%verbosity_stack, value(mainlog%verbosity_stack)) - endif - !call print('verbosity_push now '//current_verbosity(), PRINT_ALWAYS) - end subroutine verbosity_push - - !% pop the current verbosity value off the stack - subroutine verbosity_pop() - call pop(mainlog%verbosity_stack) - !call print('verbosity_pop now '//current_verbosity(), PRINT_ALWAYS) - end subroutine verbosity_pop - - !% return the current value of verbosity - function current_verbosity() - integer :: current_verbosity - current_verbosity = value(mainlog%verbosity_stack) - end function current_verbosity - - !% push the current value + n onto the stack - subroutine verbosity_push_increment(n) - integer, intent(in), optional :: n - integer my_n - - my_n = 1 - if(present(n)) my_n = n - call verbosity_push(value(mainlog%verbosity_stack)+my_n) - end subroutine verbosity_push_increment - - !% push the current value - n onto the stack - subroutine verbosity_push_decrement(n) - integer, intent(in), optional :: n - integer my_n - - my_n = 1 - if(present(n)) my_n = n - call verbosity_push(value(mainlog%verbosity_stack)-my_n) - end subroutine verbosity_push_decrement - - !% set the minimum verbosity value, by pushing value onto - !% stack and pushing 1 on to verbosity_cascade_stack - subroutine verbosity_set_minimum(verbosity) - integer, intent(in) :: verbosity - - call push(mainlog%verbosity_cascade_stack, 1) - call verbosity_push(verbosity) - end subroutine verbosity_set_minimum - - !% unset the minimum verbosity value, by popping value from - !% stack and popping from verbosity_cascade_stack - subroutine verbosity_unset_minimum() - call verbosity_pop() - call pop(mainlog%verbosity_cascade_stack) - end subroutine verbosity_unset_minimum - - pure function optional_default_l(def, opt_val) - logical, intent(in) :: def - logical, intent(in), optional :: opt_val - logical :: optional_default_l - - if (present(opt_val)) then - optional_default_l = opt_val - else - optional_default_l = def - endif - - end function optional_default_l - - pure function optional_default_i(def, opt_val) - integer, intent(in) :: def - integer, intent(in), optional :: opt_val - integer :: optional_default_i - - if (present(opt_val)) then - optional_default_i = opt_val - else - optional_default_i = def - endif - - end function optional_default_i - - pure function optional_default_ia(def, opt_val) - integer, intent(in) :: def(:) - integer, intent(in), optional :: opt_val(size(def)) - integer :: optional_default_ia(size(def)) - - if (present(opt_val)) then - optional_default_ia = opt_val - else - optional_default_ia = def - endif - - end function optional_default_ia - - - pure function optional_default_r(def, opt_val) - real(dp), intent(in) :: def - real(dp), intent(in), optional :: opt_val - real(dp) :: optional_default_r - - if (present(opt_val)) then - optional_default_r = opt_val - else - optional_default_r = def - endif - - end function optional_default_r - - pure function optional_default_ra(def, opt_val) - real(dp), intent(in) :: def(:) - real(dp), intent(in), optional :: opt_val(size(def)) - real(dp) :: optional_default_ra(size(def)) - - if (present(opt_val)) then - optional_default_ra = opt_val - else - optional_default_ra = def - endif - - end function optional_default_ra - - - pure function optional_default_z(def, opt_val) - complex(dp), intent(in) :: def - complex(dp), intent(in), optional :: opt_val - complex(dp) :: optional_default_z - - if (present(opt_val)) then - optional_default_z = opt_val - else - optional_default_z = def - endif - - end function optional_default_z - - pure function optional_default_c(def, opt_val) - character(len=*), intent(in) :: def - character(len=*), intent(in), optional :: opt_val - character(SYSTEM_STRING_LENGTH) :: optional_default_c - - if (present(opt_val)) then - optional_default_c = opt_val - else - optional_default_c = def - endif - - end function optional_default_c - - pure function optional_default_ca(def, opt_val) - character(len=*), dimension(:), intent(in) :: def - character(len=*), dimension(:), intent(in), optional :: opt_val - character(SYSTEM_STRING_LENGTH), dimension(size(def)) :: optional_default_ca - - if (present(opt_val)) then - optional_default_ca = opt_val - else - optional_default_ca = def - endif - - end function optional_default_ca - - subroutine enable_timing() - system_do_timing = .true. - end subroutine enable_timing - - subroutine disable_timing() - system_do_timing = .false. - end subroutine disable_timing - - function get_timing() - logical :: get_timing - get_timing = system_do_timing - end function get_timing - - subroutine set_timing(do_timing) - logical :: do_timing - - system_do_timing = do_timing - end subroutine set_timing - - function get_quippy_running() - logical :: get_quippy_running - - get_quippy_running = system_quippy_running - - end function get_quippy_running - - function increase_stack(stack_size) - integer, intent(in) :: stack_size - integer :: increase_stack - - integer, external :: c_increase_stack - - increase_stack = c_increase_stack(stack_size) - end function increase_stack - - !% Abort with a useful message if an MPI routine returned an error status - subroutine abort_on_mpi_error(error_code, routine_name) - integer, intent(in) :: error_code - character(len=*), intent(in) :: routine_name - -#ifdef _MPI - - character(MPI_MAX_ERROR_STRING)::error_string - integer::error_string_length, my_error_code - - if(error_code .ne. MPI_SUCCESS) then - call MPI_ERROR_STRING(error_code, error_string, error_string_length, my_error_code) - if(my_error_code .ne. MPI_SUCCESS) then - call system_abort(trim(routine_name) // " returned with error code = " // error_code & - // ", which could not be parsed") - else - call system_abort(trim(routine_name) // " had error '" // trim(error_string) // "'") - endif - endif -#else - call system_abort("abort_on_mpi_error called with routine_name='"//trim(routine_name)//"' " // & - " error_code " // error_code // " even though MPI is off") -#endif - end subroutine abort_on_mpi_error - - - subroutine parallel_print(lines, comm, verbosity, file) - character(len=*), intent(in) :: lines(:) - integer, intent(in) :: comm - integer, intent(in), optional :: verbosity - type(inoutput), intent(inout), optional :: file - - integer i -#ifdef _MPI - - integer proc - integer mpi_stat(MPI_STATUS_SIZE) - integer, allocatable :: lengths(:) - integer :: lengths_send(2) - character, allocatable :: in_lines(:) - integer n_c, line_l, n_lines - integer err - - if (mpi_id() == 0) then -#endif - do i=1, size(lines) - call Print(trim(lines(i)), verbosity, file) - end do -#ifdef _MPI - allocate(lengths(2*mpi_n_procs())) - lengths_send(1) = size(lines) - lengths_send(2) = len(adjustr(lines(1))) - call mpi_gather(lengths_send,2,MPI_INTEGER,lengths,2,MPI_INTEGER,0,comm,err) - - do proc=1, mpi_n_procs()-1 - n_lines = lengths((proc)*2+1) - line_l = lengths((proc)*2+2) - allocate(in_lines(n_lines*line_l)) - call mpi_recv(in_lines,n_lines*line_l,MPI_CHARACTER,proc,100+proc,comm,mpi_stat,err) - do i=1, n_lines*line_l, line_l - call Print(in_lines(i:i+line_l-1), verbosity, file) - end do - deallocate(in_lines) - end do - - deallocate(lengths) - - else - line_l = len(adjustr(lines(1))) - lengths_send(1) = size(lines) - lengths_send(2) = line_l - call mpi_gather(lengths_send,2,MPI_INTEGER,lengths,2,MPI_INTEGER,0,comm,err) - n_c = line_l*size(lines) - call mpi_send(lines,n_c,MPI_CHARACTER,0,100+mpi_id(),comm,err) - endif -#endif - - end subroutine parallel_print - - subroutine ALLOC_TRACE(str,amt) - character(len=*), intent(in) :: str - integer, intent(in) :: amt - - if (trace_memory) then - traced_memory = traced_memory + amt - call print("TR_ALLOCATE " // str // " " // amt // " " // traced_memory) - endif - end subroutine ALLOC_TRACE - - subroutine DEALLOC_TRACE(str,amt) - character(len=*), intent(in) :: str - integer, intent(in) :: amt - if (trace_memory) then - traced_memory = traced_memory - amt - call print("TR_ALLOCATE " // str // " " // (-amt) // " " // traced_memory) - endif - end subroutine DEALLOC_TRACE - -#ifdef _OPENMP - function system_omp_get_num_threads() - use omp_lib - integer :: system_omp_get_num_threads - -!$omp parallel -!$omp master - system_omp_get_num_threads = omp_get_num_threads() -!$omp end master -!$omp end parallel - end function system_omp_get_num_threads - - subroutine system_omp_set_num_threads(threads) - use omp_lib - integer, intent(in) :: threads - - call omp_set_num_threads(threads) - end subroutine system_omp_set_num_threads -#endif - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X These functions provide low-level access to some MPI global variables -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Return this processes' MPI ID - pure function mpi_id() result (id) - integer::id - id = mpi_myid - end function mpi_id - - !% Return the total number of MPI processes. - pure function mpi_n_procs() result (n) - integer::n - n = mpi_n - end function mpi_n_procs - - function reference_true() - logical :: reference_true - - reference_true = .true. - - end function reference_true - - function reference_false() - logical :: reference_false - - reference_false = .false. - - end function reference_false - -!% String to character array -function s2a(s) result(a) - character(len=*), intent(in) :: s - character(len=1), dimension(len(s)) :: a - - integer i - - do i=1,len(s) - a(i) = s(i:i) - end do - -end function s2a - -!% Character array to string -function a2s(a) result(s) - character(len=1), dimension(:), intent(in) :: a - character(len=size(a)) :: s - - integer i - - do i=1,size(a) - s(i:i) = a(i) - end do - -end function a2s - -!% String to padded character array of length l -function pad(s,l) result(a) - character(len=*), intent(in) :: s - integer, intent(in) :: l - character(len=1), dimension(l) :: a - - integer i - - a = ' ' - do i=1,min(len(s),size(a)) - a(i) = s(i:i) - end do -end function pad - - function make_run_directory(basename, force_run_dir_i, run_dir_i, error) result(dir) - character(len=*), optional :: basename - integer, intent(in), optional :: force_run_dir_i - integer, intent(out), optional :: run_dir_i - integer, intent(out), optional :: error - character(len=SYSTEM_STRING_LENGTH) :: dir - - integer i - character(len=SYSTEM_STRING_LENGTH) :: use_basename - integer :: use_force_run_dir_i - - logical :: exists - integer stat - - INIT_ERROR(error) - - use_force_run_dir_i = optional_default(-1, force_run_dir_i) - use_basename = optional_default("run", basename) - - if (use_force_run_dir_i >= 0) then - i = use_force_run_dir_i - dir = trim(use_basename)//"_"//i - call system_command("bash -c '[ -d "//trim(dir)//" ]'", status=stat) - if (stat /= 0) then - RAISE_ERROR("make_run_directory got force_run_dir_i="//use_force_run_dir_i//" but "//trim(dir)//" doesn't exist or isn't a directory", error) - endif - else - exists = .true. - i = 0 - do while (exists) - i = i + 1 - dir = trim(use_basename)//"_"//i - call system_command("bash -c '[ -e "//trim(dir)//" ]'", status=stat) - exists = (stat == 0) - end do - call system_command("mkdir "//trim(dir), status=stat) - if (stat /= 0) then - RAISE_ERROR("Failed to mkdir "//trim(dir)//" status " // stat, error) - endif - endif - - if (present(run_dir_i)) run_dir_i = i - - end function make_run_directory - - function link_run_directory(sourcename, basename, run_dir_i, error) result(dir) - character(len=*), intent(in) :: sourcename - character(len=*), optional :: basename - integer, intent(out), optional :: run_dir_i - integer, intent(out), optional :: error - character(len=SYSTEM_STRING_LENGTH) :: dir - - integer i - character(len=SYSTEM_STRING_LENGTH) :: use_basename - - logical :: exists - integer stat - - INIT_ERROR(error) - - use_basename = optional_default("run", basename) - - exists = .true. - i = 0 - do while (exists) - i = i + 1 - dir = trim(use_basename)//"_"//i - call system_command("bash -c '[ -e "//trim(dir)//" ]'", status=stat) - exists = (stat == 0) - end do - call system_command("ln -s "//trim(sourcename)//" "//trim(dir), status=stat) - if (stat /= 0) then - RAISE_ERROR("Failed to link "//trim(dir)//" status " // stat, error) - endif - - if (present(run_dir_i)) run_dir_i = i - - end function link_run_directory - - function current_version() - character(len=SYSTEM_STRING_LENGTH) :: current_version - -#ifdef GIT_VERSION - current_version = trim(GIT_VERSION) -#else - current_version = "" -#endif - - endfunction current_version - - pure function linebreak_string_length(str, line_len) result(length) - character(len=*), intent(in) :: str - integer, intent(in) :: line_len - integer :: length - - length = len_trim(str)+2*len_trim(str)/line_len+3 - - end function linebreak_string_length - - function linebreak_string(str, line_len) result(lb_str) - character(len=*), intent(in) :: str - integer, intent(in) :: line_len - - character(len=linebreak_string_length(str, line_len)) :: lb_str - - logical :: word_break - integer :: copy_len, last_space - character(len=len(lb_str)) :: tmp_str - - lb_str="" - tmp_str=trim(str) - do while (len_trim(tmp_str) > 0) - copy_len = min(len_trim(tmp_str),line_len) - if (tmp_str(copy_len:copy_len) /= " ") then - last_space=scan(tmp_str(1:copy_len), " ", .true.) - if ( last_space > 0 .and. (len_trim(tmp_str(1:copy_len)) - last_space) < 4) then - copy_len=last_space - endif - endif - - if (len_trim(lb_str) > 0) then ! we already have some text, add newline before concatenating next line - lb_str = trim(lb_str)//quip_new_line//trim(tmp_str(1:copy_len)) - else ! just concatenate next line - lb_str = trim(tmp_str(1:copy_len)) - endif - ! if we broke in mid word, add "-" - word_break = .true. - if (tmp_str(copy_len:copy_len) == " ") then ! we broke right after a space, so no wordbreak - word_break = .false. - else ! we broke after a character - if (copy_len < len_trim(tmp_str)) then ! there's another character after this one, check if it's a space - if (tmp_str(copy_len+1:copy_len+1) == " ") then - word_break = .false. - endif - else ! we broke after the last character - word_break = .false. - endif - endif - if (word_break) lb_str = trim(lb_str)//"-" - tmp_str(1:copy_len) = "" - tmp_str=adjustl(tmp_str) - end do - - end function linebreak_string - - subroutine mem_info_i(total_mem_i, free_mem_i) - integer(idp), intent(out) :: total_mem_i, free_mem_i - real(8) :: total_mem_r, free_mem_r - call mem_info(total_mem_r, free_mem_r) - total_mem_i = int(total_mem_r, idp) - free_mem_i = int(free_mem_r, idp) - end subroutine mem_info_i - - subroutine mem_info_r(total_mem, free_mem) - real(8), intent(out) :: total_mem, free_mem - call c_mem_info(total_mem, free_mem) - end subroutine mem_info_r - - subroutine print_mem_info(file) - type(inoutput), intent(in), optional :: file - - real(8) :: total_mem, free_mem - - call mem_info(total_mem, free_mem) - - call print('TOTAL MEMORY = '//total_mem/1.0e9_dp//' GB', file=file) - call print('FREE MEMORY = '//free_mem/1.0e9_dp//' GB', file=file) - - endsubroutine print_mem_info - - subroutine wait_for_file_to_exist(filename, max_wait_time, cycle_time, error) - character(len=*) filename - real(dp) :: max_wait_time - real(dp), optional :: cycle_time - integer, intent(out), optional :: error - - real(dp) :: total_wait_time, use_cycle_time - integer :: usleep_cycle_time - logical :: file_exists - - INIT_ERROR(error) - - use_cycle_time = optional_default(0.1_dp, cycle_time) - usleep_cycle_time = int(use_cycle_time*1000000) - - inquire(file=filename, exist=file_exists) - total_wait_time = 0.0_dp - do while (.not. file_exists) - call fusleep(usleep_cycle_time) - total_wait_time = total_wait_time + use_cycle_time - inquire(file=filename, exist=file_exists) - if (.not. file_exists .and. total_wait_time > max_wait_time) then - RAISE_ERROR("error waiting too long for '"//trim(filename)//"' to exist", error) - endif - end do - - end subroutine wait_for_file_to_exist - - !% Convert a word to upper case - function upper_case(word) - character(*) , intent(in) :: word - character(len(word)) :: upper_case - - integer :: i,ic,nlen - - nlen = len(word) - do i=1,nlen - ic = ichar(word(i:i)) - if (ic >= 97 .and. ic <= 122) then - upper_case(i:i) = char(ic-32) - else - upper_case(i:i) = char(ic) - end if - end do - end function upper_case - - !% Convert a word to lower case - pure function lower_case(word) - character(*) , intent(in) :: word - character(len(word)) :: lower_case - - integer :: i,ic,nlen - - nlen = len(word) - do i=1,nlen - ic = ichar(word(i:i)) - if (ic >= 65 .and. ic <= 90) then - lower_case(i:i) = char(ic+32) - else - lower_case(i:i) = char(ic) - end if - end do - end function lower_case - - pure function replace(string, search, substitute) result(res) - character(len=*), intent(in) :: string - character(len=1), intent(in) :: search, substitute - character(len=len(string)) :: res - - integer :: i - - i = 1 - do i = 1, len(string) - if (string(i:i) == search) then - res(i:i) = substitute - else - res(i:i) = string(i:i) - end if - end do - end function replace - - !% Print a progress bar - subroutine progress(total,current, name) - integer, intent(in) :: total, current - character(len=*), intent(in) :: name - - integer :: current_percent, k - - character(len=17) :: bar - - bar="???% | |" - - if(total >= current) then - current_percent = ceiling( 100.0_dp * real(current,dp) / real(total,dp) ) - - write(unit=bar(1:3),fmt="(i3)") current_percent - - do k = 1, current_percent / 10 - bar(6+k:6+k)="*" - enddo - ! print the progress bar. - write(unit=mainlog%unit,fmt="(a1,a,$)") char(13), trim(name) // " " // bar - else - write(unit=mainlog%unit,fmt=*) - endif - - end subroutine progress - - !% Print a progress bar with an estimate of time to completion - !% based on the elapsed time so far - subroutine progress_timer(total, current, name, elapsed_seconds) - integer, intent(in) :: total, current - character(len=*), intent(in) :: name - real(dp), intent(in) :: elapsed_seconds - - integer :: current_percent, k - real(dp) :: elapsed_time, estimated_time - character(len=1) :: time_units - - character(len=27) :: bar - - bar="???% | |" - - if(total >= current) then - current_percent = ceiling( 100.0_dp * real(current,dp) / real(total,dp) ) - estimated_time = elapsed_seconds * real(total,dp) / real(current,dp) - - write(unit=bar(1:3),fmt="(i3)") current_percent - - ! fill the progress bar - do k = 1, current_percent / 5 - bar(6+k:6+k)="*" - enddo - ! convert time to readable units - if (estimated_time / 60.0_dp > 2.0_dp) then - if (estimated_time / 3600.0_dp > 2.0_dp) then - if (estimated_time / 86400.0_dp > 3.0_dp) then - elapsed_time = elapsed_seconds / 86400.0_dp - estimated_time = estimated_time / 86400.0_dp - time_units = 'd' - else - elapsed_time = elapsed_seconds / 3600.0_dp - estimated_time = estimated_time / 3600.0_dp - time_units = 'h' - endif - else - elapsed_time = elapsed_seconds / 60.0_dp - estimated_time = estimated_time / 60.0_dp - time_units = 'm' - endif - else - elapsed_time = elapsed_seconds - time_units = 's' - endif - - ! print the progress bar. - write(unit=mainlog%unit,fmt="(a1,a,f5.1,a,f5.1,a)",advance="no") char(13), & - trim(name) // " " // bar // " ", & - elapsed_time, " / ", estimated_time, " " // time_units - else - write(unit=mainlog%unit,fmt=*) - endif - - end subroutine progress_timer - - function increase_to_multiple(a, m) result(res) - integer, intent(in) :: a, m - integer :: res - res = (a / m) * m - if (res < a) res = res + m - end function increase_to_multiple - - !% get indices of unique array elements and references - !% to these indices for each element of the array - subroutine get_uniqs_refs_char1(array, uniqs, refs, lower_bound) - character(*), intent(in) :: array(lower_bound:) - integer, intent(out), allocatable :: uniqs(:) - integer, intent(out), allocatable :: refs(:) - integer, intent(in) :: lower_bound - - integer :: r, u, n_vals - integer :: lb, ub, nb - integer, allocatable :: vals(:) - - lb = lbound(array, 1) - ub = ubound(array, 1) - allocate(vals(lb:ub)) - allocate(refs(lb:ub)) - - n_vals = 0 - do_refs: do r = lb, ub - nb = n_vals + lb - 1 - do u = nb, lb, -1 ! assuming similar neighbours - if (array(r) == array(vals(u))) then - refs(r) = u - cycle do_refs - end if - end do - refs(r) = nb + 1 - vals(refs(r)) = r - n_vals = n_vals + 1 - end do do_refs - - nb = n_vals + lb - 1 - allocate(uniqs(lb:nb)) - uniqs = vals(lb:nb) - end subroutine get_uniqs_refs_char1 - - function join_char1(array, sep) result(res) - character(*), intent(in) :: array(:) - character(*), intent(in) :: sep - character(:), allocatable :: res - - integer :: i, o, l_res, l_as - - l_as = len(array) + len(sep) - l_res = l_as * size(array) - len(sep) - allocate(character(l_res) :: res) - o = 0 - do i = lbound(array, 1), ubound(array, 1) - 1 - res(o+1:o+l_as) = array(i) // sep - o = o + l_as - end do - res(o+1:) = array(ubound(array, 1)) - end function join_char1 - -end module system_module diff --git a/src/libAtoms/Table.f95 b/src/libAtoms/Table.f95 deleted file mode 100644 index afa4bb337e..0000000000 --- a/src/libAtoms/Table.f95 +++ /dev/null @@ -1,2134 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Table module -!X -!% A 'Table' is an extensible 2D array of integers, reals, strings and logicals. -!% The lengths of all rows are the same and the number of rows will grow and shrink -!% as datais appended or deleted. Extra columns can also be appended, although this -!% is envisaged to be required less often. Any of the number of integers, -!% number of reals, number of strings and number of logicals can be zero -!% -!% Integers are referenced by 'table%int' -!% -!% Reals are referenced by 'table%real' -!% -!% Strings are referenced by 'table%str' -!% -!% Logicals are referenced by 'table%logical' -!% -!% Appending to the table is through the 'append' interface. -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module table_module - use error_module - use system_module - use linearalgebra_module - use mpi_context_module - use dictionary_module - implicit none - private - - public :: table, allocate, initialise, finalise, print, set_increment, append, find, table_string_length - public :: wipe, delete, int_part, real_part, logical_part, str_part, sort, search, select, int_subtable, insert, delete_multiple - public :: append_column, subtable, remove_columns - - integer, parameter, private :: DEFAULT_TABLE_LENGTH = 100 - integer, parameter, private :: DEFAULT_TABLE_INCREMENT = 1000 - - integer, parameter :: TABLE_STRING_LENGTH = 10 - -#ifdef DEBUG - integer :: table_realloc_count = 0 -#endif - - type Table - integer,allocatable, dimension(:,:) :: int !% (intsize,N) array of integer data - real(dp),allocatable, dimension(:,:) :: real !% (realsize,N) array of real data - character(TABLE_STRING_LENGTH), allocatable, dimension(:,:) :: str !% (strsize,N) array of string data - logical, allocatable, dimension(:,:) :: logical !% (logicalsize,N) array of logical data - integer::increment = DEFAULT_TABLE_INCREMENT !% How many rows to grow the table by on reallocation (default 1000) - integer::max_length = 0 !% Initial maximum length of the table before the first reallocation (default 100) - integer::intsize = 0 !% Number of integer columns - integer::realsize = 0 !% Number of real columns - integer::strsize = 0 !% Number of string columns - integer::logicalsize = 0 !% Number of logical columns - integer::N=0 !% Number of rows - end type Table - - !% Allocate a 'Table'. When allocating a table, you can - !% optionally specify the number of integer and real columns and the - !% initial amount of space to allocate ('max_length'). If a table is - !% unallocated when append is called for the first time it will be - !% allocated accordingly. - interface allocate - module procedure table_allocate - end interface allocate - - interface initialise - module procedure table_allocate - end interface - - !% Finalise this table. - interface finalise - module procedure table_finalise - end interface finalise - - !% Change the increment for this table. - interface set_increment - module procedure table_set_increment - end interface set_increment - -! This overriden interface causes seg faults on Tru64 unix, and does -! not seem to be necessary with ifort9, sun f95 or HP f95 so it's -! been removed for now. - -!!$ interface assignment(=) -!!$ module procedure table_assign_table -!!$ end interface - - - !% Append rows to a table. Overloaded to be able to append single elements, - !% arrays or other tables. - interface append - module procedure table_append_row_or_arrays, table_append_table - module procedure table_append_int_element, table_append_real_element - module procedure table_append_str_element, table_append_logical_element - module procedure table_append_int_element_and_real_element - module procedure table_append_int_row_real_element - module procedure table_append_int_element_real_row - module procedure table_append_int_array, table_append_real_array - module procedure table_append_str_array, table_append_logical_array - end interface append - - !% Append 1 or more columns to a table. Overloaded to be able to append - !% a scalar, 1-D array (must match N rows), or other tables (must match N rows) - interface append_column - module procedure table_append_col_i, table_append_col_i_a - module procedure table_append_col_r, table_append_col_r_a - module procedure table_append_col_s, table_append_col_s_a - module procedure table_append_col_l, table_append_col_l_a - module procedure table_append_col_table - end interface append_column - - !% remove a range of columns from a table's int or real parts - interface remove_columns - module procedure table_remove_columns - end interface remove_columns - - !% insert a row at a given position - interface insert - module procedure table_insert - end interface insert - - !% Search the integer part of a table for a given element or array. - interface find - module procedure table_find_element, table_find_row - end interface find - - !% Sort a table according to its int part - interface sort - module procedure table_sort - end interface sort - - !% Do a binary search (faster than find) on a pre-sorted table - interface search - module procedure table_search - end interface search - - !% Print this table to the mainlog or to an inoutput object. - interface print - module procedure table_print, table_print_mainlog - end interface print - - !% Utility function to return one or more columns from the integer part of a table. - !% Since this is a function the array may be returned on the stack, so be careful - !% when working with large tables --- the same goes for the 'real_part' - !% interface below. - interface int_part - module procedure table_int_part, table_int_column, table_int_columns - end interface int_part - - !% Utility function to return one or more columns from the real part of a table. - interface real_part - module procedure table_real_part, table_real_column, table_real_columns - end interface real_part - - interface str_part - module procedure table_str_part, table_str_column, table_str_columns - end interface str_part - - interface logical_part - module procedure table_logical_part, table_logical_column, table_logical_columns - end interface logical_part - - !% Delete a row by index or by value. If by value then the match - !% is made by the integer part of the table. The last row is copied - !% over the row to be deleted, so the order of rows is not maintained. - interface delete - module procedure table_record_delete_by_index - module procedure table_record_delete_by_value - end interface delete - - !% Delete multiple rows from a Table. Beware, the order of rows - !% is not maintained. - interface delete_multiple - module procedure table_record_delete_multiple - end interface delete_multiple - - !% Clear this table, but keep the allocation. - interface wipe - module procedure table_wipe - end interface wipe - - !% Zero all parts of this table. - interface zero - module procedure table_zero - end interface zero - - private::rms_diff_list - interface rms_diff - module procedure rms_diff_list - end interface - - !% Select certains rows from a table based on a mask - private::table_select - interface select - module procedure table_select - end interface select - - private :: table_bcast - interface bcast - module procedure table_bcast - end interface - - private :: table_copy_entry - interface copy_entry - module procedure table_copy_entry - endinterface copy_entry - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! general functions used to allocate and deallocate tables - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - ! Table_Allocate: Initialises a Table object ready for use. - subroutine table_allocate(this,Nint,Nreal,Nstr,Nlogical,max_length,error) - - type(table), intent(inout) :: this - integer, optional, intent(in) :: Nint !% Number of integer columns - integer, optional, intent(in) :: Nreal !% Number of real columns - integer, optional, intent(in) :: Nstr !% Number of string columns - integer, optional, intent(in) :: Nlogical !% Number of logical columns - integer, optional, intent(in) :: max_length !% Number of rows to initially allocate - type(table) :: temp - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if (present(Nint) .or. present(Nreal) .or. present(Nstr) .or. present(Nlogical)) then - - ! Initialise the table to the given dimensions - - call finalise(this) - this%max_length = DEFAULT_TABLE_LENGTH - - !If max length is present then we have info about how big the table - !is likely to be... so set the increment accordingly - if (present(max_length)) then - this%max_length = max_length - this%increment = max(1,max_length/10) - end if - - ! Beware, interface change! - if (.not. present(Nint) .or. .not. present(Nreal) .or. & - .not. present(Nstr) .or. .not. present(Nlogical)) then - call print('WARNING: The interface to table_allocate (allocate(table,...) and', PRINT_ALWAYS) - call print(' initialise(table,...)) has changed!', PRINT_ALWAYS) - call print(' from call allocate(table,Nint,Nreal,length)', PRINT_ALWAYS) - call print(' to call allocate(table,Nint,Nreal,Nstr,Nlogical,length)', PRINT_ALWAYS) - call print('Please update your code!', PRINT_ALWAYS) - RAISE_ERROR('table_allocate: if one of Nint, Nreal, Nstr, Nlogical is present then all must be!', error) - end if - - if (present(Nint)) then - this%intsize = max(Nint,0) - if (this%intsize > 0) allocate(this%int(this%intsize,this%max_length)) - else - this%intsize = 0 - end if - - if (present(Nreal)) then - this%realsize = max(Nreal,0) - if (this%realsize > 0) allocate(this%real(this%realsize,this%max_length)) - else - this%realsize = 0 - end if - - if (present(Nstr)) then - this%strsize = max(Nstr,0) - if (this%strsize > 0) allocate(this%str(this%strsize,this%max_length)) - else - this%strsize = 0 - end if - - if (present(Nlogical)) then - this%logicalsize = max(Nlogical,0) - if (this%logicalsize > 0) allocate(this%logical(this%logicalsize,this%max_length)) - else - this%logicalsize = 0 - end if - else - - ! Change the length of the table, keeping the data - temp = this -! DODGINESS: the value of max_length sometimes changes after the call finalise(this) line -! if (present(max_length)) write(*,*) 'max_length=',max_length - call finalise(this) -! if (present(max_length)) write(*,*) 'max_length=',max_length - this%max_length = temp%N - if (present(max_length)) then - this%max_length = max_length - this%increment = max(1,max_length/10) - end if - if (temp%N > this%max_length) then - RAISE_ERROR('Table_Allocate: Max_Length is smaller than number of rows', error) - endif - - if (temp%intsize > 0) then - this%intsize = temp%intsize - allocate(this%int(this%intsize,this%max_length)) - this%int(:,1:temp%N) = temp%int(:,1:temp%N) - end if - - if (temp%realsize > 0) then - this%realsize = temp%realsize - allocate(this%real(this%realsize,this%max_length)) - this%real(:,1:temp%N) = temp%real(:,1:temp%N) - end if - - if (temp%strsize > 0) then - this%strsize = temp%strsize - allocate(this%str(this%strsize,this%max_length)) - this%str(:,1:temp%N) = temp%str(:,1:temp%N) - end if - - if (temp%logicalsize > 0) then - this%logicalsize = temp%logicalsize - allocate(this%logical(this%logicalsize,this%max_length)) - this%logical(:,1:temp%N) = temp%logical(:,1:temp%N) - end if - - this%N = temp%N - - call finalise(temp) - - endif - - end subroutine table_allocate - - subroutine table_set_increment(this,increment) - - type(table), intent(inout) :: this - integer, intent(in) :: increment - - if (increment < 1) call system_abort('Table_Set_Increment: Increment must be at least 1') - - this%increment = increment - - end subroutine table_set_increment - - !% Reduce the allocation if we can, still leaving a bit at the end, not more than 'this%increment'. - subroutine reduce_allocation(this) - type(table), intent(inout) :: this - integer::nblocs - - if(this%N.gt.(this%max_length - this%increment)) return - - nblocs = this%N / this%increment + 2 - call table_allocate(this,max_length=nblocs*this%increment) - end subroutine reduce_allocation - - - ! destructor - subroutine table_finalise(this) - type(table), intent(inout)::this - - if(allocated(this%int)) deallocate(this%int) - if(allocated(this%real)) deallocate(this%real) - if(allocated(this%str)) deallocate(this%str) - if(allocated(this%logical)) deallocate(this%logical) - - this%max_length = 0 - this%N = 0 - this%intsize = 0 - this%realsize = 0 - this%strsize = 0 - this%logicalsize = 0 - - end subroutine table_finalise - - ! Zero all parts of this table. - subroutine table_zero(this) - type(table), intent(inout) :: this - if(allocated(this%int)) this%int = 0 - if(allocated(this%real)) this%real = 0.0_dp - if(allocated(this%str)) this%str = repeat(' ',TABLE_STRING_LENGTH) - if(allocated(this%logical)) this%logical = .false. - end subroutine table_zero - - !% OMIT - subroutine table_assign_table(this,other) - type(table), intent(inout) ::this - type(table), intent(in) ::other - call finalise(this) - call table_allocate(this,other%intsize,other%realsize,& - other%strsize,other%logicalsize,other%N) !optimised for temporary copies - this%N=other%N - this%increment=other%increment - if(allocated(other%int)) this%int(:,1:this%N) = other%int(:,1:this%N) - if(allocated(other%real)) this%real(:,1:this%N) = other%real(:,1:this%N) - if(allocated(other%str)) this%str(:,1:this%N) = other%str(:,1:this%N) - if(allocated(other%logical)) this%logical(:,1:this%N) = other%logical(:,1:this%N) - - end subroutine table_assign_table - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! appending to tables - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine table_append_row_or_arrays(this,intpart,realpart,strpart,logicalpart, & - intpart_2D,realpart_2D,strpart_2D,logicalpart_2D, blank_rows) - - type(Table), intent(inout) :: this - integer, intent(in), optional :: intpart(:) - real(dp), intent(in), optional :: realpart(:) - character(TABLE_STRING_LENGTH), intent(in), optional :: strpart(:) - logical, intent(in), optional :: logicalpart(:) - integer, dimension(:,:), intent(in),optional :: intpart_2D - real(dp), dimension(:,:), intent(in),optional :: realpart_2D - character(TABLE_STRING_LENGTH), dimension(:,:), intent(in),optional :: strpart_2D - logical, dimension(:,:), intent(in), optional :: logicalpart_2D - integer, optional, intent(in) :: blank_rows - - logical :: got1D, got2D - - got1D = present(intpart) .or. present(realpart) .or. & - present(strpart) .or. present(logicalpart) - got2D = present(intpart_2D) .or. present(realpart_2D) .or. & - present(strpart_2D) .or. present(logicalpart_2D) - - if (present(blank_rows)) then - if(allocated(this%int) .or. allocated(this%real) .or. & - allocated(this%str) .or. allocated(this%logical)) then - - if(this%N+blank_rows > this%max_length) then ! we need more memory - call table_allocate(this,max_length=this%N+blank_rows) - end if - this%N = this%N + blank_rows - return - else - call system_abort('table_append_row_or_arrays: blank_rows can only be used with already allocated tables') - end if - else - if (.not. got1D .and. .not. got2D) & - call system_abort('table_append_row_or_arrays: nothing to append') - - if (got1D .and. got2D) & - call system_abort("table_append_row_or_arrays: can't mix 1D and 2D arrays") - - if (got1D) call table_append_row(this,intpart,realpart,strpart,logicalpart) - if (got2D) call table_append_arrays(this,intpart_2d,realpart_2d,strpart_2d,logicalpart_2d) - end if - - end subroutine table_append_row_or_arrays - - ! append single records - ! unless all sizes are 1 we do multiple appends - subroutine table_append_row(this,intpart,realpart,strpart,logicalpart, error) - type(table), intent(inout) :: this - integer, intent(in), optional :: intpart(:) - real(dp), intent(in), optional :: realpart(:) - character(TABLE_STRING_LENGTH), intent(in), optional :: strpart(:) - logical, intent(in), optional :: logicalpart(:) - integer, intent(out), optional::error - - integer :: intsize, realsize, strsize, logicalsize - - integer, allocatable :: use_intpart(:) - real(dp), allocatable :: use_realpart(:) - character(TABLE_STRING_LENGTH), allocatable :: use_strpart(:) - logical, allocatable :: use_logicalpart(:) - - INIT_ERROR(error) - - intsize = 0 - realsize = 0 - strsize = 0 - logicalsize = 0 - if (present(intpart)) intsize = size(intpart) - if (present(realpart)) realsize = size(realpart) - if (present(strpart)) strsize = size(strpart) - if (present(logicalpart)) logicalsize = size(logicalpart) - - !Special cases: if the table has size 1 - !and the vector length is > 1 then call append_arrays - if ((this%intsize == 1 .and. intsize > 1) .or. & - (this%realsize == 1 .and. realsize > 1) .or. & - (this%strsize == 1 .and. strsize > 1) .or. & - (this%logicalsize == 1 .and. logicalsize > 1)) then - - ! Make local copies so we can reshape - allocate(use_intpart(intsize)) - if (present(intpart)) use_intpart = intpart - - allocate(use_realpart(realsize)) - if (present(realpart)) use_realpart = realpart - - allocate(use_strpart(strsize)) - if (present(strpart)) use_strpart = strpart - - allocate(use_logicalpart(logicalsize)) - if (present(logicalpart)) use_logicalpart = logicalpart - - call table_append_arrays(this, reshape(use_intpart, (/1,intsize/)), & - reshape(use_realpart, (/1,realsize/)), & - reshape(use_strpart, (/1,strsize/)), & - reshape(use_logicalpart, (/1,logicalsize/))) - - deallocate(use_intpart, use_realpart, use_strpart, use_logicalpart) - - return - end if - - if(allocated(this%int) .or. allocated(this%real) .or. & - allocated(this%str) .or. allocated(this%logical)) then - if(this%N+1 > this%max_length) then ! we need more memory -#ifdef DEBUG - !$omp atomic - table_realloc_count = table_realloc_count + 1 -#endif - call table_allocate(this,max_length=this%N+this%increment) - end if - else -! call print('allocating '//intsize//' '//realsize//' '//strsize//' '//logicalsize) - call table_allocate(this,intsize,realsize,strsize,logicalsize) - end if - - if (this%intsize > 0) then - if(present(intpart)) then - if(size(this%int,1).ne.size(intpart)) then - RAISE_ERROR(('table_append_row: appendix int part has the wrong size, '//size(intpart)//', should be '//size(this%int,1)//'. intpart: '), error) - end if - this%int(:,this%N+1) = intpart - else - ! use default value of zero - this%int(:,this%N+1) = 0 - end if - end if - - if (this%realsize > 0) then - if(present(realpart)) then - if(size(this%real,1).ne.size(realpart)) & - call system_abort('table_append_row: appendix real part has the wrong size') - this%real(:,this%N+1)=realpart - else - ! default to zero - this%real(:,this%N+1) = 0.0_dp - end if - end if - - if (this%strsize > 0) then - if(present(strpart)) then - if(size(this%str,1).ne.size(strpart)) & - call system_abort('table_append_row: appendix str part has the wrong size') - this%str(:,this%N+1)=strpart - else - ! default to empty string - this%str(:,this%N+1) = repeat(' ',TABLE_STRING_LENGTH) - end if - end if - - if (this%logicalsize > 0) then - if(present(logicalpart)) then - if(size(this%logical,1).ne.size(logicalpart)) & - call system_abort('table_append_row: appendix logical part has the wrong size') - this%logical(:,this%N+1)=logicalpart - else - ! default to false - this%logical(:,this%N+1) = .false. - end if - end if - - ! Now increment the number of valid table rows - this%N = this%N+1 - end subroutine table_append_row - - - !Appending 2D arrays to tables - - subroutine table_append_int_array(this,intpart) - type(Table), intent(inout) :: this - integer, dimension(:,:), intent(in) :: intpart - - call table_append_arrays(this,intpart=intpart) - - end subroutine table_append_int_array - - subroutine table_append_real_array(this,realpart) - type(Table), intent(inout) :: this - real(dp), dimension(:,:), intent(in) :: realpart - - call table_append_arrays(this,realpart=realpart) - - end subroutine table_append_real_array - - - subroutine table_append_str_array(this,strpart) - type(Table), intent(inout) :: this - character(TABLE_STRING_LENGTH), dimension(:,:), intent(in) :: strpart - - call table_append_arrays(this,strpart=strpart) - - end subroutine table_append_str_array - - - subroutine table_append_logical_array(this,logicalpart) - type(Table), intent(inout) :: this - logical, dimension(:,:), intent(in) :: logicalpart - call table_append_arrays(this,logicalpart=logicalpart) - - end subroutine table_append_logical_array - - - subroutine table_append_arrays(this,intpart,realpart,strpart,logicalpart) - type(Table), intent(inout) :: this - integer, dimension(:,:), intent(in),optional :: intpart - real(dp), dimension(:,:), intent(in),optional :: realpart - character(TABLE_STRING_LENGTH), dimension(:,:), intent(in),optional :: strpart - logical, dimension(:,:), intent(in), optional :: logicalpart - - !locals - integer :: datasize(4), datalength(4), thissize(4), length, i - - datasize(1) = 0 - datalength(1) = 0 - if (present(intpart)) then - datasize(1) = size(intpart,1) - datalength(1) = size(intpart,2) - end if - - datasize(2) = 0 - datalength(2) = 0 - if (present(realpart)) then - datasize(2) = size(realpart,1) - datalength(2) = size(realpart,2) - end if - - datasize(3) = 0 - datalength(3) = 0 - if (present(strpart)) then - datasize(3) = size(strpart,1) - datalength(3) = size(strpart,2) - end if - - datasize(4) = 0 - datalength(4) = 0 - if (present(logicalpart)) then - datasize(4) = size(logicalpart,1) - datalength(4) = size(logicalpart,2) - end if - - if (all(datasize == 0)) & - call system_abort('table_append_arrays: all array widths are zero!') - length = maxval(datalength) - if (length == 0) & - call system_abort('table_append_arrays: all array lengths are zero!') - - ! Check non zero lengths match - do i=1,4 - if (datalength(i) == 0) cycle - if (datalength(i) /= length) then - call print(datalength) - call system_abort('table_append_arrays: lengths mismatched between arrays') - end if - end do - - thissize = (/this%intsize,this%realsize,this%strsize,this%logicalsize/) - - !Check if the table has been allocated and allocate if not, or check for correct size - if (all(thissize == 0)) then - call table_allocate(this,datasize(1),datasize(2),datasize(3),datasize(4),length) - else - ! Check non zero length arrays are correct size - do i=1,4 - if (datalength(i) == 0) cycle - if (datasize(i) /= thissize(i)) & - call system_abort('table_append_arrays: Input data sizes do not match table sizes') - end do - - !Table already allocated. See if long enough to hold the extra data - if (this%N+length > this%max_length) call table_allocate(this,max_length = this%N+length) - endif - - !Actually do the append - if (datasize(1) > 0 .and. datalength(1) > 0) this%int(:,this%N+1:this%N+length) = intpart - if (datasize(2) > 0 .and. datalength(2) > 0) this%real(:,this%N+1:this%N+length) = realpart - if (datasize(3) > 0 .and. datalength(3) > 0) this%str(:,this%N+1:this%N+length) = strpart - if (datasize(4) > 0 .and. datalength(4) > 0) this%logical(:,this%N+1:this%N+length) = logicalpart - - this%N = this%N + length - - end subroutine table_append_arrays - - - subroutine table_append_int_element(this,intpart, error) - type(Table), intent(inout) :: this - integer, intent(in) :: intpart - integer, intent(out), optional :: error - - INIT_ERROR(error) - - call table_append_row(this,(/intpart/), error=error) - PASS_ERROR(error) - end subroutine table_append_int_element - - subroutine table_append_real_element(this,realpart) - type(Table), intent(inout) :: this - real(dp), intent(in) :: realpart - - call table_append_row(this,realpart=(/realpart/)) - end subroutine table_append_real_element - - subroutine table_append_str_element(this,strpart,error) - type(Table), intent(inout) :: this - character(*) :: strpart - integer, intent(out), optional :: error - - character(TABLE_STRING_LENGTH) :: loc_strpart - - INIT_ERROR(error) - - if (len(strpart) > TABLE_STRING_LENGTH) then - RAISE_ERROR("table_append_str_element: Length of string '" // strpart // "' (" // len(strpart) // ") exceeds maximum length for strings in a table (" // TABLE_STRING_LENGTH // ").", error) - endif - - loc_strpart = strpart - - call table_append_row(this,strpart=(/loc_strpart/)) - end subroutine table_append_str_element - - subroutine table_append_logical_element(this,logicalpart) - type(Table), intent(inout) :: this - logical, intent(in) :: logicalpart - - call table_append_row(this,logicalpart=(/logicalpart/)) - - end subroutine table_append_logical_element - - subroutine table_append_int_element_and_real_element(this,intpart,realpart) - type(Table), intent(inout) :: this - integer, intent(in) :: intpart - real(dp), intent(in) :: realpart - - call table_append_row(this,(/intpart/),(/realpart/)) - - end subroutine table_append_int_element_and_real_element - - !overloaded append for mixed scalar and row input - subroutine table_append_int_element_real_row(this,intpart,realpart) - type(table), intent(inout) :: this - integer, intent(in) :: intpart - real(dp), intent(in) :: realpart(:) - - call table_append_row(this,(/intpart/),realpart) - - end subroutine table_append_int_element_real_row - - !overloaded append for mixed scalar and row input - subroutine table_append_int_row_real_element(this,intpart,realpart) - type(table), intent(inout) :: this - integer, intent(in) :: intpart(:) - real(dp), intent(in) :: realpart - - call table_append_row(this,intpart,(/realpart/)) - - end subroutine table_append_int_row_real_element - - ! append another table to this table - subroutine table_append_table(this,other) - type(table), intent(inout) :: this - type(table), intent(in) :: other - - if(allocated(this%int) .or. allocated(this%real) .or. allocated(this%str) .or. allocated(this%logical)) then - if(this%N+other%N > this%max_length) & ! we need more memory - call table_allocate(this,max_length=this%N+other%N) - else ! new table - this=other - return - end if - - if (other%n == 0) return - - ! we have ints - if(allocated(this%int)) then - if (.not.allocated(other%int))& - call system_abort('table_append_table: appendix table has no int part!') - - if(size(this%int,1).ne.size(other%int,1))& - call system_abort('table_append_table: appendix table has int part with wrong shape!') - - this%int(:,this%N+1:this%N+other%N) = other%int(:,1:other%N) - end if - - ! we have reals - if(allocated(this%real)) then - if (.not.allocated(other%real)) & - call system_abort('table_append_table: appendix table has no real part!') - - if(size(this%real,1).ne.size(other%real,1))& - call system_abort('table_append_table: appendix table has real part with wrong shape!') - - this%real(:,this%N+1:this%N+other%N) = other%real(:,1:other%N) - end if - - ! we have strs - if(allocated(this%str)) then - if (.not.allocated(other%str)) & - call system_abort('table_append_table: appendix table has no str part!') - - if(size(this%str,1).ne.size(other%str,1))& - call system_abort('table_append_table: appendix table has str part with wrong shape!') - - this%str(:,this%N+1:this%N+other%N) = other%str(:,1:other%N) - end if - - ! we have logicals - if(allocated(this%logical)) then - if (.not.allocated(other%logical)) & - call system_abort('table_append_table: appendix table has no logical part!') - - if(size(this%logical,1).ne.size(other%logical,1))& - call system_abort('table_append_table: appendix table has logical part with wrong shape!') - - this%logical(:,this%N+1:this%N+other%N) = other%logical(:,1:other%N) - end if - - - ! update the number of rows - this%N=this%N+other%N - end subroutine table_append_table - - subroutine table_append_col_i(this, val, n_cols, cols) - type(Table), intent(inout) :: this - integer, intent(in) :: val - integer, optional :: n_cols - integer, intent(out), optional :: cols(2) - - integer :: use_n_cols = 1 - - if (present(n_cols)) use_n_cols = n_cols - - call table_extend_int_cols(this,use_n_cols) - - this%int(this%intsize-use_n_cols+1:this%intsize,:) = val - - if (present(cols)) then - cols(1) = this%intsize-use_n_cols+1 - cols(2) = this%intsize - endif - end subroutine table_append_col_i - - subroutine table_append_col_i_a(this, val_a, n_cols, cols) - type(Table), intent(inout) :: this - integer, intent(in) :: val_a(:) - integer, optional :: n_cols - integer, intent(out), optional :: cols(2) - - integer i - integer :: use_n_cols = 1 - - if (present(n_cols)) use_n_cols = n_cols - if (size(val_a) /= this%N) call system_abort ("Called table_append_col_i_a with mismatched data size") - - call table_extend_int_cols(this,use_n_cols) - do i=1, this%N - this%int(this%intsize-use_n_cols+1:this%intsize,i) = val_a(i) - end do - - if (present(cols)) then - cols(1) = this%intsize-use_n_cols+1 - cols(2) = this%intsize - endif - end subroutine table_append_col_i_a - - subroutine table_append_col_r(this, val, n_cols, cols) - type(Table), intent(inout) :: this - real(dp), intent(in) :: val - integer, optional :: n_cols - integer, intent(out), optional :: cols(2) - - integer :: use_n_cols = 1 - - if (present(n_cols)) use_n_cols = n_cols - - call table_extend_real_cols(this, use_n_cols) - - this%real(this%realsize-use_n_cols+1:this%realsize,:) = val - - if (present(cols)) then - cols(1) = this%realsize-use_n_cols+1 - cols(2) = this%realsize - endif - end subroutine table_append_col_r - - subroutine table_append_col_r_a(this, val_a, n_cols, cols) - type(Table), intent(inout) :: this - real(dp), intent(in) :: val_a(:) - integer, optional :: n_cols - integer, intent(out), optional :: cols(2) - - integer i - integer :: use_n_cols = 1 - - if (present(n_cols)) use_n_cols = n_cols - if (size(val_a) /= this%N) call system_abort ("Called table_append_col_r_a with mismatched data size") - - call table_extend_real_cols(this, use_n_cols) - do i=1, this%N - this%real(this%realsize-use_n_cols+1:this%realsize,i) = val_a(i) - end do - - if (present(cols)) then - cols(1) = this%realsize-use_n_cols+1 - cols(2) = this%realsize - endif - end subroutine table_append_col_r_a - - - subroutine table_append_col_s(this, val, n_cols, cols) - type(Table), intent(inout) :: this - character(TABLE_STRING_LENGTH), intent(in) :: val - integer, optional :: n_cols - integer, intent(out), optional :: cols(2) - - integer :: use_n_cols = 1 - - if (present(n_cols)) use_n_cols = n_cols - - call table_extend_str_cols(this, use_n_cols) - - this%str(this%strsize-use_n_cols+1:this%strsize,:) = val - - if (present(cols)) then - cols(1) = this%strsize-use_n_cols+1 - cols(2) = this%strsize - endif - end subroutine table_append_col_s - - subroutine table_append_col_s_a(this, val_a, n_cols, cols) - type(Table), intent(inout) :: this - character(TABLE_STRING_LENGTH), intent(in) :: val_a(:) - integer, optional :: n_cols - integer, intent(out), optional :: cols(2) - - integer i - integer :: use_n_cols = 1 - - if (present(n_cols)) use_n_cols = n_cols - if (size(val_a) /= this%N) call system_abort ("Called table_append_col_s_a with mismatched data size") - - call table_extend_str_cols(this, use_n_cols) - do i=1, this%N - this%str(this%strsize-use_n_cols+1:this%strsize,i) = val_a(i) - end do - - if (present(cols)) then - cols(1) = this%strsize-use_n_cols+1 - cols(2) = this%strsize - endif - end subroutine table_append_col_s_a - - - subroutine table_append_col_l(this, val, n_cols, cols) - type(Table), intent(inout) :: this - logical, intent(in) :: val - integer, optional :: n_cols - integer, intent(out), optional :: cols(2) - - integer :: use_n_cols = 1 - - if (present(n_cols)) use_n_cols = n_cols - - call table_extend_logical_cols(this, use_n_cols) - - this%logical(this%logicalsize-use_n_cols+1:this%logicalsize,:) = val - - if (present(cols)) then - cols(1) = this%logicalsize-use_n_cols+1 - cols(2) = this%logicalsize - endif - end subroutine table_append_col_l - - subroutine table_append_col_l_a(this, val_a, n_cols, cols) - type(Table), intent(inout) :: this - logical, intent(in) :: val_a(:) - integer, optional :: n_cols - integer, intent(out), optional :: cols(2) - - integer i - integer :: use_n_cols = 1 - - if (present(n_cols)) use_n_cols = n_cols - if (size(val_a) /= this%N) call system_abort ("Called table_append_col_l_a with mismatched data size") - - call table_extend_logical_cols(this, use_n_cols) - do i=1, this%N - this%logical(this%logicalsize-use_n_cols+1:this%logicalsize,i) = val_a(i) - end do - - if (present(cols)) then - cols(1) = this%logicalsize-use_n_cols+1 - cols(2) = this%logicalsize - endif - end subroutine table_append_col_l_a - - - subroutine table_append_col_table(this, other) - type(Table), intent(inout) :: this - type(Table), intent(in) :: other - - if (this%N /= other%N) call system_abort ("Called table_append_col_table with mismatched sizes") - - if (other%intsize > 0) then - call table_extend_int_cols(this, other%intsize) - this%int(this%intsize-other%intsize+1:this%intsize, :) = other%int(1:other%intsize, :) - endif - if (other%realsize > 0) then - call table_extend_real_cols(this, other%realsize) - this%real(this%realsize-other%realsize+1:this%realsize, :) = other%real(1:other%realsize, :) - endif - if (other%strsize > 0) then - call table_extend_str_cols(this, other%strsize) - this%str(this%strsize-other%strsize+1:this%strsize, :) = other%str(1:other%strsize, :) - endif - if (other%logicalsize > 0) then - call table_extend_logical_cols(this, other%logicalsize) - this%logical(this%logicalsize-other%logicalsize+1:this%logicalsize, :) = other%logical(1:other%logicalsize, :) - endif - - end subroutine table_append_col_table - - subroutine table_extend_int_cols(this, n_cols) - type(Table), intent(inout) :: this - integer n_cols - - integer, allocatable :: t(:,:) - - if (n_cols < 0) call system_abort ("Called table_extend_int_cols with n_cols < 0") - if (n_cols == 0) return - - if (allocated(this%int)) then - if (size(this%int,1) < this%intsize+n_cols) then - allocate(t(this%intsize,this%N)) - t = this%int(1:this%intsize, 1:this%N) - deallocate(this%int) - allocate(this%int(this%intsize+n_cols,this%max_length)) - this%int(1:this%intsize, 1:this%N) = t(1:this%intsize, 1:this%N) - this%int(this%intsize+1:this%intsize+n_cols,:) = 0 - endif - this%intsize = this%intsize + n_cols - else - this%intsize = n_cols - allocate(this%int(this%intsize,this%N)) - this%int = 0 - endif - end subroutine table_extend_int_cols - - subroutine table_extend_real_cols(this, n_cols) - type(Table), intent(inout) :: this - integer n_cols - - real(dp), allocatable :: t(:,:) - - if (n_cols < 0) call system_abort ("Called table_extend_int_cols with n_cols < 0") - if (n_cols == 0) return - - if (allocated(this%real)) then - if (size(this%real,1) < this%realsize+n_cols) then - allocate(t(this%realsize,this%N)) - t = this%real(1:this%realsize, 1:this%N) - deallocate(this%real) - allocate(this%real(this%realsize+n_cols,this%max_length)) - this%real(1:this%realsize, 1:this%N) = t(1:this%realsize, 1:this%N) - this%real(this%realsize+1:this%realsize+n_cols,:) = 0 - endif - this%realsize = this%realsize + n_cols - else - this%realsize = n_cols - allocate(this%real(this%realsize,this%N)) - this%real = 0 - endif - end subroutine table_extend_real_cols - - subroutine table_extend_str_cols(this, n_cols) - type(Table), intent(inout) :: this - integer n_cols - - character(TABLE_STRING_LENGTH), allocatable :: t(:,:) - - if (n_cols < 0) call system_abort ("Called table_extend_str_cols with n_cols < 0") - if (n_cols == 0) return - - if (allocated(this%str)) then - if (size(this%str,1) < this%strsize+n_cols) then - allocate(t(this%strsize,this%N)) - t = this%str(1:this%strsize, 1:this%N) - deallocate(this%str) - allocate(this%str(this%strsize+n_cols,this%max_length)) - this%str(1:this%strsize, 1:this%N) = t(1:this%strsize, 1:this%N) - this%str(this%strsize+1:this%strsize+n_cols,:) = repeat(' ',TABLE_STRING_LENGTH) - endif - this%strsize = this%strsize + n_cols - else - this%strsize = n_cols - allocate(this%str(this%strsize,this%N)) - this%str = repeat(' ',TABLE_STRING_LENGTH) - endif - end subroutine table_extend_str_cols - - - subroutine table_extend_logical_cols(this, n_cols) - type(Table), intent(inout) :: this - integer n_cols - - logical, allocatable :: t(:,:) - - if (n_cols < 0) call system_abort ("Called table_extend_logical_cols with n_cols < 0") - if (n_cols == 0) return - - if (allocated(this%logical)) then - if (size(this%logical,1) < this%logicalsize+n_cols) then - allocate(t(this%logicalsize,this%N)) - t = this%logical(1:this%logicalsize, 1:this%N) - deallocate(this%logical) - allocate(this%logical(this%logicalsize+n_cols,this%max_length)) - this%logical(1:this%logicalsize, 1:this%N) = t(1:this%logicalsize, 1:this%N) - this%logical(this%logicalsize+1:this%logicalsize+n_cols,:) = .false. - endif - this%logicalsize = this%logicalsize + n_cols - else - this%logicalsize = n_cols - allocate(this%logical(this%logicalsize,this%N)) - this%logical = .false. - endif - end subroutine table_extend_logical_cols - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! inserting a new row at a given position - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine table_insert(this,pos,intpart,realpart,strpart,logicalpart) - - type(table), intent(inout) :: this - integer, intent(in) :: pos - integer, dimension(:), optional, intent(in) :: intpart - real(dp), dimension(:), optional, intent(in) :: realpart - character(TABLE_STRING_LENGTH), dimension(:), optional, intent(in) :: strpart - logical, dimension(:), optional, intent(in) :: logicalpart - - !Check input arguments - if (pos < 1 .or. pos > this%N+1) call system_abort('table_insert: cannot insert at position '//pos) - - if (present(intpart)) then - if (this%intsize == 0) call system_abort('table insert: table does not have an int part') - if (size(intpart) /= this%intsize) & - call system_abort('table_insert: int size should be '//this%intsize//' and not '//size(intpart)) - end if - if (present(realpart)) then - if (this%realsize == 0) call system_abort('table insert: table does not have a real part') - if (size(realpart) /= this%realsize) & - call system_abort('table_insert: real size should be '//this%realsize//' and not '//size(realpart)) - end if - if (present(strpart)) then - if (this%strsize == 0) call system_abort('table insert: table does not have a str part') - if (size(strpart) /= this%strsize) & - call system_abort('table_insert: str size should be '//this%strsize//' and not '//size(strpart)) - end if - if (present(logicalpart)) then - if (this%logicalsize == 0) call system_abort('table insert: table does not have a logical part') - if (size(logicalpart) /= this%logicalsize) & - call system_abort('table_insert: logical size should be '//this%logicalsize//' and not '//size(logicalpart)) - end if - - if (.not.present(intpart) .and. .not.present(realpart) .and. & - .not. present(strpart) .and. .not. present(logicalpart)) & - call system_abort('table_insert: at least one of intpart/realpart/strpart/logicalpart must be present') - - !First check if we need to insert -- FIXME: these parameters are not optional in append() - if (pos == this%N+1) then - call append(this,intpart,realpart,strpart,logicalpart) - return - end if - - !Make sure memory is available - if (this%N+1 > this%max_length) call allocate(this,max_length=this%N+this%increment) - - !Shift everything from 'pos' to 'N' down a line and insert new data - if (this%intsize > 0) then - if (.not. present(intpart)) call system_abort('table_insert: missing intpart') - this%int(:,pos+1:this%N+1) = this%int(:,pos:this%N) - this%int(:,pos) = intpart - end if - if (this%realsize > 0) then - if (.not. present(realpart)) call system_abort('table_insert: missing realpart') - this%real(:,pos+1:this%N+1) = this%real(:,pos:this%N) - this%real(:,pos) = realpart - end if - if (this%strsize > 0) then - if (.not. present(strpart)) call system_abort('table_insert: missing strpart') - this%str(:,pos+1:this%N+1) = this%str(:,pos:this%N) - this%str(:,pos) = strpart - end if - if (this%logicalsize > 0) then - if (.not. present(logicalpart)) call system_abort('table_insert: missing logicalpart') - this%logical(:,pos+1:this%N+1) = this%logical(:,pos:this%N) - this%logical(:,pos) = logicalpart - end if - - - !Update the row counter - this%N = this%N + 1 - - end subroutine table_insert - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! sort a table by its integer part - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine table_sort(this,idx,int_cols) - type(table), intent(inout) :: this - integer, dimension(this%N), optional, intent(out) :: idx - integer, optional, intent(in) :: int_cols(:) - - integer, dimension(this%intsize) :: tmp_intpart - real(dp),dimension(this%realsize) :: tmp_realpart - character(TABLE_STRING_LENGTH), dimension(this%strsize) :: tmp_strpart - logical, dimension(this%logicalsize) :: tmp_logicalpart - - integer :: i, j, vi - logical :: have_reals, have_strs, have_logicals - integer, allocatable :: sort_cols(:) - - if (this%intsize == 0) return - have_reals = (this%realsize /= 0) - have_strs = (this%strsize /= 0) - have_logicals = (this%logicalsize /= 0) - - if (present(idx)) idx = (/ (i, i=1,this%N) /) - - if (present(int_cols)) then - allocate(sort_cols(size(int_cols))) - sort_cols = int_cols - else - allocate(sort_cols(this%intsize)) - sort_cols = (/ (i, i=1,this%intsize) /) - endif - - do i = 2, this%N - - if (int_array_ge(this%int(sort_cols,i),this%int(sort_cols,i-1))) cycle - - ! i is smaller than i-1, start moving it back - tmp_intpart = this%int(:,i) - if (have_reals) tmp_realpart = this%real(:,i) - if (have_strs) tmp_strpart = this%str(:,i) - if (have_logicals) tmp_logicalpart = this%logical(:,i) - if (present(idx)) vi = idx(i) - - j = i-1 - - do while (j >= 1) - - ! if tmp (orig i, now j+1) is greater than this j, no need to move it further - if (int_array_gt(tmp_intpart(sort_cols), this%int(sort_cols,j))) exit - - this%int(:,j+1) = this%int(:,j) - if (have_reals) this%real(:,j+1) = this%real(:,j) - if (have_strs) this%str(:,j+1) = this%str(:,j) - if (have_logicals) this%logical(:,j+1) = this%logical(:,j) - - this%int(:,j) = tmp_intpart - if (have_reals) this%real(:,j) = tmp_realpart - if (have_strs) this%str(:,j) = tmp_strpart - if (have_logicals) this%logical(:,j) = tmp_logicalpart - - if (present(idx)) then - idx(j+1) = idx(j) - idx(j) = vi - end if - j = j - 1 - - end do - - end do - - deallocate(sort_cols) - - end subroutine table_sort - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! binary search a sorted table: index = 0 if not found - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - pure function table_search(this,intpart) result(index) - - type(table), intent(in) :: this - integer, dimension(:), intent(in) :: intpart - integer :: index - - integer :: ilow, ihigh - logical :: done - - index = 0 - if (this%N < 1) return - ilow = 1; ihigh = this%N - done = .false. - - if ( int_array_gt(this%int(:,ilow),intpart) .or. int_array_lt(this%int(:,ihigh),intpart) ) done = .true. - if (.not.done) then - if (all(this%int(1:size(intpart),ilow) == intpart)) then - index = ilow - done = .true. - else if (all(this%int(1:size(intpart),ihigh) == intpart)) then - index = ihigh - done = .true. - end if - end if - - do while(.not.done) - index = (ihigh + ilow) / 2 - if (index == ilow) then ! value is not present. exit - index = 0 - done = .true. - else if (all(this%int(1:size(intpart),index) == intpart)) then ! value found - done = .true. - else if (int_array_lt(this%int(1:size(intpart),index),intpart)) then ! value at this index is too low. shift lower bound - ilow = index - else ! value at this index is too high. shift upper bound - ihigh = index - end if - end do - - end function table_search - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! deleting rows from tables - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - subroutine table_record_delete_by_index(this, n, keep_order) - type(table), intent(inout) :: this - integer, intent(in) :: n - logical, intent(in), optional :: keep_order - - logical :: do_keep_order - - do_keep_order = optional_default(.true., keep_order) - - if (n > this%N .or. n < 1) then - write(line,'(a,2(i0,a))')'table_record_delete_by_index: Tried to delete record ',n,' (N=',this%N,')' - call system_abort(line) - end if - - if (do_keep_order) then - ! move all later rows back 1 - if(allocated(this%int)) this%int (:,n:this%N-1) = this%int (:,n+1:this%N) - if(allocated(this%real)) this%real(:,n:this%N-1) = this%real(:,n+1:this%N) - if(allocated(this%str)) this%str(:,n:this%N-1) = this%str(:,n+1:this%N) - if(allocated(this%logical)) this%logical(:,n:this%N-1) = this%logical(:,n+1:this%N) - else - ! replace the row with the last row - if(allocated(this%int)) this%int (:,n) = this%int (:,this%N) - if(allocated(this%real)) this%real(:,n) = this%real(:,this%N) - if(allocated(this%str)) this%str(:,n) = this%str(:,this%N) - if(allocated(this%logical)) this%logical(:,n) = this%logical(:,this%N) - endif - - this%N=this%N-1 - - ! maybe we can reduce the memory - call reduce_allocation(this) - - end subroutine table_record_delete_by_index - - subroutine table_record_delete_multiple(this, indices) - type(Table), intent(inout) :: this - integer, intent(in), dimension(:) :: indices - - integer :: oldN, newN, i, N, copysrc - integer, dimension(size(indices)) :: sorted - integer, dimension(:), allocatable :: uniqed - - !Get our own copy of the indices so we can sort them - sorted = indices - call sort_array(sorted) - - !Now remove duplicates from sorted indices - call uniq(sorted, uniqed) - - oldN = this%N - N = size(uniqed) - newN = oldN - N - - ! Algorithm: Find first row to be removed and last row to not be removed - ! and swap them. Repeat until all rows to be removed are at the end. - copysrc = oldN - do i=1,N - do while(is_in_array(uniqed,copysrc)) - copysrc = copysrc - 1 - end do - - if (uniqed(i) > copysrc) exit - - if (allocated(this%int)) this%int(:,uniqed(i)) = this%int(:,copysrc) - if (allocated(this%real)) this%real(:,uniqed(i)) = this%real(:,copysrc) - if (allocated(this%str)) this%str(:,uniqed(i)) = this%str(:,copysrc) - if (allocated(this%logical)) this%logical(:,uniqed(i)) = this%logical(:,copysrc) - - copysrc = copysrc - 1 - end do - - this%N = newN - call reduce_allocation(this) - deallocate(uniqed) - - end subroutine table_record_delete_multiple - - - subroutine table_record_delete_by_value(this,n, keep_order) - type(table), intent(inout) :: this - integer, intent(in) :: n(:) - logical, intent(in), optional :: keep_order - - integer :: i - - if (.not.allocated(this%int)) & - call system_abort('table_record_delete_by_value: you cannot delete by value from a table without an int part') - - if (size(n).ne.size(this%int,1)) & - call system_abort('table_record_delete_by_value: the row you are trying to delete has the wrong size') - - do i=1,this%N - if ( all(this%int(:,i) == n(:)) ) then - call delete(this, i, keep_order) - exit - end if - end do - !maybe we can reduce the memory - call reduce_allocation(this) - end subroutine table_record_delete_by_value - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! Wipe the table but keep the allocation - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine table_wipe(this,zero) - type(Table), intent(inout) :: this - logical, optional, intent(in) :: zero - - if (present(zero)) then - if (zero) call table_zero(this) - end if - - this%N = 0 - - end subroutine table_wipe - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! find a row by the integer entries (return first occurrence) - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function table_find_element(this, n) result(i) - type(table), intent(in):: this - integer, intent(in) :: n - integer :: i - - i = table_find_row(this, (/n/)) - - end function table_find_element - - function table_find_row(this, n, mask) result(i) - type(table), intent(in) :: this - integer, intent(in) :: n(:) ! what we are looking for - logical,optional,intent(in) :: mask(:) ! if this exists, we only compare elements where this is true - integer :: i - - - if (this%intsize == 0) & - call system_abort('Table_Find_Row: Table has no int part') - - if (size(n) /= this%intsize) & - call system_abort('Table_Find_Row: Row being searched for has wrong size') - - ! I've removed call to int_part() here as found to be bottleneck when profiling (jrk33) - i = find_in_array(this%int(:,1:this%n), n, mask) - end function table_find_row - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! - ! printing - ! - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine table_print_mainlog(this,verbosity) - type(table), intent(in) :: this - integer, intent(in), optional :: verbosity - call table_print(this, verbosity, mainlog) - end subroutine table_print_mainlog - - - subroutine table_print(this,verbosity,file,real_format,int_format,str_format,logical_format,mask) - type(table), intent(in) :: this - type(inoutput), intent(inout) :: file - integer, intent(in), optional :: verbosity - character(*), optional, intent(in) :: real_format, int_format, str_format, logical_format - logical, optional, intent(in) :: mask(:) - - !locals - character(10) :: my_real_format, my_int_format, my_str_format, my_logical_format - character(100) :: fmt - integer :: i, j - - my_real_format = optional_default('f16.8',real_format) - my_int_format = optional_default('i8',int_format) - my_str_format = optional_default('a'//(TABLE_STRING_LENGTH+1),str_format) - my_logical_format = optional_default('l3',logical_format) - - ! Print all columns in order, first ints then reals, strs and logicals - do i=1,this%N - if (present(mask)) then - if (.not.mask(i)) cycle - endif - line = '' - do j=1,this%intsize - write (fmt,'('//trim(my_int_format)//')') this%int(j,i) - line=trim(line)//' '//trim(fmt) - end do - do j=1,this%realsize - write (fmt,'('//trim(my_real_format)//')') this%real(j,i) - line=trim(line)//' '//trim(fmt) - end do - do j=1,this%strsize - write (fmt,'('//trim(my_str_format)//')') this%str(j,i) - line=trim(line)//' '//trim(fmt) - end do - do j=1,this%logicalsize - write (fmt,'('//trim(my_logical_format)//')') this%logical(j,i) - line=trim(line)//' '//trim(fmt) - end do - call print(line,verbosity,file) - end do - - end subroutine table_print - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Returning parts of the table - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function table_int_column(this,column) - type(Table), intent(in) :: this - integer, intent(in) :: column - integer, dimension(this%N) :: table_int_column - - if (column > this%intsize) call system_abort('table_int_column: Column out of range') - - table_int_column = this%int(column,1:this%N) - - end function table_int_column - - function table_real_column(this,column) - type(Table), intent(in) :: this - integer, intent(in) :: column - real(dp), dimension(this%N) :: table_real_column - - if (column > this%realsize) call system_abort('table_real_column: Column out of range') - - table_real_column = this%real(column,1:this%N) - - end function table_real_column - - function table_str_column(this,column) - type(Table), intent(in) :: this - integer, intent(in) :: column - character(TABLE_STRING_LENGTH), dimension(this%N) :: table_str_column - - if (column > this%strsize) call system_abort('table_str_column: Column out of range') - - table_str_column = this%str(column,1:this%N) - - end function table_str_column - - - function table_logical_column(this,column) - type(Table), intent(in) :: this - integer, intent(in) :: column - logical, dimension(this%N) :: table_logical_column - - if (column > this%logicalsize) call system_abort('table_logical_column: Column out of range') - - table_logical_column = this%logical(column,1:this%N) - - end function table_logical_column - - - function table_int_columns(this,columns) - type(Table), intent(in) :: this - integer, intent(in) :: columns(:) - integer, dimension(size(columns),this%N) :: table_int_columns - - if (any(columns > this%intsize)) call system_abort('table_int_columns: Column out of range') - - table_int_columns = this%int(columns,1:this%N) - - end function table_int_columns - - function table_real_columns(this,columns) - type(Table), intent(in) :: this - integer, intent(in) :: columns(:) - real(dp), dimension(size(columns),this%N) :: table_real_columns - - if (any(columns > this%realsize)) call system_abort('table_real_columns: Column out of range') - - table_real_columns = this%real(columns,1:this%N) - - end function table_real_columns - - - function table_str_columns(this,columns) - type(Table), intent(in) :: this - integer, intent(in) :: columns(:) - character(TABLE_STRING_LENGTH), dimension(size(columns),this%N) :: table_str_columns - - if (any(columns > this%strsize)) call system_abort('table_str_columns: Column out of range') - - table_str_columns = this%str(columns,1:this%N) - - end function table_str_columns - - function table_logical_columns(this,columns) - type(Table), intent(in) :: this - integer, intent(in) :: columns(:) - logical, dimension(size(columns),this%N) :: table_logical_columns - - if (any(columns > this%logicalsize)) call system_abort('table_logical_columns: Column out of range') - - table_logical_columns = this%logical(columns,1:this%N) - - end function table_logical_columns - - - function table_int_part(this) - type(Table), intent(in) :: this - integer, dimension(this%intsize,this%N) :: table_int_part - - if (this%intsize == 0) call system_abort('table_int_part: Table has no integer part') - - table_int_part = this%int(:,1:this%N) - - end function table_int_part - - function table_real_part(this) - type(Table), intent(in) :: this - real(dp), dimension(this%realsize,this%N ) :: table_real_part - - if (this%realsize == 0) call system_abort('table_real_part: Table has no real part') - - table_real_part = this%real(:,1:this%N) - - end function table_real_part - - function table_str_part(this) - type(Table), intent(in) :: this - character(TABLE_STRING_LENGTH), dimension(this%strsize,this%N ) :: table_str_part - - if (this%strsize == 0) call system_abort('table_str_part: Table has no str part') - - table_str_part = this%str(:,1:this%N) - - end function table_str_part - - function table_logical_part(this) - type(Table), intent(in) :: this - logical, dimension(this%logicalsize,this%N ) :: table_logical_part - - if (this%logicalsize == 0) call system_abort('table_logical_part: Table has no logical part') - - table_logical_part = this%logical(:,1:this%N) - - end function table_logical_part - - - - !Create a table from selected elements of another table - - function subtable(this,rows,intcols,realcols,strcols,logicalcols) - type(Table), intent(in) :: this - integer, dimension(:), intent(in) :: rows - integer, dimension(:), intent(in),optional :: intcols - integer, dimension(:), intent(in),optional :: realcols - integer, dimension(:), intent(in),optional :: strcols - integer, dimension(:), intent(in),optional :: logicalcols - type(Table) :: subtable - - integer, dimension(:), allocatable :: use_intcols, use_realcols, use_strcols, use_logicalcols - integer :: i - - !First check none of the requested rows/columns are out of bounds - - if (any(rows > this%N)) & - call system_abort('subtable: Row out of range size(rows) ' // size(rows) // ' minval ' // minval(rows) // ' maxval ' // maxval(rows) // ' this%N ' // this%N) - - if(present(intcols)) then - if(any(intcols > 0 .and. intcols > this%intsize)) call system_abort('subtable: Integer column out of range') - allocate(use_intcols(count(intcols > 0))) - use_intcols = pack(intcols, intcols > 0) - else - allocate(use_intcols(this%intsize)) - use_intcols = (/ (i, i=1,this%intsize ) /) - end if - - if(present(realcols)) then - if(any(realcols > 0 .and. realcols > this%realsize)) call system_abort('subtable: Real column out of range') - allocate(use_realcols(count(realcols > 0))) - use_realcols = pack(realcols, realcols > 0) - else - allocate(use_realcols(this%realsize)) - use_realcols = (/ (i, i=1,this%realsize )/) - end if - - if(present(strcols)) then - if(any(strcols > 0 .and. strcols > this%strsize)) call system_abort('subtable: Str column out of range') - allocate(use_strcols(count(strcols > 0))) - use_strcols = pack(strcols, strcols > 0) - else - allocate(use_strcols(this%strsize)) - use_strcols = (/ (i, i=1,this%strsize ) /) - end if - - if(present(logicalcols)) then - if(any(logicalcols > 0 .and. logicalcols > this%logicalsize)) call system_abort('subtable: Logical column out of range') - allocate(use_logicalcols(count(logicalcols > 0))) - use_logicalcols = pack(logicalcols, logicalcols > 0) - else - allocate(use_logicalcols(this%logicalsize)) - use_logicalcols = (/ (i, i=1,this%logicalsize ) /) - end if - -! call allocate(subtable, size(use_intcols),size(use_realcols),size(use_strcols),size(use_logicalcols)) - - ! gfortran is fussier than ifort about passing empty arrays, so we have to do this ugly switch over all - ! permuations of null and non-null columns - - if (this%intsize /= 0 .and. this%realsize /= 0 .and. this%strsize /= 0 .and. this%logicalsize /= 0) then - ! case 0 - - call append(subtable,intpart_2d=this%int(use_intcols,rows),& - realpart_2d=this%real(use_realcols,rows), & - strpart_2d=this%str(use_strcols,rows), & - logicalpart_2d=this%logical(use_logicalcols,rows)) - - else if (this%intsize /= 0 .and. this%realsize /= 0 .and. this%strsize /= 0 .and. this%logicalsize == 0) then - ! case 1 - - call append(subtable,intpart_2d=this%int(use_intcols,rows),& - realpart_2d=this%real(use_realcols,rows), & - strpart_2d=this%str(use_strcols,rows)) - - else if (this%intsize /= 0 .and. this%realsize /= 0 .and. this%strsize == 0 .and. this%logicalsize /= 0) then - ! case 2 - - call append(subtable,intpart_2d=this%int(use_intcols,rows),& - realpart_2d=this%real(use_realcols,rows), & - logicalpart_2d=this%logical(use_logicalcols,rows)) - - else if (this%intsize /= 0 .and. this%realsize /= 0 .and. this%strsize == 0 .and. this%logicalsize == 0) then - ! case 3 - - call append(subtable,intpart_2d=this%int(use_intcols,rows),& - realpart_2d=this%real(use_realcols,rows)) - - else if (this%intsize /= 0 .and. this%realsize == 0 .and. this%strsize /= 0 .and. this%logicalsize /= 0) then - ! case 4 - - call append(subtable,intpart_2d=this%int(use_intcols,rows),& - strpart_2d=this%str(use_strcols,rows), & - logicalpart_2d=this%logical(use_logicalcols,rows)) - - else if (this%intsize /= 0 .and. this%realsize == 0 .and. this%strsize /= 0 .and. this%logicalsize == 0) then - ! case 5 - - call append(subtable,intpart_2d=this%int(use_intcols,rows),& - strpart_2d=this%str(use_strcols,rows)) - - else if (this%intsize /= 0 .and. this%realsize == 0 .and. this%strsize == 0 .and. this%logicalsize /= 0) then - ! case 6 - - call append(subtable,intpart_2d=this%int(use_intcols,rows),& - logicalpart_2d=this%logical(use_logicalcols,rows)) - - else if (this%intsize /= 0 .and. this%realsize == 0 .and. this%strsize == 0 .and. this%logicalsize == 0) then - ! case 7 - - call append(subtable,intpart_2d=this%int(use_intcols,rows)) - - else if (this%intsize == 0 .and. this%realsize /= 0 .and. this%strsize /= 0 .and. this%logicalsize /= 0) then - ! case 8 - - call append(subtable, & - realpart_2d=this%real(use_realcols,rows), & - strpart_2d=this%str(use_strcols,rows), & - logicalpart_2d=this%logical(use_logicalcols,rows)) - - else if (this%intsize == 0 .and. this%realsize /= 0 .and. this%strsize /= 0 .and. this%logicalsize == 0) then - ! case 9 - - call append(subtable, & - realpart_2d=this%real(use_realcols,rows), & - strpart_2d=this%str(use_strcols,rows)) - - else if (this%intsize == 0 .and. this%realsize /= 0 .and. this%strsize == 0 .and. this%logicalsize /= 0) then - ! case 10 - - call append(subtable, & - realpart_2d=this%real(use_realcols,rows), & - logicalpart_2d=this%logical(use_logicalcols,rows)) - - else if (this%intsize == 0 .and. this%realsize /= 0 .and. this%strsize == 0 .and. this%logicalsize == 0) then - ! case 11 - - call append(subtable, & - realpart_2d=this%real(use_realcols,rows)) - - else if (this%intsize == 0 .and. this%realsize == 0 .and. this%strsize /= 0 .and. this%logicalsize /= 0) then - ! case 12 - - call append(subtable, & - strpart_2d=this%str(use_strcols,rows), & - logicalpart_2d=this%logical(use_logicalcols,rows)) - - else if (this%intsize == 0 .and. this%realsize == 0 .and. this%strsize /= 0 .and. this%logicalsize == 0) then - ! case 13 - - call append(subtable, & - strpart_2d=this%str(use_strcols,rows)) - - else if (this%intsize == 0 .and. this%realsize == 0 .and. this%strsize == 0 .and. this%logicalsize /= 0) then - ! case 14 - - call append(subtable, & - logicalpart_2d=this%logical(use_logicalcols,rows)) - - else if (this%intsize == 0 .and. this%realsize == 0 .and. this%strsize == 0 .and. this%logicalsize == 0) then - ! case 15 - - call system_abort('subtable: source table is empty') - - end if - - deallocate(use_intcols, use_realcols, use_strcols, use_logicalcols) - - end function subtable - - function real_subtable(this,rows,cols) - type(Table), intent(in) :: this - integer, dimension(:), intent(in) :: rows - integer, dimension(:), intent(in) :: cols - type(Table) :: Real_Subtable - integer, dimension(0) :: intcols - - real_subtable = subtable(this,rows,intcols,cols) - - end function real_subtable - - function int_subtable(this,rows,cols) - type(Table), intent(in) :: this - integer, dimension(:), intent(in) :: rows - integer, dimension(:), intent(in) :: cols - type(Table) :: int_subtable - integer, dimension(0) :: realcols - - int_subtable = subtable(this,rows,cols,realcols) - - end function int_subtable - - function rms_diff_list(array1, array2, list) - real(dp), dimension(:,:), intent(in) :: array1, array2 - type(table) :: list - real(dp) :: rms_diff_list, d - integer :: i,j, n - call check_size('Array 2',array2,shape(array1),'rms_diff') - - rms_diff_list = 0.0_dp - do n = 1,list%N - j = list%int(1,n) - do i = 1, size(array1,1) - d = array1(i,j) - array2(i,j) - rms_diff_list = rms_diff_list + d * d - end do - end do - rms_diff_list = rms_diff_list / real(list%N*size(array1,1),dp) - rms_diff_list = sqrt(rms_diff_list) - end function rms_diff_list - - subroutine table_select(to, from, row_mask, row_list) - type(table), intent(inout) :: to - type(table), intent(in) :: from - integer, intent(in), optional :: row_list(:) - logical, intent(in), optional :: row_mask(:) - - integer, allocatable :: rows(:) - integer i, N_rows - - if ((.not. present(row_list) .and. .not. present(row_mask)) .or. (present(row_list) .and. present(row_mask))) & - call system_abort('table_select: either list or mask must be present (but not both)') - - call finalise(to) - - if(present(row_list)) then ! we have a row_list - to = subtable(from, row_list) - else ! we have a row_mask - if (from%N /= size(row_mask)) & - call system_abort("table_select mismatched sizes from " // from%N // " mask " // size(row_mask)) - - N_rows = count(row_mask) - allocate(rows(N_rows)) - ! build up a row list - N_rows = 1 - do i=1, from%N - if (row_mask(i)) then - rows(N_rows) = i - N_rows = N_rows + 1 - endif - end do - - to = subtable(from, rows) - - deallocate(rows) - end if - - end subroutine table_select - -subroutine table_remove_columns(this, int_col_min, int_col_max, real_col_min, real_col_max, & - str_col_min, str_col_max, logical_col_min, logical_col_max) - type(Table), intent(inout) :: this - integer, intent(in), optional :: int_col_min, int_col_max - integer, intent(in), optional :: real_col_min, real_col_max - integer, intent(in), optional :: str_col_min, str_col_max - integer, intent(in), optional :: logical_col_min, logical_col_max - - integer my_int_col_min, my_int_col_max, my_real_col_min, my_real_col_max - integer my_str_col_min, my_str_col_max, my_logical_col_min, my_logical_col_max - integer i - type(Table) subtab - - if (present(int_col_min)) then - my_int_col_min = int_col_min - my_int_col_max = my_int_col_min - if (present(int_col_max)) my_int_col_max = int_col_max - else - if (present(int_col_max)) call system_abort("table_remove_columns has int_col_max but no int_col_min") - my_int_col_min = 1 - my_int_col_max = 0 - endif - - if (present(real_col_min)) then - my_real_col_min = real_col_min - my_real_col_max = my_real_col_min - if (present(real_col_max)) my_real_col_max = real_col_max - else - if (present(real_col_max)) call system_abort("table_remove_columns has real_col_max but no real_col_min") - my_real_col_min = 1 - my_real_col_max = 0 - endif - - if (present(str_col_min)) then - my_str_col_min = str_col_min - my_str_col_max = my_str_col_min - if (present(str_col_max)) my_str_col_max = str_col_max - else - if (present(str_col_max)) call system_abort("table_remove_columns has str_col_max but no str_col_min") - my_str_col_min = 1 - my_str_col_max = 0 - endif - - if (present(logical_col_min)) then - my_logical_col_min = logical_col_min - my_logical_col_max = my_logical_col_min - if (present(logical_col_max)) my_logical_col_max = logical_col_max - else - if (present(logical_col_max)) call system_abort("table_remove_columns has logical_col_max but no logical_col_min") - my_logical_col_min = 1 - my_logical_col_max = 0 - endif - - subtab = subtable(this, (/ (i,i=1,this%N) /), & - intcols = (/ (i,i=1,my_int_col_min-1),(i,i=my_int_col_max+1,this%intsize) /), & - realcols = (/ (i,i=1,my_real_col_min-1),(i,i=my_real_col_max+1,this%realsize) /), & - strcols = (/ (i,i=1,my_str_col_min-1),(i,i=my_str_col_max+1,this%strsize) /), & - logicalcols = (/ (i,i=1,my_logical_col_min-1),(i,i=my_logical_col_max+1,this%logicalsize) /)) - this = subtab - -end subroutine table_remove_columns - -subroutine table_bcast(mpi, this) - type(MPI_Context), intent(in) :: mpi - type(Table), intent(inout) :: this - integer :: tmp_intsize, tmp_realsize, tmp_logicalsize, tmp_strsize, tmp_max_length - - if (.not. mpi%active) return - - if (mpi%my_proc == 0) then - - tmp_max_length = this%max_length - tmp_intsize = this%intsize - tmp_realsize = this%realsize - tmp_strsize = this%strsize - tmp_logicalsize = this%logicalsize - - call bcast(mpi, tmp_max_length) - call bcast(mpi, tmp_intsize) - call bcast(mpi, tmp_realsize) - call bcast(mpi, tmp_strsize) - call bcast(mpi, tmp_logicalsize) - - call bcast(mpi, this%n) - call bcast(mpi, this%increment) - - if (this%intsize /= 0) call bcast(mpi, this%int) - if (this%realsize /= 0) call bcast(mpi, this%real) - if (this%strsize /= 0) call bcast(mpi, this%str) - if (this%logicalsize /= 0) call bcast(mpi, this%logical) - else - call finalise(this) - call bcast(mpi, tmp_max_length) - call bcast(mpi, tmp_intsize) - call bcast(mpi, tmp_realsize) - call bcast(mpi, tmp_strsize) - call bcast(mpi, tmp_logicalsize) - call allocate(this, tmp_intsize, tmp_realsize, tmp_strsize, tmp_logicalsize, tmp_max_length) - - call bcast(mpi, this%n) - call bcast(mpi, this%increment) - - if (this%intsize /= 0) call bcast(mpi, this%int) - if (this%realsize /= 0) call bcast(mpi, this%real) - if (this%strsize /= 0) call bcast(mpi, this%str) - if (this%logicalsize /= 0) call bcast(mpi, this%logical) - end if - -end subroutine table_bcast - - -!% Move a single entry from one location to another one. -!% The destination will be overriden. -subroutine table_copy_entry(this, src, dst) - implicit none - - type(Table), intent(inout) :: this - integer, intent(in) :: src - integer, intent(in) :: dst - - ! --- - - if (allocated(this%int)) then - this%int(:, dst) = this%int(:, src) - endif - - if (allocated(this%real)) then - this%real(:, dst) = this%real(:, src) - endif - - if (allocated(this%str)) then - this%str(:, dst) = this%str(:, src) - endif - - if (allocated(this%logical)) then - this%logical(:, dst) = this%logical(:, src) - endif - -endsubroutine table_copy_entry - -end module table_module diff --git a/src/libAtoms/Thermostat.f95 b/src/libAtoms/Thermostat.f95 deleted file mode 100644 index 63c4a61d63..0000000000 --- a/src/libAtoms/Thermostat.f95 +++ /dev/null @@ -1,1929 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Thermostat module -!X -!% This module contains the implementations for all the thermostats available -!% in libAtoms: Langevin, Nose-Hoover and Nose-Hoover-Langevin. -!% Each thermostat has its own section in the 'thermostat_pre_vel1-4' subroutines, -!% which interleave the usual velocity verlet steps. -!% -!% All Langevin variants with $Q > 0$ are open Langevin, from Jones \& Leimkuhler -!% preprint ``Adaptive Stochastic Methods for Nonequilibrium Sampling" -!% -!% Langevin steps for THERMOSTAT_ALL_PURPOSE use Ornstein-Uhlenbeck steps as -!% recommended by B. Leimkuhler, private comm. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module thermostat_module - - use system_module - use units_module - use linearalgebra_module - use atoms_types_module - use atoms_module - - implicit none - private - - public :: thermostat, initialise, finalise, print, add_thermostat, remove_thermostat, add_thermostats, update_thermostat, & - set_degrees_of_freedom, nose_hoover_mass, thermostat_array_assignment - public :: THERMOSTAT_NONE, & - THERMOSTAT_LANGEVIN, & - THERMOSTAT_NOSE_HOOVER, & - THERMOSTAT_NOSE_HOOVER_LANGEVIN, & - THERMOSTAT_LANGEVIN_NPT, & - THERMOSTAT_LANGEVIN_PR, & - THERMOSTAT_NPH_ANDERSEN, & - THERMOSTAT_NPH_PR, & - THERMOSTAT_LANGEVIN_OU, & - THERMOSTAT_LANGEVIN_NPT_NB, & - THERMOSTAT_ALL_PURPOSE - public :: MIN_TEMP - - public :: thermostat_pre_vel1, thermostat_post_vel1_pre_pos, thermostat_post_pos_pre_calc, thermostat_post_calc_pre_vel2, thermostat_post_vel2 - - real(dp), dimension(3,3), parameter :: matrix_one = reshape( (/ 1.0_dp, 0.0_dp, 0.0_dp, & - & 0.0_dp, 1.0_dp, 0.0_dp, & - & 0.0_dp, 0.0_dp, 1.0_dp/), (/3,3/) ) - - real(dp), parameter :: MIN_TEMP = 1.0_dp ! K - - integer, parameter :: THERMOSTAT_NONE = 0, & - THERMOSTAT_LANGEVIN = 1, & - THERMOSTAT_NOSE_HOOVER = 2, & - THERMOSTAT_NOSE_HOOVER_LANGEVIN = 3, & - THERMOSTAT_LANGEVIN_NPT = 4, & - THERMOSTAT_LANGEVIN_PR = 5, & - THERMOSTAT_NPH_ANDERSEN = 6, & - THERMOSTAT_NPH_PR = 7, & - THERMOSTAT_LANGEVIN_OU = 8, & - THERMOSTAT_LANGEVIN_NPT_NB = 9, & - THERMOSTAT_ALL_PURPOSE = 10 - - !% Nose-Hoover thermostat --- - !% Hoover, W.G., \emph{Phys. Rev.}, {\bfseries A31}, 1695 (1985) - - !% Langevin thermostat - fluctuation/dissipation --- - !% Quigley, D. and Probert, M.I.J., \emph{J. Chem. Phys.}, - !% {\bfseries 120} 11432 - - !% Nose-Hoover-Langevin thermostat --- me! - - !% all-purpose adaptive Langevin - !% Jones and Leimkuhler, \emph{J. Chem. Phys.} {\bfseries 135}, 084125 (2011). - - !% all-purpose Nose-Hoover-Langevin - !% Leimkuhler private communication (?) - - type thermostat - - integer :: type = THERMOSTAT_NONE !% One of the types listed above - real(dp) :: gamma = 0.0_dp !% Friction coefficient in Langevin and Nose-Hoover-Langevin - real(dp) :: NHL_gamma = 0.0_dp !% Friction coefficient in all-purpose thermostat NHL - real(dp) :: eta = 0.0_dp !% $\eta$ variable in Nose-Hoover - real(dp), allocatable :: chi_a(:) !% $\chi$ variable in Leimkuhler's notation for Nose-Hoover - real(dp), allocatable :: xi_a(:) !% $\xi$ variable in Leimkuhler's notation for Nose-Hoover-Langevin - real(dp) :: p_eta = 0.0_dp !% $p_\eta$ variable in Nose-Hoover and Nose-Hoover-Langevin - real(dp) :: f_eta = 0.0_dp !% The force on the Nose-Hoover(-Langevin) conjugate momentum - real(dp) :: Q = 0.0_dp !% Thermostat mass in Nose-Hoover and Nose-Hoover-Langevin - real(dp) :: NHL_mu = 0.0_dp !% Thermostat mass in all-purpose NHL - real(dp) :: T = 0.0_dp !% Target temperature - real(dp) :: Ndof = 0.0_dp !% The number of degrees of freedom of atoms attached to this thermostat - real(dp) :: work = 0.0_dp !% Work done by this thermostat - real(dp) :: p = 0.0_dp !% External pressure - real(dp) :: gamma_p = 0.0_dp !% Friction coefficient for cell in Langevin NPT - real(dp) :: W_p = 0.0_dp !% Fictious cell mass in Langevin NPT - real(dp) :: epsilon_r = 0.0_dp !% Position of barostat variable - real(dp) :: epsilon_v = 0.0_dp !% Velocity of barostat variable - real(dp) :: epsilon_f = 0.0_dp !% Force on barostat variable - real(dp) :: epsilon_f1 = 0.0_dp !% Force on barostat variable - real(dp) :: epsilon_f2 = 0.0_dp !% Force on barostat variable - real(dp) :: volume_0 = 0.0_dp !% Reference volume - real(dp), dimension(3,3) :: lattice_v = 0.0_dp - real(dp), dimension(3,3) :: lattice_f, lattice_f2 = 0.0_dp - logical :: massive = .false. - - end type thermostat - - interface initialise - module procedure thermostat_initialise - end interface initialise - - interface finalise - module procedure thermostat_finalise, thermostats_finalise - end interface finalise - - interface assignment(=) - module procedure thermostat_assignment, thermostat_array_assignment - end interface assignment(=) - - interface print - module procedure thermostat_print, thermostats_print - end interface - - interface add_thermostat - module procedure thermostats_add_thermostat - end interface add_thermostat - - interface remove_thermostat - module procedure thermostats_remove_thermostat - end interface remove_thermostat - - interface add_thermostats - module procedure thermostats_add_thermostats - end interface add_thermostats - - interface update_thermostat - module procedure thermostats_update_thermostat - end interface update_thermostat - - interface set_degrees_of_freedom - module procedure set_degrees_of_freedom_int, set_degrees_of_freedom_real - end interface set_degrees_of_freedom - - interface nose_hoover_mass - module procedure nose_hoover_mass_int, nose_hoover_mass_real - end interface nose_hoover_mass - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X INITIALISE / FINALISE - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine thermostat_initialise(this,type,T,gamma,Q,p,gamma_p,W_p,volume_0,NHL_gamma,NHL_mu,massive) - - type(thermostat), intent(inout) :: this - integer, intent(in) :: type - real(dp), optional, intent(in) :: T - real(dp), optional, intent(in) :: gamma - real(dp), optional, intent(in) :: Q - real(dp), optional, intent(in) :: p - real(dp), optional, intent(in) :: gamma_p - real(dp), optional, intent(in) :: W_p - real(dp), optional, intent(in) :: volume_0 - real(dp), optional, intent(in) :: NHL_gamma,NHL_mu - logical, optional, intent(in) :: massive - - real(dp) :: use_Q - - if (present(T)) then - if (T < 0.0_dp) call system_abort('initialise: Temperature must be >= 0') - end if - - if (type /= THERMOSTAT_NONE .and. .not.present(T)) & - call system_abort('initialise: T must be specified when turning on a thermostat') - - this%type = type - this%work = 0.0_dp - this%eta = 0.0_dp - if (allocated(this%chi_a)) deallocate(this%chi_a) - if (allocated(this%xi_a)) deallocate(this%xi_a) - this%p_eta = 0.0_dp - this%f_eta = 0.0_dp - this%epsilon_r = 0.0_dp - this%epsilon_v = 0.0_dp - this%epsilon_f = 0.0_dp - this%epsilon_f1 = 0.0_dp - this%epsilon_f2 = 0.0_dp - this%volume_0 = 0.0_dp - this%p = 0.0_dp - this%lattice_v = 0.0_dp - this%lattice_f = 0.0_dp - this%lattice_f2 = 0.0_dp - - use_Q = optional_default(-1.0_dp, Q) - - select case(this%type) - - case(THERMOSTAT_NONE) - - this%T = 0.0_dp - this%gamma = 0.0_dp - this%Q = 0.0_dp - - case(THERMOSTAT_LANGEVIN) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_LANGEVIN does not implement massive flag") - endif - - if (.not.present(gamma)) call system_abort('thermostat initialise: gamma is required for Langevin thermostat') - if (gamma < 0.0_dp) call system_abort('thermostat initialise: gamma must be >= 0 for Langevin') - this%T = T - this%gamma = gamma - this%Q = use_Q - - case(THERMOSTAT_NOSE_HOOVER) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_NOSE_HOOVER does not implement massive flag") - endif - - if (.not.present(Q)) call system_abort('thermostat initialise: Q is required for Nose-Hoover thermostat') - if (Q <= 0.0_dp) call system_abort('thermostat initialise: Q must be > 0') - this%T = T - this%gamma = 0.0_dp - this%Q = Q - - case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_NOSE_HOOVER_LANGEVIN does not implement massive flag") - endif - - if (.not.present(gamma)) & - call system_abort('thermostat initialise: gamma is required for Nose-Hoover-Langevin thermostat') - if (gamma < 0.0_dp) call system_abort('thermostat initialise: gamma must be >= 0') - if (.not.present(Q)) call system_abort('thermostat initialise: Q is required for Nose-Hoover-Langevin thermostat') - if (Q <= 0.0_dp) call system_abort('thermostat initialise: Q must be > 0') - this%T = T - this%gamma = gamma - this%Q = Q - - case(THERMOSTAT_LANGEVIN_NPT) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_LANGEVIN_NPT does not implement massive flag") - endif - - if (.not.present(gamma) .or. .not.present(p) .or. .not.present(gamma_p) .or. .not.present(W_p) .or. .not.present(volume_0) ) & - & call system_abort('thermostat initialise: p, gamma, gamma_p, W_p and volume_0 are required for Langevin NPT baro-thermostat') - this%T = T - this%gamma = gamma - this%Q = 0.0_dp - this%p = p - this%gamma_p = gamma_p - this%W_p = W_p - this%volume_0 = volume_0 - this%Q = use_Q - - case(THERMOSTAT_LANGEVIN_PR) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_LANGEVIN_PR does not implement massive flag") - endif - - if (.not.present(gamma) .or. .not.present(p) .or. .not.present(W_p) .or. .not.present(gamma_p) ) & - & call system_abort('initialise: p, gamma, W_p are required for Langevin Parrinello-Rahman baro-thermostat') - this%T = T - this%gamma = gamma - this%Q = 0.0_dp - this%p = p - this%gamma_p = gamma_p - this%W_p = W_p - this%Q = use_Q - - case(THERMOSTAT_NPH_ANDERSEN) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_NPH_ANDERSEN does not implement massive flag") - endif - - if (.not.present(W_p) .or. .not.present(p) .or. .not.present(volume_0) .or. .not.present(gamma_p) ) & - & call system_abort('thermostat initialise: p, W_p and volume_0 are required for Andersen THERMOSTAT_NPH barostat') - this%T = 0.0_dp - this%gamma = 0.0_dp - this%Q = 0.0_dp - this%p = p - this%gamma_p = gamma_p - this%W_p = W_p - this%volume_0 = volume_0 - - case(THERMOSTAT_NPH_PR) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_NPH_PR does not implement massive flag") - endif - - if (.not.present(p) .or. .not.present(W_p) .or. .not.present(gamma_p) ) & - & call system_abort('initialise: p and W_p are required for THERMOSTAT_NPH Parrinello-Rahman barostat') - this%T = 0.0_dp - this%gamma = 0.0_dp - this%Q = 0.0_dp - this%p = p - this%gamma_p = gamma_p - this%W_p = W_p - - case(THERMOSTAT_LANGEVIN_OU) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_LANGEVIN_OU does not implement massive flag") - endif - - if (.not.present(gamma)) call system_abort('thermostat initialise: gamma is required for Langevin OU thermostat') - if (gamma < 0.0_dp) call system_abort('thermostat initialise: gamma must be >= 0 for Langevin OU') - this%T = T - this%gamma = gamma - this%Q = use_Q - - case(THERMOSTAT_LANGEVIN_NPT_NB) - if (present(massive)) then - if (massive) call system_abort("THERMOSTAT_LANGEVIN_NPT_NB does not implement massive flag") - endif - - if (.not.present(gamma) .or. .not.present(p) .or. .not.present(gamma_p) .or. .not. present(W_p) ) & - & call system_abort('thermostat initialise: p, gamma, gamma_p, W_p and volume_0 are required for Langevin NPT baro-thermostat') - this%T = T - this%gamma = gamma - this%Q = use_Q - this%p = p - this%gamma_p = gamma_p - this%W_p = W_p - - case(THERMOSTAT_ALL_PURPOSE) - this%T = T - this%gamma = optional_default(0.0_dp, gamma) - this%NHL_gamma = optional_default(0.0_dp, NHL_gamma) - this%Q = optional_default(-1.0_dp, Q) - this%NHL_mu = optional_default(-1.0_dp, NHL_mu) - this%massive = optional_default(.false., massive) - - - if (count( (/ this%NHL_gamma > 0.0_dp, this%NHL_mu > 0.0_dp /) ) == 1) call system_abort("THERMOSTAT_ALL_PURPOSE needs NHL_gamma="//this%NHL_gamma//" and NHL_mu="//this%NHL_mu//" either both or neither > 0") - - end select - - end subroutine thermostat_initialise - - subroutine thermostat_finalise(this) - - type(thermostat), intent(inout) :: this - - this%type = THERMOSTAT_NONE - this%gamma = 0.0_dp - this%NHL_gamma = 0.0_dp - this%eta = 0.0_dp - this%p_eta = 0.0_dp - this%f_eta = 0.0_dp - this%Q = 0.0_dp - this%NHL_mu = 0.0_dp - this%T = 0.0_dp - this%Ndof = 0.0_dp - this%work = 0.0_dp - this%p = 0.0_dp - this%gamma_p = 0.0_dp - this%W_p = 0.0_dp - this%epsilon_r = 0.0_dp - this%epsilon_v = 0.0_dp - this%epsilon_f = 0.0_dp - this%epsilon_f1 = 0.0_dp - this%epsilon_f2 = 0.0_dp - this%lattice_v = 0.0_dp - this%lattice_f = 0.0_dp - this%lattice_f2 = 0.0_dp - this%massive = .false. - - end subroutine thermostat_finalise - - subroutine thermostat_assignment(to,from) - - type(thermostat), intent(out) :: to - type(thermostat), intent(in) :: from - - to%type = from%type - to%gamma = from%gamma - to%NHL_gamma = from%NHL_gamma - to%eta = from%eta - if (allocated(from%chi_a)) then - if (allocated(to%chi_a)) deallocate(to%chi_a) - allocate(to%chi_a(size(from%chi_a))) - to%chi_a = from%chi_a - else - if (allocated(to%chi_a)) deallocate(to%chi_a) - endif - if (allocated(from%xi_a)) then - if (allocated(to%xi_a)) deallocate(to%xi_a) - allocate(to%xi_a(size(from%xi_a))) - to%xi_a = from%xi_a - else - if (allocated(to%xi_a)) deallocate(to%xi_a) - endif - to%p_eta = from%p_eta - to%Q = from%Q - to%NHL_mu = from%NHL_mu - to%T = from%T - to%Ndof = from%Ndof - to%work = from%work - to%p = from%p - to%gamma_p = from%gamma_p - to%W_p = from%W_p - to%epsilon_r = from%epsilon_r - to%epsilon_v = from%epsilon_v - to%epsilon_f = from%epsilon_f - to%epsilon_f1 = from%epsilon_f1 - to%epsilon_f2 = from%epsilon_f2 - to%volume_0 = from%volume_0 - to%lattice_v = from%lattice_v - to%lattice_f = from%lattice_f - to%lattice_f2 = from%lattice_f2 - to%massive = from%massive - - end subroutine thermostat_assignment - - !% Copy an array of thermostats - subroutine thermostat_array_assignment(to, from) - type(thermostat), allocatable, intent(inout) :: to(:) - type(thermostat), allocatable, intent(in) :: from(:) - - integer :: u(1), l(1), i - - if (allocated(to)) deallocate(to) - u = ubound(from) - l = lbound(from) - allocate(to(l(1):u(1))) - do i=l(1),u(1) - to(i) = from(i) - end do - - end subroutine thermostat_array_assignment - - !% Finalise an array of thermostats - subroutine thermostats_finalise(this) - - type(thermostat), allocatable, intent(inout) :: this(:) - - integer :: i, ua(1), la(1), u, l - - if (allocated(this)) then - ua = ubound(this); u = ua(1) - la = lbound(this); l = la(1) - do i = l, u - call finalise(this(i)) - end do - deallocate(this) - end if - - end subroutine thermostats_finalise - - subroutine thermostats_remove_thermostat(this,index) - type(thermostat), allocatable, intent(inout) :: this(:) - integer, intent(in) :: index - - type(thermostat), allocatable :: temp(:) - integer :: i, l, u, la(1), ua(1) - - if (.not. allocated(this)) & - call system_abort('thermostats array not allocataed') - - la = lbound(this); l=la(1) - ua = ubound(this); u=ua(1) - - if (index < l .or. index > u) & - call system_abort('index '//index//' outside of range '//l//' <= index <= '//u) - - allocate(temp(l:u)) - do i = l,u - temp(i) = this(i) - end do - call finalise(this) - - allocate(this(l:u-1)) - do i = l,u - if (i == index) cycle - this(i) = temp(i) - end do - call finalise(temp) - - end subroutine thermostats_remove_thermostat - - subroutine thermostats_add_thermostat(this,type,T,gamma,Q,p,gamma_p,W_p,volume_0,NHL_gamma,NHL_mu,massive,region_i) - - type(thermostat), allocatable, intent(inout) :: this(:) - integer, intent(in) :: type - real(dp), optional, intent(in) :: T - real(dp), optional, intent(in) :: gamma - real(dp), optional, intent(in) :: Q - real(dp), optional, intent(in) :: p - real(dp), optional, intent(in) :: gamma_p - real(dp), optional, intent(in) :: W_p - real(dp), optional, intent(in) :: volume_0 - real(dp), optional, intent(in) :: NHL_gamma, NHL_mu - logical, optional, intent(in) :: massive - integer, optional, intent(out) :: region_i - - type(thermostat), allocatable :: temp(:) - integer :: i, l, u, la(1), ua(1) - - if (allocated(this)) then - la = lbound(this); l=la(1) - ua = ubound(this); u=ua(1) - allocate(temp(l:u)) - do i = l,u - temp(i) = this(i) - end do - call finalise(this) - else - l=1 - u=0 - end if - - allocate(this(l:u+1)) - - if (allocated(temp)) then - do i = l,u - this(i) = temp(i) - end do - call finalise(temp) - end if - - call initialise(this(u+1),type,T=T,gamma=gamma,Q=Q,p=p,gamma_p=gamma_p,W_p=W_p,volume_0=volume_0,NHL_gamma=NHL_gamma,NHL_mu=NHL_mu,massive=massive) - - if (present(region_i)) region_i=u+1 - - end subroutine thermostats_add_thermostat - - subroutine thermostats_add_thermostats(this,type,n,T_a,gamma_a,Q_a,region_i) - - type(thermostat), allocatable, intent(inout) :: this(:) - integer, intent(in) :: type - integer, intent(in) :: n - real(dp), optional, intent(in) :: T_a(:) - real(dp), optional, intent(in) :: gamma_a(:) - real(dp), optional, intent(in) :: Q_a(:) - integer, optional, intent(out) :: region_i - - type(thermostat), allocatable :: temp(:) - integer :: i, l, u, la(1), ua(1) - - if (allocated(this)) then - la = lbound(this); l=la(1) - ua = ubound(this); u=ua(1) - allocate(temp(l:u)) - do i = l,u - temp(i) = this(i) - end do - call finalise(this) - else - l=1 - u=0 - end if - - allocate(this(l:u+n)) - - if (allocated(temp)) then - do i = l,u - this(i) = temp(i) - end do - call finalise(temp) - end if - - do i=1, n - if (present(T_a)) then - if (present(Q_a)) then - if (present(gamma_a)) then - call initialise(this(u+i),type,T=T_a(i),gamma=gamma_a(i),Q=Q_a(i)) - else - call initialise(this(u+i),type,T=T_a(i),Q=Q_a(i)) - endif - else ! no Q_a - if (present(gamma_a)) then - call initialise(this(u+i),type,T=T_a(i),gamma=gamma_a(i)) - else - call initialise(this(u+i),type,T=T_a(i)) - endif - endif - else ! no T_A - if (present(Q_a)) then - if (present(gamma_a)) then - call initialise(this(u+i),type,gamma=gamma_a(i),Q=Q_a(i)) - else - call initialise(this(u+i),type,Q=Q_a(i)) - endif - else ! no Q_aa - if (present(gamma_a)) then - call initialise(this(u+i),type,gamma=gamma_a(i)) - else - call initialise(this(u+i),type) - endif - endif - endif - end do - - if (present(region_i)) region_i=u+1 - - end subroutine thermostats_add_thermostats - - subroutine thermostats_update_thermostat(this,T,p,w_p) - - type(thermostat), intent(inout) :: this - real(dp), optional, intent(in) :: T - real(dp), optional, intent(in) :: p - real(dp), optional, intent(in) :: w_p - - if( present(T) ) this%T = T - if( present(p) ) this%p = p - if( present(w_p) ) this%w_p = w_p - - endsubroutine thermostats_update_thermostat - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X PRINTING - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine thermostat_print(this,file) - - type(thermostat), intent(in) :: this - type(inoutput), optional, intent(in) :: file - select case(this%type) - - case(THERMOSTAT_NONE) - call print('Thermostat off',file=file) - - case(THERMOSTAT_LANGEVIN) - call print('Langevin, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& - round(this%eta,5)//' (#), work = '//round(this%work,5)//' eV, Ndof = '// round(this%Ndof,1),file=file) - - case(THERMOSTAT_NOSE_HOOVER) - call print('Nose-Hoover, T = '//round(this%T,2)//' K, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& - round(this%eta,5)//' (#), p_eta = '//round(this%p_eta,5)//' eV fs, work = '//round(this%work,5)//' eV, Ndof = ' // round(this%Ndof,1),file=file) - - case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) - call print('Nose-Hoover-Langevin, T = '//round(this%T,2)//' K, Q = '//round(this%Q,5)//& - ' eV fs^2, gamma = '//round(this%gamma,5)//' fs^-1, eta = '//round(this%eta,5)//& - ' , p_eta = '//round(this%p_eta,5)//' eV fs, work = '//round(this%work,5)//' eV, Ndof = ' // round(this%Ndof,1),file=file) - - case(THERMOSTAT_LANGEVIN_NPT) - call print('Langevin NPT, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& - round(this%eta,5)//' (#), work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, gamma_p = '// & - round(this%gamma_p,5)//' fs^-1, W_p = '//round(this%W_p,5)//' au, Ndof = ' // round(this%Ndof,1),file=file) - - case(THERMOSTAT_LANGEVIN_PR) - call print('Langevin PR, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& - round(this%eta,5)//' (#), work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, gamma_p = '// & - round(this%gamma_p,5)//' fs^-1, W_p = '//round(this%W_p,5)//' au',file=file) - - case(THERMOSTAT_NPH_ANDERSEN) - call print('Andersen THERMOSTAT_NPH, work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, W_p = '//round(this%W_p,5)//' au, Ndof = ' // round(this%Ndof,1),file=file) - - case(THERMOSTAT_NPH_PR) - call print('Parrinello-Rahman THERMOSTAT_NPH, work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, W_p = '//round(this%W_p,5)//' au, Ndof = ' // round(this%Ndof,1),file=file) - - case(THERMOSTAT_LANGEVIN_OU) - call print('Langevin OU, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& - round(this%eta,5)//' (#), work = '//round(this%work,5)//' eV, Ndof = '// round(this%Ndof,1),file=file) - - case(THERMOSTAT_LANGEVIN_NPT_NB) - call print('Langevin NPT, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& - round(this%eta,5)//' (#), work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, gamma_p = '// & - round(this%gamma_p,5)//' fs^-1, W_p = '//round(this%W_p,5)//' au, Ndof = ' // round(this%Ndof,1),file=file) - - case(THERMOSTAT_ALL_PURPOSE) - if (this%massive) then - call print('All-purpose adaptive-Langevin , T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, chi = '//& - 'too many to list (#), xi = too many to list (#), Ndof = ' // round(this%Ndof,1),file=file) - else - if (.not. allocated(this%chi_a)) then - call print('All-purpose adaptive-Langevin , T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, NHL_mu = '//round(this%NHL_mu,5)//' eV fs^2, '//& - 'NHL_gamma = '//round(this%NHL_gamma,5)//' fs^-1, chi = '//round(0.0_dp,5)//' (#), xi = '//round(0.0_dp,5)//' Ndof = ' // round(this%Ndof,1),file=file) - else - call print('All-purpose adaptive-Langevin , T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, NHL_mu = '//round(this%NHL_mu,5)//' eV fs^2, '//& - 'NHL_gamma = '//round(this%NHL_gamma,5)//' fs^-1, chi = '//round(this%chi_a(1),5)//' (#), xi = '//round(this%xi_a(1),5)//' Ndof = ' // round(this%Ndof,1),file=file) - endif - endif - - end select - - end subroutine thermostat_print - - subroutine thermostats_print(this,file) - - type(thermostat), allocatable, intent(in) :: this(:) - type(inoutput), optional, intent(in) :: file - - integer :: u, l, i, ua(1), la(1) - - la=lbound(this); l=la(1) - ua=ubound(this); u=ua(1) - - do i = l,u - call print('Thermostat '//i//':',file=file) - call print(this(i),file) - end do - - end subroutine thermostats_print - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X SETTING Ndof - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine set_degrees_of_freedom_int(this,Ndof) - - type(thermostat), intent(inout) :: this - integer, intent(in) :: Ndof - - this%Ndof = real(Ndof,dp) - - end subroutine set_degrees_of_freedom_int - - subroutine set_degrees_of_freedom_real(this,Ndof) - - type(thermostat), intent(inout) :: this - real(dp), intent(in) :: Ndof - - this%Ndof = Ndof - - end subroutine set_degrees_of_freedom_real - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X CHOOSING NOSE-HOOVER(-THERMOSTAT_LANGEVIN) MASS - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - pure function nose_hoover_mass_int(Ndof,T,tau) result(Q) - - integer, intent(in) :: Ndof - real(dp), intent(in) :: T, tau - real(dp) :: Q - - Q = nose_hoover_mass_real(real(Ndof,dp),T,tau) - - end function nose_hoover_mass_int - - pure function nose_hoover_mass_real(Ndof,T,tau) result(Q) - - real(dp), intent(in) :: Ndof, T, tau - real(dp) :: Q - - if (tau < 0.0) then - Q = -1.0_dp - else - Q = Ndof*BOLTZMANN_K*T*tau*tau/(4.0_dp*PI*PI) - endif - - end function nose_hoover_mass_real - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT ROUTINES - !X - !X These routines interleave the usual velocity Verlet steps and should modify - !X the velocities and accelerations as required: - !X - !X advance_verlet1 - !X 00 (barostat_pre_vel1) * - !X 10 (thermostat_pre_vel1) * - !X 20 v(t+dt/2) = v(t) + a(t)dt/2 - !X 30 (thermostat_post_vel1_pre_pos) - !X 40 r(t+dt) = r(t) + v(t+dt/2)dt - !X 50 (thermostat_post_pos_pre_calc) - !X 60 (barostat_post_pos_pre_calc) * - !X calc F, virial - !X advance_verlet2 - !X 70 (thermostat_post_calc_pre_vel2) * - !X 80 v(t+dt) = v(t+dt/2) + a(t+dt)dt/2 - !X 90 (thermostat_post_vel2) * - !X 100 (barostat_post_vel2) * - !X - !X * marks routines that are needed in the refactored barostat/thermostat plan - !X - !X A thermostat can be applied to part of the atomic system by passing an integer - !X atomic property and the value it must have. - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine thermostat_pre_vel1(this,at,dt,property,value,virial) - - type(thermostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - character(*), intent(in) :: property - integer, intent(in) :: value - real(dp), dimension(3,3), intent(in), optional :: virial - - real(dp) :: decay, K, volume_p, rv_mag, OU_dv(3) - real(dp), dimension(3,3) :: lattice_p, ke_virial, decay_matrix, decay_matrix_eigenvectors, exp_decay_matrix - real(dp), dimension(3) :: decay_matrix_eigenvalues - integer :: i - integer, dimension(:), pointer :: prop_ptr - real(dp) :: delta_K - - if (.not. assign_pointer(at,property,prop_ptr)) then - call system_abort('thermostat_pre_vel1: cannot find property '//property) - end if - - select case(this%type) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_LANGEVIN) - - !Decay the velocity for dt/2. The random force will have been added to acc during the - !previous timestep. - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - else - this%eta = 0.0_dp - endif - - decay = exp(-0.5_dp*(this%gamma+this%eta)*dt) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - endif - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X NOSE-HOOVER - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_NOSE_HOOVER) - - !Propagate eta for dt (this saves doing it twice, for dt/2) - if (this%Q > 0.0_dp) then - this%eta = this%eta + this%p_eta*dt/this%Q - else - this%eta = 0.0_dp - endif - - !Decay the velocities using p_eta for dt/2. Also, accumulate the (pre-decay) - !kinetic energy (x2) and use to integrate the 'work' value - K = 0.0_dp - if (this%Q > 0.0_dp) then - decay = exp(-0.5_dp*this%p_eta*dt/this%Q) - else - decay = 1.0_dp - endif - - ! dvelo = 0.0_dp - ! ntherm = 0 - do i=1, at%N - if (prop_ptr(i) /= value) cycle - K = K + at%mass(i)*normsq(at%velo(:,i)) - ! dvelo = dvelo + norm(at%velo(:,i))*abs(1.0_dp-decay) - ! ntherm = ntherm + 1 - at%velo(:,i) = at%velo(:,i)*decay - end do - ! call print("Thermostat " // value //" thermostat_pre_vel1 N-H "//(dvelo/real(ntherm,dp))) - - !Propagate the work for dt/2 - if (this%Q > 0.0_dp) then - this%work = this%work + 0.5_dp*this%p_eta*K*dt/this%Q - endif - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X NOSE-HOOVER-THERMOSTAT_LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) - - !Decay p_eta for dt/2 and propagate it for dt/2 - this%p_eta = this%p_eta*exp(-0.5_dp*this%gamma*dt) + 0.5_dp*this%f_eta*dt - !Propagate eta for dt (this saves doing it twice, for dt/2) - if (this%Q > 0.0_dp) then - this%eta = this%eta + this%p_eta*dt/this%Q - else - this%eta = 0.0_dp - endif - - !Decay the velocities using p_eta for dt/2 and accumulate Ek (as in NH) for - !work integration - if (this%Q > 0.0_dp) then - decay = exp(-0.5_dp*this%p_eta*dt/this%Q) - else - decay = 1.0_dp - endif - K = 0.0_dp - - do i = 1, at%N - if(prop_ptr(i) /= value) cycle - K = K + at%mass(i)*normsq(at%velo(:,i)) - at%velo(:,i) = at%velo(:,i)*decay - end do - - !Propagate work - if (this%Q > 0.0_dp) then - this%work = this%work + 0.5_dp*this%p_eta*K*dt/this%Q - endif - - ! advance_verlet1 will do conservative + random force parts of v half step - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN NPT, Andersen barostat - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_LANGEVIN_NPT) - - if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: NPT & - & simulation, but virial has not been passed') - - this%epsilon_r = this%epsilon_r + 0.5_dp*this%epsilon_v*dt - volume_p = exp(3.0_dp*this%epsilon_r)*this%volume_0 - lattice_p = at%lattice * (volume_p/cell_volume(at))**(1.0_dp/3.0_dp) - call set_lattice(at,lattice_p, scale_positions=.false.) - - this%epsilon_f1 = (1.0_dp + 3.0_dp/this%Ndof)*sum(at%mass*sum(at%velo**2,dim=1)) + trace(virial) & - & - 3.0_dp * volume_p * this%p - - this%epsilon_f = this%epsilon_f1 + this%epsilon_f2 - this%epsilon_v = this%epsilon_v + 0.5_dp * dt * this%epsilon_f / this%W_p - - !Decay the velocity for dt/2. The random force will have been added to acc during the - !previous timestep. - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - else - this%eta = 0.0_dp - endif - - decay = exp(-0.5_dp*dt*((this%gamma+this%eta)+(1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - at%pos(:,i) = at%pos(:,i)*( 1.0_dp + this%epsilon_v * dt ) - end do - !at%pos = at%pos*exp(this%epsilon_vp * dt) ???? - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - endif - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN NPT, Parrinello-Rahman barostat - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_LANGEVIN_PR) - - if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: NPT & - & simulation, but virial has not been passed') - - lattice_p = at%lattice + 0.5_dp * dt * matmul(this%lattice_v,at%lattice) - - call set_lattice(at,lattice_p, scale_positions=.false.) - volume_p = cell_volume(at) - - ke_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) - - this%lattice_f = ke_virial + virial - this%p*volume_p*matrix_one + trace(ke_virial)*matrix_one/this%Ndof + this%lattice_f2 - this%lattice_v = this%lattice_v + 0.5_dp*dt*this%lattice_f / this%W_p - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - else - this%eta = 0.0_dp - endif - - !Decay the velocity for dt/2. The random force will have been added to acc during the - !previous timestep. - - decay_matrix = -0.5_dp*dt*( (this%gamma+this%eta)*matrix_one + this%lattice_v + trace(this%lattice_v)*matrix_one/this%Ndof ) - decay_matrix = ( decay_matrix + transpose(decay_matrix) ) / 2.0_dp ! Making sure the matrix is exactly symmetric - call diagonalise(decay_matrix,decay_matrix_eigenvalues,decay_matrix_eigenvectors) - exp_decay_matrix = matmul( decay_matrix_eigenvectors, matmul( diag(exp(decay_matrix_eigenvalues)), transpose(decay_matrix_eigenvectors) ) ) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = matmul(exp_decay_matrix,at%velo(:,i)) - !at%velo(:,i) = at%velo(:,i) + matmul(decay_matrix,at%velo(:,i)) - at%pos(:,i) = at%pos(:,i) + matmul(this%lattice_v,at%pos(:,i))*dt - end do - !at%pos = at%pos*exp(this%epsilon_vp * dt) ???? - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - endif - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_NPH, Andersen barostat - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_NPH_ANDERSEN) - - if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: THERMOSTAT_NPH & - & simulation, but virial has not been passed') - - this%epsilon_r = this%epsilon_r + 0.5_dp*this%epsilon_v*dt - volume_p = exp(3.0_dp*this%epsilon_r)*this%volume_0 - lattice_p = at%lattice * (volume_p/cell_volume(at))**(1.0_dp/3.0_dp) - call set_lattice(at,lattice_p, scale_positions=.false.) - - this%epsilon_f = (1.0_dp + 3.0_dp/this%Ndof)*sum(at%mass*sum(at%velo**2,dim=1)) + trace(virial) & - & - 3.0_dp * volume_p * this%p - - this%epsilon_v = this%epsilon_v + 0.5_dp * dt * this%epsilon_f / this%W_p - - !Decay the velocity for dt/2. The random force will have been added to acc during the - !previous timestep. - - decay = exp(-0.5_dp*dt*(1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - at%pos(:,i) = at%pos(:,i)*( 1.0_dp + this%epsilon_v * dt ) - end do - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_NPH, Parrinello-Rahman barostat - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_NPH_PR) - - if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: THERMOSTAT_NPH & - & simulation, but virial has not been passed') - - lattice_p = at%lattice + 0.5_dp * dt * matmul(this%lattice_v,at%lattice) - - call set_lattice(at,lattice_p, scale_positions=.false.) - volume_p = cell_volume(at) - - ke_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) - - this%lattice_f = ke_virial + virial - this%p*volume_p*matrix_one + trace(ke_virial)*matrix_one/this%Ndof - this%lattice_v = this%lattice_v + 0.5_dp*dt*this%lattice_f / this%W_p - - !Decay the velocity for dt/2. - - decay_matrix = -0.5_dp*dt*( this%lattice_v + trace(this%lattice_v)*matrix_one/this%Ndof ) - decay_matrix = ( decay_matrix + transpose(decay_matrix) ) / 2.0_dp ! Making sure the matrix is exactly symmetric - call diagonalise(decay_matrix,decay_matrix_eigenvalues,decay_matrix_eigenvectors) - exp_decay_matrix = matmul( decay_matrix_eigenvectors, matmul( diag(exp(decay_matrix_eigenvalues)), transpose(decay_matrix_eigenvectors) ) ) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = matmul(exp_decay_matrix,at%velo(:,i)) - !at%velo(:,i) = at%velo(:,i) + matmul(decay_matrix,at%velo(:,i)) - at%pos(:,i) = at%pos(:,i) + matmul(this%lattice_v,at%pos(:,i))*dt - end do - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN with Ornstein-Uhlenbeck dynamics (Leimkuhler e-mail) - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_LANGEVIN_OU) - - !Decay the velocity for dt/2 by eta (aka chi) - - if (this%eta /= 0.0_dp) then - decay = exp(-0.5_dp*this%eta*dt) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - endif - - case(THERMOSTAT_LANGEVIN_NPT_NB) - if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: NPT & - simulation, but virial has not been passed') - - ! half step epsilon_v, drag and force (from last step) parts - this%epsilon_v = this%epsilon_v*exp(-0.5_dp*dt*this%gamma_p) - this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_p - - ! half step barostat drag part of v - decay = exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) - at%velo = at%velo*decay - - ! Leimkuhler+Jones adaptive Langevin - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - else - this%eta = 0.0_dp - endif - - ! half step Langevin drag part of v - decay = exp(-0.5_dp*dt*(this%gamma+this%eta)) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - - ! Leimkuhler+Jones adaptive Langevin - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - endif - - - ! half step position affine defomration - lattice_p = at%lattice - call set_lattice(at, lattice_p*exp(0.5_dp*dt*this%epsilon_v), scale_positions=.false.) - at%pos = at%pos*exp(0.5_dp*dt*this%epsilon_v) - - case(THERMOSTAT_ALL_PURPOSE) - !TIME_PROPAG_TEX 10 before first Verlet velocity step (thermostat\_pre\_vel1) - !TIME_PROPAG_TEX 10 - !TIME_PROPAG_TEX 10 $\chi$ Nose Hoover extended DOF (also part of open Langevin) - !TIME_PROPAG_TEX 10 - !TIME_PROPAG_TEX 10 $\gamma$ Langevin decay rate = 1/time constant (also part of open Langevin) - !TIME_PROPAG_TEX 10 - !TIME_PROPAG_TEX 10 $\xi$ Nose Hoover Langevin extended DOF - !TIME_PROPAG_TEX 10 - !TIME_PROPAG_TEX 10 $r.v.$ is normal random variable, variance 1 - !TIME_PROPAG_TEX 10 - !TIME_PROPAG_TEX 10 $$ v = v \exp(-(\tau/2) \gamma) + \sqrt{k_B T \frac{1-\exp(-\tau\gamma)}{m}}~r.v.$$ - !TIME_PROPAG_TEX 10 $$ \Delta K = 1/2 \left( \sum_i m_i \left| v_i \right|^2 - N_d k_B T \right) $$ - !TIME_PROPAG_TEX 10 $$ \chi = \chi + (\tau/2) \Delta K/Q $$ - !TIME_PROPAG_TEX 10 $$ \xi = \xi + (\tau/2) \Delta K/\mu $$ - !TIME_PROPAG_TEX 10 $$ v = v \exp(-0.25 \tau (\chi + \xi)) $$ - !TIME_PROPAG_TEX 10 $$ \xi = \xi \exp\left( -(\tau/2) \gamma_\mathrm{NHL} \right) + \sqrt{k_B T \frac{1-\exp(-\tau \gamma_\mathrm{NHL})}{\mu}}~r.v. $$ - !TIME_PROPAG_TEX 10 $$ v = v \exp(-0.25 \tau (\chi + \xi)) $$ - !TIME_PROPAG_TEX 10 $$ \Delta K = 1/2 \left( \sum_i m_i \left| v_i \right|^2 - N_d k_B T \right) $$ - !TIME_PROPAG_TEX 10 $$ \xi = \xi + (\tau/2) \Delta K/\mu $$ - !TIME_PROPAG_TEX 10 $$ \chi = \chi + (\tau/2) \Delta K/Q $$ - !TIME_PROPAG_TEX 10 - - if (this%gamma > 0.0_dp .or. (this%NHL_gamma > 0.0_dp .and. this%NHL_mu > 0.0_dp)) call system_resync_rng() - - if (.not. allocated(this%chi_a)) then - if (this%massive) then - allocate(this%chi_a(count(prop_ptr == value))) - allocate(this%xi_a(count(prop_ptr == value))) - else - allocate(this%chi_a(1)) - allocate(this%xi_a(1)) - endif - this%chi_a = 0.0_dp - this%xi_a = 0.0_dp - endif - - ! Random numbers may have been used at different rates on different MPI processes: - ! we must resync the random number if we want the same numbers on each process. - call system_resync_rng() - - if (this%gamma > 0.0_dp) then - ! Do the Ornstein-Uhlenbeck half step - decay=exp(-0.5_dp*this%gamma*dt) - rv_mag = sqrt(BOLTZMANN_K*this%T*(1.0_dp-decay**2)) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - OU_dv = rv_mag/sqrt(at%mass(i))*ran_normal3() - at%velo(:,i) = decay*at%velo(:,i) + OU_dv - end do - end if - - ! Leimkuhler+Jones adaptive Langevin - ! propagate chi and xi dt/4 - if (this%Q > 0.0_dp .or. this%NHL_mu > 0.0_dp) then - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - delta_K = open_Langevin_delta_K(1, at%mass(i:i), at%velo(1:3,i:i), 3.0_dp, this%T, prop_ptr(i:i), value) - if (this%Q > 0.0_dp) this%chi_a(i) = this%chi_a(i) + 0.5_dp*dt*delta_K/this%Q - if (this%NHL_mu > 0.0_dp) this%xi_a(i) = this%xi_a(i) + 0.5_dp*dt*delta_K/this%NHL_mu - end do - else - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - if (this%Q > 0.0_dp) this%chi_a = this%chi_a + 0.5_dp*dt*delta_K/this%Q - if (this%NHL_mu > 0.0_dp) this%xi_a = this%xi_a + 0.5_dp*dt*delta_K/this%NHL_mu - endif - else - this%chi_a = 0.0_dp - this%xi_a = 0.0_dp - endif - - ! quarter step drag part of v - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - decay = exp(-0.25_dp*dt*(this%chi_a(i)+this%xi_a(i))) - at%velo(:,i) = at%velo(:,i)*decay - end do - else - decay = exp(-0.25_dp*dt*(this%chi_a(1)+this%xi_a(1))) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - endif - - ! Langevin half step for xi (if doing NHL) - if (this%NHL_mu > 0.0_dp .and. this%NHL_gamma > 0.0_dp) then - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - this%xi_a(i) = this%xi_a(i)*exp(-0.5_dp*dt*this%NHL_gamma) + sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-dt*this%NHL_gamma))/this%NHL_mu)*ran_normal() - end do - else - this%xi_a = this%xi_a*exp(-0.5_dp*dt*this%NHL_gamma) + sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-dt*this%NHL_gamma))/this%NHL_mu)*ran_normal() - endif - endif - - ! quarter step drag part of v - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - decay = exp(-0.25_dp*dt*(this%chi_a(i)+this%xi_a(i))) - at%velo(:,i) = at%velo(:,i)*decay - end do - else - decay = exp(-0.25_dp*dt*(this%chi_a(1)+this%xi_a(1))) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - endif - - ! Leimkuhler+Jones adaptive Langevin - ! propagate chi and xi dt/4 - if (this%Q > 0.0_dp .or. this%NHL_mu > 0.0_dp) then - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - delta_K = open_Langevin_delta_K(1, at%mass(i:i), at%velo(1:3,i:i), 3.0_dp, this%T, prop_ptr(i:i), value) - if (this%Q > 0.0_dp) this%chi_a(i) = this%chi_a(i) + 0.5_dp*dt*delta_K/this%Q - if (this%NHL_mu > 0.0_dp) this%xi_a(i) = this%xi_a(i) + 0.5_dp*dt*delta_K/this%NHL_mu - end do - else - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - if (this%Q > 0.0_dp) this%chi_a = this%chi_a + 0.5_dp*dt*delta_K/this%Q - if (this%NHL_mu > 0.0_dp) this%xi_a = this%xi_a + 0.5_dp*dt*delta_K/this%NHL_mu - endif - endif - - end select - - end subroutine thermostat_pre_vel1 - - subroutine thermostat_post_vel1_pre_pos(this,at,dt,property,value) - - type(thermostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - character(*), intent(in) :: property - integer, intent(in) :: value - - integer, pointer, dimension(:) :: prop_ptr - - if (.not. assign_pointer(at,property,prop_ptr)) then - call system_abort('thermostat_post_vel1_pre_pos: cannot find property '//property) - end if - - select case(this%type) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !case(THERMOSTAT_LANGEVIN) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X NOSE-HOOVER - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !case(THERMOSTAT_NOSE_HOOVER) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X NOSE-HOOVER-THERMOSTAT_LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - end select - - end subroutine thermostat_post_vel1_pre_pos - - subroutine thermostat_post_pos_pre_calc(this,at,dt,property,value) - - type(thermostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - character(*), intent(in) :: property - integer, intent(in) :: value - - real(dp) :: lattice_p(3,3) - - select case(this%type) - - case(THERMOSTAT_LANGEVIN_NPT_NB) - - ! half step position affine defomration - lattice_p = at%lattice - call set_lattice(at, lattice_p*exp(0.5_dp*dt*this%epsilon_v), scale_positions=.false.) - at%pos = at%pos*exp(0.5_dp*dt*this%epsilon_v) - - end select - - end subroutine thermostat_post_pos_pre_calc - - subroutine thermostat_post_calc_pre_vel2(this,at,dt,property,value) - - type(thermostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - character(*), intent(in) :: property - integer, intent(in) :: value - - real(dp) :: R, a(3) - integer :: i - integer, pointer, dimension(:) :: prop_ptr - real(dp) :: delta_K - - if (.not. assign_pointer(at,property,prop_ptr)) then - call system_abort('thermostat_post_calc_pre_vel2: cannot find property '//property) - end if - - select case(this%type) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - case(THERMOSTAT_LANGEVIN,THERMOSTAT_LANGEVIN_NPT,THERMOSTAT_LANGEVIN_PR,THERMOSTAT_LANGEVIN_NPT_NB) - - ! Add the random acceleration - R = 2.0_dp*this%gamma*BOLTZMANN_K*this%T/dt - - ! Random numbers may have been used at different rates on different MPI processes: - ! we must resync the random number if we want the same numbers on each process. - call system_resync_rng() - - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - a = sqrt(R/at%mass(i))*ran_normal3() - at%acc(:,i) = at%acc(:,i) + a - end do - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X NOSE-HOOVER - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !case(THERMOSTAT_NOSE_HOOVER) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X NOSE-HOOVER-THERMOSTAT_LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) nothing to be done - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN with Ornstein-Uhlenbeck dynamics (Leimkuhler e-mail) - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_LANGEVIN_OU) - - ! propagate eta (a.k.a. chi) for a full step - - if (this%Q > 0.0_dp) then - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + dt*2.0_dp*delta_K/this%Q - endif - - end select - - end subroutine thermostat_post_calc_pre_vel2 - - subroutine thermostat_post_vel2(this,at,dt,property,value,virial) - - type(thermostat), intent(inout) :: this - type(atoms), intent(inout) :: at - real(dp), intent(in) :: dt - character(*), intent(in) :: property - integer, intent(in) :: value - real(dp), dimension(3,3), intent(in), optional :: virial - - real(dp) :: decay, K, volume_p, f_cell, rv_mag, OU_dv(3) - real(dp), dimension(3,3) :: lattice_p, ke_virial, decay_matrix, decay_matrix_eigenvectors, exp_decay_matrix, random_lattice - real(dp), dimension(3) :: decay_matrix_eigenvalues - integer :: i, j - integer, pointer, dimension(:) :: prop_ptr - real(dp) :: delta_K - real(dp) :: OU_random_dv_mag - - if (.not. assign_pointer(at,property,prop_ptr)) then - call system_abort('thermostat_post_vel2: cannot find property '//property) - end if - - select case(this%type) - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_LANGEVIN) - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - else - this%eta = 0.0_dp - endif - - !Decay the velocities for dt/2 again - decay = exp(-0.5_dp*(this%gamma+this%eta)*dt) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - endif - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X NOSE-HOOVER - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_NOSE_HOOVER) - - !Decay the velocities again using p_eta for dt/2, and accumulate the (post-decay) - !kinetic energy (x2) to integrate the 'work' value. - if (this%Q > 0.0_dp) then - decay = exp(-0.5_dp*this%p_eta*dt/this%Q) - else - decay = 1.0_dp - endif - K = 0.0_dp - ! dvelo = 0.0_dp - ! ntherm = 0 - do i=1, at%N - if (prop_ptr(i) /= value) cycle - ! dvelo = dvelo + norm(at%velo(:,i))*abs(1.0_dp-decay) - ! ntherm = ntherm + 1 - at%velo(:,i) = at%velo(:,i)*decay - K = K + at%mass(i)*normsq(at%velo(:,i)) - end do - ! call print("Thermostat " // value //" thermostat_post_vel2 N-H "//(dvelo/real(ntherm,dp))) - - !Calculate new f_eta... - this%f_eta = 0.0_dp - do i = 1, at%N - if (prop_ptr(i) == value) this%f_eta = this%f_eta + at%mass(i)*normsq(at%velo(:,i)) - end do - this%f_eta = this%f_eta - this%Ndof*BOLTZMANN_K*this%T - - !Propagate p_eta for dt/2 - this%p_eta = this%p_eta + 0.5_dp*this%f_eta*dt - - !Propagate the work for dt/2 - if (this%Q > 0.0_dp) then - this%work = this%work + 0.5_dp*this%p_eta*K*dt/this%Q - endif - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X NOSE-HOOVER-THERMOSTAT_LANGEVIN - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) - ! Random numbers may have been used at different rates on different MPI processes: - ! we must resync the random number if we want the same numbers on each process. - call system_resync_rng() - - !Decay the velocities again using p_eta for dt/2, and accumulate Ek for work integration - if (this%Q > 0.0_dp) then - decay = exp(-0.5_dp*this%p_eta*dt/this%Q) - else - decay = 1.0_dp - endif - K = 0.0_dp - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - K = K + at%mass(i)*normsq(at%velo(:,i)) - end do - - !Propagate work - if (this%Q > 0.0_dp) then - this%work = this%work + 0.5_dp*this%p_eta*K*dt/this%Q - endif - - !Calculate new f_eta... - this%f_eta = 0.0_dp - !Deterministic part: - do i = 1, at%N - if (prop_ptr(i) == value) this%f_eta = this%f_eta + at%mass(i)*normsq(at%velo(:,i)) - end do - this%f_eta = this%f_eta - this%Ndof*BOLTZMANN_K*this%T - !Stochastic part: - this%f_eta = this%f_eta + sqrt(2.0_dp*this%gamma*this%Q*BOLTZMANN_K*this%T/dt)*ran_normal() - - !Propagate p_eta for dt/2 then decay it for dt/2 - this%p_eta = this%p_eta + 0.5_dp*this%f_eta*dt - this%p_eta = this%p_eta*exp(-0.5_dp*this%gamma*dt) - - case(THERMOSTAT_LANGEVIN_NPT_NB) - - call system_resync_rng() - - ! Leimkuhler+Jones adaptive Langevin - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - else - this%eta = 0.0_dp - endif - - !Decay the velocities for dt/2 again Langevin part - decay = exp(-0.5_dp*dt*(this%gamma+this%eta)) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - - ! Leimkuhler+Jones adaptive Langevin - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - endif - - - !Decay the velocities for dt/2 again barostat part - decay = exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) - do i = 1, at%N - at%velo(:,i) = at%velo(:,i)*decay - end do - - ! half step with epsilon force - volume_p = cell_volume(at) - f_cell = sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_p*this%W_p/dt)*ran_normal() - this%epsilon_f = (trace(virial)+sum(at%mass*sum(at%velo**2,dim=1))-3.0_dp*volume_p*this%p) + & - 3.0_dp/this%Ndof*sum(at%mass*sum(at%velo**2,dim=1)) + f_cell - this%epsilon_f = this%epsilon_f + f_cell - this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_p - - ! half step with epsilon drag - this%epsilon_v = this%epsilon_v*exp(-0.5_dp*dt*this%gamma_p) - - case(THERMOSTAT_LANGEVIN_NPT) - ! Random numbers may have been used at different rates on different MPI processes: - ! we must resync the random number if we want the same numbers on each process. - call system_resync_rng() - - if( .not. present(virial) ) call system_abort('thermostat_post_vel2: NPT & - & simulation, but virial has not been passed') - - f_cell = sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_p*this%W_p/dt)*ran_normal() - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - else - this%eta = 0.0_dp - endif - - !Decay the velocities for dt/2 again - decay = exp(-0.5_dp*dt*((this%gamma+this%eta)+(1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - endif - - volume_p = cell_volume(at) - this%epsilon_f = (1.0_dp + 3.0_dp/this%Ndof)*sum(at%mass*sum(at%velo**2,dim=1)) + trace(virial) & - & - 3.0_dp * volume_p * this%p + f_cell - - this%epsilon_v = ( this%epsilon_v + 0.5_dp * dt * this%epsilon_f / this%W_p ) / & - & ( 1.0_dp + 0.5_dp * dt * this%gamma_p ) - - this%epsilon_r = this%epsilon_r + 0.5_dp*this%epsilon_v*dt - volume_p = exp(3.0_dp*this%epsilon_r)*this%volume_0 - lattice_p = at%lattice * (volume_p/cell_volume(at))**(1.0_dp/3.0_dp) - call set_lattice(at,lattice_p, scale_positions=.false.) - - this%epsilon_f2 = f_cell - this%epsilon_v*this%W_p*this%gamma_p - - case(THERMOSTAT_LANGEVIN_PR) - - if( .not. present(virial) ) call system_abort('thermostat_post_vel2: NPT Parrinello-Rahman& - & simulation, but virial has not been passed') - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - else - this%eta = 0.0_dp - endif - - !Decay the velocities for dt/2 again - decay_matrix = -0.5_dp*dt*( (this%gamma+this%eta)*matrix_one + this%lattice_v + trace(this%lattice_v)*matrix_one/this%Ndof ) - decay_matrix = ( decay_matrix + transpose(decay_matrix) ) / 2.0_dp ! Making sure the matrix is exactly symmetric - call diagonalise(decay_matrix,decay_matrix_eigenvalues,decay_matrix_eigenvectors) - exp_decay_matrix = matmul( decay_matrix_eigenvectors, matmul( diag(exp(decay_matrix_eigenvalues)), transpose(decay_matrix_eigenvectors) ) ) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = matmul(exp_decay_matrix,at%velo(:,i)) - !at%velo(:,i) = at%velo(:,i) + matmul(decay_matrix,at%velo(:,i)) - end do - - if (this%Q > 0.0_dp) then - ! propagate eta (Jones and Leimkuhler chi) dt/4 - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q - endif - - do i = 1, 3 - do j = 1, 3 - random_lattice(j,i) = sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_p*this%W_p/dt)*ran_normal() - enddo - enddo - random_lattice = ( random_lattice + transpose(random_lattice) ) / 2.0_dp - - volume_p = cell_volume(at) - ke_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) - this%lattice_f = ke_virial + virial - this%p*volume_p*matrix_one + trace(ke_virial)*matrix_one/this%Ndof + random_lattice - - this%lattice_v = ( this%lattice_v + 0.5_dp*dt*this%lattice_f / this%W_p ) / ( 1.0_dp + 0.5_dp * dt * this%gamma_p ) - - lattice_p = at%lattice + 0.5_dp * dt * matmul(this%lattice_v,at%lattice) - call set_lattice(at,lattice_p, scale_positions=.false.) - - this%lattice_f2 = random_lattice - this%gamma_p * this%lattice_v * this%W_p - - case(THERMOSTAT_NPH_ANDERSEN) - - if( .not. present(virial) ) call system_abort('thermostat_post_vel2: THERMOSTAT_NPH & - & simulation, but virial has not been passed') - - !Decay the velocities for dt/2 again - decay = exp(-0.5_dp*dt*(1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - - volume_p = cell_volume(at) - this%epsilon_f = (1.0_dp + 3.0_dp/this%Ndof)*sum(at%mass*sum(at%velo**2,dim=1)) + trace(virial) & - & - 3.0_dp * volume_p * this%p - - this%epsilon_v = ( this%epsilon_v + 0.5_dp * dt * this%epsilon_f / this%W_p ) - - this%epsilon_r = this%epsilon_r + 0.5_dp*this%epsilon_v*dt - volume_p = exp(3.0_dp*this%epsilon_r)*this%volume_0 - lattice_p = at%lattice * (volume_p/cell_volume(at))**(1.0_dp/3.0_dp) - call set_lattice(at,lattice_p, scale_positions=.false.) - - case(THERMOSTAT_NPH_PR) - - if( .not. present(virial) ) call system_abort('thermostat_post_vel2: THERMOSTAT_NPH Parrinello-Rahman& - & simulation, but virial has not been passed') - - !Decay the velocities for dt/2 again - decay_matrix = -0.5_dp*dt*( this%lattice_v + trace(this%lattice_v)*matrix_one/this%Ndof ) - decay_matrix = ( decay_matrix + transpose(decay_matrix) ) / 2.0_dp ! Making sure the matrix is exactly symmetric - call diagonalise(decay_matrix,decay_matrix_eigenvalues,decay_matrix_eigenvectors) - exp_decay_matrix = matmul( decay_matrix_eigenvectors, matmul( diag(exp(decay_matrix_eigenvalues)), transpose(decay_matrix_eigenvectors) ) ) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = matmul(exp_decay_matrix,at%velo(:,i)) - !at%velo(:,i) = at%velo(:,i) + matmul(decay_matrix,at%velo(:,i)) - end do - - volume_p = cell_volume(at) - ke_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) - this%lattice_f = ke_virial + virial - this%p*volume_p*matrix_one + trace(ke_virial)*matrix_one/this%Ndof - - this%lattice_v = this%lattice_v + 0.5_dp*dt*this%lattice_f / this%W_p - lattice_p = at%lattice + 0.5_dp * dt * matmul(this%lattice_v,at%lattice) - call set_lattice(at,lattice_p, scale_positions=.false.) - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X THERMOSTAT_LANGEVIN Ornstein-Uhlenbeck - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - case(THERMOSTAT_LANGEVIN_OU) - ! Random numbers may have been used at different rates on different MPI processes: - ! we must resync the random number if we want the same numbers on each process. - call system_resync_rng() - - !Decay the velocities for dt/2 again by eta (aka chi) - if (this%eta /= 0.0_dp) then - decay = exp(-0.5_dp*this%eta*dt) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - endif - - !Decay the velocities for dt with gamma - decay = exp(-this%gamma*dt) - ! add random force - OU_random_dv_mag = sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-2.0_dp*this%gamma*dt))) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay + OU_random_dv_mag/sqrt(at%mass(i))*ran_normal3() - end do - - case(THERMOSTAT_ALL_PURPOSE) - !TIME_PROPAG_TEX 90 after second Verlet velocity step (thermostat\_post\_vel2) - !TIME_PROPAG_TEX 90 - !TIME_PROPAG_TEX 90 $$ \Delta K = 1/2 \left( \sum_i m_i \left| v_i \right|^2 - N_d k_B T \right)~r.v.$$ - !TIME_PROPAG_TEX 90 $$ \chi = \chi + (\tau/2) \Delta K/Q $$ - !TIME_PROPAG_TEX 90 $$ \xi = \xi + (\tau/2) \Delta K/\mu $$ - !TIME_PROPAG_TEX 90 $$ v = v \exp(-0.25 \tau (\chi + \xi)) $$ - !TIME_PROPAG_TEX 90 $$ \xi = \xi \exp\left( -(\tau/2) \gamma_\mathrm{NHL} \right) + \sqrt{k_B T \frac{1-\exp(-\tau \gamma_\mathrm{NHL})}{\mu}}~r.v. $$ - !TIME_PROPAG_TEX 90 $$ v = v \exp(-0.25 \tau (\chi + \xi)) $$ - !TIME_PROPAG_TEX 90 $$ \Delta K = 1/2 \left( \sum_i m_i \left| v_i \right|^2 - N_d k_B T \right) $$ - !TIME_PROPAG_TEX 90 $$ \xi = \xi + (\tau/2) \Delta K/\mu $$ - !TIME_PROPAG_TEX 90 $$ \chi = \chi + (\tau/2) \Delta K/Q $$ - !TIME_PROPAG_TEX 90 $$ v = v \exp(-(\tau/2) \gamma) + \sqrt{k_B T \frac{1-\exp(-\tau\gamma)}{m}} $$ - !TIME_PROPAG_TEX 90 - - if (this%gamma > 0.0_dp .or. (this%NHL_gamma > 0.0_dp .and. this%NHL_mu > 0.0_dp)) call system_resync_rng() - - ! Leimkuhler+Jones adaptive Langevin - ! propagate chi and xi dt/4 - if (this%Q > 0.0_dp .or. this%NHL_mu > 0.0_dp) then - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - delta_K = open_Langevin_delta_K(1, at%mass(i:i), at%velo(1:3,i:i), 3.0_dp, this%T, prop_ptr(i:i), value) - if (this%Q > 0.0_dp) this%chi_a(i) = this%chi_a(i) + 0.5_dp*dt*delta_K/this%Q - if (this%NHL_mu > 0.0_dp) this%xi_a(i) = this%xi_a(i) + 0.5_dp*dt*delta_K/this%NHL_mu - end do - else - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - if (this%Q > 0.0_dp) this%chi_a = this%chi_a + 0.5_dp*dt*delta_K/this%Q - if (this%NHL_mu > 0.0_dp) this%xi_a = this%xi_a + 0.5_dp*dt*delta_K/this%NHL_mu - endif - else - this%chi_a = 0.0_dp - this%xi_a = 0.0_dp - endif - - ! quarter step drag part of v - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - decay = exp(-0.25_dp*dt*(this%chi_a(i)+this%xi_a(i))) - at%velo(:,i) = at%velo(:,i)*decay - end do - else - decay = exp(-0.25_dp*dt*(this%chi_a(1)+this%xi_a(1))) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - endif - - ! Langevin half step for xi (if doing NHL) - if (this%NHL_mu > 0.0_dp .and. this%NHL_gamma > 0.0_dp) then - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - this%xi_a(i) = this%xi_a(i)*exp(-0.5_dp*dt*this%NHL_gamma) + sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-dt*this%NHL_gamma))/this%NHL_mu)*ran_normal() - end do - else - this%xi_a = this%xi_a*exp(-0.5_dp*dt*this%NHL_gamma) + sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-dt*this%NHL_gamma))/this%NHL_mu)*ran_normal() - endif - endif - - ! quarter step drag part of v - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - decay = exp(-0.25_dp*dt*(this%chi_a(i)+this%xi_a(i))) - at%velo(:,i) = at%velo(:,i)*decay - end do - else - decay = exp(-0.25_dp*dt*(this%chi_a(1)+this%xi_a(1))) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - at%velo(:,i) = at%velo(:,i)*decay - end do - endif - - ! Leimkuhler+Jones adaptive Langevin - ! propagate chi and xi dt/4 - if (this%Q > 0.0_dp .or. this%NHL_mu > 0.0_dp) then - if (this%massive) then - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - delta_K = open_Langevin_delta_K(1, at%mass(i:i), at%velo(1:3,i:i), 3.0_dp, this%T, prop_ptr(i:i), value) - if (this%Q > 0.0_dp) this%chi_a(i) = this%chi_a(i) + 0.5_dp*dt*delta_K/this%Q - if (this%NHL_mu > 0.0_dp) this%xi_a(i) = this%xi_a(i) + 0.5_dp*dt*delta_K/this%NHL_mu - end do - else - delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) - if (this%Q > 0.0_dp) this%chi_a = this%chi_a + 0.5_dp*dt*delta_K/this%Q - if (this%NHL_mu > 0.0_dp) this%xi_a = this%xi_a + 0.5_dp*dt*delta_K/this%NHL_mu - endif - endif - - if (this%gamma > 0.0_dp) then - ! Do the Ornstein-Uhlenbeck half step - decay=exp(-0.5_dp*this%gamma*dt) - rv_mag = sqrt(BOLTZMANN_K*this%T*(1.0_dp-decay**2)) - do i = 1, at%N - if (prop_ptr(i) /= value) cycle - OU_dv = rv_mag/sqrt(at%mass(i))*ran_normal3() - at%velo(:,i) = decay*at%velo(:,i) + OU_dv - end do - end if - - end select - - end subroutine thermostat_post_vel2 - - function open_Langevin_delta_K(N, mass, velo, Ndof, T, prop_ptr, value) result(delta_K) - integer, intent(in) :: N - real(dp), intent(in) :: mass(:), velo(:,:) - real(dp), intent(in) :: Ndof - real(dp), intent(in) :: T - integer, intent(in) :: prop_ptr(:), value - - real(dp) :: delta_K - - integer i - - delta_K = 0.0_dp - do i = 1, N - if (prop_ptr(i) == value) delta_K = delta_K + mass(i)*normsq(velo(:,i)) - end do - delta_K = 0.5_dp*(delta_K - Ndof*BOLTZMANN_K*T) - end function open_Langevin_delta_K - -end module thermostat_module diff --git a/src/libAtoms/Topology.f95 b/src/libAtoms/Topology.f95 deleted file mode 100644 index b820e1562a..0000000000 --- a/src/libAtoms/Topology.f95 +++ /dev/null @@ -1,3462 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module topology_module - - use error_module - use system_module - use units_module - use extendable_str_module - use linearalgebra_module - use dictionary_module - use table_module - use periodictable_module - use connection_module - use atoms_types_module - use atoms_module - use clusters_module - use structures_module - - - implicit none - private - -public :: next_motif, find_motif_backbone - !! private :: next_motif, write_psf_section, create_bond_list, write_pdb_file - !! private :: create_angle_list, create_dihedral_list - !! private :: create_improper_list - !! private :: create_pos_dep_charges, calc_fc - - public :: delete_metal_connects, & - write_brookhaven_pdb_file, & - write_cp2k_pdb_file, & - write_psf_file, & - write_psf_file_arb_pos, & - create_residue_labels_arb_pos, & - NONE_RUN, & - QS_RUN, & - MM_RUN, & - QMMM_RUN_CORE, & - QMMM_RUN_EXTENDED, & - find_water_monomer, find_A2_monomer, find_AB_monomer, & - find_molecule_ids, & - find_general_monomer, & - find_monomer_pairs, & - find_monomer_pairs_MPI, & - find_monomer_triplets, & - find_monomer_triplets_MPI, & - calc_mean_pos - - -!parameters for Run_Type - integer, parameter :: NONE_RUN = -100 - integer, parameter :: QS_RUN = -1 - integer, parameter :: MM_RUN = 0 - integer, parameter :: QMMM_RUN_CORE = 1 - integer, parameter :: QMMM_RUN_EXTENDED = 2 - -!parameters for the Residue Library - integer, parameter, private :: MAX_KNOWN_RESIDUES = 200 !Maximum number of residues in the library - !(really about 116 at the mo) - integer, parameter, private :: MAX_ATOMS_PER_RES = 50 !Maximum number of atoms in one residue - integer, parameter, private :: MAX_IMPROPERS_PER_RES = 12 !Maximum number of impropers in one residue - - real(dp), parameter, public :: SILICON_2BODY_CUTOFF = 3.8_dp !Si-Si 2body interaction - real(dp), parameter, public :: SILICA_2BODY_CUTOFF = 7.5_dp !Si-O, O-O 2body interaction - real(dp), parameter, public :: TITANIA_2BODY_CUTOFF = 7.5_dp !Si-O, O-O 2body interaction - real(dp), parameter, public :: SILICON_3BODY_CUTOFF = 3.8_dp !Si-Si-Si, Si-Si-O 3body cutoff - real(dp), parameter, public :: SILICA_3BODY_CUTOFF = 3.6_dp !Si-O-Si, O-Si-O, Si-O-H 3body cutoff - real(dp), parameter, public :: TITANIA_3BODY_CUTOFF = 7.5_dp !Si-O, O-O 2body interaction -! real(dp), parameter, public :: SILICON_2BODY_CUTOFF = 2.8_dp !Si-Si 2body interaction -! real(dp), parameter, public :: SILICA_2BODY_CUTOFF = 5.5_dp !Si-O, O-O 2body interaction -! real(dp), parameter, public :: SILICON_3BODY_CUTOFF = 2.8_dp !Si-Si-Si, Si-Si-O 3body cutoff -! real(dp), parameter, public :: SILICA_3BODY_CUTOFF = 2.6_dp !Si-O-Si, O-Si-O, Si-O-H 3body cutoff - - real(dp), parameter, private :: Danny_R_q = 2.0_dp - real(dp), parameter, private :: Danny_Delta_q = 0.1_dp - - real(dp), parameter, private :: Danny_Si_Si_cutoff = 2.8_dp - real(dp), parameter, private :: Danny_Si_Si_O_cutoff = 2.8_dp - real(dp), parameter, private :: Danny_Si_O_cutoff = 2.6_dp - real(dp), parameter, private :: Danny_Si_H_cutoff = 0._dp -! real(dp), parameter, private :: Danny_O_O_cutoff = 2.6_dp - real(dp), parameter, private :: Danny_O_O_cutoff = 0._dp - real(dp), parameter, private :: Danny_O_H_cutoff = 1.0_dp - real(dp), parameter, private :: Danny_H_H_cutoff = 0._dp - -contains - - - !% Topology calculation using arbitrary (usually avgpos) coordinates, as a wrapper to find_residue_labels - !% if EVB is being used, must pass exact connectivity object and set evb_nneighb_only to false - !% - subroutine create_residue_labels_arb_pos(at,do_CHARMM,intrares_impropers,find_silica_residue,pos_field_for_connectivity, & - form_bond,break_bond, silica_pos_dep_charges, silica_charge_transfer, have_titania_potential, & - find_molecules, evb_nneighb_only, remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds, error) - - type(Atoms), intent(inout),target :: at - logical, optional, intent(in) :: do_CHARMM - type(Table), optional, intent(out) :: intrares_impropers - logical, optional, intent(in) :: find_silica_residue - character(len=*), optional, intent(in) :: pos_field_for_connectivity - integer, optional, intent(in) :: form_bond(2), break_bond(2) - logical, optional, intent(in) :: silica_pos_dep_charges - real(dp), intent(in), optional :: silica_charge_transfer - logical, intent(in), optional :: have_titania_potential - logical, intent(in), optional :: find_molecules - logical, intent(in), optional :: evb_nneighb_only - logical, optional, intent(in) :: remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds - integer, optional, intent(out) :: error - - real(dp), pointer :: use_pos(:,:) - type(Connection) :: t_connect - type(Atoms) :: at_copy - logical :: do_find_silica_residue, do_have_titania_potential - logical :: use_pos_is_pos - - logical :: bond_exists, do_nneighb_only - integer :: shift(3) - real(dp) :: form_bond_dist - - integer :: ji, j - - INIT_ERROR(error) - - do_nneighb_only = optional_default(.true., evb_nneighb_only) - - ! save a copy - at_copy = at - - use_pos_is_pos = .false. - ! find desired position field (pos, avgpos, whatever) - if (present(pos_field_for_connectivity)) then - if (.not. assign_pointer(at, trim(pos_field_for_connectivity), use_pos)) then - RAISE_ERROR("calc_topology can't find pos field '"//trim(pos_field_for_connectivity)//"'", error) - endif - if (trim(pos_field_for_connectivity) == 'pos') use_pos_is_pos = .true. - else if (.not. assign_pointer(at, 'avgpos', use_pos)) then - call print("WARNING: calc_topology can't find default pos field 'avgpos', trying to use pos instead") - if (.not. assign_pointer(at, 'pos', use_pos)) then - RAISE_ERROR("calc_topology can't find avgpos or pos fields",error) - endif - use_pos_is_pos = .true. - endif - - do_find_silica_residue = optional_default(.false.,find_silica_residue) - do_have_titania_potential = optional_default(.false.,have_titania_potential) - - ! copy desired pos to pos, and new connectivity - !NB don't do if use_pos => pos - if (.not. use_pos_is_pos) at_copy%pos = use_pos - if (do_find_silica_residue) then - call set_cutoff(at_copy,SILICA_2BODY_CUTOFF) - call calc_connect(at_copy, alt_connect=t_connect) - elseif (do_have_titania_potential) then - call set_cutoff(at_copy,1.3*bond_length(22, 8)) - call calc_connect(at_copy, alt_connect=t_connect) - else - ! use hysteretic connect to get nearest neighbour cutoff - ! will use default cutoff, which is the same as heuristics_nneighb_only=.true. - call calc_connect_hysteretic(at, DEFAULT_NNEIGHTOL, DEFAULT_NNEIGHTOL, alt_connect=t_connect) - endif - - - call break_form_bonds(at, t_connect, form_bond, break_bond, error=error) - PASS_ERROR(error) - - ! now create labels using this connectivity object - call create_residue_labels_internal(at,do_CHARMM,intrares_impropers,heuristics_nneighb_only=do_nneighb_only,alt_connect=t_connect,& - find_silica_residue=do_find_silica_residue, silica_pos_dep_charges=silica_pos_dep_charges, & - silica_charge_transfer=silica_charge_transfer, have_titania_potential=have_titania_potential, & - find_molecules=find_molecules, remove_Si_H_silica_bonds=remove_Si_H_silica_bonds, & - remove_Ti_H_titania_bonds=remove_Ti_H_titania_bonds, error=error) - PASS_ERROR(error) - call finalise(t_connect) - - end subroutine create_residue_labels_arb_pos - - !% Topology calculation. Recognize residues and save atomic names, residue names etc. in the atoms object. - !% Generally useable for AMBER and CHARMM force fields, in case of CHARMM, the MM charges are assigned here, too. - !% do_CHARMM=.true. is the default - !% Optionally outputs the intraresidual impropers. - !% The algorithm will fail if the Residue_Library is not present in atoms%params or in the directory. - !% Optionally use hysteretic_connect if passed as alt_connect. - !% Optionally could use hysteretic neighbours instead of nearest neighbours, if the cutoff of the - !% alt_connect were the same as at%cutoff(_break). - !% - subroutine create_residue_labels_internal(at,do_CHARMM,intrares_impropers, heuristics_nneighb_only,alt_connect, & - find_silica_residue, silica_pos_dep_charges, silica_charge_transfer, have_titania_potential, & - find_molecules, remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds, error) !, hysteretic_neighbours) - - type(Atoms), intent(inout),target :: at - logical, optional, intent(in) :: do_CHARMM - type(Table), optional, intent(out) :: intrares_impropers - logical, intent(in), optional :: heuristics_nneighb_only - type(Connection), intent(in), optional, target :: alt_connect - logical, optional, intent(in) :: find_silica_residue, silica_pos_dep_charges - real(dp), optional, intent(in) :: silica_charge_transfer - logical, optional, intent(in) :: have_titania_potential - logical, optional, intent(in) :: find_molecules - integer, optional, intent(out) :: error - logical, optional, intent(in) :: remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds -! logical, optional, intent(in) :: hysteretic_neighbours - - - character(*), parameter :: me = 'create_residue_labels_pos_internal: ' - - type(Inoutput) :: lib - character(4) :: cha_res_name(MAX_KNOWN_RESIDUES), Cres_name - character(3) :: pdb_res_name(MAX_KNOWN_RESIDUES), pres_name - integer :: residue_number(at%N) - character(4) :: atom_name(at%N), atom_name_PDB(at%N) - real(dp) :: atom_charge(at%N) - integer :: atom_subgroup(at%N) - type(Table) :: residue_type, list - logical :: unidentified(at%N) - integer, allocatable, dimension(:,:) :: motif - integer :: i, m, n, nres - character(4), allocatable :: at_names(:), at_names_PDB(:) - real(dp), allocatable :: at_charges(:) - integer, allocatable :: at_subgroups(:) - logical :: my_do_charmm - character, dimension(:,:), pointer :: atom_type, atom_type_PDB, atom_res_name, atom_mol_name - integer, dimension(:), pointer :: atom_res_number, atom_res_type, motif_atom_num, atom_subgroup_number - real(dp), dimension(:), pointer :: atom_charge_ptr - logical :: ex - type(extendable_str) :: residue_library - integer :: i_impr, n_impr - integer, allocatable :: imp_atoms(:,:) - real(dp) :: mol_charge_sum - logical :: found_residues - type(Table) :: atom_Si, atom_SiO, SiOH_list, atom_Ti, atom_TiO, TiOH_list - real(dp), dimension(:), allocatable :: charge -integer :: j,atom_i, ji -!logical :: silanol - type(Table) :: bondH,bondSi, bondTi - integer :: bond_H,bond_Si, bond_Ti -! integer :: qm_flag_index, pos_indices(3) -! logical :: do_qmmm - type(Connection), pointer :: use_connect -! logical :: use_hysteretic_neighbours - type(Table) :: O_atom, O_neighb - integer :: hydrogen - logical :: find_silica, titania_potential, do_silica_pos_dep_charges, do_find_molecules - logical :: do_remove_Si_H_silica_bonds, do_remove_Ti_H_titania_bonds - real(dp) :: do_silica_charge_transfer - - integer, pointer :: mol_id(:) - type(allocatable_array_pointers), allocatable :: molecules(:) - integer :: i_motif_at - - INIT_ERROR(error) - - call system_timer('create_residue_labels_pos_internal') - - find_silica = optional_default(.false.,find_silica_residue) - do_silica_pos_dep_charges = optional_default(.true., silica_pos_dep_charges) - do_silica_charge_transfer = optional_default(2.4_dp, silica_charge_transfer) - titania_potential = optional_default(.false.,have_titania_potential) - do_find_molecules = optional_default(.true., find_molecules) - do_remove_Si_H_silica_bonds = optional_default(.true., remove_Si_H_silica_bonds) - do_remove_Ti_H_titania_bonds = optional_default(.true., remove_Ti_H_titania_bonds) - - if (present(alt_connect)) then - use_connect => alt_connect - else - use_connect => at%connect - endif - if (.not.use_connect%initialised) then - RAISE_ERROR(me//'No connectivity data present in atoms structure', error) - endif -! use_hysteretic_neighbours = optional_default(.false.,hysteretic_neighbours) - - my_do_charmm = optional_default(.true.,do_CHARMM) - - call initialise(residue_library) - call print_title('Creating CHARMM format') - call get_param_value(at, 'Library', residue_library, error=error) - PASS_ERROR_WITH_INFO('create_residue_labels_pos_internal: no residue library specified, but topology generation requested', error) - call print('Library: '//string(residue_library)) - - !Open the residue library - !call print('Opening library...') - call initialise(lib,string(residue_library),action=INPUT) - - !Set all atoms as initially unidentified - unidentified = .true. - - ! add property for find_motif() to save the index of each atom in the motif - call add_property(at,'motif_atom_num',0, ptr=motif_atom_num) - - !Read each of the residue motifs from the library - n = 0 - nres = 0 - mol_charge_sum = 0._dp - found_residues = .false. - if (present(intrares_impropers)) call initialise(intrares_impropers,4,0,0,0,0) - call allocate(residue_type,1,0,0,0,1000) - call print('Identifying atoms...') - -!!!!!!!!!!! TITANIA POTENTIAL !!!!!!!!!! - if (titania_potential) then - ! TIO residue if Ti atom is present in the atoms structure - if (any(at%Z(1:at%N).eq.22)) then - call print('|-Looking for TIO residue, not from the library...') - call print('| |-Found... will be treated as 1 molecule, 1 residue...') - !all this bulk will be 1 residue - n = n + 1 - cha_res_name(n) = 'TIO2' - pdb_res_name(n) = '' !not used - call append(residue_type,(/n/)) - nres = nres + 1 - - !Add Ti atoms - call initialise(atom_Ti,4,0,0,0,0) - do i = 1,at%N - if (at%Z(i).eq.22) then - call append(atom_Ti,(/i,0,0,0/)) - endif - enddo - call print(atom_Ti%N//' Ti atoms found in total') - !Add O atoms - call bfs_step(at,atom_Ti,atom_TiO,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) - call print(atom_TiO%N//' O atoms found in total') -! if (any(at%Z(atom_TiO%int(1,1:atom_TiO%N)).eq.1)) call system_abort('Ti-H bond') - if (do_remove_Ti_H_titania_bonds) then - do i=1,atom_TiO%N !check Hs bonded to Ti. There shouldn't be any,removing the bond. - if (at%Z(atom_TiO%int(1,i)).eq.1) then - call print('WARNING! Ti and H are very close',verbosity=PRINT_ALWAYS) - bond_H = atom_TiO%int(1,i) - call initialise(bondH,4,0,0,0,0) - call append(bondH,(/bond_H,0,0,0/)) - call bfs_step(at,bondH,bondTi,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) - do j = 1,bondTi%N - if (at%Z(bondTi%int(1,i)).eq.22) then - bond_Ti = bondTi%int(1,i) - call print('WARNING! Remove Ti '//bond_Ti//' and H '//bond_H//' bond ('//distance_min_image(at,bond_H,bond_Ti)//')',verbosity=PRINT_ALWAYS) - call remove_bond(use_connect,bond_H,bond_Ti) - endif - enddo - endif - enddo - endif - - !Add H atoms -- if .not.remove_Ti_H_bonds, we might include whole water molecules at this stage, adding the remaining -OH. - call add_cut_hydrogens(at,atom_TiO,heuristics_nneighb_only=.true.,alt_connect=use_connect) - call print(atom_TiO%N//' O/H atoms found in total') - -!check if none of these atoms are identified yet - if (any(.not.unidentified(atom_Ti%int(1,1:atom_Ti%N)))) then - RAISE_ERROR('already identified atoms found again.', error) - endif - if (any(.not.unidentified(atom_TiO%int(1,1:atom_TiO%N)))) then -! call system_abort('already identified atoms found again.') - do i = 1,atom_TiO%N,-1 - if (.not.unidentified(atom_TiO%int(1,i))) then - call print('delete from TiO2 list already identified atom '//atom_TiO%int(1,1:atom_TiO%N)) - call delete(atom_TiO,i) - endif - enddo - endif - unidentified(atom_Ti%int(1,1:atom_Ti%N)) = .false. - unidentified(atom_TiO%int(1,1:atom_TiO%N)) = .false. - - !add atom, residue and molecule names - !TIO - do i = 1, atom_Ti%N !atom_Ti only has Ti atoms - atom_i = atom_Ti%int(1,i) - atom_name(atom_i) = 'TIO' - atom_name_PDB(atom_i) = 'TIO' - enddo - - !OTB, OTI & HTI - do i = 1, atom_TiO%N !atom_TiO only has O,H atoms - atom_i = atom_TiO%int(1,i) - !OTB & OTI - if (at%Z(atom_i).eq.8) then - call initialise(O_neighb,4,0,0,0) - call initialise(O_atom,4,0,0,0) - call append(O_atom,(/atom_i,0,0,0/)) - call bfs_step(at,O_atom,O_neighb,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) - !check nearest neighbour number = 3 - if (O_neighb%N.ne.3) then - call print('WARNING! titania O '//atom_i//'has '//O_neighb%N//'/=3 nearest neighbours',PRINT_ALWAYS) - call print('neighbours: '//O_neighb%int(1,1:O_neighb%N)) - endif - !check if it has a H nearest neighbour - hydrogen = find_in_array(at%Z(O_neighb%int(1,1:O_neighb%N)),1) - if (hydrogen.ne.0) then - atom_name(atom_i) = 'OTI' !silanol O - atom_name_PDB(atom_i) = 'OTI' !silanol O -! call print('Found OH silanol oxygen.'//atom_TiO%int(1,i)//' hydrogen: '//O_neighb%int(1,hydrogen)) - !check if it has only 1 H nearest neighbour - if (hydrogen.lt.O_neighb%N) then - if(find_in_array(at%Z(O_neighb%int(1,hydrogen+1:O_neighb%N)),1).gt.0) then - RAISE_ERROR('More than 1 H neighbours of O '//atom_i, error) - endif - endif - else - atom_name(atom_i) = 'OTB' !bridging O - atom_name_PDB(atom_i) = 'OTB' !bridging O -! call print('Found OB bridging oxygen.'//atom_TiO%int(1,i)) - endif - call finalise(O_atom) - call finalise(O_neighb) - !HSI - elseif (at%Z(atom_TiO%int(1,i)).eq.1) then - atom_name(atom_TiO%int(1,i)) = 'HTI' - atom_name_PDB(atom_TiO%int(1,i)) = 'HTI' - else - RAISE_ERROR('Non O/H atom '//atom_i//'!?', error) - endif - enddo - - !Add all the titanium atoms together - call initialise(TiOH_list,4,0,0,0,0) - call append (TiOH_list,atom_Ti) - call append (TiOH_list,atom_TiO) - - !Residue numbers - residue_number(TiOH_list%int(1,1:TiOH_list%N)) = nres - - !Charges - !call create_pos_dep_charges(at,TiOH_list,charge) !,residue_names=cha_res_name(residue_type%int(1,residue_number(1:at%N)))) - atom_charge = 1.2_dp - do i=1,at%n - if(at%Z(i).eq.8) atom_charge(i) = -0.6_dp - call print(' '//i//' '//atom_charge(i),verbosity=PRINT_ANALYSIS) - enddo - call print("overall titania charge: "//sum(atom_charge(TiOH_list%int(1,1:TiOH_list%N)))) - - call finalise(atom_Ti) - call finalise(atom_TiO) - call finalise(TiOH_list) - - else - call print('WARNING! have_titania_potential is true, but found no Ti atoms in the atoms object!',PRINT_ALWAYS) - endif - - endif -!!!!!!!!!!!!!! END TITANIA POTENTIAL !!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!! DANNY POTENTIAL !!!!!!!!!!!!!!!! - if (find_silica) then - - ! SIO residue for Danny potential if Si atom is present in the atoms structure - if (any(at%Z(1:at%N).eq.14)) then - call print('|-Looking for SIO residue, not from the library...') - call print('| |-Found... will be treated as 1 molecule, 1 residue...') - !all this bulk will be 1 residue - n = n + 1 - cha_res_name(n) = 'SIO2' - pdb_res_name(n) = '' !not used - call append(residue_type,(/n/)) - nres = nres + 1 - - !Add Si atoms - call initialise(atom_Si,4,0,0,0,0) - do i = 1,at%N - if (at%Z(i).eq.14) then - call append(atom_Si,(/i,0,0,0/)) - endif - enddo - call print(atom_Si%N//' Si atoms found in total') - !Add O atoms - call bfs_step(at,atom_Si,atom_SiO,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) - call print(atom_SiO%N//' O atoms found in total') -! if (any(at%Z(atom_SiO%int(1,1:atom_SiO%N)).eq.1)) call system_abort('Si-H bond') - if (do_remove_Si_H_silica_bonds) then - call initialise(bondH,4,0,0,0) - call initialise(bondSi,4,0,0,0) - - do i=1,atom_SiO%N !check Hs bonded to Si. There shouldn't be any,removing the bond. - if (at%Z(atom_SiO%int(1,i)).eq.1) then - call print('WARNING! Si and H are very close',verbosity=PRINT_ALWAYS) - bond_H = atom_SiO%int(1,i) - call wipe(bondH) - call wipe(bondSi) - call append(bondH,(/bond_H,0,0,0/)) - call bfs_step(at,bondH,bondSi,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) - do j = 1,bondSi%N - if (at%Z(bondSi%int(1,j)).eq.14) then - bond_Si = bondSi%int(1,j) - call print('WARNING! Remove Si '//bond_Si//' and H '//bond_H//' bond ('//distance_min_image(at,bond_H,bond_Si)//')',verbosity=PRINT_ALWAYS) - call remove_bond(use_connect,bond_H,bond_Si) - endif - enddo - endif -! call print('atom_SiO has '//at%Z(atom_SiO%int(1,i))) - enddo - endif - !Add H atoms -- if .not.remove_Si_H_bonds, we might include whole water molecules at this stage, adding the remaining -OH. - ! call bfs_step(at,atom_SiO,atom_SIOH,nneighb_only=.true.,min_images_only=.true.) - call add_cut_hydrogens(at,atom_SiO,heuristics_nneighb_only=.true.,alt_connect=use_connect) - call print(atom_SiO%N//' O/H atoms found in total') - - !check if none of these atoms are identified yet - if (any(.not.unidentified(atom_Si%int(1,1:atom_Si%N)))) then - RAISE_ERROR('already identified atoms found again.', error) - endif - if (any(.not.unidentified(atom_SiO%int(1,1:atom_SiO%N)))) then -! call system_abort('already identified atoms found again.') - do i = 1,atom_SiO%N,-1 - if (.not.unidentified(atom_SiO%int(1,i))) then - call print('delete from SiO2 list already identified atom '//atom_SiO%int(1,1:atom_SiO%N)) - call delete(atom_SiO,i) - endif - enddo - endif - unidentified(atom_Si%int(1,1:atom_Si%N)) = .false. - unidentified(atom_SiO%int(1,1:atom_SiO%N)) = .false. - - !add atom, residue and molecule names - !SIO - do i = 1, atom_Si%N !atom_Si only has Si atoms - atom_i = atom_Si%int(1,i) - atom_name(atom_i) = 'SIO' - atom_name_PDB(atom_i) = 'SIO' - enddo - !OSB, OSI & HSI - do i = 1, atom_SiO%N !atom_SiO only has O,H atoms - atom_i = atom_SiO%int(1,i) - !OSB & OSI - if (at%Z(atom_i).eq.8) then - call initialise(O_neighb,4,0,0,0) - call initialise(O_atom,4,0,0,0) - call append(O_atom,(/atom_i,0,0,0/)) - call bfs_step(at,O_atom,O_neighb,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) - !check nearest neighbour number = 2 - if (O_neighb%N.ne.2) then - call print('WARNING! silica O '//atom_i//'has '//O_neighb%N//'/=2 nearest neighbours',PRINT_ALWAYS) - call print('neighbours: '//O_neighb%int(1,1:O_neighb%N)) - endif - !check if it has a H nearest neighbour - hydrogen = find_in_array(at%Z(O_neighb%int(1,1:O_neighb%N)),1) - if (hydrogen.ne.0) then - atom_name(atom_i) = 'OSI' !silanol O - atom_name_PDB(atom_i) = 'OSI' !silanol O -! call print('Found OH silanol oxygen.'//atom_SiO%int(1,i)//' hydrogen: '//O_neighb%int(1,hydrogen)) - !check if it has only 1 H nearest neighbour - if (hydrogen.lt.O_neighb%N) then - if(find_in_array(at%Z(O_neighb%int(1,hydrogen+1:O_neighb%N)),1).gt.0) then - RAISE_ERROR('More than 1 H neighbours of O '//atom_i, error) - endif - endif - else - atom_name(atom_i) = 'OSB' !bridging O - atom_name_PDB(atom_i) = 'OSB' !bridging O -! call print('Found OB bridging oxygen.'//atom_SiO%int(1,i)) - endif - call finalise(O_atom) - call finalise(O_neighb) - !HSI - elseif (at%Z(atom_SiO%int(1,i)).eq.1) then - atom_name(atom_SiO%int(1,i)) = 'HSI' - atom_name_PDB(atom_SiO%int(1,i)) = 'HSI' - else - RAISE_ERROR('Non O/H atom '//atom_i//'!?', error) - endif - enddo - - !Add all the silica atoms together - call initialise(SiOH_list,4,0,0,0,0) - call append (SiOH_list,atom_Si) - call append (SiOH_list,atom_SiO) - - !Residue numbers - residue_number(SiOH_list%int(1,1:SiOH_list%N)) = nres - - !Charges - if (do_silica_pos_dep_charges) then - call create_pos_dep_charges(at,SiOH_list,charge) !,residue_names=cha_res_name(residue_type%int(1,residue_number(1:at%N)))) - atom_charge(SiOH_list%int(1,1:SiOH_list%N)) = 0._dp - atom_charge(SiOH_list%int(1,1:SiOH_list%N)) = charge(SiOH_list%int(1,1:SiOH_list%N)) - call print("overall silica charge: "//sum(atom_charge(SiOH_list%int(1,1:SiOH_list%N)))) - call print('Atomic charges: ',PRINT_ANALYSIS) - call print(' ATOM CHARGE',PRINT_ANALYSIS) - do i=1,at%N - call print(' '//i//' '//atom_charge(i),verbosity=PRINT_ANALYSIS) - enddo - else - where (at%z == 1) atom_charge = do_silica_charge_transfer/4.0_dp - where (at%z == 8) atom_charge = -do_silica_charge_transfer/2.0_dp - where (at%z ==14) atom_charge = do_silica_charge_transfer - end if - - call finalise(atom_Si) - call finalise(atom_SiO) - call finalise(SiOH_list) - - else - call print('WARNING! find_silica_residue is true, but found no silicon atoms in the atoms object!',PRINT_ALWAYS) - endif - - endif -!!!!!!!!!!!!!!! END DANNY POTENTIAL !!!!!!!!!!!!!!!! - - do - - ! Pull the next residue template from the library - if (my_do_charmm) then - call next_motif(lib,cres_name,pres_name,motif,atom_names=at_names,atom_charges=at_charges,atom_names_PDB=at_names_PDB, n_impr=n_impr,imp_atoms=imp_atoms,do_CHARMM=.true.,at_subgroups=at_subgroups) - else - call next_motif(lib,cres_name,pres_name,motif,atom_names=at_names,atom_names_PDB=at_names_PDB, do_CHARMM=.false.,at_subgroups=at_subgroups) - endif - - if (cres_name=='NONE') then - found_residues = .true. - exit - endif - -! call print("motif") -! call print("cres_name " // trim(cres_name)// " pres_name "//trim(pres_name) // " n_impr " // n_impr) -! do m=1, size(motif,1) -! call print("motif " // motif(m,1:7) // " name " // trim(at_names(m)) // " charge " // at_charges(m) // " PDB name " // trim(at_names_PDB(m)) // & -! " subgroup " // at_subgroups(m)) -! end do - - ! Store its CHARMM (3 char) and PDB (3 char) names - ! e.g. cha/pdb_res_name(5) corresponds to the 5th residue found in the library - n = n + 1 - cha_res_name(n) = cres_name - pdb_res_name(n) = pres_name - - ! Search the atom structure for this residue - call print('|-Looking for '//cres_name//'...',verbosity=PRINT_ANALYSIS) - call find_motif(at,motif,list,mask=unidentified,nneighb_only=heuristics_nneighb_only,alt_connect=use_connect) !,hysteretic_neighbours=use_hysteretic_neighbours) - - if (list%N > 0) then - - call print('| |-Found '//list%N//' occurrences of '//cres_name//' with charge '//(sum(at_charges(1:size(at_charges))))) - mol_charge_sum = mol_charge_sum + list%N * sum(at_charges(1:size(at_charges))) - - ! Loop over all found instances of the residue - - do m = 1, list%N - - !Mark the newly identified atoms -!1 row is 1 residue - unidentified(list%int(:,m)) = .false. - - do i_motif_at=1, size(list%int,1) - motif_atom_num(list%int(i_motif_at,m)) = i_motif_at - end do - - !Store the residue info - nres = nres + 1 - call append(residue_type,(/n/)) - ! if residue_type%int(1,2) == 3 then residue no. 2 matches the 3rd residue in the library - residue_number(list%int(:,m)) = nres - !e.g. if residue_number(i) = j j-th residue in the atoms object (1 to 8000 in case of 8000 H2O) - ! residue_type(1,j) = k k-th residue in the library file, in order - ! cha_res_name(k) = 'ALA' name of the k-th residue in the library file - !then atom 'i' is in a residue 'ALA' - atom_subgroup(list%int(:,m)) = at_subgroups - atom_name(list%int(:,m)) = at_names - atom_name_PDB(list%int(:,m)) = at_names_PDB - if (my_do_charmm) then - atom_charge(list%int(:,m)) = at_charges - ! intraresidual IMPROPERs - if (present(intrares_impropers)) then - do i_impr = 1, n_impr - call append(intrares_impropers,list%int(imp_atoms(1:4,i_impr),m)) -! call print('Added intraresidual improper '//intrares_impropers%int(1:4,intrares_impropers%N)) - enddo - endif - endif - end do - - end if - - call print('|',verbosity=PRINT_ANALYSIS) - - end do - - ! check if residue library is empty - if (.not.found_residues) then - RAISE_ERROR('Residue library '//trim(lib%filename)//' does not contain any residues!', error) - endif - - call print('Finished.') - call print(nres//' residues found in total') - - if (any(unidentified)) then - call print(count(unidentified)//' unidentified atoms',verbosity=PRINT_ALWAYS) - call print(find(unidentified)) - do i=1,at%N - if (unidentified(i)) then - call print(ElementName(at%Z(i))//' atom '//i//' has avgpos: '//round(at%pos(1,i),5)//& - ' '//round(at%pos(2,i),5)//' '//round(at%pos(3,i),5),verbosity=PRINT_ALWAYS) - call print(ElementName(at%Z(i))//' atom '//i//' has number of neighbours: '//n_neighbours(at,i,alt_connect=alt_connect),verbosity=PRINT_ALWAYS) - do ji=1, n_neighbours(at, i, alt_connect=alt_connect) - j = neighbour(at, i, ji, alt_connect=alt_connect) - call print(" neighbour " // j // " is of type " // ElementName(at%Z(j)), verbosity=PRINT_ALWAYS) - end do - endif - enddo - - call print(at%connect) - ! THIS IS WHERE THE CALCULATION OF NEW PARAMETERS SHOULD GO - RAISE_ERROR('create_residue_labels_pos_internal: Unidentified atoms', error) - - else - call print('All atoms identified') - call print('Total charge of the molecule: '//round(mol_charge_sum,5)) - end if - - ! add data to store CHARMM topology - call add_property(at,'atom_type',repeat(' ',TABLE_STRING_LENGTH), ptr=atom_type) - call add_property(at,'atom_type_PDB',repeat(' ',TABLE_STRING_LENGTH), ptr=atom_type_PDB) - call add_property(at,'atom_res_name',repeat(' ',TABLE_STRING_LENGTH), ptr=atom_res_name) - call add_property(at,'atom_mol_name',repeat(' ',TABLE_STRING_LENGTH), ptr=atom_mol_name) - call add_property(at,'atom_res_number',0, ptr=atom_res_number) - call add_property(at,'atom_subgroup_number',0, ptr=atom_subgroup_number) - call add_property(at,'atom_res_type',0, ptr=atom_res_type) - call add_property(at,'atom_charge',0._dp, ptr=atom_charge_ptr) - - atom_type(1,1:at%N) = 'X' - atom_type_PDB(1,1:at%N) = 'X' - atom_res_name(1,1:at%N) = 'X' - atom_mol_name(1,1:at%N) = 'X' - atom_res_number(1:at%N) = 0 - atom_subgroup_number(1:at%N) = 0 - atom_res_type(1:at%N) = 0 - atom_charge_ptr(1:at%N) = 0._dp - - do i=1, at%N - atom_res_name(:,i) = pad(cha_res_name(residue_type%int(1,residue_number(i))), TABLE_STRING_LENGTH) - atom_res_number(i) = residue_number(i) - atom_subgroup_number(i) = atom_subgroup(i) - atom_res_type(i) = residue_type%int(1,residue_number(i)) - atom_type(:,i) = pad(adjustl(atom_name(i)), TABLE_STRING_LENGTH) - atom_type_PDB(:,i) = pad(adjustl(atom_name_PDB(i)), TABLE_STRING_LENGTH) - end do - - if (my_do_charmm) then - if (do_find_molecules) then - allocate(molecules(at%N)) - call find_molecule_ids(at,molecules,heuristics_nneighb_only=heuristics_nneighb_only,alt_connect=alt_connect) - do i=1, size(molecules) - if (allocated(molecules(i)%i_a)) then - ! special case for silica molecule - if (find_silica .and. count(at%Z(molecules(i)%i_a) == 14) /=0) then - atom_mol_name(:,molecules(i)%i_a) = atom_res_name(:,molecules(i)%i_a) - ! special case for single atoms - elseif (size(molecules(i)%i_a) == 1) then - atom_mol_name(:,molecules(i)%i_a) = atom_res_name(:,molecules(i)%i_a) - ! special case for H2O - else if (size(molecules(i)%i_a) == 3) then - if (count(at%Z(molecules(i)%i_a) == 8) == 1 .and. & - count(at%Z(molecules(i)%i_a) == 1) == 2) then - atom_mol_name(:,molecules(i)%i_a) = atom_res_name(:,molecules(i)%i_a) - else ! default - call print("Found molecule containing "//size(molecules(i)%i_a)//" atoms and not water, single atom or silica") - do j=1,size(molecules(i)%i_a) - atom_mol_name(:,molecules(i)%i_a(j)) = pad("M"//i, TABLE_STRING_LENGTH) - end do - endif - else ! default - call print("Found molecule containing "//size(molecules(i)%i_a)//" atoms and not water, single atom or silica") - do j=1,size(molecules(i)%i_a) - atom_mol_name(:,molecules(i)%i_a(j)) = pad("M"//i, TABLE_STRING_LENGTH) - end do - endif - end if ! allocated(molecules) - end do ! i=1,size(molecules) - deallocate(molecules) - else - ! find_molecules is F, assume we have just one molecule - ! we set molecule name to residue name of first atom - - call add_property(at,'mol_id',0,overwrite=.true.) - if (.not. assign_pointer(at,'mol_id',mol_id)) & - call system_abort("create_residue_labels_internal can't assign mol_id") - mol_id(:) = 1 - do i=1, at%N - atom_mol_name(:,i) = atom_res_name(:,1) - end do - end if - atom_charge_ptr(1:at%N) = atom_charge(1:at%N) - endif - - if (any(atom_res_number(1:at%N).le.0)) then - RAISE_ERROR('create_residue_labels_pos_internal: atom_res_number is not >0 for every atom', error) - endif - if (any(atom_type(1,1:at%N).eq.'X')) then - RAISE_ERROR('create_residue_labels_pos_internal: atom_type is not saved for at least one atom', error) - endif - if (any(atom_res_name(1,1:at%N).eq. 'X')) then - RAISE_ERROR('create_residue_labels_pos_internal: atom_res_name is not saved for at least one atom', error) - endif - - !Free up allocations - call finalise(residue_type) - call finalise(list) - if (allocated(motif)) deallocate(motif) - - !Close the library - call finalise(lib) - - call system_timer('create_residue_labels_pos_internal') - - end subroutine create_residue_labels_internal - - subroutine find_molecule_ids(at,molecules,heuristics_nneighb_only,alt_connect) - type(Atoms), intent(inout) :: at - type(allocatable_array_pointers), optional :: molecules(:) - logical, intent(in), optional :: heuristics_nneighb_only - type(Connection), intent(in), optional, target :: alt_connect - - integer, pointer :: mol_id(:) - integer :: last_seed, last_mol_id, seed_at - logical :: added_something - type(Table) :: cur_molec, next_atoms - - !if property not present - call add_property(at,'mol_id',0) - if (.not. assign_pointer(at,'mol_id',mol_id)) & - call system_abort("find_molecule_ids can't assign mol_id") - !if present - mol_id=0 - - last_seed = 0 - last_mol_id = 0 - do while (any(mol_id == 0)) - do seed_at=last_seed+1, at%N - if (mol_id(seed_at) /= 0) cycle - - ! find molecule from seed - call initialise(cur_molec) - call append(cur_molec, (/ seed_at, 0, 0, 0 /) ) - added_something = .true. - ! look for neighbours - do while (added_something) - call initialise(next_atoms) - call bfs_step(at,cur_molec,next_atoms,nneighb_only = heuristics_nneighb_only, min_images_only = .true., alt_connect=alt_connect) - if (next_atoms%N > 0) then - added_something = .true. - call append(cur_molec, next_atoms) - else - added_something = .false. - endif - end do - - ! set mol_id - mol_id(cur_molec%int(1,1:cur_molec%N)) = last_mol_id+1 - ! store in molecules - if (present(molecules)) then - allocate(molecules(last_mol_id+1)%i_a(cur_molec%N)) - molecules(last_mol_id+1)%i_a = cur_molec%int(1,1:cur_molec%N) - endif - call finalise(cur_molec) - - last_mol_id = last_mol_id + 1 - - last_seed = seed_at - end do ! seed_at - end do ! while any(mol_id == 0) - - call finalise(cur_molec) - call finalise(next_atoms) - end subroutine find_molecule_ids - - - !% This is the subroutine that reads residues from a library. - !% Used by create_CHARMM, can read from CHARMM and AMBER residue libraries. - !% do_CHARMM=.true. is the default - ! - subroutine next_motif(library,res_name,pdb_name,motif,atom_names,atom_charges,atom_names_PDB, n_impr,imp_atoms,do_CHARMM,at_subgroups,header_line) - - type(Inoutput), intent(in) :: library - character(4), intent(out) :: res_name - character(3), intent(out) :: pdb_name - integer, allocatable, intent(out) :: motif(:,:) - character(4), allocatable, intent(out) :: atom_names(:), atom_names_PDB(:) - real(dp), optional, allocatable, intent(out) :: atom_charges(:) - logical, optional, intent(in) :: do_CHARMM - integer, optional, allocatable, intent(out) :: imp_atoms(:,:) - integer, optional, intent(out) :: n_impr - integer, optional, allocatable, intent(out) :: at_subgroups(:) - character(len=*), optional, intent(out) :: header_line - - character(20), dimension(11) :: fields - integer :: status, num_fields, data(7), i, n_at, max_num_fields - type(Table) :: motif_table - integer :: tmp_at_subgroups(MAX_ATOMS_PER_RES) - character(4) :: tmp_at_names(MAX_ATOMS_PER_RES), tmp_at_names_PDB(MAX_ATOMS_PER_RES) - real(dp) :: tmp_at_charges(MAX_ATOMS_PER_RES),check_charge - logical :: my_do_charmm - character(len=STRING_LENGTH) :: line - ! for improper generation - integer :: imp_fields, tmp_imp_atoms(4,MAX_IMPROPERS_PER_RES) - - my_do_charmm = .true. - if (present(do_CHARMM)) my_do_charmm = do_CHARMM - - if (my_do_charmm) then - max_num_fields = 11 - imp_fields = 5 - else !do AMBER - max_num_fields = 9 - endif - - status = 0 - - if (present(header_line)) header_line ='' - do while(status==0) - line = read_line(library,status) - if (present(header_line)) then - if (len_trim(header_line) > 0) header_line=trim(header_line)//quip_new_line - header_line=trim(header_line)//trim(line) - endif - if (line(1:8)=='%residue') exit - end do - - if (status/=0) then - res_name = 'NONE' - pdb_name = 'NON' - return - end if - - call parse_string(line,' ',fields,num_fields) - res_name = trim(adjustl(fields(3))) - pdb_name = trim(adjustl(fields(4))) - - call allocate(motif_table,7,0,0,0,20) - n_at = 0 - check_charge=0._dp - ! residue structure [& charges] - do - call parse_line(library,' ',fields,num_fields) - if (num_fields < max_num_fields-1) exit ! last column of protein library (atom_name_PDB) is optional - do i = 1, 7 - data(i) = string_to_int(fields(i+1)) - end do - call append(motif_table,data) - n_at = n_at + 1 - tmp_at_subgroups(n_at) = string_to_int(fields(1)) - tmp_at_names(n_at) = fields(9) - if (my_do_charmm) then - tmp_at_charges(n_at) = string_to_real(fields(10)) - check_charge=check_charge+tmp_at_charges(n_at) - if(num_fields == 11) then - tmp_at_names_PDB(n_at) = fields(11) - else - tmp_at_names_PDB(n_at) = tmp_at_names(n_at) - end if - endif - end do - if (my_do_charmm) then - ! intra amino acid IMPROPER generation here - n_impr = 0 - do - if (num_fields < imp_fields) exit - if (trim(fields(1)).ne.'IMP') call system_abort('wrong improper format, should be: "IMP 1 4 7 10" with the 1st in the middle') - n_impr = n_impr + 1 - do i = 1,4 - tmp_imp_atoms(i,n_impr) = string_to_int(fields(i+1)) - enddo - call parse_line(library,' ',fields,num_fields) - enddo - endif - -! if (abs(mod(check_charge,1.0_dp)).ge.0.0001_dp .and. & -! abs(mod(check_charge,1.0_dp)+1._dp).ge.0.0001_dp .and. & !for -0.9999... -! abs(mod(check_charge,1.0_dp)-1._dp).ge.0.0001_dp) then !for +0.9999... -! call print('WARNING next_motif: Charge of '//res_name//' residue is :'//round(check_charge,4),verbosity=PRINT_ALWAYS) -! endif - - allocate(motif(motif_table%N,7)) - - motif = transpose(int_part(motif_table)) - - allocate(atom_names(n_at)) - atom_names = tmp_at_names(1:n_at) - allocate(atom_names_PDB(n_at)) - if (my_do_charmm) then - allocate(atom_charges(n_at)) - atom_charges = tmp_at_charges(1:n_at) - allocate(imp_atoms(4,n_impr)) - imp_atoms(1:4,1:n_impr) = tmp_imp_atoms(1:4,1:n_impr) - atom_names_PDB = tmp_at_names_PDB(1:n_at) - else - atom_names_PDB = atom_names - endif - - if (present(at_subgroups)) then - if (allocated(at_subgroups)) then - if (size(at_subgroups) /= n_at) deallocate(at_subgroups) - endif - if (.not. allocated(at_subgroups)) allocate(at_subgroups(n_at)) - at_subgroups = tmp_at_subgroups(1:n_at) - endif - - call finalise(motif_table) - - end subroutine next_motif - - !% Writes PDB format using the pdb_format passed as an input - !% printing charges into the last column of PDB file - !% Sample lines: - !%ATOM 1 CT3 ALA A 1 0.767 0.801 13.311 0.00 0.00 ALA C -0.2700 - !%ATOM 2 HA ALA A 1 0.074 -0.060 13.188 0.00 0.00 ALA H 0.0900 - !%ATOM 3 HA ALA A 1 0.176 1.741 13.298 0.00 0.00 ALA H 0.0900 - ! - subroutine write_pdb_file(at,pdb_file,pdb_format,run_type_string) - - character(len=*), intent(in) :: pdb_file - type(Atoms), intent(in) :: at - character(len=*), intent(in) :: pdb_format - character(len=*), optional, intent(in) :: run_type_string - - type(Inoutput) :: pdb - character(103) :: sor !Brookhaven only uses 88 - integer :: mm - character(4) :: QM_prefix_atom_mol_name - character, dimension(:,:), pointer :: atom_type, atom_res_name, atom_mol_name - integer, dimension(:), pointer :: atom_res_number - real(dp), dimension(:), pointer :: atom_charge - character(len=STRING_LENGTH) :: my_run_type_string - real(dp) :: cell_lengths(3), cell_angles(3) - - external :: lattice_xyz_to_abc - - call system_timer('write_pdb_file') - my_run_type_string = optional_default('',run_type_string) - - call initialise(pdb,trim(pdb_file),action=OUTPUT) - call print(' PDB file: '//trim(pdb%filename)) -! call print('REMARK'//at%N,file=pdb) -!lattice information could be added in a line like this: -!CRYST1 1.000 1.000 1.000 90.00 90.00 90.00 P 1 1 - call get_lattice_params(at%lattice, cell_lengths(1), cell_lengths(2), cell_lengths(3), & - cell_angles(1), cell_angles(2), cell_angles(3)) - sor='' - write(sor, '(a6,3f9.3,3f7.2,a16)') 'CRYST1', cell_lengths(:), DEGREES_PER_RADIAN*cell_angles(:), ' P 1 1' - call print(sor, file=pdb) - -! if ((trim(my_run_type_string).eq.'QMMM_CORE') .or. & -! (trim(my_run_type_string).eq.'QMMM_EXTENDED')) then -! qm_flag_index = get_property(at,'cluster_mark') -! if (trim(my_run_type_string).eq.'QMMM_EXTENDED') run_type=QMMM_RUN_EXTENDED -! if (trim(my_run_type_string).eq.'QMMM_CORE') run_type=QMMM_RUN_CORE -! endif - - if (.not. assign_pointer(at, 'atom_type_PDB', atom_type)) & - call system_abort('Cannot assign pointer to "atom_type_PDB" property.') - if (.not. assign_pointer(at, 'atom_res_name', atom_res_name)) & - call system_abort('Cannot assign pointer to "atom_res_name" property.') - if (.not. assign_pointer(at, 'atom_mol_name', atom_mol_name)) & - call system_abort('Cannot assign pointer to "atom_mol_name" property.') - if (.not. assign_pointer(at, 'atom_res_number', atom_res_number)) & - call system_abort('Cannot assign pointer to "atom_res_numer" property.') - if (.not. assign_pointer(at, 'atom_charge', atom_charge)) & - call system_abort('Cannot assign pointer to "atom_charge" property.') - - do mm=1,at%N - ! e.g. CP2K needs different name for QM molecules, if use isolated atoms - sor = '' - QM_prefix_atom_mol_name = '' - QM_prefix_atom_mol_name = trim(a2s(atom_mol_name(:,mm))) -!does not work for contiguous molecules, e.g. silica -!!! if ((trim(run_type_string).eq.'QMMM_CORE') .or. & -!!! (trim(run_type_string).eq.'QMMM_EXTENDED')) then -!!! if (at%data%int(qm_flag_index,mm).ge.QMMM_RUN_CORE .and. at%data%int(qm_flag_index,mm).le.run_type) then -!!! QM_prefix_atom_mol_name = 'QM'//trim(at%data%str(atom_mol_name_index,mm)) -!!!! call print('QM molecule '//QM_prefix_atom_mol_name) -!!! endif -!!! endif -! call print('molecule '//QM_prefix_atom_mol_name) -! call print('writing PDB file: atom type '//at%data%str(atom_type_index,mm)) - write(sor,trim(pdb_format)) 'ATOM ',mm,trim(a2s(atom_type(:,mm))),trim(a2s(atom_res_name(:,mm))),atom_res_number(mm), & - at%pos(1:3,mm),0._dp,0._dp,QM_prefix_atom_mol_name,ElementName(at%Z(mm)),atom_charge(mm) -! at%pos(1:3,mm),0._dp,0._dp,this%atom_res_name(mm),ElementName(at%Z(mm)),this%atom_charge(mm) - call print(sor,file=pdb) - enddo - call print('END',file=pdb) - - call finalise(pdb) - - call system_timer('write_pdb_file') - - end subroutine write_pdb_file - - !% Writes Brookhaven PDB format - !% charges are printed into the PSF file, too - !% use CHARGE_EXTENDED keyword i.e. reads charges from the last column of PDB file - !% Sample line: - !%ATOM 1 CT3 ALA A 1 0.767 0.801 13.311 0.00 0.00 ALA C -0.2700 - !%ATOM 2 HA ALA A 1 0.074 -0.060 13.188 0.00 0.00 ALA H 0.0900 - !%ATOM 3 HA ALA A 1 0.176 1.741 13.298 0.00 0.00 ALA H 0.0900 - ! - subroutine write_brookhaven_pdb_file(at,pdb_file,run_type_string) - - character(len=*), intent(in) :: pdb_file - type(atoms), intent(in) :: at - character(len=*), optional, intent(in) :: run_type_string - -! character(*), parameter :: pdb_format = '(a6,i5,1x,a4,1x,a4,1x,i4,1x,3x,3f8.3,2f6.2,10x,a2,2x,f7.4)' - character(*), parameter :: pdb_format = '(a6,i5,1x,a4,1x,a4,i5,1x,3x,3f8.3,2f6.2,6x,a4,1x,a2,2x,f7.4)' - - !Brookhaven PDB format - ! sor(1:6) = 'ATOM ' - ! sor(7:11) = mm - ! sor(13:16) = this%atom_type(mm) - ! sor(18:21) = this%res_name(mm) - !! sor(22:22) = ' A' !these two are now - ! sor(23:26) = residue_number(mm) ! merged to handle >9999 residues - ! sor(31:38) = at%pos(1,mm) - ! sor(39:46) = at%pos(2,mm) - ! sor(47:54) = at%pos(3,mm) - ! sor(55:60) = ' 0.00' - ! sor(61:66) = ' 0.00' - !! sor(72:75) = 'MOL1' - ! sor(77:78) = ElementName(at%Z(mm)) - ! sor(79:86) = this%atom_charge(mm) - - call system_timer('write_brookhaven_pdb_file') - - call write_pdb_file(at,pdb_file,pdb_format,run_type_string) - - call system_timer('write_brookhaven_pdb_file') - - end subroutine write_brookhaven_pdb_file - - !% Writes modified PDB format for accurate coordinates and charges, for CP2K - !% Use CHARGE_EXTENDED keyword i.e. reads charges from the last column of PDB file - !% Sample line: - !%ATOM 1 CT3 ALA A 1 0.76700000 0.80100000 13.31100000 0.00 0.00 ALA C -0.27 - !%ATOM 2 HA ALA A 1 0.07400000 -0.06000000 13.18800000 0.00 0.00 ALA H 0.09 - !%ATOM 3 HA ALA A 1 0.17600000 1.74100000 13.29800000 0.00 0.00 ALA H 0.09 - ! - subroutine write_cp2k_pdb_file(at,pdb_file,run_type_string) - - character(len=*), intent(in) :: pdb_file - type(atoms), intent(in) :: at - character(len=*), optional, intent(in) :: run_type_string - -! character(*), parameter :: pdb_format = '(a6,i5,1x,a4,1x,a4,1x,i4,1x,3x,3f13.8,2f6.2,10x,a2,2x,f6.4)' - character(*), parameter :: pdb_format = '(a6,i5,1x,a4,1x,a4,i5,1x,3x,3f13.8,2f6.2,5x,a4,1x,a2,2x,f7.4)' - - !CP2K modified PDB format - ! sor(1:6) = 'ATOM ' - ! sor(7:11) = mm - ! sor(13:16) = this%atom_type(mm) - ! sor(18:21) = this%res_name(mm) - !! sor(22:22) = ' A' !these two are now - ! sor(23:26) = residue_number(mm) ! merged to handle >9999 residues - ! sor(31:43) = at%pos(1,mm) - ! sor(44:56) = at%pos(2,mm) - ! sor(57:69) = at%pos(3,mm) - ! sor(70:75) = ' 0.00' - ! sor(76:81) = ' 0.00' - !! sor(87:90) = 'MOL1' - ! sor(92:93) = ElementName(at%Z(mm)) - ! sor(96:) = this%atom_charge(mm) - - call system_timer('write_cp2k_pdb_file') - - call write_pdb_file(at,pdb_file,pdb_format,run_type_string) - - call system_timer('write_cp2k_pdb_file') - - end subroutine write_cp2k_pdb_file - - subroutine write_psf_file_arb_pos(at,psf_file,run_type_string,intrares_impropers,imp_filename,add_silica_23body,& - pos_field_for_connectivity,form_bond,break_bond, remove_qmmm_link_bonds, & - run_suffix, error) - character(len=*), intent(in) :: psf_file - type(atoms), intent(inout) :: at - character(len=*), optional, intent(in) :: run_type_string - type(Table), optional, intent(in) :: intrares_impropers - character(80), optional, intent(in) :: imp_filename - logical, optional, intent(in) :: add_silica_23body - character(len=*), optional, intent(in) :: pos_field_for_connectivity, run_suffix - integer, optional, intent(in) :: form_bond(2), break_bond(2) - logical, optional, intent(in) :: remove_qmmm_link_bonds - integer, optional, intent(out) :: error - - real(dp), pointer :: use_pos(:,:) - type(Connection) :: t_connect - type(Atoms) :: at_copy - !character(len=TABLE_STRING_LENGTH), pointer :: atom_res_name_p(:) - logical :: use_pos_is_pos, do_add_silica_23body - - INIT_ERROR(error) - - ! save a copy - at_copy = at - - do_add_silica_23body = optional_default(.false., add_silica_23body) - - ! find desired position field (pos, avgpos, whatever) - use_pos_is_pos = .false. - if (present(pos_field_for_connectivity)) then - if (.not. assign_pointer(at, trim(pos_field_for_connectivity), use_pos)) then - RAISE_ERROR("calc_topology can't find pos field '"//trim(pos_field_for_connectivity)//"'", error) - endif - if (trim(pos_field_for_connectivity) == 'pos') use_pos_is_pos = .true. - else - if (.not. assign_pointer(at, 'avgpos', use_pos)) then - RAISE_ERROR("calc_topology can't find default pos field avgpos", error) - endif - endif - - ! copy desired pos to pos, and new connectivity - !NB don't do if use_pos => pos - if (.not. use_pos_is_pos) at_copy%pos = use_pos - - if (do_add_silica_23body) then - call set_cutoff(at_copy,SILICA_2BODY_CUTOFF) - call calc_connect(at_copy, alt_connect=t_connect) - else - ! use hysteretic connect to get nearest neighbour cutoff - ! will use default cutoff, which is the same as heuristics_nneighb_only=.true. - call calc_connect_hysteretic(at, DEFAULT_NNEIGHTOL, DEFAULT_NNEIGHTOL, alt_connect=t_connect) - endif - - - call break_form_bonds(at, t_connect, form_bond, break_bond, error=error) - PASS_ERROR(error) - - ! now create labels using this connectivity object - ! if cutoff is set to 0, heuristics_nneighb_only doesn't matter - ! if cutoff is large, then heuristics_nneighb_only must be true - ! so might as well pass true - if (do_add_silica_23body) then - ! cutoff is large, must do heuristics_nneighb_only=.true., but EVB form bond won't work - call write_psf_file (at,psf_file,run_type_string,intrares_impropers,imp_filename,add_silica_23body,heuristics_nneighb_only=.true.,alt_connect=t_connect,& - remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) - else - ! cutoff is set to 0, all bonds are already heuristics_nneighb_only except extra EVB form_bond bonds - call write_psf_file (at,psf_file,run_type_string,intrares_impropers,imp_filename,add_silica_23body,heuristics_nneighb_only=.false.,alt_connect=t_connect,& - remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) - endif - PASS_ERROR(error) - call finalise(t_connect) - end subroutine write_psf_file_arb_pos - - !% Writes PSF topology file, to be used with the PDB coordinate file. - !% PSF contains the list of atoms, bonds, angles, impropers, dihedrals. - ! - subroutine write_psf_file(at,psf_file,run_type_string,intrares_impropers,imp_filename,add_silica_23body,heuristics_nneighb_only,alt_connect, & - remove_qmmm_link_bonds, run_suffix, error) - - character(len=*), intent(in) :: psf_file - type(atoms), intent(in) :: at - character(len=*), optional, intent(in) :: run_type_string - type(Table), optional, intent(in) :: intrares_impropers - character(80), optional, intent(in) :: imp_filename - logical, optional, intent(in) :: add_silica_23body - logical, intent(in), optional :: heuristics_nneighb_only - type(Connection), intent(in), optional, target :: alt_connect - character(len=*), optional, intent(in) :: run_suffix - logical, optional, intent(in) :: remove_qmmm_link_bonds - integer, intent(out), optional :: error - - type(Inoutput) :: psf - character(103) :: sor - character(*), parameter :: psf_format = '(I8,1X,A4,I5,1X,A4,1X,A4,1X,A4,1X,2G14.6,I8)' - character(*), parameter :: title_format = '(I8,1X,A)' - character(*), parameter :: int_format = 'I8' - integer :: mm, i - character(4) :: QM_prefix_atom_mol_name - character, dimension(:,:), pointer :: atom_type, atom_type_PDB, atom_res_name, atom_mol_name - integer, dimension(:), pointer :: atom_res_number - real(dp), dimension(:), pointer :: atom_charge - type(Table) :: bonds - type(Table) :: angles - type(Table) :: dihedrals, impropers - character(len=STRING_LENGTH) :: my_run_type_string - !integer :: run_type - logical :: do_add_silica_23body - - INIT_ERROR(error) - - call system_timer('write_psf_file_pos') - - !intraresidual impropers: table or read in from file - if (.not.present(intrares_impropers).and..not.present(imp_filename)) call print('WARNING!!! NO INTRARESIDUAL IMPROPERS USED!',verbosity=PRINT_ALWAYS) - if (present(imp_filename)) then - call system_abort('Not yet implemented.') - endif - - do_add_silica_23body = optional_default(.false.,add_silica_23body) - if (do_add_silica_23body) then !!xxx there must be a SIO2 residue? - if (at%cutoff.lt.SILICA_2BODY_CUTOFF) call system_abort('The connect cutoff '//at%cutoff//' is smaller than the required cutoff for silica. Cannot build connectivity to silica.') - endif - - my_run_type_string = optional_default('',run_type_string) -! if ((trim(my_run_type_string).eq.'QMMM_CORE') .or. & -! (trim(my_run_type_string).eq.'QMMM_EXTENDED')) then -! qm_flag_index = get_property(at,'cluster_mark') -! if (trim(my_run_type_string).eq.'QMMM_EXTENDED') run_type=QMMM_RUN_EXTENDED -! if (trim(my_run_type_string).eq.'QMMM_CORE') run_type=QMMM_RUN_CORE -! endif - if (.not. assign_pointer(at, 'atom_type', atom_type)) & - call system_abort('Cannot assign pointer to "atom_type" property.') - if (.not. assign_pointer(at, 'atom_type_PDB', atom_type_PDB)) & - call system_abort('Cannot assign pointer to "atom_type_PDB" property.') - if (.not. assign_pointer(at, 'atom_res_name', atom_res_name)) & - call system_abort('Cannot assign pointer to "atom_res_name" property.') - if (.not. assign_pointer(at, 'atom_mol_name', atom_mol_name)) & - call system_abort('Cannot assign pointer to "atom_mol_name" property.') - if (.not. assign_pointer(at, 'atom_res_number', atom_res_number)) & - call system_abort('Cannot assign pointer to "atom_res_numer" property.') - if (.not. assign_pointer(at, 'atom_charge', atom_charge)) & - call system_abort('Cannot assign pointer to "atom_charge" property.') - - call initialise(psf,trim(psf_file),action=OUTPUT) - call print(' PSF file: '//trim(psf%filename)) - - call print('PSF',file=psf) - call print('',file=psf) - - write(sor,title_format) 1,'!NTITLE' - call print(sor,file=psf) - write(sor,'(A)') ' PSF file generated by libAtoms -- http://www.libatoms.org' - call print(sor,file=psf) - call print('',file=psf) - - ! ATOM section - write(sor,title_format) at%N, '!NATOM' - call print(sor,file=psf) - do mm=1,at%N - QM_prefix_atom_mol_name = '' - QM_prefix_atom_mol_name = trim(a2s(atom_mol_name(:,mm))) -!does not work for contiguous molecules, e.g. silica -!!! if ((trim(my_run_type_string).eq.'QMMM_CORE') .or. & -!!! (trim(my_run_type_string).eq.'QMMM_EXTENDED')) then -!!! if (at%data%int(qm_flag_index,mm).ge.QMMM_RUN_CORE .and. at%data%int(qm_flag_index,mm).le.run_type) then -!!! QM_prefix_atom_mol_name = 'QM'//trim(at%data%str(atom_mol_name_index,mm)) -!!!! call print('QM molecule '//QM_prefix_atom_mol_name) -!!! endif -!!! endif -! call print('molecule '//QM_prefix_atom_mol_name) -! call print('writing PSF file: atom type '//at%data%str(atom_type_index,mm)) - write(sor,psf_format) mm, QM_prefix_atom_mol_name, atom_res_number(mm), & - trim(a2s(atom_res_name(:,mm))),trim(a2s(atom_type_PDB(:,mm))),trim(a2s(atom_type(:,mm))), & - atom_charge(mm),ElementMass(at%Z(mm))/MASSCONVERT,0 - call print(sor,file=psf) - enddo - call print('',file=psf) -call print('PSF| '//at%n//' atoms') - ! BOND section - call create_bond_list(at,bonds,do_add_silica_23body,heuristics_nneighb_only,alt_connect=alt_connect, & - remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) - if (any(bonds%int(1:2,1:bonds%N).le.0) .or. any(bonds%int(1:2,1:bonds%N).gt.at%N)) & - call system_abort('write_psf_file_pos: element(s) of bonds not within (0;at%N]') - call write_psf_section(data_table=bonds,psf=psf,section='BOND',int_format=int_format,title_format=title_format) -call print('PSF| '//bonds%n//' bonds') - - ! ANGLE section - call create_angle_list(at,bonds,angles,do_add_silica_23body,heuristics_nneighb_only,alt_connect=alt_connect, & - remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) - - if (any(angles%int(1:3,1:angles%N).le.0) .or. any(angles%int(1:3,1:angles%N).gt.at%N)) then - do i = 1, angles%N - if (any(angles%int(1:3,i).le.0) .or. any(angles%int(1:3,i).gt.at%N)) & - call print('angle: '//angles%int(1,i)//' -- '//angles%int(2,i)//' -- '//angles%int(3,i),verbosity=PRINT_ALWAYS) - enddo - call system_abort('write_psf_file_pos: element(s) of angles not within (0;at%N]') - endif - call write_psf_section(data_table=angles,psf=psf,section='THETA',int_format=int_format,title_format=title_format) -call print('PSF| '//angles%n//' angles') - - ! DIHEDRAL section - call create_dihedral_list(at,angles,dihedrals,do_add_silica_23body,heuristics_nneighb_only,alt_connect=alt_connect, & - remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) - if (any(dihedrals%int(1:4,1:dihedrals%N).le.0) .or. any(dihedrals%int(1:4,1:dihedrals%N).gt.at%N)) & - call system_abort('write_psf_file_pos: element(s) of dihedrals not within (0;at%N]') - call write_psf_section(data_table=dihedrals,psf=psf,section='PHI',int_format=int_format,title_format=title_format) -call print('PSF| '//dihedrals%n//' dihedrals') - - ! IMPROPER section - call create_improper_list(at,angles,impropers,intrares_impropers=intrares_impropers, & !why not alt_connect? - remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) - if (any(impropers%int(1:4,1:impropers%N).le.0) .or. any(impropers%int(1:4,1:impropers%N).gt.at%N)) & - call system_abort('write_psf_file_pos: element(s) of impropers not within (0;at%N]') - call write_psf_section(data_table=impropers,psf=psf,section='IMPHI',int_format=int_format,title_format=title_format) -call print('PSF| '//impropers%n//' impropers') - - !empty DON, ACC and NNB sections - write(sor,title_format) 0,'!NDON' - call print(sor,file=psf) - call print('',file=psf) - - write(sor,title_format) 0,'!NACC' - call print(sor,file=psf) - call print('',file=psf) - - write(sor,title_format) 0,'!NNB' - call print(sor,file=psf) - call print('',file=psf) - - call print('END',file=psf) - - call finalise(bonds) - call finalise(angles) - call finalise(dihedrals) - call finalise(impropers) - call finalise(psf) - - call system_timer('write_psf_file_pos') -!call print('psf written. stop.') -!stop - - end subroutine write_psf_file - - !% Writes a section of the PSF topology file. - !% Given a $section$ (name of the section) and a table $data_table$ with the data, - !% it writes them into $psf$ file with $int_format$ format. - !% Used by write_psf_file. - ! - subroutine write_psf_section(data_table,psf,section,int_format,title_format) - - type(Table), intent(in) :: data_table - type(InOutput), intent(in) :: psf - character(len=*), intent(in) :: section - character(*), intent(in) :: int_format - character(*), intent(in) :: title_format - - character(len=103) :: sor - integer :: mm, i, num_per_line - - if (.not.any(size(data_table%int,1).eq.(/2,3,4/))) & - call system_abort('data table to print into psf file has wrong number of integers '//size(data_table%int,1)) - if (size(data_table%int,1).eq.2) num_per_line = 4 - if (size(data_table%int,1).eq.3) num_per_line = 3 - if (size(data_table%int,1).eq.4) num_per_line = 2 - - sor = '' - write(sor,title_format) data_table%N, '!N'//trim(section) - call print(sor,file=psf) - - mm = 1 - do while (mm.le.(data_table%N-num_per_line+1-mod(data_table%N,num_per_line))) - select case(size(data_table%int,1)) - case(2) - write(sor,'(8'//trim(int_format)//')') & - data_table%int(1,mm), data_table%int(2,mm), & - data_table%int(1,mm+1), data_table%int(2,mm+1), & - data_table%int(1,mm+2), data_table%int(2,mm+2), & - data_table%int(1,mm+3), data_table%int(2,mm+3) - mm = mm + 4 - case(3) - write(sor,'(9'//trim(int_format)//')') & - data_table%int(1,mm), data_table%int(2,mm), data_table%int(3,mm), & - data_table%int(1,mm+1), data_table%int(2,mm+1), data_table%int(3,mm+1), & - data_table%int(1,mm+2), data_table%int(2,mm+2), data_table%int(3,mm+2) - mm = mm + 3 - case(4) - write(sor,'(8'//trim(int_format)//')') & - data_table%int(1,mm), data_table%int(2,mm), data_table%int(3,mm), data_table%int(4,mm), & - data_table%int(1,mm+1), data_table%int(2,mm+1), data_table%int(3,mm+1), data_table%int(4,mm+1) - mm = mm + 2 - end select - call print(sor,file=psf) - enddo - - ! mm = data_table%N - mod(data_table%N,num_per_line) + 1 - sor = '' - do i=1, mod(data_table%N,num_per_line) !if 0 then it does nothing - select case(size(data_table%int,1)) - case(2) - write(sor((i-1)*16+1:i*16),'(2'//trim(int_format)//')') data_table%int(1,mm), data_table%int(2,mm) - case(3) - write(sor((i-1)*24+1:i*24),'(3'//trim(int_format)//')') data_table%int(1,mm), data_table%int(2,mm), data_table%int(3,mm) - case(4) - write(sor((i-1)*32+1:i*32),'(4'//trim(int_format)//')') data_table%int(1,mm), data_table%int(2,mm), data_table%int(3,mm), data_table%int(4,mm) - end select - mm = mm + 1 - enddo - - if (mm .ne. data_table%N+1) call system_abort('psf writing: written '//(mm-1)//' of '//data_table%N) - if (mod(data_table%N,num_per_line).ne.0) call print(sor,file=psf) - call print('',file=psf) - - end subroutine write_psf_section - - !% Subroutine to create a $bonds$ table with all the nearest neighbour bonds - !% according to the connectivity. If $add_silica_23body$ is true, include - !% atom pairs that have SIO2 molecule type up to the silica_cutoff distance. - !% Optionally use hysteretic_connect, if it is passed as alt_connect. - ! - subroutine create_bond_list(at,bonds,add_silica_23body,heuristics_nneighb_only,alt_connect, & - remove_qmmm_link_bonds, run_suffix) - - type(Atoms), intent(in) :: at - type(Table), intent(out) :: bonds - logical, intent(in) :: add_silica_23body - logical, intent(in), optional :: heuristics_nneighb_only - type(Connection), intent(in), optional, target :: alt_connect - logical, intent(in), optional :: remove_qmmm_link_bonds - character(len=*), intent(in), optional :: run_suffix - - character(*), parameter :: me = 'create_bond_list: ' - - type(Table) :: atom_a,atom_b - integer :: i,j - integer :: atom_j -! logical :: do_qmmm -! integer,dimension(3) :: pos_indices -! integer :: qm_flag_index - character(STRING_LENGTH) :: my_run_suffix - character, pointer, dimension(:,:) :: atom_mol_name - integer, pointer, dimension(:) :: cluster_mark - logical :: add_bond, do_remove_qmmm_link_bonds - - call system_timer('create_bond_list') - - do_remove_qmmm_link_bonds = optional_default(.false., remove_qmmm_link_bonds) - my_run_suffix = optional_default('', run_suffix) - - if (do_remove_qmmm_link_bonds) then - call assign_property_pointer(at, 'cluster_mark'//trim(my_run_suffix), cluster_mark) - end if - - if (add_silica_23body) then - if (at%cutoff.lt.SILICA_2BODY_CUTOFF) call system_abort('The connect cutoff '//at%cutoff//' is smaller than the required cutoff for silica. Cannot build connectivity to silica.') - if (.not. assign_pointer(at, 'atom_mol_name', atom_mol_name)) & - call system_abort('Cannot assign pointer to "atom_mol_name" property.') - endif - call initialise(bonds,2,0,0,0,0) - -! do_qmmm = .true. -! if (get_value(at%properties,trim('QM_flag'),pos_indices)) then -! qm_flag_index = pos_indices(2) -! else -! do_qmmm = .false. -! end if -! - do i=1,at%N - call initialise(atom_a,4,0,0,0,0) - call append(atom_a,(/i,0,0,0/)) - if (add_silica_23body) then - call bfs_step(at,atom_a,atom_b,nneighb_only=.false.,min_images_only=.true.,alt_connect=alt_connect) ! SILICON_2BODY_CUTOFF is not within nneigh_tol - else - call bfs_step(at,atom_a,atom_b,nneighb_only=heuristics_nneighb_only,min_images_only=.true.,alt_connect=alt_connect) - endif - do j = 1,atom_b%N - atom_j = atom_b%int(1,j) - if (atom_j.gt.i) then -! ! QM core atoms should be isolated atoms -!!call print('atom '//i//' (QM flag '//at%data%int(qm_flag_index,i)//')') -!!call print('atom '//atom_j//' (QM flag '//at%data%int(qm_flag_index,atom_j)//')') -! -! if (do_qmmm) then -! if (any((/at%data%int(qm_flag_index,i),at%data%int(qm_flag_index,atom_j)/).eq.1)) then -!! call print('not added '//i//' (QM flag '//at%data%int(qm_flag_index,i)//') -- '//atom_j//' (QM flag '//at%data%int(qm_flag_index,atom_j)//')') -! cycle -! else -!! call print('added '//i//' (QM flag '//at%data%int(qm_flag_index,i)//') -- '//atom_j//' (QM flag '//at%data%int(qm_flag_index,atom_j)//')') -! endif -! endif - - add_bond = .true. - - if (add_silica_23body) then ! do not include H2O -- SiO2 bonds - if ( ((trim(a2s(atom_mol_name(:,atom_j))) .eq.'SIO2' .and. trim(a2s(atom_mol_name(:,i))).ne.'SIO2')) .or. & - ((trim(a2s(atom_mol_name(:,atom_j))) .ne.'SIO2' .and. trim(a2s(atom_mol_name(:,i))).eq.'SIO2')) ) then !silica -- something -!call system_abort('should have not got here') - !add only nearest neighbours - if (.not.(is_nearest_neighbour_abs_index(at,i,atom_j,alt_connect=alt_connect))) add_bond = .false. - elseif ((trim(a2s(atom_mol_name(:,atom_j))) .eq.'SIO2' .and. trim(a2s(atom_mol_name(:,i))).eq.'SIO2')) then !silica -- silica - !add atom pairs within SILICON_2BODY_CUTOFF -!call system_abort('what not?') - if (.not.are_silica_2body_neighbours(at,i,atom_j,alt_connect=alt_connect)) add_bond = .false. !SILICON_2BODY_CUTOFF for Si-Si and Si-O, nearest neighbours otherwise(Si-H,O-O,O-H,H-H) - else -!call system_abort('should have not got here') - !add only nearest neighbours - if (.not.(is_nearest_neighbour_abs_index(at,i,atom_j,alt_connect=alt_connect))) add_bond = .false. - endif - endif - - if (do_remove_qmmm_link_bonds) then - ! skip bond if it is a QM-MM link - if ((cluster_mark(i) == HYBRID_NO_MARK) .neqv. (cluster_mark(atom_j) == HYBRID_NO_MARK)) then - call print('create_bond_list: removing QM/MM link bond '//i//'--'//atom_j, PRINT_VERBOSE) - add_bond = .false. - end if - end if - - if (add_bond) then - call append(bonds,(/i,atom_j/)) - endif - - else -! call print('not added '//i//' -- '//atom_j) - endif - enddo - call finalise(atom_a) - call finalise(atom_b) - enddo - - if (any(bonds%int(1:2,1:bonds%N).le.0) .or. any(bonds%int(1:2,1:bonds%N).gt.at%N)) & - call system_abort('create_bond_list: element(s) of bonds not within (0;at%N]') - - call system_timer('create_bond_list') - - end subroutine create_bond_list - - - !% Test if atom $j$ is a neighbour of atom $i$ for the silica 2 body terms. - !% Optionally use hysteretic_connect, if it is passed as alt_connect. - !% - function are_silica_2body_neighbours(this,i,j,alt_connect) - - type(Atoms), intent(in), target :: this - integer, intent(in) :: i,j - type(Connection), intent(in), optional, target :: alt_connect - logical :: are_silica_2body_neighbours - - real(dp) :: d - integer :: neigh, Z_i, Z_j, j2 - - are_silica_2body_neighbours = .false. - - do neigh = 1, n_neighbours(this,i) - j2 = neighbour(this,i,neigh,distance=d,alt_connect=alt_connect) - if (j2.eq.j) then - Z_i = this%Z(i) - Z_j = this%Z(j) - if ( ((Z_i.eq.14).and.(Z_j.eq. 8)) .or. & !Si--O - ((Z_i.eq. 8).and.(Z_j.eq.14)) .or. & !O--Si - ((Z_i.eq. 8).and.(Z_j.eq. 8)) ) then !O--O - if (d < SILICA_2BODY_CUTOFF) & - are_silica_2body_neighbours = .true. - elseif ((Z_i.eq.14).and.(Z_j.eq.14)) then !Si--Si - if (d < SILICON_2BODY_CUTOFF) & - are_silica_2body_neighbours = .true. -!call print(i//'--'//j//': '//d//' < 2.8? '//are_silica_2body_neighbours) - else !Si--H, O--H, O--O, H--H - if (d < (bond_length(Z_i,Z_j)*this%nneightol)) & - are_silica_2body_neighbours = .true. -!call print(i//'--'//j//': '//d//' < nneigh_tol? '//are_silica_2body_neighbours) - endif - return - endif - enddo - - call system_abort('are_silica_2body_neighbours: atom '//j//'is not a neighbour of atom '//i) - - end function are_silica_2body_neighbours - - !% Test if atom $j$ is a nearest neighbour of atom $i$ for the silica 3 body terms. - !% Optionally use hysteretic_connect, if it is passed as alt_connect. - !% - function are_silica_nearest_neighbours(this,i,j,alt_connect) - - type(Atoms), intent(in), target :: this - integer, intent(in) :: i,j - type(Connection), intent(in), optional, target :: alt_connect - logical :: are_silica_nearest_neighbours - - real(dp) :: d - integer :: neigh, Z_i, Z_j, j2 - - are_silica_nearest_neighbours = .false. - - do neigh = 1, n_neighbours(this,i) - j2 = neighbour(this,i,neigh,distance=d,alt_connect=alt_connect) - if (j2.eq.j) then - Z_i = this%Z(i) - Z_j = this%Z(j) - if ( ((Z_i.eq.14).and.(Z_j.eq. 8)) .or. & !Si--O - ((Z_i.eq. 8).and.(Z_j.eq.14)) .or. & !O--Si - ((Z_i.eq.14).and.(Z_j.eq.14)) ) then !Si--Si - if (d < SILICON_2BODY_CUTOFF) & - are_silica_nearest_neighbours = .true. -!call print(i//'--'//j//': '//d//' < 2.8? '//are_silica_nearest_neighbours) - else !Si--H, O--H, O--O, H--H - if (d < (bond_length(Z_i,Z_j)*this%nneightol)) & - are_silica_nearest_neighbours = .true. -!call print(i//'--'//j//': '//d//' < nneigh_tol? '//are_silica_nearest_neighbours) - endif - return - endif - enddo - - call system_abort('are_silica_nearest_neighbours: atom '//j//'is not a neighbour of atom '//i) - - end function are_silica_nearest_neighbours - - !% Subroutine to create an $angles$ table with all the angles, - !% according to the connectivity nearest neighbours. If $add_silica_23body$ is true, include - !% atom triplets that have SIO2 molecule type and the distances are smaller than the cutoff - !% for the corresponding 3 body cutoff. - !% Optionally use hysteretic_connect if passed as alt_connect. - ! - subroutine create_angle_list(at,bonds,angles,add_silica_23body,heuristics_nneighb_only,alt_connect, & - remove_qmmm_link_bonds, run_suffix) - - type(Atoms), intent(in) :: at - type(Table), intent(in) :: bonds - type(Table), intent(out) :: angles - logical, intent(in) :: add_silica_23body - logical, intent(in), optional :: heuristics_nneighb_only - type(Connection), intent(in), optional, target :: alt_connect - logical, intent(in), optional :: remove_qmmm_link_bonds - character(len=*), intent(in), optional :: run_suffix - character(*), parameter :: me = 'create_angle_list: ' - integer, pointer, dimension(:) :: cluster_mark - - - integer :: i,j - type(Table) :: atom_a, atom_b - integer :: atom_j, atom_1, atom_2 - logical :: add_angle, do_remove_qmmm_link_bonds - character, pointer, dimension(:,:) :: atom_mol_name, atom_type - character(STRING_LENGTH) :: my_run_suffix - - call system_timer('create_angle_list') - - do_remove_qmmm_link_bonds = optional_default(.false., remove_qmmm_link_bonds) - my_run_suffix = optional_default('', run_suffix) - - if (do_remove_qmmm_link_bonds) then - call assign_property_pointer(at, 'cluster_mark'//trim(my_run_suffix), cluster_mark) - end if - - if (add_silica_23body) then - if (.not. assign_pointer(at, 'atom_type', atom_type)) & - call system_abort('Cannot assign pointer to "atom_type" property.') - if (.not. assign_pointer(at, 'atom_mol_name', atom_mol_name)) & - call system_abort('Cannot assign pointer to "atom_mol_name" property.') - endif - - call initialise(angles,3,0,0,0,0) - - do i=1,bonds%N - - atom_1 = bonds%int(1,i) - atom_2 = bonds%int(2,i) - - ! look for one more to the beginning: ??--1--2 where ??<2 - call initialise(atom_a,4,0,0,0,0) - call append(atom_a,(/atom_1,0,0,0/)) - - if (add_silica_23body) then -!call system_abort('stop!') - call bfs_step(at,atom_a,atom_b,nneighb_only=.false.,min_images_only=.true.,alt_connect=alt_connect) ! SILICON_2BODY_CUTOFF is not within nneigh_tol - else - call bfs_step(at,atom_a,atom_b,nneighb_only=heuristics_nneighb_only,min_images_only=.true.,alt_connect=alt_connect) - endif - - do j = 1,atom_b%N -!call print('atom '//j//' out of '//atom_b%N//' which is atom '//atom_j) - atom_j = atom_b%int(1,j) - if (atom_j.ge.atom_2) cycle - - add_angle = .true. - - if (add_silica_23body) then ! do not include H2O -- SiO2 bonds - if ( ((trim(a2s(atom_mol_name(:,atom_j))) .eq.'SIO2' .and. trim(a2s(atom_mol_name(:,atom_1))).ne.'SIO2')) .or. & - ((trim(a2s(atom_mol_name(:,atom_j))) .ne.'SIO2' .and. trim(a2s(atom_mol_name(:,atom_1))).eq.'SIO2')) ) then !silica -- something - !add only nearest neighbours - if (.not.(is_nearest_neighbour_abs_index(at,atom_1,atom_j,alt_connect=alt_connect))) add_angle = .false. - elseif ((trim(a2s(atom_mol_name(:,atom_j))) .eq.'SIO2' .and. trim(a2s(atom_mol_name(:,atom_1))).eq.'SIO2')) then !silica -- silica - !add atom pairs within SILICON_2BODY_CUTOFF - if (.not.are_silica_nearest_neighbours(at,atom_1,atom_j,alt_connect=alt_connect)) add_angle = .false. - - ! we kept 2.8 A cutoff for Si-Si and 5.5 A for Si-O and O-O: reduce it to 2.6 for Si-O-Si, O-Si-O, Si-O-H - if (add_angle) then - if (any(at%Z(atom_j)*1000000+at%Z(atom_1)*1000+at%Z(atom_2).eq.(/14008014,8014008,14008001,1008014/))) then - add_angle = (distance_min_image(at,atom_j,atom_1).le.SILICA_3BODY_CUTOFF).and. & - (distance_min_image(at,atom_1,atom_2).le.SILICA_3BODY_CUTOFF) - elseif (any(at%Z(atom_j)*1000000+at%Z(atom_1)*1000+at%Z(atom_2).eq.(/14008008,8008014,1008008,8008001,8008008/))) then - add_angle = .false. - endif - endif - else !something -- something, neither are silica - !add only nearest neighbours - if (.not.(is_nearest_neighbour_abs_index(at,atom_1,atom_j,alt_connect=alt_connect))) add_angle = .false. - endif - endif - - if (do_remove_qmmm_link_bonds) then - ! skip angle if it spans the QM-MM boundary - if ( .not. (all(cluster_mark( (/atom_j, atom_1, atom_2/) ) == HYBRID_NO_MARK) .or. & - all(cluster_mark( (/atom_j, atom_1, atom_2/) ) /= HYBRID_NO_MARK))) then - call print('create_angle_list: removing QM/MM spanning angle '//(/atom_j, atom_1, atom_2/), PRINT_VERBOSE) - add_angle = .false. - end if - end if - -! if (add_angle.and.(atom_j.lt.atom_2)) & - if (add_angle) & !.and.(atom_j.lt.atom_2)) & - call append(angles,(/atom_j,atom_1,atom_2/)) - - enddo - - call finalise(atom_a) - call finalise(atom_b) - - ! look for one more to the end: 1--2--?? where 1= 1) .and. all(form_bond <= at%N)) then - bond_exists = .false. - do ji=1, n_neighbours(at, form_bond(1), alt_connect=conn) - j = neighbour(at, form_bond(1), ji, shift=shift, alt_connect=conn) - if (j == form_bond(2)) then - bond_exists = .true. - exit - endif - end do - if (.not. bond_exists) then - form_bond_dist = distance_min_image(at, form_bond(1), form_bond(2), shift=shift) - call add_bond(conn, at%pos, at%lattice, form_bond(1), form_bond(2), shift, form_bond_dist, error=error) - PASS_ERROR(error) - endif - endif ! valid atom #s - endif ! present(form_bond) - if (present(break_bond)) then - if (all(break_bond >= 1) .and. all(break_bond <= at%N)) then - bond_exists = .false. - do ji=1, n_neighbours(at, break_bond(1), alt_connect=conn) - j = neighbour(at, break_bond(1), ji, shift=shift, alt_connect=conn) - if (j == break_bond(2)) then - bond_exists = .true. - exit - endif - end do - if (bond_exists) then - call remove_bond(conn, break_bond(1), break_bond(2), shift, error=error) - PASS_ERROR(error) - endif - endif ! valid atom #s - endif ! present(break_bond) - end subroutine break_form_bonds - - function find_motif_backbone(motif, is_proline) result(backbone) - integer :: motif(:,:) - logical :: is_proline - integer :: backbone(5,3) - - integer :: i, ji, j, ki, k, li, l, mi, m, ii, ni, n, found_N, found_aC, found_cC - - is_proline = .false. - - backbone = 0 - do i=1, size(motif,1) ! look for N -!call print("check atom i " //i // " Z=" // motif(i,1)) - if (motif(i,1) /= 7) cycle - ! i is an N - found_N = i -!call print("atom i is a N, continuing") - do ji=2, size(motif,2) ! look for alpha-C - j=motif(i,ji); if (j == 0) exit -!call print("check atom j "//j//" Z=" // motif(j,1)) - if (motif(j,1) == 6) then ! j is a possible alpha-C -!call print("atom j is a C, continuing") - found_aC = j - do ki=2, size(motif,2) ! look for possible carboxyl-C - k = motif(j,ki); if (k == 0) exit -!call print("check atom k " //k//" Z=" // motif(k,1)) - if (motif(k,1) == 6) then ! k is a possible carboxyl-C -!call print("atom k is a C, continuing") - found_cC = k - do li=2, size(motif,2) ! loook for possible carboxyl-O - l = motif(k, li); if (l == 0) exit -!call print("check atom l "//l//" Z=" // motif(l,1)) - if (motif(l,1) == 8 .and. count(motif(l,2:) /= 0) == 1) then ! found carboxyl O -!call print("atom l is an O with coord 1, continuing") - - ii = 1 - backbone(ii,1) = found_N - do mi=2, size(motif,2) ! find neighbours of N for backbone - m = motif(found_N, mi); if (m == 0) exit -!call print("neighbor m " // m // " Z="//motif(m,1)// " neighbor of N") - if (m == found_aC) cycle - if (motif(m,1) == 1) then -!call print("neighbor m is a H, adding to backbone") - ii = ii + 1 - backbone(ii,1) = m - else if (motif(m,1) == 6) then - is_proline = .true. - else - call print("find_motif_backbone confused by neighbor of N", PRINT_VERBOSE) - backbone = 0 - return - endif - end do ! mi - - ii = 1 - backbone(ii,2) = found_aC - do mi=2, size(motif,2) ! find neighbours of alpha-C for backbone - m = motif(found_aC, mi); if (m == 0) exit -!call print("neighbor m " // m // " Z="//motif(m,1)// " neighbor of alpha-C") - if (m == found_N .or. m == found_cC) cycle - if (motif(m,1) == 1) then -!call print("neighbor m is a H, adding to backbone") - ii = ii + 1 - backbone(ii,2) = m - else if (motif(m,1) /= 6) then - call print("find_motif_backbone confused by neighbor of alpha-C, neither H or C", PRINT_VERBOSE) - backbone = 0 - return - endif - end do ! mi - - ii = 1 - backbone(ii,3) = found_cC - do mi=2, size(motif,2) ! find neighbours of carboxyl-C for backbone - m = motif(found_cC, mi); if (m == 0) exit -!call print("neighbor m " // m // " Z="//motif(m,1)// " neighbor of carboxyl-C") - if (m == found_aC) cycle - if (motif(m,1) == 8) then -!call print("neighbor m is an O, adding to backbone") - ii = ii + 1 - backbone(ii,3) = m - do ni=2, size(motif,2) ! look for OH - n = motif(m, ni); if (n == 0) exit - if (n == found_cC) cycle -!call print("neighbor n " // n // " Z="//motif(n,1)// " neighbor of carboxyl-C-O") - if (motif(n,1) == 1) then -!call print("neighbor n is an H, adding to backbone") - ii = ii + 1 - backbone(ii,3) = n - else - call print("find_motif_backbone confused by non-H neighbor of carboxyl-O", PRINT_VERBOSE) - backbone = 0 - return - endif - end do - else - call print("find_motif_backbone confused by neighbor of carboxyl-C", PRINT_VERBOSE) - backbone = 0 - return - endif - end do ! mi - endif ! found carboxyl O - end do ! li - endif ! carboxyl-C - end do ! ki - endif ! found alpha C - end do ! ji - end do ! i - end function find_motif_backbone - - subroutine find_general_monomer(at,monomer_index,signature,is_associated,cutoff,general_ordercheck,error) - type(atoms), intent(in) :: at - integer, intent(in), dimension(:) :: signature - real(dp), dimension(:), allocatable :: r - real(dp) :: r_ij, cutoff - integer, dimension(1) :: temp - integer, dimension(:), allocatable :: indices - integer, dimension(:,:), allocatable :: monomer_index, monomer_index_working - integer, intent(out), optional :: error - logical, optional :: general_ordercheck - integer :: i, j, k, n, Z_uniq_index, Z_uniq, Z_uniq_pos, monomers_found - logical, dimension(:), intent(inout) :: is_associated - logical :: do_general_ordercheck - - do_general_ordercheck = optional_default(.true.,general_ordercheck) - - allocate(monomer_index(size(signature),0)) - allocate(monomer_index_working(size(signature),0)) - allocate(r(size(signature))) - allocate(indices(size(signature))) - - monomers_found = 0 - if(do_general_ordercheck) then - do i = 1, at%N - if(.not. is_associated(i) .and. any(signature .eq. at%Z(i))) then - if (at%Z(i) == 1) cycle ! for now, don't let H be at the centre of a monomer - - r = cutoff ! initialise distances - indices = 0 ! initialise indices - temp = minloc(signature, signature .eq. at%Z(i)) ! will return location of first element of signature with correct Z - indices(temp(1))=i - r(temp(1))=0.0 - - do n = 1, n_neighbours(at, i) - j = neighbour(at, i, n, distance=r_ij) - if(is_associated(j) .or. .not. any(signature .eq. at%Z(j)) ) cycle - - do k=1,maxval(signature) - if (at%Z(j) .eq. k) then - if(r_ij .lt. maxval(r, mask = signature .eq. at%Z(j)) ) then - temp = maxloc(r, mask = signature .eq. at%Z(j)) - r(temp(1)) = r_ij - indices(temp(1)) = j - exit - end if - end if - end do - end do - - if(any(indices .eq. 0)) cycle ! couldn't make a monomer with i as central atom - - monomers_found = monomers_found + 1 ! number of monomers found so far - do k=1,size(signature) - is_associated(indices(k))=.true. - end do - - deallocate(monomer_index_working) - allocate(monomer_index_working(size(monomer_index,1),size(monomer_index,2))) - monomer_index_working =monomer_index - deallocate(monomer_index) - allocate(monomer_index(size(monomer_index_working,1),size(monomer_index_working,2)+1)) - monomer_index(:,:monomers_found-1) = monomer_index_working - monomer_index(:,monomers_found) = indices - end if - end do - else ! do_general_ordercheck = .false. - n = size(signature) - do i = 1, at%N-n+1 - if(.not. any(is_associated(i:i+n-1)) .and. all(signature(:) .eq. at%Z(i:i+n-1))) then - monomers_found = monomers_found + 1 ! number of monomers found so far - indices = (/(i+k, k=0,n-1)/) - is_associated(i:i+n-1) = .true. - - deallocate(monomer_index_working) - allocate(monomer_index_working(size(monomer_index,1), size(monomer_index,2))) - monomer_index_working = monomer_index - deallocate(monomer_index) - allocate(monomer_index(size(monomer_index_working,1), size(monomer_index_working,2)+1)) - monomer_index(:,:monomers_found-1) = monomer_index_working - monomer_index(:,monomers_found) = indices - end if - enddo - end if ! do_general_ordercheck - - deallocate(monomer_index_working) - deallocate(r) - deallocate(indices) - - end subroutine find_general_monomer - - subroutine find_monomer_pairs(at_in,monomer_pairs,mean_pos_diffs,pairs_diffs_map,monomer_one_index,monomer_two_index,monomers_identical,double_count,cutoff,pairs_shifts,error,use_com) - ! finds pairs of monomers combined into dimer if *any pair* of atoms are within cutoff. Returns 2 by n array of pairs, - ! the elements of which refer to the second index of the monomer_one_index and monomer_two_index matrices respectively. - ! also returns a set of diffs, which are vectors between the mean positions of the shifted versions of these pairs. - type(atoms), intent(in) :: at_in - integer, dimension(:,:), allocatable, intent(out) :: monomer_pairs - real(dp),dimension(:,:), allocatable, intent(out) :: mean_pos_diffs - integer, dimension(:), allocatable, intent(out) :: pairs_diffs_map - integer, intent(in), dimension(:,:) :: monomer_one_index, monomer_two_index - logical, intent(in) :: monomers_identical, double_count - real(dp), intent(in) :: cutoff - integer, dimension(:,:), allocatable, intent(out), optional :: pairs_shifts - integer, intent(out), optional :: error - logical, intent(in), optional :: use_com - - type(atoms) :: at - integer, dimension(:,:), allocatable :: mean_pos_shifts - integer, dimension(:), allocatable :: atomic_index_one, atomic_index_two - integer :: i, j, i_atomic, j_atomic, n, i_neighbour, i_desc, k, m, n_pairs,monomer_one_size ,monomer_two_size,rep,n_repeats - real(dp) :: r_one_two, mass_one, mass_two, temp_dist,min_dist - - real(dp), dimension(3) :: diff_one_two, mean_pos_one, mean_pos_two ! unweighted mean position of atoms in monomer, if monomer straddles cell boundary this will be in the middle of the cell - integer, dimension(3) :: shift_one_two, shift_one, shift_two,min_image_shift - integer, dimension(2) :: temp2d - integer, dimension(1) :: temp1d - logical, dimension(:), allocatable :: shifts_mask - logical :: do_use_com - - do_use_com = optional_default(.false., use_com) - - ! make a copy of the atoms object - at = at_in - call set_cutoff(at,cutoff+0.5_dp) - call calc_connect(at) - - allocate(monomer_pairs(2,0)) - allocate(mean_pos_shifts(3,0)) - allocate(mean_pos_diffs(3,0)) - allocate(pairs_diffs_map(0)) - allocate(shifts_mask(0)) - - monomer_one_size = size(monomer_one_index,1) - monomer_two_size = size(monomer_two_index,1) - - allocate(atomic_index_one(monomer_one_size)) - allocate(atomic_index_two(monomer_two_size)) - - i_desc=0 - n_pairs=0 - - ! loop over all occurences of first monomer - loop_monomer_one: do i=1,size(monomer_one_index,2) - atomic_index_one = monomer_one_index(:,i) - if (do_use_com) then - mean_pos_one = centre_of_mass(at,index_list=atomic_index_one) - else - mean_pos_one = calc_mean_pos(at,atomic_index_one) - endif - - !loop over neighbours of each atom, check at least one pair of heavy atoms within cutoff and belong to an occurrence of monomer_two - loop_monomer_one_atoms: do i_atomic=1,size(monomer_one_index,1) - if (at%Z(atomic_index_one(i_atomic)) == 1) cycle ! skip hydrogens - - loop_monomer_one_atom_neighbours: do n = 1, n_neighbours(at,atomic_index_one(i_atomic)) - - i_neighbour = neighbour(at,atomic_index_one(i_atomic),n,distance=r_one_two,shift=shift_one_two) - if (at%Z(i_neighbour) == 1 ) cycle ! skip hydrogens - if( r_one_two >= cutoff ) cycle - temp2d = maxloc(monomer_two_index, monomer_two_index .eq. i_neighbour) - if (any(temp2d .eq. 0)) cycle ! atom i_neighbour does not belong to the type of monomer we're looking for - j = temp2d(2) ! atom i_neighbour belongs to monomer j - atomic_index_two = monomer_two_index(:,j) - if (do_use_com) then - mean_pos_two = centre_of_mass(at,index_list=atomic_index_two) - else - mean_pos_two = calc_mean_pos(at,atomic_index_two) - endif - - temp_dist = distance_min_image(at,i_neighbour,mean_pos_two,shift=shift_two) - shift_one_two = shift_one_two + shift_two - - ! get the diff vector between the shifted mean positions - min_dist = distance_min_image(at,mean_pos_one,mean_pos_two,shift=min_image_shift) - diff_one_two = diff_min_image(at,mean_pos_one,mean_pos_two) + matmul(at%lattice,shift_one_two-min_image_shift) - - ! this makes sure we don't double count. All monomer pairs in the unit cell are found, - ! as are half of the monomer pairs in which one of the monomers is from a neighbour cell - are_monomers_identical: if (monomers_identical) then - if (all(shift_one_two .eq. 0)) then - if (i .ge. j) cycle - else - if (i .gt. j) cycle - if (i == j) then - temp1d = maxloc(monomer_pairs(1,:), monomer_pairs(1,:) .eq. i .and. monomer_pairs(2,:) .eq. i) - k=temp1d(1) - if (k > 0) then - shifts_mask =(/ mean_pos_shifts(1,:) .eq. -shift_one_two(1)/) .and. & - (/ mean_pos_shifts(2,:) .eq. -shift_one_two(2)/) .and. & - (/ mean_pos_shifts(3,:) .eq. -shift_one_two(3)/) - if (count( (/pairs_diffs_map .eq. k /) .and. shifts_mask) > 0) cycle ! cycle if negative shift already present - end if - end if - end if - end if are_monomers_identical - - ! check if this combination of monomers was already found - temp1d = maxloc(monomer_pairs(1,:), monomer_pairs(2,:) .eq. j .and. monomer_pairs(1,:) .eq. i) - k=temp1d(1) ! if so, pair is at (:,k) in the monomer_pairs array , else equals 0 - - if (k > 0 ) then ! have found this pair before - shifts_mask =(/ mean_pos_shifts(1,:) .eq. shift_one_two(1)/) .and. & - (/ mean_pos_shifts(2,:) .eq. shift_one_two(2)/) .and. & - (/ mean_pos_shifts(3,:) .eq. shift_one_two(3)/) - if (count( (/pairs_diffs_map .eq. k/) .and. shifts_mask) > 0) cycle ! cycle if we've already found this pair with this shift - - else ! new pair - n_pairs = n_pairs + 1 - call reallocate(monomer_pairs,2,n_pairs,copy=.true.) - monomer_pairs(:,n_pairs) = (/ i,j /) - k=n_pairs - end if - - n_repeats = 1 - if (double_count) n_repeats = 2 - do rep=1,n_repeats ! save this shift, possibly twice if we're double-counting - i_desc = i_desc + 1 - call reallocate(mean_pos_shifts,3,i_desc,copy=.true.) - call reallocate(mean_pos_diffs,3,i_desc,copy=.true.) - call reallocate(pairs_diffs_map,i_desc,copy=.true.) - call reallocate(shifts_mask,i_desc) - mean_pos_shifts(:,i_desc) = shift_one_two - mean_pos_diffs(:,i_desc) = diff_one_two - pairs_diffs_map(i_desc) = k - end do - - end do loop_monomer_one_atom_neighbours - end do loop_monomer_one_atoms - end do loop_monomer_one - - if (present(pairs_shifts)) then - allocate(pairs_shifts(3,size(mean_pos_shifts,2))) - pairs_shifts = mean_pos_shifts - end if - call finalise(at) - deallocate(mean_pos_shifts) - deallocate(atomic_index_one) - deallocate(atomic_index_two) - deallocate(shifts_mask) - - end subroutine find_monomer_pairs - - subroutine find_monomer_pairs_MPI(at,monomer_pairs,mean_pos_diffs,pairs_diffs_map,monomer_one_index,monomer_two_index,monomers_identical,double_count,cutoff,pairs_shifts,error,use_com,atom_mask) - ! finds pairs of monomers combined into dimer if the centers of mass (use_com=T)/geometry(F) are within cutoff. - ! (currently loops over all monomers, and doesn't take into account - ! interactions with mirror images) - ! Optionally takes atom_mask for use in MPI parallelisation, only looks for dimers whose first monomer is captured by the atom mask. - ! Returns dimers in ascending order of monomer index (hence no double-counting). - ! Returns 2 by n array of pairs, - ! the elements of which refer to the second index of the monomer_one_index and monomer_two_index matrices respectively. - ! also returns a set of diffs, which are vectors between the mean positions of the shifted versions of these pairs. - type(atoms), intent(in) :: at - integer, dimension(:,:), allocatable, intent(out) :: monomer_pairs ! 2 x n: (index into monomer_one_index, index into monomer_two_index) - real(dp),dimension(:,:), allocatable, intent(out) :: mean_pos_diffs ! - integer, dimension(:), allocatable, intent(out) :: pairs_diffs_map - integer, intent(in), dimension(:,:) :: monomer_one_index, monomer_two_index - logical, intent(in) :: monomers_identical, double_count - real(dp), intent(in) :: cutoff - integer, dimension(:,:), allocatable, intent(out), optional :: pairs_shifts - integer, intent(out), optional :: error - logical, intent(in), optional :: use_com - logical, dimension(:), intent(in), optional :: atom_mask - - integer, dimension(:,:), allocatable :: mean_pos_shifts - integer, dimension(:), allocatable :: atomic_index_one, atomic_index_two - integer :: i, j, i_atomic, j_atomic, n, i_neighbour, i_desc, k, m, n_pairs,monomer_one_size ,monomer_two_size,rep,n_repeats - real(dp) :: r_one_two, mass_one, mass_two, temp_dist,min_dist - - real(dp), dimension(3) :: diff_one_two, mean_pos_one, mean_pos_two ! unweighted mean position of atoms in monomer, if monomer straddles cell boundary this will be in the middle of the cell - integer, dimension(3) :: shift_one_two, shift_one, shift_two,min_image_shift - integer, dimension(2) :: temp2d - integer, dimension(1) :: temp1d - logical :: do_use_com - - real(dp), dimension(3) :: n1, n2, n3 - real(dp) :: w1, w2, w3 - - do_use_com = optional_default(.false., use_com) - - n1 = at%lattice(:,1) .cross. at%lattice(:,2) - w1 = abs(n1 .dot. at%lattice(:,3)) / norm(n1) - n2 = at%lattice(:,2) .cross. at%lattice(:,3) - w2 = abs(n2 .dot. at%lattice(:,1)) / norm(n2) - n3 = at%lattice(:,3) .cross. at%lattice(:,1) - w3 = abs(n3 .dot. at%lattice(:,2)) / norm(n3) - if (2*cutoff .ge. min(w1, w2, w3)) then - RAISE_ERROR("find_monomer_pairs_MPI: only implemented for cutoff less than half the smallest box width",error) - endif - - allocate(monomer_pairs(2,0)) - allocate(mean_pos_shifts(3,0)) - allocate(mean_pos_diffs(3,0)) - allocate(pairs_diffs_map(0)) - - monomer_one_size = size(monomer_one_index,1) - monomer_two_size = size(monomer_two_index,1) - - allocate(atomic_index_one(monomer_one_size)) - allocate(atomic_index_two(monomer_two_size)) - - i_desc=0 - n_pairs=0 - - ! loop over all occurences of first monomer - loop_monomer_one: do i=1,size(monomer_one_index,2) - atomic_index_one = monomer_one_index(:,i) - - if(present(atom_mask)) then - if (.not. any(atom_mask(atomic_index_one))) then - cycle - else - if(.not. all(atom_mask(atomic_index_one))) then - RAISE_ERROR("find_monomer_pairs_MPI: atom mask has to encompass either all or none of the atoms of monomer one",error) - endif - endif - endif - - if (do_use_com) then - mean_pos_one = centre_of_mass(at,index_list=atomic_index_one) - else - mean_pos_one = calc_mean_pos(at,atomic_index_one) - endif - - loop_monomer_two: do j=1,size(monomer_two_index,2) - atomic_index_two = monomer_two_index(:,j) - - if (monomers_identical .and. i == j) cycle - - ! could instead try to find which monomers are within cutoff instead of - ! looping over all of them - ! a) going back to some atom-based measure - ! b) implementing connectivity for molecule COMs? - - if (monomers_identical .and. i > j) cycle - ! only keep monomers for which i cutoff) cycle - - diff_one_two = diff_min_image(at,mean_pos_one,mean_pos_two) - - n_pairs = n_pairs + 1 - call reallocate(monomer_pairs,2,n_pairs,copy=.true.) - monomer_pairs(:,n_pairs) = (/ i,j /) - k=n_pairs - - i_desc = i_desc + 1 - call reallocate(mean_pos_shifts,3,i_desc,copy=.true.) - call reallocate(mean_pos_diffs,3,i_desc,copy=.true.) - call reallocate(pairs_diffs_map,i_desc,copy=.true.) - mean_pos_shifts(:,i_desc) = shift_one_two - mean_pos_diffs(:,i_desc) = diff_one_two - pairs_diffs_map(i_desc) = k - - end do loop_monomer_two - end do loop_monomer_one - - if (present(pairs_shifts)) then - allocate(pairs_shifts(3,size(mean_pos_shifts,2))) - pairs_shifts = mean_pos_shifts - end if - - deallocate(mean_pos_shifts) - deallocate(atomic_index_one) - deallocate(atomic_index_two) - end subroutine find_monomer_pairs_MPI - - subroutine find_monomer_triplets_MPI(at,monomer_triplets,triplets_diffs,triplets_diffs_map,monomer_one_index,monomer_two_index,monomer_three_index,one_two_identical,one_three_identical,two_three_identical,cutoff,error,use_com,atom_mask) - ! loops through pairs of monomers made by find_monomer_pairs above and makes trimers if a third monomer is within cutoff. Returns 3 by n array, - ! returns trimers in ascending order of monomer index (hence no double-counting) - ! the elements of which refer to the second index of the monomer_{one,two,three}_index matrices. - ! the columns of triplets shifts are (k,shift_one_two,shift_one_three), where k refers to a column of monomer_triplets and the shifts correspond to a set of periodic images which are within cutoff. - type(atoms), intent(in) :: at - integer, dimension(:,:), intent(out), allocatable :: monomer_triplets - real(dp), dimension(:,:), intent(out), allocatable :: triplets_diffs - integer, dimension(:), intent(out), allocatable :: triplets_diffs_map - integer, intent(in), dimension(:,:) :: monomer_one_index, monomer_two_index, monomer_three_index - logical, intent(in) :: one_two_identical,one_three_identical, two_three_identical - real(dp), intent(in) :: cutoff - integer, intent(out), optional :: error - logical, intent(in), optional :: use_com - logical, dimension(:), intent(in), optional :: atom_mask - - integer, dimension(:,:), allocatable :: pairs_one_two, pairs_one_three,shifts_one_two,shifts_one_three,triplets_shifts - real(dp), dimension(:,:), allocatable :: diffs_one_two,diffs_one_three - integer, dimension(:), allocatable :: map_one_two, map_one_three - integer :: i, j, k,pos_ij,pos_ik,pos_jk,i_map,i_desc - real(dp) :: dist, pairwise_cutoff,min_dist - - real(dp), dimension(3) :: diff_ij,diff_ik,diff_jk, min_distances - integer, dimension(3) :: shift_ij, shift_ik, shift_jk - integer, dimension(1) :: temp1d - logical :: double_count - - double_count=.false. - pairwise_cutoff = 2.0_dp*cutoff+ 0.1_dp ! plenty big to find all relevant dimers - - call find_monomer_pairs_MPI(at,pairs_one_two, diffs_one_two, map_one_two, monomer_one_index,monomer_two_index ,one_two_identical ,double_count,pairwise_cutoff,shifts_one_two ,error,use_com,atom_mask) - call find_monomer_pairs_MPI(at,pairs_one_three,diffs_one_three,map_one_three,monomer_one_index,monomer_three_index,one_three_identical,double_count,pairwise_cutoff,shifts_one_three,error,use_com,atom_mask) - ! could save by re-using results if one_two_identical .and. one_three_identical - ! for any equivalent monomer types we have to append the negative self-pairs since these are excluded by find_monomer_pairs - - if (.not. allocated(monomer_triplets)) allocate(monomer_triplets(3,0)) - if (.not. allocated(triplets_diffs)) allocate(triplets_diffs(6,0)) - if (.not. allocated(triplets_diffs_map)) allocate(triplets_diffs_map(0)) - if (.not. allocated(triplets_shifts)) allocate(triplets_shifts(6,0)) - - !! make triplets - do pos_ij=1,size(map_one_two) ! loop over pairs (i,j) of 1 and 2 - i=pairs_one_two( 1, map_one_two(pos_ij) ) - j=pairs_one_two( 2, map_one_two(pos_ij) ) - if (one_two_identical .and. i >= j) cycle - diff_ij = diffs_one_two(:,pos_ij) - shift_ij = shifts_one_two(:,pos_ij) - - do pos_ik=1,size(map_one_three) ! loop over monomers k of type 3 also paired with i - if (i /= pairs_one_three( 1, map_one_three(pos_ik) ) ) cycle - - k = pairs_one_three( 2 , map_one_three(pos_ik) ) - - if (one_three_identical .and. i >= k) cycle - if (two_three_identical .and. j >= k) cycle - - diff_ik = diffs_one_three(:,pos_ik) - shift_ik = shifts_one_three(:,pos_ik) - - diff_jk = diff_ik - diff_ij - shift_jk = shift_ik - shift_ij - - ! check that is a valid triplet - i.e. two sides of the triangle are within cutoff length - ! based on COM/COG distance between each monomer pair - min_distances = (/ norm(diff_ij), norm(diff_ik), norm(diff_jk) /) - if ( count(min_distances .gt. cutoff) .gt. 1 ) cycle - - call add_triplet_MPI(monomer_triplets,triplets_diffs,triplets_diffs_map,triplets_shifts,i,j,k,diff_ij,diff_ik,shift_ij,shift_ik,two_three_identical) - end do - end do - deallocate(pairs_one_two) - deallocate(shifts_one_two) - deallocate(diffs_one_two) - deallocate(pairs_one_three) - deallocate(shifts_one_three) - deallocate(diffs_one_three) - if(allocated(triplets_shifts)) deallocate(triplets_shifts) - end subroutine find_monomer_triplets_MPI - subroutine add_triplet_MPI(monomer_triplets,triplets_diffs,triplets_diffs_map,triplets_shifts,i,j,k,diff_ij,diff_ik,shift_ij,shift_ik,two_three_identical) - ! this also excludes the case where the and three identical and this pair was already found in the opposite order - integer, dimension(:,:), intent(inout), allocatable :: monomer_triplets - real(dp), dimension(:,:), intent(inout), allocatable :: triplets_diffs - integer, dimension(:), intent(inout), allocatable :: triplets_diffs_map - integer, dimension(:,:), intent(inout), allocatable :: triplets_shifts - integer, intent(in) :: i,j,k - real(dp), dimension(3),intent(in) :: diff_ij,diff_ik - integer, dimension(3),intent(in) :: shift_ij,shift_ik - logical, intent(in) :: two_three_identical - - integer, dimension(3) :: triplet - logical, dimension(:), allocatable :: shift_mask - integer, dimension(1):: temp1d - integer :: pos_ijk, pos_ikj,n_triplets,n_shifts - logical :: do_append - - if (.not. allocated(monomer_triplets)) allocate(monomer_triplets(3,0)) - if (.not. allocated(triplets_diffs)) allocate(triplets_diffs(6,0)) - if (.not. allocated(triplets_diffs_map)) allocate(triplets_diffs_map(0)) - if (.not. allocated(triplets_shifts)) allocate(triplets_shifts(6,0)) - - n_triplets = size(monomer_triplets,2) - n_shifts = size(triplets_diffs_map) - triplet = (/i,j,k/) - - n_triplets = n_triplets + 1 - call reallocate(monomer_triplets,3,n_triplets,copy=.true.) - monomer_triplets(:,n_triplets) = triplet - pos_ijk = n_triplets - - n_shifts = n_shifts + 1 - call reallocate(triplets_shifts,6,n_shifts,copy=.true.) - call reallocate(triplets_diffs,6,n_shifts,copy=.true.) - call reallocate(triplets_diffs_map,n_shifts,copy=.true.) - triplets_shifts(:,n_shifts) = (/shift_ij,shift_ik/) - triplets_diffs(:,n_shifts) = (/diff_ij,diff_ik/) - triplets_diffs_map(n_shifts) = pos_ijk - end subroutine add_triplet_MPI - - subroutine find_monomer_triplets(at,monomer_triplets,triplets_diffs,triplets_diffs_map,monomer_one_index,monomer_two_index,monomer_three_index,one_two_identical,one_three_identical,two_three_identical,cutoff,error) - ! loops through pairs of monomers made by find_monomer_pairs above and makes trimers if a third monomer is within cutoff. Returns 3 by n array, - ! the elements of which refer to the second index of the monomer_{one,two,three}_index matrices. - ! the columns of triplets shifts are (k,shift_one_two,shift_one_three), where k refers to a column of monomer_triplets and the shifts correspond to a set of periodic images which are within cutoff. - type(atoms), intent(in) :: at - integer, dimension(:,:), intent(out), allocatable :: monomer_triplets - real(dp), dimension(:,:), intent(out), allocatable :: triplets_diffs - integer, dimension(:), intent(out), allocatable :: triplets_diffs_map - integer, intent(in), dimension(:,:) :: monomer_one_index, monomer_two_index, monomer_three_index - logical, intent(in) :: one_two_identical,one_three_identical, two_three_identical - real(dp), intent(in) :: cutoff - integer, intent(out), optional :: error - - integer, dimension(:,:), allocatable :: pairs_one_two, pairs_one_three,shifts_one_two,shifts_one_three,triplets_shifts - real(dp), dimension(:,:), allocatable :: diffs_one_two,diffs_one_three - integer, dimension(:), allocatable :: map_one_two, map_one_three - integer :: i, j, k,pos_ij,pos_ik,pos_jk,i_map,i_desc - real(dp) :: dist, pairwise_cutoff,min_dist - - real(dp), dimension(3) :: diff_ij,diff_ik,diff_jk, min_distances - integer, dimension(3) :: shift_ij, shift_ik, shift_jk - integer, dimension(1) :: temp1d - logical :: double_count - - double_count=.false. - pairwise_cutoff = 2.0_dp*cutoff+ 0.1_dp ! plenty big to find all relevant dimers - - call find_monomer_pairs(at,pairs_one_two, diffs_one_two, map_one_two, monomer_one_index,monomer_two_index ,one_two_identical , double_count,pairwise_cutoff,shifts_one_two ,error) - call find_monomer_pairs(at,pairs_one_three,diffs_one_three,map_one_three,monomer_one_index,monomer_three_index,one_three_identical,double_count,pairwise_cutoff,shifts_one_three,error) - ! for any equivalent monomer types we have to append the negative self-pairs since these are excluded by find_monomer_pairs - - if (.not. allocated(monomer_triplets)) allocate(monomer_triplets(3,0)) - if (.not. allocated(triplets_diffs)) allocate(triplets_diffs(6,0)) - if (.not. allocated(triplets_diffs_map)) allocate(triplets_diffs_map(0)) - if (.not. allocated(triplets_shifts)) allocate(triplets_shifts(6,0)) - - !! make triplets - do pos_ij=1,size(map_one_two) ! loop over pairs (i,j) of 1 and 2 - i=pairs_one_two( 1, map_one_two(pos_ij) ) - j=pairs_one_two( 2, map_one_two(pos_ij) ) - diff_ij = diffs_one_two(:,pos_ij) - shift_ij = shifts_one_two(:,pos_ij) - - do pos_ik=1,size(map_one_three) ! loop over monomers k of type 3 also paired with i - if (i /= pairs_one_three( 1, map_one_three(pos_ik) ) ) cycle - - k =pairs_one_three( 2 , map_one_three(pos_ik) ) - diff_ik = diffs_one_three(:,pos_ik) - shift_ik = shifts_one_three(:,pos_ik) - - diff_jk = diff_ik - diff_ij - shift_jk = shift_ik - shift_ij - - if (two_three_identical .and. all(shift_jk .eq. 0) .and. j==k ) cycle ! skip if j and k are same monomer - -! if (two_three_identical .and. k .lt. j) cycle -! if (two_three_identical .and. all(shift_jk .eq. 0) .and. j .ge. k ) cycle -! if (two_three_identical .and. j .ge. k ) cycle - - ! check that is a valid triplet - i.e. two sides of the triangle are within cutoff length - ! find minimum intermolecular distance (excluding Hydrogen) between each monomer pair - min_distances = (/ min_intermolecular_dist(at,monomer_one_index(:,i),monomer_two_index(:,j) , diff_ij, pairwise_cutoff) , & - min_intermolecular_dist(at,monomer_one_index(:,i),monomer_three_index(:,k) , diff_ik, pairwise_cutoff) , & - min_intermolecular_dist(at,monomer_two_index(:,j),monomer_three_index(:,k) , diff_jk, pairwise_cutoff) /) - if ( count(min_distances .gt. cutoff) .gt. 1 ) cycle - call add_triplet_if_new(monomer_triplets,triplets_diffs,triplets_diffs_map,triplets_shifts,i,j,k,diff_ij,diff_ik,shift_ij,shift_ik,two_three_identical) - end do - end do - deallocate(pairs_one_two) - deallocate(shifts_one_two) - deallocate(diffs_one_two) - deallocate(pairs_one_three) - deallocate(shifts_one_three) - deallocate(diffs_one_three) - if(allocated(triplets_shifts)) deallocate(triplets_shifts) -!call print("triplets diffs") -!call print(triplets_diffs) -end subroutine find_monomer_triplets - - -subroutine add_triplet_if_new(monomer_triplets,triplets_diffs,triplets_diffs_map,triplets_shifts,i,j,k,diff_ij,diff_ik,shift_ij,shift_ik,two_three_identical) - ! this also excludes the case where the and three identical and this pair was already found in the opposite order - integer, dimension(:,:), intent(inout), allocatable :: monomer_triplets - real(dp), dimension(:,:), intent(inout), allocatable :: triplets_diffs - integer, dimension(:), intent(inout), allocatable :: triplets_diffs_map - integer, dimension(:,:), intent(inout), allocatable :: triplets_shifts - integer, intent(in) :: i,j,k - real(dp), dimension(3),intent(in) :: diff_ij,diff_ik - integer, dimension(3),intent(in) :: shift_ij,shift_ik - logical, intent(in) :: two_three_identical - - integer, dimension(3) :: triplet - logical, dimension(:), allocatable :: shift_mask - integer, dimension(1):: temp1d - integer :: pos_ijk, pos_ikj,n_triplets,n_shifts - logical :: do_append - - if (.not. allocated(monomer_triplets)) allocate(monomer_triplets(3,0)) - if (.not. allocated(triplets_diffs)) allocate(triplets_diffs(6,0)) - if (.not. allocated(triplets_diffs_map)) allocate(triplets_diffs_map(0)) - if (.not. allocated(triplets_shifts)) allocate(triplets_shifts(6,0)) - - n_triplets=size(monomer_triplets,2) - n_shifts=size(triplets_diffs_map) - triplet=(/i,j,k/) - allocate(shift_mask(n_shifts)) - !call print("triplet has i, j,k = "//(/i,j,k/)//" and shifts "//(/shift_ij,shift_ik/)) - - ! in case monomers two and three are identical, check this pair hasn't already been found in opposite order - if (two_three_identical) then - shift_mask = (/ triplets_shifts(1,:) .eq. shift_ik(1) /) .and. & - (/ triplets_shifts(2,:) .eq. shift_ik(2) /) .and. & - (/ triplets_shifts(3,:) .eq. shift_ik(3) /) .and. & - - (/ triplets_shifts(4,:) .eq. shift_ij(1) /) .and. & - (/ triplets_shifts(5,:) .eq. shift_ij(2) /) .and. & - (/ triplets_shifts(6,:) .eq. shift_ij(3) /) - - temp1d = maxloc(monomer_triplets(1,:), monomer_triplets(1,:) .eq. i .and. monomer_triplets(2,:) .eq. k .and. monomer_triplets(3,:) .eq. j) - pos_ikj = temp1d(1) - temp1d=maxloc(triplets_diffs_map,triplets_diffs_map .eq. pos_ikj .and. shift_mask) - if (temp1d(1) /= 0) then - deallocate(shift_mask) - return - end if - end if - - ! find where this triplet is if we've found it before - temp1d = maxloc(monomer_triplets(1,:), monomer_triplets(1,:) .eq. i .and. monomer_triplets(2,:) .eq. j .and. monomer_triplets(3,:) .eq. k) - pos_ijk = temp1d(1) - - if (pos_ijk == 0) then ! append triplet if it's new - n_triplets = n_triplets + 1 - call reallocate(monomer_triplets,3,n_triplets,copy=.true.) - monomer_triplets(:,n_triplets) = triplet - pos_ijk=n_triplets - end if - - shift_mask = (/ triplets_shifts(1,:) .eq. shift_ij(1) /) .and. & ! check if this shift already present for this triplet - (/ triplets_shifts(2,:) .eq. shift_ij(2) /) .and. & - (/ triplets_shifts(3,:) .eq. shift_ij(3) /) .and. & - - (/ triplets_shifts(4,:) .eq. shift_ik(1) /) .and. & - (/ triplets_shifts(5,:) .eq. shift_ik(2) /) .and. & - (/ triplets_shifts(6,:) .eq. shift_ik(3) /) - - temp1d=maxloc(triplets_diffs_map,triplets_diffs_map .eq. pos_ijk .and. shift_mask) - deallocate(shift_mask) - do_append = (temp1d(1) == 0) - - if (do_append) then ! append shift if it's new - n_shifts = n_shifts + 1 - call reallocate(triplets_shifts,6,n_shifts,copy=.true.) - call reallocate(triplets_diffs,6,n_shifts,copy=.true.) - call reallocate(triplets_diffs_map,n_shifts,copy=.true.) - triplets_shifts(:,n_shifts) = (/shift_ij,shift_ik/) - triplets_diffs(:,n_shifts) = (/diff_ij,diff_ik/) - triplets_diffs_map(n_shifts) = pos_ijk - end if -end subroutine add_triplet_if_new - -function calc_mean_pos(at,indices) result (pos) -! generates an absolute 'mean' position of a set of atoms - NB not the centre of mass - type(Atoms), intent(in) :: at - integer,dimension(:), intent(in) :: indices - real(dp),dimension(3) :: pos - integer :: i,n - - pos = 0.0_dp - n=size(indices) - - do i =2,n - pos = pos + diff_min_image(at,indices(1),indices(i)) - end do - pos = pos / n - pos = pos + at%pos(:,indices(1)) - -end function calc_mean_pos - -function min_intermolecular_dist(at,mono1,mono2,mean_pos_diff,r_init) result (r_min) - ! returns the minimum intermolecular distance between two monomers, excluding hydrogens - type(Atoms), intent(in) :: at - integer, dimension(:), intent(in) :: mono1,mono2 - real(dp), dimension(3), intent(in) :: mean_pos_diff - real(dp), intent(in) :: r_init - - real(dp) :: r_min, temp_dist - integer :: i_atomic, i_glob,j_atomic, j_glob - real(dp), dimension(3) :: mean_pos_one, mean_pos_two - - mean_pos_one = calc_mean_pos(at,mono1) - mean_pos_two = calc_mean_pos(at,mono2) - - r_min = r_init - - do i_atomic=1,size(mono1) - i_glob=mono1(i_atomic) - if (at%Z(i_glob) == 1) cycle - - do j_atomic=1,size(mono2) - j_glob = mono2(j_atomic) - if (at%Z(j_glob) == 1) cycle - temp_dist = norm( diff_min_image(at,at%pos(:,i_glob),mean_pos_one) + mean_pos_diff + diff_min_image(at,mean_pos_two,at%pos(:,j_glob)) ) - r_min = min(r_min,temp_dist) - end do - end do - -end function min_intermolecular_dist - -end module topology_module diff --git a/src/libAtoms/Units.f95 b/src/libAtoms/Units.f95 deleted file mode 100644 index 778f117368..0000000000 --- a/src/libAtoms/Units.f95 +++ /dev/null @@ -1,150 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Units module -!X -!% This module holds a collection of our units and conversion factors. -!% We use Angstroms ($\mathrm{\AA}$), eV, and femtoseconds (fs). -!% -!% - Length: Angstroms, ``a.u. * BOHR`` -!% - Energy: eV, ``a.u. * HARTREE`` -!% - Time: fs -!% - Mass: $E T^2/L^2$ = ``a.u. * HARTREE * AU_FS**2 / BOHR**2`` -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module units_module - -use system_module, only : dp ! for definition of dp -implicit none -public - -#ifdef LEGACY_UNITS -! Values of units pre-2017. -! Since results will vary, keep these around for a while in case -! someone needs consistency with these. -! Tests will fail if these values are used. -real(dp), parameter :: ELECTRONMASS_GPERMOL = 5.48579903e-4_dp !% grams/mol -real(dp), parameter :: ELEM_CHARGE = 1.60217653e-19_dp !% coulombs -real(dp), parameter :: HARTREE = 27.2113961_dp !% eV -real(dp), parameter :: RYDBERG = 0.5_dp*HARTREE !% eV -real(dp), parameter :: BOHR = 0.529177249_dp !% Angstrom -real(dp), parameter :: CUBIC_BOHR = BOHR*BOHR/HARTREE !% QUIP Units of polarisability -real(dp), parameter :: HBAR_EVSEC = 6.5821220e-16_dp !% hbar in eV seconds -real(dp), parameter :: HBAR_AU = 1.0_dp !% hbar in a.u. -real(dp), parameter :: HBAR = (HBAR_EVSEC*1e+15_dp) !% hbar in eV fs -real(dp), parameter :: ONESECOND = 1e15_dp !% 1 second in fs -real(dp), parameter :: ONESECOND_AU = (1.0_dp/(HBAR_EVSEC/(HBAR_AU*HARTREE))) !% 1 second in a.u. -real(dp), parameter :: AU_FS = (1.0_dp/ONESECOND_AU*ONESECOND) !% a.u. time in fs -real(dp), parameter :: MASSCONVERT = (1.0_dp/ELECTRONMASS_GPERMOL*HARTREE*AU_FS*AU_FS/(BOHR*BOHR)) !% = 1e7 / (N_A * ELEM_CHARGE) -real(dp), parameter :: BOLTZMANN_K = 8.617385e-5_dp !% eV/Kelvin -real(dp), parameter :: PI = 3.14159265358979323846264338327950288_dp -real(dp), parameter :: N_A = 6.0221479e23_dp !% Avogadro's number -real(dp), parameter :: KCAL_MOL = 4.3383e-2_dp !% eV -real(dp), parameter :: DEGREES_PER_RADIAN = 180.0_dp / PI -real(dp), parameter :: RADIANS_PER_DEGREE = PI / 180.0_dp -real(dp), parameter :: GPA = 1.6022e-19_dp*1.0e30_dp/1.0e9_dp !% Convert from \textsc{libAtoms} units to Gigapascals (DEPRECATED) -real(dp), parameter :: EV_A3_IN_GPA = 1.6022e-19_dp*1.0e30_dp/1.0e9_dp !% Same thing but with a less misleading name -real(dp), parameter :: GPA_TO_EV_A3 = 1.0e9_dp/ELEM_CHARGE/1.0e30_dp !% The inverse of the above, convention consistent with all other conversion factors -real(dp), parameter :: EPSILON_0 = 8.854187817e-12_dp / ELEM_CHARGE * 1.0e-10_dp !% epsilon_0 in e / V Angstrom -real(dp), parameter :: DEBYE = 1.0e-21_dp/299792458.0_dp/ELEM_CHARGE*1e10_dp !% 1D $= 10^{-18}$ statcoulomb-centrimetre in e-A -real(dp), parameter :: SQRT_TWO = sqrt(2.0_dp) -! not included originally, make sure they're not undefined -real(dp), parameter :: GRAM = 1e-3_dp !% in kg -real(dp), parameter :: ELECTRONMASS = ELECTRONMASS_GPERMOL*GRAM/N_A -real(dp), parameter :: EPSILON_0_AU = EPSILON_0*ELEM_CHARGE/1.0e-10_dp -real(dp), parameter :: VACUUM_C = 299792458.0_dp !% exact in m/s -real(dp), parameter :: INVERSE_CM = 1.0e2_dp*VACUUM_C*HBAR_EVSEC*2.0_dp*PI !% -#else -! CODATA 2014 taken from -! http://arxiv.org/pdf/1507.07956.pdf -! Fundamentals -real(dp), parameter :: ELECTRONMASS = 9.10938356e-31_dp !% electron mass / kg -real(dp), parameter :: N_A = 6.022140857e23_dp !% Avogadro constant -real(dp), parameter :: ELEM_CHARGE = 1.6021766208e-19_dp !% e / Coulombs -real(dp), parameter :: HARTREE = 27.21138602_dp !% EH / eV -real(dp), parameter :: BOHR = 0.52917721067_dp !% in Angstrom -real(dp), parameter :: HBAR_EVSEC = 6.582119514e-16_dp !% hbar in eV seconds -real(dp), parameter :: BOLTZMANN_K = 8.6173303e-5_dp !% eV/kelvin -real(dp), parameter :: EPSILON_0_AU = 8.854187817e-12_dp !% exact in F/m -real(dp), parameter :: VACUUM_C = 299792458.0_dp !% exact in m/s - -! Others -real(dp), parameter :: GRAM = 1e-3_dp !% in kg -real(dp), parameter :: PI = 3.14159265358979323846264338327950288_dp -real(dp), parameter :: SQRT_TWO = sqrt(2.0_dp) - -! derived units for QUIP -real(dp), parameter :: ELECTRONMASS_GPERMOL = ELECTRONMASS*N_A/GRAM !% grams/mol -real(dp), parameter :: RYDBERG = 0.5_dp*HARTREE !% eV -real(dp), parameter :: CUBIC_BOHR = BOHR*BOHR/HARTREE !% QUIP Units of polarisability -real(dp), parameter :: HBAR_AU = 1.0_dp !% hbar in a.u. -real(dp), parameter :: HBAR = (HBAR_EVSEC*1e+15_dp) !% hbar in eV fs -real(dp), parameter :: ONESECOND = 1e15_dp !% 1 second in fs -real(dp), parameter :: ONESECOND_AU = (1.0_dp/(HBAR_EVSEC/(HBAR_AU*HARTREE))) !% 1 second in a.u. -real(dp), parameter :: AU_FS = (1.0_dp/ONESECOND_AU*ONESECOND) !% a.u. time in fs -real(dp), parameter :: MASSCONVERT = (1.0_dp/ELECTRONMASS_GPERMOL*HARTREE*AU_FS*AU_FS/(BOHR*BOHR)) !% = 1e7 / (N_A * ELEM_CHARGE) -real(dp), parameter :: KCAL_MOL = 4.184*1000/(ELEM_CHARGE*N_A) !% Thermochemical definition in eV -real(dp), parameter :: DEGREES_PER_RADIAN = 180.0_dp / PI -real(dp), parameter :: RADIANS_PER_DEGREE = PI / 180.0_dp -real(dp), parameter :: GPA = ELEM_CHARGE*1.0e30_dp/1.0e9_dp !% Convert from \textsc{libAtoms} units to Gigapascals (DEPRECATED) -real(dp), parameter :: EV_A3_IN_GPA = ELEM_CHARGE*1.0e30_dp/1.0e9_dp !% Same thing but with a less misleading name -real(dp), parameter :: GPA_TO_EV_A3 = 1.0e9_dp/ELEM_CHARGE/1.0e30_dp !% The inverse of the above, convention consistent with all other conversion factors -real(dp), parameter :: EPSILON_0 = EPSILON_0_AU/ELEM_CHARGE*1.0e-10_dp !% epsilon_0 in e / V Angstrom -real(dp), parameter :: DEBYE = 1.0e-21_dp/VACUUM_C/ELEM_CHARGE*1e10_dp !% 1D $= 10^{-18}$ statcoulomb-centrimetre in e-A -real(dp), parameter :: INVERSE_CM = 1.0e2_dp*VACUUM_C*HBAR_EVSEC*2.0_dp*PI !% cm^{-1} * h * c -#endif - -complex(dp), parameter :: CPLX_ZERO = (0.0_dp,0.0_dp) -complex(dp), parameter :: CPLX_IMAG = (0.0_dp,1.0_dp) -complex(dp), parameter :: CPLX_ONE = (1.0_dp,0.0_dp) - -! Make the values of some compiler macros available at runtime -#ifdef HAVE_LOTF -integer, parameter :: have_lotf = 1 -#else -integer, parameter :: have_lotf = 0 -#endif - -#ifdef HAVE_CP2K -integer, parameter :: have_cp2k = 1 -#else -integer, parameter :: have_cp2k = 0 -#endif - -#ifdef HAVE_NETCDF4 -integer, parameter :: have_netcdf = 1 -#else -integer, parameter :: have_netcdf = 0 -#endif - -end module units_module diff --git a/src/libAtoms/angular_functions.f95 b/src/libAtoms/angular_functions.f95 deleted file mode 100644 index b99bb9ff0c..0000000000 --- a/src/libAtoms/angular_functions.f95 +++ /dev/null @@ -1,710 +0,0 @@ -module angular_functions_module - -use system_module -use units_module -use linearalgebra_module - -implicit none -private - - - real(dp), dimension(:,:,:,:,:,:), allocatable, save :: cg_array - integer, save :: cg_j1_max=0, cg_m1_max=0, cg_j2_max=0, cg_m2_max=0, cg_j_max=0, cg_m_max=0 - logical, save :: cg_initialised = .false. - - public :: SphericalYCartesian, GradSphericalYCartesian - public :: SphericalYCartesian_all, GradSphericalYCartesian_all - public :: SolidRCartesian, SphericalIterative, GradSphericalIterative - - public :: wigner3j - public :: cg_initialise, cg_finalise, cg_array - -contains - - !################################################################################# - !# - !% Solid Harmonic function using Cartesian coordinates - !% - !% $ R_{l m} = \sqrt{\frac{4 \pi}{2 l + 1}} r^l Y_{l m} $ - !# - !################################################################################# - - function SolidRCartesian(l, m, x) - - complex(dp) :: SolidRCartesian - integer, intent(in) :: l, m - real(dp), intent(in) :: x(3) - integer :: p, q, s - - SolidRCartesian = CPLX_ZERO - - do p = 0, l - q = p - m - s = l - p - q - - if ((q >= 0) .and. (s >= 0)) then - SolidRCartesian = SolidRCartesian + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) & - * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) & - * (x(3)**s) & - / (factorial(p) * factorial(q) * factorial(s))) - end if - end do - - SolidRCartesian = SolidRCartesian * sqrt(factorial(l + m) * factorial(l - m)) - - end function SolidRCartesian - - function SolidRCartesian_all(l_max, x) - - integer, intent(in) :: l_max - real(dp), intent(in) :: x(3) - complex(dp) :: SolidRCartesian_all(0:l_max, -l_max:l_max) - - integer :: l, m - integer :: p, q, s - complex(kind=dp) :: cm, cp, cm_term(0:l_max), cp_term(0:2*l_max), x3_term(0:2*l_max) - real(dp) :: factorials(0:2*l_max) - - SolidRCartesian_all = CPLX_ZERO - - cm = cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp) - cp = cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp) - - ! p = 0 .. l - do p=0, l_max - cm_term(p) = cm**p - end do - ! q, s = 0 .. 2l - do q=0, 2*l_max - cp_term(q) = cp**q - x3_term(q) = x(3)**q - factorials(q) = factorial(q) - end do - - do l=0, l_max - do m=-l, l - do p = 0, l - q = p - m - s = l - p - q - - if ((q >= 0) .and. (s >= 0)) then - SolidRCartesian_all(l,m) = SolidRCartesian_all(l,m) + & - ( cm_term(p) * cp_term(q) * x3_term(s) / & - ( factorials(p) * factorials(q) * factorials(s) ) ) - end if - end do - - SolidRCartesian_all(l,m) = SolidRCartesian_all(l,m) * sqrt(factorials(l + m) * factorials(l - m)) - end do - end do - - end function SolidRCartesian_all - - !################################################################################# - !# - !% Spherical Harmonic function using Cartesian coordinates - !# - !################################################################################# - - function SphericalYCartesian(l, m, x) - - complex(dp) :: SphericalYCartesian - integer, intent(in) :: l, m - real(dp), intent(in) :: x(3) - - SphericalYCartesian = SolidRCartesian(l, m, x) * sqrt(((2.0_dp * l) + 1) / (4.0_dp * PI)) & - * (normsq(x)**(-0.5_dp * l)) - - end function SphericalYCartesian - - function SphericalYCartesian_all(l_max, x) - - integer, intent(in) :: l_max - real(dp), intent(in) :: x(3) - complex(dp) :: SphericalYCartesian_all(0:l_max, -l_max:l_max) - - real(dp) :: normsq_x - integer :: l, m - - normsq_x = normsq(x) - SphericalYCartesian_all = SolidRCartesian_all(l_max, x) - do l=0, l_max - SphericalYCartesian_all(l,-l:l) = SphericalYCartesian_all(l,-l:l) * & - sqrt(((2.0_dp * l) + 1) / (4.0_dp * PI)) * (normsq_x**(-0.5_dp * l)) - end do - - end function SphericalYCartesian_all - - !################################################################################# - !# - !% Derivative of Spherical Harmonic function using Cartesian coordinates - !# - !################################################################################# - - function GradSphericalYCartesian(l, m, x) - - complex(dp) :: GradSphericalYCartesian(3) - integer, intent(in) :: l, m - real(dp), intent(in) :: x(3) - integer :: p, q, s - - GradSphericalYCartesian = CPLX_ZERO - - do p = 0, l - q = p - m - s = l - p - q - - if ((p >= 1) .and. (q >= 0) .and. (s >= 0)) then - GradSphericalYCartesian(1) = GradSphericalYCartesian(1) & - - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**(p - 1)) & - * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) & - * (x(3)**s) & - * 0.5_dp & - / (factorial(p - 1) * factorial(q) * factorial(s))) - GradSphericalYCartesian(2) = GradSphericalYCartesian(2) & - - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**(p - 1)) & - * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) & - * (x(3)**s) & - * 0.5_dp * cmplx(0.0_dp, 1.0_dp, dp) & - / (factorial(p - 1) * factorial(q) * factorial(s))) - end if - - if ((p >= 0) .and. (q >= 1) .and. (s >= 0)) then - GradSphericalYCartesian(1) = GradSphericalYCartesian(1) & - + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) & - * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**(q - 1)) & - * (x(3)**s) & - * 0.5_dp & - / (factorial(p) * factorial(q - 1) * factorial(s))) - GradSphericalYCartesian(2) = GradSphericalYCartesian(2) & - - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) & - * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**(q - 1)) & - * (x(3)**s) & - * 0.5_dp * cmplx(0.0_dp, 1.0_dp, dp) & - / (factorial(p) * factorial(q - 1) * factorial(s))) - end if - - if ((p >= 0) .and. (q >= 0) .and. (s >= 1)) then - GradSphericalYCartesian(3) = GradSphericalYCartesian(3) & - + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) & - * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) & - * (x(3)**(s - 1)) & - / (factorial(p) * factorial(q) * factorial(s - 1))) - end if - end do - - GradSphericalYCartesian = GradSphericalYCartesian & - * sqrt(factorial(l + m) * factorial(l - m) * ((2.0_dp * l) + 1) / (4.0_dp * PI)) & - * (normsq(x)**(-0.5_dp * l)) - - GradSphericalYCartesian = GradSphericalYCartesian & - - (l * x * SphericalYCartesian(l, m, x) / normsq(x)) - - end function GradSphericalYCartesian - - function GradSphericalYCartesian_all(l_max, x) - - integer, intent(in) :: l_max - real(dp), intent(in) :: x(3) - complex(dp) :: GradSphericalYCartesian_all(0:l_max, -l_max:l_max, 3) - - integer :: l, m - integer :: p, q, s - complex(kind=dp) :: cm, cp, cm_term(0:l_max), cp_term(0:2*l_max), x3_term(0:2*l_max) - real(dp) :: factorials(0:2*l_max) - real(dp) :: normsq_x - complex(dp) :: tt - - GradSphericalYCartesian_all = CPLX_ZERO - - cm = cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp) - cp = cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp) - - ! p = 0 .. l - do p=0, l_max - cm_term(p) = cm**p - end do - ! q, s = 0 .. 2l - do q=0, 2*l_max - cp_term(q) = cp**q - x3_term(q) = x(3)**q - factorials(q) = factorial(q) - end do - - normsq_x = normsq(x) - - do l=0, l_max - do m=-l, l - do p = 0, l - q = p - m - s = l - p - q - - if ((p >= 1) .and. (q >= 0) .and. (s >= 0)) then - tt = (cm_term(p-1) * cp_term(q) * x3_term(s) & - * 0.5_dp & - / (factorials(p - 1) * factorials(q) * factorials(s))) - GradSphericalYCartesian_all(l,m,1) = GradSphericalYCartesian_all(l,m,1) & - - tt - GradSphericalYCartesian_all(l,m,2) = GradSphericalYCartesian_all(l,m,2) & - - tt * cmplx(0.0_dp, 1.0_dp, dp) - end if - - if ((p >= 0) .and. (q >= 1) .and. (s >= 0)) then - tt = (cm_term(p) * cp_term(q-1) * x3_term(s) & - * 0.5_dp & - / (factorials(p) * factorials(q - 1) * factorials(s))) - GradSphericalYCartesian_all(l,m,1) = GradSphericalYCartesian_all(l,m,1) & - + tt - GradSphericalYCartesian_all(l,m,2) = GradSphericalYCartesian_all(l,m,2) & - - tt * cmplx(0.0_dp, 1.0_dp, dp) - end if - - if ((p >= 0) .and. (q >= 0) .and. (s >= 1)) then - GradSphericalYCartesian_all(l,m,3) = GradSphericalYCartesian_all(l,m,3) & - + (cm_term(p) * cp_term(q) * x3_term(s-1) & - / (factorials(p) * factorials(q) * factorials(s - 1))) - end if - end do - - GradSphericalYCartesian_all(l,m,:) = GradSphericalYCartesian_all(l,m,:) & - * sqrt(factorials(l + m) * factorials(l - m) * ((2.0_dp * l) + 1) / (4.0_dp * PI)) & - * (normsq_x**(-0.5_dp * l)) - - GradSphericalYCartesian_all(l,m,:) = GradSphericalYCartesian_all(l,m,:) & - - (l * x * SphericalYCartesian(l, m, x) / normsq_x) - end do - end do - - end function GradSphericalYCartesian_all - - !################################################################################# - !# - !% Spherical Harmonics and SH derivative functions in Cartesian coordinates using iterative method - !# - !################################################################################# - - function SphericalIterative(l_max, x) - - real(dp), allocatable :: SphericalIterative(:,:,:) - real(dp) :: Q_ml_2, Q_ml_1, Q_ml_0, r_xy_squared, sm_cm_part, s_m, c_m, s_m_new, c_m_new - real(dp) :: x(:,:), F_ml(0:l_max,0:l_max) - integer :: l, m, i, j, l_max - - allocate(SphericalIterative(-l_max:l_max, 0:l_max, SIZE(x, 2))) - F_ml = 0 - - do l=0, l_max - F_ml(l, 0) = sqrt((2*l + 1)/(2*PI)) - - do m=1, l - F_ml(l,m) = F_ml(l,m-1) * (-1/sqrt(REAL((l+m)*(l+1-m)))) - end do - end do - - do i=1, SIZE(x, 2) - do l=0, l_max - do m=-l, l - s_m = 0.0 - c_m = 1.0 - - if (m == 0) then - sm_cm_part = 1/sqrt(2.0) - - else - do j=0, ABS(m)-2 - s_m_new = x(1, i)*s_m + x(2, i)*c_m - c_m_new = -x(2, i)*s_m + x(1, i)*c_m - s_m = s_m_new - c_m = c_m_new - end do - if (m > 0) then - sm_cm_part = -x(2, i)*s_m + x(1, i)*c_m - else if (m < 0) then - sm_cm_part = x(1, i)*s_m + x(2, i)*c_m - end if - end if - - Q_ml_2 = 1.0 - - do j=1, l - Q_ml_2 = Q_ml_2 * -(2*j - 1) - end do - - Q_ml_1 = -x(3,i) * Q_ml_2 - - if (l-ABS(m)>1) then - r_xy_squared = x(1,i)*x(1,i) + x(2,i)*x(2,i) - - do j=l-2, ABS(m), -1 - Q_ml_0 = (-(2 * (j+1) * x(3,i) * Q_ml_1) - (r_xy_squared * Q_ml_2))/((l+j+1) * (l-j)) - - Q_ml_2 = Q_ml_1 - Q_ml_1 = Q_ml_0 - end do - - else if (l-ABS(m)==1) then - Q_ml_0 = Q_ml_1 - else if (l-ABS(m)==0) then - Q_ml_0 = Q_ml_2 - end if - - SphericalIterative(m,l,i) = Q_ml_0 * sm_cm_part * F_ml(l, ABS(m)) - end do - end do - end do - end function SphericalIterative - - function GradSphericalIterative(l_max, x) - - real(dp), allocatable :: GradSphericalIterative(:,:,:,:) - real(dp) :: r_xy_squared, first_term, second_term, Q_ml_0, Q_ml_1, Q_ml_2 - real(dp) :: x(:,:), F_ml(0:l_max,0:l_max), Q_ml(0:l_max,0:l_max), s(0:l_max), c(0:l_max) - integer :: l, m, l_max, i, j - - allocate(GradSphericalIterative(-l_max:l_max, 0:l_max, SIZE(x, 2), 3)) - - F_ml = 0 - do l=0, l_max - F_ml(l, 0) = sqrt((2*l + 1)/(2*PI)) - - do m=1, l - F_ml(l,m) = F_ml(l,m-1) * (-1/sqrt(REAL((l+m)*(l+1-m)))) - end do - end do - - do i=1, SIZE(x, 2) - Q_ml = 0 - r_xy_squared = x(1,i)*x(1,i) + x(2,i)*x(2,i) - do l=0, l_max - do m=0, l - Q_ml_2 = 1.0 - - do j=1, l - Q_ml_2 = Q_ml_2 * -(2*j - 1) - end do - - Q_ml_1 = -x(3,i) * Q_ml_2 - - if (l-ABS(m)>1) then - do j=l-2, ABS(m), -1 - Q_ml_0 = (-(2 * (j+1) * x(3,i) * Q_ml_1) - (r_xy_squared * Q_ml_2))/((l+j+1) * (l-j)) - - Q_ml_2 = Q_ml_1 - Q_ml_1 = Q_ml_0 - end do - else if (l-ABS(m)==1) then - Q_ml_0 = Q_ml_1 - - else if (l-ABS(m)==0) then - Q_ml_0 = Q_ml_2 - end if - Q_ml(m,l) = Q_ml_0 - end do - end do - - s(0) = 0.0 - c(0) = 1.0 - do j=1, l_max - s(j) = x(1,i)*s(j-1) + x(2,i)*c(j-1) - c(j) = -x(2,i)*s(j-1) + x(1,i)*c(j-1) - end do - - do l=0, l_max - do m=-l, l - if (l == 0) then - GradSphericalIterative(m,l,i,1) = 0.0 - GradSphericalIterative(m,l,i,2) = 0.0 - GradSphericalIterative(m,l,i,3) = 0.0 - - else if (m == 0) then - ! m = 0 case - if (l == 1) then - GradSphericalIterative(m,l,i,1) = 0.0 - GradSphericalIterative(m,l,i,2) = 0.0 - GradSphericalIterative(m,l,i,3) = F_ml(l,m)/sqrt(2.0) * l * Q_ml(0,l-1) - else - GradSphericalIterative(m,l,i,1) = F_ml(l,m)/sqrt(2.0) * x(1,i) * Q_ml(1,l-1) - GradSphericalIterative(m,l,i,2) = F_ml(l,m)/sqrt(2.0) * x(2,i) * Q_ml(1,l-1) - GradSphericalIterative(m,l,i,3) = F_ml(l,m)/sqrt(2.0) * l * Q_ml(0,l-1) - end if - else if (m < 0) then - if (abs(m) > l-2) then - first_term = 0.0 - else - first_term = Q_ml(abs(m)+1,l-1) - end if - if (l == abs(m)) then - second_term = 0.0 - else - second_term = Q_ml(abs(m),l-1) - end if - - GradSphericalIterative(m,l,i,1) = F_ml(l,abs(m)) * ((s(abs(m))*x(1,i)*first_term) + (abs(m)*s(abs(m)-1)*Q_ml(abs(m),l))) - GradSphericalIterative(m,l,i,2) = F_ml(l,abs(m)) * ((s(abs(m))*x(2,i)*first_term) + (abs(m)*c(abs(m)-1)*Q_ml(abs(m),l))) - GradSphericalIterative(m,l,i,3) = F_ml(l,abs(m)) * s(abs(m)) * (l+abs(m)) * second_term - - else if (m > 0) then - if (abs(m) > l-2) then - first_term = 0.0 - else - first_term = Q_ml(abs(m)+1,l-1) - end if - if (l == abs(m)) then - second_term = 0.0 - else - second_term = Q_ml(abs(m),l-1) - end if - - GradSphericalIterative(m,l,i,1) = F_ml(l,abs(m)) * (c(abs(m))*x(1,i)*first_term + abs(m)*c(abs(m)-1)*Q_ml(abs(m),l)) - GradSphericalIterative(m,l,i,2) = F_ml(l,abs(m)) * (c(abs(m))*x(2,i)*first_term - abs(m)*s(abs(m)-1)*Q_ml(abs(m),l)) - GradSphericalIterative(m,l,i,3) = F_ml(l,abs(m)) * c(abs(m)) * (l+abs(m)) * second_term - end if - end do - end do - end do - end function GradSphericalIterative - - - subroutine cg_initialise(j,denom) - - integer, intent(in) :: j - integer :: i_j1,i_m1,i_j2,i_m2,i_j,i_m - integer, intent(in), optional :: denom - - integer :: my_denom - - if (cg_initialised .and. j > cg_j_max) then ! need to reinitialise - call cg_finalise() - cg_initialised = .false. - endif - if (cg_initialised) return - - my_denom = optional_default(1,denom) - - cg_j1_max = j - cg_m1_max = j - cg_j2_max = j - cg_m2_max = j - cg_j_max = j !(j1_max+j2_max) - cg_m_max = j !(j1_max+j2_max) - - allocate( cg_array(0:cg_j1_max,-cg_m1_max:cg_m1_max,0:cg_j2_max,-cg_m2_max:cg_m2_max,& - & 0:cg_j_max,-cg_j_max:cg_j_max) ) - - cg_array = 0.0_dp - - do i_j1 = 0, cg_j1_max - do i_m1 = -i_j1, i_j1, my_denom - do i_j2 = 0, cg_j2_max - do i_m2 = -i_j2, i_j2, my_denom - do i_j = abs(i_j1-i_j2), min(cg_j_max,i_j1+i_j2) - do i_m = -i_j, i_j, my_denom - - - cg_array(i_j1,i_m1,i_j2,i_m2,i_j,i_m) = cg_calculate(i_j1,i_m1,i_j2,i_m2,i_j,i_m,denom) - - enddo - enddo - enddo - enddo - enddo - enddo - - cg_initialised = .true. - - endsubroutine cg_initialise - - !################################################################################# - !# - !% Finalise global CG arrays - !# - !################################################################################# - - subroutine cg_finalise - - cg_j1_max = 0 - cg_m1_max = 0 - cg_j2_max = 0 - cg_m2_max = 0 - cg_j_max = 0 - cg_m_max = 0 - - if(allocated(cg_array)) deallocate( cg_array ) - cg_initialised = .false. - - endsubroutine cg_finalise - - !################################################################################# - !# - !% Look up CG coefficient from CG array, previously calculated. - !# - !################################################################################# - - function cg_lookup(j1,m1,j2,m2,j,m,denom) result(cg) - - real(dp) :: cg - integer, intent(in) :: j1,m1,j2,m2,j,m - integer, intent(in), optional :: denom - - cg=0.0_dp - - if ( .not. cg_check(j1,m1,j2,m2,j,m,denom) ) then - return - endif - - if( j1<=cg_j1_max .and. j2<=cg_j2_max .and. j<=cg_j_max .and. & - abs(m1)<=cg_m1_max .and. abs(m2)<=cg_m2_max .and. abs(m) <= cg_m_max .and. cg_initialised ) then - cg = cg_array(j1,m1,j2,m2,j,m) - else - cg = cg_calculate(j1,m1,j2,m2,j,m,denom) - endif - - endfunction cg_lookup - - !################################################################################# - !# - !% Check if input variables for CG make sense. - !% Source: http://mathworld.wolfram.com/Clebsch-GordanCoefficient.html \\ - !% - !% $ j_1 + j_2 \ge j $ \\ - !% $ j_1 - j_2 \ge -j $ \\ - !% $ j_1 - j_2 \le j $ \\ - !% $ j_1 \ge m_1 \ge j_1 $ \\ - !% $ j_2 \ge m_2 \ge j_2 $ \\ - !% $ j \ge m \ge j $ \\ - !% $ m_1 + m_2 = m $ \\ - !# - !################################################################################# - - function cg_check(j1,m1,j2,m2,j,m,denom) - - logical :: cg_check - integer, intent(in) :: j1,m1,j2,m2,j,m - integer, intent(in), optional :: denom - - integer :: my_denom - - my_denom = optional_default(1,denom) - cg_check = (j1>=0) .and. (j2>=0) .and. (j>=0) .and. & - (abs(m1)<=j1) .and. (abs(m2)<=j2) .and. (abs(m)<=j) & - .and. (m1+m2==m) .and. (j1+j2 >= j) .and. (abs(j1-j2) <= j) & - .and. (mod(j1+j2+j,my_denom)==0) - - endfunction cg_check - - !################################################################################# - !# - !% Calculate a Clebsch-Gordan coefficient $\left< j_1 m_1 j_2 m_2 | j m \right>$ - !% Source: http://mathworld.wolfram.com/Clebsch-GordanCoefficient.html \\ - !% $ \left< j_1 m_1 j_2 m_2 | j m \right> = (-1)^{m+j_1-j_2) - !% \sqrt{2j+1} \left( \begin{array}{ccc} - !% j_1 & j_2 & j \\ - !% m_1 & m_2 & -m \\ - !% \end{array} \right) $ - !% where the thing on the right-hand side is the Wigner 3J symbol. - !# - !################################################################################# - - function cg_calculate(j1,m1,j2,m2,j,m,denom) result(cg) - - real(dp) :: cg - integer, intent(in) :: j1,m1,j2,m2,j,m - integer, intent(in), optional :: denom - - integer :: my_denom - - my_denom = optional_default(1,denom) - - cg=0.0_dp - if ( .not. cg_check(j1,m1,j2,m2,j,m,denom) ) return - - cg = oscillate((m+j1-j2)/my_denom) * sqrt(2.0_dp*real(j,dp)/real(my_denom,dp)+1.0_dp) * & - wigner3j(j1,m1,j2,m2,j,-m,denom) - - end function cg_calculate - - !################################################################################# - !# - !% Triangle coefficient - !% Source: http://mathworld.wolfram.com/TriangleCoefficient.html - !% - !% $ \Delta(a,b,c) = \frac{ (a+b-c)! (a-b+c)! (-a+b+c)! }{ (a+b+c+1)! } $ - !# - !################################################################################# - - function tc(a,b,c,denom) - - real(dp) :: tc - integer, intent(in) :: a, b, c - integer, intent(in), optional :: denom - integer :: my_denom - - my_denom = optional_default(1,denom) - - tc = factorial((a+b-c)/my_denom) * factorial((a-b+c)/my_denom) * & - factorial((-a+b+c)/my_denom) / factorial((a+b+c)/my_denom+1) - - endfunction tc - - !################################################################################# - !# - !% Wigner 3J symbol - !% Source: http://mathworld.wolfram.com/Wigner3j-Symbol.html - !% - !% \[ - !% \left( \begin{array}{ccc} - !% j_1 & j_2 & j \\ - !% m_1 & m_2 & m \\ - !% \end{array} \right) = (-1)^{j_1-j_2-m) \sqrt{ \Delta (j_1,j_2,j) } - !% \sqrt{ (j_1+m_1)! (j_1-m_1)! (j_2+m_2)! (j_2-m_2)! (j+m)! (j-m)! } - !% \sum_k \frac{ (-1)^k }{k! (j-j_2+k+m_1)! (j-j_1+k-m_2)! (j_1+j_2-j-k)! - !% (j_1-k-m_1)! (j_2-k+m_2)! } - !% \] - !% the summation index k runs on all integers where none of the argument of - !% factorials are negative - !% $\Delta(a,b,c)$ is the triangle coefficient. - !# - !################################################################################# - - function wigner3j(j1,m1,j2,m2,j,m,denom) - - real(dp) :: wigner3j - integer, intent(in) :: j1,m1,j2,m2,j,m - integer, intent(in), optional :: denom - - real(dp) :: pre_fac, triang_coeff, main_coeff, sum_coeff, sum_term - integer :: k, kmin, kmax, my_denom - - my_denom = optional_default(1,denom) - - pre_fac = oscillate((j1-j2-m)/my_denom) - - triang_coeff = sqrt( tc(j1,j2,j,denom) ) - - main_coeff = sqrt( & - factorial((j1+m1)/my_denom) * factorial((j1-m1)/my_denom) * & - factorial((j2+m2)/my_denom) * factorial((j2-m2)/my_denom) * & - factorial((j+m)/my_denom) * factorial((j-m)/my_denom) ) - - sum_coeff = 0.0_dp - - kmin = max( j2-j-m1, j1+m2-j, 0 ) / my_denom - kmax = min( j1+j2-j, j1-m1, j2+m2) / my_denom - - do k = kmin, kmax - - sum_term = 1.0_dp / ( factorial(k) * factorial((j-j2+m1)/my_denom+k) * & - factorial((j-j1-m2)/my_denom+k) * factorial((j1+j2-j)/my_denom-k) * & - factorial((j1-m1)/my_denom-k) * factorial((j2+m2)/my_denom-k) ) - - sum_term = oscillate(k) * sum_term - - sum_coeff = sum_coeff + sum_term - - enddo - - wigner3j = pre_fac * triang_coeff * main_coeff * sum_coeff - - endfunction wigner3j - -end module angular_functions_module diff --git a/src/libAtoms/clusters.f95 b/src/libAtoms/clusters.f95 deleted file mode 100644 index ed7a060c54..0000000000 --- a/src/libAtoms/clusters.f95 +++ /dev/null @@ -1,4304 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" -module clusters_module - use error_module - use system_module - use linearalgebra_module - use Table_module - use periodictable_module - use Atoms_types_module - use Atoms_module - use dictionary_module - use ParamReader_module - use group_module - use constraints_module - use dynamicalsystem_module - use cinoutput_module - -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif -implicit none -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif -private - -integer, parameter :: & - HYBRID_ACTIVE_MARK = 1, & - HYBRID_BUFFER_MARK = 2, & - HYBRID_TRANS_MARK = 3, & - HYBRID_TERM_MARK = 4, & - HYBRID_BUFFER_OUTER_LAYER_MARK = 5, & - HYBRID_ELECTROSTATIC_MARK = 6, & - HYBRID_NO_MARK = 0 -! HYBRID_FIT_MARK = 6, & - -public :: HYBRID_ACTIVE_MARK, HYBRID_BUFFER_MARK, HYBRID_TRANS_MARK, HYBRID_TERM_MARK, & - HYBRID_BUFFER_OUTER_LAYER_MARK, HYBRID_ELECTROSTATIC_MARK, HYBRID_NO_MARK -! HYBRID_FIT_MARK - -integer, parameter :: MAX_CUT_BONDS = 6 -public :: MAX_CUT_BONDS - -character(len=TABLE_STRING_LENGTH), parameter :: hybrid_mark_name(0:6) = & - (/ "h_none ", & - "h_active ", & - "h_buffer ", & - "h_trans ", & - "h_term ", & - "h_outer_l ", & - "h_fit " /) - -public :: create_cluster_info_from_mark, carve_cluster, create_cluster_simple, create_hybrid_weights, & - bfs_grow, bfs_step, multiple_images, discard_non_min_images, make_convex, create_embed_and_fit_lists, & - create_embed_and_fit_lists_from_cluster_mark, & - add_cut_hydrogens, construct_hysteretic_region, & - create_pos_or_list_centred_hybrid_region, get_hybrid_list, & - estimate_origin_extent - !, construct_region, select_hysteretic_quantum_region - -!% Grow a selection list by bond hopping. -interface bfs_grow - module procedure bfs_grow_single - module procedure bfs_grow_list -end interface - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Cluster carving routines - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% On exit, 'list' will contain 'atom' (with shift '000') - !% plus the atoms within 'n' bonds hops of it. - subroutine bfs_grow_single(this, list, atom, n, nneighb_only, min_images_only, alt_connect) - type(Atoms), intent(in) :: this - type(Table), intent(out) :: list - integer, intent(in) :: atom, n - logical, optional, intent(in)::nneighb_only, min_images_only - type(Connection), intent(in), optional :: alt_connect - - call append(list, (/atom, 0,0,0/)) ! Add atom with shift 000 - call bfs_grow_list(this, list, n, nneighb_only, min_images_only, alt_connect) - - end subroutine bfs_grow_single - - - !% On exit, 'list' will have been grown by 'n' bond hops. - subroutine bfs_grow_list(this, list, n, nneighb_only, min_images_only, alt_connect) - type(Atoms), intent(in) ::this - type(Table), intent(inout)::list - integer, intent(in) :: n - logical, optional, intent(in)::nneighb_only, min_images_only - type(Connection), intent(in), optional :: alt_connect - - type(Table)::tmplist - integer::i - - do i=1,n - call bfs_step(this, list, tmplist, nneighb_only, min_images_only, alt_connect=alt_connect) - call append(list, tmplist) - end do - - if (n >= 1) call finalise(tmplist) - end subroutine bfs_grow_list - - - !% Execute one Breadth-First-Search move on the atomic connectivity graph. - subroutine bfs_step(this,input,output,nneighb_only, min_images_only, max_r, alt_connect, property, debugfile, error) - type(Atoms), intent(in), target :: this !% The atoms structure to perform the step on. - type(Table), intent(in) :: input !% Table with intsize 4. First integer column is indices of atoms - !% already in the region, next 3 are shifts. - type(Table), intent(out) :: output !% Table with intsize 4, containing the new atomic - !% indices and shifts. - - - logical, optional, intent(in) :: nneighb_only - !% If present and true, sets whether only neighbours - !% within the sum of the two respective covalent radii (multiplied by the atom's nneightol) are included, - !% irrespective of the cutoff in the atoms structure - !% (default is true). - - logical, optional, intent(in) :: min_images_only - !% If true, there will be no repeated atomic indices in final list - only the - !% minimum shift image of those found will be included. Default is false. - - real(dp), optional, intent(in) :: max_r - !% if present, only neighbors within this range will be included - - type(Connection), intent(in), optional, target :: alt_connect - integer, intent(in), optional:: property(:) - - type(inoutput), optional :: debugfile - - integer, optional, intent(out) :: error - - !local - logical :: do_nneighb_only, do_min_images_only - integer :: i, j, n, m, jshift(3), ishift(3) - - integer :: n_i, keep_row(4), in_i, min_image - integer, allocatable, dimension(:) :: repeats - real(dp), allocatable, dimension(:) :: normsqshift - type(Connection), pointer :: use_connect - - INIT_ERROR(error) - - if (present(debugfile)) call print("bfs_step", file=debugfile) - if (present(alt_connect)) then - use_connect => alt_connect - else - use_connect => this%connect - endif - - if (present(debugfile)) call print("bfs_step cutoff " // this%cutoff, file=debugfile) - - if (.not.use_connect%initialised) then - RAISE_ERROR('BFS_Step: Atomic structure has no connectivity data', error) - endif - - do_nneighb_only = optional_default(.true., nneighb_only) - - do_min_images_only = optional_default(.false., min_images_only) - - if (present(debugfile)) call print('bfs_step: do_nneighb_only = ' // do_nneighb_only // ' do_min_images_only = '//do_min_images_only, file=debugfile) - call print('bfs_step: do_nneighb_only = ' // do_nneighb_only // ' do_min_images_only = '//do_min_images_only, PRINT_NERD) - - if(input%intsize /= 4 .or. input%realsize /= 0) then - RAISE_ERROR("bfs_step: input table must have intsize=4.", error) - endif - - call allocate(output, 4, 0, 0, 0) - - ! Now go though the atomic indices - do m = 1, input%N - i = input%int(1,m) - ishift = input%int(2:4,m) - - if (present(debugfile)) call print("bfs_step check atom " // m // " " // i // " with n_neigh " // n_neighbours(this, i, alt_connect=use_connect), file=debugfile) - ! Loop over i's neighbours - do n = 1, n_neighbours(this,i, alt_connect=use_connect) - j = neighbour(this,i,n,shift=jshift,max_dist=max_r, alt_connect=use_connect) - if (present(debugfile)) call print("bfs_step check neighbour " // n // " " // j, file=debugfile) - if (j == 0) cycle - - ! Look at next neighbour if j with correct shift is already in the cluster - ! Must check input AND output tables - if (find(input,(/j,ishift+jshift/)) > 0) cycle - if (present(debugfile)) call print("bfs_step not in input", file=debugfile) - if (find(output,(/j,ishift+jshift/)) > 0) cycle - if (present(debugfile)) call print("bfs_step not in output", file=debugfile) - - if (do_nneighb_only .and. .not. is_nearest_neighbour(this, i, n, alt_connect=use_connect)) cycle - if (present(debugfile)) call print("bfs_step acceptably near neighbor", file=debugfile) - - if (present(property)) then - if (property(j) == 0) cycle - endif - if (present(debugfile)) call print("bfs_step property matches OK", file=debugfile) - - ! Everything checks out ok, so add j to the output table - ! with correct shift - if (present(debugfile)) call print("bfs_step appending", file=debugfile) - call append(output,(/j,ishift+jshift/)) - end do - end do - - if (present(debugfile)) call print("bfs_step raw output", file=debugfile) - if (present(debugfile)) call print(output, file=debugfile) - - if (do_min_images_only) then - - ! If there are repeats of any atomic index, - ! we want to keep the one with smallest normsq(shift) - - ! must check input and output - - n = 1 - do while (n <= output%N) - - ! How many occurances in the output list? - n_i = count(int_part(output,1) == output%int(1,n)) - - ! Is there one in the input list as well? - in_i = find_in_array(int_part(input,1),output%int(1,n)) - - ! If there's only one, and we've not got one already then move on - if (n_i == 1 .and. in_i == 0) then - n = n + 1 - cycle - end if - - ! otherwise, things are more complicated... - ! we want to keep the one with the smallest shift, bearing - ! in mind that it could well be the one in the input list - - allocate(repeats(n_i), normsqshift(n_i)) - - ! Get indices of repeats of this atomic index - repeats = pack((/ (j, j=1,output%N) /), & - int_part(output,1) == output%int(1,n)) - - if (in_i /= 0) then - ! atom is in input list, remove all new occurances - call delete_multiple(output, repeats) - else - ! Find row with minimum normsq(shift) - normsqshift = normsq(real(output%int(2:4,repeats),dp),1) - min_image = repeats(minloc(normsqshift,dim=1)) - keep_row = output%int(:,min_image) - - ! keep the minimum image - call delete_multiple(output, & - pack(repeats, repeats /= min_image)) - end if - - ! don't increment n, since delete_multiple copies items from - ! end of list over deleted items, so we need to retest - - deallocate(repeats, normsqshift) - - end do - - end if - - if (present(debugfile)) call print("bfs_step final output", file=debugfile) - if (present(debugfile)) call print(output, file=debugfile) - - end subroutine bfs_step - - - !% Check if the list of indices and shifts 'list' contains - !% any repeated atomic indices. - function multiple_images(list) - type(Table), intent(in) :: list - logical :: multiple_images - - - integer :: i - multiple_images = .false. - - if (list%N == 0) return - - do i = 1, list%N - if (count(int_part(list,1) == list%int(1,i)) /= 1) then - multiple_images = .true. - return - end if - end do - - end function multiple_images - - !% Given an input list with 4 integer columns for atomic indices - !% and shifts, keep only the minimum images of each atom - subroutine discard_non_min_images(list) - type(Table), intent(inout) :: list - - integer :: n, n_i, j, min_image, keep_row(4) - integer, allocatable, dimension(:) :: repeats - real(dp), allocatable, dimension(:) :: normsqshift - - n = 1 - do while (n <= list%N) - - ! How many occurances in the list list? - n_i = count(int_part(list,1) == list%int(1,n)) - - ! If there's only one, and we've not got one already then move on - if (n_i == 1) then - n = n + 1 - cycle - end if - - ! otherwise, things are more complicated... - ! we want to keep the one with the smallest shift - - allocate(repeats(n_i), normsqshift(n_i)) - - ! Get indices of repeats of this atomic index - repeats = pack((/ (j, j=1,list%N) /), & - int_part(list,1) == list%int(1,n)) - - ! Find row with minimum normsq(shift) - normsqshift = normsq(real(list%int(2:4,repeats),dp),1) - min_image = repeats(minloc(normsqshift,dim=1)) - keep_row = list%int(:,min_image) - - ! keep the minimum image - call delete_multiple(list, & - pack(repeats, repeats /= min_image)) - - ! don't increment n, since delete_multiple copies items from - ! end of list over deleted items, so we need to retest - - deallocate(repeats, normsqshift) - - end do - - end subroutine discard_non_min_images - - - !% Add atoms to 'list' to make the selection region convex, i.e. if $i$ and - !% $j$ are nearest neighbours, with $i$ in the list and not $j$ then $j$ will be added - !% if more than half its nearest neighbours are in the list. - subroutine make_convex(this, list) - type(Atoms), intent(in) :: this - type(Table), intent(inout) :: list - type(Table)::tmplist - do while(make_convex_step(this, list, tmplist) /= 0) - call append(list, tmplist) - end do - call finalise(tmplist) - end subroutine make_convex - - !% OMIT - ! Given an input list, what needs to be added to make the selection region convex? - function make_convex_step(this, input, output, error) result(newatoms) - type(Atoms), intent(in) :: this - type(Table), intent(in) :: input - type(Table), intent(out) :: output - integer, optional, intent(out) :: error - integer::newatoms - - integer :: n, i, j, k, p, m, n_in, nn, ishift(3), jshift(3), kshift(3) - real(dp) :: r_ij, r_kj - - INIT_ERROR(error) - - ! Check table size - if(input%intsize /= 4 .or. input%realsize /= 0) then - RAISE_ERROR("make_convex_step: input table must have intsize=4", error) - endif - - if(input%intsize /= 4 .or. input%realsize /= 0) then - RAISE_ERROR("bfs_step: input table must have intsize=4.", error) - endif - - call allocate(output, 4, 0, 0, 0) - - do n=1,input%N - i = input%int(1,n) - ishift = input%int(2:4,n) - - !Loop over neighbours - do m = 1, n_neighbours(this,i) - j = neighbour(this,i,m, r_ij,shift=jshift) - - ! Look for nearest neighbours of i not in input list - if (find(input,(/j,ishift+jshift/)) == 0 .and. is_nearest_neighbour(this, i, m)) then - - n_in = 0 - nn = 0 - ! Count number of nearest neighbours of j, and how many - ! of them are in input list - do p = 1, n_neighbours(this,j) - k = neighbour(this,j,p, r_kj, shift=kshift) - if (is_nearest_neighbour(this, j, p)) then - nn = nn + 1 - if (find(input,(/k,ishift+jshift+kshift/)) /= 0) n_in = n_in + 1 - end if - end do - - !If more than half of j's nearest neighbours are in then add it to output - if (find(output, (/j,ishift+jshift/)) == 0 .and. real(n_in,dp)/real(nn,dp) > 0.5_dp) & - call append(output, (/j,ishift+jshift/)) - - end if - - end do - end do - - newatoms = output%N - - end function make_convex_step - - -! Gotcha 1: Hollow sections -! NB equivalent to reduce_n_cut_bonds when new number of bonds is 0 -! JRK: reduce_n_cut_bonds() is not equivalent to cluster_in_out_in() -! for silica, where adding IN-OUT-IN atoms doesn't change number of -! cut bonds OUT and IN refers to the list in cluster_info Look at the -! OUT nearest neighbours of IN atoms. If mode='all', then if ALL the -! nearest neighbours of the OUT atom are IN, then make the OUT atom -! IN. If mode='any', then add the OUT atom if ANY of it's nearest -! neighours (apart from the original IN atom)! are IN. This stronger -! condition is required for cp2k. - -function cluster_in_out_in(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, mode) result(cluster_changed) - type(Atoms), intent(in) :: this - type(Table), intent(inout) :: cluster_info - logical, intent(in) :: connectivity_just_from_connect - type(Connection), intent(in) :: use_connect - logical, intent(in) :: atom_mask(6) - character(len=*), intent(in) :: mode - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3), p, k, kshift(3), n_nearest, n_in - logical :: add_atom - - cluster_changed = .false. - if (trim(mode) /= 'all' .and. trim(mode) /= 'any') & - call system_abort('cluster_in_out_in: bad mode '//mode//' - should be "all" or "any"') - - n = 1 - ! Loop over cluster atoms (including ones that may get added in this loop) - call print('cluster_in_out_in: Checking for hollow sections', PRINT_NERD) - do while (n <= cluster_info%N) - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - call print('cluster_in_out_in: i = '//i//' ['//ishift//'] Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - - !Loop over neighbours - do m = 1, n_neighbours(this,i,alt_connect=use_connect) - j = neighbour(this,i,m, shift=jshift,alt_connect=use_connect) - - if (find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) == 0 .and. & - (connectivity_just_from_connect .or. is_nearest_neighbour(this, i, m, alt_connect=use_connect)) ) then - ! j is out and is nearest neighbour - - call print('cluster_in_out_in: checking j = '//j//" ["//jshift//"]",PRINT_ANALYSIS) - - ! We have an OUT nearest neighbour, loop over its nearest neighbours to see if they are IN - - n_nearest = 0 - n_in = 0 - do p = 1, n_neighbours(this,j,alt_connect=use_connect) - k = neighbour(this,j,p, shift=kshift,alt_connect=use_connect) - if (k == i) cycle - if (connectivity_just_from_connect .or. is_nearest_neighbour(this, j, p,alt_connect=use_connect)) then - n_nearest = n_nearest + 1 - if (find(cluster_info,(/k,ishift+jshift+kshift,this%Z(k),0/), atom_mask) /= 0) then - n_in = n_in + 1 - end if - end if - end do - - if (trim(mode) == "all") then - !If all of j's nearest neighbours are IN then add it - add_atom = n_nearest == n_in - else - !If any of j's nearest neighbours (apart from i) are in then add it - add_atom = n_in /= 0 - end if - - if (add_atom) then - call append(cluster_info, (/j,ishift+jshift,this%Z(j),0/), (/this%pos(:,j), 1.0_dp/), (/ "inoutin "/) ) - cluster_changed = .true. - call print('cluster_in_out_in: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - end if - - end if - - end do ! m - n = n + 1 - end do ! while (n <= cluster_info%N) - - call print('cluster_in_out_in: Finished checking',PRINT_NERD) - call print("cluster_in_out_in: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) -end function cluster_in_out_in - - !% Find cases where two IN atoms have a common - !% OUT nearest neighbour, and see if termination would cause the hydrogen - !% atoms to be too close together. If so, include the OUT nearest neighbour - !% in the cluster - !% returns true if cluster was changed - function cluster_fix_termination_clash(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, termination_clash_factor) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - real(dp), intent(in) :: termination_clash_factor - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3), p, k, kshift(3) - real(dp) :: dhat_ij(3), dhat_jk(3), r_ij, r_jk, H1(3), H2(3), diff_ik(3) - ! real(dp) :: t_norm - - cluster_changed = .false. - - call print('doing cluster_fix_termination_clash', PRINT_NERD) - - !Loop over atoms in the cluster - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) ! index of atom in the cluster - ishift = cluster_info%int(2:4,n) - call print('cluster_fix_termination_clash: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - !Loop over atom i's neighbours - do m = 1, n_neighbours(this,i,alt_connect=use_connect) - j = neighbour(this,i,m, shift=jshift, diff=dhat_ij, distance=r_ij,alt_connect=use_connect) - dhat_ij = dhat_ij/r_ij - - !If j is IN the cluster, or not a nearest neighbour then try the next neighbour - if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then - call print('cluster_fix_termination_clash: j = '//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) - cycle - end if - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print('cluster_fix_termination_clash: j = '//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - ! So j is an OUT nearest neighbour of i. - call print('cluster_fix_termination_clash: checking j = '//j//" ["//jshift//"]",PRINT_ANALYSIS) - - !Determine the position of the would-be hydrogen along i--j - call print('cluster_fix_termination_clash: Finding i--j hydrogen position',PRINT_ANALYSIS) - - H1 = this%pos(:,i) + (this%lattice .mult. (ishift)) + & - termination_bond_rescale(this%Z(i), this%Z(j)) * r_ij * dhat_ij - - !Do a loop over j's nearest neighbours - call print('cluster_fix_termination_clash: Looping over '//n_neighbours(this,j, alt_connect=use_connect)//' neighbours of j', PRINT_ANALYSIS) - - do p = 1, n_neighbours(this,j, alt_connect=use_connect) - k = neighbour(this,j,p, shift=kshift, diff=dhat_jk, distance=r_jk, alt_connect=use_connect) - dhat_jk = dhat_jk/r_jk - - !If k is OUT of the cluster or k == i or it is not a nearest neighbour of j - !then try the next neighbour - - if(find(cluster_info,(/k,ishift+jshift+kshift,this%Z(k),0/), atom_mask) == 0) then - call print('cluster_fix_termination_clash: k = '//k//" ["//kshift//"] not in cluster",PRINT_ANALYSIS) - cycle - end if - if(k == i .and. all( jshift+kshift == 0 )) cycle - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,j, p, alt_connect=use_connect))) then - call print('cluster_fix_termination_clash: k = '//k//" ["//kshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - call print('cluster_fix_termination_clash: testing k = '//k//" ["//kshift//"]", PRINT_ANALYSIS) - !Determine the position of the would-be hydrogen along k--j - call print('cluster_fix_termination_clash: Finding k--j hydrogen position',PRINT_ANALYSIS) - - diff_ik = r_ij * dhat_ij + r_jk * dhat_jk - - H2 = this%pos(:,i) + (this%lattice .mult. (ishift)) + diff_ik - & - termination_bond_rescale(this%Z(k), this%Z(j)) * r_jk * dhat_jk - call print('cluster_fix_termination_clash: Checking i--k distance and hydrogen distance',PRINT_ANALYSIS) - - call print("cluster_fix_termination_clash: proposed hydrogen positions:", PRINT_ANALYSIS) - call print(H1, PRINT_ANALYSIS) - call print(H2, PRINT_ANALYSIS) - call print('norm(H1-H2) '//norm(H1-H2)//' tol'//(bond_length(1,1)*this%nneightol*termination_clash_factor), PRINT_ANALYSIS) - !NB workaround for pgf90 bug (as of 9.0-1) - ! t_norm = norm(H1-H2); call print("cluster_fix_termination_clash: hydrogen distance would be "//t_norm, PRINT_ANALYSIS) - !NB end of workaround for pgf90 bug (as of 9.0-1) - ! If i and k are nearest neighbours, or the terminating hydrogens would be very close, then - ! include j in the cluster. The H--H checking is conservative, hence the extra factor of 1.2 - if ((norm(diff_ik) < bond_length(this%Z(i),this%Z(k))*this%nneightol) .or. & - (norm(H1-H2) < bond_length(1,1)*this%nneightol*termination_clash_factor) ) then - - call append(cluster_info,(/j,ishift+jshift,this%Z(j),0/),(/this%pos(:,j),1.0_dp/), (/ "clash "/) ) - cluster_changed = .true. - call print('cluster_fix_termination_clash: Atom '//j//'with shift '//(ishift+jshift)//' added to cluster. Atoms = '//cluster_info%N, PRINT_NERD) - ! j is now included in the cluster, so we can exit this do loop (over p) - exit - end if - - end do ! p - - end do ! m - - end do ! while (n <= cluster_info%N) - - call print('cluster_fix_termination_clash: Finished checking',PRINT_NERD) - call print("cluster_fix_termination_clash: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - end function cluster_fix_termination_clash - - !% keep each whole residue (using atom_res_number(:) property) if any bit of it is already included - function cluster_keep_whole_residues(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_keep_whole_residues) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical, intent(in) :: present_keep_whole_residues !% if true, keep_whole_residues was specified by user, not just a default value - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - integer, pointer :: atom_res_number(:) - - call print('doing cluster_keep_whole_residues', PRINT_NERD) - - cluster_changed = .false. - if (.not. assign_pointer(this, 'atom_res_number', atom_res_number)) then - if (present_keep_whole_residues) then - call print("WARNING: cluster_keep_whole_residues got keep_whole_residues requested explicitly, but no proper atom_res_number property available", PRINT_ALWAYS) - endif - return - endif - - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - if (atom_res_number(i) < 0) cycle - call print('cluster_keep_whole_residues: i = '//i//' residue # = ' // atom_res_number(i) //'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - - if (atom_res_number(i) /= atom_res_number(j)) then - call print("cluster_keep_whole_residues: j = "//j//" ["//jshift//"] has different res number " // atom_res_number(j), PRINT_ANALYSIS) - cycle - endif - if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then - call print("cluster_keep_whole_residues: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) - cycle - end if - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_keep_whole_residues: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"res_num "/) ) - cluster_changed = .true. - call print('cluster_keep_whole_residues: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - - end do ! m - end do ! while (n <= cluster_info%N) - - call print('cluster_keep_whole_residues: Finished checking',PRINT_NERD) - call print("cluster_keep_whole_residues: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - - end function cluster_keep_whole_residues - - !% keep each whole proline (using atom_subgroup_number(:) and atom_res_number(:) property) if any bit of it is already included - function cluster_keep_whole_prolines(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_keep_whole_prolines) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical, intent(in) :: present_keep_whole_prolines !% if true, keep_whole_prolines was specified by user, not just a default value - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - integer, pointer :: atom_res_number(:), atom_subgroup_number(:) - logical :: is_proline - - call print('doing cluster_keep_whole_prolines', PRINT_NERD) - - cluster_changed = .false. - if (.not. assign_pointer(this, 'atom_res_number', atom_res_number) .or. .not. assign_pointer(this, 'atom_subgroup_number', atom_subgroup_number)) then - if (present_keep_whole_prolines) then - call print("WARNING: cluster_keep_whole_prolines got keep_whole_prolines requested explicitly, but no proper atom_res_number or atom_subgroup_number properties available", PRINT_ALWAYS) - endif - return - endif - - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - if (atom_res_number(i) < 0) cycle - call print('cluster_keep_whole_prolines: i = '//i//' residue # = ' // atom_res_number(i) //' subgroup # = '// atom_subgroup_number(i) // & - '. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - is_proline = .false. - - if (atom_res_number(i) /= atom_res_number(j)) then - call print("cluster_keep_whole_prolines: j = "//j//" ["//jshift//"] has different res number " // atom_res_number(j), PRINT_ANALYSIS) - cycle - endif - if (atom_subgroup_number(i) <= -10 .or. atom_subgroup_number(j) <= -10) then - call print("cluster_keep_whole_prolines: j = "//j//" ["//jshift//"] has proline subgroup number " // atom_subgroup_number(j), PRINT_ANALYSIS) - is_proline = .true. - endif - if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then - call print("cluster_keep_whole_prolines: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) - cycle - end if - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_keep_whole_prolines: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - if (is_proline) then - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"subgp_num "/) ) - cluster_changed = .true. - call print('cluster_keep_whole_prolines: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - endif - - end do ! m - - end do ! while (n <= cluster_info%N) - - call print('cluster_keep_whole_prolines: Finished checking',PRINT_NERD) - call print("cluster_keep_whole_prolines: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - - end function cluster_keep_whole_prolines - - !% keep each proline sidechain and directly connected bit of backbone (using atom_subgroup_number and atom_res_number(:) property) if any bit of it is already included - function cluster_keep_whole_proline_sidechains(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_keep_whole_proline_sidechains) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical, intent(in) :: present_keep_whole_proline_sidechains !% if true, keep_whole_proline_sidechains was specified by user, not just a default value - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - integer, pointer :: atom_res_number(:), atom_subgroup_number(:) - logical :: is_proline - - call print('doing cluster_keep_whole_proline_sidechains', PRINT_NERD) - - cluster_changed = .false. - if (.not. assign_pointer(this, 'atom_res_number', atom_res_number) .or. .not. assign_pointer(this, 'atom_subgroup_number', atom_subgroup_number)) then - if (present_keep_whole_proline_sidechains) then - call print("WARNING: cluster_keep_whole_proline_sidechains got keep_whole_proline_sidechains requested explicitly, but no proper atom_res_number or atom_subgroup_number properties available", PRINT_ALWAYS) - endif - return - endif - - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - if (atom_res_number(i) < 0) cycle - call print('cluster_keep_whole_proline_sidechains: i = '//i//' residue # = ' // atom_res_number(i) //' subgroup # = '// atom_subgroup_number(i) // & - '. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - is_proline = .false. - - if (atom_res_number(i) /= atom_res_number(j)) then - call print("cluster_keep_whole_proline_sidechains: j = "//j//" ["//jshift//"] has different res number " // atom_res_number(j), PRINT_ANALYSIS) - cycle - endif - if (atom_subgroup_number(i) == -1000 .or. atom_subgroup_number(j) == -1000) then - call print("cluster_keep_proline_sidechains: i or j = "//j//" ["//jshift//"] has proline sidechain subgroup number " // atom_subgroup_number(j), PRINT_ANALYSIS) - is_proline = .true. - endif - if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then - call print("cluster_keep_proline_sidechains: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) - cycle - end if - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_keep_whole_proline_sidechains: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - if (is_proline) then - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"subgp_num "/) ) - cluster_changed = .true. - call print('cluster_keep_whole_proline_sidechains: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - endif - - end do ! m - - end do ! while (n <= cluster_info%N) - - call print('cluster_keep_whole_proline_sidechains: Finished checking',PRINT_NERD) - call print("cluster_keep_whole_proline_sidechains: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - - end function cluster_keep_whole_proline_sidechains - - !% keep each whole subgroup (using atom_subgroup_number and atom_res_number(:) property) if any bit of it is already included - function cluster_keep_whole_subgroups(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_keep_whole_subgroups) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical, intent(in) :: present_keep_whole_subgroups !% if true, keep_whole_subgroups was specified by user, not just a default value - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - integer, pointer :: atom_res_number(:), atom_subgroup_number(:) - - call print('doing cluster_keep_whole_subgroups', PRINT_NERD) - - cluster_changed = .false. - if (.not. assign_pointer(this, 'atom_res_number', atom_res_number) .or. .not. assign_pointer(this, 'atom_subgroup_number', atom_subgroup_number)) then - if (present_keep_whole_subgroups) then - call print("WARNING: cluster_keep_whole_subgroups got keep_whole_subgroups requested explicitly, but no proper atom_res_number or atom_subgroup_number properties available", PRINT_ALWAYS) - endif - return - endif - - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - if (atom_res_number(i) < 0) cycle - if (atom_subgroup_number(i) == 0) cycle - call print('cluster_keep_whole_subgroups: i = '//i//' residue # = ' // atom_res_number(i) //' subgroup # = '// atom_subgroup_number(i) // '. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - call print("cluster_keep_whole_subgroups: m = " // m //" j = " // j, PRINT_ANALYSIS) - if (atom_res_number(j) < 0) cycle - if (atom_subgroup_number(j) == 0) cycle - - if (atom_res_number(i) /= atom_res_number(j)) then - call print("cluster_keep_whole_subgroups: j = "//j//" ["//jshift//"] has different res number " // atom_res_number(j), PRINT_ANALYSIS) - cycle - endif - if (atom_subgroup_number(i) /= atom_subgroup_number(j)) then - call print("cluster_keep_whole_subgroups: j = "//j//" ["//jshift//"] has different subgroup number " // atom_subgroup_number(j), PRINT_ANALYSIS) - cycle - endif - if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then - call print("cluster_keep_whole_subgroups: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) - cycle - end if - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_keep_whole_subgroups: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"subgp_num "/) ) - cluster_changed = .true. - call print('cluster_keep_whole_subgroups: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - - end do ! m - - end do ! while (n <= cluster_info%N) - - call print('cluster_keep_whole_subgroups: Finished checking',PRINT_NERD) - call print("cluster_keep_whole_subgroups: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - - end function cluster_keep_whole_subgroups - - !% keep whole silica tetrahedra -- that is, for each silicon atom, keep all it's oxygen nearest neighbours - function cluster_keep_whole_silica_tetrahedra(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - - call print('doing cluster_keep_whole_silica_tetrahedra', PRINT_NERD) - - cluster_changed = .false. - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - if (this%z(i) /= 14) then - ! Consider only silicon atoms, which form centres of tetrahedra - cycle - end if - - call print('cluster_keep_whole_silica_tetrahedra: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - - if (this%z(j) /= 8) then - call print("cluster_keep_whole_silica_tetrahedra: j = "//j//" ["//jshift//"] is not oxygen ", PRINT_ANALYSIS) - cycle - endif - if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then - call print("cluster_keep_whole_silica_tetrahedra: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) - cycle - end if - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_keep_whole_silica_tetrahedra: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"tetra "/) ) - cluster_changed = .true. - call print('cluster_keep_whole_silica_tetrahedra: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - - end do ! m - - end do ! while (n <= cluster_info%N) - - call print('cluster_keep_whole_silica_tetrahedra: Finished checking',PRINT_NERD) - call print("cluster_keep_whole_silica_tetrahedra: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - - end function cluster_keep_whole_silica_tetrahedra - - !% keep whole octahedra for titania that is, for each Ti atom, keep all it's oxygen nearest neighbours but the O atoms with only 1 neighbour. - function cluster_keep_whole_titania_octahedra(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - - call print('doing cluster_keep_whole_titania_octahedra', PRINT_NERD) - - cluster_changed = .false. - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - if (this%z(i) /= 22) then - ! Consider only Ti atoms, which form centres of tetrahedra - cycle - end if - - call print('cluster_keep_whole_titania_octahedra: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - - if (this%z(j) /= 8) then - call print("cluster_keep_whole_titania_octahedra: j = "//j//" ["//jshift//"] is not oxygen ", PRINT_ANALYSIS) - cycle - endif - if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then - call print("cluster_keep_whole_titania_octahedra: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) - cycle - end if - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_keep_whole_titania_octahedra: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - !check if the oxygen has more than 1 neighbour in the cluster. -! neigh_O = 0 -! do l=1,n_neighbours(this, j, alt_connect=use_connect) -! k = neighbour(this, j, l, distance=rdist, shift=kshift, alt_connect=use_connect) -! if(find(cluster_info,(/k,ishift+jshift+kshift,this%Z(k),0/), atom_mask) == 0) then -! call print(" j : "// j // " Z(j) :" // this%Z(j) // ' shift ' // jshift) -! call print(" k : "// k // " Z(k) :" // this%Z(k) // ' shift ' // kshift) -! call print(" i : "// i // " Z(i) :" // this%Z(i) // ' shift ' // ishift) -! call print('distance between k and j '// rdist) -! call print("cluster_keep_whole_titania_octahedra: k = "//k//" ["//kshift//"] is not in cluster",PRINT_ANALYSIS) -! cycle -! end if -! if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,j, l, alt_connect=use_connect))) then -! call print(" j : "// j // " Z(j) :" // this%Z(j) // ' shift ' // jshift) -! call print(" k : "// k // " Z(k) :" // this%Z(k) // ' shift ' // kshift) -! call print(" i : "// i // " Z(i) :" // this%Z(i) // ' shift ' // ishift) -! call print('distance between k and j '// rdist) -! call print("cluster_keep_whole_titania_octahedra: k = "//k//" ["//kshift//"] not nearest neighbour",PRINT_ANALYSIS) -! cycle -! end if -! neigh_O = neigh_O + 1 -! end do ! l - - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"octa "/) ) - cluster_changed = .true. - call print('cluster_keep_whole_titania_octahedra Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - - end do ! m - - - end do ! while (n <= cluster_info%N) - - call print('cluster_keep_whole_titania_octahedra: Finished checking',PRINT_NERD) - call print("cluster_keep_whole_titania_octahedra: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - - end function cluster_keep_whole_titania_octahedra - - !% adding each neighbour outside atom if doing so immediately reduces the number of cut bonds - function cluster_reduce_n_cut_bonds(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3), p, k, kshift(3) - integer :: n_bonds_in, n_bonds_out - - call print('doing cluster_reduce_n_cut_bonds', PRINT_NERD) - - cluster_changed = .false. - - ! loop over each atom in the cluster already - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - call print('cluster_reduce_n_cut_bonds: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - - ! loop over every neighbour, looking for outside neighbours - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_reduce_n_cut_bonds: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - ! if we're here, j must be an outside neighbour of i - call print('cluster_reduce_n_cut_bonds: j = '//j//'. Looping over '//n_neighbours(this,j,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - - n_bonds_in = 0 - n_bonds_out = 0 - do p=1, n_neighbours(this, j, alt_connect=use_connect) - k = neighbour(this, j, p, shift=kshift, alt_connect=use_connect) - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,j, p, alt_connect=use_connect))) then - call print("cluster_reduce_n_cut_bonds: k = "//k//" ["//kshift//"] not nearest neighbour of j = " // j,PRINT_ANALYSIS) - cycle - end if - ! count how many bonds point in vs. out - if (find(cluster_info, (/ k, ishift+jshift+kshift, this%Z(k), 0 /), atom_mask ) /= 0) then - n_bonds_in = n_bonds_in + 1 - else - n_bonds_out = n_bonds_out + 1 - endif - end do ! p - - if (n_bonds_out < n_bonds_in) then ! adding this one would reduce number of cut bonds - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"n_cut_bond" /) ) - cluster_changed = .true. - call print('cluster_reduce_n_cut_bonds: Added atom ' //j//' ['//(ishift+jshift)//'] n_bonds_in ' // n_bonds_in // & - ' out ' // n_bonds_out // ' to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - endif - end do ! m - - end do ! while (n <= cluster_info%N) - - call print('cluster_reduce_n_cut_bonds: Finished checking',PRINT_NERD) - call print("cluster_reduce_n_cut_bonds: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - end function cluster_reduce_n_cut_bonds - - !% Go through the cluster atoms and find cut bonds. If the bond is to - !% hydrogen, then include the hydrogen in the cluster list (since AMBER - !% doesn't cap a bond to hydrogen with a link atom) - function cluster_protect_X_H_bonds(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - - call print('doing cluster_protect_X_H_bonds', PRINT_NERD) - cluster_changed = .false. - - ! loop over each atom in the cluster already - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - call print('cluster_protect_X_H_bonds: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - - ! loop over every neighbour, looking for outside neighbours - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - - ! if j is in, or not a nearest neighbour, go on to next - if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_protect_X_H_bonds: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - ! if we're here, j must be an outside neighbour of i - - if (this%Z(i) == 1 .or. this%Z(j) == 1) then - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"X_H_bond " /) ) - cluster_changed = .true. - call print('cluster_protect_X_H_bonds: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - endif - end do ! m - - end do ! while (n <= cluster_info%N) - - call print('cluster_protect_X_H_bonds: Finished checking',PRINT_NERD) - call print("cluster_protect_X_H_bonds: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - end function cluster_protect_X_H_bonds - - !% Go through the cluster atoms and find cut bonds. - !% Include the bonded-to atom in the cluster list. - !% cheap alternative to keep_residues_whole - function cluster_keep_whole_molecules(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - - call print('doing cluster_keep_whole_molecules', PRINT_NERD) - cluster_changed = .false. - - ! loop over each atom in the cluster already - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - call print('cluster_keep_whole_molecules: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) - - ! loop over every neighbour, looking for outside neighbours - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - - ! if j is in, or not a nearest neighbour, go on to next - if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_keep_whole_molecules: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - ! if we're here, j must be an outside neighbour of i - - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"molec " /) ) - cluster_changed = .true. - call print('cluster_keep_whole_molecules: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - end do ! m - - end do ! while (n <= cluster_info%N) - - call print('cluster_keep_whole_molecules: Finished checking',PRINT_NERD) - call print("cluster_keep_whole_molecules: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - end function cluster_keep_whole_molecules - - !if by accident a single atom is included, that is part of a larger entity (not ion) - !then delete it from the list as it will cause error in SCF (e.g. C=O oxygen) - !call allocate(to_delete,4,0,0,0,1) - !do n = 1, cluster%N - ! i = cluster%int(1,n) - ! is_alone = .true. - ! do j = 1, n_neighbours(at,i) - ! k = neighbour(at,i,j) - ! if(find(cluster_info,(/k,shift/)) /= 0) then - ! if(is_nearest_neighbour(at,i,j)) GOTO 120 - ! else - ! if(is_nearest_neighbour(at,i,j)) is_alone = .false. - ! end if - ! end do - ! if(.not. is_alone) call append(to_delete,(/i,shift/)) - ! 120 cycle - !end do - - !do i = 1, to_delete%N - ! call delete(cluster_info,to_delete%int(:,i)) - !end do - -!OUTDATED function cluster_biochem_in_out_in(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) -!OUTDATED type(Atoms), intent(in) :: this -!OUTDATED type(Table), intent(inout) :: cluster_info -!OUTDATED logical, intent(in) :: connectivity_just_from_connect -!OUTDATED type(Connection), intent(in) :: use_connect -!OUTDATED logical, intent(in) :: atom_mask(6) -!OUTDATED logical :: cluster_changed -!OUTDATED -!OUTDATED integer :: n, i, ishift(3), m, j, jshift(3), p, k, kshift(3) -!OUTDATED -!OUTDATED call print('doing cluster_biochem_in_out_in', PRINT_NERD) -!OUTDATED cluster_changed = .false. -!OUTDATED -!OUTDATED ! loop over each atom in the cluster already -!OUTDATED n = 1 -!OUTDATED do while (n <= cluster_info%N) -!OUTDATED i = cluster_info%int(1,n) -!OUTDATED ishift = cluster_info%int(2:4,n) -!OUTDATED call print('cluster_reduce_n_cut_bonds: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) -!OUTDATED -!OUTDATED ! loop over every neighbour, looking for outside neighbours -!OUTDATED do m=1, n_neighbours(this, i, alt_connect=use_connect) -!OUTDATED j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) -!OUTDATED -!OUTDATED ! if j is in, or not a neareste neighbour, go on to next -!OUTDATED if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle -!OUTDATED if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then -!OUTDATED call print("cluster_reduce_n_cut_bonds: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) -!OUTDATED cycle -!OUTDATED end if -!OUTDATED ! if we're here, j must be an outside neighbour of i -!OUTDATED call print('cluster_reduce_n_cut_bonds: j = '//j//'. Looping over '//n_neighbours(this,j,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) -!OUTDATED -!OUTDATED do p=1, n_neighbours(this, j, alt_connect=use_connect) -!OUTDATED k = neighbour(this, j, p, shift=kshift, alt_connect=use_connect) -!OUTDATED if (k == i .and. all(jshift + kshift == 0)) cycle -!OUTDATED if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,j, p, alt_connect=use_connect))) then -!OUTDATED call print("cluster_reduce_n_cut_bonds: k = "//k//" ["//kshift//"] not nearest neighbour of j = " // j,PRINT_ANALYSIS) -!OUTDATED cycle -!OUTDATED end if -!OUTDATED ! if k is in, then j has 2 in neighbours, and so we add it -!OUTDATED if (find(cluster_info, (/ k, ishift+jshift+kshift, this%Z(k), 0 /), atom_mask ) /= 0) then -!OUTDATED call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"bio_IOI " /) ) -!OUTDATED cluster_changed = .true. -!OUTDATED call print('cluster_biochem_in_out_in: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) -!OUTDATED exit -!OUTDATED end if -!OUTDATED end do ! p -!OUTDATED end do ! m -!OUTDATED -!OUTDATED n = n + 1 -!OUTDATED end do ! while (n <= cluster_info%N) -!OUTDATED -!OUTDATED call print('cluster_biochem_in_out_in: Finished checking',PRINT_NERD) -!OUTDATED call print("cluster_biochem_in_out_in: cluster list:", PRINT_NERD) -!OUTDATED call print(cluster_info, PRINT_NERD) -!OUTDATED end function cluster_biochem_in_out_in - - !% if an in non-H atom is in a residue and not at right coordination, add all of its neighbours - function cluster_protect_double_bonds(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_protect_double_bonds) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical, intent(in) :: present_protect_double_bonds !% if true, protect_double_bonds was specified by user, not just a default value - logical :: cluster_changed - - integer :: n, i, ishift(3), m, j, jshift(3) - integer :: n_nearest_neighbours - integer, pointer :: atom_res_number(:) - - call print('doing cluster_protect_double_bonds', PRINT_NERD) - cluster_changed = .false. - - if (.not. assign_pointer(this, 'atom_res_number', atom_res_number)) then - if (present_protect_double_bonds) then - call print("WARNING: cluster_protect_double_bonds got protect_double_bonds requested explicitly, but no proper atom_res_number property available", PRINT_ALWAYS) - endif - return - endif - - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - - if (this%Z(i) /= 0 .and. atom_res_number(i) >= 0) then - - ! count nearest neighbours of i - n_nearest_neighbours = 0 - do m=1, n_neighbours(this, i, alt_connect=use_connect) - j = neighbour(this, i, m, alt_connect=use_connect) - - ! if j is not nearest neighbour, go on to next one - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_protect_double_bonds: j = "//j//" not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - ! if we're here, j must be an outside neighbour of i - n_nearest_neighbours = n_nearest_neighbours + 1 - end do ! m - - if (ElementValence(this%Z(i)) /= -1 .and. (ElementValence(this%Z(i)) /= n_nearest_neighbours)) then ! i has a valence, and it doesn't match nn# - do m=1, n_neighbours(this, i) - j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) - - ! if j is in, or isn't nearest neighbour, go on to next - if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then - call print("cluster_protect_double_bonds: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - ! if we're here, j must be an outside neighbour of i - call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"dbl_bond " /) ) - cluster_changed = .true. - call print('cluster_protect_double_bonds: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - end do ! m - endif ! valence defined - end if ! atom_res_number(i) >= 0 - - end do ! while (n <= cluster_info%N) - - call print('cluster_protect_double_bonds: Finished checking',PRINT_NERD) - call print("cluster_protect_double_bonds: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - end function cluster_protect_double_bonds - - !% protect bond between R-C ... -N-R - !% | | - !% O R (usually H or C (proline)) - function cluster_protect_peptide_bonds(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_protect_peptide_bonds) result(cluster_changed) - type(Atoms), intent(in) :: this !% atoms structure - type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output - logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely - type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info - logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms - logical, intent(in) :: present_protect_peptide_bonds !% if true, protect_peptide_bonds was specified by user, not just a default value - logical :: cluster_changed - - integer :: n, i, ishift(3), ji, j, ki, k, jshift(3) - integer, pointer :: atom_res_number(:) - integer :: found_other_j, found_other_jshift(3) - integer :: this_neighbour_Z, other_neighbour_Z, other_Z - logical :: found_this_neighbour, found_other_neighbour - - call print('doing cluster_protect_peptide_bonds', PRINT_NERD) - cluster_changed = .false. - - if (.not. assign_pointer(this, 'atom_res_number', atom_res_number)) then - if (present_protect_peptide_bonds) then - call print("WARNING: cluster_protect_peptide_bonds got protect_peptide_bonds requested explicitly, but no proper atom_res_number property available", PRINT_ALWAYS) - endif - return - endif - - n = 0 - do while (n < cluster_info%N) - n = n + 1 - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - - if (this%Z(i) /= 0 .and. atom_res_number(i) >= 0) then - - call print("cluster_protect_peptide_bonds: i = "//i//" Z(i) " // this%Z(i), PRINT_ANALYSIS) - - ! peptide bond is C-N - ! | - ! O - if (this%Z(i) == 6) then - other_Z = 7 - this_neighbour_Z = 8 - other_neighbour_Z = 0 - else if (this%Z(i) == 7) then - other_Z = 6 - this_neighbour_Z = 0 - other_neighbour_Z = 8 - else - call print("cluster_protect_peptide_bonds: i = "//i//" not C or N",PRINT_ANALYSIS) - cycle - endif - - found_other_j = 0 - found_this_neighbour = (this_neighbour_Z == 0) - found_other_neighbour = (other_neighbour_Z == 0) - - call print("cluster_protect_peptide_bonds: other_Z " // other_Z // " this_neighbour_Z " // this_neighbour_Z // " other_neighbour_z " // other_neighbour_Z, PRINT_ANALYSIS) - call print("cluster_protect_peptide_bonds: found_this_neighbour " // found_this_neighbour // " found_other_neighbour " // found_other_neighbour, PRINT_ANALYSIS) - - ! must have 3 neighbours - if (n_neighbours(this, i, alt_connect=use_connect) /= 3) then - call print("cluster_protect_peptide_bonds: i = "//i//" doesn't have 3 neighbours",PRINT_ANALYSIS) - cycle - endif - do ji=1, n_neighbours(this, i, alt_connect=use_connect) ! look for correct neighbour - j=neighbour(this, i, ji, shift=jshift, alt_connect=use_connect) - call print("cluster_protect_peptide_bonds: j = " //j//" Z(j) " // this%Z(j), PRINT_ANALYSIS) - ! only nearest neighbours count, usually - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, ji, alt_connect=use_connect))) then - call print("cluster_protect_peptide_bonds: neighbour j = "//j//" not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - if (this%Z(j) == this_neighbour_Z .and. n_neighbours(this, j) == 1) then ! neighbour has right Z and coordination - found_this_neighbour = .true. - call print("cluster_protect_peptide_bonds: neighbour j = "//j//" is neighbor (O) we're looking for",PRINT_ANALYSIS) - endif - if (this%Z(j) == other_Z) then ! found other - ! if j is already in, this isn't a peptide bond in need of protection from being cut - if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask) /= 0) then - call print("cluster_protect_peptide_bonds: other_Z neighbour j = "//j//" already in",PRINT_ANALYSIS) - cycle - endif - ! save info on other - call print("cluster_protect_peptide_bonds: found_other_j " // j // " Z(found_other_j) " // this%Z(j), PRINT_ANALYSIS) - found_other_j = j - found_other_jshift = jshift - - ! if (.not. found_this_neighbour .or. found_other_j == 0) then ! some part of motif missing - ! call print("cluster_protect_peptide_bonds: failed to find this_neighbour_Z or other_j",PRINT_ANALYSIS) - ! cycle - ! endif - - ! other must have 3 neighbours - if (n_neighbours(this, found_other_j, alt_connect=use_connect) /= 3) then - call print("cluster_protect_peptide_bonds: found_other_j = "//found_other_j//" doesn't have 3 neighbours", PRINT_ANALYSIS) - cycle - endif - ! perhaps we should require that other be in a different residue, but not doing that now - ! if (atoms_res_number(i) == atom_res_number(found_other_j)) then - ! call print("cluster_protect_peptide_bonds: i and found_other_j are in the same residue", PRINT_ANALYSIS) - ! cycle - ! endif - - ! check neighbours of other - do ki=1, n_neighbours(this, found_other_j, alt_connect=use_connect) - k=neighbour(this, found_other_j, ki, alt_connect=use_connect) - ! only nearest neighbours count - if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,found_other_j, ki, alt_connect=use_connect))) then - call print("cluster_protect_peptide_bonds: found_other_j's neighbour k = "//k//" not nearest neighbour",PRINT_ANALYSIS) - cycle - end if - - if (this%Z(k) == other_neighbour_Z .and. n_neighbours(this, k) == 1) then ! neighbour has right Z and coordination - found_other_neighbour = .true. - call print("cluster_protect_peptide_bonds: neighbour k = "//k//" is neighbor (O) we're looking for",PRINT_ANALYSIS) - endif - end do ! ki - - ! some part of motif is missing - if (.not. found_other_neighbour) then - call print("cluster_protect_peptide_bonds: couldn't find other_neighbour",PRINT_ANALYSIS) - cycle - endif - - call append(cluster_info, (/ found_other_j, ishift+found_other_jshift, this%Z(found_other_j), 0 /), & - (/ this%pos(:,found_other_j), 1.0_dp /), (/"pep_bond " /) ) - cluster_changed = .true. - call print('cluster_protect_peptide_bonds: Added atom ' //found_other_j//' ['//(ishift+found_other_jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) - endif ! Z(j) == other_Z - end do ! ji - - end if ! Z(i) /= 0 .and. atom_res_number(i) /= 0 - - end do ! while (n <= cluster_info%N) - - call print('cluster_protect_peptide_bonds: Finished checking',PRINT_NERD) - call print("cluster_protect_peptide_bonds: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - end function cluster_protect_peptide_bonds - - subroutine create_cluster_simple(at, args_str, cluster, mark_name, error) - type(Atoms), intent(inout) :: at - character(len=*), intent(in) :: args_str - type(Atoms), intent(out) :: cluster - character(len=*), intent(in), optional :: mark_name - integer, intent(out), optional :: ERROR - - type(Table) :: cluster_info - - INIT_ERROR(error) - - call calc_connect(at) - cluster_info = create_cluster_info_from_mark(at, args_str, mark_name=mark_name, error=error) - PASS_ERROR(error) - call carve_cluster(at, args_str, cluster_info, cluster=cluster, mark_name=mark_name, error=error) - PASS_ERROR(error) - call finalise(cluster_info) - - end subroutine create_cluster_simple - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Create cluster from atoms and cluster information table (which - !% which should be generated by a call to :func:`create_cluster_info_from_hybrid_mark`. - !% - !% The output cluster contains all properties of the initial atoms object, and - !% some additional columns, which are: - !% - !% ``index`` - !% index of the cluster atoms into the initial atoms object. - !% - !% ``termindex`` - !% nonzero for termination atoms, and is an index into - !% the cluster atoms specifiying which atom is being terminated, - !% it is used in collecting the forces. - !% - !% ``rescale`` - !% a real number which for nontermination atoms is 1.0, - !% for termination atoms records the scaling applied to - !% termination bond lengths - !% - !% ``shift`` - !% the shift of each atom - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - subroutine carve_cluster(at, args_str, cluster_info, cluster, mark_name, error) - type(Atoms), intent(in), target :: at - character(len=*), intent(in) :: args_str - type(Table), intent(in) :: cluster_info - type(Atoms), intent(out) :: cluster - character(len=*), optional, intent(in) :: mark_name - integer, optional, intent(out) :: error - - type(Dictionary) :: params - logical :: do_rescale_r - real(dp) :: r_scale, cluster_vacuum, cluster_fix_lattice(3), cluster_round_lattice - logical :: terminate, randomise_buffer, print_clusters, do_calc_connect, do_same_lattice, do_fix_lattice - logical :: hysteretic_connect - integer :: i, j, k, m - real(dp) :: maxlen(3), sep(3), lat_maxlen(3), lat_sep(3) - logical :: do_periodic(3) - integer, pointer :: hybrid_mark(:), cluster_index(:), cluster_hybrid_mark(:), cluster_shift(:,:) - type(CInoutput) :: clusterfile - character(len=255) :: clusterfilename - character(len=255) :: my_mark_name - character(STRING_LENGTH) :: run_suffix - type(Table) :: outer_layer - logical :: in_outer_layer, do_map_into_cell - -#ifdef _MPI - integer::mpi_size, mpi_rank, PRINT_ALWAYS - integer :: mpi_force_size - real(dp), allocatable, dimension(:) :: mpi_force - - call get_mpi_size_rank(MPI_COMM_WORLD, mpi_size, mpi_rank) -#endif /* _MPI */ - - INIT_ERROR(error) - - call print('carve_cluster got args_str "'//trim(args_str)//'"', PRINT_VERBOSE) - - call initialise(params) - call param_register(params, 'terminate', 'T', terminate,& - help_string="do hydrogen termination") - call param_register(params, 'do_rescale_r', 'F', do_rescale_r,& - help_string="do rescale cluster lattice positions and lattice (for matching lattice constants of different models") - call param_register(params, 'r_scale', '1.0', r_scale,& - help_string="cluster position/lattice rescaling factor") - call param_register(params, 'randomise_buffer', 'T', randomise_buffer,& - help_string="randomly perturb positions of buffer atoms") - call param_register(params, 'print_clusters', 'F', print_clusters,& - help_string="Print out clusters into clusters.xyz file (clusters.MPI_RANK.xyz if in MPI)") - call param_register(params, 'cluster_calc_connect', 'F', do_calc_connect,& - help_string="run calc_connect before doing stuff (passivation, etc)") - call param_register(params, 'cluster_same_lattice', 'F', do_same_lattice,& - help_string="Don't modify cluster cell vectors from incoming cell vectors") - call param_register(params, 'cluster_fix_lattice', '0. 0. 0.', cluster_fix_lattice, & - has_value_target=do_fix_lattice, & - help_string="fix the cluster lattice to be cubic with given 3 lengths. useful with DFT codes where one doesn't pay for vacuum.") - call param_register(params, 'cluster_round_lattice', '3.0', cluster_round_lattice, & - help_string="distance to which to round cluster lattice (default is 3.0 A)") - call param_register(params, 'cluster_periodic_x', 'F', do_periodic(1),& - help_string="do not add vaccum along x, so as to make cluster's cell vectors periodic") - call param_register(params, 'cluster_periodic_y', 'F', do_periodic(2),& - help_string="do not add vaccum along x, so as to make cluster's cell vectors periodic") - call param_register(params, 'cluster_periodic_z', 'F', do_periodic(3),& - help_string="do not add vaccum along x, so as to make cluster's cell vectors periodic") - call param_register(params, 'cluster_vacuum', '10.0', cluster_vacuum,& - help_string="Amount of vacuum to add around cluster (minimum - lattice vectors are rounded up to integers)") - call param_register(params, 'hysteretic_connect', 'F', hysteretic_connect,& - help_string="Use hysteretic connection object for identifying bonds") - call param_register(params, 'map_into_cell', 'T', do_map_into_cell,& - help_string="Call map_into_cell (lattice coordinates=[-0.5,0.5)) on cluster") - call param_register(params, 'run_suffix', '', run_suffix, & - help_string="string to append to names of extra properties added to cluster. NOTE: does not override mark_name argument") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='carve_cluster arg_str') ) then - RAISE_ERROR("carve_cluster failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - ! first pick up an atoms structure with the right number of atoms and copy the properties - !Now turn the cluster_temp table into an atoms structure - call print('carve_cluster: Copying atomic data to output object',PRINT_NERD) - call print('List of atoms in cluster:', PRINT_NERD) - call print(int_part(cluster_info,1), PRINT_NERD) - - call select(cluster, at, list=int_part(cluster_info,1), error=error) - PASS_ERROR(error) - ! then reset the positions species and Z (latter two needed because termination atoms have Z=1) - ! unfold the positions to real positions using the stored shifts, at is neede because - ! next we might make the unit cell much smaller - do i=1,cluster_info%N - cluster%pos(:,i) = cluster_info%real(1:3, i)+(at%lattice .mult. cluster_info%int(2:4, i)) - cluster%Z(i) = cluster_info%int(5,i) - cluster%species(:,i) = ' ' - cluster%species(1:3,i) = s2a(ElementName(cluster_info%int(5,i))) - end do - ! add properties to cluster - call add_property(cluster, 'index'//trim(run_suffix), int_part(cluster_info,1)) - call add_property(cluster, 'shift'//trim(run_suffix), 0, n_cols=3, ptr2=cluster_shift) - cluster_shift(:,1:cluster%N) = cluster_info%int(2:4,1:cluster_info%N) - call add_property(cluster, 'termindex'//trim(run_suffix), int_part(cluster_info,6)) - call add_property(cluster, 'rescale'//trim(run_suffix), real_part(cluster_info,4)) - call add_property(cluster, 'cluster_ident'//trim(run_suffix), cluster_info%str(1,1:cluster_info%N)) - - ! Find smallest bounding box for cluster - ! Find boxes aligned with xyz (maxlen) and with a1 a2 a3 (lat_maxlen) - maxlen = 0.0_dp - lat_maxlen = 0.0_dp - do i=1,cluster%N - do j=1,cluster%N - sep = cluster%pos(:,i)-cluster%pos(:,j) - lat_sep = cluster%g .mult. sep - do k=1,3 - if (abs(sep(k)) > maxlen(k)) maxlen(k) = abs(sep(k)) - if (abs(lat_sep(k)) > lat_maxlen(k)) lat_maxlen(k) = abs(lat_sep(k)) - end do - end do - end do - - ! renormalize lat_maxlen to real dist units - do k=1,3 - lat_maxlen(k) = lat_maxlen(k) * norm(cluster%lattice(:,k)) - end do - - ! Round up maxlen to be divisible by cluster_round_lattice (default 3 A), so that it does not fluctuate too much - forall (k=1:3) maxlen(k) = cluster_round_lattice*ceiling(maxlen(k)/cluster_round_lattice) - forall (k=1:3) lat_maxlen(k) = cluster_round_lattice*ceiling(lat_maxlen(k)/cluster_round_lattice) - - ! vacuum pad cluster (if didn't set do_same_lattice or cluster_fix_lattice) - ! if not periodic at all, just do vacuum padding - ! if cluster_fix_lattice was given, just set the diagonal lattice elements to those values - ! if periodic along some dir, keep supercell vector directions, and set - ! extent in each direction to lesser of cluster extent + vacuum or original extent - if (do_same_lattice) then - cluster%lattice = at%lattice - else if (do_fix_lattice) then - cluster%lattice = 0.0_dp - do k=1,3 - cluster%lattice(k,k) = cluster_fix_lattice(k) - end do - else - if (any(do_periodic)) then - do k=1,3 - if (do_periodic(k)) then - if (lat_maxlen(k)+cluster_vacuum >= norm(at%lattice(:,k))) then - cluster%lattice(:,k) = at%lattice(:,k) - else - cluster%lattice(:,k) = (lat_maxlen(k)+cluster_vacuum)*at%lattice(:,k)/norm(at%lattice(:,k)) - endif - else - cluster%lattice(:,k) = (lat_maxlen(k)+cluster_vacuum)*at%lattice(:,k)/norm(at%lattice(:,k)) - endif - end do - else - cluster%lattice = 0.0_dp - do k=1,3 - cluster%lattice(k,k) = maxlen(k) + cluster_vacuum - end do - endif - endif - - call set_lattice(cluster, cluster%lattice, scale_positions=.false.) - - ! Remap positions so any image atoms end up inside the cell - if (do_map_into_cell) then - call map_into_cell(cluster) - end if - - call print ('carve_cluster: carved cluster with '//cluster%N//' atoms', PRINT_VERBOSE) - - write (line, '(a,f10.3,f10.3,f10.3)') & - 'carve_cluster: Cluster dimensions are ', cluster%lattice(1,1), & - cluster%lattice(2,2), cluster%lattice(3,3) - call print(line, PRINT_VERBOSE) - - my_mark_name = optional_default('hybrid_mark', mark_name) - ! reassign pointers - if (.not. assign_pointer(at, trim(my_mark_name), hybrid_mark)) then - RAISE_ERROR('cannot reassign "'//trim(my_mark_name)//'" property', error) - endif - - ! rescale cluster positions and lattice - if (do_rescale_r) then - call print('carve_cluster: rescaling cluster positions (and lattice if not fixed) by factor '//r_scale, PRINT_VERBOSE) - cluster%pos = r_scale * cluster%pos - if (.not. do_fix_lattice) then - call set_lattice(cluster, r_scale * cluster%lattice, scale_positions=.false.) - end if - end if - - if (randomise_buffer .and. .not. any(hybrid_mark == HYBRID_BUFFER_OUTER_LAYER_MARK)) & - do_calc_connect = .true. - - if (do_calc_connect) then - call print('carve_cluster: doing calc_connect', PRINT_VERBOSE) - ! Does QM force model need connectivity information? - call set_cutoff(cluster, at%cutoff) - call calc_connect(cluster) - end if - - if (randomise_buffer) then - ! If outer buffer layer is not marked do so now. This will be - ! the case if we're using hysteretic_buffer selection option. - ! In this case we consider any atoms connected to terminating - ! hydrogens to be in the outer layer - obviously this breaks down - ! if we're not terminating so we abort if that's the case. - if (.not. assign_pointer(cluster, 'index', cluster_index)) then - RAISE_ERROR('carve_cluster: cluster is missing index property', error) - endif - - if (.not. any(hybrid_mark == HYBRID_BUFFER_OUTER_LAYER_MARK)) then - if (.not. terminate) then - RAISE_ERROR('cannot determine which buffer atoms to randomise if terminate=F and hysteretic_buffer=T', error) - endif - - if (.not. assign_pointer(cluster, trim(my_mark_name), cluster_hybrid_mark)) then - RAISE_ERROR(trim(my_mark_name)//' property not found in cluster', error) - endif - - do i=1,cluster%N - if (hybrid_mark(cluster_info%int(1,i)) /= HYBRID_BUFFER_MARK) cycle - in_outer_layer = .false. - do m = 1, cluster_info%N - if (cluster_info%int(6,m).eq. i) then - in_outer_layer = .true. - exit - end if - enddo - if (in_outer_layer) then - hybrid_mark(cluster_info%int(1,i)) = HYBRID_BUFFER_OUTER_LAYER_MARK - cluster_hybrid_mark(i) = HYBRID_BUFFER_OUTER_LAYER_MARK - end if - end do - end if - - if (any(hybrid_mark == HYBRID_BUFFER_OUTER_LAYER_MARK)) then - ! Slightly randomise the positions of the outermost layer - ! of the buffer region in order to avoid systematic errors - ! in QM forces. - - call initialise(outer_layer, 1,0,0,0) - call append(outer_layer, find(hybrid_mark == HYBRID_BUFFER_OUTER_LAYER_MARK)) - - do i=1,outer_layer%N - ! Shift atom by randomly distributed vector of magnitude 0.05 A - j = find_in_array(cluster_index, outer_layer%int(1,i)) - cluster%pos(:,j) = cluster%pos(:,j) + 0.05_dp*random_unit_vector() - end do - - call finalise(outer_layer) - end if - - end if - - if (value(mainlog%verbosity_stack) >= PRINT_VERBOSE .or. print_clusters) then -#ifdef _MPI - write (clusterfilename, '(a,i3.3,a)') 'clusters.',mpi_rank,'.xyz' -#else - clusterfilename = 'clusters.xyz' -#endif /* _MPI */ - call initialise(clusterfile, clusterfilename, append=.true., action=OUTPUT) - call write(clusterfile, cluster) - call finalise(clusterfile) - end if - - end subroutine carve_cluster - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Create a cluster using the mark_name (optional arg, default 'hybrid_mark') - !% property and options in 'args_str'. - !% All atoms that are marked with anything other than 'HYBRID_NO_MARK' will - !% be included in the cluster; this includes active, transition and buffer - !% atoms. Atoms added (to satisfy heuristics) will be marked in new property - !% modified_//trim(mark_name) as 'HYBRID_BUFFER_MARK'. - !% Returns a Table object (cluster_info) which contains info on atoms whose - !% indices are given in atomlist, possibly with some extras for consistency, - !% and optionally terminated with Hydrogens, that can be used by carve_cluster(). - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function create_cluster_info_from_mark(at, args_str, cut_bonds, mark_name, error) result(cluster_info) - type(Atoms), intent(inout), target :: at - character(len=*), intent(in) :: args_str - type(Table), optional, intent(out) :: cut_bonds !% Return a list of the bonds cut when making - !% the cluster. See create_cluster() documentation. - character(len=*), intent(in), optional :: mark_name - integer, optional, intent(out) :: error - type(Table) :: cluster_info - - type(Dictionary) :: params - logical :: terminate, periodic_x, periodic_y, periodic_z, & - even_electrons, do_periodic(3), cluster_hopping_nneighb_only, cluster_heuristics_nneighb_only, & - cluster_allow_modification, hysteretic_connect, same_lattice, & - fix_termination_clash, keep_whole_residues, keep_whole_subgroups, keep_whole_prolines, keep_whole_proline_sidechains, & - keep_whole_silica_tetrahedra, keep_whole_titania_octahedra, terminate_octahedra,reduce_n_cut_bonds, in_out_in, & - protect_X_H_bonds, protect_double_bonds, protect_peptide_bonds, keep_whole_molecules, has_termination_rescale, & - combined_protein_heuristics, force_no_fix_termination_clash - character(STRING_LENGTH) :: in_out_in_mode - logical :: keep_whole_residues_has_value, keep_whole_subgroups_has_value, keep_whole_prolines_has_value, keep_whole_proline_sidechains_has_value, & - protect_double_bonds_has_value, protect_peptide_bonds_has_value, keep_whole_molecules_has_value - real(dp) :: r, r_min, centre(3), termination_rescale, termination_clash_factor - type(Table) :: cluster_list, currentlist, nextlist, activelist, bufferlist - integer :: i, j, jj, first_active, old_n, n_cluster - integer, pointer :: hybrid_mark(:), modified_hybrid_mark(:) - integer :: prev_cluster_info_n - integer, allocatable, dimension(:) :: uniqed, tmp_index - - type(Table) :: n_term, in_n_term, sorted_n_term - integer :: m, n, p, p_in, in_n - - real(dp) :: H1(3) - real(dp) :: dhat_ij(3), d(3) - real(dp) :: r_ij, rescale - real(dp) :: orig_length - real(dp), dimension(3) :: bond1, bond2, new_bond - integer :: ishift(3), jshift(3), oldN, most_hydrogens - logical :: atom_mask(6) - integer, allocatable, dimension(:) :: idx - - type(Connection), pointer :: use_connect - logical :: connectivity_just_from_connect - logical :: cluster_changed, cluster_hopping - character(len=STRING_LENGTH) :: my_mark_name - - INIT_ERROR(error) - - my_mark_name = optional_default('hybrid_mark', mark_name) - - call print('create_cluster_info_from_mark got args_str "'//trim(args_str)//'"', PRINT_VERBOSE) - - call initialise(params) - call param_register(params, 'terminate', 'T', terminate, & - help_string="Do hydrogen termination for dangling bonds") - call param_register(params, 'cluster_periodic_x', 'F', periodic_x,& - help_string="do not add vaccum along x, so as to make cluster's cell vectors periodic") - call param_register(params, 'cluster_periodic_y', 'F', periodic_y,& - help_string="do not add vaccum along y, so as to make cluster's cell vectors periodic") - call param_register(params, 'cluster_periodic_z', 'F', periodic_z,& - help_string="do not add vaccum along z, so as to make cluster's cell vectors periodic") - call param_register(params, 'even_electrons', 'F', even_electrons,& - help_string="Remove passivation hydrogen to keep total number of electrons even") - call param_register(params, 'cluster_hopping_nneighb_only', 'T', cluster_hopping_nneighb_only,& - help_string="Apply is_nearest_neighbor test to bonds when doing bond hops to find cluster. If false, uses connectivity object as is") - call param_register(params, 'cluster_heuristics_nneighb_only', 'T', cluster_heuristics_nneighb_only,& - help_string="Apply is_nearest_neighbor test to bonds when deciding what's bonded for heuristics. If false, uses connectivity object as is") - call param_register(params, 'cluster_allow_modification', 'T', cluster_allow_modification,& - help_string="Allow cluster to be modified using various heuristics") - call param_register(params, 'hysteretic_connect', 'F', hysteretic_connect,& - help_string="Use hysteretic connect object to decide what's bonded. Usually goes with cluster_*_nneighb_only=F.") - call param_register(params, 'cluster_same_lattice', 'F', same_lattice,& - help_string="Don't modify cluster cell vectors from incoming cell vectors") - call param_register(params, 'fix_termination_clash','T', fix_termination_clash,& - help_string="Apply termination clash (terimnation H too close together) heureistic") - call param_register(params, 'force_no_fix_termination_clash','F', force_no_fix_termination_clash,& - help_string="Overrides values of (terminate .or. termination_clash) to explicitly disable termination clash heuristic") - call param_register(params, 'combined_protein_heuristics','F', combined_protein_heuristics, & - help_string="Apply heuristics for proteins: overrides keep_whole_molecules=F, keep_whole_residues=F, keep_whole_subgroups=T, keep_whole_prolines=T, keep_whole_proline_sidechains=F, protect_double_bonds=F, protect_peptide_bonds=T") - call param_register(params, 'keep_whole_residues','T', keep_whole_residues, has_value_target=keep_whole_residues_has_value,& - help_string="Apply heuristic keeping identified residues whole") - call param_register(params, 'keep_whole_prolines','F', keep_whole_prolines, has_value_target=keep_whole_prolines_has_value,& - help_string="Apply heuristic keeping identified prolines whole") - call param_register(params, 'keep_whole_proline_sidechains','F', keep_whole_proline_sidechains, has_value_target=keep_whole_proline_sidechains_has_value,& - help_string="Apply heuristic keeping identified prolines sidechain+directly connected backbone part whole") - call param_register(params, 'keep_whole_subgroups','F', keep_whole_subgroups, has_value_target=keep_whole_subgroups_has_value,& - help_string="Apply heuristic keeping identified subgroups within a residue whole") - call param_register(params, 'keep_whole_silica_tetrahedra','F', keep_whole_silica_tetrahedra,& - help_string="Apply heureistic keeping SiO2 tetrahedra whole") - call param_register(params, 'keep_whole_titania_octahedra','F', keep_whole_titania_octahedra,& - help_string="Apply heureistic keeping TiO2 tetragonal structure whole") - call param_register(params, 'terminate_octahedra','F', terminate_octahedra,& - help_string="Apply heureistic terminating TiO2 octahedra") - call param_register(params, 'reduce_n_cut_bonds','T', reduce_n_cut_bonds,& - help_string="Apply heuristic that adds atoms if doing so reduces number of broken bonds") - call param_register(params, 'in_out_in', 'F', in_out_in, & - help_string="Apply heuristic than adds atoms to avoid IN-OUT-IN configurations. Usually equivalent to reduce_n_cut_bonds.") - call param_register(params, 'in_out_in_mode', 'all', in_out_in_mode, & - help_string="Mode to use for in_out_in heuristic - can be either 'all' or 'any'. Default is 'all'.") - call param_register(params, 'protect_X_H_bonds','T', protect_X_H_bonds,& - help_string="Apply heuristic protecting X-H bonds - no point H passivating bonds with an H") - call param_register(params, 'protect_double_bonds','T', protect_double_bonds, has_value_target=protect_double_bonds_has_value,& - help_string="Apply heuristic protecting double bonds from being cut (based one some heuristic idea of what's a double bond") - call param_register(params, 'protect_peptide_bonds','F', protect_peptide_bonds, has_value_target=protect_peptide_bonds_has_value,& - help_string="Apply heuristic protecting peptide bonds from being cut (RO-C...N-RR)") - call param_register(params, 'keep_whole_molecules','F', keep_whole_molecules, has_value_target=keep_whole_molecules_has_value, & - help_string="Apply heuristic keeping identified molecules (i.e. contiguous bonded groups of atoms) whole") - call param_register(params, 'termination_rescale', '0.0', termination_rescale, has_value_target=has_termination_rescale,& - help_string="rescale factor for X-H passivation bonds") - call param_register(params, 'termination_clash_factor', '1.2', termination_clash_factor, & - help_string="Factor to multiply H-H bond-length by when deciding if two Hs are too close. Default 1.2") - call param_register(params, 'cluster_hopping', 'T', cluster_hopping,& - help_string="Identify cluster region by hopping from a seed atom. Needed so that shifts will be correct.") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='create_cluster_info_from_mark args_str') ) then - RAISE_ERROR("create_cluster_info_from_mark failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if (combined_protein_heuristics) then - if (keep_whole_molecules_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_molecules") - if (keep_whole_residues_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_residues") - if (keep_whole_subgroups_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_subgroups") - if (keep_whole_prolines_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_prolines") - if (keep_whole_proline_sidechains_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_proline_sidechains") - if (protect_double_bonds_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding protect_double_bonds_has_value") - if (protect_peptide_bonds_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding protect_peptide_bonds_has_value") - keep_whole_molecules = .false. - keep_whole_molecules_has_value = .true. - keep_whole_residues = .false. - keep_whole_residues_has_value = .true. - keep_whole_subgroups = .true. - keep_whole_subgroups_has_value = .true. - keep_whole_prolines = .true. - keep_whole_prolines_has_value = .true. - keep_whole_proline_sidechains = .true. - keep_whole_proline_sidechains_has_value = .true. - protect_double_bonds = .false. - protect_peptide_bonds = .true. - protect_peptide_bonds_has_value = .true. - endif - - do_periodic = (/periodic_x,periodic_y,periodic_z/) - - if (.not. has_property(at, trim(my_mark_name))) then - RAISE_ERROR('create_cluster_info_from_mark: atoms structure has no "'//trim(my_mark_name)//'" property', error) - endif - - call assign_property_pointer(at, trim(my_mark_name), hybrid_mark, error=error) - PASS_ERROR_WITH_INFO('create_cluster_info_from_mark passed atoms structure with no hybrid_mark property', error) - - ! Calculate centre of cluster - call allocate(cluster_list, 1,0,0,0) - call append(cluster_list, find(hybrid_mark /= HYBRID_NO_MARK)) - ! unreliable when cluster extends across periodic boundaries - ! centre = 0.0_dp - ! do i=1,cluster_list%N - ! centre = centre + at%pos(:,cluster_list%int(1,i)) + (at%lattice .mult. cluster_list%int(2:4,i)) - ! end do - ! centre = centre / cluster_list%N - centre = at%pos(:,cluster_list%int(1,1)) -!!$ call print('centre = '//centre) - - ! Find ACTIVE atom closest to centre of cluster, using min image convention - r_min = huge(1.0_dp) - do i=1,cluster_list%N - if (hybrid_mark(cluster_list%int(1,i)) /= HYBRID_ACTIVE_MARK) cycle - r = distance_min_image(at, centre, cluster_list%int(1,i)) -!!$ call print(cluster_list%int(1,i)//' '//r) - if (r < r_min) then - first_active = cluster_list%int(1,i) - r_min = r - end if - end do - - if (cluster_hopping) then - call system_timer('cluster_hopping') - - n_cluster = cluster_list%N - call wipe(cluster_list) - call allocate(cluster_list, 4,0,0,0) - - ! Add first marked atom to cluster_list. shifts will be relative to this atom - call print('Growing cluster starting from atom '//first_active//', n_cluster='//n_cluster, PRINT_VERBOSE) - call append(cluster_list, (/first_active,0,0,0/)) - call append(currentlist, cluster_list) - - ! Add other active atoms using bond hopping from the central cluster atom - ! to find the other cluster atoms and hence to determine the correct - ! periodic shifts. - ! - ! This will fail if marked atoms do not form a single connected cluster - old_n = cluster_list%N - do - call wipe(nextlist) - if (hysteretic_connect) then - call BFS_step(at, currentlist, nextlist, nneighb_only=cluster_hopping_nneighb_only, & - min_images_only = any(do_periodic) .or. same_lattice , alt_connect=at%hysteretic_connect) - else - call BFS_step(at, currentlist, nextlist, nneighb_only=cluster_hopping_nneighb_only, & - min_images_only = any(do_periodic) .or. same_lattice) - endif - do j=1,nextlist%N - jj = nextlist%int(1,j) - ! shift = nextlist%int(2:4,j) - if (hybrid_mark(jj) /= HYBRID_NO_MARK .and. find(cluster_list, nextlist%int(:,j)) == 0) & - call append(cluster_list, nextlist%int(:,j)) - end do - call append(currentlist, nextlist) - - ! check exit condition - allocate(tmp_index(cluster_list%N)) - tmp_index = int_part(cluster_list,1) - call sort_array(tmp_index) - call uniq(tmp_index, uniqed) - call print('cluster hopping: got '//cluster_list%N//' atoms, of which '//size(uniqed)//' are unique.', PRINT_VERBOSE) - if (size(uniqed) == n_cluster) exit !got them all - deallocate(uniqed, tmp_index) - - ! check that cluster is still growing - if (cluster_list%N == old_n) then - call write(at, 'create_cluster_abort.xyz') - call print(cluster_list) - RAISE_ERROR('create_cluster_info_from_mark: cluster stopped growing before all marked atoms found - check for split QM region', error) - end if - old_n = cluster_list%N - end do - deallocate(tmp_index, uniqed) - call finalise(nextlist) - call finalise(currentlist) - call system_timer('cluster_hopping') - else - call system_timer('cluster_diff_min_image') - call allocate(cluster_list, 4,0,0,0) - - call append(cluster_list, (/first_active,0,0,0/)) - do i=1, at%n - if (hybrid_mark(i) == HYBRID_NO_MARK .or. i == first_active) cycle - ! shifts relative to first_active - d = distance_min_image(at, first_active, i, shift=ishift) - call append(cluster_list, (/i,ishift/)) - end do - call system_timer('cluster_diff_min_image') - end if - ! partition cluster_list so that active atoms come first - call wipe(activelist) - call wipe(bufferlist) - do i=1,cluster_list%N - if (hybrid_mark(cluster_list%int(1,i)) == HYBRID_ACTIVE_MARK) then - call append(activelist, cluster_list%int(:,i)) - else - call append(bufferlist, cluster_list%int(:,i)) - end if - end do - - call wipe(cluster_list) - call append(cluster_list, activelist) - call append(cluster_list, bufferlist) - call finalise(activelist) - call finalise(bufferlist) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! - ! Validate arguments - ! - - ! check for consistency in optional arguments - - if (.not. (count(do_periodic) == 0 .or. count(do_periodic) == 1 .or. count(do_periodic) == 3)) then - RAISE_ERROR('count(periodic) must be zero, one or three.', error) - endif - - if (same_lattice) do_periodic = .true. - - if (any(do_periodic) .and. multiple_images(cluster_list)) then - RAISE_ERROR("create_cluster: can't make a periodic cluster since cluster_list contains repeats", error) - endif - - ! check for empty list - - if(cluster_list%N == 0) then - call print('create_cluster: empty cluster_list', PRINT_NORMAL) - return - end if - - call print('create_cluster: Entering create_cluster', PRINT_NERD) - - if(.not.(cluster_list%intsize == 1 .or. cluster_list%intsize == 4) .or. cluster_list%realsize /= 0) then - RAISE_ERROR("create_cluster: cluster_list table must have intsize=1 or 4 and realsize=0.", error) - endif - - - ! Cluster_info is extensible storage for the cluster - ! It stores atomic indices and shifts (4 ints) - ! atomic number (1 int) - ! termination index (1 int): for termination atoms, which atom is being terminated? - ! and atomic positions (3 reals) - ! It's length will be at least cluster_list%N - - call print('create_cluster: Creating temporary cluster table', PRINT_NERD) - call allocate(cluster_info,6,4,1,0,cluster_list%N) - - ! First, put all the marked atoms into cluster_info, storing their positions and shifts - call print('create_cluster: Adding specified atoms to the cluster', PRINT_NERD) - do i = 1, cluster_list%N - if(cluster_list%intsize == 4) then - ! we have shifts - ishift = cluster_list%int(2:4,i) - else - ! no incoming shifts - ishift = (/0,0,0/) - end if - call append(cluster_info, (/cluster_list%int(1,i),ishift,at%Z(cluster_list%int(1,i)),0/),& - (/at%pos(:,cluster_list%int(1,i)),1.0_dp/), (/ hybrid_mark_name(hybrid_mark(cluster_list%int(1,i))) /) ) - end do - - call print("create_cluster: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - - call system_timer('cluster_consistency') - ! Next, check for various gotchas - - ! at mask is used to match with atoms already in the cluster_info table - ! if we are periodic in a direction, we don't care about the shifts in that direction when matching - atom_mask = (/.true.,.not.do_periodic, .true., .true./) - - connectivity_just_from_connect = .not. cluster_heuristics_nneighb_only - if (hysteretic_connect) then - use_connect => at%hysteretic_connect - ! will also pass true for connectivity_just_from_connect to cluster_...() routines, so that - ! is_nearest_neighbour() won't be used - connectivity_just_from_connect = .true. - else - use_connect => at%connect - endif - - if (cluster_allow_modification) then - call add_property(at, 'modified_'//trim(my_mark_name), 0, ptr=modified_hybrid_mark) - cluster_changed = .true. - modified_hybrid_mark = hybrid_mark - prev_cluster_info_n = cluster_info%N - - do while (cluster_changed) - cluster_changed = .false. - call print("fixing up cluster according to heuristics keep_whole_residues " // keep_whole_residues // & - ' keep_whole_prolines ' // keep_whole_prolines // & - ' keep_whole_proline_sidechains ' // keep_whole_proline_sidechains // & - ' keep_whole_subgroups ' // keep_whole_subgroups // & - ' keep_whole_silica_tetrahedra ' // keep_whole_silica_tetrahedra // & - ' keep_whole_titania_octahedra ' // keep_whole_titania_octahedra // & - ' terminate_octahedra ' // terminate_octahedra // & - ' reduce_n_cut_bonds ' // reduce_n_cut_bonds // & - ' in_out_in ' // in_out_in // & - ' in_out_in_mode ' // trim(in_out_in_mode) // & - ' protect_X_H_bonds ' // protect_X_H_bonds // & - ' protect_double_bonds ' // protect_double_bonds // & - ' protect_peptide_bonds ' // protect_peptide_bonds // & - ' terminate .or. fix_termination_clash ' // (terminate .or. fix_termination_clash) // & - ' force_no_fix_termination_clash '// force_no_fix_termination_clash, verbosity=PRINT_NERD) - if (keep_whole_proline_sidechains) then - cluster_changed = cluster_changed .or. cluster_keep_whole_proline_sidechains(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, keep_whole_proline_sidechains_has_value) - endif - if (keep_whole_prolines) then - cluster_changed = cluster_changed .or. cluster_keep_whole_prolines(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, keep_whole_prolines_has_value) - endif - if (keep_whole_subgroups) then - cluster_changed = cluster_changed .or. cluster_keep_whole_subgroups(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, keep_whole_subgroups_has_value) - endif - if (keep_whole_residues) then - cluster_changed = cluster_changed .or. cluster_keep_whole_residues(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, keep_whole_residues_has_value) - endif - if (keep_whole_silica_tetrahedra) then - cluster_changed = cluster_changed .or. cluster_keep_whole_silica_tetrahedra(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) - end if - if (reduce_n_cut_bonds) then - cluster_changed = cluster_changed .or. cluster_reduce_n_cut_bonds(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) - endif - if (keep_whole_titania_octahedra) then - cluster_changed = cluster_changed .or. cluster_keep_whole_titania_octahedra(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) - end if - if (in_out_in) then - cluster_changed = cluster_changed .or. cluster_in_out_in(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, in_out_in_mode) - endif - if (protect_X_H_bonds) then - cluster_changed = cluster_changed .or. cluster_protect_X_H_bonds(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) - endif - if (protect_double_bonds) then - cluster_changed = cluster_changed .or. cluster_protect_double_bonds(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, protect_double_bonds_has_value) - endif - if (protect_peptide_bonds) then - cluster_changed = cluster_changed .or. cluster_protect_peptide_bonds(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, protect_peptide_bonds_has_value) - endif - if ((terminate .or. fix_termination_clash) .and. .not. force_no_fix_termination_clash) then - cluster_changed = cluster_changed .or. cluster_fix_termination_clash(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, termination_clash_factor) - endif - if (keep_whole_molecules) then - cluster_changed = cluster_changed .or. cluster_keep_whole_molecules(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) - endif - end do ! while cluster_changed - - if (prev_cluster_info_n < cluster_info%N) modified_hybrid_mark(cluster_info%int(1,prev_cluster_info_n+1:cluster_info%N)) = HYBRID_BUFFER_MARK - - call print('create_cluster: Finished fixing cluster for various heuristic pathologies',PRINT_NERD) - call print("create_cluster: cluster list:", PRINT_NERD) - call print(cluster_info, PRINT_NERD) - end if ! allow_cluster_mod - - call system_timer('cluster_consistency') - - call system_timer('cluster_termination') - - !So now cluster_info contains all the atoms that are going to be in the cluster. - !If terminate is set, we need to add terminating hydrogens along nearest neighbour bonds - if (terminate.or.terminate_octahedra) then - call print('create_cluster: Terminating cluster with hydrogens',PRINT_NERD) - - call allocate(n_term, 5, 0, 0, 0) - call allocate(in_n_term, 5, 0, 0, 0) - oldN = cluster_info%N - - !Loop over atoms in the cluster - do n = 1, oldN - - i = cluster_info%int(1,n) - ishift = cluster_info%int(2:4,n) - if(terminate_octahedra .and. at%z(i).ne.8 ) cycle - !Loop over atom i's neighbours - do m = 1, n_neighbours(at,i, alt_connect=use_connect) - - j = neighbour(at,i,m, r_ij, diff=dhat_ij, shift=jshift, alt_connect=use_connect) - dhat_ij = dhat_ij / r_ij - - if (find(cluster_info,(/j,ishift+jshift,at%Z(j),0/), atom_mask) == 0 .and. & - (hysteretic_connect .or. is_nearest_neighbour(at, i, m, alt_connect=use_connect))) then - - ! If j is an OUT atom, and it is close enough, put a terminating hydrogen - ! at the scaled distance between i and j - - if (.not. has_termination_rescale) then - rescale = termination_bond_rescale(at%Z(i), at%Z(j)) - else - rescale = termination_rescale - end if - H1 = at%pos(:,i) + rescale * r_ij * dhat_ij - - ! Label term atom with indices into original atoms structure. - ! j is atom it's generated from and n is index into cluster table of atom it's attached to - call append(cluster_info,(/j,ishift,1,n/),(/H1, rescale/), (/ "term " /)) - - ! Keep track of how many termination atoms each cluster atom has - p = find_in_array(int_part(n_term,(/1,2,3,4/)),(/n,ishift/)) - if (p == 0) then - call append(n_term, (/n,ishift,1/)) - else - n_term%int(5,p) = n_term%int(5,p) + 1 - end if - - ! optionally keep a record of the bonds that we have cut - if (present(cut_bonds)) & - call append(cut_bonds, (/i,j,ishift,jshift/)) - - if(current_verbosity() .ge. PRINT_NERD) then - write(line,'(a,i0,a,i0,a)')'create_cluster: Replacing bond ',i,'--',j,' with hydrogen' - call print(line, PRINT_NERD) - end if - end if - - ! Keep track of how many other neighbours has - if (terminate_octahedra.and.find(cluster_info,(/j,ishift+jshift,at%Z(j),0/), atom_mask) /= 0 .and. & - (hysteretic_connect .or. is_nearest_neighbour(at, i, m, alt_connect=use_connect))) then - p_in = find_in_array(int_part(in_n_term,(/1,2,3,4/)),(/n,ishift/)) - if (p_in == 0) then - call append(in_n_term, (/n,ishift,1/)) - else - in_n_term%int(5,p_in) = in_n_term%int(5,p_in) + 1 - end if - endif - end do - - end do - - !If terminate octahedra is set we have to adjust how many H atoms are added to the oxygens. - !Since with Ti, the oxygens are threefold coordinated, we have to remove some of the added O - !to restore the correct twofold coordination. - if(terminate_octahedra) then - - j = cluster_info%N - do i=n_term%n,1,-1 - n = n_term%int(1,i) !Reference atom - in_n = find_in_array(int_part(in_n_term,(/1/)),(/n/)) - ishift = n_term%int(2:4,i) - - if (n_term%int(5,i) .eq. 2) then - if (all(cluster_info%int(2:6,j) == (/ishift,1,n/))) then - bond1 = cluster_info%real(1:3,j) - cluster_info%real(1:3,n) - bond2 = cluster_info%real(1:3,j-1) - cluster_info%real(1:3,n) - orig_length = sqrt(sum(bond1 * bond1)) - - new_bond = bond1 + bond2 - new_bond = new_bond / sqrt(sum(new_bond*new_bond)) - new_bond = new_bond * orig_length - call delete(cluster_info, j) !Delete second H atom - call print('create_cluster: removed one of atom '//cluster_info%int(1,n)//" "//maxval(int_part(n_term,5))// & - ' terminating hydrogens ', PRINT_VERBOSE) - cluster_info%real(1:3,j-1) = cluster_info%real(1:3,n) + new_bond - endif - j = j - 2 - elseif (n_term%int(5,i) .eq. 1 .and. in_n_term%int(5,in_n) .le. 1) then !Do not remove the H atom - j = j - 1 - elseif (n_term%int(5,i) .eq. 1 .and. in_n_term%int(5,in_n) .gt. 1) then !Remove the H atom - if (all(cluster_info%int(2:6,j) == (/ishift,1,n/))) then - call delete(cluster_info, j) - call print('create_cluster: removed one of atom '//cluster_info%int(1,n)//" "//maxval(int_part(n_term,5))// & - ' terminating hydrogens ', PRINT_VERBOSE) - endif - j = j - 1 - endif - end do - - endif - - ! Do we need to remove a hydrogen atom to ensure equal n_up and n_down electrons? - if (even_electrons .and. mod(sum(int_part(cluster_info,5)),2) == 1) then - - ! Find first atom with a maximal number of terminating hydrogens - - do i=1,n_term%n - call append(sorted_n_term, (/n_term%int(5,i), n_term%int(1,i)/)) - end do - allocate(idx(n_term%n)) - call sort(sorted_n_term, idx) - - n = sorted_n_term%int(2, sorted_n_term%n) - most_hydrogens = idx(sorted_n_term%n) - ishift = n_term%int(2:4,most_hydrogens) - - ! Loop over termination atoms - do j=oldN,cluster_info%N - ! Remove first H atom attached to atom i - if (all(cluster_info%int(2:6,j) == (/ishift,1,n/))) then - call delete(cluster_info, j) - call print('create_cluster: removed one of atom '//cluster_info%int(1,n)//" "//maxval(int_part(n_term,5))// & - ' terminating hydrogens to zero total spin', PRINT_VERBOSE) - exit - end if - end do - - deallocate(idx) - end if - - call finalise(n_term) - - call print('create_cluster: Finished terminating cluster',PRINT_NERD) - end if - call system_timer('cluster_termination') - - call print ('Exiting create_cluster_info', PRINT_NERD) - - call finalise(cluster_list) - - end function create_cluster_info_from_mark - - - !% Given an atoms structure with a 'hybrid_mark' property, set to - !% 'HYBRID_ACTIVE_MARK' for some atoms, this routine adds transition - !% and buffer regions, and creates a 'weight_region1' property, - !% whose values are between 0 and 1. - !% - !% Atoms marked with 'HYBRID_ACTIVE_MARK' in 'hybrid_mark' get weight - !% 1. Neighbour hopping is done up to transition_hops times, over - !% which the weight linearly decreases to zero with hop count if - !% 'weight_interpolation=hop_ramp'. If - !% 'weight_interpolation=distance_ramp', weight is 1 up to - !% 'distance_ramp_inner_radius', and goes linearly to 0 by - !% 'distance_ramp_outer_radius', where distance is calculated from - !% 'distance_ramp_center(1:3)'. 'distance_ramp' makes the most sense if - !% the 'HYBRID_ACTIVE_MARK' is set on a sphere with radius - !% distance_ramp_inner_radius from distance_ramp_center, no - !% hysteresis, and with 'transition_hops' < 0 so hops continue until - !% no more atoms are added. Transition atoms are marked with - !% 'HYBRID_TRANS_MARK'. If 'hysteretic_buffer=F' (default), buffer - !% atoms are selected by hopping 'buffer_hops' times, otherwise - !% hysteretically with radii 'hysteretic_buffer_inner_radius' and - !% 'hysteretic_buffer_outer_radius'. Buffer atoms are marked with - !% 'HYBRID_BUFFER_MARK' and given weight 0. If 'hysteretic_connect' is - !% set, all hops are done on bonds in the hysteretic_connect - !% structure. - - subroutine create_hybrid_weights(at, args_str, error) - type(Atoms), intent(inout) :: at - character(len=*), intent(in) :: args_str - integer, optional, intent(out) :: error - - type(Dictionary) :: params - logical :: has_distance_ramp_inner_radius, has_distance_ramp_outer_radius, has_distance_ramp_center - real(dp) :: distance_ramp_inner_radius, distance_ramp_outer_radius, distance_ramp_center(3) - logical :: min_images_only, mark_buffer_outer_layer, cluster_hopping_nneighb_only, hysteretic_buffer, hysteretic_connect, hysteretic_buffer_nneighb_only - real(dp) :: hysteretic_buffer_inner_radius, hysteretic_buffer_outer_radius - real(dp) :: hysteretic_connect_cluster_radius, hysteretic_connect_inner_factor, hysteretic_connect_outer_factor - real(dp) :: hysteretic_connect_inner_cutoff, hysteretic_connect_outer_cutoff - integer :: buffer_hops, transition_hops - character(STRING_LENGTH) :: weight_interpolation, run_suffix - logical :: construct_buffer_use_only_heavy_atoms, cluster_hopping_skip_unreachable - - integer, pointer :: hybrid_mark(:) - real(dp), pointer :: weight_region1(:) - integer :: n_region1, n_trans, n_region2 !, n_term - integer :: i, j, jj, first_active, shift(3) - logical :: dummy - type(Table) :: activelist, currentlist, nextlist, distances, oldbuffer, bufferlist - real(dp) :: core_CoM(3), core_mass, mass - integer :: list_1, hybrid_number - type(Table) :: total_embedlist - - real(dp) :: origin(3), extent(3,3) - integer :: old_n - integer, allocatable :: uniq_Z(:) - - logical :: distance_ramp, hop_ramp - logical :: add_this_atom, more_hops - integer :: cur_trans_hop - real(dp) :: bond_len, d - logical :: ignore_silica_residue - integer :: res_num_silica - - INIT_ERROR(error) - -! only one set of defaults now, not one in args_str and one in arg list - call initialise(params) - call param_register(params, 'run_suffix', '', run_suffix, help_string="string to append to hyrbid_mark for proper mark property name") - call param_register(params, 'transition_hops', '0', transition_hops, help_string="Number of hops to do transition region over") - call param_register(params, 'buffer_hops', '3', buffer_hops, help_string="Number of hops for buffer region") - call param_register(params, 'weight_interpolation', 'hop_ramp', weight_interpolation, help_string="How to ramp down weights for transition region: hop_ramp or distance_ramp") - call param_register(params, 'distance_ramp_inner_radius', '0', distance_ramp_inner_radius, has_value_target=has_distance_ramp_inner_radius, help_string="If distance_ramp, inner radius to start reducing weight from 1") - call param_register(params, 'distance_ramp_outer_radius', '0', distance_ramp_outer_radius, has_value_target=has_distance_ramp_outer_radius, help_string="If distance_ramp, outer radius by which to reach weight of 0") - call param_register(params, 'distance_ramp_center', '0 0 0', distance_ramp_center, has_value_target=has_distance_ramp_center, help_string="If present, origin for distances of distance ramp (otherwise cluster center of mass)") - call param_register(params, 'cluster_hopping_nneighb_only', 'T', cluster_hopping_nneighb_only, help_string="If true, only hop to atom pairs that are is_nearest_neighbor().") - call param_register(params, 'cluster_hopping_skip_unreachable', 'F', cluster_hopping_skip_unreachable, help_string='If true, remove buffer atoms no longer reachable by bond hopping') - call param_register(params, 'min_images_only', 'F', min_images_only, help_string="If true, consider only minimum images, not multiple periodic images") - call param_register(params, 'mark_buffer_outer_layer', 'T', mark_buffer_outer_layer, help_string="If true, mark outermost buffer layer") - call param_register(params, 'hysteretic_buffer', 'F', hysteretic_buffer, help_string="If true, do hysteretic buffer") - call param_register(params, 'hysteretic_buffer_inner_radius', '5.0', hysteretic_buffer_inner_radius, help_string="Inner radius for hysteretic buffer") - call param_register(params, 'hysteretic_buffer_outer_radius', '7.0', hysteretic_buffer_outer_radius, help_string="Outer radius for hysteretic buffer") - call param_register(params, 'hysteretic_buffer_nneighb_only', 'F', hysteretic_buffer_nneighb_only, help_string="If true, only hop to nearest neighbour pairs when constructing hysteretic buffer") - call param_register(params, 'hysteretic_connect', 'F', hysteretic_connect, help_string="If true, use hysteretic connect object") - call param_register(params, 'hysteretic_connect_cluster_radius', '1.2', hysteretic_connect_cluster_radius, help_string="If using hysteretic connect, use as cluster radius for origin and extent estimates") - call param_register(params, 'hysteretic_connect_inner_factor', '1.2', hysteretic_connect_inner_factor, help_string="Inner factor (multiplier for covalent bond distance) for hysteretic connect") - call param_register(params, 'hysteretic_connect_outer_factor', '1.5', hysteretic_connect_outer_factor, help_string="Outer factor (multiplier for covalent bond distance) for hysteretic connect") - call param_register(params, 'construct_buffer_use_only_heavy_atoms', 'F', construct_buffer_use_only_heavy_atoms, help_string="If true, use only non-H atoms for constructing buffer") - call param_register(params, 'ignore_silica_residue', 'F', ignore_silica_residue, help_string="If true, do special things for silica") !lam81 - call param_register(params, 'res_num_silica', '1', res_num_silica, help_string="Residue number for silica") !lam81 - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='create_hybrid_weights args_str') ) then - RAISE_ERROR("create_hybrid_weights failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - hop_ramp = .false. - distance_ramp = .false. - if (trim(weight_interpolation) == 'hop_ramp') then - hop_ramp = .true. - else if (trim(weight_interpolation) == 'distance_ramp') then - distance_ramp = .true. - else - RAISE_ERROR('create_hybrid_weights: unknown weight_interpolation value: '//trim(weight_interpolation), error) - end if - - call print('create_hybrid_weights: transition_hops='//transition_hops//' buffer_hops='//buffer_hops//' weight_interpolation='//weight_interpolation, PRINT_VERBOSE) - call print(' cluster_hopping_nneighb_only='//cluster_hopping_nneighb_only//' min_images_only='//min_images_only//' mark_buffer_outer_layer='//mark_buffer_outer_layer, PRINT_VERBOSE) - call print(' hysteretic_buffer='//hysteretic_buffer//' hysteretic_buffer_inner_radius='//hysteretic_buffer_inner_radius, PRINT_VERBOSE) - call print(' hysteretic_buffer_outer_radius='//hysteretic_buffer_outer_radius//' hysteretic_buffer_nneighb_only='//hysteretic_buffer_nneighb_only, PRINT_VERBOSE) - call print(' hysteretic_connect='//hysteretic_connect//' hysteretic_connect_cluster_radius='//hysteretic_connect_cluster_radius, PRINT_VERBOSE) - call print(' hysteretic_connect_inner_factor='//hysteretic_connect_inner_factor //' hysteretic_connect_outer_factor='//hysteretic_connect_outer_factor, PRINT_VERBOSE) - - - ! check to see if atoms has a 'weight_region1' property already, if so, check that it is compatible, if not present, add it - if(assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1)) then - weight_region1 = 0.0_dp - else - call add_property(at, 'weight_region1'//trim(run_suffix), 0.0_dp) - dummy = assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1) - end if - - ! check for a compatible hybrid_mark property. it must be present - if(.not.assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then - RAISE_ERROR('create_hybrid_weights: atoms structure has no "hybrid_mark'//trim(run_suffix)//'" property', error) - endif - - ! Fast implementation of trivial case where buffer_hops=0 and transition_hops=0 - if (buffer_hops == 0 .and. transition_hops == 0) then - call print('WARNING: buffer_hops=0 and transition_hops=0, aborting create_hybrid_weights() early') - - where (hybrid_mark /= HYBRID_ACTIVE_MARK) - hybrid_mark = HYBRID_NO_MARK - end where - - weight_region1 = 0.0_dp - where (hybrid_mark == HYBRID_ACTIVE_MARK) - weight_region1 = 1.0_dp - end where - - return - end if - - ! Add first marked atom to activelist. shifts will be relative to this atom - first_active = find_in_array(hybrid_mark, HYBRID_ACTIVE_MARK) - - n_region1 = count(hybrid_mark == HYBRID_ACTIVE_MARK) - list_1 = 0 - call allocate(activelist, 4,0,0,0) - call allocate(total_embedlist, 4,0,0,0) - - do while (total_embedlist%N < n_region1) - - call wipe(currentlist) - call wipe(activelist) - call wipe(nextlist) - - call append(activelist, (/first_active,0,0,0/)) - call append(currentlist, activelist) - weight_region1(first_active) = 1.0_dp - - if (distance_ramp) then ! we might need ACTIVE_MARK center of mass - if (has_property(at, 'mass')) then - core_mass = at%mass(first_active) - else - core_mass = ElementMass(at%Z(first_active)) - end if - core_CoM = core_mass*at%pos(:,first_active) ! we're taking this as reference atom so no shift needed here - end if - - if (hysteretic_connect) then - call system_timer('hysteretic_connect') - call estimate_origin_extent(at, hybrid_mark == HYBRID_ACTIVE_MARK, hysteretic_connect_cluster_radius, origin, extent) - call calc_connect_hysteretic(at, hysteretic_connect_inner_cutoff, hysteretic_connect_outer_cutoff, at%hysteretic_connect, origin, extent) - call system_timer('hysteretic_connect') - endif - - ! Add other active atoms using bond hopping from the first atom - ! in the cluster to find the other active atoms and hence to determine the correct - ! periodic shifts - - hybrid_number = 1 - do while (hybrid_number .ne. 0) - if (hysteretic_connect) then - call BFS_step(at, currentlist, nextlist, nneighb_only=cluster_hopping_nneighb_only, min_images_only = min_images_only, alt_connect=at%hysteretic_connect) - else - call BFS_step(at, currentlist, nextlist, nneighb_only=cluster_hopping_nneighb_only, min_images_only = min_images_only, property=hybrid_mark) - endif - hybrid_number = 0 - do j=1,nextlist%N - jj = nextlist%int(1,j) - shift = nextlist%int(2:4,j) - if (hybrid_mark(jj) == HYBRID_ACTIVE_MARK .and. find_in_array(activelist%int(1,1:activelist%N), jj) == 0) then - hybrid_number = hybrid_number+1 - call append(activelist, nextlist%int(:,j)) - weight_region1(jj) = 1.0_dp - - if (distance_ramp) then ! we might need ACTIVE_MARK center of mass - if (has_property(at, 'mass')) then - mass = at%mass(jj) - else - mass = ElementMass(at%Z(jj)) - end if - core_CoM = core_CoM + mass*(at%pos(:,jj) + (at%lattice .mult. (shift))) - core_mass = core_mass + mass - end if - - end if - end do - call append(currentlist, nextlist) - enddo - list_1 = list_1 + activelist%N - call append(total_embedlist, activelist) - - if (distance_ramp) then ! calculate actual distance ramp parameters - ! distance_ramp center is as specified, otherwise ACTIVE_MARK center of mass - core_CoM = core_CoM/core_mass - if (.not. has_distance_ramp_center) distance_ramp_center = core_CoM - - ! distance_ramp_inner_radius is as specified, otherwise distance of atom furthest from distance_ramp_center - if (.not. has_distance_ramp_inner_radius) then - call initialise(distances, 1, 1, 0, 0) - do i=1, activelist%N - jj = activelist%int(1,i) - call append(distances, jj, distance_min_image(at, distance_ramp_center, jj)) - end do - distance_ramp_inner_radius = maxval(distances%real(1,1:distances%N)) - call finalise(distances) - endif - - if (.not. has_distance_ramp_outer_radius) then - distance_ramp_outer_radius = 0.0_dp - call uniq(at%Z, uniq_Z) - do i=1, size(uniq_Z) - do j=1, size(uniq_Z) - bond_len = bond_length(uniq_Z(i), uniq_Z(j)) - if (bond_len > distance_ramp_outer_radius) distance_ramp_outer_radius = bond_len - end do - end do - if (transition_hops <= 0) & - call print("WARNING: using transition_hops for distance_ramp outer radius, but transition_hops="//transition_hops,PRINT_ALWAYS) - distance_ramp_outer_radius = distance_ramp_inner_radius + distance_ramp_outer_radius*transition_hops - endif - endif ! distance_ramp - - call wipe(currentlist) - call append(currentlist, activelist) - - ! create transition region - call print('create_hybrid_mark: creating transition region',PRINT_VERBOSE) - n_trans = 0 - - cur_trans_hop = 1 - if (distance_ramp) transition_hops = -1 ! distance ramp always does as many hops as needed to get every atom within outer radius - more_hops = (transition_hops < 0 .or. transition_hops >= 2) - do while (more_hops) - more_hops = .false. - if (hysteretic_connect) then - call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only .and. (transition_hops > 0), min_images_only = min_images_only, alt_connect=at%hysteretic_connect) - else - call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only .and. (transition_hops > 0), min_images_only = min_images_only) - endif - - call wipe(currentlist) - do j = 1,nextlist%N - jj = nextlist%int(1,j) - if(hybrid_mark(jj) == HYBRID_NO_MARK) then - add_this_atom = .true. - if (distance_ramp) then - d = distance_min_image(at, distance_ramp_center, jj) - if (d >= distance_ramp_outer_radius) add_this_atom = .false. - endif - - if (add_this_atom) then - if (hop_ramp) weight_region1(jj) = 1.0_dp - real(cur_trans_hop,dp)/real(transition_hops,dp) ! linear transition - if (distance_ramp) then ! Save distance, weight will be calculated later - if (d <= distance_ramp_inner_radius) then - weight_region1(jj) = 1.0_dp - else - weight_region1(jj) = 1.0_dp - (d-distance_ramp_inner_radius)/(distance_ramp_outer_radius-distance_ramp_inner_radius) - endif - endif - call append(currentlist, nextlist%int(:,j)) - hybrid_mark(jj) = HYBRID_TRANS_MARK - n_trans = n_trans+1 - more_hops = .true. - end if - end if - end do ! do j=1,nextlist%N - - cur_trans_hop = cur_trans_hop + 1 - if (transition_hops >= 0 .and. cur_trans_hop >= transition_hops) more_hops = .false. - end do ! more_hops - - if (list_1 < n_region1) then - call print('searching for a new quantum zone as found '//list_1//' atoms, need to get to '//n_region1, PRINT_VERBOSE) - do i =1, at%N - if (hybrid_mark(i) == HYBRID_ACTIVE_MARK .and. .not. Is_in_Array(total_embedlist%int(1,1:total_embedlist%N), i)) then - first_active = i - exit - endif - enddo - endif - - enddo ! while (total_embedlist%N < n_region1) - - ! create region2 (buffer region) - if (.not. hysteretic_buffer) then - ! since no hysteresis, safe to reset non ACTIVE/TRANS atoms to HYBRID_NO_MARK - where (hybrid_mark /= HYBRID_ACTIVE_MARK .and. hybrid_mark /= HYBRID_TRANS_MARK) hybrid_mark = HYBRID_NO_MARK - - n_region2 = 0 - do i = 0,buffer_hops-1 - if (hysteretic_connect) then - call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only, min_images_only = min_images_only, alt_connect=at%hysteretic_connect) - else - call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only, min_images_only = min_images_only) - endif - call wipe(currentlist) - do j = 1,nextlist%N - jj = nextlist%int(1,j) - if(hybrid_mark(jj) == HYBRID_NO_MARK) then - call append(currentlist, nextlist%int(:,j)) - weight_region1(jj) = 0.0_dp - if (i==buffer_hops-1 .and. mark_buffer_outer_layer) then - hybrid_mark(jj) = HYBRID_BUFFER_OUTER_LAYER_MARK - else - hybrid_mark(jj) = HYBRID_BUFFER_MARK - end if - n_region2 = n_region2+1 - end if - end do - end do - else - ! hysteretic buffer here - - call initialise(oldbuffer, 1,0,0,0) - !call wipe(oldbuffer) - call append(oldbuffer, find(hybrid_mark /= HYBRID_NO_MARK)) - - call wipe(currentlist) - - ! Add first marked atom to embedlist. shifts will be relative to this atom - first_active = find_in_array(hybrid_mark, HYBRID_ACTIVE_MARK) - call append(bufferlist, (/first_active,0,0,0/)) - call append(currentlist, bufferlist) - - n_region2 = count(hybrid_mark /= HYBRID_NO_MARK) - - ! Find old embed + buffer atoms using bond hopping from the first atom - ! in the cluster to find the other buffer atoms and hence to determine the correct - ! periodic shifts - ! - ! This will fail if marked atoms do not form connected clusters around the active atoms - old_n = bufferlist%N - do while (bufferlist%N < n_region2) - if (hysteretic_connect) then - call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only, min_images_only = min_images_only, alt_connect=at%hysteretic_connect) - else - call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only, min_images_only = min_images_only, property =hybrid_mark) - endif - do j=1,nextlist%N - jj = nextlist%int(1,j) - shift = nextlist%int(2:4,j) - if (hybrid_mark(jj) /= HYBRID_NO_MARK) call append(bufferlist, nextlist%int(:,j)) - end do - call append(currentlist, nextlist) - - ! check that cluster is still growing - if (bufferlist%N == old_n) then - exit - if (cluster_hopping_skip_unreachable) then - call print('WARNING: skipping buffer atoms no longer connected') - exit - else - RAISE_ERROR('create_hybrid_weights: buffer cluster stopped growing before all marked atoms found - check for split QM or buffer region', error) - end if - end if - old_n = bufferlist%N - end do - n_region2 = bufferlist%N ! possibly excluding some no-longer-reachable atoms - - ! Remove marks on all buffer atoms - do i=1,oldbuffer%N - if (hybrid_mark(oldbuffer%int(1,i)) == HYBRID_BUFFER_MARK .or. & - hybrid_mark(oldbuffer%int(1,i)) == HYBRID_BUFFER_OUTER_LAYER_MARK) & - hybrid_mark(oldbuffer%int(1,i)) = HYBRID_NO_MARK - end do - - !construct the hysteretic buffer region: - if (hysteretic_connect) then - call print("create_hybrid_weights calling construct_hysteretic_region", verbosity=PRINT_NERD) - call construct_hysteretic_region(region=bufferlist,at=at,core=total_embedlist,loop_atoms_no_connectivity=.false., & - inner_radius=hysteretic_buffer_inner_radius,outer_radius=hysteretic_buffer_outer_radius,use_avgpos=.false., & - add_only_heavy_atoms=construct_buffer_use_only_heavy_atoms, cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, & - force_hopping_nneighb_only=hysteretic_buffer_nneighb_only, min_images_only=min_images_only, & - alt_connect=at%hysteretic_connect, & - ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica, error=error) !NB, debugfile=mainlog) lam81 - else - call print("create_hybrid_weights calling construct_hysteretic_region", verbosity=PRINT_NERD) - call construct_hysteretic_region(region=bufferlist,at=at,core=total_embedlist,loop_atoms_no_connectivity=.false., & - inner_radius=hysteretic_buffer_inner_radius,outer_radius=hysteretic_buffer_outer_radius,use_avgpos=.false., & - add_only_heavy_atoms=construct_buffer_use_only_heavy_atoms, cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, & - force_hopping_nneighb_only=hysteretic_buffer_nneighb_only, min_images_only=min_images_only, & - ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica, error=error) !NB, debugfile=mainlog) lam81 - endif - - call print('bufferlist=',PRINT_VERBOSE) - call print(bufferlist,PRINT_VERBOSE) - - ! Mark new buffer region, leaving core QM region alone - ! at the moment only ACTIVE and NO marks are present, because hybrid_mark was set to =hybrid - do i=1,bufferlist%N - if (hybrid_mark(bufferlist%int(1,i)) == HYBRID_NO_MARK) & - hybrid_mark(bufferlist%int(1,i)) = HYBRID_BUFFER_MARK - - ! Marking the outer layer with HYBRID_BUFFER_OUTER_LAYER_MARK is - ! dealt with in create_cluster_from_mark. - - end do - - call finalise(bufferlist) - call finalise(oldbuffer) -! call finalise(embedlist) - - end if - - ! this is commented out for now, terminations are controlled in create_cluster only - ! create terminations - !n_term = 0 - !if(terminate) then - ! call BFS_step(at, currentlist, nextlist, nneighb_only = .true., min_images_only = .true.) - ! do j = 1,nextlist%N - ! jj = nextlist%int(1,j) - ! if(hybrid_mark(jj) == HYBRID_NO_MARK) then - ! weight_region1(jj) = 0.0_dp - ! hybrid_mark(jj) = HYBRID_TERM_MARK - ! n_term = n_term+1 - ! end if - ! end do - !end do - - call print('create_hybrid_weights: '//list_1//' region 1, '//n_trans//' transition, '//n_region2//& - ' region 2, '//count(hybrid_mark /= HYBRID_NO_MARK)//' in total', PRINT_VERBOSE) - !call print('create_hybrid_weights: '//n_region1//' region 1, '//n_trans//' transition, '//n_region2//& - ! ' region 2, '//count(hybrid_mark /= HYBRID_NO_MARK)//' in total', PRINT_VERBOSE) - ! call sort(total_embedlist) - - call finalise(activelist) - call finalise(currentlist) - call finalise(nextlist) - call finalise(distances) - call finalise(total_embedlist) - - end subroutine create_hybrid_weights - - !% Return estimated `(origin, extent)` for hysteretic connectivity - !% calculator to include all atoms within a distance `cluster_radius` - !% of an atom in the `active` array. - subroutine estimate_origin_extent(at, active, cluster_radius, origin, extent) - type(Atoms), intent(in) :: at - logical, intent(in) :: active(:) - real(dp), intent(in) :: cluster_radius - real(dp), intent(out) :: origin(3), extent(3,3) - - real(dp) :: center(3), low_corner(3), high_corner(3), dr(3) - integer :: i, n_active, first_active - logical :: found_first_active - - found_first_active = .false. - n_active = 0 - do i=1, at%N - if (.not. active(i)) cycle - n_active = n_active + 1 - if (found_first_active) then - center = center + diff_min_image(at, first_active, i) - else - center = 0.0_dp - first_active = i - found_first_active = .true. - endif - end do - center = center / real(n_active, dp) - center = center + at%pos(:,first_active) - - call print("estimate_origin_extent: got center" // center, verbosity=PRINT_VERBOSE) - - low_corner = 1.0e38_dp - high_corner = -1.0e38_dp - do i=1, at%N - if (.not. active(i)) cycle - dr = diff_min_image(at, at%pos(:,i), center) - low_corner = min(low_corner, dr) - high_corner = max(high_corner, dr) - end do - call print("estimate_origin_extent: got relative low_corner" // low_corner, verbosity=PRINT_NERD) - call print("estimate_origin_extent: got relative high_corner" // high_corner, verbosity=PRINT_NERD) - low_corner = low_corner + center - high_corner = high_corner + center - - call print("estimate_origin_extent: got low_corner" // low_corner, verbosity=PRINT_NERD) - call print("estimate_origin_extent: got high_corner" // high_corner, verbosity=PRINT_NERD) - - origin = low_corner - cluster_radius - extent = 0.0_dp - extent(1,1) = (high_corner(1)-low_corner(1))+2.0_dp*cluster_radius - extent(2,2) = (high_corner(2)-low_corner(2))+2.0_dp*cluster_radius - extent(3,3) = (high_corner(3)-low_corner(3))+2.0_dp*cluster_radius - - call print("estimate_origin_extent: got origin" // origin, verbosity=PRINT_VERBOSE) - call print("estimate_origin_extent: got extent(1,:) " // extent(1,:), verbosity=PRINT_VERBOSE) - call print("estimate_origin_extent: got extent(2,:) " // extent(2,:), verbosity=PRINT_VERBOSE) - call print("estimate_origin_extent: got extent(3,:) " // extent(3,:), verbosity=PRINT_VERBOSE) - - end subroutine estimate_origin_extent - - !% Given an Atoms structure with an active region marked in the mark_name (default 'hybrid_mark') - !% property using 'HYBRID_ACTIVE_MARK', grow the embed region by 'fit_hops' - !% bond hops to form a fit region. Returns the embedlist and fitlist with correct - !% periodic shifts. - subroutine create_embed_and_fit_lists(at, fit_hops, embedlist, fitlist, cluster_hopping_nneighb_only, min_images_only, mark_name, error) - - type(Atoms), intent(inout) :: at - integer :: fit_hops - type(Table), intent(out) :: embedlist, fitlist - logical, intent(in), optional :: cluster_hopping_nneighb_only, min_images_only - character(len=*), intent(in), optional :: mark_name - integer, optional, intent(out) :: error - - character(len=255) :: my_mark_name - integer, pointer :: hybrid_mark(:) - integer :: n_region1, n_region2 !, n_term - integer :: i, j, jj, first_active, shift(3) - logical :: do_hopping_nneighb_only, do_min_images_only - type(Table) :: currentlist, nextlist, tmpfitlist - integer :: n, hybrid_number - type(Table) :: totallist - integer :: list_1 - - integer :: old_n - - INIT_ERROR(error) - - my_mark_name = optional_default('hybrid_mark', mark_name) - - call print('Entered create_embed_and_fit_lists.',PRINT_VERBOSE) - do_hopping_nneighb_only = optional_default(.false., cluster_hopping_nneighb_only) - do_min_images_only = optional_default(.true., min_images_only) - - ! check for a compatible hybrid_mark property. it must be present - if(.not.assign_pointer(at, trim(my_mark_name), hybrid_mark)) then - RAISE_ERROR('create_fit_region: atoms structure has no "'//trim(my_mark_name)//'"', error) - endif - - call wipe(embedlist) - call wipe(fitlist) - - ! Add first marked atom to embedlist. shifts will be relative to this atom - first_active = find_in_array(hybrid_mark, HYBRID_ACTIVE_MARK) - - n_region1 = count(hybrid_mark == HYBRID_ACTIVE_MARK) - list_1 = 0 - call allocate(totallist,4,0,0,0) - call allocate(currentlist,4,0,0,0) - - ! Add other active atoms using bond hopping from the first atom - ! in the cluster to find the other active atoms and hence to determine the correct - ! periodic shifts - ! - old_n = embedlist%N - do while (embedlist%N < n_region1) - - call wipe(currentlist) - call wipe(nextlist) - call wipe(totallist) - - call append(totallist, (/first_active,0,0,0/)) - call print('create_embed_and_fit_lists: expanding quantum region starting from '//first_active//' atom', PRINT_VERBOSE) - call append(currentlist, totallist) - - hybrid_number = 1 - do while (hybrid_number .ne. 0) -!!!CHECK THIS - call BFS_step(at, currentlist, nextlist, nneighb_only = .false., min_images_only = do_min_images_only, property =hybrid_mark) - - hybrid_number = 0 - do j=1,nextlist%N - jj = nextlist%int(1,j) - shift = nextlist%int(2:4,j) - if (hybrid_mark(jj) == HYBRID_ACTIVE_MARK) then - hybrid_number = hybrid_number + 1 - call append(totallist, nextlist%int(:,j)) - endif - end do - call append(currentlist, nextlist) - enddo - - list_1 = list_1 + totallist%N - call append(embedlist, totallist) - call print('create_embed_and_fit_lists: number of atoms in the embedlist is '//embedlist%N, PRINT_VERBOSE) - - if (list_1 .lt. n_region1) then - n = 0 - do i =1, at%N - if (hybrid_mark(i) == HYBRID_ACTIVE_MARK) then - n = n+1 - if (.not. Is_in_Array(int_part(embedlist,1), i)) then - first_active = i - exit - endif - endif - enddo - endif - - ! check that cluster is still growing - !if (embedlist%N == old_n) then - ! RAISE_ERROR('create_embed_and_fit_lists: (embedlist) cluster stopped growing before all marked atoms found - check for split QM region', error) - !endif - !old_n = embedlist%N - end do - - - call wipe(currentlist) - call append(currentlist, embedlist) - - - ! create region2 (fit region) - call initialise(tmpfitlist,4,0,0,0,0) - n_region2 = 0 - do i = 0,fit_hops-1 - call BFS_step(at, currentlist, nextlist, nneighb_only = do_hopping_nneighb_only, min_images_only = do_min_images_only) - do j = 1,nextlist%N - jj = nextlist%int(1,j) - if(hybrid_mark(jj) /= HYBRID_ACTIVE_MARK) then - call append(tmpfitlist, nextlist%int(:,j)) - n_region2 = n_region2+1 - end if - end do - call append(currentlist, nextlist) - end do - - call print('create_embed_and_fit_lists: '//list_1//' embed, '//n_region2//' fit', PRINT_VERBOSE) - - ! Sort order to we are stable to changes in neighbour ordering introduced - ! by calc_connect. - call sort(embedlist) - call sort(tmpfitlist) - - ! fitlist consists of sorted embedlist followed by sorted list of remainder of fit atoms - call append(fitlist, embedlist) - call append(fitlist, tmpfitlist) - - if (do_min_images_only) then - if (multiple_images(embedlist)) then - call discard_non_min_images(embedlist) - call print('create_embed_and_fits_lists: multiple images discarded from embedlist', PRINT_VERBOSE) - endif - - if (multiple_images(fitlist)) then - call discard_non_min_images(fitlist) - call print('create_embed_and_fits_lists: multiple images discarded from fitlist', PRINT_VERBOSE) - endif - endif - - call finalise(currentlist) - call finalise(nextlist) - call finalise(tmpfitlist) - - end subroutine create_embed_and_fit_lists - - !% Given an Atoms structure with an active region marked in the mark_name (default 'cluster_mark') - !% property using 'HYBRID_ACTIVE_MARK', and buffer region marked using 'HYBRID_BUFFER_MARK', - !% 'HYBRID_TRANS_MARK' or 'HYBRID_BUFFER_OUTER_LAYER_MARK', simply returns the embedlist and fitlist - !% according to 'cluster_mark'. It does not take into account periodic shifts. - subroutine create_embed_and_fit_lists_from_cluster_mark(at,embedlist,fitlist, mark_name, error) - - type(Atoms), intent(in) :: at - type(Table), intent(out) :: embedlist, fitlist - character(len=*), intent(in), optional :: mark_name - integer, optional, intent(out) :: error - - character(len=255) :: my_mark_name - type(Table) :: tmpfitlist - - INIT_ERROR(error) - - my_mark_name = optional_default('cluster_mark', mark_name) - - call print('Entered create_embed_and_fit_lists_from_cluster_mark.',PRINT_VERBOSE) - call wipe(embedlist) - call wipe(fitlist) - call wipe(tmpfitlist) - - !build embed list from ACTIVE atoms - call list_matching_prop(at,embedlist,trim(my_mark_name),HYBRID_ACTIVE_MARK) - - !build fitlist from BUFFER and TRANS atoms - call list_matching_prop(at,tmpfitlist,trim(my_mark_name),HYBRID_BUFFER_MARK) - call append(fitlist,tmpfitlist) - call list_matching_prop(at,tmpfitlist,trim(my_mark_name),HYBRID_TRANS_MARK) - call append(fitlist,tmpfitlist) - call list_matching_prop(at,tmpfitlist,trim(my_mark_name),HYBRID_BUFFER_OUTER_LAYER_MARK) - call append(fitlist,tmpfitlist) - - call wipe(tmpfitlist) - call append(tmpfitlist,fitlist) - - ! Sort in order to we are stable to changes in neighbour ordering introduced - ! by calc_connect. - call sort(embedlist) - call sort(tmpfitlist) - - ! fitlist consists of sorted embedlist followed by sorted list of remainder of fit atoms - call wipe(fitlist) - call append(fitlist, embedlist) - call append(fitlist, tmpfitlist) - - call print('Embedlist:',PRINT_ANALYSIS) - call print(int_part(embedlist,1),PRINT_ANALYSIS) - call print('Fitlist:',PRINT_ANALYSIS) - call print(int_part(fitlist,1),PRINT_ANALYSIS) - - call finalise(tmpfitlist) - call print('Leaving create_embed_and_fit_lists_from_cluster_mark.',PRINT_VERBOSE) - - end subroutine create_embed_and_fit_lists_from_cluster_mark - - !% Return the atoms in a hysteretic region: - !% To become part of the 'list' region, atoms must drift within the - !% 'inner' list. To leave the 'list' region, an atom - !% must drift further than 'outer'. - !% Optionally use time averaged positions - ! - subroutine update_hysteretic_region(at,inner,outer,list,min_images_only,error) - - type(Atoms), intent(in) :: at - type(Table), intent(inout) :: inner, outer - type(Table), intent(inout) :: list - logical, optional, intent(in) :: min_images_only - integer, optional, intent(out) :: error - - integer n, my_verbosity - logical do_min_images_only - integer, allocatable :: cols(:) - - INIT_ERROR(error) - - my_verbosity = current_verbosity() - do_min_images_only = optional_default(.false., min_images_only) - call print('update_hysteretic_region: do_min_images_only='//do_min_images_only, PRINT_VERBOSE) - - if (do_min_images_only) then - ! only compare atom indices - first column in table - allocate(cols(1)) - cols(1) = 1 - else - ! compare atom indices and shifts - all four columns in table - allocate(cols(4)) - cols(:) = (/1, 2, 3, 4/) - end if - - if (my_verbosity == PRINT_ANALYSIS) then - call print('In Select_Hysteretic_Quantum_Region:') - call print('List currently contains '//list%N//' atoms') - end if - - if ((list%intsize /= inner%intsize) .or. (list%intsize /= outer%intsize)) then - RAISE_ERROR('update_hysteretic_region: inner, outer and list must have the same intsize', error) - endif - - ! Speed up searching - call sort(outer) - call sort(list) - - !Check for atoms in 'list' and not in 'outer' - do n = list%N, 1, -1 - if (search(outer,list%int(cols,n))==0) then - call delete(list,n) - if (my_verbosity > PRINT_NORMAL) call print('Removed atom ('//list%int(cols,n)//') from quantum list') - end if - end do - - call sort(list) - - !Check for new atoms in 'inner' cluster and add them to list - do n = 1, inner%N - if (search(list,inner%int(cols,n))==0) then - call append(list,inner%int(:,n)) ! copy shifts columns as well, even if we're not comparing them - call sort(list) - if (my_verbosity > PRINT_NORMAL) call print('Added atom ('//inner%int(cols,n)//') to quantum list') - end if - end do - - if (my_verbosity >= PRINT_NORMAL) call print(list%N//' atoms selected for quantum treatment') - deallocate(cols) - - end subroutine update_hysteretic_region - - - ! - !% Given an atoms object, and a point 'centre' or a list of atoms 'core', - !% fill the 'region' table with all atoms hysteretically within 'inner_radius -- outer_radius' - !% of the 'centre' or any 'core' atom, which can be reached by connectivity hopping. - !% In the case of building the 'region' around 'centre', simply_loop_over_atoms loops instead of - !% bond hopping. - !% Optionally use the time averaged positions. - !% Optionally use only heavy atom selection. - ! - subroutine construct_hysteretic_region(region,at,core,centre,loop_atoms_no_connectivity,inner_radius,outer_radius,use_avgpos,add_only_heavy_atoms,cluster_hopping_nneighb_only, & - force_hopping_nneighb_only, min_images_only,alt_connect,debugfile, ignore_silica_residue, res_num_silica, error) !lam81 - - type(Table), intent(inout) :: region - type(Atoms), intent(in) :: at - type(Table), optional, intent(in) :: core - real(dp), optional, intent(in) :: centre(3) - logical, optional, intent(in) :: loop_atoms_no_connectivity - real(dp), intent(in) :: inner_radius - real(dp), intent(in) :: outer_radius - logical, optional, intent(in) :: use_avgpos - logical, optional, intent(in) :: add_only_heavy_atoms - logical, optional, intent(in) :: cluster_hopping_nneighb_only - logical, optional, intent(in) :: force_hopping_nneighb_only - logical, optional, intent(in) :: min_images_only - type(Connection), optional,intent(in) :: alt_connect - type(inoutput), optional :: debugfile - integer, optional, intent(out) :: error - - type(Table) :: inner_region - type(Table) :: outer_region - logical :: no_hysteresis - - logical, optional, intent(in) :: ignore_silica_residue ! lam81 - integer, optional, intent(in) :: res_num_silica ! lam81 - - INIT_ERROR(error) - - if (present(debugfile)) call print("construct_hysteretic_region radii " // inner_radius // " " // outer_radius, file=debugfile) - !check the input arguments only in construct_region. - if (inner_radius.lt.0._dp) then - RAISE_ERROR('inner_radius must be > 0 and it is '//inner_radius, error) - endif - if (outer_radius.lt.inner_radius) then - RAISE_ERROR('outer radius ('//outer_radius//') must not be smaller than inner radius ('//inner_radius//').', error) - endif - - no_hysteresis = .false. - if ((outer_radius-inner_radius).lt.epsilon(0._dp)) no_hysteresis = .true. - if (inner_radius .feq. 0.0_dp) call print('WARNING: hysteretic region with inner_radius .feq. 0.0', PRINT_ALWAYS) - if (no_hysteresis) call print('WARNING! construct_hysteretic_region: inner_buffer=outer_buffer. no hysteresis applied: outer_region = inner_region used.',PRINT_ALWAYS) - if (present(debugfile)) call print(" no_hysteresis " // no_hysteresis, file=debugfile) - - if (present(debugfile)) call print(" constructing inner region", file=debugfile) - call construct_region(region=inner_region,at=at,core=core,centre=centre,loop_atoms_no_connectivity=loop_atoms_no_connectivity, & - radius=inner_radius,use_avgpos=use_avgpos,add_only_heavy_atoms=add_only_heavy_atoms,cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, & - force_hopping_nneighb_only=force_hopping_nneighb_only, & - min_images_only=min_images_only,alt_connect=alt_connect,debugfile=debugfile, & - ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica) !lam81 - if (no_hysteresis) then - call initialise(outer_region,4,0,0,0,0) - call append(outer_region,inner_region) - else - if (present(debugfile)) call print(" constructing outer region", file=debugfile) - call construct_region(region=outer_region,at=at,core=core,centre=centre,loop_atoms_no_connectivity=loop_atoms_no_connectivity, & - radius=outer_radius, use_avgpos=use_avgpos,add_only_heavy_atoms=add_only_heavy_atoms,cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, & - force_hopping_nneighb_only=force_hopping_nneighb_only, & - min_images_only=min_images_only,alt_connect=alt_connect,debugfile=debugfile, & - ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica) ! lam81 - endif - - if (present(debugfile)) call print(" orig inner_region list", file=debugfile) - if (present(debugfile)) call print(inner_region, file=debugfile) - if (present(debugfile)) call print(" orig outer_region list", file=debugfile) - if (present(debugfile)) call print(outer_region, file=debugfile) - if (present(debugfile)) call print(" old region list", file=debugfile) - if (present(debugfile)) call print(region, file=debugfile) - - call print('construct_hysteretic_region: old region list:',PRINT_VERBOSE) - call print(region,PRINT_VERBOSE) - - call update_hysteretic_region(at,inner_region,outer_region,region, min_images_only=min_images_only) - - call print('construct_hysteretic_region: inner_region list:',PRINT_VERBOSE) - call print(inner_region,PRINT_VERBOSE) - call print('construct_hysteretic_region: outer_region list:',PRINT_VERBOSE) - call print(outer_region,PRINT_VERBOSE) - - if (present(debugfile)) call print(" new inner region list", file=debugfile) - if (present(debugfile)) call print(inner_region, file=debugfile) - if (present(debugfile)) call print(" new outer region list", file=debugfile) - if (present(debugfile)) call print(outer_region, file=debugfile) - - call print('construct_hysteretic_region: new region list:',PRINT_VERBOSE) - call print(region,PRINT_VERBOSE) - - if (present(debugfile)) call print(" new region list", file=debugfile) - if (present(debugfile)) call print(region, file=debugfile) - - call finalise(inner_region) - call finalise(outer_region) - - end subroutine construct_hysteretic_region - - ! - !% Given an atoms object, and a point or a list of atoms in the first integer of - !% the 'core' table, fill the 'buffer' table with all atoms within 'radius' - !% of any core atom (which can be reached by connectivity hopping) or the point - !%(with bond hopping or simply looping once over the atoms). - !% Optionally use the time averaged positions (only for the radius). - !% Optionally use a heavy atom based selection (applying to both the core and the region atoms). - !% Alternatively use the hysteretic connection, only nearest neighbours and/or min_images (only for the n_connectivity_hops). - ! - subroutine construct_region(region,at,core,centre,loop_atoms_no_connectivity,radius,n_connectivity_hops,use_avgpos,add_only_heavy_atoms,cluster_hopping_nneighb_only,& - force_hopping_nneighb_only, min_images_only,alt_connect,debugfile, ignore_silica_residue, res_num_silica, error) !lam81 - - type(Table), intent(out) :: region - type(Atoms), intent(in) :: at - type(Table), optional, intent(in) :: core - real(dp), optional, intent(in) :: centre(3) - logical, optional, intent(in) :: loop_atoms_no_connectivity - real(dp), optional, intent(in) :: radius - integer, optional, intent(in) :: n_connectivity_hops - logical, optional, intent(in) :: use_avgpos - logical, optional, intent(in) :: add_only_heavy_atoms - logical, optional, intent(in) :: cluster_hopping_nneighb_only - logical, optional, intent(in) :: force_hopping_nneighb_only - logical, optional, intent(in) :: min_images_only - type(Connection), optional,intent(in) :: alt_connect -type(inoutput), optional :: debugfile - integer, optional, intent(out) :: error - - logical :: do_use_avgpos - logical :: do_loop_atoms_no_connectivity - logical :: do_add_only_heavy_atoms - logical :: do_hopping_nneighb_only, do_force_hopping_nneighb_only - logical :: do_min_images_only - integer :: i, j, ii, ij - type(Table) :: nextlist - logical :: more_hops, add_i - integer :: cur_hop - real(dp), pointer :: use_pos(:,:) - integer :: shift_i(3) - logical :: do_ignore_silica_residue, got_atom_res_number - - integer, pointer :: atom_res_number(:) !lam81 - logical, optional, intent(in) :: ignore_silica_residue !lam81 - integer, optional, intent(in) :: res_num_silica - - INIT_ERROR(error) - - do_loop_atoms_no_connectivity = optional_default(.false.,loop_atoms_no_connectivity) - do_ignore_silica_residue = optional_default(.false., ignore_silica_residue) - - do_add_only_heavy_atoms = optional_default(.false.,add_only_heavy_atoms) - if (do_add_only_heavy_atoms .and. .not. has_property(at,'Z')) then - RAISE_ERROR("construct_region: atoms has no Z property", error) - endif - - got_atom_res_number = assign_pointer(at, 'atom_res_number', atom_res_number) - - do_use_avgpos = optional_default(.false., use_avgpos) - - if (count((/ present(centre), present(core) /)) /= 1) then - RAISE_ERROR("Need either centre or core, but not both present(centre) " // present(centre) // " present(core) "// present(core), error) - endif - - ! if we have radius, we'll have to decide what positions to use - if (present(radius)) then - if (do_use_avgpos) then - if (.not. assign_pointer(at, "avgpos", use_pos)) then - RAISE_ERROR("do_use_avgpos is true, but no avgpos property", error) - endif - else - if (.not. assign_pointer(at, "pos", use_pos)) then - RAISE_ERROR("do_use_avgpos is false, but no pos property", error) - endif - endif - endif - - call initialise(region,4,0,0,0,0) - - if (do_loop_atoms_no_connectivity) then - if (present(debugfile)) call print(" loop over atoms", file=debugfile) - if (.not. present(radius)) then - RAISE_ERROR("do_loop_atoms_no_connectivity=T requires radius", error) - endif - if (present(n_connectivity_hops) .or. present(min_images_only) .or. present(cluster_hopping_nneighb_only)) & - call print("WARNING: do_loop_atoms_no_connectivity, but specified unused arg n_connectivity_hops " // present(n_connectivity_hops) // & - " min_images_only " // present(min_images_only) // " cluster_hopping_nneighb_only " // present(cluster_hopping_nneighb_only), PRINT_ALWAYS) - ! jrk33: disabled this warning - should be fine with small cells since distance_min_image is used. - ! call print('WARNING: check if your cell is greater than the radius, looping only works in that case.',PRINT_ALWAYS) - !if (any((/at%lattice(1,1),at%lattice(2,2),at%lattice(3,3)/) < radius)) then - !RAISE_ERROR('too small cell', error) - !endifx - do i = 1,at%N - if (present(debugfile)) call print("check atom i " // i // " Z " // at%Z(i) // " pos " // at%pos(:,i), file=debugfile) - if (do_add_only_heavy_atoms .and. at%Z(i) == 1) cycle - if (present(centre)) then ! distance from centre is all that matters - if (present(debugfile)) call print(" distance_min_image use_pos i " // use_pos(:,i) // " centre " // centre // " dist " // distance_min_image(at, use_pos(:,i), centre(1:3), shift_i(1:3)), file=debugfile) - if (distance_min_image(at,use_pos(:,i),centre(1:3),shift_i(1:3)) < radius) then - if (present(debugfile)) call print(" adding i " // i // " at " // use_pos(:,i) // " center " // centre // " dist " // distance_min_image(at, use_pos(:,i), centre(1:3), shift_i(1:3)), file=debugfile) - call append(region,(/i,shift_i(1:3)/)) - endif - else ! no centre, check distance from each core list atom - do ij=1, core%N - j = core%int(1,ij) - if (present(debugfile)) call print(" core atom ij " // ij // " j " // j // " distance_min_image use_pos i " // use_pos(:,i) // " use_pos j " // use_pos(:,j) // " dist " // distance_min_image(at, use_pos(:,i), use_pos(:,j), shift_i(1:3)), file=debugfile) - if (distance_min_image(at,use_pos(:,i),use_pos(:,j),shift_i(1:3)) < radius) then - if (present(debugfile)) call print(" adding i " // i // " at " // use_pos(:,i) // " near j " // j // " at " // use_pos(:,j) // " dist " // distance_min_image(at, use_pos(:,i), use_pos(:,j), shift_i(1:3)), file=debugfile) - call append(region,(/i,shift_i(1:3)/)) - exit - endif - end do ! j - endif ! no centre, use core - enddo ! i - - else ! do_loop_atoms_no_connectivity - - if (.not. present(core)) then - RAISE_ERROR("do_loop_atoms_no_connectivity is false, trying connectivity hops, but no core list is specified", error) - endif - - if (present(debugfile)) call print(" connectivity hopping", file=debugfile) - if (present(debugfile) .and. present(radius)) call print(" have radius " // radius, file=debugfile) - if (present(debugfile)) call print(" present cluster_hopping_nneighb_only " // present(cluster_hopping_nneighb_only), file=debugfile) - if (present(debugfile) .and. present(cluster_hopping_nneighb_only)) call print(" cluster_hopping_nneighb_only " // cluster_hopping_nneighb_only, file=debugfile) - do_hopping_nneighb_only = optional_default(.true., cluster_hopping_nneighb_only) - do_force_hopping_nneighb_only = optional_default(.false., force_hopping_nneighb_only) - do_min_images_only = optional_default(.true., min_images_only) - if (do_use_avgpos) then - RAISE_ERROR("can't use avgpos with connectivity hops - make sure your connectivity is based on pos instead", error) - endif - - if (do_ignore_silica_residue) then - call print_message('WARNING', 'Overriding min_images_only since ignore_silica_residue=T') - do_min_images_only = .true. !lam81 - end if - ! start with core - call append(region,core) - - more_hops = .true. - cur_hop = 1 - do while (more_hops) - if (present(debugfile)) call print(' construct_region do_hopping_nneighb_only = ' // do_hopping_nneighb_only // ' do_min_images_only = '//do_min_images_only, file=debugfile) - if (present(debugfile)) call print(' doing hop ' // cur_hop, file=debugfile) - if (present(debugfile)) call print(' cutoffs ' // at%cutoff, file=debugfile) - more_hops = .false. - call bfs_step(at, region, nextlist, nneighb_only=(do_hopping_nneighb_only .and. .not. present(radius)) .or. do_force_hopping_nneighb_only, & - min_images_only=do_min_images_only, max_r=radius, alt_connect=alt_connect, debugfile=debugfile) - if (present(debugfile)) call print(" bfs_step returned nextlist%N " // nextlist%N, file=debugfile) - if (present(debugfile)) call print(nextlist, file=debugfile) - if (nextlist%N /= 0) then ! go over things in next hop - do ii=1, nextlist%N - i = nextlist%int(1,ii) - add_i = .true. - if (do_add_only_heavy_atoms) then - if (at%Z(i) == 1) cycle - endif - if (do_ignore_silica_residue .and. got_atom_res_number) then ! lam81 - if (atom_res_number(i) == res_num_silica) cycle ! lam81 - endif - if (present(debugfile)) call print(" i " // i // " is heavy or all atoms requested", file=debugfile) - if (present(radius)) then ! check to make sure we're close enough to core list - if (present(debugfile)) call print(" radius is present, check distance from core list", file=debugfile) - add_i = .false. - do ij=1, core%N - j = core%int(1,ij) - if (present(debugfile)) call print(" distance of ii " // ii // " i " // i // " at " // use_pos(:,i) // " from ij " // ij // " j " // j // " at " // use_pos(:,j) // " is " // distance_min_image(at,use_pos(:,i),use_pos(:,j),shift_i(1:3)), file=debugfile) - if (distance_min_image(at,use_pos(:,i),use_pos(:,j),shift_i(1:3)) <= radius) then - if (present(debugfile)) call print(" decide to add i", file=debugfile) - add_i = .true. - exit ! from ij loop - endif - end do ! ij - endif ! present(radius) - if (add_i) then - if (present(debugfile)) call print(" actually adding i", file=debugfile) - more_hops = .true. - call append(region, nextlist%int(1:4,ii)) - endif - end do - else ! nextlist%N == 0 - if (present(n_connectivity_hops)) then - if (n_connectivity_hops > 0) & - call print("WARNING: n_connectivity_hops = " // n_connectivity_hops // " cur_hop " // cur_hop // " but no atoms added") - endif - endif ! nextlist%N - - cur_hop = cur_hop + 1 - if (present(n_connectivity_hops)) then - if (cur_hop > n_connectivity_hops) more_hops = .false. - endif - end do ! while more_hops - - endif ! do_loop_atoms_no_connectivity - if (present(debugfile)) call print("leaving construct_region()", file=debugfile) - - end subroutine construct_region - - - subroutine update_active(this, nneightol, avgpos, reset, error) - type(Atoms) :: this - real(dp), optional :: nneightol - logical, optional :: avgpos, reset - integer, optional, intent(out) :: error - - type(Atoms), save :: nn_atoms - integer, pointer, dimension(:) :: nn, old_nn, active - integer :: i - real(dp) :: use_nn_tol - logical :: use_avgpos, do_reset - - INIT_ERROR(error) - - use_nn_tol = optional_default(this%nneightol, nneightol) - use_avgpos = optional_default(.true., avgpos) - do_reset = optional_default(.false., reset) - - ! First time copy entire atoms structure into nn_atoms and - ! add properties for nn, old_nn and active - if (reset .or. .not. is_initialised(nn_atoms)) then - nn_atoms = this - call add_property(this, 'nn', 0) - call add_property(this, 'old_nn', 0) - call add_property(this, 'active', 0) - - - end if - - if (this%N /= nn_atoms%N) then - RAISE_ERROR('update_actives: Number mismatch between this%N ('//this%N//') and nn_atoms%N ('//nn_atoms%N//')', error) - endif - - if (.not. assign_pointer(this, 'nn', nn)) then - RAISE_ERROR('update_actives: Atoms is missing "nn" property', error) - endif - - if (.not. assign_pointer(this, 'old_nn', old_nn)) then - RAISE_ERROR('update_actives: Atoms is missing "old_nn" property', error) - endif - - if (.not. assign_pointer(this, 'active', active)) then - RAISE_ERROR('update_actives: Atoms is missing "active" property', error) - endif - - call print('update_actives: recalculating nearest neighbour table', PRINT_VERBOSE) - if (use_avgpos .and. associated(this%avgpos)) then - call print('update_actives: using time averaged atomic positions', PRINT_VERBOSE) - nn_atoms%pos = this%avgpos - else - call print('update_actives: using instantaneous atomic positions', PRINT_VERBOSE) - nn_atoms%pos = this%pos - end if - !% Use hysteretic connect so we can work with relative cutoffs - call calc_connect_hysteretic(nn_atoms, cutoff_factor=use_nn_tol, & - cutoff_break_factor=use_nn_tol) - - nn = 0 - do i = 1,nn_atoms%N - nn(i) = n_neighbours(nn_atoms, i) - end do - - if (all(old_nn == 0)) old_nn = nn ! Special case for first time - - ! Decrement the active counts - where (active /= 0) active = active -1 - - ! Find newly active atoms - where (nn /= old_nn) active = 1 - - if (count(active == 1) /= 0) then - call print('update_actives: '//count(active == 1)//' atoms have become active.') - end if - - old_nn = nn - - end subroutine update_active - - - ! - !% Given an atoms structure and a list of quantum atoms, find X-H - !% bonds which have been cut and include the other atom of - !% the pair in the quantum list. - ! - subroutine add_cut_hydrogens(this,qmlist,heuristics_nneighb_only,verbosity,alt_connect) - - type(Atoms), intent(in), target :: this - type(Table), intent(inout) :: qmlist - integer, optional, intent(in) :: verbosity - logical, optional, intent(in) :: heuristics_nneighb_only - type(Connection), intent(in), optional, target :: alt_connect - - type(Table) :: neighbours, bonds, centre - logical :: more_atoms - integer :: i, j, n, nn, added - type(Connection), pointer :: use_connect - logical :: my_heuristics_nneighb_only - - ! Check for atomic connectivity - if (present(alt_connect)) then - use_connect => alt_connect - else - use_connect => this%connect - endif - - my_heuristics_nneighb_only = optional_default(.true., heuristics_nneighb_only) - - more_atoms = .true. - added = 0 - call allocate(centre,4,0,0,0,1) - - !Repeat while the search trigger is true - do while(more_atoms) - - more_atoms = .false. - - !Find nearest neighbours of the cluster - call bfs_step(this,qmlist,neighbours,nneighb_only=my_heuristics_nneighb_only,min_images_only=.true.,alt_connect=use_connect) - - !Loop over neighbours - do n = 1, neighbours%N - - i = neighbours%int(1,n) - - call wipe(centre) - call append(centre,(/i,0,0,0/)) - - ! Find atoms bonded to this neighbour - call bfs_step(this,centre,bonds,nneighb_only=my_heuristics_nneighb_only,min_images_only=.true.,alt_connect=use_connect) - - !Loop over these bonds - do nn = 1, bonds%N - - j = bonds%int(1,nn) - - !Try to find j in the qmlist - if (find_in_array(int_part(qmlist,1),j)/=0) then - !We have a cut bond. If i or j are hydrogen then add i to the - !quantum list and trigger another search after this one - if (this%Z(i)==1 .or. this%Z(j)==1) then - call append(qmlist,(/i,0,0,0/)) - if (present(verbosity)) then - if (verbosity >= PRINT_NORMAL) call print('Add_Cut_Hydrogens: Added atom '//i//', neighbour of atom '//j) - end if - more_atoms = .true. - added = added + 1 - exit !Don't add the same atom more than once - end if - end if - - end do - - end do - - end do - - !Report findings - if (present(verbosity)) then - if (verbosity >= PRINT_NORMAL) then - write(line,'(a,i0,a)')'Add_Cut_Hydrogens: Added ',added,' atoms to quantum region' - call print(line) - end if - end if - - call finalise(centre) - call finalise(bonds) - call finalise(neighbours) - - end subroutine add_cut_hydrogens - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X GROUP CONVERSION -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - !% Convert a constrained atom's group to a normal group prior to quantum treatment - !% The constraints are not deleted, just ignored. The number of degrees of freedom - !% of the system is also updated. - ! - subroutine constrained_to_quantum(this,i) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i - integer :: g!, n, j, a1, a2 - - g = this%group_lookup(i) - - if (this%group(g)%type == TYPE_CONSTRAINED) then - write(line,'(2(a,i0),a)')' INFO: Converting group ',g,' from Constrained to Quantum' - call print(line) - - !Change the group type - call set_type(this%group(g),TYPE_ATOM) - - !Update the number of degrees of freedom (add 1 per removed constraint) - this%Ndof = this%Ndof + Group_N_Objects(this%group(g)) - - !Thermalize the released constraints -! do n = 1, group_n_objects(this%group(g)) -! -! j = group_nth_object(this%group(g),n) -! -! !If not a two body constraint then go to the next one. -! if (this%constraint(j)%N /= 2) cycle -! -! !Get the indices of the atoms in this constraint -! a1 = this%constraint(j)%atom(1) -! a2 = this%constraint(j)%atom(2) -! -! call thermalize_bond(this,a1,a2,this%sim_temp) -! -! end do - -! call thermalize_group(this,g,this%sim_temp) - - end if - - end subroutine constrained_to_quantum - - ! - !% When a constraint is released as a molecule drifts into the quantum region the - !% new, unconstrained degree of freedom has zero temperature. This routine adds - !% velocities in the directions between atoms which make up two body constraints - !% at a specified temperature - ! - subroutine thermalize_bond(this,i,j,T) - - type(DynamicalSystem), intent(inout) :: this !% The dynamical system - integer, intent(in) :: i,j !% The two atoms - real(dp), intent(in) :: T !% Temperature - real(dp) :: meff ! effective mass - real(dp), dimension(3) :: u_hat ! unit vector between the atoms - real(dp) :: w, wi, wj, & ! magnitude of velocity component in bond direction - mi, mj ! masses of the atoms - real(dp) :: E0,E1 ! kinetic energy in bond before and after - real(dp), save :: Etot = 0.0_dp ! cumulative energy added to the system - real(dp), save :: Eres = 0.0_dp ! cumulative energy already in bonds (QtoC error) - real(dp) :: r, v ! relative distance and velocity - - call print('Thermalize_Bond: Thermalizing bond '//i//'--'//j) - - ! Find unit vector along bond and current relative velocity - call distance_relative_velocity(this%atoms,i,j,r,v) - - ! Find unit vector between atoms - u_hat = diff_min_image(this%atoms,i,j) - u_hat = u_hat / norm(u_hat) - - ! Calculate effective mass - mi = ElementMass(this%atoms%Z(i)) - mj = ElementMass(this%atoms%Z(j)) - meff = mi * mj / (mi + mj) - - ! Calculate energy currently stored in this bond (should be zero) - E0 = 0.5_dp * meff * v * v - Eres = Eres + E0 - - call print('Thermalize_Bond: Bond currently contains '//round(E0,8)//' eV') - call print('Thermalize_Bond: Residual energy encountered so far: '//round(Eres,8)//' eV') - - ! Draw a velocity for this bond - w = gaussian_velocity_component(meff,T) - w = w - v ! Adjust for any velocity which the bond already had - - ! Distribute this between the two atoms, conserving momentum - wi = (meff / mi) * w - wj = -(meff / mj) * w - - this%atoms%velo(:,i) = this%atoms%velo(:,i) + wi * u_hat - this%atoms%velo(:,j) = this%atoms%velo(:,j) + wj * u_hat - - call distance_relative_velocity(this%atoms,i,j,r,v) - E1 = 0.5_dp * meff * v * v - - Etot = Etot + E1 - E0 - - call print('Thermalize_Bond: Added '//round(E1-E0,8)//' eV to bond') - call print('Thermalize_Bond: Added '//round(Etot,8)//' eV to the system so far') - - end subroutine thermalize_bond - - ! - !% Convert a quantum atom's group to a constrained group. The group is searched for - !% two body constraints, which are assumed to be bond length or time dependent bond length - !% constraints. The required final length is extracted, and a new time dependent bond length - !% constraint is imposed, taking the current length and relative velocity along the bond - !% to the required values, in the time given by smoothing_time. - !% - !% Any other constraints are left untouched. - ! - subroutine quantum_to_constrained(this,i,smoothing_time) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: i - real(dp), intent(in) :: smoothing_time - integer, save :: CUBIC_BONDLENGTH_SQ_FUNC - logical, save :: first_call = .true. - integer :: g, j, n, a1, a2, datalength - real(dp) :: x0,y0,y0p,x1,y1,y1p, coeffs(4), t, dE, m1, m2, meff - real(dp), save :: Etot = 0.0_dp - - !Register the constraint function if this is the first call - if (first_call) then - CUBIC_BONDLENGTH_SQ_FUNC = Register_Constraint(CUBIC_BONDLENGTH_SQ) - first_call = .false. - end if - - g = this%group_lookup(i) - - if (this%group(g)%type == TYPE_ATOM) then - write(line,'(2(a,i0),a)')' INFO: Converting group ',g,' from Quantum to Constrained' - call print(line) - - !Change the group type - call set_type(this%group(g),TYPE_CONSTRAINED) - - !Update the number of degrees of freedom (subtract 1 per added constraint) - this%Ndof = this%Ndof - Group_N_Objects(this%group(g)) - - !Loop over constraints - do n = 1, Group_N_Objects(this%group(g)) - - j = Group_Nth_Object(this%group(g),n) - - !If not a two body constraint then go to the next one. - if (this%constraint(j)%N /= 2) cycle - - !Get the indices of the atoms in this constraint - a1 = this%constraint(j)%atom(1) - a2 = this%constraint(j)%atom(2) - - !Detect the type of constraint (simple bondlength or time dependent bond length) - !from the size of the data array (1 or 6) - datalength = size(this%constraint(j)%data) - select case(datalength) - case(1) - !Simple bond length: the required final length is the only entry - y1 = this%constraint(j)%data(1) - case(6) - !Time dependent bond length: the final length is the polynomial evaluated at the end point - coeffs = this%constraint(j)%data(1:4) - t = this%constraint(j)%data(6) - y1 = ((coeffs(1)*t + coeffs(2))*t + coeffs(3))*t + coeffs(4) - case default - !This isn't a known bond length constraint. Set y1 to a negative value. - y1 = -1.0_dp - end select - - !If an existing bond length constraint has been found then set up a time dependent constraint - if (y1 > 0.0_dp) then - - call print('Quantum_to_Constrained: Reconstraining bond '//a1//'--'//a2) - - x0 = this%t - call distance_relative_velocity(this%atoms,a1,a2,y0,y0p) - x1 = this%t + smoothing_time - y1p = 0.0_dp - - !Find the coefficients of the cubic which fits these boundary conditions - call fit_cubic(x0,y0,y0p,x1,y1,y1p,coeffs) - - !Change the constraint - call ds_amend_constraint(this,j,CUBIC_BONDLENGTH_SQ_FUNC,(/coeffs,x0,x1/)) - - !Work out the amount of energy which will be removed - m1 = ElementMass(this%atoms%Z(a1)) - m2 = ElementMass(this%atoms%Z(a2)) - meff = m1 * m2 / (m1 + m2) - - dE = 0.5_dp * meff * y0p * y0p - Etot = Etot + dE - - call print('Quantum_to_Constrained: Gradually removing '//round(dE,8)//' eV from bond') - call print('Quantum_to_Constrained: Will have removed approximately '//round(Etot,8)//' eV in total') - - end if - - end do - - end if - - end subroutine quantum_to_constrained - - - subroutine thermalize_group(this,g,T) - - type(DynamicalSystem), intent(inout) :: this - integer, intent(in) :: g - real(dp), intent(in) :: T - - integer :: i, j, k - real(dp) :: mi, mj, mk, mij, mik, mjk, vij, vik, vjk, rij, rik, rjk, gij, gik, gjk - real(dp) :: ri(3), rj(3), rk(3), Rcom(3) - real(dp) :: A(9,9), b(9), A_inv(9,9), x(9) - - real(dp) :: dEij, dEik, dEjk - real(dp), save :: Etot = 0.0_dp - - ! Get atoms - i = this%group(g)%atom(1) - j = this%group(g)%atom(2) - k = this%group(g)%atom(3) - - ! Get shifted positions - ri = 0.0_dp - rj = diff_min_image(this%atoms,i,j) - rk = diff_min_image(this%atoms,i,k) - - ! Get separations and current bond velocities - call distance_relative_velocity(this%atoms,i,j,rij,vij) - call distance_relative_velocity(this%atoms,i,k,rik,vik) - call distance_relative_velocity(this%atoms,j,k,rjk,vjk) - - ! Calculate masses - mi = ElementMass(this%atoms%Z(i)) - mj = ElementMass(this%atoms%Z(j)) - mk = ElementMass(this%atoms%Z(k)) - mij = mi * mj / (mi + mj) - mik = mi * mk / (mi + mk) - mjk = mj * mk / (mj + mk) - - ! Calculate centre of mass - Rcom = (mi*ri + mj*rj + mk*rk) / (mi+mj+mk) - - ! Select a gaussian distributed velocity adjustment for each bond - gij = gaussian_velocity_component(mij,T) - gik = gaussian_velocity_component(mik,T) - gjk = gaussian_velocity_component(mjk,T) - vij = gij - vij - vik = gik - vik - vjk = gjk - vjk - - ! Build matrix... - A = 0.0_dp - b = 0.0_dp - - ! Momentum conservation - A(1,1) = mi; A(2,2) = mi; A(3,3) = mi - A(1,4) = mj; A(2,5) = mj; A(3,6) = mj - A(1,7) = mk; A(2,8) = mk; A(3,9) = mk - - ! Angular momentum conservation - A(4,2) = -mi * (ri(3) - Rcom(3)); A(4,3) = mi * (ri(2) - Rcom(2)) - A(4,5) = -mj * (rj(3) - Rcom(3)); A(4,6) = mj * (rj(2) - Rcom(2)) - A(4,8) = -mk * (rk(3) - Rcom(3)); A(4,9) = mk * (rk(2) - Rcom(2)) - - A(5,1) = mi * (ri(3) - Rcom(3)); A(5,3) = -mi * (ri(1) - Rcom(1)) - A(5,4) = mj * (rj(3) - Rcom(3)); A(5,6) = -mj * (rj(1) - Rcom(1)) - A(5,7) = mk * (rk(3) - Rcom(3)); A(5,9) = -mk * (rk(1) - Rcom(1)) - - A(6,1) = -mi * (ri(2) - Rcom(2)); A(6,2) = mi * (ri(1) - Rcom(1)) - A(6,4) = -mj * (rj(2) - Rcom(2)); A(6,5) = mj * (rj(1) - Rcom(1)) - A(6,7) = -mk * (rk(2) - Rcom(2)); A(6,8) = mk * (rk(1) - Rcom(1)) - - ! Bond length velocities - A(7,1) = ri(1) - rj(1); A(7,2) = ri(2) - rj(2); A(7,3) = ri(3) - rj(3) - A(7,4) = rj(1) - ri(1); A(7,5) = rj(2) - ri(2); A(7,6) = rj(3) - ri(3) - b(7) = rij * vij - - A(8,1) = ri(1) - rk(1); A(8,2) = ri(2) - rk(2); A(8,3) = ri(3) - rk(3) - A(8,7) = rk(1) - ri(1); A(8,8) = rk(2) - ri(2); A(8,9) = rk(3) - ri(3) - b(8) = rik * vik - - A(9,4) = rj(1) - rk(1); A(9,5) = rj(2) - rk(2); A(9,6) = rj(3) - rk(3) - A(9,7) = rk(1) - rj(1); A(9,8) = rk(2) - rj(2); A(9,9) = rk(3) - rj(3) - b(9) = rjk * vjk - - ! Invert - call inverse(A,A_inv) - x = A_inv .mult. b - - call print('Momentum before update = '//momentum(this,(/i,j,k/))) - - call print('Angular momentum before update = '//& - (mi*((ri-Rcom) .cross. this%atoms%velo(:,i)) + & - mj*((rj-Rcom) .cross. this%atoms%velo(:,j)) + & - mk*((rk-Rcom) .cross. this%atoms%velo(:,k)))) - - dEij = -bond_energy(this,i,j) - dEik = -bond_energy(this,i,k) - dEjk = -bond_energy(this,j,k) - - this%atoms%velo(:,i) = this%atoms%velo(:,i) + x(1:3) - this%atoms%velo(:,j) = this%atoms%velo(:,j) + x(4:6) - this%atoms%velo(:,k) = this%atoms%velo(:,k) + x(7:9) - - dEij = dEij + bond_energy(this,i,j) - dEik = dEik + bond_energy(this,i,k) - dEjk = dEjk + bond_energy(this,j,k) - - call print('Momentum after update = '//momentum(this,(/i,j,k/))) - - call print('Angular momentum after update = '//& - (mi*((ri-Rcom) .cross. this%atoms%velo(:,i)) + & - mj*((rj-Rcom) .cross. this%atoms%velo(:,j)) + & - mk*((rk-Rcom) .cross. this%atoms%velo(:,k)))) - - ! Now check the result - - call print('Required velocity for bond '//i//'--'//j//': '//gij) - call print('Required velocity for bond '//i//'--'//k//': '//gik) - call print('Required velocity for bond '//j//'--'//k//': '//gjk) - - call distance_relative_velocity(this%atoms,i,j,rij,vij) - call distance_relative_velocity(this%atoms,i,k,rik,vik) - call distance_relative_velocity(this%atoms,j,k,rjk,vjk) - - call print('') - - call print('Actual velocity for bond '//i//'--'//j//': '//vij) - call print('Actual velocity for bond '//i//'--'//k//': '//vik) - call print('Actual velocity for bond '//j//'--'//k//': '//vjk) - - call print('Energy added to bond '//i//'--'//j//': '//dEij) - call print('Energy added to bond '//i//'--'//k//': '//dEik) - call print('Energy added to bond '//j//'--'//k//': '//dEjk) - - Etot = Etot + dEij + dEik + dEjk - - call print('Total energy added so far = '//Etot) - - end subroutine thermalize_group - - function bond_energy(this,i,j) - - type(DynamicalSystem), intent(in) :: this - integer, intent(in) :: i, j - real(dp) :: bond_energy - - real(dp) :: mi, mj, vij, rij - - mi = ElementMass(this%atoms%Z(i)) - mj = ElementMass(this%atoms%Z(j)) - - call distance_relative_velocity(this%atoms,i,j,rij,vij) - - bond_energy = 0.5_dp * mi * mj * vij * vij / (mi + mj) - - end function bond_energy - - !% Updates the core QM flags saved in 'hybrid' and 'hybrid_mark' - !% properties. Do this hysteretically, from 'R_inner' to 'R_outer' - !% around 'origin' or 'atomlist', that is the centre of the QM - !% region (a position in space or a list of atoms). Also saves the - !% old 'hybrid_mark' property in 'old_hybrid_mark' property. - !% optionally correct selected region with heuristics (as coded in - !% :func:`create_cluster_info_from_mark`()) - ! - subroutine create_pos_or_list_centred_hybrid_region(my_atoms,R_inner,R_outer,origin, atomlist,use_avgpos,add_only_heavy_atoms, & - cluster_hopping_nneighb_only,cluster_heuristics_nneighb_only,min_images_only,use_create_cluster_info, create_cluster_info_args, list_changed, mark_postfix, & - ignore_silica_residue, res_num_silica, error) ! lam81 - - type(Atoms), intent(inout) :: my_atoms - real(dp), intent(in) :: R_inner - real(dp), intent(in) :: R_outer - real(dp), optional, intent(in) :: origin(3) - type(Table), optional, intent(in) :: atomlist !the seed of the QM region - logical, optional, intent(in) :: use_avgpos, add_only_heavy_atoms, cluster_hopping_nneighb_only, cluster_heuristics_nneighb_only, min_images_only, use_create_cluster_info - character(len=*), optional, intent(in) :: create_cluster_info_args - logical, optional, intent(out) :: list_changed - character(len=*), optional, intent(in) :: mark_postfix - integer, optional, intent(out) :: error - - logical :: do_hopping_nneighb_only, do_heuristics_nneighb_only - logical :: my_use_create_cluster_info - type(Atoms) :: atoms_for_add_cut_hydrogens - type(Table) :: core, old_core, old_all_but_term - integer, pointer :: hybrid_p(:), hybrid_mark_p(:), old_hybrid_mark_p(:) - character(len=STRING_LENGTH) :: my_create_cluster_info_args, my_mark_postfix - integer, pointer :: hybrid_region_core_tmp_p(:) - type(Table) :: padded_cluster_info - - logical, optional, intent(in) :: ignore_silica_residue ! lam81 - integer, optional, intent(in) :: res_num_silica ! lam81 - - INIT_ERROR(error) - - my_use_create_cluster_info = optional_default(.false., use_create_cluster_info) - - do_hopping_nneighb_only = optional_default(.false., cluster_hopping_nneighb_only) - do_heuristics_nneighb_only = optional_default(.true., cluster_heuristics_nneighb_only) - - if (count((/present(origin),present(atomlist)/))/=1) then - RAISE_ERROR('create_pos_or_list_centred_hybrid_mark: Exactly 1 of origin and atomlist must be present.', error) - endif - - my_mark_postfix = optional_default("", trim(mark_postfix)) - - call map_into_cell(my_atoms) - - ! save various subsets of atoms based on old hybrid marks - call allocate(core,4,0,0,0,0) - call allocate(old_core,4,0,0,0,0) - call allocate(old_all_but_term,4,0,0,0,0) - call get_hybrid_list(my_atoms,old_core,active_trans_only=.true., int_property='hybrid_mark'//trim(my_mark_postfix), error=error) - PASS_ERROR_WITH_INFO("create_pos_or_list_centred_hybrid_region getting old core", error) - call get_hybrid_list(my_atoms,core,active_trans_only=.true., int_property='hybrid_mark'//trim(my_mark_postfix), error=error) - PASS_ERROR_WITH_INFO("create_pos_or_list_centred_hybrid_region getting core", error) - call get_hybrid_list(my_atoms,old_all_but_term, all_but_term=.true., int_property='hybrid_mark'//trim(my_mark_postfix), error=error) - PASS_ERROR_WITH_INFO("create_pos_or_list_centred_hybrid_region getting all but term", error) - - ! Build the new hysteretic QM core based on distances from point/list - if (present(atomlist)) then - call print("create_pos_or_list_centred_hybrid_region calling construct_hysteretic_region", verbosity=PRINT_NERD) - call construct_hysteretic_region(region=core,at=my_atoms,core=atomlist,loop_atoms_no_connectivity=.false., & - inner_radius=R_inner,outer_radius=R_outer, use_avgpos=use_avgpos, add_only_heavy_atoms=add_only_heavy_atoms, & - cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, min_images_only=min_images_only, & - ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica, error=error) !NB , debugfile=mainlog) lam81 - else !present origin - call print("create_pos_or_list_centred_hybrid_region calling construct_hysteretic_region", verbosity=PRINT_NERD) - call construct_hysteretic_region(region=core,at=my_atoms,centre=origin,loop_atoms_no_connectivity=.true., & - inner_radius=R_inner,outer_radius=R_outer, use_avgpos=use_avgpos, add_only_heavy_atoms=add_only_heavy_atoms, & - cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, min_images_only=min_images_only, & - ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica, error=error) !NB , debugfile=mainlog) lam81 - endif - PASS_ERROR_WITH_INFO("create_pos_or_list_centred_hybrid_region constructing hysteretic region", error) - - ! call create_cluster_info_from_mark, if requested, for various chemical intuition fixes to core - if (my_use_create_cluster_info) then - call add_property(my_atoms, "hybrid_region_core_tmp", HYBRID_NO_MARK, ptr=hybrid_region_core_tmp_p) - hybrid_region_core_tmp_p(int_part(core,1)) = HYBRID_ACTIVE_MARK - if (present(create_cluster_info_args) .and. (present(cluster_hopping_nneighb_only) .or. present(cluster_heuristics_nneighb_only))) then - RAISE_ERROR("Got both create_cluster_info_args and (do_hopping_nneighb_only or do_heuristics_nneighb_only), but these conflict", error) - endif - my_create_cluster_info_args = optional_default("terminate=F cluster_hopping_nneighb_only="//do_hopping_nneighb_only// & - " cluster_heuristics_nneighb_only="//do_heuristics_nneighb_only//" cluster_allow_modification", create_cluster_info_args) - padded_cluster_info = create_cluster_info_from_mark(my_atoms, my_create_cluster_info_args, mark_name="hybrid_region_core_tmp") - call finalise(core) - call initialise(core, Nint=4, Nreal=0, Nstr=0, Nlogical=0, max_length=padded_cluster_info%N) - call append(core, blank_rows=padded_cluster_info%N) - core%int(1:4,1:padded_cluster_info%N) = padded_cluster_info%int(1:4,1:padded_cluster_info%N) - call remove_property(my_atoms,"hybrid_region_core_tmp") - endif - -!TO BE OPTIMIZED : add avgpos to add_cut_hydrogen - ! add cut hydrogens, according to avgpos - atoms_for_add_cut_hydrogens = my_atoms - atoms_for_add_cut_hydrogens%oldpos = my_atoms%avgpos - atoms_for_add_cut_hydrogens%avgpos = my_atoms%avgpos - atoms_for_add_cut_hydrogens%pos = my_atoms%avgpos - - !% Use hysteretic connectivity calculator so we can work with relative cutoffs - call calc_connect_hysteretic(atoms_for_add_cut_hydrogens, cutoff_factor=DEFAULT_NNEIGHTOL, & - cutoff_break_factor=DEFAULT_NNEIGHTOL) - - - call add_cut_hydrogens(atoms_for_add_cut_hydrogens,core) - call finalise(atoms_for_add_cut_hydrogens) - - ! check changes in QM list and set the new QM list - if (present(list_changed)) then - list_changed = check_list_change(old_list=old_core,new_list=core) - if (list_changed) call print('QM list around the origin has changed') - endif - - ! sadd old hybrid_mark property - call add_property(my_atoms,'old_hybrid_mark'//trim(my_mark_postfix),HYBRID_NO_MARK) - if (.not. assign_pointer(my_atoms,'old_hybrid_mark'//trim(my_mark_postfix),old_hybrid_mark_p)) then - RAISE_ERROR("create_pos_or_list_centred_hybrid_region couldn't get old_hybrid_mark"//trim(my_mark_postfix)//" property", error) - endif - ! update QM_flag of my_atoms - if (.not. assign_pointer(my_atoms,'hybrid_mark'//trim(my_mark_postfix),hybrid_mark_p)) then - RAISE_ERROR("create_pos_or_list_centred_hybrid_region couldn't get hybrid_mark"//trim(my_mark_postfix)//" property", error) - endif - ! save old_hybrid_mark - old_hybrid_mark_p(1:my_atoms%N) = hybrid_mark_p(1:my_atoms%N) - ! default to NO_MARK - hybrid_mark_p(1:my_atoms%N) = HYBRID_NO_MARK - ! anything which was marked before (except termination) is now BUFFER (so hysteretic buffer, later, has correct previous values) - hybrid_mark_p(int_part(old_all_but_term,1)) = HYBRID_BUFFER_MARK - ! anything returned in the core list is now ACTIVE - hybrid_mark_p(int_part(core,1)) = HYBRID_ACTIVE_MARK - - ! update hybrid property of my_atoms - if (.not. assign_pointer(my_atoms,'hybrid'//trim(my_mark_postfix),hybrid_p)) then - RAISE_ERROR("create_pos_or_list_centred_hybrid_region couldn't get hybrid"//trim(my_mark_postfix)//" property", error) - endif - hybrid_p(1:my_atoms%N) = 0 - hybrid_p(int_part(core,1)) = 1 - - call finalise(core) - call finalise(old_core) - call finalise(old_all_but_term) - - end subroutine create_pos_or_list_centred_hybrid_region - -! !% Returns a $hybridlist$ table with the atom indices whose $cluster_mark$ -! !% (or optionally any $int_property$) property takes no greater than $hybridflag$ positive value. -! ! -! subroutine get_hybrid_list(my_atoms,hybridflag,hybridlist,int_property,get_up_to_mark_value) -! -! type(Atoms), intent(in) :: my_atoms -! integer, intent(in) :: hybridflag -! type(Table), intent(out) :: hybridlist -! character(len=*), optional, intent(in) :: int_property -! logical, intent(in), optional :: get_up_to_mark_value -! -! integer, pointer :: mark_p(:) -! integer :: i -! logical :: do_get_up_to_mark_value -! -! do_get_up_to_mark_value = optional_default(.false., get_up_to_mark_value) -! -! if (present(int_property)) then -! if (.not. assign_pointer(my_atoms, trim(int_property), mark_p)) then -! RAISE_ERROR("get_hybrid_list_int couldn't get int_property='"//trim(int_property)//"'", error) -! endif -! else -! if (.not. assign_pointer(my_atoms, 'cluster_mark', mark_p)) then -! RAISE_ERROR("get_hybrid_list_int couldn't get default int_property='cluster_mark'", error) -! endif -! endif -! -! call initialise(hybridlist,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_hybrid_atoms entries -! if (do_get_up_to_mark_value) then -! do i=1,my_atoms%N -! ! if (my_atoms%data%int(hybrid_flag_index,i).gt.0.and. & -! ! my_atoms%data%int(hybrid_flag_index,i).le.hybridflag) & -! if (mark_p(i) > 0 .and. mark_p(i) <= hybridflag) & -! call append(hybridlist,(/i,0,0,0/)) -! enddo -! else -! do i=1,my_atoms%N -! ! if (my_atoms%data%int(hybrid_flag_index,i).eq.hybridflag) & -! if (mark_p(i) == hybridflag) call append(hybridlist,(/i,0,0,0/)) -! enddo -! endif -! -! if (hybridlist%N.eq.0) call print('Empty QM list with cluster_mark '//hybridflag,verbosity=PRINT_SILENT) -! -! end subroutine get_hybrid_list - - !% Checks and reports the changes between two tables, $old_qmlist$ and $new_qmlist$. - ! - function check_list_change(old_list,new_list) result(list_changed) - - type(Table), intent(in) :: old_list, new_list - integer :: i - logical :: list_changed - - list_changed = .false. - if (old_list%N.ne.new_list%N) then - call print ('list has changed: new number of atoms is: '//new_list%N//', was: '//old_list%N) - list_changed = .true. - else - if (any(old_list%int(1,1:old_list%N).ne.new_list%int(1,1:new_list%N))) then - do i=1,old_list%N - if (.not.find_in_array(int_part(old_list,1),(new_list%int(1,i))).gt.0) then - call print('list has changed: atom '//new_list%int(1,i)//' has entered the region') - list_changed = .true. - endif - if (.not.find_in_array(int_part(new_list,1),(old_list%int(1,i))).gt.0) then - call print('list has changed: atom '//old_list%int(1,i)//' has left the region') - list_changed = .true. - endif - enddo - endif - endif - - end function check_list_change - - !% return list of atoms that have various subsets of hybrid marks set - subroutine get_hybrid_list(at,hybrid_list,all_but_term,active_trans_only,int_property, error) - type(Atoms), intent(in) :: at !% object to scan for marked atoms - type(Table), intent(out) :: hybrid_list !% on return, list of marked atoms - logical, intent(in), optional :: all_but_term !% if present and true, select all marked atoms that aren't TERM - logical, intent(in), optional :: active_trans_only !% if present and true, select all atoms marked ACTIVE or TRANS - !% exactly one of all_but_term and active_trans_only must be present and true - character(len=*), optional, intent(in) :: int_property !% if present, property to check, default cluster_mark - integer, optional, intent(out) :: error - - integer :: i - integer, pointer :: hybrid_mark(:) - logical :: my_all_but_term, my_active_trans_only - character(STRING_LENGTH) :: my_int_property - - INIT_ERROR(error) - - if (.not. present(all_but_term) .and. .not. present(active_trans_only)) then - RAISE_ERROR("get_hybrid_list called with neither all_but_term nor active_trans_only present", error) - endif - - my_all_but_term = optional_default(.false., all_but_term) - my_active_trans_only = optional_default(.false., active_trans_only) - - if ((my_all_but_term .and. my_active_trans_only) .or. (.not. my_all_but_term .and. .not. my_active_trans_only)) then - RAISE_ERROR("get_hybrid_list needs exactly one of all_but_term=" // all_but_term // " and active_trans_only="//my_active_trans_only, error) - endif - - my_int_property = '' - if (present(int_property)) then - my_int_property = trim(int_property) - else - my_int_property = "cluster_mark" - endif - if (.not.(assign_pointer(at, trim(my_int_property), hybrid_mark))) then - RAISE_ERROR("get_hybrid_list couldn't find "//trim(my_int_property)//" field", error) - endif - - call initialise(hybrid_list,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries - do i=1, at%N - if (my_all_but_term) then - if (hybrid_mark(i) /= HYBRID_NO_MARK .and. hybrid_mark(i) /= HYBRID_TERM_MARK) call append(hybrid_list,(/i,0,0,0/)) - else if (my_active_trans_only) then - if (hybrid_mark(i) == HYBRID_ACTIVE_MARK .or. hybrid_mark(i) == HYBRID_TRANS_MARK) call append(hybrid_list,(/i,0,0,0/)) - else - RAISE_ERROR("impossible! get_hybrid_list has no selection mode set", error) - endif - end do - - if (hybrid_list%N.eq.0) call print('get_hybrid_list returns empty hybrid list with field '//trim(my_int_property)// & - ' all_but_term ' // my_all_but_term // ' active_trans_only ' // my_active_trans_only ,PRINT_ALWAYS) - end subroutine get_hybrid_list - - -end module clusters_module diff --git a/src/libAtoms/error.f95 b/src/libAtoms/error.f95 deleted file mode 100644 index 1ee1a560d8..0000000000 --- a/src/libAtoms/error.f95 +++ /dev/null @@ -1,425 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Exception handling -!X -!% This modules keeps track an error stack. When an error occurs a list -!% of files/lines that allow to trace back the position in the code where -!% the error occured first is constructed. -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module error_module -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif - implicit none -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif - - private - - ! --- - - integer, parameter :: ERROR_STACK_SIZE = 100 - - integer, parameter :: ERROR_DOC_LENGTH = 1000 - integer, parameter :: ERROR_FN_LENGTH = 100 - - ! --- - - !% Error kinds - integer, parameter :: ERROR_NONE = 0 - integer, parameter :: ERROR_UNSPECIFIED = -1 - integer, parameter :: ERROR_IO = -2 - integer, parameter :: ERROR_IO_EOF = -3 - integer, parameter :: ERROR_MPI = -4 - integer, parameter :: ERROR_MINIM_NOT_CONVERGED = -5 - - !% Strings - integer, parameter :: ERROR_STR_LENGTH = 20 - character(ERROR_STR_LENGTH), parameter :: ERROR_STR_UNSPECIFIED = & - "unspecified" - character(ERROR_STR_LENGTH), parameter :: ERROR_STR_IO = "IO" - character(ERROR_STR_LENGTH), parameter :: ERROR_STR_IO_EOF = "IO EOF" - character(ERROR_STR_LENGTH), parameter :: ERROR_STR_MPI = "MPI" - character(ERROR_STR_LENGTH), parameter :: ERROR_STR_MINIM_NOT_CONVERGED = & - "MINIM_NOT_CONVERGED" - character(ERROR_STR_LENGTH), parameter :: ERROR_STRINGS(5) = & - (/ ERROR_STR_UNSPECIFIED, ERROR_STR_IO, ERROR_STR_IO_EOF, & - ERROR_STR_MPI, ERROR_STR_MINIM_NOT_CONVERGED /) - - public :: ERROR_NONE, ERROR_UNSPECIFIED, ERROR_IO, ERROR_IO_EOF, ERROR_MPI - public :: ERROR_MINIM_NOT_CONVERGED - - ! --- - - type ErrorDescriptor - integer :: kind !% kind of error - logical :: has_doc !% does the documentation string exist? - character(ERROR_DOC_LENGTH) :: doc !% documentation string - character(ERROR_FN_LENGTH) :: fn !% file name where the error occured - integer :: line !% code line where the error occured - endtype ErrorDescriptor - - ! --- - - save - integer :: error_stack_position = 0 !% If this is zero, no error has occured - integer :: error_mpi_myid = 0 !% MPI rank of process. Initialised by system_initialise() - type(ErrorDescriptor) :: error_stack(ERROR_STACK_SIZE) !% Error stack - - ! --- - - public :: system_abort - interface system_abort - module procedure error_abort_with_message - endinterface - - interface quippy_running - function quippy_running() - logical :: quippy_running - end function quippy_running - end interface quippy_running - - interface f90wrap_abort - subroutine f90wrap_abort(message) - character(*), intent(in) :: message - end subroutine f90wrap_abort - end interface f90wrap_abort - - public :: error_abort - interface error_abort - module procedure error_abort_from_stack - endinterface - - public :: error_clear_stack - - public :: push_error, push_error_with_info - public :: get_error_string_and_clear, clear_error - - ! --- - - public :: error_unit, error_mpi_myid - integer :: error_unit = -1 - -contains - - !% Push a new error callback to the stack - subroutine push_error(fn, line, kind) - implicit none - - character(*), intent(in) :: fn - integer, intent(in) :: line - integer, intent(in), optional :: kind - - ! --- - - !$omp critical - - error_stack_position = error_stack_position + 1 - - if (error_stack_position > ERROR_STACK_SIZE) then - call system_abort("Fatal error: Error stack size too small.") - endif - - if (present(kind)) then - error_stack(error_stack_position)%kind = kind - else - error_stack(error_stack_position)%kind = ERROR_UNSPECIFIED - endif - error_stack(error_stack_position)%fn = fn - error_stack(error_stack_position)%line = line - - !$omp end critical - - endsubroutine push_error - - subroutine error_clear_stack() - error_stack_position = 0 - end subroutine error_clear_stack - - - !% Push a new information string onto the error stack - subroutine push_error_with_info(doc, fn, line, kind) - implicit none - - character(*), intent(in) :: doc - character(*), intent(in) :: fn - integer, intent(in) :: line - integer, intent(in), optional :: kind - - ! --- - - !$omp critical - - error_stack_position = error_stack_position + 1 - - if (error_stack_position > ERROR_STACK_SIZE) then - call system_abort("Fatal error: Error stack size too small.") - endif - - if (present(kind)) then - error_stack(error_stack_position)%kind = kind - else - error_stack(error_stack_position)%kind = ERROR_UNSPECIFIED - endif - error_stack(error_stack_position)%fn = fn - error_stack(error_stack_position)%line = line - error_stack(error_stack_position)%has_doc = .true. - error_stack(error_stack_position)%doc = doc - - !$omp end critical - - endsubroutine push_error_with_info - - - !% This error has been handled, clear it. - subroutine clear_error(error) - implicit none - - integer, intent(inout) :: error - - ! --- - - error = ERROR_NONE - - error_stack_position = 0 - - endsubroutine clear_error - - - !% Construct a string describing the error. - function get_error_string_and_clear(error) result(str) - use iso_c_binding - - implicit none - - integer, intent(inout), optional :: error - - character(ERROR_DOC_LENGTH) :: str - - ! --- - - integer :: i - character(10) :: linestr - - ! --- - - if (present(error)) then - if (-error < lbound(ERROR_STRINGS, 1) .or. & - -error > ubound(ERROR_STRINGS, 1)) then - call system_abort("Fatal: error descriptor out of bounds. Did you initialise the error variable?") - endif - - str = "Traceback (most recent call last - error kind " & - // trim(ERROR_STRINGS(-error)) // "):" - else - str = "Traceback (most recent call last)" - endif - do i = error_stack_position, 1, -1 - - write (linestr, '(I10)') error_stack(i)%line - - if (error_stack(i)%has_doc) then - - str = trim(str) // C_NEW_LINE // & - ' File "' // & - trim(error_stack(i)%fn) // & - '", line ' // & - trim(adjustl(linestr)) // & - ' kind '// & - trim(ERROR_STRINGS(-error_stack(i)%kind)) // & - C_NEW_LINE // & - " " // & - trim(error_stack(i)%doc) - - else - - str = trim(str) // C_NEW_LINE // & - ' File "' // & - trim(error_stack(i)%fn) // & - '", line ' // & - trim(adjustl(linestr))// & - ' kind '// & - trim(ERROR_STRINGS(-error_stack(i)%kind)) - endif - - enddo - - error_stack_position = 0 - - if (present(error)) then - error = ERROR_NONE - endif - - endfunction get_error_string_and_clear - - - !% Quit with an error message. Calls 'MPI_Abort' for MPI programs. - subroutine error_abort_with_message(message) - character(*), intent(in) :: message -#ifdef IFORT_TRACEBACK_ON_ABORT - integer :: j -#endif /* IFORT_TRACEBACK_ON_ABORT */ -#ifdef SIGNAL_ON_ABORT - integer :: status - integer, parameter :: SIGUSR1 = 30 -#endif -#ifdef _MPI - integer::PRINT_ALWAYS -#endif - - if (quippy_running()) call f90wrap_abort(message) - -#ifdef _MPI - write(unit=error_unit, fmt='(a,i0," ",a)') 'SYSTEM ABORT: proc=',error_mpi_myid,error_linebreak_string(trim(message),100) -#else - write(unit=error_unit, fmt='(a," ",a)') 'SYSTEM ABORT:', error_linebreak_string(trim(message),100) -#endif - call flush(error_unit) - -#ifdef _MPI - call MPI_Abort(MPI_COMM_WORLD, 1, PRINT_ALWAYS) -#endif - -#ifdef IFORT_TRACEBACK_ON_ABORT - ! Cause an integer divide by zero error to persuade - ! ifort to issue a traceback - j = 1/0 -#endif - -#ifdef DUMP_CORE_ON_ABORT - call fabort() -#else -#ifdef SIGNAL_ON_ABORT - ! send ourselves a USR1 signal rather than aborting - call kill(getpid(), SIGUSR1, status) -#else - stop 1 -#endif -#endif - end subroutine error_abort_with_message - - - !% Stop program execution since this error is not handled properly - subroutine error_abort_from_stack(error) - implicit none - - integer, intent(inout), optional :: error - - ! --- - - ! This is for compatibility with quippy, change to error_abort - call system_abort(get_error_string_and_clear(error)) - - endsubroutine error_abort_from_stack - - pure function error_linebreak_string_length(str, line_len) result(length) - character(len=*), intent(in) :: str - integer, intent(in) :: line_len - integer :: length - - length = len_trim(str)+2*len_trim(str)/line_len+3 - - end function error_linebreak_string_length - - function error_linebreak_string(str, line_len) result(lb_str) - character(len=*), intent(in) :: str - integer, intent(in) :: line_len - - character(len=error_linebreak_string_length(str, line_len)) :: lb_str - - logical :: word_break - integer :: copy_len, last_space, next_cr - character(len=len(lb_str)) :: tmp_str - character :: quip_new_line - -#ifdef NO_F2003_NEW_LINE - quip_new_line = char(13) -#else - quip_new_line = new_line(' ') -#endif - - lb_str="" - tmp_str=trim(str) - do while (len_trim(tmp_str) > 0) - next_cr = scan(trim(tmp_str),quip_new_line) - if (next_cr > 0) then - copy_len = min(len_trim(tmp_str),line_len,next_cr) - else - copy_len = min(len_trim(tmp_str),line_len) - endif - if (copy_len < len_trim(tmp_str) .and. tmp_str(copy_len+1:copy_len+1) /= " ") then - last_space=scan(tmp_str(1:copy_len), " ", .true.) - if ( last_space > 0 .and. (len_trim(tmp_str(1:copy_len)) - last_space) < 4) then - copy_len=last_space - endif - endif - - if (len_trim(lb_str) > 0) then ! we already have some text, add newline before concatenating next line - if (lb_str(len_trim(lb_str):len_trim(lb_str)) == quip_new_line) then - lb_str = trim(lb_str)//trim(tmp_str(1:copy_len)) - else - lb_str = trim(lb_str)//quip_new_line//trim(tmp_str(1:copy_len)) - endif - else ! just concatenate next line - lb_str = trim(tmp_str(1:copy_len)) - endif - ! if we broke in mid word, add "-" - word_break = .true. - if (tmp_str(copy_len:copy_len) == " ") then ! we broke right after a space, so no wordbreak - word_break = .false. - else ! we broke after a character - if (copy_len < len_trim(tmp_str)) then ! there's another character after this one, check if it's a space - if (tmp_str(copy_len+1:copy_len+1) == " ") then - word_break = .false. - endif - else ! we broke after the last character - word_break = .false. - endif - endif - if (word_break) lb_str = trim(lb_str)//"-" - tmp_str(1:copy_len) = "" - tmp_str=adjustl(tmp_str) - end do - - end function error_linebreak_string - - -endmodule error_module diff --git a/src/libAtoms/f90wrap_stub.f95 b/src/libAtoms/f90wrap_stub.f95 deleted file mode 100644 index 1957511cf8..0000000000 --- a/src/libAtoms/f90wrap_stub.f95 +++ /dev/null @@ -1,8 +0,0 @@ -! stub file to include dummy defition of Python error abort function when -! building standalone exectuble -subroutine f90wrap_abort(message) - character(*) :: message - - ! do nothing - -end subroutine f90wrap_abort diff --git a/src/libAtoms/find_surface_atoms.f95 b/src/libAtoms/find_surface_atoms.f95 deleted file mode 100644 index f473aff670..0000000000 --- a/src/libAtoms/find_surface_atoms.f95 +++ /dev/null @@ -1,333 +0,0 @@ -! based on Varshney et al IEEE Comp. Graphics and Appl. v. 14 p 19 (1994) -! linear programming solver from -! http://www.mpi-inf.mpg.de/departments/d1/teaching/ss10/opt/handouts/lecture25-SeidelLinearProgramming.pdf -! Not sure why they think that intersection of power-cell half spaces and enclosing -! tetrahedron half spaces is null for internal atoms - seems to be just something -! like Voronoi cell of atom (if all (covalent) radii are equal, anyway) -! instead, look for intersection of power cell with half spaces that don't include -! system (iterate over 6 - could be done with 4 with a tetrahedron). If any -! intersections are not null, atom has an unbounded power cell and is a surface atom. -module find_surface_atoms_module -use system_module, only : dp, print, mainlog, PRINT_VERBOSE, PRINT_ALWAYS, ran, operator(//), system_abort -use periodictable_module -use linearalgebra_module -use atoms_types_module -use atoms_module -implicit none - -private -public :: label_surface_atoms - -contains - -subroutine label_surface_atoms(at, probe_r) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: probe_r - - integer, pointer :: surf(:) - integer :: i, ji, j - real(dp) :: dist_ij, cos_ij(3), p(3), v(3), di, dj - real(dp), allocatable :: plane_constraints(:,:) - real(dp) :: bounds(3,2) - real(dp) :: bounds_constraints(6,6) - real(dp) :: nn_cutoff - integer :: nn - - nn_cutoff = 2.0_dp*probe_r + 2.0_dp*maxval(ElementCovRad(at%Z)) - call set_cutoff(at, nn_cutoff) - call calc_connect(at) - - call add_property(at, "surf", 0, n_cols=1, ptr=surf) - - bounds(1,1) = minval(at%pos(1,:))-(maxval(at%pos(1,:))-minval(at%pos(1,:))) - bounds(1,2) = maxval(at%pos(1,:))+(maxval(at%pos(1,:))-minval(at%pos(1,:))) - bounds(2,1) = minval(at%pos(2,:))-(maxval(at%pos(2,:))-minval(at%pos(2,:))) - bounds(2,2) = maxval(at%pos(2,:))+(maxval(at%pos(2,:))-minval(at%pos(2,:))) - bounds(3,1) = minval(at%pos(3,:))-(maxval(at%pos(3,:))-minval(at%pos(3,:))) - bounds(3,2) = maxval(at%pos(3,:))+(maxval(at%pos(3,:))-minval(at%pos(3,:))) - bounds_constraints(1:6,1) = (/ bounds(1,1), 0.0_dp, 0.0_dp, -1.0_dp, 0.0_dp, 0.0_dp /) - bounds_constraints(1:6,2) = (/ bounds(1,2), 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp /) - bounds_constraints(1:6,3) = (/ 0.0_dp, bounds(2,1), 0.0_dp, 0.0_dp, -1.0_dp, 0.0_dp /) - bounds_constraints(1:6,4) = (/ 0.0_dp, bounds(2,2), 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp /) - bounds_constraints(1:6,5) = (/ 0.0_dp, 0.0_dp, bounds(3,1), 0.0_dp, 0.0_dp, -1.0_dp /) - bounds_constraints(1:6,6) = (/ 0.0_dp, 0.0_dp, bounds(3,2), 0.0_dp, 0.0_dp, 1.0_dp /) - - bounds(1,1) = minval(at%pos(1,:))-10.0_dp*(maxval(at%pos(1,:))-minval(at%pos(1,:))) - bounds(1,2) = maxval(at%pos(1,:))+10.0_dp*(maxval(at%pos(1,:))-minval(at%pos(1,:))) - bounds(2,1) = minval(at%pos(2,:))-10.0_dp*(maxval(at%pos(2,:))-minval(at%pos(2,:))) - bounds(2,2) = maxval(at%pos(2,:))+10.0_dp*(maxval(at%pos(2,:))-minval(at%pos(2,:))) - bounds(3,1) = minval(at%pos(3,:))-10.0_dp*(maxval(at%pos(3,:))-minval(at%pos(3,:))) - bounds(3,2) = maxval(at%pos(3,:))+10.0_dp*(maxval(at%pos(3,:))-minval(at%pos(3,:))) - - do i=1, at%N - - ! count close enough neighbours - nn = 0 - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, distance=dist_ij) - if (dist_ij <= ElementCovRad(at%Z(i)) + ElementCovRad(at%Z(j)) + 2.0_dp*probe_R) then - nn = nn + 1 - endif - end do - - if (allocated(plane_constraints)) then - if (size(plane_constraints,2) /= nn+1) deallocate(plane_constraints) - endif - if (.not. allocated(plane_constraints)) allocate(plane_constraints(6,nn+1)) - - ! do constraints for close enough neighbours - nn = 0 - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, distance=dist_ij, cosines=cos_ij) - if (dist_ij <= ElementCovRad(at%Z(i)) + ElementCovRad(at%Z(j)) + 2.0_dp*probe_R) then - nn = nn + 1 - ! pi = di^2 - (ElementCovRad(i)+probe_r)^2 - ! pj = dj^2 - (ElementCovRad(j)+probe_r)^2 - ! along r_ij, di+dj=dij, dj=dij-di - - ! pi == pj - ! di^2 - (Ci+pr)^2 = (dij-di)^2 - (Cj+pr)^2 - ! di^2 - (Ci+pr)^2 = dij^2 - 2 di dij + di^2 - (Cj+pr)^2 - ! -(Ci+pr)^2 = dij^2 - 2 di dij - (Cj+pr)^2 - ! -2 di dij = (Cj+pr)^2-(Ci+pr)^2-dij^2 - ! di = ((Cj+pr)^2-(Ci+pr)^2-dij^2)/(-2 dij) - di = ((ElementCovRad(at%Z(j))+probe_r)**2 - (ElementCovRad(at%Z(i))+probe_r)**2 - dist_ij**2)/(-2.0_dp*dist_ij) - dj = dist_ij - di - if (abs(di) < dist_ij .and. abs(dj) < dist_ij) then ! in between - p(:) = at%pos(:,i) + abs(di)*cos_ij(:) - else if (abs(di) > abs(dj)) then ! not in between, and closer to j than to i - p(:) = at%pos(:,i) + abs(di)*cos_ij(:) - else ! not in between and closer to i than to j - p(:) = at%pos(:,i) - abs(di)*cos_ij(:) - endif - v(:) = -cos_ij(:) - plane_constraints(1:3,nn) = p - plane_constraints(4:6,nn) = v - endif - end do - do j=1,6 - plane_constraints(1:6,nn+1) = bounds_constraints(1:6,j) - if (feasible_cell_has_solution(plane_constraints, bounds)) then - surf(i) = 1 - exit - endif - end do - end do - -end subroutine label_surface_atoms - -function feasible_cell_has_solution(plane_constraints, bounds) - real(dp), intent(in) :: plane_constraints(:,:), bounds(3,2) - real(dp) :: x(3) - logical :: feasible_cell_has_solution - logical :: constraint_ok, t_constraint_ok - - integer i - - call print("has_solution "//shape(plane_constraints), PRINT_VERBOSE) - do i=1, size(plane_constraints,2) - call print("p "//plane_constraints(1:3,i)//" v "//plane_constraints(4:6,i), PRINT_VERBOSE) - end do - - x = seidel_solve(a=-plane_constraints(4:6,:),b=-sum(plane_constraints(1:3,:)*plane_constraints(4:6,:),1),& - bounds=bounds, has_solution=feasible_cell_has_solution) - call print(" has_solution " // feasible_cell_has_solution, PRINT_VERBOSE) - if (feasible_cell_has_solution) then - call print("solution x " //x, PRINT_VERBOSE) - constraint_ok=.true. - do i=1, size(plane_constraints,2) - call print(i//" a.x "//sum(-plane_constraints(4:6,i)*x)//" <=? "//sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i)) // & - " " // (sum(-plane_constraints(4:6,i)*x) <= sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))), PRINT_VERBOSE) - t_constraint_ok = (sum(-plane_constraints(4:6,i)*x) <= sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))) - if (.not. t_constraint_ok .and. abs(sum(-plane_constraints(4:6,i)*x) - sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))) < 1.0e-6_dp) t_constraint_ok = .true. - constraint_ok = constraint_ok .and. t_constraint_ok - end do - if (.not. constraint_ok) then - call print("WARNING: has_solution=T but some constraint violated") - do i=1, size(plane_constraints, 2) - t_constraint_ok = (sum(-plane_constraints(4:6,i)*x) <= sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))) - if (.not. t_constraint_ok .and. abs(sum(-plane_constraints(4:6,i)*x) - sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))) < 1.0e-6_dp) t_constraint_ok = .true. - if (.not. t_constraint_ok) then - call print(i//" a.x "//sum(-plane_constraints(4:6,i)*x)//" <=? "//sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i)) // & - " " // (sum(-plane_constraints(4:6,i)*x) <= sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))), PRINT_VERBOSE) - endif - end do - endif - endif -end function feasible_cell_has_solution - -! linear programming solver from -! http://www.mpi-inf.mpg.de/departments/d1/teaching/ss10/opt/handouts/lecture25-SeidelLinearProgramming.pdf -! solve a.x <= b for x, subject to bounds. Returns x, sets has_solution to false if no solution. -recursive function seidel_solve(a, b, bounds, has_solution) result(x) - real(dp) :: a(:,:), b(:), bounds(:,:) - logical :: has_solution - real(dp) :: x(size(a,1)) - - real(dp), allocatable :: a_skip_m(:,:), b_skip_m(:), x_skip_m(:) - real(dp), allocatable :: a_skip_dm(:,:), b_skip_dm(:), x_skip_dm(:), bounds_skip_dm(:,:) - integer :: d, m, i, j, ii, jj, i_skip, j_skip - real(dp) :: x_min, x_max - integer, allocatable :: skip_m_index(:), skip_d_index(:) - character(len=1024) :: prefix - - d = size(a,1) - m = size(a,2) -! call print("seidel_solve d "//d//" m "//m) - - if (size(b) /= m) call system_abort("Bad size of b "//size(b)) - if (size(bounds,1) /= d) call system_abort("Bad size of bounds dim 1 "//size(bounds,1)) - if (size(bounds,2) /= 2) call system_abort("Bad size of bounds dim 2 "//size(bounds,2)) - - has_solution = .true. - if (d == 1) then ! 1-D, just find range of minima, maxima - x_min = bounds(1,1) - x_max = bounds(1,2) - do i=1, m - if (a(1,i) .feq. 0.0_dp) then - if (0.0_dp <= b(i)) then - has_solution = .true. - else - has_solution = .false. - endif - else if (a(1,i) > 0) then ! x <= b/a - x_max = min(x_max, b(i)/a(1,i)) - else ! x >= b/a - x_min = max(x_min, b(i)/a(1,i)) - endif - end do ! i=1,m - if (x_max >= x_min) then - has_solution = has_solution .and. .true. - else - has_solution = has_solution .and. .false. - endif - x = 0.5_dp*(x_max+x_min) -! call print("1-D returning has_solution "//has_solution//" "//x_min//" "//x_max) - return - endif ! d == 1 - - if (m == 0) then ! no constraints - call print("WARNING: should never get here", PRINT_ALWAYS) - has_solution = .true. - x = 0.5_dp*(bounds(:,1)+bounds(:,2)) - return - endif - - ! omit a random constraint - i_skip = mod(ran(),m)+1 - allocate(x_skip_m(d)) - allocate(skip_m_index(m-1)) -! call print("skip constraint "//i_skip) - if (m == 1) then ! next would be a call with no constraints -! call print("faking m=0 call") - x_skip_m = 0.5_dp*(bounds(:,1)+bounds(:,2)) - else ! some constraints left to solve - allocate(a_skip_m(d,m-1), b_skip_m(m-1)) - ii=1 - do i=1, m - if (i /= i_skip) then - skip_m_index(ii) = i - ii = ii + 1 - endif - end do - do j=1, d - a_skip_m(j,:) = a(j,skip_m_index(:)) - end do - b_skip_m(:) = b(skip_m_index(:)) -prefix=trim(mainlog%prefix) -mainlog%prefix=trim(mainlog%prefix)//"S" - x_skip_m = seidel_solve(a_skip_m, b_skip_m, bounds, has_solution) -mainlog%prefix=trim(prefix) -! call print("got has_solution "//has_solution//" "//x_skip_m) - deallocate(a_skip_m, b_skip_m) - if (.not. has_solution) then - deallocate(x_skip_m) - deallocate(skip_m_index) - return - endif - endif - if (sum(x_skip_m(:)*a(:,i_skip)) <= b(i_skip)) then -! call print("skipped constraint is satisfied (a.x="//sum(x_skip_m(:)*a(:,i_skip))//" <= b="//b(i_skip)//"), returning") - has_solution=.true. - x = x_skip_m - deallocate(x_skip_m) - deallocate(skip_m_index) - return - endif -! call print("skipped constraint wasn't satisfied, continuing") - deallocate(x_skip_m) - ! still have skip_m_index allocated - - j_skip=0 - do j=1,d - if (a(j,i_skip) .fne. 0.0_dp) then - j_skip=j - exit - endif - end do -! call print("eliminating dim "//j_skip) - if (j_skip == 0) then -! call print("can't eliminate, assuming no solution") - has_solution = .false. - deallocate(skip_m_index) - return - endif - allocate(x_skip_dm(d-1)) - allocate(skip_d_index(d-1)) - jj=1 - do j=1, d - if (j /= j_skip) then - skip_d_index(jj) = j - jj = jj + 1 - endif - end do - if (m == 1) then ! fake m=0 call -! call print("faking m=0 call") - has_solution = .true. - x_skip_dm(1:d-1) = 0.5_dp*(bounds(skip_d_index(:),1)+bounds(skip_d_index(:),2)) - else - allocate(a_skip_dm(d-1,m-1), b_skip_dm(m-1)) - do i=1, m-1 - do j=1, d-1 - a_skip_dm(j,i) = a(skip_d_index(j),skip_m_index(i)) - a(j_skip,skip_m_index(i))*a(skip_d_index(j),i_skip)/a(j_skip,i_skip) - end do - b_skip_dm(i) = b(skip_m_index(i)) - a(j_skip,skip_m_index(i))*b(i_skip)/a(j_skip,i_skip) - end do - allocate(bounds_skip_dm(d-1,2)) - bounds_skip_dm(:,1) = bounds(skip_d_index(:),1) - bounds_skip_dm(:,2) = bounds(skip_d_index(:),2) -prefix=trim(mainlog%prefix) -mainlog%prefix=trim(mainlog%prefix)//"S" - x_skip_dm = seidel_solve(a_skip_dm, b_skip_dm, bounds_skip_dm, has_solution) -mainlog%prefix=trim(prefix) -! call print("got has_solution "//has_solution//" "//x_skip_dm) -! if (has_solution) then -! call print("check raw solution") -! do i=1, m-1 -! call print(" a.x="//sum(a_skip_dm(:,i)*x_skip_dm(:))//" <=? "//b_skip_dm(i)//" "// (sum(a_skip_dm(:,i)*x_skip_dm(:)) <=b_skip_dm(i))) -! end do -! endif - deallocate(bounds_skip_dm) - deallocate(a_skip_dm, b_skip_dm) - endif - deallocate(skip_m_index) - if (.not. has_solution) then -! call print("no solution, returning") - deallocate(x_skip_dm) - deallocate(skip_d_index) - return - endif -! call print("has solution, back substituting") - x(skip_d_index(:)) = x_skip_dm(:) - x(j_skip) = (b(i_skip) - sum(a(skip_d_index(:),i_skip)*x_skip_dm(:)))/a(j_skip,i_skip) -! call print("check backsub solution") -! do i=1, m -! call print(" a.x="//sum(a(:,i)*x(:))//" <=? "//b(i)//" "// (sum(a(:,i)*x(:)) <=b(i))) -! end do - has_solution = .true. - deallocate(x_skip_dm) - deallocate(skip_d_index) - -end function seidel_solve - -end module find_surface_atoms_module diff --git a/src/libAtoms/frametools.f95 b/src/libAtoms/frametools.f95 deleted file mode 100644 index b4fd7e8d5d..0000000000 --- a/src/libAtoms/frametools.f95 +++ /dev/null @@ -1,240 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" -module frametools_module -use error_module -use system_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use quaternions_module -implicit none -private - - -public :: atoms_mark - -public :: mark_cylinder, mark_sphere - -private :: ft_rotate -public :: rotate -interface rotate - module procedure ft_rotate -end interface rotate - -contains - -!% Mark atoms according to the results of a callback function `mark_f` -!% -!% The integer property `mark_name` will be set to `mark_value` for -!% the atoms for which the function `mark_f(at, i, periodic, f_i_data, -!% f_r_data[, error])` returns true, where `i` is the atom index and -!% the other arguments are passed along from those given to `atoms_mark`. -subroutine atoms_mark(this, mark_f, f_i_data, f_r_data, periodic, mark_name, mark_value, intersection, error) - type(atoms), intent(inout) :: this - interface - function mark_f(at, i, periodic, i_data, r_data, error) - use system_module - use atoms_module - type(atoms), intent(inout) :: at - integer, intent(in) :: i - logical, intent(in) :: periodic - integer, intent(in), optional :: i_data(:) - real(dp), intent(in), optional :: r_data(:) - integer, intent(out), optional :: error - logical mark_f - end function mark_f - end interface - integer, intent(in), optional :: f_i_data(:) !% Integer data passed along to `mark_f` function - real(dp), intent(in), optional :: f_r_data(:) !% Real data passed along to `mark_f` function - logical, intent(in), optional :: periodic !% Passed along to `mark_f` function - character(len=*), intent(in), optional :: mark_name !% Name of integer property to set the marks in - integer, intent(in), optional :: mark_value !% Value with which to mark atoms - logical, intent(in), optional :: intersection !% If true, only consider atoms where mark property is already non-zero - integer, intent(out), optional :: error - - integer :: i - character(len=128) :: my_mark_name - integer :: my_mark_value - logical :: my_intersection, my_periodic - integer, pointer :: mark(:) - - INIT_ERROR(error) - - my_mark_name = optional_default("mark", mark_name) - my_mark_value = optional_default(1, mark_value) - my_intersection = optional_default(.false., intersection) - my_periodic = optional_default(.true., periodic) - - if (.not. assign_pointer(this, trim(my_mark_name), mark)) then - call add_property(this, trim(my_mark_name), 0, ptr=mark) - else - call assign_property_pointer(this, trim(my_mark_name), mark, error=error) - endif - - do i=1, this%N - if (my_intersection .and. mark(i) == 0) cycle ! if we're doing intersection and this one isn't already marked, skip it - if (my_intersection) mark(i) = 0 ! if we're doing intersection, set mark to .false., and it'll will be set to true if it's marked in the current shape - if (mark_f(this, i, my_periodic, f_i_data, f_r_data, error=error)) then - mark(i) = my_mark_value - endif - PASS_ERROR(error) - end do -end subroutine atoms_mark - -function is_in_cylinder_f(this, i, periodic, i_data, r_data, error) - type(atoms), intent(inout) :: this - integer, intent(in) :: i - logical, intent(in) :: periodic - integer, intent(in), optional :: i_data(:) - real(dp), intent(in), optional :: r_data(:) - integer, intent(out), optional :: error - logical is_in_cylinder_f - - logical :: my_periodic - real(dp) :: delta_p(3), v(3), r - - INIT_ERROR(error) - - if (present(i_data)) then - RAISE_ERROR("is_in_cylinder_f doesn't take i_data", error) - endif - if (.not.present(r_data)) then - RAISE_ERROR("is_in_cylinder_f requires r_data", error) - endif - if (size(r_data) /= 7) then - RAISE_ERROR("is_in_cylinder_f requires [px py pz vx vy vz r] in cylinder", error) - endif - - if (periodic) then - delta_p = diff_min_image(this, i, r_data(1:3)) - else - delta_p = this%pos(:,i) - r_data(1:3) - endif - v = r_data(4:6) - v = v/norm(v) - r = r_data(7) - - delta_p = delta_p - v*(v .dot. delta_p) - if (r > 0.0_dp) then - is_in_cylinder_f = (norm(delta_p) < r) - else - is_in_cylinder_f = (norm(delta_p) >= -r) - endif -end function is_in_cylinder_f - -function is_in_sphere_f(this, i, periodic, i_data, r_data, error) - type(atoms), intent(inout) :: this - integer, intent(in) :: i - logical, intent(in) :: periodic - integer, intent(in), optional :: i_data(:) - real(dp), intent(in), optional :: r_data(:) - integer, intent(out), optional :: error - logical is_in_sphere_f - - real(dp) :: dr, r - - INIT_ERROR(error) - - if (present(i_data)) then - RAISE_ERROR("is_in_sphere_f doesn't take i_data", error) - endif - if (.not.present(r_data)) then - RAISE_ERROR("is_in_sphere_f requires r_data", error) - endif - if (size(r_data) /= 4) then - RAISE_ERROR("is_in_sphere_f requires [px py pz r] in sphere", error) - endif - - if (periodic) then - dr = distance_min_image(this, i, r_data(1:3)) - else - dr = norm(this%pos(:,i)-r_data(1:3)) - endif - r = r_data(4) - - if (r > 0.0_dp) then - is_in_sphere_f = (dr < r) - else - is_in_sphere_f = (dr >= -r) - endif -end function is_in_sphere_f - - -!% Mark atoms in a cylinder centred on the point `p` with axis `v` and radius `r` -subroutine mark_cylinder(this, p, v, r, periodic, mark_name, mark_value, intersection) - type(atoms), intent(inout) :: this - real(dp), intent(in) :: p(3), v(3), r - character(len=*), intent(in), optional :: mark_name - integer, intent(in), optional :: mark_value - logical, intent(in), optional :: periodic, intersection - - call atoms_mark(this, is_in_cylinder_f, f_r_data=(/ p, v, r /), periodic=periodic, mark_name=mark_name, mark_value=mark_value, intersection=intersection) -end subroutine mark_cylinder - -!% Mark atoms in a cylinder centred on the point `p` with radius `r` -subroutine mark_sphere(this, p, r, periodic, mark_name, mark_value, intersection) - type(atoms), intent(inout) :: this - real(dp), intent(in) :: p(3), r - character(len=*), intent(in), optional :: mark_name - integer, intent(in), optional :: mark_value - logical, intent(in), optional :: periodic, intersection - - call atoms_mark(this, is_in_sphere_f, f_r_data=(/ p, r /), periodic=periodic, mark_name=mark_name, mark_value=mark_value, intersection=intersection) -end subroutine mark_sphere - -!% Rotate `field`, which should be a vector field with shape `(3, N)`, -!% e.g. atomic positions array around `axis` by `angle`, centering the -!% rotation on `origin` -subroutine ft_rotate(field, axis, angle, origin) - real(dp), intent(inout) :: field(:,:) - real(dp), intent(in) :: axis(3) - real(dp), intent(in) :: angle - real(dp), intent(in), optional :: origin(3) - - real(dp) :: dr(3) - type(Quaternion) :: Q - integer i, N - - Q = rotation(axis, angle) - - N = size(field,2) - - do i=1, N - if (present(origin)) then - field(:,i) = field(:,i)-origin - endif - call rotate(field(:,i), Q) - end do -end subroutine ft_rotate - - -end module frametools_module diff --git a/src/libAtoms/gamma_functions.f95 b/src/libAtoms/gamma_functions.f95 deleted file mode 100644 index f5361b4e13..0000000000 --- a/src/libAtoms/gamma_functions.f95 +++ /dev/null @@ -1,244 +0,0 @@ -module gamma_module - - use system_module,only : dp - - ! Incomplete GAMMA function. Adapted from Numerical Recipes in Fortran 77. - - implicit none -! integer, parameter :: dp = kind(1.0d0) - integer, parameter :: max_iteration = 100 - real(dp), parameter :: eps = 1.0e-12_dp - real(dp), parameter :: min_float = tiny(1.0_dp) * 10.0_dp - real(dp), parameter :: log_sqrt_2_pi = log(sqrt(2.0_dp*3.14159265358979323846264338327950288_dp) ) - - interface gamma_incomplete_upper - module procedure gamma_incomplete_upper, gamma_incomplete_upper_xarray1d, & - gamma_incomplete_upper_ainteger - endinterface gamma_incomplete_upper - - contains - - function gamma_incomplete_upper_xarray1d(a,x) - real(dp), intent(in) :: a - real(dp), intent(in), dimension(:) :: x - real(dp), dimension(size(x)) :: gamma_incomplete_upper_xarray1d - - integer :: i - - do i = 1, size(x) - gamma_incomplete_upper_xarray1d(i) = gamma_incomplete_upper(a,x(i)) - enddo - - endfunction gamma_incomplete_upper_xarray1d - - function gamma_incomplete_upper_ainteger(a,x) - integer, intent(in) :: a - real(dp), intent(in) :: x - real(dp) :: gamma_incomplete_upper_ainteger - - gamma_incomplete_upper_ainteger = gamma_incomplete_upper(real(a,dp),x) - - endfunction gamma_incomplete_upper_ainteger - - function gamma_incomplete_upper(a,x) - - real(dp), intent(in) :: a, x - real(dp) :: gamma_incomplete_upper - ! USES gcf,gser - ! Returns the incomplete gamma function Q(a, x) ≡ 1 − P(a, x). - real(dp) :: gammcf, gamser, gln - - if(x < 0.0_dp .or. a <= 0.0_dp ) stop 'bad arguments in gamma_incomplete_upper' - - if(x < a+1.0_dp)then !Use the series representation - call gser(gamser,a,x,gln) - gamma_incomplete_upper = 1.0_dp - gamser !and take its complement. - else !Use the continued fraction representation. - call gcf(gammcf,a,x,gln) - gamma_incomplete_upper = gammcf - endif - - gamma_incomplete_upper = gamma_incomplete_upper * exp(gln) - - endfunction gamma_incomplete_upper - - function gammp(a,x) - - real(dp), intent(in) :: a, x - real(dp) :: gammp - ! USES gcf,gser - ! Returns the incomplete gamma function P(a, x). - real(dp) :: gammcf,gamser,gln - - if(x < 0.0_dp .or. a <= 0.0_dp) stop 'bad arguments in gammp' - - if(x < a + 1.0_dp )then !Use the series representation. - call gser(gamser,a,x,gln) - gammp=gamser - else !Use the continued fraction representation - call gcf(gammcf,a,x,gln) - gammp =1.0_dp - gammcf !and take its complement. - endif - - endfunction gammp - - function gammq(a,x) - - real(dp), intent(in) :: a, x - real(dp) :: gammq - ! USES gcf,gser - ! Returns the incomplete gamma function Q(a, x) ≡ 1 − P(a, x). - real(dp) :: gammcf, gamser, gln - - if(x < 0.0_dp .or. a <= 0.0_dp ) stop 'bad arguments in gammq' - - if(x < a+1.0_dp)then !Use the series representation - call gser(gamser,a,x,gln) - gammq=1.0_dp - gamser !and take its complement. - else !Use the continued fraction representation. - call gcf(gammcf,a,x,gln) - gammq=gammcf - endif - - endfunction gammq - - subroutine gser(gamser,a,x,gln) - real(dp), intent(in) :: a, x - real(dp), intent(out) :: gamser, gln - - ! USES ln_gamma - !Returns the incomplete gamma function P(a, x) evaluated by its series - !representation as - !gamser. Also returns ln \Gamma(a) as gln. - - integer :: i - real(dp) :: ap, del, sum - - gln = ln_gamma(a) - - if(x <= 0.0_dp)then - if(x < 0.0_dp) stop 'x < 0 in gser' - gamser=0.0_dp - else - ap = a - sum = 1.0_dp / a - del = sum - i = 0 - do - i = i + 1 - ap = ap + 1.0_dp - del = del * x / ap - sum = sum + del - if(abs(del) < abs(sum)*eps) exit - if(i == max_iteration) stop 'Number of iterations reached maximum & - number of iterations, stopping. Consider increasing max_iteration.' - enddo - gamser = sum * exp(-x + a * log(x) - gln) - endif - - endsubroutine gser - - subroutine gcf(gammcf,a,x,gln) - real(dp), intent(in) :: a, x - real(dp), intent(out) :: gammcf, gln - - ! USES ln_gamma - ! Returns the incomplete gamma function Q(a, x) evaluated by its continued - ! fraction representation as gammcf. Also returns ln \Gamma(a) as gln. - - integer :: i - real(dp) :: an,b,c,d,del,h - - gln = ln_gamma(a) - - b = x + 1.0_dp - a ! Set up for evaluating continued fraction by modiï¬ed - c = 1.0 / min_float ! Lentz’s method (5.2) with b0 = 0. - d = 1.0_dp / b - h = d - i = 0 - do ! Iterate to convergence. - i = i + 1 - an = -i * (i-a) - b = b + 2.0_dp - d = an * d + b - - if(abs(d) < min_float) d = min_float - - c = b + an / c - - if(abs(c) < min_float) c = min_float - - d = 1.0_dp / d - del = d * c - h = h * del - if(abs(del-1.0_dp) < eps) exit - if(i == max_iteration) stop 'Number of iterations reached maximum & - number of iterations, stopping. Consider increasing max_iteration.' - enddo - gammcf = exp(-x + a*log(x) - gln)*h ! Put factors in front. - - endsubroutine gcf - -! function ln_gamma(xx) -! real(dp), intent(in) :: xx -! real(dp) :: ln_gamma -! -! ! Returns the value ln[ \Gamma(xx)] for xx > 0. -! integer :: j -! real(dp) :: ser, tmp, x, y -! -! real(dp), dimension(6), parameter :: cof = (/76.18009172947146_dp,-86.50532032941677_dp, & -! 24.01409824083091_dp,-1.231739572450155_dp,0.1208650973866179e-2_dp,-0.5395239384953e-5_dp/) -! real(dp), parameter :: stp = 2.5066282746310005_dp -! -! x = xx -! y = x -! tmp = x + 5.5_dp -! tmp = (x + 0.5_dp) * log(tmp) - tmp -! ser = 1.000000000190015_dp -! do j = 1, 6 -! y = y + 1.0_dp -! ser = ser + cof(j) / y -! enddo -! ln_gamma = tmp + log(stp*ser/x) -! endfunction ln_gamma - - function ln_gamma(xx) - real(dp), intent(in) :: xx - real(dp) :: ln_gamma - - integer :: i - real(dp) :: z, x, t - - real(dp), parameter :: g = 7.0_dp - integer, parameter :: n = 9 - real(dp), dimension(n), parameter :: p = & - (/0.99999999999980993227684700473478_dp, 676.520368121885098567009190444019_dp, & - -1259.13921672240287047156078755283_dp, 771.3234287776530788486528258894_dp, & - -176.61502916214059906584551354_dp, 12.507343278686904814458936853_dp, & - -0.13857109526572011689554707_dp, 9.984369578019570859563e-6_dp, 1.50563273514931155834e-7_dp /) - - !real(dp), parameter :: g = 4.74218750_dp - !integer, parameter :: n = 15 - !real(dp), dimension(n), parameter :: p = & - !(/0.99999999999999709182_dp, 57.156235665862923517_dp, -59.597960355475491248_dp, & - ! 14.136097974741747174_dp, -0.49191381609762019978_dp, .33994649984811888699e-4_dp, & - ! 0.46523628927048575665e-4_dp, -0.98374475304879564677e-4_dp, 0.15808870322491248884e-3_dp, & - ! -0.21026444172410488319e-3_dp, 0.21743961811521264320e-3_dp, -0.16431810653676389022e-3_dp, & - ! 0.84418223983852743293e-4_dp, -0.26190838401581408670e-4_dp, 0.36899182659531622704e-5_dp/) - - z = xx - 1.0_dp - - x = 0.0_dp - do i = n, 2, -1 - x = x + p(i)/(z+real(i-1,dp)) - enddo - x = x + p(1) - - t = z + g + 0.5_dp - - ln_gamma = log_sqrt_2_pi - t + log(x) + (z+0.5_dp)*log(t) - - endfunction ln_gamma - -endmodule gamma_module diff --git a/src/libAtoms/histogram1d.f95 b/src/libAtoms/histogram1d.f95 deleted file mode 100644 index 65ea56010d..0000000000 --- a/src/libAtoms/histogram1d.f95 +++ /dev/null @@ -1,1991 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Histogram helper functions in 1D -!X -!X Computes periodic and non-periodic histograms within certain bounds. -!X Interpolation can be chosen from -!X INTERP_LINEAR: Linear interpolation between neigboring grid -!X points -!X INTERP_LUCY: Lucy function interpolation between neighboring -!X grid points -!X TODO: -!X INTERP_NONE: No interpolation, simply sort into bins -!X -!X Provides routine for MPI communication. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -#define ASSERT(x) - -module histogram1d_module - use Error_module - use System_module - use Units_module - use MPI_context_module - - private - - public :: INTERP_LINEAR, INTERP_LUCY - integer, parameter :: INTERP_LINEAR = 0 - integer, parameter :: INTERP_LUCY = 1 - - public :: Histogram1D - type Histogram1D - - ! - ! General stuff - ! - - integer :: interp ! INTERP_LINEAR, INTERP_LUCY - - integer :: n = -1 ! number of bins - real(DP) :: min_b ! minimum value - real(DP) :: max_b ! maximun value - real(DP) :: db ! difference - real(DP) :: dbin ! bin size - - logical :: periodic - - ! - ! For smoothing function - ! - - real(DP) :: sigma - - real(DP) :: fac1 -! real(DP) :: sigma_sq - - ! - ! Values - ! - - real(DP), allocatable :: x(:) ! x-values - - real(DP), allocatable :: h(:) ! values - real(DP), allocatable :: h_sq(:) ! second moment - - real(DP), allocatable :: h1(:) ! histogram with norm 1 (number of values which have been added to each bin) - - integer :: ng - real(DP), pointer :: smoothing_func(:) => NULL() - - endtype Histogram1D - - ! - ! Interface definition - ! - - public :: initialise - interface initialise - module procedure histogram1d_initialise, histogram1d_initialise_from_histogram - endinterface - - public :: finalise - interface finalise - module procedure histogram1d_finalise - endinterface - - public :: clear - interface clear - module procedure histogram1d_clear - endinterface - - public :: set_bounds - interface set_bounds - module procedure histogram1d_set_bounds - endinterface - - public :: write - interface write - module procedure histogram1d_write, histogram1d_write_mult - module procedure histogram1d_write_character_fn, histogram1d_write_mult_character_fn - endinterface - - public :: add - interface add - module procedure histogram1d_add, histogram1d_add_vals, histogram1d_add_vals_norms - module procedure histogram1d_add_vals_mask, histogram1d_add_vals_norm_mask, histogram1d_add_vals_norms_mask - module procedure histogram1d_add_histogram, histogram1d_add_mult_histograms - endinterface - - public :: add_range - interface add_range - module procedure histogram1d_add_range, histogram1d_add_range_vals, histogram1d_add_range_vals_norms - endinterface - - public :: average - interface average - module procedure histogram1d_average - endinterface - - public :: entropy - interface entropy - module procedure histogram1d_entropy - endinterface - - public :: expectation_value - interface expectation_value - module procedure histogram1d_expectation_value - endinterface - - public :: mul - interface mul - module procedure histogram1d_mul, histograms_mul, histograms2_mul, histogram1d_mul_vals - endinterface - - public :: div - interface div - module procedure histogram1d_div, histograms_div, histograms2_div, histogram1d_div_vals - endinterface - - public :: normalize - interface normalize - module procedure histogram1d_normalize - endinterface - - public :: reduce - interface reduce - module procedure histogram1d_reduce - endinterface - - public :: smooth - interface smooth - module procedure histogram1d_smooth - endinterface - - public :: sum_in_place - interface sum_in_place - module procedure histogram1d_sum_in_place - endinterface - -! Memory estimation not yet implemented in libAtoms -#if 0 - interface log_memory_estimate - module procedure log_memory_estimate_histogram, log_memory_estimate_histogram2, log_memory_estimate_histogram3 - endinterface -#endif - -contains - - !% Initialize the histogram - !% Default is linear interpolation, non-periodic - elemental subroutine histogram1d_initialise(this, n, min_b, max_b, sigma, & - periodic) - implicit none - - type(Histogram1D), intent(inout) :: this - integer, intent(in) :: n - real(DP), intent(in) :: min_b - real(DP), intent(in) :: max_b - real(DP), intent(in), optional :: sigma - logical, intent(in), optional :: periodic - - ! --- - - call finalise(this) - - this%n = n - - if (present(sigma) .and. sigma > 0.0_DP) then - - this%interp = INTERP_LUCY - - this%sigma = sigma - -! this%fac1 = 1.0_DP/(sqrt(2*PI)*this%sigma) -! this%sigma_sq = 2*sigma**2 - this%fac1 = 5/(4*this%sigma) - - else - - this%interp = INTERP_LINEAR - - endif - - if (present(periodic)) then - this%periodic = periodic - else - this%periodic = .false. - endif - - this%smoothing_func => NULL() - - allocate(this%x(n)) - allocate(this%h(n)) - allocate(this%h_sq(n)) - allocate(this%h1(n)) - - this%min_b = min_b - 1.0_DP - this%max_b = max_b - 1.0_DP - - call histogram1d_set_bounds(this, min_b, max_b) - - call histogram1d_clear(this) - - endsubroutine histogram1d_initialise - - - !% Initialize the histogram - subroutine histogram1d_initialise_from_histogram(this, that) - implicit none - - type(Histogram1D), intent(out) :: this - type(Histogram1D), intent(in ) :: that - - ! --- - - call finalise(this) - - this%n = that%n - - this%interp = that%interp - this%sigma = that%sigma - - if (this%interp == INTERP_LUCY) then - this%fac1 = 5/(4*this%sigma) - endif - - this%periodic = that%periodic - - this%smoothing_func => NULL() - - allocate(this%x(this%n)) - allocate(this%h(this%n)) - allocate(this%h_sq(this%n)) - allocate(this%h1(this%n)) - - this%min_b = that%min_b - 1.0_DP - this%max_b = that%max_b - 1.0_DP - - call histogram1d_set_bounds(this, that%min_b, that%max_b) - - call histogram1d_clear(this) - - endsubroutine histogram1d_initialise_from_histogram - - - !% Clear histogram - elemental subroutine histogram1d_clear(this) - implicit none - - type(Histogram1D), intent(inout) :: this - - ! --- - - this%h1 = 0.0_DP - this%h = 0.0_DP - this%h_sq = 0.0_DP - - endsubroutine histogram1d_clear - - - !% Set histogram bounds - elemental subroutine histogram1d_set_bounds(this, min_b, max_b) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: min_b - real(DP), intent(in) :: max_b - - ! --- - - integer :: i - real(DP) :: x - - ! --- - - if (this%min_b /= min_b .or. this%max_b /= max_b) then - - this%min_b = min_b - this%max_b = max_b - this%db = max_b - min_b - - if (this%periodic) then - this%dbin = this%db/this%n - else - this%dbin = this%db/(this%n-1) - endif - - do i = 1, this%n - this%x(i) = this%min_b + this%dbin*(i-0.5_DP) - enddo - - ! - ! Tabulate the smoothing function - ! - - if (this%interp == INTERP_LUCY) then - - this%ng = floor(this%sigma/this%dbin) - - if (.not. associated(this%smoothing_func)) then - allocate(this%smoothing_func(-this%ng:this%ng)) - else if (ubound(this%smoothing_func, 1) /= this%ng) then - deallocate(this%smoothing_func) - allocate(this%smoothing_func(-this%ng:this%ng)) - endif - - do i = -this%ng, this%ng -! this%smoothing_func(i) = this%fac1 * exp(-((this%dbin*i)**2)/this%sigma_sq) - x = abs( ( this%dbin*i )/this%sigma ) - this%smoothing_func(i) = this%fac1 * (1+3*x)*(1-x)**3 - enddo - - endif - - endif - - endsubroutine histogram1d_set_bounds - - - !% Delete a histogram table - elemental subroutine histogram1d_finalise(this) - implicit none - - type(Histogram1D), intent(inout) :: this - - ! --- - -#if 0 - if (allocated(this%x)) then - deallocate(this%x) - endif - if (allocated(this%h)) then - deallocate(this%h) - endif - if (allocated(this%h_sq)) then - deallocate(this%h_sq) - endif - if (allocated(this%h1)) then - deallocate(this%h1) - endif - - if (associated(this%smoothing_func)) then - deallocate(this%smoothing_func) - endif -#endif - - endsubroutine histogram1d_finalise - - - !% Output the histogram table to a file (by file unit) - subroutine histogram1d_write_mult(this, file, xvalues, header, error) - implicit none - - type(Histogram1D), intent(in) :: this(:) - type(InOutput), intent(in) :: file - logical, intent(in), optional :: xvalues - character(*), intent(in), optional :: header(lbound(this, 1):ubound(this, 1)) - integer, intent(out), optional :: error - - ! --- - - integer :: i, j - character(80) :: fmt - character(20) :: ext_header(lbound(this, 1):ubound(this, 1)) - - integer :: n - real(DP) :: min_b, max_b, dbin, y(lbound(this, 1):ubound(this, 1)) - - ! --- - - INIT_ERROR(error) - - n = this(lbound(this, 1))%n - min_b = this(lbound(this, 1))%min_b - max_b = this(lbound(this, 1))%max_b - dbin = this(lbound(this, 1))%dbin - - do i = lbound(this, 1)+1, ubound(this, 1) - if (this(i)%n /= n) then - RAISE_ERROR("Number of histogram bins do not match.", error) - endif - - if (this(i)%min_b /= min_b) then - RAISE_ERROR("*min_b*s do not match.", error) - endif - - if (this(i)%max_b /= max_b) then - RAISE_ERROR("*max_b*s do not match.", error) - endif - enddo - - if (present(header)) then - do i = lbound(this, 1), ubound(this, 1) - write (fmt, '(I2.2)') i+2 - ext_header(i) = trim(fmt) // ":" // trim(header(i)) - ext_header(i) = adjustr(ext_header(i)) - enddo - - write (fmt, '(A,I4.4,A)') "(A5,5X,A20,", ubound(this, 1)-lbound(this, 1)+1, "A20)" - write (file%unit, fmt) "#01:i", "02:x", ext_header - endif - - if (present(xvalues) .and. .not. xvalues) then - write (fmt, '(A,I4.4,A)') "(A,", n, "ES20.10)" - write (file%unit, trim(fmt)) "# ", this(lbound(this, 1))%x - write (fmt, '(A,I4.4,A)') "(I10,", ubound(this, 1)-lbound(this, 1)+1, "ES20.10)" - else - write (fmt, '(A,I4.4,A)') "(I10,", ubound(this, 1)-lbound(this, 1)+2, "ES20.10)" - endif - - do i = 1, n - do j = lbound(this, 1), ubound(this, 1) - y(j) = this(j)%h(i) - enddo - - if (present(xvalues) .and. .not. xvalues) then - write (file%unit, trim(fmt)) i, y - else - write (file%unit, trim(fmt)) i, this(lbound(this, 1))%x(i), y - endif - enddo - - endsubroutine histogram1d_write_mult - - - !% Output the histogram table to a file (by file name) - subroutine histogram1d_write_mult_character_fn(this, fn, xvalues, header, error) - implicit none - - type(Histogram1D), intent(in) :: this(:) - character(*), intent(in) :: fn - logical, intent(in), optional :: xvalues - character(*), intent(in), optional :: header(lbound(this, 1):ubound(this, 1)) - integer, intent(out), optional :: error - - ! --- - - type(InOutput) :: file - - ! --- - - INIT_ERROR(error) - - call initialise(file, fn, action=OUTPUT, error=error) - PASS_ERROR(error) - call histogram1d_write_mult(this, file, xvalues, header, error=error) - call finalise(file) - PASS_ERROR(error) - - endsubroutine histogram1d_write_mult_character_fn - - - !% Output the histogram table to a file (by file unit) - subroutine histogram1d_write(this, file, xvalues, header, error) - implicit none - - type(Histogram1D), intent(in) :: this - type(InOutput), intent(in) :: file - logical, intent(in), optional :: xvalues - character(*), intent(in), optional :: header - integer, intent(out), optional :: error - - ! --- - - INIT_ERROR(error) - - if (present(header)) then - call histogram1d_write_mult((/ this /), file, xvalues, (/ header /), error=error) - PASS_ERROR(error) - else - call histogram1d_write_mult((/ this /), file, xvalues, error=error) - PASS_ERROR(error) - endif - - endsubroutine histogram1d_write - - - !% Output the histogram table to a file (by file name) - subroutine histogram1d_write_character_fn(this, fn, xvalues, header, error) - implicit none - - type(Histogram1D), intent(in) :: this - character(*), intent(in) :: fn - logical, intent(in), optional :: xvalues - character(*), intent(in), optional :: header - integer, intent(out), optional :: error - - ! --- - - INIT_ERROR(error) - - if (present(header)) then - call histogram1d_write_mult_character_fn((/ this /), fn, xvalues, (/ header /), error=error) - PASS_ERROR(error) - else - call histogram1d_write_mult_character_fn((/ this /), fn, xvalues, error=error) - PASS_ERROR(error) - endif - - endsubroutine histogram1d_write_character_fn - - - !% Add a value to the histogram with linear interpolation - subroutine histogram1d_add_linear(this, val, norm) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: val - real(DP), intent(in) :: norm - - ! --- - - integer :: i1, i2 - real(DP) :: d1, d2 - - ! --- - - i1 = int(floor((val-this%min_b)/this%dbin))+1 - i2 = i1+1 - - d1 = ( (i2-1) - (val-this%min_b)/this%dbin )/this%dbin - d2 = ( (val-this%min_b)/this%dbin - (i1-1) )/this%dbin - - if ((i1 >= 0 .and. i1 <= this%n) .or. this%periodic) then - ASSERT(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP) - - if (this%periodic) then - i1 = modulo(i1-1, this%n)+1 - else - if (i1 == 0) then - i1 = 1 - endif - endif - - this%h1(i1) = this%h1(i1) + d1 - this%h(i1) = this%h(i1) + d1*norm - this%h_sq(i1) = this%h_sq(i1) + d1*norm**2 - endif - - if ((i2 >= 1 .and. i2 <= this%n+1) .or. this%periodic) then - ASSERT(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP) - - if (this%periodic) then - i2 = modulo(i2-1, this%n)+1 - else - if (i2 == this%n+1) then - i2 = this%n - endif - endif - - this%h1(i2) = this%h1(i2) + d2 - this%h(i2) = this%h(i2) + d2*norm - this%h_sq(i2) = this%h_sq(i2) + d2*norm**2 - endif - - endsubroutine histogram1d_add_linear - - - !% Add multiple values to the histogram with linear interpolation - subroutine histogram1d_add_linear_vals(this, vals, norm) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - real(DP), intent(in) :: norm - - ! --- - - integer :: i1(lbound(vals, 1):ubound(vals, 1)), i2(lbound(vals, 1):ubound(vals, 1)) - real(DP) :: d1(lbound(vals, 1):ubound(vals, 1)), d2(lbound(vals, 1):ubound(vals, 1)) - - integer :: i - - ! --- - - i1 = int(floor((vals-this%min_b)/this%dbin))+1 - i2 = i1+1 - - d1 = ( (i2-1) - (vals-this%min_b)/this%dbin )/this%dbin - d2 = ( (vals-this%min_b)/this%dbin - (i1-1) )/this%dbin - - ASSERT(all(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP)) - ASSERT(all(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP)) - - if (this%periodic) then - - i1 = modulo(i1-1, this%n)+1 - i2 = modulo(i2-1, this%n)+1 - - do i = lbound(vals, 1), ubound(vals, 1) - this%h1(i1(i)) = this%h1(i1(i)) + d1(i) - this%h1(i2(i)) = this%h1(i2(i)) + d2(i) - - this%h(i1(i)) = this%h(i1(i)) + d1(i)*norm - this%h(i2(i)) = this%h(i2(i)) + d2(i)*norm - - this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1(i)*norm**2 - this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2(i)*norm**2 - enddo - - else - - do i = lbound(vals, 1), ubound(vals, 1) - if (i1(i) >= 1 .and. i1(i) <= this%n) then - this%h1(i1(i)) = this%h1(i1(i)) + d1(i) - this%h(i1(i)) = this%h(i1(i)) + d1(i)*norm - this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1(i)*norm**2 - else if (i1(i) == 0) then - this%h1(1) = this%h1(1) + d1(i) - this%h(1) = this%h(1) + d1(i)*norm - this%h_sq(1) = this%h_sq(1) + d1(i)*norm**2 - endif - - if (i2(i) >= 1 .and. i2(i) <= this%n) then - this%h1(i2(i)) = this%h1(i2(i)) + d2(i) - this%h(i2(i)) = this%h(i2(i)) + d2(i)*norm - this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2(i)*norm**2 - else if (i2(i) == this%n+1) then - this%h1(this%n) = this%h1(this%n) + d2(i) - this%h(this%n) = this%h(this%n) + d2(i)*norm - this%h_sq(this%n) = this%h_sq(this%n) + d2(i)*norm**2 - endif - enddo - - endif - - endsubroutine histogram1d_add_linear_vals - - - !% Add multiple values to the histogram with linear interpolation - subroutine histogram1d_add_linear_vals_norms(this, vals, norms) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - real(DP), intent(in) :: norms(:) - - ! --- - - integer :: i1(lbound(vals, 1):ubound(vals, 1)), i2(lbound(vals, 1):ubound(vals, 1)) - real(DP) :: d1(lbound(vals, 1):ubound(vals, 1)), d2(lbound(vals, 1):ubound(vals, 1)) - - real(DP) :: d1n(lbound(vals, 1):ubound(vals, 1)), d2n(lbound(vals, 1):ubound(vals, 1)) - real(DP) :: d1nn(lbound(vals, 1):ubound(vals, 1)), d2nn(lbound(vals, 1):ubound(vals, 1)) - - integer :: i - - ! --- - - i1 = int(floor((vals-this%min_b)/this%dbin))+1 - i2 = i1+1 - - d1 = ( (i2-1) - (vals-this%min_b)/this%dbin )/this%dbin - d2 = ( (vals-this%min_b)/this%dbin - (i1-1) )/this%dbin - - ASSERT(all(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP)) - ASSERT(all(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP)) - - d1n = d1*norms - d2n = d2*norms - - d1nn = d1n*norms - d2nn = d2n*norms - - if (this%periodic) then - - i1 = modulo(i1-1, this%n)+1 - i2 = modulo(i2-1, this%n)+1 - - do i = lbound(vals, 1), ubound(vals, 1) - this%h1(i1(i)) = this%h1(i1(i)) + d1(i) - this%h1(i2(i)) = this%h1(i2(i)) + d2(i) - - this%h(i1(i)) = this%h(i1(i)) + d1n(i) - this%h(i2(i)) = this%h(i2(i)) + d2n(i) - - this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) - this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) - enddo - - else - - do i = lbound(vals, 1), ubound(vals, 1) - if (i1(i) >= 1 .and. i1(i) <= this%n) then - this%h1(i1(i)) = this%h1(i1(i)) + d1(i) - this%h(i1(i)) = this%h(i1(i)) + d1n(i) - this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) - else if (i1(i) == 0) then - this%h1(1) = this%h1(1) + d1(i) - this%h(1) = this%h(1) + d1n(i) - this%h_sq(1) = this%h_sq(1) + d1nn(i) - endif - - if (i2(i) >= 1 .and. i2(i) <= this%n) then - this%h1(i2(i)) = this%h1(i2(i)) + d2(i) - this%h(i2(i)) = this%h(i2(i)) + d2n(i) - this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) - else if (i2(i) == this%n+1) then - this%h1(this%n) = this%h1(this%n) + d2(i) - this%h(this%n) = this%h(this%n) + d2n(i) - this%h_sq(this%n) = this%h_sq(this%n) + d2nn(i) - endif - enddo - - endif - - endsubroutine histogram1d_add_linear_vals_norms - - - !% Add multiple values to the histogram with linear interpolation - !% and an additional mask - subroutine histogram1d_add_linear_vals_norm_mask(this, vals, norm, mask) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - real(DP), intent(in) :: norm - logical, intent(in) :: mask(:) - - ! --- - - integer :: i1(lbound(vals, 1):ubound(vals, 1)), i2(lbound(vals, 1):ubound(vals, 1)) - real(DP) :: d1(lbound(vals, 1):ubound(vals, 1)), d2(lbound(vals, 1):ubound(vals, 1)) - - real(DP) :: d1n(lbound(vals, 1):ubound(vals, 1)), d2n(lbound(vals, 1):ubound(vals, 1)) - real(DP) :: d1nn(lbound(vals, 1):ubound(vals, 1)), d2nn(lbound(vals, 1):ubound(vals, 1)) - - integer :: i - - ! --- - - i1 = int(floor((vals-this%min_b)/this%dbin))+1 - i2 = i1+1 - - d1 = ( (i2-1) - (vals-this%min_b)/this%dbin )/this%dbin - d2 = ( (vals-this%min_b)/this%dbin - (i1-1) )/this%dbin - - ASSERT(all(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP)) - ASSERT(all(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP)) - - d1n = d1*norm - d2n = d2*norm - - d1nn = d1n*norm - d2nn = d2n*norm - - if (this%periodic) then - - i1 = modulo(i1-1, this%n)+1 - i2 = modulo(i2-1, this%n)+1 - - do i = lbound(vals, 1), ubound(vals, 1) - if (mask(i)) then - this%h1(i1(i)) = this%h1(i1(i)) + d1(i) - this%h1(i2(i)) = this%h1(i2(i)) + d2(i) - - this%h(i1(i)) = this%h(i1(i)) + d1n(i) - this%h(i2(i)) = this%h(i2(i)) + d2n(i) - - this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) - this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) - endif - enddo - - else - - do i = lbound(vals, 1), ubound(vals, 1) - if (mask(i)) then - if (i1(i) >= 1 .and. i1(i) <= this%n) then - this%h1(i1(i)) = this%h1(i1(i)) + d1(i) - this%h(i1(i)) = this%h(i1(i)) + d1n(i) - this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) - else if (i1(i) == 0) then - this%h1(1) = this%h1(1) + d1(i) - this%h(1) = this%h(1) + d1n(i) - this%h_sq(1) = this%h_sq(1) + d1nn(i) - endif - - if (i2(i) >= 1 .and. i2(i) <= this%n) then - this%h1(i2(i)) = this%h1(i2(i)) + d2(i) - this%h(i2(i)) = this%h(i2(i)) + d2n(i) - this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) - else if (i2(i) == this%n+1) then - this%h1(this%n) = this%h1(this%n) + d2(i) - this%h(this%n) = this%h(this%n) + d2n(i) - this%h_sq(this%n) = this%h_sq(this%n) + d2nn(i) - endif - endif - enddo - - endif - - endsubroutine histogram1d_add_linear_vals_norm_mask - - - !% Add multiple values to the histogram with linear interpolation - !% and an additional mask - subroutine histogram1d_add_linear_vals_norms_mask(this, vals, norms, mask) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - real(DP), intent(in) :: norms(:) - logical, intent(in) :: mask(:) - - ! --- - - integer :: i1(lbound(vals, 1):ubound(vals, 1)), i2(lbound(vals, 1):ubound(vals, 1)) - real(DP) :: d1(lbound(vals, 1):ubound(vals, 1)), d2(lbound(vals, 1):ubound(vals, 1)) - - real(DP) :: d1n(lbound(vals, 1):ubound(vals, 1)), d2n(lbound(vals, 1):ubound(vals, 1)) - real(DP) :: d1nn(lbound(vals, 1):ubound(vals, 1)), d2nn(lbound(vals, 1):ubound(vals, 1)) - - integer :: i - - ! --- - - i1 = int(floor((vals-this%min_b)/this%dbin))+1 - i2 = i1+1 - - d1 = ( (i2-1) - (vals-this%min_b)/this%dbin )/this%dbin - d2 = ( (vals-this%min_b)/this%dbin - (i1-1) )/this%dbin - - ASSERT(all(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP)) - ASSERT(all(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP)) - - d1n = d1*norms - d2n = d2*norms - - d1nn = d1n*norms - d2nn = d2n*norms - - if (this%periodic) then - - i1 = modulo(i1-1, this%n)+1 - i2 = modulo(i2-1, this%n)+1 - - do i = lbound(vals, 1), ubound(vals, 1) - if (mask(i)) then - this%h1(i1(i)) = this%h1(i1(i)) + d1(i) - this%h1(i2(i)) = this%h1(i2(i)) + d2(i) - - this%h(i1(i)) = this%h(i1(i)) + d1n(i) - this%h(i2(i)) = this%h(i2(i)) + d2n(i) - - this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) - this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) - endif - enddo - - else - - do i = lbound(vals, 1), ubound(vals, 1) - if (mask(i)) then - if (i1(i) >= 1 .and. i1(i) <= this%n) then - this%h1(i1(i)) = this%h1(i1(i)) + d1(i) - this%h(i1(i)) = this%h(i1(i)) + d1n(i) - this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) - else if (i1(i) == 0) then - this%h1(1) = this%h1(1) + d1(i) - this%h(1) = this%h(1) + d1n(i) - this%h_sq(1) = this%h_sq(1) + d1nn(i) - endif - - if (i2(i) >= 1 .and. i2(i) <= this%n) then - this%h1(i2(i)) = this%h1(i2(i)) + d2(i) - this%h(i2(i)) = this%h(i2(i)) + d2n(i) - this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) - else if (i2(i) == this%n+1) then - this%h1(this%n) = this%h1(this%n) + d2(i) - this%h(this%n) = this%h(this%n) + d2n(i) - this%h_sq(this%n) = this%h_sq(this%n) + d2nn(i) - endif - endif - enddo - - endif - - endsubroutine histogram1d_add_linear_vals_norms_mask - - - !% Add a value which is broadened by a smoothing function to the histogram - subroutine histogram1d_add_smoothed(this, val, norm) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: val - real(DP), intent(in) :: norm - - ! --- - - real(DP) :: expvals(this%n) - - integer :: i1, i2, g1, g2 - real(DP) :: x2 - - ! --- - - x2 = (val-this%min_b)/this%dbin + 0.5_DP - i1 = floor(x2) - x2 = x2 - i1 - - g1 = -this%ng - g2 = this%ng-1 - - expvals(1:2*this%ng) = x2*this%smoothing_func(g1:g2) + (1.0_DP-x2)*this%smoothing_func(g1+1:g2+1) - - i1 = i1 - this%ng+1 - i2 = i1 + 2*this%ng - 1 - - ! - ! Cut smoothing function if we're at the border - ! - - g1 = 1 - g2 = 2*this%ng - - if (i1 < 1) then - g1 = g1 + (1 - i1) - i1 = 1 - endif - - if (i2 > this%n) then - g2 = g2 - (i2 - this%n) - i2 = this%n - endif - - this%h1(i1:i2) = this%h1(i1:i2) + expvals(g1:g2) - this%h(i1:i2) = this%h(i1:i2) + expvals(g1:g2)*norm - this%h_sq(i1:i2) = this%h_sq(i1:i2) + expvals(g1:g2)*norm**2 - - endsubroutine histogram1d_add_smoothed - - - !********************************************************************** - ! Add a value - !********************************************************************** - subroutine histogram1d_add(this, val, norm) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: val - real(DP), intent(in), optional :: norm - - ! --- - - real(DP) :: n - - ! --- - - if (present(norm)) then - n = norm - else - n = 1.0_DP - endif - - if (this%interp == INTERP_LINEAR) then - call histogram1d_add_linear(this, val, n) - else - call histogram1d_add_smoothed(this, val, n) - endif - - endsubroutine histogram1d_add - - - !% Add a list of values to the histogram - subroutine histogram1d_add_vals(this, vals, norm) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - real(DP), intent(in), optional :: norm - - ! --- - - integer :: i - real(DP) :: n - - ! --- - - if (present(norm)) then - n = norm - else - n = 1.0_DP - endif - - if (this%interp == INTERP_LINEAR) then - - call histogram1d_add_linear_vals(this, vals, n) - - else - - do i = lbound(vals, 1), ubound(vals, 1) - call histogram1d_add_smoothed(this, vals(i), n) - enddo - - endif - - endsubroutine histogram1d_add_vals - - - !% Add a list of values to the histogram - subroutine histogram1d_add_vals_mask(this, vals, mask) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - logical, intent(in) :: mask(:) - - ! --- - - integer :: i - - ! --- - - if (this%interp == INTERP_LINEAR) then - - do i = lbound(vals, 1), ubound(vals, 1) - if (mask(i)) then - call histogram1d_add_linear(this, vals(i), 1.0_DP) - endif - enddo - - else - - do i = lbound(vals, 1), ubound(vals, 1) - if (mask(i)) then - call histogram1d_add_smoothed(this, vals(i), 1.0_DP) - endif - enddo - - endif - - endsubroutine histogram1d_add_vals_mask - - - !% Add a list of values to the histogram - subroutine histogram1d_add_vals_norms(this, vals, norms) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - real(DP), intent(in) :: norms(:) - - ! --- - - integer :: i - - ! --- - - if (this%interp == INTERP_LINEAR) then - - call histogram1d_add_linear_vals_norms(this, vals, norms) - - else - - do i = lbound(vals, 1), ubound(vals, 1) - call histogram1d_add_smoothed(this, vals(i), norms(i)) - enddo - - endif - - endsubroutine histogram1d_add_vals_norms - - - !% Add a list of values to the histogram - subroutine histogram1d_add_vals_norm_mask(this, vals, norm, mask) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - real(DP), intent(in) :: norm - logical, intent(in) :: mask(:) - - ! --- - - integer :: i - - ! --- - - if (this%interp == INTERP_LINEAR) then - - call histogram1d_add_linear_vals_norm_mask(this, vals, norm, mask) - - else - - do i = lbound(vals, 1), ubound(vals, 1) - if (mask(i)) then - call histogram1d_add_smoothed(this, vals(i), norm) - endif - enddo - - endif - - endsubroutine histogram1d_add_vals_norm_mask - - - !% Add a list of values to the histogram - subroutine histogram1d_add_vals_norms_mask(this, vals, norms, mask) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(:) - real(DP), intent(in) :: norms(:) - logical, intent(in) :: mask(:) - - ! --- - - integer :: i - - ! --- - - if (this%interp == INTERP_LINEAR) then - - call histogram1d_add_linear_vals_norms_mask(this, vals, norms, mask) - - else - - do i = lbound(vals, 1), ubound(vals, 1) - if (mask(i)) then - call histogram1d_add_smoothed(this, vals(i), norms(i)) - endif - enddo - - endif - - endsubroutine histogram1d_add_vals_norms_mask - - - !% Add a range of values to the histogram (linear interpolation only) - subroutine histogram1d_add_range(this, vala, valb, norm, error) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vala - real(DP), intent(in) :: valb - real(DP), intent(in), optional :: norm - integer, intent(out), optional :: error - - ! --- - - integer :: i1a, i2a, i1b, i2b, i - real(DP) :: d1a, d1b, d2a, d2b - real(DP) :: va, vb, fac, n, n_sq - - ! --- - - INIT_ERROR(error) - - if (this%interp /= INTERP_LINEAR) then - RAISE_ERROR("*histogram1d_add_range* can only be used with linear interpolation.", error) - endif - - n = 1.0_DP - if (present(norm)) then - n = norm - endif - n_sq = n**2 - - if (vala > valb) then - va = valb - vb = vala - else - va = vala - vb = valb - endif - - i1a = int(floor((va-this%min_b)/this%dbin))+1 - i2a = i1a+1 - - d1a = ( (i2a-1) - (va-this%min_b)/this%dbin ) - d2a = ( (va-this%min_b)/this%dbin - (i1a-1) ) - - i1b = int(floor((vb-this%min_b)/this%dbin))+1 - i2b = i1b+1 - - d1b = ( (i2b-1) - (vb-this%min_b)/this%dbin ) - d2b = ( (vb-this%min_b)/this%dbin - (i1b-1) ) - - if (va == vb) then - - this%h1(i1a) = this%h1(i1a) + d1a - this%h(i1a) = this%h(i1a) + d1a*n - this%h_sq(i1a) = this%h_sq(i1a) + d1a*n_sq - - this%h1(i2a) = this%h1(i2a) + d2a - this%h(i2a) = this%h(i2a) + d2a*n - this%h_sq(i2a) = this%h_sq(i2a) + d2a*n_sq - - else - - fac = 1.0_DP/(vb-va) - - if (i1a == i1b) then - - d1a = fac * ( d2b * ( 1.0_DP - 0.5_DP*d2b ) - d2a * ( 1.0_DP - 0.5_DP*d2a ) ) - d2a = fac * 0.5_DP * ( d2b**2 - d2a**2 ) - - this%h1(i1a) = this%h1(i1a) + d1a - this%h(i1a) = this%h(i1a) + d1a*n - this%h_sq(i1a) = this%h_sq(i1a) + d1a*n_sq - - this%h1(i2a) = this%h1(i2a) + d2a - this%h(i2a) = this%h(i2a) + d2a*n - this%h_sq(i2a) = this%h_sq(i2a) + d2a*n_sq - - else - - forall(i = i2a:i1b-1) - this%h1(i) = this%h1(i) + 0.5_DP*fac - this%h(i) = this%h(i) + 0.5_DP*fac*n - this%h_sq(i) = this%h_sq(i) + 0.5_DP*fac*n_sq - - this%h1(i+1) = this%h1(i+1) + 0.5_DP*fac - this%h(i+1) = this%h(i+1) + 0.5_DP*fac*n - this%h_sq(i+1) = this%h_sq(i+1) + 0.5_DP*fac*n_sq - endforall - - d2a = fac * d1a * ( 1 - 0.5_DP*d1a ) - d1a = fac * 0.5_DP * d1a**2 - - d1b = fac * d2b * ( 1 - 0.5_DP*d2b ) - d2b = fac * 0.5_DP * d2b**2 - - this%h1(i1a) = this%h1(i1a) + d1a - this%h(i1a) = this%h(i1a) + d1a*n - this%h_sq(i1a) = this%h_sq(i1a) + d1a*n_sq - - this%h1(i1b) = this%h1(i1b) + d1b - this%h(i1b) = this%h(i1b) + d1b*n - this%h_sq(i1b) = this%h_sq(i1b) + d1b*n_sq - - this%h1(i2a) = this%h1(i2a) + d2a - this%h(i2a) = this%h(i2a) + d2a*n - this%h_sq(i2a) = this%h_sq(i2a) + d2a*n_sq - - this%h1(i2b) = this%h1(i2b) + d2b - this%h(i2b) = this%h(i2b) + d2b*n - this%h_sq(i2b) = this%h_sq(i2b) + d2b*n_sq - - endif - - endif - - endsubroutine histogram1d_add_range - - - !% Add a range of values to the histogram (linear interpolation only) - subroutine histogram1d_add_range_vals(this, valsa, valsb, norm, mask, error) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: valsa(:) - real(DP), intent(in) :: valsb(:) - real(DP), intent(in), optional :: norm - logical, intent(in), optional :: mask(:) - integer, intent(out), optional :: error - - ! --- - - integer :: i, j - integer :: i1a(lbound(valsa, 1):ubound(valsa, 1)), i2a(lbound(valsa, 1):ubound(valsa, 1)) - integer :: i1b(lbound(valsb, 1):ubound(valsb, 1)), i2b(lbound(valsb, 1):ubound(valsb, 1)) - real(DP) :: d1a(lbound(valsa, 1):ubound(valsa, 1)), d2a(lbound(valsa, 1):ubound(valsa, 1)) - real(DP) :: d1b(lbound(valsb, 1):ubound(valsb, 1)), d2b(lbound(valsb, 1):ubound(valsb, 1)) - real(DP) :: va(lbound(valsa, 1):ubound(valsa, 1)), vb(lbound(valsb, 1):ubound(valsb, 1)) - real(DP) :: fac(lbound(valsa, 1):ubound(valsa, 1)) - real(DP) :: n, n_sq - logical :: m(lbound(valsa, 1):ubound(valsa, 1)) - - ! --- - - INIT_ERROR(error) - - if (this%interp /= INTERP_LINEAR) then - RAISE_ERROR("*histogram1d_add_range* can only be used with linear interpolation.", error) - endif - - n = 1.0_DP - if (present(norm)) then - n = norm - endif - n_sq = n**2 - - where (valsa > valsb) - va = valsb - vb = valsa - elsewhere - va = valsa - vb = valsb - endwhere - - fac = 1.0_DP - where (va /= vb) - fac = 1.0_DP/(vb-va) - endwhere - - m = .true. - if (present(mask)) then - m = mask - endif - - i1a = int(floor((va-this%min_b)/this%dbin))+1 - i2a = i1a+1 - - d1a = ( (i2a-1) - (va-this%min_b)/this%dbin ) - d2a = ( (va-this%min_b)/this%dbin - (i1a-1) ) - - i1b = int(floor((vb-this%min_b)/this%dbin))+1 - i2b = i1b+1 - - d1b = ( (i2b-1) - (vb-this%min_b)/this%dbin ) - d2b = ( (vb-this%min_b)/this%dbin - (i1b-1) ) - - - do j = lbound(valsa, 1), ubound(valsa, 1) - - if (m(j)) then - - if (va(j) == vb(j)) then - - this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) - this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*n - this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*n_sq - - this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) - this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*n - this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*n_sq - - else - - if (i1a(j) == i1b(j)) then - - d1a(j) = fac(j) * ( d2b(j) * ( 1.0_DP - 0.5_DP*d2b(j) ) - d2a(j) * ( 1.0_DP - 0.5_DP*d2a(j) ) ) - d2a(j) = fac(j) * 0.5_DP * ( d2b(j)**2 - d2a(j)**2 ) - - this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) - this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*n - this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*n_sq - - this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) - this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*n - this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*n_sq - - else - - forall(i = i2a(j):i1b(j)-1) - this%h1(i) = this%h1(i) + 0.5_DP*fac(j) - this%h(i) = this%h(i) + 0.5_DP*fac(j)*n - this%h_sq(i) = this%h_sq(i) + 0.5_DP*fac(j)*n_sq - - this%h1(i+1) = this%h1(i+1) + 0.5_DP*fac(j) - this%h(i+1) = this%h(i+1) + 0.5_DP*fac(j)*n - this%h_sq(i+1) = this%h_sq(i+1) + 0.5_DP*fac(j)*n_sq - endforall - - d2a(j) = fac(j) * d1a(j) * ( 1 - 0.5_DP*d1a(j) ) - d1a(j) = fac(j) * 0.5_DP * d1a(j)**2 - - d1b(j) = fac(j) * d2b(j) * ( 1 - 0.5_DP*d2b(j) ) - d2b(j) = fac(j) * 0.5_DP * d2b(j)**2 - - this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) - this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*n - this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*n_sq - - this%h1(i1b(j)) = this%h1(i1b(j)) + d1b(j) - this%h(i1b(j)) = this%h(i1b(j)) + d1b(j)*n - this%h_sq(i1b(j)) = this%h_sq(i1b(j)) + d1b(j)*n_sq - - this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) - this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*n - this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*n_sq - - this%h1(i2b(j)) = this%h1(i2b(j)) + d2b(j) - this%h(i2b(j)) = this%h(i2b(j)) + d2b(j)*n - this%h_sq(i2b(j)) = this%h_sq(i2b(j)) + d2b(j)*n_sq - - endif - - endif - - endif - - enddo - - endsubroutine histogram1d_add_range_vals - - - !% Add a range of values to the histogram (linear interpolation only) - subroutine histogram1d_add_range_vals_norms(this, valsa, valsb, norms, mask, error) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: valsa(:) - real(DP), intent(in) :: valsb(:) - real(DP), intent(in) :: norms(:) - logical, intent(in), optional :: mask(:) - integer, intent(out), optional :: error - - ! --- - - integer :: i, j - integer :: i1a(lbound(valsa, 1):ubound(valsa, 1)), i2a(lbound(valsa, 1):ubound(valsa, 1)) - integer :: i1b(lbound(valsb, 1):ubound(valsb, 1)), i2b(lbound(valsb, 1):ubound(valsb, 1)) - real(DP) :: d1a(lbound(valsa, 1):ubound(valsa, 1)), d2a(lbound(valsa, 1):ubound(valsa, 1)) - real(DP) :: d1b(lbound(valsb, 1):ubound(valsb, 1)), d2b(lbound(valsb, 1):ubound(valsb, 1)) - real(DP) :: va(lbound(valsa, 1):ubound(valsa, 1)), vb(lbound(valsb, 1):ubound(valsb, 1)) - real(DP) :: fac(lbound(valsa, 1):ubound(valsa, 1)) - logical :: m(lbound(valsa, 1):ubound(valsa, 1)) - - ! --- - - INIT_ERROR(error) - - if (this%interp /= INTERP_LINEAR) then - RAISE_ERROR("*histogram1d_add_range* can only be used with linear interpolation.", error) - endif - - where (valsa > valsb) - va = valsb - vb = valsa - elsewhere - va = valsa - vb = valsb - endwhere - - fac = 1.0_DP - where (va /= vb) - fac = 1.0_DP/(vb-va) - endwhere - - m = .true. - if (present(mask)) then - m = mask - endif - - i1a = int(floor((va-this%min_b)/this%dbin))+1 - i2a = i1a+1 - - d1a = ( (i2a-1) - (va-this%min_b)/this%dbin ) - d2a = ( (va-this%min_b)/this%dbin - (i1a-1) ) - - i1b = int(floor((vb-this%min_b)/this%dbin))+1 - i2b = i1b+1 - - d1b = ( (i2b-1) - (vb-this%min_b)/this%dbin ) - d2b = ( (vb-this%min_b)/this%dbin - (i1b-1) ) - - - do j = lbound(valsa, 1), ubound(valsa, 1) - - if (m(j)) then - - if (va(j) == vb(j)) then - - this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) - this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*norms(j) - this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*norms(j)*norms(j) - - this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) - this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*norms(j) - this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*norms(j)*norms(j) - - else - - if (i1a(j) == i1b(j)) then - - d1a(j) = fac(j) * ( d2b(j) * ( 1.0_DP - 0.5_DP*d2b(j) ) - d2a(j) * ( 1.0_DP - 0.5_DP*d2a(j) ) ) - d2a(j) = fac(j) * 0.5_DP * ( d2b(j)**2 - d2a(j)**2 ) - - this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) - this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*norms(j) - this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*norms(j)*norms(j) - - this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) - this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*norms(j) - this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*norms(j)*norms(j) - - else - - forall(i = i2a(j):i1b(j)-1) - this%h1(i) = this%h1(i) + 0.5_DP*fac(j) - this%h(i) = this%h(i) + 0.5_DP*fac(j)*norms(j) - this%h_sq(i) = this%h_sq(i) + 0.5_DP*fac(j)*norms(j)*norms(j) - - this%h1(i+1) = this%h1(i+1) + 0.5_DP*fac(j) - this%h(i+1) = this%h(i+1) + 0.5_DP*fac(j)*norms(j) - this%h_sq(i+1) = this%h_sq(i+1) + 0.5_DP*fac(j)*norms(j)*norms(j) - endforall - - d2a(j) = fac(j) * d1a(j) * ( 1 - 0.5_DP*d1a(j) ) - d1a(j) = fac(j) * 0.5_DP * d1a(j)**2 - - d1b(j) = fac(j) * d2b(j) * ( 1 - 0.5_DP*d2b(j) ) - d2b(j) = fac(j) * 0.5_DP * d2b(j)**2 - - this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) - this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*norms(j) - this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*norms(j)*norms(j) - - this%h1(i1b(j)) = this%h1(i1b(j)) + d1b(j) - this%h(i1b(j)) = this%h(i1b(j)) + d1b(j)*norms(j) - this%h_sq(i1b(j)) = this%h_sq(i1b(j)) + d1b(j)*norms(j)*norms(j) - - this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) - this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*norms(j) - this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*norms(j)*norms(j) - - this%h1(i2b(j)) = this%h1(i2b(j)) + d2b(j) - this%h(i2b(j)) = this%h(i2b(j)) + d2b(j)*norms(j) - this%h_sq(i2b(j)) = this%h_sq(i2b(j)) + d2b(j)*norms(j)*norms(j) - - endif - - endif - - endif - - enddo - - endsubroutine histogram1d_add_range_vals_norms - - - !% Add two histograms - subroutine histogram1d_add_histogram(this, that, fac) - implicit none - - type(Histogram1D), intent(inout) :: this - type(Histogram1D), intent(in) :: that - real(DP), intent(in), optional :: fac - - ! --- - - this%h1 = this%h1 + that%h1 - if (present(fac)) then - this%h = this%h + fac*that%h - else - this%h = this%h + that%h - endif - - endsubroutine histogram1d_add_histogram - - - !% Add a two vectors of multiple histograms histograms - subroutine histogram1d_add_mult_histograms(this, that, fac) - implicit none - - type(Histogram1D), intent(inout) :: this(:) - type(Histogram1D), intent(in) :: that(lbound(this,1):ubound(this,1)) - real(DP), intent(in), optional :: fac - - ! --- - - integer :: i - - ! --- - - do i = lbound(this,1), ubound(this,1) - this(i)%h1 = this(i)%h1 + that(i)%h1 - if (present(fac)) then - this(i)%h = this(i)%h + fac*that(i)%h - else - this(i)%h = this(i)%h + that(i)%h - endif - enddo - - endsubroutine histogram1d_add_mult_histograms - - - !% Compute average value in each bin (does only makes sense if - !% norm != 1 was used in the add functions) - subroutine histogram1d_average(this, mpi) - implicit none - - type(Histogram1D), intent(inout) :: this - type(MPI_context), optional, intent(in) :: mpi - - ! --- - - if (present(mpi)) then - call sum_in_place(mpi, this%h1) - call sum_in_place(mpi, this%h) - call sum_in_place(mpi, this%h_sq) - endif - - where (this%h1 == 0.0_DP) - this%h1 = 1.0_DP - endwhere - - this%h = this%h / this%h1 - this%h_sq = this%h_sq / this%h1 - - endsubroutine histogram1d_average - - - !% Compute Shannon entropy of this histogram. Needs to be called - !% after normalize. - elemental function histogram1d_entropy(this) result(val) - implicit none - - type(Histogram1D), intent(in) :: this - real(DP) :: val - - ! --- - - integer :: i - real(DP) :: S - - ! --- - - S = 0.0_DP - do i = 1, this%n - if (this%h(i) > 0.0_DP) then - S = S - this%h(i)*log(this%h(i)*this%dbin) - endif - enddo - - val = S*this%dbin - - endfunction histogram1d_entropy - - - !% Compute expectation value - elemental function histogram1d_expectation_value(this) result(val) - implicit none - - type(Histogram1D), intent(in) :: this - real(DP) :: val - - ! --- - - real(DP) :: n - - ! --- - - n = sum(this%h) - - if (n == 0.0_DP) then - val = 0.0_DP - else - val = sum(this%x * this%h / n) - endif - - endfunction histogram1d_expectation_value - - - !% Multiply the histogram by a value - for normalization - subroutine histogram1d_mul(this, val) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: val - - ! --- - - this%h = this%h * val - - endsubroutine histogram1d_mul - - - !% Multiply multiple histograms by a value - for normalization - subroutine histograms_mul(this, val) - implicit none - - type(Histogram1D), intent(inout) :: this(:) - real(DP), intent(in) :: val - - ! --- - - integer :: i - - ! --- - - do i = lbound(this, 1), ubound(this, 1) - this(i)%h = this(i)%h * val - enddo - - endsubroutine histograms_mul - - - !% Multiply multiple histograms by a value - for normalization - subroutine histograms2_mul(this, val) - implicit none - - type(Histogram1D), intent(inout) :: this(:, :) - real(DP), intent(in) :: val - - ! --- - - integer :: i, j - - ! --- - - do i = lbound(this, 1), ubound(this, 1) - do j = lbound(this, 2), ubound(this, 2) - this(i, j)%h = this(i, j)%h * val - enddo - enddo - - endsubroutine histograms2_mul - - - !% Multiply the histogram by multiple value - for normalization - subroutine histogram1d_mul_vals(this, vals) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(this%n) - - ! --- - - this%h = this%h * vals - - endsubroutine histogram1d_mul_vals - - - !% Divide histogram by a value - subroutine histogram1d_div(this, val) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: val - - ! --- - - this%h = this%h / val - - endsubroutine histogram1d_div - - - !% Divide multiple histograms by a value - subroutine histograms_div(this, val) - implicit none - - type(Histogram1D), intent(inout) :: this(:) - real(DP), intent(in) :: val - - ! --- - - integer :: i - - ! --- - - do i = lbound(this, 1), ubound(this, 1) - this(i)%h = this(i)%h / val - enddo - - endsubroutine histograms_div - - - !% Divide multiple histograms by a value - subroutine histograms2_div(this, val) - implicit none - - type(Histogram1D), intent(inout) :: this(:, :) - real(DP), intent(in) :: val - - ! --- - - integer :: i, j - - ! --- - - do i = lbound(this, 1), ubound(this, 1) - do j = lbound(this, 2), ubound(this, 2) - this(i, j)%h = this(i, j)%h / val - enddo - enddo - - endsubroutine histograms2_div - - - !% Divide histogram by multiple values - subroutine histogram1d_div_vals(this, vals) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: vals(this%n) - - ! --- - - this%h = this%h / vals - - endsubroutine histogram1d_div_vals - - - !% Normalize histogram - elemental subroutine histogram1d_normalize(this) - implicit none - - type(Histogram1D), intent(inout) :: this - - ! --- - - real(DP) :: n - - ! --- - - n = sum(this%h*this%dbin) - - if (n /= 0.0_DP) then - this%h = this%h / n - endif - - endsubroutine histogram1d_normalize - - - !% OpenMP reduction - *thpriv* is a threadprivate histogram, - !% this needs to be called within an *omp parallel* construct. - subroutine histogram1d_reduce(this, thpriv) - implicit none - - type(Histogram1D), intent(inout) :: this - type(Histogram1D), intent(in) :: thpriv - - ! --- - - !$omp single - call initialise(this, thpriv) - !$omp end single - - !$omp critical - this%h = this%h + thpriv%h - this%h_sq = this%h_sq + thpriv%h_sq - this%h1 = this%h1 + thpriv%h1 - !$omp end critical - - endsubroutine histogram1d_reduce - - - !% Smooth histogram by convolution with a Gaussian - subroutine histogram1d_smooth(this, sigma) - implicit none - - type(Histogram1D), intent(inout) :: this - real(DP), intent(in) :: sigma - - ! --- - - integer :: i - real(DP) :: fac, sigma_sq, h(this%n) - - ! --- - - h = 0.0_DP - - fac = this%dbin/(sqrt(2*PI)*sigma) - sigma_sq = sigma**2 - - do i = 1, this%n - h = h + fac*this%h(i)*exp(-((this%x - this%x(i))**2/(2*sigma_sq))) - enddo - - this%h = h - - endsubroutine histogram1d_smooth - - - !% Sum histogram from different processors onto root - subroutine histogram1d_sum_in_place(mpi, this) - implicit none - - type(MPI_context), intent(in) :: mpi - type(Histogram1D), intent(inout) :: this - - ! --- - - call sum_in_place(mpi, this%h) - call sum_in_place(mpi, this%h_sq) - call sum_in_place(mpi, this%h1) - - endsubroutine histogram1d_sum_in_place - - -#if 0 - !********************************************************************** - ! Memory estimate logging - !********************************************************************** - subroutine log_memory_estimate_histogram(this) - implicit none - - type(Histogram1D), intent(in) :: this - - ! --- - - call log_memory_estimate(this%x) - call log_memory_estimate(this%h) - call log_memory_estimate(this%h_sq) - call log_memory_estimate(this%h1) - - endsubroutine log_memory_estimate_histogram - - - !********************************************************************** - ! Memory estimate logging - !********************************************************************** - subroutine log_memory_estimate_histogram2(this) - implicit none - - type(Histogram1D), intent(in) :: this(:) - - ! --- - - integer :: i - - ! --- - - do i = lbound(this, 1), ubound(this, 1) - call log_memory_estimate_histogram(this(i)) - enddo - - endsubroutine log_memory_estimate_histogram2 - - - !********************************************************************** - ! Memory estimate logging - !********************************************************************** - subroutine log_memory_estimate_histogram3(this) - implicit none - - type(Histogram1D), intent(in) :: this(:, :) - - ! --- - - integer :: i, j - - ! --- - - do j = lbound(this, 2), ubound(this, 2) - do i = lbound(this, 1), ubound(this, 1) - call log_memory_estimate_histogram(this(i, j)) - enddo - enddo - - endsubroutine log_memory_estimate_histogram3 -#endif - -endmodule histogram1d_module diff --git a/src/libAtoms/histogram2d.f95 b/src/libAtoms/histogram2d.f95 deleted file mode 100644 index 0fe9346720..0000000000 --- a/src/libAtoms/histogram2d.f95 +++ /dev/null @@ -1,826 +0,0 @@ -!********************************************************************** -! Histogram helper functions -!********************************************************************** - -#include "macros.inc" - -module histogram2d_module - use libAtoms_module - - use io - use logging - - private - public : histogram2d, init, del, clear, set_bounds, write, add, average, mul, normalize, reduce, log_memory_estimate - - integer, parameter :: INTERP_LINEAR = 0 - integer, parameter :: INTERP_LUCY = 1 - - type histogram2d_t - - ! - ! General stuff - ! - - integer :: n(2) = -1 ! number of bins - real(DP) :: min_b(2) ! minimum value - real(DP) :: max_b(2) ! minimum value - real(DP) :: db(2) ! difference - real(DP) :: dbin(2) ! bin size - - logical :: periodic(2) - - ! - ! Values - ! - - real(DP), allocatable :: x1(:) ! x-values - real(DP), allocatable :: x2(:) ! x-values - - real(DP), allocatable :: h(:, :) ! values - integer, allocatable :: h1(:, :) ! histogram2d with norm 1 (number of values which have been added to each bin) - - endtype histogram2d_t - - ! - ! Interface definition - ! - - interface init - module procedure histogram2d_init, histogram2d_init_from_histogram2d - endinterface - - interface del - module procedure histogram2d_del - endinterface - - interface clear - module procedure histogram2d_clear - endinterface - - interface set_bounds - module procedure histogram2d_set_bounds - endinterface - - interface write - module procedure histogram2d_write, histogram2d_write_mult - module procedure histogram2d_write_character_fn, histogram2d_write_mult_character_fn - endinterface -, - interface add - module procedure histogram2d_add, histogram2d_add_vals, histogram2d_add_vals_norms - module procedure histogram2d_add_vals_mask, histogram2d_add_vals_norm_mask, histogram2d_add_vals_norms_mask - module procedure histogram2d_add_histogram2d - endinterface - - interface average - module procedure histogram2d_average - endinterface - - interface mul - module procedure histogram2d_mul, histogram2ds_mul, histogram2ds2_mul - endinterface - - interface normalize - module procedure histogram2d_normalize - endinterface - - interface reduce - module procedure histogram2d_reduce - endinterface - - interface log_memory_estimate - module procedure log_memory_estimate_histogram2d, log_memory_estimate_histogram2d2, log_memory_estimate_histogram2d3 - endinterface - -contains - - !********************************************************************** - ! Initialize the histogram2d - !********************************************************************** - elemental subroutine histogram2d_init(this, n1, n2, min_b1, max_b1, min_b2, max_b2, periodic1, periodic2) - implicit none - - type(histogram2d_t), intent(out) :: this - integer, intent(in) :: n1 - integer, intent(in) :: n2 - real(DP), intent(in) :: min_b1 - real(DP), intent(in) :: max_b1 - real(DP), intent(in) :: min_b2 - real(DP), intent(in) :: max_b2 - logical, intent(in), optional :: periodic1 - logical, intent(in), optional :: periodic2 - - ! --- - - call del(this) - - this%n = (/ n1, n2 /) - - this%periodic = .false. - - if (present(periodic1)) then - this%periodic(1) = periodic1 - endif - - if (present(periodic2)) then - this%periodic(2) = periodic2 - endif - - allocate(this%x1(this%n(1))) - allocate(this%x2(this%n(2))) - allocate(this%h(this%n(1), this%n(2))) - allocate(this%h1(this%n(1), this%n(2))) - - this%min_b = (/ min_b1, min_b2 /) - 1.0_DP - this%max_b = (/ max_b1, min_b2 /) - 1.0_DP - - call histogram2d_set_bounds(this, min_b1, max_b1, min_b2, max_b2) - - call histogram2d_clear(this) - - endsubroutine histogram2d_init - - - !********************************************************************** - ! Initialize the histogram2d - !********************************************************************** - elemental subroutine histogram2d_init_from_histogram2d(this, that) - implicit none - - type(histogram2d_t), intent(out) :: this - type(histogram2d_t), intent(in) :: that - - ! --- - - call del(this) - - this%n = that%n - this%periodic = that%periodic - - allocate(this%x1(this%n(1))) - allocate(this%x2(this%n(2))) - allocate(this%h(this%n(1), this%n(2))) - allocate(this%h1(this%n(1), this%n(2))) - - this%min_b = that%min_b - 1.0_DP - this%max_b = that%max_b - 1.0_DP - - call histogram2d_set_bounds(this, that%min_b(1), that%max_b(1), that%min_b(2), that%max_b(2)) - - call histogram2d_clear(this) - - endsubroutine histogram2d_init_from_histogram2d - - - !********************************************************************** - ! Clear histogram2d - !********************************************************************** - elemental subroutine histogram2d_clear(this) - implicit none - - type(histogram2d_t), intent(inout) :: this - - ! --- - - this%h1 = 0 - this%h = 0.0_DP - - endsubroutine histogram2d_clear - - - !********************************************************************** - ! Initialize the histogram2d - !********************************************************************** - elemental subroutine histogram2d_set_bounds(this, min_b1, max_b1, min_b2, max_b2) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: min_b1 - real(DP), intent(in) :: max_b1 - real(DP), intent(in) :: min_b2 - real(DP), intent(in) :: max_b2 - - ! --- - - integer :: i - - ! --- - - if (any(this%min_b /= (/ min_b1, min_b2 /)) .or. any(this%max_b /= (/ max_b1, max_b2 /))) then - - this%min_b = (/ min_b1, min_b2 /) - this%max_b = (/ max_b1, max_b2 /) - this%db = this%max_b - this%min_b - - this%dbin = this%db/this%n - - do i = 1, this%n(1) - this%x1(i) = this%min_b(1) + this%dbin(1)*(i-0.5_DP) - this%x2(i) = this%min_b(2) + this%dbin(2)*(i-0.5_DP) - enddo - - endif - - endsubroutine histogram2d_set_bounds - - - !********************************************************************** - ! Delete a histogram2d table - !********************************************************************** - elemental subroutine histogram2d_del(this) - implicit none - - type(histogram2d_t), intent(inout) :: this - - ! --- - - if (allocated(this%x1)) then - deallocate(this%x1) - endif - if (allocated(this%x2)) then - deallocate(this%x2) - endif - if (allocated(this%h)) then - deallocate(this%h) - endif - if (allocated(this%h1)) then - deallocate(this%h1) - endif - - endsubroutine histogram2d_del - - - !********************************************************************** - ! Output the histogram2d table to a file (by file unit) - !********************************************************************** - subroutine histogram2d_write_mult(this, un, ierror) - implicit none - - type(histogram2d_t), intent(in) :: this(:) - integer, intent(in) :: un - integer, intent(inout), optional :: ierror - - ! --- - - integer :: i, j, k - character(80) :: fmt - - integer :: n(2) - real(DP) :: min_b(2), max_b(2), dbin(2), y(lbound(this, 1):ubound(this, 1)) - - ! --- - - n = this(lbound(this, 1))%n - min_b = this(lbound(this, 1))%min_b - max_b = this(lbound(this, 1))%max_b - dbin = this(lbound(this, 1))%dbin - - do i = lbound(this, 1)+1, ubound(this, 1) - if (any(this(i)%n /= n)) then - RAISE_ERROR("Number of histogram2d bins do not match.", ierror) - endif - - if (any(this(i)%min_b /= min_b)) then - RAISE_ERROR("*min_b*s do not match.", ierror) - endif - - if (any(this(i)%max_b /= max_b)) then - RAISE_ERROR("*max_b*s do not match.", ierror) - endif - enddo - - write (fmt, '(A,I4.4,A)') "(", ubound(this, 1)-lbound(this, 1)+3, "ES20.10)" - - do i = 1, n(1) - do j = 1, n(2) - do k = lbound(this, 1), ubound(this, 1) - y(k) = this(k)%h(i, j) - enddo - - write (un, trim(fmt)) this(lbound(this, 1))%x1(i), this(lbound(this, 1))%x2(j), y - enddo - - write (un, *) - enddo - - endsubroutine histogram2d_write_mult - - - !********************************************************************** - ! Output the histogram2d table to a file (by file name) - !********************************************************************** - subroutine histogram2d_write_mult_character_fn(this, fn, ierror) - implicit none - - type(histogram2d_t), intent(in) :: this(:) - character(*), intent(in) :: fn - integer, intent(inout), optional :: ierror - - ! --- - - integer :: un - - ! --- - - un = fopen(fn, F_WRITE) - call histogram2d_write_mult(this, un, ierror=ierror) - call fclose(un) - - PASS_ERROR(ierror) - - endsubroutine histogram2d_write_mult_character_fn - - - !********************************************************************** - ! Output the histogram2d table to a file (by file unit) - !********************************************************************** - subroutine histogram2d_write(this, un, ierror) - implicit none - - type(histogram2d_t), intent(in) :: this - integer, intent(in) :: un - integer, intent(inout), optional :: ierror - - ! --- - - call histogram2d_write_mult((/ this /), un, ierror=ierror) - PASS_ERROR(ierror) - - endsubroutine histogram2d_write - - - !********************************************************************** - ! Output the histogram2d table to a file (by file name) - !********************************************************************** - subroutine histogram2d_write_character_fn(this, fn, ierror) - implicit none - - type(histogram2d_t), intent(in) :: this - character(*), intent(in) :: fn - integer, intent(inout), optional :: ierror - - ! --- - - call histogram2d_write_mult_character_fn((/ this /), fn, ierror) - PASS_ERROR(ierror) - - endsubroutine histogram2d_write_character_fn - - - !********************************************************************** - ! Add a value to the histogram2d with linear interpolation - !********************************************************************** - subroutine histogram2d_add_linear(this, val1, val2, norm) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: val1 - real(DP), intent(in) :: val2 - real(DP), intent(in) :: norm - - ! --- - - integer :: i1, i2 - - ! --- - - i1 = int(floor((val1-this%min_b(1))/this%dbin(1)))+1 - i2 = int(floor((val2-this%min_b(2))/this%dbin(2)))+1 - - if (this%periodic(1)) then - i1 = modulo(i1-1, this%n(1))+1 - endif - if (this%periodic(2)) then - i2 = modulo(i2-1, this%n(2))+1 - endif - - if (i1 >= 1 .and. i1 <= this%n(1) .and. i2 >= 1 .and. i2 <= this%n(2)) then - this%h1(i1, i2) = this%h1(i1, i2) + 1 - this%h(i1, i2) = this%h(i1, i2) + norm - endif - - endsubroutine histogram2d_add_linear - - - !********************************************************************** - ! Add a value to the histogram2d with linear interpolation - !********************************************************************** - subroutine histogram2d_add_linear_vals(this, vals1, vals2, norm) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: vals1(:) - real(DP), intent(in) :: vals2(:) - real(DP), intent(in) :: norm - - ! --- - - integer :: i1(lbound(vals1, 1):ubound(vals1, 1)) - integer :: i2(lbound(vals2, 1):ubound(vals2, 1)) - - integer :: i - - ! --- - - i1 = int(floor((vals1-this%min_b(1))/this%dbin(1)))+1 - i2 = int(floor((vals2-this%min_b(2))/this%dbin(2)))+1 - - if (this%periodic(1)) then - i1 = modulo(i1-1, this%n(1))+1 - endif - if (this%periodic(2)) then - i2 = modulo(i2-1, this%n(2))+1 - endif - - do i = lbound(vals1, 1), ubound(vals1, 1) - if (i1(i) >= 1 .and. i1(i) <= this%n(1) .and. i2(i) >= 1 .and. i2(i) <= this%n(2)) then - this%h1(i1(i), i2(i)) = this%h1(i1(i), i2(i)) + 1 - this%h(i1(i), i2(i)) = this%h(i1(i), i2(i)) + norm - endif - enddo - - endsubroutine histogram2d_add_linear_vals - - - !********************************************************************** - ! Add a value - !********************************************************************** - subroutine histogram2d_add(this, val1, val2, norm) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: val1 - real(DP), intent(in) :: val2 - real(DP), intent(in), optional :: norm - - ! --- - - real(DP) :: n - - ! --- - - if (present(norm)) then - n = norm - else - n = 1.0_DP - endif - - call histogram2d_add_linear(this, val1, val2, n) - - endsubroutine histogram2d_add - - - !********************************************************************** - ! Add a list of values to the histogram2d - !********************************************************************** - subroutine histogram2d_add_vals(this, vals1, vals2, norm) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: vals1(:) - real(DP), intent(in) :: vals2(:) - real(DP), intent(in), optional :: norm - - ! --- - - real(DP) :: n - - ! --- - - if (present(norm)) then - n = norm - else - n = 1.0_DP - endif - - call histogram2d_add_linear_vals(this, vals1, vals2, n) - -! call histogram2d_add_linear_vals(this, vals, n) - - endsubroutine histogram2d_add_vals - - - !********************************************************************** - ! Add a list of values to the histogram2d - !********************************************************************** - subroutine histogram2d_add_vals_mask(this, vals1, vals2, mask) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: vals1(:) - real(DP), intent(in) :: vals2(:) - logical, intent(in) :: mask(:) - - ! --- - - integer :: i - - ! --- - - do i = lbound(vals1, 1), ubound(vals1, 1) - if (mask(i)) then - call histogram2d_add_linear(this, vals1(i), vals2(i), 1.0_DP) - endif - enddo - - endsubroutine histogram2d_add_vals_mask - - - !********************************************************************** - ! Add a list of values to the histogram2d - !********************************************************************** - subroutine histogram2d_add_vals_norms(this, vals1, vals2, norms) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: vals1(:) - real(DP), intent(in) :: vals2(:) - real(DP), intent(in) :: norms(:) - - ! --- - - integer :: i - - ! --- - - do i = lbound(vals1, 1), ubound(vals1, 1) - call histogram2d_add_linear(this, vals1(i), vals2(i), norms(i)) - enddo - -! call histogram2d_add_linear_vals_norms(this, vals, norms) - - endsubroutine histogram2d_add_vals_norms - - - !********************************************************************** - ! Add a list of values to the histogram2d - !********************************************************************** - subroutine histogram2d_add_vals_norm_mask(this, vals1, vals2, norm, mask) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: vals1(:) - real(DP), intent(in) :: vals2(:) - real(DP), intent(in) :: norm - logical, intent(in) :: mask(:) - - ! --- - - integer :: i - - ! --- - - do i = lbound(vals1, 1), ubound(vals1, 1) - if (mask(i)) then - call histogram2d_add_linear(this, vals1(i), vals2(i), norm) - endif - enddo - -! call histogram2d_add_linear_vals_norm_mask(this, vals, norm, mask) - - endsubroutine histogram2d_add_vals_norm_mask - - - !********************************************************************** - ! Add a list of values to the histogram2d - !********************************************************************** - subroutine histogram2d_add_vals_norms_mask(this, vals1, vals2, norms, mask) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: vals1(:) - real(DP), intent(in) :: vals2(:) - real(DP), intent(in) :: norms(:) - logical, intent(in) :: mask(:) - - ! --- - - integer :: i - - ! --- - - do i = lbound(vals1, 1), ubound(vals1, 1) - if (mask(i)) then - call histogram2d_add_linear(this, vals1(i), vals2(i), norms(i)) - endif - enddo - -! call histogram2d_add_linear_vals_norms_mask(this, vals, norms, mask) - - endsubroutine histogram2d_add_vals_norms_mask - - - !********************************************************************** - ! Add a list of values to the histogram2d - !********************************************************************** - subroutine histogram2d_add_histogram2d(this, that, fac) - implicit none - - type(histogram2d_t), intent(inout) :: this - type(histogram2d_t), intent(in) :: that - real(DP), intent(in), optional :: fac - - ! --- - - this%h1 = this%h1 + that%h1 - if (present(fac)) then - this%h = this%h + fac*that%h - else - this%h = this%h + that%h - endif - - endsubroutine histogram2d_add_histogram2d - - - !********************************************************************** - ! Compute average value in each bin (does only makes sense if - ! norm != 1 was used in the add functions) - !********************************************************************** - elemental subroutine histogram2d_average(this) - implicit none - - type(histogram2d_t), intent(inout) :: this - - ! --- - - where (this%h1 == 0) - this%h1 = 1 - endwhere - - this%h = this%h / this%h1 - - endsubroutine histogram2d_average - - - !********************************************************************** - ! Multiply the histogram2d by a value - for normalization - !********************************************************************** - subroutine histogram2d_mul(this, val) - implicit none - - type(histogram2d_t), intent(inout) :: this - real(DP), intent(in) :: val - - ! --- - - this%h = this%h * val - - endsubroutine histogram2d_mul - - - !********************************************************************** - ! Multiply the histogram2d by a value - for normalization - !********************************************************************** - subroutine histogram2ds_mul(this, val) - implicit none - - type(histogram2d_t), intent(inout) :: this(:) - real(DP), intent(in) :: val - - ! --- - - integer :: i - - ! --- - - do i = lbound(this, 1), ubound(this, 1) - this(i)%h = this(i)%h * val - enddo - - endsubroutine histogram2ds_mul - - - !********************************************************************** - ! Multiply the histogram2d by a value - for normalization - !********************************************************************** - subroutine histogram2ds2_mul(this, val) - implicit none - - type(histogram2d_t), intent(inout) :: this(:, :) - real(DP), intent(in) :: val - - ! --- - - integer :: i, j - - ! --- - - do i = lbound(this, 1), ubound(this, 1) - do j = lbound(this, 2), ubound(this, 2) - this(i, j)%h = this(i, j)%h * val - enddo - enddo - - endsubroutine histogram2ds2_mul - - - !********************************************************************** - ! Normalize histogram2d - !********************************************************************** - elemental subroutine histogram2d_normalize(this) - implicit none - - type(histogram2d_t), intent(inout) :: this - - ! --- - - real(DP) :: n - - ! --- - - n = sum(this%h*this%dbin(1)*this%dbin(2)) - - if (n /= 0.0_DP) then - this%h = this%h / n - endif - - endsubroutine histogram2d_normalize - - - !********************************************************************** - ! OpenMP reduction - *thpriv* is a threadprivate histogram, - ! this needs to be called within an *omp parallel* construct. - !********************************************************************** - elemental subroutine histogram2d_reduce(this, thpriv) - implicit none - - type(histogram2d_t), intent(inout) :: this - type(histogram2d_t), intent(in) :: thpriv - - ! --- - - !$omp single - call init(this, thpriv) - !$omp end single - - !$omp critical - this%h = this%h + thpriv%h - this%h1 = this%h1 + thpriv%h1 - !$omp end critical - - endsubroutine histogram2d_reduce - - - !********************************************************************** - ! Memory estimate logging - !********************************************************************** - subroutine log_memory_estimate_histogram2d(this) - implicit none - - type(histogram2d_t), intent(in) :: this - - ! --- - - call log_memory_estimate(this%x1) - call log_memory_estimate(this%x2) - call log_memory_estimate(this%h) - call log_memory_estimate(this%h1) - - endsubroutine log_memory_estimate_histogram2d - - - !********************************************************************** - ! Memory estimate logging - !********************************************************************** - subroutine log_memory_estimate_histogram2d2(this) - implicit none - - type(histogram2d_t), intent(in) :: this(:) - - ! --- - - integer :: i - - ! --- - - do i = lbound(this, 1), ubound(this, 1) - call log_memory_estimate_histogram2d(this(i)) - enddo - - endsubroutine log_memory_estimate_histogram2d2 - - - !********************************************************************** - ! Memory estimate logging - !********************************************************************** - subroutine log_memory_estimate_histogram2d3(this) - implicit none - - type(histogram2d_t), intent(in) :: this(:, :) - - ! --- - - integer :: i, j - - ! --- - - do j = lbound(this, 2), ubound(this, 2) - do i = lbound(this, 1), ubound(this, 1) - call log_memory_estimate_histogram2d(this(i, j)) - enddo - enddo - - endsubroutine log_memory_estimate_histogram2d3 - -endmodule histogram2d_module diff --git a/src/libAtoms/k_means_clustering.f95 b/src/libAtoms/k_means_clustering.f95 deleted file mode 100644 index 1884e0b676..0000000000 --- a/src/libAtoms/k_means_clustering.f95 +++ /dev/null @@ -1,245 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module k_means_clustering_module -implicit none -private - - integer, parameter :: dp = 8 - - public :: k_means_clustering_pick - interface k_means_clustering_pick - module procedure k_means_clustering_pick_1d, k_means_clustering_pick_nd - end interface - -contains - - subroutine k_means_clustering_pick_1d(x, periodicity, cluster_indices) - real(dp), intent(in) :: x(:) - real(dp), intent(in) :: periodicity - integer, intent(out) :: cluster_indices(:) - - integer :: k - real(dp), allocatable :: k_means(:) - integer :: n, rv, i, j, closest_i, closest_j - real(dp) :: rrv - real(dp) :: closest_r, r, t_sum - integer, allocatable :: a(:), prev_a(:) - - k = size(cluster_indices) - n = size(x) - allocate(k_means(k)) - - ! random initial guess - cluster_indices = 0 - do i=1, k - call random_number(rrv); rv = 1+floor(rrv*n) - do while (any(cluster_indices == rv)) - call random_number(rrv); rv = 1+floor(rrv*n) - end do - cluster_indices(i) = rv - end do - k_means = x(cluster_indices) - - allocate(a(n), prev_a(n)) - - ! evaluate initial assignments - do j=1, n - closest_i = 0 - closest_r = HUGE(1.0_dp) - do i=1, k - r = dist((/x(j)/), (/k_means(i)/), (/periodicity/)) - if (r < closest_r) then - closest_r = r - closest_i = i - endif - end do - a(j) = closest_i - end do - - prev_a = 0 - do while (any(a /= prev_a)) - prev_a = a - - ! update positions - do i=1, k - t_sum = 0.0_dp - do j=1, n - if (a(j) == i) t_sum = t_sum + x(j) - end do - k_means(i) = t_sum / real(count(a == i),dp) - end do - - ! update assignments - do j=1, n - closest_i = 0 - closest_r = HUGE(1.0_dp) - do i=1, k - r = dist((/x(j)/), (/k_means(i)/), (/periodicity/)) - if (r < closest_r) then - closest_r = r - closest_i = i - endif - end do - a(j) = closest_i - end do - end do - - do i=1, k - closest_i = 0 - closest_r = HUGE(1.0_dp) - do j=1, n - r = dist((/x(j)/), (/k_means(i)/), (/periodicity/)) - if (r < closest_r) then - closest_r = r - closest_j = j - endif - end do - cluster_indices(i) = closest_j - end do - - deallocate(a, prev_a, k_means) - - end subroutine k_means_clustering_pick_1d - - subroutine k_means_clustering_pick_nd(x, periodicity, cluster_indices) - real(dp), intent(in) :: x(:,:) - real(dp), intent(in) :: periodicity(:) - integer, intent(out) :: cluster_indices(:) - - integer :: k - real(dp), allocatable :: k_means(:,:) - integer :: n, rv, i, j, closest_i, closest_j, nd - real(dp) :: rrv - real(dp) :: closest_r, r, t_sum(size(x,1)) - integer, allocatable :: a(:), prev_a(:) - - k = size(cluster_indices) - n = size(x,2) - nd = size(x,1) - allocate(k_means(nd,k)) - - ! random initial guess - cluster_indices = 0 - do i=1, k - call random_number(rrv); rv = 1+floor(rrv*n) - do while (any(cluster_indices == rv)) - call random_number(rrv); rv = 1+floor(rrv*n) - end do - cluster_indices(i) = rv - end do - k_means(:,:) = x(:,cluster_indices(:)) - - allocate(a(n), prev_a(n)) - - ! evaluate initial assignments - do j=1, n - closest_i = 0 - closest_r = HUGE(1.0_dp) - do i=1, k - r = dist(x(:,j), k_means(:,i), periodicity(:)) - if (r < closest_r) then - closest_r = r - closest_i = i - endif - end do - a(j) = closest_i - end do - - prev_a = 0 - do while (any(a /= prev_a)) - prev_a = a - - ! update positions - do i=1, k - t_sum = 0.0_dp - do j=1, n - if (a(j) == i) t_sum(:) = t_sum(:) + x(:,j) - end do - k_means(:,i) = t_sum(:) / real(count(a == i),dp) - end do - - ! update assignments - do j=1, n - closest_i = 0 - closest_r = HUGE(1.0_dp) - do i=1, k - r = dist(x(:,j), k_means(:,i), periodicity(:)) - if (r < closest_r) then - closest_r = r - closest_i = i - endif - end do - a(j) = closest_i - end do - end do - - do i=1, k - closest_i = 0 - closest_r = HUGE(1.0_dp) - do j=1, n - r = dist(x(:,j), k_means(:,i), periodicity(:)) - if (r < closest_r) then - closest_r = r - closest_j = j - endif - end do - cluster_indices(i) = closest_j - end do - - deallocate(a, prev_a, k_means) - - end subroutine k_means_clustering_pick_nd - - ! from BRUSH paper, citing MacKay - function dist(x0, x1, periodicity) - real(dp), intent(in) :: x0(:), x1(:) - real(dp), intent(in) :: periodicity(:) - real(dp) :: dist ! result - - integer :: i - - if (any(periodicity /= 0.0_dp)) then - dist = 0.0_dp - do i=1, size(x0) - if (periodicity(i) /= 0.0_dp) then - dist = dist + 4.0_dp*sin((2.0_dp*3.14159265358979_dp/periodicity(i))*(x0(i)-x1(i))/2.0_dp)**2 - else - dist = dist + (x0(i)-x1(i))**2 - endif - end do - dist = sqrt(dist) - else - dist = sqrt(sum((x0(:)-x1(:))**2)) - endif - - end function dist - -end module k_means_clustering_module diff --git a/src/libAtoms/kind_module.f95 b/src/libAtoms/kind_module.f95 deleted file mode 100644 index 095d6439a3..0000000000 --- a/src/libAtoms/kind_module.f95 +++ /dev/null @@ -1,25 +0,0 @@ -module kind_module - - implicit none - - integer, parameter, public :: isp = selected_int_kind(9) - integer, parameter, public :: idp = selected_int_kind(18) - integer, parameter, public :: iwp = kind(isp) - -#ifdef QUAD_PRECISION - integer, parameter, public :: dp = 16 -#elsif TEN_DIGIT_PRECISION - integer, parameter, public :: dp = selected_real_kind(10) -#else - integer, parameter, public :: dp = 8 -#endif - -#ifdef HAVE_QP - integer, parameter, public :: qp = 16 -#elsif TEN_DIGIT_PRECISION - integer, parameter, public :: qp = selected_real_kind(10) -#else - integer, parameter, public :: qp = 8 -#endif - -end module kind_module diff --git a/src/libAtoms/libAtoms.f95 b/src/libAtoms/libAtoms.f95 deleted file mode 100644 index 6dd9b0b2c9..0000000000 --- a/src/libAtoms/libAtoms.f95 +++ /dev/null @@ -1,78 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X libAtoms module -!X -!% This is a container module, "use" it if you want to use libatoms stuff: -!%> use libAtoms_module -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module libAtoms_module - use error_module - use system_module - use linkedlist_module - use MPI_context_module - use units_module - use linearalgebra_module - use minimization_module - use extendable_str_module - use dictionary_module - use table_module - use spline_module - use sparse_module - use periodictable_module - use cinoutput_module - use paramreader_module - use atoms_types_module - use connection_module - use atoms_module - use quaternions_module - use rigidbody_module - use steinhardt_nelson_qw_module - use constraints_module - use thermostat_module - use barostat_module - use dynamicalsystem_module - use clusters_module - use structures_module - use frametools_module - use nye_tensor_module - use Topology_module - use atoms_ll_module - use ringstat_module - use histogram1d_module - use domaindecomposition_module - use k_means_clustering_module - use SocketTools_module - use partition_module -end module libAtoms_module diff --git a/src/libAtoms/libAtoms_misc_utils.f95 b/src/libAtoms/libAtoms_misc_utils.f95 deleted file mode 100644 index 8c14b8dcfe..0000000000 --- a/src/libAtoms/libAtoms_misc_utils.f95 +++ /dev/null @@ -1,56 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module libatoms_misc_utils_module -use libatoms_module -implicit none -private - -public :: dipole_moment - -contains - -function dipole_moment(pos, net_charge) - real(dp), intent(in) :: pos(:,:), net_charge(:) - real(dp) :: dipole_moment(size(pos,1)) - - integer :: i - - if (size(pos,2) /= size(net_charge)) & - call system_abort("dipole_moment called with incompatible size(pos) " // size(pos) //& - ", size(net_charge) " // size(net_charge)) - - dipole_moment = 0.0_dp - do i=1, size(pos,1) - dipole_moment(:) = dipole_moment(:) - pos(:,i)*net_charge(i) - end do -end function dipole_moment - -end module libatoms_misc_utils_module diff --git a/src/libAtoms/libAtoms_utils_no_module.f95 b/src/libAtoms/libAtoms_utils_no_module.f95 deleted file mode 100644 index 46f319e53f..0000000000 --- a/src/libAtoms/libAtoms_utils_no_module.f95 +++ /dev/null @@ -1,409 +0,0 @@ -#include "error.inc" - -subroutine lattice_abc_to_xyz(cell_lengths, cell_angles, lattice) - use system_module - use atoms_module - implicit none - real(dp), intent(in) :: cell_lengths(3), cell_angles(3) - real(dp), intent(out) :: lattice(3,3) - - lattice = make_lattice(cell_lengths(1), cell_lengths(2), cell_lengths(3), & - cell_angles(1), cell_angles(2), cell_angles(3)) - -end subroutine lattice_abc_to_xyz - -subroutine lattice_xyz_to_abc(lattice, cell_lengths, cell_angles) - use system_module - use atoms_module - implicit none - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(out) :: cell_lengths(3), cell_angles(3) - - call get_lattice_params(lattice, cell_lengths(1), cell_lengths(2), cell_lengths(3), & - cell_angles(1), cell_angles(2), cell_angles(3)) - -end subroutine lattice_xyz_to_abc - -subroutine c_system_initialise(verbosity) - use system_module - implicit none - integer verbosity - - call system_initialise(verbosity) - -end subroutine c_system_initialise - -function quippy_running() - use system_module, only: get_quippy_running - implicit none - logical quippy_running - quippy_running = get_quippy_running() -end function quippy_running - -! Error handling routines callable from C - -subroutine c_push_error_with_info(doc, fn, line, kind) - use error_module - implicit none - character(*), intent(in) :: doc - character(*), intent(in) :: fn - integer, intent(in) :: line - integer, intent(in), optional :: kind - - call push_error_with_info(doc, fn, line, kind) - -end subroutine c_push_error_with_info - -subroutine c_push_error(fn, line, kind) - use error_module - implicit none - - character(*), intent(in) :: fn - integer, intent(in) :: line - integer, intent(in), optional :: kind - - call push_error(fn, line, kind) - -end subroutine c_push_error - -subroutine c_error_abort(error) - use error_module - implicit none - integer, intent(inout), optional :: error - - call error_abort(error) -end subroutine c_error_abort - -subroutine c_error_clear_stack() - use error_module - implicit none - call error_clear_stack -end subroutine c_error_clear_stack - - -! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! -! Dictionary routines callable from C -! -! Routines used by CInOutput to manipulate Fortran Dictionary objects from C. -! -! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine c_dictionary_initialise(this) - use dictionary_module - implicit none - integer, intent(inout) :: this(12) - type(c_dictionary_ptr_type) :: this_ptr - - allocate(this_ptr%p) - call initialise(this=this_ptr%p) - this = transfer(this_ptr, this) - -end subroutine c_dictionary_initialise - -subroutine c_dictionary_finalise(this) - use dictionary_module - implicit none - integer, intent(in) :: this(12) - type(c_dictionary_ptr_type) :: this_ptr - - this_ptr = transfer(this, this_ptr) - call finalise(this=this_ptr%p) - deallocate(this_ptr%p) - -end subroutine c_dictionary_finalise - -subroutine c_dictionary_get_n(this, n) - use dictionary_module - implicit none - integer, intent(in) :: this(12) - integer, intent(out) :: n - type(c_dictionary_ptr_type) :: this_ptr - - this_ptr = transfer(this, this_ptr) - n = this_ptr%p%n - -end subroutine c_dictionary_get_n - -subroutine c_dictionary_get_key(this, i, key, length, error) - use error_module - use dictionary_module - implicit none - integer, intent(in) :: this(12), i - character(len=*), intent(out) :: key - integer, intent(out), optional :: length, error - type(c_dictionary_ptr_type) :: this_ptr - - INIT_ERROR(error) - length = 0 - this_ptr = transfer(this, this_ptr) - call dictionary_get_key(this_ptr%p, i, key, error) - PASS_ERROR(error) - length = len_trim(key) - -end subroutine c_dictionary_get_key - -subroutine c_dictionary_query_key(this, key, type, dshape, dloc, error) - - use error_module - use dictionary_module - use iso_c_binding, only: c_intptr_t - - use extendable_str_module - use system_module - implicit none - -#ifdef __GFORTRAN__ - INTERFACE - subroutine c_dictionary_query_index(this, entry_i, key, type, dshape, dloc, error) - use iso_c_binding, only: c_intptr_t - integer, intent(in) :: this(12) - integer, intent(in) :: entry_i - character(len=*), intent(out) :: key - integer, intent(out) :: type - integer, dimension(2), intent(out) :: dshape - integer(c_intptr_t), intent(out) :: dloc - integer, intent(out), optional :: error - end subroutine c_dictionary_query_index - END INTERFACE -#endif - - integer, intent(in) :: this(12) - character(len=*), intent(inout) :: key - integer, intent(out) :: type - integer, dimension(2), intent(out) :: dshape - integer(c_intptr_t), intent(out) :: dloc - integer, intent(out), optional :: error - - integer entry_i - type(c_dictionary_ptr_type) :: this_ptr - - INIT_ERROR(error) - this_ptr = transfer(this, this_ptr) - - entry_i = lookup_entry_i(this_ptr%p, key) - if (entry_i <= 0) then - RAISE_ERROR('c_dictionary_query_key: key '//trim(key)//' not found', error) - end if - call c_dictionary_query_index(this, entry_i, key, type, dshape, dloc, error) - PASS_ERROR(error) - -end subroutine c_dictionary_query_key - -subroutine c_dictionary_query_index(this, entry_i, key, type, dshape, dloc, error) - use error_module - use extendable_str_module - use system_module - use dictionary_module - use iso_c_binding, only: c_intptr_t - integer, intent(in) :: this(12) - integer, intent(in) :: entry_i - character(len=*), intent(out) :: key - integer, intent(out) :: type - integer, dimension(2), intent(out) :: dshape - integer(c_intptr_t), intent(out) :: dloc - integer, intent(out), optional :: error - - type(c_dictionary_ptr_type) :: this_ptr - - INIT_ERROR(error) - this_ptr = transfer(this, this_ptr) - - type = 0 - dshape(:) = 0 - dloc = 0 - - if (entry_i <= 0 .or. entry_i > this_ptr%p%N) then - RAISE_ERROR('c_dictionary_query_index: entry_i = '//entry_i//' outside range 1 < entry_i <= '//this_ptr%p%N, error) - end if - - type = this_ptr%p%entries(entry_i)%type - key = string(this_ptr%p%keys(entry_i)) - - select case(this_ptr%p%entries(entry_i)%type) - case(T_NONE) - dloc = 0 - return - - case(T_INTEGER) - dloc = loc(this_ptr%p%entries(entry_i)%i) - - case(T_REAL) - dloc = loc(this_ptr%p%entries(entry_i)%r) - - case(T_COMPLEX) - dloc = loc(this_ptr%p%entries(entry_i)%c) - - case(T_CHAR) - dshape(1) = this_ptr%p%entries(entry_i)%s%len - dloc = loc(this_ptr%p%entries(entry_i)%s%s) - - case(T_LOGICAL) - dloc = loc(this_ptr%p%entries(entry_i)%l) - - case(T_INTEGER_A) - dshape(1) = size(this_ptr%p%entries(entry_i)%i_a) - dloc = loc(this_ptr%p%entries(entry_i)%i_a) - - case(T_REAL_A) - dshape(1) = size(this_ptr%p%entries(entry_i)%r_a) - dloc = loc(this_ptr%p%entries(entry_i)%r_a) - - case(T_COMPLEX_A) - dshape(1) = size(this_ptr%p%entries(entry_i)%c_a) - dloc = loc(this_ptr%p%entries(entry_i)%c_a) - - case(T_LOGICAL_A) - dshape(1) = size(this_ptr%p%entries(entry_i)%l_a) - dloc = loc(this_ptr%p%entries(entry_i)%l_a) - - case(T_CHAR_A) - dshape(1) = size(this_ptr%p%entries(entry_i)%s_a,1) - dshape(2) = size(this_ptr%p%entries(entry_i)%s_a,2) - dloc = loc(this_ptr%p%entries(entry_i)%s_a) - - case(T_INTEGER_A2) - dshape(1) = size(this_ptr%p%entries(entry_i)%i_a2, 1) - dshape(2) = size(this_ptr%p%entries(entry_i)%i_a2, 2) - dloc = loc(this_ptr%p%entries(entry_i)%i_a2) - - case(T_REAL_A2) - dshape(1) = size(this_ptr%p%entries(entry_i)%r_a2, 1) - dshape(2) = size(this_ptr%p%entries(entry_i)%r_a2, 2) - dloc = loc(this_ptr%p%entries(entry_i)%r_a2) - - case(T_DATA) - ! not supported - dloc = 0 - RAISE_ERROR('c_dictionary_query_index: data type T_DATA not supported.', error) - - end select - -end subroutine c_dictionary_query_index - -subroutine c_dictionary_add_key(this, key, type, dshape, loc, error) - use system_module - use error_module - use dictionary_module - use iso_c_binding, only: c_intptr_t - implicit none - -#ifdef __GFORTRAN__ - INTERFACE - subroutine c_dictionary_query_key(this, key, type, dshape, dloc, error) - - use error_module - use dictionary_module - use iso_c_binding, only: c_intptr_t - - use extendable_str_module - use system_module - - integer, intent(in) :: this(12) - character(len=*), intent(inout) :: key - integer, intent(out) :: type - integer, dimension(2), intent(out) :: dshape - integer(c_intptr_t), intent(out) :: dloc - integer, intent(out), optional :: error - - end subroutine c_dictionary_query_key - END INTERFACE -#endif - - integer, intent(in) :: this(12) - character(len=*), intent(inout) :: key - integer, intent(in) :: type - integer, intent(in) :: dshape(2) - integer(c_intptr_t), intent(out) :: loc - integer, intent(out), optional :: error - - type(c_dictionary_ptr_type) this_ptr - integer mytype, mydshape(2), tmp_error - - INIT_ERROR(error) - mytype = -1 - mydshape(:) = -1 - - ! check if a compatiable entry already exists - tmp_error = 0 - call c_dictionary_query_key(this, key, mytype, mydshape, loc, tmp_error) - CLEAR_ERROR(tmp_error) - if (tmp_error == 0 .and. type == mytype .and. all(dshape == mydshape)) then - return - end if - - ! otherwise we need to add a new entry - this_ptr = transfer(this, this_ptr) - select case(type) - case(T_NONE) - call set_value(this_ptr%p, key) - - case(T_INTEGER) - call set_value(this_ptr%p, key, 0) - - case(T_REAL) - call set_value(this_ptr%p, key, 0.0_dp) - - case(T_COMPLEX) - call set_value(this_ptr%p, key, (0.0_dp, 0.0_dp)) - - case(T_CHAR) - call set_value(this_ptr%p, key, repeat('X', dshape(1))) - - case(T_LOGICAL) - call set_value(this_ptr%p, key, .false.) - - case(T_INTEGER_A) - call add_array(this_ptr%p, key, 0, dshape(1)) - - case(T_REAL_A) - call add_array(this_ptr%p, key, 0.0_dp, dshape(1)) - - case(T_COMPLEX_A) - call add_array(this_ptr%p, key, 0.0_dp, dshape(1)) - - case(T_LOGICAL_A) - call add_array(this_ptr%p, key, .false., dshape(1)) - - case(T_CHAR_A) - call add_array(this_ptr%p, key, ' ', dshape) - - case(T_INTEGER_A2) - call add_array(this_ptr%p, key, 0, dshape) - - case(T_REAL_A2) - call add_array(this_ptr%p, key, 0.0_dp, dshape) - - case default - RAISE_ERROR('c_dictionary_add_key: unknown data type '//type, error) - - end select - - ! Finally, update 'loc' pointer - call c_dictionary_query_key(this, key, mytype, mydshape, loc, error) - PASS_ERROR(error) - -end subroutine c_dictionary_add_key - -subroutine c_extendable_str_concat(this, str, keep_lf, add_lf_if_missing) - use extendable_str_module - type c_extendable_str_ptr_type - type(Extendable_str), pointer :: p - end type c_extendable_str_ptr_type - integer, intent(in) :: this(12) - character(*), intent(in) :: str - integer, intent(in) :: keep_lf, add_lf_if_missing - - type(c_extendable_str_ptr_type) :: this_ptr - logical do_keep_lf, do_add_lf_if_missing - - do_keep_lf = .false. - if (keep_lf == 1) do_keep_lf = .true. - do_add_lf_if_missing = .false. - if (add_lf_if_missing == 1) do_add_lf_if_missing = .true. - - this_ptr = transfer(this, this_ptr) - call concat(this_ptr%p, str, do_keep_lf, do_add_lf_if_missing) - -end subroutine c_extendable_str_concat - diff --git a/src/libAtoms/linearalgebra.f95 b/src/libAtoms/linearalgebra.f95 deleted file mode 100644 index bde758a04a..0000000000 --- a/src/libAtoms/linearalgebra.f95 +++ /dev/null @@ -1,7677 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Linear algebra module -!X -!% This is a general purpose linear algebra module, extending -!% the Fortran intrinsics -!% This module defines dot products between matrices and vectors, -!% wrappers to \textsc{lapack} for matrix diagonalisation and inversion, -!% as well as array searching, sorting and averaging. -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module linearalgebra_module - use error_module - use system_module - use units_module - implicit none - private - SAVE - - real(dp), parameter :: factorial_table(0:20) = (/& - 1.0_dp, & - 1.0_dp, & - 2.0_dp, & - 6.0_dp, & - 24.0_dp, & - 120.0_dp, & - 720.0_dp, & - 5040.0_dp, & - 40320.0_dp, & - 362880.0_dp, & - 3628800.0_dp, & - 39916800.0_dp, & - 479001600.0_dp, & - 6227020800.0_dp, & - 87178291200.0_dp, & - 1307674368000.0_dp, & - 20922789888000.0_dp, & - 355687428096000.0_dp, & - 6402373705728000.0_dp, & - 121645100408832000.0_dp, & - 2432902008176640000.0_dp/) - public :: factorial, factorial_int, factorial2, binom, oscillate - - real(dp), public, parameter :: TOL_SVD = 1e-13_dp - - public :: cos_cutoff_function, dcos_cutoff_function - - interface coordination_function - module procedure coordination_function_upper, coordination_function_lower_upper - endinterface coordination_function - public :: coordination_function - - interface dcoordination_function - module procedure dcoordination_function_upper, dcoordination_function_lower_upper - endinterface dcoordination_function - public :: dcoordination_function - - interface d2coordination_function - module procedure d2coordination_function_upper - endinterface d2coordination_function - public :: d2coordination_function - - interface d3coordination_function - module procedure d3coordination_function_upper - endinterface d3coordination_function - public :: d3coordination_function - - public :: la_matrix, la_matrix_factorise, la_matrix_qr_factorise, LA_Matrix_QR_Solve_Vector, la_matrix_logdet, la_matrix_qr_inverse, la_matrix_inverse, LA_Matrix_Expand_Symmetrically, la_matrix_svd, la_matrix_svd_allocate, la_matrix_pseudoinverse - - public :: initialise, assignment(=), finalise, matrix_solve, matrix_qr_solve, find, sign - public :: operator(.feq.), operator(.fne.), operator(.fgt.), operator(.fle.), operator(.flt.), operator(.fge.) - public :: norm, normsq, operator(.mult.), operator(.dot.) - public :: frobenius_norm - public :: heap_sort, is_orthogonal, find_in_array, is_in_array, trace, trace_mult, diag - public :: ran_normal3, matrix_exp, matrix3x3_det, matrix3x3_inverse, operator(.outer.), operator(.cross.) - public :: check_size, sort_array, trapezoidintegral, print, print_mathematica, int_array_ge, int_array_gt, int_array_lt - public :: angle, unit_vector, random_unit_vector, arrays_lt, is_symmetric, permutation_symbol - public :: diagonalise, nonsymmetric_diagonalise, uniq, find_indices, inverse, pseudo_inverse, matrix_product_sub, matrix_product_vect_asdiagonal_sub, matrix_mvmt - public :: add_identity, linear_interpolate, cubic_interpolate, pbc_aware_centre, randomise, zero_sum - public :: insertion_sort, update_exponential_average, least_squares, scalar_triple_product, inverse_svd_threshold, svdfact - public :: fit_cubic, symmetrise, symmetric_linear_solve, matrix_product_vect_asdiagonal_RL_sub, matrix_condition_number - public :: rms_diff, histogram, kmeans, round_prime_factors, binary_search, apply_function_matrix, invsqrt_real_array1d, fill_random_integer - public :: poly_switch, dpoly_switch, d2poly_switch, d3poly_switch - public :: is_diagonal, integerDigits - public :: make_hermitian - - logical :: use_intrinsic_blas = .false. - !% If set to true, use internal routines instead of \textsc{blas} calls for matrix - !% multiplication. Can be changed at runtime. The default is true. - integer, parameter :: NOT_FACTORISED = 0 - integer, parameter :: CHOLESKY = 1 - integer, parameter :: QR = 2 - - type LA_Matrix - real(qp), dimension(:,:), pointer :: matrix - real(qp), dimension(:,:), allocatable :: factor - real(qp), dimension(:), allocatable :: s, tau - integer :: n, m - logical :: use_allocate = .true. - logical :: initialised = .false. - logical :: equilibrated = .false. - integer :: factorised = NOT_FACTORISED - contains - final :: LA_Matrix_Finalise - endtype LA_Matrix - - interface Initialise - module procedure LA_Matrix_Initialise - endinterface Initialise - - interface assignment(=) - module procedure LA_Matrix_Initialise_Matrix - module procedure LA_Matrix_Initialise_Copy - end interface assignment(=) - - interface Finalise - module procedure LA_Matrix_Finalise - endinterface Finalise - - interface Matrix_Solve - module procedure LA_Matrix_Solve_Vector, LA_Matrix_Solve_Matrix - endinterface Matrix_Solve - - interface Matrix_QR_Solve - module procedure LA_Matrix_QR_Solve_Vector, LA_Matrix_QR_Solve_Matrix, Fixed_LA_Matrix_QR_Solve_Vector - endinterface Matrix_QR_Solve - - interface find - module procedure find_indices - end interface - - interface sign - module procedure int_sign, real_sign - end interface - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Interfaces to mathematical operations -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Construct a diagonal matrix from a vector, or extract the diagonal elements - !% of a matrix and return them as a vector. - ! matrix = diag(vector) , vector = diag(matrix) - private :: matrix_diagonal_r, matrix_diagonal_c, vector_as_diag_matrix_r, vector_as_diag_matrix_c - interface diag - module procedure matrix_diagonal_r, matrix_diagonal_c, vector_as_diag_matrix_r, vector_as_diag_matrix_c - end interface - - !% Heavily overloaded interface to print matrices and vectors of reals, complex numbers or integers. - private :: matrix_print_mainlog, matrix_print, vector_print_mainlog, vector_print - private :: matrix_z_print_mainlog, matrix_z_print, vector_z_print_mainlog, vector_z_print - private :: int_matrix_print_mainlog, int_matrix_print - private :: logical_matrix_print_mainlog, logical_matrix_print - private :: integer_array_print, integer_array_print_mainlog, logical_array_print, logical_array_print_mainlog - interface print - module procedure matrix_print_mainlog, matrix_print, vector_print_mainlog, vector_print - module procedure matrix_z_print_mainlog, matrix_z_print, vector_z_print_mainlog, vector_z_print - module procedure integer_array_print, integer_array_print_mainlog, logical_array_print_mainlog - module procedure int_matrix_print_mainlog, int_matrix_print, logical_array_print - module procedure logical_matrix_print_mainlog, logical_matrix_print - end interface - - private :: matrix_z_print_mathematica, matrix_print_mathematica - interface print_mathematica - module procedure matrix_z_print_mathematica, matrix_print_mathematica - end interface print_mathematica - - ! matrix*matrix , matrix*vector - !% Overloaded multiplication for matrix $\times$ matrix and matrix $\times$ vector. - !% Use as 'C = A .mult. B' for matrices and 'C = A .mult. v' for a matrix times a vector. - private :: matrix_product_vect, matrix_product_ddd, matrix_product_int_vect, matrix_product_zzz - private :: matrix_product_int_mat - interface operator(.mult.) - module procedure matrix_product_vect, matrix_product_ddd, matrix_product_int_vect, matrix_product_zzz - module procedure matrix_product_int_mat - end interface - !% Interface for routines that want function to be called 'matrix_product()' - interface matrix_product - module procedure matrix_product_ddd - end interface - - !% Overloaded multiplication for matrix $\times$ matrix in subroutine form, - !% with no return value allocated on the stack - interface matrix_product_sub - module procedure matrix_product_sub_ddd, matrix_product_sub_zzz, matrix_vector_product_sub_ddd - end interface - - ! matrix*diag(vector) - !% Matrix product with the diagonal matrix constructed from a vector. For example, - !% 'B = A .multd. d' is equivalent to 'B = A .mult. diag(d)' - private :: matrix_product_vect_asdiagonal_dd, matrix_product_vect_asdiagonal_zz - interface operator(.multd.) - module procedure matrix_product_vect_asdiagonal_dd, matrix_product_vect_asdiagonal_zz - end interface - - !% Matrix product with the diagonal matrix constructed from a vector in subroutine form, - !% with no return value allocated on the stack -#ifdef HAVE_QP - private :: matrix_product_vect_asdiagonal_sub_qqq -#endif - private :: matrix_product_vect_asdiagonal_sub_ddd - private :: matrix_product_vect_asdiagonal_sub_zzd - private :: matrix_product_vect_asdiagonal_sub_zdz - private :: matrix_product_vect_asdiagonal_sub_zzz - private :: vect_asdiagonal_product_matrix_sub_ddd - private :: vect_asdiagonal_product_matrix_sub_zzd - private :: vect_asdiagonal_product_matrix_sub_zdz - private :: vect_asdiagonal_product_matrix_sub_zzz - interface matrix_product_vect_asdiagonal_sub -#ifdef HAVE_QP - module procedure matrix_product_vect_asdiagonal_sub_qqq -#endif - module procedure matrix_product_vect_asdiagonal_sub_ddd - module procedure matrix_product_vect_asdiagonal_sub_zzd - module procedure matrix_product_vect_asdiagonal_sub_zdz - module procedure matrix_product_vect_asdiagonal_sub_zzz - module procedure vect_asdiagonal_product_matrix_sub_ddd - module procedure vect_asdiagonal_product_matrix_sub_zzd - module procedure vect_asdiagonal_product_matrix_sub_zdz - module procedure vect_asdiagonal_product_matrix_sub_zzz - end interface matrix_product_vect_asdiagonal_sub - - private :: matrix_product_vect_asdiagonal_RL_sub_ddd - private :: matrix_product_vect_asdiagonal_RL_sub_zzd - interface matrix_product_vect_asdiagonal_RL_sub - module procedure matrix_product_vect_asdiagonal_RL_sub_ddd - module procedure matrix_product_vect_asdiagonal_RL_sub_zzd - end interface matrix_product_vect_asdiagonal_RL_sub - - ! matrix*diag(vector)*matrix.t - !% Matrix product of matrix and a vector in the form: - !%> matrix * diag(vector) * transpose(matrix) - private :: matrix_cfct - interface matrix_mvmt - module procedure matrix_cfct - end interface - - ! vector.vector , matrix.matrix - !% Inner product of two vectors or two matrices. For two vectors $\mathbf{v}$ and - !% $\mathbf{w}$ this is simply: - !%\begin{displaymath} - !% d = \sum_{i=1}^N v_i w_i - !%\end{displaymath} - !% For $N \times M$ matrices $A$ and $B$ it is defined similarily: - !%\begin{displaymath} - !% d = \sum_{i=1}^N \sum_{j=1}^M A_{ij} B_{ij} - !%\end{displaymath} - private :: matrix_dotproduct_matrix,vector_dotpr - interface operator(.dot.) - module procedure matrix_dotproduct_matrix,vector_dotpr - end interface - - !% Floating point equality testing. Returns false if - !% '(abs(x-y) > NUMERICAL_ZERO * abs(x))', and true otherwise. - private :: real_feq,complex_feq,matrix_feq,vector_feq - interface operator(.feq.) - module procedure real_feq,real_integer_feq,integer_real_feq,complex_feq,matrix_feq,vector_feq - end interface - - !% Floating point inequality testing. - private :: real_fne,complex_fne,matrix_fne,vector_fne - interface operator(.fne.) - module procedure real_fne,complex_fne,matrix_fne,vector_fne - end interface - - private :: real_fge - interface operator(.fge.) - module procedure real_fge - end interface - - private :: real_fgt - interface operator(.fgt.) - module procedure real_fgt - end interface - - private :: real_fle - interface operator(.fle.) - module procedure real_fle - end interface - - private :: real_flt - interface operator(.flt.) - module procedure real_flt - end interface - - !% Overloaded interfaces to \textsc{lapack} matrix diagonlisation - !% functions for real and complex matrices. Always calls - !% \textsc{lapack}, regardless of the 'use_intrinsic_blas' setting. - !% Both diagonalisation and solution of the generalised eigenproblem - !% are supported, but only for real positive definite symmetric or - !% complex hermitian postive definite matrices. - private :: matrix_diagonalise, matrix_diagonalise_generalised - private :: matrix_z_diagonalise, matrix_z_diagonalise_generalised - interface diagonalise - module procedure matrix_diagonalise, matrix_diagonalise_generalised - module procedure matrix_z_diagonalise, matrix_z_diagonalise_generalised - end interface - - interface nonsymmetric_diagonalise - module procedure matrix_nonsymmetric_diagonalise - end interface - - !% Calculate the inverse of a matrix in-place. Uses \textsc{lapack} to compute the inverse. - interface inverse - module procedure matrix_inverse, matrix_z_inverse - end interface inverse - - !% Return the outer product of two vectors. Usage is 'x .outer. y'. - private :: outer, z_outer_zz - interface operator(.outer.) - module procedure outer, z_outer_zz -#ifdef HAVE_QP - module procedure outer_qq -#endif - end interface - - !% Interface to return the real outer product. Usage is 'x .realouter. y'. - private :: d_outer_zz - interface operator(.realouter.) - module procedure outer, d_outer_zz - end interface - - !% Cross product between two 3-vectors. Usage is 'x .cross. y'. - private :: cross_product - interface operator(.cross.) - module procedure cross_product - end interface - - !% Test for matrix symmetry (with floating point equality test '.feq.' as described above). - private :: matrix_is_symmetric, matrix_z_is_symmetric, int_matrix_is_symmetric - interface is_symmetric - module procedure matrix_is_symmetric, matrix_z_is_symmetric, int_matrix_is_symmetric - end interface is_symmetric - - !% Test for matrix hermiticity (with floating point equals test). - private :: matrix_z_is_hermitian - interface is_hermitian - module procedure matrix_z_is_hermitian - end interface - - !% Test for matrix hermiticity (with floating point equals test). - private :: matrix_z_make_hermitian, matrix_d_make_hermitian - interface make_hermitian - module procedure matrix_z_make_hermitian, matrix_d_make_hermitian - end interface - - !% Test if matrix is square - private :: matrix_square, matrix_z_square, int_matrix_square, logical_matrix_square - interface is_square - module procedure matrix_square, matrix_z_square, int_matrix_square, logical_matrix_square - end interface - public :: is_square - - !% Test is matrix is unitary i.e. if $M M^{-1} = I$ - private :: matrix_is_orthogonal - interface is_orthogonal - module procedure matrix_is_orthogonal - end interface is_orthogonal - - !% Symmetrise a matrix: $$A \to \frac{A + A^T}{2}$$ - private :: matrix_symmetrise - interface symmetrise - module procedure matrix_symmetrise - end interface - - !% Return the trace of a matrix. - private :: matrix_trace - interface trace - module procedure matrix_trace -#ifdef HAVE_QP - module procedure matrix_trace_q -#endif - end interface - - private :: matrix_trace_mult - interface trace_mult - module procedure matrix_trace_mult - end interface - - !% Adds the identity to a matrix - private :: matrix_add_identity_r, matrix_add_identity_c - interface add_identity - module procedure matrix_add_identity_r, matrix_add_identity_c - end interface add_identity - - !% Adds $x\mathbf{I}$ to a matrix - private :: matrix_add_xidentity_r, matrix_add_xidentity_c - interface add_xidentity - module procedure matrix_add_xidentity_r, matrix_add_xidentity_c - end interface add_xidentity - - !% Return the euclidean norm of a vector or of an array. - !% For a single vector 'x', 'norm(x)' is equal to 'sqrt(x .dot. x)' - !% A two-dimensional array is treated as a list of vectors in either - !% Fortran ('dir=1') or C ('dir=2') style-ordering. - !% The result is then a one-dimensional array of the norms of each vector. - private :: vector_norm, array_norm - interface norm - module procedure vector_norm, array_norm - end interface - - !% Euclidean norm$^2$ of a vector or a of a list of vectors. Result is equal - !% to 'x .dot. x' for a single vector 'x'. - private :: vector_normsq, array_normsq - interface normsq - module procedure vector_normsq, array_normsq -#ifdef HAVE_QP - module procedure vector_normsq_q -#endif - end interface - - !% Randomise the elements of an array. Uniformly distributed random quantities in the range - !% $(-\frac{a}{2},\frac{a}{2})$ are added to each element of the vector or matrix. - private :: vector_randomise, matrix_randomise, matrix_randomise_vweight, matrix_z_randomise, vector_z_randomise - interface randomise - module procedure vector_randomise, matrix_randomise, matrix_randomise_vweight, matrix_z_randomise, vector_z_randomise - end interface - - !% Search an array by element or by row. - private :: find_in_array_element_i, find_in_array_element_s, find_in_array_row - interface find_in_array - module procedure find_in_array_element_i, find_in_array_element_s, find_in_array_row - end interface - - !% Root-mean-square difference calculation for components of two vectors or arrays. - private :: rms_diff1, rms_diff2 - interface rms_diff - module procedure rms_diff1, rms_diff2 - end interface rms_diff - - - !% Returns a vector, contining a histogram of frequencies. - private :: vector_histogram - interface histogram - module procedure vector_histogram - end interface histogram - - private :: sort_array_i, sort_array_r - interface sort_array - module procedure sort_array_i, sort_array_r - end interface sort_array - - private :: heap_sort_i, heap_sort_r, heap_sort_r_2dim, heap_sort_i_2dim - interface heap_sort - module procedure heap_sort_i, heap_sort_r, heap_sort_r_2dim, heap_sort_i_2dim - end interface heap_sort - - private :: insertion_sort_i, insertion_sort_r - interface insertion_sort - module procedure insertion_sort_i, insertion_sort_r - end interface insertion_sort - - private :: binary_search_i, binary_search_r - interface binary_search - module procedure binary_search_i, binary_search_r - endinterface - - ! in addition, these are the intrinsics defined on matrices and vectors: - ! - ! = : intrinsic assignment, the left part needs to be allocated - ! * : intrinsic product : elementwise product - ! + : intrinsic sum : elementwise sum - ! - : intrinsic difference : elementwise difference - ! / : intrinsic division : elementwise division - ! - ! cos,sin,exp,log,sqrt,**,abs ....... : elementwise - ! matmul : intrinsic row*column product - ! transpose : intrinsic transposition - ! - ! in the following you can specify the direction of matrix, as optional argument, - ! which the operation will be performed along. - ! - ! maxval: return maximum in the matrix - ! minval: return minimum in the matrix - ! sum : return sum of matrix or vector elements - ! product : return product of matrix or vector elements - ! reshape(matrix,newshape) : to change shape - ! (the order of elements in memory will not change) - ! - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Interface to array size checking routines -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! Usage: call check_size(name,array,sizes,calling routine) - ! e.g. check_size('Velocity',velo,(/3,ds%N/),'DS_Add_Atom') - - !% Overloaded interface to assert that the size of an array is correct. - !% If the test fails 'system_abort' is called with an appropriate error message - !% constructed from the 'arrayname' and 'caller' arguments. - private :: check_size_int_dim1, check_size_int_dim1_s, check_size_int_dim2 - private :: check_size_real_dim1,check_size_real_dim1_s, check_size_real_dim2 -#ifdef HAVE_QP - private :: check_size_quad_dim1,check_size_quad_dim1_s, check_size_quad_dim2 -#endif - private :: check_size_complex_dim1,check_size_complex_dim1_s, check_size_complex_dim2 - private :: check_size_log_dim1, check_size_log_dim1_s, check_size_log_dim2 - interface check_size - module procedure check_size_int_dim1, check_size_int_dim1_s, check_size_int_dim2 - module procedure check_size_real_dim1, check_size_real_dim1_s, check_size_real_dim2, check_size_real_dim3 -#ifdef HAVE_QP - module procedure check_size_quad_dim1, check_size_quad_dim1_s, check_size_quad_dim2 -#endif - module procedure check_size_complex_dim1, check_size_complex_dim1_s, check_size_complex_dim2 - module procedure check_size_log_dim1, check_size_log_dim1_s, check_size_log_dim2 - end interface check_size - - !% Update a measure of a recent average by decaying its current value and adding on a new sample - private :: update_exponential_average_s, update_exponential_average_v, update_exponential_average_d2 - interface update_exponential_average - module procedure update_exponential_average_s, update_exponential_average_v, update_exponential_average_d2 - end interface update_exponential_average - - private :: matrix_exp_d - interface matrix_exp - module procedure matrix_exp_d - end interface matrix_exp - - private :: uniq_int, uniq_real, uniq_real_dim2 - interface uniq - module procedure uniq_int, uniq_real, uniq_real_dim2 - endinterface uniq - - private :: find_nonzero_chunk_real1d - interface find_nonzero_chunk - module procedure find_nonzero_chunk_real1d - endinterface find_nonzero_chunk -CONTAINS - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X -!X random crap -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function int_sign(n) - integer::n, int_sign - int_sign = sign(1, n) - end function int_sign - - function real_sign(n) - real(dp)::n, real_sign - real_sign = sign(1.0_dp, n) - end function real_sign - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X -!X MATRIX stuff -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Kronecker delta function $\delta_{ij}$. - function delta(i,j) - integer, intent(in) :: i,j - integer :: delta - if (i == j) then - delta = 1 - else - delta = 0 - end if - end function delta - - ! diag(v) - ! - ! return a matrix with the vector as its diagonal - function vector_as_diag_matrix_r(vect) result(matrix) - real(dp),intent(in), dimension(:) :: vect - real(dp), dimension(size(vect),size(vect)) :: matrix - integer::i - - matrix = 0.0_dp - - do i=1,size(vect) - matrix(i,i)=vect(i) - end do - - end function vector_as_diag_matrix_r - - ! diag(v) - ! - ! return a matrix with the vector as its diagonal - function vector_as_diag_matrix_c(vect) result(matrix) - complex(dp),intent(in), dimension(:) :: vect - complex(dp), dimension(size(vect),size(vect)) :: matrix - integer::i - - matrix = 0.0_dp - - do i=1,size(vect) - matrix(i,i)=vect(i) - end do - - end function vector_as_diag_matrix_c - - ! diag(matrix) - ! - ! returns the diagonal of a matrix as a vector - function matrix_diagonal_r(matrix) result (vect) - real(dp),intent(in), dimension(:,:) ::matrix - real(dp), dimension(size(matrix,1)) ::vect - integer::I - - if (.NOT.is_square(matrix)) call system_abort('Matrix_diagonal: matrix not squared') - - do i=1,size(matrix,1) - vect(i)=matrix(i,i) - end do - - end function matrix_diagonal_r - - ! diag(matrix) - ! - ! returns the diagonal of a matrix as a vector - function matrix_diagonal_c(matrix) result (vect) - complex(dp),intent(in), dimension(:,:) ::matrix - complex(dp), dimension(size(matrix,1)) ::vect - integer::I - - if (.NOT.is_square(matrix)) call system_abort('Matrix_diagonal: matrix not squared') - - do i=1,size(matrix,1) - vect(i)=matrix(i,i) - end do - - end function matrix_diagonal_c - - - ! m(:,:) .mult. v(:) - ! - ! matrix times a vector - function matrix_product_vect(matrix,vect) result (prodvect) - real(dp),intent(in), dimension(:) :: vect - real(dp),intent(in), dimension(:,:) :: matrix - real(dp), dimension(size(matrix,1)) ::prodvect - integer::N,M,i,j - - N=size(matrix,1) - M=size(matrix,2) - - if (M /= size(vect)) call check_size('Vector',vect,M,'Matrix_Product_Vect') - prodvect = 0.0_dp - do j=1,M - forall (i=1:N) prodvect(i) = prodvect(i) + matrix(i,j)*vect(j) - end do - - end function matrix_product_vect - - ! m(:,:) .mult. a(:) - ! - ! product of real matrix and integer vector - function matrix_product_int_vect(matrix,intvect) result(prodvect) - - real(dp), intent(in), dimension(:,:) :: matrix - integer, intent(in), dimension(:) :: intvect - real(dp) :: prodvect(size(matrix,1)) - integer :: M,N,i,j - - N=size(matrix,1) - M=size(matrix,2) - if(M /= size(intvect)) & - call check_size('Integer Vector',intvect,M,'Matrix_product_int_vect') - prodvect = 0.0_dp - do j=1,M - forall(i=1:N) prodvect(i) = prodvect(i)+matrix(i,j)*intvect(j) - end do - - end function matrix_product_int_vect - - function matrix_product_int_mat(matrix,intmat) result(prodmat) - - real(dp), intent(in), dimension(:,:) :: matrix - integer, intent(in), dimension(:,:) :: intmat - real(dp) :: prodmat(size(matrix,1),size(intmat,2)) - integer :: M,N,L,i - - N=size(matrix,1) - M=size(matrix,2) - L=size(intmat,2) - if (M /= size(intmat,1)) & - call check_size('Integer Matrix',intmat,(/M,L/),'Matrix_product_int_mat') - prodmat = 0.0_dp - do i=1,L - prodmat(:,i) = matrix_product_int_vect(matrix,intmat(:,i)) - end do - - end function matrix_product_int_mat - - ! subroutine form of m(:,:) .multd. v(:) for real = real * real - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) -#ifdef HAVE_QP - subroutine matrix_product_vect_asdiagonal_sub_qqq(lhs, matrix, vect) - real(qp), dimension(:,:), intent(out) :: lhs - real(qp), dimension(:,:), intent(in) :: matrix - real(qp), dimension(:), intent(in) :: vect - - integer :: i - -!$omp parallel do private(i) shared(lhs,vect,matrix) - do i = 1, size(vect) - lhs(:,i) = vect(i) * matrix(:,i) - enddo - - endsubroutine matrix_product_vect_asdiagonal_sub_qqq -#endif - - subroutine matrix_product_vect_asdiagonal_sub_ddd(lhs, matrix, vect) - real(dp), dimension(:,:), intent(out) :: lhs - real(dp), dimension(:,:), intent(in) :: matrix - real(dp), dimension(:), intent(in) :: vect - - integer :: i - -!$omp parallel do private(i) shared(lhs,vect,matrix) - do i = 1, size(vect) - lhs(:,i) = vect(i) * matrix(:,i) - enddo - - endsubroutine matrix_product_vect_asdiagonal_sub_ddd - - ! subroutine form of m(:,:) .multd. v(:) for complex = real * complex - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine matrix_product_vect_asdiagonal_sub_zdz(lhs, matrix, vect) - complex(dp), dimension(:,:), intent(out) :: lhs - real(dp), dimension(:,:), intent(in) :: matrix - complex(dp), dimension(:), intent(in) :: vect - - integer :: i - -!$omp parallel do private(i) shared(lhs,vect,matrix) - do i = 1, size(vect) - lhs(:,i) = vect(i) * matrix(:,i) - enddo - - endsubroutine matrix_product_vect_asdiagonal_sub_zdz - - ! subroutine form of m(:,:) .multd. v(:) for complex = complex * real - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine matrix_product_vect_asdiagonal_sub_zzd(lhs, matrix, vect) - complex(dp), dimension(:,:), intent(out) :: lhs - complex(dp), dimension(:,:), intent(in) :: matrix - real(dp), dimension(:), intent(in) :: vect - - integer :: i - -!$omp parallel do private(i) shared(lhs,vect,matrix) - do i = 1, size(vect) - lhs(:,i) = vect(i) * matrix(:,i) - enddo - - endsubroutine matrix_product_vect_asdiagonal_sub_zzd - - ! subroutine form of m(:,:) .multd. v(:) for complex = complex * complex - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine matrix_product_vect_asdiagonal_sub_zzz(lhs, matrix, vect) - complex(dp), dimension(:,:), intent(out) :: lhs - complex(dp), dimension(:,:), intent(in) :: matrix - complex(dp), dimension(:), intent(in) :: vect - - integer :: i - -!$omp parallel do private(i) shared(lhs,vect,matrix) - do i = 1, size(vect) - lhs(:,i)=vect(i)*matrix(:,i) - end do - - endsubroutine matrix_product_vect_asdiagonal_sub_zzz - - ! subroutine form of v(:) .multd. m(:,:) for real = real * real - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine vect_asdiagonal_product_matrix_sub_ddd(lhs, vectL, matrix) - real(dp), dimension(:,:), intent(out) :: lhs - real(dp), dimension(:), intent(in) :: vectL - real(dp), dimension(:,:), intent(in) :: matrix - - integer :: i - - do i = 1, size(matrix,2) - lhs(:,i)=vectL(:)*matrix(:,i) - end do - - end subroutine vect_asdiagonal_product_matrix_sub_ddd - - ! subroutine form of v(:) .multd. m(:,:) for complex = complex * real - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine vect_asdiagonal_product_matrix_sub_zzd(lhs, vectL, matrix) - complex(dp), dimension(:,:), intent(out) :: lhs - complex(dp), dimension(:), intent(in) :: vectL - real(dp), dimension(:,:), intent(in) :: matrix - - integer :: i - - do i = 1, size(matrix,2) - lhs(:,i)=vectL(:)*matrix(:,i) - end do - - end subroutine vect_asdiagonal_product_matrix_sub_zzd - - ! subroutine form of v(:) .multd. m(:,:) for complex = real * complex - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine vect_asdiagonal_product_matrix_sub_zdz(lhs, vectL, matrix) - complex(dp), dimension(:,:), intent(out) :: lhs - real(dp), dimension(:), intent(in) :: vectL - complex(dp), dimension(:,:), intent(in) :: matrix - - integer :: i - - do i = 1, size(matrix,2) - lhs(:,i)=vectL(:)*matrix(:,i) - end do - - end subroutine vect_asdiagonal_product_matrix_sub_zdz - - ! subroutine form of v(:) .multd. m(:,:) for complex = complex * complex - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine vect_asdiagonal_product_matrix_sub_zzz(lhs, vectL, matrix) - complex(dp), dimension(:,:), intent(out) :: lhs - complex(dp), dimension(:), intent(in) :: vectL - complex(dp), dimension(:,:), intent(in) :: matrix - - integer :: i - - do i = 1, size(matrix,2) - lhs(:,i)=vectL(:)*matrix(:,i) - end do - - end subroutine vect_asdiagonal_product_matrix_sub_zzz - - ! m(:,:) .multd. v(:) - ! - ! returns product of matrix and vector as diagonal of another matrix - function matrix_product_vect_asdiagonal_dd(matrix,vect) result (prodmatrix) - real(dp),intent(in),dimension(:,:)::matrix - real(dp),intent(in), dimension(:) :: vect - real(dp),dimension(size(matrix,1),size(matrix,2))::prodmatrix - - call matrix_product_vect_asdiagonal_sub(prodmatrix, matrix, vect) - - end function matrix_product_vect_asdiagonal_dd - - ! m(:,:) .multd. v(:) - ! - ! returns product of matrix and vector as diagonal of another matrix - function matrix_product_vect_asdiagonal_zz(matrix,vect) result (prodmatrix) - complex(dp),intent(in), dimension(:) :: vect - complex(dp),dimension(size(vect),size(vect))::prodmatrix - complex(dp),intent(in),dimension(:,:)::matrix - - call matrix_product_vect_asdiagonal_sub(prodmatrix, matrix, vect) - - end function matrix_product_vect_asdiagonal_zz - - ! multiply a matrix by a vector, interepreted as a diagonal matrix, on - ! the left and right hand sides, weighted by 0.5 - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine matrix_product_vect_asdiagonal_RL_sub_ddd(lhs, matrix, vect) - real(dp), intent(out) :: lhs(:,:) - real(dp), intent(in) :: matrix(:,:) - real(dp), intent(in) :: vect(:) - - real(dp)::tmp - integer::i,j,N - - N=size(vect) - - do j=1,N - tmp=vect(j) - do i=1,N - lhs(i,j)=0.5_dp*(tmp+vect(i))*matrix(i,j) - end do - end do - - end subroutine matrix_product_vect_asdiagonal_RL_sub_ddd - - ! multiply a matrix by a vector, interepreted as a diagonal matrix, on - ! the left and right hand sides, weighted by 0.5 - ! - ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) - subroutine matrix_product_vect_asdiagonal_RL_sub_zzd(lhs, matrix, vect) - complex(dp), intent(out) :: lhs(:,:) - complex(dp), intent(in) :: matrix(:,:) - real(dp), intent(in) :: vect(:) - - real(dp)::tmp - integer::i,j,N - - N=size(vect) - - do j=1,N - tmp=vect(j) - do i=1,N - lhs(i,j)=0.5_dp*(tmp+vect(i))*matrix(i,j) - end do - end do - - end subroutine matrix_product_vect_asdiagonal_RL_sub_zzd - - - ! multiply matrix C with a diagonal matrix that has vect as diagonal, - ! and then multiply the result and the tranpose of C. - ! NEEDS TO BE OPTIMIZED - function matrix_cfct(matrix,vect) result (prodmatrix) - real(dp),intent(in),dimension(:) :: vect - real(dp),intent(in),dimension(:,:) :: matrix - real(dp), dimension(size(matrix,1),size(matrix,1)) ::prodmatrix - integer::i,j,k,N,M - real(dp)::tmp - - N=size(matrix,1) - M=size(matrix,2) - - if(M /= size(vect)) & - call check_size('Vector',vect,M,'Matrix_CFCT') - - do I=1,N - do j=1,N - tmp=0.0_dp - do k=1,size(vect)/2 - tmp=tmp+matrix(I,K)*vect(k)*matrix(j,K) - end do - do k=size(vect)/2+1,size(vect) - if (abs(vect(k)).LT.(real(1.e-10))) cycle - - tmp=tmp+matrix(I,K)*vect(k)*matrix(j,K) - end do - prodmatrix(I,J)=tmp - end do - end do - - end function matrix_cfct - - - ! m1(:,:) .dot. m2(:,:) - ! - ! scalar product between matrixes - function matrix_dotproduct_matrix(matrix1,matrix2) result(prod) - real(dp),intent(in), dimension(:,:) :: matrix1 - real(dp),intent(in), dimension(:,:) :: matrix2 - real(dp)::prod - integer::i,j - - if(size(matrix1,1) /= size(matrix2,1) .or. size(matrix1,2) /= size(matrix2,2)) & - call check_size('Matrix2',matrix2,shape(matrix1),'Matrix_Dotproduct_Matrix') - - prod = 0.0_dp - do j = 1, size(matrix1,2) - do i = 1, size(matrix1,1) - prod = prod + matrix1(i,j)*matrix2(i,j) - end do - end do - - end function matrix_dotproduct_matrix - - ! subroutine form of m1(:,:) .mult. m2(:,:) - ! - ! set first argument to matrix product (no temporary on the stack) - subroutine matrix_product_sub_ddd(lhs, matrix1, matrix2, m1_transpose, m2_transpose, & - lhs_factor, rhs_factor) - real(dp), intent(out) :: lhs(:,:) - real(dp), intent(in) :: matrix1(:,:), matrix2(:,:) - logical, intent(in), optional :: m1_transpose, m2_transpose - real(dp), intent(in), optional :: lhs_factor, rhs_factor - - integer::M,N,maxd,K - character(len=1) :: m1_transp, m2_transp - integer :: m1_r, m1_c, m2_r, m2_c - real(dp) :: my_lhs_factor, my_rhs_factor - - m1_transp = 'N' - m2_transp = 'N' - if (present(m1_transpose)) then - if (m1_transpose) m1_transp = 'T' - endif - if (present(m2_transpose)) then - if (m2_transpose) m2_transp = 'T' - endif - - if (m1_transp == 'N') then - m1_r = 1; m1_c = 2 - else - m1_r = 2; m1_c = 1 - endif - if (m2_transp == 'N') then - m2_r = 1; m2_c = 2 - else - m2_r = 2; m2_c = 1 - endif - - my_lhs_factor = optional_default(0.0_dp, lhs_factor) - my_rhs_factor = optional_default(1.0_dp, rhs_factor) - - call check_size('lhs',lhs,(/size(matrix1,m1_r),size(matrix2,m2_c)/),'Matrix_Product') - if (m2_transp == 'N') then - call check_size('Matrix2',matrix2,(/size(matrix1,m1_c),size(matrix2,m2_c)/),'Matrix_Product') - else - call check_size('Matrix2',matrix2,(/size(matrix2,m2_c),size(matrix1,m1_c)/),'Matrix_Product') - endif - - N = size(lhs,1) !# of rows of lhs - M = size(lhs,2) !# of columns of rhs - K = size(matrix1,m1_c) !!shared dimension - maxd=max(N,M,K) - - if (use_intrinsic_blas) then - if (m1_transp == 'T') then - if (m2_transp == 'T') then - lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),transpose(matrix2)) - else - lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),matrix2) - endif - else - if (m2_transp == 'T') then - lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,transpose(matrix2)) - else - lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,matrix2) - endif - endif - else - call DGEMM(m1_transp,m2_transp, N,M,K,my_rhs_factor,matrix1,size(matrix1,1),matrix2,size(matrix2,1),& - my_lhs_factor,lhs,size(lhs,1)) - endif - - end subroutine matrix_product_sub_ddd - - ! subroutine form of m1(:,:) .mult. m2(:,:) - ! - ! set first argument to matrix product (no temporary on the stack) - subroutine matrix_product_sub_zzz(lhs, matrix1, matrix2, m1_transpose, m1_conjugate, & - m2_transpose, m2_conjugate, lhs_factor, rhs_factor) - complex(dp), intent(out) :: lhs(:,:) - complex(dp), intent(in) :: matrix1(:,:), matrix2(:,:) - logical, intent(in), optional :: m1_transpose, m1_conjugate, m2_transpose, m2_conjugate - complex(dp), intent(in), optional :: lhs_factor, rhs_factor - - integer::M,N,maxd,K - logical :: m1_transp, m2_transp, m1_conjg, m2_conjg - character(len=1) :: m1_op, m2_op - integer :: m1_r, m1_c, m2_r, m2_c - complex(dp) :: my_lhs_factor, my_rhs_factor - - m1_transp = .false. - m2_transp = .false. - m1_conjg = .false. - m2_conjg = .false. - if (present(m1_transpose)) m1_transp = m1_transpose - if (present(m2_transpose)) m2_transp = m2_transpose - if (present(m1_conjugate)) m1_conjg = m1_conjugate - if (present(m2_conjugate)) m2_conjg = m2_conjugate - - if (m1_conjg .and. m1_transp) call system_abort("Called matrix_product_sub_zzz with m1_transp and m1_conjg true") - if (m2_conjg .and. m2_transp) call system_abort("Called matrix_product_sub_zzz with m2_transp and m2_conjg true") - - if (m1_transp) then - m1_op = 'T' - else if (m1_conjg) then - m1_op = 'C' - else - m1_op = 'N' - end if - - if (m2_transp) then - m2_op = 'T' - else if (m2_conjg) then - m2_op = 'C' - else - m2_op = 'N' - end if - - if (m1_op == 'N') then - m1_r = 1; m1_c = 2 - else - m1_r = 2; m1_c = 1 - endif - if (m2_op == 'N') then - m2_r = 1; m2_c = 2 - else - m2_r = 2; m2_c = 1 - endif - - my_lhs_factor = optional_default(cmplx(0.0_dp, 0.0_dp, dp), lhs_factor) - my_rhs_factor = optional_default(cmplx(1.0_dp, 0.0_dp, dp), rhs_factor) - - call check_size('lhs',lhs,(/size(matrix1,m1_r),size(matrix2,m2_c)/),'Matrix_Product') - if (m2_op == 'N') then - call check_size('Matrix2',matrix2,(/size(matrix1,m1_c),size(matrix2,m2_c)/),'Matrix_Product') - else - call check_size('Matrix2',matrix2,(/size(matrix2,m2_c),size(matrix1,m1_c)/),'Matrix_Product') - endif - - N = size(lhs,1) !# of rows of lhs - M = size(lhs,2) !# of columns of rhs - K = size(matrix1,m1_c) !!shared dimension - maxd=max(N,M,K) - - if (use_intrinsic_blas) then - if (m1_transp) then - if (m2_transp) then - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),transpose(matrix2)) - else if (m2_conjg) then - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),conjg(transpose(matrix2))) - else - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),matrix2) - endif - else if (m1_conjg) then - if (m2_transp) then - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(conjg(transpose(matrix1)),transpose(matrix2)) - else if (m2_conjg) then - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(conjg(transpose(matrix1)),conjg(transpose(matrix2))) - else - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(conjg(transpose(matrix1)),matrix2) - endif - else - if (m2_transp) then - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,transpose(matrix2)) - else if (m2_conjg) then - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,conjg(transpose(matrix2))) - else - lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,matrix2) - endif - endif - else - call ZGEMM(m1_op,m2_op, N,M,K,my_rhs_factor,matrix1,size(matrix1,1),matrix2,size(matrix2,1),my_lhs_factor,lhs,size(lhs,1)) - endif - - end subroutine matrix_product_sub_zzz - - subroutine matrix_vector_product_sub_ddd(lhs, matrix, vector, m_transpose, & - lhs_factor, rhs_factor) - real(dp), intent(out) :: lhs(:) - real(dp), intent(in) :: matrix(:,:), vector(:) - logical, intent(in), optional :: m_transpose - real(dp), intent(in), optional :: lhs_factor, rhs_factor - - integer::M,N,maxd - character(len=1) :: m_transp - integer :: m_r, m_c - real(dp) :: my_lhs_factor, my_rhs_factor - - m_transp = 'N' - if (present(m_transpose)) then - if (m_transpose) m_transp = 'T' - endif - - if (m_transp == 'N') then - m_r = 1; m_c = 2 - else - m_r = 2; m_c = 1 - endif - - my_lhs_factor = optional_default(0.0_dp, lhs_factor) - my_rhs_factor = optional_default(1.0_dp, rhs_factor) - - call check_size('lhs',lhs,(/size(matrix,m_r)/),'Matrix_Product') - - N = size(lhs) !# of rows of lhs - M = size(matrix,m_c) !!shared dimension - maxd=max(N,M) - - if (use_intrinsic_blas) then - if (m_transp == 'T') then - lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix),vector) - else - lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(matrix,vector) - endif - else - call DGEMV(m_transp,N,M,my_rhs_factor,matrix,size(matrix,1),vector,1,& - my_lhs_factor,lhs,1) - endif - - end subroutine matrix_vector_product_sub_ddd - ! m1(:,:) .mult. m2(:,:) - ! - ! matrix multiplication (either lapack or intrinsic) - function matrix_product_ddd(matrix1,matrix2) result (prodmatrix) - real(dp),intent(in), dimension(:,:) :: matrix1 - real(dp),intent(in), dimension(:,:) :: matrix2 - real(dp), dimension(size(matrix1,1),size(matrix2,2)) ::prodmatrix - - call matrix_product_sub(prodmatrix, matrix1, matrix2) - end function matrix_product_ddd - - ! m1(:,:) .mult. m2(:,:) - ! - ! matrix multiplication (either lapack or intrinsic) - function matrix_product_zzz(matrix1,matrix2) result (prodmatrix) - complex(dp),intent(in), dimension(:,:) :: matrix1 - complex(dp),intent(in), dimension(:,:) :: matrix2 - complex(dp), dimension(size(matrix1,1),size(matrix2,2)) ::prodmatrix - - call matrix_product_sub(prodmatrix, matrix1, matrix2) - end function matrix_product_zzz - - ! m1(:,:) .mult. m2'(:,:) - ! - !% Calculate matrix product of 'matrix1' and 'matrix2' after transposing matrix2 - !% (either using \textsc{lapack} or intrinsic multiplication, depending on the - !& 'use_intrinsic_blas' setting). - function matrix_multT(matrix1,matrix2) result (prodmatrix) - real(dp),intent(in), dimension(:,:) :: matrix1 - real(dp),intent(in), dimension(:,:) :: matrix2 - real(dp), dimension(size(matrix1,1),size(matrix2,2)) ::prodmatrix - - call matrix_product_sub(prodmatrix, matrix1, matrix2, m1_transpose = .false., m2_transpose = .true.) - - end function matrix_multT - - - ! a .feq. b - ! - ! floating point logical comparison - pure function real_feq(x,y) result(feq) - - real(dp), intent(in) :: x, y - logical :: feq - - feq = (abs(x-y) <= NUMERICAL_ZERO * (abs(x)+abs(y))/2.0_dp) .or. (abs(x-y) <= NUMERICAL_ZERO) - - end function real_feq - - pure function real_integer_feq(x,y) result(feq) - - integer, intent(in) :: x - real(dp), intent(in) :: y - logical :: feq - - feq = real_feq(real(x,dp),y) - - end function real_integer_feq - - pure function integer_real_feq(x,y) result(feq) - - real(dp), intent(in) :: x - integer, intent(in) :: y - logical :: feq - - feq = real_feq(x,real(y,dp)) - - end function integer_real_feq - - ! a .fne. b - ! - ! floating point logical comparison - pure function real_fne(x,y) result(fne) - - real(dp), intent(in) :: x, y - logical :: fne - - fne = .not. real_feq(x, y) - - end function real_fne - - pure function real_fgt(x,y) result(fgt) - real(dp), intent(in) :: x, y - logical :: fgt - - fgt = ( (x-y) > max(abs(x),abs(y)) * NUMERICAL_ZERO ) !.or. ( (x-y) > NUMERICAL_ZERO ) - - endfunction real_fgt - - pure function real_fle(x,y) result(fle) - real(dp), intent(in) :: x, y - logical :: fle - - fle = .not. real_fgt(x,y) - - endfunction real_fle - - pure function real_flt(x,y) result(flt) - real(dp), intent(in) :: x, y - logical :: flt - - flt = ( (y-x) > max(abs(x),abs(y)) * NUMERICAL_ZERO ) !.or. ( (y-x) > NUMERICAL_ZERO ) - - endfunction real_flt - - pure function real_fge(x,y) result(fge) - real(dp), intent(in) :: x, y - logical :: fge - - fge = .not. real_flt(x,y) - - endfunction real_fge - - ! za .feq. zb - ! - ! complex logical comparison - pure function complex_feq(x,y) result(feq) - - complex(dp), intent(in) :: x, y - logical :: feq - - if ( (abs(real(x-y)) > NUMERICAL_ZERO * abs(real(x))) .or. & - (abs(aimag(x-y)) > NUMERICAL_ZERO * abs(aimag(x))) ) then - feq = .false. - else - feq = .true. - end if - - end function complex_feq - - ! za .fne. zb - ! - ! complex logical comparison - pure function complex_fne(x,y) result(fne) - - complex(dp), intent(in) :: x, y - logical :: fne - - if ( (abs(real(x-y)) > NUMERICAL_ZERO * abs(real(x))) .or. & - (abs(aimag(x-y)) > NUMERICAL_ZERO * abs(aimag(x))) ) then - fne = .true. - else - fne = .false. - end if - - end function complex_fne - - ! m1 .feq. m2 - ! - ! matrix floating point comparison - function matrix_feq(matrix1,matrix2) result (feq) - real(dp),intent(in), dimension(:,:) :: matrix1 - real(dp),intent(in), dimension(:,:) :: matrix2 - - integer::i,j - logical::feq - - call check_size('Matrix2',matrix2,shape(matrix1),'Matrix_FEQ') - - feq =.true. - do j=1,size(matrix1,2) - do i=1,size(matrix1,1) - if (matrix1(i,j).fne.matrix2(i,j)) then - feq=.false. - return - end if - end do - end do - - end function matrix_feq - - ! m1 .fne. m2 - ! - ! matrix floating point comparison - function matrix_fne(matrix1,matrix2) result (fne) - real(dp),intent(in), dimension(:,:) :: matrix1 - real(dp),intent(in), dimension(:,:) :: matrix2 - - integer::i,j - logical::fne - - if(size(matrix1,1) /= size(matrix2,1) .or. size(matrix1,2) /= size(matrix2,2)) & - call check_size('Matrix2',matrix2,shape(matrix1),'Matrix_FNE') - - fne =.false. - do j=1,size(matrix1,2) - do i=1,size(matrix1,1) - if (matrix1(i,j).FNE.matrix2(i,j)) then - fne=.true. - return - end if - end do - end do - - end function matrix_fne - - ! is_square(matrix) - ! - ! tells if the matrix is square - function matrix_square(matrix) result(sq) - real(dp),intent(in), dimension(:,:) :: matrix - logical::sq - - if (size(matrix,1).EQ.size(matrix,2)) then - sq=.true. - else - sq=.false. - end if - - end function matrix_square - - function int_matrix_square(matrix) result(sq) - - integer, intent(in), dimension(:,:) :: matrix - logical::sq - - sq = size(matrix,1) == size(matrix,2) - - end function int_matrix_square - - function logical_matrix_square(matrix) result(sq) - - logical, dimension(:,:), intent(in) :: matrix - - logical :: sq - - sq = size(matrix,1) == size(matrix,2) - - end function logical_matrix_square - - ! is_square(matrix_z) - ! - ! tells if the complex matrix is square - function matrix_z_square(matrix_z) result(sq) - complex(dp),intent(in), dimension(:,:) ::matrix_z - logical::sq - - if (size(matrix_z,1).EQ.size(matrix_z,2)) then - sq=.true. - else - sq=.false. - end if - - end function matrix_z_square - - - ! symmetrise matrix A -> (A + transpose(A))/2 - subroutine matrix_symmetrise(matrix) - real(dp), intent(inout), dimension(:,:) :: matrix - integer::i,j,n - real(dp)::tmp - - if (.not.is_square(matrix)) call system_abort('Matrix_Symmetrise: Matrix is not square') - - n=size(matrix,1) - do i=1,n - do j=i+1,n - tmp=0.5_dp*(matrix(i,j)+matrix(j,i)) - matrix(i,j)=tmp - matrix(j,i)=tmp - end do - end do - - end subroutine matrix_symmetrise - - !returns trace of a matrix - function matrix_trace(matrix) result(tr) - real(dp),intent(in), dimension(:,:) ::matrix - real(dp)::tr - integer::i,N - - N = min(size(matrix,1),size(matrix,2)) - - tr=0.0_dp - do i=1,N - tr=tr+matrix(i,i) - end do - - end function matrix_trace - -#ifdef HAVE_QP - function matrix_trace_q(matrix) result(tr) - real(qp),intent(in), dimension(:,:) ::matrix - real(qp)::tr - integer::i,N - - N = min(size(matrix,1),size(matrix,2)) - - tr=0.0_qp - do i=1,N - tr=tr+matrix(i,i) - end do - - end function matrix_trace_q -#endif - - !returns trace of the result matrix - function matrix_trace_mult(matrixA, matrixB) result(trm) - real(dp),intent(in), dimension(:,:) ::matrixA, matrixB - real(dp)::trm - integer::i, N - - N = size(matrixA, 1) - if(size(matrixB, 2) /= N) call system_abort("matrix_trace_mult: size(matrixB, 2) /= N") - if(size(matrixA, 2) /= size(matrixB, 1)) call system_abort("size(matrixA, 2) /= size(matrixB, 1)") - - trm=0.0_dp - do i=1,N - trm=trm + (matrixA(i,:) .dot. matrixB(:,i)) - end do - - end function matrix_trace_mult - - subroutine matrix_add_identity_r(matrix) - real(dp), intent(inout) :: matrix(:,:) - - integer i - - if (.not.is_square(matrix)) call system_abort('Matrix_add_identity: Matrix is not square') - - do i=1, size(matrix,1) - matrix(i,i) = matrix(i,i) + 1.0_dp - end do - end subroutine matrix_add_identity_r - - subroutine matrix_add_identity_c(matrix) - complex(dp), intent(inout) :: matrix(:,:) - - integer i - - if (.not.is_square(matrix)) call system_abort('Matrix_add_identity: Matrix is not square') - - do i=1, size(matrix,1) - matrix(i,i) = matrix(i,i) + 1.0_dp - end do - end subroutine matrix_add_identity_c - - subroutine matrix_add_xidentity_r(matrix,r) - real(dp), intent(inout) :: matrix(:,:) - real(dp), intent(in) :: r - - integer :: i - - if (.not.is_square(matrix)) call system_abort('Matrix_add_xidentity: Matrix is not square') - - do i=1, size(matrix,1) - matrix(i,i) = matrix(i,i) + r - end do - end subroutine matrix_add_xidentity_r - - subroutine matrix_add_xidentity_c(matrix,c) - complex(dp), intent(inout) :: matrix(:,:) - complex(dp), intent(in) :: c - - integer :: i - - if (.not.is_square(matrix)) call system_abort('Matrix_add_xidentity: Matrix is not square') - - do i=1, size(matrix,1) - matrix(i,i) = matrix(i,i) + c - end do - end subroutine matrix_add_xidentity_c - - - ! the following stuff only with lapack - ! diagonalise matrix, only symmetric case - subroutine matrix_diagonalise(this,evals,evects, ignore_symmetry, error) - real(dp),intent(in), dimension(:,:) :: this - real(dp),intent(inout), dimension(:) ::evals - real(dp),intent(inout), target, optional, dimension(:,:) :: evects - logical, intent(in), optional :: ignore_symmetry - integer, intent(out), optional :: error - - logical :: use_ignore_symmetry - real(8),allocatable::WORK(:), r8_evals(:) - real(8), pointer :: r8_evects(:,:) - integer::N,INFO,LWORK - - INIT_ERROR(error) - - use_ignore_symmetry = optional_default(.false., ignore_symmetry) - - N=size(this,2) - call check_size('Eigenvalue Vector',evals,N,'Matrix_Diagonalise') - - if (present(evects)) & - call check_size('Eigenvector Array',evects,shape(this),'Matrix_Diagonalise') - - if (use_ignore_symmetry .or. is_symmetric(this)) then - - LWORK=3*N - allocate(WORK(LWORK)) - allocate(r8_evals(N)) - - if (present(evects) .and. dp == 8) then - r8_evects => evects - else - allocate(r8_evects(N,N)) - endif - r8_evects = this - - if (present(evects)) then - call DSYEV('V','U',N,r8_evects,N,r8_evals,WORK,LWORK,INFO) - else - call DSYEV('N','U',N,r8_evects,N,r8_evals,WORK,LWORK,INFO) - endif - - if (present(evects) .and. dp /= 8) evects = r8_evects - evals = r8_evals - - deallocate(WORK) - deallocate(r8_evals) - if (.not. (present(evects) .and. dp == 8)) deallocate(r8_evects) - - if (INFO /= 0) then - mainlog%mpi_all_inoutput_flag=.true. - call print ('Matrix_diagonalise: Error in calling DSYEV! (info = '//INFO//')', PRINT_ALWAYS) - if (INFO < 0) then - call print (' '//(-INFO)//' argument had illegal value', PRINT_ALWAYS) - else if (INFO <= N) then - call print (' '//INFO//' off-diagonal elements of an intermediate tridiagonal form did not converge to zero', PRINT_ALWAYS) - endif - mainlog%mpi_all_inoutput_flag=.false. - RAISE_ERROR ('Matrix_diagonalise: Error in calling DSYEV! (info = '//INFO//')', error) - endif - else - ! Why not print a warning then call more general diagonalise? - RAISE_ERROR('Matrix_diagonalise: Non symmetric diagonalisation is not permitted',error) - end if - - end subroutine matrix_diagonalise - - ! the following stuff only with lapack - ! diagonalise complex matrix, only hermitian positive definite case - subroutine matrix_z_diagonalise(this,evals,evects,ignore_symmetry, error) - complex(dp),intent(in), dimension(:,:) :: this - real(dp),intent(inout), dimension(:) ::evals - complex(dp),intent(inout), optional, target, dimension(:,:) :: evects - logical, intent(in), optional :: ignore_symmetry - integer, intent(out), optional :: error - - integer::N,INFO,LWORK - integer NB - integer, external :: ILAENV - - logical :: use_ignore_symmetry - complex(8), pointer :: z8_evects(:,:) - real(8), allocatable :: r8_evals(:), RWORK(:) - complex(8), pointer :: WORK(:) - - INIT_ERROR(error) - - use_ignore_symmetry = optional_default(.false., ignore_symmetry) - - N=size(this,2) - call check_size('Eigenvalue Vector',evals,N,'Matrix_z_Diagonalise') - - if (present(evects)) & - call check_size('Eigenvector Array',evects,shape(this),'Matrix_z_Diagonalise') - - if (use_ignore_symmetry .or. is_hermitian(this)) then - - NB = ILAENV(1, "ZHETRD", "U", N, N, N, N) - LWORK=(NB+1)*N - allocate(WORK(LWORK)) - allocate(RWORK(3*N-2)) - allocate(r8_evals(N)) - - if (present(evects) .and. dp == 8) then - z8_evects => evects - else - allocate(z8_evects(N,N)) - endif - z8_evects = this - - if (present(evects)) then - call ZHEEV('V','U',N,z8_evects,N,r8_evals,WORK,LWORK,RWORK,INFO) - else - call ZHEEV('N','U',N,z8_evects,N,r8_evals,WORK,LWORK,RWORK,INFO) - endif - - if (present(evects) .and. dp /= 8) evects = z8_evects - evals = r8_evals - - deallocate(WORK) - deallocate(RWORK) - deallocate(r8_evals) - if (.not.(present(evects) .and. dp == 8)) deallocate(z8_evects) - - if (INFO /= 0) then - mainlog%mpi_all_inoutput_flag=.true. - call print ('Matrix_z_diagonalise: Error in calling ZHEEV! (info = '//INFO//')', PRINT_ALWAYS) - if (INFO < 0) then - call print (' '//(-INFO)//' argument had illegal value', PRINT_ALWAYS) - else if (INFO <= N) then - call print (' '//INFO//' off-diagonal elements of an intermediate tridiagonal form did not converge to zero', PRINT_ALWAYS) - endif - mainlog%mpi_all_inoutput_flag=.false. - RAISE_ERROR ('Matrix_z_diagonalise: Error in calling ZHEEV! (info = '//INFO//')', error) - endif - else - ! why not print a warning and call more general diagonalise instead? - RAISE_ERROR ('Matrix_z_diagonalise: Non hermitian diagonalisation is not permitted', error) - end if - - end subroutine matrix_z_diagonalise - - ! generalised eigenproblem - ! just works for symmetric systems - subroutine matrix_diagonalise_generalised(this,other,evals,evects,error) - real(dp),intent(in), dimension(:,:) :: this - real(dp),intent(in), dimension(:,:) :: other - real(dp),intent(inout), dimension(:) :: evals - real(dp),intent(inout), dimension(:,:) :: evects - integer, intent(out), optional :: error - - real(dp), allocatable :: other_copy(:,:) - real(dp), allocatable :: WORK(:) - integer::N,INFO,LWORK - integer, external :: ILAENV - integer NB - - INIT_ERROR(error) - - if (dp /= 8) call system_abort("matrix_diagonalise_generalised: no workaround for LAPACK assuming 8 byte double, but dp(="//dp//") /= 8") - - NB = ILAENV(1, "DSYTRD", "U", N, N, N, N) - N=size(this,1) - LWORK=(NB+2)*N - allocate(WORK(LWORK)) - allocate(other_copy(N,N)) - - call check_size('Eigenvalue vector',evals,N,'Matrix_Diagonalise_Generalised') - call check_size('Eigenvector Array',evects,shape(this),'Matrix_Diagonalise_Generalised') - - evects = this - other_copy = other - - call DSYGV(1,'V','U',N,evects,N,other_copy,N,evals,WORK,LWORK,INFO) - - deallocate(WORK) - deallocate(other_copy) - - if (INFO /= 0) then - mainlog%mpi_all_inoutput_flag=.true. - call print ('Matrix_diagonalise_generalised: Error in calling DSYGV! (info = '//INFO//')', PRINT_ALWAYS) - if (INFO < 0) then - call print (' '//(-INFO)//' argument had illegal value', PRINT_ALWAYS) - else if (INFO <= N) then - call print (' '//INFO//' off-diagonal elements of an intermediate tridiagonal form did not converge to zero', PRINT_ALWAYS) - else - call print (' '//(INFO-N)//' leading minor of B is not positive definite, factorization failed') - endif - mainlog%mpi_all_inoutput_flag=.false. - RAISE_ERROR ('Matrix_diagonalise_generalised: Error in calling DSYGV! (info = '//INFO//')', error) - endif - - end subroutine matrix_diagonalise_generalised - - ! general eigenproblem - ! just works for hermitian systems - subroutine matrix_z_diagonalise_generalised(this,other,evals,evects, error ) - complex(dp),intent(in), dimension(:,:) :: this - complex(dp),intent(in), dimension(:,:) :: other - real(dp),intent(inout), dimension(:) :: evals - complex(dp),intent(inout), dimension(:,:) :: evects - integer, intent(out), optional :: error - - complex(dp), allocatable::WORK(:) - real(dp), allocatable::RWORK(:) - integer::N,INFO,LWORK - integer, external :: ILAENV - complex(dp), allocatable :: other_copy(:,:) - - integer NB - - INIT_ERROR(error) - - if (dp /= 8) call system_abort("matrix_z_diagonalise_generalised: no workaround for LAPACK assuming 8 byte double, but dp(="//dp//") /= 8") - - N=size(this,2) - NB = ILAENV(1, "ZHETRD", "U", N, N, N, N) - LWORK=(NB+1)*N - allocate(WORK(LWORK)) - allocate(RWORK(3*N-2)) - allocate(other_copy(N,N)) - - call check_size('Eigenvalue vector',evals,N,'Matrix_z_Diagonalise_Generalised') - call check_size('Eigenvector Array',evects,shape(this),'Matrix_z_Diagonalise_Generalised') - - evects = this - other_copy = other - - call ZHEGV(1,'V','U',N,evects,N,other_copy,N,evals,WORK,LWORK,RWORK,INFO) - - deallocate(WORK) - deallocate(RWORK) - deallocate(other_copy) - - if (INFO /= 0) then - mainlog%mpi_all_inoutput_flag=.true. - call print ('Matrix_z_diagonalise_generalised: Error in calling ZHEGV! (info = '//INFO//')', PRINT_ALWAYS) - if (INFO < 0) then - call print (' '//(-INFO)//' argument had illegal value', PRINT_ALWAYS) - else if (INFO <= N) then - call print (' '//INFO//' off-diagonal elements of an intermediate tridiagonal form did not converge to zero', PRINT_ALWAYS) - else - call print (' '//(INFO-N)//' leading minor of B is not positive definite, factorization failed') - endif - mainlog%mpi_all_inoutput_flag=.false. - RAISE_ERROR ('Matrix_z_diagonalise_generalised: Error in calling ZHEGV! (info = '//INFO//')', error) - endif - - end subroutine matrix_z_diagonalise_generalised - - subroutine matrix_nonsymmetric_diagonalise(this, eval, l_evects, r_evects, error) - real(dp), dimension(:,:), intent(in) :: this - complex(dp), dimension(:), intent(out) :: eval - complex(dp), dimension(:,:), intent(out), optional, target :: l_evects, r_evects - integer, optional, intent(out) :: error - - real(dp), dimension(:), allocatable :: wr, wi, work - real(dp), dimension(:,:), allocatable :: a - real(dp), dimension(:,:), allocatable :: vl, vr - integer :: n, lwork, info, i - character(len=1) :: cl, cr - integer :: ldvl, ldvr - - INIT_ERROR(error) - - n = size(this,1) - allocate(a(n,n), wr(n), wi(n)) - if (present(r_evects)) then - allocate(vr(n,n)) - cr = 'V' - ldvr = n - else - allocate(vr(1,1)) - cr ='N' - ldvr = 1 - endif - if (present(l_evects)) then - allocate(vl(n,n)) - cl='V' - ldvl = n - else - allocate(vl(1,1)) - cl='N' - ldvl = 1 - endif - a = this - - allocate(work(1)) - lwork = -1 - call dgeev(cl, cr, n, a, n, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info) - if (info /= 0) then - RAISE_ERROR("matrix_nonsymmetric_diagonalise first dgeev call (determine lwork) failed with INFO="//info, error) - endif - lwork = ceiling(work(1)) - deallocate(work) - allocate(work(lwork)) - call dgeev(cl, cr, n, a, n, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info) - if (info /= 0) then - RAISE_ERROR("matrix_nonsymmetric_diagonalise second dgeev call (actual calculation) failed with INFO="//info, error) - endif - - eval = cmplx(wr,wi) - if (present(l_evects) .or. present(r_evects)) then - i = 1 - do while (i <= n) - if (wi(i) == 0) then - if (present(l_evects)) l_evects(:,i) = vl(:,i) - if (present(r_evects)) r_evects(:,i) = vr(:,i) - else - if (present(l_evects)) l_evects(:,i) = cmplx(vl(:,i), vl(:,i+1)) - if (present(l_evects)) l_evects(:,i+1) = cmplx(vl(:,i), -vl(:,i+1)) - if (present(r_evects)) r_evects(:,i) = cmplx(vr(:,i), vr(:,i+1)) - if (present(r_evects)) r_evects(:,i+1) = cmplx(vr(:,i), -vr(:,i+1)) - i = i + 1 - endif - i = i + 1 - end do - endif - - deallocate( a, wr, wi, work ) - if (.not. present(l_evects)) deallocate(vl) - if (.not. present(r_evects)) deallocate(vr) - - - endsubroutine matrix_nonsymmetric_diagonalise - - subroutine test_eigensys(A, B, evals, evecs) - real(dp), intent(in) :: A(:,:), B(:,:) - real(dp), intent(in) :: evals(:) - real(dp), intent(in) :: evecs(:,:) - - real(dp), allocatable :: t1(:,:), t2(:,:) - integer n, i, j - - n = size(evals) - - allocate(t1(n,n)) - allocate(t2(n,n)) - - t1 = matmul(A, evecs) - t2 = matmul(B, evecs) - - print '("test eigensys")' - - do i=1, N - do j=1, N - if (abs(t2(j,i)) > 1e-10_dp) then - print '(I0," ",4F30.20)', i, evals(i), t1(j,i), t2(j,i), t1(j,i)/t2(j,i) - else - print '(I0," ",3F30.20, "-")', i, evals(i), t1(j,i), t2(j,i) - endif - end do - end do - - end subroutine test_eigensys - - - ! calculate inverse, if the matrix is symmetric uses a quicker way, otherways a more general - ! if inverse is missing, do in-place - subroutine matrix_inverse(matrix,inverse,positive_in) - real(dp),intent(in), dimension(:,:), target::matrix - real(dp),intent(out), dimension(:,:), optional, target::inverse - logical,optional::positive_in - - integer::N,INFO,i,j,LWORK - integer,allocatable::IPIV(:) - real(dp),allocatable::WORK(:) - logical::positive - !IMPROVE real(dp), allocatable :: u_lu(:,:), b(:,:), ferr(:), berr(:) - !IMPROVE integer, allocatable :: iwork(:) - - real(dp), pointer :: u_inverse(:,:) - - if (present(inverse)) then - u_inverse => inverse - else - u_inverse => matrix - endif - - if (present(positive_in)) then - positive = positive_in - else - positive = .true. - end if - - call check_size('Inverse',u_inverse,shape(matrix),'Matrix_Inverse') - - N = size(matrix,2) - - if (present(inverse)) u_inverse = matrix - - ! try the symmetric, positive definite case - - if( matrix_is_symmetric(matrix) .and. positive) then - - ! cholesky - - ! this only works for positive definite - call DPOTRF('U', N, u_inverse, N, INFO) - - if(INFO > 0) then - write (line,'(a)') 'Matrix_Inverse: Matrix is not positive definite, switching to general case inversion!' - call print(line) - - ! we branch to the general case below - else - if (INFO < 0) then - write(line,'(a,i0,a)')'Matrix_Inverse: Error in calling DPOTRF (',info,')' - call system_abort(line) - end if - ! now do the inverse - ! again, this call is only for positive definite, but now we should be - call DPOTRI('U', N, u_inverse, N, INFO) - if (INFO /= 0) then - write(line,'(a,i0,a)')'Matrix_Inverse: Error in calling DPOTRI (',info,')' - call system_abort(line) - end if - ! filling the lower part of symmetric matrix - do i=1,N - do j=i+1,N - u_inverse(j,i) = u_inverse(i,j) - enddo - enddo - return - end if - end if - - ! do the general case - - LWORK = 3*N - allocate(WORK(LWORK)) - allocate(IPIV(N)) - - ! LU factorization - - call DGETRF(N, N, u_inverse, N, IPIV, info) - if (INFO /= 0) call system_abort('Error in calling DGETRF (info = '//info//')') - - !IMPROVE allocate(u_lu(N,N)) - !IMPROVE u_lu = u_inverse - - !inverse - - call DGETRI(N, u_inverse, N, IPIV, WORK, LWORK, info) - if (INFO /= 0) call system_abort('Error in calling DGETRI (info = '//info//')') - - !IMPROVE deallocate(WORK) - !IMPROVE allocate(b(N,N),ferr(N),berr(N),WORK(3*N),iwork(N)) - !IMPROVE b = 0.0_dp - !IMPROVE call add_identity(b) - !IMPROVE call dgerfs('N',N,N,matrix,N,u_lu,N,ipiv,b,N,u_inverse,N,ferr,berr,WORK,iwork,info) - - deallocate(WORK,IPIV) - - end subroutine matrix_inverse - - ! calculate inverse, if the matrix is symmetric uses a quicker way, otherways a more general - ! if inverse is missing, do in-place - subroutine matrix_z_inverse(matrix,inverse,positive_in) - complex(dp),intent(in), dimension(:,:), target::matrix - complex(dp),intent(out), dimension(:,:), optional, target::inverse - logical,optional::positive_in - - integer::N,INFO,i,j,LWORK - integer,allocatable::IPIV(:) - complex(dp),allocatable::WORK(:) - logical::positive - - complex(dp), pointer :: u_inverse(:,:) - - if (present(inverse)) then - u_inverse => inverse - u_inverse = matrix - else - u_inverse => matrix - endif - - if (present(positive_in)) then - positive = positive_in - else - positive = .true. - end if - - call check_size('Inverse',u_inverse,shape(matrix),'Matrix_Inverse') - - N = size(matrix,2) - - if (matrix_z_is_hermitian(matrix)) then - - - if (positive) then - - ! cholesky - - ! this only works for hermitian positive definite - call ZPOTRF('U', N, u_inverse, N, INFO) - - if(INFO > 0) then - write (line,'(a)') 'Matrix_Inverse: Matrix is not positive definite, switching to general case inversion!' - call print(line) - ! we branch to the general case below - else - if (INFO < 0) then - write(line,'(a,i0,a)')'Matrix_Inverse: Error in calling ZPOTRF (',info,')' - call system_abort(line) - end if - ! now do the inverse - ! again, this call is only for positive definite, but now we should be - call ZPOTRI('U', N, u_inverse, N, INFO) - if (INFO /= 0) then - write(line,'(a,i0,a)')'Matrix_Inverse: Error in calling ZPOTRI (',info,')' - call system_abort(line) - end if - ! filling the lower part of hermitian matrix - do i=1,N - do j=i+1,N - u_inverse(j,i) = conjg(u_inverse(i,j)) - enddo - enddo - return - end if ! zpotrf INFO > 0 - - endif ! positive - - lwork = 16*N - allocate(work(lwork)) - allocate(ipiv(N)) - - ! Bunch-Kaufman factorization - call ZHETRF('U', N, u_inverse, N, ipiv, work, lwork, info) - if (INFO /= 0) call system_abort('Error in calling ZHETRF (info = '//info//')') - - ! inverse - call ZHETRI('U', N, u_inverse, N, ipiv, work, info) - if (INFO /= 0) call system_abort('Error in calling ZHETRI (info = '//info//')') - - ! filling the lower part of hermitian matrix - do i=1,N - do j=i+1,N - u_inverse(j,i) = conjg(u_inverse(i,j)) - enddo - enddo - - deallocate(work,ipiv) - return - else if (matrix_z_is_symmetric(matrix)) then - lwork = 16*N - allocate(work(lwork)) - allocate(ipiv(N)) - - ! LU factorization - call ZSYTRF('U', N, u_inverse, N, ipiv, work, lwork, info) - if (INFO /= 0) call system_abort('Error in calling ZSYTRF (info = '//info//')') - - ! inverse - call ZSYTRI('U', N, u_inverse, N, ipiv, work, info) - if (INFO /= 0) call system_abort('Error in calling ZSYTRI (info = '//info//')') - - ! filling the lower part of symmetric matrix - do i=1,N - do j=i+1,N - u_inverse(j,i) = u_inverse(i,j) - enddo - enddo - - deallocate(work, ipiv) - return - end if ! matrix is hermitian - - ! do the general case - - LWORK = 16*N - allocate(WORK(LWORK)) - allocate(IPIV(N)) - - ! LU factorization - call ZGETRF(N, N, u_inverse, N, IPIV, info) - if (INFO /= 0) call system_abort('Error in calling ZGETRF (info = '//info//')') - - !inverse - call ZGETRI(N, u_inverse, N, IPIV, WORK, LWORK, info) - if (INFO /= 0) call system_abort('Error in calling ZGETRI (info = '//info//')') - - deallocate(WORK,IPIV) - return - - end subroutine matrix_z_inverse - - subroutine pseudo_inverse(this,inverse,error) - real(dp),intent(in), dimension(:,:) :: this - real(dp),intent(out), dimension(:,:) :: inverse - integer, optional, intent(out) :: error - - type(LA_Matrix) :: LA_this - - INIT_ERROR(error) - - call initialise(LA_this,this) - call LA_Matrix_PseudoInverse(LA_this,inverse,error=error) - call finalise(LA_this) - - endsubroutine pseudo_inverse - - ! Cholesky factorisation of a symmetric matrix. - ! Various checks (size, symmetricity etc.) might be useful later. - subroutine LA_Matrix_Initialise(this,matrix,use_allocate) - - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(in), target :: matrix - logical, intent(in), optional :: use_allocate - - if(this%initialised) call finalise(this) - - this%use_allocate = optional_default(.true., use_allocate) - - this%n = size(matrix,1) - this%m = size(matrix,2) - - if (this%use_allocate) then - allocate(this%matrix(this%n,this%m)) - this%matrix = matrix - else - this%matrix => matrix - end if - - allocate(this%factor(this%n,this%m), this%s(this%n), this%tau(this%m)) - this%initialised = .true. - - endsubroutine LA_Matrix_Initialise - - subroutine LA_Matrix_Initialise_Matrix(this,matrix) - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(in) :: matrix - call Initialise(this,matrix) - endsubroutine LA_Matrix_Initialise_Matrix - - subroutine LA_Matrix_Initialise_Copy(this, from) - - type(LA_Matrix), intent(inout) :: this - type(LA_Matrix), intent(in) :: from - - if(this%initialised) call finalise(this) - - this%use_allocate = .true. - if (associated(from%matrix)) then - allocate(this%matrix(size(from%matrix,1), size(from%matrix,2))) - this%matrix = from%matrix - end if - if (allocated(from%factor)) then - allocate(this%factor(size(from%factor,1), size(from%factor,2))) - this%factor = from%factor - end if - if (allocated(from%s)) then - allocate(this%s(size(from%s))) - this%s = from%s - end if - if (allocated(from%tau)) then - allocate(this%tau(size(from%tau))) - this%tau = from%tau - end if - this%n = from%n - this%m = from%m - this%initialised = from%initialised - this%equilibrated = from%equilibrated - this%factorised = from%factorised - - endsubroutine LA_Matrix_Initialise_Copy - - subroutine LA_Matrix_Update(this,matrix) - - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(in) :: matrix - - integer :: factorised - - factorised = this%factorised - - if(this%initialised) then - if( all(shape(matrix) == (/this%n,this%m/)) ) then - this%matrix = matrix - else - call initialise(this,matrix) - endif - else - call initialise(this,matrix) - endif - - select case(factorised) - case(CHOLESKY) - call LA_Matrix_Factorise(this) - case(QR) - call LA_Matrix_QR_Factorise(this) - endselect - - endsubroutine LA_Matrix_Update - - subroutine LA_Matrix_Finalise(this) - - type(LA_Matrix), intent(inout) :: this - - if(.not. this%initialised) return - - this%n = 0 - this%m = 0 - if(this%use_allocate .and. associated(this%matrix)) deallocate(this%matrix) - this%matrix => null() - if(allocated(this%factor) ) deallocate(this%factor) - if(allocated(this%s) ) deallocate(this%s) - if(allocated(this%tau) ) deallocate(this%tau) - this%initialised = .false. - this%equilibrated = .false. - this%factorised = NOT_FACTORISED - - endsubroutine LA_Matrix_Finalise - - subroutine LA_Matrix_Factorise(this,factor,error) - - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(out), optional :: factor - integer, optional, intent(out) :: error - - integer :: i, j, info - real(dp) :: scond, amax - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR('LA_Matrix_Factorise: object not initialised',error) - endif - - if( this%n /= this%m ) then - RAISE_ERROR('LA_Matrix_Factorise: matrix not square',error) - endif - - this%s = 1.0_qp - - do i = 1, this%n - this%s(i) = 1.0_qp / sqrt(this%matrix(i,i)) - enddo - scond = maxval(this%s) / minval(this%s) - amax = maxval(this%matrix) - - this%equilibrated = ( scond < 0.1_qp ) - - if( this%equilibrated ) then - do i = 1, this%n - this%factor(:,i) = this%matrix(:,i)*this%s(:)*this%s(i) - enddo - else - this%factor = this%matrix - endif - -#if defined(HAVE_QP) || defined(ALBERT_LAPACK) - call qpotrf(this%factor,info) -#else - call dpotrf('L', this%n, this%factor, this%n, info) - do i = 2, this%n - do j = 1, i - this%factor(j,i) = this%factor(i,j) - enddo - enddo -#endif - - if( info /= 0 ) then - RAISE_ERROR('LA_Matrix_Factorise: cannot factorise, error: '//info, error) - endif - - if( present(factor) ) then - if( this%equilibrated ) then - factor = 0.0_qp - do i = 1, this%n - do j = 1, this%n - factor(j,i) = this%factor(j,i) / this%s(i) - enddo - enddo - else - factor = this%factor - endif - endif - - this%factorised = CHOLESKY - - endsubroutine LA_Matrix_Factorise - - subroutine qpotrf(this,info) - real(qp), dimension(:,:), intent(inout) :: this - integer, intent(out), optional :: info - real(qp), dimension(:), allocatable :: v, w - - integer :: i, j, k, p, mu, n -#ifdef _OPENMP - integer, external :: omp_get_num_threads, omp_get_thread_num -#endif - - n = size(this,1) - - if(present(info)) info = 0 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! another implementation -! this(:,1) = this(:,1) / sqrt(this(1,1)) -! do j = 2, n -! this(j:n,j) = this(j:n,j) - matmul( this(j:n,1:j-1), this(j,1:j-1) ) -! if(this(j,j)<0.0_qp) then -! if(present(info)) then -! info = j -! return -! else -! call system_abort('my_potrf: trouble') -! endif -! endif -! this(j:n,j) = this(j:n,j)/sqrt(this(j,j)) -! enddo -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - p = 1 - mu = 1 - -!$omp parallel private(mu,v,w) shared(info) -!$ p=omp_get_num_threads() -!$ mu=omp_get_thread_num()+1 - allocate(v(n),w(n)) - do k = 1, n - if( mu == 1 ) then - v(k:n) = this(k:n,k) - if(v(k)<0.0_qp) then - if(present(info)) then - info = k -! return - else - call system_abort('my_potrf: trouble') - endif - endif - v(k:n) = v(k:n) / sqrt(v(k)) - this(k:n,k) = v(k:n) - endif -!$omp barrier - v(k+1:n) = this(k+1:n,k) - do j = k+mu,n,p - w(j:n) = this(j:n,j) - w(j:n) = w(j:n) - v(j)*v(j:n) - this(j:n,j) = w(j:n) - enddo -!$omp barrier - enddo - deallocate(v,w) -!$omp end parallel - - do i = 2, n - do j = 1, i - this(j,i) = this(i,j) - enddo - enddo - - endsubroutine qpotrf - - subroutine LA_Matrix_Inverse(this,inverse,error) - - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(out) :: inverse - integer, optional, intent(out) :: error - - integer :: i, j, info - - INIT_ERROR(error) - - if( this%factorised == NOT_FACTORISED ) then - call LA_Matrix_Factorise(this, error=error) - elseif( this%factorised /= CHOLESKY ) then - RAISE_ERROR('LA_Matrix_Inverse: matrix not Cholesky-factorised',error) - endif - - call check_size('inverse',inverse,shape(this%factor),'LA_Matrix_Inverse',error=error) - PASS_ERROR(error) - - inverse = this%factor - -#if defined(HAVE_QP) || defined(ALBERT_LAPACK) - call qpotri(inverse,info) -#else - call dpotri('U', this%n, inverse, this%n, info) -#endif - - if( info /= 0 ) then - RAISE_ERROR('LA_Matrix_Inverse: cannot invert, error: '//info, error) - endif - - do i = 1, this%n - do j = i+1, this%n - inverse(j,i) = inverse(i,j) - enddo - enddo - - if(this%equilibrated) then - do i = 1, this%n - inverse(:,i) = inverse(:,i)*this%s(:)*this%s(i) - enddo - endif - - endsubroutine LA_Matrix_Inverse - - subroutine qpotri(this,info) - - real(qp), dimension(:,:), intent(inout) :: this - integer, optional, intent(out) :: info - - real(qp), dimension(:,:), allocatable :: one - integer :: i, n - - n = size(this,1) - allocate(one(n,n)) - one = 0.0_qp - do i = 1, n - one(i,i) = 1.0_qp - enddo - call qpotrs(this,one) - this = one - deallocate(one) - - if(present(info)) info = 0 - - endsubroutine qpotri - - subroutine LA_Matrix_Solve_Vector(this,b,x,refine,error) - - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:), intent(in) :: b - real(qp), dimension(:), intent(out) :: x - logical, intent(in), optional :: refine - integer, intent(out), optional :: error - - real(qp), dimension(:,:), allocatable :: my_x - - INIT_ERROR(error) - - if( (size(b) /= this%n) .or. (size(x) /= this%n) ) then - RAISE_ERROR('LA_Matrix_Solve_Vector: length of b or x is not n',error) - endif - - allocate(my_x(this%n,1)) - call LA_Matrix_Solve_Matrix(this,reshape(b,(/this%n,1/)),my_x,refine,error) - x = my_x(:,1) - deallocate(my_x) - - endsubroutine LA_Matrix_Solve_Vector - - subroutine LA_Matrix_Solve_Matrix(this,b,x,refine,error) - - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(in) :: b - real(qp), dimension(:,:), intent(out) :: x - logical, intent(in), optional :: refine - integer, intent(out), optional :: error - - real(qp), dimension(:,:), allocatable :: my_b, my_x - integer :: i, m, info - - logical :: my_refine - - INIT_ERROR(error) - - if( size(b,1) /= this%n ) then - RAISE_ERROR('LA_Matrix_Solve_Matrix: first dimension of b is not n',error) - endif - - my_refine = optional_default(.false.,refine) - - if( this%factorised == NOT_FACTORISED ) then - call LA_Matrix_Factorise(this,error=error) - elseif( this%factorised /= CHOLESKY ) then - call system_abort('LA_Matrix_Solve_Matrix: matrix not Cholesky-factorised') - endif - - m = size(b,2) - allocate(my_b(this%n,m),my_x(this%n,m)) !, work(3*this%n),iwork(this%n),ferr(m), berr(m)) - - if( this%equilibrated ) then - do i = 1, m - my_x(:,i) = b(:,i)*this%s - enddo - my_b = my_x - else - my_x = b - my_b = my_x - endif - -#if defined(HAVE_QP) || defined(ALBERT_LAPACK) - call qpotrs( this%factor, my_x, info ) -#else - call dpotrs( 'U', this%n, m, this%factor, this%n, my_x, this%n, info ) -#endif - - if( this%equilibrated ) then - do i = 1, m - x(:,i) = my_x(:,i)*this%s - enddo - else - x = my_x - endif - - if( info /= 0 ) then - RAISE_ERROR('LA_Matrix_Solve_Matrix: cannot solve, error: '//info, error) - endif - deallocate(my_x,my_b) - - endsubroutine LA_Matrix_Solve_Matrix - - subroutine LA_Matrix_Expand_Symmetrically(this,vector,error) - - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:), intent(in) :: vector - integer, intent(out), optional :: error - - integer :: n, tmp_factorised, info - real(qp) :: scond, u2 - real(qp), dimension(:,:) , allocatable :: tmp_matrix, tmp_factor - real(qp), dimension(:) , allocatable :: tmp_s - - logical :: tmp_equilibrated - - INIT_ERROR(error) - - if( this%n /= this%m ) then - RAISE_ERROR('LA_Matrix_Expand_Symmetrically: matrix not square',error) - endif - - n = size(vector) - if( n /= this%n + 1 ) then - RAISE_ERROR('LA_Matrix_Expand_Symmetrically: expanding vector should be longer by 1 than matrix dimensionality',error) - endif - - allocate(tmp_matrix(this%n+1,this%n+1)) - tmp_matrix(1:this%n,1:this%n) = this%matrix - tmp_matrix(this%n+1,:) = vector - tmp_matrix(:,this%n+1) = vector - - if(this%factorised == CHOLESKY) then - allocate(tmp_factor(this%n,this%n), tmp_s(this%n)) - tmp_factor = this%factor - tmp_s = this%s - endif - - tmp_equilibrated = this%equilibrated - tmp_factorised = this%factorised - - call finalise(this) - - call initialise(this,tmp_matrix) - this%equilibrated = tmp_equilibrated - this%factorised = tmp_factorised - - select case(this%factorised) - case(CHOLESKY) - this%s(1:this%n-1) = tmp_s - this%s(this%n) = 1.0_qp / sqrt(this%matrix(this%n,this%n)) - scond = maxval(this%s) / minval(this%s) - if( this%equilibrated .or. ( scond < 0.1_qp ) ) then - call LA_Matrix_Factorise(this) - else - this%factor(1:this%n-1,1:this%n-1) = tmp_factor - this%factor(1:this%n-1,this%n) = vector(1:this%n-1) - call dtrtrs('L','N','N',this%n-1,1,tmp_factor,this%n-1,this%factor(1:this%n-1,this%n:this%n),this%n-1,info) - if( info /=0 ) then - RAISE_ERROR('LA_Matrix_Expand_Symmetrically: dtrtrs returned an error:'//info,error) - endif - u2 = this%matrix(this%n,this%n) - dot_product(this%factor(1:this%n-1,this%n),this%factor(1:this%n-1,this%n)) - if( u2 < 0.0_qp ) then - RAISE_ERROR('LA_Matrix_Expand_Symmetrically: expanded matrix no longer positive definite',error) - endif - this%factor(this%n,1:this%n-1) = this%factor(1:this%n-1,this%n) - this%factor(this%n,this%n) = sqrt(u2) - endif - case(QR) - call LA_Matrix_QR_Factorise(this) - endselect - - if(allocated(tmp_matrix)) deallocate(tmp_matrix) - if(allocated(tmp_factor)) deallocate(tmp_factor) - if(allocated(tmp_s)) deallocate(tmp_s) - - endsubroutine LA_Matrix_Expand_Symmetrically - - subroutine qpotrs(factor,x, info) - real(qp), dimension(:,:), intent(in) ::factor - real(qp), dimension(:,:), intent(inout) :: x - integer, intent(out), optional :: info - - integer :: n, m, i, j - - n = size(factor,1) - m = size(x,2) -!$omp parallel do - do i = 1, m - do j = 1, n-1 - x(j,i) = x(j,i)/factor(j,j) - x(j+1:n,i) = x(j+1:n,i) - x(j,i)*factor(j+1:n,j) - enddo - x(n,i) = x(n,i)/factor(n,n) - - do j = n, 2, -1 - x(j,i) = x(j,i)/factor(j,j) - x(1:j-1,i) = x(1:j-1,i) - x(j,i)*factor(1:j-1,j) - enddo - x(1,i) = x(1,i)/factor(1,1) - enddo - - if( present(info) ) info = 0 - - endsubroutine qpotrs - - function LA_Matrix_LogDet(this,error) - - type(LA_Matrix), intent(inout) :: this - integer, intent(out), optional :: error - real(qp) :: LA_Matrix_LogDet - integer :: i - - INIT_ERROR(error) - - if( this%factorised == NOT_FACTORISED ) then - call LA_Matrix_Factorise(this,error=error) - endif - - LA_Matrix_LogDet = 0.0_qp - do i = 1, this%m - LA_Matrix_LogDet = LA_Matrix_LogDet + log(abs(this%factor(i,i))) - enddo - - if(this%equilibrated) LA_Matrix_LogDet = LA_Matrix_LogDet - sum( log(this%s) ) - - if( this%factorised == CHOLESKY ) then - LA_Matrix_LogDet = LA_Matrix_LogDet*2 - elseif( this%factorised == QR ) then - LA_Matrix_LogDet = LA_Matrix_LogDet*1 - else - RAISE_ERROR('LA_Matrix_LogDet: matrix not Cholesky-factorised or QR-factorised',error) - endif - - endfunction LA_Matrix_LogDet - - function LA_Matrix_Det(this,error) - - type(LA_Matrix), intent(inout) :: this - integer, intent(out), optional :: error - real(qp) :: LA_Matrix_Det - integer :: i - - INIT_ERROR(error) - - if( this%factorised == NOT_FACTORISED ) then - call LA_Matrix_Factorise(this,error=error) - endif - - LA_Matrix_Det = 1.0_qp - do i = 1, this%n - LA_Matrix_Det = LA_Matrix_Det * this%factor(i,i) - enddo - - if(this%equilibrated) LA_Matrix_Det = LA_Matrix_Det / product( this%s ) - - if( this%factorised == CHOLESKY ) then - LA_Matrix_Det = LA_Matrix_Det**2 - elseif( this%factorised == QR ) then - LA_Matrix_Det = LA_Matrix_Det*1 - else - RAISE_ERROR('LA_Matrix_LogDet: matrix not Cholesky-factorised or QR-factorised',error) - endif - - endfunction LA_Matrix_Det - - subroutine LA_Matrix_QR_Factorise(this,q,r,error) - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(out), optional :: q, r - integer, intent(out), optional :: error - - integer :: info -#ifndef HAVE_QP - real(dp), dimension(:), allocatable :: work - integer :: lwork -#endif - - INIT_ERROR(error) - - this%factor = this%matrix - -#if defined(HAVE_QP) || defined(ALBERT_LAPACK) - call qgeqrf(this%factor,this%tau,info) -#else - - allocate(work(1)) - lwork = -1 - call dgeqrf(this%n, this%m, this%factor, this%n, this%tau, work, lwork, info) - lwork = nint(work(1)) - deallocate(work) - - allocate(work(lwork)) - call dgeqrf(this%n, this%m, this%factor, this%n, this%tau, work, lwork, info) - deallocate(work) -#endif - - if( info /= 0 ) then - RAISE_ERROR('LA_Matrix_QR_Factorise: '//(-info)//'-th parameter had an illegal value.',error) - endif - - this%factorised = QR - - if( present(q) .or. present(r) ) call LA_Matrix_GetQR(this,q,r,error) - - endsubroutine LA_Matrix_QR_Factorise - - subroutine LA_Matrix_GetQR(this,q,r,error) - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(out), optional :: q, r - integer, intent(out), optional :: error - - integer :: j, info -#ifndef HAVE_QP - real(dp), dimension(:), allocatable :: work - integer :: lwork -#endif - - INIT_ERROR(error) - - if( this%factorised /= QR ) then - RAISE_ERROR('LA_Matrix_GetQR: not QR-factorised, call LA_Matrix_QR_Factorise first.',error) - endif - - if(present(q)) then - call check_size('q', q, (/this%n,this%m/),'LA_Matrix_GetQR',error) - q = this%factor - -#if defined(HAVE_QP) || defined(ALBERT_LAPACK) - call qorgqr(this%factor,this%tau,q,info) -#else - allocate(work(1)) - lwork = -1 - call dorgqr(this%n, this%m, this%m, q, this%n, this%tau, work, lwork, info) - lwork = nint(work(1)) - deallocate(work) - - allocate(work(lwork)) - call dorgqr(this%n, this%m, this%m, q, this%n, this%tau, work, lwork, info) - deallocate(work) -#endif - endif - - if(present(r)) then - call check_size('r', r, (/this%m,this%m/),'LA_Matrix_GetQR',error) - r = this%factor(1:this%m,1:this%m) - do j = 1, this%m - 1 - r(j+1:this%m,j) = 0.0_dp - enddo - endif - - if( info /= 0 ) then - RAISE_ERROR('LA_Matrix_QR_Factorise: '//(info)//'-th parameter had an illegal value.',error) - endif - - endsubroutine LA_Matrix_GetQR - - subroutine Fixed_LA_Matrix_QR_Solve_Vector(factor, tau, vector, vec_result) - !supply factor and tau from QR factorisation only - real(dp), dimension(:), intent(in) :: vector - real(dp), dimension(:), intent(out) :: vec_result - real(dp), dimension(:, :), intent(in) :: factor - real(dp), dimension(:), intent(in) :: tau - - integer :: n, m, o, lwork, info, i, j - real(dp), dimension(:), allocatable :: work - real(dp), dimension(:, :), allocatable :: matrix, my_result - !real(dp) :: start, mid, end - - !reshape vector into matrix - n = size(vector) - allocate(matrix(n, 1)) - matrix = reshape(vector,(/n,1/)) - - ! sizes, n is already set - o = 1 - m = size(factor, 2) - - allocate(my_result(n, o)) - my_result = matrix - - ! start = factor(1,1) - - ! copied this directly from LA_Matrix_QR_Solve_Matrix in linearalgebra - lwork = -1 - allocate(work(1)) - call dormqr('L', 'T', n, o, m, factor, n, tau, my_result, n, work, lwork, info) - lwork = nint(work(1)) - deallocate(work) - - !mid = factor(1,1) - - allocate(work(lwork)) - call dormqr('L', 'T', n, o, m, factor, n, tau, my_result, n, work, lwork, info) - deallocate(work) - - !end = factor(1,1) - !print*, "jpd47 in fixed", start, mid, end - ! NOTE WARNING TODO with OMP_NUM_THREADS > 1 factor gets modified between start and end - ! dormqr documentation says that "A is modified by the routine but restored on exit." (A=factor) - - if( info /= 0 ) then - print*, "paramater", info, "had an illegal value" - endif - - do i = 1, o - do j = m, 2, -1 - my_result(j,i) = my_result(j,i)/factor(j,j) - my_result(1:j-1,i) = my_result(1:j-1,i) - my_result(j,i)*factor(1:j-1,j) - enddo - my_result(1,i) = my_result(1,i) / factor(1,1) - enddo - - !result = my_result(1:m,:) - vec_result = my_result(1:m, 1) - deallocate(my_result) - deallocate(matrix) -endsubroutine - - subroutine LA_Matrix_QR_Solve_Matrix(this,matrix,result,error) - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:,:), intent(in) :: matrix - real(qp), dimension(:,:), intent(out) :: result - integer, intent(out), optional :: error - - real(qp), dimension(:,:), allocatable :: my_result - integer :: info, i, j, n, o -#ifndef HAVE_QP - real(dp), dimension(:), allocatable :: work - integer :: lwork -#endif - - INIT_ERROR(error) - - if(this%factorised == NOT_FACTORISED) then - call LA_Matrix_QR_Factorise(this,error=error) - elseif(this%factorised /= QR) then - RAISE_ERROR('LA_Matrix_QR_Solve_Matrix: matrix not QR-factorised',error) - endif - - n = size(matrix,1) - o = size(matrix,2) - call check_size('result', result, (/this%m,o/),'LA_Matrix_QR_Solve_Matrix',error) - - if( n /= this%n ) then - RAISE_ERROR('LA_Matrix_QR_Solve_Matrix: dimensions of Q and matrix do not match.',error) - endif - - allocate(my_result(n,o)) - my_result = matrix -#if defined(HAVE_QP) || defined(ALBERT_LAPACK) - call qormqr(this%factor, this%tau, my_result, info) -#else - lwork = -1 - allocate(work(1)) - call dormqr('L', 'T', this%n, o, this%m, this%factor, this%n, this%tau, my_result, this%n, work, lwork, info) - lwork = nint(work(1)) - deallocate(work) - - allocate(work(lwork)) - call dormqr('L', 'T', this%n, o, this%m, this%factor, this%n, this%tau, my_result, this%n, work, lwork, info) - deallocate(work) -#endif - - if( info /= 0 ) then - RAISE_ERROR('LA_Matrix_QR_QR_Solve_Matrix: '//(-info)//'-th parameter had an illegal value.',error) - endif - - do i = 1, o - do j = this%m, 2, -1 - my_result(j,i) = my_result(j,i)/this%factor(j,j) - my_result(1:j-1,i) = my_result(1:j-1,i) - my_result(j,i)*this%factor(1:j-1,j) - enddo - my_result(1,i) = my_result(1,i) / this%factor(1,1) - enddo - - result = my_result(1:this%m,:) - deallocate(my_result) - - endsubroutine LA_Matrix_QR_Solve_Matrix - - subroutine LA_Matrix_QR_Solve_Vector(this,vector,result,error) - type(LA_Matrix), intent(inout) :: this - real(qp), dimension(:), intent(in) :: vector - real(qp), dimension(:), intent(out) :: result - integer, intent(out), optional :: error - - real(qp), dimension(:,:), allocatable :: my_result - integer :: n, m - - INIT_ERROR(error) - - n = size(vector) - m = size(result) - - allocate(my_result(m,1)) - - call LA_Matrix_QR_Solve_Matrix(this,reshape(vector,(/n,1/)),my_result,error=error) - result = my_result(:,1) - - deallocate(my_result) - - endsubroutine LA_Matrix_QR_Solve_Vector - - subroutine LA_Matrix_QR_Inverse(this,inverse,error) - type(LA_Matrix), intent(inout) :: this - real(dp), dimension(:,:), intent(out) :: inverse - integer, optional, intent(out) :: error - - real(dp), allocatable, dimension(:,:) :: Q, R, R_inv, Q_T - integer i,j,k - - INIT_ERROR(error) - - if (this%n /= this%m) then - RAISE_ERROR('LA_Matrix_QR_inverse: cannot invert non-square matrix',error) - endif - - call check_size('inverse',inverse,shape(this%factor),'LA_Matrix_QR_Inverse',error=error) - PASS_ERROR(error) - - allocate(Q(this%n, this%n), R(this%n, this%n), R_inv(this%n, this%n), Q_T(this%n, this%n)) - - if( this%factorised == NOT_FACTORISED ) then - call LA_Matrix_QR_Factorise(this, error=error) - elseif( this%factorised /= QR ) then - RAISE_ERROR('LA_Matrix_QR_Inverse: matrix not QR-factorised',error) - endif - - call LA_Matrix_GetQR(this, Q, R) - - ! inversion of upper triangular matrix R via back-substitution - R_inv(:,:) = 0.0_dp - do j=1,this%n - do i=1,j-1 - do k=1,j-1 - R_inv(i,j) = R_inv(i,j) + R_inv(i,k)*R(k,j) - end do - end do - do k=1,j-1 - R_inv(k,j) = -R_inv(k,j)/R(j,j) - end do - R_inv(j,j) = 1.0_dp/R(j,j) - end do - - ! A^-1 = (QR)^-1 = R^-1 Q^-1 = R^-1 Q^T - Q_T = transpose(Q) - inverse = matmul(R_inv, Q_T) - - deallocate(Q, R, R_inv, Q_T) - - end subroutine LA_Matrix_QR_inverse - - subroutine LA_Matrix_SVD_Allocate(this,s,u,v,error) - - type(LA_Matrix), intent(in) :: this - real(dp), dimension(:), allocatable, intent(inout), optional :: s - real(dp), dimension(:,:), allocatable, intent(inout), optional :: u, v - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - if(.not.this%initialised) then - RAISE_ERROR('LA_Matrix_SVD: not initialised',error) - endif - - if(present(s)) then - if(allocated(s)) deallocate(s) - allocate(s(min(this%n,this%m))) - endif - - if(present(u)) then - if(allocated(u)) deallocate(u) - if(this%n <= this%m) then - allocate(u(this%n,this%n)) - else - allocate(u(this%n,this%m)) - endif - endif - - if(present(v)) then - if(allocated(v)) deallocate(v) - if(this%n <= this%m) then - allocate(v(this%m,this%n)) - else - allocate(v(this%m,this%m)) - endif - endif - - endsubroutine LA_Matrix_SVD_Allocate - - subroutine LA_Matrix_SVD(this,s,u,v,error) - - type(LA_Matrix), intent(in) :: this - real(dp), dimension(:), intent(out), target, optional :: s - real(dp), dimension(:,:), intent(out), target, optional :: u, v - integer, optional, intent(out) :: error - - real(dp), dimension(:,:), allocatable :: a - real(dp), dimension(:), allocatable :: work - real(dp), dimension(:), pointer :: my_s - real(dp), dimension(:,:), pointer :: my_u, my_vt - real(dp), dimension(1,1), target :: dummy_u, dummy_vt - real(dp) :: tmp - character(len=1) :: jobu, jobvt - integer :: lwork, info, i, j - integer(kind=8) :: lwork_min - - INIT_ERROR(error) - - if(.not.this%initialised) then - RAISE_ERROR('LA_Matrix_SVD: not initialised',error) - endif - - allocate(a(this%n,this%m)) - a = this%matrix - - if(present(s)) then - call check_size('s',s,min(this%n,this%m),'LA_Matrix_SVD',error=error) - my_s => s - else - allocate(my_s(min(this%n,this%m))) - endif - - if(present(u)) then - if(this%n <= this%m) then - call check_size('u',u,(/this%n,this%n/),'LA_Matrix_SVD',error=error) - jobu = "A" - my_u => u - else - call check_size('u',u,(/this%n,this%m/),'LA_Matrix_SVD',error=error) - jobu = "S" - my_u => u - endif - else - jobu = "N" - my_u => dummy_u - endif - - if(present(v)) then - if(this%n <= this%m) then - call check_size('v',v,(/this%m,this%n/),'LA_Matrix_SVD',error=error) - jobvt = "O" - my_vt => dummy_vt - else - call check_size('v',v,(/this%m,this%m/),'LA_Matrix_SVD',error=error) - jobvt = "A" - my_vt => v - endif - else - jobvt = "N" - my_vt => dummy_vt - endif - - allocate(work(1)) - lwork = -1 - call dgesvd(jobu, jobvt, this%n, this%m, a, this%n, my_s, my_u, this%n, my_vt, this%m, work, lwork, info) - if( work(1) > huge(lwork) ) then ! optimal size of work is a bit too large. - ! that's the minimum size of the work array - lwork_min = max( 3*min(this%m, this%n) + max(this%n,this%m), 5*min(this%m,this%n) ) - if( lwork_min > huge(lwork) ) then - RAISE_ERROR("LA_Matrix_SVD: temporary array for SVD would be too large.", error) - else - ! max out the work array - lwork = huge(lwork) - endif - else - ! otherwise just go with the optimum - lwork = ceiling(work(1)) - endif - - deallocate(work) - - allocate(work(lwork)) - call dgesvd(jobu, jobvt, this%n, this%m, a, this%n, my_s, my_u, this%n, my_vt, this%m, work, lwork, info) - deallocate(work) - - if( this%n <= this%m ) then - if(present(v)) then - do i = 1, this%n - do j = 1, this%m - v(j,i) = a(i,j) - enddo - enddo - endif - else - if(present(v)) then - do i = 1, this%m - do j = i+1, this%m - tmp = v(i,j) - v(i,j) = v(j,i) - v(j,i) = tmp - enddo - enddo - endif - endif - - if(allocated(a)) deallocate(a) - my_u => null() - my_vt => null() - - if(present(s)) then - my_s => null() - else - deallocate(my_s) - endif - - if(info < 0) then - RAISE_ERROR('LA_Matrix_SVD: '//(-info)//'-th parameter had an illegal value.',error) - elseif( info > 0) then - RAISE_ERROR('LA_Matrix_SVD: singular value decomposition of the bidiagonal matrix did not converge, '//info//' superdiagonals did not converge to zero.',error) - endif - - endsubroutine LA_Matrix_SVD - - subroutine LA_Matrix_PseudoInverse(this, inverse, error) - type(LA_Matrix), intent(in) :: this - real(dp), dimension(:,:), intent(out) :: inverse - integer, optional, intent(out) :: error - - real(dp), dimension(:), allocatable :: s - real(dp), dimension(:,:), allocatable :: u, v, inverse_tmp - - INIT_ERROR(error) - - if(.not.this%initialised) then - RAISE_ERROR('LA_Matrix_SVD: not initialised',error) - endif - - call check_size('inverse',inverse,(/this%m,this%n/),'LA_Matrix_PseudoInverse',error=error) - - call LA_Matrix_SVD_Allocate(this,s=s,u=u,v=v,error=error) - call LA_Matrix_SVD(this,s=s,u=u,v=v,error=error) - - where(abs(s) > TOL_SVD) - s = 1.0_dp / s - elsewhere - s = 0.0_dp - endwhere - - allocate(inverse_tmp(size(v,1),size(v,2))) - inverse_tmp = v .multd. s - inverse = inverse_tmp .mult. transpose(u) - deallocate(inverse_tmp) - - if(allocated(s)) deallocate(s) - if(allocated(u)) deallocate(u) - if(allocated(v)) deallocate(v) - - endsubroutine LA_Matrix_PseudoInverse - - subroutine house_qp(x,v,beta) - real(qp), dimension(:), intent(in) :: x - real(qp), dimension(size(x)), intent(out) :: v - real(qp), intent(out) :: beta - - integer :: n - real(qp) :: sigma, mu - - n = size(x) - sigma = dot_product(x(2:n),x(2:n)) - v = (/ 1.0_qp, x(2:n) /) - - if( sigma == 0.0_qp ) then - beta = 0.0_qp - else - mu = sqrt(x(1)**2+sigma) - if( x(1) <= 0.0_qp ) then - v(1) = x(1) - mu - else - v(1) = -sigma / (x(1)+mu) - endif - beta = 2.0_qp * v(1)**2 / (sigma + v(1)**2) - v = v / v(1) - endif - - endsubroutine house_qp - - subroutine qgeqrf(a,beta,info) - real(qp), dimension(:,:), intent(inout) :: a - real(qp), dimension(size(a,2)), intent(out) :: beta - integer, intent(out), optional :: info - - integer :: m, n, i, j - real(qp), dimension(:), allocatable :: v, vTa, beta_v - - m = size(a,1) - n = size(a,2) - - allocate(v(m), vTa(n), beta_v(m)) - - do j = 1, n - call house_qp(a(j:m,j),v(j:m),beta(j)) - vTa(j:n) = matmul(v(j:m),a(j:m,j:n)) - beta_v(j:m) = beta(j)*v(j:m) - - do i = j, n - a(j:m,i) = a(j:m,i) - beta_v(j:m)*vTa(i) - enddo - if (j < m) a(j+1:m,j) = v(j+1:m) - enddo - - if( present(info) ) info = 0 - deallocate(v, vTa, beta_v) - - endsubroutine qgeqrf - - subroutine qormqr(a, beta, c, info) - - real(qp), dimension(:,:), intent(in) :: a - real(qp), dimension(size(a,2)), intent(in) :: beta - real(qp), dimension(:,:), intent(inout) :: c - integer, intent(out), optional :: info - - integer :: m, n, q, i, j - real(qp), dimension(:), allocatable :: v, vTc, beta_v - - m = size(a,1) - n = size(a,2) - q = size(c,2) - - allocate(v(m), vTc(q), beta_v(m)) - - do j = 1, n - v(j:m) = (/ 1.0_qp, a(j+1:m,j) /) - vTc = matmul(v(j:m),c(j:m,:)) - beta_v(j:m) = beta(j)*v(j:m) - - do i = 1, q - c(j:m,i) = c(j:m,i) - beta_v(j:m)*vTc(i) - enddo - enddo - - if( present(info) ) info = 0 - deallocate(v, vTc, beta_v) - - endsubroutine qormqr - - subroutine qorgqr(a,beta,q,info) - - real(qp), dimension(:,:), intent(in) :: a - real(qp), dimension(size(a,2)), intent(in) :: beta - real(qp), dimension(:,:), intent(out) :: q - integer, intent(out), optional :: info - - integer :: m, n, i, j - real(qp), dimension(:), allocatable :: v, vTq, beta_v - - m = size(a,1) - n = size(a,2) - - allocate(v(m), vTq(n), beta_v(m)) - - q = 0.0_qp - do j = 1, n - q(j,j) = 1.0_qp - enddo - - do j = n, 1, -1 - v(j:m) = (/1.0_qp, a(j+1:m,j) /) - vTq(j:n) = matmul(v(j:m), q(j:m,j:n)) - beta_v(j:m) = beta(j)*v(j:m) - - do i = j, n - q(j:m,i) = q(j:m,i) - beta_v(j:m)*vTq(i) - enddo - enddo - - if( present(info) ) info = 0 - deallocate(v, vTq, beta_v) - - endsubroutine qorgqr - - subroutine Matrix_CholFactorise(A,A_factor) - - real(dp), dimension(:,:), intent(inout), target :: A - real(dp), dimension(:,:), intent(out), target, optional :: A_factor - - real(dp), dimension(:,:), pointer :: my_A_factor - integer :: i, j, n, info - - if( .not. is_square(A) ) call system_abort('Matrix_CholFactorise: A is not square') - if( present(A_factor) ) call check_size('A_factor',A_factor,shape(A), 'Matrix_CholFactorise') - - n = size(A,1) - - if( present(A_factor) ) then - my_A_factor => A_factor - my_A_factor = A - else - my_A_factor => A - endif - - call dpotrf('U', n, my_A_factor, n, info) - - if( info /= 0 ) call system_abort('Matrix_CholFactorise: cannot factorise, PRINT_ALWAYS: '//info) - - do i = 1, n - do j = i+1, n - my_A_factor(j,i) = 0.0_dp - enddo - enddo - - my_A_factor => null() - - endsubroutine Matrix_CholFactorise - - ! Solve system of linear equations with an already Cholesky-factorised matrix. - subroutine Matrix_BackSubstitute(U,x,b) - - real(dp), dimension(:,:), intent(in) :: U - real(dp), dimension(:), intent(out) :: x - real(dp), dimension(:), intent(in) :: b - - integer :: n, info - - n = size(U,1) - - x = b - - call dpotrs('U', n, 1, U, n, x, n, info) - - if( info /= 0 ) call system_abort('Matrix_BackSubstitute: cannot solve system') - - endsubroutine Matrix_BackSubstitute - - ! Solve system of linear equations with an upper triagonal matrix. - subroutine Matrix_Solve_Upper_Triangular(U,x,b) - - real(dp), dimension(:,:), intent(in) :: U - real(dp), dimension(:), intent(out) :: x - real(dp), dimension(:), intent(in) :: b - - integer :: n, info - - n = size(U,1) - - x = b - - call dtrtrs('U','T','N', n, 1, U, n, x, n, info) - - if( info /= 0 ) call system_abort('Matrix_Solve_Upper_Triangular: cannot solve system') - - endsubroutine Matrix_Solve_Upper_Triangular - - ! Invert an already Cholesky-factorised matrix. - subroutine Matrix_Factorised_Inverse(U,inverse_A) - - real(dp), dimension(:,:), target, intent(inout) :: U - real(dp), dimension(:,:), target, intent(out), optional :: inverse_A - - real(dp), dimension(:,:), pointer :: inverse - integer :: i, j, n, info - - n = size(U,1) - - if( present(inverse_A) ) then - inverse => inverse_A - inverse = U - else - inverse => U - endif - - call dpotri('U', n, inverse, n, info) - - if( info /= 0 ) call system_abort('Matrix_Factorised_Inverse: cannot invert') - - do i = 1, n - do j = i+1, n - inverse(j,i) = inverse(i,j) - enddo - enddo - inverse => null() - - endsubroutine Matrix_Factorised_Inverse - - !% Test if this matrix is diagonal - function is_diagonal(matrix) - real(dp),intent(in), dimension(:,:) :: matrix - logical :: is_diagonal - - integer :: i,j - - if (.not. is_square(matrix)) call system_abort('Matrix_diagonal: matrix not squared') - - do i=1,size(matrix,1) - do j=1,size(matrix,2) - if (i == j) cycle - if (matrix(i,j) .fne. 0.0_dp) then - is_diagonal = .false. - return - end if - end do - end do - - is_diagonal = .true. - - end function is_diagonal - - ! matrix_is_symmetric(matrix) - ! - ! tells if tha matrix is symmetric - function matrix_is_symmetric(matrix) result(symm) - real(dp),intent(in), dimension(:,:):: matrix - logical::symm - integer::i,j,N - - real(dp) :: maxv - - if (.not.Is_Square(matrix)) & - call system_abort('Matrix_Is_Symmetric: Matrix is not square') - - maxv = maxval(abs(matrix)) - N=size(matrix,1) - symm=.true. - do i=1,N - do j=i+1,N - if (abs(matrix(i,j)-matrix(j,i)) > NUMERICAL_ZERO*maxv) then - symm=.false. - return - end if - enddo - enddo - - end function matrix_is_symmetric - - ! matrix_is_symmetric(matrix) - ! - ! tells if the matrix is symmetric - function int_matrix_is_symmetric(matrix) result(symm) - - integer, intent(in), dimension(:,:):: matrix - logical::symm - integer::i,j,N - - if (.not.is_square(matrix)) & - call system_abort('is_symmetric: Matrix is not square') - - N=size(matrix,1) - symm=.true. - do i=1,N - do j=i+1,N - if (matrix(j,i) /= matrix(i,j)) then - symm=.false. - return - end if - enddo - enddo - - end function int_matrix_is_symmetric - - ! matrix_z_is_symmetric(matrix) - ! - ! tells if the matrix is symmetric - function matrix_z_is_symmetric(matrix) result(symm) - complex(dp),intent(in), dimension(:,:):: matrix - logical::symm - integer::i,j,N - - real(dp) :: maxv - - if (.not.Is_Square(matrix)) & - call system_abort('Matrix_Is_Symmetric: Matrix is not square') - - maxv = maxval(abs(matrix)) - - N=size(matrix,1) - symm=.true. - do i=1,N - do j=i+1,N - if (abs(matrix(j,i)-matrix(i,j)) > maxv*NUMERICAL_ZERO ) then - symm=.false. - return - end if - enddo - enddo - - end function matrix_z_is_symmetric - - ! matrix_z_is_hermitian(matrix) - ! - ! tells if tha matrix is hermitian - function matrix_z_is_hermitian(matrix) result(herm) - complex(dp),intent(in), dimension(:,:):: matrix - - logical::herm - integer::i,j,N - - real(dp) :: maxv - - if (.not.Is_Square(matrix)) & - call system_abort('Matrix_Is_Symmetric: Matrix is not square') - - maxv = maxval(abs(matrix)) - N=size(matrix,1) - herm=.true. - do i=1,N - do j=i,N - if (abs(matrix(j,i)-conjg(matrix(i,j))) > maxv*NUMERICAL_ZERO) then - herm=.false. - return - end if - enddo - enddo - - end function matrix_z_is_hermitian - - function matrix_is_orthogonal(matrix) - real(dp),intent(in), dimension(:,:):: matrix - logical :: matrix_is_orthogonal - real(dp) :: t(size(matrix,1), size(matrix,2)), identity(size(matrix,1),size(matrix,2)) - - if (.not.Is_Square(matrix)) & - call system_abort('Matrix_Is_Symmetric: Matrix is not square') - - t = matrix .mult. transpose(matrix) - identity = 0.0_dp - call add_identity(identity) - matrix_is_orthogonal = maxval(abs(t - identity)) < maxval(matrix)*NUMERICAL_ZERO - - end function matrix_is_orthogonal - - ! print(matrix) - ! printing - - subroutine matrix_print_mainlog(this, verbosity) - real(dp),intent(in),dimension(:,:) :: this - integer, optional::verbosity - call matrix_print(this,verbosity,mainlog) - end subroutine matrix_print_mainlog - - subroutine matrix_z_print_mainlog(this, verbosity) - complex(dp),intent(in),dimension(:,:) :: this - integer, optional::verbosity - call matrix_z_print(this,verbosity,mainlog) - end subroutine matrix_z_print_mainlog - - subroutine int_matrix_print_mainlog(this, verbosity) - integer,intent(in),dimension(:,:) :: this - integer, optional::verbosity - call int_matrix_print(this,verbosity,mainlog) - end subroutine int_matrix_print_mainlog - - subroutine int_matrix_print(this,verbosity,file) - - integer, dimension(:,:), intent(in) :: this - integer, optional, intent(in) :: verbosity - type(inoutput), intent(in) :: file - - integer :: i,N,M,w - character(20) :: format - - w = int(log10(real(maxval(abs(this))+1,dp)))+3 ! leave at least one space between entries, including room for neg. sign - N = size(this,1) - M = size(this,2) - write(format,'(2(a,i0),a)')'(',M,'i',w,')' - - do i = 1, N - write(line,format) this(i,:) - call print(line,verbosity,file) - end do - - end subroutine int_matrix_print - - ! print real matrix to file, either one entry per line (always == .true.) or as a block with restrictions - subroutine matrix_print(this,verbosity,file, always) - real(dp), intent(in), dimension(:,:) :: this - type(inoutput), intent(in) :: file - integer, optional, intent(in) :: verbosity - logical, optional, intent(in) :: always - - integer :: i, n, w, j - logical :: t - character(20) :: format - integer :: max_size = 5 - integer :: absolute_max_width = 50 - logical :: do_always - - do_always = optional_default(.false., always) - - if (do_always) then - do i=1, size(this,2) - do j=1, size(this,1) - call print(j // " " // i // " " // this(j,i), verbosity, file) - end do - end do - else - - if (size(this,2) > max_size .and. size(this,1) <= max_size) then - w = size(this,1) - n = size(this,2) - t = .true. - else - w = size(this,2) - n = size(this,1) - t = .false. - end if - - if (w > absolute_max_width) then - call print('Matrix_print: matrix is too large to print', verbosity, file) - return - end if - - if (t) then - write (line, '(a)') 'Matrix_Print: printing matrix transpose' - call print(line,verbosity,file) - endif - - write(format,'(a,i0,a)')'(',w,'(1x,f18.10))' - - do i=1,n - if (t) then - write(line,format) this(:,i) - else - write(line,format) this(i,:) - end if - call print(line,verbosity,file) - end do - - end if - - end subroutine matrix_print - - subroutine matrix_z_print(this,verbosity,file) - type(inoutput), intent(in) :: file - complex(dp), intent(in), dimension(:,:) :: this - integer, optional :: verbosity - integer :: i, n, w - logical :: t - character(200) :: format - integer :: max_size = 6 - - if (size(this,2) > max_size .and. size(this,1) <= max_size) then - w = size(this,1) - n = size(this,2) - t = .true. - else - w = size(this,2) - n = size(this,1) - t = .false. - end if - - -! if (w > 60) then -! write(line,'(a,i0,a,i0,a)')'Matrix_z_Print: Both dimensions (',w,',',n,') are too large to print' -! call system_abort(line) -! end if - - if (t) then - write(line, '(a)') 'Matrix_z_Print: printing transpose' - call print(line,verbosity,file) - endif - - write(format,'(a,i0,a)')'(',w,'(x,f12.6,"+I*",f12.6))' - - do i=1,n - if (t) then - write(line,format) this(:,i) - else - write(line,format) this(i,:) - end if - call print(line,verbosity,file) - end do - - end subroutine matrix_z_print - - subroutine matrix_print_mathematica(label, this, verbosity, file) - character(len=*), intent(in) :: label - real(dp), intent(in), dimension(:,:) :: this - integer, optional :: verbosity - type(inoutput), intent(in), optional :: file - - integer i, j - - call print(trim(label)//" = { ", verbosity, file) - do i=1, size(this,1) - call print ("{", verbosity, file) - do j=1, size(this,1) - if (j == size(this,1)) then - call print(this(i,j), verbosity, file) - else - call print(this(i,j)//", ", verbosity, file) - endif - end do - if (i == size(this,1)) then - call print ("}", verbosity, file) - else - call print ("},", verbosity, file) - endif - end do - call print ("};", verbosity, file) - end subroutine matrix_print_mathematica - - subroutine matrix_z_print_mathematica(label, this, verbosity, file) - character(len=*), intent(in) :: label - complex(dp), intent(in), dimension(:,:) :: this - integer, optional :: verbosity - type(inoutput), intent(in), optional :: file - - integer i, j - - call print(trim(label)//" = { ", verbosity, file) - do i=1, size(this,1) - call print ("{", verbosity, file) - do j=1, size(this,1) - if (j == size(this,1)) then - call print(real(this(i,j), dp) // " + I*"//aimag(this(i,j)), verbosity, file) - else - call print(real(this(i,j), dp) // " + I*"//aimag(this(i,j))//", ", verbosity, file) - endif - end do - if (i == size(this,1)) then - call print ("}", verbosity, file) - else - call print ("},", verbosity, file) - endif - end do - call print ("};", verbosity, file) - end subroutine matrix_z_print_mathematica - - !% Returns reciprocal condtion number of matrix A using norm - function matrix_condition_number(A, norm) result(rcond) - real(dp), intent(in) :: A(:,:) - character, intent(in) :: norm !% 1 or O: 1-norm, I: inf-norm - real(dp) :: rcond - - integer :: m, n, minmn, lda, info - real(dp) :: anorm - integer, allocatable :: ipiv(:), iwork(:) - real(dp), allocatable :: work(:) - real(dp), allocatable :: Acopy(:,:) - - real(dp), external :: dlange - - rcond = -1.0_dp - - m = size(A, 1) - n = size(A, 2) - lda = m - - allocate(Acopy(m,n)) - Acopy = A - - allocate(work(m)) - anorm = dlange(norm, m, n, Acopy, lda, work) - deallocate(work) - - minmn = min(m, n) - allocate(ipiv(minmn)) - call dgetrf(m, n, Acopy, lda, ipiv, info) - deallocate(ipiv) - - allocate(work(4 * n)) - allocate(iwork(n)) - call dgecon(norm, n, Acopy, lda, anorm, rcond, work, iwork, info) - end function matrix_condition_number - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X -!X Polynomial fitting to boundary conditions -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! - !% Fit a cubic polynomial to a function given its values ($y_0$ and $y_1$) and - !% its derivative ($y^\prime_0$ and $y^\prime_1$) at two points ($x_0$ and $x_1$) - ! - !% \begin{displaymath} - !% y = ax^3 + bx^2 + cx + d - !% \end{displaymath} - ! - subroutine fit_cubic(x0,y0,y0p,x1,y1,y1p,coeffs) - - real(dp), intent(in) :: x0,y0,y0p !% $x_0$, $y_0$, $y^\prime_0$ - real(dp), intent(in) :: x1,y1,y1p !% $x_1$, $y_1$, $y^\prime_1$ - real(dp), intent(out) :: coeffs(4) !% '(/a,b,c,d/)' - real(dp), dimension(4,4) :: A, invA - real(dp) :: x02, x03, x12, x13 !x0^2, x0^3 ... - - x02 = x0*x0; x03 = x02*x0 - x12 = x1*x1; x13 = x12*x1 - - A = reshape( (/ x03, x13, 3.0_dp*x02, 3.0_dp*x12, & - x02, x12, 2.0_dp*x0, 2.0_dp*x1, & - x0, x1, 1.0_dp, 1.0_dp, & - 1.0_dp, 1.0_dp, 0.0_dp, 0.0_dp /),(/4,4/) ) - - call matrix_inverse(A,invA) - - coeffs = invA .mult. (/y0,y1,y0p,y1p/) - - end subroutine fit_cubic - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X -!X VECTOR stuff -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! normsq() - ! returns (X.dot.X) - pure function vector_normsq(vector) result(normsq) - - real(dp), intent(in), dimension(:) :: vector - real(dp) :: normsq - - normsq = dot_product(vector,vector) - - end function vector_normsq - - pure function vector_normsq_q(vector) result(normsq) - - real(qp), intent(in), dimension(:) :: vector - real(qp) :: normsq - - normsq = dot_product(vector,vector) - - end function vector_normsq_q - - ! norm() - ! returns SQRT((X.dot.X)) - pure function vector_norm(vector) result(norm) - - real(dp), intent(in),dimension(:) :: vector - real(dp) :: norm - - norm = sqrt(dot_product(vector,vector)) - - end function vector_norm - - - ! x .dot. y - pure function vector_dotpr(this,other) result(dotpr) - - real(dp), intent(in), dimension(:) :: this,other - real(dp) :: dotpr - - dotpr = dot_product(this,other) - - end function vector_dotpr - - - !% Return the (smallest) angle between two vectors, in radians. - !% This is calculated as - !%\begin{displaymath} - !%\arccos\left(\frac{\mathbf{a}\cdot\mathbf{b}}{|\mathbf{a}| |\mathbf{b}|}\right) - !%\end{displaymath} - pure function angle(a,b) - - real(dp), dimension(:), intent(in) :: a,b - real(dp) :: angle - real(dp) :: arg - - arg = (a .dot. b)/(norm(a)*norm(b)) - if (arg > 1.0_dp) then - arg = 1.0_dp - else if (arg < -1.0_dp) then - arg = -1.0_dp - end if - - angle = acos(arg) - - end function angle - - ! x .outer. y - pure function outer(vector1,vector2) result(outr) - real(dp),intent(in), dimension(:) ::vector1,vector2 - real(dp), dimension(size(vector1),size(vector2)) ::outr - integer::i,j - - do j=1,size(vector2) - do i=1,size(vector1) - outr(i,j)=vector1(i)*vector2(j) - end do - end do - - end function outer - - pure function outer_qq(vector1,vector2) result(outr) - real(qp),intent(in), dimension(:) ::vector1,vector2 - real(qp), dimension(size(vector1),size(vector2)) ::outr - integer::i,j - - do j=1,size(vector2) - do i=1,size(vector1) - outr(i,j)=vector1(i)*vector2(j) - end do - end do - - end function outer_qq - - ! x .outer. y - pure function d_outer_zz(vector1,vector2) result(outr) - complex(dp),intent(in), dimension(:) ::vector1,vector2 - real(dp), dimension(size(vector1),size(vector2)) ::outr - integer::i,j - - do j=1,size(vector2) - do i=1,size(vector1) - outr(i,j)=vector1(i)*conjg(vector2(j)) - end do - end do - - end function d_outer_zz - - ! x .outer. y - pure function z_outer_zz(vector1,vector2) result(outr) - complex(dp),intent(in), dimension(:) ::vector1,vector2 - complex(dp), dimension(size(vector1),size(vector2)) :: outr - integer::i,j - - do j=1,size(vector2) - do i=1,size(vector1) - outr(i,j)=vector1(i)*conjg(vector2(j)) - end do - end do - - end function z_outer_zz - - - !% Return the square root of 'r' if it is positive, or zero otherwise. - elemental function sqrt_cut(r) - real(dp),intent(in)::r - real(dp)::sqrt_cut - sqrt_cut = sqrt(max(0.0_dp,r)) - end function sqrt_cut - - - ! v1 .feq. v2 - ! - !floating point logical comparison - function vector_feq(vector1,vector2) - real(dp),intent(in), dimension(:) ::vector1,vector2 - logical::vector_feq - integer::i - - if(size(vector1) /= size(vector2)) & - call check_size('Vector2',vector2,size(vector1),'Vector_FEQ') - - vector_feq=.true. - do i=1,size(vector1) - if (vector1(i).fne.vector2(i)) then - vector_feq=.false. - return - end if - end do - - end function vector_feq - - ! v1 .fne. v2 - ! - function vector_fne(vector1,vector2) - real(dp),intent(in), dimension(:) :: vector1,vector2 - logical::vector_fne - integer::i - - if(size(vector1) /= size(vector2)) & - call check_size('Vector2',vector2,size(vector1),'Vector_FNE') - - vector_fne=.false. - do i=1,size(vector1) - if (vector1(i).fne.vector2(i)) then - vector_fne=.true. - return - end if - end do - - end function vector_fne - - - !printing - subroutine vector_print_mainlog(this, verbosity) - real(dp),intent(in), dimension(:) :: this - integer, optional::verbosity - call vector_print(this,verbosity,mainlog) - end subroutine vector_print_mainlog - - subroutine vector_print(this,verbosity,file) - real(dp),intent(in), dimension(:) :: this - type(inoutput) :: file - integer, optional :: verbosity - integer :: nbloc,i,nrest - - nbloc=size(this)/5 - nrest=mod(size(this),5) - - do i=1,nbloc - call print(""//this((i-1)*5+1:(i-1)*5+5), verbosity, file) - end do - if (nrest /= 0) then - call print(""//this((i-1)*5+1:(i-1)*5+nrest),verbosity,file) - end if - - end subroutine vector_print - - subroutine vector_z_print_mainlog(this,verbosity) - complex(dp),intent(in), dimension(:) ::this - integer, optional::verbosity - call vector_z_print(this,verbosity,mainlog) - end subroutine vector_z_print_mainlog - - subroutine vector_z_print(this,verbosity,file) - complex(dp),intent(in), dimension(:) :: this - type(inoutput) :: file - integer, optional::verbosity - integer:: nbloc,i,nrest - - nbloc=size(this)/5 - nrest=mod(size(this),5) - - do i=1,nbloc - call print(""//this((i-1)*5+1:(i-1)*5+5), verbosity, file) - end do - if (nrest /= 0) then - call print(""//this((i-1)*5+1:(i-1)*5+nrest), verbosity, file) - end if - - end subroutine vector_z_print - - subroutine integer_array_print_mainlog(this, verbosity) - integer,intent(in), dimension(:) ::this - integer, optional::verbosity - call integer_array_print(this,verbosity,mainlog) - end subroutine integer_array_print_mainlog - - subroutine integer_array_print(this,verbosity,file) - integer,intent(in), dimension(:) ::this - type(inoutput)::file - integer, optional::verbosity - integer:: nbloc,i,nrest - character(20)::form - - nbloc=size(this)/5 - nrest=mod(size(this),5) - - do i=1,nbloc - write(line,'(5i12)')this((i-1)*5+1:(i-1)*5+5) - call print(line,verbosity,file) - end do - if (nrest /= 0) then - write(form,'(a,i0,a)') '(',nrest,'i12)' - write(line,form)this((i-1)*5+1:(i-1)*5+nrest) - call print(line,verbosity,file) - end if - - end subroutine integer_array_print - - subroutine logical_array_print_mainlog(this, verbosity) - logical,intent(in), dimension(:) ::this - integer, optional::verbosity - call logical_array_print(this,verbosity,mainlog) - end subroutine logical_array_print_mainlog - - subroutine logical_array_print(this,verbosity,file) - logical,intent(in), dimension(:) ::this - type(inoutput)::file - integer, optional::verbosity - integer:: nbloc,i,nrest - character(20)::form - - nbloc=size(this)/5 - nrest=mod(size(this),5) - - do i=1,nbloc - write(line,'(5l2)')this((i-1)*5+1:(i-1)*5+5) - call print(line,verbosity,file) - end do - if (nrest /= 0) then - write(form,'(a,i0,a)') '(',nrest,'l2)' - write(line,form)this((i-1)*5+1:(i-1)*5+nrest) - call print(line,verbosity,file) - end if - - end subroutine logical_array_print - - subroutine logical_matrix_print_mainlog(this, verbosity) - logical, intent(in),dimension(:,:) :: this - integer, optional :: verbosity - call logical_matrix_print(this,verbosity,mainlog) - end subroutine logical_matrix_print_mainlog - - subroutine logical_matrix_print(this,verbosity,file) - - logical, dimension(:,:), intent(in) :: this - integer, optional, intent(in) :: verbosity - type(inoutput), intent(in) :: file - - integer :: i,N,M - character(20) :: format - - N = size(this,1) - M = size(this,2) - write(format,'(a,i0,a)')'(',M,'L3)' - - do i = 1, N - write(line,format) this(i,:) - call print(line,verbosity,file) - end do - - end subroutine logical_matrix_print - - ! add to vector elements, random quantities in the range(-a/2,a/2) - subroutine vector_randomise(v,a) - real(dp), intent(inout), dimension(:) :: v - real(dp), intent(in) :: a - - integer :: i - do i=1,size(v) - v(i)=v(i)+(ran_uniform()-0.5_dp)*a - end do - end subroutine vector_randomise - - ! add to complex vector elements, random quantities in the range(-a/2,a/2) - subroutine vector_z_randomise(v,a) - complex(dp), intent(inout), dimension(:) :: v - real(dp), intent(in) :: a - - integer :: i - do i=1,size(v) - v(i)=v(i)+cmplx((ran_uniform()-0.5_dp)*a/sqrt(2.0_dp), (ran_uniform()-0.5_dp)*a/sqrt(2.0_dp)) - end do - end subroutine vector_z_randomise - - ! - !% Return a three vector with normally distributed components - ! - function ran_normal3() - real(dp), dimension(3) :: ran_normal3 - ran_normal3(1) = ran_normal() - ran_normal3(2) = ran_normal() - ran_normal3(3) = ran_normal() - end function ran_normal3 - - - ! returns a vector, contining a histogram of frequencies - function vector_histogram(vector,min_x,max_x,Nbin,weight_vector, drop_outside) - - real(dp), dimension(:), intent(in) :: vector - real(dp), intent(in) :: min_x, max_x - integer, intent(in) :: Nbin - real(dp), dimension(:), intent(in), optional :: weight_vector - logical, optional, intent(in) :: drop_outside - real(dp), dimension(Nbin) :: vector_histogram - !local variables - real(dp) :: binsize - integer :: i, bin - logical :: do_drop_outside - - if(max_x <= min_x) then - call system_abort('Vector_Histogram: max_x < min_x') - end if - - do_drop_outside = optional_default(.false., drop_outside) - - binsize=(max_x-min_x)/(real(Nbin,dp)) - vector_histogram = 0.0_dp - - do i=1,size(vector) - - bin = ceiling((vector(i)-min_x)/binsize) - if (do_drop_outside) then - if (bin < 1 .or. bin > Nbin) cycle - else - if (bin < 1) bin = 1 - if (bin > Nbin) bin = Nbin - endif - if (present(weight_vector)) then - vector_histogram(bin) = vector_histogram(bin) + weight_vector(i) - else - vector_histogram(bin) = vector_histogram(bin) + 1.0_dp - endif - - end do - - end function vector_histogram - - ! Root-Mean-Square difference between elements of two vectors - - !% For two vectors of $N$ dimensions, this is calculated as - !%\begin{displaymath} - !%\sum_{i=1}^{N} \left(\mathbf{v_1}_i - \mathbf{v_2}_i\right)^2 - !%\end{displaymath} - function rms_diff1(vector1, vector2) - real(dp), dimension(:), intent(in) :: vector1, vector2 - real(dp) :: rms_diff1, d - integer :: i - if(size(vector1) /= size(vector2)) & - call check_size('Vector 2',vector2,shape(vector1),'RMS_diff') - rms_diff1 = 0.0_dp - do i = 1, size(vector1) - d = vector1(i) - vector2(i) - rms_diff1 = rms_diff1 + d * d - end do - rms_diff1 = rms_diff1 / real(size(vector1),dp) - rms_diff1 = sqrt(rms_diff1) - end function rms_diff1 - - - !% OMIT - function array_dotprod(this,other, dir) result(c) - real(dp),intent(in), dimension(:,:) :: this,other - integer, intent(in)::dir - real(dp)::c(size(this,3-dir)) - integer::i - - - call check_size('this, other',this,shape(other),'Array_Dotprod') - - if(dir==1) then - do i=1,size(this,2) - c(i)=sqrt(dot_product(this(:,i),other(:,i))) - end do - else if(dir==2) then - do i=1,size(this,1) - c(i)=sqrt(dot_product(this(i,:),other(i,:))) - end do - else - call system_abort('array_dotprod: dir must be 1 or 2') - end if - - end function array_dotprod - - - ! normsq of each vector - function array_normsq(this, dir) - real(dp), dimension(:,:) ::this - integer, intent(in)::dir - real(dp)::array_normsq(size(this,3-dir)) - integer::i - - if(dir==1) then - do i=1,size(this,2) - array_normsq(i)=dot_product(this(:,i),this(:,i)) - end do - else if(dir==2) then - do i=1,size(this,1) - array_normsq(i)=dot_product(this(i,:),this(i,:)) - end do - else - call system_abort('array_normsq: dir must be 1 or 2') - end if - end function array_normsq - - ! norm for each vector - function array_norm(this, dir) result(sqvalue) - real(dp),intent(in), dimension(:,:) :: this - integer, intent(in)::dir - real(dp)::sqvalue(size(this,3-dir)) - integer::i - - if(dir==1) then - do i=1,size(this,2) - sqvalue(i)=sqrt(dot_product(this(:,i),this(:,i))) - end do - else if(dir==2) then - do i=1,size(this,1) - sqvalue(i)=sqrt(dot_product(this(i,:),this(i,:))) - end do - else - call system_abort('array_norm: dir must be 1 or 2') - end if - end function array_norm - - - !% Return a list of scalar triple products for each triplet of vectors from 'a', 'b' and 'c', i.e. - !%> array3_triple(i) = a(:,i) .dot. (b(:,i) .cross. c(:,i))'. - function array3_triple(a,b,c) - real(dp),intent(in), dimension(:,:) ::a, b, c - real(dp)::array3_triple(size(a,2)) - integer::n,m,i - n=size(a,1) - m=size(a,2) - - call check_size('B',b,shape(a),'Array3_Triple') - call check_size('C',c,shape(a),'Array3_Triple') - - do i = 1,m - array3_triple(i) = scalar_triple_product(a(:,i),b(:,i),c(:,i)) - end do - - end function array3_triple - - - ! add random values to the elements of an array in the range(-a/2,a/2) - subroutine matrix_randomise(m,a) - real(dp), dimension(:,:), intent(inout) ::m - real(dp)::a - !local - integer::i,j - - do i=1,size(m,1) - do j=1,size(m,2) - m(i,j)=m(i,j)+(ran_uniform()-0.5_dp)*a - end do - end do - - end subroutine matrix_randomise - - subroutine matrix_z_randomise(m,a) - complex(dp), dimension(:,:), intent(inout) ::m - real(dp)::a - !local - integer::i,j - - do i=1,size(m,1) - do j=1,size(m,2) - m(i,j)=m(i,j)+cmplx((ran_uniform()-0.5_dp)*a/sqrt(2.0_dp), (ran_uniform()-0.5_dp)*a/sqrt(2.0_dp)) - end do - end do - - end subroutine matrix_z_randomise - - ! add to matrix elements, random quantities in the range(-a/2,a/2) - subroutine matrix_randomise_vweight(m,a) - real(dp), intent(inout), dimension(:,:) :: m - real(dp), intent(in) :: a(:) - - integer :: i,j - - if (size(m,2) /= size(a)) & - call system_abort("matrix_randomise_vweight incompatible sizes : m " // shape(m) // " a " // shape(a)) - do i=1,size(m,1) - do j=1,size(m,2) - m(i,j)=m(i,j)+(ran_uniform()-0.5_dp)*a(j) - end do - end do - end subroutine matrix_randomise_vweight - - !% For two arrays of dimension $N \times M$, this is calculated as - !%\begin{displaymath} - !%\sum_{j=1}^{M} \sum_{i=1}^{N} \left(\mathbf{a_1}_{ij} - \mathbf{a_2}_{ij}\right)^2 - !%\end{displaymath} - function rms_diff2(array1, array2) - real(dp), dimension(:,:), intent(in) :: array1, array2 - real(dp) :: rms_diff2, d - integer :: i,j - call check_size('Array 2',array2,shape(array1),'rms_diff') - rms_diff2 = 0.0_dp - do j = 1, size(array1,2) - do i = 1, size(array1,1) - d = array1(i,j) - array2(i,j) - rms_diff2 = rms_diff2 + d * d - end do - end do - rms_diff2 = rms_diff2 / real(size(array1),dp) - rms_diff2 = sqrt(rms_diff2) - end function rms_diff2 - - - ! --------------------------------- - ! - ! 3-vector procedures - ! - - pure function cross_product(x,y) ! x ^ y - - real(dp), dimension(3), intent(in):: x,y - real(dp), dimension(3) :: cross_product - - cross_product(1) = + ( x(2)*y(3) - x(3)*y(2) ) - cross_product(2) = - ( x(1)*y(3) - x(3)*y(1) ) - cross_product(3) = + ( x(1)*y(2) - x(2)*y(1) ) - - end function cross_product - - !% Return the scalar triple product $\mathbf{x} \cdot \mathbf{y} \times \mathbf{z}$ - !% of the 3-vectors 'x', 'y' and 'z'. - pure function scalar_triple_product(x,y,z) ! [x,y,z] - - real(dp), dimension(3), intent(in) :: x,y,z - real(dp) :: scalar_triple_product - - scalar_triple_product = + x(1) * ( y(2)*z(3) - y(3)*z(2) ) & - - x(2) * ( y(1)*z(3) - y(3)*z(1) ) & - + x(3) * ( y(1)*z(2) - y(2)*z(1) ) - - end function scalar_triple_product - - !% Return the vector triple product $\mathbf{x} \times (\mathbf{y} \times \mathbf{z})$ - !% of the 3-vectors 'x', 'y' and 'z'. - pure function vector_triple_product(x,y,z) ! x ^ (y ^ z) = y(x.z) - z(x.y) - - real(dp), dimension(3), intent(in) :: x,y,z - real(dp), dimension(3) :: vector_triple_product - - vector_triple_product = y * (x.dot.z) - z * (x.dot.y) - - end function vector_triple_product - - ! - !% Return a unit vector in the direction given by the angles 'theta' and 'phi', i.e. - !% convert the spherical polar coordinates point $(1,\theta,\phi)$ to cartesians. - ! - pure function unit_vector(theta,phi) - - real(dp), intent(in) :: theta, phi - real(dp), dimension(3) :: unit_vector - - unit_vector(1) = sin(theta)*cos(phi) - unit_vector(2) = sin(theta)*sin(phi) - unit_vector(3) = cos(theta) - - end function unit_vector - - ! - !% Returns a random unit vector which is - !% uniformly distributed over the unit sphere - !% [See Knop, CACM 13 326 (1970)]. - ! - function random_unit_vector() result(v) - real(dp), dimension(3) :: v - real(dp) :: x,y,z,s - - !Find a point in the unit circle - s = 1.1_dp - do while(s > 1.0_dp) - x = 2.0_dp * ran_uniform() - 1.0_dp - y = 2.0_dp * ran_uniform() - 1.0_dp - s = x*x + y*y - end do - - !z must be uniform in [-1,1]. s is uniform in [0,1] - z = 2.0_dp * s - 1.0_dp - - !x and y are constrained by normalisation - s = sqrt((1-z*z)/s) - x = x*s - y = y*s - - v = (/x,y,z/) - - end function random_unit_vector - - - ! INTERPOLATION - - !% Linearly interpolate between the points $(x_0,y_0)$ and $(x_1,y_1)$. - !% Returns the interpolated $y$ at position $x$, where $x_0 \le x \le x_1$. - pure function linear_interpolate(x0,y0,x1,y1,x) result(y) - real(dp), intent(in) :: x0,y0,x1,y1,x - real(dp) :: y - y = y0 + (y1-y0)*(x-x0)/(x1-x0) - end function linear_interpolate - - !% Perform a cubic interpolation between the points $(x_0,y_0)$ and $(x_1,y_1)$, - !% using the cubic function with zero first derivative at $x_0$ and $x_1$. - !% Returns the interpolated $y$ at position $x$, where $x_0 \le x \le x_1$. - pure function cubic_interpolate(x0,y0,x1,y1,x) result(y) - real(dp), intent(in) :: x0,y0,x1,y1,x - real(dp) :: u,v,w,y - u = (x-x0)/(x1-x0) ! relative co-ordinate - v = u * u - w = 3*v - 2*v*u ! w = 3u^2-2u^3 - y = y0 + (y1-y0)*w - end function cubic_interpolate - - - - !%OMIT - subroutine matrix_test() - real(dp),allocatable ::a(:,:),b(:,:),c(:,:),vect1(:),vect2(:),d(:,:) - real(dp)::tmp - write(line,*) 'A is a 2x2 matrix:'; call print(line) - allocate(a(2,2)) - !b=a assigment dosnt work !make subroutine - a=3 - call print(a) - write(line,*) 'Vect1 is a vector of 3 elements:'; call print(line) - allocate(vect1(3),vect2(3)) - vect1=3 - call print(vect1) - - allocate(b(3,3)) - write(line,*) 'If we assign it to the matrix b:'; call print(line) - b=diag(vect1) - call print(b) - write(line,*) 'Now the product of b * vect1:'; call print(line) - !works, but you have to initialise the result - vect2=b.mult.vect1 - call print(vect2) - - !works - - write(line,*) 'The result can be directly assigned to b that becomes:'; call print(line) - b=b.multd.vect1 - call print(b) - - write(line,*) 'The scalar product b.dot. b is :'; call print(line) - !works - tmp=b.dot.b - write(line,*) tmp; call print(line) - call print(line) - - ! works - write(line,*) 'Now b=:'; call print(line) - b=1 - b(1,2)=5 - b(3,1)=0 - b(2,2)=2 - call print(b) - - write(line,*) 'The rowcol product b*b is'; call print(line) - call print(b.mult.b) - write(line,*) 'For comparison: The matmul says that'; call print(line) - allocate(d(size(b,1),size(b,2))) - d=matmul(b,b) - call print(d) - write(line,*) 'Now b=:'; call print(line) - ! transposition works - b(1,2)=-1 - call print(b) - write(line,*) 'Transposing:'; call print(line) - b=transpose(b) - call print(b) - - !works - write(line,*) 'And Symmetrise:'; call print(line) - call matrix_symmetrise(b) - call print(b) - - allocate(c(3,3)) - - c=b -#ifndef useintrinsicblas - write(line,*) 'Eigenproblem of b?:'; call print(line) - ! works - call matrix_diagonalise(b,vect1,c) - write(line,*) 'Eigenvectors:'; call print(line) - call print(c) - write(line,*) 'Eigenvalues:'; call print(line) - call print(vect1) - - - ! general diagonalization - write(line,*) 'Generalise eigenvaue problem:'; call print(line) - call diagonalise(b,b,vect1,c) - write(line,*) 'Eigenvectors:'; call print(line) - call print(c) - write(line,*) 'Eigenvalues:'; call print(line) - call print(vect1) - - - ! check result of diagonalizations with matlab - - write(line,*) 'Now b=: (simmetric?)'; call print(line) - b(1,:)=1 - b(2,:)=2 - b(3,1)=1 - b(3,2)=3 - b(3,3)=4 - call matrix_symmetrise(b) - b(3,:)=0 - b(:,3)=0 - b(2,2)=4 - b(3,3)=6 - - call print(b) - - write(line,*) 'Its inverse is(symmetric positive definite case)'; call print(line) - call matrix_inverse(b,c)!works - call print(c) - write(line,*) 'Their rowcol product is:'; call print(line) - call print(matrix_product(c,b)) - write(line,*) 'Is it the unity matrix? thats good'; call print(line) - - b(2,1)=-2.0 - b(2,1)=3.5 - b(3,2)=7 - write(line,*) 'Now b=: (general case)'; call print(line) - call print(b) - - write(line,*) 'Its inverse is(general case)'; call print(line) - call matrix_inverse(b,c)! works - call print(c) - write(line,*) 'Their rowcol product is:'; call print(line) - call print(matrix_product(c,b)) - write(line,*) 'Is it the unity matrix? thats good'; call print(line) -#endif - - - write(line,*)'The following should be F and T ', b.FEQ.c, b.FEQ.b - call print(line) - - write(line,*) 'Putting diag(b) into a vector'; call print(line) - vect1=diag(b) - call print(vect1) - - write(line,*)'Checking CFCT, b is (34,48,48,110)? :' - call print(line) - - deallocate(b) - allocate(b(2,5)) - b(1,1:3)=3.0 - b(2,1:2)=1.0 - b(2,3:5)=6.0 - b(1,4:5)=2.0 - - call print(b) - - deallocate(vect1) - allocate(vect1(5)) - vect1=1.0_dp - - call print(matrix_cfct(b,vect1)) - - write(line,*)'Checking write_file_direct, b:' - call print(line) - call print(b) -! call matrix_file_write_direct(b,'pippo.dat') - b=0.0_dp - ! call matrix_file_read_direct(b,'pippo.dat') - write(line,*)'We write it to a file and read back. b:' - call print(line) - call print(b) - end subroutine matrix_test - - !% OMIT - subroutine vector_test() - real(dp),allocatable::vector(:),vector1(:),vector2(:) - - write(line,*)'CHECKING VECTORS';call print(line) - write(line,*)'';call print(line) - write(line,*)'a ten elements vector of 0s';call print(line) - allocate(vector(10)) - allocate(vector2(10)) - vector=0.0_dp - call print(vector) - vector=1 - write(line,*)'a ten elements vector of 1s';call print(line) - call print(vector) - write(line,*)'norm And normsq:',normsq(vector),vector_norm(vector) - call print(line) - write(line,*)'Assign it to another vector';call print(line) - allocate(vector1(10)) - vector1=vector - call print(vector1) - write(line,*)'Assign a constant:7';call print(line) - vector1=7.0_dp - call print(vector1) - - ! think about overloading - write(line,*)'Dotproduct vector .DOT. vector',dot_product(vector1,vector1) - call print(line) - write(line,*)'The outer product is'; call print(line) - call print(outer(vector,vector1)) - ! call print(line) - vector2=sqrt_cut(vector1) - write(line,*)'sqrt_cut:';call print(line) - call print(vector2) - write(line,*)'Vector_reandomise:'; call print(line) - call vector_randomise(vector1,6.0_dp) - call print(vector1) - if(vector1.FEQ.vector1) then - write(line,*)'FEQ OK' - call print(line) - end if - if(vector1.FNE.vector) then - write(line,*)'FNE OK' - call print(line) - end if - write(line,*)'Checking print:OK if last 2 are different' - call print(line) - - deallocate (vector) - allocate(vector(17)) - vector=3.57 - vector(16)=5.0 - vector(17)=-4.1 - call print(vector) - - write(line,*)'Checking vector histogram' - call print(line) - - write(line,*) vector_histogram(vector,0.0_dp,5.0_dp,5) - call print(line) - end subroutine vector_test - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Array size and shape checking routines -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - ! The one dimensional checks seem unnecessarily complicated, but they can be - ! easily generalised to higher dimensions (an extra : in intarray declaration - ! for example) - - subroutine check_size_int_dim1(arrayname,intarray,n,caller,error) - - character(*), intent(in) :: arrayname ! The name of the array to be checked - integer, dimension(:), intent(in) :: intarray ! The array to be tested - integer, dimension(:), intent(in) :: n ! The size that intarray should be - character(*), intent(in) :: caller ! The name of the calling routine - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size ! container for the actual size of intarray - logical :: failed ! Keeps track of any failures - integer :: i ! dimension iterator - - INIT_ERROR(error) - - failed = .false. - allocate( actual_size( size(shape(intarray)) ) ) - actual_size = shape(intarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed', error) - end if - - end subroutine check_size_int_dim1 - - !overloaded subroutine which allows a scalar 'n' in the one dimensional case - subroutine check_size_int_dim1_s(arrayname,intarray,n,caller,error) - character(*), intent(in) :: arrayname - integer, dimension(:), intent(in) :: intarray - integer, intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - INIT_ERROR(error) - call check_size(arrayname,intarray,(/n/),caller,error) - PASS_ERROR(error) - - end subroutine check_size_int_dim1_s - - subroutine check_size_int_dim2(arrayname,intarray,n,caller,error) - - character(*), intent(in) :: arrayname - integer, dimension(:,:), intent(in) :: intarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(intarray)) ) ) - actual_size = shape(intarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed', error) - end if - - end subroutine check_size_int_dim2 - - subroutine check_size_real_dim1(arrayname,realarray,n,caller,error) - - character(*), intent(in) :: arrayname - real(dp), dimension(:), intent(in) :: realarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(realarray)) ) ) - actual_size = shape(realarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed', error) - end if - - end subroutine check_size_real_dim1 - - !overloaded subroutine which allows a scalar 'n' in the one dimensional case - subroutine check_size_real_dim1_s(arrayname,realarray,n,caller,error) - character(*), intent(in) :: arrayname - real(dp), dimension(:), intent(in) :: realarray - integer, intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - INIT_ERROR(error) - call check_size(arrayname,realarray,(/n/),caller,error) - PASS_ERROR(error) - - end subroutine check_size_real_dim1_s - - subroutine check_size_real_dim2(arrayname,realarray,n,caller, error) - - character(*), intent(in) :: arrayname - real(dp), dimension(:,:), intent(in) :: realarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(realarray)) ) ) - actual_size = shape(realarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller) //': Size checking failed. Expected: ' // n // ', got: ' // actual_size, error) - end if - - end subroutine check_size_real_dim2 - - subroutine check_size_real_dim3(arrayname,realarray,n,caller, error) - - character(*), intent(in) :: arrayname - real(dp), dimension(:,:,:),intent(in) :: realarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(realarray)) ) ) - actual_size = shape(realarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller) //': Size checking failed. Expected: ' // n // ', got: ' // actual_size, error) - end if - - end subroutine check_size_real_dim3 - -#ifdef HAVE_QP - subroutine check_size_quad_dim1(arrayname,quadarray,n,caller,error) - - character(*), intent(in) :: arrayname - real(qp), dimension(:), intent(in) :: quadarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(quadarray)) ) ) - actual_size = shape(quadarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed',error) - end if - - end subroutine check_size_quad_dim1 - - !overloaded subroutine which allows a scalar 'n' in the one dimensional case - subroutine check_size_quad_dim1_s(arrayname,quadarray,n,caller,error) - character(*), intent(in) :: arrayname - real(qp), dimension(:), intent(in) :: quadarray - integer, intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - INIT_ERROR(error) - call check_size(arrayname,quadarray,(/n/),caller,error) - PASS_ERROR(error) - - end subroutine check_size_quad_dim1_s - - subroutine check_size_quad_dim2(arrayname,quadarray,n,caller,error) - - character(*), intent(in) :: arrayname - real(qp), dimension(:,:), intent(in) :: quadarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(quadarray)) ) ) - actual_size = shape(quadarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed', error) - end if - - end subroutine check_size_quad_dim2 -#endif - - subroutine check_size_complex_dim1(arrayname,realarray,n,caller,error) - - character(*), intent(in) :: arrayname - complex(dp), dimension(:), intent(in) :: realarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(realarray)) ) ) - actual_size = shape(realarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed', error) - end if - - end subroutine check_size_complex_dim1 - - !overloaded subroutine which allows a scalar 'n' in the one dimensional case - subroutine check_size_complex_dim1_s(arrayname,realarray,n,caller,error) - character(*), intent(in) :: arrayname - complex(dp), dimension(:), intent(in) :: realarray - integer, intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - INIT_ERROR(error) - call check_size(arrayname,realarray,(/n/),caller) - PASS_ERROR(error) - - end subroutine check_size_complex_dim1_s - - subroutine check_size_complex_dim2(arrayname,realarray,n,caller, error) - - character(*), intent(in) :: arrayname - complex(dp), dimension(:,:), intent(in) :: realarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(realarray)) ) ) - actual_size = shape(realarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed', error) - end if - - end subroutine check_size_complex_dim2 - - subroutine check_size_log_dim1(arrayname,logarray,n,caller,error) - - character(*), intent(in) :: arrayname - logical, dimension(:), intent(in) :: logarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(logarray)) ) ) - actual_size = shape(logarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed', error) - end if - - end subroutine check_size_log_dim1 - - !overloaded subroutine which allows a scalar 'n' in the one dimensional case - subroutine check_size_log_dim1_s(arrayname,logarray,n,caller,error) - character(*), intent(in) :: arrayname - logical, dimension(:), intent(in) :: logarray - integer, intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - INIT_ERROR(error) - call check_size(arrayname,logarray,(/n/),caller) - PASS_ERROR(error) - - end subroutine check_size_log_dim1_s - - subroutine check_size_log_dim2(arrayname,logarray,n,caller,error) - - character(*), intent(in) :: arrayname - logical, dimension(:,:), intent(in) :: logarray - integer, dimension(:), intent(in) :: n - character(*), intent(in) :: caller - integer, intent(out), optional :: error - - integer, dimension(:), allocatable :: actual_size - logical :: failed - integer :: i - - INIT_ERROR(error) - failed = .false. - allocate( actual_size( size(shape(logarray)) ) ) - actual_size = shape(logarray) - - if (size(actual_size) /= size(n)) then - write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & - ' dimensional and not ',size(n),' dimensional as expected' - call print(line) - failed = .true. - else - do i = 1, size(actual_size) - if (actual_size(i) /= n(i)) then - write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & - actual_size(i),' and not ',n(i),' as expected' - call print(line) - failed = .true. - end if - end do - end if - - if (failed) then - RAISE_ERROR(trim(caller)//': Size checking failed', error) - end if - - end subroutine check_size_log_dim2 - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Array Searching/Sorting/Averaging - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - !% Collect the indices corresponding to .true. elements of a mask - !% can be used to index other arrays, e.g. array(find(mask)) - function find_indices(mask) - logical::mask(:) - integer::find_indices(count(mask)) - integer::i,n - n = 1 - do i=1,size(mask) - if(mask(i)) then - find_indices(n) = i - n = n+1 - end if - end do - end function find_indices - - - !% Test if a given integer 'val' is in an integer array 'array'. - pure function is_in_array(this, val) - - - integer, intent(in) :: val - integer, intent(in), dimension(:) :: this - logical :: Is_In_Array - - if(find_in_array(this, val) > 0) then - is_in_array = .true. - else - is_in_array = .false. - end if - - end function is_in_array - - pure function find_in_array_element_i(this, val) result(n) - integer, intent(in) :: val - integer, intent(in), dimension(:) :: this - integer ::i, n - - ! Optimised to avoid overhead of function call to find_in_array_row (jrk33) - - do i = 1,size(this) - if (this(i) == val) then - n = i - return - end if - end do - - ! not found - n = 0 - - end function find_in_array_element_i - - pure function find_in_array_element_s(this, val) result(n) - character(len=*), intent(in) :: val - character(len=*), intent(in), dimension(:) :: this - integer ::i, n - - ! Optimised to avoid overhead of function call to find_in_array_row (jrk33) - - do i = 1,size(this) - if (this(i) == val) then - n = i - return - end if - end do - - ! not found - n = 0 - - end function find_in_array_element_s - - function find_in_array_row(this, val, mask) result(n) - integer, intent(in), dimension(:,:) :: this - integer, intent(in), dimension(:) :: val - logical, optional, intent(in), dimension(:) :: mask ! if this exists, we only compare elements where this is 1 - integer :: i, j, n - logical :: match - - if(present(mask)) then - if (size(val) /= size(mask)) & - call system_abort('Table_Find_Row: mask and row size mismatch') - end if - - if (present(mask)) then - do i = 1,size(this,2) - match = .true. - do j=1,size(this,1) - if (.not. mask(j)) cycle - if (this(j,i) /= val(j)) then - match = .false. - exit - end if - end do - if (.not. match) cycle - n = i - return - end do - else - do i = 1,size(this,2) - match = .true. - do j=1,size(this,1) - if (this(j,i) /= val(j)) then - match = .false. - exit - end if - end do - if (.not. match) cycle - n = i - return - end do - end if - - ! not found - n = 0 - end function find_in_array_row - - - !% Return a copy of the integer array 'array' with duplicate - !% elements removed. 'uniq' assumes the input array is sorted - !% so that duplicate entries appear consecutively. - subroutine uniq_int(array, uniqed) - integer, intent(in), dimension(:) :: array - integer, dimension(:), allocatable, intent(out) :: uniqed - - integer, dimension(size(array)) :: seen - integer :: i, n_seen - - n_seen = 1 - seen(1) = array(1) - - do i=2,size(array) - if (array(i) == array(i-1)) cycle - n_seen = n_seen + 1 - seen(n_seen) = array(i) - end do - - allocate(uniqed(n_seen)) - uniqed = seen(1:n_seen) - - end subroutine uniq_int - - subroutine uniq_real(array, uniqed) - real(dp), intent(in), dimension(:) :: array - real(dp), dimension(:), allocatable, intent(out) :: uniqed - - real(dp), dimension(size(array)) :: seen - integer :: i, n_seen - - n_seen = 1 - seen(1) = array(1) - - do i=2,size(array) - if (array(i) .feq. array(i-1)) cycle - n_seen = n_seen + 1 - seen(n_seen) = array(i) - end do - - allocate(uniqed(n_seen)) - uniqed = seen(1:n_seen) - - end subroutine uniq_real - - subroutine uniq_real_dim2(array, uniqed, unique) - real(dp), intent(in), dimension(:,:), target :: array - real(dp), dimension(:,:), allocatable, intent(out), optional :: uniqed - logical, dimension(:), intent(out), optional, target :: unique - - logical, dimension(:), pointer :: my_unique - real(dp), dimension(:), pointer :: last_unique - integer :: i, n_seen, d, n - - d = size(array,1) - n = size(array,2) - - if(present(unique)) then - my_unique => unique - else - allocate(my_unique(n)) - endif - - my_unique = .false. - my_unique(1) = .true. - last_unique => array(:,1) - - do i = 2, n - if( last_unique .feq. array(:,i) ) cycle - my_unique(i) = .true. - last_unique => array(:,i) - enddo - - last_unique => null() - - if(present(uniqed)) then - n_seen = count(my_unique) - call reallocate(uniqed,d,n_seen) - uniqed(:,:) = array(:,find_indices(my_unique)) - endif - - if(present(unique)) then - my_unique => null() - else - deallocate(my_unique) - endif - - end subroutine uniq_real_dim2 - - !% Sort an array of integers into ascending order (slow: scales as N$^2$). - !% r_data is an accompanying array of reals on which the same reordering is performed - subroutine sort_array_i(array, i_data, r_data) - - integer, dimension(:), intent(inout) :: array - integer, dimension(:), intent(inout), optional :: i_data - real(dp), dimension(:), intent(inout), optional :: r_data - integer :: i,j,minpos - integer :: min, tmp - real(dp) :: r_tmp - - - do i = 1, (size(array) - 1) - - min = huge(0) - - do j = i,size(array) - - if (array(j) < min) then - min = array(j) - minpos = j - end if - - end do - - tmp = array(i) - array(i) = array(minpos) - array(minpos) = tmp - if (present(i_data)) then - tmp = i_data(i) - i_data(i) = i_data(minpos) - i_data(minpos) = tmp - endif - if (present(r_data)) then - r_tmp = r_data(i) - r_data(i) = r_data(minpos) - r_data(minpos) = r_tmp - endif - - end do - - end subroutine sort_array_i - - - !% Sort an array of integers into ascending order (slow: scales as N$^2$). - !% i_data is an accompanying array of integers on which the same reordering is performed - subroutine sort_array_r(array, i_data,r_data) - - real(dp), dimension(:), intent(inout) :: array - integer, dimension(:), intent(inout), optional :: i_data - real(dp), dimension(:), intent(inout), optional :: r_data - integer :: i,j, minpos - real(dp) :: tmp, min - integer :: i_tmp - real(dp) :: r_tmp - - - do i = 1, (size(array) - 1) - - min = huge(0.0_dp) - - do j = i,size(array) - - if (array(j) < min) then - min = array(j) - minpos = j - end if - - end do - - tmp = array(i) - array(i) = array(minpos) - array(minpos) = tmp - if (present(i_data)) then - i_tmp = i_data(i) - i_data(i) = i_data(minpos) - i_data(minpos) = i_tmp - endif - if (present(r_data)) then - r_tmp = r_data(i) - r_data(i) = r_data(minpos) - r_data(minpos) = r_tmp - endif - - end do - - end subroutine sort_array_r - - - !% Sort an array of integers into ascending order. - !% The function uses heapsort, which always scales as N log N. - !% i_data and r_data are a accompanying arrays of integers and reals - !% on which the same reordering is performed - !% (Initial implementation by Andreas Wonisch) - subroutine heap_sort_i(array, i_data, r_data) - integer, dimension(:), intent(inout) :: array - integer, optional, dimension(:), intent(inout) :: i_data - real(dp), optional, dimension(:), intent(inout) :: r_data - - ! --- - - integer :: N, i, j, root, tmpi - real(DP) :: tmpr - - ! --- - - N = size(array) - - do i = N/2, 1, -1 - - j = i - call siftdown(j, N) - - enddo - - do i = N, 2, -1 - - ! Swap - tmpi = array(1) - array(1) = array(i) - array(i) = tmpi - if (present(i_data)) then - tmpi = i_data(1) - i_data(1) = i_data(i) - i_data(i) = tmpi - endif - if (present(r_data)) then - tmpr = r_data(1) - r_data(1) = r_data(i) - r_data(i) = tmpr - endif - - root = 1 - j = i -1 - call siftdown(root, j) - - enddo - - contains - - subroutine siftdown(root, bottom) - integer, intent(inout) :: root - integer, intent(in) :: bottom - - ! --- - - logical :: done - integer :: maxchild - - ! --- - - done = .false. - - do while ((root*2 <= bottom) .and. .not. done) - - if (root*2 == bottom) then - maxchild = root * 2 - else if (array(root*2) > array(root*2+1)) then - maxchild = root * 2 - else - maxchild = root*2 + 1 - endif - - if (array(root) < array(maxchild)) then - - ! Swap - tmpi = array(root) - array(root) = array(maxchild) - array(maxchild) = tmpi - if (present(i_data)) then - tmpi = i_data(root) - i_data(root) = i_data(maxchild) - i_data(maxchild) = tmpi - endif - if (present(r_data)) then - tmpr = r_data(root) - r_data(root) = r_data(maxchild) - r_data(maxchild) = tmpr - endif - - root = maxchild - else - done = .true. - endif - - enddo - - endsubroutine siftdown - - endsubroutine heap_sort_i - - - !% Sort an array of integers into ascending order. - !% The function uses heapsort, which always scales as N log N. - !% i_data and r_data are a accompanying arrays of integers and reals - !% on which the same reordering is performed - !% (Initial implementation by Andreas Wonisch) - subroutine heap_sort_r(array, i_data, r_data) - real(dp), dimension(:), intent(inout) :: array - integer, optional, dimension(:), intent(inout) :: i_data - real(dp), optional, dimension(:), intent(inout) :: r_data - - ! --- - - integer :: N, i, j, root, tmpi - real(DP) :: tmpr - - ! --- - - N = size(array) - - do i = N/2, 1, -1 - - j = i - call siftdown(j, N) - - enddo - - do i = N, 2, -1 - - ! Swap - tmpr = array(1) - array(1) = array(i) - array(i) = tmpr - if (present(i_data)) then - tmpi = i_data(1) - i_data(1) = i_data(i) - i_data(i) = tmpi - endif - if (present(r_data)) then - tmpr = r_data(1) - r_data(1) = r_data(i) - r_data(i) = tmpr - endif - - root = 1 - j = i -1 - call siftdown(root, j) - - enddo - - contains - - subroutine siftdown(root, bottom) - integer, intent(inout) :: root - integer, intent(in) :: bottom - - ! --- - - logical :: done - integer :: maxchild - - ! --- - - done = .false. - - do while ((root*2 <= bottom) .and. .not. done) - - if (root*2 == bottom) then - maxchild = root * 2 - else if (array(root*2) > array(root*2+1)) then - maxchild = root * 2 - else - maxchild = root*2 + 1 - endif - - if (array(root) < array(maxchild)) then - - ! Swap - tmpr = array(root) - array(root) = array(maxchild) - array(maxchild) = tmpr - if (present(i_data)) then - tmpi = i_data(root) - i_data(root) = i_data(maxchild) - i_data(maxchild) = tmpi - endif - if (present(r_data)) then - tmpr = r_data(root) - r_data(root) = r_data(maxchild) - r_data(maxchild) = tmpr - endif - - root = maxchild - else - done = .true. - endif - - enddo - - endsubroutine siftdown - - endsubroutine heap_sort_r - - subroutine heap_sort_r_2dim(array, i_data, r_data) - real(dp), dimension(:,:), intent(inout) :: array - integer, optional, dimension(:), intent(inout) :: i_data - real(dp), optional, dimension(:), intent(inout) :: r_data - - ! --- - - integer :: N, i, j, root, tmpi, d - real(dp), dimension(:), allocatable :: tmp_array - real(dp) :: tmpr - - ! --- - - N = size(array,2) - d = size(array,1) - allocate(tmp_array(d)) - - do i = N/2, 1, -1 - - j = i - call siftdown(j, N) - - enddo - - do i = N, 2, -1 - - ! Swap - tmp_array(:) = array(:,1) - array(:,1) = array(:,i) - array(:,i) = tmp_array(:) - if (present(i_data)) then - tmpi = i_data(1) - i_data(1) = i_data(i) - i_data(i) = tmpi - endif - if (present(r_data)) then - tmpr = r_data(1) - r_data(1) = r_data(i) - r_data(i) = tmpr - endif - - root = 1 - j = i -1 - call siftdown(root, j) - - enddo - - deallocate(tmp_array) - - contains - - subroutine siftdown(root, bottom) - integer, intent(inout) :: root - integer, intent(in) :: bottom - - ! --- - - logical :: done - integer :: maxchild - - ! --- - - done = .false. - - do while ((root*2 <= bottom) .and. .not. done) - - if (root*2 == bottom) then - maxchild = root * 2 - else if ( real_array_gt(array(:,root*2),array(:,root*2+1)) ) then !array(:,root*2) > array(:,root*2+1) - maxchild = root * 2 - else - maxchild = root*2 + 1 - endif - - if ( real_array_lt(array(:,root),array(:,maxchild)) ) then ! array(:,root) < array(:,maxchild) - - ! Swap - tmp_array(:) = array(:,root) - array(:,root) = array(:,maxchild) - array(:,maxchild) = tmp_array(:) - if (present(i_data)) then - tmpi = i_data(root) - i_data(root) = i_data(maxchild) - i_data(maxchild) = tmpi - endif - if (present(r_data)) then - tmpr = r_data(root) - r_data(root) = r_data(maxchild) - r_data(maxchild) = tmpr - endif - - root = maxchild - else - done = .true. - endif - - enddo - - endsubroutine siftdown - - endsubroutine heap_sort_r_2dim - - subroutine heap_sort_i_2dim(array, i_data, r_data) - integer, dimension(:,:), intent(inout) :: array - integer, optional, dimension(:), intent(inout) :: i_data - real(dp), optional, dimension(:), intent(inout) :: r_data - - ! --- - - integer :: N, i, j, root, tmpi, d - integer, dimension(:), allocatable :: tmp_array - real(dp) :: tmpr - - ! --- - - N = size(array,2) - d = size(array,1) - allocate(tmp_array(d)) - - do i = N/2, 1, -1 - - j = i - call siftdown(j, N) - - enddo - - do i = N, 2, -1 - - ! Swap - tmp_array(:) = array(:,1) - array(:,1) = array(:,i) - array(:,i) = tmp_array(:) - if (present(i_data)) then - tmpi = i_data(1) - i_data(1) = i_data(i) - i_data(i) = tmpi - endif - if (present(r_data)) then - tmpr = r_data(1) - r_data(1) = r_data(i) - r_data(i) = tmpr - endif - - root = 1 - j = i -1 - call siftdown(root, j) - - enddo - - deallocate(tmp_array) - - contains - - subroutine siftdown(root, bottom) - integer, intent(inout) :: root - integer, intent(in) :: bottom - - ! --- - - logical :: done - integer :: maxchild - - ! --- - - done = .false. - - do while ((root*2 <= bottom) .and. .not. done) - - if (root*2 == bottom) then - maxchild = root * 2 - else if ( int_array_gt(array(:,root*2),array(:,root*2+1)) ) then !array(:,root*2) > array(:,root*2+1) - maxchild = root * 2 - else - maxchild = root*2 + 1 - endif - - if ( int_array_lt(array(:,root),array(:,maxchild)) ) then ! array(:,root) < array(:,maxchild) - - ! Swap - tmp_array(:) = array(:,root) - array(:,root) = array(:,maxchild) - array(:,maxchild) = tmp_array(:) - if (present(i_data)) then - tmpi = i_data(root) - i_data(root) = i_data(maxchild) - i_data(maxchild) = tmpi - endif - if (present(r_data)) then - tmpr = r_data(root) - r_data(root) = r_data(maxchild) - r_data(maxchild) = tmpr - endif - - root = maxchild - else - done = .true. - endif - - enddo - - endsubroutine siftdown - - endsubroutine heap_sort_i_2dim - - !% Sort an array of integers into ascending order (stable, slow: scales as N$^2$). - !% i_data is an accompanying array of integers on which the same reordering is performed - subroutine insertion_sort_i(array, i_data) - integer, intent(inout), dimension(:) :: array - integer, intent(inout), dimension(size(array)), optional :: i_data - - integer :: i, vi, j, v - vi = 1 - - do i = 2, size(array) - if (array(i) >= array(i-1)) cycle - v = array(i) - if (present(i_data)) vi = i_data(i) - - do j = (i - 1), 1, -1 - if (v > array(j)) exit - array(j+1) = array(j) - if (present(i_data)) i_data(j+1) = i_data(j) - end do - array(j+1) = v - if (present(i_data)) i_data(j+1) = vi - end do - - end subroutine insertion_sort_i - - !% Sort an array of reals into ascending order (stable, slow: scales as N$^2$). - !% i_data is an accompanying array of integers on which the same reordering is performed - subroutine insertion_sort_r(array, i_data) - real(dp), intent(inout), dimension(:) :: array - integer, intent(inout), dimension(size(array)), optional :: i_data - - integer :: i, vi, j - real(dp) :: v - vi = 1 - - do i = 2, size(array) - if (array(i) >= array(i-1)) cycle - v = array(i) - if (present(i_data)) vi = i_data(i) - - do j = (i - 1), 1, -1 - if (v > array(j)) exit - array(j+1) = array(j) - if (present(i_data)) i_data(j+1) = i_data(j) - end do - array(j+1) = v - if (present(i_data)) i_data(j+1) = vi - end do - - end subroutine insertion_sort_r - - !% Do binary search and return 'index' of element containing 'value', or zero if not found. - !% 'array' must be sorted into ascending order beforehand. - !% If the array subscripts don't start at 1, then pass the actual index of the first element as 'first', - !% then, if the element isn't found, the value returned is 'first' minus 1. - !% To restrict the search to a subsection of the array supply 'low' and/or 'high'. - - function binary_search_i(array,value,first,low,high,error) result(index) - - integer, dimension(:), intent(in) :: array - integer, intent(in) :: value - integer, optional, intent(in) :: first,low,high - integer, optional, intent(out) :: error - integer :: index - !local variables - integer :: ilow, ihigh, count, max - logical :: done - - INIT_ERROR(error) - max = size(array) - ilow = 1; ihigh = max - if (present(low)) then - ilow = low - if (present(first)) ilow = ilow - first + 1 - ASSERT(ilow >= 1, 'binary_search: Bad lower index supplied', error) - end if - if (present(high)) then - ihigh = high - if (present(first)) ihigh = ihigh - first + 1 - ASSERT(ihigh <= max, 'binary_search: Bad higher index supplied', error) - end if - ASSERT(ilow <= ihigh, 'binary_search: Lower index > Higher index!', error) - - index = 0; count = 0 - done = .false. - - ASSERT(max >= 1, 'binary_search: Array must have at lease one element!', error) - - if ( (array(ilow) > value) .or. (array(ihigh) < value) ) done = .true. - if (array(ilow) == value) then - index = ilow - done = .true. - end if - if (array(ihigh) == value) then - index = ihigh - done = .true. - end if - - do while(.not.done) - count = count + 1 - index = (ihigh + ilow) / 2 - if (index == ilow) then ! value is not present. exit - index = 0 - done = .true. - else if (array(index) == value) then ! value found - done = .true. - else if (array(index) < value) then ! value at this index is too low. shift lower bound - ilow = index - else ! value at this index is too high. shift upper bound - ihigh = index - end if - ASSERT(count < max, 'binary_search: Counter hit maximum. Is the array sorted properly?', error) - end do - - if (present(first)) index = index - 1 + first - - end function binary_search_i - - - !% Do binary search and return 'index' of element being smaller or equal - !% to 'value'. 'array' must be sorted into ascending order beforehand. - !% If the array subscripts don't start at 1, then pass the actual index of - !% the first element as 'first' - function binary_search_r(array,value,first,low,high,error) result(index) - - real(DP), dimension(:), intent(in) :: array - real(DP), intent(in) :: value - integer, optional, intent(in) :: first,low,high - integer, optional, intent(out) :: error - integer :: index - !local variables - integer :: ilow, ihigh, count, max - logical :: done - - INIT_ERROR(error) - max = size(array) - ilow = 1; ihigh = max - if (present(low)) then - ilow = low - if (present(first)) ilow = ilow - first + 1 - ASSERT(ilow >= 1, 'binary_search: Bad lower index supplied', error) - end if - if (present(high)) then - ihigh = high - if (present(first)) ihigh = ihigh - first + 1 - ASSERT(ihigh <= max, 'binary_search: Bad higher index supplied', error) - end if - ASSERT(ilow <= ihigh, 'binary_search: Lower index > Higher index!', error) - - index = 0; count = 0 - done = .false. - - ASSERT(max >= 1, 'binary_search: Array must have at lease one element!', error) - - if (array(ilow) > value) then - index = ilow-1 - done = .true. - end if - if (array(ihigh) <= value) then - index = ihigh - done = .true. - end if - - do while(.not.done) - count = count + 1 - index = (ihigh + ilow) / 2 - if (array(index) <= value .and. array(index+1) > value) then - ! value found - done = .true. - else if (array(index) < value) then - ! value at this index is too low. shift lower bound - ilow = index - else - ! value at this index is too high. shift upper bound - ihigh = index - endif - ASSERT(count < max, 'binary_search: Counter hit maximum. Is the array sorted properly?', error) - end do - - if (present(first)) index = index - 1 + first - - end function binary_search_r - - - !% Subtract the average value from each element of a real array. - subroutine zero_sum(array) - - real(dp), dimension(:,:), intent(inout) :: array - real(dp), dimension(size(array,1)) :: array_avg - integer :: i - - array_avg = average_array(array) - - ! Update each component - do i = 1, size(array,2) - array(:,i) = array(:,i) - array_avg - end do - - end subroutine zero_sum - - !% Calculate the average of a two dimenstional real array across its second dimension. - function average_array(array) - - real(dp), dimension(:,:), intent(in) :: array - real(dp), dimension(size(array,1)) :: average_array - integer :: i - - average_array = 0.0_dp - do i = 1, size(array,2) - average_array = average_array + array(:,i) - end do - - average_array = average_array / real(size(array,2),dp) - - end function average_array - - - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Linear Least Squares fit using \textsc{lapack} to do singular value decomposition. - !% - !% Fit data 'y' with errors 'sig' to model using parameters 'a', - !% and calculate $\chi^2$ of the fit. The user defined subroutine 'funcs' - !% should return the model parameters 'a' for the point 'x' in the array 'afunc'. - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine least_squares(x, y, sig, a, chisq, funcs) - - real(dp), intent(in), dimension(:) :: x, y, sig - real(dp), intent(out), dimension(:) :: a - real(dp), intent(out) :: chisq - - real(dp) :: ain(size(x),size(a)), u(size(x),size(x)), v(size(a),size(a)),& - w(size(a)), sigmainv(size(a), size(x)) - integer i,j,info - real(dp), parameter :: TOL = 1e-13_dp - real(dp) :: wmax, thresh, sum, b(size(x)), afunc(size(a)) - real(dp), allocatable, dimension(:) :: work - integer :: ndata, ma, lwork - interface - subroutine funcs(x,afunc) - use system_module - real(dp) :: x, afunc(:) - end subroutine funcs - end interface - - ndata = size(x) - ma = size(a) - - ! Call user fit function and scale by sig - do i=1,ndata - call funcs(x(i), afunc) - do j=1,ma - ain(i,j) = afunc(j)/sig(i) - end do - b(i) = y(i)/sig(i) - end do - - lwork = 2 * max(3*min(ma,ndata)+max(ma,ndata),5*min(ma,ndata)) - allocate(work(lwork)) - call DGESVD('A','A',ndata,ma,ain,ndata,w,u,ndata,v,ma,work,lwork,info) - - if (info/=0) then - if (info < 0) then - write(line,'(a,i0)')'least_squares: Problem with argument ',-info - call system_abort(line) - else - call system_abort('least_squares: DBDSQR (called from DGESVD) did not converge') - end if - end if - deallocate(work) - - ! Zero singular elements - wmax = maxval(w) - thresh = TOL*wmax - - ! Invert singular value matrix - sigmainv = 0.0_dp - do i=1,ma - if (w(i) < thresh) then - sigmainv(i,i) = 0.0_dp - else - sigmainv(i,i) = 1.0_dp/w(i) - end if - end do - - a = transpose(v) .mult. sigmainv .mult. transpose(u) .mult. b - - ! Calculate chi^2 for the fitted parameters - chisq = 0.0_dp - do i=1,ndata - call funcs(x(i), afunc) - sum = 0.0_dp - do j=1,ma - sum = sum + a(j)*afunc(j) - end do - chisq = chisq + ((y(i)-sum)/sig(i))**2 - end do - - end subroutine least_squares - - !% This routine updates the average and variance of a quantity that is sampled periodically - subroutine update_running_average_and_variance(average,variance,x,N) - - real(dp), intent(inout) :: average, variance - real(dp), intent(in) :: x !% The new sample value - integer, intent(in) :: N !% The sample number - - real(dp) :: f1, f2, old_av, old_var - - f1 = real(N-1,dp) / real(N,dp) - f2 = 1.0_dp / real(N,dp) - old_av = average - old_var = variance - - !Update average - average = f1 * old_av + f2 * x - - !Update variance - variance = f1 * (old_var + old_av*old_av) + f2 * x*x - average*average - - end subroutine update_running_average_and_variance - - subroutine update_exponential_average_s(average,decay,x) - - real(dp), intent(inout) :: average - real(dp), intent(in) :: decay, x - - real(dp) :: aa(1), xa(1) - - !Pack the scalar data into a 1-component vector and call - !the vector version of this routine - - aa(1) = average - xa(1) = x - call update_exponential_average(aa,decay,xa) - - average = aa(1) - - end subroutine update_exponential_average_s - - subroutine update_exponential_average_v(average,decay,x) - - real(dp), intent(inout) :: average(:) - real(dp), intent(in) :: decay, x(size(average)) - - real(dp) :: f1, f2 - - f1 = exp(-decay) - f2 = 1.0_dp - f1 - - average = f1*average + f2*x - - end subroutine update_exponential_average_v - - subroutine update_exponential_average_d2(average,decay,x) - - real(dp), intent(inout) :: average(:,:) - real(dp), intent(in) :: decay, x(size(average,1),size(average,2)) - - real(dp) :: f1, f2 - - f1 = exp(-decay) - f2 = 1.0_dp - f1 - - average = f1*average + f2*x - - end subroutine update_exponential_average_d2 - - ! - ! If we need to bin some data in the range [a,b) with bin-width d, which bin (starting at 1) should - ! the value x go into? Also check that x lies in the correct range. - ! - function bin(a,b,d,x) - - real(dp), intent(in) :: a,b,d,x - integer :: bin - - if (x < a .or. x >= b) call system_abort('bin: data value '//round(x,3)//' does not lie in range [' & - //round(a,3)//','//round(b,3)//')') - - bin = int((x-a)/d) + 1 - - end function bin - - ! - ! Return the coordinate of the centre of the ith bin if we have n bins spanning the range [a,b) - ! - function bin_centre(a,b,n,i) result(c) - - real(dp), intent(in) :: a, b - integer, intent(in) :: n, i - real(dp) :: c - - c = a + (b-a)*(real(i,dp)-0.5_dp)/real(n,dp) - - end function bin_centre - - pure function int_array_ge(array1,array2) result(ge) - - integer, intent(in) :: array1(:) - integer, intent(in) :: array2(size(array1)) - logical :: ge - integer :: i - - ge = .true. - i = 1 - do while(i <= size(array1)) - if (array1(i) < array2(i)) then - ge =.false. - return - else if (array1(i) > array2(i)) then - return - end if - i = i + 1 - end do - - end function int_array_ge - - pure function int_array_gt(array1,array2) result(gt) - - integer, intent(in) :: array1(:) - integer, intent(in) :: array2(size(array1)) - logical :: gt - integer :: i - - gt = .true. - i = 1 - do while(i <= size(array1)) - if (array1(i) < array2(i)) then - gt =.false. - return - else if (array1(i) > array2(i)) then - return - end if - i = i + 1 - end do - gt = .false. - - end function int_array_gt - - pure function int_array_lt(array1,array2) result(lt) - - integer, intent(in) :: array1(:) - integer, intent(in) :: array2(size(array1)) - logical :: lt - - lt = .not.int_array_ge(array1,array2) - - end function int_array_lt - - pure function int_array_le(array1,array2) result(le) - - integer, intent(in) :: array1(:) - integer, intent(in) :: array2(size(array1)) - logical :: le - - le = .not.int_array_gt(array1,array2) - - end function int_array_le - - pure function real_array_gt(array1,array2) - real(dp), dimension(:), intent(in) :: array1 - real(dp), dimension(size(array1)), intent(in) :: array2 - logical :: real_array_gt - - integer :: i - - do i = 1, size(array1) - if(array1(i) .feq. array2(i)) then - cycle - elseif(array1(i) > array2(i)) then - real_array_gt = .true. - return - else !array1(i) < array2(i) - real_array_gt = .false. - return - endif - enddo - - real_array_gt = .false. - - endfunction real_array_gt - - pure function real_array_ge(array1,array2) - real(dp), dimension(:), intent(in) :: array1 - real(dp), dimension(size(array1)), intent(in) :: array2 - logical :: real_array_ge - - integer :: i - - do i = 1, size(array1) - if(array1(i) .feq. array2(i)) then - cycle - elseif(array1(i) > array2(i)) then - real_array_ge = .true. - return - else !array1(i) < array2(i) - real_array_ge = .false. - return - endif - enddo - - real_array_ge = .true. - - endfunction real_array_ge - - pure function real_array_lt(array1,array2) - real(dp), dimension(:), intent(in) :: array1 - real(dp), dimension(size(array1)), intent(in) :: array2 - logical :: real_array_lt - - real_array_lt = .not.real_array_ge(array1,array2) - endfunction real_array_lt - - pure function real_array_le(array1,array2) - real(dp), dimension(:), intent(in) :: array1 - real(dp), dimension(size(array1)), intent(in) :: array2 - logical :: real_array_le - - real_array_le = .not.real_array_gt(array1,array2) - endfunction real_array_le - - !% compare contents of 2 cells in up to N=2 arrays (int or real), return true if - !% contents in first cell is less than 2nd, with 1st array taking precendence. - function arrays_lt(i, j, i_p1, r_p1, i_p2, r_p2, i_p3, r_p3, error) - integer, intent(in) :: i, j - integer, intent(in), pointer, optional :: i_p1(:) - real(dp), intent(in), pointer, optional :: r_p1(:) - integer, intent(in), pointer, optional :: i_p2(:) - real(dp), intent(in), pointer, optional :: r_p2(:) - integer, intent(in), pointer, optional :: i_p3(:) - real(dp), intent(in), pointer, optional :: r_p3(:) - integer, intent(out), optional :: error - logical :: arrays_lt - - integer :: n_p1, n_p2, n_p3 - logical :: p1_is_i = .false., p1_is_r = .false. - logical :: p2_is_i = .false., p2_is_r = .false., have_p2 = .false. - logical :: p3_is_i = .false., p3_is_r = .false., have_p3 = .false. - - INIT_ERROR(error) - - n_p1 = 0 - if (present(i_p1)) then - if (associated(i_p1)) then - n_p1 = n_p1 + 1 - p1_is_i = .true. - endif - end if - if (present(r_p1)) then - if (associated(r_p1)) then - n_p1 = n_p1 + 1 - p1_is_r = .true. - endif - end if - if (n_p1 /= 1) then - RAISE_ERROR("arrays_lt got too many or too few present and associated p1 pointers",error) - endif - - n_p2 = 0 - if (present(i_p2)) then - if (associated(i_p2)) then - n_p2 = n_p2 + 1 - p2_is_i = .true. - endif - end if - if (present(r_p2)) then - if (associated(r_p2)) then - n_p2 = n_p2 + 1 - p2_is_r = .true. - endif - endif - if (n_p2 > 1) then - RAISE_ERROR("arrays_lt got too many present and associated p2 pointers",error) - endif - have_p2 = (n_p2 == 1) - - n_p3 = 0 - if (present(i_p3)) then - if (associated(i_p3)) then - n_p3 = n_p3 + 1 - p3_is_i = .true. - endif - end if - if (present(r_p3)) then - if (associated(r_p3)) then - n_p3 = n_p3 + 1 - p3_is_r = .true. - endif - endif - if (n_p3 > 1) then - RAISE_ERROR("arrays_lt got too many present and associated p3 pointers",error) - endif - have_p3 = (n_p3 == 1) - - ! always have some *_p1, test *_p1 - if (p1_is_i) then - if (i_p1(i) < i_p1(j)) then - arrays_lt = .true. - return - else if (i_p1(i) > i_p1(j)) then - arrays_lt = .false. - return - endif - else ! p1_is_r - if (r_p1(i) < r_p1(j)) then - arrays_lt = .true. - return - else if (r_p1(i) > r_p1(j)) then - arrays_lt = .false. - return - endif - endif - - ! *_p1 must be equal, test *_p2 - if (have_p2) then ! must have some present and associated *_p2 pointer, test it - if (p2_is_i) then - if (i_p2(i) < i_p2(j)) then - arrays_lt = .true. - return - else if (i_p2(i) > i_p2(j)) then - arrays_lt = .false. - return - endif - else ! p2_is_r - if (r_p2(i) < r_p2(j)) then - arrays_lt = .true. - return - else if (r_p2(i) > r_p2(j)) then - arrays_lt = .false. - return - endif - endif - endif - - ! *_p2 must be equal, test *_p3 - if (have_p3) then ! must have some present and associated *_p3 pointer, test it - if (p3_is_i) then - if (i_p3(i) < i_p3(j)) then - arrays_lt = .true. - return - else if (i_p3(i) > i_p3(j)) then - arrays_lt = .false. - return - endif - else ! p3_is_r - if (r_p3(i) < r_p3(j)) then - arrays_lt = .true. - return - else if (r_p3(i) > r_p3(j)) then - arrays_lt = .false. - return - endif - endif - endif - - ! *_p3 must be equal - arrays_lt = .false. - end function arrays_lt - - subroutine polar_decomposition(m, S, R) - real(dp), intent(in) :: m(3,3) - real(dp), intent(out) :: S(3,3), R(3,3) - - real(dp) :: EEt(3,3), D(3), V(3,3) - - ! Find polar decomposition: m = S*R where S is symmetric, R is a rotation - ! EEt = E*E', EEt = VDV' D diagonal, S = V D^1/2 V', R = S^-1*E - - EEt = m .mult. transpose(m) ! Normal - call diagonalise(EEt, D, V) - - ! Check positive definite - if (any(D < 0)) then - call print(m, PRINT_VERBOSE) - call system_abort("polar decomposition 'm' is not positive definite") - end if - - S = V .mult. diag(sqrt(D)) .mult. transpose(V) - R = V .mult. diag(D ** (-0.5_dp)) .mult. transpose(V) .mult. m - - call print('S:', PRINT_ANALYSIS); call print(S, PRINT_ANALYSIS) - call print('R:', PRINT_ANALYSIS); call print(R, PRINT_ANALYSIS) - - end subroutine polar_decomposition - - !% Returns the volume of intersection of two spheres, radius $r_1$ and $r_2$, whose - !% centres are a distance $d$ apart - function sphere_intersection_vol(r1,r2,d) result(V) - - real(dp), intent(in) :: r1, r2, d - real(dp) :: V - real(dp) :: t1, t2, t3 - - if (r1<0.0_dp .or. r2<0.0-dp .or. d<0.0_dp .or. (r1 + r2)>d) then - V = 0.0_dp - return - else if (abs(r1-r2)>d) then - t1 = min(r1,r2) - V = 4.0_dp*PI*t1*t1*t1/3.0_dp - return - end if - - t1 = r1 + r2 - d - t2 = r1 + r2 + d - t3 = r1 - r2 - - V = PI * t1 * t1 * (d * t2 - 3.0_dp * t3 * t3) / (12.0_dp * d) - - end function sphere_intersection_vol - - function permutation_symbol() result(eps) - real(dp) :: eps(3,3,3) - - eps = 0.0_dp - - eps(1,2,3) = 1.0_dp - eps(1,3,2) = -1.0_dp - eps(2,3,1) = 1.0_dp - eps(2,1,3) = -1.0_dp - eps(3,1,2) = 1.0_dp - eps(3,2,1) = -1.0_dp - end function permutation_symbol - - ! Matrix3x3_Inverse - ! - !% Calculate $3\times3$ matrix inverse of 'lattice' and store result in 'g'. - !% Avoids overhead of calling \textsc{lapack} for simple case of $3\times3$ matrix. - subroutine matrix3x3_inverse(matrix, g) - real(dp), intent(in) :: matrix(3,3) - real(dp), intent(out) :: g(3,3) - - real(dp) :: stp - - stp = scalar_triple_product(matrix(:,1), matrix(:,2), matrix(:,3)) - - g(1,:) = (matrix(:,2) .cross. matrix(:,3))/stp - g(2,:) = (matrix(:,3) .cross. matrix(:,1))/stp - g(3,:) = (matrix(:,1) .cross. matrix(:,2))/stp - - end subroutine matrix3x3_inverse - - !% Calulates determinant of $3\times3$ matrix - function matrix3x3_det(m) result(det) - real(dp), intent(in) :: m(3,3) - real(dp) :: det - - det = m(1,1)*(m(2,2)*m(3,3) - m(3,2)*m(2,3)) & - - m(2,1)*(m(1,2)*m(3,3) - m(3,2)*m(1,3)) & - + m(3,1)*(m(1,2)*m(2,3) - m(2,2)*m(1,3)) - - end function matrix3x3_det - - function pbc_aware_centre(p, lattice, g) result(c) - real(dp), intent(in) :: p(:,:), lattice(3,3), g(3,3) - real(dp) :: c(3) - - integer i - complex(dp) :: c_z(3) - - c_z = 0.0_dp - do i=1, size(p,2) - c_z = c_z + exp(cmplx(0.0_dp,1.0_dp)*2.0_dp*PI*(g .mult. p(:,i))) - end do - c_z = c_z / real(size(p,2),dp) - c_z = c_z/abs(c_z) - c = lattice .mult. real(log(c_z)/(cmplx(0.0_dp,1.0_dp)*2.0_dp*PI),dp) - - end function pbc_aware_centre - - - !% K-means clustering. Algorithm is as described in Numerical Recipes - !% (Third Edition, Section 16.1.2, pp. 848-849). - subroutine kmeans(data, K, means, assign, err, initialisation) - real(dp), dimension(:, :), intent(in) :: data - integer, intent(in) :: K - real(dp), intent(inout), dimension(:,:) :: means - integer, dimension(:), intent(inout) :: assign - real(dp), intent(out), optional :: err - character(*), intent(in), optional :: initialisation - - character(30) :: do_initialisation - integer :: N, M, nn, mm, kk, kmin - logical :: change - real(dp) :: dmin, d - - N = size(data, 1) - M = size(data, 2) - - do_initialisation = optional_default('none', initialisation) - if (trim(do_initialisation) /= 'none' .and. & - trim(do_initialisation) /= 'random_means' .and. & - trim(do_initialisation) /= 'random_partition') & - call system_abort('kmeans: initialisation argument should be one of "none" (default), "random_means", "random_partition"') - - if (trim(do_initialisation) == 'random_means') then - ! Initialise centroids randomly within range of input data - do kk=1,K - do mm=1,M - means(kk,mm) = ran_uniform()*(maxval(data(:,mm))-minval(data(:,mm))) + minval(data(:,mm)) - end do - end do - end if - - assign(:) = 0 - - if (trim(do_initialisation) == 'random_partition') then - ! Assign each centroid randomly to one of the K centroids - do nn=1,N - assign(nn) = mod(ran(), K)+1 - end do - - ! Compute the initial means from the random partition - means(:,:) = 0.0_dp - do nn=1,N - do mm=1,M - means(assign(nn),mm) = means(assign(nn),mm) + data(nn,mm) - end do - end do - do kk=1,K - if (any(assign == kk)) then - means(kk,:) = means(kk,:) / count(assign == kk) - end if - end do - end if - - change = .true. - - do while (change) - change = .false. - - ! E-step -- assign each point to the component whose mean it is closest to - do nn=1,N - dmin = huge(1.0_dp) - do kk=1,K - d = (data(nn,:) - means(kk,:)) .dot. (data(nn,:) - means(kk,:)) - if (d < dmin) then - dmin = d - kmin = kk - end if - end do - - if (assign(nn) /= kmin) then - assign(nn) = kmin - change = .true. - end if - end do - - ! M-step -- update each mean to the average of the data points assigned to it - means(:,:) = 0.0_dp - do nn=1,N - do mm=1,M - means(assign(nn),mm) = means(assign(nn),mm) + data(nn,mm) - end do - end do - do kk=1,K - if (any(assign == kk)) then - means(kk,:) = means(kk,:) / count(assign == kk) - end if - end do - end do - - if (present(err)) then - ! Compute residual error - err = 0.0_dp - do nn=1,N - err = err + (data(nn,:) - means(assign(nn),:)) .dot. (data(nn,:) - means(assign(nn),:)) - end do - end if - - end subroutine kmeans - - subroutine symmetric_linear_solve(M, a, M_inv_a) - real(dp), intent(in) :: M(:,:), a(:) - real(dp), intent(out):: M_inv_a(:) - - integer :: N - integer :: lwork, info - real(dp), allocatable :: work(:) - integer, allocatable :: ipiv(:) - - N = size(a) - - allocate(ipiv(N)) - M_inv_a = a - - allocate(work(1)) - lwork = -1 - call dsysv('U', N, 1, M, N, ipiv, M_inv_a, N, work, lwork, info) - if (info /= 0) & - call system_abort("symmetric_linear_solve failed in lwork computation dsysv " // info) - lwork = work(1) - deallocate(work) - - allocate(work(lwork)) - call dsysv('U', N, 1, M, N, ipiv, M_inv_a, N, work, lwork, info) - if (info /= 0) & - call system_abort("symmetric_linear_solve failed in dsysv " // info) - - deallocate(work) - deallocate(ipiv) - end subroutine symmetric_linear_solve - - !% round n to the nearest number greater or equal to n - !% with prime factors of only 2, 3, 5, ... max_prime_factor - subroutine round_prime_factors(n, max_prime_factor, error) - integer, intent(inout) :: n !% The number to be rounded - integer, optional, intent(in) :: max_prime_factor - integer, optional, intent(out) :: error - - integer :: factor, test, i, my_max_prime_factor, num_prime_factors - - INIT_ERROR(error) - - ! Check that n is not zero, otherwise we get stuck in an infinite loop - ASSERT(n /= 0, 'n=0 has no prime factors', error) - - my_max_prime_factor = optional_default(5, max_prime_factor) - select case (my_max_prime_factor) - case ( 2) ; num_prime_factors = 1 - case ( 3) ; num_prime_factors = 2 - case ( 5) ; num_prime_factors = 3 - case ( 7) ; num_prime_factors = 4 - case (11) ; num_prime_factors = 5 - case (13) ; num_prime_factors = 6 - case (17) ; num_prime_factors = 7 - case (19) ; num_prime_factors = 8 - case default - RAISE_ERROR('unsupported max_prime_factor '//my_max_prime_factor//' in prime_factors()', error) - end select - - do - test = n - do i=1,num_prime_factors - factor = 1 - select case (i) - case (1) ; factor = 2 - case (2) ; factor = 3 - case (3) ; factor = 5 - case (4) ; factor = 7 - case (5) ; factor = 11 - case (6) ; factor = 13 - case (7) ; factor = 17 - case (8) ; factor = 19 - case default - RAISE_ERROR('unsupported prime factor '//i//' in prime_factors()', error) - end select - - do while(mod(test,factor).eq.0) - test = test / factor - enddo - end do - - if (test == 1) return - n = n + 1 - end do - - end subroutine round_prime_factors - - !% Calculates integral numerically using the trapezoid formula from (x,y) data - !% pairs. - function TrapezoidIntegral(x,y) - - real(dp) :: TrapezoidIntegral - real(dp), dimension(:), intent(in) :: x, y - - integer :: n - - if( size(x) /= size(y) ) call system_abort('TrapezoidIntegral: dimensions of x and y not the same') - n = size(x) - - TrapezoidIntegral = sum((x(2:n)-x(1:n-1))*(y(2:n)+y(1:n-1)))/2.0_dp - - endfunction TrapezoidIntegral - - subroutine fill_random_integer(r,n,b) - integer, dimension(:), intent(out) :: r - integer, intent(in) :: n - integer, dimension(:), intent(in), optional :: b - - integer :: i, i0, irnd, sr - real(qp) :: rnd - - sr = size(r) - if( sr > n ) call system_abort('fill_random_integer: cannot fill array, too short') - r = 0 - i0 = 1 - if( present(b) ) then - if(size(b) > sr) call system_abort('fill_random_integer: cannot fill array, optional b too long') - r(1:size(b)) = b - i0 = size(b) + 1 - endif - - do i = i0, sr - do - call random_number(rnd) - irnd = ceiling(rnd*n) - if( all(r /= irnd) ) exit - enddo - r(i) = irnd - enddo - - end subroutine fill_random_integer - - function apply_function_matrix(fun,this) - real(dp), dimension(:,:), intent(in) :: this - real(dp), dimension(size(this,1),size(this,2)) :: apply_function_matrix - interface - function fun(x) - use system_module - real(dp), dimension(:), intent(in) :: x - real(dp), dimension(size(x)) :: fun - endfunction fun - endinterface - - real(dp), dimension(:), allocatable :: evals - real(dp), dimension(:,:), allocatable :: evects - - allocate(evals(size(this,1)), evects(size(this,1),size(this,2))) - - call diagonalise(this, evals, evects) - - apply_function_matrix = matrix_mvmt(evects,fun(evals)) - - deallocate(evals,evects) - - endfunction apply_function_matrix - - function sqrt_real_array1d(x) - real(dp), dimension(:), intent(in) :: x - real(dp), dimension(size(x)) :: sqrt_real_array1d - - sqrt_real_array1d = sqrt(x) - - endfunction sqrt_real_array1d - - function invsqrt_real_array1d(x) - real(dp), dimension(:), intent(in) :: x - real(dp), dimension(size(x)) :: invsqrt_real_array1d - - invsqrt_real_array1d = 1.0_dp/sqrt(x) - - endfunction invsqrt_real_array1d - - function matrix_exp_d(a) - real(dp), intent(in) :: a(:,:) - real(dp) :: matrix_exp_d(size(a,1),size(a,2)) - - integer :: n - complex(dp), allocatable :: rv(:,:) - complex(dp), allocatable :: ev(:), rv_inv(:,:) - - if (size(a,1) /= size(a,2)) call system_abort("matrix_exp_d needs a square matrix, not "//size(a,1)//"x"//size(a,2)) - - n = size(a,1) - allocate(rv(n,n), rv_inv(n,n), ev(n)) - - call nonsymmetric_diagonalise(a, ev, r_evects=rv) - call inverse(rv, rv_inv) - - matrix_exp_d = ((rv .multd. exp(ev)) .mult. rv_inv) - - deallocate(rv, rv_inv, ev) - end function matrix_exp_d - - subroutine find_nonzero_chunk_real1d(this,first,last) - real(dp), dimension(:), intent(in) :: this - integer, intent(out), optional :: first, last - - integer :: i - - if(present(first)) then - first = 1 - do i = 1, size(this) - if(this(i) /= 0.0_dp) then - first = i - exit - endif - enddo - endif - - if(present(last)) then - last = 1 - do i = size(this), 1, -1 - if(this(i) /= 0.0_dp) then - last = i - exit - endif - enddo - endif - - endsubroutine find_nonzero_chunk_real1d - - - subroutine svdfact(in_matrix, u_out, s_out, vt_out) - - real(dp), intent(in) :: in_matrix(:,:) - real(dp), dimension(:), intent(out) :: s_out - real(dp), dimension(:,:), intent(out) :: u_out, vt_out - real(dp), allocatable :: s(:), u(:,:), vt(:,:) - real(dp), allocatable :: work(:) - integer, allocatable :: iwork(:) - integer :: n_dimension, info, i, lwork, j - - call print('entering svdfact', verbosity=PRINT_VERBOSE) - - n_dimension = size(in_matrix(:,1)) - if (size(in_matrix(:,2)) /= n_dimension) call system_abort("svdfact only implemented for square matrices") - !call print('Dimension of the Matrix : '//n_dimension, verbosity=PRINT_VERBOSE) - - allocate(s(n_dimension), u(n_dimension,n_dimension), vt(n_dimension,n_dimension)) - allocate(iwork(8*n_dimension)) - lwork = -1 - allocate(work(1)) - call DGESDD('A', n_dimension,n_dimension,in_matrix,n_dimension, s, u,n_dimension, vt,n_dimension, work, lwork, iwork, info) - - lwork = work(1) - deallocate(work) - - allocate(work(lwork)) - call DGESDD('A', n_dimension,n_dimension,in_matrix,n_dimension, s, u,n_dimension, vt,n_dimension, work, lwork, iwork, info) - deallocate(work) - deallocate(iwork) - - call print("DGESDD finished with exit code "//info, verbosity=PRINT_VERBOSE) - - if (info /= 0) then - if (info < 0) then - write(line,'(a,i0)')'SVD: Problem with argument ',-info - call system_abort(line) - else - call system_abort('SVD: DBDSDC (called from DGESDD) did not converge') - end if - end if - - do j=1, size(s) - call print("svd values "// j//" "//s(j), verbosity=PRINT_VERBOSE) - end do - call print("smallest, largest value : "//minval(abs(s))//" "//maxval(abs(s)), verbosity=PRINT_VERBOSE) - - s_out = s - u_out = u - vt_out = vt - - deallocate(s) - deallocate(u) - deallocate(vt) - - call print('finished svdfact', PRINT_VERBOSE) - - end subroutine svdfact - - subroutine inverse_svd_threshold(in_matrix, thresh, result_inv, u_out, vt_out) - - real(dp), intent(in) :: in_matrix(:,:) - real(dp), intent(in), optional :: thresh - real(dp), intent(out), dimension(:,:), optional :: u_out, vt_out - real(dp), intent(out), dimension(:,:), optional :: result_inv - - real(dp), allocatable :: w(:), sigmainv(:,:), u(:,:), vt(:,:) - real(dp), allocatable :: work(:) - integer :: n, m, k, info, i, lwork, j - - real(dp) :: thresh_use - - call print('entering inverse_svd_threshold', verbosity=PRINT_VERBOSE) - - m = size(in_matrix,1) - n = size(in_matrix,2) - k = min(m, n) - !call print('Dimension of the Matrix : '//m//' x '//n, verbosity=PRINT_VERBOSE) - - allocate(w(k), sigmainv(n,m), u(m,m), vt(n,n)) - - lwork = -1 - allocate(work(1)) - call DGESVD('A','A', m,n,in_matrix,m, w, u,m, vt,n, work, lwork, info) - - lwork = work(1) - deallocate(work) - allocate(work(lwork)) - - call DGESVD('A','A', m,n,in_matrix,m, w, u,m, vt,n, work, lwork, info) - call print("DGESVD finished with exit code "//info, verbosity=PRINT_VERBOSE) - deallocate(work) - - if (present(result_inv)) then - - if (info /= 0) then - if (info < 0) then - write(line,'(a,i0)')'SVD: Problem with argument ',-info - call system_abort(line) - else - call system_abort('SVD: DBDSQR (called from DGESVD) did not converge') - end if - end if - - do j=1, size(w) - call print("svd values "// j//" "//w(j), verbosity=PRINT_VERBOSE) - end do - call print("smallest, largest value : "//minval(abs(w))//" "//maxval(abs(w)), verbosity=PRINT_VERBOSE) - - if (present(thresh)) then - if (thresh >= 0.0) then - thresh_use = thresh*TOL_SVD - else - thresh_use = abs(thresh)*TOL_SVD*w(1) - endif - else - thresh_use = real(max(m, n), kind=dp) * epsilon(1.0_dp) * w(1) - endif - - sigmainv = 0.0_dp - j = 0 - do i=1, k - if (w(i) < thresh_use) then - sigmainv(i,i) = 0.0_dp - j = j + 1 - else - sigmainv(i,i) = 1.0_dp/w(i) - end if - end do - - call print("the number of zero singular values : "//j, verbosity=PRINT_VERBOSE) - - result_inv = transpose(vt) .mult. sigmainv .mult. transpose(u) - - end if ! on condition of matrix inverting - - if (present(u_out)) u_out = u - if (present(vt_out)) vt_out = vt - - deallocate(w) - deallocate(sigmainv) - deallocate(u) - deallocate(vt) - - call print('finished inverse_svd_threshold', verbosity=PRINT_VERBOSE) - - end subroutine inverse_svd_threshold - - pure function frobenius_norm(this) result(norm) - real(dp), dimension(:,:), intent(in) :: this - real(dp) :: norm - integer :: i, j - - norm = 0.0_dp - do j=1, size(this,2) - do i=1, size(this,1) - norm = norm + this(i,j)**2 - end do - end do - norm = sqrt(norm) - end function frobenius_norm - - ! polynomial switching function for implementing a cutoff - - ! a sigmoid going from 1 to zero smoothly. - ! the first three derivatives are exactly zero at the end points - function poly_switch(r,cutoff_in,transition_width) - - real(dp) :: poly_switch - real(dp), intent(in) :: r, cutoff_in, transition_width - real(dp) :: x, x4 - - if( r > cutoff_in ) then - poly_switch = 0.0_dp - elseif( r > (cutoff_in-transition_width) ) then - x = (r - (cutoff_in - transition_width))/transition_width - x4 = x**4 - poly_switch = 1 - 35.0_dp*(x4) +84.0_dp*(x4*x) - 70.0_dp * (x4*x*x) + 20.0_dp* (x4)*(x**3) - else - poly_switch = 1.0_dp - endif - - end function poly_switch - - function dpoly_switch(r,cutoff_in,transition_width) - - real(dp) :: dpoly_switch - real(dp), intent(in) :: r, cutoff_in, transition_width - real(dp) :: x - - if( r > cutoff_in ) then - dpoly_switch = 0.0_dp - elseif( r > (cutoff_in-transition_width) ) then - x = (r - (cutoff_in - transition_width))/transition_width - dpoly_switch = 140.0_dp *( (x-1.0_dp)**3 )* (x**3) - dpoly_switch = dpoly_switch / transition_width - else - dpoly_switch = 0.0_dp - endif - - end function dpoly_switch - - function d2poly_switch(r,cutoff_in,transition_width) - - real(dp) :: d2poly_switch - real(dp), intent(in) :: r, cutoff_in, transition_width - real(dp) :: x - - if( r > cutoff_in ) then - d2poly_switch = 0.0_dp - elseif( r > (cutoff_in-transition_width) ) then - x = (r - (cutoff_in - transition_width))/transition_width - d2poly_switch = 420.0_dp * (x-1.0_dp)**2 * (x**2) * (2.0_dp*x-1.0_dp) - d2poly_switch = d2poly_switch / (transition_width)**2 - else - d2poly_switch = 0.0_dp - endif - - end function d2poly_switch - - function d3poly_switch(r,cutoff_in,transition_width) - - real(dp) :: d3poly_switch - real(dp), intent(in) :: r, cutoff_in, transition_width - real(dp) :: x - - if( r > cutoff_in ) then - d3poly_switch = 0.0_dp - elseif( r > (cutoff_in-transition_width) ) then - x = (r - (cutoff_in - transition_width))/transition_width - d3poly_switch = 840.0_dp * x * (5.0_dp*(x**3) - 10.0_dp*(x**2) + 6.0_dp*x -1.0_dp ) - d3poly_switch = d3poly_switch / (transition_width)**3 - else - d3poly_switch = 0.0_dp - endif - - end function d3poly_switch - - !################################################################################# - !# - !% Factorial, real result - !# - !################################################################################# - - elemental function factorial(n) result(res) - - ! factorial_real - - integer, intent(in) :: n - real(dp) :: res - integer :: i - - if (n<0) then - res = huge(1.0_dp) - res = res + 1.0_dp - elseif(n <= 20) then - res = factorial_table(n) - else - res=1.0_dp - do i=2,n - res = res*i - end do - end if - - endfunction factorial - - !################################################################################# - !# - !% Factorial, integer result - !# - !################################################################################# - - elemental function factorial_int(n) result(res) - - ! factorial_int - - integer, intent(in) :: n - integer :: res - integer :: i - - if (n<0) then - res = huge(n) - res = res + 1 - else - res=1 - do i=2,n - res = res*i - end do - end if - - endfunction factorial_int - - !################################################################################# - !# - !% Double factorial, real result - !# - !################################################################################# - - recursive function factorial2(n) result(res) - - ! double factorial - - integer, intent(in) :: n - real(dp) :: res - integer :: i - - if( n < -1 ) then - call system_abort('factorial2: negative argument') - else - res = 1.0_dp - do i = 2-mod(n,2), n, 2 - res = res*i - enddo - endif - - endfunction factorial2 - - !################################################################################# - !# - !% Binomial coefficient, real result - !# - !################################################################################# - - recursive function binom(n,r) result(res) - - ! binomial coefficients - - integer, intent(in) :: n,r - real(dp) :: res - integer :: i - - if((n<0) .or. (r<0) .or. (n cutoff_in ) then - cos_cutoff_function = 0.0_dp - else - cos_cutoff_function = 0.5_dp * ( cos(PI*r/cutoff_in) + 1.0_dp ) - endif - !if( r > cutoff_in ) then - ! cutoff = 0.0_dp - !elseif( r > (cutoff_in-S) ) then - ! cutoff = 0.5_dp * ( cos(PI*(r-cutoff_in+S)/S) + 1.0_dp ) - !else - ! cutoff = 1.0_dp - !endif - - endfunction cos_cutoff_function - - function dcos_cutoff_function(r,cutoff_in) - - real(dp) :: dcos_cutoff_function - real(dp), intent(in) :: r, cutoff_in - real(dp), parameter :: S = 0.25_dp - - if( r > cutoff_in ) then - dcos_cutoff_function = 0.0_dp - else - dcos_cutoff_function = - 0.5_dp * PI * sin(PI*r/cutoff_in) / cutoff_in - endif - !if( r > r_cut ) then - ! dcutoff = 0.0_dp - !elseif( r > (cutoff_in-S) ) then - ! dcutoff = - 0.5_dp * PI * sin(PI*(r-cutoff_in+S)/S) / S - !else - ! dcutoff = 0.0_dp - !endif - - endfunction dcos_cutoff_function - - elemental function coordination_function_upper(r,cutoff_in,transition_width) - - real(dp) :: coordination_function_upper - real(dp), intent(in) :: r, cutoff_in, transition_width - - if( r > cutoff_in ) then - coordination_function_upper = 0.0_dp - elseif( r > (cutoff_in-transition_width) ) then - coordination_function_upper = 0.5_dp * ( cos(PI*(r-cutoff_in+transition_width)/transition_width) + 1.0_dp ) - else - coordination_function_upper = 1.0_dp - endif - - endfunction coordination_function_upper - - elemental function dcoordination_function_upper(r,cutoff_in,transition_width) - - real(dp) :: dcoordination_function_upper - real(dp), intent(in) :: r, cutoff_in,transition_width - - if( r > cutoff_in ) then - dcoordination_function_upper = 0.0_dp - elseif( r > (cutoff_in-transition_width) ) then - dcoordination_function_upper = - 0.5_dp * PI * sin(PI*(r-cutoff_in+transition_width)/transition_width) / transition_width - else - dcoordination_function_upper = 0.0_dp - endif - - endfunction dcoordination_function_upper - - elemental function d2coordination_function_upper(r,cutoff_in,transition_width) - - real(dp) :: d2coordination_function_upper - real(dp), intent(in) :: r, cutoff_in,transition_width - - if( r > cutoff_in ) then - d2coordination_function_upper = 0.0_dp - elseif( r > (cutoff_in-transition_width) ) then - d2coordination_function_upper = - 0.5_dp * ((PI/ transition_width)**2) * cos(PI*(r-cutoff_in+transition_width)/transition_width) - else - d2coordination_function_upper = 0.0_dp - endif - - endfunction d2coordination_function_upper - - !NB this third derivative is not continuous! - elemental function d3coordination_function_upper(r,cutoff_in,transition_width) - - real(dp) :: d3coordination_function_upper - real(dp), intent(in) :: r, cutoff_in,transition_width - - if( r > cutoff_in ) then - d3coordination_function_upper = 0.0_dp - elseif( r > (cutoff_in-transition_width) ) then - d3coordination_function_upper = 0.5_dp * ((PI/ transition_width)**3) * sin(PI*(r-cutoff_in+transition_width)/transition_width) - else - d3coordination_function_upper = 0.0_dp - endif - - endfunction d3coordination_function_upper - - - function coordination_function_lower_upper(r,lower_cutoff_in,lower_transition_width, upper_cutoff_in, upper_transition_width) - - real(dp) :: coordination_function_lower_upper - real(dp), intent(in) :: r, lower_cutoff_in, lower_transition_width, upper_cutoff_in, upper_transition_width - - coordination_function_lower_upper = coordination_function(r, upper_cutoff_in, upper_transition_width) * coordination_function(-r, -lower_cutoff_in, lower_transition_width) - - endfunction coordination_function_lower_upper - - function dcoordination_function_lower_upper(r,lower_cutoff_in,lower_transition_width, upper_cutoff_in, upper_transition_width) - - real(dp) :: dcoordination_function_lower_upper - real(dp), intent(in) :: r, lower_cutoff_in, lower_transition_width, upper_cutoff_in, upper_transition_width - - dcoordination_function_lower_upper = dcoordination_function(r, upper_cutoff_in, upper_transition_width) * coordination_function(-r, -lower_cutoff_in, lower_transition_width) - & - coordination_function(r, upper_cutoff_in, upper_transition_width) * dcoordination_function(-r, -lower_cutoff_in, lower_transition_width) - - endfunction dcoordination_function_lower_upper - - subroutine integerDigits(this,base,iDigits,error) - integer, intent(in) :: this, base - integer, dimension(:), intent(out) :: iDigits - integer, intent(out), optional :: error - - integer :: i, my_this - integer, dimension(size(iDigits)) :: baseDigits - - INIT_ERROR(error) - - baseDigits = (/ (i, i = 0, size(iDigits)-1) /) - baseDigits = base ** baseDigits - if( this > sum(baseDigits) ) then - RAISE_ERROR("integerDigits: number too large, wouldn't fit",error) - endif - - my_this = this - do i = size(iDigits), 1, -1 - iDigits(i) = my_this / baseDigits(i) - my_this = mod(my_this,baseDigits(i)) - enddo - - endsubroutine integerDigits - -!!$ -!!$ function fermi_dirac_function(r,cutoff_in,transition_width) -!!$ -!!$ real(dp) :: fermi_dirac_function -!!$ real(dp), intent(in) :: r, cutoff_in, transition_width -!!$ real(dp) :: ex, numerical_zero -!!$ numerical_zero = 1e-16_dp -!!$ -!!$ ex = exp((r-cutoff_in)/transition_width) -!!$ -!!$ if( ex < numerical_zero ) then -!!$ fermi_dirac_function= 1.0_dp -!!$ elseif( 1/ex < numerical_zero) then -!!$ fermi_dirac_function = 0.0_dp -!!$ else -!!$ fermi_dirac_function = 1.0_dp / (ex + 1.0_dp) -!!$ endif -!!$ -!!$ endfunction fermi_dirac_function -!!$ -!!$ -!!$ function d_ln_fermi_dirac_function(r,cutoff_in,transition_width) -!!$ -!!$ real(dp) :: d_ln_fermi_dirac_function -!!$ real(dp), intent(in) :: r, cutoff_in, transition_width -!!$ real(dp) :: ex, numerical_zero -!!$ numerical_zero = 1e-16_dp -!!$ -!!$ ex = exp((r-cutoff_in)/transition_width) -!!$ -!!$ if( ex < numerical_zero ) then -!!$ d_ln_fermi_dirac_function = 0.0_dp -!!$ else -!!$ d_ln_fermi_dirac_function = (-1.0_dp/transition_width)* (r) / (1.0_dp + 1/ex) -!!$ endif -!!$ -!!$ endfunction d_ln_fermi_dirac_function - - subroutine matrix_z_make_hermitian(m, error) - complex(dp), intent(inout) :: m(:,:) - integer, intent(out), optional :: error - integer i, j - - complex(dp) :: v - - INIT_ERROR(error) - - if (.not. is_square(m)) then - RAISE_ERROR("matrix_z_make_hermitian got non-square matrix", error) - endif - - do i=1, size(m,1) - do j=i, size(m,2) - v = 0.5_dp*(m(i,j) + conjg(m(j,i))) - m(i,j) = v - m(j,i) = conjg(v) - end do - end do - end subroutine matrix_z_make_hermitian - - - subroutine matrix_d_make_hermitian(m, error) - real(dp), intent(inout) :: m(:,:) - integer, intent(out), optional :: error - integer i, j - - real(dp) :: v - - INIT_ERROR(error) - - if (.not. is_square(m)) then - RAISE_ERROR("matrix_d_make_hermitian got non-square matrix", error) - endif - - do i=1, size(m,1) - do j=i+1, size(m,2) - v = 0.5_dp*(m(i,j) + m(j,i)) - m(i,j) = v - m(j,i) = v - end do - end do - end subroutine matrix_d_make_hermitian - - -end module linearalgebra_module diff --git a/src/libAtoms/lobpcg.f95 b/src/libAtoms/lobpcg.f95 deleted file mode 100644 index 2d68484a31..0000000000 --- a/src/libAtoms/lobpcg.f95 +++ /dev/null @@ -1,686 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine matrix_general_diagonlise_lobpcg_sandia(A, M, evals, evecs, block_size, & - precond, no_guess, err) - real(dp),intent(in), dimension(:,:) :: A - real(dp),intent(in), dimension(:,:) :: M - real(dp),intent(inout), dimension(:) :: evals - real(dp),intent(inout), dimension(:,:) :: evecs - integer, intent(in), optional :: block_size - real(dp),intent(in), dimension(:,:), optional :: precond(:,:) - logical, intent(in), optional :: no_guess - integer, intent(out), optional :: err - - real(dp), allocatable :: X_twid(:,:), X(:,:), RI(:,:), R(:), PI(:,:), & - HI(:,:), S(:,:), Y(:,:), YI(:,:), A_X(:,:), M_X(:,:), rr_M(:,:), M_HI(:,:), M_YI(:,:) - real(dp), allocatable :: evals_block(:), Y_evals(:) - - logical :: done, failed - logical :: my_no_guess - integer :: n_evecs, n_full_blocks, extra_block_size - integer :: N, i, iter, max_n_iter, bs, cbs, i_block, ii_block, nrr, prev_cbs - integer :: first_eval, last_eval, max_bs, max_n_new_block, got_n_evals - real(dp) :: max_r, max_r_hist(10) - integer :: n_needed - - call print("matrix_general_diagonlise_lobpcg_sandia", PRINT_VERBOSE) - - N = size(A, 1) - - my_no_guess = optional_default(.true., no_guess) - max_bs = optional_default(1, block_size) - - n_evecs = size(evals) - if (n_evecs /= size(evecs,2)) & - call system_abort("called matrix_general_digonalise_lobpcg_sandia with mismatched evals and evecs size") - - call print("matrix_general_diagonalise_lpbpcg_sandia n_evecs " // & - n_evecs // " block_size " // max_bs, PRINT_VERBOSE) - - call print("n_full_blocks " // n_full_blocks // " extra_block_size " // extra_block_size, PRINT_VERBOSE) - - ! randomise evecs - if (my_no_guess) then - evecs = 0.0_dp - do i=1, n_evecs - call randomise(evecs(:,i), 1.0_dp) - end do - endif - - max_n_iter = 200 - max_n_new_block = 30 - - allocate(X_twid(N,max_bs)) - allocate(X(N,max_bs)) - allocate(A_X(N,max_bs)) - allocate(M_X(N,max_bs)) - allocate(evals_block(max_bs)) - allocate(R(N)) - allocate(RI(N,max_bs)) - allocate(PI(N,max_bs)) - allocate(HI(N,max_bs)) - allocate(M_HI(N,max_bs)) - allocate(Y(3*max_bs,max_bs)) - allocate(YI(3*max_bs,max_bs)) - allocate(M_YI(3*max_bs,max_bs)) - allocate(Y_evals(max_bs)) - allocate(S(N,3*max_bs)) - allocate(rr_M(3*max_bs,3*max_bs)) - - got_n_evals = 0 - i_block = 1 - failed = .false. - do while (got_n_evals < n_evecs .and. .not. failed) - - first_eval = got_n_evals + 1 - last_eval = min(first_eval+max_bs-1, N) - bs = last_eval-first_eval+1 - - call print("doing block " // first_eval // " - " // last_eval, PRINT_VERBOSE) - - n_needed = n_evecs-first_eval - ! copy block of eigenvectors - X_twid(1:N,1:min(bs,n_needed)) = evecs(1:N,first_eval:min(last_eval,n_evecs)) - if (n_needed < bs) then - do i=n_needed+1, bs - call randomise(X_twid(1:N,i), 1.0_dp) - end do - endif - - if (first_eval > 1) then - call matrix_product_sub(X(1:N,1:bs), M(1:N,1:N), X_twid(1:N,1:bs)) - call orthogonalise_col_vectors(X_twid(1:N,1:bs), evecs(1:N,1:first_eval-1), X(1:N,1:bs)) - endif - - call rr_solve(X_twid(1:N,1:bs), A(1:N,1:N), M(1:N,1:N), Y(1:bs,1:bs), Y_evals(1:bs)) - call matrix_product_sub(X(1:N,1:bs),X_twid(1:N,1:bs),Y(1:bs,1:bs)) - call matrix_product_sub(A_X(1:N,1:bs), A(1:N,1:N), X(1:N,1:bs)) - call matrix_product_sub(M_X(1:N,1:bs), M(1:N,1:N), X(1:N,1:bs)) - do i=1, bs - RI(1:N,i) = A_X(1:N,i) - Y_evals(i)*M_X(1:N,i) - end do - PI(1:N,1:bs) = 0.0_dp - cbs = bs - iter = 1 - done = .false. - max_r_hist = 1e38_dp - do while (iter < max_n_iter .and. .not. done .and. .not. failed) - call print("doing iter "//iter, PRINT_NERD) - if (present(precond)) then - call matrix_product_sub(HI(1:N,1:cbs), precond(1:N,1:N), RI(1:N,1:cbs)) - else - HI(1:N,1:cbs) = RI(1:N,1:cbs) - endif - - S(1:N,1:bs) = X(1:N,1:bs) - S(1:N,bs+1:bs+cbs) = PI(1:N,1:cbs) - - call matrix_product_sub(M_HI(1:N,1:cbs), M(1:N,1:N), HI(1:N,1:cbs)) - call orthogonalise_col_vectors(HI(1:N,1:cbs), S(1:N,1:bs+cbs), M_HI(1:N,1:cbs)) - - if (first_eval > 1) then - call orthogonalise_col_vectors(HI(1:N,1:cbs), evecs(1:N,1:first_eval-1), M_HI(1:N,1:cbs)) - end if - - S(1:N,1:bs) = X(1:N,1:bs) - S(1:N,bs+1:bs+cbs) = HI(1:N,1:cbs) - S(1:N,bs+cbs+1:bs+2*cbs) = PI(1:N,1:cbs) - if (iter == 1) then - nrr = bs+cbs - else - nrr = bs+2*cbs - endif - call rr_solve(S(1:N,1:nrr), A(1:N,1:N), M(1:N,1:N), Y(1:nrr,1:bs), Y_evals(1:bs), & - rr_M=rr_M(1:nrr,1:nrr)) - - call matrix_product_sub(X(1:N,1:bs), S(1:N,1:nrr), Y(1:nrr,1:bs)) - - call matrix_product_sub(A_X(1:N,1:bs), A(1:N,1:N), X(1:N,1:bs)) - call matrix_product_sub(M_X(1:N,1:bs), M(1:N,1:N), X(1:N,1:bs)) - if (iter == 1) then - YI = 0.0_dp - endif - prev_cbs = cbs - cbs = 0 - max_r = 0.0_dp - do i=1, bs - R(1:N) = A_X(1:N,i) - Y_evals(i)*M_X(1:N,i) - max_r = max(max_R, maxval(abs(R))) - if (maxval(abs(R(1:N))) > 1.0e-7_dp) then ! column not converged - cbs = cbs + 1 - RI(1:N,cbs) = R(1:N) - YI(1:nrr,cbs) = Y(1:nrr,i) - endif - end do - call print("residual max " // max_r // " cbs " // cbs, PRINT_VERBOSE) - max_r_hist(1:9) = max_r_hist(2:10) - max_r_hist(10) = max_r - - if (prev_cbs < cbs) then - call print("diverging, but block partially converged " // (bs-cbs), PRINT_VERBOSE) - done = .true. - n_needed = n_evecs-first_eval+1 - got_n_evals = got_n_evals + (bs-cbs) - ! copy all evecs and converged evals - evecs(1:N,first_eval:min(first_eval+(bs)-1,n_evecs)) = X(1:N,1:min(bs,n_needed)) - evals(first_eval:min(first_eval+(bs-cbs)-1,n_evecs)) = Y_evals(1:min(bs-cbs,n_needed)) - else if (cbs == 0) then ! all converged - done = .true. - n_needed = n_evecs-first_eval+1 - got_n_evals = got_n_evals + bs - ! copy converged evecs/evals - evecs(1:N,first_eval:min(last_eval,n_evecs)) = X(1:N,1:min(bs,n_needed)) - evals(first_eval:min(last_eval,n_evecs)) = Y_evals(1:min(bs,n_needed)) - else if (got_n_evals+(bs-cbs) >= n_evecs) then - call print("enough evecs done, but block partially converged " // (bs-cbs), PRINT_VERBOSE) - done = .true. - n_needed = n_evecs-first_eval+1 - got_n_evals = got_n_evals + (bs-cbs) - ! copy all evecs and converged evals - evecs(1:N,first_eval:min(first_eval+(bs)-1,n_evecs)) = X(1:N,1:min(bs,n_needed)) - evals(first_eval:min(first_eval+(bs-cbs)-1,n_evecs)) = Y_evals(1:min(bs-cbs,n_needed)) - else if (cbs /= bs .and. (iter > max_n_new_block .or. max_r_hist(10) > max_r_hist(5)*0.75_dp)) then - call print("block partially converged " // (bs-cbs), PRINT_VERBOSE) - done = .true. - n_needed = n_evecs-first_eval+1 - got_n_evals = got_n_evals + (bs-cbs) - ! copy all evecs and converged evals - evecs(1:N,first_eval:min(first_eval+(bs)-1,n_evecs)) = X(1:N,1:min(bs,n_needed)) - evals(first_eval:min(first_eval+(bs-cbs)-1,n_evecs)) = Y_evals(1:min(bs-cbs,n_needed)) - else - done = .false. - YI(1:bs,1:cbs) = 0.0_dp - call matrix_product_sub(M_YI(1:nrr,1:bs), rr_M(1:nrr,1:nrr), YI(1:nrr, 1:bs)) - call orthogonalise_col_vectors(YI(1:nrr,1:cbs), Y(1:nrr,1:bs), M_YI(1:nrr,1:cbs)) - - call matrix_product_sub(PI(1:N,1:cbs), S(1:N,1:nrr), YI(1:nrr,1:cbs)) - endif - - iter = iter + 1 - - end do ! iter - call print("block " // i_block // " took " // iter // " iterations") - if (iter >= max_n_iter) then - failed = .true. - endif - end do ! i_block - - deallocate(X_twid) - deallocate(X) - deallocate(A_X) - deallocate(M_X) - deallocate(evals_block) - deallocate(R) - deallocate(RI) - deallocate(PI) - deallocate(HI) - deallocate(M_HI) - deallocate(Y) - deallocate(YI) - deallocate(M_YI) - deallocate(Y_evals) - deallocate(S) - deallocate(rr_M) - - if (present(err)) err = 0 - - if (failed) then - if (present(err)) then - err = 1 - call print("matrix_general_diagonalise_lobpcg_sandia failed") - return - else - call system_abort("matrix_general_diagonalise_lobpcg_sandia failed") - endif - endif - - end subroutine matrix_general_diagonlise_lobpcg_sandia - - subroutine rr_solve(X, A, M, Y, evals, rr_A, rr_M) - real(dp), intent(in) :: X(:,:), A(:,:), M(:,:) - real(dp), intent(out) :: Y(:,:) - real(dp), intent(out) :: evals(:) - real(dp), intent(out), target, optional :: rr_A(:,:), rr_M(:,:) - - integer :: N, rr_size - real(dp), allocatable :: YY(:,:), ev(:) - real(dp), allocatable :: A_X(:,:), M_X(:,:) - real(dp), pointer :: l_rr_A(:,:), l_rr_M(:,:) - - if (size(A,1) /= size(A,2)) call system_abort("called rr_solve with non-square A") - if (size(M,1) /= size(M,2)) call system_abort("called rr_solve with non-square M") - if (size(X,1) /= size(A,1)) call system_abort("called rr_solve with X size not matching A/M size") - if (size(X,2) /= size(Y,1)) call system_abort("called rr_solve with X size not matching Y size") - if (size(X,2) < size(Y,2)) call system_abort("called rr_solve with X size too small for Y size") - if (size(X,2) < size(evals)) call system_abort("called rr_solve with Y size too small for evals size") - - N = size(X,1) - rr_size = size(X,2) - - if (present(rr_A)) then - if (size(rr_A,1) /= size(rr_A,2)) call system_abort("called rr_solve with non-square rr_A") - if (size(rr_A,1) /= rr_size) call system_abort("called rr_solve with rr_A size not matching X size") - l_rr_A => rr_A - else - allocate(l_rr_A(rr_size,rr_size)) - endif - if (present(rr_M)) then - if (size(rr_M,1) /= size(rr_M,2)) call system_abort("called rr_solve with non-square rr_M") - if (size(rr_M,1) /= rr_size) call system_abort("called rr_solve with rr_M size not matching X size") - l_rr_M => rr_M - else - allocate(l_rr_M(rr_size,rr_size)) - endif - - allocate(YY(rr_size,rr_size)) - allocate(ev(rr_size)) - allocate(A_X(N,rr_size)) - allocate(M_X(N,rr_size)) - - call matrix_product_sub(A_X(1:N,1:rr_size), A(1:N,1:N), X(1:N,1:rr_size)) - call matrix_product_sub(M_X(1:N,1:rr_size), M(1:N,1:N), X(1:N,1:rr_size)) - call matrix_product_sub(l_rr_A(1:rr_size,1:rr_size), X(1:N,1:rr_size), A_X(1:N,1:rr_size), & - m1_transpose=.true., m2_transpose=.false.) - call matrix_product_sub(l_rr_M(1:rr_size,1:rr_size), X(1:N,1:rr_size), M_X(1:N,1:rr_size), & - m1_transpose=.true., m2_transpose=.false.) - - call diagonalise(l_rr_A, l_rr_M, ev, YY) - - evals(:) = ev(1:size(evals)) - Y(1:rr_size,:) = YY(1:rr_size,1:size(Y,2)) - - deallocate(YY) - deallocate(ev) - deallocate(A_X) - deallocate(M_X) - if (.not. present(rr_A)) deallocate(l_rr_A) - if (.not. present(rr_M)) deallocate(l_rr_M) - end subroutine rr_solve - -! subroutine matrix_general_diagonlise_lobpcg(B, A, evals, evecs, n_evecs, block_size, & -! precond, no_guess, largest, err) -! real(dp),intent(in), dimension(:,:) :: A -! real(dp),intent(in), dimension(:,:) :: B -! real(dp),intent(inout), dimension(:) :: evals -! real(dp),intent(inout), dimension(:,:) :: evecs -! integer, intent(in), optional :: n_evecs -! integer, intent(in), optional :: block_size -! real(dp),intent(in), dimension(:,:), optional :: precond(:,:) -! logical, intent(in), optional :: no_guess -! logical, intent(in), optional :: largest -! integer, intent(out), optional :: err -! -! logical :: my_no_guess, my_largest -! integer :: my_n_evecs, my_block_size -! integer :: i_block, ii_block, n_full_blocks, extra_block_size -! integer :: i, j -! integer :: N -! integer :: iter, max_n_iter -! real(dp), allocatable :: evals_block(:) -! real(dp), allocatable :: RR_evals(:) -! real(dp), allocatable :: tt(:,:), R(:,:), W(:,:), P(:,:), RR_basis(:,:), RR_basis_AorB(:,:), & -! RR_mat_A(:,:), RR_mat_B(:,:), evecs_block(:,:), A_evecs_block(:,:), B_evecs_block(:,:) -! real(dp), allocatable :: RR_evecs(:,:) -! logical :: done -! -! integer :: i_max, rr_min, rr_max, rr_step -! real(dp) :: mag -! -! call print("matrix_general_diagonlise_lobpcg", PRINT_VERBOSE) -! -! N = size(A, 1) -! call print("N " // N, PRINT_VERBOSE) -! -! my_no_guess = optional_default(.true., no_guess) -! my_largest = optional_default(.false., largest) -! my_n_evecs = optional_default(N, n_evecs) -! my_block_size = optional_default(1, block_size) -! n_full_blocks = my_n_evecs/my_block_size -! extra_block_size = my_n_evecs - n_full_blocks*my_block_size -! if (extra_block_size /= 0) & -! call system_abort("lobpcg can't handle non integer number of blocks yet") -! -! call print("matrix_general_diagonalise_lobpcg n_evecs " // & -! my_n_evecs // " block_size " // my_block_size, PRINT_VERBOSE) -! -! call print("n_full_blocks " // n_full_blocks // " extra_block_size " // extra_block_size, PRINT_VERBOSE) -! -! allocate(evecs_block(N, my_block_size)) -! allocate(A_evecs_block(N, my_block_size)) -! allocate(B_evecs_block(N, my_block_size)) -! allocate(evals_block(my_block_size)) -! allocate(tt(N, my_block_size)) -! allocate(R(N, my_block_size)) -! allocate(W(N, my_block_size)) -! allocate(P(N, my_block_size)) -! allocate(RR_basis(N, 3*my_block_size)) -! allocate(RR_basis_AorB(N, 3*my_block_size)) -! allocate(RR_mat_A(3*my_block_size, 3*my_block_size)) -! allocate(RR_mat_B(3*my_block_size, 3*my_block_size)) -! allocate(RR_evecs(3*my_block_size, 3*my_block_size)) -! allocate(RR_evals(3*my_block_size)) -! -! ! randomise evecs -! if (my_no_guess) then -! evecs = 0.0_dp -! do i=1, n_evecs -! call randomise(evecs(:,i), 1.0_dp) -! end do -! endif -! -! max_n_iter = 100 -! -! do i_block=1, n_full_blocks -! call print("doing block " // i_block, PRINT_VERBOSE) -! -! ! copy block of eigenvectors -! evecs_block = evecs(:,(i_block-1)*my_block_size+1:i_block*my_block_size) -! call print("raw evecs_block", PRINT_ANALYSIS) -! call print(evecs_block, PRINT_ANALYSIS) -! -! ! A orthogonalize evecs_block w.r.t. previous blocks -! do ii_block=1, i_block-1 -! call orthogonalise_col_vectors(evecs_block, & -! evecs(:,(ii_block-1)*my_block_size+1:ii_block*my_block_size), A) -! end do -! -! call print("orthogonalized evecs_block", PRINT_ANALYSIS) -! call print(evecs_block, PRINT_ANALYSIS) -! -! P = 0.0_dp -! iter = 1 -! done = .false. -! do while (iter <= max_n_iter .and. .not. done) -! call print("doing iter " // iter, PRINT_NERD) -! -! ! evaluate eigenvalues -! call matrix_product_sub(A_evecs_block, A, evecs_block) -! call matrix_product_sub(B_evecs_block, B, evecs_block) -! if (iter == 1) & -! evals_block(:) = sum(evecs_block*B_evecs_block,1)/ & -! sum(evecs_block*A_evecs_block,1) -! -! call print("evals_block", PRINT_NERD) -! call print(evals_block, PRINT_NERD) -! call print("evecs_block", PRINT_ANALYSIS) -! call print(evecs_block, PRINT_ANALYSIS) -! -! ! evaluate residual -! do i=1, block_size -! R(:,i) = B_evecs_block(:,i) - evals_block(i)*A_evecs_block(:,i) -! end do -! -! call print("R", PRINT_ANALYSIS) -! call print(R, PRINT_ANALYSIS) -! -! mainlog%default_real_precision=16 -! call print("residual max " // maxval(abs(R)), PRINT_VERBOSE) -! mainlog%default_real_precision=8 -! done = (maxval(abs(R)) < 1.0e-8_dp) -! -! if (.not. done) then -! -! ! precondition -! if (present(precond)) then -! call matrix_product_sub(W, precond, R) -! else -! W = R -! endif -! -! call print("W", PRINT_ANALYSIS) -! call print(W, PRINT_ANALYSIS) -! -! ! A orthogonalize W w.r.t. previous blocks -! do ii_block=1, i_block-1 -! call orthogonalise_col_vectors(W, & -! evecs(:,(ii_block-1)*my_block_size+1:ii_block*my_block_size), A) -! end do -! -! call print("orthogonalized W", PRINT_ANALYSIS) -! call print(W, PRINT_ANALYSIS) -! -! call print("P", PRINT_ANALYSIS) -! call print(P, PRINT_ANALYSIS) -! -! ! evaluate Rayleigh-Ritz basis -! RR_basis(:,1:my_block_size) = evecs_block -! RR_basis(:,my_block_size+1:2*my_block_size) = W -! RR_basis(:,2*my_block_size+1:3*my_block_size) = P -! -! -! call print("RR_basis", PRINT_ANALYSIS) -! call print(RR_basis, PRINT_ANALYSIS) -! -! ! evaluate Rayleigh-Ritz matrices -! call matrix_product_sub(RR_basis_AorB, A, RR_basis) -! -! call matrix_product_sub(RR_mat_A, RR_basis_AorB, RR_basis, & -! m1_transpose=.true., m2_transpose=.false.) -! call print("RR_mat_A", PRINT_ANALYSIS) -! call print(RR_mat_A, PRINT_ANALYSIS) -! call matrix_product_sub(RR_basis_AorB, B, RR_basis) -! call matrix_product_sub(RR_mat_B, RR_basis_AorB, RR_basis, & -! m1_transpose=.true., m2_transpose=.false.) -! call print("RR_mat_B", PRINT_ANALYSIS) -! call print(RR_mat_B, PRINT_ANALYSIS) -! -! ! diagonalise Rayleigh-Ritz matrix -! if (iter == 1) then -! call diagonalise(RR_mat_B(1:2*block_size,1:2*block_size), & -! RR_mat_A(1:2*block_size,1:2*block_size), & -! RR_evals(1:2*block_size), RR_evecs(1:2*block_size,1:2*block_size)) -! call print("RR_evals", PRINT_NERD) -! call print(RR_evals(1:2*block_size), PRINT_NERD) -! call print("RR_evecs", PRINT_ANALYSIS) -! call print(RR_evecs(1:2*block_size,1:2*block_size), PRINT_ANALYSIS) -! else -! call diagonalise(RR_mat_B, RR_mat_A, RR_evals, RR_evecs) -! call print("RR_evals", PRINT_NERD) -! call print(RR_evals, PRINT_NERD) -! call print("RR_evecs", PRINT_ANALYSIS) -! call print(RR_evecs, PRINT_ANALYSIS) -! endif -! -! if (iter == 1) then -! i_max = 2*my_block_size -! if (my_largest) then -! rr_min = 2*my_block_size -! rr_max = my_block_size+1 -! rr_step = -1 -! else -! rr_min = my_block_size+1 -! rr_max = 2*my_block_size -! rr_step = 1 -! endif -! else -! i_max = 3*my_block_size -! if (my_largest) then -! rr_min = 3*my_block_size -! rr_max = 2*my_block_size+1 -! rr_step = -1 -! else -! rr_min = 2*my_block_size+1 -! rr_max = 3*my_block_size -! rr_step = 1 -! endif -! endif -! -! ! Create new evecs from Rayleigh-Ritz vectors -! call matrix_product_sub(evecs_block, RR_basis(:,1:i_max), & -! RR_evecs(1:i_max,rr_min:rr_max:rr_step)) -! -! ! copy Rayleigh-Ritz evals (ignored, because of orthogonalization) -! evals_block = RR_evals(rr_min:rr_max:rr_step) -! -! ! Create new Ps from Rayleigh-Ritz vectors -! RR_evecs(1:my_block_size,:) = 0.0_dp -! call matrix_product_sub(P, RR_basis(:,1:i_max), RR_evecs(1:i_max,rr_min:rr_max:rr_step)) -! -! iter = iter + 1 -! end if -! end do ! while not converged -! -! if (.not. done) then -! if (present(err)) then -! err = 1 -! deallocate(evecs_block) -! deallocate(A_evecs_block) -! deallocate(B_evecs_block) -! deallocate(evals_block) -! deallocate(tt) -! deallocate(R) -! deallocate(W) -! deallocate(P) -! deallocate(RR_basis) -! deallocate(RR_basis_AorB) -! deallocate(RR_mat_A) -! deallocate(RR_mat_B) -! deallocate(RR_evecs) -! deallocate(RR_evals) -! return -! else -! call system_abort("matrix_general_diagonalise_lobpcg failed to converge in " // & -! iter // " iterations") -! endif -! endif -! -! ! copy blocks back into main arrays -! evecs(:,(i_block-1)*my_block_size+1:i_block*my_block_size) = evecs_block -! evals((i_block-1)*my_block_size+1:i_block*my_block_size) = evals_block -! call print("block " // i_block // " took " // iter // " iterations") -! -! end do ! i_block -! -! if (present(err)) err = 0 -! -! deallocate(evecs_block) -! deallocate(A_evecs_block) -! deallocate(B_evecs_block) -! deallocate(evals_block) -! deallocate(tt) -! deallocate(R) -! deallocate(W) -! deallocate(P) -! deallocate(RR_basis) -! deallocate(RR_basis_AorB) -! deallocate(RR_mat_A) -! deallocate(RR_mat_B) -! deallocate(RR_evecs) -! deallocate(RR_evals) -! -! end subroutine matrix_general_diagonlise_lobpcg -! -! -! ! assume A is symmetric -! subroutine orthogonalise_col_vectors(V1, V2, A) -! real(dp), intent(inout) :: V1(:,:) -! real(dp), intent(in) :: V2(:,:) -! real(dp), intent(in), optional :: A(:,:) -! -! real(dp), allocatable :: A_V1(:,:), V2_V2T(:,:) -! integer :: N, n_v1, n_v2 -!integer i -! -! if (present(A)) then -! if (size(A,2) /= size(V1,1)) & -! call system_abort("called orthogonalise_col_vectors with V1 size not matching A size") -! if (size(A,1) /= size(V2,1)) & -! call system_abort("called orthogonalise_col_vectors with V2 size not matching A size") -! else -! if (size(V1,1) /= size(V2,1)) & -! call system_abort("called orthogonalise_col_vectors with V1 size not matching V2 size") -! endif -! -! if (present(A)) then -! allocate(A_V1(size(A,1),size(V1,2))) -! call matrix_product_sub(A_V1, A, V1) -! endif -! -! allocate(V2_V2T(size(V2,1), size(V2,1))) -! call matrix_product_sub(V2_V2T, V2, V2, m1_transpose=.false., m2_transpose=.true.) -! -! if (present(A)) then -! call matrix_product_sub(V1, V2_V2T, A_V1, lhs_factor=1.0_dp, rhs_factor=-1.0_dp) -!call matrix_product_sub(A_V1, A, V1) -!do i=1, size(V1,2) -! V1(:,i) = V1(:,i)/sqrt(sum(V1(:,i)*A_V1(:,i))) -!end do -! deallocate(A_V1) -! else -! call matrix_product_sub(V1, V2_V2T, V1, lhs_factor=1.0_dp, rhs_factor=-1.0_dp) -!do i=1, size(V1,2) -! V1(:,i) = V1(:,i)/sqrt(sum(V1(:,i)*V1(:,i))) -!end do -! endif -! deallocate(V2_V2T) -! -! end subroutine orthogonalise_col_vectors - - ! assume A is symmetric - subroutine orthogonalise_col_vectors(V1, V2, A_V1) - real(dp), intent(inout) :: V1(:,:) - real(dp), intent(in) :: V2(:,:) - real(dp), intent(inout), optional :: A_V1(:,:) - - real(dp), allocatable :: V2_V2T(:,:) - real(dp) :: mag - integer :: i - - if (present(A_V1)) then - if (size(A_V1,1) /= size(V1,1)) & - call system_abort("called orthogonalise_col_vectors with V1 size not matching A_V1 size") - if (size(A_V1,2) /= size(V1,2)) & - call system_abort("called orthogonalise_col_vectors with V1 size not matching A_V1 size") - else - if (size(V1,1) /= size(V2,1)) & - call system_abort("called orthogonalise_col_vectors with V1 size not matching V2 size") - endif - - allocate(V2_V2T(size(V2,1), size(V2,1))) - call matrix_product_sub(V2_V2T, V2, V2, m1_transpose=.false., m2_transpose=.true.) - - if (present(A_V1)) then - call matrix_product_sub(V1, V2_V2T, A_V1, lhs_factor=1.0_dp, rhs_factor=-1.0_dp) - do i=1, size(V1,2) - mag = sqrt(sum(V1(:,i)*A_V1(:,i))) - V1(:,i) = V1(:,i)/mag - A_V1(:,i) = A_V1(:,i)/mag - end do - else - call matrix_product_sub(V1, V2_V2T, V1, lhs_factor=1.0_dp, rhs_factor=-1.0_dp) - do i=1, size(V1,2) - V1(:,i) = V1(:,i)/sqrt(sum(V1(:,i)*V1(:,i))) - end do - endif - - deallocate(V2_V2T) - - end subroutine orthogonalise_col_vectors diff --git a/src/libAtoms/minimal_md.f95 b/src/libAtoms/minimal_md.f95 deleted file mode 100644 index b64fa04eed..0000000000 --- a/src/libAtoms/minimal_md.f95 +++ /dev/null @@ -1,102 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program md - use libAtoms_module - - implicit none - - real(dp), parameter :: dt = 1.0_dp ! Time step - real(dp), parameter :: init_temp = 300.0_dp - - type(DynamicalSystem) :: ds - type(Atoms) :: at, tmpat - type(cinoutput) :: movie - real(dp), allocatable :: f(:,:) - real(dp) :: Q - integer :: n - - call system_initialise - call initialise(movie, "movie.xyz", action=OUTPUT) - call diamond(tmpat, 3.5_dp) - call supercell(at, tmpat, 2, 2, 2) - call set_atoms(at, 6) - allocate(f(3,at%N)) ! Allocate force array - - call set_cutoff(at,3.0_dp) - call calc_connect(at) - call calc_dists(at) - call initialise(ds, at) - call rescale_velo(ds, init_temp) - call zero_momentum(ds) - - - Q = nose_hoover_mass(Ndof = 3*ds%N, T = init_temp, tau = 1000.0_dp) ! This 'tau' is the characteristic time of your system, - ! e.g. from phonon spectrum, and controls the coupling - ! of the thermostat to the system: - ! higher tau = higher mass = lower coupling - - call add_thermostat(ds, THERMOSTAT_NOSE_HOOVER_LANGEVIN, init_temp, Q = Q, tau = 5000.0_dp) ! This tau controls how fast the nose-hoover variable - ! explores phase space. - ! higher tau = slower, and more Nose-Hoover like. - -! call add_thermostat(ds, THERMOSTAT_NOSE_HOOVER, init_temp, Q = Q) -! call add_thermostat(ds, THERMOSTAT_LANGEVIN, init_temp, tau = 1000.0_dp) - - ! Use random forces - f = 0.0_dp - call randomise(f, 0.1_dp) - call zero_sum(f) - - do n = 1, 1000 - call ds_print_status(ds, 'M') - if(mod(n, 20) == 0) then - call write(ds%atoms,movie) - call calc_connect(ds%atoms) - end if - - call advance_verlet1(ds, dt) - - !Calculate new forces - f = 0.0_dp - call randomise(f, 0.1_dp) - call zero_sum(f) - - call advance_verlet2(ds, dt, f) - - end do - - call finalise(at) - call finalise(ds) - call finalise(movie) - deallocate(f) - - call system_finalise() -end program md diff --git a/src/libAtoms/minimization.f95 b/src/libAtoms/minimization.f95 deleted file mode 100644 index 9cf575fbe8..0000000000 --- a/src/libAtoms/minimization.f95 +++ /dev/null @@ -1,6246 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Minimization module -!X -!% This module contains subroutines to perform conjugate gradient and -!% damped MD minimisation of an objective function. -!% The conjugate gradient minimiser can use various different line minimisation routines. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" -module minimization_module - - use error_module - use system_module - use linearalgebra_module - implicit none - private - SAVE - - public :: minim, n_minim, fire_minim, test_gradient, n_test_gradient, precon_data, preconminim, precondimer - - public :: KahanSum, DoubleKahanSum - - real(dp),parameter:: DXLIM=huge(1.0_dp) !% Maximum amount we are willing to move any component in a linmin step - - ! parameters from Numerical Recipes */ - real(dp),parameter:: GOLD=1.618034_dp - integer, parameter:: MAXFIT=5 - real(dp),parameter:: TOL=1e-2_dp - real(dp),parameter:: CGOLD=0.3819660_dp - real(dp),parameter:: ZEPS=1e-10_dp - integer, parameter:: ITER=50 - - type precon_data - logical :: multI = .FALSE. - logical :: diag = .FALSE. - logical :: dense = .FALSE. - integer, allocatable :: preconrowlengths(:) - integer, allocatable :: preconindices(:,:) - real(dp), allocatable :: preconcoeffs(:,:,:) - character(10) :: precon_id - integer :: nneigh,mat_mult_max_iter,max_sub - real(dp) :: energy_scale,length_scale,cutoff,res2 - logical :: has_fixed = .FALSE. - real(dp) :: cell_coeff = 1.0_dp - real(dp) :: bulk_modulus, number_density, mu - end type precon_data - integer, parameter :: E_FUNC_BASIC=1, E_FUNC_KAHAN=2, E_FUNC_DOUBLEKAHAN=3 - - interface minim - module procedure minim - end interface - - interface preconminim - module procedure preconminim - end interface - - interface precondimer - module procedure precondimer - end interface - - interface test_gradient - module procedure test_gradient - end interface - - interface n_test_gradient - module procedure n_test_gradient - end interface - - interface smartmatmul - module procedure smartmatmulmat, smartmatmulvec - end interface - - ! LBFGS stuff - external QUIPLB2 - integer::MP,LP - real(dp)::GTOL,STPMIN,STPMAX - common /lb3/MP,LP,GTOL,STPMIN,STPMAX - -CONTAINS - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Smart line minimiser, adapted from Numerical Recipes. - !% The objective function is 'func'. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function linmin(x0,xdir,y,epsilon,func,data) - real(dp) :: x0(:) !% Starting position - real(dp) :: xdir(:)!% Direction of gradient at 'x0' - real(dp) :: y(:) !% Finishing position returned in 'y' after 'linmin' - real(dp)::epsilon !% Initial step size - INTERFACE - function func(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - end function func - END INTERFACE - character(len=1),optional::data(:) - integer:: linmin - - integer::i,it,sizeflag,N, bracket_it - real(dp)::Ea,Eb,Ec,a,b,c,r,q,u,ulim,Eu,fallback - real(dp)::v,w,x,Ex,Ev,Ew,e,d,xm,tol1,tol2,p,etmp - - ! Dynamically allocate to avoid stack overflow madness with ifort - real(dp), dimension(:), allocatable :: tmpa, tmpb, tmpc, tmpu - - !%RV Number of linmin steps taken, or zero if an error occured - - N=size(x0) - - allocate(tmpa(N), tmpb(N), tmpc(N), tmpu(N)) - tmpa=x0 - y=x0 - -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Ea=func(tmpa,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print(" Linmin: Ea = " // Ea // " a = " // 0.0_dp, PRINT_NORMAL) - Eb= Ea + 1.0_dp !just to start us off - - a=0.0_dp - b=2.0_dp*epsilon - - - ! lets figure out if we can go downhill at all - - it = 2 - do while( (Eb.GT.Ea) .AND. (.NOT.(Eb.FEQ.Ea))) - - b=b*0.5_dp - tmpb(:)= x0(:)+b*xdir(:) - -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Eb=func(tmpb,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print(" Linmin: Eb = " // Eb // " b = " // b, PRINT_VERBOSE) - it = it+1 - - if(b.LT.1.0e-20) then - - write(line,*) " Linmin: Direction points the wrong way\n" ; call print(line, PRINT_NORMAL) - - epsilon=0.0_dp - linmin=0 - return - end if - end do - - ! does it work in fortran? - ! two: if(isnan(Eb)) then - - ! write(global_err%unit,*) "linmin: got a NaN!" - ! epsilon=0 - ! linmin=0 - ! return - ! end if two - - if(Eb.FEQ.Ea) then - - epsilon=b - linmin=1 - call print(" Linmin: Eb.feq.Ea, returning after one step", PRINT_VERBOSE) - return - end if - - ! we now have Ea > Eb */ - - fallback = b ! b is the best point so far, make that the fallback - - write(line,*) " Linmin: xdir is ok.."; call print(line,PRINT_VERBOSE) - - c = b + GOLD*b !first guess for c */ - tmpc = x0 + c*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Ec = func(tmpc,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print(" Linmin: Ec = " // Ec // " c = " // c, PRINT_VERBOSE) - it = it + 1 - ! ! does it work in fortran? - ! four: if(isnan(Ec)) then - - ! write(global_err%unit,*) "linmin: Ec is a NaN!" - ! epsilon=0 - ! linmin=0 - ! return - ! end if four - - - - - - !let's bracket the minimum - - do while(Eb.GT.Ec) - - write(line,*) a,Ea; call print(line,PRINT_VERBOSE) - write(line,*) b,Eb; call print(line,PRINT_VERBOSE) - write(line,*) c,Ec; call print(line,PRINT_VERBOSE) - - - - - ! compute u by quadratic fit to a, b, c - - - !inverted ????????????????????? - r = (b-a)*(Eb-Ec) - q = (b-c)*(Eb-Ea) - u = b-((b-c)*q-(b-a)*r)/(2.0_dp*max(abs(q-r), 1.0e-20_dp)*sign(q-r)) - - ulim = b+MAXFIT*(c-b) - - write(line,*) "u= ",u ; call print(line,PRINT_VERBOSE) - - - if((u-b)*(c-u).GT. 0) then ! b < u < c - - write(line,*)"b < u < c" ; call print(line,PRINT_VERBOSE) - - tmpu = x0 + u*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Eu = func(tmpu,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print("linmin got one Eu " // Eu // " " // u, PRINT_NERD) - it = it + 1 - - if(Eu .LT. Ec) then ! Eb > Eu < Ec - a = b - b = u - Ea = Eb - Eb = Eu - exit !break? - else if(Eu .GT. Eb) then ! Ea > Eb < Eu - c = u - Ec = Eu - exit - end if - - !no minimum found yet - - u = c + GOLD*(c-b) - tmpu = x0 + u*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Eu = func(tmpu,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print("linmin got second Eu " // Eu // " " // u, PRINT_NERD) - it = it + 1 - - else if((u-c)*(ulim-u) .GT. 0) then ! c < u < ulim - - write(line,*) " c < u < ulim= ", ulim; call print(line,PRINT_VERBOSE) - tmpu = x0 + u*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Eu = func(tmpu,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print("linmin got one(2) Eu " // Eu // " " // u, PRINT_NERD) - it = it + 1 - - if(Eu .LT. Ec) then - b = c - c = u - u = c + GOLD*(c-b) - Eb = Ec - Ec = Eu - tmpu = x0 + u*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Eu = func(tmpu,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print("linmin got second(2) Eu " // Eu // " " // u, PRINT_NERD) - it = it + 1 - end if - - else ! c < ulim < u or u is garbage (we are in a linear regime) - write(line,*) " ulim=",ulim," < u or u garbage"; call print(line,PRINT_VERBOSE) - u = ulim - tmpu = x0 + u*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Eu = func(tmpu,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - it = it + 1 - call print("linmin got one(3) Eu " // Eu // " " // u, PRINT_NERD) - end if - - write(line,*) " "; call print(line,PRINT_VERBOSE) - write(line,*) " "; call print(line,PRINT_VERBOSE) - - ! test to see if we change any component too much - - - - do i = 1,N - - if(abs(c*xdir(i)) .GT. DXLIM)then - tmpb = x0+b*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Eb = func(tmpb,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print("linmin got new Eb " // Eb // " " // b, PRINT_NERD) - it = it + 1 - y = tmpb - write(line,*) " bracket: step too big", b, Eb - call print(line, PRINT_VERBOSE) - write(line,'("I= ",I4," C= ",F16.12," xdir(i)= ",F16.12," DXLIM =",F16.12)')& - i, c, xdir(i), DXLIM - call print(line, PRINT_VERBOSE) - - epsilon = b - - linmin= it - return - end if - end do - - - a = b - b = c - c = u - Ea = Eb - Eb = Ec - Ec = Eu - - end do - - epsilon = b - fallback = b - - bracket_it = it - call print(" Linmin: bracket OK in "//bracket_it//" steps", PRINT_VERBOSE) - - - - ! ahhh.... now we have a minimum between a and c, Ea > Eb < Ec - - write(line,*) " "; call print(line,PRINT_VERBOSE) - write(line,*) a,Ea; call print(line,PRINT_VERBOSE) - write(line,*) b,Eb; call print(line,PRINT_VERBOSE) - write(line,*) c,Ec; call print(line,PRINT_VERBOSE) - write(line,*) " "; call print(line,PRINT_VERBOSE) - - - - !******************************************************************** - ! * primitive linmin - ! * do a quadratic fit to a, b, c - ! * - ! - ! r = (b-a)*(Eb-Ec); - ! q = (b-c)*(Eb-Ea); - ! u = b-((b-c)*q-(b-a)*r)/(2*Mmax(fabs(q-r), 1e-20)*sign(q-r)); - ! y = x0 + u*xdir; - ! Eu = (*func)(y); - ! - ! if(Eb < Eu){ // quadratic fit was bad - ! if(current_verbosity() > MUMBLE) logger(" Quadratic fit was bad, returning 'b'\n"); - ! u = b; - ! y = x0 + u*xdir; - ! Eu = (*func)(y); - ! } - ! - ! if(current_verbosity() > PRINT_SILENT) - ! logger(" simple quadratic fit: %25.16e%25.16e\n\n", u, Eu); - ! - ! //return(u); - ! * - ! * end primitive linmin - !**********************************************************************/ - - ! now we need a tol1) then - u = x+d - else - u = x + tol1*sign(d) - end if - - ! evaluate function - tmpa = u*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - Eu = func(x0+tmpa,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print(' Linmin: new point u= '//u//' Eu= '//Eu, PRINT_VERBOSE) - if(any(abs(tmpa) > DXLIM)) then - if(sizeflag .EQ. 0) then - call print(' Linmin: an element of x moved more than '//DXLIM) - end if - sizeflag = 1 - endif - - ! analyse new point result - if(Eu .LE. Ex) then - call print(' Linmin: new point best so far', PRINT_VERBOSE+1) - if(u .GE. x) then - a = x - else - b = x - end if - - v=w;w=x;x=u - Ev=Ew;Ew=Ex;Ex=Eu - else - call print(' Linmin: new point is no better', PRINT_VERBOSE+1) - if(u < x) then - a = u - else - b = u - endif - - if(Eu .LE. Ew .OR. w .EQ. x) then - v=w;w=u - Ev = Ew; Ew = Eu - else if(Eu .LE. Ev .OR. v .EQ. x .OR. v .EQ. w) then - v = u - Ev = Eu - end if - end if - call print(' Linmin: a='//a//' b='//b//' x='//x, PRINT_VERBOSE+1) - - end do - - write(line,*) " Linmin: too many iterations"; call print(line, PRINT_NORMAL) - - - - y = x0 + x*xdir - epsilon = x - linmin = it - - deallocate(tmpa, tmpb, tmpc, tmpu) - return - end function linmin - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Simple (fast, dumb) line minimiser. The 'func' interface is - !% the same as for 'linmin' above. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - function linmin_fast(x0,fx0,xdir,y,epsilon,func,data) result(linmin) - real(dp)::x0(:) !% Starting vector - real(dp)::fx0 !% Value of 'func' at 'x0' - real(dp)::xdir(:) !% Direction - real(dp)::y(:) !% Result - real(dp)::epsilon !% Initial step - INTERFACE - function func(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - end function func - END INTERFACE - character(len=1),optional::data(:) - integer::linmin - - ! Dynamically allocate to avoid stack overflow madness with ifort - real(dp),allocatable::xb(:),xc(:) - real(dp)::r,q,new_eps,a,b,c,fxb,fxc,ftol - integer::n - logical::reject_quadratic_extrap - - !%RV Number of linmin steps taken, or zero if an error occured - - N=size(x0) - new_eps=-1.0_dp - a=0.0_dp - ftol=1.e-13 - allocate(xb(N)) - allocate(xc(N)) - - call print("Welcome to linmin_fast", PRINT_NORMAL) - - reject_quadratic_extrap = .true. - do while(reject_quadratic_extrap) - - b = a+epsilon - c = b+GOLD*epsilon - xb = x0+b*xdir - xc = x0+c*xdir - -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - fxb = func(xb,data) - fxc = func(xc,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - - write(line,*) " abc = ", a, b, c; call print(line, PRINT_NORMAL) - write(line,*) " f = ",fx0, fxb, fxc; call print(line, PRINT_NORMAL) - - if(abs(fx0-fxb) < abs(ftol*fx0))then - write(line,*) "*** fast_linmin is stuck, returning 0" - call print(line,PRINT_SILENT) - - linmin=0 - return - end if - - !WARNING: find a way to do the following - - ! probably we will need to wrap isnan - - !if(isnan(fxb) .OR. isnan(fxc))then - ! write(global_err%unit,*)" Got a NaN!!!" - ! linmin=0 - ! return - !end if - ! if(.NOT.finite(fxb) .OR. .NOT.finite(fxc))then - ! write(global_err%unit,*)" Got a INF!!!" - ! linmin=0 - ! return - ! end if - - r = (b-a)*(fxb-fxc) - q = (b-c)*(fxb-fx0) - new_eps = b-((b-c)*q-(b-a)*r)/(2.0*max(abs(q-r), 1.0_dp-20)*sign(1.0_dp,q-r)) - - write(line,*) " neweps = ", new_eps; call print(line, PRINT_NORMAL) - - if (abs(fxb) .GT. 100.0_dp*abs(fx0) .OR. abs(fxc) .GT. 100.0_dp*abs(fx0)) then ! extrapolation gave stupid results - epsilon = epsilon/10.0_dp - reject_quadratic_extrap = .true. - else if(new_eps > 10.0_dp*(b-a))then - write(line,*) "*** new epsilon > 10.0 * old epsilon, capping at factor of 10.0 increase" - call print(line, PRINT_NORMAL) - epsilon = 10.0_dp*(b-a) - a = c - fx0 = fxc - reject_quadratic_extrap = .true. - else if(new_eps < 0.0_dp) then - ! new proposed minimum is behind us! - if(fxb < fx0 .and. fxc < fx0 .and. fxc < fxb) then - ! increase epsilon - epsilon = epsilon*2.0_dp - call print("*** quadratic extrapolation resulted in backward step, increasing epsilon: "//epsilon, PRINT_NORMAL) - else - epsilon = epsilon/10.0_dp - write(line,*)"*** xdir wrong way, reducing epsilon ",epsilon - call print(line, PRINT_NORMAL) - endif - reject_quadratic_extrap = .true. - else if(new_eps < epsilon/10.0_dp) then - write(line,*) "*** new epsilon < old epsilon / 10, reducing epsilon by a factor of 2" - epsilon = epsilon/2.0_dp - reject_quadratic_extrap = .true. - else - reject_quadratic_extrap = .false. - end if - end do - y = x0+new_eps*xdir - - epsilon = new_eps - linmin=1 - - deallocate(xb, xc) - - return - end function linmin_fast - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Line minimizer that uses the derivative and extrapolates - !% its projection onto the search direction to zero. Again, - !% the 'func' interface is the same as for 'linmin'. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - function linmin_deriv(x0, xdir, dx0, y, epsilon, dfunc, data) result(linmin) - real(dp)::x0(:) !% Starting vector - real(dp)::xdir(:)!% Search direction - real(dp)::dx0(:) !% Initial gradient - real(dp)::y(:) !% Result - real(dp)::epsilon!% Initial step - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - character(len=1),optional::data(:) - integer::linmin - - ! local vars - integer::N - real(dp), allocatable::x1(:), dx1(:) - real(dp)::dirdx0, dirdx1, gamma, new_eps - - !%RV Number of linmin steps taken, or zero if an error occured - - N=size(x0) - dirdx1 = 9.9e30_dp - new_eps = epsilon - allocate(x1(N), dx1(N)) - - linmin = 0 - dirdx0 = xdir .DOT. dx0 - if( dirdx0 > 0.0_dp) then ! should be negative - call print("WARNING: linmin_deriv: xdir*dx0 > 0 !!!!!", PRINT_ALWAYS) - return - endif - - do while(abs(dirdx1) > abs(dirdx0)) - x1 = x0+new_eps*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dx1 = dfunc(x1,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx1 = xdir .DOT. dx1 - - if(abs(dirdx1) > abs(dirdx0)) then ! this eps leads to a point with larger abs gradient - call print("WARNING: linmin_deriv: |dirdx1| > |dirdx0|, reducing epsilon by factor of 5", PRINT_NORMAL) - new_eps = new_eps/5.0_dp - if(new_eps < 1.0e-12_dp) then - call print("WARNING: linmin_deriv: new_eps < 1e-12 !!!!!", PRINT_NORMAL) - linmin = 0 - return - endif - else - gamma = dirdx0/(dirdx0-dirdx1) - if(gamma > 2.0_dp) then - call print("*** gamma > 2.0, capping at 2.0", PRINT_NORMAL) - gamma = 2.0_dp - endif - new_eps = gamma*epsilon - endif - linmin = linmin+1 - end do - - write (line,'(a,e10.2,a,e10.2)') ' gamma = ', gamma, ' new_eps = ', new_eps - call Print(line, PRINT_NORMAL) - - y = x0+new_eps*xdir - epsilon = new_eps - - deallocate(x1, dx1) - return - end function linmin_deriv - - - !% Iterative version of 'linmin_deriv' that avoid taking large steps - !% by iterating the extrapolation to zero gradient. - function linmin_deriv_iter(x0, xdir, dx0, y, epsilon, dfunc,data,do_line_scan) result(linmin) - real(dp)::x0(:) !% Starting vector - real(dp)::xdir(:)!% Search direction - real(dp)::dx0(:) !% Initial gradient - real(dp)::y(:) !% Result - real(dp)::epsilon!% Initial step - logical, optional :: do_line_scan - - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - character(len=1),optional :: data(:) - integer::linmin - - ! local vars - integer::N, extrap_steps,i - real(dp), allocatable::xn(:), dxn(:) - real(dp)::dirdx1, dirdx2, dirdx_new, eps1, eps2, new_eps, eps11, step, old_eps - integer, parameter :: max_extrap_steps = 50 - logical :: extrap - - !%RV Number of linmin steps taken, or zero if an error occured - - N=size(x0) - allocate(xn(N), dxn(N)) - - if (present(do_line_scan)) then - if (do_line_scan) then - call print('line scan:', PRINT_NORMAL) - new_eps = 1.0e-5_dp - do i=1,50 - xn = x0 + new_eps*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dxn = dfunc(xn,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx_new = xdir .DOT. dxn - - call print(new_eps//' '//dirdx_new//' <-- LS', PRINT_NORMAL) - - new_eps = new_eps*1.15 - enddo - end if - end if - - eps1 = 0.0_dp - eps2 = epsilon - new_eps = epsilon - - linmin = 0 - dirdx1 = xdir .DOT. dx0 - dirdx2 = dirdx1 - if( dirdx1 > 0.0_dp) then ! should be negative - call print("WARNING: linmin_deriv_iter: xdir*dx0 > 0 !!!!!", PRINT_ALWAYS) - return - endif - - extrap_steps = 0 - - do while ( (abs(eps1-eps2) > TOL*abs(eps1)) .and. extrap_steps < max_extrap_steps) - do - xn = x0 + new_eps*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dxn = dfunc(xn,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx_new = xdir .DOT. dxn - - linmin = linmin + 1 - - call print('eps1 = '//eps1//' eps2 = '//eps2//' new_eps = '//new_eps, PRINT_NORMAL) - call print('dirdx1 = '//dirdx1//' dirdx2 = '//dirdx2//' dirdx_new = '//dirdx_new, PRINT_NORMAL) - - extrap = .false. - if (dirdx_new > 0.0_dp) then - if(abs(dirdx_new) < 2.0_dp*abs(dirdx1)) then - ! projected gradient at new point +ve, but not too large. - call print("dirdx_new > 0, but not too large", PRINT_NORMAL) - eps2 = new_eps - dirdx2 = dirdx_new - extrap_steps = 0 - ! we're straddling the minimum well, so gamma < 2 and we can interpolate to the next step - - ! let's try to bring in eps1 - step = 0.5_dp*(new_eps-eps1) - dirdx1 = 1.0_dp - do while (dirdx1 > 0.0_dp) - eps11 = eps1+step - call print("Trying to bring in eps1: "//eps11, PRINT_NORMAL) - xn = x0 + eps11*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dxn = dfunc(xn,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx1 = xdir .DOT. dxn - step = step/2.0_dp - end do - eps1 = eps11 - - exit - else - ! projected gradient at new point +ve and large - ! let's decrease the step we take - call print("*** reducing trial epsilon by factor of 2, making eps2=current new_eps", PRINT_NORMAL) - eps2 = new_eps - dirdx2 = dirdx_new - new_eps = (eps1+new_eps)/2.0_dp - ! check if we are just fiddling around - if(new_eps < 1.0e-12_dp) then - call print("WARNING: linmin_deriv_iter: total_eps < 1e-12 !!!!!", PRINT_NORMAL) - linmin = 0 - return - endif - end if - else ! projected gradient is -ve - if(abs(dirdx_new) <= abs(dirdx1)) then - ! projected gradient smaller than at x1 - if(dirdx2 > 0.0_dp) then - ! we have good bracketing, so interpolate - call print("dirdx_new <= 0, and we have good bracketing", PRINT_NORMAL) - eps1 = new_eps - dirdx1 = dirdx_new - extrap_steps = 0 - - ! let's try to bring in eps2 - step = 0.5_dp*(eps2-new_eps) - dirdx2 = -1.0_dp - do while(dirdx2 < 0.0_dp) - eps11 = eps2-step - call print("Trying to bring in eps2: "//eps11, PRINT_NORMAL) - xn = x0 + eps11*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dxn = dfunc(xn,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx2 = xdir .DOT. dxn - step = step/2.0_dp - end do - eps2 = eps11 - - exit - else - ! we have not bracketed yet, but can take this point and extrapolate to a bigger stepsize - old_eps = new_eps - if(abs(dirdx_new-dirdx1) .fne. 0.0_dp) new_eps = eps1-dirdx1/(dirdx_new-dirdx1)*(new_eps-eps1) - call print("we have not bracketed yet, extrapolating: "//new_eps, PRINT_NORMAL) - extrap_steps = extrap_steps + 1 - if(new_eps > 5.0_dp*old_eps) then - ! extrapolation is too large, let's just move closer - call print("capping extrapolation at "//2.0_dp*old_eps, PRINT_NORMAL) - eps1 = old_eps - new_eps = 2.0_dp*old_eps - else - ! accept the extrapolation - eps1 = old_eps - dirdx1 = dirdx_new - end if - endif - else - if (dirdx2 < 0.0_dp) then - ! have not bracketed yet, and projected gradient too big - minimum is behind us! lets move forward - call print("dirdx2 < 0.0_dp and projected gradient too big, closest stationary point is behind us!", PRINT_NORMAL) - eps1 = new_eps - dirdx1 = dirdx_new - new_eps = eps1*2.0_dp - eps2 = new_eps - extrap_steps = extrap_steps+1 - else - call print("abs(dirdx_new) > abs(dirdx1) but dirdx2 > 0, should only happen when new_eps is converged. try to bring in eps2", PRINT_NORMAL) - eps2 = 0.5_dp*(new_eps+eps2) - xn = x0 + eps2*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dxn = dfunc(xn,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx2 = xdir .DOT. dxn - exit - endif - endif - end if - end do - new_eps = eps1 - dirdx1/(dirdx2-dirdx1)*(eps2-eps1) - - - end do - - if (extrap_steps == max_extrap_steps) then - call Print('*** linmin_deriv: max consequtive extrapolation steps exceeded', PRINT_ALWAYS) - linmin = 0 - return - end if - - call print('linmin_deriv_iter done in '//linmin//' steps') - - epsilon = new_eps - y = x0 + epsilon*xdir - - deallocate(xn, dxn) - return - end function linmin_deriv_iter - - - !% Simplified Iterative version of 'linmin_deriv' that avoid taking large steps - !% by iterating the extrapolation to zero gradient. It does not try to reduce - !% the bracketing interval on both sides at every step - function linmin_deriv_iter_simple(x0, xdir, dx0, y, epsilon, dfunc,data,do_line_scan) result(linmin) - real(dp)::x0(:) !% Starting vector - real(dp)::xdir(:)!% Search direction - real(dp)::dx0(:) !% Initial gradient - real(dp)::y(:) !% Result - real(dp)::epsilon!% Initial step - logical, optional :: do_line_scan - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - character(len=1),optional :: data(:) - integer::linmin - - ! local vars - integer::N, extrap_steps, i - real(dp), allocatable::xn(:), dxn(:) - real(dp)::dirdx1, dirdx2, dirdx_new, eps1, eps2, new_eps, old_eps - integer, parameter :: max_extrap_steps = 50 - logical :: extrap - - !%RV Number of linmin steps taken, or zero if an error occured - - - - N=size(x0) - allocate(xn(N), dxn(N)) - - if (present(do_line_scan)) then - if (do_line_scan) then - call print('line scan:', PRINT_NORMAL) - new_eps = 1.0e-5_dp - do i=1,50 - xn = x0 + new_eps*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dxn = dfunc(xn,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx_new = xdir .DOT. dxn - - call print(new_eps//' '//dirdx_new, PRINT_NORMAL) - - new_eps = new_eps*1.15 - enddo - end if - end if - - - eps1 = 0.0_dp - eps2 = epsilon - old_eps = 0.0_dp - new_eps = epsilon - - linmin = 0 - dirdx1 = xdir .DOT. dx0 - dirdx2 = 0.0_dp - if( dirdx1 > 0.0_dp) then ! should be negative - call print("WARNING: linmin_deriv_iter_simple: xdir*dx0 > 0 !!!!!", PRINT_ALWAYS) - return - endif - - - - extrap_steps = 0 - - do while ( (abs(old_eps-new_eps) > TOL*abs(new_eps)) .and. extrap_steps < max_extrap_steps) - xn = x0 + new_eps*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dxn = dfunc(xn,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx_new = xdir .DOT. dxn - - - linmin = linmin + 1 - - call print('eps1 = '//eps1//' eps2 = '//eps2//' new_eps = '//new_eps, PRINT_NORMAL) - call print('dirdx1 = '//dirdx1//' dirdx2 = '//dirdx2//' dirdx_new = '//dirdx_new, PRINT_NORMAL) - extrap = .false. - if (dirdx_new > 0.0_dp) then - if(abs(dirdx_new) < 10.0_dp*abs(dirdx1)) then - ! projected gradient at new point +ve, but not too large. - call print("dirdx_new > 0, but not too large", PRINT_NORMAL) - eps2 = new_eps - dirdx2 = dirdx_new - extrap_steps = 0 - ! we're straddling the minimum well, so gamma < 2 and we can interpolate to the next step - else - ! projected gradient at new point +ve and large - ! let's decrease the step we take - call print("*** reducing trial epsilon by factor of 2, making eps2=current new_eps", PRINT_NORMAL) - eps2 = new_eps - dirdx2 = dirdx_new - old_eps = new_eps - new_eps = (eps1+new_eps)/2.0_dp - ! check if we are just fiddling around - if(new_eps < 1.0e-12_dp) then - call print("WARNING: linmin_deriv_iter_simple: new_eps < 1e-12 !!!!!", PRINT_NORMAL) - linmin = 0 - return - endif - cycle - end if - else ! projected gradient is -ve - if(abs(dirdx_new) <= abs(dirdx1)) then - ! projected gradient smaller than at x1 - if(dirdx2 > 0.0_dp) then - ! we have good bracketing, so interpolate - call print("dirdx_new <= 0, and we have good bracketing", PRINT_NORMAL) - eps1 = new_eps - dirdx1 = dirdx_new - extrap_steps = 0 - else - ! we have not bracketed yet, but can take this point and extrapolate to a bigger stepsize - old_eps = new_eps - if(abs(dirdx_new-dirdx1) .fne. 0.0_dp) new_eps = eps1-dirdx1/(dirdx_new-dirdx1)*(new_eps-eps1) - call print("we have not bracketed yet, extrapolating: "//new_eps, PRINT_NORMAL) - if(new_eps > 5.0_dp*old_eps) then - ! extrapolation is too large, let's just move closer - call print("capping extrapolation at "//2.0_dp*old_eps, PRINT_NORMAL) - eps1 = old_eps - new_eps = 2.0_dp*old_eps - else - ! accept the extrapolation - eps1 = old_eps - dirdx1 = dirdx_new - end if - extrap_steps = extrap_steps + 1 - cycle - endif - else - if (dirdx2 .eq. 0.0_dp) then - ! have not bracketed yet, and projected gradient too big - minimum is behind us! lets move forward - call print("dirdx2 < 0.0_dp and projected gradient too big, closest stationary point is behind us!", PRINT_NORMAL) - eps1 = new_eps - dirdx1 = dirdx_new - old_eps = new_eps - new_eps = eps1*2.0_dp - eps2 = new_eps - extrap_steps = extrap_steps+1 - cycle - else - call print("dirdx_new < 0, abs(dirdx_new) > abs(dirdx1) but dirdx2 > 0, function not monotonic?", PRINT_NORMAL) - eps1 = new_eps - dirdx1 = dirdx_new - endif - endif - end if - old_eps = new_eps - new_eps = eps1 - dirdx1/(dirdx2-dirdx1)*(eps2-eps1) - - end do - - if (extrap_steps == max_extrap_steps) then - call Print('*** linmin_deriv_iter_simple: max consequtive extrapolation steps exceeded', PRINT_ALWAYS) - linmin = 0 - return - end if - - epsilon = new_eps - y = x0 + epsilon*xdir - - deallocate(xn, dxn) - return - end function linmin_deriv_iter_simple - - - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Damped molecular dynamics minimiser. The objective - !% function is 'func(x)' and its gradient is 'dfunc(x)'. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - - function damped_md_minim(x,mass,func,dfunc,damp,tol,max_change,max_steps,data) - - real(dp)::x(:) !% Starting vector - real(dp)::mass(:) !% Effective masses of each degree of freedom - INTERFACE - function func(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - end function func - end INTERFACE - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - real(dp)::damp !% Velocity damping factor - real(dp)::tol !% Minimisation is taken to be converged when 'normsq(force) < tol' - real(dp)::max_change !% Maximum position change per time step - integer:: max_steps !% Maximum number of MD steps - character(len=1),optional::data(:) - - integer :: N,i - integer :: damped_md_minim - real(dp),allocatable::velo(:),acc(:),force(:) - real(dp)::dt,df2, f - - !%RV Returns number of MD steps taken. - - - N=size(x) - allocate(velo(N),acc(N),force(N)) - - call print("Welcome to damped md minim()") - write(line,*)"damping = ", damp ; call print(line) - - velo=0.0_dp -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - acc = -dfunc(x,data)/mass -#ifndef _OPENMP - call verbosity_pop() -#endif - - - dt = sqrt(max_change/maxval(abs(acc))) - write(line,*)"dt = ", dt ; call print(line) - - do I=0,max_steps - velo(:)=velo(:) + (0.5*dt)*acc(:) -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - force(:)= -dfunc(X,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - df2=normsq(force) - if(df2 .LT. tol) then - write(line,*) I," force^2 =",df2 ; call print(line) - write(line,*)"Converged in ",i," steps!!" ; call print(line) - exit - else if (mod(i,100) .EQ. 0) then - write(line,*)i," f = ", func(x,data), "df^2 = ", df2, "max(abs(df)) = ",maxval(abs(force)); call print(line) - end if - acc(:)=force(:)/mass(:) - velo(:)=velo(:) + (0.5*dt)*acc(:) - - velo(:)=velo(:) * (1.0-damp)/(1.0+damp) - x(:)=x(:)+dt*velo(:) - x(:)=x(:)+0.5*dt*dt*acc(:) - -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - f = func(x,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call print("f=" // f, PRINT_VERBOSE) - call print(x, PRINT_NERD) - - end do - ! - if(i .EQ. max_steps) then - write(line,*) "Failed to converge in ",i," steps" ; call print(line) - end if - damped_md_minim = i - return - end function damped_md_minim - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - !% Gradient descent minimizer, using either the conjugate gradients or - !% steepest descent methods. The objective function is - !% 'func(x)' and its gradient is 'dfunc(x)'. - !% There is an additional 'hook' interface which is called at the - !% beginning of each gradient descent step. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - - function minim(x_in,func,dfunc,method,convergence_tol,max_steps, linminroutine, hook, hook_print_interval, & - eps_guess, always_do_test_gradient, data, status) - real(dp), intent(inout) :: x_in(:) !% Starting position - INTERFACE - function func(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - end function func - end INTERFACE - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - character(*), intent(in) :: method !% 'cg' for conjugate gradients or 'sd' for steepest descent - real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ - !% 'convergence_tol'. - integer, intent(in) :: max_steps !% Maximum number of 'cg' or 'sd' steps - integer::minim - character(*), intent(in), optional :: linminroutine !% Name of the line minisation routine to use. - !% This should be one of 'NR_LINMIN', 'FAST_LINMIN' and - !% 'LINMIN_DERIV'. - !% If 'FAST_LINMIN' is used and problems with the line - !% minisation are detected, 'minim' automatically switches - !% to the more reliable 'NR_LINMIN', and then switches back - !% once no more problems have occurred for some time. - !% the default is NR_LINMIN - optional :: hook - INTERFACE - subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - end subroutine hook - end INTERFACE - integer, intent(in), optional :: hook_print_interval - real(dp), intent(in), optional :: eps_guess - logical, intent(in), optional :: always_do_test_gradient - character(len=1), optional, intent(inout) :: data(:) - integer, optional, intent(out) :: status - - !%RV Returns number of gradient descent steps taken during minimisation - - integer, parameter:: max_bad_cg = 5 - integer, parameter:: max_bad_iter = 5 - integer, parameter:: convergence_window = 3 - integer:: convergence_counter - integer:: main_counter - integer:: bad_cg_counter - integer:: bad_iter_counter - integer:: resetflag - integer:: exit_flag - integer:: lsteps - integer:: i, extra_report - real(dp), parameter:: stuck_tol = NUMERICAL_ZERO - real(dp):: linmin_quality - real(dp):: eps, alpha - real(dp):: oldeps - real(dp), parameter :: default_eps_guess = 0.1_dp ! HACK - real(dp) :: my_eps_guess - real(dp):: f, f_new - real(dp):: gg, dgg, hdirgrad_before, hdirgrad_after - real(dp):: dcosine, gdirlen, gdirlen_old, normsqgrad_f, normsqgrad_f_old - real(dp):: obj, obj_new - logical:: do_sd, do_sd2, do_cg, do_pcg, do_lbfgs - integer:: fast_linmin_switchback - logical:: do_fast_linmin - logical:: do_linmin_deriv - logical:: dumbool, done - logical:: do_test_gradient - integer :: my_hook_print_interval - - ! working arrays - ! Dynamically allocate to avoid stack overflow madness with ifort - real(dp),dimension(:), allocatable :: x, y, hdir, gdir, gdir_old, grad_f, grad_f_old, x_old - ! for lbfgs - real(dp), allocatable :: lbfgs_work(:), lbfgs_diag(:) - integer :: lbfgs_flag - integer, parameter :: lbfgs_M = 40 - - if (current_verbosity() >= PRINT_VERBOSE) then - my_hook_print_interval = optional_default(1, hook_print_interval) - else if (current_verbosity() >= PRINT_NORMAL) then - my_hook_print_interval = optional_default(10, hook_print_interval) - else - my_hook_print_interval = optional_default(100000, hook_print_interval) - endif - - call system_timer("minim") - - call system_timer("minim/init") - allocate(x(size(x_in))) - x = x_in - - allocate(y(size(x)), hdir(size(x)), gdir(size(x)), gdir_old(size(x)), & - grad_f(size(x)), grad_f_old(size(x))) - - extra_report = 0 - if (present(status)) status = 0 - - call print("Welcome to minim()", PRINT_NORMAL) - call print("space is "//size(x)//" dimensional", PRINT_NORMAL) - do_sd = .false. - do_sd2 = .false. - do_cg = .false. - do_pcg = .false. - do_lbfgs = .false. - - if(trim(method).EQ."sd") then - do_sd = .TRUE. - call print("Method: Steepest Descent", PRINT_NORMAL) - else if(trim(method).EQ."sd2")then - do_sd2 = .TRUE. - call print("Method: Two-Point Step Size Gradient Methods, J Barzilai and JM Borwein, IMA J Num Anal (1988) 8, 141-148", PRINT_NORMAL) - allocate(x_old(size(x))) - y=x - x_old = x - else if(trim(method).EQ."cg")then - do_cg = .TRUE. - call print("Method: Conjugate Gradients", PRINT_NORMAL) - else if(trim(method).EQ."pcg")then - do_cg = .TRUE. - do_pcg = .TRUE. - call print("Method: Preconditioned Conjugate Gradients", PRINT_NORMAL) - else if(trim(method).EQ."lbfgs") then - do_lbfgs = .TRUE. - call print("Method: LBFGS by Jorge Nocedal, please cite D. Liu and J. Nocedal, Mathematical Programming B 45 (1989) 503-528", PRINT_NORMAL) - allocate(lbfgs_diag(size(x))) - allocate(lbfgs_work(size(x)*(lbfgs_M*2+1)+2*lbfgs_M)) - call print("Allocating LBFGS work array: "//(size(x)*(lbfgs_M*2+1)+2*lbfgs_M)//" bytes") - lbfgs_flag = 0 - ! set units - MP = mainlog%unit - LP = errorlog%unit - ! - y=x ! this is reqired for lbfgs on first entry into the main loop, as no linmin is done - else - call System_abort("Invalid method in optimize: '"//trim(method)//"'") - end if - - - do_fast_linmin = .FALSE. - do_linmin_deriv = .FALSE. - if(present(linminroutine)) then - if(do_lbfgs) & - call print("Minim warning: a linminroutine was specified for use with LBFGS") - if(do_sd2) & - call print("Minim warning: a linminroutine was specified for use with two-point steepest descent SD2") - if(trim(linminroutine) .EQ. "FAST_LINMIN") then - do_fast_linmin =.TRUE. - call print("Using FAST_LINMIN linmin", PRINT_NORMAL) - else if(trim(linminroutine).EQ."NR_LINMIN") then - call print("Using NR_LINMIN linmin", PRINT_NORMAL) - else if(trim(linminroutine).EQ."LINMIN_DERIV") then - do_linmin_deriv = .TRUE. - call print("Using LINMIN_DERIV linmin", PRINT_NORMAL) - else - call System_abort("Invalid linminroutine: "//linminroutine) - end if - end if - - if (current_verbosity() .GE. PRINT_NERD .and. .not. do_linmin_deriv) then - dumbool=test_gradient(x, func, dfunc,data=data) - end if - - ! initial function calls - if (.not. do_linmin_deriv) then -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - f = func(x,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - else - f = 0.0_dp - end if - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - grad_f = dfunc(x,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - - if (my_hook_print_interval > 0) then - if (present(hook)) then - call hook(x, grad_f, f, done, .true., data) - if (done) then - call print('hook reports that minim finished, exiting.', PRINT_NORMAL) - exit_flag = 1 - end if - else - call print("hook is not present", PRINT_VERBOSE) - end if - endif - - - grad_f_old = grad_f - gdir = (-1.0_dp)*grad_f - hdir = gdir - gdir_old = gdir - normsqgrad_f = normsq(grad_f) - normsqgrad_f_old = normsqgrad_f - gdirlen = sqrt(normsqgrad_f) - gdirlen_old = gdirlen - ! quality monitors - dcosine = 0.0_dp - linmin_quality = 0.0_dp - bad_cg_counter = 0 - bad_iter_counter = 0 - convergence_counter = 0 - resetflag = 0 - exit_flag = 0 - fast_linmin_switchback = -1 - lsteps = 0 - - - - do_test_gradient = optional_default(.false., always_do_test_gradient) - my_eps_guess = optional_default(default_eps_guess, eps_guess) - eps = my_eps_guess - - !******************************************************************** - !* - !* MAIN CG LOOP - !* - !********************************************************************** - - - if(normsqgrad_f .LT. convergence_tol)then - call print("Minimization is already converged!") - call print(trim(method)//" iter = "// 0 //" df^2 = " // normsqgrad_f // " f = " // f & - &// " "//lsteps//" linmin steps eps = "//eps,PRINT_VERBOSE) - exit_flag = 1 - end if - - call system_timer("minim/init") - call system_timer("minim/main_loop") - - main_counter=1 ! incremented at the end of the loop - do while((main_counter .LT. max_steps) .AND. (.NOT.(exit_flag.gt.0))) - call system_timer("minim/main_loop/"//main_counter) - - if ((current_verbosity() >= PRINT_ANALYSIS .or. do_test_gradient) & - .and. .not. do_linmin_deriv) then - dumbool=test_gradient(x, func, dfunc,data=data) - if (.not. dumbool) call print("Gradient test failed") - end if - - !********************************************************************** - !* - !* Print stuff - !* - !**********************************************************************/ - - -#ifndef _OPENMP - if (my_hook_print_interval == 1 .or. mod(main_counter,my_hook_print_interval) == 1) call verbosity_push_increment() -#endif - call print(trim(method)//" iter = "//main_counter//" df^2 = "//normsqgrad_f//" f = "//f// & - ' max(abs(df)) = '//maxval(abs(grad_f)),PRINT_VERBOSE) - if(.not. do_lbfgs) & - call print(" dcos = "//dcosine//" q = " //linmin_quality,PRINT_VERBOSE) -#ifndef _OPENMP - if (my_hook_print_interval == 1 .or. mod(main_counter,my_hook_print_interval) == 1) call verbosity_pop() -#endif - - ! call the hook function - if (present(hook)) then - call hook(x, grad_f, f, done, (mod(main_counter-1,my_hook_print_interval) == 0), data) - if (done) then - call print('hook reports that minim finished, exiting.', PRINT_NORMAL) - exit_flag = 1 - call system_timer("minim/main_loop/"//main_counter) - cycle - end if - else - call print("hook is not present", PRINT_VERBOSE) - end if - - !********************************************************************** - !* - !* test to see if we've converged, let's quit - !* - !**********************************************************************/ - ! - if(normsqgrad_f < convergence_tol) then - convergence_counter = convergence_counter + 1 - !call print("Convergence counter = "//convergence_counter) - else - convergence_counter = 0 - end if - if(convergence_counter == convergence_window) then - call print("Converged after step " // main_counter) - call print(trim(method)//" iter = " // main_counter // " df^2= " // normsqgrad_f // " f= " // f) - exit_flag = 1 ! while loop will quit - call system_timer("minim/main_loop/"//main_counter) - cycle !continue - end if - - if( (.not. do_lbfgs) .and. (.not. do_sd2) ) then - !********************************************************************** - !* - !* do line minimization - !* - !**********************************************************************/ - - oldeps = eps - ! no output from linmin unless level >= PRINT_VERBOSE - call system_timer("minim/main_loop/"//main_counter//"/linmin") -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - if(do_fast_linmin) then - lsteps = linmin_fast(x, f, hdir, y, eps, func,data) - if (lsteps .EQ.0) then - call print("Fast linmin failed, calling normal linmin at step " // main_counter) - lsteps = linmin(x, hdir, y, eps, func,data) - end if - else if(do_linmin_deriv) then - lsteps = linmin_deriv_iter_simple(x, hdir, grad_f, y, eps, dfunc,data) - else - lsteps = linmin(x, hdir, y, eps, func,data) - end if - if ((oldeps .fne. my_eps_guess) .and. (eps > oldeps*2.0_dp)) then - eps = oldeps*2.0_dp - endif -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("minim/main_loop/"//main_counter//"/linmin") - - !********************************************************************** - !* - !* check the result of linmin - !* - !********************************************************************** - - if(lsteps .EQ. 0) then ! something very bad happenned, gradient is bad? - call print("*** LINMIN returned 0, RESETTING CG CYCLE and eps at step " // main_counter) -#ifndef _OPENMP - call verbosity_push_increment() -#endif - extra_report = extra_report + 1 - hdir = -1.0 * grad_f - eps = my_eps_guess - - if (current_verbosity() >= PRINT_NERD) call line_scan(x, hdir, func, .not. do_linmin_deriv, dfunc, data) - - bad_iter_counter = bad_iter_counter + 1 - if(bad_iter_counter .EQ. max_bad_iter) then - - call print("*** BAD linmin counter reached maximum, exiting " // max_bad_iter) - - exit_flag = 1 - if (present(status)) status = 1 - end if - - call system_timer("minim/main_loop/"//main_counter) - cycle !continue - end if - - end if ! .not. lbfgs .and. .not. sd2 - - !********************************************************************** - !* - !* Evaluate function at new position - !* - !********************************************************************** - - - if (.not. do_linmin_deriv) then -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - f_new = func(y,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - else - f_new = 0.0_dp - end if - ! if(!finite(f_new)){ - ! logger(ERROR, "OUCH!!! f_new is not finite!\n"); - ! return -1; // go back screaming - ! end if - - !******************************************************************** - ! Is everything going normal? - !*********************************************************************/ - - ! let's make sure we are progressing - ! obj is the thing we are trying to minimize - ! are we going down,and enough? - - if(.not. do_lbfgs .and. .not. do_sd2) then - if (.not. do_linmin_deriv) then - obj = f - obj_new = f_new - else - ! let's pretend that linmin_deriv never goes uphill! - obj = 0.0_dp - obj_new = -1.0_dp - end if - - if(obj-obj_new > abs(stuck_tol*obj_new)) then - ! everything is fine, clear some monitoring flags - bad_iter_counter = 0 - do i=1, extra_report -#ifndef _OPENMP - call verbosity_pop() -#endif - end do - extra_report = 0 - - if(present(linminroutine)) then - if(trim(linminroutine) .EQ. "FAST_LINMIN" .and. .not. do_fast_linmin .and. & - main_counter > fast_linmin_switchback) then - call print("Switching back to FAST_LINMIN linmin") - do_fast_linmin = .TRUE. - end if - end if - !********************************************************************** - !* Otherwise, diagnose problems - !********************************************************************** - else if(obj_new > obj)then ! are we not going down ? then things are very bad - - if( abs(obj-obj_new) < abs(stuck_tol*obj_new))then ! are we stuck ? - call print("*** Minim is stuck, exiting") - exit_flag = 1 - if (present(status)) status = 0 - call system_timer("minim/main_loop/"//main_counter) - cycle !continue - end if - - - call print("*** Minim is not going down at step " // main_counter //" ==> eps /= 10") - eps = oldeps / 10.0_dp - - if (current_verbosity() >= PRINT_NERD) call line_scan(x, hdir, func, .not. do_linmin_deriv, dfunc, data) - if(current_verbosity() >= PRINT_NERD .and. .not. do_linmin_deriv) then - if(.NOT.test_gradient(x, func, dfunc,data=data)) then - call print("*** Gradient test failed!!") - end if - end if - - - if(do_fast_linmin) then - do_fast_linmin = .FALSE. - fast_linmin_switchback = main_counter+5 - call print("Switching off FAST_LINMIN (back after " //& - (fast_linmin_switchback - main_counter) // " steps if all OK") - end if - - call print("Resetting conjugacy") - resetflag = 1 - - main_counter=main_counter-1 - bad_iter_counter=bad_iter_counter+1 ! increment BAD counter - - else ! minim went downhill, but not a lot - - call print("*** Minim is stuck at step " // main_counter // ", trying to unstick", PRINT_VERBOSE) - -#ifndef _OPENMP - if (current_verbosity() >= PRINT_NORMAL) then - call verbosity_push_increment() - extra_report = extra_report + 1 - end if -#endif - - if (current_verbosity() >= PRINT_NERD) call line_scan(x, hdir, func, .not. do_linmin_deriv, dfunc, data) - !********************************************************************** - !* - !* do gradient test if we need to - !* - !**********************************************************************/ - ! - if(current_verbosity() >= PRINT_NERD .and. .not. do_linmin_deriv) then - if(.NOT.test_gradient(x, func, dfunc,data=data)) then - call print("*** Gradient test failed!! Exiting linmin!") - exit_flag = 1 - if (present(status)) status = 1 - call system_timer("minim/main_loop/"//main_counter) - cycle !continue - end if - end if - - bad_iter_counter=bad_iter_counter+1 ! increment BAD counter - eps = my_eps_guess ! try to unstick - call print("resetting eps to " // eps,PRINT_VERBOSE) - resetflag = 1 ! reset CG - end if - - if(bad_iter_counter == max_bad_iter)then - call print("*** BAD iteration counter reached maximum " // max_bad_iter // " exiting") - exit_flag = 1 - if (present(status)) status = 1 - call system_timer("minim/main_loop/"//main_counter) - cycle !continue - end if - end if ! .not. do_bfgs and .not. do_sd2 - - !********************************************************************** - !* - !* accept iteration, get new gradient - !* - !**********************************************************************/ - - f = f_new - x = y - -! Removed resetting -! if(mod(main_counter,50) .EQ. 0) then ! reset CG every now and then regardless -! resetflag = 1 -! end if - - ! measure linmin_quality - if(.not. do_lbfgs) hdirgrad_before = hdir.DOT.grad_f - - grad_f_old = grad_f -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - grad_f = dfunc(x,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - - if( (.not. do_lbfgs) .and. (.not. do_sd2) ) then - hdirgrad_after = hdir.DOT.grad_f - if (hdirgrad_after /= 0.0_dp) then - linmin_quality = hdirgrad_before/hdirgrad_after - else - linmin_quality = HUGE(1.0_dp) - endif - end if - - normsqgrad_f_old = normsqgrad_f - normsqgrad_f = normsq(grad_f) - - - !********************************************************************** - !* Choose minimization method - !**********************************************************************/ - - if(do_sd) then !steepest descent - hdir = -1.0_dp * grad_f - elseif(do_sd2) then - if(main_counter == 1) then - alpha = 1.0e-6_dp - else - alpha = dot_product(x-x_old,grad_f-grad_f_old) / dot_product(grad_f-grad_f_old,grad_f-grad_f_old) - endif - - x_old = x - x = x - alpha * grad_f - y = x - else if(do_cg)then ! conjugate gradients - - if( bad_cg_counter == max_bad_cg .OR.(resetflag > 0)) then ! reset the conj grad cycle - - if( bad_cg_counter .EQ. max_bad_cg) then - call print("*** bad_cg_counter == "// max_bad_cg, PRINT_VERBOSE) - end if - call print("*** Resetting conjugacy", PRINT_VERBOSE) - - - hdir = -1.0_dp * grad_f - bad_cg_counter = 0 - resetflag = 0 - else ! do CG - gdirlen = 0.0 - dcosine = 0.0 - - gg = normsq(gdir) - - if(.NOT.do_pcg) then ! no preconditioning - dgg = max(0.0_dp, (gdir + grad_f).DOT.grad_f) ! Polak-Ribiere formula - gdir = (-1.0_dp) * grad_f - ! the original version was this, I had to change because intrinsic does'nt return allocatables. - ! dgg = (grad_f + gdir).DOT.grad_f - ! gdir = (-1.0_dp) * grad_f - else ! precondition - call System_abort("linmin: preconditioning not implemented") - dgg = 0.0 ! STUPID COMPILER - ! //dgg = (precond^grad_f+gdir)*grad_f; - ! //gdir = -1.0_dp*(precond^grad_f); - end if - if(gg .ne. 0.0_dp) then - hdir = gdir+hdir*(dgg/gg) - else - hdir = gdir - endif - ! calculate direction cosine - dcosine = gdir.DOT.gdir_old - gdir_old = gdir - gdirlen = norm(gdir) - - if(gdirlen .eq. 0.0_dp .or. gdirlen_old .eq. 0.0_dp) then - dcosine = 0.0_dp - else - dcosine = dcosine/(gdirlen*gdirlen_old) - endif - gdirlen_old = gdirlen - - if(abs(dcosine) > 0.2) then - bad_cg_counter= bad_cg_counter +1 - else - bad_cg_counter = 0 - end if - - end if - else if(do_lbfgs)then ! LBFGS method - y = x - call LBFGS(size(x),lbfgs_M,y, f, grad_f, .false., lbfgs_diag, (/-1,0/), 1e-12_dp, 1e-12_dp, lbfgs_work, lbfgs_flag) -! do while(lbfgs_flag == 2) -! call LBFGS(size(x),lbfgs_M,y, f, grad_f, .false., lbfgs_diag, (/-1,0/), 1e-12_dp, 1e-12_dp, lbfgs_work, lbfgs_flag) -! end do - if(lbfgs_flag < 0) then ! internal LBFGS error - call print('LBFGS returned error code '//lbfgs_flag//', exiting') - exit_flag = 1 - if (present(status)) status = 1 - call system_timer("minim/main_loop/"//main_counter) - cycle - end if - else - call System_abort("minim(): c'est ci ne pas une erreur!") - end if - - call system_timer("minim/main_loop/"//main_counter) - main_counter=main_counter + 1 - end do - call system_timer("minim/main_loop") - - if(main_counter >= max_steps) then - call print("Iterations exceeded " // max_steps) - end if - - call print("Goodbye from minim()") - call print("") - minim = main_counter-1 - - x_in = x - - deallocate(x) - deallocate(y, hdir, gdir, gdir_old, grad_f, grad_f_old) - if(allocated(x_old)) deallocate(x_old) - - if(do_lbfgs) then - deallocate(lbfgs_diag) - deallocate(lbfgs_work) - end if - - ! just in case extra pushes weren't popped -#ifndef _OPENMP - do i=1, extra_report - call verbosity_pop() - end do -#endif - - call system_timer("minim") - - end function minim - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! test_gradient - ! - !% Test a function against its gradient by evaluating the gradient from the - !% function by finite differnces. We can only test the gradient if energy and force - !% functions are pure in that they do not change the input vector - !% (e.g. no capping of parameters). The interface for 'func(x)' and 'dfunc(x)' - !% are the same as for 'minim' above. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - function test_gradient(xx,func,dfunc, dir,data) - real(dp),intent(in)::xx(:) !% Position - INTERFACE - function func(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - end function func - end INTERFACE - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - real(dp), intent(in), optional, target :: dir(:) !% direction along which to test - character(len=1),optional::data(:) - !%RV Returns true if the gradient test passes, or false if it fails - logical :: test_gradient - - - integer:: N,I,loopend - logical::ok,printit,monitor_ratio - real(dp)::f0, f, tmp, eps, ratio, previous_ratio - ! Dynamically allocate to avoid stack overflow madness with ifort - real(dp),dimension(:), allocatable ::x,dx,x_0 - real(dp), allocatable :: my_dir(:) - - N=size(xx) - allocate(x(N), dx(N), x_0(N)) - x=xx - - if(current_verbosity() > PRINT_VERBOSE) then - printit = .TRUE. - loopend=0 - else - printit = .FALSE. - loopend=1 - end if - - if(printit) then - write(line,*)" "; call print(line) - write(line,*)" " ; call print(line) - write(line,*) "Gradient test"; call print(line) - write(line,*)" " ; call print(line) - end if - - if(printit) then - write(line, *) "Calling func(x)"; call print(line) - end if - !f0 = param_penalty(x_0); -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - f0 = func(x,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - !!//logger("f0: %24.16f\n", f0); - - if(printit) then - write(line, *) "Calling dfunc(x)"; call print(line) - end if -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - dx = dfunc(x,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - !!//dx = param_penalty_deriv(x); - - allocate(my_dir(N)) - if (present(dir)) then - if (norm(dir) .feq. 0.0_dp) & - call system_abort("test_gradient got dir = 0.0, can't use as normalized direction for test") - my_dir = dir/norm(dir) - else - if (norm(dx) == 0.0_dp) & - call system_abort("test_gradient got dfunc = 0.0, can't use as normalized direction for test") - my_dir = (-1.0_dp)*dx/norm(dx) - endif - !//my_dir.zero(); - !//my_dir.randomize(0.1); - !//my_dir.x[4] = 0.1; - !//logger("dx: ");dx.print(logger_stream); - - tmp = my_dir.DOT.dx - x_0(:) = x(:) - !//logger("x0: "); x_0.print(logger_stream); - - if(printit) then - call print("GT eps (f-f0)/(eps*df) f") - end if - - ok = .FALSE. - ratio = 0.0 - - do i=0,loopend ! do it twice, print second time if not OK - previous_ratio = 0.0 - monitor_ratio = .FALSE. - - eps=1.0e-1_dp - do while(eps>1.e-20) - - - x = x_0 + eps*my_dir - !//logger("x: "); x.print(logger_stream); - !//f = param_penalty(x); -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - f = func(x,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - !//logger("f: %24.16f\n", f); - previous_ratio = ratio - ratio = (f-f0)/(eps*tmp) - - if(printit) then - write(line,'("GT ",e8.2,f22.16,e24.16)') eps, ratio, f; - call print(line) - end if - - if(abs(ratio-1.0_dp) .LT. 1e-2_dp) monitor_ratio = .TRUE. - - if(.NOT.monitor_ratio) then - if(abs((f-f0)/f0) .LT. NUMERICAL_ZERO) then ! we ran out of precision, gradient is really bad - call print("(f-f0)/f0 " // ((f-f0)/f0) // " ZERO " // NUMERICAL_ZERO, PRINT_ANALYSIS) - call print("ran out of precision, quitting loop", PRINT_ANALYSIS) - exit - end if - end if - - if(monitor_ratio) then - if( abs(ratio-1.0_dp) > abs(previous_ratio-1.0_dp) )then ! sequence broke - if(abs((f-f0)/f0*(ratio-1.0_dp)) < 1e-10_dp) then ! lets require 10 digits of precision - ok = .TRUE. - !//break; - end if - end if - end if - - eps=eps/10.0 - end do - - if(.NOT.ok) then - printit = .TRUE. ! go back and print it - else - exit - end if - - end do - if(printit) then - write(line,*)" "; call print(line, PRINT_NORMAL) - end if - - if(ok) then - write(line,*)"Gradient test OK"; call print(line, PRINT_VERBOSE) - end if - test_gradient= ok - - deallocate(x, dx, x_0) - deallocate(my_dir) - - - end function test_gradient - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - ! n_test_gradient - ! - !% Test a function against its gradient by evaluating the gradient from the - !% function by symmetric finite differnces. We can only test the gradient if - !% energy and force functions are pure in that they do not change the input - !% vector (e.g. no capping of parameters). The interface for 'func(x)' and - !% 'dfunc(x)'are the same as for 'minim' above. - ! - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine n_test_gradient(xx,func,dfunc, dir,data) - real(dp),intent(in)::xx(:) !% Position - INTERFACE - function func(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - end function func - end INTERFACE - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - real(dp), intent(in), optional, target :: dir(:) !% direction along which to test - character(len=1),optional::data(:) - - integer N, i - real(dp) :: eps, tmp, fp, fm - real(dp), allocatable :: x(:), dx(:) - real(dp), pointer :: my_dir(:) - - N=size(xx) - allocate(x(N), dx(N)) - x=xx - - dx = dfunc(x,data) - - if (present(dir)) then - if (norm(dir) == 0.0_dp) & - call system_abort("n_test_gradient got dir = 0.0, can't use as normalized direction for test") - allocate(my_dir(N)) - my_dir = dir/norm(dir) - else - if (norm(dx) == 0.0_dp) & - call system_abort("n_test_gradient got dfunc = 0.0, can't use as normalized direction for test") - allocate(my_dir(N)) - my_dir = (-1.0_dp)*dx/norm(dx) - endif - - tmp = my_dir.DOT.dx - - do i=2, 10 - eps = 10.0_dp**(-i) - x = xx + eps*my_dir - fp = func(x,data) - x = xx - eps*my_dir - fm = func(x,data) - call print ("fp " // fp // " fm " // fm) - call print("GT_N eps " // eps // " D " // tmp // " FD " // ((fp-fm)/(2.0_dp*eps)) // " diff " // (tmp-(fp-fm)/(2.0_dp*eps))) - end do - - deallocate(x, dx) - deallocate(my_dir) - - end subroutine n_test_gradient - - - !% FIRE MD minimizer from Bitzek et al., \emph{Phys. Rev. Lett.} {\bfseries 97} 170201. - !% Beware, this algorithm is patent pending in the US. - function fire_minim(x, mass, func, dfunc, dt0, tol, max_steps, hook, hook_print_interval, data, dt_max, status) - real(dp), intent(inout), dimension(:) :: x - real(dp), intent(in) :: mass - interface - function func(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - end function func - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - end interface - real(dp), intent(in) :: dt0 - real(dp), intent(in) :: tol - integer, intent(in) :: max_steps - optional :: hook - interface - subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - end subroutine hook - end interface - integer, optional :: hook_print_interval - character(len=1),optional::data(:) - real(dp), intent(in), optional :: dt_max - integer, optional, intent(out) :: status - integer :: fire_minim - - integer :: my_hook_print_interval - - real(dp), allocatable, dimension(:) :: velo, acc, force - real(dp) :: f, df2, alpha_start, alpha, P, dt, my_dt_max - integer :: i, Pcount - logical :: done - - if (present(status)) status = 0 - - if (current_verbosity() >= PRINT_VERBOSE) then - my_hook_print_interval = optional_default(1, hook_print_interval) - else if (current_verbosity() >= PRINT_NORMAL) then - my_hook_print_interval = optional_default(10, hook_print_interval) - else if (current_verbosity() >= PRINT_SILENT) then - my_hook_print_interval = optional_default(100000, hook_print_interval) - endif - - allocate (velo(size(x)), acc(size(x)), force(size(x))) - - alpha_start = 0.1_dp - alpha = alpha_start - dt = dt0 - my_dt_max = optional_default(20.0_dp*dt, dt_max) - Pcount = 0 - - call Print('Welcome to fire_minim', PRINT_NORMAL) - call Print('Attempting to find minimum with tolerance '// tol, PRINT_NORMAL) - - velo = 0 - acc = -dfunc(x,data)/mass - - do i = 1, max_steps - - velo = velo + (0.5_dp*dt)*acc - force = dfunc(x,data) ! keep original sign of gradient for now as hook() expects gradient, not force - - df2 = normsq(force) - - if (df2 < tol) then - write (line, '(i4,a,e10.2)') i, ' force^2 = ', df2 - call Print(line, PRINT_NORMAL) - - write (line, '(a,i0,a)') 'Converged in ', i, ' steps.' - call Print(line, PRINT_NORMAL) - exit - else if(mod(i, my_hook_print_interval) == 0) then - f = func(x,data) - write (line, '(i4,a,e24.16,a,e24.16,a,f0.3,a,e24.16)') i,' f=',f,' df^2=',df2,' dt=', dt, 'max(abs(df))=', maxval(abs(force)) - call Print(line, PRINT_NORMAL) - - if(present(hook)) then - call hook(x, force, f, done, (mod(i-1,my_hook_print_interval) == 0), data) - if (done) then - call print('hook reports that fire_minim is finished, exiting.', PRINT_NORMAL) - exit - end if - end if - end if - - force = -force ! convert from gradient of energy to force - acc = force/mass - velo = velo + (0.5_dp*dt)*acc - - P = velo .dot. force - velo = (1.0_dp-alpha)*velo + (alpha*norm(velo)/norm(force))*force - if (P > 0) then - if(Pcount > 5) then - dt = min(dt*1.1_dp, my_dt_max) - alpha = alpha*0.99_dp - else - Pcount = Pcount + 1 - end if - else - dt = dt*0.5_dp - velo = 0.0_dp - alpha = alpha_start - Pcount = 0 - end if - - x = x + dt*velo - x = x + (0.5_dp*dt*dt)*acc - - if(current_verbosity() >= PRINT_NERD) then - write (line, '(a,e24.16)') 'E=', func(x,data) - call print(line,PRINT_NERD) - call print(x,PRINT_NERD) - end if - end do - - if(i == max_steps) then - write (line, '(a,i0,a)') 'fire_minim: Failed to converge in ', i, ' steps.' - call Print(line, PRINT_ALWAYS) - if (present(status)) status = 1 - end if - - fire_minim = i - - deallocate(velo, acc, force) - - end function fire_minim - - - -!%%%% -!% Noam's line minimizer -!% -!% args -!% x: input vector, flattened into 1-D double array -!% bothfunc: input pointer to function computing value and gradient -!% neg_gradient: input negative of gradient (i.e. force) for input x -!% E: input value at x -!% search_dir: input vector search direction, not necessarily normalized -!% new_x: output x at minimimum -!% new_new_gradient: output negative of gradient at new_x -!% new_E: output value at new_x -!% max_step_size: input max step size (on _normalized_ search dir), output actual step size for this linmin -!% accuracy: input desired accuracy on square of L2 norm of projected gradient -!% N_evals: input initial number of function evals so far, output final number of function evalutions -!% max_N_evals: input max number of function evaluations before giving up -!% hook: input pointer to function to call after each evaluation -!% data: input pointer to other data needed for calc, flattened to 1-D character array with transfer() -!% error: output error state -!%%%% - -subroutine n_linmin(x, bothfunc, neg_gradient, E, search_dir, & - new_x, new_neg_gradient, new_E, & - max_step_size, accuracy, N_evals, max_N_evals, hook, hook_print_interval, & - data, error) - real(dp), intent(inout) :: x(:) - real(dp), intent(in) :: neg_gradient(:) - interface - subroutine bothfunc(x,E,f,data,error) - use system_module - real(dp)::x(:) - real(dp)::E - real(dp)::f(:) - character(len=1),optional::data(:) - integer,optional :: error - end subroutine bothfunc - end interface - real(dp), intent(inout) :: E - real(dp), intent(inout) :: search_dir(:) - real(dp), intent(out) :: new_x(:), new_neg_gradient(:) - real(dp), intent(out) :: new_E - real(dp), intent(inout) :: max_step_size - real(dp), intent(in) :: accuracy - integer, intent(inout) :: N_evals - integer, intent(in) :: max_N_evals - optional :: hook - interface - subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - end subroutine hook - end interface - integer, intent(in), optional :: hook_print_interval - character(len=1),optional::data(:) - integer, intent(out), optional :: error - - logical :: do_print - real(dp) search_dir_mag - real(dp) p0_dot, p1_dot, new_p_dot - real(dp), allocatable :: p0(:), p1(:), p0_ng(:), p1_ng(:), new_p(:), new_p_ng(:), t_projected(:) - real(dp) p0_E, p1_E, new_p_E - real(dp) p0_pos, p1_pos, new_p_pos - - real(dp) tt - real(dp) t_a, t_b, t_c, Ebar, pbar, soln_1, soln_2 - - integer :: n_pure_linesearch - integer :: max_pure_linesearch = 10 - logical done, use_cubic, got_valid_cubic - - integer l_error - real(dp) est_step_size - - INIT_ERROR(error) - - do_print = .false. - - allocate(p0(size(x))) - allocate(p1(size(x))) - allocate(p0_ng(size(x))) - allocate(p1_ng(size(x))) - allocate(new_p(size(x))) - allocate(new_p_ng(size(x))) - allocate(t_projected(size(x))) - - call print ("n_linmin starting line minimization", PRINT_NERD) - call print ("n_linmin initial |x| " // norm(x) // " |neg_gradient| " // & - norm(neg_gradient) // " |search_dir| " // norm(search_dir), PRINT_NERD) - - search_dir_mag = norm(search_dir) - ! search_dir = search_dir / search_dir_mag - search_dir = search_dir / search_dir_mag - - p0_dot = neg_gradient .dot. search_dir - - t_projected = search_dir*p0_dot - if (normsq(t_projected) .lt. accuracy) then - call print ("n_linmin initial config is apparently converged " // norm(t_projected) // " " // accuracy, PRINT_NERD) - endif - - p0_pos = 0.0_dp - p0 = x - p0_ng = neg_gradient - p0_E = E - - p0_dot = p0_ng .dot. search_dir - call print("initial p0_dot " // p0_dot, PRINT_NERD) - - if (p0_dot .lt. 0.0_dp) then - p0_ng = -p0_ng - p0_dot = -p0_dot - endif - - call print("cg_n " // p0_pos // " " // p0_e // " " // p0_dot // " " // & - normsq(p0_ng) // " " // N_evals // " bracket starting", PRINT_VERBOSE) - - est_step_size = 4.0_dp*maxval(abs(p0_ng))**2/p0_dot - if (max_step_size .gt. 0.0_dp .and. est_step_size .gt. max_step_size) then - est_step_size = max_step_size - endif - - p1_pos = est_step_size - p1 = x + p1_pos*search_dir - p1_ng = p0_ng - l_error = 1 - do while (l_error .ne. 0) - N_evals = N_evals + 1 - l_error=0 - call bothfunc(p1, p1_e, p1_ng, data, error=l_error); p1_ng = -p1_ng - if (present(hook_print_interval)) do_print = (mod(N_evals, hook_print_interval) == 0) - if (present(hook)) call hook(p1,p1_ng,p1_E,done,do_print,data) - if (l_error .ne. 0) then - call print("cg_n " // p1_pos // " " // p1_e // " " // 0.0_dp // " " // & - 0.0_dp // " " // N_evals // " bracket first step ERROR", PRINT_ALWAYS) - est_step_size = est_step_size*0.5_dp - p1_pos = est_step_size - p1 = x + p1_pos*search_dir - endif - if (N_evals .gt. max_N_evals) then - RAISE_ERROR_WITH_KIND(ERROR_MINIM_NOT_CONVERGED, "n_linmin ran out of iterations", error) - endif - end do - - p1_dot = p1_ng .dot. search_dir - - call print("cg_n " // p1_pos // " " // p1_e // " " // p1_dot // " " // & - normsq(p1_ng) // " " // N_evals // " bracket first step", PRINT_VERBOSE) - - t_projected = search_dir*p1_dot - ! if (object_norm(t_projected,norm_type) .lt. accuracy) then - ! ! search_dir = search_dir * search_dir_mag - ! call scalar_selfmult (search_dir, search_dir_mag) - ! minimize_along = 0 - ! call print ("returning from minimize_along, t_projected is_converged") - ! return - ! endif - - call print ("starting bracketing loop", PRINT_NERD) - - ! bracket solution - do while (p1_dot .ge. 0.0_dp) - p0 = p1 - p0_ng = p1_ng - p0_E = p1_E - p0_pos = p1_pos - p0_dot = p1_dot - - p1_pos = p1_pos + est_step_size - - call print ("checking bracketing for " // p1_pos, PRINT_NERD) - - p1 = x + p1_pos*search_dir - l_error = 1 - do while (l_error .ne. 0) - N_evals = N_evals + 1 - l_error = 0 - call bothfunc (p1, p1_E, p1_ng, data, error=l_error); p1_ng = -p1_ng - if (present(hook_print_interval)) do_print = (mod(N_evals, hook_print_interval) == 0) - if (present(hook)) call hook(p1,p1_ng,p1_E,done,do_print,data) - if (done) then - call print("hook reported done", PRINT_NERD) - search_dir = search_dir * search_dir_mag - new_x = p1 - new_neg_gradient = p1_ng - new_E = p1_E - return - endif - if (l_error .ne. 0) then - call print("cg_n " // p0_pos // " " // p0_e // " " // 0.0_dp // " " // & - 0.0_dp // " " // N_evals // " bracket loop ERROR", PRINT_ALWAYS) - call print ("Error in bracket loop " // l_error // " stepping back", PRINT_ALWAYS) - p1_pos = p1_pos - est_step_size - est_step_size = est_step_size*0.5_dp - p1_pos = p1_pos + est_step_size - p1 = x + p1_pos*search_dir - endif - if (N_evals .gt. max_N_evals) then - search_dir = search_dir * search_dir_mag - RAISE_ERROR_WITH_KIND(ERROR_MINIM_NOT_CONVERGED, "n_linmin ran out of iterations", error) - endif - end do - - p1_dot = p1_ng .dot. search_dir - - ! tt = -p0_dot/(p1_dot-p0_dot) - ! if (1.5D0*tt*(p1_pos-p0_pos) .lt. 10.0*est_step_size) then - ! est_step_size = 1.5_dp*tt*(p1_pos-p0_pos) - ! else - est_step_size = est_step_size*2.0_dp - ! end if - - call print("cg_n " // p1_pos // " " // p1_e // " " // p1_dot // " " // & - normsq(p1_ng) // " " // N_evals // " bracket loop", PRINT_VERBOSE) - end do - - call print ("bracketed by" // p0_pos // " " // p1_pos, PRINT_NERD) - - done = .false. - t_projected = 2.0_dp*sqrt(accuracy) - !new_p_dot = accuracy*2.0_dp - n_pure_linesearch = 0 - do while (n_pure_linesearch < max_pure_linesearch .and. normsq(t_projected) .ge. accuracy .and. (.not. done)) - n_pure_linesearch = n_pure_linesearch + 1 - call print ("n_linmin starting true minimization loop", PRINT_NERD) - - use_cubic = .false. - if (use_cubic) then - !!!! fit to cubic polynomial - Ebar = p1_E-p0_E - pbar = p1_pos-p0_pos - t_a = (-p0_dot) - t_c = (pbar*((-p1_dot)-(-p0_dot)) - 2.0_dp*Ebar + 2*(-p0_dot)*pbar)/pbar**3 - t_b = (Ebar - (-p0_dot)*pbar - t_c*pbar**3)/pbar**2 - - soln_1 = (-2.0_dp*t_b + sqrt(4.0_dp*t_b**2 - 12.0_dp*t_a*t_c))/(6.0_dp*t_c) - soln_2 = (-2.0_dp*t_b - sqrt(4.0_dp*t_b**2 - 12.0_dp*t_a*t_c))/(6.0_dp*t_c) - - if (soln_1 .ge. 0.0_dp .and. soln_1 .le. pbar) then - new_p_pos = p0_pos + soln_1 - got_valid_cubic = .true. - else if (soln_2 .ge. 0.0_dp .and. soln_2 .le. pbar) then - new_p_pos = p0_pos + soln_2 - got_valid_cubic = .true. - else - call print ("n_linmin warning: no valid solution for cubic", PRINT_ALWAYS) - !!!! use only derivative information to find pt. where derivative = 0 - tt = -p0_dot/(p1_dot-p0_dot) - new_p_pos = p0_pos + tt*(p1_pos-p0_pos) - done = .false. - endif - else - !!!! use only derivative information to find pt. where derivative = 0 - tt = -p0_dot/(p1_dot-p0_dot) - new_p_pos = p0_pos + tt*(p1_pos-p0_pos) - ! done = .true. - done = .false. - endif - - new_p = x + new_p_pos*search_dir - N_evals = N_evals + 1 - call bothfunc (new_p, new_p_E, new_p_ng, data, error); new_p_ng = -new_p_ng - if (error .ne. 0) then - call system_abort("n_linmin: Error in line search " // error) - endif - - if (N_evals .gt. max_N_evals) done = .true. - - ! if (inner_prod(new_p_ng,new_p_ng) .lt. 0.1 .and. got_valid_cubic) done = .true. - ! if (got_valid_cubic) done = .true. - - new_p_dot = new_p_ng .dot. search_dir - - call print("cg_n " // new_p_pos // " " // new_p_E // " " // new_p_dot // " " // & - normsq(new_p_ng) // " " // N_evals // " during line search", PRINT_VERBOSE) - - if (new_p_dot .gt. 0) then - p0 = new_p - p0_pos = new_p_pos - p0_dot = new_p_dot - p0_ng = new_p_ng - p0_E = new_p_E - else - p1 = new_p - p1_pos = new_p_pos - p1_dot = new_p_dot - p1_ng = new_p_ng - p1_E = new_p_E - endif - - t_projected = search_dir*new_p_dot - end do - - new_x = new_p - new_neg_gradient = new_p_ng - new_E = new_p_E - - max_step_size = new_p_pos - search_dir = search_dir * search_dir_mag - - call print ("done with line search", PRINT_NERD) -end subroutine n_linmin - -!%%%% -!% Noam's minimizer with preconditioning from Cristoph Ortner -!% return value: number of function evaluations -!% args -!% x_i: input vector, flattened into a 1-D double array -!% bothfunc: input pointer to function that returns value and gradient -!% can apply simple constraints and external (body) forces -!% use_precond: input logical controling preconditioning -!% apply_precond_func: input pointer to function that applies preconditioner to a vector -!% initial_E: output initial value -!% final_E: output final value -!% expected reduction: input expected reduction in value used to estimate initial step -!% max_N_evals: max number of function evaluations before giving up -!% accuracy: desired accuracy on square of L2 norm of gradient -!% hook: pointer to function passed to linmin and called once per CG step -!% does stuff like print configuration, and can also apply other ending conditions, -!% although latter capability isn't used -!% hook_print_interval: how often to call hook, depending on verbosity level -!% data: other data both_func will need to actually do calculation, flattened into -!% character array by transfer() function. Maybe be replaced with F2003 pointer soon -!% error: output error state -!%%%% -function n_minim(x_i, bothfunc, use_precond, apply_precond_func, initial_E, final_E, & - expected_reduction, max_N_evals, accuracy, hook, hook_print_interval, data, error) result(N_evals) - real(dp), intent(inout) :: x_i(:) - interface - subroutine bothfunc(x,E,f,data,error) - use system_module - real(dp)::x(:) - real(dp)::E - real(dp)::f(:) - character(len=1),optional::data(:) - integer, optional :: error - end subroutine bothfunc - end interface - logical :: use_precond - interface - subroutine apply_precond_func(x,g,P_g,data,error) - use system_module - real(dp)::x(:),g(:),P_g(:) - character(len=1),optional::data(:) - integer, optional :: error - end subroutine apply_precond_func - end interface - real(dp), intent(out) :: initial_E, final_E - real(dp), intent(inout) :: expected_reduction - integer, intent(in) :: max_N_evals - real(dp), intent(in) :: accuracy - optional :: hook - integer :: N_evals - interface - subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - end subroutine hook - end interface - integer, optional :: hook_print_interval - character(len=1),optional::data(:) - integer, optional, intent(out) :: error - - real(dp) :: E_i, E_ip1 - - logical :: done, hook_done - integer :: iter - real(dp) :: max_step_size, initial_step_size - - real(dp), allocatable :: g_i(:) - real(dp), allocatable :: x_ip1(:), g_ip1(:) - real(dp), allocatable :: h_i(:) - real(dp), allocatable :: P_g(:) - - real(dp) :: g_i_dot_g_i, g_ip1_dot_g_i, g_ip1_dot_g_ip1 - real(dp) :: gamma_i - - integer :: l_error - - integer :: my_hook_print_interval - - INIT_ERROR(error) - - if (current_verbosity() >= PRINT_VERBOSE) then - my_hook_print_interval = optional_default(1, hook_print_interval) - else if (current_verbosity() >= PRINT_NORMAL) then - my_hook_print_interval = optional_default(10, hook_print_interval) - else if (current_verbosity() >= PRINT_SILENT) then - my_hook_print_interval = optional_default(100000, hook_print_interval) - endif - - allocate(g_i(size(x_i))) - allocate(x_ip1(size(x_i))) - allocate(g_ip1(size(x_i))) - allocate(h_i(size(x_i))) - N_evals = 1 - call bothfunc(x_i, E_i, g_i, data, error=error); g_i = -g_i - if (present(hook)) call hook(x_i, g_i, E_i, done, .true., data) - PASS_ERROR_WITH_INFO("n_minim first evaluation", error) - initial_E = E_i - - allocate(P_g(size(x_i))) - ! need to get P into the routine somehow - if (use_precond) then - call apply_precond_func(x_i, g_i, P_g, data, error=error) - PASS_ERROR_WITH_INFO("n_miniCGinitial preconditioning call", error) - else - P_g = g_i - endif - - call print("#cg_n use_precond="//use_precond) - - call print("#cg_n " // " x" // & - " val" // & - " -grad.dir" // & - " |grad|^2" // " n_evals") - call print("cg_n " // 0.0_dp // " " // E_i // " " // (g_i.dot.g_i) // " " // & - normsq(g_i) // " " // N_evals // " INITIAL_VAL") - - if (normsq(g_i) .lt. accuracy) then - call print("cg_n " // 0.0_dp // " " // E_i // " " // (g_i.dot.g_i) // " " // & - normsq(g_i) // " " // N_evals // " FINAL_VAL") - call print ("n_minim initial config is converged " // norm(g_i) // " " // accuracy, PRINT_VERBOSE) - final_E = initial_E - return - endif - - h_i = P_g - - iter = 1 - done = .false. - do while (N_evals .le. max_N_evals .and. (.not.(done))) - - !! max_step_size = 4.0_dp*expected_reduction / norm(g_i) - max_step_size = 1.0_dp * expected_reduction / (g_i .dot. (h_i/norm(h_i))) ! dividing by norm(h_i) because n_linmin will normalize h_i - ! if (max_step_size .gt. 1.0_dp) then - ! max_step_size = 1.0_dp - ! endif - call print("max_step_size "//max_step_size, verbosity=PRINT_VERBOSE) - - call print("cg_n " // 0.0_dp // " " // E_i // " " // (g_i.dot.h_i) // " " // & - normsq(g_i) // " " // N_evals // " n_minim pre linmin") - l_error = ERROR_NONE - call n_linmin(x_i, bothfunc, g_i, E_i, h_i, & - x_ip1, g_ip1, E_ip1, & - max_step_size, accuracy, N_evals, max_N_evals, hook, hook_print_interval, data, l_error) - if (l_error == ERROR_MINIM_NOT_CONVERGED) then - if (N_evals > max_N_evals) then - final_E = E_i - RAISE_ERROR_WITH_KIND(l_error, "linmin: n_minim didn't converge", error) - endif - ! we're just going to continue after an unconverged linmin, - CLEAR_ERROR() - else - PASS_ERROR_WITH_INFO("linmin: n_minim error", error) - endif - - call print("cg_n " // 0.0_dp // " " // E_ip1 // " " // (g_ip1.dot.h_i) // " " // & - normsq(g_ip1) // " " // N_evals // " n_minim post linmin") - - if (E_ip1 > E_i) then - final_E = E_i - call print("WARNING:n_minim: n_limin stepped uphill - forces may not be consistent with energy", verbosity=PRINT_ALWAYS) - ! RAISE_ERROR("n_minim: n_limin stepped uphill - forces may not be consistent with energy", error) - endif - - if (normsq(g_ip1) .lt. accuracy) then - call print("n_minim is converged", PRINT_VERBOSE) - E_i = E_ip1 - x_i = x_ip1 - g_i = g_ip1 - done = .true. - endif - - ! gamma_i = sum(g_ip1*g_ip1)/sum(g_i*g_i) ! Fletcher-Reeves - ! gamma_i = sum((g_ip1-g_i)*g_ip1)/sum(g_i*g_i) ! Polak-Ribiere - g_i_dot_g_i = g_i .dot. P_g - g_ip1_dot_g_i = g_ip1 .dot. P_g - !! perhaps have some way of telling apply_precond_func to update/not update preconitioner? - if (use_precond) then - call apply_precond_func(x_ip1, g_ip1, P_g, data, error=error) - PASS_ERROR_WITH_INFO("n_minim in-loop preconditioning call", error) - else - P_g = g_ip1 - endif - g_ip1_dot_g_ip1 = g_ip1 .dot. P_g - gamma_i = (g_ip1_dot_g_ip1 - g_ip1_dot_g_i)/g_i_dot_g_i - ! steepest descent - ! gamma_i = 0.0_dp - h_i = gamma_i*h_i + P_g - - if (iter .eq. 1) then - expected_reduction = abs(E_i - E_ip1)/10.0_dp - else - expected_reduction = abs(E_i - E_ip1)/2.0_dp - endif - - E_i = E_ip1 - x_i = x_ip1 - g_i = g_ip1 - ! P_g is already P_g_ip1 from gamma_i evaluation code - - if (present(hook)) then - call hook(x_i,g_i,E_i,hook_done,(mod(iter-1,my_hook_print_interval) == 0), data) - if (hook_done) done = .true. - endif - - call print("cg_n " // 0.0_dp // " " // E_i // " " // (g_i.dot.h_i) // " " // & - normsq(g_i) // " " // N_evals // " n_minim with new dir") - - call print("n_minim loop end, N_evals " // N_evals // " max_N_evals " // max_N_evals // & - " done " // done, PRINT_VERBOSE) - - iter = iter + 1 - - end do - - if (present(hook)) then - call hook(x_i,g_i,E_i,hook_done,.true.,data) - if (hook_done) done = .true. - endif - - final_E = E_i - - call print("cg_n " // 0.0_dp // " " // final_E // " " // (g_i.dot.h_i) // " " // & - normsq(g_i) // " " // N_evals // " FINAL_VAL") - -end function n_minim - -subroutine line_scan(x0, xdir, func, use_func, dfunc, data) - real(dp)::x0(:) !% Starting vector - real(dp)::xdir(:)!% Search direction - INTERFACE - function func(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - end function func - END INTERFACE - logical :: use_func - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - character(len=1), optional::data(:) - - integer :: i - real(dp) :: new_eps - real(dp) :: fn, dirdx_new - real(dp), allocatable :: xn(:), dxn(:) - - allocate(xn(size(x0))) - allocate(dxn(size(x0))) - - fn = 0.0_dp - call print('line scan:', PRINT_NORMAL) - new_eps = 1.0e-5_dp - do i=1,50 - xn = x0 + new_eps*xdir -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - if (use_func) fn = func(xn,data) - dxn = dfunc(xn,data) -#ifndef _OPENMP - call verbosity_pop() -#endif - dirdx_new = xdir .DOT. dxn - - call print('LINE_SCAN ' // new_eps//' '//fn// ' '//dirdx_new, PRINT_NORMAL) - - new_eps = new_eps*1.15 - enddo - - deallocate(xn) - -end subroutine line_scan - -function func_wrapper(func, x, data, local_energy, gradient, doefunc) - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - integer, intent(in) :: doefunc - real(dp)::func_wrapper - - if (doefunc == E_FUNC_BASIC) then - func_wrapper = func(x, data, gradient=gradient) - if (present(local_energy)) then - local_energy = 0.0_dp - local_energy(1) = func_wrapper - endif - else - func_wrapper = func(x, data, local_energy=local_energy, gradient=gradient) - endif -end function func_wrapper - -! Interface is made to imitate the existing interface. - function preconminim(x_in,func,dfunc,build_precon,pr,method,convergence_tol,max_steps,efuncroutine,LM, linminroutine, hook, & - hook_print_interval, am_data, status,writehessian,gethessian,getfdhconnectivity,infoverride,infconvext) - - implicit none - - real(dp), intent(inout) :: x_in(:) !% Starting position - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - INTERFACE - subroutine build_precon(pr,am_data) - use system_module - import precon_data - type(precon_data),intent(inout) ::pr - character(len=1)::am_data(:) - end subroutine - END INTERFACE - type(precon_data):: pr - character(*), intent(in) :: method !% 'cg' for conjugate gradients or 'sd' for steepest descent - real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ - !% 'convergence_tol'. - integer, intent(in) :: max_steps !% Maximum number of 'cg' or 'sd' steps - character(*), intent(in), optional :: efuncroutine !% Control of the objective function evaluation - character(*), intent(in), optional :: linminroutine !% Name of the line minisation routine to use. - integer, optional :: LM - optional :: hook - INTERFACE - subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - end subroutine hook - end INTERFACE - integer, intent(in), optional :: hook_print_interval - character(len=1), optional, intent(inout) :: am_data(:) - integer, optional, intent(out) :: status - optional :: writehessian - INTERFACE - subroutine writehessian(x,data,filename) - use system_module - real(dp) :: x(:) - character(len=1)::data(:) - character(*) :: filename - end subroutine writehessian - end INTERFACE - optional :: gethessian - INTERFACE - subroutine gethessian(x,data,FDHess) - use system_module - real(dp),intent(in):: x(:) - character(len=1),intent(in)::data(:) - real(dp),intent(inout) :: FDHess(:,:) - end subroutine gethessian - end INTERFACE - optional :: getfdhconnectivity - INTERFACE - subroutine getfdhconnectivity(rows,columns,rn,data) - use system_module - integer, intent(inout) :: rows(:), columns(:) - integer, intent(out) :: rn - character(len=1), intent(in)::data(:) - end subroutine - end INTERFACE - ! result - real(dp), optional :: infoverride - logical, optional :: infconvext - integer::preconminim - - logical :: doFD,doSD, doCG,doLBFGS,doDLLBFGS,doSHLBFGS,doSHLSR1,doGHLBFGS,doGHLSR1,doGHFD,doSHFD, doGHFDH, doprecon,done - logical :: doLSbasic,doLSbasicpp,doLSstandard, doLSnone,doLSMoreThuente,doLSunit - integer :: doefunc - real(dp),allocatable :: x(:),xold(:),s(:),sold(:),g(:),gold(:),pg(:),pgold(:),xcand(:),gcand(:) - real(dp) :: alpha,alphamax, beta,betanumer,betadenom,f - integer :: n_iter,N, abortcount - real(dp),allocatable :: alpvec(:),dirderivvec(:) - integer :: my_hook_print_interval - real(dp) :: normsqgrad, normsqs - integer :: this_ls_count, total_ls_count - real(dp) :: amax - real(dp),allocatable :: local_energy(:),local_energyold(:),local_energycand(:) - real(dp) :: dotpgout - type (precon_data) :: hess - real(dp),allocatable :: LBFGSs(:,:), LBFGSy(:,:), LBFGSa(:,:), LBFGSb(:,:), LBFGSalp(:), LBFGSbet(:), LBFGSrho(:), LBFGSq(:), LBFGSz(:), LBFGSbuf1(:), LBFGSbuf2(:) - real(dp),allocatable :: LBFGSdlr(:,:) - integer :: LBFGSm, LBFGScount - integer :: I, n_back,thisind - integer :: k_out - - real(dp), allocatable :: TRcandg(:),TRBs(:),TRyk(:) - real(dp) :: TRared,TRpred,TRdelta,fcand,TRrho,ftest - type(precon_data) :: TRB - real(dp) :: TReta = 0.25 - real(dp) :: TRr = 10.0**(-8) - - real(dp), allocatable :: FDhess(:,:) - integer, allocatable :: IPIV(:) - real(dp), allocatable :: LBFGSd(:,:), LBFGSl(:,:), SR1testvec(:) - integer :: SR1I,SR1J - integer :: INFO - real(dp) :: SR1testLHS,SR1testRHS - logical :: SR1doupdate - logical :: term2norm - - - N = size(x_in) - - !allocate NLCG vectors - allocate(x(N)) - allocate(xold(N)) - allocate(s(N)) - allocate(sold(N)) - allocate(g(N)) - allocate(gold(N)) - allocate(pg(N)) - allocate(pgold(N)) - - !allocate linesearch history vectors - allocate(alpvec(max_steps)) - allocate(dirderivvec(max_steps)) - - allocate(local_energy( (size(x) - 9)/3 )) - allocate(local_energyold( (size(x) - 9)/3 )) - - if (current_verbosity() >= PRINT_VERBOSE) then - my_hook_print_interval = optional_default(1, hook_print_interval) - else if (current_verbosity() >= PRINT_NORMAL) then - my_hook_print_interval = optional_default(10, hook_print_interval) - else - my_hook_print_interval = optional_default(100000, hook_print_interval) - endif - - doFD = .false. - doCG = .FALSE. - doSD = .FALSE. - doLBFGS = .false. - doDLLBFGS = .false. - doSHLBFGS = .false. - doSHLSR1 = .false. - doGHLBFGS = .false. - doGHLSR1 = .false. - doGHFD = .false. - doGHFDH = .false. - doSHFD = .false. - if (trim(method) == 'preconCG') then - doCG = .TRUE. - call print("Using preconditioned Polak-Ribiere Conjugate Gradients") - else if (trim(method) == 'preconSD') then - doSD = .TRUE. - call print("Using preconditioned Steepest Descent") - else if (trim(method) == 'preconLBFGS') then - doLBFGS = .TRUE. - call print ("Using linesearching limited memory BFGS") - else if (trim(method) == 'preconDLLBFGS') then - doDLLBFGS = .true. - call print ("Using dogleg trust region limited memory BFGS") - else if (trim(method) == 'preconSHLBFGS') then - doSHLBFGS = .true. - call print ("Using Steihaug trust region limited memory BFGS") - else if (trim(method) == 'preconSHLSR1') then - doSHLSR1 = .true. - call print ("Using Steihaug trust region limited memory SR1") - else if (trim(method) == 'preconSHFD') then - doSHFD = .true. - call print ("Using Steihaug trust region with FD based Hessian") - else if (trim(method) == 'FD') then - doFD = .true. - else - call print('Unrecognized minim method, exiting') - call exit() - end if - - if (doLBFGS .or. doDLLBFGS .or. doSHLBFGS .or. doSHLSR1 .or. doSHFD) then - - LBFGSm = 20 - if ( present(LM) ) LBFGSm = LM - - allocate(LBFGSs(N,LBFGSm)) - allocate(LBFGSy(N,LBFGSm)) - allocate(LBFGSalp(LBFGSm)) - allocate(LBFGSbet(LBFGSm)) - allocate(LBFGSrho(LBFGSm)) - allocate(LBFGSz(N)) - allocate(LBFGSq(N)) - allocate(LBFGSbuf1(N)) - allocate(LBFGSdlr(LBFGSm,LBFGSm)) - LBFGSbuf1 = 0.0 - LBFGScount = 0 - LBFGSy = 0.0_dp - LBFGSs = 0.0_dp - LBFGSdlr = 0.0_dp - LBFGSrho = 0.0 - end if - if(doDLLBFGS .or. doSHLBFGS .or. doSHLSR1 .or. doSHFD ) then - allocate(xcand(N)) - allocate(gcand(N)) - allocate(LBFGSb(N,LBFGSm)) - allocate(TRBs(N)) - end if - if(doSHLSR1) then - allocate(SR1testvec(N)) - end if - if(doFD .or. doSHFD) then - allocate(FDHess(N,N)) - allocate(IPIV(N)) - end if - - - doLSbasic = .FALSE. - doLSbasicpp = .FALSE. - doLSstandard = .FALSE. - doLSnone = .FALSE. - doLSMoreThuente = .false. - doLSunit = .false. - - doefunc = 0 - if ( present(efuncroutine) ) then - if (trim(efuncroutine) == 'basic') then - doefunc = E_FUNC_BASIC - call print('Using naive summation of local energies') - elseif (trim(efuncroutine) == 'kahan') then - doefunc = E_FUNC_KAHAN - allocate(local_energycand((size(x)-9)/3)) - call print('Using Kahan summation of local energies') - elseif (trim(efuncroutine) == 'doublekahan') then - doefunc = E_FUNC_DOUBLEKAHAN - allocate(local_energycand((size(x)-9)/3)) - call print('Using double Kahan summation of local energies with quicksort') - else - call print('Unrecognized efuncroutine, normally use "basic" or "kahan", aborting for safety') - call exit() - end if - else - doefunc = E_FUNC_BASIC - call print('Using naive summation of local energies by default') - end if - - if (doSD .or. doCG .or. doLBFGS) then - if ( present(linminroutine) ) then - if (trim(linminroutine) == 'basic') then - call print('Using basic backtracking linesearch') - doLSbasic = .TRUE. - elseif (trim(linminroutine) == 'basicpp') then - call print('Using backtracking linesearch with cubic interpolation') - doLSbasicpp = .TRUE. - elseif (trim(linminroutine) == 'standard') then - call print('Using standard two-stage linesearch with cubic interpolation in the zoom phase, with bisection as backup') - doLSstandard = .TRUE. - elseif (trim(linminroutine) == 'none') then - call print('Using no linesearch method (relying on init_alpha to make good guesses)') - doLSnone = .TRUE. - elseif (trim(linminroutine) == 'morethuente') then - call print('Using More & Thuente minpack linesearch') - doLSMoreThuente = .TRUE. - elseif (trim(linminroutine) == 'unit') then - call print('Using fixed stepsize of 1') - doLSunit = .true. - else - call print('Unrecognized linmin routine') - call exit() - end if - else - call print('Defaulting to basic linesearch') - doLSbasic = .TRUE. - end if - end if - - term2norm = .true. - if (present(infconvext)) then - if (infconvext .eqv. .true.) then - term2norm = .false. - end if - end if - - x = x_in - - !Main Loop - this_ls_count = 0 - total_ls_count = 0 - n_iter = 1 - call system_timer("preconminim/func") -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - f = func_wrapper(func,x,am_data,local_energy,g,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("preconminim/func") - - abortcount = 0 - alpha = 0 - this_ls_count = 0 - dotpgout = 0 - do - - if(doSD .or. doCG .or. doLBFGS .or. doFD) then - normsqgrad = smartdotproduct(g,g,doefunc) - - if ( normsqgrad < convergence_tol .and. term2norm) then - call print('Extended minim completed with |df|^2 = '// normsqgrad // ' < tolerance = ' // convergence_tol // ' total linesearch iterations = '// total_ls_count) - ! call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |df|^2 = '// normsqgrad// ' max(abs(df)) = '//maxval(abs(g))//' last alpha = '//alpha) - call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad// ' sg/(|s||g|) = '//dotpgout//' last alpha = '//alpha//' max(abs(g)) = '//maxval(abs(g)) & - // ' last ls_iter = ' // this_ls_count) - exit - elseif ( maxval(abs(g)) < convergence_tol .and. .not. term2norm) then - call print('Extended minim completed with |df|_infty = '// maxval(abs(g)) // ' < tolerance = ' // convergence_tol // ' total linesearch iterations = '// total_ls_count) - ! call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |df|^2 = '// normsqgrad// ' max(abs(df)) = '//maxval(abs(g))//' last alpha = '//alpha) - call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad// ' sg/(|s||g|) = '//dotpgout//' last alpha = '//alpha//' max(abs(g)) = '//maxval(abs(g)) & - // ' last ls_iter = ' // this_ls_count) - exit - - end if - - call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad// ' sg/(|s||g|) = '//dotpgout //' last alpha = '//alpha//' max(abs(g)) = '//maxval(abs(g)) & - // ' last ls_iter = ' // this_ls_count,PRINT_NORMAL) - ! call the hook function - if (present(hook)) then - call hook(x, g, f, done, (mod(n_iter-1,my_hook_print_interval) == 0), am_data) - else - call print("hook is not present", PRINT_VERBOSE) - end if - !if(n_iter == 1) call build_precon(pr,am_data) - call build_precon(pr,am_data) - !call writeprecon(pr,'pr') - !call exit() - - if (doCG .or. doSD) then - pgold = pg - if (n_iter > 1) then - pg = apply_precon(g,pr,doefunc,init=pgold) - elseif (n_iter == 1) then - pg = apply_precon(g,pr,doefunc) - end if - end if - - sold = s - if (n_iter > 1 .AND. doCG) then - - betanumer = smartdotproduct(pg, (g - gold),doefunc) - betadenom = smartdotproduct(pgold,gold,doefunc) - beta = betanumer/betadenom - - if (beta > 0) then - beta = 0 - end if - - s = -pg + beta*sold - - elseif (doLBFGS) then - - !call print(LBFGSrho) - if (n_iter > 1) then - LBFGSs(1:N,1:(LBFGSm-1)) = LBFGSs(1:N,2:LBFGSm) - LBFGSy(1:N,1:(LBFGSm-1)) = LBFGSy(1:N,2:LBFGSm) - - LBFGSrho(1:(LBFGSm-1)) = LBFGSrho(2:LBFGSm) - LBFGSs(1:N,LBFGSm) = x - xold - LBFGSy(1:N,LBFGSm) = g - gold - LBFGSrho(LBFGSm) = 1.0/smartdotproduct(LBFGSs(1:N,LBFGSm),LBFGSy(1:N,LBFGSm),doefunc) - end if - n_back = min(LBFGSm,LBFGScount,n_iter-1) - !n_back = 0 - LBFGSq = g - do I = 1,n_back - thisind = LBFGSm - I + 1 - LBFGSalp(thisind) = LBFGSrho(thisind)*smartdotproduct(LBFGSs(1:N,thisind),LBFGSq,doefunc) - !call print(LBFGSy(1:N,thisind)) - LBFGSq = LBFGSq - LBFGSalp(thisind)*LBFGSy(1:N,thisind) - end do - if (n_iter == 1) then - LBFGSz = apply_precon(LBFGSq,pr,doefunc,k_out=k_out) - else - LBFGSz = apply_precon(LBFGSq,pr,doefunc,init=LBFGSbuf1,k_out=k_out) - end if - LBFGSbuf1 = LBFGSz - do I = 1,n_back - thisind = LBFGSm - n_back + I - LBFGSbet(thisind) = LBFGSrho(thisind)*smartdotproduct(LBFGSy(1:N,thisind),LBFGSz,doefunc) - LBFGSz = LBFGSz + LBFGSs(1:N,thisind)*(LBFGSalp(thisind) - LBFGSbet(thisind)) - end do - s = -LBFGSz - elseif (doFD) then - - call gethessian(x,am_data,FDHess) - !call writemat(FDHess,'densehess' // n_iter) - s = -g - call dgesv(size(x),1,FDHess,size(x),IPIV,s,size(x),INFO) - else - - s = -pg - - end if - - dirderivvec(n_iter) = smartdotproduct(g,s,doefunc) - dotpgout = -dirderivvec(n_iter)/(norm(g)*norm(s)) - - if (dirderivvec(n_iter) > 0) then - call print('Problem, directional derivative of search direction = '// dirderivvec(n_iter)) - if(doLBFGS) then - call print('Restarting LBFGS') - LBFGScount = 0 - end if - abortcount = abortcount + 1 - if (abortcount >= 5) then - call print(' Extended Minim aborted due to multiple bad search directions, possibly reached machine precision') - call print(' |df|^2 = '// normsqgrad // ', tolerance = ' // convergence_tol // ' total linesearch iterations = '// total_ls_count) - - !call writehessian(x,am_data,'outfinal') - exit - end if - cycle - else - if(doLBFGS) then - LBFGScount = LBFGScount + 1 - end if - abortcount = 0 - end if - !initial guess of alpha - alpha = init_alpha(alpvec,dirderivvec,n_iter) - - if(n_iter == 1 .and. (doCG .or. doSD)) then - alpha = calc_amax(s,pr,doefunc) - elseif (doLBFGS .and. (pr%precon_id == 'C1' .or. pr%precon_id == 'LJ')) then - alpha = 1.0 - else - alpha = init_alpha(alpvec,dirderivvec,n_iter) - if (pr%precon_id == 'ID') then - alpha = alpha*2.0 - end if - end if - - gold = g - amax = calc_amax(s,pr,doefunc,infoverride) - call print('Beginning linesearch, initial alpha = ' //alpha// ', alpha_max = ' //amax ,PRINT_VERBOSE) - if (doLSbasic) then - alpha = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,am_data,dirderivvec(n_iter),this_ls_count,amaxin=amax) - !call print('moo1') - elseif (doLSbasicpp) then - alpha = linesearch_basic_pp(x,s,f,alpha,func,doefunc,am_data,dirderivvec(n_iter),this_ls_count) - !call print('moo2') - elseif (doLSstandard) then - alpha = linesearch_standard(x,s,f,g,local_energy,alpha,func,doefunc,am_data,dirderivvec(n_iter),this_ls_count,amaxin=amax) - !call print('moo2') - elseif (doLSMoreThuente) then - alpha = linesearch_morethuente(x,s,f,local_energy,alpha,func,doefunc,am_data,dirderivvec(n_iter),this_ls_count,amaxin=amax) - elseif (doLSunit) then - alpha = 1.0 - call system_timer("preconminim/func") - f = func_wrapper(func,x+s,am_data,doefunc=doefunc) - call system_timer("preconminim/func") - elseif (doLSnone) then - !do nothing - this_ls_count = 0 - end if - total_ls_count = total_ls_count + this_ls_count - alpvec(n_iter) = alpha - - xold = x - if (alpha < 10.0_dp**(-14) ) then - call print(' Extended Minim aborted due to being unable to find a step along the given descent direction, probably your dE is not accurate else extremely badly conditioned') - call print(' |df|^2 = '// normsqgrad // ', tolerance = ' // convergence_tol // ' total linesearch iterations = '// total_ls_count) - exit - end if - x = x + alpha*s - - elseif (doDLLBFGS .or. doSHLBFGS .or. doSHLSR1 .or. doSHFD ) then - if (n_iter == 1) then - call system_timer("preconminim/func") -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - f = func_wrapper(func,x,am_data,local_energy,g,doefunc=doefunc) - normsqgrad = smartdotproduct(g,g,doefunc) - TRDelta = 1.0 - call build_precon(pr,am_data) -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("preconminim/func") - call print(trim(method)//" iter = 0 f = "//f// ' |g|^2 = '// normsqgrad,PRINT_NORMAL) - end if - n_back = min(LBFGSm,LBFGScount) - - if (doSHLBFGS) then - s = steihaug(x,g,pr,TRDelta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr,doBFGS=.true.) - elseif (doSHLSR1) then - s = steihaug(x,g,pr,TRDelta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr,doSR1=.true.) - elseif (doSHFD) then - call gethessian(x,am_data,FDHess) - s = steihaug(x,g,pr,TRDelta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr,doFD=.true.,FDhess=FDHess) - elseif (doDLLBFGS) then - s = LBFGSdogleg(x,g,pr,TRDelta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr) - end if - xcand = x + s - normsqs = Pdotproduct(s,s,pr,doefunc) - - call system_timer("preconminim/func") -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - fcand = func_wrapper(func,xcand,am_data,local_energycand,gcand,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("preconminim/func") - !call print(f // ' '//fcand) - if (doDLLBFGS .or. doSHLBFGS) then - TRBs = calc_LBFGS_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,s,pr,doefunc) - elseif (doSHLSR1) then - TRBs = calc_LSR1_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,s,pr,doefunc) - elseif ( doSHFD) then - TRBs = smartmatmul(FDHess,s,doefunc) - end if - - TRared = calcdeltaE(doefunc,f,fcand,local_energy,local_energycand) - TRpred = -( smartdotproduct(g,s,doefunc) + 0.5*(smartdotproduct(s,TRBs,doefunc)) ) - TRrho = TRared/TRpred - - if (TRrho < 0) then - abortcount = abortcount+1 - else - abortcount = 0 - end if - - if (abortcount >= 15) then - call print(' Extended Minim aborted due to multiple bad trust region models, possibly reached machine precision') - exit - end if - - if (TRrho < 0.25) then - TRDelta = 0.25*TRdelta - else if (TRrho > 0.75 .and. abs(sqrt(normsqs) - TRDelta) < 10.0**(-2.0)) then - TRDelta = 2.0*TRDelta - end if - - if (TRrho > TReta) then - xold = x - gold = g - - x = xcand - f = fcand - local_energy = local_energycand - g = gcand - normsqgrad = smartdotproduct(g,g,doefunc) - call build_precon(pr,am_data) - - end if - - SR1doupdate = .false. - if (doSHLSR1) then - SR1testvec = g - gold - calc_LSR1_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,x-xold,pr,doefunc) - SR1testLHS = abs(smartdotproduct(x-xold,SR1testvec,doefunc)) - SR1testRHS = 10.0**(-8.0)*sqrt(Pdotproduct(x-xold,x-xold,pr,doefunc))*sqrt(Pdotproduct(SR1testvec,SR1testvec,pr,doefunc)) - if(SR1testLHS >= SR1testRHS) SR1doupdate = .true. - end if - - if (doLBFGS .or. doDLLBFGS .or. doSHLBFGS .or. SR1doupdate) then - - LBFGSs(1:N,1:(LBFGSm-1)) = LBFGSs(1:N,2:LBFGSm) - LBFGSy(1:N,1:(LBFGSm-1)) = LBFGSy(1:N,2:LBFGSm) - LBFGSdlr(1:(LBFGSm-1),1:(LBFGSm-1)) = LBFGSdlr(2:LBFGSm,2:LBFGSm) - - LBFGSs(1:N,LBFGSm) = x - xold - LBFGSy(1:N,LBFGSm) = g - gold - LBFGScount = LBFGScount + 1 - n_back = min(LBFGSm,LBFGScount) - do I = 1,n_back - thisind = LBFGSm - I + 1 - - LBFGSdlr(LBFGSm,thisind) = smartdotproduct(LBFGSs(1:N,LBFGSm),LBFGSy(1:N,thisind),doefunc) - LBFGSdlr(thisind,LBFGSm) = smartdotproduct(LBFGSs(1:N,thisind),LBFGSy(1:N,LBFGSm),doefunc) - if(allocated(LBFGSd)) deallocate(LBFGSd) - if(allocated(LBFGSl)) deallocate(LBFGSl) - allocate(LBFGSd(n_back,n_back)) - allocate(LBFGSl(n_back,n_back)) - LBFGSd = 0.0 - LBFGSl = 0.0 - do SR1I = 1,n_back - do SR1J = 1,n_back - if (SR1I == SR1J) LBFGSd(SR1I,SR1J) = LBFGSdlr(LBFGSm-n_back+SR1I,LBFGSm-n_back+SR1J) - if (SR1I > SR1J) LBFGSl(SR1I,SR1J) = LBFGSdlr(LBFGSm-n_back+SR1I,LBFGSm-n_back+SR1J) - end do - end do - end do - end if - - if ( normsqgrad < convergence_tol ) then - call print('Extended minim completed with |df|^2 = '// normsqgrad // ' < tolerance = ' // convergence_tol) - ! call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |df|^2 = '// normsqgrad// ' max(abs(df)) = '//maxval(abs(g))//' last alpha = '//alpha) - call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad // ' |s|^2 = ' //normsqs //' rho = ' // TRrho// ' Delta^2 = '// TRDelta**2) - exit - end if - - call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad // ' |s|^2 = ' //normsqs //' rho = ' // TRrho// ' Delta^2 = '// TRDelta**2,PRINT_NORMAL) - end if - - - if (n_iter >= max_steps) then - exit - end if - n_iter = n_iter+1 - - end do - - x_in = x - - end function preconminim - - function fdhmultiply(x,FDH_rows,FDH_H,FDH_diag) - - real(dp) :: x(:), FDH_H(:) - integer :: FDH_rows(:), FDH_diag(:) - real(dp) :: fdhmultiply(size(x)) - - integer :: N, I, NH, rowind, colind - - N = size(x) - NH = size(FDH_H) - fdhmultiply = 0.0 - - colind = 1 - do I = 1,NH - rowind = FDH_rows(I) - if (colind < N) then - if (I == FDH_diag(colind+1)) then - colind = colind+1 - end if - end if - fdhmultiply(rowind) = fdhmultiply(rowind) + FDH_H(I)*x(colind) - fdhmultiply(colind) = fdhmultiply(colind) + FDH_H(I)*x(rowind) - end do - - end function - - function LBFGSdogleg(x,g,pr,Delta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr) result(s) - - implicit none - - real(dp) :: x(:),g(:) - type(precon_data) :: pr - real(dp) :: Delta - integer :: doefunc - integer :: n_back - real(dp):: LBFGSs(:,:), LBFGSy(:,:), LBFGSdlr(:,:) - real(dp) :: s(size(x)) - - real(dp) :: deltak,gammak - real(dp) :: sqn(size(x)), ssd(size(x)), LBFGSl(n_back,n_back), LBFGSr(n_back,n_back), LBFGSrinv(n_back,n_back),LBFGSd(n_back,n_back), su(size(x)),Bg(size(x)) - integer :: N, INFO, IPIV(n_back), I, J, LBFGSm - real(dp) :: WORK(n_back), sunorm, sqnnorm,a,b,c,tau, Pg(size(x)) - - N = size(x) - deltak = pr%energy_scale - gammak = 1.0/deltak - LBFGSm = size(LBFGSs,dim=2) - - LBFGSr = 0.0 - LBFGSd = 0.0 - LBFGSl = 0.0 - LBFGSrinv = 0.0 - do I = 1,n_back - do J = 1,n_back - if (I <= J) LBFGSr(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) - if (I == J) LBFGSd(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) - if (I > J) LBFGSl(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) - end do - end do - - Bg = calc_LBFGS_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,g,pr,doefunc) - su = -(smartdotproduct(g,g,doefunc)/smartdotproduct(g,Bg,doefunc))*g - sunorm = sqrt(Pdotproduct(su,su,pr,doefunc)) - if (sunorm >= Delta) then - s = su*Delta/sunorm - else - LBFGSrinv = LBFGSr - if (n_back >= 1) then - call dgetrf(n_back,n_back,LBFGSrinv,n_back,IPIV,INFO) - call dgetri(n_back,LBFGSrinv,n_back,IPIV,WORK,n_back,INFO) - end if - sqn = -calc_LBFGS_Hk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSd,LBFGSrinv,gammak,g,pr,doefunc) - sqnnorm = sqrt(Pdotproduct(sqn,sqn,pr,doefunc)) - if (sqnnorm <= Delta) then - s = sqn - else - a = Pdotproduct(sqn-su,sqn-su,pr,doefunc) - b = 2.0*Pdotproduct(su,sqn-su,pr,doefunc) - c = Pdotproduct(su,su,pr,doefunc) - Delta**2.0 - tau = (-b + sqrt(b**2.0 -4.0*a*c))/(2.0*a) - s = su + tau*(sqn-su) - end if - end if - !call exit() - end function - - function steihaug(x,g,pr,Delta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr,doSR1,doBFGS,doFD,FDHess) result(s) - - implicit none - - real(dp) :: x(:),g(:) - type(precon_data) :: pr - real(dp) :: Delta - integer :: doefunc - integer :: n_back - real(dp):: LBFGSs(:,:), LBFGSy(:,:), LBFGSdlr(:,:) - logical, optional :: doSR1,doBFGS,doFD - real(dp), optional :: FDHess(:,:) - real(dp) :: s(size(x)) - real(dp) :: a,b,c,tau - - real(dp) :: alpn,alpd,betn,alp,bet,normzcand,normr - integer :: thisind,I,J,K,N,thisind2 - integer :: LBFGSm - real(dp) :: LBFGSd(n_back,n_back), LBFGSl(n_back,n_back) - real(dp) :: eps = 10.0**(-3) - real(dp) :: d(size(x)), Bd(size(x)), r(size(x)), z(size(x)) - real(dp) :: rtilde(size(x)) - real(dp) :: zcand(size(x)) - real(dp) :: LBFGSbufinterior(size(x)) - real(dp) :: deltak - logical :: first_cg - integer :: cg_iter_count - - LBFGSm = size(LBFGSs,dim=2) - N = size(x) - first_cg = .true. - - deltak=pr%energy_scale - !Extract submatrices of S^T*Y - LBFGSd = 0.0_dp - LBFGSl = 0.0_dp - do I = 1,n_back - do J = 1,n_back - if (I == J) LBFGSd(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) - if (I > J) LBFGSl(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) - end do - end do - - !Main Steihaug loop - z = 0.0_dp - r = -g - rtilde = apply_precon_gs(r,pr,doefunc,force_k=10) - d = rtilde - do - if(present(doSR1)) then - Bd = calc_LSR1_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,d,pr,doefunc) - elseif(present(doBFGS)) then - Bd = calc_LBFGS_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,d,pr,doefunc) - elseif(present(doFD)) then - BD = smartmatmul(FDhess,d,doefunc) - end if - alpd = smartdotproduct(d,Bd,doefunc) - if (alpd <= 0.0) then - a = Pdotproduct(d,d,pr,doefunc) - b = 2.0*Pdotproduct(z,d,pr,doefunc) - c = Pdotproduct(z,z,pr,doefunc) - Delta**2.0 - tau = (-b + sqrt(b**2.0 -4.0*a*c))/(2.0*a) - s = z + tau*d - exit - end if - alpn = smartdotproduct(r,rtilde,doefunc) - alp = alpn/alpd - zcand = z + alp*d - normzcand = sqrt(Pdotproduct(zcand,zcand,pr,doefunc)) - if (normzcand >= Delta) then - a = Pdotproduct(d,d,pr,doefunc) - b = 2.0*Pdotproduct(z,d,pr,doefunc) - c = Pdotproduct(z,z,pr,doefunc) - Delta**2.0 - tau = (-b + sqrt(b**2.0 -4.0*a*c))/(2.0*a) - s = z + tau*d - exit - end if - z = zcand - r = r - alp*Bd - normr = sqrt(Pdotproduct(r,r,pr,doefunc)) - if (normr < eps) then - s = z - exit - endif - rtilde = apply_precon_gs(r,pr,doefunc,force_k=20) - betn = smartdotproduct(r,rtilde,doefunc) - bet = betn/alpn - d = rtilde + bet*d - end do - end function - - function Pdotproduct(v1,v2,pr,doefunc) - - implicit none - - real(dp) :: v1(:),v2(:) - type(precon_data) :: pr - integer :: doefunc - real(dp) :: Pdotproduct - - real(dp) :: Pv(size(v2)) - - Pv = do_mat_mult_vec(pr,v2,doefunc) - - Pdotproduct = smartdotproduct(v1,Pv,doefunc) - end function - - function calc_LBFGS_Bk_mult_v(LBFGSs,LBFGSy,LBFGSl,LBFGSd,v,pr,doefunc) result(Bkv) - - implicit none - - real(dp) :: LBFGSs(:,:), LBFGSy(:,:), LBFGSl(:,:), LBFGSd(:,:), v(:) - type(precon_data) :: pr - integer :: doefunc - real(dp) :: Bkv(size(v)) -! - integer :: n_back - integer :: INFO - integer, allocatable :: IPIV(:) - real(dp), allocatable :: midmat(:,:), midvec(:) - n_back = size(LBFGSs,dim=2) - - Bkv = do_mat_mult_vec(pr,v,doefunc) - if (n_back>=1) then - allocate(IPIV(n_back*2)) - allocate(midmat(2*n_back,2*n_back),midvec(2*n_back)) - - midvec(1:n_back) = smartmatmul(transpose(LBFGSs),do_mat_mult_vec(pr,v,doefunc),doefunc) - midvec((n_back+1):) = smartmatmul(transpose(LBFGSy),v,doefunc) - - midmat(1:n_back,1:n_back) = smartmatmul(transpose(LBFGSs),do_mat_mult_vecs(pr,LBFGSs,doefunc),doefunc) - midmat((n_back+1):,1:n_back) = LBFGSl - midmat(1:n_back,(n_back+1):) = transpose(LBFGSl) - midmat((n_back+1):,(n_back+1):) = -LBFGSd - - call dgesv(n_back*2,1,midmat,n_back*2,IPIV,midvec,n_back*2,INFO) - - Bkv = Bkv - do_mat_mult_vec(pr,smartmatmul(LBFGSs,midvec(1:n_back),doefunc),doefunc) - smartmatmul(LBFGSy,midvec((n_back+1):),doefunc) - end if - - end function - - function calc_LBFGS_Hk_mult_v(LBFGSs,LBFGSy,LBFGSd,LBFGSrinv,gammak,v,pr,doefunc) result(Hkv) - - implicit none - -! real(dp) :: LBFGSs(:,:), LBFGSy(:,:), LBFGSd(:,:), LBFGSrinv(:,:), gammak, v(:) -! real(dp) :: Hkv(size(v)) -! type(precon_data) :: pr -! logical :: doefunc(:) -! -! integer :: n_back -! integer :: INFO -! real(dp), allocatable :: midmat(:,:), midvec(:) -! -! n_back = size(LBFGSs,dim=2) -! Hkv = apply_precon_gs(v,pr,doefunc,force_k=20) -! if (n_back>=1) then -! allocate(midmat(2*n_back,2*n_back),midvec(2*n_back)) -! midvec(1:n_back) = smartmatmul(transpose(LBFGSs),v,doefunc) -! midvec((n_back+1):2*n_back) = smartmatmul(transpose(LBFGSy),apply_precon_gs(v,pr,doefunc,force_k=20),doefunc) -! -! midmat = 0.0 -! midmat(1:n_back,1:n_back) = smartmatmul(transpose(LBFGSrinv),smartmatmul(LBFGSd + smartmatmul(transpose(LBFGSy),apply_precon_vecs(LBFGSy,pr,doefunc),doefunc),LBFGSrinv,doefunc),doefunc) -! midmat((n_back+1):,1:n_back) = -LBFGSrinv -! midmat(1:n_back,(n_back+1):) = -transpose(LBFGSrinv) -! -! midvec = smartmatmul(midmat,midvec,doefunc) -! -! Hkv = Hkv + smartmatmul(LBFGSs,midvec(1:n_back),doefunc) + apply_precon_gs(smartmatmul(LBFGSy,midvec((n_back+1):),doefunc),pr,doefunc,force_k=20) -! end if - real(dp) :: LBFGSs(:,:), LBFGSy(:,:), LBFGSd(:,:), LBFGSrinv(:,:), gammak, v(:) - real(dp) :: Hkv(size(v)) - type(precon_data) :: pr - integer :: doefunc - - integer :: I,J,n_back,thisind,N - real(dp), allocatable :: LBFGSq(:),LBFGSz(:),LBFGSalp(:),LBFGSbet(:),LBFGSrho(:) - - N = size(LBFGSs,dim=1) - n_back = size(LBFGSs,dim=2) - allocate(LBFGSq(N),LBFGSz(N),LBFGSbet(n_back),LBFGSalp(n_back),LBFGSrho(n_back)) - - do I =1,n_back - LBFGSrho(I) = 1.0/smartdotproduct(LBFGSs(1:N,I),LBFGSy(1:N,I),doefunc) - end do - LBFGSq = v - do I = 1,n_back - thisind = n_back - I + 1 - - LBFGSalp(thisind) = LBFGSrho(thisind)*smartdotproduct(LBFGSs(1:N,thisind),LBFGSq,doefunc) - LBFGSq = LBFGSq - LBFGSalp(thisind)*LBFGSy(1:N,thisind) - end do - - LBFGSz = apply_precon(LBFGSq,pr,doefunc) - - do I = 1,n_back - thisind = I - - LBFGSbet(thisind) = LBFGSrho(thisind)*smartdotproduct(LBFGSy(1:N,thisind),LBFGSz,doefunc) - LBFGSz = LBFGSz + LBFGSs(1:N,thisind)*(LBFGSalp(thisind) - LBFGSbet(thisind)) - end do - Hkv = LBFGSz - - end function - - function calc_LSR1_Bk_mult_v(LBFGSs,LBFGSy,LBFGSd,LBFGSl,v,pr,doefunc) result(Bkv) - - implicit none - - real(dp) :: LBFGSs(:,:), LBFGSy(:,:), LBFGSd(:,:), LBFGSl(:,:), v(:) - type(precon_data) :: pr - integer :: doefunc - real(dp) :: Bkv(size(v)) - - integer :: n_back, INFO - real(dp), allocatable :: midmat(:,:), midvec(:) - integer, allocatable :: IPIV(:) - - n_back = size(LBFGSs,dim=2) - Bkv = do_mat_mult_vec(pr,v,doefunc) - if (n_back >= 1) then - allocate(IPIV(n_back)) - allocate(midmat(n_back,n_back),midvec(n_back)) - midvec = smartmatmul(transpose(LBFGSy - do_mat_mult_vecs(pr,LBFGSs,doefunc)),v,doefunc) - midmat = LBFGSd + LBFGSl + transpose(LBFGSl) - smartmatmul(transpose(LBFGSs),do_mat_mult_vecs(pr,LBFGSs,doefunc),doefunc) - call dgesv(n_back,1,midmat,n_back,IPIV,midvec,n_back,INFO) - Bkv = Bkv + smartmatmul(LBFGSy-do_mat_mult_vecs(pr,LBFGSs,doefunc),midvec,doefunc) - end if - - end function - - function calc_amax(g,pr,doefunc,infoverride) - - - implicit none - - real(dp) :: g(:) - type(precon_data) :: pr - real(dp) :: calc_amax - real(dp), optional :: infoverride - integer :: doefunc - real(dp) :: P_amax, inf_amax - real(dp) :: infcoeff = 0.5 - - if (present(infoverride)) then - infcoeff = infoverride - end if - - P_amax = pr%length_scale/sqrt(pdotproduct(g,g,pr,doefunc)) - inf_amax = infcoeff/maxval(abs(g)) - - calc_amax = min(P_amax,inf_amax) - - end function - - !basic linear backtracking linesearch, relies on changing initial alpha to increase step size - function linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d0,n_iter_final,amaxin) - - implicit none - - real(dp) :: x(:) - real(dp) :: s(:) - real(dp), intent(inout) :: f - real(dp), intent(inout) :: g(:) - real(dp), intent(inout) :: local_energy(:) - real(dp) :: alpha - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - integer :: doefunc - character(len=1)::data(:) - real(dp) :: linesearch_basic - integer, optional, intent(out) :: n_iter_final - real(dp) , optional :: amaxin - - - integer,parameter :: ls_it_max = 1000 - real(dp),parameter :: C = 10.0_dp**(-4.0) - integer :: ls_it - real(dp) :: f1, f0, d0, g1(size(g)) - real(dp) :: amax - real(dp) :: local_energy0(size(local_energy)),local_energy1(size(local_energy)) - real(dp) :: deltaE,deltaE2 - - alpha = alpha*4.0 - if (present(amaxin)) then - amax = amaxin - else - amax = 4.1*alpha - end if - - if(alpha>amax) alpha = amax - - f0 = f - local_energy0 = local_energy - ls_it = 0 - do - - !f1 = func_wrapper(func,x+alpha*s,data,doefunc=doefunc) - - call system_timer("preconminim/linesearch_basic/func") -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - f1 = func_wrapper(func,x+alpha*s,data,local_energy1,g1,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("preconminim/linesearch_basic/func") - call print("linesearch_basic loop "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//alpha) - - deltaE = calcdeltaE(doefunc,f1,f0,local_energy1,local_energy0) - !call print(deltaE) - - - ls_it = ls_it + 1 - if ( deltaE < C*alpha*d0) then - - - exit - end if - - if(ls_it>ls_it_max) then - exit - end if - - alpha = alpha/4.0_dp - - if (alpha <1.0e-15) then - exit - end if - - end do - - call print("linesearch_basic returning "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//alpha) - - linesearch_basic = alpha - f = f1 - g = g1 - local_energy = local_energy1 - !linesearch_basic = 15.0 - if(present(n_iter_final)) n_iter_final = ls_it - - end function - - ! Backtracking linesearch with cubic min - function linesearch_basic_pp(x,s,f,alpha,func,doefunc,data,d0,n_iter_final,amaxin) - - implicit none - - real(dp) :: x(:) - real(dp) :: s(:) - real(dp) :: f - real(dp) :: alpha - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::func - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - end function func - end INTERFACE - integer, intent(in) :: doefunc - character(len=1)::data(:) - real(dp) :: linesearch_basic_pp - integer, optional, intent(out) :: n_iter_final - real(dp), optional :: amaxin - - integer,parameter :: ls_it_max = 1000 - real(dp),parameter :: C = 10.0_dp**(-4.0) - integer :: ls_it - real(dp) :: f1, f0, d0, d1, a1, acand - real(dp) :: g1(size(x)) - real(dp) :: amax - real(dp) :: deltaE - !real(dp) :: local_energy0(size(local_energy)),local_energy1(size(local_energy)) - - alpha = alpha*4.0 - if (present(amaxin)) then - amax = amaxin - if(alpha>amax) alpha = amax - else - amax = 100.0_dp*alpha - end if - - a1 = alpha - f0 = f - ls_it = 1 - do - - !f1 = func_wrapper(func,x+alpha*s,data,doefunc=doefunc) - - call system_timer("preconminim/linesearch_basic_pp/func") -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - f1 = func_wrapper(func,x+a1*s,data,gradient=g1,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("preconminim/linesearch_basic_pp/func") - call print("linesearch_basic_pp loop "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//a1) - - d1 = dot_product(g1,s) - !call print(alpha) - - if ( f1-f0 < C*a1*d0) then - exit - end if - - if(ls_it>ls_it_max) then - exit - end if - - ls_it = ls_it + 1 - acand = cubic_min(0.0_dp,f0,d0,a1,f1,d1) - !acand = quad_min(0.0_dp,a1,f0,f1,d0) - - !call print(a1 //' '// f0//' ' //f1// ' ' //d0) - !call print('a1=' // a1 // ' acand=' // acand) - - !if ( acand == 0.0_dp) acand = a1/4.0_dp - acand = max(0.1*a1, min(acand,0.8*a1) ) - a1 = acand - - !call print(a1) - - end do - - call print("linesearch_basic_pp returning "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = N/A '//' last alpha = '//a1) - - linesearch_basic_pp = a1 - f = f1 - if(present(n_iter_final)) n_iter_final = ls_it - end function - - - ! standard two stage lineseach from N&W - function linesearch_standard(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amaxin) - implicit none - real(dp) :: x(:) - real(dp) :: s(:) - real(dp), intent(inout) :: f - real(dp), intent(inout) :: g(:) - real(dp), intent(inout) :: local_energy(:) - real(dp) :: alpha - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - integer :: doefunc - character(len=1)::data(:) - real(dp) :: d - real(dp) :: linesearch_standard - integer, optional, intent(out) :: n_iter_final - real(dp), optional :: amaxin - - - integer, parameter :: ls_it_max = 20 - real(dp), parameter :: C1 = 10.0_dp**(-4.0) - real(dp), parameter :: C2 = 0.9 - real(dp) :: amax - real(dp), parameter :: amin = 10.0_dp**(-5.0) - - real(dp) :: f0, f1, ft, a0, a1, a2, at, d0, d1, dt - real(dp) :: flo, fhi, alo, ahi, dlo, dhi - integer :: ls_it - real(dp) :: g1(size(x)), gt(size(x)) - logical :: dozoom = .FALSE. - real (dp) :: deltaE,deltaE0, deltaET, deltaETlo - real(dp) :: local_energy0(size(local_energy)),local_energy1(size(local_energy)),local_energyT(size(local_energy)),local_energylo(size(local_energy)),local_energyhi(size(local_energy)) - - a0 = 0.0_dp - f0 = f - local_energy0 = local_energy - d0 = d - a1 = alpha - - - if (present(amaxin)) then - amax = amaxin - if(a1>amax) a1 = amax - else - amax = 100.0_dp*alpha - end if - - !begin bracketing - ls_it = 0 - do - - call system_timer("preconminim/linesearch_standard/func") -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - f1 = func_wrapper(func,x+a1*s,data,local_energy1,g1,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("preconminim/linesearch_standard/func") - - - ls_it = ls_it + 1 - call print("linesearch_standard bracket "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//a1) - - - d1 = smartdotproduct(s,g1,doefunc) - - deltaE = calcdeltaE(doefunc,f1,f,local_energy1,local_energy) - deltaE0 = calcdeltaE(doefunc,f1,f0,local_energy1,local_energy0) - - if ( deltaE > C1*a1*d .OR. (deltaE0 >= 0.0 .AND. ls_it > 1 )) then - dozoom = .TRUE. - alo = a0 - ahi = a1 - flo = f0 - local_energylo = local_energy0 - fhi = f1 - local_energyhi = local_energy1 - dlo = d0 - dhi = d1 - exit - end if - - if ( abs(d1) <= C2*abs(d) ) then - dozoom = .FALSE. - exit - end if - - if ( d1 >= 0.0_dp) then - alo = a1 - ahi = a0 - flo = f1 - local_energylo = local_energy1 - fhi = f0 - local_energyhi = local_energy0 - dlo = d1 - dhi = d0 - exit - end if - - if(ls_it>ls_it_max) then - call print('linesearch_standard Ran out of line search iterations in phase 1') - a1 = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amax) - ! *1 quantities will be copied into function arguments for return at end - f1 = f - g1 = g - local_energy1 = local_energy - n_iter_final = n_iter_final + ls_it - dozoom = .FALSE. - exit - end if - - if(a1 >= amax) then - call print('linesearch_standard Bracketing failed to find an interval, reverting to basic linesearch') - a1 = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amax) - ! *1 quantities will be copied into function arguments for return at end - f1 = f - g1 = g - local_energy1 = local_energy - n_iter_final = n_iter_final + ls_it - dozoom = .FALSE. - exit - end if - - a2 = min(a1 + 4.0*(a1-a0),amax) - a0 = a1 - a1 = a2 - - f0 = f1 - local_energy0 = local_energy1 - d0 = d1 - - - !call print(a1) - - end do - - - if ( dozoom ) then - - !ls_it = ls_it+1 - do - at = cubic_min(alo,flo,dlo,ahi,fhi,dhi) - - call system_timer("preconminim/linesearch_standard/func") -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - ft = func_wrapper(func,x+at*s,data,local_energyT,gt,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("preconminim/linesearch_standard/func") - - ls_it = ls_it + 1 - call print("linesearch_standard zoom "//" iter = "//ls_it//" f = "//ft// ' |g|^2 = '// normsq(gt)//' last alpha = '//at) - - deltaET = calcdeltaE(doefunc,ft,f0,local_energyT,local_energy0) - deltaETlo = calcdeltaE(doefunc,ft,flo,local_energyT,local_energylo) - - if ( deltaET > C1*at*d .OR. deltaETlo >= 0.0) then - - ahi = at - fhi = ft - local_energyhi = local_energyT - - else - dt = dot_product(gt,s) - - - if ( abs(dt) <= C2*abs(d) ) then - - a1 = at - f1 = ft - g1 = gt - local_energy1 = local_energyT - exit - - end if - - if ( dt*(ahi-alo) >= 0.0 ) then - - ahi = alo - fhi = flo - local_energyhi = local_energylo - - end if - - alo = at - flo = ft - local_energylo = local_energyT - - end if - - if (abs(ahi - alo) < amin) then - call print('Bracket got small without satisfying curvature condition') - - deltaET = calcdeltaE(doefunc,ft,f,local_energyT,local_energy) - if ( deltaET < C1*at*d) then - call print('Bracket lowpoint satisfies sufficient decrease, using that') - a1 = at - f1 = ft - g1 = gt - exit - else - call print('Bracket lowpoint no good, doing a step of basic linesearch with original initial inputs') - a1 = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amax) - f1 = ft - g1 = gt - n_iter_final = n_iter_final + ls_it - exit - end if - end if - - if(ls_it>ls_it_max) then - call print('Ran out of line search iterations in phase 2') - a1 = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amax) - f1 = f - g1 = g - local_energy1 = local_energy - n_iter_final = n_iter_final + ls_it - exit - end if - - - end do ! zoom loop - end if - - call print("linesearch_standard returning "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//a1) - - !call print('boo ' // ls_it) - n_iter_final = ls_it - linesearch_standard = a1 - f = f1 - local_energy = local_energy1 - g = g1 - end function linesearch_standard - - function linesearch_morethuente(x,s,finit,local_energy,alpha,func,doefunc,data,d,n_iter_final,amaxin) - implicit none - real(dp) :: x(:) - real(dp) :: s(:) - real(dp), intent(inout) :: finit - real(dp), intent(inout) :: local_energy(:) - real(dp) :: alpha - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - integer :: doefunc - character(len=1)::data(:) - real(dp) :: d - real(dp) :: linesearch_morethuente - integer, optional, intent(out) :: n_iter_final - real(dp), optional :: amaxin - - - integer, parameter :: ls_it_max = 20 - real(dp), parameter :: ftol = 10.0_dp**(-4.0) ! sufficient decrease - real(dp), parameter :: gtol = 0.9 ! curvature - real(dp), parameter :: xtol = 10.0_dp**(-5.0) ! bracket size - real(dp) :: amax - real(dp), parameter :: amin = 10.0_dp**(-10.0) - - - logical :: brackt - integer :: nfev,stage - real(dp) :: f, g, ftest, fm, fx, fxm, fy, fym, ginit, gtest, gm, gx, gxm, gy, gym, stx, sty, stmin, stmax, width, width1,stp - real(dp) :: f1,g1(size(x)),local_energy1(size(x)) - integer :: ls_it - real(dp), parameter :: xtrapl = 1.1_dp, xtrapu=4.0_dp, p5 = 0.5_dp, p66 = 0.66_dp - - - stp = alpha - stpmin = amin - if (present(amaxin)) then - stpmax = amaxin - if(stp>stpmax) stp = stpmax - else - stpmax = 100.0_dp*stp - end if - - - brackt = .false. - stage = 1 - nfev = 0 - ginit = d - gtest = ftol*d - width = stpmax-stpmin - width1 = width/p5 - - stx = 0.0_dp - fx = finit - gx = ginit - sty = 0.0_dp - fy = finit - gy = ginit - stmin = 0.0_dp - stmax = stp + xtrapu*stp - - ls_it = 0 - do - - ftest = finit + stp*gtest - - ls_it = ls_it + 1 - call system_timer("preconminim/linesearch_morethuente/func") -#ifndef _OPENMP - call verbosity_push_decrement() -#endif - f1 = func_wrapper(func,x+stp*s,data,local_energy1,gradient=g1,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - call system_timer("preconminim/linesearch_morethuente/func") - - f = calcE(doefunc,f1,local_energy1) - g = smartdotproduct(g1,s,doefunc) - - ftest = finit + stp*gtest - if (stage .eq. 1 .and. f .le. ftest .and. g .ge. 0.0_dp) stage = 2 - - if (brackt .and. (stp .le. stmin .or. stp .ge. stmax)) then - call print("Rounding errors in linesearch") - exit - end if - if (brackt .and. stmax-stmin .le. xtol*stmax) then - call print("Bracket too small") - exit - end if - if (stp .eq. stpmax .and. f .le. ftest .and. g .le. gtest) then - call print("Maximum stepsize reached") - exit - end if - if (stp .eq. stpmin .and. (f .gt. ftest .or. g .ge. gtest)) then - call print("Minimum stepsize reached") - exit - end if - - if (f .le. ftest .and. abs(g) .le. gtol*(-ginit)) exit - - if (stage .eq. 1 .and. f .le. fx .and. f .gt. ftest) then - - fm = f - stp*gtest - fxm = fx - stx*gtest - fym = fy - sty*gtest - gm = g - gtest - gxm = gx - gtest - gym = gy - gtest - - call cstep(stx,fxm,gxm,sty,fym,gym,stp,fm,gm,brackt,stmin,stmax) - - fx = fxm + stx*gtest - fy = fym + sty*gtest - gx = gxm + gtest - gy = gym + gtest - - else - - call cstep(stx,fx,gx,sty,fy,gy,stp,f,g,brackt,stmin,stmax) - - end if - - if (brackt) then - if (abs(sty-stx) .ge. p66*width1) stp = stx + p5*(sty-stx) - width1 = width - width = abs(sty-stx) - else - stmin = stp + xtrapl*(stp-stx) - stmax = stp + xtrapu*(stp-stx) - end if - - stp = max(stp,stpmin) - stp = min(stp,stpmax) - - if (brackt .and. (stp .le. stmin .or. stp .ge. stmax) .or. (brackt .and. stmax-stmin .le. xtol*stmax)) stp = stx - - call print(stx// ' '//sty// ' '//stp) - end do - finit = f - linesearch_morethuente = stp - end function - - subroutine cstep(stx,fx,dx,sty,fy,dy,stp,fp,dpp,brackt,stpmin,stpmax) - implicit none - - real(dp),intent(inout) :: stx,fx,dx,sty,fy,dy,stp,fp,dpp - logical, intent(inout) :: brackt - real(dp), intent(in) :: stpmin,stpmax - - integer :: info - real(dp), parameter :: p66 = 0.66 - logical :: bound - real(dp) :: sgnd,theta,s,gamm,p,q,r,stpc,stpq,stpf - - info = 0 - - if(brackt .and. (stp<=min(stx,sty) .or. stp>=max(stx,sty))) then - call print("cstep received mixed information about the bracketing") - return - end if - if (stpmax=0.0) then - call print("cstep didn't receive a descent direction") - !return - end if - - if (fp > fx) then - info = 1 - bound = .true. - theta = 3.0*(fx - fp)/(stp - stx) + dx + dpp - s = max(abs(theta),abs(dx),abs(dpp)) - gamm = s*sqrt((theta/s)**2.0 - (dx/s)*(dpp/s)) - if (stp .lt. stx) then - gamm = -gamm - end if - p = (gamm - dx) + theta - q = ((gamm - dx) + gamm) + dp - r = p/q - stpc = stx + r*(stp-stx) - stpq = stx + ((dx/((fx-fp)/(stp-stx)+dx))/2.0)*(stp-stx) - if( abs(stpc-stx) .lt. abs(stpq-stx)) then - stpf = stpc - else - stpf = stpc + (stpq-stpc)/2.0 - end if - brackt = .true. - elseif (sgnd<0.0) then - info = 2 - bound = .false. - theta = 3.0*(fx - fp)/(stp - stx) + dx + dpp - s = max( abs(theta),abs(dx),abs(dpp)) - gamm = s*sqrt((theta/s)**2.0 - (dx/s)*(dpp/s)) - if (stp .gt. stx) then - gamm = -gamm - end if - p = (gamm - dpp) + theta - q = ((gamm - dpp) + gamm) + dx - r = p/q - stpc = stp + r*(stx-stp) - stpq = stp + (dpp/(dpp-dx))*(stx-stp) - if( abs(stpc-stp) .gt. abs(stpq-stp)) then - stpf = stpc - else - stpf = stpq - end if - brackt = .true. - elseif (abs(dpp) .lt. abs(dx))then - info = 3 - bound = .true. - theta = 3.0*(fx - fp)/(stp - stx) + dx + dpp - s = max(abs(theta),abs(dx),abs(dpp)) - gamm = s*sqrt(max(0.0,(theta/s)**2.0 - (dx/s)*(dpp/s))) - if (stp .gt. stx) then - gamm = -gamm - end if - p = (gamm - dpp) + theta - q = (gamm + (dx-dpp)) + gamm - r = p/q - if(r .lt. 0.0 .and. gamm .ne. 0.0_dp) then - stpc = stp + r*(stx-stp) - elseif (stp > stx)then - stpc = stpmax - else - stpc = stpmin - end if - stpq = stp + (dpp/(dpp-dx))*(stx-stp) - if (brackt) then - if(abs(stpc-stp) .lt. abs(stpq-stp))then - stpf = stpc - else - stpf = stpq - end if - if(stp .gt. stx) then - stpf = min(stp+p66*(sty-stp),stpf) - else - stpf = max(stp+p66*(sty-stp),stpf) - end if - else - if(abs(stpc-stp) .gt. abs(stpq-stp)) then - stpf = stpc - else - stpf = stpq - end if - stpf = min(stpmax,stpf) - stpf = max(stpmin,stpf) - end if - else - info = 4 - bound = .false. - if (brackt) then - theta = 3.0*(fp-fy)/(sty - stp) + dy + dpp - s = max(abs(theta),abs(dy),abs(dpp)) - gamm = s*sqrt((theta/s)**2.0 - (dy/s)*(dpp/s)) - if (stp .gt. sty ) then - gamm = -gamm - end if - p = (gamm - dpp) + theta - q = ((gamm - dpp) + gamm) + dy - r = p/q - stpc = stp + r*(sty-stp) - stpf = stpc - elseif(stp.gt.stx)then - stpf = stpmax - else - stpf = stpmin - end if - end if - - if (fp .gt. fx) then - sty = stp - fy = fp - dy = dpp - else - if (sgnd .lt. 0.0) then - sty = stx - fy = fx - dy = dx - end if - stx = stp - fx = fp - dx = dpp - end if - - stpf = min(stpmax,stpf) - stpf = max(stpmin,stpf) - stp = stpf - - end subroutine - - function cubic_min(a0,f0,d0,a1,f1,d1) - implicit none - - real(dp) :: a0,f0,d0,a1,f1,d1 - real(dp) :: cubic_min - - real(dp) :: h1,h2 - - h1 = d0 + d1 - 3.0_dp*(f0-f1)/(a0-a1) - - if ( h1**2.0 - d0*d1 <= 10.0**(-10.0)*abs(a1-a0) ) then - - !call print ('Line search routine cubic_min failed, crit1, will do a linear backtracking (linminroutine=basic) step') - cubic_min = (a0 + a1)/2.0_dp - else - - h2 = sign(1.0_dp,a1-a0)*sqrt(h1**2.0 - d0*d1) - if ( abs(d1-d0+2.0*h2) <= 10.0**(-8.0)*abs(d1+h2-h1) ) then - !call print ('cubic min failed, crit2, will do a linear backtracking (linminroutine=basic) step') - cubic_min = (a0 + a1)/2.0_dp - else - cubic_min = a1 - (a1-a0)*((d1+h2-h1)/(d1-d0+2.0*h2)) - end if - end if - - end function cubic_min - - function quad_min(a1,a2,f1,f2,g1) - implicit none - - real(dp) :: a1, a2, f1, f2, g1 - real(dp) :: quad_min - - real(dp) :: ama2, x, y - - ama2 = (a1-a2)**2.0 - - x = (f2 - f1 + a1*g1 - a2*g1)/ama2 - y = (2.0_dp*a1*(f1 - f2) - g1*ama2)/ama2 - - quad_min = y/(2.0_dp*x) - - end function quad_min - - !function to choose initial guess of steplength - function init_alpha(alpvec,dirderivvec,n_iter) - - implicit none - - real(dp) :: alpvec(:) - real(dp) :: dirderivvec(:) - integer :: n_iter - integer :: touse,I - - real(dp) :: init_alpha - - if (n_iter > 1) then - touse = min(n_iter-1,5) - init_alpha = 0.0 - do I =1,touse - init_alpha = init_alpha+alpvec(n_iter-I)*dirderivvec(n_iter-I)/dirderivvec(n_iter-I+1) - end do - init_alpha = init_alpha/touse - else - init_alpha = 0.01_dp - end if - - - end function - - - recursive function apply_precon(g,pr,doefunc,init,res2,max_iter,init_k,max_sub_iter,k_out,force_k) result (ap_result) - - implicit none - - real(dp) :: g(:) !to apply to - type (precon_data) :: pr - integer :: doefunc - real(dp),optional :: init(size(g)) - real(dp),optional :: res2 - integer,optional :: max_iter - integer,optional :: init_k - integer,optional :: max_sub_iter - integer,optional,intent(out) :: k_out - integer,optional :: force_k - real(dp) :: ap_result(size(g)) - integer :: k_out_internal - - logical :: do_force_k - - real(dp) :: x(size(g)) - real(dp) :: r(size(g)) - real(dp) :: p(size(g)) - real(dp) :: Ap(size(g)) - real(dp) :: passx(size(g)) - real(dp) :: alpn,alpd,alp,betn,bet,betnold - - real(dp) :: my_res2 - integer :: my_max_iter, gs, my_max_sub - - integer :: k,subk - real(dp),parameter :: betnstop = 10.0_dp**(-10) - real(dp),parameter :: alpdstop = 10.0_dp**(-14) - real(dp),parameter :: alpdsubbstop = 10.0_dp**(-1) - - call system_timer("apply_precon") - - do_force_k = .false. - if(present(force_k)) then - do_force_k = .true. - end if - - subk = 0 - k = 0 - if ( present(init_k) ) k = init_k - - !call print(pr%mat_mult_max_iter) - gs = size(g) - my_res2 = optional_default(pr%res2,res2) - my_max_iter = optional_default(pr%mat_mult_max_iter,max_iter) - my_max_sub = optional_default(pr%max_sub,max_sub_iter) - if ( present(init) ) then - x = init - r = g - do_mat_mult_vec(pr,x,doefunc) - p = r - else - x = 0.0_dp - r = g - p = r - end if - - betn = smartdotproduct(r,r,doefunc) - !call print(p) - !call print(pr%preconrowlengths) - !call exit() - do - - Ap = do_mat_mult_vec(pr,p,doefunc) - - !call print(' ') - !call print(Ap) - alpn = smartdotproduct(r,r,doefunc) - alpd = smartdotproduct(p,Ap,doefunc) - - if (alpd <= alpdstop) then - if ( betn < alpdsubbstop) then - call print("Gave up inverting matrix due to lack of precision, result may be of some use though") - ap_result = x - else - call print("Gave up inverting matrix due to lack of precision, result was garbage returning input") - ap_result = g - end if - if(present(k_out)) k_out = k - exit - end if - alp = alpn/alpd - !call print(alp) - x = x + alp*p - r = r - alp*Ap - betnold = betn - betn = smartdotproduct(r,r,doefunc) - !Usual exit condition - if ( ((betn < my_res2 .and. k >= 10) .or. betn < my_res2 .and. betn > betnold) .and. .not. do_force_k ) then - ap_result = x - if(present(k_out)) k_out = k - exit - end if - - !Force iteration count search direction - if (do_force_k) then - if(k == force_k) then - ap_result = x - exit - endif - endif - - ! Safeguard on search direction - if (betn < betnstop ) then - ap_result = x - if(present(k_out)) k_out = k - exit - end if - - !CG is not converging -! if (betn>betnold) then -! ap_result= x -! if(present(k_out)) k_out = k -! call print("CG failed to invert the preconditioner and aborted with |r|^2 = " // betn) -! exit -! end if - - bet = betn/alpn - p = r + bet*p - k = k+1 - subk = subk + 1 - - if (subk >= my_max_sub) then - !call print("Restarting preconditioner inverter") - passx = x - ap_result = apply_precon(g,pr,doefunc,init=passx,res2=res2,max_iter=max_iter,init_k=k,max_sub_iter=my_max_sub,k_out=k_out_internal) - if (present(k_out)) then - k_out = k_out_internal - end if - exit - end if - - if (k >= my_max_iter) then - if ( betn < 10.0**(-1)) then - call print("Gave up inverting preconditioner afer "// k // " iterations of CG, result may be of some use though") - ap_result = x - else - call print("Gave up inverting preconditioner afer "// k // " iterations of CG, result was garbage returning input") - ap_result = g - end if - if(present(k_out)) then - k_out = k - end if - exit - end if - - - end do - - !call print(k) - call system_timer("apply_precon") - - end function apply_precon - - function apply_precon_gs(b,pr,doefunc,init,res2,max_iter,k_out,force_k) result (ap_result) - - real(dp) :: b(:) - type(precon_data) :: pr - integer :: doefunc - real(dp), optional :: init(:), res2 - integer, optional :: max_iter, k_out, force_k - real(dp) :: ap_result(size(b)) - - integer :: my_max_iter, N, I, J, thisind, k - real(dp) :: my_res2, scoeff, r2 - real(dp) :: x(size(b)), r(size(b)) - integer :: target_elements(3), row_elements(3) - real(dp) :: Y(3),T(3),C(3) - logical :: do_force_k - - N = size(b) - my_res2 = optional_default(pr%res2,res2) - my_max_iter = optional_default(pr%mat_mult_max_iter,max_iter) - - if ( present(init) ) then - if (size(init) == size(b)) then - x = init - else - call print("init vector of incorrect dimension") - endif - else - x = 0.0_dp - end if - - do_force_k = .false. - if(present(force_k)) then - do_force_k = .true. - end if - - k=0 - x(1:9) = b(1:9) - do - - do I = 1,size(pr%preconindices,DIM=2) - C = 0.0 - target_elements = (/ I*3-2+9, I*3-1+9, I*3+9 /) - - if (pr%multI) then - x(target_elements) = b(target_elements)/pr%preconcoeffs(1,I,1) - end if - !call print(pr%preconcoeffs(1,I,1)) - do J = 2,(pr%preconrowlengths(I)) - - thisind = pr%preconindices(J,I) - row_elements = (/ thisind*3-2+9, thisind*3-1+9, thisind*3+9/) - - if (pr%multI) then - - scoeff = pr%preconcoeffs(J,I,1) - - if(doefunc == E_FUNC_BASIC) then - x(target_elements) = x(target_elements) - scoeff*x(row_elements)/pr%preconcoeffs(1,I,1) - else - Y = -scoeff*x(row_elements)/pr%preconcoeffs(1,I,1) - C - T = x(target_elements) + Y - C = (T - x(target_elements)) - Y - x(target_elements) = T - endif - - endif - end do - end do - !call print(x) - !call exit() - k=k+1 - r = b - do_mat_mult_vec(pr,x,doefunc) - r2 = smartdotproduct(r,r,doefunc) - !call print(k // ' '// r2) - if(r2**2.0= my_max_iter) then - if ( r2 < 10.0**(-1)) then - call print("Gave up inverting preconditioner afer "// k // " iterations of GS, result may be of some use though") - ap_result = x - else - call print("Gave up inverting preconditioner afer "// k // " iterations of GS, result was garbage returning input") - ap_result = b - end if - if(present(k_out)) then - k_out = k - end if - exit - end if - end do - - end function - - function apply_precon_csi(b,pr,doefunc,init,res2,max_iter,iter_out,force_iter) result (ap_result) - - implicit none - - real(dp) :: b(:) - type(precon_data) :: pr - integer :: doefunc - real(dp), optional :: init(:), res2 - integer, optional :: max_iter, iter_out, force_iter - real(dp) :: ap_result(size(b)) - - integer :: iter = 1 - real(dp) :: ykp1(size(b)), yk(size(b)), ykm1(size(b)), zk(size(b)) - real(dp) :: omega, gamm, alpha, beta - - alpha = 0.0 - - do - zk = b - do_mat_mult_vec(pr,yk,doefunc) - gamm = 1.0 - ykp1 = omega*(yk - ykm1 + gamm*zk) + ykm1 - - end do - - ap_result = ykp1 - - end function - - function apply_precon_vecs(x,pr,doefunc) - - real(dp) :: x(:,:) - type(precon_data) :: pr - integer :: doefunc - real(dp) :: apply_precon_vecs(size(x,dim=1),size(x,dim=2)) - - integer :: I,M - M = size(x,dim=2) - apply_precon_vecs = 0.0_dp - do I = 1,M - apply_precon_vecs(1:,I) = apply_precon(x(1:,I),pr,doefunc) - end do - - end function - - function apply_precon_vecs_gs(x,pr,doefunc,force_k) - - real(dp) :: x(:,:) - type(precon_data) :: pr - integer :: doefunc - integer :: force_k - real(dp) :: apply_precon_vecs_gs(size(x,dim=1),size(x,dim=2)) - - integer :: I,M - M = size(x,dim=2) - apply_precon_vecs_gs = 0.0_dp - do I = 1,M - apply_precon_vecs_gs(1:,I) = apply_precon_gs(x(1:,I),pr,doefunc,force_k=force_k) - end do - - end function - - - - function do_mat_mult_vecs(pr,x,doefunc) - - real(dp) :: x(:,:) - type(precon_data) :: pr - integer :: doefunc - real(dp) :: do_mat_mult_vecs(size(x,dim=1),size(x,dim=2)) - - integer :: I,M - M = size(x,dim=2) - do_mat_mult_vecs = 0.0_dp - do I = 1,M - do_mat_mult_vecs(1:,I) = do_mat_mult_vec(pr,x(1:,I),doefunc) - end do - - end function - - function do_mat_mult_vec(pr,x,doefunc) - - implicit none - - real(dp) :: x(:) - type(precon_data) :: pr - integer :: doefunc - real(dp) :: do_mat_mult_vec(size(x)) - - integer :: I,J,thisind,K,L - real(dp) :: scoeff - real(dp) :: dcoeffs(6) - integer,dimension(3) :: target_elements, row_elements - real(dp) :: C(3), T(3), Y(3) - - do_mat_mult_vec = 0.0_dp - do_mat_mult_vec(1:9) = pr%cell_coeff*x(1:9) - - do I = 1,size(pr%preconindices,DIM=2) - - !call print(pr%preconindices(1:pr%preconrowlengths(I),I)) - target_elements = (/ I*3-2+9, I*3-1+9, I*3+9 /) - C = 0.0_dp - if (pr%preconrowlengths(I) >= 1) then - - do J = 1,(pr%preconrowlengths(I)) - - thisind = pr%preconindices(J,I) - row_elements = (/ thisind*3-2+9, thisind*3-1+9, thisind*3+9/) - !call print(target_elements) - - - if (pr%multI) then - !call print(target_elements) - !call print(row_elements) - !call print(I // ' ' // thisind) - !call exit() - scoeff = pr%preconcoeffs(J,I,1) - if(doefunc == E_FUNC_BASIC) then - do_mat_mult_vec(target_elements) = do_mat_mult_vec(target_elements) + scoeff*x(row_elements) - else - Y = scoeff*x(row_elements) - C - T = do_mat_mult_vec(target_elements) + Y - C = (T - do_mat_mult_vec(target_elements)) - Y - do_mat_mult_vec(target_elements) = T - endif - - elseif(pr%dense) then - - !call print(size(pr%preconcoeffs(J,I,1:))) - !call exit() - - dcoeffs(1) = pr%preconcoeffs(J,I,1) - dcoeffs(2) = pr%preconcoeffs(J,I,2) - dcoeffs(3) = pr%preconcoeffs(J,I,3) - dcoeffs(4) = pr%preconcoeffs(J,I,4) - dcoeffs(5) = pr%preconcoeffs(J,I,5) - dcoeffs(6) = pr%preconcoeffs(J,I,6) - - !dcoeffs(6) =0.0! pr%preconcoeffs(J,I,6) - - !call print(dcoeffs) - !call exit() - !call writevec(dcoeffs,'dcoeffs.dat') - !call writevec(do_mat_mult(target_elements),'t1.dat') - !call writevec(x(row_elements),'r1.dat') - do_mat_mult_vec(target_elements(1)) = do_mat_mult_vec(target_elements(1)) + dcoeffs(1)*x(row_elements(1)) - do_mat_mult_vec(target_elements(1)) = do_mat_mult_vec(target_elements(1)) + dcoeffs(2)*x(row_elements(2)) - do_mat_mult_vec(target_elements(1)) = do_mat_mult_vec(target_elements(1)) + dcoeffs(3)*x(row_elements(3)) - - do_mat_mult_vec(target_elements(2)) = do_mat_mult_vec(target_elements(2)) + dcoeffs(2)*x(row_elements(1)) - do_mat_mult_vec(target_elements(2)) = do_mat_mult_vec(target_elements(2)) + dcoeffs(4)*x(row_elements(2)) - do_mat_mult_vec(target_elements(2)) = do_mat_mult_vec(target_elements(2)) + dcoeffs(5)*x(row_elements(3)) - - do_mat_mult_vec(target_elements(3)) = do_mat_mult_vec(target_elements(3)) + dcoeffs(3)*x(row_elements(1)) - do_mat_mult_vec(target_elements(3)) = do_mat_mult_vec(target_elements(3)) + dcoeffs(5)*x(row_elements(2)) - do_mat_mult_vec(target_elements(3)) = do_mat_mult_vec(target_elements(3)) + dcoeffs(6)*x(row_elements(3)) - - !call writevec(do_mat_mult(target_elements),'t2.dat') - - !call exit() - - end if - end do - - else - do_mat_mult_vec(target_elements) = x(target_elements) - end if - end do - - end function - - function convert_mat_to_dense(pr) result(prout) - - type(precon_data) :: pr - type(precon_data) :: prout - - logical :: multI = .FALSE. - logical :: diag = .FALSE. - logical :: dense = .FALSE. - integer, allocatable :: preconrowlengths(:) - integer, allocatable :: preconindices(:,:) - real(dp), allocatable :: preconcoeffs(:,:,:) - character(10) :: precon_id - integer :: nneigh,mat_mult_max_iter,max_sub - real(dp) :: energy_scale,length_scale,cutoff,res2 - logical :: has_fixed = .FALSE. - - integer :: M,N - - prout%dense = .true. - prout%precon_id = "genericdense" - prout%nneigh = pr%nneigh - prout%mat_mult_max_iter = pr%mat_mult_max_iter - prout%max_sub = pr%max_sub - prout%energy_scale = pr%energy_scale - prout%length_scale = pr%length_scale - prout%cutoff = pr%cutoff - prout%res2 = pr%res2 - prout%has_fixed = pr%has_fixed - - M = size(pr%preconrowlengths) - allocate(prout%preconrowlengths(M)) - prout%preconrowlengths(1:M) = pr%preconrowlengths(1:M) - - M = size(pr%preconindices,dim=1) - N = size(pr%preconindices,dim=2) - allocate(prout%preconindices(M,N)) - prout%preconindices(1:M,1:N) = pr%preconindices(1:M,1:N) - - M = size(pr%preconcoeffs,dim=1) - N = size(pr%preconcoeffs,dim=2) - allocate(prout%preconcoeffs(M,N,6)) - prout%preconcoeffs = 0.0 - prout%preconcoeffs(1:M,1:N,1) = pr%preconcoeffs(1:M,1:N,1) - prout%preconcoeffs(1:M,1:N,4) = pr%preconcoeffs(1:M,1:N,1) - prout%preconcoeffs(1:M,1:N,6) = pr%preconcoeffs(1:M,1:N,1) - - end function - - function calcdeltaE(doefunc,f1,f0,le1,le0) - integer :: doefunc - real(dp) :: f1, f0 - real(dp) :: le1(:), le0(:) - - real(dp) :: sorted1(size(le1)),sorted0(size(le0)) - real(dp) :: calcdeltaE - - if (doefunc == E_FUNC_BASIC) then - calcdeltaE = f1 - f0 - elseif (doefunc == E_FUNC_KAHAN) then - calcdeltaE = KahanSum(le1 - le0) - elseif (doefunc == E_FUNC_DOUBLEKAHAN) then - sorted1 = qsort(le1-le0) - calcdeltaE = DoubleKahanSum(sorted1) - endif - end function - - function calcE(doefunc,f0,le0) - integer :: doefunc - real(dp) :: f0 - real(dp) :: le0(:) - - real(dp) :: sorted0(size(le0)) - real(dp) :: calcE - - if (doefunc == E_FUNC_BASIC) then - calcE = f0 - elseif (doefunc == E_FUNC_KAHAN) then - calcE = KahanSum(le0) - elseif (doefunc == E_FUNC_DOUBLEKAHAN) then - sorted0 = qsort(le0) - calcE = DoubleKahanSum(sorted0) - endif - end function - - - - function smartdotproduct(v1,v2,doefunc) - integer :: doefunc - real(dp) :: v1(:),v2(:) - - real(dp) :: vec(size(v1)),sorted(size(v1)) - real(dp) :: smartdotproduct - - if(size(v1) .ne. size(v2)) then - call print("Dot Product called with mismatching vector sizes, exiting") - call exit() - end if - - vec = v1*v2 - - if (doefunc == E_FUNC_BASIC) then - smartdotproduct = sum(vec) - elseif (doefunc == E_FUNC_KAHAN) then - smartdotproduct = KahanSum(vec) - elseif (doefunc == E_FUNC_DOUBLEKAHAN) then - sorted = qsort(vec) - smartdotproduct = DoubleKahanSum(sorted) - endif - - end function - - function smartmatmulmat(m1,m2,doefunc) result(prod) - - real(dp) :: m1(:,:), m2(:,:) - integer :: doefunc - real(dp) :: prod(size(m1,dim=1),size(m2,dim=2)) - - integer :: I,J,M,N - M = size(m1,dim=1) - N = size(m2,dim=2) - - do I = 1,M - do J = 1,N - prod(I,J) = smartdotproduct(m1(I,1:),m2(1:,J),doefunc) - end do - end do - end function - - function smartmatmulvec(m1,m2,doefunc) result(prod) - - real(dp) :: m1(:,:), m2(:) - integer :: doefunc - real(dp) :: prod(size(m1,dim=1)) - - integer :: I,M - !call print(size(m1,dim=1) // ' ' // size(m1,dim=2) // ' '// size(m2)) - - M = size(m1,dim=1) - do I = 1,M - prod(I) = smartdotproduct(m1(I,1:),m2,doefunc) - end do - end function - - function KahanSum(vec) - - real(dp) :: vec(:) - real(dp) :: KahanSum - - integer :: I,N - real(dp) :: C,T,Y - - N = size(vec) - - KahanSum = 0.0 - C = 0.0 - do I = 1,N - Y = vec(I) - C - T = KahanSum + Y - C = (T - KahanSum) - Y - KahanSum = T - end do - - end function - - function DoubleKahanSum(vec) - - real(dp) :: vec(:) - real(dp) :: DoubleKahanSum - - integer :: I,N - real(dp) :: C,T,Y,U,V,Z - - N = size(vec) - - DoubleKahanSum = 0.0 - C = 0.0 - do I = 1,N - Y = C + vec(I) - U = vec(I) - (Y - C) - T = Y + DoubleKahanSum - V = Y - (T - DoubleKahanSum) - Z = U + V - DoubleKahanSum = T + Z - C = Z - (DoubleKahanSum - T) - end do - - end function - - recursive function qsort( data ) result( sorted ) - real(dp), dimension(:), intent(in) :: data - real(dp), dimension(1:size(data)) :: sorted - if ( size(data) > 1 ) then - sorted = (/ qsort( pack( data(2:), abs(data(2:)) > abs(data(1)) ) ), & - data(1), & - qsort( pack( data(2:), abs(data(2:)) <= abs(data(1)) ) ) /) - else - sorted = data - endif - end function - - subroutine precongradcheck(x,func,dfunc,data) - real(dp) :: x(:) - INTERFACE - function func(x,data,local_energy) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp)::func - end function func - end INTERFACE - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - character(len=1) :: data(:) - - integer :: N, I, J, levels - real(dp) :: eps,initeps - real(dp) :: f1,f2,deltaE - real(dp), allocatable :: grads(:,:), le1(:),le2(:),xp(:),xm(:) - - initeps = 1.0 - levels = 10 - - - N = size(x) - allocate(grads(levels+1,N)) - allocate(le1( (size(x) - 9)/3)) - allocate(le2( (size(x) - 9)/3)) - allocate(xp(N)) - allocate(xm(N)) - grads(1,1:N) = dfunc(x,data) - do I = 1,N - - eps = initeps - do J = 1,levels - - call print(I // " of "//N// '; '//J // ' of ' //levels) - xp = x - xm = x - xp(I) = xp(I) + eps - xm(I) = xm(I) - eps - - f1 = func(xp,data,le1) - f2 = func(xm,data,le2) - - deltaE = calcdeltaE(E_FUNC_KAHAN ,f1,f2,le1,le2) - - grads(J+1,I) = deltaE/(2.0*eps) - - eps = eps/10.0 - end do - - end do - - call writemat(grads,'gradsGab.dat') - - end subroutine - - subroutine sanity(x,func,dfunc,data) - real(dp) :: x(:) - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - character(len=1) :: data(:) - - real(dp), allocatable :: output(:),le(:) - integer :: I - real(dp),parameter :: stepsize = 10**(-3.0) - integer :: N = 1000 - real(dp) :: g(size(x)) - real(dp) :: f - - g = dfunc(x,data) - - allocate(le( (size(x)-9)/3 )) - allocate(output(N)) - do I = 1,N - call print(I // ' of ' // N) - f = func(x-I*stepsize*g,data,le) - output(I) = KahanSum(le) - end do - - call writevec(output,'sanity.dat') - - - end subroutine - - function infnorm(v) - - real(dp) :: v(:) - - real(dp) :: infnorm, temp - integer :: l, I - - l = size(v) - - temp = abs(v(1)) - do I = 2,l - if ( abs(v(I)) > temp ) temp = v(I) - end do - - infnorm = temp - - end function - - ! utility function to dump a vector into a file (for checking,debugging) - subroutine writevec(vec,filename) - real(dp) :: vec(:) - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) vec - close(outid) - - end subroutine - - subroutine writeveci(vec,filename) - integer :: vec(:) - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) vec - close(outid) - - end subroutine - - subroutine writemat(mat,filename) - real(dp) :: mat(:,:) - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) mat - close(outid) - - end subroutine - - subroutine writeprecon(precon,filename) - type(precon_data) :: precon - character(*) :: filename - - call writepreconcoeffs(precon,filename // 'coeffs') - call writepreconindices(precon,filename // 'indices') - call writepreconrowlengths(precon,filename // 'lengths') - end subroutine - - subroutine writepreconcoeffs(precon,filename) - type(precon_data) :: precon - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) precon%preconcoeffs - close(outid) - - end subroutine - - subroutine writepreconindices(precon,filename) - type(precon_data) :: precon - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) precon%preconindices - close(outid) - - end subroutine - - subroutine writepreconrowlengths(precon,filename) - type(precon_data) :: precon - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) precon%preconrowlengths - close(outid) - - end subroutine - - subroutine writeLBFGS(LBFGSs,LBFGSy,n_back,filename) - real(dp):: LBFGSs(:,:), LBFGSy(:,:) - integer :: n_back - character(*) :: filename - integer :: outid1 = 10 - integer :: outid2 = 11 - integer :: M - M = size(LBFGSs,dim=2) - - open(unit=outid1,file=(filename//'s'),action="write",status="replace") - write(outid1,*) LBFGSs(1:,(M-n_back+1):) - close(outid1) - - open(unit=outid2,file=(filename//'y'),action="write",status="replace") - write(outid2,*) LBFGSy(1:,(M-n_back+1):) - close(outid2) - - - - end subroutine - - function precondimer(x_in,v_in,func,dfunc,build_precon,pr,method,convergence_tol,max_steps,efuncroutine,LM, linminroutine, hook, hook_print_interval, am_data, status,writehessian,gethessian,infoverride) - - implicit none - - real(dp), intent(inout) :: x_in(:) !% Starting position - real(dp), intent(inout) :: v_in(:) !% Starting dimer orientation - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - INTERFACE - function dfunc(x,data) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp)::dfunc(size(x)) - end function dfunc - END INTERFACE - INTERFACE - subroutine build_precon(pr,am_data) - use system_module - import precon_data - type(precon_data),intent(inout) ::pr - character(len=1)::am_data(:) - end subroutine - END INTERFACE - type(precon_data):: pr - character(*), intent(in) :: method !% 'cg' for conjugate gradients or 'sd' for steepest descent - real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ - !% 'convergence_tol'. - integer, intent(in) :: max_steps !% Maximum number of 'cg' or 'sd' steps - integer::precondimer - character(*), intent(in), optional :: efuncroutine !% Control of the objective function evaluation - character(*), intent(in), optional :: linminroutine !% Name of the line minisation routine to use. - integer, optional :: LM - optional :: hook - INTERFACE - subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - end subroutine hook - end INTERFACE - integer, intent(in), optional :: hook_print_interval - character(len=1), optional, intent(inout) :: am_data(:) - integer, optional, intent(out) :: status - optional :: writehessian - INTERFACE - subroutine writehessian(x,data,filename) - use system_module - real(dp) :: x(:) - character(len=1)::data(:) - character(*) :: filename - end subroutine writehessian - end INTERFACE - optional :: gethessian - INTERFACE - subroutine gethessian(x,data,FDHess) - use system_module - real(dp),intent(in):: x(:) - character(len=1),intent(in)::data(:) - real(dp),intent(inout) :: FDHess(:,:) - end subroutine gethessian - end INTERFACE - real(dp), optional :: infoverride - - integer :: N,k,k2,k3,kmax,k2max - real(dp) :: h = 1e-3_dp - real(dp), parameter :: pi = 4.0_dp*datan(1.0_dp) - real(dp), parameter :: TOLvdefault = 10.0_dp**(-1) - - real(dp), allocatable :: x(:), F1(:), F2(:), F10(:), F20(:), v(:), vstar(:), Gd(:), s(:), sl2(:), Gv(:), Gvp(:), Gx(:), Gxp(:), Gdl2(:), Gvpold(:), Gxpold(:), Gs(:), Qx(:) - real(dp), allocatable :: local_energy1(:),local_energy2(:),local_energy10(:),local_energy20(:),alpvec(:),dirderivvec(:) - real(dp) :: alpha_x,crit,avn,dC,delE,e1,e10,e2,e20,lam,res_v,res_v_rot,res_x,rotC,traC,TOLv,dt - logical :: rotationfailed, totalfailure - - logical :: doLSbasic, doLSstandard - integer :: doefunc - - logical :: noimprove - real(dp) :: res_x_hist(5) = 1000.0_dp - - integer :: neval - - alpha_x = 0.01 - rotC = 10.0_dp**(-3) - traC = 10.0_dp**(-3) - TOLv = TOLvdefault - - kmax = max_steps - k2max = 5 - - if ( present(linminroutine) ) then - call print('linmin options not currently supported by dimer') -! if (trim(linminroutine) == 'basic') then -! call print('Using basic backtracking linesearch') -! doLSbasic = .TRUE. -! elseif (trim(linminroutine) == 'standard') then -! call print('Using standard two-stage linesearch with cubic interpolation in the zoom phase, with bisection as backup') -! call print('Not recommended for dimer method!!!') -! doLSstandard = .TRUE. -! end if -! else -! doLSbasic = .true. - end if - - N = size(x_in) - - allocate(local_energy1((N-9)/3),local_energy2((N-9)/3),local_energy10((N-9)/3),local_energy20((N-9)/3)) - allocate(x(N),F1(N),F2(N),F10(N),F20(N),v(N),vstar(N),Gd(N),s(N),sl2(N),Gv(N),Gvp(N),Gx(N),Gxp(N),Gdl2(N),Gvpold(N),Gxpold(N),Qx(N),gs(N)) - - allocate(alpvec(max_steps)) - allocate(dirderivvec(max_steps)) - - - !open(1,file='dimerplot.dat',status='replace',access='stream',action='write') - - doefunc = E_FUNC_BASIC - if ( present(efuncroutine) ) then - if (trim(efuncroutine) == 'basic') then - doefunc = E_FUNC_BASIC - call print('Using naive summation of local energies') - elseif (trim(efuncroutine) == 'kahan') then - doefunc = E_FUNC_KAHAN -! allocate(local_energycand((size(x)-9)/3)) - call print('Using Kahan summation of local energies') - elseif (trim(efuncroutine) == 'doublekahan') then - doefunc = E_FUNC_DOUBLEKAHAN -! allocate(local_energycand((size(x)-9)/3)) - call print('Using double Kahan summation of local energies with quicksort') - end if - else - doefunc = E_FUNC_BASIC - call print('Using naive summation of local energies by default') - end if - x = x_in - v = v_in - !call random_number(d) - - avn = pi/4.0 - k = 0 - do - - call build_precon(pr,am_data) - v = v/sqrt(Pdotproduct(v,v,pr,doefunc)) - - call writeprecon(pr,'dimerpr') - - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - e1 = func_wrapper(func,x+h*v,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) - e2 = func_wrapper(func,x-h*v,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) - neval = neval + 2 -#ifndef _OPENMP - call verbosity_pop() -#endif - - Gxpold = Gxp - Gx = 0.5_dp*(F1 + F2) - - - if (k > 0) then - Gxp = apply_precon(Gx,pr,doefunc,init=Gxpold) - else - Gxp = apply_precon(Gx,pr,doefunc) - !call exit() - end if - res_x = sqrt(smartdotproduct(Gxp,Gx,doefunc)) - - res_x_hist(1:4) = res_x_hist(2:5) - res_x_hist(5) = res_x - - !call print(abs(sum(res_x_hist)/5.0_dp) ) - -! noimprove = .false. -! if ( abs(sum(res_x_hist)/5.0_dp - res_x) < 10.0_dp**(-2)) then -! noimprove = .true. -! end if -! -! if (noimprove) then -! call print("Residual does not seem to be improving, switching to simple dimer method") -! k = simpleprecondimer(x,v,h,func,am_data,build_precon,pr,doefunc,0.005_dp,0.005_dp) -! exit -! end if - - - - Gvpold = Gvp - Gv = (F1 - F2)/(2.0_dp*h) - if (k > 0) then - Gvp = apply_precon(Gv,pr,doefunc,init=Gvpold) - else - Gvp = apply_precon(Gv,pr,doefunc) - end if - - lam = smartdotproduct(Gv,v,doefunc) - Gd = Gvp - lam*v - Gdl2 = Gv - lam*v - res_v = sqrt(Pdotproduct(Gd,Gd,pr,doefunc)) - call print('precon_dimer n_iter = ' // k // ', res_x = ' // res_x // ', res_v = ' // res_v // ', lam = ' // lam //', alpha = '// alpha_x // ', nf = '//neval) - if (res_x < convergence_tol) then - call print('Precon Dimer exiting with translation residual = ' //res_x) - exit - end if - - - - rotationfailed = .false. - totalfailure = .false. - k2 = 0 - ! Do a rotation if necessary - do while (res_v > max(TOLv,res_x)) - - s = -Gd - sl2 = -Gdl2 - dC = smartdotproduct(s,sl2,doefunc) - - e10 = e1 - e20 = e2 - F10 = F1 - F20 = F2 - local_energy10 = local_energy1 - local_energy20 = local_energy2 - - - if (rotationfailed .eqv. .false.) then - - k3 = 0 - do - crit = -h*h*rotC*dC*avn - vstar = cos(avn)*v + sin(avn)*s - vstar = vstar/sqrt(Pdotproduct(vstar,vstar,pr,doefunc)) - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - e1 = func_wrapper(func,x+h*vstar,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - e2 = func_wrapper(func,x-h*vstar,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - - neval = neval + 2 - delE = calcdeltaE(doefunc,e1,e10,local_energy1,local_energy10) + calcdeltaE(doefunc,e2,e20,local_energy2,local_energy20) - call print("precon_dimer rotation inner, theta = " // avn // ", delE = "// delE//" crit = "//crit) - - ! call print(avn // ' '// delE // ' ' //crit//' '//norm(v-vstar)) - !call print(e2// ' '//e20) - - if (delE < crit) then - v = vstar - exit - end if - - if (abs(delE) < 10.0**(-12) .and. delE < 10.0**(-15)) then - rotationfailed = .true. - call print('Ran out of precision in objective based rotation') - exit - else - avn = avn/2.0_dp - end if - - end do - else - exit - end if - - if (rotationfailed .eqv. .false.) then - - Gvpold = Gvp; - Gv = (F1 - F2)/(2.0_dp*h) - Gvp = apply_precon(Gv,pr,doefunc,init=Gvpold) - - lam = smartdotproduct(Gv,v,doefunc) - Gd = Gvp - lam*v - Gdl2 = Gv - lam*v - res_v = sqrt(Pdotproduct(Gd,Gd,pr,doefunc)) - - end if - - call print('precon_dimer rotating, iter = '// k2 //',theta = '//avn// ',delE = ' //delE //',res_v = '//res_v) - k2 = k2 + 1 - if (res_v < TOLv .or. totalfailure .eqv. .true. .or. k2 > k2max) then - !call print(res_v // ' ' //k2) - exit - end if - - - end do - - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - e1 = func_wrapper(func,x+h*v,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - e2 = func_wrapper(func,x-h*v,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - - neval = neval + 2 - Gx = 0.5*(F1+F2) - Gxpold = Gxp - Gxp = apply_precon(Gx,pr,doefunc,init=Gxpold) - - gs = -Gx + 2.0*smartdotproduct(v,Gx,doefunc)*v - s = -Gxp + 2.0*smartdotproduct(v,Gx,doefunc)*v - dt = -smartdotproduct(gs,s,doefunc) - if (dt > 0) then - gs = -gs - dt = -dt - end if - - !alpha_x = 2.0*init_alpha(alpvec,dirderivvec,k) - alpha_x = 2.0*alpha_x - e10 = e1 - e20 = e2 - F10 = F1 - F20 = F2 - local_energy10 = local_energy1 - local_energy20 = local_energy2 - res_v_rot = res_v - k2 = 0 - do - - delE = dimerdelE(x+alpha_x*s,v,h,lam,x,Gx,pr,func,am_data,doefunc,e10,e20,local_energy10,local_energy20) - crit = dt*traC*alpha_x - - neval = neval + 2 - call print('precon_dimer translating, iter = '// k2 //', alpha = '//alpha_x// ', delE = ' //delE) - if (delE < crit + 10.0**(-14) .and. res_v < 10.0*res_v_rot) then - x = x + alpha_x*s - - exit - end if - alpha_x = alpha_x/2.0 - k2 = k2 + 1 - end do - - - - k = k + 1 - dirderivvec(k) = dt - alpvec(k) = alpha_x - - if ( k >= max_steps) then - exit - end if - end do - x_in = x - - end function - - function dimerdelE(x,v,h,lam,x0,gx0,pr,func,am_data,doefunc,e10,e20,local_energy10,local_energy20) result(delE) - - real(dp) :: x(:),v(:),x0(:),gx0(:) - type(precon_data) :: pr - real(dp) :: h,lam - character(len=1), intent(inout) :: am_data(:) - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - real(dp) :: delE - integer :: doefunc - - - real(dp) :: e10,e20,local_energy10(:),local_energy20(:) - real(dp) :: e1,e2,local_energy1(size(local_energy10)),local_energy2(size(local_energy20)) - - real(dp) :: Qx(size(x)) - real(dp) :: F1(size(x)), F2(size(x)) - - Qx = smartdotproduct(v,x-x0,doefunc)*v - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - e1 = func_wrapper(func,x+h*v,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) - e2 = func_wrapper(func,x-h*v,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - - delE = (calcdeltaE(doefunc,e1,e10,local_energy1,local_energy10) + calcdeltaE(doefunc,e2,e20,local_energy2,local_energy20))/2.0_dp & - -2.0*Pdotproduct(v,x-x0,pr,doefunc)*smartdotproduct(v,gx0,doefunc) - lam*Pdotproduct(Qx,Qx,pr,doefunc) - - ! Gv = (F1 - F2)/(2.0_dp*h) - ! if (k > 0) then - ! Gvp = apply_precon(Gv,pr,doefunc,init=Gvpold) - ! else - ! Gvp = apply_precon(Gv,pr,doefunc) - ! end if - - ! lam = smartdotproduct(Gv,v,doefunc) - ! Gd = Gvp - lam*v - ! res_v = sqrt(Pdotproduct(Gd,Gd,pr,doefunc)) - ! - end function - - function simpleprecondimer(x,v,h,func,am_data,build_precon,pr,doefunc,alpha_x,alpha_v) result(k) - - real(dp), intent(inout) :: x(:),v(:) - real(dp) :: h - INTERFACE - function func(x,data,local_energy,gradient) - use system_module - real(dp)::x(:) - character(len=1),optional::data(:) - real(dp), intent(inout),optional :: local_energy(:) - real(dp), intent(inout),optional :: gradient(:) - real(dp)::func - end function func - end INTERFACE - character(len=1), intent(inout) :: am_data(:) - INTERFACE - subroutine build_precon(pr,am_data) - use system_module - import precon_data - type(precon_data),intent(inout) ::pr - character(len=1)::am_data(:) - end subroutine - END INTERFACE - type(precon_data):: pr - integer :: doefunc - real(dp) :: alpha_x,alpha_v - - integer :: k,N - integer :: kmax = 1000 - real(dp) :: e1,e2,lam,res_x,res_v - - real(dp), allocatable :: F1(:), F2(:), F10(:), F20(:), vstar(:), Gd(:), s(:), sl2(:), Gv(:), Gvp(:), Gx(:), Gxp(:), Gdl2(:), Gvpold(:), Gxpold(:), Gs(:), Qx(:) - real(dp), allocatable :: local_energy1(:),local_energy2(:),local_energy10(:),local_energy20(:),alpvec(:),dirderivvec(:) - - N = size(x,1) - allocate(local_energy1((N-9)/3),local_energy2((N-9)/3)) - allocate(F1(N),F2(N),F10(N),F20(N),vstar(N),Gd(N),s(N),sl2(N),Gv(N),Gvp(N),Gx(N),Gxp(N),Gdl2(N),Gvpold(N),Gxpold(N),Qx(N),gs(N)) - - - k = 0 - do - call build_precon(pr,am_data) - v = v/sqrt(Pdotproduct(v,v,pr,doefunc)) - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - e1 = func_wrapper(func,x+v*h,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - -#ifndef _OPENMP - call verbosity_push_decrement(2) -#endif - e2 = func_wrapper(func,x-v*h,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) -#ifndef _OPENMP - call verbosity_pop() -#endif - - Gxpold = Gxp - Gx = 0.5_dp*(F1 + F2); - if (k > 1) then - Gxp = apply_precon(Gx,pr,doefunc,init=Gxpold) - else - Gxp = apply_precon(Gx,pr,doefunc) - end if - res_x = sqrt(smartdotproduct(Gxp,Gx,doefunc)) - - Gvpold = Gvp - Gv = (F1 - F2)/(2.0_dp*h) - if (k > 1) then - Gvp = apply_precon(Gv,pr,doefunc,init=Gvpold) - else - Gvp = apply_precon(Gv,pr,doefunc) - end if - - lam = smartdotproduct(Gv,v,doefunc) - Gd = Gvp - lam*v - Gdl2 = Gv - lam*v - res_v = sqrt(Pdotproduct(Gd,Gd,pr,doefunc)) - call print('n_iter = ' // k // ', res_x = ' // res_x // ', res_v = ' // res_v // ', lam = ' // lam //', alpha = '// alpha_x) - - v = v - alpha_v*Gvp - x = x - alpha_x*(Gxp - 2.0*smartdotproduct(v,Gx,doefunc)*v) - - - k = k + 1 - if (k>=kmax) then - exit - end if - end do - - end function - - subroutine printlikematlab(x) - real(dp) :: x(:) - integer :: vl - vl = size(x) - call print(reshape(x(10:vl),(/ 3 , (vl-9)/3 /))) - - end subroutine -end module minimization_module - diff --git a/src/libAtoms/nye_tensor.f95 b/src/libAtoms/nye_tensor.f95 deleted file mode 100644 index 96b0705bb6..0000000000 --- a/src/libAtoms/nye_tensor.f95 +++ /dev/null @@ -1,310 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Nye Tensor calculations from C. S. Hartley and Y. Mishin, Acta Mat. v. 53, p. 1313 (2005) - -module nye_tensor_module - use system_module, only : dp, print, PRINT_NERD, PRINT_VERBOSE, operator(//) - use units_module - use linearalgebra_module - use atoms_module - implicit none - private - - public :: calc_nye_tensor - -contains - subroutine calc_nye_tensor(at, ref_lat, alpha, G) - type(Atoms), intent(inout) :: at - type(Atoms), intent(inout) :: ref_lat - real(dp), intent(out) :: alpha(:,:,:) - real(dp), intent(out), target, optional :: G(:,:,:) - - real(dp), pointer :: G_p(:,:,:) - real(dp), allocatable :: Qplus(:,:,:) - integer, allocatable :: match_list(:,:) - integer, allocatable :: n_matches(:) - - integer, allocatable :: ref_nn_list(:) - real(dp), allocatable :: ref_nn_vec(:,:), ref_nn_vec_normalised(:,:) - integer, allocatable :: nn_list(:) - real(dp), allocatable :: nn_vec(:,:), nn_vec_normalised(:,:) - - integer :: ref_n_neighbours, l_n_neighbours, max_n_neighbours - integer :: i_at - - integer i_gamma, II, MM, i, j, k, m - real(dp), allocatable :: Delta_G(:,:,:) - real(dp), allocatable :: Delta_G_vec(:) - real(dp) :: A(3,3,3) - real(dp) :: eps(3,3,3) - - call calc_connect(ref_lat) - call calc_connect(at) - - max_n_neighbours = 0 - do i_at = 1, at%N - l_n_neighbours = n_neighbours(at, i_at) - if (l_n_neighbours > max_n_neighbours) max_n_neighbours = l_n_neighbours - end do - call print('max_n_neighbours='//max_n_neighbours, PRINT_VERBOSE) - - if (.not.present(G)) then - allocate(G_p(3,3,at%N)) - else - G_p => G - endif - allocate(Qplus(3,max_n_neighbours,at%N)) - allocate(match_list(max_n_neighbours,at%N)) - allocate(n_matches(at%N)) - allocate(Delta_G(3,3,max_n_neighbours)) - allocate(Delta_G_vec(max_n_neighbours)) - - call get_nn_list(ref_lat, 1, ref_n_neighbours, ref_nn_list, ref_nn_vec, ref_nn_vec_normalised) - call print('get_nn_list found ref_n_neighbours='//ref_n_neighbours, PRINT_VERBOSE) - - do i_at=1, at%N - call get_nn_list(at, i_at, l_n_neighbours, nn_list, nn_vec, nn_vec_normalised) - call print('get_nn_list found l_n_neighbours='//ref_n_neighbours//' i_at='//i_at, PRINT_VERBOSE) - - call find_lattice_correspondence(l_n_neighbours, nn_list, nn_vec, nn_vec_normalised, & - ref_n_neighbours, ref_nn_list, ref_nn_vec, ref_nn_vec_normalised, & - n_matches(i_at), match_list(:,i_at), Qplus(:,:,i_at), G_p(:,:,i_at)) - call print("atom i_at " // i_at, PRINT_NERD) - call print("n_matches " // n_matches(i_at) // " match_list " // match_list(1:n_matches(i_at),i_at), PRINT_NERD) - call print("Qplus", PRINT_NERD) - call print(Qplus(1:3,1:n_matches(i_at),i_at), PRINT_NERD) - call print("G", PRINT_NERD) - call print(G_p(1:3,1:3,i_at), PRINT_NERD) - end do - - eps = permutation_symbol() - - do i_at = 1, at%N - do i_gamma = 1, n_matches(i_at) - Delta_G(:,:,i_gamma) = G_p(:,:,match_list(i_gamma,i_at)) - G_p(:,:,i_at) - call print("Delta_G(:,:,"//i_gamma//")", PRINT_NERD) - call print(Delta_G(:,:,i_gamma), PRINT_NERD) - end do - do II = 1, 3 - do MM = 1, 3 - Delta_G_vec(1:n_matches(i_at)) = Delta_G(II,MM,1:n_matches(i_at)) - call print("II " // II // " MM " // MM, PRINT_NERD) - call print("Delta_G_vec " // Delta_G_vec, PRINT_NERD) - A(II,MM,1:3) = matmul(Qplus(1:3,1:n_matches(i_at),i_at), Delta_G_vec(1:n_matches(i_at))) - call print("A " // A(II, MM, 1:3), PRINT_NERD) - end do - end do - - alpha(:,:,i_at) = 0.0_dp - do j=1, 3 - do k=1, 3 - do m=1, 3 - do i=1, 3 - alpha(j,k,i_at) = alpha(j,k,i_at) - eps(j,i,m)*A(m,k,i) - end do - end do - end do - end do - - call print("alpha(:,:,"//i_at//")", PRINT_VERBOSE) - call print(alpha(1,:,i_at), PRINT_VERBOSE) - call print(alpha(2,:,i_at), PRINT_VERBOSE) - call print(alpha(3,:,i_at), PRINT_VERBOSE) - - end do - - if (.not. present(G)) then - deallocate(G_p) - endif - deallocate(match_list, Qplus) - deallocate(n_matches) - deallocate(Delta_G, Delta_G_vec) - end subroutine calc_nye_tensor - - subroutine find_lattice_correspondence(l_n_neighbours, nn_list, nn_vec, nn_vec_normalised, & - ref_n_neighbours, ref_nn_list, ref_nn_vec, ref_nn_vec_normalised, & - n_matches, match_list, Qplus, G) - integer, intent(in) :: l_n_neighbours - integer, intent(in) :: nn_list(:) - real(dp), intent(in) :: nn_vec(:,:), nn_vec_normalised(:,:) - integer, intent(in) :: ref_n_neighbours - integer, intent(in) :: ref_nn_list(:) - real(dp), intent(in) :: ref_nn_vec(:,:), ref_nn_vec_normalised(:,:) - integer, intent(out) :: n_matches - integer, intent(out) :: match_list(:) - real(dp), intent(out) :: Qplus(:,:), G(:,:) - - real(dp), allocatable :: P(:,:), Q(:,:) - real(dp) :: QTQ_inv(3,3) - - integer :: i_beta, i_gamma, i_gammap - integer :: match_i, t_n_matches - integer, allocatable :: t_match_list(:) - real(dp), allocatable :: t_match_length(:) - real(dp) :: smallest_angle - real(dp), allocatable :: angles(:,:) - integer :: save_match, i_gamma_best_match(1), i_match - - !real(dp) :: max_angle_dev = 27.0_dp*PI/180.0_dp - - allocate(angles(l_n_neighbours, ref_n_neighbours)) - allocate(t_match_list(ref_n_neighbours)) - allocate(t_match_length(ref_n_neighbours)) - - - ! calculate all angles between lat and ref neighbor vectors - do i_gamma = 1, l_n_neighbours - do i_beta = 1, ref_n_neighbours - angles(i_gamma, i_beta) = acos(sum(nn_vec_normalised(1:3,i_gamma)*ref_nn_vec_normalised(1:3,i_beta))) - end do - end do - - - ! for each lat vector i_gamma, find matching ref vector and save in match_list(i_gamma), save 0 if more than 1 ref. vector matches - do i_gamma = 1, l_n_neighbours - smallest_angle = 1.0e38_dp - n_matches = 0 ! ref. vector matches to this real neighbor vector - do i_beta=1, ref_n_neighbours - if (angles(i_gamma, i_beta) .feq. smallest_angle) then - n_matches = n_matches + 1 - else if (angles(i_gamma, i_beta) < smallest_angle) then - n_matches = 1 - match_i = i_beta - smallest_angle = angles(i_gamma, i_beta) - endif - end do - if (n_matches /= 1 .or. smallest_angle > 27.0_dp*PI/180.0_dp) then - match_list(i_gamma) = 0 - else - match_list(i_gamma) = match_i - endif - end do - - ! look for multiple lat vectors that match same ref vector, and pick best length match - zero other entries of match_list - do i_gamma = 1, l_n_neighbours - if (match_list(i_gamma) == 0) cycle - t_n_matches = 0 - do i_gammap = 1, l_n_neighbours - if (match_list(i_gammap) == match_list(i_gamma)) then - t_n_matches = t_n_matches + 1 - t_match_list(t_n_matches) = i_gammap - t_match_length(t_n_matches) = norm(nn_vec(:,i_gammap)) - endif - end do - if (t_n_matches > 1) then - i_gamma_best_match = minloc(abs(t_match_length-norm(ref_nn_vec(:,match_list(i_gamma))))) - save_match = match_list(i_gamma) - match_list(t_match_list(1:t_n_matches)) = 0 - match_list(i_gamma_best_match(1)) = save_match - endif - end do - - ! fill in P and Q vectors for matched pairs - n_matches = count(match_list(1:l_n_neighbours) /= 0) - call print('find_lattice_correspondence found l_n_neighbours='//l_n_neighbours//' n_matches='//n_matches, PRINT_VERBOSE) - allocate(P(n_matches,3)) - allocate(Q(n_matches,3)) - i_match = 0 - do i_gamma=1, l_n_neighbours - if (match_list(i_gamma) /= 0) then - i_match = i_match + 1 - Q(i_match,1:3) = nn_vec(1:3,i_gamma) - P(i_match,1:3) = ref_nn_vec(1:3,match_list(i_gamma)) - endif - end do - - ! compute Qplus and G - QTQ_inv(1:3,1:3) = matmul(transpose(Q(1:n_matches,1:3)),Q(1:n_matches,1:3)) - call inverse(QTQ_inv) - Qplus(1:3,1:n_matches) = matmul(QTQ_inv(1:3,1:3),transpose(Q(1:n_matches,1:3))) - G(1:3,1:3) = matmul(Qplus(1:3,1:n_matches), P(1:n_matches,1:3)) - - call print("P", PRINT_NERD) - call print(P, PRINT_NERD) - call print("Q", PRINT_NERD) - call print(Q, PRINT_NERD) - call print("Q - P", PRINT_NERD) - call print((Q - P), PRINT_NERD) - call print("Q.G - P", PRINT_NERD) - call print(((Q.mult.G) - P), PRINT_NERD) - call print("rms Q-P " // sum((Q-P)**2), PRINT_NERD) - call print("rms Q.G-P " // sum(((Q.mult.G)-P)**2), PRINT_NERD) - - deallocate(P,Q) - - deallocate(angles) - deallocate(t_match_list) - deallocate(t_match_length) - - ! make output match_list(), which contains indices of atoms for each matched bond - allocate(t_match_list(l_n_neighbours)) - i_gammap = 0 - do i_gamma = 1, l_n_neighbours - if (match_list(i_gamma) /= 0) then - i_gammap = i_gammap + 1 - t_match_list(i_gammap) = nn_list(i_gamma) - end if - end do - match_list = 0 - match_list(1:n_matches) = t_match_list(1:n_matches) - deallocate(t_match_list) - end subroutine find_lattice_correspondence - - subroutine get_nn_list(at, i_at, l_n_neighbours, nn_list, nn_vec, nn_vec_normalised) - type(Atoms), intent(inout) :: at - integer, intent(in) :: i_at - integer, intent(out) :: l_n_neighbours - integer, allocatable, intent(inout) :: nn_list(:) - real(dp), allocatable, intent(inout) :: nn_vec(:,:), nn_vec_normalised(:,:) - - real(dp) :: nn_v(3), nn_v_normalised(3) - integer i_neigh - - l_n_neighbours = n_neighbours(at, i_at) - - if (.not. allocated(nn_list) .or. l_n_neighbours > size(nn_list)) then - if (allocated(nn_list)) deallocate(nn_list) - allocate(nn_list(l_n_neighbours)) - if (allocated(nn_vec)) deallocate(nn_vec) - allocate(nn_vec(3,l_n_neighbours)) - if (allocated(nn_vec_normalised)) deallocate(nn_vec_normalised) - allocate(nn_vec_normalised(3,l_n_neighbours)) - endif - - do i_neigh = 1, l_n_neighbours - nn_list(i_neigh) = neighbour(at, i_at, i_neigh, diff = nn_v, cosines = nn_v_normalised) - nn_vec(:, i_neigh) = nn_v - nn_vec_normalised(:, i_neigh) = nn_v_normalised - end do - - end subroutine get_nn_list - -end module nye_tensor_module diff --git a/src/libAtoms/partition.f95 b/src/libAtoms/partition.f95 deleted file mode 100644 index 5453edccad..0000000000 --- a/src/libAtoms/partition.f95 +++ /dev/null @@ -1,413 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X This module written by Marco Caccin -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module partition_module - - use iso_c_binding - use error_module - use system_module, only: dp, operator(//) - use atoms_types_module - use atoms_module - use connection_module - use clusters_module, only: HYBRID_ACTIVE_MARK - use ringstat_module, only: distance_map - - implicit none - private - - public :: kway_partition_atoms, partition_qm_list - - interface - function METIS_SetDefaultOptions(options) bind(c) - use iso_c_binding - integer(C_INT), dimension(0:40) :: options - end function METIS_SetDefaultOptions - - function METIS_PartGraphKway(nvtxs, ncon, xadj, adjncy, vwgt, vsize, & - adjwgt, nparts, tpwgts, ubvec, options, objval, part) bind(c) - use iso_c_binding - integer(C_INT) :: nvtxs, ncon, nparts, objval - integer(C_INT), dimension(*) :: xadj, adjncy, part - type(C_PTR) :: vwgt, vsize, adjwgt, tpwgts, ubvec - integer(C_INT), dimension(0:40) :: options - integer(C_INT) :: METIS_PartGraphKway - end function METIS_PartGraphKway - end interface - - ! There is no METIS Fortran API, so we have to declare constants. The following are valid for versions >= 5. - ! Tested with 5.1.0_3, Nov 2014 - integer(C_INT), parameter :: METIS_OPTION_PTYPE=0, METIS_OPTION_OBJTYPE=1, METIS_OPTION_CTYPE=2, METIS_OPTION_IPTYPE=3, & - METIS_OPTION_RTYPE=4, METIS_OPTION_DBGLVL=5, METIS_OPTION_NITER=6, METIS_OPTION_NCUTS=7, METIS_OPTION_SEED=8, & - METIS_OPTION_NO2HOP=9, METIS_OPTION_MINCONN=10, METIS_OPTION_CONTIG=11, METIS_OPTION_COMPRESS=12, & - METIS_OPTION_CCORDER=13, METIS_OPTION_PFACTOR=14, METIS_OPTION_NSEPS=15, METIS_OPTION_UFACTOR=16, & - METIS_OPTION_NUMBERING=17, METIS_OPTION_HELP=18, METIS_OPTION_TPWGTS=19, METIS_OPTION_NCOMMON=20, & - METIS_OPTION_NOOUTPUT=21, METIS_OPTION_BALANCE=22, METIS_OPTION_GTYPE=23, METIS_OPTION_UBVEC=24 - -contains - -! subroutine atoms_to_metis_graph(at, mask, error, filename) -! implicit none -! type(Atoms), intent(in) :: at -! integer :: distance_matrix(at%N, at%N) -! integer :: i, j -! integer :: nnodes, nedges -! logical, intent(in), optional :: mask(at%N) -! integer, intent(out), optional :: error -! character(len=*), intent(in) :: filename -! character(len=STRING_LENGTH), dimension(nnodes) :: lines -! character(len=STRING_LENGTH) :: tempstr - -! call distance_map(at, distance_matrix, mask, error) -! ! convert a bondhop distance matrix into lines of METIS graph file (line 1+1 := list of edges for node i) -! do i = 1, nnodes -! lines(i) = " " -! do j = 1, nnodes -! if (dist(i,j) == 1) then -! if (j>i) then -! nedges = nedges + 1 -! end if -! write( tempstr, '(i10)' ) j ! convert j to string -! lines(i) = trim(lines(i))//" "//trim(tempstr) ! append it to list of neighbours of i on the same line -! end if -! end do -! end do -! ! write the METIS graph file corresponding to at -! open(12, file=filename, status="replace", action="write") -! write(12,*) nnodes, nedges -! do i = 1, nnodes -! write(12,*) trim(lines(i)) -! end do -! close(12) -! end subroutine atoms_to_metis_graph - - - subroutine preprocess_atoms_to_csr_adjacency_matrix(at, nneightol, nedges) - implicit none - type(Atoms), intent(in) :: at - integer :: i - real(dp), intent(in) :: nneightol - integer, intent(out) :: nedges - type(Atoms) :: at_copy - - call atoms_copy_without_connect(at_copy, at) - at_copy%nneightol = nneightol - !% Use hysteretic connect so we can work with relative cutoffs - call calc_connect_hysteretic(at_copy, at_copy%nneightol, at_copy%nneightol) - - nedges = 0 - do i = 1, at%N - nedges = nedges + n_neighbours(at_copy, i) - end do - - call finalise(at_copy) - - end subroutine preprocess_atoms_to_csr_adjacency_matrix - - - subroutine atoms_to_csr_adjacency_matrix(at, nedges, xadj, adjncy) - implicit none - type(Atoms), intent(in) :: at - integer, intent(in) :: nedges - integer :: i, j, edge - integer :: nneighs, neigh_idx - integer(C_INT), intent(out) :: xadj(at%N+1), adjncy(2*nedges) - - edge = 0 - do i = 1, at%N - xadj(i) = edge - nneighs = n_neighbours(at, i) - do j = 1, nneighs - edge = edge + 1 - adjncy(edge) = neighbour(at, i, j) - end do - end do - xadj(at%N+1) = nedges - - end subroutine atoms_to_csr_adjacency_matrix - - - subroutine kway_partition_atoms(at, k, nneightol, part, objval, status) - - ! Generate a balanced and connected partition of an atomic configuration using METIS' PartGraphKway method. - ! INPUT Atoms object at : configuration to be partitioned - ! INPUT integer k : number of partitions - ! OUTPUT integer array part, size at%N : partition array, assigning each atom of at to part i \in [1,k] - - implicit none - type(Atoms), intent(in) :: at - integer, intent(in) :: k - real(dp), intent(in) :: nneightol - integer, intent(out), dimension(:) :: part - integer, intent(out) :: objval, status - - integer :: nedges - integer(C_INT) :: nvert, ncon, nparts, c_status, c_objval - type(C_PTR) :: vwgt, vsize, adjwgt, tpwgts, ubvec - integer(C_INT), allocatable :: options(:), adjncy(:), xadj(:) - -#ifdef HAVE_METIS - integer(C_INT), allocatable :: cpart(:) - - allocate(options(0:40)) - c_status = METIS_SetDefaultOptions(options) - options(:) = -1 - options(METIS_OPTION_NUMBERING) = 1 ! METIS_OPTION_NUMBERING: fortran indexing - options(METIS_OPTION_NCUTS) = 5 ! number of different partitionings to compute (then choose the best edgecut) - options(METIS_OPTION_CONTIG) = 1 ! forces contiguous partitions - - nvert = at%n - ncon = 1 - ! from at create csr adjacency matrix - call preprocess_atoms_to_csr_adjacency_matrix(at, nneightol, nedges) - allocate(adjncy(2*nedges), xadj(at%n + 1), cpart(at%n)) - call atoms_to_csr_adjacency_matrix(at, nedges, xadj, adjncy) - - ! perform partitioning using METIS - vwgt = C_NULL_PTR - vsize = C_NULL_PTR - adjwgt = C_NULL_PTR - tpwgts = C_NULL_PTR - ubvec = C_NULL_PTR - - c_status = METIS_PartGraphKway(nvert, ncon, xadj, adjncy, vwgt, vsize, adjwgt, nparts, & - tpwgts, ubvec, options, c_objval, part) - - ! Copy output - objval = c_objval - status = c_status - if (size(cpart) > size(part)) then - part(:) = cpart - else - call system_abort('size of part array ('//(size(part))//') insufficient to store results') - end if - - deallocate(options, adjncy, cpart) -#else - call system_abort('kway_partition_atoms requires HAVE_METIS=1 at compile time') -#endif - - end subroutine kway_partition_atoms - - function submatrix(matrix, mask) - ! select submatrix choosing only rows and columns in mask. only works for square matrices - implicit none - integer, intent(in) :: matrix(:,:) - logical, intent(in) :: mask(:) - integer, allocatable :: submatrix(:,:), my_mask(:) - integer :: i - - if (size(matrix(1,:)) /= size(matrix(:,1)) .or. size(matrix(1,:)) /= size(mask)) then - write(*,*) "Inconsistent input, submatrix function now exiting..." - end if - do i = 1, size(mask) - if (mask(i)) then - my_mask(i) = i - else - my_mask(i) = 0 - end if - end do - submatrix = matrix(pack(my_mask, my_mask > 0), pack(my_mask, my_mask > 0)) - end function submatrix - - - function costG(dm, part, idx, kappa) - ! Calculate 'free energy' of region idx using distance matrix dm and assignment assign - ! kappa measures the relative importance of surface and 1/diameter components of G (arbitrarily) - integer, intent(in), dimension(:,:) :: dm - integer, intent(in), dimension(:) :: part - integer, intent(in) :: idx - real(dp), intent(in), optional :: kappa - logical :: mask(size(part)) - integer, allocatable :: sub_dm(:,:) - real(dp) :: costG, surface_energy, r, k - integer :: i, j - - k = 1.0 - if(present(kappa)) k = kappa - - mask = (part == idx) - sub_dm = submatrix(dm, mask) - surface_energy = sum(sub_dm**2) - - if (size(shape(sub_dm)) == 1) then - r = 1.0E-6_dp - else - r = maxval(sub_dm) / real(count(mask), dp)**2 - end if - costG = surface_energy + k/r - - end function costG - - - subroutine connect2subconnects(connect, nodelist, part, sub1, sub2, nodelist1, nodelist2, cut_edges) - implicit none - integer, intent(in) :: connect(:,:), nodelist(:) - logical, intent(in) :: part(:) - integer, intent(out), allocatable :: sub1(:,:), sub2(:,:), nodelist1(:), nodelist2(:), cut_edges(:,:) - integer, allocatable :: cut_edges_temp(:,:) - integer, dimension(size(nodelist)) :: part_mask1, part_mask2 - integer :: i, j, k, ncuts - - ! FIXME compiler doesn't like logical comparison -! if ((size(connect(1,:) /= size(nodelist)) .or. size(nodelist) /= size(part) & -! .or. size(connect(1,:)) /= size(part)) then -! call system_abort('inconsistent sizes for connectivity matrix, nodelist and part') -! end if - - do i = 1, size(part) - if (part(i)) then - part_mask1(i) = i - part_mask2(i) = 0 - else - part_mask1(i) = 0 - part_mask2(i) = i - end if - end do - - ! slice the connectivity matrix - sub1 = connect(pack(part_mask1, part_mask1 > 0), pack(part_mask1, part_mask1 > 0)) - sub2 = connect(pack(part_mask2, part_mask2 > 0), pack(part_mask2, part_mask2 > 0)) - ! also return list of nodes for each new subgraph - nodelist1 = nodelist(pack(part_mask1, part_mask1 > 0)) - nodelist2 = nodelist(pack(part_mask2, part_mask2 > 0)) - - ! number of edges is the sum of upper triangle "1"s - ncuts = (sum(connect) - sum(sub1) - sum(sub2)) / 2 - write(*,*) "number of cut edges:", ncuts - allocate(cut_edges_temp(ncuts, 2)) - ! find edges that are missing from the two new subgraphs - k = 1 - do i = 1, size(connect(1,:)) - do j = i+1, size(connect(1,:)) - if (connect(i,j) == 1) then - if (any(nodelist1 .eq. nodelist(i)) .and. any(nodelist2 .eq. nodelist(j))) then - cut_edges(k,:) = (/ nodelist(i), nodelist(j) /) - k = k +1 - end if - end if - end do - end do - cut_edges = cut_edges_temp - - deallocate(cut_edges_temp) - end subroutine connect2subconnects - - function region_neighbouring_atoms(connect, nodelist, part, which) - implicit none - integer, intent(in) :: connect(:,:), part(:), nodelist(:), which - integer, allocatable :: sub1(:,:), sub2(:,:), dummy1(:), dummy2(:), cut_edges(:,:) - integer, dimension(2) :: edge, regions - integer, allocatable :: neigh_temp(:,:), region_neighbouring_atoms(:,:) - integer i - ! generate a partition of the whole graph using part == which as the carving mask. - ! returns a list of cut edges - call connect2subconnects(connect, nodelist, part==which, & - sub1, sub2, dummy1, dummy2, cut_edges) - - allocate(neigh_temp(size(cut_edges(:,1)),3)) - do i = 1, size(cut_edges(:,1)) - edge = cut_edges(i,:) - regions = (/part(minloc(abs(nodelist - edge(1)), 1)), & - part(minloc(abs(nodelist - edge(2)), 1))/) - ! which region other node belongs to - if (regions(1) == which) then - neigh_temp(i,1) = regions(2) - else - neigh_temp(i,1) = regions(1) - end if - ! which edge - neigh_temp(i,2:3) = edge - end do - region_neighbouring_atoms = neigh_temp - - deallocate(neigh_temp) - end function region_neighbouring_atoms - - - subroutine partition_qm_list(at, k, nneightol, ripening, error) - - implicit none - type(Atoms), intent(inout) :: at - integer, intent(in) :: k - real(dp), intent(in) :: nneightol - logical, intent(in) :: ripening - integer, optional, intent(out) :: error - - type(Atoms) :: qm_at - integer, pointer :: hybrid_mark(:), orig_index(:), qm_cluster_ptr(:) - logical, allocatable :: my_hybrid_mask(:) - integer :: i, objval, status - integer, dimension(:), allocatable :: part - - INIT_ERROR(error) - - call assign_property_pointer(at, 'hybrid_mark', hybrid_mark, error) - PASS_ERROR(error) - - allocate(my_hybrid_mask(at%n)) - my_hybrid_mask = (hybrid_mark == HYBRID_ACTIVE_MARK) - - ! select qm region here. NB: qm_list is now qm_at%orig_index - call select(qm_at, at, mask=my_hybrid_mask, orig_index=.true.) - allocate(part(qm_at%N)) - - ! then generate the part vector (was called assign, unfortunate choice for a fortran code) - call kway_partition_atoms(qm_at, k, nneightol, part, objval, status) - - ! now try writing down the ripening stuff in fortran - - ! add property qm_cluster - call add_property(at, 'qm_cluster', 0, ptr=qm_cluster_ptr, overwrite=.true., error=error) - PASS_ERROR(error) - - ! zero padding qm_cluster property - do i = 1, at%N - qm_cluster_ptr(i) = 0 - end do - ! update values in qm region - - call assign_property_pointer(at, 'orig_index', orig_index, error) - PASS_ERROR(error) - - do i = 1, qm_at%N - qm_cluster_ptr(orig_index(i)) = part(i) - end do - - deallocate(part) - deallocate(my_hybrid_mask) - ! WARNING: this routine does not return medoids, which are anyway useless at the current stage of partitioning method - - end subroutine partition_qm_list - -end module partition_module diff --git a/src/libAtoms/ringstat.f95 b/src/libAtoms/ringstat.f95 deleted file mode 100644 index fd390b06c5..0000000000 --- a/src/libAtoms/ringstat.f95 +++ /dev/null @@ -1,469 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Ring statistics module -!X -!% Functions to compute ring statistics according to -!% D.S. Franzblau, Phys. Rev. B 44, 4925 (1991) -!% -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - -#include "error.inc" - -module ringstat_module - use error_module - use system_module, only : dp, operator(//) - use linearalgebra_module - use atoms_module - - implicit none - private - - public :: count_sp_rings, distance_map - -contains - - !% Look for the shortest distance starting at atom *root*, - !% look only for atoms where *mask* is true - subroutine find_shortest_distances(at, root, dist, mask, error) - implicit none - - type(Atoms), intent(in) :: at - integer, intent(in) :: root - integer, intent(out) :: dist(at%N) - logical, intent(in), optional :: mask(at%N) - integer, intent(out), optional :: error - - ! --- - - integer, parameter :: MAX_WALKER = 8192 - - ! --- - - integer :: i, ni, j, k - - integer :: n_walker - integer :: walker(MAX_WALKER) - - integer :: n_new_walker - integer :: new_walker(MAX_WALKER) - logical :: this_atom - - ! --- - - INIT_ERROR(error) - - n_walker = 1 - walker(1) = root - - do while (n_walker > 0) - - n_new_walker = 0 - - do k = 1, n_walker - i = walker(k) - -! do ni = nl%seed(i), nl%last(i) - do ni = 1, n_neighbours(at, i) -! j = nl%neighbors(ni) - j = neighbour(at, i, ni) - - this_atom = .true. - if (present(mask)) this_atom = mask(j) - - if (this_atom .and. dist(j) == 0 ) then - - n_new_walker = n_new_walker+1 - if (n_new_walker > MAX_WALKER) then - RAISE_ERROR("MAX_WALKER ("//MAX_WALKER//") exceeded.", error) - endif - - new_walker(n_new_walker) = j - - dist(j) = dist(i)+1 - - endif - - enddo - - enddo - - n_walker = n_new_walker - walker(1:n_walker) = new_walker(1:n_walker) - - enddo - - dist(root) = 0 - - endsubroutine find_shortest_distances - - - !% Look for the shortest distance starting at atom *root*, - !% look only for atoms where *mask* is true - subroutine distance_map(at, dist, mask, diameter, error) - implicit none - - type(Atoms), intent(in) :: at - integer, intent(out) :: dist(at%N, at%N) - logical, intent(in), optional :: mask(at%N) - integer, intent(out), optional :: diameter - integer, intent(out), optional :: error - - ! --- - - integer :: i - logical :: this_atom - - ! --- - - INIT_ERROR(error) - - if (present(diameter)) then - diameter = 0 - endif - - dist = 0 - - do i = 1, at%N - - this_atom = .true. - if (present(mask)) this_atom = mask(i) - - if (this_atom) then - - call find_shortest_distances(at, i, dist(:, i), mask, error) - PASS_ERROR(error) - - if (present(diameter)) then - diameter = max(diameter, maxval(dist(:, i))) - endif - - endif - enddo - - ! Check that matrix is symmetric - if (any(dist /= transpose(dist))) then - RAISE_ERROR("*dist* matrix not symmetric.", error) - endif - - endsubroutine distance_map - - - !% Look for the "shortest path" ring starting at atom *at*, - !% look only for atoms where *mask* is true - subroutine count_sp_rings(at, cutoff, dist, max_ring_len, stat, mask, rings_out, dr_out, error) - implicit none - - type(Atoms), intent(in) :: at - real(DP), intent(in) :: cutoff - integer, intent(in) :: dist(at%N, at%N) - integer, intent(in) :: max_ring_len - integer, intent(inout) :: stat(max_ring_len) - logical, intent(in), optional :: mask(at%N) - integer, intent(out), optional :: rings_out(:, :) - real(dp), intent(out), optional :: dr_out(:, :, :) - integer, intent(out), optional :: error - - ! --- - - integer, parameter :: MAX_WALKER = 16384 - - real(DP), parameter :: EPS = 0.0001_DP - - ! --- - - integer :: i, ni, j, k, m, n, a, na, b, dn - - real(DP) :: d(3), abs_dr_sq, cutoff_sq - - logical, allocatable :: done(:) - logical :: is_sp - - integer :: n_walker - integer :: walker(MAX_WALKER) - integer :: last(MAX_WALKER) - - integer :: ring_len(MAX_WALKER) - integer :: rings(max_ring_len, MAX_WALKER) - real(DP) :: dr(3, max_ring_len, MAX_WALKER) - - integer :: n_new_walker - integer :: new_walker(MAX_WALKER) - integer :: new_last(MAX_WALKER) - - integer :: new_ring_len(MAX_WALKER) - integer :: new_rings(max_ring_len, MAX_WALKER) - real(DP) :: new_dr(3, max_ring_len, MAX_WALKER) - - integer :: no(at%N), n_rings_out - - ! --- - -! allocate(done(at%connect%neighbour1%t%N+at%connect%neighbour2%t%N)) - - INIT_ERROR(error) - - if (present(rings_out)) then - if (size(rings_out,1) < max_ring_len+1) then - RAISE_ERROR('size(rings_out,1) < max_ring_len+1', error) - end if - if (.not. present(dr_out)) then - RAISE_ERROR('rings_out is present but dr_out is not', error) - end if - rings_out(:,:) = 0 - dr_out(:,:,:) = 0.0_dp - n_rings_out = 0 - end if - - cutoff_sq = cutoff**2 - - no(1) = 0 - do i = 2, at%N - no(i) = no(i-1) + n_neighbours(at, i-1) - enddo - - allocate(done(no(at%N) + n_neighbours(at, at%N))) - - done = .false. - - bonds_loop1: do a = 1, at%N - if ( .not. present(mask) .or. mask(a) ) then -! bonds_loop2: do na = nl%seed(a), nl%last(a) - bonds_loop2: do na = 1, n_neighbours(at, a) -! b = nl%neighbors(na) - b = neighbour(at, a, na) - - if ( a < b .and. ( .not. present(mask) .or. mask(b) ) ) then - - done(no(a)+na) = .true. -! do ni = nl%seed(b), nl%last(b) -! if (nl%neighbors(ni) == a) then -! done(ni) = .true. -! endif -! enddo - do ni = 1, n_neighbours(at, b) - if (neighbour(at, b, ni) == a) then - done(no(b)+ni) = .true. - endif - enddo - - n_walker = 1 - walker(1) = b - last(1) = a - - ring_len = 1 - rings(1, 1) = b -! dr(:, 1, 1) = GET_DRJ(p, nl, a, b, na) - b = neighbour(at, a, na, diff=dr(:, 1, 1)) - - while_walkers_exist: do while (n_walker > 0) - - n_new_walker = 0 - - do k = 1, n_walker - i = walker(k) - - if ( i > 0 ) then - -! ni_away_from_root_loop: do ni = nl%seed(i), nl%last(i) - ni_away_from_root_loop: do ni = 1, n_neighbours(at, i) - ni_away_from_root_if: if ( .not. done(no(i)+ni) ) then - -! DISTJ_SQ(p, nl, i, ni, j, d, abs_dr_sq) - j = neighbour(at, i, ni, diff=d) - abs_dr_sq = d .dot. d - - if ( abs_dr_sq < cutoff_sq .and. ( .not. present(mask) .or. mask(j) ) .and. j /= last(k) ) then - - if ( dist(j, a) == dist(i, a)+1 ) then - - if ( ring_len(k) < (max_ring_len-1)/2 ) then - - n_new_walker = n_new_walker+1 - if (n_new_walker > MAX_WALKER) then - RAISE_ERROR("MAX_WALKER ("//MAX_WALKER//") exceeded.", error) - endif - - new_walker(n_new_walker) = j - new_last(n_new_walker) = i - - new_rings(1:ring_len(k), n_new_walker) = rings(1:ring_len(k), k) - new_ring_len(n_new_walker) = ring_len(k)+1 - new_rings(new_ring_len(n_new_walker), n_new_walker) = j - - new_dr(:, 1:ring_len(k), n_new_walker) = dr(:, 1:ring_len(k), n_new_walker) - new_dr(:, new_ring_len(n_new_walker), n_new_walker) = dr(:, ring_len(k), k) + d - - endif - - else - - if ( dist(j, a) == dist(i, a) .or. dist(j, a) == dist(i, a)-1) then - - ! Reverse search direction - n_new_walker = n_new_walker+1 - if (n_new_walker > MAX_WALKER) then - RAISE_ERROR("MAX_WALKER ("//MAX_WALKER//") exceeded.", error) - endif - - new_walker(n_new_walker) = -j - new_last(n_new_walker) = i - - new_rings(1:ring_len(k), n_new_walker) = rings(1:ring_len(k), k) - new_ring_len(n_new_walker) = ring_len(k)+1 - new_rings(new_ring_len(n_new_walker), n_new_walker) = j - - new_dr(:, 1:ring_len(k), n_new_walker) = dr(:, 1:ring_len(k), k) - new_dr(:, new_ring_len(n_new_walker), n_new_walker) = dr(:, ring_len(k), k) + d - - else - - RAISE_ERROR("Something is wrong with the distance map.", error) - - endif - - endif - - endif - - endif ni_away_from_root_if - enddo ni_away_from_root_loop - - else - - i = -i - -! ni_towards_root_loop: do ni = nl%seed(i), nl%last(i) - ni_towards_root_loop: do ni = 1, n_neighbours(at, i) - ni_towards_root_if: if ( .not. done(no(i)+ni) ) then - -! DISTJ_SQ(p, nl, i, ni, j, d, abs_dr_sq) - j = neighbour(at, i, ni, diff=d) - abs_dr_sq = d .dot. d - - if ( abs_dr_sq < cutoff_sq .and. ( .not. present(mask) .or. mask(j) ) .and. j /= last(k) ) then - - if ( j == a ) then - - d = d + dr(:, ring_len(k), k) - - if ( dot_product(d, d) < EPS ) then - - ! Now we need to check whether this ring is SP - - is_sp = .true. - - ring_len(k) = ring_len(k)+1 - rings(ring_len(k), k) = a - - do m = 1, ring_len(k) - do n = m+2, ring_len(k) - - dn = n-m - if (dn > ring_len(k)/2) dn = ring_len(k)-dn - - if (dist(rings(n, k), rings(m, k)) /= dn) then - is_sp = .false. - endif - enddo - enddo - - if (is_sp) then - if (present(rings_out)) then - n_rings_out = n_rings_out + 1 - if (n_rings_out > size(rings_out,2)) then - RAISE_ERROR('Too many rings to store in rings_out', error) - end if - ! save atoms around the ring - rings_out(:, n_rings_out) = (/ring_len(k), rings(1:ring_len(k), k) /) - ! save displacement vectors around the ring - dr_out(:, 1:ring_len(k), n_rings_out) = dr(:, 1:ring_len(k), k) - end if - stat(ring_len(k)) = stat(ring_len(k))+1 - endif - - endif - - else if (dist(j, a) == dist(i, a)-1) then - - if (all(rings(1:ring_len(k), k) /= j)) then - - n_new_walker = n_new_walker+1 - if (n_new_walker > MAX_WALKER) then - RAISE_ERROR("MAX_WALKER ("//MAX_WALKER//") exceeded.", error) - endif - - new_walker(n_new_walker) = -j - new_last(n_new_walker) = i - - new_rings(1:ring_len(k), n_new_walker) = rings(1:ring_len(k), k) - new_ring_len(n_new_walker) = ring_len(k)+1 - new_rings(new_ring_len(n_new_walker), n_new_walker) = j - - new_dr(:, 1:ring_len(k), n_new_walker) = dr(:, 1:ring_len(k), k) - new_dr(:, new_ring_len(n_new_walker), n_new_walker) = dr(:, ring_len(k), k) + d - - endif - - endif - - endif - - endif ni_towards_root_if - enddo ni_towards_root_loop - - endif - enddo - - n_walker = n_new_walker - walker(1:n_walker) = new_walker(1:n_walker) - last(1:n_walker) = new_last(1:n_walker) - - ring_len(1:n_walker) = new_ring_len(1:n_walker) - rings(:, 1:n_walker) = new_rings(:, 1:n_walker) - - dr(:, :, 1:n_walker) = new_dr(:, :, 1:n_walker) - - enddo while_walkers_exist - - endif - - enddo bonds_loop2 - endif - enddo bonds_loop1 - - deallocate(done) - - endsubroutine count_sp_rings - -endmodule ringstat_module diff --git a/src/libAtoms/statistics.f95 b/src/libAtoms/statistics.f95 deleted file mode 100644 index 77f87c1bea..0000000000 --- a/src/libAtoms/statistics.f95 +++ /dev/null @@ -1,83 +0,0 @@ -module statistics_module -use system_module, only : dp, PRINT_VERBOSE, PRINT_NORMAL, print, current_verbosity, operator(//) -implicit none -private - -public :: mean, variance - -public :: mean_var_decorrelated_err -interface mean_var_decorrelated_err - module procedure mean_var_decorrelated_err_r1 -end interface mean_var_decorrelated_err - -contains - -subroutine mean_var_decorrelated_err_r1(A, m, v, decorrelated_err, decorrelation_t) - real(dp) :: A(:) - real(dp), optional :: m, v, decorrelated_err, decorrelation_t - - integer :: bin_i, bin_size, n_bins, N - real(dp) :: A_mean, A_var, Nr, A_decorrelation_t - real(dp), allocatable :: binned_means(:) - real(dp) :: binned_means_var - real(dp) :: p_d_t, pp_d_t - logical :: found_max - - N = size(A) - Nr = N - - A_mean = mean(A) - if (present(m)) m = A_mean - if (present(v) .or. present(decorrelation_t) .or. present(decorrelated_err)) A_var = variance(A, A_mean) - if (present(v)) v = A_var - - found_max = .false. - p_d_t = -HUGE(1.0_dp) - pp_d_t = HUGE(1.0_dp) - if (present(decorrelation_t) .or. present(decorrelated_err)) then - bin_size = 1 - do while (bin_size <= N) - n_bins = N/bin_size - allocate(binned_means(n_bins)) - do bin_i=1, n_bins - binned_means(bin_i) = mean(A((bin_i-1)*bin_size+1:(bin_i-1)*bin_size+bin_size)) - end do - binned_means_var = variance(binned_means, mean(binned_means)) - deallocate(binned_means) - A_decorrelation_t = binned_means_var*real(bin_size,dp)/A_var - call print("bin_size " // bin_size // " decorrelation_t " // A_decorrelation_t, PRINT_VERBOSE) - if (A_decorrelation_t < p_d_t .and. p_d_t > pp_d_t) then - if (.not. found_max) then - if (present(decorrelation_t)) decorrelation_t = A_decorrelation_t - if (present(decorrelated_err)) decorrelated_err = sqrt(binned_means_var/real(n_bins,dp)) - found_max = .true. - endif - if (current_verbosity() <= PRINT_NORMAL) exit - endif - pp_d_t = p_d_t - p_d_t = A_decorrelation_t - if (bin_size == 1) then - bin_size = bin_size * 2 - else - bin_size = bin_size * 1.5 - endif - end do - end if - -end subroutine mean_var_decorrelated_err_r1 - -function mean(A) - real(dp), intent(in) :: A(:) - real(dp) :: mean - - mean = sum(A)/real(size(A),dp) -end function mean - -function variance(A, A_mean) - real(dp), intent(in) :: A(:), A_mean - real(dp) :: variance - - variance = sum((A-A_mean)**2)/real(size(A),dp) -end function variance - -end module statistics_module diff --git a/src/libAtoms/steinhardt_nelson_qw.f95 b/src/libAtoms/steinhardt_nelson_qw.f95 deleted file mode 100644 index d0d4d28764..0000000000 --- a/src/libAtoms/steinhardt_nelson_qw.f95 +++ /dev/null @@ -1,243 +0,0 @@ -#include "error.inc" - -module steinhardt_nelson_qw_module - -use error_module -use system_module -use units_module -use dictionary_module -use atoms_types_module -use atoms_module -use linearalgebra_module -use angular_functions_module - -implicit none -private - -public :: calc_qw, calc_qw_grad - -contains - -subroutine calc_qw(this,l,do_q,do_w,cutoff,min_cutoff,cutoff_transition_width,mask,mask_neighbour,error) - type(atoms), intent(inout) :: this - integer, intent(in) :: l - logical, intent(in), optional :: do_q, do_w - real(dp), intent(in), optional :: cutoff, cutoff_transition_width, min_cutoff - logical, dimension(:), intent(in), optional :: mask, mask_neighbour - integer, intent(out), optional :: error - - real(dp), dimension(:), pointer :: ql, wl - real(dp), dimension(3) :: diff_ij - real(dp) :: ql_crystal, wl_crystal, my_cutoff, my_min_cutoff, my_cutoff_transition_width, r_ij, f_cut - logical :: my_do_q, my_do_w, do_smooth_cutoff - - complex(dp), dimension(:), allocatable :: spherical_c - complex(dp), dimension(:), allocatable :: spherical_c_crystal - integer :: i, j, m, n, m1, m2, m3 - real(dp) :: n_bonds, n_bonds_crystal - - INIT_ERROR(error) - - my_do_q = optional_default(.false.,do_q) - my_do_w = optional_default(.false.,do_w) - my_cutoff = optional_default(this%cutoff,cutoff) - my_min_cutoff = optional_default(0.0_dp,min_cutoff) - my_cutoff_transition_width = optional_default(0.0_dp,cutoff_transition_width) - - do_smooth_cutoff = present(cutoff_transition_width) - - if(my_cutoff > this%cutoff) then - call set_cutoff(this,my_cutoff) - call calc_connect(this) - endif - - if(my_do_q) call add_property(this, 'q'//l, 0.0_dp, ptr=ql) - if(my_do_w) call add_property(this, 'w'//l, 0.0_dp, ptr=wl) - - if(present(mask)) then - call check_size("mask",mask,this%N,"calc_qw",error) - endif - if(present(mask_neighbour)) then - call check_size("mask_neighbour",mask_neighbour,this%N,"calc_qw",error) - endif - - allocate(spherical_c(-l:l), spherical_c_crystal(-l:l)) - spherical_c_crystal = CPLX_ZERO - - f_cut = 1.0_dp - n_bonds_crystal = 0.0_dp - - do i = 1, this%N - - if(present(mask)) then - if( .not. mask(i) ) cycle - endif - - n_bonds = 0.0_dp - spherical_c = CPLX_ZERO - - do n = 1, n_neighbours(this,i) - j = neighbour(this,i,n,diff=diff_ij,distance=r_ij) - - if(r_ij > my_cutoff) cycle - if(r_ij < my_min_cutoff) cycle - - if(present(mask_neighbour)) then - if( .not. mask_neighbour(j) ) cycle - endif - - if(do_smooth_cutoff) then - f_cut = coordination_function(r_ij,my_cutoff,my_cutoff_transition_width) - endif - n_bonds = n_bonds + f_cut - - do m = -l, l - spherical_c(m) = spherical_c(m) + SphericalYCartesian(l,m,diff_ij) * f_cut - enddo - - enddo - - ! spherical_c_crystal is defined as in Steinhardt and Nelson, from ( \sum_i spherical_c(i) ) / ( \sum_i n_bonds(i)) - ! An altenative would be \sum_i ( spherical_c(i) / n_bonds(i) ) - spherical_c_crystal = spherical_c_crystal + spherical_c - n_bonds_crystal = n_bonds_crystal + n_bonds - - if(n_bonds > 0.0_dp) spherical_c = spherical_c / n_bonds - - if(my_do_q) ql(i) = sqrt( dot_product(spherical_c,spherical_c) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) - - if(my_do_w) then - wl(i) = 0.0_dp - do m1 = -l, l - do m2 = -l, l - m3 = -m1-m2 - if( m3 >= -l .and. m3 <= l ) wl(i) = wl(i) + spherical_c(m1) * spherical_c(m2) * spherical_c(m3) * wigner3j(l,m1,l,m2,l,m3) - enddo - enddo - - wl(i) = wl(i) / sqrt( dot_product(spherical_c,spherical_c)**3 ) - endif - - enddo - - if (n_bonds_crystal > 0.0_dp ) spherical_c_crystal = spherical_c_crystal / n_bonds_crystal - if (my_do_q) then - ql_crystal = sqrt( dot_product(spherical_c_crystal,spherical_c_crystal) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) - call set_value(this%params, "q"//l//"_global",ql_crystal) - endif - - if(my_do_w) then - wl_crystal = 0.0_dp - do m1 = -l, l - do m2 = -l, l - m3 = -m1-m2 - if( m3 >= -l .and. m3 <= l ) wl_crystal = wl_crystal + spherical_c_crystal(m1) * spherical_c_crystal(m2) * spherical_c_crystal(m3) * wigner3j(l,m1,l,m2,l,m3) - enddo - enddo - - wl_crystal = wl_crystal / sqrt( dot_product(spherical_c_crystal(:),spherical_c_crystal(:))**3 ) - call set_value(this%params, "w"//l//"_global",wl_crystal) - endif - - if(allocated(spherical_c)) deallocate(spherical_c) - if(allocated(spherical_c_crystal)) deallocate(spherical_c_crystal) - -endsubroutine calc_qw - -subroutine calc_qw_grad(this,grad_ind,l,do_q,do_w,cutoff,cutoff_transition_width) - type(atoms), intent(inout) :: this - integer, intent(in) :: grad_ind - integer, intent(in) :: l - logical, intent(in), optional :: do_q, do_w - real(dp), optional :: cutoff, cutoff_transition_width - - integer :: i, j, n, m - logical :: my_do_q, my_do_w, do_smooth_cutoff - real(dp) :: my_cutoff, my_cutoff_transition_width, ql - real(dp) :: f_cut, df_cut(3), r_ij, diff_ij(3), n_bonds - complex(dp), allocatable :: spherical_c(:), dspherical_c(:,:,:) - real(dp), allocatable :: dn_bonds(:,:) - real(dp), pointer :: ql_grad(:,:), wl_grad(:,:) - - my_do_q = optional_default(.false.,do_q) - my_do_w = optional_default(.false.,do_w) - my_cutoff = optional_default(this%cutoff,cutoff) - my_cutoff_transition_width = optional_default(0.0_dp,cutoff_transition_width) - - do_smooth_cutoff = present(cutoff_transition_width) - - if(my_cutoff > this%cutoff) then - call set_cutoff(this,my_cutoff) - call calc_connect(this) - endif - - if(my_do_q) call add_property(this, 'q'//l//'_grad', 0.0_dp, n_cols=3, ptr2=ql_grad) - if(my_do_w) call add_property(this, 'w'//l//'_grad', 0.0_dp, n_cols=3, ptr2=wl_grad) - - if (my_do_q) ql_grad = 0.0_dp - if (my_do_w) wl_grad = 0.0_dp - - allocate(spherical_c(-l:l), dspherical_c(3,-l:l,this%N), dn_bonds(3,this%N)) - spherical_c = CPLX_ZERO - dspherical_c = CPLX_ZERO - - f_cut = 1.0_dp - df_cut = 0.0_dp - - n_bonds = 0.0_dp - dn_bonds = 0.0_dp - - i = grad_ind - do n = 1, n_neighbours(this,i) - j = neighbour(this,i,n,diff=diff_ij,distance=r_ij) - - if(r_ij > my_cutoff) cycle - - if(do_smooth_cutoff) then - f_cut = coordination_function(r_ij,my_cutoff,my_cutoff_transition_width) - df_cut(:) = -dcoordination_function(r_ij,my_cutoff,my_cutoff_transition_width)*diff_ij/r_ij - endif - n_bonds = n_bonds + f_cut - dn_bonds(:,i) = dn_bonds(:,i) + df_cut(:) - dn_bonds(:,j) = dn_bonds(:,j) - df_cut(:) - - do m = -l, l - spherical_c(m) = spherical_c(m) + SphericalYCartesian(l,m,diff_ij) * f_cut - dspherical_c(:,m,i) = dspherical_c(:,m,i) - GradSphericalYCartesian(l,m,diff_ij) * f_cut + & - SphericalYCartesian(l,m,diff_ij)*df_cut - dspherical_c(:,m,j) = dspherical_c(:,m,j) + GradSphericalYCartesian(l,m,diff_ij) * f_cut - & - SphericalYCartesian(l,m,diff_ij)*df_cut - enddo - enddo - - if(n_bonds > 0.0_dp) then - do m=-l,l - dspherical_c(:,m,i) = ((n_bonds*dspherical_c(:,m,i))-(spherical_c(m)*dn_bonds(:,i))) / (n_bonds**2) - do n = 1, n_neighbours(this,i) - j = neighbour(this,i,n) - dspherical_c(:,m,j) = ((n_bonds*dspherical_c(:,m,j))-(spherical_c(m)*dn_bonds(:,j))) / (n_bonds**2) - end do - end do - spherical_c(:) = spherical_c(:) / n_bonds - end if - - if(my_do_q) then - ql = sqrt( dot_product(spherical_c(:),spherical_c(:)) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) - do m=-l,l - ql_grad(:,i) = ql_grad(:,i) + (1.0_dp/ql)*spherical_c(m)*conjg(dspherical_c(:,m,i)) * (4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) - do n = 1, n_neighbours(this,i) - j = neighbour(this,i,n) - ql_grad(:,j) = ql_grad(:,j) + (1.0_dp/ql)*spherical_c(m)*conjg(dspherical_c(:,m,j)) * (4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) - end do - end do - endif - - if(my_do_w) then - call system_abort("calc_qw_grad does not support grad of w yet") - endif - -end subroutine calc_qw_grad - -end module steinhardt_nelson_qw_module - - diff --git a/src/libAtoms/task_manager.f95 b/src/libAtoms/task_manager.f95 deleted file mode 100644 index e395bdc6fb..0000000000 --- a/src/libAtoms/task_manager.f95 +++ /dev/null @@ -1,358 +0,0 @@ -module task_manager_module - !> A task manager determines the distribution of tasks to workers with - !> respect to the tasks' demands. - !> - !> Each task stores integer data in %idata. - !> %idata(1) is used for distribution. - !> - !> The special %worker_id=SHARED is used for shared tasks. Each worker - !> has a local entry with local %idata. %idata(1) contains the local - !> size, %idata(2) contains the global offset. - - use libatoms_module, only : initialise, finalise, print_title, print, & - operator(//), system_abort, inoutput, optional_default, OUTPUT, PRINT_VERBOSE - use linearalgebra_module, only : insertion_sort - use MPI_context_module, only : MPI_Context, print - use ScaLAPACK_module, only : Scalapack, print - - implicit none - private - - public :: task_manager_type, task_type, worker_type, SHARED - public :: task_manager_init_tasks, task_manager_init_workers, task_manager_deallocate - public :: task_manager_init_idata - public :: task_manager_add_task, task_manager_add_worker - public :: task_manager_distribute_tasks, task_manager_check_distribution - public :: task_manager_print, task_manager_export_distribution - - integer, parameter :: UNDEFINED = -1 - integer, parameter :: SHARED = 0 - - type task_type - integer :: index = UNDEFINED !> initial task index - integer, dimension(:), allocatable :: idata !> integer data for this task - integer :: worker_id = UNDEFINED !> ID of worker assigned to this task - end type task_type - - type worker_type - integer :: index = UNDEFINED !> initial worker index - integer :: n_tasks = 0 !> number of tasks assigned to this worker - integer :: n_padding = 0 !> number of padding rows to reach unified workload - type(task_type), dimension(:), allocatable :: tasks !> tasks assigned to this worker - end type worker_type - - type task_manager_type - logical :: active = .false. !> whether task manager is used - logical :: distributed = .false. !> whether tasks have been distributed - integer :: my_worker_id = 0 !> compute only tasks for this worker - integer :: unified_workload = 0 !> highest workload among workers, target for padding - - integer :: n_tasks = 0 !> number of tasks - integer :: n_workers = 0 !> number of workers - integer :: n_shared = 0 !> number of shared tasks - - integer, dimension(:), allocatable :: idata !< custom shared integer data - - type(MPI_Context) :: MPI_obj - type(ScaLAPACK) :: ScaLAPACK_obj - - type(task_type), dimension(:), allocatable :: tasks !> tasks to compute - type(worker_type), dimension(:), allocatable :: workers !> workers to compute tasks - end type task_manager_type - - contains - - !> Add task to list - subroutine task_manager_add_task(this, idata1, n_idata, worker_id) - type(task_manager_type), intent(inout) :: this - integer, intent(in), optional :: idata1 !> first idata entry for new task - integer, intent(in), optional :: n_idata !> number of idata entries for new task - integer, intent(in), optional :: worker_id !> preset worker for this task - - integer :: my_n_idata - - if (.not. this%active) return - my_n_idata = optional_default(1, n_idata) - - this%n_tasks = this%n_tasks + 1 - if (this%n_tasks > size(this%tasks)) call system_abort("More tasks added than allocated.") - associate(task => this%tasks(this%n_tasks)) - allocate(task%idata(my_n_idata)) - task%idata = UNDEFINED - task%index = this%n_tasks - if (present(idata1)) task%idata(1) = idata1 - if (present(worker_id)) task%worker_id = worker_id - end associate - end subroutine task_manager_add_task - - !> Add worker to list - subroutine task_manager_add_worker(this) - type(task_manager_type), intent(inout) :: this - - if (.not. this%active) return - - this%n_workers = this%n_workers + 1 - if (this%n_workers > size(this%workers)) call system_abort("More workers added than allocated.") - associate(worker => this%workers(this%n_workers)) - worker%index = this%n_workers - worker%n_tasks = 0 - end associate - end subroutine task_manager_add_worker - - !> @brief Distribute tasks among workers for minimal idata(1) usage - subroutine task_manager_distribute_tasks(this) - type(task_manager_type), intent(inout) :: this - - integer :: i, t, w ! indices - integer :: n - integer, dimension(:), allocatable :: workloads - integer, dimension(:), allocatable :: idata1_list - integer, dimension(:), allocatable :: index_list - - if (.not. this%active) return - if (this%n_tasks < 1) return - if (this%n_workers < 1) call system_abort("task_manager_distribute_tasks: No workers initialised.") - - allocate(workloads(this%n_workers)) - allocate(idata1_list(this%n_tasks)) - allocate(index_list(this%n_tasks)) - - ! copy to temp arrays, sort both by idata1 - do i = 1, this%n_tasks - if (.not. allocated(this%tasks(i)%idata)) call system_abort("task_manager_distribute_tasks: idata of task "//i//" is unallocated.") - idata1_list(i) = this%tasks(i)%idata(1) - index_list(i) = this%tasks(i)%index - end do - call insertion_sort(idata1_list, i_data=index_list) ! stable sort for easier testing - - ! count workload of preset tasks - workloads = 0 - do t = 1, this%n_tasks - i = index_list(t) - w = this%tasks(i)%worker_id - if (w >= 1) then - this%workers(w)%n_tasks = this%workers(w)%n_tasks + 1 - workloads(w) = workloads(w) + idata1_list(t) - end if - end do - - ! distribute tasks to workers to minimize maximum idata1 sum - do t = this%n_tasks, 1, -1 - i = index_list(t) - if (this%tasks(i)%worker_id /= UNDEFINED) cycle ! skip preset tasks - w = minloc(workloads, 1) - this%tasks(i)%worker_id = w - this%workers(w)%n_tasks = this%workers(w)%n_tasks + 1 - workloads(w) = workloads(w) + idata1_list(t) - end do - - this%unified_workload = maxval(workloads) - - ! fill workers with task id lists (replication for simpler retrieval) - this%n_shared = count(this%tasks(:)%worker_id == SHARED) - do w = 1, this%n_workers - n = this%workers(w)%n_tasks + this%n_shared - allocate(this%workers(w)%tasks(n)) - this%workers(w)%n_tasks = 0 - end do - do t = 1, this%n_tasks - w = this%tasks(t)%worker_id - if (w < 1) cycle - n = this%workers(w)%n_tasks + 1 - this%workers(w)%tasks(n) = this%tasks(t) - this%workers(w)%n_tasks = n - end do - - do w = 1, this%n_workers - this%workers(w)%n_padding = this%unified_workload - workloads(w) - end do - - call task_manager_distribute_shared_tasks(this) - - this%distributed = .true. - end subroutine task_manager_distribute_tasks - - subroutine task_manager_distribute_shared_tasks(this) - ! fill padding first, then distribute rows evenly - type(task_manager_type), intent(inout) :: this - - integer :: n, t, w - integer :: rest, n_split, n_extra, n_plus, offset - - if (.not. this%active) return - - do t = 1, this%n_tasks - if (this%tasks(t)%worker_id /= SHARED) cycle - - rest = max(this%tasks(t)%idata(1) - sum(this%workers(:)%n_padding), 0) - n_split = rest / this%n_workers - n_extra = mod(rest, this%n_workers) - n_plus = n_split - if (n_extra > 0) n_plus = n_split + 1 - - rest = this%tasks(t)%idata(1) - offset = 0 - do w = 1, this%n_workers - n = this%workers(w)%n_tasks + 1 - associate(worker => this%workers(w), w_task => this%workers(w)%tasks(n)) - call task_deepcopy(w_task, this%tasks(t)) - - w_task%idata(1) = worker%n_padding + n_split - if (w <= n_extra) w_task%idata(1) = w_task%idata(1) + 1 - w_task%idata(1) = min(w_task%idata(1), rest) - w_task%idata(2) = offset - worker%n_padding = worker%n_padding + n_plus - w_task%idata(1) - - rest = rest - w_task%idata(1) - offset = offset + w_task%idata(1) - worker%n_tasks = n - end associate - end do - this%unified_workload = this%unified_workload + n_plus - end do - end subroutine task_manager_distribute_shared_tasks - - subroutine task_manager_check_distribution(this) - type(task_manager_type), intent(in) :: this - - integer :: tmp - - if (.not. this%active) return - if (.not. this%distributed) return - - tmp = task_manager_get_max_idata1_sum(this) - if (tmp /= this%unified_workload) call system_abort("task_manager_check_distribution: unified_workload is inconsistent: "//tmp//" "//this%unified_workload) - if (any(this%workers(:)%n_padding < 0)) call system_abort("task_manager_check_distribution: negative padding: "//this%workers(:)%n_padding) - end subroutine task_manager_check_distribution - - subroutine task_manager_show_distribution(this) - type(task_manager_type), intent(in) :: this - - integer :: i, t, w, idata1_sum, n_tasks - - if (.not. this%active) return - - do w = 1, this%n_workers - call print("Tasks of worker "//w) - idata1_sum = 0 - n_tasks = 0 - do i = 1, this%workers(w)%n_tasks - t = this%workers(w)%tasks(i)%index - call print(i // ": " // t // ": " // this%workers(w)%tasks(i)%idata) - idata1_sum = idata1_sum + this%tasks(t)%idata(1) - end do - call print("Summary: "//this%workers(w)%n_tasks//" tasks, "//idata1_sum//" idata1_sum, "//this%workers(w)%n_padding//" padding") - end do - end subroutine task_manager_show_distribution - - subroutine task_manager_export_distribution(this, only_id) - type(task_manager_type), intent(in) :: this - integer, optional :: only_id !> only this worker writes distribution - - integer :: i, t, w - integer :: only_id_opt - type(Inoutput) :: file - - if (.not. this%active) return - only_id_opt = optional_default(UNDEFINED, only_id) - if (only_id_opt >= 0 .and. only_id_opt /= this%my_worker_id) return - - call initialise(file, "tm.dist", OUTPUT) - call print("worker_id task_id_local task_id_global idata", file=file) - do w = 1, this%n_workers - do i = 1, this%workers(w)%n_tasks - t = this%workers(w)%tasks(i)%index - call print(w // " " // i // " " // t // " " // this%workers(w)%tasks(i)%idata, file=file) - end do - end do - call finalise(file) - end subroutine task_manager_export_distribution - - subroutine task_manager_init_tasks(this, n_tasks) - type(task_manager_type), intent(inout) :: this - integer, intent(in) :: n_tasks !> number of tasks to allocate - - if (.not. this%active) return - - call print("Allocate task_manager%tasks for "//n_tasks//" tasks.", PRINT_VERBOSE) - allocate(this%tasks(n_tasks)) - end subroutine task_manager_init_tasks - - subroutine task_manager_init_workers(this, n_workers) - type(task_manager_type), intent(inout) :: this - integer, intent(in) :: n_workers !> number of workers to allocate and set - - integer :: w - - if (.not. this%active) return - - allocate(this%workers(n_workers)) - do w = 1, n_workers - call task_manager_add_worker(this) - end do - end subroutine task_manager_init_workers - - subroutine task_manager_init_idata(this, n_idata) - type(task_manager_type), intent(inout) :: this - integer, intent(in) :: n_idata - - if (.not. this%active) return - - allocate(this%idata(n_idata)) - end subroutine task_manager_init_idata - - subroutine task_manager_deallocate(this) - type(task_manager_type), intent(inout) :: this - - this%distributed = .false. - this%n_tasks = 0 - this%n_workers = 0 - if (allocated(this%idata)) deallocate(this%idata) - if (allocated(this%tasks)) deallocate(this%tasks) - if (allocated(this%workers)) deallocate(this%workers) - end subroutine task_manager_deallocate - - subroutine task_manager_print(this) - type(task_manager_type), intent(inout) :: this - - call print_title('task_manager_type') - call print("%active: "//this%active) - call print("%my_worker_id: "//this%my_worker_id) - call print("%distributed: "//this%distributed) - call print("%unified_workload: "//this%unified_workload) - call print("%n_tasks: "//this%n_tasks) - call print("%n_workers: "//this%n_workers) - call print_title('MPI_obj') - call print(this%MPI_obj) - call print_title('ScaLAPACK_obj') - call print(this%ScaLAPACK_obj) - call print_title('task distrubtion') - call task_manager_show_distribution(this) - call print_title('') - end subroutine task_manager_print - - function task_manager_get_max_idata1_sum(this) result(res) - type(task_manager_type), intent(in) :: this - - integer :: res - integer :: n, t, w - - if (.not. this%active) return - - res = 0 - do w = 1, this%n_workers - n = sum([(this%workers(w)%tasks(t)%idata(1), t = 1, this%workers(w)%n_tasks)]) - res = max(n, res) - end do - end function task_manager_get_max_idata1_sum - - subroutine task_deepcopy(this, from) - type(task_type), intent(inout) :: this - type(task_type), intent(in) :: from - - this%index = from%index - allocate(this%idata, source=from%idata) - this%worker_id = from%worker_id - end subroutine task_deepcopy - -end module task_manager_module diff --git a/src/libAtoms/test_gamma.f95 b/src/libAtoms/test_gamma.f95 deleted file mode 100644 index 7d8869a893..0000000000 --- a/src/libAtoms/test_gamma.f95 +++ /dev/null @@ -1,76 +0,0 @@ -program test_gamma - - use gamma_module - - implicit none - integer, parameter :: n_a = 5 - integer, parameter :: n_x = 9 - integer :: i, j, k - real(dp) :: a(n_a), x(n_x), gamma_mathematica(n_a*n_x) - - a = (/ 1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp /) - x = (/ 0.0_dp, 1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp, 6.0_dp, 7.0_dp, 8.0_dp /) - gamma_mathematica = (/ & - 1.00000000000000e0_dp, & - 3.67879441171442e-1_dp, & - 1.35335283236613e-1_dp, & - 4.9787068367864e-2_dp, & - 1.83156388887342e-2_dp, & - 6.73794699908547e-3_dp, & - 2.47875217666636e-3_dp, & - 9.11881965554516e-4_dp, & - 3.35462627902512e-4_dp, & - 1.00000000000000e0_dp, & - 7.35758882342885e-1_dp, & - 4.06005849709838e-1_dp, & - 1.99148273471456e-1_dp, & - 9.15781944436709e-2_dp, & - 4.04276819945128e-2_dp, & - 1.73512652366645e-2_dp, & - 7.29505572443613e-3_dp, & - 3.01916365112261e-3_dp, & - 2.00000000000000e0_dp, & - 1.83939720585721e0_dp, & - 1.35335283236613e0_dp, & - 8.46380162253687e-1_dp, & - 4.76206611107089e-1_dp, & - 2.49304038966162e-1_dp, & - 1.23937608833318e-1_dp, & - 5.92723277610436e-2_dp, & - 2.7507935488006e-2_dp, & - 6.0000000000000e0_dp, & - 5.88607105874308e0_dp, & - 5.14274076299128e0_dp, & - 3.88339133269339e0_dp, & - 2.60082072220025e0_dp, & - 1.59015549178417e0_dp, & - 9.07223296659887e-1_dp, & - 4.9059249746833e-1_dp, & - 2.54280671950104e-1_dp, & - 2.40000000000000e1_dp, & - 2.39121636761438e1_dp, & - 2.27363275837509e1_dp, & - 1.95663178685705e1_dp, & - 1.5092086444317e1_dp, & - 1.05718388415651e1_dp, & - 6.84135600759915e0_dp, & - 4.15179858916971e0_dp, & - 2.39117761168911e0_dp/) - - !print*,'TESTING GAMMA FUNCTION - GFORTRAN ONLY' - !do i = 1, n_a - ! print*, a(i), exp(ln_gamma(a(i))), gamma(a(i)), abs(exp(ln_gamma(a(i)))-gamma(a(i))) - !enddo - - print*,'TESTING INCOMPLETE GAMMA FUNCTION - Mathematica results' - print'(2a10,2a25,a14)','a','x','Gamma(a,x) Mathematica','Gamma(a,x) Current','Delta' - k = 0 - do i = 1, n_a - do j = 1, n_x - k = k + 1 - print'(2f10.6,2e25.15,e14.5)',a(i),x(j),gamma_mathematica(k),gamma_incomplete_upper(a(i),x(j)), & - abs(gamma_mathematica(k)-gamma_incomplete_upper(a(i),x(j))) - enddo - enddo - -endprogram test_gamma From 18020c9623b97d7350a991ce0fd9e8a8234172db Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:51:24 +0100 Subject: [PATCH 07/47] renamed source files to have F90 extension --- src/Potentials/AdjustablePotential.f95 | 1316 ------ src/Potentials/ApproxFermi.f95 | 293 -- src/Potentials/CallbackPot.f95 | 310 -- src/Potentials/ElectrostaticEmbed.f95 | 544 --- src/Potentials/Ewald.f95 | 830 ---- src/Potentials/FilePot.f95 | 495 --- src/Potentials/Functions.f95 | 451 -- src/Potentials/IP.f95 | 1155 ----- src/Potentials/IPEwald.f95 | 554 --- src/Potentials/IPModel_ASAP.f95 | 1027 ----- src/Potentials/IPModel_BOP.f95 | 800 ---- src/Potentials/IPModel_BornMayer.f95 | 571 --- src/Potentials/IPModel_Brenner.f95 | 713 --- src/Potentials/IPModel_Brenner_2002.f95 | 399 -- src/Potentials/IPModel_Brenner_Screened.f95 | 404 -- src/Potentials/IPModel_CH4.f95 | 204 - src/Potentials/IPModel_ConfiningMonomer.f95 | 340 -- src/Potentials/IPModel_Coulomb.f95 | 563 --- src/Potentials/IPModel_Custom.f95 | 192 - src/Potentials/IPModel_DispTS.f95 | 647 --- .../IPModel_EAM_Ercolessi_Adams.f95 | 814 ---- src/Potentials/IPModel_Einstein.f95 | 369 -- src/Potentials/IPModel_FB.f95 | 455 -- src/Potentials/IPModel_FC.f95 | 714 --- src/Potentials/IPModel_FC4.f95 | 836 ---- src/Potentials/IPModel_FS.f95 | 589 --- src/Potentials/IPModel_FX.f95 | 367 -- src/Potentials/IPModel_GAP.f95 | 987 ----- src/Potentials/IPModel_Glue.f95 | 905 ---- src/Potentials/IPModel_HFdimer.f95 | 208 - src/Potentials/IPModel_KIM.f95 | 683 --- src/Potentials/IPModel_LJ.f95 | 747 ---- src/Potentials/IPModel_LMTO_TBE.f95 | 362 -- src/Potentials/IPModel_LinearSOAP.f95 | 535 --- src/Potentials/IPModel_MBD.f95 | 275 -- src/Potentials/IPModel_MTP.f95 | 255 -- src/Potentials/IPModel_Morse.f95 | 569 --- src/Potentials/IPModel_Multipoles.f95 | 700 --- src/Potentials/IPModel_PartridgeSchwenke.f95 | 709 --- src/Potentials/IPModel_RS.f95 | 575 --- src/Potentials/IPModel_SCME.f95 | 336 -- src/Potentials/IPModel_SW.f95 | 920 ---- src/Potentials/IPModel_SW_VP.f95 | 1218 ----- src/Potentials/IPModel_Si_MEAM.f95 | 714 --- src/Potentials/IPModel_Spring.f95 | 259 -- src/Potentials/IPModel_Sutton_Chen.f95 | 458 -- src/Potentials/IPModel_TS.f95 | 968 ---- src/Potentials/IPModel_Template.f95 | 295 -- src/Potentials/IPModel_Tersoff.f95 | 735 --- src/Potentials/IPModel_Tether.f95 | 197 - src/Potentials/IPModel_WaterDimer_Gillan.f95 | 1027 ----- src/Potentials/IPModel_WaterTrimer_Gillan.f95 | 700 --- src/Potentials/IPModel_ZBL.f95 | 311 -- src/Potentials/IPModel_vdW.f95 | 899 ---- src/Potentials/Multipole_Interactions.f95 | 764 ---- src/Potentials/Multipoles.f95 | 642 --- src/Potentials/Partridge_Schwenke_Dipole.f95 | 713 --- src/Potentials/Potential.f95 | 2442 ---------- src/Potentials/Potential_Cluster_header.f95 | 65 - src/Potentials/Potential_Cluster_routines.f95 | 163 - src/Potentials/Potential_EVB_header.f95 | 46 - src/Potentials/Potential_EVB_routines.f95 | 400 -- .../Potential_ForceMixing_header.f95 | 128 - .../Potential_ForceMixing_routines.f95 | 783 ---- src/Potentials/Potential_Hybrid_utils.f95 | 284 -- .../Potential_Local_E_Mix_header.f95 | 83 - .../Potential_Local_E_Mix_routines.f95 | 435 -- src/Potentials/Potential_ONIOM_header.f95 | 81 - src/Potentials/Potential_ONIOM_routines.f95 | 410 -- src/Potentials/Potential_Precon_Minim.f95 | 1659 ------- src/Potentials/Potential_Sum_header.f95 | 32 - src/Potentials/Potential_Sum_routines.f95 | 174 - src/Potentials/Potential_simple.f95 | 1612 ------- src/Potentials/QC_QUIP_Wrapper.f95 | 310 -- src/Potentials/QUIP_Common.f95 | 113 - src/Potentials/QUIP_module.f95 | 74 - src/Potentials/RS_SparseMatrix.f95 | 2146 --------- src/Potentials/SocketPot.f95 | 341 -- src/Potentials/TB.f95 | 2360 ---------- src/Potentials/TBMatrix.f95 | 1310 ------ src/Potentials/TBModel.f95 | 674 --- src/Potentials/TBModel_Bowler.f95 | 1089 ----- src/Potentials/TBModel_DFTB.f95 | 1143 ----- src/Potentials/TBModel_GSP.f95 | 1385 ------ src/Potentials/TBModel_NRL_TB.f95 | 1921 -------- src/Potentials/TBModel_NRL_TB_defs.f95 | 48 - src/Potentials/TBSystem.f95 | 3943 ----------------- src/Potentials/TB_Common.f95 | 335 -- src/Potentials/TB_GreensFunctions.f95 | 649 --- src/Potentials/TB_Kpoints.f95 | 818 ---- src/Potentials/TB_Mixing.f95 | 518 --- src/Potentials/Yukawa.f95 | 594 --- src/Potentials/ginted.f | 1 + src/Potentials/quip_lammps_wrapper.f95 | 199 - src/Potentials/quip_unified_wrapper.f95 | 333 -- 95 files changed, 1 insertion(+), 63718 deletions(-) delete mode 100644 src/Potentials/AdjustablePotential.f95 delete mode 100644 src/Potentials/ApproxFermi.f95 delete mode 100644 src/Potentials/CallbackPot.f95 delete mode 100644 src/Potentials/ElectrostaticEmbed.f95 delete mode 100644 src/Potentials/Ewald.f95 delete mode 100644 src/Potentials/FilePot.f95 delete mode 100644 src/Potentials/Functions.f95 delete mode 100644 src/Potentials/IP.f95 delete mode 100644 src/Potentials/IPEwald.f95 delete mode 100644 src/Potentials/IPModel_ASAP.f95 delete mode 100644 src/Potentials/IPModel_BOP.f95 delete mode 100644 src/Potentials/IPModel_BornMayer.f95 delete mode 100644 src/Potentials/IPModel_Brenner.f95 delete mode 100644 src/Potentials/IPModel_Brenner_2002.f95 delete mode 100644 src/Potentials/IPModel_Brenner_Screened.f95 delete mode 100644 src/Potentials/IPModel_CH4.f95 delete mode 100644 src/Potentials/IPModel_ConfiningMonomer.f95 delete mode 100644 src/Potentials/IPModel_Coulomb.f95 delete mode 100644 src/Potentials/IPModel_Custom.f95 delete mode 100644 src/Potentials/IPModel_DispTS.f95 delete mode 100644 src/Potentials/IPModel_EAM_Ercolessi_Adams.f95 delete mode 100644 src/Potentials/IPModel_Einstein.f95 delete mode 100644 src/Potentials/IPModel_FB.f95 delete mode 100644 src/Potentials/IPModel_FC.f95 delete mode 100644 src/Potentials/IPModel_FC4.f95 delete mode 100644 src/Potentials/IPModel_FS.f95 delete mode 100644 src/Potentials/IPModel_FX.f95 delete mode 100644 src/Potentials/IPModel_GAP.f95 delete mode 100644 src/Potentials/IPModel_Glue.f95 delete mode 100644 src/Potentials/IPModel_HFdimer.f95 delete mode 100644 src/Potentials/IPModel_KIM.f95 delete mode 100644 src/Potentials/IPModel_LJ.f95 delete mode 100644 src/Potentials/IPModel_LMTO_TBE.f95 delete mode 100644 src/Potentials/IPModel_LinearSOAP.f95 delete mode 100644 src/Potentials/IPModel_MBD.f95 delete mode 100644 src/Potentials/IPModel_MTP.f95 delete mode 100644 src/Potentials/IPModel_Morse.f95 delete mode 100644 src/Potentials/IPModel_Multipoles.f95 delete mode 100644 src/Potentials/IPModel_PartridgeSchwenke.f95 delete mode 100644 src/Potentials/IPModel_RS.f95 delete mode 100644 src/Potentials/IPModel_SCME.f95 delete mode 100644 src/Potentials/IPModel_SW.f95 delete mode 100644 src/Potentials/IPModel_SW_VP.f95 delete mode 100644 src/Potentials/IPModel_Si_MEAM.f95 delete mode 100644 src/Potentials/IPModel_Spring.f95 delete mode 100644 src/Potentials/IPModel_Sutton_Chen.f95 delete mode 100644 src/Potentials/IPModel_TS.f95 delete mode 100644 src/Potentials/IPModel_Template.f95 delete mode 100644 src/Potentials/IPModel_Tersoff.f95 delete mode 100644 src/Potentials/IPModel_Tether.f95 delete mode 100644 src/Potentials/IPModel_WaterDimer_Gillan.f95 delete mode 100644 src/Potentials/IPModel_WaterTrimer_Gillan.f95 delete mode 100644 src/Potentials/IPModel_ZBL.f95 delete mode 100644 src/Potentials/IPModel_vdW.f95 delete mode 100644 src/Potentials/Multipole_Interactions.f95 delete mode 100644 src/Potentials/Multipoles.f95 delete mode 100644 src/Potentials/Partridge_Schwenke_Dipole.f95 delete mode 100644 src/Potentials/Potential.f95 delete mode 100644 src/Potentials/Potential_Cluster_header.f95 delete mode 100644 src/Potentials/Potential_Cluster_routines.f95 delete mode 100644 src/Potentials/Potential_EVB_header.f95 delete mode 100644 src/Potentials/Potential_EVB_routines.f95 delete mode 100644 src/Potentials/Potential_ForceMixing_header.f95 delete mode 100644 src/Potentials/Potential_ForceMixing_routines.f95 delete mode 100644 src/Potentials/Potential_Hybrid_utils.f95 delete mode 100644 src/Potentials/Potential_Local_E_Mix_header.f95 delete mode 100644 src/Potentials/Potential_Local_E_Mix_routines.f95 delete mode 100644 src/Potentials/Potential_ONIOM_header.f95 delete mode 100644 src/Potentials/Potential_ONIOM_routines.f95 delete mode 100644 src/Potentials/Potential_Precon_Minim.f95 delete mode 100644 src/Potentials/Potential_Sum_header.f95 delete mode 100644 src/Potentials/Potential_Sum_routines.f95 delete mode 100644 src/Potentials/Potential_simple.f95 delete mode 100644 src/Potentials/QC_QUIP_Wrapper.f95 delete mode 100644 src/Potentials/QUIP_Common.f95 delete mode 100644 src/Potentials/QUIP_module.f95 delete mode 100644 src/Potentials/RS_SparseMatrix.f95 delete mode 100644 src/Potentials/SocketPot.f95 delete mode 100644 src/Potentials/TB.f95 delete mode 100644 src/Potentials/TBMatrix.f95 delete mode 100644 src/Potentials/TBModel.f95 delete mode 100644 src/Potentials/TBModel_Bowler.f95 delete mode 100644 src/Potentials/TBModel_DFTB.f95 delete mode 100644 src/Potentials/TBModel_GSP.f95 delete mode 100644 src/Potentials/TBModel_NRL_TB.f95 delete mode 100644 src/Potentials/TBModel_NRL_TB_defs.f95 delete mode 100644 src/Potentials/TBSystem.f95 delete mode 100644 src/Potentials/TB_Common.f95 delete mode 100644 src/Potentials/TB_GreensFunctions.f95 delete mode 100644 src/Potentials/TB_Kpoints.f95 delete mode 100644 src/Potentials/TB_Mixing.f95 delete mode 100644 src/Potentials/Yukawa.f95 delete mode 100644 src/Potentials/quip_lammps_wrapper.f95 delete mode 100644 src/Potentials/quip_unified_wrapper.f95 diff --git a/src/Potentials/AdjustablePotential.f95 b/src/Potentials/AdjustablePotential.f95 deleted file mode 100644 index 6968a294ed..0000000000 --- a/src/Potentials/AdjustablePotential.f95 +++ /dev/null @@ -1,1316 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Learn-on-the-fly (LOTF) hybrid molecular dynamics code -!X -!X -!X Authors: Gabor Csanyi, Alessio Commisso, Steven Winfield -!X James Kermode, Gianpietro Moras, Michael Payne, Alessandro De Vita -!X -!X Copyright 2005, All Rights Reserved -!X -!X This source code is confidential, all distribution is -!X prohibited. Making unauthorized copies is also prohibited -!X -!X When using this software, the following should be referenced: -!X -!X Gabor Csanyi, Tristan Albaret, Mike C. Payne and Alessandro De Vita -!X "Learn on the fly": a hybrid classical and quantum-mechanical -!X molecular dynamics simulation -!X Physical Review Letters 93 p. 175503 (2004) >>PDF [626 KB] -!X -!X Gabor Csanyi, T. Albaret, G. Moras, M. C. Payne, A. De Vita -!X Multiscale hybrid simulation methods for material systems -!X J. Phys. Cond. Mat. 17 R691-R703 Topical Review (2005) -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X AdjustablePotential_linear module -!X -!X a set of linear potentials that can be adapted a reproduce -!X given forces on atoms -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - -module AdjustablePotential_module - use system_module, only : dp, print, inoutput, PRINT_VERBOSE, PRINT_NERD, line, optional_default, mainlog, value, system_abort, reallocate, print_message, operator(//), mpi_id, abort_on_mpi_error - use linearalgebra_module - use table_module - use sparse_module - use minimization_module - - use atoms_types_module - use atoms_module - use clusters_module - -#ifdef _MPI -#ifndef _OLDMPI - use mpi -#endif -#endif - implicit none -#ifdef _MPI -#ifdef _OLDMPI -include 'mpif.h' -#endif -#endif - private - SAVE - - public :: adjustable_potential_init, adjustable_potential_optimise, adjustable_potential_force, adjustable_potential_finalise - - - ! ratio of smallest to largest eigenvalue of spring space spanning matrix - ! for an atom to be considered not well described - real(dp), parameter :: AP_bad_atom_threshold = 0.1_dp - - ! Threshold for spring constants above which a warning will be issued - real(dp), parameter :: adjustable_potential_max_spring_constant = 1.0_dp - - integer, parameter :: adjustable_potential_nparams = 1 - - ! are we initialised or not - logical::adjustable_potential_initialised = .false. - - ! have we got some parameters saved - logical::adjustable_potential_parameters_saved = .false. - - ! this table contains the pairs of atoms for which we have a two-body - ! adjustable spring potential, together with their distance - ! and the potential parameters. the parameters are just the y values of the spring - ! !!!the integer indices refer to the order of atoms in the fitlist - ! argument of the init() routine!!! - ! - ! int real - ! - !fitlist indexes -> fi,fj,shift rij, fij <- fij: variable parameter - type(table)::twobody - - ! this table is used as a store for old data which can be used to initialise - ! parameters to values from the last interpolation step. It also stores - ! parameters from one end point during interpolation - type(table)::twobody_old - - real(dp), dimension(:,:), allocatable:: fitforce_old - - !The exclusion list table is used to prevent springs being created between - !certain pairs of atoms, e.g. if there is a bond length constraint between - !them. - type(table) :: exclusion_list - logical :: exclusions = .false. - - ! Operation twobody twobody_old - ! - ! Extrapolate from t1 -> t2 using parameters P1 P1 --, -- - ! Compute parameters P2' at t2 P2' `--> P1 - ! Interpolate from t1 -> t2 using P1 and P2' P2' --, P1 - ! Call CalcConnect -- `--> P2' - ! Create parameters P2 using P2' as initial values P2 P2' - ! Extrapolate from t2 -> t3 using parameters P2 P2 -- - ! ... - - ! local copy of target force to fit to: F1x,F1yF1z,F2x,F2y,F2z... - real(dp), allocatable, dimension(:) ::target_force - - ! local copy of fitlist indices - ! atomlist%int(1,fi) = i, fi: index in fitlist, i: index in Atoms structure - type(Table) :: atomlist, atomlist_old -!!$ type(Table) :: fitlist_old - - ! forcematrix multiplied onto the vector of - ! parameters (fij...) - ! gives the force vector on the atoms. the number of columns - ! is the number of parameters, the number of rows is 3*the number of atoms - ! - ! force = forcematrix * params - ! - ! ...0..y1_x y2_x...0...... - ! ...0..y1_y y2_y...0...... - ! ...0..y1_z y2_z...0...... - type(sparse) ::forcematrix ! linear part - -contains - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Initialize adjustable potential - !X - !X inputs are an atoms structure and a table with a single list integers - !X of atoms for which target forces are to be fitted. - !X - !X The adjustable potential will be fitted to the difference between - !X a quantum mechanical force and a classical force. - !X - !X An adjustable potential will be created between every pair of neighbouring - !X atoms that are given in the fitlist. - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - - ! this is called with a table - subroutine adjustable_potential_init(atoms_in, fitlist, directionN, spring_hops, & - map, method, nnonly) - type(Atoms), intent(in) :: atoms_in - type(Table), intent(in) :: fitlist - integer, intent(in) :: directionN - integer, optional, intent(in) :: spring_hops - logical, optional, intent(in) :: map, nnonly - character(len=*),optional,intent(in):: method - - - real(dp):: ratio, evals(3), evecs(3,3), small_evec(3), r_ij, u_ij(3), cos_theta, oldratio - real(dp), allocatable, dimension(:)::default_row - real(dp), allocatable, dimension(:,:) :: df - integer::Nfit_components, i, j, fi, fj, nj, n, hops, atomcount, oldn, & - shift(3), k, best_j, best_fj, best_shift(3), sloc(1), sx, sy, sz - type(Table) :: springs, newsprings, tmpsprings,cand_springs - logical :: do_map, do_nnonly - logical :: do_refit - - do_map = .false. - if (present(map)) do_map = map - - do_nnonly = .true. - if (present(nnonly)) do_nnonly = nnonly - - hops = 2 - if(present(spring_hops)) then - hops = spring_hops - end if - - ! If QM region hasn't changed since we last made out spring list, then - ! there's nothing to be done now. - - if(do_map) then - ! this save makes the twobody_old equal to twobody - call adjustable_potential_save_parameters - call print("Saving old parameters ....", PRINT_VERBOSE) - end if - -!!$ if (first_time) then -!!$ first_time = .false. -!!$ else if (fitlist%N == fitlist_old%N) then -!!$ -!!$ allocate(s1(fitlist%N),s2(fitlist%N)) -!!$ s1 = fitlist%int(1,1:fitlist%N) -!!$ s2 = atomlist%int(1,1:atomlist%N) -!!$ call sort_array(s1) -!!$ call sort_array(s2) -!!$ -!!$ if (all(int_part(fitlist) == int_part(fitlist_old))) then -!!$ call print('fitlist unchanged, nothing to be done in adjustable_potential_init', PRINT_VERBOSE) -!!$ deallocate(s1) -!!$ deallocate(s2) - - ! Atom set matches, but it's possible some of the shifts have changed - ! if any fit atoms have crossed a periodic boundary since last call to - ! adjustable_potential_init. Let's overwrite with new shifts. -!!$ do n=1,twobody%N -!!$ i = atomlist%int(1,twobody%int(1,n)) -!!$ j = atomlist%int(1,twobody%int(2,n)) -!!$ ! overwrite old shift in twobody%int(3:5,n) with correct shift -!!$ r = distance_min_image(atoms_in, i, j, shift=shift) -!!$ -!!$ if (abs(r-twobody%real(1,i)) < 0.1_dp) then -!!$ call print('shift update: '//shift//' '//twobody%int(3:5,i)//' '//r//' '//twobody%real(1,i)) -!!$ twobody%int(3:5,i) = shift -!!$ end if -!!$ -!!$ !! for the thin crack system, not all springs are min -!!$ !! image springs; some of them span periodic boundary. -!!$ !! how can we get round this? -!!$ -!!$ end do -!!$ -!!$ return -!!$ end if -!!$ -!!$ deallocate(s1) -!!$ deallocate(s2) -!!$ end if -!!$ call wipe(fitlist_old) -!!$ call append(fitlist_old, fitlist) - - call print("Setting up adjustable potential....", PRINT_VERBOSE) - - ! test table size - if(fitlist%intsize /= 4 .and. fitlist%intsize /= 1) & - call system_abort("adjustable_potential_init: fitlist%intsize must be 1 or 4") - if(fitlist%realsize /= 0) & - call system_abort("adjustable_potential_init: fitlist%realsize /= 0") - - if (multiple_images(fitlist)) & - call system_abort('adjustable_potential_init: fitlist contains repeated atom indices') - - call print("Fitting on atoms:", PRINT_VERBOSE) - call print(fitlist, PRINT_VERBOSE) - call print("", PRINT_VERBOSE) - - ! allocate globals - call print("Allocating target_force", PRINT_NERD) - Nfit_components = fitlist%N*3 - - call reallocate(target_force,Nfit_components) - target_force = 0.0_dp - - ! copy atom indices from argument to global - - call wipe(atomlist) - call allocate(atomlist,1,0,0,0,fitlist%N) - call append(atomlist, fitlist%int(1,1:fitlist%N)) - - ! set up twobody table that holds pairs of atom indices and shiftts - ! and the associated potential parameters (initialized to 0) - - ! wipe previous table - call print("Wiping twobody table", PRINT_NERD) - call wipe(twobody) - call allocate(twobody, 5, 1+2*adjustable_potential_nparams,0,0) - - call allocate(springs, 4, 0, 0, 0) - call allocate(newsprings, 4, 0, 0, 0) - call allocate(tmpsprings, 4, 0, 0, 0) - - - ! default parameters - allocate(default_row(1+2*adjustable_potential_nparams)) - default_row = 0.0_dp - - - ! First we try to add springs between pairs of atoms in fitlist within 'hops' - ! bond hops of one another - call print('Adding default springs') - do fi=1,atomlist%N ! loop through fit atoms - i = atomlist%int(1,fi) - - call wipe(newsprings) - call append(newsprings, (/i,0,0,0/)) - call bfs_grow(atoms_in, newsprings, hops, nneighb_only = do_nnonly) - - do nj = 1, newsprings%N - - j = newsprings%int(1,nj) - shift = newsprings%int(2:4,nj) - - fj = find(atomlist, j) - if (fj == 0) cycle ! not in fitlist - if (i == j) cycle ! don't join to self or images of self - - ! Have we already got this spring? - ! always store in order fi, fj with fi < fj - if (find(twobody, (/min(fi,fj), max(fi,fj), sign(1,fj-fi)*shift/)) /= 0) cycle - - ! Is this pair excluded? - if (exclusions) then - if (is_excluded(i,j,shift)) cycle - end if - - default_row(1) = distance(atoms_in, i, j, shift) - call append(twobody, (/min(fi,fj), max(fi,fj), sign(1,fj-fi)*shift/), default_row) - end do - - end do - write(line, '(a,i0,a)') 'Got ', twobody%N, ' springs' ; call print(line) - write(line, '(a,f0.2)') 'Searching for difficult atoms, anisotropy threshold: ', AP_bad_atom_threshold - call print(line, PRINT_VERBOSE) - - oldn = twobody%N - atomcount = 0 - ! For those fit atoms that we require directionality for, check how well the - ! springs connected to it span 3D space. If necessary add more springs for those atoms. - do fi=1,directionN - i = atomlist%int(1, fi) - - ! Find who atom i is connected to with springs, and get associated shifts - call wipe(springs) - do j = 1, twobody%N - if (twobody%int(1,j) == fi) & - call append(springs, (/atomlist%int(1,twobody%int(2,j)), twobody%int(3:5,j)/)) - if (twobody%int(2,j) == fi) & - call append(springs, (/atomlist%int(1,twobody%int(1,j)),-twobody%int(3:5,j)/)) - end do - - ! How well do these springs span 3D space? - if (springs%N > 2) then - call directionality(atoms_in, i, springs, evals, evecs, method=2) - ratio = minval(evals)/maxval(evals) - else - ratio = 0.0_dp ! less than three springs - really bad! - end if - - sloc = minloc(evals) - small_evec = evecs(:,sloc(1)) - - if (ratio < AP_bad_atom_threshold) then - - write (line,'(a,i6,a,i6,a,f10.3)') 'Atom ', i, ' with ', springs%N, & - ' springs has ratio ', ratio - call print(line, PRINT_VERBOSE) - call print('Smallest evect ='//small_evec, PRINT_VERBOSE) - - ! Not well enough - atomcount = atomcount + 1 - - ! Tabulate candidate springs - call allocate(cand_springs, 5, 2, 0, 0) - do fj = 1,atomlist%N - j = atomlist%int(1,fj) - - if (i == j) cycle ! Don't join to self - - do sx=-1,1 - do sy=-1,1 - do sz=-1,1 - - shift = (/sx,sy,sz/) - - if (find(springs, (/j,shift/)) /= 0) cycle ! We've tried this spring already - - ! Don't add if this pair is excluded - if (exclusions) then - if (is_excluded(i,j,shift)) cycle - end if - - r_ij = distance(atoms_in,i,j,shift) - u_ij = diff(atoms_in,i,j,shift) - cos_theta = abs(small_evec .dot. u_ij) / (norm(small_evec)*norm(u_ij)) - - call append(cand_springs, (/j,fj,shift/), (/r_ij,cos_theta/)) - - end do - end do - end do - end do - - ! Try to add springs until ratio exceeds thresholds - n = 0 - do while (ratio < AP_bad_atom_threshold .and. n < 8) - - ! Find candidate spring with largest cos_theta - sloc = maxloc(cand_springs%real(2,1:cand_springs%N)) - k = sloc(1) - - best_j = cand_springs%int(1,k) - best_fj = cand_springs%int(2,k) - best_shift = cand_springs%int(3:5,k) - r_ij = cand_springs%real(1,k) - - call print('Trying spring to atom '//best_j//' (index '//best_fj//') shift '//best_shift//' length '//r_ij) - - call delete(cand_springs, k) - - call append(springs, (/best_j,best_shift/)) - - oldratio = ratio - - call directionality(atoms_in, i, springs, evals, evecs, 2) - ratio = minval(evals)/maxval(evals) - - ! Add this spring to twobody only if it improves ratio - if (ratio > oldratio) then - default_row(1) = r_ij - call append(twobody,(/min(fi,best_fj),max(fi,best_fj),sign(1,best_fj-fi)*best_shift/), default_row) - - write (line, '(a,i0,a,f0.3)') ' Now got ', springs%N,' springs. Ratio improved to ', ratio - call print(line, PRINT_VERBOSE) - end if - - n = n + 1 - -!!$ newsprings = springs -!!$ -!!$ call bfs_step(atoms_in, newsprings, tmpsprings, nneighb_only = .true.) -!!$ call append(newsprings, tmpsprings) -!!$ -!!$ if (tmpsprings%N == 0) then -!!$ ! Didn't manage to add any atoms, so try nneigb_only = false, since -!!$ ! these are the 'bad' atoms and their neighbours are -!!$ ! probably some distance away -!!$ -!!$ call bfs_step(atoms_in, newsprings, tmpsprings, nneighb_only = .false.) -!!$ call append(newsprings, tmpsprings) -!!$ end if -!!$ -!!$ do nj = 1, newsprings%N -!!$ j = newsprings%int(1,nj) -!!$ shift = newsprings%int(2:4,nj) -!!$ fj = find(atomlist, j) -!!$ if (fj == 0) cycle ! not in fitlist -!!$ if (i == j) cycle ! don't join to self or images of self -!!$ -!!$ ! already got this spring -!!$ if (find(twobody, (/min(fi,fj), max(fi,fj), sign(1,fj-fi)*shift/)) /= 0) cycle -!!$ -!!$ ! Don't add if this pair is excluded -!!$ if (exclusions) then -!!$ if (is_excluded(i,j,shift)) cycle -!!$ end if -!!$ -!!$ default_row(1) = distance(atoms_in, i, j, shift) -!!$ call append(twobody,(/min(fi,fj),max(fi,fj),sign(1,fj-fi)*shift/), default_row) -!!$ end do -!!$ -!!$ ! Work out the springs again -!!$ call wipe(springs) -!!$ do j = 1, twobody%N -!!$ if (twobody%int(1,j) == fi) & -!!$ call append(springs, (/atomlist%int(1,twobody%int(2,j)), twobody%int(3:5,j)/)) -!!$ if (twobody%int(2,j) == fi) & -!!$ call append(springs, (/atomlist%int(1,twobody%int(1,j)),-twobody%int(3:5,j)/)) -!!$ end do -!!$ -!!$ ! Did we fail to add any springs at all? If so system has probably exploded -!!$ if (springs%N == 0) then -!!$ write(line, '(a,i0)') 'adjustable_potential_init: can''t add any springs for atom ', i -!!$ call system_abort(line) -!!$ end if -!!$ -!!$ call directionality(atoms_in, i, springs, evals, evecs, 2) -!!$ ratio = minval(evals)/maxval(evals) -!!$ -!!$ write (line, '(a,i0,a,f0.3)') ' Now got ', springs%N,' springs. Ratio improved to ', ratio -!!$ call print(line, PRINT_VERBOSE) -!!$ -!!$ n = n + 1 - end do - if (n == 8 .and. ratio < AP_bad_atom_threshold) then - call system_abort('adjustable_potential_init: failed to sufficiently improve bad spring space spanning') - end if - - end if - - end do - - if(atomcount > 0) then - write(line, '(a,i0,a,i0,a)') 'Added ', twobody%N-oldn, ' springs to fix ', atomcount, ' atoms' - call print(line) - end if - - call finalise(springs) - call finalise(newsprings) - call finalise(tmpsprings) - deallocate(default_row) - - call print("Allocating twobody table to proper size", PRINT_NERD) - call allocate(twobody) ! reduce table to proper length - - write(line, '(a,i0)') "Number of force components: ", size(target_force) ; call print(line) - write(line, '(a,i0)') "Number of parameters: ", twobody%N*adjustable_potential_nparams ; call print(line) - - adjustable_potential_initialised = .true. - - if(do_map) then - ! this maps from the twobody_old with the old structure into twobody with the new structure - call adjustable_potential_map_parameters - - ! Only need to refit if spline set has changed since last time - do_refit = .false. - ! if sizes don't match definitely need to refit - if (twobody%N /= twobody_old%N) then - do_refit = .true. - else - do i=1,twobody%N - ! As soon as we can't find a new spring in twobody_old, know we have to refit - if (find(twobody_old,twobody%int(:,i)) == 0) then - do_refit = .true. - exit - end if - end do - end if - - ! reoptimise with new springs to reproduce old forces at new positions - ! if fit region has changed, just copy the target force components that - ! are in both the old and new regions - if (do_refit) then - call print('Springs changed, refitting old forces with new spring set') - allocate(df(3,atomlist%N)) - df = 0.0_dp - do i=1,atomlist_old%N - fi = find(atomlist, atomlist_old%int(:,i)) ! find old fit atom in new fitlist - if (fi /= 0) df(:,fi) = fitforce_old(:,i) ! if found, copy target force - end do - call adjustable_potential_optimise(atoms_in, df, method=method) - deallocate(df) - end if - - endif - - ! this save makes the twobody_old equal to twobody (both new structure) - call adjustable_potential_save_parameters - - end subroutine adjustable_potential_init - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_finalise() - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - subroutine adjustable_potential_finalise() - if(allocated(target_force)) deallocate(target_force) - call finalise(atomlist) - call finalise(atomlist_old) - call finalise(twobody) - call finalise(twobody_old) - call adjustable_potential_delete_saved_parameters - call sparse_finalise(forcematrix) - if (exclusions) call finalise(exclusion_list) - end subroutine adjustable_potential_finalise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_delete_saved_parameters - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine adjustable_potential_delete_saved_parameters - call finalise(twobody_old) - call finalise(atomlist_old) - adjustable_potential_parameters_saved = .false. - end subroutine adjustable_potential_delete_saved_parameters - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_save_parameters - !X - !X Makes a copy of the twobody and atomlist data, avoiding a - !X reallocation if possible - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine adjustable_potential_save_parameters - if (.not.adjustable_potential_initialised) & - call system_abort('Adjustable_Potential_Save_Parameters: No parameters exist to save') - call wipe(twobody_old) - call append(twobody_old,twobody) - - call wipe(atomlist_old) - call append(atomlist_old, atomlist) - - adjustable_potential_parameters_saved = .true. - - end subroutine adjustable_potential_save_parameters - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_map_parameters - !X - !X Given an old set of data (twobody_old, atomlist_old), fill in the - !X y1 and y2 values which were used previously - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine adjustable_potential_map_parameters - integer :: i, j, fi, fj, n, m, k, shift(3) - - if(.not.adjustable_potential_initialised) & - call system_abort('Adjustable_Potential_Map_Parameters: No parameters to map!') - if (twobody_old%N == 0) & - call system_abort('Adjustable_Potential_Map_Parameters: No parameters are saved') - - if (twobody%N >= twobody_old%N) then ! loop over the smallest table - - !Loop over the entries in the old table - do n = 1, twobody_old%N - - !look up the atom indices - i = atomlist_old%int(1,twobody_old%int(1,n)) - j = atomlist_old%int(1,twobody_old%int(2,n)) - shift = twobody_old%int(3:5,n) - - !try to find the corresponding atoms in the new list - fi = find(atomlist,i) - if (fi == 0) cycle !atom i is not present in the new list - fj = find(atomlist,j) - if (fj == 0) cycle !atom j is not present in the new list - - !find the entry in the new twobody table - m = find(twobody,(/min(fi,fj),max(fi,fj),sign(1,fj-fi)*shift/)) - if (m == 0) cycle ! i and j are no longer connected - - ! copy the parameter values across - do k=1,2*adjustable_potential_nparams - twobody%real(1+k,m) = twobody_old%real(1+k,n) - end do - - end do - - else - - !Loop over the entries in the new table - do n = 1, twobody%N - - !look up the atom indices - i = atomlist%int(1,twobody%int(1,n)) - j = atomlist%int(1,twobody%int(2,n)) - shift = twobody%int(3:5,n) - - !try to find the corresponding atoms in the old list - fi = find(atomlist_old, i) - if (fi == 0) cycle !atom i is not present in the old list - fj = find(atomlist_old, j) - if (fj == 0) cycle !atom j is not present in the old list - - !find the entry in the old twobody table - m = find(twobody_old,(/min(fi,fj),max(fi,fj),sign(1,fj-fi)*shift/)) - if (m == 0) cycle ! i and j were not neighbours - - !copy the param values across - do k=1,2*adjustable_potential_nparams - twobody%real(1+k,n) = twobody_old%real(1+k,m) - end do - - end do - - end if - - end subroutine adjustable_potential_map_parameters - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_force(atoms, force) - !X - !X force and energy from the adjustable potential, using the interatomic - !X distance information from atoms. If interp is given, then interpolate - !X the parameters between twobody_old and twobody - !X - !X the force(:) array is the same size as the stored atomlist. - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine adjustable_potential_force(atoms_in, force, interp, interp_space, interp_order, energy, power) - type(Atoms), intent(in) :: atoms_in - real(dp), dimension(3,atomlist%N), intent(out) :: force - real(dp), optional, intent(in) :: interp - logical, optional, intent(in) :: interp_space - character(len=*),optional, intent(in) :: interp_order - real(dp), optional, intent(out) :: energy, power - - ! local - integer:: i, a1, a2, fi, fj, shift(3), my_interp_order - real(dp), dimension(3)::f - real(dp)::fij, r, interp_point, dalpha - logical::interpolate, do_interp_space - - do_interp_space = optional_default(.false., interp_space) - - interpolate = present(interp) .or. do_interp_space - if(interpolate .and. .not.adjustable_potential_parameters_saved) & - call System_Abort('Adjustable_Potential_Force: No parameters saved to interpolate with') - - my_interp_order = 1 - if(present(interp_order)) then - if(trim(interp_order) .eq. 'linear') then - my_interp_order = 1 - else if(trim(interp_order) .eq. 'quadratic') then - my_interp_order = 2 - else if(trim(interp_order) .eq. 'cubic') then - my_interp_order = 3 - else - call System_Abort("Invalid interpolation order `"//interp_order//"'in Adjustable_Potential_Force") - end if - end if - - force = 0.0_dp - - if(present(energy)) energy = 0.0_dp - if(present(power)) power = 0.0_dp - - do i=1,twobody%N - - fi = twobody%int(1,i) - fj = twobody%int(2,i) - shift = twobody%int(3:5,i) - - a1 = atomlist%int(1,fi) - a2 = atomlist%int(1,fj) - r = distance(atoms_in, a1, a2, shift) - - if(interpolate) then - if(do_interp_space) then - interp_point = (r - twobody_old%real(1,i))/(twobody%real(1,i)-twobody_old%real(1,i)) - fij = linear_interpolate(0.0_dp,twobody_old%real(2,i),& ! x0,y0 - 1.0_dp,twobody%real(2,i),interp_point) !x1, y1, x - else - select case(my_interp_order) - case(1) ! linear interpolation - fij = linear_interpolate(0.0_dp,twobody_old%real(2,i),& ! x0,y0 - 1.0_dp,twobody%real(2,i),interp) !x1, y1, x - - dalpha = (twobody%real(2,i) - twobody_old%real(2,i)) - case(2) ! quadratic using the derivative info at start point - fij = twobody_old%real(2,i)+interp*twobody_old%real(3,i)& - +interp*interp*(twobody%real(2,i)-twobody_old%real(2,i)-twobody_old%real(3,i)) - - dalpha = 0.0_dp - case(3) ! cubic with zero derivatives at endpoints - fij = cubic_interpolate(0.0_dp,twobody_old%real(2,i),& ! x0,y0 - 1.0_dp,twobody%real(2,i),interp) ! x1,y1, x - - dalpha = 0.0_dp - case default - call System_Abort("Invalid interpolation order in Adjustable_Potential_Force") - end select - end if - else - ! Extrapolate - fij = twobody%real(2,i) - dalpha = 0.0_dp ! Parameters don't change during extrap - end if - - ! optionally calculate energy and power - if(present(energy)) energy = energy + r*fij - if(present(power)) power = power + r*dalpha ! (since dV_dalpha = r, and dt = 1 here) - - if (value(mainlog%verbosity_stack) >= PRINT_NERD) & - call print(i//' '//a1//' '//a2//' '//r//' '//fij//' <-- SPRING', PRINT_NERD) - - ! get force - f = direction_cosines(atoms_in,a1,a2,shift)*fij - force(:,fi) = force(:,fi) + f - force(:,fj) = force(:,fj) - f - end do - - end subroutine adjustable_potential_force - - - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_force_sparse(params) - !X - !X force from the adjustable potential, using the precomputed - !X sparse matrix - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - function adjustable_potential_force_sparse(params) result(force) - real(dp)::params(:) - real(dp)::force(size(target_force)) - - if(.not.adjustable_potential_initialised) & - call system_abort("adjustable_potential_force_sparse: not initialised!") - - force = (forcematrix .mult. params) - end function adjustable_potential_force_sparse - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_force_error(params) - !X - !X normsq() of difference between target and adjustable force - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - function adjustable_potential_force_error(params,data) result(error) - real(dp)::params(:) - character,optional :: data(:) - real(dp)::error - - if(.not.adjustable_potential_initialised) & - call system_abort("adjustable_potential_force_error: not initialised!") - - if(value(mainlog%verbosity_stack) .ge. PRINT_NERD) then - write(line, *) "adjustable_potential_force_error: params(", size(params), ")" - call print(line, PRINT_NERD) - call print(params, PRINT_NERD) - end if - - error = normsq(target_force - (forcematrix .mult. params)) - - end function adjustable_potential_force_error - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_force_error_deriv(params) - !X - !X derivative of the force_error wrt variable parameters - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - function adjustable_potential_force_error_deriv(params,data) result(deriv) - real(dp)::params(:) - character,optional :: data(:) - real(dp)::force(size(target_force)) - real(dp)::deriv(size(params)) - - if(.not.adjustable_potential_initialised) & - call system_abort("adjustable_potential_force_error_deriv: not initialised!") - - if(value(mainlog%verbosity_stack) .ge. PRINT_NERD) then - write(line, *) "adjustable_potential_force_error_deriv: params(", size(params), ")" - call print(line, PRINT_NERD) - call print(params, PRINT_NERD) - end if - - force = (forcematrix .mult. params) - deriv = (-2.0_dp * (target_force - force)) .mult. forcematrix - end function adjustable_potential_force_error_deriv - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_create_forcematrix() - !X - !X creates the sparse matrix forcematrix that we - !X use to compute the adjustable forces quickly for different - !X parameters, but unchanging atomic positions - !X - !X forcematrix has as many rows as the 3*number of atoms to be fitted - !X on, so same as size(target_force), and as many columns as the - !X number of adjustable parameters, so twobody%N*adjustable_potential_nparams - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! - - subroutine adjustable_potential_create_forcematrix(atoms_in, precondition) - type(Atoms), intent(IN)::atoms_in - real(dp), intent(in) :: precondition(:) - - ! temporary hack to go via a full matrix. to be redone - real(dp), allocatable, dimension(:,:)::tmpmatrix - integer, parameter::nparams = adjustable_potential_nparams - integer::i, j, k, a1, a2, fi, fj, shift(3) - real(dp)::cosi(3) - integer, allocatable::colcounter(:), tmpcolumns(:,:) - - - write(line, *) "Setting up adjustable potential forcematrix.." ; call print(line, PRINT_VERBOSE) - write(line, *) ; call print(line, PRINT_VERBOSE) - - allocate(tmpmatrix(size(target_force), twobody%N*nparams)) - allocate(colcounter(size(target_force))) - allocate(tmpcolumns(size(target_force), twobody%N*nparams)) - tmpmatrix = 0.0_dp - colcounter = 0 - tmpcolumns = 0 - - ! loop through the springs - do i=1,twobody%N - ! we take and cache the distance from atoms_in, as it might have changed since time - ! we initialised the twobody table - fi = twobody%int(1,i) - fj = twobody%int(2,i) - shift = twobody%int(3:5,i) - a1 = atomlist%int(1,fi) - a2 = atomlist%int(1,fj) - - twobody%real(1,i) = distance(atoms_in, a1, a2, shift) - cosi = direction_cosines(atoms_in, a1, a2, shift) - - fi = (twobody%int(1,i)-1) ! subtract 1 so we can use it as index - do k=1,3 - colcounter(fi*3+k) = colcounter(fi*3+k) + 1 - ! Multiply by preconditioning factor for this spring - tmpmatrix (fi*3+k, colcounter(fi*3+k)) = cosi(k)*precondition(i) - tmpcolumns(fi*3+k, colcounter(fi*3+k)) = (i-1)*nparams+1 - end do - fj = (twobody%int(2,i)-1) ! subtract 1 so we can use it as index - do k=1,3 - colcounter(fj*3+k) = colcounter(fj*3+k) + 1 - ! Multiply by preconditioning factor for this spring - tmpmatrix (fj*3+k, colcounter(fj*3+k)) = -cosi(k)*precondition(i) - tmpcolumns(fj*3+k, colcounter(fj*3+k)) = (i-1)*nparams+1 - end do - end do ! i=1,twobody%N - - - ! fill in sparse matrix from values in tmpmatrix and tmpcolumns - call sparse_init(forcematrix, size(target_force), twobody%N*nparams) - do i=1,size(target_force) - forcematrix%rows(i) = forcematrix%table%N+1 - do j=1,colcounter(i) - call append(forcematrix%table, tmpcolumns(i,j), tmpmatrix(i,j)) - end do - end do - ! put in last row value - forcematrix%rows(i) = forcematrix%table%N+1 - - deallocate(tmpmatrix) - deallocate(tmpcolumns) - deallocate(colcounter) - - ! print it - if(value(mainlog%verbosity_stack) .ge. PRINT_NERD) then - call print('Forcematrix:',PRINT_NERD) - call print(forcematrix, PRINT_NERD) - call print('',PRINT_NERD) - end if - end subroutine adjustable_potential_create_forcematrix - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_optimise() - !X - !X the whole point of this module: vary the adjustable parameters - !X to minimize the force_error() - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine adjustable_potential_optimise(atoms_in, fitforce, fromscratch, method, prec_func, parallel_svd) - type(Atoms), intent(in):: atoms_in - real(dp), dimension(:,:), intent(in):: fitforce - logical, optional :: fromscratch - - logical :: do_fromscratch - character(len=*),optional,intent(in):: method - logical, optional, intent(in) :: parallel_svd - logical::do_svd, do_parallel_svd - integer, parameter::nparam = adjustable_potential_nparams - integer::nparamtot, bad_spring - real(dp), allocatable::params(:) - integer::steps, i, shift(3), k - real(dp):: err, ferr(3, atomlist%N) - real(dp), parameter::eigenvalue_threshold=1e-10_dp - real(dp), allocatable::full_forcematrix(:,:), X(:,:), S(:), WORK(:), precondition(:) - integer::LWORK, INFO, maxmn, minmn, M,N, RANK, a1, a2, error_code - optional :: prec_func - - interface - function prec_func(r) - use System_module - real(dp), intent(in) :: r - real(dp) :: prec_func - end function prec_func - end interface - - if(twobody%N == 0) then - call print("There are no parameters to optimise") - return - end if - - do_fromscratch = .true. - if(present(fromscratch)) do_fromscratch = fromscratch - - do_svd = .true. - if(present(method)) then - if(trim(method) .eq. "SVD") then - do_svd = .true. - else if(trim(method) .eq. "minim") then - do_svd = .false. - else - call system_abort("Adjustable_potential_optimise: invalid method '" // trim(method) // "'") - end if - end if - - !If the chosen method is SVD then the default is to run serially to - !avoid memory bottlenecks when all processors do SVD. - do_parallel_svd = optional_default(.false.,parallel_svd) - - if(size(target_force) /= size(fitforce)) & - call system_abort("adjustable_potential_optimise: target force is wrong size") - - ! Calculate preconditioning factors for each spring - allocate(precondition(twobody%N)) - if (present(prec_func)) then - do i=1,twobody%N - a1 = atomlist%int(1,twobody%int(1,i)) - a2 = atomlist%int(1,twobody%int(2,i)) - shift = twobody%int(3:5,i) - precondition(i) = prec_func(distance(atoms_in, a1, a2, shift)) - end do - else - precondition = 1.0_dp - end if - - ! create matrices for fast evaluation - call adjustable_potential_create_forcematrix(atoms_in, precondition) - - - target_force = reshape(fitforce, (/size(target_force)/)) - - nparamtot = twobody%N*nparam - allocate(params(nparamtot)) - - if(.not.adjustable_potential_initialised) & - call system_abort("adjustable_potential_optimise: not initialised!") - - call print("Target force:", PRINT_NERD) - call print(target_force, PRINT_NERD) - - call print('Optimising '//nparamtot//' adjustable parameters') - call print("RMS force component error before optimisation : "// & - sqrt(normsq(target_force)/(real(atomlist%N,dp)*3.0_dp))) - call print("Max force component error before optimisation : "//& - maxval(abs(target_force))) - - if(do_fromscratch) then - params = 0.0_dp - else - params = reshape(twobody%real(2:1+nparam,1:twobody%N), (/nparamtot/)) - endif - - if(do_svd) then - -#ifdef _MPI - - if (do_parallel_svd .or. mpi_id()==0) then - -#endif - - ! Solution by SVD - call print('Using SVD for least squares fit, eigenvalue threshold = '//eigenvalue_threshold) - allocate(full_forcematrix(size(target_force), size(params))) - full_forcematrix = forcematrix - M = size(full_forcematrix,1) - N = size(full_forcematrix,2) - minmn = minval((/M,N/)) - maxmn = maxval((/M,N/)) - allocate(X(maxmn,1)) - allocate(S(minmn)) - - allocate(WORK(1)) - - X(1:M,1) = target_force - - ! Do a workspace query first - call dgelss(M, N, 1, full_forcematrix, M, X,maxmn,S, eigenvalue_threshold, RANK, WORK, -1, INFO ) - - ! Allocate optimal size workspace - LWORK = WORK(1) - deallocate(WORK) - allocate(WORK(LWORK)) - - ! Do the SVD - call dgelss(M, N, 1, full_forcematrix, M, X,maxmn,S, eigenvalue_threshold, RANK, WORK, LWORK, INFO ) - - if (INFO /= 0) then - call system_abort('adjustable_potential_optimise: DGELSS failed with error code '//INFO) - end if - - params = X(1:N,1) - deallocate(WORK) - deallocate(S) - deallocate(X) - deallocate(full_forcematrix) - -#ifdef _MPI - - endif - - !Broadcast the params to each process if SVD only done on proc 0 - if (.not.do_parallel_svd) then - call MPI_BCAST(params,size(params),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,error_code) - !check for errors - call abort_on_mpi_error(error_code, "Adjustable_Potentia_Optimise: Params MPI_Bcast()") - end if - -#endif - - else - !! Solution by minimisation - steps = minim(params,& - adjustable_potential_force_error, & - adjustable_potential_force_error_deriv,& - "cg",1e-10_dp,1000,"FAST_LINMIN") - end if - - - ! compute RMS after optimisation - err = sqrt(adjustable_potential_force_error(params)/(real(atomlist%N,dp)*3.0_dp)) - - ! Print all magnitudes of force errors if we're a NERD - call print('Force errors', PRINT_NERD) - ferr = reshape(target_force - (forcematrix .mult. params), & - (/3, atomlist%N/)) - -!!$ call print('sparse force=') -!!$ call Print(forcematrix .mult. params) -!!$ call print('') - - do i=1,atomlist%N - write (line, '(i4,f12.6)') i, sqrt(normsq(ferr(:,i))) - call print(line, PRINT_NERD) - end do - call Print('', PRINT_NERD) - - write(line, '(a,e10.2)') "RMS force component error after optimisation : ", err - call print(line) - write(line, '(a,e10.2)') "Max force component error after optimisation : ", & - maxval(abs(target_force - (forcematrix .mult. params))) - call print(line) - - if (value(mainlog%verbosity_stack) >= PRINT_NERD) then - call Print('Final Springs:', PRINT_NERD) - do i=1,twobody%N - write (line, '(3i8,4f16.8)') i, atomlist%int(1,twobody%int(1,i)), atomlist%int(1,twobody%int(2,i)), twobody%real(1,i), precondition(i), params(i), params(i)*precondition(i) - call Print(line, PRINT_NERD) - end do - call Print('', PRINT_NERD) - end if - - ! Get physical spring constants by multiplying by precondition factor - do i=1,twobody%N - params(i) = params(i)*precondition(i) - end do - - twobody%real(2:1+nparam,1:twobody%N) = reshape(params, (/nparam,twobody%N/)) - - write(line, '(a,e10.2)') "Max abs spring constant after optimisation : ", maxval(abs(params)) - call print(line) - - if (maxval(abs(params)) > adjustable_potential_max_spring_constant) then - write(line, '(a,f10.2)') "WARNING: Max spring constant value after optimisation is large : ", & - maxval(abs(params)) - call print(line) - bad_spring = maxloc(abs(params),1) - write(line,'(2(a,i0))')' Max spring constant belongs to spring ', & - atomlist%int(1,twobody%int(1,bad_spring)),'--',atomlist%int(1,twobody%int(2,bad_spring)) - call print(line) - end if - - call print('') - - deallocate(params) - deallocate(precondition) - - ! calculate new parameter derivatives - do i=1,min(twobody%N,twobody_old%N) - do k=1,nparam - twobody%real(1+nparam+k,i) = twobody_old%real(1+nparam+k, i)+2.0_dp*(twobody%real(1+k,i)-twobody_old%real(1+k,i)-twobody_old%real(1+nparam+k,i)) - end do - end do - - ! Save the old fit force - if (allocated(fitforce_old)) deallocate(fitforce_old) - allocate(fitforce_old(size(fitforce,1),size(fitforce,2))) - fitforce_old = fitforce - - end subroutine adjustable_potential_optimise - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X adjustable_potential_print_params() - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine adjustable_potential_print_params() - real(dp)::f(size(target_force)) - integer::np - - if(.not.adjustable_potential_initialised) & - call system_abort("adjustable_potential_print_params: not initialised!") - - - write(line,*) "Atoms Shift Parameters" ; call print(line) - write(line,*) "-----------------------------------------------------" - call print(line) - call print(twobody) - write(line, *) ; call print(line) - - - write(line, *) "Force matrix: " ; call print(line) - write(line, *) ; call print(line) - call print_full(forcematrix) - write(line, *) ; call print(line) - - write(line,*) "Forces from force matrix:" ; call print( line) - np = twobody%N*adjustable_potential_nparams - f = adjustable_potential_force_sparse(reshape(twobody%real(2:1+adjustable_potential_nparams,1:twobody%N), (/np/))) - call print(transpose(reshape(f, (/3,atomlist%N/)))) - write(line, *) ; call print(line) - - end subroutine adjustable_potential_print_params - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !X Set up, alter and query the exclusion list - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - subroutine adjustable_potential_add_exclusion(atom1,atom2,shift) - - integer, intent(in) :: atom1,atom2,shift(3) - - if (atom1 == atom2) then - call print_message('WARNING', 'Adjustable_Potential_Add_Exclusion: Atom1 = Atom2') - return - end if - - if (.not.exclusions) then !Set up the exclusion table - call allocate(exclusion_list,5,0,0,0) - exclusions = .true. - end if - - !Append (/a, b, shift/) where a < b - if (atom1 < atom2) then - call append(exclusion_list,(/atom1,atom2,shift/)) - else - call append(exclusion_list,(/atom2,atom1,-shift/)) - end if - - end subroutine adjustable_potential_add_exclusion - - subroutine adjustable_potential_delete_exclusion(atom1,atom2,shift) - - integer, intent(in) :: atom1, atom2, shift(3) - - if (atom1 < atom2) then - call delete(exclusion_list,(/atom1,atom2,shift/)) - else - call delete(exclusion_list,(/atom2,atom1,-shift/)) - end if - - if (exclusion_list%N == 0) then - call finalise(exclusion_list) - exclusions = .false. - end if - - end subroutine adjustable_potential_delete_exclusion - - function is_excluded(atom1,atom2, shift) - - integer, intent(in) :: atom1, atom2, shift(3) - logical :: Is_Excluded - - if (atom1 < atom2) then - if (find(exclusion_list,(/atom1,atom2,shift/))==0) then - Is_Excluded = .false. - else - Is_Excluded = .true. - end if - else - if (find(exclusion_list,(/atom2,atom1,-shift/))==0) then - Is_Excluded = .false. - else - Is_Excluded = .true. - end if - - end if - - end function is_excluded - -end module AdjustablePotential_module - diff --git a/src/Potentials/ApproxFermi.f95 b/src/Potentials/ApproxFermi.f95 deleted file mode 100644 index c8f51269fb..0000000000 --- a/src/Potentials/ApproxFermi.f95 +++ /dev/null @@ -1,293 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X ApproxFermi module -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -module ApproxFermi_module - -use System_module -use linearalgebra_module ! for .feq. -use Units_module -use Functions_module - -implicit none - -private - -public :: ApproxFermi -type ApproxFermi - integer :: n_poles = 0 - complex(dp), allocatable :: a(:), z(:) - real(dp) :: Fermi_E, band_width -end type ApproxFermi - -public :: Initialise -interface Initialise - module procedure ApproxFermi_Initialise, ApproxFermi_Initialise_lowlevel -end interface Initialise - -public :: Finalise -interface Finalise - module procedure ApproxFermi_Finalise -end interface Finalise - -public :: Wipe -interface Wipe - module procedure ApproxFermi_Wipe -end interface Wipe - -public :: Print -interface Print - module procedure ApproxFermi_Print -end interface Print - -public :: approx_f_fermi, approx_f_fermi_deriv - -contains - -subroutine ApproxFermi_Finalise(this) - type(ApproxFermi), intent(inout) :: this - - call Wipe(this) - -end subroutine - -subroutine ApproxFermi_Wipe(this) - type(ApproxFermi), intent(inout) :: this - - if (allocated(this%a)) deallocate(this%a) - if (allocated(this%z)) deallocate(this%z) - this%n_poles = 0 - -end subroutine - -subroutine ApproxFermi_Print(this,out) - type(ApproxFermi), intent(in) :: this - type(Inoutput), intent(inout),optional:: out - - integer::i - - call Print('ApproxFermi: Fermi_E ' // this%Fermi_E // ' band_width ' // this%band_width // ' n_poles ' // this%n_poles, file=out) - - if (this%n_poles > 0) then - do i=1, size(this%a) - call Print ('GreensFunc : a z ' // i // ' ' // this%a(i) // ' ' // this%z(i), PRINT_VERBOSE, out) - end do - endif - -end subroutine ApproxFermi_Print - -subroutine ApproxFermi_Initialise(this, Fermi_E, Fermi_T, band_width) - type(ApproxFermi), intent(inout) :: this - real(dp), intent(in) :: Fermi_E, Fermi_T, band_width - - call Finalise(this) - - call calc_poles_from_T(this, Fermi_E, Fermi_T, band_width) - -end subroutine - -subroutine ApproxFermi_Initialise_lowlevel(this, n_poles, Fermi_E, band_width) - type(ApproxFermi), intent(inout) :: this - integer, intent(in) :: n_poles - real(dp), intent(in) :: Fermi_E, band_width - - call calc_poles(this, Fermi_E, n_poles, band_width) - -end subroutine - -subroutine calc_poles(this, Fermi_E, n_poles, band_width) - type(ApproxFermi), intent(inout) :: this - real(dp), intent(in) :: Fermi_E, band_width - integer, intent(in) :: n_poles - - if (n_poles == 0 .or. (band_width .feq. 0.0_dp)) then - call system_abort("Can't calc_poles with n_poles or band_width = 0") - endif - - this%Fermi_E = Fermi_E - this%n_poles = n_poles - this%band_width = band_width - - if (allocated(this%a)) then - if (size(this%a) /= this%n_poles) deallocate(this%a) - endif - if (allocated(this%z)) then - if (size(this%z) /= this%n_poles) deallocate(this%z) - endif - - if (.not.allocated(this%z)) allocate(this%z(this%n_poles)) - if (.not.allocated(this%a)) allocate(this%a(this%n_poles)) - - call calc_pole_values(this) - -end subroutine calc_poles - -subroutine calc_poles_from_T(this, Fermi_E, Fermi_T, band_width) - type(ApproxFermi), intent(inout) :: this - real(dp), intent(in) :: Fermi_E, Fermi_T, band_width - - if (band_width .feq. 0.0_dp) then - call system_abort("Can't calc_poles_from_T with band_width = 0") - endif - - this%n_poles = guess_n_poles(Fermi_T, band_width, this%band_width) - - call calc_poles(this, Fermi_E, this%n_poles, this%band_width) - -end subroutine calc_poles_from_T - -function guess_n_poles(Fermi_T, band_width_in, band_width) - real(dp), intent(in) :: Fermi_T, band_width_in - real(dp), intent(out) :: band_width - integer :: guess_n_poles - - type(ApproxFermi) t_AF - real(dp) :: Fermi_slope, AF_slope - integer np - - Fermi_slope = f_Fermi_deriv(0.0_dp, Fermi_T, 0.0_dp) - - do np=4, 1000, 4 - call Initialise(t_AF, np, 0.0_dp, band_width_in) - AF_slope = approx_f_Fermi_deriv(t_AF, 0.0_dp) - if (AF_slope < Fermi_slope) then - guess_n_poles = np - band_width = band_width_in*(AF_slope/Fermi_slope) - return - endif - call Finalise(t_AF) - end do - - call system_abort ("Couldn't find appropriate band_width and n_poles in guess_n_poles") - -end function guess_n_poles - -elemental function approx_f_Fermi(this, E) - type(ApproxFermi), intent(in) :: this - real(dp), intent(in) :: E - real(dp) :: approx_f_Fermi - - integer i - - approx_f_Fermi = 0.0_dp - do i=1, this%n_poles - approx_f_Fermi = approx_f_Fermi + this%a(i)/(E-this%z(i)) - end do - -end function approx_f_Fermi - -elemental function approx_f_Fermi_deriv(this, E) - type(ApproxFermi), intent(in) :: this - real(dp), intent(in) :: E - real(dp) :: approx_f_Fermi_deriv - - integer i - - approx_f_Fermi_deriv = 0.0_dp - do i=1, this%n_poles - approx_f_Fermi_deriv = approx_f_Fermi_deriv - this%a(i)/((E-this%z(i))**2) - end do - -end function approx_f_Fermi_deriv - -subroutine calc_pole_values(this) - type(ApproxFermi), intent(inout) :: this - - integer :: n_poles - real(dp) :: n_poles_d - - complex(dp) :: a, b, c, aa, bb, cc, x - integer i, j - real(dp) i_d - - real(dp) :: gamma, x_bot, scale, shift - ! real(dp) :: f_max - - n_poles = this%n_poles * 2 - n_poles_d = n_poles - - gamma = 3.0_dp-sqrt(8.0_dp) - ! f_max = 1.0_dp/( ((4.0_dp*((1.0_dp-gamma)**-2) - 1.0_dp)**(n_poles_d/2)) + 1.0_dp ) - x_bot = -4.0_dp*(2.0_dp*n_poles_d-12.0_dp+6.0_dp*gamma)/((1.0_dp+gamma)**2) - - do i=1, this%n_poles/2 - i_d = i-1 - a = (1.0_dp + gamma) / (2.0_dp*n_poles_d) - b = (1.0_dp - gamma) / (n_poles_d) - c = cmplx( cos(PI/(n_poles_d/2.0_dp) + i_d*PI/(n_poles_d/4.0_dp)), & - sin(PI/(n_poles_d/2.0_dp) + i_d*PI/(n_poles_d/4.0_dp)), dp ) - - aa = a*a - bb = (2.0_dp*a + b*c) - cc = (1.0_dp-c) - - this%z(i) = conjg ( (-bb - sqrt(bb*bb - 4.0_dp*aa*cc) ) / (2.0_dp * aa) ) - this%z(n_poles/2-i+1) = (-bb + sqrt(bb*bb - 4.0_dp*aa*cc) ) / (2.0_dp * aa) - end do - - do i=1, this%n_poles/2 - x = this%z(i) - this%z(i) = this%z(this%n_poles-i+1) - this%z(this%n_poles-i+1) = x - end do - - scale = -this%band_width/x_bot - shift = this%Fermi_E - - do i=1, this%n_poles - this%z(i) = this%z(i) * scale + shift - end do - - do i=1, this%n_poles - x = this%z(i) - - this%a(i) = (scale**(n_poles/2))*((1.0_dp-((x-shift)/scale)*(1.0_dp-gamma)/n_poles_d)**(n_poles/2)) - - do j=1, this%n_poles - if (j == i) then - this%a(i) = scale*(((n_poles_d*2.0_dp)/(1.0_dp+gamma))**2)*this%a(i) / & - (x-conjg(this%z(j))) - else - this%a(i) = scale*(((n_poles_d*2.0_dp)/(1.0_dp+gamma))**2)*this%a(i) / & - ( (x-this%z(j))*(x-conjg(this%z(j))) ) - endif - end do - - this%a(i) = this%a(i) * 2.0_dp - end do - -end subroutine - -end module ApproxFermi_module diff --git a/src/Potentials/CallbackPot.f95 b/src/Potentials/CallbackPot.f95 deleted file mode 100644 index 66cebad88b..0000000000 --- a/src/Potentials/CallbackPot.f95 +++ /dev/null @@ -1,310 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Callbackpot Module -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" -module Callbackpot_module - -use error_module -use system_module, only : dp, inoutput, print, current_verbosity, PRINT_NORMAL, operator(//) -use mpi_context_module -use dictionary_module -use paramreader_module -use atoms_types_module -use atoms_module - -implicit none -private - -integer, parameter :: MAX_CALLBACKS = 200 -integer :: n_callbacks = 0 - -public :: Callbackpot_type -type CallbackPot_type - character(len=STRING_LENGTH) :: init_args_str - character(len=STRING_LENGTH) :: label - integer :: callback_id - type(MPI_context) :: mpi -end type CallbackPot_type - -public :: Initialise -interface Initialise - module procedure Callbackpot_Initialise -end interface Initialise - -public :: Finalise -interface Finalise - module procedure Callbackpot_Finalise -end interface Finalise - -public :: cutoff -interface cutoff - module procedure Callbackpot_cutoff -end interface - -public :: Wipe -interface Wipe - module procedure Callbackpot_Wipe -end interface Wipe - -public :: Print -interface Print - module procedure Callbackpot_Print -end interface Print - -public :: calc -interface calc - module procedure Callbackpot_Calc -end interface - -public :: set_callback -interface set_callback - module procedure callbackpot_set_callback -end interface - - -interface - subroutine register_callbackpot_sub(sub) - interface - subroutine sub(at) - integer, intent(in) :: at(12) - end subroutine sub - end interface - end subroutine register_callbackpot_sub -end interface - -interface - subroutine call_callbackpot_sub(i,at) - integer, intent(in) :: at(12) - integer, intent(in) :: i - end subroutine call_callbackpot_sub -end interface - - -contains - - -subroutine Callbackpot_Initialise(this, args_str, mpi, error) - type(Callbackpot_type), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='CallbackPot_initialise')) then - RAISE_ERROR('CallbackPot_Initialise failed to parse args_str="'//trim(args_str)//"'", error) - endif - call finalise(params) - - this%init_args_str = args_str - if (present(mpi)) this%mpi = mpi - -end subroutine Callbackpot_Initialise - -subroutine callbackpot_set_callback(this, callback, error) - type(Callbackpot_type), intent(inout) :: this - interface - subroutine callback(at) - integer, intent(in) :: at(12) - end subroutine callback - end interface - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if (n_callbacks >= MAX_CALLBACKS) then - RAISE_ERROR('CallbackPot_Initialise: Too many registered callback routines', error) - endif - this%callback_id = n_callbacks - n_callbacks = n_callbacks + 1 - call register_callbackpot_sub(callback) - -end subroutine Callbackpot_Set_callback - -subroutine Callbackpot_Finalise(this) - type(Callbackpot_type), intent(inout) :: this - - call wipe(this) - -end subroutine Callbackpot_Finalise - -subroutine Callbackpot_Wipe(this) - type(Callbackpot_type), intent(inout) :: this - - this%callback_id = -1 - -end subroutine Callbackpot_Wipe - -function Callbackpot_cutoff(this) - type(Callbackpot_type), intent(in) :: this - real(dp) :: Callbackpot_cutoff - Callbackpot_cutoff = 0.0_dp ! return zero, because Callbackpot does its own connection calculation -end function Callbackpot_cutoff - -subroutine Callbackpot_Print(this, file) - type(Callbackpot_type), intent(in) :: this - type(Inoutput), intent(inout),optional,target:: file - - if (current_verbosity() < PRINT_NORMAL) return - - call print("Callbackpot: callback_id="//this%callback_id) - call print("Callbackpot: label="//this%label) - -end subroutine Callbackpot_Print - -subroutine Callbackpot_Calc(this, at, energy, local_e, forces, virial, local_virial, args_str, error) - type atoms_ptr_type - type(atoms), pointer :: p - end type atoms_ptr_type - type(Callbackpot_type), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: energy - real(dp), intent(out), target, optional :: local_e(:) - real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) - real(dp), intent(out), optional :: virial(3,3) - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - type(Atoms), target :: at_copy - type(atoms_ptr_type) :: at_ptr - integer :: at_ptr_i(12) - real(dp), pointer :: local_e_ptr(:), force_ptr(:,:), local_virial_ptr(:,:) - logical :: calc_energy, calc_local_e, calc_force, calc_virial, calc_local_virial - - INIT_ERROR(error) - - calc_energy = .false. - calc_local_e = .false. - calc_force = .false. - calc_virial = .false. - calc_local_virial = .false. - if (present(energy)) then - energy = 0.0_dp - calc_energy = .true. - end if - if (present(local_e)) then - local_e = 0.0_dp - calc_local_e = .true. - end if - if (present(forces)) then - forces = 0.0_dp - calc_force = .true. - end if - if (present(virial)) then - virial = 0.0_dp - calc_virial = .true. - end if - if (present(local_virial)) then - local_virial = 0.0_dp - calc_local_virial = .true. - end if - - if (this%callback_id < 0) then - RAISE_ERROR('callbackpot_calc: callback_id < 0', error) - endif - - at_copy = at - call set_value(at_copy%params, 'calc_energy', calc_energy) - call set_value(at_copy%params, 'calc_local_e', calc_local_e) - call set_value(at_copy%params, 'calc_virial', calc_virial) - call set_value(at_copy%params, 'calc_force', calc_force) - call set_value(at_copy%params, 'calc_local_virial', calc_local_virial) - call set_value(at_copy%params, 'callback_id', this%callback_id) - call set_value(at_copy%params, 'label', this%label) - if (present(args_str)) then - call set_value(at_copy%params, 'calc_args_str', args_str) - end if - - at_ptr%p => at_copy - at_ptr_i = transfer(at_ptr, at_ptr_i) - call call_callbackpot_sub(this%callback_id, at_ptr_i) - - if (present(energy)) then - if (.not. get_value(at_copy%params, 'energy', energy)) then - call print('WARNING Callbackpot_calc: "energy" requested but not returned by callback') - endif - end if - - if (present(local_e)) then - if (.not. assign_pointer(at_copy, 'local_e', local_e_ptr)) then - call print('WARNING Callbackpot_calc: "local_e" requested but not returned by callback') - else - local_e(:) = local_e_ptr - end if - end if - - if (present(forces)) then - if (.not. assign_pointer(at_copy, 'force', force_ptr)) then - call print('WARNING Callbackpot_calc: "forces" requested but not returned by callback') - else - forces(:,:) = force_ptr - end if - end if - - if (present(virial)) then - if (.not. get_value(at_copy%params, 'virial', virial)) then - call print('WARNING Callbackpot_calc: "virial" requested but not returned by callback') - end if - end if - - if (present(local_virial)) then - if (.not. assign_pointer(at_copy, 'local_virial', local_virial_ptr)) then - call print('WARNING Callbackpot_calc: "local_virial" requested but not returned by callback') - else - local_virial(:,:) = local_virial_ptr - end if - end if - - if (this%mpi%active) then - ! Share results with other nodes - if (present(energy)) call bcast(this%mpi, energy) - if (present(local_e)) call bcast(this%mpi, local_e) - - if (present(forces)) call bcast(this%mpi, forces) - if (present(virial)) call bcast(this%mpi, virial) - if (present(local_virial)) call bcast(this%mpi, local_virial) - end if - - call finalise(at_copy) - -end subroutine Callbackpot_calc - -end module Callbackpot_module diff --git a/src/Potentials/ElectrostaticEmbed.f95 b/src/Potentials/ElectrostaticEmbed.f95 deleted file mode 100644 index a0d5de2d50..0000000000 --- a/src/Potentials/ElectrostaticEmbed.f95 +++ /dev/null @@ -1,544 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!% ElectrostaticEmbed - tools for electrostatic embedding of potentials - -#include "error.inc" - -module ElectrostaticEmbed_module - - use error_module - use system_module, only : dp, inoutput, optional_default, initialise, OUTPUT, operator(//), system_timer - use units_module - use periodictable_module - use linearalgebra_module - use dictionary_module - use connection_module - use atoms_types_module - use atoms_module - use clusters_module - - use QUIP_Common_module - use Functions_module - use Potential_module -#ifdef HAVE_THIRDPARTY - use cube_tools -#endif - - implicit none - private - - integer, private, parameter :: nspins = 2 - - public :: extent_to_ngrid, assign_grid_coordinates, calc_electrostatic_potential, & -#ifdef HAVE_THIRDPARTY - write_electrostatic_potential_cube, & -#endif - make_periodic_potential - -contains - - subroutine extent_to_ngrid(extent, fine_gmax, ngrid) - real(dp), intent(in) :: extent(3), fine_gmax - integer, intent(out) :: ngrid(3) - - integer i - - do i=1,3 - ngrid(i) = ceiling(fine_gmax*extent(i)/BOHR/PI) - call round_prime_factors(ngrid(i)) - end do - - end subroutine extent_to_ngrid - - subroutine assign_grid_coordinates(ngrid, origin, extent, grid_size, r_real_grid) - integer, intent(in) :: ngrid(3) - real(dp), intent(in) :: origin(3), extent(3) - real(dp), intent(out) :: grid_size(3) - real(dp), dimension(:,:), intent(out) :: r_real_grid - - real(dp) :: lattice(3,3) - integer :: nx, ny, nz, point - - lattice(:,:) = 0.0_dp - lattice(1,1) = extent(1) - lattice(2,2) = extent(2) - lattice(3,3) = extent(3) - - point = 0 - do nz=1,ngrid(3) - do ny=1,ngrid(2) - do nx=1,ngrid(1) - - point=point+1 - - r_real_grid(1,point) = real(nx-1,dp)*lattice(1,1)/real(ngrid(1),dp) +& - & real(ny-1,dp)*lattice(2,1)/real(ngrid(2),dp) +& - & real(nz-1,dp)*lattice(3,1)/real(ngrid(3),dp) + origin(1) - r_real_grid(2,point) = real(nx-1,dp)*lattice(1,2)/real(ngrid(1),dp) +& - & real(ny-1,dp)*lattice(2,2)/real(ngrid(2),dp) +& - & real(nz-1,dp)*lattice(3,2)/real(ngrid(3),dp) + origin(2) - r_real_grid(3,point) = real(nx-1,dp)*lattice(1,3)/real(ngrid(1),dp) +& - & real(ny-1,dp)*lattice(2,3)/real(ngrid(2),dp) +& - & real(nz-1,dp)*lattice(3,3)/real(ngrid(3),dp) + origin(3) - - end do - end do - end do - - grid_size(1) = extent(1)/real(ngrid(1), dp) - grid_size(2) = extent(2)/real(ngrid(2), dp) - grid_size(3) = extent(3)/real(ngrid(3), dp) - - end subroutine assign_grid_coordinates - -#ifdef HAVE_THIRDPARTY - subroutine write_electrostatic_potential_cube(at, filename, ngrid, origin, extent, pot, & - write_efield, flip_sign, convert_to_atomic_units, error) - type(Atoms), intent(inout) :: at - character(len=*), intent(in) :: filename - integer, intent(in) :: ngrid(3) - real(dp), intent(in) :: origin(3), extent(3) - real(dp), dimension(:,:,:), intent(in) :: pot - logical, optional, intent(in) :: write_efield, flip_sign, convert_to_atomic_units - integer, optional, intent(out) :: error - - type(InOutput) :: out - type(cube_type) :: cube - type(Dictionary) :: metadata - integer i, j, n, z!, na, nb, nc - real(dp), pointer, dimension(:) :: charge, es_pot - real(dp), pointer, dimension(:,:) :: es_efield - integer, dimension(size(ElementMass)) :: nsp - logical do_efield, do_atomic_units, do_flip_sign - - INIT_ERROR(error) - - do_efield = optional_default(.true., write_efield) - do_flip_sign = optional_default(.false., flip_sign) - do_atomic_units = optional_default(.true., convert_to_atomic_units) - - if (do_efield) then - call assign_property_pointer(at, 'es_pot', es_pot, error) - PASS_ERROR(error) - - call assign_property_pointer(at, 'es_efield', es_efield, error) - PASS_ERROR(error) - else - call assign_property_pointer(at, 'charge', charge, error) - PASS_ERROR(error) - end if - - call cube_clear(cube) - cube%comment1 = trim(filename) - cube%N = at%n - cube%r0 = real(origin) - cube%na = ngrid(1)+1 - cube%nb = ngrid(2)+1 - cube%nc = ngrid(3)+1 - - ! Size of voxels - cube%da = 0.0_dp; cube%da(1) = real(extent(1)/ngrid(1)) - cube%db = 0.0_dp; cube%db(2) = real(extent(2)/ngrid(2)) - cube%dc = 0.0_dp; cube%dc(3) = real(extent(3)/ngrid(3)) - - ! We sort atoms by atomic number for compatibility with CASTEP - - ! Count number of each species - nsp(:) = 0 - do i=1,at%n - nsp(at%z(i)) = nsp(at%z(i)) + 1 - end do - - ! Fill in atomic information - allocate(cube%atoms(cube%n)) - n = 0 - do z = 1,size(nsp) - if (nsp(z) == 0) cycle - - do j=1,at%n - if (at%z(j) /= z) cycle - - n = n + 1 - cube%atoms(n)%number = at%z(j) - if (do_efield) then - ! Potential on ions and electric field - cube%atoms(n)%unknown = real(es_pot(j)) - if (do_flip_sign) cube%atoms(n)%unknown = -cube%atoms(n)%unknown - cube%atoms(n)%r(:) = real(es_efield(:,j)) - if (do_flip_sign) cube%atoms(n)%r = -cube%atoms(n)%r - else - ! Charge and position of ions - cube%atoms(n)%unknown = real(charge(j)) - cube%atoms(n)%r(:) = real(at%pos(:,j)) - end if - end do - end do - - ! Fill in volumetric information - note conversion to single precision - cube%NMOs=1 - allocate(cube%voxels(cube%na,cube%nb,cube%nc,cube%NMOs)) - cube%voxels(1:cube%na-1,1:cube%nb-1,1:cube%nc-1,1) = real(pot) - - ! periodic boundary conditions: in cube file format, values of - ! n{a,b,c}=1 entries are repeated at n{a,b,c} = cube%n{a,b,c} - cube%voxels(cube%na,:,:,1) = real(cube%voxels(1,:,:,1)) - cube%voxels(:,cube%nb,:,1) = real(cube%voxels(:,1,:,1)) - cube%voxels(:,:,cube%nc,1) = real(cube%voxels(:,:,1,1)) - - if (do_flip_sign) cube%voxels = -cube%voxels - - if (do_atomic_units) then - cube%da = cube%da/BOHR - cube%db = cube%db/BOHR - cube%dc = cube%dc/BOHR - cube%r0 = cube%r0/BOHR - cube%voxels = cube%voxels/HARTREE ! convert potential to Hartree - if (do_efield) then - ! convert potential and electric field to atomic units - do n=1,cube%n - cube%atoms(n)%unknown = cube%atoms(n)%unknown/HARTREE - cube%atoms(n)%r(:) = cube%atoms(n)%r(:)/(HARTREE/BOHR) - end do - else - ! convert positions to bohr - do n=1,cube%n - cube%atoms(n)%r = cube%atoms(n)%r/BOHR - end do - end if - end if - - ! Write meta-data into second line of .cube file - call initialise(metadata) - call set_value(metadata, 'volumetric_data', 'electrostatic_potential') - if (do_atomic_units) then - call set_value(metadata, 'units', 'atomic') - else - call set_value(metadata, 'units', 'eV_A_fs') - end if - if (do_efield) then - call set_value(metadata, 'atom_data', 'z:pot:efield') - else - call set_value(metadata, 'atom_data', 'z:charge:pos') - end if - cube%comment2 = write_string(metadata) - call finalise(metadata) - - call initialise(out, filename, OUTPUT) - call cube_write(cube, out%unit, error) - PASS_ERROR(error) - call finalise(out) - deallocate(cube%atoms) - deallocate(cube%voxels) - - end subroutine write_electrostatic_potential_cube -#endif - - subroutine make_periodic_potential(at, real_grid, ngrid, is_periodic, cutoff_radius, cutoff_width, mark_name, pot, error) - type(Atoms), intent(inout) :: at - real(dp), dimension(:,:), intent(in) :: real_grid - integer, intent(in) :: ngrid(3) - logical, intent(in) :: is_periodic(3) - real(dp), intent(in) :: cutoff_radius, cutoff_width - character(len=*), intent(in) :: mark_name - real(dp), intent(inout) :: pot(:,:,:) - integer, optional, intent(out) :: error - - integer i,j,k,a,igrid, nsurface, cell_image_Na, cell_image_Nb, cell_image_Nc - logical save_is_periodic(3), dir_mask(3) - real(dp) :: cutoff, surface_avg, d(3), fc, dfc, masked_d - logical, dimension(:), allocatable :: atom_mask - integer, pointer, dimension(:) :: mark - - INIT_ERROR(error) - - call print('is_periodic = '//is_periodic) - save_is_periodic = at%is_periodic - at%is_periodic = is_periodic - dir_mask = .not. is_periodic - call calc_connect(at) - call print('at%is_periodic = '//at%is_periodic//' dir_mask='//dir_mask) - - ! Calculate average value of potential on open surfaces - nsurface = 0 - surface_avg = 0.0_dp - if (dir_mask(1)) then - surface_avg = surface_avg + sum(pot(1,:,:)) + sum(pot(ngrid(1),:,:)) - nsurface = nsurface + 2*ngrid(2)*ngrid(3) - end if - if (dir_mask(2)) then - surface_avg = surface_avg + sum(pot(:,1,:)) + sum(pot(:,ngrid(2),:)) - nsurface = nsurface + 2*ngrid(1)*ngrid(3) - end if - if (dir_mask(3)) then - surface_avg = surface_avg + sum(pot(:,:,1)) + sum(pot(:,:,ngrid(3))) - nsurface = nsurface + 2*ngrid(1)*ngrid(2) - end if - surface_avg = surface_avg/nsurface - - if (.not. assign_pointer(at, mark_name, mark)) then - RAISE_ERROR('make_periodic_potential: failed to assign pointer to "'//trim(mark_name)//'" property', error) - end if - allocate(atom_mask(at%n)) - atom_mask = mark /= HYBRID_ELECTROSTATIC_MARK - - call fit_box_in_cell(cutoff_radius+cutoff_width, cutoff_radius+cutoff_width, cutoff_radius+cutoff_width, & - at%lattice, cell_image_Na, cell_image_Nb, cell_image_Nc) - cell_image_Na = max(1,(cell_image_Na+1)/2) - cell_image_Nb = max(1,(cell_image_Nb+1)/2) - cell_image_Nc = max(1,(cell_image_Nc+1)/2) - - ! Smoothly interpolate potential to surface_avg away from atoms - igrid = 0 - do k=1,ngrid(3) - do j=1,ngrid(2) - do i=1,ngrid(1) - igrid = igrid + 1 - a = closest_atom(at, real_grid(:,igrid), cell_image_Na, cell_image_Nb, cell_image_Nc, mask=atom_mask, diff=d) - - ! project difference vector to mask out periodic directions - masked_d = norm(pack(d, dir_mask)) - - ! if this grid point is on an open surface, check we're at least cutoff_radius + cutoff_width away from closest atom - if (dir_mask(1) .and. i==1 .or. dir_mask(2) .and. j==1 .or. dir_mask(3) .and. k==1) then - if (masked_d < cutoff_radius+cutoff_width) then - RAISE_ERROR('atom '//a//' pos='//at%pos(:,a)//' too close to surface cell=['//i//' '//j//' '//k//'] pos=['//real_grid(:,igrid)//'] d='//masked_d, error) - end if - end if - - call smooth_cutoff(masked_d, cutoff_radius, cutoff_width, fc, dfc) - pot(i,j,k) = pot(i,j,k)*fc + surface_avg*(1.0_dp-fc) - end do - end do - end do - - ! restore periodic directions - at%is_periodic = save_is_periodic - call calc_connect(at) - - deallocate(atom_mask) - - end subroutine make_periodic_potential - - !% Evaluate electrostatic potential on a grid by adding test atoms at grid points - subroutine calc_electrostatic_potential(this, at, cluster, mark_name, ngrid, origin, extent, real_grid, pot, args_str, error) -#ifdef _OPENMP - use omp_lib -#endif - - type(Potential), intent(inout) :: this - type(Atoms), intent(in) :: at - type(Atoms), intent(inout) :: cluster - character(len=*), intent(in) :: args_str, mark_name - integer, intent(in) :: ngrid(3) - real(dp), intent(in) :: origin(3), extent(3) - real(dp), intent(inout) :: real_grid(:,:), pot(:,:,:) - integer, optional, intent(out) :: error - - type(Atoms) :: at_copy - type(Atoms), save :: private_at_copy - real(dp) :: grid_size(3), tmp_cutoff - real(dp), pointer :: at_charge(:), cluster_charge(:), cluster_es_pot(:), cluster_es_efield(:,:), es_pot(:), es_efield(:,:) - real(dp), allocatable :: local_e(:) - integer, pointer, dimension(:) :: mark - integer, allocatable, dimension(:) :: z - integer, allocatable, dimension(:,:) :: lookup - logical, pointer, dimension(:) :: atom_mask, source_mask - logical, allocatable, dimension(:) :: select_mask -#ifdef _OPENMP - logical old_nested -#endif - integer i, j, k, n, igrid, offset, stride, npoint, select_n - - !$omp threadprivate(private_at_copy) - - INIT_ERROR(error) - call system_timer('calc_electrostatic_potential') - - call assign_grid_coordinates(ngrid, origin, extent, grid_size, real_grid) - - - call assign_property_pointer(at, mark_name, mark, error) - PASS_ERROR(error) - - ! Make copy of atoms within cutoff distance of a marked atom - ! so we can add test atoms at grid points - -! allocate(select_mask(at%n)) -! tmp_cutoff = cutoff(this) -! select_mask = .false. -! do i=1,at%n -! dr = diff_min_image(at, at%pos(:,i), origin+extent/2.0_dp) -! if (all(abs(dr(:)) < extent/2.0_dp+tmp_cutoff)) select_mask(i) = .true. -! end do -! call select(at_copy, at, mask=select_mask) -! select_n = at_copy%n -! deallocate(select_mask) - - allocate(select_mask(at%n)) - tmp_cutoff = cutoff(this) - select_mask = .false. - do i=1,at%n - if (mark(i) == HYBRID_NO_MARK) cycle - select_mask(i) = .true. - do j=1,at%n - if (mark(j) /= HYBRID_NO_MARK) cycle - if (distance_min_image(at, i, j) < tmp_cutoff) select_mask(j) = .true. - end do - end do - call select(at_copy, at, mask=select_mask) - select_n = at_copy%n - - call assign_property_pointer(at_copy, mark_name, mark, error) - PASS_ERROR(error) - - call assign_property_pointer(at_copy, 'charge', at_charge, error) - PASS_ERROR(error) - - ! choose balance between number of evaluations and number of simulataneous grid points - npoint = select_n - stride = max(1,size(real_grid, 2)/npoint) - npoint = size(real_grid(:,1:size(real_grid,2):stride), 2) - call print('npoint = '//npoint//' stride = '//stride) - - allocate(z(npoint)) - z(:) = 0 - call add_atoms(at_copy, real_grid(:,1:size(real_grid,2):stride), z) - - ! added atoms so must reassign pointers - if (.not. assign_pointer(at_copy, mark_name, mark)) then - RAISE_ERROR('calc_electrostatic_potential_calc failed to assign pointer to "'//trim(mark_name)//'" property', error) - end if - if (.not. assign_pointer(at_copy, 'charge', at_charge)) then - RAISE_ERROR('calc_electrostatic_potential_calc failed to assign pointer to "charge" property', error) - endif - at_charge(select_n+1:at_copy%n) = 1.0_dp - - ! atom_mask is true for atoms for which we want the local potential energy, i.e grid point atoms - call add_property(at_copy, 'atom_mask', .false., overwrite=.true., ptr=atom_mask, error=error) - PASS_ERROR(error) - atom_mask = .false. - atom_mask(select_n+1:at_copy%n) = .true. - - ! source_mask is true for atoms which should act as electrostatic sources - call add_property(at_copy, 'source_mask', .false., overwrite=.true., ptr=source_mask, error=error) - PASS_ERROR(error) - source_mask(1:select_n) = mark(1:select_n) == HYBRID_ELECTROSTATIC_MARK - source_mask(select_n+1:at_copy%n) = .false. - - call print('calc_electrostatic_potential: evaluating electrostatic potential due to '//count(source_mask)//' sources') - - ! Construct mapping from igrid to (i,j,k) - igrid = 0 - allocate(lookup(3,size(real_grid,2))) - do k=1,ngrid(3) - do j=1,ngrid(2) - do i=1,ngrid(1) - igrid = igrid + 1 - lookup(:,igrid) = (/i,j,k/) - end do - end do - end do - -#ifdef _OPENMP - old_nested = omp_get_nested() - call omp_set_nested(.false.) -#endif - !$omp parallel default(none) shared(at_copy,stride,args_str,grid_size,this,pot,real_grid,select_n,at_charge,lookup) private(local_e,npoint,igrid) - - call atoms_copy_without_connect(private_at_copy, at_copy) - call set_cutoff(private_at_copy, cutoff(this)) - - allocate(local_e(private_at_copy%n)) - - !$omp do - do offset=1,stride - npoint = size(real_grid(:,offset:size(real_grid,2):stride),2) - private_at_copy%n = select_n + npoint - private_at_copy%nbuffer = select_n + npoint - private_at_copy%pos(:,select_n+1:private_at_copy%n) = real_grid(:,offset:size(real_grid,2):stride) - call calc_connect(private_at_copy, skip_zero_zero_bonds=.true.) - - local_e = 0.0_dp - call calc(this, private_at_copy, local_energy=local_e(1:private_at_copy%n), & - args_str=trim(args_str)//' atom_mask_name=atom_mask source_mask_name=source_mask grid_size='//minval(grid_size)) - do n=1,npoint - igrid = (n-1)*stride + offset - pot(lookup(1,igrid),lookup(2,igrid),lookup(3,igrid)) = 2.0_dp*local_e(select_n+n)/at_charge(select_n+n) - end do - end do - - call finalise(private_at_copy) - deallocate(local_e) - - !$omp end parallel -#ifdef _OPENMP - call omp_set_nested(old_nested) -#endif - - ! Now do a single calculation of potential and field at ion positions in cluster - if (cluster%n > (size(at_copy%z)-select_n)) then - RAISE_ERROR("cluster contains too many atoms!", error) - end if - at_copy%n = select_n + cluster%n - at_copy%nbuffer = select_n + cluster%n - at_copy%pos(:,select_n+1:at_copy%n) = cluster%pos(:,:) - if (.not. assign_pointer(cluster, 'charge', cluster_charge)) then - RAISE_ERROR('calc_electrostatic_potential failed to assign pointer to cluster "charge" property', error) - end if - at_charge(select_n+1:at_copy%n) = 1.0_dp - at_copy%z(select_n+1:at_copy%n) = 0 ! treat as non-interacting dummy atoms - call calc_connect(at_copy, skip_zero_zero_bonds=.true.) - - call add_property(at_copy, 'es_efield', 0.0_dp, n_cols=3, overwrite=.true., ptr2=es_efield, error=error) - PASS_ERROR(error) - call add_property(at_copy, 'es_pot', 0.0_dp, overwrite=.true., ptr=es_pot, error=error) - PASS_ERROR(error) - call add_property(cluster, 'es_efield', 0.0_dp, n_cols=3, overwrite=.true., ptr2=cluster_es_efield, error=error) - PASS_ERROR(error) - call add_property(cluster, 'es_pot', 0.0_dp, overwrite=.true., ptr=cluster_es_pot, error=error) - PASS_ERROR(error) - - call calc(this, at_copy, args_str=trim(args_str)//' efield=es_efield local_energy=es_pot atom_mask_name=atom_mask source_mask_name=source_mask', error=error) - PASS_ERROR(error) - - ! Electrostatic potential at ion positions is 2*local_energy/charge - cluster_es_pot = 2.0_dp*es_pot(select_n+1:at_copy%n)/cluster_charge - cluster_es_efield = es_efield(:,select_n+1:at_copy%n) - - deallocate(select_mask) - deallocate(lookup,z) - call finalise(at_copy) - call system_timer('calc_electrostatic_potential') - - end subroutine calc_electrostatic_potential - - -end module ElectrostaticEmbed_module diff --git a/src/Potentials/Ewald.f95 b/src/Potentials/Ewald.f95 deleted file mode 100644 index d259671c31..0000000000 --- a/src/Potentials/Ewald.f95 +++ /dev/null @@ -1,830 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Ewald module -!X -!% This module computes the Ewald sum. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -module Ewald_module - -use system_module -use units_module - -use functions_module - -implicit none - -private - -integer max_n_r, max_n_q -integer n_r, n_q -integer, allocatable:: r_list(:,:), q_list(:,:) - -integer:: last_N_A = 0 -integer:: n_pairs -integer, allocatable:: pair_list(:,:) - -public add_madelung_matrix, add_dmadelung_matrix, add_dmadelung_matrix_dr - -contains - -!| subroutine add_madelung_matrix -!| calculate Madelung matrix (interactions of pt charges in 3-D periodic supercell) -!| -!|I integer N_A: number of atoms -!|I real(dp) a1(3), a2(3), a3(3): periodic supercell vectors -!|I real(dp) A(3,N_A): atomic positions -!|O real(dp) madelung_matrix(N_A,N_A): Madelung matrix -!|I logical redo_lattice: if true, redo whole calculation, rather than -!| just summing over periodic images that had significant contributions -!| last time -!| -!| Noam Bernstein 9/12/2001 -!| From Fundamental Formulas of Physics, p. 599 -!% Calculate Madelung matrix (interactions of pt charges in 3-D periodic supercell). -!% It is possible to choose between redoing the whole calculation and summing over those periodic images -!% that had significant contributions last time by setting the logical variable redo_lattice. -subroutine add_madelung_matrix(N_A, a1_in, a2_in, a3_in, A_in, madelung_matrix, redo_lattice) - integer, intent(in) :: N_A !% number of atoms (input) - real(dp), intent(in) :: a1_in(3), a2_in(3), a3_in(3) !% periodic supercell vectors (input) - real(dp), intent(in) :: A_in(3,N_A) !% atomic positions (input) - real(dp), intent(inout) :: madelung_matrix(N_A,N_A) !% Madelung matrix (output) - logical, intent(in), optional :: redo_lattice !% if true, redo whole calculation, rather than just summing over periodic images that had significant contributions last time (input) - - integer i, j, range_a(3) - integer s_a(3), s2, s3 - real(dp) b1(3), b2(3), b3(3), h(3,3) - real(dp) vol - real(dp) K(3), ri(3), rj(3), t, tv(3), Kmagsq, Rmag - - real(dp) :: a1(3), a2(3), a3(3) - real(dp), allocatable :: A(:,:) - - integer rr, qq - - real(dp) epsilon, fourepsilonsq - real(dp) recip_space_prefac, K_dep_factor - real(dp) phase - real(dp) conv_crit, prev_conv_crit - - integer ni, nip1, nip2 - real(dp) b1mag, b2mag, b3mag - real(dp) a1mag, a2mag, a3mag - - logical use_this_one - real(dp) convf - - logical u_redo_lattice - - integer i_pair - - integer nv - - allocate(A(3,N_A)) - a1 = a1_in / Bohr - a2 = a2_in / Bohr - a3 = a3_in / Bohr - A = A_in / Bohr - - u_redo_lattice = .true. - if (present(redo_lattice)) u_redo_lattice = redo_lattice - - !convf = 1.0D-10 - convf = 1.0D-14 - - h(1:3,1) = a1(1:3) - h(1:3,2) = a2(1:3) - h(1:3,3) = a3(1:3) - vol = calc_volume(h) - call cross_3 (a1, a2, b3) - call cross_3 (a2, a3, b1) - call cross_3 (a3, a1, b2) - b1 = 2.0_dp*PI* b1 / vol - b2 = 2.0_dp*PI* b2 / vol - b3 = 2.0_dp*PI* b3 / vol - - !epsilon = 0.7_dp/nn_dist - - epsilon = 1.5_dp / ( 1.0_dp/sqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) - !epsilon = 2.25_dp / ( 1.0_dp/sqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) - - fourepsilonsq = 4.0_dp*epsilon**2 - - recip_space_prefac = 4.0_dp*PI/vol - - prev_conv_crit = 0.0_dp - conv_crit = prev_conv_crit+1.0_dp - - b1mag = sqrt(sum(b1**2)) - b2mag = sqrt(sum(b2**2)) - b3mag = sqrt(sum(b3**2)) - - nv = 0 - range_a = 0 - - if (u_redo_lattice) then - - if (N_A .ne. last_N_A) then - if (allocated(pair_list)) deallocate(pair_list) - call assign_atom_pairs(N_A, n_pairs, pair_list) - last_N_A = N_A - end if - - max_n_r = 2000 - max_n_q = 2000 - if (allocated(r_list)) deallocate(r_list) - if (allocated(q_list)) deallocate(q_list) - allocate(r_list(3,max_n_r)) - allocate(q_list(3,max_n_q)) - n_r = 0 - n_q = 0 - - - ! reciprocal space - do while (abs(conv_crit-prev_conv_crit) .gt. 1.0e-14_dp) - - !!!!! - do ni=1,3 - range_a(ni) = range_a(ni) + 1 - nip1 = mod(ni,3)+1 - nip2 = mod(ni+1,3)+1 - - s_a(ni) = -range_a(ni) - do s2 = -range_a(nip1), range_a(nip1) - s_a(nip1) = s2 - do s3 = -range_a(nip2), range_a(nip2) - s_a(nip2) = s3 - - use_this_one = .false. - - K = s_a(1)*b1 + s_a(2)*b2 + s_a(3)*b3 - Kmagsq = sum(K**2) - K_dep_factor = recip_space_prefac*exp(-Kmagsq/fourepsilonsq)/Kmagsq - - do i_pair = 1, n_pairs - - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - phase = sum(K*(ri-rj)) - t = Hartree*K_dep_factor*cos(phase) - madelung_matrix(i,j) = madelung_matrix(i,j) + 2*t - - if (i /= j) madelung_matrix(j,i) = madelung_matrix(j,i) + 2*t - - if (t /= 0.0_dp .and. abs((2.0_dp*t)/madelung_matrix(i,j)) > convf) then -! workaround for buggy Cray MTA compiler -#ifndef cray_mta - use_this_one = .true. -#endif - end if - - end do - - if (use_this_one) then - n_q = n_q + 1 - q_list(1:3,n_q) = s_a - end if - - nv = nv + 1 - - end do ! s3 - end do ! s2 - end do ! ni - - prev_conv_crit = conv_crit - !NO_PARALLEL t_conv_crit = sum(abs(madelung_matrix)) - !NO_PARALLEL call global_sum(t_conv_crit, conv_crit) - conv_crit = sum(abs(madelung_matrix)) - ! print *, "G conv ", range_a, conv_crit, prev_conv_crit - - end do ! while not conv - ! print *, "nv ", nv - - - !NO_PARALLEL t_conv_crit = sum(abs(madelung_matrix)) - !NO_PARALLEL call global_sum(t_conv_crit,prev_conv_crit) - prev_conv_crit = sum(abs(madelung_matrix)) - conv_crit = prev_conv_crit+1.0_dp - - ! real space shift=0 - a1mag = sqrt(sum(a1**2)) - a2mag = sqrt(sum(a2**2)) - a3mag = sqrt(sum(a3**2)) - - tv = 0.0_dp - - do i_pair = 1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - if (i .eq. j) cycle - - ri = A(1:3,i) - rj = A(1:3,j) - - Rmag = sqrt(sum((rj+tv-ri)**2)) - t = Hartree * erfc(epsilon*Rmag)/Rmag - madelung_matrix(i,j) = madelung_matrix(i,j) + t - if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t - end do - - - prev_conv_crit = conv_crit - !NO_PARALLEL t_conv_crit = sum(dabs(madelung_matrix)) - !NO_PARALLEL call global_sum(t_conv_crit, conv_crit) - conv_crit = sum(abs(madelung_matrix)) - ! print *, "R conv ", range, conv_crit, prev_conv_crit - - nv = 0 - range_a = 0 - - ! real space shift /= 0 - do while (abs(conv_crit-prev_conv_crit) .gt. 1.0e-14_dp) - - ! amag_a(1) = a1mag*(range_a(1)+1) - ! amag_a(2) = a2mag*(range_a(2)+1) - ! amag_a(3) = a3mag*(range_a(3)+1) - ! next_increment = minloc(amag_a) - ! ni = next_increment(1) - - !!!!! - do ni=1,3 - - range_a(ni) = range_a(ni) + 1 - nip1 = mod(ni,3)+1 - nip2 = mod(ni+1,3)+1 - - s_a(ni) = -range_a(ni) - do s2 = -range_a(nip1), range_a(nip1) - s_a(nip1) = s2 - do s3 = -range_a(nip2), range_a(nip2) - s_a(nip2) = s3 - - use_this_one = .false. - - tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 - - do i_pair = 1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - Rmag = sqrt(sum((rj+tv-ri)**2)) - t = Hartree * erfc(epsilon*Rmag)/Rmag - madelung_matrix(i,j) = madelung_matrix(i,j) + t - if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t - if (t .ne. 0 .and. abs(t/madelung_matrix(i,j)) .gt. convf) then - use_this_one = .true. - end if - - end do - - !NO_PARALLEL call global_or(use_this_one, g_use_this_one) - !NO_PARALLEL use_this_one = g_use_this_one - - if (use_this_one) then - n_r = n_r + 1 - r_list(1:3,n_r) = s_a - end if - - nv = nv + 1 - end do - end do - - s_a(ni) = range_a(ni) - do s2 = -range_a(nip1), range_a(nip1) - s_a(nip1) = s2 - do s3 = -range_a(nip2), range_a(nip2) - s_a(nip2) = s3 - - use_this_one = .false. - - tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 - do i_pair = 1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - Rmag = sqrt(sum((rj+tv-ri)**2)) - t = Hartree * erfc(epsilon*Rmag)/Rmag - madelung_matrix(i,j) = madelung_matrix(i,j) + t - if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t - - if (t .ne. 0 .and. abs(t/madelung_matrix(i,j)) .gt. convf) then - use_this_one = .true. - end if - - end do - - !NO_PARALLEL call global_or(use_this_one, g_use_this_one) - !NO_PARALLEL use_this_one = g_use_this_one - - if (use_this_one) then - n_r = n_r + 1 - r_list(1:3,n_r) = s_a - end if - - nv = nv + 1 - end do - end do - - !!!!! - end do ! ni - - - prev_conv_crit = conv_crit - !NO_PARALLEL t_conv_crit = sum(abs(madelung_matrix)) - !NO_PARALLEL call global_sum(t_conv_crit, conv_crit) - conv_crit = sum(abs(madelung_matrix)) - ! print *, "R conv ", range, conv_crit, prev_conv_crit - - end do ! while conv_crit - - ! print *, "nv ", nv - ! print *, "n_r, n_q ", n_r, n_q - else ! don't redo lattice - - do qq=1, n_q - - s_a = q_list(1:3,qq) - - K = s_a(1)*b1 + s_a(2)*b2 + s_a(3)*b3 - Kmagsq = sum(K**2) - K_dep_factor = recip_space_prefac*exp(-Kmagsq/fourepsilonsq)/Kmagsq - do i_pair = 1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - phase = sum(K*(ri-rj)) - t = Hartree * K_dep_factor*cos(phase) - madelung_matrix(i,j) = madelung_matrix(i,j) + 2*t - if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + 2*t - end do - - end do - - tv = 0.0_dp - do i_pair = 1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - if (i .eq. j) cycle - ri = A(1:3,i) - rj = A(1:3,j) - - Rmag = sqrt(sum((rj+tv-ri)**2)) - t = Hartree * erfc(epsilon*Rmag)/Rmag - madelung_matrix(i,j) = madelung_matrix(i,j) + t - if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t - end do - - do rr=1, n_r - s_a = r_list(1:3,rr) - - tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 - do i_pair = 1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - Rmag = sqrt(sum((rj+tv-ri)**2)) - t = Hartree * erfc(epsilon*Rmag)/Rmag - madelung_matrix(i,j) = madelung_matrix(i,j) + t - if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t - end do - end do - - end if - - conv_crit = sum(abs(madelung_matrix)) - ! print *, "overall conv ", conv_crit - - do i=1, N_A - madelung_matrix(i,i) = madelung_matrix(i,i) - Hartree * 2.0_dp*epsilon/sqrt(PI) - end do - - madelung_matrix = madelung_matrix - Hartree * PI/(vol*epsilon**2) -madelung_matrix = madelung_matrix + 0.61_dp - - deallocate(A) - -end subroutine add_madelung_matrix - -!| subroutine add_dmadelung_matrix -!| calculate derivative of Madelung matrix (interactions of pt charges in -!| 3-D periodic supercell) -!| -!|I integer N_A: number of atoms -!|I real(dp) a1(3), a2(3), a3(3): periodic supercell vectors -!|I real(dp) A(3,N_A): atomic positions -!|O real(dp) dmadelung_matrix(N_A,N_A): derivative of Madelung matrix -!| -!| Noam Bernstein 9/12/2001 -!% This subroutine calculate derivative of Madelung matrix (interactions of pt charges in -!% 3-D periodic supercell). -subroutine add_dmadelung_matrix(N_A, a1_in, a2_in, a3_in, A_in, dmadelung_matrix) - integer :: N_A !% number of atoms - real(dp) :: a1_in(3), a2_in(3), a3_in(3) !% periodic supercell vectors - real(dp) :: A_in(3,N_A) !% atomic positions - real(dp) :: dmadelung_matrix(N_A,N_A,3) !% derivative of Madelung matrix - - !NO PARALLEL real(dp), allocatable:: t_dmadelung_matrix(:,:,:) - - integer i, j - integer s_a(3) - real(dp) b1(3), b2(3), b3(3), h(3,3) - real(dp) vol - real(dp) K(3), ri(3), rj(3), dt, tv(3), Kmagsq, Rmag, dr(3) - - real(dp) :: a1(3), a2(3), a3(3) - real(dp), allocatable :: A(:,:) - - integer i_pair - integer rr, qq - - real(dp) epsilon, fourepsilonsq - real(dp) recip_space_prefac, K_dep_factor - real(dp) phase - - allocate(A(3,N_A)) - a1 = a1_in / Bohr - a2 = a2_in / Bohr - a3 = a3_in / Bohr - A = A_in / Bohr - - h(1:3,1) = a1(1:3) - h(1:3,2) = a2(1:3) - h(1:3,3) = a3(1:3) - vol = calc_volume(h) - call cross_3 (a1, a2, b3) - call cross_3 (a2, a3, b1) - call cross_3 (a3, a1, b2) - b1 = 2.0_dp*PI* b1 / vol - b2 = 2.0_dp*PI* b2 / vol - b3 = 2.0_dp*PI* b3 / vol - - !epsilon = 0.7_dp/nn_dist - - epsilon = 1.5_dp / ( 1.0_dp/sqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) - !epsilon = 2.25_dp / ( 1.0_dp/sqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) - - fourepsilonsq = 4.0_dp*epsilon**2 - - recip_space_prefac = 4.0_dp*PI/vol - - do qq=1, n_q - - s_a = q_list(1:3,qq) - - K = s_a(1)*b1 + s_a(2)*b2 + s_a(3)*b3 - Kmagsq = sum(K**2) - K_dep_factor = recip_space_prefac*exp(-Kmagsq/fourepsilonsq)/Kmagsq - do i_pair=1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - phase = sum(K*(ri-rj)) - dt = Hartree/Bohr * K_dep_factor*(-sin(phase)) - dmadelung_matrix(i,j,1:3) = dmadelung_matrix(i,j,1:3) + 2.0_dp*dt*K(1:3) - if (i .ne. j) dmadelung_matrix(j,i,1:3) = dmadelung_matrix(j,i,1:3) - 2.0_dp*dt*K(1:3) - end do - - end do - - tv = 0.0_dp - do i_pair=1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - if (i .eq. j) cycle - ri = A(1:3,i) - rj = A(1:3,j) - - dr = ri-tv-rj - Rmag = sqrt(sum(dr**2)) - dt = Hartree/Bohr * ( (-2.0_dp/sqrt(PI))*Rmag*epsilon*exp(-(epsilon*Rmag)**2) - erfc(epsilon*Rmag) ) / Rmag**2 - dmadelung_matrix(i,j,1:3) = dmadelung_matrix(i,j,1:3) + dt*dr/Rmag - if (i .ne. j) dmadelung_matrix(j,i,1:3) = dmadelung_matrix(j,i,1:3) - dt*dr/Rmag - - end do - - do rr=1, n_r - s_a = r_list(1:3,rr) - - tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 - do i_pair=1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - dr = ri-tv-rj - Rmag = sqrt(sum(dr**2)) - dt = Hartree/Bohr * ( (-2.0_dp/sqrt(PI))*Rmag*epsilon*exp(-(epsilon*Rmag)**2) - erfc(epsilon*Rmag) ) / Rmag**2 - dmadelung_matrix(i,j,1:3) = dmadelung_matrix(i,j,1:3) + dt*dr/Rmag - if (i .ne. j) dmadelung_matrix(j,i,1:3) = dmadelung_matrix(j,i,1:3) - dt*dr/Rmag - - end do - end do - - !NO_PARALLEL allocate(t_dmadelung_matrix(N_A,N_A,3)) - !NO_PARALLEL t_dmadelung_matrix = dmadelung_matrix - !NO_PARALLEL dmadelung_matrix = 0.0_dp - !NO_PARALLEL call global_sum(t_dmadelung_matrix, dmadelung_matrix) - !NO_PARALLEL deallocate(t_dmadelung_matrix) - - deallocate(A) - -end subroutine add_dmadelung_matrix - -!| subroutine add_dmadelung_matrix_dr -!% Calculate derivative of Madelung matrix (interactions of pt charges in -!% 3-D periodic supercell) dotted with atomic positions. -!% From Nielsen and Martin, Phys. Rev. B {\bf 32}, (1985). -!| -!|I integer N_A: number of atoms -!|I real(dp) a1(3), a2(3), a3(3): periodic supercell vectors -!|I real(dp) A(3,N_A): atomic positions -!|O real(dp) dmadelung_matrix_dr(N_A,N_A): derivative of Madelung matrix -!| dotted with atomic positions -!| -!| Noam Bernstein 9/12/2001 -!| From Nielsen and Martin, PRB _32_, 1985. - -subroutine add_dmadelung_matrix_dr(N_A, a1_in, a2_in, a3_in, A_in, component, dmadelung_matrix_dr) - integer :: N_A !% number of atoms (input) - real(dp) :: a1_in(3), a2_in(3), a3_in(3) !% periodic supercell vectors (input) - real(dp) :: A_in(3,N_A) !% atomic positions (input) - integer :: component - real(dp) :: dmadelung_matrix_dr(N_A,N_A,3) !% derivative of Madelung matrix dotted with atomic positions (output) - - integer i, j - integer s_a(3) - real(dp) b1(3), b2(3), b3(3), h(3,3) - real(dp) vol - real(dp) K(3), ri(3), rj(3), dt, tv(3), Kmagsq, Rmag, dr(3) - real(dp) t_ij(3) - - real(dp) :: a1(3), a2(3), a3(3) - real(dp), allocatable :: A(:,:) - - integer i_pair - integer rr, qq - - real(dp) epsilon, fourepsilonsq - real(dp) recip_space_prefac, K_dep_factor - real(dp) phase - - allocate(A(3,N_A)) - a1 = a1_in / Bohr - a2 = a2_in / Bohr - a3 = a3_in / Bohr - A = A_in / Bohr - - h(1:3,1) = a1(1:3) - h(1:3,2) = a2(1:3) - h(1:3,3) = a3(1:3) - vol = calc_volume(h) - call cross_3 (a1, a2, b3) - call cross_3 (a2, a3, b1) - call cross_3 (a3, a1, b2) - b1 = 2.0_dp*PI* b1 / vol - b2 = 2.0_dp*PI* b2 / vol - b3 = 2.0_dp*PI* b3 / vol - - !epsilon = 0.7_dp/nn_dist - - epsilon = 1.5_dp / ( 1.0_dp/dsqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) - !epsilon = 2.25_dp / ( 1.0_dp/dsqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) - - fourepsilonsq = 4.0_dp*epsilon**2 - - recip_space_prefac = PI/(vol*epsilon**2) - - do qq=1, n_q - - s_a = q_list(1:3,qq) - - K = s_a(1)*b1 + s_a(2)*b2 + s_a(3)*b3 - Kmagsq = sum(K**2) - - K_dep_factor = recip_space_prefac*dexp(-Kmagsq/fourepsilonsq)/(Kmagsq/fourepsilonsq) - - do i_pair=1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - dr = ri-rj - phase = sum(K*(ri-rj)) - - dt = Hartree * K_dep_factor*2.0_dp*dcos(phase) - - if (component .eq. 0) then - t_ij(1:3) = dt * (2.0_dp*K(1:3)*K(1:3)/Kmagsq * (Kmagsq/fourepsilonsq + 1.0_dp) - 1.0_dp) - dmadelung_matrix_dr(i,j,1) = dmadelung_matrix_dr(i,j,1) - sum(t_ij(1:3)) - if (i .ne. j) dmadelung_matrix_dr(j,i,1) = dmadelung_matrix_dr(j,i,1) - sum(t_ij(1:3)) - else - t_ij(1:3) = dt * (2.0_dp*K(component)*K(1:3)/Kmagsq * (Kmagsq/fourepsilonsq + 1.0_dp)) - t_ij(component) = t_ij(component) - dt - dmadelung_matrix_dr(i,j,1:3) = dmadelung_matrix_dr(i,j,1:3) - t_ij(1:3) - if (i .ne. j) dmadelung_matrix_dr(j,i,1:3) = dmadelung_matrix_dr(j,i,1:3) - t_ij(1:3) - end if - end do - - end do - - tv = 0.0_dp - do i_pair=1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - if (i .eq. j) cycle - ri = A(1:3,i) - rj = A(1:3,j) - - dr = ri-tv-rj - Rmag = sqrt(sum(dr**2)) - if (component .eq. 0) then - t_ij(1:3) = Hartree * 0.5_dp*epsilon*2.0_dp*Hprime(epsilon*Rmag)*dr(1:3)*dr(1:3)/Rmag**2 - dmadelung_matrix_dr(i,j,1) = dmadelung_matrix_dr(i,j,1) - sum(t_ij(1:3)) - if (i .ne. j) dmadelung_matrix_dr(j,i,1) = dmadelung_matrix_dr(j,i,1) - sum(t_ij(1:3)) - else - t_ij(1:3) = Hartree * 0.5_dp*epsilon*2.0_dp*Hprime(epsilon*Rmag)*dr(component)*dr(1:3)/Rmag**2 - dmadelung_matrix_dr(i,j,1:3) = dmadelung_matrix_dr(i,j,1:3) - t_ij(1:3) - if (i .ne. j) dmadelung_matrix_dr(j,i,1:3) = dmadelung_matrix_dr(j,i,1:3) - t_ij(1:3) - end if - end do - - do rr=1, n_r - s_a = r_list(1:3,rr) - - tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 - do i_pair=1, n_pairs - i = pair_list(1,i_pair) - j = pair_list(2,i_pair) - ri = A(1:3,i) - rj = A(1:3,j) - - dr = ri-tv-rj - Rmag = sqrt(sum(dr**2)) - if (component .eq. 0) then - t_ij(1:3) = Hartree * 0.5_dp*epsilon*2.0_dp*Hprime(epsilon*Rmag)*dr(1:3)*dr(1:3)/Rmag**2 - dmadelung_matrix_dr(i,j,1) = dmadelung_matrix_dr(i,j,1) - sum(t_ij(1:3)) - if (i .ne. j) dmadelung_matrix_dr(j,i,1) = dmadelung_matrix_dr(j,i,1) - sum(t_ij(1:3)) - else - t_ij(1:3) = Hartree * 0.5_dp*epsilon*2.0_dp*Hprime(epsilon*Rmag)*dr(component)*dr(1:3)/Rmag**2 - dmadelung_matrix_dr(i,j,1:3) = dmadelung_matrix_dr(i,j,1:3) - t_ij(1:3) - if (i .ne. j) dmadelung_matrix_dr(j,i,1:3) = dmadelung_matrix_dr(j,i,1:3) - t_ij(1:3) - end if - end do - end do - - if (component .eq. 0) then - dmadelung_matrix_dr(1:N_A,1:N_A,1) = dmadelung_matrix_dr(1:N_A,1:N_A,1) - & - Hartree * 3.0_dp*PI/(vol*epsilon**2) - else - dmadelung_matrix_dr(1:N_A,1:N_A,1:3) = dmadelung_matrix_dr(1:N_A,1:N_A,1:3) - & - Hartree * PI/(vol*epsilon**2) - end if - -!NO_PARALLEL if (component .eq. 0) then -!NO_PARALLEL allocate(t_dmadelung_matrix_dr(N_A,N_A,1)) -!NO_PARALLEL t_dmadelung_matrix_dr(1:N_A,1:N_A,1) = dmadelung_matrix_dr(1:N_A,1:N_A,1) -!NO_PARALLEL dmadelung_matrix_dr(1:N_A,1:N_A,1) = 0.0_dp -!NO_PARALLEL call global_sum(t_dmadelung_matrix_dr, dmadelung_matrix_dr) -!NO_PARALLEL deallocate(t_dmadelung_matrix_dr) -!NO_PARALLEL else -!NO_PARALLEL allocate(t_dmadelung_matrix_dr(N_A,N_A,3)) -!NO_PARALLEL t_dmadelung_matrix_dr = dmadelung_matrix_dr -!NO_PARALLEL dmadelung_matrix_dr = 0.0_dp -!NO_PARALLEL call global_sum(t_dmadelung_matrix_dr, dmadelung_matrix_dr) -!NO_PARALLEL deallocate(t_dmadelung_matrix_dr) -!NO_PARALLEL endif - - deallocate(A) - -end subroutine add_dmadelung_matrix_dr - -!| subroutine cross_3 -!% Calculate cross product of 2 3-vectors. a(3), b(3): vectors to be crossed, c(3): cross product. -!| -!|I real(dp) a(3), b(3): vectors to be crossed -!|O real(dp) c(3): cross product -!| -!| Noam Bernstein 9/12/2001 - -subroutine cross_3(a, b, c) - real(dp) a(3), b(3), c(3) - - c(1) = a(2)*b(3)-a(3)*b(2) - c(2) = a(3)*b(1)-a(1)*b(3) - c(3) = a(1)*b(2)-a(2)*b(1) - -end subroutine cross_3 - -!| real(dp) function calc_volume -!| calculate volume of periodic supercell -!| returns volume of supercell -!| -!|I real(dp) a(3,3): matrix of peridic supercell vectors -!| -!| Noam Bernstein 9/12/2001 - -real(dp) function calc_volume(mat) - real(dp) mat(3,3) - - calc_volume = abs(det_3_by_3(mat)) -end function calc_volume - -!| real(dp) function det_3_by_3 -!| calculate determinant of 3x3 matrix -!| returns determinant of matrix -!| -!|I real(dp) a(3,3): matrix -!| -!| Noam Bernstein 9/12/2001 - -real(dp) function det_3_by_3(a) - real(dp) a(3,3) - - det_3_by_3 = -a(1,3)*a(2,2)*a(3,1) + a(1,2)*a(2,3)*a(3,1) + a(1,3)*a(2,1)*a(3,2) - & - a(1,1)*a(2,3)*a(3,2) - a(1,2)*a(2,1)*a(3,3) + a(1,1)*a(2,2)*a(3,3) -end function det_3_by_3 - -!| real(dp) function Hprime -!| calculate Hprime function for dMadelung_matrix/dr . r -!| returns value of Hprime(x) -!| -!|I real(dp) x: argument -!| -!| Noam Bernstein 9/12/2001 - -real(dp) function Hprime(x) - real(dp) x - - Hprime = (-2.0_dp/sqrt(PI))*exp(-x**2) - erfc(x)/x - -end function Hprime - -subroutine assign_atom_pairs(N, n_pairs, pair_list) - integer, intent(in) :: N - integer, intent(out) :: n_pairs - integer, allocatable, intent(inout) :: pair_list(:,:) - - integer cur_pair_i, i, j - - n_pairs = N*(N+1)/2 - - if (allocated(pair_list)) deallocate(pair_list) - allocate(pair_list(2,n_pairs)) - - cur_pair_i = 1 - do i=1, N - do j=i, N - pair_list(1,cur_pair_i) = i - pair_list(2,cur_pair_i) = j - cur_pair_i = cur_pair_i + 1 - end do - end do - -end subroutine assign_atom_pairs - -end module Ewald_module diff --git a/src/Potentials/FilePot.f95 b/src/Potentials/FilePot.f95 deleted file mode 100644 index 465664cef7..0000000000 --- a/src/Potentials/FilePot.f95 +++ /dev/null @@ -1,495 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X FilePot Module -!X -!% FilePot is a potential that computes things by writing atomic config to a -!% file, running a command, and reading its output -!% -!% it takes an argument string on initialization with one mandatory parameter -!%> command=path_to_command -!% and three optional parameters -!%> property_list=prop1:T1:N1:prop2:T2:N2... -!% which defaults to 'pos', -!%> filename= -!% which defaults to 'filepot', and -!%> min_cutoff=cutoff -!% which default to zero. If min_cutoff is non zero and the cell is narrower -!% than $2*min_cutoff$ in any direction then it will be replicated before -!% being written to the file. The forces are taken from the primitive cell -!% and the energy is reduced by a factor of the number of repeated copies. -!% -!% The command takes 2 arguments, the names of the input and the output files. -!% command output is in extended xyz form. -!% -!% energy and virial (both optional) are passed via the comment, labeled as -!% 'energy=E' and 'virial="vxx vxy vxz vyx vyy vyz vzx vzy vzz"'. -!% -!% per atoms data is at least atomic type and optionally -!% a local energy (labeled 'local_e:R:1') -!% and -!% forces (labeled 'force:R:3') -!% -!% right now (14/2/2008) the atoms_xyz reader requires the 1st 3 columns after -!% the atomic type to be the position. -!% -!% If you ask for some quantity from FilePot_Calc and it's not in the output file, it -!% returns an error status or crashes (if err isn't present). -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! some day implement calculation queues -! how to do this? one possibility: -! add args_str to FilePot_Calc, and indicate -! queued_force=i to indicate this atoms structure should be queued for the calculation -! of forces on atom i (or a list, or a range?) -! or -! process_queue, which would process the queue and fill in all the forces -#include "error.inc" -module FilePot_module - -use error_module -use system_module, only : dp, print, PRINT_NORMAL, PRINT_ALWAYS, PRINT_VERBOSE, inoutput, current_verbosity, system_command, optional_default, parse_string, operator(//) -use mpi_context_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use connection_module -use atoms_types_module -use atoms_module -use structures_module -use CInOutput_module - -implicit none -private - - -public :: FilePot_type -type FilePot_type - character(len=STRING_LENGTH) :: command - character(len=STRING_LENGTH) :: command_addl_args - character(len=STRING_LENGTH) :: property_list - character(len=STRING_LENGTH) :: read_extra_property_list - character(len=STRING_LENGTH) :: read_extra_param_list - character(len=STRING_LENGTH) :: property_list_prefixes - character(len=STRING_LENGTH) :: filename - real(dp) :: min_cutoff - - character(len=STRING_LENGTH) :: init_args_str - type(MPI_context) :: mpi - -end type FilePot_type - -public :: Initialise -interface Initialise - module procedure FilePot_Initialise -end interface Initialise - -public :: Finalise -interface Finalise - module procedure FilePot_Finalise -end interface Finalise - -public :: cutoff -interface cutoff - module procedure FilePot_cutoff -end interface - -public :: Wipe -interface Wipe - module procedure FilePot_Wipe -end interface Wipe - -public :: Print -interface Print - module procedure FilePot_Print -end interface Print - -public :: calc -interface calc - module procedure FilePot_Calc -end interface - -contains - - -subroutine FilePot_Initialise(this, args_str, mpi, error) - type(FilePot_type), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - character(len=STRING_LENGTH) :: command, property_list, read_extra_property_list, & - read_extra_param_list, property_list_prefixes, command_addl_args, filename - real(dp) :: min_cutoff - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - this%init_args_str = args_str - - call initialise(params) - call param_register(params, 'command', PARAM_MANDATORY, command, help_string="system command to execute that should read the structure file, run the model and deposit the output file") - call param_register(params, 'command_addl_args', '', command_addl_args, help_string="additional args to be appended to the command line after xyzfile and outfile") - call param_register(params, 'property_list', 'species:pos', property_list, help_string="list of properties to print with the structure file") - call param_register(params, 'read_extra_property_list', '', read_extra_property_list, help_string="names of extra properties to read from filepot.out files") - call param_register(params, 'property_list_prefixes', '', property_list_prefixes, help_string="list of prefixes to which run_suffix will be applied during calc()") - call param_register(params, 'read_extra_param_list', 'QM_cell', read_extra_param_list, help_string="list of extra params (comment line in XYZ) to read from filepot.out files. Default is 'QM_cell'") - call param_register(params, 'filename', 'filepot', filename, help_string="seed name for directory and structure files to be used") - call param_register(params, 'min_cutoff', '0.0', min_cutoff, help_string="if the unit cell does not fit into this cutoff, it is periodically replicated so that it does") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='filepot_initialise args_str')) then - RAISE_ERROR("FilePot_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("FilePot_Initialise: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - this%command = command - this%command_addl_args = command_addl_args - this%property_list = property_list - this%read_extra_property_list = read_extra_property_list - this%read_extra_param_list = read_extra_param_list - this%property_list_prefixes = property_list_prefixes - this%min_cutoff = min_cutoff - this%filename = filename - if (present(mpi)) this%mpi = mpi - -end subroutine FilePot_Initialise - -subroutine FilePot_Finalise(this) - type(FilePot_type), intent(inout) :: this - - call wipe(this) - -end subroutine FilePot_Finalise - -subroutine FilePot_Wipe(this) - type(FilePot_type), intent(inout) :: this - - this%command="" - this%command_addl_args="" - this%property_list="" - this%read_extra_property_list="" - this%read_extra_param_list="" - this%min_cutoff = 0.0_dp - this%filename = "" - -end subroutine FilePot_Wipe - -function FilePot_cutoff(this) - type(FilePot_type), intent(in) :: this - real(dp) :: FilePot_cutoff - FilePot_cutoff = 0.0_dp ! return zero, because FilePot does its own connection calculation -end function FilePot_cutoff - -subroutine FilePot_Print(this, file) - type(FilePot_type), intent(in) :: this - type(Inoutput), intent(inout),optional,target:: file - - if (current_verbosity() < PRINT_NORMAL) return - - call print("FilePot: command='"//trim(this%command)// & - "' command_addl_args='"//trim(this%command_addl_args)// & - "' filename='"//trim(this%filename)//& - "' property_list='"//trim(this%property_list)//& - "' read_extra_property_list='"//trim(this%read_extra_property_list)//& - "' read_extra_param_list='"//trim(this%read_extra_param_list)//& - "' property_list_prefixes='"//trim(this%property_list_prefixes)//& - "' min_cutoff="//this%min_cutoff,file=file) - -end subroutine FilePot_Print - -subroutine FilePot_Calc(this, at, energy, local_e, forces, virial, local_virial, args_str, error) - type(FilePot_type), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: energy - real(dp), intent(out), target, optional :: local_e(:) - real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) - real(dp), intent(out), optional :: virial(3,3) - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - character(len=STRING_LENGTH) :: xyzfile, outfile, filename, run_suffix - character(len=STRING_LENGTH) :: my_args_str - integer :: nx, ny, nz, i - type(Atoms) :: sup - integer :: status, n_properties, my_err - character(len=STRING_LENGTH) :: read_extra_property_list, read_extra_param_list, property_list, tmp_properties_array(100) - type(Dictionary) :: cli - logical :: FilePot_log, filename_override - - INIT_ERROR(error) - - if (present(energy)) energy = 0.0_dp - if (present(local_e)) local_e = 0.0_dp - if (present(forces)) forces = 0.0_dp - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) local_virial = 0.0_dp - my_args_str = '' - if (present(args_str)) my_args_str = args_str - - call initialise(cli) - call param_register(cli, "FilePot_log", "T", FilePot_log, help_string="if True, save logfile of all the filepot.xyz and filepot.out") - call param_register(cli, "read_extra_property_list", trim(this%read_extra_property_list), read_extra_property_list, help_string="extra properties to read from filepot.out. Overrides init_args version.") - call param_register(cli, "read_extra_param_list", trim(this%read_extra_param_list), read_extra_param_list, help_string="extra params to read from filepot.out. Overrides init_args version.") - call param_register(cli, "run_suffix", '', run_suffix, help_string="suffix to apply to property names in this%property_list_prefixes") - call param_register(cli, 'filename', 'filepot', filename, has_value_target=filename_override, help_string="seed name for directory and structure files to be used") - - if (.not. param_read_line(cli, my_args_str, ignore_unknown=.true.,task='filepot_calc args_str')) then - RAISE_ERROR("FilePot_calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(cli) - - if(filename_override) then - this%filename = filename - end if - - ! Run external command either if MPI object is not active, or if it is active and we're the - ! master process. Function does not return on any node until external command is finished. - - if (.not. this%mpi%active .or. (this%mpi%active .and. this%mpi%my_proc == 0)) then - - if(this%mpi%active) then - xyzfile=(trim(this%filename)//"."//this%mpi%my_proc//".xyz") - outfile=(trim(this%filename)//"."//this%mpi%my_proc//".out") - else - xyzfile=(trim(this%filename)//".xyz") - outfile=(trim(this%filename)//".out") - end if - - call print("FilePot: filename seed=`"//trim(this%filename)//"'", PRINT_VERBOSE) - call print("FilePot: outfile=`"//trim(outfile)//"'", PRINT_VERBOSE) - call print("FilePot: xyzfile=`"//trim(xyzfile)//"'", PRINT_VERBOSE) - call system_command("rm -f "//trim(outfile), status=status) - if (status /= 0) call print("WARNING: FilePot_calc failed to delete outfile="//trim(outfile)//" before running filepot command", PRINT_ALWAYS) - call system_command("rm -f "//trim(xyzfile)//".idx", status=status) - if (status /= 0) call print("WARNING: FilePot_calc failed to delete index file="//trim(xyzfile)//".idx before running filepot command", PRINT_ALWAYS) - call system_command("rm -f "//trim(outfile)//".idx", status=status) - if (status /= 0) call print("WARNING: FilePot_calc failed to delete index file="//trim(outfile)//".idx before running filepot command", PRINT_ALWAYS) - - ! Do we need to replicate cell to exceed min_cutoff ? - if (this%min_cutoff .fne. 0.0_dp) then - call fit_box_in_cell(this%min_cutoff, this%min_cutoff, this%min_cutoff, at%lattice, nx, ny, nz) - else - nx = 1; ny = 1; nz = 1 - end if - - property_list = this%property_list - if (len_trim(this%property_list_prefixes) /= 0) then - call parse_string(this%property_list_prefixes, ':', tmp_properties_array, n_properties, error=error) - do i=1, n_properties - property_list = trim(property_list)//':'//trim(tmp_properties_array(i))//run_suffix - end do - end if - - if (nx /= 1 .or. ny /= 1 .or. nz /= 1) then - call Print('FilePot: replicating cell '//nx//'x'//ny//'x'//nz//' times.') - call supercell(sup, at, nx, ny, nz) - call write(sup, xyzfile, properties=property_list) - else - call write(at, xyzfile, properties=property_list) - end if - - if (FilePot_log) then - if (nx /= 1 .or. ny /= 1 .or. nz /= 1) then - call write(sup, "FilePot_pos_log.xyz", properties=property_list,append=.true.) - else - call write(at, "FilePot_pos_log.xyz", properties=property_list,append=.true.) - endif - endif - -! call print("FilePot: invoking external command "//trim(this%command)//" "//' '//trim(xyzfile)//" "// & -! trim(outfile)//" on "//at%N//" atoms...") - call print("FilePot: invoking external command "//trim(this%command)//' '//trim(xyzfile)//" "// & - trim(outfile)//" "//trim(this%command_addl_args)//" "//trim(my_args_str)//" on "//at%N//" atoms...") - - ! call the external command here -! call system_command(trim(this%command)//" "//trim(xyzfile)//" "//trim(outfile),status=status) - call system_command(trim(this%command)//' '//trim(xyzfile)//" "//trim(outfile)//" "//& - trim(this%command_addl_args)//" "//trim(my_args_str),status=status) - call print("FilePot: got status " // status // " from external command") - - ! read back output from external command - call filepot_read_output(outfile, at, nx, ny, nz, energy, local_e, forces, virial, local_virial, & - read_extra_property_list, read_extra_param_list, run_suffix, filepot_log=FilePot_log, error=error) - PASS_ERROR_WITH_INFO("Filepot_Calc reading output", error) - end if - - if (this%mpi%active) then - ! Share results with other nodes - if (present(energy)) call bcast(this%mpi, energy) - if (present(local_e)) call bcast(this%mpi, local_e) - - if (present(forces)) call bcast(this%mpi, forces) - if (present(virial)) call bcast(this%mpi, virial) - if (present(local_virial)) call bcast(this%mpi, local_virial) - - call bcast(this%mpi, my_err) - end if - -end subroutine FilePot_calc - -subroutine filepot_read_output(outfile, at, nx, ny, nz, energy, local_e, forces, virial, local_virial, & - read_extra_property_list, read_extra_param_list, run_suffix, filepot_log, error) - character(len=*), intent(in) :: outfile - type(Atoms), intent(inout) :: at - integer, intent(in) :: nx, ny, nz - real(dp), intent(out), optional :: energy - real(dp), intent(out), target, optional :: local_e(:) - real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) - real(dp), intent(out), optional :: virial(3,3) - character(len=*), intent(in) :: read_extra_property_list, read_extra_param_list, run_suffix - logical, intent(in), optional :: filepot_log - integer, intent(out), optional :: error - - character(STRING_LENGTH) :: tmp_params_array(100), copy_keys(100) - integer :: i, n_params, n_copy - type(atoms) :: at_out, primitive - integer, pointer :: Z_p(:) - real(dp) :: virial_1d(9) - real(dp), pointer :: local_e_p(:), forces_p(:,:), local_virial_p(:,:) - logical :: my_filepot_log - - INIT_ERROR(error) - - my_filepot_log = optional_default(.false., filepot_log) - - call print('Filepot: reading back results from file '//trim(outfile)) - call read(at_out, outfile, error=error) - PASS_ERROR(error) - - if (nx /= 1 .or. ny /= 1 .or. nz /= 1) then - ! Discard atoms outside the primitive cell - call select(primitive, at_out, list=(/ (i, i=1,at_out%N/(nx*ny*nz) ) /)) - at_out = primitive - call finalise(primitive) - end if - - call print("FilePot: the following keys were found in the atoms structure:") - call print_keys(at_out%params) - - if (at_out%N /= at%N) then - RAISE_ERROR("filepot_read_output in '"//trim(outfile)//"' got N="//at_out%N//" /= at%N="//at%N, error) - endif - - if (.not. assign_pointer(at_out,'Z',Z_p)) then - RAISE_ERROR("filepot_read_output in '"//trim(outfile)//"' couldn't assign pointer for field Z", error) - endif - do i=1, at%N - if (at%Z(i) /= Z_p(i)) then - RAISE_ERROR("filepot_read_output in '"//trim(outfile)//"' got Z("//i//")="//at_out%Z(i)//" /= at%Z("//i//")="//at%Z(i), error) - endif - end do - - if (present(energy)) then - if (.not. get_value(at_out%params,'energy',energy)) then - RAISE_ERROR("filepot_read_output needed energy, but couldn't find energy in '"//trim(outfile)//"'", error) - endif - ! If cell was repeated, reduce energy by appropriate factor - ! to give energy of primitive cell. - if (nx /= 1 .or. ny /= 1 .or. nz /= 1) & - energy = energy/(nx*ny*nz) - endif - - if (present(virial)) then - if (nx /= 1 .or. ny /= 1 .or. nz /= 1) then - RAISE_ERROR("filepot_read_output: don't know how to rescale virial for repicated system", error) - endif - - if ( get_value(at_out%params,'virial',virial_1d)) then - virial(:,1) = virial_1d(1:3) - virial(:,2) = virial_1d(4:6) - virial(:,3) = virial_1d(7:9) - elseif( .not. get_value(at_out%params,'virial',virial) ) then - RAISE_ERROR("filepot_read_output needed virial, but couldn't find virial in '"//trim(outfile)//"'", error) - endif - endif - - if (present(local_e)) then - if (.not. assign_pointer(at_out, 'local_e', local_e_p)) then - RAISE_ERROR("filepot_read_output needed local_e, but couldn't find local_e in '"//trim(outfile)//"'", error) - endif - local_e = local_e_p - endif - - if (present(forces)) then - if (.not. assign_pointer(at_out, 'force', forces_p)) then - RAISE_ERROR("filepot_read_output needed forces, but couldn't find force in '"//trim(outfile)//"'", error) - endif - forces = forces_p - endif - - if (present(local_virial)) then - if (.not. assign_pointer(at_out, 'local_virial', local_virial_p)) then - RAISE_ERROR("filepot_read_output needed local_virial, but couldn't find local_virial in '"//trim(outfile)//"'", error) - endif - local_virial = local_virial_p - endif - - if (len_trim(read_extra_property_list) > 0) then - call copy_properties(at, at_out, trim(read_extra_property_list)) - endif - - if (len_trim(read_extra_param_list) > 0) then - call parse_string(read_extra_param_list, ':', tmp_params_array, n_params, error=error) - PASS_ERROR(error) - - n_copy = 0 - do i=1,n_params - if (has_key(at_out%params, trim(tmp_params_array(i)))) then - n_copy = n_copy + 1 - copy_keys(n_copy) = tmp_params_array(i) - call print("FilePot copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) - else if (has_key(at_out%params, trim(tmp_params_array(i))//trim(run_suffix))) then - n_copy = n_copy + 1 - copy_keys(n_copy) = trim(tmp_params_array(i))//trim(run_suffix) - call print("FilePot copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) - end if - end do - - call subset(at_out%params, copy_keys(1:n_copy), at%params, out_no_initialise=.true.) - end if - - if (my_filepot_log) then - call write(at_out, "FilePot_out_log.xyz", append=.true.) - endif - - call finalise(at_out) - -end subroutine filepot_read_output - -end module FilePot_module diff --git a/src/Potentials/Functions.f95 b/src/Potentials/Functions.f95 deleted file mode 100644 index 78601fc65b..0000000000 --- a/src/Potentials/Functions.f95 +++ /dev/null @@ -1,451 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Functions Module -!X -!% The Functions Module contains useful subroutines and functions -!% to compute the Fermi occupation $n(E)$ of given energy levels, -!% and error functions. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -module functions_module - -use System_module - -implicit none -private - -public erf, erfc -public :: f_Fermi, f_Fermi_deriv, smooth_cutoff - -contains - -!% Calculate the Fermi occupation for en energy level ('E'), -!% at a given temperature ('T'), -!% and chemical potential ('mu'). -elemental function f_Fermi(mu, T, E) - real(dp), intent(in) :: mu, T, E - real(dp) :: f_Fermi - - if (abs(T) < 1.0e-10_dp) then - if (E-mu < 0.0_dp) then - f_Fermi = 1.0_dp - else if (E-mu > 0.0_dp) then - f_Fermi = 0.0_dp - else - f_Fermi = 0.5_dp - endif - else - f_Fermi = 1.0_dp/(1.0_dp+exp((E-mu)/T)) - endif -end function f_Fermi - -elemental function f_Fermi_deriv(mu, T, E) - real(dp), intent(in) :: mu, T, E - real(dp) :: f_Fermi_deriv - - real(dp) :: arg - - if (abs(T) < 1.0e-10_dp) then - f_Fermi_deriv = 0.0_dp - else - arg = abs((E-mu)/T) - f_Fermi_deriv = -1.0_dp/((1.0_dp+exp(-arg))**2 * exp(arg) * T) - endif -end function f_Fermi_deriv - - -!| double precision function erf -!| calculate error function of argument -!| returns error function of argument -!| -!|I double precision x: argument -!| -!| Noam Bernstein 9/12/2001 - -double precision function erf(x) -implicit none - double precision x - - if (x .lt. 0.0D0) then - erf = -gammp_half(x*x) - else - erf = gammp_half(x*x) - end if - -end function - -!| double precision function erfc -!| calculate error function complement of argument -!| returns error function complement of argument -!| -!|I double precision x: argument -!| -!| Noam Bernstein 9/12/2001 - -double precision function erfc(x) -implicit none - double precision x - - if (x .lt. 0.0D0) then - erfc = 1.0D0 + gammp_half(x*x) - else - erfc = gammq_half(x*x) - end if -end function - -!| double precision function gammp_half -!| calculate incomplete gamma p function of (0.5,x) -!| returns incomplete gamma p function of (0.5,x) -!| -!|I double precision x: argument -!| -!| Noam Bernstein 9/12/2001 - -double precision function gammp_half(x) -implicit none - double precision x - - double precision Gamma_half ! = sqrt(pi) - parameter ( Gamma_half = 1.77245385090552D0 ) - - gammp_half = 2.0D0/Gamma_half * sqrt(x) * p_F0(x) - -end function - -!| double precision function gammq_half -!| calculate incomplete gamma q function (complement of gamma p) of (0.5,x) -!| returns incomplete gamma q function (complement of gamma p) of (0.5,x) -!| -!|I double precision x: argument -!| -!| Noam Bernstein 9/12/2001 - -double precision function gammq_half(x) -implicit none - double precision x - - double precision Gamma_half ! = sqrt(pi) - parameter ( Gamma_half = 1.77245385090552D0 ) - - if (x .ne. 0) then - gammq_half = 2.0D0/Gamma_half * sqrt(x) * p_F0C(x) - else - gammq_half = 1.0D0 - end if - -end function - -!| double precision function p_F0(x) -!| calculate F_m(x) for m=0 using FFFMT3 -!| returns value of F_0(x) -!| -!|I double precision x: argument -!| -!| Noam Bernstein 9/13/2001 - -double precision function p_F0(x) -implicit none - double precision x - - double precision xx(1) - double precision s1(1,5) - - xx(1) = x - call FFFMT3_F90(1, 1, xx, s1) - - p_F0 = s1(1,1) - -end function - -!| double precision function p_F0C(x) -!| calculate sqrt(pi/x)/2-F_m(x) for m=0 using FFFMT3C -!| returns value of sqrt(pi/x)/2-F_0(x) -!| -!|I double precision x: argument -!| -!| Noam Bernstein 9/13/2001 - -double precision function p_F0C(x) -implicit none - double precision x - - double precision xx(1) - double precision s1(1,5) - - xx(1) = x - call FFFMT3C_F90(1, 1, xx, s1) - - p_F0C = s1(1,1) - -end function - -!| subroutine FFFMT3_F90(x) -!% Calculate $F_m(x)$ for $m=0$ using 'FFFMT3C' -!| -!|I integer MX, NPTS: maximum, actual number of pts to be evaluated -!|I double precision xx(NPTS): arguments -!|O double precision s1(NPTS,5): returned values -!| -!| Noam Bernstein 9/13/2001 -!| From Mark Pederson's code - -subroutine FFFMT3_F90(MX,NPTS,XX,S1) -! MODIFIED BY MARK R PEDERSON (1990) -! To FORTRAN 90 by Noam Bernstein -implicit none - integer MX, NPTS - double precision XX(MX),S1(MX,5) - - logical, save:: FIRST = .true. - double precision, save:: F(10,1601) - - double precision ONEOVRI(5) - double precision G(20) - - double precision:: ROOTPI = 1.77245385090551602728D0 - double precision:: ONEOVER3 = 1.0D0/3.0D0 - - integer I, L, K, KK, IT, IPTS - double precision T, X, DEN, TERM, SUM, FACT, Q, EPS, EX - double precision RT, POL1, RECT1, DT - - IF (NPTS.GT.MX) THEN - PRINT *,'FFFMT3: MX MUST BE AT LEAST: ',NPTS - stop - END IF - IF (FIRST) THEN - ! ONEOVER3 = 1.0D0/3.0D0 - FACT = 1.0D0 - DO I = 1,5 - ONEOVRI(I) = 1.0D0/I - FACT = FACT*ONEOVRI(I) - END DO - FIRST = .FALSE. - EPS = 1.0D-12 - DO I = 1,10 - F(I,1) = 1.0D0/(2*I-1) - END DO - T = 0.0D0 - DO L = 2,1601 - T = (1.0D-2)*(L-1) - X = 2*T - DEN = 39.0D0 - TERM = 1.0D0/DEN - SUM = TERM - !DO 130 I = 2,100 - DO I = 2,100 - DEN = DEN+2.0D0 - TERM = TERM*X/DEN - SUM = SUM+TERM - Q = TERM/SUM - ! IF (Q-EPS) 140,140,130 - if (Q .le. EPS) exit - END DO - ! 130 CONTINUE - ! 140 EX = EXP(-T) - EX = EXP(-T) - G(20) = EX*SUM - ! - ! USE DOWNWARD RECURSION - ! - DO I = 1,19 - K = 21-I - KK = K-1 - G(KK) = (X*G(K)+EX)/(2*KK-1) - END DO - DO I = 1,10 - F(I,L) = G(I) - END DO - END DO - DO L = 1,1601 - F(5,L) = F(5,L)/2.0D0 - F(6,L) = F(6,L)/6.0D0 - END DO - END IF - ! - DO IPTS = 1,NPTS - IF (XX(IPTS) .GT. 16.0D0) THEN - POL1 = -EXP(-XX(IPTS)) - RT = SQRT(XX(IPTS))*ROOTPI - RECT1 = 0.5D0/XX(IPTS) - S1(IPTS,1) = RECT1*(RT+POL1) - S1(IPTS,2) = RECT1*(S1(IPTS,1)+POL1) - S1(IPTS,3) = RECT1*(3*S1(IPTS,2)+POL1) - ELSE - IT = INT(100*XX(IPTS)+1.5D0) - POL1 = EXP(-XX(IPTS)) - RECT1 = 2*XX(IPTS) - DT = (1.0D-2)*(IT-1)-XX(IPTS) - S1(IPTS,3) = F(3,IT)+DT*(F(4,IT)+DT*(F(5,IT)+DT*F(6,IT))) - S1(IPTS,2) = (S1(IPTS,3)*RECT1+POL1)*ONEOVER3 - S1(IPTS,1) = (S1(IPTS,2)*RECT1+POL1) - END IF - END DO - RETURN -end subroutine - -!| subroutine FFFMT3C_F90(x) -!% Calculate $\frac{1}{2}\sqrt{\frac{\pi}{x}}-F_m(x)$ for $m=0$ using FFFMT3C -!| -!|I integer MX, NPTS: maximum, actual number of pts to be evaluated -!|I double precision xx(NPTS): arguments -!|O double precision s1(NPTS,5): returned values -!| -!| Noam Bernstein 9/13/2001 -!| Modified for F_0(x) complement from Mark Pederson's code - -subroutine FFFMT3C_F90(MX,NPTS,XX,S1) -! MODIFIED BY MARK R PEDERSON (1990) -! To FORTRAN 90 by Noam Bernstein -implicit none - integer MX, NPTS - double precision XX(MX),S1(MX,5) - - logical, save:: FIRST = .true. - double precision, save:: F(10,1601) - - double precision ONEOVRI(5) - double precision G(20) - - double precision:: ROOTPI = 1.77245385090551602728D0 - double precision:: ONEOVER3 = 1.0D0/3.0D0 - - integer I, L, K, KK, IT, IPTS - double precision T, X, DEN, TERM, SUM, FACT, Q, EPS, EX - double precision RT, POL1, RECT1, DT - - IF (NPTS.GT.MX) THEN - PRINT *,'FFFMT3: MX MUST BE AT LEAST: ',NPTS - stop - END IF - IF (FIRST) THEN - ! ONEOVER3 = 1.0D0/3.0D0 - FACT = 1.0D0 - DO I = 1,5 - ONEOVRI(I) = 1.0D0/I - FACT = FACT*ONEOVRI(I) - END DO - FIRST = .FALSE. - EPS = 1.0D-12 - DO I = 1,10 - F(I,1) = 1.0D0/(2*I-1) - END DO - T = 0.0D0 - DO L = 2,1601 - T = (1.0D-2)*(L-1) - X = 2*T - DEN = 39.0D0 - TERM = 1.0D0/DEN - SUM = TERM - !DO 130 I = 2,100 - DO I = 2,100 - DEN = DEN+2.0D0 - TERM = TERM*X/DEN - SUM = SUM+TERM - Q = TERM/SUM - ! IF (Q-EPS) 140,140,130 - if (Q .le. EPS) exit - END DO - ! 130 CONTINUE - ! 140 EX = EXP(-T) - EX = EXP(-T) - G(20) = EX*SUM - ! - ! USE DOWNWARD RECURSION - ! - DO I = 1,19 - K = 21-I - KK = K-1 - G(KK) = (X*G(K)+EX)/(2*KK-1) - END DO - DO I = 1,10 - F(I,L) = G(I) - END DO - END DO - DO L = 1,1601 - F(5,L) = F(5,L)/2.0D0 - F(6,L) = F(6,L)/6.0D0 - END DO - END IF - ! - DO IPTS = 1,NPTS - IF (XX(IPTS) .GT. 16.0D0) THEN - POL1 = -EXP(-XX(IPTS)) - RT = SQRT(XX(IPTS))*ROOTPI - RECT1 = 0.5D0/XX(IPTS) - !! S1(IPTS,1) = RECT1*(RT+POL1) - ! for computing the complement of F0 - S1(IPTS,1) = -RECT1*POL1 - ! S1(IPTS,2) = RECT1*(S1(IPTS,1)+POL1) - ! S1(IPTS,3) = RECT1*(3*S1(IPTS,2)+POL1) - ELSE - IT = INT(100*XX(IPTS)+1.5D0) - POL1 = EXP(-XX(IPTS)) - RECT1 = 2*XX(IPTS) - DT = (1.0D-2)*(IT-1)-XX(IPTS) - S1(IPTS,3) = F(3,IT)+DT*(F(4,IT)+DT*(F(5,IT)+DT*F(6,IT))) - S1(IPTS,2) = (S1(IPTS,3)*RECT1+POL1)*ONEOVER3 - S1(IPTS,1) = (S1(IPTS,2)*RECT1+POL1) - ! for computing the complement of F0 - S1(IPTS,1) = ROOTPI/(2.0D0*sqrt(XX(IPTS))) - S1(IPTS,1) - END IF - END DO - RETURN -end subroutine - - -!% Smooth cutoff function from D.J. Cole \emph{et al.}, J. Chem. Phys. {\bf 127}, 204704 (2007). -subroutine smooth_cutoff(x,R,D,fc,dfc_dx) - - real(dp), intent(in) :: x,R,D - real(dp), intent(out) :: fc,dfc_dx - real(dp), parameter :: pi = dacos(-1.0d0) - - if (x .lt. (R-D)) then - fc = 1.0d0 - dfc_dx = 0.0d0 - return - else if (x .gt. (R+D)) then - fc = 0.0d0 - dfc_dx = 0.0d0 - return - else - fc = 1.0d0 - (x-R+D)/(2.0d0*D) + 1.0d0/(2.0d0*pi)*dsin((pi/D)*(x-R+D)) - dfc_dx = 1.0d0/(2.0d0*D)* (dcos((pi/D)*(x-R+D)) - 1.0d0) - return - end if -end subroutine smooth_cutoff - - -end module functions_module diff --git a/src/Potentials/IP.f95 b/src/Potentials/IP.f95 deleted file mode 100644 index d16b864484..0000000000 --- a/src/Potentials/IP.f95 +++ /dev/null @@ -1,1155 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IP module -!X -!% General object which manages all the possible interatomic potentials (IP), addressing -!% the calls to the right modules. The available IPs are the following: -!% \begin{itemize} -!% \item Gaussian Approximation Potential ({\bf IPModel_GAP}) -!% \item Lennard-Jones Potential ({\bf IPModel_LJ}) -!% \item Morse Potential ({\bf IPModel_Morse}) -!% \item Force-Constant Potential ({\bf IPModel_FC}) -!% \item Stillinger and Weber Potential for Silicon ({\bf IPModel_SW}) -!% \item Tersoff potential for C/Si/Ge ({\bf IPModel_Tersoff}) -!% \item Embedded Atom Potential of Ercolessi Adam ({\bf IPModel_EAM_ErcolAd}) -!% \item Brenner Potential ({\bf IPModel_Brenner}) -!% \item FB Potential for SiO2 ({\bf IPModel_FB}) -!% \item Silicon Modified Embedded Atom Potentia l ({\bf IPModel_Si_MEAM}) -!% \item Finnis-Sinclair ({\bf IPModel_FS}) -!% \item Bond Order Potential ({\bf IPModel_BOP}) -!% \item Screened Brenner Potential (interface) ({\bf IPModel_Brenner_Screened}) -!% \item 2nd generation Brenner Potential (interface) ({\bf IPModel_Brenner_2002}) -!% \item Partridge-Schwenke potential ({\bf IPModel_PartridgeSchwenke}) -!% \item van der Waals potential ({\bf IPModel_vdW}) -!% \item Einstein crystal potential ({\bf IPModel_Einstein}) -!% \item Coulomb potential ({\bf IPModel_Coulomb}) -!% \item Sutton-Chen potential ({\bf IPModel_Sutton_Chen}) -!% \item Simple potential for an HF dimer ({\bf IPModel_HFdimer}) -!% \item 2-body potential for water dimer ({\bf IPModel_WaterDimer_Gillan}) -!% \item Born-Mayer potential ({\bf IPModel_BornMayer}) -!% \item Customised (hardwired) potential ({\bf IPModel_Custom}) -!% \item Tether a selection of atoms to the origin with a spring ({\bf IPModel_Tether}) -!% \item Fourth-order force-constant potential ({\bf IPModel_FC4}) -!% \item Dispersion correction from Tkatchenko and Scheffler ({\bf IPModel_DispTS}) -!% \item SCME multipole model for water ({\bf IPModel_SCME}) -!% \item MTP potential ({\bf IPModel_MTP}) -!% \item Many-body dispersion ({\bf IPModel_MBD}) -!% \item ZBL potential ({\bf IPModel_ZBL}) -!% \item LinearSOAP potential ({\bf IPModel_LinearSOAP}) -!% \item TTM-nF multipole model for water ({\bf IPModel_nF}) -!% \item CH4 potential ({\bf IPModel_CH4}) -!% \item Confining monomer potential ({\bf IPModel_ConfiningMonomer}) -!% \item Repulsive Step potential ({\bf IPModel_RS}) -!% \item Template potential ({\bf IPModel_Template}) -!% \end{itemize} -!% The IP_type object contains details regarding the selected IP. -!% When a type Potential is defined -!%> type(Potential) :: pot -!% it is then necessary to initialise the IP parameters (readable from an external input file or -!% from an internal string) and to define the IP type: -!%> call Initialise(pot, IP_type, params) -!% where IP_type can be -!% \begin{itemize} -!% \item 'IP GAP' -!% \item 'IP LJ' -!% \item 'IP Morse' -!% \item 'IP FC' -!% \item 'IP SW' -!% \item 'IP Tersoff' -!% \item 'IP EAM_ErcolAd' -!% \item 'IP Brenner' -!% \item 'IP FB' -!% \item 'IP Si_MEAM' -!% \item 'IP FS' -!% \item 'IP BOP' -!% \item 'IP Brenner_Screened' -!% \item 'IP Brenner_2002' -!% \item 'IP PartridgeSchwenke' -!% \item 'IP vdW' -!% \item 'IP Einstein' -!% \item 'IP Coulomb' -!% \item 'IP ConfiningMonomer' -!% \item 'IP Sutton_Chen' -!% \item 'IP HFdimer' -!% \item 'IP BornMayer' -!% \item 'IP_WaterDimer_Gillan' -!% \item 'IP_WaterTrimer_Gillan' -!% \item 'IP Custom' -!% \item 'IP Tether' -!% \item 'IP LMTO_TBE' -!% \item 'IP Multipoles' -!% \item 'IP FC4' -!% \item 'IP DispTS' -!% \item 'IP SCME' -!% \item 'IP MTP' -!% \item 'IP MBD' -!% \item 'IP ZBL' -!% \item 'IP LinearSOAP' -!% \item 'IP TTM_nF' -!% \item 'IP CH4' -!% \item 'IP RS' -!% \item 'IP Template' -!% \end{itemize} -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" -module IP_module - -! use system_module, only : dp -use error_module -use system_module, only : dp, inoutput, initialise, INPUT, print, print_message, PRINT_VERBOSE, PRINT_ALWAYS, system_timer -use units_module -use mpi_context_module -use extendable_str_module -use dictionary_module -use paramreader_module -use atoms_module - -use QUIP_Common_module -use IPModel_GAP_module, only : ipmodel_gap, initialise, finalise, calc, print -use IPModel_LJ_module, only : ipmodel_lj, initialise, finalise, calc, print -use IPModel_Morse_module, only : ipmodel_morse, initialise, finalise, calc, print -use IPModel_FC_module, only : ipmodel_fc, initialise, finalise, calc, print -use IPModel_SW_module, only : ipmodel_sw, initialise, finalise, calc, print -use IPModel_Tersoff_module, only : ipmodel_tersoff, initialise, finalise, calc, print -use IPModel_EAM_ErcolAd_module, only : ipmodel_eam_ercolad, initialise, finalise, calc, print -use IPModel_Brenner_module, only : ipmodel_brenner, initialise, finalise, calc, print -use IPModel_FB_module, only : ipmodel_fb, initialise, finalise, calc, print -use IPModel_Si_MEAM_module, only : ipmodel_si_meam, initialise, finalise, calc, print -use IPModel_FS_module, only : ipmodel_fs, initialise, finalise, calc, print -use IPModel_BOP_module, only : ipmodel_bop, initialise, finalise, calc, print -use IPModel_Brenner_Screened_module, only : ipmodel_brenner_screened, initialise, finalise, calc, print -use IPModel_Brenner_2002_module, only : ipmodel_brenner_2002, initialise, finalise, calc, print -#ifdef HAVE_ASAP -use IPModel_ASAP_module, only : ipmodel_asap, initialise, finalise, calc, print -#endif -use IPModel_TS_module, only : ipmodel_ts, initialise, finalise, calc, print, setup_atoms -use IPModel_Glue_module, only : ipmodel_glue, initialise, finalise, calc, print -use IPModel_PartridgeSchwenke_module, only : ipmodel_partridgeschwenke, initialise, finalise, calc, print -use IPModel_Einstein_module, only : ipmodel_einstein, initialise, finalise, calc, print -use IPModel_Coulomb_module, only : ipmodel_coulomb, initialise, finalise, calc, print -use IPModel_Sutton_Chen_module, only : ipmodel_sutton_chen, initialise, finalise, calc, print -use IPModel_LMTO_TBE_module, only: ipmodel_lmto_tbe, initialise, finalise, calc, print -use IPModel_ZBL_module, only : ipmodel_zbl, initialise, finalise, calc, print -use IPModel_LinearSOAP_module, only: ipmodel_linearsoap, initialise, finalise, calc, print -use IPModel_CH4_module, only : ipmodel_CH4, initialise, finalise, calc, print -#ifdef HAVE_KIM -use IPModel_KIM_module, only : ipmodel_kim, initialise, finalise, calc, print -#endif -use IPModel_FX_module, only : ipmodel_fx, initialise, finalise, calc, print -use IPModel_HFdimer_module, only : ipmodel_hfdimer, initialise, finalise, calc, print -use IPModel_WaterDimer_Gillan_module, only : ipmodel_waterdimer_gillan, initialise, finalise, calc, print -use IPModel_WaterTrimer_Gillan_module, only : ipmodel_watertrimer_gillan, initialise, finalise, calc, print -use IPModel_BornMayer_module, only : ipmodel_bornmayer, initialise, finalise, calc, print -use IPModel_Custom_module, only : ipmodel_custom, initialise, finalise, calc, print -use IPModel_ConfiningMonomer_module, only : ipmodel_confiningmonomer, initialise, finalise, calc, print -use IPModel_Tether_module, only : ipmodel_tether, initialise, finalise, calc, print -use IPModel_Spring_module, only : ipmodel_Spring, initialise, finalise, calc, print -use IPModel_SW_VP_module, only : ipmodel_sw_vp, initialise, finalise, calc, print -use IPModel_Multipoles_module, only : ipmodel_multipoles, initialise, finalise, calc, print -use IPModel_FC4_module, only : ipmodel_fc4, initialise, finalise, calc, print -use IPModel_DispTS_module, only : ipmodel_dispts, initialise, finalise, calc, print -use IPModel_SCME_module, only : ipmodel_scme, initialise, finalise, calc, print -use IPModel_MTP_module, only : ipmodel_mtp, initialise, finalise, calc, print -use IPModel_MBD_module, only : ipmodel_mbd, initialise, finalise, calc, print -use IPModel_TTM_nF_module, only : ipmodel_ttm_nf, initialise, finalise, calc, print -use IPModel_vdW_module, only : ipmodel_vdW, initialise, finalise, calc, print -use IPModel_RS_module, only : ipmodel_rs, initialise, finalise, calc, print -! Add new IP here -use IPModel_Template_module, only : ipmodel_template, initialise, finalise, calc, print - -implicit none - -private - -integer, parameter :: FF_LJ = 1, FF_SW = 2, FF_Tersoff = 3, FF_EAM_ErcolAd = 4, & - FF_Brenner = 5, FF_GAP = 6, FF_FS = 7, FF_BOP = 8, FF_FB = 9, FF_Si_MEAM = 10, FF_Brenner_Screened = 11, & - FF_Brenner_2002 = 12, FF_ASAP = 13, FF_TS = 14, FF_FC = 15, FF_Morse = 16, FF_GLUE = 17, FF_PartridgeSchwenke = 18, & - FF_Einstein = 19, FF_Coulomb = 20, FF_Sutton_Chen = 21, FF_KIM = 22, FF_FX = 23, FF_HFdimer = 24, FF_Custom = 25, FF_SW_VP=26, & - FF_BornMayer = 27, FF_WaterDimer_Gillan=28, FF_WaterTrimer_Gillan=29, FF_Tether=30, FF_LMTO_TBE=31, FF_FC4 = 32, FF_Spring=33, & - FF_Multipoles=34, FF_SCME = 35, FF_MTP = 36, FF_ZBL=37, FF_LinearSOAP=38, & - FF_MBD=39, FF_DispTS=40, FF_TTM_NF = 41, FF_CH4=42, FF_ConfiningMonomer=43, FF_vdW = 44, FF_RS=45, & ! Add new IPs here - FF_Template = 99 - -public :: IP_type -type IP_type - integer :: functional_form = 0 - - type(IPModel_GAP) ip_gap - type(IPModel_LJ) ip_lj - type(IPModel_Morse) ip_morse - type(IPModel_FC) ip_fc - type(IPModel_SW) ip_sw - type(IPModel_Tersoff) ip_Tersoff - type(IPModel_EAM_ErcolAd) ip_EAM_ErcolAd - type(IPModel_Brenner) ip_Brenner - type(IPModel_FB) ip_FB - type(IPModel_Si_MEAM) ip_Si_MEAM - type(IPModel_FS) ip_fs - type(IPModel_BOP) ip_BOP - type(IPModel_Brenner_Screened) ip_Brenner_Screened - type(IPModel_Brenner_2002) ip_Brenner_2002 -#ifdef HAVE_ASAP - type(IPModel_ASAP) ip_ASAP -#endif - type(IPModel_TS) ip_TS - type(IPModel_Glue) ip_Glue - type(IPModel_PartridgeSchwenke) ip_PartridgeSchwenke - type(IPModel_Einstein) ip_Einstein - type(IPModel_Coulomb) ip_Coulomb - type(IPModel_Sutton_Chen) ip_Sutton_Chen -#ifdef HAVE_KIM - type(IPModel_KIM) ip_KIM -#endif - type(IPModel_FX) ip_FX - type(IPModel_BornMayer) ip_BornMayer - type(IPModel_Custom) ip_Custom - type(IPModel_ConfiningMonomer) ip_ConfiningMonomer - type(IPModel_HFdimer) ip_HFdimer - type(IPModel_SW_VP) ip_sw_vp - type(IPModel_WaterDimer_Gillan) ip_waterdimer_gillan - type(IPModel_WaterTrimer_Gillan) ip_watertrimer_gillan - type(IPModel_Tether) ip_Tether - type(IPModel_Spring) ip_Spring - type(IPModel_LMTO_TBE) ip_LMTO_TBE - type(IPModel_Multipoles) ip_Multipoles - type(IPModel_FC4) ip_fc4 - type(IPModel_DispTS) ip_dispts - type(IPModel_SCME) ip_SCME - type(IPModel_MTP) ip_MTP - type(IPModel_ZBL) ip_ZBL - type(IPModel_MBD) ip_MBD - type(IPModel_LinearSOAP) ip_LinearSOAP - type(IPModel_TTM_nF) ip_TTM_nF - ! Add new IP here - type(IPModel_CH4) ip_CH4 - type(IPModel_vdW) ip_vdW - type(IPModel_RS) ip_RS - type(IPModel_Template) ip_Template - type(mpi_context) :: mpi_glob, mpi_local - -end type IP_type - -!% Initialise IP_type object defining the IP model and the corresponding parameters. If necessary -!% it initialises the input file for the potential parameters. -public :: Initialise -public :: IP_Initialise_filename -interface Initialise - module procedure IP_Initialise_inoutput, IP_Initialise_str -end interface Initialise - -public :: Finalise -interface Finalise - module procedure IP_Finalise -end interface Finalise - -!% Return the cutoff of this interatomic potential -public :: cutoff -interface cutoff - module procedure IP_cutoff -end interface - -!% Print the parameters of the selected IP model -public :: Print -interface Print - module procedure IP_Print -end interface Print - -!% Hook routine called before calc() is invoked. Can be used to add required properties. -public :: setup_atoms -interface setup_atoms - module procedure ip_setup_atoms -end interface - -!% Call the potential calculator for the selected IP model -public :: Calc -private :: IP_Calc -interface Calc - module procedure IP_Calc -end interface Calc - -!% set up optimal parameters for parallel computation for a given system -public :: setup_parallel -private :: IP_setup_parallel -interface setup_parallel - module procedure IP_setup_parallel -end interface setup_parallel - -contains - -!% OMIT -subroutine IP_Initialise_filename(this, args_str, filename, mpi_obj, error) - type(IP_type), intent(inout) :: this - character(len=*), intent(in) :: args_str - character(len=*), intent(in) :: filename !% File name containing the IP parameters - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(inoutput) io - - INIT_ERROR(error) - - call Initialise(io, filename, INPUT) - - call Initialise(this, args_str, io, mpi_obj) - - call Finalise(io) - -end subroutine - - -subroutine IP_Initialise_inoutput(this, args_str, io_obj, mpi_obj, error) - type(IP_type), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(inoutput), intent(inout), optional :: io_obj - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(extendable_str) :: ss - - INIT_ERROR(error) - - call Initialise(ss) - if (present(io_obj)) then - if (present(mpi_obj)) then - call read(ss, io_obj%unit, convert_to_string=.true., mpi_comm=mpi_obj%communicator, mpi_id=mpi_obj%my_proc) - else - call read(ss, io_obj%unit, convert_to_string=.true.) - endif - endif - call Initialise(this, args_str, string(ss), mpi_obj) - call Finalise(ss) - -end subroutine IP_Initialise_inoutput - -subroutine IP_Initialise_str(this, args_str, param_str, mpi_obj, error) - type(IP_type), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(Dictionary) :: params - logical is_GAP, is_LJ, is_FC, is_Morse, is_SW, is_Tersoff, is_EAM_ErcolAd, is_Brenner, is_FS, is_BOP, is_FB, is_Si_MEAM, & - is_Brenner_Screened, is_Brenner_2002, is_ASAP, is_TS, is_Glue, is_PartridgeSchwenke, is_Einstein, is_Coulomb, & - is_Sutton_Chen, is_KIM, is_FX, is_HFdimer, is_BornMayer, is_Custom, is_SW_VP, is_WaterDimer_Gillan , & - is_WaterTrimer_Gillan, is_Tether, is_Spring, is_LMTO_TBE, is_FC4 , is_Multipoles, is_SCME, is_MTP, & - is_MBD, is_ZBL, is_LinearSOAP, is_DispTS, is_TTM_nF, is_CH4, is_ConfiningMonomer, is_vdW, is_RS, &! Add new IPs here - is_Template - - INIT_ERROR(error) - - call Finalise(this) - - call initialise(params) - call param_register(params, 'GAP', 'false', is_GAP, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'LJ', 'false', is_LJ, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Morse', 'false', is_Morse, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'FC', 'false', is_FC, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SW', 'false', is_SW, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Tersoff', 'false', is_Tersoff, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'EAM_ErcolAd', 'false', is_EAM_ErcolAd, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Brenner', 'false', is_Brenner, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'FB', 'false', is_FB, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Si_MEAM', 'false', is_Si_MEAM, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'FS', 'false', is_FS, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'BOP', 'false', is_BOP, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Brenner_Screened', 'false', is_Brenner_Screened, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Brenner_2002', 'false', is_Brenner_2002, help_string="No help yet. This source file was $LastChangedBy$") -#ifdef HAVE_ASAP - call param_register(params, 'ASAP', 'false', is_ASAP, help_string="No help yet. This source file was $LastChangedBy$") -#else - is_ASAP = .false. -#endif - call param_register(params, 'TS', 'false', is_TS, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Glue', 'false', is_Glue, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'PartridgeSchwenke', 'false', is_PartridgeSchwenke, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Einstein', 'false', is_Einstein, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Coulomb', 'false', is_Coulomb, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Sutton_Chen', 'false', is_Sutton_Chen, help_string="No help yet. This source file was $LastChangedBy$") -#ifdef HAVE_KIM - call param_register(params, 'KIM', 'false', is_KIM, help_string="No help yet. This source file was $LastChangedBy$") -#else - is_KIM = .false. -#endif - call param_register(params, 'FX', 'false', is_FX, help_string="Fanourgakis-Xantheas model of water") - call param_register(params, 'BornMayer', 'false', is_BornMayer, help_string="Born-Mayer potential") - call param_register(params, 'Custom', 'false', is_Custom, help_string="Customised (hard wired) potential") - call param_register(params, 'ConfiningMonomer', 'false', is_ConfiningMonomer, help_string="Confining potential for monomers, currently hardcoded for CH4") - call param_register(params, 'HFdimer', 'false', is_HFdimer, help_string="HF dimer potential") - call param_register(params, 'SW_VP', 'false', is_SW_VP, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'WaterDimer_Gillan', 'false', is_WaterDimer_Gillan, help_string='Water Dimer 2-body potential by Mike Gillan') - call param_register(params, 'WaterTrimer_Gillan', 'false', is_WaterTrimer_Gillan, help_string='Water Trimer 3-body potential by Mike Gillan') - call param_register(params, 'Tether', 'false', is_Tether, help_string="Tether a selection of atoms to the origin with a spring") - call param_register(params, 'Spring', 'false', is_Spring, help_string="Tether a selection of atoms to each other with a spring") - call param_register(params, 'LMTO_TBE', 'false', is_LMTO_TBE, help_string="Interface to LMTO empirical Tight Binding code") - call param_register(params, 'Multipoles', 'false', is_Multipoles, help_string="Electrostatics including charges, dipoles, polarisabilities") - call param_register(params, 'FC4', 'false', is_FC4, help_string="Fourth-order force-constant potential of Esfarjani et al") - call param_register(params, 'DispTS', 'false', is_DispTS, help_string="Dispersion correction from Tkatchenko and Scheffler (PRL, 2009)") - call param_register(params, 'SCME', 'false', is_SCME, help_string="SCME water potential") - call param_register(params, 'MTP', 'false', is_MTP, help_string="MTP potential") - call param_register(params, 'MBD', 'false', is_MBD, help_string="Many-body dispersion correction") - call param_register(params, 'ZBL', 'false', is_ZBL, help_string="ZBL potential") - call param_register(params, 'TTM_nF', 'false', is_TTM_nF, help_string="TTM_nF water potentials") - call param_register(params, 'LinearSOAP', 'false', is_LinearSOAP, help_string="LinearSOAP potential") - ! Add new IP here - call param_register(params, 'CH4', 'false', is_CH4, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'vdW', 'false', is_vdW, help_string="van der Waals correction") - call param_register(params, 'RS', 'false', is_RS, help_string="Repulsive Step potential") - call param_register(params, 'Template', 'false', is_Template, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IP_Initialise_str args_str')) then - RAISE_ERROR("IP_Initialise_str failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if (count((/is_GAP, is_LJ, is_FC, is_Morse, is_SW, is_Tersoff, is_EAM_ErcolAd, is_Brenner, is_FS, is_BOP, is_FB, is_Si_MEAM, & - is_Brenner_Screened, is_Brenner_2002, is_ASAP, is_TS, is_Glue, is_PartridgeSchwenke, is_Einstein, is_Coulomb, & - is_Sutton_Chen, is_KIM, is_FX, is_HFdimer, is_BornMayer, is_Custom, is_SW_VP, is_WaterDimer_Gillan,is_WaterTrimer_Gillan, & - is_Tether, is_Spring, is_LMTO_TBE, is_FC4, is_Multipoles, is_DispTS, is_SCME, is_MTP, is_MBD, is_ZBL,is_linearSOAP, & - is_TTM_nF, is_CH4, is_ConfiningMonomer, is_vdW, is_RS, & ! add new IPs here - is_Template /)) /= 1) then - RAISE_ERROR("IP_Initialise_str found too few or too many IP Model types args_str='"//trim(args_str)//"'", error) - endif - - if (is_GAP) then - this%functional_form = FF_GAP - call Initialise(this%ip_gap, args_str, param_str) - else if (is_LJ) then - this%functional_form = FF_LJ - call Initialise(this%ip_lj, args_str, param_str) - else if (is_Morse) then - this%functional_form = FF_Morse - call Initialise(this%ip_morse, args_str, param_str) - else if (is_FC) then - this%functional_form = FF_FC - call Initialise(this%ip_fc, args_str, param_str) - else if (is_SW) then - this%functional_form = FF_SW - call Initialise(this%ip_sw, args_str, param_str) - else if (is_Tersoff) then - this%functional_form = FF_Tersoff - call Initialise(this%ip_tersoff, args_str, param_str) - else if (is_EAM_ErcolAd) then - this%functional_form = FF_EAM_ErcolAd - call Initialise(this%ip_EAM_ErcolAd, args_str, param_str) - else if (is_Brenner) then - this%functional_form = FF_Brenner - call Initialise(this%ip_Brenner, args_str, param_str) - else if (is_FB) then - this%functional_form = FF_FB - call Initialise(this%ip_FB, args_str, param_str) - else if (is_Si_MEAM) then - this%functional_form = FF_Si_MEAM - call Initialise(this%ip_Si_MEAM, args_str, param_str) - else if (is_FS) then - this%functional_form = FF_FS - call Initialise(this%ip_fs, args_str, param_str) - else if (is_BOP) then - this%functional_form = FF_BOP - call Initialise(this%ip_bop, args_str, param_str) - else if (is_Brenner_Screened) then - this%functional_form = FF_Brenner_Screened - call Initialise(this%ip_brenner_screened, args_str, param_str) - else if (is_Brenner_2002) then - this%functional_form = FF_Brenner_2002 - call Initialise(this%ip_brenner_2002, args_str, param_str) -#ifdef HAVE_ASAP - else if (is_ASAP) then - this%functional_form = FF_ASAP - call Initialise(this%ip_ASAP, args_str, param_str) -#endif - else if (is_TS) then - this%functional_form = FF_TS - call Initialise(this%ip_TS, args_str, param_str) - else if (is_Glue) then - this%functional_form = FF_GLUE - call Initialise(this%ip_Glue, args_str, param_str) - else if (is_PartridgeSchwenke) then - this%functional_form = FF_PartridgeSchwenke - call Initialise(this%ip_PartridgeSchwenke, args_str, param_str) - else if (is_Einstein) then - this%functional_form = FF_Einstein - call Initialise(this%ip_Einstein, args_str, param_str) - else if (is_Coulomb) then - this%functional_form = FF_Coulomb - call Initialise(this%ip_Coulomb, args_str, param_str) - else if (is_Sutton_Chen) then - this%functional_form = FF_Sutton_Chen - call Initialise(this%ip_Sutton_Chen, args_str, param_str) -#ifdef HAVE_KIM - else if (is_KIM) then - this%functional_form = FF_KIM - call Initialise(this%ip_KIM, args_str, param_str) -#endif - else if (is_FX) then - this%functional_form = FF_FX - call Initialise(this%ip_fx, args_str, param_str) - else if (is_BornMayer) then - this%functional_form = FF_BornMayer - call Initialise(this%ip_bornmayer, args_str, param_str) - else if (is_Custom) then - this%functional_form = FF_Custom - call Initialise(this%ip_custom, args_str, param_str) - else if (is_ConfiningMonomer) then - this%functional_form = FF_ConfiningMonomer - call Initialise(this%ip_confiningmonomer, args_str, param_str) - else if (is_HFdimer) then - this%functional_form = FF_HFdimer - call Initialise(this%ip_HFdimer, args_str, param_str) - else if (is_SW_VP) then - this%functional_form = FF_SW_VP - call Initialise(this%ip_sw_vp, args_str, param_str) - else if (is_WaterDimer_Gillan) then - this%functional_form = FF_WaterDimer_Gillan - call Initialise(this%ip_waterdimer_gillan, args_str, param_str) - else if (is_WaterTrimer_Gillan) then - this%functional_form = FF_WaterTrimer_Gillan - call Initialise(this%ip_watertrimer_gillan, args_str, param_str) - else if (is_Tether) then - this%functional_form = FF_Tether - call Initialise(this%ip_tether, args_str, param_str) - else if (is_Spring) then - this%functional_form = FF_Spring - call Initialise(this%ip_Spring, args_str, param_str) - else if (is_LMTO_TBE) then - this%functional_form = FF_LMTO_TBE - call Initialise(this%ip_LMTO_TBE, args_str, param_str) - else if (is_FC4) then - this%functional_form = FF_FC4 - call Initialise(this%ip_FC4, args_str, param_str) - else if (is_Multipoles) then - this%functional_form = FF_Multipoles - call Initialise(this%ip_Multipoles, args_str, param_str) - else if (is_DispTS) then - this%functional_form = FF_DispTS - call Initialise(this%ip_dispts, args_str, param_str) - else if (is_SCME) then - this%functional_form = FF_SCME - call Initialise(this%ip_SCME, args_str, param_str) - else if (is_MTP) then - this%functional_form = FF_MTP - call Initialise(this%ip_MTP, args_str, param_str) - else if (is_MBD) then - this%functional_form = FF_MBD - call Initialise(this%ip_MBD, args_str, param_str) - else if (is_ZBL) then - this%functional_form = FF_ZBL - call Initialise(this%ip_ZBL, args_str, param_str) - else if (is_LinearSOAP) then - this%functional_form = FF_LinearSOAP - call Initialise(this%ip_LinearSOAP, args_str, param_str) - else if (is_TTM_nF) then - this%functional_form = FF_TTM_nF - call Initialise(this%ip_TTM_nF, args_str, param_str) - else if (is_CH4) then - this%functional_form = FF_CH4 - call Initialise(this%ip_CH4, args_str, param_str) - else if (is_vdW) then - this%functional_form = FF_vdW - call Initialise(this%ip_vdW, args_str, param_str) - else if (is_RS) then - this%functional_form = FF_RS - call Initialise(this%ip_RS, args_str, param_str) - ! Add new IP here - else if (is_Template) then - this%functional_form = FF_Template - call Initialise(this%ip_Template, args_str, param_str) - end if - - if (present(mpi_obj)) this%mpi_glob = mpi_obj - -end subroutine IP_Initialise_str - -subroutine IP_Finalise(this) - type(IP_type), intent(inout) :: this - - if (this%mpi_local%active) call free_context(this%mpi_local) - select case (this%functional_form) - case (FF_GAP) - call Finalise(this%ip_gap) - case (FF_LJ) - call Finalise(this%ip_lj) - case (FF_Morse) - call Finalise(this%ip_morse) - case (FF_FC) - call Finalise(this%ip_fc) - case (FF_SW) - call Finalise(this%ip_sw) - case (FF_Tersoff) - call Finalise(this%ip_tersoff) - case (FF_EAM_ErcolAd) - call Finalise(this%ip_EAM_ErcolAd) - case(FF_Brenner) - call Finalise(this%ip_Brenner) - case(FF_FB) - call Finalise(this%ip_fb) - case(FF_Si_MEAM) - call Finalise(this%ip_Si_MEAM) - case (FF_FS) - call Finalise(this%ip_fs) - case (FF_BOP) - call Finalise(this%ip_bop) - case (FF_Brenner_Screened) - call Finalise(this%ip_brenner_screened) - case (FF_Brenner_2002) - call Finalise(this%ip_brenner_2002) -#ifdef HAVE_ASAP - case (FF_ASAP) - call Finalise(this%ip_ASAP) -#endif - case (FF_TS) - call Finalise(this%ip_TS) - case (FF_GLUE) - call Finalise(this%ip_Glue) - case (FF_PartridgeSchwenke) - call Finalise(this%ip_PartridgeSchwenke) - case (FF_Einstein) - call Finalise(this%ip_Einstein) - case (FF_Coulomb) - call Finalise(this%ip_Coulomb) - case (FF_Sutton_Chen) - call Finalise(this%ip_Sutton_Chen) -#ifdef HAVE_KIM - case (FF_KIM) - call Finalise(this%ip_KIM) -#endif - case (FF_FX) - call Finalise(this%ip_FX) - case(FF_BornMayer) - call Finalise(this%ip_BornMayer) - case (FF_Custom) - call Finalise(this%ip_Custom) - case (FF_ConfiningMonomer) - call Finalise(this%ip_confiningmonomer) - case (FF_HFdimer) - call Finalise(this%ip_HFdimer) - case (FF_SW_VP) - call Finalise(this%ip_sw_vp) - case (FF_WaterDimer_Gillan) - call Finalise(this%ip_waterdimer_gillan) - case (FF_WaterTrimer_Gillan) - call Finalise(this%ip_watertrimer_gillan) - case (FF_Tether) - call Finalise(this%ip_Tether) - case (FF_Spring) - call Finalise(this%ip_Spring) - case (FF_LMTO_TBE) - call Finalise(this%ip_LMTO_TBE) - case (FF_FC4) - call Finalise(this%ip_FC4) - case (FF_Multipoles) - call Finalise(this%ip_Multipoles) - case (FF_DispTS) - call Finalise(this%ip_dispts) - case (FF_SCME) - call Finalise(this%ip_SCME) - case (FF_MTP) - call Finalise(this%ip_MTP) - case (FF_MBD) - call Finalise(this%ip_MBD) - case (FF_ZBL) - call Finalise(this%ip_ZBL) - case (FF_LinearSOAP) - call Finalise(this%ip_LinearSOAP) - case (FF_TTM_nF) - call Finalise(this%ip_TTM_nF) - case (FF_CH4) - call Finalise(this%ip_CH4) - case (FF_vdW) - call Finalise(this%ip_vdW) - case (FF_RS) - call Finalise(this%ip_RS) - ! add new IP here - case (FF_Template) - call Finalise(this%ip_Template) - end select - -end subroutine IP_Finalise - -function IP_cutoff(this) - type(IP_type), intent(in) :: this - real(dp) :: IP_cutoff - - select case (this%functional_form) - case (FF_GAP) - IP_cutoff = this%ip_gap%cutoff - case (FF_LJ) - IP_cutoff = this%ip_lj%cutoff - case (FF_Morse) - IP_cutoff = this%ip_morse%cutoff - case (FF_FC) - IP_cutoff = this%ip_fc%cutoff - case (FF_SW) - IP_cutoff = this%ip_sw%cutoff - case (FF_Tersoff) - IP_cutoff = this%ip_tersoff%cutoff - case (FF_EAM_ErcolAd) - IP_cutoff = this%ip_EAM_ErcolAd%cutoff - case(FF_Brenner) - IP_cutoff = this%ip_Brenner%cutoff - case(FF_FB) - IP_cutoff = this%ip_FB%cutoff - case(FF_Si_MEAM) - IP_cutoff = this%ip_Si_MEAM%cutoff - case (FF_FS) - IP_cutoff = this%ip_fs%cutoff - case (FF_BOP) - IP_cutoff = this%ip_bop%cutoff - case (FF_Brenner_Screened) - IP_cutoff = this%ip_brenner_screened%cutoff - case (FF_Brenner_2002) - IP_cutoff = this%ip_brenner_2002%cutoff -#ifdef HAVE_ASAP - case (FF_ASAP) - IP_cutoff = max(this%ip_asap%cutoff_ms, this%ip_asap%cutoff_coulomb)*BOHR -#endif - case (FF_TS) - IP_cutoff = max(this%ip_TS%cutoff_ms, this%ip_TS%cutoff_coulomb)*BOHR - case (FF_GLUE) - IP_cutoff = this%ip_Glue%cutoff - case (FF_PartridgeSchwenke) - IP_cutoff = this%ip_PartridgeSchwenke%cutoff - case (FF_Einstein) - IP_cutoff = this%ip_Einstein%cutoff - case (FF_Coulomb) - IP_cutoff = this%ip_Coulomb%cutoff - case (FF_Sutton_Chen) - IP_cutoff = this%ip_Sutton_Chen%cutoff -#ifdef HAVE_KIM - case (FF_KIM) - IP_cutoff = this%ip_kim%cutoff -#endif - case (FF_FX) - IP_cutoff = this%ip_fx%cutoff - case (FF_BornMayer) - IP_cutoff = this%ip_BornMayer%cutoff - case (FF_Custom) - IP_cutoff = this%ip_custom%cutoff - case (FF_ConfiningMonomer) - IP_cutoff = this%ip_confiningmonomer%cutoff - case (FF_HFdimer) - IP_cutoff = this%ip_HFdimer%cutoff - case (FF_SW_VP) - IP_cutoff = this%ip_sw_vp%cutoff - case (FF_WaterDimer_Gillan) - IP_cutoff = this%ip_waterdimer_gillan%cutoff - case (FF_WaterTrimer_Gillan) - IP_cutoff = this%ip_watertrimer_gillan%cutoff - case (FF_Tether) - IP_cutoff = this%ip_tether%cutoff - case (FF_Spring) - IP_cutoff = this%ip_Spring%cutoff - case(FF_LMTO_TBE) - IP_cutoff = this%ip_LMTO_TBE%cutoff - case(FF_FC4) - IP_cutoff = this%ip_FC4%cutoff - case (FF_Multipoles) - IP_cutoff = this%ip_multipoles%cutoff - case (FF_DispTS) - IP_cutoff = this%ip_dispts%cutoff - case (FF_SCME) - IP_cutoff = this%ip_SCME%cutoff - case (FF_MTP) - IP_cutoff = this%ip_MTP%cutoff - case (FF_MBD) - IP_cutoff = this%ip_MBD%cutoff - case (FF_ZBL) - IP_cutoff = this%ip_ZBL%cutoff - case (FF_LinearSOAP) - IP_cutoff = this%ip_LinearSOAP%cutoff - case (FF_TTM_nF) - IP_cutoff = this%ip_TTM_nF%cutoff - case (FF_CH4) - IP_cutoff = this%ip_CH4%cutoff - case (FF_vdW) - IP_cutoff = this%ip_vdW%cutoff - case (FF_RS) - IP_cutoff = this%ip_RS%cutoff - ! Add new IP here - case (FF_Template) - IP_cutoff = this%ip_Template%cutoff - case default - IP_cutoff = 0.0_dp - end select -end function IP_cutoff - -subroutine IP_setup_atoms(this, at) - type(IP_type), intent(in) :: this - type(Atoms), intent(inout) :: at - - select case (this%functional_form) - case (FF_TS) - call setup_atoms(this%ip_TS, at) - end select - -end subroutine IP_setup_atoms - -subroutine IP_Calc(this, at, energy, local_e, f, virial, local_virial, args_str, error) - type(IP_type), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: energy, local_e(:) !% \texttt{energy} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) - real(dp), intent(out), optional :: virial(3,3) - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - type(Dictionary) :: params - integer :: pgroup_size - integer :: n_groups - logical :: has_pgroup_size = .false. - logical :: do_auto_pgroups = .true. - - INIT_ERROR(error) - - call initialise(params) - call param_register(params, 'pgroup_size', '0', pgroup_size, has_value_target=has_pgroup_size, & - help_string="Explicitly specify the parallel group size, i.e. the number of & - MPI processes") - if (present(args_str)) then - if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='IP_Calc')) then - call system_abort("IP_Calc failed to parse args_str " // args_str) - endif - endif - call finalise(params) - - call system_timer("IP_Calc") - - if (this%mpi_glob%active .and. .not. this%mpi_local%active) then - do_auto_pgroups = .true. - if (has_pgroup_size) then - if ((pgroup_size > 0) .and. (pgroup_size <= this%mpi_glob%n_procs)) then - n_groups = this%mpi_glob%n_procs / pgroup_size - if (n_groups * pgroup_size == this%mpi_glob%n_procs) then - do_auto_pgroups = .false. - else - call print_message('WARNING', "Invalid parallel group size specified: " // pgroup_size) - call print_message('WARNING', "Falling back to automatic selection") - endif - else - call print_message('WARNING', "Invalid parallel group size specified: " // pgroup_size) - call print_message('WARNING', "Falling back to automatic selection") - endif - endif - if (do_auto_pgroups) then - call setup_parallel(this, at, energy, local_e, f, virial, local_virial) - else - call setup_parallel_groups(this, this%mpi_glob, pgroup_size) - endif - endif - - select case (this%functional_form) - case (FF_GAP) - call calc(this%ip_gap, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_LJ) - call calc(this%ip_lj, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - PASS_ERROR(error) - case (FF_Morse) - call calc(this%ip_morse, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_FC) - call calc(this%ip_fc, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_SW) - call calc(this%ip_sw, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Tersoff) - call calc(this%ip_tersoff, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_EAM_ErcolAd) - call calc(this%ip_EAM_ErcolAd, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case(FF_Brenner) - call calc(this%ip_Brenner, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case(FF_FB) - call calc(this%ip_FB, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case(FF_Si_MEAM) - call calc(this%ip_Si_MEAM, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_FS) - call calc(this%ip_fs, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_BOP) - call calc(this%ip_bop, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Brenner_Screened) - call calc(this%ip_brenner_screened, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Brenner_2002) - call calc(this%ip_brenner_2002, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) -#ifdef HAVE_ASAP - case (FF_ASAP) - call calc(this%ip_asap, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) -#endif - case (FF_TS) - call calc(this%ip_TS, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_GLUE) - call calc(this%ip_Glue, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_PartridgeSchwenke) - call calc(this%ip_PartridgeSchwenke, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Einstein) - call calc(this%ip_Einstein, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Coulomb) - call calc(this%ip_Coulomb, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Sutton_Chen) - call calc(this%ip_Sutton_Chen, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) -#ifdef HAVE_KIM - case (FF_KIM) - call calc(this%ip_KIM, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - PASS_ERROR(error) -#endif - case (FF_FX) - call calc(this%ip_FX, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_BornMayer) - call calc(this%ip_BornMayer, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Custom) - call calc(this%ip_Custom, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_ConfiningMonomer) - call calc(this%ip_confiningmonomer, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_HFdimer) - call calc(this%ip_HFdimer, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_SW_VP) - call calc(this%ip_sw_vp, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_WaterDimer_Gillan) - call calc(this%ip_waterdimer_gillan, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_WaterTrimer_Gillan) - call calc(this%ip_watertrimer_gillan, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Tether) - call calc(this%ip_Tether, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Spring) - call calc(this%ip_Spring, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_LMTO_TBE) - call calc(this%ip_LMTO_TBE, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_FC4) - call calc(this%ip_FC4, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_Multipoles) - call calc(this%ip_Multipoles, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_DispTS) - call calc(this%ip_dispts, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_SCME) - call calc(this%ip_SCME, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_MTP) - call calc(this%ip_MTP, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_MBD) - call calc(this%ip_MBD, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_ZBL) - call calc(this%ip_ZBL, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_LinearSOAP) - call calc(this%ip_LinearSOAP, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_TTM_nF) - call calc(this%ip_TTM_nF, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_CH4) - call calc(this%ip_CH4, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_vdW) - call calc(this%ip_vdW, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case (FF_RS) - call calc(this%ip_RS, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - ! Add new IP here - case (FF_Template) - call calc(this%ip_Template, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) - case default - RAISE_ERROR("IP_Calc confused by functional_form " // this%functional_form, error) - end select - - call system_timer("IP_Calc") -end subroutine IP_Calc - - -subroutine IP_Print(this, file, dict, error) - type(IP_type), intent(inout) :: this - type(Inoutput), intent(inout),optional :: file - type(Dictionary), intent(inout), optional :: dict - integer, intent(out), optional :: error - - INIT_ERROR(error) - - call Print ("IP : " // this%functional_form, file=file) - - select case (this%functional_form) - case (FF_GAP) - call Print(this%ip_gap, file=file, dict=dict) - case (FF_LJ) - call Print(this%ip_lj, file=file) - case (FF_Morse) - call Print(this%ip_morse, file=file) - case (FF_FC) - call Print(this%ip_fc, file=file) - case (FF_SW) - call Print(this%ip_sw, file=file) - case (FF_Tersoff) - call Print(this%ip_tersoff, file=file) - case (FF_EAM_ErcolAd) - call Print(this%ip_EAM_ErcolAd, file=file) - case (FF_Brenner) - call Print(this%ip_Brenner, file=file) - case (FF_FB) - call Print(this%ip_FB, file=file) - case (FF_Si_MEAM) - call Print(this%ip_Si_MEAM, file=file) - case (FF_FS) - call Print(this%ip_fs, file=file) - case (FF_BOP) - call Print(this%ip_bop, file=file) - case (FF_Brenner_Screened) - call Print(this%ip_brenner_screened, file=file) - case (FF_Brenner_2002) - call Print(this%ip_brenner_2002, file=file) -#ifdef HAVE_ASAP - case (FF_ASAP) - call Print(this%ip_asap, file=file) -#endif - case (FF_TS) - call Print(this%ip_TS, file=file) - case (FF_GLUE) - call Print(this%ip_Glue, file=file) - case (FF_PartridgeSchwenke) - call Print(this%ip_PartridgeSchwenke, file=file) - case (FF_Einstein) - call Print(this%ip_Einstein, file=file) - case (FF_Coulomb) - call Print(this%ip_Coulomb, file=file) - case (FF_Sutton_Chen) - call Print(this%ip_Sutton_Chen, file=file) -#ifdef HAVE_KIM - case (FF_KIM) - call Print(this%ip_kim, file=file) -#endif - case (FF_FX) - call Print(this%ip_fx, file=file) - case (FF_BornMayer) - call Print(this%ip_BornMayer, file=file) - case (FF_Custom) - call Print(this%ip_custom, file=file) - case (FF_ConfiningMonomer) - call Print(this%ip_confiningmonomer, file=file) - case (FF_HFdimer) - call Print(this%ip_HFdimer, file=file) - case (FF_SW_VP) - call Print(this%ip_sw_vp, file=file) - case (FF_WaterDimer_Gillan) - call Print(this%ip_waterdimer_gillan, file=file) - case (FF_WaterTrimer_Gillan) - call Print(this%ip_watertrimer_gillan, file=file) - case (FF_Tether) - call Print(this%ip_tether, file=file) - case (FF_Spring) - call Print(this%ip_Spring, file=file) - case (FF_LMTO_TBE) - call Print(this%ip_LMTO_TBE, file=file) - case (FF_FC4) - call Print(this%ip_FC4, file=file) - case (FF_Multipoles) - call Print(this%ip_Multipoles, file=file) - case (FF_DispTS) - call Print(this%ip_dispts, file=file) - case (FF_SCME) - call Print(this%ip_SCME, file=file) - case (FF_MTP) - call Print(this%ip_MTP, file=file) - case (FF_MBD) - call Print(this%ip_MBD, file=file) - case (FF_ZBL) - call Print(this%ip_ZBL, file=file) - case (FF_LinearSOAP) - call Print(this%ip_LinearSOAP, file=file) - case (FF_TTM_nF) - call Print(this%ip_TTM_nF, file=file) - case (FF_CH4) - call Print(this%ip_CH4, file=file) - case (FF_vdW) - call Print(this%ip_vdW, file=file) - case (FF_RS) - call Print(this%ip_RS, file=file) - ! add new IP here - case (FF_Template) - call Print(this%ip_Template, file=file) - case default - RAISE_ERROR("IP_Print confused by functional_form " // this%functional_form, error) - end select - -end subroutine IP_Print - -subroutine IP_setup_parallel(this, at, energy, local_e, f, virial, local_virial, args_str) - type(IP_type), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: energy, local_e(:) !% \texttt{energy} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), intent(in), optional :: args_str - - - integer :: pgroup_size, prev_pgroup_size - integer :: n_groups - real(dp) :: prev_time, this_time - - prev_time = 1.0e38_dp - prev_pgroup_size = 0 - - call print('IP_Setup_Parallel timings', PRINT_VERBOSE) - call print('IP_Setup_Parallel group_size time/sec', PRINT_VERBOSE) - - call print("IP_Setup_Parallel at%N "//at%N// " present(energy) "//present(energy)// " present(local_e) "//present(local_e)// " present(f) "//present(f)// " present(virial) "//present(virial)// " present(local_virial) "//present(local_virial), PRINT_VERBOSE) - - call setup_atoms(this, at) - do pgroup_size=this%mpi_glob%n_procs, 1, -1 - n_groups = this%mpi_glob%n_procs / pgroup_size - if (n_groups*pgroup_size == this%mpi_glob%n_procs) then - call setup_parallel_groups(this, this%mpi_glob, pgroup_size) - call system_timer("IP_parallel", do_always = .true., do_print = .false.) - call calc(this, at, energy, local_e, f, virial, local_virial, args_str) - call system_timer("IP_parallel", do_always = .true., time_elapsed = this_time, do_print = .false.) - this_time = max(this%mpi_glob, this_time) - call print("IP_Setup_Parallel "//pgroup_size//' '//this_time, PRINT_VERBOSE) - if (this_time > prev_time) then - call setup_parallel_groups(this, this%mpi_glob, prev_pgroup_size) - exit - else - prev_time = this_time - prev_pgroup_size = pgroup_size - endif - endif - end do - - call print("Parallelizing IP using group_size " // prev_pgroup_size, PRINT_ALWAYS) -end subroutine IP_setup_parallel - -subroutine setup_parallel_groups(this, mpi, pgroup_size, error) - type(IP_type), intent(inout) :: this - type(mpi_context), intent(in) :: mpi - integer, intent(in) :: pgroup_size - integer, intent(out), optional :: error - - integer :: split_index - - INIT_ERROR(error) - - if (this%mpi_local%active) call free_context(this%mpi_local) - - if (mpi%active) then - split_index = mpi%my_proc/pgroup_size - call split_context(mpi, split_index, this%mpi_local) - endif - -end subroutine setup_parallel_groups - -end module IP_module diff --git a/src/Potentials/IPEwald.f95 b/src/Potentials/IPEwald.f95 deleted file mode 100644 index 8aadd83514..0000000000 --- a/src/Potentials/IPEwald.f95 +++ /dev/null @@ -1,554 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPEwald_module - -use error_module -use system_module, only : dp, optional_default, PRINT_ANALYSIS, operator(//) -use units_module -use Atoms_module -use linearalgebra_module -use functions_module - -implicit none - -real(dp), parameter :: reciprocal_time_by_real_time = 1.0_dp / 3.0_dp - -private -public :: Ewald_calc, Ewald_corr_calc, Direct_Coulomb_Calc, DSF_Coulomb_calc - -contains - - ! Ewald routine - ! input: atoms object, has to have charge property - ! input, optional: ewald_error (controls speed and ewald_error) - ! input, optional: use_ewald_cutoff (forces original cutoff to be used) - ! output: energy, force, virial - - ! procedure to determine optimal Ewald parameters: - ! Optimization of the Ewald sum for large systems, Mol. Simul. 13 (1994), no. 1, 1-9. - - subroutine Ewald_calc(at_in, charge, e, f, virial, ewald_error, use_ewald_cutoff, smooth_coulomb_cutoff, error) - - type(Atoms), intent(in), target :: at_in - real(dp), dimension(:), intent(in) :: charge - - real(dp), intent(out), optional :: e - real(dp), dimension(:,:), intent(out), optional :: f - real(dp), dimension(3,3), intent(out), optional :: virial - real(dp), intent(in), optional :: ewald_error - logical, intent(in), optional :: use_ewald_cutoff - real(dp), intent(in), optional :: smooth_coulomb_cutoff - integer, intent(out), optional :: error - - integer :: i, j, k, n, n1, n2, n3, not_needed !for reciprocal force - integer, dimension(3) :: nmax !how many reciprocal vectors are to be taken - - logical :: my_use_ewald_cutoff - - real(dp) :: r_ij, erfc_ar, arg, my_ewald_error, alpha, kmax, kmax2, prefac, infac, two_alpha_over_sqrt_pi, v, & - & ewald_precision, ewald_cutoff, my_cutoff, my_smooth_coulomb_cutoff, smooth_arg, smooth_f, dsmooth_f - - real(dp), dimension(3) :: force, u_ij, a, b, c, h - real(dp), dimension(3,3) :: identity3x3, k3x3 - real(dp), dimension(:,:,:,:), allocatable :: coskr, sinkr - real(dp), dimension(:,:,:,:), allocatable :: k_vec ! reciprocal vectors - real(dp), dimension(:,:,:,:), allocatable :: force_factor - real(dp), dimension(:,:,:), allocatable :: energy_factor - real(dp), dimension(:,:,:), allocatable :: mod2_k !square of length of reciprocal vectors - - type(Atoms), target :: my_at - type(Atoms), pointer :: at - - INIT_ERROR(error) - - call check_size('charge',charge,at_in%N,'IPEwald',error) - - identity3x3 = 0.0_dp - call add_identity(identity3x3) - - ! Set up Ewald calculation - my_ewald_error = optional_default(1e-06_dp,ewald_error) * 4.0_dp * PI * EPSILON_0 ! convert eV to internal units - my_use_ewald_cutoff = optional_default(.true.,use_ewald_cutoff) ! can choose between optimal Ewald - my_smooth_coulomb_cutoff = optional_default(0.0_dp, smooth_coulomb_cutoff) ! default is not to use smooth Coulomb - - a = at_in%lattice(:,1); b = at_in%lattice(:,2); c = at_in%lattice(:,3) - v = cell_volume(at_in) - - h(1) = v / norm(b .cross. c) - h(2) = v / norm(c .cross. a) - h(3) = v / norm(a .cross. b) - - ewald_precision = -log(my_ewald_error) - ewald_cutoff = sqrt(ewald_precision/PI) * reciprocal_time_by_real_time**(1.0_dp/6.0_dp) * & - & minval(sqrt( sum(at_in%lattice(:,:)**2,dim=1) )) / at_in%N**(1.0_dp/6.0_dp) - - call print('Ewald cutoff = '//ewald_cutoff,PRINT_ANALYSIS) - - if( my_use_ewald_cutoff .and. (ewald_cutoff > at_in%cutoff) ) then - my_at = at_in - call set_cutoff(my_at,ewald_cutoff) - call calc_connect(my_at) - at => my_at - else - at => at_in - endif - - if( my_use_ewald_cutoff ) then - my_cutoff = ewald_cutoff - else - my_cutoff = at_in%cutoff - endif - - if( my_cutoff < my_smooth_coulomb_cutoff ) then - RAISE_ERROR('Cutoff='//my_cutoff//' is smaller than the smooth region specified by smooth_coulomb_cutoff='//my_smooth_coulomb_cutoff, error) - endif - - alpha = sqrt(ewald_precision) / my_cutoff - call print('Ewald alpha = '//alpha,PRINT_ANALYSIS) - - kmax = 2.0_dp * ewald_precision / my_cutoff - kmax2 = kmax**2 - call print('Ewald kmax = '//kmax,PRINT_ANALYSIS) - - nmax = nint( kmax * h / 2.0_dp / PI ) - call print('Ewald nmax = '//nmax,PRINT_ANALYSIS) - - two_alpha_over_sqrt_pi = 2.0_dp * alpha / sqrt(PI) - - prefac = 4.0_dp * PI / v - infac = - 1.0_dp / (4.0_dp * alpha**2.0_dp) - - allocate( k_vec(3,-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1)), & - & mod2_k(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1) ), & - & force_factor(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1),3), & - & energy_factor(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1) ) ) - - allocate( coskr(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1),at%N), & - & sinkr(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1),at%N) ) - - k_vec = 0.0_dp - mod2_k = 0.0_dp - force_factor = 0.0_dp - energy_factor = 0.0_dp - - coskr = 0.0_dp - sinkr = 0.0_dp - - not_needed = ( 2*nmax(3) + 1 ) * nmax(2) + nmax(3) + 1 ! lot of symmetries for k and -k so count only - - n = 0 - do n1 = 0, nmax(1) - do n2 = -nmax(2), nmax(2) - do n3 = -nmax(3), nmax(3) - - n = n + 1 - - if( n>not_needed ) then - k_vec(:,n3,n2,n1) = ( at%g(1,:)*n1 + at%g(2,:)*n2 + at%g(3,:)*n3 ) * 2.0_dp * PI - mod2_k(n3,n2,n1) = normsq( k_vec(:,n3,n2,n1) ) - - force_factor(n3,n2,n1,:) = 1.0_dp/mod2_k(n3,n2,n1) * & - & exp(mod2_k(n3,n2,n1)*infac) * k_vec(:,n3,n2,n1) - energy_factor(n3,n2,n1) = 1.0_dp/mod2_k(n3,n2,n1) * exp(infac*mod2_k(n3,n2,n1)) - endif - - enddo - enddo - enddo - - do i = 1, at%N - n = 0 - do n1 = 0, nmax(1) - do n2 = -nmax(2), nmax(2) - do n3 = -nmax(3), nmax(3) - - n = n + 1 - - if( (n>not_needed) .and. ( mod2_k(n3,n2,n1) my_cutoff ) cycle - - if( r_ij < my_smooth_coulomb_cutoff ) then - smooth_arg = r_ij * PI / my_smooth_coulomb_cutoff / 2.0_dp - smooth_f = ( 1.0_dp - sin(smooth_arg) ) / r_ij - dsmooth_f = cos(smooth_arg) * PI / my_smooth_coulomb_cutoff / 2.0_dp - else - smooth_f = 0.0_dp - dsmooth_f = 0.0_dp - endif - - erfc_ar = erfc(r_ij*alpha)/r_ij - - if( present(e) ) e = e + 0.5_dp * charge(i)*charge(j)* ( erfc_ar - smooth_f ) - - if( present(f) .or. present(virial) ) then - force(:) = charge(i)*charge(j) * & - & ( two_alpha_over_sqrt_pi * exp(-(r_ij*alpha)**2) + erfc_ar - smooth_f - dsmooth_f) / r_ij * u_ij(:) - - if(present(f)) then - f(:,i) = f(:,i) - force(:) - endif - - if (present(virial)) virial = virial + 0.5_dp * (force .outer. u_ij) * r_ij - endif - - enddo - enddo - - ! reciprocal energy - if(present(e)) e = e + sum((sum(coskr,dim=4)**2 + sum(sinkr,dim=4)**2)*energy_factor) * prefac & - & - sum(charge**2) * alpha / sqrt(PI) - PI / ( 2.0_dp * alpha**2 * v ) * sum(charge)**2 - - ! reciprocal force - if( present(f) ) then - do i = 1, at%N - do j = 1, at%N - - if( i<=j ) cycle - - force = (/( sum(force_factor(:,:,:,k) * & - & ( sinkr(:,:,:,j)*coskr(:,:,:,i) - sinkr(:,:,:,i)*coskr(:,:,:,j) ) ), k=1,3 )/) * prefac * 2.0_dp - - !force acting on atom j by atom i - f(:,i) = f(:,i) - force(:) - f(:,j) = f(:,j) + force(:) - - enddo - enddo - endif - - ! reciprocal contribution to virial - if(present(virial)) then - n = 0 - do n1 = 0, nmax(1) - do n2 = -nmax(2), nmax(2) - do n3 = -nmax(3), nmax(3) - - n = n + 1 - - if( (n>not_needed) .and. ( mod2_k(n3,n2,n1) null() - - INIT_ERROR(error) - call check_size('charge',charge,(/at_in%N/),'Ewald_corr_calc',error) - - my_cutoff = optional_default(at_in%cutoff,cutoff) - - if( present(cutoff) .and. (my_cutoff > at_in%cutoff) ) then - my_at = at_in - call set_cutoff(my_at,cutoff) - call calc_connect(my_at) - at => my_at - else - at => at_in - endif - - if( present(e) ) e = 0.0_dp - if( present(f) ) f = 0.0_dp - if( present(virial) ) virial = 0.0_dp - - do i = 1, at%N - !Loop over neighbours - do n = 1, n_neighbours(at,i) - j = neighbour(at,i,n,distance=r_ij,cosines=u_ij) ! nth neighbour of atom i - if( r_ij > my_cutoff ) cycle - - de = 0.5_dp * ( cos(r_ij*PI/my_cutoff) + 1.0_dp ) / r_ij - - if( present(e) ) e = e + 0.5_dp * de * charge(i)*charge(j) - - if( present(f) .or. present(virial) ) then - force = charge(i)*charge(j) * & - & ( -de - 0.5*PI*sin(r_ij*PI/my_cutoff)/my_cutoff ) / r_ij * u_ij - - if(present(f)) then - f(:,i) = f(:,i) + force - endif - - if (present(virial)) virial = virial - 0.5_dp * (force .outer. u_ij) * r_ij - endif - - enddo - enddo - - if(present(e)) e = e * HARTREE*BOHR ! convert from internal units to eV - if(present(f)) f = f * HARTREE*BOHR ! convert from internal units to eV/A - if(present(virial)) virial = virial * HARTREE*BOHR - - if(associated(at,my_at)) call finalise(my_at) - at => null() - - endsubroutine Ewald_corr_calc - - subroutine Direct_Coulomb_calc(at_in,charge, e,f,virial,local_e,cutoff,error) - - type(Atoms), intent(in), target :: at_in - real(dp), dimension(:), intent(in) :: charge - - real(dp), intent(out), optional :: e - real(dp), dimension(:,:), intent(out), optional :: f - real(dp), dimension(3,3), intent(out), optional :: virial - real(dp), dimension(:), intent(out), optional :: local_e - real(dp), intent(in), optional :: cutoff - integer, intent(out), optional :: error - - integer :: i, j, n - - real(dp) :: my_cutoff, r_ij, de - real(dp), dimension(3) :: force, u_ij - - real(dp), dimension(:), pointer :: my_charge - - type(Atoms), target :: my_at - type(Atoms), pointer :: at => null() - - INIT_ERROR(error) - call check_size('charge',charge,(/at_in%N/),'Ewald_corr_calc',error) - - my_cutoff = optional_default(at_in%cutoff,cutoff) - - if( present(cutoff) .and. (my_cutoff > at_in%cutoff) ) then - my_at = at_in - call set_cutoff(my_at,cutoff) - call calc_connect(my_at) - at => my_at - else - at => at_in - endif - - if( present(e) ) e = 0.0_dp - if( present(f) ) f = 0.0_dp - if( present(virial) ) virial = 0.0_dp - if( present(local_e) ) local_e = 0.0_dp - - do i = 1, at%N - !Loop over neighbours - do n = 1, n_neighbours(at,i) - j = neighbour(at,i,n,distance=r_ij,cosines=u_ij) ! nth neighbour of atom i - if( r_ij > my_cutoff ) cycle - - de = 0.5_dp * charge(i)*charge(j) / r_ij - - if( present(e) ) e = e + de - if( present(local_e) ) local_e(i) = local_e(i) + de - - if( present(f) .or. present(virial) ) then - force = - de / r_ij * u_ij - - if(present(f)) then - f(:,i) = f(:,i) + force - f(:,j) = f(:,j) - force - endif - - if (present(virial)) virial = virial - (force .outer. u_ij) * r_ij - endif - - enddo - enddo - - if(present(e)) e = e * HARTREE*BOHR ! convert from internal units to eV - if(present(f)) f = f * HARTREE*BOHR ! convert from internal units to eV/A - if(present(virial)) virial = virial * HARTREE*BOHR - - if(associated(at,my_at)) call finalise(my_at) - at => null() - - endsubroutine Direct_Coulomb_calc - - subroutine DSF_Coulomb_calc(at_in,charge, alpha, e, f, virial, local_e, e_potential, e_field, cutoff, error) - - type(Atoms), intent(in), target :: at_in - real(dp), dimension(:), intent(in) :: charge - real(dp), intent(in) :: alpha - - real(dp), intent(out), optional :: e - real(dp), dimension(:,:), intent(out), optional :: f - real(dp), dimension(3,3), intent(out), optional :: virial - real(dp), dimension(:), intent(out), optional :: local_e - real(dp), dimension(:), intent(out), optional :: e_potential - real(dp), dimension(:,:), intent(out), optional :: e_field - real(dp), intent(in), optional :: cutoff - integer, intent(out), optional :: error - - integer :: i, j, n - - real(dp) :: my_cutoff, r_ij, phi_i, e_i, v_ij, dv_ij, v_cutoff, dv_cutoff, two_alpha_over_square_root_pi - - real(dp), dimension(3) :: u_ij, dphi_i, dphi_ij - real(dp), dimension(3,3) :: dphi_ij_outer_r_ij - - type(Atoms), target :: my_at - type(Atoms), pointer :: at => null() - - INIT_ERROR(error) - call check_size('charge',charge,(/at_in%N/),'DSF_Coulomb_calc',error) - - my_cutoff = optional_default(at_in%cutoff,cutoff) - - two_alpha_over_square_root_pi = 2.0_dp * alpha / sqrt(pi) - - v_cutoff = erfc(alpha * my_cutoff) / my_cutoff - dv_cutoff = ( v_cutoff + two_alpha_over_square_root_pi*exp(-(alpha*my_cutoff)**2) ) / my_cutoff - - if( present(cutoff) .and. (my_cutoff > at_in%cutoff) ) then - my_at = at_in - call set_cutoff(my_at,cutoff) - call calc_connect(my_at) - at => my_at - else - at => at_in - endif - - if( present(e) ) e = 0.0_dp - if( present(f) ) f = 0.0_dp - if( present(virial) ) virial = 0.0_dp - if( present(local_e) ) local_e = 0.0_dp - if( present(e_potential) ) e_potential = 0.0_dp - if( present(e_field) ) e_field = 0.0_dp - - do i = 1, at%N - !Loop over neighbours - - phi_i = 0.0_dp - dphi_i = 0.0_dp - dphi_ij_outer_r_ij = 0.0_dp - - - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, max_dist=my_cutoff) ! nth neighbour of atom i - if (j <= 0) cycle - if (r_ij .feq. 0.0_dp) cycle - - v_ij = erfc(alpha*r_ij) / r_ij - phi_i = phi_i + charge(j) * ( v_ij - v_cutoff + dv_cutoff * (r_ij - my_cutoff) ) - - if( present(f) .or. present(virial) .or. present(e_field) ) then - dv_ij = ( v_ij + two_alpha_over_square_root_pi * exp(-(alpha*r_ij)**2) ) / r_ij - dphi_ij = charge(j) * ( dv_ij - dv_cutoff ) * u_ij - dphi_i = dphi_i + dphi_ij - - if(present(virial) ) dphi_ij_outer_r_ij = dphi_ij_outer_r_ij + ( dphi_ij .outer. u_ij ) * r_ij - endif - enddo - - if( present(e) .or. present(local_e) ) then - e_i = 0.5_dp * phi_i * charge(i) - if( present(e) ) e = e + e_i - if( present(local_e) ) local_e(i) = e_i - endif - - if(present(e_potential)) e_potential(i) = phi_i - - if(present(f)) f(:,i) = f(:,i) - dphi_i * charge(i) - - if (present(virial)) virial = virial + 0.5_dp * charge(i) * dphi_ij_outer_r_ij - - if(present(e_field)) e_field(:,i) = dphi_i - enddo - - if(present(e)) e = e * HARTREE*BOHR ! convert from internal units to eV - if(present(local_e)) local_e = local_e * HARTREE*BOHR ! convert from internal units to eV - if(present(f)) f = f * HARTREE*BOHR ! convert from internal units to eV/A - if(present(virial)) virial = virial * HARTREE*BOHR - - if(associated(at,my_at)) call finalise(my_at) - at => null() - - endsubroutine DSF_Coulomb_calc - -endmodule IPEwald_module diff --git a/src/Potentials/IPModel_ASAP.f95 b/src/Potentials/IPModel_ASAP.f95 deleted file mode 100644 index b4beec065a..0000000000 --- a/src/Potentials/IPModel_ASAP.f95 +++ /dev/null @@ -1,1027 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_ASAP -!X -!% Interface to ASAP potential. -!% P. Tangney and S. Scandolo, -!% An ab initio parametrized interatomic force field for silica -!% J. Chem. Phys, 117, 8898 (2002). -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_ASAP_module - -use libAtoms_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -logical, private :: asap_initialised = .false. - -public :: IPModel_ASAP -type IPModel_ASAP - integer :: n_types = 0, n_atoms = 0 - real(dp) :: betapol, tolpol, yukalpha, yuksmoothlength - integer :: maxipol, pred_order - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - real(dp), allocatable, dimension(:) :: pol, z - real(dp), allocatable, dimension(:,:) :: D_ms, gamma_ms, R_ms, B_pol, C_pol - logical :: tewald, tdip_sr - real :: raggio, a_ew, gcut - integer :: iesr(3) - - real(dp) :: cutoff_coulomb, cutoff_ms - - character(len=STRING_LENGTH) :: label - logical :: initialised - -end type IPModel_ASAP - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_ASAP), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_ASAP_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_ASAP_Finalise -end interface Finalise - -interface Print - module procedure IPModel_ASAP_Print -end interface Print - -interface Calc - module procedure IPModel_ASAP_Calc -end interface Calc - -contains - -#ifdef HAVE_ASAP - subroutine asap_singlepoint_finalise() - - use atoms - use verlet - use neighbour - use pot_parameters - use stuff - use energy_i - use print65 - use electric_field - use nndim - use neighbour3 - use fixpar - use distortion, only : taimsp,rmin_aim - use thermal_cond - use shakes - use compress - use quench - use forcetest - use iteration - use changepress - use metric - use netquant - use universal - use initstuff - use plot_efield - use polar - use structopt - use parameters - use presstemp - use testf - use minimiser - implicit none - - deallocate(mass,spind,objind,numobj,numobjsp) - deallocate(nnlist,nnlist2,nnlist3) - deallocate(nnat,nnat2,nnat3,nn_imag) - deallocate(nn_imag2,nn_imag3) - deallocate(s,sm) - deallocate(r,rm) - deallocate(Z,bij,Cij) - deallocate(Dij,alphaij) - deallocate(Eij,Nij) - deallocate(pol,bpol,cpol) - deallocate(theta0jik,bjik) - deallocate(b_tt,r_ms) - deallocate(gamma_ms,d_ms) - deallocate(c_harm,rmin,rmin_aim) - deallocate(adist,bdist,cdist,ddist) - deallocate(bu1,alphau1) - deallocate(sigma1,sigma2,sigma3,sigma4) - deallocate(bu2,alphau2) - deallocate(taimsp,minr,mindistl) - deallocate(elements) - deallocate(aelements) - deallocate(ielements) - deallocate(dt2bym, aumass) - deallocate(parf, tparf) - deallocate(posobj,velobj,dipobj) - deallocate(timposepos,timposevel,timposedip) - deallocate(zerovec,falseimp) - if (allocated(dip_perm)) deallocate(dip_perm) - if (t_therm) deallocate(nzave,ztempave) - - if (allocated(efield_old)) deallocate(efield_old) - if (allocated(efield)) deallocate(efield) - if (allocated(fqdip)) deallocate(fqdip) - if (allocated(fdipdip)) deallocate(fdipdip) - if (allocated(force_ew)) deallocate(force_ew) - if (allocated(efield_ew)) deallocate(efield_ew) - if (allocated(dip)) deallocate(dip) - if (allocated(stress_ew)) deallocate(stress_ew) - if (allocated(dip_sr)) deallocate(dip_sr) - if (allocated(efield_old)) deallocate(efield_old) - if (allocated(force_pol)) deallocate(force_pol) - if (allocated(stress_pol)) deallocate(stress_pol) - if (allocated(testt)) deallocate(testt) - - end subroutine asap_singlepoint_finalise - -#endif - - -subroutine IPModel_ASAP_Initialise_str(this, args_str, param_str) - use system_module, only : dp - type(IPModel_ASAP), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - this%initialised = .false. - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_ASAP_Initialise_str args_str')) then - call system_abort("IPModel_ASAP_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_ASAP_read_params_xml(this, param_str) - this%n_atoms = 0 - this%initialised = .true. - -end subroutine IPModel_ASAP_Initialise_str - -subroutine IPModel_ASAP_Finalise(this) - use system_module, only : dp - type(IPModel_ASAP), intent(inout) :: this - -#ifdef HAVE_ASAP - if (asap_initialised) then - call asap_singlepoint_finalise() - asap_initialised = .false. - end if - this%initialised = .false. -#else - call system_abort('ASAP potential is not compiled in. Recompile with HAVE_ASAP=1') -#endif - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%pol)) deallocate(this%pol) - if (allocated(this%z)) deallocate(this%z) - if (allocated(this%D_ms)) deallocate(this%D_ms) - if (allocated(this%gamma_ms)) deallocate(this%gamma_ms) - if (allocated(this%R_ms)) deallocate(this%R_ms) - if (allocated(this%B_pol)) deallocate(this%B_pol) - if (allocated(this%C_pol)) deallocate(this%C_pol) - this%n_types = 0 - this%label = '' -end subroutine IPModel_ASAP_Finalise - - -subroutine IPModel_ASAP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) -#ifdef HAVE_ASAP - use neighbour!, only : nsp,nat,iesr,spind,rcut - use neighbour3 - use pot_parameters - use logical_stuff - use polar - use stuff - use distortion, only : xgmin,xgmax,taimsp - use parameters - use testf - use initstuff - use atoms - use verlet - use iteration - use nndim - use metric - use fixpar, only: ntype, tpbc, treadpar - use energy_i - use print65 - use electric_field - use nndim - use distortion, only : taimsp,rmin_aim - use thermal_cond - use shakes - use compress - use quench - use forcetest - use iteration - use changepress - use metric - use netquant - use universal, only: au_to_kbar, small - use initstuff - use plot_efield - use polar - use structopt - use parameters - use presstemp - use testf - use minimiser - -#endif - use libAtoms_module, only : myAtoms => Atoms, Dictionary, BOHR, HARTREE, & - ElementMass, massconvert, initialise, param_read_line, finalise, & - ElementName, print, operator(//), cell_volume, has_property, & - assign_pointer, add_property, system_abort, fit_box_in_cell, & - param_register, check_size, operator(.fne.), assign_property_pointer - - type(IPModel_ASAP), intent(inout):: this - type(myAtoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional, intent(in) :: args_str - type(MPI_Context), intent(in), optional :: mpi - - integer, intent(out), optional :: error - type(Dictionary) :: params - real(dp) :: asap_e, asap_stress(3,3), a_ew, f_ew - logical smlra,smlrc,smlgc,smlrc2,smlrc3,smlrc4 - logical nsmlra,nsmlrc,nsmlgc - real*8 rarec,gcrec,rcrec,root2 - real*8 raggio_in,rcut_in,gcut_in - real(dp), allocatable :: asap_f(:,:) - real(dp), pointer :: dipoles_ptr(:,:), ext_efield_ptr(:,:) - integer :: i, ti, tj - logical :: do_restart, calc_dipoles - integer at0, atf - integer idebug - real(dp) dtold,dtnew - logical tzeroc - logical sumewald - real(dp) mass_cel - logical tscaled - logical readnat - logical texist - logical tpow,tgmin - integer nesr - - logical :: has_atom_mask_name, applied_efield - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - -#ifdef HAVE_ASAP - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_ASAP_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_ASAP_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_ASAP_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_ASAP_Calc: local_virial calculation requested but not supported yet.", error) - endif - - allocate(asap_f(3,at%N)) - - call initialise(params) - this%label='' - call param_register(params, 'restart', 'F', do_restart, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'calc_dipoles', 'T', calc_dipoles, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - call param_register(params, 'applied_efield', 'F', applied_efield, help_string="No help yet. This source file was $LastChangedBy$") - - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_ASAP_Calc args_str')) then - call system_abort("IPModel_ASAP_Initialise_str failed to parse args_str="//trim(args_str)) - endif - call finalise(params) - - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_ASAP_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_ASAP_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - if (.not. asap_initialised .or. this%n_atoms /= at%n) then - - if (asap_initialised) then - call asap_singlepoint_finalise() - asap_initialised = .false. - end if - - this%n_atoms = at%n - - idebug = 0 - nat = this%n_atoms - nsp = this%n_types - at0 = 1 - atf = nat - nobj = 1 - - nthermo = min(atf-at0+1,nat-1) - allocate(mass(this%n_types)) - - tsinglepoint = .true. - tangstrom = .false. - irestart = -1 - itsave = 0 - readunit = 90 - saveunit = 90 - readnat = .false. - dtold = 0.0d0 - dtnew = 0.0d0 - ntstep = 0 - iprint = 0 - iprintxyz = 0 - deltat = dtnew - tcenter = .false. - timposepbc = .false. - tremovetrans = .false. - treadxyz = .false. - tfirst_xyzprint = .true. - treadpar = .false. - tappendfiles = .false. - tstructopt = .false. - tsdp = .false. - tpbc = .true. - tpow = .false. - tgmin = .false. - testewald = .false. - ttime = .true. - tforcetest = .false. - tscaled = .false. - tangstrom = .false. - texist = .false. - tprint65 = .false. - tenergy_i = .false. - tbin65 = .false. - iprint65 = 1 - tzeroc = .false. - tcel = .false. - tsdc = .false. - cell_dir = 3 - press = 0.0d0 - mass_cel = 2.0d6 - press = press / au_to_kbar - wc = mass_cel - trescale = .false. - tnosep = .false. - tboltz = .false. - tshake = .false. - tcompress = .false. - tquench = .false. - tchangeP= .false. - tpolwrite = .false. - t_therm = .false. - tshowforce = .false. - tplot_efield = .false. - tfirst_efield_plot = .true. - tewald = .false. - write_sr = .false. - read_sr= .false. - calc_sr=.false. - calc_pol = .false. - write_pol=.false. - read_pol=.false. - calc_gvec=.false. - write_gvec=.false. - read_gvec=.false. - write_aim = .false. - read_aim= .false. - calc_aim=.false. - tzvar=.false. - tpolvar=.false. - tsrvar=.false. - tpol=.false. - tsr=.false. - taim = .false. - tz=.false. - hafta=.false. - tbegin = .true. - tyukawa = .true. - - sumewald = .true. - allocate(spind(nat),objind(nat),numobj(nobj),numobjsp(nobj,nsp)) - allocate(z(nsp),bij(nsp,nsp),Cij(nsp,nsp)) - allocate(Dij(nsp,nsp),alphaij(nsp,nsp)) - allocate(Eij(nsp,nsp),Nij(nsp,nsp)) - allocate(pol(nsp),bpol(nsp,nsp),cpol(nsp,nsp)) - allocate(theta0jik(nsp,nsp,nsp),bjik(nsp,nsp,nsp)) - allocate(b_tt(3,nsp,nsp),r_ms(nsp,nsp)) - allocate(gamma_ms(nsp,nsp),d_ms(nsp,nsp)) - allocate(c_harm(nsp,nsp),rmin(nsp,nsp)) - allocate(rmin_aim(nsp,nsp)) - rmin_aim = 0.d0 - allocate(adist(nsp,nsp),bdist(nsp,nsp)) - allocate(cdist(nsp),ddist(nsp,nsp)) - allocate(bu1(nsp,nsp),alphau1(nsp,nsp)) - allocate(sigma1(nsp),sigma2(nsp),sigma3(nsp),sigma4(nsp)) - allocate(bu2(nsp,nsp),alphau2(nsp,nsp)) - allocate(taimsp(nsp)) - allocate(minr(nsp,nsp),mindistl(nsp,nsp)) - mindistl = 0.d0 - - allocate(s(3,nat),sm(3,nat)) - allocate(r(3,nat),rm(3,nat)) - allocate(dt2bym(nat),aumass(nat)) - allocate(elements(nsp)) - allocate(aelements(nat)) - allocate(ielements(nat)) - nparm = (nsp*nsp*nsp+21*nsp*nsp+28*nsp)/2 + 4*nsp - allocate (parf(nparm),tparf(nparm)) - tgen = .false. - testforce = .false. - npar = 1 - - ntnlist = (/1,1/) - nnatmax = 100000 - nnatmax_sr = 30000 - allocate(posobj(3,nobj),velobj(3,nobj),dipobj(3,nobj)) - allocate(timposepos(nobj),timposevel(nobj),timposedip(nobj)) - allocate(zerovec(3,nobj),falseimp(nobj)) - zerovec = 0.0d0! - - falseimp = .false. - XNOS2M = 0.D0 - XNOSM = 0.D0 - XNOS0 = 0.D0 - VRNOS = 0.D0 - - it = 1 - - c_harm = 0.0_dp - rmin = 0.0_dp - - ! Per type parameters - do ti=1,this%n_types - mass(ti) = ElementMass(this%atomic_num(ti))/MASSCONVERT - elements(ti) = ElementName(this%atomic_num(ti)) - z(ti) = this%z(ti) - pol(ti) = this%pol(ti) - ntype(ti) = count(at%Z == this%atomic_num(ti)) - end do - - write(6,'(/," Nos of each species:",10i6)') (ntype(i),i=1,nsp) - write(6,'(/," Masses :",2(1x,f10.5))') mass - - ! Ewald parameters - tewald = this%tewald - raggio = this%raggio - a_ew = this%a_ew - gcut = this%gcut - rcut(1) = this%cutoff_coulomb - rcut(3) = this%cutoff_ms - iesr = this%iesr - - call print('tewald :'//tewald) - write(6,'(/," Raggio :",1x,f10.5)') raggio - write(6,'(" A_ew :",1x,e10.5)') a_ew - write(6,'(" iesr :",3i3)') iesr - write(6,'(" Gcut :",1x,f10.5,/)') gcut - - smlgc = gcut.lt.small - smlrc = rcut(1).lt.small - smlra = raggio.lt.small - smlrc2 = rcut(2).lt.small - smlrc3 = rcut(3).lt.small - smlrc4 = rcut(4).lt.small - - nsmlgc = .not.smlgc ! iesr will be computed later from rcut and cell - - nsmlrc = .not.smlrc - nsmlra = .not.smlra - - f_ew = dsqrt(-1.0d0*log(a_ew)) - root2 = dsqrt(2.0d0) - - rarec = 0.0d0 - rcrec = 0.0d0 - gcrec = 0.0d0 - - raggio_in = raggio - gcut_in = gcut - rcut_in = rcut(1) - - if (smlrc.and.smlgc.and.smlra) then - rarec = 3.0d0 - gcrec = f_ew*root2/rarec - rcrec = gcut*rarec*rarec - else if (nsmlrc.and.smlgc.and.smlra) then - rarec = rcut(1)/f_ew/root2 - gcrec = f_ew*root2/rarec - raggio = rarec - gcut = gcrec - else if (smlrc.and.nsmlgc.and.smlra) then - rarec = f_ew*root2/gcut - rcrec = gcut*rarec*rarec - raggio = rarec - rcut(1) = rcrec - else if (smlrc.and.smlgc.and.nsmlra) then - gcrec = f_ew*dsqrt(2.0d0)/raggio - rcrec = gcrec*raggio*raggio - gcut = gcrec - rcut(1) = rcrec - else if (nsmlrc.and.nsmlgc.and.smlra) then - rarec = rcut(1)/f_ew/root2 - gcrec = f_ew*root2/raggio - raggio = rarec - else if (nsmlrc.and.smlgc.and.nsmlra) then - rarec = rcut(1)/f_ew/root2 - gcrec = f_ew*root2/raggio - gcut = gcrec - else if (smlrc.and.nsmlgc.and.nsmlra) then - gcrec = f_ew*root2/raggio - rcrec = gcrec*raggio*raggio - rcut(1) = rcrec - else if (nsmlrc.and.nsmlgc.and.nsmlra) then - write(6,*) 'raggio, rcut, gcut, are all defined!!' - endif - - if (smlrc2) rcut(2) = rcut(1) - if (smlrc3) rcut(3) = rcut(1) - if (smlrc4) rcut(4) = rcut(1) - - write(6,'(/," Input Raggio : ",f10.5)')raggio_in - write(6,'(" Input r-space cutoff : ",f10.5)')rcut_in - write(6,'(" Input g-space cutoff : ",f10.5)')gcut_in - write(6,'(/," Recommended Raggio : ",f10.5)')rarec - write(6,'(" Recommended r-space cutoff : ",f10.5)')rcrec - write(6,'(" Recommended g-space cutoff : ",f10.5)')gcrec - write(6,'(/," Using Raggio : ",f10.5)')raggio - write(6,'(" Using r-space cutoff : ",f10.5)')rcut(1) - write(6,'(" Using g-space cutoff : ",f10.5)')gcut - write(6,'(/," Secondary r-space cutoff : ",f10.5)')rcut(2) - write(6,'(" Tertiary r-space cutoff : ",f10.5)')rcut(3) - write(6,'(" Quaternary r-space cutoff : ",f10.5)')rcut(4) - - netcharge = 0.0d0 - do i=1,this%n_types - netcharge = netcharge + z(i)*dfloat(ntype(i)) - if (dabs(z(i)).gt.1.d-10) tz = .true. - end do - - write(6,'(/," Charges : ",100(e13.5))') z - write(6,'(/," Net charge ",e13.5)') netcharge - write(6,*) - - ! Short range parameters - tsr = .true. - alphaij = 0.0_dp - bij = 0.0_dp - cij = 0.0_dp - dij = 0.0_dp - eij = 0.0_dp - nij = 0.0_dp - b_tt = 0.0_dp - gamma_ms = 0.d0 - r_ms = 0.0d0 - d_ms= 0.0d0 - do ti=1,this%n_types - do tj=1,this%n_types - d_ms(ti,tj) = this%d_ms(ti,tj) - gamma_ms(ti,tj) = this%gamma_ms(ti,tj) - R_ms(ti,tj) = this%R_ms(ti,tj) - end do - end do - - ! Polarisation - betapol = this%betapol - maxipol = this%maxipol - tolpol = this%tolpol - pred_order = this%pred_order - - tpol = any(dabs(pol) > 1.0e-6_dp) - tpolvar = tpol - call Print('tpol = '//tpol) - call Print('tpolvar = '//tpolvar) - call Print('Polarisation: '//pol) - - bpol = 0.0_dp - cpol = 0.0_dp - do ti=1,this%n_types - do tj=1,this%n_types - bpol(ti,tj) = this%B_pol(ti,tj) - cpol(ti,tj) = this%C_pol(ti, tj) - end do - end do - - ! Smoothing - smooth = .false. - - ! Yukawa parameters - yukalpha = this%yukalpha - yuksmoothlength = this%yuksmoothlength - tdip_sr = this%tdip_sr - - asap_initialised = .true. - end if - - spind = 0 - do i=1,this%n_types - where(at%Z == this%atomic_num(i)) spind = i - end do - - ! ASAP uses atomic units - lengths are in Bohr, energies in Hartree, - ! forces in Hartree/Bohr and stress in Hartree/Bohr**3 - - r(:,:) = at%pos(:,:)/BOHR ! positions - rm(:,:) = at%pos(:,:)/BOHR - htm = transpose(at%lattice/BOHR) ! lattice - ht = transpose(at%lattice/BOHR) - restart = do_restart ! reset electric field - - if (applied_efield) then - call assign_property_pointer(at, 'ext_efield', ext_efield_ptr, error) - PASS_ERROR(error) - - ! check electric field is constant - if (maxval(abs(sum(ext_efield_ptr,2)/real(size(ext_efield_ptr,2),dp) - ext_efield_ptr(:,1))) > 1.0e-6_dp) then - RAISE_ERROR('IPModel_ASAP_calc: external efield must be constant (same for all atoms)', error) - end if - - telectric = .true. - tfieldion = .true. - e_applied = ext_efield_ptr(:,1)/(HARTREE/BOHR) ! external applied electric field - else - telectric = .false. - tfieldion = .false. - e_applied(:) = 0.0_dp - end if - - objind = 1 - numobj(1) = nat - ntype = 1 - numobjsp = 0 - do i=1,nat - ntype(spind(i)) = ntype(spind(i)) + 1 - numobjsp(1,spind(i)) = numobjsp(1,spind(i)) + 1 - end do - - call inv3(ht,htm1,omega) - - if (all(iesr == -1)) then - ! given rcut(1) and lattice, compute iesr - call fit_box_in_cell(rcut(1),rcut(1),rcut(1), at%lattice, iesr(1), iesr(2), iesr(3)) - iesr = iesr/2 - end if - - nesr = (2*iesr(1)+1)*(2*iesr(2)+1)*(2*iesr(3)+1) - nnatmax = min(nnatmax,nat*nesr) - nnatmax = nnatmax + 10 - - if (allocated(nnat)) deallocate(nnat) - if (allocated(nnat2)) deallocate(nnat2) - if (allocated(nnat3)) deallocate(nnat3) - if (allocated(nnlist)) deallocate(nnlist) - if (allocated(nnlist2)) deallocate(nnlist2) - if (allocated(nnlist3)) deallocate(nnlist3) - if (allocated(nn_imag)) deallocate(nn_imag) - if (allocated(nn_imag2)) deallocate(nn_imag2) - if (allocated(nn_imag3)) deallocate(nn_imag3) - - call label_elements - call init - call prepare_traj - - if((mod(it,ntnlist(1)).eq.1).or.(ntnlist(1).eq.1)) then - call nbrlist(r,nnatmax) - call nbrlist3(r) - endif - - if(mod(it,ntnlist(2)).eq.1) then - call nbrlist3(r) - endif - - call force_ft(asap_e, asap_f, asap_stress, 0) - it = it + 1 - - ! Convert to {eV, A, fs} units - if (present(e)) e = asap_e*HARTREE - if (present(f)) f = asap_f*(HARTREE/BOHR) - if (present(virial)) virial = asap_stress*(HARTREE/(BOHR**3))*cell_volume(at) - if (present(local_e)) local_e = 0.0_dp - - if (calc_dipoles .and. tpol) then - if (.not. has_property(at, 'dipoles')) call add_property(at, 'dipoles', 0.0_dp, n_cols=3) - call assign_property_pointer(at, 'dipoles', dipoles_ptr, error) - PASS_ERROR(error) - dipoles_ptr = dip*BOHR - end if - - deallocate(asap_f) -#else - RAISE_ERROR('ASAP potential is not compiled in. Recompile with HAVE_ASAP=1', error) -#endif - -end subroutine IPModel_ASAP_Calc - - -subroutine IPModel_ASAP_Print(this, file) - use system_module, only : dp - type(IPModel_ASAP), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_ASAP : ASAP Potential", file=file) - call Print("IPModel_ASAP : n_types = " // this%n_types //" n_atoms = "//this%n_atoms, file=file) - call Print("IPModel_ASAP : betapol = "//this%betapol//" maxipol = "//this%maxipol//" tolpol = "//this%tolpol//" pred_order = "//this%pred_order, file=file) - call Print("IPModel_ASAP : yukalpha = "//this%yukalpha//" yuksmoothlength = "//this%yuksmoothlength, file=file) - call Print("IPModel_ASAP : cutoff_coulomb = "//this%cutoff_coulomb//" cutoff_ms = "//this%cutoff_ms, file=file) - - do ti=1, this%n_types - call Print ("IPModel_ASAP : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call Print ("IPModel_ASAP : pol = "//this%pol(ti), file=file) - call Print ("IPModel_ASAP : z = "//this%z(ti), file=file) - call verbosity_push_decrement() - do tj =1,this%n_types - call Print ("IPModel_ASAP : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) //& - " " // this%atomic_num(tj), file=file) - call Print ("IPModel_ASAP : pair " // this%D_ms(ti,tj) // " " // this%gamma_ms(ti,tj) // " " & - // this%R_ms(ti,tj) // " " // this%B_pol(ti,tj) // " " // this%C_pol(ti, tj), file=file) - end do - call verbosity_pop() - end do - -end subroutine IPModel_ASAP_Print - -subroutine IPModel_ASAP_read_params_xml(this, param_str) - use system_module, only : dp - type(IPModel_ASAP), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_ASAP_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_ASAP_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - use system_module, only : dp - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: val - - integer ti, tj, Zi, Zj - - if (name == 'TS_params') then ! new ASAP stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call Quip_fox_get_value(attributes, 'label', val, status) - if (status /= 0) val = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (val == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call Quip_fox_get_value(attributes, 'n_types', val, status) - if (status == 0) then - read (val, *), parse_ip%n_types - else - call system_abort("Can't find n_types in TS_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - allocate(parse_ip%pol(parse_ip%n_types)) - parse_ip%pol = 0.0_dp - allocate(parse_ip%z(parse_ip%n_types)) - - allocate(parse_ip%D_ms(parse_ip%n_types,parse_ip%n_types)) - parse_ip%D_ms = 0.0_dp - allocate(parse_ip%gamma_ms(parse_ip%n_types,parse_ip%n_types)) - parse_ip%gamma_ms = 0.0_dp - allocate(parse_ip%R_ms(parse_ip%n_types,parse_ip%n_types)) - parse_ip%R_ms = 0.0_dp - allocate(parse_ip%B_pol(parse_ip%n_types,parse_ip%n_types)) - parse_ip%B_pol = 0.0_dp - allocate(parse_ip%C_pol(parse_ip%n_types,parse_ip%n_types)) - parse_ip%C_pol = 0.0_dp - - call QUIP_FoX_get_value(attributes, "cutoff_coulomb", val, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find cutoff_coulomb") - read (val, *) parse_ip%cutoff_coulomb - - call QUIP_FoX_get_value(attributes, "cutoff_ms", val, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find cutoff_ms") - read (val, *) parse_ip%cutoff_ms - - call Quip_fox_get_value(attributes, "betapol", val, status) - if (status == 0) read (val, *) parse_ip%betapol - - call Quip_fox_get_value(attributes, "maxipol", val, status) - if (status == 0) read (val, *) parse_ip%maxipol - - call Quip_fox_get_value(attributes, "tolpol", val, status) - if (status == 0) read (val, *) parse_ip%tolpol - - call Quip_fox_get_value(attributes, "pred_order", val, status) - if (status == 0) read (val, *) parse_ip%pred_order - - call Quip_fox_get_value(attributes, "yukalpha", val, status) - if (status == 0) read (val, *) parse_ip%yukalpha - - call Quip_fox_get_value(attributes, "yuksmoothlength", val, status) - if (status == 0) read (val, *) parse_ip%yuksmoothlength - - parse_ip%tewald = .false. - call Quip_fox_get_value(attributes, "tewald", val, status) - if (status == 0) read (val, *), parse_ip%tewald - - parse_ip%tdip_sr = .true. - call Quip_fox_get_value(attributes, "tdip_sr", val, status) - if (status == 0) read (val, *), parse_ip%tdip_sr - - parse_ip%raggio = 0.0_dp - call Quip_fox_get_value(attributes, "raggio", val, status) - if (status == 0) read (val, *), parse_ip%raggio - - parse_ip%a_ew = 0.0_dp - call Quip_fox_get_value(attributes, "a_ew", val, status) - if (status == 0) read (val, *), parse_ip%a_ew - - parse_ip%gcut = 0.0_dp - call Quip_fox_get_value(attributes, "gcut", val, status) - if (status == 0) read (val, *), parse_ip%gcut - - parse_ip%iesr = 0 - call Quip_fox_get_value(attributes, "iesr", val, status) - if (status == 0) read (val, *), parse_ip%iesr - - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call Quip_fox_get_value(attributes, "type", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find type") - read (val, *) ti - - call Quip_fox_get_value(attributes, "atomic_num", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find atomic_num") - read (val, *) parse_ip%atomic_num(ti) - - call Quip_fox_get_value(attributes, "pol", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find pol") - read (val, *) parse_ip%pol(ti) - - call Quip_fox_get_value(attributes, "z", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find z") - read (val, *) parse_ip%z(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call Quip_fox_get_value(attributes, "atnum_i", val, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_i") - read (val, *) Zi - call Quip_fox_get_value(attributes, "atnum_j", val, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_j") - read (val, *) Zj - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - - call Quip_fox_get_value(attributes, "D_ms", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find D_ms") - read (val, *) parse_ip%D_ms(ti,tj) - call Quip_fox_get_value(attributes, "gamma_ms", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find gamma_ms") - read (val, *) parse_ip%gamma_ms(ti,tj) - call Quip_fox_get_value(attributes, "R_ms", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find R_ms") - read (val, *) parse_ip%R_ms(ti,tj) - call Quip_fox_get_value(attributes, "B_pol", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find B_pol") - read (val, *) parse_ip%B_pol(ti,tj) - call Quip_fox_get_value(attributes, "C_pol", val, status) - if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find C_pol") - read (val, *) parse_ip%C_pol(ti,tj) - - if (ti /= tj) then - parse_ip%D_ms(tj,ti) = parse_ip%D_ms(ti,tj) - parse_ip%gamma_ms(tj,ti) = parse_ip%gamma_ms(ti,tj) - parse_ip%R_ms(tj,ti) = parse_ip%R_ms(ti,tj) - parse_ip%B_pol(tj,ti) = parse_ip%B_pol(ti,tj) - parse_ip%C_pol(tj,ti) = parse_ip%C_pol(ti,tj) - endif - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - use system_module, only : dp - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'TS_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_ASAP_module diff --git a/src/Potentials/IPModel_BOP.f95 b/src/Potentials/IPModel_BOP.f95 deleted file mode 100644 index 1e0100bf08..0000000000 --- a/src/Potentials/IPModel_BOP.f95 +++ /dev/null @@ -1,800 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_BOP module -!X -!% Module for Bond-Order potential -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_BOP_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_VERBOSE, PRINT_NERD, current_verbosity, initialise, OUTPUT, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use table_module -use atoms_types_module -use connection_module -use atoms_module -use clusters_module -use structures_module -use cinoutput_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_BOP -type IPModel_BOP - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - - integer :: n - type(Atoms) :: at - integer, allocatable, dimension(:) :: aptr - integer, allocatable, dimension(:) :: bptr - integer :: bptr_num - - character(len=STRING_LENGTH) :: label - -end type IPModel_BOP - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_BOP), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_BOP_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_BOP_Finalise -end interface Finalise - -interface Print - module procedure IPModel_BOP_Print, IPModel_BOP_Print_ptr -end interface Print - -interface Calc - module procedure IPModel_BOP_Calc -end interface Calc - -contains - -subroutine IPModel_BOP_Initialise_str(this, args_str, param_str) - type(IPModel_BOP), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BOP_Initialise_str args_str')) then - call system_abort("IPModel_BOP_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_BOP_read_params_xml(this, param_str) - -end subroutine IPModel_BOP_Initialise_str - -subroutine IPModel_BOP_Finalise(this) - type(IPModel_BOP), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_BOP_Finalise - - -! nat is the number of atoms whose energy and forces have to be computed with bop library -subroutine IPModel_BOP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_BOP), intent(inout):: this - type(Atoms), intent(inout) :: at !Active + buffer atoms - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), allocatable, dimension(:,:) :: f_bop -! real(dp), allocatable, dimension(:) :: local_e_bop - integer, allocatable, dimension(:) :: map_tobop - type(Atoms) :: at_bop !Active + buffer atoms - type(Atoms) :: at_tmp - real(dp) :: e_bop - integer :: nat !Number of active atoms, the first nat of at - type(Dictionary) :: params - integer :: i, nreplicate_x, nreplicate_y, nreplicate_z - logical :: lpbc, lreplicate_cell, lprint_xyz, lcrack,latoms - integer, pointer, dimension(:) :: map,map_bop, active, original_cell, hybrid - real(dp), pointer, dimension(:,:):: forces_bop -! real(dp), pointer, dimension(:) :: local_energy - integer :: nsafe, natoms_active - - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_BOP_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_BOP_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_BOP_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_BOP_Calc: local_virial calculation requested but not supported yet.", error) - endif - - lpbc = .false. - if (present(args_str)) then - call initialise(params) - call param_register(params, 'nat', '0', nat, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'pbc', '.false.', lpbc, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'replicate_x', '1', nreplicate_x, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'replicate_y', '1', nreplicate_y, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'replicate_z', '1', nreplicate_z, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'print_xyz', 'F', lprint_xyz, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'crack', 'F', lcrack, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'all_atoms', 'F', latoms, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BOP_Calc args_str')) then - call system_abort("IPModel_BOP_Calc failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_BOP_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_BOP_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - else - nat = 1 - endif - - - if(latoms.and.lcrack) call system_abort('IPModel_BOP: all_atoms ' // latoms// " and crack " // lcrack) - - if(nat.eq.0) then - if(lcrack) then - if (.not. assign_pointer(at, 'hybrid', hybrid)) & - call system_abort('IPModel_BOP: atoms structure is missing hybrid property') - natoms_active = count(hybrid/=0) - this%n = at%N - elseif(latoms) then - this%n = at%N - else - this%n = 1 - endif - else - this%n = nat - endif - - lreplicate_cell = .false. - if(nreplicate_x.ne.1.or.nreplicate_y.ne.1.or.nreplicate_z.ne.1) then - lreplicate_cell = .true. - endif - - if(lreplicate_cell.and.lpbc) then - call system_abort("IPModel_BOP_Calc: or PBC or replicates the unit cell") - endif - - at_tmp = at - call add_property(at_tmp, 'map', 0) - if (.not. assign_pointer(at_tmp, 'map', map)) & - call system_abort('active pointer assignment failed') - do i=1,at_tmp%N - map(i) = i - enddo - - if(lreplicate_cell) then - nsafe = 1 - call print("Replicate cell : "//nreplicate_x//" "// nreplicate_y //" "// nreplicate_z, PRINT_NERD) -! call supercell_minus_plus(at_bop, at_tmp, nreplicate_x, nsafe, nsafe) -! call supercell_minus_plus(at_tmp, at_bop, nsafe, nreplicate_y, nsafe) -! call supercell_minus_plus(at_bop, at_tmp, nsafe, nsafe,nreplicate_z) - call supercell(at_bop, at_tmp, nreplicate_x, nsafe, nsafe) - call supercell(at_tmp, at_bop, nsafe, nreplicate_y, nsafe) - call supercell(at_bop, at_tmp, nsafe, nsafe,nreplicate_z) - elseif(lpbc) then - call print ("Periodic boundary condition applied", PRINT_NERD) - call IPModel_BOP_compute_buffer(this,at,at_bop) - at_bop = at_tmp - else ! no pbc - at_bop = at_tmp - endif -! Assign map property for computing forces with BOP library - if (.not. has_property(at_bop, 'map')) & - call system_abort('IPModel_BOP: atoms structure has no "map" property') - if (.not. assign_pointer(at_bop, 'map', map_bop)) & - call system_abort('IPModel_BOP passed atoms structure with no map property') - allocate(map_tobop(at_bop%N)) - map_tobop = map_bop - -! A vacuum region surrounding the cluster has to be applied before computing the connecting - at_bop%lattice = at_bop%lattice * 3.0_dp -! Cutoff set to the potential value in order to reduce the number of neighbours for the BOP library - call set_cutoff(at_bop, this%cutoff) -! Recompute connectivity - call print('IPModel_BOP : cutoff used for connectivity' // at_bop%cutoff, PRINT_NERD) - call set_lattice(at_bop,at_bop%lattice,scale_positions=.false., remap=.true.,reconnect=.true.) - -! Atoms to be passed to the Bop library - this%at = at_bop - - if(this%n.gt.this%at%N) then - call system_abort("IPModel_BOP_Calc: number of atoms for BOP library "// this%n // " > at%N = " // this%at%N) - endif - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - local_e = 0.0_dp - if(size(local_e).gt.this%at%N) then - call system_abort("IPModel_BOP_Calc: reallocate local_e to the right value = (" // this%n // ") !") - endif - endif - if (present(f)) then - f = 0.0_dp - if(size(f,2).gt.this%at%N) then - call system_abort("IPModel_BOP_Calc: reallocate f to the right value = (3," // this%n // ") !") - endif - endif - if (present(virial)) virial = 0.0_dp - -! Compute the two pointer vectors required by the BOP library for the at_bop object - call print('Computing pointers for BOP library', PRINT_NERD) - call IPModel_BOP_Calc_ptr(this) - - if(allocated(f_bop)) deallocate(f_bop) - allocate(f_bop(3,this%n)) -! if(allocated(local_e_bop)) deallocate(local_e_bop) -! allocate(local_e_bop(this%n)) - f_bop = 0.0_dp - e_bop = 0.0_dp - -! Compute forces and energy with BOP library -#ifdef HAVE_BOP - call print('Calling BOP library : active atoms='// this%n// " on "//this%at%N ) - call system_timer('BOP') - call bop(this%n,this%at%N,this%at%pos,this%aptr,this%bptr_num,this%bptr,map_tobop,e_bop,f_bop) - call system_timer('BOP') - call print('BOP energy : ' // e_bop) -#else - call print('No BOP library!!!') -#endif - -! Print properties if print_xyz=T is passed in args_str - if(lprint_xyz) then - call add_property(at_bop, 'active', 0) - if (.not. assign_pointer(at_bop, 'active', active)) & - call system_abort('active pointer assignment failed') - active(1:this%n) = 1 - call add_property(at_bop, 'original_cell', 0) - if (.not. assign_pointer(at_bop, 'original_cell', original_cell)) & - call system_abort('original_cell pointer assignment failed') - original_cell(1:at%n) = 1 - call add_property(at_bop, 'forces_bop', 0.0_dp, n_cols=3) - if (.not. assign_pointer(at_bop, 'forces_bop', forces_bop)) & - call system_abort('forces_bop: failed to assign pointer to forces_bop') - forces_bop(:,1:this%n) = f_bop(:,1:this%n) -! call add_property(at_bop, 'local_energy', 0.0_dp) -! if (.not. assign_pointer(at_bop, 'local_energy', local_energy)) & -! call system_abort('local_energy: failed to assign pointer to local_bop') -! local_energy(1:this%n) = local_e_bop(1:this%n) - call write(at_bop, "bop_cell.xyz", properties='active:original_cell:map:forces_bop') - endif - - if(present(f)) then -! if (present(mpi)) call sum_in_place(mpi, f_bop) - if(lcrack) then - f(:,1:natoms_active) = f_bop(:,1:natoms_active) - else - f(:,1:this%n) = f_bop(:,1:this%n) - endif - endif - if(present(e)) e = e_bop -! if (present(mpi) .and. present(e)) e = sum(mpi, e_bop) - call print('Energy computed with BOP library : ' // e_bop // " eV ",PRINT_NERD) - if (present(mpi)) then - if (present(local_e)) call sum_in_place(mpi, local_e) - endif - if(current_verbosity() >= PRINT_NERD) then - do i =1, this%n - call print('Forces computed with BOP library on atom ' // i // " : " // f_bop(1,i) // " "// f_bop(2,i) // " " // f_bop(3,i) ) - enddo - endif - - call finalise(at_bop) - call finalise(at_tmp) - -end subroutine IPModel_BOP_Calc - -! compute aptr and bptr vectors required by the BOP library. -subroutine IPModel_BOP_Calc_ptr(this) - type(IPModel_BOP), intent(inout) :: this - integer :: nn, iat - integer :: ik, k, itemp - real(dp) :: rik - - if(allocated(this%aptr)) deallocate(this%aptr) - allocate(this%aptr(this%at%N)) - if(allocated(this%bptr)) deallocate(this%bptr) - nn = 0 - do iat = 1, this%at%N - nn = nn + n_neighbours(this%at, iat) + 2 - enddo - nn = nn + 1 - this%bptr_num = nn - allocate(this%bptr(this%bptr_num)) - - itemp = -1000000 - nn = 0 - do iat = 1, this%at%N - nn = nn + 1 - this%bptr(nn) = iat - this%aptr(iat) = nn - if(nn.ge.this%bptr_num) then - call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num") - endif - do ik = 1, n_neighbours(this%at, iat) - nn = nn + 1 - k = neighbour(this%at, iat, ik, rik) - this%bptr(nn) = k - if(nn.ge.this%bptr_num) then - call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num") - endif - enddo - nn = nn + 1 - this%bptr(nn) = itemp - if(nn.ge.this%bptr_num) then - call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num") - endif - enddo - this%bptr(this%bptr_num) = 0 - if(current_verbosity() >= PRINT_VERBOSE) then - call print(this,this%aptr,this%bptr) - endif - -end subroutine IPModel_BOP_Calc_ptr - -subroutine IPModel_BOP_Print(this, file) - type(IPModel_BOP), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_BOP : Bond-Order-Potential", file=file) - call Print("IPModel_BOP : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_BOP : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_BOP : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_BOP_Print - -subroutine IPModel_BOP_Print_ptr(this, aptr, bptr) - type(IPModel_BOP), intent(in) :: this - integer, intent(inout), dimension(:) :: aptr - integer, intent(inout), dimension(:) :: bptr - type(inoutput) :: file_a - type(inoutput) :: file_b - integer :: i - - call print("Printing aptr and bptr") - call initialise(file_a,'aptr.in', OUTPUT) - call initialise(file_b,'bptr.in', OUTPUT) - call print(this%at%N, file=file_a) - do i = 1, this%at%N - call print(" " // i // " " // this%aptr(i), file=file_a) - enddo - call print(this%bptr_num, file=file_b) - do i = 1, this%bptr_num - call print(" " // i // " " // this%bptr(i), file=file_b) - enddo - call finalise(file_a) - call finalise(file_b) - -end subroutine IPModel_BOP_Print_ptr - -subroutine IPModel_BOP_read_params_xml(this, param_str) - type(IPModel_BOP), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_BOP_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_BOP_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - integer ti - - if (name == 'BOP_params') then ! new BOP stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in BOP_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - endif - - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'BOP_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_BOP_compute_buffer(this,at,at_bop) - type(IPModel_BOP), intent(inout):: this - type(Atoms), intent(inout) :: at - type(Atoms), intent(inout) :: at_bop - integer :: cellsNa,cellsNb,cellsNc, n_atom - integer :: cellsNa2,cellsNb2,cellsNc2 - real(dp) :: cutoff - integer :: i_atom, i, j, k - type(table) :: list - - cutoff = this%cutoff - call print("calc_connect: cutoff calc_connect " // cutoff) - cellsNa = at%connect%cellsNa - cellsNb = at%connect%cellsNb - cellsNc = at%connect%cellsNc - cellsNa2 = nint(real(cellsNa,dp) / 2.0_dp ) - cellsNb2 = nint(real(cellsNb,dp) / 2.0_dp ) - cellsNc2 = nint(real(cellsNc,dp) / 2.0_dp ) - call print("calc_connect: cells_N[abc] " // cellsNa // " " // cellsNb // " " // cellsNc) - - call calc_connect(at) - -! pick an atom in the middle of the unit box - i_atom = -1 - loop_c : do k = cellsNc2, cellsNc - loop_b : do j = cellsNb2, cellsNb - loop_a : do i = cellsNa2, cellsNa -! n_atom = at%connect%cell(i,j,k)%N - n_atom = at%connect%cell_heads(i,j,k) - if(n_atom.ne.0) then -! i_atom = at%connect%cell(i,j,k)%int(1,1) - i_atom = n_atom - exit loop_c - endif - enddo loop_a - enddo loop_b - enddo loop_c - if(i_atom == -1) call system_abort("IPModel_BOP_compute_buffer : no atom in the halved simulation cell") - - call append(list, (/i_atom,0,0,0/)) - call BFS_grow(at, list, 4) - call print('---------------cluster--------------------', PRINT_NERD) - call print(list, PRINT_NERD) - call print('--------------end cluster-----------------', PRINT_NERD) - - call build_cluster(at, list, at_bop) - -end subroutine IPModel_BOP_compute_buffer - -subroutine build_cluster(at, list, at_bop) - type(Atoms), intent(inout) :: at - type(Atoms), intent(inout) :: at_bop - type(table) :: list - real(dp), dimension(3) :: dist, rmax, length - integer, dimension(3) :: n_cell_rep - integer :: iatom, jatom, i - - call print ('Number of atoms belonging to the cluster : ' // list%N ) - call print ('Cluster center atom : ' // list%int(1,1) ) - call print (' shift : ' // list%int(2:4,1) ) - -! Find how many cells have to be added - iatom = list%int(1,1) - rmax = 0.0_dp - do i = 2, list%N - jatom = list%int(1,i) - dist = abs( at%pos(:,iatom) - pos_j(at, jatom, list%int(2:4,i)) ) - if(dist(1) .gt. rmax(1)) rmax(1) = dist(1) - if(dist(2) .gt. rmax(2)) rmax(2) = dist(2) - if(dist(3) .gt. rmax(3)) rmax(3) = dist(3) - enddo - length(1) = at%lattice(1,1) / real(at%connect%cellsNa,dp) - length(2) = at%lattice(2,2) / real(at%connect%cellsNb,dp) - length(3) = at%lattice(3,3) / real(at%connect%cellsNc,dp) - - n_cell_rep = int(rmax/length) + 1 - call print("Number of cell repeated along the three directions : " // n_cell_rep(1:3) ) - -! Add to the simulation cell the just computed number of cells - call add_cells(at, n_cell_rep, at_bop) - -end subroutine build_cluster - -subroutine add_cells(at, n_cell_rep, at_bop) - type(Atoms), intent(inout) :: at - type(Atoms), intent(inout) :: at_bop - integer, dimension(3) :: cells, n_cell_rep, periodicity - integer :: i, j, k, ic, ic_right_p, ic_right_m, ii, iatom - real(dp) :: pos(3), length - - cells(1) = at%connect%cellsNa - cells(2) = at%connect%cellsNb - cells(3) = at%connect%cellsNc - - at_bop = at - do i = 1, 3 ! x, y, z - if(n_cell_rep(i).eq.0) cycle !skip this direction - do ic = 1, n_cell_rep(i) - ic_right_p = cells(i) - ic + 1 + int((ic - 1) / cells(i)) * cells(i) - ic_right_m = ic - 1 - int((ic - 1) / cells(i)) * cells(i) - - periodicity = 0 - periodicity(i) = int( (ic-1)/cells(i) + 1 ) - call print ("ic_right_p " // ic_right_p // " ; ic " // ic, PRINT_NERD) - call print ("ic_right_m " // ic_right_m // " ; ic " // ic, PRINT_NERD) - call print ("periodicity " // periodicity, PRINT_NERD) - - if(i.eq.1) then - do j = 1, cells(2) - do k = 1, cells(3) -! do ii = 1, at%connect%cell(ic_right_p,j,k)%N -! iatom = at%connect%cell(ic_right_p,j,k)%int(1,ii) - iatom = at%connect%cell_heads(ic_right_p,j,k) - do while(iatom > 0) - call print( j //" "// k // " atom : " // iatom // " " // cell_n(at%connect, ic_right_p,j,k)) - pos = at%pos(:,iatom) + real(periodicity,dp) * at%lattice(i,i) - call add_atoms(at_bop, pos, at%Z(iatom)) - iatom = at%connect%next_atom_in_cell(iatom) - enddo - -! do ii = 1, at%connect%cell(ic_right_m,j,k)%N -! iatom = at%connect%cell(ic_right_m,j,k)%int(1,ii) - iatom = at%connect%cell_heads(ic_right_m,j,k) - do while (iatom > 0) - call print( j //" "// k // " atom : " // iatom // " " // cell_n(at%connect, ic_right_m,j,k)) - pos = at%pos(:,iatom) + real(periodicity,dp) * at%lattice(i,i) - call add_atoms(at_bop, pos, at%Z(iatom)) - iatom = at%connect%next_atom_in_cell(iatom) - enddo - enddo - enddo - elseif(i.eq.2) then - - elseif(i.eq.3) then - - endif - - enddo - length = at%lattice(i,i) / cells(i) - at_bop%lattice(i,i) = at_bop%lattice(i,i) + n_cell_rep(i) * length * 2.0_dp - - enddo - - stop - -end subroutine add_cells - -function pos_j(at, j, shift) - type(Atoms), intent(inout) :: at - real(dp), dimension(3) :: pos_j - integer, dimension(3) :: shift - integer :: j - - pos_j = (at%lattice .mult. shift) + at%pos(:,j) - -end function pos_j - -!!$ subroutine supercell_minus_plus(aa, a, n1, n2, n3) -!!$ type(Atoms), intent(out)::aa !% Output (big) cell -!!$ type(Atoms), intent(in)::a !% Input cell -!!$ integer, intent(inout)::n1, n2, n3 -!!$ real(dp)::lattice(3,3), p(3) -!!$ integer::i,j,k,n -!!$ type(Table) :: big_data -!!$ integer :: nn1, n1save, n2save, n3save -!!$ integer, pointer, dimension(:) :: map_new, map -!!$ -!!$ n1save = n1 -!!$ n2save = n2 -!!$ n3save = n3 -!!$ n1 = 2 * n1 - 1 -!!$ n2 = 2 * n2 - 1 -!!$ n3 = 2 * n3 - 1 -!!$ -!!$ call allocate(big_data,a%data%intsize,a%data%realsize,& -!!$ a%data%strsize, a%data%logicalsize, a%N*n1*n2*n3) -!!$ -!!$ ! Replicate atomic data n1*n2*n3 times -!!$ do i=1,n1*n2*n3 -!!$ call append(big_data,a%data) -!!$ end do -!!$ -!!$ lattice(:,1) = a%lattice(:,1)*n1save -!!$ lattice(:,2) = a%lattice(:,2)*n2save -!!$ lattice(:,3) = a%lattice(:,3)*n3save -!!$ call atoms_initialise(aa, a%N*n1*n2*n3, lattice, data=big_data, properties=a%properties) -!!$ if (a%use_uniform_cutoff) then -!!$ call set_cutoff(aa, a%cutoff) -!!$ else -!!$ call set_cutoff_factor(aa, a%cutoff) -!!$ end if -!!$ -!!$ if (.not. assign_pointer(a, 'map', map)) & -!!$ call system_abort('active pointer assignment failed') -!!$ if (.not. assign_pointer(aa, 'map', map_new)) & -!!$ call system_abort('active pointer assignment failed') -!!$ -!!$ nn1 = 0 -!!$ do i = 0,n1save-1 -!!$ do j = 0,n2save-1 -!!$ do k = 0,n3save-1 -!!$ p = a%lattice .mult. (/i,j,k/) -!!$ do n = 1,a%N -!!$ ! overwrite position with shifted pos -!!$ nn1 = nn1 + 1 -!!$ aa%pos(:,nn1) = a%pos(:,n)+p -!!$ map_new(nn1) = map(n) -!!$ end do -!!$ if(i.eq.0.and.j.eq.0.and.k.eq.0) cycle -!!$ do n = 1,a%N -!!$ ! overwrite position with shifted pos -!!$ nn1 = nn1 + 1 -!!$ aa%pos(:,nn1) = a%pos(:,n)-p -!!$ map_new(nn1) = map(n) -!!$ end do -!!$ end do -!!$ end do -!!$ end do -!!$ -!!$ call finalise(big_data) -!!$ -!!$ end subroutine supercell_minus_plus - -end module IPModel_BOP_module diff --git a/src/Potentials/IPModel_BornMayer.f95 b/src/Potentials/IPModel_BornMayer.f95 deleted file mode 100644 index 87ad935624..0000000000 --- a/src/Potentials/IPModel_BornMayer.f95 +++ /dev/null @@ -1,571 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_BornMayer -!X -!% BornMayer potential of the form $V_{ij} = A_{ij} exp(-b_{ij} r_{ij}) - c_{ij}/r_{ij}^6$ -!% Use together with an IPModel_Coulomb to include long range forces -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_BornMayer_module - - use error_module - use system_module, only : dp, inoutput, print, PRINT_VERBOSE, PRINT_ANALYSIS, current_verbosity, operator(//) - use dictionary_module - use paramreader_module - use linearalgebra_module - use atoms_types_module - use atoms_module - - use mpi_context_module - use QUIP_Common_module - - implicit none - private - - include 'IPModel_interface.h' - - public :: IPModel_BornMayer - type IPModel_BornMayer - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - real(dp), allocatable :: A(:,:), b(:,:), c(:,:), cutoff_a(:,:), & - energy_shift(:,:), linear_force_shift(:,:) - - real(dp) :: cutoff = 0.0_dp - - character(len=STRING_LENGTH) :: label - - end type IPModel_BornMayer - - logical, private :: parse_in_ip, parse_matched_label - type(IPModel_BornMayer), private, pointer :: parse_ip - - interface Initialise - module procedure IPModel_BornMayer_Initialise_str - end interface Initialise - - interface Finalise - module procedure IPModel_BornMayer_Finalise - end interface Finalise - - interface Print - module procedure IPModel_BornMayer_Print - end interface Print - - interface Calc - module procedure IPModel_BornMayer_Calc - end interface Calc - -contains - - subroutine IPModel_BornMayer_Initialise_str(this, args_str, param_str) - type(IPModel_BornMayer), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BornMayer_Initialise_str args_str')) then - call system_abort("IPModel_BornMayer_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_BornMayer_read_params_xml(this, param_str) - - this%cutoff = maxval(this%cutoff_a) - - end subroutine IPModel_BornMayer_Initialise_str - - subroutine IPModel_BornMayer_Finalise(this) - type(IPModel_BornMayer), intent(inout) :: this - - ! Add finalisation code here - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%A)) deallocate(this%A) - if (allocated(this%b)) deallocate(this%b) - if (allocated(this%c)) deallocate(this%c) - if (allocated(this%cutoff_a)) deallocate(this%cutoff_a) - if (allocated(this%energy_shift)) deallocate(this%energy_shift) - if (allocated(this%linear_force_shift)) deallocate(this%linear_force_shift) - - this%n_types = 0 - this%label = '' - end subroutine IPModel_BornMayer_Finalise - - - subroutine IPModel_BornMayer_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_BornMayer), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - integer i, ji, j, ti, tj, n_neigh_i - real(dp) :: drij(3), drij_mag - real(dp) :: drij_dri(3), drij_drj(3) - real(dp) :: virial_i(3,3) - real(dp) :: de, de_dr, de_drij - - -#ifdef _OPENMP - real(dp) :: private_virial(3,3), private_e - real(dp), allocatable :: private_f(:,:), private_local_e(:), private_local_virial(:,:) -#endif - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_BornMayer_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_BornMayer_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_BornMayer_Calc', error) - local_virial = 0.0_dp - endif - - atom_mask_pointer => null() - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of property containing logical mask for calculation") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BornMayer_Calc args_str')) then - RAISE_ERROR("IPModel_BornMayer_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_BornMayer_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - else - atom_mask_pointer => null() - endif - else - do_rescale_r = .false. - do_rescale_E = .false. - endif - - if (do_rescale_r) call print('IPModel_BornMayer_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) - if (do_rescale_E) call print('IPModel_BornMayer_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) - - -#ifdef _OPENMP - !$omp parallel default(none) private(i, ji, j, drij, drij_mag, ti, tj, drij_dri, drij_drj, de, de_dr, de_drij, private_virial, private_e, private_f, private_local_e, private_local_virial, n_neigh_i, virial_i) shared(this, at, e, virial, atom_mask_pointer, mpi, do_rescale_r, r_scale, f, local_e, local_virial) - - if (present(e)) private_e = 0.0_dp - if (present(local_e)) then - allocate(private_local_e(at%N)) - private_local_e = 0.0_dp - endif - if (present(f)) then - allocate(private_f(3,at%N)) - private_f = 0.0_dp - endif - if (present(virial)) private_virial = 0.0_dp - if (present(local_virial)) then - allocate(private_local_virial(9,at%N)) - private_local_virial = 0.0_dp - endif - - !$omp do -#endif - do i=1, at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_BornMayer_Calc i " // i // " " // n_neighbours(at,i), PRINT_ANALYSIS) - n_neigh_i = n_neighbours(at, i) - do ji=1, n_neigh_i - j = neighbour(at, i, ji, drij_mag, cosines=drij, max_dist=this%cutoff) - if (j <= 0) cycle - if (drij_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) drij_mag = drij_mag*r_scale - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_BornMayer_Calc i j " // i // " " // j, PRINT_ANALYSIS) - - if (present(e) .or. present(local_e)) then - - de = IPModel_BornMayer_pairenergy(this, ti, tj, drij_mag) - - if (present(local_e)) then -#ifdef _OPENMP - private_local_e(i) = private_local_e(i) + de -#else - local_e(i) = local_e(i) + de -#endif - endif - if (present(e)) then -#ifdef _OPENMP - private_e = private_e + de -#else - e = e + de -#endif - endif - endif - - if (present(f) .or. present(virial) .or. present(local_virial)) then - - de_dr = IPModel_BornMayer_pairenergy_deriv(this, ti, tj, drij_mag) - - if (present(f)) then -#ifdef _OPENMP - private_f(:,i) = private_f(:,i) + de_dr*drij - private_f(:,j) = private_f(:,j) - de_dr*drij -#else - f(:,i) = f(:,i) + de_dr*drij - f(:,j) = f(:,j) - de_dr*drij -#endif - endif - - if(present(virial) .or. present(local_virial)) virial_i = de_dr*(drij .outer. drij)*drij_mag - - if (present(virial)) then -#ifdef _OPENMP - private_virial = private_virial - virial_i -#else - virial = virial - virial_i -#endif - endif - if (present(local_virial)) then -#ifdef _OPENMP - private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i, (/9/)) -#else - local_virial(:,i) = local_virial(:,i) - reshape(virial_i, (/9/)) -#endif - endif - - endif - end do - end do - -#ifdef _OPENMP - !$omp critical - if (present(e)) e = e + private_e - if (present(f)) f = f + private_f - if (present(local_e)) local_e = local_e + private_local_e - if (present(virial)) virial = virial + private_virial - if (present(local_virial)) local_virial = local_virial + private_local_virial - !$omp end critical - - if(allocated(private_f)) deallocate(private_f) - if(allocated(private_local_e)) deallocate(private_local_e) - if(allocated(private_local_virial)) deallocate(private_local_virial) - - !$omp end parallel -#endif - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) call sum_in_place(mpi, f) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(local_virial)) call sum_in_place(mpi, local_virial) - endif - - if (do_rescale_r) then - if (present(f)) f = f*r_scale - end if - - if (do_rescale_E) then - if (present(e)) e = e*E_scale - if (present(local_e)) local_e = local_e*E_scale - if (present(f)) f = f*E_scale - if (present(virial)) virial=virial*E_scale - if (present(local_virial)) local_virial=local_virial*E_scale - end if - - atom_mask_pointer => null() - - end subroutine IPModel_BornMayer_Calc - - function IPModel_BornMayer_pairenergy(this, ti, tj, r) - type(IPModel_BornMayer), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_BornMayer_pairenergy - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then - IPModel_BornMayer_pairenergy = 0.0_dp - return - endif - - IPModel_BornMayer_pairenergy = 0.5_dp*((this%A(ti,tj)*exp(-this%b(ti,tj)*r) - this%c(ti,tj)/(r**6.0_dp)) & - - this%energy_shift(ti,tj) - this%linear_force_shift(ti,tj)*(r-this%cutoff_a(ti,tj))) - - end function IPModel_BornMayer_pairenergy - - function IPModel_BornMayer_pairenergy_deriv(this, ti, tj, r) - type(IPModel_BornMayer), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_BornMayer_pairenergy_deriv - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then - IPModel_BornMayer_pairenergy_deriv = 0.0_dp - return - endif - - IPModel_BornMayer_pairenergy_deriv = 0.5_dp*(-this%b(ti,tj)*this%A(ti,tj)*exp(-this%b(ti,tj)*r) & - + 6.0_dp*this%c(ti,tj)/(r**7.0_dp) - this%linear_force_shift(ti,tj)) - - end function IPModel_BornMayer_pairenergy_deriv - - - subroutine IPModel_BornMayer_Print(this, file) - type(IPModel_BornMayer), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_BornMayer : BornMayer Potential", file=file) - call Print("IPModel_BornMayer : n_types = " // this%n_types, file=file) - do ti=1, this%n_types - call Print ("IPModel_BornMayer : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - do tj=1, this%n_types - call Print ("IPModel_BornMayer : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) // & - " " // this%atomic_num(tj), file=file) - call Print ("IPModel_BornMayer : pair A=" // this%A(ti,tj) // " b=" // this%b(ti,tj) // " c=" //this%c(ti,tj), file=file) - call Print (" cutoff="//this%cutoff_a(ti,tj)//" energy_shift="//this%energy_shift(ti,tj), file=file) - call Print (" linear_force_shift="//this%linear_force_shift(ti,tj), file=file) - end do - end do - - end subroutine IPModel_BornMayer_Print - - subroutine IPModel_BornMayer_read_params_xml(this, param_str) - type(IPModel_BornMayer), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_BornMayer_read_params_xml parsed file, but n_types = 0") - endif - - end subroutine IPModel_BornMayer_read_params_xml - - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - !X - !% XML param reader functions - !X - !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - logical :: energy_shift, linear_force_shift - - integer :: status - character(len=STRING_LENGTH) :: value - - integer ti, tj, Zi, Zj - - if (name == 'BornMayer_params') then ! new BornMayer stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in BornMayer_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - allocate(parse_ip%A(parse_ip%n_types,parse_ip%n_types)) - parse_ip%A = 0.0_dp - allocate(parse_ip%b(parse_ip%n_types,parse_ip%n_types)) - parse_ip%b = 0.0_dp - allocate(parse_ip%c(parse_ip%n_types,parse_ip%n_types)) - parse_ip%c = 0.0_dp - allocate(parse_ip%cutoff_a(parse_ip%n_types,parse_ip%n_types)) - parse_ip%cutoff_a = 0.0_dp - allocate(parse_ip%energy_shift(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%linear_force_shift(parse_ip%n_types,parse_ip%n_types)) - parse_ip%energy_shift = 0.0_dp - parse_ip%linear_force_shift = 0.0_dp - endif - - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - parse_ip%energy_shift = 0.0_dp - parse_ip%linear_force_shift = 0.0_dp - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "atnum_i", value, status) - if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find atnum_i") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find atnum_j") - read (value, *) Zj - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "A", value, status) - if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find A") - read (value, *) parse_ip%A(ti,tj) - call QUIP_FoX_get_value(attributes, "b", value, status) - if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find b") - read (value, *) parse_ip%b(ti,tj) - call QUIP_FoX_get_value(attributes, "c", value, status) - if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find c") - read (value, *) parse_ip%c(ti,tj) - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff_a(ti,tj) - - call QUIP_FoX_get_value(attributes, "energy_shift", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find energy_shift") - read (value, *) energy_shift - if (energy_shift) parse_ip%energy_shift(ti,tj) = IPModel_BornMayer_pairenergy(parse_ip, ti, tj, parse_ip%cutoff_a(ti,tj)) - - call QUIP_FoX_get_value(attributes, "linear_force_shift", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find linear_force_shift") - read (value, *) linear_force_shift - if (linear_force_shift) parse_ip%linear_force_shift(ti,tj) = IPModel_BornMayer_pairenergy_deriv(parse_ip, ti, tj, parse_ip%cutoff_a(ti,tj)) - - if (ti /= tj) then - parse_ip%A(tj,ti) = parse_ip%A(ti,tj) - parse_ip%b(tj,ti) = parse_ip%b(ti,tj) - parse_ip%c(tj,ti) = parse_ip%c(ti,tj) - parse_ip%cutoff_a(tj,ti) = parse_ip%cutoff_a(ti,tj) - parse_ip%energy_shift(tj,ti) = parse_ip%energy_shift(ti,tj) - parse_ip%linear_force_shift(tj,ti) = parse_ip%linear_force_shift(ti,tj) - endif - end if - - end subroutine IPModel_startElement_handler - - subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'BornMayer_params') then - parse_in_ip = .false. - end if - endif - - end subroutine IPModel_endElement_handler - -end module IPModel_BornMayer_module diff --git a/src/Potentials/IPModel_Brenner.f95 b/src/Potentials/IPModel_Brenner.f95 deleted file mode 100644 index b6ea2be178..0000000000 --- a/src/Potentials/IPModel_Brenner.f95 +++ /dev/null @@ -1,713 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Brenner module -!X -!% Module for computing energy, forces and virial with Brenner potential for hydrocarbons. -!% Ref. D. W. Brenner, Empirical potential for hydrocarbons for use in -!% simulating the chemical vapor deposition of diamond films. -!% Phys. Rev. B {\bf 42}, 9458 (1990). -!% The 'IPModel_Brenner' object reads parameters from a 'Brenner_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Brenner_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use units_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Brenner -type IPModel_Brenner - integer :: n_types = 0 !% Number of atomic types - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} - - real(dp) :: cutoff = 0.0_dp - - real(dp), allocatable :: R1(:,:), R2(:,:), De(:,:), S(:,:), beta(:,:) !% IP parameters - real(dp), allocatable :: delta(:,:), Re(:,:), a0(:,:,:), c0(:,:,:), d0(:,:,:) !% IP parameters - real(dp), allocatable :: shift(:,:) - - character(len=STRING_LENGTH) :: label - -end type IPModel_Brenner - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Brenner), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Brenner_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Brenner_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Brenner_Print -end interface Print - -interface Calc - module procedure IPModel_Brenner_Calc -end interface Calc - -contains - -subroutine IPModel_Brenner_Initialise_str(this, args_str, param_str) - type(IPModel_Brenner), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_Initialise_str args_str')) then - call system_abort("IPModel_Brenner_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Brenner_read_params_xml(this, param_str) - -end subroutine IPModel_Brenner_Initialise_str - -subroutine IPModel_Brenner_Finalise(this) - type(IPModel_Brenner), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%R1)) deallocate(this%R1) - if (allocated(this%R2)) deallocate(this%R2) - if (allocated(this%De)) deallocate(this%De) - if (allocated(this%S)) deallocate(this%S) - if (allocated(this%beta)) deallocate(this%beta) - if (allocated(this%delta)) deallocate(this%delta) - if (allocated(this%Re)) deallocate(this%Re) - if (allocated(this%a0)) deallocate(this%a0) - if (allocated(this%c0)) deallocate(this%c0) - if (allocated(this%d0)) deallocate(this%d0) - if (allocated(this%shift)) deallocate(this%shift) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Brenner_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X The potential calculator -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!% This routine computes energy, forces and the virial. -!% Derivatives by James Kermode jrk33@cam.ac.uk -subroutine IPModel_Brenner_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Brenner), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer :: i,j,k,m,n,r,s,p, max_neighb - integer :: ti,tj,tk,tr,ts - real(dp) :: r_ij, fc_ij, dfc_ij, & - Vr1, Va1, Vr, Va, dVr_ij, dVa_ij, G_sum, B(2), Bbar, & - t1, t2, prefactor - real(dp), dimension(:), allocatable :: cos_theta, r_rk, fc_rk, dfc_rk, & - G, dG_dcostheta - real(dp), dimension(3) :: u_ij, u_rs, grad_s, grad_k, f_s, f_k, f_ij - real(dp), dimension(:,:), allocatable :: u_rk - real(dp), pointer :: w_e(:) - real(dp) :: De_ij, R1_ij, R2_ij, Re_ij, S_ij, beta_ij, delta_ij, shift_ij, w_f - real(dp) :: a0_ijk, c0_2_ijk, d0_2_ijk, R1_rk, R2_rk, de - - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) then - e = 0.0_dp - endif - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Brenner_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_Brenner_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) then - virial = 0.0_dp - endif - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_Brenner_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_Brenner_Calc: local_virial calculation requested but not supported yet", error) - endif - - if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Brenner_Calc args_str')) then - RAISE_ERROR("IPModel_Brenner_Calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then - RAISE_ERROR("IPModel_Brenner_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.",error) - endif - else - atom_mask_pointer => null() - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_Brenner_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - endif - - ! Find maximum number of neighbours and allocate - ! temporary storage for bond vectors and angles - max_neighb = 0 - do i=1,at%N - n = n_neighbours(at, i) - if (n > max_neighb) max_neighb = n - end do - - allocate(cos_theta(max_neighb)) - allocate(r_rk(max_neighb), u_rk(3,max_neighb)) - allocate(fc_rk(max_neighb), dfc_rk(max_neighb)) - allocate(G(max_neighb), dG_dcostheta(max_neighb)) - - do i=1,at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - ! Loop over neighbour of atom i - do n=1, n_neighbours(at, i) - j = neighbour(at, i, n,r_ij,cosines=u_ij) - if (r_ij .feq. 0.0_dp) cycle - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - R1_ij = this%R1(ti,tj) - R2_ij = this%R2(ti,tj) - - if (r_ij < R2_ij) then - De_ij = this%De(ti,tj) - Re_ij = this%Re(ti,tj) - S_ij = this%S(ti,tj) - beta_ij = this%beta(ti,tj) - delta_ij = this%delta(ti,tj) - shift_ij = this%shift(ti,tj) - else - cycle ! Outside range of cutoff function - end if - - call brenner_cutoff(r_ij, R1_ij, R2_ij, fc_ij, dfc_ij) - - ! Evaluate attractive and repulsive pair potentials - Vr1 = De_ij/(S_ij-1.0_dp)* & - exp(-sqrt(2.0_dp*S_ij)*beta_ij*(r_ij-Re_ij)) - Va1 = De_ij*S_ij/(S_ij-1.0_dp)* & - exp(-sqrt(2.0_dp/S_ij)*beta_ij*(r_ij-Re_ij)) - - Vr = Vr1*fc_ij - Va = Va1*fc_ij - - ! Derivatives of Vr and Va wrt r_ij - dVr_ij = Vr1*(-sqrt(2.0_dp*S_ij)*beta_ij*fc_ij + dfc_ij) - dVa_ij = Va1*(-sqrt(2.0_dp/S_ij)*beta_ij*fc_ij + dfc_ij) - - ! Repeat twice, first centred on atom i -> B_ij and derivatives - ! second time centred on atom j -> B_ji and derivatives - do p = 1,2 - - if (p == 1) then - r = i; s = j - tr = ti; ts = tj; - u_rs = u_ij - else - r = j; s = i - tr = tj; ts = ti; - u_rs = -u_ij ! reverse bond vector 2nd time - end if - - ! First we loop over neighbours of atom r (i or j) - ! to get get total bond order factors B_ij and B_ji. - ! Store r_rk, u_rk, cos_theta, fc_rk, dfc_rk, G, - ! and dG_dcostheta for each neighbour to save having - ! to recalculate them below when we evaluate forces - G_sum = 0.0_dp - do m=1, n_neighbours(at, r) - k = neighbour(at, r, m, r_rk(m), cosines=u_rk(:,m)) - if (k == i .or. k == j) cycle - if (r_rk(m) .feq. 0.0_dp) cycle - - tk = get_type(this%type_of_atomic_num, at%Z(k)) - - R1_rk = this%R1(tr,tk) - R2_rk = this%R2(tr,tk) - - ! First time: r_rk = r_ik - ! Second time: r_rk = r_jk - if (r_rk(m) > R2_rk) cycle ! Outside range of cutoff function - - a0_ijk = this%a0(ti,tj,tk) - c0_2_ijk = this%c0(ti,tj,tk)*this%c0(ti,tj,tk) - d0_2_ijk = this%d0(ti,tj,tk)*this%d0(ti,tj,tk) - - ! first time: theta_ijk - ! Second time: theta_jik - call brenner_cutoff(r_rk(m), R1_rk, R2_rk, fc_rk(m), dfc_rk(m)) - - cos_theta(m) = u_rs .dot. u_rk(:,m) - - t1 = (1.0_dp + cos_theta(m)); t2 = t1*t1 - G(m) = a0_ijk*(1.0_dp + c0_2_ijk/d0_2_ijk - & - c0_2_ijk/(d0_2_ijk + t2)) - dG_dcostheta(m) = 2.0_dp*a0_ijk*c0_2_ijk*t1/ & - ((d0_2_ijk + t2)**2) - - G_sum = G_sum + G(m)*fc_rk(m) - end do - - ! This is the bond order factor - B(p) = (1.0_dp + G_sum)**(-delta_ij) - - ! Now we need to loop over neigbours again to work out - ! derivaties of B_ij or B_ji wrt atom positions. We - ! get gradient from chain rule and the results that: - ! - ! grad_j(cos_theta_ijk) = (u_ik - cos_theta*u_ij)/r_ij - ! grad_k(cos_theta_ijk) = (u_ij - cos_theta*u_ik)/r_ik - ! grad_i(cos_theta_ijk) = -(grad_j + grad_k) - ! - ! Use previously cached data for each neighbour - - if (associated(w_e)) then - w_f = 0.5_dp*(w_e(i)+w_e(j)) - else - w_f = 1.0_dp - endif - - if (present(f) .or. present(virial)) then - - prefactor = 0.5_dp*w_f*0.5_dp*Va*delta_ij/ & - ((1.0_dp + G_sum)**(1.0_dp + delta_ij)) - - do m=1, n_neighbours(at, r) - k = neighbour(at, r, m) - if (k == i .or. k == j) cycle - if (r_rk(m) > R2_ij) cycle ! Outside range of cutoff function - - ! force on atom k depends on r_ik or r_jk, hence second term - ! First time: F_k ~ grad_k(theta_ijk) + grad_k(r_ik) - ! Second time: F_k ~ grad_k(theta_jik) + grad_k(r_jk) - grad_k = (u_rs - cos_theta(m)*u_rk(:,m))/r_rk(m) - f_k = -prefactor*(grad_k*dG_dcostheta(m)*fc_rk(m) + G(m)*dfc_rk(m)*u_rk(:,m)) - if (present(f)) then - f(:,k) = f(:,k) + f_k - end if - - ! First time: F_j ~ grad_j(theta_ijk) - ! Second time: F_i ~ grad_i(theta_jik) - grad_s = (u_rk(:,m) - cos_theta(m)*u_rs)/r_ij - f_s = -prefactor*(grad_s*dG_dcostheta(m)*fc_rk(m)) - if (present(f)) then - f(:,s) = f(:,s) + f_s - end if - - ! First time: F_i = -(F_k + F_j) - ! Second time: F_j = -(F_k + F_i) - if (present(f)) then - f(:,r) = f(:,r) - (f_k + f_s) - end if - - if (present(virial)) then - virial = virial + ((u_rs*r_ij) .outer. f_s) + & - ((u_rk(:,m)*r_rk(m)) .outer. f_k) - end if - - end do - end if - end do - - ! Finally, average bond order factors B_ij and B_ji - Bbar = 0.5_dp*(B(1) + B(2)) + shift_ij - - ! Add two-body part of f - if (present(f) .or. present(virial)) then - t1 = dVr_ij - Bbar*dVa_ij - f_ij = 0.5_dp*w_f*t1*u_ij - - if (present(f)) then - f(:,i) = f(:,i) + f_ij - f(:,j) = f(:,j) - f_ij - end if - - ! 2 body contribution to virial - if (present(virial)) then - virial = virial - ((u_ij*r_ij) .outer. f_ij) - end if - - end if - - if (present(e) .or. present(local_e)) then - de = 0.5_dp*(Vr - Bbar*Va) - if (present(local_e)) then - local_e(i) = local_e(i) + 0.5_dp*de - local_e(j) = local_e(j) + 0.5_dp*de - end if - if (present(e)) then - e = e + de*w_f - end if - end if - - end do - end do - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) call sum_in_place(mpi, f) - if (present(virial)) call sum_in_place(mpi, virial) - endif - - deallocate(cos_theta) - deallocate(r_rk, u_rk) - deallocate(fc_rk, dfc_rk) - deallocate(G, dG_dcostheta) - -end subroutine IPModel_Brenner_Calc - - -!% Evaluate cutoff function \texttt{fc} and its derivative \texttt{dfc} wrt r -subroutine brenner_cutoff(r, R1, R2, fc, dfc) - real(dp), intent(in) :: r, R1, R2 - real(dp), intent(out) :: fc, dfc - - if (r < R1) then - fc = 1.0_dp - dfc = 0.0_dp !fc constant, so d(fc)/dr = 0 - else - fc = 0.5_dp*(1.0_dp + cos(PI*(r-R1)/(R2-R1))) - dfc = -0.5_dp*PI*sin(PI*(r-R1)/(R2-R1))/(R2-R1) - end if -end subroutine brenner_cutoff - - - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% Parameters can be given using an external input file or with an internal string. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - - integer ti, tj, tk, Zi, Zj, Zk - - if (name == 'Brenner_params') then ! new Brenner stanza - - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered Brenner_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, "n_types", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find n_types") - read (value, *) parse_ip%n_types - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - allocate(parse_ip%R1(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%R2(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%De(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%S(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%beta(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%delta(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%Re(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%a0(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%c0(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%d0(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%shift(parse_ip%n_types,parse_ip%n_types)) - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "atnum_i", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_i") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_j") - read (value, *) Zj - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "R1", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find R1") - read (value, *) parse_ip%R1(ti,tj) - call QUIP_FoX_get_value(attributes, "R2", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find R2") - read (value, *) parse_ip%R2(ti,tj) - call QUIP_FoX_get_value(attributes, "De", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find De") - read (value, *) parse_ip%De(ti,tj) - call QUIP_FoX_get_value(attributes, "S", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find S") - read (value, *) parse_ip%S(ti,tj) - call QUIP_FoX_get_value(attributes, "beta", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find beta") - read (value, *) parse_ip%beta(ti,tj) - call QUIP_FoX_get_value(attributes, "delta", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find delta") - read (value, *) parse_ip%delta(ti,tj) - call QUIP_FoX_get_value(attributes, "Re", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find Re") - read (value, *) parse_ip%Re(ti,tj) - call QUIP_FoX_get_value(attributes, "shift", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find shift") - read (value, *) parse_ip%shift(ti,tj) - - - if (ti /= tj) then - parse_ip%R1(tj,ti) = parse_ip%R1(ti,tj) - parse_ip%R2(tj,ti) = parse_ip%R2(ti,tj) - parse_ip%De(tj,ti) = parse_ip%De(ti,tj) - parse_ip%S(tj,ti) = parse_ip%S(ti,tj) - parse_ip%beta(tj,ti) = parse_ip%beta(ti,tj) - parse_ip%delta(tj,ti) = parse_ip%delta(ti,tj) - parse_ip%Re(tj,ti) = parse_ip%Re(ti,tj) - parse_ip%shift(tj,ti) = parse_ip%shift(ti,tj) - endif - - parse_ip%cutoff = maxval(parse_ip%R2) - - elseif (parse_in_ip .and. name == 'per_triplet_data') then - - call QUIP_FoX_get_value(attributes, "atnum_c", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_c") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_j") - read (value, *) Zj - call QUIP_FoX_get_value(attributes, "atnum_k", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_k") - read (value, *) Zk - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - tk = get_type(parse_ip%type_of_atomic_num,Zk) - - call QUIP_FoX_get_value(attributes, "a0", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find a0") - read (value, *) parse_ip%a0(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "c0", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find c0") - read (value, *) parse_ip%c0(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "d0", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find d0") - read (value, *) parse_ip%d0(ti,tj,tk) - - if (tj /= tk) then - parse_ip%a0(ti,tk,tj) = parse_ip%a0(ti,tj,tk) - parse_ip%c0(ti,tk,tj) = parse_ip%c0(ti,tj,tk) - parse_ip%d0(ti,tk,tj) = parse_ip%d0(ti,tj,tk) - endif - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Brenner_params') then - parse_in_ip = .false. - endif - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_Brenner_read_params_xml(this, param_str) - type(IPModel_Brenner), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type (xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_ip => this - parse_in_ip = .false. - parse_matched_label = .false. - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Brenner_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_Brenner_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of Brenner potential parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_Brenner_Print (this, file) - type(IPModel_Brenner), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj, tk - - call Print("IPModel_Brenner : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print("IPModel_Brenner : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - do tj=1, this%n_types - call Print ("IPModel_Brenner : pair "// ti // " " // tj // " R1 " // this%R1(ti,tj) & - // " R2 " // this%R2(ti,tj)// " De " // this%De(ti,tj)// " S " // this%S(ti,tj) & - // " beta " // this%beta(ti,tj)// " delta " // this%delta(ti,tj) & - // " Re " // this%Re(ti,tj)// " shift " // this%shift(ti,tj), file=file) - do tk=1,this%n_types - call Print("IPModel_Brenner : triplet "// ti //" "//tj//" "//tk//" a0 "//this%a0(ti,tj,tk)& - //" c0 "//this%c0(ti,tj,tj)//" d0 "//this%d0(ti,tj,tk),file=file) - end do - end do - call verbosity_pop() - end do - -end subroutine IPModel_Brenner_Print - -end module IPModel_Brenner_module diff --git a/src/Potentials/IPModel_Brenner_2002.f95 b/src/Potentials/IPModel_Brenner_2002.f95 deleted file mode 100644 index fcd5d0349c..0000000000 --- a/src/Potentials/IPModel_Brenner_2002.f95 +++ /dev/null @@ -1,399 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Brenner_Screened module -!X -!% Module for interfacing to Brenner Potential as described in -!% Brenner et al. `A second-generation reactive empirical bond order (REBO) potential -!% energy expression for hydrocarbons', J. Phys.: Cond Mat (2002) vol. 14 (4) pp. 783-802 -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Brenner_2002_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -#ifdef HAVE_MDCORE -use force_brenner2002, only: force_brenner2002_kernel -use db_brenner2002, only: db_brenner2002_init -#endif - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Brenner_2002 -type IPModel_Brenner_2002 - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - - integer :: n - type(Atoms) :: at - integer, allocatable, dimension(:) :: aptr - integer, allocatable, dimension(:) :: bptr - integer :: bptr_num - - character(len=STRING_LENGTH) :: label - -end type IPModel_Brenner_2002 - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Brenner_2002), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Brenner_2002_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Brenner_2002_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Brenner_2002_Print -end interface Print - -interface Calc - module procedure IPModel_Brenner_2002_Calc -end interface Calc - -contains - -subroutine IPModel_Brenner_2002_Initialise_str(this, args_str, param_str) - type(IPModel_Brenner_2002), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - character(len=STRING_LENGTH) label - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_2002_Initialise_str args_str')) then - call system_abort("IPModel_Brenner_2002_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Brenner_2002_read_params_xml(this, param_str) - -#ifdef HAVE_MDCORE - call db_brenner2002_init() - this%cutoff = 2.0_dp -#else - call system_abort('IPModel_Brenner_2002_Initialise - support for mdcore not compiled in') -#endif - -end subroutine IPModel_Brenner_2002_Initialise_str - -subroutine IPModel_Brenner_2002_Finalise(this) - type(IPModel_Brenner_2002), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Brenner_2002_Finalise - - -subroutine IPModel_Brenner_2002_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Brenner_2002), intent(inout):: this - type(Atoms), intent(inout) :: at !Active + buffer atoms - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer:: i,n - real(dp), dimension(:,:), allocatable :: pos_in, force_out, dr - real(dp) :: brenner_e, brenner_virial(3,3) - - real(dp), dimension(:,:,:), allocatable :: w_per_at - integer, dimension(:), allocatable :: aptr, bptr, k_typ - integer :: n_tot, neighb - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Brenner_2002_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Brenner_2002_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Brenner_2002_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_Brenner_2002_Calc: local_virial calculation requested but not supported yet.", error) - endif - - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_2002_Calc args_str')) then - RAISE_ERROR("IPModel_Brenner_2002_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_Brenner_2002_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_Brenner_2002_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - endif - - - n_tot = 0 - do i=1,at%N - n_tot = n_tot + n_neighbours(at, i) - end do - - allocate(aptr(at%N+1),bptr(n_tot+at%n+1),dr(n_tot+at%n+1,3), w_per_at(3,3,at%n), & - pos_in(at%n,3),force_out(at%n,3),k_typ(at%N)) - force_out = 0.0_dp - dr = 0.0_dp - brenner_e = 0.0_dp - aptr = 0 - bptr = 0 - - k_typ = 1 - - neighb = 1 - do i=1,at%N - pos_in(i,:) = at%pos(:,i) - - aptr(i) = neighb - do n=1,n_neighbours(at,i) - bptr(neighb) = neighbour(at,i,n, diff=dr(neighb,:)) - dr(neighb,:) = -dr(neighb,:) ! opposite sign convention - - neighb = neighb + 1 - end do - neighb = neighb + 1 - end do - bptr(neighb) = 0 - aptr(at%N+1) = neighb - - brenner_virial = 0.0_dp -#ifdef HAVE_MDCORE - call force_brenner2002_kernel(at%N,pos_in,k_typ,brenner_e,force_out, brenner_virial, & - aptr, bptr, size(bptr), dr, w_per_at) -#else - call system_abort('IPModel_Brenner_2002 - mdcore support not compiled in') -#endif - - if (present(local_e)) call system_abort('IPModel_Brenner_2002 - no support for local energies') - - if (present(e)) e = brenner_e - - if (present(f)) then - do i=1,at%N - f(:,i) = force_out(i,:) - end do - end if - - if (present(virial)) then - virial = -brenner_virial - end if - - deallocate(aptr,bptr,dr,pos_in,force_out,w_per_at) - -end subroutine IPModel_Brenner_2002_Calc - - -subroutine IPModel_Brenner_2002_Print(this, file) - type(IPModel_Brenner_2002), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_Brenner_2002 : 2nd generation Brenner Potential", file=file) - call Print(" J. Phys.: Cond Mat (2002) vol. 14 (4) pp. 783-802", file=file) - call Print("IPModel_Brenner_2002 : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_Brenner_2002 : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_Brenner_2002 : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_Brenner_2002_Print - -subroutine IPModel_Brenner_2002_read_params_xml(this, param_str) - type(IPModel_Brenner_2002), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Brenner_2002_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_Brenner_2002_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - logical shifted - integer ti, tj - - if (name == 'Brenner_2002_params') then ! new Brenner_2002 stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in Brenner_2002_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_2002_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - endif - - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_2002_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_2002_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Brenner_2002_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_Brenner_2002_module diff --git a/src/Potentials/IPModel_Brenner_Screened.f95 b/src/Potentials/IPModel_Brenner_Screened.f95 deleted file mode 100644 index b7c40db575..0000000000 --- a/src/Potentials/IPModel_Brenner_Screened.f95 +++ /dev/null @@ -1,404 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Brenner_Screened module -!X -!% Module for interfacing to Screened Brenner Potential as described in -!% -!% ``Describing bond-breaking processes by reactive potentials: -!% Importance of an environment-dependent interaction range.'' -!% Lars Pastewka, Pablo Pou, Rubén Pérez, Peter Gumbsch, Michael Moseler. -!% Phys. Rev. B (2008) vol. 78 (16) pp. 4 -!% http://dx.doi.org/10.1103/PhysRevB.78.161402 -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Brenner_Screened_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -#ifdef HAVE_MDCORE -use force_brenner2002_exp, only: force_brenner2002_exp_kernel -use db_brenner2002_exp, only: with_dihedral, db_brenner2002_init -#endif - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Brenner_Screened -type IPModel_Brenner_Screened - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - - integer :: n - type(Atoms) :: at - integer, allocatable, dimension(:) :: aptr - integer, allocatable, dimension(:) :: bptr - integer :: bptr_num - - character(len=STRING_LENGTH) :: label - -end type IPModel_Brenner_Screened - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Brenner_Screened), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Brenner_Screened_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Brenner_Screened_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Brenner_Screened_Print -end interface Print - -interface Calc - module procedure IPModel_Brenner_Screened_Calc -end interface Calc - -contains - -subroutine IPModel_Brenner_Screened_Initialise_str(this, args_str, param_str) - type(IPModel_Brenner_Screened), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - character(len=STRING_LENGTH) label - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_Screened_Initialise_str args_str')) then - call system_abort("IPModel_Brenner_Screened_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Brenner_Screened_read_params_xml(this, param_str) - -#ifdef HAVE_MDCORE - with_dihedral = 0 - call db_brenner2002_init() - this%cutoff = 4.0_dp -#else - call system_abort('IPModel_Brenner_Screened_Initialise - support for mdcore not compiled in') -#endif - -end subroutine IPModel_Brenner_Screened_Initialise_str - -subroutine IPModel_Brenner_Screened_Finalise(this) - type(IPModel_Brenner_Screened), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Brenner_Screened_Finalise - - -subroutine IPModel_Brenner_Screened_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Brenner_Screened), intent(inout):: this - type(Atoms), intent(inout) :: at !Active + buffer atoms - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer:: i,n - real(dp), dimension(:,:), allocatable :: pos_in, force_out, dr - real(dp) :: brenner_e, brenner_virial(3,3) - - real(dp), dimension(:), allocatable :: abs_dr - integer, dimension(:), allocatable :: aptr, bptr, k_typ - integer :: n_tot, neighb - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Brenner_Screened_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Brenner_Screened_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Brenner_Screened_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_Brenner_Screened_Calc: local_virial calculation requested but not supported yet.", error) - endif - - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_Screened_Calc args_str')) then - RAISE_ERROR("IPModel_Brenner_Screened_Calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_Brenner_Screened_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_Brenner_Screened_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - endif - - n_tot = 0 - do i=1,at%N - n_tot = n_tot + n_neighbours(at, i) - end do - - allocate(aptr(at%N+1),bptr(n_tot+at%n+1),dr(n_tot+at%n+1,3), abs_dr(n_tot+at%n+1), & - pos_in(at%n,3),force_out(at%n,3),k_typ(at%N)) - force_out = 0.0_dp - dr = 0.0_dp - brenner_e = 0.0_dp - aptr = 0 - bptr = 0 - - k_typ = 1 - - neighb = 1 - do i=1,at%N - pos_in(i,:) = at%pos(:,i) - - aptr(i) = neighb - do n=1,n_neighbours(at,i) - bptr(neighb) = neighbour(at,i,n, diff=dr(neighb,:),distance=abs_dr(neighb)) - dr(neighb,:) = -dr(neighb,:) ! opposite sign convention - - neighb = neighb + 1 - end do - neighb = neighb + 1 - end do - bptr(neighb) = 0 - aptr(at%N+1) = neighb - - brenner_virial = 0.0_dp -#ifdef HAVE_MDCORE - call force_brenner2002_exp_kernel(at%N,pos_in,k_typ,brenner_e,force_out, brenner_virial, & - aptr, bptr, size(bptr), dr, abs_dr) -#else - call system_abort('IPModel_Brenner_Screened - mdcore support not compiled in') -#endif - - if (present(local_e)) call system_abort('IPModel_Brenner_Screened - no support for local energies') - - if (present(e)) e = brenner_e - - if (present(f)) then - do i=1,at%N - f(:,i) = force_out(i,:) - end do - end if - - if (present(virial)) then - virial = -brenner_virial - end if - - deallocate(aptr,bptr,dr,pos_in,force_out,abs_dr) - -end subroutine IPModel_Brenner_Screened_Calc - - -subroutine IPModel_Brenner_Screened_Print(this, file) - type(IPModel_Brenner_Screened), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_Brenner_Screened : Screnned Brenner Potential", file=file) - call Print(" Phys. Rev. B (2008) vol. 78 (16) pp. 4 ", file=file) - call Print("IPModel_Brenner_Screened : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_Brenner_Screened : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_Brenner_Screened : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_Brenner_Screened_Print - -subroutine IPModel_Brenner_Screened_read_params_xml(this, param_str) - type(IPModel_Brenner_Screened), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Brenner_Screened_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_Brenner_Screened_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - logical shifted - integer ti, tj - - if (name == 'Brenner_Screened_params') then ! new Brenner_Screened stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in Brenner_Screened_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_Screened_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - endif - - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_Screened_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Brenner_Screened_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Brenner_Screened_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_Brenner_Screened_module diff --git a/src/Potentials/IPModel_CH4.f95 b/src/Potentials/IPModel_CH4.f95 deleted file mode 100644 index 12d2e7fb20..0000000000 --- a/src/Potentials/IPModel_CH4.f95 +++ /dev/null @@ -1,204 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_CH4 -!X -!% CH4 module for use when implementing a new Interatomic Potential -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_CH4_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use units_module -use atoms_module -use topology_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_CH4 -type IPModel_CH4 - real(dp) :: cutoff = 0.0_dp - - character(len=STRING_LENGTH) :: label - -end type IPModel_CH4 - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_CH4), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_CH4_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_CH4_Finalise -end interface Finalise - -interface Print - module procedure IPModel_CH4_Print -end interface Print - -interface Calc - module procedure IPModel_CH4_Calc -end interface Calc - -interface - function ch4pot_func_10(r) - real(8), intent(in) :: r(10) - real(8) :: ch4pot_func_10 - endfunction ch4pot_func_10 -endinterface - -contains - -subroutine IPModel_CH4_Initialise_str(this, args_str, param_str) - type(IPModel_CH4), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_CH4_Initialise_str args_str')) then - call system_abort("IPModel_CH4_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - this%cutoff = 2.0 - -end subroutine IPModel_CH4_Initialise_str - -subroutine IPModel_CH4_Finalise(this) - type(IPModel_CH4), intent(inout) :: this - - ! Add finalisation code here - - this%label = '' - this%cutoff = 0.0_dp -end subroutine IPModel_CH4_Finalise - - -subroutine IPModel_CH4_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_CH4), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer, dimension(5) :: signature - integer, dimension(:,:), allocatable :: monomer_index - logical, dimension(:), allocatable :: is_associated - real(dp), dimension(3,4) :: pos - real(dp), dimension(4,4) :: bmat, bmati - real(dp), dimension(10) :: rten - integer :: i, j, iC, iH, n_monomers - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_CH4_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_CH4_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_CH4_Calc', error) - local_virial = 0.0_dp - endif - - signature = (/6,1,1,1,1/) - allocate(is_associated(at%N)) - - - is_associated = .false. - call find_general_monomer(at,monomer_index,signature,is_associated,this%cutoff,error=error) - - n_monomers = size(monomer_index,2) - -#ifdef HAVE_CH4 - call ch4_initialise(bmat,bmati) -#endif - - do i = 1, n_monomers - iC = monomer_index(1,i) - do j = 1, 4 - iH = monomer_index(j+1,i) - pos(:,j) = diff_min_image(at,iC,iH) / BOHR - enddo -#ifdef HAVE_CH4 - call bond_cart2radau_int10(pos,bmati,rten) - if(present(e)) e = e + ch4pot_func_10(rten) * INVERSE_CM -#endif - enddo - - if(allocated(monomer_index)) deallocate(monomer_index) - if(allocated(is_associated)) deallocate(is_associated) - -end subroutine IPModel_CH4_Calc - - -subroutine IPModel_CH4_Print(this, file) - type(IPModel_CH4), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_CH4 : CH4 Potential", file=file) - call Print("IPModel_CH4 : cutoff = " // this%cutoff, file=file) - -end subroutine IPModel_CH4_Print - -end module IPModel_CH4_module diff --git a/src/Potentials/IPModel_ConfiningMonomer.f95 b/src/Potentials/IPModel_ConfiningMonomer.f95 deleted file mode 100644 index b017bf056d..0000000000 --- a/src/Potentials/IPModel_ConfiningMonomer.f95 +++ /dev/null @@ -1,340 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2017. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_ConfiningMonomer -!X -!% Potential to keep monomers together, currently hardcoded for methane -!% (but should be easy to modify for any single-centre molecule) -!% -!% Simple harmonic on C-H bonds and H-C-H angle cosines -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_ConfiningMonomer_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_VERBOSE, PRINT_NERD, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use topology_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_ConfiningMonomer -type IPModel_ConfiningMonomer - real(dp) :: cutoff = 0.0_dp - real(dp) :: kbond = 0.0_dp - real(dp) :: kangle = 0.0_dp - real(dp) :: bond_r0 = 0.0_dp - real(dp) :: angle_cos0 = 0.0_dp -end type IPModel_ConfiningMonomer - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_ConfiningMonomer), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_ConfiningMonomer_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_ConfiningMonomer_Finalise -end interface Finalise - -interface Print - module procedure IPModel_ConfiningMonomer_Print -end interface Print - -interface Calc - module procedure IPModel_ConfiningMonomer_Calc -end interface Calc - -contains - -subroutine IPModel_ConfiningMonomer_Initialise_str(this, args_str, param_str, error) - type(IPModel_ConfiningMonomer), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out):: error - - - INIT_ERROR(error) - call Finalise(this) - - call initialise(params) - call param_register(params, 'kbond', '0.0', this%kbond, help_string='Strength of quadratic restraint on C-H bonds. Potential is kconf*(r-r0)^2') - call param_register(params, 'kangle', '0.0', this%kangle, help_string='Strength of quadratic restraint on H-C-H cosines. Potential is kconf*(cos(theta)-cos(theta0))^2') - call param_register(params, 'bond_r0', '0.0', this%bond_r0, help_string='Equilibrium bond length for C-H bonds.') - call param_register(params, 'angle_cos0', '0.0', this%angle_cos0, help_string='Cosine of equilibrium bond angle for H-C-H triplets.') - call param_register(params, 'cutoff', '0.0', this%cutoff, help_string='Cutoff for finding methane monomers') - if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_ConfiningMonomer_Initialise args_str')) then - RAISE_ERROR("IPModel_ConfiningMonomer_Init failed to parse args_str='"//trim(args_str)//"'", error) - end if - call finalise(params) - -end subroutine IPModel_ConfiningMonomer_Initialise_str - -subroutine IPModel_ConfiningMonomer_Finalise(this) - type(IPModel_ConfiningMonomer), intent(inout) :: this - - ! Add finalisation code here - -end subroutine IPModel_ConfiningMonomer_Finalise - - -subroutine IPModel_ConfiningMonomer_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_ConfiningMonomer), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - ! Add calc() code here - - ! Confining potential for methanes - first find general monomers, then place - ! harmonic restraints on bonds and angles. - - integer, dimension(:,:), allocatable :: monomer_index - logical, dimension(:), allocatable :: is_associated - real(dp) :: energy, force(3,at%N) - - type(Dictionary) :: params - character(STRING_LENGTH) :: atom_mask_name, pers_idces_name - logical :: has_atom_mask_name, has_pers_idces_name - logical, dimension(:), pointer :: atom_mask_pointer - integer, dimension(:), pointer :: pers_idces_pointer - logical :: called_from_lammps - - integer :: mon_i, i_atomic, atom_i, rank_j, atom_j, rank_k, atom_k - real(dp) :: e_pair, d_epair_dr, rij(3), rik(3), rij_mag, rik_mag, rij_norm(3), rik_norm(3) - real(dp) :: e_trip, d_etrip_dcos, cos_ijk, fij(3), fik(3) - real(dp) :: virial_i(3,3), virial_j(3,3), virial_k(3,3) - - - INIT_ERROR(error) - - if(present(args_str)) then - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For monomers where this property is true the Potential is " // & - "calculated.") - - call param_register(params, 'lammps', 'F', called_from_lammps, help_string="Should be true if this potential is called from LAMMPS") - - call param_register(params, 'pers_idces_name', 'NONE', pers_idces_name, has_value_target=has_pers_idces_name, & - help_string="Name of an integer property in the atoms object containing the original LAMMPS atom ids (only needed if & - called from lammps)") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='general_dimer_calc args_str')) then - RAISE_ERROR("IPModel_ConfiningMonomer_Calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then - RAISE_ERROR("IPModel_ConfiningMonomer_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - - if( called_from_lammps ) then - if (.not. has_pers_idces_name) then - RAISE_ERROR("IPModel_ConfiningMonomer_Calc needs persistent indices if working with lammps.", error) - endif - if (.not. assign_pointer(at, trim(pers_idces_name), pers_idces_pointer)) then - RAISE_ERROR("IPModel_ConfiningMonomer_Calc did not find "//trim(pers_idces_name)//" property in the atoms object.", error) - endif - endif - else - called_from_lammps = .false. - atom_mask_pointer => null() - endif - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_ConfiningMonomer_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_ConfiningMonomer_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_ConfiningMonomer_Calc', error) - local_virial = 0.0_dp - endif - - allocate(is_associated(at%N)) - is_associated = .false. - if (called_from_lammps) then - call shuffle(at, pers_idces_pointer, error) - endif - call find_general_monomer(at, monomer_index, (/6, 1, 1, 1, 1/), is_associated, this%cutoff, general_ordercheck=.false., error=error) - - call print("Found " // size(monomer_index, 2) // " monomers", PRINT_VERBOSE) - if(.not. all(is_associated)) then - call print("WARNING: IP ConfiningMonomer: not all atoms assigned to a methane monomer. If you have partial monomers this is OK.", PRINT_VERBOSE) - end if - - ! First, loop over monomers. These are also the centres of angle triplets. - do mon_i = 1, size(monomer_index, 2) - ! Copied from IPModel_SW.f95 -- let's hope this works. - if (present(mpi)) then - if (mpi%active) then - if (mod(mon_i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - atom_i = monomer_index(1, mon_i) - ! Only evaluate the monomer if the central C atom is local - should check - ! how lammps accounts for forces on non-local atoms - if (associated(atom_mask_pointer)) then - if (.not. atom_mask_pointer(atom_i)) cycle - end if - - call print("Atom " // atom_i // " has " // n_neighbours(at, atom_i, max_dist=this%cutoff) // " neighbours", PRINT_VERBOSE) - do rank_j = 1, n_neighbours(at, atom_i) - atom_j = neighbour(at, atom_i, rank_j, distance=rij_mag, diff=rij, cosines=rij_norm, max_dist=this%cutoff) - if (atom_j .eq. 0) cycle ! Neighbour outside of cutoff - if (rij_mag .feq. 0.0_dp) cycle ! Somehow got self - ! This really shouldn't happen in any normal cases, but account for it anyways - if (.not. (any(monomer_index(2:5, mon_i) .eq. atom_j))) then - call print("WARNING: Stray neighbour " // atom_j // ", rank " // rank_j // ", of atom " // atom_i // " detected!", PRINT_VERBOSE) - cycle - end if - - ! Pairwise forces and energies - e_pair = this%kbond * (rij_mag - this%bond_r0)**2 - d_epair_dr = 2.0_dp * this%kbond * (rij_mag - this%bond_r0) - - if (present(e)) e = e + e_pair - if (present(local_e)) then - ! Eh, let's just concentrate all the 'local' quantities on the monomer centres. - local_e(atom_i) = local_e(atom_i) + e_pair - end if - if (present(f)) then - f(:, atom_j) = f(:, atom_j) - 1.0_dp * d_epair_dr * rij_norm - f(:, atom_i) = f(:, atom_i) + 1.0_dp * d_epair_dr * rij_norm - end if - if (present(virial) .or. present(local_virial)) then - virial_i = -1.0 * d_epair_dr * rij_mag * (rij_norm .outer. rij_norm) - end if - if (present(virial)) virial = virial + virial_i - if (present(local_virial)) then - local_virial(:, atom_i) = local_virial(:, atom_i) + reshape(virial_i, (/9/)) - end if - - do rank_k = 1, n_neighbours(at, atom_i) - atom_k = neighbour(at, atom_i, rank_k, distance=rik_mag, diff=rik, cosines=rik_norm, max_dist=this%cutoff) - if (atom_k .eq. 0) cycle - ! Again, shouldn't happen, but better to be safe - if (.not. (any(monomer_index(2:5, mon_i) .eq. atom_k))) cycle - if (atom_k <= atom_j) cycle - - cos_ijk = sum(rij_norm*rik_norm) - e_trip = this%kangle * (cos_ijk - this%angle_cos0)**2 - d_etrip_dcos = 2.0_dp * this%kangle * (cos_ijk - this%angle_cos0) - if (present(e)) e = e + e_trip - if (present(local_e)) then - ! Hm, the triplet local quantities can be assigned to the outer atoms - local_e(atom_j) = local_e(atom_j) + 0.5_dp * e_trip - local_e(atom_k) = local_e(atom_k) + 0.5_dp * e_trip - end if - if (present(f) .or. present(virial) .or. present(local_virial)) then - ! Apparently these need to have the opposite sign from what I - ! originally thought - isn't it f_i = -grad_i(e) though? - fij = 1.0_dp * d_etrip_dcos * (rik_norm - rij_norm*cos_ijk) / rij_mag - fik = 1.0_dp * d_etrip_dcos * (rij_norm - rik_norm*cos_ijk) / rik_mag - end if - if (present(f)) then - f(:, atom_i) = f(:, atom_i) + fij + fik - f(:, atom_j) = f(:, atom_j) - fij - f(:, atom_k) = f(:, atom_k) - fik - end if - if (present(virial) .or. present(local_virial)) then - ! TODO check these signs - virial_j = -1.0_dp * d_etrip_dcos * ((rik_norm .outer. rij_norm) - (rij_norm .outer. rij_norm)*cos_ijk) - virial_k = -1.0_dp * d_etrip_dcos * ((rij_norm .outer. rik_norm) - (rik_norm .outer. rik_norm)*cos_ijk) - end if - if (present(virial)) virial = virial + virial_j + virial_k - if (present(local_virial)) then - local_virial(:, atom_i) = local_virial(:, atom_i) + reshape(virial_j, (/9/)) + reshape(virial_k, (/9/)) - end if - end do - end do - end do - - ! Copied from IPModel_SW.xml - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) call sum_in_place(mpi, f) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(local_virial)) call sum_in_place(mpi, local_virial) - endif - - deallocate(monomer_index) - deallocate(is_associated) - -end subroutine IPModel_ConfiningMonomer_Calc - - -subroutine IPModel_ConfiningMonomer_Print(this, file) - type(IPModel_ConfiningMonomer), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_ConfiningMonomer : ConfiningMonomer Potential", file=file) - call Print("IPModel_ConfiningMonomer : cutoff = " // this%cutoff, file=file) - call Print("IPModel_ConfiningMonomer : kbond = " // this%kbond, file=file) - call Print("IPModel_ConfiningMonomer : kangle = " // this%kangle, file=file) - call Print("IPModel_ConfiningMonomer : bond_r0 = " // this%bond_r0, file=file) - call Print("IPModel_ConfiningMonomer : angle_cos0 = " // this%angle_cos0, file=file) - -end subroutine IPModel_ConfiningMonomer_Print - - -end module IPModel_ConfiningMonomer_module diff --git a/src/Potentials/IPModel_Coulomb.f95 b/src/Potentials/IPModel_Coulomb.f95 deleted file mode 100644 index c3509a2cff..0000000000 --- a/src/Potentials/IPModel_Coulomb.f95 +++ /dev/null @@ -1,563 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X IPModel_Coulomb -!X -!% Coulomb module. Calculates electrostatic interactions between charged -!% species. Supported methods: -!% Direct: the $1/r$ potential -!% Yukawa: Yukawa-screened electrostatic interactions -!% Ewald: Ewald summation technique -!% DSF: Damped Shifted Force Coulomb potential. The interaction is damped by the -!% error function and the potential is force-shifted so both the potential and its -!% derivative goes smoothly to zero at the cutoff. Reference: JCP, 124, 234104 (2006) -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module IPModel_Coulomb_module - -use error_module -use system_module, only : dp, inoutput, print, lower_case, verbosity_push_decrement, verbosity_pop, operator(//), split_string, string_to_int -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use units_module - -use mpi_context_module -use QUIP_Common_module - -use Yukawa_module -use IPEwald_module -use Ewald_module - - -implicit none -private - -include 'IPModel_interface.h' - -integer, parameter :: IPCoulomb_Method_Direct = 1 -integer, parameter :: IPCoulomb_Method_Yukawa = 2 -integer, parameter :: IPCoulomb_Method_Ewald = 3 -integer, parameter :: IPCoulomb_Method_DSF = 4 -integer, parameter :: IPCoulomb_Method_Ewald_NB = 5 - -public :: IPModel_Coulomb -type IPModel_Coulomb - - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - real(dp), dimension(:), allocatable :: charge - integer :: method = 0 - integer :: damping = 0 - integer :: screening = 0 - - real(dp) :: cutoff = 0.0_dp - - real(dp) :: yukawa_alpha = 0.0_dp - real(dp) :: yukawa_smooth_length = 0.0_dp - real(dp) :: yukawa_grid_size = 0.0_dp - logical :: yukawa_pseudise = .false. - - real(dp) :: ewald_error - real(dp) :: smooth_coulomb_cutoff - - real(dp) :: dsf_alpha = 0.0_dp - - character(len=STRING_LENGTH) :: label - - -endtype IPModel_Coulomb - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Coulomb), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Coulomb_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Coulomb_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Coulomb_Print -end interface Print - -interface Calc - module procedure IPModel_Coulomb_Calc -end interface Calc - -contains - -subroutine IPModel_Coulomb_Initialise_str(this, args_str, param_str) - type(IPModel_Coulomb), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - character(len=STRING_LENGTH) :: method_str - logical :: has_method - - call Finalise(this) - call initialise(params) - this%label='' - method_str='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'method', '', method_str, help_string="If present, method for Coulomb calculation. Will be overridden & - by xml parameters if present", has_value_target=has_method) - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Coulomb_Initialise_str args_str')) then - call system_abort("IPModel_Coulomb_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Coulomb_read_params_xml(this, param_str) - - if(this%method == 0) then - if(has_method) then - this%method = IPModel_Coulomb_get_method(method_str) - else - call system_abort("IPModel_Coulomb_Initialise_str: no method specified either in XML or arguments") - endif - endif - - - ! Add initialisation code here - -end subroutine IPModel_Coulomb_Initialise_str - -function IPModel_Coulomb_get_method(this) - character(len=*), intent(in) :: this - integer :: IPModel_Coulomb_get_method - - select case(lower_case(trim(this))) - case("direct") - IPModel_Coulomb_get_method = IPCoulomb_Method_Direct - case("yukawa") - IPModel_Coulomb_get_method = IPCoulomb_Method_Yukawa - case("ewald") - IPModel_Coulomb_get_method = IPCoulomb_Method_Ewald - case("ewald_nb") - IPModel_Coulomb_get_method = IPCoulomb_Method_Ewald_NB - case("dsf") - IPModel_Coulomb_get_method = IPCoulomb_Method_DSF - case default - call system_abort ("IPModel_Coulomb_get_method: method "//trim(this)//" unknown") - end select - -endfunction IPModel_Coulomb_get_method - -subroutine IPModel_Coulomb_Finalise(this) - type(IPModel_Coulomb), intent(inout) :: this - - ! Add finalisation code here - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%charge)) deallocate(this%charge) - - this%n_types = 0 - this%label = '' - this%cutoff = 0.0_dp - this%method = 0 - -end subroutine IPModel_Coulomb_Finalise - -recursive subroutine IPModel_Coulomb_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Coulomb), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - real(dp), dimension(:), allocatable, target :: my_charge - real(dp), dimension(:), pointer :: charge - real(dp), dimension(:,:), allocatable :: dummy_force - real(dp) :: r_scale, E_scale, e_pre_calc - logical :: do_rescale_r, do_rescale_E, do_pairwise_by_Z,do_e, do_f - - real(dp), pointer :: local_e_by_Z(:,:), local_e_contrib(:) - integer, allocatable :: Z_s(:), Z_u(:) - integer :: n_uniq_Zs - - - real(dp), allocatable :: gamma_mat(:,:) - - integer :: i, i_Z - - character(len=STRING_LENGTH) :: charge_property_name, atom_mask_name, source_mask_name - - INIT_ERROR(error) - do_f=present(f) - do_e=present(e) - - if (do_e) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Coulomb_Calc', error) - local_e = 0.0_dp - endif - if (do_f) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Coulomb_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Coulomb_Calc', error) - local_virial = 0.0_dp - endif - - if (present(args_str)) then - call initialise(params) - call param_register(params, 'charge_property_name', 'charge', charge_property_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'atom_mask_name', '', atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'source_mask_name', '', source_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.") - call param_register(params, 'pairwise_by_Z', 'F',do_pairwise_by_Z, help_string="If true, calculate pairwise contributions to local_e broken down by Z") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Coulomb_Calc args_str')) then - RAISE_ERROR("IPModel_Coulomb_Calc failed to parse args_str="//trim(args_str), error) - endif - call finalise(params) - if (do_rescale_r ) then - RAISE_ERROR("IPModel_Coulomb_Calc: rescaling of potential with r_scale not yet implemented!", error) - end if - else - charge_property_name = 'charge' - endif - - if(has_property(at,charge_property_name)) then - if(.not. assign_pointer(at, charge_property_name, charge)) then - RAISE_ERROR('IPModel_Coulomb_Calc failed to assign pointer to '//trim(charge_property_name)//' property', error) - endif - else - allocate(my_charge(at%N)) - charge => my_charge - charge = 0.0_dp - do i = 1, at%N - charge(i) = this%charge(this%type_of_atomic_num(at%Z(i))) - enddo - endif - - - selectcase(this%method) - case(IPCoulomb_Method_Direct) - call Direct_Coulomb_calc(at, charge, e=e, f=f, virial=virial, error = error) - case(IPCoulomb_Method_Yukawa) - call yukawa_charges(at, charge, this%cutoff, this%yukawa_alpha, this%yukawa_smooth_length, & - e, local_e, f, virial, & - mpi=mpi, atom_mask_name=atom_mask_name, source_mask_name=source_mask_name, type_of_atomic_num=this%type_of_atomic_num, & - pseudise=this%yukawa_pseudise, grid_size=this%yukawa_grid_size, error=error) - case(IPCoulomb_Method_Ewald) - call Ewald_calc(at, charge, e, f, virial, ewald_error=this%ewald_error, use_ewald_cutoff=.false., smooth_coulomb_cutoff=this%smooth_coulomb_cutoff, error=error) - case(IPCoulomb_Method_Ewald_NB) - if (present(f) .or. present(virial) .or. present(local_virial)) then - RAISE_ERROR("IPModel_Coulomb_Calc: method ewald_nb doesn't have F or V implemented yet", error) - endif - allocate(gamma_mat(at%n,at%n)) - gamma_mat = 0.0_dp - call add_madelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, gamma_mat, redo_lattice=.true.) -call print("gamma_mat") -call print(gamma_mat) - if (present(e)) e = 0.5_dp*sum(charge*matmul(gamma_mat, charge)) - if (present(local_e)) local_e = 0.5_dp*charge*matmul(gamma_mat, charge) - if (do_pairwise_by_Z) then - allocate(Z_s(at%n)) - Z_s = at%Z - call sort_array(Z_s) - call uniq(Z_s, Z_u) - deallocate(Z_s) - -call print("local_pot "//matmul(gamma_mat, charge)) - - n_uniq_Zs = size(Z_u) - if (has_property(at, "local_e_pairwise_by_Z")) call remove_property(at, "local_e_pairwise_by_Z") - call add_property(at, "local_e_pairwise_by_Z", 0.0_dp, n_cols=n_uniq_Zs, ptr2 = local_e_by_Z) - allocate(local_e_contrib(at%N)) - do i=1, at%N - local_e_contrib = 0.5_dp * gamma_mat(i,:) * charge(:) * charge(i) -call print("local_e_contrib "//i //" "//local_e_contrib) - do i_Z = 1, n_uniq_Zs - local_e_by_Z(i_Z,i) = sum(local_e_contrib, mask=(at%Z == Z_u(i_Z))) - end do - end do - deallocate(local_e_contrib) - - endif - deallocate(gamma_mat) - case(IPCoulomb_Method_DSF) - call DSF_Coulomb_calc(at, charge, this%DSF_alpha, e=e, local_e=local_e, f=f, virial=virial, cutoff=this%cutoff, error = error) - case default - RAISE_ERROR("IPModel_Coulomb_Calc: unknown method", error) - endselect - - - charge => null() - if(allocated(my_charge)) deallocate(my_charge) - - if (do_rescale_E) then - if (present(e)) e = e*E_scale - if (present(local_e)) local_e = local_e*E_scale - if (present(f)) f = f*E_scale - if (present(virial)) virial=virial*E_scale - if (present(local_virial)) local_virial=local_virial*E_scale - end if - -end subroutine IPModel_Coulomb_Calc - - -subroutine IPModel_Coulomb_Print(this, file) - type(IPModel_Coulomb), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti , tj - - call Print("IPModel_Coulomb : Coulomb Potential", file=file) - select case(this%method) - case(IPCoulomb_Method_Direct) - call Print("IPModel_Coulomb method: Direct") - case(IPCoulomb_Method_Yukawa) - call Print("IPModel_Coulomb method: Yukawa") - case(IPCoulomb_Method_Ewald) - call Print("IPModel_Coulomb method: Ewald") - case(IPCoulomb_Method_Ewald_NB) - call Print("IPModel_Coulomb method: Ewald_NB") - case(IPCoulomb_Method_DSF) - call Print("IPModel_Coulomb method: Damped Shifted Force Coulomb") - case default - call system_abort ("IPModel_Coulomb: method identifier "//this%method//" unknown") - endselect - - call Print("IPModel_Coulomb : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_Coulomb : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_Coulomb : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_Coulomb_Print - -subroutine IPModel_Coulomb_read_params_xml(this, param_str) - type(IPModel_Coulomb), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0 ) then - call system_abort("IPModel_Coulomb_read_params_xml parsed file, but n_types = 0 ") - endif - -end subroutine IPModel_Coulomb_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - - character(len=STRING_LENGTH) :: value, signature_string, pos_type_str - character(len=STRING_LENGTH), dimension(99) :: signature_fields - - logical :: energy_shift, linear_force_shift - integer :: ti, tj, i ,n_atoms - real(dp) :: alpha_au - - if (name == 'Coulomb_params') then ! new Coulomb stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (trim(value) == trim(parse_ip%label)) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'method', value, status) - if (status == 0) then - parse_ip%method = IPModel_Coulomb_get_method(value) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in Coulomb_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - allocate(parse_ip%charge(parse_ip%n_types)) - parse_ip%charge = 0.0_dp - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_Coulomb_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - - - call QUIP_FoX_get_value(attributes, "yukawa_alpha", value, status) - if (status /= 0) then - if( parse_ip%method == IPCoulomb_Method_Yukawa ) call system_abort("IPModel_Coulomb_read_params_xml: Yukawa method requested but no yukawa_alpha parameter found.") - else - read (value, *) parse_ip%yukawa_alpha - endif - - call QUIP_FoX_get_value(attributes, "yukawa_smooth_length", value, status) - if (status == 0) then - read (value, *) parse_ip%yukawa_smooth_length - else - parse_ip%yukawa_smooth_length = 0.0_dp - endif - - call QUIP_FoX_get_value(attributes, "yukawa_pseudise", value, status) - if (status == 0) then - read (value, *) parse_ip%yukawa_pseudise - else - parse_ip%yukawa_pseudise = .false. - endif - - call QUIP_FoX_get_value(attributes, "yukawa_grid_size", value, status) - if (status == 0) then - read (value, *) parse_ip%yukawa_grid_size - else - parse_ip%yukawa_grid_size = 0.0_dp - endif - - call QUIP_FoX_get_value(attributes, "ewald_error", value, status) - if (status == 0) then - read (value, *) parse_ip%ewald_error - else - parse_ip%ewald_error = 1.0e-6_dp - endif - - call QUIP_FoX_get_value(attributes, "smooth_coulomb_cutoff", value, status) - if (status == 0) then - read (value, *) parse_ip%smooth_coulomb_cutoff - else - parse_ip%smooth_coulomb_cutoff = 0.0_dp - endif - - call QUIP_FoX_get_value(attributes, "dsf_alpha", value, status) - if (status /= 0) then - if( parse_ip%method == IPCoulomb_Method_DSF ) call system_abort("IPModel_Coulomb_read_params_xml: Damped Shifted Force method requested but no dsf_alpha parameter found.") - else - read (value, *) parse_ip%dsf_alpha - endif - - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Coulomb_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Coulomb_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - call QUIP_FoX_get_value(attributes, "charge", value, status) - if (status /= 0) call system_abort ("IPModel_Coulomb_read_params_xml cannot find charge") - read (value, *) parse_ip%charge(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - endif - - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Coulomb_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_Coulomb_module diff --git a/src/Potentials/IPModel_Custom.f95 b/src/Potentials/IPModel_Custom.f95 deleted file mode 100644 index 88ce669335..0000000000 --- a/src/Potentials/IPModel_Custom.f95 +++ /dev/null @@ -1,192 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Custom -!X -!% Customised interatomic potential: -!% -!% Energy and Force routines are hardwired -!% Cutoff is hardwired -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Custom_module - -use error_module -use system_module, only : dp, inoutput, print, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Custom -type IPModel_Custom - real(dp) :: cutoff = 0.0_dp - real(dp) :: kconf = 0.0_dp -end type IPModel_Custom - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Custom), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Custom_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Custom_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Custom_Print -end interface Print - -interface Calc - module procedure IPModel_Custom_Calc -end interface Calc - -contains - -subroutine IPModel_Custom_Initialise_str(this, args_str, param_str, error) - type(IPModel_Custom), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out):: error - - - INIT_ERROR(error) - call Finalise(this) - - call initialise(params) - call param_register(params, 'kconf', '0.0', this%kconf, help_string='strength of quadratic confinement potential on O atoms. potential is kconf*(rO)^2') - if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_Custom_Initialise args_str')) then - RAISE_ERROR("IPModel_Custom_Init failed to parse args_str='"//trim(args_str)//"'", error) - end if - call finalise(params) - -end subroutine IPModel_Custom_Initialise_str - -subroutine IPModel_Custom_Finalise(this) - type(IPModel_Custom), intent(inout) :: this - - ! Add finalisation code here - -end subroutine IPModel_Custom_Finalise - - -subroutine IPModel_Custom_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Custom), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - ! Add calc() code here - - - real(dp) :: energy, force(3,at%N) - real(dp) :: rO1, rO2, drO1(3), drO2(3) - - INIT_ERROR(error) - - ! Harmonic confining potential on Os - - rO1 = distance_min_image(at, 1, (/0.0_dp, 0.0_dp, 0.0_dp/)) - rO2 = distance_min_image(at, 4, (/0.0_dp, 0.0_dp, 0.0_dp/)) - - - energy = this%kConf*rO1**2 + this%kConf*rO2**2 - - !Forces - - force = 0.0_dp - - if(rO1 .feq. 0.0_dp) then - drO1 = 0.0_dp - else - drO1 = diff_min_image(at, 1, (/0.0_dp, 0.0_dp, 0.0_dp/))/rO1 - end if - - if(rO2 .feq. 0.0_dp) then - drO2 = 0.0_dp - else - drO2 = diff_min_image(at, 4, (/0.0_dp, 0.0_dp, 0.0_dp/))/rO2 - end if - - force(:,1) = 2.0_dp*this%kConf*rO1*drO1 - force(:,4) = 2.0_dp*this%kConf*rO2*drO2 - - - if (present(e)) e = energy - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Custom_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Custom_Calc', error) - f = force - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Custom_Calc', error) - local_virial = 0.0_dp - endif - - -end subroutine IPModel_Custom_Calc - - -subroutine IPModel_Custom_Print(this, file) - type(IPModel_Custom), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_Custom : Custom Potential", file=file) - call Print("IPModel_Custom : cutoff = " // this%cutoff, file=file) - call Print("IPModel_Custom : kconf = " // this%kconf, file=file) - -end subroutine IPModel_Custom_Print - - -end module IPModel_Custom_module diff --git a/src/Potentials/IPModel_DispTS.f95 b/src/Potentials/IPModel_DispTS.f95 deleted file mode 100644 index 9684b7155e..0000000000 --- a/src/Potentials/IPModel_DispTS.f95 +++ /dev/null @@ -1,647 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2017. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_DispTS -!X -!% Pairwise dispersion correction from Tkatchenko and Scheffler, -!% PRL 102(7) 073005 (2009). -!% -!% Free-atom reference data must be supplied in the XML file; Hirshfeld volumes -!% must be supplied in the Atoms object. -!% -!% Free-atom reference data is available e.g. from Chu and Dalgarno, -!% JCP 121, 4083 (2004) (used in original implementation) or from -!% Gould and BuÄko, JCTC 12(8), 3603 (2016) (better coverage) -!% -!% Tail corrections for the energy and virial are available for -!% this potential. Doing them properly, however, requires -!% an integral over the smooth cutoff function; this involves the -!% the special Ci and Si functions (sine and cosine integrals). -!% Those are not yet implemented here, so instead this potential -!% asks for a precomputed constant that depends only on the cutoff -!% and transition width: -!% \[ -!% I = -\frac{2}{3} \pi (r_{in}^{-3} - 3 \int_{r_{in}}^{r_{out}} r^{-4} S(r) dr) -!% \] -!% where r_{out} is this potential's cutoff, r_{in} is the cutoff -!% minus the cutoff_transition_width, and S(r) is the switching -!% function that goes smoothly from 1 at r_{in} to 0 at r_{out}. -!% In this potential, S(r) is the first half of a cosine (shifted -!% and scaled). -!% -!% To use tail corrections, compute this integral using any -!% method you like and supply it ($I$) as 'tail_correction_const' -!% in the parameter file or on the command line (or use an existing -!% parameter file that already has it). Alternatively, supply a -!% factor $\lambda$ (called 'tail_corr_factor') between 0 and 1 where: -!% \[ -!% \lambda = \frac{-3 \int_{r_{in}}^{r_{out}} r^{-4} S(r) dr}{r_{out}^{-3} - r_{in}^{-3}} -!% \] -!% which may be more intuitive as the fraction of "missing" energy -!% within the transition region. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_DispTS_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_NERD, verbosity_push_decrement, verbosity_pop, operator(//) -use units_module, only : GPA_TO_EV_A3, PI -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_DispTS -type IPModel_DispTS - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - real(dp), allocatable :: c6_free(:), alpha_free(:), r_vdW_free(:) - logical :: only_inter_resid = .false. - logical :: do_tail_corrections = .true. - - real(dp) :: cutoff = 0.0_dp - real(dp) :: cutoff_transition_width = 0.5_dp - - real(dp) :: tail_corr_smooth_factor = 0.0_dp - real(dp) :: tail_correction_const = 0.0_dp - - ! Constants for now... - real(dp) :: damp_steepness = 20.0_dp - real(dp) :: damp_scale = 0.94 !PBE - - character(len=STRING_LENGTH) :: label - -end type IPModel_DispTS - - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_DispTS), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_DispTS_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_DispTS_Finalise -end interface Finalise - -interface Print - module procedure IPModel_DispTS_Print -end interface Print - -interface Calc - module procedure IPModel_DispTS_Calc -end interface Calc - - -contains - - -subroutine IPModel_DispTS_Initialise_str(this, args_str, param_str) - type(IPModel_DispTS), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - logical :: use_smooth_factor - - call Finalise(this) - - call initialise(params) - this%label='' - use_smooth_factor = .false. - call param_register(params, 'label', '', this%label, help_string="Label to identify the potential") - call param_register(params, 'only_inter_resid', 'F', this%only_inter_resid, & - help_string="If True, only calculate interactions between atoms with different ResIDs (requires 'resid' property to be present)") - !call param_register(params, 'do_tail_corrections', this%do_tail_corrections, & - ! help_string="If True, apply long-range corrections to the energy and virial") - call param_register(params, 'tail_correction_const', '0.0', this%tail_correction_const, has_value_target=this%do_tail_corrections, & - help_string="Constant used to calculate tail corrections. Both the energy and virial corrections are equal to this value divided by the cell volume & - multiplied by the sum of all pairwise C6 coefficients. Units: Ang^-3.") - call param_register(params, 'tail_corr_factor', '0.0', this%tail_corr_smooth_factor, has_value_target=use_smooth_factor, & - help_string="Proportion of missing energy in the transition region; used to calculate tail corrections instead of 'tail_correction_const'.") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_DispTS_Initialise_str args_str')) then - call system_abort("IPModel_DispTS_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_DispTS_read_params_xml(this, param_str) - if (this%tail_corr_smooth_factor .fne. 0.0_dp) then - use_smooth_factor = .true. - endif - - if (use_smooth_factor) then - if (this%do_tail_corrections) then - call system_abort("IPModel_DispTS_Initialise_str: Supply only one of 'tail_corr_factor' or 'tail_correction_const'") - else - this%tail_correction_const = -2.0 * PI / 3.0 * & - ((1.0_dp - this%tail_corr_smooth_factor)/(this%cutoff - this%cutoff_transition_width)**3 + & - this%tail_corr_smooth_factor/this%cutoff**3) - this%do_tail_corrections = .true. - endif - endif - -end subroutine IPModel_DispTS_Initialise_str - - -subroutine IPModel_DispTS_Finalise(this) - type(IPModel_DispTS), intent(inout) :: this - - ! Add finalisation code here - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%c6_free)) deallocate(this%c6_free) - if (allocated(this%alpha_free)) deallocate(this%alpha_free) - if (allocated(this%r_vdW_free)) deallocate(this%r_vdW_free) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_DispTS_Finalise - - -subroutine IPModel_DispTS_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_DispTS), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - - character(len=*), optional :: args_str - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer, pointer, dimension(:) :: resid - real(dp), pointer, dimension(:) :: my_hirshfeld_volume - character(STRING_LENGTH) :: hirshfeld_vol_name - - integer :: i, j, d, ji, ti, tj - real(dp) :: dr(3), dr_mag, de, de_dr, vi, vj - real(dp) :: damp, dfdamp - real(dp) :: tail_correction, c6_sum - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_DispTS_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_DispTS_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_DispTS_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_DispTS_Calc: local_virial calculation requested but not supported yet.", error) - endif - - tail_correction = 0.0_dp - c6_sum = 0.0_dp - - if (this%only_inter_resid) then - if (.not. assign_pointer(at, "resid", resid)) then - RAISE_ERROR("IPModel_DispTS_Calc calculation with only_inter_resid=T requires resid field", error) - endif - end if - - if (present(args_str)) then - if (len_trim(args_str) > 0) then - call initialise(params) - call param_register(params, 'hirshfeld_vol_name', 'hirshfeld_rel_volume', hirshfeld_vol_name, & - help_string='Name of the Atoms property containing relative Hirshfeld volumes $v/v_{free}$') - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0', r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0', E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_MBD_Calc args_str')) then - RAISE_ERROR("IPModel_DispTS_Calc failed to parse args_str '"//trim(args_str)//"'", error) - endif - call finalise(params) - call assign_property_pointer(at, trim(hirshfeld_vol_name), my_hirshfeld_volume, error) - PASS_ERROR_WITH_INFO("IPModel_DispTS_Calc could not find '"//trim(hirshfeld_vol_name)//"' property in the Atoms object", error) - endif - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_LJ_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_LJ_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - else - call assign_property_pointer(at, 'hirshfeld_rel_volume', my_hirshfeld_volume, error) - PASS_ERROR_WITH_INFO("IPModel_DispTS_Calc could not find 'hirshfeld_rel_volume' property in the Atoms object", error) - endif - - ! Adapted from IPModel_LJ.f95 as a general pair potential - do i = 1, at%N - - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - vi = my_hirshfeld_volume(i) - - if (this%do_tail_corrections) then - do j = 1, at%n - if (i == j) cycle - if (this%only_inter_resid) then - if (resid(i) == resid(j)) cycle - endif - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - vj = my_hirshfeld_volume(j) - c6_sum = c6_sum + IPModel_DispTS_pair_c6(this, ti, tj, vi, vj) - enddo - endif - - do ji = 1, n_neighbours(at, i) - j = neighbour(at, i, ji, dr_mag, cosines = dr) - - if (dr_mag .feq. 0.0_dp) cycle - if ((i < j)) cycle - - if (this%only_inter_resid) then - if (resid(i) == resid(j)) cycle - endif - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - vj = my_hirshfeld_volume(j) - - damp = 0.0_dp - dfdamp = 0.0_dp - if (present(f) .or. present(virial)) then - call IPModel_DispTS_fdamp(this, ti, tj, vi, vj, dr_mag, damp, dfdamp) - else if (present(e) .or. present(local_e)) then - call IPModel_DispTS_fdamp(this, ti, tj, vi, vj, dr_mag, damp) - endif - - if (present(e) .or. present(local_e)) then - de = IPModel_DispTS_pairenergy(this, ti, tj, vi, vj, dr_mag, damp) - - if (present(local_e)) then - local_e(i) = local_e(i) + 0.5_dp*de - if(i/=j) local_e(j) = local_e(j) + 0.5_dp*de - endif - if (present(e)) then - if(i==j) then - e = e + 0.5_dp*de - else - e = e + de - endif - endif - endif - if (present(f) .or. present(virial)) then - de_dr = IPModel_DispTS_pairenergy_deriv(this, ti, tj, vi, vj, dr_mag, damp, dfdamp) - if (present(f)) then - f(:,i) = f(:,i) + de_dr*dr - if(i/=j) f(:,j) = f(:,j) - de_dr*dr - endif - if (present(virial)) then - if(i==j) then - virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*dr_mag - else - virial = virial - de_dr*(dr .outer. dr)*dr_mag - endif - endif - endif - end do - end do - - if (this%do_tail_corrections) then - tail_correction = c6_sum * this%tail_correction_const / cell_volume(at) - if (present(e)) e = e + tail_correction - if (present(virial)) then - do d = 1, 3 - virial(d, d) = virial(d, d) + tail_correction - enddo - endif - ! Already taken care of in energy and virial sums - !if (present(mpi)) then - ! tail_correction = sum(mpi, tail_correction) - !endif - call print("Energy tail correction: " // tail_correction // " eV", PRINT_NERD) - call print("Pressure tail correction: " // (tail_correction / cell_volume(at) / GPA_TO_EV_A3) // " GPa", PRINT_NERD) - endif - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(f)) call sum_in_place(mpi, f) - endif - -end subroutine IPModel_DispTS_Calc - - -subroutine IPModel_DispTS_fdamp(this, ti, tj, vi, vj, r, damp, dfdamp) - type(IPModel_DispTS), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r, vi, vj ! Pair distance and relative Hirshfeld volumes - real(dp), intent(out), optional :: damp - real(dp), intent(out), optional :: dfdamp - - real(dp) :: rfree ! Inner cutoff distance - - rfree = this%r_vdW_free(ti)*vi**(1/3.0_dp) + this%r_vdW_free(tj)*vj**(1/3.0_dp) - if (present(damp)) then - damp = 1.0_dp / (1.0_dp + exp(-1.0_dp * this%damp_steepness * (r/rfree/this%damp_scale - 1.0_dp))) - endif - if (present(dfdamp)) then - dfdamp = this%damp_steepness / (2.0_dp * this%damp_scale * rfree) & - / (cosh(this%damp_steepness * (r/rfree/this%damp_scale - 1.0_dp)) + 1.0_dp) - endif - -end subroutine IPModel_DispTS_fdamp - - -function IPModel_DispTS_pair_c6(this, ti, tj, vi, vj) - type(IPModel_DispTS), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: vi, vj ! relative Hirshfeld volumes - real(dp) :: IPModel_DispTS_pair_c6 - - real(dp) :: c6, c6i, c6j ! VdW R^-6 coefficients - real(dp) :: alphai, alphaj - - c6i = this%c6_free(ti) * vi**2 - c6j = this%c6_free(tj) * vj**2 - alphai = this%alpha_free(ti) * vi - alphaj = this%alpha_free(tj) * vj - c6 = 2*c6i*c6j / (alphai/alphaj * c6j + alphaj/alphai * c6i) - IPModel_DispTS_pair_c6 = c6 - -end function IPModel_DispTS_pair_c6 - - -function IPModel_DispTS_pairenergy(this, ti, tj, vi, vj, r, damp) - type(IPModel_DispTS), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r, vi, vj ! Pair distance and relative Hirshfeld volumes - real(dp), intent(in) :: damp ! Damping factor (precalculated) - real(dp) :: IPModel_DispTS_pairenergy - - real(dp) :: c6 ! VdW R^-6 coefficient - real(dp) :: cut ! Smooth cutoff function - - c6 = IPModel_DispTS_pair_c6(this, ti, tj, vi, vj) - cut = coordination_function(r, this%cutoff, this%cutoff_transition_width) - IPModel_DispTS_pairenergy = -1.0_dp * c6 * r**(-6) * damp * cut - -end function IPModel_DispTS_pairenergy - - -function IPModel_DispTS_pairenergy_deriv(this, ti, tj, vi, vj, r, damp, dfdamp) - type(IPModel_DispTS), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r, vi, vj ! Pair distance and relative Hirshfeld volumes - real(dp), intent(in) :: damp, dfdamp ! Damping function and derivative - real(dp) :: IPModel_DispTS_pairenergy_deriv - - real(dp) :: c6 ! VdW R^-6 coefficient - real(dp) :: cut, dcut ! Cutoff function and derivative - - c6 = IPModel_DispTS_pair_c6(this, ti, tj, vi, vj) - cut = coordination_function(r, this%cutoff, this%cutoff_transition_width) - dcut = dcoordination_function(r, this%cutoff, this%cutoff_transition_width) - - IPModel_DispTS_pairenergy_deriv = -1.0_dp * c6 * r**(-6) & - * (dfdamp*cut + damp*dcut - 6.0_dp/r * damp*cut) - -end function IPModel_DispTS_pairenergy_deriv - - -subroutine IPModel_DispTS_Print(this, file) - type(IPModel_DispTS), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_DispTS : T-S dispersion correction potential", file=file) - call Print("IPModel_DispTS : n_types = " // this%n_types // " cutoff = " // this%cutoff // & - " transition width = " // this%cutoff_transition_width, file=file) - - do ti=1, this%n_types - call Print("IPModel_DispTS : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call Print("IPModel_DispTS : type " // ti // " free-atom: C6 " // this%c6_free(ti) & - // " polarizability " // this%alpha_free(ti) & - // " vdW radius " // this%r_vdW_free(ti), file=file) - end do - if (this%do_tail_corrections) then - call Print("IPModel_DispTS : Tail corrections with integral constant " // & - this%tail_correction_const, file=file) - else - call Print("IPModel_DispTS : No tail corrections", file=file) - endif - -end subroutine IPModel_DispTS_Print - - -subroutine IPModel_DispTS_read_params_xml(this, param_str) - type(IPModel_DispTS), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_DispTS_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_DispTS_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - integer ti - - if (name == 'DispTS_params') then ! new DispTS stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in DispTS_params") - endif - - call QUIP_FoX_get_value(attributes, 'only_inter_resid', value, status) - if (status == 0) then - read (value, *) parse_ip%only_inter_resid - else - parse_ip%only_inter_resid = .false. - endif - call QUIP_FoX_get_value(attributes, 'tail_correction_const', value, status) - if (status == 0) then - read (value, *) parse_ip%tail_correction_const - parse_ip%do_tail_corrections = .true. - else - parse_ip%tail_correction_const = 0.0_dp - parse_ip%do_tail_corrections = .false. - endif - - call QUIP_FoX_get_value(attributes, 'tail_corr_factor', value, status) - if (status == 0) then - read (value, *) parse_ip%tail_corr_smooth_factor - else - parse_ip%tail_corr_smooth_factor = 0.0_dp - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - allocate(parse_ip%c6_free(parse_ip%n_types)) - allocate(parse_ip%alpha_free(parse_ip%n_types)) - allocate(parse_ip%r_vdW_free(parse_ip%n_types)) - parse_ip%atomic_num = 0 - parse_ip%c6_free = 0.0_dp - parse_ip%alpha_free = 0.0_dp - parse_ip%r_vdW_free = 0.0_dp - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - call QUIP_FoX_get_value(attributes, "cutoff_transition_width", value, status) - if (status == 0) then - read (value, *) parse_ip%cutoff_transition_width - endif - endif - - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - call QUIP_FoX_get_value(attributes, "c6_free", value, status) - if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find c6_free") - read (value, *) parse_ip%c6_free(ti) - - call QUIP_FoX_get_value(attributes, "alpha_free", value, status) - if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find alpha_free") - read (value, *) parse_ip%alpha_free(ti) - - call QUIP_FoX_get_value(attributes, "r_vdW_free", value, status) - if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find r_vdW_free") - read (value, *) parse_ip%r_vdW_free(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'DispTS_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_DispTS_module diff --git a/src/Potentials/IPModel_EAM_Ercolessi_Adams.f95 b/src/Potentials/IPModel_EAM_Ercolessi_Adams.f95 deleted file mode 100644 index bcc9769526..0000000000 --- a/src/Potentials/IPModel_EAM_Ercolessi_Adams.f95 +++ /dev/null @@ -1,814 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_EAM_ErcolAd module -!X -!% Module for the Embedded Atom Potential of Liu, Ercolessi, Adams. -!% (Ref. Liu, Ercolessi, Adams, {\it Modelling Simul. Mater. Sci. Eng.} {\bf 12}, 665-670, (2004)). -!% In this potential no analytic function is assumed for the actractive and repulsive terms. -!% Each function is described as a set of points, whose values are the IP parameters. -!% A cubic spline function is then used for interpolation between those points. -!% The 'IPModel_EAM_ErcolAd' object contains all the parameters (the grid points) -!% read from an 'EAM_ErcolAd_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_EAM_ErcolAd_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_VERBOSE, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use spline_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -#define PAIR -#define EMBED - -include 'IPModel_interface.h' - -public :: IPModel_EAM_ErcolAd -type IPModel_EAM_ErcolAd - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - - real(dp), allocatable :: r_min(:,:), r_cut(:,:) - real(dp), allocatable :: spline_V(:,:,:,:), spline_rho(:,:,:), spline_F(:,:,:) !% Cubic spline for interpolation between the mesh points. - - type(Spline), allocatable :: V(:,:),rho(:),F(:) - real(dp), allocatable :: V_F_shift(:) - - character(len=STRING_LENGTH) :: label - -end type IPModel_EAM_ErcolAd - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_EAM_ErcolAd), private, pointer :: parse_ip -integer :: parse_cur_type_i, parse_cur_type_j, parse_cur_point -logical :: parse_in_spline_V, parse_in_spline_rho, parse_in_spline_F - -interface Initialise - module procedure IPModel_EAM_ErcolAd_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_EAM_ErcolAd_Finalise -end interface Finalise - -interface Print - module procedure IPModel_EAM_ErcolAd_Print -end interface Print - -interface Calc - module procedure IPModel_EAM_ErcolAd_Calc -end interface Calc - -contains - -subroutine IPModel_EAM_ErcolAd_Initialise_str(this, args_str, param_str) - type(IPModel_EAM_ErcolAd), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_EAM_ErcolAd_Initialise_str args_str')) then - call system_abort("IPModel_EAM_ErcolAd_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_EAM_ErcolAd_read_params_xml(this, param_str) - -end subroutine IPModel_EAM_ErcolAd_Initialise_str - -subroutine IPModel_EAM_ErcolAd_Finalise(this) - type(IPModel_EAM_ErcolAd), intent(inout) :: this - - integer i, j - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%r_min)) deallocate(this%r_min) - if (allocated(this%r_cut)) deallocate(this%r_cut) - - if (allocated(this%spline_V)) deallocate(this%spline_V) - if (allocated(this%spline_rho)) deallocate(this%spline_rho) - if (allocated(this%spline_F)) deallocate(this%spline_F) - - if (allocated(this%rho)) then - do i=1,this%n_types - call Finalise(this%rho(i)) - end do - deallocate(this%rho) - endif - - if (allocated(this%F)) then - do i=1,this%n_types - call Finalise(this%F(i)) - end do - deallocate(this%F) - endif - - if (allocated(this%V)) then - do i=1,this%n_types - do j=1,this%n_types - call finalise(this%V(i,j)) - end do - end do - deallocate(this%V) - endif - - this%n_types = 0 - this%label = '' -end subroutine IPModel_EAM_ErcolAd_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator. It computes energy, forces and virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_EAM_ErcolAd_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_EAM_ErcolAd), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp) :: de, rho_i, drho_i_dri(3), drho_i_drj(3), drho_i_drij_outer_rij(3,3), w_f, V_r, rho_r - real(dp), pointer :: w_e(:) - integer :: i, ji, j, ti, tj - real(dp) :: r_ij_mag, r_ij_hat(3) - real(dp) :: F_n, dF_n, e_in - real(dp) :: spline_rho_d_val, spline_V_d_val, virial_factor(3,3), virial_i(3,3), virial_in(3,3) - real(dp), allocatable, dimension(:,:) :: f_in - - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) then - e = 0.0_dp - endif - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_EAM_ErcolAd_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_EAM_ErcolAd_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) then - virial = 0.0_dp - endif - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_EAM_ErcolAd_Calc', error) - local_virial = 0.0_dp - endif - - if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_EAM_ErcolAd_Calc args_str')) & - call system_abort("IPModel_EAM_ErcolAd_Calc failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_EAM_ErcolAd_Calc did not find "//trim(atom_mask_name)//" propery in the atoms object.") - else - atom_mask_pointer => null() - endif - else - do_rescale_r = .false. - do_rescale_E = .false. - endif - - if (do_rescale_r) call print('IPModel_Tersoff_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) - if (do_rescale_E) call print('IPModel_Tersoff_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) - - ! Has to be allocated because it is in the reduction clause - allocate(f_in(3,at%N)) - f_in = 0.0_dp - e_in = 0.0_dp - virial_in = 0.0_dp - -!$omp parallel do default(none) shared(this,at,mpi,atom_mask_pointer,do_rescale_r,r_scale,w_e,e,f,virial,local_e,local_virial) & -!$omp private(i,j,ti,tj,ji,w_f,rho_i,drho_i_dri,drho_i_drj,drho_i_drij_outer_rij,r_ij_mag,r_ij_hat,V_r,rho_r,de,virial_i) & -!$omp private(spline_rho_d_val,spline_V_d_val,F_n,dF_n,virial_factor) & -!$omp reduction(+:e_in,f_in,virial_in) - do i=1, at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - w_f = 1.0_dp - - rho_i = 0.0_dp - drho_i_dri = 0.0_dp - drho_i_drij_outer_rij = 0.0_dp - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, r_ij_mag, cosines = r_ij_hat) - if (r_ij_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) r_ij_mag = r_ij_mag*r_scale - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (associated(w_e)) w_f = 0.5_dp*(w_e(i)+w_e(j)) - - if (r_ij_mag < this%r_min(ti,tj)) cycle - if (r_ij_mag >= this%r_cut(ti,tj)) cycle - - V_r = eam_spline_V(this, ti, tj, r_ij_mag) - rho_r = eam_spline_rho(this, tj, r_ij_mag) - - V_r = V_r - 2.0_dp*this%V_F_shift(ti)*rho_r - - rho_i = rho_i + rho_r - - de = 0.5_dp*V_r -#ifdef PAIR - if (present(e)) e_in = e_in + de*w_f - if (present(local_e)) local_e(i) = local_e(i) + de -#endif - - if (present(f) .or. present(virial) .or. present(local_virial)) then - spline_rho_d_val = eam_spline_rho_d(this,tj,r_ij_mag) - spline_V_d_val = eam_spline_V_d(this,ti,tj,r_ij_mag) - spline_V_d_val = spline_V_d_val - 2.0_dp*this%V_F_shift(ti)*spline_rho_d_val - if (present(f)) then - drho_i_dri = drho_i_dri + spline_rho_d_val*r_ij_hat -#ifdef PAIR - f_in(:,i) = f_in(:,i) + 0.5_dp*w_f*spline_V_d_val*r_ij_hat - f_in(:,j) = f_in(:,j) - 0.5_dp*w_f*spline_V_d_val*r_ij_hat -#endif - endif - if (present(virial) .or. present(local_virial)) then - virial_factor = (r_ij_hat .outer. r_ij_hat)*r_ij_mag - drho_i_drij_outer_rij = drho_i_drij_outer_rij + spline_rho_d_val*virial_factor - virial_i = 0.5_dp * w_f*spline_V_d_val*virial_factor - endif -#ifdef PAIR - if (present(virial) ) virial_in = virial_in - virial_i - if (present(local_virial) ) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) -#endif - endif - - enddo ! ji - - if (associated(w_e)) w_f = w_e(i) - -#ifdef EMBED - if (present(e) .or. present(local_e)) then - F_n = eam_spline_F(this, ti, rho_i) - F_n = F_n + this%V_F_shift(ti)*rho_i - de = F_n - if (present(e)) e_in = e_in + de*w_f - if (present(local_e)) local_e(i) = local_e(i) + de - endif - - if (present(f) .or. present(virial) .or. present(local_virial)) then - dF_n = eam_spline_F_d(this, ti, rho_i) - dF_n = dF_n + this%V_F_shift(ti) - if (present(f)) f_in(:,i) = f_in(:,i) + w_f*dF_n*drho_i_dri - if (present(virial) .or. present(local_virial)) virial_i = w_f*dF_n*drho_i_drij_outer_rij - if (present(virial)) virial_in = virial_in - virial_i - if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) - - if (present(f)) then - ! cross terms for forces - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, r_ij_mag, cosines = r_ij_hat) - if (r_ij_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) r_ij_mag = r_ij_mag*r_scale - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - drho_i_drj = -eam_spline_rho_d(this, tj, r_ij_mag)*r_ij_hat - f_in(:,j) = f_in(:,j) + w_f*dF_n*drho_i_drj - end do - end if - - endif -#endif - - enddo ! i - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e_in) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) then - call sum_in_place(mpi, f_in) - f = f_in - endif - if (present(virial)) then - call sum_in_place(mpi, virial_in) - virial = virial_in - endif - if (present(local_virial)) call sum_in_place(mpi, local_virial) - endif - - if (do_rescale_r) then - if (present(f)) f = f*r_scale - end if - - if (do_rescale_E) then - if (present(e)) e = e*E_scale - if (present(local_e)) local_e = local_e*E_scale - if (present(f)) f = f*E_scale - if (present(virial)) virial=virial*E_scale - if (present(local_virial)) local_virial=local_virial*E_scale - end if - if(allocated(f_in)) deallocate(f_in) - -end subroutine IPModel_EAM_ErcolAd_Calc - -function eam_spline_V(this, ti, tj, r) - type(IPModel_EAM_ErcolAd), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r - real(dp) :: eam_spline_V - - if (r < min_knot(this%V(ti,tj)) .or. r >= max_knot(this%V(ti,tj))) then - eam_spline_V = 0.0_dp - else - eam_spline_V = spline_value(this%V(ti,tj),r) - endif - -end function eam_spline_V - -function eam_spline_rho(this, ti, r) - type(IPModel_EAM_ErcolAd), intent(in) :: this - integer, intent(in) :: ti - real(dp), intent(in) :: r - real(dp) :: eam_spline_rho - - if (r < min_knot(this%rho(ti)) .or. r >= max_knot(this%rho(ti))) then - eam_spline_rho = 0.0_dp - else - eam_spline_rho = spline_value(this%rho(ti),r) - endif - -end function eam_spline_rho - -function eam_spline_F(this, ti, rho) - type(IPModel_EAM_ErcolAd), intent(in) :: this - integer, intent(in) :: ti - real(dp), intent(in) :: rho - real(dp) :: eam_spline_F - - if (rho < min_knot(this%F(ti)) .or. rho >= max_knot(this%F(ti))) then - eam_spline_F = 0.0_dp - else - eam_spline_F = spline_value(this%F(ti),rho) - endif - -end function eam_spline_F - -function eam_spline_V_d(this, ti, tj, r) - type(IPModel_EAM_ErcolAd), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r - real(dp) :: eam_spline_V_d - - if (r < min_knot(this%V(ti,tj)) .or. r >= max_knot(this%V(ti,tj))) then - eam_spline_V_d = 0.0_dp - else - eam_spline_V_d = spline_deriv(this%V(ti,tj),r) - endif - -end function eam_spline_V_d - -function eam_spline_rho_d(this, ti, r) - type(IPModel_EAM_ErcolAd), intent(in) :: this - integer, intent(in) :: ti - real(dp), intent(in) :: r - real(dp) :: eam_spline_rho_d - - if (r < min_knot(this%rho(ti)) .or. r >= max_knot(this%rho(ti))) then - eam_spline_rho_d = 0.0_dp - else - eam_spline_rho_d = spline_deriv(this%rho(ti),r) - endif - -end function eam_spline_rho_d - -function eam_spline_F_d(this, ti, rho) - type(IPModel_EAM_ErcolAd), intent(in) :: this - integer, intent(in) :: ti - real(dp), intent(in) :: rho - real(dp) :: eam_spline_F_d - - if (rho < min_knot(this%F(ti)) .or. rho >= max_knot(this%F(ti))) then - eam_spline_F_d = 0.0_dp - else - eam_spline_F_d = spline_deriv(this%F(ti),rho) - endif - -end function eam_spline_F_d - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - - integer ti, Zi, Zj - integer n_types, n_spline_V, n_spline_rho, n_spline_F - real(dp) :: v - - if (name == 'EAM_ErcolAd_params') then ! new Ercolessi Adams stanza - - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered EAM_ErcolAd_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, "n_types", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find n_types") - read (value, *) parse_ip%n_types - n_types = parse_ip%n_types - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - allocate(parse_ip%r_min(n_types,n_types)) - allocate(parse_ip%r_cut(n_types,n_types)) - parse_ip%r_min = 0.0_dp - parse_ip%r_cut = 0.0_dp - - allocate(parse_ip%V_F_shift(n_types)) - parse_ip%V_F_shift = 0.0_dp - - call QUIP_FoX_get_value(attributes, "n_spline_V", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find n_spline_V") - read (value, *) n_spline_V - call QUIP_FoX_get_value(attributes, "n_spline_rho", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find n_spline_rho") - read (value, *) n_spline_rho - call QUIP_FoX_get_value(attributes, "n_spline_F", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find n_spline_F") - read (value, *) n_spline_F - - allocate(parse_ip%spline_V(5,n_spline_V,n_types,n_types)) - allocate(parse_ip%spline_rho(5,n_spline_rho,n_types)) - allocate(parse_ip%spline_F(5,n_spline_F,n_types)) - - allocate(parse_ip%V(n_types,n_types)) - allocate(parse_ip%rho(n_types)) - allocate(parse_ip%F(n_types)) - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find type") - read (value, *) ti - - if (ti < 1 .or. ti > parse_ip%n_types) call system_abort("IPModel_EAM_ErcolAd_read_params_xml got" // & - " per_type_data type out of range " // ti // " n_types " // parse_ip%n_types) - - parse_cur_type_i = ti - parse_cur_type_j = ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - call QUIP_FoX_get_value(attributes, "V_F_shift", value, status) - if (status == 0) then - read (value, *) parse_ip%V_F_shift(parse_cur_type_i) - endif - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "atomic_num_i", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find atomic_num_i") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atomic_num_j", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find atomic_num_j") - read (value, *) Zj - - parse_cur_type_i = get_type(parse_ip%type_of_atomic_num,Zi) - parse_cur_type_j = get_type(parse_ip%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "r_min", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r_min") - read (value, *) parse_ip%r_min(parse_cur_type_i, parse_cur_type_j) - - call QUIP_FoX_get_value(attributes, "r_cut", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r_cut") - read (value, *) parse_ip%r_cut(parse_cur_type_i, parse_cur_type_j) - - if (parse_cur_type_i /= parse_cur_type_j) then - parse_ip%r_min(parse_cur_type_j, parse_cur_type_i) = parse_ip%r_min(parse_cur_type_i, parse_cur_type_j) - parse_ip%r_cut(parse_cur_type_j, parse_cur_type_i) = parse_ip%r_cut(parse_cur_type_i, parse_cur_type_j) - end if - - elseif (parse_in_ip .and. name == 'spline_V') then - parse_in_spline_V = .true. - parse_cur_point = 1 - elseif (parse_in_ip .and. name == 'spline_rho') then - parse_in_spline_rho = .true. - parse_cur_point = 1 - elseif (parse_in_ip .and. name == 'spline_F') then - parse_in_spline_F = .true. - parse_cur_point = 1 - elseif (parse_in_ip .and. name == 'point') then - - if (parse_in_spline_V) then - - if (parse_cur_point > size(parse_ip%spline_V,2)) call system_abort ("IPModel_EAM_ErcolAd got too " // & - "many points " // parse_cur_point // " type " // parse_cur_type_i // " " // parse_cur_type_j // " in_spline_V") - - call QUIP_FoX_get_value(attributes, "r", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r") - read (value, *) v - parse_ip%spline_V(1,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v - - call QUIP_FoX_get_value(attributes, "y", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find y") - read (value, *) v - parse_ip%spline_V(2,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v - - call QUIP_FoX_get_value(attributes, "b", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find b") - read (value, *) v - parse_ip%spline_V(3,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v - - call QUIP_FoX_get_value(attributes, "c", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find c") - read (value, *) v - parse_ip%spline_V(4,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v - - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find d") - read (value, *) v - parse_ip%spline_V(5,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v - - if (parse_cur_type_i /= parse_cur_type_j) then - parse_ip%spline_V(1:5,parse_cur_point,parse_cur_type_j,parse_cur_type_i) = & - parse_ip%spline_V(1:5,parse_cur_point,parse_cur_type_i,parse_cur_type_j) - endif - - else if (parse_in_spline_rho) then - - if (parse_cur_point > size(parse_ip%spline_rho,2)) call system_abort ("IPModel_EAM_ErcolAd got " // & - "too many points " // parse_cur_point // " type " // parse_cur_type_i // " in_spline_rho") - - call QUIP_FoX_get_value(attributes, "r", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r") - read (value, *) v - parse_ip%spline_rho(1,parse_cur_point,parse_cur_type_i) = v - - call QUIP_FoX_get_value(attributes, "y", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find y") - read (value, *) v - parse_ip%spline_rho(2,parse_cur_point,parse_cur_type_i) = v - - call QUIP_FoX_get_value(attributes, "b", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find b") - read (value, *) v - parse_ip%spline_rho(3,parse_cur_point,parse_cur_type_i) = v - - call QUIP_FoX_get_value(attributes, "c", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find c") - read (value, *) v - parse_ip%spline_rho(4,parse_cur_point,parse_cur_type_i) = v - - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find d") - read (value, *) v - parse_ip%spline_rho(5,parse_cur_point,parse_cur_type_i) = v - - else if (parse_in_spline_F) then - - if (parse_cur_point > size(parse_ip%spline_F,2)) call system_abort ("IPModel_EAM_ErcolAd got " // & - "too many points " // parse_cur_point // " type " // parse_cur_type_i // " in_spline_F") - - call QUIP_FoX_get_value(attributes, "r", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r") - read (value, *) v - parse_ip%spline_F(1,parse_cur_point,parse_cur_type_i) = v - - call QUIP_FoX_get_value(attributes, "y", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find y") - read (value, *) v - parse_ip%spline_F(2,parse_cur_point,parse_cur_type_i) = v - - call QUIP_FoX_get_value(attributes, "b", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find b") - read (value, *) v - parse_ip%spline_F(3,parse_cur_point,parse_cur_type_i) = v - - call QUIP_FoX_get_value(attributes, "c", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find c") - read (value, *) v - parse_ip%spline_F(4,parse_cur_point,parse_cur_type_i) = v - - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find d") - read (value, *) v - parse_ip%spline_F(5,parse_cur_point,parse_cur_type_i) = v - endif - - parse_cur_point = parse_cur_point + 1 - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'EAM_ErcolAd_params') then - parse_in_ip = .false. - elseif (parse_in_ip .and. name == 'spline_V') then - parse_in_spline_V = .false. - elseif (parse_in_ip .and. name == 'spline_rho') then - parse_in_spline_rho = .false. - elseif (parse_in_ip .and. name == 'spline_F') then - parse_in_spline_F = .false. - endif - endif - - end subroutine IPModel_endElement_handler - -subroutine IPModel_EAM_ErcolAd_read_params_xml(this, param_str) - type(IPModel_EAM_ErcolAd), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type (xml_t) :: fxml - integer ti, tj - - if (len(trim(param_str)) <= 0) return - - parse_ip => this - parse_in_ip = .false. - parse_matched_label = .false. - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types == 0) call system_abort("EAM_ErcolAd Tried to parse, but n_types still 0") - - do ti=1, this%n_types - call initialise(this%rho(ti),this%spline_rho(1,:,ti),this%spline_rho(2,:,ti),huge(1.0_dp),0.0_dp) - call initialise(this%F(ti),this%spline_F(1,:,ti),this%spline_F(2,:,ti),huge(1.0_dp),huge(1.0_dp)) - do tj=1, this%n_types - call initialise(this%V(ti,tj),this%spline_V(1,:,ti,tj),this%spline_V(2,:,ti,tj),huge(1.0_dp),0.0_dp) - end do - end do - - parse_ip%cutoff = maxval(parse_ip%r_cut) - -end subroutine IPModel_EAM_ErcolAd_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of potential parameters: number of different types, cutoff radius, atomic numbers, ect. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_EAM_ErcolAd_Print (this, file) - type(IPModel_EAM_ErcolAd), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_EAM_ErcolAd : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print("IPModel_EAM_ErcolAd : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print("IPModel_EAM_ErcolAd : spline_rho ", file=file) - call Print(this%rho(ti), file=file) - call Print("IPModel_EAM_ErcolAd : spline_F ", file=file) - call Print(this%F(ti), file=file) - do tj=1, this%n_types - call Print("IPModel_EAM_ErcolAd : pair "// ti // " " // tj // " r_min " // this%r_min(ti,tj) // " r_cut " // this%r_cut(ti,tj), file=file) - call Print("IPModel_EAM_ErcolAd : pair spline_V ", file=file) - call Print(this%V(ti,tj), file=file) - end do - call verbosity_pop() - end do - -end subroutine IPModel_EAM_ErcolAd_Print - -end module IPModel_EAM_ErcolAd_module diff --git a/src/Potentials/IPModel_Einstein.f95 b/src/Potentials/IPModel_Einstein.f95 deleted file mode 100644 index f896af7f65..0000000000 --- a/src/Potentials/IPModel_Einstein.f95 +++ /dev/null @@ -1,369 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Einstein -!X -!% Einstein module -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Einstein_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use cinoutput_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Einstein -type IPModel_Einstein - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - real(dp), dimension(:), allocatable :: spring_constant - - type(atoms) :: ref - character(len=STRING_LENGTH) :: ref_file - - real(dp) :: cutoff = 0.0_dp - - character(len=STRING_LENGTH) :: label - -end type IPModel_Einstein - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Einstein), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Einstein_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Einstein_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Einstein_Print -end interface Print - -interface Calc - module procedure IPModel_Einstein_Calc -end interface Calc - -contains - -subroutine IPModel_Einstein_Initialise_str(this, args_str, param_str) - type(IPModel_Einstein), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Einstein_Initialise_str args_str')) then - call system_abort("IPModel_Einstein_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Einstein_read_params_xml(this, param_str) - - call read(this%ref,trim(this%ref_file)) - ! Add initialisation code here - -end subroutine IPModel_Einstein_Initialise_str - -subroutine IPModel_Einstein_Finalise(this) - type(IPModel_Einstein), intent(inout) :: this - - ! Add finalisation code here - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%spring_constant)) deallocate(this%spring_constant) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Einstein_Finalise - - -subroutine IPModel_Einstein_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Einstein), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), dimension(3) :: diff - real(dp), dimension(3,3) :: virial_i - real(dp) :: ki, ei - integer :: i, ti - ! Add calc() code here - - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Einstein_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Einstein_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Einstein_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_Einstein_Calc: local_virial calculation requested but not supported yet.", error) - endif - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Einstein_Calc args_str')) & - call system_abort("IPModel_Einstein_Calc failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_Einstein_Calc did not find "//trim(atom_mask_name)//" propery in the atoms object.") - else - atom_mask_pointer => null() - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_Einstein_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - endif - - - if(at%N /= this%ref%N) call system_abort("IPModel_Einstein_Calc: number of atoms "//at%N//" does not match the number of atoms "//this%ref%N//" in the & - reference structure") - - do i = 1, at%N - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - ki = this%spring_constant(ti) - - diff = diff_min_image(at,this%ref%pos(:,i),at%pos(:,i)) - if(present(local_e) .or. present(e)) ei = 0.5_dp * ki * sum(diff**2) - - if(present(local_e)) local_e(i) = ei - if(present(e)) e = e + ei - - if(present(f)) f(:,i) = f(:,i) - ki*diff - if(present(virial) .or. present(local_virial)) virial_i = ki*(diff .outer. at%pos(:,i)) - - if(present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) - if(present(virial)) virial = virial - virial_i - enddo - -end subroutine IPModel_Einstein_Calc - - -subroutine IPModel_Einstein_Print(this, file) - type(IPModel_Einstein), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_Einstein : Einstein Potential", file=file) - call Print("IPModel_Einstein : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_Einstein : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call Print ("IPModel_Einstein : type " // ti // " spring_constant " // this%spring_constant(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_Einstein : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_Einstein_Print - -subroutine IPModel_Einstein_read_params_xml(this, param_str) - type(IPModel_Einstein), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Einstein_read_params_xml parsed file, but n_types = 0") - endif -end subroutine IPModel_Einstein_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - integer ti - - if (name == 'Einstein_params') then ! new Einstein stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in Einstein_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%spring_constant(parse_ip%n_types)) - parse_ip%spring_constant = 0.0_dp - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - - call QUIP_FoX_get_value(attributes, "ref_file", value, status) - if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find ref_file") - parse_ip%ref_file = trim(value) - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - call QUIP_FoX_get_value(attributes, "spring_constant", value, status) - if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find spring_constant") - read (value, *) parse_ip%spring_constant(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Einstein_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_Einstein_module diff --git a/src/Potentials/IPModel_FB.f95 b/src/Potentials/IPModel_FB.f95 deleted file mode 100644 index 9897226f55..0000000000 --- a/src/Potentials/IPModel_FB.f95 +++ /dev/null @@ -1,455 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_FB module -!% -!% Module for Flikkema \& Bromley interatomic potential -!% -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_FB_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_FB -type IPModel_FB - integer :: n_types = 0 !% Number of atomic types. - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - real(dp), dimension(:,:), allocatable :: A, B, C - - character(len=STRING_LENGTH) label - -end type IPModel_FB - -logical, private :: parse_in_ip, parse_matched_label -integer :: parse_cur_type_i, parse_cur_type_j -type(IPModel_FB), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_FB_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_FB_Finalise -end interface Finalise - -interface Print - module procedure IPModel_FB_Print -end interface Print - -interface Calc - module procedure IPModel_FB_Calc -end interface Calc - -contains - -subroutine IPModel_FB_Initialise_str(this, args_str, param_str) - type(IPModel_FB), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label = '' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FB_Initialise_str args_str')) then - call system_abort("IPModel_FB_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_FB_read_params_xml(this, param_str) - -end subroutine IPModel_FB_Initialise_str - -subroutine IPModel_FB_Finalise(this) - type(IPModel_FB), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%A)) deallocate(this%A) - if (allocated(this%B)) deallocate(this%B) - if (allocated(this%C)) deallocate(this%C) - - this%n_types = 0 - this%cutoff = 0.0_dp - this%label = '' -end subroutine IPModel_FB_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_FB_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_FB), intent(in) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out), optional :: e !% \texttt{e} = System total energy - real(dp), dimension(:), intent(out), optional :: local_e !% \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), dimension(3,3), intent(out), optional :: virial !% Virial - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer :: i, j, n, ti, tj - real(dp) :: r_ij, de, de_dr - real(dp), dimension(3) :: u_ij - real(dp), dimension(3,3) :: virial_i - - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - type(Atoms) :: at_ew - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_FB_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_FB_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_FB_Calc', error) - local_virial = 0.0_dp - endif - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_FB_Calc args_str')) then - RAISE_ERROR("IPModel_FB_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then - RAISE_ERROR("IPModel_FB_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.",error) - endif - else - atom_mask_pointer => null() - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_FB_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - endif - - do i = 1, at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - do n = 1, n_neighbours(at, i) - j = neighbour(at, i, n, distance=r_ij, cosines = u_ij) - if (r_ij .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - if (present(e) .or. present(local_e)) then - de = 0.5_dp * (this%A(ti,tj) * exp( - r_ij / this%B(ti,tj) ) - this%C(ti,tj) / r_ij**6) - if (present(local_e)) local_e(i) = local_e(i) + de - if (present(e)) e = e + de - endif - if (present(f) .or. present(virial)) then - de_dr = 0.5_dp * (-this%A(ti,tj) * exp( - r_ij / this%B(ti,tj) ) / this%B(ti,tj) + & - & 6.0_dp * this%C(ti,tj) / r_ij**7 ) - if (present(f)) then - f(:,i) = f(:,i) + de_dr*u_ij - f(:,j) = f(:,j) - de_dr*u_ij - endif - if (present(virial) .or. present(local_virial)) virial_i = de_dr*(u_ij .outer. u_ij)*r_ij - if (present(virial)) virial = virial - virial_i - if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) - endif - end do - end do - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(f)) call sum_in_place(mpi, f) - endif - -end subroutine IPModel_FB_Calc - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for XML stanza is given below. -!% -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - integer :: ti, Zi, Zj - - if (name == 'FB_params') then ! new FB stanza - - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered FB_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in FB_params") - endif - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if (status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort("Can't find cutoff in FB_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%A(parse_ip%n_types,parse_ip%n_types)) - parse_ip%A = 0.0_dp - allocate(parse_ip%B(parse_ip%n_types,parse_ip%n_types)) - parse_ip%B = 0.0_dp - allocate(parse_ip%C(parse_ip%n_types,parse_ip%n_types)) - parse_ip%C = 0.0_dp - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "atomic_num_i", value, status) - if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find atomic_num_i") - read (value, *) Zi - - call QUIP_FoX_get_value(attributes, "atomic_num_j", value, status) - if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find atomic_num_i") - read (value, *) Zj - - parse_cur_type_i = get_type(parse_ip%type_of_atomic_num,Zi) - parse_cur_type_j = get_type(parse_ip%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "A", value, status) - if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find A") - read (value, *) parse_ip%A(parse_cur_type_i,parse_cur_type_j) - - call QUIP_FoX_get_value(attributes, "B", value, status) - if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find B") - read (value, *) parse_ip%B(parse_cur_type_i,parse_cur_type_j) - - call QUIP_FoX_get_value(attributes, "C", value, status) - if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find C") - read (value, *) parse_ip%C(parse_cur_type_i,parse_cur_type_j) - - if (parse_cur_type_i /= parse_cur_type_j) then - parse_ip%A(parse_cur_type_j,parse_cur_type_i) = parse_ip%A(parse_cur_type_i,parse_cur_type_j) - parse_ip%B(parse_cur_type_j,parse_cur_type_i) = parse_ip%B(parse_cur_type_i,parse_cur_type_j) - parse_ip%C(parse_cur_type_j,parse_cur_type_i) = parse_ip%C(parse_cur_type_i,parse_cur_type_j) - end if - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'FB_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_FB_read_params_xml(this, param_str) - type(IPModel_FB), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_FB_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_FB_read_params_xml - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of FB parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_FB_Print (this, file) - type(IPModel_FB), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_FB : Flikkema Bromley", file=file) - call Print("IPModel_FB : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call verbosity_push_decrement() - do tj=1, this%n_types - call Print ("IPModel_FB : interaction " // ti // " " // tj // " A " // this%A(ti,tj) // " B " // & - & this%B(ti,tj) // " C " // this%C(ti,tj), file=file) - end do - call verbosity_pop() - end do - -end subroutine IPModel_FB_Print - -end module IPModel_FB_module - diff --git a/src/Potentials/IPModel_FC.f95 b/src/Potentials/IPModel_FC.f95 deleted file mode 100644 index c2613e5cdb..0000000000 --- a/src/Potentials/IPModel_FC.f95 +++ /dev/null @@ -1,714 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_FC module -!X -!% Module for Force-Constant (Guggenheim-McGlashan) pair potential. -!% \begin{equation} -!% \nonumber -!% V(r) = 1/2 phi2 (r-r0)^2 + 1/6 phi3 (r-r0)^3 + 1.24 phi4 (r-r0)^4 -!% \end{equation} -!% -!% Proc. Royal Soc. London A, v. 255, p. 456 (1960) -!% Used, e.g. by Bernstein, Feldman, and Singh, Phys. Rev. B (2010) -!% -!% The IPModel_FC object contains all the parameters read from a -!% 'FC_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" -#define NEIGHBOR_LOOP_OPTION 1 - -module IPModel_FC_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_NERD, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use table_module -use connection_module -use atoms_types_module -use atoms_module -use cinoutput_module - -use mpi_context_module -use QUIP_Common_module - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_FC -type IPModel_FC - integer :: n_types = 0 !% Number of atomic types. - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - real(dp), allocatable :: r0(:,:,:), phi2(:,:,:), phi3(:,:,:), phi4(:,:,:) !% IP parameters. - integer, allocatable :: n_fcs(:,:) - - character(len=STRING_LENGTH) :: ideal_struct_file - type(Atoms) :: ideal_struct - - character(len=STRING_LENGTH) label - -end type IPModel_FC - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_FC), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_FC_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_FC_Finalise -end interface Finalise - -interface Print - module procedure IPModel_FC_Print -end interface Print - -interface Calc - module procedure IPModel_FC_Calc -end interface Calc - -contains - -subroutine IPModel_FC_Initialise_str(this, args_str, param_str) - type(IPModel_FC), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - integer, allocatable :: sorted_index(:) - real(dp), allocatable :: t_phi(:) - integer :: ti, tj - - integer :: i, ji, j, s(3), fc_i, tind, t_s(3) - real(dp) :: ideal_v(3), ideal_dr_mag - integer, pointer :: travel(:) - - call Finalise(this) - - call initialise(params) - this%label = '' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "ideal_struct_file", PARAM_MANDATORY, this%ideal_struct_file, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FC_Initialise_str args_str')) then - call system_abort("IPModel_FC_Initialise_str failed to find mandatory ideal_struct_file or parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_FC_read_params_xml(this, param_str) - - call read(this%ideal_struct, trim(this%ideal_struct_file)) -#if NEIGHBOR_LOOP_OPTION == 1 || NEIGHBOR_LOOP_OPTION == 2 - ! will do nothing if travel already exists, but it must exist for inlined neighbor stuff in _Calc() - call add_property(this%ideal_struct, "travel", value=0, n_cols=3, overwrite=.false.) -#endif - - do ti=1, this%n_types - do tj=1, this%n_types - this%n_fcs(ti,tj) = count(this%r0(ti,tj,:) > 0.0_dp) - if (this%n_fcs(ti,tj) > 1) then - allocate(sorted_index(this%n_fcs(ti,tj))) - allocate(t_phi(this%n_fcs(ti,tj))) - sorted_index = [(i, i = 1, size(sorted_index))] - call insertion_sort(this%r0(ti,tj,1:this%n_fcs(ti,tj)), i_data=sorted_index) - t_phi = this%phi2(ti,tj,sorted_index); this%phi2(ti,tj,1:this%n_fcs(ti,tj)) = t_phi - t_phi = this%phi3(ti,tj,sorted_index); this%phi3(ti,tj,1:this%n_fcs(ti,tj)) = t_phi - t_phi = this%phi4(ti,tj,sorted_index); this%phi4(ti,tj,1:this%n_fcs(ti,tj)) = t_phi - deallocate(sorted_index) - deallocate(t_phi) - endif - end do - end do - - call set_cutoff(this%ideal_struct, this%cutoff) - call calc_connect(this%ideal_struct) - do i = 1, this%ideal_struct%N - ti = get_type(this%type_of_atomic_num, this%ideal_struct%Z(i)) - ji = 1 - do while (ji <= n_neighbours(this%ideal_struct, i)) - ji = 1 - do while (ji <= n_neighbours(this%ideal_struct, i)) - j = neighbour(this%ideal_struct, i, ji, distance=ideal_dr_mag, shift=s) - - ! if (dr_mag .feq. 0.0_dp) cycle - ! if ((i < j) .and. i_is_min_image) cycle - - tj = get_type(this%type_of_atomic_num, this%ideal_struct%Z(j)) - - fc_i = find_fc_i(this, ti, tj, ideal_dr_mag) - if (fc_i <= 0) then - call remove_bond(this%ideal_struct%connect, i, j, s) - exit - end if - ji = ji + 1 - end do ! while ji inner - end do ! while ji outer - end do ! j - -end subroutine IPModel_FC_Initialise_str - -subroutine IPModel_FC_Finalise(this) - type(IPModel_FC), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%r0)) deallocate(this%r0) - if (allocated(this%phi2)) deallocate(this%phi2) - if (allocated(this%phi3)) deallocate(this%phi3) - if (allocated(this%phi4)) deallocate(this%phi4) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_FC_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_FC_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_FC), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), pointer :: w_e(:) - integer i, ji, j, ti, tj, fc_i - real(dp) :: dr(3), dr_mag, ideal_dr_mag, ideal_v(3) - real(dp) :: de, de_dr - integer :: s(3) - logical :: i_is_min_image - - integer :: i_calc, n_extra_calcs - character(len=20) :: extra_calcs_list(10) - - logical :: do_flux = .false. - real(dp), pointer :: velo(:,:) - real(dp) :: flux(3) - integer :: tind, dr_shift(3) - type(Table), pointer :: t - logical :: is_j - real(dp) :: dr_v(3) -#if NEIGHBOR_LOOP_OPTION == 2 - integer :: i_n1n, j_n1n -#endif - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_FC_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_FC_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) virial = 0.0_dp - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_FC_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_FC_Calc: local_virial calculation requested but not supported yet.", error) - endif - - atom_mask_pointer => null() - if (present(args_str)) then - if (len_trim(args_str) > 0) then - n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) - if (n_extra_calcs > 0) then - do i_calc=1, n_extra_calcs - select case(trim(extra_calcs_list(i_calc))) - case("flux") - if (.not. assign_pointer(at, "velo", velo)) & - call system_abort("IPModel_FC_Calc Flux calculation requires velo field") - do_flux = .true. - flux = 0.0_dp - case default - call system_abort("Unsupported extra_calc '"//trim(extra_calcs_list(i_calc))//"'") - end select - end do - endif ! n_extra_calcs - endif ! len_trim(args_str) - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_FC_Calc args_str')) then - RAISE_ERROR("IPModel_FC_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - - if( has_atom_mask_name ) then - RAISE_ERROR('IPModel_FC_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_FC_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - endif ! present(args_str) - - if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) - - do i = 1, at%N - i_is_min_image = this%ideal_struct%connect%is_min_image(i) - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - do ji = 1, n_neighbours(this%ideal_struct, i) -#if NEIGHBOR_LOOP_OPTION == 0 - j = neighbour(at, i, ji, dr_mag, cosines = dr, shift=s) -#endif -#if NEIGHBOR_LOOP_OPTION == 1 || NEIGHBOR_LOOP_OPTION == 2 -#if NEIGHBOR_LOOP_OPTION == 1 - j = neighbour_index(this%ideal_struct, i, ji, tind, t, is_j) -#else - i_n1n = ji-this%ideal_struct%connect%neighbour2(i)%t%N - if (ji <= this%ideal_struct%connect%neighbour2(i)%t%N) then - j = this%ideal_struct%connect%neighbour2(i)%t%int(1,ji) - j_n1n = this%ideal_struct%connect%neighbour2(i)%t%int(2,ji) - tind = j_n1n - t => this%ideal_struct%connect%neighbour1(j)%t - is_j = .true. - else if (i_n1n <= this%ideal_struct%connect%neighbour1(i)%t%N) then - j = this%ideal_struct%connect%neighbour1(i)%t%int(1,i_n1n) - tind = i_n1n - t => this%ideal_struct%connect%neighbour1(i)%t - is_j = .false. - endif -#endif - if((i < j) .and. i_is_min_image) cycle - ideal_dr_mag = t%real(1,tind) - if (ideal_dr_mag .feq. 0.0_dp) cycle - if (is_j) then - s = -t%int(2:4,tind) - else - s = t%int(2:4,tind) - endif -#endif - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - fc_i = find_fc_i(this, ti, tj, ideal_dr_mag) - if (fc_i <= 0) cycle - -#if NEIGHBOR_LOOP_OPTION == 1 || NEIGHBOR_LOOP_OPTION == 2 - ! v = (p(j) - lat . travel(j)) - (p(i) - lat . travel(i)) + lat . s - ! = p(j) - p(i) + lat . (travel(i) - travel(j) + s) - dr_shift = - at%travel(:,i) + at%travel(:,j) + this%ideal_struct%travel(:,i) - this%ideal_struct%travel(:,j) + s(:) - dr_v = at%pos(:,j) - at%pos(:,i) + ( at%lattice(:,1) * dr_shift(1) + & - at%lattice(:,2) * dr_shift(2) + & - at%lattice(:,3) * dr_shift(3) ) - dr_mag = sqrt(dr_v(1)*dr_v(1) + dr_v(2)*dr_v(2) + dr_v(3)*dr_v(3)) -#endif - - if (present(e) .or. present(local_e)) then - de = IPModel_FC_pairenergy(this, ti, tj, fc_i, dr_mag) - if (present(local_e)) then - local_e(i) = local_e(i) + 0.5_dp*de - if (i_is_min_image) local_e(j) = local_e(j) + 0.5_dp*de - endif - if (present(e)) then - if (associated(w_e)) then - de = de*0.5_dp*(w_e(i)+w_e(j)) - endif - if(i_is_min_image) then - e = e + de - else - e = e + 0.5_dp*de - endif - endif - endif - if (present(f) .or. present(virial) .or. do_flux) then - de_dr = IPModel_FC_pairenergy_deriv(this, ti, tj, fc_i, dr_mag) - if (associated(w_e)) then - de_dr = de_dr*0.5_dp*(w_e(i)+w_e(j)) - endif - dr = dr_v/dr_mag - if (present(f)) then - f(:,i) = f(:,i) + de_dr*dr - if(i_is_min_image) f(:,j) = f(:,j) - de_dr*dr - endif - if (do_flux) then - ! -0.5 (v_i + v_j) . F_ij * dr_ij - flux = flux - 0.5_dp*sum((velo(:,i)+velo(:,j))*(de_dr*dr))*(dr*dr_mag) - endif - if (present(virial)) then - if(i_is_min_image) then - virial = virial - de_dr*(dr .outer. dr)*dr_mag - else - virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*dr_mag - endif - endif - endif - end do - end do ! i - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(f)) call sum_in_place(mpi, f) - endif - if (do_flux) then - flux = flux / cell_volume(at) - if (present(mpi)) call sum_in_place(mpi, flux) - call set_value(at%params, "Flux", flux) - endif - -end subroutine IPModel_FC_Calc - -!% This routine computes the two-body term for a pair of atoms separated by a distance r. -function IPModel_FC_pairenergy(this, ti, tj, fc_i, r) - type(IPModel_FC), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - integer, intent(in) :: fc_i !% Force-constant index - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_FC_pairenergy - - real(dp) :: dr, dr2, dr3, dr4 - real(dp), parameter :: c2 = 1.0_dp/2.0_dp, c3 = 1.0_dp/6.0_dp, c4 = 1.0_dp/24.0_dp - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff)) then - IPModel_FC_pairenergy = 0.0 - return - endif - - dr = r - this%r0(ti,tj,fc_i) - dr2 = dr*dr - dr3 = dr2*dr - dr4 = dr2*dr2 - IPModel_FC_pairenergy = c2*this%phi2(ti,tj,fc_i)*dr2 + & - c3*this%phi3(ti,tj,fc_i)*dr3 + & - c4*this%phi4(ti,tj,fc_i)*dr4 -end function IPModel_FC_pairenergy - -!% Derivative of the two-body term. -function IPModel_FC_pairenergy_deriv(this, ti, tj, fc_i, r) - type(IPModel_FC), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - integer, intent(in) :: fc_i !% FC index - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_FC_pairenergy_deriv - - real(dp) :: dr, dr2, dr3 - real(dp), parameter :: c2 = 1.0_dp, c3 = 1.0_dp/2.0_dp, c4 = 1.0_dp/6.0_dp - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff)) then - IPModel_FC_pairenergy_deriv = 0.0 - return - endif - - dr = r - this%r0(ti,tj,fc_i) - dr2 = dr*dr - dr3 = dr2*dr - IPModel_FC_pairenergy_deriv = c2*this%phi2(ti,tj,fc_i)*dr + & - c3*this%phi3(ti,tj,fc_i)*dr2 + & - c4*this%phi4(ti,tj,fc_i)*dr3 -end function IPModel_FC_pairenergy_deriv - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for XML stanza is given below, please notice that -!% they are simply dummy parameters for testing purposes, with no physical meaning. -!% -!%> -!%> -!%> -!%> -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - integer atnum_i, atnum_j, fc_i, ti, tj, max_n_fcs, ti_a(1) - - if (name == 'FC_params') then ! new FC stanza - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered FC_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in FC_params") - endif - - call QUIP_FoX_get_value(attributes, 'max_n_fcs', value, status) - if (status == 0) then - read (value, *) max_n_fcs - else - call system_abort("Can't find max_n_fcs in FC_params") - endif - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if (status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort("Can't find this%cutoff in FC_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%r0(parse_ip%n_types,parse_ip%n_types,max_n_fcs)) - allocate(parse_ip%phi2(parse_ip%n_types,parse_ip%n_types,max_n_fcs)) - allocate(parse_ip%phi3(parse_ip%n_types,parse_ip%n_types,max_n_fcs)) - allocate(parse_ip%phi4(parse_ip%n_types,parse_ip%n_types,max_n_fcs)) - allocate(parse_ip%n_fcs(parse_ip%n_types,parse_ip%n_types)) - - parse_ip%r0 = 0.0_dp - parse_ip%phi2 = 0.0_dp - parse_ip%phi3 = 0.0_dp - parse_ip%phi4 = 0.0_dp - - endif ! parse_in_ip - elseif (parse_in_ip .and. name == 'FC') then - - call QUIP_FoX_get_value(attributes, "atnum_i", value, status) - if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find atnum_i") - read (value, *) atnum_i - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find atnum_j") - read (value, *) atnum_j - call QUIP_FoX_get_value(attributes, "fc_i", value, status) - if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find fc_i") - read (value, *) fc_i - - if (all(parse_ip%atomic_num /= atnum_i)) then - ti_a = minloc(parse_ip%atomic_num) - parse_ip%atomic_num(ti_a(1)) = atnum_i - endif - if (all(parse_ip%atomic_num /= atnum_j)) then - ti_a = minloc(parse_ip%atomic_num) - parse_ip%atomic_num(ti_a(1)) = atnum_j - endif - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - ti = parse_ip%type_of_atomic_num(atnum_i) - tj = parse_ip%type_of_atomic_num(atnum_j) - - call QUIP_FoX_get_value(attributes, "r0", value, status) - if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find r0") - read (value, *) parse_ip%r0(ti,tj,fc_i) - call QUIP_FoX_get_value(attributes, "phi2", value, status) - if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find phi2") - read (value, *) parse_ip%phi2(ti,tj,fc_i) - call QUIP_FoX_get_value(attributes, "phi3", value, status) - if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find phi3") - read (value, *) parse_ip%phi3(ti,tj,fc_i) - call QUIP_FoX_get_value(attributes, "phi4", value, status) - if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find phi4") - read (value, *) parse_ip%phi4(ti,tj,fc_i) - - if (ti /= tj) then - parse_ip%r0(tj,ti,fc_i) = parse_ip%r0(ti,tj,fc_i) - parse_ip%phi2(tj,ti,fc_i) = parse_ip%phi2(ti,tj,fc_i) - parse_ip%phi3(tj,ti,fc_i) = parse_ip%phi3(ti,tj,fc_i) - parse_ip%phi4(tj,ti,fc_i) = parse_ip%phi4(ti,tj,fc_i) - endif - - endif ! parse_in_ip .and. name = 'FC' - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'FC_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_FC_read_params_xml(this, param_str) - type(IPModel_FC), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_FC_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_FC_read_params_xml - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of FC parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_FC_Print (this, file) - type(IPModel_FC), intent(inout) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj, fc_i - - call Print("IPModel_FC : Force-Constant (Guggenheim-McGlashan)", file=file) - call Print("IPModel_FC : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_FC : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - do tj=1, this%n_types - do fc_i=1, this%n_fcs(ti,tj) - call Print ("IPModel_FC : interaction " // ti // " " // tj // " r0 " // this%r0(ti,tj,fc_i) // " phi2,3,4 " // & - this%phi2(ti,tj,fc_i) // " " // this%phi3(ti,tj,fc_i) // " " // this%phi4(ti,tj,fc_i), file=file) - end do - end do - call verbosity_pop() - end do - - call verbosity_push_decrement(PRINT_NERD) - call print("IPModel_FC : ideal_struct_file='"//trim(this%ideal_struct_file)//"'", file=file) - call print("IPModel_FC : ideal_struct", file=file) - call write(this%ideal_struct,'stdout') - call verbosity_pop() - -end subroutine IPModel_FC_Print - -function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) - character(len=*), intent(in) :: args_str - character(len=*), intent(out) :: extra_calcs_list(:) - integer :: n_extra_calcs - - character(len=STRING_LENGTH) :: extra_calcs_str - type(Dictionary) :: params - - n_extra_calcs = 0 - call initialise(params) - call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") - if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then - if (len_trim(extra_calcs_str) > 0) then - call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") - end if - end if - call finalise(params) - -end function parse_extra_calcs - -function find_fc_i(this, ti, tj, ideal_dr_mag) - type(IPModel_FC), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: ideal_dr_mag - integer find_fc_i - - integer :: fc_i - - find_fc_i = 0 - do fc_i=1, this%n_fcs(ti,tj) - if (abs(this%r0(ti,tj,fc_i)-ideal_dr_mag) < 1.0e-4_dp) then - find_fc_i = fc_i - return - endif - end do -end function find_fc_i - -end module IPModel_FC_module diff --git a/src/Potentials/IPModel_FC4.f95 b/src/Potentials/IPModel_FC4.f95 deleted file mode 100644 index e3a5444956..0000000000 --- a/src/Potentials/IPModel_FC4.f95 +++ /dev/null @@ -1,836 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_FC4 module -!X -!% Module for the Fourth-order force-constant potential, described in -!% Esfarjani, Chen and Stokes, Phys. Rev. B {\bf 84} 085204 (2011) -!% -!% Calculation works as follows: The atom positions and velocities in -!% 'at' correspond to a supercell of the primitive lattice, read into -!% 'ideal_struct'. The 'cell_offset' property of 'at' contains the -!% multiples of the lattice vectors mapping this atom from the -!% primitive cell to the supercell, and the 'prim_index' property is -!% the index of the atom within this cell. A third file contains the -!% neighbours (described as 'neighbourshell', 'atom_shl' in Esfarjani) -!% to which force constants are computed. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_FC4_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use minimization_module, only: KahanSum -use atoms_types_module -use atoms_module -use cinoutput_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_FC4 -type IPModel_FC4 - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - - character(len=STRING_LENGTH) :: label - - character(len=STRING_LENGTH) :: ideal_struct_file - type(Atoms) :: ideal_struct - integer, pointer :: ideal_struct_prim_index(:) - integer, pointer :: ideal_struct_cell_offset(:,:) - - character(len=STRING_LENGTH) :: atom_shl_file - type(Atoms) :: atom_shl - integer, pointer :: atom_shl_prim_index(:) - integer, pointer :: atom_shl_cell_offset(:,:) - - character(len=STRING_LENGTH) :: fc2_file, fc3_file, fc4_file - - integer :: nfc2, nfc2_indep, nfc3, nfc3_indep, nfc4, nfc4_indep - - integer , allocatable :: igroup_2(:) - integer , allocatable :: iatomterm_2(:,:) - integer , allocatable :: ixyzterm_2(:,:) - real(dp), allocatable :: fcs_2(:) - real(dp), allocatable :: ampterm_2(:) - - integer , allocatable :: igroup_3(:) - integer , allocatable :: iatomterm_3(:,:) - integer , allocatable :: ixyzterm_3(:,:) - real(dp), allocatable :: fcs_3(:) - real(dp), allocatable :: ampterm_3(:) - - integer , allocatable :: igroup_4(:) - integer , allocatable :: iatomterm_4(:,:) - integer , allocatable :: ixyzterm_4(:,:) - real(dp), allocatable :: fcs_4(:) - real(dp), allocatable :: ampterm_4(:) - - integer, allocatable :: findatom_sc_array(:,:,:,:) - integer sc_min(3), sc_max(3) - - real(dp) :: superlattice(3,3), inv_superlattice(3,3) - -end type IPModel_FC4 - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_FC4), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_FC4_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_FC4_Finalise -end interface Finalise - -interface Print - module procedure IPModel_FC4_Print -end interface Print - -interface Calc - module procedure IPModel_FC4_Calc -end interface Calc - -contains - -subroutine IPModel_FC4_Initialise_str(this, args_str, param_str) - type(IPModel_FC4), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - integer :: ntau - - call Finalise(this) - - this%label = '' - this%ideal_struct_file = '' - this%atom_shl_file = '' - this%fc2_file = '' - this%fc3_file = '' - this%fc4_file = '' - - call initialise(params) - - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "ideal_struct_file", PARAM_MANDATORY, this%ideal_struct_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "atom_shl_file", PARAM_MANDATORY, this%atom_shl_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "fc2_file", PARAM_MANDATORY, this%fc2_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "fc3_file", '', this%fc3_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "fc4_file", '', this%fc4_file, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FC4_Initialise_str args_str')) then - call system_abort("IPModel_FC4_Initialise_str failed to find mandatory ideal_struct_file or fc2_file, or parse label from args_str="//trim(args_str)) - endif - - call finalise(params) - - call IPModel_FC4_read_params_xml(this, param_str) - - ! - ! Read the ideal structure - ! - call read(this%ideal_struct, trim(this%ideal_struct_file)) - call get_param_value(this%ideal_struct, "Superlattice", this%superlattice) - call matrix3x3_inverse(this%superlattice, this%inv_superlattice) - call add_property(this%ideal_struct, "cell_offset", value=0, n_cols=3, overwrite=.false.) - call add_property(this%ideal_struct, "prim_index", value=0, n_cols=1, overwrite=.false.) - if (.not.assign_pointer(this%ideal_struct, "prim_index", this%ideal_struct_prim_index)) & - call system_abort("IPModel_FC4 requires 'prim_index' field in ideal struct file") - if (.not.assign_pointer(this%ideal_struct, "cell_offset", this%ideal_struct_cell_offset)) & - call system_abort("IPModel_FC4 requires 'cell_offset' field in ideal struct file") - - allocate(this%igroup_2(this%nfc2), & - this%iatomterm_2(2,this%nfc2), & - this%ixyzterm_2(2,this%nfc2), & - this%fcs_2(this%nfc2), & - this%ampterm_2(this%nfc2)) - - allocate(this%igroup_3(this%nfc3), & - this%iatomterm_3(3,this%nfc3), & - this%ixyzterm_3(3,this%nfc3), & - this%fcs_3(this%nfc3), & - this%ampterm_3(this%nfc3)) - - allocate(this%igroup_4(this%nfc4), & - this%iatomterm_4(4,this%nfc4), & - this%ixyzterm_4(4,this%nfc4), & - this%fcs_4(this%nfc4), & - this%ampterm_4(this%nfc4)) - - this%sc_min = minval(this%ideal_struct_cell_offset,2) - this%sc_max = maxval(this%ideal_struct_cell_offset,2) - ntau = maxval(this%ideal_struct_prim_index) - - allocate(this%findatom_sc_array(ntau, this%sc_min(1):this%sc_max(1), & - this%sc_min(2):this%sc_max(2), & - this%sc_min(3):this%sc_max(3))) - - call fill_findatom_sc_array(this%findatom_sc_array, ntau, this%sc_min, this%sc_max, this%ideal_struct) - - ! - ! Read the atom_shl atoms - ! - call read(this%atom_shl, trim(this%atom_shl_file)) - call add_property(this%atom_shl, "cell_offset", value=0, n_cols=3, overwrite=.false.) - call add_property(this%atom_shl, "prim_index", value=0, n_cols=1, overwrite=.false.) - if (.not.assign_pointer(this%atom_shl, "prim_index", this%atom_shl_prim_index)) & - call system_abort("IPModel_FC4 requires 'prim_index' field in atom_shl file") - if (.not.assign_pointer(this%atom_shl, "cell_offset", this%atom_shl_cell_offset)) & - call system_abort("IPModel_FC4 requires 'cell_offset' field in atom_shl file") - - ! - ! Read the force constants - ! - call read_fcs(2, this%nfc2, trim(this%fc2_file), this%igroup_2, this%iatomterm_2, this%ixyzterm_2, this%fcs_2, this%ampterm_2) - if (this%nfc3.gt.0) call read_fcs(3, this%nfc3, trim(this%fc3_file), this%igroup_3, this%iatomterm_3, this%ixyzterm_3, this%fcs_3, this%ampterm_3) - if (this%nfc4.gt.0) call read_fcs(4, this%nfc4, trim(this%fc4_file), this%igroup_4, this%iatomterm_4, this%ixyzterm_4, this%fcs_4, this%ampterm_4) - -end subroutine IPModel_FC4_Initialise_str - -subroutine IPModel_FC4_Finalise(this) - type(IPModel_FC4), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%igroup_2)) deallocate(this%igroup_2) - if (allocated(this%iatomterm_2)) deallocate(this%iatomterm_2) - if (allocated(this%ixyzterm_2)) deallocate(this%ixyzterm_2) - if (allocated(this%fcs_2)) deallocate(this%fcs_2) - if (allocated(this%ampterm_2)) deallocate(this%ampterm_2) - - if (allocated(this%igroup_3)) deallocate(this%igroup_3) - if (allocated(this%iatomterm_3)) deallocate(this%iatomterm_3) - if (allocated(this%ixyzterm_3)) deallocate(this%ixyzterm_3) - if (allocated(this%fcs_3)) deallocate(this%fcs_3) - if (allocated(this%ampterm_3)) deallocate(this%ampterm_3) - - if (allocated(this%igroup_4)) deallocate(this%igroup_4) - if (allocated(this%iatomterm_4)) deallocate(this%iatomterm_4) - if (allocated(this%ixyzterm_4)) deallocate(this%ixyzterm_4) - if (allocated(this%fcs_4)) deallocate(this%fcs_4) - if (allocated(this%ampterm_4)) deallocate(this%ampterm_4) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_FC4_Finalise - - -subroutine IPModel_FC4_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_FC4), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer :: ia, ja, ka, la, i0, j0, k0, l0, alpha, beta, gamma, delta - integer ix - integer :: ifc, ni(3), taui, tauj - real(dp) :: disp_alpha_i, disp_beta_j, phi, de, df, fsum(3) - real(dp) :: displacement(3,at%N) - real(dp) :: local_virial_sq(3,3,at%N) - real(dp) :: local_e_tmp(at%N) - - real(dp) :: r_ij(3), com_offset(3) - integer n_extra_calcs, i_calc - character(len=20) :: extra_calcs_list(10) - - logical :: do_flux = .false. - real(dp), pointer :: velo(:,:) - real(dp) :: flux(3) -! real(dp), allocatable :: local_flux(:,:) - - INIT_ERROR(error) - -! allocate(local_flux(3,at%N)) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_FC4_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_FC4_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_FC4_Calc', error) - local_virial = 0.0_dp - endif - - if (present(args_str)) then - if (len_trim(args_str) > 0) then - n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) - if (n_extra_calcs > 0) then - do i_calc=1, n_extra_calcs - select case(trim(extra_calcs_list(i_calc))) - case("flux") - if (.not. assign_pointer(at, "velo", velo)) then - RAISE_ERROR("IPModel_LJ_Calc Flux calculation requires velo field", error) - endif - do_flux = .true. - case default - RAISE_ERROR("Unsupported extra_calc '"//trim(extra_calcs_list(i_calc))//"'", error) - end select - end do - endif ! n_extra_calcs - endif ! len_trim(args_str) - end if ! present(args_str) - - local_virial_sq = 0 - local_e_tmp = 0 - flux = 0 -! local_flux = 0 - -! Remap positions by the mean position to avoid loss of precision in -! the forces if there is a drift. Don't use 'centre_of_mass' because -! the `mass' property might not be present. Using the precise centre -! of mass is not important. - do ix=1,3 - com_offset(ix) = KahanSum( (/ (at%pos(ix,ia) - this%ideal_struct%pos(ix,ia), ia=1,at%N) /) ) / at%N - end do - - do ia=1,at%N - displacement(:,ia) = -diff_min_image(at, ia, this%ideal_struct%pos(:,ia) + com_offset) - end do - - do ia=1,at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(ia-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - taui = this%ideal_struct_prim_index(ia) ! the primitive-cell atom index (taui) - ni = this%ideal_struct_cell_offset(:,ia) ! the image cell of the atom (ni) - ! - ! second order - do ifc=1,this%nfc2 - i0 = this%iatomterm_2(1,ifc) - if (this%atom_shl_prim_index(i0).ne.taui.or.any(this%atom_shl_cell_offset(:,i0).ne.0)) cycle - - j0 = this%iatomterm_2(2,ifc) - alpha = this%ixyzterm_2(1,ifc) - beta = this%ixyzterm_2(2,ifc) - ja = findatom_sc(this, this%atom_shl_prim_index(j0), this%atom_shl_cell_offset(:,j0) + ni, at) - - phi = this%fcs_2(ifc) * this%ampterm_2(ifc) - df = -phi * displacement(beta,ja) - - if (present(local_e).or.present(e)) local_e_tmp(ia) = local_e_tmp(ia) + 0.5*phi * displacement(alpha,ia) * displacement(beta,ja) - if (present(f)) f(alpha,ia) = f(alpha,ia) + df - if (do_flux) then - r_ij = diff_min_image(at, ia, ja) - flux = flux + r_ij(:) * phi * displacement(alpha,ia) * velo(beta,ja) / 2 - end if - if (present(local_virial).or.present(virial)) then - local_virial_sq(alpha,:,ia) = local_virial_sq(alpha,:,ia) + at%pos(:,ia) * df - end if - end do - - ! - ! third order - do ifc=1,this%nfc3 - i0 = this%iatomterm_3(1,ifc) - if (this%atom_shl_prim_index(i0).ne.taui.or.any(this%atom_shl_cell_offset(:,i0).ne.0)) cycle - j0 = this%iatomterm_3(2,ifc) - k0 = this%iatomterm_3(3,ifc) - - alpha = this%ixyzterm_3(1,ifc) - beta = this%ixyzterm_3(2,ifc) - gamma = this%ixyzterm_3(3,ifc) - - ja = findatom_sc(this, this%atom_shl_prim_index(j0), this%atom_shl_cell_offset(:,j0) + ni, at) - ka = findatom_sc(this, this%atom_shl_prim_index(k0), this%atom_shl_cell_offset(:,k0) + ni, at) - - phi = this%fcs_3(ifc) * this%ampterm_3(ifc) - - df = -phi * displacement(beta,ja) * displacement(gamma,ka) / 2 - - if (present(local_e).or.present(e)) local_e_tmp(ia) = local_e_tmp(ia) + phi * displacement(alpha,ia) * displacement(beta,ja) * displacement(gamma,ka) / 6 - if (present(f)) f(alpha,ia) = f(alpha,ia) + df - if (do_flux) then - r_ij = diff_min_image(at, ia, ja) - flux = flux + r_ij(:) * phi * displacement(alpha,ia) * displacement(gamma,ka) * velo(beta,ja) / 3 - end if - if (present(local_virial).or.present(virial)) then - local_virial_sq(alpha,:,ia) = local_virial_sq(alpha,:,ia) + at%pos(:,ia) * df - end if - end do - - ! - ! fourth order - do ifc=1,this%nfc4 - i0 = this%iatomterm_4(1,ifc) - if (this%atom_shl_prim_index(i0).ne.taui.or.any(this%atom_shl_cell_offset(:,i0).ne.0)) cycle - j0 = this%iatomterm_4(2,ifc) - k0 = this%iatomterm_4(3,ifc) - l0 = this%iatomterm_4(4,ifc) - - alpha = this%ixyzterm_4(1,ifc) - beta = this%ixyzterm_4(2,ifc) - gamma = this%ixyzterm_4(3,ifc) - delta = this%ixyzterm_4(4,ifc) - - ja = findatom_sc(this, this%atom_shl_prim_index(j0), this%atom_shl_cell_offset(:,j0) + ni, at) - ka = findatom_sc(this, this%atom_shl_prim_index(k0), this%atom_shl_cell_offset(:,k0) + ni, at) - la = findatom_sc(this, this%atom_shl_prim_index(l0), this%atom_shl_cell_offset(:,l0) + ni, at) - - phi = this%fcs_4(ifc) * this%ampterm_4(ifc) - - df = -phi * displacement(beta,ja) * displacement(gamma,ka) * displacement(delta,la) / 6 - if (present(local_e).or.present(e)) local_e_tmp(ia) = local_e_tmp(ia) + & - phi * displacement(alpha,ia) * displacement(beta,ja) * displacement(gamma,ka) * displacement(delta,la) / 24 - if (present(f)) f(alpha,ia) = f(alpha,ia) + df - if (do_flux) then - ! distance between current positions of atoms i and j (same meaning as the anh_md code) - r_ij = diff_min_image(at, ia, ja) -! local_flux(:,ia) = local_flux(:,ia) + r_ij * phi * displacement(alpha,ia) * displacement(gamma,ka) * displacement(delta,la) * velo(beta,ja) / 8 - flux = flux + r_ij(:) * phi * displacement(alpha,ia) * displacement(gamma,ka) * displacement(delta,la) * velo(beta,ja) / 8 - end if - !if (present(local_virial).or.present(virial)) then - local_virial_sq(alpha,:,ia) = local_virial_sq(alpha,:,ia) + at%pos(:,ia) * df - !local_virial_sq(alpha,:,ja) = local_virial_sq(alpha,:,ja) + at%pos(:,ia) * df / 4 - !local_virial_sq(alpha,:,ka) = local_virial_sq(alpha,:,ka) + at%pos(:,ia) * df / 4 - !local_virial_sq(alpha,:,la) = local_virial_sq(alpha,:,la) + at%pos(:,ia) * df / 4 - !end if - end do - end do - - if (present(local_virial)) local_virial = reshape(local_virial_sq, (/ 9, at%N /)) - if (present(virial)) virial = sum(local_virial_sq,3) - if (present(local_e)) local_e = local_e_tmp - if (present(e)) e = KahanSum(local_e_tmp) - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(virial)) call sum_in_place(mpi, local_virial) - if (present(f)) call sum_in_place(mpi, f) - endif - if (present(f)) then - do ix=1,3 - fsum(ix) = KahanSum(f(ix,:)) / at%N - end do - do ia=1,at%N - f(:,ia) = f(:,ia) - fsum - end do - end if - - - if (do_flux) then - if (present(mpi)) call sum_in_place(mpi, flux) -! local_flux = local_flux / cell_volume(at) -! flux = sum(local_flux,2) - flux = flux / cell_volume(at) - call set_value(at%params, "Flux", flux) - end if - -end subroutine IPModel_FC4_Calc - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - integer atnum_i, atnum_j, fc_i, ti, tj, max_n_fcs, ti_a(1) - - if (name == 'FC4_params') then ! new FC4 stanza - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered FC4_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in FC4_params") - endif - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if (status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort("Can't find cutoff in FC4_params") - endif - - call QUIP_FoX_get_value(attributes, 'nfc2', value, status) - if (status == 0) then - read (value, *) parse_ip%nfc2 - else - call system_abort("Can't find nfc2 in FC4_params") - endif - call QUIP_FoX_get_value(attributes, 'nfc2_indep', value, status) - if (status == 0) then - read (value, *) parse_ip%nfc2_indep - else - parse_ip%nfc2_indep = parse_ip%nfc2 - endif - - call QUIP_FoX_get_value(attributes, 'nfc3', value, status) - if (status == 0) then - read (value, *) parse_ip%nfc3 - else - parse_ip%nfc3 = 0 - endif - call QUIP_FoX_get_value(attributes, 'nfc3_indep', value, status) - if (status == 0) then - read (value, *) parse_ip%nfc3_indep - else - parse_ip%nfc3_indep = parse_ip%nfc3 - endif - - call QUIP_FoX_get_value(attributes, 'nfc4', value, status) - if (status == 0) then - read (value, *) parse_ip%nfc4 - else - parse_ip%nfc4 = 0 - endif - call QUIP_FoX_get_value(attributes, 'nfc4_indep', value, status) - if (status == 0) then - read (value, *) parse_ip%nfc4_indep - else - parse_ip%nfc4_indep = parse_ip%nfc4 - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - endif ! parse_in_ip - elseif (parse_in_ip .and. name == 'FC4') then - - call QUIP_FoX_get_value(attributes, "atnum_i", value, status) - if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find atnum_i") - read (value, *) atnum_i - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find atnum_j") - read (value, *) atnum_j - call QUIP_FoX_get_value(attributes, "fc_i", value, status) - if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find fc_i") - read (value, *) fc_i - - ! if (all(parse_ip%atomic_num /= atnum_i)) then - ! ti_a = minloc(parse_ip%atomic_num) - ! parse_ip%atomic_num(ti_a(1)) = atnum_i - ! endif - ! if (all(parse_ip%atomic_num /= atnum_j)) then - ! ti_a = minloc(parse_ip%atomic_num) - ! parse_ip%atomic_num(ti_a(1)) = atnum_j - ! endif - ! if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - ! allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - ! parse_ip%type_of_atomic_num = 0 - ! do ti=1, parse_ip%n_types - ! if (parse_ip%atomic_num(ti) > 0) & - ! parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - ! end do - - ! ti = parse_ip%type_of_atomic_num(atnum_i) - ! tj = parse_ip%type_of_atomic_num(atnum_j) - - ! call QUIP_FoX_get_value(attributes, "r0", value, status) - ! if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find r0") - ! read (value, *) parse_ip%r0(ti,tj,fc_i) - ! call QUIP_FoX_get_value(attributes, "phi2", value, status) - ! if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find phi2") - ! read (value, *) parse_ip%phi2(ti,tj,fc_i) - ! call QUIP_FoX_get_value(attributes, "phi3", value, status) - ! if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find phi3") - ! read (value, *) parse_ip%phi3(ti,tj,fc_i) - ! call QUIP_FoX_get_value(attributes, "phi4", value, status) - ! if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find phi4") - ! read (value, *) parse_ip%phi4(ti,tj,fc_i) - - ! if (ti /= tj) then - ! parse_ip%r0(tj,ti,fc_i) = parse_ip%r0(ti,tj,fc_i) - ! parse_ip%phi2(tj,ti,fc_i) = parse_ip%phi2(ti,tj,fc_i) - ! parse_ip%phi3(tj,ti,fc_i) = parse_ip%phi3(ti,tj,fc_i) - ! parse_ip%phi4(tj,ti,fc_i) = parse_ip%phi4(ti,tj,fc_i) - ! endif - - endif ! parse_in_ip .and. name = 'FC4' - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'FC4_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_FC4_read_params_xml(this, param_str) - type(IPModel_FC4), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_FC4_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_FC4_read_params_xml - - -subroutine IPModel_FC4_Print(this, file) - type(IPModel_FC4), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_FC4 : FC4 Potential", file=file) - call Print("IPModel_FC4 : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - call Print("IPModel_FC4 : label = " // this%label, file=file) - - do ti=1, this%n_types - call Print ("IPModel_FC4 : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_FC4 : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_FC4_Print - -function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) - character(len=*), intent(in) :: args_str - character(len=*), intent(out) :: extra_calcs_list(:) - integer :: n_extra_calcs - - character(len=STRING_LENGTH) :: extra_calcs_str - type(Dictionary) :: params - - n_extra_calcs = 0 - call initialise(params) - call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") - if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then - if (len_trim(extra_calcs_str) > 0) then - call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") - end if - end if - call finalise(params) - -end function parse_extra_calcs - -! subroutine read_fc2(nfc2, file, igroup_2, iatomterm_2, ixyzterm_2, ampterm_2, fcs_2) -! character(len=*), intent(in) :: file -! integer, intent(in) :: nfc2 - -! integer, intent(out) :: igroup_2(nfc2) -! integer, intent(out) :: iatomterm_2(2,nfc2) -! integer, intent(out) :: ixyzterm_2(2,nfc2) -! real(dp), intent(out) :: fcs_2(nfc2) -! real(dp), intent(out) :: ampterm_2(nfc2) - -! integer t,i ! ,mx -! character(len=999) line - -! integer, parameter :: iunit = 1111 -! open(unit=iunit, file=file) - -! read(iunit,'(a)') line -! do i=1,nfc2 -! read (iunit,*,err=92) t,igroup_2(i), & -! iatomterm_2(1,i),ixyzterm_2(1,i),iatomterm_2(2,i),ixyzterm_2(2,i), & -! fcs_2(i),ampterm_2(i) -! end do -! return -! 92 call system_abort("IPModel_FC4_Initialise_str: End of file while reading second order force constants from "//file//", after t="//t) -! end subroutine read_fc2 - -subroutine read_fcs(rank, nfc, file, igroup, iatomterm, ixyzterm, ampterm, fcs) - integer, intent(in) :: rank, nfc - character(len=*), intent(in) :: file - - integer, intent(out) :: igroup(nfc) - integer, intent(out) :: iatomterm(rank,nfc) - integer, intent(out) :: ixyzterm(rank,nfc) - real(dp), intent(out) :: fcs(nfc) - real(dp), intent(out) :: ampterm(nfc) - - integer t,i,r ! ,mx - character(len=999) line - - integer, parameter :: iunit = 1111 - - open(unit=iunit, file=file) - - read (iunit,'(a)') line - read (iunit,*,err=92,end=92) (t,igroup(i), (iatomterm(r,i), ixyzterm(r,i), r=1,rank), fcs(i), ampterm(i), i=1,nfc) - return -92 call system_abort("IPModel_FC4_Initialise_str: End of file while reading force constants from "//file//", after t="//t) -end subroutine read_fcs - -subroutine fill_findatom_sc_array(findatom_sc_array, ntau, mn, mx, at) - integer, intent(in) :: ntau, mn(3), mx(3) - type(Atoms), intent(in) :: at ! check: should have 'n(3)' and 'tau' field - integer, intent(out) :: findatom_sc_array(ntau,mn(1):mx(1),mn(2):mx(2),mn(3):mx(3)) - - integer, pointer :: prim_index(:) - integer, pointer :: cell_offset(:,:) - - integer i - - if(.not.assign_pointer(at, "prim_index", prim_index)) & - call system_abort("IPModel_FC4 requires 'prim_index' field") - if(.not.assign_pointer(at, "cell_offset", cell_offset)) & - call system_abort("IPModel_FC4 requires 'cell_offset' field") - - findatom_sc_array = -1 - do i=1,at%N - findatom_sc_array(prim_index(i), cell_offset(1,i), cell_offset(2,i), cell_offset(3,i)) = i - end do -end subroutine fill_findatom_sc_array - -function findatom_sc(this, tau, n, at) - integer findatom_sc - type(IPModel_FC4), intent(in) :: this - integer, intent(in) :: tau, n(3) ! the primitive cell index and offset - type(Atoms), intent(in) :: at - integer nwrap(3), nsc(3), tau_sc_idx - real(dp) :: wrap(3), prim_cell_pos(3), prim_cell(3,3), inv_prim_cell(3,3), tau_prim(3), tau_frac(3), tau_frac_remap(3), n_frac(3) - - namelist/NMLDEBUG/tau,n,prim_cell,inv_prim_cell,tau_sc_idx,tau_prim,tau_frac,tau_frac_remap,prim_cell_pos,wrap,nwrap - -! Common case: just see if it is in the array - if (all(n.ge.this%sc_min.and.n.le.this%sc_max)) then - findatom_sc = this%findatom_sc_array(tau,n(1),n(2),n(3)) - if (findatom_sc.ge.0) return - end if - -! Otherwise, try to wrap it - - ! the primitive cell - prim_cell = this%ideal_struct%lattice - inv_prim_cell = this%ideal_struct%g - - tau_sc_idx = this%findatom_sc_array(tau,0,0,0) - tau_prim = this%ideal_struct%pos(:,tau_sc_idx) - - ! express the primitive cell we asked for as a fractional - ! coordinates of the simulation box. - tau_frac = matmul(this%inv_superlattice, matmul(prim_cell, n) + tau_prim) - - ! remap to [0,1) - tau_frac_remap = modulo(tau_frac, 1.0_dp) - - prim_cell_pos = matmul(this%superlattice, tau_frac_remap) - tau_prim - - ! find the offset of the primitive cell this location coresponds to - wrap = matmul(inv_prim_cell, prim_cell_pos) - if (any(abs(modulo(wrap+0.5_dp,1.0_dp)-0.5_dp).gt.1D-6)) then - write (*,'(2(3F18.12,x))') modulo(wrap,1.0_dp), wrap - call system_abort("Findatom_sc: got fractional box!") - endif - - nwrap = nint(wrap) - - findatom_sc = this%findatom_sc_array(tau,nwrap(1),nwrap(2),nwrap(3)) - - ! express in terms of primitive cell coords - - if (findatom_sc < 0) then - write (*,nml=NMLDEBUG) - call system_abort("Findatom_sc: requested atom tau=" // tau & - // ", n=" // n // " does not exist in the supercell") - end if - -end function findatom_sc - -end module IPModel_FC4_module diff --git a/src/Potentials/IPModel_FS.f95 b/src/Potentials/IPModel_FS.f95 deleted file mode 100644 index 9a09e19a2c..0000000000 --- a/src/Potentials/IPModel_FS.f95 +++ /dev/null @@ -1,589 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_FS module -!X -!% Module for Finnis-Sinclair embedded-atom potential -!% (Ref. Philosophical Magazine A, {\bf 50}, 45 (1984)). -!% -!% The IPModel_FS object contains all the parameters read from a -!% 'FS_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_FS_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_VERBOSE, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_FS -type IPModel_FS - integer :: n_types = 0 !% Number of atomic types. - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - real(dp), allocatable :: c(:,:), c0(:,:), c1(:,:), c2(:,:) - real(dp), allocatable :: A(:,:), beta(:,:), d(:,:) - - character(len=STRING_LENGTH) :: label - -end type IPModel_FS - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_FS), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_FS_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_FS_Finalise -end interface Finalise - -interface Print - module procedure IPModel_FS_Print -end interface Print - -interface Calc - module procedure IPModel_FS_Calc -end interface Calc - -contains - -subroutine IPModel_FS_Initialise_str(this, args_str, param_str) - type(IPModel_FS), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label = '' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FS_Initialise_str args_str')) then - call system_abort("IPModel_FS_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_FS_read_params_xml(this, param_str) - -! Two cutoff radius: this%d > this%c - this%cutoff = maxval(this%d) - -end subroutine IPModel_FS_Initialise_str - -subroutine IPModel_FS_Finalise(this) - type(IPModel_FS), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%c)) deallocate(this%c) - if (allocated(this%c0)) deallocate(this%c0) - if (allocated(this%c1)) deallocate(this%c1) - if (allocated(this%c2)) deallocate(this%c2) - if (allocated(this%A)) deallocate(this%A) - if (allocated(this%beta)) deallocate(this%beta) - if (allocated(this%d)) deallocate(this%d) - - this%n_types = 0 - this%label = '' - -end subroutine IPModel_FS_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_FS_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_FS), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer i, ji, j, ti, tj - real(dp) :: rij(3), rij_mag, drij(3) - real(dp) :: phi_tot, sqrt_phi_tot - real(dp) :: Ui, dU - - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - ! private variables for open-mp - real(dp) :: private_virial(3,3), private_e, virial_i(3,3) - real(dp), allocatable, dimension(:,:) :: private_f - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_FS_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_FS_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_FS_Calc', error) - local_virial = 0.0_dp - endif - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_FS_Calc args_str')) then - RAISE_ERROR("IPModel_FS_Calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then - RAISE_ERROR("IPModel_FS_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - else - do_rescale_r = .false. - do_rescale_E = .false. - endif - - if (do_rescale_r) call print('IPModel_Tersoff_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) - if (do_rescale_E) call print('IPModel_Tersoff_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) - -!$omp parallel private(i,ji,j,ti,tj,phi_tot,sqrt_phi_tot,dU,Ui,drij,rij_mag,private_virial, virial_i,private_f,private_e) - - if (present(e)) private_e = 0.0_dp - if (present(virial)) private_virial = 0.0_dp - if (present(f)) then - allocate(private_f(3,at%N)) - private_f = 0.0_dp - endif - -!$omp do - do i=1, at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - phi_tot = 0.0_dp - - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, rij_mag) - if (rij_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) rij_mag = rij_mag*r_scale - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - phi_tot = phi_tot + this%A(ti,tj) * this%A(ti,tj) * phi_ij(this, ti, tj, rij_mag) - enddo - - sqrt_phi_tot = dsqrt(phi_tot) - - if (present(e)) then - private_e = private_e - sqrt_phi_tot - endif - if (present(local_e)) then - local_e(i) = local_e(i) - sqrt_phi_tot - endif - - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, rij_mag, cosines = drij) - if (rij_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) rij_mag = rij_mag*r_scale - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (present(e) .or. present(local_e)) then - Ui = 0.5_dp * Vij(this, ti, tj, rij_mag) - if (present(local_e)) then - local_e(i) = local_e(i) + Ui - endif - if (present(e)) then - private_e = private_e + Ui - endif - endif - - if (present(f) .or. present(virial)) then - - dU = 0.5_dp * dVij(this, ti, tj, rij_mag) - this%A(ti,tj) * this%A(ti,tj) * dphi_ij(this, ti, tj, rij_mag) / 2.0_dp / sqrt_phi_tot - - if (present(f)) then - private_f(:,i) = private_f(:,i) + dU * drij(:) - private_f(:,j) = private_f(:,j) - dU * drij(:) - endif - if (present(virial).or.present(local_virial)) virial_i = dU*(drij .outer. drij)*rij_mag - if (present(virial)) private_virial = private_virial - virial_i - if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) - endif - - end do - - end do - -!$omp critical - if(present(e)) e = e + private_e - if(present(virial)) virial = virial + private_virial - if(present(f)) f = f + private_f -!$omp end critical - - if(allocated(private_f)) deallocate(private_f) -!$omp end parallel - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) call sum_in_place(mpi, f) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(local_virial)) call sum_in_place(mpi, local_virial) - endif - - if (do_rescale_r) then - if (present(f)) f = f*r_scale - end if - - if (do_rescale_E) then - if (present(e)) e = e*E_scale - if (present(local_e)) local_e = local_e*E_scale - if (present(f)) f = f*E_scale - if (present(virial)) virial=virial*E_scale - if (present(local_virial)) local_virial=local_virial*E_scale - end if - -end subroutine IPModel_FS_Calc - -function Vij(this, ti, tj, r) - type(IPModel_FS), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r - real(dp) :: Vij - - if ((r .feq. 0.0_dp) .or. (r > this%c(ti,tj))) then - Vij = 0.0 - return - endif - - Vij = (r - this%c(ti,tj))*(r - this%c(ti,tj))*(this%c0(ti,tj) + r * this%c1(ti,tj) + r * r * this%c2(ti,tj) ) - -end function Vij - - -function dVij(this, ti, tj, r) - type(IPModel_FS), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r - real(dp) :: dVij - - if ((r .feq. 0.0_dp) .or. (r > this%c(ti,tj))) then - dVij = 0.0 - return - endif - - dVij = 2.0_dp * (r - this%c(ti,tj))*(this%c0(ti,tj) + r * this%c1(ti,tj) + r * r * this%c2(ti,tj)) + & - (r - this%c(ti,tj))*(r - this%c(ti,tj))*(this%c1(ti,tj) + 2.0_dp * r * this%c2(ti,tj)) -end function dVij - - -function phi_ij(this, ti, tj, r) - type(IPModel_FS), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r - real(dp) :: num - real(dp) :: phi_ij - - if ((r .feq. 0.0_dp) .or. (r > this%d(ti,tj))) then - phi_ij = 0.0 - return - endif - - num = r - this%d(ti,tj) - phi_ij = num * num + this%beta(ti,tj) * (num * num * num) / this%d(ti,tj) - -end function phi_ij - -function dphi_ij(this, ti, tj, r) - type(IPModel_FS), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: r - real(dp) :: num - real(dp) :: dphi_ij - - if ((r .feq. 0.0_dp) .or. (r > this%d(ti,tj))) then - dphi_ij = 0.0 - return - endif - - num = r - this%d(ti,tj) - dphi_ij = 2.0_dp * num + 3.0_dp * this%beta(ti,tj) * (num * num) / this%d(ti,tj) - -end function dphi_ij - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - integer ti, tj - - if (name == 'FS_params') then ! new FS stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in FS_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%c(parse_ip%n_types,parse_ip%n_types)) - parse_ip%c = 0.0_dp - allocate(parse_ip%c0(parse_ip%n_types,parse_ip%n_types)) - parse_ip%c0 = 0.0_dp - allocate(parse_ip%c1(parse_ip%n_types,parse_ip%n_types)) - parse_ip%c1 = 0.0_dp - allocate(parse_ip%c2(parse_ip%n_types,parse_ip%n_types)) - parse_ip%c2 = 0.0_dp - allocate(parse_ip%A(parse_ip%n_types,parse_ip%n_types)) - parse_ip%A = 0.0_dp - allocate(parse_ip%beta(parse_ip%n_types,parse_ip%n_types)) - parse_ip%beta = 0.0_dp - allocate(parse_ip%d(parse_ip%n_types,parse_ip%n_types)) - parse_ip%d = 0.0_dp - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "type1", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find type1") - read (value, *) ti - call QUIP_FoX_get_value(attributes, "type2", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find type2") - read (value, *) tj - - call QUIP_FoX_get_value(attributes, "c", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find c") - read (value, *) parse_ip%c(ti,tj) - call QUIP_FoX_get_value(attributes, "c0", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find c0") - read (value, *) parse_ip%c0(ti,tj) - call QUIP_FoX_get_value(attributes, "c1", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find c1") - read (value, *) parse_ip%c1(ti,tj) - call QUIP_FoX_get_value(attributes, "c2", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find c2") - read (value, *) parse_ip%c2(ti,tj) - call QUIP_FoX_get_value(attributes, "A", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find A") - read (value, *) parse_ip%A(ti,tj) - call QUIP_FoX_get_value(attributes, "beta", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find beta") - read (value, *) parse_ip%beta(ti,tj) - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find d") - read (value, *) parse_ip%d(ti,tj) - - if (ti /= tj) then - parse_ip%c(tj,ti) = parse_ip%c(ti,tj) - parse_ip%c0(tj,ti) = parse_ip%c0(ti,tj) - parse_ip%c1(tj,ti) = parse_ip%c1(ti,tj) - parse_ip%c2(tj,ti) = parse_ip%c2(ti,tj) - parse_ip%A(tj,ti) = parse_ip%A(ti,tj) - parse_ip%beta(tj,ti) = parse_ip%beta(ti,tj) - parse_ip%d(tj,ti) = parse_ip%d(ti,tj) - end if - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'FS_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_FS_read_params_xml(this, param_str) - type(IPModel_FS), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_FS_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_FS_read_params_xml - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X printing -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_FS_Print (this, file) - type(IPModel_FS), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_FS : Finnis-Sinclair", file=file) - call Print("IPModel_FS : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_FS : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - do tj=1, this%n_types - call Print ("IPModel_FS : interaction " // ti // " " // tj // " c, c0, c1, c2 " // this%c(ti,tj) // " " // & - this%c0(ti,tj) // " " // this%c1(ti,tj) // " " // this%c2(ti,tj) // " " // & - " d " // this%d(ti,tj) // " " // & - " A " // this%a(ti,tj) // " " // " beta " // & - this%beta(ti,tj), file=file) - end do - call verbosity_pop() - end do - -end subroutine IPModel_FS_Print - -end module IPModel_FS_module diff --git a/src/Potentials/IPModel_FX.f95 b/src/Potentials/IPModel_FX.f95 deleted file mode 100644 index ba660c0ba6..0000000000 --- a/src/Potentials/IPModel_FX.f95 +++ /dev/null @@ -1,367 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_FX -!X -!% polarisable water model -!% G. S. Fanourgakis and S. S. Xantheas, Journal of Chemical Physics 128, 074506 (2008) -!% This is a wrapper for a code downloaded from http://www.pnl.gov/science/ttm3f.asp -!% WARNING: it does not deal with periodic boundary conditions -!% UNITS: KCal/mol for energies and Angstroms for distance for the original FX code, of course the QUIP calculator converts to eVs. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_FX_module - -use error_module -use system_module, only : dp, inoutput, print, operator(//) -use units_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use spline_module -use atoms_types_module -use atoms_module -use topology_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_FX -type IPModel_FX - real(dp) :: cutoff = 2.0_dp - logical :: return_one_body = .false. - logical :: return_two_body = .false. - real(dp) :: two_body_weight_roo = 0.0_dp - real(dp) :: two_body_weight_delta = 0.0_dp - logical :: do_two_body_weight = .false. - type(Spline) :: two_body_weight - logical :: OHH_ordercheck = .true. - real(dp) :: E_scale - ! some modifiable FX parameters, defaults are from the FX source code - real(dp) :: polarM=1.444_dp - real(dp) :: vdwC=-0.72298855E+03_dp,vdwD=0.10211829E+06_dp, vdwE=0.37170376E+01_dp -end type IPModel_FX - - -interface Initialise - module procedure IPModel_FX_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_FX_Finalise -end interface Finalise - -interface Print - module procedure IPModel_FX_Print -end interface Print - -interface Calc - module procedure IPModel_FX_Calc -end interface Calc - -contains - -subroutine IPModel_FX_Initialise_str(this, args_str, param_str, error) - type(IPModel_FX), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out) :: error - - INIT_ERROR(error) - - call Finalise(this) - -#ifndef HAVE_FX - RAISE_ERROR('IPModel_FX_Calc: FX model was not compiled in. Check the HAVE_FX flag in the Makefiles.', error) -#else - - call initialise(params) - call param_register(params, 'return_two_body', 'F', this%return_two_body, help_string="if set, return the two_body energy and force as the main return data") - call param_register(params, 'return_one_body', 'F', this%return_one_body, help_string="if set, return the one_body energy and force as the main return data") - call param_register(params, 'two_body_weight_roo', '0.0', this%two_body_weight_roo, has_value_target=this%do_two_body_weight, help_string="if set, apply weight function to 2-body energy and force based on O-O distance. For a positive two_body_weight_delta, weight is 1 for rOO < two_body_weight_roo-two_body_weight_delta and weight is 0 for rOO > two_body_weight_roo+two_body_weight_delta") - call param_register(params, 'two_body_weight_delta', '0.25', this%two_body_weight_delta, help_string="width of weighting function for two_body energy and force based on O-O distance. For weighting to take effect, two_body_weight_roo needs to be explicitly set. For a positive two_body_weight_delta, weight is 1 for rOO < two_body_weight_roo-two_body_weight_delta and weight is 0 for rOO > two_body_weight_roo+two_body_weight_delta") - call param_register(params, 'OHH_ordercheck', 'T', this%OHH_ordercheck, help_string="if FALSE, skip transforming atomic order to OHHOHHOHH... and assume atoms are in that order. This also skips cutoff checking for OH bonds. default: TRUE") - call param_register(params, 'E_scale', '1.0', this%E_scale, 'Scale the potential by this factor') - call param_register(params, 'polarM', '1.444', this%polarM, help_string="polarisability on the M site") - call param_register(params, 'vdwC', '-0.72298855E+03', this%vdwC, help_string="vdwC parameter") - call param_register(params, 'vdwD', '0.10211829E+06', this%vdwD, help_string="vdwD parameter") - call param_register(params, 'vdwE', '0.37170376E+01', this%vdwE, help_string="vdwE parameter") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FX_Initialise args_str')) then - RAISE_ERROR("IPModel_FX_Init failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if(this%do_two_body_weight) then - call initialise(this%two_body_weight, (/this%two_body_weight_roo - this%two_body_weight_delta, this%two_body_weight_roo + this%two_body_weight_delta/), (/1.0_dp, 0.0_dp/), 0.0_dp, 0.0_dp) - end if -#endif -end subroutine IPModel_FX_Initialise_str - -subroutine IPModel_FX_Finalise(this) - type(IPModel_FX), intent(inout) :: this -end subroutine IPModel_FX_Finalise - - -subroutine IPModel_FX_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_FX), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), dimension(3,at%N) :: RR, dRR - real(dp) :: energy - integer, dimension(at%N) :: rindex - integer :: i, j, k, kk, Oi, Oj - - type(Dictionary) :: params - logical :: has_atom_mask_name, do_one_body, do_two_body - character(STRING_LENGTH) :: atom_mask_name, one_body_name, two_body_name - logical :: OHH_ordercheck = .true., do_OHH_ordercheck - - integer, dimension(:,:), allocatable :: water_monomer_index - real(dp), allocatable :: one_body_energy(:), one_body_force(:,:), two_body_force(:,:) - real(dp) :: watpos(3,3), wat2pos(3,6), watRR(3,3), watdRR(3,3), wat2RR(3,6), wat2dRR(3,6), wat2_force(3,6) - real(dp) :: two_body_energy, diff_OiOj(3), watE, wat2E, two_body_energy_ij - integer :: wat_rindex(3), wat2_rindex(6), watZ(3), wat2Z(6) - real(dp):: weight, dweight(3), rOiOj - - INIT_ERROR(error) - -#ifndef HAVE_FX - RAISE_ERROR('IPModel_FX_Calc: FX model was not compiled in. Check the HAVE_FX flag in the Makefiles.', error) -#else - - if(present(local_e)) then - RAISE_ERROR('IPModel_FX_Calc: local_e calculation requested but not supported yet.', error) - end if - if(present(virial)) then - RAISE_ERROR('IPModel_FX_Calc: virial calculation requested but not supported yet.', error) - end if - if (present(local_virial)) then - RAISE_ERROR("IPModel_FX_Calc: local_virial calculation requested but not supported yet.", error) - endif - - if(.not. present(e) .and. .not. present(f)) return ! nothing to do - - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy: nb326 $") - call param_register(params, 'one_body', 'one_body', one_body_name, has_value_target=do_one_body, help_string="compute one-body terms of the cluster expansion and store it using this name") - call param_register(params, 'two_body', 'two_body', two_body_name, has_value_target=do_two_body, help_string="compute two-body terms of the cluster expansion and store it using this name") - call param_register(params, 'OHH_ordercheck', 'T', OHH_ordercheck, has_value_target=do_OHH_ordercheck, help_string="if FALSE, skip transforming atomic order to OHHOHHOHH... and assume atoms are in that order. This also skips cutoff checking for OH bonds.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FX_Calc args_str')) then - RAISE_ERROR("IPModel_FX_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_FX_Calc: atom_mask_name found, but not supported', error) - endif - endif - - - if(do_OHH_ordercheck) then - do_OHH_ordercheck = OHH_ordercheck - else - do_OHH_ordercheck = this%OHH_ordercheck - end if - - call nttm3f_readXYZ(at%N/3, at%Z, at%pos, RR, rindex, do_OHH_ordercheck) - call ttm3f(at%N/3,RR, dRR, energy, this%polarM, this%vdwC, this%vdwD, this%vdwE) - - - if(present(e)) e=energy * KCAL_MOL * this%E_scale - if(present(f)) then - do i=1,at%N - f(:,i)=-dRR(:,rindex(i)) * KCAL_MOL * this%E_scale - end do - end if - - ! cluster expansion - - - if(do_one_body .or. do_two_body .or. this%return_one_body .or. this%return_two_body) then - - allocate(water_monomer_index(3,at%N/3)) - - call find_water_monomer(at,water_monomer_index, OHH_ordercheck=do_OHH_ordercheck,error=error) - PASS_ERROR(error) - - allocate(one_body_energy(at%N/3)) - allocate(one_body_force(3,at%N)) - ! compute monomer energies and forces - do i=1,at%N/3 - Oi = water_monomer_index(1,i) - watpos(:,1) = at%pos(:,Oi) - watZ(1) = 8 ! Oxygen - watpos(:,2) = at%pos(:,Oi)+diff_min_image(at, Oi, water_monomer_index(2,i)) - watpos(:,3) = at%pos(:,Oi)+diff_min_image(at, Oi, water_monomer_index(3,i)) - watZ(2:3) = 1 ! Hydrogens - - call nttm3f_readXYZ(1, watZ, watpos, watRR, wat_rindex, do_OHH_ordercheck) - call ttm3f(1, watRR, watdRR, watE, this%polarM, this%vdwC, this%vdwD, this%vdwE) - one_body_energy(i) = watE*KCAL_MOL*this%E_scale - do k=1,3 - one_body_force(:,water_monomer_index(k,i)) = -watdRR(:,wat_rindex(k)) * KCAL_MOL * this%E_scale - end do - end do - - ! if one body terms were asked for, store them - if(this%return_one_body) then - if(present(e)) then - e = sum(one_body_energy) - end if - if(present(f)) then - f = one_body_force - end if - end if - - if(do_one_body) then - call set_value(at%params, trim(one_body_name)//"_energy", sum(one_body_energy)) - call add_property(at, trim(one_body_name)//"_force", one_body_force) - end if - - ! compute dimer energies and forces - if(do_two_body .or. this%return_two_body) then - allocate(two_body_force(3,at%N)) - two_body_energy = 0.0_dp - two_body_force = 0.0_dp - do i=1,at%N/3 - do j=i+1,at%N/3 - Oi = water_monomer_index(1,i) - Oj = water_monomer_index(1,j) - wat2pos(:,1) = at%pos(:,Oi) - wat2Z(1) = 8 ! first Oxygen - wat2pos(:,2) = at%pos(:,Oi) + diff_min_image(at, Oi, water_monomer_index(2,i)) - wat2pos(:,3) = at%pos(:,Oi) + diff_min_image(at, Oi, water_monomer_index(3,i)) - wat2Z(2:3) = 1 ! first Hydrogens - diff_OiOj = diff_min_image(at, Oi, Oj) - wat2pos(:,4) = at%pos(:,Oi) + diff_OiOj - wat2Z(4) = 8 ! second Oxygen - wat2pos(:,5) = at%pos(:,Oi) + diff_OiOj+diff_min_image(at, Oj, water_monomer_index(2,j)) - wat2pos(:,6) = at%pos(:,Oi) + diff_OiOj+diff_min_image(at, Oj, water_monomer_index(3,j)) - wat2Z(5:6) = 1 ! first Hydrogens - - call nttm3f_readXYZ(2, wat2Z, wat2pos, wat2RR, wat2_rindex, do_OHH_ordercheck) - call ttm3f(2, wat2RR, wat2dRR, wat2E, this%polarM, this%vdwC, this%vdwD, this%vdwE) - - rOiOj = norm(diff_OiOj) - if(this%do_two_body_weight) then - weight = spline_value(this%two_body_weight, rOiOj) - dweight = spline_deriv(this%two_body_weight, rOiOj) - else - weight = 1.0_dp - dweight = 0.0_dp - end if - - two_body_energy_ij = (wat2E * KCAL_MOL * this%E_scale - one_body_energy(i) - one_body_energy(j)) - two_body_energy = two_body_energy + two_body_energy_ij*weight - - do k=1,6 - wat2_force(:,k) = -wat2dRR(:,wat2_rindex(k)) * KCAL_MOL * this%E_scale - end do - do k=1,3 - kk = water_monomer_index(k, i) - two_body_force(:,kk) = two_body_force(:,kk) + (wat2_force(:,k)-one_body_force(:,kk))*weight - if(k==1) two_body_force(:,kk) = two_body_force(:,kk) + two_body_energy_ij*dweight*diff_OiOj/rOiOj - - kk = water_monomer_index(k, j) - two_body_force(:,kk) = two_body_force(:,kk) + (wat2_force(:,3+k)-one_body_force(:,kk))*weight - if(k==1) two_body_force(:,kk) = two_body_force(:,kk) - two_body_energy_ij*dweight*diff_OiOj/rOiOj - end do - end do - end do - - if(this%return_two_body) then - if(present(e)) then - e = two_body_energy - end if - if(present(f)) then - f = two_body_force - end if - end if - - ! store two-body terms - if(do_two_body) then - call set_value(at%params, trim(two_body_name)//"_energy", two_body_energy) - call add_property(at, trim(two_body_name)//"_force", two_body_force) - end if - end if - endif - -#endif - -end subroutine IPModel_FX_Calc - - -subroutine IPModel_FX_Print(this, file) - type(IPModel_FX), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - call Print("IPModel_FX : ", file=file) - -#ifndef HAVE_FX - call Print(" not compiled in. Check the HAVE_FX flag in the Makefiles.", file=file) -#else - call print("polarisable model for water", file=file) - call print("by G. S. Fanourgakis and S. S. Xantheas", file=file) - call print("Journal of Chemical Physics 128, 074506 (2008)", file=file) - if(this%return_two_body) then - call print("Returning 2-body term as a result of calc()", file=file) - end if - if(this%return_one_body) then - call print("Returning 1-body term as a result of calc()", file=file) - end if - if(this%do_two_body_weight) then - call print("Two-body term is weighted with parameters x0="//this%two_body_weight_roo//" delta="//this%two_body_weight_delta, file=file) - end if - if(this%OHH_ordercheck) then - call print("Performing reordering of atoms into OHHOHH.. order and checking O-H cutoff distances") - else - call print("SKIPPING reordering of atoms into OHHOHH.. order and checking O-H cutoff distances") - end if -#endif -end subroutine IPModel_FX_Print - - -end module IPModel_FX_module diff --git a/src/Potentials/IPModel_GAP.f95 b/src/Potentials/IPModel_GAP.f95 deleted file mode 100644 index 1352d5c6dd..0000000000 --- a/src/Potentials/IPModel_GAP.f95 +++ /dev/null @@ -1,987 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_GAP module -!X -!% Module for Gaussian Approximation Potential. -!% -!% The IPModel_GAP object contains all the parameters read from a -!% 'GAP_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_GAP_module - -use error_module -use system_module, only : dp, inoutput, string_to_int, reallocate, system_timer , print, PRINT_NERD -use dictionary_module -use periodictable_module, only: total_elements -use extendable_str_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -#ifdef HAVE_GAP -use descriptors_module -use gp_predict_module -#endif - -implicit none - -private - -include 'IPModel_interface.h' - -#ifdef GAP_VERSION - integer, parameter :: gap_version = GAP_VERSION -#else - integer, parameter :: gap_version = 0 -#endif - -! this stuff is here for now, but it should live somewhere else eventually -! lower down in the GP - -public :: IPModel_GAP - -type IPModel_GAP - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - real(dp) :: E_scale = 0.0_dp !% scale factor for the potential - - ! bispectrum parameters - integer :: j_max = 0 - real(dp) :: z0 = 0.0_dp - integer :: n_species = 0 !% Number of atomic types. - integer, dimension(:), allocatable :: Z - real(dp), dimension(total_elements) :: z_eff = 0.0_dp - real(dp), dimension(total_elements) :: w_Z = 1.0_dp - real(dp), dimension(total_elements) :: e0 = 0.0_dp - - ! qw parameters - integer :: qw_l_max = 0 - integer :: qw_f_n = 0 - logical :: qw_do_q = .false. - logical :: qw_do_w = .false. - real(dp), allocatable :: qw_cutoff(:) - integer, allocatable :: qw_cutoff_f(:) - real(dp), allocatable :: qw_cutoff_r1(:) - - integer :: cosnx_l_max, cosnx_n_max - - real(dp), dimension(:), allocatable :: pca_mean, NormFunction - real(dp), dimension(:,:), allocatable :: pca_matrix, RadialTransform - - logical :: do_pca = .false. - - character(len=256) :: coordinates !% Coordinate system used in GAP database - - character(len=STRING_LENGTH) :: label - -#ifdef HAVE_GAP - type(gpSparse) :: my_gp - type(descriptor), dimension(:), allocatable :: my_descriptor -#endif - logical :: initialised = .false. - type(extendable_str) :: command_line - integer :: xml_version - -end type IPModel_GAP - -logical, private :: parse_in_ip, parse_in_gap_data, parse_matched_label, parse_in_ip_done -integer, private :: parse_n_row, parse_cur_row - -type(IPModel_GAP), private, pointer :: parse_ip -type(extendable_str), save :: parse_cur_data - -interface Initialise - module procedure IPModel_GAP_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_GAP_Finalise -end interface Finalise - -interface Print - module procedure IPModel_GAP_Print -end interface Print - -interface Calc - module procedure IPModel_GAP_Calc -end interface Calc - -contains - -subroutine IPModel_GAP_Initialise_str(this, args_str, param_str) - type(IPModel_GAP), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - - integer :: i_coordinate - real(dp) :: gap_variance_regularisation - logical :: has_gap_variance_regularisation - - call Finalise(this) - - ! now initialise the potential -#ifndef HAVE_GAP - call system_abort('IPModel_GAP_Initialise_str: must be compiled with HAVE_GAP') -#else - - call initialise(params) - this%label='' - - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'E_scale', '1.0', this%E_scale, help_string="rescaling factor for the potential") - call param_register(params, 'gap_variance_regularisation', '0.001', gap_variance_regularisation, & - has_value_target=has_gap_variance_regularisation, help_string="Regularisation value for variance calculation.") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Initialise_str args_str')) & - call system_abort("IPModel_GAP_Initialise_str failed to parse label from args_str="//trim(args_str)) - call finalise(params) - - call IPModel_GAP_read_params_xml(this, param_str) - call gp_readXML(this%my_gp, param_str,label=trim(this%label)) - if (.not. this%my_gp%fitted) call system_abort('IPModel_GAP_Initialise_str: GAP model has not been fitted.') - allocate(this%my_descriptor(this%my_gp%n_coordinate)) - - this%cutoff = 0.0_dp - do i_coordinate = 1, this%my_gp%n_coordinate - call concat(this%my_gp%coordinate(i_coordinate)%descriptor_str," xml_version="//this%xml_version) - call initialise(this%my_descriptor(i_coordinate),string(this%my_gp%coordinate(i_coordinate)%descriptor_str)) - this%cutoff = max(this%cutoff,cutoff(this%my_descriptor(i_coordinate))) - if( has_gap_variance_regularisation) call gpCoordinates_initialise_variance_estimate(this%my_gp%coordinate(i_coordinate), gap_variance_regularisation) - enddo - -#endif - -end subroutine IPModel_GAP_Initialise_str - -subroutine IPModel_GAP_Finalise(this) - type(IPModel_GAP), intent(inout) :: this -#ifdef HAVE_GAP - if (allocated(this%qw_cutoff)) deallocate(this%qw_cutoff) - if (allocated(this%qw_cutoff_f)) deallocate(this%qw_cutoff_f) - if (allocated(this%qw_cutoff_r1)) deallocate(this%qw_cutoff_r1) - - if (allocated(this%Z)) deallocate(this%Z) - - if (this%my_gp%initialised) call finalise(this%my_gp) - - - this%cutoff = 0.0_dp - this%j_max = 0 - this%z0 = 0.0_dp - this%n_species = 0 - this%z_eff = 0.0_dp - this%w_Z = 1.0_dp - this%qw_l_max = 0 - this%qw_f_n = 0 - this%qw_do_q = .false. - this%qw_do_w = .false. - - this%coordinates = '' - - this%label = '' - this%initialised = .false. -#endif - - call finalise(this%command_line) - -end subroutine IPModel_GAP_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_GAP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_GAP), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - -#ifdef HAVE_GAP - real(dp), pointer :: w_e(:) - real(dp) :: e_i, e_i_cutoff - real(dp), dimension(:), allocatable :: local_e_in, energy_per_coordinate - real(dp), dimension(:,:,:), allocatable :: virial_in - integer :: d, i, j, n, m, i_coordinate, i_pos0 - - real(dp), dimension(:,:), allocatable :: f_in - - real(dp), dimension(3) :: pos, f_gp - real(dp), dimension(3,3) :: virial_i - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical, dimension(:), allocatable :: mpi_local_mask - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name, calc_local_gap_variance, calc_energy_per_coordinate - real(dp) :: r_scale, E_scale - - real(dp) :: gap_variance_i_cutoff - real(dp), dimension(:), allocatable :: gap_variance, local_gap_variance_in - real(dp), dimension(:), pointer :: local_gap_variance_pointer - real(dp), dimension(:,:), allocatable :: gap_variance_gradient_in - real(dp), dimension(:,:), pointer :: gap_variance_gradient_pointer - real(dp) :: gap_variance_regularisation - logical :: do_rescale_r, do_rescale_E, do_gap_variance, print_gap_variance, do_local_gap_variance, do_energy_per_coordinate - integer :: only_descriptor - logical :: do_select_descriptor - logical :: mpi_parallel_descriptor - - type(descriptor_data) :: my_descriptor_data - type(extendable_str) :: my_args_str - real(dp), dimension(:), allocatable :: gradPredict, grad_variance_estimate - - INIT_ERROR(error) - - if (present(e)) then - e = 0.0_dp - endif - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_GAP_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_GAP_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) then - virial = 0.0_dp - endif - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_GAP_Calc', error) - local_virial = 0.0_dp - endif - - ! Has to be allocated as it's in the reduction clause. - allocate(local_e_in(at%N)) - local_e_in = 0.0_dp - - allocate(energy_per_coordinate(this%my_gp%n_coordinate)) - energy_per_coordinate = 0.0_dp - - allocate(f_in(3,at%N)) - f_in = 0.0_dp - - allocate(virial_in(3,3,at%N)) - virial_in = 0.0_dp - - if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) - - ! initialise this one since param parser doesn't set it - atom_mask_pointer => null() - has_atom_mask_name = .false. - atom_mask_name = "" - only_descriptor = 0 - - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true, energies, forces, virials etc. are " // & - "calculated") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.") - - call param_register(params, 'local_gap_variance', '', calc_local_gap_variance, help_string="Compute variance estimate of the GAP prediction per atom and return it in the Atoms object.") - call param_register(params, 'print_gap_variance', 'F', print_gap_variance, help_string="Compute variance estimate of the GAP prediction per descriptor and prints it.") - call param_register(params, 'gap_variance_regularisation', '0.001', gap_variance_regularisation, help_string="Regularisation value for variance calculation.") - - call param_register(params, 'only_descriptor', '0', only_descriptor, has_value_target=do_select_descriptor, help_string="Only select a single coordinate") - call param_register(params, 'energy_per_coordinate', '', calc_energy_per_coordinate, help_string="Compute energy per GP coordinate and return it in the Atoms object.") - - call param_register(params, 'mpi_parallel_descriptor', 'F', mpi_parallel_descriptor, help_string="Do MPI parallelism over descriptor instances rather than atoms") - - if(present(args_str)) then - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_GAP_Calc args_str')) & - call system_abort("IPModel_GAP_Calc failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_GAP_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_GAP_Calc: rescaling of potential at the calc() stage with r_scale and E_scale not yet implemented!", error) - end if - - my_args_str = trim(args_str) - else - ! call parser to set defaults - if (.not. param_read_line(params,"",ignore_unknown=.true.,task='IPModel_GAP_Calc args_str')) & - call system_abort("IPModel_GAP_Calc failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - call initialise(my_args_str) - endif - - call concat(my_args_str," xml_version="//this%xml_version) - - do_local_gap_variance = len_trim(calc_local_gap_variance) > 0 - do_gap_variance = do_local_gap_variance .or. print_gap_variance - do_energy_per_coordinate = len_trim(calc_energy_per_coordinate) > 0 - - ! Has to be allocated as it's in the reduction clause. - allocate( local_gap_variance_in(at%N) ) - local_gap_variance_in = 0.0_dp - allocate( gap_variance_gradient_in(3,at%N) ) - gap_variance_gradient_in = 0.0_dp - - if( present(mpi) ) then - if(mpi%active) then - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_GAP: atom_mask_name '//trim(atom_mask_name)//' present while running MPI version.'// \ - 'The use of atom_mask_name is intended for serial-compiled code called from an external parallel code, such as LAMMPS',error) - endif - - if( has_property(at,"mpi_local_mask") ) then - RAISE_ERROR("IPModel_GAP: mpi_local_mask property already present", error) - endif - - if (.not. mpi_parallel_descriptor) then - allocate(mpi_local_mask(at%N)) - call add_property_from_pointer(at,'mpi_local_mask',mpi_local_mask,error=error) - - call concat(my_args_str," atom_mask_name=mpi_local_mask") - endif - endif - endif - - - if(print_gap_variance) then - call print('GAP_VARIANCE potential '//trim(this%label)//' calculating for '//this%my_gp%n_coordinate//' descriptors') - end if - - loop_over_descriptors: do i_coordinate = 1, this%my_gp%n_coordinate - if (do_select_descriptor .and. (this%my_gp%n_coordinate > 1)) then - if (i_coordinate /= only_descriptor) then - call print("GAP label="//trim(this%label)//" skipping coordinate "//i_coordinate, PRINT_NERD) - cycle - end if - end if - - if (.not. mpi_parallel_descriptor) then ! If parallelising over atoms, not descriptors - if(mpi%active) call descriptor_MPI_setup(this%my_descriptor(i_coordinate),at,mpi,mpi_local_mask,error) - endif - - d = descriptor_dimensions(this%my_descriptor(i_coordinate)) - - if(do_gap_variance) then - call gpCoordinates_initialise_variance_estimate(this%my_gp%coordinate(i_coordinate), gap_variance_regularisation) - endif - - if(present(f) .or. present(virial) .or. present(local_virial)) then - if (allocated(gradPredict)) deallocate(gradPredict) - allocate(gradPredict(d)) - - if(allocated(grad_variance_estimate)) deallocate(grad_variance_estimate) - allocate(grad_variance_estimate(d)) - end if - call calc(this%my_descriptor(i_coordinate),at,my_descriptor_data, & - do_descriptor=.true.,do_grad_descriptor=present(f) .or. present(virial) .or. present(local_virial), args_str=trim(string(my_args_str)), error=error) - PASS_ERROR(error) - allocate(gap_variance(size(my_descriptor_data%x))) - - call system_timer('IPModel_GAP_Calc_gp_predict') - -!$omp parallel default(none) private(i,gradPredict, grad_variance_estimate, e_i,n,m,j,pos,f_gp,e_i_cutoff,virial_i,i_pos0,gap_variance_i_cutoff) & -!$omp shared(this,at,i_coordinate,my_descriptor_data,e,virial,local_virial,local_e,do_gap_variance,do_local_gap_variance,gap_variance,f,do_energy_per_coordinate,mpi,mpi_parallel_descriptor) & -!$omp reduction(+:local_e_in,f_in,virial_in,local_gap_variance_in, gap_variance_gradient_in, energy_per_coordinate) - -!$omp do schedule(dynamic) - loop_over_descriptor_instances: do i = 1, size(my_descriptor_data%x) - if( .not. my_descriptor_data%x(i)%has_data ) cycle - - if (mpi_parallel_descriptor .and. mpi%active) then - ! This blocking strategy should yield a good, memory-local distribution of descriptors to processors - if (.not. ((i - 1) * mpi%n_procs / size(my_descriptor_data%x)) == mpi%my_proc) cycle - endif - - !call system_timer('IPModel_GAP_Calc_gp_predict') - - if(present(f) .or. present(virial) .or. present(local_virial)) then - call reallocate(gradPredict,size(my_descriptor_data%x(i)%data(:)),zero=.true.) - e_i = gp_predict(this%my_gp%coordinate(i_coordinate) , xStar=my_descriptor_data%x(i)%data(:), gradPredict = gradPredict, variance_estimate=gap_variance(i), do_variance_estimate=do_gap_variance, grad_variance_estimate=grad_variance_estimate) - else - e_i = gp_predict(this%my_gp%coordinate(i_coordinate) , xStar=my_descriptor_data%x(i)%data(:), variance_estimate=gap_variance(i), do_variance_estimate=do_gap_variance) - endif - !call system_timer('IPModel_GAP_Calc_gp_predict') - if(present(e) .or. present(local_e)) then - - e_i_cutoff = e_i * my_descriptor_data%x(i)%covariance_cutoff / size(my_descriptor_data%x(i)%ci) - call print("GAPDEBUG ci="//my_descriptor_data%x(i)%ci//" e_i="//e_i//" e_i_cutoff="//e_i_cutoff, PRINT_NERD) - - do n = 1, size(my_descriptor_data%x(i)%ci) - local_e_in( my_descriptor_data%x(i)%ci(n) ) = local_e_in( my_descriptor_data%x(i)%ci(n) ) + e_i_cutoff - enddo - endif - - if( do_energy_per_coordinate ) energy_per_coordinate(i_coordinate) = energy_per_coordinate(i_coordinate) + e_i * my_descriptor_data%x(i)%covariance_cutoff - - if( do_local_gap_variance ) then - gap_variance_i_cutoff = gap_variance(i) * my_descriptor_data%x(i)%covariance_cutoff**2 / size(my_descriptor_data%x(i)%ci) - - do n = 1, size(my_descriptor_data%x(i)%ci) - local_gap_variance_in( my_descriptor_data%x(i)%ci(n) ) = local_gap_variance_in( my_descriptor_data%x(i)%ci(n) ) + gap_variance_i_cutoff - enddo - endif - - if(present(f) .or. present(virial) .or. present(local_virial)) then - i_pos0 = lbound(my_descriptor_data%x(i)%ii,1) - - do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1) - if( .not. my_descriptor_data%x(i)%has_grad_data(n) ) cycle - j = my_descriptor_data%x(i)%ii(n) - pos = my_descriptor_data%x(i)%pos(:,n) - f_gp = matmul( gradPredict,my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff + & - e_i * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) - if( present(f) ) then - f_in(:,j) = f_in(:,j) - f_gp - endif - if( do_local_gap_variance ) then - gap_variance_gradient_in(:,j) = gap_variance_gradient_in(:,j) + & - matmul( grad_variance_estimate, my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff**2 + & - 2.0_dp * gap_variance(i) * my_descriptor_data%x(i)%covariance_cutoff * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) - endif - if( present(virial) .or. present(local_virial) ) then - virial_i = ((pos-my_descriptor_data%x(i)%pos(:,i_pos0)) .outer. f_gp) - virial_in(:,:,j) = virial_in(:,:,j) - virial_i - - !virial_i = (pos .outer. f_gp) / size(my_descriptor_data%x(i)%ci) - !do m = 1, size(my_descriptor_data%x(i)%ci) - ! virial_in(:,:,my_descriptor_data%x(i)%ci(m)) = virial_in(:,:,my_descriptor_data%x(i)%ci(m)) - virial_i - !enddo - endif - enddo - endif - enddo loop_over_descriptor_instances -!$omp end do - if(allocated(gradPredict)) deallocate(gradPredict) -!$omp end parallel - call system_timer('IPModel_GAP_Calc_gp_predict') - - if(print_gap_variance) then - if( size(my_descriptor_data%x) > 0 ) then - do i = 1, size(my_descriptor_data%x) - if( .not. my_descriptor_data%x(i)%has_data ) cycle - call print('GAP_VARIANCE potential '//trim(this%label)//' descriptor '//i_coordinate//' var( '//i//' ) = '//(gap_variance(i))//" * "//(my_descriptor_data%x(i)%covariance_cutoff**2)//" cutoff") - if(allocated(my_descriptor_data%x(i)%ii)) call print('GAP_VARIANCE potential '//trim(this%label)//' descriptor '//i_coordinate//' ii( '//i//' ) = '//my_descriptor_data%x(i)%ii) - enddo - else - call print('GAP_VARIANCE potential '//trim(this%label)//' descriptor '//i_coordinate//' not found') - endif - endif - if(allocated(gap_variance)) deallocate(gap_variance) - - call finalise(my_descriptor_data) - - enddo loop_over_descriptors - - if(present(f)) f = f_in - if(present(e)) e = sum(local_e_in) - if(present(local_e)) local_e = local_e_in - if(present(virial)) virial = sum(virial_in,dim=3) - - if(present(local_virial)) then - do i = 1, at%N - local_virial(:,i) = reshape(virial_in(:,:,i),(/9/)) - enddo - endif - - if(allocated(local_e_in)) deallocate(local_e_in) - if(allocated(f_in)) deallocate(f_in) - if(allocated(virial_in)) deallocate(virial_in) - - if (present(mpi)) then - if( mpi%active ) then - if(present(f)) call sum_in_place(mpi,f) - if(present(virial)) call sum_in_place(mpi,virial) - if(present(local_virial)) call sum_in_place(mpi,local_virial) - if(present(e)) e = sum(mpi,e) - if(present(local_e) ) call sum_in_place(mpi,local_e) - if(do_local_gap_variance) then - call sum_in_place(mpi, local_gap_variance_in) - if(present(f) .or. present(virial) .or. present(local_virial)) call sum_in_place(mpi, gap_variance_gradient_in) - endif - if(do_energy_per_coordinate) call sum_in_place(mpi,energy_per_coordinate) - - if (.not. mpi_parallel_descriptor) then - call remove_property(at,'mpi_local_mask', error=error) - deallocate(mpi_local_mask) - endif - endif - endif - - if( do_local_gap_variance ) then - call add_property(at, trim(calc_local_gap_variance), 0.0_dp, ptr = local_gap_variance_pointer, error=error) - PASS_ERROR(error) - local_gap_variance_pointer = local_gap_variance_in - - if(present(f) .or. present(virial) .or. present(local_virial)) then - call add_property(at, "gap_variance_gradient", 0.0_dp, n_cols=3, ptr2 = gap_variance_gradient_pointer, error=error) - PASS_ERROR(error) - gap_variance_gradient_pointer = gap_variance_gradient_in - endif - endif - - if( do_energy_per_coordinate ) call set_param_value(at,trim(calc_energy_per_coordinate),energy_per_coordinate) - - if(allocated(local_gap_variance_in)) deallocate(local_gap_variance_in) - if(allocated(gap_variance_gradient_in)) deallocate(gap_variance_gradient_in) - if(allocated(energy_per_coordinate)) deallocate(energy_per_coordinate) - - if(present(e)) then - if( associated(atom_mask_pointer) ) then - e = e + sum(this%e0(at%Z),mask=atom_mask_pointer) - else - e = e + sum(this%e0(at%Z)) - endif - endif - - if(present(local_e)) then - if( associated(atom_mask_pointer) ) then - where (atom_mask_pointer) local_e = local_e + this%e0(at%Z) - else - local_e = local_e + this%e0(at%Z) - endif - endif - - if(present(f)) f = this%E_scale * f - if(present(e)) e = this%E_scale * e - if(present(local_e)) local_e = this%E_scale * local_e - if(present(virial)) virial = this%E_scale * virial - if(present(local_virial)) local_virial = this%E_scale * local_virial - - atom_mask_pointer => null() - local_gap_variance_pointer => null() - gap_variance_gradient_pointer => null() - call finalise(my_args_str) - -#endif - -end subroutine IPModel_GAP_Calc - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for XML stanza is given below, please notice that -!% they are simply dummy parameters for testing purposes, with no physical meaning. -!% -!%> -!%> -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - integer :: ri, Z - - if(name == 'GAP_params') then ! new GAP stanza - - if(parse_in_ip) & - call system_abort("IPModel_startElement_handler entered GAP_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if(parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if(status /= 0) value = '' - - if(len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if(value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - parse_ip%label = trim(value) ! if we found a label, AND didn't have one originally, pass it back to the object. - endif - - if(parse_in_ip) then - if(parse_ip%initialised) call finalise(parse_ip) - endif - - - call QUIP_FoX_get_value(attributes, 'gap_version', value, status) - if( (status == 0) ) then - parse_ip%xml_version = string_to_int(value) - if( parse_ip%xml_version > gap_version ) & - call system_abort( & - 'Database was created with a later version of the code.' // & - 'Version of code used to generate the database is '//trim(value)//'.'// & - 'Version of current code is '//gap_version//'. Please update your code.') - else - parse_ip%xml_version = 0 - endif - - elseif(parse_in_ip .and. name == 'GAP_data') then - - call QUIP_FoX_get_value(attributes, 'e0', value, status) - if(status == 0) then - read (value, *) parse_ip%e0(1) - parse_ip%e0 = parse_ip%e0(1) - endif - - call QUIP_FoX_get_value(attributes, 'do_pca', value, status) - if(status == 0) then - read (value, *) parse_ip%do_pca - else - parse_ip%do_pca = .false. - endif - - allocate( parse_ip%Z(parse_ip%n_species) ) - parse_in_gap_data = .true. - - elseif(parse_in_ip .and. parse_in_gap_data .and. name == 'e0') then - call QUIP_FoX_get_value(attributes, 'Z', value, status) - if(status == 0) then - read (value, *) Z - else - call system_abort('IPModel_GAP_read_params_xml cannot find Z') - endif - if( Z > size(parse_ip%e0) ) call system_abort('IPModel_GAP_read_params_xml: attribute Z = '//Z//' > '//size(parse_ip%e0)) - - call QUIP_FoX_get_value(attributes, 'value', value, status) - if(status == 0) then - read (value, *) parse_ip%e0(Z) - else - call system_abort('IPModel_GAP_read_params_xml cannot find value in e0') - endif - - elseif(parse_in_ip .and. name == 'water_monomer_params') then - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if(status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') - endif - - elseif(parse_in_ip .and. name == 'hf_dimer_params') then - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if(status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') - endif - - elseif(parse_in_ip .and. name == 'water_dimer_params') then - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if(status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') - endif - - elseif(parse_in_ip .and. name == 'bispectrum_so4_params') then - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if(status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') - endif - - call QUIP_FoX_get_value(attributes, 'j_max', value, status) - if(status == 0) then - read (value, *) parse_ip%j_max - else - call system_abort('IPModel_GAP_read_params_xml cannot find j_max') - endif - - call QUIP_FoX_get_value(attributes, 'z0', value, status) - if(status == 0) then - read (value, *) parse_ip%z0 - else - call system_abort('IPModel_GAP_read_params_xml cannot find z0') - endif - - elseif(parse_in_ip .and. name == 'cosnx_params') then - - call QUIP_FoX_get_value(attributes, 'l_max', value, status) - if(status == 0) then - read (value, *) parse_ip%cosnx_l_max - else - call system_abort('IPModel_GAP_read_params_xml cannot find l_max') - endif - - call QUIP_FoX_get_value(attributes, 'n_max', value, status) - if(status == 0) then - read (value, *) parse_ip%cosnx_n_max - else - call system_abort('IPModel_GAP_read_params_xml cannot find n_max') - endif - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if(status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') - endif - - allocate(parse_ip%NormFunction(parse_ip%cosnx_n_max), parse_ip%RadialTransform(parse_ip%cosnx_n_max,parse_ip%cosnx_n_max)) - - elseif(parse_in_ip .and. name == 'qw_so3_params') then - - call QUIP_FoX_get_value(attributes, 'l_max', value, status) - if(status == 0) then - read (value, *) parse_ip%qw_l_max - else - call system_abort('IPModel_GAP_read_params_xml cannot find l_max') - endif - - call QUIP_FoX_get_value(attributes, 'n_radial', value, status) - if(status == 0) then - read (value, *) parse_ip%qw_f_n - else - call system_abort('IPModel_GAP_read_params_xml cannot find n_radial') - endif - - call QUIP_FoX_get_value(attributes, 'do_q', value, status) - if(status == 0) then - read (value, *) parse_ip%qw_do_q - else - call system_abort('IPModel_GAP_read_params_xml cannot find do_q') - endif - - call QUIP_FoX_get_value(attributes, 'do_w', value, status) - if(status == 0) then - read (value, *) parse_ip%qw_do_w - else - call system_abort('IPModel_GAP_read_params_xml cannot find do_w') - endif - - allocate(parse_ip%qw_cutoff(parse_ip%qw_f_n), parse_ip%qw_cutoff_f(parse_ip%qw_f_n), parse_ip%qw_cutoff_r1(parse_ip%qw_f_n)) - - elseif(parse_in_ip .and. name == 'radial_function') then - - call QUIP_FoX_get_value(attributes, 'i', value, status) - if(status == 0) then - read (value, *) ri - else - call system_abort('IPModel_GAP_read_params_xml cannot find i') - endif - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if(status == 0) then - read (value, *) parse_ip%qw_cutoff(ri) - else - call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') - endif - - call QUIP_FoX_get_value(attributes, 'cutoff_type', value, status) - if(status == 0) then - read (value, *) parse_ip%qw_cutoff_f(ri) - else - call system_abort('IPModel_GAP_read_params_xml cannot find cutoff_type') - endif - - call QUIP_FoX_get_value(attributes, 'cutoff_r1', value, status) - if(status == 0) then - read (value, *) parse_ip%qw_cutoff_r1(ri) - else - call system_abort('IPModel_GAP_read_params_xml cannot find cutoff_r1') - endif - - elseif(parse_in_ip .and. name == 'NormFunction') then - - parse_n_row = parse_ip%cosnx_n_max - call zero(parse_cur_data) - - elseif(parse_in_ip .and. name == 'command_line') then - call zero(parse_cur_data) - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - character(len=100*parse_n_row) :: val - - if (parse_in_ip) then - if(name == 'GAP_params') then - parse_in_ip = .false. - parse_in_ip_done = .true. - elseif(name == 'GAP_data') then - parse_in_gap_data = .false. - - elseif(name == 'bispectrum_so4_params') then - - elseif(name == 'hf_dimer_params') then - - elseif(name == 'water_monomer_params') then - - elseif(name == 'water_dimer_params') then - - elseif(name == 'qw_so3_params') then - - elseif(name == 'radial_function') then - - elseif(name == 'per_type_data') then - - elseif(name == 'PCA_mean') then - - val = string(parse_cur_data) - read(val,*) parse_ip%pca_mean - - elseif(name == 'row') then - - val = string(parse_cur_data) - read(val,*) parse_ip%pca_matrix(:,parse_cur_row) - - elseif(name == 'NormFunction') then - - val = string(parse_cur_data) - read(val,*) parse_ip%NormFunction - - elseif(name == 'RadialTransform_row') then - - val = string(parse_cur_data) - read(val,*) parse_ip%RadialTransform(:,parse_cur_row) - - elseif(name == 'command_line') then - parse_ip%command_line = parse_cur_data - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_characters_handler(in) - character(len=*), intent(in) :: in - - if(parse_in_ip) then - call concat(parse_cur_data, in, keep_lf=.false.) - endif - -end subroutine IPModel_characters_handler - -subroutine IPModel_GAP_read_params_xml(this, param_str) - type(IPModel_GAP), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) then - call system_abort('IPModel_GAP_read_params_xml: invalid param_str length '//len(trim(param_str)) ) - else - parse_in_ip = .false. - parse_in_ip_done = .false. - parse_matched_label = .false. - parse_ip => this - call initialise(parse_cur_data) - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler, & - characters_handler = IPModel_characters_handler) - call close_xml_t(fxml) - - call finalise(parse_cur_data) - - if(.not. parse_in_ip_done) & - call system_abort('IPModel_GAP_read_params_xml: could not initialise GAP potential. No GAP_params present?') - this%initialised = .true. - endif - -end subroutine IPModel_GAP_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of GAP parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_GAP_Print (this, file, dict) - type(IPModel_GAP), intent(inout) :: this - type(Inoutput), intent(inout),optional :: file - type(Dictionary), intent(inout), optional :: dict - integer :: i - - real(dp), dimension(:), allocatable :: log_likelihood - -#ifdef HAVE_GAP - call Print("IPModel_GAP : Gaussian Approximation Potential", file=file) - call Print("IPModel_GAP : label = "//this%label, file=file) - call Print("IPModel_GAP : cutoff = "//this%cutoff, file=file) - call Print("IPModel_GAP : E_scale = "//this%E_scale, file=file) - call Print("IPModel_GAP : command_line = "//string(this%command_line),file=file) - - allocate(log_likelihood(this%my_gp%n_coordinate)) - do i = 1, this%my_gp%n_coordinate - log_likelihood(i) = gp_log_likelihood(this%my_gp%coordinate(i)) - enddo - - call Print("IPModel_GAP : log likelihood = "//log_likelihood,file=file) -#else - allocate(log_likelihood(1)) - log_likelihood = 0.0_dp -#endif - - if( present(dict) ) then - if( dict%N == 0 ) call initialise(dict) - call set_value(dict,"log_likelihood_"//trim(this%label),log_likelihood) - endif - - if(allocated(log_likelihood)) deallocate(log_likelihood) - -end subroutine IPModel_GAP_Print - -end module IPModel_GAP_module diff --git a/src/Potentials/IPModel_Glue.f95 b/src/Potentials/IPModel_Glue.f95 deleted file mode 100644 index 922fde3684..0000000000 --- a/src/Potentials/IPModel_Glue.f95 +++ /dev/null @@ -1,905 +0,0 @@ -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X QUIP: quantum mechanical and interatomic potential simulation package -!X -!X Portions written by Noam Bernstein, while working at the -!X Naval Research Laboratory, Washington DC. -!X -!X Portions written by Gabor Csanyi, Copyright 2006-2007. -!X -!X When using this software, please cite the following reference: -!X -!X reference -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X IPModel_Glue -!X -!% Generic implementation of Glue potentials. Glue potentials are described -!% in the XML params file. -!X -!X Copyright Tim Green 2010. Licensed under the Gnu Public License version 3. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Glue_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use spline_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -type SplineDataContainer - real(dp), allocatable, dimension(:,:) :: data - real(dp) :: y1, yn -end type SplineDataContainer - -public :: IPModel_Glue -type IPModel_Glue - integer :: n_types = 0 ! Number of different species we have - - ! Maps from atomic number to type and vice versa - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - real(dp), allocatable, dimension(:) :: poly - - type(SplineDataContainer), allocatable, dimension(:) :: spline_data_potential, spline_data_density - type(SplineDataContainer), allocatable, dimension(:,:) :: spline_data_pair - type(Spline), allocatable :: potential(:) - type(Spline), allocatable :: pair(:,:) - type(Spline), allocatable :: density(:) - logical, dimension(:), allocatable :: do_density_spline - - character(len=STRING_LENGTH) :: label - -end type IPModel_Glue - -logical, private :: parse_in_ip, parse_matched_label, parse_in_density_potential, parse_in_neighbours_potential, parse_in_density, parse_in_potential_pair -type(IPModel_Glue), private, pointer :: parse_ip -integer :: parse_curr_type_i = 0, parse_curr_type_j = 0, parse_curr_point, parse_n_neighbours - -interface Initialise - module procedure IPModel_Glue_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Glue_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Glue_Print -end interface Print - -interface Calc - module procedure IPModel_Glue_Calc -end interface Calc - -contains - -subroutine IPModel_Glue_Initialise_str(this, args_str, param_str) - type(IPModel_Glue), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Glue_Initialise_str args_str')) then - call system_abort("IPModel_Glue_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Glue_read_params_xml(this, param_str) - -end subroutine IPModel_Glue_Initialise_str - -subroutine IPModel_Glue_Finalise(this) - type(IPModel_Glue), intent(inout) :: this - integer :: i, j - - ! Add finalisation code here - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%spline_data_density)) then - do i=1,this%n_types - if(allocated(this%spline_data_density(i)%data)) deallocate(this%spline_data_density(i)%data) - enddo - deallocate(this%spline_data_density) - endif - - if(allocated(this%do_density_spline)) deallocate(this%do_density_spline) - - if (allocated(this%spline_data_potential)) then - do i=1,this%n_types - if(allocated(this%spline_data_potential(i)%data)) deallocate(this%spline_data_potential(i)%data) - enddo - deallocate(this%spline_data_potential) - endif - - if (allocated(this%spline_data_pair)) then - do i=1,this%n_types - do j=1,this%n_types - if(allocated(this%spline_data_pair(j,i)%data)) deallocate(this%spline_data_pair(j,i)%data) - enddo - enddo - deallocate(this%spline_data_pair) - endif - - if(allocated(this%poly)) deallocate(this%poly) - - if (allocated(this%potential)) then - do i=1,this%n_types - call finalise(this%potential(i)) - enddo - deallocate(this%potential) - endif - - if (allocated(this%density)) then - do i=1,this%n_types - call finalise(this%density(i)) - enddo - deallocate(this%density) - endif - - if (allocated(this%pair)) then - do i=1,this%n_types - do j = 1, this%n_types - call finalise(this%pair(j,i)) - enddo - enddo - deallocate(this%pair) - endif - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Glue_Finalise - -subroutine IPModel_Glue_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Glue), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - real(dp), dimension(:), allocatable :: local_e_in, rho_local - real(dp), dimension(:,:), allocatable :: f_in - real(dp), dimension(:,:,:), allocatable :: local_virial_in - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E, unknown_type - ! Loop variables - integer :: i, ji, j, ti, tj - - real(dp) :: r_ij_mag, r_ij_hat(3), pair_e_ij, dpair_e_ij ! Neighbour vector info - - ! For calculating forces and the virial tensor - real(dp) :: dpotential_drho_drho_i_drij(3), dpotential_drho - - INIT_ERROR(error) - - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Glue_Calc', error) - endif - - if(present(e) .or. present(local_e)) then - allocate(local_e_in(at%N)) - local_e_in = 0.0_dp - else - allocate(local_e_in(1)) - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_Glue_Calc', error) - allocate(f_in(3,at%N)) - f_in = 0.0_dp - else - allocate(f_in(1,1)) - end if - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_Glue_Calc', error) - local_virial = 0.0_dp - endif - - if(present(virial) .or. present(local_virial)) then - allocate(local_virial_in(3,3,at%N)) - local_virial_in = 0.0_dp - else - allocate(local_virial_in(1,1,1)) - endif - - atom_mask_pointer => null() - - if(present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Glue_Calc args_str')) then - RAISE_ERROR("IPModel_Glue_Calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then - RAISE_ERROR("IPModel_Glue_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_Glue_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - endif - - ! Iterate over atoms - allocate(rho_local(at%N)) - rho_local = 0.0_dp - -!$omp parallel do default(none) shared(this,at,atom_mask_pointer,rho_local) private(i,j,ji,ti,tj,r_ij_mag,unknown_type) - do i = 1, at%N - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ! Get the type of this species from its atomic number - ti = get_type(this%type_of_atomic_num, at%Z(i), unknown_type=unknown_type) - if( unknown_type ) cycle - - ! Iterate over our nighbours - do ji = 1, n_neighbours(at, i) - j = neighbour(at, i, ji, distance = r_ij_mag) - tj = get_type(this%type_of_atomic_num, at%Z(j), unknown_type=unknown_type) - if( unknown_type ) cycle - - if (r_ij_mag < glue_cutoff(this, tj)) then ! Skip atoms beyond the cutoff - rho_local(i) = rho_local(i) + eam_density(this, tj, r_ij_mag) - endif - enddo - enddo -!$omp end parallel do - - ! Iterate over atoms -!$omp parallel do default(none) shared(this,at,atom_mask_pointer,rho_local,local_e_in,e,f,virial,local_e,local_virial) & -!$omp private(i,ji,j,ti,tj,r_ij_mag,r_ij_hat,dpotential_drho, dpotential_drho_drho_i_drij, pair_e_ij, dpair_e_ij, unknown_type) & -!$omp reduction(+:f_in,local_virial_in) - do i = 1, at%N - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ! Get the type of this species from its atomic number - ti = get_type(this%type_of_atomic_num, at%Z(i), unknown_type=unknown_type) - if( unknown_type ) cycle - - dpotential_drho = eam_spline_potential_deriv(this, ti, rho_local(i)) - - ! Iterate over our nighbours - do ji = 1, n_neighbours(at, i) - j = neighbour(at, i, ji, r_ij_mag, cosines=r_ij_hat) - tj = get_type(this%type_of_atomic_num, at%Z(j), unknown_type=unknown_type) - if( unknown_type ) cycle - - if (r_ij_mag < glue_cutoff(this, tj)) then ! Skip atoms beyond the cutoff - if( present(f) .or. present(virial) .or. present(local_virial) ) then - dpotential_drho_drho_i_drij = dpotential_drho * eam_density_deriv(this, tj, r_ij_mag) * r_ij_hat - endif - - if(present(f)) then - f_in(:,j) = f_in(:,j) - dpotential_drho_drho_i_drij - f_in(:,i) = f_in(:,i) + dpotential_drho_drho_i_drij - endif - - if(present(virial) .or. present(local_virial)) local_virial_in(:,:,j) = local_virial_in(:,:,j) - ( dpotential_drho_drho_i_drij .outer. r_ij_hat ) * r_ij_mag - endif - - if( r_ij_mag < pair_cutoff(this,ti,tj) ) then - pair_e_ij = eam_spline_pair(this,ti,tj,r_ij_mag) - if( present(local_e) .or. present(e) ) local_e_in(i) = local_e_in(i) + 0.5_dp * pair_e_ij - if( present(f) .or. present(virial) .or. present(local_virial) ) dpair_e_ij = eam_spline_pair_deriv(this,ti, tj, r_ij_mag) - if( present(f) ) f_in(:,i) = f_in(:,i) + 0.5 * dpair_e_ij * r_ij_hat - if( present(f) ) f_in(:,j) = f_in(:,j) - 0.5 * dpair_e_ij * r_ij_hat - if( present(virial) .or. present(local_virial) ) local_virial_in(:,:,j) = local_virial_in(:,:,j) - 0.5_dp * dpair_e_ij * (r_ij_hat .outer. r_ij_hat) * r_ij_mag - endif - - enddo ! ji - - if(present(local_e) .or. present(e)) local_e_in(i) = local_e_in(i) + eam_spline_potential(this, ti, rho_local(i)) - end do ! i -!$omp end parallel do - - - if(present(e)) e = sum(local_e_in) - if(present(f)) f = f_in - if(present(local_e)) local_e = local_e_in - if(present(virial)) virial = sum(local_virial_in,dim=3) - if(present(local_virial)) local_virial = reshape(local_virial_in,(/9,at%N/)) - - if(allocated(rho_local)) deallocate(rho_local) - if(allocated(local_e_in)) deallocate(local_e_in) - if(allocated(f_in)) deallocate(f_in) - if(allocated(local_virial_in)) deallocate(local_virial_in) - -end subroutine IPModel_Glue_Calc - -function glue_cutoff(this, ti, error) - type(IPModel_Glue), intent(in) :: this - integer, intent(in) :: ti - integer, intent(out), optional :: error - real(dp) :: glue_cutoff - - INIT_ERROR(error) - - if( .not. this%density(ti)%initialised ) then - RAISE_ERROR("glue_cutoff: spline not initialised", error) - endif - - glue_cutoff = max_knot(this%density(ti)) - -end function glue_cutoff - -function pair_cutoff(this, ti, tj, error) - type(IPModel_Glue), intent(in) :: this - integer, intent(in) :: ti, tj - integer, intent(out), optional :: error - real(dp) :: pair_cutoff - - INIT_ERROR(error) - - if( .not. this%pair(ti,tj)%initialised ) then - pair_cutoff = 0.0_dp - else - pair_cutoff = max_knot(this%pair(ti,tj)) - endif - -end function pair_cutoff - -function eam_density(this, ti, r, error) - type(IPModel_Glue), intent(in) :: this - integer, intent(in) :: ti - real(dp), intent(in) :: r - integer, intent(out), optional :: error - real(dp) :: eam_density - - INIT_ERROR(error) - - if( .not. this%density(ti)%initialised ) then - RAISE_ERROR("eam_density: spline not initialised", error) - endif - - if (r < glue_cutoff(this, ti)) then - if(this%do_density_spline(ti)) then - eam_density = spline_value(this%density(ti),r) - else - eam_density = this%poly(ti)*(glue_cutoff(this, ti)-r)**3 - endif - else - eam_density = 0.0_dp - endif -end function eam_density - -function eam_density_deriv(this, ti, r, error) - type(IPModel_Glue), intent(in) :: this - integer, intent(in) :: ti - real(dp), intent(in) :: r - integer, intent(out), optional :: error - real(dp) :: eam_density_deriv - - INIT_ERROR(error) - - if( .not. this%density(ti)%initialised ) then - RAISE_ERROR("eam_density_deriv: spline not initialised", error) - endif - - if (r < glue_cutoff(this, ti)) then - if(this%do_density_spline(ti)) then - eam_density_deriv = spline_deriv(this%density(ti),r) - else - eam_density_deriv = -3.0_dp * this%poly(ti)*(glue_cutoff(this, ti)-r)**2 - endif - else - eam_density_deriv = 0.0_dp - endif -end function eam_density_deriv - -function eam_spline_potential(this, ti, rho, error) - ! Evaluate the potential spline at r for the ti^th species - type(IPModel_Glue), intent(in) :: this - integer, intent(in) :: ti - real(dp), intent(in) :: rho - integer, intent(out), optional :: error - real(dp) :: eam_spline_potential - - INIT_ERROR(error) - - if( .not. this%potential(ti)%initialised ) then - RAISE_ERROR("eam_spline_potential: spline not initialised", error) - endif - - eam_spline_potential = spline_value(this%potential(ti), rho) - -end function eam_spline_potential - -function eam_spline_potential_deriv(this, ti, rho, error) - ! Evaluate the potential spline derivitive at r for the ti^th species - type(IPModel_Glue), intent(in) :: this - integer, intent(in) :: ti - real(dp), intent(in) :: rho - integer, intent(out), optional :: error - real(dp) :: eam_spline_potential_deriv - - INIT_ERROR(error) - - if( .not. this%potential(ti)%initialised ) then - RAISE_ERROR("eam_spline_potential_deriv: spline not initialised", error) - endif - - eam_spline_potential_deriv = spline_deriv(this%potential(ti), rho) - -end function eam_spline_potential_deriv - -function eam_spline_pair(this, ti, tj, rho, error) - ! Evaluate the potential spline at r for the ti^th species - type(IPModel_Glue), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: rho - integer, intent(out), optional :: error - real(dp) :: eam_spline_pair - - INIT_ERROR(error) - - if( .not. this%pair(ti,tj)%initialised ) then - eam_spline_pair = 0.0_dp - else - eam_spline_pair = spline_value(this%pair(ti,tj), rho) - endif - - -end function eam_spline_pair - -function eam_spline_pair_deriv(this, ti, tj, rho, error) - ! Evaluate the potential spline derivitive at r for the ti^th species - type(IPModel_Glue), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: rho - integer, intent(out), optional :: error - real(dp) :: eam_spline_pair_deriv - - INIT_ERROR(error) - - if( .not. this%pair(ti,tj)%initialised ) then - eam_spline_pair_deriv = 0.0_dp - else - eam_spline_pair_deriv = spline_deriv(this%pair(ti, tj), rho) - endif - - -end function eam_spline_pair_deriv - -subroutine IPModel_Glue_Print(this, file) - type(IPModel_Glue), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_Glue : Glue Potential", file=file) - call Print("IPModel_Glue : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_Glue : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_Glue : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_Glue_Print - -subroutine IPModel_Glue_read_params_xml(this, param_str) - type(IPModel_Glue), intent(inout), target :: this - character(len=*), intent(in) :: param_str - integer :: ti, tj - real(dp) :: max_cutoff - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Glue_read_params_xml parsed file, but n_types = 0") - endif - - ! Initialise the spline data structures with the spline data - do ti = 1, this%n_types - - if(allocated(this%spline_data_density(ti)%data)) then - call initialise(this%density(ti), this%spline_data_density(ti)%data(:,1), this%spline_data_density(ti)%data(:,2), & - this%spline_data_density(ti)%y1, this%spline_data_density(ti)%yn) - endif - if(allocated(this%spline_data_potential(ti)%data)) then - call initialise(this%potential(ti), this%spline_data_potential(ti)%data(:,1), this%spline_data_potential(ti)%data(:,2), this%spline_data_potential(ti)%y1,this%spline_data_potential(ti)%yn) - endif - - do tj = 1, this%n_types - if(allocated(this%spline_data_pair(tj,ti)%data)) then - call initialise(this%pair(tj,ti), this%spline_data_pair(tj,ti)%data(:,1), this%spline_data_pair(tj,ti)%data(:,2), this%spline_data_pair(tj,ti)%y1, this%spline_data_pair(tj,ti)%yn) - call initialise(this%pair(ti,tj), this%spline_data_pair(tj,ti)%data(:,1), this%spline_data_pair(tj,ti)%data(:,2), this%spline_data_pair(tj,ti)%y1, this%spline_data_pair(tj,ti)%yn) - endif - enddo - - this%poly(ti) = dot_product(this%spline_data_density(ti)%data(:,2), (glue_cutoff(this,ti) - & - this%spline_data_density(ti)%data(:,1))**3) / & - dot_product((glue_cutoff(this,ti)-this%spline_data_density(ti)%data(:,1))**3, & - (glue_cutoff(this,ti)-this%spline_data_density(ti)%data(:,1))**3) - end do - - max_cutoff = 0.0_dp - ! Find the largest cutoff - do ti = 1, this%n_types - max_cutoff = max(glue_cutoff(this,ti),max_cutoff) - do tj = 1, this%n_types - max_cutoff = max(pair_cutoff(this,tj,ti),max_cutoff) - enddo - enddo - this%cutoff = max_cutoff - -end subroutine IPModel_Glue_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - integer :: ti, tj, num_points - real(dp) :: v - - if (name == 'Glue_params') then ! new Template stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in Glue_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - ! Allocate n_types spline data objects for further allocation - allocate(parse_ip%spline_data_density(parse_ip%n_types)) - allocate(parse_ip%spline_data_potential(parse_ip%n_types)) - allocate(parse_ip%spline_data_pair(parse_ip%n_types,parse_ip%n_types)) - - allocate(parse_ip%do_density_spline(parse_ip%n_types)) - - ! Allocate the splines - allocate(parse_ip%pair(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%potential(parse_ip%n_types)) - allocate(parse_ip%density(parse_ip%n_types)) - allocate(parse_ip%poly(parse_ip%n_types)) - endif - - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find type") - read (value, *) ti ! This is the index of this particular species - - parse_curr_type_i = ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) ! This is the atomic number of this particular species - - ! Re-do the atomic number -> species index map - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "type1", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find type") - read (value, *) ti ! This is the index of this particular species - - parse_curr_type_i = ti - - call QUIP_FoX_get_value(attributes, "type2", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find type") - read (value, *) tj ! This is the index of this particular species - - parse_curr_type_j = tj - - elseif (parse_in_ip .and. parse_curr_type_i /= 0 .and. name == 'density') then - ! Density is modelled as scale*exp(-extent*x). Could probably determine scale from normalization, but I won't. - - parse_in_density = .true. - parse_curr_point = 1 - - call QUIP_FoX_get_value(attributes, "num_points", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml density but no num_points") - read (value, *) num_points ! - - call QUIP_FoX_get_value(attributes, "do_spline", value, status) - if (status /= 0) then - parse_ip%do_density_spline(parse_curr_type_i) = .false. - else - read (value, *) parse_ip%do_density_spline(parse_curr_type_i) - endif - - call QUIP_FoX_get_value(attributes, "density_y1", value, status) ! endpoint derivative - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml density but no density_y1") - read (value, *) parse_ip%spline_data_density(parse_curr_type_i)%y1 - - call QUIP_FoX_get_value(attributes, "density_yn", value, status) ! endpoint derivative - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml density but no density_yn") - read (value, *) parse_ip%spline_data_density(parse_curr_type_i)%yn - - ! Allocate num_points in the current type - allocate(parse_ip%spline_data_density(parse_curr_type_i)%data(num_points,2)) - - elseif (parse_in_ip .and. parse_curr_type_i /= 0 .and. name == 'potential_density') then - - ! Potential supplied as density vs. energy - parse_in_density_potential = .true. - parse_curr_point = 1 - - call QUIP_FoX_get_value(attributes, "num_points", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml potential_density but no num_points") - read (value, *) num_points ! - - call QUIP_FoX_get_value(attributes, "y1", value, status) ! endpoint derivative - if (status /= 0) then - parse_ip%spline_data_potential(parse_curr_type_i)%y1 = 2.0e30_dp - else - read (value, *) parse_ip%spline_data_potential(parse_curr_type_i)%y1 - endif - - call QUIP_FoX_get_value(attributes, "yn", value, status) ! endpoint derivative - if (status /= 0) then - parse_ip%spline_data_potential(parse_curr_type_i)%yn = 2.0e30_dp - else - read (value, *) parse_ip%spline_data_potential(parse_curr_type_i)%yn - endif - - ! Allocate num_points in the current type - allocate(parse_ip%spline_data_potential(parse_curr_type_i)%data(num_points,2)) - - elseif (parse_in_ip .and. parse_curr_type_i /= 0 .and. name == 'potential_neighbours') then - - ! Potential supplied as distance to nearest neighbour vs. energy, along with number of neighbours - parse_in_neighbours_potential = .true. - parse_curr_point = 1 - - call QUIP_FoX_get_value(attributes, "num_neighbours", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml missing num_neighbours on potential_neighbouring") - read (value, *) parse_n_neighbours - - call QUIP_FoX_get_value(attributes, "num_points", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml potential_neighbours but no num_points") - read (value, *) num_points ! scale of the electron density for this element - - ! Allocate num_points in the current type - allocate(parse_ip%spline_data_potential(parse_curr_type_i)%data(num_points,2)) - - elseif (parse_in_ip .and. parse_curr_type_i /= 0 .and. parse_curr_type_j /= 0 .and. name == 'potential_pair') then - - ! Pair potential - parse_in_potential_pair = .true. - parse_curr_point = 1 - - call QUIP_FoX_get_value(attributes, "num_points", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml potential_pair but no num_points") - read (value, *) num_points - - call QUIP_FoX_get_value(attributes, "y1", value, status) ! endpoint derivative - if (status /= 0) then - parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%y1 = 0.0_dp - else - read (value, *) parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%y1 - endif - - call QUIP_FoX_get_value(attributes, "yn", value, status) ! endpoint derivative - if (status /= 0) then - parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%yn = 0.0_dp - else - read (value, *) parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%yn - endif - - ! Allocate num_points in the current type - allocate(parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%data(num_points,2)) - - elseif (parse_in_ip .and. name == 'point') then - - if (parse_in_density_potential) then - - ! - ! Potential defined as a rho->E map - ! - - if (parse_curr_point > size(parse_ip%spline_data_potential(parse_curr_type_i)%data,1)) call system_abort ("IPModel_Glue got too " // & - "many points " // parse_curr_point // " type " // parse_curr_type_i // " in potential_density") - - call QUIP_FoX_get_value(attributes, "rho", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find rho") - read (value, *) v - parse_ip%spline_data_potential(parse_curr_type_i)%data(parse_curr_point,1) = v - - call QUIP_FoX_get_value(attributes, "E", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find E") - read (value, *) v - parse_ip%spline_data_potential(parse_curr_type_i)%data(parse_curr_point,2) = v - - elseif (parse_in_potential_pair) then - - if (parse_curr_point > size(parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%data,1)) call system_abort ("IPModel_Glue got too " // & - "many points " // parse_curr_point // " type " // parse_curr_type_i // " in potential_pair") - - call QUIP_FoX_get_value(attributes, "r", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find r") - read (value, *) v - parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%data(parse_curr_point,1) = v - - call QUIP_FoX_get_value(attributes, "E", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find E") - read (value, *) v - parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%data(parse_curr_point,2) = v - - elseif (parse_in_neighbours_potential) then - - ! - ! Potential defined as a a->E map for N nearest neighbours - ! - - if (parse_curr_point > size(parse_ip%spline_data_potential(parse_curr_type_i)%data,1)) call system_abort ("IPModel_Glue got too " // & -"many points " // parse_curr_point // " type " // parse_curr_type_i // " in potential_neighbours") - - call QUIP_FoX_get_value(attributes, "a", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find a") - read (value, *) v - - ! This implies that the denstiy must be defined above the potential - parse_ip%spline_data_potential(parse_curr_type_i)%data(parse_curr_point,1) = eam_density(parse_ip, parse_curr_type_i, v) * parse_n_neighbours - - call QUIP_FoX_get_value(attributes, "E", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find E") - read (value, *) v - parse_ip%spline_data_potential(parse_curr_type_i)%data(parse_curr_point,2) = v - - ! call print(parse_ip%spline_data(parse_curr_type_i)%spline_potential(1, parse_curr_point) // " " // parse_ip%spline_data(parse_curr_type_i)%spline_potential(2, parse_curr_point) // " " ) - - elseif (parse_in_density) then - - ! - ! Potential defined as a a->E map for N nearest neighbours - ! - - if (parse_curr_point > size(parse_ip%spline_data_density(parse_curr_type_i)%data,1)) call system_abort ("IPModel_Glue got too " // & -"many points " // parse_curr_point // " type " // parse_curr_type_i // " in density") - - call QUIP_FoX_get_value(attributes, "a", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find a") - read (value, *) v - - ! This implies that the denstiy must be defined above the potential - parse_ip%spline_data_density(parse_curr_type_i)%data(parse_curr_point,1) = v - - call QUIP_FoX_get_value(attributes, "rho", value, status) - if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find rho") - read (value, *) v - parse_ip%spline_data_density(parse_curr_type_i)%data(parse_curr_point,2) = v - - ! call print(parse_ip%spline_data(parse_curr_type_i)%spline_potential(1, parse_curr_point) // " " // parse_ip%spline_data(parse_curr_type_i)%spline_potential(2, parse_curr_point) // " " ) - - endif - - parse_curr_point = parse_curr_point + 1 - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Glue_params') then - parse_in_ip = .false. - elseif (name == 'potential_density') then - parse_in_density_potential = .false. - elseif (name == 'potential_pair') then - parse_in_potential_pair = .false. - elseif (name == 'potential_neighbours') then - parse_in_neighbours_potential = .false. - elseif (name == 'density') then - parse_in_density = .false. - elseif (name == 'per_type_data') then - parse_curr_type_i = 0 - elseif (name == 'per_pair_data') then - parse_curr_type_i = 0 - parse_curr_type_j = 0 - endif - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_Glue_module diff --git a/src/Potentials/IPModel_HFdimer.f95 b/src/Potentials/IPModel_HFdimer.f95 deleted file mode 100644 index 9b949a56a5..0000000000 --- a/src/Potentials/IPModel_HFdimer.f95 +++ /dev/null @@ -1,208 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_HFdimer -!X -!% Simple interatomic potential for an HF dimer: -!% -!% Includes a linear spring between bonded H and F atoms, Coulomb interaction and short-range repulsion -!% between nonbonded atoms. The parametrisation was done from MP2 calculations. -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_HFdimer_module - -use error_module -use system_module, only : dp, inoutput, print, operator(//) -use units_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_HFdimer -type IPModel_HFdimer - real(dp) :: cutoff = 10.0_dp -end type IPModel_HFdimer - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_HFdimer), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_HFdimer_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_HFdimer_Finalise -end interface Finalise - -interface Print - module procedure IPModel_HFdimer_Print -end interface Print - -interface Calc - module procedure IPModel_HFdimer_Calc -end interface Calc - -contains - -subroutine IPModel_HFdimer_Initialise_str(this, args_str, param_str) - type(IPModel_HFdimer), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - ! Add initialisation code here - -end subroutine IPModel_HFdimer_Initialise_str - -subroutine IPModel_HFdimer_Finalise(this) - type(IPModel_HFdimer), intent(inout) :: this - - ! Add finalisation code here - -end subroutine IPModel_HFdimer_Finalise - - -subroutine IPModel_HFdimer_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_HFdimer), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - ! Add calc() code here - - - real(dp) :: energy, force(3,4) - real(dp) :: rHF1, rHF2, rFF, rF1, rF2, dr1(3), dr2(3), drFF(3), drF1(3), drF2(3), rHH, rH1F2, rH2F1, drHH(3), drH1F2(3), drH2F1(3), q2 - real(dp), parameter :: kHF = 0.0_dp ! 37.84_dp ! H-F spring constant - real(dp), parameter :: kConf = 0.0_dp ! 0.15_dp ! confinement - real(dp), parameter :: d0HF = 0.9_dp, BFF = 0.269268123658040_dp, r0FF = 2.0312819622_dp, r0HF = 1.1564_dp, BHF = 0.141733063687659_dp, q=0.43_dp - - INIT_ERROR(error) - - - - ! Hydrogen Fluoride dimer potential - ! spring constant between H-F and repulsive interaction between Fs, repulsive interaction between nonbonded HFs, Coulomb interaction between nonbonded things - ! The order in the Atoms object must be H-F H-F - ! - ! Harmonic confining potential on Fs - - rHF1 = distance_min_image(at, 1, 2) - rHF2 = distance_min_image(at, 3, 4) - rFF = distance_min_image(at, 2, 4) - rHH = distance_min_image(at,1,3) - rH1F2 = distance_min_image(at,1,4) - rH2F1 = distance_min_image(at,2,3) - - rF1 = distance_min_image(at, 2, (/0.0_dp, 0.0_dp, 0.0_dp/)) - rF2 = distance_min_image(at, 4, (/0.0_dp, 0.0_dp, 0.0_dp/)) - - ! Bonded energy terms - energy = kHF*(rHF1-d0HF)**2 + kHF*(rHF2-d0HF)**2 - - ! repulsive terms - energy = energy + exp(-(rFF-r0FF)/BFF) + exp(-(rH1F2-r0HF)/BHF) + exp(-(rH2F1-r0HF)/BHF) - - ! confinement - energy = energy + kConf*rF1**2 + kConf*rF2**2 - - ! Coulomb Energy - q2 = HARTREE*BOHR*q*q - energy = energy + q2*(& - (+1.0_dp)/rHH + & ! H1-H2 - (-1.0_dp)/rH1F2 + & ! H1-F2 - (+1.0_dp)/rFF + & ! F1-F2 - (-1.0_dp)/rH2F1) ! F1-H2 - - !Forces - - dr1 = diff_min_image(at, 1, 2)/rHF1 - dr2 = diff_min_image(at, 3, 4)/rHF2 - drFF = diff_min_image(at, 2, 4)/rFF - drF1 = diff_min_image(at, 2, (/0.0_dp, 0.0_dp, 0.0_dp/))/rF1 - drF2 = diff_min_image(at, 4, (/0.0_dp, 0.0_dp, 0.0_dp/))/rF2 - - drHH = diff_min_image(at,1,3)/rHH - drH1F2 = diff_min_image(at,1,4)/rH1F2 - drH2F1 = diff_min_image(at,2,3)/rH2F1 - - force(:,1) = 2.0_dp*kHF*(rHF1-d0HF)*dr1 -q2/rHH**2*drHH + q2/rH1F2**2*drH1F2 - 1.0_dp/BHF*exp(-(rH1F2-r0HF)/BHF)*drH1F2 - force(:,2) = -2.0_dp*kHF*(rHF1-d0HF)*dr1 - 1.0_dp/BFF*exp(-(rFF-r0FF)/BFF) * drFF + 2.0_dp*kConf*rF1*drF1 +q2/rH2F1**2*drH2F1 -q2/rFF**2*drFF - 1.0_dp/BHF*exp(-(rH2F1-r0HF)/BHF)*drH2F1 - force(:,3) = 2.0_dp*kHF*(rHF2-d0HF)*dr2 +q2/rHH**2*drHH - q2/rH2F1**2*drH2F1 + 1.0_dp/BHF*exp(-(rH2F1-r0HF)/BHF)*drH2F1 - force(:,4) = -2.0_dp*kHF*(rHF2-d0HF)*dr2 + 1.0_dp/BFF*exp(-(rFF-r0FF)/BFF) * drFF + 2.0_dp*kConf*rF2*drF2 -q2/rH1F2**2*drH1F2 +q2/rFF**2*drFF + 1.0_dp/BHF*exp(-(rH1F2-r0HF)/BHF)*drH1F2 - - - if (present(e)) e = energy - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_HFdimer_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_HFdimer_Calc', error) - f = force - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_HFdimer_Calc', error) - local_virial = 0.0_dp - endif - - -end subroutine IPModel_HFdimer_Calc - - -subroutine IPModel_HFdimer_Print(this, file) - type(IPModel_HFdimer), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_HFdimer : HFdimer Potential", file=file) - call Print("IPModel_HFdimer : cutoff = " // this%cutoff, file=file) - -end subroutine IPModel_HFdimer_Print - - -end module IPModel_HFdimer_module diff --git a/src/Potentials/IPModel_KIM.f95 b/src/Potentials/IPModel_KIM.f95 deleted file mode 100644 index c01787cc45..0000000000 --- a/src/Potentials/IPModel_KIM.f95 +++ /dev/null @@ -1,683 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_KIM module -!X -!% Module for KIM (Knowledgebase of Interatomic potential Models) -!% -!% The IPModel_KIM object contains all the parameters read from a -!% 'KIM_params' XML stanza. (?) -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" -#include "KIM_API_status.h" - - - -module IPModel_KIM_module - -use error_module -use system_module, only : dp, inoutput, quip_new_line, split_string_simple -use periodictable_module -use extendable_str_module -use linearalgebra_module -use dictionary_module -use paramreader_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module -use KIM_API - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_KIM -type IPModel_KIM - integer(kind=kim_intptr) :: pkim = 0 - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - character(len=STRING_LENGTH) KIM_Model_name, KIM_Test_name - - logical :: kim_is_initialised = .false. - - integer, pointer :: atomTypeOfZ(:) => null() - character(len=512), pointer :: model_optional_outputs(:) => null() - - logical :: kim_model_has_energy, kim_model_has_forces, kim_model_has_particleenergy, kim_model_has_virial - -end type IPModel_KIM - -!NB in an ideal world these should not be global variables, but that requires -!NB passing in a neighObject explicitly into the iterator, rather than just a pkim -!NB maybe something can be done with a KIM buffer? -integer :: kim_iterator_current_i = -1 -type(Atoms), pointer :: kim_at - -interface Initialise - module procedure IPModel_KIM_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_KIM_Finalise -end interface Finalise - -interface Print - module procedure IPModel_KIM_Print -end interface Print - -interface Calc - module procedure IPModel_KIM_Calc -end interface Calc - -contains - -subroutine IPModel_KIM_Initialise_str(this, args_str, param_str) - type(IPModel_KIM), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - integer :: n_atom_types, kim_at_type_code, Z_i, at_type_i, j, k - character(len=KIM_KEY_STRING_LENGTH) atom_types_list(1); pointer(p_atom_types_list, atom_types_list) - - type(Dictionary) :: params - integer :: kim_error - type(Extendable_Str) :: test_kim_es - - - ! Some day it would be nice if this could be cleaner with F2003 pointers - real(dp) :: cutoffstub; pointer(pcutoff,cutoffstub); - - call Finalise(this) - - ! get params from QUIP, specifically KIM model and test names - call initialise(params) - call param_register(params, 'KIM_Model_name', PARAM_MANDATORY, this%KIM_Model_name, help_string="Name of KIM Model to initialise") - call param_register(params, 'KIM_Test_name', '-', this%KIM_Test_name, help_string="Name of KIM Test to initialise. If '-', autogenerate test.kim file") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_KIM_Initialise_str args_str')) then - call system_abort("IPModel_KIM_Initialise_str failed to parse args_str="//trim(args_str)) - endif - call finalise(params) - -#ifdef KIM_NO_AUTOGENERATE_TEST_KIM - if (trim(this%KIM_Test_name) == '-') then - call system_abort("IPModel_KIM_Initialise_str: no support for KIM_Test_name=- autogenerate test.kim file") - endif -#endif - -#ifndef KIM_NO_AUTOGENERATE_TEST_KIM - if (trim(this%KIM_Test_name) == '-') then - ! create KIM test file string from model kim string - call write_test_kim_file_from_model(this, test_kim_es) - - ! KIM routines to initialise pkim based on this%KIM_Test_name string - kim_error = KIM_API_string_init_f(this%pkim, string(test_kim_es)//char(0), this%KIM_Model_name) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_init_str_testname_f failed", kim_error) /= KIM_STATUS_OK) then - call print(test_kim_es) - call system_abort("IPModel_KIM_Initialise_str: kim_api_init_str_testname_f with Test='"//trim(this%KIM_Test_name)// & - "' and Model='"//trim(this%KIM_Model_name)//"' failed") - endif - - else -#endif - ! KIM routines to initialise pkim based on this%KIM_Test_name - kim_error = KIM_API_init_f(this%pkim, this%KIM_Test_name, this%KIM_Model_name) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_init_f failed", kim_error) /= KIM_STATUS_OK) & - call system_abort("IPModel_KIM_Initialise_str: kim_api_init_f with Test='"//trim(this%KIM_Test_name)// & - "' and Model='"//trim(this%KIM_Model_name)//"' failed") -#ifndef KIM_NO_AUTOGENERATE_TEST_KIM - endif -#endif - - this%kim_is_initialised = .true. - kim_iterator_current_i = -1 - nullify(kim_at) - - ! create array for conversion of atomic numbers to KIM atom type codes - p_atom_types_list = KIM_API_get_model_partcl_typs_f(this%pkim, n_atom_types, kim_error) - - allocate(this%atomTypeOfZ(size(ElementName))) - this%atomTypeOfZ(:) = -1 - do at_type_i=1, n_atom_types - ! replace null termination with space padding (C -> Fortran) - do j=1, KIM_KEY_STRING_LENGTH - if (atom_types_list(at_type_i)(j:j) == char(0)) then - do k=j, KIM_KEY_STRING_LENGTH - atom_types_list(at_type_i)(k:k) = ' ' - end do - exit - endif - end do - kim_at_type_code = KIM_API_get_partcl_type_code_f(this%pkim, trim(atom_types_list(at_type_i)), kim_error) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_get_partcl_type_code_f failed", kim_error) /= KIM_STATUS_OK) & - call system_abort("failed to find name of atom type "//at_type_i//" '"//trim(atom_types_list(at_type_i))//"' in pkim") - Z_i = find_in_array(ElementName, trim(atom_types_list(at_type_i))) - if (Z_i < 1) then - call system_abort("failed to find atomic number for name of atom type "//at_type_i//" '"//trim(atom_types_list(at_type_i))//"'") - endif - Z_i = Z_i - 1 - this%atomTypeOfZ(Z_i) = kim_at_type_code - end do - - ! register the neighbor list iterator - kim_error = kim_api_set_data_f(this%pkim, "get_neigh", int(1,8), loc(quip_neighbour_iterator)) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_set_data_f failed", kim_error) /= KIM_STATUS_OK) & - call system_abort("IPModel_KIM_Initialise_str failed to register quip_neighbour_iterator in kim") - - ! register the cutoff - kim_error = kim_api_set_data_f(this%pkim, "cutoff", int(1,8), loc(this%cutoff)) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_set_data_f failed", kim_error) /= KIM_STATUS_OK) & - call system_abort("IPModel_KIM_Initialise_str failed to register cutoff in kim") - - ! initialize the model - kim_error = KIM_API_model_init_f(this%pkim) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_model_init_f failed", kim_error) /= KIM_STATUS_OK) & - call system_abort("IPModel_KIM_Initialise_str: kim_api_model_init_f failed") - -end subroutine IPModel_KIM_Initialise_str - -function quip_neighbour_iterator(pkim, iterator_mode, request, atom, nneigh, p_neigh_list, p_neigh_rij) result(outval) - integer(kind=kim_intptr) :: pkim - integer :: iterator_mode, request, atom, nneigh - - !NB 512 should be replaced with a KIM constant - integer, save :: neigh_list(512) - integer :: neigh_list_stub(1); pointer (p_neigh_list, neigh_list_stub) - - !NB 512 should be replaced with a KIM constant - real(dp), save :: neigh_rij(3,512) - real(dp) :: neigh_rij_stub(3,1); pointer (p_neigh_rij, neigh_rij_stub) - - integer :: outval - - integer :: ji - - p_neigh_rij = loc(neigh_rij(1,1)) - p_neigh_list = loc(neigh_list(1)) - - if (iterator_mode == 1) then ! locator mode - if (request < 1 .or. request > kim_at%N) then - outval = KIM_STATUS_NEIGH_INVALID_REQUEST - return - endif - atom = request - else if (iterator_mode == 0) then ! iterator mode - if (request == 0) then - kim_iterator_current_i = 1 - outval = KIM_STATUS_NEIGH_ITER_INIT_OK - return - else if (request == 1) then - if (kim_iterator_current_i > kim_at%N) then - outval = KIM_STATUS_NEIGH_ITER_PAST_END - return - endif - atom = kim_iterator_current_i - kim_iterator_current_i = kim_iterator_current_i + 1 - else ! other iterator requests - outval = KIM_STATUS_NEIGH_INVALID_REQUEST - return - endif - else ! other mode - outval = KIM_STATUS_NEIGH_INVALID_MODE - return - endif - - nneigh = n_neighbours(kim_at, atom) - do ji=1, nneigh - neigh_list(ji) = neighbour(kim_at, atom, ji, diff = neigh_rij(1:3,ji)) - end do - - outval = KIM_STATUS_OK - -end function quip_neighbour_iterator - -subroutine IPModel_KIM_Finalise(this) - type(IPModel_KIM), intent(inout) :: this - - integer :: kim_error - - !! BAD - bug in gfortran 4.5 makes (apparently) this%kim_is_initialised is not set correctly for new structures, so we can't trust it - if (this%kim_is_initialised) then - kim_error = kim_api_model_destroy_f(this%pkim) - call kim_api_free_f(this%pkim, kim_error) - endif - - this%KIM_Test_name = '' - this%KIM_Model_name = '' - this%cutoff = 0.0_dp - this%kim_is_initialised = .false. - kim_iterator_current_i = -1 - if (this%pkim /= 0) then - if (associated(this%AtomTypeOfZ)) deallocate(this%AtomTypeOfZ) - if (associated(this%model_optional_outputs)) deallocate(this%model_optional_outputs) - endif - this%pkim = 0 - nullify(kim_at) -end subroutine IPModel_KIM_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_KIM_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_KIM), intent(inout) :: this - type(Atoms), intent(inout), target :: at - real(dp), intent(out), target, optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), target, optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - character(len=STRING_LENGTH) :: extra_calcs_list(10) - integer :: n_extra_calcs - integer*8 :: ppos, pf, pe, pN, pNlocal - integer*8 :: Nstub - - real(dp) :: virial_sym(6) - integer :: i - integer :: numberAtomTypes - integer, allocatable :: atomTypes(:) - integer kim_error - integer :: bad_i(1) - - real(dp), target :: t_e - real(dp), allocatable, target :: t_local_e(:), t_f(:,:) - real(dp), pointer :: p_e, p_local_e(:), p_f(:,:) - - INIT_ERROR(error) - - ! check for unsupported output quantities - if (present(local_virial)) then - RAISE_ERROR("IPModel_KIM_Calc can't handle local_virial yet", error) - endif - if (present(args_str)) then - if (len_trim(args_str) > 0) then - n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) - if (n_extra_calcs > 0) then - RAISE_ERROR("No extra calcs supported, found "//n_extra_calcs//" in args_str " // trim(args_str), error) - endif - endif - endif - - ! allocate atomTypes array for conversion from atomic number to atom type - allocate(atomTypes(at%N)) - atomTypes(1:at%N) = this%atomTypeOfZ(at%Z(1:at%N)) - if (any(atomTypes < 0)) then - bad_i = minloc(atomTypes) - RAISE_ERROR("Some Z mapped to an invalid atom type, e.g. atom "//bad_i(1)//" Z "//at%Z(bad_i(1)), error) - endif - numberAtomTypes = maxval(this%atomTypeOfZ) - - ! register config input information - call kim_api_setm_data_f(this%pkim, kim_error, & - "numberOfParticles", int(1,8), loc(at%N), KIM_L(.true.), & - "coordinates", int(3*at%N,8), loc(at%pos(1,1)), KIM_L(.true.), & - "numberParticleTypes", int(numberAtomTypes,8), loc(numberAtomTypes), KIM_L(.true.), & - "particleTypes", int(at%N,8), loc(atomTypes(1)), KIM_L(.true.)) - ! deal with ghost atoms later (numberOfContributingAtoms) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_setm_data_f for inputs failed", kim_error) /= KIM_STATUS_OK) then - RAISE_ERROR("Failed to setm_data for numberOfParticles, coordinates, particleTypes fields in pkim", error) - endif - - ! it would be nice to know if model outputs are optional or not, so we don't have to allocate them - ! if we don't need to - if (present(e)) then - if (.not. this%kim_model_has_energy) & - call system_abort("IPModel_KIM_calc got energy, but kim model does not return energy") - p_e => e - else - p_e => t_e - endif - if (present(f)) then - if (.not. this%kim_model_has_forces) & - call system_abort("IPModel_KIM_calc got forces, but kim model does not return forces") - p_f => f - else - if (this%kim_model_has_forces) then - allocate(t_f(3, at%N)) - else - allocate(t_f(1, 1)) - endif - p_f => t_f - endif - if (present(local_e)) then - if (.not. this%kim_model_has_particleenergy) & - call system_abort("IPModel_KIM_calc got local_e, but kim model does not return particleEnergy") - p_f => f - else - if (this%kim_model_has_particleenergy) then - allocate(t_local_e(at%N)) - else - allocate(t_local_e(1)) - endif - p_local_e => t_local_e - endif - ! virial is already dealt with because virial_sym needs to be defined separately from virial (6 vs. 3x3) - - ! register config output information - call kim_api_setm_data_f(this%pkim, kim_error, & - "energy", int(1,8), loc(p_e), KIM_L(.true.), & - "particleEnergy", int(at%N,8), loc(p_local_e(1)), KIM_L(.true.), & - "forces", int(3*at%N,8), loc(p_f(1,1)), KIM_L(.true.), & - "virial", int(6,8), loc(virial_sym(1)), KIM_L(.true.)) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_setm_data_f for output failed", kim_error) /= KIM_STATUS_OK) then - RAISE_ERROR("Failed to setm_data for energy, particleEnergy, forces, virial fields in pkim", error) - endif - - ! set compute for config output information - call kim_api_setm_compute_f(this%pkim, kim_error, & - "energy", KIM_COMPUTE_L(present(e)), KIM_L(.true.), & - "particleEnergy", KIM_COMPUTE_L(present(local_e)), KIM_L(.true.), & - "forces", KIM_COMPUTE_L(present(f)), KIM_L(.true.), & - "virial", KIM_COMPUTE_L(present(virial)), KIM_L(.true.)) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_setm_compute_f for outputs failed", kim_error) /= KIM_STATUS_OK) then - RAISE_ERROR("Failed to setm_compute for energy, particleEnergy, forces, virial field in pkim", error) - endif - - ! set data for neighbor stuff - - kim_at => at - - kim_error = kim_api_set_data_f(this%pkim, "neighObject", int(1,8), loc(at%N)) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_set_data_f for neighObject failed", kim_error) /= KIM_STATUS_OK) then - RAISE_ERROR("Failed to create neighObject field in pkim", error) - endif - - kim_error = kim_api_model_compute_f(this%pkim) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_model_compute_f failed", kim_error) /= KIM_STATUS_OK) then - RAISE_ERROR("Failed to compute with KIM Model", error) - endif - - if (present(virial)) then - virial(1,1) = -virial_sym(1) - virial(2,2) = -virial_sym(2) - virial(3,3) = -virial_sym(3) - virial(2,3) = -virial_sym(4) - virial(3,2) = -virial_sym(4) - virial(1,3) = -virial_sym(5) - virial(3,1) = -virial_sym(5) - virial(1,2) = -virial_sym(6) - virial(2,1) = -virial_sym(6) - endif - - deallocate(atomTypes) - if (allocated(t_f)) deallocate(t_f) - if (allocated(t_local_e)) deallocate(t_local_e) - -end subroutine IPModel_KIM_Calc - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of KIM parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_KIM_Print (this, file) - type(IPModel_KIM), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_KIM : KIM", file=file) - call Print("IPModel_KIM : Test name = " // trim(this%KIM_Test_name) // " Model name = " // & - trim(this%KIM_Model_Name) // " cutoff = " // this%cutoff, file=file) - -end subroutine IPModel_KIM_Print - -function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) - character(len=*), intent(in) :: args_str - character(len=*), intent(out) :: extra_calcs_list(:) - integer :: n_extra_calcs - - character(len=STRING_LENGTH) :: extra_calcs_str - type(Dictionary) :: params - - n_extra_calcs = 0 - call initialise(params) - call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") - if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then - if (len_trim(extra_calcs_str) > 0) then - call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") - end if - end if - call finalise(params) - -end function parse_extra_calcs - -subroutine write_test_kim_file_from_model(this, test_kim_es) - type(IPModel_KIM), intent(inout) :: this - type(Extendable_Str) :: test_kim_es - - integer kim_error - integer :: i, str_len - character(len=1) :: model_str_stub(1); pointer(p_model_str, model_str_stub) - - integer :: sec_start, sec_end - character(len=80) :: cur_sec_name - integer :: t_index - integer(kind=kim_intptr) :: t_pkim = 0 - character(len=1000) :: test_model_output - - - p_model_str = kim_api_get_model_kim_str_f(trim(this%KIM_model_name), str_len, kim_error) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_get_model_kim_str failed", kim_error) /= KIM_STATUS_OK) & - call system_abort("Failed to get model .kim string") - - call initialise(test_kim_es) - do i=1, str_len - call concat(test_kim_es, model_str_stub(i), no_trim=.true.) - end do - - ! keep SUPPORTED_ATOM/PARTICLE_TYPES - will fail at compute type if it doesn't match - - ! get rid of MODEL_PARAMETERS section - call find_section(test_kim_es, "MODEL_PARAMETERS", sec_start, sec_end) - if (sec_start > 0) then - call substr_replace(test_kim_es, sec_start, sec_end, "") - endif - - ! set CONVENTIONS section to QUIP's restrictions - call find_section(test_kim_es, "CONVENTIONS", sec_start, sec_end) - if (sec_start > 0) then - call substr_replace(test_kim_es, sec_start, sec_end, & - "CONVENTIONS:"//quip_new_line// & - " OneBasedLists flag"//quip_new_line// & - " Neigh_BothAccess flag"//quip_new_line// & - " NEIGH_RVEC_F flag"//quip_new_line//quip_new_line// & - "################################################################################") - else - call system_abort("write_test_kim_file_from_model failed to find CONVENTIONS section") - endif - - ! set MODEL_INPUT section to what QUIP supports - call find_section(test_kim_es, "MODEL_INPUT", sec_start, sec_end) - if (sec_start > 0) then - call substr_replace(test_kim_es, sec_start, sec_end, & - "MODEL_INPUT:"//quip_new_line// & - "# Name Type Unit Shape Requirements"//quip_new_line// & - "numberOfParticles integer none []"//quip_new_line// & - "numberParticleTypes integer none []"//quip_new_line// & - "particleTypes integer none [numberOfParticles]"//quip_new_line// & - "coordinates real*8 length [numberOfParticles,3]"//quip_new_line// & - "get_neigh method none []"//quip_new_line// & - "neighObject pointer none []"//quip_new_line// & - "#######################################################################################################") - else - call system_abort("write_test_kim_file_from_model failed to find MODEL_INPUT section") - endif - - ! promise to use every model output - kim_error = KIM_API_model_info_f(t_pkim, this%KIM_Model_name) - if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_model_info_f failed", kim_error) /= KIM_STATUS_OK) & - call system_abort("Failed to get info for kim model "//trim(this%KIM_model_name)) - - t_index = KIM_API_get_index_f(t_pkim, "energy", kim_error) - this%kim_model_has_energy = (kim_error == KIM_STATUS_OK) - t_index = KIM_API_get_index_f(t_pkim, "forces", kim_error) - this%kim_model_has_forces = (kim_error == KIM_STATUS_OK) - t_index = KIM_API_get_index_f(t_pkim, "particleEnergy", kim_error) - this%kim_model_has_particleenergy = (kim_error == KIM_STATUS_OK) - t_index = KIM_API_get_index_f(t_pkim, "virial", kim_error) - this%kim_model_has_virial = (kim_error == KIM_STATUS_OK) - - test_model_output = & - "destroy method none []"//quip_new_line// & - "compute method none []"//quip_new_line// & - "cutoff real*8 length []"//quip_new_line - if (this%kim_model_has_energy) & - test_model_output = trim(test_model_output)// & - "energy real*8 energy []"//quip_new_line - if (this%kim_model_has_forces) & - test_model_output = trim(test_model_output)// & - "forces real*8 force [numberOfParticles,3]"//quip_new_line - if (this%kim_model_has_particleenergy) & - test_model_output = trim(test_model_output)// & - "particleEnergy real*8 energy [numberOfParticles]"//quip_new_line - if (this%kim_model_has_virial) & - test_model_output = trim(test_model_output)// & - "virial real*8 energy [6]"//quip_new_line - - call find_section(test_kim_es, "MODEL_OUTPUT", sec_start, sec_end) - if (sec_start > 0) then - call substr_replace(test_kim_es, sec_start, sec_end, & - "MODEL_OUTPUT:"//quip_new_line// & - "# Name Type Unit Shape "//quip_new_line// & - trim(test_model_output)// & - "#######################################################################################################") - else - call system_abort("write_test_kim_file_from_model failed to find MODEL_OUTPUT section") - endif - -end subroutine write_test_kim_file_from_model - -subroutine find_section(test_kim_es, sec_name, sec_start, sec_end) - type(Extendable_Str) :: test_kim_es - character(len=*), intent(in) :: sec_name - integer, intent(out) :: sec_start, sec_end - - integer :: cur_sec_loc, next_sec_loc - character(len=80) :: cur_sec_name - - sec_start = -1 - sec_end = -1 - - cur_sec_loc = find_section_label(test_kim_es, 1, cur_sec_name) - do while (cur_sec_loc > 0) - if (trim(cur_sec_name) == trim(sec_name)) then - sec_start = cur_sec_loc - next_sec_loc = find_section_label(test_kim_es, cur_sec_loc+len_trim(cur_sec_name)+1) - if (next_sec_loc <= 0) then - sec_end = test_kim_es%len - else - sec_end = next_sec_loc - 2 - endif - return - endif - cur_sec_loc = find_section_label(test_kim_es, cur_sec_loc+len_trim(cur_sec_name)+1, cur_sec_name) - end do - -end subroutine find_section - -function find_section_label(test_kim_es, start, sec_name) result(sec_loc) - type(Extendable_Str) :: test_kim_es - integer, intent(in) :: start - character(len=*), optional :: sec_name - integer :: sec_loc - - integer :: i - logical :: after_newline, in_section, is_newline, is_section_char, is_section_end - character(len=80) :: t_sec_name - - after_newline = (start == 1) - - sec_loc = -1 - in_section = .false. - do i=start, test_kim_es%len - is_newline = (substr(test_kim_es,i,i) == quip_new_line) - is_section_char = (scan(substr(test_kim_es,i,i),"ABCDEFGHIJKLMNOPQRSTUVWXYZ_") > 0) - is_section_end = (substr(test_kim_es,i,i) == ':') - if (after_newline) then - if (is_section_char) then - in_section = .true. - t_sec_name = substr(test_kim_es, i, i) - endif - else ! not after newline - if (in_section) then - if (is_section_end) then - sec_loc = i-len_trim(t_sec_name) - if (present(sec_name)) sec_name = trim(t_sec_name) - return - else if (is_section_char) then - t_sec_name = trim(t_sec_name) // substr(test_kim_es, i, i) - else - sec_loc = -1 - in_section = .false. - endif - endif - endif - after_newline = is_newline - end do - - sec_loc = -1 - in_section = .false. - -end function find_section_label - -function KIM_L(l) - logical, intent(in) :: l - integer :: KIM_L - - if (l) then - KIM_L = 1 - else - KIM_L = 0 - endif -end function KIM_L - -function KIM_COMPUTE_L(l) - logical, intent(in) :: l - integer :: KIM_COMPUTE_L - - if (l) then - KIM_COMPUTE_L = KIM_COMPUTE_TRUE - else - KIM_COMPUTE_L = KIM_COMPUTE_FALSE - endif -end function KIM_COMPUTE_L - -end module IPModel_KIM_module diff --git a/src/Potentials/IPModel_LJ.f95 b/src/Potentials/IPModel_LJ.f95 deleted file mode 100644 index f3a694c144..0000000000 --- a/src/Potentials/IPModel_LJ.f95 +++ /dev/null @@ -1,747 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_LJ module -!X -!% Module for Lennard-Jones pair potential. -!% \begin{equation} -!% \nonumber -!% V(r) = 4 \epsilon \left[ \left( \frac{\sigma}{r} \right)^{12} - \left( \frac{\sigma}{r} \right)^6 \right] -!% \end{equation} -!% For parameters see Ashcroft and Mermin, {\it Solid State Physics}. -!% -!% NB: The energy calculation in the code is -!% \begin{equation*} -!% V(r) = \epsilon_{12} (\sigma/r)^{12} - \epsilon_6 (\sigma/r)^6 -!% \end{equation*} -!% (plus energy and linear force shift, if applicable) -!% hence the factor 4 has to be included in the potential XML file. -!% -!% If requested, tail corrections are added for all pairs with a -!% nonzero $\epsilon_6$ (i.e. a nonzero sixth-power tail). This -!% requires all such pairs to have equal cutoffs and smooth cutoff -!% widths. See the documentation for the 'DispTS' potential for -!% more information on how these corrections are computed in QUIP. -!% -!% The IPModel_LJ object contains all the parameters read from a -!% 'LJ_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_LJ_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use units_module, only : PI -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_LJ -type IPModel_LJ - integer :: n_types = 0 !% Number of atomic types. - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - real(dp), allocatable :: sigma(:,:), eps6(:,:), eps12(:,:), cutoff_a(:,:), energy_shift(:,:), linear_force_shift(:,:), smooth_cutoff_width(:,:) !% IP parameters. - real(dp) :: tail_corr_smooth_factor - real(dp) :: tail_corr_const - real(dp), allocatable :: tail_c6_coeffs(:,:) - logical :: only_inter_resid = .false. - logical :: do_tail_corrections = .false. - logical :: tail_smooth_cutoff = .false. - - character(len=STRING_LENGTH) label - -end type IPModel_LJ - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_LJ), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_LJ_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_LJ_Finalise -end interface Finalise - -interface Print - module procedure IPModel_LJ_Print -end interface Print - -interface Calc - module procedure IPModel_LJ_Calc -end interface Calc - -contains - -subroutine IPModel_LJ_Initialise_str(this, args_str, param_str) - type(IPModel_LJ), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - real(dp) :: tc_cutoff = -1.0_dp - real(dp) :: tc_ctw = -1.0_dp - integer :: ti,tj - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label = '' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LJ_Initialise_str args_str')) then - call system_abort("IPModel_LJ_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_LJ_read_params_xml(this, param_str) - - this%cutoff = maxval(this%cutoff_a) - - ! Check whether we can even do tail corrections, then set up the constants - if (this%do_tail_corrections) then - tc_cutoff = -1.0_dp - allocate(this%tail_c6_coeffs(this%n_types, this%n_types)) - do ti = 1,this%n_types - do tj = ti,this%n_types - if (this%eps6(ti,tj) .fne. 0.0_dp) then - - if ((this%energy_shift(ti,tj) .fne. 0.0_dp) .or. & - (this%linear_force_shift(ti,tj) .fne. 0.0_dp)) then - call system_abort("IPModel_LJ_Initialise_str: Tail corrections not implemented with & - energy or force shifts") - endif - - if (tc_cutoff .feq. -1.0_dp) then - tc_cutoff = this%cutoff_a(ti,tj) - tc_ctw = this%smooth_cutoff_width(ti,tj) - else if (this%cutoff_a(ti,tj) .fne. tc_cutoff) then - call system_abort("IPModel_LJ_Initialise_str: Tail corrections require all & - cutoffs to be equal; " // this%cutoff_a(ti,tj) //" =/= "// tc_cutoff) - else if (this%smooth_cutoff_width(ti,tj) .fne. tc_ctw) then - call system_abort("IPModel_LJ_Initialise_str: Tail corrections require all & - cutoff transition widths to be equal; " // this%smooth_cutoff_width(ti,tj) //" =/= "// tc_ctw) - endif - this%tail_c6_coeffs(ti,tj) = this%eps6(ti,tj) * this%sigma(ti,tj)**6 - else - this%tail_c6_coeffs(ti,tj) = 0.0_dp - endif - this%tail_c6_coeffs(tj,ti) = this%tail_c6_coeffs(ti,tj) - enddo - enddo - if (tc_cutoff .fgt. 0.0_dp) then - if (tc_ctw .fgt. 0.0_dp) then - this%tail_smooth_cutoff = .true. - this%tail_corr_const = -2.0_dp * PI / 3.0_dp * & - ((1.0_dp - this%tail_corr_smooth_factor) / (tc_cutoff - tc_ctw)**3 & - + this%tail_corr_smooth_factor / tc_cutoff**3) - else - this%tail_smooth_cutoff = .false. - this%tail_corr_const = -2.0_dp * PI / 3.0_dp / tc_cutoff**3 - endif - else - this%tail_corr_const = 0.0_dp - this%do_tail_corrections = .false. - endif - endif - -end subroutine IPModel_LJ_Initialise_str - -subroutine IPModel_LJ_Finalise(this) - type(IPModel_LJ), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%sigma)) deallocate(this%sigma) - if (allocated(this%eps6)) deallocate(this%eps6) - if (allocated(this%eps12)) deallocate(this%eps12) - if (allocated(this%cutoff_a)) deallocate(this%cutoff_a) - if (allocated(this%energy_shift)) deallocate(this%energy_shift) - if (allocated(this%linear_force_shift)) deallocate(this%linear_force_shift) - if (allocated(this%smooth_cutoff_width)) deallocate(this%smooth_cutoff_width) - if (allocated(this%tail_c6_coeffs)) deallocate(this%tail_c6_coeffs) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_LJ_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_LJ_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_LJ), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), pointer :: w_e(:) - integer i, ji, j, ti, tj, d - real(dp) :: dr(3), dr_mag - real(dp) :: de, de_dr - logical :: i_is_min_image - - integer :: i_calc, n_extra_calcs - character(len=20) :: extra_calcs_list(10) - - logical :: do_flux = .false. - real(dp), pointer :: velo(:,:) - real(dp) :: flux(3) - - integer, pointer :: resid(:) - real(dp) :: c6_sum, tail_correction - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_LJ_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_LJ_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_LJ_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_LJ_Calc: local_virial calculation requested but not supported yet.", error) - endif - - if (this%only_inter_resid) then - if (.not. assign_pointer(at, "resid", resid)) then - RAISE_ERROR("IPModel_LJ_Calc calculation with only_inter_resid=T requires resid field", error) - endif - end if - - if (present(args_str)) then - if (len_trim(args_str) > 0) then - n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) - if (n_extra_calcs > 0) then - do i_calc=1, n_extra_calcs - select case(trim(extra_calcs_list(i_calc))) - case("flux") - if (.not. assign_pointer(at, "velo", velo)) then - RAISE_ERROR("IPModel_LJ_Calc Flux calculation requires velo field", error) - endif - do_flux = .true. - flux = 0.0_dp - case default - RAISE_ERROR("Unsupported extra_calc '"//trim(extra_calcs_list(i_calc))//"'", error) - end select - end do - endif ! n_extra_calcs - endif ! len_trim(args_str) - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LJ_Calc args_str')) then - RAISE_ERROR("IPModel_LJ_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_LJ_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_LJ_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - endif ! present(args_str) - - if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) - - c6_sum = 0.0_dp - do i = 1, at%N - i_is_min_image = is_min_image(at,i) - - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - ! Might be optimized if we have only_inter_resid=F - ! Can then just count number of pairs of each type - if (this%do_tail_corrections) then - do j = i+1, at%N - if (this%only_inter_resid) then - if (resid(i) == resid(j)) cycle - endif - tj = get_type(this%type_of_atomic_num, at%Z(j)) - if (this%tail_c6_coeffs(tj,ti) .fne. 0.0_dp) then - c6_sum = c6_sum + 2*this%tail_c6_coeffs(tj,ti) - endif - enddo - endif - - do ji = 1, n_neighbours(at, i) - j = neighbour(at, i, ji, dr_mag, cosines = dr) - - if (dr_mag .feq. 0.0_dp) cycle - !if ((i < j) .and. i_is_min_image) cycle - if ((i < j)) cycle - - if (this%only_inter_resid) then - if (resid(i) == resid(j)) cycle - end if - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (present(e) .or. present(local_e)) then - de = IPModel_LJ_pairenergy(this, ti, tj, dr_mag) - - if (present(local_e)) then - local_e(i) = local_e(i) + 0.5_dp*de - !if(i_is_min_image) local_e(j) = local_e(j) + 0.5_dp*de - if(i/=j) local_e(j) = local_e(j) + 0.5_dp*de - endif - if (present(e)) then - if (associated(w_e)) then - de = de*0.5_dp*(w_e(i)+w_e(j)) - endif - !if(i_is_min_image) then - ! e = e + de - !else - if(i==j) then - e = e + 0.5_dp*de - else - e = e + de - endif - !endif - endif - endif - if (present(f) .or. present(virial) .or. do_flux) then - de_dr = IPModel_LJ_pairenergy_deriv(this, ti, tj, dr_mag) - if (associated(w_e)) then - de_dr = de_dr*0.5_dp*(w_e(i)+w_e(j)) - endif - if (present(f)) then - f(:,i) = f(:,i) + de_dr*dr - !if(i_is_min_image) f(:,j) = f(:,j) - de_dr*dr - if(i/=j) f(:,j) = f(:,j) - de_dr*dr - endif - if (do_flux) then - ! -0.5 (v_i + v_j) . F_ij * dr_ij - flux = flux - 0.5_dp*sum((velo(:,i)+velo(:,j))*(de_dr*dr))*(dr*dr_mag) - endif - if (present(virial)) then - !if(i_is_min_image) then - ! virial = virial - de_dr*(dr .outer. dr)*dr_mag - !else - if(i==j) then - virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*dr_mag - else - virial = virial - de_dr*(dr .outer. dr)*dr_mag - endif - !endif - endif - endif - end do - end do - - if (this%do_tail_corrections) then - tail_correction = c6_sum * this%tail_corr_const / cell_volume(at) - if (present(e)) e = e + tail_correction - if (present(virial)) then - do d = 1, 3 - if (this%tail_smooth_cutoff) then - ! Seems counterintuitive, but the math works out (for r^-6 potentials) - virial(d,d) = virial(d,d) + tail_correction - else - virial(d,d) = virial(d,d) + 2*tail_correction - endif - enddo - endif - endif - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(f)) call sum_in_place(mpi, f) - endif - if (do_flux) then - flux = flux / cell_volume(at) - if (present(mpi)) call sum_in_place(mpi, flux) - call set_value(at%params, "Flux", flux) - endif - -end subroutine IPModel_LJ_Calc - -!% This routine computes the two-body term for a pair of atoms separated by a distance r. -function IPModel_LJ_pairenergy(this, ti, tj, r) - type(IPModel_LJ), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_LJ_pairenergy - - real(dp) :: tpow - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then - IPModel_LJ_pairenergy = 0.0_dp - return - endif - - tpow = (this%sigma(ti,tj)/r)**6 - - IPModel_LJ_pairenergy = (this%eps12(ti,tj)*tpow*tpow - this%eps6(ti,tj)*tpow) - this%energy_shift(ti,tj) - & - & this%linear_force_shift(ti,tj)*(r-this%cutoff_a(ti,tj)) - - if (.not. (this%smooth_cutoff_width(ti,tj) .feq. 0.0_dp)) then - IPModel_LJ_pairenergy = IPModel_LJ_pairenergy*poly_switch(r,this%cutoff_a(ti,tj),this%smooth_cutoff_width(ti,tj)) - end if - -end function IPModel_LJ_pairenergy - -!% Derivative of the two-body term. -function IPModel_LJ_pairenergy_deriv(this, ti, tj, r) - type(IPModel_LJ), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_LJ_pairenergy_deriv - - real(dp) :: tpow - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then - IPModel_LJ_pairenergy_deriv = 0.0_dp - return - endif - - tpow = (this%sigma(ti,tj)/r)**6 - - IPModel_LJ_pairenergy_deriv = (-12.0_dp*this%eps12(ti,tj)*tpow*tpow + 6.0_dp*this%eps6(ti,tj)*tpow)/r - this%linear_force_shift(ti,tj) - - if (.not. (this%smooth_cutoff_width(ti,tj) .feq. 0.0_dp)) then - IPModel_LJ_pairenergy_deriv = IPModel_LJ_pairenergy_deriv * poly_switch(r,this%cutoff_a(ti,tj),this%smooth_cutoff_width(ti,tj)) & - +IPModel_LJ_pairenergy(this, ti, tj, r) * dpoly_switch(r,this%cutoff_a(ti,tj),this%smooth_cutoff_width(ti,tj)) - - end if - -end function IPModel_LJ_pairenergy_deriv - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for XML stanza is given below, please notice that -!% they are simply dummy parameters for testing purposes, with no physical meaning. -!% -!%> -!%> -!%> -!%> eps12="1.0" cutoff="6.0" energy_shift="T" linear_force_shift="F" /> -!%> eps12="2.0" cutoff="7.5" energy_shift="T" linear_force_shift="F" /> -!%> eps12="1.5" cutoff="6.75" energy_shift="T" linear_force_shift="F" /> -!%> -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - logical :: energy_shift, linear_force_shift,smooth_cutoff_width - integer :: ti, tj - - if (name == 'LJ_params') then ! new LJ stanza - - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered LJ_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in LJ_params") - endif - - call QUIP_FoX_get_value(attributes, 'only_inter_resid', value, status) - if (status == 0) then - read (value, *) parse_ip%only_inter_resid - else - parse_ip%only_inter_resid = .false. - endif - - call QUIP_FoX_get_value(attributes, 'tail_corr_factor', value, status) - if (status == 0) then - read (value, *) parse_ip%tail_corr_smooth_factor - parse_ip%do_tail_corrections = .true. - else - parse_ip%do_tail_corrections = .false. - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%sigma(parse_ip%n_types,parse_ip%n_types)) - parse_ip%sigma = 1.0_dp - allocate(parse_ip%eps6(parse_ip%n_types,parse_ip%n_types)) - parse_ip%eps6 = 0.0_dp - allocate(parse_ip%eps12(parse_ip%n_types,parse_ip%n_types)) - parse_ip%eps12 = 0.0_dp - allocate(parse_ip%cutoff_a(parse_ip%n_types,parse_ip%n_types)) - parse_ip%cutoff_a = 0.0_dp - allocate(parse_ip%energy_shift(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%linear_force_shift(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%smooth_cutoff_width(parse_ip%n_types,parse_ip%n_types)) - parse_ip%energy_shift = 0.0_dp - parse_ip%linear_force_shift = 0.0_dp - parse_ip%smooth_cutoff_width = 0.0_dp - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find type") - read (value, *) ti - - if (ti < 1) call system_abort("IPModel_LJ_read_params_xml got per_type_data type="//ti//" < 1") - if (ti > parse_ip%n_types) call system_abort("IPModel_LJ_read_params_xml got per_type_data type="//ti//" > n_types="//parse_ip%n_types) - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - parse_ip%energy_shift = 0.0_dp - parse_ip%linear_force_shift = 0.0_dp - parse_ip%smooth_cutoff_width = 0.0_dp - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "type1", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find type1") - read (value, *) ti - call QUIP_FoX_get_value(attributes, "type2", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find type2") - read (value, *) tj - - if (ti < 1) call system_abort("IPModel_LJ_read_params_xml got per_type_data type1="//ti//" < 1") - if (ti > parse_ip%n_types) call system_abort("IPModel_LJ_read_params_xml got per_pair_data type1="//ti//" > n_types="//parse_ip%n_types) - if (tj < 1) call system_abort("IPModel_LJ_read_params_xml got per_type_data type2="//tj//" < 1") - if (tj > parse_ip%n_types) call system_abort("IPModel_LJ_read_params_xml got per_pair_data type2="//tj//" > n_types="//parse_ip%n_types) - - call QUIP_FoX_get_value(attributes, "sigma", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find sigma") - read (value, *) parse_ip%sigma(ti,tj) - call QUIP_FoX_get_value(attributes, "eps6", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find eps6") - read (value, *) parse_ip%eps6(ti,tj) - call QUIP_FoX_get_value(attributes, "eps12", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find eps12") - read (value, *) parse_ip%eps12(ti,tj) - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff_a(ti,tj) - - call QUIP_FoX_get_value(attributes, "energy_shift", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find energy_shift") - read (value, *) energy_shift - if (energy_shift) parse_ip%energy_shift(ti,tj) = IPModel_LJ_pairenergy(parse_ip, ti, tj, parse_ip%cutoff_a(ti,tj)) - - call QUIP_FoX_get_value(attributes, "linear_force_shift", value, status) - if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find linear_force_shift") - read (value, *) linear_force_shift - if (linear_force_shift) parse_ip%linear_force_shift(ti,tj) = IPModel_LJ_pairenergy_deriv(parse_ip, ti, tj, parse_ip%cutoff_a(ti,tj)) - - call QUIP_FoX_get_value(attributes, "smooth_cutoff_width", value, status) - if (status == 0) read (value, *) parse_ip%smooth_cutoff_width(ti,tj) - - if (ti /= tj) then - parse_ip%eps6(tj,ti) = parse_ip%eps6(ti,tj) - parse_ip%eps12(tj,ti) = parse_ip%eps12(ti,tj) - parse_ip%sigma(tj,ti) = parse_ip%sigma(ti,tj) - parse_ip%cutoff_a(tj,ti) = parse_ip%cutoff_a(ti,tj) - parse_ip%energy_shift(tj,ti) = parse_ip%energy_shift(ti,tj) - parse_ip%linear_force_shift(tj,ti) = parse_ip%linear_force_shift(ti,tj) - parse_ip%smooth_cutoff_width(tj,ti) = parse_ip%smooth_cutoff_width(ti,tj) - end if - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'LJ_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_LJ_read_params_xml(this, param_str) - type(IPModel_LJ), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_LJ_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_LJ_read_params_xml - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of LJ parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_LJ_Print (this, file) - type(IPModel_LJ), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_LJ : Lennard-Jones", file=file) - call Print("IPModel_LJ : n_types = " // this%n_types // " cutoff = " // this%cutoff // & - " only_inter_resid = " // this%only_inter_resid // " do_tail_corrections = " // this%do_tail_corrections, file=file) - - do ti=1, this%n_types - call Print ("IPModel_LJ : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - do tj=1, this%n_types - call Print ("IPModel_LJ : interaction " // ti // " " // tj // " sigma " // this%sigma(ti,tj) // " eps6,12 " // & - this%eps6(ti,tj) // " " // this%eps12(ti,tj) // " cutoff_a " // this%cutoff_a(ti,tj) // " energy_shift " // & - this%energy_shift(ti,tj) // " linear_force_shift " // this%linear_force_shift(ti,tj) // & - " smooth_cutoff_width " // this%smooth_cutoff_width(ti,tj) , file=file) - end do - call verbosity_pop() - end do - -end subroutine IPModel_LJ_Print - -function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) - character(len=*), intent(in) :: args_str - character(len=*), intent(out) :: extra_calcs_list(:) - integer :: n_extra_calcs - - character(len=STRING_LENGTH) :: extra_calcs_str - type(Dictionary) :: params - - n_extra_calcs = 0 - call initialise(params) - call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") - if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then - if (len_trim(extra_calcs_str) > 0) then - call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") - end if - end if - call finalise(params) - -end function parse_extra_calcs - -end module IPModel_LJ_module diff --git a/src/Potentials/IPModel_LMTO_TBE.f95 b/src/Potentials/IPModel_LMTO_TBE.f95 deleted file mode 100644 index 9d64b9dbc0..0000000000 --- a/src/Potentials/IPModel_LMTO_TBE.f95 +++ /dev/null @@ -1,362 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_LMTO_TBE -!X -!% Interface to empirical Tight Binding code within LM suite -!% (https://bitbucket.org/lmto/lm/branch/libtbe) -!% -!% Requires linking with LMTO code (HAVE_LMTO_TBE=1 in Makefile.inc). -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_LMTO_TBE_module - -use error_module -use units_module, only: RYDBERG, BOHR -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -#ifdef HAVE_LMTO_TBE -use libtbe, only: tbinit, tbsc -#endif - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_LMTO_TBE -type IPModel_LMTO_TBE - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - real(dp) :: cutoff = 0.0_dp !% cutoff is always zero as LMTO code does its own neighbour calculation - character(len=STRING_LENGTH) :: label, control_file - type(Atoms) :: oldat - -end type IPModel_LMTO_TBE - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_LMTO_TBE), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_LMTO_TBE_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_LMTO_TBE_Finalise -end interface Finalise - -interface Print - module procedure IPModel_LMTO_TBE_Print -end interface Print - -interface Calc - module procedure IPModel_LMTO_TBE_Calc -end interface Calc - -contains - -subroutine IPModel_LMTO_TBE_Initialise_str(this, args_str, param_str) - type(IPModel_LMTO_TBE), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LMTO_TBE_Initialise_str args_str')) then - call system_abort("IPModel_LMTO_TBE_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_LMTO_TBE_read_params_xml(this, param_str) - -#ifdef HAVE_LMTO_TBE - call tbinit(this%control_file) -#else - call system_abort("IPModel_LMTO_TBE can only be used when compiled with HAVE_LMTO_TBE enabled") -#endif - - -end subroutine IPModel_LMTO_TBE_Initialise_str - -subroutine IPModel_LMTO_TBE_Finalise(this) - type(IPModel_LMTO_TBE), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_LMTO_TBE_Finalise - - -subroutine IPModel_LMTO_TBE_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_LMTO_TBE), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer i - logical :: reorder = .false. - integer, allocatable :: atypes(:) - real(dp), allocatable :: force(:,:), atpos(:,:) - real(dp) :: energy, atlattice(3,3) - integer, pointer :: index(:), oldindex(:) - - INIT_ERROR(error) - -#ifdef HAVE_LMTO_TBE - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_LMTO_TBE_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_LMTO_TBE_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_LMTO_TBE_Calc', error) - local_virial = 0.0_dp - endif - - ! check if Atoms is "equivalent" (isoatomic) to previous Atoms - ! if not we need to re-initialise the TB code - if (at%n /= this%oldat%n) then - call print('LMTO_TBE_Calc: natoms changed, reordering') - reorder = .true. - else if (maxval(abs(at%lattice - this%oldat%lattice)) > 1e-7_dp) then - call print('LMTO_TBE_Calc: lattice components changed, reordering') - reorder = .true. - else if (any(at%z /= this%oldat%z)) then - call print('LMTO_TBE_Calc: atomic numbers changed, reordering') - reorder = .true. - else if (has_property(at, 'index')) then - ! clusters have an 'index' property that points back to original atom - if (has_property(this%oldat, 'index')) then - call assign_property_pointer(at, 'index', index, error) - PASS_ERROR(error) - call assign_property_pointer(this%oldat, 'index', oldindex, error) - PASS_ERROR(error) - if (any(index /= oldindex)) then - call print('LMTO_TBE_Calc: atomic numbers changed, reordering') - reorder = .true. - end if - else - call print('LMTO_TBE_Calc: new atoms has "index" property, old does not, reordering') - reorder = .true. - end if - end if - - allocate(atypes(at%n), force(3, at%n), atpos(3, at%n)) - do i=1, at%N - atypes(i) = get_type(this%type_of_atomic_num, at%Z(i)) - end do - - call print('LMTO_TBE_Calc: invoking tbsc() on '//at%n//' atoms with reorder='//reorder) - - atlattice = at%lattice/BOHR - atpos = at%pos/BOHR - ! libtbe expects the force to be initialised as it will accumulate forces - force = 0.0_dp - - call tbsc(atlattice, at%n, atpos, atypes, energy, force, & - reorder=reorder, incomm=mpi%communicator) - if (present(e)) then - e = energy*RYDBERG - end if - if (present(f)) then - f = force*(RYDBERG/BOHR) - end if - - deallocate(atypes, force, atpos) - - call atoms_copy_without_connect(this%oldat, at) -#else - RAISE_ERROR("IPModel_LMTO_TBE_Calc() called but LMTO_TBE support not compiled in", error) -#endif - -end subroutine IPModel_LMTO_TBE_Calc - - -subroutine IPModel_LMTO_TBE_Print(this, file) - type(IPModel_LMTO_TBE), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_LMTO_TBE : LMTO_TBE Potential", file=file) - call Print("IPModel_LMTO_TBE : n_types = " // this%n_types, file=file) - - do ti=1, this%n_types - call Print ("IPModel_LMTO_TBE : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_LMTO_TBE", file=file) - call verbosity_pop() - end do - -end subroutine IPModel_LMTO_TBE_Print - -subroutine IPModel_LMTO_TBE_read_params_xml(this, param_str) - type(IPModel_LMTO_TBE), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_LMTO_TBE_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_LMTO_TBE_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - integer ti - - if (name == 'LMTO_TBE_params') then ! new LMTO_TBE stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in LMTO_TBE_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - call QUIP_FoX_get_value(attributes, "control_file", value, status) - if (status /= 0) call system_abort ("IPModel_LMTO_TBE_read_params_xml cannot find control_file") - read (value, *) parse_ip%control_file - - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_LMTO_TBE_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_LMTO_TBE_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'LMTO_TBE_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_LMTO_TBE_module diff --git a/src/Potentials/IPModel_LinearSOAP.f95 b/src/Potentials/IPModel_LinearSOAP.f95 deleted file mode 100644 index b94909ab8d..0000000000 --- a/src/Potentials/IPModel_LinearSOAP.f95 +++ /dev/null @@ -1,535 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_LinearSOAP module -!X -!% Module for a Linear SOAP potential. -!% \begin{equation} -!% \nonumber -!% E = \sum_i \beta \cdot p_{ss'nn'l,i} -!% \end{equation} -!% where $p_{ss'nn'l,i}$ is the SOAP sphericial power spectrum of atom i, and -!% $\beta$ is a vector of coefficients. -!% -!% The IPModel_LinearSOAP object contains all the parameters read from a -!% 'LinearSOAP_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_LinearSOAP_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -#ifdef HAVE_GAP -use descriptors_module -#endif -use mpi_context_module -use QUIP_Common_module -use extendable_str_module - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_LinearSOAP -type IPModel_LinearSOAP - integer :: n_types = 0 !% Number of atomic types. - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - real(dp) :: atom_sigma = 0.0_dp !% atom_sigma to be passed to SOAP - integer :: l_max = 0 - integer :: n_max = 0 - integer :: pissnl_dimension !% actual dimension of fit. - real(dp), allocatable :: e0(:) !% energy shift per atom - real(dp), allocatable :: beta(:,:) !% pissnl coefficients. size is the maximum of the pissnl_dimensions over all species - - character(len=STRING_LENGTH) label - -end type IPModel_LinearSOAP - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_LinearSOAP), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_LinearSOAP_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_LinearSOAP_Finalise -end interface Finalise - -interface Print - module procedure IPModel_LinearSOAP_Print -end interface Print - -interface Calc - module procedure IPModel_LinearSOAP_Calc -end interface Calc - -contains - -subroutine IPModel_LinearSOAP_Initialise_str(this, args_str, param_str) - type(IPModel_LinearSOAP), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - -! now initialise the potential -#ifndef HAVE_GAP - call system_abort('IPModel_LinearSOAP_Initialise_str: must be compiled with HAVE_GAP') -#else - - call initialise(params) - this%label = '' - call param_register(params, 'label', '', this%label, help_string="XML label of the potential") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LinearSOAP_Initialise_str args_str')) then - call system_abort("IPModel_LinearSOAP_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_LinearSOAP_read_params_xml(this, param_str) -#endif -end subroutine IPModel_LinearSOAP_Initialise_str - -subroutine IPModel_LinearSOAP_Finalise(this) - type(IPModel_LinearSOAP), intent(inout) :: this - -#ifdef HAVE_GAP - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%beta)) deallocate(this%beta) - if (allocated(this%e0)) deallocate(this%e0) - - this%n_types = 0 - this%label = '' - -#endif -end subroutine IPModel_LinearSOAP_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_LinearSOAP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_LinearSOAP), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - -#ifdef HAVE_GAP - - integer i, atomtype, d - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale, e_i - logical :: do_rescale_r, do_rescale_E - - logical, dimension(:), allocatable :: mpi_local_mask - real(dp), dimension(:), allocatable :: local_e_in - logical, dimension(:), pointer :: atom_mask_pointer - - type(descriptor), dimension(:), allocatable :: my_descriptor - type(descriptor_data) :: my_descriptor_data - type(extendable_str) :: Zstring - type(extendable_str) :: my_args_str - - - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_LinearSOAP_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_LinearSOAP_Calc', error) - f = 0.0_dp - RAISE_ERROR("IPModel_LinearSOAP_Calc: force calculation requested but not supported yet.", error) - end if - if (present(virial)) then - virial = 0.0_dp - RAISE_ERROR("IPModel_LinearSOAP_Calc: virial calculation requested but not supported yet.", error) - end if - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_LinearSOAP_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_LinearSOAP_Calc: local_virial calculation requested but not supported yet.", error) - endif - - - allocate(local_e_in(at%N)) - local_e_in = 0.0_dp - - atom_mask_pointer => null() - has_atom_mask_name = .false. - atom_mask_name = "" - - - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LinearSOAP_Calc args_str')) then - RAISE_ERROR("IPModel_LinearSOAP_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - - if(has_atom_mask_name) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_GAP_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - else - atom_mask_pointer => null() - endif - - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_LinearSOAP_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - my_args_str = trim(args_str) - else - call initialise(my_args_str) - endif ! present(args_str) - - - - allocate(my_descriptor(this%n_types)) - - - ! compute descriptors for all atoms in the cell - - call initialise(Zstring) - call concat(Zstring," species_Z={") - do atomtype=1,this%n_types - call concat(Zstring, " "//this%atomic_num(atomtype)) - end do - call concat(Zstring, "} ") - - if( present(mpi) ) then - if(mpi%active) then - if(has_atom_mask_name) then - RAISE_ERROR("IPModel_GAP: atom_mask_name "//trim(atom_mask_name)//" present while running MPI version."// \ - "The use of atom_mask_name is intended for serial-compiled code called from an external parallel code, such as LAMMPS",error) - endif - - if( has_property(at,"mpi_local_mask") ) then - RAISE_ERROR("IPModel_GAP: mpi_local_mask property already present", error) - endif - - allocate(mpi_local_mask(at%N)) - call add_property_from_pointer(at,'mpi_local_mask',mpi_local_mask,error=error) - - call concat(my_args_str," atom_mask_name=mpi_local_mask") - endif - endif - - - do atomtype=1,this%n_types - call initialise(my_descriptor(atomtype),"soap cutoff="//this%cutoff//" n_max="//this%n_max//" l_max="//this%l_max//" atom_sigma="//this%atom_sigma//" n_species="//this%n_types//" Z="//this%atomic_num(atomtype)//Zstring//" "//string(my_args_str)) - - if(mpi%active) call descriptor_MPI_setup(my_descriptor(atomtype),at,mpi,mpi_local_mask,error) - - d = descriptor_dimensions(my_descriptor(atomtype)) - - ! compute descriptors for this atom type center - call calc(my_descriptor(atomtype),at,my_descriptor_data, & - do_descriptor=.true.,do_grad_descriptor=.false., & - args_str=trim(string(my_args_str)), error=error) - PASS_ERROR(error) - - ! this loop is over the found descriptors, i.e. all atoms of the current type - do i=1,size(my_descriptor_data%x) - - !beta . pissnl - e_i = sum(this%beta(:,atomtype) * my_descriptor_data%x(i)%data(:)) - - local_e_in(my_descriptor_data%x(i)%ci(1)) = e_i - end do - - call finalise(my_descriptor_data) - end do - - ! - ! collect data and cleanup - - if(present(e)) e = sum(local_e_in) - if(present(local_e)) local_e = local_e_in - - if (present(mpi)) then - if( mpi%active ) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(f)) call sum_in_place(mpi, f) - - call remove_property(at,'mpi_local_mask', error=error) - deallocate(mpi_local_mask) - end if - endif - - ! cleanup - if(allocated(local_e_in)) deallocate(local_e_in) - -#endif - -end subroutine IPModel_LinearSOAP_Calc - - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for XML stanza is given below, please notice that -!% they are simply dummy parameters for testing purposes, with no physical meaning. -!% -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - -#ifdef HAVE_GAP - integer :: status - character(len=1024) :: value - - integer :: ti, atomtype, i - real(dp) :: v - - if (name == 'LinearSOAP_params') then ! new LinearSOAP stanza - - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered LinearSOAP_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in LinearSOAP_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%e0(parse_ip%n_types)) - parse_ip%e0 = 0.0_dp - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(108)) - parse_ip%type_of_atomic_num = 0 - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "atomtype", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find atomtype") - read (value, *) ti - - if (ti < 1) call system_abort("IPModel_LinearSOAP_read_params_xml got per_type_data type="//ti//" < 1") - if (ti > parse_ip%n_types) call system_abort("IPModel_LinearSOAP_read_params_xml got per_type_data type="//ti//" > n_types="//parse_ip%n_types) - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - - call QUIP_FoX_get_value(attributes, "e0", value, status) - if(status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find e0") - read (value, *) parse_ip%e0(ti) - - - elseif (parse_in_ip .and. name == 'params') then - - call QUIP_FoX_get_value(attributes, "l_max", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find l_max") - read (value, *) parse_ip%l_max - - call QUIP_FoX_get_value(attributes, "n_max", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find n_max") - read (value, *) parse_ip%n_max - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - - call QUIP_FoX_get_value(attributes, "atom_sigma", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find atom_sigma") - read (value, *) parse_ip%atom_sigma - - call QUIP_FoX_get_value(attributes, "pissnl_dimension", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find pissnl_dimension") - read (value, *) parse_ip%pissnl_dimension - - if(allocated(parse_ip%beta)) deallocate(parse_ip%beta) - allocate(parse_ip%beta(parse_ip%pissnl_dimension, parse_ip%n_types)) - - elseif (parse_in_ip .and. name == 'beta') then - - if(.not. allocated(parse_ip%beta)) call system_abort ("IPModel_LinearSOAP_read_params_xml encountered stanza but beta array is not yet allcoated") - - call QUIP_FoX_get_value(attributes, "atomtype", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find atomtype in stanza") - read (value, *) atomtype - - call QUIP_FoX_get_value(attributes, "i", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find i in stanza") - read (value, *) i - - call QUIP_FoX_get_value(attributes, "value", value, status) - if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find value in stanza") - read (value, *) v - - if (i > parse_ip%pissnl_dimension) call system_abort("IPModel_LinearSOAP_read_params_xml: i > pissnl_dimension in stanza") - if (atomtype > parse_ip%n_types) call system_abort("IPModel_LinearSOAP_read_params_xml: atomtype > n_types in stanza") - - parse_ip%beta(i,atomtype) = v - - - endif -#endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'LinearSOAP_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_LinearSOAP_read_params_xml(this, param_str) - type(IPModel_LinearSOAP), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_LinearSOAP_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_LinearSOAP_read_params_xml - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of LinearSOAP parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_LinearSOAP_Print (this, file) - type(IPModel_LinearSOAP), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_LinearSOAP ", file=file) - call Print("IPModel_LinearSOAP : n_types = " // this%n_types // " cutoff = " // this%cutoff // " l_max = " // this%l_max // " n_max = " // this%n_max // " atom_sigma = " // this%atom_sigma // " pissnl_dimension = " // this%pissnl_dimension, file=file) - - do ti=1, this%n_types - call Print ("IPModel_LinearSOAP : type " // ti // " atomic_num " // this%atomic_num(ti) // " e0 = " // this%e0(ti), file=file) - end do - -end subroutine IPModel_LinearSOAP_Print - - -end module IPModel_LinearSOAP_module diff --git a/src/Potentials/IPModel_MBD.f95 b/src/Potentials/IPModel_MBD.f95 deleted file mode 100644 index 57c7dbca62..0000000000 --- a/src/Potentials/IPModel_MBD.f95 +++ /dev/null @@ -1,275 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_MBD -!X -!% Many-body van der Waals correction from -!% Tkatchenko, DiStasio, Car, & Scheffler -!% Phys. Rev. Lett. 108, 236402 (2012). -!% -!% Requires the MBD code from http://www.fhi-berlin.mpg.de/~tkatchen/MBD/MBD.tar -!% Download and extract into ThirdParty/MBD -!% TODO the Makefile should automatically patch their UTILS.F90 and compile it -!% in -!% -!% For more information on the method and parameters see ThirdParty/MBD/README -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_MBD_module - -use error_module -use system_module, only : dp, inoutput, print, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use units_module, only : QPI => PI, QBOHR => BOHR, HARTREE -#ifdef HAVE_MBD -use MBD_UTILS -#endif - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_MBD -type IPModel_MBD - real(dp) :: cutoff = 0.0_dp ! Cutoff in the quip sense doesn't really apply here - integer :: xc = 1 ! PBE - real(dp) :: mbd_cfdm_dip_cutoff = 100.d0 ! Angstrom - real(dp) :: mbd_supercell_cutoff= 25.d0 ! Angstrom - real(dp) :: mbd_scs_dip_cutoff = 120.0 ! Angstrom - logical :: mbd_scs_vacuum_axis(3) -end type IPModel_MBD - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_MBD), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_MBD_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_MBD_Finalise -end interface Finalise - -interface Print - module procedure IPModel_MBD_Print -end interface Print - -interface Calc - module procedure IPModel_MBD_Calc -end interface Calc - -contains - -subroutine IPModel_MBD_Initialise_str(this, args_str, param_str, error) - type(IPModel_MBD), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out):: error - - - INIT_ERROR(error) - call Finalise(this) - - call initialise(params) - ! Some of these should definitely be in the xml file, but use command line for now - call param_register(params, 'xc_type', '1', this%xc, help_string='Type of X-C functional that was used: dial 1 for PBE, 2 for PBE0, or 3 for HSE') - call param_register(params, 'cfdm_dip_cutoff', '100.0', this%mbd_cfdm_dip_cutoff, help_string='MBD dipole field integration cutoff') - call param_register(params, 'scs_dip_cutoff', '120.0', this%mbd_scs_dip_cutoff, help_string='Periodic SCS integration cutoff - important for low-dim systems') - call param_register(params, 'supercell_cutoff', '25.0', this%mbd_supercell_cutoff, help_string='Radius used to make periodic supercell - important convergence parameter') - call param_register(params, 'vacuum_x', 'false', this%mbd_scs_vacuum_axis(1), help_string='Which directions should be treated as vacuum instead of periodic: X') - call param_register(params, 'vacuum_y', 'false', this%mbd_scs_vacuum_axis(2), help_string='Which directions should be treated as vacuum instead of periodic: Y') - call param_register(params, 'vacuum_z', 'false', this%mbd_scs_vacuum_axis(3), help_string='Which directions should be treated as vacuum instead of periodic: Z') - if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_MBD_Initialise args_str')) then - RAISE_ERROR("IPModel_MBD_Init failed to parse args_str='"//trim(args_str)//"'", error) - end if - call finalise(params) - -#ifdef HAVE_MBD - ! MBD pi = QUIP Units pi - pi = QPI - bohr = QBOHR ! Used in the code - nasty arithmetic errors if uninitialized - three_by_pi = 3.0 / pi - flag_xc = this%xc - mbd_cfdm_dip_cutoff = this%mbd_cfdm_dip_cutoff - mbd_supercell_cutoff= this%mbd_supercell_cutoff - mbd_scs_dip_cutoff = this%mbd_scs_dip_cutoff - n_periodic = 0 - mbd_scs_vacuum_axis = this%mbd_scs_vacuum_axis - ! And that replaces MBD_UTILS::init_constants() - ! MPI stuff: - ! Um, this was supposed to be set in MPI_INIT but I can't find a way to access it - mpiierror = 0 -#endif - -end subroutine IPModel_MBD_Initialise_str - -subroutine IPModel_MBD_Finalise(this) - type(IPModel_MBD), intent(inout) :: this - - ! Add finalisation code here - -end subroutine IPModel_MBD_Finalise - - -subroutine IPModel_MBD_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_MBD), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - logical :: mpi_active - integer, intent(out), optional :: error - - type(Dictionary) :: params - real(dp), pointer, dimension(:) :: my_hirshfeld_volume - character(STRING_LENGTH) :: hirshfeld_vol_name - real(dp) :: energy = 0.0_dp - integer :: at_idx - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - !TODO lammps usually asks for this though - is there another way? - RAISE_ERROR("IPModel_MBD does not have local energies", error) - endif - ! Need finite differences for forces and virials - if (present(f) .or. present(virial) .or. present(local_virial)) then - RAISE_ERROR("IPModel_MBD does not yet provide analytical gradients", error) - endif - - if (present(args_str)) then - if (len_trim(args_str) > 0) then - call initialise(params) - call param_register(params, 'hirshfeld_vol_name', 'hirshfeld_rel_volume', hirshfeld_vol_name, & - help_string='Name of the Atoms property containing relative Hirshfeld volumes $v/v_{free}$') - - if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_MBD_Calc args_str')) then - RAISE_ERROR("IPModel_MBD_Calc failed to parse args_str '"//trim(args_str)//"'", error) - endif - call finalise(params) - call assign_property_pointer(at, trim(hirshfeld_vol_name), my_hirshfeld_volume, error) - PASS_ERROR_WITH_INFO("IPModel_MBD_Calc could not find '"//trim(hirshfeld_vol_name)//"' property in the Atoms object", error) - endif - else - call assign_property_pointer(at, 'hirshfeld_rel_volume', my_hirshfeld_volume, error) - endif - -#ifdef HAVE_MBD - mpi_active = .false. - if (present(mpi)) then - if (mpi%active) then - mpi_active = .true. - endif - endif - - n_atoms = at%N - if (mpi_active) then - mpicomm = mpi%communicator - myid = mpi%my_proc - n_tasks = mpi%n_procs - call allocate_task() - else ! assume serial - myid = 0 - n_tasks = 1 - call allocate_task() - endif - - ! Note: many of these variables come from the MBD_UTILS module - if(.not.allocated(coords)) allocate(coords(3,n_atoms)) - if(.not.allocated(atom_name)) allocate(atom_name(n_atoms)) - if(.not.allocated(hirshfeld_volume)) allocate(hirshfeld_volume(n_atoms)) - lattice_vector = at%lattice / QBOHR - ! TODO maybe this should count the number of periodic dimensions - even - ! though MBD_UTILS only distinguishes 0 and >0 - ! Related: Maybe want to support non-periodic calculations if all the lattice - ! directions are specified as vacuum - n_periodic = 3 ! I think this means use PBC - coords = at%pos / QBOHR - do at_idx = 1, at%N - atom_name(at_idx) = at%species(1, at_idx) // at%species(2, at_idx) - enddo - hirshfeld_volume = my_hirshfeld_volume - - call MBD_at_rsSCS(energy) -#ifdef _MPI - PASS_MPI_ERROR(mpiierror, error) -#endif /*MPI*/ -#endif /*MBD*/ - -#ifdef HAVE_MBD - if (present(e)) e = energy * HARTREE - - if (allocated(coords)) deallocate(coords) - if (allocated(atom_name)) deallocate(atom_name) - if (allocated(hirshfeld_volume)) deallocate(hirshfeld_volume) -#endif - -end subroutine IPModel_MBD_Calc - - -subroutine IPModel_MBD_Print(this, file) - type(IPModel_MBD), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_MBD : Many-body dispersion", file=file) - select case(this%xc) - case(1) - call Print("IPModel_MBD : xc type PBE", file=file) - case(2) - call Print("IPModel_MBD : xc type PBE0", file=file) - case(3) - call Print("IPModel_MBD : xc type HSE", file=file) - case default - call Print("IPModel_MBD : xc type unknown", file=file) - end select - call Print("IPModel_MBD : mbd_supercell_cutoff = " // this%mbd_supercell_cutoff, file=file) - call Print("IPModel_MBD : mbd_scs_dip_cutoff = " // this%mbd_scs_dip_cutoff, file=file) - call Print("IPModel_MBD : mbd_cfdm_dip_cutoff = " // this%mbd_cfdm_dip_cutoff, file=file) - call Print("IPModel_MBD : mbd_scs_vacuum_axis = " // this%mbd_scs_vacuum_axis, file=file) - -end subroutine IPModel_MBD_Print - - -end module IPModel_MBD_module diff --git a/src/Potentials/IPModel_MTP.f95 b/src/Potentials/IPModel_MTP.f95 deleted file mode 100644 index a0897d97da..0000000000 --- a/src/Potentials/IPModel_MTP.f95 +++ /dev/null @@ -1,255 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_MTP -!X -!% MTP interatomic potential: interface to Alex Shapeev's C++ code. -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_MTP_module - -use iso_c_binding, only : C_NULL_CHAR -use error_module -use system_module, only : dp, inoutput, print, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use CInOutput_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_MTP -type IPModel_MTP - real(dp) :: cutoff = 0.0_dp -end type IPModel_MTP - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_MTP), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_MTP_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_MTP_Finalise -end interface Finalise - -interface Print - module procedure IPModel_MTP_Print -end interface Print - -interface Calc - module procedure IPModel_MTP_Calc -end interface Calc - -#ifdef HAVE_MTP -interface - subroutine alex_initialise(filename, cutoff, error) bind(C) - use iso_c_binding, only: c_double, c_char, c_int - character(kind=c_char) :: filename(*) - real(kind=c_double) :: cutoff - integer(kind=c_int) :: error - endsubroutine alex_initialise -endinterface - -interface - subroutine alex_compute(neigh_count,neigh_len,input_pos,out_force,out_site_en, error) bind(C) - use iso_c_binding, only: c_ptr, c_int - integer(kind=c_int) :: neigh_count - type(c_ptr), value :: neigh_len - type(c_ptr), value :: input_pos - type(c_ptr), value :: out_force - type(c_ptr), value :: out_site_en - integer(kind=c_int) :: error - endsubroutine alex_compute -endinterface -#endif - -contains - -subroutine IPModel_MTP_Initialise_str(this, args_str, param_str, error) - type(IPModel_MTP), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out):: error - - character(len=STRING_LENGTH) :: alex_filename - integer :: mtp_error - - INIT_ERROR(error) - call Finalise(this) - - call initialise(params) - call param_register(params, 'alex_filename', '', alex_filename, help_string='filename for coefficiets') - if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_MTP_Initialise args_str')) then - RAISE_ERROR("IPModel_MTP_Init failed to parse args_str='"//trim(args_str)//"'", error) - end if - call finalise(params) - -#ifdef HAVE_MTP - call alex_initialise(trim(alex_filename)//C_NULL_CHAR, this%cutoff,mtp_error) - if( mtp_error /= 0 ) then - RAISE_ERROR("IPModel_MTP_Init received error "//mtp_error//" from alex_initialise()",error) - endif -#else - RAISE_ERROR("support for MTP not compiled in. Obtain MTP code first, and HAVE_MTP = 1 in your Makefile.inc, and recompile QUIP",error) -#endif - -end subroutine IPModel_MTP_Initialise_str - -subroutine IPModel_MTP_Finalise(this) - type(IPModel_MTP), intent(inout) :: this - - ! Add finalisation code here - -end subroutine IPModel_MTP_Finalise - - -subroutine IPModel_MTP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - use iso_c_binding, only : c_int, c_double, c_loc - type(IPModel_MTP), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - ! Add calc() code here - - - integer :: i, j, n, neighbour_index - real(dp) :: r_ij - real(dp), dimension(3) :: diff_ij, f_ij - integer(kind=c_int), dimension(:), allocatable, target :: alex_n_neighbours - real(kind=c_double), dimension(:), allocatable, target :: alex_energy, alex_r_neighbours, alex_f_neighbours - integer :: mtp_error - - INIT_ERROR(error) - - allocate(alex_n_neighbours(at%N), alex_energy(at%N)) - - do i = 1, at%N - alex_n_neighbours(i) = n_neighbours(at,i,max_dist=this%cutoff) - enddo - - allocate(alex_r_neighbours(3*sum(alex_n_neighbours)), alex_f_neighbours(3*sum(alex_n_neighbours))) - - neighbour_index = 0 - - do i = 1, at%N - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance=r_ij, diff=diff_ij) - if( r_ij > this%cutoff ) cycle - - neighbour_index = neighbour_index + 1 - alex_r_neighbours(3*(neighbour_index-1)+1:3*neighbour_index) = diff_ij - enddo - enddo - -#ifdef HAVE_MTP - call alex_compute(at%N,c_loc(alex_n_neighbours), c_loc(alex_r_neighbours), c_loc(alex_f_neighbours), c_loc(alex_energy), mtp_error) - if( mtp_error /= 0 ) then - call write(at, 'stdout', prefix='MTP_ERROR') - RAISE_ERROR("IPModel_MTP_Calc received error "//mtp_error//" from alex_compute()",error) - endif -#endif - - if (present(e)) e = sum(alex_energy) - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_MTP_Calc', error) - local_e = alex_energy - endif - - if (present(f).or.present(virial)) then - if(present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_MTP_Calc', error) - f = 0.0_dp - endif - if(present(virial)) virial = 0.0_dp - - neighbour_index = 0 - do i = 1, at%N - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance=r_ij, diff=diff_ij) - if( r_ij > this%cutoff ) cycle - - neighbour_index = neighbour_index + 1 - f_ij = alex_f_neighbours(3*(neighbour_index-1)+1:3*neighbour_index) - if(present(f)) then - f(:,j) = f(:,j) - f_ij - f(:,i) = f(:,i) + f_ij - endif - if(present(virial)) then - virial = virial - ( diff_ij .outer. f_ij ) - endif - enddo - enddo - - end if - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_MTP_Calc', error) - local_virial = 0.0_dp - endif - - if(allocated(alex_n_neighbours)) deallocate(alex_n_neighbours) - if(allocated(alex_energy)) deallocate(alex_energy) - if(allocated(alex_r_neighbours)) deallocate(alex_r_neighbours) - if(allocated(alex_f_neighbours)) deallocate(alex_f_neighbours) - -end subroutine IPModel_MTP_Calc - - -subroutine IPModel_MTP_Print(this, file) - type(IPModel_MTP), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_MTP : MTP Potential", file=file) - call Print("IPModel_MTP : cutoff = " // this%cutoff, file=file) - -end subroutine IPModel_MTP_Print - - -end module IPModel_MTP_module diff --git a/src/Potentials/IPModel_Morse.f95 b/src/Potentials/IPModel_Morse.f95 deleted file mode 100644 index 771283137a..0000000000 --- a/src/Potentials/IPModel_Morse.f95 +++ /dev/null @@ -1,569 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Morse module -!X -!% Module for Morse pair potential. -!% \begin{equation} -!% \nonumber -!% V(r) = D \left( \exp(-2 \alpha (r-r_0)) - 2 \exp( -\alpha (r-r_0)) \right) -!% \end{equation} -!% -!% The IPModel_Morse object contains all the parameters read from a -!% 'Morse_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Morse_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - - -use mpi_context_module -use QUIP_Common_module - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_Morse -type IPModel_Morse - integer :: n_types = 0 !% Number of atomic types. - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - real(dp), allocatable :: D(:,:), alpha(:,:), r0(:,:), cutoff_a(:,:) !% IP parameters. - - character(len=STRING_LENGTH) label - -end type IPModel_Morse - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Morse), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Morse_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Morse_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Morse_Print -end interface Print - -interface Calc - module procedure IPModel_Morse_Calc -end interface Calc - -contains - -subroutine IPModel_Morse_Initialise_str(this, args_str, param_str) - type(IPModel_Morse), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label = '' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Morse_Initialise_str args_str')) then - call system_abort("IPModel_Morse_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Morse_read_params_xml(this, param_str) - - this%cutoff = maxval(this%cutoff_a) - -end subroutine IPModel_Morse_Initialise_str - -subroutine IPModel_Morse_Finalise(this) - type(IPModel_Morse), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%r0)) deallocate(this%r0) - if (allocated(this%D)) deallocate(this%D) - if (allocated(this%alpha)) deallocate(this%alpha) - if (allocated(this%cutoff_a)) deallocate(this%cutoff_a) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Morse_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_Morse_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Morse), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), pointer :: w_e(:) - integer i, ji, j, ti, tj - real(dp) :: dr(3), dr_mag - real(dp) :: de, de_dr - logical :: i_is_min_image - - integer :: i_calc, n_extra_calcs - character(len=20) :: extra_calcs_list(10) - - logical :: do_flux = .false. - real(dp), pointer :: velo(:,:) - real(dp) :: flux(3) - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Morse_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_Morse_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) virial = 0.0_dp - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_Morse_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_Morse_Calc: local_virial calculation requested but not supported yet.", error) - endif - - if (present(args_str)) then - if (len_trim(args_str) > 0) then - n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) - if (n_extra_calcs > 0) then - do i_calc=1, n_extra_calcs - select case(trim(extra_calcs_list(i_calc))) - case("flux") - if (.not. assign_pointer(at, "velo", velo)) & - call system_abort("IPModel_Morse_Calc Flux calculation requires velo field") - do_flux = .true. - flux = 0.0_dp - case default - call system_abort("Unsupported extra_calc '"//trim(extra_calcs_list(i_calc))//"'") - end select - end do - endif ! n_extra_calcs - endif ! len_trim(args_str) - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Morse_Calc args_str')) then - RAISE_ERROR("IPModel_Morse_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_Morse_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_Morse_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - endif ! present(args_str) - - if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) - - do i = 1, at%N - i_is_min_image = at%connect%is_min_image(i) - - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - do ji = 1, n_neighbours(at, i) - j = neighbour(at, i, ji, dr_mag, cosines = dr) - - if (dr_mag .feq. 0.0_dp) cycle - if ((i < j) .and. i_is_min_image) cycle - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (present(e) .or. present(local_e)) then - de = IPModel_Morse_pairenergy(this, ti, tj, dr_mag) - if (present(local_e)) then - local_e(i) = local_e(i) + 0.5_dp*de - if(i_is_min_image) local_e(j) = local_e(j) + 0.5_dp*de - endif - if (present(e)) then - if (associated(w_e)) then - de = de*0.5_dp*(w_e(i)+w_e(j)) - endif - if(i_is_min_image) then - e = e + de - else - e = e + 0.5_dp*de - endif - endif - endif - if (present(f) .or. present(virial) .or. do_flux) then - de_dr = IPModel_Morse_pairenergy_deriv(this, ti, tj, dr_mag) - if (associated(w_e)) then - de_dr = de_dr*0.5_dp*(w_e(i)+w_e(j)) - endif - if (present(f)) then - f(:,i) = f(:,i) + de_dr*dr - if(i_is_min_image) f(:,j) = f(:,j) - de_dr*dr - endif - if (do_flux) then - ! -0.5 (v_i + v_j) . F_ij * dr_ij - flux = flux - 0.5_dp*sum((velo(:,i)+velo(:,j))*(de_dr*dr))*(dr*dr_mag) - endif - if (present(virial)) then - if(i_is_min_image) then - virial = virial - de_dr*(dr .outer. dr)*dr_mag - else - virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*dr_mag - endif - endif - endif - end do - end do - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(f)) call sum_in_place(mpi, f) - endif - if (do_flux) then - flux = flux / cell_volume(at) - if (present(mpi)) call sum_in_place(mpi, flux) - call set_value(at%params, "Flux", flux) - endif - -end subroutine IPModel_Morse_Calc - -!% This routine computes the two-body term for a pair of atoms separated by a distance r. -function IPModel_Morse_pairenergy(this, ti, tj, r) - type(IPModel_Morse), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_Morse_pairenergy - - real(dp) :: texp - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then - IPModel_Morse_pairenergy = 0.0 - return - endif - - texp = exp(-this%alpha(ti,tj)*(r-this%r0(ti,tj))) - - IPModel_Morse_pairenergy = this%D(ti,tj) * ( texp*texp - 2.0_dp*texp ) -end function IPModel_Morse_pairenergy - -!% Derivative of the two-body term. -function IPModel_Morse_pairenergy_deriv(this, ti, tj, r) - type(IPModel_Morse), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_Morse_pairenergy_deriv - - real(dp) :: texp, texp_d - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then - IPModel_Morse_pairenergy_deriv = 0.0 - return - endif - - texp = exp(-this%alpha(ti,tj)*(r-this%r0(ti,tj))) - texp_d = -this%alpha(ti,tj) * texp - - IPModel_Morse_pairenergy_deriv = this%D(ti,tj) * ( 2.0_dp*texp*texp_d - 2.0_dp * texp_d) -end function IPModel_Morse_pairenergy_deriv - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for XML stanza is given below. Please notice that -!% these are simply dummy parameters for testing purposes, with no physical meaning. -!% -!%> -!%> -!%> -!%> -!%> -!% -!% cutoff defaults to r0 - log(1e-8) / alpha -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - integer atnum_i, atnum_j, ti, tj, ti_a(1) - - if (name == 'Morse_params') then ! new Morse stanza - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered Morse_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in Morse_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%r0(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%D(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%alpha(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%cutoff_a(parse_ip%n_types,parse_ip%n_types)) - - parse_ip%r0 = 0.0_dp - parse_ip%D = 0.0_dp - parse_ip%alpha = 0.0_dp - - endif ! parse_in_ip - elseif (parse_in_ip .and. name == 'pair') then - - call QUIP_FoX_get_value(attributes, "atnum_i", value, status) - if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find atnum_i") - read (value, *) atnum_i - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find atnum_j") - read (value, *) atnum_j - - if (all(parse_ip%atomic_num /= atnum_i)) then - ti_a = minloc(parse_ip%atomic_num) - parse_ip%atomic_num(ti_a(1)) = atnum_i - endif - if (all(parse_ip%atomic_num /= atnum_j)) then - ti_a = minloc(parse_ip%atomic_num) - parse_ip%atomic_num(ti_a(1)) = atnum_j - endif - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - ti = parse_ip%type_of_atomic_num(atnum_i) - tj = parse_ip%type_of_atomic_num(atnum_j) - - call QUIP_FoX_get_value(attributes, "r0", value, status) - if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find r0") - read (value, *) parse_ip%r0(ti,tj) - call QUIP_FoX_get_value(attributes, "D", value, status) - if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find D") - read (value, *) parse_ip%D(ti,tj) - call QUIP_FoX_get_value(attributes, "alpha", value, status) - if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find alpha") - read (value, *) parse_ip%alpha(ti,tj) - - parse_ip%cutoff_a(ti,tj) = -1.0_dp - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status == 0) read (value, *) parse_ip%cutoff_a(ti,tj) - - if (ti /= tj) then - parse_ip%r0(tj,ti) = parse_ip%r0(ti,tj) - parse_ip%D(tj,ti) = parse_ip%D(ti,tj) - parse_ip%alpha(tj,ti) = parse_ip%alpha(ti,tj) - parse_ip%cutoff_a(tj,ti) = parse_ip%cutoff_a(ti,tj) - endif - - endif ! parse_in_ip .and. name = 'Morse' - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Morse_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_Morse_read_params_xml(this, param_str) - type(IPModel_Morse), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - integer :: ti, tj - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Morse_read_params_xml parsed file, but n_types = 0") - endif - - ! default cutoff: - ! exp(-alpha (r-r0)) < 1e-8 - ! -alpha (r-r0) < log(1e-8) - ! r - r0 < log(1e-8) / -alpha - ! r < r0 + log(1e-8) / -alpha - ! r < r0 + 13.8 / alpha - - do ti=1, this%n_types - do tj=1, this%n_types - if (this%cutoff_a(ti,tj) < 0.0_dp) this%cutoff_a(ti,tj) = this%r0(ti,tj) - log(1.0e-8_dp) / this%alpha(ti,tj) - end do - end do - this%cutoff = maxval(this%cutoff_a) - -end subroutine IPModel_Morse_read_params_xml - - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of Morse parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_Morse_Print (this, file) - type(IPModel_Morse), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_Morse : Morse", file=file) - call Print("IPModel_Morse : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_Morse : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - do tj=1, this%n_types - call Print ("IPModel_Morse : interaction " // ti // " " // tj // " r0 " // this%r0(ti,tj) // " D " // & - this%D(ti,tj) // " alpha " // this%alpha(ti,tj) // " cutoff_a " // this%cutoff_a(ti,tj), file=file) - end do - call verbosity_pop() - end do - -end subroutine IPModel_Morse_Print - -function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) - character(len=*), intent(in) :: args_str - character(len=*), intent(out) :: extra_calcs_list(:) - integer :: n_extra_calcs - - character(len=STRING_LENGTH) :: extra_calcs_str - type(Dictionary) :: params - - n_extra_calcs = 0 - call initialise(params) - call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") - if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then - if (len_trim(extra_calcs_str) > 0) then - call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") - end if - end if - call finalise(params) - -end function parse_extra_calcs - -end module IPModel_Morse_module diff --git a/src/Potentials/IPModel_Multipoles.f95 b/src/Potentials/IPModel_Multipoles.f95 deleted file mode 100644 index a950e4c783..0000000000 --- a/src/Potentials/IPModel_Multipoles.f95 +++ /dev/null @@ -1,700 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Multipoles -!X -!% Multipoles interatomic potential: -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Multipoles_module - -use error_module -!use system_module, only : dp, inoutput, print, lower_case, verbosity_push_decrement, verbosity_pop, operator(//), split_string, string_to_int,PRINT_ANALYSIS,reallocate -use system_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use Multipoles_module -use units_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -integer, parameter :: IPMultipoles_Method_Direct = 1 -integer, parameter :: IPMultipoles_Method_Yukawa = 2 -integer, parameter :: IPMultipoles_Method_Ewald = 3 - -integer, parameter :: Multipole_Position_Atomic = 1 -integer, parameter :: Multipole_Position_Centre_of_Mass = 2 -integer, parameter :: Multipole_Position_M_Site = 3 - -integer, parameter :: Charge_Method_None = 0 -integer, parameter :: Charge_Method_Fixed = 1 -integer, parameter :: Charge_Method_GAP = 2 -integer, parameter :: Charge_Method_Partridge_Schwenke = 3 - -integer, parameter :: Dipole_Method_None = 0 -integer, parameter :: Dipole_Method_Partridge_Schwenke = 1 -integer, parameter :: Dipole_Method_GAP = 2 - -integer, parameter :: Polarisation_Method_None = 0 -integer, parameter :: Polarisation_Method_FPI = 1 -integer, parameter :: Polarisation_Method_GMRES = 2 -integer, parameter :: Polarisation_Method_QR = 3 - -integer, parameter :: Damping_None = 0 -integer, parameter :: Damping_Exp = 1 -integer, parameter :: Damping_Erf = 2 -integer, parameter :: Damping_Erf_Uniform = 3 - -integer, parameter :: Screening_None = 0 -integer, parameter :: Screening_Yukawa = 1 -integer, parameter :: Screening_Erfc_Uniform = 2 - -public :: IPModel_Multipoles -type IPModel_Multipoles - - type(Multipole_Moments) :: multipoles - - integer :: n_monomer_types = 0 - - integer :: method = 0 - integer :: damping = 0 - integer :: screening = 0 - integer :: polarisation = 0 - - real(dp) :: cutoff = 0.0_dp - - real(dp) :: ewald_error - real(dp) :: smooth_coulomb_cutoff - - character(len=STRING_LENGTH) :: label - -end type IPModel_Multipoles - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Multipoles), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Multipoles_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Multipoles_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Multipoles_Print -end interface Print - -interface Calc - module procedure IPModel_Multipoles_Calc -end interface Calc - -contains - -subroutine IPModel_Multipoles_Initialise_str(this, args_str, param_str, error) - type(IPModel_Multipoles), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out):: error - - - INIT_ERROR(error) - call Finalise(this) - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_Multipoles_Initialise args_str')) then - RAISE_ERROR("IPModel_Multipoles_Init failed to parse args_str='"//trim(args_str)//"'", error) - end if - - call finalise(params) - - call IPModel_Multipoles_read_params_xml(this, param_str) - -end subroutine IPModel_Multipoles_Initialise_str - -subroutine IPModel_Multipoles_Finalise(this) - type(IPModel_Multipoles), intent(inout) :: this - - ! Add finalisation code here - call finalise(this%multipoles) - -end subroutine IPModel_Multipoles_Finalise - - -subroutine IPModel_Multipoles_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Multipoles), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Atoms) :: dummy_atoms - real(dp),dimension(:,:), allocatable :: pol_matrix - type(Ewald_arrays) :: ewald - type(Dictionary) :: params - real(dp) :: r_scale, E_scale, pol_energy - logical :: do_rescale_r, do_rescale_E,do_e, do_f, strict - - logical :: my_use_ewald_cutoff - - INIT_ERROR(error) - do_f=present(f) - do_e=present(e) - if(do_e)e=0.0_dp - if (do_f) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Coulomb_Calc', error) - f = 0.0_dp - end if - if (present(args_str)) then - call initialise(params) - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Not supported in multipole calcs.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.") - call param_register(params, 'strict', 'T',strict, help_string="If true, make sure every atom in system belongs to one of the monomers in this potential, default T") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Multipoles_Calc args_str')) then - RAISE_ERROR("IPModel_Multipoles_Calc failed to parse args_str="//trim(args_str), error) - endif - call finalise(params) - if (do_rescale_r ) then - RAISE_ERROR("IPModel_Multipoles_Calc: rescaling of potential with r_scale not yet implemented!", error) - end if - endif - - call multipole_sites_setup(at,this%multipoles,dummy_atoms,do_f,strict) ! multipoles includes exclude_list - - if (this%method == IPMultipoles_Method_Ewald) then - call ewald_setup(dummy_atoms,this%multipoles,ewald,this%ewald_error) ! changes this%multipoles%cutoff - end if - - if (this%polarisation /= Polarisation_Method_None) then - call electrostatics_calc(dummy_atoms,this%multipoles,ewald,do_field=.true.) - call build_polarisation_matrix(dummy_atoms,this%multipoles,pol_matrix,ewald) ! A^-1-T - call calc_induced_dipoles(pol_matrix,this%multipoles,this%polarisation,pol_energy) ! this updates the dipoles on any polarisable sites - if(do_e) e = pol_energy - end if - - call electrostatics_calc(dummy_atoms,this%multipoles,ewald,e=e,do_force=.true.) - if (present(f)) then - call atomic_forces_from_sites(this%multipoles%sites,f=f) ! no support for virial or local stuff yet - end if - - if (do_rescale_E) then - if (present(e)) e = e*E_scale - if (present(local_e)) local_e = local_e*E_scale - if (present(f)) f = f*E_scale - if (present(virial)) virial=virial*E_scale - if (present(local_virial)) local_virial=local_virial*E_scale - end if - - ! clean up - if(allocated(pol_matrix)) deallocate(pol_matrix) - call finalise(dummy_atoms) - -end subroutine IPModel_Multipoles_Calc - - -subroutine IPModel_Multipoles_Print(this, file) - type(IPModel_Multipoles), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti , tj - - call Print("IPModel_Multipoles : Multipoles Potential", file=file) - select case(this%method) - case(IPMultipoles_Method_Direct) - call Print("IPModel_Multipoles method: Direct") - case(IPMultipoles_Method_Yukawa) - call Print("IPModel_Multipoles method: Yukawa") - case(IPMultipoles_Method_Ewald) - call Print("IPModel_Multipoles method: Ewald") - case default - call system_abort ("IPModel_Multipoles: method identifier "//this%method//" unknown") - endselect - - call Print("IPModel_Multipoles : n_monomer_types = " // this%n_monomer_types // " cutoff = " // this%cutoff, file=file) - - call print("Electrostatics Options for multipole interactions",file=file) - select case(this%multipoles%calc_opts%damping) - case(Damping_None) - call Print("IPModel_Multipoles damping : No damping, bare electrostatic interactions at short range",file=file) - case(Damping_Erf) - call Print("IPModel_Multipoles damping : Gaussian damping of electrostatic interactions at short range",file=file) - case(Damping_Exp) - call Print("IPModel_Multipoles damping : Exponential damping of electrostatic interactions at short range",file=file) - call Print("IPModel_Multipoles damping : Exponential damping rank : "//this%multipoles%calc_opts%damp_exp_order,file=file) - call Print("IPModel_Multipoles damping : Exponential damping scale : "//this%multipoles%calc_opts%damp_exp_scale,file=file) - case default - call Print("IPModel_Multipoles damping : Unknown damping scheme",file=file) - endselect - - select case(this%multipoles%calc_opts%screening) - case(Screening_None) - call Print("IPModel_Multipoles screening : No screening, including all long range electrostatic interactions",file=file) - case(Screening_Yukawa) - call Print("IPModel_Multipoles screening : Yukawa screening of long range electrostatic interactions",file=file) - call Print("IPModel_Multipoles screening : yukawa alpha : "//this%multipoles%calc_opts%yukawa_alpha,file=file) - call Print("IPModel_Multipoles screening : yukawa smooth_length : "//this%multipoles%calc_opts%yukawa_smooth_length,file=file) - case default - call Print("IPModel_Multipoles screening : Unknown screening scheme",file=file) - endselect - - do ti=1,this%n_monomer_types - call print("IPModel_Multipoles : monomer " // ti // " signature " // this%multipoles%monomer_types(ti)%signature, file=file) - do tj=1,size(this%multipoles%monomer_types(ti)%site_types) - call print("IPModel_Multipoles : site " // tj // " d " // this%multipoles%monomer_types(ti)%site_types(tj)%d, file=file) - call print("IPModel_Multipoles : site " // tj //" charge method : "//this%multipoles%monomer_types(ti)%site_types(tj)%charge_method, file=file) - call print("IPModel_Multipoles : site " // tj //" dipole method : "//this%multipoles%monomer_types(ti)%site_types(tj)%dipole_method, file=file) - call print("IPModel_Multipoles : site " // tj //" pos_type " // this%multipoles%monomer_types(ti)%site_types(tj)%pos_type, file=file) - call print("IPModel_Multipoles : site " // tj //" polarisable : "//this%multipoles%monomer_types(ti)%site_types(tj)%polarisable, file=file) - call print("IPModel_Multipoles : site " // tj //" polarisability : "//this%multipoles%monomer_types(ti)%site_types(tj)%alpha, file=file) - call print("IPModel_Multipoles : site " // tj //" damping radius : "//this%multipoles%monomer_types(ti)%site_types(tj)%damp_rad, file=file) - end do - end do - - -end subroutine IPModel_Multipoles_Print - -subroutine IPModel_Multipoles_read_params_xml(this, param_str) - type(IPModel_Multipoles), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_monomer_types == 0) then - call system_abort("IPModel_Multipoles_read_params_xml parsed file, but n_monomer_types = 0") - endif - -end subroutine IPModel_Multipoles_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - - character(len=STRING_LENGTH) :: value, signature_string, pos_type_str, moments_method_str - character(len=STRING_LENGTH), dimension(99) :: signature_fields - - logical :: energy_shift, linear_force_shift - integer :: ti, tj, i , j, n_atoms,n_sites, n_pairs,cursor - real(dp) :: alpha_au - - if (name == 'Multipoles_params') then ! new Multipoles stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - - if (parse_ip%n_monomer_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_monomer_types', value, status) - if (status /= 0) then - value='0' - endif - read (value, *) parse_ip%n_monomer_types - - allocate(parse_ip%multipoles%monomer_types(parse_ip%n_monomer_types)) - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - parse_ip%multipoles%cutoff = parse_ip%cutoff - - call QUIP_FoX_get_value(attributes, 'dipole_tolerance', value, status) - if (status /= 0) then - value='0.0D0' - endif - read (value, *) parse_ip%multipoles%dipole_tolerance - - call QUIP_FoX_get_value(attributes, 'intermolecular_only', value, status) - if (status == 0) then - read (value, *) parse_ip%multipoles%intermolecular_only - endif - - - call QUIP_FoX_get_value(attributes, "method", value, status) - if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find method") - select case(lower_case(trim(value))) - case("direct") - parse_ip%method = IPMultipoles_Method_Direct - case("yukawa") - parse_ip%method = IPMultipoles_Method_Yukawa - case("ewald") - parse_ip%method = IPMultipoles_Method_Ewald - case default - call system_abort ("IPModel_Multipoles_read_params_xml: method "//trim(value)//" unknown") - endselect - - call QUIP_FoX_get_value(attributes, "polarisation", value, status) - if (status /= 0) value = "none" - select case(lower_case(trim(value))) - case("fpi") - parse_ip%polarisation = Polarisation_Method_FPI - case("gmres") - parse_ip%polarisation = Polarisation_Method_GMRES - case("qr") - parse_ip%polarisation = Polarisation_Method_QR - case("none") - parse_ip%polarisation = Polarisation_Method_None - case default - parse_ip%polarisation = Polarisation_Method_None - endselect - - call QUIP_FoX_get_value(attributes, "damping", value, status) - if (status /= 0) value = "none" - select case(lower_case(trim(value))) - case("exp") - parse_ip%multipoles%calc_opts%damping = Damping_Exp - case("erf") - parse_ip%multipoles%calc_opts%damping = Damping_Erf - case("none") - parse_ip%multipoles%calc_opts%damping = Damping_None - case default - parse_ip%multipoles%calc_opts%damping = Damping_None - endselect - - - call QUIP_FoX_get_value(attributes, "damp_exp_scale", value, status) ! global param to adjust strength of damping, just a convenience param for damping_exp - if (status == 0) then - if (parse_ip%multipoles%calc_opts%damping == Damping_Exp) then - read (value, *) parse_ip%multipoles%calc_opts%damp_exp_scale - else - call system_abort("IPModel_Multipoles_read_params_xml: damp_exp_scale specified but exponential damping not selected") - end if - else - parse_ip%multipoles%calc_opts%damp_exp_scale = 1.0_dp - endif - - call QUIP_FoX_get_value(attributes, "damp_exp_order", value, status) ! order of exponential damping, typically 3 or 4, default 3 like in FX water model - if (status == 0) then - if (parse_ip%multipoles%calc_opts%damping == Damping_Exp) then - read (value, *) parse_ip%multipoles%calc_opts%damp_exp_order - else - call system_abort("IPModel_Multipoles_read_params_xml: damp_exp_order specified but exponential damping not selected") - end if - else - parse_ip%multipoles%calc_opts%damp_exp_order = 3 - endif - - call QUIP_FoX_get_value(attributes, "yukawa_alpha", value, status) - if (status /= 0) then - if( parse_ip%method == IPMultipoles_Method_Yukawa ) call system_abort("IPModel_Multipoles_read_params_xml: Yukawa method requested but no yukawa_alpha parameter found.") - else - read (value, *) parse_ip%multipoles%calc_opts%yukawa_alpha - parse_ip%screening = Screening_Yukawa - parse_ip%multipoles%calc_opts%screening = Screening_Yukawa - endif - - call QUIP_FoX_get_value(attributes, "yukawa_smooth_length", value, status) - if (status /= 0) then - if( parse_ip%screening == Screening_Yukawa ) call system_abort("IPModel_Multipoles_read_params_xml: Yukawa method requested but no yukawa_smooth_length parameter found.") - else - read (value, *) parse_ip%multipoles%calc_opts%yukawa_smooth_length - endif - - call QUIP_FoX_get_value(attributes, "ewald_error", value, status) - if (status == 0) then - read (value, *) parse_ip%ewald_error - else - parse_ip%ewald_error = 1.0e-6_dp - endif - - call QUIP_FoX_get_value(attributes, "smooth_coulomb_cutoff", value, status) - if (status == 0) then - read (value, *) parse_ip%smooth_coulomb_cutoff - else - parse_ip%smooth_coulomb_cutoff = 0.0_dp - endif - - endif - - elseif (parse_in_ip .and. name == 'monomer') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find type") - read (value, *) ti - if (ti < 1) call system_abort("IPModel_Multipoles_read_params_xml got monomer type="//ti//" < 1") - if (ti > parse_ip%n_monomer_types) call system_abort("IPModel_Multipoles_read_params_xml got monomer type="//ti//" > n_monomer_types="//parse_ip%n_monomer_types) - - call QUIP_FoX_get_value(attributes, "signature", value, status) - if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find signature") - - read (value, *) signature_string - call split_string(signature_string,'_','{}',signature_fields(:),n_atoms,matching=.true.) !read the signature - allocate(parse_ip%multipoles%monomer_types(ti)%signature(n_atoms)) - allocate(parse_ip%multipoles%monomer_types(ti)%masses(n_atoms)) - - do i=1,n_atoms - parse_ip%multipoles%monomer_types(ti)%signature(i) = string_to_int(signature_fields(i)) ! pass it to the monomer type - end do - - !call QUIP_FoX_get_value(attributes, "exclude_pairs", value, status) - - call QUIP_FoX_get_value(attributes, "monomer_cutoff", value, status) - if (size(parse_ip%multipoles%monomer_types(ti)%signature) > 1) then - if (status /= 0 ) then - call system_abort ("IPModel_Multipoles_read_params_xml cannot find monomer_cutoff") - else - read (value, *) parse_ip%multipoles%monomer_types(ti)%monomer_cutoff - end if - else - parse_ip%multipoles%monomer_types(ti)%monomer_cutoff = 0.01_dp - end if - - call QUIP_FoX_get_value(attributes, "n_sites", value, status) - if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find number of sites") - n_sites=string_to_int(value) - allocate(parse_ip%multipoles%monomer_types(ti)%site_types(n_sites)) - if(parse_ip%multipoles%intermolecular_only) then - n_pairs=(n_sites*(n_sites-1))/2 - call reallocate(parse_ip%multipoles%monomer_types(ti)%excluded_pairs,2,n_pairs,zero=.true.) - cursor=0 - do i=1,n_sites-1 - do j=i+1,n_sites - cursor=cursor+1 - parse_ip%multipoles%monomer_types(ti)%excluded_pairs(1,cursor)=i - parse_ip%multipoles%monomer_types(ti)%excluded_pairs(2,cursor)=j - end do - end do - end if - - call QUIP_FoX_get_value(attributes, "step", value, status) - if (status /= 0) value = '1D-08' - read (value, *) parse_ip%multipoles%monomer_types(ti)%step - - call QUIP_FoX_get_value(attributes, "gammaM", value, status) - if (status == 0) read (value, *) parse_ip%multipoles%monomer_types(ti)%gammaM - - - elseif (parse_in_ip .and. name == 'per_site_data') then - - call QUIP_FoX_get_value(attributes, "monomer", value, status) - if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find which monomer this site belongs to, specify with monomer='n' n=0,1,2...") - read (value, *) ti - if (ti < 1) call system_abort("IPModel_Multipoles_read_params_xml got monomer type="//ti//" < 1") - if (.not. allocated(parse_ip%multipoles%monomer_types(ti)%signature)) call system_abort("IPModel_Multipoles_read_params_xml, site specified but monomer not initialised") - - call QUIP_FoX_get_value(attributes, "site", value, status) - if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find site number (e.g. site='1') ") - - read (value, *) tj - - if (tj < 1) call system_abort("IPModel_Multipoles_read_params_xml got site type="//tj//" < 1") - if (tj > size(parse_ip%multipoles%monomer_types(ti)%site_types)) call system_abort("IPModel_Multipoles_read_params_xml got site type="//tj//" > n_sites="//size(parse_ip%multipoles%monomer_types(ti)%site_types)) - call QUIP_FoX_get_value(attributes, "charge", value, status) - if (status == 0) then - read (value, *) parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = 1 - else - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge = 0.0_dp - end if - - call QUIP_FoX_get_value(attributes, "pos_type", value, status) - if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find site pos_type ") - read (value, *) pos_type_str - - if (trim(pos_type_str) /= "") then - select case(lower_case(trim(pos_type_str))) - case("atom") - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%pos_type = Multipole_Position_Atomic - case("com") - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%pos_type = Multipole_Position_Centre_of_Mass - case("m-site") - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%pos_type = Multipole_Position_M_Site - case default - call system_abort ("IPModel_Multipoles_read_params_xml: pos_type "//trim(value)//" unknown") - end select - end if - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) value='0' - read (value, *) parse_ip%multipoles%monomer_types(ti)%site_types(tj)%atomic_number - - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = 0 - - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge_method = Charge_Method_None - call QUIP_FoX_get_value(attributes, "charge_method", value, status) - if (status == 0) then - read (value, *) moments_method_str - select case(lower_case(trim(moments_method_str))) - case("none") - continue - case("fixed") - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge_method = Charge_Method_Fixed - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 1 - case("gap") - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge_method = Charge_Method_GAP - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 1 - case("partridge_schwenke") - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge_method = Charge_Method_Partridge_Schwenke - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 1 - case default - call system_abort ("IPModel_Multipoles_read_params_xml: moments_method "//trim(value)//" unknown") - end select - end if - - call QUIP_FoX_get_value(attributes, "dipole_method", value, status) - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%dipole_method = Dipole_Method_None - if (status == 0) then - read (value, *) moments_method_str - select case(lower_case(trim(moments_method_str))) - case("none") - continue - case("gap") - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%dipole_method = Dipole_Method_GAP - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 3 - case("partridge_schwenke") - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%dipole_method = Dipole_Method_Partridge_Schwenke - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 3 - case default - call system_abort ("IPModel_Multipoles_read_params_xml: moments_method "//trim(value)//" unknown") - end select - end if - - call QUIP_FoX_get_value(attributes, "pol_alpha", value, status) - if (status /= 0) then - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%polarisable=.false. - else - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%polarisable=.true. - if (parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d .lt. 3 ) parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 3 - read (value, *) alpha_au - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%alpha=alpha_au*CUBIC_BOHR - if (parse_ip%multipoles%calc_opts%damping==Damping_None) then - call system_abort("IPModel_Multipoles_read_params_xml: Cannot have polarsiable sites present with undamped interactions") - end if - end if - - ! by default, polarisable sites are damped and unpolarisable ones are not, can override default behaviour by setting damp_rad - ! if damp_rad=0.0, then no damping occurs. If want to damp a non-polarisable site, have to provide a radius manually - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damped = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%polarisable - - call QUIP_FoX_get_value(attributes, "damp_rad", value, status) - if (status /= 0) then - if (parse_ip%multipoles%calc_opts%damping==Damping_Erf) then - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damp_rad = (alpha_au*sqrt(2.0_dp/PI)/3.0_dp)**(1.0_dp/3.0_dp)*BOHR - else if (parse_ip%multipoles%calc_opts%damping==Damping_Exp) then - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damp_rad = (alpha_au)**(1.0_dp/3.0_dp)*BOHR - end if - else - if (parse_ip%multipoles%calc_opts%damping==Damping_None) then - call system_abort("IPModel_Multipoles_read_params_xml: damp_rad specified but no damping type selected, please specify damping=exp or damping=erf") - else - read (value, *) parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damp_rad ! override default damp_rad value - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damped = .true. - end if - end if - - if (.not. parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damped ) then - if ( parse_ip%multipoles%calc_opts%damping/=Damping_None ) then - call system_abort ("IPModel_Multipoles_read_params_xml: damping requested but no radii specified for non-polarisable sites ") - else - do i=1,tj-1 - if (parse_ip%multipoles%monomer_types(ti)%site_types(i)%polarisable) then - call system_abort ("IPModel_Multipoles_read_params_xml: cannot have undamped charges in combination with polarisable sites. Please ensure all sites have a damp_rad set. ") - end if - end do - end if - end if - - parse_ip%multipoles%monomer_types(ti)%site_types(tj)%initialised = .true. - - endif - - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Multipoles_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - - -end module IPModel_Multipoles_module diff --git a/src/Potentials/IPModel_PartridgeSchwenke.f95 b/src/Potentials/IPModel_PartridgeSchwenke.f95 deleted file mode 100644 index f68bcd20f6..0000000000 --- a/src/Potentials/IPModel_PartridgeSchwenke.f95 +++ /dev/null @@ -1,709 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_PartridgeSchwenke -!X -!% Partridge-Schwenke model for a water monomer. This is a wrapper for the -!% code downloaded from EPAPS from the JCP website. -!% EPAPS code: E-JCPSA-106-4618 -!% -!% Reference: -!% Authors: Harry Partridge and David W. Schwenke -!% Title: The determination of an accurate isotope dependent potential energy -!% surface for water ... -!% Journal: Journal of Chemical Physics, Volume 106, No.11, 15 March 1997-Page 4618 -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_PartridgeSchwenke_module - -use error_module -use system_module, only : dp, inoutput, print -use units_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use topology_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_PartridgeSchwenke -type IPModel_PartridgeSchwenke - real(dp) :: cutoff = 1.7_dp - logical :: OHH_ordercheck = .true. -end type IPModel_PartridgeSchwenke - -real(dp) :: c5z(245),cbasis(245),ccore(245), crest(245) -integer::i, idx(245,3) -data (idx(i,1),i=1,245)/& - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & - 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 4, 4, 4, 4, 4, 4, 4, 4, & - 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, & - 6, 6, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, & - 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 5, & - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, & - 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, & - 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 9, 9, & - 9, 9, 9, 9, 9/ -data (idx(i,2),i=1,245)/& - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4, 4, & - 4, 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, & - 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 5, 5, 5, 5, 5, 5, 5, 4, 4, 4, & - 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 1, 1, & - 1, 1, 1, 1, 1/ -data (idx(i,3),i=1,245)/& - 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 1, 2, 3, 4, 5, & - 6, 7, 8, 9,10,11,12,13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, & - 12,13, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, & - 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, & - 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, & - 11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, & - 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, & - 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9, & - 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, & - 3, 4, 5, 6, 7, 8, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4, 5, 6, & - 7, 8, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4, 5, 6, 7, 1, 2, 3, & - 4, 5, 6, 7, 1, 2, 3, 4, 5, 6, 7, 1, 2, 3, 4, 5, 6, 7, 1, 2, & - 3, 4, 5, 6, 7/ -data (c5z(i),i=1,245)/& - 4.2278462684916D+04, 4.5859382909906D-02, 9.4804986183058D+03, & - 7.5485566680955D+02, 1.9865052511496D+03, 4.3768071560862D+02, & - 1.4466054104131D+03, 1.3591924557890D+02,-1.4299027252645D+03, & - 6.6966329416373D+02, 3.8065088734195D+03,-5.0582552618154D+02, & - -3.2067534385604D+03, 6.9673382568135D+02, 1.6789085874578D+03, & - -3.5387509130093D+03,-1.2902326455736D+04,-6.4271125232353D+03, & - -6.9346876863641D+03,-4.9765266152649D+02,-3.4380943579627D+03, & - 3.9925274973255D+03,-1.2703668547457D+04,-1.5831591056092D+04, & - 2.9431777405339D+04, 2.5071411925779D+04,-4.8518811956397D+04, & - -1.4430705306580D+04, 2.5844109323395D+04,-2.3371683301770D+03, & - 1.2333872678202D+04, 6.6525207018832D+03,-2.0884209672231D+03, & - -6.3008463062877D+03, 4.2548148298119D+04, 2.1561445953347D+04, & - -1.5517277060400D+05, 2.9277086555691D+04, 2.6154026873478D+05, & - -1.3093666159230D+05,-1.6260425387088D+05, 1.2311652217133D+05, & - -5.1764697159603D+04, 2.5287599662992D+03, 3.0114701659513D+04, & - -2.0580084492150D+03, 3.3617940269402D+04, 1.3503379582016D+04, & - -1.0401149481887D+05,-6.3248258344140D+04, 2.4576697811922D+05, & - 8.9685253338525D+04,-2.3910076031416D+05,-6.5265145723160D+04, & - 8.9184290973880D+04,-8.0850272976101D+03,-3.1054961140464D+04, & - -1.3684354599285D+04, 9.3754012976495D+03,-7.4676475789329D+04, & - -1.8122270942076D+05, 2.6987309391410D+05, 4.0582251904706D+05, & - -4.7103517814752D+05,-3.6115503974010D+05, 3.2284775325099D+05, & - 1.3264691929787D+04, 1.8025253924335D+05,-1.2235925565102D+04, & - -9.1363898120735D+03,-4.1294242946858D+04,-3.4995730900098D+04, & - 3.1769893347165D+05, 2.8395605362570D+05,-1.0784536354219D+06, & - -5.9451106980882D+05, 1.5215430060937D+06, 4.5943167339298D+05, & - -7.9957883936866D+05,-9.2432840622294D+04, 5.5825423140341D+03, & - 3.0673594098716D+03, 8.7439532014842D+04, 1.9113438435651D+05, & - -3.4306742659939D+05,-3.0711488132651D+05, 6.2118702580693D+05, & - -1.5805976377422D+04,-4.2038045404190D+05, 3.4847108834282D+05, & - -1.3486811106770D+04, 3.1256632170871D+04, 5.3344700235019D+03, & - 2.6384242145376D+04, 1.2917121516510D+05,-1.3160848301195D+05, & - -4.5853998051192D+05, 3.5760105069089D+05, 6.4570143281747D+05, & - -3.6980075904167D+05,-3.2941029518332D+05,-3.5042507366553D+05, & - 2.1513919629391D+03, 6.3403845616538D+04, 6.2152822008047D+04, & - -4.8805335375295D+05,-6.3261951398766D+05, 1.8433340786742D+06, & - 1.4650263449690D+06,-2.9204939728308D+06,-1.1011338105757D+06, & - 1.7270664922758D+06, 3.4925947462024D+05,-1.9526251371308D+04, & - -3.2271030511683D+04,-3.7601575719875D+05, 1.8295007005531D+05, & - 1.5005699079799D+06,-1.2350076538617D+06,-1.8221938812193D+06, & - 1.5438780841786D+06,-3.2729150692367D+03, 1.0546285883943D+04, & - -4.7118461673723D+04,-1.1458551385925D+05, 2.7704588008958D+05, & - 7.4145816862032D+05,-6.6864945408289D+05,-1.6992324545166D+06, & - 6.7487333473248D+05, 1.4361670430046D+06,-2.0837555267331D+05, & - 4.7678355561019D+05,-1.5194821786066D+04,-1.1987249931134D+05, & - 1.3007675671713D+05, 9.6641544907323D+05,-5.3379849922258D+05, & - -2.4303858824867D+06, 1.5261649025605D+06, 2.0186755858342D+06, & - -1.6429544469130D+06,-1.7921520714752D+04, 1.4125624734639D+04, & - -2.5345006031695D+04, 1.7853375909076D+05,-5.4318156343922D+04, & - -3.6889685715963D+05, 4.2449670705837D+05, 3.5020329799394D+05, & - 9.3825886484788D+03,-8.0012127425648D+05, 9.8554789856472D+04, & - 4.9210554266522D+05,-6.4038493953446D+05,-2.8398085766046D+06, & - 2.1390360019254D+06, 6.3452935017176D+06,-2.3677386290925D+06, & - -3.9697874352050D+06,-1.9490691547041D+04, 4.4213579019433D+04, & - 1.6113884156437D+05,-7.1247665213713D+05,-1.1808376404616D+06, & - 3.0815171952564D+06, 1.3519809705593D+06,-3.4457898745450D+06, & - 2.0705775494050D+05,-4.3778169926622D+05, 8.7041260169714D+03, & - 1.8982512628535D+05,-2.9708215504578D+05,-8.8213012222074D+05, & - 8.6031109049755D+05, 1.0968800857081D+06,-1.0114716732602D+06, & - 1.9367263614108D+05, 2.8678295007137D+05,-9.4347729862989D+04, & - 4.4154039394108D+04, 5.3686756196439D+05, 1.7254041770855D+05, & - -2.5310674462399D+06,-2.0381171865455D+06, 3.3780796258176D+06, & - 7.8836220768478D+05,-1.5307728782887D+05,-3.7573362053757D+05, & - 1.0124501604626D+06, 2.0929686545723D+06,-5.7305706586465D+06, & - -2.6200352535413D+06, 7.1543745536691D+06,-1.9733601879064D+04, & - 8.5273008477607D+04, 6.1062454495045D+04,-2.2642508675984D+05, & - 2.4581653864150D+05,-9.0376851105383D+05,-4.4367930945690D+05, & - 1.5740351463593D+06, 2.4563041445249D+05,-3.4697646046367D+03, & - -2.1391370322552D+05, 4.2358948404842D+05, 5.6270081955003D+05, & - -8.5007851251980D+05,-6.1182429537130D+05, 5.6690751824341D+05, & - -3.5617502919487D+05,-8.1875263381402D+02,-2.4506258140060D+05, & - 2.5830513731509D+05, 6.0646114465433D+05,-6.9676584616955D+05, & - 5.1937406389690D+05, 1.7261913546007D+05,-1.7405787307472D+04, & - -3.8301842660567D+05, 5.4227693205154D+05, 2.5442083515211D+06, & - -1.1837755702370D+06,-1.9381959088092D+06,-4.0642141553575D+05, & - 1.1840693827934D+04,-1.5334500255967D+05, 4.9098619510989D+05, & - 6.1688992640977D+05, 2.2351144690009D+05,-1.8550462739570D+06, & - 9.6815110649918D+03,-8.1526584681055D+04,-8.0810433155289D+04, & - 3.4520506615177D+05, 2.5509863381419D+05,-1.3331224992157D+05, & - -4.3119301071653D+05,-5.9818343115856D+04, 1.7863692414573D+03, & - 8.9440694919836D+04,-2.5558967650731D+05,-2.2130423988459D+04, & - 4.4973674518316D+05,-2.2094939343618D+05/ -data (cbasis(i),i=1,245)/& - 6.9770019624764D-04,-2.4209870001642D+01, 1.8113927151562D+01, & - 3.5107416275981D+01,-5.4600021126735D+00,-4.8731149608386D+01, & - 3.6007189184766D+01, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - -7.7178474355102D+01,-3.8460795013977D+01,-4.6622480912340D+01, & - 5.5684951167513D+01, 1.2274939911242D+02,-1.4325154752086D+02, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00,-6.0800589055949D+00, & - 8.6171499453475D+01,-8.4066835441327D+01,-5.8228085624620D+01, & - 2.0237393793875D+02, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 3.3525582670313D+02, 7.0056962392208D+01,-4.5312502936708D+01, & - -3.0441141194247D+02, 2.8111438108965D+02, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-1.2983583774779D+02, 3.9781671212935D+01, & - -6.6793945229609D+01,-1.9259805675433D+02, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-8.2855757669957D+02,-5.7003072730941D+01, & - -3.5604806670066D+01, 9.6277766002709D+01, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 8.8645622149112D+02,-7.6908409772041D+01, & - 6.8111763314154D+01, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 2.5090493428062D+02,-2.3622141780572D+02, 5.8155647658455D+02, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 2.8919570295095D+03, & - -1.7871014635921D+02,-1.3515667622500D+02, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-3.6965613754734D+03, 2.1148158286617D+02, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00,-1.4795670139431D+03, & - 3.6210798138768D+02, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - -5.3552886800881D+03, 3.1006384016202D+02, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 1.6241824368764D+03, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 4.3764909606382D+03, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 1.0940849243716D+03, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 3.0743267832931D+03, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00/ -data (ccore(i),i=1,245)/& - 2.4332191647159D-02,-2.9749090113656D+01, 1.8638980892831D+01, & - -6.1272361746520D+00, 2.1567487597605D+00,-1.5552044084945D+01, & - 8.9752150543954D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - -3.5693557878741D+02,-3.0398393196894D+00,-6.5936553294576D+00, & - 1.6056619388911D+01, 7.8061422868204D+01,-8.6270891686359D+01, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00,-3.1688002530217D+01, & - 3.7586725583944D+01,-3.2725765966657D+01,-5.6458213299259D+00, & - 2.1502613314595D+01, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 5.2789943583277D+02,-4.2461079404962D+00,-2.4937638543122D+01, & - -1.1963809321312D+02, 2.0240663228078D+02, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-6.2574211352272D+02,-6.9617539465382D+00, & - -5.9440243471241D+01, 1.4944220180218D+01, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-1.2851139918332D+03,-6.5043516710835D+00, & - 4.0410829440249D+01,-6.7162452402027D+01, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 1.0031942127832D+03, 7.6137226541944D+01, & - -2.7279242226902D+01, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - -3.3059000871075D+01, 2.4384498749480D+01,-1.4597931874215D+02, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 1.6559579606045D+03, & - 1.5038996611400D+02,-7.3865347730818D+01, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-1.9738401290808D+03,-1.4149993809415D+02, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00,-1.2756627454888D+02, & - 4.1487702227579D+01, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - -1.7406770966429D+03,-9.3812204399266D+01, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-1.1890301282216D+03, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 2.3723447727360D+03, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-1.0279968223292D+03, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 5.7153838472603D+02, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00/ -data (crest(i),i=1,245)/& - 0.0000000000000D+00,-4.7430930170000D+00,-1.4422132560000D+01, & - -1.8061146510000D+01, 7.5186735000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - -2.7962099800000D+02, 1.7616414260000D+01,-9.9741392630000D+01, & - 7.1402447000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00,-7.8571336480000D+01, & - 5.2434353250000D+01, 7.7696745000000D+01, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 1.7799123760000D+02, 1.4564532380000D+02, 2.2347226000000D+02, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-4.3823284100000D+02,-7.2846553000000D+02, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00,-2.6752313750000D+02, 3.6170310000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & - 0.0000000000000D+00, 0.0000000000000D+00/ -real(dp) :: reoh, thetae, b1, roh, alphaoh, deoh, phh1, phh2 -data reoh,thetae,b1,roh,alphaoh,deoh,phh1,phh2/0.958649d0,& - 104.3475d0,2.0d0,0.9519607159623009d0,2.587949757553683d0,& - 42290.92019288289d0,16.94879431193463d0,12.66426998162947d0/ -real(dp) :: f5z, fbasis, fcore, frest -data f5z,fbasis,fcore,frest/0.99967788500000d0,& - 0.15860145369897d0,-1.6351695982132d0,1d0/ - -interface Initialise - module procedure IPModel_PartridgeSchwenke_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_PartridgeSchwenke_Finalise -end interface Finalise - -interface Print - module procedure IPModel_PartridgeSchwenke_Print -end interface Print - -interface Calc - module procedure IPModel_PartridgeSchwenke_Calc -end interface Calc - -contains - -subroutine IPModel_PartridgeSchwenke_Initialise_str(this, args_str, param_str, error) - type(IPModel_PartridgeSchwenke), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out) :: error - - call Finalise(this) - - call initialise(params) - call param_register(params, 'OHH_ordercheck', 'T', this%OHH_ordercheck, help_string="if FALSE, skip transforming atomic order to OHHOHHOHH... and assume atoms are in that order. This also skips cutoff checking for OH bonds. default: TRUE") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_PartridgeSchwenke_Initialise args_str')) then - RAISE_ERROR("IPModel_PartridgeSchwenke failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - -end subroutine IPModel_PartridgeSchwenke_Initialise_str - -subroutine IPModel_PartridgeSchwenke_Finalise(this) - type(IPModel_PartridgeSchwenke), intent(inout) :: this -end subroutine IPModel_PartridgeSchwenke_Finalise - - -subroutine IPModel_PartridgeSchwenke_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_PartridgeSchwenke), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), dimension(at%N/3,3) :: rij ! array to pass to vibpot containing geometry - real(dp), dimension(at%N/3) :: v ! result from vibpot containing energy - integer :: i, o, h1, h2 - integer, dimension(3,at%N/3) :: water_index - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if(present(local_e)) then - RAISE_ERROR('local_e not implemented', error) - end if - if(present(f)) then - RAISE_ERROR('forces not implemented', error) - end if - if(present(virial)) then - RAISE_ERROR('virial not implemented', error) - end if - if (present(local_virial)) then - RAISE_ERROR("IPModel_PartridgeSchwenke_Calc: local_virial calculation requested but not supported yet.", error) - endif - - if(.not. present(e)) return ! nothing to do - - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_PartridgeSchwenke_Calc args_str')) then - RAISE_ERROR("IPModel_PartridgeSchwenke_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_PartridgeSchwenke_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_PartridgeSchwenke_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - endif - - ! loop through atoms, find oxygens and their closest hydrogens - - call find_water_monomer(at,water_index,this%OHH_ordercheck,error=error) - - do i = 1, at%N/3 - o = water_index(1,i) - h1 = water_index(2,i) - h2 = water_index(3,i) - rij(i,1) = distance_min_image(at,o,h1) - rij(i,2) = distance_min_image(at,o,h2) - rij(i,3) = acos(cosine(at,o,h1,h2)) - end do - - ! convert distances to atomic units - do i = 1, at%N/3 - rij(i,1) = rij(i,1)/BOHR - rij(i,2) = rij(i,2)/BOHR - end do - call vibpot(rij, v, at%N/3) ! actually call energy calculator - e = sum(v)*HARTREE ! convert result into eV - -end subroutine IPModel_PartridgeSchwenke_Calc - - -subroutine IPModel_PartridgeSchwenke_Print(this, file) - type(IPModel_PartridgeSchwenke), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - call Print("IPModel_PartridgeSchwenke : Partridge-Schwenke water molecule potential", file=file) - call print("pes for h2o", file=file) - call print("by Harry Partridge and David W. Schwenke", file=file) - call print("submitted to J. Chem. Phys. Aug. 28, 1996", file=file) -end subroutine IPModel_PartridgeSchwenke_Print - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X the following is the original code accompanying the article -!X modified to f90 freeform format and some printing commented out -!X parameter declarations were moved out into the module scope -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine vibpot(rij,v,n) - integer :: n - real(dp), dimension(n, 3) :: rij - real(dp), dimension(n) :: v - -! -! pes for h2o, -! Harry Partridge and David W. Schwenke, J. Chem. Phys., -! submitted Aug. 28, 1996. -! rij(i,1)& rij(i,2) are oh distances in au -! rij(i,3) is hoh angle in rad -! v(i) is pes in au -! n is number of geometries -! - real(dp) :: fmat(15,3) - integer :: ifirst = 0 - integer :: i, j - real(dp) :: ce, ex, rad, rhh, term, vhh, voh1, voh2, x1, x2, x3 - save - - if(ifirst.eq.0)then - ifirst=1 -! write(6,1) -! 1 format(/1x,'pes for h2o', -! $ /1x,'by Harry Partridge and David W. Schwenke', -! $ /1x,'submitted to J. Chem. Phys. Aug. 28, 1996') -! write(6,56) -! 56 format(/1x,'parameters before adjustment') -! write(6,55)phh1,phh2,deoh,alphaoh,roh -! 55 format(/1x,'two body potential parameters:', -! $ /1x,'hh: phh1 = ',f10.1,' phh2 = ',f5.2, -! $ /1x,'oh: deoh = ',f10.1,' alpha = ',f7.4, -! $ ' re = ',f7.4) -! write(6,4)reoh,thetae,b1 -! 4 format(/1x,'three body parameters:', -! $ /1x,'reoh = ',f10.4,' thetae = ',f10.4, -! $ /1x,'betaoh = ',f10.4, -! $ /1x,' i j k',7x,'c5z',9x,'cbasis',10x,'ccore', -! $ 10x,'crest') - do i=1,245 -! write(6,5)(idx(i,j)-1,j=1,3),c5z(i),cbasis(i),ccore(i),crest(i) -! 5 format(1x,3i5,1p4e15.7) - c5z(i)=f5z*c5z(i)+fbasis*cbasis(i)+fcore*ccore(i) & - +frest*crest(i) - end do -! write(6,57)f5z,fbasis,fcore,frest -! 57 format(/1x,'adjusting parameters using scale factors ', -! $ /1x,'f5z = ',f11.8, -! $ /1x,'fbasis = ',f11.8, -! $ /1x,'fcore = ',f11.8, -! $ /1x,'frest = ',f11.8) - phh1=phh1*f5z - deoh=deoh*f5z -! write(6,55)phh1,phh2,deoh,alphaoh,roh -! write(6,58)reoh,thetae,b1,((idx(i,j)-1,j=1,3),c5z(i),i=1,245) -! 58 format(/1x,'three body parameters:', -! $ /1x,'reoh = ',f10.4,' thetae = ',f10.4, -! $ /1x,'betaoh = ',f10.4, -! $ /1x,' i j k cijk', -! $ /(1x,3i5,1pe15.7)) -! -! convert parameters from 1/cm, angstrom to a.u. -! - reoh=reoh/0.529177249d0 - b1=b1*0.529177249d0*0.529177249d0 - do i=1,245 - c5z(i)=c5z(i)*4.556335d-6 - end do - rad=acos(-1d0)/1.8d2 - ce=cos(thetae*rad) - phh1=phh1*exp(phh2) - phh1=phh1*4.556335d-6 - phh2=phh2*0.529177249d0 - deoh=deoh*4.556335d-6 - roh=roh/0.529177249d0 - alphaoh=alphaoh*0.529177249d0 - c5z(1)=c5z(1)*2d0 - end if - - do i=1,n - x1=(rij(i,1)-reoh)/reoh - x2=(rij(i,2)-reoh)/reoh - x3=cos(rij(i,3))-ce - rhh=sqrt(rij(i,1)**2+rij(i,2)**2-2d0*rij(i,1)*rij(i,2)*cos(rij(i,3))) - vhh=phh1*exp(-phh2*rhh) - ex=exp(-alphaoh*(rij(i,1)-roh)) - voh1=deoh*ex*(ex-2d0) - ex=exp(-alphaoh*(rij(i,2)-roh)) - voh2=deoh*ex*(ex-2d0) - fmat(1,1)=1d0 - fmat(1,2)=1d0 - fmat(1,3)=1d0 - do j=2,15 - fmat(j,1)=fmat(j-1,1)*x1 - fmat(j,2)=fmat(j-1,2)*x2 - fmat(j,3)=fmat(j-1,3)*x3 - end do - v(i)=0d0 - do j=2,245 - term=c5z(j)*(fmat(idx(j,1),1)*fmat(idx(j,2),2) & - +fmat(idx(j,2),1)*fmat(idx(j,1),2)) & - *fmat(idx(j,3),3) - v(i)=v(i)+term - end do - v(i)=v(i)*exp(-b1*((rij(i,1)-reoh)**2+(rij(i,2)-reoh)**2)) & - +c5z(1) & - +voh1+voh2+vhh - end do - return -end subroutine vibpot - -end module IPModel_PartridgeSchwenke_module diff --git a/src/Potentials/IPModel_RS.f95 b/src/Potentials/IPModel_RS.f95 deleted file mode 100644 index 8fdad875ff..0000000000 --- a/src/Potentials/IPModel_RS.f95 +++ /dev/null @@ -1,575 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_RS module -!X -!% Module for a Repulsive Step pair potential. -!% \begin{equation} -!% \nonumber -!% V(r) = \epsilon \left[ \left( \frac{\sigma}{r} \right)^{14} + \frac{1}{2} \left( 1 - \tanh (k (r - \sigma_1)) \right) \right] -!% \end{equation} -!% From J. Chem. Phys. 129, 064512 (2008) -!% -!% The IPModel_RS object contains all the parameters read from a -!% 'RS_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_RS_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, string_to_numerical, operator(//) -use extendable_str_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use units_module, only : PI -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_RS -type shoulder_params_t - integer :: n = 0 - real(dp), dimension(:), allocatable :: sigma1, lambda, k - real(dp) :: lambda0 = 0.0_dp -endtype shoulder_params_t - -type IPModel_RS - integer :: n_types = 0 !% Number of atomic types. - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - real(dp), allocatable :: eps(:,:), sigma(:,:) - type(shoulder_params_t), dimension(:,:), allocatable :: shoulder_params - - character(len=STRING_LENGTH) label - -end type IPModel_RS - -logical, private :: parse_in_ip, parse_matched_label -integer, private :: parse_ti, parse_tj -type(extendable_str), private, save :: parse_element_data -type(IPModel_RS), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_RS_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_RS_Finalise -end interface Finalise - -interface Print - module procedure IPModel_RS_Print -end interface Print - -interface Calc - module procedure IPModel_RS_Calc -end interface Calc - -contains - -subroutine IPModel_RS_Initialise_str(this, args_str, param_str) - type(IPModel_RS), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label = '' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_RS_Initialise_str args_str')) then - call system_abort("IPModel_RS_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_RS_read_params_xml(this, param_str) - -end subroutine IPModel_RS_Initialise_str - -subroutine IPModel_RS_Finalise(this) - type(IPModel_RS), intent(inout) :: this - integer :: i, j - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%sigma)) deallocate(this%sigma) - if (allocated(this%eps)) deallocate(this%eps) - if (allocated(this%shoulder_params)) then - do i = 1, this%n_types - do j = 1, this%n_types - if(allocated(this%shoulder_params(j,i)%sigma1)) deallocate(this%shoulder_params(j,i)%sigma1) - if(allocated(this%shoulder_params(j,i)%lambda)) deallocate(this%shoulder_params(j,i)%lambda) - if(allocated(this%shoulder_params(j,i)%k)) deallocate(this%shoulder_params(j,i)%k) - this%shoulder_params(j,i)%n = 0 - this%shoulder_params(j,i)%lambda0 = 0.0_dp - enddo - enddo - deallocate(this%shoulder_params) - endif - - this%n_types = 0 - this%label = '' -end subroutine IPModel_RS_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_RS_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_RS), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), pointer :: w_e(:) - integer i, ji, j, ti, tj - real(dp) :: dr(3), dr_mag - real(dp) :: de, de_dr, virial_i(3,3) - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_RS_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_RS_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_RS_Calc', error) - local_virial = 0.0_dp - endif - - atom_mask_pointer => null() - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of logical property used to mask atoms") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_RS_Calc args_str')) then - RAISE_ERROR("IPModel_RS_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_RS_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - else - atom_mask_pointer => null() - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_RS_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - - endif ! present(args_str) - - if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) - - do i = 1, at%N - - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - do ji = 1, n_neighbours(at, i) - j = neighbour(at, i, ji, dr_mag, cosines = dr) - - if (dr_mag .feq. 0.0_dp) cycle - !if (j <= 0) cycle - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (present(e) .or. present(local_e)) then - de = 0.5_dp * IPModel_RS_pairenergy(this, ti, tj, dr_mag) - - if (present(local_e)) then - local_e(i) = local_e(i) + de - endif - if (present(e)) then - if (associated(w_e)) then - de = de*0.5_dp*(w_e(i)+w_e(j)) - endif - e = e + de - endif - endif - if (present(f) .or. present(virial)) then - de_dr = 0.5_dp*IPModel_RS_pairenergy_deriv(this, ti, tj, dr_mag) - if (associated(w_e)) then - de_dr = de_dr*0.5_dp*(w_e(i)+w_e(j)) - endif - if (present(f)) then - f(:,i) = f(:,i) + de_dr*dr - f(:,j) = f(:,j) - de_dr*dr - endif - - if (present(virial) .or. present(local_virial) ) virial_i = de_dr*(dr .outer. dr)*dr_mag - if (present(virial)) virial = virial - virial_i - if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i, (/9/)) - endif - end do - end do - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(local_virial)) call sum_in_place(mpi, local_virial) - if (present(f)) call sum_in_place(mpi, f) - endif - -end subroutine IPModel_RS_Calc - -!% This routine computes the two-body term for a pair of atoms separated by a distance r. -function IPModel_RS_pairenergy(this, ti, tj, r) - type(IPModel_RS), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_RS_pairenergy - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff)) then - IPModel_RS_pairenergy = 0.0_dp - return - endif - - IPModel_RS_pairenergy = this%eps(ti,tj) * ( & - ( this%sigma(ti,tj) / r )**14 + & - sum( this%shoulder_params(ti,tj)%lambda * tanh( this%shoulder_params(ti,tj)%k * ( r - this%shoulder_params(ti,tj)%sigma1 ) ) ) + & - this%shoulder_params(ti,tj)%lambda0 ) - -end function IPModel_RS_pairenergy - -!% Derivative of the two-body term. -function IPModel_RS_pairenergy_deriv(this, ti, tj, r) - type(IPModel_RS), intent(in) :: this - integer, intent(in) :: ti, tj !% Atomic types. - real(dp), intent(in) :: r !% Distance. - real(dp) :: IPModel_RS_pairenergy_deriv - - if ((r .feq. 0.0_dp) .or. (r > this%cutoff)) then - IPModel_RS_pairenergy_deriv = 0.0_dp - return - endif - - IPModel_RS_pairenergy_deriv = this%eps(ti,tj) * ( & - - 14.0_dp * ( this%sigma(ti,tj) / r )**14 / r + & - sum( this%shoulder_params(ti,tj)%lambda * & - this%shoulder_params(ti,tj)%k / cosh( this%shoulder_params(ti,tj)%k * ( r - this%shoulder_params(ti,tj)%sigma1 ) )**2 ) ) - -end function IPModel_RS_pairenergy_deriv - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for XML stanza is given below, please notice that -!% they are simply dummy parameters for testing purposes, with no physical meaning. -!% -!% -!% -!% -!% -!% -0.5 -!% 1.35 -!% 10 -!% -!% -!% -!% -!% -!% -0.8 0.3 -!% 1.35 1.80 -!% 10 10 -!% -!% -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - if (name == 'RS_params') then ! new RS stanza - - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered RS_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in RS_params") - endif - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if (status == 0) then - read (value, *) parse_ip%cutoff - else - call system_abort("Can't find cutoff in RS_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%sigma(parse_ip%n_types,parse_ip%n_types)) - parse_ip%sigma = 1.0_dp - allocate(parse_ip%eps(parse_ip%n_types,parse_ip%n_types)) - parse_ip%eps = 0.0_dp - allocate(parse_ip%shoulder_params(parse_ip%n_types,parse_ip%n_types)) - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find type") - read (value, *) parse_ti - - if (parse_ti < 1) call system_abort("IPModel_RS_read_params_xml got per_type_data type="//parse_ti//" < 1") - if (parse_ti > parse_ip%n_types) call system_abort("IPModel_RS_read_params_xml got per_type_data type="//parse_ti//" > n_types="//parse_ip%n_types) - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(parse_ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do parse_ti=1, parse_ip%n_types - if (parse_ip%atomic_num(parse_ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(parse_ti)) = parse_ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "type1", value, status) - if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find type1") - read (value, *) parse_ti - call QUIP_FoX_get_value(attributes, "type2", value, status) - if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find type2") - read (value, *) parse_tj - - if (parse_ti < 1) call system_abort("IPModel_RS_read_params_xml got per_type_data type1="//parse_ti//" < 1") - if (parse_ti > parse_ip%n_types) call system_abort("IPModel_RS_read_params_xml got per_pair_data type1="//parse_ti//" > n_types="//parse_ip%n_types) - if (parse_tj < 1) call system_abort("IPModel_RS_read_params_xml got per_type_data type2="//parse_tj//" < 1") - if (parse_tj > parse_ip%n_types) call system_abort("IPModel_RS_read_params_xml got per_pair_data type2="//parse_tj//" > n_types="//parse_ip%n_types) - - call QUIP_FoX_get_value(attributes, "sigma", value, status) - if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find sigma") - read (value, *) parse_ip%sigma(parse_ti,parse_tj) - call QUIP_FoX_get_value(attributes, "eps", value, status) - if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find eps6") - read (value, *) parse_ip%eps(parse_ti,parse_tj) - - - - call QUIP_FoX_get_value(attributes, "n", value, status) - if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find n") - read (value, *) parse_ip%shoulder_params(parse_ti,parse_tj)%n - allocate( parse_ip%shoulder_params(parse_ti,parse_tj)%sigma1( parse_ip%shoulder_params(parse_ti,parse_tj)%n ), & - parse_ip%shoulder_params(parse_ti,parse_tj)%lambda( parse_ip%shoulder_params(parse_ti,parse_tj)%n ), & - parse_ip%shoulder_params(parse_ti,parse_tj)%k( parse_ip%shoulder_params(parse_ti,parse_tj)%n ) ) - - if (parse_ti /= parse_tj) then - parse_ip%eps(parse_tj,parse_ti) = parse_ip%eps(parse_ti,parse_tj) - parse_ip%sigma(parse_tj,parse_ti) = parse_ip%sigma(parse_ti,parse_tj) - parse_ip%shoulder_params(parse_tj,parse_ti)%n = parse_ip%shoulder_params(parse_ti,parse_tj)%n - - allocate( parse_ip%shoulder_params(parse_tj,parse_ti)%sigma1( parse_ip%shoulder_params(parse_tj,parse_ti)%n ), & - parse_ip%shoulder_params(parse_tj,parse_ti)%lambda( parse_ip%shoulder_params(parse_tj,parse_ti)%n ), & - parse_ip%shoulder_params(parse_tj,parse_ti)%k( parse_ip%shoulder_params(parse_tj,parse_ti)%n ) ) - end if - - elseif (parse_in_ip .and. name == 'lambda') then - call zero(parse_element_data) - elseif (parse_in_ip .and. name == 'sigma1') then - call zero(parse_element_data) - elseif (parse_in_ip .and. name == 'k') then - call zero(parse_element_data) - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'RS_params') then - parse_in_ip = .false. - elseif( name == "lambda" ) then - call string_to_numerical( string(parse_element_data), parse_ip%shoulder_params(parse_ti,parse_tj)%lambda ) - parse_ip%shoulder_params(parse_ti,parse_tj)%lambda0 = -sum(parse_ip%shoulder_params(parse_ti,parse_tj)%lambda) - if( parse_ti /= parse_tj ) then - parse_ip%shoulder_params(parse_tj,parse_ti)%lambda = parse_ip%shoulder_params(parse_ti,parse_tj)%lambda - parse_ip%shoulder_params(parse_tj,parse_ti)%lambda0 = parse_ip%shoulder_params(parse_ti,parse_tj)%lambda0 - endif - elseif( name == "sigma1" ) then - call string_to_numerical( string(parse_element_data), parse_ip%shoulder_params(parse_ti,parse_tj)%sigma1 ) - if( parse_ti /= parse_tj ) parse_ip%shoulder_params(parse_tj,parse_ti)%sigma1 = parse_ip%shoulder_params(parse_ti,parse_tj)%sigma1 - elseif( name == "k" ) then - call string_to_numerical( string(parse_element_data), parse_ip%shoulder_params(parse_ti,parse_tj)%k ) - if( parse_ti /= parse_tj ) parse_ip%shoulder_params(parse_tj,parse_ti)%k = parse_ip%shoulder_params(parse_ti,parse_tj)%k - end if - - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_characters_handler(in) - character(len=*), intent(in) :: in - - if( parse_in_ip ) then - call concat(parse_element_data, in, keep_lf=.false.,lf_to_whitespace=.true.) - endif -endsubroutine IPModel_characters_handler - -subroutine IPModel_RS_read_params_xml(this, param_str) - type(IPModel_RS), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - call initialise(parse_element_data) - - call open_xml_string(fxml, param_str) - call parse(fxml, & - characters_handler = IPModel_characters_handler, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - call finalise(parse_element_data) - - if (this%n_types == 0) then - call system_abort("IPModel_RS_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_RS_read_params_xml - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of RS parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_RS_Print (this, file) - type(IPModel_RS), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_RS : Repulsive Step", file=file) - call Print("IPModel_RS : label = "//this%label, file=file) - call Print("IPModel_RS : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_RS : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - do tj=1, this%n_types - call Print ("IPModel_RS : interaction " // ti // " " // tj // " sigma " // this%sigma(ti,tj) // " eps " // & - this%eps(ti,tj) // " sigma1 " // this%shoulder_params(ti,tj)%sigma1 // " k " // this%shoulder_params(ti,tj)%k // & - " lambda " // this%shoulder_params(ti,tj)%lambda, file=file) - end do - call verbosity_pop() - end do - -end subroutine IPModel_RS_Print - -end module IPModel_RS_module diff --git a/src/Potentials/IPModel_SCME.f95 b/src/Potentials/IPModel_SCME.f95 deleted file mode 100644 index c0d51f69ec..0000000000 --- a/src/Potentials/IPModel_SCME.f95 +++ /dev/null @@ -1,336 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_SCME -!X -!% SCME module for the single-centre multipole expansion water module, developed by Thor Wikfeldt -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_SCME_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use linearalgebra_module, only: is_diagonal -use topology_module, only: find_water_monomer -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -#ifdef HAVE_SCME -use scme, only : scme_calculate -#endif - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_SCME -type IPModel_SCME - !integer :: n_types = 0 - !integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - logical :: full_interaction_order, use_repulsion, use_PS_PES - - character(len=STRING_LENGTH) :: label - -end type IPModel_SCME - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_SCME), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_SCME_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_SCME_Finalise -end interface Finalise - -interface Print - module procedure IPModel_SCME_Print -end interface Print - -interface Calc - module procedure IPModel_SCME_Calc -end interface Calc - -contains - -subroutine IPModel_SCME_Initialise_str(this, args_str, param_str) - type(IPModel_SCME), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'full_interaction_order', 'T', this%full_interaction_order, help_string="Whether to truncate the interaction order calculation at 5th order") - call param_register(params, 'use_repulsion', 'F', this%use_repulsion, help_string="Whether to use repulsion in SCME") - call param_register(params, 'use_PS_PES', 'T', this%use_PS_PES, help_string="Whether to use the PS potential energy surface") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SCME_Initialise_str args_str')) then - call system_abort("IPModel_SCME_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - if( trim(this%label) /= "version_20170802" ) then - call system_abort("IPModel_SCME_Initialise_str: SCME with updated parameters/damping. Make sure your potential is compatible. Proceed with caution, email Albert for instructions if in doubt.") - endif - !call IPModel_SCME_read_params_xml(this, param_str) - this%cutoff = 2.0_dp - - ! Add initialisation code here - -end subroutine IPModel_SCME_Initialise_str - -subroutine IPModel_SCME_Finalise(this) - type(IPModel_SCME), intent(inout) :: this - - ! Add finalisation code here - this%cutoff = 0.0_dp - - this%label = '' -end subroutine IPModel_SCME_Finalise - - - - - - - -!///////////////////////////////// -subroutine IPModel_SCME_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_SCME), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:) !j - real(dp), intent(out), optional :: local_virial(:,:) !j - !j real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer :: nWater, i, a, m - integer, dimension(:,:), allocatable :: water_monomer_index - real(dp) :: uTot - real(dp), dimension(3) :: lattice - real(dp), dimension(:), allocatable :: raOri - real(dp), dimension(:,:), allocatable :: coords !j - real(dp), dimension(:,:), allocatable :: fa !j - - INIT_ERROR(error) -#ifndef HAVE_SCME - RAISE_ERROR('IPModel_SCME_Calc - not linked to the scme library',error) -#endif - - if (present(e)) e = 0.0_dp - - if (present(local_e)) then - RAISE_ERROR('IPModel_SCME_Calc - local energies not implemented',error) - call check_size('Local_E',local_e,(/at%N/),'IPModel_SCME_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - RAISE_ERROR('IPModel_SCME_Calc - forces not implemented',error) - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_SCME_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) then - RAISE_ERROR('IPModel_SCME_Calc - virials not implemented',error) - virial = 0.0_dp - endif - - if (present(local_virial)) then - RAISE_ERROR('IPModel_SCME_Calc - local virials not implemented',error) - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_SCME_Calc', error) - local_virial = 0.0_dp - endif - - nWater = count(at%Z==8) - allocate(water_monomer_index(3,nWater)) - call find_water_monomer(at,water_monomer_index,error=error) - - !j allocate(raOri(3*at%N),fa(3*at%N)) - allocate(raOri(3*at%N),fa(3,at%N)) !j - allocate( coords(3,at%N) ) !j - - if( is_diagonal(at%lattice) ) then - do i = 1, 3 - lattice(i) = at%lattice(i,i) - enddo - else - RAISE_ERROR('IPModel_SCME_Calc - lattice must be orthorhombic',error) - endif - - do i = 1, nWater !j molecules. I should change raOrig to at(3,n_atoms) or at(3,3,n_water) - - ! This is the new 3 by N_atoms coordinate matrix - coords(:,(i-1)*3+1) = at%pos(:,water_monomer_index(2,i)) !j coords is hho ordered in scme - coords(:,(i-1)*3+2) = at%pos(:,water_monomer_index(3,i)) - coords(:,(i-1)*3+3) = at%pos(:,water_monomer_index(1,i)) - - ! This is the old version: - do a = 1, 3 !j xyz - raOri( (i-1)*6 + a ) = at%pos(a,water_monomer_index(2,i)) !j h - raOri( (i-1)*6 + a + 3 ) = at%pos(a,water_monomer_index(3,i)) !j h - raOri( (i-1)*3 + nWater*6 + a ) = at%pos(a,water_monomer_index(1,i)) !j o - enddo - enddo - -#ifdef HAVE_SCME - !call scme_calculate(at%N,raOri, lattice, fa, uTot) - call scme_calculate(at%N,coords, lattice, fa, uTot,in_FULL=this%full_interaction_order, in_USE_REP=this%use_repulsion, in_USE_PS_PES=this%use_PS_PES) -#endif - - - if(present(f))then - do m = 1,nWater !jö Rearange from HHO (in fa in SCME) to OHH ( in f in QUIP) - f(:,(m-1)*3+1)=fa(:,(m-1)*3+3) !O - f(:,(m-1)*3+2)=fa(:,(m-1)*3+1) !H1 - f(:,(m-1)*3+3)=fa(:,(m-1)*3+2) !H1 - enddo - endif - - !if(present(f)) f = fa !j copy over the forces to the quip-defined array f from scme-specified fa ! How come the order gets correct? - - if (present(e)) e = uTot !j if (present): Refers to optional arguments - - if(allocated(water_monomer_index)) deallocate(water_monomer_index) - if(allocated(raOri)) deallocate(raOri) - if(allocated(fa)) deallocate(fa) - -end subroutine IPModel_SCME_Calc -!/////////////////////////////////////////////////////////// - - - - - - -subroutine IPModel_SCME_Print(this, file) - type(IPModel_SCME), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_SCME : SCME Potential", file=file) - -end subroutine IPModel_SCME_Print - -subroutine IPModel_SCME_read_params_xml(this, param_str) - type(IPModel_SCME), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - -end subroutine IPModel_SCME_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - if (name == 'SCME_params') then ! new SCME stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if(parse_in_ip) then - call finalise(parse_ip) - endif - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'SCME_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_SCME_module diff --git a/src/Potentials/IPModel_SW.f95 b/src/Potentials/IPModel_SW.f95 deleted file mode 100644 index 1b21f02f57..0000000000 --- a/src/Potentials/IPModel_SW.f95 +++ /dev/null @@ -1,920 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_SW module -!X -!% Module for the Stillinger and Weber potential for silicon -!% (Ref. Phys. Rev. B {\bf 31}, 5262, (1984)). -!% The IPModel_SW object contains all the parameters read -!% from an 'SW_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_SW_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_NERD, PRINT_VERBOSE, PRINT_ANALYSIS, current_verbosity, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_SW -type IPModel_SW - integer :: n_types = 0 !% Number of atomic types - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} - - real(dp) :: cutoff = 0.0_dp - - real(dp), allocatable :: a(:,:), AA(:,:), BB(:,:), p(:,:), q(:,:), sigma(:,:), eps2(:,:) !% IP parameters - real(dp), allocatable :: lambda(:,:,:), gamma(:,:,:), eps3(:,:,:) !% IP parameters - - character(len=STRING_LENGTH) :: label - -end type IPModel_SW - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_SW), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_SW_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_SW_Finalise -end interface Finalise - -interface Print - module procedure IPModel_SW_Print -end interface Print - -interface Calc - module procedure IPModel_SW_Calc -end interface Calc - -contains - -subroutine IPModel_SW_Initialise_str(this, args_str, param_str) - type(IPModel_SW), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Initialise_str args_str')) then - call system_abort("IPModel_SW_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_SW_read_params_xml(this, param_str) - -end subroutine IPModel_SW_Initialise_str - -subroutine IPModel_SW_Finalise(this) - type(IPModel_SW), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%a)) deallocate(this%a) - if (allocated(this%AA)) deallocate(this%AA) - if (allocated(this%BB)) deallocate(this%BB) - if (allocated(this%p)) deallocate(this%p) - if (allocated(this%q)) deallocate(this%q) - if (allocated(this%sigma)) deallocate(this%sigma) - if (allocated(this%eps2)) deallocate(this%eps2) - if (allocated(this%lambda)) deallocate(this%lambda) - if (allocated(this%gamma)) deallocate(this%gamma) - if (allocated(this%eps3)) deallocate(this%eps3) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_SW_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator. It computes energy, forces and virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_SW_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_SW), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), pointer :: w_e(:) - integer i, ji, j, ki, k - real(dp) :: drij(3), drij_mag, drik(3), drik_mag, drij_dot_drik - real(dp) :: w_f - - integer ti, tj, tk - - real(dp) :: drij_dri(3), drij_drj(3), drik_dri(3), drik_drk(3) - real(dp) :: dcos_ijk_dri(3), dcos_ijk_drj(3), dcos_ijk_drk(3) - real(dp) :: virial_i(3,3), virial_j(3,3), virial_k(3,3) - - real(dp) :: de, de_dr, de_drij, de_drik, de_dcos_ijk - real(dp) :: cur_cutoff - - integer :: n_neigh_i - - type(Dictionary) :: params - logical :: has_atom_mask_name, atom_mask_exclude_all - character(STRING_LENGTH) :: atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - -#ifdef _OPENMP - real(dp) :: private_virial(3,3), private_e - real(dp), allocatable :: private_f(:,:), private_local_e(:), private_local_virial(:,:) -#endif - - INIT_ERROR(error) - - call print("IPModel_SW_Calc starting ", PRINT_ANALYSIS) - if (present(e)) e = 0.0_dp - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_SW_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_SW_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) virial = 0.0_dp - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_SW_Calc', error) - local_virial = 0.0_dp - endif - - atom_mask_pointer => null() - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of logical property used to mask atoms") - call param_register(params, 'atom_mask_exclude_all', 'F', atom_mask_exclude_all, help_string="If true, exclude contributions made by atoms with atom_mask==.false. on their neighbour with atom_mask==.true., i.e. behave as if excluded atoms were not there at all") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Calc args_str')) then - RAISE_ERROR("IPModel_SW_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_SW_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - else - atom_mask_pointer => null() - endif - else - do_rescale_r = .false. - do_rescale_E = .false. - endif - - if (do_rescale_r) call print('IPModel_SW_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) - if (do_rescale_E) call print('IPModel_SW_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) - - if (.not.assign_pointer(at,"weight", w_e)) nullify(w_e) - -#ifdef _OPENMP -!$omp parallel private(i, ji, j, ki, k, drij, drij_mag, drik, drik_mag, drij_dot_drik, w_f, ti, tj, tk, drij_dri, drij_drj, drik_dri, drik_drk, dcos_ijk_dri, dcos_ijk_drj, dcos_ijk_drk, de, de_dr, de_drij, de_drik, de_dcos_ijk, cur_cutoff, private_virial, private_e, private_f, private_local_e, private_local_virial, n_neigh_i, virial_i, virial_j, virial_k) - - if (present(e)) private_e = 0.0_dp - if (present(local_e)) then - allocate(private_local_e(at%N)) - private_local_e = 0.0_dp - endif - if (present(f)) then - allocate(private_f(3,at%N)) - private_f = 0.0_dp - endif - if (present(virial)) private_virial = 0.0_dp - if (present(local_virial)) then - allocate(private_local_virial(9,at%N)) - private_local_virial = 0.0_dp - endif - -!$omp do -#endif - do i=1, at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_Calc i " // i // " " // n_neighbours(at,i), PRINT_ANALYSIS) - cur_cutoff = maxval(this%a(ti,:)*this%sigma(ti,:)) - n_neigh_i = n_neighbours(at, i) - do ji=1, n_neigh_i - - if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then - if(.not. atom_mask_pointer(j)) cycle - endif - - j = neighbour(at, i, ji, drij_mag, cosines = drij, max_dist = cur_cutoff) - if (j <= 0) cycle - if (drij_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) drij_mag = drij_mag*r_scale - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (drij_mag/this%sigma(ti,tj) > this%a(ti,tj)) cycle - - if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_Calc i j " // i // " " // j, PRINT_ANALYSIS) - - if (associated(w_e)) then - w_f = 0.5_dp*(w_e(i)+w_e(j)) - else - w_f = 1.0_dp - endif - - if (present(e) .or. present(local_e)) then - ! factor of 0.5 because SW definition goes over each pair only once - de = 0.5_dp*this%eps2(ti,tj)*f2(this, drij_mag, ti, tj) - if (present(local_e)) then -#ifdef _OPENMP - private_local_e(i) = private_local_e(i) + de -#else - local_e(i) = local_e(i) + de -#endif - endif - if (present(e)) then -#ifdef _OPENMP - private_e = private_e + de*w_f -#else - e = e + de*w_f -#endif - endif - endif - - if (present(f) .or. present(virial) .or. present(local_virial)) then - de_dr = 0.5_dp*this%eps2(ti,tj)*df2_dr(this, drij_mag, ti, tj) - if (present(f)) then -#ifdef _OPENMP - private_f(:,i) = private_f(:,i) + de_dr*w_f*drij - private_f(:,j) = private_f(:,j) - de_dr*w_f*drij -#else - f(:,i) = f(:,i) + de_dr*w_f*drij - f(:,j) = f(:,j) - de_dr*w_f*drij -#endif - endif - - if(present(virial) .or. present(local_virial)) virial_i = de_dr*w_f*(drij .outer. drij)*drij_mag - - if (present(virial)) then -#ifdef _OPENMP - private_virial = private_virial - virial_i -#else - virial = virial - virial_i -#endif - endif - if (present(local_virial)) then -#ifdef _OPENMP - private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i, (/9/)) -#else - local_virial(:,i) = local_virial(:,i) - reshape(virial_i, (/9/)) -#endif - endif - - endif - - if (associated(w_e)) then - w_f = w_e(i) - else - w_f = 1.0_dp - endif - - do ki=1, n_neigh_i - if (ki <= ji) cycle - k = neighbour(at, i, ki, drik_mag, cosines = drik, max_dist=cur_cutoff) - - if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then - if(.not. atom_mask_pointer(k)) cycle - endif - - if (k <= 0) cycle - if (drik_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) drik_mag = drik_mag*r_scale - - tk = get_type(this%type_of_atomic_num, at%Z(k)) - - if (drik_mag/this%sigma(ti,tk) > this%a(ti,tk)) cycle - - drij_dot_drik = sum(drij*drik) - if (present(e) .or. present(local_e)) then - de = this%eps3(ti,tj,tk)*f3(this, drij_mag, drik_mag, drij_dot_drik, ti, tj, tk) - if (present(local_e)) then -#ifdef _OPENMP - private_local_e(i) = private_local_e(i) + de -#else - local_e(i) = local_e(i) + de -#endif - endif - if (present(e)) then -#ifdef _OPENMP - private_e = private_e + de*w_f -#else - e = e + de*w_f -#endif - endif - endif - if (present(f) .or. present(virial) .or. present(local_virial)) then - call df3_dr(this, drij_mag, drik_mag, drij_dot_drik, ti, tj, tk, de_drij, de_drik, de_dcos_ijk) - drij_dri = drij - drij_drj = -drij - drik_dri = drik - drik_drk = -drik - -! dcos_ijk = drij_dot_drik -! (ri_x - rj_x)*(ri_x - rk_x) + (ri_y - rj_y)*(ri_y-rk_y) / (rij rik) -! -! d/dri -! -! ((rij rik)(rij_x + rik_x) - (rij . rik)(rij rik_x / rik + rik rij_x/rij)) / (rij rik)^2 -! -! rij rik ( rij_x + rik_x) - (rij.rik)(rij rik_x / rik + rik rij_x/rij) -! --------------------------------------------------------------------- -! rij^2 rik^2 -! -! rij_x + rik_x cos_ijk (rij rik_x / rik + rik rij_x /rij) -! ------------- - ------------------------------------------ -! rij rik rij rik -! -! rij_x + rik_x -! ------------- - cos_ijk (rik_x / rik^2 + rij_x / rij^2) -! rij rik -! -! -! rhatij_x/rik + rhatik_x/rij - cos_ijk(rhatik_x/rik + rhatij_x/rij) -! -! -! d/drj -! -! ((rij rik)(-rik_x) - (rij.rik)(rik (-rij_x)/rij)) / (rij rik)^2 -! -! -rik_x (rij.rik) ( rik rij_x/rij) -! ------- + --------------------------- -! rij rik rij^2 rik^2 -! -! -rhatik_x/rij + cos_ijk rhatij_x/rij -! -! d/drij -! -! (ri_x - rj_x)*(ri_x - rk_x) + (ri_y - rj_y)*(ri_y-rk_y) / (rij rik) -! -! (rij rik) rik_x - (rij . rik) (rij_x/rij rik) -! --------------------------------------------- -! (rij rik)^2 -! -! rik_x (rij.rik) rij_x -! ------ - --------------- -! rij rik rij^3 rik -! -! rhatik_x (rhatij . rhatik) rhatij_x -! -------- - ------------------------ -! rij rij -! -! rhatik_x cos_ijk * rhatij_x -! -------- - ------------------ -! rij rij - - dcos_ijk_dri = drij/drik_mag + drik/drij_mag - drij_dot_drik * (drik/drik_mag + drij/drij_mag) - dcos_ijk_drj = -drik/drij_mag + drij_dot_drik * drij/drij_mag - dcos_ijk_drk = -drij/drik_mag + drij_dot_drik * drik/drik_mag - - if (present(f)) then -#ifdef _OPENMP - private_f(:,i) = private_f(:,i) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_dri(:) + de_drik*drik_dri(:) + & - de_dcos_ijk * dcos_ijk_dri(:)) - private_f(:,j) = private_f(:,j) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_drj(:) + de_dcos_ijk*dcos_ijk_drj(:)) - private_f(:,k) = private_f(:,k) + w_f*this%eps3(ti,tj,tk)*(de_drik*drik_drk(:) + de_dcos_ijk*dcos_ijk_drk(:)) -#else - f(:,i) = f(:,i) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_dri(:) + de_drik*drik_dri(:) + & - de_dcos_ijk * dcos_ijk_dri(:)) - f(:,j) = f(:,j) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_drj(:) + de_dcos_ijk*dcos_ijk_drj(:)) - f(:,k) = f(:,k) + w_f*this%eps3(ti,tj,tk)*(de_drik*drik_drk(:) + de_dcos_ijk*dcos_ijk_drk(:)) -#endif - end if - - if( present(virial) .or. present(local_virial) ) then - virial_i = w_f*this%eps3(ti,tj,tk)*( & - de_drij*(drij .outer. drij)*drij_mag + de_drik*(drik .outer. drik)*drik_mag + & - de_dcos_ijk * ((drik .outer. drij) - drij_dot_drik * (drij .outer. drij)) + & - de_dcos_ijk * ((drij .outer. drik) - drij_dot_drik * (drik .outer. drik)) ) - - virial_j = w_f*this%eps3(ti,tj,tk)*( & - de_drij*(drij .outer. drij)*drij_mag + & - de_dcos_ijk * ((drik .outer. drij) - drij_dot_drik * (drij .outer. drij)) ) - - virial_k = w_f*this%eps3(ti,tj,tk)*( & - de_drik*(drik .outer. drik)*drik_mag + & - de_dcos_ijk * ((drij .outer. drik) - drij_dot_drik * (drik .outer. drik)) ) - endif - - if (present(virial)) then -#ifdef _OPENMP - private_virial = private_virial - virial_i -#else - virial = virial - virial_i -#endif - end if - if (present(local_virial)) then -#ifdef _OPENMP - !private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i,(/9/)) - private_local_virial(:,j) = private_local_virial(:,j) - reshape(virial_j,(/9/)) - private_local_virial(:,k) = private_local_virial(:,k) - reshape(virial_k,(/9/)) -#else - !local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) - local_virial(:,j) = local_virial(:,j) - reshape(virial_j,(/9/)) - local_virial(:,k) = local_virial(:,k) - reshape(virial_k,(/9/)) -#endif - end if - endif - - end do ! ki - - end do - end do - -#ifdef _OPENMP -!$omp critical - if (present(e)) e = e + private_e - if (present(f)) f = f + private_f - if (present(local_e)) local_e = local_e + private_local_e - if (present(virial)) virial = virial + private_virial - if (present(local_virial)) local_virial = local_virial + private_local_virial -!$omp end critical - - if(allocated(private_f)) deallocate(private_f) - if(allocated(private_local_e)) deallocate(private_local_e) - if(allocated(private_local_virial)) deallocate(private_local_virial) - -!$omp end parallel -#endif - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) call sum_in_place(mpi, f) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(local_virial)) call sum_in_place(mpi, local_virial) - endif - - if (do_rescale_r) then - if (present(f)) f = f*r_scale - end if - - if (do_rescale_E) then - if (present(e)) e = e*E_scale - if (present(local_e)) local_e = local_e*E_scale - if (present(f)) f = f*E_scale - if (present(virial)) virial=virial*E_scale - if (present(local_virial)) local_virial=local_virial*E_scale - end if - - atom_mask_pointer => null() - -end subroutine IPModel_SW_Calc - -function f3(this, rij_i, rik_i, cos_ijk, ti, tj, tk) - type(IPModel_SW), intent(in) :: this - real(dp), intent(in) :: rij_i, rik_i, cos_ijk - integer, intent(in) :: ti, tj, tk - real(dp) :: f3 - - real(dp) :: rij, rik - real(dp), parameter :: one_third = 1.0_dp/3.0_dp - - rij = rij_i/this%sigma(ti,tj) - rik = rik_i/this%sigma(ti,tk) - - if (rij >= this%a(ti,tj) .or. rik >= this%a(ti,tk)) then - f3 = 0.0_dp - return - endif - - f3 = this%lambda(ti,tj,tk)*exp( this%gamma(ti,tj,tk)/(rij-this%a(ti,tj)) + this%gamma(ti,tj,tk)/(rik-this%a(ti,tk)) )* & - (cos_ijk + one_third)**2 - -end function f3 - -subroutine df3_dr(this, rij_i, rik_i, cos_ijk, ti, tj, tk, de_drij, de_drik, de_dcos_ijk) - type(IPModel_SW), intent(in) :: this - real(dp), intent(in) :: rij_i, rik_i, cos_ijk - integer, intent(in) :: ti, tj, tk - real(dp), intent(out) :: de_drij, de_drik, de_dcos_ijk - - real(dp) :: rij, rik, r_scale_ij, r_scale_ik - real(dp) :: expf, cosf - - real(dp), parameter :: one_third = 1.0_dp/3.0_dp - - rij = rij_i/this%sigma(ti,tj) - rik = rik_i/this%sigma(ti,tk) - - if (rij >= this%a(ti,tj) .or. rik >= this%a(ti,tk)) then - de_drij = 0.0_dp - de_drik = 0.0_dp - de_dcos_ijk = 0.0_dp - return - endif - - r_scale_ij = 1.0_dp/this%sigma(ti,tj) - r_scale_ik = 1.0_dp/this%sigma(ti,tk) - - expf = this%lambda(ti,tj,tk)*exp(this%gamma(ti,tj,tk)/(rij - this%a(ti,tj)) + this%gamma(ti,tj,tk)/(rik - this%a(ti,tk))) - cosf = (cos_ijk + one_third) - - de_drij = -expf * this%gamma(ti,tj,tk)/(rij-this%a(ti,tj))**2 * cosf**2 * r_scale_ij - de_drik = -expf * this%gamma(ti,tj,tk)/(rik-this%a(ti,tk))**2 * cosf**2 * r_scale_ik - de_dcos_ijk = expf * 2.0_dp * cosf - -end subroutine df3_dr - - -function f2(this, ri, ti, tj) - type(IPModel_SW), intent(in) :: this - real(dp), intent(in) :: ri - integer, intent(in) :: ti, tj - real(dp) :: f2 - - real(dp) r - - r = ri/this%sigma(ti,tj) - - if (r >= this%a(ti,tj)) then - f2 = 0.0_dp - return - endif - - f2 = this%AA(ti,tj)*(this%BB(ti,tj) * r**(-this%p(ti,tj)) - r**(-this%q(ti,tj))) * exp(1.0_dp/(r-this%a(ti,tj))) - -end function f2 - -function df2_dr(this, ri, ti, tj) - type(IPModel_SW), intent(in) :: this - real(dp), intent(in) :: ri - integer, intent(in) :: ti, tj - real(dp) :: df2_dr - - real(dp) r, dr_dri - real(dp) :: expf, dexpf_dr, powf, dpowf_dr - - r = ri/this%sigma(ti,tj) - - if (r >= this%a(ti,tj)) then - df2_dr = 0.0_dp - return - endif - - dr_dri = 1.0_dp/this%sigma(ti,tj) - - expf = exp(1.0_dp/(r-this%a(ti,tj))) - dexpf_dr = -expf/(r-this%a(ti,tj))**2 - - powf = this%BB(ti,tj)*(r**(-this%p(ti,tj))) - r**(-this%q(ti,tj)) - dpowf_dr = -this%p(ti,tj)*this%BB(ti,tj)*(r**(-this%p(ti,tj)-1)) + this%q(ti,tj)*r**(-this%q(ti,tj)-1) - - df2_dr = this%AA(ti,tj)*(powf*dexpf_dr + dpowf_dr*expf)*dr_dri - -end function df2_dr - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for the input file. -!% First the general parameters and pair terms: -!%> -!%> -!%> -!%> p="0" q="0" a="5.0" sigma="1.0" eps="0.0" /> -!%> p="4" q="0" a="1.25" sigma="2.537884" eps="2.1672" /> -!%> p="4" q="0" a="1.80" sigma="2.0951" eps="2.1675" /> -!% Now the triplet terms: atnum_c is the center atom, neighbours j and k -!%> lambda="21.0" gamma="1.20" eps="2.1675" /> -!%> lambda="21.0" gamma="1.20" eps="2.1675" /> -!%> lambda="21.0" gamma="1.20" eps="2.1675" /> -!%> -!%> lambda="21.0" gamma="1.20" eps="2.1675" /> -!%> lambda="21.0" gamma="1.20" eps="2.1675" /> -!%> lambda="21.0" gamma="1.20" eps="2.1675" /> -!%> -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - integer ti, tj, tk, Zi, Zj, Zk - - if (name == 'SW_params') then ! new SW stanza - call print("startElement_handler SW_params", PRINT_NERD) - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered SW_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) then - call print("SW_params startElement_handler bailing because we already matched our label", PRINT_NERD) - return ! we already found an exact match for this label - end if - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - call print("SW_params startElement_handler found xml label '"//trim(value)//"'", PRINT_NERD) - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - call print("SW_params startElement_handler was passed in label '"//trim(parse_ip%label)//"'", PRINT_NERD) - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - call print("SW_params startElement_handler got label didn't match", PRINT_NERD) - parse_in_ip = .false. - endif - else ! no label passed in - call print("SW_params startElement_handler was not passed in a label", PRINT_NERD) - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call print("SW_params startElement_handler finalising old data, restarting to parse new section", PRINT_NERD) - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, "n_types", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find n_types") - read (value, *) parse_ip%n_types - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%a(parse_ip%n_types,parse_ip%n_types)) - parse_ip%a = 0.0_dp - allocate(parse_ip%AA(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%BB(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%p(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%q(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%sigma(parse_ip%n_types,parse_ip%n_types)) - parse_ip%sigma = 0.0_dp - allocate(parse_ip%eps2(parse_ip%n_types,parse_ip%n_types)) - - allocate(parse_ip%lambda(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%gamma(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%eps3(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "atnum_i", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_i") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_j") - read (value, *) Zj - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "AA", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find AA") - read (value, *) parse_ip%AA(ti,tj) - call QUIP_FoX_get_value(attributes, "BB", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find BB") - read (value, *) parse_ip%BB(ti,tj) - call QUIP_FoX_get_value(attributes, "p", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find p") - read (value, *) parse_ip%p(ti,tj) - call QUIP_FoX_get_value(attributes, "q", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find q") - read (value, *) parse_ip%q(ti,tj) - call QUIP_FoX_get_value(attributes, "a", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find a") - read (value, *) parse_ip%a(ti,tj) - call QUIP_FoX_get_value(attributes, "sigma", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find sigma") - read (value, *) parse_ip%sigma(ti,tj) - call QUIP_FoX_get_value(attributes, "eps", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find eps") - read (value, *) parse_ip%eps2(ti,tj) - - if (ti /= tj) then - parse_ip%AA(tj,ti) = parse_ip%AA(ti,tj) - parse_ip%BB(tj,ti) = parse_ip%BB(ti,tj) - parse_ip%p(tj,ti) = parse_ip%p(ti,tj) - parse_ip%q(tj,ti) = parse_ip%q(ti,tj) - parse_ip%a(tj,ti) = parse_ip%a(ti,tj) - parse_ip%sigma(tj,ti) = parse_ip%sigma(ti,tj) - parse_ip%eps2(tj,ti) = parse_ip%eps2(ti,tj) - endif - - parse_ip%cutoff = maxval(parse_ip%a*parse_ip%sigma) - - elseif (parse_in_ip .and. name == 'per_triplet_data') then - - call QUIP_FoX_get_value(attributes, "atnum_c", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_c") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_j") - read (value, *) Zj - call QUIP_FoX_get_value(attributes, "atnum_k", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_k") - read (value, *) Zk - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - tk = get_type(parse_ip%type_of_atomic_num,Zk) - - call QUIP_FoX_get_value(attributes, "lambda", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find lambda") - read (value, *) parse_ip%lambda(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "gamma", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find gamma") - read (value, *) parse_ip%gamma(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "eps", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find eps") - read (value, *) parse_ip%eps3(ti,tj,tk) - - if (tj /= tk) then - parse_ip%lambda(ti,tk,tj) = parse_ip%lambda(ti,tj,tk) - parse_ip%gamma(ti,tk,tj) = parse_ip%gamma(ti,tj,tk) - parse_ip%eps3(ti,tk,tj) = parse_ip%eps3(ti,tj,tk) - endif - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'SW_params') then - call print("endElement_handler SW_params", PRINT_NERD) - parse_in_ip = .false. - endif - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_SW_read_params_xml(this, param_str) - type(IPModel_SW), intent(inout), target :: this - character(len=*) :: param_str - - type (xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_ip => this - parse_in_ip = .false. - parse_matched_label = .false. - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_SW_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X printing -!% Printing of SW parameters: number of different types, cutoff radius, atomic numbers, ect. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - -subroutine IPModel_SW_Print (this, file) - type(IPModel_SW), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer ti, tj, tk - - call Print("IPModel_SW : Stillinger-Weber", file=file) - call Print("IPModel_SW : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_SW : type "// ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - do tj=1, this%n_types - call Print ("IPModel_SW : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) // & - " " // this%atomic_num(tj), file=file) - call Print ("IPModel_SW : pair " // this%AA(ti,tj) // " " // this%BB(ti,tj) // " " // this%p(ti,tj) // " " // & - this%q(ti,tj) // " " // this%a(ti,tj), file=file) - call Print ("IPModel_SW : " // this%sigma(ti,tj) // " " // this%eps2(ti,tj), file=file) - do tk=1, this%n_types - call Print ("IPModel_SW : triplet interaction ti tj " // ti // " " // tj // " " // tk // & - " Zi Zj Zk " // this%atomic_num(ti) // " " // this%atomic_num(tj) // " " // this%atomic_num(tk), file=file) - call Print ("IPModel_SW : triplet " // this%lambda(ti,tj,tk) // " " // this%gamma(ti,tj,tk) // " " // & - this%eps3(ti,tj,tk), file=file) - end do - end do - call verbosity_pop() - end do - -end subroutine IPModel_SW_Print - -end module IPModel_SW_module diff --git a/src/Potentials/IPModel_SW_VP.f95 b/src/Potentials/IPModel_SW_VP.f95 deleted file mode 100644 index 4939d772be..0000000000 --- a/src/Potentials/IPModel_SW_VP.f95 +++ /dev/null @@ -1,1218 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_SW_VP module -!X -!% Danny potential J ChemPhys 127, 204704(2007) for SiO_2. -!% -!% Only the case of fourfold coordinated silcon and twofold coordinated -!% is considered. (-->Fixed charges). -!% -!% The IPModel_SW_VP object contains all the parameters read -!% from an 'SW_VP_params' XML stanza. -!X -!X Contribution from Anke Butenuth -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_SW_VP_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_NERD, PRINT_ANALYSIS, current_verbosity, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module -use Functions_module -implicit none - -private - -include 'IPModel_interface.h' - -public :: IPModel_SW_VP -type IPModel_SW_VP - integer :: n_types = 0 !% Number of atomic types - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} - - real(dp) :: cutoff = 0.0_dp - - - real(dp), allocatable :: a(:,:), AA(:,:), BB(:,:), p(:,:), q(:,:), sigma(:,:), eps2(:,:), C_0(:,:), C_1(:,:), b(:,:), D_SiO(:,:), C_OOprime(:,:), D_OOprime(:,:) !% IP parameters - real(dp), allocatable :: lambda(:,:,:), d1(:,:,:), d2(:,:,:), gamma1(:,:,:), gamma2(:,:,:), eps3(:,:,:), costheta0(:,:,:) !% IP parameters - - - character(len=STRING_LENGTH) :: label - -end type IPModel_SW_VP - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_SW_VP), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_SW_VP_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_SW_VP_Finalise -end interface Finalise - -interface Print - module procedure IPModel_SW_VP_Print -end interface Print - -interface Calc - module procedure IPModel_SW_VP_Calc -end interface Calc - -contains - -subroutine IPModel_SW_VP_Initialise_str(this, args_str, param_str) - type(IPModel_SW_VP), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy: nb326 $") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_VP_Initialise_str args_str')) then - call system_abort("IPModel_SW_VP_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_SW_VP_read_params_xml(this, param_str) - -end subroutine IPModel_SW_VP_Initialise_str - -subroutine IPModel_SW_VP_Finalise(this) - type(IPModel_SW_VP), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%a)) deallocate(this%a) - if (allocated(this%AA)) deallocate(this%AA) - if (allocated(this%BB)) deallocate(this%BB) - if (allocated(this%p)) deallocate(this%p) - if (allocated(this%q)) deallocate(this%q) - if (allocated(this%sigma)) deallocate(this%sigma) - if (allocated(this%eps2)) deallocate(this%eps2) - if (allocated(this%lambda)) deallocate(this%lambda) - if (allocated(this%gamma1)) deallocate(this%gamma1) - if (allocated(this%gamma2)) deallocate(this%gamma2) - if (allocated(this%eps3)) deallocate(this%eps3) - if (allocated(this%costheta0)) deallocate(this%costheta0) - if (allocated(this%d1)) deallocate(this%d1) - if (allocated(this%d2)) deallocate(this%d2) - if (allocated(this%C_0)) deallocate(this%C_0) - if (allocated(this%C_1)) deallocate(this%C_1) - if (allocated(this%b)) deallocate(this%b) - if (allocated(this%D_SiO)) deallocate(this%D_SiO) - if (allocated(this%C_OOprime)) deallocate(this%C_OOprime) - if (allocated(this%D_OOprime)) deallocate(this%D_OOprime) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_SW_VP_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator. It computes energy, forces and virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_SW_VP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_SW_VP), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), pointer :: w_e(:) - integer i, ji, j, ki, k - real(dp) :: drij(3), drij_mag, drik(3), drik_mag, drij_dot_drik - real(dp) :: w_f - - integer ti, tj, tk - - real(dp) :: drij_dri(3), drij_drj(3), drik_dri(3), drik_drk(3) - real(dp) :: dcos_ijk_dri(3), dcos_ijk_drj(3), dcos_ijk_drk(3) - real(dp) :: virial_i(3,3) - - real(dp) :: de, de_dr, de_drij, de_drik, de_dcos_ijk - real(dp) :: cur_cutoff - - - integer :: n_neigh_i - - type(Dictionary) :: params - logical :: has_atom_mask_name, atom_mask_exclude_all - character(STRING_LENGTH) :: atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - -#ifdef _OPENMP - real(dp) :: private_virial(3,3), private_e - real(dp), allocatable :: private_f(:,:), private_local_e(:), private_local_virial(:,:) -#endif - - INIT_ERROR(error) - - call print("IPModel_SW_VP_Calc starting ", PRINT_ANALYSIS) - if (present(e)) e = 0.0_dp - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_SW_VP_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_SW_VP_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) virial = 0.0_dp - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_GAP_Calc', error) - local_virial = 0.0_dp - endif - - atom_mask_pointer => null() - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of logical property used to mask atoms") - call param_register(params, 'atom_mask_exclude_all', 'F', atom_mask_exclude_all, help_string="If true, exclude contributions made by atoms with atom_mask==.false. on their neighbour with atom_mask==.true., i.e. behave as if excluded atoms were not there at all") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_VP_Calc args_str')) then - RAISE_ERROR("IPModel_SW_VP_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_SW_VP_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - else - atom_mask_pointer => null() - endif - endif - - if (.not.assign_pointer(at,"weight", w_e)) nullify(w_e) - -#ifdef _OPENMP - !$omp parallel default(none) private(i, ji, j, ki, k, drij, drij_mag, drik, drik_mag, drij_dot_drik, w_f, ti, tj, tk, drij_dri, drij_drj, drik_dri, drik_drk, dcos_ijk_dri, dcos_ijk_drj, dcos_ijk_drk, de, de_dr, de_drij, de_drik, de_dcos_ijk, cur_cutoff, private_virial, private_e, private_f, private_local_e, private_local_virial, n_neigh_i, virial_i) shared(this,at,e,local_e,f,virial,local_virial,mpi,atom_mask_pointer,atom_mask_exclude_all,w_e) - - if (present(e)) private_e = 0.0_dp - if (present(local_e)) then - allocate(private_local_e(at%N)) - private_local_e = 0.0_dp - endif - if (present(f)) then - allocate(private_f(3,at%N)) - private_f = 0.0_dp - endif - if (present(virial)) private_virial = 0.0_dp - if (present(local_virial)) then - allocate(private_local_virial(9,at%N)) - private_local_virial = 0.0_dp - endif - -!$omp do -#endif - do i=1, at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_VP_Calc i " // i // " " // n_neighbours(at,i), PRINT_ANALYSIS) - cur_cutoff = maxval(this%a(ti,:)*this%sigma(ti,:)) - n_neigh_i = n_neighbours(at, i) - - - do ji=1, n_neigh_i - j = neighbour(at, i, ji, drij_mag, cosines = drij, max_dist = cur_cutoff) - - if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then - if(.not. atom_mask_pointer(j)) cycle - endif - - if (j <= 0) cycle - if (drij_mag .feq. 0.0_dp) cycle - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (drij_mag/this%sigma(ti,tj) > this%a(ti,tj)) cycle - - - if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_VP_Calc i j " // i // " " // j, PRINT_ANALYSIS) - - if (associated(w_e)) then - w_f = 0.5_dp*(w_e(i)+w_e(j)) ! - else - w_f = 1.0_dp - endif - - if (present(e) .or. present(local_e)) then - ! factor of 0.5 because SW_VP definition goes over each pair only once - - ! select functional form of pair potentials depending on species : oxygen -oxygen - if ((ti .eq. 2) .and. (tj .eq. 2)) then ! - de = 0.5_dp*this%eps2(ti,tj)*f2OO(this, drij_mag, ti, tj) - - elseif ((ti .eq. 2) .and. (tj .eq. 3)) then ! Oxygen Silicon - de = 0.5_dp*this%eps2(ti,tj)*f2SiO(this, drij_mag, ti, tj) - - - elseif ((ti .eq. 3) .and. (tj .eq.2 )) then ! Calls the Silicon-Oxygen function again - de = 0.5_dp*this%eps2(ti,tj)*f2SiO(this, drij_mag, ti, tj) - - elseif ((ti .eq. 3) .and. (tj .eq. 3)) then ! Silicon -Silicon - de = 0.5_dp*this%eps2(ti,tj)*f2SiSi(this, drij_mag, ti, tj) - - else - de= 0.0_dp - endif - - - - if (present(local_e)) then -#ifdef _OPENMP - private_local_e(i) = private_local_e(i) + de -#else - local_e(i) = local_e(i) + de -#endif - endif - if (present(e)) then -#ifdef _OPENMP - private_e = private_e + de*w_f -#else - e = e + de*w_f -#endif - endif - endif - - if (present(f) .or. present(virial) .or. present(local_virial)) then - - - !select pair potentials depending on species : oxygen-oxygen - if ((ti .eq. 2) .and. (tj .eq. 2)) then - de_dr = 0.5_dp*this%eps2(ti,tj)*df2OO_dr(this, drij_mag, ti, tj) - - elseif ((ti .eq. 3) .and. (tj .eq. 2)) then ! oxygen-silicon - de_dr = 0.5_dp*this%eps2(ti,tj)* df2SiO_dr(this, drij_mag, ti, tj) - - elseif ((ti.eq. 2) .and. (tj .eq. 3 )) then ! Calls the silicon-oxygen function again - de_dr = 0.5_dp*this%eps2(ti,tj)* df2SiO_dr(this, drij_mag, ti, tj) - - elseif ((ti .eq. 3 ) .and. (tj .eq. 3)) then ! silicon-silicon - de_dr = 0.5_dp*this%eps2(ti,tj)*df2SiSi_dr(this, drij_mag, ti, tj) - else - de_dr = 0.0_dp - endif - - - - - if (present(f)) then -#ifdef _OPENMP - private_f(:,i) = private_f(:,i) + de_dr*w_f*drij - private_f(:,j) = private_f(:,j) - de_dr*w_f*drij -#else - f(:,i) = f(:,i) + de_dr*w_f*drij - f(:,j) = f(:,j) - de_dr*w_f*drij -#endif - endif - - if(present(virial) .or. present(local_virial)) virial_i = de_dr*w_f*(drij .outer. drij)*drij_mag - - - - if (present(virial)) then -#ifdef _OPENMP - private_virial = private_virial - virial_i -#else - virial = virial - virial_i -#endif - endif - if (present(local_virial)) then -#ifdef _OPENMP - private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i, (/9/)) -#else - local_virial(:,i) = local_virial(:,i) - reshape(virial_i, (/9/)) -#endif - endif - - endif - - if (associated(w_e)) then - w_f = w_e(i) - else - w_f = 1.0_dp - endif - enddo ! closes j loop - enddo ! closes i loop - - ! New loop for three body terms, because (see parameters/ip.params.SW_VP.xml) cutoff for three body terms is in SiSiO case larger then the SiSi cutoff - - !$omp do - do i=1, at%N - - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) ! - - - ! if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_VP_Calc i " // i // " " // n_neighbours(at,i), PRINT_ANALYSIS) - cur_cutoff = maxval(this%a(ti,:)*this%sigma(ti,:)) - n_neigh_i = n_neighbours(at, i) - - - do ji=1, n_neigh_i - j = neighbour(at, i, ji, drij_mag, cosines = drij, max_dist = cur_cutoff) - - if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then - if(.not. atom_mask_pointer(j)) cycle - endif - - if (j <= 0) cycle - if (drij_mag .feq. 0.0_dp) cycle - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - - - do ki=1, n_neigh_i - - if (ki <= ji) cycle - - k = neighbour(at, i, ki, drik_mag, cosines = drik, max_dist=cur_cutoff) - - if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then - if(.not. atom_mask_pointer(k)) cycle - endif - - if (k <= 0) cycle - if (drik_mag .feq. 0.0_dp) cycle - - tk = get_type(this%type_of_atomic_num, at%Z(k)) - if (drik_mag > this%d2(ti, tj, tk)) cycle - if (drij_mag > this%d1(ti, tj, tk)) cycle - - drij_dot_drik = sum(drij*drik) - if (present(e) .or. present(local_e)) then - de = this%eps3(ti,tj,tk)*f3(this, drij_mag, drik_mag, drij_dot_drik, ti, tj, tk) - - - if (present(local_e)) then -#ifdef _OPENMP - private_local_e(i) = private_local_e(i) + de -#else - local_e(i) = local_e(i) + de -#endif - endif - if (present(e)) then -#ifdef _OPENMP - private_e = private_e + de*w_f -#else - e = e + de*w_f -#endif - endif - endif - if (present(f) .or. present(virial)) then - call df3_dr(this, drij_mag, drik_mag, drij_dot_drik, ti, tj, tk, de_drij, de_drik, de_dcos_ijk) - drij_dri = drij - drij_drj = -drij !grad.|vec(r_i) -vec(r_j)|= -( vec(r_i) -vec(r_j))/|vec(r_i) -vec(r_j)| = -drij - drik_dri = drik - drik_drk = -drik - -! dcos_ijk = drij_dot_drik -! (ri_x - rj_x)*(ri_x - rk_x) + (ri_y - rj_y)*(ri_y-rk_y) / (rij rik) -! -! d/dri -! -! ((rij rik)(rij_x + rik_x) - (rij . rik)(rij rik_x / rik + rik rij_x/rij)) / (rij rik)^2 -! -! rij rik ( rij_x + rik_x) - (rij.rik)(rij rik_x / rik + rik rij_x/rij) -! --------------------------------------------------------------------- -! rij^2 rik^2 -! -! rij_x + rik_x cos_ijk (rij rik_x / rik + rik rij_x /rij) -! ------------- - ------------------------------------------ -! rij rik rij rik -! -! rij_x + rik_x -! ------------- - cos_ijk (rik_x / rik^2 + rij_x / rij^2) -! rij rik -! -! -! rhatij_x/rik + rhatik_x/rij - cos_ijk(rhatik_x/rik + rhatij_x/rij) -! -! -! d/drj -! -! ((rij rik)(-rik_x) - (rij.rik)(rik (-rij_x)/rij)) / (rij rik)^2 -! -! -rik_x (rij.rik) ( rik rij_x/rij) -! ------- + --------------------------- -! rij rik rij^2 rik^2 -! -! -rhatik_x/rij + cos_ijk rhatij_x/rij -! -! d/drij -! -! (ri_x - rj_x)*(ri_x - rk_x) + (ri_y - rj_y)*(ri_y-rk_y) / (rij rik) -! -! (rij rik) rik_x - (rij . rik) (rij_x/rij rik) -! --------------------------------------------- -! (rij rik)^2 -! -! rik_x (rij.rik) rij_x -! ------ - --------------- -! rij rik rij^3 rik -! -! rhatik_x (rhatij . rhatik) rhatij_x -! -------- - ------------------------ -! rij rij -! -! rhatik_x cos_ijk * rhatij_x -! -------- - ------------------ -! rij rij - - dcos_ijk_dri = drij/drik_mag + drik/drij_mag - drij_dot_drik * (drik/drik_mag + drij/drij_mag) - dcos_ijk_drj = -drik/drij_mag + drij_dot_drik * drij/drij_mag - dcos_ijk_drk = -drij/drik_mag + drij_dot_drik * drik/drik_mag - - - - - if (present(f)) then -#ifdef _OPENMP - private_f(:,i) = private_f(:,i) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_dri(:) + de_drik*drik_dri(:) + & - de_dcos_ijk * dcos_ijk_dri(:)) - private_f(:,j) = private_f(:,j) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_drj(:) + de_dcos_ijk*dcos_ijk_drj(:)) - private_f(:,k) = private_f(:,k) + w_f*this%eps3(ti,tj,tk)*(de_drik*drik_drk(:) + de_dcos_ijk*dcos_ijk_drk(:)) -#else - f(:,i) = f(:,i) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_dri(:) + de_drik*drik_dri(:) + & - de_dcos_ijk * dcos_ijk_dri(:)) - f(:,j) = f(:,j) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_drj(:) + de_dcos_ijk*dcos_ijk_drj(:)) - f(:,k) = f(:,k) + w_f*this%eps3(ti,tj,tk)*(de_drik*drik_drk(:) + de_dcos_ijk*dcos_ijk_drk(:)) -#endif - end if - - if( present(virial) .or. present(local_virial) ) virial_i = & - w_f*this%eps3(ti,tj,tk)*( & - de_drij*(drij .outer. drij)*drij_mag + de_drik*(drik .outer. drik)*drik_mag + & - de_dcos_ijk * ((drik .outer. drij) - drij_dot_drik * (drij .outer. drij)) + & - de_dcos_ijk * ((drij .outer. drik) - drij_dot_drik * (drik .outer. drik)) ) - - if (present(virial)) then -#ifdef _OPENMP - private_virial = private_virial - virial_i -#else - virial = virial - virial_i -#endif - end if - if (present(local_virial)) then -#ifdef _OPENMP - private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i,(/9/)) -#else - local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) -#endif - end if - endif - - end do - - end do - end do - -#ifdef _OPENMP -!$omp critical - if (present(e)) e = e + private_e - if (present(f)) f = f + private_f - if (present(local_e)) local_e = local_e + private_local_e - if (present(virial)) virial = virial + private_virial - if (present(local_virial)) local_virial = local_virial + private_local_virial -!$omp end critical - - if(allocated(private_f)) deallocate(private_f) - if(allocated(private_local_e)) deallocate(private_local_e) - if(allocated(private_local_virial)) deallocate(private_local_virial) - -!$omp end parallel -#endif - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) call sum_in_place(mpi, f) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(local_virial)) call sum_in_place(mpi, local_virial) - endif - -end subroutine IPModel_SW_VP_Calc - - - - -function f3(this, rij_i, rik_i, cos_ijk, ti, tj, tk) - type(IPModel_SW_VP), intent(in) :: this - real(dp), intent(in) :: rij_i, rik_i, cos_ijk - integer, intent(in) :: ti, tj, tk - real(dp) :: f3 - - real(dp) :: rij, rik - !We give all cosines as parameters from xml file - - rij = rij_i - rik = rik_i - - if (rij_i >= this%d1(ti,tj,tk) .or. rik_i >= this%d2(ti,tj,tk)) then - f3 = 0.0_dp - return - endif - - f3 = this%lambda(ti,tj,tk)*exp( this%gamma1(ti,tj,tk)/(rij-this%d1(ti,tj,tk)) + this%gamma2(ti,tj,tk)/(rik-this%d2(ti,tj,tk)) )* & - (cos_ijk - this%costheta0(ti,tj,tk))**2 - - - -end function f3 - -subroutine df3_dr(this, rij_i, rik_i, cos_ijk, ti, tj, tk, de_drij, de_drik, de_dcos_ijk) - type(IPModel_SW_VP), intent(in) :: this - real(dp), intent(in) :: rij_i, rik_i, cos_ijk - integer, intent(in) :: ti, tj, tk - real(dp), intent(out) :: de_drij, de_drik, de_dcos_ijk - - real(dp) :: rij, rik - real(dp) :: expf, cosf - - - rij = rij_i - rik = rik_i - - if (rij_i >= this%d1(ti,tj,tk) .or. rik_i >= this%d2(ti,tj,tk)) then ! Anke_new - de_drij = 0.0_dp - de_drik = 0.0_dp - de_dcos_ijk = 0.0_dp - return - endif - - - expf = this%lambda(ti,tj,tk)*exp(this%gamma1(ti,tj,tk)/(rij - this%d1(ti,tj,tk)) + this%gamma2(ti,tj,tk)/(rik - this%d2(ti,tj,tk))) - cosf = (cos_ijk -this%costheta0(ti,tj,tk)) - - de_drij = -expf * this%gamma1(ti,tj,tk)/(rij-this%d1(ti,tj,tk))**2 * cosf**2 - de_drik = -expf * this%gamma2(ti,tj,tk)/(rik-this%d2(ti,tj,tk))**2 * cosf**2 - de_dcos_ijk = expf * 2.0_dp * cosf - - - - - -end subroutine df3_dr - - - - -!************Begin: Anke modification********** - - - - -function f2SiSi(this, ri, ti, tj) - type(IPModel_SW_VP), intent(in) :: this - real(dp), intent(in) :: ri - integer, intent(in) :: ti, tj - - real(dp) :: f2SiSi - - -! if (ri >= this%a(ti,tj)) then -! f2SiSi = 0.0_dp -! return -! endif - -! f2SiSi = this%AA(ti,tj)*(1.0_dp+3.2_dp*qi*qj)*faqj*faqi*(this%BB(ti,tj) * r**(-this%p(ti,tj)) - r**(-this%q(ti,tj))) * exp(1.0_dp/(r-this%a(ti,tj))) -! for now, fixed coordination. If Si is fourfold coordinated, in Si0_2 is faq(Si) = 0. -! -! Potential has to be modified if one wants Si-Si interactions as well - - f2SiSi = 0.0_dp - -end function f2SiSi - -function df2SiSi_dr(this, ri, ti, tj) - type(IPModel_SW_VP), intent(in) :: this - real(dp), intent(in) :: ri - integer, intent(in) :: ti, tj - real(dp) :: df2SiSi_dr - - real(dp) :: expf, dexpf_dr, powf, dpowf_dr - - - ! if (r >= this%a(ti,tj)) then - ! df2SiSi_dr = 0.0_dp - - ! return - ! endif - - - ! expf = exp(this%sigma(ti,tj)/(r-this%a(ti,tj))) - ! dexpf_dr = -expf*this%sigma(ti,tj)/(r-this%a(ti,tj))**2 - - ! powf = this%BB(ti,tj)*(r**(-this%p(ti,tj))) - r**(-this%q(ti,tj)) - ! dpowf_dr = -this%p(ti,tj)*this%BB(ti,tj)*(r**(-this%p(ti,tj)-1)) + this%q(ti,tj)*r**(-this%q(ti,tj)-1) - - df2SiSi_dr = 0.0_dp - -end function df2SiSi_dr - - -function f2SiO(this, r, ti, tj) - type(IPModel_SW_VP), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: f2SiO - - real(dp) :: expf - real(dp) :: f2SiO_at_cutoff, df2SiO_dr_at_cutoff - -! Cutoff sigma*a for longrange non-coulombic terms - - if (r >= (this%sigma(ti,tj)*this%a(ti,tj))) then - f2SiO = 0.0_dp - return - endif - - - - expf = exp(-r/this%a(ti,tj)) - f2SiO_at_cutoff = (this%C_0(ti,tj)-this%C_1(ti,tj)*1.6_dp)*(this%sigma(ti,tj)*this%a(ti,tj))**(-9.0_dp)-this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj))**(-4.0_dp)*exp(-this%sigma(ti,tj)) - df2SiO_dr_at_cutoff= -9.0_dp*(this%C_0(ti, tj)-this%C_1(ti,tj)*1.6_dp)*(this%sigma(ti,tj)*this%a(ti,tj)) **(-10.0_dp) & - + 4.0_dp*this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj)) **(-5.0_dp)* exp(-this%sigma(ti,tj)) & - + this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-4.0_dp)*exp(-this%sigma(ti,tj))/this%a(ti,tj) - - - - f2SiO = (this%C_0(ti,tj)-this%C_1(ti,tj)*1.6_dp)*r**(-9.0_dp) - this%D_SiO(ti,tj)*r**(-4.0_dp)*expf - f2SiO_at_cutoff - (r - this%sigma(ti,tj)*this%a(ti,tj))*df2SiO_dr_at_cutoff - - - -end function f2SiO - - - -function df2SiO_dr(this, r, ti, tj) - type(IPModel_SW_VP), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: df2SiO_dr - real(dp) :: expf - real(dp) :: df2SiO_dr_at_cutoff - - if (r >= (this%sigma(ti,tj)*this%a(ti,tj))) then - df2SiO_dr = 0.0_dp - return - endif - - - - expf = exp(-r/this%a(ti,tj)) - df2SiO_dr_at_cutoff= -9.0_dp*(this%C_0(ti, tj)-this%C_1(ti,tj)*1.6_dp)*(this%sigma(ti,tj)*this%a(ti,tj)) **(-10.0_dp) & - + 4.0_dp*this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj)) **(-5.0_dp)* exp(-this%sigma(ti,tj)) & - + this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-4.0_dp)*exp(-this%sigma(ti,tj))/this%a(ti,tj) - - - df2SiO_dr = -9.0_dp*(this%C_0(ti, tj)-this%C_1(ti,tj)*1.6_dp)*r**(-10.0_dp) + 4.0_dp*this%D_SiO(ti,tj)*r**(-5.0_dp)*expf + this%D_SiO(ti,tj)*r**(-4.0_dp)*expf/this%a(ti,tj) - df2SiO_dr_at_cutoff - - - -end function df2SiO_dr - - -function f2OO(this, r, ti, tj) - type(IPModel_SW_VP), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: f2OO - real(dp) :: expf - real(dp) :: f2OO_at_cutoff, df2OO_dr_at_cutoff - - if (r >= (this%sigma(ti,tj)*this%a(ti,tj))) then - f2OO = 0.0_dp - return - endif - - - expf = exp(-r/this%a(ti,tj)) - f2OO_at_cutoff= (this%C_OOprime(ti, tj))*(this%sigma(ti,tj)*this%a(ti,tj))**(-7.0_dp) - this%D_OOprime(ti, tj)*(this%sigma(ti,tj)*this%a(ti,tj))**(-4.0_dp)*exp(-this%sigma(ti,tj)) - ! Cutoff is at r = sigma*a, thus can be altered via parameter list - df2OO_dr_at_cutoff= -7.0_dp*(this%C_OOprime(ti,tj))*(this%sigma(ti,tj)*this%a(ti,tj) )**(-8.0_dp) + 4.0_dp*this%D_OOprime(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-5.0_dp)* exp(-this%sigma(ti,tj)) & - + this%D_OOprime(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-4.0_dp)*exp(-this%sigma(ti,tj))/this%a(ti,tj) - - f2OO = (this%C_OOprime(ti, tj))*r**(-7.0_dp) - this%D_OOprime(ti, tj)*r**(-4.0_dp)*expf - f2OO_at_cutoff & - - (r - this%sigma(ti,tj)*this%a(ti,tj))*df2OO_dr_at_cutoff - - -end function f2OO - - -function df2OO_dr(this, r, ti, tj) - type(IPModel_SW_VP), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: df2OO_dr, df2OO_dr_at_cutoff - - real(dp) :: expf - - if (r >= (this%sigma(ti,tj)*this%a(ti,tj))) then - df2OO_dr = 0.0_dp - return - endif - - - expf = exp(-r/this%a(ti,tj)) - - df2OO_dr_at_cutoff = -7.0_dp*(this%C_OOprime(ti,tj))*(this%sigma(ti,tj)*this%a(ti,tj) )**(-8.0_dp) + 4.0_dp*this%D_OOprime(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-5.0_dp)* exp(-this%sigma(ti,tj)) & - + this%D_OOprime(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-4.0_dp)*exp(-this%sigma(ti,tj))/this%a(ti,tj) - - df2OO_dr = -7.0_dp*(this%C_OOprime(ti,tj))*r**(-8.0_dp) + 4.0_dp*this%D_OOprime(ti,tj)*r**(-5.0_dp)*expf + this%D_OOprime(ti,tj)*r**(-4.0_dp)*expf/this%a(ti,tj)- df2OO_dr_at_cutoff - - - -end function df2OO_dr - - - - -!*************End: Anke modification********** - - - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for the input file. -!% -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> -!%> Danny potential J ChemPhys 127, 204704(2007).The potential has to be called as a pot_init_args='Sum init_args_pot1={IP SW_VP} init_args_pot2={IP Coulomb}' -!%> -!%> -!%> -!%> p="0" q="0" a="1.0" sigma="1.0" eps="0.0" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="0" D_OOprime="0" /> -!%> p="0" q="0" a="1.0" sigma="1.0" eps="0.0" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="0" D_OOprime="0" /> -!%> p="4" q="0" a="1.25" sigma="2.537884" eps="0.000" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="0" D_OOprime="0"/> -!%> p="0" q="0" a="4.43" sigma="1.24" eps="14.39" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="51.692" D_OOprime="1.536"/> -!%> p="0" q="0" a="4.43" sigma="1.24" eps="14.39" C_0="14.871" C_1="2.178" D_SiO="3.072" C_OOprime="0.0" D_OOprime="0.0"/> -!%> p="4" q="0" a="1.80" sigma="2.0951" eps="0" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="0.0" D_OOprime="0.0"/> -!%> -!%> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="3.46" gamma1="0.48" gamma2="0.48" d1="1.24" d2="1.24" costheta0="-0.5373" eps="0.0" /> -!%> lambda="3.46" gamma1="0.48" gamma2="0.48" d1="1.24" d2="1.24" costheta0="-0.5373" eps="0.0" /> -!%> lambda="0.521" gamma1="1" gamma2="1" d1="2.6" d2="2.6" costheta0="-0.5373" eps="14.39" /> -!%> lambda="3.46" gamma1="0.48" gamma2="0.48" d1="1.24" d2="1.24" costheta0="-0.5373" eps="0.0" /> -!%> lambda="3.46" gamma1="0.48" gamma2="0.48" d1="1.24" d2="1.24" costheta0="-0.5373" eps="0.0" /> -!%> lambda="1.4" gamma1="1" gamma2="1" d1="2.6" d2="2.6" costheta0="-0.777" eps="14.39" /> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> -!%> lambda="0.350" gamma1="1" gamma2="1" d1="2.6" d2="2.6" costheta0="-0.333" eps="14.39" /> -!%> -!%> lambda="3.164" gamma1="4.06" gamma2="0.52" d1="3.981" d2="2.933" costheta0="-0.333" eps="14.39" /> -!%> lambda="3.164" gamma1="2.51" gamma2="2.51" d1="3.771" d2="3.771" costheta0="-0.333" eps="14.39" /> -!%> -!%> -!%> -!%> -!%> -!%> -!% -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - integer ti, tj, tk, Zi, Zj, Zk - - if (name == 'SW_VP_params') then ! new SW_VP stanza - call print("startElement_handler SW_VP_params", PRINT_NERD) - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered SW_VP_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) then - call print("SW_VP_params startElement_handler bailing because we already matched our label", PRINT_NERD) - return ! we already found an exact match for this label - end if - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - call print("SW_VP_params startElement_handler found xml label '"//trim(value)//"'", PRINT_NERD) - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - call print("SW_VP_params startElement_handler was passed in label '"//trim(parse_ip%label)//"'", PRINT_NERD) - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - call print("SW_VP_params startElement_handler got label didn't match", PRINT_NERD) - parse_in_ip = .false. - endif - else ! no label passed in - call print("SW_VP_params startElement_handler was not passed in a label", PRINT_NERD) - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call print("SW_VP_params startElement_handler finalising old data, restarting to parse new section", PRINT_NERD) - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, "n_types", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find n_types") - read (value, *) parse_ip%n_types - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%a(parse_ip%n_types,parse_ip%n_types)) - parse_ip%a = 0.0_dp - allocate(parse_ip%AA(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%BB(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%p(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%q(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%sigma(parse_ip%n_types,parse_ip%n_types)) - parse_ip%sigma = 0.0_dp - allocate(parse_ip%eps2(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%C_0(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%C_1(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%D_SiO(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%C_OOprime(parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%D_OOprime(parse_ip%n_types,parse_ip%n_types)) - - allocate(parse_ip%lambda(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%gamma1(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%gamma2(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%eps3(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%d1(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%d2(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - allocate(parse_ip%costheta0(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "atnum_i", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_i") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_j") - read (value, *) Zj - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "AA", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find AA") - read (value, *) parse_ip%AA(ti,tj) - call QUIP_FoX_get_value(attributes, "BB", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find BB") - read (value, *) parse_ip%BB(ti,tj) - call QUIP_FoX_get_value(attributes, "p", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find p") - read (value, *) parse_ip%p(ti,tj) - call QUIP_FoX_get_value(attributes, "q", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find q") - read (value, *) parse_ip%q(ti,tj) - call QUIP_FoX_get_value(attributes, "a", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find a") - read (value, *) parse_ip%a(ti,tj) - call QUIP_FoX_get_value(attributes, "sigma", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find sigma") - read (value, *) parse_ip%sigma(ti,tj) - call QUIP_FoX_get_value(attributes, "eps", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find eps") - read (value, *) parse_ip%eps2(ti,tj) - call QUIP_FoX_get_value(attributes, "C_0", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find C_0") - read (value, *) parse_ip%C_0(ti,tj) - call QUIP_FoX_get_value(attributes, "C_1", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find C_1") - read (value, *) parse_ip%C_1(ti,tj) - call QUIP_FoX_get_value(attributes, "D_SiO", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find D_SiO") - read (value, *) parse_ip%D_SiO(ti,tj) - call QUIP_FoX_get_value(attributes, "C_OOprime", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find C_OOprime") - read (value, *) parse_ip%C_OOprime(ti,tj) - call QUIP_FoX_get_value(attributes, "D_OOprime", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find D_OOprime") - read (value, *) parse_ip%D_OOprime(ti,tj) - - if (ti /= tj) then - parse_ip%AA(tj,ti) = parse_ip%AA(ti,tj) - parse_ip%BB(tj,ti) = parse_ip%BB(ti,tj) - parse_ip%p(tj,ti) = parse_ip%p(ti,tj) - parse_ip%q(tj,ti) = parse_ip%q(ti,tj) - parse_ip%a(tj,ti) = parse_ip%a(ti,tj) - parse_ip%sigma(tj,ti) = parse_ip%sigma(ti,tj) - parse_ip%eps2(tj,ti) = parse_ip%eps2(ti,tj) - parse_ip%C_0(tj,ti) = parse_ip%C_0(ti,tj) - parse_ip%C_1(tj,ti) = parse_ip%C_1(ti,tj) - parse_ip%D_SiO(tj,ti) = parse_ip%D_SiO(ti,tj) - parse_ip%C_OOprime(tj,ti) = parse_ip%C_OOprime(ti,tj) - parse_ip%D_OOprime(tj,ti) = parse_ip%D_OOprime(ti,tj) - endif - - parse_ip%cutoff = maxval(parse_ip%a*parse_ip%sigma) - - elseif (parse_in_ip .and. name == 'per_triplet_data') then - - call QUIP_FoX_get_value(attributes, "atnum_c", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_c") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_j") - read (value, *) Zj - call QUIP_FoX_get_value(attributes, "atnum_k", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_k") - read (value, *) Zk - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - tk = get_type(parse_ip%type_of_atomic_num,Zk) - - call QUIP_FoX_get_value(attributes, "lambda", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find lambda") - read (value, *) parse_ip%lambda(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "gamma1", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find gamma1") - read (value, *) parse_ip%gamma1(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "gamma2", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find gamma2") - read (value, *) parse_ip%gamma2(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "d1", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find d1") - read (value, *) parse_ip%d1(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "d2", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find d2") - read (value, *) parse_ip%d2(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "costheta0", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find costheta0") - read (value, *) parse_ip%costheta0(ti,tj,tk) - call QUIP_FoX_get_value(attributes, "eps", value, status) - if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find eps") - read (value, *) parse_ip%eps3(ti,tj,tk) - - - if (tj /= tk) then - parse_ip%lambda(ti,tk,tj) = parse_ip%lambda(ti,tj,tk) - parse_ip%gamma1(ti,tk,tj) = parse_ip%gamma2(ti,tj,tk) ! ti is central atom for tj /=tk, the legs change and hence gamma1 and gamma2 interchange - parse_ip%gamma2(ti,tk,tj) = parse_ip%gamma1(ti,tj,tk) ! - parse_ip%d1(ti,tk,tj) = parse_ip%d2(ti,tj,tk) ! ti is central atom for tj /=tk, the legs change and hence d1 and d2 interchange - parse_ip%d2(ti,tk,tj) = parse_ip%d1(ti,tj,tk) ! - parse_ip%eps3(ti,tk,tj) = parse_ip%eps3(ti,tj,tk) - parse_ip%costheta0(ti,tk,tj) = parse_ip%costheta0(ti,tj,tk) - endif - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'SW_VP_params') then - call print("endElement_handler SW_VP_params", PRINT_NERD) - parse_in_ip = .false. - endif - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_SW_VP_read_params_xml(this, param_str) - type(IPModel_SW_VP), intent(inout), target :: this - character(len=*) :: param_str - - type (xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_ip => this - parse_in_ip = .false. - parse_matched_label = .false. - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_SW_VP_read_params_xml parsed file, but n_types = 0") - endif - - end subroutine IPModel_SW_VP_read_params_xml - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X printing -!% Printing of SW_VP parameters: number of different types, cutoff radius, atomic numbers, ect. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - -subroutine IPModel_SW_VP_Print (this, file) - type(IPModel_SW_VP), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer ti, tj, tk - - call Print("IPModel_SW_VP : Combined Stillinger-Weber/Vashishta potential", file=file) - call Print("IPModel_SW_VP : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_SW_VP : type "// ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - do tj=1, this%n_types - call Print ("IPModel_SW_VP : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) // & - " " // this%atomic_num(tj), file=file) - call Print ("IPModel_SW_VP : pair " // this%AA(ti,tj) // " " // this%BB(ti,tj) // " " // this%p(ti,tj) // " " // & - this%q(ti,tj) // " " // this%a(ti,tj), file=file) - call Print ("IPModel_SW_VP : " // this%sigma(ti,tj) // " " // this%eps2(ti,tj), file=file) - do tk=1, this%n_types - call Print ("IPModel_SW_VP : triplet interaction ti tj " // ti // " " // tj // " " // tk // & - " Zi Zj Zk " // this%atomic_num(ti) // " " // this%atomic_num(tj) // " " // this%atomic_num(tk), file=file) - call Print ("IPModel_SW_VP : triplet " // this%lambda(ti,tj,tk) // " " // this%gamma1(ti,tj,tk) // " " // & - this%eps3(ti,tj,tk), file=file) - end do - end do - call verbosity_pop() - end do - -end subroutine IPModel_SW_VP_Print - -end module IPModel_SW_VP_module diff --git a/src/Potentials/IPModel_Si_MEAM.f95 b/src/Potentials/IPModel_Si_MEAM.f95 deleted file mode 100644 index e3fe783d71..0000000000 --- a/src/Potentials/IPModel_Si_MEAM.f95 +++ /dev/null @@ -1,714 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Si_MEAM module -!X -!% Module for the Modified Embedded Atom Method potential for Si -!% The IPModel_Si_MEAM object contains all the parameters read -!% from an 'Si_MEAN_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! -#include "error.inc" - -module IPModel_Si_MEAM_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use spline_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - - -implicit none -private - -type IPModel_Si_MEAM - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - - type(spline), dimension(:,:), allocatable :: phi - type(spline), dimension(:,:), allocatable :: rho - type(spline), dimension(:,:), allocatable :: f - type(spline), dimension(:), allocatable :: U - type(spline), dimension(:,:,:), allocatable :: g - - real(dp), dimension(:,:), allocatable :: r_cut_phi - real(dp), dimension(:,:), allocatable :: r_cut_rho - real(dp), dimension(:,:), allocatable :: r_cut_f - - character(len=STRING_LENGTH) :: label -endtype IPModel_Si_MEAM - -interface Initialise - module procedure IPModel_Si_MEAM_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Si_MEAM_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Si_MEAM_Print -end interface Print - -interface Calc - module procedure IPModel_Si_MEAM_Calc -end interface Calc - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Si_MEAM), private, pointer :: parse_ip -integer :: parse_cur_type_i, parse_cur_type_j, parse_cur_type_k, parse_cur_point, n_spline - -real(dp) :: yp1, ypn -real(dp), dimension(:), allocatable :: spline_x, spline_y -character(len=100) :: spline_function - -public :: IPModel_Si_MEAM, Initialise, Finalise, Print, Calc - -contains - -subroutine IPModel_Si_MEAM_Initialise_str(this, args_str, param_str) - type(IPModel_Si_MEAM), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Si_MEAM_Initialise_str args_str')) then - call system_abort("IPModel_Si_MEAM_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Si_MEAM_read_params_xml(this, param_str) - -end subroutine IPModel_Si_MEAM_Initialise_str - -subroutine IPModel_Si_MEAM_Finalise(this) - type(IPModel_Si_MEAM), intent(inout) :: this - - integer :: ti, tj, tk - - do ti=1, this%n_types - call finalise(this%U(ti)) - do tj=1, this%n_types - call finalise(this%phi(ti,tj)) - call finalise(this%rho(ti,tj)) - call finalise(this%f(ti,tj)) - do tk=1, this%n_types - call finalise(this%g(ti,tj,tk)) - enddo - end do - end do - - if(allocated(this%phi)) deallocate(this%phi) - if(allocated(this%rho)) deallocate(this%rho) - if(allocated(this%f)) deallocate(this%f) - if(allocated(this%U)) deallocate(this%U) - if(allocated(this%g)) deallocate(this%g) - if(allocated(this%atomic_num)) deallocate(this%atomic_num) - if(allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if(allocated(this%r_cut_phi)) deallocate(this%r_cut_phi) - if(allocated(this%r_cut_rho)) deallocate(this%r_cut_rho) - if(allocated(this%r_cut_f)) deallocate(this%r_cut_f) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Si_MEAM_Finalise - -subroutine IPModel_Si_MEAM_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Si_MEAM), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out), optional :: e !% \texttt{e} = System total energy - real(dp), dimension(:), intent(out), optional :: local_e !% \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), dimension(3,3), intent(out), optional :: virial !% Virial - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - !local - integer :: i, j, k, n, nn, ti, tj, tk - - real(dp) :: r_ij, r_ik, n_i, f_ij, f_ik, theta_jik, g_jik, U_i, phi_ij, & - & dphi_ij, df_ij, df_ik, dg_jik, dU_i, drho_ij - real(dp), dimension(3) :: u_ij, u_ik, dn_i, dn_j, dn_i_dr_ij, diff_ij, diff_ik - real(dp), dimension(3,3) :: dn_i_drij_outer_rij - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Si_MEAM_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Si_MEAM_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Si_MEAM_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_Si_MEAM_Calc: local_virial calculation requested but not supported yet.", error) - endif - - atom_mask_pointer => null() - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of logical property used to mask atoms") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Si_MEAM_Calc args_str')) then - RAISE_ERROR("IPModel_Si_MEAM_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_SW_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - else - atom_mask_pointer => null() - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_Si_MEAM_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - endif - - !Loop over atoms - do i = 1, at%N - - if (present(mpi)) then - if(mpi%active) then - if(mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - n_i = 0.0_dp - dn_i = 0.0_dp - dn_i_drij_outer_rij = 0.0_dp - !Loop over neighbours - do n = 1, n_neighbours(at,i) - - j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, diff=diff_ij) ! nth neighbour of atom i - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if( r_ij < this%r_cut_phi(ti,tj) ) then - if(present(local_e) .or. present(e)) phi_ij = spline_value(this%phi(ti,tj),r_ij) - if(present(local_e)) local_e(i) = local_e(i) + phi_ij*0.5_dp - if(present(e)) e = e + phi_ij*0.5_dp - - if(present(f) .or. present(virial) ) dphi_ij = spline_deriv(this%phi(ti,tj),r_ij) - if(present(f)) then - f(:,i) = f(:,i) + 0.5_dp*dphi_ij*u_ij - f(:,j) = f(:,j) - 0.5_dp*dphi_ij*u_ij - endif - if(present(virial)) virial = virial - 0.5_dp * dphi_ij*(u_ij .outer. u_ij)*r_ij - endif - - if( (r_ij >= this%r_cut_rho(ti,tj)).or.(r_ij >= this%r_cut_f(ti,tj)) ) cycle - - n_i = n_i + spline_value(this%rho(ti,tj),r_ij) - if(present(f) .or. present(virial) ) then - dn_i_dr_ij = spline_deriv(this%rho(ti,tj),r_ij)*u_ij - if(present(f)) dn_i = dn_i + dn_i_dr_ij - if(present(virial)) dn_i_drij_outer_rij = dn_i_drij_outer_rij + (dn_i_dr_ij .outer. u_ij) * r_ij - endif - - f_ij = spline_value(this%f(ti,tj),r_ij) - if(present(f) .or. present(virial)) df_ij = spline_deriv(this%f(ti,tj),r_ij) - - do nn = 1, n_neighbours(at,i) - - k = neighbour(at, i, nn, distance=r_ik, cosines=u_ik, diff=diff_ik) - tk = get_type(this%type_of_atomic_num, at%Z(k)) - - !if( j>=k ) cycle - if( norm(diff_ij-diff_ik) .feq. 0.0_dp ) cycle - if( r_ik >= this%r_cut_f(ti,tk) ) cycle - - theta_jik = dot_product(u_ij,u_ik) !cosine( at, i, j, k ) - - f_ik = spline_value(this%f(ti,tk),r_ik) - if(present(f) .or. present(virial)) df_ik = spline_deriv(this%f(ti,tk),r_ik) - - g_jik = spline_value(this%g(ti,tj,tk),theta_jik) - if(present(f) .or. present(virial)) dg_jik = spline_deriv(this%g(ti,tj,tk),theta_jik) - - n_i = n_i + 0.5_dp * f_ij * f_ik * g_jik - - if( present(f) ) & - & dn_i = dn_i + 0.5_dp * ( g_jik * & - & ( df_ij * f_ik * u_ij + & - & df_ik * f_ij * u_ik ) + & - & f_ij * f_ik * dg_jik * & - & ( u_ij / r_ik + u_ik / r_ij - & - & theta_jik * ( u_ij / r_ij + u_ik / r_ik ) ) ) - - if( present(virial) ) & - & dn_i_drij_outer_rij = dn_i_drij_outer_rij + & - & 0.5_dp * ( g_jik * ( df_ij * f_ik * (u_ij.outer.u_ij) * r_ij + & - df_ik * f_ij * (u_ik.outer.u_ik) * r_ik ) + & - & f_ij * f_ik * dg_jik * & - & ( (u_ij .outer. u_ik) - theta_jik * (u_ij .outer. u_ij) + & - & (u_ik .outer. u_ij) - theta_jik * (u_ik .outer. u_ik) ) ) - enddo - - enddo - if(present(local_e) .or. present(e)) U_i = spline_value(this%U(ti),n_i) - if(present(f) .or. present(virial)) dU_i = spline_deriv(this%U(ti),n_i) - - if(present(local_e)) local_e(i) = local_e(i) + U_i - if(present(e)) e = e + U_i - if(present(f)) f(:,i) = f(:,i) + dU_i * dn_i - if(present(virial)) virial = virial - dU_i * dn_i_drij_outer_rij - - if(present(f)) then - do n = 1, n_neighbours(at,i) !cross-terms - - j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, diff=diff_ij) ! nth neighbour of atom i - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - if( (r_ij >= this%r_cut_rho(ti,tj)).or.(r_ij >= this%r_cut_f(ti,tj)) ) cycle - - drho_ij = spline_deriv(this%rho(ti,tj),r_ij) - - f(:,j) = f(:,j) - dU_i * drho_ij * u_ij - - f_ij = spline_value(this%f(ti,tj),r_ij) - df_ij = spline_deriv(this%f(ti,tj),r_ij) - - dn_j = 0.0_dp - - do nn = 1, n_neighbours(at,i) - - k = neighbour(at, i, nn, distance=r_ik, cosines=u_ik, diff=diff_ik) - tk = get_type(this%type_of_atomic_num, at%Z(k)) - - if( norm(diff_ij-diff_ik) .feq. 0.0_dp ) cycle - if( r_ik >= this%r_cut_f(ti,tk) ) cycle - - theta_jik = dot_product(u_ij,u_ik) !cosine( at, i, j, k ) - - f_ik = spline_value(this%f(ti,tk),r_ik) - df_ik = spline_deriv(this%f(ti,tk),r_ik) - - g_jik = spline_value(this%g(ti,tj,tk),theta_jik) - dg_jik = spline_deriv(this%g(ti,tj,tk),theta_jik) - - dn_j = dn_j + df_ij * f_ik * g_jik * u_ij + & - & f_ij * f_ik * dg_jik * ( u_ik / r_ij - theta_jik * u_ij / r_ij ) - - enddo - - f(:,j) = f(:,j) - dU_i * dn_j - enddo - endif - enddo - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) call sum_in_place(mpi, f) - if (present(virial)) call sum_in_place(mpi, virial) - endif - -endsubroutine IPModel_Si_MEAM_Calc - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - - integer :: ti, Zi, Zj, Zk - integer :: n_types - real(dp) :: v - - if (name == 'Si_MEAM_params') then - - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered Si_MEAM_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, "n_types", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find n_types") - read (value, *) parse_ip%n_types - n_types = parse_ip%n_types - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - allocate(parse_ip%r_cut_phi(n_types,n_types)) - parse_ip%r_cut_phi = 0.0_dp - allocate(parse_ip%r_cut_rho(n_types,n_types)) - parse_ip%r_cut_rho = 0.0_dp - allocate(parse_ip%r_cut_f(n_types,n_types)) - parse_ip%r_cut_f = 0.0_dp - - allocate( parse_ip%phi(n_types,n_types)) - allocate( parse_ip%rho(n_types,n_types)) - allocate( parse_ip%f(n_types,n_types)) - allocate( parse_ip%U(n_types)) - allocate( parse_ip%g(n_types,n_types,n_types)) - - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find type") - read (value, *) ti - - if (ti < 1 .or. ti > parse_ip%n_types) call system_abort("IPModel_Si_MEAM_read_params_xml got" // & - " per_type_data type out of range " // ti // " n_types " // parse_ip%n_types) - - parse_cur_type_i = ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "atomic_num_i", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_i") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atomic_num_j", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_j") - read (value, *) Zj - - parse_cur_type_i = get_type(parse_ip%type_of_atomic_num,Zi) - parse_cur_type_j = get_type(parse_ip%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "r_cut_phi", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find r_cut_phi") - read (value, *) parse_ip%r_cut_phi(parse_cur_type_i, parse_cur_type_j) - call QUIP_FoX_get_value(attributes, "r_cut_rho", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find r_cut_rho") - read (value, *) parse_ip%r_cut_rho(parse_cur_type_i, parse_cur_type_j) - call QUIP_FoX_get_value(attributes, "r_cut_f", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find r_cut_f") - read (value, *) parse_ip%r_cut_f(parse_cur_type_i, parse_cur_type_j) - - elseif (parse_in_ip .and. name == 'per_triplet_data') then - - call QUIP_FoX_get_value(attributes, "atomic_num_i", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_i") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atomic_num_j", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_j") - read (value, *) Zj - call QUIP_FoX_get_value(attributes, "atomic_num_k", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_k") - read (value, *) Zk - - parse_cur_type_i = get_type(parse_ip%type_of_atomic_num,Zi) - parse_cur_type_j = get_type(parse_ip%type_of_atomic_num,Zj) - parse_cur_type_k = get_type(parse_ip%type_of_atomic_num,Zk) - - elseif (parse_in_ip .and. name == 'spline') then - call QUIP_FoX_get_value(attributes, "spline_function", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find spline_function") - read (value, *) spline_function - call QUIP_FoX_get_value(attributes, "n_spline", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find n_spline") - read (value, *) n_spline - call QUIP_FoX_get_value(attributes, "yp1", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find yp1") - read (value, *) yp1 - call QUIP_FoX_get_value(attributes, "ypn", value, status) - if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find ypn") - read (value, *) ypn - allocate( spline_x(n_spline), spline_y(n_spline) ) - parse_cur_point = 1 - elseif (parse_in_ip .and. name == 'point') then - - if (parse_cur_point > n_spline) call system_abort ("IPModel_Si_MEAM got too " // & - &"many points " // parse_cur_point // " type " // parse_cur_type_i // " " // parse_cur_type_j // & - & " in spline "// trim(spline_function)) - - call QUIP_FoX_get_value(attributes, "x", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_Ercolessi_Adams_read_params_xml cannot find x") - read (value, *) v - spline_x(parse_cur_point) = v - - call QUIP_FoX_get_value(attributes, "y", value, status) - if (status /= 0) call system_abort ("IPModel_EAM_Ercolessi_Adams_read_params_xml cannot find y") - read (value, *) v - spline_y(parse_cur_point) = v - - parse_cur_point = parse_cur_point + 1 - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Si_MEAM_params') then - parse_in_ip = .false. - elseif (name == 'spline') then - selectcase(trim(spline_function)) - case('phi') - call initialise(parse_ip%phi(parse_cur_type_i,parse_cur_type_j), spline_x, spline_y, yp1, ypn) - if( parse_cur_type_i /= parse_cur_type_j ) & - & call initialise(parse_ip%phi(parse_cur_type_j,parse_cur_type_i), spline_x, spline_y, yp1, ypn) - case('rho') - call initialise(parse_ip%rho(parse_cur_type_i,parse_cur_type_j), spline_x, spline_y, yp1, ypn) - if( parse_cur_type_i /= parse_cur_type_j ) & - & call initialise(parse_ip%rho(parse_cur_type_j,parse_cur_type_i), spline_x, spline_y, yp1, ypn) - case('f') - call initialise(parse_ip%f(parse_cur_type_i,parse_cur_type_j), spline_x, spline_y, yp1, ypn) - if( parse_cur_type_i /= parse_cur_type_j ) & - & call initialise(parse_ip%f(parse_cur_type_j,parse_cur_type_i), spline_x, spline_y, yp1, ypn) - case('U') - call initialise(parse_ip%U(parse_cur_type_i), spline_x, spline_y, yp1, ypn) - case('g') - call initialise(parse_ip%g(parse_cur_type_i,parse_cur_type_j,parse_cur_type_k), & - & spline_x, spline_y, yp1, ypn) - if( parse_cur_type_j /= parse_cur_type_k ) & - & call initialise(parse_ip%g(parse_cur_type_i,parse_cur_type_k,parse_cur_type_j), & - & spline_x, spline_y, yp1, ypn) - case default - call system_abort('') - endselect - deallocate(spline_x, spline_y) - endif - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_Si_MEAM_read_params_xml(this, param_str) - type(IPModel_Si_MEAM), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type (xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_ip => this - parse_in_ip = .false. - parse_matched_label = .false. - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types == 0) call system_abort("Si_MEAM Tried to parse, but n_types still 0") - - parse_ip%cutoff = max(maxval(parse_ip%r_cut_phi),maxval(parse_ip%r_cut_rho),maxval(parse_ip%r_cut_f)) - -end subroutine IPModel_Si_MEAM_read_params_xml - - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of potential parameters: number of different types, cutoff radius, atomic numbers, ect. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_Si_MEAM_Print (this, file) - type(IPModel_Si_MEAM), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj, tk - - call Print("IPModel_Si_MEAM : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print("IPModel_Si_MEAM : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print("IPModel_Si_MEAM : U ", file=file) - call Print(this%U(ti), file=file) - do tj=1, this%n_types - call Print("IPModel_Si_MEAM : pair "// ti // " " // tj // " r_cut_phi " // this%r_cut_phi(ti,tj), file=file) - call Print("IPModel_Si_MEAM : pair phi ", file=file) - call Print(this%phi(ti,tj), file=file) - - call Print("IPModel_Si_MEAM : pair "// ti // " " // tj // " r_cut_rho " // this%r_cut_rho(ti,tj), file=file) - call Print("IPModel_Si_MEAM : pair rho ", file=file) - call Print(this%rho(ti,tj), file=file) - - call Print("IPModel_Si_MEAM : pair "// ti // " " // tj // " r_cut_f " // this%r_cut_f(ti,tj), file=file) - call Print("IPModel_Si_MEAM : pair f ", file=file) - call Print(this%f(ti,tj), file=file) - do tk=1, this%n_types - call Print("IPModel_Si_MEAM : triplet g", file=file) - call Print(this%g(ti,tj,tk), file=file) - enddo - end do - call verbosity_pop() - end do - -end subroutine IPModel_Si_MEAM_Print - -endmodule IPModel_Si_MEAM_module -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! -! diff --git a/src/Potentials/IPModel_Spring.f95 b/src/Potentials/IPModel_Spring.f95 deleted file mode 100644 index b81b2b2650..0000000000 --- a/src/Potentials/IPModel_Spring.f95 +++ /dev/null @@ -1,259 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Spring -!X -!% Tethers two groups of atoms (their Centers of Geometry) together with a spring: -!% -!% Energy and Force routines are hardwired -!% Cutoff is hardwired -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Spring_module - -use error_module -use system_module, only : dp, inoutput, print, operator(//), split_string,string_to_int -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use topology_module, only : calc_mean_pos - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Spring -type IPModel_Spring - real(dp) :: cutoff = 0.0_dp - real(dp) :: force_constant = 0.0_dp - real(dp) :: left = 0.0_dp - real(dp) :: right = 0.0_dp - logical :: use_com = .true. - integer,allocatable,dimension(:) :: spring_indices1 - integer,allocatable,dimension(:) :: spring_indices2 -end type IPModel_Spring - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Spring), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Spring_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Spring_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Spring_Print -end interface Print - -interface Calc - module procedure IPModel_Spring_Calc -end interface Calc - -contains - -subroutine IPModel_Spring_Initialise_str(this, args_str, param_str, error) - type(IPModel_Spring), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out):: error - character(len=STRING_LENGTH) :: indices1_string, indices2_string - character(len=STRING_LENGTH), dimension(99) :: indices1_fields, indices2_fields - integer:: i,n_group1,n_group2 - - INIT_ERROR(error) - call Finalise(this) - - call initialise(params) - call param_register(params, 'cutoff', '0.0', this%cutoff, help_string='Not used') - call param_register(params, 'force_constant', '0.0', this%force_constant, help_string='Force constant for quadratic confinement potential. Energy is 0.5*force_constant*displacement^2') - call param_register(params, 'left', '0.0', this%left, help_string='Inner distance at which left harmonic wall ends') - call param_register(params, 'right', '0.0', this%right, help_string='Outer distance at which right harmonic wall begins') - call param_register(params, 'use_com', 'T', this%use_com, help_string='T: use centre of mass. F: use centre of geometry.') - call param_register(params, 'indices1', PARAM_MANDATORY, indices1_string, help_string="Indices (1-based) of the first group of atoms you wish to tether, format {i1 i2 i3 ...}") - call param_register(params, 'indices2', PARAM_MANDATORY, indices2_string, help_string="Indices (1-based) of the second group of atoms you wish to tether, format {i1 i2 i3 ...}") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_Spring_Initialise args_str')) then - RAISE_ERROR("IPModel_Spring_Init failed to parse args_str='"//trim(args_str)//"'", error) - end if - call finalise(params) - - call split_string(indices1_string,' ','{}',indices1_fields(:),n_group1,matching=.true.) - call split_string(indices2_string,' ','{}',indices2_fields(:),n_group2,matching=.true.) - allocate(this%spring_indices1(n_group1)) - allocate(this%spring_indices2(n_group2)) - - do i=1,n_group1 - this%spring_indices1(i) = string_to_int(indices1_fields(i)) - end do - do i=1,n_group2 - this%spring_indices2(i) = string_to_int(indices2_fields(i)) - end do - - -end subroutine IPModel_Spring_Initialise_str - -subroutine IPModel_Spring_Finalise(this) - type(IPModel_Spring), intent(inout) :: this - - ! Add finalisation code here - -end subroutine IPModel_Spring_Finalise - - -subroutine IPModel_Spring_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Spring), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - - real(dp) :: energy, force(3,at%N), r, dr(3), com1(3), com2(3), theforce(3), disp - integer :: i , n_group1, n_group2, i_group11, i_group1i, i_group21, i_group2i - real(dp), allocatable :: weight1(:), weight2(:) - - n_group1=size(this%spring_indices1) - n_group2=size(this%spring_indices2) - - INIT_ERROR(error) - - allocate(weight1(n_group1), weight2(n_group2)) - - if (this%use_com) then - if (.not. has_property(at, 'mass')) then - RAISE_ERROR('IPModel_Spring_Calc: Atoms has no mass property', error) - end if - - do i=1,n_group1 - weight1(i) = at%mass(this%spring_indices1(i)) - end do - weight1 = weight1 / sum(weight1) - - do i=1,n_group2 - weight2(i) = at%mass(this%spring_indices2(i)) - end do - weight2 = weight2 / sum(weight2) - else - weight1 = 1.0_dp / n_group1 - weight2 = 1.0_dp / n_group2 - end if - - if (this%use_com) then - com1 = centre_of_mass(at, index_list=this%spring_indices1) - com2 = centre_of_mass(at, index_list=this%spring_indices2) - else - com1 = calc_mean_pos(at, this%spring_indices1) - com2 = calc_mean_pos(at, this%spring_indices2) - end if - - r = distance_min_image(at, com1, com2) - - energy = 0.0_dp - force = 0.0_dp - - disp = 0.0_dp - if (r .fgt. this%right) then - disp = r - this%right - end if - if (r .flt. this%left) then - disp = r - this%left - end if - - dr = diff_min_image(at, com1, com2) / r - - ! Harmonic confining potential on tethered atoms - ! energy - energy = energy + 0.5_dp * this%force_constant * disp**2 - - ! force - theforce = ( this%force_constant * disp ) * dr - do i=1,n_group1 - force(:,this%spring_indices1(i)) = theforce * weight1(i) - end do - do i=1,n_group2 - force(:,this%spring_indices2(i)) = - theforce * weight2(i) - end do - - deallocate(weight1) - deallocate(weight2) - - - if (present(e)) e = energy - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Spring_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Spring_Calc', error) - f = force - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Spring_Calc', error) - local_virial = 0.0_dp - endif - -end subroutine IPModel_Spring_Calc - - -subroutine IPModel_Spring_Print(this, file) - type(IPModel_Spring), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_Spring : Spring Potential", file=file) - call Print("IPModel_Spring : cutoff = " // this%cutoff, file=file) - call Print("IPModel_Spring : force_constant = " // this%force_constant, file=file) - call Print("IPModel_Spring : left = " // this%left, file=file) - call Print("IPModel_Spring : right = " // this%right, file=file) - call Print("IPModel_Spring : use_com = " // this%use_com, file=file) - call Print("IPModel_Spring : group 1 atoms = " // this%spring_indices1, file=file) - call Print("IPModel_Spring : group 2 atoms = " // this%spring_indices2, file=file) - -end subroutine IPModel_Spring_Print - - -end module IPModel_Spring_module diff --git a/src/Potentials/IPModel_Sutton_Chen.f95 b/src/Potentials/IPModel_Sutton_Chen.f95 deleted file mode 100644 index 4ac2d28fc6..0000000000 --- a/src/Potentials/IPModel_Sutton_Chen.f95 +++ /dev/null @@ -1,458 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Sutton_Chen -!X -!% Sutton_Chen module for use when implementing a new Interatomic Potential -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Sutton_Chen_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Sutton_Chen -type IPModel_Sutton_Chen - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp), dimension(:), allocatable :: a, epsilon, c, v_cutoff, rho_cutoff, & - dv_cutoff, drho_cutoff - integer, dimension(:), allocatable :: m, n - real(dp) :: cutoff = 0.0_dp - - character(len=STRING_LENGTH) :: label - -end type IPModel_Sutton_Chen - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Sutton_Chen), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Sutton_Chen_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Sutton_Chen_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Sutton_Chen_Print -end interface Print - -interface Calc - module procedure IPModel_Sutton_Chen_Calc -end interface Calc - -contains - -subroutine IPModel_Sutton_Chen_Initialise_str(this, args_str, param_str) - type(IPModel_Sutton_Chen), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - integer :: ti - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Sutton_Chen_Initialise_str args_str')) then - call system_abort("IPModel_Sutton_Chen_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Sutton_Chen_read_params_xml(this, param_str) - - do ti = 1, this%n_types - this%v_cutoff(ti) = ( this%a(ti) / this%cutoff )**this%n(ti) - this%dv_cutoff(ti) = - this%n(ti) * ( this%a(ti) / this%cutoff )**this%n(ti) / this%cutoff - this%rho_cutoff(ti) = ( this%a(ti) / this%cutoff )**this%m(ti) - this%drho_cutoff(ti) = - this%m(ti) * ( this%a(ti) / this%cutoff )**this%m(ti) / this%cutoff - enddo - -end subroutine IPModel_Sutton_Chen_Initialise_str - -subroutine IPModel_Sutton_Chen_Finalise(this) - type(IPModel_Sutton_Chen), intent(inout) :: this - - ! Add finalisation code here - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%a)) deallocate(this%a) - if (allocated(this%epsilon)) deallocate(this%epsilon) - if (allocated(this%c)) deallocate(this%c) - if (allocated(this%m)) deallocate(this%m) - if (allocated(this%n)) deallocate(this%n) - if (allocated(this%v_cutoff)) deallocate(this%v_cutoff) - if (allocated(this%dv_cutoff)) deallocate(this%dv_cutoff) - if (allocated(this%rho_cutoff)) deallocate(this%rho_cutoff) - if (allocated(this%drho_cutoff)) deallocate(this%drho_cutoff) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Sutton_Chen_Finalise - - -subroutine IPModel_Sutton_Chen_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Sutton_Chen), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer :: i, j, n, ti, tj - real(dp) :: r_ij, rho_i, v_i, a_over_r, drho_i_drij, dv_i_drij, df_i, e_i - real(dp), dimension(3) :: drho_i_dri, dv_i_dri, u_ij - real(dp), dimension(3,3) :: drho_i_drij_outer_rij, dv_i_drij_outer_rij, virial_i - - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Sutton_Chen_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Sutton_Chen_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Sutton_Chen_Calc', error) - local_virial = 0.0_dp - endif - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Sutton_Chen_Calc args_str')) then - RAISE_ERROR("IPModel_Sutton_Chen_Calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then - RAISE_ERROR("IPModel_Sutton_Chen_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - else - atom_mask_pointer => null() - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_Sutton_Chen_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - endif - - do i = 1, at%N - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - rho_i = 0.0_dp ! Local density from neighbours - v_i = 0.0_dp - - drho_i_dri = 0.0_dp - dv_i_dri = 0.0_dp - - drho_i_drij_outer_rij = 0.0_dp - dv_i_drij_outer_rij = 0.0_dp - - ! Get the type of this species from its atomic number - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - do n = 1, n_neighbours(at, i) - j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, max_dist=this%cutoff) - if( j <= 0 ) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - a_over_r = this%a(tj) / r_ij - - rho_i = rho_i + ( a_over_r**this%m(tj) - this%rho_cutoff(tj) ) - v_i = v_i + ( a_over_r**this%n(tj) - this%v_cutoff(tj) ) - - if( present(f) .or. present(virial) .or. present(local_virial) ) then - drho_i_drij = - this%m(tj) * a_over_r**this%m(tj) / r_ij - dv_i_drij = -this%n(tj) * a_over_r**this%n(tj) / r_ij - - if( present(f) ) then - drho_i_dri = drho_i_dri + drho_i_drij * u_ij - dv_i_dri = dv_i_dri + dv_i_drij * u_ij - endif - - if( present(virial) .or. present(local_virial) ) then - drho_i_drij_outer_rij = drho_i_drij_outer_rij + drho_i_drij*(u_ij .outer. u_ij)*r_ij - dv_i_drij_outer_rij = dv_i_drij_outer_rij + dv_i_drij*(u_ij .outer. u_ij)*r_ij - endif - endif - enddo - - df_i = - 0.5_dp * this%c(ti) / sqrt(rho_i) - - if(present(f)) then - f(:,i) = f(:,i) + this%epsilon(ti) * ( drho_i_dri * df_i + dv_i_dri ) - do n = 1, n_neighbours(at, i) - j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, max_dist=this%cutoff) - if( j <= 0 ) cycle - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - a_over_r = this%a(tj) / r_ij - drho_i_drij = - this%m(tj) * a_over_r**this%m(tj) / r_ij - - f(:,j) = f(:,j) - this%epsilon(tj) * df_i * drho_i_drij * u_ij - enddo - endif - - if( present(e) .or. present(local_e) ) then - e_i = this%epsilon(ti) * ( 0.5_dp * v_i - this%c(ti) * sqrt(rho_i) ) - if( present(e) ) e = e + e_i - if( present(local_e) ) local_e(i) = e_i - endif - - if( present(virial) .or. present(local_virial) ) then - virial_i = this%epsilon(ti) * ( - 0.5_dp * dv_i_drij_outer_rij - & - df_i * drho_i_drij_outer_rij ) - - if(present(virial)) virial = virial + virial_i - if(present(local_virial)) local_virial(:,i) = local_virial(:,i) + reshape(virial_i,(/9/)) - endif - enddo ! i - - atom_mask_pointer => null() - -end subroutine IPModel_Sutton_Chen_Calc - - -subroutine IPModel_Sutton_Chen_Print(this, file) - type(IPModel_Sutton_Chen), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_Sutton_Chen : Sutton_Chen Potential", file=file) - call Print("IPModel_Sutton_Chen : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_Sutton_Chen : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_Sutton_Chen : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_Sutton_Chen_Print - -subroutine IPModel_Sutton_Chen_read_params_xml(this, param_str) - type(IPModel_Sutton_Chen), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Sutton_Chen_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_Sutton_Chen_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - integer ti - - if (name == 'Sutton_Chen_params') then ! new Sutton_Chen stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in Sutton_Chen_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - allocate(parse_ip%a(parse_ip%n_types)) - parse_ip%a = 0.0_dp - allocate(parse_ip%epsilon(parse_ip%n_types)) - parse_ip%epsilon = 0.0_dp - allocate(parse_ip%c(parse_ip%n_types)) - parse_ip%c = 0.0_dp - allocate(parse_ip%m(parse_ip%n_types)) - parse_ip%m = 0 - allocate(parse_ip%n(parse_ip%n_types)) - parse_ip%n = 0 - allocate(parse_ip%v_cutoff(parse_ip%n_types)) - parse_ip%v_cutoff = 0.0_dp - allocate(parse_ip%dv_cutoff(parse_ip%n_types)) - parse_ip%dv_cutoff = 0.0_dp - allocate(parse_ip%rho_cutoff(parse_ip%n_types)) - parse_ip%rho_cutoff = 0.0_dp - allocate(parse_ip%drho_cutoff(parse_ip%n_types)) - parse_ip%drho_cutoff = 0.0_dp - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - call QUIP_FoX_get_value(attributes, "a", value, status) - if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find a") - read (value, *) parse_ip%a(ti) - - call QUIP_FoX_get_value(attributes, "epsilon", value, status) - if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find epsilon") - read (value, *) parse_ip%epsilon(ti) - - call QUIP_FoX_get_value(attributes, "c", value, status) - if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find c") - read (value, *) parse_ip%c(ti) - - call QUIP_FoX_get_value(attributes, "m", value, status) - if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find m") - read (value, *) parse_ip%m(ti) - - call QUIP_FoX_get_value(attributes, "n", value, status) - if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find n") - read (value, *) parse_ip%n(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - enddo - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Sutton_Chen_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_Sutton_Chen_module diff --git a/src/Potentials/IPModel_TS.f95 b/src/Potentials/IPModel_TS.f95 deleted file mode 100644 index 0fd2d05b01..0000000000 --- a/src/Potentials/IPModel_TS.f95 +++ /dev/null @@ -1,968 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_TS -!X -!% Reimplementation of TS potential: -!% P. Tangney and S. Scandolo, -!% An ab initio parametrized interatomic force field for silica -!% J. Chem. Phys, 117, 8898 (2002). -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_TS_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_VERBOSE, current_verbosity, line, system_timer, verbosity_push_decrement, verbosity_pop, operator(//) -use units_module -use periodictable_module -use mpi_context_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use cinoutput_module - - -use functions_module -use QUIP_Common_module -use Yukawa_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_TS -type IPModel_TS - integer :: n_types = 0 - real(dp) :: betapol, tolpol, yukalpha, yuksmoothlength - integer :: maxipol, pred_order - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - real(dp), allocatable, dimension(:) :: pol, z, pseudise_sigma - real(dp), allocatable, dimension(:,:) :: D_ms, gamma_ms, R_ms, B_pol, C_pol - - real(dp) :: cutoff_coulomb, cutoff_ms, smoothlength_ms - - character(len=STRING_LENGTH) :: label - logical :: initialised, tdip_sr - -end type IPModel_TS - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_TS), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_TS_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_TS_Finalise -end interface Finalise - -interface Print - module procedure IPModel_TS_Print -end interface Print - -public :: setup_atoms -interface setup_atoms - module procedure IPModel_TS_setup_atoms -end interface - -interface Calc - module procedure IPModel_TS_Calc -end interface Calc - -contains - - -subroutine IPModel_TS_Initialise_str(this, args_str, param_str) - type(IPModel_TS), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - this%initialised = .false. - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_TS_Initialise_str args_str')) then - call system_abort("IPModel_TS_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_TS_read_params_xml(this, param_str) - this%initialised = .true. - -end subroutine IPModel_TS_Initialise_str - -subroutine IPModel_TS_Finalise(this) - type(IPModel_TS), intent(inout) :: this - - this%initialised = .false. - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%pol)) deallocate(this%pol) - if (allocated(this%z)) deallocate(this%z) - if (allocated(this%D_ms)) deallocate(this%D_ms) - if (allocated(this%gamma_ms)) deallocate(this%gamma_ms) - if (allocated(this%R_ms)) deallocate(this%R_ms) - if (allocated(this%B_pol)) deallocate(this%B_pol) - if (allocated(this%C_pol)) deallocate(this%C_pol) - if (allocated(this%pseudise_sigma)) deallocate(this%pseudise_sigma) - this%n_types = 0 - this%label = '' -end subroutine IPModel_TS_Finalise - -subroutine asap_short_range_dipole_moments(this, at, charge, dip_sr, mpi) - type(IPModel_TS), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), dimension(:), intent(in) :: charge - real(dp), dimension(:,:), intent(out) :: dip_sr - type(MPI_Context), intent(in), optional :: mpi - - integer :: i, ti, m, j, tj, k - real(dp) :: r_ij, u_ij(3), qj, bij, cij, dist3, dist5, gij, factork, expfactor, fc, dfc_dr - integer, parameter :: nk = 4 - real(dp), allocatable :: private_dip_sr(:,:) - - call system_timer('asap_short_range_dipole_moments') - - dip_sr = 0.0_dp - - !$omp parallel default(none) shared(this, mpi, at, charge, dip_sr) private(ti, m, j, tj, k, r_ij, u_ij, qj, bij, cij, dist3, dist5, gij, factork, expfactor, fc, dfc_dr, private_dip_sr) - - allocate(private_dip_sr(size(dip_sr,1),size(dip_sr,2))) - private_dip_sr = 0.0_dp - - !$omp do schedule(runtime) - do i=1, at%n - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - if (.not. (abs(this%pol(ti)) > 0.0_dp)) cycle - - do m = 1, n_neighbours(at, i) - - j = neighbour(at, i, m, distance=r_ij, diff=u_ij, max_dist=(this%cutoff_ms*BOHR)) - if (j <= 0) cycle - if (r_ij .feq. 0.0_dp) cycle - - r_ij = r_ij/BOHR - u_ij = u_ij/BOHR - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - qj = charge(j) - bij = this%b_pol(ti, tj) - cij = this%c_pol(ti, tj) - - dist3 = r_ij**3.0_dp - dist5 = r_ij**5.0_dp - - gij = 0.0_dp - factork = cij*exp(-bij*r_ij) - do k=1,nk - gij = gij + factork - factork = factork*bij*r_ij/real(k,dp) - enddo - gij = gij + factork - - expfactor = exp(-this%yukalpha*r_ij) - call smooth_cutoff(r_ij, this%cutoff_coulomb-this%yuksmoothlength, this%yuksmoothlength, fc, dfc_dr) - - private_dip_sr(:,i) = private_dip_sr(:,i) - this%pol(ti)*qj*u_ij*gij/dist3*expfactor*fc - end do - end do - !$omp end do - - if (present(mpi)) then - if (mpi%active) call sum_in_place(mpi, private_dip_sr) - endif - - !$omp critical - dip_sr = dip_sr + private_dip_sr*BOHR - !$omp end critical - - deallocate(private_dip_sr) - !$omp end parallel - - call system_timer('asap_short_range_dipole_moments') - -end subroutine asap_short_range_dipole_moments - -!% Morse-stretch potential, defined by -!% \begin{displaymath} -!% U_ij = D_ij \left[ e^{\gamma_{ij}\left( 1 - r_{ij}/r^0_{ij} \right)} -!% - 2 e^{\gamma_{ij}/2\left( 1 - r_{ij}/r^0_{ij} \right)} \right] -!% \end{displaymath} -subroutine asap_morse_stretch(this, at, e, local_e, f, virial, mpi) -#ifdef _OPENMP - use omp_lib -#endif - type(IPModel_TS), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:) - real(dp), intent(out), optional :: virial(3,3) - type(MPI_Context), intent(in), optional :: mpi - - integer i, j, m, ti, tj - real(dp) :: r_ij, u_ij(3), dms, gammams, rms - real(dp) :: exponentms, factorms, phi, de - real(dp) :: dforce, fc, dfc_dr - real(dp) :: elimitij(this%n_types, this%n_types) - logical :: i_is_min_image, j_is_min_image - - real(dp) :: private_virial(3,3), private_e - real(dp), allocatable :: private_f(:,:), private_local_e(:) - - call system_timer('asap_morse_stretch') - - ! Evaluate potential at cutoff. Will be subtracted from total energy. - elimitij = 0.0_dp - do ti=1,this%n_types - do tj=1,this%n_types - phi = exp(this%gamma_ms(ti,tj)*(1.0_dp - this%cutoff_ms/this%r_ms(ti,tj))) - elimitij(ti,tj) = this%d_ms(ti,tj)*(phi - 2.0_dp*sqrt(phi)) - end do - end do - - !$omp parallel default(none) shared(this, mpi, at, e, local_e, f, virial, elimitij) private(i, j, m, ti, tj, r_ij, u_ij, dms, gammams, rms, exponentms, factorms, phi, de, dforce, i_is_min_image, j_is_min_image, private_virial, private_e, private_f, private_local_e, fc, dfc_dr) - - if (present(e)) private_e = 0.0_dp - if (present(local_e)) then - allocate(private_local_e(at%N)) - private_local_e = 0.0_dp - endif - if (present(f)) then - allocate(private_f(3,at%N)) - private_f = 0.0_dp - endif - if (present(virial)) private_virial = 0.0_dp - - !$omp do schedule(runtime) - do i=1, at%n - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if (allocated(at%connect%is_min_image)) then - i_is_min_image = at%connect%is_min_image(i) - else - i_is_min_image = is_min_image(at, i) - end if - ti = get_type(this%type_of_atomic_num, at%Z(i)) - do m = 1, n_neighbours(at, i) - - j = neighbour(at, i, m, distance=r_ij, cosines=u_ij, max_dist=(this%cutoff_ms*BOHR)) - - if (j <= 0) cycle - if (r_ij .feq. 0.0_dp) cycle - - if (allocated(at%connect%is_min_image)) then - j_is_min_image = at%connect%is_min_image(j) - else - j_is_min_image = is_min_image(at, j) - end if - - if (i < j .and. i_is_min_image .and. j_is_min_image) cycle - - r_ij = r_ij/BOHR - - call smooth_cutoff(r_ij, this%cutoff_ms-this%smoothlength_ms, this%smoothlength_ms, fc, dfc_dr) - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - dms = this%d_ms(ti,tj) - gammams = this%gamma_ms(ti,tj) - rms = this%r_ms(ti, tj) - - exponentms = gammams*(1.0_dp-r_ij/rms) - factorms = gammams/rms - phi = exp(exponentms) - - if (present(e) .or. present(local_e)) then - de = (dms*(phi - 2.0_dp*sqrt(phi)) - elimitij(ti, tj))*fc - - if (present(e)) then - if (i_is_min_image .and. j_is_min_image) then - private_e = private_e + de - else - private_e = private_e + 0.5_dp*de - end if - end if - - if (present(local_e)) then - private_local_e(i) = private_local_e(i) + 0.5_dp*de - if (i_is_min_image .and. j_is_min_image) private_local_e(j) = private_local_e(j) + 0.5_dp*de - end if - end if - - if (present(f) .or. present(virial)) then - dforce = -dms*(factorms*phi - factorms*dsqrt(phi))*fc + (dms*(phi - 2.0_dp*sqrt(phi)) - elimitij(ti, tj))*dfc_dr - - if (present(f)) then - private_f(:,i) = private_f(:,i) + dforce*u_ij - if (i_is_min_image .and. j_is_min_image) private_f(:,j) = private_f(:,j) - dforce*u_ij - end if - if (present(virial)) then - if (i_is_min_image .and. j_is_min_image) then - private_virial = private_virial - dforce*(u_ij .outer. u_ij)*r_ij - else - private_virial = private_virial - 0.5_dp*dforce*(u_ij .outer. u_ij)*r_ij - end if - end if - end if - end do - end do - - if (present(mpi)) then - if (mpi%active) then - if (present(e)) private_e = sum(mpi, private_e) - if (present(local_e)) call sum_in_place(mpi, private_local_e) - if (present(f)) call sum_in_place(mpi, private_f) - if (present(virial)) call sum_in_place(mpi, private_virial) - end if - end if - - !$omp critical - if (present(e)) e = e + private_e*HARTREE - if (present(f)) f = f + private_f*(HARTREE/BOHR) - if (present(local_e)) local_e = local_e + private_local_e*HARTREE - if (present(virial)) virial = virial + private_virial*HARTREE - !$omp end critical - - if (allocated(private_f)) deallocate(private_f) - if (allocated(private_local_e)) deallocate(private_local_e) - - !$omp end parallel - - call system_timer('asap_morse_stretch') - -end subroutine asap_morse_stretch - -subroutine IPModel_TS_setup_atoms(this, at) - type(IPModel_TS), intent(in):: this - type(Atoms), intent(inout) :: at - - logical :: dummy - integer :: i, ti - real(dp), dimension(:), pointer :: charge - - ! If charge property doesn't exist, we add and initialise it now - - if (.not. has_property(at, 'charge')) then - call add_property(at, 'charge', 0.0_dp) - dummy = assign_pointer(at, 'charge', charge) - do i=1, at%N - ti = get_type(this%type_of_atomic_num, at%Z(i)) - charge(i) = this%z(ti) - end do - end if - - if (.not. has_property(at, 'fixdip')) call add_property(at, 'fixdip', .false.) - if (.not. has_property(at, 'efield')) call add_property(at, 'efield', 0.0_dp, n_cols=3) - if (.not. has_property(at, 'dipoles')) call add_property(at, 'dipoles', 0.0_dp, n_cols=3) - if (.not. has_property(at, 'efield_old1')) call add_property(at, 'efield_old1', 0.0_dp, n_cols=3) - if (.not. has_property(at, 'efield_old2')) call add_property(at, 'efield_old2', 0.0_dp, n_cols=3) - if (.not. has_property(at, 'efield_old3')) call add_property(at, 'efield_old3', 0.0_dp, n_cols=3) - - ! Increment at%cutoff if necessary - call set_cutoff_minimum(at, max(this%cutoff_ms, this%cutoff_coulomb)*BOHR) - -end subroutine IPModel_TS_setup_atoms - -subroutine IPModel_TS_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_TS), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional, intent(in) :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - logical :: restart, applied_efield, save_dipole_velo, & - calc_charge, calc_sc_dipoles, calc_dipoles, calc_short_range - real(dp), allocatable, target :: efield_int_old(:,:) - real(dp), allocatable :: efield_charge(:,:), efield_dipole(:,:), dip_sr(:,:) - real(dp), pointer, dimension(:) :: charge - real(dp), pointer, dimension(:,:) :: efield, dipoles, efield_old1, efield_old2, efield_old3, ext_efield, dip_velo - logical, pointer, dimension(:) :: fixdip - real(dp) :: diff, diff_old - integer :: n_efield_old - integer :: i, npol, ti, vv - character(len=STRING_LENGTH) :: efield_name, dipoles_name, atom_mask_name, source_mask_name - logical :: pseudise - real(dp) :: grid_size - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - real, parameter :: difftol = 500.0_dp - - INIT_ERROR(error) - - call system_timer('asap_calc') - vv = current_verbosity() - - if (present(args_str)) then - call initialise(params) - call param_register(params, 'efield', 'efield', efield_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'dipoles', 'dipoles', dipoles_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'save_dipole_velo', 'F', save_dipole_velo, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'restart', 'F', restart, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'applied_efield', 'F', applied_efield, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'calc_charge', 'T', calc_charge, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'calc_sc_dipoles', 'T', calc_sc_dipoles, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'calc_dipoles', 'T', calc_dipoles, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'calc_short_range', 'T', calc_short_range, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'atom_mask_name', '', atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'source_mask_name', '', source_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'pseudise', 'F', pseudise, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'grid_size', '0.0', grid_size, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_TS_Calc args_str')) then - RAISE_ERROR("IPModel_TS_Calc failed to parse args_str="//trim(args_str), error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_TS_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - call finalise(params) - else - efield_name = 'efield' - dipoles_name = 'dipoles' - save_dipole_velo = .false. - restart = .false. - applied_efield = .false. - calc_charge = .true. - calc_sc_dipoles = .true. - calc_short_range = .true. - atom_mask_name = '' - source_mask_name = '' - pseudise = .false. - grid_size = 0.0_dp - r_scale = 1.0_dp - E_scale = 1.0_dp - end if - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_TS_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_TS_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_TS_Calc', error) - local_virial = 0.0_dp - RAISE_ERROR("IPModel_TS_Calc: local_virial calculation requested but not supported yet.", error) - endif - - allocate(efield_charge(3,at%n), efield_dipole(3,at%n)) - - ! Assign pointers - if (.not. assign_pointer(at, efield_name, efield)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "'//trim(efield_name)//'" property', error) - endif - - if (.not. assign_pointer(at, dipoles_name, dipoles)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "'//trim(dipoles_name)//'" property', error) - endif - - if (save_dipole_velo .and. maxval(abs(dipoles)) > 0.0_dp) then - if (.not. assign_pointer(at, 'dip_velo', dip_velo)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer ot "dip_velo" property', error) - endif - do i=1,at%n - dip_velo(:,i) = -dipoles(:,i) - end do - end if - - if (applied_efield) then - if (.not. assign_pointer(at, 'ext_efield', ext_efield)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "ext_efield" property', error) - endif - end if - - if (.not. assign_pointer(at, 'charge', charge)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "charge" property', error) - endif - if (.not. assign_pointer(at, 'fixdip', fixdip)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "fixdip" property', error) - endif - if (.not. assign_pointer(at, 'efield_old1', efield_old1)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "efield_old1" property', error) - endif - if (.not. assign_pointer(at, 'efield_old2', efield_old2)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "efield_old2" property', error) - endif - if (.not. assign_pointer(at, 'efield_old3', efield_old3)) then - RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "efield_old3" property', error) - endif - - if (.not. get_value(at%params, 'n_efield_old', n_efield_old)) n_efield_old = 0 - - if (restart) then - efield_old1(:,:) = 0.0_dp - efield_old2(:,:) = 0.0_dp - efield_old3(:,:) = 0.0_dp - n_efield_old = 0 - end if - - efield_dipole = 0.0_dp - if (calc_sc_dipoles) then - do i=1,at%n - if (.not. fixdip(i)) dipoles(:,i) = 0.0_dp - end do - - ! Extrapolate from the old electric efield - if (this%pred_order == 0 .or. n_efield_old < 2) then - efield_dipole = efield_old1(:,:) - end if - - if (this%pred_order == 1 .and. n_efield_old >= 2) then - efield_dipole = 2.0_dp*efield_old1(:,:) - efield_old2(:,:) - end if - - if (this%pred_order == 2 .and. n_efield_old >= 3) then - efield_dipole = 3.0_dp*efield_old1(:,:) - 3.0_dp*efield_old2(:,:) + efield_old3(:,:) - end if - - if (this%pred_order /= 0) then - if (this%pred_order == 1) then - efield_old2 = efield_old1 - else if (this%pred_order == 2) then - efield_old3 = efield_old2 - efield_old2 = efield_old1 - end if - end if - - call set_value(at%params, 'n_efield_old', min(n_efield_old+1,3)) - end if - - efield_charge = 0.0_dp - if (calc_charge) then - if (maxval(abs(this%z)) > 0.0_dp) then - call yukawa_charges(at, charge, this%cutoff_coulomb*BOHR, this%yukalpha/BOHR, this%yuksmoothlength*BOHR, & - e, local_e, f, virial, efield_charge, mpi, atom_mask_name, source_mask_name, this%type_of_atomic_num, & - pseudise, this%pseudise_sigma*BOHR, grid_size, error=error) - end if - end if - - if (calc_sc_dipoles) then - allocate(dip_sr(3,at%n)) - dip_sr = 0.0_dp - if (this%tdip_sr) call asap_short_range_dipole_moments(this, at, charge, dip_sr, mpi) - - allocate(efield_int_old(3,at%n)) - efield_int_old = 0.0_dp - - if (maxval(abs(this%pol)) > 0.0_dp .and. .not. all(fixdip)) then - - call print('Entering TS Self-consistent dipole loop with '//count(.not. fixdip)//' variable dipole moments', PRINT_VERBOSE) - - ! Self-consistent determination of dipole moments - diff_old = 1.0_dp - npol = 1 - call system_timer('asap_self_consistent_dipoles') - do - ! Mix current and previous total efields - if (npol == 1) then - efield = efield_dipole + efield_charge - else - efield = this%betapol*efield_dipole + & - (1.0_dp - this%betapol)*efield_int_old + efield_charge - end if - - ! Add external field if present - if (applied_efield) then - do i=1,at%n - efield(:,i) = efield(:,i) + ext_efield(:,i) - end do - end if - - ! Calculate dipole moment in response to total efield - do i=1,at%n - if (fixdip(i)) cycle - ti = get_type(this%type_of_atomic_num, at%Z(i)) - if (abs(this%pol(ti)) > 0.0_dp) then - dipoles(:,i) = efield(:,i)*((BOHR**2/HARTREE)*this%pol(ti)) + dip_sr(:,i) - end if - end do - - ! Calculate new efield and measure of convergence - efield_int_old = efield_dipole - efield_dipole = 0.0_dp - call yukawa_dipoles(at, charge, dipoles, this%cutoff_coulomb*BOHR, this%yukalpha/BOHR, this%yuksmoothlength*BOHR, & - (BOHR**2/HARTREE)*this%pol, this%b_pol, this%c_pol, this%type_of_atomic_num, this%tdip_sr, efield=efield_dipole, & - mpi=mpi, error=error) - - diff = 0.0_dp - do i=1,at%n - ti = get_type(this%type_of_atomic_num, at%Z(i)) - diff = diff + (BOHR/HARTREE)**2*((efield_dipole(:,i) - efield_old1(:,i)) .dot. (efield_dipole(:,i) - efield_old1(:,i)))*& - this%pol(ti)*this%pol(ti) - end do - diff = sqrt(diff/at%n) - efield_old1 = efield_dipole - - if (vv >= PRINT_VERBOSE) then - write (line,'("Polarisation iteration : ",i5,3e16.8)') npol, diff_old, diff - call print(line, PRINT_VERBOSE) - end if - - if (diff > difftol) then - call write(at, 'ipmodel_asap_polarisation_divergence.xyz') - RAISE_ERROR('IPModel_TS_calc: Polarisation diverges - diff='//diff, error) - end if - - if (abs(diff - diff_old) < this%tolpol) exit - - diff_old = diff - npol = npol + 1 - if (npol >= this%maxipol) then - call write(at, 'ipmodel_asap_polarisation_not_converged.xyz') - RAISE_ERROR('IPModel_TS_calc: Polarisation not converged in '//this%maxipol//' steps - diff='//diff, error) - endif - - end do - call system_timer('asap_self_consistent_dipoles') - - ! Save final dipole field for next time - efield_old1 = efield_dipole - end if - end if - - efield_dipole = 0.0_dp - if (calc_dipoles) then - ! Compute final energy, local energies, forces, virial and electric efield - if (maxval(abs(dipoles)) > 0.0_dp) then - call yukawa_dipoles(at, charge, dipoles, this%cutoff_coulomb*BOHR, this%yukalpha/BOHR, this%yuksmoothlength*BOHR, & - (BOHR**2/HARTREE)*this%pol, this%b_pol, this%c_pol, this%type_of_atomic_num, this%tdip_sr, & - e, local_e, f, virial, efield_dipole, mpi, atom_mask_name, source_mask_name, pseudise, & - this%pseudise_sigma*BOHR, grid_size, error=error) - - if (save_dipole_velo) then - ! dip_velo = dipoles_{N-1} - dipoles_N (we do not divide by timestep here) - do i=1,at%n - dip_velo(:,i) = dip_velo(:,i) + dipoles(:,i) - end do - end if - end if - end if - - efield(:,1:at%n) = efield_charge + efield_dipole - - ! Finally, add the short-range contribution - if (calc_short_range) then - call asap_morse_stretch(this, at, e, local_e, f, virial, mpi) - end if - - if (allocated(efield_charge)) deallocate(efield_charge) - if (allocated(efield_dipole)) deallocate(efield_dipole) - if (allocated(dip_sr)) deallocate(dip_sr) - if (allocated(efield_int_old)) deallocate(efield_int_old) - - call system_timer('asap_calc') - -end subroutine IPModel_TS_Calc - - -subroutine IPModel_TS_Print(this, file) - type(IPModel_TS), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_TS : TS Potential", file=file) - call Print("IPModel_TS : n_types = " // this%n_types, file=file) - call Print("IPModel_TS : betapol = "//this%betapol//" maxipol = "//this%maxipol//" tolpol = "//this%tolpol//" pred_order = "//this%pred_order, file=file) - call Print("IPModel_TS : yukalpha = "//this%yukalpha//" yuksmoothlength = "//this%yuksmoothlength, file=file) - call Print("IPModel_TS : cutoff_coulomb = "//this%cutoff_coulomb//" cutoff_ms = "//this%cutoff_ms//" smoothlength_ms="//this%smoothlength_ms, file=file) - - do ti=1, this%n_types - call Print ("IPModel_TS : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call Print ("IPModel_TS : pol = "//this%pol(ti), file=file) - call Print ("IPModel_TS : z = "//this%z(ti), file=file) - call Print ("IPModel_TS : pseudise_sigma = "//this%pseudise_sigma(ti), file=file) - call verbosity_push_decrement() - do tj =1,this%n_types - call Print ("IPModel_TS : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) //& - " " // this%atomic_num(tj), file=file) - call Print ("IPModel_TS : pair " // this%D_ms(ti,tj) // " " // this%gamma_ms(ti,tj) // " " & - // this%R_ms(ti,tj) // " " // this%B_pol(ti,tj) // " " // this%C_pol(ti, tj), file=file) - - end do - call verbosity_pop() - end do - -end subroutine IPModel_TS_Print - -subroutine IPModel_TS_read_params_xml(this, param_str) - type(IPModel_TS), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - integer :: ti - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_TS_read_params_xml parsed file, but n_types = 0") - endif - - ! pseudise_sigma defaults to covalent radii - do ti=1,this%n_types - if (this%pseudise_sigma(ti) .feq. 0.0_dp) then - this%pseudise_sigma(ti) = ElementCovRad(this%atomic_num(ti))/BOHR - end if - end do - -end subroutine IPModel_TS_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - integer ti, tj, Zi, Zj - - if (name == 'TS_params') then ! new ASAP stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in TS_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - allocate(parse_ip%pol(parse_ip%n_types)) - parse_ip%pol = 0.0_dp - allocate(parse_ip%z(parse_ip%n_types)) - allocate(parse_ip%pseudise_sigma(parse_ip%n_types)) - parse_ip%pseudise_sigma = 0.0_dp - - allocate(parse_ip%D_ms(parse_ip%n_types,parse_ip%n_types)) - parse_ip%D_ms = 0.0_dp - allocate(parse_ip%gamma_ms(parse_ip%n_types,parse_ip%n_types)) - parse_ip%gamma_ms = 0.0_dp - allocate(parse_ip%R_ms(parse_ip%n_types,parse_ip%n_types)) - parse_ip%R_ms = 0.0_dp - allocate(parse_ip%B_pol(parse_ip%n_types,parse_ip%n_types)) - parse_ip%B_pol = 0.0_dp - allocate(parse_ip%C_pol(parse_ip%n_types,parse_ip%n_types)) - parse_ip%C_pol = 0.0_dp - - call QUIP_FoX_get_value(attributes, "cutoff_coulomb", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find cutoff_coulomb") - read (value, *) parse_ip%cutoff_coulomb - - call QUIP_FoX_get_value(attributes, "cutoff_ms", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find cutoff_ms") - read (value, *) parse_ip%cutoff_ms - - parse_ip%smoothlength_ms = 0.0_dp - call QUIP_FoX_get_value(attributes, "smoothlength_ms", value, status) - if (status == 0) read (value, *) parse_ip%smoothlength_ms - - call QUIP_FoX_get_value(attributes, "betapol", value, status) - if (status == 0) read (value, *) parse_ip%betapol - - call QUIP_FoX_get_value(attributes, "maxipol", value, status) - if (status == 0) read (value, *) parse_ip%maxipol - - call QUIP_FoX_get_value(attributes, "tolpol", value, status) - if (status == 0) read (value, *) parse_ip%tolpol - - call QUIP_FoX_get_value(attributes, "pred_order", value, status) - if (status == 0) read (value, *) parse_ip%pred_order - - call QUIP_FoX_get_value(attributes, "yukalpha", value, status) - if (status == 0) read (value, *) parse_ip%yukalpha - - call QUIP_FoX_get_value(attributes, "yuksmoothlength", value, status) - if (status == 0) read (value, *) parse_ip%yuksmoothlength - - parse_ip%tdip_sr = .true. - call QUIP_FoX_get_value(attributes, "tdip_sr", value, status) - if (status == 0) read (value, *) parse_ip%tdip_sr - - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - call QUIP_FoX_get_value(attributes, "pol", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find pol") - read (value, *) parse_ip%pol(ti) - - call QUIP_FoX_get_value(attributes, "z", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find z") - read (value, *) parse_ip%z(ti) - - call QUIP_FoX_get_value(attributes, "pseudise_sigma", value, status) - if (status == 0) then - read (value, *) parse_ip%pseudise_sigma(ti) - end if - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "atnum_i", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_i") - read (value, *) Zi - call QUIP_FoX_get_value(attributes, "atnum_j", value, status) - if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_j") - read (value, *) Zj - - ti = get_type(parse_ip%type_of_atomic_num,Zi) - tj = get_type(parse_ip%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "D_ms", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find D_ms") - read (value, *) parse_ip%D_ms(ti,tj) - call QUIP_FoX_get_value(attributes, "gamma_ms", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find gamma_ms") - read (value, *) parse_ip%gamma_ms(ti,tj) - call QUIP_FoX_get_value(attributes, "R_ms", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find R_ms") - read (value, *) parse_ip%R_ms(ti,tj) - call QUIP_FoX_get_value(attributes, "B_pol", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find B_pol") - read (value, *) parse_ip%B_pol(ti,tj) - call QUIP_FoX_get_value(attributes, "C_pol", value, status) - if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find C_pol") - read (value, *) parse_ip%C_pol(ti,tj) - - if (ti /= tj) then - parse_ip%D_ms(tj,ti) = parse_ip%D_ms(ti,tj) - parse_ip%gamma_ms(tj,ti) = parse_ip%gamma_ms(ti,tj) - parse_ip%R_ms(tj,ti) = parse_ip%R_ms(ti,tj) - parse_ip%B_pol(tj,ti) = parse_ip%B_pol(ti,tj) - parse_ip%C_pol(tj,ti) = parse_ip%C_pol(ti,tj) - endif - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'TS_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_TS_module diff --git a/src/Potentials/IPModel_Template.f95 b/src/Potentials/IPModel_Template.f95 deleted file mode 100644 index 914ead9042..0000000000 --- a/src/Potentials/IPModel_Template.f95 +++ /dev/null @@ -1,295 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Template -!X -!% Template module for use when implementing a new Interatomic Potential -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Template_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Template -type IPModel_Template - integer :: n_types = 0 - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) - - real(dp) :: cutoff = 0.0_dp - - character(len=STRING_LENGTH) :: label - -end type IPModel_Template - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Template), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Template_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Template_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Template_Print -end interface Print - -interface Calc - module procedure IPModel_Template_Calc -end interface Calc - -contains - -subroutine IPModel_Template_Initialise_str(this, args_str, param_str) - type(IPModel_Template), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Template_Initialise_str args_str')) then - call system_abort("IPModel_Template_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Template_read_params_xml(this, param_str) - - ! Add initialisation code here - -end subroutine IPModel_Template_Initialise_str - -subroutine IPModel_Template_Finalise(this) - type(IPModel_Template), intent(inout) :: this - - ! Add finalisation code here - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Template_Finalise - - -subroutine IPModel_Template_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Template), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - ! Add calc() code here - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Template_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Template_Calc', error) - f = 0.0_dp - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Template_Calc', error) - local_virial = 0.0_dp - endif - - RAISE_ERROR('IPModel_Calc - not implemented',error) - -end subroutine IPModel_Template_Calc - - -subroutine IPModel_Template_Print(this, file) - type(IPModel_Template), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti - - call Print("IPModel_Template : Template Potential", file=file) - call Print("IPModel_Template : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print ("IPModel_Template : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_Template : " // & - "cutoff " // this%cutoff , & - file=file) - call verbosity_pop() - end do - -end subroutine IPModel_Template_Print - -subroutine IPModel_Template_read_params_xml(this, param_str) - type(IPModel_Template), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_ip = .false. - parse_matched_label = .false. - parse_ip => this - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Template_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_Template_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - integer ti - - if (name == 'Template_params') then ! new Template stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, 'n_types', value, status) - if (status == 0) then - read (value, *) parse_ip%n_types - else - call system_abort("Can't find n_types in Template_params") - endif - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - call QUIP_FoX_get_value(attributes, "cutoff", value, status) - if (status /= 0) call system_abort ("IPModel_Template_read_params_xml cannot find cutoff") - read (value, *) parse_ip%cutoff - endif - - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Template_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Template_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Template_params') then - parse_in_ip = .false. - end if - endif - -end subroutine IPModel_endElement_handler - -end module IPModel_Template_module diff --git a/src/Potentials/IPModel_Tersoff.f95 b/src/Potentials/IPModel_Tersoff.f95 deleted file mode 100644 index 09f1c3e03e..0000000000 --- a/src/Potentials/IPModel_Tersoff.f95 +++ /dev/null @@ -1,735 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Tersoff module -!X -!% Module for computing energy using the Tersoff potential for C/Si/Ge and alloys -!% (Ref. J. Tersoff, Phys. Rev. B {\bf 39}, 5566 (1989)). -!% The IPModel_Tersoff object contains all the parameters read from a 'Tersoff_params' -!% XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Tersoff_module - -use error_module -use system_module, only : dp, inoutput, print, PRINT_VERBOSE, verbosity_push_decrement, verbosity_pop, operator(//) -use units_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Tersoff -type IPModel_Tersoff - integer :: n_types = 0 !% Number of atomic types - integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connections - - real(dp), allocatable :: A(:), B(:), lambda(:), mu(:), beta(:) !% IP parameters dimensioned as \texttt{n_types} - real(dp), allocatable :: n(:), c(:), d(:), h(:), R(:), S(:) !% IP parameters dimensioned as \texttt{n_types} - real(dp), allocatable :: chi(:,:) !% IP parameter depending on the pair interaction (mixing hentalpy), dimensioned as \texttt{(n_types,n_types)} - - character(len=STRING_LENGTH) :: label - -end type IPModel_Tersoff - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Tersoff), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Tersoff_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Tersoff_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Tersoff_Print -end interface Print - -interface Calc - module procedure IPModel_Tersoff_Calc -end interface Calc - -contains - -subroutine IPModel_Tersoff_Initialise_str(this, args_str, param_str) - type(IPModel_Tersoff), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Tersoff_Initialise_str args_str')) then - call system_abort("IPModel_Tersoff_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call IPModel_Tersoff_read_params_xml(this, param_str) - -end subroutine IPModel_Tersoff_Initialise_str - -subroutine IPModel_Tersoff_Finalise(this) - type(IPModel_Tersoff), intent(inout) :: this - - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - - if (allocated(this%A)) deallocate(this%A) - if (allocated(this%B)) deallocate(this%B) - if (allocated(this%lambda)) deallocate(this%lambda) - if (allocated(this%mu)) deallocate(this%mu) - if (allocated(this%beta)) deallocate(this%beta) - if (allocated(this%n)) deallocate(this%n) - if (allocated(this%c)) deallocate(this%c) - if (allocated(this%d)) deallocate(this%d) - if (allocated(this%h)) deallocate(this%h) - if (allocated(this%R)) deallocate(this%R) - if (allocated(this%S)) deallocate(this%S) - if (allocated(this%chi)) deallocate(this%chi) - - this%n_types = 0 - this%label = '' -end subroutine IPModel_Tersoff_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator. It computes energy, forces and virial. -!% Derivatives are taken from M. Tang, Ph.D. Thesis, MIT 1995. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -subroutine IPModel_Tersoff_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Tersoff), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp), pointer :: w_e(:) - integer i, ji, j, ki, k - integer ti, tj, tk - real(dp) :: dr_ij(3), dr_ij_mag, dr_ik(3), dr_ik_mag, dr_jk(3), dr_jk_mag - real(dp) :: dr_ij_diff(3), dr_ik_diff(3) - real(dp) :: w_f - - real(dp), allocatable :: z_ij(:) - real(dp) :: AA_ij, BB_ij, lambda_ij, mu_ij, beta_i, n_i, c_i, d_i, h_i, R_ij, S_ij, chi_ij; - real(dp) :: zeta_ij, b_ij, V_ij_R, V_ij_A, f_C_ij; - real(dp) :: R_ik, S_ik, cos_theta_ijk; - real(dp) :: exp_lambda_ij, exp_mu_ij - - real(dp) :: de - - real(dp) :: dr_ij_mag_dr_i(3), dr_ij_mag_dr_j(3) - real(dp) :: dr_ik_mag_dr_i(3), dr_ik_mag_dr_k(3) - real(dp) :: dr_jk_mag_dr_j(3), dr_jk_mag_dr_k(3) - real(dp) :: f_C_ij_d, dV_ij_R_dr_ij_mag - real(dp) :: f_C_ik - - real(dp) :: dcos_theta_ijk_dr_ij_mag, dcos_theta_ijk_dr_ik_mag, dcos_theta_ijk_dr_jk_mag - real(dp) :: dg_dcos_theta_ijk - - real(dp) :: beta_i_db_ij_dz_ij - real(dp) :: dzeta_ij_dr_ij_mag, dzeta_ij_dr_ik_mag, dzeta_ij_dr_jk_mag - real(dp) :: db_ij_dr_ij_mag, db_ij_dr_ik_mag, db_ij_dr_jk_mag - real(dp) :: dV_ij_A_dr_ij_mag, dV_ij_A_dr_ik_mag, dV_ij_A_dr_jk_mag - real(dp) :: virial_i(3,3) - - type(Dictionary) :: params - logical, dimension(:), pointer :: atom_mask_pointer - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - if (present(e)) e = 0.0_dp - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Tersoff_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_Tersoff_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) then - virial = 0.0_dp - endif - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_Tersoff_Calc', error) - local_virial = 0.0_dp - endif - - if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) - - atom_mask_pointer => null() - if(present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Tersoff_Calc args_str')) & - call system_abort("IPModel_Tersoff_Calc failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_Tersoff_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - else - atom_mask_pointer => null() - endif - else - do_rescale_r = .false. - do_rescale_E = .false. - endif - - if (do_rescale_r) call print('IPModel_Tersoff_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) - if (do_rescale_E) call print('IPModel_Tersoff_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) - - do i=1, at%N - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if(associated(atom_mask_pointer)) then - if(.not. atom_mask_pointer(i)) cycle - endif - - allocate(z_ij(n_neighbours(at,i))) - ti = get_type(this%type_of_atomic_num, at%Z(i)) - - ! calculate z_ij = beta_i zeta_ij - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dr_ij_mag, cosines = dr_ij) - if (dr_ij_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) dr_ij_mag = dr_ij_mag*r_scale - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - S_ij = sqrt(this%S(ti)*this%S(tj)) - if (dr_ij_mag < S_ij) then - beta_i = this%beta(ti) - R_ij = sqrt(this%R(ti)*this%R(tj)) - c_i = this%c(ti) - d_i = this%d(ti) - h_i = this%h(ti) - else - cycle - endif - - zeta_ij = 0.0_dp - do ki=1, n_neighbours(at, i) - if (ki == ji) cycle - k = neighbour(at, i, ki, dr_ik_mag, cosines = dr_ik) - if (dr_ik_mag .feq. 0.0_dp) cycle - if (do_rescale_r) dr_ik_mag = dr_ik_mag*r_scale - - tk = get_type(this%type_of_atomic_num, at%Z(k)) - - R_ik = sqrt(this%R(ti)*this%R(tk)) - S_ik = sqrt(this%S(ti)*this%S(tk)) - cos_theta_ijk = sum(dr_ij*dr_ik) - zeta_ij = zeta_ij + f_C(dr_ik_mag, R_ik, S_ik)*g(cos_theta_ijk, c_i, d_i, h_i) - end do - z_ij(ji) = beta_i*zeta_ij - end do ! ji (calc z_ij) - - ! calculate energies, forces, etc - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dr_ij_mag, dr_ij_diff, dr_ij) - if (dr_ij_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) then - dr_ij_mag = dr_ij_mag * r_scale - dr_ij_diff = dr_ij_diff * r_scale - end if - - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - S_ij = sqrt(this%S(ti)*this%S(tj)) - if (dr_ij_mag < S_ij) then - n_i = this%n(ti) - R_ij = sqrt(this%R(ti)*this%R(tj)) - AA_ij = sqrt(this%A(ti)*this%A(tj)) - BB_ij = sqrt(this%B(ti)*this%B(tj)) - lambda_ij = 0.5_dp*(this%lambda(ti)+this%lambda(tj)) - mu_ij = 0.5_dp*(this%mu(ti)+this%mu(tj)) - chi_ij = this%chi(ti,tj) - else - cycle - endif - - b_ij = chi_ij*(1.0_dp + z_ij(ji)**n_i)**(-1.0_dp/(2*n_i)) - f_C_ij = f_C(dr_ij_mag, R_ij, S_ij) - exp_lambda_ij = exp(-lambda_ij*dr_ij_mag) - exp_mu_ij = exp(-mu_ij*dr_ij_mag) - V_ij_R = f_C_ij * (AA_ij * exp_lambda_ij) - V_ij_A = f_C_ij * (-b_ij*BB_ij * exp_mu_ij) - - if (associated(w_e)) then - w_f = 0.5_dp*(w_e(i)+w_e(j)) - else - w_f = 1.0_dp - endif - - if (present(e) .or. present(local_e)) then - ! factor of 0.5 because Tersoff definition goes over each pair only once - de = 0.5_dp*(V_ij_R + v_ij_A) - if (present(local_e)) then - local_e(i) = local_e(i) + de - endif - if (present(e)) then - e = e + de*w_f - endif - endif - - if (present(f) .or. present(virial) .or. present(local_virial)) then - dr_ij_mag_dr_i = -dr_ij - dr_ij_mag_dr_j = dr_ij - - f_C_ij_d = f_C_d(dr_ij_mag, R_ij, S_ij) - dV_ij_R_dr_ij_mag = f_C_ij_d*AA_ij*exp_lambda_ij + f_C_ij*AA_ij*(-lambda_ij)*exp_lambda_ij - if (present(f)) then - f(:,i) = f(:,i) - 0.5_dp*w_f * dV_ij_R_dr_ij_mag * dr_ij_mag_dr_i(:) - f(:,j) = f(:,j) - 0.5_dp*w_f * dV_ij_R_dr_ij_mag * dr_ij_mag_dr_j(:) - endif - if (present(virial) .or. present(local_virial)) virial_i = 0.5_dp*w_f * dV_ij_R_dr_ij_mag * (dr_ij .outer. dr_ij) * dr_ij_mag - if (present(virial)) virial = virial - virial_i - if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) - - if (z_ij(ji) .fne. 0.0_dp) then - beta_i_db_ij_dz_ij = beta_i* ( -0.5_dp*chi_ij * & - ( ( 1.0_dp+z_ij(ji)**n_i)**(-(1.0_dp+2.0_dp*n_i)/(2.0_dp*n_i)) ) * & - ( z_ij(ji)**(n_i-1.0_dp) ) ) - else - beta_i_db_ij_dz_ij = -1.0_dp - endif - - do ki=1, n_neighbours(at,i) - if (ki == ji) cycle - k = neighbour(at, i, ki, dr_ik_mag, dr_ik_diff, dr_ik) - if (dr_ik_mag .feq. 0.0_dp) cycle - - if (do_rescale_r) then - dr_ik_mag = dr_ik_mag * r_scale - dr_ik_diff = dr_ik_diff * r_scale - end if - - tk = get_type(this%type_of_atomic_num, at%Z(k)) - - dr_ik_mag_dr_i = -dr_ik - dr_ik_mag_dr_k = dr_ik - - cos_theta_ijk = sum(dr_ij*dr_ik) - - dcos_theta_ijk_dr_ij_mag = 1.0_dp/dr_ik_mag - cos_theta_ijk/dr_ij_mag - dcos_theta_ijk_dr_ik_mag = 1.0_dp/dr_ij_mag - cos_theta_ijk/dr_ik_mag - - dr_jk = dr_ik_diff - dr_ij_diff - dr_jk_mag = sqrt(sum(dr_jk*dr_jk)) - dr_jk = dr_jk/dr_jk_mag - - dr_jk_mag_dr_j = -dr_jk - dr_jk_mag_dr_k = dr_jk - - dcos_theta_ijk_dr_jk_mag = -dr_jk_mag/(dr_ij_mag*dr_ik_mag) - dg_dcos_theta_ijk = dg_dcos_theta(cos_theta_ijk, c_i, d_i, h_i) - - R_ik = sqrt(this%R(ti)*this%R(tk)) - S_ik = sqrt(this%S(ti)*this%S(tk)) - f_C_ik = f_C(dr_ik_mag, R_ik, S_ik) - - dzeta_ij_dr_ij_mag = f_C_ik * dg_dcos_theta_ijk * dcos_theta_ijk_dr_ij_mag - dzeta_ij_dr_jk_mag = f_C_ik * dg_dcos_theta_ijk * dcos_theta_ijk_dr_jk_mag - - dzeta_ij_dr_ik_mag = f_C_ik * dg_dcos_theta_ijk * dcos_theta_ijk_dr_ik_mag + & - f_C_d(dr_ik_mag, R_ik, S_ik) * g(cos_theta_ijk, c_i, d_i, h_i) - - db_ij_dr_ij_mag = beta_i_db_ij_dz_ij*dzeta_ij_dr_ij_mag - db_ij_dr_ik_mag = beta_i_db_ij_dz_ij*dzeta_ij_dr_ik_mag - db_ij_dr_jk_mag = beta_i_db_ij_dz_ij*dzeta_ij_dr_jk_mag - - dV_ij_A_dr_ij_mag = f_C_ij*(-db_ij_dr_ij_mag*BB_ij*exp_mu_ij) - dV_ij_A_dr_ik_mag = f_C_ij*(-db_ij_dr_ik_mag*BB_ij*exp_mu_ij) - dV_ij_A_dr_jk_mag = f_C_ij*(-db_ij_dr_jk_mag*BB_ij*exp_mu_ij) - - if (present(f)) then - f(:,i) = f(:,i) - w_f*( 0.5_dp * dV_ij_A_dr_ik_mag*dr_ik_mag_dr_i(:) + & - 0.5_dp * dV_ij_A_dr_ij_mag*dr_ij_mag_dr_i(:) ) - - f(:,j) = f(:,j) - w_f*( 0.5_dp * dV_ij_A_dr_jk_mag*dr_jk_mag_dr_j(:) + & - 0.5_dp * dV_ij_A_dr_ij_mag*dr_ij_mag_dr_j(:) ) - - f(:,k) = f(:,k) - w_f*( 0.5_dp*dV_ij_A_dr_ik_mag*dr_ik_mag_dr_k(:) + & - 0.5_dp*dV_ij_A_dr_jk_mag*dr_jk_mag_dr_k(:) ) - end if - - if (present(virial) .or. present(local_virial)) virial_i = & - w_f*0.5_dp*( dV_ij_A_dr_ij_mag*(dr_ij .outer. dr_ij)*dr_ij_mag + & - dV_ij_A_dr_ik_mag*(dr_ik .outer. dr_ik)*dr_ik_mag + & - dV_ij_A_dr_jk_mag*(dr_jk .outer. dr_jk)*dr_jk_mag) - - if (present(virial)) virial = virial - virial_i - if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) - - end do ! ki - dV_ij_A_dr_ij_mag = f_C_ij_d*(-b_ij*BB_ij*exp_mu_ij) + & - f_C_ij*(-b_ij*BB_ij*(-mu_ij)*exp_mu_ij) - - if (present(f)) then - f(:,i) = f(:,i) - 0.5_dp*w_f * dV_ij_A_dr_ij_mag * dr_ij_mag_dr_i(:) - f(:,j) = f(:,j) - 0.5_dp*w_f * dV_ij_A_dr_ij_mag * dr_ij_mag_dr_j(:) - endif - if (present(virial)) virial_i = & - 0.5_dp*w_f * dV_ij_A_dr_ij_mag*(dr_ij .outer. dr_ij)*dr_ij_mag - if (present(virial)) virial = virial - virial_i - if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) - - endif ! present(f) - - end do ! ji - deallocate(z_ij) - end do ! i - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(f)) call sum_in_place(mpi, f) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(local_virial)) call sum_in_place(mpi, local_virial) - endif - - if (do_rescale_r) then - if (present(f)) f = f*r_scale - end if - - if (do_rescale_E) then - if (present(e)) e = e*E_scale - if (present(local_e)) local_e = local_e*E_scale - if (present(f)) f = f*E_scale - if (present(virial)) virial=virial*E_scale - if (present(local_virial)) local_virial=local_virial*E_scale - end if - - atom_mask_pointer => null() - -end subroutine IPModel_Tersoff_Calc - -!% Compute the cutoff function. -function f_C(r, RR, SS) - real(dp), intent(in) :: r - real(dp), intent(in) :: RR, SS - real(dp) :: f_C - - if (r <= RR) then - f_C = 1.0_dp - else if (r <= SS) then - f_C = 0.5+0.5*cos(PI*(r-RR)/(SS-RR)) - else - f_C = 0.0_dp - endif -end function f_C - -!% Compute the derivative of the cutoff function. -function f_C_d(r, RR, SS) - real(dp), intent(in) :: r - real(dp), intent(in) :: RR, SS - real(dp) :: f_C_d - - if (r <= RR) then - f_C_d = 0.0_dp - else if (r <= SS) then - f_C_d = -0.5*PI/(SS-RR) * sin(PI*(r-RR)/(SS-RR)) - else - f_C_d = 0.0_dp - endif -end function f_C_d - -!% Compute the angular term g for the bond-order coefficient. -function g(cos_theta, c, d, h) - real(dp), intent(in) :: cos_theta - real(dp), intent(in) :: c, d, h - real(dp) :: g - - g = 1.0 + (c*c)/(d*d) - (c*c)/(d*d+(h-cos_theta)*(h-cos_theta)); -end function g - -!% Compute the derivative of the angular term for the bond-order coefficient. -function dg_dcos_theta(cos_theta, c, d, h) - real(dp), intent(in) :: cos_theta - real(dp), intent(in) :: c, d, h - real(dp) :: dg_dcos_theta - - real(dp) :: t - - t = d*d + (h-cos_theta)*(h-cos_theta); - dg_dcos_theta = (-2.0_dp*c*c*(h-cos_theta))/(t*t) - -end function dg_dcos_theta - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X XML param reader functions -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - - integer ti, tj - - if (name == 'Tersoff_params') then ! new Tersoff stanza - - if (parse_in_ip) & - call system_abort("IPModel_startElement_handler entered Tersoff_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if (value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - endif - - if (parse_in_ip) then - if (parse_ip%n_types /= 0) then - call finalise(parse_ip) - endif - - call QUIP_FoX_get_value(attributes, "n_types", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find n_types") - read (value, *) parse_ip%n_types - - allocate(parse_ip%atomic_num(parse_ip%n_types)) - parse_ip%atomic_num = 0 - - allocate(parse_ip%A(parse_ip%n_types)) - allocate(parse_ip%B(parse_ip%n_types)) - allocate(parse_ip%lambda(parse_ip%n_types)) - allocate(parse_ip%mu(parse_ip%n_types)) - allocate(parse_ip%beta(parse_ip%n_types)) - allocate(parse_ip%n(parse_ip%n_types)) - allocate(parse_ip%c(parse_ip%n_types)) - allocate(parse_ip%d(parse_ip%n_types)) - allocate(parse_ip%h(parse_ip%n_types)) - allocate(parse_ip%R(parse_ip%n_types)) - allocate(parse_ip%S(parse_ip%n_types)) - allocate(parse_ip%chi(parse_ip%n_types,parse_ip%n_types)) - - endif - - elseif (parse_in_ip .and. name == 'per_type_data') then - - call QUIP_FoX_get_value(attributes, "type", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find type") - read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find atomic_num") - read (value, *) parse_ip%atomic_num(ti) - - call QUIP_FoX_get_value(attributes, "A", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find A") - read (value, *) parse_ip%A(ti) - call QUIP_FoX_get_value(attributes, "B", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find B") - read (value, *) parse_ip%B(ti) - call QUIP_FoX_get_value(attributes, "lambda", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find lambda") - read (value, *) parse_ip%lambda(ti) - call QUIP_FoX_get_value(attributes, "mu", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find mu") - read (value, *) parse_ip%mu(ti) - call QUIP_FoX_get_value(attributes, "beta", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find beta") - read (value, *) parse_ip%beta(ti) - call QUIP_FoX_get_value(attributes, "n", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find n") - read (value, *) parse_ip%n(ti) - call QUIP_FoX_get_value(attributes, "c", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find c") - read (value, *) parse_ip%c(ti) - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find d") - read (value, *) parse_ip%d(ti) - call QUIP_FoX_get_value(attributes, "h", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find h") - read (value, *) parse_ip%h(ti) - call QUIP_FoX_get_value(attributes, "R", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find R") - read (value, *) parse_ip%R(ti) - call QUIP_FoX_get_value(attributes, "S", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find S") - read (value, *) parse_ip%S(ti) - - parse_ip%cutoff = maxval(parse_ip%S) - - if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) - allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) - parse_ip%type_of_atomic_num = 0 - do ti=1, parse_ip%n_types - if (parse_ip%atomic_num(ti) > 0) & - parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti - end do - - elseif (parse_in_ip .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "type1", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find type1") - read (value, *) ti - call QUIP_FoX_get_value(attributes, "type2", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find type2") - read (value, *) tj - - call QUIP_FoX_get_value(attributes, "chi", value, status) - if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find chi") - read (value, *) parse_ip%chi(ti,tj) - if (ti /= tj) then - parse_ip%chi(tj,ti) = parse_ip%chi(ti,tj) - endif - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if (name == 'Tersoff_params') then - parse_in_ip = .false. - endif - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_Tersoff_read_params_xml(this, param_str) - type(IPModel_Tersoff), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type (xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_ip => this - parse_in_ip = .false. - parse_matched_label = .false. - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types == 0) then - call system_abort("IPModel_Tersoff_read_params_xml parsed file, but n_types = 0") - endif - -end subroutine IPModel_Tersoff_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of Tersoff parameters: number of different types, cutoff radius, atomic numbers, ect. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_Tersoff_Print (this, file) - type(IPModel_Tersoff), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer :: ti, tj - - call Print("IPModel_Tersoff : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) - - do ti=1, this%n_types - call Print("IPModel_Tersoff : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) - call verbosity_push_decrement() - call Print ("IPModel_Tersoff : params A "//this%A(ti) //" B "// this%B(ti)//" lambda "// this%lambda(ti)//" mu "// & - this%mu(ti)// " beta " // this%beta(ti), file=file) - call Print ("IPModel_Tersoff : params n "// this%n(ti)//" c "// this%c(ti)//" d "// this%d(ti)//" h "// this%h(ti) & - // " R "// this%R(ti)//" S " // this%S(ti), file=file) - do tj=1, this%n_types - call Print ("IPModel_tersoff : pair "// ti // " " // tj // " chi " // this%chi(ti,tj), file=file) - end do - call verbosity_pop() - end do - -end subroutine IPModel_Tersoff_Print - -end module IPModel_Tersoff_module diff --git a/src/Potentials/IPModel_Tether.f95 b/src/Potentials/IPModel_Tether.f95 deleted file mode 100644 index 9128d45288..0000000000 --- a/src/Potentials/IPModel_Tether.f95 +++ /dev/null @@ -1,197 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_Tether -!X -!% Tether a selection of atoms to the origin with a spring: -!% -!% Energy and Force routines are hardwired -!% Cutoff is hardwired -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_Tether_module - -use error_module -use system_module, only : dp, inoutput, print, operator(//), split_string,string_to_int -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_Tether -type IPModel_Tether - real(dp) :: cutoff = 0.0_dp - real(dp) :: r0 = 0.0_dp - real(dp) :: kconf = 0.0_dp - integer,allocatable,dimension(:) :: tether_indices -end type IPModel_Tether - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_Tether), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_Tether_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_Tether_Finalise -end interface Finalise - -interface Print - module procedure IPModel_Tether_Print -end interface Print - -interface Calc - module procedure IPModel_Tether_Calc -end interface Calc - -contains - -subroutine IPModel_Tether_Initialise_str(this, args_str, param_str, error) - type(IPModel_Tether), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out):: error - character(len=STRING_LENGTH) :: indices_string - character(len=STRING_LENGTH), dimension(99) :: indices_fields - integer:: i,n_tethered - - INIT_ERROR(error) - call Finalise(this) - - call initialise(params) - call param_register(params, 'kconf', '0.0', this%kconf, help_string='strength of quadratic confinement potential on atoms. potential is kconf*(r - r0)^2') - call param_register(params, 'r0', '0.0', this%r0, help_string='distance at which quadratic confinement potential on atoms begins. potential is kconf*(r - r0)^2') - call param_register(params, 'indices', PARAM_MANDATORY, indices_string, help_string="Indices (1-based) of the atoms you wish to tether, format {i1 i2 i3 ...}") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_Tether_Initialise args_str')) then - RAISE_ERROR("IPModel_Tether_Init failed to parse args_str='"//trim(args_str)//"'", error) - end if - call finalise(params) - - call split_string(indices_string,' ','{}',indices_fields(:),n_tethered,matching=.true.) - allocate(this%tether_indices(n_tethered)) - - do i=1,n_tethered - this%tether_indices(i) = string_to_int(indices_fields(i)) - end do - - -end subroutine IPModel_Tether_Initialise_str - -subroutine IPModel_Tether_Finalise(this) - type(IPModel_Tether), intent(inout) :: this - - ! Add finalisation code here - -end subroutine IPModel_Tether_Finalise - - -subroutine IPModel_Tether_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_Tether), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - - real(dp) :: energy, force(3,at%N), r, disp, dr(3), origin(3)=0.0_dp - integer :: i , n_tethered, i_teth - - n_tethered=size(this%tether_indices) - - INIT_ERROR(error) - - ! Harmonic confining potential on tethered atoms - energy = 0.0_dp - force = 0.0_dp - do i=1,n_tethered - i_teth = this%tether_indices(i) - - r = distance_min_image(at, i_teth , origin) - - if(r .fgt. this%r0) then - disp = r - this%r0 - ! energy - energy = energy + this%kConf*disp**2 - ! force - dr = diff_min_image(at, i_teth, origin)/r - force(:,i_teth) = ( 2.0_dp*this%kConf*disp ) * dr - end if - end do - - if (present(e)) e = energy - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_Tether_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Tether_Calc', error) - f = force - end if - if (present(virial)) virial = 0.0_dp - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Tether_Calc', error) - local_virial = 0.0_dp - endif - -end subroutine IPModel_Tether_Calc - - -subroutine IPModel_Tether_Print(this, file) - type(IPModel_Tether), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_Tether : Tether Potential", file=file) - call Print("IPModel_Tether : cutoff = " // this%cutoff, file=file) - call Print("IPModel_Tether : kconf = " // this%kconf, file=file) - call Print("IPModel_Tether : tethered atoms = " // this%tether_indices, file=file) - -end subroutine IPModel_Tether_Print - - -end module IPModel_Tether_module diff --git a/src/Potentials/IPModel_WaterDimer_Gillan.f95 b/src/Potentials/IPModel_WaterDimer_Gillan.f95 deleted file mode 100644 index fdae127062..0000000000 --- a/src/Potentials/IPModel_WaterDimer_Gillan.f95 +++ /dev/null @@ -1,1027 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_WaterDimer_Gillan -!X -!% Interaction of two water molecules, parametrised by Mike Gillan in 2011 -!% -!% only expected to be accurate at long range ($> 5 \AA$). Parameters are -!% fitted to MP2 AVTZ energies -!% -!% Energy only -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_WaterDimer_Gillan_module - -use error_module -use system_module, only : dp, inoutput, print, operator(//) -use units_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use spline_module -use quaternions_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_WaterDimer_Gillan -type IPModel_WaterDimer_Gillan - real(dp) :: cutoff = 0.0_dp - character(len=STRING_LENGTH) :: fname_d, fname_q - real(dp) :: two_body_weight_roo = 0.0_dp - real(dp) :: two_body_weight_delta = 0.0_dp - logical :: do_two_body_weight = .false. - type(Spline) :: two_body_weight -end type IPModel_WaterDimer_Gillan - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_WaterDimer_Gillan), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_WaterDimer_Gillan_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_WaterDimer_Gillan_Finalise -end interface Finalise - -interface Print - module procedure IPModel_WaterDimer_Gillan_Print -end interface Print - -interface Calc - module procedure IPModel_WaterDimer_Gillan_Calc -end interface Calc - - -! module-gobal variables - -integer, parameter :: ngrid_mx=20 -integer :: lin3d_2_igotdata, lin3d_2_itab_print, lin3d_2_nxsup, lin3d_2_nysup, lin3d_2_nzsup -real(dp) :: lin3d_2_xinf, lin3d_2_xsup, lin3d_2_yinf, lin3d_2_ysup, lin3d_2_zinf, lin3d_2_zsup -real(dp) :: lin3d_2_deltax, lin3d_2_deltay, lin3d_2_deltaz -real(dp) :: lin3d_2_f1tab(ngrid_mx, ngrid_mx, ngrid_mx), lin3d_2_f2tab(ngrid_mx, ngrid_mx, ngrid_mx) -integer :: lin3d_3_igotdata, lin3d_3_itab_print, lin3d_3_nxsup, lin3d_3_nysup, lin3d_3_nzsup -real(dp) :: lin3d_3_xinf, lin3d_3_xsup, lin3d_3_yinf, lin3d_3_ysup, lin3d_3_zinf, lin3d_3_zsup -real(dp) :: lin3d_3_deltax, lin3d_3_deltay, lin3d_3_deltaz -real(dp) :: lin3d_3_f1tab(ngrid_mx, ngrid_mx, ngrid_mx), lin3d_3_f2tab(ngrid_mx, ngrid_mx, ngrid_mx), lin3d_3_f3tab(ngrid_mx, ngrid_mx, ngrid_mx) -contains - -subroutine IPModel_WaterDimer_Gillan_Initialise_str(this, args_str, param_str, error) - type(IPModel_WaterDimer_Gillan), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out) :: error - integer:: init3d - real(dp) :: theta, r1, r2, f1, f2, f3 - - INIT_ERROR(error) - - call Finalise(this) - - - call initialise(params) - call param_register(params, 'dipole_file', PARAM_MANDATORY, this%fname_d, help_string="name of file which contains the dipole tables") - call param_register(params, 'quadrupole_file', PARAM_MANDATORY, this%fname_q, help_string="name of file which contains the quadrupole tables") - call param_register(params, 'two_body_weight_roo', '0.0', this%two_body_weight_roo, has_value_target=this%do_two_body_weight, help_string="if set, apply weight function to 2-body energy and force based on O-O distance. For a positive two_body_weight_delta, weight is 1 for rOO < two_body_weight_roo-two_body_weight_delta and weight is 0 for rOO > two_body_weight_roo+two_body_weight_delta") - call param_register(params, 'two_body_weight_delta', '0.25', this%two_body_weight_delta, help_string="width of weighting function for two_body energy and force based on O-O distance. For weighting to take effect, two_body_weight_roo needs to be explicitly set. For a positive two_body_weight_delta, weight is 1 for rOO < two_body_weight_roo-two_body_weight_delta and weight is 0 for rOO > two_body_weight_roo+two_body_weight_delta") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_WaterDimer_Gillan_Initialise args_str')) then - RAISE_ERROR("IPModel_WaterDimer_Gillan_Init failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - - if(this%do_two_body_weight) then - call initialise(this%two_body_weight, (/this%two_body_weight_roo - this%two_body_weight_delta, this%two_body_weight_roo + this%two_body_weight_delta/), (/1.0_dp, 0.0_dp/), 0.0_dp, 0.0_dp) - end if - - ! read interpolation tables - init3d = 0 - - - call lin3d_2(init3d,theta,r1,r2,f1,f2, this%fname_d) - call lin3d_3(init3d,theta,r1,r2,f1,f2,f3,this%fname_q) - - -end subroutine IPModel_WaterDimer_Gillan_Initialise_str - - -subroutine IPModel_WaterDimer_Gillan_Finalise(this) - type(IPModel_WaterDimer_Gillan), intent(inout) :: this - - ! Add finalisation code here - - call finalise(this%two_body_weight) - -end subroutine IPModel_WaterDimer_Gillan_Finalise - - -subroutine IPModel_WaterDimer_Gillan_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_WaterDimer_Gillan), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - real(dp) :: dip_frac, pol_o, pol_h, c6oo, c6oh, c6hh - real(dp) :: atpos(2,3,3), axis(3) - real(dp) :: e_dqtot, e_ind, e_disp, elong_tot - integer :: nmolec, init3d - type(Quaternion) :: quat - - real(dp):: weight, dweight(3), rOiOj - - INIT_ERROR(error) - - ! Parameters - - dip_frac = 0.4_dp - pol_o = 7.0_dp - pol_h = 2.0_dp - c6oo = 25.0_dp - c6oh = 4.5_dp - c6hh = 2.0_dp - nmolec = 2 - - ! Rotate atoms so that rOO is along the z axis and O1 is at the origin - - !get rotation axis - axis = (at%pos(:,4)-at%pos(:,1)) .cross. (/0.0_dp,0.0_dp,1.0_dp/) - atpos(1,1,:) = at%pos(:,1)-at%pos(:,1) - atpos(1,2,:) = at%pos(:,2)-at%pos(:,1) - atpos(1,3,:) = at%pos(:,3)-at%pos(:,1) - atpos(2,1,:) = at%pos(:,4)-at%pos(:,1) - atpos(2,2,:) = at%pos(:,5)-at%pos(:,1) - atpos(2,3,:) = at%pos(:,6)-at%pos(:,1) - - if(axis .fne. (/0.0_dp,0.0_dp,0.0_dp/)) then - quat = orientation(at%pos(:,4)-at%pos(:,1), axis, (/0.0_dp,0.0_dp,1.0_dp/), axis) - - call rotate(atpos(1,1,:), quat) - call rotate(atpos(1,2,:), quat) - call rotate(atpos(1,3,:), quat) - call rotate(atpos(2,1,:), quat) - call rotate(atpos(2,2,:), quat) - call rotate(atpos(2,3,:), quat) - end if - - ! make that call - call h2o_dimer_far(dip_frac,pol_o,pol_h,c6oo,c6oh,c6hh,atpos,e_dqtot,e_ind,e_disp,elong_tot) - - if(this%do_two_body_weight) then - rOiOj = norm(diff_min_image(at, 1, 4)) - weight = spline_value(this%two_body_weight, rOiOj) - dweight = spline_deriv(this%two_body_weight, rOiOj) - else - weight = 1.0_dp - dweight = 0.0_dp - end if - - if (present(e)) e = elong_tot*HARTREE*weight - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_WaterDimer_Gillan_Calc', error) - local_e = 0.0_dp - endif - if (present(f)) then - f = 0.0_dp - !RAISE_ERROR('Forces not implemented', error) - end if - if (present(virial)) then - RAISE_ERROR('Virial not implemented', error) - else - virial = 0.0_dp - end if - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_WaterDimer_Gillan_Calc', error) - local_virial = 0.0_dp - endif - - -end subroutine IPModel_WaterDimer_Gillan_Calc - - -subroutine IPModel_WaterDimer_Gillan_Print(this, file) - type(IPModel_WaterDimer_Gillan), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_WaterDimer_Gillan : WaterDimer_Gillan Potential", file=file) - call Print("IPModel_WaterDimer_Gillan : cutoff = " // this%cutoff, file=file) - if(this%do_two_body_weight) then - call print("Two-body term is weighted with parameters x0="//this%two_body_weight_roo//" delta="//this%two_body_weight_delta, file=file) - end if - -end subroutine IPModel_WaterDimer_Gillan_Print - -! ===================================================================== -! sbrt computes long-range 2-body energy of H2O dimer, using simple -! distributed multipole model plus simple models for induction -! and dispersion. -! --------------------------------------------------------------------- - subroutine h2o_dimer_far(dip_frac,pol_o,pol_h,c6oo,c6oh,c6hh,atpos,e_dqtot,e_ind,e_disp,elong_tot) - implicit none -! ... variables in argument list - real(dp):: dip_frac, pol_o, pol_h, c6oo, c6oh, c6hh - real(dp):: atpos(2,3,3) - real(dp):: e_dqtot, e_ind, e_disp, elong_tot -! ... local variables - real*8 pi, bohr - parameter (pi = 3.14159265359, bohr = 0.52917720859) - integer init3d - integer mo, na, ns, i, j, k, m - real*8 f1, f2, f3 - real*8 r1, r2, theta, theta_deg, r1sq, r2sq, scprod - real*8 sinfun, cosfun, tanfun, cotfun - real*8 mux, muz, qxx, qzz, qxz, rmu_scal - real*8 xmagsq, zmagsq, xnorm, znorm - real*8 bvec_0(2,3), bvec_bohr_0(2,3), bvec_r(2,2,3) - real*8 rlocvec(3,3) - real*8 univec(2,3) - real*8 dipvec_0(3) - real*8 quadten_0(9), quadten_d(9) - real*8 ddvec_0(3,3) - real*8 ddvec_r(2,3,3) - real*8 quadten_r(2,9) - real*8 dv1o(3), dv1h1(3), dv1h2(3), dv2o(3), dv2h1(3),dv2h2(3) - real*8 qt1(9) ,qt2(9), sepoo(3) - real*8 rroo(3), rroh1(3), rroh2(3), rrh1o(3), rrh1h1(3), rrh1h2(3), rrh2o(3), rrh2h1(3), rrh2h2(3) - real*8 dd_int_oo, dd_int_oh1, dd_int_oh2, dd_int_h1o, dd_int_h1h1, dd_int_h1h2, dd_int_h2o, dd_int_h2h1, dd_int_h2h2, dd_int - real*8 dq_int_oo, dq_int_h1o, dq_int_h2o, dq_int - real*8 qd_int_oo, qd_int_oh1, qd_int_oh2, qd_int, qq_int - real*8 e_ind_1o, e_ind_1h1, e_ind_1h2, e_ind_2o, e_ind_2h1, e_ind_2h2 - real*8 d6oo, d6oh1, d6oh2, d6h1o, d6h1h1, d6h1h2, d6h2o, d6h2h1, d6h2h2 - real*8 evec1(3), evec2(3), evec3(3), evec4(3), evect(3) - character(len=STRING_LENGTH) fname -! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -! begin loop over monomers -! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - do mo = 1, 2 -! ... make the two bond vectors bvec_r drawn from O to H1 and O to H2 -! ... for present monomer -! write(*,111) -! 111 format(/'bond lengths r1, r2 and bond angle theta ', -! * 'for monomers:') -! write(*,112) mo -! 112 format('monomer no:',i5) - r1sq = 0.d0 - r2sq = 0.d0 - scprod = 0.d0 - do i = 1, 3 - bvec_r(mo,1,i) = atpos(mo,2,i) - atpos(mo,1,i) - r1sq = r1sq + bvec_r(mo,1,i)*bvec_r(mo,1,i) - bvec_r(mo,2,i) = atpos(mo,3,i) - atpos(mo,1,i) - r2sq = r2sq + bvec_r(mo,2,i)*bvec_r(mo,2,i) - scprod = scprod + bvec_r(mo,1,i)*bvec_r(mo,2,i) - enddo - r1 = sqrt(r1sq) - r2 = sqrt(r2sq) - theta = acos(scprod/(r1*r2)) - theta_deg = (180.d0/pi)*theta -! write(*,113) r1 -! 113 format('bond length O-H1:',f15.6,' angstrom') -! write(*,114) r2 -! 114 format('bond length O-H2:',f15.6,' angstrom') -! write(*,115) theta_deg -! 115 format('bond angle H-O-H:',f15.6,' degrees') -! ... unit vectors along local x, y and z axes - do i = 1, 3 - univec(1,i) = bvec_r(mo,1,i)/r1 - univec(2,i) = bvec_r(mo,2,i)/r2 - enddo - xmagsq = 0.d0 - zmagsq = 0.d0 - do i = 1, 3 - rlocvec(1,i) = univec(1,i) - univec(2,i) - xmagsq = xmagsq + rlocvec(1,i)*rlocvec(1,i) - rlocvec(3,i) = univec(1,i) + univec(2,i) - zmagsq = zmagsq + rlocvec(3,i)*rlocvec(3,i) - enddo - xnorm = sqrt(xmagsq) - znorm = sqrt(zmagsq) - do i = 1, 3 - rlocvec(1,i) = rlocvec(1,i)/xnorm - rlocvec(3,i) = rlocvec(3,i)/znorm - enddo - rlocvec(2,1) = rlocvec(3,2)*rlocvec(1,3) - rlocvec(3,3)*rlocvec(1,2) - rlocvec(2,2) = rlocvec(3,3)*rlocvec(1,1) - rlocvec(3,1)*rlocvec(1,3) - rlocvec(2,3) = rlocvec(3,1)*rlocvec(1,2) - rlocvec(3,2)*rlocvec(1,1) -! write(*,121) -! 121 format(/'local x, y and z unit vectors:') -! do ns = 1, 3 -! write(*,122) (rlocvec(ns,i), i = 1, 3) -! 122 format(3x,3f12.6) -! enddo -! ... bond vectors in local frame - sinfun = sin(0.5d0*theta) - cosfun = cos(0.5d0*theta) - tanfun = sinfun/cosfun - cotfun = cosfun/sinfun - bvec_0(1,1) = r1*sinfun - bvec_0(1,2) = 0.d0 - bvec_0(1,3) = r1*cosfun - bvec_0(2,1) = -r2*sinfun - bvec_0(2,2) = 0.d0 - bvec_0(2,3) = r2*cosfun - do ns = 1, 2 - do i = 1, 3 - bvec_bohr_0(ns,i) = bvec_0(ns,i)/bohr - enddo - enddo -! ... for present monomer, compute components of -! ... dipole vector and quadrupole tensor in local frame. -! ... Local frame is defined thus: -! ... z-axis is along bisector of H-O-H angle, with bond vectors drawn -! ... from O to H having positive z-components -! ... x-axis is in molecular plane and is perpendicular to z-axis, -! ... with bond vector drawn from O to H1 having positive x-component -! ... bond vector from O to H2 having negative x-component. -! ... y-axis is perpendicular to x- and z-axes, in direction such that -! ... x-, y- and z-axes form a normal right-handed set. -! ... dipole vector - init3d = 1 - fname=repeat(' ',20) - call lin3d_2(init3d,theta_deg,r1,r2,mux,muz,fname) - dipvec_0(1) = mux - dipvec_0(2) = 0.d0 - dipvec_0(3) = muz -! write(*,131) -! 131 format('x-, y- and z-components of dipole vector:') -! write(*,132) (dipvec_0(i), i = 1, 3) -! 132 format(3x,3f15.6) -! ... compute components of quadrupole tensor - init3d = 1 - fname=repeat(' ',20) - call lin3d_3(init3d,theta_deg,r1,r2,qxx,qzz,qxz,fname) - quadten_0(1) = qxx - quadten_0(2) = 0.d0 - quadten_0(3) = qxz - quadten_0(4) = 0.d0 - quadten_0(5) = -qxx - qzz - quadten_0(6) = 0.d0 - quadten_0(7) = qxz - quadten_0(8) = 0.d0 - quadten_0(9) = qzz -! write(*,141) -! 141 format('xx, xy, xz, yx, yy, yz, zx, zy, zz components of ', -! * 'quadrupole tensor:') -! do i = 1, 3 -! write(*,142) (quadten_0(3*(i-1)+j), j = 1, 3) -! 142 format(3x,3f15.6) -! enddo -! ... distribute dipole vector between O and H atoms - ddvec_0(1,1) = (1.d0 - dip_frac)*dipvec_0(1) - ddvec_0(1,2) = 0.d0 - ddvec_0(1,3) = (1.d0 - dip_frac)*dipvec_0(3) - ddvec_0(2,1) = 0.5d0*dip_frac*(dipvec_0(1) + tanfun*dipvec_0(3)) - ddvec_0(2,2) = 0.d0 - ddvec_0(2,3) = 0.5d0*dip_frac*(cotfun*dipvec_0(1) + dipvec_0(3)) - ddvec_0(3,1) = 0.5d0*dip_frac*(dipvec_0(1) - tanfun*dipvec_0(3)) - ddvec_0(3,2) = 0.d0 - ddvec_0(3,3) = 0.5d0*dip_frac*(-cotfun*dipvec_0(1) + dipvec_0(3)) -! write(*,151) -! 151 format('components of dipole vectors on O, H1 and H2: ') -! do i = 1, 3 -! write(*,152) (ddvec_0(i,j), j = 1, 3) -! 152 format(3x,3f15.6) -! enddo -! ... adjust quadrupole tensor to compensate for distributed dipole - do ns = 1, 2 - rmu_scal = 0.d0 - do i = 1, 3 - rmu_scal = rmu_scal + bvec_bohr_0(ns,i)*ddvec_0(ns+1,i) - enddo - do i = 1, 3 - k = 3*(i-1) + i - quadten_0(k) = quadten_0(k) + rmu_scal - enddo - do i = 1, 3 - do j = 1, 3 - k = 3*(i-1) + j - quadten_0(k) = quadten_0(k) - 1.5d0*(bvec_bohr_0(ns,i)*ddvec_0(ns+1,j) + ddvec_0(ns+1,i)*bvec_bohr_0(ns,j)) - enddo - enddo - enddo -! write(*,161) -! 161 format('quad tensor adj to compensate for distrib dip: ') -! do i = 1, 3 -! write(*,162) (quadten_0(3*(i-1)+j), j = 1, 3) -! 162 format(3x,3f15.6) -! enddo -! ... distributed dipole vectors in lab frame - do ns = 1, 3 - do i = 1, 3 - ddvec_r(mo,ns,i) = 0.d0 - do k = 1, 3 - ddvec_r(mo,ns,i) = ddvec_r(mo,ns,i) + ddvec_0(ns,k)*rlocvec(k,i) - enddo - enddo - enddo -! write(*,171) -! 171 format(/'distributed dipole vectors in lab frame:') -! do ns = 1, 3 -! write(*,172) (ddvec_r(mo,ns,i), i = 1, 3) -! 172 format(3x,3f15.6) -! enddo -! ... quadrupole tensor in lab frame - do i = 1, 3 - do j = 1, 3 - m = 3*(i-1) + j - quadten_d(m) = 0.d0 - do k = 1, 3 - ns = 3*(i-1) + k - quadten_d(m) = quadten_d(m) + quadten_0(ns)*rlocvec(k,j) - enddo - enddo - enddo - do i = 1, 3 - do j = 1, 3 - m = 3*(i-1) + j - quadten_r(mo,m) = 0.d0 - do k = 1, 3 - ns = 3*(k-1) + j - quadten_r(mo,m) = quadten_r(mo,m) + rlocvec(k,i)*quadten_d(ns) - enddo - enddo - enddo -! write(*,181) -! 181 format(/'quadrupole tensor in lab frame:') -! do i = 1, 3 -! write(*,182) (quadten_r(mo,3*(i-1)+j), j = 1, 3) -! 182 format(3x,3f15.6) -! enddo - enddo -! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -! end loop over monomers -! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -! -! ... calculate 1st-order electrostatic interactions ......... -! write(*,211) -! 211 format(/75('-')) -! write(*,212) -! 212 format(/'d-d, d-q, q-d and q-q interactions: (a.u.)') -! ... temp arrays for distributed dipoles and quadrupoles - do i = 1, 3 - dv1o(i) = ddvec_r(1,1,i) - dv1h1(i) = ddvec_r(1,2,i) - dv1h2(i) = ddvec_r(1,3,i) - dv2o(i) = ddvec_r(2,1,i) - dv2h1(i) = ddvec_r(2,2,i) - dv2h2(i) = ddvec_r(2,3,i) - enddo - do k = 1, 9 - qt1(k) = quadten_r(1,k) - qt2(k) = quadten_r(2,k) - enddo -! ... vector posn of O in 2nd monomer relative to O in 1st monomer - do i = 1, 3 - sepoo(i) = atpos(2,1,i) - atpos(1,1,i) - enddo -! ... make interatomic separation vectors - do i = 1, 3 - rroo(i) = sepoo(i)/bohr - rroh1(i) = (bvec_r(2,1,i) + sepoo(i))/bohr - rroh2(i) = (bvec_r(2,2,i) + sepoo(i))/bohr - rrh1o(i) = (-bvec_r(1,1,i) + sepoo(i))/bohr - rrh1h1(i) = (bvec_r(2,1,i) - bvec_r(1,1,i) + sepoo(i))/bohr - rrh1h2(i) = (bvec_r(2,2,i) - bvec_r(1,1,i) + sepoo(i))/bohr - rrh2o(i) = (-bvec_r(1,2,i) + sepoo(i))/bohr - rrh2h1(i) = (bvec_r(2,1,i) - bvec_r(1,2,i) + sepoo(i))/bohr - rrh2h2(i) = (bvec_r(2,2,i) - bvec_r(1,2,i) + sepoo(i))/bohr - enddo -! ... dipole-dipole interactions - call dip_dip(dv1o,dv2o,rroo,dd_int_oo) - call dip_dip(dv1o,dv2h1,rroh1,dd_int_oh1) - call dip_dip(dv1o,dv2h2,rroh2,dd_int_oh2) - call dip_dip(dv1h1,dv2o,rrh1o,dd_int_h1o) - call dip_dip(dv1h1,dv2h1,rrh1h1,dd_int_h1h1) - call dip_dip(dv1h1,dv2h2,rrh1h2,dd_int_h1h2) - call dip_dip(dv1h2,dv2o,rrh2o,dd_int_h2o) - call dip_dip(dv1h2,dv2h1,rrh2h1,dd_int_h2h1) - call dip_dip(dv1h2,dv2h2,rrh2h2,dd_int_h2h2) - dd_int = dd_int_oo + dd_int_oh1 + dd_int_oh2 + dd_int_h1o + dd_int_h1h1 + dd_int_h1h2 + dd_int_h2o + dd_int_h2h1 + dd_int_h2h2 -! ... dipole-quadrupole interactions - call dip_quad(dv1o,qt2,rroo,dq_int_oo) - call dip_quad(dv1h1,qt2,rrh1o,dq_int_h1o) - call dip_quad(dv1h2,qt2,rrh2o,dq_int_h2o) - dq_int = dq_int_oo + dq_int_h1o + dq_int_h2o -! ... quadrupole-dipole interactions - call quad_dip(qt1,dv2o,rroo,qd_int_oo) - call quad_dip(qt1,dv2h1,rroh1,qd_int_oh1) - call quad_dip(qt1,dv2h2,rroh2,qd_int_oh2) - qd_int = qd_int_oo + qd_int_oh1 + qd_int_oh2 -! ... quadrupole-quadrupole interaction - call quad_quad(qt1,qt2,rroo,qq_int) -! write(*,221) dd_int, dq_int, qd_int, qq_int -! 221 format(3x,4e15.6) - e_dqtot = dd_int + dq_int + qd_int + qq_int -! --- induction energy ------------------------------------------------ -! ... pol of mono2/O from dip and quad on mono1 - call dip_field(rroo,dv1o,evec1) - call dip_field(rrh1o,dv1h1,evec2) - call dip_field(rrh2o,dv1h2,evec3) - call quad_field(rroo,qt1,evec4) - do i = 1, 3 - evect(i) = evec1(i) + evec2(i) + evec3(i) + evec4(i) - enddo - e_ind_2o = -0.5d0*pol_o*(evect(1)**2 + evect(2)**2 + evect(3)**2) -! ... pol of mono2/H1 from dip and quad on mono1 - call dip_field(rroh1,dv1o,evec1) - call dip_field(rrh1h1,dv1h1,evec2) - call dip_field(rrh2h1,dv1h2,evec3) - call quad_field(rroh1,qt1,evec4) - do i = 1, 3 - evect(i) = evec1(i) + evec2(i) + evec3(i) + evec4(i) - enddo - e_ind_2h1 = -0.5d0*pol_h*(evect(1)**2 + evect(2)**2 + evect(3)**2) -! ... pol of mono2/H2 from dip and quad on mono1 - call dip_field(rroh2,dv1o,evec1) - call dip_field(rrh1h2,dv1h1,evec2) - call dip_field(rrh2h2,dv1h2,evec3) - call quad_field(rroh2,qt1,evec4) - do i = 1, 3 - evect(i) = evec1(i) + evec2(i) + evec3(i) + evec4(i) - enddo - e_ind_2h2 = -0.5d0*pol_h*(evect(1)**2 + evect(2)**2 + evect(3)**2) -! ... pol of mono1/O from dip and quad on mono2 - call dip_field(rroo,dv2o,evec1) - call dip_field(rroh1,dv2h1,evec2) - call dip_field(rroh2,dv2h2,evec3) - call quad_field(rroo,qt2,evec4) - do i = 1, 3 - evect(i) = evec1(i) + evec2(i) + evec3(i) - evec4(i) - enddo - e_ind_1o = -0.5d0*pol_o*(evect(1)**2 + evect(2)**2 + evect(3)**2) -! ... pol of mono1/H1 from dip and quad on mono2 - call dip_field(rrh1o,dv2o,evec1) - call dip_field(rrh1h1,dv2h1,evec2) - call dip_field(rrh1h2,dv2h2,evec3) - call quad_field(rrh1o,qt2,evec4) - do i = 1, 3 - evect(i) = evec1(i) + evec2(i) + evec3(i) - evec4(i) - enddo - e_ind_1h1 = -0.5d0*pol_h*(evect(1)**2 + evect(2)**2 + evect(3)**2) -! ... pol of mono1/H2 from dip and quad on mono2 - call dip_field(rrh2o,dv2o,evec1) - call dip_field(rrh2h1,dv2h1,evec2) - call dip_field(rrh2h2,dv2h2,evec3) - call quad_field(rrh2o,qt2,evec4) - do i = 1, 3 - evect(i) = evec1(i) + evec2(i) + evec3(i) - evec4(i) - enddo - e_ind_1h2 = -0.5d0*pol_h*(evect(1)**2 + evect(2)**2 + evect(3)**2) - e_ind = e_ind_1o + e_ind_1h1 + e_ind_1h2 + e_ind_2o + e_ind_2h1 + e_ind_2h2 -! --- dispersion energy ---------------------------------------------- - d6oo = (rroo(1)**2 + rroo(2)**2 + rroo(3)**2)**3 - d6oh1 = (rroh1(1)**2 + rroh1(2)**2 + rroh1(3)**2)**3 - d6oh2 = (rroh2(1)**2 + rroh2(2)**2 + rroh2(3)**2)**3 - d6h1o = (rrh1o(1)**2 + rrh1o(2)**2 + rrh1o(3)**2)**3 - d6h1h1 = (rrh1h1(1)**2 + rrh1h1(2)**2 + rrh1h1(3)**2)**3 - d6h1h2 = (rrh1h2(1)**2 + rrh1h2(2)**2 + rrh1h2(3)**2)**3 - d6h2o = (rrh2o(1)**2 + rrh2o(2)**2 + rrh2o(3)**2)**3 - d6h2h1 = (rrh2h1(1)**2 + rrh2h1(2)**2 + rrh2h1(3)**2)**3 - d6h2h2 = (rrh2h2(1)**2 + rrh2h2(2)**2 + rrh2h2(3)**2)**3 - e_disp = -(c6oo/d6oo + c6oh/d6oh1 + c6oh/d6oh2 + c6oh/d6h1o + c6hh/d6h1h1 + c6hh/d6h1h2 + c6oh/d6h2o + c6hh/d6h2h1 + c6hh/d6h2h2) -! ... output components of and total 2-body energy - elong_tot = e_dqtot + e_ind + e_disp -! write(*,231) -! 231 format('1st-order e-stat, induct, disp, total energy (a.u.):') -! write(*,232) e_dqtot, e_ind, e_disp, elong_tot -! 232 format(3x,3e15.6,3x,e15.6) -! --------------------------------------------------------------------- - return - end subroutine h2o_dimer_far -! ===================================================================== - -! ===================================================================== -! sbrt lin3d_2: performs 3D linear interpolation to evaluate two -! functions f1, f2 of 3 variables, the values of the functions -! being given on a regular 3D grid. Sbrt is called first with -! flag init3d = 0, whereupon it reads in the grid data from -! a file, which contains also the numbers of grid points and -! the upper and lower limits of x, y and z. On subsequent call -! with init3d != 0, sbrt uses linear interpolation to evaluate -! f1 and f2 at requested point (x,y,z). -! --------------------------------------------------------------------- - subroutine lin3d_2(init3d,x,y,z,f1,f2,fname) - implicit none - character(len=STRING_LENGTH) fname - integer ngrid3_mx - parameter (ngrid3_mx = ngrid_mx*ngrid_mx*ngrid_mx) - integer init3d - real*8 x, y, z, f1, f2 - integer ix, iy, iz, nx, ny, nz - integer nxsup, nysup, nzsup - real*8 xi, eta, zeta, px, py, pz, qx, qy, qz -! --------------------------------------------------------------------- - if(init3d .eq. 0) then - lin3d_2_igotdata = 1 - open(unit=21,file=trim(fname)) - read(21,*) lin3d_2_nxsup, lin3d_2_xinf, lin3d_2_xsup - read(21,*) lin3d_2_nysup, lin3d_2_yinf, lin3d_2_ysup - read(21,*) lin3d_2_nzsup, lin3d_2_zinf, lin3d_2_zsup - lin3d_2_deltax = (lin3d_2_xsup - lin3d_2_xinf)/float(lin3d_2_nxsup - 1) - lin3d_2_deltay = (lin3d_2_ysup - lin3d_2_yinf)/float(lin3d_2_nysup - 1) - lin3d_2_deltaz = (lin3d_2_zsup - lin3d_2_zinf)/float(lin3d_2_nzsup - 1) -! ..................................................................... - do nx = 1, lin3d_2_nxsup - do ny = 1, lin3d_2_nysup - do nz = 1, lin3d_2_nzsup - read(21,*) ix, iy, iz, lin3d_2_f1tab(ix,iy,iz), lin3d_2_f2tab(ix,iy,iz) - enddo - enddo - enddo - close(unit=21) - else - xi = (x - lin3d_2_xinf)/lin3d_2_deltax - if((x - lin3d_2_xinf) .lt. 0.d0) then - ix = 0 - elseif(((x - lin3d_2_xinf) .ge. 0.d0) .and. ((x - lin3d_2_xsup) .le. 0.d0)) then - ix = int(xi) - else - ix = lin3d_2_nxsup - 2 - endif - px = xi - float(ix) - qx = 1.d0 - px - ix = ix + 1 - eta = (y - lin3d_2_yinf)/lin3d_2_deltay - if((y - lin3d_2_yinf) .lt. 0.d0) then - iy = 0 - elseif(((y - lin3d_2_yinf) .ge. 0.d0) .and. ((y - lin3d_2_ysup) .le. 0.d0)) then - iy = int(eta) - else - iy = lin3d_2_nysup - 2 - endif - py = eta - float(iy) - qy = 1.d0 - py - iy = iy + 1 - zeta = (z - lin3d_2_zinf)/lin3d_2_deltaz - if((z - lin3d_2_zinf) .lt. 0.d0) then - iz = 0 - elseif(((z - lin3d_2_zinf) .ge. 0.d0) .and. ((z - lin3d_2_zsup) .le. 0.d0)) then - iz = int(zeta) - else - iz = lin3d_2_nzsup - 2 - endif - pz = zeta - float(iz) - qz = 1.d0 - pz - iz = iz + 1 - f1 = qx*qy*qz*lin3d_2_f1tab(ix,iy,iz) + qx*qy*pz*lin3d_2_f1tab(ix,iy,iz+1) + qx*py*qz*lin3d_2_f1tab(ix,iy+1,iz) + qx*py*pz*lin3d_2_f1tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_2_f1tab(ix+1,iy,iz) + px*qy*pz*lin3d_2_f1tab(ix+1,iy,iz+1) + px*py*qz*lin3d_2_f1tab(ix+1,iy+1,iz) + px*py*pz*lin3d_2_f1tab(ix+1,iy+1,iz+1) - f2 = qx*qy*qz*lin3d_2_f2tab(ix,iy,iz) + qx*qy*pz*lin3d_2_f2tab(ix,iy,iz+1) + qx*py*qz*lin3d_2_f2tab(ix,iy+1,iz) + qx*py*pz*lin3d_2_f2tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_2_f2tab(ix+1,iy,iz) + px*qy*pz*lin3d_2_f2tab(ix+1,iy,iz+1) + px*py*qz*lin3d_2_f2tab(ix+1,iy+1,iz) + px*py*pz*lin3d_2_f2tab(ix+1,iy+1,iz+1) - endif -! --------------------------------------------------------------------- - return - end subroutine lin3d_2 -! ===================================================================== - - -! ===================================================================== -! sbrt lin3d_3: performs 3D linear interpolation to evaluate three -! functions f1, f2, f3 of 3 variables, the values of the functions -! being given on a regular 3D grid. Sbrt is called first with -! flag init3d = 0, whereupon it reads in the grid data from -! a file, which contains also the numbers of grid points and -! the upper and lower limits of x, y and z. On subsequent call -! with init3d != 0, sbrt uses linear interpolation to evaluate -! f1, f2 and f3 at requested point (x,y,z). -! --------------------------------------------------------------------- - subroutine lin3d_3(init3d,x,y,z,f1,f2,f3,fname) - implicit none - character(len=STRING_LENGTH) fname - integer ngrid3_mx - parameter (ngrid3_mx = ngrid_mx*ngrid_mx*ngrid_mx) - integer init3d - real*8 x, y, z, f1, f2, f3 - integer ix, iy, iz, nx, ny, nz - real*8 xi, eta, zeta, px, py, pz, qx, qy, qz -! --------------------------------------------------------------------- - if(init3d .eq. 0) then - lin3d_3_igotdata = 1 - open(unit=21,file=trim(fname)) - read(21,*) lin3d_3_nxsup, lin3d_3_xinf, lin3d_3_xsup - read(21,*) lin3d_3_nysup, lin3d_3_yinf, lin3d_3_ysup - read(21,*) lin3d_3_nzsup, lin3d_3_zinf, lin3d_3_zsup - lin3d_3_deltax = (lin3d_3_xsup - lin3d_3_xinf)/float(lin3d_3_nxsup - 1) - lin3d_3_deltay = (lin3d_3_ysup - lin3d_3_yinf)/float(lin3d_3_nysup - 1) - lin3d_3_deltaz = (lin3d_3_zsup - lin3d_3_zinf)/float(lin3d_3_nzsup - 1) -! ..................................................................... - do nx = 1, lin3d_3_nxsup - do ny = 1, lin3d_3_nysup - do nz = 1, lin3d_3_nzsup - read(21,*) ix, iy, iz, lin3d_3_f1tab(ix,iy,iz), lin3d_3_f2tab(ix,iy,iz), lin3d_3_f3tab(ix,iy,iz) - enddo - enddo - enddo - close(unit=21) - else - xi = (x - lin3d_3_xinf)/lin3d_3_deltax - if((x - lin3d_3_xinf) .lt. 0.d0) then - ix = 0 - elseif(((x - lin3d_3_xinf) .ge. 0.d0) .and. ((x - lin3d_3_xsup) .le. 0.d0)) then - ix = int(xi) - else - ix = lin3d_3_nxsup - 2 - endif - px = xi - float(ix) - qx = 1.d0 - px - ix = ix + 1 - if((ix .lt. 1) .or. (ix .gt. lin3d_3_nxsup)) then - write(*,931) ix - 931 format(//'error: index ix out of range: ',i10) - stop - endif - eta = (y - lin3d_3_yinf)/lin3d_3_deltay - if((y - lin3d_3_yinf) .lt. 0.d0) then - iy = 0 - elseif(((y - lin3d_3_yinf) .ge. 0.d0) .and. ((y - lin3d_3_ysup) .le. 0.d0)) then - iy = int(eta) - else - iy = lin3d_3_nysup - 2 - endif - py = eta - float(iy) - qy = 1.d0 - py - iy = iy + 1 - if((iy .lt. 1) .or. (iy .gt. lin3d_3_nysup)) then - write(*,932) iy - 932 format(//'error: index iy out of range: ',i10) - stop - endif - zeta = (z - lin3d_3_zinf)/lin3d_3_deltaz - if((z - lin3d_3_zinf) .lt. 0.d0) then - iz = 0 - elseif(((z - lin3d_3_zinf) .ge. 0.d0) .and. ((z - lin3d_3_zsup) .le. 0.d0)) then - iz = int(zeta) - else - iz = lin3d_3_nzsup - 2 - endif - pz = zeta - float(iz) - qz = 1.d0 - pz - iz = iz + 1 - if((iz .lt. 1) .or. (iz .gt. lin3d_3_nzsup)) then - write(*,933) iz - 933 format(//'error: index iz out of range: ',i10) - stop - endif - f1 = qx*qy*qz*lin3d_3_f1tab(ix,iy,iz) + qx*qy*pz*lin3d_3_f1tab(ix,iy,iz+1) + qx*py*qz*lin3d_3_f1tab(ix,iy+1,iz) + qx*py*pz*lin3d_3_f1tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_3_f1tab(ix+1,iy,iz) + px*qy*pz*lin3d_3_f1tab(ix+1,iy,iz+1) + px*py*qz*lin3d_3_f1tab(ix+1,iy+1,iz) + px*py*pz*lin3d_3_f1tab(ix+1,iy+1,iz+1) - f2 = qx*qy*qz*lin3d_3_f2tab(ix,iy,iz) + qx*qy*pz*lin3d_3_f2tab(ix,iy,iz+1) + qx*py*qz*lin3d_3_f2tab(ix,iy+1,iz) + qx*py*pz*lin3d_3_f2tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_3_f2tab(ix+1,iy,iz) + px*qy*pz*lin3d_3_f2tab(ix+1,iy,iz+1) + px*py*qz*lin3d_3_f2tab(ix+1,iy+1,iz) + px*py*pz*lin3d_3_f2tab(ix+1,iy+1,iz+1) - f3 = qx*qy*qz*lin3d_3_f3tab(ix,iy,iz) + qx*qy*pz*lin3d_3_f3tab(ix,iy,iz+1) + qx*py*qz*lin3d_3_f3tab(ix,iy+1,iz) + qx*py*pz*lin3d_3_f3tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_3_f3tab(ix+1,iy,iz) + px*qy*pz*lin3d_3_f3tab(ix+1,iy,iz+1) + px*py*qz*lin3d_3_f3tab(ix+1,iy+1,iz) + px*py*pz*lin3d_3_f3tab(ix+1,iy+1,iz+1) - endif -! --------------------------------------------------------------------- - return - end subroutine lin3d_3 -! ===================================================================== - - -! ============================================================ -! sbrt dip_dip: evaluates dipole-dipole interaction energy -! ------------------------------------------------------------ - subroutine dip_dip(dv1,dv2,rr,vdd) - implicit none - real*8 vdd - real*8 dv1(*), dv2(*), rr(*) - real*8 d1_d2, d1_r, d2_r, r -! ... scalar product of dipoles - d1_d2 = dv1(1)*dv2(1) + dv1(2)*dv2(2) + dv1(3)*dv2(3) -! ... scalar products of dipoles and separation vector - d1_r = dv1(1)*rr(1) + dv1(2)*rr(2) + dv1(3)*rr(3) - d2_r = dv2(1)*rr(1) + dv2(2)*rr(2) + dv2(3)*rr(3) -! ... distance - r = sqrt(rr(1)*rr(1) + rr(2)*rr(2) + rr(3)*rr(3)) -! ... dipole-dipole interaction energy - vdd = -(3.d0*d1_r*d2_r/(r*r) - d1_d2)/(r*r*r) - return - end subroutine dip_dip -! ============================================================ - -! ============================================================ -! sbrt dip_quad: evaluates dipole-quadrupole interaction energy -! ------------------------------------------------------------ - subroutine dip_quad(dv,qt,rr,vdq) - implicit none - real*8 vdq - real*8 dv(*), qt(*), rr(*) - integer i, j, k - real*8 d_r, r_q_r, r_q_d, r -! ... scalar product of dipole vector and separation vector - d_r = 0.d0 - do i = 1, 3 - d_r = d_r + dv(i)*rr(i) - enddo -! ... scalar product separation with quad tensor with separation - r_q_r = 0.d0 - do i = 1, 3 - do j = 1, 3 - k = 3*(i-1) + j - r_q_r = r_q_r + rr(i)*qt(k)*rr(j) - enddo - enddo -! ... scalar product separation with quad tensor with dipole - r_q_d = 0.d0 - do i = 1, 3 - do j = 1, 3 - k = 3*(i-1) + j - r_q_d = r_q_d + rr(i)*qt(k)*dv(j) - enddo - enddo -! ... distance - r = sqrt(rr(1)*rr(1) + rr(2)*rr(2) + rr(3)*rr(3)) -! ... dipole-quadrupole interaction energy - vdq = 5.d0*d_r*r_q_r/(r**7) - 2.d0*r_q_d/(r**5) -! ... - return - end subroutine dip_quad -! ============================================================= - -! ============================================================ -! sbrt quad_dip: evaluates quadrupole-dipole interaction energy -! ------------------------------------------------------------ - subroutine quad_dip(qt,dv,rr,vqd) - implicit none - real*8 vqd - real*8 dv(*), qt(*), rr(*) - integer i, j, k - real*8 d_r, r_q_r, r_q_d, r -! ... scalar product of dipole vector and separation vector - d_r = 0.d0 - do i = 1, 3 - d_r = d_r + dv(i)*rr(i) - enddo -! ... scalar product separation with quad tensor with separation - r_q_r = 0.d0 - do i = 1, 3 - do j = 1, 3 - k = 3*(i-1) + j - r_q_r = r_q_r + rr(i)*qt(k)*rr(j) - enddo - enddo -! ... scalar product separation with quad tensor with dipole - r_q_d = 0.d0 - do i = 1, 3 - do j = 1, 3 - k = 3*(i-1) + j - r_q_d = r_q_d + rr(i)*qt(k)*dv(j) - enddo - enddo -! ... distance - r = sqrt(rr(1)*rr(1) + rr(2)*rr(2) + rr(3)*rr(3)) -! ... quadrupole-dipole interaction energy - vqd = -5.d0*d_r*r_q_r/(r**7) + 2.d0*r_q_d/(r**5) -! ... - return - end subroutine quad_dip -! ============================================================= - -! ============================================================= -! sbrt quad_quad: evaluates quadrupole-quadrupole interaction energy -! ------------------------------------------------------------- - subroutine quad_quad(qt1,qt2,rr,vqq) - implicit none - real*8 vqq - real*8 qt1(*), qt2(*), rr(*) - integer i, j, k - real*8 tr_q_q, r_q1_r, r_q2_r, r_q_q_r, s1, s2, r -! ... trace of qt1*qt2 - tr_q_q = 0.d0 - do i = 1, 3 - do j = 1, 3 - k = 3*(i-1) + j - tr_q_q = tr_q_q + qt1(k)*qt2(k) - enddo - enddo -! ... scalar products r*qt1*r and r*qt2*r - r_q1_r = 0.d0 - r_q2_r = 0.d0 - do i = 1, 3 - do j = 1, 3 - k = 3*(i-1) + j - r_q1_r = r_q1_r + rr(i)*qt1(k)*rr(j) - r_q2_r = r_q2_r + rr(i)*qt2(k)*rr(j) - enddo - enddo -! ... scalar product r*qt1*qt2*r - r_q_q_r = 0.d0 - do i = 1, 3 - s1 = 0.d0 - s2 = 0.d0 - do j = 1, 3 - k = 3*(i-1) + j - s1 = s1 + qt1(k)*rr(j) - s2 = s2 + qt2(k)*rr(j) - enddo - r_q_q_r = r_q_q_r + s1*s2 - enddo -! ... distance - r = sqrt(rr(1)*rr(1) + rr(2)*rr(2) + rr(3)*rr(3)) -! ... quad-quad interaction energy - vqq = 2.d0*tr_q_q/(3.d0*(r**5)) - 20.d0*r_q_q_r/(3.d0*(r**7)) + 35.d0*r_q1_r*r_q2_r/(3.d0*(r**9)) -! ... - return - end subroutine quad_quad -! =============================================================== - -! =============================================================== -! sbrt dip_field: computes electric field vector evec2 at vector -! position pos2 due to electric dipole vector mu1 at origin -! --------------------------------------------------------------- - subroutine dip_field(pos2,mu1,evec2) - implicit none - real*8 pos2(*), mu1(*), evec2(*) - integer n - real*8 drr, mudotr, drr3, drr5 -! --------------------------------------------------------------- - drr = 0.d0 - mudotr = 0.d0 - do n = 1, 3 - drr = drr + pos2(n)*pos2(n) - mudotr = mudotr + mu1(n)*pos2(n) - enddo - drr = sqrt(drr) - drr3 = drr*drr*drr - drr5 = drr*drr*drr3 - do n = 1, 3 - evec2(n) = 3.d0*mudotr*pos2(n)/drr5 - mu1(n)/drr3 - enddo -! --------------------------------------------------------------- - return - end subroutine dip_field -! =============================================================== - -! =============================================================== -! sbrt quad_field: computes electric field evec2 at vector -! position pos2 due to electric quadrupole tensor q1 at origin -! --------------------------------------------------------------- - subroutine quad_field(pos2,q1,evec2) - implicit none - real*8 pos2(*), q1(*), evec2(*) - integer k, m, n - real*8 drr, drr5, drr7, rdqdr - real*8 qdotr(3) -! --------------------------------------------------------------- - drr = 0.d0 - rdqdr = 0.d0 - do m = 1, 3 - drr = drr + pos2(m)*pos2(m) - qdotr(m) = 0.d0 - do n = 1, 3 - k = 3*(m-1) + n - rdqdr = rdqdr + pos2(m)*q1(k)*pos2(n) - qdotr(m) = qdotr(m) + q1(k)*pos2(n) - enddo - enddo - drr = sqrt(drr) - drr5 = drr*drr*drr*drr*drr - drr7 = drr*drr*drr5 - do n = 1, 3 - evec2(n) = 5.d0*rdqdr*pos2(n)/drr7 - 2.d0*qdotr(n)/drr5 - enddo -! ---------------------------------------------------------------- - return - end subroutine quad_field -! ================================================================ - - - - end module IPModel_WaterDimer_Gillan_module diff --git a/src/Potentials/IPModel_WaterTrimer_Gillan.f95 b/src/Potentials/IPModel_WaterTrimer_Gillan.f95 deleted file mode 100644 index 12a1747d2a..0000000000 --- a/src/Potentials/IPModel_WaterTrimer_Gillan.f95 +++ /dev/null @@ -1,700 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_WaterTrimer_Gillan -!X -!% 3-body interaction of three water molecules, parametrised by Mike Gillan in 2013 -!% -!% Based on polynomial basis functions of Paesani 2012 -!% -!% Energy only -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_WaterTrimer_Gillan_module - -use error_module -use system_module, only : dp, inoutput, print, operator(//) -use units_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use spline_module -use quaternions_module -use atoms_types_module -use atoms_module -use topology_module - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_WaterTrimer_Gillan -type IPModel_WaterTrimer_Gillan - real(dp) :: cutoff = 8.0_dp - character(len=STRING_LENGTH) :: coeff_file - logical :: OHH_ordercheck = .true. - type(Spline) :: fcut - real (dp) :: fcut_delta = 0.5 -end type IPModel_WaterTrimer_Gillan - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_WaterTrimer_Gillan), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_WaterTrimer_Gillan_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_WaterTrimer_Gillan_Finalise -end interface Finalise - -interface Print - module procedure IPModel_WaterTrimer_Gillan_Print -end interface Print - -interface Calc - module procedure IPModel_WaterTrimer_Gillan_Calc -end interface Calc - -! module-gobal variables - -integer,parameter :: nbas_tot_max=150 - -integer ibas_code, nbas_tot, nbas_totp -integer natom, nbas_2deg, nbas_3deg -integer iswitch(nbas_tot_max) -real(dp):: drep(nbas_tot_max) -real(dp):: basis(nbas_tot_max) - - - -contains - -subroutine IPModel_WaterTrimer_Gillan_Initialise_str(this, args_str, param_str, error) - type(IPModel_WaterTrimer_Gillan), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - integer, optional, intent(out) :: error - integer :: i, nb1 - real(dp) :: rr(3,9) - - INIT_ERROR(error) - - call Finalise(this) - - call initialise(params) - call param_register(params, 'coeff_file', PARAM_MANDATORY, this%coeff_file, help_string="name of file which contains the polynomial coefficients") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_WaterTrimer_Gillan_Initialise args_str')) then - RAISE_ERROR("IPModel_WaterTrimer_Gillan_Init failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - open(unit=21,file=this%coeff_file) - read(21,*) ibas_code -! write(*,121) ibas_code -! 121 format(/'basis code: ',i3) - read(21,*) nbas_tot -! write(*,122) nbas_tot -! 122 format(/'total no. of basis functions: ',i5) - if(nbas_tot .gt. nbas_tot_max) then -! write(*,901) -! 901 format(/'error: too many basis functions') - RAISE_ERROR('error: too many basis functions', error) - endif - -!c ... initial call of basis calculator - call calc_basis(0,ibas_code,nbas_2deg,nbas_3deg,nbas_tot_max,rr,basis) -! write(*,126) nbas_2deg, nbas_3deg -! 126 format(/'after initial call to basis calculator:'/ -! * 'no. of deg-2 basis functions: ',i5/ -! * 'no. of deg-3 basis functions: ',i5) - nbas_totp = nbas_2deg + nbas_3deg -! write(*,127) nbas_totp -! 127 format(/'hence total no. of basis functions: ',i5) - if(nbas_totp .ne. nbas_tot) then -! write(*,905) -! 905 format(//'error: conflicting no. of basis functions') - RAISE_ERROR('error: conflicting no. of basis functions', error) - endif -!c ... read basis coeffs -! write(*,131) -! 131 format(/'switch flags, basis coeffs:') - do i = 1, nbas_tot - read(21,*) nb1, iswitch(i), drep(i) -! write(*,132) nb, iswitch(nb), drep(nb) -! 132 format(i5,3x,i3,3x,e15.6) - enddo - close(unit=21) - - call initialise(this%fcut, (/this%cutoff - this%fcut_delta, this%cutoff/), (/1.0_dp, 0.0_dp/), 0.0_dp, 0.0_dp) - - - end subroutine IPModel_WaterTrimer_Gillan_Initialise_str - -subroutine IPModel_WaterTrimer_Gillan_Finalise(this) - type(IPModel_WaterTrimer_Gillan), intent(inout) :: this - - ! Add finalisation code here - call finalise(this%fcut) - - -end subroutine IPModel_WaterTrimer_Gillan_Finalise - - -subroutine IPModel_WaterTrimer_Gillan_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_WaterTrimer_Gillan), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer :: i, w1, w2, w3, w1O, w2O, w3O - integer, dimension(3,at%N/3) :: water_index - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - real(dp) rr(3,9) - real(dp) e_trimer - - INIT_ERROR(error) - - if(present(local_e)) then - RAISE_ERROR('IPModel_WaterTrimer_Gillan_Calc: local_e not implemented', error) - end if - if(present(f)) then - RAISE_ERROR('IPModel_WaterTrimer_Gillan_Calc: forces not implemented', error) - end if - if(present(virial)) then - RAISE_ERROR('IPModel_WaterTrimer_Gillan_Calc: virial not implemented', error) - end if - if (present(local_virial)) then - RAISE_ERROR("IPModel_WaterTrimer_Gillan_Calc: local_virial calculation requested but not supported yet.", error) - endif - - if(.not. present(e)) return ! nothing to do - - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy: nb326 $") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - - if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_WaterTrimer_Gillan_Calc args_str')) then - RAISE_ERROR("IPModel_WaterTrimer_Gillan_Calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if(has_atom_mask_name) then - RAISE_ERROR('IPModel_WaterTrimer_Gillan_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_WaterTrimer_Gillan_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) - end if - endif - - ! loop through atoms, find oxygens and their closest hydrogens - - call find_water_monomer(at,water_index,this%OHH_ordercheck,error=error) - - e = 0.d0 - - ! triple loop through monomers - do w1 = 1, at%N/3 - do w2 = w1+1, at%N/3 - do w3 = w2+1, at%N/3 - - w1O = water_index(1,w1) - rr(:,1) = at%pos(:,w1O) ! O - rr(:,2) = rr(:,1) + diff_min_image(at, w1O, water_index(2,w1)) ! H - rr(:,3) = rr(:,1) + diff_min_image(at, w1O, water_index(3,w1)) ! H - - w2O = water_index(1,w2) - rr(:,4) = rr(:,1) + diff_min_image(at, w1O, w2O) ! O - rr(:,5) = rr(:,1) + diff_min_image(at, w1O, water_index(2,w2)) ! H - rr(:,6) = rr(:,1) + diff_min_image(at, w1O, water_index(3,w2)) ! H - - w3O = water_index(1,w3) - rr(:,7) = rr(:,1) + diff_min_image(at, w1O, w3O) ! O - rr(:,8) = rr(:,1) + diff_min_image(at, w1O, water_index(2,w3)) ! H - rr(:,9) = rr(:,1) + diff_min_image(at, w1O, water_index(3,w3)) ! H - -!c ... calculate values of basis functions for current config - call calc_basis(1,ibas_code,nbas_2deg,nbas_3deg,nbas_tot_max, rr,basis) - e_trimer = 0.0_dp - do i = 1, nbas_tot - if(iswitch(i) .eq. 1) then - e_trimer = e_trimer + drep(i)*basis(i) - endif - enddo - e = e+e_trimer* spline_value(this%fcut, distance_min_image(at, w1O, w2O)) * & - spline_value(this%fcut, distance_min_image(at, w1O,w3O))* & - spline_value(this%fcut, distance_min_image(at, w2O, w3O)) - - - ! write(*,231) nc, e3bas - ! 231 format(/'config. no. ',i5,' 3-body correction: ',e15.6) - ! write(13,232) nc, e3bas - ! 232 format(i5,3x,e15.6) - enddo - end do - end do - !c ... end loop over configs - - - e = e*HARTREE - - -end subroutine IPModel_WaterTrimer_Gillan_Calc - - -subroutine IPModel_WaterTrimer_Gillan_Print(this, file) - type(IPModel_WaterTrimer_Gillan), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_WaterTrimer_Gillan : WaterTrimer_Gillan Potential", file=file) - call Print("IPModel_WaterTrimer_Gillan : cutoff = " // this%cutoff, file=file) - call Print("IPModel_WaterTrimer_Gillan : cutoff_delta = " // this%fcut_delta, file=file) - call Print("IPModel_WaterTrimer_Gillan : WARNING: no multiple periodic images implemented, so minimum-image convention applies to this potential!!! ", file=file) - -end subroutine IPModel_WaterTrimer_Gillan_Print - -!c ===================================================================== -!c Subroutine calc_basis: directs calculation to appropriate -!c version calc_basis_n() according to value of flag ibas_code. -!c The only versions implemented so far are ibas_code = 0, 1 -!c and any other values will cause the code to stop. -!c --------------------------------------------------------------------- - subroutine calc_basis(iret,ibas_code,nbas_2deg,nbas_3deg,nbas_tot_max,rr,basis) - implicit none - integer iret, ibas_code, nbas_2deg, nbas_3deg, nbas_tot_max - real*8 rr(3,9) - real*8 basis(nbas_tot_max) -!c --------------------------------------------------------------------- - if(ibas_code .eq. 0) then - call calc_basis_0(iret,nbas_2deg,nbas_3deg,nbas_tot_max,rr,basis) - elseif(ibas_code .eq. 1) then - call calc_basis_1(iret,nbas_2deg,nbas_3deg,nbas_tot_max,rr,basis) - else -! write(*,901) -! 901 format(//'error: sbrt calc_basis called with flag nbas_2deg ', -! * 'out of range') - stop - endif -!c --------------------------------------------------------------------- - return - end subroutine calc_basis -!c ===================================================================== - -!c ================================================================= -!c Subroutine calc_basis_0: computes deg-2 and deg-3 3-body -!c basis functions for model where only O-O distances are used -!c and at most one distance factor is allowed for each -!c O-O distance. -!c ------------------------------------------------------------------ - subroutine calc_basis_0(iret,nbas_2deg,nbas_3deg,nbas_tot_max, rr,basis) - implicit none - integer iret, nbas_2deg, nbas_3deg, nbas_tot_max - real*8 rr(3,9) - real*8 basis(nbas_tot_max) - real*8 kOO, dOO - real*8 d14, d17, d47, e14, e17, e47 -!c --------------------------------------------------------------------- - nbas_2deg = 1 - nbas_3deg = 1 - if(iret .eq. 0) return - kOO = 1.3d0 - dOO = 3.d0 -!c ... - d14 = sqrt((rr(1,4) - rr(1,1))**2 + (rr(2,4) - rr(2,1))**2 + (rr(3,4) - rr(3,1))**2) - d17 = sqrt((rr(1,7) - rr(1,1))**2 + (rr(2,7) - rr(2,1))**2 + (rr(3,7) - rr(3,1))**2) - d47 = sqrt((rr(1,4) - rr(1,7))**2 + (rr(2,4) - rr(2,7))**2 + (rr(3,4) - rr(3,7))**2) - e14 = exp(-kOO*(d14 - dOO)) - e17 = exp(-kOO*(d17 - dOO)) - e47 = exp(-kOO*(d47 - dOO)) - basis(1) = e14*e17 + e14*e47 + e17*e47 - basis(2) = e14*e17*e47 -!c --------------------------------------------------------------------- - return - end subroutine calc_basis_0 -!c ===================================================================== - -!c ================================================================= -!c Subroutine calc_basis_1: computes deg-2 and deg-3 3-body -!c basis functions for model where O-O, O-H and H-H distances are -!c used and at most one distance factor is allowed for each -!c monomer pair. -!c ------------------------------------------------------------------ - subroutine calc_basis_1(iret,nbas_2deg,nbas_3deg,nbas_tot_max, rr,basis) - implicit none - integer iret, nbas_2deg, nbas_3deg, nbas_tot_max - real*8 rr(3,9) - real*8 basis(nbas_tot_max) -!c ... - real*8 kOO, dOO, kOH, dOH, kHH, dHH - real*8 d14, d15, d16, d17, d18, d19, d24, d25, d26, d27, d28, d29, d34, d35, d36, d37, d38, d39, d47, d48, d49, d57, d58, d59, d67, d68, d69 - real*8 e14, e15, e16, e17, e18, e19, e24, e25, e26, e27, e28, e29, e34, e35, e36, e37, e38, e39, e47, e48, e49, e57, e58, e59, e67, e68, e69 -!c --------------------------------------------------------------------- - nbas_2deg = 13 - nbas_3deg = 30 - if(iret .eq. 0) return -!c --------------------------------------------------------------------- - kOO = 0.6d0 - dOO = 3.d0 - kOH = 1.4d0 - dOH = 3.d0 - kHH = 1.0d0 - dHH = 3.d0 -!c --------------------------------------------------------------------- - d14 = sqrt((rr(1,4) - rr(1,1))**2 + (rr(2,4) - rr(2,1))**2 + (rr(3,4) - rr(3,1))**2) - d15 = sqrt((rr(1,5) - rr(1,1))**2 + (rr(2,5) - rr(2,1))**2 + (rr(3,5) - rr(3,1))**2) - d16 = sqrt((rr(1,6) - rr(1,1))**2 + (rr(2,6) - rr(2,1))**2 + (rr(3,6) - rr(3,1))**2) - d17 = sqrt((rr(1,7) - rr(1,1))**2 + (rr(2,7) - rr(2,1))**2 + (rr(3,7) - rr(3,1))**2) - d18 = sqrt((rr(1,8) - rr(1,1))**2 + (rr(2,8) - rr(2,1))**2 + (rr(3,8) - rr(3,1))**2) - d19 = sqrt((rr(1,9) - rr(1,1))**2 + (rr(2,9) - rr(2,1))**2 + (rr(3,9) - rr(3,1))**2) - d24 = sqrt((rr(1,4) - rr(1,2))**2 + (rr(2,4) - rr(2,2))**2 + (rr(3,4) - rr(3,2))**2) - d25 = sqrt((rr(1,5) - rr(1,2))**2 + (rr(2,5) - rr(2,2))**2 + (rr(3,5) - rr(3,2))**2) - d26 = sqrt((rr(1,6) - rr(1,2))**2 + (rr(2,6) - rr(2,2))**2 + (rr(3,6) - rr(3,2))**2) - d27 = sqrt((rr(1,7) - rr(1,2))**2 + (rr(2,7) - rr(2,2))**2 + (rr(3,7) - rr(3,2))**2) - d28 = sqrt((rr(1,8) - rr(1,2))**2 + (rr(2,8) - rr(2,2))**2 + (rr(3,8) - rr(3,2))**2) - d29 = sqrt((rr(1,9) - rr(1,2))**2 + (rr(2,9) - rr(2,2))**2 + (rr(3,9) - rr(3,2))**2) - d34 = sqrt((rr(1,4) - rr(1,3))**2 + (rr(2,4) - rr(2,3))**2 + (rr(3,4) - rr(3,3))**2) - d35 = sqrt((rr(1,5) - rr(1,3))**2 + (rr(2,5) - rr(2,3))**2 + (rr(3,5) - rr(3,3))**2) - d36 = sqrt((rr(1,6) - rr(1,3))**2 + (rr(2,6) - rr(2,3))**2 + (rr(3,6) - rr(3,3))**2) - d37 = sqrt((rr(1,7) - rr(1,3))**2 + (rr(2,7) - rr(2,3))**2 + (rr(3,7) - rr(3,3))**2) - d38 = sqrt((rr(1,8) - rr(1,3))**2 + (rr(2,8) - rr(2,3))**2 + (rr(3,8) - rr(3,3))**2) - d39 = sqrt((rr(1,9) - rr(1,3))**2 + (rr(2,9) - rr(2,3))**2 + (rr(3,9) - rr(3,3))**2) - d47 = sqrt((rr(1,7) - rr(1,4))**2 + (rr(2,7) - rr(2,4))**2 + (rr(3,7) - rr(3,4))**2) - d48 = sqrt((rr(1,8) - rr(1,4))**2 + (rr(2,8) - rr(2,4))**2 + (rr(3,8) - rr(3,4))**2) - d49 = sqrt((rr(1,9) - rr(1,4))**2 + (rr(2,9) - rr(2,4))**2 + (rr(3,9) - rr(3,4))**2) - d57 = sqrt((rr(1,7) - rr(1,5))**2 + (rr(2,7) - rr(2,5))**2 + (rr(3,7) - rr(3,5))**2) - d58 = sqrt((rr(1,8) - rr(1,5))**2 + (rr(2,8) - rr(2,5))**2 + (rr(3,8) - rr(3,5))**2) - d59 = sqrt((rr(1,9) - rr(1,5))**2 + (rr(2,9) - rr(2,5))**2 + (rr(3,9) - rr(3,5))**2) - d67 = sqrt((rr(1,7) - rr(1,6))**2 + (rr(2,7) - rr(2,6))**2 + (rr(3,7) - rr(3,6))**2) - d68 = sqrt((rr(1,8) - rr(1,6))**2 + (rr(2,8) - rr(2,6))**2 + (rr(3,8) - rr(3,6))**2) - d69 = sqrt((rr(1,9) - rr(1,6))**2 + (rr(2,9) - rr(2,6))**2 + (rr(3,9) - rr(3,6))**2) - - e14 = exp(-kOO*(d14 - dOO)) - e15 = exp(-kOH*(d15 - dOH)) - e16 = exp(-kOH*(d16 - dOH)) - e17 = exp(-kOO*(d17 - dOO)) - e18 = exp(-kOH*(d18 - dOH)) - e19 = exp(-kOH*(d19 - dOH)) - e24 = exp(-kOH*(d24 - dOH)) - e25 = exp(-kHH*(d25 - dHH)) - e26 = exp(-kHH*(d26 - dHH)) - e27 = exp(-kOH*(d27 - dOH)) - e28 = exp(-kHH*(d28 - dHH)) - e29 = exp(-kHH*(d29 - dHH)) - e34 = exp(-kOH*(d34 - dOH)) - e35 = exp(-kHH*(d35 - dHH)) - e36 = exp(-kHH*(d36 - dHH)) - e37 = exp(-kOH*(d37 - dOH)) - e38 = exp(-kHH*(d38 - dHH)) - e39 = exp(-kHH*(d39 - dHH)) - e47 = exp(-kOO*(d47 - dOO)) - e48 = exp(-kOH*(d48 - dOH)) - e49 = exp(-kOH*(d49 - dOH)) - e57 = exp(-kOH*(d57 - dOH)) - e58 = exp(-kHH*(d58 - dHH)) - e59 = exp(-kHH*(d59 - dHH)) - e67 = exp(-kOH*(d67 - dOH)) - e68 = exp(-kHH*(d68 - dHH)) - e69 = exp(-kHH*(d69 - dHH)) -!c - basis(1) = e14*e17 + e14*e47 + e17*e47 -!c - basis(2) = e14*e18 + e14*e19 + e24*e47 + e34*e47 + e17*e57 + e17*e67 + e14*e48 + e14*e49 + e27*e47 + e37*e47 + e15*e17 + e16*e17 -!c - basis(3) = e14*e27 + e14*e37 + e15*e47 + e16*e47 + e17*e48 + e17*e49 + e14*e57 + e14*e67 + e18*e47 + e19*e47 + e17*e24 + e17*e34 -!c - basis(4) = e14*e28 + e14*e29 + e14*e38 + e14*e39 + e25*e47 + e35*e47 + e26*e47 + e36*e47 + e17*e58 + e17*e68 + e17*e59 + e17*e69 + e14*e58 + e14*e59 + e14*e68 + e14*e69 + e28*e47 + e38*e47 + e29*e47 + e39*e47 + e17*e25 + e17*e26 + e17*e35 + e17*e36 -!c - basis(5) = e15*e18 + e15*e19 + e16*e18 + e16*e19 + e24*e48 + e34*e48 + e24*e49 + e34*e49 + e27*e57 + e27*e67 + e37*e57 + e37*e67 -!c - basis(6) = e15*e27 + e16*e27 + e15*e37 + e16*e37 + e15*e48 + e15*e49 + e16*e48 + e16*e49 + e27*e48 + e37*e48 + e27*e49 + e37*e49 + e24*e57 + e34*e57 + e24*e67 + e34*e67 + e18*e57 + e18*e67 + e19*e57 + e19*e67 + e18*e24 + e19*e24 + e18*e34 + e19*e34 -!c - basis(7) = e15*e28 + e15*e29 + e16*e28 + e16*e29 + e15*e38 + e15*e39 + e16*e38 + e16*e39 + e25*e48 + e35*e48 + e25*e49 + e35*e49 + e26*e48 + e36*e48 + e26*e49 + e36*e49 + e27*e58 + e27*e68 + e37*e58 + e37*e68 + e27*e59 + e27*e69 + e37*e59 + e37*e69 + e24*e58 + e24*e59 + e34*e58 + e34*e59 + e24*e68 + e24*e69 + e34*e68 + e34*e69 + e28*e57 + e38*e57 + e28*e67 + e38*e67 + e29*e57 + e39*e57 + e29*e67 + e39*e67 + e18*e25 + e18*e26 + e19*e25 + e19*e26 + e18*e35 + e18*e36 + e19*e35 + e19*e36 -!c - basis(8) = e15*e57 + e16*e67 + e18*e48 + e19*e49 + e24*e27 + e34*e37 -!c - basis(9) = e15*e58 + e15*e59 + e16*e68 + e16*e69 + e28*e48 + e38*e48 + e29*e49 + e39*e49 + e25*e27 + e26*e27 + e35*e37 + e36*e37 + e24*e28 + e24*e29 + e34*e38 + e34*e39 + e25*e57 + e35*e57 + e26*e67 + e36*e67 + e18*e58 + e18*e68 + e19*e59 + e19*e69 -!c - basis(10) = e15*e67 + e16*e57 + e19*e48 + e18*e49 + e27*e34 + e24*e37 -!c - basis(11) = e15*e68 + e15*e69 + e16*e58 + e16*e59 + e29*e48 + e39*e48 + e28*e49 + e38*e49 + e27*e35 + e27*e36 + e25*e37 + e26*e37 + e24*e38 + e24*e39 + e28*e34 + e29*e34 + e26*e57 + e36*e57 + e25*e67 + e35*e67 + e18*e59 + e18*e69 + e19*e58 + e19*e68 -!c - basis(12) = e25*e28 + e25*e29 + e26*e28 + e26*e29 + e35*e38 + e35*e39 + e36*e38 + e36*e39 + e25*e58 + e35*e58 + e25*e59 + e35*e59 + e26*e68 + e36*e68 + e26*e69 + e36*e69 + e28*e58 + e28*e68 + e38*e58 + e38*e68 + e29*e59 + e29*e69 + e39*e59 + e39*e69 -!c - basis(13) = e25*e38 + e25*e39 + e26*e38 + e26*e39 + e28*e35 + e29*e35 + e28*e36 + e29*e36 + e26*e58 + e36*e58 + e26*e59 + e36*e59 + e25*e68 + e35*e68 + e25*e69 + e35*e69 + e28*e59 + e28*e69 + e38*e59 + e38*e69 + e29*e58 + e29*e68 + e39*e58 + e39*e68 -!c - basis(14) = e14*e17*e47 -!c - basis(15) = e14*e17*e48 + e14*e17*e49 + e14*e27*e47 + e14*e37*e47 + e15*e17*e47 + e16*e17*e47 + e14*e18*e47 + e14*e19*e47 + e17*e24*e47 + e17*e34*e47 + e14*e17*e57 + e14*e17*e67 -!c - basis(16) = e14*e17*e58 + e14*e17*e59 + e14*e17*e68 + e14*e17*e69 + e14*e28*e47 + e14*e38*e47 + e14*e29*e47 + e14*e39*e47 + e17*e25*e47 + e17*e26*e47 + e17*e35*e47 + e17*e36*e47 -!c - basis(17) = e14*e18*e48 + e14*e19*e49 + e24*e27*e47 + e34*e37*e47 + e15*e17*e57 + e16*e17*e67 -!c - basis(18) = e14*e18*e49 + e14*e19*e48 + e24*e37*e47 + e27*e34*e47 + e16*e17*e57 + e15*e17*e67 -!c - basis(19) = e14*e18*e57 + e14*e19*e57 + e14*e18*e67 + e14*e19*e67 + e18*e24*e47 + e18*e34*e47 + e19*e24*e47 + e19*e34*e47 + e17*e24*e57 + e17*e24*e67 + e17*e34*e57 + e17*e34*e67 + e14*e27*e48 + e14*e27*e49 + e14*e37*e48 + e14*e37*e49 + e15*e27*e47 + e15*e37*e47 + e16*e27*e47 + e16*e37*e47 + e15*e17*e48 + e16*e17*e48 + e15*e17*e49 + e16*e17*e49 -!c - basis(20) = e14*e18*e58 + e14*e19*e59 + e14*e18*e68 + e14*e19*e69 + e24*e28*e47 + e34*e38*e47 + e24*e29*e47 + e34*e39*e47 + e17*e25*e57 + e17*e26*e67 + e17*e35*e57 + e17*e36*e67 + e14*e28*e48 + e14*e29*e49 + e14*e38*e48 + e14*e39*e49 + e25*e27*e47 + e35*e37*e47 + e26*e27*e47 + e36*e37*e47 + e15*e17*e58 + e16*e17*e68 + e15*e17*e59 + e16*e17*e69 -!c - basis(21) = e14*e18*e59 + e14*e19*e58 + e14*e18*e69 + e14*e19*e68 + e24*e38*e47 + e28*e34*e47 + e24*e39*e47 + e29*e34*e47 + e17*e26*e57 + e17*e25*e67 + e17*e36*e57 + e17*e35*e67 + e14*e29*e48 + e14*e28*e49 + e14*e39*e48 + e14*e38*e49 + e27*e35*e47 + e25*e37*e47 + e27*e36*e47 + e26*e37*e47 + e15*e17*e68 + e16*e17*e58 + e15*e17*e69 + e16*e17*e59 -!c - basis(22) = e14*e27*e57 + e14*e27*e67 + e14*e37*e57 + e14*e37*e67 + e15*e18*e47 + e15*e19*e47 + e16*e18*e47 + e16*e19*e47 + e17*e24*e48 + e17*e34*e48 + e17*e24*e49 + e17*e34*e49 -!c - basis(23) = e14*e27*e58 + e14*e27*e59 + e14*e27*e68 + e14*e27*e69 + e14*e37*e58 + e14*e37*e59 + e14*e37*e68 + e14*e37*e69 + e15*e28*e47 + e15*e38*e47 + e15*e29*e47 + e15*e39*e47 + e16*e28*e47 + e16*e38*e47 + e16*e29*e47 + e16*e39*e47 + e17*e25*e48 + e17*e26*e48 + e17*e35*e48 + e17*e36*e48 + e17*e25*e49 + e17*e26*e49 + e17*e35*e49 + e17*e36*e49 + e14*e28*e57 + e14*e29*e57 + e14*e38*e57 + e14*e39*e57 + e14*e28*e67 + e14*e29*e67 + e14*e38*e67 + e14*e39*e67 + e18*e25*e47 + e18*e35*e47 + e18*e26*e47 + e18*e36*e47 + e19*e25*e47 + e19*e35*e47 + e19*e26*e47 + e19*e36*e47 + e17*e24*e58 + e17*e24*e68 + e17*e24*e59 + e17*e24*e69 + e17*e34*e58 + e17*e34*e68 + e17*e34*e59 + e17*e34*e69 -!c - basis(24) = e14*e28*e58 + e14*e29*e59 + e14*e28*e68 + e14*e29*e69 + e14*e38*e58 + e14*e39*e59 + e14*e38*e68 + e14*e39*e69 + e25*e28*e47 + e35*e38*e47 + e25*e29*e47 + e35*e39*e47 + e26*e28*e47 + e36*e38*e47 + e26*e29*e47 + e36*e39*e47 + e17*e25*e58 + e17*e26*e68 + e17*e35*e58 + e17*e36*e68 + e17*e25*e59 + e17*e26*e69 + e17*e35*e59 + e17*e36*e69 -!c - basis(25) = e14*e28*e59 + e14*e29*e58 + e14*e28*e69 + & - e14*e29*e68 + e14*e38*e59 + e14*e39*e58 + & - e14*e38*e69 + e14*e39*e68 + e25*e38*e47 + & - e28*e35*e47 + e25*e39*e47 + e29*e35*e47 + & - e26*e38*e47 + e28*e36*e47 + e26*e39*e47 + & - e29*e36*e47 + e17*e26*e58 + e17*e25*e68 + & - e17*e36*e58 + e17*e35*e68 + e17*e26*e59 + & - e17*e25*e69 + e17*e36*e59 + e17*e35*e69 -!c - basis(26) = e15*e18*e48 + e15*e19*e49 + e16*e18*e48 + & - e16*e19*e49 + e24*e27*e48 + e34*e37*e48 + & - e24*e27*e49 + e34*e37*e49 + e15*e27*e57 + & - e16*e27*e67 + e15*e37*e57 + e16*e37*e67 + & - e18*e24*e48 + e19*e24*e49 + e18*e34*e48 + & - e19*e34*e49 + e24*e27*e57 + e34*e37*e57 + & - e24*e27*e67 + e34*e37*e67 + e15*e18*e57 + & - e16*e18*e67 + e15*e19*e57 + e16*e19*e67 -!c - basis(27) = e15*e18*e49 + e15*e19*e48 + e16*e18*e49 + & - e16*e19*e48 + e24*e37*e48 + e27*e34*e48 + & - e24*e37*e49 + e27*e34*e49 + e16*e27*e57 + & - e15*e27*e67 + e16*e37*e57 + e15*e37*e67 + & - e19*e24*e48 + e18*e24*e49 + e19*e34*e48 + & - e18*e34*e49 + e27*e34*e57 + e24*e37*e57 + & - e27*e34*e67 + e24*e37*e67 + e15*e18*e67 + & - e16*e18*e57 + e15*e19*e67 + e16*e19*e57 -!c - basis(28) = e15*e18*e58 + e15*e19*e59 + e16*e18*e68 + & - e16*e19*e69 + e24*e28*e48 + e34*e38*e48 + & - e24*e29*e49 + e34*e39*e49 + e25*e27*e57 + & - e26*e27*e67 + e35*e37*e57 + e36*e37*e67 -!c - basis(29) = e15*e18*e59 + e15*e19*e58 + e16*e18*e69 + & - e16*e19*e68 + e24*e38*e48 + e28*e34*e48 + & - e24*e39*e49 + e29*e34*e49 + e26*e27*e57 + & - e25*e27*e67 + e36*e37*e57 + e35*e37*e67 + & - e24*e29*e48 + e24*e28*e49 + e34*e39*e48 + & - e34*e38*e49 + e27*e35*e57 + e25*e37*e57 + & - e27*e36*e67 + e26*e37*e67 + e15*e18*e68 + & - e16*e18*e58 + e15*e19*e69 + e16*e19*e59 -!c - basis(30) = e15*e18*e69 + e15*e19*e68 + e16*e18*e59 + & - e16*e19*e58 + e24*e39*e48 + e29*e34*e48 + & - e24*e38*e49 + e28*e34*e49 + e27*e36*e57 + & - e27*e35*e67 + e26*e37*e57 + e25*e37*e67 -!c - basis(31) = e15*e27*e48 + e15*e27*e49 + e16*e27*e48 + & - e16*e27*e49 + e15*e37*e48 + e15*e37*e49 + & - e16*e37*e48 + e16*e37*e49 + e18*e24*e57 + & - e19*e24*e57 + e18*e34*e57 + e19*e34*e57 + & - e18*e24*e67 + e19*e24*e67 + e18*e34*e67 + & - e19*e34*e67 -!c - basis(32) = e15*e27*e58 + e15*e27*e59 + e16*e27*e68 + & - e16*e27*e69 + e15*e37*e58 + e15*e37*e59 + & - e16*e37*e68 + e16*e37*e69 + e15*e28*e48 + & - e15*e38*e48 + e15*e29*e49 + e15*e39*e49 + & - e16*e28*e48 + e16*e38*e48 + e16*e29*e49 + & - e16*e39*e49 + e25*e27*e48 + e26*e27*e48 + & - e35*e37*e48 + e36*e37*e48 + e25*e27*e49 + & - e26*e27*e49 + e35*e37*e49 + e36*e37*e49 + & - e24*e28*e57 + e24*e29*e57 + e34*e38*e57 + & - e34*e39*e57 + e24*e28*e67 + e24*e29*e67 + & - e34*e38*e67 + e34*e39*e67 + e18*e25*e57 + & - e18*e35*e57 + e18*e26*e67 + e18*e36*e67 + & - e19*e25*e57 + e19*e35*e57 + e19*e26*e67 + & - e19*e36*e67 + e18*e24*e58 + e18*e24*e68 + & - e19*e24*e59 + e19*e24*e69 + e18*e34*e58 + & - e18*e34*e68 + e19*e34*e59 + e19*e34*e69 -!c - basis(33) = e15*e27*e68 + e15*e27*e69 + e16*e27*e58 + & - e16*e27*e59 + e15*e37*e68 + e15*e37*e69 + & - e16*e37*e58 + e16*e37*e59 + e15*e29*e48 + & - e15*e39*e48 + e15*e28*e49 + e15*e38*e49 + & - e16*e29*e48 + e16*e39*e48 + e16*e28*e49 + & - e16*e38*e49 + e27*e35*e48 + e27*e36*e48 + & - e25*e37*e48 + e26*e37*e48 + e27*e35*e49 + & - e27*e36*e49 + e25*e37*e49 + e26*e37*e49 + & - e24*e38*e57 + e24*e39*e57 + e28*e34*e57 + & - e29*e34*e57 + e24*e38*e67 + e24*e39*e67 + & - e28*e34*e67 + e29*e34*e67 + e18*e26*e57 + & - e18*e36*e57 + e18*e25*e67 + e18*e35*e67 + & - e19*e26*e57 + e19*e36*e57 + e19*e25*e67 + & - e19*e35*e67 + e18*e24*e59 + e18*e24*e69 + & - e19*e24*e58 + e19*e24*e68 + e18*e34*e59 + & - e18*e34*e69 + e19*e34*e58 + e19*e34*e68 -!c - basis(34) = e15*e28*e57 + e15*e29*e57 + e16*e28*e67 + & - e16*e29*e67 + e15*e38*e57 + e15*e39*e57 + & - e16*e38*e67 + e16*e39*e67 + e18*e25*e48 + & - e18*e35*e48 + e19*e25*e49 + e19*e35*e49 + & - e18*e26*e48 + e18*e36*e48 + e19*e26*e49 + & - e19*e36*e49 + e24*e27*e58 + e24*e27*e68 + & - e34*e37*e58 + e34*e37*e68 + e24*e27*e59 + & - e24*e27*e69 + e34*e37*e59 + e34*e37*e69 -!c - basis(35) = e15*e28*e58 + e15*e29*e59 + e16*e28*e68 + & - e16*e29*e69 + e15*e38*e58 + e15*e39*e59 + & - e16*e38*e68 + e16*e39*e69 + e25*e28*e48 + & - e35*e38*e48 + e25*e29*e49 + e35*e39*e49 + & - e26*e28*e48 + e36*e38*e48 + e26*e29*e49 + & - e36*e39*e49 + e25*e27*e58 + e26*e27*e68 + & - e35*e37*e58 + e36*e37*e68 + e25*e27*e59 + & - e26*e27*e69 + e35*e37*e59 + e36*e37*e69 + & - e24*e28*e58 + e24*e29*e59 + e34*e38*e58 + & - e34*e39*e59 + e24*e28*e68 + e24*e29*e69 + & - e34*e38*e68 + e34*e39*e69 + e25*e28*e57 + & - e35*e38*e57 + e26*e28*e67 + e36*e38*e67 + & - e25*e29*e57 + e35*e39*e57 + e26*e29*e67 + & - e36*e39*e67 + e18*e25*e58 + e18*e26*e68 + & - e19*e25*e59 + e19*e26*e69 + e18*e35*e58 + & - e18*e36*e68 + e19*e35*e59 + e19*e36*e69 -!c - basis(36) = e15*e28*e59 + e15*e29*e58 + e16*e28*e69 + & - e16*e29*e68 + e15*e38*e59 + e15*e39*e58 + & - e16*e38*e69 + e16*e39*e68 + e25*e38*e48 + & - e28*e35*e48 + e25*e39*e49 + e29*e35*e49 + & - e26*e38*e48 + e28*e36*e48 + e26*e39*e49 + & - e29*e36*e49 + e26*e27*e58 + e25*e27*e68 + & - e36*e37*e58 + e35*e37*e68 + e26*e27*e59 + & - e25*e27*e69 + e36*e37*e59 + e35*e37*e69 + & - e24*e29*e58 + e24*e28*e59 + e34*e39*e58 + & - e34*e38*e59 + e24*e29*e68 + e24*e28*e69 + & - e34*e39*e68 + e34*e38*e69 + e28*e35*e57 + & - e25*e38*e57 + e28*e36*e67 + e26*e38*e67 + & - e29*e35*e57 + e25*e39*e57 + e29*e36*e67 + & - e26*e39*e67 + e18*e25*e68 + e18*e26*e58 + & - e19*e25*e69 + e19*e26*e59 + e18*e35*e68 + & - e18*e36*e58 + e19*e35*e69 + e19*e36*e59 -!c - basis(37) = e15*e28*e67 + e15*e29*e67 + e16*e28*e57 + & - e16*e29*e57 + e15*e38*e67 + e15*e39*e67 + & - e16*e38*e57 + e16*e39*e57 + e19*e25*e48 + & - e19*e35*e48 + e18*e25*e49 + e18*e35*e49 + & - e19*e26*e48 + e19*e36*e48 + e18*e26*e49 + & - e18*e36*e49 + e27*e34*e58 + e27*e34*e68 + & - e24*e37*e58 + e24*e37*e68 + e27*e34*e59 + & - e27*e34*e69 + e24*e37*e59 + e24*e37*e69 -!c - basis(38) = e15*e28*e68 + e15*e29*e69 + e16*e28*e58 + & - e16*e29*e59 + e15*e38*e68 + e15*e39*e69 + & - e16*e38*e58 + e16*e39*e59 + e25*e29*e48 + & - e35*e39*e48 + e25*e28*e49 + e35*e38*e49 + & - e26*e29*e48 + e36*e39*e48 + e26*e28*e49 + & - e36*e38*e49 + e27*e35*e58 + e27*e36*e68 + & - e25*e37*e58 + e26*e37*e68 + e27*e35*e59 + & - e27*e36*e69 + e25*e37*e59 + e26*e37*e69 + & - e24*e38*e58 + e24*e39*e59 + e28*e34*e58 + & - e29*e34*e59 + e24*e38*e68 + e24*e39*e69 + & - e28*e34*e68 + e29*e34*e69 + e26*e28*e57 + & - e36*e38*e57 + e25*e28*e67 + e35*e38*e67 + & - e26*e29*e57 + e36*e39*e57 + e25*e29*e67 + & - e35*e39*e67 + e18*e25*e59 + e18*e26*e69 + & - e19*e25*e58 + e19*e26*e68 + e18*e35*e59 + & - e18*e36*e69 + e19*e35*e58 + e19*e36*e68 -!c - basis(39) = e15*e28*e69 + e15*e29*e68 + e16*e28*e59 + & - e16*e29*e58 + e15*e38*e69 + e15*e39*e68 + & - e16*e38*e59 + e16*e39*e58 + e25*e39*e48 + & - e29*e35*e48 + e25*e38*e49 + e28*e35*e49 + & - e26*e39*e48 + e29*e36*e48 + e26*e38*e49 + & - e28*e36*e49 + e27*e36*e58 + e27*e35*e68 + & - e26*e37*e58 + e25*e37*e68 + e27*e36*e59 + & - e27*e35*e69 + e26*e37*e59 + e25*e37*e69 + & - e24*e39*e58 + e24*e38*e59 + e29*e34*e58 + & - e28*e34*e59 + e24*e39*e68 + e24*e38*e69 + & - e29*e34*e68 + e28*e34*e69 + e28*e36*e57 + & - e26*e38*e57 + e28*e35*e67 + e25*e38*e67 + & - e29*e36*e57 + e26*e39*e57 + e29*e35*e67 + & - e25*e39*e67 + e18*e25*e69 + e18*e26*e59 + & - e19*e25*e68 + e19*e26*e58 + e18*e35*e69 + & - e18*e36*e59 + e19*e35*e68 + e19*e36*e58 -!c - basis(40) = e25*e28*e58 + e25*e29*e59 + e26*e28*e68 + & - e26*e29*e69 + e35*e38*e58 + e35*e39*e59 + & - e36*e38*e68 + e36*e39*e69 -!c - basis(41) = e25*e28*e59 + e25*e29*e58 + e26*e28*e69 + & - e26*e29*e68 + e35*e38*e59 + e35*e39*e58 + & - e36*e38*e69 + e36*e39*e68 + e25*e38*e58 + & - e28*e35*e58 + e25*e39*e59 + e29*e35*e59 + & - e26*e38*e68 + e28*e36*e68 + e26*e39*e69 + & - e29*e36*e69 + e26*e28*e58 + e25*e28*e68 + & - e36*e38*e58 + e35*e38*e68 + e26*e29*e59 + & - e25*e29*e69 + e36*e39*e59 + e35*e39*e69 -!c - basis(42) = e25*e28*e69 + e25*e29*e68 + e26*e28*e59 + & - e26*e29*e58 + e35*e38*e69 + e35*e39*e68 + & - e36*e38*e59 + e36*e39*e58 + e25*e39*e58 + & - e29*e35*e58 + e25*e38*e59 + e28*e35*e59 + & - e26*e39*e68 + e29*e36*e68 + e26*e38*e69 + & - e28*e36*e69 + e28*e36*e58 + e28*e35*e68 + & - e26*e38*e58 + e25*e38*e68 + e29*e36*e59 + & - e29*e35*e69 + e26*e39*e59 + e25*e39*e69 -!c - basis(43) = e25*e38*e69 + e25*e39*e68 + e26*e38*e59 + & - e26*e39*e58 + e28*e35*e69 + e29*e35*e68 + & - e28*e36*e59 + e29*e36*e58 -!c --------------------------------------------------------------------- - return - end subroutine calc_basis_1 - - end module IPModel_WaterTrimer_Gillan_module - - - diff --git a/src/Potentials/IPModel_ZBL.f95 b/src/Potentials/IPModel_ZBL.f95 deleted file mode 100644 index a612f8553c..0000000000 --- a/src/Potentials/IPModel_ZBL.f95 +++ /dev/null @@ -1,311 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_ZBL -!X -!% Module for Ziegler-Biersack-Littmark potential for -!% screened nuclear repulsion -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_ZBL_module - -use error_module -use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) -use units_module -use dictionary_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use periodictable_module, only : ElementCovRad - -use mpi_context_module -use QUIP_Common_module - -implicit none -private - -include 'IPModel_interface.h' - -public :: IPModel_ZBL -type IPModel_ZBL - real(dp) :: cutoff = 0.0 - real(dp) :: use_cutoff = 0.0 - real(dp) :: cutoff_width = 0.0 - logical :: shift_cutoff = .false., cutoff_scale_cov_rad = .false. - real(dp) :: a_pre_exp = 0.46850 - real(dp) :: a_exp = 0.23 - real(dp) :: p_pre_exp_1 = 0.18175 - real(dp) :: p_exp_1 = -3.19980 - real(dp) :: p_pre_exp_2 = 0.50986 - real(dp) :: p_exp_2 = -0.94229 - real(dp) :: p_pre_exp_3 = 0.28022 - real(dp) :: p_exp_3 = -0.40290 - real(dp) :: p_pre_exp_4 = 0.02817 - real(dp) :: p_exp_4 = -0.20162 - real(dp) :: E_scale - character(len=STRING_LENGTH) :: label - -end type IPModel_ZBL - -logical, private :: parse_in_ip, parse_matched_label -type(IPModel_ZBL), private, pointer :: parse_ip - -interface Initialise - module procedure IPModel_ZBL_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_ZBL_Finalise -end interface Finalise - -interface Print - module procedure IPModel_ZBL_Print -end interface Print - -interface Calc - module procedure IPModel_ZBL_Calc -end interface Calc - -contains - -subroutine IPModel_ZBL_Initialise_str(this, args_str, param_str) - type(IPModel_ZBL), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_ZBL_Initialise_str args_str')) then - call system_abort("IPModel_ZBL_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call param_register(params, 'E_scale', '1.0', this%E_scale, help_string="E_scale") - call param_register(params, 'cutoff', '0.0', this%cutoff, help_string="cutoff") - call param_register(params, 'cutoff_width', '0.0', this%cutoff_width, help_string="smooth cutoff width") - call param_register(params, 'shift_cutoff', 'F', this%shift_cutoff, help_string="shift value at cutoff to equal 0") - call param_register(params, 'cutoff_scale_cov_rad', 'F', this%cutoff_scale_cov_rad, help_string="multiply cutoff by sum of covalent radii (but cutoff_width is absolute)") - call param_register(params, 'a_pre_exp', '0.46850', this%a_pre_exp, help_string="pre-exponential factor for screening parameter") - call param_register(params, 'a_exp', '0.23', this%a_exp, help_string="exponent of charge of nuclei") - call param_register(params, 'p_pre_exp_1', '0.18175', this%p_pre_exp_1, help_string="first pre-exponential factor of screening function") - call param_register(params, 'p_exp_1', '-3.19980', this%p_exp_1, help_string="first exponent of screening function") - call param_register(params, 'p_pre_exp_2', '0.50986', this%p_pre_exp_2, help_string="second pre-exponential factor of screening function") - call param_register(params, 'p_exp_2', '-0.94229', this%p_exp_2, help_string="second exponent of screening function") - call param_register(params, 'p_pre_exp_3', '0.28022', this%p_pre_exp_3, help_string="third pre-exponential factor of screening function") - call param_register(params, 'p_exp_3', '-0.40290', this%p_exp_3, help_string="third exponent of screening function") - call param_register(params, 'p_pre_exp_4', '0.02817', this%p_pre_exp_4, help_string="fourth pre-exponential factor of screening function") - call param_register(params, 'p_exp_4', '-0.20162', this%p_exp_4, help_string="fourth exponent of screening function") - - if (param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_ZBL_Initialise_str args_str')) then - end if - - ! by default cutoff used is cutoff set - this%use_cutoff = this%cutoff - if (this%cutoff_scale_cov_rad) then - ! if cutoff is actually scale for covalent rad sum, set externally accessible - ! cutoff to be max possible value for any element - this%cutoff = 2.0*maxval(ElementCovRad) - endif - - call finalise(params) - -end subroutine IPModel_ZBL_Initialise_str - -subroutine IPModel_ZBL_Finalise(this) - type(IPModel_ZBL), intent(inout) :: this - - this%label = '' -end subroutine IPModel_ZBL_Finalise - -subroutine IPModel_ZBL_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_ZBL), intent(inout):: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) - character(len=*), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - integer :: i, ji, j - logical :: i_is_min_image - real(dp) :: ke_e2 = 14.3996458521 !% Coulomb's constant x elemntary charge^{2} in eV*A - real(dp) :: r, rs, dr(3) - real(dp) :: a, c - real(dp) :: t_1, t_2, t_3, t_4 - real(dp) :: rs_shifted, t_1_shifted, t_2_shifted, t_3_shifted, t_4_shifted, c_shifted - real(dp) :: de, de_dr - real(dp) :: f_cut = 1.0, df_cut = 0.0 - real(dp) :: use_cutoff - - type(Dictionary) :: params - logical :: has_atom_mask_name - logical, dimension(:), pointer :: atom_mask_pointer - character(STRING_LENGTH) :: atom_mask_name - - INIT_ERROR(error) - - if (present(e)) e = 0.0 - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_ZBL_Calc', error) - local_e = 0.0 - endif - if (present(f)) then - call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_ZBL_Calc', error) - f = 0.0 - end if - if (present(virial)) virial = 0.0 - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_ZBL_Calc', error) - local_virial = 0.0 - RAISE_ERROR('IPModel_ZBL_Calc: local_virial calculation requested but not supported yet',error) - endif - if (present(local_e)) then - RAISE_ERROR('IPModel_ZBL_Calc: local_e calculation requested but not supported yet',error) - end if - - atom_mask_pointer => null() - if (present(args_str)) then - call initialise(params) - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target = has_atom_mask_name, help_string="name of atom_mask property") - if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_ZBL_args_str')) then - RAISE_ERROR("IPModel_ZBL_Calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - endif - if (has_atom_mask_name) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then - RAISE_ERROR("IPModel_ZBL_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) - endif - endif - - use_cutoff = this%use_cutoff - do i = 1, at%N - if (associated(atom_mask_pointer)) then - if (.not. atom_mask_pointer(i)) cycle - endif - - i_is_min_image = is_min_image(at,i) - - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - do ji = 1, n_neighbours(at, i) - j = neighbour(at, i, ji, distance=r, cosines=dr) - - ! if (i < j) cycle - - if (this%cutoff_scale_cov_rad) use_cutoff = this%use_cutoff * (ElementCovRad(at%Z(i))+ElementCovRad(at%Z(j))) - - if (use_cutoff == 0.0 .or. r <= use_cutoff) then - c = ke_e2*real(at%Z(i))*real(at%Z(j))/r - a = this%a_pre_exp/(real(at%Z(i))**this%a_exp + real(at%Z(j))**this%a_exp) - rs = r/a - t_1 = this%p_pre_exp_1*exp(this%p_exp_1*rs) - t_2 = this%p_pre_exp_2*exp(this%p_exp_2*rs) - t_3 = this%p_pre_exp_3*exp(this%p_exp_3*rs) - t_4 = this%p_pre_exp_4*exp(this%p_exp_4*rs) - if (use_cutoff > 0.0 .and. this%cutoff_width > 0.0) f_cut = poly_switch(r, use_cutoff, this%cutoff_width) - de = c*(t_1+t_2+t_3+t_4) - if (this%shift_cutoff) then - c_shifted = ke_e2*real(at%Z(i))*real(at%Z(j))/use_cutoff - rs_shifted = use_cutoff/a - t_1_shifted = this%p_pre_exp_1*exp(this%p_exp_1*rs_shifted) - t_2_shifted = this%p_pre_exp_2*exp(this%p_exp_2*rs_shifted) - t_3_shifted = this%p_pre_exp_3*exp(this%p_exp_3*rs_shifted) - t_4_shifted = this%p_pre_exp_4*exp(this%p_exp_4*rs_shifted) - de = de - c_shifted*(t_1_shifted+t_2_shifted+t_3_shifted+t_4_shifted) - endif - if (present(e)) then - e = e + 0.5*de*f_cut - end if - if (present(f) .or. present(virial)) then - if (use_cutoff > 0.0 .and. this%cutoff_width > 0.0) df_cut = dpoly_switch(r, use_cutoff, this%cutoff_width) - de_dr = -c/r*(t_1+t_2+t_3+t_4) + c/a*(this%p_exp_1*t_1+this%p_exp_2*t_2+this%p_exp_3*t_3+this%p_exp_4*t_4) - de_dr = de_dr*f_cut + de*df_cut - if (present(f)) then - f(:,i) = f(:,i) + 0.5*de_dr*dr - f(:,j) = f(:,j) - 0.5*de_dr*dr - end if - if (present(virial)) then - virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*r - endif - end if - end if - end do - end do - - if(present(e)) e = e*this%E_scale - if(present(f)) f = f*this%E_scale - if(present(virial)) virial = virial*this%E_scale - if(present(local_e)) local_e = local_e*this%E_scale - - if (present(mpi)) then - if (present(e)) e = sum(mpi, e) - if (present(local_e)) call sum_in_place(mpi, local_e) - if (present(virial)) call sum_in_place(mpi, virial) - if (present(f)) call sum_in_place(mpi, f) - endif - -end subroutine IPModel_ZBL_Calc - - -subroutine IPModel_ZBL_Print(this, file) - type(IPModel_ZBL), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call Print("IPModel_ZBL : ZBL Potential", file=file) - call Print("IPModel_ZBL : cutoff = " // this%cutoff, file=file) - call Print("IPModel_ZBL : cutoff_width = " // this%cutoff_width, file=file) - call Print("IPModel_ZBL : a_pre_exp = " // this%a_pre_exp, file=file) - call Print("IPModel_ZBL : a_exp = " // this%a_exp, file=file) - call Print("IPModel_ZBL : p_pre_exp_1 = " // this%p_pre_exp_1, file=file) - call Print("IPModel_ZBL : p_exp_1 = " // this%p_exp_1, file=file) - call Print("IPModel_ZBL : p_pre_exp_2 = " // this%p_pre_exp_2, file=file) - call Print("IPModel_ZBL : p_exp_2 = " // this%p_exp_2, file=file) - call Print("IPModel_ZBL : p_pre_exp_3 = " // this%p_pre_exp_3, file=file) - call Print("IPModel_ZBL : p_exp_3 = " // this%p_exp_3, file=file) - call Print("IPModel_ZBL : p_pre_exp_4 = " // this%p_pre_exp_4, file=file) - call Print("IPModel_ZBL : p_exp_4 = " // this%p_exp_4, file=file) - -end subroutine IPModel_ZBL_Print - -end module IPModel_ZBL_module diff --git a/src/Potentials/IPModel_vdW.f95 b/src/Potentials/IPModel_vdW.f95 deleted file mode 100644 index 1a1607f26c..0000000000 --- a/src/Potentials/IPModel_vdW.f95 +++ /dev/null @@ -1,899 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IPModel_vdW module -!X -!% Module for Gaussian Approximation Potential. -!% -!% The IPModel_vdW object contains all the parameters read from a -!% 'vdW_params' XML stanza. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module IPModel_vdW_module - -use error_module -use system_module, only : idp, dp, inoutput, string_to_int, reallocate, system_timer , print, PRINT_NERD -use units_module -use dictionary_module -use periodictable_module, only: total_elements -use extendable_str_module -use paramreader_module -use linearalgebra_module -use atoms_types_module -use atoms_module - -use mpi_context_module -use QUIP_Common_module - -#ifdef HAVE_GAP -use descriptors_module -use gp_predict_module -#endif - -implicit none - -private - -include 'IPModel_interface.h' - -#ifdef GAP_VERSION - integer, parameter :: gap_version = GAP_VERSION -#else - integer, parameter :: gap_version = 0 -#endif - -! this stuff is here for now, but it should live somewhere else eventually -! lower down in the GP - -public :: IPModel_vdW - -type IPModel_vdW - - real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. - - real(dp) :: E_scale = 0.0_dp !% scale factor for the potential - real(dp) :: sr = 0.0_dp - real(dp) :: d = 0.0_dp - real(dp) :: vdW_cutoff = 0.0_dp - real(dp) :: vdW_cutoff_buffer = 0.0_dp - - character(len=STRING_LENGTH) :: label - -#ifdef HAVE_GAP - type(gpSparse) :: my_gp - type(descriptor), dimension(:), allocatable :: my_descriptor -#endif - real(dp), dimension(total_elements) :: e0 = 0.0_dp - integer(idp), dimension(total_elements) :: map = -1 - integer :: n_types = 0 - integer, dimension(:), allocatable :: Z - real(dp), dimension(:), allocatable :: r0 - real(dp), dimension(:), allocatable :: alpha0 - real(dp), dimension(:), allocatable :: c6 - real(dp), dimension(:,:), allocatable :: c6_pair - - - logical :: initialised = .false. - type(extendable_str) :: command_line - integer :: xml_version - -end type IPModel_vdW - -logical, private :: parse_in_ip, parse_in_vdW_data, parse_matched_label, parse_in_ip_done - -type(IPModel_vdW), private, pointer :: parse_ip -type(extendable_str), save :: parse_cur_data - -interface Initialise - module procedure IPModel_vdW_Initialise_str -end interface Initialise - -interface Finalise - module procedure IPModel_vdW_Finalise -end interface Finalise - -interface Print - module procedure IPModel_vdW_Print -end interface Print - -interface Calc - module procedure IPModel_vdW_Calc -end interface Calc - -contains - -subroutine IPModel_vdW_Initialise_str(this, args_str, param_str) - type(IPModel_vdW), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(Dictionary) :: params - - integer :: n, m, i_coordinate - - call Finalise(this) - - ! now initialise the potential -#ifndef HAVE_GAP - call system_abort('IPModel_vdW_Initialise_str: must be compiled with HAVE_GAP') -#else - - call initialise(params) - this%label='' - - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'E_scale', '1.0', this%E_scale, help_string="rescaling factor for the potential") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Initialise_str args_str')) & - call system_abort("IPModel_vdW_Initialise_str failed to parse label from args_str="//trim(args_str)) - call finalise(params) - - call IPModel_vdW_read_params_xml(this, param_str) - call gp_readXML(this%my_gp, param_str,label=trim(this%label)) - - do n = 1, this%n_types - this%map(this%Z(n)) = n - enddo - - allocate(this%c6_pair(this%n_types,this%n_types)) - do n = 1, this%n_types - do m = 1, this%n_types - this%c6_pair(m,n) = 2.0_dp * ( this%alpha0(n)*this%alpha0(m)*this%c6(n)*this%c6(m) ) / & - ( this%alpha0(n)**2 * this%c6(m) + this%alpha0(m)**2 * this%c6(n) ) - enddo - enddo - - allocate(this%my_descriptor(this%my_gp%n_coordinate)) - - this%cutoff = 0.0_dp - do i_coordinate = 1, this%my_gp%n_coordinate - call concat(this%my_gp%coordinate(i_coordinate)%descriptor_str," xml_version="//this%xml_version) - call initialise(this%my_descriptor(i_coordinate),string(this%my_gp%coordinate(i_coordinate)%descriptor_str)) - this%cutoff = max(this%cutoff,cutoff(this%my_descriptor(i_coordinate))) - enddo - this%cutoff = max(this%cutoff,this%vdW_cutoff) - -#endif - -end subroutine IPModel_vdW_Initialise_str - -subroutine IPModel_vdW_Finalise(this) - type(IPModel_vdW), intent(inout) :: this -#ifdef HAVE_GAP - - if (this%my_gp%initialised) call finalise(this%my_gp) - if(allocated(this%Z)) deallocate(this%Z) - if(allocated(this%r0)) deallocate(this%r0) - if(allocated(this%alpha0)) deallocate(this%alpha0) - if(allocated(this%c6)) deallocate(this%c6) - if(allocated(this%c6_pair)) deallocate(this%c6_pair) - this%n_types = 0 - this%map = -1 - - this%cutoff = 0.0_dp - this%vdW_cutoff = 0.0_dp - this%sr = 0.0_dp - this%d = 0.0_dp - - this%label = '' - this%initialised = .false. -#endif - - call finalise(this%command_line) - -end subroutine IPModel_vdW_Finalise - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% The potential calculator: this routine computes energy, forces and the virial. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_vdW_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) - type(IPModel_vdW), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. - real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} - real(dp), intent(out), optional :: virial(3,3) !% Virial - character(len=*), intent(in), optional :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - -#ifdef HAVE_GAP - type v_data - real(dp) :: v - integer :: n_lo, n_up - integer, dimension(:), allocatable :: j - real(dp), dimension(:,:), allocatable :: deriv - real(dp), dimension(:,:), allocatable :: diff - endtype v_data - - character(STRING_LENGTH) :: atom_mask_name - - logical :: has_atom_mask_name, do_rescale_r, do_rescale_E, do_select_descriptor, do_derivative - logical, dimension(:), pointer :: atom_mask_pointer - logical, dimension(:), allocatable :: mpi_local_mask - - integer :: only_descriptor, i_coordinate, d, i, j, k, i_desc, n, m - - real(dp) :: r_scale, E_scale, v_i, v_i_cutoff, r_ij, & - r6_ij, dr6_ij_dr_ij, scaled_buffer, f_cut_ij, df_cut_ij_dr_ij, & - c6_eff, r0_ij, d_sR_r0_ij, exp_factor, f_damp, e_i, & - df_damp_dr_ij, df_damp_dr0_ij, df_damp_dvi, df_damp_dvj, dc6_eff_dvi, dc6_eff_dvj, & - de_i_dr_ij - real(dp), dimension(3) :: v_deriv, u_ij, f_ij, de_i_drk - real(dp), dimension(:), allocatable :: grad_predict, r0_eff, dr0_eff_dv - real(dp), dimension(:), allocatable :: local_e_in - real(dp), dimension(:,:), allocatable :: f_in - real(dp), dimension(:,:,:), allocatable :: virial_in - - type(Dictionary) :: params - type(descriptor_data), target :: my_descriptor_data - type(extendable_str) :: my_args_str - type(v_data), dimension(:), allocatable :: local_v - - !real(dp) :: e_i, e_i_cutoff - !integer :: d, i, j, n, m, i_coordinate, i_pos0 - - - !real(dp), dimension(3) :: pos, f_gp - !real(dp), dimension(3,3) :: virial_i - !type(Dictionary) :: params - !logical :: has_atom_mask_name - !character(STRING_LENGTH) :: atom_mask_name, calc_local_gap_variance, calc_energy_per_coordinate - !real(dp) :: r_scale, E_scale - - !real(dp) :: gap_variance_i_cutoff - !real(dp), dimension(:), allocatable :: gap_variance, local_gap_variance_in - !real(dp), dimension(:), pointer :: local_gap_variance_pointer - !real(dp), dimension(:,:), allocatable :: gap_variance_gradient_in - !real(dp), dimension(:,:), pointer :: gap_variance_gradient_pointer - !real(dp) :: gap_variance_regularisation - !logical :: do_rescale_r, do_rescale_E, do_gap_variance, print_gap_variance, do_local_gap_variance, do_energy_per_coordinate - !integer :: only_descriptor - !logical :: do_select_descriptor - !logical :: mpi_parallel_descriptor - - !type(descriptor_data) :: my_descriptor_data - !type(extendable_str) :: my_args_str - - INIT_ERROR(error) - - if (present(e)) then - e = 0.0_dp - endif - - if (present(local_e)) then - call check_size('Local_E',local_e,(/at%N/),'IPModel_vdW_Calc', error) - local_e = 0.0_dp - endif - - if (present(f)) then - call check_size('Force',f,(/3,at%N/),'IPModel_vdW_Calc', error) - f = 0.0_dp - end if - - if (present(virial)) then - virial = 0.0_dp - endif - - if (present(local_virial)) then - call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_vdW_Calc', error) - local_virial = 0.0_dp - endif - - do_derivative = present(f) .or. present(virial) .or. present(local_virial) - - atom_mask_pointer => null() - has_atom_mask_name = .false. - atom_mask_name = "" - only_descriptor = 0 - - if( any(this%map(at%Z) == -1) ) then - RAISE_ERROR("IPModel_vdW_Calc: atoms object contains atom types for which vdW parameters were not specified",error) - endif - - call initialise(params) - - call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, & - help_string="Name of a logical property in the atoms object. For atoms where this property is true, energies, forces, virials etc. are " // & - "calculated") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.") - call param_register(params, 'only_descriptor', '0', only_descriptor, has_value_target=do_select_descriptor, help_string="Only select a single coordinate") - - if(present(args_str)) then - if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_vdW_Calc args_str')) & - call system_abort("IPModel_vdW_Calc failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - - if( has_atom_mask_name ) then - if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & - call system_abort("IPModel_vdW_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("IPModel_vdW_Calc: rescaling of potential at the calc() stage with r_scale and E_scale not yet implemented!", error) - end if - - my_args_str = trim(args_str) - else - ! call parser to set defaults - if (.not. param_read_line(params,"",ignore_unknown=.true.,task='IPModel_vdW_Calc args_str')) & - call system_abort("IPModel_vdW_Calc failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - call initialise(my_args_str) - endif - - if( present(mpi) ) then - if(mpi%active) then - if(has_atom_mask_name) then - RAISE_ERROR("IPModel_vdW: atom_mask_name "//trim(atom_mask_name)//" present while running MPI version."// \ - " The use of atom_mask_name is intended for serial-compiled code called from an external parallel code, such as LAMMPS",error) - endif - - if( has_property(at,"mpi_local_mask") ) then - RAISE_ERROR("IPModel_vdW: mpi_local_mask property already present", error) - endif - - allocate(mpi_local_mask(at%N)) - call add_property_from_pointer(at,'mpi_local_mask',mpi_local_mask,error=error) - call concat(my_args_str," atom_mask_name=mpi_local_mask") - endif - endif - - call concat(my_args_str," xml_version="//this%xml_version) - - allocate(local_v(at%N)) - do i = 1, at%N - local_v(i)%v = this%e0(at%Z(i)) - enddo - - do i_coordinate = 1, this%my_gp%n_coordinate - - if (do_select_descriptor .and. (this%my_gp%n_coordinate > 1)) then - if (i_coordinate /= only_descriptor) then - call print("vdW label="//trim(this%label)//" skipping coordinate "//i_coordinate, PRINT_NERD) - cycle - end if - end if - - if(mpi%active) call descriptor_MPI_setup(this%my_descriptor(i_coordinate),at,mpi,mpi_local_mask,error) - - d = descriptor_dimensions(this%my_descriptor(i_coordinate)) - - if( do_derivative ) then - if (allocated(grad_predict)) deallocate(grad_predict) - allocate(grad_predict(d)) - end if - call calc(this%my_descriptor(i_coordinate),at,my_descriptor_data, & - do_descriptor=.true.,do_grad_descriptor=present(f) .or. present(virial) .or. present(local_virial), args_str=trim(string(my_args_str)), error=error) - PASS_ERROR(error) - do i_desc = 1, size(my_descriptor_data%x) - if( size(my_descriptor_data%x(i_desc)%ci) /= 1 ) then - RAISE_ERROR("IPModel_vdW_Calc: descriptor is not local and atomic",error) - endif - i = my_descriptor_data%x(i_desc)%ci(1) - - if ( do_derivative ) then - local_v(i)%n_lo = lbound(my_descriptor_data%x(i_desc)%ii,1) - local_v(i)%n_up = ubound(my_descriptor_data%x(i_desc)%ii,1) - allocate(local_v(i)%deriv(3,local_v(i)%n_lo:local_v(i)%n_up), & - local_v(i)%j(local_v(i)%n_lo:local_v(i)%n_up), & - local_v(i)%diff(3,local_v(i)%n_lo:local_v(i)%n_up)) - do n = local_v(i)%n_lo, local_v(i)%n_up - local_v(i)%diff(:,n) = my_descriptor_data%x(i_desc)%pos(:,n) - & - my_descriptor_data%x(i_desc)%pos(:,local_v(i)%n_lo) - enddo - local_v(i)%j = my_descriptor_data%x(i_desc)%ii - local_v(i)%deriv = 0.0_dp - endif - enddo - -!$omp parallel default(none) private(i_desc,n,i,grad_predict,v_i,v_i_cutoff,v_deriv) & -!$omp shared(this,d,i_coordinate,my_descriptor_data,f,virial,local_virial,local_v,do_derivative) -!$omp do schedule(dynamic) - do i_desc = 1, size(my_descriptor_data%x) - if(present(f) .or. present(virial) .or. present(local_virial)) then - call reallocate(grad_predict,d,zero=.true.) - v_i = gp_predict(this%my_gp%coordinate(i_coordinate), & - xStar=my_descriptor_data%x(i_desc)%data(:), & - gradPredict = grad_predict ) - else - v_i = gp_predict(this%my_gp%coordinate(i_coordinate), xStar=my_descriptor_data%x(i_desc)%data(:)) - endif - - v_i_cutoff = v_i * my_descriptor_data%x(i_desc)%covariance_cutoff - i = my_descriptor_data%x(i_desc)%ci(1) - local_v(i)%v = local_v(i)%v + v_i_cutoff - - if( do_derivative ) then - do n = lbound(my_descriptor_data%x(i_desc)%ii,1), ubound(my_descriptor_data%x(i_desc)%ii,1) - if( .not. my_descriptor_data%x(i_desc)%has_grad_data(n) ) cycle - v_deriv = matmul( grad_predict,my_descriptor_data%x(i_desc)%grad_data(:,:,n)) * my_descriptor_data%x(i_desc)%covariance_cutoff + & - v_i * my_descriptor_data%x(i_desc)%grad_covariance_cutoff(:,n) - local_v(i)%deriv(:,n) = local_v(i)%deriv(:,n) + v_deriv - enddo - endif - enddo -!$omp end do - if(allocated(grad_predict)) deallocate(grad_predict) -!$omp end parallel - call finalise(my_descriptor_data) - enddo - - ! Has to be allocated as it's in the reduction clause. - allocate(local_e_in(at%N)) - local_e_in = 0.0_dp - - allocate(f_in(3,at%N)) - f_in = 0.0_dp - - allocate(virial_in(3,3,at%N)) - virial_in = 0.0_dp - - allocate(r0_eff(at%N)) - if( do_derivative ) then - allocate(dr0_eff_dv(at%N)) - endif - - do i = 1, at%N - r0_eff(i) = local_v(i)%v**(1.0_dp/3.0_dp) * this%r0(this%map(at%Z(i))) - if( do_derivative ) then - dr0_eff_dv(i) = r0_eff(i) / local_v(i)%v / 3.0_dp - endif - enddo - - -!$omp parallel default(none) private(i,j,k,n,m,r_ij,u_ij,r6_ij,dr6_ij_dr_ij,scaled_buffer,f_cut_ij,df_cut_ij_dr_ij, & -!$omp c6_eff,r0_ij,d_sR_r0_ij,exp_factor,f_damp,e_i,df_damp_dr_ij,df_damp_dr0_ij,df_damp_dvi,df_damp_dvj, & -!$omp dc6_eff_dvi,dc6_eff_dvj,de_i_dr_ij,f_ij,de_i_drk) & -!$omp shared(this,at,e,f,virial,do_derivative,local_v,r0_eff,dr0_eff_dv) & -!$omp reduction(+:local_e_in,f_in,virial_in) -!$omp do schedule(dynamic) - do i = 1, at%N - do n = 1, n_neighbours(at,i) - j = neighbour(at, i, n, distance=r_ij, cosines=u_ij) - - if( r_ij > this%vdW_cutoff ) cycle - - r6_ij = 1.0_dp / r_ij**6 - if( do_derivative ) dr6_ij_dr_ij = -6.0_dp * r6_ij / r_ij - - if( r_ij > this%vdW_cutoff - this%vdW_cutoff_buffer ) then - scaled_buffer = ( r_ij - this%vdW_cutoff + this%vdW_cutoff_buffer ) / this%vdW_cutoff_buffer - f_cut_ij = 1.0_dp - 3.0_dp*scaled_buffer**2 + 2.0_dp*scaled_buffer**3 - - if( do_derivative ) then - df_cut_ij_dr_ij = -6.0_dp*(scaled_buffer+scaled_buffer**2) / this%vdW_cutoff_buffer - dr6_ij_dr_ij = dr6_ij_dr_ij*f_cut_ij + r6_ij*df_cut_ij_dr_ij - endif - r6_ij = r6_ij*f_cut_ij - endif - - c6_eff = local_v(i)%v * local_v(j)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i))) - r0_ij = r0_eff(i) + r0_eff(j) - - d_sR_r0_ij = this%d / this%sR / r0_ij - exp_factor = exp( -d_sR_r0_ij*r_ij + this%d ) - f_damp = 1.0_dp / ( 1.0_dp + exp_factor ) - - e_i = -0.5*f_damp*c6_eff*r6_ij - local_e_in(i) = local_e_in(i) + e_i - - if(do_derivative) then - df_damp_dr_ij = f_damp**2 * exp_factor * d_sR_r0_ij - df_damp_dr0_ij = -df_damp_dr_ij * r_ij / r0_ij - - df_damp_dvi = df_damp_dr0_ij * dr0_eff_dv(i) - df_damp_dvj = df_damp_dr0_ij * dr0_eff_dv(j) - - dc6_eff_dvi = local_v(j)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i))) - dc6_eff_dvj = local_v(i)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i))) - - de_i_dr_ij = 0.5_dp*(f_damp*c6_eff*dr6_ij_dr_ij + df_damp_dr_ij*c6_eff*r6_ij) - f_ij = de_i_dr_ij*u_ij - if(present(f)) then - f_in(:,i) = f_in(:,i) - f_ij - f_in(:,j) = f_in(:,j) + f_ij - endif - if(present(virial)) then - virial_in(:,:,j) = virial_in(:,:,j) + ( f_ij .outer. u_ij ) * r_ij - endif - - do m = local_v(i)%n_lo, local_v(i)%n_up - k = local_v(i)%j(m) - de_i_drk = (df_damp_dvi*c6_eff + f_damp*dc6_eff_dvi)*r6_ij* & - local_v(i)%deriv(:,m) - if(present(f)) f_in(:,k) = f_in(:,k) + de_i_drk - if(present(virial)) then - virial_in(:,:,k) = virial_in(:,:,k) + (de_i_drk .outer. local_v(i)%diff(:,m)) - endif - enddo - endif - - enddo - enddo -!$omp end do -!$omp end parallel - - if(present(f)) f = f_in - if(present(e)) e = sum(local_e_in) - if(present(local_e)) local_e = local_e_in - if(present(virial)) virial = sum(virial_in,dim=3) - - if(present(local_virial)) then - do i = 1, at%N - local_virial(:,i) = reshape(virial_in(:,:,i),(/9/)) - enddo - endif - - if(allocated(local_e_in)) deallocate(local_e_in) - if(allocated(f_in)) deallocate(f_in) - if(allocated(virial_in)) deallocate(virial_in) - - if (present(mpi)) then - if( mpi%active ) then - if(present(f)) call sum_in_place(mpi,f) - if(present(virial)) call sum_in_place(mpi,virial) - if(present(local_virial)) call sum_in_place(mpi,local_virial) - if(present(e)) e = sum(mpi,e) - if(present(local_e) ) call sum_in_place(mpi,local_e) - - call remove_property(at,'mpi_local_mask', error=error) - deallocate(mpi_local_mask) - endif - endif - -! if(present(e)) then -! if( associated(atom_mask_pointer) ) then -! e = e + sum(this%e0(at%Z),mask=atom_mask_pointer) -! else -! e = e + sum(this%e0(at%Z)) -! endif -! endif -! -! if(present(local_e)) then -! if( associated(atom_mask_pointer) ) then -! where (atom_mask_pointer) local_e = local_e + this%e0(at%Z) -! else -! local_e = local_e + this%e0(at%Z) -! endif -! endif - - if(present(f)) f = this%E_scale * f - if(present(e)) e = this%E_scale * e - if(present(local_e)) local_e = this%E_scale * local_e - if(present(virial)) virial = this%E_scale * virial - if(present(local_virial)) local_virial = this%E_scale * local_virial - - atom_mask_pointer => null() - call finalise(my_args_str) - - if(allocated(local_v)) then - do i = 1, at%N - local_v(i)%v = 0.0_dp - if(allocated(local_v(i)%deriv)) deallocate(local_v(i)%deriv) - if(allocated(local_v(i)%j)) deallocate(local_v(i)%j) - if(allocated(local_v(i)%diff)) deallocate(local_v(i)%diff) - enddo - deallocate(local_v) - endif - if( allocated(r0_eff) ) deallocate(r0_eff) - if( allocated(dr0_eff_dv) ) deallocate(dr0_eff_dv) - -! if(present(e) .or. present(local_e)) then -! -! e_i_cutoff = e_i * my_descriptor_data%x(i)%covariance_cutoff / size(my_descriptor_data%x(i)%ci) -! call print("vdWDEBUG ci="//my_descriptor_data%x(i)%ci//" e_i="//e_i//" e_i_cutoff="//e_i_cutoff, PRINT_NERD) -! -! do n = 1, size(my_descriptor_data%x(i)%ci) -! local_e_in( my_descriptor_data%x(i)%ci(n) ) = local_e_in( my_descriptor_data%x(i)%ci(n) ) + e_i_cutoff -! enddo -! endif -! -! if(present(f) .or. present(virial) .or. present(local_virial)) then -! i_pos0 = lbound(my_descriptor_data%x(i)%ii,1) -! -! do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1) -! if( .not. my_descriptor_data%x(i)%has_grad_data(n) ) cycle -! j = my_descriptor_data%x(i)%ii(n) -! pos = my_descriptor_data%x(i)%pos(:,n) -! f_gp = matmul( gradPredict,my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff + & -! e_i * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) -! if( present(f) ) then -! f_in(:,j) = f_in(:,j) - f_gp -! endif -! if( do_local_gap_variance ) then -! gap_variance_gradient_in(:,j) = gap_variance_gradient_in(:,j) + & -! matmul( grad_variance_estimate, my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff**2 + & -! 2.0_dp * gap_variance(i) * my_descriptor_data%x(i)%covariance_cutoff * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) -! endif -! if( present(virial) .or. present(local_virial) ) then -! virial_i = ((pos-my_descriptor_data%x(i)%pos(:,i_pos0)) .outer. f_gp) -! virial_in(:,:,j) = virial_in(:,:,j) - virial_i -! -! !virial_i = (pos .outer. f_gp) / size(my_descriptor_data%x(i)%ci) -! !do m = 1, size(my_descriptor_data%x(i)%ci) -! ! virial_in(:,:,my_descriptor_data%x(i)%ci(m)) = virial_in(:,:,my_descriptor_data%x(i)%ci(m)) - virial_i -! !enddo -! endif -! enddo -! endif -! enddo loop_over_descriptor_instances -! call system_timer('IPModel_vdW_Calc_gp_predict') - -#endif - -end subroutine IPModel_vdW_Calc - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% XML param reader functions. -!% An example for XML stanza is given below, please notice that -!% they are simply dummy parameters for testing purposes, with no physical meaning. -!% -!%> -!%> -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - - integer :: ri, Z - - if(name == 'vdW_params') then ! new vdW stanza - - if(parse_in_ip) & - call system_abort("IPModel_startElement_handler entered vdW_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if(parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if(status /= 0) value = '' - - if(len(trim(parse_ip%label)) > 0) then ! we were passed in a label - if(value == parse_ip%label) then ! exact match - parse_matched_label = .true. - parse_in_ip = .true. - else ! no match - parse_in_ip = .false. - endif - else ! no label passed in - parse_in_ip = .true. - parse_ip%label = trim(value) ! if we found a label, AND didn't have one originally, pass it back to the object. - endif - - if(parse_in_ip) then - if(parse_ip%initialised) call finalise(parse_ip) - endif - - - call QUIP_FoX_get_value(attributes, 'gap_version', value, status) - if( (status == 0) ) then - parse_ip%xml_version = string_to_int(value) - if( parse_ip%xml_version > gap_version ) & - call system_abort( & - 'Database was created with a later version of the code.' // & - 'Version of code used to generate the database is '//trim(value)//'.'// & - 'Version of current code is '//gap_version//'. Please update your code.') - else - parse_ip%xml_version = 0 - endif - - call QUIP_FoX_get_value(attributes, 'sR', value, status) - if(status == 0) then - read (value, *) parse_ip%sR - else - call system_abort('IPModel_vdW_read_params_xml cannot find sR') - endif - - call QUIP_FoX_get_value(attributes, 'd', value, status) - if(status == 0) then - read (value, *) parse_ip%d - else - call system_abort('IPModel_vdW_read_params_xml cannot find d') - endif - - call QUIP_FoX_get_value(attributes, 'cutoff', value, status) - if(status == 0) then - read (value, *) parse_ip%vdW_cutoff - else - call system_abort('IPModel_vdW_read_params_xml cannot find cutoff') - endif - - call QUIP_FoX_get_value(attributes, 'cutoff_buffer', value, status) - if(status == 0) then - read (value, *) parse_ip%vdW_cutoff_buffer - else - call system_abort('IPModel_vdW_read_params_xml cannot find cutoff_buffer') - endif - - ! For good measure - parse_ip%map = -1 - - elseif(parse_in_ip .and. name == 'GAP_data') then - - call QUIP_FoX_get_value(attributes, 'e0', value, status) - if(status == 0) then - read (value, *) parse_ip%e0(1) - parse_ip%e0 = parse_ip%e0(1) - endif - - parse_in_vdW_data = .true. - - elseif(parse_in_ip .and. parse_in_vdW_data .and. name == 'e0') then - call QUIP_FoX_get_value(attributes, 'Z', value, status) - if(status == 0) then - read (value, *) Z - else - call system_abort('IPModel_vdW_read_params_xml cannot find Z') - endif - if( Z > size(parse_ip%e0) ) call system_abort('IPModel_vdW_read_params_xml: attribute Z = '//Z//' > '//size(parse_ip%e0)) - - call QUIP_FoX_get_value(attributes, 'value', value, status) - if(status == 0) then - read (value, *) parse_ip%e0(Z) - else - call system_abort('IPModel_vdW_read_params_xml cannot find value in e0') - endif - - elseif(parse_in_ip .and. name == 'per_type_data') then - parse_ip%n_types = parse_ip%n_types + 1 - call reallocate(parse_ip%Z,parse_ip%n_types,copy=.true.) - call reallocate(parse_ip%r0,parse_ip%n_types,copy=.true.) - call reallocate(parse_ip%alpha0,parse_ip%n_types,copy=.true.) - call reallocate(parse_ip%c6,parse_ip%n_types,copy=.true.) - - call QUIP_FoX_get_value(attributes, 'Z', value, status) - if(status == 0) then - read (value, *) parse_ip%Z(parse_ip%n_types) - else - call system_abort('IPModel_vdW_read_params_xml cannot find Z') - endif - - call QUIP_FoX_get_value(attributes, 'r0', value, status) - if(status == 0) then - read (value, *) parse_ip%r0(parse_ip%n_types) - else - call system_abort('IPModel_vdW_read_params_xml cannot find r0') - endif - - call QUIP_FoX_get_value(attributes, 'alpha0', value, status) - if(status == 0) then - read (value, *) parse_ip%alpha0(parse_ip%n_types) - else - call system_abort('IPModel_vdW_read_params_xml cannot find alpha0') - endif - - call QUIP_FoX_get_value(attributes, 'c6', value, status) - if(status == 0) then - read (value, *) parse_ip%c6(parse_ip%n_types) - else - call system_abort('IPModel_vdW_read_params_xml cannot find c6') - endif - endif - -end subroutine IPModel_startElement_handler - -subroutine IPModel_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ip) then - if(name == 'vdW_params') then - parse_in_ip = .false. - parse_in_ip_done = .true. - elseif(name == 'vdW_data') then - parse_in_vdW_data = .false. - - elseif(name == 'per_type_data') then - - elseif(name == 'command_line') then - parse_ip%command_line = parse_cur_data - end if - endif - -end subroutine IPModel_endElement_handler - -subroutine IPModel_characters_handler(in) - character(len=*), intent(in) :: in - - if(parse_in_ip) then - call concat(parse_cur_data, in, keep_lf=.false.) - endif - -end subroutine IPModel_characters_handler - -subroutine IPModel_vdW_read_params_xml(this, param_str) - type(IPModel_vdW), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) then - call system_abort('IPModel_vdW_read_params_xml: invalid param_str length '//len(trim(param_str)) ) - else - parse_in_ip = .false. - parse_in_ip_done = .false. - parse_matched_label = .false. - parse_ip => this - call initialise(parse_cur_data) - - call open_xml_string(fxml, param_str) - call parse(fxml, & - startElement_handler = IPModel_startElement_handler, & - endElement_handler = IPModel_endElement_handler, & - characters_handler = IPModel_characters_handler) - call close_xml_t(fxml) - - call finalise(parse_cur_data) - - if(.not. parse_in_ip_done) & - call system_abort('IPModel_vdW_read_params_xml: could not initialise vdW potential. No vdW_params present?') - this%initialised = .true. - endif - -end subroutine IPModel_vdW_read_params_xml - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!% Printing of vdW parameters: number of different types, cutoff radius, atomic numbers, etc. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -subroutine IPModel_vdW_Print (this, file, dict) - type(IPModel_vdW), intent(inout) :: this - type(Inoutput), intent(inout),optional :: file - type(Dictionary), intent(inout), optional :: dict - integer :: i - -#ifdef HAVE_GAP - call Print("IPModel_vdW : Gaussian Approximation Potential", file=file) - call Print("IPModel_vdW : label = "//this%label, file=file) - call Print("IPModel_vdW : cutoff = "//this%cutoff, file=file) - call Print("IPModel_vdW : E_scale = "//this%E_scale, file=file) - call Print("IPModel_vdW : command_line = "//string(this%command_line),file=file) - -#else -#endif - -end subroutine IPModel_vdW_Print - -end module IPModel_vdW_module diff --git a/src/Potentials/Multipole_Interactions.f95 b/src/Potentials/Multipole_Interactions.f95 deleted file mode 100644 index d9bc198f94..0000000000 --- a/src/Potentials/Multipole_Interactions.f95 +++ /dev/null @@ -1,764 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - -#include "error.inc" - -module multipole_interactions_module - - use system_module - use units_module - use extendable_str_module - use linearalgebra_module - use dictionary_module - use table_module - use periodictable_module - use connection_module - use atoms_types_module - use atoms_module - use clusters_module - use structures_module - use units_module - use functions_module - use gamma_module - - implicit none - private - -integer, parameter :: Damping_None = 0 -integer, parameter :: Damping_Exp = 1 -integer, parameter :: Damping_Erf = 2 -integer, parameter :: Damping_Erf_Uniform = 3 - -integer, parameter :: Screening_None = 0 -integer, parameter :: Screening_Yukawa = 1 -integer, parameter :: Screening_Erfc_Uniform = 2 - - - -public :: Multipole_Moments_Site_Site_Interaction, assignment(=), T_rank_zero, T_rank_one, T_rank_two, T_rank_three, finalise - -public :: Multipole_Calc_Opts -type Multipole_Calc_Opts - integer :: damping=Damping_None,screening=Screening_None,damp_exp_order - real(dp) :: erf_kappa_uniform,erfc_kappa_uniform,damp_exp_scale,yukawa_alpha,yukawa_smooth_length - logical :: do_energy, do_force, do_test, do_field, do_pot - !______________________________________________________________________________________________________ - ! Only certain dmaping/screening combinations make sense. The interactions can be damped(smeared) at short range and screened at long range - ! Short range damping can be gaussian or exponential - ! - ! erf_kappa - - ! inverse length parameter for gaussian short-range damping, used in the reciprical part of Ewald - ! but also in preventing divergence in polarisable models - ! - ! damp_exp_scale, damp_exp_order - ! - ! Exponential short-range damping as used in the TTM , FX, and AMOEBA water potentials, among others. - ! the damping goes like exp(-a(r/r0)**m) where m=damp_exp_order. Models use m=3 or m=4. a is the damp_exp_scale - ! (optional, default 1.0), and r0 is related to the damp_rad of each site, see function site_site_params. - ! - ! yukawa_alpha,smooth_length,cutoff - ! parameters for yukawa exponential screening of long-range interactions - ! - ! erfc_kappa - - ! inverse length parameter for Ewald long-range screening - ! - ! - !______________________________________________________________________________________________________ - -end type Multipole_Calc_Opts - -public :: Multipole_Interactions_Site -type Multipole_Interactions_Site - ! alpha is scalar polarisability - integer :: pos_type, charge_method, dipole_method, atomic_number, d ! d is the number of multipole components on this site, 1 if just a charge, 3 if dipole, 4 if charge+dipole - real(dp) :: charge = 0.0_dp, potential=0.0_dp, alpha=0.0_dp , e_grad_charge=0.0_dp , damp_rad=0.0_dp - real(dp), dimension(3) :: position, dipole, e_grad_pos=(/0.0_dp,0.0_dp,0.0_dp/), e_field=(/0.0_dp,0.0_dp,0.0_dp/), e_grad_dipole=(/0.0_dp,0.0_dp,0.0_dp/) - ! real(dp), dimension(3,3) :: quadrupole ! no quadrupolar interactions implemented but could be straighforwardly added - integer, dimension(:), allocatable :: atom_indices - real(dp), dimension(:,:,:), allocatable :: charge_grad_positions, dipole_grad_positions, pos_grad_positions ! are derivatives of the multipole position and components with respect to atomic positions - logical :: initialised, polarisable,damped -end type Multipole_Interactions_Site - -!% Overloaded assigment operator. -private :: Multipole_Site_Assignment -interface assignment(=) - module procedure Multipole_Site_Assignment -end interface assignment(=) - -interface finalise - module procedure Multipole_Site_Finalise -end interface finalise - -contains - -subroutine Multipole_Site_Assignment(to,from) - - type(Multipole_Interactions_Site), intent(inout) :: to - type(Multipole_Interactions_Site), intent(in) :: from - - call Multipole_Site_Finalise(to) - - to%pos_type = from%pos_type - to%polarisable = from%polarisable - to%alpha = from%alpha - to%damped = from%damped - to%damp_rad = from%damp_rad - to%charge = from%charge - to%potential = from%potential - to%e_field = from%e_field - to%d=from%d - to%atomic_number = from%atomic_number - to%position = from%position - to%dipole=from%dipole - to%e_grad_pos = from%e_grad_pos - to%charge_method = from%charge_method - to%dipole_method = from%dipole_method - to%e_grad_charge=from%e_grad_charge - to%e_grad_dipole=from%e_grad_dipole - - if (allocated(from%charge_grad_positions)) then - allocate(to%charge_grad_positions(size(from%charge_grad_positions,1),size(from%charge_grad_positions,2),size(from%charge_grad_positions,3))) - to%charge_grad_positions=from%charge_grad_positions - end if - - if (allocated(from%dipole_grad_positions)) then - allocate(to%dipole_grad_positions(size(from%dipole_grad_positions,1),size(from%dipole_grad_positions,2),size(from%dipole_grad_positions,3))) - to%dipole_grad_positions=from%dipole_grad_positions - end if - - if (allocated(from%pos_grad_positions)) then - allocate(to%pos_grad_positions(size(from%pos_grad_positions,1),size(from%pos_grad_positions,2),size(from%pos_grad_positions,3))) - to%pos_grad_positions=from%pos_grad_positions - end if - - to%initialised=.true. - -end subroutine Multipole_Site_Assignment - -subroutine Multipole_Site_Finalise(this) - - type(Multipole_Interactions_Site), intent(inout) :: this - - if (allocated(this%charge_grad_positions)) deallocate(this%charge_grad_positions) - if (allocated(this%dipole_grad_positions)) deallocate(this%dipole_grad_positions) - if (allocated(this%pos_grad_positions)) deallocate(this%pos_grad_positions) - - this%d=0 - this%charge = 0.0_dp - this%dipole = 0.0_dp - - this%atomic_number=0 - this%pos_type = 0 - this%charge_method = 0 - this%dipole_method = 0 - - this%alpha = 0.0_dp - this%damp_rad = 0.0_dp - this%potential = 0.0_dp - this%e_field = 0.0_dp - this%position = 0.0_dp - - this%initialised=.false. - -end subroutine Multipole_Site_Finalise - -! calculate pairwise damping coeffs for exponential, gaussian damping -subroutine Site_Site_Params(do_damp,do_screen,damp_rad_pairwise,erf_kappa_pairwise,radius_one,radius_two,calc_opts) - real (dp), intent(in) :: radius_one,radius_two - type(Multipole_Calc_Opts) :: calc_opts - real(dp),intent(out) :: erf_kappa_pairwise,damp_rad_pairwise - logical,intent(out)::do_damp,do_screen - - do_screen = calc_opts%screening /= Screening_None - do_damp = calc_opts%damping /= Damping_None - - if(calc_opts%damping==Damping_Erf_Uniform) then - erf_kappa_pairwise = calc_opts%erf_kappa_uniform - else if (do_damp) then - damp_rad_pairwise = sqrt(radius_one*radius_two) - damp_rad_pairwise = damp_rad_pairwise/(calc_opts%damp_exp_scale**(1.0_dp/calc_opts%damp_exp_order)) - erf_kappa_pairwise = 1.0_dp/norm((/radius_one,radius_two/)) !! equations 12,13 in J. Phys.: Condens. Matter 26 (2014) 213202 - end if - -end subroutine Site_Site_Params - - -! calculates interactions between multipole moments on two sites. -! site%d refers to the total number of multipole components on that site. If d=1 there is only a charge, if d=3 there is only a dipole -! if d=4 then the site has both a charge and a dipole. -! if multiple sites are present then the energies and forces from the different interactions are added together -recursive subroutine Multipole_Moments_Site_Site_Interaction(energy,site_one,site_two,calc_opts, cutoff,error,test) - real(dp), intent(out) :: energy - type(Multipole_Interactions_Site), intent(inout) :: site_one, site_two - type(Multipole_Calc_Opts) :: calc_opts - real(dp), optional :: cutoff - logical, optional,intent(in) :: test - integer, optional, intent(out) :: error - - integer :: i - real(dp) :: e0, e_plus, step=1.0D-8, q - real(dp), dimension(3) :: pos, dip - logical, dimension(2) :: has_charge, has_dipole - logical :: do_test - - do_test=optional_default(.false.,test) - - if (calc_opts%do_energy) energy=0.0_dp -!call print("do energy ? "//calc_opts%do_energy) -!call print("site site interaction") -!call print("position 1 "//site_one%position) -!call print("position 2 "//site_two%position) - - if (calc_opts%do_force) then - site_one%e_grad_pos = 0.0_dp - site_one%e_grad_charge = 0.0_dp - site_one%e_grad_dipole = 0.0_dp - - site_two%e_grad_pos = 0.0_dp - site_two%e_grad_charge = 0.0_dp - site_two%e_grad_dipole = 0.0_dp - end if - if (calc_opts%do_field) then - site_one%e_field = 0.0_dp - site_two%e_field = 0.0_dp - end if - if (calc_opts%do_pot) then - site_one%potential = 0.0_dp - site_two%potential = 0.0_dp - end if - - has_charge(1) = (site_one%d .eq. 1 .or. site_one%d .eq. 4) - has_charge(2) = (site_two%d .eq. 1 .or. site_two%d .eq. 4) - - has_dipole(1) = (site_one%d .eq. 3 .or. site_one%d .eq. 4) - has_dipole(2) = (site_two%d .eq. 3 .or. site_two%d .eq. 4) - - if (has_charge(1)) then - if (has_charge(2)) then - call Multipole_Interactions_Charge_Charge(energy,site_one, site_two,calc_opts,cutoff=cutoff) - end if - if (has_dipole(2)) then - call Multipole_Interactions_Charge_Dipole(energy,site_one, site_two,calc_opts,cutoff=cutoff) - end if - end if - if (has_dipole(1)) then - if (has_charge(2)) then - call Multipole_Interactions_Charge_Dipole(energy,site_two, site_one,calc_opts,cutoff=cutoff) - end if - if (has_dipole(2)) then - call Multipole_Interactions_Dipole_Dipole(energy,site_one, site_two,calc_opts,cutoff=cutoff) - end if - end if - ! if a site has both a charge and a dipole we iwll have double counted the pot and field - if (site_one%d == 4) then - site_one%e_field = 0.5_dp * site_one%e_field - site_one%potential = 0.5_dp * site_one%potential - end if - if (site_two%d == 4) then - site_two%e_field = 0.5_dp * site_two%e_field - site_two%potential = 0.5_dp * site_two%potential - end if - - -! call print("site site interaction energy is "//energy) - - - if (do_test) then - call print("testing gradients of site-site interactions with step size "//step) -! call print(" diff vec : "//site_two%position-site_one%position) - e0=energy - pos=site_one%position - do i=1,3 - site_one%position(i) = pos(i) + step - call Multipole_Moments_Site_Site_Interaction(e_plus,site_one, site_two,calc_opts,cutoff=cutoff,test=.false.) - call print("r_"//i//" : "//(site_two%position(i)-site_one%position(i))//" gradient : "//site_one%e_grad_pos(i)//" e diff : "//(e_plus-e0)//" fd grad : " // (e_plus-e0)/(step) ) - site_one%position(i) = pos(i) - end do - pos=site_two%position - do i=1,3 - site_two%position(i) = pos(i) + step - call Multipole_Moments_Site_Site_Interaction(e_plus,site_one, site_two,calc_opts,cutoff=cutoff,test=.false.) - call print("r_"//i//" : "//(site_two%position(i)-site_one%position(i))//" gradient : "//site_two%e_grad_pos(i)//" e diff : "//(e_plus-e0)//" fd grad : " // (e_plus-e0)/(step) ) - site_two%position(i) = pos(i) - end do - end if - -end subroutine Multipole_Moments_Site_Site_Interaction - - -subroutine Multipole_Interactions_Charge_Charge(energy,site_one, site_two,calc_opts,cutoff,error) - type(Multipole_Interactions_Site), intent(inout) :: site_one, site_two - type(Multipole_Calc_Opts) :: calc_opts - real(dp),intent(out) :: energy - real(dp), optional :: cutoff - integer, intent(out), optional :: error - real(dp), dimension(3) :: r_one_two, e_grad_pos, T1 - real(dp) :: T0 - - ! vector pointing from site one to site two. position of second site should already be set to correct image position - r_one_two = site_two%position - site_one%position - - - T0 = T_rank_zero(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) - T1 = T_rank_one(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) - if (calc_opts%do_energy) energy = energy + site_one%charge * T0 * site_two%charge - - ! force - if (calc_opts%do_force) then - e_grad_pos = site_one%charge * T1 * site_two%charge ! NB this should be negative of the force - site_one%e_grad_pos = site_one%e_grad_pos - e_grad_pos - site_two%e_grad_pos = site_two%e_grad_pos + e_grad_pos - - site_one%e_grad_charge = site_one%e_grad_charge + T0 * site_two%charge - site_two%e_grad_charge = site_two%e_grad_charge + T0 * site_one%charge - end if - - if (calc_opts%do_pot) then - site_one%potential = site_one%potential + T0 * site_two%charge - site_two%potential = site_two%potential + T0 * site_one%charge - end if - - if (calc_opts%do_field) then - site_one%e_field = site_one%e_field + T1 * site_two%charge - site_two%e_field = site_two%e_field - T1 * site_one%charge - end if - - return - -end subroutine Multipole_Interactions_Charge_Charge - -subroutine Multipole_Interactions_Charge_Dipole(energy,site_one, site_two,calc_opts,cutoff,error) - type(Multipole_Interactions_Site), intent(inout) :: site_one, site_two - type(Multipole_Calc_Opts) :: calc_opts - real(dp),intent(out) :: energy - real(dp), optional :: cutoff - integer, intent(out), optional :: error - real(dp), dimension(3) :: r_one_two, e_grad_pos, T1 - real(dp), dimension(3,3) :: T2 - real(dp) :: T0 - - ! site one is the charge, site two is the dipole - - ! vector pointing from site one to site two. position of second site should already be set to correct image position - r_one_two = site_two%position - site_one%position - - T0 = T_rank_zero(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) - T1 = T_rank_one(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) - T2 = T_rank_two(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) - - if (calc_opts%do_energy) energy = energy + site_one%charge * dot_product(T1, site_two%dipole) - - ! force - if (calc_opts%do_force) then - e_grad_pos = - site_one%charge * matmul(T2,site_two%dipole) !NB grad of energy so minus the force - site_one%e_grad_pos = site_one%e_grad_pos + e_grad_pos - site_two%e_grad_pos = site_two%e_grad_pos - e_grad_pos - - site_one%e_grad_charge = site_one%e_grad_charge + dot_product(T1, site_two%dipole) - site_two%e_grad_dipole = site_two%e_grad_dipole + site_one%charge * T1 - end if - - if (calc_opts%do_pot) then - site_one%potential = site_one%potential + dot_product(T1, site_two%dipole) - site_two%potential = site_two%potential + site_one%charge * T0 - end if - - if (calc_opts%do_field) then - site_one%e_field = site_one%e_field + matmul(T2,site_two%dipole) - site_two%e_field = site_two%e_field - T1 *site_one%charge - end if - - return - -end subroutine Multipole_Interactions_Charge_Dipole - -subroutine Multipole_Interactions_Dipole_Dipole(energy,site_one, site_two,calc_opts,cutoff,error) - type(Multipole_Interactions_Site), intent(inout) :: site_one, site_two - type(Multipole_Calc_Opts) :: calc_opts - real(dp),intent(out) :: energy - real(dp), optional :: cutoff - integer, intent(out), optional :: error - real(dp), dimension(3) :: r_one_two, e_grad_pos, temp1, T1 - real(dp), dimension(3,3) :: T2, temp2 - real(dp), dimension(3,3,3) :: T3 - integer :: i,j,k - - ! vector pointing from site one to site two. position of second site should already be set to correct image position - r_one_two = site_two%position - site_one%position - - T1 = T_rank_one(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) - T2 = T_rank_two(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) - T3 = T_rank_three(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) - - temp1 = matmul(T2,site_two%dipole) - - if (calc_opts%do_energy) energy = energy - dot_product(site_one%dipole, temp1) - - ! force - if (calc_opts%do_force) then - do i=1,3 - do j=1,3 - temp1 = T3(i,j,:) - temp2(i,j) = dot_product(temp1,site_two%dipole) - end do - end do - temp2 = transpose(temp2) - e_grad_pos = matmul(temp2,site_one%dipole) - site_one%e_grad_pos = site_one%e_grad_pos + e_grad_pos - site_two%e_grad_pos = site_two%e_grad_pos - e_grad_pos - - site_one%e_grad_dipole = site_one%e_grad_dipole - matmul(T2, site_two%dipole) - site_two%e_grad_dipole = site_two%e_grad_dipole - matmul(T2, site_one%dipole) - end if - - if (calc_opts%do_pot) then - site_one%potential = site_one%potential - dot_product(T1, site_two%dipole) - site_two%potential = site_two%potential + dot_product(T1, site_one%dipole) - end if - - if (calc_opts%do_field) then - site_one%e_field = site_one%e_field + matmul(T2,site_two%dipole) - site_two%e_field = site_two%e_field + matmul(T2,site_one%dipole) - end if - - return - -end subroutine Multipole_Interactions_Dipole_Dipole - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -!______________________________________________________________________________________________________ -! -! T tensors with damping/screening using notation from J Chem Phys 133, 234101 -! note parity of these tensors is (-1)^r where r is the rank of the tensor, minus signs in brackets -! indicate that the sign of 'diff' (the first argument) matters. -! -! Units are as follows : -! T_rank_zero : eV /(electron charge)^2 -! T_rank_one : Angstrom^-1 * eV /(electron charge)^2 -! T_rank_two : Angstrom^-2 * eV /(electron charge)^2 -! T_rank_three : Angstrom^-3 * eV /(electron charge)^2 -! -! so that the potential, electric field, and field gradient due to a charge are given by: -! pot = charge * T_rank_zero -! E_field = (-) charge * T_rank_one -! grad(E_field) = charge * T_rank_two -! -! And for a dipole in units of Ang*(electron charge) -! pot = (-) dot_product(dipole, T_rank_one) -! E_field = matmul(T_rank_two,dipole) -! grad(E_field) = (-) T_rank_three * dipole (a rank two tensor arising from multiplication of a rank 3 and rank 1 tensor) -! -!______________________________________________________________________________________________________ - -function T_rank_zero(diff, calc_opts,radius_one,radius_two,cutoff,error) - ! generalised 1/r including damping and screening - real(dp), dimension(3),intent(in) :: diff - type(Multipole_Calc_Opts) :: calc_opts - real(dp),intent(in) :: radius_one,radius_two - real(dp), intent(in), optional :: cutoff - integer, optional :: error - - real(dp) :: r, T_rank_zero, a, f, s0, s0_damp, s0_screen,u,um - real(dp) :: damp_rad_exp,erf_kappa,erfc_kappa - logical :: do_screen, do_damp - integer :: m - - call Site_Site_Params(do_screen,do_damp,damp_rad_exp,erf_kappa,radius_one,radius_two,calc_opts) - r=norm(diff) - - if (do_damp .and. do_screen) then - s0 = -1.0_dp - else if (do_damp .or. do_screen) then - s0 = 0.0_dp - else - s0 = 1.0_dp - end if - - s0_damp=0.0_dp - s0_screen=0.0_dp - - if (calc_opts%damping == Damping_Erf .or. calc_opts%damping == Damping_Erf_Uniform) then - s0_damp=erf(erf_kappa*r) - end if - if (calc_opts%damping == Damping_Exp ) then - m=calc_opts%damp_exp_order - u=(r/damp_rad_exp) - um=u**m - s0_damp=1.0_dp-exp(-um)+u*gamma_incomplete_upper((1.0_dp-1.0_dp/m),um) - end if - - if (calc_opts%screening == Screening_Erfc_Uniform) then - erfc_kappa=calc_opts%erfc_kappa_uniform - s0_screen= erfc(erfc_kappa*r) - end if - if (calc_opts%screening == Screening_Yukawa) then - a = calc_opts%yukawa_alpha - f = poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - s0_screen= exp(-a*r)*f - end if - s0 = s0 + s0_damp + s0_screen - T_rank_zero = (HARTREE*BOHR)*s0/r - -end function T_rank_zero - -function T_rank_one(diff, calc_opts,radius_one,radius_two,cutoff,error) - ! generalised grad(1/r) including damping and screening - real(dp), dimension(3),intent(in) :: diff - type(Multipole_Calc_Opts) :: calc_opts - real(dp),intent(in) :: radius_one,radius_two - real(dp), intent(in), optional :: cutoff - integer, optional :: error - real(dp) :: damp_rad_exp,erf_kappa,erfc_kappa - real(dp) :: r,r3, a,f,df, u,um,s0_damp, s0_screen, s1,s1_damp,s1_screen - real(dp), dimension(3) :: T_rank_one - logical :: do_damp, do_screen - integer:: m - r=norm(diff) - r3=r*r*r - - call Site_Site_Params(do_screen,do_damp,damp_rad_exp,erf_kappa,radius_one,radius_two,calc_opts) - - if (do_damp .and. do_screen) then - s1 = -1.0_dp - else if (do_damp .or. do_screen) then - s1 = 0.0_dp - else - s1 = 1.0_dp - end if - - s0_damp=0.0_dp - s0_screen=0.0_dp - s1_damp=0.0_dp - s1_screen=0.0_dp - - if (calc_opts%damping == Damping_Erf .or. calc_opts%damping == Damping_Erf_Uniform) then - s0_damp=erf(erf_kappa*r) - s1_damp = s0_damp - (2.0_dp*r*erf_kappa/sqrt(PI)) * exp(-(erf_kappa*r)**2) - end if - if (calc_opts%damping == Damping_Exp ) then - m=calc_opts%damp_exp_order - u=(r/damp_rad_exp) - um=u**m - s1_damp=1.0_dp-exp(-um) - end if - - if (calc_opts%screening == Screening_Erfc_Uniform) then - erfc_kappa=calc_opts%erfc_kappa_uniform - s0_screen= erfc(erfc_kappa*r) - s1_screen = s0_screen + (2.0_dp*r*erfc_kappa/sqrt(PI)) * exp(-(erfc_kappa*r)**2) - end if - if (calc_opts%screening == Screening_Yukawa) then - a = calc_opts%yukawa_alpha - f = poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - df = dpoly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - s0_screen = exp(-a*r)*f - s1_screen= s0_screen - r*exp(-a*r)*(df - a*f) - end if - - s1 = s1+s1_damp+s1_screen - T_rank_one = -(HARTREE*BOHR)*s1/r3 * diff -end function T_rank_one - -function T_rank_two(diff, calc_opts,radius_one,radius_two,cutoff,error) - real(dp), dimension(3),intent(in) :: diff - type(Multipole_Calc_Opts) :: calc_opts - real(dp),intent(in) :: radius_one,radius_two - real(dp), intent(in), optional :: cutoff - integer, optional :: error - real(dp) :: damp_rad_exp,erf_kappa,erfc_kappa - real(dp) :: r,r3,r5, a, f,df,d2f,u,um, & - s0_damp=0.0_dp, s0_screen=0.0_dp, s1=0.0_dp,s1_damp=0.0_dp,s1_screen=0.0_dp,s2=0.0_dp,s2_damp=0.0_dp,s2_screen=0.0_dp - real(dp), dimension(3,3) :: T_rank_two, identity - logical :: do_damp, do_screen - integer :: m - - r=norm(diff) - r3=r*r*r - r5=r3*r*r - - call Site_Site_Params(do_screen,do_damp,damp_rad_exp,erf_kappa,radius_one,radius_two,calc_opts) - - identity=0.0_dp - call add_identity(identity) - - s0_damp=0.0_dp - s0_screen=0.0_dp - s1_damp=0.0_dp - s1_screen=0.0_dp - s2_damp=0.0_dp - s2_screen=0.0_dp - - if (do_damp .and. do_screen) then - s1 = -1.0_dp - s2 = -1.0_dp - else if (do_damp .or. do_screen) then - s1 = 0.0_dp - s2 = 0.0_dp - else - s1 = 1.0_dp - s2 = 1.0_dp - end if - - if (calc_opts%damping == Damping_Erf .or. calc_opts%damping == Damping_Erf_Uniform) then - s0_damp=erf(erf_kappa*r) - s1_damp = s0_damp - (2.0_dp*r*erf_kappa/sqrt(PI)) * exp(-(erf_kappa*r)**2) - s2_damp = s1_damp - (4.0_dp/(3.0_dp*sqrt(PI)))*((r*erf_kappa)**3) * exp(-(erf_kappa*r)**2) - end if - if (calc_opts%damping == Damping_Exp ) then - m=calc_opts%damp_exp_order - u=(r/damp_rad_exp) - um=u**m - s1_damp=1.0_dp-exp(-um) - s2_damp=1.0_dp-(1.0_dp+(m/3.0_dp)*um)*exp(-um) - end if - if (calc_opts%screening == Screening_Erfc_Uniform) then - erfc_kappa=calc_opts%erfc_kappa_uniform - s0_screen= erfc(erfc_kappa*r) - s1_screen = s0_screen + (2.0_dp*r*erfc_kappa/sqrt(PI)) * exp(-(erfc_kappa*r)**2) - s2_screen = s1_screen + (4.0_dp/(3.0_dp*sqrt(PI)))*((r*erfc_kappa)**3)* exp(-(erfc_kappa*r)**2) - end if - if (calc_opts%screening == Screening_Yukawa) then - a = calc_opts%yukawa_alpha - f = poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - df = dpoly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - d2f = d2poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - s0_screen = exp(-a*r)*f - s1_screen= s0_screen - r*exp(-a*r)*(df - a*f) - s2_screen = s1_screen + (r*r/3.0_dp)* exp(-a*r) *( (a**2)*f - 2.0_dp*a*df + d2f ) - end if - - s1 = s1+s1_damp+s1_screen - s2 = s2+s2_damp+s2_screen - - T_rank_two = (3.0_dp*s2/r5) * (diff .outer. diff) - (s1/r3) * identity - T_rank_two = (HARTREE*BOHR)*T_rank_two -end function T_rank_two - - -function T_rank_three(diff,calc_opts,radius_one,radius_two,cutoff,error) - real(dp), dimension(3),intent(in) :: diff - type(Multipole_Calc_Opts) :: calc_opts - real(dp),intent(in) :: radius_one,radius_two - real(dp), intent(in), optional :: cutoff - integer, optional :: error - real(dp) :: damp_rad_exp, erf_kappa, erfc_kappa - real(dp) :: r,r5,r7,c1, c2, a, f, df, d2f, d3f, u,um,& - s0_damp, s0_screen,s1_damp,s1_screen, & - s2_damp,s2_screen, s2, & - s3_damp,s3_screen, s3 - real(dp), dimension(3,3,3) :: T_rank_three - logical :: do_damp, do_screen - integer :: i,j,k,m - - r=norm(diff) - r5=r**5 - r7=r5*r*r - - call Site_Site_Params(do_screen,do_damp,damp_rad_exp,erf_kappa,radius_one,radius_two,calc_opts) - - s0_damp=0.0_dp - s0_screen=0.0_dp - s1_damp=0.0_dp - s1_screen=0.0_dp - s2_damp=0.0_dp - s2_screen=0.0_dp - s3_damp=0.0_dp - s3_screen=0.0_dp - - if (do_damp .and. do_screen) then - s2 = -1.0_dp - s3 = -1.0_dp - else if (do_damp .or. do_screen) then - s2 = 0.0_dp - s3 = 0.0_dp - else - s2 = 1.0_dp - s3 = 1.0_dp - end if - - if (calc_opts%damping == Damping_Erf .or. calc_opts%damping == Damping_Erf_Uniform) then - s0_damp=erf(erf_kappa*r) - s1_damp = s0_damp - (2.0_dp/sqrt(PI))*(r*erf_kappa) * exp(-(erf_kappa*r)**2) - s2_damp = s1_damp - (4.0_dp/(3.0_dp*sqrt(PI)))*((r*erf_kappa)**3) * exp(-(erf_kappa*r)**2) - s3_damp = s2_damp - (8.0_dp/(15.0_dp*sqrt(PI)))*((r*erf_kappa)**5) * exp(-(erf_kappa*r)**2) - end if - if (calc_opts%damping == Damping_Exp ) then - m=calc_opts%damp_exp_order - u=(r/damp_rad_exp) - um=u**m - s1_damp=1.0_dp-exp(-um) - s2_damp=1.0_dp-(1.0_dp+(m/3.0_dp)*um)*exp(-um) - s3_damp=1.0_dp-(1.0_dp+(m*(8.0_dp-m)/15.0)*um+(m**2/15.0_dp)*um*um)*exp(-um) - end if - if (calc_opts%screening == Screening_Erfc_Uniform) then - erfc_kappa=calc_opts%erfc_kappa_uniform - s0_screen= erfc(erfc_kappa*r) - s1_screen = s0_screen + (2.0_dp*r*erfc_kappa/sqrt(PI)) * exp(-(erfc_kappa*r)**2) - s2_screen = s1_screen + (4.0_dp/(3.0_dp*sqrt(PI)))*((r*erfc_kappa)**3)* exp(-(erfc_kappa*r)**2) - s3_screen = s2_screen + (8.0_dp/(15.0_dp*sqrt(PI)))*((r*erfc_kappa)**5)* exp(-(erfc_kappa*r)**2) - end if - if (calc_opts%screening == Screening_Yukawa) then - a = calc_opts%yukawa_alpha - f = poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - df = dpoly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - d2f = d2poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - d3f = d3poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) - - s0_screen = exp(-a*r)*f - s1_screen= s0_screen - r*exp(-a*r)*(df - a*f) - s2_screen = s1_screen + (r*r/3.0_dp)* exp(-a*r) *( (a**2)*f - 2.0_dp*a*df + d2f ) - c1 = ( (a**2)*f*(1.0_dp+a*r) - a*df*(2.0_dp+3.0_dp*a*r) + d2f*(1.0_dp + 3.0_dp*a*r) - d3f*r ) - s3_screen = s2_screen + (r*r/15.0_dp)* c1 * exp(-a*r) - end if - - s2 = s2+s2_damp+s2_screen - s3 = s3+s3_damp+s3_screen - c1 = (-s3*15.0_dp/r7) - c2 = (s2*3.0_dp/r5) - T_rank_three = 0.0_dp - do i=1,3 - do j=1,3 - do k=1,3 - T_rank_three(i,j,k) = c1*diff(i)*diff(j)*diff(k) - if (j .eq. k ) T_rank_three(i,j,k) = T_rank_three(i,j,k) + c2*diff(i) - if (i .eq. k ) T_rank_three(i,j,k) = T_rank_three(i,j,k) + c2*diff(j) - if (i .eq. j ) T_rank_three(i,j,k) = T_rank_three(i,j,k) + c2*diff(k) - end do - end do - end do - T_rank_three = (HARTREE*BOHR)*T_rank_three - -end function T_rank_three - - -end module multipole_interactions_module diff --git a/src/Potentials/Multipoles.f95 b/src/Potentials/Multipoles.f95 deleted file mode 100644 index dcd4f9fa3d..0000000000 --- a/src/Potentials/Multipoles.f95 +++ /dev/null @@ -1,642 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - -#include "error.inc" - -module Multipoles_module - -use error_module -!use system_module, only : dp, print, inoutput, optional_default, system_timer, operator(//), print_message -use system_module -use cinoutput_module -use units_module -use dictionary_module -use paramreader_module -use periodictable_module -use linearalgebra_module -use atoms_types_module -use atoms_module -use topology_module -use extendable_str_module -use table_module -use connection_module -use clusters_module -use structures_module -use multipole_interactions_module -use partridge_schwenke_dipole_module - - -#ifdef HAVE_GAP -use descriptors_module -#endif - -use mpi_context_module -use QUIP_Common_module - - -implicit none -private -public :: multipole_sites_setup, atomic_forces_from_sites, electrostatics_calc,finalise, build_polarisation_matrix, calc_induced_dipoles,ewald_setup - -integer, parameter :: Multipole_Position_Atomic = 1 -integer, parameter :: Multipole_Position_Centre_of_Mass = 2 -integer, parameter :: Multipole_Position_M_Site = 3 - -integer, parameter :: Charge_Method_None = 0 -integer, parameter :: Charge_Method_Fixed = 1 -integer, parameter :: Charge_Method_GAP = 2 -integer, parameter :: Charge_Method_Partridge_Schwenke = 3 - -integer, parameter :: Dipole_Method_None = 0 -integer, parameter :: Dipole_Method_Partridge_Schwenke = 1 -integer, parameter :: Dipole_Method_GAP = 2 - -integer, parameter :: Polarisation_Method_None = 0 -integer, parameter :: Polarisation_Method_FPI = 1 -integer, parameter :: Polarisation_Method_GMRES = 2 -integer, parameter :: Polarisation_Method_QR = 3 - -integer, parameter :: Damping_None = 0 -integer, parameter :: Damping_Exp = 1 -integer, parameter :: Damping_Erf = 2 -integer, parameter :: Damping_Erf_Uniform = 3 - -integer, parameter :: Screening_None = 0 -integer, parameter :: Screening_Yukawa = 1 -integer, parameter :: Screening_Erfc_Uniform = 2 - -real(dp), parameter :: reciprocal_time_by_real_time = 1.0_dp / 3.0_dp - -type Monomers - type(Multipole_Interactions_Site), dimension(:), allocatable :: site_types ! this just a dummy list of site types with no actual positions - integer, dimension(:), allocatable :: signature - integer, dimension(:,:), allocatable :: excluded_pairs,monomer_indices - real(dp), dimension(:), allocatable :: masses - real(dp) :: monomer_cutoff = 0.0_dp, step ! step size (Angstroms) used for finite difference gradient calculations - real(dp) :: gammaM = 0.426706882_dp ! param for determining M-site position in water models -end type Monomers - -public :: Multipole_Moments -type Multipole_Moments - real(dp) :: cutoff = 0.0_dp, dipole_tolerance=1e-7_dp - type(Monomers), dimension(:), allocatable :: monomer_types - type(Multipole_Calc_Opts) :: calc_opts - type(Multipole_Interactions_Site), dimension(:), allocatable :: sites ! 1 to 1 correspondence w dummy atom sites - logical :: strict=.true., initialised=.false.,intermolecular_only = .true. - - integer, dimension(:), allocatable :: pol_idx - logical, dimension(:), allocatable :: site_polarisable - integer, dimension(:,:), allocatable :: exclude_list -end type Multipole_Moments - -public :: Ewald_arrays -type Ewald_arrays - real(dp), dimension(:,:), allocatable :: Q - logical :: do_ewald = .false. -end type Ewald_arrays - -interface Finalise - module procedure Multipole_Moments_Finalise - module procedure Monomers_Finalise -end interface Finalise - -contains - - -subroutine Multipole_Moments_Finalise(this) - - type(Multipole_Moments),intent(inout) :: this - integer::i - - if (allocated(this%monomer_types)) then - do i=1,size(this%monomer_types) - call finalise(this%monomer_types(i)) - end do - deallocate(this%monomer_types) - end if - if (allocated(this%sites)) then - do i=1,size(this%sites) - call finalise(this%sites(i)) - end do - deallocate(this%sites) - end if - - if (allocated(this%pol_idx)) deallocate(this%pol_idx) - if (allocated(this%site_polarisable)) deallocate(this%site_polarisable) - if (allocated(this%exclude_list)) deallocate(this%exclude_list) - - this%initialised = .False. - -end subroutine Multipole_Moments_Finalise - -subroutine Monomers_Finalise(this) - - type(Monomers),intent(inout) :: this - integer :: i - - this%monomer_cutoff = 0.0_dp - if (allocated(this%site_types)) then - do i=1,size(this%site_types) - call finalise(this%site_types(i)) - end do - deallocate(this%site_types) - end if - if (allocated(this%signature)) deallocate(this%signature) - if (allocated(this%excluded_pairs)) deallocate(this%excluded_pairs) - if (allocated(this%monomer_indices)) deallocate(this%monomer_indices) - if (allocated(this%masses)) deallocate(this%masses) - -end subroutine Monomers_Finalise - -subroutine clear_sites(this) - type(Multipole_Moments),intent(inout) :: this - integer::i - - if (allocated(this%monomer_types)) then - do i=1,size(this%monomer_types) - if (allocated(this%monomer_types(i)%monomer_indices)) deallocate(this%monomer_types(i)%monomer_indices) - end do - end if - - if (allocated(this%sites)) then - do i=1,size(this%sites) - call finalise(this%sites(i)) - end do - deallocate(this%sites) - end if - - if (allocated(this%pol_idx)) deallocate(this%pol_idx) - if (allocated(this%site_polarisable)) deallocate(this%site_polarisable) - if (allocated(this%exclude_list)) deallocate(this%exclude_list) - -end subroutine clear_sites - -subroutine multipole_sites_setup(at,multipoles,dummy_atoms,do_grads,strict) - type(Atoms) :: at,dummy_atoms - type(Multipole_Moments) :: multipoles - logical, optional :: do_grads,strict - - logical,dimension(:), allocatable :: associated_to_monomer - integer, dimension(3) :: shift - integer :: n_sites, n_mono_types, cursor,i,j - logical :: my_do_grads,my_strict - - my_do_grads=optional_default(.false.,do_grads) - my_strict=optional_default(.true.,strict) - - call clear_sites(multipoles) - - call reallocate(associated_to_monomer,at%N,zero=.true.) - n_sites=0 - n_mono_types=size(multipoles%monomer_types) - do i=1,n_mono_types ! can introduce a case switch here if want to support more monomer finding routines - if(allocated(multipoles%monomer_types(i)%monomer_indices))deallocate(multipoles%monomer_types(i)%monomer_indices) - call find_general_monomer(at,multipoles%monomer_types(i)%monomer_indices,multipoles%monomer_types(i)%signature,associated_to_monomer,multipoles%monomer_types(i)%monomer_cutoff) - n_sites = n_sites + size(multipoles%monomer_types(i)%site_types) * size(multipoles%monomer_types(i)%monomer_indices,2) - end do - -! if (.not. all(associated_to_monomer)) then -! RAISE_ERROR('Multipoles: Not all atoms are assigned to a monomer', error) -! end if - allocate(multipoles%sites(n_sites)) - - - cursor=0 - do i=1,n_mono_types ! fill in list of sites and exclude list - do j=1,size(multipoles%monomer_types(i)%monomer_indices,2) - call add_sites_for_monomer(at,multipoles%sites,cursor,multipoles%exclude_list,multipoles%monomer_types(i),multipoles%monomer_types(i)%monomer_indices(:,j),my_do_grads) - end do - end do - - call initialise(dummy_atoms,0,at%lattice) ! set up dummy atoms obj - do i=1,n_sites - call add_atoms(dummy_atoms,multipoles%sites(i)%position,1) ! all dummy atoms are Hydrogens - end do - call set_cutoff(dummy_atoms,multipoles%cutoff) - call calc_connect(dummy_atoms) - - !call write(dummy_atoms, 'stdout', prefix='DUMMY',real_format='%16.8f') - - - ! if want to implement this way for efficiency, will probably have to create a second Connection object, which doesn't contain excluded interactions - ! this is because for calculated induced dipoles we typically don't ignore intramolecular interactions, so we shuold ignore the exclude list. -!!$ -!!$ do i=1,size(exclude_list,2) ! delete bonds in exclude list -!!$ call distance_min_image(dummy_atoms,exclude_list(1,i),exclude_list(2,i),shift=shift) -!!$ call remove_bond(dummy_atoms%connection,exclude_list(1,i),exclude_list(2,i),shift=shift) -!!$ end do - - deallocate(associated_to_monomer) - -end subroutine multipole_sites_setup - -subroutine ewald_setup(dummy_atoms,multipoles,ewald,my_ewald_error) - type(Atoms) :: dummy_atoms - type(Multipole_Moments) :: multipoles - type(Ewald_arrays) :: ewald - - real(dp) :: r_ij, erfc_ar, arg, my_ewald_error, alpha, kmax, kmax2, prefac, infac, two_alpha_over_sqrt_pi, v, & - & ewald_precision, ewald_cutoff, my_cutoff, my_smooth_coulomb_cutoff, smooth_arg, smooth_f, dsmooth_f - - ewald_precision = -log(my_ewald_error) - ewald_cutoff = sqrt(ewald_precision/PI) * reciprocal_time_by_real_time**(1.0_dp/6.0_dp) * & - & minval(sqrt( sum(dummy_atoms%lattice(:,:)**2,dim=1) )) / dummy_atoms%N**(1.0_dp/6.0_dp) - call print('Ewald cutoff = '//ewald_cutoff,PRINT_ANALYSIS) - multipoles%cutoff = ewald_cutoff - - write(*,*) "more to do to fill these arrays" - -end subroutine ewald_setup - -subroutine add_sites_for_monomer(at,sites,offset,exclude_list,monomer_type,atom_indices,do_grads) - type(Atoms) :: at - type(Multipole_Interactions_Site), dimension(:) :: sites - integer :: offset - integer, dimension(:,:), allocatable :: exclude_list - type(Monomers) :: monomer_type - integer, dimension(:) :: atom_indices - logical :: do_grads - - real(dp),dimension(:,:),allocatable :: atomic_positions - integer :: monomer_size,sites_per_mono,exclude_offset,n_exclude - integer :: i_atom_site,i_site_glob,i_atom,i_site,i - integer, dimension(3) :: water_signature = (/1,1,8/) - real(dp), dimension(3,3) :: identity3x3 - real(dp), dimension(3) :: com_pos - - real(dp) :: monomer_mass - integer,dimension(:), allocatable :: signature_copy,site_atom_map - - - identity3x3 = 0.0_dp - call add_identity(identity3x3) - - monomer_size = size(monomer_type%signature) - sites_per_mono = size(monomer_type%site_types) - - allocate(atomic_positions(3,monomer_size)) - do i=1,monomer_size - monomer_type%masses(i) =ElementMass(monomer_type%signature(i)) - end do - monomer_mass = sum(monomer_type%masses) - - allocate(site_atom_map(sites_per_mono)) - allocate(signature_copy(monomer_size)) - signature_copy = monomer_type%signature - site_atom_map=0 - - do i_site=1,sites_per_mono - if (monomer_type%site_types(i_site)%pos_type .eq. Multipole_Position_Atomic) then - i_atom_site=find_in_array(signature_copy,monomer_type%site_types(i_site)%atomic_number) - signature_copy(i_atom_site)=0 ! make sure we don't put two sites on the same atom - site_atom_map(i_site) =i_atom_site - end if - end do - - atomic_positions=0.0_dp - com_pos=0.0_dp - - ! find positions of atoms and centre of mass - do i=1,monomer_size - i_atom = atom_indices(i) - atomic_positions(:,i) = at%pos(:,i_atom) - com_pos = com_pos + monomer_type%masses(i) * at%pos(:,i_atom) - end do - - com_pos = com_pos * (1.0_dp/monomer_mass) - - do i_site=1,sites_per_mono - - i_site_glob=offset+i_site - - sites(i_site_glob) = monomer_type%site_types(i_site) ! copy info from template site - - sites(i_site_glob)%charge = 0.0_dp - sites(i_site_glob)%dipole = 0.0_dp - - allocate(sites(i_site_glob)%atom_indices(monomer_size)) - sites(i_site_glob)%atom_indices = atom_indices - - selectcase(monomer_type%site_types(i_site)%pos_type) ! assign positions - case(Multipole_Position_Centre_of_Mass) - sites(i_site_glob)%position = com_pos - case(Multipole_Position_Atomic) - sites(i_site_glob)%position = atomic_positions(:,site_atom_map(i_site)) - case(Multipole_Position_M_Site) - call m_site_position(atomic_positions,monomer_type%gammaM,sites(i_site_glob)%position) - case default - call print("site position param : "//sites(i_site_glob)%pos_type) - call system_abort("Multipole_Moments_Assign doesn't know where to put this multipole moment") - end select - - - selectcase(sites(i_site_glob)%charge_method) ! assign charges - case(Charge_Method_Fixed) - sites(i_site_glob)%charge = monomer_type%site_types(i_site)%charge - case(Charge_Method_GAP) - call system_abort("GAP moments not yet implemented") ! call charge_GAP() - case(Charge_Method_Partridge_Schwenke) -!#ifndef HAVE_FX -! RAISE_ERROR('Multipoles: PS water as charges requested but FX model was not compiled in. Check the HAVE_FX flag in the Makefiles.', error) -!#endif - call charges_PS(atomic_positions,sites(i_site_glob)%charge,i_site,monomer_type%gammaM) - call test_charge_grads_PS(atomic_positions,monomer_type%gammaM) - end select - selectcase(sites(i_site_glob)%dipole_method) ! assign dipoles - case(Dipole_Method_GAP) - continue ! call dipole_moment_GAP() - case(Dipole_Method_Partridge_Schwenke) - if (any(monomer_type%signature .ne. water_signature)) then - call system_abort(" Signature of water monomer must be "//water_signature) - end if - call dipole_moment_PS(atomic_positions,sites(i_site_glob)%dipole) - !call print("PS dipole : "//sites(i_site_glob)%dipole) - end select - - if (do_grads) then - - allocate(sites(i_site_glob)%pos_grad_positions(3,3,monomer_size)) ! gradients of position of site wrt atomic positions - allocate(sites(i_site_glob)%charge_grad_positions(1,3,monomer_size)) ! gradients of charge wrt atomic positions - allocate(sites(i_site_glob)%dipole_grad_positions(3,3,monomer_size)) ! gradients of dipole components wrt atomic positions - - sites(i_site_glob)%e_grad_pos = 0.0_dp - sites(i_site_glob)%e_grad_charge = 0.0_dp - sites(i_site_glob)%e_grad_dipole = 0.0_dp - - sites(i_site_glob)%charge_grad_positions = 0.0_dp - sites(i_site_glob)%dipole_grad_positions = 0.0_dp - sites(i_site_glob)%pos_grad_positions=0.0_dp - - ! calc gradient of this site's multipole components with respect to atomic positions - selectcase(sites(i_site_glob)%charge_method) ! assign charge gradients - case(Charge_Method_Fixed) - continue ! gradients are zero - case(Charge_Method_GAP) - call system_abort("GAP moments not yet implemented") - ! something like call charge_gradients_GAP() - case(Charge_Method_Partridge_Schwenke) - call charge_gradients_PS(atomic_positions,sites(i_site_glob)%charge_grad_positions,monomer_type%gammaM,i_site) - end select - selectcase(sites(i_site_glob)%dipole_method) - case(Dipole_Method_Partridge_Schwenke) - call dipole_moment_gradients_PS(atomic_positions,sites(i_site_glob)%dipole_grad_positions,step=monomer_type%step) - case(Dipole_Method_GAP) - call system_abort("GAP moments not yet implemented") - ! something like call dipole_gradients_GAP() - end select - - ! calc gradients of this site's position with respect to atomic positions - selectcase(sites(i_site_glob)%pos_type) - case(Multipole_Position_Centre_of_Mass) - do i=1,monomer_size - sites(i_site_glob)%pos_grad_positions(:,:,i) = ( monomer_type%masses(i) / monomer_mass) * identity3x3 - end do - case(Multipole_Position_Atomic) - sites(i_site_glob)%pos_grad_positions(:,:,site_atom_map(i_site)) = identity3x3 - case(Multipole_Position_M_Site) - call m_site_position_grads(monomer_type%gammaM,sites(i_site_glob)%pos_grad_positions) - case default - call system_abort("Multipole_Moments_Assign doesn't know how multipole position varies with atomic positions") - end select - end if - - end do - - exclude_offset=0 - if(allocated(exclude_list)) then - exclude_offset=size(exclude_list,2) - end if - if(allocated(monomer_type%excluded_pairs)) then - n_exclude=size(monomer_type%excluded_pairs,2) - call reallocate(exclude_list,2,exclude_offset+n_exclude,copy=.true.) - do i=1,n_exclude - exclude_list(1,exclude_offset+i)=offset+monomer_type%excluded_pairs(1,i) - exclude_list(2,exclude_offset+i)=offset+monomer_type%excluded_pairs(2,i) - end do - end if - offset = offset+sites_per_mono - - deallocate(atomic_positions) - -end subroutine add_sites_for_monomer - -subroutine electrostatics_calc(at,multipoles,ewald,do_pot,do_field,do_force,e) - type(Atoms) :: at - type(Multipole_Moments) :: multipoles - type(Ewald_arrays) :: ewald - logical,optional :: do_pot,do_field,do_force - real(dp),optional :: e - - real(dp) :: my_energy,r_ij,site_site_energy - integer :: i_site,n,j_site - real(dp), dimension(3) :: diff - type(Multipole_Interactions_Site) :: site1,site2 - - - multipoles%calc_opts%do_pot = optional_default(.false.,do_pot) - multipoles%calc_opts%do_field = optional_default(.false.,do_field) - multipoles%calc_opts%do_force = optional_default(.false.,do_force) - - if(.not. allocated(multipoles%exclude_list)) allocate(multipoles%exclude_list(2,0)) -!call print("doing calc w cutoff "//multipoles%cutoff) -!call print("exclude list ") -!call print(multipoles%exclude_list) - ! real space part - do i_site=1,at%N - - multipoles%sites(i_site)%e_field=0.0_dp - multipoles%sites(i_site)%potential=0.0_dp - multipoles%sites(i_site)%e_grad_pos=0.0_dp - multipoles%sites(i_site)%e_grad_charge=0.0_dp - multipoles%sites(i_site)%e_grad_dipole=0.0_dp - - site1 = multipoles%sites(i_site) - do n = 1, n_neighbours(at,i_site) - j_site = neighbour(at,i_site,n,distance=r_ij,diff=diff) - - if( r_ij > multipoles%cutoff ) cycle - - if ( find_in_array(multipoles%exclude_list,(/i_site,j_site/)) + find_in_array(multipoles%exclude_list,(/j_site,i_site/)) .gt. 0 ) cycle - - site2 = multipoles%sites(j_site) - site2%position = site1%position + diff ! make a copy of neighbour site and move it to the correct position - - call Multipole_Moments_Site_Site_Interaction(site_site_energy,site1,site2, multipoles%calc_opts, cutoff=multipoles%cutoff) - - my_energy = my_energy + 0.5_dp * site_site_energy ! double counting - - multipoles%sites(i_site)%e_field = multipoles%sites(i_site)%e_field + site1%e_field - multipoles%sites(i_site)%potential = multipoles%sites(i_site)%potential + site1%potential - multipoles%sites(i_site)%e_grad_pos = multipoles%sites(i_site)%e_grad_pos + site1%e_grad_pos - multipoles%sites(i_site)%e_grad_charge = multipoles%sites(i_site)%e_grad_charge + site1%e_grad_charge - multipoles%sites(i_site)%e_grad_dipole = multipoles%sites(i_site)%e_grad_dipole + site1%e_grad_dipole - - end do - end do - -call print("real space energy "//my_energy) - ! if ewald - ! recip part - ! self part - - if (present(e))e=e+my_energy - -end subroutine electrostatics_calc - - -subroutine atomic_forces_from_sites(sites,f) - type(Multipole_Interactions_Site), dimension(:) :: sites - real(dp), intent(out), dimension(:,:),optional :: f - - integer :: i, j, k, a, n_atoms,i_site,i_atom - - - do i_site=1,size(sites) ! add up force contributions in most transparent way possible - - n_atoms = size(sites(i_site)%atom_indices) - - do a=1,n_atoms ! a is atom number, i component of atomic position, j component of dipole, k component of site position - i_atom=sites(i_site)%atom_indices(a) - do i=1,3 - f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_charge * sites(i_site)%charge_grad_positions(1,i,a) ! NB force is minus grad - do j=1,3 - f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_dipole(j) * sites(i_site)%dipole_grad_positions(j,i,a) - end do - do k=1,3 - f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_pos(k) * sites(i_site)%pos_grad_positions(k,i,a) - end do - end do - end do - - end do - -end subroutine atomic_forces_from_sites - -subroutine build_polarisation_matrix(at,multipoles,pol_matrix,ewald) - type(Atoms) :: at - type(Multipole_Moments) :: multipoles - real(dp), dimension(:,:),allocatable :: pol_matrix - type(Ewald_arrays) :: ewald - - integer :: N_pol,i,i_pol,j_pol,i_site,j_site,n,ii - type(Multipole_Interactions_Site) :: site1,site2 - - real(dp), dimension(3,3) :: prop_mat ! temporary storage of dipole field tensor - real(dp), dimension(3) :: diff - real(dp) :: r_ij - - N_pol=0 - call reallocate(multipoles%pol_idx,at%N,zero=.true.) - do i_site=1,at%N - if(multipoles%sites(i_site)%polarisable) then - N_pol=N_pol+1 - multipoles%pol_idx(i_site)=N_pol - end if - end do - - call reallocate(pol_matrix,3*N_pol,3*N_pol,zero=.true.) - - do i_site=1,at%N - i_pol=multipoles%pol_idx(i_site) - if(i_pol .eq. 0) cycle - do ii=3*i_pol-2,3*i_pol - pol_matrix(ii,ii) = 1.0_dp / multipoles%sites(i_site)%alpha - end do - end do - - do i_site=1,at%N - i_pol=multipoles%pol_idx(i_site) - if(i_pol .eq. 0) cycle - site1 = multipoles%sites(i_site) - - do n = 1, n_neighbours(at,i_site) - j_site = neighbour(at,i_site,n,distance=r_ij,diff=diff) - j_pol = multipoles%pol_idx(j_site) - if( r_ij > multipoles%cutoff .or. j_pol .eq. 0) cycle -!prop_mat=T_rank_two(diff,multipoles%calc_opts,site1%damp_rad,site2%damp_rad,cutoff=multipoles%cutoff) -!call print(prop_mat) - pol_matrix(3*i_pol-2:3*i_pol,3*j_pol-2:3*j_pol) = - T_rank_two(diff,multipoles%calc_opts,site1%damp_rad,site2%damp_rad,cutoff=multipoles%cutoff) - end do - - end do - -end subroutine build_polarisation_matrix - -subroutine calc_induced_dipoles(pol_matrix,multipoles,polarisation,pol_energy) - real(dp), dimension(:,:) :: pol_matrix - type(Multipole_Moments) :: multipoles - integer :: polarisation - real(dp),intent(out) :: pol_energy - - type(LA_Matrix) :: la_pol_matrix - real(dp),dimension(:),allocatable :: perm_field,induced_dipoles - integer:: i_pol,i_site,N_pol,N_sites,ii - - N_sites=size(multipoles%pol_idx) - N_pol=count(multipoles%pol_idx .ne. 0) - - call reallocate(perm_field,3*N_pol,zero=.true.) - call reallocate(induced_dipoles,3*N_pol,zero=.true.) - call initialise(la_pol_matrix,pol_matrix) - - ! extract permanent fields from sites - do i_site=1,N_sites - i_pol=multipoles%pol_idx(i_site) - if(i_pol .eq. 0) cycle - ii=3*i_pol-2 - perm_field(ii:ii+2) = multipoles%sites(i_site)%e_field - end do -!call print("perm_field") -!call print(perm_field) - - ! solve system with QR or GMRES - if ( polarisation == Polarisation_Method_QR) then - call LA_Matrix_QR_Factorise(la_pol_matrix) - call LA_Matrix_QR_Solve_Vector(la_pol_matrix,perm_field,induced_dipoles) - end if - - pol_energy=0.0_dp - ! update dipoles on sites and sum induction energy - do i_site=1,N_sites - i_pol=multipoles%pol_idx(i_site) - if(i_pol .eq. 0) cycle - ii=3*i_pol-2 - multipoles%sites(i_site)%dipole = multipoles%sites(i_site)%dipole + induced_dipoles(ii:ii+2) - pol_energy = pol_energy + 0.5_dp*(normsq(induced_dipoles(ii:ii+2))/multipoles%sites(i_site)%alpha) - end do -call print("polarisation energy "//pol_energy) -!call print("dipoles") -!call print(induced_dipoles) - - -end subroutine calc_induced_dipoles - -end module Multipoles_module diff --git a/src/Potentials/Partridge_Schwenke_Dipole.f95 b/src/Potentials/Partridge_Schwenke_Dipole.f95 deleted file mode 100644 index e331df00e1..0000000000 --- a/src/Potentials/Partridge_Schwenke_Dipole.f95 +++ /dev/null @@ -1,713 +0,0 @@ -#include "error.inc" - - -module partridge_schwenke_dipole_module - -use error_module -use system_module, only : dp, print, inoutput, optional_default, system_timer, operator(//), system_abort -use units_module -use linearalgebra_module, only : add_identity -implicit none -private - -public :: dipole_moment_PS, dipole_moment_gradients_PS,charges_PS,charge_gradients_PS,m_site_position,m_site_position_grads,test_charge_grads_PS - -real(dp) :: coef(823) -integer ::i, idx(823,3) -data (idx(i,1),i=1,823 )/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, & - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, & - 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, & - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, & - 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,10,10,10,10,10,10,10,10,10,10, & -11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, & - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & - 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, & - 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,10,10,10,10,10,10,10,10,10, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, & - 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, & - 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 9, 9, 9, & - 9, 9, 9, 9, 9, 9, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, & - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, & - 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & - 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, & - 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, & - 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, & - 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, & - 4, 4, 4, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1/ -data (idx(i,2),i=1,823 )/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & - 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & - 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & - 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, & - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, & - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, & - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, & - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, & - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, & - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, & - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, & - 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, & - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, & - 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, & - 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,10,10,10,10,10,10,10,10,10,10, & -10,10,10,10,10,10,10,10,10,11,11,11,11,11,11,11,11,11/ -data (idx(i,3),i=1,823)/ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, & -15,16,17,18,19, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17, & -18, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17, 1, 2, 3, 4, & - 5, 6, 7, 8, 9,10,11,12,13,14,15,16, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, & -11,12,13,14,15, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, 1, 2, 3, & - 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, & - 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, & - 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17,18, 1, 2, 3, 4, 5, & - 6, 7, 8, 9,10,11,12,13,14,15,16,17,18, 1, 2, 3, 4, 5, 6, 7, 8, 9, & -10,11,12,13,14,15,16,17, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, & -15,16, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 1, 2, 3, 4, 5, & - 6, 7, 8, 9,10,11,12,13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, & - 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, & -11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, & - 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17, 1, 2, 3, 4, 5, 6, 7, & - 8, 9,10,11,12,13,14,15,16, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, & -14,15, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, 1, 2, 3, 4, 5, 6, & - 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, & - 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, & - 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16, 1, & - 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 1, 2, 3, 4, 5, 6, 7, 8, & - 9,10,11,12,13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, & - 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, & - 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, & - 6, 7, 8, 9,10,11,12,13,14,15, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, & -13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, 6, 7, & - 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, & - 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9, & -10,11,12,13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, 4, & - 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, & - 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, & - 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, & - 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, & - 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, & - 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, & - 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, & - 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, & - 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9/ -data (coef(i),i=1,296 )/3.3059356035504D-01,-6.5251838873142D-02, & - 4.1240972465648D-02, -2.2116144218802D-02, 1.2580837420455D-02, & - 7.8310787716761D-03, 2.2288047625127D-02, -1.3669697654061D-01, & - 2.4937882844205D-02, 4.3657889120529D-01, -4.6471342590799D-01, & - -5.5058444686450D-01, 1.5887018737408D+00, -6.5038773968250D-01, & - -1.9774754735667D+00, 2.3124888370313D+00, 3.8251566080155D-01, & - -1.6334099937156D+00, 6.2881257157520D-01, -1.8927984910357D-01, & - -7.2499911946761D-02, -3.1228675269345D-02, -5.6242287160400D-02, & - -1.3290140915015D-02, -1.1339837953158D-01, 4.1911643453876D-01, & - 1.0878140964594D+00, -2.1578445557330D+00, -6.0750507724534D+00, & - 9.1561006195652D+00, 1.3224003890557D+01, -2.0748430357416D+01, & - -1.0449365066054D+01, 2.1628595870529D+01, -4.2431457957766D-01, & - -7.5571164522298D+00, 2.0524343250386D+00, 5.5868906350997D-01, & - -5.9721805154700D-02, 9.3334456754609D-02, 1.0923671353769D-01, & - -3.3757729524242D-03, -8.1955430151354D-01, 5.6496735493995D-01, & - -1.3011057288355D+00, 5.3901118329658D+00, 1.3568988621720D+01, & - -3.7808429693587D+01, -2.0739014515304D+01, 8.3199919232595D+01, & - -9.8755630053578D+00, -6.1652207627820D+01, 2.7023074052020D+01, & - 2.4525958185483D+00, -5.5149034988337D-01, 1.5103514025733D-01, & - -2.4618413187533D-01, -4.1804716531894D-01, 2.6714852474484D+00, & - -3.9168656863665D+00, -2.4125252717845D+01, 4.3527442372053D+01, & - 5.9633945281439D+01, -1.4203637448798D+02, -2.5686288988000D+01, & - 1.8623562080820D+02, -7.1111780955171D+01, -8.1445438601723D+01, & - 7.5998791997709D+01, -1.9604047605233D+01, 6.9877155195411D-01, & - 2.7810300377705D-01, -5.2931179377996D-01, -1.0053094346116D+01, & - 1.4814307367778D+01, 7.8108768923701D+01, -1.0805092078057D+02, & - -2.3239081566836D+02, 3.7213457783017D+02, 3.0496349672975D+02, & - -6.3411783219992D+02, -1.4879340998406D+02, 5.0022502992215D+02, & - -1.3111459794329D+01, -1.2290268190725D+02, -5.8654536308254D-01, & - -3.2431931793368D+00, -4.3010113145914D+00, 6.0041429939524D+01, & - -5.6492374908452D+01, -2.3766509586367D+02, 5.7464248240814D+02, & - -1.1755625188188D+01, -1.3722806921925D+03, 1.1416528991599D+03, & - 1.0319638945490D+03, -1.3181474199324D+03, -2.8780475896443D+02, & - 4.8041729027996D+02, 2.5765411421547D-01, 3.0320582307308D+00, & - 1.8801635566723D+01, -1.0807887522259D+01, -9.2855800489316D+01, & - -2.0023372590061D+02, 3.7208691892624D+01, 1.2333932023660D+03, & - -2.3854122885654D+02, -2.2719119490167D+03, 1.2845178202043D+03, & - 1.0639169133522D+03, -8.1775958686613D+02, -2.5657303999430D+00, & - 3.2500673972889D+01, 2.7614957583093D+01, -6.3541800745099D+02, & - 3.7542804251488D+02, 3.1023608042457D+03, -3.2841743471965D+03, & - -3.9310047363443D+03, 5.9367773903877D+03, -5.6931755253618D+02, & - -1.6343922939315D+03, 5.6921856317329D+02, 6.9934412991284D+00, & - -9.0226351470208D+01, -1.6210263409154D+02, 1.5895772244284D+03, & - -2.3411885205624D+02, -7.0717394064325D+03, 6.2987514309228D+03, & - 7.4402200861379D+03, -1.1416901914882D+04, 3.3350622040450D+03, & - 3.1195654244768D+02, -6.2871212585897D+00, 7.9926393798994D+01, & - 1.7167392636067D+02, -1.3658290879599D+03, -5.6544576497080D+01, & - 5.9229738209174D+03, -4.7443933784239D+03, -6.0256769257614D+03, & - 9.1534258978092D+03, -3.1293931276615D+03, 1.6169861139146D+00, & - -2.0468415192255D+01, -4.6075981473614D+01, 3.4557095272353D+02, & - 2.6381121398946D+01, -1.4631669362241D+03, 1.2299345022018D+03, & - 1.2705573668289D+03, -2.5152540533899D+03, 1.7151603225554D+03, & - 8.6865937684802D+01, -1.6707195632608D+03, 6.2315981153506D+02, & - 1.4270102465207D+03, -1.0493951381706D+03, -3.7380369214480D+02, & - 5.5457941332705D+02, -1.4236914052765D+02, -6.1540053279229D-02, & - 1.5531427659386D-01, -3.1860760875349D-02, 3.2654417741389D-02, & - -2.2987178066698D-01, 3.0488522568491D-01, 2.2933076978782D+00, & - -3.7563267358823D+00, -1.0753342561066D+01, 2.0419223364673D+01, & - 2.2747341950651D+01, -5.4709940439901D+01, -1.5369671127204D+01, & - 7.1082849961840D+01, -1.2914573886419D+01, -3.5970581259398D+01, & - 1.6891394219063D+01, -7.5177127154281D-02, -5.5097454571807D-02, & - 1.3178003090885D-02, -7.3713198218206D-02, 1.0116574180841D-01, & - -5.6479840733797D-01, 7.0154865623363D-01, 1.0496975433616D+00, & - -5.0788071354498D+00, 5.5950672093606D+00, 8.3560432301710D+00, & - -2.4631240429059D+01, 6.4228976148411D+00, 2.9716418329629D+01, & - -2.5429959665417D+01, -7.0743350880142D+00, 1.6290654019047D+01, & - -5.5863925933866D+00, -1.2201221052153D-01, 2.9211663541558D-01, & - -5.0527445973303D-02, -1.1499331650193D+00, -1.1524746330230D+00, & - 1.4889417611659D+01, 1.8304400502439D+01, -7.0581115296041D+01, & - -7.0486462006098D+01, 1.9124714847398D+02, 1.0441968375963D+02, & - -2.7288439929057D+02, -6.4888829584091D+01, 1.8924747244095D+02, & - 2.4269853698223D+01, -6.0338716812716D+01, -3.5328088267763D-02, & - 3.0902606918779D-01, 1.2053004980265D+00, -6.0803513996890D+00, & - -1.7483113565255D-01, -6.2625401449884D+00, -2.7246752169995D+01, & - 2.0444304756919D+02, -7.7839322800197D+01, -5.3730625493358D+02, & - 4.7830647603102D+02, 4.6597134541889D+02, -6.1259392504536D+02, & - -1.1548852899995D+02, 2.3547566621563D+02, -2.3347154414735D-02, & - -1.1968693854390D+00, 1.0224938597971D+01, 5.3446850508065D+01, & - -1.4111836292138D+02, -3.1522742996746D+02, 4.8421928937666D+02, & - 6.7783542838211D+02, -5.2424354383194D+02, -9.1849951039291D+02, & - 2.9732037903974D+01, 1.0861777943385D+03, 3.0719961746829D+01, & - -5.0010435278295D+02, 1.8839519932092D+00, -1.7599267033384D+01, & - -1.0219850683350D+02, 1.8829260033990D+02, 7.3803356268807D+02, & - -3.8632754653668D+02, -1.7644793500072D+03, -8.8777283880817D+02, & - 2.9449590358391D+03, 2.0536359693554D+03, -3.3452415814017D+03, & - -3.1293172119834D+02, 1.0127512420257D+03, -3.0193368209445D+00, & - 4.1095352165196D+01, 4.4348552320534D+01, -7.9321796890387D+02, & - 3.2539233560467D+02, 3.1868226505597D+03, -2.0997414646993D+03, & - -1.8521962831455D+03, 9.1469297093176D+02, -2.3634831297013D+03, & - 3.4289073363414D+03, -1.1416454795844D+03, -1.5199034217066D+01, & - 1.4232675696336D+02, 9.3114014166986D+02, -1.4217668280744D+03, & - -6.6892280796250D+03, 4.5183848177059D+03, 1.2162309555107D+04, & - -6.0881419416832D+03, -6.5629804880923D+03, 4.3337118077328D+03, & - -8.1558350744764D+02, 4.3004262747050D+01, -4.5882304802650D+02, & - -2.0410524329200D+03, 6.1474199330111D+03, 1.1724980372884D+04, & - -2.3175030314049D+04, -1.1837559831675D+04, 2.5197118132844D+04, & - -3.2683703679870D+03, -2.7866974850481D+03, -2.8591617842506D+01, & - 3.1751114848550D+02, 1.2298684178193D+03, -4.5417151814417D+03, & - -6.2204390702960D+03, 1.7700472889577D+04, 2.6246105174545D+03/ -data (coef(i),i=297,590 ) / & - -1.8861366382775D+04, 7.9585442979514D+03, 3.9716425665863D-02, & - -7.6680420565681D-02, -2.9794073611373D-02, 2.9651275363141D-01, & - 2.3617540011178D-01, -5.3814608941930D+00, 4.0147726416215D+00, & - 3.7532098679521D+01, -3.9135190680333D+01, -1.1925521735589D+02, & - 1.2926060949759D+02, 1.9857026702725D+02, -2.0774883055076D+02, & - -1.7655360260354D+02, 1.7333813535796D+02, 6.9917438328193D+01, & - -6.5021997846616D+01, 3.8151219229796D-02, 4.3843768950232D-02, & - -2.4086574908239D-01, 2.3158689464466D-02, 6.9158105021969D+00, & - -1.2586455424488D+01, -5.0585593269608D+01, 7.3347518061775D+01, & - 1.4968744302400D+02, -1.6800393040240D+02, -2.4320433942912D+02, & - 2.0861481767385D+02, 2.1775727676924D+02, -1.6369018032037D+02, & - -7.3208995085005D+01, 5.4436885233608D+01, 1.1600348167678D-01, & - -4.9809340646254D-01, 1.5047843655988D+00, 8.3092068539797D+00, & - -3.8274991517389D+01, -1.4955961155500D+01, 2.0476668028645D+02, & - -1.4680118753568D+02, -3.4810875016780D+02, 4.4949122123679D+02, & - 2.1140330213824D+02, -3.4203945153975D+02, -1.7142290576617D+02, & - 8.0503251494110D+01, 1.0907423981457D+02, -3.0813919972698D-01, & - 5.3469826239172D+00, 4.1194843505592D+00, -1.1308670564800D+02, & - 4.5037871493300D+01, 6.4697558804757D+02, -3.3915227244081D+02, & - -1.3127082959971D+03, 4.7475537719540D+02, 8.1252490358818D+02, & - 3.0426799712395D+02, 2.9160486418388D+02, -6.4609348432963D+02, & - -2.1720015797288D+02, -4.0717901122888D-01, -2.1775365635881D+00, & - 2.0109616610057D+01, 1.1840212900112D+02, -2.3299581294368D+01, & - -1.3804184017780D+03, -3.7864690931221D+02, 5.4422454262195D+03, & - 1.1731401502819D+02, -7.8538796156468D+03, 1.2681623750875D+03, & - 2.4245427250637D+03, 5.2537243990115D+02, 4.9012179973933D+00, & - -5.8422833107136D+01, -1.1959337380958D+02, 7.6197184851275D+02, & - -5.4004121440061D+02, -6.5752094811032D+02, 5.0117235022499D+03, & - -8.3195437886163D+03, -4.0923671328069D+03, 1.4067572094755D+04, & - -5.1926504471740D+03, -1.8352378595347D+03, 1.8348460774400D+00, & - 4.4232889207825D+01, -2.8532180098981D+02, -5.7783235501804D+02, & - 4.7469633395506D+03, -2.7717073870747D+03, -1.5477480217467D+04, & - 2.0164435060594D+04, 7.6472187060327D+03, -1.4329906429453D+04, & - 2.7654174295895D+03, -2.4933719687704D+01, 1.6938637652995D+02, & - 1.1725472236032D+03, -2.6185152590142D+03, -9.5402134640010D+03, & - 1.7455906770618D+04, 1.7071726465930D+04, -4.2977938350785D+04, & - 8.3240887122425D+03, 8.9751790796763D+03, 2.1229895778839D+01, & - -1.8436561758379D+02, -8.5222313684980D+02, 2.8331698142703D+03, & - 5.3669935127176D+03, -1.4884070826991D+04, -4.6728813976088D+03, & - 2.8923002872424D+04, -1.5729684853032D+04, -9.1001855777311D-02, & - 1.2606953268180D-01, -3.1519952720694D-01, 1.0882246949699D-02, & - 6.1775970589028D+00, 4.0310495365214D+00, -6.9928682686748D+01, & - 9.0965453694424D+00, 3.2158833968308D+02, -1.6194149323382D+02, & - -6.7791173776787D+02, 4.6669667687548D+02, 6.5699669870691D+02, & - -5.2009876671815D+02, -2.3449493492895D+02, 2.0039592779180D+02, & - 3.8802318093898D-03, -4.9919819499055D-01, -2.6557572554758D+00, & - 2.2769271640128D+00, 1.7001242162874D+01, 3.3420756287497D+01, & - -2.9261140751289D+01, -2.1451913425330D+02, -8.3514798161063D+01, & - 6.0390350949326D+02, 2.4911128495358D+02, -8.8970779087907D+02, & - -6.1341985024217D+01, 5.2339793092702D+02, -1.4773870434232D+02, & - -7.3018652841179D-02, 1.2511869964145D-01, -9.0051305439079D-01, & - 1.5938093544128D+01, 3.6086128531278D+01, -1.5519028779513D+02, & - -3.6378153009876D+02, 7.4515812347262D+02, 9.4098545547879D+02, & - -2.0232105093403D+03, -6.3656643380741D+02, 2.2768813182156D+03, & - -1.1769679117170D+02, -7.5095701817072D+02, -6.3164626178965D-02, & - -2.4973821350993D+00, 7.5448861484495D+00, 1.1635606223809D+02, & - -2.2524693749573D+02, -1.0556395012207D+03, 1.8778696180785D+03, & - 2.4814533070907D+03, -4.9001417316772D+03, 2.8787017655091D+02, & - 1.9230152500049D+03, -2.4720091192153D+03, 2.2231531670467D+03, & - -1.5972254758261D+00, 3.3358952350678D+01, -1.5349485484053D+02, & - -1.0222605060145D+03, 2.6058333596737D+03, 5.5066961210604D+03, & - -1.0260746375597D+04, -9.5244944213392D+03, 1.4445465194127D+04, & - 6.7693189472350D+03, -7.0519076729418D+03, -2.2351446735772D+03, & - -4.0377331481523D+00, -2.1309356232702D+01, 1.0932116051132D+03, & - 1.8951040191421D+03, -1.2638353905062D+04, -7.8334339454752D+03, & - 3.7355822038927D+04, -3.2070232783474D+02, -2.7752315703767D+04, & - 3.0703700646355D+03, 6.7196527978088D+03, 1.8589753977584D+01, & - -1.1531237755348D+02, -1.9071791312915D+03, -5.0507717540472D+02, & - 1.8671838329812D+04, 1.8782898019424D+03, -4.9077963825250D+04, & - 1.9663501548405D+04, 1.6775956075880D+04, -6.8797694636129D+03, & - -1.5392769605278D+01, 1.4314231518070D+02, 9.2742914488985D+02, & - -8.6369670411176D+02, -7.5732720415571D+03, 1.2303421777411D+03, & - 1.9655249072421D+04, -1.1356364687235D+04, -1.5516005133570D+03, & - 7.7063768526421D-02, 7.0426469599854D-02, 2.0761670250555D+00, & - -2.8634959354359D+00, -3.1164263380429D+01, 6.3325838362807D+01, & - 1.3440137971042D+02, -4.2450130534225D+02, -1.7557989913336D+02, & - 1.1703417590195D+03, -1.5736118502704D+02, -1.4314931107424D+03, & - 5.4735799135351D+02, 6.5228691636034D+02, -3.4649449001593D+02, & - 3.3658722082134D-01, -5.0676809602213D+00, -2.9106727200001D+00, & - 8.2676750156482D+01, -1.3148704459247D+02, -2.5035771616523D+02, & - 8.8155125325036D+02, 1.5760038417742D+01, -1.7669112592171D+03, & - 3.7903643238106D+02, 1.3940556790468D+03, 9.5473923100084D+01, & - -5.9488289804203D+02, -1.0375305686597D+02, 1.0611853628745D-01, & - 6.8018645407458D-01, -3.8241143585196D+01, -1.4180657093351D+02, & - 5.5839462134171D+02, 8.9083861487365D+02, -2.2428731955568D+03, & - -1.0696194575091D+03, 3.3044661448638D+03, -1.1680010201567D+02, & - -1.7920012637278D+03, -6.1232642612491D+02, 1.3836367193425D+03, & - 2.0417520570553D-01, -7.9433513459797D+00, 4.9941677146710D+01, & - 3.8556761998824D+02, -4.3354401901645D+02, -2.9252579756013D+03, & - 7.0787648712498D+02, 7.4494602120593D+03, -7.2827828707273D+02, & - -6.2503713255535D+03, 9.7289221009631D+02, 7.7312858527177D+01, & - -6.6197854413995D+00, 1.0995202663404D+02, 4.2496312130364D+02, & - -1.0926295063977D+03, -3.4735863505250D+03, 3.8366949704567D+03, & - 6.8787898380604D+03, -5.5632277387875D+03, -4.8778452478220D+03, & - 3.2616178520528D+03, 2.0068291316213D+03, 3.5777786501690D+00, & - -5.7449163082074D+01, -1.1330140975813D+03, -2.3867994586921D+02, & - 1.2486261487440D+04, -2.9307104402199D+03, -2.7262386305868D+04, & - 1.3625571370624D+04, 9.8571450057540D+03, -5.6749289072923D+03/ -data (coef(i),i=591,823)/ & - 4.1553990812089D+00, -7.9039807148033D+01, 8.8968879497294D+02, & - 1.3455454325898D+03, -1.0988450257158D+04, 2.1243056081888D+03, & - 2.2695927933545D+04, -1.6151195263114D+04, 5.7162399438863D+02, & - -1.4707745858430D-01, 9.7352979651830D-01, -1.3963979746230D+00, & - -5.0620597759579D+00, 4.1889115153715D+01, -1.6750935186307D+02, & - 5.4153300234594D+01, 8.6519209898296D+02, -9.9771562423031D+02, & - -1.1954597331072D+03, 1.9130571891052D+03, 3.2970524550364D+02, & - -1.0799252122230D+03, 2.3188545562150D+02, -2.3260472371895D+00, & - 2.8778841876862D+01, 7.3729117301464D+01, -3.9665840600899D+02, & - -1.0492975222219D+02, 9.8391313374665D+02, -8.7153556883620D+02, & - 1.2925482149096D+02, 2.8407542775704D+03, -2.5510566959515D+03, & - -2.6562766587407D+03, 1.9418505402370D+03, 6.4880930217887D+02, & - -6.6339523191321D-01, -6.7652338227873D+00, 1.2595758727568D+02, & - 2.6358517711430D+02, -1.9491350746858D+03, -8.1556544124539D+02, & - 8.0674120988159D+03, -2.8030710355945D+03, -8.2835866894133D+03, & - 8.5200522744880D+03, -1.4823246514080D+03, -1.8582682447107D+03, & - 1.3411433749499D+01, -1.0724377110067D+02, -7.3011900696809D+02, & - 3.2986284159027D+02, 5.4422009200589D+03, 5.1612586434237D+03, & - -1.5408182231606D+04, -1.7219721238496D+04, 2.3099974160780D+04, & - 7.5627594219128D+03, -7.2222488902078D+03, 9.0134473169245D+00, & - -1.8141737623666D+02, -1.6250043077780D+02, 2.7734466811064D+03, & - -1.7603482955414D+03, -8.4261842852894D+03, 1.1505910416517D+04, & - 2.3905813350797D+03, -9.9322452343220D+03, 2.5033774697627D+03, & - -1.5504722193729D+01, 2.3356522943559D+02, 5.0446696501510D+02, & - -2.7974049426340D+03, -2.1728892649799D+03, 8.8232547331869D+03, & - -8.8130817256117D+02, -5.5988385752909D+03, 2.4600534679954D+03, & - 2.9839839544840D-01, -2.5151376007022D+00, -1.6128107429533D+01, & - 1.5815400376918D+01, 1.7510608940292D+02, 9.2482388065900D+01, & - -9.7809220540734D+02, -2.4201666223881D+02, 2.3142988047960D+03, & - -4.5860050306794D+02, -1.8750958557472D+03, 7.4085721397343D+02, & - 2.8053172515762D+02, 4.1947911256955D-02, 1.0075005360980D+01, & - -6.7719600149183D+01, -3.0685585897860D+02, 1.1072385861168D+03, & - 1.6789916295748D+03, -4.8695580803695D+03, -2.0262753920751D+03, & - 5.5980332463152D+03, 6.2850579996277D+02, 2.3166144606877D+02, & - -2.2309515494369D+03, 2.5859761872220D+00, -1.0732897589540D+01, & - -1.4608367222295D+02, 7.3151950872768D+02, 2.0691657871185D+03, & - -6.2964172055131D+03, -7.0631065409304D+03, 1.3988300813956D+04, & - -6.8942777509668D+02, -7.6064339013414D+03, 5.2175199344330D+03, & - -2.9738335062942D+01, 2.6716014780161D+02, 1.4275147307938D+03, & - -2.6294668536922D+03, -9.2629448907848D+03, 3.1355735803168D+03, & - 2.1600693888086D+04, 3.6602362688419D+03, -2.6634480984280D+04, & - 7.9284616538140D+03, 6.7932985538261D+00, -4.0715244679510D+01, & - -2.9625172153656D+02, 6.2654153362437D+01, 3.1592520545123D+03, & - -1.2656094035574D+03, -6.9719119937501D+03, 5.0452169759528D+03, & - 6.3580318228825D+02, 4.9487190936163D-01, -8.1704383753618D+00, & - 3.0866575425802D+01, 1.2890521782151D+02, -7.1868218834493D+02, & - 1.2673007356194D+02, 2.5550860147502D+03, -1.7241055434141D+03, & - -2.3386125844583D+03, 1.9632048623696D+03, 4.8684298042802D+02, & - -6.0019082249152D+02, 1.8914198671144D+01, -2.5768302141778D+02, & - -4.5268033914720D+02, 4.0156097099637D+03, -1.2034046445670D+03, & - -1.2847127836559D+04, 1.2601534082468D+04, 1.0123828204742D+04, & - -1.8277570534558D+04, 4.9534460864680D+03, 1.7746905955483D+03, & - -5.6579196192910D+00, 6.8763882806458D+01, 8.2283065915338D+01, & - -2.4462084382260D+03, -4.0910387942633D+02, 1.5800388896523D+04, & - -1.5542381059831D+03, -2.2695400772600D+04, 1.4191039695857D+04, & - -3.1236918418556D+03, 1.5730605077744D+01, -1.4806541142544D+02, & - -7.3549773901344D+02, 1.9567318545056D+03, 3.8451428102190D+03, & - -5.0356609530826D+03, -5.0370354604727D+03, 1.8104166969353D+03, & - 3.4573735155463D+03, -2.2310791296488D+00, 3.0309038289269D+01, & - 2.4387010913574D-02, -4.0609309840901D+02, 9.8147125540770D+02, & - -1.2887853697751D+02, -2.9863513297012D+03, 2.9859066623897D+03, & - 7.5810452433204D+02, -1.3633646747081D+03, 2.3494005037572D+02, & - -3.6049971507842D+01, 4.6341305915926D+02, 1.0179406463565D+03, & - -6.8412635604360D+03, -3.4856750931568D+02, 1.9896790284724D+04, & - -1.0548394707187D+04, -1.5786132878027D+04, 1.5616388325597D+04, & - -3.8177104809982D+03, 3.9840698767479D+00, -5.5640306634995D+01, & - -4.1773631283442D+01, 1.6530852321701D+03, 3.5846651873594D+01, & - -1.0125455268494D+04, 1.4310619082953D+03, 1.4684788370590D+04, & - -7.5655604775677D+03, 2.1863563084839D+00, -2.8676540512968D+01, & - -2.5470438201247D+01, 3.6758591398511D+02, -5.7140314000597D+02, & - 3.8434447269712D+01, 1.5820008738722D+03, -2.0663067220802D+03, & - 3.5807377993698D+02, 2.8966278527317D+02, 1.9992892131663D+01, & - -2.5091839059403D+02, -5.9493849732297D+02, 3.6040463692465D+03, & - 6.8425945490518D+02, -9.8117448904512D+03, 2.9842697258990D+03, & - 7.8691352095489D+03, -4.3817966235099D+03, -5.5702600343214D-01, & - 7.2587027792799D+00, 8.6351336949194D+00, -8.9552953762538D+01, & - 1.1575980363922D+02, -3.0029982429047D+01, -2.8073588184232D+02, & - 5.1929492676140D+02, -2.3951066467556D+02/ - -contains - ! some wrapper functions and the Partridge Schwenke Dipole moment surface for water - published - ! J. Chem. Phys. 113, 6592 (2000); http://dx.doi.org/10.1063/1.1311392 - ! retreived from EPAPS : EPAPS Document No. E-JCPSA6-113-304040 - - subroutine m_site_position(atomic_positions,gammaM,pos) - real(dp), dimension(3,3),intent(in) :: atomic_positions - real(dp), intent(in) :: gammaM - real(dp),dimension(3),intent(out) :: pos - - pos = (1.0_dp-gammaM)*atomic_positions(:,3) + 0.5_dp*gammaM*(atomic_positions(:,1)+atomic_positions(:,2)) - end subroutine m_site_position - - subroutine m_site_position_grads(gammaM,grads) - real(dp), intent(in) :: gammaM - real(dp), dimension(3,3,3),intent(out) :: grads - real(dp), dimension(3,3) :: identity3x3 - - identity3x3 = 0.0_dp - call add_identity(identity3x3) - - grads(:,:,1) = (0.5_dp*gammaM) *identity3x3 - grads(:,:,2) = (0.5_dp*gammaM) *identity3x3 - grads(:,:,3) = (1.0_dp-gammaM) *identity3x3 - - end subroutine m_site_position_grads - - subroutine test_charge_grads_PS(atomic_positions,gammaM) - real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom, as dms_nasa expects - real(dp) :: gammaM - - real(dp) :: q0,q_plus,step - real(dp), dimension(3,3) :: x - real(dp), dimension(1,3,3) :: grad - integer :: i_site,i,j - - step=1e-8_dp - do i_site=1,3 - call charges_PS(atomic_positions,q0,i_site,gammaM) - call charge_gradients_PS(atomic_positions,grad,gammaM,i_site) - do i=1,3 ! loop over position components - do j=1,3 ! loop over atoms - x=atomic_positions - x(i,j)= x(i,j)+step - call charges_PS(x,q_plus,i_site,gammaM) - call print(" Step Size : "// step //" (q(i)-q0(i)) / (grad*step) : "//(q_plus -q0)/ (grad(1,i,j)*step)) - end do - end do - end do - end subroutine test_charge_grads_PS - - subroutine charges_PS(atomic_positions,charge,i_site,gammaM) - real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom, as dms_nasa expects - real(dp),intent(inout) :: charge - integer, intent(in) :: i_site - real(dp),intent(inout) :: gammaM - - real(dp), dimension(3) :: q - real(dp), dimension(3,3) :: x - real(dp), dimension(3,3,3) :: charge_grads - real(dp) :: tmp - integer :: i - - ! vibdip function wants atomic order to be H,H,O, whereas dms_nasa expects O,H,H, so have to switch - do i=1,3 - x(:,i)=atomic_positions(:,4-i) - end do - - tmp=0.5_dp*gammaM/(1.0_dp-gammaM) -#ifdef HAVE_FX - call dms_nasa(x,q,charge_grads) -#endif - ! sites 1 and 2 are hydrogens, site 3 is the M-site - select case(i_site) - case(1) - charge = q(3)+tmp*(q(2)+q(3)) - case(2) - charge = q(2)+tmp*(q(2)+q(3)) - case(3) - charge = q(1) / (1.0_dp-gammaM) - case default - call system_abort("invalid i_site passed to charges_PS, only 3 sites per monomer") - end select -call print("array of charges "//q) - end subroutine charges_PS - - subroutine charge_gradients_PS(atomic_positions,grad,gammaM,i_site) - ! PS definitions ! QUIP structure - ! charge grad components (1,3,3) -> ! grad array which we return has structure (1,3,3) - ! 1st index labels the atom wrt which we differentiate ! 1st index labels charge - ! 2nd index labels the charge (H1,H2,O) whose charge is 'changing' ! 2nd index labels cartesian component - ! 3rd index labels the cartesian component of atom i's position ! 3rd index labels the atom - - real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom - real(dp), dimension(1,3,3),intent(inout) :: grad ! indices: (1,position component,atom) index 1 is the site(fixed), 2 is pos component, 3 is atom - real(dp),intent(inout) :: gammaM - integer, intent(in) :: i_site - - real(dp), dimension(3,3,3) :: charge_grads ! indices: (atom,charge,position component) - real(dp), dimension(3,3) :: x,dq_dqa !! gradients of site charges (as def in TTM models) wrt atomic charges from dms - real(dp), dimension(3) :: q - integer :: i_charge,i_atom,i_pos - real(dp) :: a, b - - ! ordering of sites is HHM, ordering of dms charges is OHH - - b=0.5_dp*gammaM - a=1.0_dp-b - - !gradients of site charges (q) wrt atomic dms charges (qa) which we get from PS function. - dq_dqa = (1.0_dp /( 1.0_dp-gammaM)) * reshape((/0.0_dp,0.0_dp,1.0_dp,b,a,0.0_dp,a,b,0.0_dp/),shape(dq_dqa)) - - -do i_atom=1,3 -call print(" "//dq_dqa(i_atom,:)) -end do - - ! switch to OHH atom ordering - do i_atom=1,3 - x(:,i_atom)=atomic_positions(:,4-i_atom) - end do -#ifdef HAVE_FX - call dms_nasa(x,q,charge_grads) -#endif - - - grad=0.0_dp - do i_atom=1,3 - do i_charge=1,3 - grad(1,:,i_atom) = grad(1,:,i_atom) + dq_dqa(i_site,i_charge) * charge_grads(4-i_atom,i_charge,:) ! 4-i_atom because switching from OHH to HHO ordering - end do -call print("atom number "//i_atom) -call print(""//grad(1,:,i_atom)) - end do - - end subroutine charge_gradients_PS - - subroutine dipole_moment_PS(atomic_positions,dipole) - real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom - real(dp), dimension(3),intent(inout) :: dipole - real(dp), dimension(1,3,3) :: x ! rank 3 array because that's what vibdip takes as an argument - real(dp), dimension(1,3) :: d ! rank 2 array because that's what vibdip takes as an argument - x(1,:,:) = atomic_positions *(1.0_dp/BOHR) ! convert to a.u. - call vibdip(x,d,1) - dipole = d(1,:)* BOHR ! convert from a.u. - end subroutine dipole_moment_PS - - subroutine dipole_moment_gradients_PS(atomic_positions,grad,step,test) - - ! calculate gradients of dipole moment components wrt atomic positions, using finite differences - ! step is an optional parameter, but should be chosen to get maximal precision in the gradients - - real(dp),intent(in), optional :: step ! distance in Angstroms to move atoms for finite diff - logical,intent(in), optional :: test ! whether to test to find the best step size - real(dp) :: my_step - real(dp), dimension(1,3) :: d_plus, d_minus, d_plus_fd, d0 - real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom - real(dp), dimension(1,3,3) :: x ! working array to hold temporary positions - real(dp), dimension(3,3,3),intent(inout) :: grad - integer :: i, j ,k - logical :: do_test - - do_test = optional_default(.False.,test) - my_step = optional_default(1e-8_dp *BOHR, step) - - if (do_test) then - call print("RESULT OF GRADIENT TESTING THE FINITE DIFFERENCE GRADS") - end if - - grad = 0.0_dp - - do i=1,3 ! loop over atoms - do j=1,3 ! loop over position components - x(1,:,:) = atomic_positions *(1.0_dp/BOHR) - x(1,j,i) = x(1,j,i) + my_step - call vibdip(x,d_plus,1) - x(1,j,i) = x(1,j,i) - 2.0_dp*my_step - call vibdip(x,d_minus,1) - do k=1,3 ! loop over dipole components - grad(k,j,i) = (d_plus(1,k) - d_minus(1,k)) / (2.0_dp * my_step) ! this already in QUIP units, since dipole gradient with position just has units of charge (e). - end do - end do - end do - - if (do_test) then - call print("Testing gradient of PS dipole moment components wrt atomic positions : ") - my_step = 0.9_dp*my_step - do i=1,3 ! loop over atoms - do j=1,3 ! loop over position components - do k=1,3 ! loop over dipole components - x(1,:,:) = atomic_positions *(1.0_dp/BOHR) - call vibdip(x,d0,1) - x(1,j,i) = x(1,j,i) + my_step - call vibdip(x,d_plus,1) - call print(" Step Size : "// my_step //" (d(i)-d0(i)) / (grad*step) : "//(d_plus(1,k) -d0(1,k))/ (grad(k,j,i)*my_step)) - end do - end do - end do - end if - - end subroutine dipole_moment_gradients_PS - - subroutine vibdip(x,d,n) - integer :: n, isump,nf,i,j, ifirst=0 - real(dp), dimension(n,3,3) :: x - real(dp), dimension(n,3) :: d - real(dp), dimension(19,3) :: fmat - real(dp) :: reoh, thetae,b1,toang,rad,cabc,ce,r1x,r1y,r1z,r1,r2x,r2y,r2z,r2, & - x1,x2,x3,p1,p2,damp1,damp2,term,term1,term2 - save - - !!$c - !!$c dipole moment surface for h2o, - !!$c David W. Schwenke and Harry Partridge, J. Chem. Phys., - !!$c submitted May, 2000. - !!$c - !!$c x(i,j,k) is cartesian coordinate (in a.u.) of atoms in some frame - !!$c of reference, i is geometry no., j=1 x, j=2 y, j=3 z, - !!$c k=1,2 h, k=3 o. - !!$c n is number of geometries. - !!$c - !!$c return dipole moment d(i,j) (in a.u.), i is geometry no., j=1 x, - !!$c j=2 y, j=3 z in the same frame of reference as input - !!$c cartesians. - !!$c - - if(ifirst.eq.0)then - ifirst=1 - ! write(6,1) - !!$1 format(/1x,'dipole moment surface for h2o', - !!$ $ /1x,'by David W. Schwenke and Harry Partridge ', - !!$ $ /1x,'submitted to J. Chem. Phys. May, 2000', - !!$ $ /1x,'use parameters for FIT2') !6d6s00 - reoh= 0.958648999999999973d0 - thetae= 104.347499999999997d0 - b1= 1.50000000000000000d0 - !!$ write(6,4)reoh,thetae,b1 - !!$ 4 format(/1x,'reoh = ',f10.4,' thetae = ',f10.4, - !!$ $ /1x,'beta = ',f10.4) - nf=1 - isump=0 - toang=1d0/1.889725989d0 - reoh=reoh*1.889725989d0 - b1=b1/1.889725989d0**2 - nf=823 !6d6s00 - do i=1,nf !6d6s00 - !write(6,5)(idx(i,j),j=1,3),coef(i) - !5 format(1x,3i5,1pe15.7) - isump=max(isump,idx(i,1),idx(i,2),idx(i,3)) - end do - rad=acos(-1d0)/1.8d2 - ce=cos(thetae*rad) - end if - - - do i=1,n - - r1x=x(i,1,1)-x(i,1,3) - r1y=x(i,2,1)-x(i,2,3) - r1z=x(i,3,1)-x(i,3,3) - r1=sqrt(r1x**2+r1y**2+r1z**2) - r2x=x(i,1,2)-x(i,1,3) - r2y=x(i,2,2)-x(i,2,3) - r2z=x(i,3,2)-x(i,3,3) - r2=sqrt(r2x**2+r2y**2+r2z**2) - cabc=(r1x*r2x+r1y*r2y+r1z*r2z)/(r1*r2) - x1=(r1-reoh)/reoh - x2=(r2-reoh)/reoh - x3=cabc-ce - fmat(1,1)=1d0 - fmat(1,2)=1d0 - fmat(1,3)=1d0 - - do j=2,isump - - fmat(j,1)=fmat(j-1,1)*x1 - fmat(j,2)=fmat(j-1,2)*x2 - fmat(j,3)=fmat(j-1,3)*x3 - end do - p1=0d0 - p2=0d0 - damp1=exp(-b1*((r1-reoh)**2)) !6d6s00 - damp2=exp(-b1*((r2-reoh)**2)) !6d6s00 - - do j=1,nf - term=coef(j)*fmat(idx(j,3),3) - term1=term*fmat(idx(j,1),1)*fmat(idx(j,2),2) - term2=term*fmat(idx(j,2),1)*fmat(idx(j,1),2) - if(idx(j,2).gt.1.or.idx(j,3).gt.1)then !2d26s99 - term1=term1*damp2 !2d26s99 - term2=term2*damp1 !2d26s99 - end if !2d26s99 - p1=p1+term1 - p2=p2+term2 - end do - p1=p1*damp1 - p2=p2*damp2 - d(i,1)=p1*(x(i,1,1)-x(i,1,3))+p2*(x(i,1,2)-x(i,1,3)) - d(i,2)=p1*(x(i,2,1)-x(i,2,3))+p2*(x(i,2,2)-x(i,2,3)) - d(i,3)=p1*(x(i,3,1)-x(i,3,3))+p2*(x(i,3,2)-x(i,3,3)) - end do - return - end subroutine vibdip - -end module partridge_schwenke_dipole_module diff --git a/src/Potentials/Potential.f95 b/src/Potentials/Potential.f95 deleted file mode 100644 index f55ae3114a..0000000000 --- a/src/Potentials/Potential.f95 +++ /dev/null @@ -1,2442 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!% This module encapsulates all the interatomic potentials implemented in QUIP -!% -!% A Potential object represents an interatomic potential, a -!% tight binding model or an interface to an external code used to -!% perform calculations. It is initialised from an `args_str` -!% describing the type of potential, and an XML formatted string -!% `param_str` giving the parameters. -!% -!% Types of Potential: -!% -!% ==================== ========================================================== -!% `args_str` prefix Description -!% ==================== ========================================================== -!% ``IP`` Interatomic Potential -!% ``TB`` Tight Binding Model -!% ``FilePot`` File potential, used to communicate with external program -!% ``CallbackPot`` Callback potential, computation done by Python function -!% ``Sum`` Sum of two other potentials -!% ``ForceMixing`` Combination of forces from two other potentials -!% ==================== ========================================================== -!% -!% -!% Types of interatomic potential available: -!% -!% ======================== ========================================================== -!% `args_str` prefix Description -!% ======================== ========================================================== -!% ``IP BOP`` Bond order potential for metals -!% ``IP BornMayer`` Born-Mayer potential for oxides -!% (e.g. BKS potential for silica) -!% ``IP Brenner`` Brenner (1990) potential for carbon -!% ``IP Brenner_2002`` Brenner (2002) reactive potential for carbon -!% ``IP Brenner_Screened`` Interface to Pastewka et al. screened Brenner reactive -!% potential for carbon -!% ``IP Coulomb`` Coulomb interaction: support direct summation, -!% Ewald and damped shifted force Coulomb potential -!% ``IP Einstein`` Einstein crystal potential -!% ``IP EAM_ErcolAd`` Embedded atom potential of Ercolessi and Adams -!% ``IP FB`` Flikkema and Bromley potential -!% ``IP FS`` Finnis-Sinclair potential for metals -!% ``IP FX`` Wrapper around ttm3f water potential of -!% Fanourgakis-Xantheas -!% ``IP GAP`` Gaussian approximation potential -!% ``IP Glue`` Generic implementation of 'glue' potential -!% ``IP HFdimer`` Simple interatomic potential for an HF dimer, from -!% MP2 calculations -!% ``IP KIM`` Interface to KIM, the Knowledgebase of Interatomic -!% potential Models (www.openkim.org) -!% ``IP LJ`` Lennard-Jones potential -!% ``IP Morse`` Morse potential -!% ``IP PartridgeSchwenke`` Partridge-Schwenke model for a water monomer -!% ``IP SW`` Stillinger-Weber potential for silicon -!% ``IP SW_VP`` Combined Stillinger-Weber and Vashista potential -!% for Si and :mol:`SiO_2`. -!% ``IP Si_MEAM`` Silicon modified embedded attom potential -!% ``IP Sutton_Chen`` Sutton-Chen potential -!% ``IP TS`` Tangney-Scandolo polarisable potential for oxides -!% ``IP Tersoff`` Tersoff potential for silicon -!% ``IP WaterDimer_Gillan`` 2-body potential for water dimer -!% ======================== ========================================================== -!% -!% Types of tight binding potential available: -!% -!% ======================= ========================================================== -!% `args_str` prefix Description -!% ======================= ========================================================== -!% ``TB Bowler`` Bowler tight binding model -!% ``TB DFTB`` Density functional tight binding -!% ``TB GSP`` Goodwin-Skinner-Pettifor tight binding model -!% ``TB NRL_TB`` Naval Research Laboratory tight binding model -!% ======================= ========================================================== -!% -!% Examples of the XML parameters for each of these potential can be -!% found in the `src/Parameters `_ -!% directory of the QUIP git repository. -!% -!%!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#ifdef HAVE_LOCAL_E_MIX -#define HAVE_HYBRID -#endif -#ifdef HAVE_ONIOM -#define HAVE_HYBRID -#endif - -#include "error.inc" -module Potential_module - - use error_module - use system_module, only : dp, inoutput, print, PRINT_ALWAYS, PRINT_NORMAL, PRINT_VERBOSE, PRINT_NERD, initialise, finalise, INPUT, & - optional_default, current_verbosity, mainlog, round, verbosity_push_decrement, verbosity_push, verbosity_pop, print_message, system_timer, system_abort, operator(//) - use units_module, only : EV_A3_IN_GPA - use periodictable_module, only : ElementCovRad, ElementMass - use extendable_str_module, only : extendable_str, initialise, read, string, finalise - use linearalgebra_module , only : norm, trace, matrix3x3_det, normsq, least_squares, add_identity, inverse, diagonalise, symmetric_linear_solve, operator(.fne.), operator(.mult.), operator(.feq.), print - use dictionary_module, only : dictionary, STRING_LENGTH, lookup_entry_i, write_string, get_value, has_key, read_string, set_value, remove_value, initialise, finalise - use paramreader_module, only : param_register, param_read_line - use mpi_context_module, only : mpi_context - use table_module, only : table, find, int_part, wipe, append, finalise - use minimization_module , only : minim, n_minim, fire_minim, test_gradient, n_test_gradient - use connection_module, only : connection - use atoms_types_module, only : atoms, assign_pointer, add_property, assign_property_pointer, add_property_from_pointer, diff_min_image, distance_min_image - use atoms_module, only : has_property, cell_volume, neighbour, n_neighbours, set_lattice, is_nearest_neighbour, & - get_param_value, remove_property, calc_connect, set_cutoff, set_cutoff_minimum, set_param_value, calc_dists, atoms_repoint, finalise, assignment(=) - use cinoutput_module, only : cinoutput, write, quip_chdir, quip_dirname, quip_basename, quip_getcwd - use dynamicalsystem_module, only : dynamicalsystem, ds_print_status, advance_verlet1, advance_verlet2 - use clusters_module, only : HYBRID_ACTIVE_MARK, HYBRID_NO_MARK, HYBRID_BUFFER_MARK, create_embed_and_fit_lists_from_cluster_mark, create_embed_and_fit_lists, & - create_hybrid_weights, add_cut_hydrogens, create_cluster_info_from_mark, bfs_grow, carve_cluster - - use QUIP_Common_module -#ifdef HAVE_TB - use TB_module -#endif - use Potential_simple_module - - use adjustablepotential_module, only: adjustable_potential_init, adjustable_potential_optimise, & - adjustable_potential_force, adjustable_potential_finalise - - implicit none - -#ifndef POTENTIAL_NO_DEFAULT_PRIVATE - private -#endif - - logical, save :: printed_cutoff_warning = .false. - - !************************************************************************* - !* - !* Potential header - !* - !************************************************************************* - - integer :: hack_restraint_i(2) - real(dp) :: hack_restraint_r, hack_restraint_k - public :: hack_restraint_i, hack_restraint_r, hack_restraint_k - - public :: Potential - !% Potential type which abstracts all QUIP interatomic potentials - !% - !% Provides interface to all energy/force/virial calculating schemes, - !% including actual calculations, as well as abstract hybrid schemes - !% such as LOTF, Force Mixing, ONIOM, and the local energy scheme. - !% - !% Typically a Potential is constructed from an initialisation - !% args_str and an XML parameter file, e.g. in Fortran:: - !% - !% type(InOutput) :: xml_file - !% type(Potential) :: pot - !% ... - !% call initialise(xml_file, 'SW.xml', INPUT) - !% call initialise(pot, 'IP SW', param_file=xml_file) - !% - !% Or, equivaently in Python:: - !% - !% pot = Potential('IP SW', param_filename='SW.xml') - !% - !% creates a Stillinger-Weber potential using the parameters from - !% the file 'SW.xml'. The XML parameters can also be given directly - !% as a string, via the `param_str` argument. - !% - !% The main workhorse is the :meth:`calc` routine, which is used - !% internally to perform all calculations, e.g. to calculate forces:: - !% - !% type(Atoms) :: at - !% real(dp) :: force(3,8) - !% ... - !% call diamond(at, 5.44, 14) - !% call randomise(at%pos, 0.01) - !% call calc(pot, at, force=force) - !% - !% Note that there is now no need to set the 'Atoms%cutoff' attribute to the - !% cutoff of this Potential: if it is less than this it will be increased - !% automatically and a warning will be printed. - !% The neighbour lists are updated automatically with the - !% :meth:`~quippy.atoms.Atoms.calc_connect` routine. For efficiency, - !% it's a good idea to set at%cutoff_skin greater than zero to decrease - !% the frequency at which the connectivity needs to be rebuilt. - !% - !% A Potential can be used to optimise the geometry of an - !% :class:`~quippy.atoms.Atoms` structure, using the :meth:`minim` routine, - !% (or, in Python, via the :class:`Minim` wrapper class). - type Potential - type(MPI_context) :: mpi - character(len=STRING_LENGTH) :: init_args_pot1, init_args_pot2, xml_label, xml_init_args, calc_args = "" - - logical :: is_simple = .false. - type(Potential_simple) :: simple - - type(Potential), pointer :: l_mpot1 => null() ! local copies of potentials, if they are created by potential_initialise from an args string - type(Potential), pointer :: l_mpot2 => null() ! local copies of potentials, if they are created by potential_initialise from an args string - - logical :: is_sum = .false. - type(Potential_Sum), pointer :: sum => null() - - logical :: is_forcemixing = .false. - type(Potential_FM), pointer :: forcemixing => null() - - logical :: is_evb = .false. - type(Potential_EVB), pointer :: evb => null() - -#ifdef HAVE_LOCAL_E_MIX - logical :: is_local_e_mix = .false. - type(Potential_Local_E_Mix), pointer :: local_e_mix => null() -#endif - -#ifdef HAVE_ONIOM - logical :: is_oniom = .false. - type(Potential_ONIOM), pointer :: oniom => null() -#endif - - logical :: is_cluster = .false. - type(Potential_Cluster), pointer :: cluster => null() - - logical :: do_rescale_r, do_rescale_E - real(dp) :: r_scale, E_scale - - end type Potential - - public :: Initialise, Potential_Filename_Initialise - interface Initialise - module procedure Potential_Initialise, Potential_Initialise_inoutput - end interface - - public :: Finalise - interface Finalise - module procedure Potential_Finalise - end interface - - public :: Setup_Parallel - interface Setup_Parallel - module procedure Potential_Setup_Parallel - end interface - - public :: Print - interface Print - module procedure Potential_Print - end interface - - - !% Return the cutoff of this 'Potential', in Angstrom. This is the - !% minimum neighbour connectivity cutoff that should be used: if - !% you're doing MD you'll want to use a slightly larger cutoff so - !% that new neighbours don't drift in to range between connectivity - !% updates - public :: Cutoff - interface Cutoff - module procedure Potential_Cutoff - end interface - - public :: Calc - - !% Apply this Potential to the Atoms object - !% 'at'. Atoms%calc_connect is automatically called to update the - !% connecticvity information -- if efficiency is important to you, - !% ensure that at%cutoff_skin is set to a non-zero value to decrease - !% the frequence of connectivity updates. - !% optional arguments determine what should be calculated and how - !% it will be returned. Each physical quantity has a - !% corresponding optional argument, which can either be an 'True' - !% to store the result inside the Atoms object (i.e. in - !% Atoms%params' or in 'Atoms%properties' with the - !% default name, a string to specify a different property or - !% parameter name, or an array of the the correct shape to - !% receive the quantity in question, as set out in the table - !% below. - !% - !% ================ ============= ================ ========================= - !% Array argument Quantity Shape Default storage location - !% ================ ============= ================ ========================= - !% ``energy`` Energy ``()`` ``energy`` param - !% ``local_energy`` Local energy ``(at.n,)`` ``local_energy`` property - !% ``force`` Force ``(3,at.n)`` ``force`` property - !% ``virial`` Virial tensor ``(3,3)`` ``virial`` param - !% ``local_virial`` Local virial ``(3,3,at.n)`` ``local_virial`` property - !% ================ ============= ================ ========================= - !% - !% The 'args_str' argument is an optional string containing - !% additional arguments which depend on the particular Potential - !% being used. - !% - !% Not all Potentials support all of these quantities: an error - !% will be raised if you ask for something that is not supported. - interface Calc - module procedure Potential_Calc - end interface - - !% Minimise the configuration 'at' under the action of this - !% Potential. Returns number of minimisation steps taken. If - !% an error occurs or convergence is not reached within 'max_steps' - !% steps, 'status' will be set to 1 on exit. - !% - !% Example usage (in Python, Fortran code is similar. See - !% :ref:`geomopt` in the quippy tutorial for full - !% explanation):: - !% - !%> at0 = diamond(5.44, 14) - !%> pot = Potential('IP SW', param_str=''' - !%> Stillinger and Weber, Phys. Rev. B 31 p 5262 (1984) - !%> - !%> - !%> p="4" q="0" a="1.80" sigma="2.0951" eps="2.1675" /> - !%> - !%> lambda="21.0" gamma="1.20" eps="2.1675" /> - !%> ''') - !%> pot.minim(at0, 'cg', 1e-7, 100, do_pos=True, do_lat=True) - public :: Minim - interface Minim - module procedure Potential_Minim - end interface - - public :: test_gradient - interface test_gradient - module procedure pot_test_gradient - end interface - - public :: n_test_gradient - interface n_test_gradient - module procedure pot_n_test_gradient - end interface - - public :: set_callback - interface set_callback - module procedure potential_set_callback - end interface - - ! Allow Potential_Precon_Minim access to some Potential Functions - public :: energy_func - public :: gradient_func - public :: print_hook - public :: pack_pos_dg - public :: unpack_pos_dg - public :: fix_atoms_deform_grad - public :: prep_atoms_deform_grad - public :: max_rij_change - public :: constrain_virial - - - public :: potential_minimise - type Potential_minimise - real(dp) :: minim_pos_lat_preconditioner = 1.0_dp - - real(dp) :: minim_save_lat(3,3) - character(len=STRING_LENGTH) :: minim_args_str - logical :: minim_do_pos, minim_do_lat - integer :: minim_n_eval_e, minim_n_eval_f, minim_n_eval_ef - real(dp) :: pos_lat_preconditioner_factor - type(Atoms), pointer :: minim_at => null() - real(dp), pointer :: last_connect_x(:) => null() - type(Potential), pointer :: minim_pot => null() - type(CInoutput), pointer :: minim_cinoutput_movie => null() - real(dp), dimension(3,3) :: external_pressure = 0.0_dp - - logical :: connectivity_rebuilt = .false. - - end type Potential_minimise - - type(Potential), pointer :: parse_pot - logical, save :: parse_in_pot, parse_in_pot_done, parse_matched_label - - public :: run - - interface run - module procedure dynamicalsystem_run - end interface run - -#include "Potential_Sum_header.f95" -#include "Potential_ForceMixing_header.f95" -#include "Potential_EVB_header.f95" - -#ifdef HAVE_LOCAL_E_MIX -#include "Potential_Local_E_Mix_header.f95" -#endif -#ifdef HAVE_ONIOM -#include "Potential_ONIOM_header.f95" -#endif -#include "Potential_Cluster_header.f95" - - ! Public interfaces from Potential_Hybrid_utils.f95 - - public :: bulk_modulus - interface bulk_modulus - module procedure potential_bulk_modulus - end interface bulk_modulus - - public :: test_local_virial - interface test_local_virial - module procedure potential_test_local_virial - end interface test_local_virial - -#ifdef HAVE_TB - public :: calc_TB_matrices - interface calc_TB_matrices - module procedure Potential_calc_TB_matrices - end interface -#endif - - contains - - !************************************************************************* - !* - !* Potential routines - !* - !************************************************************************* - -recursive subroutine potential_Filename_Initialise(this, args_str, param_filename, bulk_scale, mpi_obj, error) - type(Potential), intent(inout) :: this - character(len=*), intent(in) :: args_str !% Valid arguments are 'Sum', 'ForceMixing', 'EVB', 'Local_E_Mix' and 'ONIOM', and any type of simple_potential - character(len=*), intent(in) :: param_filename !% name of xml parameter file for potential initializers - type(Atoms), optional, intent(inout) :: bulk_scale !% optional bulk structure for calculating space and E rescaling - type(MPI_Context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(inoutput) :: io - type(extendable_str) :: my_cwd, param_file_dirname, param_file_basename - - INIT_ERROR(error) - - if (len_trim(param_filename) == 0) then - RAISE_ERROR("potential_Filename_Initialise: empty filename",error) - endif - - my_cwd = quip_getcwd() - param_file_dirname = quip_dirname(trim(param_filename)) - param_file_basename = quip_basename(trim(param_filename)) - - call quip_chdir(param_file_dirname) - - call initialise(io, trim(string(param_file_basename)), INPUT, master_only=.true.) - call initialise(this, args_str, io, bulk_scale=bulk_scale, mpi_obj=mpi_obj, error=error) - PASS_ERROR(error) - call finalise(io) - - call quip_chdir(my_cwd) - -end subroutine potential_Filename_Initialise - -subroutine potential_initialise_inoutput(this, args_str, io_obj, bulk_scale, mpi_obj, error) - type(Potential), intent(inout) :: this - character(len=*), intent(in) :: args_str !% Valid arguments are 'Sum', 'ForceMixing', 'EVB', 'Local_E_Mix' and 'ONIOM', and any type of simple_potential - type(InOutput), intent(in) :: io_obj !% name of xml parameter inoutput for potential initializers - type(Atoms), optional, intent(inout) :: bulk_scale !% optional bulk structure for calculating space and E rescaling - type(MPI_Context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(extendable_str) :: es - - INIT_ERROR(error) - - call initialise(es) - if (io_obj%initialised) then - if (present(mpi_obj)) then - call read(es, io_obj%unit, convert_to_string=.true., mpi_comm=mpi_obj%communicator, mpi_id=mpi_obj%my_proc) - else - call read(es, io_obj%unit, convert_to_string=.true.) - endif - else - call initialise(es) - endif - - call initialise(this, args_str=args_str, param_str=string(es), bulk_scale=bulk_scale, mpi_obj=mpi_obj, error=error) - PASS_ERROR(error) - call finalise(es) - -end subroutine potential_initialise_inoutput - -recursive subroutine potential_initialise(this, args_str, pot1, pot2, param_str, bulk_scale, mpi_obj, error) - type(Potential), intent(inout) :: this - character(len=*), optional, intent(in) :: args_str !% Valid arguments are 'Sum', 'ForceMixing', 'EVB', 'Local_E_Mix' and 'ONIOM', and any type of simple_potential - type(Potential), optional, intent(in), target :: pot1 !% Optional first Potential upon which this Potential is based - type(Potential), optional, intent(in), target :: pot2 !% Optional second potential - character(len=*), optional, intent(in) :: param_str !% contents of xml parameter file for potential initializers, if needed - type(Atoms), optional, intent(inout) :: bulk_scale !% optional bulk structure for calculating space and E rescaling - type(MPI_Context), optional, intent(in) :: mpi_obj - integer, intent(out), optional :: error - - type(Potential), pointer :: u_pot1, u_pot2 - type(Dictionary) :: params - - logical :: has_xml_label, minimise_bulk, has_target_vol, has_target_B, has_r_scale, has_E_scale - real(dp) :: target_vol, target_B, r_scale, vol, B - character(len=STRING_LENGTH) :: my_args_str, init_args_str, first_tag, xml_label - type(Atoms) :: bulk - integer :: it, tag_start, tag_end - - INIT_ERROR(error) - - call finalise(this) - - my_args_str = '' - if (present(args_str)) my_args_str = args_str - - ! Default init_args are xml_label=LABEL, extracting LABEL from first XML tag - if (len_trim(my_args_str) == 0) then - if (.not. present(param_str)) then - RAISE_ERROR('No init_args given and param_str not present', error) - end if - if (len_trim(param_str) == 0) then - RAISE_ERROR('No init_args given and param_str is empty', error) - end if - tag_start = index(param_str, '<') - tag_end = index(param_str, '>') - xml_label = param_str(tag_start+1:tag_end-1) - call print_message('INFO', 'Potential_initialise using default init_args "Potential xml_label='//trim(xml_label)//'"', PRINT_VERBOSE) - my_args_str = 'Potential xml_label='//xml_label - end if - - call initialise(params) - call param_register(params, 'xml_label', '', this%xml_label, has_value_target=has_xml_label, help_string="Label in xml file Potential stanza to match") - call param_register(params, 'calc_args', '', this%calc_args, help_string="Default calc_args that are passed each time calc() is called") - if(.not. param_read_line(params, my_args_str, ignore_unknown=.true.,task='Potential_Initialise args_str')) then - RAISE_ERROR("Potential_initialise failed to parse args_str='"//trim(my_args_str)//"'", error) - endif - call finalise(params) - - my_args_str = "" - if(has_xml_label) then - call Potential_read_params_xml(this, param_str) - my_args_str = trim(this%xml_init_args) - endif - my_args_str = trim(my_args_str) // " " // trim(args_str) - - call initialise(params) - call param_register(params, 'init_args_pot1', '', this%init_args_pot1, help_string="Argument string for initializing pot1 (for non-simple potentials") - call param_register(params, 'init_args_pot2', '', this%init_args_pot2, help_string="Argument string for initializing pot2 (for non-simple potentials") - call param_register(params, 'Sum', 'false', this%is_sum, help_string="Potential that's a sum of 2 other potentials") - call param_register(params, 'ForceMixing', 'false', this%is_forcemixing, help_string="Potential that's force-mixing of 2 other potentials") - call param_register(params, 'EVB', 'false', this%is_evb, help_string="Potential using empirical-valence bond to mix 2 other potentials") -#ifdef HAVE_LOCAL_E_MIX - call param_register(params, 'Local_E_Mix', 'false', this%is_local_e_mix, help_string="Potential that's local energy mixing of 2 other potentials") -#endif /* HAVE_LOCAL_E_MIX */ -#ifdef HAVE_ONIOM - call param_register(params, 'ONIOM', 'false', this%is_oniom, help_string="Potential from ONIOM mixing of two other potential energies") -#endif /* HAVE_ONIOM */ - call param_register(params, 'Cluster', 'false', this%is_cluster, help_string="Potential evaluated using clusters") - call param_register(params, 'do_rescale_r', 'F', this%do_rescale_r, help_string="If true, rescale distances by factor r_scale.") - call param_register(params, 'r_scale', '1.0', this%r_scale, has_value_target=has_r_scale, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'do_rescale_E', 'F', this%do_rescale_E, help_string="If true, rescale energy by factor E_scale.") - call param_register(params, 'E_scale', '1.0', this%E_scale, has_value_target=has_E_scale, help_string="Recaling factor for energy. Default 1.0.") - call param_register(params, "minimise_bulk", "F", minimise_bulk, help_string="If true, minimise bulk_scale structure before measuring eqm. volume and bulk modulus for rescaling") - call param_register(params, "target_vol", "0.0", target_vol, has_value_target=has_target_vol, & - help_string="Target volume per cell used if do_rescale_r=T Unit is A^3.") - call param_register(params, "target_B", "0.0", target_B, has_value_target=has_target_B, & - help_string="Target bulk modulus used if do_rescale_E=T. Unit is GPa.") - - if(.not. param_read_line(params, my_args_str, ignore_unknown=.true.,task='Potential_Initialise args_str')) then - RAISE_ERROR("Potential_initialise failed to parse args_str='"//trim(my_args_str)//"'", error) - endif - call finalise(params) - - if (present(pot1) .and. len_trim(this%init_args_pot1) > 0) then - RAISE_ERROR("Potential_initialise got both pot and args_str with init_args_pot1 passed in, conflict", error) - endif - if (present(pot2) .and. len_trim(this%init_args_pot2) > 0) then - RAISE_ERROR("Potential_initialise got both pot2 and args_str with init_args_pot2 passed in, conflict", error) - endif - - if (len_trim(this%init_args_pot1) > 0) then - allocate(this%l_mpot1) - call initialise(this%l_mpot1, args_str=this%init_args_pot1, param_str=param_str, bulk_scale=bulk_scale, mpi_obj=mpi_obj, error=error) - PASS_ERROR_WITH_INFO("Initializing pot1", error) - u_pot1 => this%l_mpot1 - else - u_pot1 => pot1 - endif - if (len_trim(this%init_args_pot2) > 0) then - allocate(this%l_mpot2) - call initialise(this%l_mpot2, args_str=this%init_args_pot2, param_str=param_str, bulk_scale=bulk_scale, mpi_obj=mpi_obj, error=error) - PASS_ERROR_WITH_INFO("Initializing pot2", error) - u_pot2 => this%l_mpot2 - else - if (present(pot2)) then - u_pot2 => pot2 - else - nullify(u_pot2) - endif - endif - - if (present(mpi_obj)) this%mpi = mpi_obj - - this%is_simple = .not. any( (/ this%is_sum, this%is_forcemixing, this%is_evb & -#ifdef HAVE_LOCAL_E_MIX - , this%is_local_e_mix & -#endif -#ifdef HAVE_ONIOM - , this%is_oniom & -#endif - , this%is_cluster & - /) ) - - if (count( (/this%is_simple, this%is_sum, this%is_forcemixing, this%is_evb & -#ifdef HAVE_LOCAL_E_MIX - , this%is_local_e_mix & -#endif /* HAVE_LOCAL_E_MIX */ -#ifdef HAVE_ONIOM - , this%is_oniom & -#endif /* HAVE_ONIOM */ - , this%is_cluster & - /) ) /= 1) then - RAISE_ERROR("Potential_initialise found too few or two many Potential types args_str='"//trim(my_args_str)//"'", error) - end if - - if (this%is_simple) then - if (present(bulk_scale) .and. .not. has_target_vol .and. .not. has_target_B) call print("Potential_initialise Simple ignoring bulk_scale passed in", PRINT_ALWAYS) - - call initialise(this%simple, my_args_str, param_str, mpi_obj, error=error) - PASS_ERROR_WITH_INFO("Initializing pot", error) - else if (this%is_sum) then - if (present(bulk_scale)) call print("Potential_initialise Sum ignoring bulk_scale passed in", PRINT_ALWAYS) - - if (.not. associated(u_pot2)) then - RAISE_ERROR('Potential_initialise: two potentials needs for sum potential', error) - endif - - allocate(this%sum) - call initialise(this%sum, my_args_str, u_pot1, u_pot2, mpi_obj, error=error) - PASS_ERROR_WITH_INFO("Initializing sum", error) - - else if (this%is_forcemixing) then - - allocate(this%forcemixing) - if(associated(u_pot2)) then - call initialise(this%forcemixing, my_args_str, u_pot1, u_pot2, bulk_scale, mpi_obj, error=error) - else - ! if only one pot is given, assign it to QM. this is useful for time-embedding LOTF - call initialise(this%forcemixing, my_args_str, qmpot=u_pot1, reference_bulk=bulk_scale, mpi=mpi_obj, error=error) - endif - PASS_ERROR_WITH_INFO("Initializing forcemixing", error) - - else if (this%is_evb) then - if (present(bulk_scale)) call print("Potential_initialise EVB ignoring bulk_scale passed in", PRINT_ALWAYS) - - !1 is enough, everything is the same apart from the passed topology - if (associated(u_pot2)) then - call print('WARNING! Potential_initialise EVB ignoring u_pot2 (it will use u_pot1 twice)', PRINT_ALWAYS) - endif - - allocate(this%evb) - call initialise(this%evb, my_args_str, u_pot1, mpi_obj, error=error) - PASS_ERROR_WITH_INFO("Initializing evb", error) - -#ifdef HAVE_LOCAL_E_MIX - else if (this%is_local_e_mix) then - if (.not. associated(u_pot2)) then - RAISE_ERROR('Potential_initialise: two potentials needs for local_e_mix potential', error) - endif - - allocate(this%local_e_mix) - call initialise(this%local_e_mix, my_args_str, u_pot1, u_pot2, bulk_scale, mpi_obj, error=error) - PASS_ERROR_WITH_INFO("Initializing local_e_mix", error) -#endif /* HAVE_LOCAL_E_MIX */ -#ifdef HAVE_ONIOM - else if (this%is_oniom) then - if (.not. associated(u_pot2)) then - RAISE_ERROR('Potential_initialise: two potentials needs for oniom potential', error) - endif - - allocate(this%oniom) - call initialise(this%oniom, my_args_str, u_pot1, u_pot2, bulk_scale, mpi_obj, error=error) - PASS_ERROR_WITH_INFO("Initializing oniom", error) -#endif /* HAVE_ONIOM */ - - else if (this%is_cluster) then - allocate(this%cluster) - call initialise(this%cluster, my_args_str, u_pot1, mpi_obj, error=error) - PASS_ERROR_WITH_INFO("Initializing Cluster", error) - end if - - if (this%is_simple .and. (this%do_rescale_r .or. this%do_rescale_E)) then - if (this%do_rescale_r) then - if (.not. has_r_scale .and. .not. has_target_vol) then - RAISE_ERROR("potential_initialise: do_rescale_r=T but neither r_scale nor target_vol present", error) - end if - end if - if (this%do_rescale_E) then - if (.not. has_E_scale .and. .not. has_target_B) then - RAISE_ERROR("potential_initialise: do_rescale_E=T but neither E_scale nor target_B present", error) - end if - end if - - ! Automatic calculation of rescaling factors r_scale and E_scale to match target_vol and/or target_B - if (has_target_vol .or. has_target_B) then - if (.not. present(bulk_scale)) then - RAISE_ERROR("potential_initialise: target_vol or target_B present but no bulk_scale provided", error) - end if - - bulk = bulk_scale - call set_cutoff(bulk, cutoff(this)+1.0_dp) - call calc_connect(bulk) - if (minimise_bulk) then - call print("MINIMISING bulk in potential", PRINT_VERBOSE) - call verbosity_push_decrement() - it = minim(this, at=bulk, method='cg', convergence_tol=1e-6_dp, max_steps=100, linminroutine='NR_LINMIN', & - do_print = .false., do_lat = .true., args_str=args_str) - call verbosity_pop() - endif - - r_scale = 1.0_dp - if (this%do_rescale_r) then - vol = cell_volume(bulk) - r_scale = (vol/target_vol)**(1.0_dp/3.0_dp) - call print("do_rescale_r: original cell volume (from minim) is "//vol//" A^3") - call print("do_rescale_r: setting potential r_scale to "//r_scale//" to match target cell volume of "//target_vol//" A^3") - end if - - if (this%do_rescale_E) then - call bulk_modulus(this, bulk, B, vol, minimise_bulk, args_str=args_str) - this%E_scale = target_B/(B*r_scale**3) - call print("do_rescale_E: original cell volume (from quadratic fit) is "//vol//" A^3") - call print("do_rescale_E: original bulk modulus (from quadratic fit) is "//B//" GPa") - call print("do_rescale_E: setting potential E_scale to "//this%E_scale//" to match target bulk modulus of "//target_B//" GPa") - end if - - if (this%do_rescale_r) this%r_scale = r_scale - end if - end if - - end subroutine potential_initialise - - recursive subroutine potential_finalise(this, error) - type(Potential), intent(inout) :: this - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if (this%is_simple) then - call finalise(this%simple) - else if (this%is_sum) then - call finalise(this%sum) - deallocate(this%sum) - else if (this%is_forcemixing) then - call finalise(this%forcemixing) - deallocate(this%forcemixing) - else if (this%is_evb) then - call finalise(this%evb) - deallocate(this%evb) -#ifdef HAVE_LOCAL_E_MIX - else if (this%is_local_e_mix) then - call finalise(this%local_e_mix) - deallocate(this%local_e_mix) -#endif /* HAVE_LOCAL_E_MIX */ -#ifdef HAVE_ONIOM - else if (this%is_oniom) then - call finalise(this%oniom) - deallocate(this%oniom) -#endif /* HAVE_ONIOM */ - else if (this%is_cluster) then - call finalise(this%cluster) - deallocate(this%cluster) - end if - - if (associated(this%l_mpot1)) call finalise(this%l_mpot1) - if (associated(this%l_mpot2)) call finalise(this%l_mpot2) - nullify(this%l_mpot1) - nullify(this%l_mpot2) - - this%is_simple = .false. - this%is_sum = .false. - this%is_forcemixing = .false. - this%is_evb = .false. -#ifdef HAVE_LOCAL_E_MIX - this%is_local_e_mix = .false. -#endif -#ifdef HAVE_ONIOM - this%is_oniom = .false. -#endif - this%is_cluster = .false. - - end subroutine potential_finalise - - recursive subroutine potential_calc(this, at, energy, force, virial, local_energy, local_virial, args_str, error) - type(Potential), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: energy - real(dp), intent(out), optional :: force(:,:) - real(dp), intent(out), optional :: virial(3,3) - real(dp), intent(out), optional :: local_virial(:,:) - real(dp), intent(out), optional :: local_energy(:) - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:), at_local_virial_ptr(:,:) - type(Dictionary) :: params - character(len=STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, extra_args_str - character(len=STRING_LENGTH) :: use_calc_energy, use_calc_force, use_calc_virial, use_calc_local_energy, use_calc_local_virial - real(dp) :: r_scale, E_scale - logical :: has_r_scale, has_E_scale, do_calc_connect - integer i - - INIT_ERROR(error) - - calc_energy = "" - calc_virial = "" - calc_force = "" - calc_local_energy = "" - calc_local_virial = "" - - call initialise(params) - call param_register(params, "energy", "", calc_energy, help_string="If present, calculate energy and put it in field with this string as name") - call param_register(params, "virial", "", calc_virial, help_string="If present, calculate virial and put it in field with this string as name") - call param_register(params, "force", "", calc_force, help_string="If present, calculate force and put it in field with this string as name") - call param_register(params, "local_energy", "", calc_local_energy, help_string="If present, calculate local energy and put it in field with this string as name") - call param_register(params, "local_virial", "", calc_local_virial, help_string="If present, calculate local virial and put it in field with this string as name") - call param_register(params, "r_scale", "0.0", r_scale, has_value_target=has_r_scale, help_string="Distance rescale factor. Overrides r_scale init arg") - call param_register(params, "E_scale", "0.0", E_scale, has_value_target=has_E_scale, help_string="Energy rescale factor. Overrides E_scale init arg") - call param_register(params, "do_calc_connect", "T", do_calc_connect, help_string="Switch on/off automatic calc_connect() calls.") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Calc args_str')) then - RAISE_ERROR('Potential_Calc failed to parse args_str="'//trim(args_str)//'"', error) - endif - call finalise(params) - - if (cutoff(this) > 0.0_dp .and. do_calc_connect) then - ! For Potentials which need connectivity information, ensure Atoms cutoff is >= Potential cutoff - ! Also call calc_connect() to update connectivity information. This incurrs minimial overhead - ! if at%cutoff_skin is non-zero, as the full rebuild will only be done when atoms have moved sufficiently - if (at%cutoff < cutoff(this)) then - if (printed_cutoff_warning) call verbosity_push_decrement() - ! print warning unless cutoff was 0.0 or -1, these are defaults for "no cutoff", so probably no warning needed - if (at%cutoff /= 0.0_dp .and. at%cutoff /= -1.0_dp) then - call print_message('WARNING', 'Potential_calc: cutoff of Atoms object ('//at%cutoff//') < Potential cutoff ('//cutoff(this)//') - increasing it now') - end if - if (printed_cutoff_warning) call verbosity_pop() - printed_cutoff_warning = .true. - call set_cutoff(at, cutoff(this)) - end if - call calc_connect(at) - end if - - extra_args_str = "" - - ! create property/param names and possibly storage - use_calc_energy = trim(calc_energy) - if (present(energy) .and. len_trim(calc_energy) == 0) then ! have optional and no args_str - make new name for param - use_calc_energy = "energy" - do while (lookup_entry_i(at%params, trim(use_calc_energy)) > 0) - use_calc_energy = "T"//trim(use_calc_energy) - end do - extra_args_str = trim(extra_args_str) // " energy="//trim(use_calc_energy) - endif - - use_calc_force = trim(calc_force) - - if (present(force)) then - if (len_trim(calc_force) == 0) then ! have force optional but not args_str - add property from pointer in new property name - use_calc_force = "force" - do while (has_property(at, trim(use_calc_force))) - use_calc_force = "T"//trim(use_calc_force) - end do - extra_args_str = trim(extra_args_str) // " force="//trim(use_calc_force) - call add_property_from_pointer(at, trim(use_calc_force), force) - else ! has force optional _and_ args_str - add property with its own storage - call add_property(at, trim(calc_force), 0.0_dp, n_cols=3, ptr2=at_force_ptr) - endif - else if (len_trim(calc_force) > 0) then ! no optional, have args_str - add property with its own storage - call add_property(at, trim(calc_force), 0.0_dp, n_cols=3, ptr2=at_force_ptr) - endif - - use_calc_virial = trim(calc_virial) ! have optional and no args_str - make new name for param - if (present(virial) .and. len_trim(calc_virial) == 0) then - use_calc_virial = "virial" - do while (lookup_entry_i(at%params, trim(use_calc_virial)) > 0) - use_calc_virial = "T"//trim(use_calc_virial) - end do - extra_args_str = trim(extra_args_str) // " virial="//trim(use_calc_virial) - endif - - use_calc_local_energy = trim(calc_local_energy) - if (present(local_energy)) then - if (len_trim(calc_local_energy) == 0) then ! have local_energy optional but not args_str - add property from pointer in new property name - use_calc_local_energy = "local_energy" - do while (has_property(at, trim(use_calc_local_energy))) - use_calc_local_energy = "T"//trim(use_calc_local_energy) - end do - extra_args_str = trim(extra_args_str) // " local_energy="//trim(use_calc_local_energy) - call add_property_from_pointer(at, trim(use_calc_local_energy), local_energy) - else ! has local_energy optional _and_ args_str - add property with its own storage - call add_property(at, trim(calc_local_energy), 0.0_dp, n_cols=1, ptr=at_local_energy_ptr) - endif - else if (len_trim(calc_local_energy) > 0) then ! no optional, have args_str - add property with its own storage - call add_property(at, trim(calc_local_energy), 0.0_dp, n_cols=1, ptr=at_local_energy_ptr) - endif - - use_calc_local_virial = trim(calc_local_virial) - if (present(local_virial)) then - if (len_trim(calc_local_virial) == 0) then ! have local_virial optional but not args_str - add property from pointer in new property name - use_calc_local_virial = "local_virial" - do while (has_property(at, trim(use_calc_local_virial))) - use_calc_local_virial = "T"//trim(use_calc_local_virial) - end do - extra_args_str = trim(extra_args_str) // " local_virial="//trim(use_calc_local_virial) - call add_property_from_pointer(at, trim(use_calc_local_virial), local_virial) - else ! has local_virial optional _and_ args_str - add property with its own storage - call add_property(at, trim(calc_local_virial), 0.0_dp, n_cols=9, ptr2=at_local_virial_ptr) - endif - else if (len_trim(calc_local_virial) > 0) then ! no optional, have args_str - add property with its own storage - call add_property(at, trim(calc_local_virial), 0.0_dp, n_cols=9, ptr2=at_local_virial_ptr) - endif - - ! Set r_scale, E_scale in extra_args_str if not present in args_str - if (this%do_rescale_r .and. .not. has_r_scale) extra_args_str = trim(extra_args_str)//" r_scale="//this%r_scale - if (this%do_rescale_E .and. .not. has_E_scale) extra_args_str = trim(extra_args_str)//" E_scale="//this%E_scale - - ! do actual calculation using args_str - if (this%is_simple) then - call Calc(this%simple, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) - PASS_ERROR(error) - else if (this%is_sum) then - call Calc(this%sum, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) - PASS_ERROR(error) - else if (this%is_forcemixing) then - call Calc(this%forcemixing, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) - PASS_ERROR(error) - else if (this%is_evb) then - call Calc(this%evb, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) - PASS_ERROR(error) -#ifdef HAVE_LOCAL_E_MIX - else if (this%is_local_e_mix) then - call Calc(this%local_e_mix, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) - PASS_ERROR(error) -#endif /* HAVE_local_e_mix */ -#ifdef HAVE_ONIOM - else if (this%is_oniom) then - call Calc(this%oniom, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) - PASS_ERROR(error) -#endif /* HAVE_ONIOM */ - else if (this%is_cluster) then - call Calc(this%cluster, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) - PASS_ERROR(error) - else - RAISE_ERROR('Potential_Calc: no potential type is set',error) - endif - - ! get values from property/param if necessary, and remove temporary if only optional was passed in - if (present(energy)) then - call get_param_value(at, trim(use_calc_energy), energy) - if (len_trim(calc_energy) == 0) call remove_value(at%params, trim(use_calc_energy)) - endif - if (present(force)) then - if (len_trim(calc_force) == 0) then ! property should be a pointer to force optional - call remove_property(at, trim(use_calc_force)) - else - force = at_force_ptr - endif - endif - if (present(virial)) then - call get_param_value(at, trim(use_calc_virial), virial) - if (len_trim(calc_virial) == 0) call remove_value(at%params, trim(use_calc_virial)) - endif - if (present(local_energy)) then - if (len_trim(calc_local_energy) == 0) then ! property should be pointer to local_energy optional - call remove_property(at, trim(use_calc_local_energy)) - else - local_energy = at_local_energy_ptr - endif - endif - if (present(local_virial)) then - if (len_trim(calc_local_virial) == 0) then ! property should be pointer to local_virial optional - call remove_property(at, trim(use_calc_local_virial)) - else - local_virial = at_local_virial_ptr - endif - endif - - end subroutine potential_calc - - subroutine Potential_setup_parallel(this, at, args_str, error) - type(Potential), intent(inout) :: this - type(Atoms), intent(inout) :: at !% The atoms structure to compute energy and forces - character(len=*), intent(in) :: args_str - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(this%is_simple) then - call setup_parallel(this%simple, at, args_str) - endif - end subroutine Potential_setup_parallel - - recursive subroutine potential_print(this, file, dict, error) - type(Potential), intent(inout) :: this - type(Inoutput), intent(inout), optional :: file - type(Dictionary), intent(inout), optional :: dict - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if (this%is_simple) then - call Print('Potential containing potential') - call Print(this%simple, file=file, dict=dict) - else if (this%is_sum) then - call Print(this%sum, file=file,dict=dict) - else if (this%is_forcemixing) then - call Print(this%forcemixing, file=file) - else if (this%is_evb) then - call Print(this%evb, file=file) -#ifdef HAVE_LOCAL_E_MIX - else if (this%is_local_e_mix) then - call Print(this%local_e_mix, file=file) -#endif /* HAVE_LOCAL_E_MIX */ -#ifdef HAVE_ONIOM - else if (this%is_oniom) then - call Print(this%oniom, file=file) -#endif /* HAVE_ONIOM */ - else if (this%is_cluster) then - call Print(this%cluster, file=file) - else - RAISE_ERROR('Potential_Print: no potential type is set', error) - end if - end subroutine potential_print - - - recursive function potential_cutoff(this, error) - type(Potential), intent(in) :: this - integer, intent(out), optional :: error - real(dp) :: potential_cutoff - - INIT_ERROR(error) - - if (this%is_simple) then - potential_cutoff = cutoff(this%simple) - else if (this%is_sum) then - potential_cutoff = cutoff(this%sum) - else if (this%is_forcemixing) then - potential_cutoff = cutoff(this%forcemixing) - else if (this%is_evb) then - potential_cutoff = cutoff(this%evb) -#ifdef HAVE_LOCAL_E_MIX - else if (this%is_local_e_mix) then - potential_cutoff = cutoff(this%local_e_mix) -#endif /* HAVE_local_e_mix */ -#ifdef HAVE_ONIOM - else if (this%is_oniom) then - potential_cutoff = cutoff(this%oniom) -#endif /* HAVE_ONIOM */ - else if (this%is_cluster) then - potential_cutoff = cutoff(this%cluster) - else - RAISE_ERROR('Potential_Cutoff: no potential type is set', error) - end if - end function potential_cutoff - - - subroutine potential_set_calc_args_str(this, args_str, error) - type(Potential), intent(inout) :: this - character(len=*), intent(in) :: args_str - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(len_trim(args_str) > len(this%calc_args)) then - RAISE_ERROR('potential_set_calc_args_str: args_str longer than the avaiable calc_args field', error) - endif - - this%calc_args = trim(args_str) - - endsubroutine potential_set_calc_args_str - - function potential_get_calc_args_str(this, error) - type(Potential), intent(inout) :: this - integer, intent(out), optional :: error - character(len=STRING_LENGTH) :: potential_get_calc_args_str - - INIT_ERROR(error) - - if(len_trim(this%calc_args) > len(potential_get_calc_args_str)) then - RAISE_ERROR('potential_get_calc_args_str: calc_args field too long', error) - endif - - potential_get_calc_args_str = trim(this%calc_args) - - endfunction potential_get_calc_args_str - - !************************************************************************* - !* - !* Minimisation routines - !* - !************************************************************************* - - - function potential_minim(this, at, method, convergence_tol, max_steps, linminroutine, do_print, print_inoutput, print_cinoutput, & - do_pos, do_lat, args_str, eps_guess, fire_minim_dt0, fire_minim_dt_max, external_pressure, use_precond, & - hook_print_interval, error) - type(Potential), intent(inout), target :: this !% potential to evaluate energy/forces with - type(Atoms), intent(inout), target :: at !% starting configuration - character(*), intent(in) :: method !% passed to minim() - real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ - !% 'convergence_tol'. - integer, intent(in) :: max_steps !% Maximum number of steps - character(*), intent(in),optional :: linminroutine !% Name of the line minisation routine to use, passed to base minim() - logical, optional :: do_print !% if true, print configurations using minim's hook() - type(inoutput), intent(inout), optional, target :: print_inoutput !% inoutput object to print configs to, needed if do_print is true - type(cinoutput), intent(inout), optional, target :: print_cinoutput !% cinoutput object to print configs to, needed if do_print is true - logical, optional :: do_pos, do_lat !% do relaxation w.r.t. positions and/or lattice (if neither is included, do both) - character(len=*), intent(in), optional :: args_str !% arguments to pass to calc() - real(dp), intent(in), optional :: eps_guess !% eps_guess argument to pass to minim - real(dp), intent(in), optional :: fire_minim_dt0 !% if using fire minim, initial value for time step - real(dp), intent(in), optional :: fire_minim_dt_max !% if using fire minim, max value for time step - real(dp), dimension(3,3), optional :: external_pressure - logical, intent(in), optional :: use_precond - integer, intent(in), optional :: hook_print_interval !% how often to print xyz from hook function - integer, intent(out), optional :: error !% set to 1 if an error occurred during minimisation - integer::potential_minim - - character(len=100) :: use_method - - logical :: my_use_precond - integer n_iter, n_iter_tot - real(dp), allocatable :: x(:) - real(dp) :: deform_grad(3,3) - logical my_do_print - logical done - real(dp) :: my_eps_guess - real(dp) :: my_fire_minim_dt0, my_fire_minim_dt_max - - real(dp) :: initial_E, final_E, mass - type(potential_minimise) am - integer :: am_data_size - character, allocatable :: am_data(:) - character, dimension(1) :: am_mold - integer :: status - - INIT_ERROR(error) - - my_use_precond = optional_default(.false., use_precond) - - am_data_size = size(transfer(am, am_mold)) - allocate(am_data(am_data_size)) - - use_method = trim(method) - - my_fire_minim_dt0 = optional_default(1.0_dp, fire_minim_dt0) - my_fire_minim_dt_max = optional_default(20.0_dp, fire_minim_dt_max) - - my_eps_guess = optional_default(1.0e-2_dp/at%N, eps_guess) - if (my_eps_guess .feq. 0.0_dp) my_eps_guess = 1.0e-2_dp/at%N - - if (cutoff(this) > 0.0_dp) then - ! For Potentials which need connectivity information, ensure Atoms cutoff is >= Potential cutoff - ! Also call calc_connect() to update connectivity information. This incurrs minimial overhead - ! if at%cutoff_skin is non-zero, as the full rebuild will only be done when atoms have moved sufficiently - if (at%cutoff < cutoff(this)) then - if (printed_cutoff_warning) call verbosity_push_decrement() - ! print warning unless cutoff was 0.0 or -1, these are defaults for "no cutoff", so probably no warning needed - if (at%cutoff /= 0.0_dp .and. at%cutoff /= -1.0_dp) then - call print_message('WARNING', 'Potential_calc: cutoff of Atoms object ('//at%cutoff//') < Potential cutoff ('//cutoff(this)//') - increasing it now') - end if - if (printed_cutoff_warning) call verbosity_pop() - printed_cutoff_warning = .true. - call set_cutoff(at, cutoff(this)) - end if - call calc_connect(at) - end if - - am%minim_at => at - am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*am%minim_at%N - - if (present(args_str)) then - am%minim_args_str = args_str - else - am%minim_args_str = "" - endif - am%minim_pot => this - - if (.not.present(do_pos) .and. .not. present(do_lat)) then - am%minim_do_pos = .true. - am%minim_do_lat = .true. - else - am%minim_do_pos = optional_default(.false., do_pos) - am%minim_do_lat = optional_default(.false., do_lat) - endif - - am%external_pressure = 0.0_dp - if (present(external_pressure)) then - am%external_pressure = external_pressure - if( (am%external_pressure(1,1) .fne. am%external_pressure(2,2)) .or. & - & (am%external_pressure(1,1) .fne. am%external_pressure(3,3)) .or. & - & (am%external_pressure(1,2) .fne. 0.0_dp) .or. & - & (am%external_pressure(1,3) .fne. 0.0_dp) .or. & - & (am%external_pressure(2,1) .fne. 0.0_dp) .or. & - & (am%external_pressure(2,3) .fne. 0.0_dp) .or. & - & (am%external_pressure(3,1) .fne. 0.0_dp) .or. & - & (am%external_pressure(3,2) .fne. 0.0_dp) ) then - if(trim(use_method) /= 'fire') then - call print_message('WARNING', 'Anisotrpic pressure is being used. Switching to fire_minim.') - use_method = 'fire' - endif - endif - endif - - my_do_print = optional_default(.false., do_print) - - if (my_do_print .and. .not. present(print_inoutput) .and. .not. present(print_cinoutput)) & - call system_abort("potential_minim: do_print is true, but no print_inoutput or print_cinoutput present") - - if (my_do_print) then - if (present(print_cinoutput)) then - am%minim_cinoutput_movie => print_cinoutput - if (this%is_forcemixing) & - this%forcemixing%minim_cinoutput_movie => print_cinoutput -#ifdef HAVE_LOCAL_E_MIX - if (this%is_local_e_mix) & - this%local_e_mix%minim_cinoutput_movie => print_cinoutput -#endif /* HAVE_LOCAL_E_MIX */ -#ifdef HAVE_ONIOM - if (this%is_oniom) & - this%oniom%minim_cinoutput_movie => print_cinoutput -#endif /* HAVE_ONIOM */ - end if - else - nullify(am%minim_cinoutput_movie) - endif - - am%minim_n_eval_e = 0 - am%minim_n_eval_f = 0 - - allocate(x(9+am%minim_at%N*3)) - allocate(am%last_connect_x(size(x))) - am%last_connect_x=1.0e38_dp - deform_grad = 0.0_dp; call add_identity(deform_grad) - call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) - - am_data = transfer(am, am_data) - if (trim(use_method) == 'cg_n') then - n_iter = n_minim(x, both_func, my_use_precond, apply_precond_func, initial_E, final_E, my_eps_guess, max_steps, convergence_tol, print_hook, & - hook_print_interval=hook_print_interval, data=am_data, error=error) - PASS_ERROR(error) - else if (trim(use_method) == 'fire') then - if (has_property(at, 'mass')) then - mass = at%mass(1) - else - mass = ElementMass(at%Z(1)) - end if - n_iter = fire_minim(x, mass, dummy_energy_func, gradient_func, my_fire_minim_dt0, convergence_tol, max_steps, & - print_hook, hook_print_interval=hook_print_interval, data=am_data, dt_max=my_fire_minim_dt_max, status=status) - else - n_iter = minim(x, energy_func, gradient_func, use_method, convergence_tol, max_steps, linminroutine, & - print_hook, hook_print_interval=hook_print_interval, eps_guess=my_eps_guess, data=am_data, status=status) - endif - call print("minim relax w.r.t. both n_iter " // n_iter, PRINT_VERBOSE) - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - if(am%minim_at%cutoff > 0.0_dp) then - call calc_connect(am%minim_at) - end if - n_iter_tot = n_iter - done = .true. - deallocate(am%last_connect_x) - deallocate(x) - call print("MINIM_N_EVAL E " // am%minim_n_eval_e // " F " // am%minim_n_eval_f // & - " EF " // am%minim_n_eval_ef, PRINT_VERBOSE) - - potential_minim = n_iter_tot - - deallocate(am_data) - - end function potential_minim - - subroutine potential_test_local_virial(this, at, args_str) - type(Atoms), intent(inout), target :: at - type(Potential), target, intent(inout) :: this - character(len=*), intent(in), optional :: args_str - - real(dp) :: dx, r_ik - real(dp), dimension(3) :: diff_ik - real(dp), dimension(3,3) :: virial - real(dp), dimension(:), allocatable :: local_energy_p, local_energy_m - real(dp), dimension(:,:), allocatable :: tmp_local_virial, pos0 - real(dp), dimension(:,:,:), allocatable :: local_virial, local_virial_fd - - integer :: d, i, k, n, alpha - - call print_message('WARNING', "TLV: potential_test_local_virial: your cell has to be big enough so no multiple images are used for any atom.") - - if(at%cutoff < cutoff(this)) call set_cutoff(at,cutoff(this)) - - if(at%cutoff > 0.0_dp) then - call calc_connect(at) - end if - - allocate(tmp_local_virial(9,at%N), local_virial(3,3,at%N), local_virial_fd(3,3,at%N), & - local_energy_p(at%N), local_energy_m(at%N), pos0(3,at%N)) - - call calc(this,at,local_virial = tmp_local_virial, virial = virial) - local_virial = reshape(tmp_local_virial,(/3,3,at%N/)) - - call print("TLV: RMS difference between virial and local virial summed over atoms = "//sqrt( sum( (virial - sum(local_virial,dim=3))**2 ) )) - - pos0 = at%pos - - dx = 1.0_dp - - print"(a,a16,a20)", "TLV", "dx", "RMS" - do d = 1, 10 - dx = dx * 0.1_dp - local_virial_fd = 0.0_dp - - do i = 1, at%N - - do alpha = 1, 3 - at%pos(alpha,i) = pos0(alpha,i) + dx - if(at%cutoff > 0.0_dp) then - call calc_connect(at) - end if - call calc(this,at,local_energy=local_energy_p,args_str=args_str) - - at%pos(alpha,i) = pos0(alpha,i) - dx - if(at%cutoff > 0.0_dp) then - call calc_connect(at) - end if - call calc(this,at,local_energy=local_energy_m,args_str=args_str) - - at%pos(alpha,i) = pos0(alpha,i) - if(at%cutoff > 0.0_dp) then - call calc_connect(at) - end if - - do n = 1, n_neighbours(at,i) - k = neighbour(at,i,n,distance = r_ik, diff = diff_ik) - - if( r_ik > cutoff(this) ) cycle - - local_virial_fd(:,alpha,i) = local_virial_fd(:,alpha,i) + diff_ik * ( local_energy_p(k) - local_energy_m(k) ) / 2.0_dp / dx - enddo - enddo - enddo - - print"(a,f16.10,e20.10)", "TLV", dx, sqrt(sum((local_virial_fd - local_virial)**2)) - enddo - - endsubroutine potential_test_local_virial - - subroutine undo_travel(at) - type(Atoms), intent(inout) :: at - -! if (any(at%travel /= 0)) then -! at%pos = at%pos + (at%lattice .mult. at%travel) -! at%travel = 0 -! endif -end subroutine undo_travel - - ! test the gradient given a potential, string to pass to calc, and atoms structure - function pot_test_gradient(pot, at, do_pos, do_lat, args_str, dir_field) - type(Atoms), intent(inout), target :: at - type(Potential), target, intent(inout) :: pot - logical, intent(in), optional :: do_pos, do_lat - character(len=*), intent(in), optional :: args_str - character(len=*), intent(in), optional :: dir_field - logical pot_test_gradient - - real(dp) :: dg(3,3) - real(dp), allocatable :: x(:), dir_x(:) - real(dp), pointer :: dir_p(:,:) - integer :: am_data_size - type(potential_minimise) :: am - character, allocatable :: am_data(:) - character, dimension(1) :: am_mold - - am_data_size = size(transfer(am, am_mold)) - allocate(am_data(am_data_size)) - - pot_test_gradient = .true. - - if (present(args_str)) then - am%minim_args_str = args_str - else - am%minim_args_str = "" - endif - am%minim_pot => pot - - ! neither do_pos not do_lat is specified, so do both by default - if (.not. present(do_pos) .and. .not. present(do_lat)) then - am%minim_do_pos= .true. - am%minim_do_lat= .true. - else ! something is specified, so do exactly that - am%minim_do_pos = optional_default(.false., do_pos) - am%minim_do_lat = optional_default(.false., do_lat) - endif - - am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*at%N - - if (present(dir_field)) then - if (.not. assign_pointer(at, trim(dir_field), dir_p)) & - call system_abort("pot_test_gradient got dir_field '"//trim(dir_field)//"' but can't assign pointer to it") - call print("pot_test_gradient using '"//trim(dir_field)//"' field for gradient test direction") - else - nullify(dir_p) - endif - - am%minim_at => at - allocate(x(at%N*3+9)) - allocate(am%last_connect_x(at%N*3+9)) - am%last_connect_x=1.0e38_dp - dg = 0.0_dp; call add_identity(dg) - call pack_pos_dg(at%pos, dg, x, am%pos_lat_preconditioner_factor) - if (associated(dir_p)) then - allocate(dir_x(at%N*3+9)) - dg = 0.0_dp - call pack_pos_dg(dir_p, dg, dir_x, am%pos_lat_preconditioner_factor) - endif - am_data = transfer(am, am_data) - if (associated(dir_p)) then - pot_test_gradient = test_gradient(x, energy_func, gradient_func, dir=dir_x, data=am_data) - else - pot_test_gradient = test_gradient(x, energy_func, gradient_func, data=am_data) - endif - deallocate(x) - if (allocated(dir_x)) deallocate(dir_x) - deallocate(am%last_connect_x) - - deallocate(am_data) - - end function pot_test_gradient - - ! test the gradient given a potential, string to pass to calc, and atoms structure - subroutine pot_n_test_gradient(pot, at, do_pos, do_lat, args_str, dir_field) - type(Potential), target, intent(inout) :: pot - type(Atoms), intent(inout), target :: at - logical, intent(in), optional :: do_pos, do_lat - character(len=*), intent(in), optional :: args_str - character(len=*), intent(in), optional :: dir_field - - real(dp), allocatable :: x(:), dir_x(:) - real(dp), pointer :: dir_p(:,:) - real(dp) :: dg(3,3) - integer :: am_data_size - type(potential_minimise) :: am - character, allocatable :: am_data(:) - character, dimension(1) :: am_mold - - am_data_size = size(transfer(am, am_mold)) - allocate(am_data(am_data_size)) - - if (present(args_str)) then - am%minim_args_str = args_str - else - am%minim_args_str = "" - endif - am%minim_pot => pot - - ! neither do_pos not do_lat is specified, so do both by default - if (.not. present(do_pos) .and. .not. present(do_lat)) then - am%minim_do_pos= .true. - am%minim_do_lat= .true. - else ! something is specified, so do exactly that - am%minim_do_pos = optional_default(.false., do_pos) - am%minim_do_lat = optional_default(.false., do_lat) - endif - - am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*at%N - - if (present(dir_field)) then - if (.not. assign_pointer(at, trim(dir_field), dir_p)) & - call system_abort("pot_test_gradient got dir_field '"//trim(dir_field)//"' but can't assign pointer to it") - call print("pot_test_gradient using '"//trim(dir_field)//"' field for gradient test direction") - else - nullify(dir_p) - endif - - am%minim_at => at - allocate(x(at%N*3+9)) - allocate(am%last_connect_x(at%N*3+9)) - am%last_connect_x=1.0e38_dp - dg = 0.0_dp; call add_identity(dg) - call pack_pos_dg(at%pos, dg, x, am%pos_lat_preconditioner_factor) - if (associated(dir_p)) then - allocate(dir_x(at%N*3+9)) - dg = 0.0_dp - call pack_pos_dg(dir_p, dg, dir_x, am%pos_lat_preconditioner_factor) - endif - am_data = transfer(am, am_data) - if (associated(dir_p)) then - call n_test_gradient(x, energy_func, gradient_func, data=am_data, dir=dir_x) - else - call n_test_gradient(x, energy_func, gradient_func, data=am_data) - endif - deallocate(x) - if (allocated(dir_x)) deallocate(dir_x) - deallocate(am%last_connect_x) - - deallocate(am_data) - - end subroutine pot_n_test_gradient - - ! hook for minim to print configuration during position relaxation - subroutine print_hook(x,dx,E,done,do_print,am_data) - real(dp), intent(in) :: x(:), dx(:) - real(dp), intent(in) :: E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character, intent(in), optional :: am_data(:) - - real(dp), allocatable :: f(:,:) - real(dp), pointer :: f_p(:,:) - integer, pointer, dimension(:) :: hybrid_mark - real(dp) :: virial(3,3), deform_grad(3,3), deform_grad_inv(3,3) - type(potential_minimise) :: am - logical :: my_do_print - - if (.not. present(am_data)) call system_abort("potential_minimise print_hook must have am_data") - my_do_print = optional_default(.true., do_print) - - am = transfer(am_data, am) - ! beware of transfer and pointers !!! - call atoms_repoint(am%minim_at) - - if (associated(am%minim_cinoutput_movie)) then - if (size(x) /= am%minim_at%N*3+9) call system_abort("Called gradient_func() with size mismatch " // & - size(x) // " /= " // am%minim_at%N // "*3+9") - - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - - allocate(f(3,am%minim_at%N)) - f = reshape(dx(10:), (/3,am%minim_at%N/)) - f = transpose(deform_grad) .mult. f - - virial = reshape(dx(1:9), (/3,3/) ) - call inverse(deform_grad, deform_grad_inv) - virial = virial .mult. transpose(deform_grad_inv) - - ! Set atom parameters to print energy, maxforce and maxvirial - call set_value(am%minim_at%params, 'E', E) - if (am%minim_do_pos) then - call set_value(am%minim_at%params, 'MaxForce', maxval(norm(f,1))) - call set_value(am%minim_at%params, 'df2', normsq(reshape(f,(/3*am%minim_at%N/)))) - - - if (am%minim_pot%is_forcemixing) then - !NB This should really be an arbitrary field name, but no obvious way to pass print_hook info on what - !NB the name is (no run_suffix args_str argument, for example) - if (assign_pointer(am%minim_at, 'hybrid_mark', hybrid_mark)) then - if (.not. am%minim_pot%forcemixing%minimise_mm) then - call set_value(am%minim_at%params, 'QM_MaxForce', & - maxval(abs(f(:,find(hybrid_mark == HYBRID_ACTIVE_MARK))))) - - call set_value(am%minim_at%params, 'QM_df2', & - normsq(reshape(f(:,find(hybrid_mark == HYBRID_ACTIVE_MARK)),& - (/3*count(hybrid_mark == HYBRID_ACTIVE_MARK)/)))) - - end if - end if - end if - - end if - - if (am%minim_do_lat) & - call set_value(am%minim_at%params, 'MaxVirial', maxval(abs(virial))) - - if (assign_pointer(am%minim_at, "forces", f_p)) f_p = -f - if (assign_pointer(am%minim_at, "force", f_p)) f_p = -f ! compatibility with crack program - - if (my_do_print) then - if (associated(am%minim_cinoutput_movie)) then - if (trim(am%minim_cinoutput_movie%filename) == "stdout") then - if (.not. am%minim_pot%mpi%active .or. (am%minim_pot%mpi%active .and. am%minim_pot%mpi%my_proc == 0)) & - call write(am%minim_cinoutput_movie, am%minim_at, prefix="MINIM_TRAJ") - else - if (.not. am%minim_pot%mpi%active .or. (am%minim_pot%mpi%active .and. am%minim_pot%mpi%my_proc == 0)) & - call write(am%minim_cinoutput_movie, am%minim_at) - end if - end if - end if - - deallocate(f) - call fix_atoms_deform_grad(deform_grad, am%minim_at,am) - endif - done = .false. - - end subroutine print_hook - - function dummy_energy_func(xx, am_data) - real(dp) :: xx(:) - character(len=1), optional :: am_data(:) - real(dp) :: dummy_energy_func - - dummy_energy_func = 0.0_dp - - end function dummy_energy_func - - - ! compute energy - function energy_func(x, am_data) - real(dp) :: x(:) - character(len=1), optional :: am_data(:) - real(dp) :: energy_func - - real(dp) :: max_atom_rij_change - real(dp) :: deform_grad(3,3) - type(potential_minimise) :: am - real(dp), pointer :: minim_applied_force(:,:) - - call system_timer("energy_func") - - if (.not. present(am_data)) call system_abort("potential_minimise energy_func must have am_data") - am = transfer(am_data, am) - call atoms_repoint(am%minim_at) - - am%minim_n_eval_e = am%minim_n_eval_e + 1 - - if (size(x) /= am%minim_at%N*3+9) call system_abort("Called energy_func() with size mismatch " // & - size(x) // " /= " // am%minim_at%N // "*3+9") - - ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter - max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & - 1.0_dp/am%pos_lat_preconditioner_factor) - - call print("energy_func got x " // x, PRINT_NERD) - - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - - ! Safety factor of 1.1, just in case - ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter - if (1.1*max_atom_rij_change >= am%minim_at%cutoff - cutoff(am%minim_pot)) then - call print("gradient_func: Do calc_connect, atoms moved " // max_atom_rij_change // & - "*1.1 >= buffer " // (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) - if(am%minim_at%cutoff > 0.0_dp) then - call calc_connect(am%minim_at) - end if - am%last_connect_x = x - else - call print("gradient_func: Do calc_dists, atoms moved " // max_atom_rij_change // & - " *1.1 < buffer " // (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) - call calc_dists(am%minim_at) - end if - - call print("energy_func using am%minim_at", PRINT_NERD) - if (current_verbosity() >= PRINT_NERD) call write(am%minim_at, 'stdout') - - call calc(am%minim_pot, am%minim_at, energy = energy_func, args_str = am%minim_args_str) - call print ("energy_func got energy " // energy_func, PRINT_NERD) - - energy_func = energy_func + cell_volume(am%minim_at)*trace(am%external_pressure) / 3.0_dp - call print ("energy_func got enthalpy " // energy_func, PRINT_NERD) - - ! add extra forces - if (assign_pointer(am%minim_at, "minim_applied_force", minim_applied_force)) then - energy_func = energy_func - sum(minim_applied_force*am%minim_at%pos) - end if - - call fix_atoms_deform_grad(deform_grad, am%minim_at, am) - call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) - - am_data = transfer(am, am_data) - - call system_timer("energy_func") - - end function energy_func - - ! compute gradient (forces and virial) - ! x is vectorized version of atomic positions - ! result is vectorized version of forces - function gradient_func(x, am_data) - real(dp) :: x(:) - character(len=1), optional :: am_data(:) - real(dp) :: gradient_func(size(x)) - - real(dp) :: deform_grad(3,3), virial(3,3), deform_grad_inv(3,3) - real(dp), allocatable :: f(:,:) - real(dp) :: max_atom_rij_change - integer :: t_i(2), i, j - integer, pointer, dimension(:) :: move_mask, fixed_pot - integer, pointer, dimension(:,:) :: move_mask_3 - real(dp), pointer :: minim_applied_force(:,:) - - type(potential_minimise) :: am - - call system_timer("gradient_func") - - if (.not. present(am_data)) call system_abort("potential_minimise gradient_func must have am_data") - am = transfer(am_data, am) - ! beware of transfer and pointers !!! - call atoms_repoint(am%minim_at) - - am%minim_n_eval_e = am%minim_n_eval_e + 1 - - am%minim_n_eval_f = am%minim_n_eval_f + 1 - - if (size(x) /= am%minim_at%N*3+9) call system_abort("Called gradient_func() with size mismatch " // & - size(x) // " /= " // am%minim_at%N // "*3+9") - - ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter - max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & - 1.0_dp/am%pos_lat_preconditioner_factor) - - if (current_verbosity() >= PRINT_NERD) call print("gradient_func got x " // x, PRINT_NERD) - - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - - ! Safety factor of 1.1, just in case - ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter - if (1.1*max_atom_rij_change >= am%minim_at%cutoff - cutoff(am%minim_pot)) then - call print("gradient_func: Do calc_connect, atoms moved " // max_atom_rij_change // & - "*1.1 >= buffer " // (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) - if(am%minim_at%cutoff > 0.0_dp) then - call calc_connect(am%minim_at) - end if - am%last_connect_x = x - else - call print("gradient_func: Do calc_dists, atoms moved " // max_atom_rij_change // & - " *1.1 < buffer " // (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) - call calc_dists(am%minim_at) - end if - - if (current_verbosity() >= PRINT_NERD) call add_property(am%minim_at, "force", 0.0_dp, 3) - - allocate(f(3,am%minim_at%N)) - f = 0.0_dp - virial = 0.0_dp - if (am%minim_do_pos .and. am%minim_do_lat) then - call calc(am%minim_pot, am%minim_at, force = f, virial = virial, args_str = am%minim_args_str) - else if (am%minim_do_pos) then - call calc(am%minim_pot, am%minim_at, force = f, args_str = am%minim_args_str) - else - call calc(am%minim_pot, am%minim_at, virial = virial, args_str = am%minim_args_str) - endif - - call print("gradient_func used am%minim_at, got forces", PRINT_NERD) - if (current_verbosity() >= PRINT_NERD) call write(am%minim_at,'stdout') - - ! zero forces if fixed by potential - if (am%minim_do_pos .and. assign_pointer(am%minim_at, "fixed_pot", fixed_pot)) then - do i=1, am%minim_at%N - if (fixed_pot(i) /= 0) f(:,i) = 0.0_dp - end do - endif - - ! Zero force on any fixed atoms - if (assign_pointer(am%minim_at, 'move_mask', move_mask)) then - do i=1,am%minim_at%N - if (move_mask(i) == 0) f(:,i) = 0.0_dp - end do - endif - if (assign_pointer(am%minim_at, 'move_mask_3', move_mask_3)) then - do i=1,am%minim_at%N - do j=1, 3 - if (move_mask_3(j,i) == 0) f(j,i) = 0.0_dp - end do - end do - end if - - ! add extra forces - if (assign_pointer(am%minim_at, "minim_applied_force", minim_applied_force)) then - f = f + minim_applied_force - ! val = val - sum(minim_applied_force*am%minim_at%pos) - endif - - if (current_verbosity() >= PRINT_NERD) then - call print ("gradient_func got f", PRINT_NERD) - call print(f, PRINT_NERD) - call print ("gradient_func got virial", PRINT_NERD) - call print(virial, PRINT_NERD) - end if - virial = virial - am%external_pressure*cell_volume(am%minim_at) - - if (current_verbosity() >= PRINT_NERD) then - call print ("gradient_func got virial, external pressure subtracted", PRINT_NERD) - call print(virial, PRINT_NERD) - end if - - f = transpose(deform_grad) .mult. f - - call constrain_virial(am%minim_at, virial) - - call inverse(deform_grad, deform_grad_inv) - virial = virial .mult. transpose(deform_grad_inv) - - call pack_pos_dg(-f, -virial, gradient_func, 1.0_dp/am%pos_lat_preconditioner_factor) - if (current_verbosity() >= PRINT_NERD) then - call print ("gradient_func packed as", PRINT_NERD) - call print (gradient_func, PRINT_NERD) - endif - - t_i = maxloc(abs(f)) - call print ("gradient_func got max force component " // f(t_i(1),t_i(2)) // " on atom " // t_i(2) // & - " max virial component " // maxval(abs(virial))) - - deallocate(f) - - call fix_atoms_deform_grad(deform_grad, am%minim_at,am) - call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) - am_data = transfer(am, am_data) - - call system_timer("gradient_func") - - end function gradient_func - -! Cristoph Ortner's simple Hessian preconditioner, dense matrix inverse right now - subroutine apply_precond_func(x,g,P_g,am_data,error) - real(dp) :: x(:), g(:), P_g(:) - character(len=1), optional :: am_data(:) - integer, optional :: error - - type(potential_minimise) :: am - real(dp) :: deform_grad(3,3) - real(dp), allocatable :: P(:,:) - real(dp) :: c0, c1 - integer :: i, jj, j - real(dp) :: max_atom_rij_change - integer :: n_nearest - integer, pointer :: move_mask(:), move_mask_3(:,:) - - INIT_ERROR(error) - - am = transfer(am_data, am) - call atoms_repoint(am%minim_at) - - max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & - 1.0_dp/am%pos_lat_preconditioner_factor) - !max_atom_rij_change = 1.038_dp !FIXME this line shouldn't be here either - - call print("apply_precond_func got x " // x, PRINT_NERD) - - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - - ! Safety factor of 1.1, just in case - ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter - if (1.1*max_atom_rij_change >= am%minim_at%cutoff - cutoff(am%minim_pot)) then - call print("apply_precond_func: Do calc_connect, atoms moved " // max_atom_rij_change // "*1.1 >= buffer " // & - (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) - if(am%minim_at%cutoff > 0.0_dp) then - call calc_connect(am%minim_at) - end if - am%last_connect_x = x - else - call print("apply_precond_func: Do calc_dists, atoms moved " // max_atom_rij_change // " *1.1 < buffer " // & - (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) - call calc_dists(am%minim_at) - end if - - ! identity - ! c0 = 1.0_dp - ! c1 = 0.0_dp - ! simplest expression of connectivity - c0 = 0.01_dp - c1 = 1.0_dp - - allocate(P(3*am%minim_at%N,3*am%minim_at%N)) - P = 0.0_dp - do i=1, am%minim_at%N - n_nearest = 0 - do jj=1, n_neighbours(am%minim_at, i) - if (is_nearest_neighbour(am%minim_at, i, jj)) then - n_nearest = n_nearest + 1 - j = neighbour(am%minim_at, i, jj) - P(3*(i-1)+1,3*(j-1)+1) = -c1 - P(3*(i-1)+2,3*(j-1)+2) = -c1 - P(3*(i-1)+3,3*(j-1)+3) = -c1 - endif - end do - P(3*(i-1)+1,3*(i-1)+1) = c0+c1*n_nearest - P(3*(i-1)+2,3*(i-1)+2) = c0+c1*n_nearest - P(3*(i-1)+3,3*(i-1)+3) = c0+c1*n_nearest - end do - - if (assign_pointer(am%minim_at, 'move_mask', move_mask)) then - do i=1,am%minim_at%N - if (move_mask(i) == 0) then - P(3*(i-1)+1:3*(i-1)+3,:) = 0.0_dp - P(:,3*(i-1)+1:3*(i-1)+3) = 0.0_dp - P(3*(i-1)+1,3*(i-1)+1) = 1.0_dp - P(3*(i-1)+2,3*(i-1)+2) = 1.0_dp - P(3*(i-1)+3,3*(i-1)+3) = 1.0_dp - endif - end do - endif - if (assign_pointer(am%minim_at, 'move_mask_3', move_mask_3)) then - do i=1,am%minim_at%N - do j=1, 3 - if (move_mask_3(j,i) == 0) then - P(3*(i-1)+j:3*(i-1)+j,:) = 0.0_dp - P(:,3*(i-1)+j:3*(i-1)+j) = 0.0_dp - P(3*(i-1)+j,3*(i-1)+j) = 1.0_dp - endif - end do - end do - endif - - P_g(1:9) = g(1:9) - call symmetric_linear_solve(P, g(10:10+am%minim_at%N*3-1), P_g(10:10+am%minim_at%N*3-1)) - - end subroutine apply_precond_func - ! compute energy and gradient (forces and virial) - ! x is vectorized version of atomic positions - ! result is vectorized version of forces - subroutine both_func(x,val,grad,am_data,error) - real(dp) :: x(:) - real(dp) :: val - real(dp) :: grad(:) - character(len=1), optional :: am_data(:) - integer, optional :: error - - real(dp) :: deform_grad(3,3), virial(3,3), deform_grad_inv(3,3) - real(dp), allocatable :: f(:,:) - real(dp) :: max_atom_rij_change - integer :: t_i(2), i, j - integer, pointer, dimension(:) :: move_mask, fixed_pot - integer, pointer, dimension(:,:) :: move_mask_3 - real(dp), pointer :: minim_applied_force(:,:) - - type(potential_minimise) :: am - - real(dp) :: hack_restraint_E, hack_restraint_F(3), dr - - INIT_ERROR(error) - - call system_timer("both_func") - - if (.not. present(am_data)) call system_abort("potential_minimise both_func must have am_data") - am = transfer(am_data, am) - ! beware of transfer and pointers !!! - call atoms_repoint(am%minim_at) - - am%minim_n_eval_ef = am%minim_n_eval_ef + 1 - - if (size(x) /= am%minim_at%N*3+9) call system_abort("Called both_func() with size mismatch " // & - size(x) // " /= " // am%minim_at%N // "*3+9") - - ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter - max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & - 1.0_dp/am%pos_lat_preconditioner_factor) - !max_atom_rij_change = 1.038_dp ! FIXME this line shouldn't be here, right? - - call print("both_func got x " // x, PRINT_NERD) - - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - - ! Safety factor of 1.1, just in case - ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter - if (1.1*max_atom_rij_change >= am%minim_at%cutoff - cutoff(am%minim_pot)) then - call print("both_func: Do calc_connect, atoms moved " // max_atom_rij_change // "*1.1 >= buffer " // & - (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) - if(am%minim_at%cutoff > 0.0_dp) then - call calc_connect(am%minim_at) - end if - am%last_connect_x = x - else - call print("both_func: Do calc_dists, atoms moved " // max_atom_rij_change // " *1.1 < buffer " // & - (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) - call calc_dists(am%minim_at) - end if - - call print("both_func using am%minim_at", PRINT_NERD) - if (current_verbosity() >= PRINT_NERD) call write(am%minim_at,'stdout') - - allocate(f(3,am%minim_at%N)) - f = 0.0_dp - virial = 0.0_dp - if (am%minim_do_pos .and. am%minim_do_lat) then - call calc(am%minim_pot, am%minim_at, energy = val, force = f, virial = virial, args_str = am%minim_args_str) - else if (am%minim_do_pos) then - call calc(am%minim_pot, am%minim_at, energy = val, force = f, args_str = am%minim_args_str) - else - call calc(am%minim_pot, am%minim_at, energy = val, virial = virial, args_str = am%minim_args_str) - endif - -if (am%minim_do_pos) then - if (all(hack_restraint_i > 0) .and. all(hack_restraint_i <= am%minim_at%n)) then - call print("hack_restraint i "//hack_restraint_i// " k " // hack_restraint_k // " r " // hack_restraint_r, PRINT_ALWAYS) - dr = distance_min_image(am%minim_at, hack_restraint_i(1), hack_restraint_i(2)) - hack_restraint_E = 0.5_dp * hack_restraint_k*(dr - hack_restraint_r)**2 - val = val + hack_restraint_E - hack_restraint_F = hack_restraint_k*(dr - hack_restraint_r)*diff_min_image(am%minim_at, hack_restraint_i(1), hack_restraint_i(2))/dr - call print("hack_restraint dr-r "//(dr-hack_restraint_r)//"E "//hack_restraint_E// " F " // hack_restraint_F, PRINT_ALWAYS) - f(:,hack_restraint_i(1)) = f(:,hack_restraint_i(1)) + hack_restraint_F - f(:,hack_restraint_i(2)) = f(:,hack_restraint_i(2)) - hack_restraint_F - endif -endif - - if (assign_pointer(am%minim_at, "minim_applied_force", minim_applied_force)) then - f = f + minim_applied_force - val = val - sum(minim_applied_force*am%minim_at%pos) - endif - - call print ("both_func got f", PRINT_NERD) - call print(f, PRINT_NERD) - call print ("both_func got virial", PRINT_NERD) - call print(virial, PRINT_NERD) - - virial = virial - am%external_pressure*cell_volume(am%minim_at) - call print ("both_func got virial, external pressure subtracted", PRINT_NERD) - call print(virial, PRINT_NERD) - - val = val + cell_volume(am%minim_at)*trace(am%external_pressure) / 3.0_dp - call print ("both_func got enthalpy " // val, PRINT_NERD) - ! zero forces if fixed by potential - if (am%minim_do_pos .and. assign_pointer(am%minim_at, "fixed_pot", fixed_pot)) then - do i=1, am%minim_at%N - if (fixed_pot(i) /= 0) f(:,i) = 0.0_dp - end do - endif - - ! Zero force on any fixed atoms - if (assign_pointer(am%minim_at, 'move_mask', move_mask)) then - do i=1,am%minim_at%N - if (move_mask(i) == 0) f(:,i) = 0.0_dp - end do - end if - if (assign_pointer(am%minim_at, 'move_mask_3', move_mask_3)) then - do i=1,am%minim_at%N - do j=1, 3 - if (move_mask_3(j,i) == 0) f(j,i) = 0.0_dp - end do - end do - end if - - f = transpose(deform_grad) .mult. f - - call constrain_virial(am%minim_at, virial) - - call inverse(deform_grad, deform_grad_inv) - virial = virial .mult. transpose(deform_grad_inv) - - call pack_pos_dg(-f, -virial, grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call print ("both_func gradient packed as", PRINT_NERD) - call print (grad, PRINT_NERD) - - t_i = maxloc(abs(f)) - call print ("both_func got max force component " // f(t_i(1),t_i(2)) // " on atom " // t_i(2) // & - " max virial component " // maxval(abs(virial))) - - deallocate(f) - - call fix_atoms_deform_grad(deform_grad, am%minim_at,am) - call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) - - am_data = transfer(am, am_data) - - call system_timer("both_func") - - end subroutine both_func - - function max_rij_change(last_connect_x, x, r_cut, lat_factor) - real(dp), intent(inout) :: last_connect_x(:) - real(dp), intent(in) :: x(:) - real(dp), intent(in) :: r_cut, lat_factor - real(dp) :: max_rij_change - - real(dp) :: F0(3,3), F0_evals(3), dF(3,3), dF_evals(3) - - call print("max_rij_change, size(last_connect_x) " // size(last_connect_x) // & - " size(x) " // size(x), PRINT_NERD) - if (size(last_connect_x) == size(x)) then - F0 = lat_factor*reshape(last_connect_x(1:9), (/ 3,3 /)) - dF = lat_factor*reshape(x(1:9), (/ 3,3 /)) - F0 - call diagonalise(matmul(F0,transpose(F0)), F0_evals) - call diagonalise(matmul(dF,transpose(dF)), dF_evals) - F0_evals = sqrt(F0_evals) - dF_evals = sqrt(dF_evals) - call print("max_rij_change = " // maxval(abs(F0_evals)) //"*2.0_dp*"// & - maxval(abs(last_connect_x-x))*sqrt(3.0_dp) // & - " + " // maxval(abs(dF_evals))//"*"//r_cut, PRINT_VERBOSE) - max_rij_change = maxval(abs(F0_evals))*2.0_dp*maxval(abs(last_connect_x-x))*sqrt(3.0_dp) + & - maxval(abs(dF_evals))*r_cut - else - call system_abort("max_rij_change: size(last_connect_x)="//size(last_connect_x)// & - " /= size(x)="//size(x)) - endif - - end function max_rij_change - - ! prepare atoms structure given a deformation gradient matrix - subroutine prep_atoms_deform_grad(deform_grad, at, am) - real(dp), intent(in) :: deform_grad(3,3) - type(Atoms), intent(inout) :: at - type(potential_minimise), intent(inout) :: am - - am%minim_save_lat = at%lattice - call set_lattice(at, deform_grad .mult. am%minim_save_lat, scale_positions=.true.) - end subroutine prep_atoms_deform_grad - - ! remove effect of deformation gradient applied by prep_atoms_deform_grad - subroutine fix_atoms_deform_grad(deform_grad, at,am) - real(dp), intent(in) :: deform_grad(3,3) - type(Atoms), intent(inout) :: at - type(potential_minimise), intent(inout) :: am - - real(dp) :: deform_grad_inv(3,3) - - call inverse(deform_grad, deform_grad_inv) - at%pos = deform_grad_inv .mult. at%pos - call set_lattice(at, am%minim_save_lat, scale_positions=.false.) - - end subroutine fix_atoms_deform_grad - - ! unpack a deformation grad and a pos array from 1-D array into a atoms%pos 2-D array - subroutine unpack_pos_dg(xx, at_N, at_pos, dg, lat_factor) - real(dp), intent(in) :: xx(:) - integer :: at_N - real(dp), intent(inout) :: at_pos(:,:) - real(dp) :: dg(3,3) - real(dp), intent(in) :: lat_factor - - if (3*at_N+9 /= size(xx)) call system_abort("Called unpack_pos with mismatching sizes x " // size(xx) // " at " // at_N) - - dg = lat_factor*reshape(xx(1:9), (/ 3,3 /) ) - at_pos = reshape(xx(10:), (/ 3, at_N /) ) - -end subroutine unpack_pos_dg - - ! pack a 3xN 2-D array into a 1-D array - subroutine pack_pos_dg(x2d, dg2d, x, lat_factor) - real(dp), intent(in) :: x2d(:,:) - real(dp), intent(in) :: dg2d(3,3) - real(dp), intent(out) :: x(:) - real(dp), intent(in) :: lat_factor - - if (size(x2d,1) /= 3) call system_abort("Called pack with mismatching size(x2d,1) " // & - size(x2d,1) // " != 3") - - if (size(dg2d,1) /= 3 .or. size(dg2d,2) /= 3) & - call system_abort("Called pack with mismatching size(dg2d,1) " // shape(dg2d) // " != 3x3") - if (size(x) /= (size(x2d)+size(dg2d))) & - call system_abort("Called pack with mismatching size x " // size(x) // " x2d " // size(x2d) // & - " dg2d " // size(dg2d)) - - x(1:9) = lat_factor*reshape(dg2d, (/ 9 /) ) - - x(10:) = reshape(x2d, (/ size(x2d) /) ) - -end subroutine pack_pos_dg - - subroutine Potential_read_params_xml(this, param_str) - type(Potential), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) & - call system_abort('Potential_read_params_xml: invalid param_str length '//len(trim(param_str)) ) - - parse_in_pot = .false. - parse_in_pot_done = .false. - parse_matched_label = .false. - parse_pot => this - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = Potential_startElement_handler, & - endElement_handler = Potential_endElement_handler) - call close_xml_t(fxml) - - if(.not. parse_in_pot_done) then - if (len_trim(param_str) > 10000) then - call system_abort('Potential_read_params_xml: could not initialise potential from xml_label. param_str(1:10000)='//trim(param_str(1:10000))) - else - call system_abort('Potential_read_params_xml: could not initialise potential from xml_label. param_str='//trim(param_str)) - endif - endif - - endsubroutine Potential_read_params_xml - - subroutine Potential_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=STRING_LENGTH) :: value - - if(name == 'Potential') then ! new Potential stanza - - if(parse_in_pot) & - call system_abort("Potential_startElement_handler entered with parse_in true. Probably a forgotten /> at the end of a tag.") - - if(parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if(status /= 0) value = '' - - if(len(trim(parse_pot%xml_label)) > 0) then ! we were passed in a label - if(trim(value) == trim(parse_pot%xml_label)) then ! exact match - parse_matched_label = .true. - parse_in_pot = .true. - else ! no match - parse_in_pot = .false. - endif - else ! no label passed in - call system_abort("Potential_startElement_handler: no label passed in") - endif - - call QUIP_FoX_get_value(attributes, 'init_args', value, status) - if(status == 0) then - read (value, '(a)') parse_pot%xml_init_args - else - call system_abort("Potential_startElement_handler: no init_args attribute found") - endif - - endif - - endsubroutine Potential_startElement_handler - - subroutine Potential_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if(parse_in_pot) then - if(name == 'Potential') then - parse_in_pot = .false. - parse_in_pot_done = .true. - endif - endif - - endsubroutine Potential_endElement_handler - - subroutine potential_set_callback(this, callback) - type(Potential), intent(inout) :: this - interface - subroutine callback(at) - integer, intent(in) :: at(12) - end subroutine callback - end interface - - if (this%is_simple) then - call set_callback(this%simple, callback) - else - call system_abort('potential_set_callback() only implemented for simple Potentials.') - end if - - end subroutine potential_set_callback - -#ifdef HAVE_TB - !% Calculate TB Hamiltonian and overlap matrices and optionally their derivatives wrt atomic positions. - !% This always triggers a force calculation, since the elements for dH and dS are assembled on the fly for each atom. - subroutine potential_calc_TB_matrices(this, at, args_str, Hd, Sd, Hz, Sz, dH, dS, index) - type(Potential), intent(inout) :: this - type(atoms), intent(inout) :: at !% Atomic structure to use for TB matrix calculation - character(len=*), intent(in), optional :: args_str !% Additional arguments to pass to TB `calc()` routine - real(dp), intent(inout), optional, dimension(:,:) :: Hd, Sd !% Hamiltonian and overlap for real wavefunctions (gamma point) - complex(dp), intent(inout), optional, dimension(:,:) :: Hz, Sz !% Complex Hamiltonian and overlap (multiple kpoints) - real(dp), intent(inout), optional, dimension(:,:,:,:) :: dH, dS !% Derivative of H and S wrt atomic positiions. Shape is `(3, N_atoms, N_elecs, N_elecs)` - integer, optional, intent(in) :: index - - if (this%is_simple) then - call calc_TB_matrices(this%simple, at, args_str, Hd, Sd, Hz, Sz, dH, dS, index=index) - else - call system_abort('potential_calc_TB_matrices() only implemented for simple Potentials.') - end if - - end subroutine potential_calc_TB_matrices -#endif - -#include "Potential_Sum_routines.f95" -#include "Potential_ForceMixing_routines.f95" -#include "Potential_EVB_routines.f95" - -#ifdef HAVE_LOCAL_E_MIX -#include "Potential_Local_E_Mix_routines.f95" -#endif -#ifdef HAVE_ONIOM -#include "Potential_ONIOM_routines.f95" -#endif - -#include "Potential_Cluster_routines.f95" -#include "Potential_Hybrid_utils.f95" - - - !% Run 'n_steps' of dynamics using forces from Potential 'pot'. - !% - !% For each step, forces are evaluated using the Potential - !% 'pot' and the DynamicalSystem is advanced by a time 'dt' - !% (default 1 fs). 'n_steps' (default 10 steps) are carried out in - !% total, with snapshots saved every 'save_interval' steps. The - !% connectivity is recalculated every 'connect_interval' steps. - !% 'args_str' can be used to supply extra arguments to 'Potential%calc'. - subroutine DynamicalSystem_run(this, pot, dt, n_steps, hook, hook_interval, summary_interval, write_interval, trajectory, args_str, error) - type(DynamicalSystem), intent(inout), target :: this - type(Potential), intent(inout) :: pot - real(dp), intent(in) :: dt - integer, intent(in) :: n_steps - integer, intent(in), optional :: summary_interval, hook_interval, write_interval - type(CInOutput), intent(inout), optional :: trajectory - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - interface - subroutine hook() - end subroutine hook - end interface - - integer :: n, my_summary_interval, my_hook_interval, my_write_interval - real(dp) :: e - real(dp), pointer, dimension(:,:) :: f - character(len=STRING_LENGTH) :: my_args_str - type(Dictionary) :: params - - INIT_ERROR(error) - - my_summary_interval = optional_default(1, summary_interval) - my_hook_interval = optional_default(1, hook_interval) - my_write_interval = optional_default(1, write_interval) - my_args_str = optional_default("", args_str) - call initialise(params) - call read_string(params, my_args_str) - if (.not. has_key(params, 'energy')) call set_value(params, 'energy') - if (.not. has_key(params, 'force')) call set_value(params, 'force') - my_args_str = write_string(params) - call finalise(params) - - call calc(pot, this%atoms, args_str=my_args_str, error=error) - PASS_ERROR(error) - call set_value(this%atoms%params, 'time', this%t) - if (.not. get_value(this%atoms%params, 'energy', e)) & - call system_abort("dynamicalsystem_run failed to get energy") - if (.not. assign_pointer(this%atoms, 'force', f)) & - call system_abort("dynamicalsystem_run failed to get forces") - if (my_summary_interval > 0) call ds_print_status(this, epot=e) - call hook() - if (present(trajectory)) call write(trajectory, this%atoms) - - ! initialize accelerations from forces, so first call to verlet1 will be correct - this%atoms%acc(1,:) = f(1,:)/this%atoms%mass - this%atoms%acc(2,:) = f(2,:)/this%atoms%mass - this%atoms%acc(3,:) = f(3,:)/this%atoms%mass - - do n=1,n_steps - call advance_verlet1(this, dt) - call calc(pot, this%atoms, args_str=my_args_str, error=error) - PASS_ERROR(error) - call advance_verlet2(this, dt, f) - if (.not. get_value(this%atoms%params, 'energy', e)) & - call system_abort("dynamicalsystem_run failed to get energy") - if (.not. assign_pointer(this%atoms, 'force', f)) & - call system_abort("dynamicalsystem_run failed to get forces") - if (my_summary_interval > 0 .and. mod(n, my_summary_interval) == 0) call ds_print_status(this, epot=e) - call set_value(this%atoms%params, 'time', this%t) - - if (my_hook_interval > 0 .and. mod(n,my_hook_interval) == 0) call hook() - if (present(trajectory) .and. my_write_interval > 0 .and. mod(n,my_write_interval) == 0) call write(trajectory, this%atoms) - if (cutoff(pot) > 0.0_dp .and. this%atoms%cutoff > 0.0_dp) call calc_connect(this%atoms) - end do - - end subroutine DynamicalSystem_run - - subroutine constrain_DG(at, deform_grad) - type(Atoms), intent(in) :: at - real(dp), intent(inout) :: deform_grad(3,3) - - logical :: minim_constant_volume - real(dp) :: scaled_ident(3,3), DG_det - integer :: error - - minim_constant_volume = .false. - call get_param_value(at, "Minim_Constant_Volume", minim_constant_volume, error=error) - - ! zero out trace component, which changes volume - if (minim_constant_volume) then - DG_det = matrix3x3_det(deform_grad) - scaled_ident = 0.0_dp - call add_identity(scaled_ident) - scaled_ident = scaled_ident * (DG_det**(-1.0/3.0)) - deform_grad = matmul(deform_grad, scaled_ident) - endif - end subroutine constrain_DG - - subroutine constrain_virial(at, virial) - type(Atoms), intent(in) :: at - real(dp), intent(inout) :: virial(3,3) - - integer :: error - logical :: minim_hydrostatic_strain, minim_constant_volume - logical :: minim_lattice_fix_mask(3,3) - real(dp) :: minim_lattice_fix(3,3) - real(dp) :: scaled_ident - - real(dp) :: virial_trace - - minim_hydrostatic_strain = .false. - call get_param_value(at, "Minim_Hydrostatic_Strain", minim_hydrostatic_strain, error=error) - CLEAR_ERROR(error) - - minim_lattice_fix = 0.0_dp - call get_param_value(at, "Minim_Lattice_Fix", minim_lattice_fix, error=error) - CLEAR_ERROR(error) - minim_lattice_fix_mask = (minim_lattice_fix /= 0.0_dp) - - minim_constant_volume = .false. - call get_param_value(at, "Minim_Constant_Volume", minim_constant_volume, error=error) - CLEAR_ERROR(error) - - ! project onto identity - if (minim_hydrostatic_strain) then - virial_trace = trace(virial) - virial = 0.0_dp - virial(1,1) = virial_trace/3.0_dp - virial(2,2) = virial_trace/3.0_dp - virial(3,3) = virial_trace/3.0_dp - endif - ! Zero out components corresponding to fixed lattice elements - if (any(minim_lattice_fix_mask)) then - virial = merge(0.0_dp, virial, minim_lattice_fix_mask) - end if - - if (minim_constant_volume) then - virial_trace = virial(1,1) + virial(2,2) + virial(3,3) - virial(1,1) = virial(1,1) - virial_trace/3.0 - virial(2,2) = virial(2,2) - virial_trace/3.0 - virial(3,3) = virial(3,3) - virial_trace/3.0 - endif - - end subroutine constrain_virial - - - -end module Potential_module diff --git a/src/Potentials/Potential_Cluster_header.f95 b/src/Potentials/Potential_Cluster_header.f95 deleted file mode 100644 index 758d7d2caa..0000000000 --- a/src/Potentials/Potential_Cluster_header.f95 +++ /dev/null @@ -1,65 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Cluster header stuff to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - public :: Potential_Cluster - type Potential_Cluster - type(Potential), pointer :: inner_pot - real(dp):: r_scale_pot1 = 1.0_dp, E_scale_pot1 = 1.0_dp - character(STRING_LENGTH) :: run_suffix - - end type Potential_Cluster - - interface Print - module procedure potential_cluster_print - end interface Print - - interface Cutoff - module procedure potential_cluster_cutoff - end interface Cutoff - - interface Calc - module procedure potential_cluster_calc - end interface Calc - - interface Initialise - module procedure potential_cluster_initialise - end interface Initialise - - interface Finalise - module procedure potential_cluster_finalise - end interface Finalise diff --git a/src/Potentials/Potential_Cluster_routines.f95 b/src/Potentials/Potential_Cluster_routines.f95 deleted file mode 100644 index 58d9b16170..0000000000 --- a/src/Potentials/Potential_Cluster_routines.f95 +++ /dev/null @@ -1,163 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Cluster routines to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - recursive subroutine potential_Cluster_initialise(this, args_str, inner_pot, mpi_obj, error) - type(Potential_Cluster), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(Potential), intent(inout), target :: inner_pot - type(MPI_Context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(Dictionary) :: params - logical :: minimise_bulk - logical :: do_rescale_r, do_rescale_E, do_tb_defaults - - INIT_ERROR(error) - - call initialise(params) - call param_register(params, "run_suffix", "", this%run_suffix, help_string="Suffix to apply to hybrid mark properties$") - call param_register(params, "r_scale", "1.0", this%r_scale_pot1, help_string="Rescaling factor for cluster positions") - call param_register(params, "E_scale", "1.0", this%E_scale_pot1, help_string="Rescaling factor for cluster energies (and hence also forces)") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Cluster_initialise args_str') ) then - RAISE_ERROR("Potential_Cluster_initialise failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - - if (this%r_scale_pot1 <= 0.0_dp) this%r_scale_pot1 = 1.0_dp - if (this%E_scale_pot1 <= 0.0_dp) this%E_scale_pot1 = 1.0_dp - - call print ("Rescaling positions in region1 potential by " // this%r_scale_pot1 // " to match lattice constants") - call print ("Rescaling energies in region1 potential by " // this%E_scale_pot1 // " to match bulk modulus") - - this%inner_pot => inner_pot - - end subroutine - - recursive subroutine potential_Cluster_finalise(this) - type(Potential_Cluster), intent(inout) :: this - - nullify(this%inner_pot) - - end subroutine potential_Cluster_finalise - - - recursive function potential_Cluster_cutoff(this) - type(Potential_Cluster), intent(in) :: this - real(dp) :: potential_Cluster_cutoff - - potential_Cluster_cutoff = cutoff(this%inner_pot) - - end function potential_Cluster_cutoff - - recursive subroutine potential_Cluster_print(this, file) - type(Potential_Cluster), intent(inout) :: this - type(Inoutput),intent(inout),optional:: file - - call print('Cluster potential:', file=file) - call print('Inner Potential:', file=file) - call print('================', file=file) - call print(this%inner_pot, file=file) - call print('') - call print('r_scale_pot1=' // this%r_scale_pot1 // ' E_scale_pot1=' // this%E_scale_pot1, file=file) - call print('') - end subroutine potential_Cluster_print - - - recursive subroutine potential_Cluster_calc(this, at, args_str, error) - type(Potential_Cluster), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - type(Dictionary) :: params - character(STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, run_suffix - logical single_cluster, little_clusters - - INIT_ERROR(error) - - if (.not. associated(this%inner_pot)) then - RAISE_ERROR("Potential_Cluster_calc: this%inner_pot", error) - endif - - call initialise(params) - call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "energy", "", calc_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "force", "", calc_force, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "virial", "", calc_virial, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "local_energy", "", calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "local_virial", "", calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'single_cluster', 'F', single_cluster, & - help_string="If true, calculate all active/transition atoms with a single big cluster") - call param_register(params, 'little_clusters', 'F', little_clusters, & - help_string="If true, calculate forces (only) by doing each atom separately surrounded by a little buffer cluster") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Cluster_Calc args_str') ) then - RAISE_ERROR("Potential_Cluster_calc_energy failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - - if (len_trim(calc_energy) /= 0 .or. len_trim(calc_local_energy) /= 0 .or. & - len_trim(calc_virial) /= 0 .or. len_trim(calc_local_virial) /= 0) then - RAISE_ERROR("Potential_Cluster_calc: can only calculate forces, not energies or virials", error) - end if - - if (single_cluster .and. little_clusters) then - RAISE_ERROR('Potential_Cluster_calc: single_cluster and little_clusters options are mutually exclusive', error) - end if - - end subroutine potential_Cluster_calc - - - subroutine calc_single_cluster(this, at, args_str, error) - type(Potential_Cluster), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - INIT_ERROR(error) - - end subroutine calc_single_cluster - - subroutine calc_little_clusters(this, at, args_str, error) - type(Potential_Cluster), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - INIT_ERROR(error) - - end subroutine calc_little_clusters diff --git a/src/Potentials/Potential_EVB_header.f95 b/src/Potentials/Potential_EVB_header.f95 deleted file mode 100644 index 9b0dbc10ce..0000000000 --- a/src/Potentials/Potential_EVB_header.f95 +++ /dev/null @@ -1,46 +0,0 @@ - - public :: Potential_EVB - type Potential_EVB - type(MPI_context) :: mpi - - type(Potential), pointer :: pot1 => null() !% The underlying MM potential, pot1 and pot2 - - character(STRING_LENGTH) :: mm_args_str !% Args string to be passed to 'calc' method of pot1 and pot2 - - character(STRING_LENGTH) :: topology_suffix1 !% Suffix in topology filename, to be added to mm_args_str of pot1 - character(STRING_LENGTH) :: topology_suffix2 !% Suffix in topology filename, to be added to mm_args_str of pot2 - - integer :: form_bond(2) !% Atom pair that is bonded in EVB1 only - integer :: break_bond(2) !% Atom pair that is bonded in EVB2 only - - real(dp) :: diagonal_dE2 !% The energy offset to E2 - real(dp) :: offdiagonal_A12 !% The offdiagonal pre-exponent factor of EVB Hamiltonian - real(dp) :: offdiagonal_mu12 !% The offdiagonal exponent factor of the EVB Hamiltonian - real(dp) :: offdiagonal_mu12_square !% The offdiagonal exponent factor of the EVB Hamiltonian: A exp(-mu12(r-r0)-mu12_square(r-r0)^2) - real(dp) :: offdiagonal_r0 !% The offdiagonal exponent of the EVB Hamiltonian - - logical :: save_forces !% Whether to save forces from the 2 MM calculations in the Atoms object (needed for force on E_GAP) - logical :: save_energies !% Whether to save energies from the 2 MM calculations in the Atoms object (needed for E_GAP) - - end type Potential_EVB - - interface Initialise - module procedure Potential_EVB_Initialise - end interface - - interface Finalise - module procedure Potential_EVB_Finalise - end interface - - interface Print - module procedure Potential_EVB_Print - end interface - - interface Cutoff - module procedure Potential_EVB_Cutoff - end interface - - interface Calc - module procedure Potential_EVB_Calc - end interface - diff --git a/src/Potentials/Potential_EVB_routines.f95 b/src/Potentials/Potential_EVB_routines.f95 deleted file mode 100644 index 768f40ac43..0000000000 --- a/src/Potentials/Potential_EVB_routines.f95 +++ /dev/null @@ -1,400 +0,0 @@ - - !************************************************************************* - !* - !* Potential_EVB routines - !* - !************************************************************************* - - recursive subroutine Potential_EVB_Initialise(this, args_str, pot1, mpi, error) - type(Potential_EVB), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(Potential), intent(in), target :: pot1 - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - !Only 1 potential for the 2 MM calculations - this%pot1 => pot1 - - call initialise(params) - call param_register(params, 'mm_args_str', '', this%mm_args_str, help_string="Argumentum string to be passed on to the underlying MM potential(s) of the EVB method.") - call param_register(params, 'topology_suffix1', '_EVB1', this%topology_suffix1, help_string="Suffix of the first topology file of the EVB method.") - call param_register(params, 'topology_suffix2', '_EVB2', this%topology_suffix2, help_string="Suffix of the second topology file of the EVB method.") - call param_register(params, 'form_bond', '0 0', this%form_bond, help_string="Which bond to form in the first topology and break in the second topology used in the EVB calculation.") - call param_register(params, 'break_bond', '0 0', this%break_bond, help_string="Which bond to break in the first topology and form in the second topology used in the EVB calculation.") - call param_register(params, 'diagonal_dE2', '0.0', this%diagonal_dE2, help_string="Energy offset between the energy minima of the two topologies of the EVB method.") - call param_register(params, 'offdiagonal_A12', '0.0', this%offdiagonal_A12, help_string="A12 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") - call param_register(params, 'offdiagonal_mu12', '0.0', this%offdiagonal_mu12, help_string="mu12 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") - call param_register(params, 'offdiagonal_mu12_square', '0.0', this%offdiagonal_mu12_square, help_string="mu12_square parameter of the coupling parameter A12*exp(-mu12*r0-mu12_square*r0**2.0).") - call param_register(params, 'offdiagonal_r0', '0.0', this%offdiagonal_r0, help_string="r0 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") - call param_register(params, 'save_forces', 'T', this%save_forces, help_string="Whether to save forces in atoms%params as EVB1_$forces$ EVB2_$forces$ if $forces$ is given when calling calc.") - call param_register(params, 'save_energies', 'T', this%save_energies, help_string="Whether to save energies in atoms%params as EVB1_$energy$ and EVB2_$energy$ if $energy$ is given when calling calc.") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_EVB_initialise args_str')) then - RAISE_ERROR('Potential_EVB_initialise failed to parse args_str="'//trim(args_str)//'"', error) - endif - call finalise(params) - - if (present(mpi)) this%mpi = mpi - - end subroutine Potential_EVB_Initialise - - recursive subroutine Potential_EVB_Finalise(this) - type(Potential_EVB), intent(inout) :: this - - nullify(this%pot1) - - this%mm_args_str = "" - this%topology_suffix1 = "" - this%topology_suffix2 = "" - this%form_bond(1:2) = 0 - this%break_bond(1:2) = 0 - this%diagonal_dE2 = 0._dp - this%offdiagonal_A12 = 0._dp - this%offdiagonal_mu12 = 0._dp - this%offdiagonal_mu12_square = 0._dp - this%offdiagonal_r0 = 0._dp - this%save_forces = .false. - this%save_energies = .false. - - end subroutine Potential_EVB_Finalise - - recursive subroutine Potential_EVB_Print(this, file) - type(Potential_EVB), intent(inout) :: this - type(Inoutput), intent(inout), optional :: file - - call print('Potential_EVB:', file=file) - call print(' mm_args_str='//trim(this%mm_args_str), file=file) - call print(' topology_suffix1='//trim(this%topology_suffix1), file=file) - call print(' topology_suffix2='//trim(this%topology_suffix2), file=file) - call print(' evb1-form and evb2-break bond: '//this%form_bond(1:2), file=file) - call print(' evb1-break and evb2-form bond: '//this%break_bond(1:2), file=file) - call print(' diagonal E2(shift to E2): '//this%diagonal_dE2, file=file) - call print(' offdiagonal A12(pre-exponent factor): '//this%offdiagonal_A12, file=file) - call print(' offdiagonal mu12(exponent factor): '//this%offdiagonal_mu12, file=file) - call print(' offdiagonal mu12_square(exponent factor): '//this%offdiagonal_mu12_square, file=file) - call print(' offdiagonal r0(exponent): '//this%offdiagonal_r0, file=file) - call print(' save_forces: '//this%save_forces, file=file) - call print(' save_energies: '//this%save_energies, file=file) - call print('', file=file) - if (associated(this%pot1)) then - call print('Potential 1:', file=file) - call print(this%pot1, file=file) - call print('', file=file) - else - call print('Potential 1 not initialised', file=file) - call print('', file=file) - end if - call print('Potential 2: same as Potential 1', file=file) - call print('', file=file) - - end subroutine Potential_EVB_Print - - recursive subroutine Potential_EVB_Calc(this, at, args_str, error) - type(Potential_EVB), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - real(dp) :: e, virial - real(dp), pointer :: at_force_ptr(:,:), dgap_dr_ptr(:,:) - - real(dp) :: gap, term1 - type(Dictionary) :: params - character(STRING_LENGTH) :: mm_args_str - character(STRING_LENGTH) :: topology_suffix1, topology_suffix2 - integer :: form_bond(2), break_bond(2), atom1, atom3 - logical :: have_form_bond, have_break_bond - - logical :: save_energies, save_forces - real(dp) :: my_e_1, my_e_2, e_offdiag - real(dp), allocatable :: my_f_1(:,:), my_f_2(:,:), de_offdiag_dr(:,:) - real(dp) :: offdiagonal_A12, offdiagonal_r0, offdiagonal_mu12, offdiagonal_mu12_square, diagonal_dE2, & - rab, d_rab_dx(3) - logical :: no_coupling, dummy - character(STRING_LENGTH) :: extra_calc_args - - character(STRING_LENGTH) :: psf_print - character(STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, calc_EVB_gap - character(STRING_LENGTH) :: use_calc_energy - character(STRING_LENGTH) :: new_args_str - - INIT_ERROR(error) - - !read args_str - call initialise(params) - call param_register(params, 'mm_args_str', ''//this%mm_args_str, mm_args_str, help_string="Argumentum string to be passed on to the underlying MM potential(s) of the EVB method.") - call param_register(params, 'topology_suffix1', ''//this%topology_suffix1, topology_suffix1, help_string="Suffix of the first topology file of the EVB method.") - call param_register(params, 'topology_suffix2', ''//this%topology_suffix2, topology_suffix2, help_string="Suffix of the second topology file of the EVB method.") - call param_register(params, 'form_bond', ''//this%form_bond, form_bond, help_string="Which bond to form in the first topology and break in the second topology used in the EVB calculation.") - call param_register(params, 'break_bond', ''//this%break_bond, break_bond, help_string="Which bond to break in the first topology and form in the second topology used in the EVB calculation.") - call param_register(params, 'diagonal_dE2', ''//this%diagonal_dE2, diagonal_dE2, help_string="Energy offset between the energy minima of the two topologies of the EVB method.") - call param_register(params, 'offdiagonal_A12', ''//this%offdiagonal_A12, offdiagonal_A12, help_string="A12 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") - call param_register(params, 'offdiagonal_mu12', ''//this%offdiagonal_mu12, offdiagonal_mu12, help_string="mu12 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") - call param_register(params, 'offdiagonal_mu12_square', ''//this%offdiagonal_mu12_square, offdiagonal_mu12_square, help_string="mu12_square parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") - call param_register(params, 'offdiagonal_r0', ''//this%offdiagonal_r0, offdiagonal_r0, help_string="r0 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") - call param_register(params, 'save_forces', ''//this%save_forces, save_forces, help_string="Whether to save forces in atoms%params as EVB1_$forces$ EVB2_$forces$ if $forces$ is given when calling calc.") - call param_register(params, 'save_energies', ''//this%save_energies, save_energies, help_string="Whether to save energies in atoms%params as EVB1_$energy$ and EVB2_$energy$ if $energy$ is given when calling calc.") - call param_register(params, 'energy', '', calc_energy, help_string="Under what name to save the EVB energies (EVB1_$energy$ and EVB2_$energy$) in atoms%params.") - call param_register(params, 'force', '', calc_force, help_string="Under what name to save the EVB forces (EVB1_$force$ and EVB2_$force$) in atoms%data.") - call param_register(params, 'virial', '', calc_virial, help_string="Whether to calculate virial. This option is not supported in EVB calculations.$") - call param_register(params, 'local_energy', '', calc_local_energy, help_string="Whether to calculate local energy. This option is not supported in EVB calculations.") - call param_register(params, 'local_virial', '', calc_local_virial, help_string="Whether to calculate local virial. This option is not supported in EVB calculations.") - call param_register(params, 'EVB_gap', '', calc_EVB_gap, help_string="Under what name to save the EVB gap energy in atoms%params. Forces on the gap energy will be saved in $EVB_gap$_force property.") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_EVB_calc args_str')) then - RAISE_ERROR('Potential_EVB_calc failed to parse args_str="'//trim(args_str)//'"', error) - endif - call finalise(params) - - !CHECK ARGUMENTS - - if (len_trim(calc_virial) > 0 .or. len_trim(calc_local_energy) > 0 .or. len_trim(calc_local_virial) > 0) then - RAISE_ERROR('Potential_EVB_calc: supports only energy and forces, not virial, local_energy or local_virial', error) - endif - - if (len_trim(calc_force) > 0) then - call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) - PASS_ERROR_WITH_INFO("Potential_EVB_Calc assigning pointer for force property '"//trim(calc_force)//"'", error) - endif - - !coupling parameters - if (offdiagonal_A12 .feq. 0._dp) then - call print('WARNING! Offdiagonal A12 is set to 0. No coupling between resonance states.') - no_coupling = .true. - else - if (offdiagonal_A12 < 0._dp .or. offdiagonal_mu12 < 0._dp .or. offdiagonal_mu12_square < 0._dp .or. offdiagonal_r0 < 0._dp ) then - RAISE_ERROR('Potential_EVB_calc offdiagonal parameters must be positive or 0 for no coupling. Got offdiagonal_A12: '//offdiagonal_A12 //' and offdiagonal_mu12: '//offdiagonal_mu12//' and offdiagonal_mu12_square: '//offdiagonal_mu12_square//' and offdiagonal_r0: '//offdiagonal_r0, error) - endif - no_coupling = .false. - endif - - !form_bond - have_form_bond = .true. - if(any(form_bond<1) .or. any(form_bond>at%N)) then - !check whether all 0 (skip) - if (all(form_bond==0)) then - have_form_bond = .false. - else - RAISE_ERROR('Potential_EVB_calc form_bond is out of range 1--'//at%N//': '//form_bond, error) - endif - endif - - !break_bond - have_break_bond = .true. - if(any(break_bond<1) .or. any(break_bond>at%N)) then - !check whether all 0 (skip) - if (all(break_bond==0)) then - have_break_bond = .false. - else - RAISE_ERROR('Potential_EVB_calc break_bond is out of range 1--'//at%N//': '//break_bond, error) - endif - endif - - if (.not.(have_form_bond .or. have_break_bond)) then - RAISE_ERROR('Potential_EVB_calc no bonds to form neither to break. ', error) - endif - - !CALCULATE E,F WITH DIFFERENT TOPOLOGIES - - ! allocate local arrays - if (len_trim(calc_force) > 0) then - allocate(my_f_1(3,at%N)) - allocate(my_f_2(3,at%N)) - allocate(de_offdiag_dr(3,at%N)) - endif - - ! SETUP CALC_ARGS, AND CALL CALC FOR TOPOLOGY 1 - ! topology suffix - extra_calc_args="topology_suffix="//trim(topology_suffix1) - ! add energy= arg if needed - use_calc_energy=trim(calc_energy) - if (len_trim(calc_energy) == 0) then - use_calc_energy="energy" - do while (has_key(at%params, trim(use_calc_energy))) - use_calc_energy = "T"//trim(use_calc_energy) - end do - endif - extra_calc_args=trim(extra_calc_args)//" energy="//trim(use_calc_energy) - if (len_trim(calc_force) > 0) extra_calc_args=trim(extra_calc_args)//" force="//trim(calc_force) - ! add args to form/break bonds for topology 1 - if (have_form_bond) extra_calc_args=trim(extra_calc_args)//" form_bond={"//form_bond(1:2)//"}" - if (have_break_bond) extra_calc_args=trim(extra_calc_args)//" break_bond={"//break_bond(1:2)//"}" - !calc with topology1 -call print("EVB1 ARGS_STR "//trim(mm_args_str)//" "//trim(extra_calc_args)) - call calc(this%pot1, at, args_str=trim(mm_args_str)//" "//trim(extra_calc_args), error=error) - PASS_ERROR(error) - - call get_param_value(at, trim(use_calc_energy), my_e_1, error=error) - PASS_ERROR_WITH_INFO("getting energy parameter '"//trim(use_calc_energy)//"' for topology 1", error) - if (len_trim(calc_energy) == 0) call remove_value(at%params, trim(use_calc_energy)) - if (len_trim(calc_force) > 0) my_f_1 = at_force_ptr - - ! SETUP CALC_ARGS, AND CALL CALC FOR TOPOLOGY 2 - ! topology suffix - extra_calc_args="topology_suffix="//trim(topology_suffix2) - ! add energy and force args if needed - use_calc_energy=trim(calc_energy) - if (len_trim(calc_energy) == 0) then - use_calc_energy="energy" - do while (has_key(at%params, trim(use_calc_energy))) - use_calc_energy = "T"//trim(use_calc_energy) - end do - endif - extra_calc_args=trim(extra_calc_args)//" energy="//trim(use_calc_energy) - if (len_trim(calc_force) > 0) extra_calc_args=trim(extra_calc_args)//" force="//trim(calc_force) - ! form/break bonds for topology 2 - if (have_form_bond) extra_calc_args=trim(extra_calc_args)//" break_bond={"//form_bond(1:2)//"}" - if (have_break_bond) extra_calc_args=trim(extra_calc_args)//" form_bond={"//break_bond(1:2)//"}" - !calc with topology2 -call print("EVB2 ARGS_STR "//trim(mm_args_str)//" "//trim(extra_calc_args)) - call calc(this%pot1, at, args_str=trim(mm_args_str)//" "//trim(extra_calc_args), error=error) - PASS_ERROR(error) - - call get_param_value(at, trim(use_calc_energy), my_e_2, error=error) - PASS_ERROR_WITH_INFO("getting energy parameter '"//trim(use_calc_energy)//"' for topology 2", error) - my_e_2 = my_e_2 + diagonal_dE2 - if (len_trim(calc_energy) == 0) call remove_value(at%params, trim(use_calc_energy)) - if (len_trim(calc_force) > 0) my_f_2 = at_force_ptr - - call print("EVB energies my_e_1 " // my_e_1 // " " // my_e_2, PRINT_VERBOSE) - - !CALCULATE EVB ENERGY AND FORCES - - !distance or distance difference - if (no_coupling) then - call print("EVB no coupling", PRINT_VERBOSE) - !take the E, F of the resonance state with the smaller E - if (my_e_1 < my_e_2) then - if (len_trim(calc_energy) > 0) call set_param_value(at, trim(calc_energy), my_e_1) - if (len_trim(calc_force) > 0) at_force_ptr = my_f_1 - else - if (len_trim(calc_energy) > 0) call set_param_value(at, trim(calc_energy), my_e_2) - if (len_trim(calc_force) > 0) at_force_ptr = my_f_2 - endif - if (len_trim(calc_EVB_gap) > 0) then - gap=my_e_1-my_e_2 - call set_param_value(at, trim(calc_EVB_gap), gap) - call print("EVB gap " // gap, PRINT_VERBOSE) - if (len_trim(calc_force) > 0) then - call add_property(at, trim(calc_EVB_gap)//"_force", 0.0_dp, n_cols=3, ptr2=dgap_dr_ptr, error=error) - PASS_ERROR(error) - dgap_dr_ptr = my_f_1 - my_f_2 - !dgap_dr_ptr = ((my_e_1 - my_e_2)*(my_f_1 - my_f_2) - 4.0_dp*e_offdiag*de_offdiag_dr) / sqrt((my_e_1 - my_e_2)**2.0_dp + 4._dp*e_offdiag**2) - endif - endif - else - !calculate coupling terms -- rab is the bondlength or the sum of the bond length - rab = 0._dp - if (have_form_bond.and.have_break_bond) then - !the distance of the two atoms around the central one - atom1=form_bond(1) - atom3=form_bond(2) - if (break_bond(1)==atom1) then - atom1=break_bond(2) - elseif (break_bond(1)==atom3) then - atom3=break_bond(2) - elseif (break_bond(2)==atom1) then - atom1=break_bond(1) - elseif (break_bond(2)==atom3) then - atom3=break_bond(1) - else - call system_abort("The forming and breaking bonds are not around a common atom. This case has not yet been implemented.") - endif - rab = distance_min_image(at,atom1,atom3) - else - !use the only bond that breaks/forms - if (have_form_bond) then - rab = distance_min_image(at,form_bond(1),form_bond(2)) - elseif (have_break_bond) then - rab = distance_min_image(at,break_bond(1),break_bond(2)) - endif - endif - - - if (len_trim(calc_energy) > 0 .or. len_trim(calc_force) > 0) then - !original by Warshel - !e_offdiag = offdiagonal_A12 * exp(-offdiagonal_mu12 * abs(rab)) - !Letif's modification (the original is too strong and sucks the two Cl atoms together) - e_offdiag = offdiagonal_A12 * exp(-offdiagonal_mu12 * (rab - offdiagonal_r0) - offdiagonal_mu12_square * (rab - offdiagonal_r0)**2._dp) - call print("EVB e_offidag " // e_offdiag, PRINT_VERBOSE) - endif - - !energy - term1 = sqrt((my_e_1 - my_e_2)**2._dp + 4._dp*e_offdiag**2) - if (len_trim(calc_energy) > 0) then - e = 0.5_dp * (my_e_1 + my_e_2) - 0.5_dp * term1 - call set_param_value(at, trim(calc_energy), e) - call print("EVB coupled energy " // e, PRINT_VERBOSE) - endif - if (len_trim(calc_EVB_gap) > 0) then - gap=my_e_1-my_e_2 - call set_param_value(at, trim(calc_EVB_gap), gap) - call print("EVB gap " // gap, PRINT_VERBOSE) - endif - - !force - if (len_trim(calc_force) > 0) then - !force coupling term - de_offdiag_dr = 0._dp - if (have_form_bond.and.have_break_bond) then !breaking and forming bonds around the same atom - d_rab_dx = diff_min_image(at,atom1,atom3)/distance_min_image(at,atom1,atom3) - de_offdiag_dr(1:3,atom1) = de_offdiag_dr(1:3,atom1) + e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) - de_offdiag_dr(1:3,atom3) = de_offdiag_dr(1:3,atom3) - e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) - elseif (have_form_bond) then !only 1 forming bond - d_rab_dx = diff_min_image(at,form_bond(1),form_bond(2))/distance_min_image(at,form_bond(1),form_bond(2)) - de_offdiag_dr(1:3,form_bond(1)) = de_offdiag_dr(1:3,form_bond(1)) + e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) - de_offdiag_dr(1:3,form_bond(2)) = de_offdiag_dr(1:3,form_bond(2)) - e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) - elseif (have_break_bond) then !only 1 breaking bond - d_rab_dx = diff_min_image(at,break_bond(1),break_bond(2))/distance_min_image(at,break_bond(1),break_bond(2)) - de_offdiag_dr(1:3,break_bond(1)) = de_offdiag_dr(1:3,break_bond(1)) + e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) - de_offdiag_dr(1:3,break_bond(2)) = de_offdiag_dr(1:3,break_bond(2)) - e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) - endif - !force - at_force_ptr = 0.5_dp * (my_f_1 + my_f_2) - & - 0.5_dp * ((my_e_1 - my_e_2)*(my_f_1 - my_f_2) - 4.0_dp*e_offdiag*de_offdiag_dr) / sqrt((my_e_1 - my_e_2)**2.0_dp + 4._dp*e_offdiag**2) - if (len_trim(calc_EVB_gap) > 0) then - call add_property(at, trim(calc_EVB_gap)//"_force", 0.0_dp, n_cols=3, ptr2=dgap_dr_ptr, error=error) - PASS_ERROR(error) - dgap_dr_ptr = my_f_1 - my_f_2 - !dgap_dr_ptr = ((my_e_1 - my_e_2)*(my_f_1 - my_f_2) - 4.0_dp*e_offdiag*de_offdiag_dr) / sqrt((my_e_1 - my_e_2)**2.0_dp + 4._dp*e_offdiag**2) - endif - endif - endif - - !SAVE E,F IF NEEDED - -if (len_trim(calc_energy) > 0) then -call print("DEBUG EVB E1 " // my_e_1 // " E2 " // my_e_2 // " e " // e, PRINT_ALWAYS) -endif - if (save_energies .and. len_trim(calc_energy) > 0) then - call set_param_value(at,'EVB1_'//trim(calc_energy),my_e_1) - call set_param_value(at,'EVB2_'//trim(calc_energy),my_e_2) - endif - - if (save_forces .and. len_trim(calc_force) > 0) then - call add_property(at, 'EVB1_'//trim(calc_force), my_f_1) - call add_property(at, 'EVB2_'//trim(calc_force), my_f_2) - endif - - if (allocated(my_f_1)) deallocate(my_f_1) - if (allocated(my_f_2)) deallocate(my_f_2) - if (allocated(de_offdiag_dr)) deallocate(de_offdiag_dr) - - end subroutine Potential_EVB_Calc - - recursive function Potential_EVB_Cutoff(this) - type(Potential_EVB), intent(in) :: this - real(dp) :: potential_EVB_cutoff - - if(associated(this%pot1)) then - potential_EVB_cutoff = cutoff(this%pot1) - else - potential_EVB_cutoff = 0.0_dp - endif - - end function Potential_EVB_Cutoff - diff --git a/src/Potentials/Potential_ForceMixing_header.f95 b/src/Potentials/Potential_ForceMixing_header.f95 deleted file mode 100644 index 56bb821ebb..0000000000 --- a/src/Potentials/Potential_ForceMixing_header.f95 +++ /dev/null @@ -1,128 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Force Mixing header stuff to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - public :: Potential_FM - type Potential_FM - - type(Potential), pointer :: mmpot => null() - type(Potential), pointer :: qmpot => null() - type(MPI_context) :: mpi - - character(STRING_LENGTH) :: init_args_str - - logical :: minimise_mm !% Should classical degrees of freedom be minimised in each calc? - logical :: calc_weights !% Should weights be recalculated on each call to 'calc()' - character(STRING_LENGTH) :: method !% What fit method to use. Options are: - !% \begin{itemize} - !% \item 'lotf_adj_pot_svd' --- LOTF using SVD to optimised the Adj Pot - !% \item 'lotf_adj_pot_minim' --- LOTF using conjugate gradients to optimise the Adj Pot - !% \item 'conserve_momentum' --- divide the total force on QM region over the fit atoms to conserve momentum - !% \item 'force_mixing' --- force mixing with details depending on values of - !% 'buffer_hops', 'transtion_hops' and 'weight_interpolation' - !% \item 'force_mixing_abrupt' --- simply use QM forces on QM atoms and MM forces on MM atoms - !% (shorthand for 'method=force_mixing buffer_hops=0 transition_hops=0') - !% \item 'force_mixing_smooth' --- use QM forces in QM region, MM forces in MM region and - !% linearly interpolate in buffer region (shorthand for 'method=force_mixing weight_interpolation=hop_ramp') - !% \item 'force_mixing_super_smooth' --- as above, but weight forces on each atom by distance from - !% centre of mass of core region (shorthand for 'method=force_mixing weight_interpolation=distance_ramp') - !% \end{itemize} - !% Default method is 'conserve_momentum'. - character(STRING_LENGTH) :: run_suffix !% string to append to 'hybrid_mark' for actual hybrid_mark property - real(dp) :: mm_reweight !% Factor by which to reweight classical forces in embed zone - character(STRING_LENGTH) :: conserve_momentum_weight_method !% Weight method to use with 'method=conserve_momentum'. Should be one of - !% 'uniform' (default), 'mass', 'mass^2' or 'user', - !% with the last referring to a 'conserve_momentum_weight' - !% property in the Atoms object. - character(STRING_LENGTH) :: mm_args_str !% Args string to be passed to 'calc' method of 'mmpot' - character(STRING_LENGTH) :: qm_args_str !% Args string to be passed to 'calc' method of 'qmpot' - integer :: qm_little_clusters_buffer_hops !% Number of bond hops used for buffer region for qm calcs with little clusters - logical :: use_buffer_for_fitting !% Whether to generate the fit region or just use the buffer as the fit region. Only for method=conserve_momentum - integer :: fit_hops !% Number of bond hops used for fit region. Applies to 'conserve_momentum' and 'lotf_*' methods only. - logical :: add_cut_H_in_fitlist !% Whether to extend the fit region where a cut hydrogen is cut after the fitlist selection. - !% This will ensure to only include whole water molecules in the fitlist. - logical :: randomise_buffer !% If true, then positions of outer layer of buffer atoms will be randomised slightly. Default false. - logical :: save_forces !% If true, save MM, QM and total forces as properties in the Atoms object (default true) - - integer :: lotf_spring_hops !% Maximum lengths of springs for LOTF 'adj_pot_svd' and 'adj_pot_minim' methods (default is 2). - character(STRING_LENGTH) :: lotf_interp_order !% Interpolation order: should be one of 'linear', 'quadratic', or 'cubic'. Default is 'linear'. - logical :: lotf_interp_space !% Do spatial rather than temporal interpolation of adj pot parameters. Default is false. - logical :: lotf_nneighb_only !% If true (which is the default), uses nearest neigbour hopping to determine fit atoms - logical :: do_rescale_r !% If true rescale positions in QM region by r_scale_pot1 - logical :: do_rescale_E !% If true rescale energies in QM region by E_scale_pot1 - real(dp) :: r_scale_pot1 !% Rescale positions in QM region by this factor - real(dp) :: E_scale_pot1 !% Rescale energy in QM region by this factor - - character(STRING_LENGTH) :: minim_mm_method - real(dp) :: minim_mm_tol, minim_mm_eps_guess - integer :: minim_mm_max_steps - character(STRING_LENGTH) :: minim_mm_linminroutine - logical :: minim_mm_do_pos, minim_mm_do_lat - logical :: minim_mm_do_print - - character(STRING_LENGTH) :: minim_mm_args_str - - type(Dictionary) :: create_hybrid_weights_params !% extra arguments to pass create_hybrid_weights - - type(Potential), pointer :: relax_pot - type(Inoutput), pointer :: minim_inoutput_movie - type(CInoutput), pointer :: minim_cinoutput_movie - - type(Table) :: embedlist, fitlist - - end type Potential_FM - - interface Initialise - module procedure Potential_FM_initialise - end interface - - interface Finalise - module procedure Potential_FM_Finalise - end interface - - interface Print - module procedure Potential_FM_Print - end interface - - interface Cutoff - module procedure Potential_FM_Cutoff - end interface - - interface Calc - module procedure Potential_FM_Calc - end interface - - diff --git a/src/Potentials/Potential_ForceMixing_routines.f95 b/src/Potentials/Potential_ForceMixing_routines.f95 deleted file mode 100644 index 6ed3ca51ea..0000000000 --- a/src/Potentials/Potential_ForceMixing_routines.f95 +++ /dev/null @@ -1,783 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Force Mixing routines to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - recursive subroutine Potential_FM_initialise(this, args_str, mmpot, qmpot, reference_bulk, mpi, error) - type(Potential_FM), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(Potential), intent(inout), target :: qmpot - type(Potential), optional, intent(inout), target :: mmpot !% if mmpot is not given, a zero potential is assumed, this is most useful in LOTF mode - type(Atoms), optional, intent(inout) :: reference_bulk - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - logical :: minimise_bulk, do_tb_defaults, do_rescale_r, do_rescale_E - real(dp) :: dummy_E - - INIT_ERROR(error) - - call finalise(this) - - this%init_args_str = args_str - - call initialise(params) - call param_register(params, 'run_suffix', '', this%run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minimise_mm', 'F', this%minimise_mm, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'calc_weights', 'T', this%calc_weights, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'method', 'conserve_momentum', this%method, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'mm_reweight', '1.0', this%mm_reweight, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'conserve_momentum_weight_method', 'uniform', this%conserve_momentum_weight_method, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'mm_args_str', '', this%mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'qm_args_str', '', this%qm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'qm_little_clusters_buffer_hops', '3', this%qm_little_clusters_buffer_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'use_buffer_for_fitting', 'F', this%use_buffer_for_fitting, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'fit_hops', '3', this%fit_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'add_cut_H_in_fitlist', 'F', this%add_cut_H_in_fitlist, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'randomise_buffer', 'F', this%randomise_buffer, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'save_forces', 'T', this%save_forces, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_spring_hops', '2', this%lotf_spring_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_interp_order', 'linear', this%lotf_interp_order, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_interp_space', 'F', this%lotf_interp_space, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_nneighb_only', 'T', this%lotf_nneighb_only, help_string="No help yet. This source file was $LastChangedBy$") - - ! Parameters for the MM minimisation - call param_register(params, 'minim_mm_method', 'cg', this%minim_mm_method, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_tol', '1e-6', this%minim_mm_tol, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_eps_guess', '1e-4', this%minim_mm_eps_guess, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_max_steps', '1000', this%minim_mm_max_steps, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_linminroutine', 'FAST_LINMIN', this%minim_mm_linminroutine, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_pos', 'T', this%minim_mm_do_pos, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_lat', 'F', this%minim_mm_do_lat, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_print', 'F', this%minim_mm_do_print, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_args_str', '', this%minim_mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - - ! Parameters for do_reference_bulk calculation, init time only - call param_register(params, "minimise_bulk", "F", minimise_bulk, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "do_tb_defaults", "F", do_tb_defaults, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'do_rescale_r', 'F', do_rescale_r, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'do_rescale_E', 'F', do_rescale_E, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_FM_initialise args_str')) then - RAISE_ERROR('Potential_FM_initialise failed to parse args_str="'//trim(args_str)//'"', error) - endif - - call finalise(params) - - call initialise(this%create_hybrid_weights_params) - call read_string(this%create_hybrid_weights_params, args_str) - call remove_value(this%create_hybrid_weights_params, 'forcemixing') - call remove_value(this%create_hybrid_weights_params, 'init_args_pot1') - call remove_value(this%create_hybrid_weights_params, 'init_args_pot2') - call remove_value(this%create_hybrid_weights_params, 'run_suffix') - call remove_value(this%create_hybrid_weights_params, 'minimise_mm') - call remove_value(this%create_hybrid_weights_params, 'calc_weights') - call remove_value(this%create_hybrid_weights_params, 'method') - call remove_value(this%create_hybrid_weights_params, 'mm_reweight') - call remove_value(this%create_hybrid_weights_params, 'conserve_momentum_weight_method') - call remove_value(this%create_hybrid_weights_params, 'mm_args_str') - call remove_value(this%create_hybrid_weights_params, 'qm_args_str') - call remove_value(this%create_hybrid_weights_params, 'qm_little_clusters_buffer_hops') - call remove_value(this%create_hybrid_weights_params, 'use_buffer_for_fitting') - call remove_value(this%create_hybrid_weights_params, 'fit_hops') - call remove_value(this%create_hybrid_weights_params, 'add_cut_H_in_fitlist') - call remove_value(this%create_hybrid_weights_params, 'randomise_buffer') - call remove_value(this%create_hybrid_weights_params, 'save_forces') - call remove_value(this%create_hybrid_weights_params, 'lotf_spring_hops') - call remove_value(this%create_hybrid_weights_params, 'lotf_interp_order') - call remove_value(this%create_hybrid_weights_params, 'lotf_interp_space') - call remove_value(this%create_hybrid_weights_params, 'lotf_nneighb_only') - call remove_value(this%create_hybrid_weights_params, 'do_rescale_r') - call remove_value(this%create_hybrid_weights_params, 'do_rescale_E') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_method') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_tol') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_eps_guess') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_max_steps') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_linminroutine') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_pos') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_lat') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_print') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_args_str') - call remove_value(this%create_hybrid_weights_params, 'minimise_bulk') - call remove_value(this%create_hybrid_weights_params, 'do_tb_defaults') - - this%do_rescale_r = .false. - this%do_rescale_E = .false. - this%r_scale_pot1 = 1.0_dp - this%E_scale_pot1 = 1.0_dp - - if (do_rescale_r .or. do_rescale_E) then - - this%do_rescale_r = do_rescale_r - this%do_rescale_E = do_rescale_E - - if (.not. present(reference_bulk)) then - RAISE_ERROR("potential_forcemixing_initialise got do_rescale_r=T do_tb_defaults="//do_tb_defaults//" but reference_bulk is not present", error) - endif - - if (.not. present(mmpot)) then - RAISE_ERROR("potential_forcemixing_initialise got do_rescale_r=T but no mmpot was given", error) - endif - - call do_reference_bulk(reference_bulk, qmpot, mmpot, minimise_bulk, do_rescale_r, do_rescale_E, & - this%r_scale_pot1, this%E_scale_pot1, do_tb_defaults) - - if (this%r_scale_pot1 <= 0.0_dp) this%r_scale_pot1 = 1.0_dp - if (this%E_scale_pot1 <= 0.0_dp) this%E_scale_pot1 = 1.0_dp - if (do_rescale_r) call print ("Rescaling positions in QM potential by " // this%r_scale_pot1 // " to match lattice constants") - if (do_rescale_E) call print ("Rescaling energies in QM potential by " // this%E_scale_pot1 // " to match bulk moduli") - end if - - this%qmpot => qmpot - if(present(mmpot)) then - this%mmpot => mmpot - else - this%mmpot => null() - end if - - if (this%minimise_mm .and. present(mmpot)) then - ! call initialise(this%relax_pot, "Simple", mmpot) - this%relax_pot => mmpot - endif - - if (present(mpi)) this%mpi = mpi - - end subroutine Potential_FM_initialise - - - recursive subroutine Potential_FM_finalise(this) - type(Potential_FM), intent(inout) :: this - - nullify(this%mmpot) - nullify(this%qmpot) - call finalise(this%embedlist) - call finalise(this%fitlist) - call finalise(this%create_hybrid_weights_params) - - end subroutine Potential_FM_finalise - - - recursive subroutine Potential_FM_print(this, file) - type(Potential_FM), intent(inout) :: this - type(Inoutput), intent(inout), optional :: file - - if (current_verbosity() < PRINT_NORMAL) return - - call Print('Potential_FM:',file=file) - call Print(' minimise_mm='//this%minimise_mm,file=file) - call Print(' calc_weights='//this%calc_weights,file=file) - call Print(' method='//trim(this%method),file=file) - call Print(' mm_reweight='//this%mm_reweight,file=file) - call Print(' conserve_momentum_weight_method='//this%conserve_momentum_weight_method) - call Print(' mm_args_str='//trim(this%mm_args_str), file=file) - call Print(' qm_args_str='//trim(this%qm_args_str), file=file) - call Print(' qm_little_clusters_buffer_hops='//this%qm_little_clusters_buffer_hops, file=file) - call print(' use_buffer_for_fitting='//this%use_buffer_for_fitting) - call Print(' fit_hops='//this%fit_hops, file=file) - call print(' add_cut_H_in_fitlist='//this%add_cut_H_in_fitlist,file=file) - call Print(' randomise_buffer='//this%randomise_buffer, file=file) - call Print(' save_forces='//this%save_forces, file=file) - call Print(' lotf_spring_hops='//this%lotf_spring_hops, file=file) - call Print(' lotf_interp_order='//this%lotf_interp_order, file=file) - call Print(' lotf_interp_space='//this%lotf_interp_space, file=file) - call Print(' lotf_nneighb_only='//this%lotf_nneighb_only, file=file) - call Print(' r_scale_pot1='//this%r_scale_pot1, file=file) - call Print(' E_scale_pot1='//this%E_scale_pot1, file=file) - call Print('',file=file) - call Print(' minim_mm_method='//this%minim_mm_method,file=file) - call Print(' minim_mm_tol='//this%minim_mm_tol,file=file) - call Print(' minim_mm_eps_guess='//this%minim_mm_eps_guess,file=file) - call Print(' minim_mm_max_steps='//this%minim_mm_max_steps,file=file) - call Print(' minim_mm_linminroutine='//this%minim_mm_linminroutine,file=file) - call Print(' minim_mm_do_pos='//this%minim_mm_do_pos,file=file) - call Print(' minim_mm_do_lat='//this%minim_mm_do_lat,file=file) - call Print(' minim_mm_do_print='//this%minim_mm_do_print,file=file) - call Print(' minim_mm_args_str='//trim(this%minim_mm_args_str),file=file) - call Print('',file=file) - call Print(' create_hybrid_weights_params '//write_string(this%create_hybrid_weights_params), file=file) - call Print('',file=file) - if (associated(this%mmpot)) then - call Print('MM Potential:',file=file) - call Print(this%mmpot,file=file) - call Print('',file=file) - else - call print('MM potential not initialised') - end if - if (associated(this%qmpot)) then - call Print('QM potential:',file=file) - call Print(this%qmpot,file=file) - else - call print('QM potential not initialised') - end if - call Print('',file=file) - - end subroutine Potential_FM_print - - - recursive subroutine Potential_FM_calc(this, at, args_str, error) - type(Potential_FM), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - real(dp), pointer :: at_force_ptr(:,:) - - real(dp), allocatable, dimension(:,:) :: df, df_fit - real(dp), allocatable, dimension(:,:) :: f_mm, f_qm - real(dp), pointer, dimension(:,:) :: force_ptr - real(dp), pointer, dimension(:) :: weight_region1, conserve_momentum_weight - integer, pointer, dimension(:) :: hybrid, hybrid_mark - logical, pointer, dimension(:) :: hybrid_mask - integer :: i, j, k, n - type(Dictionary) :: params, calc_create_hybrid_weights_params - type(Connection) :: saved_connect - logical :: dummy - logical :: minimise_mm, calc_weights, save_forces, lotf_do_init, & - lotf_do_map, lotf_do_fit, lotf_do_interp, lotf_do_qm, lotf_interp_space, & - randomise_buffer, lotf_nneighb_only - character(STRING_LENGTH) :: method, mm_args_str, qm_args_str, conserve_momentum_weight_method, & - AP_method, lotf_interp_order, atom_mask - real(dp) :: mm_reweight, dV_dt, f_tot(3), w_tot, weight, lotf_interp, origin(3), extent(3,3) - integer :: fit_hops - - character(STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, run_suffix, qm_run_suffix, & - create_hybrid_weights_params_str - - integer :: weight_method, qm_little_clusters_buffer_hops, lotf_spring_hops - integer, parameter :: UNIFORM_WEIGHT=1, MASS_WEIGHT=2, MASS2_WEIGHT=3, USER_WEIGHT=4, CM_WEIGHT_REGION1=5 - integer, allocatable, dimension(:) :: embed, fit - !NB workaround for pgf90 bug (as of 9.0-1) - real(dp) :: t_norm - !NB end of workaround for pgf90 bug (as of 9.0-1) - - INIT_ERROR(error) - - ! Override parameters with those given in args_str - call initialise(params) - call param_register(params, "run_suffix", ''//this%run_suffix, run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "minimise_mm", ''//this%minimise_mm, minimise_mm, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "calc_weights", ''//this%calc_weights, calc_weights, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "method", this%method, method, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "mm_reweight", ''//this%mm_reweight, mm_reweight, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'conserve_momentum_weight_method', ''//this%conserve_momentum_weight_method, & - conserve_momentum_weight_method, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'mm_args_str', this%mm_args_str, mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'qm_args_str', this%qm_args_str, qm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'qm_little_clusters_buffer_hops', ''//this%qm_little_clusters_buffer_hops, qm_little_clusters_buffer_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'use_buffer_for_fitting', ''//this%use_buffer_for_fitting, this%use_buffer_for_fitting, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'fit_hops', ''//this%fit_hops, fit_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'add_cut_H_in_fitlist', ''//this%add_cut_H_in_fitlist,this%add_cut_H_in_fitlist, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'randomise_buffer', ''//this%randomise_buffer, randomise_buffer, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'save_forces', ''//this%save_forces, save_forces, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_spring_hops', ''//this%lotf_spring_hops, lotf_spring_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_interp_order', this%lotf_interp_order, lotf_interp_order, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_interp_space', ''//this%lotf_interp_space, lotf_interp_space, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_nneighb_only', ''//this%lotf_nneighb_only, lotf_nneighb_only, help_string="No help yet. This source file was $LastChangedBy$") - - ! override args_str parameters for the MM minimisation - call param_register(params, 'minim_mm_method', 'cg', this%minim_mm_method, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_tol', '1e-6', this%minim_mm_tol, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_eps_guess', '1e-4', this%minim_mm_eps_guess, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_max_steps', '1000', this%minim_mm_max_steps, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_linminroutine', 'FAST_LINMIN', this%minim_mm_linminroutine, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_pos', 'T', this%minim_mm_do_pos, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_lat', 'F', this%minim_mm_do_lat, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_print', 'F', this%minim_mm_do_print, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_args_str', '', this%minim_mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - - ! lotf parameters, calc time only - call param_register(params, 'lotf_do_init', 'T', lotf_do_init, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_do_map', 'F', lotf_do_map, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_do_qm', 'T', lotf_do_qm, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_do_fit', 'T', lotf_do_fit, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_do_interp', 'F', lotf_do_interp, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'lotf_interp', '0.0', lotf_interp, help_string="No help yet. This source file was $LastChangedBy$") - - call param_register(params, 'energy', '', calc_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'force', '', calc_force, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'virial', '', calc_virial, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'local_energy', '', calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'local_virial', '', calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_FM_Calc args_str') ) then - RAISE_ERROR("Potential_FM_calc failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if (current_verbosity().ge.PRINT_NERD) call print(this) - - call initialise(calc_create_hybrid_weights_params) - call read_string(calc_create_hybrid_weights_params, write_string(this%create_hybrid_weights_params)) - call read_string(calc_create_hybrid_weights_params, args_str, append=.true.) - - call remove_value(calc_create_hybrid_weights_params, 'minimise_mm') - call remove_value(calc_create_hybrid_weights_params, 'calc_weights') - call remove_value(calc_create_hybrid_weights_params, 'method') - call remove_value(calc_create_hybrid_weights_params, 'mm_reweight') - call remove_value(calc_create_hybrid_weights_params, 'conserve_momentum_weight_method') - call remove_value(calc_create_hybrid_weights_params, 'mm_args_str') - call remove_value(calc_create_hybrid_weights_params, 'qm_args_str') - call remove_value(calc_create_hybrid_weights_params, 'qm_little_clusters_buffer_hops') - call remove_value(calc_create_hybrid_weights_params, 'use_buffer_for_fitting') - call remove_value(calc_create_hybrid_weights_params, 'fit_hops') - call remove_value(calc_create_hybrid_weights_params, 'add_cut_H_in_fitlist') - call remove_value(calc_create_hybrid_weights_params, 'randomise_buffer') - call remove_value(calc_create_hybrid_weights_params, 'save_forces') - call remove_value(calc_create_hybrid_weights_params, 'lotf_spring_hops') - call remove_value(calc_create_hybrid_weights_params, 'lotf_interp_order') - call remove_value(calc_create_hybrid_weights_params, 'lotf_interp_space') - call remove_value(calc_create_hybrid_weights_params, 'lotf_nneighb_only') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_method') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_tol') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_eps_guess') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_max_steps') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_linminroutine') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_do_pos') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_do_lat') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_do_print') - call remove_value(calc_create_hybrid_weights_params, 'minim_mm_args_str') - call remove_value(calc_create_hybrid_weights_params, 'lotf_do_init') - call remove_value(calc_create_hybrid_weights_params, 'lotf_do_map') - call remove_value(calc_create_hybrid_weights_params, 'lotf_do_qm') - call remove_value(calc_create_hybrid_weights_params, 'lotf_do_fit') - call remove_value(calc_create_hybrid_weights_params, 'lotf_do_interp') - call remove_value(calc_create_hybrid_weights_params, 'lotf_interp') - - ! Apply - if (trim(method) == 'force_mixing_abrupt') then - call set_value(calc_create_hybrid_weights_params, 'buffer_hops', 0) - call set_value(calc_create_hybrid_weights_params, 'transition_hops', 0) - call set_value(calc_create_hybrid_weights_params, 'weight_interpolation', 'hop_ramp') - else if (trim(method) == 'force_mixing_smooth') then - call set_value(calc_create_hybrid_weights_params, 'weight_interpolation', 'hop_ramp') - else if (trim(method) == 'force_mixing_super_smooth') then - call set_value(calc_create_hybrid_weights_params, 'weight_interpolation', 'distance_ramp') - end if - - if (len_trim(calc_energy) > 0 .or. len_trim(calc_virial) > 0 .or. len_trim(calc_local_energy) > 0 .or. len_trim(calc_local_virial) > 0 .or. & - len_trim(calc_force) <= 0) then - RAISE_ERROR('Potential_FM_calc: supports only forces, not energy, virial, local_energy or local_virial', error) - endif - - allocate(f_mm(3,at%N),f_qm(3,at%N)) - f_mm = 0.0_dp - f_qm = 0.0_dp - call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) - PASS_ERROR(error) - - if (calc_weights) then - - call system_timer('calc_weights') - - if (.not. has_property(at, 'hybrid_mark'//trim(run_suffix))) & - call add_property(at, 'hybrid_mark'//trim(run_suffix), HYBRID_NO_MARK) - - if (.not. assign_pointer(at, "hybrid"//trim(run_suffix), hybrid)) then - RAISE_ERROR("Potential_FM_calc: at doesn't have hybrid"//trim(run_suffix)//" property and calc_weights was specified", error) - endif - - if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then - RAISE_ERROR('Potential_FM_Calc: hybrid_mark'//trim(run_suffix)//' property missing', error) - endif - - if(any((hybrid.ne.HYBRID_ACTIVE_MARK).and.(hybrid.ne.HYBRID_NO_MARK))) then - RAISE_ERROR('Potential_FM_calc: hybrid property must contain only 1 (for QM) and 0 (anywhere else).', error) - endif - !update only the active region, the buffer region will be updated in create_hybrid_weights - - ! if we have a hysteretic buffer, set marks to allow previously active atoms to become buffer atoms - ! if we don't, then this is irrelevant anyway - ! create_hybrid_weights will then set the buffer marks - where (hybrid_mark == HYBRID_ACTIVE_MARK) hybrid_mark = HYBRID_BUFFER_MARK - where (hybrid == HYBRID_ACTIVE_MARK) hybrid_mark = HYBRID_ACTIVE_MARK - - call Print('Potential_FM_calc: got '//count(hybrid /= 0)//' active atoms.', PRINT_VERBOSE) - - if (count(hybrid_mark == HYBRID_ACTIVE_MARK) == 0) then - RAISE_ERROR('Potential_ForceMixing_Calc: zero active atoms and calc_weights was specified', error) - endif - - create_hybrid_weights_params_str = write_string(calc_create_hybrid_weights_params) - call finalise(calc_create_hybrid_weights_params) - call create_hybrid_weights(at, create_hybrid_weights_params_str) - call set_value(at%params, 'create_hybrid_weights_params', create_hybrid_weights_params_str) ! save how we did the calc_weights call - - call system_timer('calc_weights') - - end if - - if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then - RAISE_ERROR('Potential_FM_Calc: hybrid_mark'//trim(run_suffix)//' property missing', error) - endif - - ! Do the MM minimisation, freezing the atoms marked as active - if (minimise_mm) then - call do_minimise_mm(this%relax_pot, at, this%minim_mm_method, this%minim_mm_tol, this%minim_mm_max_steps, & - this%minim_mm_linminroutine, this%minim_mm_do_pos, this%minim_mm_do_lat, this%minim_mm_do_print, & - this%minim_mm_args_str, this%minim_mm_eps_guess, this%minim_inoutput_movie, & - this%minim_cinoutput_movie, find(hybrid_mark == HYBRID_ACTIVE_MARK)) - endif - - ! Do the classical calculation - if(associated(this%mmpot)) then - mm_args_str=trim(mm_args_str)//' force='//trim(calc_force) - call calc(this%mmpot, at, args_str=mm_args_str, error=error) - f_mm = at_force_ptr - else - f_mm = 0.0_dp - end if - - ! Save MM forces if requested to be saved - if (save_forces) call add_property(at, 'FM_MM_'//trim(calc_force), f_mm, overwrite=.true.) - - !Potential calc could have added properties e.g. old_cluster_mark - if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then - RAISE_ERROR('Potential_FM_Calc: hybrid_mark property missing', error) - endif - if (.not. any(hybrid_mark /= HYBRID_NO_MARK)) then - at_force_ptr = f_mm - return - end if - - call print('Potential_FM_Calc: reweighting classical forces by '//mm_reweight//' in active region', PRINT_VERBOSE) - do i=1,at%N - if (hybrid_mark(i) /= HYBRID_ACTIVE_MARK) cycle - f_mm(:,i) = mm_reweight*f_mm(:,i) - end do - - !Fitlist construction has been moved to after the cluster carving in case the cluster is used as the fitlist. - - ! Do the expensive QM calculation. For the LOTF methods we only do this if lotf_do_qm is true - if (method(1:4) /= 'lotf' .or. (method(1:4) == 'lotf' .and. lotf_do_qm)) then - - call initialise(params) - call read_string(params, qm_args_str) - - call set_value(params, 'force='//trim(calc_force)) - - !! TODO - possibly want to set more default options in the qm_args_str here - if (.not. has_key(params, 'buffer_hops')) & - call set_value(params, 'buffer_hops', qm_little_clusters_buffer_hops) - - call set_value(params, 'randomise_buffer', randomise_buffer) - call set_value(params, 'calc_weights', calc_weights) ! Let QM know if we changed the weights - - if (get_value(params, 'run_suffix', qm_run_suffix)) then - ! if args_str and qm_args_str both defin a run_suffix, then assert that they match - if (trim(run_suffix) /= trim(qm_run_suffix)) then - RAISE_ERROR('Potential_FM_calc: run_suffix args_str ('//trim(run_suffix)//') does not match qm_args_str value ('//trim(qm_run_suffix)//')', error) - end if - else - ! copy run_suffix from our args_str to qm_args_str - call set_value(params, 'run_suffix', run_suffix) - end if - - if (this%do_rescale_r) call set_value(params, 'r_scale', this%r_scale_pot1) - if (this%do_rescale_E) call set_value(params, 'E_scale', this%E_scale_pot1) - - if (has_key(params, 'atom_mask')) then - if (.not. get_value(params, 'atom_mask', atom_mask)) then - RAISE_ERROR('Potential_FM_Calc: atom_mask present in qm_args_str, but not of type string', error) - end if - call add_property(at, 'hybrid_mask', .false., overwrite=.true., ptr=hybrid_mask) - if (trim(atom_mask) == "active") then - ! Mark the active atoms - hybrid_mask = hybrid_mark == HYBRID_ACTIVE_MARK - else if (trim(atom_mask) == "active_plus_buffer") then - ! Mark active and buffer atoms - hybrid_mask = hybrid_mark /= HYBRID_NO_MARK - else if (trim(atom_mask) == "active_plus_cutoff") then - ! Mark active atom and their neighbours (within QM pot cutoff) - hybrid_mask = hybrid_mark == HYBRID_ACTIVE_MARK - do i=1,at%n - if (hybrid_mark(i) == HYBRID_ACTIVE_MARK) then - do n=1,n_neighbours(at, i) - j = neighbour(at, i, n, max_dist=cutoff(this%qmpot)) - if (j == 0) cycle - hybrid_mask(j) = .true. - end do - end if - end do - else - RAISE_ERROR('Potential_FM_Calc: unexpected atom_mask value "'//trim(atom_mask)//'"', error) - end if - call print('Potential_FM_Calc: got atom_mask with '//count(hybrid_mark == HYBRID_ACTIVE_MARK)//' marked atoms.', PRINT_VERBOSE) - call set_value(params, 'atom_mask_name', 'hybrid_mask') - end if - - qm_args_str = write_string(params, real_format='f16.8') - call finalise(params) - - ! Do the QM. If qm_args_str contatins 'single_cluster' or 'little_clusters' options - ! then potential calc() will do cluster carving. If it contains 'atom_mask_name' we - ! don't make a cluster, but only compute forces on marked atoms. - call calc(this%qmpot, at, args_str=qm_args_str, error=error) - f_qm = at_force_ptr - - ! Save QM forces if requested to be saved - if (save_forces) call add_property(at, 'FM_QM_'//trim(calc_force), f_qm, overwrite=.true.) - - end if - - !Fitlist construction has been moved here. - - ! Make embed and fit lists if we need them - if (method(1:4) == 'lotf' .or. trim(method) == 'conserve_momentum') then - - if ((method(1:4) == 'lotf' .and. lotf_do_init) .or. trim(method) == 'conserve_momentum') then - if (this%use_buffer_for_fitting) then - if (trim(method).ne.'conserve_momentum') then - RAISE_ERROR('use_buffer_for_fitting=T only works for method=conserve_momentum', error) - endif - !create lists according to hybrid_mark property, use BUFFER/TRANS/BUFFER_OUTER_LAYER as fitlist - call create_embed_and_fit_lists_from_cluster_mark(at,this%embedlist,this%fitlist, mark_name='hybrid_mark'//trim(run_suffix)) -! if (this%add_cut_H_in_fitlist) then !no cut H on the fitlist's border -! call add_cut_hydrogens(at,this%fitlist) -! endif - else - call create_embed_and_fit_lists(at, fit_hops, this%embedlist, this%fitlist, & - cluster_hopping_nneighb_only=lotf_nneighb_only, min_images_only=.true., mark_name='hybrid_mark'//trim(run_suffix)) - if (this%add_cut_H_in_fitlist) then !no cut H on the fitlist's border - call add_cut_hydrogens(at,this%fitlist) - endif - - end if - endif - - ! Make some convenient arrays of embed and fit list - allocate(embed(this%embedlist%N)) - embed = int_part(this%embedlist,1) - allocate(fit(this%fitlist%N)) - fit = int_part(this%fitlist,1) - end if - - if (method(1:4) == 'lotf') then - - if (trim(method) == 'lotf_adj_pot_svd' .or. trim(method) == 'lotf_adj_pot_minim') then - - if (trim(method) == 'lotf_adj_pot_svd') then - AP_method = 'SVD' - else - AP_method = 'minim' - end if - - ! Optimise the adjustable potential - allocate(df(3,this%fitlist%N)) - df = 0.0_dp - df(:,1:this%embedlist%N) = f_qm(:,embed) - f_mm(:,embed) - - if (lotf_do_init) then - call print('Initialising adjustable potential with map='//lotf_do_map, PRINT_VERBOSE) - call adjustable_potential_init(at, this%fitlist, directionN=this%embedlist%N, & - method=AP_method, nnonly=lotf_nneighb_only, & - spring_hops=lotf_spring_hops, map=lotf_do_map) - end if - - if (lotf_do_qm .and. lotf_do_fit) then - call system_timer('lotf_adj_pot_fit') - call adjustable_potential_optimise(at, df, method=AP_method) - call system_timer('lotf_adj_pot_fit') - end if - - if (lotf_do_interp) then - call adjustable_potential_force(at, df, interp=lotf_interp, & - interp_space=lotf_interp_space, interp_order=lotf_interp_order,power=dV_dt) - else - call adjustable_potential_force(at, df, power=dV_dt) - end if - - at_force_ptr = f_mm ! Start with classical forces - at_force_ptr(:,fit) = at_force_ptr(:,fit) + df ! Add correction in fit region - - deallocate(df) - - else if (trim(this%method) == 'lotf_adj_pot_sw') then - - RAISE_ERROR('lotf_adj_pot_sw no longer supported.', error) - - ! old style adj pot: SW with variable parameters - -!!$ allocate(df(3,this%fitlist%N)) -!!$ -!!$ ! old style method: we fit to QM force in embed region and MM force in outer fit region, -!!$ ! not to force difference -!!$ df = f_mm(:,fit) -!!$ df(:,1:this%embedlist%N) = f_qm(:,embed) -!!$ -!!$ if (lotf_do_init) & -!!$ call adjustable_potential_sw_init(at, this%fitlist) -!!$ -!!$ if (lotf_do_qm .and. lotf_do_fit) & -!!$ call adjustable_potential_sw_optimise(at, df) -!!$ -!!$ if (lotf_do_interp) then -!!$ call adjustable_potential_force(at, df, interp=lotf_interp) -!!$ else -!!$ call adjustable_potential_force(at, df) -!!$ end if -!!$ -!!$ f = f_mm ! start with classical forces -!!$ f(:,fit) = df ! replace with fitted force -!!$ -!!$ deallocate(df) - - end if - - else if (trim(method) == 'conserve_momentum') then - - call verbosity_push(PRINT_NORMAL) - - call print('Conserving momentum using fit list with '//this%fitlist%N//' atoms', PRINT_VERBOSE) - - select case(conserve_momentum_weight_method) - case ('uniform') - weight_method = UNIFORM_WEIGHT - call print('conserve_momentum: uniform weighting', PRINT_VERBOSE) - case ('mass') - weight_method = MASS_WEIGHT - call print('conserve_momentum: using mass weighting', PRINT_VERBOSE) - case ('mass^2') - weight_method = MASS2_WEIGHT - call print('conserve_momentum: using mass squared weighting', PRINT_VERBOSE) - case ('user') - weight_method = USER_WEIGHT - call print('conserve_momentum: using user defined weighting', PRINT_VERBOSE) - case ('weight_region1') - weight_method = CM_WEIGHT_REGION1 - call print('conserve_momentum: using user defined weighting', PRINT_VERBOSE) - case default - RAISE_ERROR('Potential_FM_Calc: unknown conserve_momentum_weight method: '//trim(conserve_momentum_weight_method), error) - end select - - if (weight_method == USER_WEIGHT) then - if (.not. assign_pointer(at, 'conserve_momentum_weight', conserve_momentum_weight)) then - RAISE_ERROR('Potential_FM_Calc: missing property conserve_momentum_weight', error) - endif - end if - - allocate(df(3,at%N),df_fit(3,this%fitlist%N)) - - if (.not. assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1)) then - RAISE_ERROR('Potential_FM_Calc: missing weight_region1 property - try setting calc_weights=T in args_str', error) - endif - - ! Straight forward force mixing using weight_region1 created by create_hybrid_weights() - do i=1,at%N - df(:,i) = (weight_region1(i)*f_qm(:,i) + (1.0_dp - weight_region1(i))*f_mm(:,i)) - f_mm(:,i) - end do - - f_tot = sum(df,dim=2) - call print('conserve_momentum: norm(sum of target forces) = '//round(norm(f_tot),15), PRINT_VERBOSE) - - w_tot = 0.0_dp - do i = 1, this%fitlist%N - select case(weight_method) - case(UNIFORM_WEIGHT) - weight = 1.0_dp - case(MASS_WEIGHT) - if (.not. associated(at%mass)) then - RAISE_ERROR('Potential_FM_Calc MASS_WEIGHT, but at%mass is not associated', error) - endif - weight = at%mass(fit(i)) - case(MASS2_WEIGHT) - if (.not. associated(at%mass)) then - RAISE_ERROR('Potential_FM_Calc MASS2_WEIGHT, but at%mass is not associated', error) - endif - weight = at%mass(fit(i))*at%mass(fit(i)) - case(USER_WEIGHT) - weight = conserve_momentum_weight(fit(i)) - case(CM_WEIGHT_REGION1) - weight = weight_region1(fit(i)) - end select - df_fit(:,i) = -weight * f_tot - w_tot = w_tot + weight - end do - df_fit = (df_fit / w_tot) - - !NB workaround for pgf90 bug (as of 9.0-1) - t_norm = norm(sum(df_fit,dim=2));call print('conserve_momentum: norm(sum of fit forces) = '//round(t_norm, 15), PRINT_VERBOSE) - !NB end of workaround for pgf90 bug (as of 9.0-1) - - ! Final forces are classical forces plus corrected QM forces - at_force_ptr = f_mm + df - at_force_ptr(:,fit) = at_force_ptr(:,fit) + df_fit - - call verbosity_pop() - - deallocate(df, df_fit) - - else if (method(1:12) == 'force_mixing') then - - if (.not. assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1)) then - RAISE_ERROR('Potential_FM_Calc: missing weight_region1 property - try setting calc_weights=T in args_str', error) - endif - - ! Straight forward force mixing using weight_region1 created by create_hybrid_weights() - do i=1,at%N - at_force_ptr(:,i) = weight_region1(i)*f_qm(:,i) + (1.0_dp - weight_region1(i))*f_mm(:,i) - end do - - else - RAISE_ERROR('Potential_FM_calc: unknown method '//trim(method), error) - end if - - deallocate(f_mm,f_qm) - - if (allocated(embed)) deallocate(embed) - if (allocated(fit)) deallocate(fit) - - end subroutine Potential_FM_calc - - - recursive function Potential_FM_cutoff(this) - type(Potential_FM), intent(in) :: this - real(dp) :: potential_fm_cutoff - - ! Return larger of QM and MM cutoffs - if(associated(this%mmpot) .and. associated(this%qmpot)) then - potential_fm_cutoff = max(cutoff(this%mmpot), cutoff(this%qmpot)) - else if(associated(this%qmpot)) then - potential_fm_cutoff = cutoff(this%qmpot) - else if(associated(this%mmpot)) then - potential_fm_cutoff = cutoff(this%mmpot) - else - potential_fm_cutoff = 0.0_dp - endif - - end function Potential_FM_cutoff - - diff --git a/src/Potentials/Potential_Hybrid_utils.f95 b/src/Potentials/Potential_Hybrid_utils.f95 deleted file mode 100644 index 7237c9f5d5..0000000000 --- a/src/Potentials/Potential_Hybrid_utils.f95 +++ /dev/null @@ -1,284 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X misc routines to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - subroutine linear_square(x,afunc) - real(dp) :: x, afunc(:) - - afunc(1) = x*x - afunc(2) = x - afunc(3) = 1 - - end subroutine linear_square - - subroutine potential_bulk_modulus(pot, at, B, V0, minimise_bulk, eps, args_str) - type(Potential), intent(inout) :: pot - type(Atoms), intent(in) :: at - real(dp), intent(out) :: V0, B - logical, intent(in), optional :: minimise_bulk - real(dp), intent(in), optional :: eps - character(len=*), intent(in), optional :: args_str - - integer :: i,j, steps - real(dp) :: E(11), V(11), a(3), chisq, use_eps - type(Atoms) :: at0, at1 - logical :: do_minimise_bulk - - do_minimise_bulk = optional_default(.true., minimise_bulk) - use_eps = optional_default(2.0e-3_dp, eps) - - at0 = at - if (do_minimise_bulk) then - ! Minimise initial cell - call verbosity_push_decrement() - steps = minim(pot, at0, 'cg', 1e-6_dp, 100, & - 'LINMIN_DERIV', do_pos=.true.,do_lat=.true., do_print=.false., args_str=args_str) - call verbosity_pop() - end if - - do i = 1, 11 - at1 = at0 - call set_lattice(at1, at1%lattice*(1.0_dp - real(i-6,dp)*use_eps), scale_positions=.true.) - V(i) = cell_volume(at1) - call set_cutoff (at1, cutoff(pot)+1.0_dp) - call calc_connect(at1) - - if (do_minimise_bulk) then - ! Minimise positions with lattice fixed - call verbosity_push_decrement() - steps = minim(pot, at1, 'cg', 1e-6_dp, 100, & - 'LINMIN_DERIV', do_pos=.true.,do_lat=.false., do_print=.false., args_str=args_str) - call verbosity_pop() - end if - - call calc(pot, at1, energy=E(i), args_str=args_str) - call print('bulk_modulus V='//V(i)//' E='//E(i), PRINT_NERD) - end do - - call least_squares(V, E, (/ ( 1.0_dp, j=1,11) /), & - a, chisq, linear_square) - - V0 = -a(2)/(2*a(1)) - B = -1.0*a(2)*EV_A3_IN_GPA - - end subroutine potential_bulk_modulus - -!% We define a potential energy function $E(r)$, and then a scaled function -!% \[ -!% E\'(r) = \beta E(\alpha r) -!% \] -!% The corresponding force in the original coordinate system is -!% \[ -!% F\'(r) = -\frac{\partial E\'}{\partial r} = -\beta \alpha \frac{\partial E\'}{\partial r} = \beta \alpha\, F -!% \] -!% The equilibrium lattice constant changes from $a_0$ to $a_0\'$ and the equilbrium cell volume changes from $V_0$ to $V_0\'$ according to -!% \begin{eqnarray*} -!% a_0' & = & \frac{a_0}{\alpha} \\ V_0' & = & \frac{V_0}{\alpha^3} -!% \end{eqnarray*} -!% The scaled bulk modulus is -!% \begin{eqnarray*} -!% B' & = & V \frac{\partial^2 E'}{\partial V^2} \\ & = & \beta \alpha^3 V \frac{\partial^2E}{\partial V^2} \\ & = & \beta \alpha^3 B -!% \end{eqnarray*} -!% Thus if we want to match a target volume $V_0\'$ and bulk modulus $B\'$ we should use -!% \begin{eqnarray*} -!% \alpha & = & \left( \frac{V_0}{V_0'} \right)^\frac{1}{3} = \frac{a_0}{a_0'} \\ \beta & = & \frac{B'}{B \alpha^3} -!% \end{eqnarray*} -!% where $a_0$ and $a_0\'$ are the lattice constants before and after rescaling. -!% -!% For QM/MM force mixing, where we label the QM potential as region 1 and the classical (MM) potential -!% as region 2, the aim is to rescale the QM potential to match the MM lattice constant $a_2$ and bulk -!% modulus $B_2$, so we have -!% \begin{eqnarray*} -!% \alpha & = & \frac{a_1}{a_2} \\ \beta & = & \frac{B_2}{B_1 \alpha^3} -!% \end{eqnarray*} -!% where $a_1$ and $B_1$ are the unmodified QM lattice constant and bulk modulus, respectively. -!% Note that this is equivalent to rescaling the MM \emph{positions} to match the QM lattice constant. - - subroutine do_reference_bulk(reference_bulk, region1_pot, region2_pot, minimise_bulk, do_rescale_r, do_rescale_E, & - r_scale_pot1, E_scale_pot1, do_tb_defaults) - type(Atoms), intent(inout) :: reference_bulk - type(Potential), intent(inout), target :: region1_pot, region2_pot - logical, intent(in) :: minimise_bulk, do_rescale_r, do_rescale_E, do_tb_defaults - real(dp), intent(inout) :: r_scale_pot1, E_scale_pot1 - - real(dp) :: e_bulk, B_region2, B_region1, vol - - type(Atoms) :: bulk_region1, bulk_region2 - integer :: it - - call verbosity_push_decrement(PRINT_NERD) - call print("potential_local_e_mix_initialise called with reference_bulk") - call write(reference_bulk, "stdout") - call verbosity_pop() - - ! set up region1 stuff - bulk_region1 = reference_bulk - call set_cutoff(bulk_region1, cutoff(region1_pot)+0.5_dp) - call calc_connect(bulk_region1) -! call initialise(region1_pot, "Simple", region1_pot) - if (minimise_bulk) then - call print("MINIMISING bulk in region1 potential", PRINT_VERBOSE) - call verbosity_push_decrement() - it = minim(region1_pot, at=bulk_region1, method='cg', convergence_tol=0.001_dp, max_steps=100, linminroutine='NR_LINMIN', & - do_print = .false., do_lat = .true., args_str='solver=DIAG SCF_NONE') - call verbosity_pop() - endif - call calc(region1_pot, bulk_region1, energy=e_bulk, args_str='solver=DIAG SCF_NONE') - call print("region1 Potential energy " // e_bulk) - call print("region1 Potential lattice") - call print(bulk_region1%lattice) - -#ifdef HAVE_TB - if (do_tb_defaults .and. associated(region1_pot%simple%tb)) then - region1_pot%simple%tb%tbsys%tbmodel%default_fermi_E = region1_pot%simple%tb%fermi_E - region1_pot%simple%tb%tbsys%tbmodel%has_default_fermi_E = .true. - region1_pot%simple%tb%tbsys%tbmodel%default_band_width = (region1_pot%simple%tb%fermi_E - minval(TB_evals(region1_pot%simple%tb)))*1.2_dp - region1_pot%simple%tb%tbsys%tbmodel%has_default_band_width = .true. - region1_pot%simple%tb%tbsys%tbmodel%default_fermi_T = 0.2_dp - region1_pot%simple%tb%tbsys%tbmodel%has_default_fermi_T = .true. - - region1_pot%simple%tb%tbsys%scf%conv_tol = 1e-8_dp - endif -#endif - - ! set up region2 stuff - bulk_region2 = reference_bulk -! call initialise(region2_pot, "Simple", region2_pot) - call set_cutoff(bulk_region2, cutoff(region2_pot)+0.5_dp) - call calc_connect(bulk_region2) - if (minimise_bulk) then - call print("MINIMISING bulk in region2 potential", PRINT_VERBOSE) - call verbosity_push_decrement() - it = minim(region2_pot, at=bulk_region2, method='cg', convergence_tol=0.001_dp, max_steps=100, linminroutine='NR_LINMIN', & - do_print = .false., do_lat = .true.) - call verbosity_pop() - end if - call calc(region2_pot, bulk_region2, energy=e_bulk) - call print("region2 Potential Bulk energy = " // e_bulk) - call print("region2 Potential lattice") - call print(bulk_region2%lattice) - -#ifdef HAVE_TB - if (do_tb_defaults .and. associated(region2_pot%simple%tb)) then - region2_pot%simple%tb%tbsys%tbmodel%default_fermi_E = region2_pot%simple%tb%fermi_E - region2_pot%simple%tb%tbsys%tbmodel%has_default_fermi_E = .true. - region2_pot%simple%tb%tbsys%tbmodel%default_band_width = (region2_pot%simple%tb%fermi_E - minval(TB_evals(region2_pot%simple%tb)))*1.2_dp - region2_pot%simple%tb%tbsys%tbmodel%has_default_band_width = .true. - region2_pot%simple%tb%tbsys%tbmodel%default_fermi_T = 0.2_dp - region2_pot%simple%tb%tbsys%tbmodel%has_default_fermi_T = .true. - - region2_pot%simple%tb%tbsys%scf%conv_tol = 1e-8_dp - endif -#endif - r_scale_pot1 = 1.0_dp - if (do_rescale_r) then - ! compute scale, assuming that lattices are only off by a uniform scale - r_scale_pot1 = maxval(abs(bulk_region1%lattice(:,1)))/maxval(abs(bulk_region2%lattice(:,1))) - endif - - E_scale_pot1 = 1.0_dp - if (do_rescale_E) then - call bulk_modulus(region2_pot, bulk_region2, B_region2, vol, minimise_bulk) - call bulk_modulus(region1_pot, bulk_region1, B_region1, vol, minimise_bulk) - - call print('Bulk modulus in region 1 = '//B_region1//' GPa') - call print('Bulk modulus in region 2 = '//B_region2//' GPa') - - E_scale_pot1 = B_region2/(B_region1*r_scale_pot1**3) - end if - - call finalise(bulk_region1) - call finalise(bulk_region2) - end subroutine do_reference_bulk - - subroutine do_minimise_mm(relax_pot, at, minim_mm_method, minim_mm_tol, minim_mm_max_steps, & - minim_mm_linminroutine, minim_mm_do_pos, minim_mm_do_lat, minim_mm_do_print, & - minim_mm_args_str, minim_mm_eps_guess, minim_inoutput_movie, & - minim_cinoutput_movie, & - constrained_list) - type(Potential), intent(inout) :: relax_pot - type(Atoms), intent(inout) :: at - character(len=*), intent(in) :: minim_mm_method - real(dp), intent(in) :: minim_mm_tol - integer, intent(in) :: minim_mm_max_steps - character(len=*), intent(in) :: minim_mm_linminroutine - logical, intent(in) :: minim_mm_do_pos, minim_mm_do_lat, minim_mm_do_print - character(len=*), intent(in) :: minim_mm_args_str - real(dp), intent(in) :: minim_mm_eps_guess - type(Inoutput), intent(inout) :: minim_inoutput_movie - type(CInoutput), intent(inout) :: minim_cinoutput_movie - integer, intent(in) :: constrained_list(:) - - integer, pointer :: fixed_pot(:) - integer :: mm_steps - - if (.not. assign_pointer(at, "fixed_pot", fixed_pot)) then - call add_property(at, "fixed_pot", 0) - if (.not. assign_pointer(at, "fixed_pot", fixed_pot)) & - call system_abort("do_minimise_mm failed to assign pointer for property 'fixed_pot'") - endif - - if (minval(constrained_list) < 1 .or. maxval(constrained_list) > size(fixed_pot)) then - call print("do_minimise_mm: size(fixed_pot) " // size(fixed_pot) // & - " size(constrained_list) " // size(constrained_list), PRINT_ALWAYS) - call print("do_minimise_mm: constrained_list", PRINT_ALWAYS) - call print(constrained_list, PRINT_ALWAYS) - call system_abort("do_minimise_mm with invalid value in constrained list") - endif - - fixed_pot = 0 - fixed_pot(constrained_list) = 1 - - call verbosity_push_decrement() - mainlog%prefix="NESTED_MINIM" - mm_steps = minim(relax_pot, at, minim_mm_method, minim_mm_tol, minim_mm_max_steps, & - linminroutine=minim_mm_linminroutine, do_pos=minim_mm_do_pos, do_lat=minim_mm_do_lat, & - do_print=minim_mm_do_print, args_str=minim_mm_args_str, & - eps_guess=minim_mm_eps_guess, print_inoutput=minim_inoutput_movie, & - print_cinoutput=minim_cinoutput_movie) - mainlog%prefix="" - call verbosity_pop() - call print("Potential_local_e_mix_calc minimise_mm got mm_steps " // mm_steps, PRINT_VERBOSE) - - call calc_connect(at) - - call print("MM minimisation done in "//mm_steps//" steps", PRINT_VERBOSE) - - fixed_pot=0 - - end subroutine do_minimise_mm - diff --git a/src/Potentials/Potential_Local_E_Mix_header.f95 b/src/Potentials/Potential_Local_E_Mix_header.f95 deleted file mode 100644 index 6839aaf871..0000000000 --- a/src/Potentials/Potential_Local_E_Mix_header.f95 +++ /dev/null @@ -1,83 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Local Energy Mixing header stuff to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - public :: Potential_Local_E_Mix - type Potential_Local_E_Mix - type(Potential), pointer :: pot_region1 - type(Potential), pointer :: pot_region2 - logical :: terminate = .true. - real(dp):: r_scale_pot1 = 1.0_dp, E_scale_pot1 = 1.0_dp - - type(Potential) :: relax_pot - - character(STRING_LENGTH) :: run_suffix - logical :: minimise_mm - character(STRING_LENGTH) :: minim_mm_method - real(dp) :: minim_mm_tol, minim_mm_eps_guess - integer :: minim_mm_max_steps - character(STRING_LENGTH) :: minim_mm_linminroutine - logical :: minim_mm_do_pos, minim_mm_do_lat - logical :: minim_mm_do_print - character(STRING_LENGTH) :: minim_mm_args_str - - type(Dictionary) :: create_hybrid_weights_params - - type(Inoutput), pointer :: minim_inoutput_movie - type(CInoutput), pointer :: minim_cinoutput_movie - - end type Potential_Local_E_Mix - - interface Print - module procedure potential_local_e_mix_print - end interface Print - - interface Cutoff - module procedure potential_local_e_mix_cutoff - end interface Cutoff - - interface Calc - module procedure potential_local_e_mix_calc - end interface Calc - - interface Initialise - module procedure potential_local_e_mix_initialise - end interface Initialise - - interface Finalise - module procedure potential_local_e_mix_finalise - end interface Finalise diff --git a/src/Potentials/Potential_Local_E_Mix_routines.f95 b/src/Potentials/Potential_Local_E_Mix_routines.f95 deleted file mode 100644 index 896a148b0b..0000000000 --- a/src/Potentials/Potential_Local_E_Mix_routines.f95 +++ /dev/null @@ -1,435 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Local Energy Mixing routines to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - recursive subroutine potential_local_e_mix_initialise(this, args_str, region1_pot, region2_pot, reference_bulk, mpi_obj, error) - type(Potential_Local_E_Mix), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(Potential), intent(inout), target :: region1_pot, region2_pot - type(Atoms), optional, intent(inout) :: reference_bulk - type(MPI_Context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(Dictionary) :: params - logical :: minimise_bulk - logical :: do_rescale_r, do_rescale_E, do_tb_defaults - - INIT_ERROR(error) - - call initialise(params) - call param_register(params, "run_suffix", "", this%run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "r_scale", "1.0", this%r_scale_pot1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "E_scale", "1.0", this%E_scale_pot1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "terminate", "T", this%terminate, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "minimise_bulk", "F", minimise_bulk, help_string="No help yet. This source file was $LastChangedBy$") - - call param_register(params, "do_rescale_r", "F", do_rescale_r, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "do_rescale_E", "F", do_rescale_E, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "do_tb_defaults", "T", do_tb_defaults, help_string="No help yet. This source file was $LastChangedBy$") - - call param_register(params, "minimise_mm", "F", this%minimise_mm, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "minim_mm_method", "cg", this%minim_mm_method, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_tol', '1e-6', this%minim_mm_tol, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_eps_guess', '1e-4', this%minim_mm_eps_guess, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_max_steps', '500', this%minim_mm_max_steps, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_linminroutine', 'FAST_LINMIN', this%minim_mm_linminroutine, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_pos', 'T', this%minim_mm_do_pos, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_lat', 'F', this%minim_mm_do_lat, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_print', 'F', this%minim_mm_do_print, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_args_str', '', this%minim_mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Local_E_Mix_initialise args_str') ) then - RAISE_ERROR("Potential_Local_E_Mix_initialise failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - call initialise(this%create_hybrid_weights_params) - call read_string(this%create_hybrid_weights_params, args_str) - call remove_value(this%create_hybrid_weights_params, 'run_suffix') - call remove_value(this%create_hybrid_weights_params, 'r_scale') - call remove_value(this%create_hybrid_weights_params, 'E_scale') - call remove_value(this%create_hybrid_weights_params, 'terminate') - call remove_value(this%create_hybrid_weights_params, 'minimise_bulk') - call remove_value(this%create_hybrid_weights_params, 'do_rescale_r') - call remove_value(this%create_hybrid_weights_params, 'do_rescale_E') - call remove_value(this%create_hybrid_weights_params, 'do_tb_defaults') - call remove_value(this%create_hybrid_weights_params, 'minimise_mm') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_method') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_tol') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_eps_guess') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_max_steps') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_linminroutine') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_pos') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_lat') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_print') - call remove_value(this%create_hybrid_weights_params, 'minim_mm_args_str') - - if (this%minimise_mm) then - call initialise(this%relax_pot, "Simple", region2_pot) - endif - - if (do_rescale_r .or. do_rescale_E .or. do_tb_defaults) then - if (.not. present(reference_bulk)) then - RAISE_ERROR("potential_local_e_mix_initialise got do_rescale_r="//do_rescale_r//" do_rescale_E="//do_rescale_E//" do_tb_defaults="//do_tb_defaults//" but reference_bulk is not present", error) - endif - - call do_reference_bulk(reference_bulk, region1_pot, region2_pot, minimise_bulk, do_rescale_r, do_rescale_E, & - this%r_scale_pot1, this%E_scale_pot1, do_tb_defaults) - - endif - - if (this%r_scale_pot1 <= 0.0_dp) this%r_scale_pot1 = 1.0_dp - if (this%E_scale_pot1 <= 0.0_dp) this%E_scale_pot1 = 1.0_dp - - call print ("Rescaling positions in region1 potential by " // this%r_scale_pot1 // " to match lattice constants") - call print ("Rescaling energies in region1 potential by " // this%E_scale_pot1 // " to match bulk modulus") - - this%pot_region1 => region1_pot - this%pot_region2 => region2_pot - - end subroutine - - recursive subroutine potential_local_e_mix_finalise(this) - type(Potential_Local_E_Mix), intent(inout) :: this - - call finalise(this%pot_region1) - call finalise(this%pot_region2) - - deallocate(this%pot_region1) - deallocate(this%pot_region2) - end subroutine potential_local_e_mix_finalise - - - recursive function potential_local_e_mix_cutoff(this) - type(Potential_Local_E_Mix), intent(in) :: this - real(dp) :: potential_local_e_mix_cutoff - - potential_local_e_mix_cutoff = max(cutoff(this%pot_region1), cutoff(this%pot_region2)) - end function potential_local_e_mix_cutoff - - recursive subroutine potential_local_e_mix_print(this, file) - type(Potential_Local_E_Mix), intent(inout) :: this - type(Inoutput),intent(inout),optional:: file - - call print('Local_E_Mix potential:', file=file) - call print('Potential in region 1 (embedded):', file=file) - call print('=======================', file=file) - call print(this%pot_region1, file=file) - call print('') - call print('Potential in region 2 (surroundings):', file=file) - call print('=======================', file=file) - call print(this%pot_region2, file=file) - call print('do_terminate ' // this%terminate, file=file) - call print('r_scale_pot1=' // this%r_scale_pot1 // ' E_scale_pot1=' // this%E_scale_pot1, file=file) - call print('') - end subroutine potential_local_e_mix_print - - recursive subroutine potential_local_e_mix_calc(this, at, args_str, error) - type(Potential_Local_E_Mix), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - logical :: calc_weights - integer :: core_hops, transition_hops, buffer_hops - type(Dictionary) :: params, calc_create_hybrid_weights_params - type(Table) :: region1_table - integer :: i - integer, pointer :: hybrid(:), hybrid_mark(:) - character(len=STRING_LENGTH) :: run_suffix - - INIT_ERROR(error) - - if (.not. associated(this%pot_region1) .or. .not. associated(this%pot_region2)) & - call system_abort("Potential_Local_E_Mix_calc: this%pot_region1 or this%pot_region2 not initialised") - - call initialise(params) - call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "calc_weights", "F", calc_weights, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "core_hops", "0", core_hops, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Local_E_Mix_Calc args_str') ) & - call system_abort("Potential_Local_E_Mix_calc_energy failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - - if (calc_weights) then - call print("Potential_Local_E_Mix_calc got calc_weights core_hops " // core_hops, PRINT_VERBOSE) - call add_property(at, "weight_region1", 0.0_dp) - call add_property(at, "hybrid_mark"//trim(run_suffix), HYBRID_NO_MARK) - if (.not. assign_pointer(at, "hybrid"//trim(run_suffix), hybrid)) & - call system_abort("QC_QUIP_calc at doesn't have hybrid property and calc_weights was specified") - if (.not. assign_pointer(at, "hybrid_mark"//trim(run_suffix), hybrid_mark)) & - call system_abort("QC_QUIP_calc Failed to add hybrid_mark property to at") - - call calc_connect(at) - - call wipe(region1_table) - hybrid_mark = HYBRID_NO_MARK - do i=1, size(hybrid) - if (hybrid(i) /= 0) call append(region1_table, (/ i, 0, 0, 0 /) ) - end do - call bfs_grow(at, region1_table, core_hops, nneighb_only = .false.) - hybrid_mark(int_part(region1_table,1)) = HYBRID_ACTIVE_MARK - - call read_string(calc_create_hybrid_weights_params, write_string(this%create_hybrid_weights_params)) - call read_string(calc_create_hybrid_weights_params, trim(args_str), append=.true.) - call create_hybrid_weights(at, write_string(calc_create_hybrid_weights_params)) - endif - - call calc_local_energy_mix(this, at, args_str, error=error) - PASS_ERROR(error) - - end subroutine potential_local_e_mix_calc - - recursive subroutine calc_local_energy_mix(this, at, args_str, error) - type(Potential_Local_E_Mix), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - real(dp) :: energy, virial(3,3) - real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:) - - ! local variables - integer :: i - integer, pointer :: hybrid_mark(:), index(:), termindex(:) - real(dp), pointer :: weight(:), weight_region1(:), rescale(:), c_weight(:) - real(dp), pointer :: f_cluster(:,:), local_e_cluster(:) - real(dp), allocatable :: weight_saved(:), local_e_weight(:), local_e_region2(:), local_e_region1(:), f_region1(:,:) - real(dp) :: e_cluster - logical :: dummy - type(Atoms) :: cluster - type(Table) :: cluster_info - type(Dictionary) :: params - character(STRING_LENGTH) :: cc_args_str - - real(dp), pointer :: local_e_pot1(:), local_e_pot2(:) - character(STRING_LENGTH) :: calc_energy, calc_force, calc_local_energy, calc_virial, calc_local_virial, local_energy_args_str, local_energy_name, run_suffix - - INIT_ERROR(error) - - allocate(weight_saved(at%N)) - allocate(local_e_weight(at%N)) - allocate(local_e_region2(at%N)) - allocate(local_e_region1(at%N)) - allocate(f_region1(3,at%N)) - - call system_timer("calc_local_energy_mix") - - call initialise(params) - call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'energy', '', calc_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'force', '', calc_force, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'local_energy', '', calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'virial', '', calc_virial, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'local_virial', '', calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Local_E_Mix args_str') ) & - call system_abort("Potential_Local_E_Mix failed to parse args_str='"//trim(args_str)//"'") - call finalise(params) - - if(.not. (associated(this%pot_region1) .and. associated(this%pot_region2))) then - call system_abort('local_e_mix_calc_energy_mix: potential for region 1 or region 2 is not initialised') - end if - - ! check for a compatible weight property, create it if necessary - if (.not.assign_pointer(at, 'weight', weight)) then - call add_property(at, 'weight', 1.0_dp) - if(.not.assign_pointer(at, 'weight', weight)) & - call system_abort("Impossible failure to create weight property in calc_local_energy_mix") - weight_saved = 1.0_dp - else - weight_saved = weight - endif - ! check for a compatible hybrid and weight_region1 property. they must be present - if (.not.assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) & - call system_abort('hybrid_calc_energy_mix: atoms structure has no "hybrid_mark'//trim(run_suffix)//'" property') - if (.not.assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1)) & - call system_abort('hybrid_calc_energy_mix: atoms structure has no "weight_region1'//trim(run_suffix)//'" property') - - if(.not. all(hybrid_mark == HYBRID_NO_MARK)) then - if(len_trim(calc_virial) > 0 .or. len_trim(calc_local_virial) > 0) then - RAISE_ERROR('hybrid_calc_energy_mix: virial or local_virial not yet implemented when QM region is active', error) - end if - endif - - ! if hybrid is active, carve cluster and do minimisation if necessary - if(any(hybrid_mark /= HYBRID_NO_MARK)) then - call initialise(params) - call set_value(params, 'terminate', this%terminate) - call set_value(params, 'cluster_allow_modification', 'F') - call set_value(params, 'cluster_periodic_x', 'T') - call set_value(params, 'cluster_periodic_y', 'T') - call set_value(params, 'cluster_periodic_z', 'T') - call set_value(params, 'randomise_buffer', 'F') - cc_args_str = write_string(params) - call finalise(params) - cluster_info = create_cluster_info_from_mark(at, cc_args_str) - call carve_cluster(at, cc_args_str, cluster_info, cluster) - - if (this%minimise_mm) then - dummy = assign_pointer(cluster, 'index', index) - call do_minimise_mm(this%relax_pot, at, this%minim_mm_method, this%minim_mm_tol, this%minim_mm_max_steps, & - this%minim_mm_linminroutine, this%minim_mm_do_pos, this%minim_mm_do_lat, this%minim_mm_do_print, & - this%minim_mm_args_str, this%minim_mm_eps_guess, this%minim_inoutput_movie, & - this%minim_cinoutput_movie, index) - endif - endif - - if (len_trim(calc_local_energy) > 0) then - call assign_property_pointer(at, trim(local_energy_name), at_local_energy_ptr, error=error) - PASS_ERROR(error) - local_energy_name = trim(calc_local_energy) - local_energy_args_str = "" - else - local_energy_name = "LEMIX_local_energy" - PASS_ERROR(error) - call add_property(at, trim(local_energy_name), 0.0_dp, ptr=at_local_energy_ptr) - local_energy_args_str = "local_energy="//trim(local_energy_name) - endif - if (len_trim(calc_force) > 0) then - call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) - PASS_ERROR(error) - endif - - ! do calculation in region 2 first - weight = weight_saved-weight_region1 ! "negate" the weights - - call system_timer("calc_local_energy_mix/calc_region_2") - call Calc(this%pot_region2, at, args_str=args_str//" "//trim(local_energy_args_str)) - call system_timer("calc_local_energy_mix/calc_region_2") - if (len_trim(calc_energy) > 0) call get_param_value(at, trim(calc_energy), energy) - local_e_region2 = at_local_energy_ptr - - if (assign_pointer(at, "local_e_pot2", local_e_pot2)) local_e_pot2 = local_e_region2 - - call system_timer("calc_local_energy_mix/prep_cluster") - if(len_trim(calc_local_energy) > 0) then - local_e_weight = 1.0_dp-weight_region1 - at_local_energy_ptr = local_e_weight * local_e_region2 - endif - - ! if there are no marked atoms, we are done, so return - if(all(hybrid_mark == HYBRID_NO_MARK)) then - ! restore weights - weight = weight_saved - call print('No REGION 1 marks, not carving REGION 1 cluster') - return - end if - - ! Now compute region 1 - - ! copy weight_region1 back into cluster for region1 calculation - if (.not.assign_pointer(cluster, 'weight', c_weight)) & - call system_abort("calc_local_energy_mix didn't find weight property for cluster") - if (.not. assign_pointer(cluster, 'index', index)) & - call system_abort("calc_local_energy_mix didn't find index property for cluster") - c_weight = weight_region1(index) - - ! rescale cluster - call set_lattice(cluster, this%r_scale_pot1 * cluster%lattice, scale_positions=.true.) - - call calc_connect(cluster) - - call system_timer("calc_local_energy_mix/prep_cluster") - call system_timer("calc_local_energy_mix/calc_region_1") - call Calc(this%pot_region1, cluster, args_str = args_str//" solver=DIAG_GF SCF=GLOBAL_U "//trim(local_energy_args_str)) - if (len_trim(calc_force) > 0) then - call assign_property_pointer(cluster, trim(calc_force), f_cluster, error=error) - PASS_ERROR_WITH_INFO("Potential_Local_E_Mix failed to assign pointer for region 1 force property '"//trim(calc_force)//"'", error) - ! scale back forces - f_cluster = f_cluster*this%E_scale_pot1*this%r_scale_pot1 - endif - if (len_trim(calc_energy) > 0) call get_param_value(at, trim(calc_energy), e_cluster) - call assign_property_pointer(at, trim(local_energy_name), local_e_cluster, error=error) - PASS_ERROR_WITH_INFO("Potential_Local_E_Mix failed to assign pointer for region 1 local_energy property '"//trim(calc_local_energy)//"'", error) - - if (len_trim(calc_energy) > 0) e_cluster = e_cluster*this%E_scale_pot1 - if (len_trim(calc_local_energy) > 0) local_e_cluster = local_e_cluster*this%E_scale_pot1 - call system_timer("calc_local_energy_mix/calc_region_1") - - call system_timer("calc_local_energy_mix/combine") - if(current_verbosity() > PRINT_VERBOSE) call write(cluster, "cluster.cfg") - - ! redistribute local energies and weights from the cluster to region 1 - if (.not. assign_pointer(cluster, 'index', index)) & - call system_abort('calc_local_energy_mix: cluster structure has no "index" property') - if (.not. assign_pointer(cluster, 'rescale', rescale)) & - call system_abort('calc_local_energy_mix: cluster structure has no "rescale" property') - if (.not. assign_pointer(cluster, 'termindex', termindex)) & - call system_abort('calc_local_energy_mix: cluster structure has no "termindex" property') - ! first add terms arising from the fact that the position of the rescaled termination atoms - ! depends on the position of the atoms they are terminating - local_e_region1 = 0.0_dp - f_region1 = 0.0_dp - if(len_trim(calc_force) > 0) then - do i=1,cluster%N - if(termindex(i) > 0) & - f_cluster(:,termindex(i)) = f_cluster(:,termindex(i)) + (1.0_dp-rescale(i))*f_cluster(:,i) - end do - end if - ! now do the redistribution - do i=1,cluster%N - if(len_trim(calc_force) > 0) f_region1(:,index(i)) = f_region1(:,index(i)) + f_cluster(:,i)*rescale(i) - if(len_trim(calc_local_energy) > 0) local_e_region1(index(i)) = local_e_region1(index(i)) + local_e_cluster(i) - end do - - if (assign_pointer(at, "local_e_pot1", local_e_pot1)) local_e_pot1 = local_e_region1 - - ! finally add region 1 stuff to the output variables - if(len_trim(calc_energy) > 0) then - energy = energy + e_cluster - call set_param_value(at, trim(calc_energy), energy) - endif - if(len_trim(calc_local_energy) > 0) then - local_e_weight = weight_region1 - at_local_energy_ptr = at_local_energy_ptr + local_e_weight * local_e_region1 - endif - if(len_trim(calc_force) > 0) at_force_ptr = at_force_ptr + f_region1 - - weight = weight_saved - - call finalise(cluster) - - deallocate(weight_saved) - deallocate(local_e_weight) - deallocate(local_e_region2) - deallocate(local_e_region1) - deallocate(f_region1) - - if (len_trim(calc_local_energy) == 0) call remove_property(at, trim(local_energy_name)) - - call system_timer("calc_local_energy_mix/combine") - call system_timer("calc_local_energy_mix") - end subroutine calc_local_energy_mix diff --git a/src/Potentials/Potential_ONIOM_header.f95 b/src/Potentials/Potential_ONIOM_header.f95 deleted file mode 100644 index 13add01c71..0000000000 --- a/src/Potentials/Potential_ONIOM_header.f95 +++ /dev/null @@ -1,81 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X ONIOM header stuff to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - - public :: Potential_ONIOM - type Potential_ONIOM - type(Potential), pointer :: pot_region1 - type(Potential), pointer :: pot_region2 - logical :: terminate = .true. - real(dp):: r_scale_pot1 = 1.0_dp, E_scale_pot1 = 1.0_dp - - type(Potential) :: relax_pot - - character(STRING_LENGTH) :: run_suffix - logical :: minimise_mm - character(STRING_LENGTH) :: minim_mm_method - real(dp) :: minim_mm_tol, minim_mm_eps_guess - integer :: minim_mm_max_steps - character(STRING_LENGTH) :: minim_mm_linminroutine - logical :: minim_mm_do_pos, minim_mm_do_lat - logical :: minim_mm_do_print - character(STRING_LENGTH) :: minim_mm_args_str - - type(Inoutput), pointer :: minim_inoutput_movie - type(CInoutput), pointer :: minim_cinoutput_movie - - end type Potential_ONIOM - - interface Print - module procedure potential_oniom_print - end interface Print - - interface Cutoff - module procedure potential_oniom_cutoff - end interface Cutoff - - interface Calc - module procedure potential_oniom_calc - end interface Calc - - interface Initialise - module procedure potential_oniom_initialise - end interface Initialise - - interface Finalise - module procedure potential_oniom_finalise - end interface Finalise diff --git a/src/Potentials/Potential_ONIOM_routines.f95 b/src/Potentials/Potential_ONIOM_routines.f95 deleted file mode 100644 index 2542611e41..0000000000 --- a/src/Potentials/Potential_ONIOM_routines.f95 +++ /dev/null @@ -1,410 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X ONIOM routines to be included in Potential.f95 -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - recursive subroutine potential_ONIOM_initialise(this, args_str, region1_pot, region2_pot, reference_bulk, mpi_obj, error) - type(Potential_ONIOM), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(Potential), intent(inout), target :: region1_pot, region2_pot - type(Atoms), optional, intent(inout) :: reference_bulk - type(MPI_Context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(Dictionary) :: params - logical :: minimise_bulk - logical :: do_rescale_r, do_rescale_E, do_tb_defaults - - INIT_ERROR(error) - - call initialise(params) - call param_register(params, "run_suffix", "", this%run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - - call param_register(params, "r_scale", "1.0", this%r_scale_pot1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "E_scale", "1.0", this%E_scale_pot1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "terminate", "T", this%terminate, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "minimise_bulk", "F", minimise_bulk, help_string="No help yet. This source file was $LastChangedBy$") - - call param_register(params, "do_rescale_r", "F", do_rescale_r, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "do_rescale_E", "F", do_rescale_E, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "do_tb_defaults", "F", do_tb_defaults, help_string="No help yet. This source file was $LastChangedBy$") - - call param_register(params, "minimise_mm", "F", this%minimise_mm, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "minim_mm_method", "cg", this%minim_mm_method, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_tol', '1e-6', this%minim_mm_tol, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_eps_guess', '1e-4', this%minim_mm_eps_guess, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_max_steps', '500', this%minim_mm_max_steps, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_linminroutine', 'FAST_LINMIN', this%minim_mm_linminroutine, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_pos', 'T', this%minim_mm_do_pos, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_lat', 'F', this%minim_mm_do_lat, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_do_print', 'F', this%minim_mm_do_print, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'minim_mm_args_str', '', this%minim_mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_ONIOM_initialise args_str') ) then - RAISE_ERROR("Potential_ONIOM_initialise failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - - if (this%minimise_mm) then - call initialise(this%relax_pot, "Simple", region2_pot) - endif - - if (do_rescale_r .or. do_rescale_E .or. do_tb_defaults) then - if (.not. present(reference_bulk)) then - RAISE_ERROR("potential_local_e_mix_initialise got do_rescale_r="//do_rescale_r//" do_rescale_E="//do_rescale_E//" do_tb_defaults="//do_tb_defaults//" but reference_bulk is not present", error) - endif - - call do_reference_bulk(reference_bulk, region1_pot, region2_pot, minimise_bulk, do_rescale_r, do_rescale_E, & - this%r_scale_pot1, this%E_scale_pot1, do_tb_defaults) - - endif - - if (this%r_scale_pot1 <= 0.0_dp) this%r_scale_pot1 = 1.0_dp - if (this%E_scale_pot1 <= 0.0_dp) this%E_scale_pot1 = 1.0_dp - - call print ("Rescaling positions in region1 potential by " // this%r_scale_pot1 // " to match lattice constants") - call print ("Rescaling energies in region1 potential by " // this%E_scale_pot1 // " to match bulk modulus") - - this%pot_region1 => region1_pot - this%pot_region2 => region2_pot - - end subroutine - - recursive subroutine potential_ONIOM_finalise(this) - type(Potential_ONIOM), intent(inout) :: this - - call finalise(this%pot_region1) - call finalise(this%pot_region2) - - deallocate(this%pot_region1) - deallocate(this%pot_region2) - end subroutine potential_ONIOM_finalise - - - recursive function potential_ONIOM_cutoff(this) - type(Potential_ONIOM), intent(in) :: this - real(dp) :: potential_ONIOM_cutoff - - potential_ONIOM_cutoff = max(cutoff(this%pot_region1), cutoff(this%pot_region2)) - end function potential_ONIOM_cutoff - - recursive subroutine potential_ONIOM_print(this, file) - type(Potential_ONIOM), intent(inout) :: this - type(Inoutput),intent(inout),optional:: file - - call print('ONIOM potential:', file=file) - call print('Potential in region 1 (embedded):', file=file) - call print('=======================', file=file) - call print(this%pot_region1, file=file) - call print('') - call print('Potential in region 2 (surroundings):', file=file) - call print('=======================', file=file) - call print(this%pot_region2, file=file) - call print('do_terminate ' // this%terminate, file=file) - call print('r_scale_pot1=' // this%r_scale_pot1 // ' E_scale_pot1=' // this%E_scale_pot1, file=file) - call print('') - end subroutine potential_ONIOM_print - - - recursive subroutine potential_ONIOM_calc(this, at, args_str, error) - type(Potential_ONIOM), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - logical :: calc_weights - integer :: core_hops - type(Dictionary) :: params - type(Table) :: region1_table - integer :: i - integer, pointer :: hybrid(:), hybrid_mark(:) - character(len=STRING_LENGTH) :: run_suffix - - INIT_ERROR(error) - - if (.not. associated(this%pot_region1) .or. .not. associated(this%pot_region2)) then - RAISE_ERROR("Potential_ONIOM_calc: this%pot_region1 or this%pot_region2 not initialised", error) - endif - - call initialise(params) - call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "calc_weights", "F", calc_weights, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "core_hops", "0", core_hops, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_ONIOM_Calc args_str') ) then - RAISE_ERROR("Potential_ONIOM_calc_energy failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(params) - if (calc_weights) then - call print("Potential_ONIOM_calc got calc_weights core_hops " // core_hops, PRINT_VERBOSE) - call add_property(at, "weight_region1"//trim(run_suffix), 0.0_dp) - call add_property(at, "hybrid_mark"//trim(run_suffix), HYBRID_NO_MARK) - if (.not. assign_pointer(at, "hybrid"//trim(run_suffix), hybrid)) then - RAISE_ERROR("QC_QUIP_calc at doesn't have hybrid"//trim(run_suffix)//" property and calc_weights was specified", error) - endif - if (.not. assign_pointer(at, "hybrid_mark"//trim(run_suffix), hybrid_mark)) then - RAISE_ERROR("QC_QUIP_calc Failed to add hybrid_mark"//trim(run_suffix)//" property to at", error) - endif - - call calc_connect(at) - - call wipe(region1_table) - hybrid_mark = HYBRID_NO_MARK - do i=1, size(hybrid) - if (hybrid(i) /= 0) call append(region1_table, (/ i, 0, 0, 0 /) ) - end do - call bfs_grow(at, region1_table, core_hops, nneighb_only = .false.) - hybrid_mark(int_part(region1_table,1)) = HYBRID_ACTIVE_MARK - - call create_hybrid_weights(at, args_str="transition_hops=0 buffer_hops=0") - endif - - call calc_oniom(this, at, args_str, error) - PASS_ERROR(error) - - end subroutine potential_ONIOM_calc - - - recursive subroutine calc_oniom(this, at, args_str, error) - type(Potential_ONIOM), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - real(dp) :: energy, virial(3,3) - real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:), at_local_virial_ptr(:,:) - - type(Atoms) :: cluster - type(Table) :: cluster_info - type(Dictionary) :: params - character(STRING_LENGTH) :: cc_args_str - - real(dp) :: cluster_energy_1, cluster_energy_2 - real(dp), allocatable :: cluster_local_e_1(:), cluster_local_e_2(:) - real(dp), pointer :: cluster_force_ptr(:,:), cluster_local_energy_ptr(:), cluster_local_virial_ptr(:,:) - real(dp), allocatable :: cluster_force_1(:,:), cluster_force_2(:,:), cluster_local_virial_1(:,:), cluster_local_virial_2(:,:) - real(dp) :: cluster_virial_1(3,3), cluster_virial_2(3,3) - - integer, pointer :: hybrid_mark(:), index(:), termindex(:) - real(dp), pointer :: rescale(:) - logical :: dummy - integer i - - character(STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, run_suffix - - INIT_ERROR(error) - - call system_timer("calc_oniom") - - call initialise(params) - call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "energy", "", calc_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "force", "", calc_force, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "virial", "", calc_virial, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "local_energy", "", calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "local_virial", "", calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Calc_ONIOM args_str')) then - RAISE_ERROR("Calc_ONIOM failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - if(.not. (associated(this%pot_region1) .and. associated(this%pot_region2))) then - RAISE_ERROR('calc_oniom: potential for region 1 or region 2 is not initialised', error) - end if - - ! Check for a compatible hybrid_mark property. It must be present. - if (.not.assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then - RAISE_ERROR('calc_oniom: atoms structure has no "hybrid_mark'//trim(run_suffix)//'" property', error) - endif - - ! if hybrid is active, carve cluster and do minimisation if necessary - if(any(hybrid_mark /= HYBRID_NO_MARK)) then - - call initialise(params) - call set_value(params, 'terminate', this%terminate) - call set_value(params, 'cluster_allow_modification', 'F') - call set_value(params, 'cluster_periodic_x', 'T') - call set_value(params, 'cluster_periodic_y', 'T') - call set_value(params, 'cluster_periodic_z', 'T') - call set_value(params, 'randomise_buffer', 'F') - cc_args_str = write_string(params) - cluster_info = create_cluster_info_from_mark(at, cc_args_str) - call carve_cluster(at, cc_args_str, cluster_info, cluster) - - - if (this%minimise_mm) then - dummy = assign_pointer(cluster, 'index', index) - call do_minimise_mm(this%relax_pot, at, this%minim_mm_method, this%minim_mm_tol, this%minim_mm_max_steps, & - this%minim_mm_linminroutine, this%minim_mm_do_pos, this%minim_mm_do_lat, this%minim_mm_do_print, & - this%minim_mm_args_str, this%minim_mm_eps_guess, this%minim_inoutput_movie, & - this%minim_cinoutput_movie, index) - endif - endif - - if (len_trim(calc_force) > 0) then - call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) - PASS_ERROR(error) - endif - if (len_trim(calc_local_energy) > 0) then - call assign_property_pointer(at, trim(calc_local_energy), at_local_energy_ptr, error=error) - PASS_ERROR(error) - endif - if (len_trim(calc_local_virial) > 0) then - call assign_property_pointer(at, trim(calc_local_virial), at_local_virial_ptr, error=error) - PASS_ERROR(error) - endif - - ! do calculation in whole system first using pot_region2 - call system_timer("calc_oniom/calc_whole_sys") - call Calc(this%pot_region2, at, args_str=args_str) - call system_timer("calc_oniom/calc_whole_sys") - if (len_trim(calc_energy) > 0) call get_param_value(at, trim(calc_energy), energy) - if (len_trim(calc_virial) > 0) call get_param_value(at, trim(calc_virial), virial) - - call system_timer("calc_oniom/prep_cluster") - - ! if there are no marked atoms, we are done, so return - if(all(hybrid_mark == HYBRID_NO_MARK)) then - call print('WARNING: ONIOM with No REGION 1 marks, not carving REGION 1 cluster') - return - end if - - ! rescale cluster - call set_lattice(cluster, this%r_scale_pot1 * cluster%lattice, scale_positions=.true.) - - call calc_connect(cluster) - - call system_timer("calc_oniom/prep_cluster") - - call system_timer("calc_oniom/calc_cluster_1") - allocate(cluster_force_1(3,cluster%N)) - allocate(cluster_local_e_1(cluster%N)) - allocate(cluster_local_virial_1(9,cluster%N)) - call Calc(this%pot_region1, cluster, args_str=args_str) - if (len_trim(calc_force) > 0) then - call assign_property_pointer(cluster, trim(calc_force), cluster_force_ptr, error=error) - PASS_ERROR_WITH_INFO("Calc_ONIOM failed to get value for force property '"//trim(calc_force)//"'", error) - cluster_force_1 = cluster_force_ptr*this%E_scale_pot1*this%r_scale_pot1 - endif - if (len_trim(calc_virial) > 0) then - call get_param_value(cluster, trim(calc_virial), cluster_virial_1) - cluster_virial_1 = cluster_virial_1*this%E_scale_pot1 - endif - if (len_trim(calc_energy) > 0) then - call get_param_value(cluster, trim(calc_energy), cluster_energy_1) - cluster_energy_1 = cluster_energy_1*this%E_scale_pot1 - endif - if (len_trim(calc_local_energy) > 0) then - call assign_property_pointer(cluster, trim(calc_local_energy), cluster_local_energy_ptr, error=error) - RAISE_ERROR("Calc_ONIOM failed to get value for local_energy property '"//trim(calc_local_energy)//"'", ERROR) - cluster_local_e_1 = cluster_local_energy_ptr*this%E_scale_pot1 - endif - if (len_trim(calc_local_virial) > 0) then - call assign_property_pointer(cluster, trim(calc_local_virial), cluster_local_virial_ptr, error=error) - PASS_ERROR_WITH_INFO("Calc_ONIOM failed to get value for local_virial property '"//trim(calc_local_virial)//"'", error) - cluster_local_virial_1 = cluster_local_virial_ptr*this%E_scale_pot1 - endif - call system_timer("calc_oniom/calc_cluster_1") - - ! unrescale cluster - call set_lattice(cluster, cluster%lattice / this%r_scale_pot1, scale_positions=.true.) - - call calc_connect(cluster) - - call system_timer("calc_oniom/calc_cluster_2") - allocate(cluster_force_2(3,cluster%N)) - allocate(cluster_local_e_2(cluster%N)) - allocate(cluster_local_virial_2(9,cluster%N)) - call Calc(this%pot_region2, cluster, args_str=args_str) - if (len_trim(calc_force) > 0) cluster_force_2 = cluster_force_ptr - if (len_trim(calc_virial) > 0) call get_param_value(cluster, trim(calc_virial), cluster_virial_2) - if (len_trim(calc_energy) > 0) call get_param_value(cluster, trim(calc_energy), cluster_energy_2) - if (len_trim(calc_local_energy) > 0) cluster_local_e_2 = cluster_local_energy_ptr - if (len_trim(calc_local_virial) > 0) cluster_local_virial_2 = cluster_local_virial_ptr - call system_timer("calc_oniom/calc_cluster_2") - - call system_timer("calc_oniom/combine") - if(current_verbosity() > PRINT_VERBOSE) & - call write(cluster, "cluster.cfg") - - ! redistribute local energies and weights from the cluster to region 1 - dummy = assign_pointer(cluster, 'index', index) - dummy = assign_pointer(cluster, 'rescale', rescale) - dummy = assign_pointer(cluster, 'termindex', termindex) - ! first add terms arising from the fact that the position of the rescaled termination atoms - ! depends on the position of the atoms they are terminating - if(len_trim(calc_force) > 0) then - do i=1,cluster%N - if(termindex(i) > 0) then - cluster_force_1(:,termindex(i)) = cluster_force_1(:,termindex(i)) + (1.0_dp-rescale(i))*cluster_force_1(:,i) - cluster_force_2(:,termindex(i)) = cluster_force_2(:,termindex(i)) + (1.0_dp-rescale(i))*cluster_force_2(:,i) - endif - end do - end if - ! now do the redistribution - if(len_trim(calc_force) > 0) then - do i=1,cluster%N - at_force_ptr(:,index(i)) = at_force_ptr(:,index(i)) + cluster_force_1(:,i)*rescale(i) - cluster_force_2(:,i)*rescale(i) - end do - end if - if(len_trim(calc_virial) > 0) then - virial = virial + cluster_virial_1 - cluster_virial_2 - call set_param_value(at, trim(calc_virial), virial) - endif - if(len_trim(calc_local_energy) > 0) then - do i=1,cluster%N - at_local_energy_ptr(index(i)) = at_local_energy_ptr(index(i)) + cluster_local_e_1(i) - cluster_local_e_2(i) - end do - end if - if(len_trim(calc_energy) > 0) then - energy = energy + cluster_energy_1 - cluster_energy_2 - call set_param_value(at, trim(calc_energy), energy) - endif - if(len_trim(calc_local_virial) > 0) then - do i=1,cluster%N - at_local_virial_ptr(:,index(i)) = at_local_virial_ptr(:,index(i)) + cluster_local_virial_1(:,i) - cluster_local_virial_2(:,i) - end do - end if - call system_timer("calc_oniom/combine") - - call finalise(cluster) - deallocate(cluster_force_1) - deallocate(cluster_local_e_1) - deallocate(cluster_local_virial_1) - deallocate(cluster_force_2) - deallocate(cluster_local_e_2) - deallocate(cluster_local_virial_2) - - call system_timer("calc_oniom") - end subroutine calc_oniom diff --git a/src/Potentials/Potential_Precon_Minim.f95 b/src/Potentials/Potential_Precon_Minim.f95 deleted file mode 100644 index 969a3ef2e8..0000000000 --- a/src/Potentials/Potential_Precon_Minim.f95 +++ /dev/null @@ -1,1659 +0,0 @@ - -#include "error.inc" -module Potential_Precon_Minim_module - - - use Potential_Module, only : Potential, potential_minimise, energy_func, gradient_func, cutoff, max_rij_change, calc, print_hook, constrain_virial, fix_atoms_deform_grad, pack_pos_dg, unpack_pos_dg, prep_atoms_deform_grad - use error_module - use system_module, only : dp, inoutput, print, PRINT_ALWAYS, PRINT_NORMAL, PRINT_VERBOSE, PRINT_NERD, initialise, finalise, INPUT, & - optional_default, current_verbosity, mainlog, round, verbosity_push_decrement, verbosity_push,verbosity_push_increment, verbosity_pop, print_message, system_timer, system_abort, operator(//) - use units_module, only : EV_A3_IN_GPA - use periodictable_module, only : ElementCovRad, ElementMass - use extendable_str_module, only : extendable_str, initialise, read, string, finalise - use linearalgebra_module , only : norm, trace, matrix3x3_det, normsq, least_squares, add_identity, inverse, diagonalise, symmetric_linear_solve, operator(.fne.), operator(.mult.), operator(.feq.), print - use dictionary_module, only : dictionary, STRING_LENGTH, lookup_entry_i, write_string, get_value, has_key, read_string, set_value, remove_value, initialise, finalise - use paramreader_module, only : param_register, param_read_line - use mpi_context_module, only : mpi_context - use table_module, only : table, find, int_part, wipe, append, finalise - use minimization_module , only : minim, n_minim, fire_minim, test_gradient, n_test_gradient, precon_data, preconminim, precondimer - use connection_module, only : connection - use atoms_types_module, only : atoms, assign_pointer, add_property, assign_property_pointer, add_property_from_pointer, diff_min_image, distance_min_image - use atoms_module, only : has_property, cell_volume, neighbour, n_neighbours, set_lattice, is_nearest_neighbour, & - get_param_value, remove_property, calc_connect, set_cutoff_minimum, set_param_value, calc_dists, atoms_repoint, finalise, assignment(=) - use cinoutput_module, only : cinoutput, write - use dynamicalsystem_module, only : dynamicalsystem, ds_print_status, advance_verlet1, advance_verlet2 - use clusters_module, only : HYBRID_ACTIVE_MARK, HYBRID_NO_MARK, HYBRID_BUFFER_MARK, create_embed_and_fit_lists_from_cluster_mark, create_embed_and_fit_lists, & - create_hybrid_weights, add_cut_hydrogens, create_cluster_info_from_mark, bfs_grow, carve_cluster - - implicit none - - public :: Precon_Minim - interface Precon_Minim - module procedure Precon_Potential_Minim - end interface - - public :: Precon_Dimer - interface Precon_Dimer - module procedure Precon_Potential_Dimer - end interface - -! public :: Precon_MEP -! interface Precon_MEP -! module procedure Precon_Potential_MEP -! end interface - - contains - - - subroutine allocate_precon(this,at,precon_id,nneigh,energy_scale,length_scale,cutoff,res2,max_iter,max_sub,bulk_modulus,number_density,auto_mu) - type (precon_data), intent(inout) :: this - type (Atoms) :: at - character(*) :: precon_id - integer :: nneigh,max_iter,max_sub - real(dp) :: energy_scale, length_scale, cutoff,res2,bulk_modulus,number_density - real(dp) :: scalingnumer, scalingdenom, thisdist, this_r2 - logical :: auto_mu - integer :: I,J, thisind, thisneighcount - - this%precon_id = precon_id - this%nneigh = nneigh - this%energy_scale = energy_scale - this%length_scale = length_scale - this%cutoff = cutoff - this%res2 = res2 - this%mat_mult_max_iter = max_iter - this%max_sub = max_sub - this%bulk_modulus = bulk_modulus - this%number_density = number_density - - if (has_property(at, 'move_mask')) then - this%has_fixed = .TRUE. - else - this%has_fixed = .FALSE. - end if - - allocate(this%preconrowlengths(at%N)) - allocate(this%preconindices(nneigh+1,at%N)) - - if (trim(precon_id) == "LJ" .OR. trim(precon_id) == "ID" .OR. trim(precon_id) == "C1" .OR. trim(precon_id) == "exp") then - this%multI = .TRUE. - elseif (trim(precon_id) == "LJdense") then - this%dense = .true. - else - call print ("Unrecognized Preconditioner, exiting") - call exit() - end if - - - call set_cutoff_minimum(at, this%cutoff) - if(at%cutoff > 0.0_dp) call calc_connect(at) - - if (this%multI .eqv. .true.) then - allocate(this%preconcoeffs(nneigh+1,at%N,1)) - elseif (this%dense .eqv. .true.) then - allocate(this%preconcoeffs(nneigh+1,at%N,6)) - end if - call print('allocate_precon: auto_mu='//auto_mu) - if (auto_mu .and. (trim(precon_id) == "C1" .or. trim(precon_id) == "LJ" .or. trim(precon_id) == "exp")) then - this%mu=25.5/(this%cutoff**2.0) - elseif (.not. auto_mu .and. (trim(precon_id) == "C1" .or. trim(precon_id) == "LJ" .or. trim(precon_id) == "exp")) then - ! compute approximation to best \mu using - ! C1: mu = 3 (bulk-mod) * \sum_n vol[n] / \sum_{n, r} |r|^2 - ! LJ: mu = 3 (bulk-mod) * \sum_n vol[n] / \sum_{n, r} C(|r|) |r|^2 - ! where C(|r|) is the preconditioner coefficient for this bond - scalingnumer = 0.0_dp - scalingdenom = 0.0_dp - do I = 1,(at%N) - scalingnumer = scalingnumer + 1.0 - thisneighcount = n_neighbours(at,I) - do J = 1,thisneighcount - thisind = neighbour(at,I,J,distance=thisdist) - if (thisind > 0 .and. (thisdist <= this%cutoff)) then - if (this%precon_id == "LJ" .or. this%precon_id == "C1" .or. this%precon_id == "exp") then - this_r2 = thisdist**2.0 - if (this%precon_id == "LJ") then - ! if preconditoner is LJ, we scale the coefficient by C(|r|) - this_r2 = this_r2 * (thisdist/this%length_scale)**(-6.0_dp) - else if (this%precon_id == "exp") then - this_r2 = this_r2 * exp(-thisdist/this%length_scale) - end if - scalingdenom = scalingdenom + this_r2 - end if - end if - end do - end do - scalingnumer = scalingnumer*bulk_modulus/number_density - this%mu = (2.0*scalingnumer)/(scalingdenom/3.0) - else - this%mu=1.0 - end if - call print('allocate_precon: selected mu='//this%mu) - - end subroutine allocate_precon - - subroutine build_precon(this,am_data) - - implicit none - - type (precon_data),intent(inout) :: this - character(len=1) :: am_data(:) - - type (potential_minimise) :: am - - real(dp) :: conconstant - integer :: I,J,thisneighcount,thisneighcountlocal,thisind,thisind2 - real(dp) :: thisdist, thiscoeff - real(dp) :: thisdiff(3) - integer :: nearneighcount - logical :: did_rebuild, fixed_neighbour - integer :: didcount - real(dp) :: scalingcoeff, scalingnumer, scalingdenom - - call system_timer('build_precon') - am = transfer(am_data,am) - - call atoms_repoint(am%minim_at) - call set_cutoff_minimum(am%minim_at, this%cutoff) - - if(am%minim_at%cutoff > 0.0_dp) call calc_connect(am%minim_at,did_rebuild=did_rebuild) - if (did_rebuild .eqv. .true.) then - call print("Connectivity rebuilt by preconditioner") - am%connectivity_rebuilt = .true. - end if - -!: call print(this%precon_id == "C1") -!: !Bail out if the preconditioner does not need updating -!: if (am%connectivity_rebuilt .eqv. .false. .and. this%precon_id == "C1") then -!: call print("Saved a recompute") -!: return -!: end if - !conconstant = 1.0_dp/am%minim_at%N - !conconstant = 1.0_dp - conconstant = 0.01_dp ! stabilisation parameter - - scalingnumer = 0.0 - scalingdenom = 0.0 - - this%preconrowlengths = 0 - this%preconindices = 0 - this%preconcoeffs = 0.0 - !call print('Building precon with cutoff ' // this%cutoff) - - if(this%precon_id /= "ID") then - didcount = 0 - do I = 1,(am%minim_at%N) - !call print("rah") - !if(am%minim_at%move_mask(I) == 1) then - - if(this%has_fixed) then - if (am%minim_at%move_mask(I) == 0) then - this%preconcoeffs(1,I,1) = 1.0 - this%preconindices(1,I) = I - this%preconrowlengths(I) = 1 - cycle - end if - end if - - scalingnumer = scalingnumer + 1 - didcount = didcount+1 - thisneighcount = n_neighbours(am%minim_at,I) - thisneighcountlocal = n_neighbours(am%minim_at,I,max_dist=this%cutoff) - !call print(thisneighcount) - - ! call print(thisneighcount // ' ' // thisneighcountlocal) - ! do J=1,thisneighcount - ! call print(neighbour(am%minim_at,I,J)) - ! end do - ! call exit() - - if(thisneighcountlocal > this%nneigh) then - call print("Not enough memory was allocated for preconditioner, increase value of nneigh, undefined behaviour (probably runtime error) follows",PRINT_ALWAYS) - end if - - this%preconindices(1,I) = I - this%preconcoeffs(1,I,1) = conconstant - nearneighcount = 1 - do J = 1,thisneighcount - - thisind = neighbour(am%minim_at,I,J,distance=thisdist,diff=thisdiff,index=thisind2) - if (thisind > 0 .and. (thisdist <= this%cutoff) .and. thisind /= I) then - !call print(thisdist // ' ' // this%cutoff) - !call print( I // ' '// J // ' '// thisneighcount// ' ' // thisind // ' ' // thisdist) - !call print( I // ' ' // thisind // ' ' //thisind2 // ' ' // thisdist) - - - !call writevec(reshape(this%preconcoeffs(1,I,1:6),(/6/)),'coeffs0.dat') - if (this%precon_id == "LJ" .or. this%precon_id == "C1" .or. this%precon_id == "exp") then - - if (this%precon_id == "LJ") then - thiscoeff = ( thisdist/this%length_scale)**(-6.0_dp) - ! thiscoeff = 1.0_dp!max(min(thiscoeff,10.0_dp),0.1_dp) - !call print(thiscoeff) - else if (this%precon_id == "exp") then - thiscoeff = exp(-thisdist/this%length_scale) - else if (this%precon_id == "C1") then - thiscoeff = 1.0_dp - end if - - this%preconcoeffs(1,I,1) = this%preconcoeffs(1,I,1) + thiscoeff - scalingdenom = scalingdenom + thisdist**2.0 - - fixed_neighbour = this%has_fixed .and. (am%minim_at%move_mask(thisind) /= 1) - if (.not. fixed_neighbour) then - nearneighcount = nearneighcount+1 - this%preconcoeffs(nearneighcount,I,1) = -thiscoeff - this%preconindices(nearneighcount,I) = thisind - end if - - !this%preconcoeffs(1,I,1) = this%preconcoeffs(1,I,1) + thiscoeff - !this%preconcoeffs(nearneighcount,I,1) = -thiscoeff - - !nearneighcount = nearneighcount+1 -! elseif (this%precon_id == "LJdense") then -! -! ! Coeff 1 -! thiscoeff = this%energy_scale * ( (thisdiff(1)**2.0)*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & -! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0)) & -! + 12.0*this%length_scale**12.0/(thisdist**14.0) - 12.0*this%length_scale**6.0/(thisdist**8.0)) -! this%preconcoeffs(nearneighcount,I,1) = thiscoeff -! this%preconcoeffs(1,I,1) = this%preconcoeffs(1,I,1) - thiscoeff -! -! ! Coeff 2 -! thiscoeff = this%energy_scale * ( (thisdiff(1)*thisdiff(2))*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & -! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0))) -! this%preconcoeffs(nearneighcount,I,2) = thiscoeff -! this%preconcoeffs(1,I,2) = this%preconcoeffs(1,I,2) - thiscoeff -! -! ! Coeff 3 -! thiscoeff = this%energy_scale * ( (thisdiff(1)*thisdiff(3))*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & -! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0))) -! this%preconcoeffs(nearneighcount,I,3) = thiscoeff -! this%preconcoeffs(1,I,3) = this%preconcoeffs(1,I,3) - thiscoeff -! -! ! Coeff 4 -! thiscoeff = this%energy_scale * ( (thisdiff(2)**2.0)*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & -! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0)) & -! + 12.0*this%length_scale**12.0/(thisdist**14.0) - 12.0*this%length_scale**6.0/(thisdist**8.0)) -! this%preconcoeffs(nearneighcount,I,4) = thiscoeff -! this%preconcoeffs(1,I,4) = this%preconcoeffs(1,I,4) - thiscoeff -! -! ! Coeff 5 -! thiscoeff = this%energy_scale * ( (thisdiff(2)*thisdiff(3))*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & -! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0))) -! this%preconcoeffs(nearneighcount,I,5) = thiscoeff -! this%preconcoeffs(1,I,5) = this%preconcoeffs(1,I,5) - thiscoeff -! -! ! Coeff 6 -! thiscoeff = this%energy_scale * ( (thisdiff(3)**2.0)*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & -! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0)) & -! + 12.0*this%length_scale**12.0/(thisdist**14.0) - 12.0*this%length_scale**6.0/(thisdist**8.0)) -! this%preconcoeffs(nearneighcount,I,6) = thiscoeff -! this%preconcoeffs(1,I,6) = this%preconcoeffs(1,I,6) - thiscoeff -! -! !call writevec(reshape(this%preconcoeffs(1,I,1:6),(/6/)),'coeffs1.dat') -! !call writevec(reshape(this%preconcoeffs(nearneighcount,I,1:6),(/6/)),'coeffs2.dat') -! !call writevec(thisdiff,'diff.dat') -! !call exit() -! - end if - - - end if - end do - - !call print(nearneighcount) - this%preconrowlengths(I) = nearneighcount - !end if - end do - else if (this%precon_id == 'ID') then - do I = 1,(am%minim_at%N) - this%preconcoeffs(1,I,1) = 1.0 - this%preconrowlengths(I) = 1 - this%preconindices(1,I) = I - end do - end if - - if(this%precon_id == 'LJ' .or. this%precon_id == 'C1' .or. this%precon_id == 'exp') then - ! scalingdenom = scalingdenom/3.0 - ! scalingnumer = 2.0*scalingnumer*this%bulk_modulus/this%number_density - !scalingcoeff = scalingnumer/scalingdenom - !scalingcoeff =this%bulk_modulus - - !call print(this%number_density) - call print('build_precon: using mu='//this%mu, PRINT_VERBOSE) - this%preconcoeffs= this%preconcoeffs*this%mu - end if - am%connectivity_rebuilt = .false. - !call exit() - - this%cell_coeff = 1.0_dp/(sum(this%preconcoeffs(1,:,1))/size(this%preconcoeffs,2)) - - call system_timer('build_precon') - - end subroutine build_precon - - subroutine getdenseC1precon(prmat,at,cutoff) - - implicit none - - real(dp), intent(inout) :: prmat(:,:) !The dense precon matrix will be stored here, it should be (N*3+9)x(N*3+9) - type (Atoms), target :: at ! The atoms the precon will be built from - real(dp) :: cutoff - type (precon_data) :: pr - character, allocatable :: am_data(:) - character, dimension(1) :: am_mold - type (potential_minimise) :: am - integer :: I, J, target_elements(3), row_elements(3), thisind, am_data_size, K - real(dp) :: scoeff - - call allocate_precon(pr,at,'C1',125,1.0_dp,1.0_dp,cutoff,10.0_dp**(-10.0),100,20,0.625_dp,0.1_dp,.true.) - - am%minim_at => at - am_data_size = size(transfer(am, am_mold)) - allocate(am_data(am_data_size)) - am_data = transfer(am, am_data) - call build_precon(pr,am_data) - prmat = 0.0 - do I = 1,9 - prmat(I,I) = 1.0 - end do - do I = 1,size(pr%preconindices,DIM=2) - - !call print(pr%preconindices(1:pr%preconrowlengths(I),I)) - target_elements = (/ I*3-2+9, I*3-1+9, I*3+9 /) - if (pr%preconrowlengths(I) >= 1) then - do J = 1,(pr%preconrowlengths(I)) - - thisind = pr%preconindices(J,I) - row_elements = (/ thisind*3-2+9, thisind*3-1+9, thisind*3+9/) - - scoeff = pr%preconcoeffs(J,I,1) - !call print(scoeff) - do K = 1,3 - prmat(row_elements(K),target_elements(K)) = prmat(row_elements(K),target_elements(K)) + scoeff - prmat(target_elements(K),row_elements(K)) = prmat(target_elements(K),row_elements(K)) + scoeff - end do - end do - end if - end do - end subroutine - - function Precon_Potential_Minim(this, at, method, convergence_tol, max_steps,efuncroutine, linminroutine, do_print, print_inoutput, print_cinoutput, & - do_pos, do_lat, args_str,external_pressure, & - hook, hook_print_interval, & - error,precon_id,length_scale,energy_scale,precon_cutoff,nneigh,res2,mat_mult_max_iter,max_sub,infoverride,convchoice,bulk_modulus,number_density,auto_mu) - - implicit none - - type(Potential), intent(inout), target :: this !% potential to evaluate energy/forces with - type(Atoms), intent(inout), target :: at !% starting configuration - character(*), intent(in) :: method !% passed to precon_minim() -! Options for method -! 'preconSD' - preconditioned steepest descent -! 'preconCG' - preconditioned safeguarded Polak-Ribiere conjugate gradient -! 'preconLBFGS - preconditioned LBFGS - - real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ - !% 'convergence_tol'. - integer, intent(in) :: max_steps !% Maximum number of steps - - character(*), intent(in), optional :: efuncroutine !% How to evaluate change in energy in a step -!Options for efuncroutine -! 'basic' - naive summation (default) -! 'kahan' - kahan summation of local energy differences (QUIPs potential must provide local_energy, if it does turn this on) - - character(*), intent(in),optional :: linminroutine !% Name of the line minisation routine to use -! Options for linminroutine -! 'basic' - simple backtracking, each iteration satisfies armijo -! 'standard' - bracket and zoom by cubic interpolation, with bisection as backup, each iteration satisfies wolfe -! 'none' - no linesearch, relies on estimating alpha from previous gradients etc, very dangerous - - logical, optional :: do_print !% if true, print configurations using minim's hook() - type(inoutput), intent(inout), optional, target :: print_inoutput !% inoutput object to print configs to, needed if do_print is true - type(cinoutput), intent(inout), optional, target :: print_cinoutput !% cinoutput object to print configs to, needed if do_print is true - logical, optional :: do_pos, do_lat !% do relaxation w.r.t. positions and/or lattice (if neither is included, do both) - character(len=*), intent(in), optional :: args_str !% arguments to pass to calc() - real(dp), dimension(3,3), optional :: external_pressure - optional :: hook - INTERFACE - subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - end subroutine hook - END INTERFACE - integer, intent(in), optional :: hook_print_interval !% how often to print xyz from hook function - integer, intent(out), optional :: error !% set to 1 if an error occurred during minimisation - - character(*), intent(in),optional :: precon_id -! Eventually will support multiple preconditioners for now just supports: -! 'ID' - identity preconditioner (default) i.e. no preconditioner -! 'C1' - binary connectivity precontioner -! 'LJ' - connectivity preconditioner based on LJ potential - - real(dp), intent(in), optional :: length_scale !length scale of potential (reference lattice distance, approximately will be probably good enough), default 1.0 - real(dp), intent(in), optional :: energy_scale !prefactor of the potential energy, default 1.0 - real(dp), intent(in), optional :: precon_cutoff !cutoff radius of the preconditioner, default 1.5, probably set this midway between first and second neighbour distances, assuming first neighbours contribute much more to the energy, if the potential is more or less 'flat' then may need to include second neighbours - integer, intent(in), optional :: nneigh !maximum number of neighbours expected in precon_cutoff radius, may be removed when this becomes automatic, default is 125, only necessary to edit if you run out of memory - - - real(dp), intent(in), optional :: bulk_modulus - real(dp), intent(in), optional :: number_density - - real(dp), intent(in), optional :: res2 !criteria for the residual squared of the approximate preconditioner inverse, probably dont need to change this - integer, intent(in), optional :: mat_mult_max_iter !max number of iterations of the preconditioner inverter, probably dont need to change this - integer, intent(in), optional :: max_sub !max number of iterations of the inverter before restarting, probably dont need to change this - - real(dp), optional :: infoverride !optional override to max step in infinity norm - logical, optional :: auto_mu - - character(*), intent(in),optional :: convchoice - - integer:: Precon_Potential_Minim - - character(len=STRING_LENGTH) :: use_method - - integer n_iter, n_iter_tot - real(dp), allocatable :: x(:) - real(dp) :: deform_grad(3,3) - logical my_do_print - logical done - - type(potential_minimise) am - integer :: am_data_size - character, allocatable :: am_data(:) - character, dimension(1) :: am_mold - integer :: status - - type (precon_data) :: pr - real(dp) :: my_length_scale, my_energy_scale, my_precon_cutoff, my_res2, my_bulk_modulus,my_number_density - integer :: my_nneigh, my_mat_mult_max_iter, my_max_sub - character(10) :: my_precon_id - logical :: doinfnorm, my_auto_mu - - - INIT_ERROR(error) - - doinfnorm = .false. - if (present(convchoice)) then - if (trim(convchoice) == 'infnorm') then - - doinfnorm = .true. - call print("Using inf_norm for convergence") - else - call print("Unrecognized choice of convergence metric, defaulting to 2 norm") - end if - - else - call print("Defaulting to 2 norm for convergence") - end if - - - my_bulk_modulus = optional_default(0.625_dp,bulk_modulus) - my_number_density = optional_default(0.01_dp,number_density) - - my_precon_id = optional_default('ID',precon_id) - if ((present(length_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then - call print("No length_scale specified, defaulting to reference lattice distance = 1.0. Unless this is a good estimate preconditioning may work VERY POORLY, if in doubt estimate high, set optional argument length_scale.") - end if - -! if ((present(energy_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then -! call print("No energy_scale specified, defaulting to prefactor = 1.0. Unless this is a good estimate preconditioning may work very poorly, set optional argument energy_scale.") -! end if - - if ((present(precon_cutoff) .eqv. .false.) .and. (trim(my_precon_id) /= 'ID')) then - call print("No precon cutoff specified, using the potential's own cutoff = "//cutoff(this)//". Decreasing this may improve performance, set optional argument precon_cutoff.") - end if - - am_data_size = size(transfer(am, am_mold)) - allocate(am_data(am_data_size)) - - use_method = trim(method) - - if(at%cutoff > 0.0_dp) call calc_connect(at) - am%minim_at => at - am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*am%minim_at%N - - if (present(args_str)) then - am%minim_args_str = args_str - else - am%minim_args_str = "" - endif - am%minim_pot => this - - if (.not.present(do_pos) .and. .not. present(do_lat)) then - am%minim_do_pos = .true. - am%minim_do_lat = .true. - else - am%minim_do_pos = optional_default(.false., do_pos) - am%minim_do_lat = optional_default(.false., do_lat) - endif - - am%external_pressure = 0.0_dp - if (present(external_pressure)) then - am%external_pressure = external_pressure - if( (am%external_pressure(1,1) .fne. am%external_pressure(2,2)) .or. & - & (am%external_pressure(1,1) .fne. am%external_pressure(3,3)) .or. & - & (am%external_pressure(1,2) .fne. 0.0_dp) .or. & - & (am%external_pressure(1,3) .fne. 0.0_dp) .or. & - & (am%external_pressure(2,1) .fne. 0.0_dp) .or. & - & (am%external_pressure(2,3) .fne. 0.0_dp) .or. & - & (am%external_pressure(3,1) .fne. 0.0_dp) .or. & - & (am%external_pressure(3,2) .fne. 0.0_dp) ) then - if(trim(use_method) /= 'fire') then - call print_message('WARNING', 'Anisotrpic pressure is being used. Switching to fire_minim.') - use_method = 'fire' - endif - endif - endif - - my_do_print = optional_default(.false., do_print) - - if (my_do_print .and. .not. present(print_inoutput) .and. .not. present(print_cinoutput)) & - call system_abort("potential_minim: do_print is true, but no print_inoutput or print_cinoutput present") - - if (my_do_print) then - if (present(print_cinoutput)) then - am%minim_cinoutput_movie => print_cinoutput - if (this%is_forcemixing) & - this%forcemixing%minim_cinoutput_movie => print_cinoutput -#ifdef HAVE_LOCAL_E_MIX - if (this%is_local_e_mix) & - this%local_e_mix%minim_cinoutput_movie => print_cinoutput -#endif /* HAVE_LOCAL_E_MIX */ -#ifdef HAVE_ONIOM - if (this%is_oniom) & - this%oniom%minim_cinoutput_movie => print_cinoutput -#endif /* HAVE_ONIOM */ - end if - else - nullify(am%minim_cinoutput_movie) - endif - - am%minim_n_eval_e = 0 - am%minim_n_eval_f = 0 - - allocate(x(9+am%minim_at%N*3)) - allocate(am%last_connect_x(size(x))) - am%last_connect_x=1.0e38_dp - deform_grad = 0.0_dp; call add_identity(deform_grad) - call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) - - am_data = transfer(am, am_data) - my_nneigh = optional_default(125,nneigh) - my_energy_scale = optional_default(1.0_dp,energy_scale) - my_length_scale = optional_default(1.0_dp,length_scale) - my_precon_cutoff = optional_default(cutoff(this),precon_cutoff) - my_res2 = optional_default(10.0_dp**(-5.0_dp),res2) - my_mat_mult_max_iter = optional_default(am%minim_at%N*3,mat_mult_max_iter) - my_auto_mu = optional_default(.true.,auto_mu) - my_max_sub = 30 - - if (my_length_scale < 0.5_dp) then - call print("WARNING: You have set your atomistic length scale (approximate first neighbour distance) to: "//my_length_scale // " this is very low and probably constitutes an incorrect input",PRINT_ALWAYS) - end if - - call allocate_precon(pr,at,my_precon_id,my_nneigh,my_energy_scale,my_length_scale,my_precon_cutoff,my_res2,my_mat_mult_max_iter,my_max_sub,my_bulk_modulus,my_number_density,my_auto_mu) - - n_iter = preconminim(x, energy_func_local, gradient_func, build_precon, pr, use_method, convergence_tol, max_steps, & - efuncroutine=efuncroutine, linminroutine=linminroutine, hook=hook, hook_print_interval=hook_print_interval, & - am_data=am_data, status=status, writehessian=writeapproxhessiangrad,gethessian=getapproxhessian,getfdhconnectivity=getfdhconnectivity,& - infoverride = infoverride, infconvext = doinfnorm) - - - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - if(am%minim_at%cutoff > 0.0_dp) call calc_connect(am%minim_at) - n_iter_tot = n_iter - done = .true. - deallocate(am%last_connect_x) - deallocate(x) - call print("MINIM_N_EVAL E " // am%minim_n_eval_e // " F " // am%minim_n_eval_f // & - " EF " // am%minim_n_eval_ef, PRINT_VERBOSE) - - Precon_Potential_Minim = n_iter_tot - deallocate(am_data) - - end function - - function Precon_Potential_Dimer(this, at,at2, method, convergence_tol, max_steps,efuncroutine, linminroutine, do_print, print_inoutput, print_cinoutput, & - do_pos, do_lat, args_str,external_pressure, & - hook,hook_print_interval,& - error,precon_id,length_scale,energy_scale,precon_cutoff,nneigh,res2,mat_mult_max_iter,max_sub,infoverride,bulk_modulus,number_density,auto_mu) - - implicit none - - type(Potential), intent(inout), target :: this !% potential to evaluate energy/forces with - type(Atoms), intent(inout), target :: at ! final configuration - type(Atoms), intent(in), target :: at2 ! start configuration 2 - character(*), intent(in) :: method !% passed to precon_minim() -! Options for method -! 'preconSD' - preconditioned steepest descent -! 'preconCG' - preconditioned safeguarded Polak-Ribiere conjugate gradient - - real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ - !% 'convergence_tol'. - integer, intent(in) :: max_steps !% Maximum number of steps - - character(*), intent(in), optional :: efuncroutine !% How to evaluate change in energy in a step -!Options for efuncroutine -! 'basic' - naive summation (default) -! 'kahan' - kahan summation of local energy differences (QUIPs potential must provide local_energy) - - character(*), intent(in),optional :: linminroutine !% Name of the line minisation routine to use -! Options for linminroutine -! 'basic' - simple backtracking, each iteration satisfies armijo -! 'basicpp' - cubic backtracking, tries to satisfy armijo -! 'standard' - bracket and zoom by cubic interpolation, with bisection as backup, each iteration satisfies wolfe -! 'none' - no linesearch, relies on estimating alpha from previous gradients etc, very dangerous - - logical, optional :: do_print !% if true, print configurations using minim's hook() - type(inoutput), intent(inout), optional, target :: print_inoutput !% inoutput object to print configs to, needed if do_print is true - type(cinoutput), intent(inout), optional, target :: print_cinoutput !% cinoutput object to print configs to, needed if do_print is true - logical, optional :: do_pos, do_lat !% do relaxation w.r.t. positions and/or lattice (if neither is included, do both) - character(len=*), intent(in), optional :: args_str !% arguments to pass to calc() - real(dp), dimension(3,3), optional :: external_pressure - integer, intent(in), optional :: hook_print_interval !% how often to print xyz from hook function - integer, intent(out), optional :: error !% set to 1 if an error occurred during minimisation - optional :: hook - INTERFACE - subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - end subroutine hook - END INTERFACE - - character(*), intent(in),optional :: precon_id -! Eventually will support multiple preconditioners for now just supports: -! 'ID' - identity preconditioner (default) i.e. no preconditioner -! 'C1' - binary connectivity precontioner -! 'LJ' - connectivity preconditioner based on LJ potential - - real(dp), intent(in), optional :: length_scale !length scale of potential (reference lattice distance, approximately will be probably good enough), default 1.0 - real(dp), intent(in), optional :: energy_scale !prefactor of the potential energy, default 1.0 - real(dp), intent(in), optional :: precon_cutoff !cutoff radius of the preconditioner, default 1.5, probably set this midway between first and second neighbour distances, assuming first neighbours contribute much more to the energy, if the potential is more or less 'flat' then may need to include second neighbours - integer, intent(in), optional :: nneigh !maximum number of neighbours expected in precon_cutoff radius, may be removed when this becomes automatic, default is 125 - - real(dp), intent(in), optional :: res2 !criteria for the residual squared of the approximate preconditioner inverse, probably dont need to change this - integer, intent(in), optional :: mat_mult_max_iter !max number of iterations of the preconditioner inverter, probably dont need to change this - integer, intent(in), optional :: max_sub !max number of iterations of the inverter before restarting - - real(dp), intent(in), optional :: bulk_modulus - real(dp), intent(in), optional :: number_density - logical, optional :: auto_mu - - integer:: Precon_Potential_Dimer - - character(len=STRING_LENGTH) :: use_method - - integer n_iter, n_iter_tot - real(dp), allocatable :: x(:),v(:),vpos(:,:) - real(dp) :: deform_grad(3,3) - logical my_do_print - logical done - - type(potential_minimise) am - integer :: am_data_size - character, allocatable :: am_data(:) - character, dimension(1) :: am_mold - integer :: status - - type (precon_data) :: pr - real(dp) :: my_length_scale, my_energy_scale, my_precon_cutoff, my_res2,my_bulk_modulus,my_number_density - integer :: my_nneigh, my_mat_mult_max_iter, my_max_sub - character(10) :: my_precon_id - logical :: my_auto_mu - - real(dp), optional :: infoverride - - INIT_ERROR(error) - - my_precon_id = optional_default('ID',precon_id) - if ((present(length_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then - call print("No length_scale specified, defaulting to reference lattice distance = 1.0. Unless this is a good estimate preconditioning may work VERY POORLY, if in doubt estimate high, set optional argument length_scale.") - end if - - if ((present(energy_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then - call print("No energy_scale specified, defaulting to prefactor = 1.0. Unless this is a good estimate preconditioning may work very poorly, set optional argument energy_scale.") - end if - - if ((present(precon_cutoff) .eqv. .false.) .and. (trim(my_precon_id) /= 'ID')) then - call print("No precon cutoff specified, using the potential's own cutoff = "//cutoff(this)//". Decreasing this may improve performance, set optional argument precon_cutoff.") - end if - - - am_data_size = size(transfer(am, am_mold)) - allocate(am_data(am_data_size)) - - use_method = trim(method) - - at%pos = (at%pos + at2%pos)/2.0 - allocate(vpos(at%N,3)) - vpos = (at%pos - at2%pos) - - my_bulk_modulus = optional_default(0.625_dp,bulk_modulus) - my_number_density = optional_default(0.01_dp,number_density) - - - if(at%cutoff > 0.0_dp) call calc_connect(at) - am%minim_at => at - am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*am%minim_at%N - - if (present(args_str)) then - am%minim_args_str = args_str - else - am%minim_args_str = "" - endif - am%minim_pot => this - -! am%minim_do_lat = .false. - am%minim_do_lat = .false. -! if (.not.present(do_pos) .and. .not. present(do_lat)) then -! am%minim_do_pos = .true. -! am%minim_do_lat = .true. -! else -! am%minim_do_pos = optional_default(.false., do_pos) -! am%minim_do_lat = optional_default(.false., do_lat) -! endif - - am%external_pressure = 0.0_dp - if (present(external_pressure)) then - am%external_pressure = external_pressure - if( (am%external_pressure(1,1) .fne. am%external_pressure(2,2)) .or. & - & (am%external_pressure(1,1) .fne. am%external_pressure(3,3)) .or. & - & (am%external_pressure(1,2) .fne. 0.0_dp) .or. & - & (am%external_pressure(1,3) .fne. 0.0_dp) .or. & - & (am%external_pressure(2,1) .fne. 0.0_dp) .or. & - & (am%external_pressure(2,3) .fne. 0.0_dp) .or. & - & (am%external_pressure(3,1) .fne. 0.0_dp) .or. & - & (am%external_pressure(3,2) .fne. 0.0_dp) ) then - if(trim(use_method) /= 'fire') then - call print_message('WARNING', 'Anisotrpic pressure is being used. Switching to fire_minim.') - use_method = 'fire' - endif - endif - endif - - my_do_print = optional_default(.false., do_print) - - if (my_do_print .and. .not. present(print_inoutput) .and. .not. present(print_cinoutput)) & - call system_abort("potential_minim: do_print is true, but no print_inoutput or print_cinoutput present") - - if (my_do_print) then - if (present(print_cinoutput)) then - am%minim_cinoutput_movie => print_cinoutput - if (this%is_forcemixing) & - this%forcemixing%minim_cinoutput_movie => print_cinoutput -#ifdef HAVE_LOCAL_E_MIX - if (this%is_local_e_mix) & - this%local_e_mix%minim_cinoutput_movie => print_cinoutput -#endif /* HAVE_LOCAL_E_MIX */ -#ifdef HAVE_ONIOM - if (this%is_oniom) & - this%oniom%minim_cinoutput_movie => print_cinoutput -#endif /* HAVE_ONIOM */ - end if - else - nullify(am%minim_cinoutput_movie) - endif - - am%minim_n_eval_e = 0 - am%minim_n_eval_f = 0 - - allocate(x(9+am%minim_at%N*3),v(9+am%minim_at%N*3)) - allocate(am%last_connect_x(size(x))) - am%last_connect_x=1.0e38_dp - deform_grad = 0.0_dp; call add_identity(deform_grad) - call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) - - call pack_pos_dg(vpos, deform_grad, v, 0.0_dp) - !call print(x) - !call exit() - - - am_data = transfer(am, am_data) - my_nneigh = optional_default(125,nneigh) - my_energy_scale = optional_default(1.0_dp,energy_scale) - my_length_scale = optional_default(1.0_dp,length_scale) - my_precon_cutoff = optional_default(cutoff(this),precon_cutoff) - my_res2 = optional_default(10.0_dp**(-5.0_dp),res2) - my_mat_mult_max_iter = optional_default(am%minim_at%N*3,mat_mult_max_iter) - my_max_sub = 30 - my_auto_mu = optional_default(.true.,auto_mu) - - call allocate_precon(pr,at,my_precon_id,my_nneigh,my_energy_scale,my_length_scale,my_precon_cutoff,my_res2,my_mat_mult_max_iter,my_max_sub,my_bulk_modulus,my_number_density,my_auto_mu) - !call print(use_method) - n_iter = precondimer(x,v, energy_func_local, gradient_func, build_precon, pr, use_method, convergence_tol, max_steps,efuncroutine=efuncroutine, linminroutine=linminroutine, & - hook=print_hook, hook_print_interval=hook_print_interval, am_data=am_data, status=status, writehessian=writeapproxhessiangrad,gethessian=getapproxhessian) -! n_iter = minim(x, energy_func, gradient_func, use_method, convergence_tol, max_steps, linminroutine, & - ! print_hook, hook_print_interval=hook_print_interval, eps_guess=my_eps_guess, data=am_data, status=status) - - - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - if(am%minim_at%cutoff > 0.0_dp ) call calc_connect(am%minim_at) - n_iter_tot = n_iter - done = .true. - deallocate(am%last_connect_x) - deallocate(x) - - call print("Precon dimer exiting") - Precon_Potential_Dimer = n_iter_tot - - deallocate(am_data) - - end function - - -! function Precon_Potential_MEP(this,allat,at1,at2, method, convergence_tol, max_steps, linminroutine,efuncroutine,k, do_print, print_inoutput, print_cinoutput, & -! do_pos, do_lat, args_str,external_pressure, & -! hook_print_interval, error,precon_id,length_scale,energy_scale,precon_cutoff,nneigh,NatMax,fix_ends,res2,mat_mult_max_iter,max_sub,deltat) -! -! implicit none -! -! type(Potential), intent(in), target :: this !% potential to evaluate energy/forces with -! type(Atoms), intent(inout), target, dimension(:) :: allat -! type(Atoms), intent(in), target :: at1 !% start of the chain -! type(Atoms), intent(in), target :: at2 !% end of the chain !Number of states in the chain -! character(*), intent(in) :: method !% passed to precon_minim() -!! Options for method -!! 'preconSD' - preconditioned steepest descent -!! 'preconCG' - preconditioned safeguarded Polak-Ribiere conjugate gradient -! -! real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ -! !% 'convergence_tol'. -! integer, intent(in) :: max_steps !% Maximum number of steps -! character(*), intent(in),optional :: linminroutine !% Name of the line minisation routine to use -!! Options for linminroutine -!! 'basic' - simple backtracking, each iteration satisfies armijo -!! 'basicpp' - cubic backtracking, tries to satisfy armijo -!! 'standard' - bracket and zoom by cubic interpolation, with bisection as backup, each iteration satisfies wolfe -!! 'none' - no linesearch, relies on estimating alpha from previous gradients etc, very dangerous -! -! character(*), intent(in), optional :: efuncroutine !% How to evaluate change in energy in a step -! real(dp), optional ::k -! logical, optional :: do_print !% if true, print configurations using minim's hook() -! type(inoutput), intent(inout), optional, target :: print_inoutput !% inoutput object to print configs to, needed if do_print is true -! type(cinoutput), intent(inout), optional, target :: print_cinoutput !% cinoutput object to print configs to, needed if do_print is true -! logical, optional :: do_pos, do_lat !% do relaxation w.r.t. positions and/or lattice (if neither is included, do both) -! character(len=*), intent(in), optional :: args_str !% arguments to pass to calc() -! real(dp), dimension(3,3), optional :: external_pressure -! integer, intent(in), optional :: hook_print_interval !% how often to print xyz from hook function -! integer, intent(out), optional :: error !% set to 1 if an error occurred during minimisation -! -! character(*), intent(in),optional :: precon_id -!! Eventually will support multiple preconditioners for now just supports: -!! 'ID' - identity preconditioner (default) i.e. no preconditioner -!! 'C1' - binary connectivity precontioner -!! 'LJ' - connectivity preconditioner based on LJ potential -! -! real(dp), intent(in), optional :: length_scale !length scale of potential (reference lattice distance, approximately will be probably good enough), default 1.0 -! real(dp), intent(in), optional :: energy_scale !prefactor of the potential energy, default 1.0 -! real(dp), intent(in), optional :: precon_cutoff !cutoff radius of the preconditioner, default 1.5, probably set this midway between first and second neighbour distances -! integer, intent(in), optional :: nneigh !maximum number of neighbours expected in precon_cutoff radius, may be removed when this becomes automatic, default is 125 -! integer :: status -! integer, intent(in), optional :: NatMax -! logical, intent(in), optional :: fix_ends -! real(dp), intent(in), optional :: res2 !criteria for the residual squared of the approximate preconditioner inverse, probably dont need to change this -! integer, intent(in), optional :: mat_mult_max_iter !max number of iterations of the preconditioner inverter, probably dont need to change this -! integer, intent(in), optional :: max_sub !max number of iterations of the inverter before restarting -! real(dp), optional :: deltat -! -! integer :: Precon_Potential_MEP -! type (potential_minimise), allocatable, dimension(:) :: am -! real (dp), allocatable, dimension(:) :: x1, x2 -! real (dp), allocatable, dimension(:,:) :: allx -! integer :: I, Nd, Nat -! integer :: am_data_size -! character, dimension(1) :: am_mold -! real(dp) :: deform_grad(3,3) -! logical my_do_print -! character(len=100) :: use_method -! character, allocatable, dimension(:,:) :: am_data -! real(dp) :: var -! real(dp) :: myk -! -! type (precon_data), allocatable, dimension (:) :: pr -! real(dp) :: my_length_scale, my_energy_scale, my_precon_cutoff, my_res2 -! integer :: my_nneigh, my_mat_mult_max_iter,my_max_sub -! character(10) :: my_precon_id -! integer :: n_iter -! logical :: my_fix_ends -! -! my_fix_ends = .true. -! if( present(fix_ends) ) my_fix_ends = fix_ends -! -! my_precon_id = optional_default('ID',precon_id) -! if ((present(length_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then -! call print("No length_scale specified, defaulting to reference lattice distance = 1.0. Unless this is a good estimate preconditioning may work VERY POORLY, if in doubt estimate high, set optional argument length_scale.") -! end if -! -! if ((present(energy_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then -! call print("No energy_scale specified, defaulting to prefactor = 1.0. Unless this is a good estimate preconditioning may work very poorly, set optional argument energy_scale.") -! end if -! -! if ((present(precon_cutoff) .eqv. .false.) .and. (trim(my_precon_id) /= 'ID')) then -! call print("No precon cutoff specified, using the potential's own cutoff = "//cutoff(this)//". Decreasing this may improve performance, set optional argument precon_cutoff.") -! end if -! -! myk = 1.0 -! if (present(k)) myk=k -! -! Nat = size(allat) -! allocate(am(Nat)) -! allocate(pr(Nat)) -! -! ! build the Atoms types -! do I = 1,Nat -! call initialise(allat(I),at1%N,at1%lattice) -! end do -! -! ! just for now most Atoms are copies of at1 -! do I = 1,(Nat-1) -! allat(I) = at1 -! end do -! allat(Nat) = at2 -! -! -! Nd = 9+at1%N*3 -! call print("Nd " // Nd) -! -! ! setup minimization -! use_method = trim(method) -! do I = 1,Nat -! call calc_connect(allat(I)) -! am(I)%minim_at => allat(I) -! am(I)%pos_lat_preconditioner_factor = am(I)%minim_pos_lat_preconditioner*am(I)%minim_at%N -! -! if (present(args_str)) then -! am(I)%minim_args_str = args_str -! else -! am(I)%minim_args_str = "" -! endif -! am(I)%minim_pot => this -! -! if (.not.present(do_pos) .and. .not. present(do_lat)) then -! am(I)%minim_do_pos = .true. -! am(I)%minim_do_lat = .true. -! else -! am(I)%minim_do_pos = optional_default(.false., do_pos) -! am(I)%minim_do_lat = optional_default(.false., do_lat) -! endif -! -! am(I)%external_pressure = 0.0_dp -! if (present(external_pressure)) then -! am(I)%external_pressure = external_pressure -! if( (am(I)%external_pressure(1,1) .fne. am(1)%external_pressure(2,2)) .or. & -! & (am(I)%external_pressure(1,1) .fne. am(1)%external_pressure(3,3)) .or. & -! & (am(I)%external_pressure(1,2) .fne. 0.0_dp) .or. & -! & (am(I)%external_pressure(1,3) .fne. 0.0_dp) .or. & -! & (am(I)%external_pressure(2,1) .fne. 0.0_dp) .or. & -! & (am(I)%external_pressure(2,3) .fne. 0.0_dp) .or. & -! & (am(I)%external_pressure(3,1) .fne. 0.0_dp) .or. & -! & (am(I)%external_pressure(3,2) .fne. 0.0_dp) ) then -! if(trim(use_method) /= 'fire') then -! call print_message('WARNING', 'Anisotrpic pressure is being used. Switching to fire_minim.') -! use_method = 'fire' -! endif -! endif -! endif -! -! my_do_print = optional_default(.false., do_print) -! -! if (my_do_print .and. .not. present(print_inoutput) .and. .not. present(print_cinoutput)) & -! call system_abort("potential_minim: do_print is true, but no print_inoutput or print_cinoutput present") -! -! if (my_do_print) then -! if (present(print_cinoutput)) then -! am(I)%minim_cinoutput_movie => print_cinoutput -! if (this%is_forcemixing) & -! this%forcemixing%minim_cinoutput_movie => print_cinoutput -!#ifdef HAVE_LOCAL_E_MIX -! if (this%is_local_e_mix) & -! this%local_e_mix%minim_cinoutput_movie => print_cinoutput -!#endif /* HAVE_LOCAL_E_MIX */ -!#ifdef HAVE_ONIOM -! if (this%is_oniom) & -! this%oniom%minim_cinoutput_movie => print_cinoutput -!#endif /* HAVE_ONIOM */ -! end if -! else -! nullify(am(I)%minim_cinoutput_movie) -! endif -! -! am(I)%minim_n_eval_e = 0 -! am(I)%minim_n_eval_f = 0 -! -! allocate(am(I)%last_connect_x(Nd)) -! am(I)%last_connect_x=1.0e38_dp -! end do -! -! allocate(x1(Nd)) -! allocate(x2(Nd)) -! allocate(allx(Nd,Nat)) -! -! deform_grad = 0.0_dp; call add_identity(deform_grad) -! call pack_pos_dg(am(1)%minim_at%pos, deform_grad, x1, am(1)%pos_lat_preconditioner_factor) -! call pack_pos_dg(am(Nat)%minim_at%pos, deform_grad, x2, am(Nat)%pos_lat_preconditioner_factor) -! allx(1:Nd,1) = x1 -! allx(1:Nd,Nat) = x2 -! -! ! place atoms linearly along the path -! do I=2,(Nat-1) -! var = (I-1.0)/(Nat-1.0) -! allx(1:Nd,I) = x1 + var*(x2-x1) -! call unpack_pos_dg(allx(1:Nd,I) , am(I)%minim_at%N, am(I)%minim_at%pos, deform_grad, 1.0_dp/am(I)%pos_lat_preconditioner_factor) -! end do -! -! am_data_size = size(transfer(am, am_mold)) -! -! my_nneigh = optional_default(125,nneigh) -! my_energy_scale = optional_default(1.0_dp,energy_scale) -! my_length_scale = optional_default(1.0_dp,length_scale) -! my_precon_cutoff = optional_default(cutoff(this),precon_cutoff) -! my_res2 = optional_default(10.0_dp**(-10.0_dp),res2) -! my_mat_mult_max_iter = optional_default(am(1)%minim_at%N*3,mat_mult_max_iter) -! my_max_sub = optional_default(200,max_sub) -! -! allocate(am_data(am_data_size,Nat)) -! do I=1,Nat -! am_data(1:am_data_size,I) = transfer(am(I), am_data(1:am_data_size,I)) -! call allocate_precon(pr(I),allat(I),my_precon_id,my_nneigh,my_energy_scale,my_length_scale,my_precon_cutoff,my_res2,my_mat_mult_max_iter,my_max_sub) -! end do -! -! n_iter = preconMEP(allx,energy_func, gradient_func, build_precon, pr, use_method,my_fix_ends, convergence_tol, max_steps, linminroutine=linminroutine,efuncroutine=efuncroutine,k=myk, & -! hook=print_hook, hook_print_interval=hook_print_interval, am_data=am_data,status=status,deltat=deltat) -! -! do I=1,Nat -! call unpack_pos_dg(allx(1:Nd,I) , am(I)%minim_at%N, am(I)%minim_at%pos, deform_grad, 1.0_dp/am(I)%pos_lat_preconditioner_factor) -! end do -! -! -! -! end function - - ! compute energy - function energy_func_local(x, am_data, local_energy_inout,gradient_inout) - real(dp) :: x(:) - character(len=1), optional :: am_data(:) - real(dp) :: energy_func_local - real(dp), intent(inout),optional :: local_energy_inout(:), gradient_inout(:) - - real(dp) :: max_atom_rij_change - real(dp) :: deform_grad(3,3) - type(potential_minimise) :: am - real(dp) , allocatable :: f(:,:) - real(dp) :: virial(3,3), deform_grad_inv(3,3) - integer :: i - integer, pointer, dimension(:) :: move_mask, fixed_pot - real(dp), pointer :: minim_applied_force(:,:) - logical :: did_rebuild - - call system_timer("energy_func") - - if (.not. present(am_data)) call system_abort("potential_minimise energy_func must have am_data") - am = transfer(am_data, am) - call atoms_repoint(am%minim_at) - - am%minim_n_eval_e = am%minim_n_eval_e + 1 - - if (size(x) /= am%minim_at%N*3+9) call system_abort("Called energy_func() with size mismatch " // & - size(x) // " /= " // am%minim_at%N // "*3+9") - - ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter - max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & - 1.0_dp/am%pos_lat_preconditioner_factor) - !call print(max_atom_rij_change// ' '//am%minim_at%cutoff // ' '// cutoff(am%minim_pot)) - !call print(am%minim_at%connect%neighbour1(302)%t%int(1,1:)) - - if (current_verbosity() >= PRINT_NERD) call print("energy_func got x " // x, PRINT_NERD) - - call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) - call prep_atoms_deform_grad(deform_grad, am%minim_at, am) - - if(am%minim_at%cutoff > 0.0_dp) call calc_connect(am%minim_at,did_rebuild=did_rebuild) - am%last_connect_x = x - - if (did_rebuild .eqv. .true.) then - call print("Connectivity rebuilt in objective function",PRINT_NERD) - am%connectivity_rebuilt = .true. - end if - - if (current_verbosity() >= PRINT_NERD) then - call print("energy_func using am%minim_at", PRINT_NERD) - call write(am%minim_at, 'stdout') - end if - - if( .not. present(gradient_inout) ) then - call calc(am%minim_pot, am%minim_at, energy = energy_func_local, local_energy = local_energy_inout, args_str = am%minim_args_str) - else - allocate(f(3,am%minim_at%N)) - f = 0.0_dp - virial = 0.0_dp - if (am%minim_do_pos .and. am%minim_do_lat) then - call calc(am%minim_pot, am%minim_at, energy = energy_func_local, local_energy = local_energy_inout, force = f, virial = virial, args_str = am%minim_args_str) - else if (am%minim_do_pos) then - call calc(am%minim_pot, am%minim_at, energy = energy_func_local, local_energy = local_energy_inout, force = f, args_str = am%minim_args_str) - else - call calc(am%minim_pot, am%minim_at, energy = energy_func_local, local_energy = local_energy_inout, virial = virial, args_str = am%minim_args_str) - endif - - - ! zero forces if fixed by potential - if (am%minim_do_pos .and. assign_pointer(am%minim_at, "fixed_pot", fixed_pot)) then - do i=1, am%minim_at%N - if (fixed_pot(i) /= 0) f(:,i) = 0.0_dp - end do - endif - - ! Zero force on any fixed atoms - if (assign_pointer(am%minim_at, 'move_mask', move_mask)) then - do i=1,am%minim_at%N - if (move_mask(i) == 0) f(:,i) = 0.0_dp - end do - end if - - ! add applied forces - if (am%minim_do_pos .and. assign_pointer(am%minim_at, "minim_applied_force", minim_applied_force)) then - f = f + minim_applied_force - energy_func_local = energy_func_local - sum(minim_applied_force*am%minim_at%pos) - endif - - if (current_verbosity() >= PRINT_NERD) then - call print ("energy_func_local got f", PRINT_NERD) - call print(f, PRINT_NERD) - call print ("energy_func_local got virial", PRINT_NERD) - call print(virial, PRINT_NERD) - end if - - virial = virial - am%external_pressure*cell_volume(am%minim_at) - - if (current_verbosity() >= PRINT_NERD) then - call print ("energy_func_local got virial, external pressure subtracted", PRINT_NERD) - call print(virial, PRINT_NERD) - end if - - f = transpose(deform_grad) .mult. f - - call constrain_virial(am%minim_at, virial) - - call inverse(deform_grad, deform_grad_inv) - virial = virial .mult. transpose(deform_grad_inv) - - call pack_pos_dg(-f, -virial, gradient_inout, 1.0_dp/am%pos_lat_preconditioner_factor) - end if - - call print ("energy_func got energy " // energy_func_local, PRINT_NERD) - energy_func_local = energy_func_local + cell_volume(am%minim_at)*trace(am%external_pressure) / 3.0_dp - call print ("energy_func got enthalpy " // energy_func_local, PRINT_NERD) - - call fix_atoms_deform_grad(deform_grad, am%minim_at, am) - call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) - - am_data = transfer(am, am_data) - - call system_timer("energy_func") - - end function energy_func_local - - ! utility function to dump a vector into a file (for checking,debugging) - subroutine writevec(vec,filename) - real(dp) :: vec(:) - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) vec - close(outid) - - end subroutine - - subroutine writemat(mat,filename) - real(dp) :: mat(:,:) - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) mat - close(outid) - - end subroutine - - subroutine writematint(mat,filename) - integer :: mat(:,:) - character(*) :: filename - - integer :: outid = 10 - open(unit=outid,file=filename,action="write",status="replace") - write(outid,*) mat - close(outid) - - end subroutine - - subroutine writeapproxhessian(x,data,filename) - - implicit none - - real(dp) :: x(:) - character(len=1) :: data(:) - character(*) :: filename - - type(potential_minimise) :: am - - real(dp),parameter :: eps = 10.0**(-5) - integer,parameter :: nneigh = 500 - real(dp), allocatable :: hess(:) - integer, allocatable :: hessinds(:,:)! ,hxcounts(:) - integer :: I, J, thisneighcount, thisind, thisotherind, II, JJ, hxcount - real(dp), allocatable :: xpp(:), xpm(:), xmm(:), xmp(:), lepp(:), lepm(:), lemm(:), lemp(:) - real(dp) :: fpp, fpm, fmm, fmp - integer :: hx,hy - real(dp) :: fx - am = transfer(data,am) - - !call atoms_repoint(am%minim_at) - !call calc_connect(am%minim_at) - !call calc_dists(am%minim_at) - - !call fix_atoms_deform_grad(deform_grad, am%minim_at, am) - !call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) - - allocate(xpp(size(x)),xpm(size(x)),xmm(size(x)),xmp(size(x))) - allocate(lepp(am%minim_at%N),lepm(am%minim_at%N),lemm(am%minim_at%N),lemp(am%minim_at%N)) - allocate(hess(3*am%minim_at%N*nneigh)) - allocate(hessinds(3*am%minim_at%N*nneigh,2)) - !allocate(hxcounts(3*am%minim_at%N)) - hessinds = 0 - hess = 0.0 - fx = energy_func_local(x,data,lepp) - fx = KahanSum(lepp) - hxcount = 1 - do I = 1,(am%minim_at%N) ! Loop over atoms - call print(I) - thisneighcount = n_neighbours(am%minim_at,I) - !call print(x) - !call exit() - if(thisneighcount > 3*nneigh) then - call print("Not enough memory was allocated for Hessian, increase value of nneigh") - end if - - do II = 1,3 ! Loop over coordinates of atom I - hx = 3*(I-1) + II - - do J = 1,(thisneighcount+1) ! Loop over neighbours of atom I - if (J > 1) then - thisind = neighbour(am%minim_at,I,J-1,index=thisotherind) - else - thisind = I - end if - do JJ = 1,3 ! Loop over coordinates of atom J - hy = 3*(thisind-1) + JJ - - if(hy .eq. hx) then - xpp = x - xmm = x - xpp(hx+9) = xpp(hx+9) + eps - xmm(hx+9) = xmm(hx+9) - eps - - fpp = energy_func_local(xpp,data,lepp) - fmm = energy_func_local(xmm,data,lemm) - fpp = KahanSum(lepp) - fmm = KahanSum(lemm) - hess(hxcount) = (fpp - 2.0*fx + fmm)/(eps**2.0) - hessinds(hxcount,1) = hx - hessinds(hxcount,2) = hx - !call print(I // ' ' // II // ' '// thisind// ' '//JJ//' ' // J // ' '// hx // ' '//hy// ' '//hess(hxcount)) - hxcount = hxcount + 1 - - elseif(hy .gt. hx) then - xpp = x - xpm = x - xmp = x - xmm = x - xpp(hx+9) = xpp(hx+9) + eps - xpp(hy+9) = xpp(hy+9) + eps - xpm(hx+9) = xpm(hx+9) + eps - xpm(hy+9) = xpm(hy+9) - eps - xmp(hx+9) = xmp(hx+9) - eps - xmp(hy+9) = xmp(hy+9) + eps - xmm(hx+9) = xmm(hx+9) - eps - xmm(hy+9) = xmm(hy+9) - eps - - - fpp = energy_func_local(xpp,data,lepp) - fpm = energy_func_local(xpm,data,lepm) - fmp = energy_func_local(xmp,data,lemp) - fmm = energy_func_local(xmm,data,lemm) - fpp = KahanSum(lepp) - fpm = KahanSum(lepm) - fmp = KahanSum(lemp) - fmm = KahanSum(lemm) - hess(hxcount) = (fpp + fmm - fmp - fpm)/(4.0*eps**2.0) - hessinds(hxcount,1) = hx - hessinds(hxcount,2) = hy - !call print(I // ' ' // II // ' '// thisind// ' '//JJ//' ' // J // ' '// hx // ' '//hy// ' '//hess(hxcount)) - hxcount = hxcount + 1 - endif - !call print(fpp// ' '//fpm// ' '//fmp // ' '// fmm// ' '//fpp+fmm-fmp-fpm) - end do - end do - end do - end do - - call writevec(hess,filename // 'hess.dat') - call writematint(hessinds, filename // 'hessinds.dat') - - end subroutine - - function KahanSum(vec) - - real(dp) :: vec(:) - real(dp) :: KahanSum - - integer :: I,N - real(dp) :: C,T,Y - - N = size(vec) - - KahanSum = 0.0 - C = 0.0 - do I = 1,N - y = vec(I) - C - T = KahanSum + Y - C = (T - KahanSum) - Y - KahanSum = T - end do - - end function - - subroutine writeapproxhessiangrad(x,data,filename) - - implicit none - - real(dp) :: x(:) - character(len=1) :: data(:) - character(*) :: filename - - type(potential_minimise) :: am - - real(dp),parameter :: eps = 10.0**(-3) - - real(dp), allocatable :: hess(:) - integer, allocatable :: hessinds(:,:) - real(dp),allocatable :: gp(:,:), gm(:,:), g(:), xm(:) - - integer :: I,J,II,JJ,N - integer :: hx, hy, thisind, hxcount - integer :: nneigh = 500 - integer :: thisneighcount, thisotherind - - N = size(x) - am = transfer(data,am) - allocate(xm(N),g(N)) - allocate(gp(N,N-9)) - allocate(gm(N,N-9)) - allocate(hessinds(3*am%minim_at%N*nneigh,2)) - allocate(hess(3*am%minim_at%N*nneigh)) - - hess = 0.0 - hessinds = 0 - gp = 0.0 - gm = 0.0 - call verbosity_push_decrement() - do I = 10,N - xm = x - xm(I) = xm(I) + 1.0*eps - g = gradient_func(xm,data) - !call print(g) - !call exit() - gp(1:N,I-9) = g - xm(I) = xm(I) - 2.0*eps - g = gradient_func(xm,data) - gm(1:N,I-9) = g - !call print(gp(1:N,I-9)) - end do - call verbosity_pop() - !call exit() - hxcount = 1 - do I = 1,(am%minim_at%N) ! Loop over atoms - !call print(I) - thisneighcount = n_neighbours(am%minim_at,I) - !call print(x) - !call exit() - if(thisneighcount > 3*nneigh) then - call print("Not enough memory was allocated for Hessian, increase value of nneigh") - end if - - do II = 1,3 ! Loop over coordinates of atom I - hx = 3*(I-1) + II - - do J = 1,(thisneighcount+1) ! Loop over neighbours of atom I - if (J > 1) then - thisind = neighbour(am%minim_at,I,J-1,index=thisotherind) - else - thisind = I - end if - do JJ = 1,3 ! Loop over coordinates of atom J - hy = 3*(thisind-1) + JJ - if (hy >= hx) then - !call print(hx //" "//hy//" "//gp(hy+9,hx) // " "// gm(hy+9,hx) // " "// gp(hx+9,hy)// " "//gm(hx+9,hy)) - !call print(gp(1:N,1)) - !call exit() - hess(hxcount) = (gp(hy+9,hx) - gm(hy+9,hx))/(4.0*eps) + (gp(hx+9,hy) - gm(hx+9,hy))/(4.0*eps) - hessinds(hxcount,1) = hx - hessinds(hxcount,2) = hy - !call print(I // ' ' // II // ' '// thisind// ' '//JJ//' ' // J // ' '// hx // ' '//hy// ' '//hess(hxcount)) - hxcount = hxcount + 1 - end if - !call print(fpp// ' '//fpm// ' '//fmp // ' '// fmm// ' '//fpp+fmm-fmp-fpm) - end do - end do - end do - end do - !call exit() - call writevec(hess,filename // 'hess.dat') - call writematint(hessinds, filename // 'hessinds.dat') - !call exit() - end subroutine - - subroutine getapproxhessian(x,data,hessout) - - implicit none - - real(dp),intent(in) :: x(:) - character(len=1),intent(in) :: data(:) - real(dp),intent(inout) :: hessout(:,:) - - type(potential_minimise) :: am - - real(dp),parameter :: eps = 10.0**(-3) - - real(dp),allocatable :: gp(:,:), gm(:,:), g(:), xm(:) - real(dp) :: hesscoeff - integer :: I,J,II,JJ,N - integer :: hx, hy, thisind, hxcount - integer :: nneigh = 500 - integer :: thisneighcount, thisotherind - - N = size(x) - am = transfer(data,am) - allocate(xm(N),g(N)) - allocate(gp(N,N-9)) - allocate(gm(N,N-9)) - - hessout = 0.0_dp - - gp = 0.0 - gm = 0.0 - call verbosity_push_decrement() - do I = 10,N - xm = x - xm(I) = xm(I) + 1.0*eps - g = gradient_func(xm,data) - !call print(g) - !call exit() - gp(1:N,I-9) = g - xm(I) = xm(I) - 2.0*eps - g = gradient_func(xm,data) - gm(1:N,I-9) = g - !call print(gp(1:N,I-9)) - end do - call verbosity_pop() - !call exit() - hxcount = 1 - do I = 1,9 - hessout(I,I) = 1 - end do - do I = 1,(am%minim_at%N) ! Loop over atoms - !call print(I) - thisneighcount = n_neighbours(am%minim_at,I) - !call print(x) - !call exit() - if(thisneighcount > 3*nneigh) then - call print("Not enough memory was allocated for Hessian, increase value of nneigh") - end if - - do II = 1,3 ! Loop over coordinates of atom I - hx = 3*(I-1) + II - - do J = 1,(thisneighcount+1) ! Loop over neighbours of atom I - if (J > 1) then - thisind = neighbour(am%minim_at,I,J-1,index=thisotherind) - else - thisind = I - end if - do JJ = 1,3 ! Loop over coordinates of atom J - hy = 3*(thisind-1) + JJ - if (hy >= hx) then - !call print(hx //" "//hy//" "//gp(hy+9,hx) // " "// gm(hy+9,hx) // " "// gp(hx+9,hy)// " "//gm(hx+9,hy)) - !call print(gp(1:N,1)) - !call exit() - hesscoeff = (gp(hy+9,hx) - gm(hy+9,hx))/(4.0*eps) + (gp(hx+9,hy) - gm(hx+9,hy))/(4.0*eps) - hessout(hx+9,hy+9) = hessout(hx+9,hy+9) + hesscoeff - if (hy > hx) then - hessout(hy+9,hx+9) = hessout(hy+9,hx+9) + hesscoeff - end if - !call print(I // ' ' // II // ' '// thisind// ' '//JJ//' ' // J // ' '// hx // ' '//hy// ' '//hess(hxcount)) - hxcount = hxcount + 1 - end if - !call print(fpp// ' '//fpm// ' '//fmp // ' '// fmm// ' '//fpp+fmm-fmp-fpm) - end do - end do - end do - end do - deallocate(xm,g,gp,gm) - !call exit() - !call exit() - end subroutine - - subroutine getfdhconnectivity(rows,diag,rn,data) - - implicit none - - integer, intent(inout) :: rows(:), diag(:) - character(len=1),intent(in) :: data(:) - integer, intent(out) :: rn - - type(potential_minimise) :: am - integer :: rowsindex - integer :: thisneighcount,thisind - integer :: I, J, II, JJ, hx, hy - integer :: buffer(300) - integer :: bufferindex - integer :: cleanN - - diag(1:9) = (/1, 2, 3, 4, 5, 6, 7, 8, 9/) - rows(1:9) = (/1, 2, 3, 4, 5, 6, 7, 8, 9/) - am = transfer(data,am) - - rowsindex = 10 - do I = 1,(am%minim_at%N) - thisneighcount = n_neighbours(am%minim_at,I) - - do II = 1,3 ! Loop over coordinates of atom I - - hx = 3*(I-1) + II + 9 - diag(hx) = rowsindex - buffer = 3*am%minim_at%N + 10 - bufferindex = 1 - do J = 1,(thisneighcount+1) ! Loop over neighbours of atom I - - if (J > 1) then - thisind = neighbour(am%minim_at,I,J-1) - else - thisind = I - end if - !if (thisind >= I) then - do JJ = 1,3 - hy = 3*(thisind-1) + JJ + 9 - if (hy>=hx) then - buffer(bufferindex) = hy - bufferindex = bufferindex+1 - !rows(rowsindex) = hy - !rowsindex = rowsindex + 1 - end if - end do - !end if - end do - !call print(" ") - !call print(buffer) - call fdhcleaner(buffer,3*am%minim_at%N+10,cleanN) - !call print(buffer(1:cleanN)) - rows(rowsindex:(rowsindex+cleanN-1)) = buffer(1:cleanN) - rowsindex = rowsindex + cleanN - end do - end do - rn = rowsindex-1 - end subroutine - - recursive function qsort( data ) result( sorted ) - integer, dimension(:), intent(in) :: data - integer, dimension(1:size(data)) :: sorted - if ( size(data) > 1 ) then - sorted = (/ qsort( pack( data(2:), abs(data(2:)) <= abs(data(1)) ) ), data(1), qsort( pack( data(2:), abs(data(2:)) > abs(data(1)) ) ) /) - else - sorted = data - endif - end function - - subroutine fdhcleaner(data,data_max,cleanN) - - implicit none - - integer, intent(inout) :: data(:) - integer, intent(in) :: data_max - integer, intent(out) :: cleanN - - integer :: I, N - - N = size(data) - data = qsort(data) - - !call print(data) - !call exit() - I = 1 - do - !call print(I // ' ' // N // ' '// data(I:) // ' '// data_max) - if (data(I) == data(I+1)) then - data(I+1:N-1) = data(I+2:N) - else - I = I+1 - end if - if(I == N .or. data(I) >= data_max) then - exit - end if - end do - cleanN = I-1 - - end subroutine - -end module diff --git a/src/Potentials/Potential_Sum_header.f95 b/src/Potentials/Potential_Sum_header.f95 deleted file mode 100644 index e4b0f92c29..0000000000 --- a/src/Potentials/Potential_Sum_header.f95 +++ /dev/null @@ -1,32 +0,0 @@ - - public :: Potential_Sum - type Potential_Sum - type(MPI_context) :: mpi - - type(Potential), pointer :: pot1 => null() - type(Potential), pointer :: pot2 => null() - - logical :: subtract_pot1 - logical :: subtract_pot2 - end type Potential_Sum - - interface Initialise - module procedure Potential_Sum_Initialise - end interface - - interface Finalise - module procedure Potential_Sum_Finalise - end interface - - interface Print - module procedure Potential_Sum_Print - end interface - - interface Cutoff - module procedure Potential_Sum_Cutoff - end interface - - interface Calc - module procedure Potential_Sum_Calc - end interface - diff --git a/src/Potentials/Potential_Sum_routines.f95 b/src/Potentials/Potential_Sum_routines.f95 deleted file mode 100644 index bd2f3646ca..0000000000 --- a/src/Potentials/Potential_Sum_routines.f95 +++ /dev/null @@ -1,174 +0,0 @@ - - !************************************************************************* - !* - !* Potential_Sum routines - !* - !************************************************************************* - - recursive subroutine Potential_Sum_Initialise(this, args_str, pot1, pot2, mpi, error) - type(Potential_Sum), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(Potential), intent(in), target :: pot1, pot2 - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - INIT_ERROR(error) - - call finalise(this) - - this%pot1 => pot1 - this%pot2 => pot2 - - if (present(mpi)) this%mpi = mpi - - end subroutine Potential_Sum_Initialise - - recursive subroutine Potential_Sum_Finalise(this) - type(Potential_Sum), intent(inout) :: this - - nullify(this%pot1) - nullify(this%pot2) - - end subroutine Potential_Sum_Finalise - - recursive subroutine Potential_Sum_Print(this, file, dict) - type(Potential_Sum), intent(inout) :: this - type(Inoutput), intent(inout), optional :: file - type(Dictionary), intent(inout), optional :: dict - - call print('Potential_Sum:', file=file) - call print('', file=file) - if (associated(this%pot1)) then - call print('Potential 1:', file=file) - call print(this%pot1, file=file, dict=dict) - call print('', file=file) - else - call print('Potential 1 not initialised', file=file) - call print('', file=file) - end if - if (associated(this%pot2)) then - call print('Potential 2:', file=file) - call Print(this%pot2, file=file, dict=dict) - call print('', file=file) - else - call print('Potential 2 not initialised', file=file) - call print('', file=file) - end if - - end subroutine Potential_Sum_Print - - recursive subroutine Potential_Sum_Calc(this, at, args_str, error) - type(Potential_Sum), intent(inout) :: this - type(Atoms), intent(inout) :: at - character(*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - real(dp) :: energy, virial(3,3) - real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:), at_local_virial_ptr(:,:) - - real(dp) :: my_e_1, my_e_2 - real(dp), allocatable :: my_local_e_1(:) - real(dp), allocatable :: my_f_1(:,:), my_local_virial_1(:,:) - real(dp) :: my_virial_1(3,3) - type(Dictionary) :: params - character(STRING_LENGTH) :: calc_energy, calc_force, calc_local_energy, calc_virial, calc_local_virial, calc_args_pot1, calc_args_pot2, my_args_str - logical :: store_contributions - - INIT_ERROR(error) - - call initialise(params) - call param_register(params,"energy", "", calc_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"force", "", calc_force, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"virial", "", calc_virial, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"local_energy", "", calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"local_virial", "", calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"calc_args_pot1", "", calc_args_pot1, help_string="additional args_str to pass along to pot1") - call param_register(params,"calc_args_pot2", "", calc_args_pot2, help_string="additional args_str to pass along to pot2") - call param_register(params,"store_contributions", "F", store_contributions, help_string="if true, store contributions to sum with _pot1 and _pot2 suffixes") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Sum_calc args_str')) then - RAISE_ERROR('Potential_Sum_calc failed to parse args_str="'//trim(args_str)//'"', error) - endif - call finalise(params) - - my_args_str = optional_default("", args_str) - - call calc(this%pot1, at, args_str=trim(my_args_str)//" "//calc_args_pot1, error=error) - PASS_ERROR(error) - if (len_trim(calc_energy) > 0) then - call get_param_value(at, trim(calc_energy), my_e_1) - call print("Potential_sum my_e_1 " // my_e_1, PRINT_VERBOSE) - if (store_contributions) call set_param_value(at, trim(calc_energy)//"_pot1", my_e_1) - endif - if (len_trim(calc_virial) > 0) then - call get_param_value(at, trim(calc_virial), my_virial_1) - if (store_contributions) call set_param_value(at, trim(calc_virial)//"_pot1", my_virial_1) - endif - if (len_trim(calc_local_energy) > 0) then - call assign_property_pointer(at, trim(calc_local_energy), at_local_energy_ptr, error=error) - PASS_ERROR(error) - allocate(my_local_e_1(at%N)) - my_local_e_1 = at_local_energy_ptr - if (store_contributions) call add_property(at, trim(calc_local_energy)//"_pot1", at_local_energy_ptr, overwrite=.true.) - endif - if (len_trim(calc_force) > 0) then - call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) - PASS_ERROR(error) - allocate(my_f_1(3, at%N)) - my_f_1 = at_force_ptr - if (store_contributions) call add_property(at, trim(calc_force)//"_pot1", at_force_ptr, overwrite=.true.) - endif - if (len_trim(calc_local_virial) > 0) then - call assign_property_pointer(at, trim(calc_local_virial), at_local_virial_ptr, error=error) - PASS_ERROR(error) - allocate(my_local_virial_1(9, at%N)) - my_local_virial_1 = at_local_virial_ptr - if (store_contributions) call add_property(at, trim(calc_local_virial)//"_pot1", at_local_virial_ptr, overwrite=.true.) - endif - - - call calc(this%pot2, at, args_str=trim(my_args_str)//" "//calc_args_pot2, error=error) - PASS_ERROR(error) - if (len_trim(calc_energy) > 0) then - call get_param_value(at, trim(calc_energy), energy) - call print("Potential_sum my_e_2 " // energy, PRINT_VERBOSE) - if (store_contributions) call set_param_value(at, trim(calc_energy)//"_pot2", energy) - energy = my_e_1 + energy - call set_param_value(at, trim(calc_energy), energy) - endif - if (len_trim(calc_virial) > 0) then - call get_param_value(at, trim(calc_virial), virial) - if (store_contributions) call set_param_value(at, trim(calc_virial)//"_pot2", virial) - virial = my_virial_1 + virial - call set_param_value(at, trim(calc_virial), virial) - endif - if (len_trim(calc_local_energy) > 0) then - if (store_contributions) call add_property(at, trim(calc_local_energy)//"_pot2", at_local_energy_ptr, overwrite=.true.) - at_local_energy_ptr = my_local_e_1 + at_local_energy_ptr - endif - if (len_trim(calc_force) > 0) then - if (store_contributions) call add_property(at, trim(calc_force)//"_pot2", at_force_ptr, overwrite=.true.) - at_force_ptr = my_f_1 + at_force_ptr - end if - if (len_trim(calc_local_virial) > 0) then - if (store_contributions) call add_property(at, trim(calc_local_virial)//"_pot2", at_local_virial_ptr, overwrite=.true.) - at_local_virial_ptr = my_local_virial_1 + at_local_virial_ptr - end if - - if (allocated(my_local_e_1)) deallocate(my_local_e_1) - if (allocated(my_f_1)) deallocate(my_f_1) - if (allocated(my_local_virial_1)) deallocate(my_local_virial_1) - - end subroutine Potential_Sum_Calc - - recursive function Potential_Sum_Cutoff(this) - type(Potential_Sum), intent(in) :: this - real(dp) :: potential_sum_cutoff - - if(associated(this%pot1) .and. associated(this%pot2)) then - potential_sum_cutoff = max(cutoff(this%pot1), cutoff(this%pot2)) - else - potential_sum_cutoff = 0.0_dp - endif - - end function Potential_Sum_Cutoff - diff --git a/src/Potentials/Potential_simple.f95 b/src/Potentials/Potential_simple.f95 deleted file mode 100644 index fe0bdb2aac..0000000000 --- a/src/Potentials/Potential_simple.f95 +++ /dev/null @@ -1,1612 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X Potential_simple module -!X -!% The Potential_simple module handles the first-level selection of the -!% desidered force field (tight-binding \texttt{TB_type}, empirical potential \texttt{IP_type} or -!% hybrid description \texttt{FilePot_type}). -!% It contains the interfaces \texttt{Initialise}, \texttt{Finalise}, \texttt{cutoff}, -!% \texttt{Calc}, \texttt{Print}, which have the only role to -!% re-addressing the calls to the corresponding -!% modules. -!% A Potential object simply contains a pointer to the desired force field type -!% (only one of the three can be selected). -!% It is initialised with -!%> call Initialise(pot,arg_str,io_obj,[mpi_obj]) -!% where, \texttt{arg_str} is a string defining the potential type and -!% possible some additional options. -!% For interatomic potentials \texttt{arg_str} will start with 'IP'; there are several different IPs defined: -!% see documentation for the 'IP_module' module. For tight binding, 'arg_str' should start with 'TB'; -!% see docuementation for 'TB_module' for more details. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" -module Potential_simple_module - - use error_module - use system_module, only : dp, inoutput, PRINT_VERBOSE, PRINT_NERD, PRINT_ALWAYS, PRINT_ANALYSIS, current_verbosity, INPUT, optional_default, parse_string, verbosity_push, verbosity_pop - use extendable_str_module - use dictionary_module - use paramreader_module - use linearalgebra_module - use table_module - use atoms_types_module - use atoms_module - use connection_module, only: is_in_subregion - use cinoutput_module - use clusters_module - use partition_module - - use QUIP_Common_module - use MPI_context_module - use IP_module -#ifdef HAVE_TB - use TB_module -#endif - use FilePot_module - use CallbackPot_module - use SocketPot_module - - implicit none - private - - public :: potential_simple - type Potential_Simple - type(MPI_context) :: mpi - - character(len=124) :: type_args_str - - ! only one of these can be allocated at any given time -#ifdef HAVE_TB - type(TB_type), pointer :: tb => null() -#endif - type(IP_type), pointer :: ip => null() - type(FilePot_type), pointer :: filepot => null() - type(CallbackPot_type), pointer :: callbackpot => null() - type(SocketPot_type), pointer :: socketpot => null() - logical :: is_wrapper - logical :: little_clusters - logical :: force_using_fd - logical :: virial_using_fd - - end type Potential_Simple - -!% Initialise a Potential object (selecting the force field) and, if necessary, the input file for potential parameters. - public :: Initialise - public :: Potential_Simple_Filename_Initialise - interface Initialise - module procedure Potential_Simple_Initialise_inoutput, Potential_Simple_Initialise_str - end interface Initialise - -!% Finalise the Potential_Simple object - public :: Finalise - interface Finalise - module procedure Potential_Simple_Finalise - end interface Finalise - -!% Print potential details - public :: Print - interface Print - module procedure Potential_Simple_Print - end interface Print - -!% Set potential cutoff - public :: cutoff - interface cutoff - module procedure Potential_Simple_cutoff - end interface cutoff - -!% Potential_Simple calculator for energy, forces and virial - public :: Calc - interface Calc - module procedure Potential_Simple_Calc - end interface Calc - -!% Set up what you need for parallel calculation - public :: setup_parallel - interface setup_parallel - module procedure Potential_Simple_setup_parallel - end interface setup_parallel - - public :: set_callback - interface set_callback - module procedure Potential_Simple_set_callback - end interface - -#ifdef HAVE_TB - public :: calc_TB_matrices - interface calc_TB_matrices - module procedure Potential_Simple_calc_TB_matrices - end interface calc_TB_matrices -#endif - -contains - - subroutine Potential_Simple_Filename_Initialise(this, args_str, filename, mpi_obj, no_parallel, error) - type(Potential_simple), intent(inout) :: this - character(len=*), intent(in) :: args_str - character(len=*), intent(in) :: filename - type(MPI_context), intent(in), optional :: mpi_obj - logical, intent(in), optional :: no_parallel - integer, intent(out), optional :: error - - type(inoutput) :: io - - INIT_ERROR(error) - - ! WARNING: setting master_only=.true. may lead to failure if not all processes are calling the initialise - call Initialise(io, filename, INPUT, master_only = .true.) - call Initialise(this, args_str, io, mpi_obj, no_parallel, error=error) - PASS_ERROR(error) - call Finalise(io) - - end subroutine Potential_Simple_Filename_Initialise - - subroutine Potential_simple_Initialise_inoutput(this, args_str, io_obj, mpi_obj, no_parallel, error) - type(Potential_simple), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(Inoutput), intent(inout) :: io_obj - type(MPI_context), intent(in), optional :: mpi_obj - logical, intent(in), optional :: no_parallel - integer, intent(out), optional :: error - - type(extendable_str) :: es - logical my_no_parallel - - INIT_ERROR(error) - - my_no_parallel = optional_default(.false., no_parallel) - call Initialise(es) - if (present(mpi_obj)) then - call read(es, io_obj%unit, convert_to_string=.true., mpi_comm = mpi_obj%communicator, mpi_id=mpi_obj%my_proc) - else - call read(es, io_obj%unit, convert_to_string=.true.) - endif - if (my_no_parallel) then - call Initialise(this, args_str, string(es), error=error) - else - call Initialise(this, args_str, string(es), mpi_obj, error=error) - endif - PASS_ERROR(error) - - call Finalise(es) - - end subroutine Potential_Simple_Initialise_inoutput - - subroutine Potential_Simple_Initialise_str(this, args_str, param_str, mpi_obj, error) - type(Potential_Simple), intent(inout) :: this - character(len=*), intent(in) :: args_str - character(len=*), intent(in), optional :: param_str - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - logical is_TB, is_IP, is_FilePot, is_wrapper, is_callbackpot, is_socketpot - type(Dictionary) :: params - - INIT_ERROR(error) - - call Finalise(this) - - call initialise(params) - call param_register(params, 'TB', 'false', is_TB, help_string="If true, a tight-binding model") - call param_register(params, 'IP', 'false', is_IP, help_string="If true, an interatomic potential model") - call param_register(params, 'FilePot', 'false', is_FilePot, help_string="If true, a potential that interacts with another executable by reading/writing files") - call param_register(params, 'wrapper', 'false', is_wrapper, help_string="If true, a hardcoded wrapper function") - call param_register(params, 'CallbackPot', 'false', is_CallbackPot, help_string="If true, a callback potential (calls arbitrary passed by user)") - call param_register(params, 'SocketPot', 'false', is_SocketPot, help_string="If true, a socket potential that communicates via TCP/IP sockets") - call param_register(params, 'little_clusters', 'false', this%little_clusters, help_string="If true, uses little cluster, calculate forces only") - call param_register(params, 'force_using_fd', 'F', this%force_using_fd, & - help_string="If true, and if 'force' is also present in the calc argument list, calculate forces using finite difference.") - call param_register(params, 'virial_using_fd', 'F', this%virial_using_fd, & - help_string="If true, and if 'virial' is also present in the calc argument list, calculate virial using finite difference.") - - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Simple_Initialise_str args_str')) then - call system_abort("Potential_Simple_Initialise_str failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - - if (count( (/is_TB, is_IP, is_FilePot, is_wrapper, is_callbackpot, is_socketpot /) ) /= 1) then - call system_abort("Potential_Simple_Initialise_str found too few or too many Potential_Simple types args_str='"//trim(args_str)//"'") - endif - - if (is_IP) then - allocate(this%ip) - if(present(param_str)) then - if (this%little_clusters) then - call Initialise(this%ip, args_str, param_str, error=error) - else - call Initialise(this%ip, args_str, param_str, mpi_obj, error=error) - end if - PASS_ERROR(error) - else - RAISE_ERROR('Potential_Simple_initialise: no param_str present during IP init', error) - endif -#ifdef HAVE_TB - else if (is_TB) then - allocate(this%tb) - if(present(param_str)) then - if (this%little_clusters) then - call Initialise(this%tb, args_str, param_str, error=error) - else - call Initialise(this%tb, args_str, param_str, mpi_obj=mpi_obj, error=error) - end if - PASS_ERROR(error) - else - RAISE_ERROR('Potential_Simple_initialise: no param_str present during TB init', error) - endif -#else - else if (is_TB) then - RAISE_ERROR('Potential_Simple_initialise: TB support not compiled in', error) -#endif - else if (is_FilePot) then - allocate(this%filepot) - if (this%little_clusters) then - call Initialise(this%filepot, args_str, error=error) - else - call Initialise(this%filepot, args_str, mpi_obj, error=error) - end if - - PASS_ERROR(error) - else if (is_CallbackPot) then - allocate(this%CallbackPot) - if (this%little_clusters) then - call Initialise(this%callbackpot, args_str, error=error) - else - call Initialise(this%callbackpot, args_str, mpi=mpi_obj, error=error) - end if - PASS_ERROR(error) - else if (is_SocketPot) then - allocate(this%SocketPot) - if (this%little_clusters) then - call Initialise(this%socketpot, args_str, error=error) - else - call Initialise(this%socketpot, args_str, mpi=mpi_obj, error=error) - end if - PASS_ERROR(error) - else if(is_wrapper) then - this%is_wrapper = .true. - endif - - if (present(mpi_obj)) this%mpi = mpi_obj - - end subroutine Potential_Simple_Initialise_str - - subroutine Potential_Simple_Finalise(this, error) - type(Potential_Simple), intent(inout) :: this - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(associated(this%ip)) then - call Finalise(this%ip) - deallocate(this%ip) -#ifdef HAVE_TB - else if(associated(this%tb)) then - call Finalise(this%tb) - deallocate(this%tb) -#endif - elseif(associated(this%filepot)) then - call Finalise(this%filepot) - deallocate(this%filepot) - elseif(associated(this%callbackpot)) then - call Finalise(this%callbackpot) - deallocate(this%callbackpot) - elseif(associated(this%socketpot)) then - call Finalise(this%socketpot) - deallocate(this%socketpot) - end if - this%is_wrapper = .false. - end subroutine Potential_Simple_Finalise - - function Potential_Simple_cutoff(this) - type(Potential_Simple), intent(in) :: this - real(dp) :: Potential_Simple_cutoff - - if(associated(this%ip)) then - Potential_Simple_cutoff = cutoff(this%ip) -#ifdef HAVE_TB - else if(associated(this%tb)) then - Potential_Simple_cutoff = cutoff(this%tb) -#endif - elseif(associated(this%filepot)) then - Potential_Simple_cutoff = cutoff(this%filepot) - elseif(associated(this%callbackpot)) then - Potential_Simple_cutoff = cutoff(this%callbackpot) - elseif(associated(this%socketpot)) then - Potential_Simple_cutoff = cutoff(this%socketpot) - else - Potential_Simple_cutoff = 0.0_dp - end if - end function Potential_Simple_cutoff - - recursive subroutine Potential_Simple_Calc(this, at, args_str, error) - type(Potential_Simple), intent(inout) :: this - type(Atoms), intent(inout) :: at !% The atoms structure to compute energy and forces - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - real(dp) :: energy, virial(3,3), deform(3,3), lat_save(3,3) - real(dp), allocatable :: allpos_save(:,:) - real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:), at_local_virial_ptr(:,:) - - integer:: i,j,k,n, zero_loc(1) - real(dp):: e_plus, e_minus, pos_save, r_scale, E_scale, cluster_box_buffer - type(Dictionary) :: params - logical :: single_cluster, little_clusters, dummy, do_rescale_r, do_rescale_E, has_cluster_box_buffer - integer :: partition_k_clusters - real(dp) :: partition_nneightol - logical :: partition_do_ripening - character(len=STRING_LENGTH) :: my_args_str, cluster_args_str, new_args_str - integer, pointer, dimension(:) :: hybrid_mark, cluster_index, termindex, modified_hybrid_mark - real(dp), pointer, dimension(:) :: weight_region1, at_prop_ptr_r, cluster_prop_ptr_r - integer, allocatable, dimension(:) :: hybrid_mark_saved - logical, allocatable, dimension(:) :: cluster_mask - real(dp), allocatable, dimension(:) :: weight_region1_saved - real(dp), pointer, dimension(:,:) :: f_cluster - logical :: do_carve_cluster - type(Table) :: cluster_info, cut_bonds, t - integer, pointer :: cut_bonds_p(:,:), old_cut_bonds_p(:,:) - integer :: i_inner, i_outer, n_non_term - type(Atoms) :: cluster - character(len=STRING_LENGTH), target :: calc_force, calc_energy, calc_local_energy, calc_virial, calc_local_virial - logical :: do_calc_force, do_calc_energy, do_calc_local_energy, do_calc_virial, do_calc_local_virial - - integer, pointer :: cluster_mark_p(:), at_prop_ptr_i(:), cluster_prop_ptr_i(:) - integer, pointer :: old_cluster_mark_p(:) - character(len=STRING_LENGTH) :: run_suffix - logical :: force_using_fd, use_ridders - real(dp) :: force_fd_delta - logical :: virial_using_fd - real(dp) :: virial_fd_delta - real(dp) :: origin(3), extent(3,3), extent_inv(3,3), subregion_center(3) - - character(len=STRING_LENGTH) :: read_extra_param_list, read_extra_property_list - character(STRING_LENGTH) :: tmp_params_array(100), copy_keys(100) - integer :: n_copy, n_params, prop_j - - integer, parameter :: ridders_ntab = 10 - real(dp), parameter :: ridders_con = 1.4_dp - real(dp), parameter :: ridders_con2 = ridders_con**2 - real(dp), parameter :: ridders_safe = 2.0_dp - integer :: ridders_itab, ridders_jtab - real(dp) :: ridders_hh, ridders_error, ridders_errort, ridders_fac, ridders_a(ridders_ntab,ridders_ntab) - - - INIT_ERROR(error) - - if (at%N <= 0) then - RAISE_ERROR("Potential_Simple_Calc called with at%N <= 0", error) - endif - - if (present(args_str)) then - call print('Potential_Simple_calc got args_str "'//trim(args_str)//'"', PRINT_VERBOSE) - my_args_str = args_str - else - call print('Potential_Simple_calc got no args_str', PRINT_VERBOSE) - my_args_str = "" - endif - - call initialise(params) - call param_register(params, 'single_cluster', 'F', single_cluster, & - help_string="If true, calculate all active/transition atoms with a single big cluster") - call param_register(params, 'run_suffix', '', run_suffix, & - help_string="suffix to append to hybrid_mark field used") - call param_register(params, 'carve_cluster', 'T', do_carve_cluster, & - help_string="If true, calculate active region atoms by carving out a cluster") - call param_register(params, 'little_clusters', 'F', little_clusters, & - help_string="If true, calculate forces (only) by doing each atom separately surrounded by a little buffer cluster") - call param_register(params, 'partition_k_clusters', '0', partition_k_clusters, & - help_string="If given and K > 1, partition QM core region into K sub-clusters using partition_qm_list() routine") - call param_register(params, 'partition_nneightol', '0.0', partition_nneightol, & - help_string="If given override at%nneightol used to generate connectivity matrix for partitioning") - call param_register(params, 'partition_do_ripening', 'F', partition_do_ripening, & - help_string="If true, enable digestive ripening to refine the METIS-generated K-way partitioning (not yet implemented)") - call param_register(params, 'cluster_box_buffer', '0.0', cluster_box_buffer, has_value_target=has_cluster_box_buffer, & - help_string="If present, quickly cut out atoms in box within cluster_box_radius of any active atoms, rather than doing it properly") - call param_register(params, 'r_scale', '1.0', r_scale, has_value_target=do_rescale_r, & - help_string="rescale calculated positions (and correspondingly forces) by this factor") - call param_register(params, 'E_scale', '1.0', E_scale, has_value_target=do_rescale_E, & - help_string="rescale calculate energies (and correspondingly forces) by this factor") - call param_register(params, 'use_ridders', 'F', use_ridders, & - help_string="If true and using numerical derivatives, use the Ridders method.") - call param_register(params, 'force_using_fd', 'F', force_using_fd, & - help_string="If true, and if 'force' is also present in the argument list, calculate forces using finite difference.") - call param_register(params, 'force_fd_delta', '1.0e-4', force_fd_delta, & - help_string="Displacement to use with finite difference force calculation") - call param_register(params, 'virial_using_fd', 'F', virial_using_fd, & - help_string="If true, and if 'virial' is also present in the argument list, calculate virial using finite difference.") - call param_register(params, 'virial_fd_delta', '1.0e-4', virial_fd_delta, & - help_string="Displacement to use with finite difference virial calculation") - call param_register(params, 'energy', '', calc_energy, & - help_string="If present, calculate energy and put it in field with this string as name") - call param_register(params, 'force', '', calc_force, & - help_string="If present, calculate force and put it in field with this string as name") - call param_register(params, 'local_energy', '', calc_local_energy, & - help_string="If present, calculate local_energy and put it in field with this string as name") - call param_register(params, 'virial', '', calc_virial, & - help_string="If present, calculate virial and put it in field with this string as name") - call param_register(params, 'local_virial', '', calc_local_virial, & - help_string="If present, calculate local_virial and put it in field with this string as name") - call param_register(params, "read_extra_param_list", '', read_extra_param_list, & - help_string="if single_cluster=T and carve_cluster=T, extra params to copy back from cluster") - call param_register(params, "read_extra_property_list", '', read_extra_property_list, & - help_string="if single_cluster=T and carve_cluster=T, extra properties to copy back from cluster") - - if (.not. param_read_line(params, my_args_str, ignore_unknown=.true.,task='Potential_Simple_Calc_str args_str') ) then - RAISE_ERROR("Potential_Simple_calc failed to parse args_str='"//trim(my_args_str)//"'", error) - endif - call finalise(params) - - if(this%force_using_fd) then - force_using_fd = .true. - end if - if(this%virial_using_fd) then - virial_using_fd = .true. - end if - - if (count((/single_cluster, little_clusters, partition_k_clusters > 1/)) > 1) then - RAISE_ERROR('Potential_Simple_calc: single_cluster and little_clusters options are mutually exclusive', error) - endif - - if (len_trim(calc_force) > 0) then - call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) - PASS_ERROR(error) - endif - if (len_trim(calc_local_energy) > 0) then - call assign_property_pointer(at, trim(calc_local_energy), at_local_energy_ptr, error=error) - PASS_ERROR(error) - endif - if (len_trim(calc_local_virial) > 0) then - call assign_property_pointer(at, trim(calc_local_virial), at_local_virial_ptr, error=error) - PASS_ERROR(error) - endif - - if (little_clusters) then - - if (.not. this%little_clusters) then - RAISE_ERROR('Potential_Simple_calc: little_clusters=T in calc() args_str but not in initialise() args_str.', error) - end if - - if (len_trim(calc_energy) > 0 .or. len_trim(calc_local_energy) > 0 .or. len_trim(calc_virial) > 0 .or. len_trim(calc_local_virial) > 0 .or. & - len_trim(calc_force) <= 0) then - RAISE_ERROR('Potential_Simple_calc: little_clusters option only supports calculation of forces, not energies, local energies or virials', error) - endif - - ! modified args_str options for create_cluster_info() and carve_cluster() - call initialise(params) - call read_string(params, my_args_str) - call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE - if (do_rescale_r) call set_value(params, 'do_rescale_r', .true.) - cluster_args_str = write_string(params, real_format='f16.8') - call finalise(params) - - ! modified args_str options for potential calc() on clusters - ! must remove "little_clusters" from args_str so that recursion terminates - ! We rescale cluster explicity, so remove from args_str so that underlying potential doesn't do it - call initialise(params) - call read_string(params, my_args_str) - call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE - call remove_value(params, 'little_clusters') - call remove_value(params, 'r_scale') - call remove_value(params, 'E_scale') - new_args_str = write_string(params, real_format='f16.8') - call finalise(params) - - if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then - RAISE_ERROR('Potential_Simple_calc: cannot assign pointer to hybrid_mark property ', error) - endif - - if (.not. any(hybrid_mark == HYBRID_ACTIVE_MARK)) then - at_force_ptr = 0.0_dp - return - end if - - ! Save hybrid_mark and weight_region1, because we're going to overwrite them - allocate(hybrid_mark_saved(at%N)) - hybrid_mark_saved = hybrid_mark - - if (has_property(at, 'weight_region1'//trim(run_suffix))) then - dummy = assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1) - allocate(weight_region1_saved(at%N)) - weight_region1_saved = weight_region1 - end if - - ! call ourselves once for each active or transition atom - at_force_ptr = 0.0_dp - n = 0 - do i=1,at%N - if (hybrid_mark_saved(i) /= HYBRID_ACTIVE_MARK .and. hybrid_mark_saved(i) /= HYBRID_TRANS_MARK) cycle - - if (this%mpi%active) then - n = n + 1 - call print('Potential_Simple_calc: cluster '//n//' around atom '//i//' assigned to proc '//mod(n-1,this%mpi%n_procs)//' of '//(this%mpi%n_procs), PRINT_VERBOSE) - if (mod(n-1, this%mpi%n_procs) .ne. this%mpi%my_proc) cycle - end if - call print('Potential_Simple_calc: constructing little_cluster around atom '//i, PRINT_VERBOSE) - hybrid_mark = HYBRID_NO_MARK - hybrid_mark(i) = HYBRID_ACTIVE_MARK - call create_hybrid_weights(at, cluster_args_str) - cluster_info = create_cluster_info_from_mark(at, cluster_args_str,mark_name='hybrid_mark'//trim(run_suffix),error=error) - PASS_ERROR_WITH_INFO("potential_calc: creating little cluster ="//i//" from hybrid_mark", error) - call carve_cluster(at, cluster_args_str, cluster_info, cluster) - call finalise(cluster_info) - - ! Reassign pointers - create_cluster_info_from_mark() might have broken them - if (has_property(at, 'hybrid_mark'//trim(run_suffix))) & - dummy = assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark) - if (has_property(at, 'weight_region1'//trim(run_suffix))) & - dummy = assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1) - - if (current_verbosity() >= PRINT_NERD) then - call write(cluster, 'stdout', prefix='LITTLE_CLUSTER') - endif - call print('ARGS0 | '//cluster_args_str,PRINT_VERBOSE) - - ! Disable MPI for duration of calc() call, since we're doing parallelisation at level of clusters - call calc(this, cluster, args_str=new_args_str) - if (.not. assign_pointer(cluster, trim(calc_force), f_cluster)) then - RAISE_ERROR('Potential_Simple_calc: small_clusters failed to get a valid '//trim(calc_force)//' property in cluster from calc',error) - endif - - if (do_rescale_r) f_cluster = f_cluster*r_scale - if (do_rescale_E) f_cluster = f_cluster*E_scale - at_force_ptr(:,i) = f_cluster(:,1) - call finalise(cluster) - end do - - if (this%mpi%active) then - call sum_in_place(this%mpi, at_force_ptr) - end if - hybrid_mark = hybrid_mark_saved - deallocate(hybrid_mark_saved) - - if (allocated(weight_region1_saved)) then - weight_region1 = weight_region1_saved - deallocate(weight_region1_saved) - end if - - else if (partition_k_clusters > 1) then - - ! Split QM cluster into K pieces using METIS graph partitioning library call - - if (partition_nneightol == 0.0_dp) partition_nneightol = at%nneightol - call partition_qm_list(at, partition_k_clusters, partition_nneightol, partition_do_ripening) - call write(at, 'partitioned.xyz') - - ! ... FIXME need to loop over the sub-clusters and call ourselves recursively on each - - else if (single_cluster) then - - if (len_trim(calc_energy) > 0 .or. len_trim(calc_local_energy) > 0 .or. len_trim(calc_virial) > 0 .or. len_trim(calc_local_virial) > 0 .or. & - len_trim(calc_force) <= 0) then - RAISE_ERROR('Potential_Simple_calc: single_cluster option only supports calculation of forces, not energies, local energies or virials', error) - endif - - if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then - RAISE_ERROR('Potential_Simple_calc: single_cluster cannot assign pointer to hybrid_mark'//trim(run_suffix)//' property ', error) - endif - - if (.not. any(hybrid_mark == HYBRID_ACTIVE_MARK)) then - at_force_ptr = 0.0_dp - return - end if - - ! modified args_str options for create_cluster_info() and carve_cluster() - call initialise(params) - call read_string(params, my_args_str) - call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE - if (do_rescale_r) call set_value(params, 'do_rescale_r', .true.) - cluster_args_str = write_string(params, real_format='f16.8') - call finalise(params) - - ! modified args_str options for potential calc() on clusters - ! must remove "single_cluster" from args_str so that recursion terminates - ! We rescale cluster explicity, so remove from args_str so that underlying potential doesn't do it - call initialise(params) - call read_string(params, my_args_str) - call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE - call remove_value(params, 'single_cluster') - call remove_value(params, 'r_scale') - call remove_value(params, 'E_scale') - new_args_str = write_string(params, real_format='f16.8') - call finalise(params) - - ! call ourselves on a cluster formed from marked atoms - call print('Potential_Simple_calc: constructing single_cluster', PRINT_VERBOSE) - - if (do_carve_cluster) then - call print('Potential_Simple_calc: carving cluster', PRINT_VERBOSE) - - if (has_cluster_box_buffer) then - call print('Doing quick cluster carving using cluster box buffer '//cluster_box_buffer//' A') - - call estimate_origin_extent(at, hybrid_mark == HYBRID_ACTIVE_MARK, cluster_box_buffer, origin, extent) - call matrix3x3_inverse(extent,extent_inv) - subregion_center = origin + 0.5_dp*sum(extent,2) - allocate(cluster_mask(at%n)) - do i=1, at%N - cluster_mask(i) = is_in_subregion(at%pos(:,i), subregion_center, at%lattice, at%g, extent_inv) - end do - call select(cluster, at, mask=cluster_mask, orig_index=.true.) - deallocate(cluster_mask) - - ! move orig_index property to index//run_suffix - call assign_property_pointer(cluster, 'orig_index', cluster_index, error=error) - PASS_ERROR(error) - call add_property(cluster, 'index'//trim(run_suffix), cluster_index) - call remove_property(cluster, 'orig_index', error=error) - PASS_ERROR(error) - ! there are no terminating atoms - call add_property(cluster, 'termindex'//trim(run_suffix), 0) - else - cluster_info = create_cluster_info_from_mark(at, cluster_args_str, mark_name='hybrid_mark'//trim(run_suffix), error=error) - PASS_ERROR_WITH_INFO("potential_calc: creating cluster info from hybrid_mark", error) - - ! Check there are no repeated indices among the non-termination atoms in the cluster - n_non_term = count(cluster_info%int(6,1:cluster_info%n) == 0) - t = int_subtable(cluster_info,(/ (i,i=1,n_non_term) /),(/1/)) - if (multiple_images(t)) then - RAISE_ERROR('Potential_Simple_calc: single_cluster=T not yet implemented when cluster contains repeated periodic images', error) - endif - call finalise(t) - - call carve_cluster(at, cluster_args_str, cluster_info, cluster, mark_name='hybrid_mark'//trim(run_suffix), error=error) - PASS_ERROR_WITH_INFO("potential_calc: carving cluster", error) - call finalise(cluster_info) - end if - if (current_verbosity() >= PRINT_NERD) then - call write(cluster, 'stdout', prefix='CLUSTER') - endif - if (.not. assign_pointer(cluster, 'index'//trim(run_suffix), cluster_index)) then - RAISE_ERROR('Potential_Simple_calc: cluster is missing index property', error) - endif - if (.not. assign_pointer(cluster, 'termindex'//trim(run_suffix), termindex)) then - RAISE_ERROR('Potential_Simple_calc: cluster is missing termindex property', error) - endif - call print('ARGS1 | '//cluster_args_str,PRINT_VERBOSE) - - call calc(this, cluster, args_str=new_args_str, error=error) - PASS_ERROR_WITH_INFO('potential_calc after calc in carve_cluster', error) - - call assign_property_pointer(cluster, trim(calc_force), f_cluster, error=error) - PASS_ERROR_WITH_INFO('Potential_Simple_calc: single_cluster failed to get a valid '//trim(calc_force)//' property in cluster from calc',error) - if (do_rescale_r) f_cluster = f_cluster*r_scale - if (do_rescale_E) f_cluster = f_cluster*E_scale - - ! Reassign pointers - create_cluster_info_from_mark() might have broken them - if (has_property(at, 'hybrid_mark'//trim(run_suffix))) & - dummy = assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark) - - ! copy forces for all active and transition atoms - at_force_ptr = 0.0_dp - do i=1,cluster%N - if (termindex(i) /= 0) cycle ! skip termination atoms - if (hybrid_mark(cluster_index(i)) == HYBRID_ACTIVE_MARK .or. & - hybrid_mark(cluster_index(i)) == HYBRID_TRANS_MARK) & - at_force_ptr(:,cluster_index(i)) = f_cluster(:,i) - end do - nullify(f_cluster) - - ! might need to copy some params from cluster to main Atoms object, for compatibility with filepot - if (len_trim(read_extra_param_list) > 0) then - call parse_string(read_extra_param_list, ':', tmp_params_array, n_params, error=error) - PASS_ERROR(error) - - n_copy = 0 - do i=1,n_params - if (has_key(cluster%params, trim(tmp_params_array(i)))) then - n_copy = n_copy + 1 - copy_keys(n_copy) = tmp_params_array(i) - call print("Potential_simple calc() copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) - else if (has_key(cluster%params, trim(tmp_params_array(i))//trim(run_suffix))) then - n_copy = n_copy + 1 - copy_keys(n_copy) = trim(tmp_params_array(i))//trim(run_suffix) - call print("Potential_simple calc() copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) - end if - end do - call subset(cluster%params, copy_keys(1:n_copy), at%params, out_no_initialise=.true.) - end if - - ! do the same for any extra properties to be copied back - if (len_trim(read_extra_property_list) > 0) then - call parse_string(read_extra_property_list, ':', tmp_params_array, n_params, error=error) - PASS_ERROR(error) - - n_copy = 0 - do i=1,n_params - if (has_key(cluster%properties, trim(tmp_params_array(i)))) then - n_copy = n_copy + 1 - copy_keys(n_copy) = tmp_params_array(i) - call print("Potential_simple calc() copying property key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) - else if (has_key(cluster%properties, trim(tmp_params_array(i))//trim(run_suffix))) then - n_copy = n_copy + 1 - copy_keys(n_copy) = trim(tmp_params_array(i))//trim(run_suffix) - call print("Potential_simple calc() copying property key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) - end if - end do - - do j=1, n_copy - prop_j = lookup_entry_i(cluster%properties, copy_keys(j)) - if (cluster%properties%entries(prop_j)%type == T_INTEGER_A) then - if (.not. has_property(at, copy_keys(j))) call add_property(at, copy_keys(j), 0) - call assign_property_pointer(at, copy_keys(j), at_prop_ptr_i, error=error) - PASS_ERROR(error) - call assign_property_pointer(cluster, copy_keys(j), cluster_prop_ptr_i, error=error) - PASS_ERROR(error) - do i=1,cluster%N - at_prop_ptr_i(cluster_index(i)) = cluster_prop_ptr_i(i) - end do - else if (cluster%properties%entries(prop_j)%type == T_REAL_A) then - if (.not. has_property(at, copy_keys(j))) call add_property(at, copy_keys(j), 0.0_dp) - call assign_property_pointer(at, copy_keys(j), at_prop_ptr_r, error=error) - PASS_ERROR(error) - call assign_property_pointer(cluster, copy_keys(j), cluster_prop_ptr_r, error=error) - PASS_ERROR(error) - do i=1,cluster%N - at_prop_ptr_r(cluster_index(i)) = cluster_prop_ptr_r(i) - end do - else - RAISE_ERROR('unsupported property type '//cluster%properties%entries(prop_j)%type, error) - end if - end do - end if - - call finalise(cluster) - else ! not do_carve_cluster - call print('Potential_Simple_calc: not carving cluster', PRINT_VERBOSE) - cluster_info = create_cluster_info_from_mark(at, trim(cluster_args_str) // " cluster_same_lattice", cut_bonds, mark_name='hybrid_mark'//trim(run_suffix), error=error) - PASS_ERROR_WITH_INFO('potential_calc creating cluster info from hybrid mark with carve_cluster=F', error) - - call add_property(at, 'cluster_mark'//trim(run_suffix), HYBRID_NO_MARK) - call add_property(at, 'old_cluster_mark'//trim(run_suffix), HYBRID_NO_MARK) - if (.not. assign_pointer(at, 'cluster_mark'//trim(run_suffix), cluster_mark_p)) then - RAISE_ERROR("Potential_Simple_calc failed to assing pointer for cluster_mark"//trim(run_suffix)//" pointer", error) - endif - if (.not. assign_pointer(at, 'old_cluster_mark'//trim(run_suffix), old_cluster_mark_p)) then - RAISE_ERROR("Potential_Simple_calc failed to assing pointer for old_cluster_mark"//trim(run_suffix)//" pointer", error) - endif - old_cluster_mark_p = cluster_mark_p - cluster_mark_p = HYBRID_NO_MARK - if (.not. assign_pointer(at, 'modified_hybrid_mark'//trim(run_suffix), modified_hybrid_mark)) then - cluster_mark_p = hybrid_mark - else - cluster_mark_p = modified_hybrid_mark - endif - - !save cut bonds in cut_bonds property - call add_property(at, 'old_cut_bonds'//trim(run_suffix), 0, n_cols=MAX_CUT_BONDS) - if (.not. assign_pointer(at, 'old_cut_bonds'//trim(run_suffix), old_cut_bonds_p)) then - RAISE_ERROR("Potential_Simple_calc failed to assing pointer for cut_bonds pointer", error) - endif - call add_property(at, 'cut_bonds'//trim(run_suffix), 0, n_cols=MAX_CUT_BONDS) - if (.not. assign_pointer(at, 'cut_bonds'//trim(run_suffix), cut_bonds_p)) then - RAISE_ERROR("Potential_Simple_calc failed to assing pointer for cut_bonds pointer", error) - endif - old_cut_bonds_p = cut_bonds_p - cut_bonds_p = 0 - do i=1, cut_bonds%N - i_inner = cut_bonds%int(1,i) - i_outer = cut_bonds%int(2,i) - zero_loc = minloc(cut_bonds_p(:,i_inner)) - if (cut_bonds_p(zero_loc(1),i_inner) == 0) then ! free space for a cut bond - cut_bonds_p(zero_loc(1),i_inner) = i_outer - else - call print("cut_bonds table:", PRINT_VERBOSE) - call print(cut_bonds, PRINT_VERBOSE) - call print("ERROR: Potential_Simple_calc ran out of space to store cut_bonds information", PRINT_ALWAYS) - call print("ERROR: inner atom " // i_inner // " already has cut_bonds to " // cut_bonds_p(:,i_inner) // & - " no space to add cut bond to " // i_outer, PRINT_ALWAYS) - RAISE_ERROR("Potential_Simple_calc out of space to store cut_bonds information", error) - endif - end do - call finalise(cut_bonds) - if (current_verbosity() >= PRINT_ANALYSIS) then - ! prefix should be "UNCARVED_CLUSTER" - call write(at, 'stdout') - endif - call calc(this, at, args_str=new_args_str, error=error) - PASS_ERROR_WITH_INFO('potential_calc after calc with carve_cluster=F', error) - if (do_rescale_r) at_force_ptr = at_force_ptr*r_scale - if (do_rescale_E) at_force_ptr = at_force_ptr*E_scale - endif ! do_carve_cluster - else ! little_clusters and single_cluster are false.. - - ! For IP, call setup_atoms() hook now in case any properties must be added. - ! This must be done *before* we assign pointers to force, local_e etc. - if (associated(this%ip)) then - call setup_atoms(this%ip, at) - end if - - do_calc_force = (len_trim(calc_force) > 0) .and. .not. force_using_fd - do_calc_energy = len_trim(calc_energy) > 0 - do_calc_local_energy = len_trim(calc_local_energy) > 0 - do_calc_virial = (len_trim(calc_virial) > 0) .and. .not. virial_using_fd - do_calc_local_virial = len_trim(calc_local_virial) > 0 - call print("do_calc_force= "//do_calc_force//" calc_force="//trim(calc_force), PRINT_VERBOSE) - call print("force_using_fd= "//force_using_fd, PRINT_VERBOSE) - call print("virial_using_fd= "//virial_using_fd, PRINT_VERBOSE) - call print("do_calc_energy= "//do_calc_energy//" calc_energy="//trim(calc_energy), PRINT_VERBOSE) - call print("do_calc_local_energy= "//do_calc_local_energy//" calc_local_energy="//trim(calc_local_energy), PRINT_VERBOSE) - call print("do_calc_virial= "//do_calc_virial//" calc_virial="//trim(calc_virial), PRINT_VERBOSE) - call print("do_calc_local_virial= "//do_calc_local_virial//" calc_local_virial="//trim(calc_local_virial), PRINT_VERBOSE) - - if(do_calc_virial .or. do_calc_energy .or. do_calc_force .or. do_calc_local_energy .or. do_calc_local_virial) then - if(associated(this%ip)) then - - if (do_calc_local_virial) then - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, f=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, local_e=at_local_energy_ptr, f=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, energy=energy, f=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, f=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, f=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, local_e=at_local_energy_ptr, f=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, energy=energy, f=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, f=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - end if - else ! no local virials - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, f=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, local_e=at_local_energy_ptr, f=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, energy=energy, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, energy=energy, f=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, f=at_force_ptr, virial=virial, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, f=at_force_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, local_e=at_local_energy_ptr, f=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, energy=energy, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, energy=energy, f=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, f=at_force_ptr, args_str=args_str, error=error) - end if - end if - endif -#ifdef HAVE_TB - else if(associated(this%tb)) then - - if (do_calc_local_virial) then - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, energy=energy, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, energy=energy, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - end if - else ! no local virials - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, energy=energy, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, energy=energy, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, forces=at_force_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, energy=energy, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, energy=energy, forces=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) - end if - end if - endif - -#endif - elseif(associated(this%filepot)) then - - if (do_calc_local_virial) then - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, energy=energy, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, energy=energy, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - end if - else ! no local virials - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, energy=energy, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, energy=energy, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, forces=at_force_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, energy=energy, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, energy=energy, forces=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) - end if - end if - endif - - elseif(associated(this%callbackpot)) then - - if (do_calc_local_virial) then - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - end if - else ! no local virials - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, forces=at_force_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, forces=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) - end if - end if - endif - - - elseif(associated(this%socketpot)) then - - if (do_calc_local_virial) then - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) - end if - end if - else ! no local virials - if (do_calc_virial) then - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) - end if - else - if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, forces=at_force_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, args_str=args_str, error=error) - else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, forces=at_force_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) - else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then - call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) - end if - end if - endif - - elseif(this%is_wrapper) then - ! - ! put here hardcoded energy and force functions - ! - !if(present(e)) e = wrapper_energy(at) - !if(present(f)) call wrapper_force(at, f) - RAISE_ERROR("Potential_Simple_Calc: hardcoded wrapper functions are not defined", error) - else - RAISE_ERROR ("Potential_Simple_Calc: Potential_Simple is not initialised", error) - end if - PASS_ERROR_WITH_INFO('potential_calc after actual calc', error) - - if (len_trim(calc_energy) /= 0) then - call set_value(at%params, trim(calc_energy), energy) - call print("Setting parameter `"//trim(calc_energy)//"' to "//energy, PRINT_VERBOSE) - end if - if (len_trim(calc_virial) /= 0) then - call set_value(at%params, trim(calc_virial), virial) - end if - - end if - - if (force_using_fd .and. len_trim(calc_force) > 0) then ! do forces by finite difference - - call print("Calculating force by finite differences with displacement="//force_fd_delta, PRINT_VERBOSE) - - ! must remove 'force_using_fd' from args_str if it's there (and the rest, or properties get overwritten) - call initialise(params) - call read_string(params, my_args_str) - call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE - call remove_value(params, 'force_using_fd') - call remove_value(params, 'force') - call remove_value(params, 'energy') - call remove_value(params, 'local_energy') - call remove_value(params, 'virial') - call set_value(params, "energy", "fd_energy") - new_args_str = write_string(params, real_format='f16.8') - call finalise(params) - call print("calc_force="//trim(calc_force), PRINT_ANALYSIS) - call print("New_args_str: "//new_args_str, PRINT_ANALYSIS) - - - if(use_ridders) then - do i = 1, at%N - do k = 1, 3 - pos_save = at%pos(k,i) - ridders_hh = force_fd_delta - - at%pos(k,i) = pos_save + ridders_hh - if(at%cutoff > 0) call calc_dists(at) - call calc(this, at, args_str=new_args_str, error=error) - call get_param_value(at, "fd_energy", e_plus, error=error) - PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) - - at%pos(k,i) = pos_save - ridders_hh - if(at%cutoff > 0) call calc_dists(at) - call calc(this, at, args_str=new_args_str, error=error) - call get_param_value(at, "fd_energy", e_minus, error=error) - PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) - - ridders_a(1,1) = (e_plus - e_minus) / (2.0_dp*ridders_hh) - ridders_error = huge(1.0_dp) - - do ridders_itab = 2, ridders_ntab - ridders_hh = ridders_hh / ridders_con - - at%pos(k,i) = pos_save + ridders_hh - if(at%cutoff > 0) call calc_dists(at) - call calc(this, at, args_str=new_args_str, error=error) - call get_param_value(at, "fd_energy", e_plus, error=error) - PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) - - at%pos(k,i) = pos_save - ridders_hh - if(at%cutoff > 0) call calc_dists(at) - call calc(this, at, args_str=new_args_str, error=error) - call get_param_value(at, "fd_energy", e_minus, error=error) - PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) - - ridders_a(1,ridders_itab) = (e_plus - e_minus) / (2.0_dp*ridders_hh) - ridders_fac = ridders_con2 - - do ridders_jtab = 2, ridders_itab - ridders_a(ridders_jtab,ridders_itab) = (ridders_a(ridders_jtab-1,ridders_itab)*ridders_fac - & - ridders_a(ridders_jtab-1,ridders_itab-1))/(ridders_fac-1.0_dp) - ridders_fac = ridders_con2*ridders_fac - ridders_errort = max(abs(ridders_a(ridders_jtab,ridders_itab)-ridders_a(ridders_jtab-1,ridders_itab)), & - abs(ridders_a(ridders_jtab,ridders_itab)-ridders_a(ridders_jtab-1,ridders_itab-1))) - - if( ridders_errort <= ridders_error ) then - ridders_error = ridders_errort - at_force_ptr(k,i) = -ridders_a(ridders_jtab,ridders_itab) - endif - enddo ! jtab - - if( abs(ridders_a(ridders_itab,ridders_itab)-ridders_a(ridders_itab-1,ridders_itab-1) ) >= ridders_SAFE*ridders_error) exit - enddo ! itab - at%pos(k,i) = pos_save - !error_force(alpha,i) = abs(error) - enddo ! k - enddo ! i - else - do i=1,at%N - do k=1,3 - pos_save = at%pos(k,i) - at%pos(k,i) = pos_save + force_fd_delta - if(at%cutoff > 0) call calc_dists(at) - call calc(this, at, args_str=new_args_str, error=error) - call get_param_value(at, "fd_energy", e_plus, error=error) - PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) - at%pos(k,i) = pos_save - force_fd_delta - if(at%cutoff > 0) call calc_dists(at) - call calc(this, at, args_str=new_args_str, error=error) - call get_param_value(at, "fd_energy", e_minus, error=error) - PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) - at%pos(k,i) = pos_save - if(at%cutoff > 0) call calc_dists(at) - at_force_ptr(k,i) = (e_minus-e_plus)/(2.0_dp*force_fd_delta) ! force is -ve gradient - end do - end do - endif - - call remove_value(at%params, "fd_energy") - call print("Done with finite difference force calculation", PRINT_VERBOSE) - end if - if(virial_using_fd .and. len_trim(calc_virial) > 0) then ! do virial by finite difference - call print("Calculating virial by finite differences with displacement="//virial_fd_delta, PRINT_VERBOSE) - - ! must remove 'virial_using_fd' from args_str if it's there (and the rest, or properties get overwritten) - call initialise(params) - call read_string(params, my_args_str) - call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE - call remove_value(params, 'virial_using_fd') - call remove_value(params, 'force') - call remove_value(params, 'energy') - call remove_value(params, 'local_energy') - call remove_value(params, 'virial') - call set_value(params, "energy", "fd_energy") - new_args_str = write_string(params, real_format='f16.8') - call finalise(params) - - call print("Virial finite difference calculation: new_args_str=`"//new_args_str//"'", PRINT_VERBOSE) - - allocate(allpos_save(3,at%N)) - allpos_save = at%pos - lat_save = at%lattice - do i=1,3 - do j=i,3 - - deform = 0.0_dp - call add_identity(deform) - deform(i,j) = deform(i,j) + virial_fd_delta - if(i /= j) deform(j,i) = deform(j,i) + virial_fd_delta - call set_lattice(at, matmul(deform,lat_save), scale_positions=.true.) - if(at%cutoff > 0) call calc_dists(at) -! call verbosity_push(PRINT_ANALYSIS) -! call print(at) -! call verbosity_pop() - call calc(this, at, args_str=new_args_str, error=error) -! call verbosity_push(PRINT_ANALYSIS) -! call print(at) -! call verbosity_pop() - call get_param_value(at, "fd_energy", e_plus, error=error) - PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd virial failed to get energy property fd_energy", error) - - deform = 0.0_dp - call add_identity(deform) - deform(i,j) = deform(i,j) - virial_fd_delta - if(i /= j) deform(j,i) = deform(j,i) - virial_fd_delta - call set_lattice(at, matmul(deform,lat_save), scale_positions=.true.) - if(at%cutoff > 0) call calc_dists(at) - call calc(this, at, args_str=new_args_str, error=error) - call get_param_value(at, "fd_energy", e_minus, error=error) - PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd virial failed to get energy property fd_energy", error) - virial(i,j) = -(e_plus-e_minus)/(2.0_dp*virial_fd_delta) - virial(j,i) = virial(i,j) - end do - end do - call set_value(at%params, trim(calc_virial), virial) - at%pos = allpos_save - call set_lattice(at, lat_save, scale_positions=.false.) - call remove_value(at%params, "fd_energy") - if(at%cutoff > 0) call calc_dists(at) - deallocate(allpos_save) - call print("Done with finite difference virial calculation", PRINT_VERBOSE) - end if - end if - - end subroutine Potential_Simple_Calc - -! function Potential_Simple_Brief_Description(this) result desc -! type(Potential_Simple), intent(inout) :: this -! character(30), intent(out) :: desc -! if(associated(this%tb)) then -! desc = '' -! elseif(associated(this%ip)) then -! desc = Brief_Description(this%ip) -! elseif(associated(this%filepot)) then -! desc = '' -! elseif(this%is_wrapper) then -! desc = '' -! else -! call system_abort ("Potential_Simple_Brief_Description: Potential_Simple is not initialised") -! end if -! -! end function Potential_Simple_Brief_Description - - - subroutine Potential_Simple_Print(this, file, dict, error) - type(Potential_Simple), intent(inout) :: this - type(Inoutput), intent(inout),optional:: file - type(Dictionary), intent(inout), optional :: dict - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(associated(this%ip)) then - call Print(this%ip, file=file, dict=dict) -#ifdef HAVE_TB - else if(associated(this%tb)) then - call Print(this%tb, file=file) -#endif - elseif(associated(this%filepot)) then - call Print(this%filepot, file=file) - elseif(associated(this%callbackpot)) then - call Print(this%callbackpot, file=file) - elseif(associated(this%socketpot)) then - call Print(this%socketpot, file=file) - elseif(this%is_wrapper) then - call print("Potential_Simple: wrapper Potential_Simple") - else - RAISE_ERROR ("Potential_Simple_Print: no potential type is set", error) - end if - - end subroutine Potential_Simple_Print - - subroutine Potential_Simple_setup_parallel(this, at, args_str, error) - type(Potential_Simple), intent(inout) :: this - type(Atoms), intent(inout) :: at !% The atoms structure to compute energy and forces - character(len=*), intent(in) :: args_str - integer, intent(out), optional :: error - - real(dp) :: e - real(dp), allocatable :: f(:,:) - type(Dictionary) :: params - character(STRING_LENGTH) :: calc_energy, calc_force - - INIT_ERROR(error) - - call initialise(params) - call param_register(params, "energy", "", calc_energy, help_string="If present, calculate energy. Also name of parameter to put energy into") - call param_register(params, "force", "", calc_force, help_string="If present, calculate forces. Also name of property to put forces into") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Simple_setup_parallel args_str')) then - RAISE_ERROR("Potential_Simple_setup_parallel failed to parse args_str='"//trim(args_str)//"'", error) - endif - call finalise(params) - - - if(associated(this%ip)) then - if (len_trim(calc_energy) > 0) then - if (len_trim(calc_force) > 0) then - allocate(f(3,at%n)) - call setup_parallel(this%ip, at, energy=e, f=f, args_str=args_str) - deallocate(f) - else - call setup_parallel(this%ip, at, energy=e, args_str=args_str) - endif - else - if (len_trim(calc_force) > 0) then - allocate(f(3,at%n)) - call setup_parallel(this%ip, at, f=f, args_str=args_str) - deallocate(f) - else - call setup_parallel(this%ip, at, args_str=args_str) - endif - endif -#ifdef HAVE_TB - else if(associated(this%tb)) then - return -#endif - elseif(associated(this%filepot)) then - return - elseif(associated(this%callbackpot)) then - return - elseif(associated(this%socketpot)) then - return - elseif(this%is_wrapper) then - return - else - RAISE_ERROR ("Potential_Simple_Print: Potential_Simple is not initialised", error) - end if - - if (allocated(f)) deallocate(f) - - end subroutine Potential_Simple_setup_parallel - - subroutine Potential_Simple_set_callback(this, callback, error) - type(Potential_Simple), intent(inout) :: this - interface - subroutine callback(at) - integer, intent(in) :: at(12) - end subroutine callback - end interface - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if (.not. associated(this%callbackpot)) then - RAISE_ERROR('Potential_Simple_set_callback: this Potential_Simple is not a CallbackPot', error) - endif - call set_callback(this%callbackpot, callback) - - end subroutine Potential_Simple_set_callback - -#ifdef HAVE_TB - subroutine Potential_Simple_calc_TB_matrices(this, at, args_str, Hd, Sd, Hz, Sz, dH, dS, index, error) - type(Potential_Simple), intent(inout) :: this - type(atoms), intent(inout) :: at - character(len=*), intent(in), optional :: args_str - real(dp), intent(inout), optional, dimension(:,:) :: Hd, Sd - complex(dp), intent(inout), optional, dimension(:,:) :: Hz, Sz - real(dp), intent(inout), optional, dimension(:,:,:,:) :: dH, dS - integer, intent(in), optional :: index - integer, intent(out), optional :: error - - character(len=STRING_LENGTH) :: my_args_str - real(dp), allocatable, dimension(:,:) :: tmp_forces - - INIT_ERROR(error) - - if (.not. associated(this%tb)) then - RAISE_ERROR('Potential_Simple_copy_TB_matrices: this Potential_Simple is not a TB potential', error) - endif - - my_args_str = "" - if (present(args_str)) my_args_str = trim(args_str) - - allocate(tmp_forces(3,at%N)) - call calc(this%tb, at, args_str=trim(my_args_str), forces=tmp_forces, dH=dH, dS=dS, index=index) - call copy_matrices(this%tb, Hd, Sd, Hz, Sz, index=index) - deallocate(tmp_forces) - - end subroutine Potential_Simple_calc_TB_matrices - -#endif - -end module Potential_Simple_module diff --git a/src/Potentials/QC_QUIP_Wrapper.f95 b/src/Potentials/QC_QUIP_Wrapper.f95 deleted file mode 100644 index 99aa967ffe..0000000000 --- a/src/Potentials/QC_QUIP_Wrapper.f95 +++ /dev/null @@ -1,310 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield, -! H0 X Tamas K Stenczel -! H0 X -! H0 X Copyright 2006-2021. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X wrapper for quasicontinuum code to use QUIP potentials -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module QC_QUIP_Wrapper_module - use system_module, only : dp, system_initialise, INPUT, system_abort, & - verbosity_push, verbosity_pop, PRINT_SILENT, operator(//), inoutput, PRINT_ALWAYS - use extendable_str_module, only : extendable_str, string, read - use table_module, only : table, wipe, int_part - use atoms_types_module, only : atoms, assign_pointer, add_property - use atoms_module, only : initialise, calc_connect, set_lattice, assignment(=) - use potential_module, only : potential, initialise, finalise, calc - use mpi_context_module, only : mpi_context - implicit none - private - - type (Potential), save :: pot - type (Atoms), save :: at - type (MPI_context), save :: mpi_glob - - real(dp), private :: vacuum_dist = 5.0_dp - - public :: verbosity_push, verbosity_pop, PRINT_SILENT - public :: QC_QUIP_initialise, QC_QUIP_calc, MakeLine - type (Potential), save :: pot_ip -#if defined(HAVE_LOCAL_E_MIX) || defined(HAVE_ONIOM) - type (Potential), save :: pot_qm - public :: QC_QUIP_initialise_hybrid, QC_QUIP_calc_hybrid -#endif - -contains - - subroutine MakeLine(str1, real1, str2, real2, strout) - character(len = *), intent(in) :: str1, str2 - real(dp), intent(in) :: real1, real2 - character(len = *), intent(out) :: strout - - strout = trim(str1) // real1 // trim(str2) // real2 - end subroutine MakeLine - - subroutine QC_QUIP_initialise(str, err) - character(len = *), intent(in) :: str - integer, intent(out), optional :: err - - type(inoutput) :: params - type(extendable_str) :: params_str - - call system_initialise() - call Initialise(params, "quip_params.xml", INPUT) - call Initialise(params_str) - call read(params_str, params%unit) - - call Initialise(pot, args_str = str, param_str = string(params_str)) - if (present(err)) err = 0 - end subroutine - - subroutine QC_QUIP_calc(Lz, pos, Z, w, local_e, f, err) - real(dp), intent(in) :: Lz - real(dp), intent(in) :: pos(:, :) - integer, intent(in) :: Z(:) - real(dp), intent(in) :: w(:) - real(dp), intent(out) :: local_e(:), f(:, :) - integer, intent(out) :: err - - integer N - real(dp), pointer :: weight(:) - - if (.not. matching_array_sizes(Z, pos, w, local_e, f, N)) then - call system_abort("Mismatched array sizes in QC_QUIP_calc") - endif - - call qc_setup_atoms(at, N, Lz, pos, Z) - - if (.not. assign_pointer(at, "weight", weight)) then - call add_property(at, "weight", 0.0_dp) - if (.not. assign_pointer(at, "weight", weight)) & - call system_abort("QC_QUIP_calc Failed to add weight property to at") - weight = w - endif - - call add_property_from_pointer(at, "local_energy", local_e) - call add_property_from_pointer(at, "force", f) - call calc(pot, at, args_str = "local_energy force", error = err) - - end subroutine - -#if defined(HAVE_LOCAL_E_MIX) || defined(HAVE_ONIOM) - subroutine QC_QUIP_initialise_hybrid(str_ip, str_qm, str_hybrid, lat, Z, pos, err) - - ! moduel level imports - ! gcc10: these are needed to be discovered by the compiler to realise that there - ! in indeed no argument mismatch - use system_module, only : print - use potential_module, only : print - - character(len = *), intent(in) :: str_ip, str_qm, str_hybrid - real(dp), intent(in), optional :: lat(3, 3) - integer, intent(in), optional :: Z(:) - real(dp), intent(in), optional :: pos(:, :) - integer, intent(out), optional :: err - - type(inoutput) :: params - type(extendable_str) :: params_str - ! type(atoms) :: bulk - integer :: n_present - - call system_initialise(enable_timing = .true.) - - call initialise(mpi_glob) - - call initialise(params, "quip_params.xml", INPUT) - call initialise(params_str) - call read(params_str, params%unit, convert_to_string = .true., & - mpi_comm = mpi_glob%communicator, mpi_id = mpi_glob%my_proc) - - ! call initialise(pot_ip, str_ip, string(params_str)) - ! call initialise(pot_qm, str_qm, string(params_str), mpi_obj = mpi_glob) - - call finalise(params_str) - - n_present = count ((/present(lat), present(Z), present(pos) /)) - if (n_present == 3) then - if (.not. matching_array_sizes(Z, pos = pos)) then - call system_abort("Mismatched array sizes in QC_QUIP_initialise_hybrid") - endif - call print("QC_QUIP_initialise_hybrid was passed in bulk structure, & - &ignoring it", PRINT_ALWAYS) - ! call initialise(bulk, size(Z), lat) - ! bulk%Z = Z - ! bulk%pos = pos - ! call initialise(pot, str_hybrid, pot_qm, pot_ip, bulk) - ! call finalise(bulk) - call initialise(pot, str_hybrid // " init_args_pot2=" // trim(str_ip) & - // " init_args_pot1=" // trim(str_qm), mpi_obj = mpi_glob) - else if (n_present == 0) then - call initialise(pot, str_hybrid // " init_args_pot2=" // trim(str_ip) & - // " init_args_pot1=" // trim(str_qm), mpi_obj = mpi_glob) - else - call system_abort("QC_QUIP_initialise_hybrid called with some but not & - &all of lat, Z, pos present") - endif - - call print("QC_QUIP using hybrid potential:") - call print(pot) - - if (present(err)) err = 0 - end subroutine QC_QUIP_initialise_hybrid - - subroutine QC_QUIP_calc_hybrid(Lz, pos, Z, w, qm_list, local_e, f, & - qm_region_width, buffer_region_width, err) - real(dp), intent(in) :: Lz - real(dp), intent(in) :: pos(:, :) - integer, intent(in) :: Z(:) - real(dp), intent(in) :: w(:) - integer, intent(in) :: qm_list(:) - real(dp), intent(out) :: local_e(:), f(:, :) - integer, intent(in) :: qm_region_width, buffer_region_width - integer, intent(out) :: err - - integer i, N - real(dp), pointer :: weight(:) - integer, pointer :: hybrid(:) - type(table) :: qm_table - - if (.not. matching_array_sizes(Z, pos, w, local_e, f, N)) then - call system_abort("Mismatched array sizes in QC_QUIP_calc_hybrid") - endif - - if (buffer_region_width > 0 .and. pot%is_oniom) & - call system_abort("Don't do buffer_region_width = " // & - buffer_region_width // " > 0 with ONIOM") - - call qc_setup_atoms(at, N, Lz, pos, Z) - - call add_property(at, "weight", 0.0_dp) - call add_property(at, "hybrid", 0) - - if (.not. assign_pointer(at, "weight", weight)) & - call system_abort("QC_QUIP_calc Failed to add weight property to at") - if (.not. assign_pointer(at, "hybrid", hybrid)) & - call system_abort("QC_QUIP_calc Failed to add hybrid property to at") - - call calc_connect(at) - - hybrid = 0 - call wipe(qm_table) - do i = 1, size(qm_list) - if (qm_list(i) > at%N) call system_abort("QC_QUIP_calc_hybrid got qm_list(" // i // ")=" & - // qm_list(i) // " > at%N=" // at%N) - if (qm_list(i) > 0) call append(qm_table, (/ qm_list(i), 0, 0, 0 /)) - end do - - hybrid(int_part(qm_table, 1)) = 1 - - weight = w - - call add_property_from_pointer(at, "local_energy", local_e) - call add_property_from_pointer(at, "force", f) - - if (pot%is_oniom) then - call calc(pot, at, args_str = "local_energy force calc_weights" // & - " core_hops=" // qm_region_width // " transition_hops=0 buffer_hops=" // buffer_region_width, error = err) - else - call calc(pot, at, args_str = "local_energy force calc_weights" // & - " core_hops=" // qm_region_width // " transition_hops=0 buffer_hops=" // buffer_region_width // & - " solver=DIAG_GF SCF_GLOBAL_U GLOBAL_U=20.0", error = err) - endif - - end subroutine QC_QUIP_calc_hybrid -#endif - - function matching_array_sizes(Z, pos, w, local_e, f, N) - integer, intent(in) :: Z(:) - real(dp), intent(in), optional :: pos(:, :) - real(dp), intent(in), optional :: w(:) - real(dp), intent(in), optional :: local_e(:), f(:, :) - integer, intent(out), optional :: N - logical :: matching_array_sizes - - integer my_N - - matching_array_sizes = .true. - my_N = size(Z) - if (present(N)) N = my_N - if (present(pos)) then - if (3 /= size(pos, 1) .or. my_N /= size(pos, 2)) then - matching_array_sizes = .false. - return - endif - endif - if (present(w)) then - if (my_N /= size(w)) then - matching_array_sizes = .false. - return - endif - endif - if (present(local_e)) then - if (my_N /= size(local_e)) then - matching_array_sizes = .false. - return - endif - endif - if (present(f)) then - if (3 /= size(f, 1) .or. my_N /= size(f, 2)) then - matching_array_sizes = .false. - return - endif - endif - - end function matching_array_sizes - - subroutine qc_setup_atoms(at, N, Lz, pos, Z) - type(atoms), intent(inout) :: at - integer, intent(in) :: N - real(dp), intent(in) :: Lz - real(dp), intent(in) :: pos(:, :) - integer, intent(in) :: Z(:) - - real(dp) :: lattice(3, 3) - - lattice = 0.0_dp - lattice(1, 1) = maxval(pos(1, :)) - minval(pos(1, :)) + vacuum_dist - lattice(2, 2) = maxval(pos(2, :)) - minval(pos(2, :)) + vacuum_dist - lattice(3, 3) = Lz - - if (at%N /= N) then - call Initialise(at, N, lattice) - end if - call set_lattice(at, lattice, scale_positions = .false.) - at%pos = pos - at%Z = Z - - call calc_connect(at) - end subroutine qc_setup_atoms - -end module QC_QUIP_Wrapper_module diff --git a/src/Potentials/QUIP_Common.f95 b/src/Potentials/QUIP_Common.f95 deleted file mode 100644 index 18c8a2157c..0000000000 --- a/src/Potentials/QUIP_Common.f95 +++ /dev/null @@ -1,113 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X QUIP_Common_module -!X -!% The QUIP_Common module contains functions to get the atom type from -!% the atomic number or -!% a token from a string. -!% -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module QUIP_Common_module - -use FoX_sax, only: xml_t, dictionary_t, haskey, getvalue, open_xml_string, close_xml_t, parse -use System_module - -implicit none - -private - -public :: get_type -public :: xml_t, dictionary_t, open_xml_string, close_xml_t, parse -public :: QUIP_FoX_get_value - -public :: pauli_sigma -complex(dp), parameter :: pauli_sigma(2,2,3) = reshape( (/ & - cmplx(0.0_dp,0.0_dp,dp), cmplx(1.0_dp,0.0_dp,dp), cmplx(1.0_dp,0.0_dp,dp), cmplx(0.0_dp,0.0_dp,dp), & - cmplx(0.0_dp,0.0_dp,dp), cmplx(0.0_dp,1.0_dp,dp), -cmplx(0.0_dp,1.0_dp,dp), cmplx(0.0_dp,0.0_dp,dp), & - cmplx(1.0_dp,0.0_dp,dp), cmplx(0.0_dp,0.0_dp,dp), cmplx(0.0_dp,0.0_dp,dp), cmplx(-1.0_dp,0.0_dp,dp) /) , & - (/ 2, 2, 3 /) ) - - -contains - -!% Get the type from the atomic number, with error checking. -function get_type(type_of_atomic_num, Z, unknown_type) - integer, intent(in) :: type_of_atomic_num(:) - integer, intent(in) :: Z - logical, intent(out), optional :: unknown_type - - integer get_type - - if (Z < 1 .or. Z > size(type_of_atomic_num)) then - if(present(unknown_type)) then - unknown_type = .true. - get_type = -1 - return - else - call system_abort ('get_type: Atomic number '//Z //' out of range') - endif - endif - - if (type_of_atomic_num(Z) == 0) then - if(present(unknown_type)) then - unknown_type = .true. - get_type = -1 - return - else - call system_abort ('get_type: Atomic number '//Z//' does not correspond to a defined type') - endif - endif - - get_type = type_of_atomic_num(Z) - if(present(unknown_type)) unknown_type = .false. - -end function get_type - -subroutine QUIP_FoX_get_value(attributes, key, val, status) - type(dictionary_t), intent(in) :: attributes - character(len=*), intent(in) :: key - character(len=*), intent(inout) :: val - integer, intent(out), optional :: status - - if (HasKey(attributes,key)) then - val = GetValue(attributes, trim(key)) - if (present(status)) status = 0 - else - val = "" - if (present(status)) status = 1 - endif -end subroutine - -end module QUIP_Common_module diff --git a/src/Potentials/QUIP_module.f95 b/src/Potentials/QUIP_module.f95 deleted file mode 100644 index 5ba9e7ca52..0000000000 --- a/src/Potentials/QUIP_module.f95 +++ /dev/null @@ -1,74 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X QUIP Module -!X -!% This is a container module. ``use" it if you want to use QUIP stuff -!%> use QUIP_module -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module QUIP_internals_module - use functions_module - use quip_common_module - use ewald_module - use IPModel_lj_module - use IPModel_sw_module - use IPModel_tersoff_module -#ifdef HAVE_TB - use tb_mixing_module - use tb_common_module - use tbmodel_bowler_module - use tbmodel_dftb_module - use tbmodel_nrl_tb_module -#endif -end module QUIP_internals_module - -!% This is a container module. ``use" it if you want to use QUIP stuff -!%> use QUIP_module -module QUIP_module - use mpi_context_module - use scalapack_module - use matrix_module - use rs_sparsematrix_module -#ifdef HAVE_TB - use approxfermi_module - use tb_kpoints_module - use tbmodel_module - use tbmatrix_module - use tbsystem_module - use tb_greensfunctions_module - use tb_module -#endif - use ip_module - use potential_module -end module QUIP_module diff --git a/src/Potentials/RS_SparseMatrix.f95 b/src/Potentials/RS_SparseMatrix.f95 deleted file mode 100644 index 01020ecd8b..0000000000 --- a/src/Potentials/RS_SparseMatrix.f95 +++ /dev/null @@ -1,2146 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X RS_SparseMatrix module -!X -!% Module for sparce matrix math. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module RS_SparseMatrix_module - -use System_module -use MPI_Context_module -use linearalgebra_module -use Atoms_module -use ScaLAPACK_module -use Matrix_module -implicit none -private - -public :: RS_SparseMatrixL -type RS_SparseMatrixL - integer :: N = 0, N_dense_rows = 0 - integer :: n_blocks = 0, data_size = 0 - integer, allocatable :: block_size(:), dense_row_of_row(:) - integer, allocatable :: row_indices(:), data_ptrs(:) - integer, allocatable :: col(:) - - integer :: cur_row = 1, cur_col_offset = 0 -end type RS_SparseMatrixL - -public :: RS_SparseMatrixD -type RS_SparseMatrixD - type(RS_SparseMatrixL) :: l - real(dp), allocatable :: data(:) -end type RS_SParseMatrixD - -public :: RS_SparseMatrixZ -type RS_SparseMatrixZ - type(RS_SparseMatrixL) :: l - complex(dp), allocatable :: data(:) -end type RS_SParseMatrixZ - -public :: Initialise -interface Initialise - module procedure RS_SparseMatrixL_Initialise_at, RS_SparseMatrixL_Initialise_prod - module procedure RS_SparseMatrixD_Initialise_at, RS_SparseMatrixD_Initialise_prod - module procedure RS_SparseMatrixZ_Initialise_at, RS_SparseMatrixZ_Initialise_prod -end interface Initialise - - -public :: Finalise -interface Finalise - module procedure RS_SparseMatrixL_Finalise - module procedure RS_SparseMatrixD_Finalise - module procedure RS_SparseMatrixZ_Finalise -end interface Finalise - -public :: Wipe -interface Wipe - module procedure RS_SparseMatrixL_Wipe - module procedure RS_SparseMatrixD_Wipe - module procedure RS_SparseMatrixZ_Wipe -end interface Wipe - -public :: Zero -interface Zero - module procedure RS_SparseMatrixD_Zero - module procedure RS_SparseMatrixZ_Zero -end interface Zero - -public :: Print -interface Print - module procedure RS_SparseMatrixD_Print - module procedure RS_SparseMatrixZ_Print -end interface Print - -public :: Print_simple -interface Print_simple - module procedure RS_SparseMatrixD_Print_simple -! module procedure RS_SparseMatrixZ_Print -end interface Print_simple - -public :: copy -interface copy - module procedure copy_dd_dsp - module procedure copy_zd_zsp - module procedure copy_dsp_dd - module procedure copy_zsp_zd -end interface - -public :: matrix_product_sub -interface matrix_product_sub - module procedure matrix_product_sub_dsp_dsp_dsp, matrix_product_sub_dden_dden_dsp - module procedure matrix_product_sub_zsp_zsp_zsp - module procedure matrix_product_sub_dden_dden_zsp, matrix_product_sub_zden_dden_zsp, matrix_product_sub_zden_zden_zsp - module procedure matrix_product_sub_zden_zden_dsp -end interface matrix_product_sub - -public :: add_block -interface add_block - module procedure RS_SparseMatrixD_add_block - module procedure RS_SparseMatrixZ_add_block -end interface - -public :: partial_TraceMult -interface partial_TraceMult - module procedure RS_SparseMatrix_partial_TraceMult_dden_dsp - module procedure RS_SparseMatrix_partial_TraceMult_dden_zsp - module procedure RS_SparseMatrix_partial_TraceMult_zden_dsp - module procedure RS_SparseMatrix_partial_TraceMult_zden_zsp - module procedure RS_SparseMatrix_partial_TraceMult_dsp_zden - module procedure RS_SparseMatrix_partial_TraceMult_dsp_dden - module procedure RS_SparseMatrix_partial_TraceMult_zsp_zden -end interface partial_TraceMult - -public :: TraceMult -interface TraceMult - module procedure RS_SparseMatrix_TraceMult_dden_dsp - module procedure RS_SparseMatrix_TraceMult_dden_zsp - module procedure RS_SparseMatrix_TraceMult_zden_dsp - module procedure RS_SparseMatrix_TraceMult_zden_zsp - module procedure RS_SparseMatrix_TraceMult_dsp_zden - module procedure RS_SparseMatrix_TraceMult_dsp_dden - module procedure RS_SparseMatrix_TraceMult_zsp_zden -end interface TraceMult - -public :: multDiagRL -interface multDiagRL - module procedure RS_SparseMatrixD_multDiagRL_d, RS_SparseMatrixZ_multDiagRL_d -end interface multDiagRL - -public :: check_sparse -interface check_sparse - module procedure check_sparse_layout -end interface check_sparse - -interface get_dense_block - module procedure get_dense_blockD, get_dense_blockZ -end interface get_dense_block - -contains - -subroutine RS_SparseMatrixL_Initialise_at(this, at, first_orb_of_atom, cutoff, mpi_obj) - type(RS_SparseMatrixL), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: first_orb_of_atom(:) - real(dp), intent(in), optional :: cutoff - type(MPI_context), intent(in), optional :: mpi_obj - - integer :: i, ji, j - integer :: cur_data_pos, cur_row_offset - integer, allocatable :: neighbour_sorted(:) - real(dp), allocatable :: neighbour_distance_sorted(:) - integer :: n_uniq - - real(dp) :: my_cutoff - - if (present(mpi_obj)) then - call System_abort("No support for parallel sparse matrix") - end if - - my_cutoff = HUGE(1.0_dp) - if (present(cutoff)) my_cutoff = cutoff - - call Wipe(this) - - this%N = at%N - if (size(first_orb_of_atom) /= at%N+1) call system_abort("RS_SparseMatrixL_Initialise_at size(first_orb_of_atom) = " // size(first_orb_of_atom) // " != at%N+1 = " // (at%N+1)) - this%N_dense_rows = first_orb_of_atom(at%N+1)-1 - - allocate(this%block_size(at%N)) - call ALLOC_TRACE("RS_L_init block_size", size(this%block_size)*INTEGER_SIZE) - allocate(this%dense_row_of_row(at%N)) - call ALLOC_TRACE("RS_L_init dense_row_of_row", size(this%dense_row_of_row)*INTEGER_SIZE) - this%block_size(:) = first_orb_of_atom(2:at%N+1)-first_orb_of_atom(1:at%N) - this%dense_row_of_row(:) = first_orb_of_atom(1:at%N) - - allocate(this%row_indices(at%N+1)) - call ALLOC_TRACE("RS_L_init row_indices", size(this%row_indices)*INTEGER_SIZE) - - this%n_blocks = 0 - this%data_size = 0 - - this%row_indices = 0 - do i=1, at%N - - allocate(neighbour_sorted(n_neighbours(at, i))) - allocate(neighbour_distance_sorted(n_neighbours(at, i))) - do ji=1, n_neighbours(at, i) - neighbour_sorted(ji) = neighbour(at, i, ji, neighbour_distance_sorted(ji)) - end do - call sort_array(neighbour_sorted, r_data=neighbour_distance_sorted) - - n_uniq = uniq_minval(neighbour_sorted, neighbour_distance_sorted) - - if(n_uniq == 0) call system_abort("atoms with no neighbours, not even itself!?!?!?") - - do ji=1, n_uniq - j = neighbour_sorted(ji) - if (ji > 1) then - if (j == neighbour_sorted(ji-1)) cycle - end if - - ! insert data for regular element - if (neighbour_distance_sorted(ji) <= my_cutoff) then - this%row_indices(i+1) = this%row_indices(i+1) + 1 - this%n_blocks = this%n_blocks + 1 - this%data_size = this%data_size + this%block_size(i)*this%block_size(j) - end if - - end do - - deallocate(neighbour_sorted) - deallocate(neighbour_distance_sorted) - - end do - - this%row_indices(1) = 1 - do i=2, at%N+1 - this%row_indices(i) = this%row_indices(i) + this%row_indices(i-1) - end do - - if (this%n_blocks == 0) then - allocate(this%col(1)) - allocate(this%data_ptrs(1)) - else - allocate(this%col(this%n_blocks)) - allocate(this%data_ptrs(this%n_blocks)) - end if - call ALLOC_TRACE("RS_L_init col", size(this%col)*INTEGER_SIZE) - call ALLOC_TRACE("RS_L_init data_ptrs", size(this%data_ptrs)*INTEGER_SIZE) - - cur_data_pos = 1 - do i=1, at%N - - allocate(neighbour_sorted(n_neighbours(at, i))) - allocate(neighbour_distance_sorted(n_neighbours(at, i))) - do ji=1, n_neighbours(at, i) - neighbour_sorted(ji) = neighbour(at, i, ji, neighbour_distance_sorted(ji)) - end do - call sort_array(neighbour_sorted, r_data=neighbour_distance_sorted) - - n_uniq = uniq_minval(neighbour_sorted, neighbour_distance_sorted) - - if(n_uniq == 0) call system_abort("atoms with no neighbours, not even itself!?!?!?") - - cur_row_offset = 0 - - do ji=1, n_uniq - j = neighbour_sorted(ji) - if (ji > 1) then - if (j == neighbour_sorted(ji-1)) cycle - end if - - ! insert data for regular element - if (neighbour_distance_sorted(ji) <= my_cutoff) then - this%col(this%row_indices(i)+cur_row_offset) = j - this%data_ptrs(this%row_indices(i)+cur_row_offset) = cur_data_pos - cur_row_offset = cur_row_offset + 1 - cur_data_pos = cur_data_pos + this%block_size(i)*this%block_size(j) - end if - - end do - - deallocate(neighbour_sorted) - deallocate(neighbour_distance_sorted) - - end do -end subroutine RS_SparseMatrixL_Initialise_at - -function uniq_minval(i_data, r_data) - integer, intent(inout) :: i_data(:) - real(dp), intent(inout) :: r_data(:) - integer :: uniq_minval - - real(dp) :: min_r_data - integer :: data_len, i, ii, imin, imax - - data_len = size(i_data) - if (data_len == 0) then - uniq_minval=0 - return - end if - - ii = 1 - do i=1, data_len - if (i == 1) then - imin = i - cycle - end if - if (i_data(i) /= i_data(i-1)) then - imax = i-1 - min_r_data = minval(r_data(imin:imax)) - i_data(ii) = i_data(imin) - r_data(ii) = min_r_data - ii = ii + 1 - imin = i - end if - end do - min_r_data = minval(r_data(imin:data_len)) - i_data(ii) = i_data(imin) - r_data(ii) = min_r_data - - uniq_minval = ii -end function uniq_minval - -subroutine RS_SparseMatrixD_Initialise_at(this, at, first_orb_of_atom, cutoff, mpi_obj) - type(RS_SparseMatrixD), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: first_orb_of_atom(:) - real(dp), intent(in), optional :: cutoff - type(MPI_context), intent(in), optional :: mpi_obj - - call Wipe(this) - - call Initialise(this%l, at, first_orb_of_atom, cutoff, mpi_obj) - - allocate(this%data(this%l%data_size)) - call ALLOC_TRACE("RS_D_init data", size(this%data)*REAL_SIZE) -end subroutine RS_SparseMatrixD_Initialise_at - -subroutine RS_SparseMatrixZ_Initialise_at(this, at, first_orb_of_atom, cutoff, mpi_obj) - type(RS_SparseMatrixZ), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: first_orb_of_atom(:) - real(dp), intent(in), optional :: cutoff - type(MPI_context), intent(in), optional :: mpi_obj - - call Wipe(this) - - call Initialise(this%l, at, first_orb_of_atom, cutoff, mpi_obj) - - allocate(this%data(this%l%data_size)) - call ALLOC_TRACE("RS_Z_init data", size(this%data)*COMPLEX_SIZE) -end subroutine RS_SparseMatrixZ_Initialise_at - -subroutine RS_SparseMatrixL_Initialise_prod(this, al, bl, mpi_obj) - type(RS_SparseMatrixL), intent(inout) :: this - type(RS_SparseMatrixL), intent(in) :: al, bl - type(MPI_context), intent(in), optional :: mpi_obj - - integer is, kk, ks, jj, js - integer cur_entry, p, pd - logical, allocatable :: col_used(:) - integer, allocatable :: col_list(:) - - if (present(mpi_obj)) then - call System_abort("No support for mpi_obj in sparse matrix") - end if - - this%N = al%N - this%N_dense_rows = al%N_dense_rows - allocate(this%block_size(this%N)) - call ALLOC_TRACE("RS_L_init_product block_size", size(this%block_size)*INTEGER_SIZE) - allocate(this%dense_row_of_row(this%N)) - call ALLOC_TRACE("RS_L_init_product dense_row_of_row", size(this%dense_row_of_row)*INTEGER_SIZE) - this%block_size = al%block_size - this%dense_row_of_row = al%dense_row_of_row - - allocate(this%row_indices(this%N+1)) - call ALLOC_TRACE("RS_L_init_product row_indices", size(this%row_indices)*INTEGER_SIZE) - this%row_indices = 0 - this%n_blocks = 0 - this%data_size = 0 - - allocate(col_used(al%N)) - allocate(col_list(al%N)) - col_used = .false. - - do is=1, al%N - do kk=al%row_indices(is), al%row_indices(is+1)-1 - ks = al%col(kk) - cur_entry = 0 - do jj=bl%row_indices(ks), bl%row_indices(ks+1)-1 - js = bl%col(jj) - if (.not.col_used(js)) then - cur_entry = cur_entry + 1 - col_list(cur_entry) = js - col_used(js) = .true. - this%n_blocks = this%n_blocks + 1 - this%data_size = this%data_size + al%block_size(is)*bl%block_size(js) - end if - end do - end do - do jj=1, cur_entry - col_used(col_list(jj)) = .false. - end do - end do - - allocate(this%col(this%n_blocks)) - allocate(this%data_ptrs(this%n_blocks)) - call ALLOC_TRACE("RS_L_init_product col", size(this%col)*INTEGER_SIZE) - call ALLOC_TRACE("RS_L_init_product data_ptrs", size(this%data_ptrs)*INTEGER_SIZE) - - p = 1 - pd = 1 - do is=1, al%N - this%row_indices(is) = p - do kk=al%row_indices(is), al%row_indices(is+1)-1 - ks = al%col(kk) - cur_entry = 0 - do jj=bl%row_indices(ks), bl%row_indices(ks+1)-1 - js = bl%col(jj) - if (.not.col_used(js)) then - cur_entry = cur_entry + 1 - col_list(cur_entry) = js - col_used(js) = .true. - - this%col(p) = js - this%data_ptrs(p) = pd - p = p + 1 - pd = pd + al%block_size(is)*bl%block_size(js) - end if - end do - end do - do jj=1, cur_entry - col_used(col_list(jj)) = .false. - end do - end do - this%row_indices(al%N+1) = p - - deallocate(col_used) - deallocate(col_list) -end subroutine RS_SparseMatrixL_Initialise_prod - -subroutine RS_SparseMatrixD_Initialise_prod(this, al, bl, mpi_obj) - type(RS_SparseMatrixD), intent(inout) :: this - type(RS_SparseMatrixL), intent(in) :: al, bl - type(MPI_context), intent(in), optional :: mpi_obj - - call Wipe(this) - - call Initialise(this%l, al, bl) - - allocate(this%data(this%l%data_size)) - call ALLOC_TRACE("RS_D_init_product data", size(this%data)*REAL_SIZE) - -end subroutine RS_SparseMatrixD_Initialise_prod - -subroutine RS_SparseMatrixZ_Initialise_prod(this, al, bl, mpi_obj) - type(RS_SparseMatrixZ), intent(inout) :: this - type(RS_SparseMatrixL), intent(in) :: al, bl - type(MPI_context), intent(in), optional :: mpi_obj - - call Wipe(this) - - call Initialise(this%l, al, bl) - - allocate(this%data(this%l%data_size)) - call ALLOC_TRACE("RS_Z_init_product data", size(this%data)*COMPLEX_SIZE) - -end subroutine RS_SparseMatrixZ_Initialise_prod - -subroutine RS_SparseMatrixL_Finalise(this) - type(RS_SparseMatrixL), intent(inout) :: this - - call Wipe(this) -end subroutine RS_SparseMatrixL_Finalise - -subroutine RS_SparseMatrixD_Finalise(this) - type(RS_SparseMatrixD), intent(inout) :: this - - call Wipe(this) -end subroutine RS_SparseMatrixD_Finalise - -subroutine RS_SparseMatrixZ_Finalise(this) - type(RS_SparseMatrixZ), intent(inout) :: this - - call Wipe(this) -end subroutine RS_SparseMatrixZ_Finalise - -subroutine RS_SparseMatrixL_Wipe(this) - type(RS_SparseMatrixL), intent(inout) :: this - - call DEALLOC_TRACE("RS_L_wipe block_size", size(this%block_size)*INTEGER_SIZE) - if (allocated(this%block_size)) deallocate(this%block_size) - call DEALLOC_TRACE("RS_L_wipe dense_row_of_row", size(this%dense_row_of_row)*INTEGER_SIZE) - if (allocated(this%dense_row_of_row)) deallocate(this%dense_row_of_row) - call DEALLOC_TRACE("RS_L_wipe row_indices", size(this%row_indices)*INTEGER_SIZE) - if (allocated(this%row_indices)) deallocate(this%row_indices) - call DEALLOC_TRACE("RS_L_wipe data_ptrs", size(this%data_ptrs)*INTEGER_SIZE) - if (allocated(this%data_ptrs)) deallocate(this%data_ptrs) - call DEALLOC_TRACE("RS_L_wipe col", size(this%col)*INTEGER_SIZE) - if (allocated(this%col)) deallocate(this%col) - - this%N = 0 - this%N_dense_rows = 0 - this%n_blocks = 0 - this%data_size = 0 -end subroutine RS_SparseMatrixL_Wipe - -subroutine RS_SparseMatrixD_Wipe(this) - type(RS_SparseMatrixD), intent(inout) :: this - - call Wipe(this%l) - call DEALLOC_TRACE("RS_D_wipe data", size(this%data)*REAL_SIZE) - if (allocated(this%data)) deallocate(this%data) - -end subroutine RS_SparseMatrixD_Wipe - -subroutine RS_SparseMatrixZ_Wipe(this) - type(RS_SparseMatrixZ), intent(inout) :: this - - call Wipe(this%l) - call DEALLOC_TRACE("RS_Z_wipe data", size(this%data)*COMPLEX_SIZE) - if (allocated(this%data)) deallocate(this%data) - -end subroutine RS_SparseMatrixZ_Wipe - -subroutine RS_SparseMatrixD_Zero(this, d_mask, od_mask) - type(RS_SparseMatrixD), intent(inout) :: this - logical, intent(in), optional :: d_mask(:), od_mask(:) - - integer i, ji, j, block_nr, block_nc - - if (present(d_mask) .or. present(od_mask)) then - do i=1, this%l%N - block_nr = this%l%block_size(i) - do ji=this%l%row_indices(i), this%l%row_indices(i+1)-1 - j = this%l%col(ji) - block_nc = this%l%block_size(j) - if (present(d_mask) .and. i == j) then - if (d_mask(i)) this%data(this%l%data_ptrs(ji):this%l%data_ptrs(ji)+block_nr*block_nc-1) = 0.0_dp - end if - if (present(od_mask) .and. i /= j) then - if (od_mask(i) .or. od_mask(j)) this%data(this%l%data_ptrs(ji):this%l%data_ptrs(ji)+block_nr*block_nc-1) = 0.0_dp - end if - end do - end do - else - this%data = 0.0_dp - end if - -end subroutine RS_SparseMatrixD_Zero - -subroutine RS_SparseMatrixZ_Zero(this, d_mask, od_mask) - type(RS_SparseMatrixZ), intent(inout) :: this - logical, intent(in), optional :: d_mask(:), od_mask(:) - - integer i, ji, j, block_nr, block_nc - - if (present(d_mask) .or. present(od_mask)) then - do i=1, this%l%N - block_nr = this%l%block_size(i) - do ji=this%l%row_indices(i), this%l%row_indices(i+1)-1 - j = this%l%col(ji) - block_nc = this%l%block_size(j) - if (present(d_mask) .and. i == j) then - if (d_mask(i)) this%data(this%l%data_ptrs(ji):this%l%data_ptrs(ji)+block_nr*block_nc-1) = 0.0_dp - end if - if (present(od_mask) .and. i /= j) then - if (od_mask(i) .or. od_mask(j)) this%data(this%l%data_ptrs(ji):this%l%data_ptrs(ji)+block_nr*block_nc-1) = 0.0_dp - end if - end do - end do - else - this%data = 0.0_dp - end if - -end subroutine RS_SparseMatrixZ_Zero - -subroutine RS_SparseMatrixD_Print(this,file) - type(RS_SparseMatrixD), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer :: i, j - integer :: block_nr, block_nc - - call Print ('RS_SparseMatrixD : N ' // this%l%N, file=file) - - call Print ('RS_SparseMatrixD : n_blocks data_size ' // this%l%n_blocks // " " // this%l%data_size, file=file) - - do i=1, this%l%N - call Print ('RS_SparseMatrixD : row, block_size dense_row ' // i // " " // this%l%block_size(i) // " " // & - this%l%dense_row_of_row(i), file=file) - do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 - call Print ("RS_SparseMatrixD entry j "// j // " col " // this%l%col(j) // " data_ptr " // this%l%data_ptrs(j), & - file=file) - block_nr = this%l%block_size(i) - block_nc = this%l%block_size(this%l%col(j)) - call Print(reshape( & - this%data(this%l%data_ptrs(j):this%l%data_ptrs(j)+block_nr*block_nc-1),(/block_nr,block_nc/) ), & - file=file) - end do - end do - -end subroutine RS_SparseMatrixD_Print - -subroutine RS_SparseMatrixZ_Print(this,file) - type(RS_SparseMatrixZ), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer :: i, j - integer :: block_nr, block_nc - - call Print('RS_SparseMatrixZ : ', file=file) - - call Print ('RS_SparseMatrixZ : N ' // this%l%N, file=file) - - call Print ('RS_SparseMatrixZ : n_blocks data_size ' // this%l%n_blocks // this%l%data_size, file=file) - - do i=1, this%l%N - call Print ('RS_SparseMatrixZ : row, block_size dense_row ' // i // " " // this%l%block_size(i) // " " // & - this%l%dense_row_of_row(i), file=file) - do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 - call Print ("RS_SparseMatrixZ entry j " // j // " col " // this%l%col(j) // " data_ptr " // this%l%data_ptrs(j), file=file) - block_nr = this%l%block_size(i) - block_nc = this%l%block_size(this%l%col(j)) - call Print(reshape( & - this%data(this%l%data_ptrs(j):this%l%data_ptrs(j)+block_nr*block_nc-1),(/block_nr,block_nc/) ), file=file) - end do - end do - -end subroutine RS_SparseMatrixZ_Print - -subroutine RS_SparseMatrixD_Print_simple(this,file) - type(RS_SparseMatrixD), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer :: i, tj, j, ii, jj - integer :: block_nr, block_nc - integer :: n_entries - - n_entries = 0 - do i=1, this%l%N - block_nr = this%l%block_size(i) - do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 - block_nc = this%l%block_size(this%l%col(j)) - n_entries = n_entries + block_nr*block_nc - end do - end do - - call print(this%l%N // " " // n_entries, file=file) - - do i=1, this%l%N - block_nr = this%l%block_size(i) - do tj=this%l%row_indices(i), this%l%row_indices(i+1)-1 - j = this%l%col(tj) - do ii=1, block_nr - do jj=1, block_nc - call print((this%l%dense_row_of_row(i)+ii-1) // " " // (this%l%dense_row_of_row(j)+jj-1) // " " // & - this%data(this%l%data_ptrs(tj)+ii-1+(jj-1)*block_nr), file=file) - end do - end do - end do - end do -end subroutine RS_SparseMatrixD_Print_simple - -subroutine copy_dsp_dd(this, dense) - type(RS_SparseMatrixD), intent(in) :: this - real(dp), intent(inout), dimension(:,:) :: dense - - integer :: i, tj, j, ii, jj - integer :: block_nr, block_nc - integer :: n_entries - - !if (any(shape(dense) /= (/this%l%N, this%l%N/))) call system_abort("size of dense matrix wrong: expecting "//this%l%N) - - n_entries = 0 - do i=1, this%l%N - block_nr = this%l%block_size(i) - do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 - block_nc = this%l%block_size(this%l%col(j)) - n_entries = n_entries + block_nr*block_nc - end do - end do - - do i=1, this%l%N - block_nr = this%l%block_size(i) - do tj=this%l%row_indices(i), this%l%row_indices(i+1)-1 - j = this%l%col(tj) - do ii=1, block_nr - do jj=1, block_nc - dense(this%l%dense_row_of_row(i)+ii-1, & - this%l%dense_row_of_row(j)+jj-1) = & - this%data(this%l%data_ptrs(tj)+ii-1+(jj-1)*block_nr) - end do - end do - end do - end do -end subroutine copy_dsp_dd - -subroutine copy_zsp_zd(this, dense) - type(RS_SparseMatrixZ), intent(in) :: this - complex(dp), intent(inout), dimension(:,:) :: dense - - integer :: i, tj, j, ii, jj - integer :: block_nr, block_nc - integer :: n_entries - - if (any(shape(dense) /= (/this%l%N, this%l%N/))) call system_abort("size of dense matrix wrong: expecting "//this%l%N) - - n_entries = 0 - do i=1, this%l%N - block_nr = this%l%block_size(i) - do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 - block_nc = this%l%block_size(this%l%col(j)) - n_entries = n_entries + block_nr*block_nc - end do - end do - - do i=1, this%l%N - block_nr = this%l%block_size(i) - do tj=this%l%row_indices(i), this%l%row_indices(i+1)-1 - j = this%l%col(tj) - do ii=1, block_nr - do jj=1, block_nc - dense(this%l%dense_row_of_row(i)+ii-1, & - this%l%dense_row_of_row(j)+jj-1) = & - this%data(this%l%data_ptrs(tj)+ii-1+(jj-1)*block_nr) - end do - end do - end do - end do -end subroutine copy_zsp_zd - -subroutine copy_dd_dsp(a, b, d_mask, od_mask) - type(MatrixD), intent(inout) :: a - type(RS_SparseMatrixD), intent(in) :: b - logical, optional :: d_mask(:), od_mask(:) - - integer is, jj, js, id, jd - - a%data = 0.0_dp - do is=1, b%l%N - id = b%l%dense_row_of_row(is) - do jj=b%l%row_indices(is), b%l%row_indices(is+1)-1 - js = b%l%col(jj) - if (present(d_mask)) then - if ((is == js) .and. .not. d_mask(is)) cycle - endif - if (present(od_mask)) then - if ((is /= js) .and. .not. od_mask(is) .and. .not. od_mask(js)) cycle - endif - jd = b%l%dense_row_of_row(js) - a%data(id:id+b%l%block_size(is)-1,jd:jd+b%l%block_size(js)-1) = & - reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+b%l%block_size(is)*b%l%block_size(js)-1), & - (/b%l%block_size(is), b%l%block_size(js)/) ) - end do - end do -end subroutine copy_dd_dsp - -subroutine copy_zd_zsp(a, b, d_mask, od_mask) - type(MatrixZ), intent(inout) :: a - type(RS_SparseMatrixZ), intent(in) :: b - logical, optional :: d_mask(:), od_mask(:) - - integer is, jj, js, id, jd - - a%data = 0.0_dp - do is=1, b%l%N - id = b%l%dense_row_of_row(is) - do jj=b%l%row_indices(is), b%l%row_indices(is+1)-1 - js = b%l%col(jj) - if (present(d_mask)) then - if ((is == js) .and. .not. d_mask(is)) cycle - endif - if (present(od_mask)) then - if ((is /= js) .and. .not. od_mask(is) .and. .not. od_mask(js)) cycle - endif - jd = b%l%dense_row_of_row(js) - a%data(id:id+b%l%block_size(is)-1,jd:jd+b%l%block_size(js)-1) = & - reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+b%l%block_size(is)*b%l%block_size(js)-1), & - (/b%l%block_size(is), b%l%block_size(js)/) ) - end do - end do -end subroutine copy_zd_zsp - -subroutine matrix_product_sub_dsp_dsp_dsp(c,a,b, a_transpose, b_transpose) - type(RS_SparseMatrixD), intent(inout) :: c - type(RS_SparseMatrixD), intent(in) :: a - type(RS_SparseMatrixD), intent(in) :: b - logical, intent(in), optional :: a_transpose, b_transpose - - integer is, kk, ks, jj_b, jj_c - integer block_ni, block_nj, block_nk - integer max_block_size - real(dp), allocatable :: a_block(:,:) - - c%data = 0.0_dp - - if (present(a_transpose)) then - if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(b_transpose)) then - if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - - max_block_size = maxval(a%l%block_size) - allocate(a_block(max_block_size,max_block_size)) - - do is=1, a%l%N - block_ni = a%l%block_size(is) - do kk=a%l%row_indices(is), a%l%row_indices(is+1)-1 - ks = a%l%col(kk) - block_nk = a%l%block_size(ks) - a_block(1:block_ni,1:block_nk) = reshape(a%data(a%l%data_ptrs(kk):a%l%data_ptrs(kk)+block_ni*block_nk-1), & - (/block_ni,block_nk/)) - - jj_c = c%l%row_indices(is) - jj_b = b%l%row_indices(ks) - do while (jj_c < c%l%row_indices(is+1) .and. jj_b < b%l%row_indices(ks+1)) - if (b%l%col(jj_b) == c%l%col(jj_c)) then - block_nj = b%l%block_size(b%l%col(jj_b)) - c%data(c%l%data_ptrs(jj_c):c%l%data_ptrs(jj_c)+block_ni*block_nj-1) = & - c%data(c%l%data_ptrs(jj_c):c%l%data_ptrs(jj_c)+block_ni*block_nj-1) + reshape( & - matmul( a_block(1:block_ni,1:block_nk), & - reshape(b%data(b%l%data_ptrs(jj_b):b%l%data_ptrs(jj_b)+block_nk*block_nj-1), & - (/block_nk,block_nj/)) ), & - (/block_ni*block_nj/) ) - jj_b = jj_b + 1 - jj_c = jj_c + 1 - else if (b%l%col(jj_b) < c%l%col(jj_c)) then - jj_b = jj_b + 1 - else - jj_c = jj_c + 1 - end if - end do - - end do - end do - - deallocate(a_block) - -end subroutine matrix_product_sub_dsp_dsp_dsp - -subroutine matrix_product_sub_zsp_zsp_zsp(c,a,b, a_transpose, a_conjugate, b_transpose, b_conjugate) - type(RS_SparseMatrixZ), intent(inout) :: c - type(RS_SparseMatrixZ), intent(in) :: a - type(RS_SparseMatrixZ), intent(in) :: b - logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose, b_conjugate - - integer is, kk, ks, jj_b, jj_c - integer block_ni, block_nj, block_nk - integer max_block_size - complex(dp), allocatable :: a_block(:,:) - - c%data = 0.0_dp - - if (present(a_transpose)) then - if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(b_transpose)) then - if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(a_conjugate)) then - if (a_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") - end if - if (present(b_conjugate)) then - if (b_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") - end if - - max_block_size = maxval(a%l%block_size) - allocate(a_block(max_block_size,max_block_size)) - - do is=1, a%l%N - block_ni = a%l%block_size(is) - do kk=a%l%row_indices(is), a%l%row_indices(is+1)-1 - ks = a%l%col(kk) - block_nk = a%l%block_size(ks) - a_block(1:block_ni,1:block_nk) = reshape(a%data(a%l%data_ptrs(kk):a%l%data_ptrs(kk)+block_ni*block_nk-1), & - (/block_ni,block_nk/)) - - jj_c = c%l%row_indices(is) - jj_b = b%l%row_indices(ks) - do while (jj_c < c%l%row_indices(is+1) .and. jj_b < b%l%row_indices(ks+1)) - if (b%l%col(jj_b) == c%l%col(jj_c)) then - block_nj = b%l%block_size(b%l%col(jj_b)) - c%data(c%l%data_ptrs(jj_c):c%l%data_ptrs(jj_c)+block_ni*block_nj-1) = & - c%data(c%l%data_ptrs(jj_c):c%l%data_ptrs(jj_c)+block_ni*block_nj-1) + reshape( & - matmul( a_block(1:block_ni,1:block_nk), & - reshape(b%data(b%l%data_ptrs(jj_b):b%l%data_ptrs(jj_b)+block_nk*block_nj-1), & - (/block_nk,block_nj/)) ), & - (/block_ni*block_nj/) ) - jj_b = jj_b + 1 - jj_c = jj_c + 1 - else if (b%l%col(jj_b) < c%l%col(jj_c)) then - jj_b = jj_b + 1 - else - jj_c = jj_c + 1 - end if - end do - - end do - end do - - deallocate(a_block) - -end subroutine matrix_product_sub_zsp_zsp_zsp - -subroutine matrix_product_sub_dden_dden_dsp(c,a,b,a_transpose, b_transpose, diag_mask, offdiag_mask) - type(MatrixD), intent(inout) :: c - type(MatrixD), intent(in) :: a - type(RS_SparseMatrixD), intent(in) :: b - logical, intent(in), optional :: a_transpose, b_transpose - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - - integer id, is, kd, ks, jj, jd, js - integer block_ni, block_nj, block_nk - - c%data = 0.0_dp - - if (present(a_transpose)) then - if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(b_transpose)) then - if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - - id = 1 - is = 1 - do while (id <= a%N) - block_ni = b%l%block_size(is) - kd = 1 - ks = 1 - do while (kd <= a%M) - block_nk = b%l%block_size(ks) - do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 - js = b%l%col(jj) - jd = b%l%dense_row_of_row(js) - block_nj = b%l%block_size(js) - - if (present(diag_mask)) then - if (js == ks .and. .not. diag_mask(ks)) cycle - end if - if (present(offdiag_mask)) then - if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle - end if - - c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & - c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & - matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & - reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1), & - (/block_nk,block_nj/)) ) - end do - kd = kd + b%l%block_size(ks) - ks = ks + 1 - end do - id = id + b%l%block_size(is) - is = is + 1 - end do -end subroutine - -subroutine matrix_product_sub_dden_dden_zsp(c,a,b,a_transpose, b_transpose, diag_mask, offdiag_mask) - type(MatrixD), intent(inout) :: c - type(MatrixD), intent(in) :: a - type(RS_SparseMatrixZ), intent(in) :: b - logical, intent(in), optional :: a_transpose, b_transpose - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - - integer id, is, kd, ks, jj, jd, js - integer block_ni, block_nj, block_nk - - c%data = 0.0_dp - - if (present(a_transpose)) then - if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(b_transpose)) then - if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - - id = 1 - is = 1 - do while (id <= a%N) - block_ni = b%l%block_size(is) - kd = 1 - ks = 1 - do while (kd <= a%M) - block_nk = b%l%block_size(ks) - do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 - js = b%l%col(jj) - jd = b%l%dense_row_of_row(js) - block_nj = b%l%block_size(js) - - if (present(diag_mask)) then - if (js == ks .and. .not. diag_mask(ks)) cycle - end if - if (present(offdiag_mask)) then - if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle - end if - - c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & - c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & - matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & - reshape(real(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1)), & - (/block_nk,block_nj/)) ) - end do - kd = kd + b%l%block_size(ks) - ks = ks + 1 - end do - id = id + b%l%block_size(is) - is = is + 1 - end do -end subroutine - -subroutine matrix_product_sub_zden_dden_zsp(c,a,b,a_transpose, b_transpose, b_conjugate, diag_mask, offdiag_mask) - type(MatrixZ), intent(inout) :: c - type(MatrixD), intent(in) :: a - type(RS_SparseMatrixZ), intent(in) :: b - logical, intent(in), optional :: a_transpose, b_transpose, b_conjugate - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - - integer id, is, kd, ks, jj, jd, js - integer block_ni, block_nj, block_nk - - c%data = 0.0_dp - - if (present(a_transpose)) then - if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(b_transpose)) then - if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(b_conjugate)) then - if (b_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") - end if - - id = 1 - is = 1 - do while (id <= a%N) - block_ni = b%l%block_size(is) - kd = 1 - ks = 1 - do while (kd <= a%M) - block_nk = b%l%block_size(ks) - do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 - js = b%l%col(jj) - jd = b%l%dense_row_of_row(js) - block_nj = b%l%block_size(js) - - if (present(diag_mask)) then - if (js == ks .and. .not. diag_mask(ks)) cycle - end if - if (present(offdiag_mask)) then - if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle - end if - - c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & - c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & - matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & - reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1), & - (/block_nk,block_nj/)) ) - end do - kd = kd + b%l%block_size(ks) - ks = ks + 1 - end do - id = id + b%l%block_size(is) - is = is + 1 - end do -end subroutine - -subroutine matrix_product_sub_zden_zden_zsp(c,a,b,a_transpose, a_conjugate, b_transpose, b_conjugate, diag_mask, offdiag_mask) - type(MatrixZ), intent(inout) :: c - type(MatrixZ), intent(in) :: a - type(RS_SparseMatrixZ), intent(in) :: b - logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose, b_conjugate - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - - integer id, is, kd, ks, jj, jd, js - integer block_ni, block_nj, block_nk - - c%data = 0.0_dp - - if (present(a_transpose)) then - if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(b_transpose)) then - if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") - end if - if (present(a_conjugate)) then - if (a_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") - end if - if (present(b_conjugate)) then - if (b_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") - end if - - id = 1 - is = 1 - do while (id <= a%N) - block_ni = b%l%block_size(is) - kd = 1 - ks = 1 - do while (kd <= a%M) - block_nk = b%l%block_size(ks) - do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 - js = b%l%col(jj) - jd = b%l%dense_row_of_row(js) - block_nj = b%l%block_size(js) - - if (present(diag_mask)) then - if (js == ks .and. .not. diag_mask(ks)) cycle - end if - if (present(offdiag_mask)) then - if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle - end if - - c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & - c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & - matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & - reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1), & - (/block_nk,block_nj/)) ) - end do - kd = kd + b%l%block_size(ks) - ks = ks + 1 - end do - id = id + b%l%block_size(is) - is = is + 1 - end do -end subroutine - -subroutine matrix_product_sub_zden_zden_dsp(c,a,b,a_transpose, a_conjugate, b_transpose, diag_mask, offdiag_mask) - type(MatrixZ), intent(inout) :: c - type(MatrixZ), intent(in) :: a - type(RS_SparseMatrixD), intent(in) :: b - logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - - integer id, is, kd, ks, jj, jd, js - integer block_ni, block_nj, block_nk - - if (present(a_transpose)) then - if (a_transpose) call system_abort("Can't do dense = dense * sparse with transposed matrices") - end if - if (present(b_transpose)) then - if (b_transpose) call system_abort("Can't do dense = dense * sparse with transposed matrices") - end if - if (present(a_conjugate)) then - if (a_conjugate) call system_abort("Can't do dense = dense * sparse with conjugate matrices") - end if - - c%data = 0.0_dp - - id = 1 - is = 1 - do while (id <= a%N) - block_ni = b%l%block_size(is) - kd = 1 - ks = 1 - do while (kd <= a%M) - block_nk = b%l%block_size(ks) - do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 - js = b%l%col(jj) - jd = b%l%dense_row_of_row(js) - block_nj = b%l%block_size(js) - - if (present(diag_mask)) then - if (js == ks .and. .not. diag_mask(ks)) cycle - end if - if (present(offdiag_mask)) then - if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle - end if - - c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & - c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & - matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & - reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1), & - (/block_nk,block_nj/)) ) - end do - kd = kd + b%l%block_size(ks) - ks = ks + 1 - end do - id = id + b%l%block_size(is) - is = is + 1 - end do -end subroutine - -subroutine RS_SparseMatrixD_add_block(this, block, block_nr, block_nc, at_row, at_col) - type(RS_SparseMatrixD), intent(inout) :: this - real(dp), intent(in) :: block(:,:) - integer, intent(in) :: block_nr, block_nc - integer, intent(in), optional :: at_row, at_col - - integer n_cols - integer cur_col, col_offset - - if (.not. present(at_row) .or. .not. present(at_col)) then - call System_abort("need at_row and at_col for add_block to RS_SparseMatrixD") - end if - - if (at_row > this%l%N .or. at_col > this%l%N) then - call system_abort("RS_SparseMatrixD_add_block tried to add block outside of matrix bounds "//at_row//","//at_col//" "//this%l%N) - end if - - if (this%l%cur_row /= at_row) then - this%l%cur_row = at_row - this%l%cur_col_offset = 0 - end if - - cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+this%l%cur_col_offset) - if (cur_col == at_col) then - call add_block_d(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) - return - else if (cur_col > at_col) then - do col_offset = this%l%cur_col_offset-1, 0, -1 - cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+col_offset) - if (cur_col == at_col) then - this%l%cur_col_offset = col_offset - call add_block_d(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) - return - end if - end do - else - n_cols = this%l%row_indices(this%l%cur_row+1)-this%l%row_indices(this%l%cur_row) - do col_offset = this%l%cur_col_offset+1, n_cols-1 - cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+col_offset) - if (cur_col == at_col) then - this%l%cur_col_offset = col_offset - call add_block_d(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) - return - end if - end do - end if - -end subroutine RS_SparseMatrixD_add_block - -subroutine RS_SparseMatrixZ_add_block(this, block, block_nr, block_nc, at_row, at_col) - type(RS_SparseMatrixZ), intent(inout) :: this - complex(dp), intent(in) :: block(:,:) - integer, intent(in) :: block_nr, block_nc - integer, intent(in) :: at_row, at_col - - integer n_cols - integer cur_col, col_offset - - if (at_row > this%l%N .or. at_col > this%l%N) then - call system_abort("RS_SparseMatrixZ_add_block_tried to add block outside of matrix bounds "//at_row//","//at_col//" "//this%l%N) - end if - - if (this%l%cur_row /= at_row) then - this%l%cur_row = at_row - this%l%cur_col_offset = 0 - end if - - cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+this%l%cur_col_offset) - if (cur_col == at_col) then - call add_block_z(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) - return - else if (cur_col > at_col) then - do col_offset = this%l%cur_col_offset-1, 0, -1 - cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+col_offset) - if (cur_col == at_col) then - this%l%cur_col_offset = col_offset - call add_block_z(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) - return - end if - end do - else - n_cols = this%l%row_indices(this%l%cur_row+1)-this%l%row_indices(this%l%cur_row) - do col_offset = this%l%cur_col_offset+1, n_cols-1 - cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+col_offset) - if (cur_col == at_col) then - this%l%cur_col_offset = col_offset - call add_block_z(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) - return - end if - end do - end if - -end subroutine RS_SparseMatrixZ_add_block - -subroutine add_block_d(this, cur_row, cur_col_offset, in_nr, in_nc, block) - type(RS_SparseMatrixD), intent(inout) :: this - integer, intent(in) :: cur_row, cur_col_offset - integer, intent(in) :: in_nr, in_nc - real(dp), intent(in) :: block(:,:) - - integer ptr_i, this_nr, this_nc - - ptr_i = this%l%row_indices(cur_row)+cur_col_offset - this_nr = this%l%block_size(cur_row) - this_nc = this%l%block_size(this%l%col(ptr_i)) - if (in_nr /= this_nr .or. in_nc /= this_nc) then - call System_abort("add_block_d tried to add block of wrong shape in_nr,nc "//in_nr// " "//in_nc//" sp_nr,nc "//this_nr//" "//this_nc) - end if - this%data(this%l%data_ptrs(ptr_i):this%l%data_ptrs(ptr_i)+this_nr*this_nc-1) = & - this%data(this%l%data_ptrs(ptr_i):this%l%data_ptrs(ptr_i)+this_nr*this_nc-1) + & - reshape( block(1:in_nr,1:in_nc), (/this_nr*this_nc/) ) -end subroutine add_block_d - -subroutine add_block_z(this, cur_row, cur_col_offset, in_nr, in_nc, block) - type(RS_SparseMatrixZ), intent(inout) :: this - integer, intent(in) :: cur_row, cur_col_offset - integer, intent(in) :: in_nr, in_nc - complex(dp), intent(in) :: block(:,:) - - integer ptr_i, this_nr, this_nc - - ptr_i = this%l%row_indices(cur_row)+cur_col_offset - this_nr = this%l%block_size(cur_row) - this_nc = this%l%block_size(this%l%col(ptr_i)) - if (in_nr /= this_nr .or. in_nc /= this_nc) then - call System_abort("add_block_z tried to add block of wrong shape in_nr,nc "//in_nr// " "//in_nc//" sp_nr,nc "//this_nr//" "//this_nc) - end if - this%data(this%l%data_ptrs(ptr_i):this%l%data_ptrs(ptr_i)+this_nr*this_nc-1) = & - this%data(this%l%data_ptrs(ptr_i):this%l%data_ptrs(ptr_i)+this_nr*this_nc-1) + & - reshape( block(1:in_nr,1:in_nc), (/this_nr*this_nc/) ) -end subroutine add_block_z - -function RS_SparseMatrix_partial_TraceMult_dden_dsp(a, b, a_T, b_T, diag_mask, offdiag_mask) result(v) - type(MatrixD), intent(in) :: a - type(RS_SparseMatrixD), intent(in) :: b - logical, intent(in), optional :: a_T, b_T - logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) - complex(dp) :: v(a%N) - - logical u_a_T, u_b_T - integer i, ji, j, tt - integer block_ni, block_nj, max_block_size - real(dp), allocatable :: a_block(:,:), b_block(:,:) - logical, pointer :: d_mask(:), od_mask(:) - logical use_a_ij_transpose - logical have_any - - max_block_size = maxval(b%l%block_size) - allocate(a_block(max_block_size,max_block_size)) - allocate(b_block(max_block_size,max_block_size)) - if (present(diag_mask)) then - d_mask => diag_mask - else - allocate(d_mask(b%l%N)) - d_mask = .true. - end if - if (present(offdiag_mask)) then - od_mask => offdiag_mask - else - allocate(od_mask(b%l%N)) - od_mask = .true. - end if - - u_a_T = optional_default(.false., a_T) - u_b_T = optional_default(.false., b_T) - - use_a_ij_transpose = .false. - if ((u_a_T .and. u_b_T) .or. (.not. u_a_T .and. .not. u_b_T)) use_a_ij_transpose = .true. - - v = 0.0_dp - do i=1, b%l%N - block_ni = b%l%block_size(i) - do ji=b%l%row_indices(i), b%l%row_indices(i+1)-1 - j = b%l%col(ji) - if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle - block_nj = b%l%block_size(j) - have_any = get_dense_block(a%data, a%scalapack_info_obj, use_a_ij_transpose, i, j, b%l, block_ni, block_nj, a_block) - - if (have_any) then - b_block(1:block_ni,1:block_nj) = reshape(b%data(b%l%data_ptrs(ji):b%l%data_ptrs(ji)+block_ni*block_nj-1),(/block_ni,block_nj/)) - - if (u_b_T) then - do tt=1, block_nj - v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) = & - v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) + & - a_block(1:block_ni,tt)*b_block(1:block_ni,tt) - end do - else - do tt=1, block_ni - v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) = & - v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) + & - a_block(tt,1:block_nj)*b_block(tt,1:block_nj) - end do - end if - end if - - end do - end do - - deallocate(a_block) - deallocate(b_block) - if (.not.present(diag_mask)) deallocate(d_mask) - if (.not.present(offdiag_mask)) deallocate(od_mask) - -end function RS_SparseMatrix_partial_TraceMult_dden_dsp - -function RS_SparseMatrix_partial_TraceMult_dden_zsp(a, b, a_T, b_H, diag_mask, offdiag_mask) result(v) - type(MatrixD), intent(in) :: a - type(RS_SparseMatrixZ), intent(in) :: b - logical, intent(in), optional :: a_T, b_H - logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) - complex(dp) :: v(a%N) - - logical u_a_T, u_b_H - integer i, jj, j, tt - integer block_ni, block_nj, max_block_size - real(dp), allocatable :: a_block(:,:) - complex(dp), allocatable :: b_block(:,:) - logical, pointer :: d_mask(:), od_mask(:) - logical :: use_a_ij_transpose - logical have_any - - max_block_size = maxval(b%l%block_size) - allocate(a_block(max_block_size,max_block_size)) - allocate(b_block(max_block_size,max_block_size)) - if (present(diag_mask)) then - d_mask => diag_mask - else - allocate(d_mask(b%l%N)) - d_mask = .true. - end if - if (present(offdiag_mask)) then - od_mask => offdiag_mask - else - allocate(od_mask(b%l%N)) - od_mask = .true. - end if - - u_a_T = optional_default(.false., a_T) - u_b_H = optional_default(.false., b_H) - - use_a_ij_transpose = .false. - if ((u_a_T .and. u_b_H) .or. (.not. u_a_T .and. .not. u_b_H)) use_a_ij_transpose = .true. - - v = 0.0_dp - do i=1, b%l%N - block_ni = b%l%block_size(i) - do jj=b%l%row_indices(i), b%l%row_indices(i+1)-1 - j = b%l%col(jj) - if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle - block_nj = b%l%block_size(j) - have_any = get_dense_block(a%data, a%scalapack_info_obj, use_a_ij_transpose, i, j, b%l, block_ni, block_nj, a_block) - - if (have_any) then - b_block(1:block_ni,1:block_nj) = reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) - if (u_b_H) b_block = conjg(b_block) - - if (u_b_H) then - do tt=1, block_nj - v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) = & - v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) + & - a_block(1:block_ni,tt)*b_block(1:block_ni,tt) - end do - else - do tt=1, block_ni - v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) = & - v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) + & - a_block(tt,1:block_nj)*b_block(tt,1:block_nj) - end do - end if - end if - - end do - end do - - deallocate(a_block) - deallocate(b_block) - if (.not.present(diag_mask)) deallocate(d_mask) - if (.not.present(offdiag_mask)) deallocate(od_mask) - -end function RS_SparseMatrix_partial_TraceMult_dden_zsp - -function RS_SparseMatrix_partial_TraceMult_zden_dsp(a, b, a_H, b_T, diag_mask, offdiag_mask) result(v) - type(MatrixZ), intent(in) :: a - type(RS_SparseMatrixD), intent(in) :: b - logical, intent(in), optional :: a_H, b_T - logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) - complex(dp) :: v(a%N) - - logical u_a_H, u_b_T - integer i, jj, j, tt - integer block_ni, block_nj, max_block_size - complex(dp), allocatable :: a_block(:,:) - real(dp), allocatable :: b_block(:,:) - logical, pointer :: d_mask(:), od_mask(:) - logical :: use_a_ij_transpose - logical have_any - - max_block_size = maxval(b%l%block_size) - allocate(a_block(max_block_size,max_block_size)) - allocate(b_block(max_block_size,max_block_size)) - if (present(diag_mask)) then - d_mask => diag_mask - else - allocate(d_mask(b%l%N)) - d_mask = .true. - end if - if (present(offdiag_mask)) then - od_mask => offdiag_mask - else - allocate(od_mask(b%l%N)) - od_mask = .true. - end if - - u_a_H = optional_default(.false., a_H) - u_b_T = optional_default(.false., b_T) - - use_a_ij_transpose = .false. - if ((u_a_H .and. u_b_T) .or. (.not. u_a_H .and. .not. u_b_T)) use_a_ij_transpose = .true. - - v = 0.0_dp - do i=1, b%l%N - block_ni = b%l%block_size(i) - do jj=b%l%row_indices(i), b%l%row_indices(i+1)-1 - j = b%l%col(jj) - if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle - block_nj = b%l%block_size(j) - have_any = get_dense_block(a%data, a%scalapack_info_obj, use_a_ij_transpose, i, j, b%l, block_ni, block_nj, a_block) - if (u_a_H) a_block = conjg(a_block) - - if (have_any) then - b_block(1:block_ni,1:block_nj) = reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) - - if (u_b_T) then - do tt=1, block_nj - v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) = & - v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) + & - a_block(1:block_ni,tt)*b_block(1:block_ni,tt) - end do - else - do tt=1, block_ni - v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) = & - v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) + & - a_block(tt,1:block_nj)*b_block(tt,1:block_nj) - end do - end if - end if - - end do - end do - - deallocate(a_block) - deallocate(b_block) - if (.not.present(diag_mask)) deallocate(d_mask) - if (.not.present(offdiag_mask)) deallocate(od_mask) - -end function RS_SparseMatrix_partial_TraceMult_zden_dsp - -function RS_SparseMatrix_partial_TraceMult_zden_zsp(a, b, a_H, b_H, diag_mask, offdiag_mask) result(v) - type(MatrixZ), intent(in) :: a - type(RS_SparseMatrixZ), intent(in) :: b - logical, intent(in), optional :: a_H, b_H - logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) - complex(dp) :: v(a%N) - - logical u_a_H, u_b_H - integer i, jj, j, tt - integer block_ni, block_nj, max_block_size - complex(dp), allocatable :: a_block(:,:), b_block(:,:) - logical, pointer :: d_mask(:), od_mask(:) - logical :: use_a_ij_transpose - logical have_any - - max_block_size = maxval(b%l%block_size) - allocate(a_block(max_block_size,max_block_size)) - allocate(b_block(max_block_size,max_block_size)) - if (present(diag_mask)) then - d_mask => diag_mask - else - allocate(d_mask(b%l%N)) - d_mask = .true. - end if - if (present(offdiag_mask)) then - od_mask => offdiag_mask - else - allocate(od_mask(b%l%N)) - od_mask = .true. - end if - - u_a_H = optional_default(.false., a_H) - u_b_H = optional_default(.false., b_H) - - use_a_ij_transpose = .false. - if ((u_a_H .and. u_b_H) .or. (.not. u_a_H .and. .not. u_b_H)) use_a_ij_transpose = .true. - - v = 0.0_dp - do i=1, b%l%N - block_ni = b%l%block_size(i) - do jj=b%l%row_indices(i), b%l%row_indices(i+1)-1 - j = b%l%col(jj) - if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle - block_nj = b%l%block_size(j) - have_any = get_dense_block(a%data, a%scalapack_info_obj, use_a_ij_transpose, i, j, b%l, block_ni, block_nj, a_block) - if (u_a_H) a_block = conjg(a_block) - - if (have_any) then - b_block(1:block_ni,1:block_nj) = reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) - if (u_b_H) b_block = conjg(b_block) - - if (u_b_H) then - do tt=1, block_nj - v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) = & - v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) + & - a_block(1:block_ni,tt)*b_block(1:block_ni,tt) - end do - else - do tt=1, block_ni - v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) = & - v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) + & - a_block(tt,1:block_nj)*b_block(tt,1:block_nj) - end do - end if - end if - - end do - end do - - deallocate(a_block) - deallocate(b_block) - if (.not.present(diag_mask)) deallocate(d_mask) - if (.not.present(offdiag_mask)) deallocate(od_mask) - -end function RS_SparseMatrix_partial_TraceMult_zden_zsp - -function RS_SparseMatrix_partial_TraceMult_dsp_zden(a, b, a_T, b_H, diag_mask, offdiag_mask) result(v) - type(RS_SparseMatrixD), intent(in) :: a - type(MatrixZ), intent(in) :: b - logical, intent(in), optional :: a_T, b_H - logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) - complex(dp) :: v(b%N) - - logical u_a_T, u_b_H - integer i, jj, j, tt - integer block_ni, block_nj, max_block_size - real(dp), allocatable :: a_block(:,:) - complex(dp), allocatable :: b_block(:,:) - logical, pointer :: d_mask(:), od_mask(:) - logical use_b_ij_transpose - logical have_any - - max_block_size = maxval(a%l%block_size) - allocate(b_block(max_block_size,max_block_size)) - allocate(a_block(max_block_size,max_block_size)) - if (present(diag_mask)) then - d_mask => diag_mask - else - allocate(d_mask(a%l%N)) - d_mask = .true. - end if - if (present(offdiag_mask)) then - od_mask => offdiag_mask - else - allocate(od_mask(a%l%N)) - od_mask = .true. - end if - - u_a_T = optional_default(.false., a_T) - u_b_H = optional_default(.false., b_H) - - use_b_ij_transpose = .false. - if ((u_a_T .and. u_b_H) .or. (.not. u_a_T .and. .not. u_b_H)) use_b_ij_transpose = .true. - - v = 0.0_dp - do i=1, a%l%N - block_ni = a%l%block_size(i) - do jj=a%l%row_indices(i), a%l%row_indices(i+1)-1 - j = a%l%col(jj) - if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle - block_nj = a%l%block_size(j) - have_any = get_dense_block(b%data, b%scalapack_info_obj, use_b_ij_transpose, i, j, a%l, block_ni, block_nj, b_block) - if (u_b_H) b_block = conjg(b_block) - - if (have_any) then - a_block(1:block_ni,1:block_nj) = reshape(a%data(a%l%data_ptrs(jj):a%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) - - if (u_a_T) then - do tt=1, block_ni - v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) = & - v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) + & - a_block(tt,1:block_nj)*b_block(tt,1:block_nj) - end do - else - do tt=1, block_nj - v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) = & - v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) + & - a_block(1:block_ni,tt)*b_block(1:block_ni,tt) - end do - end if - end if - - end do - end do - - deallocate(b_block) - deallocate(a_block) - if (.not.present(diag_mask)) deallocate(d_mask) - if (.not.present(offdiag_mask)) deallocate(od_mask) - -end function RS_SparseMatrix_partial_TraceMult_dsp_zden - -function RS_SparseMatrix_partial_TraceMult_zsp_zden(a, b, a_H, b_H, diag_mask, offdiag_mask) result(v) - type(RS_SparseMatrixZ), intent(in) :: a - type(MatrixZ), intent(in) :: b - logical, intent(in), optional :: a_H, b_H - logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) - complex(dp) :: v(b%N) - - logical u_a_H, u_b_H - integer i, jj, j, tt - integer block_ni, block_nj, max_block_size - complex(dp), allocatable :: a_block(:,:) - complex(dp), allocatable :: b_block(:,:) - logical, pointer :: d_mask(:), od_mask(:) - logical use_b_ij_transpose - logical have_any - - max_block_size = maxval(a%l%block_size) - allocate(b_block(max_block_size,max_block_size)) - allocate(a_block(max_block_size,max_block_size)) - if (present(diag_mask)) then - d_mask => diag_mask - else - allocate(d_mask(a%l%N)) - d_mask = .true. - end if - if (present(offdiag_mask)) then - od_mask => offdiag_mask - else - allocate(od_mask(a%l%N)) - od_mask = .true. - end if - - u_a_H = optional_default(.false., a_H) - u_b_H = optional_default(.false., b_H) - - use_b_ij_transpose = .false. - if ((u_a_H .and. u_b_H) .or. (.not. u_a_H .and. .not. u_b_H)) use_b_ij_transpose = .true. - - v = 0.0_dp - do i=1, a%l%N - block_ni = a%l%block_size(i) - do jj=a%l%row_indices(i), a%l%row_indices(i+1)-1 - j = a%l%col(jj) - if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle - block_nj = a%l%block_size(j) - have_any = get_dense_block(b%data, b%scalapack_info_obj, use_b_ij_transpose, i, j, a%l, block_ni, block_nj, b_block) - if (u_b_H) b_block = conjg(b_block) - - if (have_any) then - a_block(1:block_ni,1:block_nj) = reshape(a%data(a%l%data_ptrs(jj):a%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) - if (u_a_H) a_block = conjg(a_block) - - if (u_a_H) then - do tt=1, block_ni - v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) = & - v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) + & - a_block(tt,1:block_nj)*b_block(tt,1:block_nj) - end do - else - do tt=1, block_nj - v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) = & - v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) + & - a_block(1:block_ni,tt)*b_block(1:block_ni,tt) - end do - end if - end if - - end do - end do - - deallocate(b_block) - deallocate(a_block) - if (.not.present(diag_mask)) deallocate(d_mask) - if (.not.present(offdiag_mask)) deallocate(od_mask) - -end function RS_SparseMatrix_partial_TraceMult_zsp_zden - -function RS_SparseMatrix_partial_TraceMult_dsp_dden(a, b, a_T, b_T, diag_mask, offdiag_mask) result(v) - type(RS_SparseMatrixD), intent(in) :: a - type(MatrixD), intent(in) :: b - logical, intent(in), optional :: a_T, b_T - logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) - complex(dp) :: v(b%N) - - logical u_a_T, u_b_T - integer i, jj, j, tt - integer block_ni, block_nj, max_block_size - real(dp), allocatable :: a_block(:,:) - real(dp), allocatable :: b_block(:,:) - logical, pointer :: d_mask(:), od_mask(:) - logical use_b_ij_transpose - logical have_any - - max_block_size = maxval(a%l%block_size) - allocate(b_block(max_block_size,max_block_size)) - allocate(a_block(max_block_size,max_block_size)) - if (present(diag_mask)) then - d_mask => diag_mask - else - allocate(d_mask(a%l%N)) - d_mask = .true. - end if - if (present(offdiag_mask)) then - od_mask => offdiag_mask - else - allocate(od_mask(a%l%N)) - od_mask = .true. - end if - - u_a_T = optional_default(.false., a_T) - u_b_T = optional_default(.false., b_T) - - use_b_ij_transpose = .false. - if ((u_a_T .and. u_b_T) .or. (.not. u_a_T .and. .not. u_b_T)) use_b_ij_transpose = .true. - - v = 0.0_dp - do i=1, a%l%N - block_ni = a%l%block_size(i) - do jj=a%l%row_indices(i), a%l%row_indices(i+1)-1 - j = a%l%col(jj) - if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle - block_nj = a%l%block_size(j) - have_any = get_dense_block(b%data, b%scalapack_info_obj, use_b_ij_transpose, i, j, a%l, block_ni, block_nj, b_block) - - if (have_any) then - a_block(1:block_ni,1:block_nj) = reshape(a%data(a%l%data_ptrs(jj):a%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) - - if (u_a_T) then - do tt=1, block_ni - v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) = & - v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) + & - a_block(tt,1:block_nj)*b_block(tt,1:block_nj) - end do - else - do tt=1, block_nj - v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) = & - v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) + & - a_block(1:block_ni,tt)*b_block(1:block_ni,tt) - end do - end if - end if - - end do - end do - - deallocate(b_block) - deallocate(a_block) - if (.not.present(diag_mask)) deallocate(d_mask) - if (.not.present(offdiag_mask)) deallocate(od_mask) - -end function RS_SparseMatrix_partial_TraceMult_dsp_dden - -function get_dense_blockD(a_data, a_scalapack_info_obj, use_a_ij_transpose, i, j, b_l, block_ni, block_nj, a_block) - real(dp), intent(in) :: a_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack_info_obj - logical, intent(in) :: use_a_ij_transpose - integer, intent(in) :: i, j - type(RS_SparseMatrixL), intent(in) :: b_l - integer, intent(in) :: block_ni, block_nj - real(dp), intent(out) :: a_block(:,:) - logical :: get_dense_blockD - - integer io, jo, g_i, g_j, l_i, l_j - - if (a_scalapack_info_obj%active) then - get_dense_blockD = .false. - do io = 0, block_ni-1 - do jo = 0, block_nj-1 - g_i = b_l%dense_row_of_row(i) + io - g_j = b_l%dense_row_of_row(j) + jo - if (use_a_ij_transpose) then - call coords_global_to_local(a_scalapack_info_obj, g_j, g_i, l_i, l_j) - if (l_i > 0 .and. l_j > 0) then - a_block(io+1,jo+1) = a_data(l_i,l_j) - get_dense_blockD = .true. - else - a_block(io+1,jo+1) = 0.0_dp - end if - else - call coords_global_to_local(a_scalapack_info_obj, g_i, g_j, l_i, l_j) - if (l_i > 0 .and. l_j > 0) then - a_block(io+1,jo+1) = a_data(l_i,l_j) - get_dense_blockD = .true. - else - a_block(io+1,jo+1) = 0.0_dp - end if - end if - end do - end do - else - get_dense_blockD = .true. - if (use_a_ij_transpose) then - a_block(1:block_ni,1:block_nj) = transpose(a_data(b_l%dense_row_of_row(j):b_l%dense_row_of_row(j)+block_nj-1, & - b_l%dense_row_of_row(i):b_l%dense_row_of_row(i)+block_ni-1)) - else - a_block(1:block_ni,1:block_nj) = a_data(b_l%dense_row_of_row(i):b_l%dense_row_of_row(i)+block_ni-1, & - b_l%dense_row_of_row(j):b_l%dense_row_of_row(j)+block_nj-1) - end if - end if - -end function get_dense_blockD - -function get_dense_blockZ(a_data, a_scalapack_info_obj, use_a_ij_transpose, i, j, b_l, block_ni, block_nj, a_block) - complex(dp), intent(in) :: a_data(:,:) - type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack_info_obj - logical, intent(in) :: use_a_ij_transpose - integer, intent(in) :: i, j - type(RS_SparseMatrixL), intent(in) :: b_l - integer, intent(in) :: block_ni, block_nj - complex(dp), intent(out) :: a_block(:,:) - logical :: get_dense_blockZ - - integer io, jo, g_i, g_j, l_i, l_j - - if (a_scalapack_info_obj%active) then - get_dense_blockZ = .false. - do io = 0, block_ni-1 - do jo = 0, block_nj-1 - g_i = b_l%dense_row_of_row(i) + io - g_j = b_l%dense_row_of_row(j) + jo - if (use_a_ij_transpose) then - call coords_global_to_local(a_scalapack_info_obj, g_j, g_i, l_i, l_j) - if (l_i > 0 .and. l_j > 0) then - a_block(io+1,jo+1) = a_data(l_i,l_j) - get_dense_blockZ = .true. - else - a_block(io+1,jo+1) = 0.0_dp - end if - else - call coords_global_to_local(a_scalapack_info_obj, g_i, g_j, l_i, l_j) - if (l_i > 0 .and. l_j > 0) then - a_block(io+1,jo+1) = a_data(l_i,l_j) - get_dense_blockZ = .true. - else - a_block(io+1,jo+1) = 0.0_dp - end if - end if - end do - end do - else - get_dense_blockZ = .true. - if (use_a_ij_transpose) then - a_block(1:block_ni,1:block_nj) = transpose(a_data(b_l%dense_row_of_row(j):b_l%dense_row_of_row(j)+block_nj-1, & - b_l%dense_row_of_row(i):b_l%dense_row_of_row(i)+block_ni-1)) - else - a_block(1:block_ni,1:block_nj) = a_data(b_l%dense_row_of_row(i):b_l%dense_row_of_row(i)+block_ni-1, & - b_l%dense_row_of_row(j):b_l%dense_row_of_row(j)+block_nj-1) - end if - end if - -end function get_dense_blockZ - -function RS_SparseMatrix_TraceMult_dden_dsp(a, b, w, a_T, b_T, diag_mask, offdiag_mask) - type(MatrixD), intent(in) :: a - type(RS_SparseMatrixD), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_T, b_T - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - real(dp) :: RS_SparseMatrix_TraceMult_dden_dsp - - if (present(w)) then - RS_SparseMatrix_TraceMult_dden_dsp = sum(partial_TraceMult(a, b, a_T, b_T, diag_mask, offdiag_mask)*w) - else - RS_SparseMatrix_TraceMult_dden_dsp = sum(partial_TraceMult(a, b, a_T, b_T, diag_mask, offdiag_mask)) - end if - -end function RS_SparseMatrix_TraceMult_dden_dsp - -function RS_SparseMatrix_TraceMult_dden_zsp(a, b, w, a_T, b_H, diag_mask, offdiag_mask) - type(MatrixD), intent(in) :: a - type(RS_SparseMatrixZ), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_T, b_H - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: RS_SparseMatrix_TraceMult_dden_zsp - - if (present(w)) then - RS_SparseMatrix_TraceMult_dden_zsp = sum(partial_TraceMult(a, b, a_T, b_H, diag_mask, offdiag_mask)*w) - else - RS_SparseMatrix_TraceMult_dden_zsp = sum(partial_TraceMult(a, b, a_T, b_H, diag_mask, offdiag_mask)) - end if - -end function RS_SparseMatrix_TraceMult_dden_zsp - -function RS_SparseMatrix_TraceMult_zden_dsp(a, b, w, a_H, b_T, diag_mask, offdiag_mask) - type(MatrixZ), intent(in) :: a - type(RS_SparseMatrixD), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_H, b_T - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: RS_SparseMatrix_TraceMult_zden_dsp - - if (present(w)) then - RS_SparseMatrix_TraceMult_zden_dsp = sum(partial_TraceMult(a, b, a_H, b_T, diag_mask, offdiag_mask)*w) - else - RS_SparseMatrix_TraceMult_zden_dsp = sum(partial_TraceMult(a, b, a_H, b_T, diag_mask, offdiag_mask)) - end if - -end function RS_SparseMatrix_TraceMult_zden_dsp - -function RS_SparseMatrix_TraceMult_dsp_zden(a, b, w, a_T, b_H, diag_mask, offdiag_mask) - type(RS_SparseMatrixD), intent(in) :: a - type(MatrixZ), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_T, b_H - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: RS_SparseMatrix_TraceMult_dsp_zden - - if (present(w)) then - RS_SparseMatrix_TraceMult_dsp_zden = sum(partial_TraceMult(a, b, a_T, b_H, diag_mask, offdiag_mask)*w) - else - RS_SparseMatrix_TraceMult_dsp_zden = sum(partial_TraceMult(a, b, a_T, b_H, diag_mask, offdiag_mask)) - end if - -end function RS_SparseMatrix_TraceMult_dsp_zden - -function RS_SparseMatrix_TraceMult_dsp_dden(a, b, w, a_T, b_T, diag_mask, offdiag_mask) - type(RS_SparseMatrixD), intent(in) :: a - type(MatrixD), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_T, b_T - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: RS_SparseMatrix_TraceMult_dsp_dden - - if (present(w)) then - RS_SparseMatrix_TraceMult_dsp_dden = sum(partial_TraceMult(a, b, a_T, b_T, diag_mask, offdiag_mask)*w) - else - RS_SparseMatrix_TraceMult_dsp_dden = sum(partial_TraceMult(a, b, a_T, b_T, diag_mask, offdiag_mask)) - end if - -end function RS_SparseMatrix_TraceMult_dsp_dden - -function RS_SparseMatrix_TraceMult_zsp_zden(a, b, w, a_H, b_H, diag_mask, offdiag_mask) - type(RS_SparseMatrixZ), intent(in) :: a - type(MatrixZ), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_H, b_H - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: RS_SparseMatrix_TraceMult_zsp_zden - - if (present(w)) then - RS_SparseMatrix_TraceMult_zsp_zden = sum(partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask)*w) - else - RS_SparseMatrix_TraceMult_zsp_zden = sum(partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask)) - end if - -end function RS_SparseMatrix_TraceMult_zsp_zden - -function RS_SparseMatrix_TraceMult_zden_zsp(a, b, w, a_H, b_H, diag_mask, offdiag_mask) - type(MatrixZ), intent(in) :: a - type(RS_SparseMatrixZ), intent(in) :: b - real(dp), intent(in), optional :: w(:) - logical, intent(in), optional :: a_H, b_H - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: RS_SparseMatrix_TraceMult_zden_zsp - - if (present(w)) then - RS_SparseMatrix_TraceMult_zden_zsp = sum(partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask)*w) - else - RS_SparseMatrix_TraceMult_zden_zsp = sum(partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask)) - end if - -end function RS_SparseMatrix_TraceMult_zden_zsp - -subroutine RS_SparseMatrixD_multDiagRL_d(this, A, diag) - type(RS_SparseMatrixD), intent(inout) :: this - type(RS_SparseMatrixD), intent(in) :: A - real(dp), intent(in) :: diag(:) - - integer i, jj, j, block_ni, block_nj, io, jo - real(dp) fac - - do i=1, A%l%N - block_ni = A%l%block_size(i) - do jj=A%l%row_indices(i), A%l%row_indices(i+1)-1 - j = A%l%col(jj) - block_nj = A%l%block_size(j) - do jo=0, block_nj-1 - do io=0, block_ni-1 - fac = 0.5_dp*(diag(this%l%dense_row_of_row(i)+io)+diag(this%l%dense_row_of_row(j)+jo)) - this%data(this%l%data_ptrs(jj)+io+block_ni*jo) = fac*A%data(this%l%data_ptrs(jj)+io+block_ni*jo) - end do - end do - end do - end do - -end subroutine RS_SparseMatrixD_multDiagRL_d - -subroutine RS_SparseMatrixZ_multDiagRL_d(this, A, diag) - type(RS_SparseMatrixZ), intent(inout) :: this - type(RS_SparseMatrixZ), intent(in) :: A - real(dp), intent(in) :: diag(:) - - integer i, jj, j, block_ni, block_nj, io, jo - real(dp) fac - - do i=1, A%l%N - block_ni = A%l%block_size(i) - do jj=A%l%row_indices(i), A%l%row_indices(i+1)-1 - j = A%l%col(jj) - block_nj = A%l%block_size(j) - do jo=0, block_nj-1 - do io=0, block_ni-1 - fac = 0.5_dp*(diag(this%l%dense_row_of_row(i)+io)+diag(this%l%dense_row_of_row(j)+jo)) - this%data(this%l%data_ptrs(jj)+io+block_ni*jo) = fac*A%data(this%l%data_ptrs(jj)+io+block_ni*jo) - end do - end do - end do - end do - -end subroutine RS_SparseMatrixZ_multDiagRL_d - -subroutine check_sparse_layout(l) - type(RS_SparseMatrixL), intent(in) :: l - integer i, ji, j - - do i=1, l%N - do ji=l%row_indices(i), l%row_indices(i+1)-1 - j = l%col(ji) - - call print("check_sparse " // i // " " // j) - - if (ji > l%row_indices(i)) then - if (j <= l%col(ji-1)) then - call print("ERROR row " // i // " col " // j // " (ji="//ji//") out of order") - call print(l%col(l%row_indices(i):l%row_indices(i+1)-1)) - end if - end if - - if (.not. any(l%col(l%row_indices(j):l%row_indices(j+1)-1) == i)) then - call print ("ERROR row "//i//" col "//j//" has no transpose match") - call print(l%col(l%row_indices(j):l%row_indices(j+1)-1)) - end if - - end do - end do -end subroutine - -end module RS_SparseMatrix_module diff --git a/src/Potentials/SocketPot.f95 b/src/Potentials/SocketPot.f95 deleted file mode 100644 index 194ef1dc1a..0000000000 --- a/src/Potentials/SocketPot.f95 +++ /dev/null @@ -1,341 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X SocketPot Module -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" -module SocketPot_module - -use error_module -use system_module -use mpi_context_module -use dictionary_module -use paramreader_module -use atoms_types_module -use atoms_module -use SocketTools_module - -implicit none -private - -public :: SocketPot_type -type SocketPot_type - character(len=STRING_LENGTH) :: init_args_str - character(len=STRING_LENGTH) :: ip - character(len=STRING_LENGTH) :: property_list - character(len=STRING_LENGTH) :: property_list_prefixes - character(len=STRING_LENGTH) :: read_extra_property_list - character(len=STRING_LENGTH) :: read_extra_param_list - integer :: port, client_id, label, last_label, buffsize - type(MPI_context) :: mpi -end type SocketPot_type - -public :: Initialise -interface Initialise - module procedure SocketPot_Initialise -end interface Initialise - -public :: Finalise -interface Finalise - module procedure SocketPot_Finalise -end interface Finalise - -public :: cutoff -interface cutoff - module procedure SocketPot_cutoff -end interface - -public :: Wipe -interface Wipe - module procedure SocketPot_Wipe -end interface Wipe - -public :: Print -interface Print - module procedure SocketPot_Print -end interface Print - -public :: calc -interface calc - module procedure SocketPot_Calc -end interface - -contains - - -subroutine SocketPot_Initialise(this, args_str, mpi, error) - type(SocketPot_type), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(MPI_Context), intent(in), optional :: mpi - integer, intent(out), optional :: error - - type(Dictionary) :: params - - INIT_ERROR(error) - - call finalise(this) - - call initialise(params) - call param_register(params, 'server_ip', '', this%ip, help_string="IP address to send configs to") - call param_register(params, 'server_port', '0', this%port, help_string="TCP port number to send configs to. Default 0.") - call param_register(params, 'client_id', '0', this%client_id, help_string="Identity of this client. Default 0.") - call param_register(params, 'buffsize', '1000000', this%buffsize, help_string='Size of recv buffer in bytes. Default 100000') - call param_register(params, 'property_list', 'species:pos', this%property_list, help_string="list of properties to send with the structure") - call param_register(params, 'read_extra_property_list', '', this%read_extra_property_list, help_string="names of extra properties to read back") - call param_register(params, 'read_extra_param_list', 'QM_cell', this%read_extra_param_list, help_string="list of extra params (comment line in XYZ) to read back. Default is 'QM_cell'") - call param_register(params, 'property_list_prefixes', '', this%property_list_prefixes, help_string="list of prefixes to which run_suffix will be applied during calc()") - - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='SocketPot_initialise')) then - RAISE_ERROR('SocketPot_Initialise failed to parse args_str="'//trim(args_str)//"'", error) - endif - call finalise(params) - - this%label = 0 - this%init_args_str = args_str - if (present(mpi)) this%mpi = mpi - -end subroutine SocketPot_Initialise - -subroutine SocketPot_Finalise(this) - type(SocketPot_type), intent(inout) :: this - - call wipe(this) - -end subroutine SocketPot_Finalise - -subroutine SocketPot_Wipe(this) - type(SocketPot_type), intent(inout) :: this - - this%ip = '' - this%port = 0 - this%client_id = 0 - this%buffsize = 1000000 - this%property_list="" - this%read_extra_property_list="" - this%read_extra_param_list="" - this%property_list_prefixes="" - -end subroutine SocketPot_Wipe - -function SocketPot_cutoff(this) - type(SocketPot_type), intent(in) :: this - real(dp) :: SocketPot_cutoff - SocketPot_cutoff = 0.0_dp ! return zero, because SocketPot does its own connection calculation -end function SocketPot_cutoff - -subroutine SocketPot_Print(this, file) - type(SocketPot_type), intent(in) :: this - type(Inoutput), intent(inout),optional,target:: file - - if (current_verbosity() < PRINT_NORMAL) return - - call print('SocketPot: connecting to QUIP server on host '//trim(this%ip)//':'//this%port//' with client_id '//this%client_id, file=file) - call print(" buffsize="//this%buffsize//& - " property_list='"//trim(this%property_list)//& - "' read_extra_property_list='"//trim(this%read_extra_property_list)//& - "' read_extra_param_list='"//trim(this%read_extra_param_list)//& - "' property_list_prefixes='"//trim(this%property_list_prefixes)//"'", file=file) - -end subroutine SocketPot_Print - -subroutine SocketPot_Calc(this, at, energy, local_e, forces, virial, local_virial, args_str, error) - type(SocketPot_type), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: energy - real(dp), intent(out), target, optional :: local_e(:) - real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) - real(dp), intent(out), optional :: virial(3,3) - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - type(Atoms) :: at_copy - type(Dictionary) :: cli - integer n_params, n_copy, i, n_properties, label - real(dp), pointer :: local_e_ptr(:), force_ptr(:,:), local_virial_ptr(:,:) - logical :: calc_energy, calc_local_e, calc_force, calc_virial, calc_local_virial - character(STRING_LENGTH) :: my_args_str, tmp_params_array(100), copy_keys(100), property_list, & - read_extra_property_list, read_extra_param_list, run_suffix, tmp_properties_array(100) - - INIT_ERROR(error) - - my_args_str = '' - if (present(args_str)) my_args_str = args_str - - call param_register(cli, "property_list", trim(this%property_list), property_list, help_string="properties to send. Overrides init_args version.") - call param_register(cli, "read_extra_property_list", trim(this%read_extra_property_list), read_extra_property_list, help_string="extra properties to read. Overrides init_args version.") - call param_register(cli, "read_extra_param_list", trim(this%read_extra_param_list), read_extra_param_list, help_string="extra params to read. Overrides init_args version.") - call param_register(cli, "run_suffix", '', run_suffix, help_string="suffix to apply to property names in this%property_list_prefixes") - - if (.not. param_read_line(cli, my_args_str, ignore_unknown=.true.,task='socketpot_calc args_str')) then - RAISE_ERROR("FilePot_calc failed to parse args_str='"//trim(args_str)//"'",error) - endif - call finalise(cli) - - if (.not. this%mpi%active .or. (this%mpi%active .and. this%mpi%my_proc == 0)) then - calc_energy = .false. - calc_local_e = .false. - calc_force = .false. - calc_virial = .false. - calc_local_virial = .false. - if (present(energy)) then - energy = 0.0_dp - calc_energy = .true. - end if - if (present(local_e)) then - local_e = 0.0_dp - calc_local_e = .true. - end if - if (present(forces)) then - forces = 0.0_dp - calc_force = .true. - end if - if (present(virial)) then - virial = 0.0_dp - calc_virial = .true. - end if - if (present(local_virial)) then - local_virial = 0.0_dp - calc_local_virial = .true. - end if - - at_copy = at ! work with a copy of original Atoms - call set_value(at_copy%params, 'calc_energy', calc_energy) - call set_value(at_copy%params, 'calc_local_e', calc_local_e) - call set_value(at_copy%params, 'calc_virial', calc_virial) - call set_value(at_copy%params, 'calc_force', calc_force) - call set_value(at_copy%params, 'calc_local_virial', calc_local_virial) - call set_value(at_copy%params, 'label', this%label) - if (present(args_str)) then - call set_value(at_copy%params, 'calc_args_str', args_str) - end if - - if (len_trim(this%property_list_prefixes) /= 0) then - call parse_string(this%property_list_prefixes, ':', tmp_properties_array, n_properties, error=error) - do i=1, n_properties - property_list = trim(property_list)//':'//trim(tmp_properties_array(i))//run_suffix - end do - end if - - call system_timer('socket_send') - call socket_send_xyz(this%ip, this%port, this%client_id, at_copy, properties=property_list) - call system_timer('socket_send') - - this%label = this%label + 1 - - call system_timer('socket_recv') - call socket_recv_xyz(this%ip, this%port, this%client_id, this%buffsize, at_copy) - call system_timer('socket_recv') - - if (.not. get_value(at_copy%params, 'label', label)) then - RAISE_ERROR('SocketPot_Calc: missing label param in received atoms', error) - end if - if (label /= this%label) then - RAISE_ERROR('SocketPot_Calc: mismatch between labels expected ('//this%label//') and received ('//label//').', error) - end if - - if (present(energy)) then - if (.not. get_value(at_copy%params, 'energy', energy)) then - call print('WARNING SocketPot_calc: "energy" requested but not returned by callback') - endif - end if - - if (present(local_e)) then - if (.not. assign_pointer(at_copy, 'local_e', local_e_ptr)) then - call print('WARNING SocketPot_calc: "local_e" requested but not returned by callback') - else - local_e(:) = local_e_ptr - end if - end if - - if (present(forces)) then - if (.not. assign_pointer(at_copy, 'force', force_ptr)) then - call print('WARNING SocketPot_calc: "forces" requested but not returned by callback') - else - forces(:,:) = force_ptr - end if - end if - - if (present(virial)) then - if (.not. get_value(at_copy%params, 'virial', virial)) then - call print('WARNING SocketPot_calc: "virial" requested but not returned by callback') - end if - end if - - if (present(local_virial)) then - if (.not. assign_pointer(at_copy, 'local_virial', local_virial_ptr)) then - call print('WARNING SocketPot_calc: "local_virial" requested but not returned by callback') - else - local_virial(:,:) = local_virial_ptr - end if - end if - - if (len_trim(read_extra_property_list) > 0) then - call copy_properties(at, at_copy, trim(read_extra_property_list)) - endif - - if (len_trim(read_extra_param_list) > 0) then - call parse_string(read_extra_param_list, ':', tmp_params_array, n_params, error=error) - PASS_ERROR(error) - - n_copy = 0 - do i=1,n_params - if (has_key(at_copy%params, trim(tmp_params_array(i)))) then - n_copy = n_copy + 1 - copy_keys(n_copy) = tmp_params_array(i) - call print("SocketPot copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) - else if (has_key(at_copy%params, trim(tmp_params_array(i))//trim(run_suffix))) then - n_copy = n_copy + 1 - copy_keys(n_copy) = trim(tmp_params_array(i))//trim(run_suffix) - call print("SocketPot copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) - end if - end do - - call subset(at_copy%params, copy_keys(1:n_copy), at%params, out_no_initialise=.true.) - end if - end if - - if (this%mpi%active) then - ! Share results with other nodes - if (present(energy)) call bcast(this%mpi, energy) - if (present(local_e)) call bcast(this%mpi, local_e) - - if (present(forces)) call bcast(this%mpi, forces) - if (present(virial)) call bcast(this%mpi, virial) - if (present(local_virial)) call bcast(this%mpi, local_virial) - end if - - call finalise(at_copy) - -end subroutine SocketPot_calc - -end module SocketPot_module diff --git a/src/Potentials/TB.f95 b/src/Potentials/TB.f95 deleted file mode 100644 index 012db28980..0000000000 --- a/src/Potentials/TB.f95 +++ /dev/null @@ -1,2360 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X TB module -!X -!% General object which handles all the possible tight-binding potentials (TB), re-addressing -!% the calls to the right routines. -!% -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" -module TB_module - -use error_module -use system_module, only : dp, inoutput, initialise, finalise, INPUT, current_verbosity, print, & - DEALLOC_TRACE, PRINT_NORMAL, PRINT_VERBOSE, PRINT_ALWAYS, PRINT_NERD, PRINT_ANALYSIS, optional_default, mpi_id, REAL_SIZE, ALLOC_TRACE, & - verbosity_push_decrement, verbosity_push, verbosity_pop, system_timer, operator(//) -use mpi_context_module, only : mpi_context, finalise -use linearalgebra_module, only : operator(.feq.), operator(.fne.), operator(.mult.) -use extendable_str_module, only : extendable_str, initialise, finalise, read, string -use dictionary_module, only : dictionary, get_value, set_value, STRING_LENGTH -use paramreader_module, only : param_register, param_read_line -use atoms_types_module, only : assign_pointer -use atoms_module, only : atoms, calc_connect, set_cutoff, assignment(=) -use CInOutput_module, only : write - -use QUIP_common_module - -use Functions_module, only : f_fermi, f_fermi_deriv -use ApproxFermi_module, only : approxfermi, approx_f_fermi, approx_f_fermi_deriv, initialise, finalise, print -use Matrix_module, only : matrixd, add_identity, inverse -! use RS_SparseMatrix_module -use TB_KPoints_module, only : kpoints, ksum_dup, ksum_distrib, local_ksum, min, max, ksum_distrib_inplace, collect -use TBModel_module, only : has_band_width, has_Fermi_T, has_Fermi_E, get_local_rep_E, get_local_rep_E_force, get_local_rep_E_virial -use TBMatrix_module, only : tbmatrix, tbvector, finalise, wipe, diagonalise, partial_TraceMult, Re_diag, diag_spinor, partial_TraceMult_spinor, TraceMult, matrix_product_sub, & - multDiag, multDiagRL, zero, transpose_sub, accum_scaled_elem_product, scaled_accum, copy -use TBSystem_module, only : tbsystem, initialise, finalise, wipe, print, setup_atoms, update_orb_local_pot, atom_orbital_spread, & - scf_e_correction, scf_f_correction, scf_virial_correction, atom_orbital_sum, fill_matrices, fill_dmatrices, fill_these_matrices, & - SCF_LCN, SCF_GCN, SCF_LOCAL_U, SCF_NONLOCAL_U_DFTB, SCF_NONLOCAL_U_NRL_TB, n_elec, scf_set_atomic_n_mom, scf_set_global_n, & - calc_orb_local_pot, scf_get_atomic_n_mom, scf_get_global_n, set_type, local_scf_e_correction, fill_sc_matrices, setup_deriv_matrices, & - add_term_d2scfe_dn2_times_vec, add_term_dscf_e_correction_dn, add_term_d2scfe_dgndn, atom_orbital_spread_mat, ksum_atom_orbital_sum_mat, & - add_term_dscf_e_correction_dgn, copy_matrices -use TB_GreensFunctions_module, only : greensfunctions, initialise, finalise, wipe, print, calc_dm_from_gs, calc_gs, calc_mod_dm_from_gs, gsum_distrib_inplace - -implicit none -private - -public :: TB_type -type TB_type - type(TBSystem) tbsys - type(Atoms) at - integer method - - type(TBVector) :: evals, E_fillings, F_fillings, eval_F_fillings - type(TBMatrix) :: evecs - type(TBMatrix) :: dm, Hdm, scaled_evecs - - type(MPI_context) :: mpi - - type (GreensFunctions) gf - - logical :: calc_done = .false. - real(dp) :: fermi_E, fermi_T - real(dp) :: fermi_E_precision = 1.0e-9_dp - real(dp) :: homo_e, lumo_e - - character(len=1024) :: init_args_str - character(len=1024) :: calc_args_str - -end type TB_type - -public :: Initialise -public :: TB_Initialise_filename -interface Initialise - module procedure TB_Initialise_inoutput, TB_Initialise_str -end interface Initialise - -public :: Finalise -interface Finalise - module procedure TB_Finalise -end interface Finalise - -public :: cutoff -interface cutoff - module procedure TB_cutoff -end interface - -public :: Wipe -interface Wipe - module procedure TB_Wipe -end interface Wipe - -public :: Print -interface Print - module procedure TB_Print -end interface Print - -public :: Setup_atoms -interface Setup_atoms - module procedure TB_Setup_atoms -end interface Setup_atoms - -public :: solve_diag -interface solve_diag - module procedure TB_solve_diag -end interface - -public :: calc -interface calc - module procedure TB_calc -end interface - -public :: calc_diag -interface calc_diag - module procedure TB_calc_diag -end interface - -public :: calc_GF -interface calc_GF - module procedure TB_calc_GF -end interface - -public :: TB_evals - -public :: absorption - -interface find_fermi_E - module procedure TB_find_fermi_E -end interface find_fermi_E - -interface calc_E_fillings - module procedure TB_calc_E_fillings -end interface calc_E_fillings - -interface calc_F_fillings - module procedure TB_calc_F_fillings -end interface calc_F_fillings - -interface realloc_match_tbsys - module procedure realloc_match_tbsys_vec, realloc_match_tbsys_mat -end interface realloc_match_tbsys - -public :: copy_matrices -interface copy_matrices - module procedure TB_copy_matrices -end interface copy_matrices - -contains - - -subroutine TB_Initialise_filename(this, args_str, filename, kpoints_obj, mpi_obj, error) - type(TB_type), intent(inout) :: this - character(len=*), intent(in) :: args_str - character(len=*), intent(in) :: filename - type(KPoints), intent(in), optional :: kpoints_obj - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(inoutput) io - - INIT_ERROR(error) - - call Initialise(io, filename, INPUT) - - call Initialise(this, args_str, io, kpoints_obj, mpi_obj, error) - PASS_ERROR(error) - - call Finalise(io) - -end subroutine TB_Initialise_filename - -subroutine TB_Initialise_inoutput(this, args_str, io_obj, kpoints_obj, mpi_obj, error) - type(TB_type), intent(inout) :: this - character(len=*), intent(in) :: args_str - type(Inoutput), intent(inout), optional :: io_obj - type(KPoints), intent(in), optional :: kpoints_obj - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - type(extendable_str) :: ss - - INIT_ERROR(error) - - call Initialise(ss) - if (present(io_obj)) then - if (present(mpi_obj)) then - call read(ss, io_obj%unit, convert_to_string=.true., mpi_comm = mpi_obj%communicator, mpi_id = mpi_obj%my_proc) - else - call read(ss, io_obj%unit, convert_to_string=.true.) - endif - endif - call Initialise(this, args_str, string(ss), kpoints_obj, mpi_obj, error) - PASS_ERROR(error) - - call Finalise(ss) - -end subroutine TB_Initialise_inoutput - - -subroutine TB_Initialise_str(this, args_str, param_str, kpoints_obj, mpi_obj, error) - type(TB_type), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(KPoints), intent(in), optional :: kpoints_obj - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - INIT_ERROR(error) - - call Finalise(this) - - this%init_args_str = args_str - - if (present(mpi_obj)) then - this%mpi = mpi_obj - endif - call Initialise(this%tbsys, args_str, param_str, kpoints_obj, mpi_obj) -end subroutine TB_Initialise_str - -subroutine TB_Finalise(this) - type(TB_type), intent(inout) :: this - - call Wipe(this) - call Finalise(this%tbsys) - call Finalise(this%mpi) - call Finalise(this%evals) - call Finalise(this%E_fillings) - call Finalise(this%F_fillings) - call Finalise(this%eval_F_fillings) - call Finalise(this%evecs) - call Finalise(this%dm) - call Finalise(this%Hdm) - call Finalise(this%gf) -end subroutine - -subroutine TB_Wipe(this) - type(TB_type), intent(inout) :: this - - call Wipe(this%tbsys) - call Wipe(this%evals) - call Wipe(this%E_fillings) - call Wipe(this%F_fillings) - call Wipe(this%eval_F_fillings) - call Wipe(this%evecs) - call Wipe(this%dm) - call Wipe(this%Hdm) - call Wipe(this%gf) - - this%calc_done = .false. - -end subroutine - -function TB_cutoff(this) - type(TB_type), intent(in) :: this - real(dp) :: TB_cutoff - TB_cutoff = 0.0_dp ! return zero, because TB does its own connection calculation -end function TB_cutoff - -subroutine TB_Print(this, file) - type(TB_type), intent(in) :: this - type(Inoutput), intent(inout),optional,target:: file - - if (current_verbosity() < PRINT_NORMAL) return - - call Print('TB : ', file=file) - - if (this%calc_done) then - call print("Fermi_E " // this%Fermi_E //" Fermi_T " // this%Fermi_T) - else - call print("Fermi_E, Fermi_T not yet set (no calc done)") - endif - - call Print (this%tbsys, file=file) - if (this%calc_done) then - call print ("homo " // this%homo_e // " lumo " // this%lumo_e // " gap " // (this%lumo_e-this%homo_e), file=file) - else - call print("homo, lumo, gap not yet set (no calc done)") - endif - call verbosity_push_decrement() - call print("evals", file=file) - call Print (this%evals, file=file) - call verbosity_push_decrement() - call print("E_fillings", file=file) - call Print (this%E_fillings, file=file) - call print("F_fillings", file=file) - call Print (this%F_fillings, file=file) - call print("eval_F_fillings", file=file) - call Print (this%eval_F_fillings, file=file) - call verbosity_push_decrement() - call print("evecs", file=file) - call Print (this%evecs, file=file) - call print("dm", file=file) - call Print (this%dm, file=file) - call print("Hdm", file=file) - call Print (this%Hdm, file=file) - call print("gf", file=file) - call Print (this%gf, file=file) - call verbosity_pop() - call verbosity_pop() - call verbosity_pop() - -end subroutine TB_Print - -subroutine TB_copy_matrices(this, Hd, Sd, Hz, Sz, index) - type(TB_type), intent(in) :: this - real(dp), intent(inout), optional, dimension(:,:) :: Hd, Sd - complex(dp), intent(inout), optional, dimension(:,:) :: Hz, Sz - integer, intent(in), optional :: index - - call copy_matrices(this%tbsys, Hd, Sd, Hz, Sz, index) -end subroutine TB_copy_matrices - - -subroutine TB_Setup_atoms(this, at, is_noncollinear, is_spinpol_no_scf, args_str, error) - type(TB_type), intent(inout) :: this - type(Atoms), intent(in) :: at - logical, intent(in), optional :: is_noncollinear, is_spinpol_no_scf - character(len=*), intent(in), optional :: args_str - integer, intent(out), optional :: error - - INIT_ERROR(error) - - call wipe(this%tbsys) - call setup_atoms(this%tbsys, at, is_noncollinear, is_spinpol_no_scf, args_str, this%mpi, error=error) - PASS_ERROR(error) - - this%at = at - call set_cutoff(this%at, this%tbsys%tbmodel%cutoff) - call calc_connect(this%at, own_neighbour=.true.) - -end subroutine TB_setup_atoms - - -subroutine realloc_match_tbsys_vec(tbsys, vec) - type(TBSystem), intent(in) :: tbsys - type(TBVector), intent(inout) :: vec - - if (vec%N /= tbsys%N .or. vec%n_vectors /= tbsys%n_matrices) then - call Finalise(vec) - call Initialise(vec, tbsys%N, tbsys%n_matrices) - endif -end subroutine realloc_match_tbsys_vec - -subroutine realloc_match_tbsys_mat(tbsys, mat) - type(TBSystem), intent(in) :: tbsys - type(TBMatrix), intent(inout) :: mat - - if (mat%N /= tbsys%N .or. mat%n_matrices /= tbsys%n_matrices) then - call Finalise(mat) - call Initialise(mat, tbsys%N, tbsys%n_matrices, tbsys%complex_matrices, & - scalapack_obj=tbsys%scalapack_my_matrices) - endif -end subroutine realloc_match_tbsys_mat - -subroutine TB_solve_diag(this, need_evecs, use_fermi_E, fermi_E, w_n, use_prev_charge, AF, error) - type(TB_type), intent(inout) :: this - logical, intent(in), optional :: need_evecs - logical, optional, intent(in) :: use_Fermi_E - real(dp), optional, intent(inout) :: fermi_E - real(dp), pointer, intent(in) :: w_n(:) - logical, optional, intent(in) :: use_prev_charge - type(ApproxFermi), intent(inout), optional :: AF - integer, intent(out), optional :: error - - logical my_use_prev_charge - - real(dp), pointer :: scf_orbital_n(:), scf_orbital_m(:,:) - real(dp) :: global_N - real(dp), pointer :: local_N(:), local_mom(:,:), local_pot(:) - logical do_evecs - - integer diag_error - integer :: max_iter = 1 - integer iter - logical scf_converged - - INIT_ERROR(error) - - my_use_prev_charge = optional_default(.false., use_prev_charge) - - if (this%at%cutoff < this%tbsys%tbmodel%cutoff) & - call print ("WARNING: Called TB_solve_diag with messed up cutoff in atoms: cutoff "// & - this%at%cutoff // " < " // this%tbsys%tbmodel%cutoff) - - if (present(AF)) then - if (present(use_fermi_E)) then - if (use_fermi_E) then - if (AF%n_poles == 0) then - call system_abort("Called solve_diag with use_fermi_E and AF that is uninitialized") - endif - else - if (AF%band_width .feq. 0.0_dp) then - call system_abort("Called solve_diag with .not. use_fermi_E and AF that has no band_width") - endif - endif - endif - endif - - if (this%tbsys%scf%active) then - max_iter= this%tbsys%scf%max_iter - endif - - if (this%tbsys%scf%active) then - if (my_use_prev_charge) then - - if (assign_pointer(this%at, 'local_N', local_N)) then - call print("TB_solve_diag calling set_atomic_n_mom(this%tbsys%scf) using this%at:local_N", PRINT_VERBOSE) - else - call print("TB_solve_diag got use_prev_charge, but no local_N value is defined", PRINT_ALWAYS) - endif - if (assign_pointer(this%at, 'local_mom', local_mom)) then - call print("TB_solve_diag calling set_atomic_n_mom(this%tbsys%scf) using this%at:local_mom", PRINT_VERBOSE) - else - call print("TB_solve_diag got use_prev_charge, but no local_mom value is defined", PRINT_ALWAYS) - endif - if (assign_pointer(this%at, 'local_pot', local_pot)) then - call print("TB_solve_diag calling set_atomic_n_mom(this%tbsys%scf) using this%at:local_pot", PRINT_VERBOSE) - else - call print("TB_solve_diag got use_prev_charge, but no local_pot value is defined", PRINT_ALWAYS) - endif - - call scf_set_atomic_n_mom(this%tbsys, local_N, local_mom, local_pot) - - if (get_value(this%at%params, 'global_N', global_N)) then - call print("TB_solve_diag calling set_global_N(this%tbsys%scf from this%at:global_N", PRINT_VERBOSE) - call scf_set_global_N(this%tbsys, w_n, global_N) - else - call scf_set_global_N(this%tbsys, w_n) - call print("TB_solve_diag got use_prev_charge, but no global_N value is defined", PRINT_ALWAYS) - endif - - else - nullify(local_N) - nullify(local_mom) - nullify(local_pot) - call scf_set_atomic_n_mom(this%tbsys, local_N, local_mom, local_pot) - call scf_set_global_N(this%tbsys, w_n) - endif - endif - - do_evecs = .false. - if (present(need_evecs)) do_evecs = need_evecs - do_evecs = do_evecs .or. this%tbsys%scf%active - - call realloc_match_tbsys(this%tbsys, this%evals) - if (do_evecs) then - call realloc_match_tbsys(this%tbsys, this%evecs) - endif - - nullify(scf_orbital_n) - nullify(scf_orbital_m) - if (this%tbsys%scf%active) then - allocate(scf_orbital_n(this%tbsys%N)) - if (this%tbsys%noncollinear) then - allocate(scf_orbital_m(3,this%tbsys%N)) - endif - endif - call fill_sc_matrices(this%tbsys, this%at) - - call calc_orb_local_pot(this%tbsys, w_n) - - iter = 1 - scf_converged = .false. - if(this%tbsys%scf%active) call print("TB starting SCF iterations") - do while (iter <= max_iter .and. .not. scf_converged) - - call fill_matrices(this%tbsys, this%at) - - if (this%tbsys%tbmodel%is_orthogonal) then - if (do_evecs) then - call diagonalise(this%tbsys%H, this%evals, this%evecs, ignore_symmetry = .true., error = diag_error) - else - call diagonalise(this%tbsys%H, this%evals, ignore_symmetry = .true., error = diag_error) - end if - else - if (do_evecs) then - call diagonalise(this%tbsys%H, this%tbsys%S, this%evals, this%evecs, ignore_symmetry = .true., error = diag_error) - else - call diagonalise(this%tbsys%H, this%tbsys%S, this%evals, ignore_symmetry = .true., error = diag_error) - endif - endif - - if (diag_error /= 0) then - if (this%mpi%my_proc == 0) then - call write(this%at, "atom_dump_bad_diagonalise."//mpi_id()//".xyz") - endif - RAISE_ERROR_WITH_KIND(diag_error, "TB_solve_diag got error " // diag_error // " from diagonalise", error) - endif - - if (this%tbsys%scf%active) then - call calc_E_fillings(this, use_fermi_e, fermi_E, AF, w_n) - call calc_dm_from_evecs(this) - call calc_local_orbital_num(this, scf_orbital_n) - if (this%tbsys%noncollinear) call calc_local_orbital_mom(this, scf_orbital_m) - scf_converged = update_orb_local_pot(this%tbsys, this%at, iter, w_n, scf_orbital_n, scf_orbital_m) - else - scf_converged = .true. - endif - iter = iter + 1 - - if (current_verbosity() >= PRINT_VERBOSE) then - if (this%tbsys%scf%active) then - if (assign_pointer(this%at, 'local_N', local_N) .or. assign_pointer(this%at, 'local_mom', local_mom) .or. & - assign_pointer(this%at, 'local_pot', local_pot)) then - call scf_get_atomic_n_mom(this%tbsys, local_N, local_mom, local_pot) - endif - if (get_value(this%at%params, 'global_N', global_N)) then - call scf_get_global_N(this%tbsys, global_N) - call set_value(this%at%params, 'global_N', global_N) - endif - endif - call write(this%at, 'stdout', prefix="SCF_ITER_"//iter) - endif ! VERBOSE - - end do - - if (this%tbsys%scf%active) then - if (assign_pointer(this%at, 'local_N', local_N) .or. assign_pointer(this%at, 'local_mom', local_mom) .or. & - assign_pointer(this%at, 'local_pot', local_pot)) then - call scf_get_atomic_n_mom(this%tbsys, local_N, local_mom, local_pot) - endif - if (get_value(this%at%params, 'global_N', global_N)) then - call scf_get_global_N(this%tbsys, global_N) - call set_value(this%at%params, 'global_N', global_N) - endif - endif - - if (associated(scf_orbital_n)) deallocate(scf_orbital_n) - if (associated(scf_orbital_m)) deallocate(scf_orbital_m) - - if (.not. scf_converged) then - call print("WARNING: TB_solve_diag failed to converge SCF in TB_solve_diag", PRINT_ALWAYS) - endif - - if (this%tbsys%scf%active .and. scf_converged ) call print("TB SCF iterations converged") -end subroutine TB_solve_diag - -subroutine TB_calc(this, at, energy, local_e, forces, virial, local_virial, args_str, & - use_fermi_E, fermi_E, fermi_T, band_width, AF, dH, dS, index, error) - - type(TB_type), intent(inout) :: this - type(Atoms), intent(inout) :: at - real(dp), intent(out), optional :: energy - real(dp), intent(out), optional :: local_e(:) - real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) - real(dp), intent(out), optional :: virial(3,3) - character(len=*), intent(in), optional :: args_str - logical, optional :: use_fermi_E - real(dp), intent(inout), optional :: fermi_E, fermi_T, band_width - type(ApproxFermi), intent(inout), optional :: AF - real(dp), optional, intent(inout), dimension(:,:,:,:) :: dH - real(dp), optional, intent(inout), dimension(:,:,:,:) :: dS - integer, optional, intent(in) :: index - integer, intent(out), optional :: error - - real(dp) :: my_energy - logical :: my_use_Fermi_E - real(dp) :: my_Fermi_E, my_Fermi_T, my_band_width - character(len=STRING_LENGTH) :: solver_arg - logical :: noncollinear, spinpol_no_scf, use_prev_charge, do_evecs - type(ApproxFermi) :: my_AF - logical :: do_at_local_N - real(dp), pointer :: local_N_p(:) - - type(Dictionary) :: params - logical :: has_atom_mask_name - character(STRING_LENGTH) :: atom_mask_name - real(dp) :: r_scale, E_scale - logical :: do_rescale_r, do_rescale_E - - INIT_ERROR(error) - - call system_timer("TB_calc") - call system_timer("TB_calc/prep") - - if (present(args_str)) then - this%calc_args_str = args_str - call initialise(params) - call param_register(params, 'solver', 'DIAG', solver_arg, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'noncollinear', 'F', noncollinear, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'spinpol_no_scf', 'F', spinpol_no_scf, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'use_prev_charge', 'F', use_prev_charge, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'do_at_local_N', 'F', do_at_local_N, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'do_evecs', 'F', do_evecs, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") - call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TB_Calc args_str')) then - call system_abort("TB_calc failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - - call set_type(this%tbsys%scf, args_str) - - if(has_atom_mask_name) then - RAISE_ERROR('TB_Calc: atom_mask_name found, but not supported', error) - endif - if (do_rescale_r .or. do_rescale_E) then - RAISE_ERROR("TB_Calc: rescaling of potential with r_scale and E_scale not implemented!", error) - end if - else - this%calc_args_str = '' - solver_arg = 'DIAG' - noncollinear = .false. - spinpol_no_scf = .false. - do_evecs = .false. - use_prev_charge = .false. - do_at_local_N = .false. - endif - call setup_atoms(this, at, noncollinear, spinpol_no_scf, args_str, error=error) - PASS_ERROR(error) - - if( present(local_virial) ) then - RAISE_ERROR("TB_Calc: local_virial calculation requested, but not implemented yet",error) - endif - - if(current_verbosity() > PRINT_NERD) then - call write(this%at, "tb_calc_atomslog.xyz", append=.true.) - end if - - call system_timer("TB_calc/prep") - - ! local_N_p points to at property local_N if do_at_local_N is true and at property local_N is defined - nullify(local_N_p) - if (do_at_local_N) then - if (.not. assign_pointer(this%at, 'local_N', local_N_p)) & - call system_abort("TB_calc got do_at_local_N=T, but failed to find local_N property") - endif - - select case (trim(solver_arg)) - case ('DIAG') - call system_timer("TB_calc/DIAG_calc_diag") - my_energy = calc_diag(this, use_fermi_E, fermi_E, fermi_T, local_e, local_N_p, forces, virial, & - use_prev_charge = use_prev_charge, AF=AF, do_evecs = do_evecs, dH=dH, dS=dS, index=index, error=error) - call system_timer("TB_calc/DIAG_calc_diag") - case ('GF') - call system_timer("TB_calc/GF_calc_GF") - if (present(virial)) call system_abort("No virial with GF (yet?)") - my_energy = calc_GF(this, use_fermi_E, fermi_E, fermi_T, band_width, local_e, local_N_p, forces, AF) - call system_timer("TB_calc/GF_calc_GF") - case ('DIAG_GF') - call system_timer("TB_calc/DIAG_GF") - call system_timer("TB_calc/DIAG_GF_prep") - if (present(virial)) call system_abort("No virial with GF (yet?)") - - if (.not. has_Fermi_T(my_fermi_T, this%tbsys%tbmodel, Fermi_T, this%calc_args_str)) & - call system_abort("TB_calc called without Fermi_T for model without default Fermi_T") - if (.not. has_band_width(my_band_width, this%tbsys%tbmodel, band_width, this%calc_args_str)) & - call system_abort("TB_calc called without band_width for model without default band_width") - - ! default to constant mu, for now at least - my_use_fermi_E = optional_default(.true., use_fermi_E) - - if (my_use_Fermi_E .and. .not. present(AF)) then - if (.not. has_Fermi_E(my_Fermi_E, this%tbsys%tbmodel, Fermi_E, this%calc_args_str)) & - call system_abort("Called TB_calc with use_Fermi_E but neither AF nor Fermi_E nor TB Model with default Fermi_E") - endif - - if (present(AF)) then - my_AF = AF - else - call Initialise(my_AF, my_Fermi_E, my_Fermi_T, my_band_width) - end if - call system_timer("TB_calc/DIAG_GF_prep") - - call system_timer("TB_calc/DIAG_GF_calc_diag") - my_energy = calc_diag(this, my_use_fermi_E, local_e = local_e, & - local_N = local_N_p, use_prev_charge = use_prev_charge, do_evecs = do_evecs, & - AF = my_AF) - call system_timer("TB_calc/DIAG_GF_calc_diag") - if (present(forces)) then - call system_timer("TB_calc/DIAG_GF_calc_GF") - my_energy = calc_GF(this, use_fermi_E = .true., local_e = local_e, local_N = local_N_p, forces = forces, AF = my_AF) - call system_timer("TB_calc/DIAG_GF_calc_GF") - endif - call finalise(my_AF) - call system_timer("TB_calc/DIAG_GF") - case default - call system_abort("TB_calc confused by args '" // trim(solver_arg) // "'") - end select - - if (present(energy)) energy = my_energy - call system_timer("TB_calc") - - this%calc_done = .true. - - call copy_atoms_fields(this%at, at) - - -end subroutine TB_calc - -subroutine copy_atoms_fields(from_at, to_at) - type(Atoms), intent(in):: from_at - type(Atoms), intent(inout):: to_at - - real(dp), pointer :: from_R1(:), to_R1(:), from_R2(:,:), to_R2(:,:) - real(dp) :: from_R - - if (assign_pointer(from_at, 'local_N', from_R1) .and. & - assign_pointer(to_at, 'local_N', to_R1)) then - to_R1 = from_R1 - endif - if (assign_pointer(from_at, 'local_mom', from_R2) .and. & - assign_pointer(to_at, 'local_mom', to_R2)) then - to_R2 = from_R2 - endif - if (assign_pointer(from_at, 'local_N', from_R1) .and. & - assign_pointer(to_at, 'local_N', to_R1)) then - to_R1 = from_R1 - endif - if (assign_pointer(from_at, 'local_E', from_R1) .and. & - assign_pointer(to_at, 'local_E', to_R1)) then - to_R1 = from_R1 - endif - if (assign_pointer(from_at, 'local_pot', from_R1) .and. & - assign_pointer(to_at, 'local_pot', to_R1)) then - to_R1 = from_R1 - endif - - if (get_value(from_at%params, 'global_dN', from_R)) then - call set_value(to_at%params, 'global_dN', from_R) - endif - -end subroutine copy_atoms_fields - -function TB_calc_diag(this, use_fermi_E, fermi_E, fermi_T, local_e, local_N, forces, virial, use_prev_charge, AF, do_evecs, dH, dS, index, error) - type(TB_type), intent(inout) :: this - logical, optional :: use_fermi_E - real(dp), intent(inout), optional :: fermi_E, fermi_T - real(dp), intent(out), target, optional :: local_e(:) - real(dp), intent(out), pointer, optional :: local_N(:) - real(dp), intent(out), optional :: forces(:,:) - real(dp), intent(out), optional :: virial(3,3) - logical, optional, intent(in) :: use_prev_charge - type(ApproxFermi), intent(inout), optional :: AF - logical, optional :: do_evecs - real(dp), optional, intent(inout), dimension(:,:,:,:) :: dH - real(dp), optional, intent(inout), dimension(:,:,:,:) :: dS - integer, optional, intent(in) :: index - integer, intent(out), optional :: error - real(dp) :: TB_calc_diag - - real(dp), allocatable :: forces_scf(:,:) - real(dp) :: virial_scf(3,3) - real(dp), allocatable :: local_e_scf(:), local_e_rep(:) - real(dp) :: global_e_scf - real(dp), pointer :: u_local_e(:) - real(dp) :: u_e, u_e_scf, u_e_rep - integer :: i - logical :: u_do_evecs, do_local_N, do_local_e - - type(Dictionary) :: params - - real(dp), pointer :: w_e(:) - real(dp), pointer :: w_n(:) - - INIT_ERROR(error) - - call system_timer("TB_calc_diag") - call system_timer("TB_calc_diag/prep") - call print("TB_calc_diag starting", PRINT_VERBOSE) - - if (.not. assign_pointer(this%at, "weight", w_e)) then - nullify(w_e) - else - call print("Using weight from atom properties for w_e", PRINT_VERBOSE) - endif - if (.not. assign_pointer(this%at, "weight_n", w_n)) then - if (.not. assign_pointer(this%at, "weight", w_n)) then - nullify(w_n) - else - call print("Using weight from atom properties for w_n", PRINT_VERBOSE) - endif - else - call print("Using weight_n from atom properties for w_n", PRINT_VERBOSE) - endif - - if (associated(w_e) .and. (present(forces) .or. present(virial))) then - if (maxval(w_e) .ne. 1.0_dp .or. minval(w_e) .ne. 1.0_dp) then - call system_abort ("TB_calc_diag can't do forces or virial of weighted energy") - endif - endif - - do_local_N = .false. - if (present(local_N)) then - if (associated(local_N)) then - if (size(local_N) == this%at%N) then - do_local_N = .true. - else - if (size(local_N) /= 0) & - call system_abort("TB_calc_diag called with size(local_N)="//size(local_N)// & - " not 0, and not matching this%at%N="//this%at%N) - endif - endif - endif - do_local_e = .false. - if (present(local_e)) then - if (size(local_e) == this%at%N) then - do_local_e = .true. - else - if (size(local_e) /= 0) & - call system_abort("TB_calc_diag called with size(local_e)="//size(local_e)// & - " not 0, and not matching this%at%N="//this%at%N) - endif - endif - - u_do_evecs = optional_default(.false., do_evecs) .or. present(forces) .or. present(virial) .or. & - do_local_e .or. associated(w_e) .or. & - do_local_N .or. associated(w_n) .or. this%tbsys%scf%active - if (u_do_evecs) call print("evecs are needed", PRINT_VERBOSE) - - if (.not. has_fermi_T(this%fermi_T, this%tbsys%tbmodel, fermi_T, this%calc_args_str)) & - call system_abort("TB_calc_diag called without fermi_T for a TB model without default fermi T") - call system_timer("TB_calc_diag/prep") - - call initialise(params) - call param_register(params, 'fermi_e_precision', ''//this%fermi_E_precision, this%fermi_E_precision, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, this%calc_args_str, ignore_unknown=.true.,task='TB_calc_diag fermi_e_precision')) then - call system_abort("TBModel_has_fermi_e failed to parse this%calc_args_str='"//trim(this%calc_args_str)//"'") - endif - call finalise(params) - - call system_timer("TB_calc_diag/solve_diag") - call print("TB_calc_diag solve_diag", PRINT_VERBOSE) - call solve_diag(this, u_do_evecs, use_fermi_e, Fermi_E, w_n, use_prev_charge=use_prev_charge, AF=AF, error=error) - call system_timer("TB_calc_diag/solve_diag") - PASS_ERROR_WITH_INFO("TB_calc got error from solve_diag", error) - - call system_timer("TB_calc_diag/calc_EFV") - allocate(local_e_rep(this%at%N)) - do i=1, this%at%N - local_e_rep(i) = get_local_rep_E(this%tbsys%tbmodel, this%at, i) - end do - - if (present(fermi_T)) then - if (fermi_T .fne. this%fermi_T) then - this%fermi_T = fermi_T - endif - endif - if (present(fermi_E)) then - if (fermi_E .fne. this%fermi_E) then - this%fermi_E = fermi_E - endif - endif - - call system_timer("TB_calc_diag/calc_EFV/calc_E_fillings") - call calc_E_fillings(this, use_fermi_E, fermi_E, AF, w_n) - call system_timer("TB_calc_diag/calc_EFV/calc_E_fillings") - if (present(AF)) then - call print("TB_calc_diag using AF Fermi_E " // AF%Fermi_E // " band_width " // AF%band_width // " n_poles " // AF%n_poles, PRINT_VERBOSE) - else - call print("TB_calc_diag has Fermi_E " // this%Fermi_E // " Fermi_T " // this%Fermi_T, PRINT_VERBOSE) - endif - - if (do_local_e .or. associated(w_e) .or. do_local_N .or. associated(w_n)) then - call print("TB_calc_diag calculating per atom stuff", PRINT_VERBOSE) - call system_timer("TB_calc_diag/calc_EFV/calc_dm_for_local_stuff") - call calc_dm_from_evecs(this, .false.) - call system_timer("TB_calc_diag/calc_EFV/calc_dm_for_local_stuff") - - call system_timer("TB_calc_diag/calc_EFV/calc_local_stuff") - if (do_local_e) then - u_local_e => local_e - else - allocate(u_local_e(this%at%N)) - endif - allocate(local_e_scf(this%at%N)) - - call calc_local_atomic_energy(this, u_local_e) - call local_scf_e_correction(this%tbsys, this%at, local_e_scf, global_e_scf, w_n) - call print("TB_calc_diag got sum(local_energies) eval " // sum(u_local_e) // & - " scf " // sum(local_e_scf) // " rep " // sum(local_e_rep), PRINT_VERBOSE) - u_local_e = u_local_e + local_e_scf + local_e_rep - - if (associated(w_e)) then - u_local_e = u_local_e + global_e_scf/sum(w_e) - TB_calc_diag = sum(w_e*u_local_e) - else - u_local_e = u_local_e + global_e_scf/size(u_local_e) - TB_calc_diag = sum(u_local_e) - endif - - deallocate(local_e_scf) - if (.not. present(local_e)) deallocate(u_local_e) - - if (do_local_N) call calc_local_atomic_num(this, local_N) - - call system_timer("TB_calc_diag/calc_EFV/calc_local_stuff") - else ! no local E or N required - call system_timer("TB_calc_diag/calc_EFV/E_calc") - u_e = ksum_dup(this%tbsys%kpoints, sum(this%evals%data_d*this%E_fillings%data_d,dim=1)) - u_e_rep = sum(local_e_rep) - u_e_scf = scf_e_correction(this%tbsys, this%at, w_n) - call print("TB_calc_diag got energies eval " // u_e // " scf " // u_e_scf // " rep " // u_e_rep, PRINT_VERBOSE) - TB_calc_diag = u_e + u_e_rep + u_e_scf - call system_timer("TB_calc_diag/calc_EFV/E_calc") - endif - - if (present(forces) .or. present(virial)) then - call print("TB_calc_diag calculating forces", PRINT_VERBOSE) - call calc_F_fillings(this, .not. this%tbsys%tbmodel%is_orthogonal, AF) - call system_timer("TB_calc_diag/calc_EFV/calc_dm_for_FV") - call calc_dm_from_evecs(this, .true.) - call system_timer("TB_calc_diag/calc_EFV/calc_dm_for_FV") - if (present(forces)) then - call system_timer("TB_calc_diag/calc_EFV/calculate_forces") - forces = calculate_forces_diag(this, dH, dS, index) - allocate(forces_scf(3,this%at%N)) - forces_scf = scf_f_correction(this%tbsys, this%at) - forces = forces + forces_scf - deallocate(forces_scf) - call system_timer("TB_calc_diag/calc_EFV/calculate_forces") - end if - if (present(virial)) then - call system_timer("TB_calc_diag/calc_EFV/calculate_virial") - virial = calculate_virial_diag(this) - virial_scf = scf_virial_correction(this%tbsys, this%at) - virial = virial + virial_scf - call system_timer("TB_calc_diag/calc_EFV/calculate_virial") - end if - endif - - call system_timer("TB_calc_diag/calc_EFV") - call system_timer("TB_calc_diag") - call print("TB_calc_diag ending", PRINT_VERBOSE) - -end function TB_calc_diag - - -function TB_calc_GF(this, use_fermi_E, fermi_E, fermi_T, band_width, local_e, local_N, forces, AF, SelfEnergy) - type(TB_type), intent(inout) :: this - logical, intent(in), optional :: use_fermi_E - real(dp), intent(inout), optional :: fermi_E - real(dp), intent(in), optional :: fermi_T, band_width - real(dp), intent(out), target, optional :: local_e(:) - real(dp), intent(out), pointer, optional :: local_N(:) - real(dp), intent(out), optional :: forces(:,:) - type(ApproxFermi), intent(inout), optional, target :: AF - type(TBMatrix), intent(in), optional :: SelfEnergy(:) - real(dp) :: TB_calc_GF - - logical find_new_fermi_E - type(ApproxFermi), pointer :: u_AF - logical local_u_AF - real(dp), allocatable :: forces_scf(:,:) - - integer i - - real(dp), pointer :: u_local_e(:) - real(dp), allocatable :: local_e_rep(:), local_e_scf(:) - real(dp) :: global_e_scf - - real(dp), pointer :: w_e(:) - real(dp), pointer :: w_n(:) - real(dp) :: use_band_width - - logical :: do_local_e, do_local_N - - call system_timer("TB_calc_GF") - call print("TB_calc_GF starting", PRINT_VERBOSE) - - do_local_N = .false. - if (present(local_N)) then - if (associated(local_N)) then - if (size(local_N) == this%at%N) then - do_local_N = .true. - else - if (size(local_N) /= 0) & - call system_abort("TB_calc_diag called with size(local_N)="//size(local_N)// & - " not 0, and not matching this%at%N="//this%at%N) - endif - endif - endif - do_local_e = .false. - if (present(local_e)) then - if (size(local_e) == this%at%N) then - do_local_e = .true. - else - if (size(local_e) /= 0) & - call system_abort("TB_calc_diag called with size(local_e)="//size(local_e)// & - " not 0, and not matching this%at%N="//this%at%N) - endif - endif - - call system_timer("TB_calc_GF_prep") - if (.not. assign_pointer(this%at, "weight", w_e)) then - nullify(w_e) - else - call print("Using weights from atom properties for w_e", PRINT_VERBOSE) - endif - if (.not. assign_pointer(this%at, "weight", w_n)) then - nullify(w_n) - else - call print("Using weights from atom properties for w_n", PRINT_VERBOSE) - endif - - find_new_fermi_E = .false. - if (present(use_fermi_E)) find_new_fermi_E = .not. use_fermi_E - - if (find_new_fermi_E .and. present(forces)) then - call system_abort("TB_calc_GF an't do constant N with forces yet") - endif - - if (.not. find_new_fermi_E .and. (.not. has_fermi_E(this%fermi_e, this%tbsys%tbmodel, fermi_E, this%calc_args_str) .and. & - .not. present(AF))) then - call system_abort("called calc_GF with use_fermi_E but no fermi_E or AF") - endif - - if ((present(fermi_E) .or. present(fermi_T) .or. present(band_width)) .and. present(AF)) then - call system_abort("calc_GF has AF as well as fermi_e, fermi_T, or band_width present - don't know which one to use") - endif - - if (present(AF)) then - u_AF => AF - local_u_AF = .false. - else - allocate(u_AF) - local_u_AF = .true. - endif - - if (find_new_fermi_E) then - call print("TB_calc_GF: finding our own Fermi level", PRINT_VERBOSE) - - if (.not. has_fermi_T(this%fermi_T, this%tbsys%tbmodel, fermi_T, this%calc_args_str)) & - call system_abort("TB_calc_GF called without Fermi_T for TB Model without default Fermi_T") - - if (.not. has_band_width(u_AF%band_width, this%tbsys%tbmodel, band_width, this%calc_args_str)) & - call system_abort("TB_calc_GF called without band_width for TB Model without default band_width") - - !call verbosity_push_increment() - call solve_diag(this, .false., fermi_E = fermi_E, w_n = w_n, AF = u_AF) - !call verbosity_pop() - else - if (has_fermi_E(this%fermi_e, this%tbsys%tbmodel, fermi_E, this%calc_args_str) .and. & - has_fermi_T(this%fermi_T, this%tbsys%tbmodel, fermi_T, this%calc_args_str) .and. & - has_band_width(use_band_width, this%tbsys%tbmodel, band_width, this%calc_args_str)) then - call print("Initialising ApproxFermi using fermi_e " // this%fermi_e // " fermi_T " // this%fermi_T // & - " band_width "// use_band_width, PRINT_VERBOSE) - call Initialise(u_AF, this%Fermi_E, this%fermi_T, use_band_width) - else - call system_abort("find_new_fermi_E is false, but we are missing fermi_e, fermi_T or band_width for Initialise(AF...)") - endif - endif - - call print("TB_calc_diag has Fermi_E " // this%Fermi_E // " Fermi_T " // this%Fermi_T, PRINT_VERBOSE) - - call verbosity_push_decrement() - call print("TB_calc_GF using ApproxFermi:") - call print(u_AF) - call verbosity_pop() - - call Initialise(this%gf, u_AF%z, u_AF%a, this%tbsys) - this%gf%tbsys%scf = this%tbsys%scf - - if (local_u_AF) then - call finalise(u_AF) - endif - call system_timer("TB_calc_GF_prep") - - call system_timer("TB_calc_GF_calc_Gs") - call print("TB_calc_GF calculating Gs", PRINT_VERBOSE) - call calc_Gs(this%gf, this%at, SelfEnergy) - call system_timer("TB_calc_GF_calc_Gs") - - call system_timer("TB_calc_GF_calc_EFV") - call print("TB_calc_GF calculating dm from Gs", PRINT_VERBOSE) - call calc_dm_from_Gs(this%gf) - - call print("TB_calc_GF calculating energy, number", PRINT_VERBOSE) - - if (do_local_e) then - u_local_e => local_e - else - allocate(u_local_e(this%at%N)) - endif - - allocate(local_e_rep(this%at%N)) - allocate(local_e_scf(this%at%N)) - do i=1, this%at%N - local_e_rep(i) = get_local_rep_E(this%tbsys%tbmodel, this%at, i) - end do - - call calc_local_atomic_energy_GF(this, u_local_e) - call local_scf_e_correction(this%tbsys, this%at, local_e_scf, global_e_scf, w_n) - u_local_e = u_local_e + local_e_scf + local_e_rep - - if (associated(w_e)) then - u_local_e = u_local_e + global_e_scf/sum(w_e) - TB_calc_GF = sum(u_local_e*w_e) - else - u_local_e = u_local_e + global_e_scf/size(u_local_e) - TB_calc_GF = sum(u_local_e) - endif - - if (.not. present(local_e)) deallocate(u_local_e) - deallocate(local_e_rep) - deallocate(local_e_scf) - - if (do_local_N) call calc_local_atomic_num_GF(this, local_N) - - if (present(forces)) then - call print("TB_calc_GF calculating forces", PRINT_VERBOSE) - forces = calculate_forces_GF(this, w_e, w_n) - allocate(forces_scf(3,this%at%N)) - forces_scf = scf_f_correction(this%gf%tbsys, this%at) - forces = forces + forces_scf - deallocate(forces_scf) - endif - call system_timer("TB_calc_GF_calc_EFV") - call system_timer("TB_calc_GF") - - call print("TB_calc_GF finished", PRINT_VERBOSE) - -end function TB_calc_GF - -subroutine calc_local_atomic_energy_GF(this, local_e) - type(TB_type), intent(inout) :: this - real(dp), intent(inout) :: local_e(:) - - local_e = local_ksum(this%gf%tbsys%kpoints, atom_orbital_sum(this%gf%tbsys, & - real(partial_TraceMult(this%gf%dm, this%gf%tbsys%H, & - a_H=.true., b_H=.false.)))) - call ksum_distrib_inplace(this%gf%tbsys%kpoints, local_e) -end subroutine calc_local_atomic_energy_GF - -subroutine calc_local_atomic_num_GF(this, local_N) - type(TB_type), intent(inout) :: this - real(dp), intent(inout) :: local_N(:) - - local_N = local_ksum(this%gf%tbsys%kpoints, atom_orbital_sum(this%gf%tbsys, & - real(partial_TraceMult(this%gf%dm, this%gf%tbsys%S, & - a_H=.true., b_H=.false.)))) - call ksum_distrib_inplace(this%gf%tbsys%kpoints, local_N) -end subroutine calc_local_atomic_num_GF - -subroutine calc_local_atomic_energy(this, local_e) - type(TB_type), intent(inout) :: this - real(dp), intent(inout) :: local_e(:) - - local_e = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, & - real(partial_TraceMult(this%dm, this%tbsys%H, & - a_H=.true., b_H=.false.)))) - call ksum_distrib_inplace(this%tbsys%kpoints, local_e) -end subroutine calc_local_atomic_energy - -subroutine calc_local_atomic_num(this, local_N) - type(TB_type), intent(inout) :: this - real(dp), intent(inout) :: local_N(:) - - if (this%tbsys%tbmodel%is_orthogonal) then - local_N = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, Re_diag(this%dm))) - else - local_N = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, & - real(partial_TraceMult(this%dm, this%tbsys%S, & - a_H=.true., b_H=.false.)))) - endif - call ksum_distrib_inplace(this%tbsys%kpoints, local_N) -end subroutine calc_local_atomic_num - -subroutine calc_local_orbital_num(this, local_N) - type(TB_type), intent(inout) :: this - real(dp), intent(inout) :: local_N(:) - - if (this%tbsys%tbmodel%is_orthogonal) then - local_N = local_ksum(this%tbsys%kpoints, Re_diag(this%dm)) - else - local_N = local_ksum(this%tbsys%kpoints, real(partial_TraceMult(this%dm, this%tbsys%S, a_H=.true., b_H=.false.))) - endif - call ksum_distrib_inplace(this%tbsys%kpoints, local_N) -end subroutine calc_local_orbital_num - -subroutine calc_local_orbital_mom(this, local_m) - type(TB_type), intent(inout) :: this - real(dp), intent(inout) :: local_m(:,:) - - integer :: i - complex(dp), allocatable :: local_spinor(:,:,:) - - local_m = 0.0_dp - - if (.not. this%tbsys%noncollinear) then - return - endif - - call fill_matrices(this%tbsys, this%at, need_H=.false., need_S=.true., no_S_spin=.true.) - - allocate(local_spinor(2,2,this%tbsys%N/2)) - - if (this%tbsys%tbmodel%is_orthogonal) then - local_spinor = local_ksum(this%tbsys%kpoints, diag_spinor(this%dm)) - else - local_spinor = local_ksum(this%tbsys%kpoints, partial_TraceMult_spinor(this%dm, this%tbsys%S, a_H=.true., b_H=.false.)) - endif - - do i=1, this%tbsys%N/2 - local_m(1,(i-1)*2+1) = sum(conjg(pauli_sigma(:,:,1))*local_spinor(:,:,i)) - local_m(2,(i-1)*2+1) = sum(conjg(pauli_sigma(:,:,2))*local_spinor(:,:,i)) - local_m(3,(i-1)*2+1) = sum(conjg(pauli_sigma(:,:,3))*local_spinor(:,:,i)) - end do - call ksum_distrib_inplace(this%tbsys%kpoints, local_m) - - deallocate(local_spinor) - - call fill_matrices(this%tbsys, this%at, need_H=.false., need_S=.true., no_S_spin=.false.) - -end subroutine calc_local_orbital_mom - - -function calculate_forces_diag(this, dH, dS, index) result(forces) - type(TB_type), intent(inout) :: this - real(dp) :: forces(3,this%at%N) ! result - real(dp), optional, intent(inout), dimension(:,:,:,:) :: dH - real(dp), optional, intent(inout), dimension(:,:,:,:) :: dS - integer, optional, intent(in) :: index - - logical, allocatable :: od_mask(:), d_mask(:) - - integer i - - if (this%at%cutoff < this%tbsys%tbmodel%cutoff) & - call print ("WARNING: Called calculate_forces_diag with messed up cutoff in atoms: cutoff" // & - this%at%cutoff // " < " // this%tbsys%tbmodel%cutoff) - - forces = 0.0_dp - allocate(od_mask(this%at%N)) - allocate(d_mask(this%at%N)) - - call Setup_deriv_matrices(this%tbsys, this%at) - do i=1, this%at%N - call fill_dmatrices(this%tbsys, this%at, i, diag_mask=d_mask, offdiag_mask=od_mask) - if (current_verbosity() >= PRINT_NERD) then - call print("force dH x "//i) - call print(this%tbsys%dH(1)) - call print("force dH y "//i) - call print(this%tbsys%dH(2)) - call print("force dH z "//i) - call print(this%tbsys%dH(3)) - call print("force dS x "//i) - call print(this%tbsys%dS(1)) - call print("force dS y "//i) - call print(this%tbsys%dS(2)) - call print("force dS z "//i) - call print(this%tbsys%dS(3)) - endif - if (present(dH)) then - call copy(this%tbsys%dH(1), dH(1,i,:,:), index=index) - call copy(this%tbsys%dH(2), dH(2,i,:,:), index=index) - call copy(this%tbsys%dH(3), dH(3,i,:,:), index=index) - endif - if (present(dS)) then - call copy(this%tbsys%dS(1), dS(1,i,:,:), index=index) - call copy(this%tbsys%dS(2), dS(2,i,:,:), index=index) - call copy(this%tbsys%dS(3), dS(3,i,:,:), index=index) - endif - - forces(1,i) = forces(1,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(1), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - forces(2,i) = forces(2,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(2), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - forces(3,i) = forces(3,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(3), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - if (.not. this%tbsys%tbmodel%is_orthogonal) then - forces(1,i) = forces(1,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(1), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - forces(2,i) = forces(2,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(2), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - forces(3,i) = forces(3,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(3), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - endif - end do - - deallocate(od_mask) - deallocate(d_mask) - - call ksum_distrib_inplace(this%tbsys%kpoints, forces) - - do i=1, this%at%N - forces = forces + get_local_rep_E_force(this%tbsys%tbmodel, this%at, i) - end do - -end function calculate_forces_diag - -function calculate_virial_diag(this) result(virial) - type(TB_type), intent(inout) :: this - real(dp) :: virial(3,3) ! result - - logical, allocatable :: od_mask(:), d_mask(:) - - integer i - - if (this%at%cutoff < this%tbsys%tbmodel%cutoff) & - call print ("WARNING: Called calculate_virial_diag with messed up cutoff in atoms: cutoff" // & - this%at%cutoff // " < " // this%tbsys%tbmodel%cutoff) - - virial = 0.0_dp - allocate(od_mask(this%at%N)) - allocate(d_mask(this%at%N)) - - call Setup_deriv_matrices(this%tbsys, this%at) - do i=1, 3 - call fill_dmatrices(this%tbsys, this%at, -i, diag_mask=d_mask, offdiag_mask=od_mask) - - virial(1,i) = virial(1,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(1), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - virial(2,i) = virial(2,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(2), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - virial(3,i) = virial(3,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(3), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - if (.not. this%tbsys%tbmodel%is_orthogonal) then - virial(1,i) = virial(1,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(1), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - virial(2,i) = virial(2,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(2), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - virial(3,i) = virial(3,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(3), & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - endif - end do - - call ksum_distrib_inplace(this%tbsys%kpoints, virial) - do i=1, this%at%N - virial = virial + get_local_rep_E_virial(this%tbsys%tbmodel, this%at, i) - end do - - deallocate(od_mask) - deallocate(d_mask) - -end function calculate_virial_diag - -function calculate_forces_GF(this, w_e, w_n) result (forces) - type(TB_type), intent(inout) :: this - real(dp), intent(in), pointer :: w_e(:), w_n(:) - real(dp) :: forces(3,this%at%N) ! result - - logical, allocatable :: od_mask(:), d_mask(:) - - integer i - - call system_timer("calculate_forces_GF") - - if (this%at%cutoff < this%gf%tbsys%tbmodel%cutoff) & - call print("WARNING: Called calculate_forces_GF with messed up cutoff in atoms: cutoff" // & - this%at%cutoff // " < " // this%gf%tbsys%tbmodel%cutoff) - - call system_timer("calculate_forces_GF_calc_mod_dm") - call calc_mod_dm_from_Gs(this%gf, w_e, w_n) - call system_timer("calculate_forces_GF_calc_mod_dm") - - call system_timer("calculate_forces_GF_Tr") - forces = 0.0_dp - allocate(od_mask(this%at%N)) - allocate(d_mask(this%at%N)) - - call Setup_deriv_matrices(this%gf%tbsys, this%at) - do i=1, this%at%N - call fill_dmatrices(this%gf%tbsys, this%at, i, diag_mask=d_mask, offdiag_mask=od_mask) - - forces(1,i) = forces(1,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_H, this%gf%tbsys%dH(1), & - a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) - forces(2,i) = forces(2,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_H, this%gf%tbsys%dH(2), & - a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) - forces(3,i) = forces(3,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_H, this%gf%tbsys%dH(3), & - a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) - if (.not. this%gf%tbsys%tbmodel%is_orthogonal) then - forces(1,i) = forces(1,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_S, this%gf%tbsys%dS(1), & - a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) - forces(2,i) = forces(2,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_S, this%gf%tbsys%dS(2), & - a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) - forces(3,i) = forces(3,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_S, this%gf%tbsys%dS(3), & - a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) - endif - end do - - deallocate(od_mask) - deallocate(d_mask) - - call system_timer("calculate_forces_GF_Tr") - - call system_timer("calculate_forces_GF_accum") - call ksum_distrib_inplace(this%gf%tbsys%kpoints, forces) - - call system_timer("calculate_forces_GF_scf") - forces = forces + scf_f_correction_GF(this%gf, this%at, w_e, w_n) - call system_timer("calculate_forces_GF_scf") - - do i=1, this%at%N - if (associated(w_e)) then - forces = forces + w_e(i) * get_local_rep_E_force(this%gf%tbsys%tbmodel, this%at, i) - else - forces = forces + get_local_rep_E_force(this%gf%tbsys%tbmodel, this%at, i) - endif - end do - call system_timer("calculate_forces_GF_accum") - call system_timer("calculate_forces_GF") - -end function calculate_forces_GF - -function scf_f_correction_GF(gf, at, w_e, w_n) result(forces) - type(GreensFunctions), intent(inout) :: gf - type(Atoms), intent(in) :: at - real(dp), intent(in), pointer :: w_e(:), w_n(:) - real(dp) :: forces(3,gf%tbsys%N_atoms) - - real(dp), allocatable :: n(:), dn_dr_mat(:,:,:), dgN_dr_vec(:,:) - real(dp), allocatable :: dlpot(:) - real(dp) :: dglobal_pot - real(dp), allocatable :: ww_e(:) - integer N_atoms - - type(TBMatrix) :: sp_Stwid, sp_S - logical, allocatable :: d_mask(:), od_mask(:) - - integer i, j - - if (at%cutoff < gf%tbsys%tbmodel%cutoff) & - call print ("WARNING: Called scf_f_correction_GF with messed up cutoff in atoms: cutoff" // & - at%cutoff // " < " // gf%tbsys%tbmodel%cutoff) - - N_atoms = gf%tbsys%N_atoms - - allocate(d_mask(N_atoms)) - allocate(od_mask(N_atoms)) - - forces = 0.0_dp - if (.not. gf%tbsys%scf%active) then - return - endif - - if (size(gf%tbsys%scf%terms) /= 1) then - call system_abort("GreensFunc_scf_f_correction_GF not yet implemented for more than 1 type of SCF defined") - endif - - if (gf%tbsys%scf%terms(1)%type == SCF_LCN .or. gf%tbsys%scf%terms(1)%type == SCF_GCN) then - call system_abort("GreensFunc_scf_f_correction_GF not yet implemented for local or global charge neutrality") - endif - - allocate(dlpot(gf%tbsys%N)) - - call Initialise(sp_Stwid, at, gf%tbsys%first_orb_of_atom, gf%tbsys%n_matrices, gf%tbsys%complex_matrices) - call Initialise(sp_S, at, gf%tbsys%first_orb_of_atom, gf%tbsys%n_matrices, gf%tbsys%complex_matrices) - - call fill_these_matrices(gf%tbsys, at, do_S = .true., S = sp_S) - - allocate(n(gf%tbsys%N)) - n = local_ksum(gf%tbsys%kpoints, real(partial_TraceMult(gf%dm, gf%tbsys%S, a_H=.true., b_H=.false.))) - call ksum_distrib_inplace(gf%tbsys%kpoints, n) - - if (gf%tbsys%scf%terms(1)%type == SCF_LOCAL_U .or. & - gf%tbsys%scf%terms(1)%type == SCF_NONLOCAL_U_DFTB .or. & - gf%tbsys%scf%terms(1)%type == SCF_NONLOCAL_U_NRL_TB) then - - allocate(dn_dr_mat(3,N_atoms,gf%tbsys%N)) - call ALLOC_TRACE("scf_f_correction_GF dn_dr_mat", size(dn_dr_mat)*REAL_SIZE) - - ! calculate derivative of dn w.r.t r - call calc_dn_dr_mat(gf, at, dn_dr_mat) - - ! calculate correction to forces using dn_dr_mat - - ! correct forces by derivative of shift of Hamiltonian - do i=1, N_atoms - call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) - do j=1, 3 - call add_term_d2SCFE_dn2_times_vec(gf%tbsys%scf%terms(1), gf%tbsys, dn_dr_mat(j,i,:), dlpot) - - call multDiagRL(sp_Stwid, sp_S, dlpot) - forces(j,i) = forces(j,i) + local_ksum(gf%tbsys%kpoints, real(TraceMult(gf%mod_dm_H, sp_Stwid, a_H=.false., b_H=.true.))) - - ! Tr [ mod_dm 0.5 (lpot dS lpot) ] was necessary in SIMPLE (C+) version, since dH_ij/dr didn't - ! include 0.5 ( lpot(i) + lpot(j) dS_ij/dr. Here it does include it, so this - ! isn't necessary - - end do ! j=1, 3 - end do ! i=1, N_atoms - call ksum_distrib_inplace(gf%tbsys%kpoints, forces) - - call add_term_dscf_e_correction_dn(gf%tbsys%scf%terms(1), gf%tbsys, dlpot) - - allocate(ww_e(gf%tbsys%N)) - if (associated(w_e)) then - ww_e = atom_orbital_spread(gf%tbsys, w_e) - else - ww_e = 1.0_dp - endif - - ! correct forces by derivative of double counting terms - do i=1, N_atoms - do j=1, 3 - forces(j,i) = forces(j,i) - sum(ww_e(:)*dlpot(:)*dn_dr_mat(j,i,:)) - end do - end do - - call ALLOC_TRACE("scf_f_correction_GF dn_dr_mat", size(dn_dr_mat)*REAL_SIZE) - deallocate(dn_dr_mat) - - else ! global U - - allocate(dgN_dr_vec(3,N_atoms)) - - if (.not. associated(w_n)) & - call system_abort("called scf_f_correction_GF with GLOBAL_U but no global_at_weight") - - call calc_dgN_dr_vec(gf, at, dgN_dr_vec, w_n, sp_S, sp_Stwid) - - do i=1, at%N - call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) - do j=1, 3 - call add_term_d2SCFE_dgNdn(gf%tbsys%scf%terms(1), gf%tbsys, w_n, dlpot) - dlpot = dlpot*dgN_dr_vec(j,i) - - call multDiagRL(sp_Stwid, sp_S, dlpot) - forces(j,i) = forces(j,i) + local_ksum(gf%tbsys%kpoints, real(TraceMult(gf%mod_dm_H, sp_Stwid, a_H=.false., b_H=.true.))) - - ! Tr [ mod_dm 0.5 (lpot dS lpot) ] was necessary in SIMPLE (C+) version, since dH_ij/dr didn't - ! include 0.5 ( lpot(i) + lpot(j) dS_ij/dr. Here we do, so this - ! isn't necessary - - end do ! j=1, 3 - end do ! i=1, N_atoms - call ksum_distrib_inplace(gf%tbsys%kpoints, forces) - - call add_term_dscf_e_correction_dgN(gf%tbsys%scf%terms(1), dglobal_pot) - - ! correct forces by derivative of double counting terms - forces(:,:) = forces(:,:) - dglobal_pot*dgN_dr_vec(:,:) - - deallocate(dgN_dr_vec) - - endif ! local or global u - - call finalise(sp_Stwid) - call finalise(sp_S) - - deallocate(d_mask) - deallocate(od_mask) - -end function scf_f_correction_GF - -subroutine calc_dn_dr_mat(gf, at, dn_dr_mat) - type(GreensFunctions), intent(inout) :: gf - type(Atoms), intent(in) :: at - real(dp), intent(out) :: dn_dr_mat(:,:,:) - - type(TBMatrix) :: M2_raw - type(MatrixD) :: M2, M2inv - integer N_atoms, N_eff - - real(dp), allocatable :: dn0_dr_mat(:,:,:), t_dn0_dr_mat(:,:,:) - real(dp), allocatable :: dn0_dr(:) - type(TBMatrix) :: GS, G_dAdr, GU, GSU, SGS_T, GS_T - complex(dp) :: a, az - - real(dp), allocatable :: U_spread(:), gamma_spread(:,:) - integer ip, i, j, ii - logical, allocatable :: d_mask(:), od_mask(:) - - if (at%cutoff < gf%tbsys%tbmodel%cutoff) & - call print ("WARNING: Called calc_dn_dr_mat with messed up cutoff in atoms: cutoff" // & - at%cutoff // " < " // gf%tbsys%tbmodel%cutoff) - - N_eff = gf%tbsys%N - - allocate(d_mask(N_atoms)) - allocate(od_mask(N_atoms)) - - if (allocated(gf%tbsys%scf%terms(1)%gamma)) then - allocate(gamma_spread(gf%tbsys%N,gf%tbsys%N)) - call atom_orbital_spread_mat(gf%tbsys, gf%tbsys%scf%terms(1)%gamma, gamma_spread) - endif - if (allocated(gf%tbsys%scf%terms(1)%U)) then - allocate(U_spread(gf%tbsys%N)) - U_spread = atom_orbital_spread(gf%tbsys, gf%tbsys%scf%terms(1)%U) - endif - - allocate(dn0_dr_mat(3,N_atoms,N_eff)) - dn0_dr_mat = 0.0_dp - - call Initialise(M2_raw, gf%tbsys%S%N, gf%tbsys%S%n_matrices, .false.) - call Initialise(M2, N_eff) - call Initialise(M2inv, N_eff) - call zero(M2_raw) - - do ip=1, gf%N_G - if (ip == 1) then - allocate(t_dn0_dr_mat(3,N_atoms,N_eff)) - call ALLOC_TRACE("calc_dn_dr_mat t_dn0_dr_mat",size(t_dn0_dr_mat)*REAL_SIZE) - call Initialise(GS, gf%G(1)) - call Initialise(GS_T, gf%G(1)) - call Initialise(G_dAdr, gf%G(1)) - call Initialise(SGS_T, gf%G(1)) - call Initialise(GU, gf%G(1)) - call Initialise(GSU, gf%G(1)) - allocate(dn0_dr(N_eff)) - endif - - t_dn0_dr_mat = 0.0_dp - - if (.not. gf%tbsys%complex_matrices) then ! factor of 2.0, instead of doing G(z) and G(conjg(z)) separately - a = 2.0_dp * gf%a(ip) - az = 2.0_dp * gf%a(ip)*gf%z(ip) - else - a = gf%a(ip) - az = gf%a(ip)*gf%z(ip) - endif - - call matrix_product_sub(GS, gf%G(ip), gf%tbsys%S) - - do i=1, at%N - ! this version of fill_dmatrices returns scf-local-potential-shifted - ! dH (i.e. dH(i,j) + 0.5(lpot(i)+lpot(j))dS(i,j) - ! SIMPLE (C+) version didn't give shifted dH, and that contribution to dn/dr - ! was accounted for in "M1". This version doesn't need that - - call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) - do j=1, 3 - ! Tr [ rho dS/dr WI ] - if (.not. gf%tbsys%tbmodel%is_orthogonal) then - if (ip == 1 .and. gf%mpi_across_poles%my_proc == 0) then - dn0_dr = local_ksum(gf%tbsys%kpoints, & - real(partial_TraceMult(gf%dm, gf%tbsys%dS(j), a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - call ksum_distrib_inplace(gf%tbsys%kpoints, dn0_dr) - do ii=1, N_eff - !NB sign determined empirically :( - t_dn0_dr_mat(j,i,ii) = -dn0_dr(ii) - end do - end if - end if - - dn0_dr = 0.0_dp - - ! Tr [ drho0/dr S WI ] = Tr [ sum_i ( a_i z_i G_i dS/dr G_i - a_i G_i dH0/dr G_i ) S WI = - ! Tr [ sum_i a_i z_i G_i dS/dr G_i S WI - sum_i a_i G_i dH0/dr G_i S WI - if (.not. gf%tbsys%tbmodel%is_orthogonal) then - call matrix_product_sub(G_dAdr, gf%G(ip), gf%tbsys%dS(j), diag_mask=d_mask, offdiag_mask=od_mask) - - dn0_dr = dn0_dr + real(az*local_ksum(gf%tbsys%kpoints, partial_TraceMult(G_dAdr, GS))) - endif - - call matrix_product_sub(G_dAdr, gf%G(ip), gf%tbsys%dH(j), diag_mask=d_mask, offdiag_mask=od_mask) - - dn0_dr = dn0_dr - real(a*local_ksum(gf%tbsys%kpoints, partial_TraceMult(G_dAdr, GS))) - - call ksum_distrib_inplace(gf%tbsys%kpoints, dn0_dr) - - ! factor of 2 folded into a and az (or explicit evaluation of G(conjg(z))) - t_dn0_dr_mat(j,i,:) = t_dn0_dr_mat(j,i,:) - dn0_dr(:) - - end do ! j - end do ! i - - call transpose_sub(GS_T, GS) - - ! (SGS)^T = (S GS)^T = (GS)^T S^T - call matrix_product_sub(SGS_T, GS_T, gf%tbsys%S, A_transpose = .false., B_transpose = .true.) - - if (allocated(gamma_spread)) then - call matrix_product_sub(GU, gf%G(ip), gamma_spread) - else - call multDiag(GU, gf%G(ip), U_spread) - endif - - if (allocated(gamma_spread)) then - call matrix_product_sub(GSU, GS, gamma_spread) - else - call multDiag(GSU, GS, U_spread) - endif - - ! factor of 0.5 to compensate for factor of 2 in a (or explicit eval of G(conjg(z)) - ! OMP critical - call accum_scaled_elem_product(GU, SGS_T, 0.5_dp*a, M2_raw) - call accum_scaled_elem_product(GSU, GS_T, 0.5_dp*a, M2_raw) - - ! OMP critical - dn0_dr_mat = dn0_dr_mat + t_dn0_dr_mat - - if (gf%tbsys%complex_matrices) then - - t_dn0_dr_mat = 0.0_dp - - a = conjg(gf%a(ip)) - az = conjg(gf%a(ip)*gf%z(ip)) - - call matrix_product_sub(GS, gf%G_conjg(ip), gf%tbsys%S) - - do i=1, at%N - ! this version of fill_dmatrices returns scf-local-potential-shifted - ! dH (i.e. dH(i,j) + 0.5(lpot(i)+lpot(j))dS(i,j) - ! SIMPLE (C+) version didn't give shifted dH, and that contribution to dn/dr - ! was accounted for in "M1". This version doesn't need that - - call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) - do j=1, 3 - - dn0_dr = 0.0_dp - - ! Tr [ drho0/dr S WI ] = Tr [ sum_i ( a_i z_i G_i dS/dr G_i - a_i G_i dH0/dr G_i ) S WI = - ! Tr [ sum_i a_i z_i G_i dS/dr G_i S WI - sum_i a_i G_i dH0/dr G_i S WI - if (.not. gf%tbsys%tbmodel%is_orthogonal) then - call matrix_product_sub(G_dAdr, gf%G_conjg(ip), gf%tbsys%dS(j), diag_mask=d_mask, offdiag_mask=od_mask) - - dn0_dr = dn0_dr + real(az*local_ksum(gf%tbsys%kpoints, partial_TraceMult(G_dAdr, GS))) - endif - - call matrix_product_sub(G_dAdr, gf%G_conjg(ip), gf%tbsys%dH(j), diag_mask=d_mask, offdiag_mask=od_mask) - - dn0_dr = dn0_dr - real(a*local_ksum(gf%tbsys%kpoints, partial_TraceMult(G_dAdr, GS))) - call ksum_distrib_inplace(gf%tbsys%kpoints, dn0_dr) - - ! factor of 2 folded into a and az (or explicit evaluation of G(conjg(z))) - t_dn0_dr_mat(j,i,:) = t_dn0_dr_mat(j,i,:) - dn0_dr(:) - - end do ! j - end do ! i - - call transpose_sub(GS_T, GS) - - ! (SGS)^T = S^T (GS)^T - call matrix_product_sub(SGS_T, GS_T, gf%tbsys%S, A_transpose = .false., B_transpose = .true.) - - if (allocated(gamma_spread)) then - call matrix_product_sub(GU, gf%G_conjg(ip), gamma_spread) - else - call multDiag(GU, gf%G_conjg(ip), U_spread) - endif - - if (allocated(gamma_spread)) then - call matrix_product_sub(GSU, GS, gamma_spread) - else - call multDiag(GSU, GS, U_spread) - endif - - ! factor of 0.5 to compensate for factor of 2 in a (or explicit eval of G(conjg(z)) - ! OMP critical - call accum_scaled_elem_product(GU, SGS_T, 0.5_dp*a, M2_raw) - call accum_scaled_elem_product(GSU, GS_T, 0.5_dp*a, M2_raw) - - ! OMP critical - dn0_dr_mat = dn0_dr_mat + t_dn0_dr_mat - - endif ! non-gamma - end do ! ip = 1..N_G - - call ksum_atom_orbital_sum_mat(gf%tbsys, M2_raw, M2) - - call Gsum_distrib_inplace(gf, dn0_dr_mat) - call Gsum_distrib_inplace(gf, M2) - - ! dn[I]/dr = dn0[I]/dr + sum_M M2[I][M] dn[M]/dr - ! x = v0 + M.x - ! x - M.x = v0 - ! (I-M) . x = v0 - ! x = (I-M)^-1 . v0 - - !NB sign determined empirically - !NB call scale(M2, -1.0_dp) - call add_identity(M2) - call inverse(M2, M2inv, .false.) - - do i=1, at%N - do j=1, 3 - dn_dr_mat(j,i,:) = M2inv%data .mult. dn0_dr_mat(j,i,:) - end do - end do - - call finalise(M2_raw) - call finalise(M2) - call finalise(M2inv) - - call Finalise(GS) - call Finalise(GS_T) - call Finalise(G_dAdr) - call Finalise(SGS_T) - call Finalise(GU) - call Finalise(GSU) - - call DEALLOC_TRACE("calc_dn_dr_mat gamma_spread", size(gamma_spread)*REAL_SIZE) - deallocate(gamma_spread) - call DEALLOC_TRACE("calc_dn_dr_mat U_spread", size(U_spread)*REAL_SIZE) - deallocate(U_spread) - call DEALLOC_TRACE("calc_dn_dr_mat dn0_dr_mat", size(dn0_dr_mat)*REAL_SIZE) - deallocate(dn0_dr_mat) - call DEALLOC_TRACE("calc_dn_dr_mat t_dn_dr_mat", size(t_dn0_dr_mat)*REAL_SIZE) - deallocate(t_dn0_dr_mat) - call DEALLOC_TRACE("calc_dn_dr_mat dn0_dr", size(dn0_dr)*REAL_SIZE) - deallocate(dn0_dr) - - deallocate(d_mask) - deallocate(od_mask) - -end subroutine calc_dn_dr_mat - -subroutine calc_dgN_dr_vec(gf, at, dgN_dr_vec, w_n, sp_S, sp_Stwid) - type(GreensFunctions), intent(inout) :: gf - type(Atoms), intent(in) :: at - real(dp), intent(out) :: dgN_dr_vec(:,:) - real(dp), intent(in) :: w_n(:) - type(TBMatrix), intent(in) :: sp_S - type(TBmatrix), intent(inout) :: sp_Stwid - - real(dp), allocatable :: ww_n(:) - real(dp) dgN_dr_denom - complex(dp) :: a, az - - logical, allocatable :: d_mask(:), od_mask(:) - - integer ip, i, j - - type(TBMatrix) :: GWN, SG, aGWNSG, azGWNSG, GWNSG - - if (at%cutoff < gf%tbsys%tbmodel%cutoff) & - call print ("WARNING: Called calc_dgN_dr_vec with messed up cutoff in atoms: uniform" // & - at%cutoff // " < " // gf%tbsys%tbmodel%cutoff) - - allocate(ww_n(gf%tbsys%N)) - ww_n = atom_orbital_spread(gf%tbsys, w_n) - - allocate(d_mask(at%N)) - allocate(od_mask(at%N)) - - call multDiagRL(sp_Stwid, sp_S, gf%tbsys%scf%global_U*ww_n) - - do ip=1, gf%N_G - if (ip == 1) then - call Initialise(SG, gf%G(1)) - call Initialise(GWN, gf%G(1)) - call Initialise(aGWNSG, gf%G(1)) - call Initialise(azGWNSG, gf%G(1)) - call Initialise(GWNSG, gf%G(1)) - call zero(aGWNSG) - call zero(azGWNSG) - endif - - - if (.not. gf%tbsys%complex_matrices) then ! factor of 2.0, instead of doing G(z) and G(conjg(z)) separately - a = 2.0_dp*gf%a(ip) - az = 2.0_dp*gf%a(ip)*gf%z(ip) - else - a = gf%a(ip) - az = gf%a(ip)*gf%z(ip) - endif - - call multDiag(GWN, gf%G(ip), ww_n) - call matrix_product_sub(SG, gf%tbsys%S, gf%G(ip)) - call matrix_product_sub(GWNSG, GWN, SG) - - ! omp critical - call scaled_accum(aGWNSG, a, GWNSG) - call scaled_accum(azGWNSG, az, GWNSG) - - if (gf%tbsys%complex_matrices) then - a = conjg(gf%a(ip)) - az = conjg(gf%a(ip)*gf%z(ip)) - - call multDiag(GWN, gf%G_conjg(ip), ww_n) - call matrix_product_sub(SG, gf%tbsys%S, gf%G_conjg(ip)) - call matrix_product_sub(GWNSG, GWN, SG) - - ! omp critical - call scaled_accum(aGWNSG, a, GWNSG) - call scaled_accum(azGWNSG, az, GWNSG) - - endif - end do - - call Finalise(SG) - call Finalise(GWN) - call Finalise(GWNSG) - - call Gsum_distrib_inplace(gf, aGWNSG) - call Gsum_distrib_inplace(gf, azGWNSG) - - !NB sign set empirically - ! factor of 2 shifted into aGWNSG - dgN_dr_denom = 1.0_dp + ksum_distrib(gf%tbsys%kpoints, real(local_ksum(gf%tbsys%kpoints, TraceMult(sp_Stwid, aGWNSG, & - a_H=.true., b_H=.false.)))) - - dgN_dr_vec = 0.0_dp - - do i=1, at%N - call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) - do j=1, 3 - if (.not. gf%tbsys%tbmodel%is_orthogonal) then - ! Tr [ dS/dr rho wN ] - ! NB sign set empirically - dgN_dr_vec(j,i) = dgN_dr_vec(j,i) - sum(ww_n * & - local_ksum(gf%tbsys%kpoints, real(partial_TraceMult(gf%tbsys%dS(j), gf%dm, & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask)))) - ! factor of 2 shifted into aGWNSG and azGWNSG - dgN_dr_vec(j,i) = dgN_dr_vec(j,i) - local_ksum(gf%tbsys%kpoints, real(TraceMult(gf%tbsys%dS(j), azGWNSG, & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - end if - dgN_dr_vec(j,i) = dgN_dr_vec(j,i) + & - local_ksum(gf%tbsys%kpoints, real(TraceMult(gf%tbsys%dH(j), aGWNSG, & - a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) - - ! NB SIMPLE (C+) implementation needs to add something because its dH_ij/dr doesn't - ! include the 0.5 (lpot(i) + lpot(j) dS_ij/dr part - end do - end do - - call ksum_distrib_inplace(gf%tbsys%kpoints, dgN_dr_vec) - - dgN_dr_vec = dgN_dr_vec / dgN_dr_denom - - call Finalise(aGWNSG) - call Finalise(azGWNSG) - - deallocate(d_mask) - deallocate(od_mask) - -end subroutine calc_dgN_dr_vec - - -subroutine calc_dm_from_evecs(this, for_forces) - type(TB_type), intent(inout) :: this - logical, intent(in), optional :: for_forces - - logical do_forces - - do_forces = .false. - if (present(for_forces)) do_forces = for_forces - - call realloc_match_tbsys(this%tbsys, this%dm) - call realloc_match_tbsys(this%tbsys, this%scaled_evecs) - call Zero(this%dm) - if (do_forces .and. .not. this%tbsys%tbmodel%is_orthogonal) then - call realloc_match_tbsys(this%tbsys, this%Hdm) - call Zero(this%Hdm) - endif - - if (do_forces) then - call multDiag(this%scaled_evecs, this%evecs, this%F_fillings) - call matrix_product_sub(this%dm, this%scaled_evecs, this%evecs, b_conjugate = .true.) - if (.not. this%tbsys%tbmodel%is_orthogonal) then - call multDiag(this%scaled_evecs, this%evecs, this%eval_F_fillings) - call matrix_product_sub(this%Hdm, this%scaled_evecs, this%evecs, b_conjugate = .true.) - endif - else - call multDiag(this%scaled_evecs, this%evecs, this%E_fillings) - call matrix_product_sub(this%dm, this%scaled_evecs, this%evecs, b_conjugate = .true.) - endif - -end subroutine calc_dm_from_evecs - -subroutine TB_calc_E_fillings(this, use_fermi_E, fermi_E, AF, w_n) - type(TB_type), intent(inout) :: this - logical, intent(in), optional :: use_fermi_E - real(dp), intent(in), optional :: fermi_E - type(ApproxFermi), intent(inout), optional :: AF - real(dp), intent(in), pointer :: w_n(:) - - logical find_new_fermi_E - real(dp) :: degeneracy - - if (present(use_fermi_E) .and. .not. present(AF)) then - if (.not. has_fermi_E(this%fermi_E, this%tbsys%tbmodel, fermi_E, this%calc_args_str)) & - call system_abort("called calc_E_fillings with use_fermi_E, but no Fermi_E or AF") - endif - - find_new_fermi_E = .true. - if (present(use_fermi_E)) find_new_fermi_E = .not. use_fermi_E - - if (present(AF)) call print("calc_E_fillings using approx fermi function", PRINT_VERBOSE) - - if (find_new_fermi_E) then - call print("calc_E_fillings finding new fermi level", PRINT_VERBOSE) - else - call print("calc_E_fillings using current fermi level", PRINT_VERBOSE) - endif - - call realloc_match_tbsys(this%tbsys, this%E_fillings) - - if (find_new_fermi_E) then - ! not so useful for Fermi E to be set based on w_n. - ! mostly w_n applies to SCF_GCN and SCF_LOBAL_U. - ! can be restored if necessary, but should probably have a different - ! name for the property than weight_n - call find_fermi_E(this, AF) - call print ("TB_calc_E_fillings got new Fermi_E " // this%Fermi_E, PRINT_VERBOSE) - else - if (present(fermi_E)) then - this%fermi_E = fermi_E - endif - if (this%tbsys%noncollinear) then - degeneracy = 1.0_dp - else - degeneracy = 2.0_dp - endif - if (present(AF)) then - call calc_fermi_factors(this%E_fillings, this%evals, AF = AF, degeneracy=degeneracy) - else - call calc_fermi_factors(this%E_fillings, this%evals, fermi_E = this%fermi_E, fermi_T = this%fermi_T, degeneracy=degeneracy) - endif - endif - -end subroutine TB_calc_E_fillings - -subroutine TB_calc_F_fillings(this, need_eval_F_fillings, AF) - type(TB_type), intent(inout) :: this - logical, intent(in), optional :: need_eval_F_fillings - type(ApproxFermi), intent(inout), optional :: AF - - call realloc_match_tbsys(this%tbsys, this%F_fillings) - - if (present(AF)) then - call calc_mod_fermi_factors(this, this%E_fillings, this%F_fillings, AF = AF) - else - call calc_mod_fermi_factors(this, this%E_fillings, this%F_fillings, fermi_E = this%fermi_E, fermi_T = this%fermi_T) - endif - - if (present(need_eval_F_fillings)) then - if (need_eval_F_fillings) then - call realloc_match_tbsys(this%tbsys, this%eval_F_fillings) - this%eval_F_fillings%data_d = this%F_fillings%data_d*this%evals%data_d - endif - endif - -end subroutine TB_calc_F_fillings - -subroutine TB_find_fermi_E(this, AF, w_n) - type(TB_type), intent(inout) :: this - type(ApproxFermi), intent(inout), optional :: AF - real(dp), intent(in), pointer, optional :: w_n(:) - - integer iter - integer, parameter :: max_iter = 200 - real(dp) :: e_min, e_max, e_try - real(dp) :: N_try - logical :: have_w_n - - real(dp), allocatable :: local_N(:) - real(dp) :: N_e - real(dp) :: EPS - real(dp) :: degeneracy - - call print("called find_fermi_E fermi_T " // this%fermi_T // " " // (this%fermi_T < 1e-8_dp), PRINT_ANALYSIS) - - have_w_n = .false. - if (present(w_n)) then - if (associated(w_n)) have_w_n = .true. - endif - - N_e = n_elec(this%tbsys, this%at, w_n) - - if (present(AF)) then - if (AF%n_poles == 0 .or. (AF%band_width .feq. 0.0_dp)) then - call system_abort("called find_fermi_E with AF present but n_poles of band_width == 0") - endif - endif - - if (this%fermi_T < 1e-8_dp) then - call system_abort ("find_fermi_E can't handle fermi_T < 1e-8") - else - e_min = min(this%tbsys%kpoints, this%evals%data_d(1,:)) - 10.0_dp - e_max = max(this%tbsys%kpoints, this%evals%data_d(this%evals%N,:)) + 10.0_dp - - call Print("find_Fermi_E N_e " // N_e // " e_min " // e_min // " e_max " // e_max, PRINT_ANALYSIS) - - if (have_w_n) allocate(local_N(this%tbsys%N_atoms)) - - iter = 0 - N_try = N_e + 1 - do while (abs(N_try-N_e) > this%fermi_E_precision) - e_try = (e_min + e_max) / 2.0_dp - if (this%tbsys%noncollinear) then - degeneracy = 1.0_dp - else - degeneracy = 2.0_dp - endif - if (present(AF)) then - AF%z = AF%z - AF%fermi_E + e_try - AF%fermi_E = e_try - call calc_fermi_factors(this%E_fillings, this%evals, AF = AF, degeneracy=degeneracy) - else - call calc_fermi_factors(this%E_fillings, this%evals, fermi_E = e_try, fermi_T = this%fermi_T, degeneracy=degeneracy) - endif - if (have_w_n) then - ! could be done more efficiency, by precomputing for each state the - ! occupation on each atom - call calc_dm_from_evecs(this, .false.) - call calc_local_atomic_num(this, local_N) - N_try = sum(w_n*local_N) - else - N_try = ksum_dup(this%tbsys%kpoints, sum(this%E_fillings%data_d,dim=1)) - endif - call Print("find_Fermi_E e_try n_try " // (iter+1) // " " // e_try // " " // n_try, PRINT_ANALYSIS) - if (N_try < N_e) then - e_min = e_try - else - e_max = e_try - endif - iter = iter + 1 - if (iter .gt. max_iter) then - call print("N_e " // N_e // " N_try " // N_try, PRINT_ALWAYS) - call print("e_min " // e_min // " e_max " // e_max // " e_try " // e_try, PRINT_ALWAYS) - call print("this%evals", PRINT_ALWAYS) - call verbosity_push(PRINT_NORMAL) - call print(this%evals) - call verbosity_pop() - call system_abort("Ran out of iterations in find_fermi_E") - endif - if ((abs(N_try-N_e) > this%fermi_E_precision) .and. (e_min == e_max)) then - call print("N_e " // N_e // " N_try " // N_try, PRINT_ALWAYS) - call print("e_min " // e_min // " e_max " // e_max // " e_try " // e_try, PRINT_ALWAYS) - call print("this%evals", PRINT_ALWAYS) - call verbosity_push(PRINT_NORMAL) - call print(this%evals) - call verbosity_pop() - call system_abort("Ran out of precision in find_fermi_E") - endif - end do - - this%fermi_E = e_try - endif - - EPS=1e-4_dp - this%homo_e = maxval(this%evals%data_d, this%evals%data_d <= this%fermi_E+EPS) - this%lumo_e = minval(this%evals%data_d, this%evals%data_d >= this%fermi_E-EPS) - this%homo_e = max(this%tbsys%kpoints, this%homo_e) - this%lumo_e = min(this%tbsys%kpoints, this%lumo_e) - - if (allocated(local_N)) deallocate(local_N) - -end subroutine TB_find_fermi_E - -subroutine calc_fermi_factors(fermi_factors, evals, fermi_E, fermi_T, AF, degeneracy) - type(TBVector), intent(inout) :: fermi_factors - type(TBVector), intent(in) :: evals - real(dp), intent(in), optional :: fermi_E, fermi_T - type(ApproxFermi), intent(in), optional :: AF - real(dp), intent(in), optional :: degeneracy - - real(dp) :: u_degeneracy - - u_degeneracy = optional_default(2.0_dp, degeneracy) - - if (present(AF)) then - fermi_factors%data_d(:,:) = u_degeneracy*approx_f_fermi(AF, evals%data_d(:,:)) - else if (present(Fermi_E) .and. present(Fermi_T)) then - fermi_factors%data_d(:,:) = u_degeneracy*f_fermi(fermi_E, fermi_T, evals%data_d(:,:)) - else - call system_abort("Called calc_fermi_factors without sufficient inputs for exact or approx fermi function") - endif -end subroutine calc_fermi_factors - -subroutine calc_fermi_derivs(fermi_factors, evals, fermi_E, fermi_T, AF, degeneracy) - type(TBVector), intent(inout) :: fermi_factors - type(TBVector), intent(in) :: evals - real(dp), intent(in), optional :: fermi_E, fermi_T - type(ApproxFermi), intent(in), optional :: AF - real(dp), intent(in), optional :: degeneracy - - real(dp) :: u_degeneracy - - u_degeneracy = optional_default(2.0_dp, degeneracy) - - if (present(AF) .and. (present(fermi_E) .or. present(fermi_T))) then - call system_abort("Called calc_fermi_factors with both ApproxFermi and Fermi_E or Fermi_T") - endif - - if (present(AF)) then - fermi_factors%data_d(:,:) = u_degeneracy*approx_f_fermi_deriv(AF, evals%data_d(:,:)) - else if (present(Fermi_E) .and. present(Fermi_T)) then - fermi_factors%data_d(:,:) = u_degeneracy*f_fermi_deriv(fermi_E, fermi_T, evals%data_d(:,:)) - else - call system_abort("Called calc_fermi_factors without sufficient inputs for exact or approx fermi function") - endif - -end subroutine calc_fermi_derivs - -subroutine calc_mod_fermi_factors(this, fermi_factors, mod_fermi_factors, fermi_E, fermi_T, AF) - type(TB_type), intent(inout) :: this - type(TBVector), intent(in) :: fermi_factors - type(TBVector), intent(inout) :: mod_fermi_factors - real(dp), intent(in), optional :: Fermi_E, Fermi_T - type(ApproxFermi), intent(in), optional :: AF - - real(dp) numerator, denominator, theta - type(TBVector) :: fermi_derivs - real(dp) :: degeneracy - - if (present(AF) .and. (present(fermi_E) .or. present(fermi_T))) then - call system_abort("Called calc_mod_fermi_factors with both ApproxFermi and Fermi_E or Fermi_T") - endif - - call Initialise(fermi_derivs, fermi_factors%N, fermi_factors%n_vectors) - - if (this%tbsys%noncollinear) then - degeneracy = 1.0_dp - else - degeneracy = 2.0_dp - endif - - call calc_fermi_derivs(fermi_derivs, this%evals, fermi_E, fermi_T, AF, degeneracy) - - denominator = ksum_dup(this%tbsys%kpoints, sum(fermi_derivs%data_d,dim=1)) - - if (denominator .feq. 0.0_dp) then - mod_fermi_factors%data_d = fermi_factors%data_d - else - numerator = ksum_dup(this%tbsys%kpoints, sum(this%evals%data_d*fermi_derivs%data_d,dim=1)) - theta = numerator/denominator - -! constant mu - ! mod_fermi_factors%data_d = fermi_factors%data_d + & - ! fermi_derivs%data_d*(this%evals%data_d) - -! constant N - mod_fermi_factors%data_d = fermi_factors%data_d + & - fermi_derivs%data_d*(this%evals%data_d-theta) - - endif - - call Finalise(fermi_derivs) -end subroutine calc_mod_fermi_factors - -function TB_evals(this) - type(TB_type) :: this - real(dp) :: TB_evals(this%tbsys%N,this%tbsys%kpoints%g_N) - - if(allocated(this%evals%data_d)) then - call collect(this%tbsys%kpoints, this%evals%data_d, TB_evals) - else - call system_abort("TB_evals() call with unallocated evals%data_d array") - end if - -end function TB_evals - -! calculation optical absorption with formula from -! Snyder and Rotkin, Small v. 4, p. 1284-1286 -subroutine absorption(this, polarization, freqs, gamma, a) - type(TB_type), intent(inout) :: this - complex(dp), intent(in) :: polarization(3) - real(dp), intent(in) :: freqs(:), gamma - real(dp), intent(out) :: a(:) - - complex(dp) :: polarization_hat(3) - type(TBMatrix) :: dipole_evecs(3) - integer :: i, f, ik, i_freq - real(dp), allocatable :: absorption_contrib(:) - - if (this%evecs%N == 0 .or. this%evecs%n_matrices == 0) & - call system_abort("Absorption needs eigenvectors to be already calculated") - - call dipole_matrix(this, dipole_evecs) - - call verbosity_push_decrement() - call print("dipole_evecs(1)") - call print(dipole_evecs(1)) - call print("dipole_evecs(2)") - call print(dipole_evecs(2)) - call print("dipole_evecs(3)") - call print(dipole_evecs(3)) - call verbosity_pop() - - polarization_hat = polarization / sqrt(sum(abs(polarization)**2)) - - allocate(absorption_contrib(this%evecs%n_matrices)) - - do i_freq=1, size(freqs) - absorption_contrib = 0.0_dp - do ik=1, this%evecs%n_matrices - do i=1, this%evecs%N - do f=i+1, this%evecs%N - if ((this%E_fillings%data_d(i,ik) .fne. 0.0_dp) .and. (this%E_fillings%data_d(f,ik) .fne. 1.0_dp)) then - if (dipole_evecs(1)%is_complex) then - absorption_contrib(ik) = absorption_contrib(ik) + & - ( (abs(dipole_evecs(1)%data_z(ik)%data(i,f)*polarization_hat(1) + & - dipole_evecs(2)%data_z(ik)%data(i,f)*polarization_hat(2) + & - dipole_evecs(3)%data_z(ik)%data(i,f)*polarization_hat(3))**2)/(freqs(i_freq)) ) * & - ( (this%E_fillings%data_d(i,ik)/2.0_dp*(1.0_dp-this%E_fillings%data_d(f,ik)/2.0_dp)) / & - ((this%evals%data_d(f,ik)-this%evals%data_d(i,ik)-freqs(i_freq))**2 + gamma**2) ) - else - absorption_contrib(ik) = absorption_contrib(ik) + & - ( (abs(dipole_evecs(1)%data_d(ik)%data(i,f)*polarization_hat(1) + & - dipole_evecs(2)%data_d(ik)%data(i,f)*polarization_hat(2) + & - dipole_evecs(3)%data_d(ik)%data(i,f)*polarization_hat(3))**2)/(freqs(i_freq)) ) * & - ( (this%E_fillings%data_d(i,ik)/2.0_dp*(1.0_dp-this%E_fillings%data_d(f,ik)/2.0_dp)) / & - ((this%evals%data_d(f,ik)-this%evals%data_d(i,ik)-freqs(i_freq))**2 + gamma**2) ) - endif - endif - end do ! f - end do ! i - end do ! ik - - a(i_freq) = ksum_distrib(this%tbsys%kpoints, local_ksum(this%tbsys%kpoints, absorption_contrib)) - end do - - deallocate(absorption_contrib) - - call finalise(dipole_evecs(1)) - call finalise(dipole_evecs(2)) - call finalise(dipole_evecs(3)) - -end subroutine absorption - -subroutine dipole_matrix(this, dipole_evecs) - type(TB_type), intent(inout) :: this - type(TBMatrix), intent(inout) :: dipole_evecs(3) - - type(TBMatrix) :: dipole_basis(3), t - - integer :: i - - do i=1, 3 - call realloc_match_tbsys(this%tbsys, dipole_basis(i)) - call realloc_match_tbsys(this%tbsys, dipole_evecs(i)) - end do - call realloc_match_tbsys(this%tbsys, t) - - call fill_these_matrices(this%tbsys, this%at, do_dipole=.true., dipole=dipole_basis) - - call verbosity_push_decrement(PRINT_NERD) - call print("dipole_basis(1)") - call print(dipole_basis(1)) - call print("dipole_basis(2)") - call print(dipole_basis(2)) - call print("dipole_basis(3)") - call print(dipole_basis(3)) - call verbosity_pop() - - do i=1,3 - call matrix_product_sub(t, dipole_basis(i), this%evecs, a_conjugate=.false., b_conjugate = .false.) - call matrix_product_sub(dipole_evecs(i), this%evecs, t, a_conjugate=.true., b_conjugate = .false.) - end do - - do i=1, 3 - call finalise(dipole_basis(i)) - end do - call finalise(t) - -end subroutine dipole_matrix - -end module TB_module diff --git a/src/Potentials/TBMatrix.f95 b/src/Potentials/TBMatrix.f95 deleted file mode 100644 index 6c8b88a5ca..0000000000 --- a/src/Potentials/TBMatrix.f95 +++ /dev/null @@ -1,1310 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X IP module -!X -!% Contain objects for handling TB matrices (\texttt{type TBMatrix}) and vectors -!% (\texttt{type TBVector}). -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module TBMatrix_module - -use error_module -use system_module, only : dp, current_verbosity, inoutput, PRINT_NORMAL, operator(//), optional_default -use mpi_context_module -use linearalgebra_module -use atoms_module - -use ScaLAPACK_module -use Matrix_module -use RS_SparseMatrix_module -use TBModel_module - -implicit none -private - -public :: TBVector -type TBVector - integer :: N = 0 - integer :: n_vectors = 0 - logical :: is_complex = .false. !% Logical variable to define if vector elements are complex - - real(dp), allocatable :: data_d(:,:) - complex(dp), allocatable :: data_z(:,:) -end type TBVector - -public :: TBMatrix -type TBMatrix - integer :: N = 0 - integer :: n_matrices = 0 - logical :: is_complex = .false. !% Logical variable to define if matrix elements are complex - logical :: is_sparse = .false. !% Logical variable to define if such matrix is sparse - - type(MatrixD), allocatable :: data_d(:) - type(MatrixZ), allocatable :: data_z(:) - type(RS_SparseMatrixD), allocatable :: sdata_d(:) - type(RS_SparseMatrixZ), allocatable :: sdata_z(:) -end type TBMatrix - -public :: Initialise -interface Initialise - module procedure TBMatrix_Initialise, TBMatrix_Initialise_tbm, TBVector_Initialise - module procedure TBMatrix_Initialise_sp -end interface Initialise - -public :: Finalise -interface Finalise - module procedure TBMatrix_Finalise, TBVector_Finalise -end interface Finalise - -public :: Wipe -interface Wipe - module procedure TBMatrix_Wipe, TBVector_Wipe -end interface Wipe - -public :: Zero -interface Zero - module procedure TBMatrix_Zero, TBVector_Zero -end interface Zero - -public :: Print -interface Print - module procedure TBMatrix_Print, TBVector_Print -end interface Print - -public :: copy -interface copy - module procedure TBMatrix_copy_d - module procedure TBMatrix_copy_z -end interface copy - -public :: add_block -interface add_block - module procedure TBMatrix_add_block_d, TBMatrix_add_block_z -end interface add_block - -public :: diagonalise -interface diagonalise - module procedure TBMatrix_diagonalise, TBmatrix_diagonalise_gen -end interface diagonalise - -public :: multDiag -interface multDiag - module procedure TBMatrix_multDiag, TBMatrix_multDiag_d, TBMatrix_multDiag_z -end interface multDiag - -public :: multDiagRL -interface multDiagRL - module procedure TBMatrix_multDiagRL_d -end interface multDiagRL - -public :: matrix_product_sub -interface matrix_product_sub - module procedure TBMatrix_matrix_product_sub, TBMatrix_matrix_product_sub_r2 -end interface matrix_product_sub - -public operator(.DOT.) -interface operator(.DOT.) - module procedure TBVector_dotproduct -end interface - -public :: partial_TraceMult -interface partial_TraceMult - module procedure TBMatrix_partial_TraceMult -end interface partial_TraceMult - -public :: partial_TraceMult_spinor -interface partial_TraceMult_spinor - module procedure TBMatrix_partial_TraceMult_spinor -end interface partial_TraceMult_spinor - -public :: TraceMult -interface TraceMult - module procedure TBMatrix_TraceMult -end interface TraceMult - -public :: Re_diag -interface Re_diag - module procedure TBMatrix_Re_diag -end interface Re_diag - -public :: diag_spinor -interface diag_spinor - module procedure TBMatrix_diag_spinor -end interface diag_spinor - -public :: scaled_sum -interface scaled_sum - module procedure TBMatrix_scaled_sum -end interface scaled_sum - -public :: scaled_accum -interface scaled_accum - module procedure TBMatrix_scaled_accum -end interface scaled_accum - -public :: inverse -interface inverse - module procedure TBMatrix_inverse -end interface inverse - -public :: sum_in_place -interface sum_in_place - module procedure TBMatrix_sum_in_place -end interface sum_in_place - -public :: accum_scaled_elem_product -interface accum_scaled_elem_product - module procedure TBMatrix_accum_scaled_elem_product -end interface accum_scaled_elem_product - -public :: sum_matrices -interface sum_matrices - module procedure TBMatrix_sum_matrices_d -end interface sum_matrices - -public :: transpose_sub -interface transpose_sub - module procedure TBMatrix_transpose_sub -end interface transpose_sub - - -public :: make_hermitian -interface make_hermitian - module procedure TBMatrix_make_hermitian -end interface make_hermitian - -contains - -subroutine TBMatrix_sum_in_place(this, mpi) - type(TBMatrix), intent(inout) :: this - type(MPI_context) :: mpi - - integer i - - do i=1, this%n_matrices - if (this%is_complex) then - if (this%is_sparse) then - call sum_in_place(mpi, this%sdata_z(i)%data) - else - call sum_in_place(mpi, this%data_z(i)%data) - endif - else - if (this%is_sparse) then - call sum_in_place(mpi, this%sdata_d(i)%data) - else - call sum_in_place(mpi, this%data_d(i)%data) - endif - endif - end do - -end subroutine TBMatrix_sum_in_place - -subroutine TBMatrix_Initialise(this, N, n_matrices, is_complex, scalapack_obj) - type(TBMatrix), intent(inout) :: this - integer, intent(in) :: N - integer, intent(in), optional :: n_matrices - logical, intent(in), optional :: is_complex - type(ScaLAPACK), intent(in), optional :: scalapack_obj - - integer i - - call Finalise(this) - - this%N = N - if (present(n_matrices)) then - this%n_matrices = n_matrices - else - this%n_matrices = 1 - endif - if (present(is_complex)) then - this%is_complex = is_complex - endif - - if (this%is_complex) then - allocate(this%data_z(this%n_matrices)) - do i=1, this%n_matrices - call Initialise(this%data_z(i), this%N, scalapack_obj=scalapack_obj) - end do - else - allocate(this%data_d(this%n_matrices)) - do i=1, this%n_matrices - call Initialise(this%data_d(i), this%N, scalapack_obj=scalapack_obj) - end do - endif - -end subroutine TBMatrix_Initialise - -subroutine TBMatrix_Initialise_tbm(this, from) - type(TBMatrix), intent(inout) :: this - type(TBMatrix), intent(in) :: from - - integer i - - call Finalise(this) - - this%N = from%N - this%n_matrices = from%n_matrices - this%is_complex = from%is_complex - - if (this%is_complex) then - if (this%n_matrices > 0) allocate(this%data_z(this%n_matrices)) - do i=1, this%n_matrices - call Initialise(this%data_z(i), from%data_z(i)) - end do - else - if (this%n_matrices > 0) allocate(this%data_d(this%n_matrices)) - do i=1, this%n_matrices - call Initialise(this%data_d(i), from%data_d(i)) - end do - endif - -end subroutine TBMatrix_Initialise_tbm - -subroutine TBMatrix_Initialise_sp(this, at, first_orb_of_atom, n_matrices, is_complex, mpi_obj) - type(TBMatrix), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: first_orb_of_atom(:) - integer, intent(in), optional :: n_matrices - logical, intent(in), optional :: is_complex - type(MPI_Context), intent(in), optional :: mpi_obj - - integer i - - call Finalise(this) - - this%is_sparse = .true. - - this%N = first_orb_of_atom(at%N+1)-1 - if (present(n_matrices)) then - this%n_matrices = n_matrices - else - this%n_matrices = 1 - endif - if (present(is_complex)) then - this%is_complex = is_complex - endif - - if (this%is_complex) then - if (this%n_matrices > 0) allocate(this%sdata_z(this%n_matrices)) - do i=1, this%n_matrices - call Initialise(this%sdata_z(i), at, first_orb_of_atom, mpi_obj=mpi_obj) - end do - else - if (this%n_matrices > 0) allocate(this%sdata_d(this%n_matrices)) - do i=1, this%n_matrices - call Initialise(this%sdata_d(i), at, first_orb_of_atom, mpi_obj=mpi_obj) - end do - endif - -end subroutine TBMatrix_Initialise_sp - -subroutine TBMatrix_Finalise(this) - type(TBMatrix), intent(inout) :: this - - call Wipe(this) - -end subroutine TBMatrix_Finalise - -subroutine TBMatrix_Zero(this, d_mask, od_mask) - type(TBMatrix), intent(inout) :: this - logical, intent(in), optional :: d_mask(:), od_mask(:) - - integer i - - if (allocated(this%data_d)) then - do i=1, size(this%data_d) - call Zero(this%data_d(i), d_mask, od_mask) - end do - end if - if (allocated(this%data_z)) then - do i=1, size(this%data_z) - call Zero(this%data_z(i), d_mask, od_mask) - end do - end if - if (allocated(this%sdata_d)) then - do i=1, size(this%sdata_d) - call Zero(this%sdata_d(i), d_mask, od_mask) - end do - end if - if (allocated(this%sdata_z)) then - do i=1, size(this%sdata_z) - call Zero(this%sdata_z(i), d_mask, od_mask) - end do - end if -end subroutine TBMatrix_Zero - -subroutine TBMatrix_Wipe(this) - type(TBMatrix), intent(inout) :: this - - integer :: i - - if (allocated(this%data_d)) then - do i=1, size(this%data_d) - call Finalise(this%data_d(i)) - end do - deallocate(this%data_d) - endif - if (allocated(this%data_z)) then - do i=1, size(this%data_z) - call Finalise(this%data_z(i)) - end do - deallocate(this%data_z) - end if - if (allocated(this%sdata_d)) then - do i=1, size(this%sdata_d) - call Finalise(this%sdata_d(i)) - end do - deallocate(this%sdata_d) - endif - if (allocated(this%sdata_z)) then - do i=1, size(this%sdata_z) - call Finalise(this%sdata_z(i)) - end do - deallocate(this%sdata_z) - endif - - this%N = 0 - this%n_matrices = 0 -end subroutine TBMatrix_Wipe - -subroutine TBMatrix_Print(this,file) - type(TBMatrix), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer::i - - if (current_verbosity() < PRINT_NORMAL) return - - call Print('TBMatrix : ', file=file) - - call Print ('TBMatrix : N n_matrices ' // this%N // " " // this%n_matrices, file=file) - call Print ('TBMatrix : is_complex ' // this%is_complex, file=file) - - if (allocated(this%data_d)) then - do i=1, size(this%data_d) - call Print ('TBMatrix : data_d ' // i, file=file) - call Print(this%data_d(i), file=file) - end do - endif - - if (allocated(this%data_z)) then - do i=1, size(this%data_z) - call Print ('TBMatrix : data_z ' // i, file=file) - call Print(this%data_z(i), file=file) - end do - endif - - if (allocated(this%sdata_d)) then - do i=1, size(this%sdata_d) - call Print ('TBMatrix : sdata_d ' // i, file=file) - call print_simple(this%sdata_d(i), file=file) - !call Print(this%sdata_d(i), file=file) - end do - endif - - if (allocated(this%sdata_z)) then - do i=1, size(this%sdata_z) - call Print ('TBMatrix : sdata_z ' // i, file=file) - !call print_simple(this%sdata_z(i), file=file) - call Print(this%sdata_z(i), file=file) - end do - endif - -end subroutine TBMatrix_Print - -subroutine TBMatrix_copy_d(this, data_d, index) - type(TBMatrix), intent(in) :: this - real(dp), intent(inout), dimension(:,:) :: data_d - integer, optional, intent(in) :: index - integer my_index - - my_index = optional_default(1, index) - - call Print('TBMatrix : ') - call Print ('TBMatrix : N n_matrices ' // this%N // " " // this%n_matrices) - call Print ('TBMatrix : is_complex ' // this%is_complex) - - if (allocated(this%data_d)) then - if (my_index > size(this%data_d)) call system_abort("index > size(data_d)") - data_d(:,:) = this%data_d(my_index)%data - else if (allocated(this%sdata_d)) then - if (my_index > size(this%sdata_d)) call system_abort("index > size(sdata_d)") - call copy(this%sdata_d(my_index), data_d) - endif -end subroutine TBmatrix_copy_d - -subroutine TBMatrix_copy_z(this, data_z, index) - type(TBMatrix), intent(in) :: this - complex(dp), intent(inout), dimension(:,:) :: data_z - integer, optional, intent(in) :: index - integer my_index - - my_index = optional_default(1, index) - - call Print('TBMatrix : ') - call Print ('TBMatrix : N n_matrices ' // this%N // " " // this%n_matrices) - call Print ('TBMatrix : is_complex ' // this%is_complex) - - if (allocated(this%data_z)) then - if (my_index > size(this%data_z)) call system_abort("index > size(data_z)") - if (any(shape(data_z) /= shape(this%data_z(my_index)%data))) call system_abort("data_z size mismatch") - data_z(:,:) = this%data_z(my_index)%data - else if (allocated(this%sdata_z)) then - call copy(this%sdata_z(my_index), data_z) - endif -end subroutine TBMatrix_copy_z - -subroutine TBVector_Initialise(this, N, n_vectors, is_complex) - type(TBVector), intent(inout) :: this - integer, intent(in) :: N - integer, intent(in), optional :: n_vectors - logical, intent(in), optional :: is_complex - - call Finalise(this) - - this%N = N - if (present(n_vectors)) then - this%n_vectors = n_vectors - else - this%n_vectors = 1 - endif - if (present(is_complex)) then - this%is_complex = is_complex - endif - - if (this%is_complex) then - allocate(this%data_z(this%N,this%n_vectors)) - else - allocate(this%data_d(this%N,this%n_vectors)) - endif - -end subroutine TBVector_Initialise - -subroutine TBVector_Finalise(this) - type(TBVector), intent(inout) :: this - - call Wipe(this) - -end subroutine TBVector_Finalise - -subroutine TBVector_Wipe(this) - type(TBVector), intent(inout) :: this - - if (allocated(this%data_d)) deallocate(this%data_d) - if (allocated(this%data_z)) deallocate(this%data_z) - - this%N = 0 - this%n_vectors = 0 -end subroutine TBVector_Wipe - -subroutine TBVector_Zero(this) - type(TBVector), intent(inout) :: this - - if (allocated(this%data_d)) this%data_d = 0.0_dp - if (allocated(this%data_z)) this%data_z = 0.0_dp - -end subroutine TBVector_Zero - -subroutine TBVector_Print(this,file) - type(TBVector), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer::i - - if (current_verbosity() < PRINT_NORMAL) return - - call Print('TBVector : ', file=file) - - call Print ('TBVector : N n_vectors ' // this%N // ' ' // this%n_vectors, file=file) - call Print ('TBVector : is_complex ' // this%is_complex, file=file) - - if (allocated(this%data_d)) then - do i=1, size(this%data_d,2) - call Print ('TBVector : data_d ' // i, file=file) - call Print(this%data_d(:,i), file=file) - end do - endif - - if (allocated(this%data_z)) then - do i=1, size(this%data_z,2) - call Print ('TBVector : data_z ' // i, file=file) - call Print(this%data_z(:,i), file=file) - end do - endif - -end subroutine TBVector_Print - -subroutine TBMatrix_add_block_d(this, im, block, block_nr, block_nc, first_row, first_col, at_row, at_col) - type(TBMatrix), intent(inout) :: this - integer, intent(in) :: im - real(dp), intent(in) :: block(:,:) - integer, intent(in) :: block_nr, block_nc - integer, intent(in) :: first_row, first_col - integer, intent(in), optional :: at_row, at_col - - - if (this%is_complex) then - if (this%is_sparse) then - call add_block(this%sdata_z(im), cmplx(block, 0.0_dp, dp), block_nr, block_nc, at_row, at_col) - else - call add_block(this%data_z(im), cmplx(block, 0.0_dp, dp), block_nr, block_nc, first_row, first_col) - endif - else - if (this%is_sparse) then - call add_block(this%sdata_d(im), block, block_nr, block_nc, at_row, at_col) - else - call add_block(this%data_d(im), block, block_nr, block_nc, first_row, first_col) - endif - endif - -end subroutine TBMatrix_add_block_d - -subroutine TBMatrix_add_block_z(this, im, block, block_nr, block_nc, first_row, first_col, at_row, at_col) - type(TBMatrix), intent(inout) :: this - integer, intent(in) :: im - complex(dp), intent(in) :: block(:,:) - integer, intent(in) :: block_nr, block_nc - integer, intent(in) :: first_row, first_col - integer, intent(in), optional :: at_row, at_col - - if (this%is_complex) then - if (this%is_sparse) then - call add_block(this%sdata_z(im), block, block_nr, block_nc, at_row, at_col) - else - call add_block(this%data_z(im), block, block_nr, block_nc, first_row, first_col) - endif - else - call system_abort ("tried to add complex block to real TBMatrix") - endif - -end subroutine TBMatrix_add_block_z - -subroutine TBMatrix_diagonalise_gen(this, overlap, evals, evecs, ignore_symmetry, error) - type(TBMatrix), intent(in) :: this - type(TBMatrix), intent(in) :: overlap - type(TBVector), intent(inout) :: evals - type(TBMatrix), intent(inout), optional :: evecs - logical, intent(in), optional :: ignore_symmetry - integer, intent(out), optional :: error - - integer i - - INIT_ERROR(error) - - if (this%is_sparse) then - RAISE_ERROR("can't diagonalize_gen sparse matrix", error) - endif - - if (this%is_complex) then - do i=1, this%n_matrices - if (present(evecs)) then - call diagonalise(this%data_z(i), overlap%data_z(i), evals%data_d(:,i), evecs%data_z(i), ignore_symmetry=ignore_symmetry, error = error) - else - call diagonalise(this%data_z(i), overlap%data_z(i), evals%data_d(:,i), ignore_symmetry=ignore_symmetry, error = error) - endif - end do - else - do i=1, this%n_matrices - if (present(evecs)) then - call diagonalise(this%data_d(i), overlap%data_d(i), evals%data_d(:,i), evecs%data_d(i), ignore_symmetry=ignore_symmetry, error = error) - else - call diagonalise(this%data_d(i), overlap%data_d(i), evals%data_d(:,i), ignore_symmetry=ignore_symmetry, error = error) - endif - end do - endif - PASS_ERROR(error) -end subroutine TBMatrix_diagonalise_gen - -subroutine TBMatrix_diagonalise(this, evals, evecs, ignore_symmetry, error) - type(TBMatrix), intent(in) :: this - type(TBVector), intent(inout) :: evals - type(TBMatrix), intent(inout), optional :: evecs - logical, intent(in), optional :: ignore_symmetry - integer, intent(out), optional :: error - - integer i - - INIT_ERROR(error) - - if (this%is_sparse) then - RAISE_ERROR("can't diagonalize sparse matrix", error) - endif - - if (this%is_complex) then - do i=1, this%n_matrices - if (present(evecs)) then - call diagonalise(this%data_z(i), evals%data_d(:,i), evecs%data_z(i), ignore_symmetry=ignore_symmetry, error = error) - else - call diagonalise(this%data_z(i), evals%data_d(:,i), ignore_symmetry=ignore_symmetry, error = error) - endif - end do - else - do i=1, this%n_matrices - if (present(evecs)) then - call diagonalise(this%data_d(i), evals%data_d(:,i), evecs%data_d(i), ignore_symmetry = ignore_symmetry, error = error) - else - call diagonalise(this%data_d(i), evals%data_d(:,i), ignore_symmetry = ignore_symmetry, error = error) - endif - end do - endif - PASS_ERROR(error) -end subroutine TBMatrix_diagonalise - -function TBVector_dotproduct(this, that) - type(TBVector), intent(in) :: this, that - real(dp) :: TBVector_dotproduct - - if (this%is_complex .or. that%is_complex) then - call system_abort ("TBVector_dotproduct can't handle complex vectors") - endif - - TBVector_dotproduct = this%data_d .dot. this%data_d -end function TBVector_dotproduct - -!subroutine accum_tbmatrix_col_outer_product(this, mati, i, TBV_f) -! type(TBMatrix), intent(inout) :: this -! type(TBMatrix), intent(in) :: mati -! integer, intent(in) :: i -! type(TBVector), intent(in) :: TBV_f -! -! integer ik -! -! if (mati%is_sparse) then -! call System_abort("can't accum_tbmatrix_col_outer_product of sparse matrix") -! endif -! -! do ik=1, mati%n_matrices -! if (TBV_f%data_d(i,ik) .fne. 0.0_dp) then -! if (mati%is_complex) then -! if (this%is_complex) then -! call accum_col_outer_product(this%data_z(ik), mati%data_z(ik), i, TBV_f%data_d(i,ik)) -! else -! call system_abort("tried to add outer product of columns of real TBMatrix to complex TBMatrix") -! endif -! else -! if (.not. this%is_complex) then -! call accum_col_outer_product(this%data_d(ik), mati%data_d(ik), i, TBV_f%data_d(i,ik)) -! else -! call system_abort("tried to add outer product of columns of complex TBMatrix to real TBMatrix") -! endif -! endif -! endif -! end do -!end subroutine - -function TBMatrix_TraceMult(a, b, w, a_H, b_H, diag_mask, offdiag_mask) - type(TBMatrix), intent(in) :: a, b - real(dp), intent(in), optional, target :: w(:) - logical, intent(in), optional :: a_H, b_H - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: TBMatrix_TraceMult(a%n_matrices) - - integer im - - do im=1, a%n_matrices - ! dense-sparse - if (.not. a%is_complex .and. .not. a%is_sparse .and. .not. b%is_complex .and. b%is_sparse) then - TBMatrix_TraceMult(im) = TraceMult(a%data_d(im), b%sdata_d(im), w, a_H, b_H, diag_mask, offdiag_mask) - else if (a%is_complex .and. .not. a%is_sparse .and. b%is_complex .and. b%is_sparse) then - TBMatrix_TraceMult(im) = TraceMult(a%data_z(im), b%sdata_z(im), w, a_H, b_H, diag_mask, offdiag_mask) - ! sparse-dense - else if (.not. a%is_complex .and. a%is_sparse .and. .not. b%is_complex .and. .not. b%is_sparse) then - TBMatrix_TraceMult(im) = TraceMult(a%sdata_d(im), b%data_d(im), w, a_H, b_H, diag_mask, offdiag_mask) - else if (.not. a%is_complex .and. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then - TBMatrix_TraceMult(im) = TraceMult(a%sdata_d(im), b%data_z(im), w, a_H, b_H, diag_mask, offdiag_mask) - else if (a%is_complex .and. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then - TBMatrix_TraceMult(im) = TraceMult(a%sdata_z(im), b%data_z(im), w, a_H, b_H, diag_mask, offdiag_mask) - else - call system_abort ("No TBMatrix_TraceMult implemented yet for " // & - " a%c " // a%is_complex // " a%s " // a%is_sparse // & - " b%c " // b%is_complex // " b%s " // b%is_sparse ) - endif - end do - -end function TBMatrix_TraceMult - -function TBMatrix_partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask) - type(TBMatrix), intent(in) :: a, b - logical, intent(in), optional :: a_H, b_H - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: TBMatrix_partial_TraceMult(a%N, a%n_matrices) - - integer im - - do im=1, a%n_matrices - if (.not. a%is_complex .and. .not. a%is_sparse .and. .not. b%is_complex .and. .not. b%is_sparse) then - if (present(diag_mask) .or. present(offdiag_mask)) call system_abort("Can't do diag_mask for TraceMult of 2 dense matrices") - TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%data_d(im), b%data_d(im), a_H, b_H) - else if (.not. a%is_complex .and. .not. a%is_sparse .and. .not. b%is_complex .and. b%is_sparse) then - TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%data_d(im), b%sdata_d(im), a_H, b_H, diag_mask,offdiag_mask) - else if (.not. a%is_complex .and. a%is_sparse .and. .not. b%is_complex .and. .not. b%is_sparse) then - TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%sdata_d(im), b%data_d(im), a_H, b_H, diag_mask,offdiag_mask) - else if (a%is_complex .and. .not. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then - if (present(diag_mask) .or. present(offdiag_mask)) call system_abort("Can't do diag_mask for TraceMult of 2 dense matrices") - TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%data_z(im), b%data_z(im), a_H, b_H) - else if (a%is_complex .and. .not. a%is_sparse .and. b%is_complex .and. b%is_sparse) then - TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%data_z(im), b%sdata_z(im), a_H, b_H, diag_mask,offdiag_mask) - else if (a%is_complex .and. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then - TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%sdata_z(im), b%data_z(im), a_H, b_H, diag_mask,offdiag_mask) - else - call system_abort ("No TBMatrix_partial_TraceMult implemented yet for " // & - " a%c " // a%is_complex // " a%s " // a%is_sparse // & - " b%c " // b%is_complex // " b%s " // b%is_sparse ) - endif - end do - -end function TBMatrix_partial_TraceMult - -function TBMatrix_partial_TraceMult_spinor(a, b, a_H, b_H, diag_mask, offdiag_mask) - type(TBMatrix), intent(in) :: a, b - logical, intent(in), optional :: a_H, b_H - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - complex(dp) :: TBMatrix_partial_TraceMult_spinor(2,2,a%N/2, a%n_matrices) - - integer im - - do im=1, a%n_matrices - if (a%is_complex .and. .not. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then - if (present(diag_mask) .or. present(offdiag_mask)) call system_abort("Can't do diag_mask for TraceMult_spinor of 2 dense matrices") - TBMatrix_partial_TraceMult_spinor(:,:,:,im) = partial_TraceMult_spinor(a%data_z(im), b%data_z(im), a_H, b_H) - else - call system_abort ("No TBMatrix_partial_TraceMult_spinor implemented yet for " // & - " a%c " // a%is_complex // " a%s " // a%is_sparse // & - " b%c " // b%is_complex // " b%s " // b%is_sparse ) - endif - end do - -end function TBMatrix_partial_TraceMult_spinor - - -function TBMatrix_Re_diag(a) - type(TBMatrix), intent(in) :: a - real(dp) :: TBMatrix_Re_diag(a%N, a%n_matrices) - - integer im - - do im=1, a%n_matrices - if (a%is_complex) then - TBMatrix_Re_diag(:,im) = Re_diag(a%data_z(im)) - else - TBMatrix_Re_diag(:,im) = Re_diag(a%data_d(im)) - endif - end do - -end function TBMatrix_Re_diag - -function TBMatrix_diag_spinor(a) - type(TBMatrix), intent(in) :: a - complex(dp) :: TBMatrix_diag_spinor(2,2,a%N/2, a%n_matrices) - - integer im - - do im=1, a%n_matrices - if (a%is_complex) then - TBMatrix_diag_spinor(:,:,:,im) = diag_spinor(a%data_z(im)) - else - TBMatrix_diag_spinor(:,:,:,im) = diag_spinor(a%data_d(im)) - endif - end do - -end function TBMatrix_diag_spinor - -subroutine TBMatrix_scaled_sum(this, f1_z, m1, f2, m2) - type(TBMatrix), intent(inout) :: this - complex(dp), intent(in) :: f1_z - type(TBMatrix), intent(in) :: m1 - real(dp), intent(in) :: f2 - type(TBMatrix), intent(in) :: m2 - - complex(dp) f2_z - - integer im - - if (this%is_sparse) call system_abort("No TBMatrix_scaled_sum for sparse matrices") - - f2_z = f2 - - do im=1, this%n_matrices - if (this%is_complex) then - if (m1%is_complex) then - if (m2%is_complex) then - call scaled_sum(this%data_z(im), f1_z, m1%data_z(im), f2_z, m2%data_z(im)) - else - ! call scaled_sum(this%data_z(im), f1_z, m1%data_z(im), f2_z, m2%data_d(im)) - call system_abort ("Can't do scaled sum for Z Z D") - endif - else - if (m2%is_complex) then - ! call scaled_sum(this%data_z(im), f1_z, m1%data_d(im), f2_z, m2%data_z(im)) - call system_abort ("Can't do scaled sum for Z D Z") - else - call scaled_sum(this%data_z(im), f1_z, m1%data_d(im), f2_z, m2%data_d(im)) - endif - endif - else - if (m1%is_complex) then - if (m2%is_complex) then - ! call scaled_sum(this%data_d(im), f1_z, m1%data_z(im), f2_z, m2%data_z(im)) - call system_abort ("Can't do scaled sum for D Z Z") - else - ! call scaled_sum(this%data_d(im), f1_z, m1%data_z(im), f2_z, m2%data_d(im)) - call system_abort ("Can't do scaled sum for D Z D") - endif - else - if (m2%is_complex) then - ! call scaled_sum(this%data_d(im), f1_z, m1%data_d(im), f2_z, m2%data_z(im)) - call system_abort ("Can't do scaled sum for D D Z") - else - ! call scaled_sum(this%data_d(im), f1_z, m1%data_d(im), f2_z, m2%data_d(im)) - call system_abort ("Can't do scaled sum for D D D") - endif - endif - endif - end do - -end subroutine TBMatrix_scaled_sum - -subroutine TBMatrix_scaled_accum(this, f1_z, m1) - type(TBMatrix), intent(inout) :: this - complex(dp), intent(in) :: f1_z - type(TBMatrix), intent(in) :: m1 - - integer im - - if (this%is_sparse) call system_abort("No TBMatrix_accum for sparse matrices") - - do im=1, this%n_matrices - if (this%is_complex) then - if (m1%is_complex) then - call scaled_accum(this%data_z(im), f1_z, m1%data_z(im)) - else - ! call scaled_accum(this%data_z(im), f1_z, m1%data_d(im)) - call system_abort ("Can't do scaled accum for Z D") - endif - else - if (m1%is_complex) then - call scaled_accum(this%data_d(im), f1_z, m1%data_z(im)) - else - ! call scaled_accum(this%data_d(im), f1_z, m1%data_d(im)) - call system_abort ("Can't do scaled accum for D D") - endif - endif - end do - -end subroutine TBMatrix_scaled_accum - -subroutine TBMatrix_inverse(this, inv, positive) - type(TBMatrix), intent(inout) :: this - type(TBMatrix), intent(out), optional :: inv - logical, intent(in), optional :: positive - - integer im - - if (this%is_sparse) call system_abort("No TBMatrix_inverse for sparse matrices") - - do im=1, this%n_matrices - if (this%is_complex) then - if (present(inv)) then - if (.not. (inv%is_complex)) then - call system_abort("Called TBMatrix_inverse with complex matrix but real inverse") - endif - call inverse(this%data_z(im), inv%data_z(im), positive) - else - call inverse(this%data_z(im), positive=positive) - endif - else - if (present(inv)) then - if (inv%is_complex) then - call system_abort("Called TBMatrix_inverse with real matrix but complex inverse") - endif - call inverse(this%data_d(im), inv%data_d(im), positive) - else - call inverse(this%data_d(im), positive=positive) - endif - endif - end do -end subroutine TBMatrix_inverse - -subroutine TBMatrix_multDiag(this, A, diag) - type(TBMatrix), intent(inout) :: this - type(TBMatrix), intent(in) :: A - type(TBVector), intent(in) :: diag - - integer im - - if (this%N /= diag%N) then - call system_abort("Called TBMatrix_multDiag with mismatched sizes") - endif - - if (this%is_sparse) call system_abort("No TBMatrix_multDiag for sparse matrices") - if (A%is_sparse) call system_abort("No TBMatrix_multDiag for sparse matrices") - - if ((this%is_complex .and. .not. A%is_complex) .or. & - (.not. this%is_complex .and. A%is_complex)) call system_abort ("TBMatrix_multDiag with mismatched types") - - do im=1, this%n_matrices - if (this%is_complex) then - if (diag%is_complex) then - call multDiag(this%data_z(im), A%data_z(im), diag%data_z(:,im)) - else - call multDiag(this%data_z(im), A%data_z(im), diag%data_d(:,im)) - endif - else - if (diag%is_complex) then - call system_abort("Can't TBMatrix_multDiag of a real matrix time complex diag") - else - call multDiag(this%data_d(im), A%data_d(im), diag%data_d(:,im)) - endif - endif - end do -end subroutine TBMatrix_multDiag - -subroutine TBMatrix_multDiag_d(this, A, diag) - type(TBMatrix), intent(inout) :: this - type(TBMatrix), intent(in) :: A - real(dp), intent(in) :: diag(:) - - integer im - - if (this%N /= size(diag)) then - call system_abort("Called TBMatrix_multDiag_d with mismatched sizes") - endif - - if (this%is_sparse) call system_abort("No TBMatrix_multDiag_d for sparse matrices") - if (A%is_sparse) call system_abort("No TBMatrix_multDiag_d for sparse matrices") - - if ((this%is_complex .and. .not. A%is_complex) .or. & - (.not. this%is_complex .and. A%is_complex)) call system_abort ("TBMatrix_multDiag_d with mismatched types") - - do im=1, this%n_matrices - if (this%is_complex) then - call multDiag(this%data_z(im), A%data_z(im), diag) - else - call multDiag(this%data_d(im), A%data_d(im), diag) - endif - end do -end subroutine TBMatrix_multDiag_d - - -subroutine TBMatrix_multDiag_z(this, A, diag) - type(TBMatrix), intent(inout) :: this - type(TBMatrix), intent(in) :: A - complex(dp), intent(in) :: diag(:) - - integer im - - if (this%N /= size(diag)) then - call system_abort("Called TBMatrix_multDiag_z with mismatched sizes") - endif - - if (this%is_sparse) call system_abort("No TBMatrix_multDiag_z for sparse matrices") - if (A%is_sparse) call system_abort("No TBMatrix_multDiag_z for sparse matrices") - - if ((this%is_complex .and. .not. A%is_complex) .or. & - (.not. this%is_complex .and. A%is_complex)) call system_abort ("TBMatrix_multDiag_z with mismatched types") - - do im=1, this%n_matrices - if (this%is_complex) then - call multDiag(this%data_z(im), A%data_z(im), diag) - else - call system_abort ("TBMatrix_multDiag_z Can't multiply a real matrix by a complex diag") - endif - end do -end subroutine TBMatrix_multDiag_z - -subroutine TBMatrix_multDiagRL_d(this, A, diag) - type(TBMatrix), intent(inout) :: this - type(TBMatrix), intent(in) :: A - real(dp) :: diag(:) - - integer im - - if (this%N /= size(diag)) & - call system_abort("Called TBMatrix_multDiagRL_d with mismatched sizes") - - if ((A%is_sparse .and. .not. this%is_sparse) .or. & - (.not. A%is_sparse .and. this%is_sparse)) & - call system_abort ("Called TBMatrix_multDiagRL_d with mismatched sparsity") - - if ((this%is_complex .and. .not. A%is_complex) .or. & - (.not. this%is_complex .and. A%is_complex)) call system_abort ("TBMatrix_multDiagRL_d with mismatched types") - - do im=1, this%n_matrices - if (this%is_sparse) then - if (this%is_complex) then - call multDiagRL(this%sdata_z(im), A%sdata_z(im), diag) - else - call multDiagRL(this%sdata_d(im), A%sdata_d(im), diag) - endif - else - if (this%is_complex) then - call multDiagRL(this%data_z(im), A%data_z(im), diag) - else - call multDiagRL(this%data_d(im), A%data_d(im), diag) - endif - endif - end do -end subroutine TBMatrix_multDiagRL_d - -subroutine TBMatrix_matrix_product_sub(C, A, B, A_transpose, A_conjugate, B_transpose, B_conjugate, & - diag_mask, offdiag_mask) - type(TBMatrix), intent(inout) :: C - type(TBMatrix), intent(in) :: A, B - logical, intent(in), optional :: A_transpose, A_conjugate, B_transpose, B_conjugate - logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) - - logical a_transp, a_conjg, b_transp, b_conjg - integer im - - if (C%N /= A%N .or. C%N /= B%N) call system_abort ("TBMatrix_matrix_product_sub with C vs A, B size mismatch" & - // C%N // " " // A%N // " " // B%N ) - - if (C%is_sparse .or. A%is_sparse) & - call system_abort("Can't do TBMatrix_matrix_product_sub C=A*B for sparse C or A matrices") - - a_transp = .false. - b_transp = .false. - a_conjg = .false. - b_conjg = .false. - if (present(a_transpose)) a_transp = a_transpose - if (present(b_transpose)) b_transp = b_transpose - if (present(a_conjugate)) a_conjg = a_conjugate - if (present(b_conjugate)) b_conjg = b_conjugate - - if (a_transp .and. a_conjg) then - call system_abort("TBMatrix_matrix_product_sub called with a_transp and a_conj both true") - endif - if (b_transp .and. b_conjg) then - call system_abort("TBMatrix_matrix_product_sub called with b_transp and b_conj both true") - endif - - do im=1, C%n_matrices - if (C%is_complex) then - if (A%is_complex) then - if (B%is_complex) then - if (B%is_sparse) then - call matrix_product_sub(C%data_z(im), A%data_z(im), B%sdata_z(im), a_transpose, a_conjugate, b_transpose, b_conjugate, & - diag_mask, offdiag_mask) - else - if (present(diag_mask) .or. present(offdiag_mask)) & - call system_abort("TBMatrix_matrix_product_sub can't use masks when B isn't sparse") - call matrix_product_sub(C%data_z(im), A%data_z(im), B%data_z(im), a_transpose, a_conjugate, b_transpose, b_conjugate) - endif - else ! B is real - if (B%is_sparse) then - call matrix_product_sub(C%data_z(im), A%data_z(im), B%sdata_d(im), a_transpose, a_conjugate, b_transp .or. b_conjg, & - diag_mask, offdiag_mask) - else - if (present(diag_mask) .or. present(offdiag_mask)) & - call system_abort("TBMatrix_matrix_product_sub can't use masks when B isn't sparse") - call matrix_product_sub(C%data_z(im), A%data_z(im), B%data_d(im), a_transpose, a_conjugate, b_transp .or. b_conjg) - endif - endif - else ! A is real - if (B%is_complex) then - if (B%is_sparse) then - call matrix_product_sub(C%data_z(im), A%data_d(im), B%sdata_z(im), a_transp .or. a_conjg, b_transpose, b_conjugate, & - diag_mask, offdiag_mask) - else - if (present(diag_mask) .or. present(offdiag_mask)) & - call system_abort("TBMatrix_matrix_product_sub can't use masks when B isn't sparse") - call matrix_product_sub(C%data_z(im), A%data_d(im), B%data_z(im), a_transp .or. a_conjg, b_transpose, b_conjugate) - endif - else - call system_abort ("No TBMatrix_matrix_product_sub for C = R R") - endif - endif - else ! C is real - if (A%is_complex) then - call system_abort("No TBMatrix_matrix_product for R = C * ?") - else ! A is real - if (B%is_complex) then - call system_abort("No TBMatrix_matrix_product for R = ?* C") - else ! B is real - if (B%is_sparse) then - call matrix_product_sub(C%data_d(im), A%data_d(im), B%sdata_d(im), a_transp .or. a_conjg, b_transp .or. b_conjg, & - diag_mask, offdiag_mask) - else - if (present(diag_mask) .or. present(offdiag_mask)) & - call system_abort("TBMatrix_matrix_product_sub can't use masks when B isn't sparse") - call matrix_product_sub(C%data_d(im), A%data_d(im), B%data_d(im), a_transp .or. a_conjg, b_transp .or. b_conjg) - endif - endif - endif - endif - end do -end subroutine TBMatrix_matrix_product_sub - -subroutine TBMatrix_matrix_product_sub_r2(C, A, B, a_transpose, a_conjugate, b_transpose) - type(TBMatrix), intent(inout) :: C - type(TBMatrix), intent(in) :: A - real(dp), intent(in) :: B(:,:) - logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose - - logical :: a_transp, a_conjg - - integer im - - a_transp = .false. - a_conjg = .false. - if (present(a_transpose)) a_transp = a_transpose - if (present(a_conjugate)) a_conjg = a_conjugate - - if (a_transp .and. a_conjg) call system_abort("Called TBMatrix_matrix_product_sub_r2 with a_transp and a_conjg") - - if (C%N /= A%N .or. C%N /= size(B,2)) call system_abort ("TBMatrix_matrix_product with C vs A, B size mismatch") - - if (C%is_sparse .or. A%is_sparse) & - call system_abort("Can't do TBMatrix_matrix_product_r2 for sparse matrices") - - do im=1, C%n_matrices - if (C%is_complex) then - call system_abort ("No TBMatrix_matrix_product for C = ? ?") - else ! C is real - if (A%is_complex) then - call system_abort ("No TBMatrix_matrix_product for R = C ?") - else - call matrix_product_sub(C%data_d(im), A%data_d(im), B, a_transp .or. a_conjg, b_transpose) - endif - endif - end do -end subroutine TBMatrix_matrix_product_sub_r2 - -subroutine TBMatrix_accum_scaled_elem_product(A, B, s, C) - type(TBMatrix), intent(in) :: A, B - complex(dp), intent(in) :: s - type(TBMatrix), intent(inout) :: C - - integer im - - if (A%N /= B%N .or. A%N /= C%N) & - call system_abort ("TBMatrix_accum_scaled_elem_product called with size mismatch") - if (A%n_matrices /= B%n_matrices .or. A%n_matrices /= C%n_matrices) & - call system_abort ("TBMatrix_accum_scaled_elem_product called with n_matrices mismatch") - - if (A%is_sparse .or. B%is_sparse .or. C%is_sparse) then - call system_abort ("TBMatrix_accum_scaled_elem_product called with sparse matrix") - endif - - do im=1, A%n_matrices - if (C%is_complex) then - call system_abort("No TBMatrix_accum_scaled_elem_product for complex C") - else - if (A%is_complex) then - if (B%is_complex) then - C%data_d(im)%data = C%data_d(im)%data + real(s * A%data_z(im)%data * B%data_z(im)%data) - else - call system_abort("No TBMatrix_accum_scaled_elem_product for real B") - endif - else - call system_abort("No TBMatrix_accum_scaled_elem_product for real A") - endif - - endif - end do -end subroutine TBMatrix_accum_scaled_elem_product - -subroutine TBMatrix_sum_matrices_d(this, weights, m) - type(TBMatrix), intent(in) :: this - real(dp), intent(in) :: weights(:) - type(MatrixD), intent(inout) :: m - - integer im - - if (this%N /= m%N .or. this%N /= m%M) call system_abort("TBMatrix_sum_matrices_d called with size mismatch") - if (this%n_matrices /= size(weights)) call system_abort("TBMatrix_sum_matrices_d called with n_matrices mismatch") - - if (this%is_sparse) call system_abort("Can't do TBMatrix_sum_matrices_d on a sparse TBMatrix") - - m%data = 0.0_dp - - do im=1, this%n_matrices - if (this%is_complex) then - m%data = m%data + weights(im)*this%data_z(im)%data - else - m%data = m%data + weights(im)*this%data_d(im)%data - endif - end do -end subroutine TBMatrix_sum_matrices_d - -subroutine TBMatrix_transpose_sub(this, m) - type(TBMatrix), intent(inout) :: this - type(TBMatrix), intent(in) :: m - - integer im - - if (this%N /= m%N) call system_abort("TBMatrix_transpose_sub called with size mismatch") - if (this%n_matrices /= m%n_matrices) call system_abort("TBMatrix_transpose_sub called with n_matrices mismatch") - - if (this%is_sparse .or. m%is_sparse) call system_abort("Can't do TBMatrix_transpose_sub on a sparse TBMatrix") - - do im=1, this%n_matrices - if (this%is_complex) then - if (m%is_complex) then - call transpose_sub(this%data_z(im), m%data_z(im)) - else - call system_abort("Can't TBMatrix_transpose_sub from real matrix into complex") - ! call transpose_sub(this%data_z(im), m%data_d(im)) - endif - else - if (m%is_complex) then - ! call transpose_sub(this%data_d(im), m%data_z(im)) - call system_abort("Can't TBMatrix_transpose_sub from complex matrix into real") - else - call transpose_sub(this%data_d(im), m%data_d(im)) - endif - endif - end do - -end subroutine TBMatrix_transpose_sub - -subroutine TBMatrix_make_hermitian(this) - type(TBMatrix), intent(inout) :: this - - integer :: im - - if (this%is_sparse) call system_abort("Can't do TBMatrix_make_hermitian on a sparse TBMatrix") - - do im=1, this%n_matrices - if (this%is_complex) then - call make_hermitian(this%data_z(im)) - else - call make_hermitian(this%data_d(im)) - endif - end do - -end subroutine TBMatrix_make_hermitian - -end module TBMatrix_module diff --git a/src/Potentials/TBModel.f95 b/src/Potentials/TBModel.f95 deleted file mode 100644 index 6a71cd2139..0000000000 --- a/src/Potentials/TBModel.f95 +++ /dev/null @@ -1,674 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X TBModel module -!X -!% General object which handles the possible TB scheme, addressing -!% the calls to the right modules. -!% The available models are the following -!% \begin{itemize} -!% \item "NRL_TB", whose related object is \texttt{TBModel_NRL_TB} -!% \item "Bowler", whose related object is \texttt{TBModel_Bowler} -!% \item "DFTB" , whose related object is \texttt{TBModel_DFTB} -!% \item "GSP" , whose related object is \texttt{TBModel_GSP} -!% \end{itemize} -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module TBModel_module - -use system_module, only : dp, print, inoutput, PRINT_VERBOSE, system_abort, operator(//) -use dictionary_module -use paramreader_module -use atoms_module - -use QUIP_Common_module -use TBModel_NRL_TB_module -use TBModel_Bowler_module -use TBModel_DFTB_module -use TBModel_GSP_module - -implicit none -private - -integer, parameter :: FF_NONE = 0, FF_NRL_TB = 1, FF_Bowler = 2, FF_DFTB = 3, FF_GSP = 4 -character(len=6) :: ff_names(0:4) = (/ & - 'NONE ', & - 'NRL_TB', & - 'Bowler', & - 'DFTB ', & - 'GSP '/) - -include 'TBModel_interface.h' - -public :: TBModel -type TBModel - real(dp) cutoff - - logical is_orthogonal - integer :: functional_form = FF_NONE - - type(TBModel_NRL_TB) tbmodel_nrl_tb - type(TBModel_Bowler) tbmodel_bowler - type(TBModel_DFTB) tbmodel_dftb - type(TBModel_GSP) tbmodel_gsp - - logical :: has_default_fermi_E, has_default_fermi_T, has_default_band_width, has_default_k_density - real(dp) :: default_fermi_E, default_fermi_T, default_band_width, default_k_density - -end type TBModel - -interface Initialise - module procedure TBModel_Initialise_str -end interface Initialise - -interface Finalise - module procedure TBModel_Finalise -end interface Finalise - -interface Print - module procedure TBModel_Print -end interface Print - -interface n_orbs_of_Z - module procedure TBModel_n_orbs_of_Z -end interface n_orbs_of_Z - -interface n_orb_sets_of_Z - module procedure TBModel_n_orb_sets_of_Z -end interface n_orb_sets_of_Z - -interface n_orbs_of_orb_set_of_Z - module procedure TBModel_n_orbs_of_orb_set_of_Z -end interface n_orbs_of_orb_set_of_Z - -interface orb_type_of_orb_set_of_Z - module procedure TBModel_orb_type_of_orb_set_of_Z -end interface orb_type_of_orb_set_of_Z - -interface n_elecs_of_Z - module procedure TBModel_n_elecs_of_Z -end interface n_elecs_of_Z - -interface get_HS_blocks - module procedure TBModel_get_HS_blocks -end interface get_HS_blocks - -interface get_dHS_masks - module procedure TBModel_get_dHS_masks -end interface get_dHS_masks - -interface get_dHS_blocks - module procedure TBModel_get_dHS_blocks -end interface get_dHS_blocks - -interface get_local_rep_E - module procedure TBModel_get_local_rep_E -end interface get_local_rep_E - -interface get_local_rep_E_force - module procedure TBModel_get_local_rep_E_force -end interface get_local_rep_E_force - -interface get_local_rep_E_virial - module procedure TBModel_get_local_rep_E_virial -end interface get_local_rep_E_virial - -public :: has_fermi_E -interface has_fermi_E - module procedure TBModel_has_fermi_E -end interface has_fermi_E - -public :: has_fermi_T -interface has_fermi_T - module procedure TBModel_has_fermi_T -end interface has_fermi_T - -public :: has_band_width -interface has_band_width - module procedure TBModel_has_band_width -end interface has_band_width - -public :: has_k_density -interface has_k_density - module procedure TBModel_has_k_density -end interface has_k_density - -contains - -subroutine TBModel_Initialise_str(this, args_str, param_str) - type(TBModel), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - logical :: is_nrl_tb, is_bowler, is_dftb, is_gsp - real(dp) :: str_fermi_e, str_fermi_T, str_band_width, str_k_density - logical, target :: has_str_fermi_e, has_str_fermi_T, has_str_band_width, has_str_k_density - - call Initialise(params) - call param_register(params, 'NRL-TB', 'false', is_nrl_tb, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'Bowler', 'false', is_bowler, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'DFTB', 'false', is_dftb, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'GSP', 'false', is_gsp, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'fermi_e', '0.0', str_fermi_e, has_value_target=has_str_fermi_e, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'fermi_T', '0.0', str_fermi_T, has_value_target=has_str_fermi_T, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'band_width', '0.0', str_band_width, has_value_target=has_str_band_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'k_density', '0.0', str_k_density, has_value_target=has_str_k_density, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_Initialise_str args_str')) then - call system_abort("TBModel_Initialise_str failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - - if (count((/is_nrl_tb, is_bowler, is_dftb, is_gsp/)) /= 1) then - call system_abort("TBModel_Initialise_str found too few or too many TB Model types args_str='"//trim(args_str)//"'") - endif - - if (is_nrl_tb) then - this%functional_form = FF_NRL_TB - call Initialise(this%tbmodel_nrl_tb, args_str, param_str) - this%cutoff=this%tbmodel_nrl_tb%cutoff - this%is_orthogonal = this%tbmodel_nrl_tb%is_orthogonal - this%has_default_fermi_e = this%tbmodel_nrl_tb%has_default_fermi_e - this%has_default_fermi_T = this%tbmodel_nrl_tb%has_default_fermi_T - this%has_default_band_width = this%tbmodel_nrl_tb%has_default_band_width - this%has_default_k_density = this%tbmodel_nrl_tb%has_default_k_density - this%default_fermi_e = this%tbmodel_nrl_tb%default_fermi_e - this%default_fermi_T = this%tbmodel_nrl_tb%default_fermi_T - this%default_band_width = this%tbmodel_nrl_tb%default_band_width - this%default_k_density = this%tbmodel_nrl_tb%default_k_density - else if (is_bowler) then - this%functional_form = FF_Bowler - call Initialise(this%tbmodel_bowler, args_str, param_str) - this%cutoff=this%tbmodel_bowler%cutoff - this%is_orthogonal = this%tbmodel_bowler%is_orthogonal - this%has_default_fermi_e = this%tbmodel_bowler%has_default_fermi_e - this%has_default_fermi_T = this%tbmodel_bowler%has_default_fermi_T - this%has_default_band_width = this%tbmodel_bowler%has_default_band_width - this%has_default_k_density = this%tbmodel_bowler%has_default_k_density - this%default_fermi_e = this%tbmodel_bowler%default_fermi_e - this%default_fermi_T = this%tbmodel_bowler%default_fermi_T - this%default_band_width = this%tbmodel_bowler%default_band_width - this%default_k_density = this%tbmodel_bowler%default_k_density - else if(is_dftb) then - this%functional_form = FF_DFTB - call Initialise(this%tbmodel_dftb, args_str, param_str) - this%cutoff=this%tbmodel_dftb%cutoff - this%is_orthogonal = this%tbmodel_dftb%is_orthogonal - this%has_default_fermi_e = this%tbmodel_dftb%has_default_fermi_e - this%has_default_fermi_T = this%tbmodel_dftb%has_default_fermi_T - this%has_default_band_width = this%tbmodel_dftb%has_default_band_width - this%has_default_k_density = this%tbmodel_dftb%has_default_k_density - this%default_fermi_e = this%tbmodel_dftb%default_fermi_e - this%default_fermi_T = this%tbmodel_dftb%default_fermi_T - this%default_band_width = this%tbmodel_dftb%default_band_width - this%default_k_density = this%tbmodel_dftb%default_k_density - else if (is_gsp) then - this%functional_form = FF_GSP - call Initialise(this%tbmodel_gsp, args_str, param_str) - this%cutoff=this%tbmodel_gsp%cutoff - this%is_orthogonal = this%tbmodel_gsp%is_orthogonal - this%has_default_fermi_e = this%tbmodel_gsp%has_default_fermi_e - this%has_default_fermi_T = this%tbmodel_gsp%has_default_fermi_T - this%has_default_band_width = this%tbmodel_gsp%has_default_band_width - this%has_default_k_density = this%tbmodel_gsp%has_default_k_density - this%default_fermi_e = this%tbmodel_gsp%default_fermi_e - this%default_fermi_T = this%tbmodel_gsp%default_fermi_T - this%default_band_width = this%tbmodel_gsp%default_band_width - this%default_k_density = this%tbmodel_gsp%default_k_density - end if - - if (has_str_fermi_e) then - this%has_default_fermi_e = .true. - this%default_fermi_e = str_fermi_e - endif - if (has_str_fermi_T) then - this%has_default_fermi_T = .true. - this%default_fermi_T = str_fermi_T - endif - if (has_str_band_width) then - this%has_default_band_width = .true. - this%default_band_width = str_band_width - endif - if (has_str_k_density) then - this%has_default_k_density = .true. - this%default_k_density = str_k_density - endif - -end subroutine TBModel_Initialise_str - -subroutine TBModel_Finalise(this) - type(TBModel), intent(inout) :: this - - select case(this%functional_form) - case (FF_NRL_TB) - call Finalise(this%tbmodel_nrl_tb) - case (FF_Bowler) - call Finalise(this%tbmodel_bowler) - case (FF_DFTB) - call Finalise(this%tbmodel_dftb) - case (FF_GSP) - call Finalise(this%tbmodel_gsp) - case (FF_NONE) - return - case default - call system_abort ('TBModel_Finalise confused by functional_form' // this%functional_form) - end select - -end subroutine TBModel_Finalise - -function TBModel_n_orbs_of_Z(this, Z) - type(TBModel), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_n_orbs_of_Z - - select case(this%functional_form) - case (FF_NRL_TB) - TBModel_n_orbs_of_Z = n_orbs_of_Z(this%tbmodel_nrl_tb,Z) - case (FF_Bowler) - TBModel_n_orbs_of_Z = n_orbs_of_Z(this%tbmodel_bowler,Z) - case (FF_DFTB) - TBModel_n_orbs_of_Z = n_orbs_of_Z(this%tbmodel_dftb,Z) - case (FF_GSP) - TBModel_n_orbs_of_Z = n_orbs_of_Z(this%tbmodel_gsp,Z) - case default - call system_abort ('TBModel_n_orbs_of_Z confused by functional_form' // this%functional_form) - end select - -end function TBModel_n_orbs_of_Z - -function TBModel_n_orb_sets_of_Z(this, Z) - type(TBModel), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_n_orb_sets_of_Z - - select case(this%functional_form) - case (FF_NRL_TB) - TBModel_n_orb_sets_of_Z = n_orb_sets_of_Z(this%tbmodel_nrl_tb,Z) - case (FF_Bowler) - TBModel_n_orb_sets_of_Z = n_orb_sets_of_Z(this%tbmodel_bowler,Z) - case (FF_DFTB) - TBModel_n_orb_sets_of_Z = n_orb_sets_of_Z(this%tbmodel_dftb,Z) - case (FF_GSP) - TBModel_n_orb_sets_of_Z = n_orb_sets_of_Z(this%tbmodel_gsp,Z) - case default - call system_abort ('TBModel_n_orb_sets_of_Z confused by functional_form' // this%functional_form) - end select - -end function TBModel_n_orb_sets_of_Z - -function TBModel_n_orbs_of_orb_set_of_Z(this, Z, i_set) - type(TBModel), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_n_orbs_of_orb_set_of_Z - - select case(this%functional_form) - case (FF_NRL_TB) - TBModel_n_orbs_of_orb_set_of_Z = n_orbs_of_orb_set_of_Z(this%tbmodel_nrl_tb,Z,i_set) - case (FF_Bowler) - TBModel_n_orbs_of_orb_set_of_Z = n_orbs_of_orb_set_of_Z(this%tbmodel_bowler,Z,i_set) - case (FF_DFTB) - TBModel_n_orbs_of_orb_set_of_Z = n_orbs_of_orb_set_of_Z(this%tbmodel_dftb,Z,i_set) - case (FF_GSP) - TBModel_n_orbs_of_orb_set_of_Z = n_orbs_of_orb_set_of_Z(this%tbmodel_gsp,Z,i_set) - case default - call system_abort ('TBModel_n_orbs_of_orb_set_of_Z confused by functional_form' // this%functional_form) - end select - -end function TBModel_n_orbs_of_orb_set_of_Z - -function TBModel_orb_type_of_orb_set_of_Z(this, Z, i_set) - type(TBModel), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_orb_type_of_orb_set_of_Z - - select case(this%functional_form) - case (FF_NRL_TB) - TBModel_orb_type_of_orb_set_of_Z = orb_type_of_orb_set_of_Z(this%tbmodel_nrl_tb,Z,i_set) - case (FF_Bowler) - TBModel_orb_type_of_orb_set_of_Z = orb_type_of_orb_set_of_Z(this%tbmodel_bowler,Z,i_set) - case (FF_DFTB) - TBModel_orb_type_of_orb_set_of_Z = orb_type_of_orb_set_of_Z(this%tbmodel_dftb,Z,i_set) - case (FF_GSP) - TBModel_orb_type_of_orb_set_of_Z = orb_type_of_orb_set_of_Z(this%tbmodel_gsp,Z,i_set) - case default - call system_abort ('TBModel_orb_type_of_orb_set_of_Z confused by functional_form' // this%functional_form) - end select - -end function TBModel_orb_type_of_orb_set_of_Z - -function TBModel_n_elecs_of_Z(this, Z) - type(TBModel), intent(in) :: this - integer, intent(in) :: Z - real(dp) TBModel_n_elecs_of_Z - - select case(this%functional_form) - case (FF_NRL_TB) - TBModel_n_elecs_of_Z = n_elecs_of_Z(this%tbmodel_nrl_tb,Z) - case (FF_Bowler) - TBModel_n_elecs_of_Z = n_elecs_of_Z(this%tbmodel_bowler,Z) - case (FF_DFTB) - TBModel_n_elecs_of_Z = n_elecs_of_Z(this%tbmodel_dftb,Z) - case (FF_GSP) - TBModel_n_elecs_of_Z = n_elecs_of_Z(this%tbmodel_gsp,Z) - case default - call system_abort ('TBModel_n_elecs_of_Z confused by functional_form' // this%functional_form) - end select - -end function TBModel_n_elecs_of_Z - -subroutine TBModel_Print(this,file) - type(TBModel), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - call print("TBModel: is_orthogonal " // this%is_orthogonal, PRINT_VERBOSE) - call print("TBModel: functional_form " // ff_names(this%functional_form), PRINT_VERBOSE) - call print("TBModel: has_default_fermi_e " // this%has_default_fermi_e // " default_fermi_e " // & - this%default_fermi_e, PRINT_VERBOSE) - call print("TBModel: has_default_fermi_T " // this%has_default_fermi_T // " default_fermi_T " // & - this%default_fermi_T, PRINT_VERBOSE) - call print("TBModel: has_default_band_width " // this%has_default_band_width // " default_band_width " // & - this%default_band_width, PRINT_VERBOSE) - call print("TBModel: has_default_k_density " // this%has_default_k_density // " default_k_density " // & - this%default_k_density, PRINT_VERBOSE) - - select case(this%functional_form) - case (FF_NRL_TB) - call Print(this%tbmodel_nrl_tb, file=file) - case (FF_Bowler) - call Print(this%tbmodel_bowler, file=file) - case (FF_DFTB) - call Print(this%tbmodel_dftb, file=file) - case (FF_GSP) - call Print(this%tbmodel_gsp, file=file) - case default - call system_abort ('TBModel_Print confused by functional_form' // this%functional_form) - end select - -end subroutine - -subroutine TBModel_get_HS_blocks(this, at, i, j, dv_hat, dv_mag, b_H, b_S, i_mag) - type(TBModel), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i, j - real(dp), intent(in) :: dv_hat(3), dv_mag - real(dp), intent(out) :: b_H(:,:), b_S(:,:) - integer, intent(in), optional :: i_mag - - select case(this%functional_form) - case (FF_NRL_TB) - call get_HS_blocks(this%tbmodel_nrl_tb, at, i, j, dv_hat, dv_mag, b_H, b_S, i_mag) - case (FF_Bowler) - call get_HS_blocks(this%tbmodel_bowler, at, i, j, dv_hat, dv_mag, b_H, b_S, i_mag) - case (FF_DFTB) - call get_HS_blocks(this%tbmodel_dftb, at, i, j, dv_hat, dv_mag, b_H, b_S, i_mag) - case (FF_GSP) - call get_HS_blocks(this%tbmodel_gsp, at, i, j, dv_hat, dv_mag, b_H, b_S) - case default - call system_abort ('TBModel_get_HS_blocks confused by functional_form' // this%functional_form) - end select - -end subroutine - -subroutine TBModel_get_dHS_masks(this, at, at_ind, d_mask, od_mask) - type(TBModel), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_ind - logical, intent(out), optional :: d_mask(:), od_mask(:) - - select case(this%functional_form) - case (FF_NRL_TB) - call get_dHS_masks(this%tbmodel_nrl_tb, at, at_ind, d_mask, od_mask) - case (FF_Bowler) - call get_dHS_masks(this%tbmodel_bowler, at, at_ind, d_mask, od_mask) - case (FF_DFTB) - call get_dHS_masks(this%tbmodel_dftb, at, at_ind, d_mask, od_mask) - case (FF_GSP) - call get_dHS_masks(this%tbmodel_gsp, at_ind, d_mask, od_mask) - case default - call system_abort ('TBModel_get_HS_masks confused by functional_form' // this%functional_form) - end select - -end subroutine - -function TBModel_get_dHS_blocks(this, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) - type(TBModel), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i, j - real(dp), intent(in) :: dv_hat(3), dv_mag - integer, intent(in) :: at_ind - real(dp), intent(out) :: b_dH(:,:,:), b_dS(:,:,:) - integer, intent(in), optional :: i_mag - logical TBModel_get_dHS_blocks - - select case(this%functional_form) - case (FF_NRL_TB) - TBModel_get_dHS_blocks = get_dHS_blocks(this%tbmodel_nrl_tb, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) - case (FF_Bowler) - TBModel_get_dHS_blocks = get_dHS_blocks(this%tbmodel_bowler, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) - case (FF_DFTB) - TBModel_get_dHS_blocks = get_dHS_blocks(this%tbmodel_dftb, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) - case (FF_GSP) - TBModel_get_dHS_blocks = get_dHS_blocks(this%tbmodel_gsp, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS) - case default - call system_abort ('TBModel_get_HS_blocks confused by functional_form' // this%functional_form) - end select - -end function TBModel_get_dHS_blocks - -function TBModel_get_local_rep_E(this, at, i) - type(TBModel), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: TBModel_get_local_rep_E - - select case(this%functional_form) - case (FF_NRL_TB) - TBModel_get_local_rep_E = get_local_rep_E(this%tbmodel_nrl_tb, at, i) - case (FF_Bowler) - TBModel_get_local_rep_E = get_local_rep_E(this%tbmodel_bowler, at, i) - case (FF_DFTB) - TBModel_get_local_rep_E = get_local_rep_E(this%tbmodel_dftb, at, i) - case (FF_GSP) - TBModel_get_local_rep_E = get_local_rep_E(this%tbmodel_gsp, at, i) - case default - call system_abort ('TBModel_get_local_rep_E confused by functional_form' // this%functional_form) - end select -end function TBModel_get_local_rep_E - -function TBModel_get_local_rep_E_force(this, at, i) result(force) - type(TBModel), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: force(3,at%N) - - select case(this%functional_form) - case (FF_NRL_TB) - force = get_local_rep_E_force(this%tbmodel_nrl_tb, at, i) - case (FF_Bowler) - force = get_local_rep_E_force(this%tbmodel_bowler, at, i) - case (FF_DFTB) - force = get_local_rep_E_force(this%tbmodel_dftb, at, i) - case (FF_GSP) - force = get_local_rep_E_force(this%tbmodel_gsp, at, i) - case default - call system_abort ('TBModel_get_local_rep_E_force confused by functional_form' // this%functional_form) - end select -end function TBModel_get_local_rep_E_force - -function TBModel_get_local_rep_E_virial(this, at, i) result(virial) - type(TBModel), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: virial(3,3) - - select case(this%functional_form) - case (FF_NRL_TB) - virial = get_local_rep_E_virial(this%tbmodel_nrl_tb, at, i) - case (FF_Bowler) - virial = get_local_rep_E_virial(this%tbmodel_bowler, at, i) - case (FF_DFTB) - virial = get_local_rep_E_virial(this%tbmodel_dftb, at, i) - case (FF_GSP) - virial = get_local_rep_E_virial(this%tbmodel_gsp, at, i) - case default - call system_abort ('TBModel_get_local_rep_E_virial confused by functional_form' // this%functional_form) - end select -end function TBModel_get_local_rep_E_virial - -function TBModel_has_Fermi_E(out_Fermi_E, this, Fermi_E, args_str) - real(dp), intent(out) :: out_Fermi_E - type(TBModel), intent(in) :: this - real(dp), optional, intent(in) :: Fermi_E - character(len=*), optional, intent(in) :: args_str - logical :: TBModel_has_Fermi_E - - type(Dictionary) :: params - logical :: has_str_fermi_e - - TBModel_has_Fermi_E = .false. - if (present(Fermi_E)) then - out_Fermi_E = Fermi_E - TBModel_has_Fermi_E = .true. - else - if (this%has_default_fermi_E) then - out_Fermi_E = this%default_Fermi_E - TBModel_has_Fermi_E = .true. - endif - if (present(args_str)) then - call initialise(params) - call param_register(params, 'fermi_e', ''//out_fermi_E, out_fermi_E, has_value_target=has_str_fermi_e, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_has_Fermi_E args_str')) then - call system_abort("TBModel_has_fermi_e failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - if (has_str_fermi_e) TBModel_has_fermi_E = .true. - endif - endif - -end function TBModel_has_Fermi_E - -function TBModel_has_Fermi_T(out_Fermi_T, this, Fermi_T, args_str) - real(dp), intent(out) :: out_Fermi_T - type(TBModel), intent(in) :: this - real(dp), optional, intent(in) :: Fermi_T - character(len=*), optional, intent(in) :: args_str - logical :: TBModel_has_Fermi_T - - type(Dictionary) :: params - logical :: has_str_fermi_T - - TBModel_has_Fermi_T = .false. - if (present(Fermi_T)) then - out_Fermi_T = Fermi_T - TBModel_has_Fermi_T = .true. - else - if (this%has_default_fermi_T) then - out_Fermi_T = this%default_Fermi_T - TBModel_has_Fermi_T = .true. - endif - if (present(args_str)) then - call initialise(params) - call param_register(params, 'fermi_T', ''//out_fermi_T, out_fermi_T, has_value_target=has_str_fermi_T, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_has_Fermi_T args_str')) then - call system_abort("TBModel_has_fermi_T failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - if (has_str_fermi_T) TBModel_has_fermi_T = .true. - endif - endif - -end function TBModel_has_Fermi_T - -function TBModel_has_band_width(out_band_width, this, band_width, args_str) - real(dp), intent(out) :: out_band_width - type(TBModel), intent(in) :: this - real(dp), optional, intent(in) :: band_width - character(len=*), optional, intent(in) :: args_str - logical :: TBModel_has_band_width - - type(Dictionary) :: params - logical :: has_str_band_width - - TBModel_has_band_width = .false. - if (present(band_width)) then - out_band_width = band_width - TBModel_has_band_width = .true. - else - if (this%has_default_band_width) then - out_band_width = this%default_band_width - TBModel_has_band_width = .true. - endif - if (present(args_str)) then - call initialise(params) - call param_register(params, 'band_width', ''//out_band_width, out_band_width, has_value_target=has_str_band_width, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_has_band_width args_str')) then - call system_abort("TBModel_has_band_width failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - if (has_str_band_width) TBModel_has_band_width = .true. - endif - endif - -end function TBModel_has_band_width - -function TBModel_has_k_density(out_k_density, this, k_density, args_str) - real(dp), intent(out) :: out_k_density - type(TBModel), intent(in) :: this - real(dp), optional, intent(in) :: k_density - character(len=*), optional, intent(in) :: args_str - logical :: TBModel_has_k_density - - type(Dictionary) :: params - logical :: has_str_k_density - - TBModel_has_k_density = .false. - if (present(k_density)) then - out_k_density = k_density - TBModel_has_k_density = .true. - else - if (this%has_default_k_density) then - out_k_density = this%default_k_density - TBModel_has_k_density = .true. - endif - if (present(args_str)) then - call initialise(params) - call param_register(params, 'k_density', ''//out_k_density, out_k_density, has_value_target=has_str_k_density, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_has_k_density args_str')) then - call system_abort("TBModel_has_k_density failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - if (has_str_k_density) TBModel_has_k_density = .true. - endif - endif - -end function TBModel_has_k_density - -end module TBModel_module diff --git a/src/Potentials/TBModel_Bowler.f95 b/src/Potentials/TBModel_Bowler.f95 deleted file mode 100644 index 1f02d1464c..0000000000 --- a/src/Potentials/TBModel_Bowler.f95 +++ /dev/null @@ -1,1089 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X TBModel_Bowler module -!X -!% Calculate energies using Bowler tight-binding model -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module TBModel_Bowler_module - -use system_module, only : dp, print, inoutput, system_abort, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use spline_module -use atoms_module - -use TB_Common_module -use QUIP_Common_module - -implicit none -private - -integer, parameter :: max_n_orb_sets = 2 - -include 'TBModel_interface.h' - -public :: TBModel_Bowler -type TBModel_Bowler - integer :: n_types = 0 - character(len=STRING_LENGTH) label - - real(dp) :: cutoff = 0.0_dp - logical :: is_orthogonal = .true. - - integer, allocatable :: type_of_atomic_num(:) - integer, allocatable :: n_orbs(:), n_elecs(:), n_orb_sets(:), orb_set_type(:,:) - integer, allocatable :: atomic_num(:) - - !! Bowler parameters - real(dp), allocatable :: H_coeff(:,:,:), Vrep(:,:) - real(dp), allocatable :: r0(:,:), rc(:,:), n(:,:), nc(:,:), dc(:,:), m(:,:), mc(:,:) - real(dp) :: tailx0 - - real(dp), allocatable :: E(:,:) - - type(spline), allocatable :: H_tail_spline(:,:) - type(spline), allocatable :: Vrep_tail_spline(:,:) - - logical :: has_default_fermi_E = .false., has_default_fermi_T = .true., has_default_band_width = .false., has_default_k_density=.false. - real(dp) :: default_fermi_E, default_fermi_T = 0.001_dp, default_band_width, default_k_density - -end type - -integer, private :: parse_cur_type -logical, private :: parse_in_tbm, parse_matched_label -type(TBModel_Bowler), private, pointer :: parse_tbm - -interface Initialise - module procedure TBModel_Bowler_Initialise_str -end interface Initialise - -interface Finalise - module procedure TBModel_Bowler_Finalise -end interface Finalise - -interface Print - module procedure TBModel_Bowler_Print -end interface Print - -interface n_orbs_of_Z - module procedure TBModel_Bowler_n_orbs_of_Z -end interface n_orbs_of_Z - -interface n_orb_sets_of_Z - module procedure TBModel_Bowler_n_orb_sets_of_Z -end interface n_orb_sets_of_Z - -interface n_orbs_of_orb_set_of_Z - module procedure TBModel_Bowler_n_orbs_of_orb_set_of_Z -end interface n_orbs_of_orb_set_of_Z - -interface orb_type_of_orb_set_of_Z - module procedure TBModel_Bowler_orb_type_of_orb_set_of_Z -end interface orb_type_of_orb_set_of_Z - -interface n_elecs_of_Z - module procedure TBModel_Bowler_n_elecs_of_Z -end interface n_elecs_of_Z - -interface get_HS_blocks - module procedure TBModel_Bowler_get_HS_blocks -end interface get_HS_blocks - -interface get_dHS_masks - module procedure TBModel_Bowler_get_dHS_masks -end interface get_dHS_masks - -interface get_dHS_blocks - module procedure TBModel_Bowler_get_dHS_blocks -end interface get_dHS_blocks - -interface get_local_rep_E - module procedure TBModel_Bowler_get_local_rep_E -end interface get_local_rep_E - -interface get_local_rep_E_force - module procedure TBModel_Bowler_get_local_rep_E_force -end interface get_local_rep_E_force - -interface get_local_rep_E_virial - module procedure TBModel_Bowler_get_local_rep_E_virial -end interface get_local_rep_E_virial - -interface calc_H_coeff - module procedure TBModel_Bowler_calc_H_coeff -end interface calc_H_coeff - -interface calc_H_coeff_deriv - module procedure TBModel_Bowler_calc_H_coeff_deriv -end interface calc_H_coeff_deriv - -contains - -subroutine TBModel_Bowler_Initialise_str(this, args_str, param_str) - type(TBModel_Bowler), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_Bowler_Initialise_str args_str')) then - call system_abort("TBModel_Bowler_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call TBModel_Bowler_read_params_xml(this, param_str) -end subroutine TBModel_Bowler_Initialise_str - -subroutine TBModel_Bowler_Finalise(this) - type(TBModel_Bowler), intent(inout) :: this - - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%n_orbs)) deallocate(this%n_orbs) - if (allocated(this%n_elecs)) deallocate(this%n_elecs) - if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) - if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - - if (allocated(this%H_coeff)) deallocate(this%H_coeff) - if (allocated(this%Vrep)) deallocate(this%Vrep) - - if (allocated(this%r0)) deallocate(this%r0) - if (allocated(this%rc)) deallocate(this%rc) - if (allocated(this%n)) deallocate(this%n) - if (allocated(this%nc)) deallocate(this%nc) - if (allocated(this%dc)) deallocate(this%dc) - if (allocated(this%m)) deallocate(this%m) - if (allocated(this%mc)) deallocate(this%mc) - - if (allocated(this%E)) deallocate(this%E) - - if (allocated(this%H_tail_spline)) deallocate(this%H_tail_spline) - if (allocated(this%Vrep_tail_spline)) deallocate(this%Vrep_tail_spline) - - this%n_types = 0 - this%label = '' -end subroutine TBModel_Bowler_Finalise - -subroutine TBM_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - character(len=1024) :: value - integer status - integer ti, tj, Zi, Zj - - if (name == 'Bowler_params') then ! new Bowler stanza - - if (parse_in_tbm) & - call system_abort("IPModel_startElement_handler entered Bowler_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_tbm%label)) > 0) then ! we were passed in a label - if (value == parse_tbm%label) then ! exact match - parse_matched_label = .true. - parse_in_tbm = .true. - else ! no match - parse_in_tbm = .false. - endif - else ! no label passed in - parse_in_tbm = .true. - endif - - if (parse_in_tbm) then - if (parse_tbm%n_types /= 0) then - call finalise(parse_tbm) - endif - - parse_cur_type = 1 - - call QUIP_FoX_get_value(attributes, "n_types", value, status); - if (status == 0) read (value, *) parse_tbm%n_types - call QUIP_FoX_get_value(attributes, "tailx0", value, status); - if (status == 0) read (value, *) parse_tbm%tailx0 - call QUIP_FoX_get_value(attributes, "cutoff", value, status); - if (status == 0) read (value, *) parse_tbm%cutoff - - allocate(parse_tbm%atomic_num(parse_tbm%n_types)) - parse_tbm%atomic_num = 0 - allocate(parse_tbm%n_orbs(parse_tbm%n_types)) - allocate(parse_tbm%n_elecs(parse_tbm%n_types)) - allocate(parse_tbm%n_orb_sets(parse_tbm%n_types)) - allocate(parse_tbm%orb_set_type(max_n_orb_sets,parse_tbm%n_types)) - allocate(parse_tbm%E(max_n_orb_sets,parse_tbm%n_types)) - - allocate(parse_tbm%H_coeff(4, parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%Vrep(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%rc(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%r0(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%n(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%nc(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%dc(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%m(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%mc(parse_tbm%n_types, parse_tbm%n_types)) - - parse_tbm%H_coeff = 0.0_dp - parse_tbm%Vrep = 0.0_dp - parse_tbm%rc = 1.0_dp - parse_tbm%r0 = 0.0_dp - parse_tbm%n = 0.0_dp - parse_tbm%nc = 0.0_dp - parse_tbm%dc = 1.0_dp - parse_tbm%m = 0.0_dp - parse_tbm%mc = 0.0_dp - endif - - elseif (parse_in_tbm .and. name == 'per_type_data') then - if (parse_cur_type > parse_tbm%n_types) & - call system_abort('Too many types defined in Bowler_params') - - call QUIP_FoX_get_value(attributes, "Z", value, status); - if (status == 0) read (value, *) parse_tbm%atomic_num(parse_cur_type) - - call QUIP_FoX_get_value(attributes, "n_orbs", value, status); - if (status == 0) read (value, *) parse_tbm%n_orbs(parse_cur_type) - if (parse_tbm%n_orbs(parse_cur_type) == 1) then - parse_tbm%n_orb_sets(parse_cur_type) = 1 - parse_tbm%orb_set_type(1,parse_cur_type) = ORB_S - call QUIP_FoX_get_value(attributes, "E_s", value, status); - if (status == 0) read (value, *) parse_tbm%E(ORB_S,parse_cur_type) - else if (parse_tbm%n_orbs(parse_cur_type) == 4) then - parse_tbm%n_orb_sets(parse_cur_type) = 2 - parse_tbm%orb_set_type(1,parse_cur_type) = ORB_S - parse_tbm%orb_set_type(2,parse_cur_type) = ORB_P - call QUIP_FoX_get_value(attributes, "E_s", value, status); - if (status == 0) read (value, *) parse_tbm%E(ORB_S,parse_cur_type) - call QUIP_FoX_get_value(attributes, "E_p", value, status); - if (status == 0) read (value, *) parse_tbm%E(ORB_P,parse_cur_type) - else - call system_abort("TBModel_Bowler_read_params_xml can only do Bowler with s or sp") - endif - - call QUIP_FoX_get_value(attributes, "n_elecs", value, status); - if (status == 0) read (value, *) parse_tbm%n_elecs(parse_cur_type) - - if (allocated(parse_tbm%type_of_atomic_num)) deallocate(parse_tbm%type_of_atomic_num) - allocate(parse_tbm%type_of_atomic_num(maxval(parse_tbm%atomic_num(:)))) - parse_tbm%type_of_atomic_num(:) = 0 - do ti=1, parse_tbm%n_types - if (parse_Tbm%atomic_num(ti) > 0) & - parse_tbm%type_of_atomic_num(parse_tbm%atomic_num(ti)) = ti - end do - - parse_cur_type = parse_cur_type + 1 - - elseif (parse_in_tbm .and. name == 'defaults') then - - call QUIP_FoX_get_value(attributes, "fermi_e", value, status) - if (status == 0) then - parse_tbm%has_default_fermi_e = .true. - read (value, *) parse_tbm%default_fermi_e - endif - call QUIP_FoX_get_value(attributes, "fermi_T", value, status) - if (status == 0) then - parse_tbm%has_default_fermi_T = .true. - read (value, *) parse_tbm%default_fermi_T - endif - call QUIP_FoX_get_value(attributes, "band_width", value, status) - if (status == 0) then - parse_tbm%has_default_band_width = .true. - read (value, *) parse_tbm%default_band_width - endif - call QUIP_FoX_get_value(attributes, "k_density", value, status) - if (status == 0) then - parse_tbm%has_default_k_density = .true. - read (value, *) parse_tbm%default_k_density - endif - - elseif (parse_in_tbm .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "Z1", value, status); - if (status == 0) read (value, *) Zi - call QUIP_FoX_get_value(attributes, "Z2", value, status); - if (status == 0) read (value, *) Zj - - ti = get_type(parse_tbm%type_of_atomic_num,Zi) - tj = get_type(parse_tbm%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "rc", value, status); - if (status == 0) read (value, *) parse_tbm%rc(ti,tj) - call QUIP_FoX_get_value(attributes, "r0", value, status); - if (status == 0) read (value, *) parse_tbm%r0(ti,tj) - call QUIP_FoX_get_value(attributes, "n", value, status); - if (status == 0) read (value, *) parse_tbm%n(ti,tj) - call QUIP_FoX_get_value(attributes, "nc", value, status); - if (status == 0) read (value, *) parse_tbm%nc(ti,tj) - call QUIP_FoX_get_value(attributes, "dc", value, status); - if (status == 0) read (value, *) parse_tbm%dc(ti,tj) - call QUIP_FoX_get_value(attributes, "m", value, status); - if (status == 0) read (value, *) parse_tbm%m(ti,tj) - call QUIP_FoX_get_value(attributes, "mc", value, status); - if (status == 0) read (value, *) parse_tbm%mc(ti,tj) - - call QUIP_FoX_get_value(attributes, "H_sss", value, status); - if (status == 0) read (value, *) parse_tbm%H_coeff(SK_SSS,ti,tj) - call QUIP_FoX_get_value(attributes, "H_sps", value, status); - if (status == 0) read (value, *) parse_tbm%H_coeff(SK_SPS,ti,tj) - call QUIP_FoX_get_value(attributes, "H_pps", value, status); - if (status == 0) read (value, *) parse_tbm%H_coeff(SK_PPS,ti,tj) - call QUIP_FoX_get_value(attributes, "H_ppp", value, status); - if (status == 0) read (value, *) parse_tbm%H_coeff(SK_PPP,ti,tj) - call QUIP_FoX_get_value(attributes, "Vrep", value, status); - if (status == 0) read (value, *) parse_tbm%Vrep(ti,tj) - - if (ti /= tj) then - parse_tbm%rc(tj,ti) = parse_tbm%rc(ti,tj) - parse_tbm%r0(tj,ti) = parse_tbm%r0(ti,tj) - parse_tbm%n(tj,ti) = parse_tbm%n(ti,tj) - parse_tbm%nc(tj,ti) = parse_tbm%nc(ti,tj) - parse_tbm%dc(tj,ti) = parse_tbm%dc(ti,tj) - parse_tbm%m(tj,ti) = parse_tbm%m(ti,tj) - parse_tbm%mc(tj,ti) = parse_tbm%mc(ti,tj) - parse_tbm%H_coeff(SK_SSS:SK_PPP,tj,ti) = parse_tbm%H_coeff(SK_SSS:SK_PPP,ti,tj) - parse_tbm%Vrep(tj,ti) = parse_tbm%Vrep(ti,tj) - - call QUIP_FoX_get_value(attributes, "H_pss", value, status); - if (status == 0) read (value, *) parse_tbm%H_coeff(SK_SPS,tj,ti) - end if - endif - -end subroutine TBM_startElement_handler - -subroutine TBM_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (name == 'Bowler_params') then - parse_in_tbm = .false. - endif - -end subroutine TBM_endElement_handler - -subroutine TBModel_Bowler_read_params_xml(this, param_str) - type(TBModel_Bowler), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_tbm = .false. - parse_matched_label = .false. - parse_tbm => this - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = TBM_startElement_handler, & - endElement_handler = TBM_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types <= 0) call system_abort("TBModel_Bowler_read_params_xml couldn't find any types defined") - - call TBModel_Bowler_fix_tails(this) - -end subroutine TBModel_Bowler_read_params_xml -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! type(inoutput), pointer :: in -! -! integer ti, tj, Zi, Zj, tt -! -! integer status -! type(dictionary_t) :: attributes -! type(xml_t) :: fxml -! character(len=1024) :: value -! integer :: ndata -! character(len=10240) :: pcdata -! -! if (present(from_io)) then -! in => from_io -! else -! allocate(in) -! call Initialise(in, trim(bowler_default_file), INPUT) -! endif -! -! call open_xmlfile(in%unit, fxml, status) -!! call enable_debug(sax=.true.) -! if (status /= 0) call system_abort('TBModel_Bowler_read_params_xml Cannot open xml file') -! -! call rewind_xmlfile(fxml) -! -! call get_node(fxml, path='//Bowler_params', attributes=attributes, status=status) -! if (status /= 0) call system_abort('TBModel_Bowler_read_params_xml Cannot find /Bowler_params/header') -! call QUIP_FoX_get_value(attributes, "name", value, status); -! if (status == 0) read (value, *) this%name -! -! call QUIP_FoX_get_value(attributes, "n_types", value, status); -! if (status == 0) read (value, *) this%n_types -! call QUIP_FoX_get_value(attributes, "tailx0", value, status); -! if (status == 0) read (value, *) this%tailx0 -! call QUIP_FoX_get_value(attributes, "cutoff", value, status); -! if (status == 0) read (value, *) this%cutoff -! -! allocate(this%atomic_num(this%n_types)) -! allocate(this%n_orbs(this%n_types)) -! allocate(this%n_elecs(this%n_types)) -! allocate(this%n_orb_sets(this%n_types)) -! allocate(this%orb_set_type(max_n_orb_sets,this%n_types)) -! allocate(this%E(max_n_orb_sets,this%n_types)) -! -! call rewind_xmlfile(fxml) -! -! !! read bowler params -! do ti=1, this%n_types -! call get_node(fxml, path='//Bowler_params/per_type_data', attributes=attributes, status=status) -! if (status /= 0) call system_abort("Couldn't find per_type_data for " // str(ti)) -! -! call QUIP_FoX_get_value(attributes, "Z", value, status); -! if (status == 0) read (value, *) this%atomic_num(ti) -! -! call QUIP_FoX_get_value(attributes, "n_orbs", value, status); -! if (status == 0) read (value, *) this%n_orbs(ti) -! if (this%n_orbs(ti) == 1) then -! this%n_orb_sets(ti) = 1 -! this%orb_set_type(1,ti) = ORB_S -! call QUIP_FoX_get_value(attributes, "E_s", value, status); -! if (status == 0) read (value, *) this%E(ORB_S,ti) -! else if (this%n_orbs(ti) == 4) then -! this%n_orb_sets(ti) = 2 -! this%orb_set_type(1,ti) = ORB_S -! this%orb_set_type(2,ti) = ORB_P -! call QUIP_FoX_get_value(attributes, "E_s", value, status); -! if (status == 0) read (value, *) this%E(ORB_S,ti) -! call QUIP_FoX_get_value(attributes, "E_p", value, status); -! if (status == 0) read (value, *) this%E(ORB_P,ti) -! else -! call system_abort("TBModel_Bowler_read_params_xml can only do Bowler with s or sp") -! endif -! -! call QUIP_FoX_get_value(attributes, "n_elecs", value, status); -! if (status == 0) read (value, *) this%n_elecs(ti) -! -! end do -! -! allocate(this%type_of_atomic_num(maxval(this%atomic_num(:)))) -! this%type_of_atomic_num(:) = 0 -! do ti=1, this%n_types -! this%type_of_atomic_num(this%atomic_num(ti)) = ti -! end do -! -! allocate(this%H_coeff(4, this%n_types, this%n_types)) -! allocate(this%Vrep(this%n_types, this%n_types)) -! allocate(this%rc(this%n_types, this%n_types)) -! allocate(this%r0(this%n_types, this%n_types)) -! allocate(this%n(this%n_types, this%n_types)) -! allocate(this%nc(this%n_types, this%n_types)) -! allocate(this%dc(this%n_types, this%n_types)) -! allocate(this%m(this%n_types, this%n_types)) -! allocate(this%mc(this%n_types, this%n_types)) -! call rewind_xmlfile(fxml) -! -! this%H_coeff = 0.0_dp -! this%Vrep = 0.0_dp -! this%rc = 1.0_dp -! this%r0 = 0.0_dp -! this%n = 0.0_dp -! this%nc = 0.0_dp -! this%dc = 1.0_dp -! this%m = 0.0_dp -! this%mc = 0.0_dp -! -! do tt=1, (this%n_types*(this%n_types+1))/2 -! call get_node(fxml, path='//Bowler_params/per_pair_data', attributes=attributes, status=status) -! if (status /= 0) call system_abort("Couldn't find per_pair_data for " // trim(str(ti)) // ' ' // trim(str(tj))) -! -! call QUIP_FoX_get_value(attributes, "Z1", value, status); -! if (status == 0) read (value, *) Zi -! call QUIP_FoX_get_value(attributes, "Z2", value, status); -! if (status == 0) read (value, *) Zj -! -! ti = get_type(this%type_of_atomic_num,Zi) -! tj = get_type(this%type_of_atomic_num,Zj) -! -! call QUIP_FoX_get_value(attributes, "rc", value, status); -! if (status == 0) read (value, *) this%rc(ti,tj) -! call QUIP_FoX_get_value(attributes, "r0", value, status); -! if (status == 0) read (value, *) this%r0(ti,tj) -! call QUIP_FoX_get_value(attributes, "n", value, status); -! if (status == 0) read (value, *) this%n(ti,tj) -! call QUIP_FoX_get_value(attributes, "nc", value, status); -! if (status == 0) read (value, *) this%nc(ti,tj) -! call QUIP_FoX_get_value(attributes, "dc", value, status); -! if (status == 0) read (value, *) this%dc(ti,tj) -! call QUIP_FoX_get_value(attributes, "m", value, status); -! if (status == 0) read (value, *) this%m(ti,tj) -! call QUIP_FoX_get_value(attributes, "mc", value, status); -! if (status == 0) read (value, *) this%mc(ti,tj) -! -! call QUIP_FoX_get_value(attributes, "H_sss", value, status); -! if (status == 0) read (value, *) this%H_coeff(SK_SSS,ti,tj) -! call QUIP_FoX_get_value(attributes, "H_sps", value, status); -! if (status == 0) read (value, *) this%H_coeff(SK_SPS,ti,tj) -! call QUIP_FoX_get_value(attributes, "H_pps", value, status); -! if (status == 0) read (value, *) this%H_coeff(SK_PPS,ti,tj) -! call QUIP_FoX_get_value(attributes, "H_ppp", value, status); -! if (status == 0) read (value, *) this%H_coeff(SK_PPP,ti,tj) -! call QUIP_FoX_get_value(attributes, "Vrep", value, status); -! if (status == 0) read (value, *) this%Vrep(ti,tj) -! -! if (ti /= tj) then -! this%rc(tj,ti) = this%rc(ti,tj) -! this%r0(tj,ti) = this%r0(ti,tj) -! this%n(tj,ti) = this%n(ti,tj) -! this%nc(tj,ti) = this%nc(ti,tj) -! this%dc(tj,ti) = this%dc(ti,tj) -! this%m(tj,ti) = this%m(ti,tj) -! this%mc(tj,ti) = this%mc(ti,tj) -! this%H_coeff(SK_SSS:SK_PPP,tj,ti) = this%H_coeff(SK_SSS:SK_PPP,ti,tj) -! this%Vrep(tj,ti) = this%Vrep(ti,tj) -! -! call QUIP_FoX_get_value(attributes, "H_pss", value, status); -! if (status == 0) read (value, *) this%H_coeff(SK_SPS,tj,ti) -! endif -! end do -! -! call TBModel_Bowler_fix_tails(this) -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine TBModel_Bowler_fix_tails(this) - type(TBModel_Bowler), intent(inout) :: this - - integer ti, tj - real(dp) :: x(2), y(2), yd1, yd2 - - x(1) = this%tailx0 - x(2) = this%cutoff - y(2) = 0.0_dp - yd2 = 0.0_dp - - allocate(this%H_tail_spline(this%n_types, this%n_types)) - allocate(this%Vrep_tail_spline(this%n_types, this%n_types)) - - do ti=1, this%n_types - do tj=1, this%n_types - y(1) = TBModel_Bowler_dist_scaling(x(1), this%r0(ti,tj), this%n(ti,tj), this%rc(ti,tj), this%nc(ti,tj)) - yd1 = TBModel_Bowler_dist_scaling_deriv(x(1), this%r0(ti,tj), this%n(ti,tj), this%rc(ti,tj), this%nc(ti,tj)) - call initialise(this%H_tail_spline(ti,tj), x, y, yd1, yd2) - - y(1) = TBModel_Bowler_dist_scaling(x(1), this%r0(ti,tj), this%m(ti,tj), this%dc(ti,tj), this%mc(ti,tj)) - yd1 = TBModel_Bowler_dist_scaling_deriv(x(1), this%r0(ti,tj), this%m(ti,tj), this%dc(ti,tj), this%mc(ti,tj)) - call initialise(this%Vrep_tail_spline(ti,tj), x, y, yd1, yd2) - end do - end do - -end subroutine TBModel_Bowler_fix_tails - -subroutine TBModel_Bowler_Print(this,file) - type(TBModel_Bowler), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer:: ti, tj - - if(this%n_types == 0) call System_Abort('TBModel_Bowler_Print: TBModel_Bowler structure not initialised') - - call Print('TBModel_Bowler Structure:', file=file) - - !! print bowler params - call Print ("TBModel_Bowler tailx0 " // this%tailx0 // " cutoff " // this%cutoff, file=file) - do ti=1, this%n_types - call Print ("TBModel_Bowler type " // ti // " Z " // this%atomic_num(ti) // " n_orbs " // this%n_orbs(ti) // & - " n_elecs " // this%n_elecs(ti), file=file) - if (this%n_orb_sets(ti) == 1) then - call Print ("TBModel_Bowler E " // this%E(1,ti), file=file) - else - call Print ("TBModel_Bowler E " // this%E(1:2,ti), file=file) - endif - end do - - call verbosity_push_decrement() - do ti=1, this%n_types - do tj=1, this%n_types - call Print ("TBModel_Bowler interaction " // & - ti // " " // tj // " Z " // this%atomic_num(ti) // " " // this%atomic_num(tj), file=file) - - call Print ("TBModel_Bowler r0 " // this%r0(ti,tj), file=file) - - call Print ("TBModel_Bowler SK " // this%H_coeff(:,ti,tj), file=file) - call Print ("TBModel_Bowler H scaling rc n nc " // & - this%rc(ti,tj) // " " // this%n(ti,tj) // " " // this%nc(ti,tj), file=file) - call Print (this%H_tail_spline(ti,tj), file=file) - - call Print ("TBModel_Bowler Vrep " // this%Vrep(ti,tj), file=file) - call Print ("TBModel_Bowler Vrep scaling dc m mc " // & - this%dc(ti,tj) // " " // this%m(ti,tj) // this%mc(ti,tj), file=file) - call Print (this%Vrep_tail_spline(ti,tj), file=file) - - end do - end do - call verbosity_pop() - -end subroutine TBModel_Bowler_Print - -function TBModel_Bowler_n_orbs_of_Z(this, Z) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_Bowler_n_orbs_of_Z - - TBModel_Bowler_n_orbs_of_Z = this%n_orbs(get_type(this%type_of_atomic_num,Z)) -end function TBModel_Bowler_n_orbs_of_Z - -function TBModel_Bowler_n_orb_sets_of_Z(this, Z) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_Bowler_n_orb_sets_of_Z - - TBModel_Bowler_n_orb_sets_of_Z = this%n_orb_sets(get_type(this%type_of_atomic_num,Z)) -end function TBModel_Bowler_n_orb_sets_of_Z - -function TBModel_Bowler_n_orbs_of_orb_set_of_Z(this, Z, i_set) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_Bowler_n_orbs_of_orb_set_of_Z - - TBModel_Bowler_n_orbs_of_orb_set_of_Z = N_ORBS_OF_SET(this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z))) - -end function TBModel_Bowler_n_orbs_of_orb_set_of_Z - -function TBModel_Bowler_orb_type_of_orb_set_of_Z(this, Z, i_set) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_Bowler_orb_type_of_orb_set_of_Z - - TBModel_Bowler_orb_type_of_orb_set_of_Z = this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z)) - -end function TBModel_Bowler_orb_type_of_orb_set_of_Z - -function TBModel_Bowler_n_elecs_of_Z(this, Z) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: Z - real(dp) TBModel_Bowler_n_elecs_of_Z - - TBModel_Bowler_n_elecs_of_Z = this%n_elecs(get_type(this%type_of_atomic_num,Z)) -end function TBModel_Bowler_n_elecs_of_Z - -subroutine TBModel_Bowler_get_HS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, b_H, b_S, i_mag) - type(TBModel_Bowler), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, at_j - real(dp), intent(in) :: dv_hat(3), dv_mag - real(dp), intent(out) :: b_H(:,:) - real(dp), intent(out) :: b_S(:,:) - integer, intent(in), optional :: i_mag - - integer ti, tj, is, js, i_set, j_set - integer i, j - real(dp) SK_frad_H(N_SK) - real(dp) dv_hat_sq(3) - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - tj = get_type(this%type_of_atomic_num,at%Z(at_j)) - - b_S = 0.0_dp - - if (dv_mag .feq. 0.0_dp) then - b_H = 0.0_dp - - i = 1 - do i_set = 1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - b_H(i,i) = onsite_function(this, ti, this%orb_set_type(i_set,ti)) - b_S(i,i) = 1.0_dp - i = i + 1 - end do - end do - - else - - dv_hat_sq = dv_hat**2 - - i = 1 - do i_set=1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - j = 1 - do j_set=1, this%n_orb_sets(tj) - call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H) - do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) - - b_H(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H) - j = j + 1 - end do - end do - i = i + 1 - end do - end do - endif - -end subroutine TBModel_Bowler_get_HS_blocks - -subroutine TBModel_Bowler_get_dHS_masks(this, at, at_ind, d_mask, od_mask) - type(TBModel_Bowler), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_ind - logical, intent(out), optional :: d_mask(:), od_mask(:) - - if (at_ind < 0) then - if (present(d_mask)) d_mask = .true. - if (present(od_mask)) od_mask = .true. - else - if (present(d_mask)) d_mask = .false. - if (present(od_mask)) then - od_mask = .false. - od_mask(at_ind) = .true. - endif - endif -end subroutine TBModel_Bowler_get_dHS_masks - -function TBModel_Bowler_get_dHS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) - type(TBModel_Bowler), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, at_j - real(dp), intent(in) :: dv_hat(3), dv_mag - integer, intent(in) :: at_ind - real(dp), intent(out) :: b_dH(:,:,:) - real(dp), intent(out) :: b_dS(:,:,:) - integer, intent(in), optional :: i_mag - logical :: TBModel_Bowler_get_dHS_blocks - - integer ti, tj, is, js, i_set, j_set - integer i, j - real(dp) SK_frad_H(N_SK) - real(dp) SK_dfrad_H(N_SK) - real(dp) dv_hat_sq(3) - real(dp) virial_outerprod_fac - - if ((at_ind > 0 .and. at_i /= at_ind .and. at_j /= at_ind) .or. & - (at_ind > 0 .and. at_i == at_j) .or. & - (dv_mag > this%cutoff) .or. & - (dv_mag .feq. 0.0_dp)) then - TBModel_Bowler_get_dHS_blocks = .false. - return - endif - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - tj = get_type(this%type_of_atomic_num,at%Z(at_j)) - - b_dS = 0.0_dp - - dv_hat_sq = dv_hat**2 - - - i = 1 - do i_set=1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - j = 1 - do j_set=1, this%n_orb_sets(tj) - call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H) - call dradial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_dfrad_H) - do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) - - if (at_ind > 0) then - virial_outerprod_fac = 1.0_dp - else - virial_outerprod_fac = -dv_mag*dv_hat(-at_ind) - end if - b_dH(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & - this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H, SK_dfrad_H)*virial_outerprod_fac - j = j + 1 - end do - end do - i = i + 1 - end do - end do - - if (at_ind == at_j) b_dH = -b_dH - - TBModel_Bowler_get_dHS_blocks = .true. - return - -end function TBModel_Bowler_get_dHS_blocks - -subroutine radial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, is, js, f_H) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dv_mag - integer, intent(in) :: orb_set_type_i, orb_set_type_j - integer, intent(in) :: is, js - real(dp), intent(out) :: f_H(N_SK) - - if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then - f_H(SK_SSS) = calc_H_coeff(this, SK_SSS, dv_mag, ti, tj) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then - f_H(SK_SPS) = calc_H_coeff(this, SK_SPS, dv_mag, ti, tj) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then - f_H(SK_SPS) = -calc_H_coeff( this, SK_SPS, dv_mag, tj, ti) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then - f_H(SK_PPS) = calc_H_coeff(this, SK_PPS, dv_mag, ti, tj) - f_H(SK_PPP) = calc_H_coeff(this, SK_PPP, dv_mag, ti, tj) - else - call system_abort("TBModel_Bowler radial_functions got invalide orb_set_type "//orb_set_type_i//" or "//orb_set_type_j) - endif -end subroutine radial_functions - -subroutine dradial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, is, js, f_dH) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dv_mag - integer, intent(in) :: orb_set_type_i, orb_set_type_j - integer, intent(in) :: is, js - real(dp), intent(out) :: f_dH(N_SK) - - if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then - f_dH(SK_SSS) = calc_H_coeff_deriv(this, SK_SSS, dv_mag, ti, tj) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then - f_dH(SK_SPS) = calc_H_coeff_deriv(this, SK_SPS, dv_mag, ti, tj) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then - f_dH(SK_SPS) = -calc_H_coeff_deriv( this, SK_SPS, dv_mag, tj, ti) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then - f_dH(SK_PPS) = calc_H_coeff_deriv(this, SK_PPS, dv_mag, ti, tj) - f_dH(SK_PPP) = calc_H_coeff_deriv(this, SK_PPP, dv_mag, ti, tj) - else - call system_abort("TBModel_Bowler dradial_functions got invalide orb_set_type "//orb_set_type_i//" or "//orb_set_type_j) - endif -end subroutine dradial_functions - -function TBModel_Bowler_calc_H_coeff(this, sk_ind, dist, ti, tj) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: sk_ind - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_Bowler_calc_H_coeff - - TBModel_Bowler_calc_H_coeff = this%H_coeff(sk_ind, ti, tj)* & - TBModel_Bowler_H_dist_func(this, dist, ti, tj) - -end function TBModel_Bowler_calc_H_coeff - -function TBModel_Bowler_calc_H_coeff_deriv(this, sk_ind, dist, ti, tj) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: sk_ind - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_Bowler_calc_H_coeff_deriv - - TBModel_Bowler_calc_H_coeff_deriv = this%H_coeff(sk_ind, ti, tj)* & - TBModel_Bowler_H_dist_func_deriv(this, dist, ti, tj) - -end function TBModel_Bowler_calc_H_coeff_deriv - -function TBModel_Bowler_H_dist_func(this, dist, ti, tj) - type(TBModel_Bowler), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_Bowler_H_dist_func - - if (dist <= this%cutoff) then - if (dist <= this%tailx0) then - TBModel_Bowler_H_dist_func = TBModel_Bowler_dist_scaling(dist, & - this%r0(ti,tj), this%n(ti,tj), this%rc(ti, tj), this%nc(ti, tj)) - else - TBModel_Bowler_H_dist_func = spline_value(this%H_tail_spline(ti,tj), dist) - endif - else - TBModel_Bowler_H_dist_func = 0.0_dp - endif -end function TBModel_Bowler_H_dist_func - -function TBModel_Bowler_H_dist_func_deriv(this, dist, ti, tj) - type(TBModel_Bowler), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_Bowler_H_dist_func_deriv - - if (dist <= this%cutoff) then - if (dist <= this%tailx0) then - TBModel_Bowler_H_dist_func_deriv = TBModel_Bowler_dist_scaling_deriv(dist, & - this%r0(ti,tj), this%n(ti,tj), this%rc(ti, tj), this%nc(ti, tj)) - else - TBModel_Bowler_H_dist_func_deriv = spline_deriv(this%H_tail_spline(ti,tj), dist) - endif - else - TBModel_Bowler_H_dist_func_deriv = 0.0_dp - endif -end function TBModel_Bowler_H_dist_func_deriv - -function TBModel_Bowler_Vrep_dist_func(this, dist, ti, tj) - type(TBModel_Bowler), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_Bowler_Vrep_dist_func - - if (dist <= this%cutoff) then - if (dist <= this%tailx0) then - TBModel_Bowler_Vrep_dist_func = TBModel_Bowler_dist_scaling(dist, & - this%r0(ti,tj), this%m(ti,tj), this%dc(ti, tj), this%mc(ti, tj)) - else - TBModel_Bowler_Vrep_dist_func = spline_value(this%Vrep_tail_spline(ti,tj), dist) - endif - else - TBModel_Bowler_Vrep_dist_func = 0.0_dp - endif -end function TBModel_Bowler_Vrep_dist_func - -function TBModel_Bowler_Vrep_dist_func_deriv(this, dist, ti, tj) - type(TBModel_Bowler), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_Bowler_Vrep_dist_func_deriv - - if (dist <= this%cutoff) then - if (dist <= this%tailx0) then - TBModel_Bowler_Vrep_dist_func_deriv = TBModel_Bowler_dist_scaling_deriv(dist, & - this%r0(ti,tj), this%m(ti,tj), this%dc(ti, tj), this%mc(ti, tj)) - else - TBModel_Bowler_Vrep_dist_func_deriv = spline_deriv(this%Vrep_tail_spline(ti,tj), dist) - endif - else - TBModel_Bowler_Vrep_dist_func_deriv = 0.0_dp - endif -end function TBModel_Bowler_Vrep_dist_func_deriv - -function TBModel_Bowler_dist_scaling(r, r0, n, rc, nc) - real(dp), intent(in) :: r, r0, n, rc, nc - real(dp) :: TBModel_Bowler_dist_scaling - - TBModel_Bowler_dist_scaling = (r0/r)**n * exp(n* ((r0/rc)**nc - (r/rc)**nc)) -end function TBModel_Bowler_dist_scaling - -function TBModel_Bowler_dist_scaling_deriv(r, r0, n, rc, nc) - real(dp), intent(in) :: r, r0, n, rc, nc - real(dp) :: TBModel_Bowler_dist_scaling_deriv - - real(dp) tmp1, tmp2 - - tmp1 = (r0/r)**n - tmp2 = exp(n*((r0/rc)**nc - (r/rc)**nc)) - - TBModel_Bowler_dist_scaling_deriv = n*tmp1/(-r)*tmp2 + tmp1*tmp2*(-n)*nc*((r/rc)**nc)/r -end function TBModel_Bowler_dist_scaling_deriv - -function onsite_function(this, ti, orb_set_type) - type(TBModel_Bowler), intent(in) :: this - integer, intent(in) :: ti, orb_set_type - real(dp) :: onsite_function - - onsite_function = this%E(orb_set_type, ti) - -end function onsite_function - -function TBModel_Bowler_get_local_rep_E(this, at, i) - type(TBModel_Bowler), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: TBModel_Bowler_get_local_rep_E - - real(dp) E, dist - integer ji, j, ti, tj - - TBModel_Bowler_get_local_rep_E = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - E = this%Vrep(ti,tj) * TBModel_Bowler_Vrep_dist_func(this, dist, ti, tj) - TBModel_Bowler_get_local_rep_E = TBModel_Bowler_get_local_rep_E + E/2.0_dp - end do - -end function TBModel_Bowler_get_local_rep_E - -function TBModel_Bowler_get_local_rep_E_force(this, at, i) result(force) - type(TBModel_Bowler), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: force(3,at%N) - - real(dp) dE_dr, dist, dv_hat(3) - integer ji, j, ti, tj - - force = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist, cosines = dv_hat) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - dE_dr = this%Vrep(ti,tj) * TBModel_Bowler_Vrep_dist_func_deriv(this, dist, ti, tj) - force(:,i) = force(:,i) + dE_dr*dv_hat(:)/2.0_dp - force(:,j) = force(:,j) - dE_dr*dv_hat(:)/2.0_dp - end do - -end function TBModel_Bowler_get_local_rep_E_force - -function TBModel_Bowler_get_local_rep_E_virial(this, at, i) result(virial) - type(TBModel_Bowler), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: virial(3,3) - - real(dp) dE_dr, dist, dv_hat(3) - integer ji, j, ti, tj - - virial = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist, cosines = dv_hat) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - dE_dr = this%Vrep(ti,tj) * TBModel_Bowler_Vrep_dist_func_deriv(this, dist, ti, tj) - virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist / 2.0_dp - end do - -end function TBModel_Bowler_get_local_rep_E_virial - -end module TBModel_Bowler_module diff --git a/src/Potentials/TBModel_DFTB.f95 b/src/Potentials/TBModel_DFTB.f95 deleted file mode 100644 index fca8de2a00..0000000000 --- a/src/Potentials/TBModel_DFTB.f95 +++ /dev/null @@ -1,1143 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X TBModel_DFTB module -!X -!% Calculate energies using DFTB tight-binding model -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -module TBModel_DFTB_module - -use system_module, only : dp, inoutput, print, PRINT_NORMAL, PRINT_ALWAYS, PRINT_NERD, current_verbosity, increase_stack, system_abort, verbosity_push_decrement, verbosity_pop -use units_module -use extendable_str_module -use linearalgebra_module -use spline_module -use dictionary_module -use paramreader_module -use atoms_module - -use TB_Common_module -use QUIP_Common_module - -implicit none -private - -include 'TBModel_interface.h' - -public :: TBModel_DFTB -type TBModel_DFTB - integer :: n_types = 0 - character(len=STRING_LENGTH) label - - real(dp) :: cutoff = 0.0_dp - logical :: is_orthogonal = .false. - - integer, allocatable :: type_of_atomic_num(:) - integer, allocatable :: n_orbs(:), n_elecs(:), n_orb_sets(:), orb_set_type(:,:) - integer, allocatable :: atomic_num(:) - - !! DFTB parameters - real(dp), allocatable:: E(:,:) - - real(dp), allocatable:: SK_cutoff(:,:), Vrep_cutoff(:,:) - - type(spline), allocatable :: H_spline(:,:,:), S_spline(:,:,:), Vrep_spline(:,:) - - logical :: has_default_fermi_E = .false., has_default_fermi_T = .true., has_default_band_width = .false., has_default_k_density = .false. - real(dp) :: default_fermi_E, default_fermi_T = 0.001_dp, default_band_width, default_k_density - -end type TBModel_DFTB - -type(extendable_str), private, save :: parse_cur_data -logical, private :: parse_in_tbm, parse_matched_label -logical :: parse_in_H_spline, parse_in_S_spline, parse_in_Vrep_spline -integer :: parse_cur_type_i, parse_cur_type_j, parse_cur_point_i -type (TBModel_DFTB), pointer :: parse_tbm -real(dp), allocatable :: parse_SK_r(:), parse_H_vals(:,:), parse_S_vals(:,:) -real(dp), allocatable :: parse_Vrep_r(:), parse_Vrep_vals(:) - -interface Initialise - module procedure TBModel_DFTB_Initialise_str -end interface Initialise - -interface Finalise - module procedure TBModel_DFTB_Finalise -end interface Finalise - -interface Print - module procedure TBModel_DFTB_Print -end interface Print - -interface n_orbs_of_Z - module procedure TBModel_DFTB_n_orbs_of_Z -end interface n_orbs_of_Z - -interface n_orb_sets_of_Z - module procedure TBModel_DFTB_n_orb_sets_of_Z -end interface n_orb_sets_of_Z - -interface n_orbs_of_orb_set_of_Z - module procedure TBModel_DFTB_n_orbs_of_orb_set_of_Z -end interface n_orbs_of_orb_set_of_Z - -interface orb_type_of_orb_set_of_Z - module procedure TBModel_DFTB_orb_type_of_orb_set_of_Z -end interface orb_type_of_orb_set_of_Z - -interface n_elecs_of_Z - module procedure TBModel_DFTB_n_elecs_of_Z -end interface n_elecs_of_Z - -interface get_HS_blocks - module procedure TBModel_DFTB_get_HS_blocks -end interface get_HS_blocks - -interface get_dHS_masks - module procedure TBModel_DFTB_get_dHS_masks -end interface get_dHS_masks - -interface get_dHS_blocks - module procedure TBModel_DFTB_get_dHS_blocks -end interface get_dHS_blocks - -interface get_local_rep_E - module procedure TBModel_DFTB_get_local_rep_E -end interface get_local_rep_E - -interface get_local_rep_E_force - module procedure TBModel_DFTB_get_local_rep_E_force -end interface get_local_rep_E_force - -interface get_local_rep_E_virial - module procedure TBModel_DFTB_get_local_rep_E_virial -end interface get_local_rep_E_virial - -contains - -subroutine TBModel_DFTB_Initialise_str(this, args_str, param_str) - type(TBModel_DFTB), intent(inout) :: this - character(len=*) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_DFTB_Initialise_str args_str')) then - call system_abort("TBModel_DFTB_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call TBModel_DFTB_read_params_xml(this, param_str) -end subroutine TBModel_DFTB_Initialise_str - -subroutine TBModel_DFTB_Finalise(this) - type(TBModel_DFTB), intent(inout) :: this - - integer ti, tj, i - - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%n_orbs)) deallocate(this%n_orbs) - if (allocated(this%n_elecs)) deallocate(this%n_elecs) - if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) - if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - - if (allocated(this%E)) deallocate(this%E) - if (allocated(this%SK_cutoff)) deallocate(this%SK_cutoff) - if (allocated(this%Vrep_cutoff)) deallocate(this%Vrep_cutoff) - - if (allocated(this%H_spline)) then - do ti=1, size(this%H_spline,2) - do tj=1, size(this%H_spline,3) - do i=1, size(this%H_spline,1) - call finalise(this%H_spline(i,ti,tj)) - end do - end do - end do - deallocate(this%H_spline) - endif - if (allocated(this%S_spline)) then - do ti=1, size(this%S_spline,2) - do tj=1, size(this%S_spline,3) - do i=1, size(this%S_spline,1) - call finalise(this%S_spline(i,ti,tj)) - end do - end do - end do - deallocate(this%S_spline) - endif - if (allocated(this%Vrep_spline)) then - do ti=1, size(this%Vrep_spline,1) - do tj=1, size(this%Vrep_spline,2) - call finalise(this%Vrep_spline(ti,tj)) - end do - end do - deallocate(this%Vrep_spline) - endif - - this%n_types = 0 - this%label = '' -end subroutine TBModel_DFTB_Finalise - -subroutine TBM_characters_handler(in) - character(len=*), intent(in) :: in - - if (parse_in_tbm) then - call concat(parse_cur_data, in, keep_lf=.false.) - endif -end subroutine - -subroutine TBM_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - - integer max_n_orb_sets, SK_npts, Vrep_npts - integer ti, tj - - call zero(parse_cur_data) - - if (name == 'DFTB_params') then ! new DFTB stanza - call print("DFTB_params startElement_handler", PRINT_NERD) - - if (parse_in_tbm) & - call system_abort("IPModel_startElement_handler entered DFTB_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) then - call print("DFTB_params startElement_handler bailing because we already matched our label", PRINT_NERD) - return ! we already found an exact match for this label - endif - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - call print("DFTB_params startElement_handler found xml label '"//trim(value)//"'", PRINT_NERD) - - if (len(trim(parse_tbm%label)) > 0) then ! we were passed in a label - call print("DFTB_params startElement_handler was passed in label '"//trim(parse_tbm%label)//"'", PRINT_NERD) - if (value == parse_tbm%label) then ! exact match - call print("DFTB_params startElement_handler got label exact match", PRINT_NERD) - parse_matched_label = .true. - parse_in_tbm = .true. - else ! no match - call print("DFTB_params startElement_handler got label didn't match", PRINT_NERD) - parse_in_tbm = .false. - endif - else ! no label passed in - call print("DFTB_params startElement_handler was not passed in a label", PRINT_NERD) - parse_in_tbm = .true. - call print("DFTB_params startElement_handler was not passed in a label", PRINT_NERD) - endif - - call print("DFTB_params startElement_handler parse_in_tbm " // parse_in_tbm, PRINT_NERD) - - if (parse_in_tbm) then - call initialise(parse_cur_data) - if (parse_tbm%n_types /= 0) then - call print("DFTB_params startElement_handler finalising old data, restarting to parse new section", PRINT_NERD) - call finalise(parse_tbm) - endif - endif - - elseif (parse_in_tbm .and. name == 'defaults') then - - call QUIP_FoX_get_value(attributes, "fermi_e", value, status) - if (status == 0) then - parse_tbm%has_default_fermi_e = .true. - read (value, *) parse_tbm%default_fermi_e - endif - call QUIP_FoX_get_value(attributes, "fermi_T", value, status) - if (status == 0) then - parse_tbm%has_default_fermi_T = .true. - read (value, *) parse_tbm%default_fermi_T - endif - call QUIP_FoX_get_value(attributes, "band_width", value, status) - if (status == 0) then - parse_tbm%has_default_band_width = .true. - read (value, *) parse_tbm%default_band_width - endif - call QUIP_FoX_get_value(attributes, "k_density", value, status) - if (status == 0) then - parse_tbm%has_default_k_density = .true. - read (value, *) parse_tbm%default_k_density - endif - - elseif (parse_in_tbm .and. name == 'n_types') then - call QUIP_FoX_get_value(attributes, "v", value, status); - if (status == 0) read (value, *) parse_tbm%n_types - - allocate(parse_tbm%atomic_num(parse_tbm%n_types)) - parse_tbm%atomic_num = 0 - allocate(parse_tbm%n_orbs(parse_tbm%n_types)) - allocate(parse_tbm%n_elecs(parse_tbm%n_types)) - allocate(parse_tbm%n_orb_sets(parse_tbm%n_types)) - - allocate(parse_tbm%H_spline(10,parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%S_spline(10,parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%Vrep_spline(parse_tbm%n_types,parse_tbm%n_types)) - - allocate(parse_tbm%SK_cutoff(parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%Vrep_cutoff(parse_tbm%n_types,parse_tbm%n_types)) - - elseif (parse_in_tbm .and. name == 'cutoff') then - call QUIP_FoX_get_value(attributes, "v", value, status); - if (status == 0) read (value, *) parse_tbm%cutoff - parse_tbm%cutoff = parse_tbm%cutoff*BOHR - elseif (parse_in_tbm .and. name == 'max_n_orb_sets') then - call QUIP_FoX_get_value(attributes, "v", value, status); - if (status == 0) read (value, *) max_n_orb_sets - allocate(parse_tbm%orb_set_type(max_n_orb_sets,parse_tbm%n_types)) - allocate(parse_tbm%E(max_n_orb_sets,parse_tbm%n_types)) - elseif (parse_in_tbm .and. name == 'per_type_data') then - call QUIP_FoX_get_value(attributes, "type", value, status); - if (status == 0) read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_num", value, status); - if (status == 0) read (value, *) parse_tbm%atomic_num(ti) - call QUIP_FoX_get_value(attributes, "n_orbs", value, status); - if (status == 0) read (value, *) parse_tbm%n_orbs(ti) - call QUIP_FoX_get_value(attributes, "n_orb_sets", value, status); - if (status == 0) read (value, *) parse_tbm%n_orb_sets(ti) - call QUIP_FoX_get_value(attributes, "n_elecs", value, status); - if (status == 0) read (value, *) parse_tbm%n_elecs(ti) - - parse_cur_type_i = ti - parse_cur_type_j = ti - - if (allocated(parse_tbm%type_of_atomic_num)) deallocate(parse_tbm%type_of_atomic_num) - allocate(parse_tbm%type_of_atomic_num(maxval(parse_tbm%atomic_num(:)))) - parse_tbm%type_of_atomic_num(:) = 0 - do ti=1, parse_tbm%n_types - if (parse_tbm%atomic_num(ti) > 0) & - parse_tbm%type_of_atomic_num(parse_tbm%atomic_num(ti)) = ti - end do - - elseif (parse_in_tbm .and. name == 'per_pair_data') then - call QUIP_FoX_get_value(attributes, "type1", value, status); - if (status == 0) read (value, *) ti - call QUIP_FoX_get_value(attributes, "type2", value, status); - if (status == 0) read (value, *) tj - call QUIP_FoX_get_value(attributes, "SK_npts", value, status); - if (status == 0) read (value, *) SK_npts - call QUIP_FoX_get_value(attributes, "Vrep_npts", value, status); - if (status == 0) read (value, *) Vrep_npts - call QUIP_FoX_get_value(attributes, "SK_cutoff", value, status); - if (status == 0) read (value, *) parse_tbm%SK_cutoff(ti,tj) - parse_tbm%SK_cutoff(ti,tj) = parse_tbm%SK_cutoff(ti,tj)*BOHR - call QUIP_FoX_get_value(attributes, "Vrep_cutoff", value, status); - if (status == 0) read (value, *) parse_tbm%Vrep_cutoff(ti,tj) - parse_tbm%Vrep_cutoff(ti,tj) = parse_tbm%Vrep_cutoff(ti,tj)*BOHR - - allocate(parse_SK_r(SK_npts)) - allocate(parse_H_vals(10,SK_npts)) - allocate(parse_S_vals(10,SK_npts)) - allocate(parse_Vrep_r(Vrep_npts)) - allocate(parse_Vrep_vals(Vrep_npts)) - - parse_cur_type_i = ti - parse_cur_type_j = tj - - elseif (parse_in_tbm .and. name == 'H_spline') then - parse_in_H_spline = .true. - parse_cur_point_i = 1 - elseif (parse_in_tbm .and. name == 'S_spline') then - parse_in_S_spline = .true. - parse_cur_point_i = 1 - elseif (parse_in_tbm .and. name == 'Vrep_spline') then - parse_in_Vrep_spline = .true. - parse_cur_point_i = 1 - elseif (parse_in_tbm .and. name == 'point') then - if (parse_in_H_spline .or. parse_in_S_spline) then - call QUIP_FoX_get_value(attributes, "r", value, status); - if (status == 0) read (value, *) parse_SK_r(parse_cur_point_i) - parse_SK_r(parse_cur_point_i) = parse_SK_r(parse_cur_point_i) * BOHR - elseif (parse_in_Vrep_spline) then - call QUIP_FoX_get_value(attributes, "r", value, status); - if (status == 0) read (value, *) parse_Vrep_r(parse_cur_point_i) - parse_Vrep_r(parse_cur_point_i) = parse_Vrep_r(parse_cur_point_i) * BOHR - else - call system_abort('Found point in DFTB_params but not in H_spline, S_spline, or Vrep_spline') - endif - endif - -end subroutine TBM_startElement_handler - -subroutine TBM_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - character(len=10240) :: val - integer ii - - if (parse_in_tbm) then - if (name == 'DFTB_params') then - parse_in_tbm = .false. - elseif (name == 'orb_set_type') then - val = string(parse_cur_data) - read (val, *) parse_tbm%orb_set_type(1:parse_tbm%n_orb_sets(parse_cur_type_i),parse_cur_type_i) - elseif (name == 'E') then - val = string(parse_cur_data) - read (val, *) parse_tbm%E(1:parse_tbm%n_orb_sets(parse_cur_type_i),parse_cur_type_i) - parse_tbm%E(:,parse_cur_type_i) = parse_tbm%E(:,parse_cur_type_i) * HARTREE - elseif (name == 'per_pair_data') then - if (allocated(parse_SK_r)) deallocate(parse_SK_r) - if (allocated(parse_H_vals)) deallocate(parse_H_vals) - if (allocated(parse_S_vals)) deallocate(parse_S_vals) - if (allocated(parse_Vrep_r)) deallocate(parse_Vrep_r) - if (allocated(parse_Vrep_vals)) deallocate(parse_Vrep_vals) - elseif (parse_in_tbm .and. name == 'H_spline') then - do ii=1, 10 - call initialise(parse_tbm%H_spline(ii,parse_cur_type_i,parse_cur_type_j), parse_SK_r, parse_H_vals(ii,:), 0.0_dp, 0.0_dp) - end do - parse_in_H_spline = .false. - elseif (parse_in_tbm .and. name == 'S_spline') then - do ii=1, 10 - call initialise(parse_tbm%S_spline(ii,parse_cur_type_i,parse_cur_type_j), parse_SK_r, parse_S_vals(ii,:), 0.0_dp, 0.0_dp) - end do - parse_in_S_spline = .false. - elseif (parse_in_tbm .and. name == 'Vrep_spline') then - call initialise(parse_tbm%Vrep_spline(parse_cur_type_i,parse_cur_type_j), parse_Vrep_r, parse_Vrep_vals, 0.0_dp, 0.0_dp) - parse_in_Vrep_spline = .false. - elseif (name == 'point') then - if (parse_in_H_spline) then - val = string(parse_cur_data) - parse_H_vals(1:10,parse_cur_point_i) = 0.0_dp - read (val, *, end=1000) parse_H_vals(1:10,parse_cur_point_i) -1000 continue - parse_H_vals(1:10,parse_cur_point_i) = parse_H_vals(1:10,parse_cur_point_i) * HARTREE - elseif (parse_in_S_spline) then - val = string(parse_cur_data) - parse_S_vals(1:10,parse_cur_point_i) = 0.0_dp - read (val, *, end=1010) parse_S_vals(1:10,parse_cur_point_i) -1010 continue - elseif (parse_in_Vrep_spline) then - val = string(parse_cur_data) - read (val, *) parse_Vrep_vals(parse_cur_point_i) - parse_Vrep_vals(parse_cur_point_i) = parse_Vrep_vals(parse_cur_point_i) * HARTREE - else - call system_abort('Found point in DFTB_params but not in H_spline, S_spline, or Vrep_Spline') - endif - parse_cur_point_i = parse_cur_point_i + 1 - endif - endif - -end subroutine TBM_endElement_handler - - -subroutine TBModel_DFTB_read_params_xml(this, param_str) - type(TBModel_DFTB), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - integer :: err - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_tbm => this - parse_in_tbm = .false. - parse_matched_label = .false. - parse_in_H_spline = .false. - parse_in_S_spline = .false. - parse_in_Vrep_spline = .false. - - err = increase_stack(5*len(param_str)) - if (err /= 0)then - call print("TBModel_DfTB_Initialise_str Failed to increase stack before calling parse_xml", PRINT_ALWAYS) - endif - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - characters_handler = TBM_characters_handler, & - startElement_handler = TBM_startElement_handler, & - endElement_handler = TBM_endElement_handler) - - call close_xml_t(fxml) - -end subroutine - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! type(inoutput), pointer :: in -! -! integer ti, tj, Zi, Zj, tt, i, j, ii, jj -! integer max_n_orb_sets -! -! integer SK_npts, Vrep_npts -! real(dp), allocatable :: SK_r(:), H_vals(:,:), S_vals(:,:), Vrep_r(:), Vrep_vals(:) -! -! integer status -! type(dictionary_t) :: attributes -! type(xml_t) :: fxml -! character(len=1024) :: value -! integer :: ndata -! character(len=10240) :: pcdata -! integer cur_i -! -! if (present(from_io)) then -! in => from_io -! else -! allocate(in) -! call Initialise(in, trim(dftb_default_file), INPUT) -! endif -! -! call open_xmlfile(in%unit, fxml, status) -!! call enable_debug(sax=.true.) -! if (status /= 0) call system_abort('TBModel_DFTB_read_params_xml Cannot open xml file') -! -! call rewind_xmlfile(fxml) -! -! call get_node(fxml, path='//DFTB_params', attributes=attributes, status=status) -! if (status /= 0) call system_abort('TBModel_DFTB_read_params_xml Cannot find /DFTB_params/header') -! -! call get_node(fxml, path='//DFTB_params/n_types', attributes=attributes, status=status) -! call QUIP_FoX_get_value(attributes, "v", value, status); -! if (status == 0) read (value, *) this%n_types -! -! call get_node(fxml, path='//DFTB_params/cutoff', attributes=attributes, status=status) -! call QUIP_FoX_get_value(attributes, "v", value, status); -! if (status == 0) read (value, *) this%cutoff -! this%cutoff = this%cutoff*BOHR -! -! call get_node(fxml, path='//DFTB_params/max_n_orb_sets', attributes=attributes, status=status) -! call QUIP_FoX_get_value(attributes, "v", value, status); -! if (status == 0) read (value, *) max_n_orb_sets -! -! allocate(this%atomic_num(this%n_types)) -! allocate(this%n_orbs(this%n_types)) -! allocate(this%n_elecs(this%n_types)) -! allocate(this%n_orb_sets(this%n_types)) -! allocate(this%orb_set_type(max_n_orb_sets,this%n_types)) -! allocate(this%E(max_n_orb_sets,this%n_types)) -! -! call rewind_xmlfile(fxml) -! -! !! read DFTB per-type params -! do tt=1, this%n_types -! call get_node(fxml, path='//DFTB_params/per_type_data', attributes=attributes, status=status) -! if (status /= 0) call system_abort("Couldn't find per_type_data for " // str(ti)) -! -! call QUIP_FoX_get_value(attributes, "type", value, status); -! if (status == 0) then -! read (value, *) ti -! else -! call system_abort ("failed to find type in per_type_data " // str(tt)) -! endif -! -! call QUIP_FoX_get_value(attributes, "atomic_num", value, status); -! if (status == 0) read (value, *) this%atomic_num(ti) -! -! call QUIP_FoX_get_value(attributes, "n_orbs", value, status); -! if (status == 0) read (value, *) this%n_orbs(ti) -! -! call QUIP_FoX_get_value(attributes, "n_orb_sets", value, status); -! if (status == 0) read (value, *) this%n_orb_sets(ti) -! -! call QUIP_FoX_get_value(attributes, "n_elecs", value, status); -! if (status == 0) read (value, *) this%n_elecs(ti) -! -! call get_node(fxml, path='orb_set_type', attributes=attributes, pcdata=pcdata, status=status) -! ndata = 0 -! call build_data_array(pcdata, this%orb_set_type(1:this%n_orb_sets(ti),ti), ndata) -! if (ndata /= this%n_orb_sets(ti)) call system_abort ('Mismatch in amount of data reading orb_set_type '// trim(str(ti)) // & -! ' ' // trim(str(ndata))) -! -! call get_node(fxml, path='E', attributes=attributes, pcdata=pcdata, status=status) -! ndata = 0 -! call build_data_array(pcdata, this%E(1:this%n_orb_sets(ti),ti), ndata) -! if (ndata /= this%n_orb_sets(ti)) call system_abort ('Mismatch in amount of data reading E '// trim(str(ti)) // & -! ' ' // trim(str(ndata))) -! this%E(:,ti) = this%E(:,ti)*HARTREE -! -! end do -! -! allocate(this%type_of_atomic_num(maxval(this%atomic_num(:)))) -! this%type_of_atomic_num(:) = 0 -! do ti=1, this%n_types -! this%type_of_atomic_num(this%atomic_num(ti)) = ti -! end do -! -! allocate(this%H_spline(10,this%n_types,this%n_types)) -! allocate(this%S_spline(10,this%n_types,this%n_types)) -! allocate(this%Vrep_spline(this%n_types,this%n_types)) -! -! allocate(this%SK_cutoff(this%n_types,this%n_types)) -! allocate(this%Vrep_cutoff(this%n_types,this%n_types)) -! -! call rewind_xmlfile(fxml) -! -! do ii=1, this%n_types -! do jj=1, this%n_types -! call get_node(fxml, path='//DFTB_params/per_pair_data', attributes=attributes, status=status) -! if (status /= 0) then -! call system_abort("Can't find per_pair_data for " // str(ii) // ' ' // str(jj)) -! endif -! call QUIP_FoX_get_value(attributes, "type1", value, status); -! if (status == 0) read (value, *) ti -! call QUIP_FoX_get_value(attributes, "type2", value, status); -! if (status == 0) read (value, *) tj -! call QUIP_FoX_get_value(attributes, "SK_npts", value, status); -! if (status == 0) read (value, *) SK_npts -! call QUIP_FoX_get_value(attributes, "Vrep_npts", value, status); -! if (status == 0) read (value, *) Vrep_npts -! call QUIP_FoX_get_value(attributes, "SK_cutoff", value, status); -! if (status == 0) read (value, *) this%SK_cutoff(ti,tj) -! this%SK_cutoff(ti,tj) = this%SK_cutoff(ti,tj)*BOHR -! call QUIP_FoX_get_value(attributes, "Vrep_cutoff", value, status); -! if (status == 0) read (value, *) this%Vrep_cutoff(ti,tj) -! this%Vrep_cutoff(ti,tj) = this%Vrep_cutoff(ti,tj)*BOHR -! -! allocate(SK_r(SK_npts)) -! allocate(H_vals(10,SK_npts)) -! allocate(S_vals(10,SK_npts)) -! -! allocate(Vrep_r(Vrep_npts)) -! allocate(Vrep_vals(Vrep_npts)) -! -! call mark_node(fxml, path='//DFTB_params/per_pair_data/H_spline', attributes=attributes, status=status) -! if (status /= 0) then -! call system_abort("Can't find H_spline for " // str(ii) // ' ' // str(jj)) -! endif -! do i=1, SK_npts -! call get_node(fxml, path='point', attributes=attributes, pcdata=pcdata, status=status) -! if (status /= 0) then -! call system_abort("Can't find H_spline/point for " // str(ii) // ' ' // str(jj)) -! endif -! -! call QUIP_FoX_get_value(attributes, "r", value, status); -! if (status == 0) read (value, *) SK_r(i) -! -! ndata = 0 -! call build_data_array(pcdata, H_vals(1:10,i), ndata) -! end do -! SK_r = SK_r*BOHR -! H_vals = H_vals*HARTREE -! do i=1, 10 -! call initialise(this%H_spline(i,ti,tj), SK_r, H_vals(i,:), 0.0_dp, 0.0_dp) -! end do -! -! call mark_node(fxml, path='//DFTB_params/per_pair_data/S_spline', attributes=attributes, status=status) -! if (status /= 0) then -! call system_abort("Can't find S_spline for " // str(ii) // ' ' // str(jj)) -! endif -! do i=1, SK_npts -! call get_node(fxml, path='point', attributes=attributes, pcdata=pcdata, status=status) -! if (status /= 0) then -! call system_abort("Can't find S_spline/point for " // str(ii) // ' ' // str(jj)) -! endif -! -! call QUIP_FoX_get_value(attributes, "r", value, status); -! if (status == 0) read (value, *) SK_r(i) -! -! ndata = 0 -! call build_data_array(pcdata, S_vals(1:10,i), ndata) -! end do -! SK_r = SK_r*BOHR -! do i=1, 10 -! call initialise(this%S_spline(i,ti,tj), SK_r, S_vals(i,:), 0.0_dp, 0.0_dp) -! end do -! -! call mark_node(fxml, path='//DFTB_params/per_pair_data/Vrep_spline', attributes=attributes, status=status) -! if (status /= 0) then -! call system_abort("Can't find Vrep_spline for " // str(ii) // ' ' // str(jj)) -! endif -! do i=1, Vrep_npts -! call get_node(fxml, path='point', attributes=attributes, pcdata=pcdata, status=status) -! if (status /= 0) then -! call system_abort("Can't find Vrep_spline/point for " // str(ii) // ' ' // str(jj)) -! endif -! -! call QUIP_FoX_get_value(attributes, "r", value, status); -! if (status == 0) read (value, *) Vrep_r(i) -! -! ndata = 0 -! call build_data_array(pcdata, Vrep_vals(i:i), ndata) -! end do -! Vrep_r = Vrep_r*BOHR -! Vrep_vals = Vrep_vals*HARTREE -! call initialise(this%Vrep_spline(ti,tj), Vrep_r, Vrep_vals, 0.0_dp, 0.0_dp) -! -! deallocate(SK_r) -! deallocate(H_vals) -! deallocate(S_vals) -! deallocate(Vrep_r) -! deallocate(Vrep_vals) -! end do -! end do -! -!end subroutine TBModel_DFTB_read_params_xml -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine TBModel_DFTB_Print(this,file) - type(TBModel_DFTB), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer:: ti, tj, i - - if(this%n_types == 0) call System_Abort('TBModel_DFTB_Print: TBModel_DFTB structure not initialised') - - call Print('TBModel_DFTB Structure:', file=file) - - !! print DFTB params - call Print ("TBModel_DFTB cutoff " // this%cutoff, file=file) - do ti=1, this%n_types - call Print ("TBModel_DFTB type " // ti // " Z " // this%atomic_num(ti) // " n_orbs " // this%n_orbs(ti) // & - " n_elecs " // this%n_elecs(ti), file=file) - if (this%n_orb_sets(ti) == 1) then - call Print ("TBModel_DFTB E " // this%E(1,ti), file=file) - else if (this%n_orb_sets(ti) == 2) then - call Print ("TBModel_DFTB E " // this%E(1:2,ti), file=file) - else - call Print ("TBModel_DFTB E " //this%E(1:3,ti), file=file) - endif - end do - - call verbosity_push_decrement(PRINT_NERD) - if (current_verbosity() >= PRINT_NORMAL) then - do ti=1, this%n_types - do tj=1, this%n_types - call Print ("TBModel_DFTB interaction " // ti // " " // tj // " Z " // this%atomic_num(ti) // " " // & - this%atomic_num(tj), file=file) - - do i=1, 10 - call Print ("H_spline " // i, file=file) - call Print (this%H_spline(i,ti,tj), file=file) - end do - do i=1, 10 - call Print ("S_spline " // i, file=file) - call Print (this%S_spline(i,ti,tj), file=file) - end do - call Print ("Vrep_spline", file=file) - call Print (this%Vrep_spline(ti,tj), file=file) - - end do - end do - endif - call verbosity_pop() - -end subroutine TBModel_DFTB_Print - -function TBModel_DFTB_n_orbs_of_Z(this, Z) - type(TBModel_DFTB), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_DFTB_n_orbs_of_Z - - TBModel_DFTB_n_orbs_of_Z = this%n_orbs(get_type(this%type_of_atomic_num,Z)) -end function TBModel_DFTB_n_orbs_of_Z - -function TBModel_DFTB_n_orb_sets_of_Z(this, Z) - type(TBModel_DFTB), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_DFTB_n_orb_sets_of_Z - - TBModel_DFTB_n_orb_sets_of_Z = this%n_orb_sets(get_type(this%type_of_atomic_num,Z)) -end function TBModel_DFTB_n_orb_sets_of_Z - -function TBModel_DFTB_n_orbs_of_orb_set_of_Z(this, Z, i_set) - type(TBModel_DFTB), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_DFTB_n_orbs_of_orb_set_of_Z - - TBModel_DFTB_n_orbs_of_orb_set_of_Z = N_ORBS_OF_SET(this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z))) - -end function TBModel_DFTB_n_orbs_of_orb_set_of_Z - -function TBModel_DFTB_orb_type_of_orb_set_of_Z(this, Z, i_set) - type(TBModel_DFTB), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_DFTB_orb_type_of_orb_set_of_Z - - TBModel_DFTB_orb_type_of_orb_set_of_Z = this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z)) - -end function TBModel_DFTB_orb_type_of_orb_set_of_Z - -function TBModel_DFTB_n_elecs_of_Z(this, Z) - type(TBModel_DFTB), intent(in) :: this - integer, intent(in) :: Z - real(dp) TBModel_DFTB_n_elecs_of_Z - - TBModel_DFTB_n_elecs_of_Z = this%n_elecs(get_type(this%type_of_atomic_num,Z)) -end function TBModel_DFTB_n_elecs_of_Z - -subroutine TBModel_DFTB_get_HS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, b_H, b_S, i_mag) - type(TBModel_DFTB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, at_j - real(dp), intent(in) :: dv_hat(3), dv_mag - real(dp), intent(out) :: b_H(:,:) - real(dp), intent(out) :: b_S(:,:) - integer, intent(in), optional :: i_mag - - integer ti, tj, is, js, i_set, j_set - integer i, j - real(dp) SK_frad_H(N_SK), SK_frad_S(N_SK) - real(dp) dv_hat_sq(3) - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - tj = get_type(this%type_of_atomic_num,at%Z(at_j)) - - - if (dv_mag .feq. 0.0_dp) then - b_H = 0.0_dp - b_S = 0.0_dp - - i = 1 - do i_set = 1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - b_H(i,i) = this%E(i_set,ti) - b_S(i,i) = 1.0_dp - i = i + 1 - end do - end do - - else - - dv_hat_sq = dv_hat**2 - - i = 1 - do i_set=1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - j = 1 - do j_set=1, this%n_orb_sets(tj) - call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H, SK_frad_S) - do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) - - b_H(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H) - b_S(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_S) - j = j + 1 - end do - end do - i = i + 1 - end do - end do - endif - -end subroutine TBModel_DFTB_get_HS_blocks - -subroutine TBModel_DFTB_get_dHS_masks(this, at, at_ind, d_mask, od_mask) - type(TBModel_DFTB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_ind - logical, intent(out), optional :: d_mask(:), od_mask(:) - - if (at_ind < 0) then - if (present(d_mask)) d_mask = .true. - if (present(od_mask)) od_mask = .true. - else - if (present(d_mask)) d_mask = .false. - if (present(od_mask)) then - od_mask = .false. - od_mask(at_ind) = .true. - endif - endif - -end subroutine - -function TBModel_DFTB_get_dHS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) - type(TBModel_DFTB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, at_j - real(dp), intent(in) :: dv_hat(3), dv_mag - integer, intent(in) :: at_ind - real(dp), intent(out) :: b_dH(:,:,:) - real(dp), intent(out) :: b_dS(:,:,:) - integer, intent(in), optional :: i_mag - logical :: TBModel_DFTB_get_dHS_blocks - - integer ti, tj, is, js, i_set, j_set - integer i, j - real(dp) SK_frad_H(N_SK), SK_frad_S(N_SK) - real(dp) SK_dfrad_H(N_SK), SK_dfrad_S(N_SK) - real(dp) dv_hat_sq(3) - real(dp) virial_outerprod_fac - - if ((at_ind > 0 .and. at_i /= at_ind .and. at_j /= at_ind) .or. & - (at_ind > 0 .and. at_i == at_j) .or. & - (dv_mag > this%cutoff) .or. & - (dv_mag .feq. 0.0_dp)) then - TBModel_DFTB_get_dHS_blocks = .false. - return - endif - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - tj = get_type(this%type_of_atomic_num,at%Z(at_j)) - - if (dv_mag > this%SK_cutoff(ti,tj)) then - TBModel_DFTB_get_dHS_blocks = .false. - return - endif - - dv_hat_sq = dv_hat**2 - - i = 1 - do i_set=1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - j = 1 - do j_set=1, this%n_orb_sets(tj) - call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H, SK_frad_S) - call dradial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_dfrad_H, SK_dfrad_S) - do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) - - if (at_ind > 0) then - virial_outerprod_fac = 1.0_dp - else - virial_outerprod_fac = -dv_mag*dv_hat(-at_ind) - end if - b_dH(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & - this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H, SK_dfrad_H)*virial_outerprod_fac - b_dS(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & - this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_S, SK_dfrad_S)*virial_outerprod_fac - j = j + 1 - end do - end do - i = i + 1 - end do - end do - - if (at_ind == at_j) then - b_dH = -b_dH - b_dS = -b_dS - end if - - TBModel_DFTB_get_dHS_blocks = .true. - return - - -end function TBModel_DFTB_get_dHS_blocks - -subroutine radial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, is, js, f_H, f_S) - type(TBModel_DFTB), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dv_mag - integer, intent(in) :: orb_set_type_i, orb_set_type_j - integer, intent(in) :: is, js - real(dp), intent(out) :: f_H(N_SK), f_S(N_SK) - - if (dv_mag > this%SK_cutoff(ti,tj)) then - f_H = 0.0_dp - f_S = 0.0_dp - return - endif - - if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then - f_H(SK_SSS) = spline_value(this%H_spline(1,ti,tj), dv_mag) - f_S(SK_SSS) = spline_value(this%S_spline(1,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then - f_H(SK_SPS) = spline_value(this%H_spline(2,ti,tj), dv_mag) - f_S(SK_SPS) = spline_value(this%S_spline(2,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then - f_H(SK_SPS) = -spline_value(this%H_spline(2,tj,ti), dv_mag) - f_S(SK_SPS) = -spline_value(this%S_spline(2,tj,ti), dv_mag) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then - f_H(SK_PPS) = spline_value(this%H_spline(3,ti,tj), dv_mag) - f_S(SK_PPS) = spline_value(this%S_spline(3,ti,tj), dv_mag) - f_H(SK_PPP) = spline_value(this%H_spline(4,ti,tj), dv_mag) - f_S(SK_PPP) = spline_value(this%S_spline(4,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_D) then - f_H(SK_SDS) = spline_value(this%H_spline(5,ti,tj), dv_mag) - f_S(SK_SDS) = spline_value(this%S_spline(5,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_S) then - f_H(SK_SDS) = spline_value(this%H_spline(5,tj,ti), dv_mag) - f_S(SK_SDS) = spline_value(this%S_spline(5,tj,ti), dv_mag) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_D) then - f_H(SK_PDS) = spline_value(this%H_spline(6,ti,tj), dv_mag) - f_S(SK_PDS) = spline_value(this%S_spline(6,ti,tj), dv_mag) - f_H(SK_PDP) = spline_value(this%H_spline(7,ti,tj), dv_mag) - f_S(SK_PDP) = spline_value(this%S_spline(7,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_P) then - f_H(SK_PDS) = -spline_value(this%H_spline(6,tj,ti), dv_mag) - f_S(SK_PDS) = -spline_value(this%S_spline(6,tj,ti), dv_mag) - f_H(SK_PDP) = spline_value(this%H_spline(7,tj,ti), dv_mag) - f_S(SK_PDP) = spline_value(this%S_spline(7,tj,ti), dv_mag) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then - f_H(SK_DDS) = spline_value(this%H_spline(9,ti,tj), dv_mag) - f_S(SK_DDS) = spline_value(this%S_spline(8,ti,tj), dv_mag) - f_H(SK_DDP) = spline_value(this%H_spline(9,ti,tj), dv_mag) - f_S(SK_DDP) = spline_value(this%S_spline(9,ti,tj), dv_mag) - f_H(SK_DDD) = spline_value(this%H_spline(10,ti,tj), dv_mag) - f_S(SK_DDD) = spline_value(this%S_spline(10,ti,tj), dv_mag) - else - call system_abort("TBModel_DFTB radial_functions got invalide orb_set_type "//orb_set_type_i//" or "//orb_set_type_j) - endif - end subroutine radial_functions - - subroutine dradial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, is, js, f_dH, f_dS) - type(TBModel_DFTB), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dv_mag - integer, intent(in) :: orb_set_type_i, orb_set_type_j - integer, intent(in) :: is, js - real(dp), intent(out) :: f_dH(N_SK), f_dS(N_SK) - - if (dv_mag > this%SK_cutoff(ti,tj)) then - f_dH = 0.0_dp - f_dS = 0.0_dp - return - endif - - if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then - f_dH(SK_SSS) = spline_deriv(this%H_spline(1,ti,tj), dv_mag) - f_dS(SK_SSS) = spline_deriv(this%S_spline(1,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then - f_dH(SK_SPS) = spline_deriv(this%H_spline(2,ti,tj), dv_mag) - f_dS(SK_SPS) = spline_deriv(this%S_spline(2,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then - f_dH(SK_SPS) = -spline_deriv(this%H_spline(2,tj,ti), dv_mag) - f_dS(SK_SPS) = -spline_deriv(this%S_spline(2,tj,ti), dv_mag) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then - f_dH(SK_PPS) = spline_deriv(this%H_spline(3,ti,tj), dv_mag) - f_dS(SK_PPS) = spline_deriv(this%S_spline(3,ti,tj), dv_mag) - f_dH(SK_PPP) = spline_deriv(this%H_spline(4,ti,tj), dv_mag) - f_dS(SK_PPP) = spline_deriv(this%S_spline(4,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_D) then - f_dH(SK_SDS) = spline_deriv(this%H_spline(5,ti,tj), dv_mag) - f_dS(SK_SDS) = spline_deriv(this%S_spline(5,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_S) then - f_dH(SK_SDS) = spline_deriv(this%H_spline(5,tj,ti), dv_mag) - f_dS(SK_SDS) = spline_deriv(this%S_spline(5,tj,ti), dv_mag) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_D) then - f_dH(SK_PDS) = spline_deriv(this%H_spline(6,ti,tj), dv_mag) - f_dS(SK_PDS) = spline_deriv(this%S_spline(6,ti,tj), dv_mag) - f_dH(SK_PDP) = spline_deriv(this%H_spline(7,ti,tj), dv_mag) - f_dS(SK_PDP) = spline_deriv(this%S_spline(7,ti,tj), dv_mag) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_P) then - f_dH(SK_PDS) = -spline_deriv(this%H_spline(6,tj,ti), dv_mag) - f_dS(SK_PDS) = -spline_deriv(this%S_spline(6,tj,ti), dv_mag) - f_dH(SK_PDP) = spline_deriv(this%H_spline(7,tj,ti), dv_mag) - f_dS(SK_PDP) = spline_deriv(this%S_spline(7,tj,ti), dv_mag) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then - f_dH(SK_DDS) = spline_deriv(this%H_spline(9,ti,tj), dv_mag) - f_dS(SK_DDS) = spline_deriv(this%S_spline(8,ti,tj), dv_mag) - f_dH(SK_DDP) = spline_deriv(this%H_spline(9,ti,tj), dv_mag) - f_dS(SK_DDP) = spline_deriv(this%S_spline(9,ti,tj), dv_mag) - f_dH(SK_DDD) = spline_deriv(this%H_spline(10,ti,tj), dv_mag) - f_dS(SK_DDD) = spline_deriv(this%S_spline(10,ti,tj), dv_mag) - else - call system_abort("TBModel_DFTB dradial_functions got invalide orb_set_type "//orb_set_type_i//" or "//orb_set_type_j) - endif - -end subroutine dradial_functions - -function TBModel_DFTB_get_local_rep_E(this, at, i) - type(TBModel_DFTB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: TBModel_DFTB_get_local_rep_E - - real(dp) E, dist - integer ji, j, ti, tj - - TBModel_DFTB_get_local_rep_E = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (dist < this%Vrep_cutoff(ti,tj)) then - E = spline_value(this%Vrep_spline(ti,tj), dist) - TBModel_DFTB_get_local_rep_E = TBModel_DFTB_get_local_rep_E + E/2.0_dp - endif - end do - -end function TBModel_DFTB_get_local_rep_E - -function TBModel_DFTB_get_local_rep_E_force(this, at, i) result(force) - type(TBModel_DFTB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: force(3,at%N) - - real(dp) dE_dr, dist, dv_hat(3) - integer ji, j, ti, tj - - force = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist, cosines = dv_hat) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (dist < this%Vrep_cutoff(ti,tj)) then - dE_dr = spline_deriv(this%Vrep_spline(ti,tj),dist) - force(:,i) = force(:,i) + dE_dr*dv_hat(:)/2.0_dp - force(:,j) = force(:,j) - dE_dr*dv_hat(:)/2.0_dp - end if - end do - -end function TBModel_DFTB_get_local_rep_E_force - -function TBModel_DFTB_get_local_rep_E_virial(this, at, i) result(virial) - type(TBModel_DFTB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: virial(3,3) - - real(dp) dE_dr, dist, dv_hat(3) - integer ji, j, ti, tj - - virial = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist, cosines = dv_hat) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - - if (dist < this%Vrep_cutoff(ti,tj)) then - dE_dr = spline_deriv(this%Vrep_spline(ti,tj),dist) - virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist / 2.0_dp - end if - end do - -end function TBModel_DFTB_get_local_rep_E_virial - -end module TBModel_DFTB_module diff --git a/src/Potentials/TBModel_GSP.f95 b/src/Potentials/TBModel_GSP.f95 deleted file mode 100644 index c59421cb4c..0000000000 --- a/src/Potentials/TBModel_GSP.f95 +++ /dev/null @@ -1,1385 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X TBModel_GSP module -!X -!% Calculate energies using Goodwin-Skinner-Pettifor tight-binding model -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -module TBModel_GSP_module - -use system_module, only : dp, inoutput, system_abort, verbosity_push_decrement, verbosity_pop, operator(//) -use dictionary_module -use paramreader_module -use linearalgebra_module -use spline_module -use atoms_types_module -use atoms_module - -use TB_Common_module -use QUIP_Common_module - -implicit none -private - -integer, parameter :: max_n_orb_sets = 3 - -include 'TBModel_interface.h' - -public :: TBModel_GSP -type TBModel_GSP - integer :: n_types = 0 - character(len=STRING_LENGTH) label - - real(dp) :: cutoff = 0.0_dp - real(dp) :: cutoff_H = 0.0_dp - logical :: is_orthogonal = .true. - - integer, allocatable :: type_of_atomic_num(:) - integer, allocatable :: n_orbs(:), n_orb_sets(:), orb_set_type(:,:) - real(dp), allocatable :: n_elecs(:) - integer, allocatable :: atomic_num(:) - -! GSP parameters - real(dp), allocatable :: H_coeff(:,:,:) - real(dp), allocatable :: O_coeff(:,:,:) - real(dp), allocatable :: Atau(:,:,:) - real(dp), allocatable :: deltatau0(:,:,:) - real(dp), allocatable :: r0(:,:), rc(:,:), na(:,:), nb(:,:), nc(:,:) - - real(dp), allocatable :: B(:,:), Rcore(:,:), lambda0(:), C(:), nu(:), m(:) - real(dp), allocatable :: Rtail(:), Rcut(:) - - real(dp), allocatable :: Ai(:,:,:), Ri(:,:,:) - - real(dp) :: tailx0 - - real(dp), allocatable :: E(:,:) - - type(spline), allocatable :: H_tail_spline(:,:) - type(spline), allocatable :: Vrep_env_emb_tail_spline(:) - - logical :: has_default_fermi_E = .false., has_default_fermi_T = .true., has_default_band_width = .false., has_default_k_density=.false. - real(dp) :: default_fermi_E, default_fermi_T = 0.001_dp, default_band_width, default_k_density - -end type - -integer, private :: parse_cur_type -logical, private :: parse_in_tbm, parse_matched_label -type(TBModel_GSP), pointer :: parse_tbm - -interface Initialise - module procedure TBModel_GSP_Initialise_str -end interface Initialise - -interface Finalise - module procedure TBModel_GSP_Finalise -end interface Finalise - -interface Print - module procedure TBModel_GSP_Print -end interface Print - -interface n_orbs_of_Z - module procedure TBModel_GSP_n_orbs_of_Z -end interface n_orbs_of_Z - -interface n_orb_sets_of_Z - module procedure TBModel_GSP_n_orb_sets_of_Z -end interface n_orb_sets_of_Z - -interface n_orbs_of_orb_set_of_Z - module procedure TBModel_GSP_n_orbs_of_orb_set_of_Z -end interface n_orbs_of_orb_set_of_Z - -interface orb_type_of_orb_set_of_Z - module procedure TBModel_GSP_orb_type_of_orb_set_of_Z -end interface orb_type_of_orb_set_of_Z - -interface n_elecs_of_Z - module procedure TBModel_GSP_n_elecs_of_Z -end interface n_elecs_of_Z - -interface get_HS_blocks - module procedure TBModel_GSP_get_HS_blocks -end interface get_HS_blocks - -interface get_dHS_masks - module procedure TBModel_GSP_get_dHS_masks -end interface get_dHS_masks - -interface get_dHS_blocks - module procedure TBModel_GSP_get_dHS_blocks -end interface get_dHS_blocks - -interface get_local_rep_E - module procedure TBModel_GSP_get_local_rep_E -end interface get_local_rep_E - -interface get_local_rep_E_force - module procedure TBModel_GSP_get_local_rep_E_force -end interface get_local_rep_E_force - -interface get_local_rep_E_virial - module procedure TBModel_GSP_get_local_rep_E_virial -end interface get_local_rep_E_virial - -interface calc_H_coeff - module procedure TBModel_GSP_calc_H_coeff -end interface calc_H_coeff - -interface calc_H_coeff_deriv - module procedure TBModel_GSP_calc_H_coeff_deriv -end interface calc_H_coeff_deriv - -contains - -subroutine TBModel_GSP_Initialise_str(this, args_str, param_str) - type(TBModel_GSP), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_GSP_Initialise_str args_str')) then - call system_abort("TBModel_GSP_Initialise_str parse problems"//trim(args_str)) - endif - call finalise(params) - - call TBModel_GSP_read_params_xml(this, param_str) -end subroutine TBModel_GSP_Initialise_str - -subroutine TBModel_GSP_Finalise(this) - type(TBModel_GSP), intent(inout) :: this - - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%n_orbs)) deallocate(this%n_orbs) - if (allocated(this%n_elecs)) deallocate(this%n_elecs) - if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) - if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - - if (allocated(this%H_coeff)) deallocate(this%H_coeff) - if (allocated(this%O_coeff)) deallocate(this%O_coeff) - if (allocated(this%Atau)) deallocate(this%Atau) - if (allocated(this%deltatau0)) deallocate(this%deltatau0) - - if (allocated(this%r0)) deallocate(this%r0) - if (allocated(this%rc)) deallocate(this%rc) - if (allocated(this%na)) deallocate(this%na) - if (allocated(this%nb)) deallocate(this%nb) - if (allocated(this%nc)) deallocate(this%nc) - - if (allocated(this%B)) deallocate(this%B) - if (allocated(this%Rcore)) deallocate(this%Rcore) - if (allocated(this%lambda0)) deallocate(this%lambda0) - if (allocated(this%C)) deallocate(this%C) - if (allocated(this%nu)) deallocate(this%nu) - if (allocated(this%m)) deallocate(this%m) - if (allocated(this%Rtail)) deallocate(this%Rtail) - if (allocated(this%Rcut)) deallocate(this%Rcut) - - if (allocated(this%Ai)) deallocate(this%Ai) - if (allocated(this%Ri)) deallocate(this%Ri) - - if (allocated(this%E)) deallocate(this%E) - - if (allocated(this%H_tail_spline)) deallocate(this%H_tail_spline) - if (allocated(this%Vrep_env_emb_tail_spline)) deallocate(this%Vrep_env_emb_tail_spline) - - this%n_types = 0 - this%label = '' -end subroutine TBModel_GSP_Finalise - -subroutine TBM_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - character(len=1024) :: value - integer status - integer ti, tj, Zi, Zj - - if (name == 'GSP_params') then ! new GSP stanza - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_tbm%label)) > 0) then ! we were passed in a label - if (value == parse_tbm%label) then ! exact match - parse_matched_label = .true. - parse_in_tbm = .true. - else ! no match - parse_in_tbm = .false. - endif - else ! no label passed in - parse_in_tbm = .true. - endif - - if (parse_in_tbm) then - if (parse_tbm%n_types /= 0) then - call finalise(parse_tbm) - endif - - parse_cur_type = 1 - - call QUIP_FoX_get_value(attributes, "n_types", value, status); - if (status == 0) read (value, *) parse_tbm%n_types - call QUIP_FoX_get_value(attributes, "tailx0", value, status); - if (status == 0) read (value, *) parse_tbm%tailx0 - call QUIP_FoX_get_value(attributes, "cutoff", value, status); - if (status == 0) read (value, *) parse_tbm%cutoff - call QUIP_FoX_get_value(attributes, "cutoff_H", value, status); - if (status == 0) read (value, *) parse_tbm%cutoff_H - - allocate(parse_tbm%atomic_num(parse_tbm%n_types)) - parse_tbm%atomic_num = 0 - allocate(parse_tbm%n_orbs(parse_tbm%n_types)) - allocate(parse_tbm%n_elecs(parse_tbm%n_types)) - allocate(parse_tbm%n_orb_sets(parse_tbm%n_types)) - allocate(parse_tbm%orb_set_type(max_n_orb_sets,parse_tbm%n_types)) - allocate(parse_tbm%E(max_n_orb_sets,parse_tbm%n_types)) - allocate(parse_tbm%B(parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%Rcore(parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%lambda0(parse_tbm%n_types)) - allocate(parse_tbm%C(parse_tbm%n_types)) - allocate(parse_tbm%nu(parse_tbm%n_types)) - allocate(parse_tbm%m(parse_tbm%n_types)) - allocate(parse_tbm%Rtail(parse_tbm%n_types)) - allocate(parse_tbm%Rcut(parse_tbm%n_types)) - allocate(parse_tbm%Ai(4,parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%Ri(4,parse_tbm%n_types,parse_tbm%n_types)) - - allocate(parse_tbm%H_coeff(10, parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%O_coeff(10, parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%Atau(10, parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%deltatau0(10, parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%rc(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%r0(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%na(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%nb(parse_tbm%n_types, parse_tbm%n_types)) - allocate(parse_tbm%nc(parse_tbm%n_types, parse_tbm%n_types)) - - parse_tbm%H_coeff = 0.0_dp - parse_tbm%O_coeff = 0.0_dp - parse_tbm%Atau = 0.0_dp - parse_tbm%deltatau0 = 0.0_dp - parse_tbm%rc = 1.0_dp - parse_tbm%r0 = 0.0_dp - parse_tbm%na = 0.0_dp - parse_tbm%nb = 1.0_dp - parse_tbm%nc = 0.0_dp - parse_tbm%B = 1.0_dp - parse_tbm%Rcore = 0.0_dp - parse_tbm%lambda0 = 0.0_dp - parse_tbm%C = 0.0_dp - parse_tbm%nu = 0.0_dp - parse_tbm%m = 0.0_dp - parse_tbm%Rtail = 0.0_dp - parse_tbm%Rcut = 0.0_dp - parse_tbm%Ai = 0.0_dp - parse_tbm%Ri = 0.0_dp - endif - - elseif (parse_in_tbm .and. name == 'per_type_data') then - if (parse_cur_type > parse_tbm%n_types) & - call system_abort('Too many types defined in GSP_params') - - call QUIP_FoX_get_value(attributes, "Z", value, status); - if (status == 0) read (value, *) parse_tbm%atomic_num(parse_cur_type) - - call QUIP_FoX_get_value(attributes, "n_orbs", value, status); - if (status == 0) read (value, *) parse_tbm%n_orbs(parse_cur_type) - if (parse_tbm%n_orbs(parse_cur_type) == 5) then - parse_tbm%n_orb_sets(parse_cur_type) = 1 - parse_tbm%orb_set_type(1,parse_cur_type) = ORB_D - call QUIP_FoX_get_value(attributes, "E_d", value, status); - if (status == 0) read (value, *) parse_tbm%E(ORB_D,parse_cur_type) - else - call system_abort("TBModel_GSP_read_params_xml can only do d") - endif - - call QUIP_FoX_get_value(attributes, "n_elecs", value, status); - if (status == 0) read (value, *) parse_tbm%n_elecs(parse_cur_type) - - if (allocated(parse_tbm%type_of_atomic_num)) deallocate(parse_tbm%type_of_atomic_num) - allocate(parse_tbm%type_of_atomic_num(maxval(parse_tbm%atomic_num(:)))) - parse_tbm%type_of_atomic_num(:) = 0 - do ti=1, parse_tbm%n_types - if (parse_Tbm%atomic_num(ti) > 0) & - parse_tbm%type_of_atomic_num(parse_tbm%atomic_num(ti)) = ti - end do - -! Parameters of the repulsive environment-dependent term - call QUIP_FoX_get_value(attributes, "lambda0", value, status); - if (status == 0) read (value, *) parse_tbm%lambda0(parse_cur_type) - call QUIP_FoX_get_value(attributes, "C", value, status); - if (status == 0) read (value, *) parse_tbm%C(parse_cur_type) - call QUIP_FoX_get_value(attributes, "nu", value, status); - if (status == 0) read (value, *) parse_tbm%nu(parse_cur_type) - call QUIP_FoX_get_value(attributes, "m", value, status); - if (status == 0) read (value, *) parse_tbm%m(parse_cur_type) - call QUIP_FoX_get_value(attributes, "Rtail", value, status); - if (status == 0) read (value, *) parse_tbm%Rtail(parse_cur_type) - call QUIP_FoX_get_value(attributes, "Rcut", value, status); - if (status == 0) read (value, *) parse_tbm%Rcut(parse_cur_type) - - parse_cur_type = parse_cur_type + 1 - - elseif (parse_in_tbm .and. name == 'defaults') then - - call QUIP_FoX_get_value(attributes, "fermi_e", value, status) - if (status == 0) then - parse_tbm%has_default_fermi_e = .true. - read (value, *) parse_tbm%default_fermi_e - endif - call QUIP_FoX_get_value(attributes, "fermi_T", value, status) - if (status == 0) then - parse_tbm%has_default_fermi_T = .true. - read (value, *) parse_tbm%default_fermi_T - endif - call QUIP_FoX_get_value(attributes, "band_width", value, status) - if (status == 0) then - parse_tbm%has_default_band_width = .true. - read (value, *) parse_tbm%default_band_width - endif - call QUIP_FoX_get_value(attributes, "k_density", value, status) - if (status == 0) then - parse_tbm%has_default_k_density = .true. - read (value, *) parse_tbm%default_k_density - endif - - elseif (parse_in_tbm .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "Z1", value, status); - if (status == 0) read (value, *) Zi - call QUIP_FoX_get_value(attributes, "Z2", value, status); - if (status == 0) read (value, *) Zj - - ti = get_type(parse_tbm%type_of_atomic_num,Zi) - tj = get_type(parse_tbm%type_of_atomic_num,Zj) - - call QUIP_FoX_get_value(attributes, "rc", value, status); - if (status == 0) read (value, *) parse_tbm%rc(ti,tj) - call QUIP_FoX_get_value(attributes, "r0", value, status); - if (status == 0) read (value, *) parse_tbm%r0(ti,tj) - call QUIP_FoX_get_value(attributes, "na", value, status); - if (status == 0) read (value, *) parse_tbm%na(ti,tj) - call QUIP_FoX_get_value(attributes, "nb", value, status); - if (status == 0) read (value, *) parse_tbm%nb(ti,tj) - call QUIP_FoX_get_value(attributes, "nc", value, status); - if (status == 0) read (value, *) parse_tbm%nc(ti,tj) - -! parameters of the repulsive environment-dependent term - call QUIP_FoX_get_value(attributes, "B", value, status); - if (status == 0) read (value, *) parse_tbm%B(ti,tj) - call QUIP_FoX_get_value(attributes, "Rcore", value, status); - if (status == 0) read (value, *) parse_tbm%Rcore(ti,tj) - - call QUIP_FoX_get_value(attributes, "A1", value, status); - if (status == 0) read (value, *) parse_tbm%Ai(1,ti,tj) - call QUIP_FoX_get_value(attributes, "A2", value, status); - if (status == 0) read (value, *) parse_tbm%Ai(2,ti,tj) - call QUIP_FoX_get_value(attributes, "A3", value, status); - if (status == 0) read (value, *) parse_tbm%Ai(3,ti,tj) - call QUIP_FoX_get_value(attributes, "A4", value, status); - if (status == 0) read (value, *) parse_tbm%Ai(4,ti,tj) - call QUIP_FoX_get_value(attributes, "R1", value, status); - if (status == 0) read (value, *) parse_tbm%Ri(1,ti,tj) - call QUIP_FoX_get_value(attributes, "R2", value, status); - if (status == 0) read (value, *) parse_tbm%Ri(2,ti,tj) - call QUIP_FoX_get_value(attributes, "R3", value, status); - if (status == 0) read (value, *) parse_tbm%Ri(3,ti,tj) - call QUIP_FoX_get_value(attributes, "R4", value, status); - if (status == 0) read (value, *) parse_tbm%Ri(4,ti,tj) - - call QUIP_FoX_get_value(attributes, "H_dds", value, status); - if (status == 0) read (value, *) parse_tbm%H_coeff(SK_DDS,ti,tj) - call QUIP_FoX_get_value(attributes, "H_ddp", value, status); - if (status == 0) read (value, *) parse_tbm%H_coeff(SK_DDP,ti,tj) - call QUIP_FoX_get_value(attributes, "H_ddd", value, status); - if (status == 0) read (value, *) parse_tbm%H_coeff(SK_DDD,ti,tj) - - call QUIP_FoX_get_value(attributes, "O_dds", value, status); - if (status == 0) read (value, *) parse_tbm%O_coeff(SK_DDS,ti,tj) - call QUIP_FoX_get_value(attributes, "O_ddp", value, status); - if (status == 0) read (value, *) parse_tbm%O_coeff(SK_DDP,ti,tj) - call QUIP_FoX_get_value(attributes, "O_ddd", value, status); - if (status == 0) read (value, *) parse_tbm%O_coeff(SK_DDD,ti,tj) - - call QUIP_FoX_get_value(attributes, "Atau_dds", value, status); - if (status == 0) read (value, *) parse_tbm%Atau(SK_DDS,ti,tj) - call QUIP_FoX_get_value(attributes, "Atau_ddp", value, status); - if (status == 0) read (value, *) parse_tbm%Atau(SK_DDP,ti,tj) - call QUIP_FoX_get_value(attributes, "Atau_ddd", value, status); - if (status == 0) read (value, *) parse_tbm%Atau(SK_DDD,ti,tj) - - call QUIP_FoX_get_value(attributes, "deltatau0_dds", value, status); - if (status == 0) read (value, *) parse_tbm%deltatau0(SK_DDS,ti,tj) - call QUIP_FoX_get_value(attributes, "deltatau0_ddp", value, status); - if (status == 0) read (value, *) parse_tbm%deltatau0(SK_DDP,ti,tj) - call QUIP_FoX_get_value(attributes, "deltatau0_ddd", value, status); - if (status == 0) read (value, *) parse_tbm%deltatau0(SK_DDD,ti,tj) - - if (ti /= tj) then - parse_tbm%rc(tj,ti) = parse_tbm%rc(ti,tj) - parse_tbm%r0(tj,ti) = parse_tbm%r0(ti,tj) - parse_tbm%na(tj,ti) = parse_tbm%na(ti,tj) - parse_tbm%nb(tj,ti) = parse_tbm%nb(ti,tj) - parse_tbm%nc(tj,ti) = parse_tbm%nc(ti,tj) - parse_tbm%B(tj,ti) = parse_tbm%B(ti,tj) - parse_tbm%Rcore(tj,ti) = parse_tbm%Rcore(ti,tj) - parse_tbm%Ai(1,tj,ti) = parse_tbm%Ai(1,ti,tj) - parse_tbm%Ai(2,tj,ti) = parse_tbm%Ai(2,ti,tj) - parse_tbm%Ai(3,tj,ti) = parse_tbm%Ai(3,ti,tj) - parse_tbm%Ai(4,tj,ti) = parse_tbm%Ai(4,ti,tj) - parse_tbm%Ri(1,tj,ti) = parse_tbm%Ri(1,ti,tj) - parse_tbm%Ri(2,tj,ti) = parse_tbm%Ri(2,ti,tj) - parse_tbm%Ri(3,tj,ti) = parse_tbm%Ri(3,ti,tj) - parse_tbm%Ri(4,tj,ti) = parse_tbm%Ri(4,ti,tj) - parse_tbm%H_coeff(SK_DDS,tj,ti) = parse_tbm%H_coeff(SK_DDS,ti,tj) - parse_tbm%H_coeff(SK_DDP,tj,ti) = parse_tbm%H_coeff(SK_DDP,ti,tj) - parse_tbm%H_coeff(SK_DDD,tj,ti) = parse_tbm%H_coeff(SK_DDD,ti,tj) - parse_tbm%O_coeff(SK_DDS,tj,ti) = parse_tbm%O_coeff(SK_DDS,ti,tj) - parse_tbm%O_coeff(SK_DDP,tj,ti) = parse_tbm%O_coeff(SK_DDP,ti,tj) - parse_tbm%O_coeff(SK_DDD,tj,ti) = parse_tbm%O_coeff(SK_DDD,ti,tj) - parse_tbm%Atau(SK_DDS,tj,ti) = parse_tbm%Atau(SK_DDS,ti,tj) - parse_tbm%Atau(SK_DDP,tj,ti) = parse_tbm%Atau(SK_DDP,ti,tj) - parse_tbm%Atau(SK_DDD,tj,ti) = parse_tbm%Atau(SK_DDD,ti,tj) - parse_tbm%deltatau0(SK_DDS,tj,ti) = parse_tbm%deltatau0(SK_DDS,ti,tj) - parse_tbm%deltatau0(SK_DDP,tj,ti) = parse_tbm%deltatau0(SK_DDP,ti,tj) - parse_tbm%deltatau0(SK_DDD,tj,ti) = parse_tbm%deltatau0(SK_DDD,ti,tj) - end if - endif - -end subroutine TBM_startElement_handler - -subroutine TBM_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (name == 'GSP_params') then - parse_in_tbm = .false. - endif - -end subroutine TBM_endElement_handler - -subroutine TBModel_GSP_read_params_xml(this, param_str) - type(TBModel_GSP), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_tbm = .false. - parse_matched_label = .false. - parse_tbm => this - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - startElement_handler = TBM_startElement_handler, & - endElement_handler = TBM_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types <= 0) call system_abort("TBModel_GSP_read_params_xml couldn't find any types defined") -!" - call TBModel_GSP_fix_tails(this) - -end subroutine - -subroutine TBModel_GSP_fix_tails(this) - type(TBModel_GSP), intent(inout) :: this - - integer ti, tj - real(dp) :: x(2), y(2), yd1, yd2, x_env(2) - - x(1) = this%tailx0 - x(2) = this%cutoff_H - y(2) = 0.0_dp - yd2 = 0.0_dp - - allocate(this%H_tail_spline(this%n_types, this%n_types)) - allocate(this%Vrep_env_emb_tail_spline(this%n_types)) - - do ti=1, this%n_types - do tj=1, this%n_types - y(1) = TBModel_GSP_dist_scaling(x(1),this%r0(ti,tj), & - this%rc(ti,tj),this%na(ti,tj),this%nb(ti,tj),this%nc(ti,tj)) - yd1 = TBModel_GSP_dist_scaling_deriv(x(1),this%r0(ti,tj), & - this%rc(ti,tj),this%na(ti,tj),this%nb(ti,tj),this%nc(ti,tj)) - call initialise(this%H_tail_spline(ti,tj), x, y, yd1, yd2) - end do - - x_env(1) = this%Rtail(ti) - x_env(2) = this%Rcut(ti) - y(1) = TBModel_GSP_Vrep_env_emb_term(x_env(1),this%C(ti),this%nu(ti)) - yd1 = TBModel_GSP_Vrep_env_emb_term_deriv(x_env(1),this%C(ti),this%nu(ti)) - call initialise(this%Vrep_env_emb_tail_spline(ti), x_env, y, yd1, yd2) - end do - -end subroutine - -subroutine TBModel_GSP_Print(this,file) - type(TBModel_GSP), intent(in) :: this - type(Inoutput), intent(inout),optional :: file - - integer:: ti, tj - - if(this%n_types == 0) call System_Abort('TBModel_GSP_Print: TBModel_GSP structure not initialised') -!' - call Print('TBModel_GSP Structure:', file=file) - - !! print GSP params - call Print ("TBModel_GSP tailx0 " // this%tailx0 // " cutoff " // this%cutoff, file=file) - call Print (" " // " cutoff_H " // this%cutoff_H, file=file) - do ti=1, this%n_types - call Print ("TBModel_GSP type " // ti // " Z " // this%atomic_num(ti) // " n_orbs " // this%n_orbs(ti) // & - " n_elecs " // this%n_elecs(ti), file=file) - if (this%n_orb_sets(ti) == 1) then - call Print ("TBModel_GSP E " // this%E(1,ti), file=file) - else - call Print ("TBModel_GSP Es " // this%E(ORB_S,ti), file=file) - call Print ("TBModel_GSP Ed " // this%E(ORB_D,ti), file=file) - endif - end do - - call verbosity_push_decrement() - do ti=1, this%n_types - do tj=1, this%n_types - call Print ("TBModel_GSP interaction " // & - ti // " " // tj // " Z " // this%atomic_num(ti) // " " // this%atomic_num(tj), file=file) - - call Print ("TBModel_GSP r0 " // this%r0(ti,tj), file=file) - - call Print ("TBModel_GSP SK dds " // this%H_coeff(SK_DDS,ti,tj), file=file) - call Print ("TBModel_GSP SK ddp " // this%H_coeff(SK_DDP,ti,tj), file=file) - call Print ("TBModel_GSP SK ddd " // this%H_coeff(SK_DDD,ti,tj), file=file) - call Print ("TBModel_GSP Overlap coefficients dds " // this%O_coeff(SK_DDS,ti,tj), file=file) - call Print ("TBModel_GSP Overlap coefficients ddp " // this%O_coeff(SK_DDP,ti,tj), file=file) - call Print ("TBModel_GSP Overlap coefficients ddd " // this%O_coeff(SK_DDD,ti,tj), file=file) - call Print ("TBModel_GSP Atau dds " // this%Atau(SK_DDS,ti,tj), file=file) - call Print ("TBModel_GSP Atau ddp " // this%Atau(SK_DDP,ti,tj), file=file) - call Print ("TBModel_GSP Atau ddd " // this%Atau(SK_DDD,ti,tj), file=file) - call Print ("TBModel_GSP deltatau0 dds " // this%deltatau0(SK_DDS,ti,tj), file=file) - call Print ("TBModel_GSP deltatau0 ddp " // this%deltatau0(SK_DDP,ti,tj), file=file) - call Print ("TBModel_GSP deltatau0 ddd " // this%deltatau0(SK_DDD,ti,tj), file=file) - call Print ("TBModel_GSP H scaling rc na nb nc " // & - this%rc(ti,tj) // " " // this%na(ti,tj) // " " // this%nb(ti,tj) // " " // this%nc(ti,tj), file=file) - - call Print (this%H_tail_spline(ti,tj), file=file) - call Print (this%Vrep_env_emb_tail_spline(ti), file=file) - - call Print ("TBModel_GSP pair potential Vrep A1 A2 A3 A4 " // & - this%Ai(1,ti,tj) // " " // this%Ai(2,ti,tj) // " " // & - this%Ai(3,ti,tj) // " " // this%Ai(4,ti,tj), file=file) - call Print ("TBModel_GSP pair potential Vrep R1 R2 R3 R4 " // & - this%Ri(1,ti,tj) // " " // this%Ri(2,ti,tj) // " " // & - this%Ri(3,ti,tj) // " " // this%Ri(4,ti,tj), file=file) - - call Print ("TBModel_GSP Environmental Vrep : B Rcore " // & - this%B(ti,tj) // " " // this%Rcore(ti,tj), file=file) - end do - call Print ("TBModel_GSP Environmental Vrep : lambda0 nu " // & - this%lambda0(ti) // " " // this%nu(ti) , file=file) - call Print ("TBModel_GSP Environmental Vrep : C m " // & - this%c(ti) // " " // this%m(ti), file=file) - call Print ("TBModel_GSP Environmental Vrep : Rtail Rcut " // & - this%Rtail(ti) // " " // this%Rcut(ti), file=file) - end do - call verbosity_pop() - -end subroutine TBModel_GSP_Print - -function TBModel_GSP_n_orbs_of_Z(this, Z) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_GSP_n_orbs_of_Z - - TBModel_GSP_n_orbs_of_Z = this%n_orbs(get_type(this%type_of_atomic_num,Z)) -end function TBModel_GSP_n_orbs_of_Z - -function TBModel_GSP_n_orb_sets_of_Z(this, Z) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_GSP_n_orb_sets_of_Z - - TBModel_GSP_n_orb_sets_of_Z = this%n_orb_sets(get_type(this%type_of_atomic_num,Z)) -end function TBModel_GSP_n_orb_sets_of_Z - -function TBModel_GSP_n_orbs_of_orb_set_of_Z(this, Z, i_set) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_GSP_n_orbs_of_orb_set_of_Z - - TBModel_GSP_n_orbs_of_orb_set_of_Z = N_ORBS_OF_SET(this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z))) - -end function TBModel_GSP_n_orbs_of_orb_set_of_Z - -function TBModel_GSP_orb_type_of_orb_set_of_Z(this, Z, i_set) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_GSP_orb_type_of_orb_set_of_Z - - TBModel_GSP_orb_type_of_orb_set_of_Z = this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z)) - -end function TBModel_GSP_orb_type_of_orb_set_of_Z - -function TBModel_GSP_n_elecs_of_Z(this, Z) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: Z - real(dp) TBModel_GSP_n_elecs_of_Z - - TBModel_GSP_n_elecs_of_Z = this%n_elecs(get_type(this%type_of_atomic_num,Z)) -end function TBModel_GSP_n_elecs_of_Z - -subroutine TBModel_GSP_get_HS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, b_H, b_S) - type(TBModel_GSP), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, at_j - real(dp), intent(in) :: dv_hat(3), dv_mag - real(dp), intent(out) :: b_H(:,:) - real(dp), intent(out) :: b_S(:,:) - - integer i, j, ti, tj, is, js, i_set, j_set - real(dp) SK_frad_H(N_SK) - real(dp) dv_hat_sq(3) - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - tj = get_type(this%type_of_atomic_num,at%Z(at_j)) - - b_S = 0.0_dp - - if (dv_mag .feq. 0.0_dp) then - b_H = 0.0_dp - - i = 1 - do i_set = 1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - b_H(i,i) = onsite_function(this, ti, this%orb_set_type(i_set,ti)) - b_S(i,i) = 1.0_dp - i = i + 1 - end do - end do - - else - - dv_hat_sq = dv_hat**2 - - i = 1 - do i_set=1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - j = 1 - do j_set=1, this%n_orb_sets(tj) - call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - SK_frad_H) - do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) - - b_H(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H) - j = j + 1 - end do - end do - i = i + 1 - end do - end do - endif - -end subroutine TBModel_GSP_get_HS_blocks - -subroutine TBModel_GSP_get_dHS_masks(this, at_ind, d_mask, od_mask) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: at_ind - logical, intent(out), optional :: d_mask(:), od_mask(:) - - if (at_ind < 0) then - if (present(d_mask)) d_mask = .true. - if (present(od_mask)) od_mask = .true. - else - if (present(d_mask)) d_mask = .false. - if (present(od_mask)) then - od_mask = .false. - od_mask(at_ind) = .true. - endif - endif -end subroutine - -function TBModel_GSP_get_dHS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, at_ind, b_dH, b_dS) - type(TBModel_GSP), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, at_j - real(dp), intent(in) :: dv_hat(3), dv_mag - integer, intent(in) :: at_ind - real(dp), intent(out) :: b_dH(:,:,:) - real(dp), intent(out) :: b_dS(:,:,:) - logical :: TBModel_GSP_get_dHS_blocks - - integer :: i, j, ti, tj, is, js, i_set, j_set - real(dp) SK_frad_H(N_SK) - real(dp) SK_dfrad_H(N_SK) - real(dp) dv_hat_sq(3) - real(dp) virial_outerprod_fac - - if ((at_ind > 0 .and. at_i /= at_ind .and. at_j /= at_ind) .or. & - (at_ind > 0 .and. at_i == at_j) .or. & - (dv_mag > this%cutoff_H) .or. & - (dv_mag .feq. 0.0_dp)) then - TBModel_GSP_get_dHS_blocks = .false. - return - endif - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - tj = get_type(this%type_of_atomic_num,at%Z(at_j)) - - b_dS = 0.0_dp - - dv_hat_sq = dv_hat**2 - - i = 1 - do i_set=1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - j = 1 - do j_set=1, this%n_orb_sets(tj) - call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - SK_frad_H) - call dradial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - SK_dfrad_H) - do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) - - if (at_ind > 0) then - virial_outerprod_fac = 1.0_dp - else - virial_outerprod_fac = -dv_mag*dv_hat(-at_ind) - end if - b_dH(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & - this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H, SK_dfrad_H)*virial_outerprod_fac - j = j + 1 - end do - end do - i = i + 1 - end do - end do - - if (at_ind == at_j) b_dH = -b_dH - - TBModel_GSP_get_dHS_blocks = .true. - return - -end function TBModel_GSP_get_dHS_blocks - -subroutine radial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, f_H) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dv_mag - integer, intent(in) :: orb_set_type_i, orb_set_type_j - real(dp), intent(out) :: f_H(N_SK) - - if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then - f_H(SK_DDS) = calc_H_coeff(this, SK_DDS, dv_mag, ti, tj) - f_H(SK_DDP) = calc_H_coeff(this, SK_DDP, dv_mag, ti, tj) - f_H(SK_DDD) = calc_H_coeff(this, SK_DDD, dv_mag, ti, tj) - endif -end subroutine radial_functions - -subroutine dradial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, f_dH) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dv_mag - integer, intent(in) :: orb_set_type_i, orb_set_type_j - real(dp), intent(out) :: f_dH(N_SK) - - if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then - f_dH(SK_DDS) = calc_H_coeff_deriv(this, SK_DDS, dv_mag, ti, tj) - f_dH(SK_DDP) = calc_H_coeff_deriv(this, SK_DDP, dv_mag, ti, tj) - f_dH(SK_DDD) = calc_H_coeff_deriv(this, SK_DDD, dv_mag, ti, tj) - endif -end subroutine dradial_functions - -function TBModel_GSP_calc_H_coeff(this, sk_ind, dist, ti, tj) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: sk_ind - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_GSP_calc_H_coeff - - TBModel_GSP_calc_H_coeff = this%H_coeff(sk_ind, ti, tj)* & - TBModel_GSP_H_dist_func(this, dist, ti, tj) - -end function TBModel_GSP_calc_H_coeff - -function TBModel_GSP_calc_H_coeff_deriv(this, sk_ind, dist, ti, tj) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: sk_ind - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_GSP_calc_H_coeff_deriv - - TBModel_GSP_calc_H_coeff_deriv = this%H_coeff(sk_ind, ti, tj)* & - TBModel_GSP_H_dist_func_deriv(this, dist, ti, tj) - -end function TBModel_GSP_calc_H_coeff_deriv - -function TBModel_GSP_calc_O_coeff(this, sk_ind, dist, ti, tj) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: sk_ind - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_GSP_calc_O_coeff - - TBModel_GSP_calc_O_coeff = this%O_coeff(sk_ind, ti, tj)* & - TBModel_GSP_H_dist_func(this, dist, ti, tj) - -end function TBModel_GSP_calc_O_coeff - -function TBModel_GSP_calc_O_coeff_deriv(this, sk_ind, dist, ti, tj) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: sk_ind - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_GSP_calc_O_coeff_deriv - - TBModel_GSP_calc_O_coeff_deriv = this%O_coeff(sk_ind, ti, tj)* & - TBModel_GSP_H_dist_func_deriv(this, dist, ti, tj) - -end function TBModel_GSP_calc_O_coeff_deriv - -function TBModel_GSP_H_dist_func(this, dist, ti, tj) - type(TBModel_GSP), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_GSP_H_dist_func - - if (dist <= this%cutoff_H) then - if (dist <= this%tailx0) then - TBModel_GSP_H_dist_func = TBModel_GSP_dist_scaling(dist, & - this%r0(ti,tj),this%rc(ti,tj),this%na(ti,tj),this%nb(ti,tj),this%nc(ti,tj)) - else - TBModel_GSP_H_dist_func = spline_value(this%H_tail_spline(ti,tj), dist) - endif - else - TBModel_GSP_H_dist_func = 0.0_dp - endif -end function TBModel_GSP_H_dist_func - -function TBModel_GSP_H_dist_func_deriv(this, dist, ti, tj) - type(TBModel_GSP), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp) :: TBModel_GSP_H_dist_func_deriv - - if (dist <= this%cutoff_H) then - if (dist <= this%tailx0) then - TBModel_GSP_H_dist_func_deriv = TBModel_GSP_dist_scaling_deriv(dist, & - this%r0(ti,tj),this%rc(ti,tj),this%na(ti,tj),this%nb(ti,tj),this%nc(ti,tj)) - else - TBModel_GSP_H_dist_func_deriv = spline_deriv(this%H_tail_spline(ti,tj), dist) - endif - else - TBModel_GSP_H_dist_func_deriv = 0.0_dp - endif -end function TBModel_GSP_H_dist_func_deriv - -! Compute the screening function Sij_tau -function TBModel_GSP_screening(this,sk_ind,at,i,j,dist,ti,tj) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: sk_ind - type(Atoms) :: at - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - integer :: i,j - real(dp) :: TBModel_GSP_screening - - TBModel_GSP_screening = & - (TBModel_GSP_screening_c(this,sk_ind,at,i,j,dist,ti,tj) & - - TBModel_GSP_screening_mu(this) )/ & - (1._dp + TBModel_GSP_calc_O_coeff(this,sk_ind,dist,ti,tj)**2.0_dp - & - 2._dp * TBModel_GSP_screening_mu(this) ) - -end function TBModel_GSP_screening - -function TBModel_GSP_screening_c(this,sk_ind,at, i,j,dist,ti,tj) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: sk_ind - type(Atoms) :: at - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dist - integer :: i,j - real(dp) :: TBModel_GSP_screening_c - real(dp) :: c_temp - real(dp) :: rik, rjk - real(dp) :: g_i, g_j, g_j2, theta_i, theta_j - integer :: k, kk, ki, kj, tk - logical :: lgo - real(dp) :: cterm(15) - - c_temp = 0._dp - do ki = 1, n_neighbours(at, i) - k = neighbour(at, i, ki, rik) - if (rik .feq. 0.0_dp) cycle - tk = get_type(this%type_of_atomic_num, at%Z(k)) - rjk = distance(at, j, k, (/0, 0, 0/)) - - theta_i = cosine_neighbour(at,i,j,k) - theta_j = cosine_neighbour(at,j,i,k) - g_i = TBModel_GSP_screening_g(sk_ind,theta_i) - g_j = TBModel_GSP_screening_g(sk_ind,theta_j) - g_j2 = TBModel_GSP_screening_g(sk_ind,-theta_j) - - call TBModel_GSP_calc_c_terms(this) - !call TBModel_GSP_calc_c_terms(this,sk_ind,dist,rik,rjk,ti,tj,tk,g_i,g_j,g_j2,cterm) - - c_temp = c_temp + (cterm(1)*cterm(2) + cterm(3)*cterm(4))*cterm(5)*cterm(6) - & - cterm(7) *cterm(8) *cterm(9) *cterm(10)*cterm(10) - & - cterm(11)*cterm(12)*cterm(13)*cterm(14)*cterm(14) - enddo - - do kj =1, n_neighbours(at, j) - k = neighbour(at, j, kj, rjk) - if (rjk .feq. 0.0_dp) cycle - tk = get_type(this%type_of_atomic_num, at%Z(k)) - lgo = .true. - do ki=1, n_neighbours(at, i) - kk = neighbour(at, i, ki) - if(k.eq.kk) then - exit - lgo = .false. - endif - enddo - if(.not.lgo) cycle - rik = distance(at, i, k, (/0, 0, 0/)) - - theta_i = cosine_neighbour(at,i,j,k) - theta_j = cosine_neighbour(at,j,i,k) - g_i = TBModel_GSP_screening_g(sk_ind,theta_i) - g_j = TBModel_GSP_screening_g(sk_ind,theta_j) - g_j2 = TBModel_GSP_screening_g(sk_ind,-theta_j) - - !call TBModel_GSP_calc_c_terms(this,sk_ind,dist,rik,rjk,ti,tj,tk,g_i,g_j,g_j2,cterm) - call TBModel_GSP_calc_c_terms(this) - - c_temp = c_temp + (cterm(1)*cterm(2) + cterm(3)*cterm(4))*cterm(5)*cterm(6) - & - cterm(7) *cterm(8) *cterm(9) *cterm(10)*cterm(10) - & - cterm(11)*cterm(12)*cterm(13)*cterm(14)*cterm(14) - enddo - - TBModel_GSP_screening_c = & - this%Atau(sk_ind,ti,tj)*(1._dp + this%deltatau0(sk_ind,ti,tj))/4._dp/ & - TBModel_GSP_calc_H_coeff (this,sk_ind,dist,ti,tj) * c_temp - -end function TBModel_GSP_screening_c - -function TBModel_GSP_screening_c_deriv(this) - type(TBModel_GSP), intent(in) :: this - real(dp) :: TBModel_GSP_screening_c_deriv - - TBModel_GSP_screening_c_deriv = 0.d0 - -end function TBModel_GSP_screening_c_deriv - -function TBModel_GSP_screening_mu(this) - type(TBModel_GSP), intent(in) :: this - real(dp) :: TBModel_GSP_screening_mu - - TBModel_GSP_screening_mu = 0._dp - -end function TBModel_GSP_screening_mu - -function TBModel_GSP_screening_g(sk_ind,theta) - integer, intent(in) :: sk_ind - real(dp) :: theta - real(dp) :: TBModel_GSP_screening_g - - if(sk_ind.eq.SK_DDS) then - TBModel_GSP_screening_g = (1._dp/4._dp) * (1._dp + 3._dp* dcos(2._dp*theta)) - elseif(sk_ind.eq.SK_DDP) then - TBModel_GSP_screening_g = (dsqrt(3._dp)/2._dp)*dsin(2._dp*theta) - elseif(sk_ind.eq.SK_DDD) then - TBModel_GSP_screening_g = (dsqrt(3._dp)/4._dp)*(1._dp - dcos(2._dp*theta)) - endif - -end function TBModel_GSP_screening_g - -subroutine TBModel_GSP_calc_c_terms(this) - type(TBModel_GSP), intent(in) :: this -! integer, intent(in) :: sk_ind -! integer, intent(in) :: ti, tj, tk -! real(dp), intent(in) :: rij, rik, rjk -! real(dp) :: g_i, g_j, g_j2 -! real(dp) :: cterm(15) - -! cterm(1) = TBModel_GSP_calc_H_coeff(this,SK_SDS,rik,ti,tk) -! cterm(2) = TBModel_GSP_calc_O_coeff(this,SK_SDS,rjk,tk,tj) -! cterm(3) = TBModel_GSP_calc_O_coeff(this,SK_SDS,rik,ti,tk) -! cterm(4) = TBModel_GSP_calc_H_coeff(this,SK_SDS,rjk,tk,tj) -! cterm(5) = g_i -! cterm(6) = g_j2 -! cterm(7) = TBModel_GSP_calc_H_coeff(this,SK_SDS,rik,ti,tk) -! cterm(8) = TBModel_GSP_calc_O_coeff(this,SK_SDS,rik,tk,ti) -! cterm(9) = TBModel_GSP_calc_O_coeff(this,sk_ind,rij,ti,tj) -! cterm(10)= g_i -! cterm(11)= TBModel_GSP_calc_O_coeff(this,sk_ind,rij,ti,tj) -! cterm(12)= TBModel_GSP_calc_O_coeff(this,SK_SDS,rjk,tj,tk) -! cterm(13)= TBModel_GSP_calc_H_coeff(this,SK_SDS,rjk,tk,tj) -! cterm(14)= g_j -end subroutine TBModel_GSP_calc_c_terms - -subroutine TBModel_GSP_calc_c_terms_deriv(this) - type(TBModel_GSP), intent(in) :: this -! integer, intent(in) :: sk_ind -! integer, intent(in) :: ti, tj, tk -! real(dp), intent(in) :: rij, rik, rjk -! real(dp) :: dg_i, dg_j, dg_j2 -! real(dp) :: cterm_deriv(15) - -! cterm_deriv(1) = TBModel_GSP_calc_H_coeff_deriv(this,SK_SDS,rik,ti,tk) -! cterm_deriv(2) = TBModel_GSP_calc_O_coeff_deriv(this,SK_SDS,rjk,tk,tj) -! cterm_deriv(3) = TBModel_GSP_calc_O_coeff_deriv(this,SK_SDS,rik,ti,tk) -! cterm_deriv(4) = TBModel_GSP_calc_H_coeff_deriv(this,SK_SDS,rjk,tk,tj) -! cterm_deriv(5) = dg_i -! cterm_deriv(6) = dg_j2 -! cterm_deriv(7) = TBModel_GSP_calc_H_coeff_deriv(this,SK_SDS,rik,ti,tk) -! cterm_deriv(8) = TBModel_GSP_calc_O_coeff_deriv(this,SK_SDS,rik,tk,ti) -! cterm_deriv(9) = TBModel_GSP_calc_O_coeff_deriv(this,sk_ind,rij,ti,tj) -! cterm_deriv(10)= dg_i -! cterm_deriv(11)= TBModel_GSP_calc_O_coeff_deriv(this,sk_ind,rij,ti,tj) -! cterm_deriv(12)= TBModel_GSP_calc_O_coeff_deriv(this,SK_SDS,rjk,tj,tk) -! cterm_deriv(13)= TBModel_GSP_calc_H_coeff_deriv(this,SK_SDS,rjk,tk,tj) -! cterm_deriv(14)= dg_j -end subroutine TBModel_GSP_calc_c_terms_deriv - -!Compute the repulsive pair potential V(Rij) = sum_k A_k (R_k - Rij)**3 -function TBModel_GSP_Vrep_dist_func(this, dist, ti, tj) - type(TBModel_GSP), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - integer :: i - real(dp) :: TBModel_GSP_Vrep_dist_func - - TBModel_GSP_Vrep_dist_func = 0.0_dp - - do i = 1, 4 - if(dist.gt.this%Ri(i,ti,tj) ) cycle - TBModel_GSP_Vrep_dist_func = TBModel_GSP_Vrep_dist_func + this%Ai(i,ti,tj) * (this%Ri(i,ti,tj) - dist)**3.0_dp - enddo - -end function - -! Compute the derivative of the repulsive pair potential V(Rij) = sum_k A_k (R_k - Rij)**3 -function TBModel_GSP_Vrep_dist_func_deriv(this, dist, ti, tj) - type(TBModel_GSP), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - integer :: i - real(dp) :: TBModel_GSP_Vrep_dist_func_deriv - - TBModel_GSP_Vrep_dist_func_deriv = 0.0_dp - do i = 1, 4 - if(dist.gt.this%Ri(i,ti,tj) ) cycle - TBModel_GSP_Vrep_dist_func_deriv = TBModel_GSP_Vrep_dist_func_deriv - 3.0_dp * this%Ai(i,ti,tj) * (this%Ri(i,ti,tj) - dist)**2.0_dp - enddo -end function TBModel_GSP_Vrep_dist_func_deriv - -! Compute the environmental Repulsive pair potential -function TBModel_GSP_Vrep_env(this,dist,lambda,ti,tj) - type(TBModel_GSP), intent(in) :: this - real(dp), intent(in) :: dist - real(dp) :: lambda - integer, intent(in) :: ti, tj - real(dp) :: TBModel_GSP_Vrep_env - - TBModel_GSP_Vrep_env = this%B(ti,tj)/dist * & - dexp(-lambda*(dist - 2.0_dp* this%Rcore(ti,tj))) - -end function TBModel_GSP_Vrep_env - -! Compute the derivative (term ij) of the environmental Repulsive pair potential -function TBModel_GSP_Vrep_env_deriv_ij(this,dist,ti,tj,lambda) - - type(TBModel_GSP), intent(in) :: this - real(dp), intent(in) :: dist - integer, intent(in) :: ti, tj - real(dp), intent(in) :: lambda - real(dp) :: TBModel_GSP_Vrep_env_deriv_ij - - TBModel_GSP_Vrep_env_deriv_ij = - this%B(ti,tj)/dist * & - dexp(-lambda*(dist - 2.0_dp* this%Rcore(ti,tj))) * & - (1.0_dp/dist + lambda) - -end function TBModel_GSP_Vrep_env_deriv_ij - -! Compute the derivative (term wk) of the environmental Repulsive pair potential -function TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,ti,tj,emb_i,lambda) - type(TBModel_GSP), intent(in) :: this - real(dp), intent(in) :: dist, dist_k - integer, intent(in) :: ti, tj - real(dp) :: emb_i - real(dp) :: lambda - real(dp) :: emb_term_deriv - real(dp) :: TBModel_GSP_Vrep_env_deriv_wk - - if(dist_k.lt.this%Rtail(ti)) then - emb_term_deriv = TBModel_GSP_Vrep_env_emb_term_deriv(dist_k,this%C(ti),this%nu(ti)) - elseif(dist_k.lt.this%Rcut(ti)) then - emb_term_deriv = spline_deriv(this%Vrep_env_emb_tail_spline(ti), dist_k) - else - emb_term_deriv = 0.0_dp - endif - - TBModel_GSP_Vrep_env_deriv_wk = - this%B(ti,tj)/dist/this%m(ti)/2.0_dp * & - (dist - 2.0_dp* this%Rcore(ti,tj)) * & - dexp(-lambda * (dist - 2.0_dp* this%Rcore(ti,tj)))*& - emb_i ** ((1-this%m(ti))/this%m(ti)) * & - emb_term_deriv - -end function TBModel_GSP_Vrep_env_deriv_wk - -! Compute the embedded-atom expression => Sum C exp(-nu Rik) -function TBModel_GSP_Vrep_env_emb(this, at, i, ti) - type(TBModel_GSP), intent(in) :: this - type(Atoms), intent(in) :: at - integer :: i, ti, k - integer :: ki - real(dp) :: emb, rik - real(dp) :: TBModel_GSP_Vrep_env_emb - - emb = 0.0_dp - do ki=1, n_neighbours(at, i) - k = neighbour(at, i, ki, rik) - if (rik .feq. 0.0_dp) cycle - if(rik.lt.this%Rtail(ti)) then - emb = emb + TBModel_GSP_Vrep_env_emb_term(rik,this%C(ti),this%nu(ti)) - elseif(rik.lt.this%Rcut(ti)) then - emb = emb + spline_value(this%Vrep_env_emb_tail_spline(ti),rik) - endif - enddo - TBModel_GSP_Vrep_env_emb = emb -end function TBModel_GSP_Vrep_env_emb - -! compute C exp(-nu Rij) -function TBModel_GSP_Vrep_env_emb_term(dist,C, nu) - real(dp), intent(in) :: C, nu - real(dp), intent(in) :: dist - real(dp) :: TBModel_GSP_Vrep_env_emb_term - - TBModel_GSP_Vrep_env_emb_term = C * dexp(-nu*dist) - -end function TBModel_GSP_Vrep_env_emb_term - -! compute derivative of C exp(-nu Rij) -function TBModel_GSP_Vrep_env_emb_term_deriv(dist,C, nu) - real(dp), intent(in) :: C, nu - real(dp), intent(in) :: dist - real(dp) :: TBModel_GSP_Vrep_env_emb_term_deriv - - TBModel_GSP_Vrep_env_emb_term_deriv = - nu * C * dexp(-nu*dist) - -end function TBModel_GSP_Vrep_env_emb_term_deriv - -! Compute lambda, necessary for the embedded-atom like repulsive potential -function TBModel_GSP_Vrep_env_lambda(this,ti,tj,emb_i,emb_j) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp) :: emb_i, emb_j - real(dp) :: lambda_i, lambda_j - real(dp) :: TBModel_GSP_Vrep_env_lambda - - lambda_i = this%lambda0(ti) + emb_i**(1/this%m(ti)) - lambda_j = this%lambda0(tj) + emb_j**(1/this%m(tj)) - TBModel_GSP_Vrep_env_lambda = (lambda_i + lambda_j)/2.0_dp - -end function TBModel_GSP_Vrep_env_lambda - -! Scaling factor for the hopping parameters -function TBModel_GSP_dist_scaling(r, r0, rc, na, nb, nc) - real(dp), intent(in) :: r, r0, rc, na, nb, nc - real(dp) :: TBModel_GSP_dist_scaling - - TBModel_GSP_dist_scaling = (r0/r)**na * exp(nb* ((r0/rc)**nc - (r/rc)**nc)) - -end function TBModel_GSP_dist_scaling - -! Scaling factor derivative for the hopping parameters -function TBModel_GSP_dist_scaling_deriv(r, r0, rc, na, nb, nc) - real(dp), intent(in) :: r, r0, rc, na, nb, nc - real(dp) :: TBModel_GSP_dist_scaling_deriv - - real(dp) tmp1, tmp2 - - tmp1 = (r0/r)**na - tmp2 = exp(nb*((r0/rc)**nc - (r/rc)**nc)) - - TBModel_GSP_dist_scaling_deriv = na*tmp1/(-r)*tmp2 + tmp1*tmp2*(-nb)*nc*((r/rc)**nc)/r -end function TBModel_GSP_dist_scaling_deriv - -function onsite_function(this, ti, orb_set_type) - type(TBModel_GSP), intent(in) :: this - integer, intent(in) :: ti, orb_set_type - real(dp) :: onsite_function - - onsite_function = this%E(orb_set_type, ti) - -end function onsite_function - -!Repulsive term: Pure two body potential + Repulsive embedded-atom like potential -function TBModel_GSP_get_local_rep_E(this, at, i) - type(TBModel_GSP), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: emb_i, emb_j, lambda_ij - real(dp) :: TBModel_GSP_get_local_rep_E - - real(dp) :: E, dist - integer ji, j, ti, tj - - TBModel_GSP_get_local_rep_E = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - emb_i = TBModel_GSP_Vrep_env_emb(this, at, i, ti) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - emb_j = TBModel_GSP_Vrep_env_emb(this, at, j, tj) - lambda_ij = TBModel_GSP_Vrep_env_lambda(this,ti,tj,emb_i,emb_j) - - E = TBModel_GSP_Vrep_dist_func(this,dist,ti,tj) + & - TBModel_GSP_Vrep_env(this,dist,lambda_ij,ti,tj) - - TBModel_GSP_get_local_rep_E = TBModel_GSP_get_local_rep_E + E/2.0_dp - end do - -end function TBModel_GSP_get_local_rep_E - -! Forces due to the repulsive term: two body potential + embedded-atom like potential -function TBModel_GSP_get_local_rep_E_force(this, at, i) result(force) - type(TBModel_GSP), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: force(3,at%N) - - real(dp) :: dE_dr, dist, dist_k, dv_hat(3) - real(dp) :: emb_i, emb_j - real(dp) :: lambda_ij - integer :: ji, j, ti, tj - integer :: k, ik, jk - - force = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - emb_i = TBModel_GSP_Vrep_env_emb(this, at, i, ti) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist, cosines = dv_hat) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - emb_j = TBModel_GSP_Vrep_env_emb(this, at, j, tj) - lambda_ij = TBModel_GSP_Vrep_env_lambda(this,ti,tj,emb_i,emb_j) - - dE_dr = TBModel_GSP_Vrep_dist_func_deriv(this, dist, ti, tj) + & - TBModel_GSP_Vrep_env_deriv_ij(this,dist,ti,tj,lambda_ij) - force(:,i) = force(:,i) + dE_dr*dv_hat(:)/2.0_dp - force(:,j) = force(:,j) - dE_dr*dv_hat(:)/2.0_dp - - do ik = 1, n_neighbours(at, i) - k = neighbour(at, i, ik, dist_k, cosines = dv_hat) - if (dist_k .feq. 0.0_dp) cycle - dE_dr = TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,ti,tj,emb_i,lambda_ij) - force(:,i) = force(:,i) + dE_dr*dv_hat(:)/2.0_dp - force(:,k) = force(:,k) - dE_dr*dv_hat(:)/2.0_dp - enddo - - do jk = 1, n_neighbours(at, j) - k = neighbour(at, j, jk, dist_k, cosines = dv_hat) - if (dist_k .feq. 0.0_dp) cycle - dE_dr = TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,tj,ti,emb_j,lambda_ij) - force(:,j) = force(:,j) + dE_dr*dv_hat(:)/2.0_dp - force(:,k) = force(:,k) - dE_dr*dv_hat(:)/2.0_dp - enddo - end do -end function TBModel_GSP_get_local_rep_E_force - -function TBModel_GSP_get_local_rep_E_virial(this, at, i) result(virial) - type(TBModel_GSP), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: virial(3,3) - real(dp) :: lambda_ij - - real(dp) :: emb_i, emb_j - real(dp) :: dE_dr, dist, dist_k, dv_hat(3) - integer :: ji, j, ti, tj, k, ik, jk - - virial = 0.0_dp - - ti = get_type(this%type_of_atomic_num, at%Z(i)) - emb_i = TBModel_GSP_Vrep_env_emb(this, at, i, ti) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dist, cosines = dv_hat) - if (dist .feq. 0.0_dp) cycle - tj = get_type(this%type_of_atomic_num, at%Z(j)) - emb_j = TBModel_GSP_Vrep_env_emb(this, at, j, tj) - lambda_ij = TBModel_GSP_Vrep_env_lambda(this,ti,tj,emb_i,emb_j) - - dE_dr = TBModel_GSP_Vrep_dist_func_deriv(this, dist, ti, tj) + & - TBModel_GSP_Vrep_env_deriv_ij(this,dist,ti,tj,lambda_ij) - virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist / 2.0_dp - - do ik = 1, n_neighbours(at, i) - k = neighbour(at, i, ik, dist_k, cosines = dv_hat) - if (dist_k .feq. 0.0_dp) cycle - dE_dr = TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,ti,tj,emb_i,lambda_ij) - virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist_k / 2.0_dp - enddo - - do jk = 1, n_neighbours(at, j) - k = neighbour(at, j, jk, dist_k, cosines = dv_hat) - if (dist_k .feq. 0.0_dp) cycle - dE_dr = TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,tj,ti,emb_j,lambda_ij) - virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist_k / 2.0_dp - enddo - end do - -end function TBModel_GSP_get_local_rep_E_virial - -end module TBModel_GSP_module - diff --git a/src/Potentials/TBModel_NRL_TB.f95 b/src/Potentials/TBModel_NRL_TB.f95 deleted file mode 100644 index d343a2dc08..0000000000 --- a/src/Potentials/TBModel_NRL_TB.f95 +++ /dev/null @@ -1,1921 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X TBModel_NRL_TB module -!X -!% Calculate energies using NRL-TB tight-binding model -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module TBModel_NRL_TB_module - -use system_module, only : dp, print, inoutput, optional_default, system_abort, verbosity_push_decrement, verbosity_pop -use periodictable_module -use units_module -use linearalgebra_module -use dictionary_module -use extendable_str_module -use paramreader_module -use atoms_module -use error_module - -use TB_Common_module -use QUIP_Common_module -use TBModel_NRL_TB_defs_module - -implicit none -private - -! character(30) :: nrltb_default_file = "tightbind.parms.NRL_TB.xml" - -include 'TBModel_interface.h' - -public :: TBModel_NRL_TB -type TBModel_NRL_TB - integer :: n_types = 0, n_mag = 0 - logical :: is_orthogonal = .true., is_magnetic = .false., has_pair_repulsion = .false., & - overlap_zero_limit = .true., force_harrison_signs = .false., has_short_ranged_splines = .false. - character(len=STRING_LENGTH) label - - real(dp) :: cutoff = 0.0_dp - - integer, allocatable :: type_of_atomic_num(:) - integer, allocatable :: n_orbs(:), n_elecs(:), n_orb_sets(:), orb_set_type(:,:) - integer, allocatable :: atomic_num(:) - - real(dp), allocatable :: atomic_mass(:) - real(dp), allocatable :: r_cut(:,:), screen_l(:,:) - real(dp), allocatable :: pair_rep_inner(:,:), pair_rep_outer(:,:) - real(dp), allocatable :: r_min_spline(:,:), sigma_spline(:,:) - - real(dp), allocatable :: lambda_sq(:,:) - real(dp), allocatable :: abcd(:,:,:,:,:) - - real(dp), allocatable :: H_coeff(:,:,:,:,:), S_coeff(:,:,:,:,:) - - logical :: has_default_fermi_e = .false., has_default_fermi_T = .true., has_default_band_width = .false., has_default_k_density=.false. - real(dp) :: default_fermi_e, default_fermi_T = 0.001_dp, default_band_width, default_k_density - -end type TBModel_NRL_TB - -integer :: parse_cur_type_i, parse_cur_type_j -type(extendable_str), private, save :: parse_cur_data -logical, private :: parse_in_tbm, parse_matched_label -type (TBModel_NRL_TB), pointer :: parse_tbm - - - -interface Initialise - module procedure TBModel_NRL_TB_Initialise_str -end interface Initialise - -interface Finalise - module procedure TBModel_NRL_TB_Finalise -end interface Finalise - -interface Print - module procedure TBModel_NRL_TB_Print -end interface Print - -interface n_orbs_of_Z - module procedure TBModel_NRL_TB_n_orbs_of_Z -end interface n_orbs_of_Z - -interface n_orb_sets_of_Z - module procedure TBModel_NRL_TB_n_orb_sets_of_Z -end interface n_orb_sets_of_Z - -interface n_orbs_of_orb_set_of_Z - module procedure TBModel_NRL_TB_n_orbs_of_orb_set_of_Z -end interface n_orbs_of_orb_set_of_Z - -interface orb_type_of_orb_set_of_Z - module procedure TBModel_NRL_TB_orb_type_of_orb_set_of_Z -end interface orb_type_of_orb_set_of_Z - -interface n_elecs_of_Z - module procedure TBModel_NRL_TB_n_elecs_of_Z -end interface n_elecs_of_Z - -interface get_HS_blocks - module procedure TBModel_NRL_TB_get_HS_blocks -end interface get_HS_blocks - -interface get_dHS_masks - module procedure TBModel_NRL_TB_get_dHS_masks -end interface get_dHS_masks - -interface get_dHS_blocks - module procedure TBModel_NRL_TB_get_dHS_blocks -end interface get_dHS_blocks - -interface get_local_rep_E - module procedure TBModel_NRL_TB_get_local_rep_E -end interface get_local_rep_E - -interface get_local_rep_E_force - module procedure TBModel_NRL_TB_get_local_rep_E_force -end interface get_local_rep_E_force - -interface get_local_rep_E_virial - module procedure TBModel_NRL_TB_get_local_rep_E_virial -end interface get_local_rep_E_virial - -contains - -subroutine TBModel_NRL_TB_Initialise_str(this, args_str, param_str) - type(TBModel_NRL_TB), intent(inout) :: this - character(len=*), intent(in) :: args_str - character(len=*), intent(in) :: param_str - - type(Dictionary) :: params - - call Finalise(this) - - call initialise(params) - this%label='' - call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_NRL_TB_Initialise_str args_str')) then - call system_abort("TBModel_NRL_TB_Initialise_str failed to parse label from args_str="//trim(args_str)) - endif - call finalise(params) - - call TBModel_NRL_TB_read_params_xml(this, param_str) -end subroutine TBModel_NRL_TB_Initialise_str - -subroutine TBModel_NRL_TB_Finalise(this) - type(TBModel_NRL_TB), intent(inout) :: this - - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%n_orbs)) deallocate(this%n_orbs) - if (allocated(this%n_elecs)) deallocate(this%n_elecs) - if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) - if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) - - if (allocated(this%atomic_mass)) deallocate(this%atomic_mass) - if (allocated(this%r_cut)) deallocate(this%r_cut) - if (allocated(this%screen_l)) deallocate(this%screen_l) - if (allocated(this%pair_rep_inner)) deallocate(this%pair_rep_inner) - if (allocated(this%pair_rep_outer)) deallocate(this%pair_rep_outer) - - if (allocated(this%lambda_sq)) deallocate(this%lambda_sq) - if (allocated(this%abcd)) deallocate(this%abcd) - if (allocated(this%H_coeff)) deallocate(this%H_coeff) - if (allocated(this%S_coeff)) deallocate(this%S_coeff) - - this%n_types = 0 - this%n_mag = 0 - this%label = '' -end subroutine TBModel_NRL_TB_Finalise - -subroutine TBM_characters_handler(in) - character(len=*), intent(in) :: in - - if (parse_in_tbm) then - call concat(parse_cur_data, in, keep_lf=.false.) - endif -end subroutine TBM_characters_handler - -subroutine TBM_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - - integer ii, ti, tj - - print *, "TBM_startElement_handler" - - call zero(parse_cur_data) - - if (name == 'NRL_TB_params') then ! new NRL_TB stanza - - if (parse_in_tbm) & - call system_abort("IPModel_startElement_handler entered NRL_TB_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") - - if (parse_matched_label) return ! we already found an exact match for this label - - call QUIP_FoX_get_value(attributes, 'label', value, status) - if (status /= 0) value = '' - - if (len(trim(parse_tbm%label)) > 0) then ! we were passed in a label - if (value == parse_tbm%label) then ! exact match - parse_matched_label = .true. - parse_in_tbm = .true. - else ! no match - parse_in_tbm = .false. - endif - else ! no label passed in - parse_in_tbm = .true. - endif - - if (parse_in_tbm) then - call Initialise(parse_cur_data) - if (parse_tbm%n_types /= 0) then - call finalise(parse_tbm) - endif - endif - - elseif (parse_in_tbm .and. name == 'defaults') then - - call QUIP_FoX_get_value(attributes, "fermi_e", value, status) - if (status == 0) then - parse_tbm%has_default_fermi_e = .true. - read (value, *) parse_tbm%default_fermi_e - endif - call QUIP_FoX_get_value(attributes, "fermi_T", value, status) - if (status == 0) then - parse_tbm%has_default_fermi_T = .true. - read (value, *) parse_tbm%default_fermi_T - endif - call QUIP_FoX_get_value(attributes, "band_width", value, status) - if (status == 0) then - parse_tbm%has_default_band_width = .true. - read (value, *) parse_tbm%default_band_width - endif - call QUIP_FoX_get_value(attributes, "k_density", value, status) - if (status == 0) then - parse_tbm%has_default_k_density = .true. - read (value, *) parse_tbm%default_k_density - endif - - elseif (parse_in_tbm .and. name == 'header') then - - call QUIP_FoX_get_value(attributes, "is_orthogonal", value, status); - if (status == 0) read (value, *) parse_tbm%is_orthogonal - call QUIP_FoX_get_value(attributes, "is_magnetic", value, status) - if (status == 0) read (value, *) parse_tbm%is_magnetic - if (parse_tbm%is_magnetic) then - parse_tbm%n_mag = 2 - else - parse_tbm%n_mag = 1 - endif - call QUIP_FoX_get_value(attributes, "has_pair_repulsion", value, status) - if (status == 0) read (value, *) parse_tbm%has_pair_repulsion - call QUIP_FoX_get_value(attributes, "overlap_zero_limit", value, status) - if (status == 0) read (value, *) parse_tbm%overlap_zero_limit - call QUIP_FoX_get_value(attributes, "force_harrison_signs", value, status) - if (status == 0) read (value, *) parse_tbm%force_harrison_signs - call QUIP_FoX_get_value(attributes, "has_short_ranged_splines", value, status) - if (status == 0) read (value, *) parse_tbm%has_short_ranged_splines - - elseif (parse_in_tbm .and. name == 'n_types') then - - call QUIP_FoX_get_value(attributes, "v", value, status); - if (status == 0) read (value, *) parse_tbm%n_types - - allocate(parse_tbm%atomic_num(parse_tbm%n_types)) - parse_tbm%atomic_num = 0 - allocate(parse_tbm%atomic_mass(parse_tbm%n_types)) - allocate(parse_tbm%n_orbs(parse_tbm%n_types)) - allocate(parse_tbm%n_elecs(parse_tbm%n_types)) - allocate(parse_tbm%n_orb_sets(parse_tbm%n_types)) - allocate(parse_tbm%orb_set_type(max_n_orb_sets,parse_tbm%n_types)) - allocate(parse_tbm%r_cut(parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%screen_l(parse_tbm%n_types,parse_tbm%n_types)) - if (parse_tbm%has_pair_repulsion) then - allocate(parse_tbm%pair_rep_inner(parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%pair_rep_outer(parse_tbm%n_types,parse_tbm%n_types)) - endif - if (parse_tbm%has_short_ranged_splines) then - allocate(parse_tbm%r_min_spline(parse_tbm%n_types,parse_tbm%n_types)) - allocate(parse_tbm%sigma_spline(parse_tbm%n_types,parse_tbm%n_types)) - endif - allocate(parse_tbm%lambda_sq(parse_tbm%n_types,parse_tbm%n_mag)) - allocate(parse_tbm%abcd(4,max_n_orb_sets,parse_tbm%n_types,parse_tbm%n_types,parse_tbm%n_mag)) - allocate(parse_tbm%H_coeff(4,N_SK,parse_tbm%n_types,parse_tbm%n_types,parse_tbm%n_mag)) - allocate(parse_tbm%S_coeff(4,N_SK,parse_tbm%n_types,parse_tbm%n_types,parse_tbm%n_mag)) - - elseif (parse_in_tbm .and. name == 'per_type_data') then - - if (parse_tbm%n_types == 0) & - call system_abort("NRL_TB_params got to per_type_data before finding n_types") - - call QUIP_FoX_get_value(attributes, "type", value, status); - if (status == 0) read (value, *) ti - - call QUIP_FoX_get_value(attributes, "atomic_mass", value, status); - if (status == 0) read (value, *) parse_tbm%atomic_mass(ti) - parse_tbm%atomic_num(ti) = 0 - call QUIP_FoX_get_value(attributes, "atomic_num", value, status); - if (status == 0) read (value, *) parse_tbm%atomic_num(ti) - if (parse_tbm%atomic_num(ti) == 0) then - parse_tbm%atomic_num(ti) = Atomic_Number_from_Mass(parse_tbm%atomic_mass(ti)) - endif - call QUIP_FoX_get_value(attributes, "n_orbs", value, status); - if (status == 0) read (value, *) parse_tbm%n_orbs(ti) - call QUIP_FoX_get_value(attributes, "n_elecs", value, status); - if (status == 0) read (value, *) parse_tbm%n_elecs(ti) - call QUIP_FoX_get_value(attributes, "n_orb_sets", value, status); - if (status == 0) read (value, *) parse_tbm%n_orb_sets(ti) - if (parse_tbm%is_magnetic) then - call QUIP_FoX_get_value(attributes, "lambda_sq_up", value, status); - if (status == 0) read (value, *) parse_tbm%lambda_sq(ti,1) - call QUIP_FoX_get_value(attributes, "lambda_sq_down", value, status); - if (status == 0) read (value, *) parse_tbm%lambda_sq(ti,2) - else - call QUIP_FoX_get_value(attributes, "lambda_sq", value, status); - if (status == 0) read (value, *) parse_tbm%lambda_sq(ti,:) - endif - - if (allocated(parse_tbm%type_of_atomic_num)) deallocate(parse_tbm%type_of_atomic_num) - allocate(parse_tbm%type_of_atomic_num(maxval(parse_tbm%atomic_num(:)))) - parse_tbm%type_of_atomic_num(:) = 0 - do ii=1, parse_tbm%n_types - if (parse_tbm%atomic_num(ii) > 0) & - parse_tbm%type_of_atomic_num(parse_tbm%atomic_num(ii)) = ii - end do - - parse_cur_type_i = ti - parse_cur_type_j = ti - - elseif (parse_in_tbm .and. name == 'orb_set_type') then - - call zero(parse_cur_data) - - elseif (parse_in_tbm .and. name == 'per_pair_data') then - - call QUIP_FoX_get_value(attributes, "type1", value, status); - if (status == 0) read (value, *) ti - call QUIP_FoX_get_value(attributes, "type2", value, status); - if (status == 0) read (value, *) tj - call QUIP_FoX_get_value(attributes, "r_cut", value, status); - if (status == 0) read (value, *) parse_tbm%r_cut(ti,tj) - call QUIP_FoX_get_value(attributes, "screen_l", value, status); - if (status == 0) read (value, *) parse_tbm%screen_l(ti,tj) - if (parse_tbm%has_pair_repulsion) then - call QUIP_FoX_get_value(attributes, "pair_rep_inner", value, status); - if (status == 0) read (value, *) parse_tbm%pair_rep_inner(ti,tj) - call QUIP_FoX_get_value(attributes, "pair_rep_outer", value, status); - if (status == 0) read (value, *) parse_tbm%pair_rep_outer(ti,tj) - endif - if (parse_tbm%has_short_ranged_splines) then - call QUIP_FoX_get_value(attributes, "r_min_spline", value, status); - if (status == 0) read (value, *) parse_tbm%r_min_spline(ti,tj) - call QUIP_FoX_get_value(attributes, "sigma_spline", value, status); - if (status == 0) read (value, *) parse_tbm%sigma_spline(ti,tj) - endif - - parse_cur_type_i = ti - parse_cur_type_j = tj - - elseif (parse_in_tbm .and. name == 'abcd') then - - call zero(parse_cur_data) - - elseif (parse_in_tbm .and. name == 'H_coeff') then - - call zero(parse_cur_data) - - elseif (parse_in_tbm .and. name == 'S_coeff') then - - call zero(parse_cur_data) - - endif - -end subroutine TBM_startElement_handler - -subroutine TBM_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - character(len=10240) :: val - real(dp) :: abcd_v(32), coeff_v(160) - integer k - - if (parse_in_tbm) then - if (name == 'NRL_TB_params') then - parse_in_tbm = .false. - elseif (name == 'orb_set_type') then - val = string(parse_cur_data) - read (val, *) parse_tbm%orb_set_type(1:parse_tbm%n_orb_sets(parse_cur_type_i),parse_cur_type_i) - elseif (name == 'abcd') then - val = string(parse_cur_data) - if (parse_tbm%is_magnetic) then - if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals - read (val, *) abcd_v(1:32) - parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(1:4) - parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(5:8) - parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(9:12) - parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(13:16) - parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(17:20) - parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(21:24) - parse_tbm%abcd(1:4,4,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(25:28) - parse_tbm%abcd(1:4,4,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(29:32) - else ! no f orbitals - read (val, *) abcd_v(1:24) - parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(1:4) - parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(5:8) - parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(9:12) - parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(13:16) - parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(17:20) - parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(21:24) - endif - else - if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals - read (val, *) abcd_v(1:16) - parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(1:4) - parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(5:8) - parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(9:12) - parse_tbm%abcd(1:4,4,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(13:16) - else ! no f orbitals - read (val, *) abcd_v(1:12) - parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(1:4) - parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(5:8) - parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(9:12) - endif - endif - elseif (name == 'H_coeff') then - val = string(parse_cur_data) - if (parse_tbm%is_magnetic) then - if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals - read (val, *) coeff_v(1:160) - else ! no f orbitals - read (val, *) coeff_v(1:80) - coeff_v(81:160) = 0.0_dp - endif - do k=1, 20 - parse_tbm%H_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,1) = coeff_v(8*(k-1)+1:8*(k-1)+4) - parse_tbm%H_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,2) = coeff_v(8*(k-1)+5:8*(k-1)+8) - end do - else - if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals - read (val, *) coeff_v(1:80) - else ! no f orbitals - read (val, *) coeff_v(1:40) - coeff_v(41:80) = 0.0_dp - endif - do k=1, 20 - parse_tbm%H_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,1) = coeff_v(4*(k-1)+1:4*(k-1)+4) - end do - endif - elseif (name == 'S_coeff') then - val = string(parse_cur_data) - if (parse_tbm%is_magnetic) then - if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals - read (val, *) coeff_v(1:160) - else ! no f orbitals - read (val, *) coeff_v(1:80) - coeff_v(81:160) = 0.0_dp - endif - do k=1, 20 - parse_tbm%S_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,1) = coeff_v(8*(k-1)+1:8*(k-1)+4) - parse_tbm%S_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,2) = coeff_v(8*(k-1)+5:8*(k-1)+8) - end do - else - if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals - read (val, *) coeff_v(1:80) - else ! no f orbitals - read (val, *) coeff_v(1:40) - coeff_v(41:80) = 0.0_dp - endif - do k=1, 20 - parse_tbm%S_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,1) = coeff_v(4*(k-1)+1:4*(k-1)+4) - end do - endif - endif - endif - -end subroutine TBM_endElement_handler - -subroutine TBModel_NRL_TB_read_params_xml(this, param_str) - type(TBModel_NRL_TB), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len(trim(param_str)) <= 0) return - - parse_in_tbm = .false. - parse_matched_label = .false. - parse_tbm => this - call Initialise(parse_cur_data) - - call open_xml_string(fxml, param_str) - - call parse(fxml, & - characters_handler = TBM_characters_handler, & - startElement_handler = TBM_startElement_handler, & - endElement_handler = TBM_endElement_handler) - - call close_xml_t(fxml) - - if (this%n_types == 0) call system_abort("Called TBModel_NRL_TB_read_params_xml but no types are defined") - - this%cutoff = maxval(this%r_cut) - - call TBModel_NRL_TB_change_units(this) - - call finalise(parse_cur_data) - -end subroutine TBModel_NRL_TB_read_params_xml - -subroutine TBModel_NRL_TB_change_units(this) - type(TBModel_NRL_TB), intent(inout) :: this - - integer :: i, j - - this%r_cut = this%r_cut * BOHR - this%cutoff = this%cutoff * BOHR - this%screen_l = this%screen_l * BOHR - - if (this%has_pair_repulsion) then - this%pair_rep_inner = this%pair_rep_inner * BOHR - this%pair_rep_outer = this%pair_rep_outer * BOHR - endif - - if (this%has_short_ranged_splines) then - this%r_min_spline = this%r_min_spline * BOHR - this%sigma_spline = this%sigma_spline * BOHR - endif - - this%lambda_sq = this%lambda_sq / BOHR - this%abcd = this%abcd * RYDBERG - - this%H_coeff(MC_E,:,:,:,:) = this%H_coeff(MC_E,:,:,:,:) * RYDBERG - this%H_coeff(MC_F,:,:,:,:) = this%H_coeff(MC_F,:,:,:,:) * RYDBERG / BOHR - this%H_coeff(MC_FB,:,:,:,:) = this%H_coeff(MC_FB,:,:,:,:) * RYDBERG / BOHR**2 - this%H_coeff(MC_G_SQ,:,:,:,:) = this%H_coeff(MC_G_SQ,:,:,:,:) / BOHR - - do i=1, this%n_types - do j=1, this%n_types - if (i == j .and. this%overlap_zero_limit) then - this%S_coeff(MC_E,:,i,j,:) = this%S_coeff(MC_E,:,i,j,:) / BOHR - this%S_coeff(MC_F,:,i,j,:) = this%S_coeff(MC_F,:,i,j,:) / BOHR**2 - this%S_coeff(MC_FB,:,i,j,:) = this%S_coeff(MC_FB,:,i,j,:) / BOHR**3 - this%S_coeff(MC_G_SQ,:,i,j,:) = this%S_coeff(MC_G_SQ,:,i,j,:) / BOHR - else - this%S_coeff(MC_F,:,i,j,:) = this%S_coeff(MC_F,:,i,j,:) / BOHR - this%S_coeff(MC_FB,:,i,j,:) = this%S_coeff(MC_FB,:,i,j,:) / BOHR**2 - this%S_coeff(MC_G_SQ,:,i,j,:) = this%S_coeff(MC_G_SQ,:,i,j,:) / BOHR - endif - end do - end do - -end subroutine TBModel_NRL_TB_change_units - -subroutine TBModel_NRL_TB_Print(this,file) - type(TBModel_NRL_TB), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer::i, j, ii, i_mag, n_sk_use, max_spdf - - if(this%n_types == 0) call System_Abort('TBModel_NRL_TB_Print: TBModel_NRL_TB structure not initialised') - - call Print('TBModel_NRL_TB n_types:' // this%n_types, file=file) - - call Print ('TBModel_NRL_TB: is_orthogonal ' // this%is_orthogonal // & - ' is_magnetic '// this%is_magnetic// ' has_pair_repulsion '// this%has_pair_repulsion// & - ' overlap_zero_limit '// this%overlap_zero_limit// ' force_harrison_signs '// this%force_harrison_signs// ' has_short_ranged_splines '//this%has_short_ranged_splines, file=file) - - if (any(this%orb_set_type == ORB_F)) then - n_sk_use = 20 - max_spdf = SPDF_F - else - n_sk_use = 10 - max_spdf = SPDF_D - endif - - do i=1, this%n_types - call Print ('TBModel_NRL_TB: atomic num mass n_orbs n_elecs ' // this%atomic_num(i) // " " // this%atomic_mass(i) // & - " " // this%n_orbs(i) // " " // this%n_elecs(i), file=file) - call verbosity_push_decrement() - do j=1, this%n_types - call Print ("TBModel_NRL_TB: types " // i // " " // j, file=file) - call Print ('TBModel_NRL_TB: r_cut screen_l ' // this%r_cut(i,j) // " " // this%screen_l(i,j), file=file) - if (this%has_pair_repulsion) then - call Print ('TBModel_NRL_TB: pair_rep inner outer ' // this%pair_rep_inner(i,j) // " " // this%pair_rep_outer(i,j), file=file) - endif - if (this%has_short_ranged_splines) then - call Print ('TBModel_NRL_TB: r_min_spline sigma_spline ' // this%r_min_spline(i,j) // " " // this%sigma_spline(i,j), file=file) - endif - do i_mag=1, this%n_mag - if (this%is_magnetic .and. i_mag == 1) call print("TBModel_NRL_TB: spin up") - if (this%is_magnetic .and. i_mag == 2) call print("TBModel_NRL_TB: spin down") - if (i == j) then - call Print ('TBModel_NRL_TB: lambda_sq ' // this%lambda_sq(i,i_mag), file=file) - endif - call Print ('TBModel_NRL_TB: a_s b_s c_s d_s ' // this%abcd(ABCD_A:ABCD_D,SPDF_S,i,j,i_mag), file=file) - call Print ('TBModel_NRL_TB: a_p b_p c_p d_p ' // this%abcd(ABCD_A:ABCD_D,SPDF_P,i,j,i_mag), file=file) - call Print ('TBModel_NRL_TB: a_d b_d c_d d_d ' // this%abcd(ABCD_A:ABCD_D,SPDF_D,i,j,i_mag), file=file) - if (max_spdf >= SPDF_F) & - call Print ('TBModel_NRL_TB: a_f b_f c_f d_f ' // this%abcd(ABCD_A:ABCD_D,SPDF_F,i,j,i_mag), file=file) - - do ii=1, n_sk_use - call Print ('TBModel_NRL_TB: H e f fb g_sq ' // ii // " " // this%H_coeff(MC_E:MC_G_SQ,ii,i,j,i_mag), file=file) - end do - - do ii=1, n_sk_use - call Print ('TBModel_NRL_TB: S e f fb g_sq ' // ii // " " // this%S_coeff(MC_E:MC_G_SQ,ii,i,j,i_mag), file=file) - end do - end do ! i_mag - - end do - call verbosity_pop() - end do - -end subroutine TBModel_NRL_TB_Print - -function TBModel_NRL_TB_n_orbs_of_Z(this, Z) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_NRL_TB_n_orbs_of_Z - - TBModel_NRL_TB_n_orbs_of_Z = this%n_orbs(get_type(this%type_of_atomic_num,Z)) -end function TBModel_NRL_TB_n_orbs_of_Z - -function TBModel_NRL_TB_n_orb_sets_of_Z(this, Z) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: Z - integer TBModel_NRL_TB_n_orb_sets_of_Z - - TBModel_NRL_TB_n_orb_sets_of_Z = this%n_orb_sets(get_type(this%type_of_atomic_num,Z)) -end function TBModel_NRL_TB_n_orb_sets_of_Z - -function TBModel_NRL_TB_n_orbs_of_orb_set_of_Z(this, Z, i_set) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_NRL_TB_n_orbs_of_orb_set_of_Z - - TBModel_NRL_TB_n_orbs_of_orb_set_of_Z = N_ORBS_OF_SET(this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z))) - -end function TBModel_NRL_TB_n_orbs_of_orb_set_of_Z - -function TBModel_NRL_TB_orb_type_of_orb_set_of_Z(this, Z, i_set) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: Z, i_set - integer TBModel_NRL_TB_orb_type_of_orb_set_of_Z - - TBModel_NRL_TB_orb_type_of_orb_set_of_Z = this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z)) - -end function TBModel_NRL_TB_orb_type_of_orb_set_of_Z - -function TBModel_NRL_TB_n_elecs_of_Z(this, Z) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: Z - real(dp) TBModel_NRL_TB_n_elecs_of_Z - - TBModel_NRL_TB_n_elecs_of_Z = this%n_elecs(get_type(this%type_of_atomic_num,Z)) -end function TBModel_NRL_TB_n_elecs_of_Z - -subroutine TBModel_NRL_TB_get_HS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, b_H, b_S, i_mag) - type(TBModel_NRL_TB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, at_j - real(dp), intent(in) :: dv_hat(3), dv_mag - real(dp), intent(out) :: b_H(:,:), b_S(:,:) - integer, intent(in), optional :: i_mag - - integer ti, tj, is, js, i_set, j_set - integer i, j - real(dp) SK_frad_H(N_SK), SK_frad_S(N_SK) - real(dp) dv_hat_sq(3) - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - tj = get_type(this%type_of_atomic_num,at%Z(at_j)) - - b_H = 0.0_dp - b_S = 0.0_dp - - if (dv_mag .feq. 0.0_dp) then - i = 1 - do i_set = 1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - b_H(i,i) = onsite_function(this, at, at_i, this%orb_set_type(i_set,ti), i_mag) - b_S(i,i) = 1.0D0 - i = i + 1 - end do - end do - else - - dv_hat_sq = dv_hat**2 - - i = 1 - do i_set=1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - j = 1 - do j_set=1, this%n_orb_sets(tj) - SK_frad_H = 0.0_dp - SK_frad_S = 0.0_dp - call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - SK_frad_H, SK_frad_S, i_mag) - do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) - - b_H(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H) - - if (this%is_orthogonal) then - b_S(i,j) = 0.0_dp - else - b_S(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_S) - endif - - j = j + 1 - end do - end do - i = i + 1 - end do - end do - endif ! onsite - -end subroutine TBModel_NRL_TB_get_HS_blocks - -subroutine TBModel_NRL_TB_get_dHS_masks(this, at, at_ind, d_mask, od_mask) - type(TBModel_NRL_TB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_ind - logical, intent(out), optional :: d_mask(:), od_mask(:) - - integer ji, j - - if (present(d_mask)) then - if (at_ind < 0) then - d_mask = .true. - else - d_mask = .false. - d_mask(at_ind) = .true. - do ji=1, n_neighbours(at, at_ind) - j = neighbour(at, at_ind, ji) - d_mask(j) = .true. - end do - endif - endif - - if (present(od_mask)) then - if (at_ind < 0) then - od_mask = .true. - else - od_mask = .false. - od_mask(at_ind) = .true. - endif - endif - -end subroutine TBModel_NRL_TB_get_dHS_masks - - -function TBModel_NRL_TB_get_dHS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) - type(TBModel_NRL_TB), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, at_j - real(dp), intent(in) :: dv_hat(3), dv_mag - integer, intent(in) :: at_ind - real(dp), intent(out) :: b_dH(:,:,:), b_dS(:,:,:) - integer, intent(in), optional :: i_mag - logical TBModel_NRL_TB_get_dHS_blocks - - integer ti, tj, is, js, i_set, j_set - integer i, j - real(dp) SK_frad_H(N_SK), SK_frad_S(N_SK), SK_dfrad_H(N_SK), SK_dfrad_S(N_SK) - real(dp) dv_hat_sq(3) - real(dp) virial_outerprod_fac - - if (at_i /= at_j) then ! off-diagonal block - ! for force derivatives, only matching rows contribute - if (at_ind > 0 .and. at_ind /= at_i .and. at_ind /= at_j) then - TBModel_NRL_TB_get_dHS_blocks = .false. - return - endif - else ! diagonal block - ! only atoms within cutoff contribute - if (dv_mag > this%cutoff) then - TBModel_NRL_TB_get_dHS_blocks = .false. - return - endif - endif - - ! force derivative off-diagonal masquerading as diagonal don't contribute - if (at_ind > 0 .and. at_i == at_j .and. (dv_mag .fne. 0.0_dp)) then - b_dH = 0.0_dp - b_dS = 0.0_dp - TBModel_NRL_TB_get_dHS_blocks = .true. - return - endif - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - tj = get_type(this%type_of_atomic_num,at%Z(at_j)) - - b_dH = 0.0_dp - b_dS = 0.0_dp - - if (dv_mag .feq. 0.0_dp) then ! on-site - i = 1 - do i_set = 1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - b_dH(i,i,:) = donsite_function(this, at, at_i, this%orb_set_type(i_set,ti), at_ind, i_mag) - b_dS(i,i,:) = 0.0D0 - i = i + 1 - end do - end do - - else ! hopping (even if on diagonal matrix block) - - dv_hat_sq = dv_hat**2 - - i = 1 - do i_set=1, this%n_orb_sets(ti) - do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) - j = 1 - do j_set=1, this%n_orb_sets(tj) - call radial_functions(this, ti, tj, dv_mag, & - this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - SK_frad_H, SK_frad_S, i_mag) - call dradial_functions(this, ti, tj, dv_mag, & - this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - SK_dfrad_H, SK_dfrad_S, i_mag) - do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) - - if (at_ind > 0) then - virial_outerprod_fac = 1.0_dp - else - virial_outerprod_fac = -dv_mag*dv_hat(-at_ind) - endif - b_dH(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & - this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_H, SK_dfrad_H)*virial_outerprod_fac - - if (this%is_orthogonal) then - b_dS(i,j,:) = 0.0_dp - else - b_dS(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & - this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & - is, js, SK_frad_S, SK_dfrad_S)*virial_outerprod_fac - endif - - j = j + 1 - end do - end do - i = i + 1 - end do - end do - - if (at_ind == at_j) then - b_dH = -b_dH - if (.not. this%is_orthogonal) then - b_dS = -b_dS - endif - endif - - endif ! hopping - - TBModel_NRL_TB_get_dHS_blocks = .true. - return - -end function TBModel_NRL_TB_get_dHS_blocks - -function TBModel_NRL_TB_get_local_rep_E(this, at, i) - type(TBModel_NRL_TB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: TBModel_NRL_TB_get_local_rep_E - - TBModel_NRL_TB_get_local_rep_E = 0.0_dp - -end function TBModel_NRL_TB_get_local_rep_E - -function TBModel_NRL_TB_get_local_rep_E_force(this, at, i) result(force) - type(TBModel_NRL_TB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: force(3,at%N) - - force = 0.0_dp - -end function TBModel_NRL_TB_get_local_rep_E_force - -function TBModel_NRL_TB_get_local_rep_E_virial(this, at, i) result(virial) - type(TBModel_NRL_TB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i - real(dp) :: virial(3,3) - - virial = 0.0_dp - -end function TBModel_NRL_TB_get_local_rep_E_virial - -subroutine radial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, f_H, f_S, i_mag) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dv_mag - integer, intent(in) :: orb_set_type_i, orb_set_type_j - real(dp), intent(out) :: f_H(N_SK), f_S(N_SK) - integer, intent(in), optional :: i_mag - - integer :: u_i_mag - - u_i_mag = optional_default(1, i_mag) - - if (this%n_mag == 1) u_i_mag = 1 - if (u_i_mag > this%n_mag) call system_abort("NRL_TB_Model radial_functions called for spin " // u_i_mag // " max spin only " // this%n_mag) - - if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then - f_H(SK_SSS) = calc_SK_coeff_H(this, SK_SSS,ti,tj, dv_mag,u_i_mag) - f_S(SK_SSS) = calc_SK_coeff_S_zero_limit(this, SK_SSS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j, u_i_mag) - if (this%force_harrison_signs) f_H(SK_SSS) = harrison_sign_sss*abs(f_H(SK_SSS)) - if (this%force_harrison_signs) f_S(SK_SSS) = harrison_sign_sss*abs(f_S(SK_SSS)) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then - f_H(SK_SPS) = calc_SK_coeff_H(this, SK_SPS,ti,tj, dv_mag,u_i_mag) - f_S(SK_SPS) = calc_SK_coeff_S_zero_limit(this, SK_SPS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_H(SK_SPS) = harrison_sign_sps*abs(f_H(SK_SPS)) - if (this%force_harrison_signs) f_S(SK_SPS) = harrison_sign_sps*abs(f_S(SK_SPS)) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then - f_H(SK_SPS) = -calc_SK_coeff_H(this, SK_SPS,tj,ti, dv_mag,u_i_mag) - f_S(SK_SPS) = -calc_SK_coeff_S_zero_limit(this, SK_SPS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_H(SK_SPS) = -harrison_sign_sps*abs(f_H(SK_SPS)) - if (this%force_harrison_signs) f_S(SK_SPS) = -harrison_sign_sps*abs(f_S(SK_SPS)) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then - f_H(SK_PPS) = calc_SK_coeff_H(this, SK_PPS,ti,tj, dv_mag,u_i_mag) - f_H(SK_PPP) = calc_SK_coeff_H(this, SK_PPP,ti,tj, dv_mag,u_i_mag) - f_S(SK_PPS) = calc_SK_coeff_S_zero_limit(this, SK_PPS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_PPP) = calc_SK_coeff_S_zero_limit(this, SK_PPP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_H(SK_PPS) = harrison_sign_pps*abs(f_H(SK_PPS)) - if (this%force_harrison_signs) f_S(SK_PPS) = harrison_sign_pps*abs(f_S(SK_PPS)) - if (this%force_harrison_signs) f_H(SK_PPP) = harrison_sign_ppp*abs(f_H(SK_PPP)) - if (this%force_harrison_signs) f_S(SK_PPP) = harrison_sign_ppp*abs(f_S(SK_PPP)) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_D) then - f_H(SK_SDS) = calc_SK_coeff_H(this, SK_SDS,ti,tj, dv_mag,u_i_mag) - f_S(SK_SDS) = calc_SK_coeff_S_zero_limit(this, SK_SDS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_H(SK_SDS) = harrison_sign_sds*abs(f_H(SK_SDS)) - if (this%force_harrison_signs) f_S(SK_SDS) = harrison_sign_sds*abs(f_S(SK_SDS)) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_S) then - f_H(SK_SDS) = calc_SK_coeff_H(this, SK_SDS,tj,ti, dv_mag,u_i_mag) - f_S(SK_SDS) = calc_SK_coeff_S_zero_limit(this, SK_SDS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_H(SK_SDS) = harrison_sign_sds*abs(f_H(SK_SDS)) - if (this%force_harrison_signs) f_S(SK_SDS) = harrison_sign_sds*abs(f_S(SK_SDS)) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_D) then - f_H(SK_PDS) = calc_SK_coeff_H(this, SK_PDS,ti,tj, dv_mag,u_i_mag) - f_H(SK_PDP) = calc_SK_coeff_H(this, SK_PDP,ti,tj, dv_mag,u_i_mag) - f_S(SK_PDS) = calc_SK_coeff_S_zero_limit(this, SK_PDS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_PDP) = calc_SK_coeff_S_zero_limit(this, SK_PDP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_H(SK_PDS) = harrison_sign_pds*abs(f_H(SK_PDS)) - if (this%force_harrison_signs) f_S(SK_PDS) = harrison_sign_pds*abs(f_S(SK_PDS)) - if (this%force_harrison_signs) f_H(SK_PDP) = harrison_sign_pdp*abs(f_H(SK_PDP)) - if (this%force_harrison_signs) f_S(SK_PDP) = harrison_sign_pdp*abs(f_S(SK_PDP)) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_P) then - f_H(SK_PDS) = -calc_SK_coeff_H(this, SK_PDS,tj,ti, dv_mag,u_i_mag) - f_H(SK_PDP) = -calc_SK_coeff_H(this, SK_PDP,tj,ti, dv_mag,u_i_mag) - f_S(SK_PDS) = -calc_SK_coeff_S_zero_limit(this, SK_PDS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_PDP) = -calc_SK_coeff_S_zero_limit(this, SK_PDP,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_H(SK_PDS) = -harrison_sign_pds*abs(f_H(SK_PDS)) - if (this%force_harrison_signs) f_S(SK_PDS) = -harrison_sign_pds*abs(f_S(SK_PDS)) - if (this%force_harrison_signs) f_H(SK_PDP) = -harrison_sign_pdp*abs(f_H(SK_PDP)) - if (this%force_harrison_signs) f_S(SK_PDP) = -harrison_sign_pdp*abs(f_S(SK_PDP)) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then - f_H(SK_DDS) = calc_SK_coeff_H(this, SK_DDS,tj,ti, dv_mag,u_i_mag) - f_H(SK_DDP) = calc_SK_coeff_H(this, SK_DDP,tj,ti, dv_mag,u_i_mag) - f_H(SK_DDD) = calc_SK_coeff_H(this, SK_DDD,tj,ti, dv_mag,u_i_mag) - f_S(SK_DDS) = calc_SK_coeff_S_zero_limit(this, SK_DDS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_DDP) = calc_SK_coeff_S_zero_limit(this, SK_DDP,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_DDD) = calc_SK_coeff_S_zero_limit(this, SK_DDD,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_H(SK_DDS) = harrison_sign_dds*abs(f_H(SK_DDS)) - if (this%force_harrison_signs) f_S(SK_DDS) = harrison_sign_dds*abs(f_S(SK_DDS)) - if (this%force_harrison_signs) f_H(SK_DDP) = harrison_sign_ddp*abs(f_H(SK_DDP)) - if (this%force_harrison_signs) f_S(SK_DDP) = harrison_sign_ddp*abs(f_S(SK_DDP)) - - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_F) then - f_H(SK_SFS) = calc_SK_coeff_H(this, SK_SFS,ti,tj, dv_mag,u_i_mag) - f_S(SK_SFS) = calc_SK_coeff_S_zero_limit(this, SK_SFS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_S) then - f_H(SK_SFS) = -calc_SK_coeff_H(this, SK_SFS,tj,ti, dv_mag,u_i_mag) - f_S(SK_SFS) = -calc_SK_coeff_S_zero_limit(this, SK_SFS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_F) then - f_H(SK_PFS) = calc_SK_coeff_H(this, SK_PFS,ti,tj, dv_mag,u_i_mag) - f_H(SK_PFP) = calc_SK_coeff_H(this, SK_PFP,ti,tj, dv_mag,u_i_mag) - f_S(SK_PFS) = calc_SK_coeff_S_zero_limit(this, SK_PFS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_PFP) = calc_SK_coeff_S_zero_limit(this, SK_PFP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_P) then - f_H(SK_PFS) = calc_SK_coeff_H(this, SK_PFS,tj,ti, dv_mag,u_i_mag) - f_H(SK_PFP) = calc_SK_coeff_H(this, SK_PFP,tj,ti, dv_mag,u_i_mag) - f_S(SK_PFS) = calc_SK_coeff_S_zero_limit(this, SK_PFS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_PFP) = calc_SK_coeff_S_zero_limit(this, SK_PFP,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_F) then - f_H(SK_DFS) = calc_SK_coeff_H(this, SK_DFS,ti,tj, dv_mag,u_i_mag) - f_H(SK_DFP) = calc_SK_coeff_H(this, SK_DFP,ti,tj, dv_mag,u_i_mag) - f_H(SK_DFD) = calc_SK_coeff_H(this, SK_DFD,ti,tj, dv_mag,u_i_mag) - f_S(SK_DFS) = calc_SK_coeff_S_zero_limit(this, SK_DFS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_DFP) = calc_SK_coeff_S_zero_limit(this, SK_DFP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_DFD) = calc_SK_coeff_S_zero_limit(this, SK_DFD,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_D) then - f_H(SK_DFS) = -calc_SK_coeff_H(this, SK_DFS,tj,ti, dv_mag,u_i_mag) - f_H(SK_DFP) = -calc_SK_coeff_H(this, SK_DFP,tj,ti, dv_mag,u_i_mag) - f_H(SK_DFD) = -calc_SK_coeff_H(this, SK_DFD,tj,ti, dv_mag,u_i_mag) - f_S(SK_DFS) = -calc_SK_coeff_S_zero_limit(this, SK_DFS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_DFP) = -calc_SK_coeff_S_zero_limit(this, SK_DFP,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_DFD) = -calc_SK_coeff_S_zero_limit(this, SK_DFD,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_F) then - f_H(SK_FFS) = calc_SK_coeff_H(this, SK_FFS,ti,tj, dv_mag,u_i_mag) - f_H(SK_FFP) = calc_SK_coeff_H(this, SK_FFP,ti,tj, dv_mag,u_i_mag) - f_H(SK_FFD) = calc_SK_coeff_H(this, SK_FFD,ti,tj, dv_mag,u_i_mag) - f_H(SK_FFF) = calc_SK_coeff_H(this, SK_FFF,ti,tj, dv_mag,u_i_mag) - f_S(SK_FFS) = calc_SK_coeff_S_zero_limit(this, SK_FFS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_FFP) = calc_SK_coeff_S_zero_limit(this, SK_FFP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_FFD) = calc_SK_coeff_S_zero_limit(this, SK_FFD,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_S(SK_FFF) = calc_SK_coeff_S_zero_limit(this, SK_FFF,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - endif - -end subroutine radial_functions - -subroutine dradial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, f_dH, f_dS, i_mag) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dv_mag - integer, intent(in) :: orb_set_type_i, orb_set_type_j - real(dp), intent(out) :: f_dH(N_SK), f_dS(N_SK) - integer, intent(in), optional :: i_mag - - integer :: u_i_mag - - u_i_mag = optional_default(1, i_mag) - - if (this%n_mag == 1) u_i_mag = 1 - if (u_i_mag > this%n_mag) call system_abort("NRL_TB_Model dradial_functions called for spin " // u_i_mag // " max spin only " // this%n_mag) - - if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then - f_dH(SK_SSS) = calc_SK_coeff_H_d(this, SK_SSS,ti,tj, dv_mag,u_i_mag) - f_dS(SK_SSS) = calc_SK_coeff_S_d_zero_limit(this, SK_SSS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_SSS) = harrison_sign_sss*abs(f_dH(SK_SSS)) - if (this%force_harrison_signs) f_dS(SK_SSS) = harrison_sign_sss*abs(f_dS(SK_SSS)) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then - f_dH(SK_SPS) = calc_SK_coeff_H_d(this, SK_SPS,ti,tj, dv_mag,u_i_mag) - f_dS(SK_SPS) = calc_SK_coeff_S_d_zero_limit(this, SK_SPS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_SPS) = harrison_sign_sps*abs(f_dH(SK_SPS)) - if (this%force_harrison_signs) f_dS(SK_SPS) = harrison_sign_sps*abs(f_dS(SK_SPS)) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then - f_dH(SK_SPS) = -calc_SK_coeff_H_d(this, SK_SPS,tj,ti, dv_mag,u_i_mag) - f_dS(SK_SPS) = -calc_SK_coeff_S_d_zero_limit(this, SK_SPS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_SPS) = -harrison_sign_sps*abs(f_dH(SK_SPS)) - if (this%force_harrison_signs) f_dS(SK_SPS) = -harrison_sign_sps*abs(f_dS(SK_SPS)) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then - f_dH(SK_PPS) = calc_SK_coeff_H_d(this, SK_PPS,ti,tj, dv_mag,u_i_mag) - f_dH(SK_PPP) = calc_SK_coeff_H_d(this, SK_PPP,ti,tj, dv_mag,u_i_mag) - f_dS(SK_PPS) = calc_SK_coeff_S_d_zero_limit(this, SK_PPS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_PPP) = calc_SK_coeff_S_d_zero_limit(this, SK_PPP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_PPS) = harrison_sign_pps*abs(f_dH(SK_PPS)) - if (this%force_harrison_signs) f_dS(SK_PPS) = harrison_sign_pps*abs(f_dS(SK_PPS)) - if (this%force_harrison_signs) f_dH(SK_PPP) = harrison_sign_ppp*abs(f_dH(SK_PPP)) - if (this%force_harrison_signs) f_dS(SK_PPP) = harrison_sign_ppp*abs(f_dS(SK_PPP)) - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_D) then - f_dH(SK_SDS) = calc_SK_coeff_H_d(this, SK_SDS,ti,tj, dv_mag,u_i_mag) - f_dS(SK_SDS) = calc_SK_coeff_S_d_zero_limit(this, SK_SDS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_SDS) = harrison_sign_sds*abs(f_dH(SK_SDS)) - if (this%force_harrison_signs) f_dS(SK_SDS) = harrison_sign_sds*abs(f_dS(SK_SDS)) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_S) then - f_dH(SK_SDS) = calc_SK_coeff_H_d(this, SK_SDS,tj,ti, dv_mag,u_i_mag) - f_dS(SK_SDS) = calc_SK_coeff_S_d_zero_limit(this, SK_SDS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_SDS) = harrison_sign_sds*abs(f_dH(SK_SDS)) - if (this%force_harrison_signs) f_dS(SK_SDS) = harrison_sign_sds*abs(f_dS(SK_SDS)) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_D) then - f_dH(SK_PDS) = calc_SK_coeff_H_d(this, SK_PDS,ti,tj, dv_mag,u_i_mag) - f_dH(SK_PDP) = calc_SK_coeff_H_d(this, SK_PDP,ti,tj, dv_mag,u_i_mag) - f_dS(SK_PDS) = calc_SK_coeff_S_d_zero_limit(this, SK_PDS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_PDP) = calc_SK_coeff_S_d_zero_limit(this, SK_PDP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_PDS) = harrison_sign_pds*abs(f_dH(SK_PDS)) - if (this%force_harrison_signs) f_dS(SK_PDS) = harrison_sign_pds*abs(f_dS(SK_PDS)) - if (this%force_harrison_signs) f_dH(SK_PDP) = harrison_sign_pdp*abs(f_dH(SK_PDP)) - if (this%force_harrison_signs) f_dS(SK_PDP) = harrison_sign_pdp*abs(f_dS(SK_PDP)) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_P) then - f_dH(SK_PDS) = -calc_SK_coeff_H_d(this, SK_PDS,tj,ti, dv_mag,u_i_mag) - f_dH(SK_PDP) = -calc_SK_coeff_H_d(this, SK_PDP,tj,ti, dv_mag,u_i_mag) - f_dS(SK_PDS) = -calc_SK_coeff_S_d_zero_limit(this, SK_PDS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_PDP) = -calc_SK_coeff_S_d_zero_limit(this, SK_PDP,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_PDS) = -harrison_sign_pds*abs(f_dH(SK_PDS)) - if (this%force_harrison_signs) f_dS(SK_PDS) = -harrison_sign_pds*abs(f_dS(SK_PDS)) - if (this%force_harrison_signs) f_dH(SK_PDP) = -harrison_sign_pdp*abs(f_dH(SK_PDP)) - if (this%force_harrison_signs) f_dS(SK_PDP) = -harrison_sign_pdp*abs(f_dS(SK_PDP)) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then - f_dH(SK_DDS) = calc_SK_coeff_H_d(this, SK_DDS,tj,ti, dv_mag,u_i_mag) - f_dH(SK_DDP) = calc_SK_coeff_H_d(this, SK_DDP,tj,ti, dv_mag,u_i_mag) - f_dH(SK_DDD) = calc_SK_coeff_H_d(this, SK_DDD,tj,ti, dv_mag,u_i_mag) - f_dS(SK_DDS) = calc_SK_coeff_S_d_zero_limit(this, SK_DDS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_DDP) = calc_SK_coeff_S_d_zero_limit(this, SK_DDP,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_DDD) = calc_SK_coeff_S_d_zero_limit(this, SK_DDD,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - if (this%force_harrison_signs) f_dH(SK_DDS) = harrison_sign_dds*abs(f_dH(SK_DDS)) - if (this%force_harrison_signs) f_dS(SK_DDS) = harrison_sign_dds*abs(f_dS(SK_DDS)) - if (this%force_harrison_signs) f_dH(SK_DDP) = harrison_sign_ddp*abs(f_dH(SK_DDP)) - if (this%force_harrison_signs) f_dS(SK_DDP) = harrison_sign_ddp*abs(f_dS(SK_DDP)) - - else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_F) then - f_dH(SK_SFS) = calc_SK_coeff_H_d(this, SK_SFS,ti,tj, dv_mag,u_i_mag) - f_dS(SK_SFS) = calc_SK_coeff_S_d_zero_limit(this, SK_SFS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_S) then - f_dH(SK_SFS) = -calc_SK_coeff_H_d(this, SK_SFS,tj,ti, dv_mag,u_i_mag) - f_dS(SK_SFS) = -calc_SK_coeff_S_d_zero_limit(this, SK_SFS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_F) then - f_dH(SK_PFS) = calc_SK_coeff_H_d(this, SK_PFS,ti,tj, dv_mag,u_i_mag) - f_dH(SK_PFP) = calc_SK_coeff_H_d(this, SK_PFP,ti,tj, dv_mag,u_i_mag) - f_dS(SK_PFS) = calc_SK_coeff_S_d_zero_limit(this, SK_PFS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_PFP) = calc_SK_coeff_S_d_zero_limit(this, SK_PFP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_P) then - f_dH(SK_PFS) = calc_SK_coeff_H_d(this, SK_PFS,tj,ti, dv_mag,u_i_mag) - f_dH(SK_PFP) = calc_SK_coeff_H_d(this, SK_PFP,tj,ti, dv_mag,u_i_mag) - f_dS(SK_PFS) = calc_SK_coeff_S_d_zero_limit(this, SK_PFS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_PFP) = calc_SK_coeff_S_d_zero_limit(this, SK_PFP,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_F) then - f_dH(SK_DFS) = calc_SK_coeff_H_d(this, SK_DFS,ti,tj, dv_mag,u_i_mag) - f_dH(SK_DFP) = calc_SK_coeff_H_d(this, SK_DFP,ti,tj, dv_mag,u_i_mag) - f_dH(SK_DFD) = calc_SK_coeff_H_d(this, SK_DFD,ti,tj, dv_mag,u_i_mag) - f_dS(SK_DFS) = calc_SK_coeff_S_d_zero_limit(this, SK_DFS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_DFP) = calc_SK_coeff_S_d_zero_limit(this, SK_DFP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_DFD) = calc_SK_coeff_S_d_zero_limit(this, SK_DFD,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_D) then - f_dH(SK_DFS) = -calc_SK_coeff_H_d(this, SK_DFS,tj,ti, dv_mag,u_i_mag) - f_dH(SK_DFP) = -calc_SK_coeff_H_d(this, SK_DFP,tj,ti, dv_mag,u_i_mag) - f_dH(SK_DFD) = -calc_SK_coeff_H_d(this, SK_DFD,tj,ti, dv_mag,u_i_mag) - f_dS(SK_DFS) = -calc_SK_coeff_S_d_zero_limit(this, SK_DFS,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_DFP) = -calc_SK_coeff_S_d_zero_limit(this, SK_DFP,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_DFD) = -calc_SK_coeff_S_d_zero_limit(this, SK_DFD,tj,ti, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_F) then - f_dH(SK_FFS) = calc_SK_coeff_H_d(this, SK_FFS,ti,tj, dv_mag,u_i_mag) - f_dH(SK_FFP) = calc_SK_coeff_H_d(this, SK_FFP,ti,tj, dv_mag,u_i_mag) - f_dH(SK_FFD) = calc_SK_coeff_H_d(this, SK_FFD,ti,tj, dv_mag,u_i_mag) - f_dH(SK_FFF) = calc_SK_coeff_H_d(this, SK_FFF,ti,tj, dv_mag,u_i_mag) - f_dS(SK_FFS) = calc_SK_coeff_S_d_zero_limit(this, SK_FFS,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_FFP) = calc_SK_coeff_S_d_zero_limit(this, SK_FFP,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_FFD) = calc_SK_coeff_S_d_zero_limit(this, SK_FFD,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - f_dS(SK_FFF) = calc_SK_coeff_S_d_zero_limit(this, SK_FFF,ti,tj, dv_mag, & - ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) - endif -end subroutine dradial_functions - -recursive function calc_SK_coeff_H(this, SK_type, ti, tj, dist, i_mag) result(calc_SK_coeff_H_result) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: SK_type - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dist - integer, intent(in), optional :: i_mag - real(dp) :: calc_SK_coeff_H_result, R_min, sigma - - real(dp) :: H_0, H_0_d, H_0_dd - integer :: u_i_mag - - - u_i_mag = optional_default(1, i_mag) - - if (this%has_short_ranged_splines) then - R_min = this%r_min_spline(ti,tj) - sigma = this%sigma_spline(ti,tj) - if (dist >= R_min) then - calc_SK_coeff_H_result = calc_SK_poly(this%H_coeff(1:4,SK_type, ti, tj, u_i_mag), dist) - calc_SK_coeff_H_result = calc_SK_coeff_H_result * NRLTB_cutoff_function(this, dist, ti, tj) - else - H_0 = calc_SK_coeff_H(this, SK_type, ti, tj, R_min, i_mag) - H_0_d = calc_SK_coeff_H_d(this, SK_type, ti, tj, R_min, i_mag) - H_0_dd = calc_SK_coeff_H_dd(this, SK_type, ti, tj, R_min, i_mag) - if (dist < R_min - sigma) then - calc_SK_coeff_H_result = short_ranged_spline(H_0, H_0_d, H_0_dd, sigma, 0.0_dp) - else - calc_SK_coeff_H_result = short_ranged_spline(H_0, H_0_d, H_0_dd, sigma, dist-R_min+sigma) - endif - endif - else - calc_SK_coeff_H_result = calc_SK_poly(this%H_coeff(1:4,SK_type, ti, tj, u_i_mag), dist) - calc_SK_coeff_H_result = calc_SK_coeff_H_result * NRLTB_cutoff_function(this, dist, ti, tj) - endif -end function calc_SK_coeff_H - -recursive function calc_SK_coeff_H_d(this, SK_type, ti, tj, dist, i_mag) result(calc_SK_coeff_H_d_result) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: SK_type - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dist - integer, intent(in), optional :: i_mag - real(dp) :: calc_SK_coeff_H_d_result - - real(dp) :: R_min, sigma - real(dp) :: H_0, H_0_d, H_0_dd - real(dp) :: SK, SKd, co, cod - real(dp) :: SK_0, SK_0_d, co_0, co_0_d - integer :: u_i_mag - - u_i_mag = optional_default(1, i_mag) - - SKd = calc_SK_poly_deriv(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) - SK = calc_SK_poly(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) - co = NRLTB_cutoff_function(this, dist, ti, tj) - cod = NRLTB_cutoff_function_d(this, dist, ti, tj) - - if (this%has_short_ranged_splines) then - R_min = this%r_min_spline(ti,tj) - sigma = this%sigma_spline(ti,tj) - if (dist >= R_min) then - calc_SK_coeff_H_d_result = SK*cod + SKd*co - elseif (dist < R_min - sigma) then - calc_SK_coeff_H_d_result = 0.0_dp - else - H_0 = calc_SK_coeff_H(this, SK_type, ti, tj, R_min, i_mag) - H_0_d = calc_SK_coeff_H_d(this, SK_type, ti, tj, R_min, i_mag) - H_0_dd = calc_SK_coeff_H_dd(this, SK_type, ti, tj, R_min, i_mag) - - calc_SK_coeff_H_d_result = short_ranged_spline_d(H_0, H_0_d, H_0_dd, sigma, dist-R_min+sigma) - endif - else - calc_SK_coeff_H_d_result = SK*cod + SKd*co - endif - - -end function calc_SK_coeff_H_d - - -function calc_SK_coeff_H_dd(this, SK_type, ti, tj, dist, i_mag, error) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: SK_type - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dist - integer, intent(in), optional :: i_mag - real(dp) :: calc_SK_coeff_H_dd - - real(dp) :: R_min, sigma - real(dp) :: SK, SKd, SKdd, co, cod, codd - integer :: u_i_mag - - integer, intent(out), optional :: error - - INIT_ERROR(error) - - u_i_mag = optional_default(1, i_mag) - - SK = calc_SK_poly(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) - SKd = calc_SK_poly_deriv(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) - SKdd = calc_SK_poly_2nd_deriv(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) - - co = NRLTB_cutoff_function(this, dist, ti, tj) - cod = NRLTB_cutoff_function_d(this, dist, ti, tj) - codd = NRLTB_cutoff_function_dd(this, dist, ti, tj) - if (this%has_short_ranged_splines) then - R_min = this%r_min_spline(ti,tj) - sigma = this%sigma_spline(ti,tj) - if (dist >= R_min) then - calc_SK_coeff_H_dd = SK*codd + 2.0_dp*SKd*cod + SKdd*co - else - RAISE_ERROR("calc_SK_coeff_H_dd not defined yet below R_min if short ranged spline active.", error) - endif - else - calc_SK_coeff_H_dd = SK*codd + 2.0_dp*SKd*cod + SKdd*co - endif -end function calc_SK_coeff_H_dd - -recursive function calc_SK_coeff_S_zero_limit(this, SK_type, ti, tj, dist, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) & - result(calc_SK_coeff_S_zero_limit_result) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: SK_type - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dist - logical, intent(in) :: ti_eq_tj, orb_ti_eq_orb_tj - integer, intent(in), optional :: i_mag - real(dp) :: calc_SK_coeff_S_zero_limit_result - - real(dp) :: R_min, sigma - real(dp) :: S_0, S_0_d, S_0_dd - integer :: u_i_mag - - u_i_mag = optional_default(1, i_mag) - - if (this%has_short_ranged_splines) then - R_min = this%r_min_spline(ti,tj) - sigma = this%sigma_spline(ti,tj) - if (dist >= R_min) then - calc_SK_coeff_S_zero_limit_result = calc_SK_poly_zero_limit(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & - this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - calc_SK_coeff_S_zero_limit_result = calc_SK_coeff_S_zero_limit_result * NRLTB_cutoff_function(this, dist, ti, tj) - else - S_0 = calc_SK_coeff_S_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) - S_0_d = calc_SK_coeff_S_d_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) - S_0_dd = calc_SK_coeff_S_dd_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) - if (dist < R_min - sigma) then - calc_SK_coeff_S_zero_limit_result = short_ranged_spline(S_0, S_0_d, S_0_dd, sigma, 0.0_dp) - else - calc_SK_coeff_S_zero_limit_result = short_ranged_spline(S_0, S_0_d, S_0_dd, sigma, dist-R_min+sigma) - endif - endif - else - calc_SK_coeff_S_zero_limit_result = calc_SK_poly_zero_limit(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & - this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - calc_SK_coeff_S_zero_limit_result = calc_SK_coeff_S_zero_limit_result * NRLTB_cutoff_function(this, dist, ti, tj) - endif -end function calc_SK_coeff_S_zero_limit - - -recursive function calc_SK_coeff_S_d_zero_limit(this, SK_type, ti, tj, dist, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) & - result(calc_SK_coeff_S_d_zero_limit_result) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: SK_type - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dist - logical, intent(in) :: ti_eq_tj, orb_ti_eq_orb_tj - integer, intent(in), optional :: i_mag - real(dp) :: calc_SK_coeff_S_d_zero_limit_result - - real(dp) :: R_min, sigma - real(dp) :: SK_0, SK_0_d, co_0, co_0_d - real(dp) :: S_0, S_0_d, S_0_dd - real(dp) :: SK, SKd, co, cod - integer :: u_i_mag - - u_i_mag = optional_default(1, i_mag) - - SK = calc_SK_poly_zero_limit(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & - this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - SKd = calc_SK_poly_zero_limit_deriv(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & - this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - co = NRLTB_cutoff_function(this, dist, ti, tj) - cod = NRLTB_cutoff_function_d(this, dist, ti, tj) - - - if (this%has_short_ranged_splines) then - R_min = this%r_min_spline(ti,tj) - sigma = this%sigma_spline(ti,tj) - if (dist >= R_min) then - calc_SK_coeff_S_d_zero_limit_result = SK*cod + SKd*co - elseif (dist < R_min - sigma) then - calc_SK_coeff_S_d_zero_limit_result = 0.0_dp - else - S_0 = calc_SK_coeff_S_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) - S_0_d = calc_SK_coeff_S_d_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) - S_0_dd = calc_SK_coeff_S_dd_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) - calc_SK_coeff_S_d_zero_limit_result = short_ranged_spline_d(S_0, S_0_d, S_0_dd, sigma, dist-R_min+sigma) - endif - else - calc_SK_coeff_S_d_zero_limit_result = SK*cod + SKd*co - endif - -end function calc_SK_coeff_S_d_zero_limit - - -function calc_SK_coeff_S_dd_zero_limit(this, SK_type, ti, tj, dist, ti_eq_tj, orb_ti_eq_orb_tj, i_mag, error) - type(TBModel_NRL_TB), intent(in) :: this - integer, intent(in) :: SK_type - integer, intent(in) :: ti, tj - real(dp), intent(in) :: dist - logical, intent(in) :: ti_eq_tj, orb_ti_eq_orb_tj - integer, intent(in), optional :: i_mag - real(dp) :: calc_SK_coeff_S_dd_zero_limit - - real(dp) :: R_min, sigma - real(dp) :: SK, SKd, SKdd, co, cod, codd - integer :: u_i_mag - - integer, intent(out), optional :: error - - INIT_ERROR(error) - - u_i_mag = optional_default(1, i_mag) - - SK = calc_SK_poly_zero_limit(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & - this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - SKd = calc_SK_poly_zero_limit_deriv(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & - this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - SKdd = calc_SK_poly_zero_limit_2nd_deriv(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & - this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - co = NRLTB_cutoff_function(this, dist, ti, tj) - cod = NRLTB_cutoff_function_d(this, dist, ti, tj) - codd = NRLTB_cutoff_function_dd(this, dist, ti, tj) - - if (this%has_short_ranged_splines) then - R_min = this%r_min_spline(ti,tj) - sigma = this%sigma_spline(ti,tj) - if (dist >= R_min) then - calc_SK_coeff_S_dd_zero_limit = SK*codd + 2.0_dp*SKd*cod + SKdd*co - else - RAISE_ERROR("calc_SK_coeff_S_dd_zero_limit not defined yet below R_min if short ranged spline active.", error) - endif - else - calc_SK_coeff_S_dd_zero_limit = SK*codd + 2.0_dp*SKd*cod + SKdd*co - endif - -end function calc_SK_coeff_S_dd_zero_limit - - -function calc_SK_poly(coeff, dist) - real(dp), intent(in) :: coeff(4) - real(dp), intent(in) :: dist - real(dp) :: calc_SK_poly - - calc_SK_poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist))*exp(-coeff(MC_G_SQ)*dist) -end function calc_SK_poly - -function calc_SK_poly_deriv(coeff, dist) - real(dp), intent(in) :: coeff(4) - real(dp), intent(in) :: dist - real(dp) :: calc_SK_poly_deriv - - real(dp) poly, poly_d, expv, expv_d - - expv = exp(-coeff(MC_G_SQ)*dist) - expv_d = expv*(-coeff(MC_G_SQ)) - poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist)) - poly_d = coeff(MC_F) + 2.0_dp*coefF(MC_FB)*dist - - calc_SK_poly_deriv = expv*poly_d + expv_d*poly -end function calc_SK_poly_deriv - -function calc_SK_poly_2nd_deriv(coeff, dist) - - real(dp), intent(in) :: coeff(4) - real(dp), intent(in) :: dist - real(dp) :: calc_SK_poly_2nd_deriv - - real(dp) poly, poly_d, poly_dd, expv, expv_d, expv_dd - - expv = exp(-coeff(MC_G_SQ)*dist) - expv_d = expv*(-coeff(MC_G_SQ)) - expv_dd = expv*(-coeff(MC_G_SQ))**2 - - poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist)) - poly_d = coeff(MC_F) + 2.0_dp*coefF(MC_FB)*dist - poly_dd = 2.0_dp*coefF(MC_FB) - - calc_SK_poly_2nd_deriv = expv*poly_dd + 2*expv_d*poly_d + expv_dd * poly - -end function calc_SK_poly_2nd_deriv - -function calc_SK_poly_zero_limit(coeff, dist, overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - real(dp), intent(in) :: coeff(4) - real(dp), intent(in) :: dist - logical, intent(in) :: overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj - real(dp) :: calc_SK_poly_zero_limit - - real(dp) zero_limit - - if (overlap_zero_limit .and. ti_eq_tj .and. orb_ti_eq_orb_tj) then - zero_limit = 1.0_dp - else - zero_limit = 0.0_dp - end if - - if (overlap_zero_limit .and. ti_eq_tj) then - calc_SK_poly_zero_limit = (zero_limit + dist*(coeff(MC_E) + dist*(coeff(MC_F) + & - coeff(MC_FB)*dist)))*exp(-COEFF(MC_G_SQ)*dist) - else - calc_SK_poly_zero_limit = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist))* & - exp(-coeff(MC_G_SQ)*dist) - endif -end function calc_SK_poly_zero_limit - -function calc_SK_poly_zero_limit_deriv(coeff, dist, overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - real(dp), intent(in) :: coeff(4) - real(dp), intent(in) :: dist - logical, intent(in) :: overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj - real(dp) :: calc_SK_poly_zero_limit_deriv - - real(dp) zero_limit - real(dp) poly, poly_d, expv, expv_d - - if (overlap_zero_limit .and. ti_eq_tj .and. orb_ti_eq_orb_tj) then - zero_limit = 1.0_dp - else - zero_limit = 0.0_dp - end if - - expv = exp(-COEFF(MC_G_SQ)*dist) - expv_d = expv*(-COEFF(MC_G_SQ)) - - if (overlap_zero_limit .and. ti_eq_tj) then - poly = (zero_limit + dist*(coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist))) - poly_d = coeff(MC_E) + dist*(2.0_dp*coeff(MC_F) + 3.0_dp*coeff(MC_FB)*dist) - else - poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist)) - poly_d = coeff(MC_F) + 2.0_dp*coeff(MC_FB)*dist - endif - - calc_SK_poly_zero_limit_deriv = expv * poly_d + expv_d * poly -end function calc_SK_poly_zero_limit_deriv - -function calc_SK_poly_zero_limit_2nd_deriv(coeff, dist, overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) - real(dp), intent(in) :: coeff(4) - real(dp), intent(in) :: dist - logical, intent(in) :: overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj - real(dp) :: calc_SK_poly_zero_limit_2nd_deriv - - real(dp) zero_limit - real(dp) poly, poly_d, poly_dd, expv, expv_d, expv_dd - - if (overlap_zero_limit .and. ti_eq_tj .and. orb_ti_eq_orb_tj) then - zero_limit = 1.0_dp - else - zero_limit = 0.0_dp - end if - - expv = exp(-COEFF(MC_G_SQ)*dist) - expv_d = expv*(-COEFF(MC_G_SQ)) - expv_dd = expv*(-COEFF(MC_G_SQ))**2 - - if (overlap_zero_limit .and. ti_eq_tj) then - poly = (zero_limit + dist*(coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist))) - poly_d = coeff(MC_E) + dist*(2.0_dp*coeff(MC_F) + 3.0_dp*coeff(MC_FB)*dist) - poly_dd = 2.0_dp*coeff(MC_F) + 6.0_dp*coeff(MC_FB)*dist - else - poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist)) - poly_d = coeff(MC_F) + 2.0_dp*coeff(MC_FB)*dist - poly_dd = 2.0_dp*coeff(MC_FB) - endif - - calc_SK_poly_zero_limit_2nd_deriv = expv*poly_dd + 2*expv_d*poly_d + expv_dd * poly -end function calc_SK_poly_zero_limit_2nd_deriv - - -function onsite_function(this, at, at_i, orb_set_type,i_mag) - type(TBModel_NRL_TB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, orb_set_type - integer, intent(in), optional :: i_mag - real(dp) :: onsite_function - - integer :: ji, j, ti, tj - real(dp) :: dist - real(dp) :: density(this%n_types) - real(dp) :: f_cut, expv - integer :: u_i_mag - - u_i_mag = optional_default(1, i_mag) - - if (this%n_mag == 1) u_i_mag = 1 - if (u_i_mag > this%n_mag) call system_abort("NRL_TB_Model onsite_functions called for spin " // u_i_mag // " max spin only " // this%n_mag) - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - - density = 0.0_dp - do ji=1, n_neighbours(at, at_i) - j = neighbour(at, at_i, ji, dist) - tj = get_type(this%type_of_atomic_num,at%Z(j)) - - f_cut = NRLTB_cutoff_function(this, dist, ti, tj) - expv = exp(-this%lambda_sq(tj,u_i_mag)*dist) - density(tj) = density(tj) + expv*f_cut - end do - - onsite_function = 0.0_dp - do tj=1, this%n_types - onsite_function = onsite_function + onsite_poly(this%abcd(1:4,orb_set_type,tj,ti,u_i_mag), density(tj)) - end do - -end function onsite_function - -function donsite_function(this, at, at_i, orb_set_type, at_ind, i_mag) - type(TBModel_NRL_TB), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_i, orb_set_type, at_ind - integer, intent(in), optional :: i_mag - real(dp) :: donsite_function(3) - - integer :: ji, j, ti, tj - real(dp) :: dist - real(dp) :: density(this%n_types), density_d(this%n_types,3) - real(dp) :: f_cut, expv, f_cut_d, expv_d, dircos(3) - real(dp) :: virial_outerprod_fac - integer :: u_i_mag - - u_i_mag = optional_default(1, i_mag) - - if (this%n_mag == 1) u_i_mag = 1 - if (u_i_mag > this%n_mag) call system_abort("NRL_TB_Model donsite_functions called for spin " // u_i_mag // " max spin only " // this%n_mag) - - ti = get_type(this%type_of_atomic_num,at%Z(at_i)) - - density = 0.0_dp - density_d = 0.0_dp - do ji=1, n_neighbours(at, at_i) - j = neighbour(at, at_i, ji, dist, cosines = dircos) - tj = get_type(this%type_of_atomic_num,at%Z(j)) - - f_cut = NRLTB_cutoff_function(this, dist, ti, tj) - f_cut_d = NRLTB_cutoff_function_d(this, dist, ti, tj) - expv = exp(-this%lambda_sq(tj,u_i_mag)*dist) - expv_d = expv*(-this%lambda_sq(tj,u_i_mag)) - density(tj) = density(tj) + expv*f_cut - if (at_i == at_ind) then - density_d(tj,:) = density_d(tj,:) + (expv*f_cut_d + expv_d*f_cut)*(-dircos(:)) - else if (j == at_ind) then - density_d(tj,:) = density_d(tj,:) + (expv*f_cut_d + expv_d*f_cut)*dircos(:) - else if (at_ind < 0) then - virial_outerprod_fac = -dist*dircos(-at_ind) - density_d(tj,:) = density_d(tj,:) + (expv*f_cut_d + expv_d*f_cut)*(-dircos(:))*virial_outerprod_fac - endif - end do - - donsite_function = 0.0_dp - do tj=1, this%n_types - donsite_function(1) = donsite_function(1) + donsite_poly(this%abcd(1:4,orb_set_type,tj,ti,u_i_mag), & - density(tj), density_d(tj,1)) - donsite_function(2) = donsite_function(2) + donsite_poly(this%abcd(1:4,orb_set_type,tj,ti,u_i_mag), & - density(tj), density_d(tj,2)) - donsite_function(3) = donsite_function(3) + donsite_poly(this%abcd(1:4,orb_set_type,tj,ti,u_i_mag), & - density(tj), density_d(tj,3)) - end do - -end function donsite_function - -function onsite_poly(abcd, density) - real(dp), intent(in) :: abcd(4) - real(dp), intent(in) :: density - real(dp) :: onsite_poly - - onsite_poly = abcd(ABCD_A) + abcd(ABCD_B)*density**(2.0_dp/3.0_dp) + & - abcd(ABCD_C)*density**(4.0_dp/3.0_dp) + abcd(ABCD_D)*density**2 - -end function onsite_poly - -function donsite_poly(abcd, density, density_d) - real(dp), intent(in) :: abcd(4) - real(dp), intent(in) :: density, density_d - real(dp) :: donsite_poly - - if (density .feq. 0.0_dp) then - donsite_poly = 0.0_dp - else - donsite_poly = (abcd(ABCD_B)*(2.0_dp/3.0_dp)*density**(-1.0_dp/3.0_dp) + & - abcd(ABCD_C)*(4.0_dp/3.0_dp)*density**(1.0_dp/3.0_dp) + abcd(ABCD_D)*2.0_dp*density)*density_d - endif - -end function donsite_poly - - -function short_ranged_spline(H_0, H_0_d, H_0_dd, sigma, u) -! spline function for TB potential evaluation proposed by Trinkle et al., Empirical tight-binding model for titanium phase transformations, Phys. Rev. B 73 (2006) 094123 - real(dp), intent(in) :: H_0, H_0_d, H_0_dd, sigma, u - real(dp) :: short_ranged_spline - - short_ranged_spline = H_0 - 0.5_dp*sigma*H_0_d + 1.0_dp/12.0_dp*sigma**2*H_0_dd + & - (sigma*H_0_d - 1.0_dp/3.0_dp*sigma**2*H_0_dd)*u**3/sigma**3 + & - (-0.5_dp*sigma*H_0_d + 0.25_dp*sigma**2*H_0_dd)*u**4/sigma**4 -end function short_ranged_spline - -function short_ranged_spline_d(H_0, H_0_d, H_0_dd, sigma, u) -! derivative of the above given spline function of Trinkle et al., Empirical tight-binding model for titanium phase transformations, Phys. Rev. B 73 (2006) 094123 - real(dp), intent(in) :: H_0, H_0_d, H_0_dd, sigma, u - real(dp) :: short_ranged_spline_d - - short_ranged_spline_d = 3.0_dp*(sigma*H_0_d - 1.0_dp/3.0_dp*sigma**2*H_0_dd)*u**2/sigma**3 + & - 4.0_dp*(-0.5_dp*sigma*H_0_d + 0.25_dp*sigma**2*H_0_dd)*u**3/sigma**4 - - -end function short_ranged_spline_d - -function NRLTB_cutoff_function(this, r, ti, tj) - type(TBModel_NRL_TB), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: NRLTB_cutoff_function - - double precision screen_R0 - double precision cutoff_smooth - double precision expv - - if (r .gt. 10.0_dp**(-4)) then - - screen_R0 = this%r_cut(ti,tj) - 5.0D0*abs(this%screen_l(ti,tj)) - - expv = exp((r-screen_R0)/abs(this%screen_l(ti,tj))) - - cutoff_smooth = NRLTB_cutoff_func_smooth(this, r, ti, tj) - NRLTB_cutoff_function = ( 1.0_dp/(1.0_dp+expv) ) * cutoff_smooth - else - NRLTB_cutoff_function = 0.0_dp - end if - -end function NRLTB_cutoff_function - -function NRLTB_cutoff_function_d(this, r, ti, tj) - type(TBModel_NRL_TB), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: NRLTB_cutoff_function_d - - double precision screen_R0 - double precision cutoff_smooth, cutoff_smooth_d - double precision expv, expv_d - - if (r .gt. 10.0_dp**(-4)) then - - screen_R0 = this%r_cut(ti,tj) - 5.0D0*abs(this%screen_l(ti,tj)) - - expv = exp((r-screen_R0)/abs(this%screen_l(ti,tj))) - expv_d = expv * 1.0_dp/abs(this%screen_l(ti,tj)) - - cutoff_smooth = NRLTB_cutoff_func_smooth(this, r, ti, tj) - cutoff_smooth_d = NRLTB_cutoff_func_smooth_d(this, r, ti, tj) - - NRLTB_cutoff_function_d = ( 1.0_dp/(1.0_dp+expv) ) * cutoff_smooth_d - & - (1.0_dp/(1.0_dp+expv)**2)*expv_d * cutoff_smooth - else - NRLTB_cutoff_function_d = 0.0_dp - end if - -end function NRLTB_cutoff_function_d - - -function NRLTB_cutoff_function_dd(this, r, ti, tj) - type(TBModel_NRL_TB), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: NRLTB_cutoff_function_dd - - double precision screen_R0 - double precision cutoff_smooth, cutoff_smooth_d, cutoff_smooth_dd - double precision expv, expv_d, expv_dd - - if (r .gt. 10.0_dp**(-4)) then - - screen_R0 = this%r_cut(ti,tj) - 5.0D0*abs(this%screen_l(ti,tj)) - - expv = exp((r-screen_R0)/abs(this%screen_l(ti,tj))) - expv_d = expv * 1.0_dp/abs(this%screen_l(ti,tj)) - expv_dd = expv_d * 1.0_dp/abs(this%screen_l(ti,tj)) - - cutoff_smooth = NRLTB_cutoff_func_smooth(this, r, ti, tj) - cutoff_smooth_d = NRLTB_cutoff_func_smooth_d(this, r, ti, tj) - cutoff_smooth_dd = NRLTB_cutoff_func_smooth_dd(this, r, ti, tj) - - NRLTB_cutoff_function_dd = ( -1.0_dp/(1.0_dp+expv)**2 )*expv_d * cutoff_smooth_d + ( 1.0_dp/(1.0_dp+expv) ) * cutoff_smooth_dd - & - ((-2.0_dp/(1.0_dp+expv)**3)*expv_d**2 * cutoff_smooth + (1.0_dp/(1.0_dp+expv)**2)*expv_dd * cutoff_smooth + (1.0_dp/(1.0_dp+expv)**2)*expv_d * cutoff_smooth_d) - else - NRLTB_cutoff_function_dd = 0.0_dp - end if - -end function NRLTB_cutoff_function_dd - -function NRLTB_cutoff_func_smooth(this, r, ti, tj) - type(TBModel_NRL_TB), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: NRLTB_cutoff_func_smooth - - double precision R_MIN, R_MAX - - double precision PI - parameter (PI = 3.14159265358979323846264338327950288_dp) - - - if (this%screen_l(ti,tj) .lt. 0.0_dp) then - NRLTB_cutoff_func_smooth = 1.0_dp - return - endif - - R_MAX = this%r_cut(ti,tj) - R_MIN = R_MAX - abs(this%screen_l(ti,tj)) - - if (r .lt. R_MIN) then - NRLTB_cutoff_func_smooth = 1.0_dp - else if (r .gt. R_MAX) then - NRLTB_cutoff_func_smooth = 0.0_dp - else - NRLTB_cutoff_func_smooth = 1.0_dp - (1.0_dp - cos( (r-R_MIN)*PI / (R_MAX-R_MIN) ))/2.0_dp - end if - -end function NRLTB_cutoff_func_smooth - -function NRLTB_cutoff_func_smooth_d(this, r, ti, tj) - type(TBModel_NRL_TB), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: NRLTB_cutoff_func_smooth_d - - double precision R_MIN, R_MAX - - double precision PI - parameter (PI = 3.14159265358979323846264338327950288_dp) - - - if (this%screen_l(ti,tj) .lt. 0.0_dp) then - NRLTB_cutoff_func_smooth_d = 1.0_dp - return - endif - - R_MAX = this%r_cut(ti,tj) - R_MIN = R_MAX - abs(this%screen_l(ti,tj)) - - if (r .lt. R_MIN) then - NRLTB_cutoff_func_smooth_d = 0.0_dp - else if (r .gt. R_MAX) then - NRLTB_cutoff_func_smooth_d = 0.0_dp - else - NRLTB_cutoff_func_smooth_d = -sin( (r-R_MIN)*PI / (R_MAX-R_MIN) )/2.0_dp * (PI/(R_MAX-R_MIN)) - end if - -end function NRLTB_cutoff_func_smooth_d - -function NRLTB_cutoff_func_smooth_dd(this, r, ti, tj) - type(TBModel_NRL_TB), intent(in) :: this - real(dp), intent(in) :: r - integer, intent(in) :: ti, tj - real(dp) :: NRLTB_cutoff_func_smooth_dd - - double precision R_MIN, R_MAX - - double precision PI - parameter (PI = 3.14159265358979323846264338327950288_dp) - - - if (this%screen_l(ti,tj) .lt. 0.0_dp) then - NRLTB_cutoff_func_smooth_dd = 0.0_dp - return - endif - - R_MAX = this%r_cut(ti,tj) - R_MIN = R_MAX - abs(this%screen_l(ti,tj)) - - if (r .lt. R_MIN) then - NRLTB_cutoff_func_smooth_dd = 0.0_dp - else if (r .gt. R_MAX) then - NRLTB_cutoff_func_smooth_dd = 0.0_dp - else - NRLTB_cutoff_func_smooth_dd = -cos( (r-R_MIN)*PI / (R_MAX-R_MIN) )/2.0_dp * (PI/(R_MAX-R_MIN))**2 - end if - -end function NRLTB_cutoff_func_smooth_dd - -end module TBModel_NRL_TB_module diff --git a/src/Potentials/TBModel_NRL_TB_defs.f95 b/src/Potentials/TBModel_NRL_TB_defs.f95 deleted file mode 100644 index 00afcf50b1..0000000000 --- a/src/Potentials/TBModel_NRL_TB_defs.f95 +++ /dev/null @@ -1,48 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X TBModel_NRL_TB_defs module -!X -!% Definitions for NRL-TB model, to be shared with format conversion program -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -module TBModel_NRL_TB_defs_module -implicit none -public - integer, parameter :: max_n_orb_sets = 4 - - integer, parameter :: ABCD_A = 1, ABCD_B = 2, ABCD_C = 3, ABCD_D = 4 - integer, parameter :: SPDF_S = 1, SPDF_P = 2, SPDF_D = 3, SPDF_F = 4 - - integer, parameter :: MC_E = 1, MC_F = 2, MC_FB = 3, MC_G_SQ = 4 -end module TBModel_NRL_TB_defs_module diff --git a/src/Potentials/TBSystem.f95 b/src/Potentials/TBSystem.f95 deleted file mode 100644 index d8fbdfbacb..0000000000 --- a/src/Potentials/TBSystem.f95 +++ /dev/null @@ -1,3943 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X TBSystem module -!X -!% Code to contain a TB calculation, and evaluate H and S matrices etc. -!% Also contains much code to support self-consitency, dipole matrix elements -!% and spin-orbit coupling -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -module TBSystem_module - -use error_module -use system_module, only : dp, print, inoutput, PRINT_NORMAL, PRINT_ALWAYS, PRINT_NERD, current_verbosity, optional_default, operator(//), verbosity_push_decrement, verbosity_pop, verbosity_push, PRINT_ANALYSIS -use units_module, only : Hartree, Bohr, PI -use periodictable_module, only : ElementName -use linearalgebra_module, only : operator(.mult.), operator(.feq.), norm, print -use mpi_context_module, only : mpi_context, initialise, finalise -use dictionary_module, only : dictionary, initialise, finalise -use paramreader_module, only : param_register, param_read_line -use atoms_module, only : atoms, n_neighbours, neighbour, assignment(=) - -! use Functions_module -use QUIP_Common_module ! , only : xml_t, dictionary_t, pauli_sigma -use ScaLAPACK_module, only : scalapack, initialise -use TB_Common_module -use TBModel_module, only : tbmodel, initialise, finalise, print, & - n_orb_sets_of_Z, orb_type_of_orb_set_of_Z, n_orbs_of_orb_set_of_Z, n_orbs_of_Z, n_elecs_of_Z, & - get_HS_blocks, get_dHS_blocks, get_dHS_masks -use Matrix_module, only : matrixd, initialise, finalise, zero -use TBMatrix_module, only : tbmatrix, initialise, finalise, wipe, print, zero, add_block, sum_matrices, copy, make_hermitian -use TB_KPoints_module, only : kpoints, initialise, finalise, calc_phase, print, init_mpi, ksum_distrib_inplace -use TB_mixing_module, only : do_mix_simple, do_ridders_residual, do_mix_broyden -use ewald_module, only : add_madelung_matrix, add_dmadelung_matrix, add_dmadelung_matrix_dr - - -implicit none -private - -! character(40) :: sc_default_file = "self_consistency.data.xml" - -integer, parameter, public :: & - SCF_NONE = 0, & - SCF_LOCAL_U = 1, & - SCF_GLOBAL_U = 2, & - SCF_LCN = 3, & - SCF_GCN = 4, & - SCF_NONLOCAL_U_DFTB = 5, & - SCF_NONLOCAL_U_NRL_TB = 6, & - SCF_SPIN_DIR = 7, & - SCF_SPIN_STONER = 8 - -character(len=30), parameter :: scf_names(0:8) = (/ & -'NONE ', & -'LOCAL_U ', & -'GLOBAL_U ', & -'LCN ', & -'GCN ', & -'NONLOCAL_U_DFTB ', & -'NONLOCAL_U_NRL_TB ', & -'SPIN_DIR ', & -'SPIN_STONER ' /) - -! LOCAL_U F = sum_a U_a (n_a-n0_a)^2 -! GLOBAL_U F = U (sum_a n_a-n0_a)^2 -! LCN -! GCN -! NONLOCAL_U_DFTB F = sum_ab (n_a-n0_a) gamma_ab (n_b-n0_b) -! NONLOCAL_U_NRL_TB F = sum_ab (n_a-n0_a) gamma_ab (n_b-n0_b) -! SPIN_DIR F = -0.5 sum_a splitting_a | atomic_mom_a(i) | -! SPIN_STONER F = -0.25 sum_a stoner_param_a | atomic_mom_a(i) | ^2 - -public :: Self_Consistency_Term -type Self_Consistency_Term - logical :: active = .false. - integer :: type = SCF_NONE - integer :: N = 0, N_atoms = 0, N_manifolds = 0 - integer :: n_dof = 0 - - ! for SCF_GLOBAL_U - real(dp) :: global_U - real(dp) :: global_N - - ! for SCF_GLOBAL_U - real(dp) :: global_pot - - ! for SCF_LOCAL_U and SCF_NONLOCAL_U - real(dp), allocatable :: U(:) - real(dp), allocatable :: atomic_n(:), atomic_n0(:) - real(dp), allocatable :: datomic_local_pot_dr(:,:) - ! for SCF_LCN - real(dp), allocatable :: atomic_local_pot(:) - - ! for SCF_NONLOCAL_U_* - real(dp), allocatable :: gamma(:,:), dgamma_dr(:,:,:) - - ! for SCF_SPIN_* - real(dp), allocatable :: manifold_mom(:,:) - ! for SCF_SPIN_DIR - real(dp), allocatable :: spin_splitting(:) - ! for SCF_SPIN_STONER - real(dp), allocatable :: stoner_param(:) - -end type Self_Consistency_Term - -public :: Self_Consistency -type Self_Consistency - logical :: active = .false. - - integer :: N = 0, N_atoms = 0, N_manifolds = 0 - - real(dp) :: global_U - real(dp), allocatable :: U(:), stoner_param(:,:) - - type(Self_Consistency_Term), allocatable :: terms(:) - real(dp), allocatable :: orb_local_pot(:), orb_exch_field(:,:) - - real(dp) :: alpha = 0.01_dp, w0 = 0.02_dp - real(dp) :: conv_tol = 1.0e-10_dp - real(dp) :: mix_simple_end_tol = -1.0e-2_dp, mix_simple_start_tol=1.0e38_dp - - integer :: max_iter = 100 - - logical :: mix_simple = .false. - -end type Self_Consistency - -public :: TB_Dipole_Model -type TB_Dipole_Model - logical :: active = .false. - - integer :: n_types - integer, allocatable :: type_of_atomic_num(:), atomic_num(:) - integer, allocatable :: n_orb_sets(:), orb_set_type(:,:), orb_set_phase(:,:) - real(dp), allocatable :: gaussian_width(:,:) - -end type TB_Dipole_Model - -public :: TB_Spin_Orbit_Coupling -type TB_Spin_Orbit_Coupling - logical :: active = .false. - - integer :: n_types - integer, allocatable :: type_of_atomic_num(:), atomic_num(:) - integer, allocatable :: n_orb_sets(:), orb_set_type(:,:) - real(dp), allocatable :: SO_param(:,:) -end type TB_Spin_Orbit_Coupling - -public :: TBSystem -type TBSystem - - ! model and atomic config - integer :: N = 0, N_atoms = 0, N_manifolds = 0 - integer, allocatable :: at_Z(:) - type(TBModel) tbmodel - ! first_orb_of_atom: index into array of all orbitals of first orbital associated with each atom - ! first_manifold_of_atom: index into array of all manifolds of first manifold (s, p, d, etc) associated with each atom - ! first_orb_of_manifold: index into array of all orbitals of first orbital associated with each manifold - integer, allocatable :: first_orb_of_atom(:), first_manifold_of_atom(:), first_orb_of_manifold(:) - - logical :: noncollinear = .false. - logical :: spinpol_no_scf = .false. - logical :: complex_matrices = .false. - - integer :: max_block_size = 0 - - ! matrices - integer :: n_matrices = 0 - type(TBMatrix) :: H - type(TBMatrix) :: S - - type(TBMatrix) :: dH(3) - type(TBMatrix) :: dS(3) - - ! k points - logical :: kpoints_generate_dynamically = .false., kpoints_generate_next_dynamically = .false., kpoints_use_mp = .true. - real(dp) :: kpoints_k_space_density = 1.0_dp - type(KPoints) :: kpoints - - ! self consistency - type(Self_Consistency) :: scf - type(TB_Dipole_model) :: dipole_model - type(TB_Spin_Orbit_Coupling) :: SO - - type(MPI_context) :: mpi_global, mpi_my_matrices - type(ScaLAPACK) :: scalapack_my_matrices - -end type TBSystem - -logical :: parse_in_self_consistency -type(Self_Consistency), pointer :: parse_self_consistency - -logical :: parse_in_dipole_model -type(TB_Dipole_Model), pointer :: parse_dipole_model - -logical :: parse_in_spin_orbit_coupling -type(TB_Spin_Orbit_Coupling), pointer :: parse_spin_orbit_coupling - -public :: Initialise -interface Initialise - module procedure TBSystem_Initialise_str, TBSystem_Initialise_from_tbsys - module procedure Self_Consistency_Initialise_str, TB_Dipole_Model_Initialise_str - module procedure TB_Spin_Orbit_Coupling_Initialise_str -end interface Initialise - -public :: Setup_atoms -interface Setup_atoms - module procedure TBSystem_Setup_atoms_from_atoms, TBSystem_Setup_atoms_from_tbsys, TBSystem_setup_atoms_from_arrays -end interface Setup_atoms - -public :: Setup_deriv_matrices -interface Setup_deriv_matrices - module procedure TBSystem_Setup_deriv_matrices -end interface Setup_deriv_matrices - -interface Setup_system - module procedure Self_Consistency_setup_system - module procedure Self_Consistency_Term_setup_system -end interface Setup_system - -public :: Finalise -interface Finalise - module procedure TBSystem_Finalise, Self_Consistency_Finalise, Self_Consistency_Term_Finalise - module procedure TB_Dipole_Model_Finalise, TB_Spin_Orbit_Coupling_Finalise -end interface Finalise - -public :: Print -interface Print - module procedure TBSystem_Print, Self_Consistency_Print, Self_Consistency_Term_Print - module procedure TB_Dipole_Model_Print, TB_Spin_Orbit_Coupling_Print -end interface Print - -public :: Wipe -interface Wipe - module procedure TBSystem_Wipe, Self_Consistency_Wipe, Self_Consistency_Term_Wipe -end interface Wipe - -interface read_params_xml - module procedure Self_Consistency_read_params_xml, TB_Dipole_Model_read_params_xml, TB_Spin_Orbit_Coupling_read_params_xml -end interface read_params_xml - -public :: fill_matrices -interface fill_matrices - module procedure TBSystem_fill_matrices -end interface fill_matrices - -public :: fill_these_matrices -interface fill_these_matrices - module procedure TBSystem_fill_these_matrices -end interface fill_these_matrices - -public :: fill_dmatrices -interface fill_dmatrices - module procedure TBSystem_fill_dmatrices -end interface fill_dmatrices - -public :: fill_sc_matrices -interface fill_sc_matrices - module procedure TBSystem_fill_sc_matrices, Self_Consistency_Term_fill_sc_matrices -end interface fill_sc_matrices - -public :: fill_sc_dmatrices -interface fill_sc_dmatrices - module procedure TBSystem_fill_sc_dmatrices, Self_Consistency_Term_fill_sc_dmatrices -end interface fill_sc_dmatrices - -public :: atom_orbital_sum -interface atom_orbital_sum - module procedure TBSystem_atom_orbital_sum_real1, TBSystem_atom_orbital_sum_real2 - module procedure TBSystem_atom_orbital_sum_complex2 -end interface atom_orbital_sum - -public :: manifold_orbital_sum -interface manifold_orbital_sum - module procedure TBSystem_manifold_orbital_sum_real2 -end interface manifold_orbital_sum - -public :: atom_orbital_spread -interface atom_orbital_spread - module procedure TBSystem_atom_orbital_spread_real1 -end interface atom_orbital_spread - -public :: atom_orbital_spread_mat -interface atom_orbital_spread_mat - module procedure TBSystem_atom_orbital_spread_mat_r -end interface atom_orbital_spread_mat - -public :: ksum_atom_orbital_sum_mat -interface ksum_atom_orbital_sum_mat - module procedure TBSystem_ksum_atom_orbital_sum_mat_d -end interface ksum_atom_orbital_sum_mat - -public :: atom_orbital_sum_mat -interface atom_orbital_sum_mat - module procedure TBSystem_atom_orbital_sum_mat_r -end interface atom_orbital_sum_mat - -public :: set_type -interface set_type - module procedure Self_Consistency_set_type_str -end interface set_type - -public :: calc_orb_local_pot -interface calc_orb_local_pot - module procedure TBSystem_calc_orb_local_pot -end interface calc_orb_local_pot - -public :: update_orb_local_pot -interface update_orb_local_pot - module procedure TBSystem_update_orb_local_pot -end interface update_orb_local_pot - -public :: scf_e_correction, local_scf_e_correction, scf_f_correction, scf_virial_correction - -public :: n_elec -interface n_elec - module procedure TBSystem_n_elec -end interface n_elec - -public :: scf_get_atomic_n_mom -interface scf_get_atomic_n_mom - module procedure TBSystem_scf_get_atomic_n_mom -end interface scf_get_atomic_n_mom - -public :: scf_get_global_N -interface scf_get_global_N - module procedure TBSystem_scf_get_global_N -end interface scf_get_global_N - -public :: scf_set_atomic_n_mom -interface scf_set_atomic_n_mom - module procedure TBSystem_scf_set_atomic_n_mom -end interface scf_set_atomic_n_mom - -public :: scf_set_global_N -interface scf_set_global_N - module procedure TBSystem_scf_set_global_N -end interface scf_set_global_N - -public :: add_term_d2SCFE_dgNdn, add_term_dscf_e_correction_dgN, add_term_d2SCFE_dn2_times_vec, add_term_dscf_e_correction_dn - -public :: initialise_kpoints -interface initialise_kpoints - module procedure TBSystem_initialise_kpoints -end interface initialise_kpoints - -public :: copy_matrices -interface copy_matrices - module procedure TBSystem_copy_matrices -end interface copy_matrices - -contains -subroutine TBSystem_Initialise_str(this, args_str, param_str, kpoints_obj, mpi_obj) - type(TBSystem), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - type(KPoints), intent(in), optional :: kpoints_obj - type(MPI_context), intent(in), optional :: mpi_obj - - call Finalise(this) - - call Initialise(this%tbmodel, args_str, param_str) - - if (present(kpoints_obj)) then - call Initialise(this%kpoints, kpoints_obj, mpi_obj) - call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) - else - call initialise_kpoints(this, args_str, param_str, mpi_obj, from_tbsystem_initialise=.true.) - endif - - call Initialise(this%scf, args_str, param_str) - call Initialise(this%dipole_model, args_str, param_str) - call Initialise(this%SO, args_str, param_str) - -end subroutine TBSystem_Initialise_str - -subroutine check_dipole_model_consistency(dipole_model, tbm, Z) - type(TB_Dipole_Model), intent(in) :: dipole_model - type(TBModel), intent(in) :: tbm - integer, intent(in) :: Z(:) - - integer :: i_at - integer :: i_type, i_orb_set - - do i_at=1, size(Z) - i_type = dipole_model%type_of_atomic_num(Z(i_at)) - if (dipole_model%n_orb_sets(i_type) /= n_orb_sets_of_Z(tbm, Z(i_at))) & - call system_abort("check_dipole_model_consistency found mismatch in number of orbitals sets for Z="//Z(i_at) // & - " dipole_model " // dipole_model%n_orb_sets(i_type) // " tbmodel " // n_orb_sets_of_Z(tbm, Z(i_at)) ) - do i_orb_set=1, dipole_model%n_orb_sets(i_type) - if (dipole_model%orb_set_type(i_orb_set,i_type) /= orb_type_of_orb_set_of_Z(tbm, Z(i_at), i_orb_set)) & - call system_abort("check_dipole_model_consistency found mismatch in orbital set type for Z="//Z(i_at) // & - " i_orb_set="//i_orb_set// " dipole_model " // dipole_model%orb_set_type(i_orb_set,i_type) // " tbmodel " // orb_type_of_orb_set_of_Z(tbm, Z(i_at), i_orb_set) ) - end do - end do -end subroutine check_dipole_model_consistency - -subroutine check_spin_orbit_coupling_consistency(spin_orbit_coupling, tbm, Z) - type(TB_Spin_Orbit_Coupling), intent(in) :: spin_orbit_coupling - type(TBModel), intent(in) :: tbm - integer, intent(in) :: Z(:) - - integer :: i_at - integer :: i_type, i_orb_set - - do i_at=1, size(Z) - i_type = spin_orbit_coupling%type_of_atomic_num(Z(i_at)) - if (spin_orbit_coupling%n_orb_sets(i_type) /= n_orb_sets_of_Z(tbm, Z(i_at))) & - call system_abort("check_spin_orbit_coupling_consistency found mismatch in number of orbitals sets for Z="//Z(i_at) // & - " spin_orbit_coupling " // spin_orbit_coupling%n_orb_sets(i_type) // " tbmodel " // n_orb_sets_of_Z(tbm, Z(i_at)) ) - do i_orb_set=1, spin_orbit_coupling%n_orb_sets(i_type) - if (spin_orbit_coupling%orb_set_type(i_orb_set,i_type) /= orb_type_of_orb_set_of_Z(tbm, Z(i_at), i_orb_set)) & - call system_abort("check_spin_orbit_coupling_consistency found mismatch in orbital set type for Z="//Z(i_at) // & - " i_orb_set="//i_orb_set// " spin_orbit_coupling " // spin_orbit_coupling%orb_set_type(i_orb_set,i_type) // " tbmodel " // & - orb_type_of_orb_set_of_Z(tbm, Z(i_at), i_orb_set) ) - end do - end do -end subroutine check_spin_orbit_coupling_consistency - -subroutine TBSystem_Initialise_from_tbsys(this, from, mpi_obj) - type(TBSystem), intent(inout) :: this - type(TBSystem), intent(in) :: from - type(MPI_context), intent(in), optional :: mpi_obj - - call Finalise(this) - - this%tbmodel = from%tbmodel - this%complex_matrices = from%complex_matrices - this%noncollinear = from%noncollinear - this%spinpol_no_scf = from%spinpol_no_scf - - this%kpoints = from%kpoints - this%kpoints_generate_dynamically = from%kpoints_generate_dynamically - this%kpoints_generate_next_dynamically = from%kpoints_generate_next_dynamically - this%kpoints_use_mp = from%kpoints_use_mp - this%kpoints_k_space_density = from%kpoints_k_space_density - call init_mpi(this%kpoints, mpi_obj) - - call initialise_tbsystem_k_dep_stuff(this, mpi_obj) - - this%scf = from%scf - this%dipole_model = from%dipole_model - - call setup_atoms(this, from) -end subroutine TBSystem_Initialise_from_tbsys - -subroutine initialise_tbsystem_k_dep_stuff(this, mpi_obj) - type(TBSystem), intent(inout) :: this - type(MPI_Context), optional, intent(in) :: mpi_obj - - if (this%kpoints%N > 0) then - this%n_matrices = this%kpoints%N - else - this%n_matrices = 0 - endif - - if (present(mpi_obj)) then - this%mpi_global = this%kpoints%mpi_global - call Initialise(this%scalapack_my_matrices, this%kpoints%mpi_my_kpt) - if (.not. this%scalapack_my_matrices%active .and. this%kpoints%mpi_my_kpt%n_procs > 1) then - this%kpoints%no_sum_over_my_kpt = .true. - endif - this%mpi_my_matrices = this%kpoints%mpi_my_kpt - endif - -end subroutine Initialise_tbsystem_k_dep_stuff - -subroutine TBSystem_Finalise(this) - type(TBSystem), intent(inout) :: this - - call Wipe(this) - - call Finalise(this%tbmodel) - call Finalise(this%kpoints) - call Finalise(this%scf) - call Finalise(this%dipole_model) - - call Finalise(this%H) - call Finalise(this%dH(1)) - call Finalise(this%dH(2)) - call Finalise(this%dH(3)) - call Finalise(this%S) - call Finalise(this%dS(1)) - call Finalise(this%dS(2)) - call Finalise(this%dS(3)) - - call Finalise(this%mpi_global) -end subroutine TBSystem_Finalise - -subroutine TBSystem_Wipe(this) - type(TBSystem), intent(inout) :: this - - if (allocated(this%first_orb_of_atom)) deallocate(this%first_orb_of_atom) - if (allocated(this%first_orb_of_manifold)) deallocate(this%first_orb_of_manifold) - if (allocated(this%first_manifold_of_atom)) deallocate(this%first_manifold_of_atom) - if (allocated(this%at_Z)) deallocate(this%at_Z) - - call Wipe(this%scf) - call Wipe(this%H) - call Wipe(this%S) - call Wipe(this%dH(1)) - call Wipe(this%dH(2)) - call Wipe(this%dH(3)) - call Wipe(this%dS(1)) - call Wipe(this%dS(2)) - call Wipe(this%dS(3)) - - call Finalise(this%mpi_my_matrices) - - this%N = 0 - this%N_atoms = 0 - this%N_manifolds = 0 - this%max_block_size = 0 -end subroutine TBSystem_Wipe - -function TBSystem_n_elec(this, at, w_n) - type(TBSystem), intent(in) :: this - type(Atoms), intent(in) :: at - real(dp), intent(in), pointer, optional :: w_n(:) - real(dp) :: TBSystem_n_elec - - integer i - - TBSystem_n_elec = 0 - do i=1, this%N_atoms - if (present(w_n)) then - if (associated(w_n)) then - TBSystem_n_elec = TBSystem_n_elec + w_n(i)*n_elecs_of_Z(this%tbmodel, at%Z(i)) - else - TBSystem_n_elec = TBSystem_n_elec + n_elecs_of_Z(this%tbmodel, at%Z(i)) - end if - else - TBSystem_n_elec = TBSystem_n_elec + n_elecs_of_Z(this%tbmodel, at%Z(i)) - endif - end do -end function TBSystem_n_elec - -subroutine TBSystem_Setup_atoms_from_atoms(this, at, noncollinear, spinpol_no_scf, args_str, mpi_obj, error) - type(TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - logical, intent(in), optional :: noncollinear, spinpol_no_scf - character(len=*), intent(in), optional :: args_str - type(MPI_context), intent(in), optional :: mpi_obj - integer, intent(out), optional :: error - - INIT_ERROR(error) - - call initialise_kpoints(this, args_str=args_str, mpi_obj=mpi_obj) - if (this%kpoints_generate_dynamically) then - call initialise(this%kpoints, at%lattice, this%kpoints_k_space_density, this%kpoints_use_mp, mpi_obj) - call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) - this%kpoints_generate_dynamically = this%kpoints_generate_next_dynamically - endif - call setup_atoms(this, at%N, at%Z, noncollinear, spinpol_no_scf, error=error) - PASS_ERROR(error) - -end subroutine TBSystem_Setup_atoms_from_atoms - -subroutine TBSystem_Setup_atoms_from_tbsys(this, from, error) - type(TBSystem), intent(inout) :: this - type(TBSystem), intent(in) :: from - integer, intent(out), optional :: error - - INIT_ERROR(error) - - call setup_atoms(this, from%N_atoms, from%at_Z, from%noncollinear, from%spinpol_no_scf, error=error) - PASS_ERROR(error) - -end subroutine TBSystem_Setup_Atoms_from_tbsys - -subroutine TBSystem_Setup_atoms_from_arrays(this, at_N, at_Z, noncollinear, spinpol_no_scf, error) - type(TBSystem), intent(inout) :: this - integer, intent(in) :: at_N, at_Z(:) - logical, intent(in), optional :: noncollinear, spinpol_no_scf - integer, intent(out), optional :: error - - integer :: i_at, i_man, man_offset, last_man_offset - integer :: n_mag - - INIT_ERROR(error) - - call Wipe(this) - - this%noncollinear = optional_default(this%noncollinear, noncollinear) - this%spinpol_no_scf = optional_default(this%spinpol_no_scf, spinpol_no_scf) - - this%N_atoms = at_N - allocate(this%at_Z(this%N_atoms)) - this%at_Z = at_Z - - if (this%noncollinear) then - n_mag = 2 - else - n_mag = 1 - end if - - ! fill in first_orb_of_atom and first_manifold_of_atom arrays - allocate(this%first_orb_of_atom(this%N_atoms+1)) - allocate(this%first_manifold_of_atom(this%N_atoms+1)) - this%first_orb_of_atom(1) = 1 - this%first_manifold_of_atom(1) = 1 - do i_at=2, this%N_atoms+1 - this%first_orb_of_atom(i_at) = this%first_orb_of_atom(i_at-1) + & - n_mag*n_orbs_of_Z(this%tbmodel, at_Z(i_at-1)) - this%first_manifold_of_atom(i_at) = this%first_manifold_of_atom(i_at-1) + & - n_orb_sets_of_Z(this%tbmodel, at_Z(i_at-1)) - end do - - this%N = this%first_orb_of_atom(this%N_atoms+1)-1 - this%N_manifolds = this%first_manifold_of_atom(this%N_atoms+1)-1 - - ! fill in first_orb_of_manifold array - allocate(this%first_orb_of_manifold(this%N_manifolds+1)) - this%first_orb_of_manifold(1) = 1 - ! don't really need this, but some compilers complain because it's used before set (even though - ! thing that uses it (last_man_offset) isn't actually used until it has a meaningul value) - man_offset = 1 - ! set in case first atom has only 1 manifold - last_man_offset = 1 - do i_at=1, this%N_atoms - do i_man=this%first_manifold_of_atom(i_at), this%first_manifold_of_atom(i_at+1)-1 - ! if this is very first manifold, it was already set before entering loop, so skip - if (i_man == 1) cycle - - ! save man_offset in case we need it for next atom's first manifold - last_man_offset = man_offset - ! man_offset says which manifold (1...) of this atom the loop is currently at - man_offset = i_man - this%first_manifold_of_atom(i_at) + 1 - - if (man_offset == 1) then - ! first manifold of this atom - ! first orb is first orb of first manifold of previous atom + number of orbs in that manifold - this%first_orb_of_manifold(i_man) = this%first_orb_of_manifold(i_man-1) + & - n_mag*n_orbs_of_orb_set_of_Z(this%tbmodel, at_Z(i_at-1), last_man_offset) - else - ! second or later manifold of this atom - ! first orb is first orb of previous manifold + number of orbs in that manifold - this%first_orb_of_manifold(i_man) = this%first_orb_of_manifold(i_man-1) + & - n_mag*n_orbs_of_orb_set_of_Z(this%tbmodel, at_Z(i_at), man_offset-1) - endif - if (i_at == this%N_atoms+1) exit - end do - end do - - ! set last orb of last manifold - this%first_orb_of_manifold(this%N_manifolds+1) = this%first_orb_of_manifold(this%N_manifolds) + & - n_mag*n_orbs_of_orb_set_of_Z(this%tbmodel, at_Z(this%N_atoms), n_orb_sets_of_Z(this%tbmodel, at_Z(this%N_atoms))) - - this%max_block_size = maxval(this%first_orb_of_atom(2:this%N_atoms+1) - & - this%first_orb_of_atom(1:this%N_atoms)) - - this%complex_matrices = this%kpoints%non_gamma .or. this%noncollinear - call Initialise(this%H, this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) - if (.not. this%tbmodel%is_orthogonal) then - call Initialise(this%S, this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) - endif - - call setup_system(this%scf, this%N, this%tbmodel, this%N_atoms, this%at_Z, this%N_manifolds) - -end subroutine TBSystem_Setup_Atoms_from_arrays - -subroutine TBSystem_Setup_deriv_matrices(this, at, dense, need_S) - type(TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - logical, intent(in), optional :: dense, need_S - - logical do_S, my_dense - - do_S = .not. this%tbmodel%is_orthogonal - if (present(need_S)) do_S = do_S .or. need_S - - if (this%N == 0 .or. this%N_atoms == 0) then - call system_abort ('Called TBSystem_Setup_deriv_matrices on uninitialized TBSystem') - endif - - my_dense = optional_default(.false., dense) - - call Finalise(this%dH(1)) - call Finalise(this%dH(2)) - call Finalise(this%dH(3)) - call Finalise(this%dS(1)) - call Finalise(this%dS(2)) - call Finalise(this%dS(3)) - - if (my_dense) then - call Initialise(this%dH(1), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) - call Initialise(this%dH(2), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) - call Initialise(this%dH(3), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) - if (do_S) then - call Initialise(this%dS(1), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) - call Initialise(this%dS(2), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) - call Initialise(this%dS(3), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) - endif - else - call Initialise(this%dH(1), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) - call Initialise(this%dH(2), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) - call Initialise(this%dH(3), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) - if (do_S) then - call Initialise(this%dS(1), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) - call Initialise(this%dS(2), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) - call Initialise(this%dS(3), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) - endif - endif - -end subroutine - -subroutine TBSystem_fill_matrices(this, at, need_H, need_S, no_S_spin) - type (TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - logical, intent(in), optional :: need_H, need_S, no_S_spin - - logical :: do_need_H, do_need_S, do_no_S_spin - - do_need_S = .not. this%tbmodel%is_orthogonal - if (present(need_S)) do_need_S = do_need_S .or. need_S - - do_need_H = optional_default(.true., need_H) - do_no_S_spin = optional_default(.false., no_S_spin) - - if (do_need_S .and. this%S%N == 0) then - call Initialise(this%S, this%N, this%n_matrices, this%complex_matrices) - endif - - call fill_these_matrices(this, at, do_need_H, this%H, do_need_S, this%S, do_no_S_spin) - -end subroutine - -subroutine TBSystem_fill_these_matrices(this, at, do_H, H, do_S, S, no_S_spin, do_dipole, dipole) - type (TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - logical, intent(in), optional :: do_H - type(TBMatrix), intent(inout), optional :: H - logical, intent(in), optional :: do_S - type(TBMatrix), intent(inout), optional :: S - logical, intent(in), optional :: no_S_spin - logical, intent(in), optional :: do_dipole - type(TBMatrix), intent(inout), optional :: dipole(3) - - integer :: i, ji, j, ik, ii, jj, iii, jjj - real(dp), allocatable :: block_H(:,:), block_S(:,:), block_H_up(:,:), block_H_down(:,:), block_dipole(:,:,:) - complex(dp), allocatable :: block_H_z(:,:), block_S_z(:,:), block_H_z_phase(:,:), block_S_z_phase(:,:) - complex(dp), allocatable :: block_dipole_z(:,:,:), block_dipole_z_phase(:,:,:) - complex(dp), allocatable :: block_SO(:,:) - real(dp) :: dv_hat(3), dv_hat_ij(3), dv_hat_ji(3), dv_mag - integer :: shift(3) - complex(dp) :: expf - - integer :: block_nr, block_nc - - logical :: u_do_S, u_do_S_block, u_do_H, u_no_S_spin, u_do_dipole - - u_do_S = optional_default(.false., do_S) - u_do_H = optional_default(.false., do_H) - u_no_S_spin = optional_default(.false., no_S_spin) - u_do_dipole = optional_default(.false., do_dipole) - - u_do_S_block = u_do_S .or. this%scf%active - - if (u_do_H .and. .not. present(H)) call system_abort("Called TBSystem_fill_some_matrices with do_H but no H") - if (u_do_S .and. .not. present(S)) call system_abort("Called TBSystem_fill_some_matrices with do_S but no S") - if (u_do_dipole .and. .not. present(dipole)) call system_abort("Called TBSystem_fill_some_matrices with do_dipole but no dipole") - - if (u_do_H) call Zero(H) - if (u_do_S) call Zero(S) - if (u_do_dipole) then - call Zero(dipole(1)) - call Zero(dipole(2)) - call Zero(dipole(3)) - call check_dipole_model_consistency(this%dipole_model, this%tbmodel, at%Z) - endif - - allocate(block_H(this%max_block_size, this%max_block_size)) - allocate(block_S(this%max_block_size, this%max_block_size)) - allocate(block_dipole(this%max_block_size, this%max_block_size,3)) - block_H = 0.0_dp - block_S = 0.0_dp - block_dipole = 0.0_dp - if (this%complex_matrices) then - allocate(block_H_z(this%max_block_size, this%max_block_size)) - allocate(block_S_z(this%max_block_size, this%max_block_size)) - allocate(block_dipole_z(this%max_block_size, this%max_block_size,3)) - block_H_z = 0.0_dp - block_S_z = 0.0_dp - block_dipole_z = 0.0_dp - if (this%kpoints%non_gamma) then - allocate(block_H_z_phase(this%max_block_size, this%max_block_size)) - allocate(block_S_z_phase(this%max_block_size, this%max_block_size)) - allocate(block_dipole_z_phase(this%max_block_size, this%max_block_size,3)) - block_H_z_phase = 0.0_dp - block_S_z_phase = 0.0_dp - block_dipole_z_phase = 0.0_dp - endif - endif - if (this%noncollinear) then - allocate(block_H_up(this%max_block_size, this%max_block_size)) - allocate(block_H_down(this%max_block_size, this%max_block_size)) - block_H_up = 0.0_dp - block_H_down = 0.0_dp - if (this%SO%active) then - allocate(block_SO(this%max_block_size, this%max_block_size)) - block_SO = 0.0_dp - call check_spin_orbit_coupling_consistency(this%SO, this%tbmodel, at%Z) - endif - else - if (this%SO%active) then - call print("WARNING: fill_these_matrices got active spin-orbit coupling, but noncollinear is off") - endif - endif - - do i=1, at%N - block_nr = this%first_orb_of_atom(i+1)-this%first_orb_of_atom(i) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dv_mag, shift = shift) - - ! do our own direction cosine, since atom_neighbour() result isn't antisymmetric enough - if (i == j) then - dv_hat = at%lattice .mult. shift - else - dv_hat_ij = at%pos(:,j) - at%pos(:,i) + (at%lattice .mult. shift) - dv_hat_ji = at%pos(:,i) - at%pos(:,j) - (at%lattice .mult. shift) - dv_hat = 0.5_dp*(dv_hat_ij - dv_hat_ji) - endif - if (maxval(abs(dv_hat)) .feq. 0.0_dp) then - dv_hat = 0.0_dp - else - dv_hat = dv_hat / norm(dv_hat) - endif - - block_nc = this%first_orb_of_atom(j+1)-this%first_orb_of_atom(j) - - if (this%noncollinear) then - if (.not. this%complex_matrices) call system_abort("noncollinear supported for complex matrices only") - call get_HS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, block_H_up, block_S, i_mag=1) - call get_HS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, block_H_down, block_S, i_mag=2) - block_H_z = 0.0_dp - if (this%spinpol_no_scf) then - block_H_z(1:block_nr:2,1:block_nc:2) = block_H_up(1:block_nr/2,1:block_nc/2) - block_H_z(2:block_nr:2,2:block_nc:2) = block_H_down(1:block_nr/2,1:block_nc/2) - else - block_H_z(1:block_nr:2,1:block_nc:2) = 0.5_dp*(block_H_up(1:block_nr/2,1:block_nc/2)+block_H_down(1:block_nr/2,1:block_nc/2)) - block_H_z(2:block_nr:2,2:block_nc:2) = 0.5_dp*(block_H_up(1:block_nr/2,1:block_nc/2)+block_H_down(1:block_nr/2,1:block_nc/2)) - endif - block_S_z = 0.0_dp - block_S_z(1:block_nr:2,1:block_nc:2) = block_S(1:block_nr/2,1:block_nc/2) - block_S_z(2:block_nr:2,2:block_nc:2) = block_S(1:block_nr/2,1:block_nc/2) - if (u_no_S_spin) then - block_S_z(1:block_nr:2,2:block_nc:2) = block_S(1:block_nr/2,1:block_nc/2) - block_S_z(2:block_nr:2,1:block_nc:2) = block_S(1:block_nr/2,1:block_nc/2) - endif - if (this%SO%active .and. (i == j) .and. (dv_mag .feq. 0.0_dp)) then - call get_SO_block(this%SO, this%tbmodel, at%Z(i), block_SO) - block_H_z = block_H_z + block_SO - endif - if (u_do_dipole) call system_abort("No dipole for noncollinear magnetism yet") - else ! not noncollinear - call get_HS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, block_H, block_S) - if (this%complex_matrices) then - block_H_z = block_H - block_S_z = block_S - endif - if (u_do_dipole) then - call get_dipole_block(this%dipole_model, at, i, j, dv_hat, dv_mag, block_dipole) - if (this%complex_matrices) then - block_dipole_z = block_dipole - endif - endif - endif - - if (u_do_H) then - if (this%scf%active) then - do ii=1, this%first_orb_of_atom(i+1)-this%first_orb_of_atom(i) - do jj=1, this%first_orb_of_atom(j+1)-this%first_orb_of_atom(j) - if (this%complex_matrices) then - block_H_z(ii,jj) = block_H_z(ii,jj) + & - 0.5_dp*( this%scf%orb_local_pot(this%first_orb_of_atom(i)+ii-1) + & - this%scf%orb_local_pot(this%first_orb_of_atom(j)+jj-1) ) * block_S_z(ii,jj) - else - block_H(ii,jj) = block_H(ii,jj) + & - 0.5_dp*( this%scf%orb_local_pot(this%first_orb_of_atom(i)+ii-1) + & - this%scf%orb_local_pot(this%first_orb_of_atom(j)+jj-1) ) * block_S(ii,jj) - endif - end do - end do - - if (this%noncollinear) then - do ii=1, block_nr, 2 - do jj=1, block_nc, 2 - iii = (ii-1)/2+1 - jjj = (jj-1)/2+1 - call add_exch_field_local_pot(0.5_dp*(this%scf%orb_exch_field(1:3,this%first_orb_of_atom(i)+ii-1) + & - this%scf%orb_exch_field(1:3,this%first_orb_of_atom(j)+jj-1)), & - block_S(iii,jjj), block_H_z(ii:ii+1,jj:jj+1) ) - end do - end do - endif - - endif - endif - - if (this%complex_matrices) then - if (this%kpoints%non_gamma) then - do ik=1, this%kpoints%N - expf = calc_phase(this%kpoints, ik, shift) - if (u_do_H) then - block_H_z_phase = block_H_z*expf - call add_block(H, ik, block_H_z_phase, block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - if (u_do_S) then - block_S_z_phase = block_S_z*expf - call add_block(S, ik, block_S_z_phase, block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - if (u_do_dipole) then - block_dipole_z_phase = block_dipole_z*expf - call add_block(dipole(1), ik, block_dipole_z_phase(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(dipole(2), ik, block_dipole_z_phase(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(dipole(3), ik, block_dipole_z_phase(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - end do - else ! gamma-point - if (u_do_H) then - call add_block(H, 1, block_H_z, block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - if (u_do_S) then - call add_block(S, 1, block_S_z, block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - if (u_do_dipole) then - call add_block(dipole(1), 1, block_dipole_z(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(dipole(2), 1, block_dipole_z(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(dipole(3), 1, block_dipole_z(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - endif ! non gamma - else ! real matrices - do ik=1, this%n_matrices - if (u_do_H) then - call add_block(H, ik, block_H, block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - if (u_do_S) then - call add_block(S, ik, block_S, block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - if (u_do_dipole) then - call add_block(dipole(1), ik, block_dipole(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(dipole(2), ik, block_dipole(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(dipole(3), ik, block_dipole(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - end do - endif ! complex matrices - - end do - end do - - if (allocated(block_H)) deallocate(block_H) - if (allocated(block_H_up)) deallocate(block_H_up) - if (allocated(block_H_down)) deallocate(block_H_down) - if (allocated(block_S)) deallocate(block_S) - if (allocated(block_dipole)) deallocate(block_dipole) - if (allocated(block_H_z)) deallocate(block_H_z) - if (allocated(block_S_z)) deallocate(block_S_z) - if (allocated(block_dipole_z)) deallocate(block_dipole_z) - if (allocated(block_H_z_phase)) deallocate(block_H_z_phase) - if (allocated(block_S_z_phase)) deallocate(block_S_z_phase) - if (allocated(block_dipole_z_phase)) deallocate(block_dipole_z_phase) - - ! if (do_H) call make_hermitian(H) - ! if (do_S) call make_hermitian(S) - -end subroutine TBSystem_fill_these_matrices - -subroutine add_exch_field_local_pot(exch_field, block_S, block_H_z) - real(dp), intent(in) :: exch_field(3) - real(dp), intent(in) :: block_S - complex(dp), intent(inout) :: block_H_z(2,2) - - complex(dp) :: E_dot_sigma(2,2) - - E_dot_sigma(:,:) = exch_field(1)*pauli_sigma(:,:,1) + exch_field(2)*pauli_sigma(:,:,2) + exch_field(3)*pauli_sigma(:,:,3) - - block_H_z = block_H_z + block_S*E_dot_sigma - -end subroutine add_exch_field_local_pot - -subroutine TBSystem_fill_dmatrices(this, at, at_ind, need_S, dense, diag_mask, offdiag_mask) - type (TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: at_ind - logical, intent(in), optional :: need_S, dense - logical, intent(out), optional, target :: diag_mask(:), offdiag_mask(:) - - integer :: i, ji, j, ik, ii, jj - real(dp), allocatable :: block_dH(:,:,:), block_dS(:,:,:), block_dH_up(:,:,:), block_dH_down(:,:,:) - complex(dp), allocatable :: block_dH_z(:,:,:), block_dS_z(:,:,:) - complex(dp), allocatable :: block_dH_z_phase(:,:,:), block_dS_z_phase(:,:,:) - real(dp) :: dv_hat(3), dv_mag - integer :: shift(3) - - logical, pointer :: d_mask(:), od_mask(:) - - logical :: do_S, do_S_block - logical :: block_active - - complex(dp) :: expf - - integer block_nr, block_nc - - if (at_ind >= 0) then - if (at_ind < 1 .or. at_ind > at%N) & - call system_abort("Called TBSystem_fill_dmatrices for atom with at_ind " // at_ind // " > 0, but out of range " // 1 // " " // at%N) - else - if (at_ind < -3 .or. at_ind > -1) & - call system_abort("Called TBSystem_fill_dmatrices for virial with at_ind " // at_ind // " < 0, but out of range " // -3 // " " // -3) - end if - - do_S = .not. this%tbmodel%is_orthogonal - if (present(need_S)) do_S = do_S .or. need_S - do_S_block = do_S .or. this%scf%active - - allocate(block_dH(this%max_block_size, this%max_block_size, 3)) - allocate(block_dH_up(this%max_block_size, this%max_block_size, 3)) - allocate(block_dH_down(this%max_block_size, this%max_block_size, 3)) - allocate(block_dS(this%max_block_size, this%max_block_size, 3)) - block_dH = 0.0_dp - block_dH_up = 0.0_dp - block_dH_down = 0.0_dp - block_dS = 0.0_dp - if (this%complex_matrices) then - allocate(block_dH_z(this%max_block_size, this%max_block_size, 3)) - allocate(block_dS_z(this%max_block_size, this%max_block_size, 3)) - block_dH_z = 0.0_dp - block_dS_z = 0.0_dp - if (this%kpoints%non_gamma) then - allocate(block_dH_z_phase(this%max_block_size, this%max_block_size, 3)) - allocate(block_dS_z_phase(this%max_block_size, this%max_block_size, 3)) - block_dH_z_phase = 0.0_dp - block_dS_z_phase = 0.0_dp - endif - endif - - if (present(diag_mask)) then - d_mask => diag_mask - else - allocate(d_mask(at%N)) - endif - if (present(offdiag_mask)) then - od_mask => offdiag_mask - else - allocate(od_mask(at%N)) - endif - call get_dHS_masks(this%tbmodel, at, at_ind, d_mask, od_mask) - - call Zero(this%dH(1), d_mask, od_mask) - call Zero(this%dH(2), d_mask, od_mask) - call Zero(this%dH(3), d_mask, od_mask) - if (do_S) then - call Zero(this%dS(1), d_mask, od_mask) - call Zero(this%dS(2), d_mask, od_mask) - call Zero(this%dS(3), d_mask, od_mask) - endif - - do i=1, at%N - block_nr = this%first_orb_of_atom(i+1)-this%first_orb_of_atom(i) - do ji=1, n_neighbours(at, i) - j = neighbour(at, i, ji, dv_mag, cosines = dv_hat, shift = shift) - block_nc = this%first_orb_of_atom(j+1)-this%first_orb_of_atom(j) - - - if ((i == j .and. .not. d_mask(i)) .or. & - (i /= j .and. .not. od_mask(i) .and. .not. od_mask(j))) then - cycle - endif - - if (this%noncollinear) then - if (.not. this%complex_matrices) call system_abort("noncollinear supported for complex matrices only") - if (.not. this%spinpol_no_scf) call system_abort("noncollinear forces only supported for spinpol_no_scf") - block_active = get_dHS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, at_ind, block_dH_up, block_dS, i_mag=1) - block_active = get_dHS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, at_ind, block_dH_down, block_dS, i_mag=2) - if (block_active .and. this%complex_matrices) then - block_dH_z(1:block_nr:2,1:block_nc:2,:) = block_dH_up(1:block_nr/2,1:block_nc/2,:) - block_dH_z(2:block_nr:2,2:block_nc:2,:) = block_dH_down(1:block_nr/2,1:block_nc/2,:) - if (do_S_block) then - block_dS_z(1:block_nr:2,1:block_nc:2,:) = block_dS(1:block_nr/2,1:block_nc/2,:) - block_dS_z(2:block_nr:2,2:block_nc:2,:) = block_dS(1:block_nr/2,1:block_nc/2,:) - endif - endif - else - block_active = get_dHS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, at_ind, block_dH, block_dS) - if (block_active .and. this%complex_matrices) then - block_dH_z = block_dH - if (do_S_block) block_dS_z = block_dS - endif - endif - - if (block_active .and. this%scf%active) then - do ii=1, this%first_orb_of_atom(i+1)-this%first_orb_of_atom(i) - do jj=1, this%first_orb_of_atom(j+1)-this%first_orb_of_atom(j) - if (this%complex_matrices) then - block_dH_z(ii,jj,:) = block_dH_z(ii,jj,:) + & - 0.5_dp*( this%scf%orb_local_pot(this%first_orb_of_atom(i)+ii-1) + & - this%scf%orb_local_pot(this%first_orb_of_atom(j)+jj-1) ) * block_dS_z(ii,jj,:) - else - block_dH(ii,jj,:) = block_dH(ii,jj,:) + & - 0.5_dp*( this%scf%orb_local_pot(this%first_orb_of_atom(i)+ii-1) + & - this%scf%orb_local_pot(this%first_orb_of_atom(j)+jj-1) ) * block_dS(ii,jj,:) - endif - end do - end do - ! need to add noncollinear stuff here !!! - endif - - if (block_active) then - if (this%complex_matrices) then - if (this%kpoints%non_gamma) then - do ik=1, this%kpoints%N - expf = calc_phase(this%kpoints, ik, shift) - block_dH_z_phase = block_dH_z*expf - call add_block(this%dH(1), ik, block_dH_z_phase(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dH(2), ik, block_dH_z_phase(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dH(3), ik, block_dH_z_phase(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - if (do_S) then - block_dS_z_phase = block_dS_z*expf - call add_block(this%dS(1), ik, block_dS_z_phase(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dS(2), ik, block_dS_z_phase(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dS(3), ik, block_dS_z_phase(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - end do - else ! gamma - call add_block(this%dH(1), 1, block_dH_z(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dH(2), 1, block_dH_z(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dH(3), 1, block_dH_z(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - if (do_S) then - call add_block(this%dS(1), 1, block_dS_z(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dS(2), 1, block_dS_z(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dS(3), 1, block_dS_z(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - endif ! non_gamma - else ! real matrices - call add_block(this%dH(1), 1, block_dH(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dH(2), 1, block_dH(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dH(3), 1, block_dH(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - if (do_S) then - call add_block(this%dS(1), 1, block_dS(:,:,1), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dS(2), 1, block_dS(:,:,2), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - call add_block(this%dS(3), 1, block_dS(:,:,3), block_nr, block_nc, & - this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) - endif - endif ! complex_matrices - endif ! block_active - - end do ! i - end do ! j - - if (allocated(block_dH)) deallocate(block_dH) - if (allocated(block_dS)) deallocate(block_dS) - if (allocated(block_dH_z)) deallocate(block_dH_z) - if (allocated(block_dS_z)) deallocate(block_dS_z) - if (allocated(block_dH_z_phase)) deallocate(block_dH_z_phase) - if (allocated(block_dS_z_phase)) deallocate(block_dS_z_phase) - - if (.not. present(diag_mask)) deallocate(d_mask) - if (.not. present(offdiag_mask)) deallocate(od_mask) - -end subroutine - -subroutine TBSystem_ksum_mat_d(this, tbm, m) - type(TBSystem), intent(in) :: this - type(TBMatrix), intent(in) :: tbm - type(MatrixD), intent(inout) :: m - - call sum_matrices(tbm, this%kpoints%weights, m) -end subroutine - -subroutine TBSystem_ksum_atom_orbital_sum_mat_d(this, tbm, m) - type(TBSystem), intent(in) :: this - type(TBMatrix), intent(in) :: tbm - type(MatrixD), intent(inout) :: m - - type(MatrixD) :: t_m - - call Initialise(t_m, this%N) - call Zero(t_m) - - call sum_matrices(tbm, this%kpoints%weights, t_m) - call ksum_distrib_inplace(this%kpoints, t_m%data) - - call atom_orbital_sum_mat(this, t_m%data, m%data) -end subroutine - -function TBSystem_atom_orbital_sum_real2(this,a) - type(TBSystem), intent(in) :: this - real(dp), intent(in) :: a(:,:) - real(dp) :: TBSystem_atom_orbital_sum_real2(this%N_atoms,size(a,2)) - - integer i - - if (size(a,1) /= this%N) then - call system_abort("Called TBSystem_atom_orbital_sum_real2 with wrong size array") - endif - - do i=1, this%N_atoms - TBSystem_atom_orbital_sum_real2(i,:) = sum(a(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1,:),1) - end do -end function TBSystem_atom_orbital_sum_real2 - - -function TBSystem_atom_orbital_sum_real1(this,a) - type(TBSystem), intent(in) :: this - real(dp), intent(in) :: a(:) - real(dp) :: TBSystem_atom_orbital_sum_real1(this%N_atoms) - - integer i - - if (size(a) /= this%N) then - call system_abort("Called TBSystem_atom_orbital_sum_real1 with wrong size array") - endif - - do i=1, this%N_atoms - TBSystem_atom_orbital_sum_real1(i) = sum(a(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1)) - end do -end function TBSystem_atom_orbital_sum_real1 - -function TBSystem_atom_orbital_sum_complex2(this,a) - type(TBSystem), intent(in) :: this - complex(dp), intent(in) :: a(:,:) - complex(dp) :: TBSystem_atom_orbital_sum_complex2(this%N_atoms, size(a,2)) - - integer i - - if (size(a,1) /= this%N) then - call system_abort("Called TBSystem_atom_orbital_sum_complex2 with wrong size array") - endif - - do i=1, this%N_atoms - TBSystem_atom_orbital_sum_complex2(i,:) = sum(a(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1,:),1) - end do -end function TBSystem_atom_orbital_sum_complex2 - -function TBSystem_atom_orbital_spread_real1(this,a) - type(TBSystem), intent(in) :: this - real(dp), intent(in) :: a(:) - real(dp) :: TBSystem_atom_orbital_spread_real1(this%N) - - integer i - - if (size(a) /= this%N_atoms) then - call system_abort("Called TBSystem_atom_orbital_spread_real1 with wrong size array a " // & - size(a) // " this%N_atoms " // this%N_atoms) - endif - - do i=1, this%N_atoms - TBSystem_atom_orbital_spread_real1(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1) = a(i) - end do -end function TBSystem_atom_orbital_spread_real1 - -subroutine TBSystem_atom_orbital_sum_mat_r(this,a, out) - type(TBSystem), intent(in) :: this - real(dp), intent(in) :: a(:,:) - real(dp), intent(out) :: out(:,:) - - integer i, j - - if (size(a,1) /= this%N .or. size(a,2) /= this%N) then - call system_abort("Called TBSystem_atom_orbital_sum_mat_r with wrong size input") - endif - if (size(out,1) /= this%N_atoms .or. size(out,2) /= this%N_atoms) then - call system_abort("Called TBSystem_atom_orbital_sum_mat_r with wrong size output") - endif - - do j=1, this%N_atoms - do i=1, this%N_atoms - out(i,j) = sum(a(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1, & - this%first_orb_of_atom(j):this%first_orb_of_atom(j+1)-1)) - end do - end do -end subroutine TBSystem_atom_orbital_sum_mat_r - -subroutine TBSystem_atom_orbital_spread_mat_r(this,a, out) - type(TBSystem), intent(in) :: this - real(dp), intent(in) :: a(:,:) - real(dp), intent(out) :: out(:,:) - - integer i, j - - if (size(a,1) /= this%N_atoms .or. size(a,2) /= this%N_atoms) then - call system_abort("Called TBSystem_atom_orbital_spread_mat_r with wrong size input") - endif - if (size(out,1) /= this%N .or. size(out,2) /= this%N) then - call system_abort("Called TBSystem_atom_orbital_spread_mat_r with wrong size output") - endif - - do j=1, this%N_atoms - do i=1, this%N_atoms - out(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1, & - this%first_orb_of_atom(j):this%first_orb_of_atom(j+1)-1) = a(i,j) - end do - end do -end subroutine TBSystem_atom_orbital_spread_mat_r - -function TBSystem_manifold_orbital_sum_real2(this,a) - type(TBSystem), intent(in) :: this - real(dp), intent(in) :: a(:,:) - real(dp) :: TBSystem_manifold_orbital_sum_real2(size(a,1),this%N_manifolds) - - integer i - - if (size(a,2) /= this%N) then - call system_abort("Called TBSystem_manifold_orbital_sum_real2 with wrong size array shape(a) " // shape(a) // " this%N " // (this%N)) - endif - - do i=1, this%N_manifolds - TBSystem_manifold_orbital_sum_real2(:,i) = sum(a(:,this%first_orb_of_manifold(i):this%first_orb_of_manifold(i+1)-1),2) - end do -end function TBSystem_manifold_orbital_sum_real2 - -subroutine TBSystem_Print(this,file) - type(TBSystem), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - if (current_verbosity() < PRINT_NORMAL) return - - call Print ('TBSystem : N N_atoms ' // this%N // " " // this%N_atoms, file=file) - - call Print (this%tbmodel, file=file) - - if (this%kpoints%non_gamma) then - call Print (this%kpoints, file=file) - endif - if (this%scf%active) then - call Print (this%scf, file=file) - endif - if (this%dipole_model%active) then - call Print (this%dipole_model, file=file) - endif - - if (this%SO%active) then - call Print (this%SO, file=file) - endif - - if (this%N > 0) then - call verbosity_push_decrement(PRINT_NERD) - call Print("first_orb_of_atom", file=file) - call Print(this%first_orb_of_atom, file=file) - - call Print("first_manifold_of_atom", file=file) - call Print(this%first_manifold_of_atom, file=file) - - call Print("first_orb_of_manifold", file=file) - call Print(this%first_orb_of_manifold, file=file) - - call print("H", file=file) - call Print (this%H, file=file) - call print("S", file=file) - call Print (this%S, file=file) - call verbosity_pop() - endif - -end subroutine TBSystem_Print - -subroutine TBSystem_copy_matrices(this, Hd, Sd, Hz, Sz, index) - type(TBSystem), intent(in) :: this - real(dp), intent(inout), optional, dimension(:,:) :: Hd, Sd - complex(dp), intent(inout), optional, dimension(:,:) :: Hz, Sz - integer, intent(in), optional :: index - - if (present(Hd)) call copy(this%H, Hd, index=index) - if (present(Hz)) call copy(this%H, Hz, index=index) - if (present(Sd)) call copy(this%S, Sd, index=index) - if (present(Sz)) call copy(this%S, Sz, index=index) -end subroutine TBSystem_copy_matrices - -subroutine Self_Consistency_Initialise_str(this, args_str, param_str) - type(Self_Consistency), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - call Finalise(this) - - call read_params_xml(this, param_str) - - call set_type(this, args_str) - -end subroutine Self_Consistency_Initialise_str - -subroutine TB_Dipole_Model_Initialise_str(this, args_str, param_str) - type(TB_Dipole_Model), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - call Finalise(this) - - call read_params_xml(this, param_str) - -end subroutine TB_Dipole_Model_Initialise_str - -subroutine TB_Spin_Orbit_Coupling_Initialise_str(this, args_str, param_str) - type(TB_Spin_Orbit_Coupling), intent(inout) :: this - character(len=*), intent(in) :: args_str, param_str - - type(Dictionary) :: params - - call Finalise(this) - - call read_params_xml(this, param_str) - - call initialise(params) - call param_register(params, 'spin_orbit_coupling', 'F', this%active, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TB_Spin_Orbit_Coupling_Initialise_str args_str')) then - call system_abort("TB_Spin_Orbit_Coupling_Initialise_str failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - -end subroutine TB_Spin_Orbit_Coupling_Initialise_str - -subroutine Self_Consistency_set_type_str(this, args_str) - type(Self_Consistency), intent(inout) :: this - character(len=*), intent(in) :: args_str - - type(Dictionary) :: params - real(dp) :: global_U - logical :: is_SCF(8) - integer :: i, i_term, N_terms - - call initialise(params) - - call param_register(params, 'SCF_LOCAL_U', 'F', is_SCF(SCF_LOCAL_U), help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_NONLOCAL_U_DFTB', 'F', is_SCF(SCF_NONLOCAL_U_DFTB), help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_NONLOCAL_U_NRL_TB', 'F', is_SCF(SCF_NONLOCAL_U_NRL_TB), help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_GLOBAL_U', 'F', is_SCF(SCF_GLOBAL_U), help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_LCN', 'F', is_SCF(SCF_LCN), help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_GCN', 'F', is_SCF(SCF_GCN), help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_SPIN_DIR', 'F', is_SCF(SCF_SPIN_DIR), help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_SPIN_STONER', 'F', is_SCF(SCF_SPIN_STONER), help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'GLOBAL_U', '-1.0', global_U, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_ALPHA', ''//this%alpha, this%alpha, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_W0', ''//this%w0, this%w0, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_MAX_ITER', ''//this%max_iter, this%max_iter, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_MIX_SIMPLE', ''//this%mix_simple, this%mix_simple, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_CONV_TOL', ''//this%conv_tol, this%conv_tol, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_MIX_SIMPLE_END_TOL', ''//this%mix_simple_end_tol, this%mix_simple_end_tol, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'SCF_MIX_SIMPLE_START_TOL', ''//this%mix_simple_start_tol, this%mix_simple_start_tol, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Self_Consistency_set_type_str args_str')) then - call system_abort("Self_Consistency_Initialise_str failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - - if (count(is_SCF) == 0) return - - if (is_SCF(SCF_LCN) .or. is_SCF(SCF_GCN)) then - if (count(is_SCF) /= 1) & - call system_abort("Self_Consistency_set_type_str got SCF_LCN or SCF_GCN, but also some other sort of SCF") - endif - - this%active = .true. - - N_terms = count(is_SCF) - if (allocated(this%terms)) then - do i_term=1, size(this%terms) - call Finalise(this%terms(i_term)) - end do - deallocate(this%terms) - endif - allocate(this%terms(N_terms)) - i_term = 0 - do i=1, size(is_SCF) - if (is_SCF(i)) then - i_term = i_term + 1 - this%terms(i_term)%type = i - this%terms(i_term)%active = .true. - end if - end do - -end subroutine Self_Consistency_set_type_str - -subroutine Self_Consistency_Finalise(this) - type(Self_Consistency), intent(inout) :: this - - integer :: i_term - - call Wipe(this) - - if (allocated(this%U)) deallocate(this%U) - if (allocated(this%stoner_param)) deallocate(this%stoner_param) - - if (allocated(this%terms)) then - do i_term=1, size(this%terms) - call Finalise(this%terms(i_term)) - end do - deallocate(this%terms) - end if - - this%active = .false. - -end subroutine Self_Consistency_Finalise - -subroutine Self_Consistency_Term_Finalise(this) - type(Self_Consistency_Term), intent(inout) :: this - - call wipe(this) - - this%type = SCF_NONE - this%N = 0 - this%N_atoms = 0 - this%N_manifolds = 0 - - this%global_U = 0.0_dp - - this%active = .false. - -end subroutine Self_Consistency_Term_Finalise - -subroutine Self_Consistency_Wipe(this) - type(Self_Consistency), intent(inout) :: this - - integer :: i_term - - if (allocated(this%orb_local_pot)) deallocate(this%orb_local_pot) - if (allocated(this%orb_exch_field)) deallocate(this%orb_exch_field) - - if (allocated(this%terms)) then - do i_term=1, size(this%terms) - call Wipe(this%terms(i_term)) - end do - end if - - this%N = 0 - this%N_atoms = 0 - this%N_manifolds = 0 -end subroutine Self_Consistency_Wipe - -subroutine Self_Consistency_Term_Wipe(this) - type(Self_Consistency_Term), intent(inout) :: this - - this%N = 0 - this%N_atoms = 0 - this%N_manifolds = 0 - this%n_dof = 0 - - this%global_N = 0.0 - this%global_pot = 0.0 - - if (allocated(this%U)) deallocate(this%U) - if (allocated(this%spin_splitting)) deallocate(this%spin_splitting) - if (allocated(this%stoner_param)) deallocate(this%stoner_param) - if (allocated(this%atomic_n)) deallocate(this%atomic_n) - if (allocated(this%atomic_n0)) deallocate(this%atomic_n0) - if (allocated(this%manifold_mom)) deallocate(this%manifold_mom) - if (allocated(this%atomic_local_pot)) deallocate(this%atomic_local_pot) - if (allocated(this%datomic_local_pot_dr)) deallocate(this%datomic_local_pot_dr) - if (allocated(this%gamma)) deallocate(this%gamma) - if (allocated(this%dgamma_dr)) deallocate(this%dgamma_dr) - -end subroutine Self_Consistency_Term_Wipe - -subroutine TB_Dipole_Model_Finalise(this) - type(TB_Dipole_Model), intent(inout) :: this - - this%n_types = 0 - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) - if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) - if (allocated(this%orb_set_phase)) deallocate(this%orb_set_phase) - if (allocated(this%gaussian_width)) deallocate(this%gaussian_width) - - this%active = .false. - -end subroutine TB_Dipole_Model_Finalise - -subroutine TB_Spin_Orbit_Coupling_Finalise(this) - type(TB_Spin_Orbit_Coupling), intent(inout) :: this - - this%n_types = 0 - if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) - if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) - if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) - if (allocated(this%SO_param)) deallocate(this%SO_param) - - this%active = .false. - -end subroutine TB_Spin_Orbit_Coupling_Finalise - -subroutine TBSystem_scf_set_atomic_n_mom(this, atomic_n, atomic_mom, atomic_pot) - type(TBSystem), intent(inout) :: this - real(dp), intent(in), pointer :: atomic_n(:), atomic_mom(:,:), atomic_pot(:) - - integer :: i_term, i_at, i_man - - do i_term=1, size(this%scf%terms) - if (allocated(this%scf%terms(i_term)%atomic_n)) then - if (associated(atomic_n)) then - this%scf%terms(i_term)%atomic_n = atomic_n - else - this%scf%terms(i_term)%atomic_n = this%scf%terms(i_term)%atomic_n0 - endif - end if - if (allocated(this%scf%terms(i_term)%manifold_mom)) then - if (associated(atomic_mom)) then - this%scf%terms(i_term)%manifold_mom = 0.0_dp - do i_at=1, this%N_atoms - do i_man = this%first_manifold_of_atom(i_at), this%first_manifold_of_atom(i_at+1)-1 - if (i_man == this%first_manifold_of_atom(i_at+1)-1) then - this%scf%terms(i_term)%manifold_mom(:,i_man) = atomic_mom(:,i_at) - else - this%scf%terms(i_term)%manifold_mom(:,i_man) = 1.0e-6_dp*atomic_mom(:,i_at) - endif - end do - end do - else - this%scf%terms(i_term)%manifold_mom = 0.0_dp - endif - end if ! manifold_mom is allocated - if (allocated(this%scf%terms(i_term)%atomic_local_pot)) then - if (associated(atomic_pot)) then - this%scf%terms(i_term)%atomic_local_pot = atomic_pot - else - this%scf%terms(i_term)%atomic_local_pot = 0.0_dp - endif - end if - end do ! atomic_local_pot is allocated -end subroutine TBSystem_scf_set_atomic_n_mom - -subroutine TBSystem_scf_set_global_N(this, global_at_weight, global_N) - type(TBSystem), intent(inout) :: this - real(dp), intent(in), pointer :: global_at_weight(:) - real(dp), intent(in), optional :: global_N - - integer i_term - - ! if global weight isn't associated, we can't set global_N. - ! If it's actually needed by some SCF terms, they'll complain - if (.not. associated(global_at_weight)) return - - do i_term=1, size(this%scf%terms) - if (present(global_N)) then - this%scf%terms(i_term)%global_N = global_N - else - this%scf%terms(i_term)%global_N = sum(this%scf%terms(i_term)%atomic_n0*global_at_weight) - endif - end do -end subroutine TBSystem_scf_set_global_N - -subroutine TBSystem_scf_get_atomic_n_mom(this, atomic_n, atomic_mom, atomic_pot) - type(TBSystem), intent(inout) :: this - real(dp), intent(out), pointer :: atomic_n(:), atomic_mom(:,:), atomic_pot(:) - - integer i_term, i_at, i_man - logical got_atomic_n, got_manifold_mom, got_atomic_pot - - if (associated(atomic_n)) then - atomic_n = 0.0_dp - got_atomic_n = .false. - do i_term=1, size(this%scf%terms) - if (allocated(this%scf%terms(i_term)%atomic_n)) then - if (got_atomic_n) & - call system_abort("TBSystem_scf_get_atomic_n_mom found atomic_n allocated in more than 1 term") - atomic_n = this%scf%terms(i_term)%atomic_n - got_atomic_n = .true. - end if - end do - - if (.not. got_atomic_n) & - call print("WARNING: TBSystem_scf_get_atomic_n_mom was passed atomic_n but didn't find " // & - "atomic_n allocated in any terms", PRINT_ALWAYS) - end if - - if (associated(atomic_mom)) then - got_manifold_mom = .false. - do i_term=1, size(this%scf%terms) - if (allocated(this%scf%terms(i_term)%manifold_mom)) then - if (got_manifold_mom) & - call system_abort("TBSystem_scf_get_atomic_n_mom found manifold_mom allocated in more than 1 term") - do i_at=1, this%N_atoms - i_man = this%first_manifold_of_atom(i_at+1)-1 - atomic_mom(:,i_at) = this%scf%terms(i_term)%manifold_mom(:,i_man) - end do - got_manifold_mom = .true. - end if - end do - - if (.not. got_manifold_mom) & - call print("WARNING: TBSystem_scf_get_atomic_n_mom was passed atomic_mom but didn't find " // & - "manifold_mom allocated in any terms", PRINT_ALWAYS) - end if - - if (associated(atomic_pot)) then - atomic_pot = 0.0_dp - got_atomic_pot = .false. - do i_term=1, size(this%scf%terms) - if (allocated(this%scf%terms(i_term)%atomic_local_pot)) then - if (got_atomic_pot) & - call system_abort("TBSystem_scf_get_atomic_n_mom found atomic_pot allocated in more than 1 term") - atomic_pot = this%scf%terms(i_term)%atomic_local_pot - got_atomic_pot = .true. - end if - end do - - if (.not. got_atomic_pot) & - call print("WARNING: TBSystem_scf_get_atomic_n_mom was passed atomic_pot but didn't find " // & - "atomic_pot allocated in any terms", PRINT_ALWAYS) - end if - -end subroutine TBSystem_scf_get_atomic_n_mom - -subroutine TBSystem_scf_get_global_N(this, global_N) - type(TBSystem), intent(inout) :: this - real(dp), intent(out) :: global_N - - integer i_term - logical got_global_N - - got_global_N = .false. - do i_term=1, size(this%scf%terms) - if (this%scf%terms(i_term)%global_U > 0.0_dp) then - if (got_global_N) & - call system_abort("TBSystem_scf_get_global_N found global_N allocated in more than 1 term") - global_N = this%scf%terms(i_term)%global_N - got_global_N = .true. - endif - end do - - if (.not. got_global_N) & - call system_abort("TBSystem_scf_get_global_N didn't find global_N allocated in any terms") -end subroutine TBSystem_scf_get_global_N - -subroutine SC_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_self_consistency) then - if (name == "self_consistency") then - parse_in_self_consistency = .false. - endif - endif -end subroutine SC_endElement_handler - -subroutine SC_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - integer :: max_stoner_manifolds, n_stoner_params - integer :: atnum - - if (name == "self_consistency") then - parse_in_self_consistency = .true. - - call QUIP_FoX_get_value(attributes, 'tolerance', value, status) - if (status /= 0) then - call print("Can't find tolerance in self_consistency", PRINT_ALWAYS) - else - read (value, *) parse_self_consistency%conv_tol - endif - - call QUIP_FoX_get_value(attributes, 'global_U', value, status) - if (status == 0) read (value, *) parse_self_consistency%global_U - - if (allocated(parse_self_consistency%U)) deallocate(parse_self_consistency%U) - allocate(parse_self_consistency%U(size(ElementName))) - parse_self_consistency%U = 0.0_dp - - call QUIP_FoX_get_value(attributes, 'max_stoner_manifolds', value, status) - if (status == 0) then - read (value, *) max_stoner_manifolds - if (allocated(parse_self_consistency%stoner_param)) deallocate(parse_self_consistency%stoner_param) - allocate(parse_self_consistency%stoner_param(max_stoner_manifolds,size(ElementName))) - parse_self_consistency%stoner_param = 0.0_dp - endif - - else if (parse_in_self_consistency .and. name == "U") then - - call QUIP_FoX_get_value(attributes, 'Z', value, status) - if (status /= 0) call system_abort('Self_Consistency_read_params_xml cannot find Z attribute in U') - read (value, *) atnum - - if (atnum <= 0 .or. atnum > size(parse_self_consistency%U)) & - call system_abort ("SC parse xml atnum " // atnum // " out of range " // 1 // " " // size(parse_self_consistency%U)) - call QUIP_FoX_get_value(attributes, 'U', value, status) - if (status /= 0) call system_abort('Self_Consistency_read_params_xml cannot find U attribute') - read (value, *) parse_self_consistency%U(atnum) - - else if (parse_in_self_consistency .and. name == "stoner_params") then - - call QUIP_FoX_get_value(attributes, 'Z', value, status) - if (status /= 0) call system_abort('Self_Consistency_read_params_xml cannot find Z attribute in stoner_params') - read (value, *) atnum - - call QUIP_FoX_get_value(attributes, 'n_stoner_params', value, status) - if (status == 0) then - read (value, *) n_stoner_params - if (n_stoner_params > 0) then - call QUIP_FoX_get_value(attributes, 'stoner_params', value, status) - if (status /= 0) & - call system_abort("parse self consistency got n_stoner_params " // n_stoner_params // " for Z=" // atnum // " but can't find actual stoner_params") - read (value, *) parse_self_consistency%stoner_param(1:n_stoner_params,atnum) - end if - end if - endif - -end subroutine SC_startElement_handler - -subroutine Self_Consistency_read_params_xml(this, in) - type(Self_Consistency), intent(inout), target :: this - character(len=*) :: in - - type(xml_t) :: fxml - - if (len(trim(in)) <= 0) then - return - endif - - parse_in_self_consistency = .false. - parse_self_consistency => this - - call open_xml_string(fxml, in) - - call parse(fxml, & - startElement_handler = SC_startElement_handler, & - endElement_handler = SC_endElement_handler) - - call close_xml_t(fxml) - -end subroutine Self_Consistency_read_params_xml - -subroutine DM_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_dipole_model) then - if (name == "dipole_model") then - parse_in_dipole_model = .false. - endif - endif -end subroutine DM_endElement_handler - -subroutine DM_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - integer :: atnum, i_type, new_n_orb_sets, i - character(len=1), allocatable :: orb_set_types_str(:) - - if (name == "dipole_model") then - parse_in_dipole_model = .true. - - parse_dipole_model%n_types = 0 - - if (allocated(parse_dipole_model%type_of_atomic_num)) deallocate(parse_dipole_model%type_of_atomic_num) - allocate(parse_dipole_model%type_of_atomic_num(size(ElementName))) - parse_dipole_model%type_of_atomic_num = 0 - - else if (parse_in_dipole_model .and. name == "element") then - parse_dipole_model%active = .true. - i_type = parse_dipole_model%n_types + 1 - - call QUIP_FoX_get_value(attributes, 'Z', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find Z attribute in type ' // status) - read (value, *) atnum - if (atnum <= 0 .or. atnum > size(parse_dipole_model%type_of_atomic_num)) & - call system_abort ("DM parse xml atnum " // atnum // " out of range " // 1 // " " // size(parse_dipole_model%type_of_atomic_num)) - - parse_dipole_model%type_of_atomic_num(atnum) = i_type - - call QUIP_FoX_get_value(attributes, 'n_orb_sets', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find n_orb_sets attribute ' // status) - read (value, *) new_n_orb_sets - - call realloc_dipole_model(parse_dipole_model, i_type, new_n_orb_sets) - - parse_dipole_model%atomic_num(i_type) = atnum - parse_dipole_model%n_orb_sets(i_type) = new_n_orb_sets - - allocate(orb_set_types_str(parse_dipole_model%n_orb_sets(i_type))) - call QUIP_FoX_get_value(attributes, 'orb_set_types', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find orb_set_types attribute ' // status) - read (value, *) orb_set_types_str - do i=1, parse_dipole_model%n_orb_sets(i_type) - if (orb_set_types_str(i) == 's' .or. orb_set_types_str(i) == 'S') then - parse_dipole_model%orb_set_type(i,i_type) = ORB_S - else if (orb_set_types_str(i) == 'p' .or. orb_set_types_str(i) == 'P') then - parse_dipole_model%orb_set_type(i,i_type) = ORB_P - else if (orb_set_types_str(i) == 'd' .or. orb_set_types_str(i) == 'D') then - parse_dipole_model%orb_set_type(i,i_type) = ORB_D - endif - end do - - call QUIP_FoX_get_value(attributes, 'gaussian_widths', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find gaussian_widths attribute ' // status) - read (value, *) parse_dipole_model%gaussian_width(1:parse_dipole_model%n_orb_sets(i_type),i_type) - - call QUIP_FoX_get_value(attributes, 'orb_set_phases', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find orb_set_phase attribute ' // status) - read (value, *) parse_dipole_model%orb_set_phase(1:parse_dipole_model%n_orb_sets(i_type),i_type) - - endif - -end subroutine DM_startElement_handler - -subroutine SO_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_spin_orbit_coupling) then - if (name == "spin_orbit_coupling") then - parse_in_spin_orbit_coupling = .false. - endif - endif -end subroutine SO_endElement_handler - -subroutine SO_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer :: status - character(len=1024) :: value - integer :: atnum, i_type, new_n_orb_sets, i - character(len=1), allocatable :: orb_set_types_str(:) - - if (name == "spin_orbit_coupling") then - parse_in_spin_orbit_coupling = .true. - - parse_spin_orbit_coupling%n_types = 0 - - if (allocated(parse_spin_orbit_coupling%type_of_atomic_num)) deallocate(parse_spin_orbit_coupling%type_of_atomic_num) - allocate(parse_spin_orbit_coupling%type_of_atomic_num(size(ElementName))) - parse_spin_orbit_coupling%type_of_atomic_num = 0 - - else if (parse_in_spin_orbit_coupling .and. name == "element") then - parse_spin_orbit_coupling%active = .true. - i_type = parse_spin_orbit_coupling%n_types + 1 - - call QUIP_FoX_get_value(attributes, 'Z', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find Z attribute in type ' // status) - read (value, *) atnum - if (atnum <= 0 .or. atnum > size(parse_spin_orbit_coupling%type_of_atomic_num)) & - call system_abort ("SO parse xml atnum " // atnum // " out of range " // 1 // " " // size(parse_spin_orbit_coupling%type_of_atomic_num)) - - parse_spin_orbit_coupling%type_of_atomic_num(atnum) = i_type - - call QUIP_FoX_get_value(attributes, 'n_orb_sets', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find n_orb_sets attribute ' // status) - read (value, *) new_n_orb_sets - - call realloc_spin_orbit_coupling(parse_spin_orbit_coupling, i_type, new_n_orb_sets) - - parse_spin_orbit_coupling%atomic_num(i_type) = atnum - parse_spin_orbit_coupling%n_orb_sets(i_type) = new_n_orb_sets - - allocate(orb_set_types_str(parse_spin_orbit_coupling%n_orb_sets(i_type))) - call QUIP_FoX_get_value(attributes, 'orb_set_types', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find orb_set_types attribute ' // status) - read (value, *) orb_set_types_str - do i=1, parse_spin_orbit_coupling%n_orb_sets(i_type) - if (orb_set_types_str(i) == 's' .or. orb_set_types_str(i) == 'S') then - parse_spin_orbit_coupling%orb_set_type(i,i_type) = ORB_S - else if (orb_set_types_str(i) == 'p' .or. orb_set_types_str(i) == 'P') then - parse_spin_orbit_coupling%orb_set_type(i,i_type) = ORB_P - else if (orb_set_types_str(i) == 'd' .or. orb_set_types_str(i) == 'D') then - parse_spin_orbit_coupling%orb_set_type(i,i_type) = ORB_D - endif - end do - - call QUIP_FoX_get_value(attributes, 'SO_params', value, status) - if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find SO_params attribute ' // status) - read (value, *) parse_spin_orbit_coupling%SO_param(1:parse_spin_orbit_coupling%n_orb_sets(i_type),i_type) - - endif - -end subroutine SO_startElement_handler - -subroutine TB_Dipole_Model_read_params_xml(this, in) - type(TB_Dipole_Model), intent(inout), target :: this - character(len=*) :: in - - type(xml_t) :: fxml - - if (len(trim(in)) <= 0) then - return - endif - - parse_in_dipole_model = .false. - parse_dipole_model => this - - call open_xml_string(fxml, in) - - call parse(fxml, & - startElement_handler = DM_startElement_handler, & - endElement_handler = DM_endElement_handler) - - call close_xml_t(fxml) - -end subroutine - -subroutine TB_Spin_Orbit_Coupling_read_params_xml(this, in) - type(TB_Spin_Orbit_Coupling), intent(inout), target :: this - character(len=*) :: in - - type(xml_t) :: fxml - - if (len(trim(in)) <= 0) then - return - endif - - parse_in_spin_orbit_coupling = .false. - parse_spin_orbit_coupling => this - - call open_xml_string(fxml, in) - - call parse(fxml, & - startElement_handler = SO_startElement_handler, & - endElement_handler = SO_endElement_handler) - - call close_xml_t(fxml) - -end subroutine - -subroutine Self_Consistency_setup_system(this, N, tbm, at_N, at_Z, N_manifolds) - type(Self_Consistency), intent(inout) :: this - integer, intent(in) :: N - type(TBModel), intent(in) :: tbm - integer, intent(in) :: at_N, at_Z(:), N_manifolds - - integer :: i_term - - call wipe(this) - - - this%N = N - this%N_atoms = at_N - this%N_manifolds = N_manifolds - - allocate(this%orb_local_pot(this%N)) - if (allocated(this%terms)) then - do i_term=1, size(this%terms) - if (this%terms(i_term)%type == SCF_SPIN_DIR .or. this%terms(i_term)%type == SCF_SPIN_STONER) then - allocate(this%orb_exch_field(3,this%N)) - exit - endif - end do - - do i_term=1, size(this%terms) - call setup_system(this%terms(i_term), this%N, tbm, at_N, at_Z, this%global_U, this%N_manifolds) - end do - end if - -end subroutine Self_Consistency_setup_system - -subroutine Self_Consistency_Term_setup_system(this, N, tbm, at_N, at_Z, global_U, N_manifolds) - type(Self_Consistency_Term), intent(inout) :: this - integer, intent(in) :: N - type(TBModel), intent(in) :: tbm - integer, intent(in) :: at_N, at_Z(:) - real(dp), intent(in) :: global_U - integer, intent(in) :: N_manifolds - - integer :: i - - if (allocated(this%U)) deallocate(this%U) - if (allocated(this%stoner_param)) deallocate(this%stoner_param) - if (allocated(this%spin_splitting)) deallocate(this%spin_splitting) - if (allocated(this%atomic_n)) deallocate(this%atomic_n) - if (allocated(this%atomic_n0)) deallocate(this%atomic_n0) - if (allocated(this%manifold_mom)) deallocate(this%manifold_mom) - if (allocated(this%atomic_local_pot)) deallocate(this%atomic_local_pot) - if (allocated(this%gamma)) deallocate(this%gamma) - if (allocated(this%dgamma_dr)) deallocate(this%dgamma_dr) - - if (.not. this%active) return - - this%N = N - this%N_atoms = at_N - this%N_manifolds = N_manifolds - select case (this%type) - case(SCF_NONE) - this%n_dof = 0 - return - case(SCF_GCN) - this%n_dof = 1 - allocate(this%atomic_n0(this%N_atoms)) - do i=1, at_N - this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) - end do - this%global_pot = 0.0_dp - return - case(SCF_GLOBAL_U) - this%n_dof = 1 - this%global_U = global_U - allocate(this%atomic_n0(this%N_atoms)) - do i=1, at_N - this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) - end do - return - case(SCF_LCN) - this%n_dof = this%N_atoms - allocate(this%atomic_n0(this%N_atoms)) - do i=1, at_N - this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) - end do - allocate(this%atomic_n(this%N_atoms)) - allocate(this%atomic_local_pot(this%N_atoms)) - this%atomic_local_pot = 0.0_dp - return - case(SCF_LOCAL_U) - this%n_dof = this%N_atoms - allocate(this%U(this%N_atoms)) - this%U = 0.0_dp - allocate(this%atomic_n(this%N_atoms)) - allocate(this%atomic_n0(this%N_atoms)) - do i=1, at_N - this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) - end do - return - case(SCF_NONLOCAL_U_DFTB) - this%n_dof = this%N_atoms - allocate(this%gamma(this%N_atoms,this%N_atoms)) - this%gamma = 0.0_dp - allocate(this%atomic_n(this%N_atoms)) - allocate(this%atomic_n0(this%N_atoms)) - do i=1, at_N - this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) - end do - case(SCF_NONLOCAL_U_NRL_TB) - this%n_dof = this%N_atoms - allocate(this%gamma(this%N_atoms,this%N_atoms)) - this%gamma = 0.0_dp - allocate(this%atomic_n(this%N_atoms)) - allocate(this%atomic_n0(this%N_atoms)) - do i=1, at_N - this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) - end do - return - case(SCF_SPIN_DIR) - this%n_dof = 3*this%N_manifolds - allocate(this%manifold_mom(3,this%N_manifolds)) - allocate(this%spin_splitting(this%N_manifolds)) - this%spin_splitting = 0.0_dp - return - case(SCF_SPIN_STONER) - this%n_dof = 3*this%N_manifolds - allocate(this%manifold_mom(3,this%N_manifolds)) - allocate(this%stoner_param(this%N_manifolds)) - this%stoner_param = 0.0_dp - return - case default - call system_abort("Self_Consistency_Term_setup_system confused by this%type="//this%type) - end select - -end subroutine Self_Consistency_Term_setup_system - -subroutine TB_Dipole_Model_Print(this,file) - type(TB_Dipole_Model), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer :: i_type, i_orb_set - - if (current_verbosity() < PRINT_NORMAL) return - - call Print('TB_Dipole_Model : active='//this%active, file=file) - call Print('TB_Dipole_Model : n_types='//this%n_types, file=file) - do i_type = 1, this%n_types - call print('TB_Dipole_Model : type ' // i_type // ' atomic_num ' // this%atomic_num(i_type) // & - ' n_orb_sets ' // this%n_orb_sets(i_type), file=file) - do i_orb_set = 1, this%n_orb_sets(i_type) - call print('TB_Dipole_model: i_orb_set ' // i_orb_set // ' orb_type ' // this%orb_set_type(i_orb_set,i_type) // & - ' width ' // this%gaussian_width(i_orb_set, i_type) // ' phase ' // this%orb_set_phase(i_orb_set, i_type), file=file) - end do - end do - -end subroutine TB_Dipole_Model_Print - -subroutine TB_Spin_Orbit_Coupling_Print(this,file) - type(TB_Spin_Orbit_Coupling), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer :: i_type, i_orb_set - - if (current_verbosity() < PRINT_NORMAL) return - - call Print('TB_Spin_Orbit_Coupling : active='//this%active, file=file) - call Print('TB_Spin_Orbit_Coupling : n_types='//this%n_types, file=file) - do i_type = 1, this%n_types - call print('TB_Spin_Orbit_Coupling : type ' // i_type // ' atomic_num ' // this%atomic_num(i_type) // & - ' n_orb_sets ' // this%n_orb_sets(i_type), file=file) - do i_orb_set = 1, this%n_orb_sets(i_type) - call print('TB_Spin_Orbit_Coupling: i_orb_set ' // i_orb_set // ' orb_type ' // this%orb_set_type(i_orb_set,i_type) // & - ' SO_param ' // this%SO_param(i_orb_set, i_type), file=file) - end do - end do - -end subroutine TB_Spin_Orbit_Coupling_Print - -subroutine Self_Consistency_Print(this,file) - type(Self_Consistency), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer::i - - if (current_verbosity() < PRINT_NORMAL) return - - call Print('Self_Consistency : active='//this%active, file=file) - - call Print("Self_Consistency : global_U " // this%global_U, file=file) - - call Print("Self_Consistency : allocated(this%U) " // allocated(this%U), file=file) - if (allocated(this%U)) then - call Print("Self_Consistency : size(this%U) " // size(this%U), file=file) - do i=1, size(this%U) - if (this%U(i) /= 0.0_dp) then - call Print('Self_Consistency : U ' // i // " " // this%U(i), file=file) - endif - end do - else - call Print("Self_Consistency : size(this%U) 0", file=file) - endif - if (allocated(this%stoner_param)) then - call Print("Self_Consistency : size(this%stoner_param) " // size(this%stoner_param), file=file) - do i=1, size(this%stoner_param,2) - if (maxval(this%stoner_param(:,i)) /= 0.0_dp) then - call Print('Self_Consistency : stoner_param ' // i // " " // this%stoner_param(:,i), file=file) - endif - end do - else - call Print("Self_Consistency : size(this%stoner_param) 0", file=file) - endif - - if (allocated(this%terms)) then - do i=1, size(this%terms) - call Print('Self_Consistency : term ' // i, file=file) - call Print(this%terms(i),file=file) - end do - end if - - call verbosity_push_decrement() - - if (allocated(this%orb_local_pot)) then - call Print('Self_Consistency : orb_local_pot ', file=file) - call Print(this%orb_local_pot, file=file) - endif - - if (allocated(this%orb_exch_field)) then - call Print('Self_Consistency : orb_exch_field ', file=file) - call Print(this%orb_exch_field, file=file) - endif - - call verbosity_pop() - -end subroutine Self_Consistency_Print - -subroutine Self_Consistency_Term_Print(this, file) - type(Self_Consistency_Term), intent(in) :: this - type(Inoutput), intent(inout), optional :: file - - integer :: i - - if (current_verbosity() < PRINT_NORMAL) return - - if (.not. this%active) return - - call Print('Self_Consistency_Term type : ' // scf_names(this%type), file=file) - - call Print('Self_Consistency_Term n_dof : ' // this%n_dof, file=file) - - if (this%type == SCF_GLOBAL_U) & - call Print('Self_Consistency_Term global_U ' // this%global_U // ' global_N ' // this%global_N, file=file) - - if (this%type == SCF_GCN) & - call Print('Self_Consistency_Term global_pot ' // this%global_pot // ' global_N ' // this%global_N, file=file) - - if (allocated(this%atomic_n)) then - call Print('Self_Consistency_Term : atomic_n ', file=file) - call Print(this%atomic_n, file=file) - endif - - if (allocated(this%manifold_mom)) then - call Print('Self_Consistency_Term : manifold_mom ', file=file) - do i=1, size(this%manifold_mom,2) - call Print(i // " " // this%manifold_mom(:,i) // " mag " // norm(this%manifold_mom(:,i)), file=file) - end do - endif - - call verbosity_push_decrement() - - if (allocated(this%U)) then - call Print('Self_Consistency_Term : U ', file=file) - call Print(this%U, file=file) - endif - - if (allocated(this%spin_splitting)) then - call Print('Self_Consistency_Term : spin_splitting ', file=file) - call Print(this%spin_splitting, file=file) - endif - - if (allocated(this%stoner_param)) then - call Print('Self_Consistency_Term : stoner_param ', file=file) - call Print(this%stoner_param, file=file) - endif - - if (allocated(this%atomic_n0)) then - call Print('Self_Consistency_Term : atomic_n0 ', file=file) - call Print(this%atomic_n0, file=file) - endif - - if (allocated(this%atomic_local_pot)) then - call Print('Self_Consistency_Term : atomic_local_pot ', file=file) - call Print(this%atomic_local_pot, file=file) - endif - - call verbosity_push_decrement() - - if (allocated(this%gamma)) then - call Print('Self_Consistency : gamma ', file=file) - call Print(this%gamma, file=file) - endif - if (allocated(this%dgamma_dr)) then - call Print('Self_Consistency : dgamma_dr(:,:,1) ', file=file) - call Print(this%dgamma_dr(:,:,1), file=file) - call Print('Self_Consistency : dgamma_dr(:,:,2) ', file=file) - call Print(this%dgamma_dr(:,:,2), file=file) - call Print('Self_Consistency : dgamma_dr(:,:,3) ', file=file) - call Print(this%dgamma_dr(:,:,3), file=file) - endif - - call verbosity_pop() - call verbosity_pop() -end subroutine Self_Consistency_Term_Print - -subroutine TBSystem_fill_sc_matrices(this, at) - type(TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - - integer i - - if (allocated(this%scf%terms)) then - do i=1, size(this%scf%terms) - call fill_sc_matrices(this%scf%terms(i), at, this%scf%U, this%scf%stoner_param, this%first_orb_of_atom, & - this%first_manifold_of_atom, this%first_orb_of_manifold, this%tbmodel) - end do - end if -end subroutine TBSystem_fill_sc_matrices - -subroutine Self_Consistency_Term_fill_sc_matrices(this, at, U, stoner_param, first_orb_of_atom, first_manifold_of_atom, first_orb_of_manifold, tbm) - type(Self_Consistency_Term), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(in), allocatable :: U(:), stoner_param(:,:) - integer, intent(in) :: first_orb_of_atom(:), first_manifold_of_atom(:), first_orb_of_manifold(:) - type(TBModel), intent(in) :: tbm - - real(dp), allocatable :: block_H_up(:,:), block_H_down(:,:), block_S(:,:) - integer :: i_at, i_man, n_i, orb_offset, man_offset - - select case(this%type) - case (SCF_NONE) - return - case (SCF_LCN) - return - case (SCF_GCN) - return - case (SCF_GLOBAL_U) - return - case (SCF_LOCAL_U) - if (.not. allocated(U)) & - call system_abort("self_consistency_term_fill_sc_matrices called with SCF_LOCAL_U but U not allocated") - if (minval(at%Z) < 1 .or. maxval(at%Z) > size(U)) & - call system_abort("self_consistency_term_fill_scf_matrices SCF_LOCAL_U called with at%Z element out of range 1.."//size(U)) - if (minval(U(at%Z)) <= 0) & - call system_abort("Tried to do a local U for atom " // minloc(U(at%Z)) // " Z " // at%Z(minloc(U(at%Z))) // " which has nonsense U") - this%U = U(at%Z) - case (SCF_NONLOCAL_U_DFTB) - if (.not. allocated(U)) & - call system_abort("self_consistency_term_fill_sc_matrices called with SCF_NONLOCAL_U_DFTB but U not allocated") - if (minval(at%Z) < 1 .or. maxval(at%Z) > size(U)) & - call system_abort("self_consistency_term_fill_scf_matrices SCF_NONLOCAL_U_DFTB called with at%Z element out of range 1.." // size(U)) - call calc_gamma_dftb(at, U, this%gamma) - case (SCF_NONLOCAL_U_NRL_TB) - if (.not. allocated(U)) & - call system_abort("self_consistency_term_fill_sc_matrices called with SCF_NONLOCAL_U_NRL_TB but U not allocated") - if (minval(at%Z) < 1 .or. maxval(at%Z) > size(U)) & - call system_abort("self_consistency_term_fill_scf_matrices SCF_NONLOCAL_U_NRL_TB called with at%Z element out of range 1.." // size(U)) - call calc_gamma_nrl_tb(at, U, this%gamma) - case (SCF_SPIN_DIR) - do i_at=1, at%N - n_i = first_orb_of_atom(i_at+1)-first_orb_of_atom(i_at) - allocate(block_H_up(n_i,n_i)) - allocate(block_H_down(n_i,n_i)) - allocate(block_S(n_i,n_i)) - call get_HS_blocks(tbm, at, i_at, i_at, (/ 0.0_dp, 0.0_dp, 0.0_dp /), 0.0_dp, block_H_up, block_S, i_mag=1) - call get_HS_blocks(tbm, at, i_at, i_at, (/ 0.0_dp, 0.0_dp, 0.0_dp /), 0.0_dp, block_H_down, block_S, i_mag=2) - do i_man=first_manifold_of_atom(i_at), first_manifold_of_atom(i_at+1)-1 - orb_offset = first_orb_of_manifold(i_man)-first_orb_of_atom(i_at)+1 - this%spin_splitting(i_man) = -0.5_dp*(block_H_up(orb_offset,orb_offset)-block_H_down(orb_offset,orb_offset)) - end do - deallocate(block_H_up) - deallocate(block_H_down) - deallocate(block_S) - end do - case (SCF_SPIN_STONER) - if (.not. allocated(stoner_param)) & - call system_abort("self_consistency_term_fill_sc_matrices called with SCF_SPIN_STONER but stoner_param not allocated") - if (minval(at%Z) < 1 .or. maxval(at%Z) > size(stoner_param)) & - call system_abort("self_consistency_term_fill_scf_matrices SCF_SPIN_STONER called with at%Z element out of range 1.."//size(stoner_param)) - do i_at=1, at%N - do i_man=first_manifold_of_atom(i_at), first_manifold_of_atom(i_at+1)-1 - man_offset = i_man - first_manifold_of_atom(i_at) + 1 - this%stoner_param(i_man) = stoner_param(man_offset, at%Z(i_at)) - this%stoner_param(i_man) = stoner_param(man_offset, at%Z(i_at)) - end do - end do - case default - call system_abort("Self_Consistency_Term_fill_sc_matrices confused by this%type="//this%type) - end select -end subroutine Self_Consistency_Term_fill_sc_matrices - -subroutine realloc_dgamma_dr(this) - type(Self_Consistency_Term), intent(inout) :: this - - if (.not. allocated(this%gamma)) then - call system_abort ("Called realloc_dgamma_dr with gamma not allocated") - endif - - if (allocated(this%dgamma_dr)) then - if (size(this%dgamma_dr,1) /= size(this%gamma,1) .or. & - size(this%dgamma_dr,2) /= size(this%gamma,2)) then - deallocate(this%dgamma_dr) - endif - endif - - if (.not.allocated(this%dgamma_dr)) then - allocate(this%dgamma_dr(size(this%gamma,1),size(this%gamma,2),3)) - endif -end subroutine realloc_dgamma_dr - -subroutine TBSystem_fill_sc_dmatrices(this, at, virial_component) - type(TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in), optional :: virial_component - - integer i_term - - if (allocated(this%scf%terms)) then - do i_term=1, size(this%scf%terms) - call fill_sc_dmatrices(this%scf%terms(i_term), at, this%scf%U, virial_component) - end do - end if -end subroutine TBSystem_fill_sc_dmatrices - -subroutine Self_Consistency_Term_fill_sc_dmatrices(this, at, U, virial_component) - type(Self_Consistency_Term), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp), intent(in) :: U(:) - integer, intent(in), optional :: virial_component - - select case(this%type) - case (SCF_NONE) - return - case (SCF_LCN) - return - case (SCF_GCN) - return - case (SCF_GLOBAL_U) - return - case (SCF_LOCAL_U) - return - case (SCF_NONLOCAL_U_DFTB) - call realloc_dgamma_dr(this) - call calc_dgamma_dr_dftb(at, U, this%dgamma_dr, virial_component) - case (SCF_NONLOCAL_U_NRL_TB) - call realloc_dgamma_dr(this) - call calc_dgamma_dr_nrl_tb(at, U, this%dgamma_dr, virial_component) - case (SCF_SPIN_DIR) - call system_abort("fill_sc_dmatrices: no SCF_SPIN_DIR yet") - return - case (SCF_SPIN_STONER) - return - case default - call system_abort("Self_Consistency_Term_fill_sc_dmatrices Confused by this%type="//this%type) - end select -end subroutine Self_Consistency_Term_fill_sc_dmatrices - -! from a (input) scf system and a new (output) orbital_n vector, compute new -! control parameters (density, local potential) for next SCF step -function TBSystem_update_orb_local_pot(this, at, iter, global_at_weight, new_orbital_n, new_orbital_m) - type(TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: iter - real(dp), intent(in), pointer :: global_at_weight(:) - real(dp), intent(in), pointer :: new_orbital_n(:), new_orbital_m(:,:) - logical :: TBSystem_update_orb_local_pot - - integer :: broyden_iter - integer :: i_term, n_dof, cur_dof, last_dof - real(dp) :: resid - logical :: done - - real(dp), allocatable :: to_zero_vec(:), control_vec(:), new_control_vec(:) - - if (.not. this%scf%active .or. size(this%scf%terms) == 0) then - TBSystem_update_orb_local_pot = .true. - return - endif - - n_dof = 0 - if (allocated(this%scf%terms)) then - do i_term=1, size(this%scf%terms) - n_dof = n_dof + this%scf%terms(i_term)%n_dof - end do - end if - - allocate(to_zero_vec(n_dof), control_vec(n_dof), new_control_vec(n_dof)) - - cur_dof = 1 - if (allocated(this%scf%terms)) then - do i_term=1, size(this%scf%terms) - last_dof = cur_dof + this%scf%terms(i_term)%n_dof - 1 - call get_vecs(this%scf%terms(i_term), this, to_zero_vec(cur_dof:last_dof), control_vec(cur_dof:last_dof), global_at_weight, new_orbital_n, new_orbital_m) - cur_dof = last_dof+1 - end do - end if - - if (this%scf%mix_simple) then - call do_mix_simple(iter, control_vec, to_zero_vec, new_control_vec, this%scf%alpha) - else - if (n_dof == 1) then - call do_ridders_residual(iter, control_vec(1), to_zero_vec(1), new_control_vec(1)) - else - broyden_iter = mod(iter-1,100)+1 ! throw out Broyden history every 100 steps - call do_mix_broyden(broyden_iter, control_vec, to_zero_vec, new_control_vec, this%scf%alpha, this%scf%w0) - endif - endif - - resid = maxval(abs(to_zero_vec)) - call Print("SCF iteration " // iter // " residual " // resid) - - done = (resid < this%scf%conv_tol) - - if (.not. done .and. this%scf%mix_simple .and. resid < this%scf%mix_simple_end_tol) then - call print("mix_simple is active, resid < this%scf%mix_simple_end_tol, switching simple mixing off", PRINT_ALWAYS) - this%scf%mix_simple = .false. - endif - if (.not. done .and. .not. this%scf%mix_simple .and. resid > this%scf%mix_simple_start_tol) then - call print("mix_simple is not active, resid > this%scf%mix_simple_start_tol, switching simple mixing on", PRINT_ALWAYS) - this%scf%mix_simple = .true. - endif - - cur_dof = 1 - if (allocated(this%scf%terms)) then - do i_term=1, size(this%scf%terms) - last_dof = cur_dof + this%scf%terms(i_term)%n_dof - 1 - ! SCF_SPIN_DIR isn't self consistent, so always update - if ((.not. done) .or. this%scf%terms(i_term)%type == SCF_SPIN_DIR) then - call set_vec(this%scf%terms(i_term), new_control_vec(cur_dof:last_dof)) - end if - cur_dof = last_dof+1 - end do - end if - - call calc_orb_local_pot(this, global_at_weight) - - deallocate(to_zero_vec, control_vec, new_control_vec) - - TBSystem_update_orb_local_pot = done - -end function TBSystem_update_orb_local_pot - -subroutine get_vecs(this, tbsys, to_zero_vec, control_vec, global_at_weight, new_orbital_n, new_orbital_m) - type(Self_Consistency_Term), intent(inout) :: this - type(TBSystem), intent(in) :: tbsys - real(dp), intent(out) :: to_zero_vec(:), control_vec(:) - real(dp), intent(in), pointer :: new_orbital_n(:), new_orbital_m(:,:) - real(dp), intent(in), pointer :: global_at_weight(:) - - integer :: i, N_mom - real(dp), allocatable :: new_manifold_m(:,:) - - if (this%type == SCF_NONE) return - - select case(this%type) - case (SCF_NONE) - return - case (SCF_LCN) - if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_LCN") - to_zero_vec = atom_orbital_sum(tbsys, new_orbital_n) - this%atomic_n0 - control_vec = this%atomic_local_pot - if (current_verbosity() >= PRINT_NERD) then - call print("get_vecs SCF_LCN delta_n" // to_zero_vec, PRINT_NERD) - endif - case(SCF_GCN) - if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_GCN") - if (.not. associated(global_at_weight)) & - call system_abort("Self_Consistency_Term_get_vecs SCF_GCN but no global_at_weight") - to_zero_vec = sum(global_at_weight*(atom_orbital_sum(tbsys, new_orbital_n)-this%atomic_n0)) - control_vec = this%global_pot - if (current_verbosity() >= PRINT_NERD) then - call print("get_vecs SCF_GCN delta_n" // to_zero_vec, PRINT_NERD) - endif - case(SCF_GLOBAL_U) - if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_GLOBAL_U") - if (.not. associated(global_at_weight)) & - call system_abort("Self_Consistency_Term_get_vecs SCF_GCN but no global_at_weight") - to_zero_vec = sum(global_at_weight*(atom_orbital_sum(tbsys, new_orbital_n)))-this%global_N - control_vec = this%global_N - if (current_verbosity() >= PRINT_NERD) then - call print("get_vecs SCF_GLOBAL_U delta_n" // to_zero_vec, PRINT_NERD) - endif - case (SCF_LOCAL_U) - if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_LOCAL_U") - to_zero_vec = atom_orbital_sum(tbsys, new_orbital_n) - this%atomic_n - control_vec = this%atomic_n - if (current_verbosity() >= PRINT_NERD) then - call print("get_vecs SCF_LOCAL_U delta_n" // to_zero_vec, PRINT_NERD) - endif - case (SCF_NONLOCAL_U_DFTB) - if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_NONLOCAL_U_DFTB") - to_zero_vec = atom_orbital_sum(tbsys, new_orbital_n) - this%atomic_n - control_vec = this%atomic_n - if (current_verbosity() >= PRINT_NERD) then - call print("get_vecs SCF_NONLOCAL_U_DFTB delta_n" // to_zero_vec, PRINT_NERD) - endif - case (SCF_NONLOCAL_U_NRL_TB) - if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_NONLOCAL_U_NRL_TB") - to_zero_vec = atom_orbital_sum(tbsys, new_orbital_n) - this%atomic_n - control_vec = this%atomic_n - if (current_verbosity() >= PRINT_NERD) then - call print("get_vecs SCF_NONLOCAL_U_NRL_TB delta_n" // to_zero_vec, PRINT_NERD) - endif - case (SCF_SPIN_DIR) - if (.not. associated(new_orbital_m)) call system_abort("get_vecs needs new_orbital_m for SCF_SPIN_DIR") - allocate(new_manifold_m(3,tbsys%N_manifolds)) - N_mom = tbsys%N_manifolds - new_manifold_m = manifold_orbital_sum(tbsys, new_orbital_m) - to_zero_vec(1:3*N_mom:3) = new_manifold_m(1,1:N_mom) - this%manifold_mom(1,1:N_mom) - to_zero_vec(2:3*N_mom:3) = new_manifold_m(2,1:N_mom) - this%manifold_mom(2,1:N_mom) - to_zero_vec(3:3*N_mom:3) = new_manifold_m(3,1:N_mom) - this%manifold_mom(3,1:N_mom) - control_vec(1:3*N_mom:3) = this%manifold_mom(1,1:N_mom) - control_vec(2:3*N_mom:3) = this%manifold_mom(2,1:N_mom) - control_vec(3:3*N_mom:3) = this%manifold_mom(3,1:N_mom) - if (current_verbosity() >= PRINT_NERD) then - call print("get_vecs SCF_SPIN_DIR current manifold moment", PRINT_NERD) - do i=1, tbsys%N_manifolds - call print(" " // i // " " // new_manifold_m(:,i), PRINT_NERD) - end do - endif - deallocate(new_manifold_m) - case (SCF_SPIN_STONER) - if (.not. associated(new_orbital_m)) call system_abort("get_vecs needs new_orbital_m for SCF_SPIN_STONER") - allocate(new_manifold_m(3,tbsys%N_manifolds)) - N_mom = tbsys%N_manifolds - new_manifold_m = manifold_orbital_sum(tbsys, new_orbital_m) - if (current_verbosity() >= PRINT_NERD) then - call print("get_vecs SCF_SPIN_STONER current manifold moment", PRINT_NERD) - do i=1, tbsys%N_manifolds - call print(" " // i // " " // new_manifold_m(:,i), PRINT_NERD) - end do - endif - to_zero_vec(1:3*N_mom:3) = new_manifold_m(1,1:N_mom) - this%manifold_mom(1,1:N_mom) - to_zero_vec(2:3*N_mom:3) = new_manifold_m(2,1:N_mom) - this%manifold_mom(2,1:N_mom) - to_zero_vec(3:3*N_mom:3) = new_manifold_m(3,1:N_mom) - this%manifold_mom(3,1:N_mom) - control_vec(1:3*N_mom:3) = this%manifold_mom(1,1:N_mom) - control_vec(2:3*N_mom:3) = this%manifold_mom(2,1:N_mom) - control_vec(3:3*N_mom:3) = this%manifold_mom(3,1:N_mom) - deallocate(new_manifold_m) - case default - call system_abort("Self_Consistency_Term_get_vecs confused by this%type="//this%type) - end select -end subroutine get_vecs - -subroutine set_vec(this, new_control_vec) - type(Self_Consistency_Term), intent(inout) :: this - real(dp), intent(in) :: new_control_vec(:) - - integer :: N_mom - - select case(this%type) - case (SCF_NONE) - return - case (SCF_LCN) - this%atomic_local_pot = new_control_vec - case(SCF_GCN) - this%global_pot = new_control_vec(1) - case (SCF_GLOBAL_U) - this%global_N = new_control_vec(1) - case (SCF_LOCAL_U) - this%atomic_n = new_control_vec - case (SCF_NONLOCAL_U_DFTB) - this%atomic_n = new_control_vec - case (SCF_NONLOCAL_U_NRL_TB) - this%atomic_n = new_control_vec - case (SCF_SPIN_DIR) - N_mom = size(this%manifold_mom,2) - this%manifold_mom(1,1:N_mom) = new_control_vec(1:3*N_mom:3) - this%manifold_mom(2,1:N_mom) = new_control_vec(2:3*N_mom:3) - this%manifold_mom(3,1:N_mom) = new_control_vec(3:3*N_mom:3) - case (SCF_SPIN_STONER) - N_mom = size(this%manifold_mom,2) - this%manifold_mom(1,1:N_mom) = new_control_vec(1:3*N_mom:3) - this%manifold_mom(2,1:N_mom) = new_control_vec(2:3*N_mom:3) - this%manifold_mom(3,1:N_mom) = new_control_vec(3:3*N_mom:3) - case default - call system_abort("Self_Consistency_Term_set_vec confused by this%type="//this%type) - end select -end subroutine set_vec - -! calculate orbital local potential from terms aready set in SCF object (local pot -! for LCN and GCN, and global_N or atomic_n for U based SCF. -subroutine TBSystem_calc_orb_local_pot(this, global_at_weight) - type(TBSystem), intent(inout) :: this - real(dp), intent(in), pointer :: global_at_weight(:) - - integer :: i_term - - this%scf%orb_local_pot = 0.0_dp - - if (.not. this%scf%active) return - - if (allocated(this%scf%terms)) then - do i_term=1, size(this%scf%terms) - if (allocated(this%scf%orb_local_pot)) & - call add_term_dSCFE_dn(this%scf%terms(i_term), this, global_at_weight, this%scf%orb_local_pot) - if (allocated(this%scf%orb_exch_field)) & - call add_term_dSCFE_dm(this%scf%terms(i_term), this, global_at_weight, this%scf%orb_exch_field) - end do - end if - -end subroutine TBSystem_calc_orb_local_pot - -subroutine add_term_dSCFE_dn(this, tbsys, global_at_weight, dSCFE_dn) - type(Self_Consistency_Term), intent(inout) :: this - type(TBSystem), intent(in) :: tbsys - real(dp), intent(in), pointer :: global_at_weight(:) - real(dp), intent(out) :: dSCFE_dn(:) - - dSCFE_dn = 0.0_dp - - select case (this%type) - case (SCF_NONE) - return - case (SCF_LCN) - dSCFE_dn = atom_orbital_spread(tbsys, this%atomic_local_pot) - case (SCF_GCN) - if (.not. associated(global_at_weight)) & - call system_abort("add_term_dSCFE_dn with SCF_GCN but no global_at_weight") - dSCFE_dn = atom_orbital_spread(tbsys, global_at_weight*this%global_pot) - case (SCF_GLOBAL_U) - if (.not. associated(global_at_weight)) & - call system_abort("add_term_dSCFE_dn with SCF_GLOBAL_U but no global_at_weight") - dSCFE_dn = atom_orbital_spread(tbsys, global_at_weight*this%global_U*(this%global_N-sum(global_at_weight*this%atomic_n0))) - case (SCF_LOCAL_U) - dSCFE_dn = atom_orbital_spread(tbsys, this%U*(this%atomic_n-this%atomic_n0)) - case (SCF_NONLOCAL_U_DFTB) - dSCFE_dn = atom_orbital_spread(tbsys, matmul(this%gamma,(this%atomic_n-this%atomic_n0))) - case (SCF_NONLOCAL_U_NRL_TB) - dSCFE_dn = atom_orbital_spread(tbsys, matmul(this%gamma,(this%atomic_n-this%atomic_n0))) - case (SCF_SPIN_DIR) - return - case (SCF_SPIN_STONER) - return - case default - call system_abort("add_term_dSCFE_dn confused by this%type="//this%type) - end select -end subroutine add_term_dSCFE_dn - -subroutine add_term_dSCFE_dm(this, tbsys, global_at_weight, dSCFE_dm) - type(Self_Consistency_Term), intent(inout) :: this - type(TBSystem), intent(in) :: tbsys - real(dp), intent(in), pointer :: global_at_weight(:) - real(dp), intent(out) :: dSCFE_dm(:,:) - - integer :: i_man, i_orb - real(dp) :: e(3) - - dSCFE_dm = 0.0_dp - - select case (this%type) - case (SCF_NONE) - return - case (SCF_LCN) - return - case (SCF_GCN) - return - case (SCF_GLOBAL_U) - return - case (SCF_LOCAL_U) - return - case (SCF_NONLOCAL_U_DFTB) - return - case (SCF_NONLOCAL_U_NRL_TB) - return - case (SCF_SPIN_DIR) - do i_man=1, tbsys%N_manifolds - e = this%manifold_mom(:,i_man) - if (norm(e) .feq. 0.0_dp) then - e = (/ 0.0_dp, 0.0_dp, 1.0_dp /) - else - e = e / norm(e) - endif - do i_orb = tbsys%first_orb_of_manifold(i_man), tbsys%first_orb_of_manifold(i_man+1)-1 - ! F = -0.5 sum_a spin_split_a |m_a| - ! dF/dm_i = -0.5 spin_split_a (|m_a| 2*m_a - |m_a|^2 m_a/|m_a|) / |m_a|^2 - ! = -0.5 spin_split_a ( 2*m_a/|m_a| - m_a/|m_a| ) - ! = -0.5 spin_split_a m_a/|m_a| - dSCFE_dm(1:3,i_orb) = -0.5_dp * this%spin_splitting(i_man)*e(1:3) - end do - end do - return - case (SCF_SPIN_STONER) - do i_man=1, tbsys%N_manifolds - do i_orb=tbsys%first_orb_of_manifold(i_man), tbsys%first_orb_of_manifold(i_man+1)-1 - ! F = -0.25 sum_a stoner_param_a * |m_a|^2 - ! dF/dm_i = -0.25 stoner_param_a 2 |m_a| m_a/|m_a| - ! = -0.5 stoner_param_a m_a - dSCFE_dm(1:3,i_orb) = -0.5_dp * this%stoner_param(i_man)*this%manifold_mom(1:3,i_man) - end do - end do - return - case default - call system_abort("add_term_dSCFE_dn confused by this%type="//this%type) - end select - -end subroutine add_term_dSCFE_dm - -subroutine add_term_d2SCFE_dgNdn(this, tbsys, global_at_weight, d2SCFE_dgNdn) - type(Self_Consistency_Term), intent(inout) :: this - type(TBSystem), intent(in) :: tbsys - real(dp), intent(in):: global_at_weight(:) - real(dp), intent(out) :: d2SCFE_dgNdn(:) - - d2SCFE_dgNdn = 0.0_dp - - if (.not. this%active) return - - select case (this%type) - case (SCF_NONE) - return - case (SCF_GLOBAL_U) - d2SCFE_dgNdn = atom_orbital_spread(tbsys, global_at_weight*this%global_U) - case default - call system_abort("add_term_d2SCFE_dgNdn only defined for GLOBAL_U") - end select -end subroutine add_term_d2SCFE_dgNdn - -subroutine add_term_d2SCFE_dn2_times_vec(this, tbsys, vec, d2SCFE_dn2_times_vec) - type(Self_Consistency_Term), intent(inout) :: this - type(TBSystem), intent(in) :: tbsys - real(dp), intent(in) :: vec(:) - real(dp), intent(out) :: d2SCFE_dn2_times_vec(:) - - d2SCFE_dn2_times_vec = 0.0_dp - - if (.not. this%active) return - - select case (this%type) - case (SCF_NONE) - return - case (SCF_LOCAL_U) - d2SCFE_dn2_times_vec = atom_orbital_spread(tbsys, this%U*vec) - case (SCF_NONLOCAL_U_DFTB) - d2SCFE_dn2_times_vec = atom_orbital_spread(tbsys, matmul(this%gamma,vec)) - case (SCF_NONLOCAL_U_NRL_TB) - d2SCFE_dn2_times_vec = atom_orbital_spread(tbsys, matmul(this%gamma,vec)) - case default - call system_abort("add_term_d2SCFE_dgNdn only defined for LOCAL_U and NONLOCAL_U_*") - end select -end subroutine add_term_d2SCFE_dn2_times_vec - -subroutine calc_gamma_dftb(at, U, gamma) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: U(:) - real(dp), intent(out) :: gamma(:,:) - - integer :: i, j - real(dp) :: U_i, U_j - real(dp) :: val - - real(dp) :: max_val - integer s1, s2, s3, s_range - real(dp) :: pi(3), pj(3), o(3), dr(3) - - gamma = 0.0_dp - - do i=1, at%N - if (U(at%Z(i)) <= 0) call system_abort("Tried to do a local U for atom " // i // " Z " // at%Z(i) // " which has nonsense U") - U_i = U(at%Z(i)) - gamma(i,i) = U_i - end do - - max_val = 1.0_dp - s_range = 1 - do while (max_val > 1.0e-12_dp) - max_val = 0.0_dp - do s1 = -s_range, s_range - do s2 = -s_range, s_range - do s3 = -s_range, s_range - if ((s_range > 1) .and. & - (s1 /= -s_range) .and. (s1 /= s_range) .and. & - (s2 /= -s_range) .and. (s2 /= s_range) .and. & - (s3 /= -s_range) .and. (s3 /= s_range)) cycle - do i=1, at%N - U_i = U(at%Z(i)) - pi = at%pos(1:3,i) - do j=i, at%N - if (i == j .and. s1 == 0 .and. s2 == 0 .and. s3 == 0) cycle - U_j = U(at%Z(j)) - pj = at%pos(1:3,j) - o = s1*at%lattice(:,1) + s2*at%lattice(:,2) + s3*at%lattice(:,3) - dr = (pi - pj - o) - val = Hartree*dftb_s(U_i/Hartree, U_j/Hartree, sqrt(sum(dr*dr))/Bohr) - if (abs(val) > max_val) max_val = abs(val) - gamma(i,j) = gamma(i,j) - val - gamma(j,i) = gamma(j,i) - val - end do - end do - end do - end do - end do - s_range = s_range + 1 - end do - - call add_madelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, gamma) - -end subroutine calc_gamma_dftb - -subroutine calc_dgamma_dr_dftb(at, U, dgamma_dr, virial_component) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: U(:) - real(dp), intent(out) :: dgamma_dr(:,:,:) - integer, intent(in), optional :: virial_component - - integer :: i, j - real(dp) :: U_i, U_j - real(dp) :: dval - - real(dp) :: max_val - integer s1, s2, s3, s_range - real(dp) :: pi(3), pj(3), o(3), dr(3), dr_mag - - integer my_virial_component - - my_virial_component = 0 - if (present(virial_component)) my_virial_component = virial_component - - dgamma_dr = 0.0_dp - - max_val = 1.0_dp - s_range = 1 - do while (max_val > 1.0e-12_dp) - max_val = 0.0_dp - do s1=-s_range,s_range - do s2=-s_range,s_range - do s3=-s_range,s_range - if ((s_range > 1) .and. & - (s1 /= -s_range) .and. (s1 /= s_range) .and. & - (s2 /= -s_range) .and. (s2 /= s_range) .and. & - (s3 /= -s_range) .and. (s3 /= s_range)) cycle - do i=1, at%N - if (U(at%Z(i)) <= 0) call system_abort("Tried to do a local U for atom " // i // " Z " // at%Z(i) // " which has nonsense U") - U_i = U(at%Z(i)) - pi = at%pos(1:3,i) - do j=i+1, at%N - if (U(at%Z(j)) <= 0) call system_abort("Tried to do a local U for atom " // j // " Z " // at%Z(j) // " which has nonsense U") - U_j = U(at%Z(j)) - pj = at%pos(1:3,j) - o = s1*at%lattice(:,1) + s2*at%lattice(:,2) + s3*at%lattice(:,3) - dr = (pi - pj - o) - dr_mag = sqrt(sum(dr*dr)) - dr = dr/dr_mag - dval = Hartree/Bohr * dftb_s_deriv(U_i/Hartree, U_j/Hartree, dr_mag/Bohr) - if (abs(dval) > max_val) max_val = abs(dval) - if (my_virial_component > 0) then - dgamma_dr(i,j,:) = dgamma_dr(i,j,:) + dval*dr*dr_mag*dr(my_virial_component) - dgamma_dr(j,i,:) = dgamma_dr(j,i,:) + dval*dr*dr_mag*dr(my_virial_component) - else - dgamma_dr(i,j,:) = dgamma_dr(i,j,:) - dval*dr - dgamma_dr(j,i,:) = dgamma_dr(j,i,:) + dval*dr - endif - end do - end do - end do - end do - end do - s_range = s_range + 1 - end do - - if (my_virial_component > 0) then - call add_dmadelung_matrix_dr(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, my_virial_component, dgamma_dr) - else - call add_dmadelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, dgamma_dr) - endif - -end subroutine calc_dgamma_dr_dftb - -subroutine calc_gamma_nrl_tb(at, U, gamma) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: U(:) - real(dp), intent(out) :: gamma(:,:) - - integer :: i, j - real(dp) :: U_i, U_j - real(dp) :: val - - real(dp) :: max_val - integer s1, s2, s3, s_range - real(dp) :: pi(3), pj(3), o(3), dr(3) - - gamma = 0.0_dp - - do i=1, at%N - if (at%Z(i) < 1 .or. at%Z(i) > size(U)) & - call system_abort("calc_gamma_nrl_tb got at%Z("//i//") out of range 1..size(U)="//size(U)) - if (U(at%Z(i)) <= 0) & - call system_abort("calc_gamma_nrl_tb tried to do a local U for atom " // i // " Z " // at%Z(i) // " which has nonsense U") - U_i = U(at%Z(i)) - gamma(i,i) = U_i - end do - - max_val = 1.0_dp - s_range = 1 - do while (max_val > 1.0e-10_dp) - max_val = 0.0_dp - do s1=-s_range,s_range - do s2=-s_range,s_range - do s3=-s_range,s_range - if ((s_range > 1) .and. & - (s1 /= -s_range) .and. (s1 /= s_range) .and. & - (s2 /= -s_range) .and. (s2 /= s_range) .and. & - (s3 /= -s_range) .and. (s3 /= s_range)) cycle - do i=1, at%N - U_i = U(at%Z(i)) - pi = at%pos(1:3,i) - do j=i, at%N - if (i == j .and. s1 == 0 .and. s2 == 0 .and. s3 == 0) cycle - U_j = U(at%Z(j)) - pj = at%pos(1:3,j) - o = s1*at%lattice(:,1) + s2*at%lattice(:,2) + s3*at%lattice(:,3) - dr = (pi - pj - o) - val = Hartree*nrl_tb_s(U_i/Hartree, U_j/Hartree, sqrt(sum(dr*dr))/Bohr) - if (abs(val) > max_val) max_val = abs(val) - gamma(i,j) = gamma(i,j) - val - gamma(j,i) = gamma(j,i) - val - end do - end do - end do - end do - end do - s_range = s_range + 1 - end do - - call add_madelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, gamma) - -end subroutine calc_gamma_nrl_tb - -subroutine calc_dgamma_dr_nrl_tb(at, U, dgamma_dr, virial_component) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: U(:) - real(dp), intent(out) :: dgamma_dr(:,:,:) - integer, intent(in), optional :: virial_component - - integer :: i, j - real(dp) :: U_i, U_j - real(dp) :: dval - - real(dp) :: max_val - integer s1, s2, s3, s_range - real(dp) :: pi(3), pj(3), o(3), dr(3), dr_mag - integer my_virial_component - - my_virial_component = 0 - if (present(virial_component)) my_virial_component = virial_component - - dgamma_dr = 0.0_dp - - max_val = 1.0_dp - s_range = 1 - do while (max_val > 1.0e-10_dp) - max_val = 0.0_dp - do s1=-s_range,s_range - do s2=-s_range,s_range - do s3=-s_range,s_range - if ((s_range > 1) .and. & - (s1 /= -s_range) .and. (s1 /= s_range) .and. & - (s2 /= -s_range) .and. (s2 /= s_range) .and. & - (s3 /= -s_range) .and. (s3 /= s_range)) cycle - do i=1, at%N - if (U(at%Z(i)) <= 0) call system_abort("Tried to do a local U for atom " // i // " Z " // at%Z(i) // " which has nonsense U") - U_i = U(at%Z(i)) - pi = at%pos(1:3,i) - do j=i+1, at%N - if (U(at%Z(j)) <= 0) call system_abort("Tried to do a local U for atom " // j // " Z " // at%Z(j) // " which has nonsense U") - U_j = U(at%Z(j)) - pj = at%pos(1:3,j) - o = s1*at%lattice(:,1) + s2*at%lattice(:,2) + s3*at%lattice(:,3) - dr = (pi - pj - o) - dr_mag = sqrt(sum(dr*dr)) - dr = dr/dr_mag - dval = Hartree/Bohr * nrl_tb_s_deriv(U_i/Hartree, U_j/Hartree, dr_mag/Bohr) - if (abs(dval) > max_val) max_val = abs(dval) - if (my_virial_component > 0) then - dgamma_dr(i,j,:) = dgamma_dr(i,j,:) + dval*dr*dr_mag*dr(my_virial_component) - dgamma_dr(j,i,:) = dgamma_dr(j,i,:) + dval*dr*dr_mag*dr(my_virial_component) - else - dgamma_dr(i,j,:) = dgamma_dr(i,j,:) - dval*dr - dgamma_dr(j,i,:) = dgamma_dr(j,i,:) + dval*dr - endif - end do - end do - end do - end do - end do - s_range = s_range + 1 - end do - - if (my_virial_component > 0) then - call add_dmadelung_matrix_dr(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, my_virial_component, dgamma_dr) - else - call add_dmadelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, dgamma_dr) - endif - -end subroutine calc_dgamma_dr_nrl_tb - -! From Michael Strenberg's Ph.D. Thesis, p. 27, Paderborn 2001 -function dftb_s(u_a, u_b, R) - real(dp), intent(in) :: u_a, u_b, R - real(dp) :: dftb_s - - real(dp) tau_a, tau_b - - tau_a = 16.0_dp/5.0_dp * u_a - tau_b = 16.0_dp/5.0_dp * u_b - - if (tau_a /= tau_b) then - dftb_s = & - exp(-tau_a*R)* ( (tau_b**4 * tau_a) / (2.0_dp * (tau_a**2 - tau_b**2)**2) - & - (tau_b**6 - 3.0_dp*tau_b**4*tau_a**2) / (R * (tau_a**2-tau_b**2)**3) ) + & - exp(-tau_b*R)* ( (tau_a**4 * tau_b) / (2.0_dp * (tau_b**2 - tau_a**2)**2) - & - (tau_a**6 - 3.0_dp*tau_a**4*tau_b**2) / (R * (tau_b**2-tau_a**2)**3) ) - else - dftb_s = & - exp(-tau_a*R) * (48.0_dp + 33.0_dp * tau_a * R + 9.0_dp * (tau_a*R)**2 + (tau_a*R)**3) / & - (48.0_dp * R) - endif -end function dftb_s - -function dftb_s_deriv(u_a, u_b, R) - real(dp), intent(in) :: u_a, u_b, R - real(dp) :: dftb_s_deriv - - real(dp) tau_a, tau_b - real(dp) exp_v, rat_v, exp_v_deriv, rat_v_deriv - - tau_a = 16.0_dp/5.0_dp * u_a - tau_b = 16.0_dp/5.0_dp * u_b - - if (tau_a /= tau_b) then - exp_v = exp(-tau_a*R) - exp_v_deriv = -tau_a*exp_v - rat_v = (tau_b**4 * tau_a) / (2.0_dp * (tau_a**2 - tau_b**2)**2) - & - (tau_b**6 - 3.0_dp*tau_b**4*tau_a**2) / (R * (tau_a**2-tau_b**2)**3) - rat_v_deriv = (tau_b**6 - 3.0_dp*tau_b**4*tau_a**2) / (R**2 * (tau_a**2-tau_b**2)**3) - dftb_s_deriv = exp_v*rat_v_deriv + exp_v_deriv*rat_v - - exp_v = exp(-tau_b*R) - exp_v_deriv = -tau_b*exp_v - rat_v = (tau_a**4 * tau_b) / (2.0_dp * (tau_b**2 - tau_a**2)**2) - & - (tau_a**6 - 3.0_dp*tau_a**4*tau_b**2) / (R * (tau_b**2-tau_a**2)**3) - rat_v_deriv = (tau_a**6 - 3.0_dp*tau_a**4*tau_b**2) / (R**2 * (tau_b**2-tau_a**2)**3) - - dftb_s_deriv = dftb_s_deriv + exp_v*rat_v_deriv + exp_v_deriv*rat_v - - else - exp_v = exp(-tau_a*R) - exp_v_deriv = -tau_a*exp_v - rat_v = (48.0_dp + 33.0_dp * tau_a * R + 9.0_dp * (tau_a*R)**2 + (tau_a*R)**3) / (48.0_dp * R) - rat_v_deriv = ( (48.0_dp*R) * (33.0_dp * tau_a + 18.0_dp * tau_a**2 * R + 3*(tau_a*R)**2 * tau_a) - & - (48.0_dp + 33.0_dp * tau_a * R + 9.0_dp * (tau_a*R)**2 + (tau_a*R)**3) * 48.0_dp ) / & - ((48.0_dp*R)**2) - - dftb_s_deriv = exp_v*rat_v_deriv + exp_v_deriv*rat_v - endif -end function dftb_s_deriv - -function nrl_tb_s_deriv(u_a, u_b, R) - real(dp), intent(in) :: u_a, u_b, R - real(dp) :: nrl_tb_s_deriv - - real(dp) a, c - - a = PI/2.0D0 * u_a**2 - c = PI/2.0D0 * u_b**2 - - nrl_tb_s_deriv = -1.0D0/R**2 - ( (a*c)**1.5D0 / PI**3 ) * & - 2.0D0*PI**2.5D0 / (a*c*sqrt(a+c)) * dF0(a,c,R) -end function nrl_tb_s_deriv - -function nrl_tb_s(u_a, u_b, R) - real(dp), intent(in) :: u_a, u_b, R - real(dp) :: nrl_tb_s - - real(dp) :: a, c - - a = PI/2.0_dp * u_a**2 - c = PI/2.0_dp * u_b**2 - - nrl_tb_s = 1.0_dp/R - ( (a*c)**1.5_dp / PI**3 ) * & - 2.0_dp*PI**2.5_dp / (a*c*sqrt(a+c)) * F0(a,c,R) -end function nrl_tb_s - -function F0(a, c, R) - real(dp), intent(in) :: a, c, R - real(dp) :: F0 - - double precision coeff, q - - ! gamma(a,b,c,d) = 1 - ! from G&R 3.321 + 8.250 - coeff = a*c/(a+c) * R**2 - q = sqrt(coeff) - - F0 = sqrt(PI)/(2*q) * erf(q) - -end function F0 - -function dF0(a,c,R) - real(dp), intent(in) :: a, c, R - real(dp) :: dF0 - - real(dp) coeff, q - - ! gamma(a,b,c,d) = 1 - ! from G&R 3.321 + 8.250 - coeff = a*c/(a+c) * R**2 - q = sqrt(coeff) - - dF0 = ( exp(-q*q)/q - sqrt(PI)/(2*q*q) * erf(q) ) * sqrt((a*c)/(a+c)) - -end function - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine local_scf_e_correction(this, at, local_e, global_E, global_at_weight) - type(TBSystem), intent(in) :: this - type(Atoms), intent(in) :: at - real(dp), intent(out) :: local_e(:), global_E - real(dp), pointer, intent(in), optional :: global_at_weight(:) - - integer :: i_term - - local_e = 0.0_dp - global_e = 0.0_dp - - if (.not. this%scf%active) return - - if (allocated(this%scf%terms)) then - do i_term=1, size(this%scf%terms) - call add_term_local_scf_e_correction(this%scf%terms(i_term), local_e, global_E, this%N_atoms, this%first_manifold_of_atom, global_at_weight) - end do - end if - -end subroutine local_scf_e_correction - -! for SCF energy, + SCFE - dSCFE_dn * n -! for charge neutrality, -pot*n0 -subroutine add_term_local_scf_e_correction(this, local_e, global_E, N_atoms, first_manifold_of_atom, global_at_weight) - type(Self_Consistency_Term), intent(in) :: this - real(dp), intent(out) :: local_e(:), global_E - integer :: N_atoms, first_manifold_of_atom(:) - real(dp), pointer, intent(in), optional :: global_at_weight(:) - - integer :: i_at, i_man - - select case(this%type) - case (SCF_NONE) - return - case (SCF_LCN) - local_e = local_e - this%atomic_local_pot*this%atomic_n0 - case (SCF_GCN) - if (.not. present(global_at_weight)) & - call system_abort ("local_scf_e_correction with SCF_GCN but without global_at_weight") - if (.not. associated(global_at_weight)) & - call system_abort ("local_scf_e_correction with SCF_GCN but with unassociated global_at_weight") - global_e = global_e - this%global_pot*sum(global_at_weight*this%atomic_n0) - case (SCF_GLOBAL_U) - if (.not. present(global_at_weight)) & - call system_abort ("local_scf_e_correction with SCF_GLOBAL_U but without global_at_weight") - if (.not. associated(global_at_weight)) & - call system_abort ("local_scf_e_correction with SCF_GLOBAL_U but with unassociated global_at_weight") - global_e = global_e + 0.5_dp*this%global_U*(this%global_N-sum(global_at_weight*this%atomic_n0))**2 - & - this%global_U*(this%global_N-sum(global_at_weight*this%atomic_n0))*this%global_N - case (SCF_LOCAL_U) - local_e = local_e + 0.5_dp*this%U*(this%atomic_n-this%atomic_n0)**2 - this%U*(this%atomic_n-this%atomic_n0)*this%atomic_n - case (SCF_NONLOCAL_U_DFTB) - local_e = local_e + 0.5_dp*((this%atomic_n-this%atomic_n0) * matmul(this%gamma, this%atomic_n-this%atomic_n0)) - & - (this%atomic_n * matmul(this%gamma,this%atomic_n-this%atomic_n0)) - case (SCF_NONLOCAL_U_NRL_TB) - local_e = local_e + 0.5_dp*((this%atomic_n-this%atomic_n0) * matmul(this%gamma, this%atomic_n-this%atomic_n0)) - & - (this%atomic_n * matmul(this%gamma,this%atomic_n-this%atomic_n0)) - case (SCF_SPIN_DIR) - return - case (SCF_SPIN_STONER) - do i_at=1, N_atoms - do i_man=first_manifold_of_atom(i_at), first_manifold_of_atom(i_at+1)-1 - ! add F({m_i}) - local_e(i_at) = local_e(i_at) - 0.25_dp*this%stoner_param(i_man)*norm(this%manifold_mom(1:3,i_man))**2 - ! subtract dF/dm_i . m_i - local_e(i_at) = local_e(i_at) + 0.5_dp*this%stoner_param(i_man)*norm(this%manifold_mom(1:3,i_man))**2 - end do - end do - case default - call system_abort("add_term_local_scf_e_correction confused by this%type="//this%type) - end select - -end subroutine add_term_local_scf_e_correction - -subroutine add_term_dscf_e_correction_dgN(this, dglobal_E_dgN) - type(Self_Consistency_Term), intent(in) :: this - real(dp), intent(out) :: dglobal_E_dgN - - dglobal_E_dgN = 0.0_dp - - if (.not. this%active) return - - select case(this%type) - case (SCF_NONE) - return - case (SCF_GLOBAL_U) - dglobal_E_dgN = this%global_U*this%global_N - case default - call system_abort("add_term_dscf_e_correction_dgN only defined for GLOBAL_U") - end select -end subroutine - -subroutine add_term_dscf_e_correction_dn(this, tbsys, dlocal_E_dn) - type(Self_Consistency_Term), intent(in) :: this - type(TBSystem), intent(in) :: tbsys - real(dp), intent(out) :: dlocal_E_dn(:) - - dlocal_E_dn = 0.0_dp - - if (.not. this%active) return - - select case(this%type) - case (SCF_NONE) - return - case (SCF_LOCAL_U) - dlocal_E_dn = atom_orbital_spread(tbsys, this%U*this%atomic_n) - case (SCF_NONLOCAL_U_DFTB) - dlocal_E_dn = atom_orbital_spread(tbsys, matmul(this%gamma,this%atomic_n)) - case (SCF_NONLOCAL_U_NRL_TB) - dlocal_E_dn = atom_orbital_spread(tbsys, matmul(this%gamma,this%atomic_n)) - case default - call system_abort("add_term_dscf_e_correction_dgN only defined for GLOBAL_U") - end select -end subroutine - -subroutine realloc_datomic_local_pot_dr(this) - type(Self_Consistency_Term), intent(inout) :: this - - if (.not. allocated(this%atomic_n)) then - call system_abort ("realloc_datomic_local_pot_dr with local_pot not allocated") - endif - - if (allocated(this%datomic_local_pot_dr)) then - if (size(this%datomic_local_pot_dr,1) /= size(this%atomic_n,1)) then - deallocate(this%datomic_local_pot_dr) - endif - endif - - if (.not.allocated(this%datomic_local_pot_dr)) then - allocate(this%datomic_local_pot_dr(size(this%atomic_n,1),3)) - endif -end subroutine realloc_datomic_local_pot_dr - -function scf_f_correction(this, at) result(forces_scf) - type(TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp) :: forces_scf(3,at%N) ! result - - integer i_term - - forces_scf = 0.0 - - call fill_sc_dmatrices(this, at) - - if (allocated(this%scf%terms)) then - do i_term=1, size(this%scf%terms) - forces_scf = forces_scf + add_term_scf_f_correction(this%scf%terms(i_term), at) - end do - end if - -end function scf_f_correction - -function add_term_scf_f_correction(this, at) result (forces_scf) - type(Self_Consistency_Term), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp) :: forces_scf(3,at%N) ! result - - forces_scf = 0.0_dp - - select case(this%type) - case (SCF_NONE) - return - case (SCF_GCN) - return - case (SCF_GLOBAL_U) - return - case (SCF_LCN) - return - case (SCF_LOCAL_U) - return - case (SCF_NONLOCAL_U_DFTB) - call realloc_datomic_local_pot_dr(this) - this%datomic_local_pot_dr(:,1) = matmul(this%dgamma_dr(:,:,1),(this%atomic_n-this%atomic_n0)) - this%datomic_local_pot_dr(:,2) = matmul(this%dgamma_dr(:,:,2),(this%atomic_n-this%atomic_n0)) - this%datomic_local_pot_dr(:,3) = matmul(this%dgamma_dr(:,:,3),(this%atomic_n-this%atomic_n0)) - forces_scf(1,:) = -this%datomic_local_pot_dr(:,1)*(this%atomic_n-this%atomic_n0) - forces_scf(2,:) = -this%datomic_local_pot_dr(:,2)*(this%atomic_n-this%atomic_n0) - forces_scf(3,:) = -this%datomic_local_pot_dr(:,3)*(this%atomic_n-this%atomic_n0) - case (SCF_NONLOCAL_U_NRL_TB) - call realloc_datomic_local_pot_dr(this) - this%datomic_local_pot_dr(:,1) = matmul(this%dgamma_dr(:,:,1),(this%atomic_n-this%atomic_n0)) - this%datomic_local_pot_dr(:,2) = matmul(this%dgamma_dr(:,:,2),(this%atomic_n-this%atomic_n0)) - this%datomic_local_pot_dr(:,3) = matmul(this%dgamma_dr(:,:,3),(this%atomic_n-this%atomic_n0)) - forces_scf(1,:) = -this%datomic_local_pot_dr(:,1)*(this%atomic_n-this%atomic_n0) - forces_scf(2,:) = -this%datomic_local_pot_dr(:,2)*(this%atomic_n-this%atomic_n0) - forces_scf(3,:) = -this%datomic_local_pot_dr(:,3)*(this%atomic_n-this%atomic_n0) - case (SCF_SPIN_DIR) - call system_abort("add_term_scf_f_correction not implemented for SCF_SPIN_DIR yet") - case (SCF_SPIN_STONER) - return - case default - call system_abort("add_term_scf_f_correction confused by this%type="//this%type) - end select -end function add_term_scf_f_correction - -function scf_virial_correction(this, at) result(virial_scf) - type(TBSystem), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp) :: virial_scf(3,3) ! result - - integer :: component, i_term - - virial_scf = 0.0_dp - do component=1,3 - call fill_sc_dmatrices(this, at, component) - if (allocated(this%scf%terms)) then - do i_term=1, size(this%scf%terms) - virial_scf(:,component) = virial_scf(:,component) + add_term_scf_virial_correction(this%scf%terms(i_term), at) - end do - end if - end do -end function scf_virial_correction - -function add_term_scf_virial_correction(this, at) result (virial_scf) - type(Self_Consistency_Term), intent(inout) :: this - type(Atoms), intent(in) :: at - real(dp) :: virial_scf(3) ! result - - virial_scf = 0.0_dp - - select case(this%type) - case (SCF_NONE) - return - case (SCF_GCN) - return - case (SCF_GLOBAL_U) - return - case (SCF_LCN) - return - case (SCF_LOCAL_U) - return - case (SCF_NONLOCAL_U_DFTB) - call realloc_datomic_local_pot_dr(this) - this%datomic_local_pot_dr(:,1) = matmul(this%dgamma_dr(:,:,1),(this%atomic_n-this%atomic_n0)) - this%datomic_local_pot_dr(:,2) = matmul(this%dgamma_dr(:,:,2),(this%atomic_n-this%atomic_n0)) - this%datomic_local_pot_dr(:,3) = matmul(this%dgamma_dr(:,:,3),(this%atomic_n-this%atomic_n0)) - virial_scf(1) = 0.5_dp*sum(this%datomic_local_pot_dr(:,1)*(this%atomic_n-this%atomic_n0)) - virial_scf(2) = 0.5_dp*sum(this%datomic_local_pot_dr(:,2)*(this%atomic_n-this%atomic_n0)) - virial_scf(3) = 0.5_dp*sum(this%datomic_local_pot_dr(:,3)*(this%atomic_n-this%atomic_n0)) - case (SCF_NONLOCAL_U_NRL_TB) - call realloc_datomic_local_pot_dr(this) - this%datomic_local_pot_dr(:,1) = matmul(this%dgamma_dr(:,:,1),(this%atomic_n-this%atomic_n0)) - this%datomic_local_pot_dr(:,2) = matmul(this%dgamma_dr(:,:,2),(this%atomic_n-this%atomic_n0)) - this%datomic_local_pot_dr(:,3) = matmul(this%dgamma_dr(:,:,3),(this%atomic_n-this%atomic_n0)) - virial_scf(1) = 0.5_dp*sum(this%datomic_local_pot_dr(:,1)*(this%atomic_n-this%atomic_n0)) - virial_scf(2) = 0.5_dp*sum(this%datomic_local_pot_dr(:,2)*(this%atomic_n-this%atomic_n0)) - virial_scf(3) = 0.5_dp*sum(this%datomic_local_pot_dr(:,3)*(this%atomic_n-this%atomic_n0)) - case (SCF_SPIN_DIR) - call system_abort("add_term_scf_virial_correction not implemented for SCF_SPIN_DIR yet") - case (SCF_SPIN_STONER) - return - case default - call system_abort("calc_datomic_local_pot_dr confused by this%type="//this%type) - end select -end function add_term_scf_virial_correction - -function scf_e_correction(this, at, global_at_weight) - type(TBSystem), intent(in) :: this - type(Atoms), intent(in) :: at - real(dp), pointer, intent(in), optional :: global_at_weight(:) - real(dp) :: scf_e_correction - - real(dp), allocatable :: local_e_scf(:) - real(dp) :: global_e_scf - - allocate(local_e_scf(at%N)) - - call local_scf_e_correction(this, at, local_e_scf, global_e_scf, global_at_weight) - scf_e_correction = sum(local_e_scf) + global_e_scf - deallocate(local_e_scf) - -end function scf_e_correction - -subroutine get_dipole_block(this, at, i, j, dv_hat, dv_mag, block_dipole) - type(TB_Dipole_Model), intent(in) :: this - type(Atoms), intent(in) :: at - integer, intent(in) :: i, j - real(dp), intent(in) :: dv_hat(3), dv_mag - real(dp), intent(out) :: block_dipole(:,:,:) - - real(dp) :: pi(3), pj(3), sigi, sigj - integer :: phasei, phasej - integer :: i_type, j_type, i_orb_set, j_orb_set, i_offset, j_offset - integer :: first_i, last_i, first_j, last_j - real(dp) :: W(10,10,4), W_T(9,9,4), trans_mat_i(10,9), trans_mat_j(10,9) - - pi = at%pos(1:3,i) - pj = at%pos(1:3,i) + dv_hat(1:3)*dv_mag - - i_type = this%type_of_atomic_num(at%Z(i)) - j_type = this%type_of_atomic_num(at%Z(j)) - - i_offset = 1 - do i_orb_set=1, this%n_orb_sets(i_type) - sigi = this%gaussian_width(i_orb_set, i_type) - phasei = this%orb_set_phase(i_orb_set, i_type) - - call init_transform(trans_mat_i, sigi, phasei) - - j_offset = 1 - do j_orb_set=1, this%n_orb_sets(j_type) - sigj = this%gaussian_width(j_orb_set, j_type) - phasej = this%orb_set_phase(j_orb_set, j_type) - - call init_transform(trans_mat_j, sigj, phasej) - ! Mark Pederson's dipole matrix element routine - call GINTED(sigi, sigj, pi, pj, W) - W_T(1:9,1:9,1) = matmul(matmul(transpose(trans_mat_i),W(1:10,1:10,1)),trans_mat_j) - W_T(1:9,1:9,2) = matmul(matmul(transpose(trans_mat_i),W(1:10,1:10,2)),trans_mat_j) - W_T(1:9,1:9,3) = matmul(matmul(transpose(trans_mat_i),W(1:10,1:10,3)),trans_mat_j) - - if (this%orb_set_type(i_orb_set,i_type) == ORB_S) then - first_i = 1 - last_i = 1 - else if (this%orb_set_type(i_orb_set,i_type) == ORB_P) then - first_i = 2 - last_i = 4 - else if (this%orb_set_type(i_orb_set,i_type) == ORB_D) then - first_i = 5 - last_i = 9 - else - call system_abort("get_dipole_block got unknown orb_set_type for i_orb_set " // this%orb_set_type(i_orb_set,i_type)) - endif - if (this%orb_set_type(j_orb_set,j_type) == ORB_S) then - first_j = 1 - last_j = 1 - else if (this%orb_set_type(j_orb_set,j_type) == ORB_P) then - first_j = 2 - last_j = 4 - else if (this%orb_set_type(j_orb_set,j_type) == ORB_D) then - first_j = 5 - last_j = 9 - else - call system_abort(" get_dipole_block got unknown orb_set_type for j_orb_set " // this%orb_set_type(j_orb_set,j_type)) - endif - block_dipole(i_offset:i_offset+N_ORBS_OF_SET(this%orb_set_type(i_orb_set,i_type))-1, & - j_offset:j_offset+N_ORBS_OF_SET(this%orb_set_type(j_orb_set,j_type))-1, 1:3) = W_T(first_i:last_i,first_j:last_j,1:3) - j_offset = j_offset + N_ORBS_OF_SET(this%orb_set_type(j_orb_set,j_type)) - end do ! j_orb_set - i_offset = i_offset + N_ORBS_OF_SET(this%orb_set_type(i_orb_set,i_type)) - end do ! i_orb_set - -end subroutine get_dipole_block - -subroutine init_transform(trans, sigma, phase) -implicit none - real(dp), intent(out) :: trans(10,9) - real(dp), intent(in) :: sigma - integer, intent(in) :: phase - - integer O_S, O_PX, O_PY, O_PZ - parameter (O_S = 1, O_PX = 2, O_PY = 3, O_PZ = 4) - integer O_DXX, O_DYY, O_DZZ, O_DXY, O_DYZ, O_DXZ - parameter (O_DXX = 5, O_DYY = 6, O_DZZ = 7, O_DXY = 8, O_DXZ = 9, O_DYZ = 10) - - integer OT_S, OT_PX, OT_PY, OT_PZ - parameter (OT_S = 1, OT_PY = 2, OT_PZ = 3, OT_PX = 4) - integer OT_DXY, OT_DYZ, OT_DZX, OT_DXXYY, OT_DZZRR - parameter (OT_DXY = 5, OT_DYZ = 6, OT_DZZRR = 7, OT_DZX = 8, OT_DXXYY = 9) - real(dp) :: inv_rt2, inv_rt6 - real(dp) :: rt2 - - real(dp) :: base_norm_factor, rt_sigma - - inv_rt2 = 1.0_dp/sqrt(2.0_dp) - inv_rt6 = 1.0_dp/sqrt(6.0_dp) - rt2 = sqrt(2.0_dp) - - base_norm_factor = 1.0D0/(PI/(2.0_dp*sigma))**(3.0_dp/4.0_dp) - rt_sigma = sqrt(sigma) - - trans = 0.0D0 - - trans(O_S,OT_S) = base_norm_factor - - trans(O_PX,OT_PX) = -2.0_dp*base_norm_factor*rt_sigma - trans(O_PY,OT_PY) = -2.0_dp*base_norm_factor*rt_sigma - trans(O_PZ,OT_PZ) = -2.0_dp*base_norm_factor*rt_sigma - - trans(O_DXY,OT_DXY) = 4.0_dp*base_norm_factor*sigma - trans(O_DYZ,OT_DYZ) = 4.0_dp*base_norm_factor*sigma - trans(O_DXZ,OT_DZX) = 4.0_dp*base_norm_factor*sigma - - trans(O_DXX,OT_DXXYY) = inv_rt2*rt2*2.0_dp*base_norm_factor*sigma - trans(O_DYY,OT_DXXYY) = -inv_rt2*rt2*2.0_dp*base_norm_factor*sigma - - trans(O_DXX,OT_DZZRR) = -inv_rt6*rt2*2.0_dp*base_norm_factor*sigma - trans(O_DYY,OT_DZZRR) = -inv_rt6*rt2*2.0_dp*base_norm_factor*sigma - trans(O_DZZ,OT_DZZRR) = 2.0D0*inv_rt6*rt2*2.0_dp*base_norm_factor*sigma - - trans = trans*phase - -end subroutine init_transform - -subroutine realloc_dipole_model(this, new_n_types, new_n_orb_sets) - type(TB_Dipole_Model), intent(inout) :: this - integer, intent(in) :: new_n_types, new_n_orb_sets - - integer :: max_n_orb_sets - integer, allocatable :: t_atomic_num(:), t_n_orb_sets(:), t_orb_set_type(:,:), t_orb_set_phase(:,:) - real(dp), allocatable :: t_gaussian_width(:,:) - - if (size(this%n_orb_sets) > 0) then - max_n_orb_sets = maxval(this%n_orb_sets,1) - else - max_n_orb_sets = 0 - endif - if (new_n_types > this%n_types .or. new_n_orb_sets > max_n_orb_sets) then - ! allocate temporaries if necessary - if (this%n_types > 0) then - allocate(t_n_orb_sets(this%n_types)) - t_n_orb_sets = this%n_orb_sets(1:this%n_types) - allocate(t_atomic_num(this%n_types)) - t_atomic_num = this%atomic_num(1:this%n_types) - if (max_n_orb_sets > 0) then - allocate(t_orb_set_type(max_n_orb_sets,this%n_types)) - allocate(t_gaussian_width(max_n_orb_sets,this%n_types)) - allocate(t_orb_set_phase(max_n_orb_sets,this%n_types)) - t_orb_set_type = this%orb_set_type(1:max_n_orb_sets,1:this%n_types) - t_gaussian_width = this%gaussian_width(1:max_n_orb_sets,1:this%n_types) - t_orb_set_phase = this%orb_set_phase(1:max_n_orb_sets,1:this%n_types) - endif - endif - - ! deallocate and reallocate real arrays - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) - if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) - if (allocated(this%gaussian_width)) deallocate(this%gaussian_width) - if (allocated(this%orb_set_phase)) deallocate(this%orb_set_phase) - allocate(this%atomic_num(new_n_types)) - allocate(this%n_orb_sets(new_n_types)) - allocate(this%orb_set_type(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) - allocate(this%orb_set_phase(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) - allocate(this%gaussian_width(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) - this%atomic_num = 0 - this%n_orb_sets = 0 - this%orb_set_type = 0 - this%gaussian_width = 0.0_dp - this%orb_set_phase = 0 - - ! copy from temporaries if necessary - if (this%n_types > 0) then - this%atomic_num(1:this%n_types) = t_atomic_num(1:this%n_types) - this%n_orb_sets(1:this%n_types) = t_n_orb_sets(1:this%n_types) - if (max_n_orb_sets > 0) then - this%orb_set_type(1:max_n_orb_sets,1:this%n_types) = t_orb_set_type(1:max_n_orb_sets, 1:this%n_types) - this%gaussian_width(1:max_n_orb_sets,1:this%n_types) = t_gaussian_width(1:max_n_orb_sets, 1:this%n_types) - this%orb_set_phase(1:max_n_orb_sets,1:this%n_types) = t_orb_set_phase(1:max_n_orb_sets, 1:this%n_types) - endif - endif - this%n_types = max(this%n_types, new_n_types) - - if (allocated(t_atomic_num)) deallocate(t_atomic_num) - if (allocated(t_n_orb_sets)) deallocate(t_n_orb_sets) - if (allocated(t_orb_set_type)) deallocate(t_orb_set_type) - if (allocated(t_gaussian_width)) deallocate(t_gaussian_width) - if (allocated(t_orb_set_phase)) deallocate(t_orb_set_phase) - endif -end subroutine realloc_dipole_model - -subroutine realloc_spin_orbit_coupling(this, new_n_types, new_n_orb_sets) - type(TB_Spin_Orbit_Coupling), intent(inout) :: this - integer, intent(in) :: new_n_types, new_n_orb_sets - - integer :: max_n_orb_sets - integer, allocatable :: t_atomic_num(:), t_n_orb_sets(:), t_orb_set_type(:,:) - real(dp), allocatable :: t_SO_param(:,:) - - if (size(this%n_orb_sets) > 0) then - max_n_orb_sets = maxval(this%n_orb_sets,1) - else - max_n_orb_sets = 0 - endif - if (new_n_types > this%n_types .or. new_n_orb_sets > max_n_orb_sets) then - ! allocate temporaries if necessary - if (this%n_types > 0) then - allocate(t_n_orb_sets(this%n_types)) - t_n_orb_sets = this%n_orb_sets(1:this%n_types) - allocate(t_atomic_num(this%n_types)) - t_atomic_num = this%atomic_num(1:this%n_types) - if (max_n_orb_sets > 0) then - allocate(t_orb_set_type(max_n_orb_sets,this%n_types)) - allocate(t_SO_param(max_n_orb_sets,this%n_types)) - t_orb_set_type = this%orb_set_type(1:max_n_orb_sets,1:this%n_types) - t_SO_param = this%SO_param(1:max_n_orb_sets,1:this%n_types) - endif - endif - - ! deallocate and reallocate real arrays - if (allocated(this%atomic_num)) deallocate(this%atomic_num) - if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) - if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) - if (allocated(this%SO_param)) deallocate(this%SO_param) - allocate(this%atomic_num(new_n_types)) - allocate(this%n_orb_sets(new_n_types)) - allocate(this%orb_set_type(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) - allocate(this%SO_param(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) - this%atomic_num = 0 - this%n_orb_sets = 0 - this%orb_set_type = 0 - this%SO_param = 0.0_dp - - ! copy from temporaries if necessary - if (this%n_types > 0) then - this%atomic_num(1:this%n_types) = t_atomic_num(1:this%n_types) - this%n_orb_sets(1:this%n_types) = t_n_orb_sets(1:this%n_types) - if (max_n_orb_sets > 0) then - this%orb_set_type(1:max_n_orb_sets,1:this%n_types) = t_orb_set_type(1:max_n_orb_sets, 1:this%n_types) - this%SO_param(1:max_n_orb_sets,1:this%n_types) = t_SO_param(1:max_n_orb_sets, 1:this%n_types) - endif - endif - this%n_types = max(this%n_types, new_n_types) - - if (allocated(t_atomic_num)) deallocate(t_atomic_num) - if (allocated(t_n_orb_sets)) deallocate(t_n_orb_sets) - if (allocated(t_orb_set_type)) deallocate(t_orb_set_type) - if (allocated(t_SO_param)) deallocate(t_SO_param) - endif -end subroutine realloc_spin_orbit_coupling - -subroutine get_SO_block(this, tbm, Z, block_SO) - type(TB_Spin_Orbit_Coupling), intent(in) :: this - type(TBModel), intent(in) :: tbm - integer, intent(in) :: Z - complex(dp), intent(out) :: block_SO(:,:) - - complex(dp) :: V(2,2) - integer :: i_orb_set, i_orb_dir, j_orb_dir, i_orb_type - integer :: offset_base, i_offset, j_offset - integer :: i_type - - i_type = this%type_of_atomic_num(Z) - block_SO = 0.0_dp - offset_base = 0 - do i_orb_set=1, n_orb_sets_of_Z(tbm, Z) - i_orb_type = orb_type_of_orb_set_of_Z(tbm, Z, i_orb_set) - do i_orb_dir=1, n_orbs_of_orb_set_of_Z(tbm, Z, i_orb_set) - do j_orb_dir=1, n_orbs_of_orb_set_of_Z(tbm, Z, i_orb_set) - i_offset = offset_base + i_orb_dir - 1 - j_offset = offset_base + j_orb_dir - 1 - V = spin_orbit_function(i_orb_type, i_orb_dir, j_orb_dir) - block_SO(2*i_offset+1:2*i_offset+2,2*j_offset+1:2*j_offset+2) = this%SO_param(i_orb_set, i_type) * V(1:2,1:2) - end do - end do - offset_base = offset_base + n_orbs_of_orb_set_of_Z(tbm, Z, i_orb_set) - end do - -end subroutine get_SO_block - -subroutine tbsystem_initialise_kpoints(this, args_str, param_str, mpi_obj, from_tbsystem_initialise) - type(TBSystem), intent(inout) :: this - character(len=*), intent(in), optional :: args_str - character(len=*), intent(in), optional :: param_str - type(MPI_context), intent(in), optional :: mpi_obj - logical, intent(in), optional :: from_tbsystem_initialise - - type(Dictionary) :: params - logical :: use_k_density, use_k_density_once, k_use_mp - integer :: k_mesh(3) - logical :: my_from_tbsystem_initialise - real(dp) :: k_density - - my_from_tbsystem_initialise = optional_default(.false., from_tbsystem_initialise) - - if (present(args_str)) then - call initialise(params) - call param_register(params, "k_density", "-1.0", k_density, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "use_k_density", "F", use_k_density, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "use_k_density_once", "F", use_k_density_once, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "k_mesh", "-1 -1 -1", k_mesh, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, "k_use_mp", ""//this%kpoints_use_mp, k_use_mp, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBSystem_Initialise_KPoints')) then - call system_abort("tbsystem_initialise_kpoints failed to parse args_str='"//trim(args_str)//"'") - endif - call finalise(params) - else - use_k_density = .false. - use_k_density_once = .false. - k_mesh = (/ -1, -1, -1 /) - k_use_mp = .true. - endif - - if (use_k_density .and. use_k_density_once) then - call system_abort("tbsystem_initialise_kpoints confused because user passed both use_k_density and use_k_density_once") - endif - - if (.not. my_from_tbsystem_initialise .and. use_k_density_once) then - call system_abort("tbsystem_initialise_kp[oints use_k_density_once can only be passed from tbsystem_initialise") - endif - - if ((use_k_density .or. use_k_density_once) .and. any(k_mesh > 0)) then - call system_abort("tbsystem_initialise_kpoints confused by having both use_k_density ("//use_k_density// & - ") or use_k_density_once("//use_k_density_once//") and signs of intent to use k_mesh ("//k_mesh//")") - endif - - if (my_from_tbsystem_initialise) then - if (use_k_density .or. use_k_density_once) then - this%kpoints_generate_dynamically = .true. - this%kpoints_generate_next_dynamically = .not. use_k_density_once - this%kpoints_use_mp = k_use_mp - if (k_density >= 0.0_dp) then - this%kpoints_k_space_density = k_density - else if (this%tbmodel%has_default_k_density) then - this%kpoints_k_space_density = this%tbmodel%default_k_density - else - this%kpoints_k_space_density = -1.0_dp - endif - else if (any(k_mesh > 0)) then - call initialise(this%kpoints, k_mesh, k_use_mp, mpi_obj) - call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) - else - if (present(param_str)) then - call initialise(this%kpoints, param_str, mpi_obj) - call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) - endif - endif - else ! not from tbsystem_initialise - if (use_k_density) then - this%kpoints_generate_dynamically = .true. - this%kpoints_generate_next_dynamically = .true. - this%kpoints_use_mp = k_use_mp - if (k_density >= 0.0_dp) then - this%kpoints_k_space_density = k_density - else if (this%tbmodel%has_default_k_density) then - this%kpoints_k_space_density = this%tbmodel%default_k_density - else - this%kpoints_k_space_density = -1.0_dp - endif - else if (any(k_mesh > 0)) then - call initialise(this%kpoints, k_mesh, k_use_mp, mpi_obj) - call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) - endif - endif - - -end subroutine tbsystem_initialise_kpoints - -end module TBSystem_module diff --git a/src/Potentials/TB_Common.f95 b/src/Potentials/TB_Common.f95 deleted file mode 100644 index 51de2bde0a..0000000000 --- a/src/Potentials/TB_Common.f95 +++ /dev/null @@ -1,335 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X TB_Common_module -!X -!% TB module computes the tight-binding Hamiltonian matrix elements -!% in the two-center approximation, applying the general expressions -!% derived by A.V. Podolskiy and P. Vogl Phys. Rev. B {\bf 69}, 233101 (2004). -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - -module TB_Common_module - -use System_module -implicit none -private - -integer, parameter, public :: ORB_S = 1, ORB_P = 2, ORB_D = 3, ORB_F = 4 - -integer, parameter, public :: N_ORBS_OF_SET(4) = (/1, 3, 5, 7/) - - - -integer, parameter, public :: harrison_sign_sss = -1, harrison_sign_sps = 1, & - harrison_sign_pps = 1, harrison_sign_ppp = -1, & - harrison_sign_sds = -1, harrison_sign_pds = -1, & - harrison_sign_pdp = 1, harrison_sign_dds = -1, & - harrison_sign_ddp = 1 - -integer, parameter, public :: N_SK = 20 -integer, parameter, public :: SK_SSS = 1, SK_SPS = 2, SK_PPS = 3, SK_PPP = 4, & - SK_SDS = 5, SK_PDS = 6, SK_PDP = 7, SK_DDS = 8, SK_DDP = 9, SK_DDD = 10, & - SK_SFS = 11, SK_PFS = 12, SK_PFP = 13, SK_DFS = 14, SK_DFP = 15, SK_DFD = 16, & - SK_FFS = 17, SK_FFP = 18, SK_FFD = 19, SK_FFF = 20 - -public :: angular_function, dangular_function, spin_orbit_function - -contains - -function angular_function(dcos, dcos_sq, orb_type_i, orb_type_j, orb_dir_i, orb_dir_j, sk) result(V) - real(dp), intent(in) :: dcos(3), dcos_sq(3) - integer, intent(in) :: orb_type_i, orb_type_j - integer, intent(in) :: orb_dir_i, orb_dir_j - real(dp), intent(in) :: sk(N_SK) - real(dp) :: V - - real(dp) :: u_V_sss, u_V_sps, u_V_pps, u_V_ppp - real(dp) :: u_V_sds, u_V_pds, u_V_pdp - real(dp) :: u_V_dds, u_V_ddp, u_V_ddd - real(dp) :: u_V_sfs, u_V_pfs, u_V_pfp - real(dp) :: u_V_dfs, u_V_dfp, u_V_dfd - real(dp) :: u_V_ffs, u_V_ffp, u_V_ffd, u_V_fff - - real(dp) :: L, M, N, Lsq, Msq, Nsq, Nsq_denom - - real(dp) :: root_3 - - root_3 = sqrt(3.0_dp) - - ! L on L - u_V_sss = sk(SK_SSS) - - u_V_pps = sk(SK_PPS) - u_V_ppp = sk(SK_PPP) - - u_V_dds = sk(SK_DDS) - u_V_ddp = sk(SK_DDP) - u_V_ddd = sk(SK_DDD) - - u_V_ffs = sk(SK_FFS) - u_V_ffp = sk(SK_FFP) - u_V_ffd = sk(SK_FFD) - u_V_fff = sk(SK_FFF) - - ! L on L +/- 2 - u_V_sds = sk(SK_SDS) - - u_V_pfs = sk(SK_PFS) - u_V_pfp = sk(SK_PFP) - - ! SK_vogl.h does also its own sign flip - if (orb_type_i < orb_type_j) then - ! L on L +/- 1 - u_V_sps = sk(SK_SPS) - - u_V_pds = sk(SK_PDS) - u_V_pdp = sk(SK_PDP) - - u_V_dfs = sk(SK_DFS) - u_V_dfp = sk(SK_DFP) - u_V_dfd = sk(SK_DFD) - - ! L on L +/- 3 - u_V_sfs = sk(SK_SFS) - else - ! L on L +/- 1 - u_V_sps = -sk(SK_SPS) - - u_V_pds = -sk(SK_PDS) - u_V_pdp = -sk(SK_PDP) - - u_V_dfs = -sk(SK_DFS) - u_V_dfp = -sk(SK_DFP) - u_V_dfd = -sk(SK_DFD) - - ! L on L +/- 3 - u_V_sfs = -sk(SK_SFS) - endif - - L = dcos(1) - M = dcos(2) - N = dcos(3) - Lsq = dcos_sq(1) - Msq = dcos_sq(2) - Nsq = dcos_sq(3) - ! work around division by (-1 + Nsq) in SK_vogl.h by defining special variant of - ! Nsq that is regularized, so that numerator which is 0 can correctly drive - ! expression to 0 instead of getting NaN - Nsq_denom = Nsq - if (Nsq == 1.0) then - Nsq_denom = Nsq - 1.0e-5 - endif - - ! seems to prevent intel 9.1.051 -O3 optimizer from breaking S1-D5 matrix element (and maybe others?) - if (orb_type_i < 0) call print("") - -include 'SK_vogl.h' - -end function angular_function - -function spin_orbit_function(orb_type_i, orb_dir_i, orb_dir_j) result(V) - integer, intent(in) :: orb_type_i, orb_dir_i, orb_dir_j - complex(dp) :: V(2,2) - - real(dp) :: root_3 - - root_3 = sqrt(3.0_dp) - - ! spin-orbit term - ! from Podolskiy and Vogl, Phys. Rev. B v. 69, p 233101 (2004) - -include 'SK_SO_vogl.h' - -end function spin_orbit_function - -function dangular_function(dist, dcos, dcos_sq, orb_type_i, orb_type_j, & - orb_dir_i, orb_dir_j, sk, dsk) - real(dp), intent(in) :: dist, dcos(3), dcos_sq(3) - integer, intent(in) :: orb_type_i, orb_type_j - integer, intent(in) :: orb_dir_i, orb_dir_j - real(dp), intent(in) :: sk(N_SK), dsk(N_SK) - real(dp) :: dangular_function(3) - - real(dp) :: rVd(3), rVd_t - - real(dp) :: u_V_sss, u_V_sps, u_V_pps, u_V_ppp - real(dp) :: u_V_sds, u_V_pds, u_V_pdp - real(dp) :: u_V_dds, u_V_ddp, u_V_ddd - real(dp) :: u_V_sfs, u_V_pfs, u_V_pfp - real(dp) :: u_V_dfs, u_V_dfp, u_V_dfd - real(dp) :: u_V_ffs, u_V_ffp, u_V_ffd, u_V_fff - - real(dp) :: u_Vd_sss, u_Vd_sps, u_Vd_pps, u_Vd_ppp - real(dp) :: u_Vd_sds, u_Vd_pds, u_Vd_pdp - real(dp) :: u_Vd_dds, u_Vd_ddp, u_Vd_ddd - real(dp) :: u_Vd_sfs, u_Vd_pfs, u_Vd_pfp - real(dp) :: u_Vd_dfs, u_Vd_dfp, u_Vd_dfd - real(dp) :: u_Vd_ffs, u_Vd_ffp, u_Vd_ffd, u_Vd_fff - - real(dp) :: L, M, N, Lsq, Msq, Nsq, Nsq_denom - real(dp) :: dL_dr(3), dM_dr(3), dN_dr(3) - - real(dp) :: root_3 - - root_3 = sqrt(3.0_dp) - - ! L on L - u_V_sss = sk(SK_SSS) - - u_V_pps = sk(SK_PPS) - u_V_ppp = sk(SK_PPP) - - u_V_dds = sk(SK_DDS) - u_V_ddp = sk(SK_DDP) - u_V_ddd = sk(SK_DDD) - - u_V_ffs = sk(SK_FFS) - u_V_ffp = sk(SK_FFP) - u_V_ffd = sk(SK_FFD) - u_V_fff = sk(SK_FFF) - - u_Vd_sss = dsk(SK_SSS) - - u_Vd_pps = dsk(SK_PPS) - u_Vd_ppp = dsk(SK_PPP) - - u_Vd_dds = dsk(SK_DDS) - u_Vd_ddp = dsk(SK_DDP) - u_Vd_ddd = dsk(SK_DDD) - - u_Vd_ffs = dsk(SK_FFS) - u_Vd_ffp = dsk(SK_FFP) - u_Vd_ffd = dsk(SK_FFD) - u_Vd_fff = dsk(SK_FFF) - - ! L on L +/- 2 - u_V_sds = sk(SK_SDS) - - u_V_pfs = sk(SK_PFS) - u_V_pfp = sk(SK_PFP) - - u_Vd_sds = dsk(SK_SDS) - - u_Vd_pfs = dsk(SK_PFS) - u_Vd_pfp = dsk(SK_PFP) - - ! SK_vogl.h does also its own sign flip - if (orb_type_i < orb_type_j) then - ! L on L +/- 1 - u_V_sps = sk(SK_SPS) - - u_V_pds = sk(SK_PDS) - u_V_pdp = sk(SK_PDP) - - u_V_dfs = sk(SK_DFS) - u_V_dfp = sk(SK_DFP) - u_V_dfd = sk(SK_DFD) - - u_Vd_sps = dsk(SK_SPS) - - u_Vd_pds = dsk(SK_PDS) - u_Vd_pdp = dsk(SK_PDP) - - u_Vd_dfs = dsk(SK_DFS) - u_Vd_dfp = dsk(SK_DFP) - u_Vd_dfd = dsk(SK_DFD) - - ! L on L +/- 3 - u_V_sfs = sk(SK_SFS) - - u_Vd_sfs = dsk(SK_SFS) - else - ! L on L +/- 1 - u_V_sps = -sk(SK_SPS) - - u_V_pds = -sk(SK_PDS) - u_V_pdp = -sk(SK_PDP) - - u_V_dfs = -sk(SK_DFS) - u_V_dfp = -sk(SK_DFP) - u_V_dfd = -sk(SK_DFD) - - u_Vd_sps = -dsk(SK_SPS) - - u_Vd_pds = -dsk(SK_PDS) - u_Vd_pdp = -dsk(SK_PDP) - - u_Vd_dfs = -dsk(SK_DFS) - u_Vd_dfp = -dsk(SK_DFP) - u_Vd_dfd = -dsk(SK_DFD) - - ! L on L +/- 3 - u_V_sfs = -sk(SK_SFS) - - u_Vd_sfs = -dsk(SK_SFS) - endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - L = dcos(1) - M = dcos(2) - N = dcos(3) - Lsq = dcos_sq(1) - Msq = dcos_sq(2) - Nsq = dcos_sq(3) - ! work around division by (-1 + Nsq) in SKd_vogl.h by defining special variant of - ! Nsq that is regularized, so that numerator which is 0 can correctly drive - ! expression to 0 instead of getting NaN - Nsq_denom = Nsq - if (Nsq == 1.0) then - Nsq_denom = Nsq - 1.0e-5 - endif - - ! seems to prevent intel 9.1.051 -O3 optimizer from breaking S1-D5 matrix element (and maybe others?) - if (orb_type_i < 0) call print("") - -include 'SKd_vogl.h' - - dL_dr(1) = (-1.0_dp+L**2)/dist - dL_dr(2) = L*M/dist - dL_dr(3) = L*N/dist - - dM_dr(1) = M*L/dist - dM_dr(2) = (-1.0_dp+M**2)/dist - dM_dr(3) = M*N/dist - - dN_dr(1) = N*L/dist - dN_dr(2) = N*M/dist - dN_dr(3) = (-1.0_dp+N**2)/dist - - dangular_function(:) = (rVd(1)*dL_dr(:) + rVd(2)*dM_dr(:) + rVd(3)*dN_dr(:) - rVd_t*dcos(:)) - -end function dangular_function - -end module TB_Common_module diff --git a/src/Potentials/TB_GreensFunctions.f95 b/src/Potentials/TB_GreensFunctions.f95 deleted file mode 100644 index 67d59a7225..0000000000 --- a/src/Potentials/TB_GreensFunctions.f95 +++ /dev/null @@ -1,649 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX! -!X -!X TB_GreensFunctions module -!X -!% Contain Green's functions of a TB model, calculate them, -!% and compute derivatives of energies by summing over GFs -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX! -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX! -module TB_GreensFunctions_module - -use system_module, only : dp, print, inoutput, mainlog, PRINT_NERD, verbosity_push_decrement, verbosity_pop, system_abort, operator(//) -use mpi_context_module -use atoms_module - -use Functions_module -use ApproxFermi_module -use Matrix_module -use TBMatrix_module -use TB_Kpoints_module -use TBSystem_module - -implicit none -private - -public :: GreensFunctions -type GreensFunctions - integer :: N_G = 0 - complex(dp), allocatable :: a(:), z(:) - - type(TBSystem) :: tbsys - type(TBMatrix), allocatable :: G(:), G_conjg(:) - type(TBMatrix) :: dm, mod_dm_H, mod_dm_S - type(MPI_Context) :: mpi_global, mpi_my_poles, mpi_across_poles -end type GreensFunctions - -public :: Initialise -interface Initialise - module procedure GreensFunctions_Initialise -end interface Initialise - -public :: Finalise -interface Finalise - module procedure GreensFunctions_Finalise -end interface Finalise - -public :: Wipe -interface Wipe - module procedure GreensFunctions_Wipe -end interface Wipe - -public :: Print -interface Print - module procedure GreensFunctions_Print -end interface Print - -public :: Setup_system -interface Setup_system - module procedure GreensFunctions_Setup_system -end interface Setup_system - -interface init_mpi - module procedure GreensFunctions_init_mpi -end interface init_mpi - -interface end_mpi - module procedure GreensFunctions_end_mpi -end interface end_mpi - -public :: calc_Gs -interface calc_Gs - module procedure GreensFunctions_calc_Gs -end interface calc_Gs - -public :: calc_dm_from_Gs -interface calc_dm_from_Gs - module procedure GreensFunctions_calc_dm_from_Gs -end interface calc_dm_from_Gs - -public :: calc_mod_dm_from_Gs -interface calc_mod_dm_from_Gs - module procedure GreensFunctions_calc_mod_dm_from_Gs -end interface calc_mod_dm_from_Gs - -public :: Gsum_distrib_inplace -interface Gsum_distrib_inplace - module procedure GreensFunctions_Gsum_distrib_inplace_tbm, GreensFunctions_Gsum_distrib_inplace_r2 - module procedure GreensFunctions_Gsum_distrib_inplace_r3, GreensFunctions_Gsum_distrib_inplace_matd -end interface Gsum_distrib_inplace - -public :: Gsum_distrib -interface Gsum_distrib - module procedure GreensFunctions_Gsum_distrib_d -end interface Gsum_distrib - -contains - -subroutine GreensFunctions_Finalise(this) - type(GreensFunctions), intent(inout) :: this - - call end_mpi(this) - - call Wipe(this) - call Finalise(this%dm) - call Finalise(this%mod_dm_H) - call Finalise(this%mod_dm_S) - call Finalise(this%tbsys) - call Finalise(this%mpi_global) - call Finalise(this%mpi_my_poles) - call Finalise(this%mpi_across_poles) -end subroutine GreensFunctions_Finalise - -subroutine GreensFunctions_Wipe(this) - type(GreensFunctions), intent(inout) :: this - - integer :: i - - call Wipe(this%tbsys) - - if (allocated(this%G)) then - do i=1, size(this%G) - call Finalise(this%G(i)) - end do - deallocate(this%G) - endif - if (allocated(this%G_conjg)) then - do i=1, size(this%G_conjg) - call Finalise(this%G_conjg(i)) - end do - deallocate(this%G_conjg) - endif - if (allocated(this%a)) deallocate(this%a) - if (allocated(this%z)) deallocate(this%z) - this%N_G = 0 - - call finalise(this%dm) - call finalise(this%mod_dm_H) - call finalise(this%mod_dm_S) -end subroutine GreensFunctions_Wipe - -subroutine GreensFunctions_Print(this,file) - type(GreensFunctions), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer::i - - call Print('GreensFunctions : ', file=file) - - call Print ('GreensFunctions: N_G ' // this%N_G, file=file) - if (this%N_G > 0) then - do i=1, size(this%a) - call Print ("GreensFunctions : a z " // i // " " // this%a(i) // " " // this%z(i), file=file) - end do - call verbosity_push_decrement() - do i=1, size(this%G) - call Print(this%G(i), file=file) - end do - do i=1, size(this%G_conjg) - call Print(this%G_conjg(i), file=file) - end do - call verbosity_pop() - endif -end subroutine GreensFunctions_Print - -subroutine GreensFunctions_init_mpi(this, mpi_obj) - type(GreensFunctions), intent(inout) :: this - type(MPI_Context), intent(in) :: mpi_obj - - integer i - integer local_N_G, n_procs_per_pole, t - integer my_split_ident - integer, allocatable :: local_index(:) - complex(dp), allocatable :: t_a(:), t_z(:) - logical :: no_pole_here - - this%mpi_global = mpi_obj - - if (this%N_G > this%mpi_global%n_procs) then - n_procs_per_pole = 1 - else - n_procs_per_pole = this%mpi_global%n_procs/this%N_G - endif - - allocate(local_index(this%N_G)) - local_N_G = 0 - do i=0, this%N_G-1 - t = this%mpi_global%my_proc/n_procs_per_pole - if (mod(i,this%mpi_global%n_procs) == t) then - local_N_G = local_N_G + 1 - local_index(local_N_G) = i+1 - end if - end do - - if (local_N_G == 0) then - local_N_G = 1 - no_pole_here = .true. - local_index(1) = this%N_G - else - no_pole_here = .false. - endif - - if (this%mpi_global%active) then - my_split_ident = this%mpi_global%my_proc/n_procs_per_pole - call split_context(this%mpi_global, my_split_ident, this%mpi_my_poles) - - my_split_ident = this%mpi_my_poles%my_proc - call split_context(this%mpi_global, my_split_ident, this%mpi_across_poles) - endif - - allocate(t_a(local_N_G)) - allocate(t_z(local_N_G)) - t_a(1:local_N_G) = this%a(local_index(1:local_N_G)) - t_z(1:local_N_G) = this%z(local_index(1:local_N_G)) - - deallocate(this%a) - deallocate(this%z) - this%N_G = local_N_G - allocate(this%a(this%N_G)) - allocate(this%z(this%N_G)) - this%a = t_a - this%z = t_z - if (no_pole_here) this%a = 0.0_dp - deallocate(t_a) - deallocate(t_z) -end subroutine GreensFunctions_init_mpi - -subroutine GreensFunctions_end_mpi(this) - type(GreensFunctions), intent(inout) :: this - - if (this%mpi_global%active) then - call free_context(this%mpi_my_poles) - call free_context(this%mpi_across_poles) - endif -end subroutine GreensFunctions_end_mpi - - -subroutine GreensFunctions_Initialise(this, z, a, tbsys, mpi_obj) - type(GreensFunctions), intent(inout) :: this - complex(dp) :: z(:), a(:) - type(TBSystem), intent(in), optional :: tbsys - type(MPI_Context), intent(in), optional :: mpi_obj - - - if (size(z) /= size(a)) call system_abort("Called GreensFunctions_Initialise with mismatching z and a arrays") - - call Finalise(this) - - this%N_G = size(z) - if (allocated(this%z)) deallocate(this%z) - if (allocated(this%a)) deallocate(this%a) - allocate(this%z(size(z))) - allocate(this%a(size(a))) - this%z = z - this%a = a - - if (present(mpi_obj)) then - call init_mpi(this, mpi_obj) - else - call init_mpi(this, tbsys%mpi_global) - endif - - if (present(tbsys)) then - call Setup_system(this, tbsys) - endif - -end subroutine GreensFunctions_Initialise - -subroutine GreensFunctions_Setup_system(this, tbsys) - type(GreensFunctions), intent(inout) :: this - type(TBSystem), intent(in) :: tbsys - - integer i - - call Finalise(this%tbsys) - - if (allocated(this%G)) then - do i=1, size(this%G) - call Finalise(this%G(i)) - end do - deallocate(this%G) - endif - if (allocated(this%G_conjg)) then - do i=1, size(this%G_conjg) - call Finalise(this%G_conjg(i)) - end do - deallocate(this%G_conjg) - endif - - call Initialise(this%tbsys, tbsys, mpi_obj=this%mpi_my_poles) - this%tbsys%scf = tbsys%scf - - allocate(this%G(this%N_G)) - do i=1, this%N_G - call Initialise(this%G(i), this%tbsys%N, this%tbsys%n_matrices, .true., this%tbsys%scalapack_my_matrices) - end do - if (this%tbsys%complex_matrices) then - allocate(this%G_conjg(this%N_G)) - do i=1, this%N_G - call Initialise(this%G_conjg(i), this%tbsys%N, this%tbsys%n_matrices, .true., this%tbsys%scalapack_my_matrices) - end do - endif - - call Initialise(this%dm, this%tbsys%N, this%tbsys%n_matrices, this%tbsys%complex_matrices, & - scalapack_obj=this%tbsys%scalapack_my_matrices) - call Initialise(this%mod_dm_H, this%tbsys%N, this%tbsys%n_matrices, this%tbsys%complex_matrices, & - scalapack_obj=this%tbsys%scalapack_my_matrices) - if (.not. this%tbsys%tbmodel%is_orthogonal) then - call Initialise(this%mod_dm_S, this%tbsys%N, this%tbsys%n_matrices, this%tbsys%complex_matrices, & - scalapack_obj=this%tbsys%scalapack_my_matrices) - endif - -end subroutine - -subroutine GreensFunctions_calc_Gs(this, at, SelfEnergy) - type(GreensFunctions), intent(inout) :: this - type(Atoms), intent(inout) :: at - type(TBMatrix), intent(in), optional :: SelfEnergy(:) - - integer i - - - call fill_matrices(this%tbsys, at, .true.) - - if (present(SelfEnergy)) then - if (this%N_G /= size(SelfEnergy)) & - call system_abort("Called GreensFunctions_calc_Gs with SelfEnergy size mismatch " // size(SelfEnergy) // " " // this%N_G) - endif - -!$omp parallel do - do i=1, this%N_G - mainlog%mpi_all_inoutput_flag=.true. - call print("GreensFunctions_calc_Gs doing i="//i, PRINT_NERD) - mainlog%mpi_all_inoutput_flag=.false. - call scaled_sum(this%G(i), this%z(i), this%tbsys%S, -1.0_dp, this%tbsys%H) - if (present(SelfEnergy)) then - call scaled_accum(this%G(i), cmplx(1.0_dp, 0.0_dp, dp), SelfEnergy(i)) - endif - call inverse(this%G(i), positive = .false.) - if (this%tbsys%complex_matrices) then - call scaled_sum(this%G_conjg(i), conjg(this%z(i)), this%tbsys%S, -1.0_dp, this%tbsys%H) - call inverse(this%G_conjg(i), positive = .false.) - endif - end do - -end subroutine GreensFunctions_calc_Gs - -subroutine GreensFunctions_calc_dm_from_Gs(this) - type(GreensFunctions), intent(inout) :: this - - integer i - - call zero(this%dm) - do i=1, this%N_G - if (this%tbsys%complex_matrices) then - call scaled_accum(this%dm, -this%a(i), this%G(i)) - call scaled_accum(this%dm, -conjg(this%a(i)), this%G_conjg(i)) - else - call scaled_accum(this%dm, -2.0_dp*this%a(i), this%G(i)) - endif - end do - - call Gsum_distrib_inplace(this, this%dm) -end subroutine - -subroutine GreensFunctions_calc_mod_dm_from_Gs(this, w_e, w_n, do_const_N) - type(GreensFunctions), intent(inout) :: this - real(dp), intent(in), pointer :: w_e(:), w_n(:) - logical, intent(in), optional :: do_const_N - - real(dp), allocatable :: ww_e(:), ww_n(:) - logical :: const_N = .false. - real(dp) chempot - type(TBMatrix),save :: GWE, GWE_H_G, GWN, GWN_S_G - -!$OMP threadprivate(GWE,GWN,GWE_H_G,GWN_S_G) - - complex(dp) a, az - - integer i - - if (present(do_const_N)) const_N = do_const_N - - call zero(this%mod_dm_H) - if (.not. this%tbsys%tbmodel%is_orthogonal) then - call zero(this%mod_dm_S) - endif - - allocate(ww_e(this%tbsys%N)) - allocate(ww_n(this%tbsys%N)) - - if (associated(w_e)) then - ww_e = atom_orbital_spread(this%tbsys, w_e) - else - ww_e = 1.0_dp - endif - if (associated(w_n)) then - ww_n = atom_orbital_spread(this%tbsys, w_n) - else - ww_n = 1.0_dp - endif - - if (const_N) chempot = GreensFunctions_calc_chempot(this, w_e, w_n) - - -!$omp parallel private(a,az) - call Initialise(GWE, this%tbsys%N, this%tbsys%n_matrices, is_complex = .true., scalapack_obj=this%tbsys%scalapack_my_matrices) - call Initialise(GWE_H_G, this%tbsys%N, this%tbsys%n_matrices, is_complex = .true., scalapack_obj=this%tbsys%scalapack_my_matrices) - if (const_N) then - call Initialise(GWN, this%tbsys%N, this%tbsys%n_matrices, is_complex = .true., scalapack_obj=this%tbsys%scalapack_my_matrices) - call Initialise(GWN_S_G, this%tbsys%N, this%tbsys%n_matrices, is_complex = .true., scalapack_obj=this%tbsys%scalapack_my_matrices) - endif -!$omp do - do i=1, this%N_G - mainlog%mpi_all_inoutput_flag=.true. - call print("GreensFunctions_calc_mod_dm_from_Gs doing i="//i, PRINT_NERD) - mainlog%mpi_all_inoutput_flag=.false. - call multDiag(GWE, this%G(i), ww_e) - if (const_N) call multDiag(GWN, this%G(i), ww_n) - - call calc_GWAG(GWE, this%G(i), this%tbsys%H, GWE_H_G) - if (const_N) call calc_GWAG(GWN, this%G(i), this%tbsys%S, GWE_H_G) - - a = this%a(i) - az = this%a(i)*this%z(i) - - if (.not. this%tbsys%complex_matrices) then ! double instead of doing G(z) and G(conjg(z)) separately - a = 2.0_dp*a - az = 2.0_dp*az - endif - - ! const mu - ! F = Re d/dr sum_i Tr [ H a_i (z_i S-H)^-1 W ] - ! pull Re and sum in - ! = d/dr Tr [ H Re sum_i a_i (z_i S - H)^-1 W ] - ! chain rule - ! = Tr [ dH/dr Re sum_i a_i G_i W ] + Tr [ H Re sum_i a_i -G_i (z_i dS/dr - dH/dr) G_i W ] - ! expand - ! = Tr [ dH/dr Re sum_i a_i G_i W ] + Tr [ dH/dr Re sum_i a_i (G_i W H G_i ) + - ! dS/dr Re sum_i -a_i z_i G_i W H G_i ]; - ! = Tr [ dH/dr sum_i Re ( a_i G_i W + a_i G_i W H W G_i ) ] + Tr [ dS/dr Re (sum_i -az_i G_i W H G_i) ] - ! const N - ! F = Re d/dr Tr [ H sum_i a_i G_i WE - mu S sum_i a_i G_i WN ]; mu = dE / dN - ! = f_mu - mu Tr [ dS/dr Re sum_i a_i G_i WN ] - mu Tr [ S Re sum_i a_i -G_i (z_i dS/dr - dH/dr) G_i WN ] - ! = f_mu - mu Tr [ dS/dr Re sum_i a_i G_i WN ] - mu Tr [ dH/dr Re sum_i a_i G_i WN S G_i - - ! dS/dr Re sum_i az_i G_i WN S G_i ] - ! = f_mu + Tr [ dH/dr Re sum_i -mu a_i G_i WN S G_i ] + Tr [ dS/dr Re sum_i -mu a_i G_i WN + - ! dS/dr Re sum_i mu az_i G_i WN S G_i ] - -!$omp critical - call scaled_accum(this%mod_dm_H, -a, GWE) ! Tr dH/dr G W contribution to E - call scaled_accum(this%mod_dm_H, -a, GWE_H_G) ! Tr H dG/dr W = Tr H G dH/dr G W = Tr dH/dr G W H G - - if (const_N) then - call scaled_accum(this%mod_dm_H, a*chempot, GWN_S_G) ! Tr S dG/dr W = Tr S G dH/dr G W = Tr dH/dr G W S G - endif - - if (.not. this%tbsys%tbmodel%is_orthogonal) then - call scaled_accum(this%mod_dm_S, az, GWE_H_G) ! Tr H dG/dr W = Tr H G dS/dr G W = Tr dS/dr G W H G - if (const_N) then - call scaled_accum(this%mod_dm_S, a*chempot, GWN) ! Tr dS/dr G W contribution to mu N - call scaled_accum(this%mod_dm_S, -az*chempot, GWN_S_G) ! Tr S dG/dr W = Tr S G dS/dr G W = Tr dS/dr G W S G - endif - endif -!$omp end critical - - if (this%tbsys%complex_matrices) then ! need to do G(conjg(z)) explicitly - call multDiag(GWE, this%G_conjg(i), ww_e) - if (const_N) call multDiag(GWN, this%G_conjg(i), ww_n) - - call calc_GWAG(GWE, this%G_conjg(i), this%tbsys%H, GWE_H_G) - if (const_N) call calc_GWAG(GWN, this%G_conjg(i), this%tbsys%S, GWE_H_G) - - a = conjg(this%a(i)) - az = conjg(this%a(i)*this%z(i)) - -!$omp critical - call scaled_accum(this%mod_dm_H, -a, GWE) ! Tr dH/dr G W contribution to E - call scaled_accum(this%mod_dm_H, -a, GWE_H_G) ! Tr H dG/dr W = Tr H G dH/dr G W = Tr dH/dr G W H G - - if (const_N) then - call scaled_accum(this%mod_dm_H, a*chempot, GWN_S_G) ! Tr S dG/dr W = Tr S G dH/dr G W = Tr dH/dr G W S G - endif - - if (.not. this%tbsys%tbmodel%is_orthogonal) then - - call scaled_accum(this%mod_dm_S, az, GWE_H_G) ! Tr H dG/dr W = Tr H G dS/dr G W = Tr dS/dr G W H G - if (const_N) then - call scaled_accum(this%mod_dm_S, a*chempot, GWN) ! Tr dS/dr G W contribution to mu N - call scaled_accum(this%mod_dm_S, -az*chempot, GWN_S_G) ! Tr S dG/dr W = Tr S G dS/dr G W = Tr dS/dr G W S G - endif - endif -!$omp end critical - - endif - end do - call Finalise(GWE) - call Finalise(GWE_H_G) - if (const_N) then - call Finalise(GWN) - call Finalise(GWN_S_G) - endif -!$omp end parallel - - call Gsum_distrib_inplace(this, this%mod_dm_H) - if (.not. this%tbsys%tbmodel%is_orthogonal) then - call Gsum_distrib_inplace(this, this%mod_dm_S) - endif - - deallocate(ww_e, ww_n) - - -end subroutine - -function GreensFunctions_calc_chempot(this, w_e, w_n) - type(GreensFunctions), intent(in) :: this - real(dp), pointer :: w_e(:), w_n(:) - real(dp) :: GreensFunctions_calc_chempot - - integer i - real(dp) :: dE_dmu = 0.0_dp, dN_dmu = 0.0_dp - - complex(dp), allocatable :: pTr_GSGS(:), pTr_GSGH(:) - complex(dp) :: Tr_GSGS, Tr_GSGH - - type(TBMatrix) :: GS, GH - complex a - - call Initialise(GS, this%tbsys%N, this%tbsys%n_matrices, .true., scalapack_obj = this%tbsys%scalapack_my_matrices) - call Initialise(GH, this%tbsys%N, this%tbsys%n_matrices, .true., scalapack_obj = this%tbsys%scalapack_my_matrices) - - allocate(pTR_GSGS(this%tbsys%N_atoms)) - allocate(pTR_GSGH(this%tbsys%N_atoms)) - - do i=1, this%N_G - a = this%a(i) - - call matrix_product_sub(GS, this%G(i), this%tbsys%S) - call matrix_product_sub(GH, this%G(i), this%tbsys%H) - - pTr_GSGS = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, partial_TraceMult(GS, GS))) - call ksum_distrib_inplace(this%tbsys%kpoints, pTr_GSGS) - if (associated(w_n)) then - Tr_GSGS = sum(w_n*pTR_GSGS) - else - Tr_GSGS = sum(pTR_GSGS) - endif - - pTr_GSGH = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, partial_TraceMult(GS, GH))) - call ksum_distrib_inplace(this%tbsys%kpoints, pTr_GSGH) - if (associated(w_e)) then - Tr_GSGH = sum(w_e*pTR_GSGH) - else - Tr_GSGH = sum(pTR_GSGH) - endif - - dE_dmu = dE_dmu - 2.0_dp*a*Tr_GSGH - dN_dmu = dN_dmu - 2.0_dp*a*Tr_GSGS - end do - - dE_dmu = Gsum_distrib(this, dE_dmu) - dN_dmu = Gsum_distrib(this, dN_dmu) - - GreensFunctions_calc_chempot = dE_dmu / dN_dmu - -end function GreensFunctions_calc_chempot - -subroutine calc_GWAG(GW, G, A, GWAG) - type(TBMatrix), intent(in) :: GW, A, G - type(TBMatrix), intent(inout) :: GWAG - - type(TBMatrix) :: t - - call Initialise(t, GW) - - call matrix_product_sub(t, A, G) - call matrix_product_sub(GWAG, GW, t) - - call Finalise(t) -end subroutine calc_GWAG - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -subroutine GreensFunctions_Gsum_distrib_inplace_tbm(this, M) - type(GreensFunctions), intent(in) :: this - type(TBMatrix), intent(inout) :: M - - call sum_in_place(M, this%mpi_across_poles) -end subroutine - -subroutine GreensFunctions_Gsum_distrib_inplace_r2(this, M) - type(GreensFunctions), intent(in) :: this - real(dp), intent(inout) :: M(:,:) - - call sum_in_place(this%mpi_across_poles, M) -end subroutine - -subroutine GreensFunctions_Gsum_distrib_inplace_r3(this, M) - type(GreensFunctions), intent(in) :: this - real(dp), intent(inout) :: M(:,:,:) - - call sum_in_place(this%mpi_across_poles, M) -end subroutine - -subroutine GreensFunctions_Gsum_distrib_inplace_matd(this, M) - type(GreensFunctions), intent(in) :: this - type(MatrixD), intent(inout) :: M - - call sum_in_place(this%mpi_across_poles, M%data) -end subroutine - -function GreensFunctions_Gsum_distrib_d(this, d) - type(GreensFunctions), intent(in) :: this - real(dp), intent(in) :: d - real(dp) :: GreensFunctions_Gsum_distrib_d - - GreensFunctions_Gsum_distrib_d = sum(this%mpi_across_poles, d) -end function GreensFunctions_Gsum_distrib_d - -end module TB_GreensFunctions_module diff --git a/src/Potentials/TB_Kpoints.f95 b/src/Potentials/TB_Kpoints.f95 deleted file mode 100644 index 08e2629cc8..0000000000 --- a/src/Potentials/TB_Kpoints.f95 +++ /dev/null @@ -1,818 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!X -!X TB_KPoints Module -!X -!% This is a module for doing (weighted and unweighted) k-points sums, -!% sorting, computing phase factors. -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module TB_KPoints_module - -use system_module, only : dp, inoutput, initialise, INPUT, is_file_readable, NUMERICAL_ZERO, system_abort -use units_module -use extendable_str_module -use linearalgebra_module -use mpi_context_module -use quip_Common_module - -implicit none - -private - -character(len=20) :: kpt_default_file = "k_pt_mesh.data.xml" - -!% Structure for storing k-points and doing k-points sums (in parallel) -public :: KPoints -type KPoints - integer :: N = 0, g_N = 0 - real(dp), allocatable :: k_pts(:,:), weights(:), g_k_pts(:,:), g_weights(:) - logical :: non_gamma = .false. - logical :: no_sum_over_my_kpt = .false. - type(MPI_context) :: mpi_global, mpi_my_kpt, mpi_across_kpts -end type - -type(extendable_str), save :: cur_data -logical :: parse_in_kp -integer :: parse_cur_kp -type(KPoints), pointer :: parse_kp - -!% Initialise by reading parameters from file/inoutput -public :: Initialise -public :: KPoints_Initialise_filename -interface Initialise - module procedure KPoints_Initialise_inoutput, KPoints_Initialise_str, KPoints_Initialise_kp - module procedure KPoints_Initialise_mesh, KPoints_Initialise_density -end interface Initialise - -!% Prepare splitting according to mpi. -public :: init_mpi -interface init_mpi - module procedure KPoints_init_mpi -end interface init_mpi - -!% Interface to deallocate everything. -public :: Finalise -interface Finalise - module procedure KPoints_Finalise -end interface Finalise - -!% Free mpi_contexts generated in init_mpi. -public :: end_mpi -interface end_mpi - module procedure KPoints_end_mpi -end interface end_mpi - -!% Interface to print everything. -public :: Print -interface Print - module procedure KPoints_Print -end interface Print - -!% Calculate a phase factor for a given k-point and cell shift. -public :: calc_phase -interface calc_phase - module procedure KPoints_calc_phase -end interface - -!% Read params in XML format. -private :: KPoints_read_points_xml -interface read_points_xml - module procedure KPoints_read_points_xml -end interface read_points_xml - -!% Minimum over k-points of a quantity that's duplicated among processors of each k-point. -public :: min -interface min - module procedure KPoints_kmin_real, KPoints_kmin_real1 -end interface min - -!% Maximum over k-points of a quantity that's duplicated among processors of each k-point. -public :: max -interface max - module procedure KPoints_kmax_real, KPoints_kmax_real1 -end interface max - -!% Weighted sum over k-points of a quantity that's duplicated among processors of each k-point. -public :: ksum_dup -interface ksum_dup - module procedure KPoints_ksum_dup_r1, KPoints_ksum_dup_c1 -end interface ksum_dup - -!% Local weighted sum over k-points of a quantity. -public :: local_ksum -interface local_ksum - module procedure KPoints_local_ksum_real1, KPoints_local_ksum_real2 - module procedure KPoints_local_ksum_complex1, KPoints_local_ksum_complex2, KPoints_local_ksum_complex4 -end interface local_ksum - -!% UNweighted sum over k-points of an array that's distributed among processors of each k-point. -public :: ksum_distrib -interface ksum_distrib - module procedure KPoints_ksum_distrib_real -end interface ksum_distrib - -!% in-place UNweighted sum over k-points of an array that's distributed among processors of each k-point. -public :: ksum_distrib_inplace -interface ksum_distrib_inplace - module procedure KPoints_ksum_distrib_inplace_real1, KPoints_ksum_distrib_inplace_real2 - module procedure KPoints_ksum_distrib_inplace_complex1 -end interface ksum_distrib_inplace - -public :: collect -interface collect - module procedure Kpoints_collect_real2 -end interface collect - -contains - -subroutine KPoints_Initialise_filename(this, filename, mpi_obj) - type(KPoints), intent(inout) :: this - character(len=*), intent(in) :: filename - type(MPI_context), intent(in), optional :: mpi_obj - - type(inoutput) io - - call Initialise(io,filename,INPUT) - call Initialise(this,io,mpi_obj) - call Finalise(io) - -end subroutine - -subroutine KPoints_Initialise_inoutput(this, from_io, mpi_obj) - type(KPoints), intent(inout) :: this - type(inoutput), intent(inout), target, optional :: from_io - type(MPI_context), intent(in), optional :: mpi_obj - - logical file_present - type(inoutput), pointer :: in - type(extendable_str) :: ss - - file_present = .true. - - if (present(from_io)) then - in => from_io - else - if (is_file_readable(trim(kpt_default_file))) then - allocate(in) - call Initialise(in, trim(kpt_default_file), INPUT) - else - file_present = .false. - endif - endif - - call Initialise(ss) - if (file_present) then - if (present(mpi_obj)) then - call read(ss, in%unit, convert_to_string=.true., mpi_comm=mpi_obj%communicator, mpi_id=mpi_obj%my_proc) - else - call read(ss, in%unit, convert_to_string=.true.) - endif - endif - - call Initialise(this, string(ss), mpi_obj) - - call Finalise(ss) - -end subroutine - -subroutine KPoints_Initialise_str(this, from_str, mpi_obj) - type(KPoints), intent(inout) :: this - character(len=*), intent(in) :: from_str - type(MPI_context), intent(in), optional :: mpi_obj - - call Finalise(this) - - call KPoints_read_points_xml(this, from_str) - - call finish_initialise(this, mpi_obj) - -end subroutine KPoints_Initialise_str - -subroutine KPoints_Initialise_kp(this, from_kpoints, mpi_obj) - type(KPoints), intent(inout) :: this - type(KPoints), intent(in) :: from_kpoints - type(MPI_context), intent(in), optional :: mpi_obj - - call Finalise(this) - - this%non_gamma = from_kpoints%non_gamma - this%N = from_kpoints%g_N - if (this%N > 0) then - allocate(this%k_pts(3,this%N)) - allocate(this%weights(this%N)) - this%k_pts = from_kpoints%g_k_pts - this%weights = from_kpoints%g_weights - endif - - call finish_initialise(this, mpi_obj) - -end subroutine KPoints_Initialise_kp - -function reciprocal_lattice(lattice) - real(dp), intent(in) :: lattice(3,3) - real(dp) :: reciprocal_lattice(3,3) - - call matrix3x3_inverse(lattice,reciprocal_lattice) - reciprocal_lattice = -2.0_dp*PI*transpose(reciprocal_lattice) - -end function reciprocal_lattice - -subroutine KPoints_Initialise_density(this, lattice, k_space_density, monkhorst_pack, mpi_obj) - type(KPoints), intent(inout) :: this - real(dp), intent(in) :: lattice(3,3) - real(dp), intent(in) :: k_space_density - logical, intent(in), optional :: monkhorst_pack - type(MPI_context), intent(in), optional :: mpi_obj - - integer :: n(3) - real(dp) :: recip_lattice(3,3) - - if (k_space_density > 0.0_dp) then - recip_lattice = reciprocal_lattice(lattice) - - call matrix3x3_inverse(lattice,recip_lattice) - recip_lattice = -2.0_dp*PI*transpose(recip_lattice) - - n(1) = norm(recip_lattice(:,1))*k_space_density+1.0_dp-NUMERICAL_ZERO - n(2) = norm(recip_lattice(:,2))*k_space_density+1.0_dp-NUMERICAL_ZERO - n(3) = norm(recip_lattice(:,3))*k_space_density+1.0_dp-NUMERICAL_ZERO - where (n == 0) - n = 1 - end where - where (n > 1) - n = n + mod(n,2) - end where - else - n = 1 - endif - call initialise(this, n, monkhorst_pack, mpi_obj) - -end subroutine KPoints_initialise_density - -subroutine KPoints_Initialise_mesh(this, n, monkhorst_pack, mpi_obj) - type(KPoints), intent(inout) :: this - integer, intent(in) :: n(3) - logical, intent(in), optional :: monkhorst_pack - type(MPI_context), intent(in), optional :: mpi_obj - - integer :: i, i1, i2, i3, ik - integer :: min(3), max(3), step(3) - real(dp) :: denom(3) - logical :: shift(3) - real(dp), allocatable :: mesh_wt(:,:,:) - - call Finalise(this) - - if (minval(n) < 1) call system_abort("Called KPoints_initialise_mesh with garbage mesh size " // n) - - if (maxval(n) > 1) then - shift = .false. - if (present(monkhorst_pack)) then - if (monkhorst_pack .and. mod(n(1),2) == 0) then - shift(1) = .true. - end if - if (monkhorst_pack .and. mod(n(2),2) == 0) then - shift(2) = .true. - end if - if (monkhorst_pack .and. mod(n(3),2) == 0) then - shift(3) = .true. - end if - endif - - this%N = 0 - do i=1, 3 - if (shift(i)) then - if (mod(n(i),2) == 0) then - min(i) = -(n(i)-1) - max(i) = n(i)-1 - step(i) = 2 - denom(i) = 2*n(i) - else - call system_abort("kpoints_initialise_mesh tried to Monkhorst-Pack shift odd dimension " // i) - endif - else - if (mod(n(i),2) == 0) then - min(i) = -n(i)/2+1 - max(i) = n(i)/2 - step(i) = 1 - denom(i) = n(i) - else - if (n(i) == 1) then - min(i) = 0 - max(i) = 0 - step(i) = 1 - denom(i) = 1 - else - min(i) = -(n(i)-1)/2 - max(i) = (n(i)-1)/2 - step(i) = 1 - denom(i) = n(i) - end if - end if - endif - end do - - allocate(mesh_wt(min(1):max(1),min(2):max(2),min(3):max(3))) - mesh_wt = 1.0_dp - do i1=min(1), max(1), step(1) - do i2=min(2), max(2), step(2) - do i3=min(3), max(3), step(3) - if (-i1 >= min(1) .and. -i1 <= max(1) .and. & - -i2 >= min(2) .and. -i2 <= max(2) .and. & - -i3 >= min(3) .and. -i3 <= max(3)) then ! reflected k-point is in range - if ((i1 /= 0 .or. i2 /= 0 .or. i3 /= 0) .and. & - (mesh_wt(i1,i2,i3) > 0.0_dp .and. mesh_wt(-i1,-i2,-i3) > 0.0_dp)) then ! not gamma and both points have weight - mesh_wt(-i1,-i2,-i3) = mesh_wt(-i1,-i2,-i3) + mesh_wt(i1,i2,i3) - mesh_wt(i1,i2,i3) = 0.0_dp - endif - endif - end do - end do - end do - - this%N = 0 - do i1=min(1), max(1), step(1) - do i2=min(2), max(2), step(2) - do i3=min(3), max(3), step(3) - if (mesh_wt(i1,i2,i3) > 0.0_dp) this%N = this%N + 1 - end do - end do - end do - allocate(this%k_pts(3,this%N)) - allocate(this%weights(this%N)) - - ik = 1 - do i1=min(1), max(1), step(1) - do i2=min(2), max(2), step(2) - do i3=min(3), max(3), step(3) - if (mesh_wt(i1,i2,i3) > 0.0_dp) then - this%k_pts(1,ik) = real(i1,dp)/denom(1) - this%k_pts(2,ik) = real(i2,dp)/denom(2) - this%k_pts(3,ik) = real(i3,dp)/denom(3) - this%weights(ik) = mesh_wt(i1,i2,i3) - ik = ik + 1 - endif - end do - end do - end do - - deallocate(mesh_wt) - else ! maxval(n) <= 1 - this%non_gamma = .false. - this%N = 1 - allocate(this%k_pts(3,this%N)) - allocate(this%weights(this%N)) - this%k_pts = 0.0_dp - this%weights = 1.0_dp - endif - - call finish_initialise(this, mpi_obj) - -end subroutine KPoints_initialise_mesh - -subroutine finish_initialise(this, mpi_obj) - type(KPoints), intent(inout) :: this - type(MPI_Context), intent(in), optional :: mpi_obj - - if (this%N > 0) then - this%weights = this%weights / sum(this%weights) - this%non_gamma = (maxval(abs(this%k_pts(1:3,1:this%N))) > 0.0_dp) - else - this%N = 1 - allocate(this%k_pts(3,1)) - allocate(this%weights(1)) - this%k_pts(1:3,1) = 0.0_dp - this%weights(1) = 1.0_dp - this%non_gamma = .false. - endif - - this%g_N = this%N - allocate(this%g_k_pts(3,this%g_N)) - allocate(this%g_weights(this%g_N)) - this%g_k_pts = this%k_pts - this%g_weights = this%weights - - if (present(mpi_obj)) then - call KPoints_init_mpi(this, mpi_obj) - endif - -end subroutine finish_initialise - -subroutine KPoints_init_mpi(this, mpi_obj) - type(KPoints), intent(inout) :: this - type(MPI_context), intent(in) :: mpi_obj - - integer i - integer t, local_N - integer, allocatable :: local_index(:) - integer my_split_ident - integer n_procs_per_matrix - real(dp), allocatable :: t_k_pts(:,:), t_weights(:) - - this%mpi_global = mpi_obj - - if (this%g_N >= this%mpi_global%n_procs) then - n_procs_per_matrix = 1 - else - n_procs_per_matrix = this%mpi_global%n_procs/this%g_N - endif - - allocate(local_index(this%g_N)) - local_N = 0 - do i=0, this%g_N-1 - t = this%mpi_global%my_proc/n_procs_per_matrix - if (mod(i,this%mpi_global%n_procs) == t) then - local_N = local_N + 1 - local_index(local_N) = i+1 - endif - end do - - if (this%mpi_global%active) then - - my_split_ident = this%mpi_global%my_proc/n_procs_per_matrix - call split_context(this%mpi_global, my_split_ident, this%mpi_my_kpt) - - my_split_ident = this%mpi_my_kpt%my_proc - call split_context(this%mpi_global, my_split_ident, this%mpi_across_kpts) - endif - - allocate(t_k_pts(3,local_N)) - allocate(t_weights(local_N)) - t_k_pts(1:3,1:local_N) = this%g_k_pts(1:3,local_index(1:local_N)) - t_weights(1:local_N) = this%g_weights(local_index(1:local_N)) - - deallocate(this%k_pts) - deallocate(this%weights) - this%N = local_N - allocate(this%k_pts(3,this%N)) - allocate(this%weights(this%N)) - this%k_pts = t_k_pts - this%weights = t_weights - deallocate(t_k_pts) - deallocate(t_weights) - -end subroutine KPoints_init_mpi - -subroutine KP_characters_handler(in) - character(len=*), intent(in) :: in - - if (parse_in_kp) call concat(cur_data, in, keep_lf=.false.) -end subroutine - -subroutine KP_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: val - - if (name == "KPoints") then - parse_in_kp = .true. - parse_cur_kp=1 - call QUIP_FoX_get_value(attributes, "N", val, status) - if (status /= 0) & - call system_abort("parse kpoints xml: KPoints doesn't have N attribute") - read(val, *) parse_kp%N - if (parse_kp%N > 0) then - allocate(parse_kp%k_pts(3,parse_kp%N)) - allocate(parse_kp%weights(parse_kp%N)) - endif - elseif (parse_in_kp .and. name == "point") then - if (parse_cur_kp > parse_kp%N) & - call system_abort("parse kpoints xml found too many point elements " // parse_cur_kp // " > " // parse_kp%N) - call QUIP_FoX_get_value(attributes, "weight", val, status) - if (status /= 0) & - call system_abort("parse kpoints xml: point " // parse_cur_kp // " doesn't have weight attribute") - read(val, *) parse_kp%weights(parse_cur_kp) - endif - - call zero(cur_data) - -end subroutine - -subroutine KP_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - character(len=1024) :: str - - if (name == "KPoints") then - parse_in_kp = .false. - else if (parse_in_kp .and. name == "point") then - if (parse_cur_kp > parse_kp%N) & - call system_abort("parse kpoints xml: too many points specified, at least " // parse_cur_kp) - str = string(cur_data) - read(str, *) parse_kp%k_pts(1:3,parse_cur_kp) - parse_cur_kp = parse_cur_kp + 1 - call zero(cur_data) - endif - -end subroutine - -subroutine KPoints_read_points_xml(this, str) - type(KPoints), intent(inout), target :: this - character(len=*), intent(in) :: str - - type(xml_t) :: fxml - - if (len(trim(str)) <= 0) then - this%N = 0 - return - endif - - parse_cur_kp = 1 - parse_kp => this - - call open_xml_string(fxml, str) - - call parse(fxml, & - characters_handler=KP_characters_handler, & - startElement_handler=KP_startElement_handler, & - endElement_handler=KP_endElement_handler) - - call close_xml_t(fxml) - -end subroutine - -subroutine KPoints_Finalise(this) - type(KPoints), intent(inout) :: this - - call end_mpi(this) - - if (allocated(this%k_pts)) deallocate(this%k_pts) - if (allocated(this%weights)) deallocate(this%weights) - if (allocated(this%g_k_pts)) deallocate(this%g_k_pts) - if (allocated(this%g_weights)) deallocate(this%g_weights) - - this%N = 0 - this%g_N = 0 - this%non_gamma = .false. - -end subroutine KPoints_Finalise - -subroutine KPoints_end_mpi(this) - type(KPoints), intent(inout) :: this - - call free_context(this%mpi_my_kpt) - call free_context(this%mpi_across_kpts) -end subroutine KPoints_end_mpi - -subroutine KPoints_Print(this,file) - type(KPoints), intent(in) :: this - type(Inoutput), intent(inout),optional:: file - - integer::i - - call Print('KPoints : ', file=file) - - call Print ('KPoints : non_gamma ' // this%non_gamma, file=file) - call Print ('KPoints : g_N ' // this%g_N, file=file) - do i=1, this%g_N - call Print ('KPoints : g_k_pt ' // i // " " // this%g_k_pts(1:3,i) // " " // this%g_weights(i), file=file) - end do - -end subroutine KPoints_Print - -function KPoints_calc_phase(this, ik, shift) - type(KPoints), intent(in) :: this - integer, intent(in) :: ik - integer, intent(in) :: shift(3) - complex(dp) :: KPoints_calc_phase - - real(dp) phase - - phase = 2.0_dp*PI*sum(shift(1:3)*this%k_pts(1:3,ik)) - KPoints_calc_phase = cmplx(cos(phase), sin(phase), KIND(phase)) - -end function KPoints_calc_phase - - -function KPoints_kmin_real(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v - real(dp) :: KPoints_kmin_real - - if (this%mpi_my_kpt%my_proc == 0) then - KPoints_kmin_real = min(this%mpi_across_kpts, v) - endif - - call bcast(this%mpi_my_kpt, KPoints_kmin_real) -end function KPoints_kmin_real - -function KPoints_kmin_real1(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v(:) - real(dp) :: KPoints_kmin_real1 - - if (this%mpi_my_kpt%my_proc == 0) then - KPoints_kmin_real1 = min(this%mpi_across_kpts, minval(v)) - endif - - call bcast(this%mpi_my_kpt, KPoints_kmin_real1) -end function KPoints_kmin_real1 - -function KPoints_kmax_real(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v - real(dp) :: KPoints_kmax_real - - if (this%mpi_my_kpt%my_proc == 0) then - KPoints_kmax_real = max(this%mpi_across_kpts, v) - endif - - call bcast(this%mpi_my_kpt, KPoints_kmax_real) -end function KPoints_kmax_real - -function KPoints_kmax_real1(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v(:) - real(dp) :: KPoints_kmax_real1 - - if (this%mpi_my_kpt%my_proc == 0) then - KPoints_kmax_real1 = max(this%mpi_across_kpts, maxval(v)) - endif - - call bcast(this%mpi_my_kpt, KPoints_kmax_real1) -end function KPoints_kmax_real1 - -function KPoints_ksum_dup_r1(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v(:) - real(dp) :: KPoints_ksum_dup_r1 - - if (this%mpi_my_kpt%my_proc == 0) then - if (size(v) /= size(this%weights)) call System_abort("size mismatch in KPoints_ksum_dup_r1") - KPoints_ksum_dup_r1 = sum(this%mpi_across_kpts, dot_product(v,this%weights)) - endif - - call bcast(this%mpi_my_kpt, KPoints_ksum_dup_r1) -end function KPoints_ksum_dup_r1 - -function KPoints_ksum_dup_c1(this, v) - type(KPoints), intent(in) :: this - complex(dp), intent(in) :: v(:) - complex(dp) :: KPoints_ksum_dup_c1 - - if (this%mpi_my_kpt%my_proc == 0) then - if (size(v) /= size(this%weights)) call System_abort("size mismatch in KPoints_ksum_dup_c1") - KPoints_ksum_dup_c1 = sum(this%mpi_across_kpts, dot_product(v,this%weights)) - endif - - call bcast(this%mpi_my_kpt, KPoints_ksum_dup_c1) -end function KPoints_ksum_dup_c1 - -function KPoints_local_ksum_real1(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v(:) - real(dp) :: KPoints_local_ksum_real1 - - KPoints_local_ksum_real1 = dot_product(v,this%weights) -end function KPoints_local_ksum_real1 - -function KPoints_local_ksum_real2(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v(:,:) - real(dp) :: KPoints_local_ksum_real2(size(v,1)) - - integer ik - - KPoints_local_ksum_real2(:) = 0.0_dp - do ik=1, this%N - KPoints_local_ksum_real2(:) = KPoints_local_ksum_real2(:) + v(:,ik)*this%weights(ik) - end do -end function KPoints_local_ksum_real2 - -function KPoints_local_ksum_complex1(this, v) - type(KPoints), intent(in) :: this - complex(dp), intent(in) :: v(:) - complex(dp) :: KPoints_local_ksum_complex1 - - KPoints_local_ksum_complex1 = dot_product(v,this%weights) -end function KPoints_local_ksum_complex1 - -function KPoints_local_ksum_complex2(this, v) - type(KPoints), intent(in) :: this - complex(dp), intent(in) :: v(:,:) - complex(dp) :: KPoints_local_ksum_complex2(size(v,1)) - - integer ik - - KPoints_local_ksum_complex2(:) = 0.0_dp - do ik=1, this%N - KPoints_local_ksum_complex2(:) = KPoints_local_ksum_complex2(:) + v(:,ik)*this%weights(ik) - end do -end function KPoints_local_ksum_complex2 - -function KPoints_local_ksum_complex4(this, v) - type(KPoints), intent(in) :: this - complex(dp), intent(in) :: v(:,:,:,:) - complex(dp) :: KPoints_local_ksum_complex4(size(v,1),size(v,2),size(v,3)) - - integer ik - - KPoints_local_ksum_complex4(:,:,:) = 0.0_dp - do ik=1, this%N - KPoints_local_ksum_complex4(:,:,:) = KPoints_local_ksum_complex4(:,:,:) + v(:,:,:,ik)*this%weights(ik) - end do -end function KPoints_local_ksum_complex4 - -function KPoints_ksum_distrib_real(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v - real(dp) :: KPoints_ksum_distrib_real - - if (this%no_sum_over_my_kpt) then - KPoints_ksum_distrib_real = sum(this%mpi_across_kpts, v) - else - KPoints_ksum_distrib_real = sum(this%mpi_across_kpts, sum(this%mpi_my_kpt, v)) - endif -end function KPoints_ksum_distrib_real - -subroutine KPoints_ksum_distrib_inplace_real2(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(inout) :: v(:,:) - - if (.not. this%no_sum_over_my_kpt) then - call sum_in_place(this%mpi_my_kpt, v) - endif - call sum_in_place(this%mpi_across_kpts, v) -end subroutine KPoints_ksum_distrib_inplace_real2 - -subroutine KPoints_ksum_distrib_inplace_real1(this, v) - type(KPoints), intent(in) :: this - real(dp), intent(inout) :: v(:) - - if (.not. this%no_sum_over_my_kpt) then - call sum_in_place(this%mpi_my_kpt, v) - endif - call sum_in_place(this%mpi_across_kpts, v) -end subroutine KPoints_ksum_distrib_inplace_real1 - -subroutine KPoints_ksum_distrib_inplace_complex1(this, v) - type(KPoints), intent(in) :: this - complex(dp), intent(inout) :: v(:) - - if (.not. this%no_sum_over_my_kpt) then - call sum_in_place(this%mpi_my_kpt, v) - endif - call sum_in_place(this%mpi_across_kpts, v) -end subroutine KPoints_ksum_distrib_inplace_complex1 - -subroutine KPoints_collect_real2(this, v_in, v_out) - type(KPoints), intent(in) :: this - real(dp), intent(in) :: v_in(:,:) - real(dp), intent(out) :: v_out(:,:) - - if (size(v_in,1) /= size(v_out,1)) then - call system_abort("Called KPoints_collect_real2 with vector size mismatch v_in " // & - size(v_in,1) // " v_out " // size(v_out,1)) - endif - - if (size(v_in,2) /= this%N) then - call system_abort("Called KPoints_collect_real2 with local N_k mismatch v_in " // & - size(v_in,2) // " this%N " // this%N) - end if - - if (size(v_out,2) /= this%g_N) then - call system_abort("Called KPoints_collect_real2 with local N_k mismatch v_in " // & - size(v_in,2) // " this%N " // this%N) - end if - - call allgatherv(this%mpi_across_kpts, v_in, v_out) -end subroutine KPoints_collect_real2 - -end module TB_KPoints_module diff --git a/src/Potentials/TB_Mixing.f95 b/src/Potentials/TB_Mixing.f95 deleted file mode 100644 index 8c9f5eea6c..0000000000 --- a/src/Potentials/TB_Mixing.f95 +++ /dev/null @@ -1,518 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X TB_Mixing module -!X -!% do charge mixing for self-consistent TB models -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -module tb_mixing_module - -use System_module -use linearalgebra_module -implicit none - -private - -integer:: n_hist = 20 - -! Broyden -real(dp), allocatable:: u(:,:), dF(:,:), last_F(:), last_n(:) -real(dp), allocatable:: dn_mm1(:) -real(dp), allocatable:: a(:,:), beta(:,:), gamma(:,:), c(:,:), t(:,:), w(:) - -! Ridders -real(dp):: xmin, fmin, xmax, fmax -real(dp):: bracket_step -logical:: need_bracket = .true. -real(dp):: x3, f3, x4, f4 -logical:: got_f3, got_f4 - -public :: do_mix_broyden -interface do_mix_broyden - module procedure do_mix_broyden_array, do_mix_broyden_scalar -end interface do_mix_broyden - -public :: do_mix_simple -interface do_mix_simple - module procedure do_mix_simple_array, do_mix_simple_scalar -end interface do_mix_simple - -public :: do_ridders_residual - -contains - -! From Johnson PRB vol. 38, p. 12807 -subroutine do_mix_broyden_array(iter, n, F, np1, alpha, w0) - integer, intent(in) :: iter - real(dp), intent(in) :: n(:), F(:) - real(dp), intent(out) :: np1(:) - real(dp), intent(in) :: alpha, w0 - - integer mi, i, j, ki, li, ni - integer :: iter_offset - integer :: effective_iter - real(dp) :: dF_norm - - iter_offset = 0 - - if (realloc_hist_dep_stuff()) then - if (iter /= 1) then - call print("WARNING: had to realloc hist_dep_stuff but iter /= 1") - iter_offset = iter-1 - endif - endif - if (realloc_size_dep_stuff(size(n))) then - if (iter /= 1) then - call print("WARNING:had to realloc size_dep_stuff but iter /= 1") - iter_offset = iter-1 - endif - endif - - effective_iter = iter - iter_offset - - mi = min(effective_iter, n_hist) - - np1 = n + alpha * F - - if (effective_iter == 1) then - last_F = F - last_n = n - else - if (effective_iter .gt. n_hist) then - do i=1, mi-2 - dF(:,i) = dF(:,i+1) - w(i) = w(i+1) - u(:,i) = u(:,i+1) - end do - do i=1, mi-2 - do j=1, mi-2 - a(i,j) = a(i+1,j+1) - end do - end do - do i=1, mi-1 - do j=1, mi-1 - c(i,j) = c(i,j+1) - gamma(i,j) = gamma(i+1,j) - end do - end do - end if ! iter > n_hist - - ! calculate dF_(m-1) - dF(:,mi-1) = F(:) - last_F(:) - !!!dF_norm = sqrt(sum(dF**2)) - dF_norm = sqrt(sum(dF(:,mi-1)**2)) - dF(:,mi-1) = dF(:,mi-1) / dF_norm - last_F = F - -!! dF(:,mi-1) -!! w(mi-1) -!! a(1:mi-1,mi-1) a(mi-1,1:mi-1) -!! u(1:N_A,mi-1) -!! c(1:mi-1,mi) -!! gamma(mi,1:mi-1) - - ! calculate dn_(m-1) - dn_mm1(:) = (n(:) - last_n(:)) / dF_norm - last_n = n - - ! as per DD Johnson's suggestion in paper - w(mi-1) = min(1.0_dp/sqrt(sum(F**2)), 1.0_dp) - - ! update a_ij - do i=1, mi-1 - a(i,mi-1) = w(i)*w(mi-1)*sum(dF(:,i)*dF(:,mi-1)) - if (i .ne. mi-1) then - a(mi-1,i) = a(i,mi-1) - end if - end do - - ! compute beta = (w0^2 + a ) ^ -1 - t = a - do i=1, mi-1 - t(i,i) = t(i,i) + w0**2 - end do - call inverse(t(1:mi-1,1:mi-1), beta(1:mi-1,1:mi-1), .false.) - - ! compute u_(m-1) - u(:,mi-1) = alpha*dF(:,mi-1) + dn_mm1(:) - - ! compute c_k^m - do ki=1, mi-1 - c(ki,mi) = w(ki)*sum(dF(:,ki)*F(:)) - end do - do li=1, mi-1 - gamma(mi,li) = 0.0_dp - do ki=1, mi-1 - gamma(mi,li) = gamma(mi,li) + c(ki,mi)*beta(ki,li) - end do - end do - do ni=1, mi-1 - np1(:) = np1(:) - w(ni)*gamma(mi,ni)*u(:,ni) - end do - endif - -end subroutine do_mix_broyden_array - -subroutine do_mix_broyden_scalar(iter, n, F, np1, alpha, w0) - integer, intent(in) :: iter - real(dp), intent(in) :: n, F - real(dp), intent(out) :: np1 - real(dp), intent(in) :: alpha, w0 - - real(dp) :: na(1), Fa(1), np1a(1) - - na = n - Fa = F - np1a = np1 - - call do_mix_broyden(iter, na, Fa, np1a, alpha, w0) - - np1 = np1a(1) - -end subroutine do_mix_broyden_scalar - -subroutine do_mix_simple_array(iter, n, F, np1, alpha) - integer, intent(in) :: iter - real(dp), intent(in) :: n(:), F(:) - real(dp), intent(out) :: np1(:) - real(dp), intent(in) :: alpha - - np1 = n + alpha * F - -end subroutine do_mix_simple_array - -subroutine do_mix_simple_scalar(iter, n, F, np1, alpha) - integer, intent(in) :: iter - real(dp), intent(in) :: n, F - real(dp), intent(out) :: np1 - real(dp), intent(in) :: alpha - - real(dp) :: na(1), Fa(1), np1a(1) - - na = n - Fa = F - np1a = np1 - - call do_mix_simple(iter, na, Fa, np1a, alpha) - - np1 = np1a(1) - -end subroutine do_mix_simple_scalar - -function realloc_hist_dep_stuff() - logical :: realloc_hist_dep_stuff - - realloc_hist_dep_stuff = .false. - - if (allocated(a)) then - if (size(a,1) /= n_hist .or. size(a,2) /= n_hist) then - deallocate(a) - endif - endif - if (.not. allocated(a)) then - allocate(a(n_hist,n_hist)) - realloc_hist_dep_stuff = .true. - a = 0.0_dp - endif - - if (allocated(beta)) then - if (size(beta,1) /= n_hist .or. size(beta,2) /= n_hist) then - deallocate(beta) - endif - endif - if (.not. allocated(beta)) then - allocate(beta(n_hist,n_hist)) - realloc_hist_dep_stuff = .true. - beta = 0.0_dp - endif - - if (allocated(gamma)) then - if (size(gamma,1) /= n_hist .or. size(gamma,2) /= n_hist) then - deallocate(gamma) - endif - endif - if (.not. allocated(gamma)) then - allocate(gamma(n_hist,n_hist)) - realloc_hist_dep_stuff = .true. - endif - gamma = 0.0_dp - - if (allocated(c)) then - if (size(c,1) /= n_hist .or. size(c,2) /= n_hist) then - deallocate(c) - endif - endif - if (.not. allocated(c)) then - allocate(c(n_hist,n_hist)) - realloc_hist_dep_stuff = .true. - c = 0.0_dp - endif - - if (allocated(t)) then - if (size(t,1) /= n_hist .or. size(t,2) /= n_hist) then - deallocate(t) - endif - endif - if (.not. allocated(t)) then - allocate(t(n_hist,n_hist)) - realloc_hist_dep_stuff = .true. - t = 0.0_dp - endif - - if (allocated(w)) then - if (size(w) /= n_hist) then - deallocate(w) - endif - endif - if (.not. allocated(w)) then - allocate(w(n_hist)) - realloc_hist_dep_stuff = .true. - w = 0.0_dp - endif - -end function realloc_hist_dep_stuff - -function realloc_size_dep_stuff(new_n) - integer, intent(in) :: new_n - logical :: realloc_size_dep_stuff - - realloc_size_dep_stuff = .false. - - if (allocated(u)) then - if (size(u,1) /= new_n .or. size(u,2) /= n_hist) then - deallocate(u) - endif - endif - if (.not. allocated(u)) then - allocate(u(new_n, n_hist)) - realloc_size_dep_stuff = .true. - u = 0.0_dp - endif - - if (allocated(dF)) then - if (size(dF,1) /= new_n .or. size(dF,2) /= n_hist) then - deallocate(dF) - endif - endif - if (.not. allocated(dF)) then - allocate(dF(new_n, n_hist)) - realloc_size_dep_stuff = .true. - dF = 0.0_dp - endif - - if (allocated(last_F)) then - if (size(last_F) /= new_n) then - deallocate(last_F) - endif - endif - if (.not. allocated(last_F)) then - allocate(last_F(new_n)) - realloc_size_dep_stuff = .true. - last_F = 0.0_dp - endif - - if (allocated(last_n)) then - if (size(last_n) /= new_n) then - deallocate(last_n) - endif - endif - if (.not. allocated(last_n)) then - allocate(last_n(new_n)) - realloc_size_dep_stuff = .true. - last_n = 0.0_dp - endif - - if (allocated(dn_mm1)) then - if (size(dn_mm1) /= new_n) then - deallocate(dn_mm1) - endif - endif - if (.not. allocated(dn_mm1)) then - allocate(dn_mm1(new_n)) - realloc_size_dep_stuff = .true. - dn_mm1 = 0.0_dp - endif - -end function realloc_size_dep_stuff - -!subroutine inverse (ns, n, a, b, err) -! integer, intent(in) :: ns, n -! real(dp), intent(inout) :: a(ns,ns) -! real(dp), intent(out) :: b(ns,ns) -! integer, intent(out) :: err -! -! real(dp) :: td(ns), ad(ns), bd(ns) -! -! integer i, j, k -! -! do i=1, n -! if (dabs(a(i,i)) .lt. 1.0D-12) then -! print *, "Matrix has zero diagonal element ", i -! err = 1 -! return -! end if -! end do -! -! if (n .eq. 1) then -! b(1,1) = 1.0_dp/a(1,1) -! return -! end if -! -! b = 0.0_dp -! do i=1, n -! b(i,i) = 1.0_dp -! end do -! -! do i=1, n -! do j=1, n -! td(j) = a(j,i) / a(i,i) -! end do -! -! td(i) = 0.0_dp -! do k=1, n -! bd(k) = b(i,k) -! ad(k) = a(i,k) -! end do -! -! do k=1, n -! do j=1, n -! b(j,k) = b(j,k) - (td(j)*bd(k)) -! a(j,k) = a(j,k) - (td(j)*ad(k)) -! end do -! end do -! -! end do -! -! do i=1, n -! do j=1, n -! b(j,i) = b(j,i) / a(j,j) -! end do -! end do -! -! err = 0 -! -!end subroutine - -! From Numerical Recipes in C++, 2nd ed. -subroutine do_ridders_residual(iter, cur_x, cur_f, next_x) - integer, intent(in) :: iter - real(dp), intent(in) :: cur_x, cur_f - real(dp), intent(out) :: next_x - - real(dp) t, num, denom - - if (iter == 1) need_bracket = .true. - - if (need_bracket) then - if (iter == 1) then - xmin = cur_x; - fmin = cur_f; - next_x = 0.99_dp*cur_x + 0.01_dp*(cur_f+cur_x); - bracket_step = next_x - cur_x; - return - endif - if (sign(1.0_dp,cur_f) == sign(1.0_dp,fmin)) then - bracket_step = bracket_step*1.5 - if (abs(cur_f) < abs(fmin)) then - xmin = cur_x - fmin = cur_f - next_x = cur_x + bracket_step - else - next_x = cur_x - bracket_step - endif - return - else - xmax = cur_x - fmax = cur_f - if (xmin > xmax) then - t = xmin; xmin = xmax; xmax = t - t = fmin; fmin = fmax; fmax = t - endif - x3 = (xmin+xmax)/2.0_dp - next_x = x3 - need_bracket = .false. - got_f4 = .false. - got_f3 = .true. - return - endif - endif - - if (got_f3) then - f3 = cur_f - num = sign(1.0_dp,fmin-fmax)*f3 - denom = sqrt(f3*f3 - fmin*fmax) - if (denom == 0.0) then - next_x = x3 - return - endif - x4 = x3 + (x3-xmin)*num/denom - next_x = x4; - got_f3 = .false. - got_f4 = .true. - return - endif - - if (got_f4) then - f4 = cur_f - if (x3 < x4) then - if (sign(1.0_dp,fmin) /= sign (1.0_dp,f3)) then - xmax = x3 - fmax = f3 - else if (sign(1.0_dp,f3) /= sign(1.0_dp,f4)) then - xmin = x3; fmin = f3; - xmax = x4; fmax = f4; - else if (sign(1.0_dp,f4) /= sign(1.0_dp,fmax)) then - xmin = x4; fmin = f4; - endif - else - if (sign(1.0_dp,fmin) /= sign (1.0_dp,f4)) then - xmax = x4; - fmax = f4; - else if (sign(1.0_dp,f4) /= sign(1.0_dp,f3)) then - xmin = x4; fmin = f4; - xmax = x3; fmax = f3; - else if (sign(1.0_dp,f3) /= sign(1.0_dp,fmax)) then - xmin = x3; fmin = f3; - endif - endif - - x3 = (xmin+xmax)/2.0_dp; - next_x = x3; - got_f4 = .false. - got_f3 = .true. - return - endif -end subroutine do_ridders_residual - -end module tb_mixing_module diff --git a/src/Potentials/Yukawa.f95 b/src/Potentials/Yukawa.f95 deleted file mode 100644 index d9095bb0a4..0000000000 --- a/src/Potentials/Yukawa.f95 +++ /dev/null @@ -1,594 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module Yukawa_module - -use error_module -use system_module, only : dp, optional_default, system_timer -use units_module -use linearalgebra_module -use mpi_context_module -use atoms_types_module -use atoms_module -use functions_module -use QUIP_Common_module - -implicit none -private - -public :: yukawa_charges, yukawa_dipoles - -real(dp), parameter :: sqrt_2 = 1.41421356237309504880168872421_dp -real(dp), parameter :: sqrt_pi = 1.77245385090551602729816748334_dp - -contains - -!% Charge-charge interactions, screened by Yukawa function -subroutine yukawa_charges(at, charge, cutoff, alpha, smoothlength, & - e, local_e, f, virial, efield, mpi, atom_mask_name, source_mask_name, type_of_atomic_num, pseudise, pseudise_sigma, grid_size, error) - type(Atoms), intent(inout) :: at - real(dp), dimension(:), intent(in) :: charge !% charges, in units of the electronic charge - real(dp), intent(in) :: cutoff !% cutoff distance in A - real(dp), intent(in) :: alpha !% inverse screening length, in $A^{-1}$ - real(dp), intent(in) :: smoothlength !% distance over which potential is smoothly turned off, in A - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:) - real(dp), intent(out), optional :: virial(3,3) - real(dp), intent(out), optional :: efield(:,:) - type(MPI_Context), intent(in), optional :: mpi - character(len=*), optional, intent(in) :: atom_mask_name, source_mask_name - integer, intent(in), optional :: type_of_atomic_num(:) - logical, optional, intent(in) :: pseudise - real(dp), optional, intent(in) :: pseudise_sigma(:) - real(dp), optional, intent(in) :: grid_size - integer, intent(out), optional :: error - - real(dp) :: erf_val, erf_deriv - integer i, j, m, ti, tj - real(dp) :: r_ij, u_ij(3), zv2, gamjir, gamjir3, gamjir2, fc, dfc_dr - real(dp) :: de, dforce, expfactor, defield(3) - logical :: i_is_min_image, j_is_min_image, do_pseudise - real(dp) :: private_virial(3,3), private_e, sigma - real(dp), allocatable :: private_f(:,:), private_efield(:,:), private_local_e(:) - logical, pointer, dimension(:) :: atom_mask, source_mask - real(dp) :: yukcutoff, yukalpha, yuksmoothlength - - INIT_ERROR(error) - call system_timer('yukawa_charges') - - ! Unit conversion of arguments from eV/A/fs to atomic units - ! (charges are not affected) - yukcutoff = cutoff/BOHR - yukalpha = alpha*BOHR - yuksmoothlength = smoothlength/BOHR - - do_pseudise = optional_default(.false., pseudise) - if (do_pseudise .and. (.not. present(pseudise_sigma) .or. .not. present(type_of_atomic_num))) then - RAISE_ERROR("pseudise=T but pseudise_sigma or type_of_atomic_num arguments not present", error) - end if - atom_mask => null() - if (present(atom_mask_name)) then - if (trim(atom_mask_name) /= '') then - call assign_property_pointer(at, atom_mask_name, atom_mask, error) - PASS_ERROR(error) - end if - end if - - source_mask => null() - if (present(source_mask_name)) then - if (trim(source_mask_name) /= '') then - call assign_property_pointer(at, source_mask_name, source_mask, error) - PASS_ERROR(error) - end if - end if - - !$omp parallel default(none) shared(mpi, charge, at, e, local_e, f, virial, efield, atom_mask, source_mask, yukcutoff, cutoff, yukalpha, yuksmoothlength, grid_size, do_pseudise, pseudise_sigma, type_of_atomic_num) private(i, j, m, r_ij, u_ij, zv2, gamjir, gamjir3, gamjir2, fc, dfc_dr, de, dforce, expfactor, i_is_min_image, j_is_min_image, private_virial, private_e, private_f, private_local_e, private_efield, erf_val, erf_deriv, sigma, defield, ti, tj) - - if (present(e)) private_e = 0.0_dp - if (present(local_e)) then - allocate(private_local_e(at%N)) - private_local_e = 0.0_dp - endif - if (present(f)) then - allocate(private_f(3,at%N)) - private_f = 0.0_dp - endif - if (present(efield)) then - allocate(private_efield(3,at%N)) - private_efield = 0.0_dp - end if - if (present(virial)) private_virial = 0.0_dp - - !$omp do schedule(runtime) - do i=1, at%n - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if (associated(atom_mask)) then - if (.not. atom_mask(i)) cycle - i_is_min_image = .false. - else - if (allocated(at%connect%is_min_image)) then - i_is_min_image = at%connect%is_min_image(i) - else - i_is_min_image = is_min_image(at, i) - end if - end if - - ti = 0 - if (do_pseudise .and. at%Z(i) /= 0) ti = get_type(type_of_atomic_num, at%Z(i)) - - do m = 1, n_neighbours(at, i) - - j = neighbour(at, i, m, distance=r_ij, cosines=u_ij, max_dist=cutoff) - if (j <= 0) cycle - - if (associated(source_mask)) then - if (.not. source_mask(j)) cycle - end if - - if (r_ij .feq. 0.0_dp) then - if (present(grid_size)) then - r_ij = grid_size/BOHR - else - cycle - end if - end if - - if (allocated(at%connect%is_min_image)) then - j_is_min_image = at%connect%is_min_image(j) - else - j_is_min_image = is_min_image(at, j) - end if - - if (i < j .and. i_is_min_image .and. j_is_min_image) cycle - - r_ij = r_ij/BOHR - zv2 = charge(i)*charge(j) - - tj = 0 - if (do_pseudise .and. at%Z(j) /= 0) tj = get_type(type_of_atomic_num, at%Z(j)) - - gamjir = zv2/r_ij - gamjir3 = gamjir/(r_ij**2.0_dp) - gamjir2 = zv2/(r_ij**2.0_dp) - expfactor = exp(-yukalpha*r_ij) - - call smooth_cutoff(r_ij, yukcutoff-yuksmoothlength, yuksmoothlength, fc, dfc_dr) - - if (do_pseudise) then - sigma = pseudise_sigma(tj)/BOHR - erf_val = 1.0_dp - erf_deriv = 0.0_dp - ! pseudise if sigma > 0, correction for r >= 9s is < 1e-16 - if (sigma > 0.0_dp .and. r_ij < 9.0_dp*sigma) then - erf_val = erf(r_ij/(sqrt_2 * sigma)) - erf_deriv = sqrt_2/(sqrt_pi*sigma)*exp(-r_ij*r_ij/(2.0_dp*sigma*sigma)) - end if - end if - - if (present(e) .or. present(local_e)) then - de = gamjir*expfactor*fc - if (do_pseudise) de = de*erf_val - - if (present(e)) then - if (i_is_min_image .and. j_is_min_image) then - private_e = private_e + de - else - private_e = private_e + 0.5_dp*de - end if - end if - if (present(local_e)) then - private_local_e(i) = private_local_e(i) + 0.5_dp*de - if (i_is_min_image .and. j_is_min_image) private_local_e(j) = private_local_e(j) + 0.5_dp*de - end if - end if - - if (present(f) .or. present(virial) .or. present(efield)) then - dforce = gamjir3*expfactor*fc*r_ij + gamjir*(yukalpha*fc - dfc_dr)*expfactor - if (do_pseudise) dforce = dforce*erf_val - gamjir*expfactor*fc*erf_deriv - - if (present(f)) then - private_f(:,i) = private_f(:,i) - dforce*u_ij - if (i_is_min_image .and. j_is_min_image) private_f(:,j) = private_f(:,j) + dforce*u_ij - end if - - if (present(virial)) then - if (i_is_min_image .and. j_is_min_image) then - private_virial = private_virial + dforce*(u_ij .outer. u_ij)*r_ij - else - private_virial = private_virial + 0.5_dp*dforce*(u_ij .outer. u_ij)*r_ij - end if - end if - - if (present(efield)) then - defield = gamjir3*expfactor*fc*u_ij*r_ij - if (do_pseudise) defield = defield*erf_val - private_efield(:,i) = private_efield(:,i) - defield/charge(i) - if (i_is_min_image .and. j_is_min_image) private_efield(:,j) = private_efield(:,j) + defield/charge(j) - end if - end if - - end do - end do - - if (present(mpi)) then - if (mpi%active) then - if (present(e)) private_e = sum(mpi, private_e) - if (present(local_e)) call sum_in_place(mpi, private_local_e) - if (present(f)) call sum_in_place(mpi, private_f) - if (present(virial)) call sum_in_place(mpi, private_virial) - if (present(efield)) call sum_in_place(mpi, private_efield) - end if - end if - - ! Unit conversion of output to eV/A/fs - !$omp critical - if (present(e)) e = e + private_e*HARTREE - if (present(local_e)) local_e = local_e + private_local_e*HARTREE - if (present(f)) f = f + private_f*(HARTREE/BOHR) - if (present(virial)) virial = virial + private_virial*HARTREE - if (present(efield)) efield = efield + private_efield*(HARTREE/BOHR) - !$omp end critical - - if (allocated(private_f)) deallocate(private_f) - if (allocated(private_local_e)) deallocate(private_local_e) - if (allocated(private_efield)) deallocate(private_efield) - - !$omp end parallel - - call system_timer('yukawa_charges') - - end subroutine yukawa_charges - - -!% Charge-dipole and dipole-dipole interactions, screened by Yukawa function -subroutine yukawa_dipoles(at, charge, dip, cutoff, alpha, smoothlength, pol, b_pol, c_pol, & - type_of_atomic_num, tdip_sr, e, local_e, f, virial, efield, mpi, atom_mask_name, source_mask_name, pseudise, & - pseudise_sigma, grid_size, error) -#ifdef _OPENMP - use omp_lib -#endif - - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: charge(:) !% charges, in units of the electronic charge - real(dp), intent(in) :: dip(:,:) !% (3,N) array of dipoles moments in units of (electron charge)*A - real(dp), intent(in) :: cutoff !% cutoff distance in A - real(dp), intent(in) :: alpha !% inverse screening length, in $A^{-1}$ - real(dp), intent(in) :: smoothlength !% distance over which potential is smoothly turned off, in A - real(dp), intent(in) :: pol(:) !% polarisabilities of each species, ordered by type_num - real(dp), intent(in) :: b_pol(:,:), c_pol(:,:) !% parameters for Madden short-range dipole moments - integer, intent(in) :: type_of_atomic_num(:) - logical, intent(in) :: tdip_sr - real(dp), intent(out), optional :: e, local_e(:) - real(dp), intent(out), optional :: f(:,:) - real(dp), intent(out), optional :: virial(3,3) - real(dp), intent(out), optional :: efield(:,:) - type(MPI_Context), intent(in), optional :: mpi - character(len=*), optional, intent(in) :: atom_mask_name, source_mask_name - logical, optional, intent(in) :: pseudise - real(dp), optional, intent(in) :: pseudise_sigma(:) - real(dp), optional, intent(in) :: grid_size - integer, intent(out), optional :: error - - integer i, j, m, ti, tj, k - real(dp) :: r_ij, u_ij(3), gamjir3, gamjir2, fc, dfc_dr, de, sigma, dforce(3), erf_val, erf_deriv - real(dp) :: expfactor, dipi(3), dipj(3), qj, qi, pp, pri, prj, defield_i(3), defield_j(3) - real(dp) :: de_ind, de_dd, de_qd, dfqdip(3), dfdipdip(3), factor1, dist3, dist5 - real(dp) :: const1, const2, factork, de_sr, df_sr(3), gij, dgijdrij, bij, cij - logical :: i_is_min_image, j_is_min_image, tpoli, tpolj, qipj, qjpi, pipj, do_pseudise - - real(dp) :: private_virial(3,3), private_e - real(dp), allocatable :: private_f(:,:), private_local_e(:), private_efield(:,:) - logical, pointer, dimension(:) :: atom_mask, source_mask - - real(dp) :: yukcutoff, yukalpha, yuksmoothlength, yukpol(size(pol)) - - INIT_ERROR(error) - call system_timer('yukawa_dipoles') - - ! Unit conversion of arguments from eV/A/fs to atomic units - yukcutoff = cutoff/BOHR - yukalpha = alpha*BOHR - yuksmoothlength = smoothlength/BOHR - yukpol = pol/(BOHR**2/HARTREE) - - do_pseudise = optional_default(.false., pseudise) - if (do_pseudise .and. .not. present(pseudise_sigma)) then - RAISE_ERROR("pseudise=T but pseudise_sigma argument not present", error) - end if - - atom_mask => null() - if (present(atom_mask_name)) then - if (trim(atom_mask_name) /= '') then - call assign_property_pointer(at, atom_mask_name, atom_mask, error) - PASS_ERROR(error) - end if - end if - - source_mask => null() - if (present(source_mask_name)) then - if (trim(source_mask_name) /= '') then - call assign_property_pointer(at, source_mask_name, source_mask, error) - PASS_ERROR(error) - end if - end if - - !$omp parallel default(none) shared(yukcutoff, yukpol, mpi, at, charge, dip, e, local_e, f, virial, efield, type_of_atomic_num, cutoff, yukalpha, yuksmoothlength, pol, b_pol, c_pol, tdip_sr, do_pseudise, atom_mask, source_mask, grid_size, pseudise_sigma) private(i, j, m, ti, tj, k, r_ij, u_ij, gamjir3, gamjir2, fc, dfc_dr, expfactor, dipi, dipj, qj, qi, pp, pri, prj, de_ind, de_dd, de_qd, dfqdip, dfdipdip, factor1, dist3, dist5, const1, const2, factork, de_sr, df_sr, gij, dgijdrij, bij, cij, i_is_min_image, j_is_min_image, tpoli, tpolj, qipj, qjpi, pipj, private_e, private_local_e, private_virial, private_f, private_efield, sigma, erf_val, erf_deriv, de, defield_i, defield_j, dforce) - - if (present(e)) private_e = 0.0_dp - if (present(local_e)) then - allocate(private_local_e(at%N)) - private_local_e = 0.0_dp - endif - if (present(f)) then - allocate(private_f(3,at%N)) - private_f = 0.0_dp - endif - if (present(efield)) then - allocate(private_efield(3,at%N)) - private_efield = 0.0_dp - end if - if (present(virial)) private_virial = 0.0_dp - - !$omp do schedule(runtime) - do i=1, at%n - if (present(mpi)) then - if (mpi%active) then - if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle - endif - endif - - if (associated(atom_mask)) then - if (.not. atom_mask(i)) cycle - i_is_min_image = .false. - else - if (allocated(at%connect%is_min_image)) then - i_is_min_image = at%connect%is_min_image(i) - else - i_is_min_image = is_min_image(at, i) - end if - end if - ti = 0 - if (at%Z(i) /= 0) ti = get_type(type_of_atomic_num, at%Z(i)) - - qi = charge(i) - dipi = dip(:,i)/BOHR - tpoli = .false. - if (ti /= 0) tpoli = abs(yukpol(ti)) > 0.0_dp - - ! Induced contribution to energy - if ((present(e) .or. present(local_e)) .and. tpoli) then - de_ind = 0.5_dp*(dipi .dot. dipi)/yukpol(ti) - if (present(e)) private_e = private_e + de_ind - if (present(local_e)) private_local_e(i) = private_local_e(i) + de_ind - end if - - do m = 1, n_neighbours(at, i) - - j = neighbour(at, i, m, distance=r_ij, diff=u_ij, max_dist=cutoff) - if (j <= 0) cycle - - if (associated(source_mask)) then - if (.not. source_mask(j)) cycle - end if - - if (r_ij .feq. 0.0_dp) then - if (present(grid_size)) then - r_ij = grid_size/BOHR - else - cycle - end if - end if - - if (allocated(at%connect%is_min_image)) then - j_is_min_image = at%connect%is_min_image(j) - else - j_is_min_image = is_min_image(at, j) - end if - - if (i < j .and. i_is_min_image .and. j_is_min_image) cycle - - r_ij = r_ij/BOHR - u_ij = u_ij/BOHR - tj = 0 - if (at%Z(j) /= 0) tj = get_type(type_of_atomic_num, at%Z(j)) - - qj = charge(j) - dipj = dip(:,j)/BOHR - tpolj = .false. - if (tj /= 0) tpolj = abs(yukpol(tj)) > 0.0_dp - - qipj = (abs(qi) > 0.0_dp) .and. tpolj - qjpi = (abs(qj) > 0.0_dp) .and. tpoli - pipj = tpoli .and. tpolj - - if (.not. (pipj .or. qipj .or. qjpi)) cycle - - gamjir2 = 1.0_dp/r_ij**2.0_dp - gamjir3 = gamjir2/r_ij - factor1 = 3.0_dp*gamjir2*gamjir3 - - expfactor = exp(-yukalpha*r_ij) - - call smooth_cutoff(r_ij, yukcutoff-yuksmoothlength, yuksmoothlength, fc, dfc_dr) - - pp = 0.0_dp - if (pipj) pp = dipi .dot. dipj - pri = 0.0_dp - if (tpoli) pri = dipi .dot. u_ij - - prj = 0.0_dp - if (tpolj) prj = dipj .dot. u_ij - - if (do_pseudise) then - sigma = pseudise_sigma(tj)/BOHR - erf_val = 1.0_dp - erf_deriv = 0.0_dp - ! pseudise if sigma > 0, correction for r >= 9s is < 1e-16 - if (sigma > 0.0_dp .and. r_ij < 9.0_dp*sigma) then - erf_val = erf(r_ij/(sqrt_2 * sigma)) - erf_deriv = sqrt_2/(sqrt_pi*sigma)*exp(-r_ij*r_ij/(2.0_dp*sigma*sigma)) - end if - end if - - if (present(efield)) then - defield_i = (3.0_dp*prj*u_ij*gamjir2 - dipj)*gamjir2*dsqrt(gamjir2)*expfactor*fc - defield_j = (3.0_dp*pri*u_ij*gamjir2 - dipi)*gamjir2*dsqrt(gamjir2)*expfactor*fc - if (do_pseudise) then - defield_i = defield_i*erf_val - defield_j = defield_j*erf_val - end if - private_efield(:,i) = private_efield(:,i) + defield_i - if (i_is_min_image .and. j_is_min_image) private_efield(:,j) = private_efield(:,j) + defield_j - end if - - if (present(e) .or. present(local_e) .or. present(virial) .or. present(f)) then - - de_dd = (pp - 3.0_dp*pri*prj*gamjir2)*gamjir3 - de_qd = -(qi*prj - qj*pri)*gamjir3 - - de_sr = 0.0_dp - df_sr = 0.0_dp - if (tdip_sr .and. ti /= 0 .and. tj /= 0) then - - bij = b_pol(ti, tj) - cij = c_pol(ti, tj) - - dist3 = 1.0_dp/(r_ij**3.0_dp) - dist5 = 1.0_dp/(r_ij**5.0_dp) - - gij = 0.0_dp - factork = cij*exp(-bij*r_ij) - do k=1,4 - gij = gij + factork - factork = factork*bij*r_ij/float(k) - enddo - gij = gij + factork - dgijdrij = -bij*factork - - const1 = gij*dist3 - const2 = (qj*pri-qi*prj) & - * (r_ij*dgijdrij-3.0_dp*gij)*dist5 - - de_sr = -(qi*prj - qj*pri)*gij*dist3 - - df_sr = ((qj*dipi-qi*dipj)*const1 + u_ij*const2) & - *expfactor*fc & - -de_sr*(yukalpha*fc - dfc_dr)*expfactor/r_ij*u_ij - end if - - de = (de_dd + de_qd + de_sr)*expfactor*fc - if (do_pseudise) de = de*erf_val - - if (present(e)) then - if (i_is_min_image .and. j_is_min_image) then - private_e = private_e + de - else - private_e = private_e + 0.5_dp*de - end if - end if - - if (present(local_e)) then - private_local_e(i) = private_local_e(i) + 0.5_dp*de - if (i_is_min_image .and. j_is_min_image) private_local_e(j) = private_local_e(j) + 0.5_dp*de - end if - - if (present(f) .or. present(virial)) then - dfqdip = .0_dp - if (qipj .or. qjpi) then - dfqdip = ((qj*dipi(:) - qi*dipj(:) & - - 3.0_dp*(qj*pri-qi*prj)*u_ij*gamjir2)*gamjir3)*expfactor*fc & - - de_qd*(yukalpha*fc - dfc_dr)*expfactor/r_ij*u_ij - end if - - dfdipdip = 0.0_dp - if (pipj) then - dfdipdip = (-(pp*u_ij + dipj(:)*pri+dipi(:)*prj & - - 5.0_dp*prj*pri*u_ij(:)*gamjir2)*factor1)*expfactor*fc & - - de_dd*(yukalpha*fc - dfc_dr)*expfactor/r_ij*u_ij(:) - end if - - dforce = dfqdip + dfdipdip + df_sr - if (do_pseudise) dforce = dforce*erf_val + (de_dd + de_qd + de_sr)*expfactor*fc*erf_deriv*u_ij/r_ij - - if (present(f)) then - private_f(:,i) = private_f(:,i) + dforce - if (i_is_min_image .and. j_is_min_image) private_f(:,j) = private_f(:,j) - dforce - end if - - if (present(virial)) then - if (i_is_min_image .and. j_is_min_image) then - private_virial = private_virial - (dforce .outer. u_ij) - else - private_virial = private_virial - 0.5_dp*(dforce .outer. u_ij) - end if - end if - end if - end if - - end do - end do - !$omp end do - - if (present(mpi)) then - if (mpi%active) then - if (present(e)) private_e = sum(mpi, private_e) - if (present(local_e)) call sum_in_place(mpi, private_local_e) - if (present(f)) call sum_in_place(mpi, private_f) - if (present(virial)) call sum_in_place(mpi, private_virial) - if (present(efield)) call sum_in_place(mpi, private_efield) - end if - end if - - !$omp critical - if (present(e)) e = e + private_e*HARTREE - if (present(local_e)) local_e = local_e + private_local_e*HARTREE - if (present(f)) f = f + private_f*(HARTREE/BOHR) - if (present(virial)) virial = virial + private_virial*HARTREE - if (present(efield)) efield = efield + private_efield*(HARTREE/BOHR) - !$omp end critical - - if (allocated(private_f)) deallocate(private_f) - if (allocated(private_local_e)) deallocate(private_local_e) - if (allocated(private_efield)) deallocate(private_efield) - - !$omp end parallel - - call system_timer('yukawa_dipoles') - -end subroutine yukawa_dipoles - -end module Yukawa_module diff --git a/src/Potentials/ginted.f b/src/Potentials/ginted.f index 826605884c..456eaa2fd9 100644 --- a/src/Potentials/ginted.f +++ b/src/Potentials/ginted.f @@ -10,6 +10,7 @@ ! 5-10 xx yy zz xy xz yz SUBROUTINE GINTED(A1,A2,A,B,W) IMPLICIT REAL*8 (A-H,O-Z) + IMPLICIT INTEGER (I-N) DIMENSION A(3),B(3),W(10,10,4),L3(3,4) DIMENSION V(3,3,5,3) DIMENSION ML(10,3) diff --git a/src/Potentials/quip_lammps_wrapper.f95 b/src/Potentials/quip_lammps_wrapper.f95 deleted file mode 100644 index 14c859d0dc..0000000000 --- a/src/Potentials/quip_lammps_wrapper.f95 +++ /dev/null @@ -1,199 +0,0 @@ -module QUIP_LAMMPS_wrapper_module - - use system_module - use linearalgebra_module - use connection_module - use atoms_types_module - use atoms_module - - use potential_module - implicit none - - private - integer, parameter :: API_VERSION = 1 ! Manually increment for each _incompatible_ API change - - public :: quip_lammps_wrapper, quip_lammps_potential_initialise, quip_lammps_api_version - - type quip_lammps_potential - type(Potential), pointer :: pot - endtype quip_lammps_potential - - contains - - function quip_lammps_api_version() bind(c) - use iso_c_binding, only: c_int - integer(kind=c_int) :: quip_lammps_api_version - - quip_lammps_api_version = API_VERSION - end function quip_lammps_api_version - - subroutine quip_lammps_wrapper(nlocal, nghost, atomic_numbers, lmptag, & - inum, sum_num_neigh, ilist, & - quip_num_neigh, quip_neigh, lattice, & - quip_potential, n_quip_potential, quip_x, & - quip_e, quip_local_e, quip_virial, quip_local_virial, quip_force) bind(c) - - use iso_c_binding, only: c_double, c_int - - integer(kind=c_int), intent(in) :: nlocal ! number of local atoms in process - integer(kind=c_int), intent(in) :: nghost ! number of ghost atoms in process - integer(kind=c_int), intent(in) :: inum ! size of ilist, the list of local atoms (should be nlocal in most cases) - integer(kind=c_int), intent(in) :: sum_num_neigh ! number of all neighbours - - integer(kind=c_int), intent(in), dimension(nlocal+nghost) :: atomic_numbers ! list of atomic numbers of all atoms - integer(kind=c_int), intent(in), dimension(nlocal+nghost) :: lmptag ! list of lammps atom ids - integer(kind=c_int), intent(in), dimension(inum) :: ilist ! list of local atoms - integer(kind=c_int), intent(in), dimension(inum) :: quip_num_neigh ! number of neighbours of each local atom - integer(kind=c_int), intent(in), dimension(sum_num_neigh) :: quip_neigh ! list of neighbours of local atoms, packaged - real(kind=c_double), intent(in), dimension(3,3) :: lattice ! lattice parameters - integer(kind=c_int), intent(in), dimension(n_quip_potential) :: quip_potential ! integer array transfering the location of the QUIP potential in the memory - integer(kind=c_int), intent(in) :: n_quip_potential ! size of quip_potential - real(kind=c_double), intent(in), dimension(3,(nlocal+nghost)) :: quip_x ! atomic positions - real(kind=c_double), intent(out) :: quip_e ! energy - real(kind=c_double), intent(out), dimension(nlocal+nghost) :: quip_local_e ! atomic energies - real(kind=c_double), intent(out), dimension(3,3) :: quip_virial ! virial - real(kind=c_double), intent(out), dimension(9,(nlocal+nghost)) :: quip_local_virial ! atomic virials - real(kind=c_double), intent(out), dimension(3,(nlocal+nghost)) :: quip_force ! force - - integer :: i, j, n, nn, ni, i_n1n, j_n2n, error - integer, save :: nn_guess = 0 - type(atoms), save :: at - type(quip_lammps_potential) :: am - type(Potential), pointer :: pot - logical, dimension(:), pointer :: local - real(dp) :: r_ij - - real(dp), parameter :: small_number = 1.0e-10_dp - -#ifdef _MPI - call system_abort("quip_lammps_wrapper: code compiled with MPI. This plugin must be compiled with a serial compiler.") -#endif - - if( n_quip_potential == 0 ) then - call system_abort('quip_lammps_wrapper: quip_potential not initialised') - else - am = transfer(quip_potential,am) - pot => am%pot - endif - - ! if this region is vacuum, don't do anything. - if(nlocal > 0) then - - ! Initialise atoms object. If number of atoms does not change, keep the - ! object. Allocate connection table, be generous with the number of - ! neighbours. - if( .not. is_initialised(at) .or. at%N /= (nlocal+nghost) .or. nn_guess < maxval(quip_num_neigh) ) then - call finalise(at) - call initialise(at,(nlocal+nghost),lattice) - call set_cutoff(at,cutoff(pot)) - nn_guess = 2*maxval(quip_num_neigh) - call connection_fill(at%connect,at%N,at%N,nn_guess=nn_guess) - endif - - ! Transport atomic numbers and positions. - at%Z = atomic_numbers - at%pos = quip_x - - ! Add atom mask to atoms object. Potentials will only include these atoms - ! in the calculation. - call add_property(at,'local',.false.,ptr = local, overwrite=.true., error=error) - - ! And the lammps atom ids, for distinguishability - call add_property(at, 'lmptag', lmptag, overwrite=.true., error=error) - - ! Zero all connections. - do i = 1, at%N - at%connect%neighbour1(i)%t%N = 0 - at%connect%neighbour2(i)%t%N = 0 - enddo - - ! Fill connection table. - nn = 0 - do ni = 1, inum - ! Look up ni-th atom as atom i. - i = ilist(ni) + 1 - ! Set local flag - include in potential calculation. - local(i) = .true. - - i_n1n = 0 - do n = 1, quip_num_neigh(ni) - nn = nn + 1; - j = quip_neigh(nn) - - ! j is atom i's n-th neighbour. Fill the connection table for both i - ! and j at the same time. As LAMMPS repeats periodic images - ! explicitly, shift is set to 0. For the same reason, the lattice - ! variable is not really important, except in calculating the - ! virial. - if( i <= j ) then - i_n1n = i_n1n + 1 - at%connect%neighbour1(i)%t%N = at%connect%neighbour1(i)%t%N + 1 ! Increase size of neighbour list by one - at%connect%neighbour1(i)%t%int(1,i_n1n) = j ! The last neighbour is j - at%connect%neighbour1(i)%t%int(2:4,i_n1n) = 0 ! Set the shift to zero - - r_ij = norm(at%pos(:,i) - at%pos(:,j)) - if( r_ij < small_number ) call system_abort('quip_lammps_wrapper: atoms '//i//' and '//j//' overlap exactly.') - at%connect%neighbour1(i)%t%real(1,i_n1n) = r_ij - - at%connect%neighbour2(j)%t%N = at%connect%neighbour2(j)%t%N + 1 ! Fill the connection for the other atom in the pair. - j_n2n = at%connect%neighbour2(j)%t%N - at%connect%neighbour2(j)%t%int(1,j_n2n) = i - at%connect%neighbour2(j)%t%int(2,j_n2n) = i_n1n - endif - enddo - enddo - - ! Call the QUIP potential. - call calc(pot,at,energy=quip_e,local_energy=quip_local_e,force=quip_force,virial=quip_virial,local_virial=quip_local_virial,args_str="atom_mask_name=local pers_idces_name=lmptag lammps do_calc_connect=F") - else - quip_e = 0.0_dp - quip_local_e = 0.0_dp - quip_virial = 0.0_dp - quip_local_virial = 0.0_dp - quip_force = 0.0_dp - endif - - endsubroutine quip_lammps_wrapper - - subroutine quip_lammps_potential_initialise(quip_potential,n_quip_potential,quip_cutoff,quip_file,n_quip_file,quip_string,n_quip_string) bind(c) - - use iso_c_binding, only: c_double, c_int, c_char - - integer(kind=c_int), intent(out), dimension(n_quip_potential) :: quip_potential - integer(kind=c_int), intent(inout) :: n_quip_potential - real(kind=c_double), intent(out) :: quip_cutoff - character(kind=c_char), intent(in) :: quip_file(n_quip_file) - integer(kind=c_int), intent(in) :: n_quip_file - character(kind=c_char), intent(in) :: quip_string(n_quip_string) - integer(kind=c_int), intent(in) :: n_quip_string - - type(Potential), target, save :: pot - type(quip_lammps_potential) :: am - - integer, dimension(1) :: ammold - -#ifdef _MPI - call system_abort("quip_lammps_wrapper: code compiled with MPI. This plugin must be compiled with a serial compiler.") -#endif - ! In this routine we initialise the QUIP potential and set a pointer to - ! it. The pointer will then be transferred as an integer array to the - ! wrapper. - ! Routine has to be called twice. The integer array used to transfer the - ! pointer will be allocated by LAMMPS. The first call sends the size of - ! the array, and the second call transfers the pointer via the array. - if( n_quip_potential == 0 ) then - call system_initialise(verbosity=PRINT_SILENT) - call Potential_Filename_Initialise(pot, trim(a2s(quip_string)), trim(a2s(quip_file))) - am%pot => pot - n_quip_potential = size(transfer(am,ammold)) - else - am%pot => pot - quip_potential = transfer(am,ammold) - endif - - ! Cutoff returned. - quip_cutoff = cutoff(pot) - - endsubroutine quip_lammps_potential_initialise - -endmodule QUIP_LAMMPS_wrapper_module diff --git a/src/Potentials/quip_unified_wrapper.f95 b/src/Potentials/quip_unified_wrapper.f95 deleted file mode 100644 index d1e18eec16..0000000000 --- a/src/Potentials/quip_unified_wrapper.f95 +++ /dev/null @@ -1,333 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X Tamas K. Stenczel -! H0 X -! H0 X Copyright 2006-2020. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X quip_wrapper subroutine -!X -!% wrapper to make it nicer for non-QUIP programs to use a QUIP potential -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module quip_unified_wrapper_module - -use system_module, only : dp, print, system_initialise, system_abort, PRINT_ANALYSIS, PRINT_VERBOSE, PRINT_NORMAL, PRINT_SILENT, verbosity_push, & - verbosity_pop, optional_default -use dictionary_module, only : dictionary, STRING_LENGTH -use periodictable_module, only : atomic_number_from_symbol -use mpi_context_module, only : mpi_context, initialise -use atoms_types_module, only : assign_pointer -use atoms_module, only : atoms, initialise, finalise, set_cutoff, calc_connect, set_lattice, get_param_value -use potential_module, only : potential, potential_filename_initialise, calc, cutoff, print, Finalise -implicit none - -contains - -subroutine quip_unified_wrapper(N,pos,frac_pos,lattice,symbol,Z, & - quip_param_file,quip_param_file_len,init_args_str,init_args_str_len,calc_args_str,calc_args_str_len, & - energy,force,virial,do_energy,do_force,do_virial,output_unit,mpi_communicator,reload_pot) - !% Unified wrapper for QUIP potentials - !% - !% Notes: (tks32) - !% - changes in the potential on the fly are picked up only if reload_pot is specified - !% - MPI context cannot be changed on the fly - - use system_module, only: optional_default, print - implicit none - - ! arguments in call order - integer, intent(in) :: N - real(dp), dimension(3,N), intent(in), optional :: pos - real(dp), dimension(3,N), intent(in), optional :: frac_pos - real(dp), dimension(3,3), intent(in), optional :: lattice - character(len=*), dimension(N), intent(in), optional :: symbol - integer, dimension(N), intent(in), optional :: Z - integer, intent(in) :: quip_param_file_len - character(len=quip_param_file_len) :: quip_param_file - integer, intent(in) :: init_args_str_len - character(len=init_args_str_len) :: init_args_str - integer, intent(in) :: calc_args_str_len - character(len=calc_args_str_len) :: calc_args_str - real(dp), intent(out), optional :: energy - real(dp), dimension(3,N), intent(out), optional :: force - real(dp), dimension(3,3), intent(out), optional :: virial - logical, intent(in), optional :: do_energy - logical, intent(in), optional :: do_force - logical, intent(in), optional :: do_virial - integer, intent(in), optional :: output_unit - integer, intent(in), optional :: mpi_communicator - logical, intent(in), optional :: reload_pot ! reloads the potential - - ! internal variables - integer :: i - real(dp), dimension(:,:), pointer :: quip_wrapper_force - character(len=STRING_LENGTH) :: use_calc_args - real(dp) :: use_lattice(3,3) - logical :: use_do_energy, use_do_force, use_do_virial - - ! saved stuff - type(atoms), save :: at - type(Potential), save :: pot - type(MPI_context), save :: mpi_glob - logical, save :: first_run = .true. - - if (present(lattice)) then - use_lattice = lattice - else - use_lattice = 0.0_dp - endif - - if( first_run ) then - call system_initialise(verbosity=PRINT_SILENT,mainlog_unit=output_unit) - call Initialise(mpi_glob,communicator=mpi_communicator) - call Potential_Filename_Initialise(pot, args_str=trim(init_args_str), param_filename=quip_param_file,mpi_obj=mpi_glob) - call verbosity_push(PRINT_NORMAL) - call Print(pot) - call verbosity_pop() - call initialise(at,N,use_lattice) - end if - - if (optional_default(.false., reload_pot)) then - ! deallocate old potential -- this was initialised in first_run - call Finalise(pot) - ! initialise with new parameters - call Potential_Filename_Initialise(pot, args_str=trim(init_args_str), param_filename=quip_param_file,mpi_obj=mpi_glob) - call Print(pot) - endif - - if( .not. first_run .and. (N /= at%N) ) then - call finalise(at) - call initialise(at,N,use_lattice) - endif - - call set_lattice(at,use_lattice, scale_positions=.false.) - - if (present(Z)) then - if (present(symbol)) call system_abort("quip_unified_wrapper got both Z and symbol, don't know which to use") - at%Z = Z - else ! no Z, use symbol - if (.not. present(symbol)) call system_abort("quip_unified_wrapper got neither Z nor symbol") - do i = 1, at%N - at%Z(i) = atomic_number_from_symbol(symbol(i)) - enddo - endif - - if (present(pos)) then - if (present(frac_pos)) call system_abort("quip_unified_wrapper got both pos and frac_pos, don't know which to use") - at%pos = pos - else ! no pos, use frac_pos - if (.not. present(frac_pos)) call system_abort("quip_unified_wrapper got neither pos nor frac_pos") - at%pos = matmul(at%lattice,frac_pos) - endif - - if(at%cutoff > 0) call calc_connect(at) - - use_calc_args = trim(calc_args_str) - use_do_energy = optional_default(present(energy), do_energy) - use_do_force = optional_default(present(force), do_force) - use_do_virial = optional_default(present(virial), do_virial) - if (use_do_energy .and. .not. present(energy)) call system_abort("quip_unified_wrapper got do_energy=.true. but not present(energy)") - if (use_do_force .and. .not. present(force)) call system_abort("quip_unified_wrapper got do_force=.true. but not present(force)") - if (use_do_virial .and. .not. present(virial)) call system_abort("quip_unified_wrapper got do_virial=.true. but not present(virial)") - if(use_do_energy) use_calc_args = trim(use_calc_args)//" energy=quip_wrapper_energy " - if(use_do_force) use_calc_args = trim(use_calc_args)//" force=quip_wrapper_force " - if(use_do_virial) use_calc_args = trim(use_calc_args)//" virial=quip_wrapper_virial " - - call calc(pot,at,args_str=trim(use_calc_args)) - - if(use_do_energy) call get_param_value(at, "quip_wrapper_energy", energy) - if(use_do_virial) call get_param_value(at, "quip_wrapper_virial", virial) - if(use_do_force) then - if(.not. assign_pointer(at,"quip_wrapper_force",quip_wrapper_force) ) call system_abort("Could not calculate forces") - force = quip_wrapper_force - endif - - first_run = .false. - -end subroutine quip_unified_wrapper - -end module quip_unified_wrapper_module - -subroutine quip_wrapper(N,lattice,symbol,pos,args_str,args_str_len,energy,force,virial,do_energy,do_force,do_virial) - - use system_module, only : dp - use quip_unified_wrapper_module - - implicit none - - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - integer, intent(in) :: args_str_len - character(len=args_str_len) :: args_str - real(dp), dimension(3,N), intent(in) :: pos - real(dp), intent(out) :: energy - real(dp), dimension(3,N), intent(out) :: force - real(dp), dimension(3,3), intent(out) :: virial - logical, intent(in) :: do_energy, do_force, do_virial - - call quip_unified_wrapper(N=N,lattice=lattice,symbol=symbol,pos=pos,init_args_str=args_str,init_args_str_len=args_str_len, & - energy=energy,force=force,virial=virial,do_energy=do_energy,do_force=do_force,do_virial=do_virial, & - quip_param_file="quip_params.xml", quip_param_file_len=15, calc_args_str="",calc_args_str_len=0) - - -endsubroutine quip_wrapper - -subroutine quip_wrapper_castep(N,lattice,frac_pos,symbol, & - quip_param_file,quip_param_file_len,init_args_str,init_args_str_len,calc_args_str,calc_args_str_len, & - energy,force,virial,do_energy,do_force,do_virial,output_unit, reload_pot, mpi_communicator, use_mpi) - - !% Castep wrapper for QUIP potentials - !% - !% Notes: (tks32) - !% - added reload_pot optional arg - !% - lattice was intent(inout), made no sense so changed it to intent(in) - !% as it is in the unitied wrapper as well - - use system_module, only : dp - use quip_unified_wrapper_module - - implicit none - - integer, intent(in) :: N - real(dp), dimension(3,N), intent(in) :: frac_pos - real(dp), dimension(3,3), intent(in) :: lattice - character(len=3), dimension(N), intent(in) :: symbol - integer, intent(in) :: quip_param_file_len - character(len=quip_param_file_len), intent(in) :: quip_param_file - integer, intent(in) :: init_args_str_len - character(len=init_args_str_len), intent(in) :: init_args_str - integer, intent(in) :: calc_args_str_len - character(len=calc_args_str_len), intent(in) :: calc_args_str - real(dp), intent(out) :: energy - real(dp), dimension(3,N), intent(out) :: force - real(dp), dimension(3,3), intent(out) :: virial - logical, intent(in) :: do_energy - logical, intent(in) :: do_force - logical, intent(in) :: do_virial - integer, intent(in) :: output_unit - logical, intent(in) :: reload_pot ! reloads the potential - ! we should not have optional arguments, - ! so we get told here if we should use MPI or not - integer, intent(in) :: mpi_communicator - logical, intent(in) :: use_mpi - - if (use_mpi) then - call quip_unified_wrapper(N=N,frac_pos=frac_pos,lattice=lattice,symbol=symbol, & - quip_param_file=quip_param_file, quip_param_file_len=quip_param_file_len, & - init_args_str=init_args_str,init_args_str_len=init_args_str_len, & - calc_args_str=calc_args_str,calc_args_str_len=calc_args_str_len, & - energy=energy,force=force,virial=virial,& - do_energy=do_energy,do_force=do_force,do_virial=do_virial,output_unit=output_unit, & - reload_pot=reload_pot, mpi_communicator=mpi_communicator) - else - call quip_unified_wrapper(N=N,frac_pos=frac_pos,lattice=lattice,symbol=symbol, & - quip_param_file=quip_param_file, quip_param_file_len=quip_param_file_len, & - init_args_str=init_args_str,init_args_str_len=init_args_str_len, & - calc_args_str=calc_args_str,calc_args_str_len=calc_args_str_len, & - energy=energy,force=force,virial=virial,& - do_energy=do_energy,do_force=do_force,do_virial=do_virial,output_unit=output_unit, & - reload_pot=reload_pot) - end if - -endsubroutine quip_wrapper_castep - - -subroutine quip_wrapper_onetep(N, lattice, pos, Z, & - quip_param_file_len, quip_param_file, & - init_args_str_len, init_args_str, & - calc_args_str_len, calc_args_str, & - energy, force, & - do_energy, do_force, & - output_unit, reload_pot) - - !% ONETEP wrapper for QUIP potentials - !% does not interface virials, because onetep does not implement stresses - !% - !% written by T. K. Stenczel, July 2021 - - use system_module, only : dp - use quip_unified_wrapper_module - - implicit none - - integer, intent(in) :: N - real(dp), dimension(3,N), intent(in) :: pos - real(dp), dimension(3,3), intent(in) :: lattice - integer, dimension(N), intent(in) :: Z - integer, intent(in) :: quip_param_file_len - character(len=quip_param_file_len), intent(in) :: quip_param_file - integer, intent(in) :: init_args_str_len - character(len=init_args_str_len), intent(in) :: init_args_str - integer, intent(in) :: calc_args_str_len - character(len=calc_args_str_len), intent(in) :: calc_args_str - real(dp), intent(out) :: energy - real(dp), dimension(3,N), intent(out) :: force - logical, intent(in) :: do_energy - logical, intent(in) :: do_force - integer, intent(in) :: output_unit - logical, intent(in) :: reload_pot ! reloads the potential - - call quip_unified_wrapper(N=N, pos=pos, lattice=lattice, Z=Z, & - quip_param_file=quip_param_file, quip_param_file_len=quip_param_file_len, & - init_args_str=init_args_str, init_args_str_len=init_args_str_len, & - calc_args_str=calc_args_str, calc_args_str_len=calc_args_str_len, & - energy=energy, force=force, & - do_energy=do_energy, do_force=do_force, output_unit=output_unit, & - reload_pot=reload_pot) - - -endsubroutine quip_wrapper_onetep - -subroutine quip_wrapper_simple(N,lattice,Z,pos,energy,force,virial) - - use system_module, only : dp - use quip_unified_wrapper_module - - implicit none - - integer, intent(in) :: N - real(dp), dimension(3,3), intent(inout) :: lattice - integer, dimension(N), intent(in)::Z - real(dp), dimension(3,N), intent(in) :: pos - real(dp), intent(out) :: energy - real(dp), dimension(3,N), intent(out) :: force - real(dp), dimension(3,3), intent(out) :: virial - - - call quip_unified_wrapper(N=N,lattice=lattice,Z=Z,pos=pos,init_args_str="xml_label=default",init_args_str_len=17, & - energy=energy,force=force,virial=virial,do_energy=.true.,do_force=.true.,do_virial=.true., & - quip_param_file="quip_params.xml", quip_param_file_len=15, calc_args_str="",calc_args_str_len=0) - - -endsubroutine quip_wrapper_simple - From 81ac49b0d23c9fb370fc3a55993064802fcf7c95 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 17:51:35 +0100 Subject: [PATCH 08/47] renamed source files to have F90 extension --- src/Utils/crackparams.f95 | 1981 ------------ src/Utils/cracktools.f95 | 2869 ----------------- src/Utils/elasticity.f95 | 736 ----- src/Utils/force_machine_learning_module.f95 | 1256 -------- src/Utils/phonons.f95 | 1241 ------- src/Utils/real_space_covariance.f95 | 1101 ------- src/Utils/restraints_constraints_xml.f95 | 446 --- .../structure_analysis_traj_routines.f95 | 1844 ----------- src/Utils/transition_state.f95 | 802 ----- src/Utils/ts_params.f95 | 400 --- 10 files changed, 12676 deletions(-) delete mode 100644 src/Utils/crackparams.f95 delete mode 100644 src/Utils/cracktools.f95 delete mode 100644 src/Utils/elasticity.f95 delete mode 100644 src/Utils/force_machine_learning_module.f95 delete mode 100644 src/Utils/phonons.f95 delete mode 100644 src/Utils/real_space_covariance.f95 delete mode 100644 src/Utils/restraints_constraints_xml.f95 delete mode 100644 src/Utils/structure_analysis_traj_routines.f95 delete mode 100644 src/Utils/transition_state.f95 delete mode 100644 src/Utils/ts_params.f95 diff --git a/src/Utils/crackparams.f95 b/src/Utils/crackparams.f95 deleted file mode 100644 index 3ddf6ddfcd..0000000000 --- a/src/Utils/crackparams.f95 +++ /dev/null @@ -1,1981 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!% This module contains the 'CrackParams' type which holds all parameters -!% for a fracture simulation. These parameters are used by both 'makecrack' -!% and 'crack'. The module also contains code to read parameters from -!% and XML file. -!% -!% The 'CrackParams' type contains all simulation parameters for a fracture simulation. -!% It is initialised from the '' stanza of an XML file, which -!% should contain some or all of the following tags: -!% * '' -- parameters used exclusively by 'makecrack' which -!% define the geometry and structure of the simulation cell. -!% * 'simulation' -- high level parameters which define the task to be performed -!% by the 'crack' program. -!% * 'md' -- parameters related to molecular dynamics, used when -!% 'simulation_task = md'. -!% * 'minim' -- parameters related to geometry optimsation, used when -!% 'simulation_task = minim' -!% * 'io' -- Input/output parameters -!% * 'selection' -- parameters that effect the choice of QM region -!% * 'classical' -- parameters that define which classical potential to use -!% * 'qm' -- parameters concerned with QM force evaluation, including which -!% potential to use. -!% * 'fit' -- parameters relating to the adjustable potential used to reproduce -!% quantum mechanical forces -!% * 'force_intergration' -- parameters for the force integration task, used -!% when 'simulation_task = force_integration'. -!% * 'quasi_static' -- parameters for the quasi-static loading task, used -!% when 'simulation_task = quasi_static'. -!% * 'hack' -- finally, nasty hacks required for some crack systems, for -!% example it is necessary to zero the $z$-component of the QM forces to -!% get a well behaved simulation of the fracture of two-dimensional graphene. -!% -!% Note that tag and attribute names are mapped into variable names by joining -!% them with an underscore: for example the 'task' attribute within the 'simulation' -!% tag becomes the 'simulation_task' variables. -!% See below for a brief description of each parameter. -!% -!% Here is a complete example of the '' XML stanza for a MD run -!% using the Bowler tight binding model in the QM region and the standard -!% Stillinger-Weber potential for the classical region :: -!% -!%> -!%> name="(111)[11b0]" width="200.0" height="100.0" -!%> num_layers="1" G="1.0" seed_length="50.0" -!%> strain_zone_width="50.0" vacuum_size="50.0" -!%> hydrogenate="T" rescale_x_z="F" rescale_x="F" nerate_load="F" strain_increment="0.005" /> -!%> -!%> -!%> -!%> thermalise_tau="50.0" thermalise_wait_time="400.0" tau="500.0" -!%> wait_time="500.0" interval_time="100.0" -!%> extrapolate_steps="5" crust="2.0" /> -!%> -!%> linminroutine="FAST_LINMIN" minimise_mm="F" /> -!%> -!%> checkpoint_interval="100.0" /> -!%> -!%> ellipse_bias="0.5" ellipse_buffer="1.3" cutoff_plane="10.0" -!%> fit_on_eqm_coordination_only="F" /> -!%> -!%> -!%> -!%> buffer_hops="3" vacuum_size="3.0" even_electrons="T" -!%> randomise_buffer="T" force_periodic="F" /> -!%> -!%> -!%> -!% -!% Parameters for the classical and QM regions should be included in the same XML -!% file, and all three stanzas should then be enclosed by some outer tags to make -!% a well formed XML file. For example this could be '...', -!% but the choice of name is arbitrary. - -#include "error.inc" - -module CrackParams_module - - use libAtoms_module - use QUIP_Common_module - use Potential_module - use system_module, only : verbosity_to_str, verbosity_of_str, get_env_var - - implicit none - - private - - integer, parameter :: MAX_PROPERTIES = 100, MAX_MD_STANZA = 5 - - public :: CrackParams, CrackMDParams, CrackParams_any_per_atom_tau - - type CrackMDParams - ! Molecular dynamics parameters - real(dp) :: time_step !% Molecular Dynamics time-step, in fs. - integer :: extrapolate_steps !% Number of steps to extrapolate for - real(dp) :: crust !% Distance by which 'Atoms' cutoff should exceed that of MM potential, in \AA{}. - real(dp) :: recalc_connect_factor !% Maximum atom movement as a fraction of 'md_crust' before connectivity is recalculated. - real(dp) :: nneigh_tol !% Nearest neighbour tolerance, as a fraction of sum of covalant radii. - integer :: eqm_coordination(2) !% Equilibrium coordination number of bulk (used for finding crack tip). - real(dp) :: sim_temp !% Target temperature for Langevin thermostat, in Kelvin. - real(dp) :: avg_time !% Averaging time for bonding/nearest neighbours etc. Unit:~fs. - real(dp) :: thermalise_tau !% Thermostat time constant during thermalisiation. Unit:~fs. - real(dp) :: thermalise_wait_time !% Minimium thermalisation time at each load before changing to (almost) microcanoical MD. Unit:~fs. - real(dp) :: thermalise_wait_factor!% Factor controlling the thermalisation time at each load before changing to (almost) microcanonical MD - real(dp) :: tau !% Thermostat time constant during (almost) microcanonical MD. Unit:~fs. - logical :: per_atom_tau !% Use per-atom thermostat time constant (property name 'per_atom_tau', overrides md%tau for atoms where $\text{property} > 0$) during (almost) microcanonical MD. Logical. - real(dp) :: wait_time !% Minimum wait time between loadings. Unit:~fs. - real(dp) :: interval_time !% How long must there be no topological changes for before load is incremented. Unit:~fs. - real(dp) :: calc_connect_interval !% How often should connectivity be recalculated? - real(dp) :: smooth_loading_rate !% increment load at this rate, in units of (J/m$^2$)/fs, after every integration step - real(dp) :: smooth_loading_tip_move_tol !% Distance in angstrom by which CrackPos must increase for crack to be considered to be moving - real(dp) :: smooth_loading_arrest_time !% Crack must move by at least 'smooth_loading_tip_move_tol' A in every 'smooth_loading_arrest_time' - !% to be considered to be moving. - real(dp) :: smooth_loading_tip_edge_tol !% If tip arrests closer than this distance to edge of slab, consider simulation finished - real(dp) :: damping_time !% Time constant for damped molecular dynamics - real(dp) :: stanza_time !% Time to run in this MD stanza before moving to next one - real(dp) :: max_runtime !% If $\ge 0$, exit cleanly if elapsed runtime (in seconds) is $\ge$ this - real(dp) :: crack_find_tip_interval !% Print position of crack tip at this frequency - character(len=3) :: ensemble !$ MD ensmble: NVE only NVT are supported - - end type CrackMDParams - - !% This type contains all the parameters for a crack simulation, each of which is described briefly - !% below. - type CrackParams - - ! Crack parameters (used only by makecrack) - character(STRING_LENGTH) :: crack_structure !% Structure: so far 'diamond' and 'graphene' are supported - character(STRING_LENGTH) :: crack_element !% Element to make slab from. Supported so far: Si, C, SiC, SiO - integer :: crack_z(2) !% Initialised automatically from crack element - character(STRING_LENGTH) :: crack_name !% Crack name, in format '(abc)[def]' with negative indices - !% denoted by a trailing 'b' (for bar), e.g. '(111)[11b0]'. - real(dp) :: crack_lattice_guess !% Guess at bulk lattice parameter, used to obtain accurate result. Unit:~\AA{}. - real(dp) :: crack_lattice_a, crack_lattice_c, crack_lattice_u, crack_lattice_x, crack_lattice_y, crack_lattice_z - real(dp) :: crack_width !% Width of crack slab, in \AA{}. - real(dp) :: crack_height !% Height of crack slab, in \AA{}. - integer :: crack_num_layers !% Number of primitive cells in $z$ direction - logical :: crack_apply_initial_load !% If 'true', apply initial loading field to crack slab - real(dp) :: crack_strain !% Initial applied strain - real(dp) :: crack_G !% Initial energy release rate loading in J/m$^2$ (override strain) - character(STRING_LENGTH) :: crack_loading !% 'uniform' for constant load, - !% 'ramp' for linearly decreasing load along $x$, - !% 'kfield' for Irwin plane strain K-field, - !% 'interp_kfield_uniform' to linearly interpolate between k-field - !% (at crack tip) and uniform at distance 'crack_load_interp_length' - !% 'reduce_uniform' for reducing load - real(dp) :: crack_load_interp_length !% Length over which linear interpolation between k-field - !% and uniform strain field is carried out - real(dp) :: crack_ramp_length !% Length of ramp for the case 'crack_loading="ramp"' - real(dp) :: crack_ramp_start_length !% Length of the region in between the crack tip and the start of the ramp for the case 'crack_loading="ramp"' - real(dp) :: crack_ramp_end_G !% Loading at end of ramp for the case 'crack_loading="ramp"' - real(dp) :: crack_strain_increment !% Rate of loading, expressed as strain of initial loading - real(dp) :: crack_G_increment !% Rate of loading, expressed as increment in G (override strain_increment) - real(dp) :: crack_seed_length !% Length of seed crack. Unit:~\AA{}. - real(dp) :: crack_strain_zone_width !% Distance over which strain increases. Unit:~\AA{}. - real(dp) :: crack_vacuum_size !% Amount of vacuum around crack slab. Unit:~\AA{}. - logical :: crack_rescale_x_z !% Rescale atomsatoms in x direction by v and in z direction by v2 - logical :: crack_rescale_x !% Rescale atomsatoms in x direction by v - logical :: crack_relax_loading_field !% Should 'makecrack' relax the applied loading field - real(dp) :: crack_edge_fix_tol !% How close must an atom be to top or bottom to be fixed. Unit:~\AA{}. - real(dp) :: crack_y_shift !% Shift required to align y=0 with centre of a vertical bond. - !% This value is only used for unknown values of 'crack_name'. Unit:~\AA{}. - real(dp) :: crack_x_shift !% Shift required to get "nice" surface terminations on vertical edges - logical :: crack_align_y !% Vertical alignment turned on - real(dp) :: crack_seed_embed_tol !% Atoms closer than this distance from crack tip will be used to seed embed region. Unit:~\AA{}. - real(dp) :: crack_graphene_theta !% Rotation angle of graphene plane, in radians. - real(dp) :: crack_graphene_notch_width !% Width of graphene notch. Unit:~\AA{}. - real(dp) :: crack_graphene_notch_height !% Height of graphene notch. Unit:~\AA{}. - character(STRING_LENGTH) :: crack_slab_filename !% Input file to use instead of generating slabs. - character(STRING_LENGTH) :: crack_bulk_filename !% Input file containing primitive cell - logical :: crack_relax_bulk !% If true (default) relax bulk cell using classical potential - integer :: crack_dislo_seed !% atom at the core of the dislocation - logical :: crack_check_surface_coordination !% Checking of the surface coordination before generating the crack seed - integer :: crack_check_coordination_atom_type !% Atom type we check the coordination for - integer :: crack_check_coordination_critical_nneigh !% Critical number of neighbours in the connectivity checking - real(dp) :: crack_check_coordination_region !% Region (+/- around y=0 level) where the atomic coordination is checked. - logical :: crack_double_ended !% If true, we do a double ended crack with periodic boundary conditions along $x$ direction. - real(dp) :: crack_tip_grid_size !% Size (in A) of grid used for locating crack tips - real(dp) :: crack_tip_min_separation !% Minimum seperation (in A) between a pair of crack tips for them to be considered distinct - character(STRING_LENGTH) :: crack_tip_method !% One of 'coordination', 'percolation', 'local_energy' or 'alpha_shape' - logical :: crack_free_surfaces !% If true, crack is 3D with free surfaces at z= +/- depth/2 - real(dp) :: crack_front_window_size !% Size of windows along crack front. Should be roughly equal to lattice periodicity in this direction. - logical :: crack_fix_sides !% If true fix atoms close to left and right edges of slab - logical :: crack_fix_dipoles !% If true, we keep fixed dipoles for atoms at the edges. - real(dp) :: crack_fix_dipoles_tol !% How close must an atom be to top or bottom to keep fixed its dipole. Unit:~\AA{}. - real(dp) :: crack_thermostat_ramp_length !% Length of thermostat ramp used for stadium damping at left and right edges - real(dp) :: crack_thermostat_ramp_max_tau !% Value of thermostat tau at end of ramp, in fs. - logical :: crack_initial_velocity_field !% If true, initialise velocity field with dU/dc - real(dp) :: crack_initial_velocity_field_dx, crack_initial_velocity_field_dt - logical :: crack_curved_front !% If true, initialise slab with a curved crack front - real(dp) :: crack_curvature !% Curvature used when crack_curved_front=T - real(dp) :: crack_front_alpha !% Value of alpha to use when tip_method=alpha_shape - real(dp) :: crack_front_angle_threshold !% Maximum bearing for segments to be included in crack front - - ! Simulation parameters - character(STRING_LENGTH) :: simulation_task !% Task to perform: 'md', 'minim', etc. - integer :: simulation_seed !% Random number seed. Use zero for a random seed, or a particular value to repeat a previous run. - logical :: simulation_classical !% Perform a purely classical simulation - logical :: simulation_force_initial_load_step !% Force a load step at beginning of simulation - character(STRING_LENGTH) :: simulation_initial_state !% Initial state. Overrides value read from input atoms structure - - - ! Minimisation parameters - character(STRING_LENGTH) :: minim_method !% Minimisation method: use 'cg' for conjugate gradients or 'sd' for steepest descent. - !% See 'minim()' in 'libAtoms/minimisation.f95' for details. - real(dp) :: minim_tol !% Target force tolerance - geometry optimisation is considered to be - !% converged when $|\mathbf{f}|^2 <$ 'tol' - real(dp) :: minim_eps_guess !% Initial guess for line search step size $\epsilon$. - integer :: minim_max_steps !% Maximum number of minimisation steps. - integer :: minim_print_output !% Number of steps between XYZ confgurations printed - character(STRING_LENGTH) :: minim_linminroutine !% Linmin routine, e.g. 'FAST_LINMIN' for classical potentials with total energy, or - !% 'LINMIN_DERIV' when doing a LOTF hybrid simulation and only forces are available. - real(dp) :: minim_fire_dt0 !% If using fire_minim, the initial step size - real(dp) :: minim_fire_dt_max !% If using fire_minim, the maximum step size - logical :: minim_minimise_mm !% Should we minimise classical degrees of freedom before each QM force evaluation - character(STRING_LENGTH) :: minim_mm_method !% Minim method for MM minimisation, e.g. 'cg' for conjugate gradients - real(dp) :: minim_mm_tol !% Target force tolerance for MM minimisation - real(dp) :: minim_mm_eps_guess !% Initial guess for line search $\epsilon$ for MM minimisation - integer :: minim_mm_max_steps !% Maximum number of cg cycles for MM minimisation - character(STRING_LENGTH) :: minim_mm_linminroutine !% Linmin routine for MM minimisation - character(STRING_LENGTH) :: minim_mm_args_str !% Args string to be passed to MM calc() routine - - - ! I/O parameters - integer :: io_verbosity !% Output verbosity. In XML file, this should be specified as one of - !% 'ERROR', 'SILENT', 'NORMAL', 'VERBOSE', 'NERD' or 'ANALYSIS' - logical :: io_netcdf !% If true, output in NetCDF format instead of XYZ - real(dp) :: io_print_interval !% Interval between movie XYZ frames, in fs. - logical :: io_print_all_properties !% If true, print all atom properties to movie file. This will generate large - !% files but is useful for debugging. - character(STRING_LENGTH), allocatable :: io_print_properties(:) !% List of properties to print to movie file. - real(dp) :: io_checkpoint_interval !% Interval between writing checkpoint files, in fs. - character(STRING_LENGTH) :: io_checkpoint_path !% Path to write checkpoint files to. Set this to local scratch space to avoid doing - !%lots of I/O to a network drive. Default is current directory. - logical :: io_mpi_print_all !% Print output on all nodes. Useful for debugging. Default .false. - logical :: io_backup !% If true, create backups of check files - logical :: io_timing !% If true, enable timing (default false) - - ! Selection parameters - integer :: selection_max_qm_atoms !% Maximum number of QM atoms to select - character(STRING_LENGTH) :: selection_method !% One of 'static', 'coordination', 'crack_front' - real(dp) :: selection_ellipse(3) !% Principal radii of selection ellipse along $x$, $y$ and $z$ in \AA{}. - real(dp) :: selection_ellipse_bias !% Shift applied to ellipses, expressed as fraction of ellipse radius in $x$ direction. - real(dp) :: selection_ellipse_buffer !% Difference in size between inner and outer selection ellipses, i.e. amount of hysteresis. - real(dp) :: selection_cutoff_plane !% Only atoms within this distance from crack tip are candidates for QM selection. Unit: \AA{}. - logical :: selection_directionality !% Require good directionality of spring space spanning for atoms in embed region. - real(dp) :: selection_edge_tol !% Size of region at edges of crack slab which is ignored for selection purposes. - real(dp) :: selection_update_interval!% intervals between QM selection updates, defaults to 0.0_dp meaning 'every step' - - ! Classical parameters - character(STRING_LENGTH) :: classical_args !% Arguments used to initialise classical potential - character(STRING_LENGTH) :: classical_args_str !% Arguments used by Calc Potential - real(dp) :: classical_force_reweight !% Factor by which to reduce classical forces in the embed region. Default is unity. - - ! QM parameters - character(STRING_LENGTH) :: qm_args !% Arguments used to initialise QM potential - character(STRING_LENGTH) :: qm_args_str !% Arguments used by QM potential - character(STRING_LENGTH) :: qm_extra_args_str !% Extra arguments passed to ForceMixing potential - logical :: qm_cp2k !% Enable CP2K mode. Default false. - logical :: qm_clusters !% Should we carve clusters? Default true. - logical :: qm_little_clusters !% One big cluster or lots of little ones? - integer :: qm_buffer_hops !% Number of bond hops used for buffer region - integer :: qm_transition_hops !% Number of transition hops used for buffer region - logical :: qm_terminate !% Terminate clusters with hydrogen atoms - logical :: qm_force_periodic !% Force clusters to be periodic in $z$ direction. - logical :: qm_randomise_buffer !% Randomise positions of outer layer of buffer atoms slightly to avoid systematic errors. - logical :: qm_even_electrons !% Discard a hydrogen if necessary to give an overall non-spin-polarised cluster - real(dp) :: qm_vacuum_size !% Amount of vacuum surrounding cluster in non-periodic directions ($x$ and $y$ at least). Unit:~\AA{}. - logical :: qm_calc_force_error !% Do a full QM calculation at each stage in extrap and interp to measure force error - logical :: qm_rescale_r !% If true, rescale space in QM cluster to match QM lattice constant - logical :: qm_hysteretic_buffer !% If true, manage the buffer region hysteritcally - real(dp) :: qm_hysteretic_buffer_inner_radius !% Inner radius used for hystertic buffer region - real(dp) :: qm_hysteretic_buffer_outer_radius !% Outer radius used for hystertic buffer region - logical :: qm_hysteretic_buffer_nneighb_only !% Should hysteretic buffer be formed by nearest neighbor hopping? - - logical :: qm_hysteretic_connect !% Enable hysteretic connectivity - real(dp) :: qm_hysteretic_connect_inner_factor !% Inner bond factor. Default 1.2 - real(dp) :: qm_hysteretic_connect_outer_factor !% Outer bond factor. Default 1.5 - real(dp) :: qm_hysteretic_connect_cluster_radius !% Radius other which to keep track of hysteretic connectivity info. Default 10.0 A. - - ! Fit parameters - integer :: fit_hops !% Number of hops used to generate fit region from embed region - integer :: fit_spring_hops !% Number of hops used when creating list of springs - character(STRING_LENGTH) :: fit_method !% Method to use for force mixing: should be one of - !% \begin{itemize} - !% \item 'lotf_adj_pot_svd' --- LOTF using SVD to optimised the Adj Pot - !% \item 'lotf_adj_pot_minim' --- LOTF using conjugate gradients to optimise the Adj Pot - !% \item 'lotf_adj_pot_sw' --- LOTF using old style SW Adj Pot - !% \item 'conserve_momentum' --- divide the total force on QM region over the fit atoms to conserve momentum - !% \item 'force_mixing' --- force mixing with details depending on values of - !% 'buffer_hops', 'transtion_hops' and 'weight_interpolation' - !% \item 'force_mixing_abrupt' --- simply use QM forces on QM atoms and MM forces on MM atoms - !% (shorthand for 'method=force_mixing buffer_hops=0 transition_hops=0') - !% \item 'force_mixing_smooth' --- use QM forces in QM region, MM forces in MM region and - !% linearly interpolate in buffer region (shorthand for 'method=force_mixing weight_interpolation=hop_ramp') - !% \item 'force_mixing_super_smooth' --- as above, but weight forces on each atom by distance from - !% centre of mass of core region (shorthand for 'method=force_mixing weight_interpolation=distance_ramp') - !% \end{itemize} - !% - - ! Force intergration parameters - character(STRING_LENGTH) :: force_integration_end_file !% XYZ file containing ending configuration for force integration. - integer :: force_integration_n_steps !% Number of steps to take in force integration - - ! Quasi-static loading parameters - real(dp) :: quasi_static_tip_move_tol !% How far cracktip must advance before we consider fracture to have occurred. - - ! Elastic constants C_ij - logical :: elastic_read - real(dp), dimension(6,6) :: elastic_cij - - ! Finally, nasty hacks - logical :: hack_qm_zero_z_force !% Zero $z$ component of all forces (used for graphene) - logical :: hack_fit_on_eqm_coordination_only !% Only include fit atoms that have coordination - !% number equal to 'md_eqm_coordination' (used for graphene). - - integer :: num_md_stanza, md_stanza - type(CrackMDParams) :: md(MAX_MD_STANZA) - - logical :: constraint_fix_gradient, constraint_fix_curvature, constraint_fix_position, constraint_fix_bond - real(dp) :: constraint_gradient, constraint_curvature, constraint_position, constraint_bond_length - integer :: constraint_bond_i, constraint_bond_j - - end type CrackParams - - type(CrackParams), pointer :: parse_cp - logical :: parse_in_crack - - public :: initialise - interface initialise - module procedure CrackParams_initialise - end interface - - public :: finalise - interface finalise - module procedure CrackParams_finalise - end interface finalise - - public :: print - interface print - module procedure CrackParams_print - end interface - - public :: read_xml - interface read_xml - module procedure CrackParams_read_xml_filename - module procedure CrackParams_read_xml - end interface - - -contains - - !% Convert a string representation of the material to - !% an atomic number array suitable for passing to 'diamond()', \emph{e.g.} - !% 'Si' $\to$ '14', 'C' $\to$ '6' and 'SiC' $\to$ '(/14,6/)'. - subroutine crack_parse_atomic_numbers(str, Z) - character(len=*), intent(in) :: str - integer, intent(out) :: Z(:) - - integer i, p - - i = 0 - p=1 - do while (p <= len(trim(str))) - i = i + 1 - if (i > size(Z)) call system_abort("Too many elements in str='"//trim(str)//"' for size(Z)="//size(Z)) - if (len(trim(str)) > p .and. scan(str(p+1:p+1),'abcdefghijklmnopqrstuvwxzy') == 1) then ! 2 letter element - Z(i) = Atomic_Number(str(p:p+1)) - p = p + 1 - else - Z(i) = Atomic_Number(str(p:p)) - endif - p = p + 1 - end do - - if (i == 0) then - call system_abort("parse_atomic_numbers failed to parse anything, str='"//trim(str)//"'") - else if (i == 1) then - Z(2:) = Z(1) - else - if (i /= size(Z)) then - call system_abort("parse_atomic_numbers found "//i//" elements, but size(Z)="//size(Z)) - endif - endif - end subroutine crack_parse_atomic_numbers - - - !% Initialise this CrackParams structure and set default - !% values for all parameters. WARNING: many of these defaults are - !% only really appropriate for diamond structure silicon fracture. - subroutine CrackParams_initialise(this, filename, validate) - type(CrackParams), intent(inout) :: this - character(len=*), optional, intent(in) :: filename - logical, optional, intent(in) :: validate - integer md_idx - - ! Parameters for 'makecrack' - this%crack_structure = 'diamond' - this%crack_element = 'Si' - this%crack_name = '(111)[11b0]' - this%crack_lattice_guess = 5.43_dp ! Angstrom, correct for Si - - ! Default lattice parameters for alpha quartz - this%crack_lattice_a = 4.87009_dp - this%crack_lattice_c = 5.36254_dp - this%crack_lattice_u = 0.46699_dp - this%crack_lattice_x = 0.41288_dp - this%crack_lattice_y = 0.27198_dp - this%crack_lattice_z = 0.11588_dp - - this%crack_width = 200.0_dp ! Angstrom - this%crack_height = 100.0_dp ! Angstrom - this%crack_num_layers = 1 ! number - this%crack_apply_initial_load = .true. - this%crack_strain = 0.01 ! default is 1% strain - this%crack_G = -1.0_dp ! overrides strain if > 0 - this%crack_loading = 'uniform' - this%crack_load_interp_length = 100.0_dp ! Angstrom - this%crack_ramp_length = 100.0_dp ! Angstrom - this%crack_ramp_start_length = 200.0_dp ! Angstrom - this%crack_ramp_end_G = 1.0_dp ! J/m^2 - this%crack_strain_increment = 0.005_dp ! 0.5% per loading cycle - this%crack_G_increment = 0.0_dp ! increment of G per loading cycle, override initial_loading_strain if present - this%crack_seed_length = 50.0_dp ! Angstrom - this%crack_strain_zone_width = 0.0_dp ! Angstrom - this%crack_vacuum_size = 100.0_dp ! Angstrom - this%crack_relax_loading_field = .true. - this%crack_rescale_x_z = .false. - this%crack_rescale_x = .false. - this%crack_edge_fix_tol = 2.7_dp ! Angstrom - this%crack_y_shift = 0.0_dp ! Angstrom - this%crack_x_shift = 0.0_dp ! Angstrom - this%crack_align_y = .true. ! Angstrom - this%crack_seed_embed_tol = 3.0_dp ! Angstrom - this%crack_dislo_seed = 0 - this%crack_double_ended = .false. - this%crack_tip_grid_size = 3.0_dp ! Angstrom - this%crack_tip_min_separation = 20.0_dp ! Angstrom - this%crack_tip_method = 'coordination' - this%crack_free_surfaces = .false. - this%crack_front_window_size = 5.44_dp ! Angstrom - this%crack_fix_sides = .false. - this%crack_fix_dipoles = .false. - this%crack_fix_dipoles_tol = 5.0_dp ! Angstrom - this%crack_thermostat_ramp_length = 50.0 - this%crack_thermostat_ramp_max_tau = 10000.0 - - this%crack_initial_velocity_field = .false. - this%crack_initial_velocity_field_dx = 3.84_dp ! Angstrom - this%crack_initial_velocity_field_dt = 100.0_dp ! fs - - this%crack_curved_front = .false. - this%crack_curvature = -0.001_dp - this%crack_front_alpha = 100.0_dp - this%crack_front_angle_threshold = 100.0_dp ! degrees - - ! Graphene specific crack parameters - this%crack_graphene_theta = 0.0_dp ! Angle - this%crack_graphene_notch_width = 5.0_dp ! Angstrom - this%crack_graphene_notch_height = 5.0_dp ! Angstrom - - this%crack_slab_filename = '' - this%crack_bulk_filename = '' - this%crack_relax_bulk = .true. - - this%crack_check_surface_coordination = .false. - this%crack_check_coordination_atom_type = 18 - this%crack_check_coordination_critical_nneigh = 2 - this%crack_check_coordination_region = 10.0_dp - - ! Basic simulation parameters - this%simulation_task = 'md' - this%simulation_seed = 0 - this%simulation_classical = .false. - this%simulation_force_initial_load_step = .false. - this%simulation_initial_state = '' - - ! Molecular dynamics parameters - this%num_md_stanza = 0 - this%md_stanza = 1 - do md_idx=1,MAX_MD_STANZA - this%md(md_idx)%time_step = 1.0_dp ! fs - this%md(md_idx)%extrapolate_steps = 10 ! number - this%md(md_idx)%crust = 2.0_dp ! Angstrom - this%md(md_idx)%recalc_connect_factor = 0.8_dp ! fraction of md%crust - this%md(md_idx)%nneigh_tol = 1.3_dp ! fraction of sum of covalent radii - this%md(md_idx)%eqm_coordination(1) = 4 ! eqm coordination for element 1 (e.g. Si) - this%md(md_idx)%eqm_coordination(2) = 2 ! eqm coordination for element 2 (e.g. O) - this%md(md_idx)%sim_temp = 300.0_dp ! Kelvin - this%md(md_idx)%avg_time = 50.0_dp ! fs - this%md(md_idx)%thermalise_tau = 50.0_dp ! fs - this%md(md_idx)%thermalise_wait_time = 400.0_dp ! fs - this%md(md_idx)%thermalise_wait_factor= 2.0_dp ! number - this%md(md_idx)%tau = 500.0_dp ! fs - this%md(md_idx)%per_atom_tau = .false. ! - this%md(md_idx)%wait_time = 500.0_dp ! fs - this%md(md_idx)%interval_time = 100.0_dp ! fs - this%md(md_idx)%calc_connect_interval = 10.0_dp ! fs - this%md(md_idx)%smooth_loading_rate = 0.0_dp - this%md(md_idx)%smooth_loading_tip_move_tol = 3.0_dp ! Angstrom - this%md(md_idx)%smooth_loading_arrest_time = 400.0_dp ! fs - this%md(md_idx)%smooth_loading_tip_edge_tol = 50.0_dp ! Angstrom - this%md(md_idx)%damping_time = 100.0_dp ! fs - this%md(md_idx)%stanza_time = -1.0_dp ! fs - this%md(md_idx)%max_runtime = -1.0_dp ! CPU seconds - this%md(md_idx)%crack_find_tip_interval = 100.0_dp ! fs - this%md(md_idx)%ensemble = 'NVT' - end do - - - ! Minimisation parameters - this%minim_method = 'cg' - this%minim_tol = 1e-3_dp ! normsq(force) eV/A - this%minim_eps_guess = 0.01_dp ! Angstrom - this%minim_max_steps = 1000 ! number - this%minim_print_output = 10 ! number - this%minim_linminroutine = 'LINMIN_DERIV' - this%minim_fire_dt0 = 1.0_dp ! fs - this%minim_fire_dt_max = 10.0_dp ! fs - this%minim_minimise_mm = .false. - this%minim_mm_method = 'cg' - this%minim_mm_tol = 1e-6_dp ! normsq(force) eV/A - this%minim_mm_eps_guess = 0.001_dp ! Angstrom - this%minim_mm_max_steps = 1000 ! number - this%minim_mm_linminroutine = 'FAST_LINMIN' - this%minim_mm_args_str = '' - - ! I/O parameters - this%io_verbosity = PRINT_NORMAL - this%io_netcdf = .false. - this%io_print_interval = 10.0_dp ! fs - this%io_print_all_properties = .false. - if (allocated(this%io_print_properties)) deallocate(this%io_print_properties) - allocate(this%io_print_properties(4)) - ! arrays of strings must all have the same length, really - this%io_print_properties = (/"species ", & - "pos ", & - "changed_nn ", & - "hybrid_mark "/) - this%io_checkpoint_interval = 100.0_dp ! fs - this%io_checkpoint_path = '' - this%io_mpi_print_all = .false. - this%io_backup = .false. - this%io_timing = .false. - - ! Selection parameters - this%selection_max_qm_atoms = 200 - this%selection_method = "coordination" - this%selection_ellipse = (/8.0_dp, 5.0_dp, 10.0_dp /) ! Angstrom - this%selection_ellipse_bias = 0.5_dp ! Fraction of principal radius in x direction - this%selection_ellipse_buffer = 1.3_dp ! Angstrom - this%selection_cutoff_plane = 10.0_dp ! Angstrom - this%selection_directionality = .true. - this%selection_edge_tol = 10.0_dp ! A - this%selection_update_interval= 0.0_dp - - ! Classical parameters - this%classical_args = 'IP SW' - this%classical_args_str = '' - this%classical_force_reweight = 1.0_dp ! Fraction - - ! QM parameters - this%qm_args = 'FilePot command=./castep_driver.py property_list=pos:embed' - this%qm_args_str = '' - this%qm_extra_args_str = '' - this%qm_cp2k = .false. - this%qm_clusters = .true. - this%qm_little_clusters = .false. - this%qm_buffer_hops = 3 ! Number - this%qm_transition_hops = 0 ! Number - this%qm_terminate = .true. - this%qm_force_periodic = .false. - this%qm_randomise_buffer = .true. - this%qm_even_electrons = .false. - this%qm_vacuum_size = 10.0_dp ! Angstrom - this%qm_calc_force_error = .false. - this%qm_rescale_r = .false. - this%qm_hysteretic_buffer = .false. - this%qm_hysteretic_buffer_inner_radius = 5.0_dp - this%qm_hysteretic_buffer_outer_radius = 7.0_dp - this%qm_hysteretic_buffer_nneighb_only = .true. - this%qm_hysteretic_connect = .false. - this%qm_hysteretic_connect_inner_factor = 1.2_dp - this%qm_hysteretic_connect_outer_factor = 1.5_dp - this%qm_hysteretic_connect_cluster_radius = 10.0_dp - - ! Fit parameters - this%fit_hops = 3 - this%fit_spring_hops = 3 - this%fit_method = 'lotf_adj_pot_svd' - - ! Force integration parameters - this%force_integration_end_file = '' ! Filename - this%force_integration_n_steps = 10 ! number - - ! Quasi static loading - this%quasi_static_tip_move_tol = 5.0_dp ! Angstrom - - this%elastic_read = .false. - this%elastic_cij = 0.0_dp - - ! Nasty hack - this%hack_qm_zero_z_force = .false. - this%hack_fit_on_eqm_coordination_only = .false. - - ! Constraints - this%constraint_fix_position = .false. - this%constraint_fix_gradient = .false. - this%constraint_fix_curvature = .false. - this%constraint_fix_bond = .false. - this%constraint_bond_i = 0 - this%constraint_bond_j = 0 - this%constraint_bond_length = 0.0_dp - this%constraint_position = 0.0_dp - this%constraint_gradient = 0.0_dp - this%constraint_curvature = 0.0_dp - - if (present(filename)) then - call read_xml(this, filename, validate=validate) - end if - - end subroutine CrackParams_initialise - - subroutine CrackParams_finalise(this) - type(CrackParams), intent(inout) :: this - - ! do nothing - - end subroutine CrackParams_finalise - - - !% Read crack parameters from 'xmlfile' into this CrackParams object. - !% First we reset to default values by calling 'initialise(this)'. - - subroutine CrackParams_read_xml_filename(this, filename, validate, error) - type(CrackParams), intent(inout), target :: this - character(len=*), intent(in) :: filename - logical, optional, intent(in) :: validate - integer, intent(out), optional :: error - - type(InOutput) xml - - INIT_ERROR(error) - - call initialise(xml, filename, INPUT) - call crackparams_read_xml(this, xml, validate, error) - PASS_ERROR(error) - - call finalise(xml) - - end subroutine CrackParams_read_xml_filename - - subroutine CrackParams_read_xml(this, xmlfile, validate, error) - type(CrackParams), intent(inout), target :: this - type(Inoutput),intent(in) :: xmlfile - logical, optional, intent(in) :: validate - integer, intent(out), optional :: error - - type (xml_t) :: fxml - type(extendable_str) :: ss, ss2 - type(Dictionary) :: env_dict - character(len=256) :: quip_dtd_dir - logical do_validate - integer status - - INIT_ERROR(error) - do_validate = optional_default(.false., validate) - - call initialise(this) ! Reset to defaults - - call Initialise(ss) - if (do_validate) then - call read(ss, xmlfile%unit, convert_to_string=.true.) - call initialise(env_dict) - call get_env_var('QUIP_DTD_DIR', quip_dtd_dir, status=status) - if (status /= 0) then - call get_env_var('QUIP_ROOT', quip_dtd_dir, status=status) - if (status /= 0) then - call get_env_var("HOME", quip_dtd_dir, status) - if (status /= 0) then - RAISE_ERROR("Could not get QUIP_DTD_DIR or QUIP_ROOT or HOME env variables", error) - else - quip_dtd_dir = trim(quip_dtd_dir)//"/share/quip_dtds" - end if - else - quip_dtd_dir = trim(quip_dtd_dir)//"/dtds" - end if - end if - call set_value(env_dict, 'QUIP_DTD_DIR', quip_dtd_dir) - call expand_string(env_dict, ss, ss2, error) - PASS_ERROR(error) - call finalise(ss) - call finalise(env_dict) - else - call read(ss2, xmlfile%unit, convert_to_string=.true.) - end if - - if (len(trim(string(ss2))) <= 0) return - - call open_xml_string(fxml, string(ss2)) - - parse_cp => this - parse_in_crack = .false. - - call parse(fxml, & - startElement_handler = CrackParams_startElement_handler, & - endElement_handler = CrackParams_endElement_handler, & - error_handler = CrackParams_error_handler, & - fatalError_handler = CrackParams_error_handler, & - warning_handler = CrackParams_error_handler, & - validate=validate) - - call close_xml_t(fxml) - call Finalise(ss2) - - if ((this%crack_strain_zone_width .feq. 0.0_dp) .and. this%crack_G > 0.0_dp) & - this%crack_strain_zone_width = this%crack_G * 10.0_dp - - end subroutine CrackParams_read_xml - - subroutine CrackParams_error_handler(msg) - character(len=*), intent(in) :: msg - - call system_abort(msg) - - end subroutine CrackParams_error_handler - - !% OMIT - subroutine CrackParams_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - - logical :: got_species - integer :: n_properties, i, j - character(len=1024) :: tmp_properties(MAX_PROPERTIES) - - if (name == 'crack_params') then ! new crack_params stanza - - parse_in_crack = .true. - - elseif (parse_in_crack .and. name == 'crack') then - - call QUIP_FoX_get_value(attributes, "structure", value, status) - if (status == 0) then - parse_cp%crack_structure = value - end if - - call QUIP_FoX_get_value(attributes, "element", value, status) - if (status == 0) then - parse_cp%crack_element = value - call crack_parse_atomic_numbers(parse_cp%crack_element, parse_cp%crack_z) - end if - - call QUIP_FoX_get_value(attributes, "name", value, status) - if (status == 0) then - parse_cp%crack_name = value - end if - - call QUIP_FoX_get_value(attributes, "lattice_guess", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_lattice_guess - end if - - call QUIP_FoX_get_value(attributes, "lattice_a", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_lattice_a - end if - - call QUIP_FoX_get_value(attributes, "lattice_c", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_lattice_c - end if - - call QUIP_FoX_get_value(attributes, "lattice_u", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_lattice_u - end if - - call QUIP_FoX_get_value(attributes, "lattice_x", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_lattice_x - end if - - call QUIP_FoX_get_value(attributes, "lattice_y", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_lattice_y - end if - - call QUIP_FoX_get_value(attributes, "lattice_z", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_lattice_z - end if - - call QUIP_FoX_get_value(attributes, "width", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_width - end if - - call QUIP_FoX_get_value(attributes, "height", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_height - end if - - call QUIP_FoX_get_value(attributes, "num_layers", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_num_layers - end if - - call QUIP_FoX_get_value(attributes, "apply_initial_load", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_apply_initial_load - end if - - call QUIP_FoX_get_value(attributes, "strain", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_strain - end if - - call QUIP_FoX_get_value(attributes, "G", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_G - end if - - call QUIP_FoX_get_value(attributes, "loading", value, status) - if (status == 0) then - parse_cp%crack_loading = value - end if - - call QUIP_FoX_get_value(attributes, "load_interp_length", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_load_interp_length - end if - - call QUIP_FoX_get_value(attributes, "ramp_length", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_ramp_length - end if - - call QUIP_FoX_get_value(attributes, "ramp_start_length", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_ramp_start_length - end if - - call QUIP_FoX_get_value(attributes, "ramp_end_G", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_ramp_end_G - end if - call QUIP_FoX_get_value(attributes, "initial_loading_strain", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_strain_increment - end if - - call QUIP_FoX_get_value(attributes, "G_increment", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_G_increment - end if - - call QUIP_FoX_get_value(attributes, "seed_length", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_seed_length - end if - - call QUIP_FoX_get_value(attributes, "strain_zone_width", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_strain_zone_width - end if - - call QUIP_FoX_get_value(attributes, "vacuum_size", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_vacuum_size - end if - - call QUIP_FoX_get_value(attributes, "rescale_x_z", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_rescale_x_z - end if - - call QUIP_FoX_get_value(attributes, "rescale_x", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_rescale_x - end if - - call QUIP_FoX_get_value(attributes, "relax_loading_field", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_relax_loading_field - end if - - call QUIP_FoX_get_value(attributes, "edge_fix_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_edge_fix_tol - end if - - call QUIP_FoX_get_value(attributes, "y_shift", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_y_shift - end if - - call QUIP_FoX_get_value(attributes, "x_shift", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_x_shift - end if - - call QUIP_FoX_get_value(attributes, "align_y", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_align_y - end if - - call QUIP_FoX_get_value(attributes, "seed_embed_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_seed_embed_tol - end if - - call QUIP_FoX_get_value(attributes, "graphene_theta", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_graphene_theta - end if - - call QUIP_FoX_get_value(attributes, "graphene_notch_width", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_graphene_notch_width - end if - - call QUIP_FoX_get_value(attributes, "graphene_notch_height", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_graphene_notch_height - end if - - call QUIP_FoX_get_value(attributes, "slab_filename", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_slab_filename - end if - - call QUIP_FoX_get_value(attributes, "bulk_filename", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_bulk_filename - end if - - call QUIP_FoX_get_value(attributes, "relax_bulk", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_relax_bulk - end if - - call QUIP_FoX_get_value(attributes, "dislo_seed", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_dislo_seed - end if - - call QUIP_FoX_get_value(attributes, "check_surface_coordination", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_check_surface_coordination - end if - - call QUIP_FoX_get_value(attributes, "check_coordination_atom_type", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_check_coordination_atom_type - end if - - call QUIP_FoX_get_value(attributes,"check_coordination_critical_nneigh", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_check_coordination_critical_nneigh - end if - - call QUIP_FoX_get_value(attributes,"check_coordination_region", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_check_coordination_region - end if - - call QUIP_FoX_get_value(attributes, "double_ended", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_double_ended - end if - - call QUIP_FoX_get_value(attributes, "tip_grid_size", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_tip_grid_size - end if - - call QUIP_FoX_get_value(attributes, "tip_min_separation", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_tip_min_separation - end if - - call QUIP_FoX_get_value(attributes, "tip_method", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_tip_method - end if - - call QUIP_FoX_get_value(attributes, "free_surfaces", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_free_surfaces - end if - - call QUIP_FoX_get_value(attributes, "front_window_size", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_front_window_size - end if - - call QUIP_FoX_get_value(attributes, "fix_sides", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_fix_sides - end if - - call QUIP_FoX_get_value(attributes, "fix_dipoles", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_fix_dipoles - end if - - call QUIP_FoX_get_value(attributes, "fix_dipoles_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_fix_dipoles_tol - end if - - call QUIP_FoX_get_value(attributes, "thermostat_ramp_length", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_thermostat_ramp_length - end if - - call QUIP_FoX_get_value(attributes, "thermostat_ramp_max_tau", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_thermostat_ramp_max_tau - end if - - call QUIP_FoX_get_value(attributes, "initial_velocity_field", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_initial_velocity_field - end if - - call QUIP_FoX_get_value(attributes, "initial_velocity_field_dx", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_initial_velocity_field_dx - end if - - call QUIP_FoX_get_value(attributes, "initial_velocity_field_dt", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_initial_velocity_field_dt - end if - - call QUIP_FoX_get_value(attributes, "curved_front", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_curved_front - end if - - call QUIP_FoX_get_value(attributes, "curvature", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_curvature - end if - - call QUIP_FoX_get_value(attributes, "front_alpha", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_front_alpha - end if - - call QUIP_FoX_get_value(attributes, "front_angle_threshold", value, status) - if (status == 0) then - read (value, *) parse_cp%crack_front_angle_threshold - end if - - elseif (parse_in_crack .and. name == 'simulation') then - - call QUIP_FoX_get_value(attributes, "task", value, status) - if (status == 0) then - parse_cp%simulation_task = value - end if - - call QUIP_FoX_get_value(attributes, "seed", value, status) - if (status == 0) then - read (value, *) parse_cp%simulation_seed - end if - - call QUIP_FoX_get_value(attributes, "classical", value, status) - if (status == 0) then - read (value, *) parse_cp%simulation_classical - end if - - call QUIP_FoX_get_value(attributes, "force_initial_load_step", value, status) - if (status == 0) then - read (value, *) parse_cp%simulation_force_initial_load_step - end if - - call QUIP_FoX_get_value(attributes, "initial_state", value, status) - if (status == 0) then - read (value, *) parse_cp%simulation_initial_state - end if - - - elseif (parse_in_crack .and. name == 'md') then - - parse_cp%num_md_stanza = parse_cp%num_md_stanza + 1 - if (parse_cp%num_md_stanza > MAX_MD_STANZA) call system_abort('Too many stanza (maxmimum '//MAX_MD_STANZA//')') - - call QUIP_FoX_get_value(attributes, "time_step", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%time_step - end if - - call QUIP_FoX_get_value(attributes, "sim_temp", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%sim_temp - end if - - call QUIP_FoX_get_value(attributes, "extrapolate_steps", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%extrapolate_steps - end if - - call QUIP_FoX_get_value(attributes, "crust", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%crust - end if - - call QUIP_FoX_get_value(attributes, "recalc_connect_factor", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%recalc_connect_factor - end if - - call QUIP_FoX_get_value(attributes, "nneigh_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%nneigh_tol - end if - - call QUIP_FoX_get_value(attributes, "eqm_coordination", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%eqm_coordination - end if - - call QUIP_FoX_get_value(attributes, "avg_time", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%avg_time - end if - - call QUIP_FoX_get_value(attributes, "thermalise_tau", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%thermalise_tau - end if - - call QUIP_FoX_get_value(attributes, "thermalise_wait_time", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%thermalise_wait_time - end if - - call QUIP_FoX_get_value(attributes, "thermalise_wait_factor", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%thermalise_wait_factor - end if - - call QUIP_FoX_get_value(attributes, "tau", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%tau - end if - - call QUIP_FoX_get_value(attributes, "per_atom_tau", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%per_atom_tau - end if - - call QUIP_FoX_get_value(attributes, "wait_time", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%wait_time - end if - - call QUIP_FoX_get_value(attributes, "interval_time", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%interval_time - end if - - call QUIP_FoX_get_value(attributes, "calc_connect_interval", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%calc_connect_interval - end if - - call QUIP_FoX_get_value(attributes, "smooth_loading_rate", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%smooth_loading_rate - end if - - call QUIP_FoX_get_value(attributes, "smooth_loading_tip_move_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%smooth_loading_tip_move_tol - end if - - call QUIP_FoX_get_value(attributes, "smooth_loading_arrest_time", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%smooth_loading_arrest_time - end if - - call QUIP_FoX_get_value(attributes, "smooth_loading_tip_edge_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%smooth_loading_tip_edge_tol - end if - - call QUIP_FoX_get_value(attributes, "damping_time", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%damping_time - end if - - call QUIP_FoX_get_value(attributes, "stanza_time", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%stanza_time - end if - - call QUIP_FoX_get_value(attributes, "max_runtime", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%max_runtime - end if - - call QUIP_FoX_get_value(attributes, "crack_find_tip_interval", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%crack_find_tip_interval - end if - - call QUIP_FoX_get_value(attributes, "ensemble", value, status) - if (status == 0) then - read (value, *) parse_cp%md(parse_cp%num_md_stanza)%ensemble - end if - - - elseif (parse_in_crack .and. name == 'minim') then - - call QUIP_FoX_get_value(attributes, "method", value, status) - if (status == 0) then - parse_cp%minim_method = value - end if - - call QUIP_FoX_get_value(attributes, "tol", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_tol - end if - - call QUIP_FoX_get_value(attributes, "eps_guess", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_eps_guess - end if - - call QUIP_FoX_get_value(attributes, "max_steps", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_max_steps - end if - - call QUIP_FoX_get_value(attributes, "print_output", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_print_output - end if - - call QUIP_FoX_get_value(attributes, "linminroutine", value, status) - if (status == 0) then - parse_cp%minim_linminroutine = value - end if - - call QUIP_FoX_get_value(attributes, "fire_dt0", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_fire_dt0 - end if - - call QUIP_FoX_get_value(attributes, "fire_dt_max", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_fire_dt_max - end if - - call QUIP_FoX_get_value(attributes, "minimise_mm", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_minimise_mm - end if - - call QUIP_FoX_get_value(attributes, "mm_method", value, status) - if (status == 0) then - parse_cp%minim_mm_method = value - end if - - call QUIP_FoX_get_value(attributes, "mm_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_mm_tol - end if - - call QUIP_FoX_get_value(attributes, "mm_eps_guess", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_mm_eps_guess - end if - - call QUIP_FoX_get_value(attributes, "mm_max_steps", value, status) - if (status == 0) then - read (value, *) parse_cp%minim_mm_max_steps - end if - - call QUIP_FoX_get_value(attributes, "mm_linminroutine", value, status) - if (status == 0) then - parse_cp%minim_mm_linminroutine = value - end if - - call QUIP_FoX_get_value(attributes, "mm_args_str", value, status) - if (status == 0) then - parse_cp%minim_mm_args_str = value - end if - - elseif (parse_in_crack .and. name == 'io') then - - call QUIP_FoX_get_value(attributes, "verbosity", value, status) - if (status == 0) then - parse_cp%io_verbosity = verbosity_of_str(value) - end if - - call QUIP_FoX_get_value(attributes, "netcdf", value, status) - if (status == 0) then - read (value, *) parse_cp%io_netcdf - end if - - call QUIP_FoX_get_value(attributes, "print_interval", value, status) - if (status == 0) then - read (value, *) parse_cp%io_print_interval - end if - - call QUIP_FoX_get_value(attributes, "print_all_properties", value, status) - if (status == 0) then - read (value, *) parse_cp%io_print_all_properties - end if - - call QUIP_FoX_get_value(attributes, "print_properties", value, status) - if (status == 0) then - - ! Backwards compatibility: prepend species tag if it's missing - call parse_string(value, ':', tmp_properties, n_properties) - got_species = .false. - do i=1, n_properties - if (trim(tmp_properties(i)) == 'species') then - if (i /= 1) then - tmp_properties(i) = tmp_properties(1) - tmp_properties(1) = 'species' - endif - got_species = .true. - endif - end do - - if (got_species) then - value = trim(tmp_properties(1)) - do i=2, n_properties - value = trim(value) // ':' // tmp_properties(i) - end do - else - value = 'species:'//trim(value) - endif - - call parse_string(value, ':', tmp_properties, n_properties) - - if (n_properties > MAX_PROPERTIES) & - call system_abort('error reading io_print_properties: MAX_PROPERTIES('//MAX_PROPERTIES//') exceeded') - - if (allocated(parse_cp%io_print_properties)) deallocate(parse_cp%io_print_properties) - allocate(parse_cp%io_print_properties(n_properties)) - parse_cp%io_print_properties(1:n_properties) = tmp_properties(1:n_properties) - - end if - - call QUIP_FoX_get_value(attributes, "checkpoint_interval", value, status) - if (status == 0) then - read (value, *) parse_cp%io_checkpoint_interval - end if - - call QUIP_FoX_get_value(attributes, "checkpoint_path", value, status) - if (status == 0) then - read (value, *) parse_cp%io_checkpoint_path - end if - - call QUIP_FoX_get_value(attributes, "mpi_print_all", value, status) - if (status == 0) then - read (value, *) parse_cp%io_mpi_print_all - end if - - call QUIP_FoX_get_value(attributes, "backup", value, status) - if (status == 0) then - read (value, *) parse_cp%io_backup - end if - - call QUIP_FoX_get_value(attributes, "timing", value, status) - if (status == 0) then - read (value, *) parse_cp%io_timing - end if - - elseif (parse_in_crack .and. name == 'selection') then - - call QUIP_FoX_get_value(attributes, "max_qm_atoms", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_max_qm_atoms - end if - - call QUIP_FoX_get_value(attributes, "method", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_method - end if - - call QUIP_FoX_get_value(attributes, "ellipse", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_ellipse - end if - - call QUIP_FoX_get_value(attributes, "ellipse_bias", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_ellipse_bias - end if - - call QUIP_FoX_get_value(attributes, "ellipse_buffer", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_ellipse_buffer - end if - - call QUIP_FoX_get_value(attributes, "cutoff_plane", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_cutoff_plane - end if - - call QUIP_FoX_get_value(attributes, "directionality", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_directionality - end if - - call QUIP_FoX_get_value(attributes, "edge_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_edge_tol - end if - - call QUIP_FoX_get_value(attributes, "update_interval", value, status) - if (status == 0) then - read (value, *) parse_cp%selection_update_interval - end if - - - - elseif (parse_in_crack .and. name == 'classical') then - - call QUIP_FoX_get_value(attributes, "args", value, status) - if (status == 0) then - parse_cp%classical_args = value - end if - - call QUIP_FoX_get_value(attributes, "args_str", value, status) - if (status == 0) then - parse_cp%classical_args_str = value - end if - - call QUIP_FoX_get_value(attributes, "force_reweight", value, status) - if (status == 0) then - read (value, *) parse_cp%classical_force_reweight - end if - - elseif (parse_in_crack .and. name == 'qm') then - - call QUIP_FoX_get_value(attributes, "args", value, status) - if (status == 0) then - parse_cp%qm_args = value - end if - - call QUIP_FoX_get_value(attributes, "args_str", value, status) - if (status == 0) then - parse_cp%qm_args_str = value - end if - - call QUIP_FoX_get_value(attributes, "extra_args_str", value, status) - if (status == 0) then - parse_cp%qm_extra_args_str = value - end if - - - call QUIP_FoX_get_value(attributes, "cp2k", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_cp2k - end if - - call QUIP_FoX_get_value(attributes, "clusters", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_clusters - end if - - call QUIP_FoX_get_value(attributes, "little_clusters", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_little_clusters - end if - - ! backwards compatibility - call QUIP_FoX_get_value(attributes, "small_clusters", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_little_clusters - end if - - call QUIP_FoX_get_value(attributes, "buffer_hops", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_buffer_hops - end if - - call QUIP_FoX_get_value(attributes, "transition_hops", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_transition_hops - end if - - call QUIP_FoX_get_value(attributes, "terminate", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_terminate - end if - - call QUIP_FoX_get_value(attributes, "force_periodic", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_force_periodic - end if - - call QUIP_FoX_get_value(attributes, "randomise_buffer", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_randomise_buffer - end if - - ! backwards compatibility - call QUIP_FoX_get_value(attributes, "even_hydrogens", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_even_electrons - end if - - call QUIP_FoX_get_value(attributes, "even_electrons", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_even_electrons - end if - - call QUIP_FoX_get_value(attributes, "vacuum_size", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_vacuum_size - end if - - call QUIP_FoX_get_value(attributes, "calc_force_error", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_calc_force_error - end if - - call QUIP_FoX_get_value(attributes, "rescale_r", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_rescale_r - end if - - call QUIP_FoX_get_value(attributes, "hysteretic_buffer", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_hysteretic_buffer - end if - - call QUIP_FoX_get_value(attributes, "hysteretic_buffer_inner_radius", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_hysteretic_buffer_inner_radius - end if - - call QUIP_FoX_get_value(attributes, "hysteretic_buffer_outer_radius", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_hysteretic_buffer_outer_radius - end if - - call QUIP_FoX_get_value(attributes, "hysteretic_buffer_nneighb_only", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_hysteretic_buffer_nneighb_only - end if - - call QUIP_FoX_get_value(attributes, "hysteretic_connect", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_hysteretic_connect - end if - - call QUIP_FoX_get_value(attributes, "hysteretic_connect_inner_factor", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_hysteretic_connect_inner_factor - end if - - call QUIP_FoX_get_value(attributes, "hysteretic_connect_outer_factor", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_hysteretic_connect_outer_factor - end if - - call QUIP_FoX_get_value(attributes, "hysteretic_connect_cluster_radius", value, status) - if (status == 0) then - read (value, *) parse_cp%qm_hysteretic_connect_cluster_radius - end if - - - elseif (parse_in_crack .and. name == 'fit') then - - call QUIP_FoX_get_value(attributes, "hops", value, status) - if (status == 0) then - read (value, *) parse_cp%fit_hops - end if - - call QUIP_FoX_get_value(attributes, "spring_hops", value, status) - if (status == 0) then - read (value, *) parse_cp%fit_spring_hops - end if - - call QUIP_FoX_get_value(attributes, "method", value, status) - if (status == 0) then - parse_cp%fit_method = value - end if - - - elseif (parse_in_crack .and. name == 'force_integration') then - - call QUIP_FoX_get_value(attributes, "end_file", value, status) - if (status == 0) then - parse_cp%force_integration_end_file = value - end if - - call QUIP_FoX_get_value(attributes, "n_steps", value, status) - if (status == 0) then - read (value, *) parse_cp%force_integration_n_steps - end if - - elseif (parse_in_crack .and. name == 'quasi_static') then - - call QUIP_FoX_get_value(attributes, "tip_move_tol", value, status) - if (status == 0) then - read (value, *) parse_cp%quasi_static_tip_move_tol - end if - - elseif (parse_in_crack .and. name == 'elastic') then - - call QUIP_FoX_get_value(attributes, "read", value, status) - if (status == 0) then - read(value, *) parse_cp%elastic_read - end if - - do i=1,6 - do j=1,6 - call QUIP_FoX_get_value(attributes, "c_"//i//j, value, status) - if (status == 0) then - read(value, *) parse_cp%elastic_cij(i,j) - end if - end do - end do - - - elseif (parse_in_crack .and. name == 'hack') then - - call QUIP_FoX_get_value(attributes, "qm_zero_z_force", value, status) - if (status == 0) then - read (value, *) parse_cp%hack_qm_zero_z_force - end if - - call QUIP_FoX_get_value(attributes, "fit_on_eqm_coordination_only", value, status) - if (status == 0) then - read (value, *) parse_cp%hack_fit_on_eqm_coordination_only - end if - - elseif (parse_in_crack .and. name == 'constraint') then - - call QUIP_FoX_get_value(attributes, "fix_bond", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_fix_bond - end if - - call QUIP_FoX_get_value(attributes, "bond_i", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_bond_i - end if - - call QUIP_FoX_get_value(attributes, "bond_j", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_bond_j - end if - - call QUIP_FoX_get_value(attributes, "bond_length", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_bond_length - end if - - call QUIP_FoX_get_value(attributes, "fix_position", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_fix_position - end if - - call QUIP_FoX_get_value(attributes, "position", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_position - end if - - call QUIP_FoX_get_value(attributes, "fix_curvature", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_fix_curvature - end if - - call QUIP_FoX_get_value(attributes, "curvature", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_curvature - end if - - call QUIP_FoX_get_value(attributes, "fix_gradient", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_fix_gradient - end if - - call QUIP_FoX_get_value(attributes, "gradient", value, status) - if (status == 0) then - read (value, *) parse_cp%constraint_gradient - end if - - - endif - - end subroutine CrackParams_startElement_handler - - !% OMIT - subroutine CrackParams_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_crack) then - if (name == 'crack_params') then - parse_in_crack = .false. - endif - endif - - end subroutine CrackParams_endElement_handler - - - !% Print out this CrackParams structure - subroutine CrackParams_print(this,file) - type(CrackParams), intent(in) :: this - type(Inoutput), optional, intent(in) :: file - integer :: i, md_idx - - call Print(' Crack parameters:',file=file) - call Print(' structure = '//trim(this%crack_structure),file=file) - call Print(' element = '//trim(this%crack_element),file=file) - call Print(' lattice_guess = '//this%crack_lattice_guess//' A',file=file) - call Print(' lattice_a = '//this%crack_lattice_a//' A',file=file) - call Print(' lattice_c = '//this%crack_lattice_c//' A',file=file) - call Print(' lattice_u = '//this%crack_lattice_u//' A',file=file) - call Print(' lattice_x = '//this%crack_lattice_x//' A',file=file) - call Print(' lattice_y = '//this%crack_lattice_y//' A',file=file) - call Print(' lattice_z = '//this%crack_lattice_z//' A',file=file) - call Print(' name = '//trim(this%crack_name),file=file) - call Print(' width = '//this%crack_width//' A', file=file) - call Print(' height = '//this%crack_height//' A', file=file) - call Print(' num_layers = '//this%crack_num_layers, file=file) - call Print(' apply_initial_load = '//this%crack_apply_initial_load, file=file) - call Print(' strain = '//this%crack_strain, file=file) - call Print(' G = '//this%crack_G//' J/m^2', file=file) - call Print(' loading = '//this%crack_loading, file=file) - call Print(' load_interp_length = '//this%crack_load_interp_length, file=file) - call Print(' ramp_length = '//this%crack_ramp_length//' A', file=file) - call Print(' ramp_start_length = '//this%crack_ramp_start_length//' A', file=file) - call Print(' ramp_end_G = '//this%crack_ramp_end_G//' J/m^2', file=file) - call Print(' strain_increment = '//this%crack_strain_increment, file=file) - call Print(' G_increment = '//this%crack_G_increment//' J/m^2 per load cycle', file=file) - call Print(' seed_length = '//this%crack_seed_length//' A', file=file) - call Print(' strain_zone_width = '//this%crack_strain_zone_width//' A', file=file) - call Print(' vacuum_size = '//this%crack_vacuum_size//' A', file=file) - call Print(' relax_loading_field = '//this%crack_relax_loading_field, file=file) - call Print(' rescale_x_z = '//this%crack_rescale_x_z, file=file) - call Print(' rescale_x = '//this%crack_rescale_x, file=file) - call Print(' edge_fix_tol = '//this%crack_edge_fix_tol//' A', file=file) - call Print(' y_shift = '//this%crack_y_shift//' A', file=file) - call Print(' x_shift = '//this%crack_x_shift//' A', file=file) - call Print(' align_y = '//this%crack_align_y, file=file) - call Print(' seed_embed_tol = '//this%crack_seed_embed_tol//' A', file=file) - call Print(' graphene_theta = '//this%crack_graphene_theta//' rad', file=file) - call Print(' graphene_notch_width = '//this%crack_graphene_notch_width//' A', file=file) - call Print(' graphene_notch_height = '//this%crack_graphene_notch_height//' A', file=file) - call Print(' slab_filename = '//this%crack_slab_filename, file=file) - call Print(' bulk_filename = '//this%crack_bulk_filename, file=file) - call Print(' relax_bulk = '//this%crack_relax_bulk, file=file) - call Print(' dislo_seed = '//this%crack_dislo_seed, file=file) - call Print(' check_surface_coordination = '//this%crack_check_surface_coordination, file=file) - call Print(' check_coordination_atom_type = '//this%crack_check_coordination_atom_type, file=file) - call Print(' check_coordination_critical_nneigh = '//this%crack_check_coordination_critical_nneigh, file=file) - call Print(' check_coordination_region = '//this%crack_check_coordination_region//' A', file=file) - call Print(' doubled_ended = '//this%crack_double_ended, file=file) - call Print(' tip_grid_size = '//this%crack_tip_grid_size, file=file) - call Print(' tip_min_separation = '//this%crack_tip_min_separation, file=file) - call Print(' tip_method = '//trim(this%crack_tip_method), file=file) - call Print(' free_surfaces = '//this%crack_free_surfaces, file=file) - call Print(' front_window_size = '//this%crack_front_window_size, file=file) - call Print(' fix_sides = '//this%crack_fix_sides, file=file) - call Print(' fix_dipoles = '//this%crack_fix_dipoles, file=file) - call Print(' fix_dipoles_tol = '//this%crack_fix_dipoles_tol, file=file) - call Print(' thermostat_ramp_length = '//this%crack_thermostat_ramp_length//' A', file=file) - call Print(' thermostat_ramp_max_tau = '//this%crack_thermostat_ramp_max_tau//' fs', file=file) - call Print(' curved_front = '//this%crack_curved_front, file=file) - call Print(' curvature = '//this%crack_curvature, file=file) - call Print(' front_alpha = '//this%crack_front_alpha, file=file) - call Print(' front_angle_threshold = '//this%crack_front_angle_threshold, file=file) - call Print('',file=file) - call Print(' Simulation parameters:',file=file) - call Print(' task = '//trim(this%simulation_task),file=file) - call Print(' seed = '//this%simulation_seed,file=file) - call Print(' classical = '//this%simulation_classical,file=file) - call Print(' force_initial_load_step = '//this%simulation_force_initial_load_step,file=file) - call Print(' initial_state = '//this%simulation_initial_state,file=file) - call Print('',file=file) - call Print(' MD parameters:',file=file) - call print(' num_md_stanza = '//this%num_md_stanza) - do md_idx=1,this%num_md_stanza - call print(' md_stanza = '//md_idx) - call Print(' time_step = '//this%md(md_idx)%time_step//' fs',file=file) - call Print(' extrapolate_steps = '//this%md(md_idx)%extrapolate_steps,file=file) - call Print(' crust = '//this%md(md_idx)%crust//' A',file=file) - call Print(' recalc_connect_factor = '//this%md(md_idx)%recalc_connect_factor,file=file) - call Print(' nneigh_tol = '//this%md(md_idx)%nneigh_tol,file=file) - call Print(' eqm_coordination = '//this%md(md_idx)%eqm_coordination,file=file) - call Print(' sim_temp = '//this%md(md_idx)%sim_temp//' K',file=file) - call Print(' avg_time = '//this%md(md_idx)%avg_time//' fs',file=file) - call Print(' thermalise_tau = '//this%md(md_idx)%thermalise_tau//' fs',file=file) - call Print(' thermalise_wait_time = '//this%md(md_idx)%thermalise_wait_time//' fs',file=file) - call Print(' thermalise_wait_factor = '//this%md(md_idx)%thermalise_wait_factor//' fs',file=file) - call Print(' tau = '//this%md(md_idx)%tau//' fs',file=file) - call Print(' per_atom_tau = '//this%md(md_idx)%per_atom_tau,file=file) - call Print(' wait_time = '//this%md(md_idx)%wait_time//' fs',file=file) - call Print(' interval_time = '//this%md(md_idx)%interval_time//' fs',file=file) - call Print(' calc_connect_interval = '//this%md(md_idx)%calc_connect_interval//' fs',file=file) - call Print(' smooth_loading_rate = '//this%md(md_idx)%smooth_loading_rate//' (J/m^2)/fs', file=file) - call Print(' smooth_loading_tip_move_tol = '//this%md(md_idx)%smooth_loading_tip_move_tol//' A', file=file) - call Print(' smooth_loading_arrest_time = '//this%md(md_idx)%smooth_loading_arrest_time//' fs', file=file) - call Print(' smooth_loading_tip_edge_tol = '//this%md(md_idx)%smooth_loading_tip_edge_tol//' A', file=file) - call Print(' damping_time ='//this%md(md_idx)%damping_time//' fs', file=file) - call Print(' stanza_time ='//this%md(md_idx)%stanza_time//' s', file=file) - call Print(' max_runtime ='//this%md(md_idx)%max_runtime//' s', file=file) - call Print(' crack_find_tip_interval ='//this%md(md_idx)%crack_find_tip_interval//' fs', file=file) - call Print(' ensemble = '//this%md(md_idx)%ensemble, file=file) - end do - call Print('',file=file) - call Print(' Minimisation parameters:',file=file) - call Print(' method = '//trim(this%minim_method),file=file) - call Print(' tol = '//this%minim_tol//' (eV/A)^2',file=file) - call Print(' eps_guess = '//this%minim_eps_guess//' A',file=file) - call Print(' max_steps = '//this%minim_max_steps,file=file) - call Print(' print_output = '//this%minim_print_output,file=file) - call Print(' linminroutine = '//trim(this%minim_linminroutine),file=file) - call Print(' fire_dt0 = '//this%minim_fire_dt0//' fs',file=file) - call Print(' fire_dt_max = '//this%minim_fire_dt_max//' fs',file=file) - call Print(' minimise_mm = '//this%minim_minimise_mm,file=file) - call Print(' mm_method = '//trim(this%minim_mm_method),file=file) - call Print(' mm_tol = '//this%minim_mm_tol// ' (eV/A)^2',file=file) - call Print(' mm_eps_guess = '//this%minim_mm_eps_guess//' A',file=file) - call Print(' mm_max_steps = '//this%minim_mm_max_steps,file=file) - call Print(' mm_linminroutine = '//trim(this%minim_mm_linminroutine),file=file) - call Print(' mm_args_str = '//trim(this%minim_mm_args_str),file=file) - call Print('',file=file) - call Print(' I/O parameters:',file=file) - call Print(' verbosity = '//trim(verbosity_to_str(this%io_verbosity)),file=file) - call Print(' netcdf = '//this%io_netcdf,file=file) - call Print(' print_interval = '//this%io_print_interval//' fs',file=file) - call Print(' print_all_properties = '//this%io_print_all_properties,file=file) - line=' print_properties = ' - do i=1,size(this%io_print_properties) - line=trim(line)//' '//trim(this%io_print_properties(i)) - end do - call Print(line,file=file) - - call Print(' checkpoint_interval = '//this%io_checkpoint_interval//' fs',file=file) - call Print(' checkpoint_path = '//this%io_checkpoint_path,file=file) - call Print(' mpi_print_all = '//this%io_mpi_print_all,file=file) - call Print(' backup = '//this%io_backup, file=file) - call Print(' timing = '//this%io_timing, file=file) - call Print('',file=file) - call Print(' Selection parameters:',file=file) - call Print(' max_qm_atoms = '//this%selection_max_qm_atoms,file=file) - call Print(' method = '//trim(this%selection_method),file=file) - call Print(' ellipse = '//this%selection_ellipse//' A',file=file) - call Print(' ellipse_bias = '//this%selection_ellipse_bias//' radius fraction',file=file) - call Print(' ellipse_buffer = '//this%selection_ellipse_buffer//' A',file=file) - call Print(' cutoff_plane = '//this%selection_cutoff_plane//' A',file=file) - call Print(' directionality = '//this%selection_directionality) - call Print(' edge_tol = '//this%selection_edge_tol//' A',file=file) - call Print(' update_interval = '//this%selection_update_interval//' fs',file=file) - call Print('',file=file) - call Print(' Classical parameters:',file=file) - call Print(' args = '//trim(this%classical_args),file=file) - call Print(' args_str = '//trim(this%classical_args_str),file=file) - call Print(' force_reweight = '//this%classical_force_reweight,file=file) - call Print('',file=file) - call Print(' QM parameters:',file=file) - call Print(' args = '//trim(this%qm_args),file=file) - call Print(' args_str = '//trim(this%qm_args_str),file=file) - call Print(' extra_args_str = '//trim(this%qm_extra_args_str),file=file) - call Print(' cp2k = '//this%qm_cp2k,file=file) - call Print(' clusters = '//this%qm_clusters,file=file) - call Print(' little_clusters = '//this%qm_little_clusters,file=file) - call Print(' buffer_hops = '//this%qm_buffer_hops,file=file) - call Print(' transition_hops = '//this%qm_transition_hops,file=file) - call Print(' terminate = '//this%qm_terminate,file=file) - call Print(' force_periodic = '//this%qm_force_periodic,file=file) - call Print(' randomise_buffer = '//this%qm_randomise_buffer,file=file) - call Print(' even_electrons = '//this%qm_even_electrons,file=file) - call Print(' vacuum_size = '//this%qm_vacuum_size//' A',file=file) - call Print(' calc_force_error = '//this%qm_calc_force_error, file=file) - call Print(' rescale_r = '//this%qm_rescale_r, file=file) - call Print(' hysteretic_buffer = '//this%qm_hysteretic_buffer, file=file) - call Print(' hysteretic_buffer_inner_radius = '//this%qm_hysteretic_buffer_inner_radius//' A', file=file) - call Print(' hysteretic_buffer_outer_radius = '//this%qm_hysteretic_buffer_outer_radius//' A', file=file) - call Print(' hysteretic_buffer_nneighb_only = '//this%qm_hysteretic_buffer_nneighb_only, file=file) - call Print(' hysteretic_connect = '//this%qm_hysteretic_connect, file=file) - call Print(' hysteretic_connect_inner_factor = '//this%qm_hysteretic_connect_inner_factor, file=file) - call Print(' hysteretic_connect_outer_factor = '//this%qm_hysteretic_connect_outer_factor, file=file) - call Print(' hysteretic_connect_cluster_radius = '//this%qm_hysteretic_connect_cluster_radius//' A', file=file) - call Print('',file=file) - call Print(' Fit parameters:',file=file) - call Print(' hops = '//this%fit_hops,file=file) - call Print(' spring_hops = '//this%fit_spring_hops, file=file) - call Print(' method = '//trim(this%fit_method),file=file) - call Print('',file=file) - call Print(' Force integration parameters',file=file) - call Print(' end_file = '//trim(this%force_integration_end_file),file=file) - call Print(' n_steps = '//this%force_integration_n_steps,file=file) - call Print('',file=file) - call Print(' Quasi static loading parameters',file=file) - call Print(' tip_move_tol = '//this%quasi_static_tip_move_tol,file=file) - call Print('',file=file) - call Print(' Elastic constants') - call Print(' read = '//this%elastic_read,file=file) - if (this%elastic_read) call Print(this%elastic_cij, file=file) - call Print(' Nasty hacks:',file=file) - call Print(' qm_zero_z_force = '//this%hack_qm_zero_z_force,file=file) - call Print(' fit_on_eqm_coordination_only = '//this%hack_fit_on_eqm_coordination_only) - call Print('',file=file) - call Print(' Constraints:',file=file) - call Print(' constraint_fix_bond = '//this%constraint_fix_bond, file=file) - call Print(' constraint_bond_i = '//this%constraint_bond_i, file=file) - call Print(' constraint_bond_j = '//this%constraint_bond_j, file=file) - call Print(' constraint_bond_length = '//this%constraint_bond_length, file=file) - call Print(' constraint_fix_position = '//this%constraint_fix_position, file=file) - call Print(' constraint_position = '//this%constraint_position, file=file) - call Print(' constraint_fix_curvature = '//this%constraint_fix_curvature, file=file) - call Print(' constraint_curvature = '//this%constraint_curvature, file=file) - call Print(' constraint_fix_gradient = '//this%constraint_fix_gradient, file=file) - call Print(' constraint_gradient = '//this%constraint_gradient, file=file) - - - end subroutine CrackParams_print - - function CrackParams_any_per_atom_tau(this) - type(CrackParams), intent(in) :: this - logical :: CrackParams_any_per_atom_tau - integer :: i - - CrackParams_any_per_atom_tau = .false. - do i=1,this%num_md_stanza - if (this%md(i)%per_atom_tau) then - CrackParams_any_per_atom_tau = .true. - return - end if - end do - - end function CrackParams_any_per_atom_tau - -end module CrackParams_module diff --git a/src/Utils/cracktools.f95 b/src/Utils/cracktools.f95 deleted file mode 100644 index 1f3313c0cb..0000000000 --- a/src/Utils/cracktools.f95 +++ /dev/null @@ -1,2869 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module CrackTools_module - - use libAtoms_module - use potential_module - use elasticity_module - use CrackParams_module - - implicit none - - !% Print crack slab to XYZ file, using properties defined in 'params%io_print_properties' - !% or all properties if 'params%io_print_all_properties' is true. - interface crack_print - module procedure crack_print_cio - module procedure crack_print_filename - end interface - -#ifdef HAVE_CGAL - interface - subroutine c_alpha_shape_2(n, x, y, alpha, shape_n, shape_list, error) bind(c) - use iso_c_binding, only: C_INT, C_DOUBLE - integer(kind=C_INT), intent(in) :: n - real(kind=C_DOUBLE), intent(in), dimension(n) :: x, y - real(kind=C_DOUBLE), intent(in) :: alpha - integer(kind=C_INT), intent(inout) :: shape_n - integer(kind=C_INT), intent(in), dimension(shape_n) :: shape_list - integer(kind=C_INT), intent(out) :: error - end subroutine c_alpha_shape_2 - - - subroutine c_crack_front_alpha_shape(n, x, y, alpha, angle_threshold, front_n, front_list, error) bind(c) - use iso_c_binding, only: C_INT, C_DOUBLE - integer(kind=C_INT), intent(in) :: n - real(kind=C_DOUBLE), intent(in), dimension(n) :: x, y - real(kind=C_DOUBLE), intent(in) :: alpha, angle_threshold - integer(kind=C_INT), intent(inout) :: front_n - integer(kind=C_INT), intent(in), dimension(front_n) :: front_list - integer(kind=C_INT), intent(out) :: error - end subroutine c_crack_front_alpha_shape - end interface -#endif - -contains - - subroutine crack_fix_pointers(crack_slab, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - type(Atoms), intent(inout) :: crack_slab - real(dp), pointer, dimension(:,:) :: load, force - integer, pointer, dimension(:) :: move_mask, nn, changed_nn, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark - - if (.not. has_property(crack_slab, 'nn')) & - call add_property(crack_slab, 'nn', 0) - if (.not. assign_pointer(crack_slab, 'nn', nn)) & - call system_abort('nn pointer assignment failed') - - if (.not. has_property(crack_slab, 'changed_nn')) & - call add_property(crack_slab, 'changed_nn', 0) - if (.not. assign_pointer(crack_slab, 'changed_nn', changed_nn)) & - call system_abort('changed_nn pointer assignment failed') - - if (.not. has_property(crack_slab, 'load')) & - call add_property(crack_slab, 'load', 0.0_dp, n_cols=3) - if (.not. assign_pointer(crack_slab, 'load', load)) & - call system_abort('load pointer assignment failed') - - if (.not. has_property(crack_slab, 'move_mask')) & - call add_property(crack_slab, 'move_mask', 0) - if (.not. assign_pointer(crack_slab, 'move_mask', move_mask)) & - call system_abort('move_mask pointer assignment failed') - - if (.not. has_property(crack_slab, 'edge_mask')) & - call add_property(crack_slab, 'edge_mask', 0) - if (.not. assign_pointer(crack_slab, 'edge_mask', edge_mask)) & - call system_abort('edge_mask pointer assignment failed') - - if (.not. has_property(crack_slab, 'load_mask')) & - call add_property(crack_slab, 'load_mask', 0) - if (.not. assign_pointer(crack_slab, 'load_mask', load_mask)) & - call system_abort('load_mask pointer assignment failed') - - if (.not. has_property(crack_slab, 'md_old_changed_nn')) & - call add_property(crack_slab, 'md_old_changed_nn', 0) - if (.not. assign_pointer(crack_slab, 'md_old_changed_nn', md_old_changed_nn)) & - call system_abort('md_old_changed_nn pointer assignment failed') - - if (.not. has_property(crack_slab, 'old_nn')) & - call add_property(crack_slab, 'old_nn', 0) - if (.not. assign_pointer(crack_slab, 'old_nn', old_nn)) & - call system_abort('old_nn pointer assignment failed') - - if (.not. has_property(crack_slab, 'hybrid')) & - call add_property(crack_slab, 'hybrid', 0) - if (.not. assign_pointer(crack_slab, 'hybrid', hybrid)) & - call system_abort('hybrid pointer assignment failed') - - if (.not. has_property(crack_slab, 'hybrid_mark')) & - call add_property(crack_slab, 'hybrid_mark', 0) - if (.not. assign_pointer(crack_slab, 'hybrid_mark', hybrid_mark)) & - call system_abort('hybrid_mark pointer assignment failed') - - if (.not. has_property(crack_slab, 'force')) & - call add_property(crack_slab, 'force', 0.0_dp, n_cols=3) - if (.not. assign_pointer(crack_slab, 'force', force)) & - call system_abort('force pointer assignment failed') - - end subroutine crack_fix_pointers - - !% Parse crack name in the format is (ijk)[lmn], with negative numbers - !% denoted by a trailing 'b' (short for 'bar'), e.g. '(111)[11b0]' - !% Axes of crack slab returned as $3\times3$ matrix with columns - !% $\mathbf{x}$,$\mathbf{y}$,$\mathbf{z}$. - subroutine crack_parse_name(crackname, axes) - character(len=*), intent(in) :: crackname - real(dp), intent(out), dimension(3,3) :: axes - - real(dp), dimension(3) :: x,y,z - integer :: crack(6), i, j - - j = 1 - do i=1, len(crackname) - if (crackname(i:i) == 'b') crack(j-1) = -crack(j-1) - if (verify(crackname(i:i), '0123456789') == 0) then - crack(j) = ichar(crackname(i:i)) - ichar('0') - j = j + 1 - end if - end do - - y = (/ (real(crack(i),dp), i=1,3) /) - z = (/ (real(crack(i),dp), i=4,6) /) - x = y .cross. z - - write (line,'(a,3f8.3)') 'x =', x - call print(line) - write (line,'(a,3f8.3)') 'y =', y - call print(line) - write (line,'(a,3f8.3)') 'z =', z - call print(line) - - axes(:,1) = x; axes(:,2) = y; axes(:,3) = z - - end subroutine crack_parse_name - - !% Calculate energy release rate $G$ from strain using - !% $$G = \frac{1}{2} \frac{E}{1-\nu^2} \epsilon^2 h$$ - !% from thin strip result. Quantities are: - !% 'strain',$\epsilon$, dimensionless ratio $\frac{\Delta y}{y}$; - !% 'E', $E$, Young's modulus, GPa; - !% 'v', $\nu$, Poisson ratio, dimensionless; - !% 'height', $h$ \AA{}, 10$^{-10}$~m; - !% 'G', Energy release rate, J/m$^2$. - function crack_strain_to_g(strain, E, v, height) - real(dp), intent(in) :: strain, E, v, height - real(dp) :: crack_strain_to_g - - crack_strain_to_g = 1.0_dp/2.0_dp*E/(1.0_dp-v*v)*strain*strain*height*0.1_dp - - end function crack_strain_to_g - - - !% Calculate $epsilon$ from $G$, inverse of above formula. - !% Units are as the same as 'crack_strain_to_g' - function crack_g_to_strain(G, E, v, height) - real(dp), intent(in) :: G, E, v, height - real(dp) :: crack_g_to_strain - - crack_g_to_strain = sqrt(2.0_dp*G*(1.0_dp-v*v)/(E*height*0.1_dp)) - - end function crack_g_to_strain - - !% Convert from energy release rate $G$ to stress intensity factor $K$ - !% Units: G (J/m$^2$), E (GPa), K (Pa sqrt(m)) - function crack_g_to_k(G, E, v, mode) result(K) - real(dp), intent(in) :: G, E, v - character(*), optional, intent(in) :: mode - real(dp) :: K - - real(dp) :: Ep - character(20) :: use_mode - - use_mode = optional_default("plane strain", mode) - - if (trim(use_mode) == 'plane stress') then - Ep = E - else if (trim(use_mode) == 'plane strain') then - Ep = E/(1.0_dp-v*v) - else - call system_abort('crack_k_to_g: bad mode '//trim(use_mode)) - end if - - K = sqrt(G*Ep*1e9_dp) - - end function crack_g_to_k - - !% Convert from stress intensity factor $K$ to energy release rate $G$ - !% Units: G (J/m$^2$), E (GPa), K (Pa sqrt(m)) - function crack_k_to_g(K, E, v, mode) result(G) - real(dp), intent(in) :: K, E, v - character(*), optional, intent(in) :: mode - real(dp) :: G - - real(dp) :: Ep - character(20) :: use_mode - - use_mode = optional_default("plane strain", mode) - - if (trim(use_mode) == 'plane stress') then - Ep = E - else if (trim(use_mode) == 'plane strain') then - Ep = E/(1.0_dp-v*v) - else - call system_abort('crack_k_to_g: bad mode '//trim(use_mode)) - end if - - G = K*K/(Ep*1e9_dp) - - end function crack_k_to_g - - - !% Measure the current height of slab and calculate - !% energy release rate $G$ from current and original - !% heights and elastic constants $E$ and $\nu$, using the equation - !% $$ G = \frac{1}{2} \frac{E}{1-\nu^2} \frac{{h - h_0}^2}{h_0} $$ - !% where $h_0$ is the original height and $h$ the new height. - !% Otherwise, symbols and units are the same as in 'crack_strain_to_g'. - function crack_measure_g(at, E, v, orig_height) result(G) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: E, v, orig_height - real(dp) :: G - - real(dp) :: new_height - - new_height = maxval(at%pos(2,:))-minval(at%pos(2,:)) - G = 0.1_dp*0.5_dp*E/(1.0_dp-v*v)*(new_height - orig_height)**2.0_dp/orig_height - - end function crack_measure_g - - - !% Rescale atoms in slab, with atoms in front of either crack tip - !% strained in y direction by 'strain' and atoms behind crack tip - !% rigidly shifted to keep top and bottom edges flat. A transition - !% zone is created in between with linearly varying strain to - !% avoid creation of defects. - !% - !%> -------------------------------------- - !%> | | | | | | - !%> | | |___| | | - !%> | | | | | | - !%> | | |___| | | - !%> | | | | | | - !%> | 1 | 2 | 3 | 4 | 5 | - !%> -------------------------------------- - !% - !%> ====== =========================================== ====== - !%> Region Position Load - !%> ====== =========================================== ====== - !%> 1 x < l_crack_pos - zone_width G - !%> 2 l_crack_pos - zone_width <= x < l_crack_pos G -> 0 - !%> 3 l_crack_pos < x < r_crack_pos 0 - !%> 4 r_crack_pos < x <= r_crack_pos + zone_width 0 -> G - !%> 5 x > r_crack_pos + zone_width G - !%> ====== =========================================== ====== - - subroutine crack_uniform_load(at, params, l_crack_pos, r_crack_pos, zone_width, eps, G, apply_load, disp) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - real(dp), intent(in) :: l_crack_pos, r_crack_pos, zone_width - real(dp), intent(in), optional :: eps, G - logical, optional :: apply_load - real(dp), dimension(:,:), intent(out) :: disp - - integer :: j - real(dp) top_old, top_new, bottom_old, bottom_new, x, y, q, strain, E, v, & - orig_height, new_height, crack_pos_y, y_check, my_G - logical :: do_apply_load - - if (.not. get_value(at%params, 'OrigHeight', orig_height)) & - call system_abort('crack_uniform_load: "OrigHeight" parameter missing') - - if (.not. get_value(at%params, 'YoungsModulus', E)) & - call system_abort('crack_uniform_load: "YoungsModulus" missing') - - if (.not. get_value(at%params, 'PoissonRatio_yx', v)) & - call system_abort('crack_uniform_load: "PoissonRatio_yx" missing') - - if (.not. get_value(at%params, 'CrackPosy', crack_pos_y)) & - call system_abort('crack_uniform_load: CrackPosy parameter missing from atoms') - - if ((.not. present(eps) .and. .not. present(G)) .or. (present(eps) .and. present(G))) & - call system_abort('crack_uniform_load: one of eps or G must be present (but not both)') - - ! Calculate strain corresponding to given G - if (present(G)) then - call print('Requested G = '//G) - strain = crack_g_to_strain(G, E, v, orig_height) - else - strain = eps - end if - call Print('Applying strain '//strain) - - top_old = 0.0; top_new = 0.0; bottom_old = 0.0; bottom_new = 0.0 - - ! Find top and bottom - do j=1, at%N - if (at%pos(2,j) > top_old) top_old = at%pos(2,j) - if (at%pos(2,j) < bottom_old) bottom_old = at%pos(2,j); - end do - - disp = 0.0_dp - - do j=1, at%N - x = at%pos(1,j); - y = at%pos(2,j)-crack_pos_y; - - ! Strain regions 1 and 5 - if (x < l_crack_pos-zone_width .or. x > r_crack_pos+zone_width) then - disp(2,j) = strain*y - end if - - ! Strain region 2 - if (x >= l_crack_pos-zone_width .and. x < l_crack_pos) then - q = (x - (l_crack_pos - zone_width))/zone_width - y_check = y - if(params%crack_check_surface_coordination.and.at%Z(j).eq.params%crack_check_coordination_atom_type.and.abs(y).lt.params%crack_check_coordination_region) then - call crack_check_coordination(at,params,j,y_check) - endif - if (y_check >= 0.0) then - disp(2,j) = strain*(y*(1.0-q) + top_old*q) - else - disp(2,j) = strain*(y*(1.0-q) + bottom_old*q) - end if - end if - - ! Strain region 4 - if (x > r_crack_pos .and. x <= r_crack_pos+zone_width) then - q = (x - r_crack_pos)/zone_width; - y_check = y - if(params%crack_check_surface_coordination.and.at%Z(j).eq.params%crack_check_coordination_atom_type.and.abs(y).lt.params%crack_check_coordination_region) then - call crack_check_coordination(at,params,j,y_check) - endif - if (y_check >= 0.0) then - disp(2,j) = strain*(y*q + top_old*(1.0-q)) - else - disp(2,j) = strain*(y*q + bottom_old*(1.0-q)) - end if - end if - - ! Rigidly shift region 3 - if (x >= l_crack_pos .and. x <= r_crack_pos) then - y_check = y - if(params%crack_check_surface_coordination.and.at%Z(j).eq.params%crack_check_coordination_atom_type.and.abs(y).lt.params%crack_check_coordination_region) then - call crack_check_coordination(at,params,j,y_check) - endif - if(y_check >= 0.0) then - disp(2,j) = strain*top_old - else - disp(2,j) = strain*bottom_old - end if - end if - end do - - do_apply_load = optional_default(.false.,apply_load) - if (do_apply_load) then - - at%pos(2,:) = at%pos(2,:) + disp(2,:) - - new_height = maxval(at%pos(2,:))-minval(at%pos(2,:)) - call print('Measured slab height after strain = '//new_height) - my_G = 0.1_dp*0.5_dp*E/(1.0_dp-v*v)*(new_height - orig_height)**2.0_dp/orig_height - call print('Measured G = '//my_G) - - call set_value(at%params, 'strain', strain) - call set_value(at%params, 'G', my_G) - end if - - end subroutine crack_uniform_load - - !% Calculate Irwin K-field stresses and/or displacements for all atoms in 'at'. - !% Atomic positions should be the original undistorted bulk crystal positions. - !% 'YoungsModulus' and 'PoissonRatio_yx' parameters are extracted from 'at', along - !% with 'CrackPos' to specify the location of the crack tip. If neither 'sig' nor 'disp' - !% are present thenn properties are added to at if do_disp or do_sig are true. - !% Stress is in 6 component Voigt notation: $1=xx, 2=yy, 3=zz, 4=yz, 5=zx$ and $6=xy$, and - !% displacement is a Cartesian vector $(u_x,u_y,u_z)$. - - !Instead of adding a property to the atom structure, return - !an array with sig and disp, if do_sig or do_disp are true - subroutine crack_k_field(at, K, mode, sig, disp, do_sig, do_disp) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: K - character(*), intent(in), optional :: mode - real(dp), dimension(:,:), optional, intent(out) :: sig, disp - logical, optional, intent(in) :: do_sig, do_disp - - real(dp), allocatable, dimension(:,:) :: mysig - real(dp) :: E, v, r, theta, kappa, vp, vpp, crack_pos(3), pos(3) - character(20) :: use_mode - logical :: my_do_sig, my_do_disp - integer :: i - - use_mode = optional_default("plane strain", mode) - my_do_sig = optional_default(.false., do_sig) - my_do_disp = optional_default(.false., do_disp) - - if (.not. get_value(at%params, 'YoungsModulus', E)) & - call system_abort('crack_k_field: "YoungsModulus" missing') - - if (.not. get_value(at%params, 'PoissonRatio_yx', v)) & - call system_abort('crack_k_field: "PoissonRatio_yx" missing') - - crack_pos = 0.0_dp - if (.not. get_value(at%params, 'CrackPosx', crack_pos(1))) & - call system_abort('crack_k_field: CrackPosx parameter missing from atoms') - - if (.not. get_value(at%params, 'CrackPosy', crack_pos(2))) & - call system_abort('crack_k_field: CrackPosy parameter missing from atoms') - - if (trim(use_mode) == 'plane stress') then - kappa = (3.0_dp - v)/(1.0_dp + v) - vp = 0.0_dp - vpp = v - else if (trim(use_mode) == 'plane strain') then - kappa = 3.0_dp - 4.0_dp*v - vp = v - vpp = 0.0_dp - else - call system_abort('crack_k_field: bad mode '//trim(use_mode)) - end if - - - allocate(mysig(6,at%N)) - - do i=1,at%N - - pos = at%pos(:,i) - crack_pos - r = sqrt(pos(1)*pos(1) + pos(2)*pos(2))*1e-10_dp - theta = atan2(pos(2),pos(1)) - - mysig(1,i) = K/sqrt(2.0_dp*pi*r)*cos(theta/2.0_dp)*(1.0_dp - sin(theta/2.0_dp)* & - sin(3.0_dp*theta/2.0_dp)) - - mysig(2,i) = K/sqrt(2.0_dp*pi*r)*cos(theta/2.0_dp)*(1.0_dp + sin(theta/2.0_dp)* & - sin(3.0_dp*theta/2.0_dp)) - - mysig(3,i) = vp*(mysig(1,i) + mysig(2,i)) - mysig(4,i) = 0.0_dp - mysig(5,i) = 0.0_dp - - mysig(6,i) = K/sqrt(2.0_dp*pi*r)*sin(theta/2.0_dp)*cos(theta/2.0_dp)* & - cos(3.0_dp*theta/2.0_dp) - - if(my_do_disp) then - disp(1,i) = K/(2.0_dp*E*1e9_dp)*sqrt(r/(2.0_dp*pi))*((1.0_dp+v)*(2.0_dp*kappa-1.0_dp)*cos(theta/2.0_dp) - & - cos(3.0_dp*theta/2.0_dp))/1e-10 - disp(2,i) = K/(2.0_dp*E*1e9_dp)*sqrt(r/(2.0_dp*pi))*((1.0_dp+v)*(2.0_dp*kappa-1.0_dp)*sin(theta/2.0_dp) - & - sin(3.0_dp*theta/2.0_dp))/1e-10 - disp(3,i) = -vpp*pos(3)*1e-10_dp/(E*1e9_dp)*(mysig(1,i) + mysig(2,i))/1e-10 - end if - - end do - - if (my_do_sig) sig = mysig/1e9_dp - deallocate(mysig) - - end subroutine crack_k_field - -!The subroutine crack_apply_strain_ramp has to be called in order to create a slab with two different strain regions (or loading regions). -!G1 defines the initial loading with which the initial crack is created and it characterizes the third region just before the start of the ramp. -!G2 defines the final loading belonging to the fifth region, immediately after the ramp, and is associated to the parameter crack_ramp_end_G. -!Tha parameter crack_ramp_start_length defines the extension of region 3, lying in between the crack tip (d2) and start of the ramp. -!In between of the 2 different strain regions (region3 with G=G1 and region 5 with G=G2) is created a buffer region -!which length is defined by the parameter crack_ramp_length (|d4-d3| in this subroutine). -!IMPORTANT: In the crack.xml the option crack_loading="ramp" has to be used with crack_apply_loading_field="F" and simulation_initial_state="MD_CONSTANT". - - subroutine crack_apply_strain_ramp(at, G1, G2, d1, d2, d3, d4) !I didn't change crack tip from 1D to 2D in this routine... - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: G1, G2, d1, d2, d3, d4 - - integer :: j - real(dp) x, y, q, strain1, strain2, & - E, v, orig_height, orig_width, new_height, G - - if (.not. get_value(at%params, 'OrigHeight', orig_height)) & - call system_abort('crack_apply_strain_ramp: "OrigHeight" parameter missing') - - if (.not. get_value(at%params, 'OrigWidth', orig_width)) & - call system_abort('crack_apply_strain_ramp: "OrigWidth" parameter missing') - - if (.not. get_value(at%params, 'YoungsModulus', E)) & - call system_abort('crack_apply_strain_ramp: "YoungsModulus" missing') - - if (.not. get_value(at%params, 'PoissonRatio_yx', v)) & - call system_abort('crack_apply_strain_ramp: "PoissonRatio_yx" missing') - - ! Calculate strains corresponding to given Gs - strain1 = crack_g_to_strain(G1, E, v, orig_height) - strain2 = crack_g_to_strain(G2, E, v, orig_height) - - call print('Starting load G1 = '//G1//' --> strain '//strain1) - call print('Final load G2 = '//G2//' --> strain '//strain2) - - - do j=1, at%N - x = at%pos(1,j) - y = at%pos(2,j) - - ! Rigidly shift region 1 - if (x <= d1) then - at%pos(2,j) = at%pos(2,j) + strain1*orig_height/2.0_dp*sign(1.0_dp,y) - end if - - ! Linearly increasing strain in region 2 - ! Interpolate between 0 at x=d1 and strain1 at x=d2 - ! Add shift to align with first region at x=d1 - if (x > d1 .and. x <= d2) then - q = (x - d1)/(d2-d1) - at%pos(2,j) = at%pos(2,j) * (1.0_dp + strain1*q) + & - strain1*orig_height/2.0_dp*sign(1.0_dp,y)*(1.0_dp-q) - end if - - - ! Equilibration region in region 3: constant strain1 in this region - if (x > d2 .and. x <= d3) then - at%pos(2,j) = at%pos(2,j) * (1.0_dp + strain1) - end if - - ! Decreasing strain in region 4 - ! Interpolate between strain1 at x=d2 and strain2 at x=d3 - if (x > d3 .and. x <= d4) then - q = (x - d3)/(d4-d3) - at%pos(2,j) = at%pos(2,j) * (1.0_dp + (strain1*(1.0_dp-q) + strain2*q)) - end if - - ! Constant strain2 in region 5 - if (x > d4) then - at%pos(2,j) = at%pos(2,j) * (1.0_dp + strain2) - end if - - end do - - new_height = maxval(at%pos(2,:))-minval(at%pos(2,:)) - call print('Measured slab height after strain = '//new_height) - G = 0.1_dp*0.5_dp*E/(1.0_dp-v*v)*(new_height - orig_height)**2.0_dp/orig_height - call print('Measured G = '//G) - - call set_value(at%params, 'G', G) - - end subroutine crack_apply_strain_ramp - - - subroutine crack_setup_marks(crack_slab, params) - type(Atoms) :: crack_slab - type(CrackParams) :: params - - type(Table) :: crack_tips - integer :: i - - ! Pointers into Atoms data structure - real(dp), pointer, dimension(:,:) :: load, force - integer, pointer, dimension(:) :: move_mask, nn, changed_nn, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark - - call crack_fix_pointers(crack_slab, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - ! Setup edge_mask to allow easy exclusion of edge atoms - do i=1,crack_slab%N - if (crack_is_edge_atom(crack_slab, i, params%selection_edge_tol)) & - edge_mask(i) = 1 - end do - - ! Setup load_mask - do i=1,crack_slab%N - if (crack_is_topbottom_edge_atom(crack_slab, i, params%selection_edge_tol)) & - load_mask(i) = 1 - end do - - ! Calculate connectivity and numbers of nearest neighbours - call crack_update_connect(crack_slab, params) - - ! Find position of crack tips - call crack_find_tip(crack_slab, params, crack_tips) - - call print('crack_setup_marks: crack_tips=') - call print(crack_tips) - - ! We'll follow the right-most crack tip which is last entry in list - call set_value(crack_slab%params, 'CrackPosx', crack_tips%real(1,crack_tips%N)) - call set_value(crack_slab%params, 'CrackPosy', crack_tips%real(2,crack_tips%N)) - - call crack_fix_pointers(crack_slab, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - ! clear changed_nn, hybrid and hybrid_mark - hybrid(:) = 0 - hybrid_mark(:) = 0 - changed_nn(:) = 0 - - ! Artificially set changed_nn to 1 for atoms near to crack tip - do i = 1, crack_slab%N - if (distance_min_image(crack_slab, i, crack_tips%real(:,crack_tips%N)) < params%crack_seed_embed_tol) & - changed_nn(i) = 1 - end do - - call Print('Seeded embed region with '//count(changed_nn /= 0)//' atoms.') - call finalise(crack_tips) - -! call crack_update_selection(crack_slab, params) - - end subroutine crack_setup_marks - - subroutine crack_calc_load_field(crack_slab, params, classicalpot, load_method, overwrite_pos, mpi) - type(Atoms), intent(inout) :: crack_slab - type(CrackParams), intent(in) :: params - type(Potential), intent(inout) :: classicalpot - character(*), intent(in) :: load_method - logical, intent(in) :: overwrite_pos - type(MPI_Context), intent(in) :: mpi - - type(Atoms) :: crack_slab1, bulk - real(dp), pointer, dimension(:,:) :: load, force - real(dp), allocatable, dimension(:,:) :: k_disp, u_disp - integer, pointer, dimension(:) :: move_mask, nn, changed_nn, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark - type(CInOutput) :: movie - real(dp), allocatable :: relaxed_pos(:,:), initial_pos(:,:), new_pos(:,:) - integer :: i, k, steps - real(dp) :: G, G1, E, v, v2, Orig_Width, Orig_Height, width1, height1 - real(dp) :: K1, r, l_crack_pos, r_crack_pos, crack_pos(2) - !NB workaround for pgf90 bug (as of 9.0-1) - real(dp) :: t_norm - !NB end workaround for pgf90 bug (as of 9.0-1) - - if (.not. get_value(crack_slab%params, 'OrigHeight', orig_height)) & - call system_abort('crack_calc_load_field: "OrigHeight" parameter missing') - - if (.not. get_value(crack_slab%params, 'OrigWidth', orig_width)) & - call system_abort('crack_calc_load_field: "OrigWidth" parameter missing') - - if (.not. get_value(crack_slab%params, 'YoungsModulus', E)) & - call system_abort('crack_calc_load_field: "YoungsModulus" missing') - - if (.not. get_value(crack_slab%params, 'PoissonRatio_yx', v)) & - call system_abort('crack_calc_load_field: "PoissonRatio_yx" missing') - - if (.not. get_value(crack_slab%params, 'PoissonRatio_yz', v2)) & - call system_abort('crack_calc_load_field: "PoissonRatio_yz" missing') - - if (.not. get_value(crack_slab%params, 'CrackPosx', crack_pos(1))) & - call system_abort('crack_calc_load_field: "CrackPosx" missing') - - if (.not. get_value(crack_slab%params, 'CrackPosy', crack_pos(2))) & - call system_abort('crack_calc_load_field: "CrackPosy" missing') - - if (.not. get_value(crack_slab%params, 'G', G)) & - call system_abort('crack_calc_load_field: "G" missing') - - call add_property(crack_slab, 'load', 0.0_dp, n_cols=3) - - call crack_fix_pointers(crack_slab, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - if (.not. mpi%active .or. (mpi%active .and.mpi%my_proc == 0)) then - if (params%io_netcdf) then - call initialise(movie, 'crack_relax_loading_movie.nc', action=OUTPUT) - else - call initialise(movie, 'crack_relax_loading_movie.xyz', action=OUTPUT) - end if - end if - - if (params%crack_double_ended) then - l_crack_pos = -params%crack_seed_length - else - l_crack_pos = -orig_width - end if - - allocate(relaxed_pos(3,crack_slab%N), new_pos(3,crack_slab%N)) - allocate(k_disp(3, crack_slab%N)) - allocate(u_disp(3, crack_slab%N)) - allocate(initial_pos(3,crack_slab%N)) - - !save initial positions of crack_slab - initial_pos = crack_slab%pos - - !create a bulk slab - call crack_make_slab(params, classicalpot, crack_slab1, width1, height1, E, v, v2, bulk) - - ! Apply loading field - if (trim(load_method) == 'saved') then - - !relax the positions of the original slab - if (params%crack_relax_loading_field) then - ! Geometry optimise - steps = minim(classicalpot, crack_slab, method=params%minim_mm_method, convergence_tol=params%minim_mm_tol, & - max_steps=params%minim_mm_max_steps, linminroutine=params%minim_mm_linminroutine, do_print=.true., & - do_pos=.true.,do_lat=.false., & - print_cinoutput=movie) - end if - - ! Save relaxed positions - relaxed_pos = crack_slab%pos - - crack_slab%pos = initial_pos - - call print_title('Applying saved load increment') - call crack_apply_load_increment(crack_slab) - - else if (trim(load_method) == 'uniform') then - - !relax the positions of the original slab - if (params%crack_relax_loading_field) then - ! Geometry optimise - steps = minim(classicalpot, crack_slab, method=params%minim_mm_method, convergence_tol=params%minim_mm_tol, & - max_steps=params%minim_mm_max_steps, linminroutine=params%minim_mm_linminroutine, do_print=.true., & - do_pos=.true.,do_lat=.false., & - print_cinoutput=movie) - endif - - ! Save relaxed positions - relaxed_pos = crack_slab%pos - - crack_slab%pos = initial_pos - call print_title('Applying uniform load increment') - ! strain it a bit - do i=1,crack_slab%N - crack_slab%pos(2,i) = crack_slab%pos(2,i)*(1.0_dp+params%crack_strain_increment) - end do - - else if (trim(load_method) == 'reduce_uniform') then - - ! Save relaxed positions - relaxed_pos = crack_slab%pos - - crack_slab%pos = initial_pos - call print_title('Applying uniform load decrement') - ! Invoque function crack_is_topbottom_edge_atom = abs(slab%pos(2,i)) > height/2.0_dp - edge_gap - ! strain it a bit - do i=1,crack_slab%N - if (crack_is_topbottom_edge_atom(crack_slab, i, params%selection_edge_tol)) & - crack_slab%pos(2,i) = crack_slab%pos(2,i)*(1.0_dp-params%crack_strain_increment) - end do - - else if (trim(load_method) == 'kfield') then - - call print_title('Applying K-field load increment') - - crack_slab%pos = crack_slab1%pos - - k_disp = 0.0_dp - call print('Energy release rate G = '//G//' J/m^2') - call print('Stress Intensity Factor K = '//(crack_g_to_k(G,E,v)/1e6_dp)//' MPa.sqrt(m)') - call crack_k_field(crack_slab, crack_g_to_k(G,E,v), do_sig=.false., disp=k_disp, do_disp=.true.) - - do i=1,crack_slab%N - crack_slab%pos(:,i) = crack_slab%pos(:,i) + k_disp(:,i) - end do - - if (params%crack_relax_loading_field) then - ! now relax - steps = minim(classicalpot, crack_slab, method=params%minim_mm_method, convergence_tol=params%minim_mm_tol, & - max_steps=params%minim_mm_max_steps, linminroutine=params%minim_mm_linminroutine, do_print=.true., & - do_pos=.true.,do_lat=.false., & - print_cinoutput=movie) - end if - relaxed_pos = crack_slab%pos - - - crack_slab%pos = crack_slab1%pos - ! apply load increment - K1 = crack_g_to_k(crack_strain_to_g( & - crack_g_to_strain(G, E, v, orig_height) + & - params%crack_strain_increment, E, v, orig_height),E,v) - - k_disp = 0.0_dp - call print('Stress Intensity Factor K_1 = '//(K1/1e6_dp)//' MPa.sqrt(m)') - call crack_k_field(crack_slab, K1, do_sig=.false., disp=k_disp, do_disp=.true.) - - do i=1,crack_slab%N - crack_slab%pos(:,i) = crack_slab%pos(:,i) + k_disp(:,i) - end do - - - else if (trim(load_method) == 'interp_kfield_uniform') then - - crack_slab%pos = crack_slab1%pos - r_crack_pos = crack_pos(1)-0.85*params%crack_strain_zone_width - - call print('Applying load 1') - - u_disp = 0.0_dp - call crack_uniform_load(crack_slab, params, l_crack_pos, r_crack_pos, & - params%crack_strain_zone_width, G, apply_load=.false., disp=u_disp) - - k_disp = 0.0_dp - call print('Energy release rate G = '//G//' J/m^2') - call print('Stress Intensity Factor K = '//(crack_g_to_k(G,E,v)/1e6_dp)//' MPa.sqrt(m)') - call crack_k_field(crack_slab, crack_g_to_k(G,E,v), do_sig=.false., disp=k_disp, do_disp=.true.) - - r = 0.0 - do i=1,crack_slab%N - r = sqrt((crack_slab%pos(1,i) - crack_pos(1))**2.0_dp + & - (crack_slab%pos(2,i) - crack_pos(2))**2.0_dp) - if (r > params%crack_load_interp_length) then - crack_slab%pos(:,i) = crack_slab%pos(:,i) + u_disp(:,i) - else - do k=1,3 - crack_slab%pos(k,i) = crack_slab%pos(k,i) + & - linear_interpolate(0.0_dp, k_disp(k,i), params%crack_load_interp_length, u_disp(k,i), r) - end do - end if - end do - - if (params%crack_relax_loading_field) then - steps = minim(classicalpot, crack_slab, method=params%minim_mm_method, convergence_tol=params%minim_mm_tol, & - max_steps=params%minim_mm_max_steps, linminroutine=params%minim_mm_linminroutine, do_print=.true., & - do_pos=.true.,do_lat=.false., & - print_cinoutput=movie) - end if - relaxed_pos = crack_slab%pos - - call print('Applying new load') - - crack_slab%pos = crack_slab1%pos - - G1 = crack_strain_to_g( & - crack_g_to_strain(G, E, v, orig_height) + & - params%crack_strain_increment, E, v, orig_height) - - u_disp = 0.0_dp - call crack_uniform_load(crack_slab, params, l_crack_pos, r_crack_pos, & - params%crack_strain_zone_width, G1, apply_load=.false., disp=u_disp) - - ! apply load increment to K_disp - K1 = crack_g_to_k(G1,E,v) - - k_disp = 0.0_dp - call print('Energy release rate G_1 = '//G1//' J/m^2') - call print('Stress Intensity Factor K_1 = '//(K1/1e6_dp)//' MPa.sqrt(m)') - call crack_k_field(crack_slab, K1, do_sig=.false., disp=k_disp, do_disp=.true.) - - r = 0.0 - do i=1,crack_slab%N - r = sqrt((crack_slab%pos(1,i) - crack_pos(1))**2.0_dp + & - (crack_slab%pos(2,i) - crack_pos(2))**2.0_dp) - if (r > params%crack_load_interp_length) then - crack_slab%pos(:,i) = crack_slab%pos(:,i) + u_disp(:,i) - else - do k=1,3 - crack_slab%pos(k,i) = crack_slab%pos(k,i) + & - linear_interpolate(0.0_dp, k_disp(k,i), params%crack_load_interp_length, u_disp(k,i), r) - end do - end if - end do - - end if - - - if (params%crack_relax_loading_field) then - - ! now re-relax - steps = minim(classicalpot, crack_slab, method=params%minim_mm_method, convergence_tol=params%minim_mm_tol, & - max_steps=params%minim_mm_max_steps, linminroutine=params%minim_mm_linminroutine, do_print=.true., & - do_pos=.true.,do_lat=.false., & - print_cinoutput=movie) - end if - - call crack_fix_pointers(crack_slab, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - ! work out displacement field, using relaxed positions - do i=1,crack_slab%N - load(:,i) = crack_slab%pos(:,i) - relaxed_pos(:,i) - end do - - call print('Displacement field generated. Max disp: '//maxval(load)) - !NB workaround for pgf90 bug (as of 9.0-1) - t_norm = norm(reshape(load,(/3*crack_slab%N/))) - !NB end workaround for pgf90 bug (as of 9.0-1) - call print(' RMS disp: '//(t_norm/sqrt(3.0_dp*crack_slab%N))) - - if (overwrite_pos) then - crack_slab%pos = relaxed_pos - else - crack_slab%pos = initial_pos - end if - - - call calc_connect(crack_slab, store_is_min_image=.true.) - - deallocate(relaxed_pos, new_pos) - deallocate(u_disp, k_disp) - call finalise(movie) - call finalise(crack_slab1) - - end subroutine crack_calc_load_field - - subroutine crack_make_seed(crack_slab, params) - type(Atoms), intent(inout) :: crack_slab - type(CrackParams), intent(in) :: params - - real(dp), allocatable, dimension(:,:):: k_disp, u_disp - real(dp), pointer, dimension(:,:) :: load, force - integer, pointer, dimension(:) :: move_mask, nn, changed_nn, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark - real(dp) :: G, E, v, v2, Orig_Width, Orig_Height, r, l_crack_pos, r_crack_pos, strain - integer :: i, k - - call crack_fix_pointers(crack_slab, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - if (.not. get_value(crack_slab%params, 'OrigHeight', orig_height)) & - call system_abort('crack_make_seed: "OrigHeight" parameter missing') - - if (.not. get_value(crack_slab%params, 'OrigWidth', orig_width)) & - call system_abort('crack_make_seed: "OrigWidth" parameter missing') - - if (.not. get_value(crack_slab%params, 'YoungsModulus', E)) & - call system_abort('crack_make_seed: "YoungsModulus" missing') - - if (.not. get_value(crack_slab%params, 'PoissonRatio_yx', v)) & - call system_abort('crack_make_seed: "PoissonRatio_yx" missing') - - if (.not. get_value(crack_slab%params, 'PoissonRatio_yz', v2)) & - call system_abort('crack_make_seed: "PoissonRatio_yz" missing') - - allocate(k_disp(3,crack_slab%N)) - allocate(u_disp(3,crack_slab%N)) - - ! Determine position of seed crack - if (.not. params%crack_double_ended) then - l_crack_pos = -orig_width ! single ended crack - r_crack_pos = -orig_width/2.0_dp + params%crack_seed_length - else - l_crack_pos = -params%crack_seed_length/2.0_dp - r_crack_pos = params%crack_seed_length/2.0_dp - end if - -!!$ if (trim(params%crack_structure) == 'graphene') then -!!$ r_crack_pos = -orig_width -!!$ end if - - if (trim(params%crack_loading) == 'uniform') then - call print_title('Seed crack - Uniform Load') - - - call set_value(crack_slab%params, 'CrackPosx', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - call set_value(crack_slab%params, 'CrackPosy', 0.0_dp) - call set_value(crack_slab%params, 'OrigCrackPos', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - - if (params%crack_G > 0.0_dp) then - call crack_uniform_load(crack_slab, params, l_crack_pos, r_crack_pos, & - params%crack_strain_zone_width, G=params%crack_G, apply_load=.true., disp=u_disp) - else - call crack_uniform_load(crack_slab, params, l_crack_pos, r_crack_pos, & - params%crack_strain_zone_width, eps=params%crack_strain, apply_load=.true., disp=u_disp) - end if - - if (.not. get_value(crack_slab%params, 'strain', strain)) & - call system_abort('After crack_uniform_load(), strain parameter missing') - - if(params%crack_rescale_x_z) then - ! Rescale in x direction by v and in z direction by v2 - if (.not. get_value(crack_slab%params,'OrigHeight',orig_height)) orig_height = 0.0_dp - crack_slab%pos(1,:) = crack_slab%pos(1,:)*(1.0_dp-v*strain) - crack_slab%pos(3,:) = crack_slab%pos(3,:)*(1.0_dp-v2*strain) - crack_slab%lattice(3,3) = crack_slab%lattice(3,3)*(1.0_dp-v2*strain) - call set_lattice(crack_slab, crack_slab%lattice, scale_positions=.false.) - elseif(params%crack_rescale_x) then - ! Rescale in x direction by v - if (.not. get_value(crack_slab%params,'OrigHeight',orig_height)) orig_height = 0.0_dp - crack_slab%pos(1,:) = crack_slab%pos(1,:)*(1.0_dp-v*strain) - endif - - else if (trim(params%crack_loading) == 'ramp') then - - call print_title('Seed crack - Loading Ramp') - call set_value(crack_slab%params, 'CrackPosx', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - call set_value(crack_slab%params, 'CrackPosy', 0.0_dp) - call set_value(crack_slab%params, 'OrigCrackPos', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - call crack_apply_strain_ramp(crack_slab, params%crack_G, params%crack_ramp_end_G, r_crack_pos, & - r_crack_pos+params%crack_strain_zone_width, & - r_crack_pos+params%crack_strain_zone_width+params%crack_ramp_start_length, & - r_crack_pos+params%crack_strain_zone_width+params%crack_ramp_start_length+params%crack_ramp_length) - - else if (trim(params%crack_loading) == 'kfield') then - - call print_title('Seed crack - Irwin K-field Loading') - - if (.not. get_value(crack_slab%params,'OrigHeight',orig_height)) orig_height = 0.0_dp - - call print('Initial stress intesity factor K_0 = '//crack_g_to_k(params%crack_G, E, v)/1e6_dp//' MPa.sqrt(m)') - - call set_value(crack_slab%params, 'CrackPosx', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - call set_value(crack_slab%params, 'CrackPosy', 0.0_dp) - call set_value(crack_slab%params, 'OrigCrackPos', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - call set_value(crack_slab%params, 'G', params%crack_G) - call crack_k_field(crack_slab, crack_g_to_k(params%crack_G, E, v), disp=k_disp, do_disp=.true.) - - do i=1,crack_slab%N - crack_slab%pos(:,i) = crack_slab%pos(:,i) + k_disp(:,i) - end do - - else if (trim(params%crack_loading) == 'interp_kfield_uniform') then - - ! interpolate linearly between K field (near tip) and uniform loading (near edge) - - call print_title('Seed crack - K-field and Uniform Loading') - - k_disp = 0.0_dp - u_disp = 0.0_dp - call print('Interpolation length '//params%crack_load_interp_length//' A') - - if (.not. get_value(crack_slab%params,'OrigHeight',orig_height)) orig_height = 0.0_dp - - call print('Initial energy release rate G_0 = '//params%crack_G//' J/m^2') - call print('Initial stress intesity factor K_0 = '//crack_g_to_k(params%crack_G, E, v)/1e6_dp//' MPa.sqrt(m)') - - - call set_value(crack_slab%params, 'CrackPosx', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - call set_value(crack_slab%params, 'CrackPosy', 0.0_dp) - call set_value(crack_slab%params, 'OrigCrackPos', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - - call crack_k_field(crack_slab, crack_g_to_k(params%crack_G, E, v), disp=k_disp, do_disp=.true.) - - G = params%crack_G - call crack_uniform_load(crack_slab, params, l_crack_pos, r_crack_pos, & - params%crack_strain_zone_width, G, apply_load=.false., disp=u_disp) - call set_value(crack_slab%params, 'G', G) - - do i=1,crack_slab%N - r = sqrt((crack_slab%pos(1,i) - (r_crack_pos + 0.85*params%crack_strain_zone_width))**2.0_dp + & - crack_slab%pos(2,i)**2.0_dp) - if (r > params%crack_load_interp_length) then - crack_slab%pos(:,i) = crack_slab%pos(:,i) + u_disp(:,i) - else - do k=1,3 - crack_slab%pos(k,i) = crack_slab%pos(k,i) + & - linear_interpolate(0.0_dp, k_disp(k,i), params%crack_load_interp_length, u_disp(k,i), r) - end do - end if - end do - - else if (trim(params%crack_loading) == 'reduce_uniform') then - - if (params%crack_G > 0.0_dp) then - - call print_title('Seed crack - Reduce Loading') - - G = params%crack_G - call set_value(crack_slab%params, 'G', G) - call set_value(crack_slab%params, 'CrackPosx', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - call set_value(crack_slab%params, 'CrackPosy', 0.0_dp) - call set_value(crack_slab%params, 'OrigCrackPos', r_crack_pos + 0.85_dp*params%crack_strain_zone_width) - call crack_uniform_load(crack_slab, params, l_crack_pos, r_crack_pos, & - params%crack_strain_zone_width, G, apply_load=.true., disp=u_disp) - - if(params%crack_rescale_x_z) then - ! Rescale in x direction by v and in z direction by v2 - if (.not. get_value(crack_slab%params,'OrigHeight',orig_height)) orig_height = 0.0_dp - strain = crack_g_to_strain(params%crack_G, E, v, orig_height) - crack_slab%pos(1,:) = crack_slab%pos(1,:)*(1.0_dp-v*strain) - crack_slab%pos(3,:) = crack_slab%pos(3,:)*(1.0_dp-v2*strain) - crack_slab%lattice(3,3) = crack_slab%lattice(3,3)*(1.0_dp-v2*strain) - call set_lattice(crack_slab, crack_slab%lattice, scale_positions=.false.) - elseif(params%crack_rescale_x) then - ! Rescale in x direction by v - if (.not. get_value(crack_slab%params,'OrigHeight',orig_height)) orig_height = 0.0_dp - strain = crack_g_to_strain(params%crack_G, E, v, orig_height) - crack_slab%pos(1,:) = crack_slab%pos(1,:)*(1.0_dp-v*strain) - endif - end if - - else - call system_abort('Unknown loading type '//trim(params%crack_loading)) - end if - - deallocate(u_disp) - deallocate(k_disp) - - end subroutine crack_make_seed - - - !% Increase the load by adding the the load displacement field - !% to the atomic positions. The routine recalculates the loading - !% G and stores it in the atom parameter dictionary. - subroutine crack_apply_load_increment(at, G_increment) - type(Atoms) :: at - real(dp), optional :: G_increment - - integer :: i - real(dp), pointer, dimension(:,:) :: load - real(dp) :: orig_height, new_height, G, E, v - real(dp) :: load_scale, my_G_increment - real(dp) :: cur_height, cur_G, test_height, load_dheight, prefactor, target_G - - if (.not. get_value(at%params, 'OrigHeight', orig_height)) & - call system_abort('crack_apply_load_increment: "OrigHeight" parameter missing from atoms structure') - - if (.not. get_value(at%params, 'YoungsModulus', E)) & - call system_abort('crack_apply_load_increment: "YoungsModulus" missing') - - if (.not. get_value(at%params, 'PoissonRatio_yx', v)) & - call system_abort('crack_apply_load_increment: "PoissonRatio_yx" missing') - - if (.not. assign_pointer(at, 'load', load)) & - call system_abort('crack_apply_load_increment: load field is missing') - - my_G_increment = optional_default(0.0_dp, G_increment) - if (my_G_increment .fne. 0.0_dp) then - ! calc cur properties - cur_height = maxval(at%pos(2,:))-minval(at%pos(2,:)) - cur_G = 0.1_dp*0.5_dp*E/(1.0_dp-v*v)*(cur_height - orig_height)**2.0_dp/orig_height - target_G = cur_G + G_increment - - call print("crack_apply_load: doing G_increment, cur_G="//cur_G) - - ! calc properties after full load_step - !$omp parallel do - do i=1,at%N - at%pos(:,i) = at%pos(:,i) + load(:,i) - end do - test_height = maxval(at%pos(2,:))-minval(at%pos(2,:)) - load_dheight = test_height-cur_height - ! step back to orig positions - !$omp parallel do - do i=1,at%N - at%pos(:,i) = at%pos(:,i) - load(:,i) - end do - - ! cur_G = A (cur_h-orig_h)^2/orig_h - ! load_dheight = test_height - cur_height - ! target_G = A (cur_h + x load_dh - orig_h)^2/orig_h - ! - ! A = cur_G*orig_h / (cur_h-orig_h)^2 - ! x = (sqrt(target_G*orig_h/A)-cur_h+orig_h)/load_dh - prefactor = cur_G*orig_height / (cur_height-orig_height)**2 - load_scale = (sqrt(target_G*orig_height/prefactor) - cur_height + orig_height) / load_dheight - else - load_scale = 1.0_dp - endif - - !$omp parallel do - do i=1,at%N - at%pos(:,i) = at%pos(:,i) + load_scale*load(:,i) - end do - call system_timer('calc_dists') - call calc_dists(at) - call system_timer('calc_dists') - - new_height = maxval(at%pos(2,:))-minval(at%pos(2,:)) - call print('crack_apply_load: new height = '//new_height) - G = 0.1_dp*0.5_dp*E/(1.0_dp-v*v)*(new_height - orig_height)**2.0_dp/orig_height - call print('crack_apply_load: new loading G = '//G) - - call set_value(at%params, 'G', G) - - end subroutine crack_apply_load_increment - - - - !% Return true if the point 'd' is within an ellipse centred at the origin - !% with the $x$, $y$, and $z$ radii specifeid in the vector 'ellipse'. - function in_ellipse(d, ellipse) - real(dp), dimension(3), intent(in) :: d, ellipse - logical :: In_Ellipse - - in_ellipse = .false. - - if (abs(d(1)) > ellipse(1) .or. & - abs(d(2)) > ellipse(2) .or. & - abs(d(3)) > ellipse(3)) return - - In_Ellipse = (d(1)/ellipse(1))*(d(1)/ellipse(1))+ & - (d(2)/ellipse(2))*(d(2)/ellipse(2))+ & - (d(3)/ellipse(3))*(d(3)/ellipse(3)) < 1.0_dp - end function in_ellipse - - !% Select atoms in ellipse centred on an atom and with given principal radii - subroutine select_ellipse(at, ellipse, ellipse_bias, list, c) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: ellipse(3) !% Principal radii of ellipse in $x$, $y$ and $z$ directions - real(dp), intent(in) :: ellipse_bias(3) !% Shift ellipse, positive values forward - type(Table), intent(inout) :: list !% On exit contains indexes of selected atoms, which - !% are also reachable by nearest neighbour bond hopping starting from c - integer, intent(in) :: c !% Ellipse is centred around atom 'c'. - integer i, old_n - type(Table) :: ellipselist, nextlist - - call allocate(ellipselist, Nint=1, Nreal=0, Nstr=0, Nlogical=0) - do i=1,at%N - if (in_ellipse(diff_min_image(at, c, i) - ellipse_bias, ellipse)) call append(ellipselist, i) - end do - - ! include entries in ellipse which can be reached by nearest neighbour bond hopping starting from c - call allocate(list, Nint=4, Nreal=0, Nstr=0, Nlogical=0) - call append(list, (/c, 0, 0, 0/)) - old_n = 1 - do while (list%n < ellipselist%n) - call BFS_step(at, list, nextlist, nneighb_only=.true., min_images_only=.true.) - - ! add entries from nextlist if they are also in ellipse - do i=1,nextlist%N - if (find_in_array(ellipselist%int(1,1:ellipselist%n), nextlist%int(1,i)) /= 0) call append(list, nextlist%int(:,i)) - end do - - ! check that list is still growing - if (list%N == old_n) exit - old_n = list%n - end do - call print('select_ellipse: selected '//(list%n)//'/'//(ellipselist%n)//' atoms centered on '//c, PRINT_VERBOSE) - - end subroutine select_ellipse - - - !% Returns true if atom 'i' is near to an open surface of slab. - !% Open surfaces are planes at $x = \pm$'OrigWidth/2' and $y = \pm$'OrigHeight/2'. - !% "Near to" means within 'edge_gap' of the surface. - function crack_is_edge_atom(slab, i, edge_gap) - type(Atoms), intent(in) :: slab - integer, intent(in) :: i - real(dp), intent(in) :: edge_gap - logical :: crack_is_edge_atom - real(dp) :: width, height - - if (.not. get_value(slab%params, 'OrigWidth', width)) & - call system_abort('crack_is_edge_atom: "OrigWidth" parameter missing') - - if (.not. get_value(slab%params, 'OrigHeight', height)) & - call system_abort('crack_is_edge_atom: "OrigWidth" parameter missing') - - crack_is_edge_atom = abs(slab%pos(2,i)) > height/2.0_dp - edge_gap .or. & - abs(slab%pos(1,i)) > width/2.0_dp - edge_gap - - end function crack_is_edge_atom - - !%Returns true if atom 'i' is the topbottom surface of slab - !%Topbottom surfaces are planes at $y = \pm$'OrigHeight/2' - function crack_is_topbottom_edge_atom(slab, i, edge_gap) - type(Atoms), intent(in) :: slab - integer, intent(in) :: i - real(dp), intent(in) :: edge_gap - logical :: crack_is_topbottom_edge_atom - real(dp) :: height - - if (.not. get_value(slab%params, 'OrigHeight', height)) & - call system_abort('crack_is_topbottom_edge_atom: "OrigHeight" parameter missing') - - crack_is_topbottom_edge_atom = abs(slab%pos(2,i)) > height/2.0_dp - edge_gap - - end function crack_is_topbottom_edge_atom - - !% Update the connectivity of a crack slab. calc_connect is only called if - !% necessary (i.e. if the maximal atomic displacement is bigger than - !% 'params%md(params%md_stanza)%recalc_connect_factor*params%md(params%md_stanza)%crust' - !% The 'nn' and 'changed_nn' properties are updated each call, with - !% the (cheaper) nearest neighbour calc_connect always being perforemd. - subroutine crack_update_connect(at, params) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - - type(Atoms), save :: nn_atoms - real(dp) :: max_disp - real(dp), allocatable, save, dimension(:,:) :: stored_pos - integer, pointer, dimension(:) :: old_nn, nn, changed_nn, edge_mask - integer :: i - logical :: first_time - - call system_timer('connectivity update') - - if (.not. assign_pointer(at, 'nn', nn)) & - call system_abort('crack_update_connect: nn property missing from atoms') - - if (.not. assign_pointer(at, 'old_nn', old_nn)) & - call system_abort('crack_update_connect: old_nn property missing from atoms') - - if (.not. assign_pointer(at, 'changed_nn', changed_nn)) & - call system_abort('crack_update_connect: changed_nn property missing from atoms') - - if (.not. assign_pointer(at, 'edge_mask', edge_mask)) & - call system_abort('crack_update_connect: edge property missing from atoms') - - ! First time we need to allocate stored_pos - first_time = .false. - if (.not. allocated(stored_pos)) then - allocate(stored_pos(3,at%N)) - stored_pos = 0.0_dp - first_time = .true. - call atoms_copy_without_connect(nn_atoms, at) ! First time we copy entire atoms structure - end if - - if (.not. first_time) then - max_disp = maxval(normsq(stored_pos - at%pos, 1)) - call print('Maximum atomic displacement since last calc_connect is '//max_disp) - end if - - if (first_time .or. (max_disp > params%md(params%md_stanza)%recalc_connect_factor*params%md(params%md_stanza)%crust)) then - call print('Recalculating connectivity') - call calc_connect(at, store_is_min_image=.true.) - stored_pos = at%pos ! Save positions for next time - end if - - call print('Recalculating nearest neighbour table') - if (trim(params%simulation_task) == 'md' .and. associated(at%avgpos)) then - nn_atoms%pos = at%avgpos - else - nn_atoms%pos = at%pos - end if - !% Use hysteretic version of calc_connect() so we can use relative cutoffs - call calc_connect_hysteretic(nn_atoms, cutoff_factor=params%md(params%md_stanza)%nneigh_tol, & - cutoff_break_factor=params%md(params%md_stanza)%nneigh_tol) - - ! fix pointers - calc_connect() may have called map_into_cell() which adds properties - if (.not. assign_pointer(at, 'nn', nn)) & - call system_abort('crack_update_connect: nn property missing from atoms') - - if (.not. assign_pointer(at, 'old_nn', old_nn)) & - call system_abort('crack_update_connect: old_nn property missing from atoms') - - if (.not. assign_pointer(at, 'changed_nn', changed_nn)) & - call system_abort('crack_update_connect: changed_nn property missing from atoms') - - if (.not. assign_pointer(at, 'edge_mask', edge_mask)) & - call system_abort('crack_update_connect: edge property missing from atoms') - - nn = 0 - do i = 1,nn_atoms%N - nn(i) = n_neighbours(nn_atoms, i) - end do - - if (all(old_nn == 0)) old_nn = nn ! Special case for first time - - ! Age all the NN changes by 1 - where (changed_nn /= 0) changed_nn = changed_nn + 1 - - ! Update changed_nn flag (excludes edge atoms) - where (edge_mask == 0 .and. nn /= old_nn) changed_nn = 1 - - if (count(changed_nn == 1) /= 0) then - call print('CONNECT '//count(changed_nn == 1)//' atoms changed their neighbour count.') - end if - old_nn = nn - - call system_timer('connectivity update') - - end subroutine crack_update_connect - - subroutine crack_update_selection(at, params) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - - if (trim(params%selection_method) == 'coordination') then - call crack_update_selection_coordination(at, params) - - else if (trim(params%selection_method) == 'crack_front') then - call crack_update_selection_crack_front(at, params) - - else if (trim(params%selection_method) == 'static') then - call print('crack_update_selection: selection_method=static, no action required.') - - else - call system_abort('crack_update_selection: unknown selection_method '//trim(params%selection_method)) - end if - - end subroutine crack_update_selection - - !% Update QM selection region for a crack configuration using the 'nn' and 'changed_nn' - !% properties and the 'CrackPos' parameter from the atoms structure, as well as the - !% selection parameters in 'params'. If 'update_embed' is true then the embed region is - !% updated, otherwise we simply recompute the fit region from the embed region. - !% The value of 'num_directionality' returned can be passed to adjustable_potential_init. - subroutine crack_update_selection_coordination(at, params) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - - integer :: p, i, j, surface, age - type(Table) :: old_embed, selectlist(2), tmp_select, embedlist, temptable, crack_tips - type(Table), dimension(2) :: new_embed - integer, allocatable, dimension(:) :: sindex - real(dp), allocatable, dimension(:) :: sorted, tip_dist - real(dp), dimension(2,3) :: selection_ellipse - real(dp) :: ellipse_bias(3), crack_pos(3) - integer :: dislo_seed, temp_N - integer :: error=ERROR_NONE - integer, pointer, dimension(:) :: nn, changed_nn, hybrid, edge_mask - - call system_timer('selection update') - - if (.not. assign_pointer(at, 'nn', nn)) & - call system_abort('crack_update_selection_coordination: nn property missing from atoms') - - if (.not. assign_pointer(at, 'edge_mask', edge_mask)) & - call system_abort('crack_update_selection_coordination: nn property missing from atoms') - - if (.not. assign_pointer(at, 'changed_nn', changed_nn)) & - call system_abort('crack_update_selection_coordination: changed_nn property missing from atoms') - - if (.not. assign_pointer(at, 'hybrid', hybrid)) & - call system_abort('crack_update_selection_coordination: atoms structure is missing hybrid property') - - - if (.not. get_value(at%params, 'CrackPosx', crack_pos(1))) & - call system_abort('crack_update_selection_coordination: CrackPosx parameter missing from atoms') - - if (.not. get_value(at%params, 'CrackPosy', crack_pos(2))) & - call system_abort('crack_update_selection_coordination: CrackPosy parameter missing from atoms') - - call print('Building QM selection zone...') - - call allocate(embedlist, Nint=1,Nreal=0,Nstr=0,Nlogical=0) - call allocate(old_embed, Nint=1,Nreal=0,Nstr=0,Nlogical=0) - call print('count(changed_nn /= 0) = '//count(changed_nn /= 0)) - call print('Got '//count(hybrid == HYBRID_ACTIVE_MARK)//' old embed atoms') - if (count(hybrid == HYBRID_ACTIVE_MARK) /= 0) & - call append(old_embed, find(hybrid == HYBRID_ACTIVE_MARK)) - - selection_ellipse(1,:) = params%selection_ellipse - selection_ellipse(2,:) = params%selection_ellipse - do i=1,3 - selection_ellipse(2,i) = selection_ellipse(2,i) + params%selection_ellipse_buffer - end do - ellipse_bias = 0.0_dp - ! bias ellipse forward by arbitrary fraction of a radius (0.5 => 1/4 back, 3/4 ahead) - ellipse_bias(1) = params%selection_ellipse_bias*selection_ellipse(1,1) - - !if there is a dislo_seed, add qm atoms around the dislocation core - call allocate(temptable, Nint=4,Nreal=0,Nstr=0,Nlogical=0) - dislo_seed = params%crack_dislo_seed - temp_N=0 - if (dislo_seed .ne. 0) then - call print('DISLOCATION: adding atoms around the core '//dislo_seed) - call bfs_grow(at, temptable, dislo_seed, 3,nneighb_only=.false.,min_images_only=.true.) - temp_N = temptable%N - call print('found '//temp_N//' extra qm atoms') - endif - - ! Do selection twice, once to get inner and once to get outer surface - do surface=1,2 - - call allocate(selectlist(surface), Nint=5, Nreal=0, Nstr=0, Nlogical=0) - - ! Mark ellipsoid around each real atom with changed_nn /= 0 with its age - ! - If central (active) atom already marked, keep the newer mark - ! - If embedded atoms already marked, also keep newer mark - - do i=1,at%N - if (changed_nn(i) == 0) cycle - - if (abs(at%pos(1,i)-crack_pos(1)) < params%selection_cutoff_plane .and. & - abs(at%pos(2,i)-crack_pos(2)) < params%selection_cutoff_plane) then - - p = Find_in_array(selectlist(surface)%int(1,1:selectlist(surface)%N), i) - if (p == 0) then - call append(selectlist(surface), (/i,0,0,0,changed_nn(i)/)) - else - selectlist(surface)%int(5,p) = min(selectlist(surface)%int(5,p), changed_nn(i)) - end if - - if (old_embed%N == 0) then - ! First time we do embedding, use ellipse halfway between inner and outer - call select_ellipse(at, 0.5_dp*(selection_ellipse(1,:) + selection_ellipse(2,:)), & - ellipse_bias, tmp_select, i) - else - call select_ellipse(at, selection_ellipse(surface,:), ellipse_bias, tmp_select, i) - end if - - do j = 1, tmp_select%N - p = Find_in_array(int_part(selectlist(surface),(/1,2,3,4/)), tmp_select%int(:,j)) - if (p == 0) then - ! Marking for first time - call append(selectlist(surface), (/tmp_select%int(:,j), changed_nn(i)/)) - else - ! Keep newer mark - selectlist(surface)%int(5,p) = min(selectlist(surface)%int(5,p), changed_nn(i)) - end if - end do - end if - end do - - - - ! Sort by age of NN changes, most recent are smallest values - allocate(sorted(selectlist(surface)%N)) - allocate(tip_dist(selectlist(surface)%N)) - allocate(sindex(selectlist(surface)%N)) - sorted = selectlist(surface)%int(5,1:selectlist(surface)%N) - sindex = [(i, i = 1, size(sindex))] - - ! multiply sorted by abs(distance from tip). - do i = 1, selectlist(surface)%N - j = selectlist(surface)%int(1,i) - tip_dist(i) = ((crack_pos(1)-at%pos(1,j))**2+(crack_pos(2)-at%pos(2,j))**2)**(1/2) - sorted(i) = sorted(i)*tip_dist(i) - enddo - - call insertion_sort(sorted, i_data=sindex) - - i = 1 - do while (i <= selectlist(surface)%N .and. new_embed(surface)%N < params%selection_max_qm_atoms-temp_N) - age = sorted(i) - call print(' Selecting changed_nn age '//age) - - do while(i <= selectlist(surface)%N) - if (sorted(i) /= age) exit - call append(new_embed(surface), selectlist(surface)%int(1:4,sindex(i))) - i = i + 1 - end do - - call print('Surface '//surface//' Now embedding '//new_embed(surface)%N//' atoms') - end do - - deallocate(sorted) - deallocate(tip_dist) - deallocate(sindex) - - ! First time there's no need to go round twice - if(old_embed%N == 0) exit - end do - - - call wipe(embedlist) - - ! Keep old embed atoms unless they're now outside outer surface - do i=1,old_embed%N - if (is_in_array(new_embed(2)%int(1,1:new_embed(2)%N), old_embed%int(1,i))) then - call append(embedlist, old_embed%int(1,i), error=error) - HANDLE_ERROR(error) - end if - end do - - ! Add atoms inside inner surface - do i=1,new_embed(1)%N - if (.not. is_in_array(embedlist%int(1,1:embedlist%N), new_embed(1)%int(1,i))) then - call append(embedlist, new_embed(1)%int(1,i), error=error) - HANDLE_ERROR(error) - end if - end do - - call Print('Embedding '//embedlist%N//' atoms.') - - call finalise(old_embed) - call finalise(new_embed(1)) - call finalise(new_embed(2)) - call finalise(selectlist(1)) - call finalise(selectlist(2)) - call finalise(tmp_select) - - ! Find new position of crack tips - call crack_find_tip(at, params, crack_tips) - call print('crack_update_selection_coordination: crack_tips=') - call print(crack_tips) - - ! We'll follow the right-most crack tip which is last entry in list - call set_value(at%params, 'CrackPosx', crack_tips%real(1,crack_tips%N)) - call set_value(at%params, 'CrackPosy', crack_tips%real(2,crack_tips%N)) - call finalise(crack_tips) - - !quantum atoms around the dislocation - if (dislo_seed .ne. 0) then - do i = 1, temp_N - if (.not.Is_In_Array(int_part(embedlist,1),temptable%int(1,i))) then - call append(embedlist,temptable%int(1,i)) - endif - enddo - call print('atoms in the embedlist after = '//embedlist%N) - endif - - ! Copy embedlist to 'hybrid' property - hybrid = 0 - hybrid(int_part(embedlist,1)) = 1 - - call finalise(temptable) - call finalise(embedlist) - - call system_timer('selection update') - - end subroutine crack_update_selection_coordination - - - subroutine crack_update_selection_crack_front(at, params) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - - integer :: i, surface - type(Table) :: old_embed, tmp_select, embedlist - integer, allocatable, dimension(:,:) :: selectmask - real(dp), dimension(2,3) :: selection_ellipse - real(dp) :: ellipse_bias(3) - - integer, pointer, dimension(:) :: hybrid - logical, pointer, dimension(:) :: crack_front - - call system_timer('selection update') - - if (.not. assign_pointer(at, 'crack_front', crack_front)) & - call system_abort('crack_update_selection_crack_front: crack_front property missing from atoms') - if (.not. assign_pointer(at, 'hybrid', hybrid)) & - call system_abort('crack_update_selection: atoms structure is missing hybrid property') - - call allocate(embedlist, Nint=1,Nreal=0,Nstr=0,Nlogical=0) - call allocate(old_embed, Nint=1,Nreal=0,Nstr=0,Nlogical=0) - call print('Got '//count(hybrid == HYBRID_ACTIVE_MARK)//' old embed atoms') - if (count(hybrid == HYBRID_ACTIVE_MARK) /= 0) & - call append(old_embed, find(hybrid == HYBRID_ACTIVE_MARK)) - - selection_ellipse(1,:) = params%selection_ellipse - selection_ellipse(2,:) = params%selection_ellipse - do i=1,3 - selection_ellipse(2,i) = selection_ellipse(2,i) + params%selection_ellipse_buffer - end do - ellipse_bias = 0.0_dp - ! bias ellipse forward by arbitrary fraction of a radius (0.5 => 1/4 back, 3/4 ahead) - ellipse_bias(1) = params%selection_ellipse_bias*selection_ellipse(1,1) - - ! Find new position of crack front - call crack_find_tip_local_energy(at, params) - - allocate(selectmask(2,at%n)) - selectmask = 0 - - ! Do selection twice, once to get inner and once to get outer surface - do surface=1,2 - - ! Mark ellipsoid around each atom with crack_front /= 0 - do i=1,at%N - if (.not. crack_front(i)) cycle - - - selectmask(surface,i) = 1 - - if (old_embed%N == 0) then - ! First time we do embedding, use ellipse halfway between inner and outer - call select_ellipse(at, 0.5_dp*(selection_ellipse(1,:) + selection_ellipse(2,:)), & - ellipse_bias, tmp_select, i) - else - call select_ellipse(at, selection_ellipse(surface,:), ellipse_bias, tmp_select, i) - end if - - call print('marking '//tmp_select%n//' atoms in ellipse around atom '//i) - - selectmask(surface,tmp_select%int(1,1:tmp_select%n)) = 1 - end do - - write (line,'(a,i0,a,i0,a)') 'Surface ',surface,' Now embedding ', count(selectmask(surface,:) == 1), ' atoms' - call print(line) - - ! First time there's no need to go round twice - if(old_embed%N == 0) exit - end do - - - call wipe(embedlist) - - ! Keep old embed atoms unless they're now outside outer surface - do i=1,old_embed%N - if (selectmask(2,old_embed%int(1,i)) == 1) call append(embedlist, old_embed%int(1,i)) - end do - - ! Add atoms inside inner surface - do i=1,at%N - if (selectmask(1,i) == 0) cycle - if (.not. is_in_array(embedlist%int(1,1:embedlist%N), i)) & - call append(embedlist, i) - end do - - call Print('Embedding '//embedlist%N//' atoms.') - - ! Copy embedlist to 'hybrid' property - hybrid = 0 - hybrid(int_part(embedlist,1)) = HYBRID_ACTIVE_MARK - - call finalise(old_embed) - call finalise(tmp_select) - call finalise(embedlist) - deallocate(selectmask) - call system_timer('selection update') - - end subroutine crack_update_selection_crack_front - - - subroutine crack_find_tip(at, params, crack_tips) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - type(Table), intent(out) :: crack_tips - - logical, pointer, dimension(:) :: crack_front - real(dp) :: crack_tip(2) - integer :: i, n - - if (trim(params%crack_tip_method) == 'coordination') then - call allocate(crack_tips, Nint=0, Nreal=3, Nstr=0, Nlogical=0) - crack_tip = crack_find_tip_coordination(at, params) - call append(crack_tips, realpart=(/crack_tip(1), crack_tip(2), 0.0_dp /)) - - else if (trim(params%crack_tip_method) == 'percolation') then - call crack_find_tip_percolation(at, params, crack_tips) - - else if (trim(params%crack_tip_method) == 'local_energy') then - call crack_find_surface_atoms(at) - call crack_find_tip_local_energy(at, params) - - if (.not. assign_pointer(at, 'crack_front', crack_front)) & - call system_abort('crack_find_tip: crack_front property missing from atoms') - - ! Calculate crack tip position as average along crack front - crack_tip = 0.0_dp - n = 0 - do i=1,at%N - if (.not. crack_front(i)) cycle - crack_tip(1) = crack_tip(1) + at%pos(1,i) - crack_tip(2) = crack_tip(2) + at%pos(2,i) - n = n + 1 - end do - crack_tip = crack_tip / real(n, dp) - call append(crack_tips, realpart=(/crack_tip(1), crack_tip(2), 0.0_dp /)) - - else if (trim(params%crack_tip_method) == 'alpha_shape') then -#ifdef HAVE_CGAL - call crack_find_surface_atoms(at) - call crack_front_alpha_shape(at, params%crack_front_alpha, & - params%crack_front_angle_threshold) -#else - call system_abort('crack_find_tip: method="alpha_shape" but compiled without CGAL support') -#endif - - if (.not. get_value(at%params, 'CrackPosx', crack_tip(1))) & - call system_abort('crack_find_tip: CrackPosx param missing') - if (.not. get_value(at%params, 'CrackPosy', crack_tip(2))) & - call system_abort('crack_find_tip: CrackPosy param missing') - call append(crack_tips, realpart=(/crack_tip(1), crack_tip(2), 0.0_dp /)) - - else - call system_abort('crack_find_tip: unknown tip_method '//trim(params%crack_tip_method)) - - end if - - - if (params%crack_double_ended) then - if (crack_tips%N /= 2) call system_abort('Expected two, but found '//crack_tips%N//' crack tips') - else - if (crack_tips%N /= 1) call system_abort('Expected one, but found '//crack_tips%N//' crack tips') - end if - - end subroutine crack_find_tip - - !% Return $x$ coordinate of rightmost undercoordinated atom - function crack_find_tip_coordination(at, params, n_tip_atoms, tip_indices) result(crack_pos) - type(Atoms), intent(inout) :: at - type(CrackParams) :: params - real(dp), dimension(2) :: crack_pos - integer, intent(out), optional :: n_tip_atoms, tip_indices(:) - - integer :: i, ti, n_tip - integer, pointer, dimension(:) :: nn, edge_mask, orig_index - integer, allocatable :: eqm_coord(:) - real(dp) :: tip_pos - type(Atoms) :: surface - real(dp), parameter :: tol = 1.0_dp - - if (.not. assign_pointer(at, 'nn', nn)) & - call system_abort('crack_find_tip_coordination: nn property missing from atoms') - - if (.not. assign_pointer(at, 'edge_mask', edge_mask)) & - call system_abort('crack_find_tip_coordination: edge property missing from atoms') - - ! Select undercoodinated atoms - allocate(eqm_coord(at%n)) - do i=1,at%n - ti = find_in_array(params%crack_z, at%z(i)) - eqm_coord(i) = params%md(params%md_stanza)%eqm_coordination(ti) - end do - - if (count(nn < eqm_coord .and. edge_mask /= 1) == 0) then - call system_abort('crack_find_tip_coordination: no under-coordinated atoms found') - end if - - call select(surface, at, nn < eqm_coord .and. edge_mask /= 1) - deallocate(eqm_coord) - - ! order by x coordinate - call add_property(surface, 'posx', surface%pos(1,:)) - call atoms_sort(surface, 'posx') - - ! include all atoms closer than 'tol' to rightmost undercoordinated atom - tip_pos = surface%pos(1,surface%N) - n_tip = 1 - do while (.true.) - if (surface%N-n_tip < 1) exit - if (abs(surface%pos(1,surface%N-n_tip) - tip_pos) > tol) exit - n_tip = n_tip+1 - end do - - call print('crack_find_tip_coordination: got '//n_tip//' tip atoms.') - - ! average positions - crack_pos(1) = sum(surface%pos(1,surface%N-n_tip+1:surface%N))/real(n_tip, dp) - crack_pos(2) = sum(surface%pos(2,surface%N-n_tip+1:surface%N))/real(n_tip, dp) - - call assign_property_pointer(surface, 'orig_index', orig_index) - call Print('Crack position = '//crack_pos//' near atoms ['//orig_index(surface%N-n_tip+1:surface%N)//']') - call set_value(at%params, 'CrackPosx', crack_pos(1)) - call set_value(at%params, 'CrackPosy', crack_pos(2)) - - if (present(n_tip_atoms)) n_tip_atoms = n_tip - if (present(tip_indices)) then - if (size(tip_indices) < n_tip) call system_abort('crack_find_tip_coordination: tip_indices array too small') - tip_indices(1:n_tip) = orig_index(surface%N-n_tip+1:surface%N) - end if - - call finalise(surface) - - end function crack_find_tip_coordination - - function percolation_step(grid) - integer, dimension(:,:,:), intent(inout) :: grid - logical :: percolation_step - - integer i,j,k - integer, allocatable, dimension(:,:,:) :: ngrid - - ! Copy of `grid` with bounds (0:nx+1,0:ny+1,0:nz+1) and zeros around edges - allocate(ngrid(0:size(grid,1)+1,0:size(grid,2)+1,0:size(grid,3)+1)) - ngrid = 0 - ngrid(1:size(grid,1),1:size(grid,2),1:size(grid,3)) = grid - - ! Age burned out regions - where (grid >= 2) - grid = grid + 1 - end where - - ! Spread fire - do k=1,size(grid,3) - do j=1,size(grid,2) - do i=1,size(grid,1) - if (ngrid(i,j,k) /= 1) cycle - - if (ngrid(i+1,j,k) == 2 .or. ngrid(i-1,j,k) == 2 .or. & - ngrid(i,j+1,k) == 2 .or. ngrid(i,j-1,k) == 2 .or. & - ngrid(i,j,k+1) == 2 .or. ngrid(i,j,k-1) == 2) then - grid(i,j,k) = 2 - end if - end do - end do - end do - - deallocate(ngrid) - - ! Return true if fire still alive - percolation_step = count(grid == 2) /= 0 - - end function percolation_step - - - !% Locate crack tips within 'at' using a percolation algorithm. A grid with cells - !% of side 'params%crack_tip_grid_size' is initialised and populated with 1s in cells containing - !% atoms and 0s where there are no atoms. The percolation is then - !% seeded in the void at (0,0,0) for a double-ended crack or (-OrigWidth/2, 0, 0) - !% for a single-ended crack, and then spreads between connected cells - !% like a forest fire. A filter is used to remove local minima closer than - !% 'params%crack_tip_min_separation' cells from one another. The result is a Table - !% with realsize=3 containing the coordinates of the crack tips detected. - !% If a through-going crack is detected the result table will have size zero. - subroutine crack_find_tip_percolation(at, params, crack_tips) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - type(Table), intent(out) :: crack_tips - integer, dimension(:,:,:), allocatable, target :: n_cell, cells, min_cells, old_cells - type(Connection) :: connect - type(Table) :: minima - integer :: min_dist - integer :: start_i, start_j, start_k, i, j, k, nstep, d_i, d_j, grid_i, u, v, w, grid_factor - integer :: min_i, max_i, min_j, max_j, min_k, max_k, fill - integer :: top_edge, bottom_edge, left_edge, right_edge, occ_threshold, n_slab - real(dp) :: crack_t(3), crack_pos(3), orig_width, start_pos(3), occ_mu, occ_sigma, grid_size - logical :: duplicate - integer, pointer, dimension(:) :: horz_slice, vert_slice - integer, pointer, dimension(:,:,:) :: n_cell_slab - type(Atoms) :: at_copy - - call system_timer('crack_find_tip') - - if (.not. get_value(at%params, 'OrigWidth', orig_width)) & - call system_abort('crack_find_tip_percolation: "OrigWidth" parameter missing from atoms') - - call atoms_copy_without_connect(at_copy, at) - call allocate(crack_tips, Nint=0, Nreal=3, Nstr=0, Nlogical=0) - - do grid_i=0,0 - grid_factor = 2**grid_i - grid_size = params%crack_tip_grid_size/grid_factor - - if (grid_factor /= 1) then - if (allocated(old_cells)) deallocate(old_cells) - allocate(old_cells(connect%cellsNa,connect%cellsNb,connect%cellsNc)) - old_cells = cells - call print('old_cells allocated to shape '//shape(old_cells)) - call print('cells allocated to shape '//shape(cells)) - deallocate(n_cell, cells, min_cells) - end if - - ! Construct temporary Connection object and partition atoms into cells - call print('crack_find_tip_percolation: allocating percolation grid with cell size '//grid_size//' A') - - call finalise(connect) - call set_cutoff(at_copy, grid_size) - call calc_connect(at_copy, alt_connect=connect) - -!!$ if (grid_i == 0) then -!!$ call divide_cell(at%lattice, grid_size, cellsNa, cellsNb, cellsNc) -!!$ else -!!$ cellsNa = cellsNa*2 -!!$ cellsNb = cellsNb*2 -!!$ cellsNc = cellsNc*2 -!!$ end if -!!$ call initialise(connect, at%N, at%Nbuffer, at%pos, at%lattice, at%g, fill=.false.) -!!$ call connection_cells_initialise(connect, cellsna, cellsnb, cellsnc, at%n) -!!$ call partition_atoms(connect, at) - - allocate(n_cell(connect%cellsNa,connect%cellsNb, connect%cellsNc)) - allocate(cells(connect%cellsNa,connect%cellsNb, connect%cellsNc)) - allocate(min_cells(connect%cellsNa,connect%cellsNb, connect%cellsNc)) - - call print('crack_find_tip_percolation: shape(cells)='//shape(cells)) - - n_cell = 0 - do k=1,connect%cellsnc - do j=1,connect%cellsnb - do i=1,connect%cellsna -! n_cell(i,j,k) = connect%cell(i,j,k)%n - n_cell(i,j,k) = cell_n(connect,i,j,k) - end do - end do - end do - - ! Find top and bottom edges of slab - vert_slice => n_cell(max(1,size(n_cell,1)/2),:,max(1,size(n_cell,3)/2)) - top_edge = 1 - do while (vert_slice(top_edge) == 0) - top_edge = top_edge + 1 - end do - top_edge = top_edge + 2 - - bottom_edge = size(vert_slice) - do while (vert_slice(bottom_edge) == 0) - bottom_edge = bottom_edge - 1 - end do - bottom_edge = bottom_edge - 2 - - ! Find left and right edges of slab - if (params%crack_double_ended) then - left_edge = 1 - right_edge = size(n_cell,1) - else - horz_slice => n_cell(:,max(1,size(n_cell,2)/2),max(1,size(n_cell,3)/2)) - - left_edge = 1 - do while (horz_slice(left_edge) == 0) - left_edge = left_edge + 1 - end do - left_edge = left_edge + 2 - - right_edge = size(horz_slice) - do while (horz_slice(right_edge) == 0) - right_edge = right_edge - 1 - end do - right_edge = right_edge - 2 - end if - - call print('crack_find_tip_percolation: edges left='//left_edge//' right='//right_edge//' top='//top_edge//' bottom='//bottom_edge) - - n_slab = (right_edge-left_edge+1)*(bottom_edge-top_edge+1)*connect%cellsnc - - call print('crack_find_tip_percolation: n_slab='//n_slab) - - n_cell_slab => n_cell(left_edge:right_edge,top_edge:bottom_edge,:) - - occ_mu = real(sum(n_cell_slab),dp)/size(n_cell_slab) - occ_sigma = sqrt(real(sum(n_cell_slab**2),dp)/size(n_cell_slab) - occ_mu**2.0_dp) - - occ_threshold = max(0,floor(occ_mu - occ_sigma)) - call print('crack_find_tip_percolation: occ_mu='//occ_mu//' occ_sigma='//occ_sigma//' occ_threshold='//occ_threshold) - - ! Mark cells with occupancy <= occ_threshold for percolation - cells = 0 - - where (n_cell <= occ_threshold) cells = 1 - - call print('crack_find_tip_percolation: before filtration count(cells == 1) = '//count(cells == 1)) - - ! Clear marks not visited in previous percolation - if (grid_factor /= 1) then - - call print('fill = '//fill) - call print('crack_find_tip_percolation: count(old_cells == fill) = '//count(old_cells == fill)) - - do k=1,size(old_cells,3) - do j=1,size(old_cells,2) - do i=1,size(old_cells,1) - if (old_cells(i,j,k) == fill) then - do w=0,1 - do v=0,1 - do u = 0,1 - cells(2*i+u,2*j+v,2*k+w) = 0 - end do - end do - end do - end if - end do - end do - end do - end if - - call print('crack_find_tip_percolation: after filtration count(cells == 1) = '//count(cells == 1)) - - if (params%crack_double_ended) then - start_pos = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - else - start_pos = (/ -0.5_dp*orig_width/2.0_dp, 0.0_dp, 0.0_dp /) - end if - - call cell_of_pos(connect, at%g .mult. start_pos, start_i, start_j, start_k) - - if (cells(start_i, start_j, start_k) /= 1) & - call system_abort('crack_find_tip_percolation: cannot start percolation since start_pos='//start_pos//' is not in void') - - call print('crack_find_tip_percolation: seeding percolation in cell ('//i//','//j//','//k//')', PRINT_VERBOSE) - - ! Stop percolation from going outside slab - cells(:left_edge,:,:) = 0 - cells(right_edge:,:,:) = 0 - cells(:,:top_edge,:) = 0 - cells(:,bottom_edge:,:) = 0 - - ! Seed percolation at start_pos then allow "fire" to percolate through cells - cells(start_i,start_j,start_k) = 2 - nstep = 0 - do while (percolation_step(cells)) - nstep = nstep + 1 - end do - call print('crack_find_tip_percolation: percolation completed in '//nstep//' steps', PRINT_VERBOSE) - - if (any(cells(left_edge,top_edge:bottom_edge,:) > 1) .and. any(cells(right_edge,top_edge:bottom_edge,:) > 1)) then - call print('crack_find_tip_percolation: through-going crack detected') - - deallocate(n_cell) - deallocate(cells) - deallocate(min_cells) - if (allocated(old_cells)) deallocate(old_cells) - - call finalise(connect) - call finalise(at_copy) - call finalise(minima) - call system_timer('crack_find_tip') - return - - end if - - ! Fill cells outside the slab and those containing atoms to avoid them showing up as minima - fill = 2*maxval(cells) - where(cells == 0 .or. cells == 1) - cells = fill - end where - - end do - - - ! minimum filter: each point on the grid is set to the minimum of nearby points - ! Equivalent to - ! min_cells(i,j,k) = minval(cells(i-min_dist/2:i+min_dist/2, j-min_dist/2:j+min_dist/2, k-min_dist/2:j+min_dist/2) - ! but without overflowing any array boundaries - - min_dist = params%crack_tip_min_separation/grid_size - call print('crack_find_tip_percolation: minimum distance between tips is '//params%crack_tip_min_separation//' A = '//min_dist//' cells.', PRINT_VERBOSE) - - min_cells = 0 - do k=1,connect%cellsnc - min_k = min(max(k - min_dist/2, 1), connect%cellsnc) - max_k = min(max(k + min_dist/2, 1), connect%cellsnc) - - do j=1,connect%cellsnb - min_j = min(max(j - min_dist/2, 1), connect%cellsnb) - max_j = min(max(j + min_dist/2, 1), connect%cellsnb) - - do i=1,connect%cellsna - min_i = min(max(i - min_dist/2, 1), connect%cellsna) - max_i = min(max(i + min_dist/2, 1), connect%cellsna) - - min_cells(i,j,k) = minval(cells(min_i:max_i, min_j:max_j, min_k:max_k)) - end do - end do - end do - - ! Find all the local minima - call allocate(minima, Nint=3,Nreal=0,Nstr=0,Nlogical=0) - do k=1,connect%cellsnc - do j=1,connect%cellsnb - do i=1,connect%cellsna - if (min_cells(i,j,k) == cells(i,j,k) .and. min_cells(i,j,k) /= fill) call append(minima, (/i,j,k/)) - end do - end do - end do - - call print('crack_find_tip_percolation: got '//minima%n//' tips before duplicate removal', PRINT_VERBOSE) - if (current_verbosity() >= PRINT_VERBOSE) then - do i=1,minima%n - crack_t(1) = real(minima%int(1,i),dp)/connect%cellsna - crack_t(2) = real(minima%int(2,i),dp)/connect%cellsnb - crack_t(3) = real(minima%int(3,i),dp)/connect%cellsnc - crack_t = crack_t - 0.5_dp - call print(' tip #'//i//' cell '//minima%int(:,i)//' position '//(at%lattice .mult. crack_t)) - end do - end if - - ! Remove duplicate minima of same depth within params%crack_tip_min_separation of one another - do while (.true.) - duplicate = .false. - outer: do i=1,minima%N - do j=i+1,minima%N - if (dot_product((minima%int(:,i) - minima%int(:,j)),(minima%int(:,i) - minima%int(:,j))) < min_dist**2) then - duplicate = .true. - exit outer - end if - end do - end do outer - - if (duplicate) then - d_i = dot_product((minima%int(:,i) - (/start_i, start_j, start_k/)),(minima%int(:,i) - (/start_i, start_j, start_k/))) - d_j = dot_product((minima%int(:,j) - (/start_i, start_j, start_k/)),(minima%int(:,j) - (/start_i, start_j, start_k/))) - - call print('duplicates '//i//' and '//j//' d_i='//d_i//' d_j='//d_j) - - if (d_i > d_j) then - call print('removing j '//j) - call delete(minima, j, .true.) - else - call print('removing i '//i) - call delete(minima, i, .true.) - end if - else - exit - end if - end do - - call print('crack_find_tip_percolation: found '//minima%n//' crack tips') - - do i=1,minima%n - crack_t(1) = real(minima%int(1,i),dp)/connect%cellsna - crack_t(2) = real(minima%int(2,i),dp)/connect%cellsnb - crack_t(3) = real(minima%int(3,i),dp)/connect%cellsnc - crack_t = crack_t - 0.5_dp - crack_pos = at%lattice .mult. crack_t - - ! Insert in crack_tips table such that results are ordered by increasing x coordinate - j = 1 - do while (j <= crack_tips%N) - if (crack_tips%real(1,j) > crack_pos(1)) exit - j = j + 1 - end do - - call print('crack_find_tip_percolation: inserting x='//crack_pos(1)//' at position '//j) - call insert(crack_tips, j, realpart=crack_pos) - end do - - deallocate(n_cell) - deallocate(cells) - deallocate(min_cells) - if (allocated(old_cells)) deallocate(old_cells) - - call finalise(connect) - call finalise(at_copy) - call finalise(minima) - call system_timer('crack_find_tip') - - end subroutine crack_find_tip_percolation - - - subroutine crack_find_surface_atoms(at) - type(Atoms), intent(inout) :: at - - real(dp), allocatable, dimension(:,:) :: filtered_local_energy - real(dp), pointer, dimension(:) :: local_energy - integer, pointer, dimension(:) :: edge_mask, assign - logical, pointer, dimension(:) :: crack_surface - logical, allocatable, dimension(:) :: filtered_surface - real(dp) :: means(2,1) - integer surface_cluster(1) - - if (.not. assign_pointer(at, 'local_energy', local_energy)) & - call system_abort('crack_find_tip_local_energy: local_energy property missing from atoms') - - if (.not. assign_pointer(at, 'edge_mask', edge_mask)) & - call system_abort('crack_find_tip_local_energy: edge_mask property missing from atoms') - - if (.not. assign_pointer(at, 'crack_surface', crack_surface)) & - call system_abort('crack_find_tip_local_energy: crack_surface property missing from atoms') - - ! Carry out k-means clustering by the filtered local energies: - ! will give two clusters one for bulk and other for surface. - ! crack surface atoms are those in highest energy cluster and with - ! edge_mask == 0 - - allocate(filtered_local_energy(count(edge_mask == 0),1), assign(count(edge_mask == 0))) - filtered_local_energy(:,1) = pack(local_energy, edge_mask == 0) - means(1,1) = minval(filtered_local_energy) - means(2,1) = maxval(filtered_local_energy) - call kmeans(filtered_local_energy, 2, means, assign) - allocate(filtered_surface(size(assign))) - surface_cluster = maxloc(means(:,1)) - filtered_surface = assign == surface_cluster(1) - crack_surface = unpack(filtered_surface, edge_mask == 0, .false.) - deallocate(filtered_local_energy, assign, filtered_surface) - - call print('crack_find_surface_atoms: found '//count(crack_surface)//' surface atoms.') - - end subroutine crack_find_surface_atoms - - subroutine crack_find_tip_local_energy(at, params) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - - real(dp), allocatable, dimension(:) :: surface_x, surface_z, surface_x_band - integer, allocatable, dimension(:) :: surface_i, surface_i_band - logical, pointer, dimension(:) :: crack_surface, crack_front - real(dp) z - integer i - - if (.not. assign_pointer(at, 'crack_surface', crack_surface)) & - call system_abort('crack_find_tip_local_energy: crack_surface property missing from atoms') - - if (.not. assign_pointer(at, 'crack_front', crack_front)) & - call system_abort('crack_find_tip_local_energy: crack_front property missing from atoms') - - crack_front(:) = .false. - - allocate(surface_i(count(crack_surface)), surface_i_band(count(crack_surface)), & - surface_z(count(crack_surface)), & - surface_x(count(crack_surface)), surface_x_band(count(crack_surface))) - - ! Indices and (x,z) coordinates of surface atoms - surface_i = pack( (/ (i, i=1,at%N) /), crack_surface) - surface_x = pack(at%pos(1,:), crack_surface) - surface_z = pack(at%pos(3,:), crack_surface) - - z = minval(surface_z) - do while (z <= maxval(surface_z)) - surface_i_band = 0 - surface_x_band = -huge(1.0_dp) - where (surface_z >= z .and. surface_z < z + params%crack_front_window_size) - surface_i_band = surface_i - surface_x_band = surface_x - end where - - if (count(surface_i_band /= 0) == 0) cycle ! continue if there are no atoms in this band - - ! Mark the right-most atom in the band as being part of the crack front - crack_front(surface_i_band(maxloc(surface_x_band))) = .true. - z = z + params%crack_front_window_size - end do - - deallocate(surface_i, surface_x, surface_z, surface_i_band, surface_x_band) - call print('crack_find_tip_local_energy: found '//count(crack_front)//' crack front atoms.') - - end subroutine crack_find_tip_local_energy - -#ifdef HAVE_CGAL - subroutine alpha_shape_2(x, y, alpha, shape_n, shape_list, error) - real(dp), intent(in) :: x(:), y(:) - real(dp), intent(in) :: alpha - integer, intent(out) :: shape_n - integer, intent(out) :: shape_list(size(x)) - integer, optional, intent(out) :: error - - integer points_n - - INIT_ERROR(error) - - if (size(x) /= size(y)) then - RAISE_ERROR("alpha_shape_2: size(x) /= size(y)", error) - end if - points_n = size(x) - shape_n = size(shape_list) - call c_alpha_shape_2(points_n, x, y, alpha, shape_n, shape_list, error) - ! convert from 0-based to 1-based indices - shape_list(1:shape_n) = shape_list(1:shape_n) + 1 - - end subroutine alpha_shape_2 - - subroutine crack_front_alpha_shape(at, alpha, angle_threshold, error) - use iso_c_binding, only: C_INT, C_DOUBLE - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: alpha, angle_threshold - integer, intent(out), optional :: error - - logical, pointer, dimension(:) :: crack_surface, crack_front - real(C_DOUBLE) :: c_alpha, c_angle_threshold - real(C_DOUBLE), allocatable, dimension(:) :: x, z - integer(C_INT), allocatable, dimension(:) :: front, surf - integer(C_INT) :: n_surf, n_front - integer :: i - - INIT_ERROR(error) - - if (.not. assign_pointer(at, 'crack_front', crack_front)) then - RAISE_ERROR('crack_find_tip_local_energy: crack_front property missing from atoms', error) - end if - - if (.not. assign_pointer(at, 'crack_surface', crack_surface)) then - RAISE_ERROR('crack_find_tip_local_energy: crack_surface property missing from atoms', error) - end if - - n_surf = count(crack_surface) - allocate(x(n_surf), z(n_surf), surf(n_surf)) - surf(:) = pack((/ (i, i=1,at%N) /), crack_surface) - x(:) = pack(at%pos(1,:), crack_surface) - z(:) = pack(at%pos(3,:), crack_surface) - - n_front = n_surf - allocate(front(n_front)) - front(:) = 0 - - c_alpha = alpha - c_angle_threshold = angle_threshold - - call c_crack_front_alpha_shape(n_surf, x, z, c_alpha, c_angle_threshold, n_front, front, error) - PASS_ERROR(error) - - front(1:n_front) = front(1:n_front) + 1 ! convert to Fortran indexing - crack_front(:) = .false. - crack_front(surf(front(1:n_front))) = .true. - - deallocate(x, z, surf, front) - - call set_value(at%params, 'CrackPosx', sum(x(front(1:n_front))/real(n_front,dp))) - call set_value(at%params, 'CrackPosy', 0.0_dp) - - end subroutine crack_front_alpha_shape -#endif - - subroutine crack_print_cio(at, cio, params) - type(Atoms), intent(inout) :: at - type(CInoutput), intent(inout) :: cio - type(CrackParams), intent(in) :: params - - if (params%io_print_all_properties) then - call write(cio, at) - else - call write(cio, at, properties_array=params%io_print_properties) - end if - end subroutine crack_print_cio - - subroutine crack_print_filename(at, filename, params) - type(Atoms), intent(inout) :: at - character(*), intent(in) :: filename - type(CrackParams), intent(in) :: params - - type(CInOutput) :: cio - - call initialise(cio, filename, action=OUTPUT) - if (params%io_print_all_properties) then - call write(cio, at) - else - call write(cio, at, properties_array=params%io_print_properties) - end if - call finalise(cio) - - end subroutine crack_print_filename - - subroutine crack_make_slab(params, classicalpot, crack_slab,width, height, E, v, v2, bulk) - type(CrackParams), intent(in) :: params - type(Potential), intent(inout) :: classicalpot - type(Atoms), intent(out) :: crack_slab - real(dp), intent(out) :: width, height, E, v, v2 - type(Atoms), intent(out) :: bulk - - real(dp) :: a, shift, uij(3), ydiff, mindiff, minabsy - type(Atoms) :: crack_layer - real (dp), dimension(3,3) :: axes, lattice - integer :: i, atom1, atom2, n, j, nx, ny - real(dp), dimension(6,6) :: c, c0 - - if (trim(params%crack_bulk_filename) /= '') then - - call print_title('Reading bulk cell from file '//trim(params%crack_bulk_filename)) - call read(bulk, params%crack_bulk_filename) - - if (params%elastic_read) then - c = params%elastic_cij/EV_A3_IN_GPA - else - call calc_elastic_constants(classicalpot, bulk, c=c, c0=c0, relax_initial=params%crack_relax_bulk, return_relaxed=params%crack_relax_bulk) - - call print('Relaxed elastic constants (GPa):') - call print(c*EV_A3_IN_GPA) - call print('') - call print('Unrelaxed elastic constants (GPa):') - call print(c0*EV_A3_IN_GPA) - call print('') - - call print('Relaxed lattice') - call print(bulk%lattice) - end if - - if (.not. get_value(bulk%params, 'YoungsModulus', E)) & - call system_abort('crack_uniform_load: "YoungsModulus" missing') - - if (.not. get_value(bulk%params, 'PoissonRatio_yx', v)) & - call system_abort('crack_uniform_load: "PoissonRatio_yx" missing') - - if (.not. get_value(bulk%params, 'PoissonRatio_yz', v2)) & - call system_abort('crack_uniform_load: "PoissonRatio_yz" missing') - - call Print('') - call print('Youngs modulus E_y = '//E) - call print('Poisson ratio v_yx = '//v) - call print('Poisson ratio v_yz = '//v2) - call Print('') - - nx = int(floor(params%crack_width/bulk%lattice(1,1))) - ny = int(floor(params%crack_height/bulk%lattice(2,2))) - - nx = max(nx, 1) - ny = max(ny, 1) - - call supercell(crack_layer, bulk, nx, ny, 1) - - call set_cutoff(crack_layer, cutoff(classicalpot)+params%md(params%md_stanza)%crust) - call supercell(crack_slab, crack_layer, 1, 1, params%crack_num_layers) - call calc_connect(crack_slab, store_is_min_image=.true.) - - call Print('Slab contains '//crack_slab%N//' atoms.') - - ! Actual width and height differ a little from requested - width = maxval(crack_slab%pos(1,:))-minval(crack_slab%pos(1,:)) - height = maxval(crack_slab%pos(2,:))-minval(crack_slab%pos(2,:)) - call Print('Actual slab dimensions '//width//' A x '//height//' A') - - else - - if (trim(params%crack_structure) == 'graphene') then - - call print_title('Graphene Crack') - -!!$ call graphene_elastic(classicalpot, a, v, E) - - a = 1.42_dp - v = 0.144_dp - E = 344.0_dp - - call Print('graphene sheet, lattice constant a='//a) - - bulk = graphene_cubic(a) - - if (trim(params%crack_slab_filename).ne.'') then - call print('Reading atoms from input file') - call read(crack_slab, trim(params%crack_slab_filename)) - else - call graphene_slab(crack_layer, a, params%crack_graphene_theta, & - params%crack_width, params%crack_height) - crack_layer%Z = 6 - - if (abs(params%crack_graphene_theta - 0.0_dp) < 1e-3_dp) then - call print('armchair sheet') - shift = 0.61567821_dp - else if (abs(params%crack_graphene_theta - pi/6.0_dp) < 1e-3_dp) then - call print('zigzag sheet') - shift = 0.53319064_dp - end if - - lattice = crack_layer%lattice - lattice(1,1) = lattice(1,1) + params%crack_vacuum_size - lattice(2,2) = lattice(2,2) + params%crack_vacuum_size - call set_lattice(crack_layer, lattice, scale_positions=.false.) - - do i=1,crack_layer%N - crack_layer%pos(2,i) = crack_layer%pos(2,i) + shift - end do - endif - - ! Actual width and height differ a little from requested - width = maxval(crack_layer%pos(1,:))-minval(crack_layer%pos(1,:)) - height = maxval(crack_layer%pos(2,:))-minval(crack_layer%pos(2,:)) - call Print('Actual slab dimensions '//width//' A x '//height//' A') - - ! Cut notch - if (params%crack_graphene_notch_width > 0.0_dp .and. & - params%crack_graphene_notch_height > 0.0_dp) then - call Print('Cutting notch with width '//params%crack_graphene_notch_width// & - ' A, height '//params%crack_graphene_notch_height//' A.') - - i = 1 - do - if ((crack_layer%pos(2,i) < & - -(0.5_dp*params%crack_graphene_notch_height/ & - params%crack_graphene_notch_width*(crack_layer%pos(1,i)+width/2.0_dp)) + & - params%crack_graphene_notch_height/2.0_dp) .and. & - (crack_layer%pos(2,i) > & - (0.5_dp*params%crack_graphene_notch_height/ & - params%crack_graphene_notch_width*(crack_layer%pos(1,i)+width/2.0_dp)) - & - params%crack_graphene_notch_height/2.0_dp)) then - call remove_atoms(crack_layer, i) - - i = i - 1 ! retest - end if - if (i == crack_layer%N) exit - i = i + 1 - end do - end if - - crack_layer%lattice(3,3) = 10.0_dp - crack_slab = crack_layer - - call set_cutoff(crack_slab, cutoff(classicalpot)+params%md(params%md_stanza)%crust) - call calc_connect(crack_slab, store_is_min_image=.true.) - - call Print('Graphene sheet contains '//crack_slab%N//' atoms.') - - else if (trim(params%crack_structure) == 'diamond'.or.trim(params%crack_structure) == 'bcc' & - .or.trim(params%crack_structure) == 'fcc' .or. trim(params%crack_structure) == 'alpha_quartz' & - .or.trim(params%crack_structure) == 'anatase' .or. trim(params%crack_structure) == 'rutile') then - - if(trim(params%crack_structure) == 'diamond') then - call print_title('Diamond Structure Crack') - call diamond(bulk, params%crack_lattice_guess, params%crack_z) - elseif(trim(params%crack_structure) == 'bcc') then - call print_title('BCC Structure Crack') - call bcc(bulk, params%crack_lattice_guess, params%crack_z(1)) - call set_cutoff(bulk, cutoff(classicalpot)) - elseif(trim(params%crack_structure) == 'fcc') then - call print_title('FCC Structure Crack') - call fcc(bulk, params%crack_lattice_guess, params%crack_z(1)) - call set_cutoff(bulk, cutoff(classicalpot)) - elseif(trim(params%crack_structure) == 'alpha_quartz') then - call print_title('Alpha Quartz Crack') - call alpha_quartz(bulk, a=params%crack_lattice_a, c=params%crack_lattice_c, u=params%crack_lattice_u, & - x=params%crack_lattice_x, y=params%crack_lattice_y, z=params%crack_lattice_z) - call set_cutoff(bulk, cutoff(classicalpot)) - elseif(trim(params%crack_structure) == 'anatase') then - call print_title('TiO2 Anatase Crack') - call anatase_cubic(bulk, a=params%crack_lattice_a, c=params%crack_lattice_c, u=params%crack_lattice_u) - call set_cutoff(bulk, cutoff(classicalpot)) - elseif(trim(params%crack_structure) == 'rutile') then - call print_title('TiO2 Rutile Crack') - call rutile(bulk, a=params%crack_lattice_a, c=params%crack_lattice_c, u=params%crack_lattice_u) - call set_cutoff(bulk, cutoff(classicalpot)) - endif - - if (params%elastic_read) then - c = params%elastic_cij/EV_A3_IN_GPA - else - call calc_elastic_constants(classicalpot, bulk, c=c, c0=c0, relax_initial=params%crack_relax_bulk, return_relaxed=params%crack_relax_bulk) - - call print('Relaxed elastic constants (GPa):') - call print(c*EV_A3_IN_GPA) - call print('') - call print('Unrelaxed elastic constants (GPa):') - call print(c0*EV_A3_IN_GPA) - call print('') - - call print('Relaxed lattice') - call print(bulk%lattice) - end if - - ! Parse crack name and make crack slab - if (trim(params%crack_structure) == 'alpha_quartz') then - - ! basal (0001) surface - a = params%crack_lattice_a - axes = reshape((/1.0_dp, 0.0_dp, 0.0_dp, & - 0.0_dp, 0.0_dp, 1.0_dp, & - 0.0_dp, 1.0_dp, 0.0_dp/), (/3,3/)) - else - a = bulk%lattice(1,1) - - call Print(trim(params%crack_element)//' crack: atomic number Z='//params%crack_z//& - ', lattice constant a = '//a) - call Print('Crack name '//params%crack_name) - - call crack_parse_name(params%crack_name, axes) - end if - - ! Get elastic constants relevant for a pull in y direction - E = Youngs_Modulus(C, axes(:,2))*EV_A3_IN_GPA - v = Poisson_Ratio(C, axes(:,2), axes(:,1)) - v2 = Poisson_Ratio(C, axes(:,2), axes(:,3)) - - call Print('') - call print('Youngs modulus E_y = '//E) - call print('Poisson ratio v_yx = '//v) - call print('Poisson ratio v_yz = '//v2) - call Print('') - - if (trim(params%crack_slab_filename).ne.'') then - call print('Reading atoms from input file') - call read(crack_slab, trim(params%crack_slab_filename)) - else - call slab(crack_layer, axes, width=params%crack_width, height=params%crack_height, nz=1, atnum=params%crack_z, & - lat_type=trim(params%crack_structure), a=a, c=params%crack_lattice_c, u=params%crack_lattice_u, & - x=params%crack_lattice_x, y=params%crack_lattice_y, z=params%crack_lattice_z) - call set_cutoff(crack_layer, cutoff(classicalpot)+params%md(params%md_stanza)%crust) - call supercell(crack_slab, crack_layer, 1, 1, params%crack_num_layers) - endif - - call calc_connect(crack_slab, store_is_min_image=.true.) - - call Print('Slab contains '//crack_slab%N//' atoms.') - - ! Actual width and height differ a little from requested - width = maxval(crack_slab%pos(1,:))-minval(crack_slab%pos(1,:)) - height = maxval(crack_slab%pos(2,:))-minval(crack_slab%pos(2,:)) - call Print('Actual slab dimensions '//width//' A x '//height//' A') - - else - ! Add code here for other structures... - - call system_abort("Don't (yet!) know how to make cracks with structure "//trim(params%crack_structure)) - - end if ! select on crack_structure - - end if - - if(params%crack_align_y) then - call print_title('Aligning Seed Crack at y=0') - - ! Find an atom close to y=0 - minabsy = 1000.0_dp - atom1 = -1; atom2 = -1 - mindiff = 1000.0_dp - do i=1, crack_slab%N - if (abs(crack_slab%pos(2,i)) < minabsy) then - minabsy = abs(crack_slab%pos(2,i)) - atom1 = i - end if - end do - - ! Apply shift to centre the seed crack in the right place - if (trim(params%crack_name) == '(111)[11b0]') then - - call calc_connect(crack_slab) - - ! Find atom1's closest neighbour vertically above or below it (x and z equal, not y) - do n = 1, n_neighbours(crack_slab, atom1) - j = neighbour(crack_slab, atom1, n, diff=uij) ! nth neighbour of atom1 - if (abs(uij(1)) < 1e-4_dp .and. & - abs(uij(2)) > 1e-4_dp .and. & - abs(uij(3)) < 1e-4_dp) then - - ydiff = abs(crack_slab%pos(2,atom1)-crack_slab%pos(2,j)) - if (ydiff < mindiff) then - mindiff = ydiff - atom2 = j - end if - end if - end do - - if (atom1 == -1 .or. atom2 == -1) & - call system_abort('Failed to find a pair of atoms vertically aligned!') - - ! Align y=0 to centre line of atom1-atom2 bond - shift = (crack_slab%pos(2,atom1) + crack_slab%pos(2,atom2))/2.0_dp - - call Print('Centering on (atom '//atom1//')--(atom '//atom2//') bond') - call print(' Atom 1 pos = '//crack_slab%pos(:,atom1)) - call print(' Atom 2 pos = '//crack_slab%pos(:,atom2)) - call Print('Shifting atoms vertically by '//shift) - - do i=1,crack_slab%N - crack_slab%pos(2,i) = crack_slab%pos(2,i) + shift - end do - - else if(trim(params%crack_name) == '(110)[11b0]') then - ! Align y=0 to atom1 - shift = -crack_slab%pos(2,atom1) - - call Print('Centering on atom '//atom1) - call print(' Atom 1 pos = '//crack_slab%pos(:,atom1)) - call Print('Shifting atoms vertically by '//shift) - do i=1,crack_slab%N - crack_slab%pos(2,i) = crack_slab%pos(2,i) + shift - end do - - else if (trim(params%crack_name) == '(110)[001b]') then - ! Do nothing - correctly aligned already - else if (trim(params%crack_name) == '(100)(010)') then - ! Do nothing - correctly aligned already - else if (trim(params%crack_structure) == 'graphene') then - ! Do nothing - correctly aligned already - else - ! Get shift from params - do i=1,crack_slab%N - crack_slab%pos(2,i) = crack_slab%pos(2,i) + params%crack_y_shift - end do - end if - endif - - ! Horizontal shift - if (params%crack_x_shift .fne. 0.0_dp) then - do i=1,crack_slab%N - crack_slab%pos(1,i) = crack_slab%pos(1,i) + params%crack_x_shift - end do - end if - - end subroutine crack_make_slab - - subroutine crack_check_coordination(at,params,j,y,x_boundaries,neigh_removed, at_for_connectivity) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(in) :: params - integer, intent(in) :: j - real(dp), optional,intent(inout) :: y - logical, optional, intent(in) :: x_boundaries - logical, optional, intent(inout) :: neigh_removed(at%n) - type(Atoms), optional :: at_for_connectivity - logical :: my_x_boundaries - real(dp) :: rmin, rij - integer :: i, ji, n2, who_closest - integer, allocatable,dimension(:) :: who, who_nn, who_absolute_index - - my_x_boundaries = optional_default(.false.,x_boundaries) - - rmin = 100.d0 - allocate(who_nn(n_neighbours(at, j))) - allocate(who(n_neighbours(at, j))) - allocate(who_absolute_index(n_neighbours(at, j))) - who_absolute_index = 0 - who_nn = 0 - who = 0 - n2 = 0 - - - do i = 1, n_neighbours(at, j) - ji = neighbour(at,j,i,distance=rij) - if(at%Z(ji).ne.at%Z(j)) then - n2 = n2 + 1 - who_absolute_index(n2) = ji - who(n2) = i - if(present(at_for_connectivity)) then - who_nn(n2) = n_neighbours(at_for_connectivity, ji) - else - who_nn(n2) = n_neighbours(at, ji) - endif -! Detect who is the nearest neighbour of different type - if(rij.lt.rmin) then - rmin = rij - who_closest = i - endif - endif - enddo - -! Check the connectivity. E.g.: if coordination_critical_nneigh=2, it checks when the atom has 3 nn, since it is going to loose a neighbours of its. -! If an atom has already lost a neighbour, do not remove another atoms from it - do i = 1, n2 - if(present(neigh_removed).and.neigh_removed(who_absolute_index(i))) then - who_closest = who(i) - exit - elseif(who_nn(i).le.params%crack_check_coordination_critical_nneigh+1.and.who(i).ne.who_closest) then - if(who_nn(who_closest).gt.who_nn(i)) then - who_closest = who(i) - endif - endif - enddo - - if(my_x_boundaries) then - ! check x-boundary - if(at%pos(1,neighbour(at,j,who_closest)).gt.0.0_dp.and.at%pos(1,j).lt.0.0_dp) then - at%pos(1,j) = at%pos(1,j) + at%lattice(1,1) - elseif(at%pos(1,neighbour(at,j,who_closest)).lt.0.0_dp.and.at%pos(1,j).gt.0.0_dp) then - at%pos(1,j) = at%pos(1,j) - at%lattice(1,1) - endif - if(present(neigh_removed)) then - do i = 1, n2 - if( abs(at%pos(1,neighbour(at,j,who(i)))-at%pos(1,j)).gt.at%lattice(1,1)/2.0_dp) then - neigh_removed=.true. - endif - enddo - endif - else !check only y - if(at%pos(2,neighbour(at,j,who_closest)).gt.0.0_dp) then - y = abs(at%pos(2,j)) - else - y = -abs(at%pos(2,j)) - endif - endif - - end subroutine crack_check_coordination - - subroutine crack_check_coordination_boundaries(at,params) - type(Atoms), intent(inout) :: at - type(CrackParams), intent(inout) :: params - type(Atoms) :: at_tmp - real(dp), dimension(3,3) :: lattice_tmp - integer :: i - logical, dimension(at%n) :: neigh_removed - real(dp) :: width - - at_tmp = at - lattice_tmp = at_tmp%lattice - lattice_tmp(1,1) = lattice_tmp(1,1) + params%crack_vacuum_size - lattice_tmp(2,2) = lattice_tmp(2,2) + params%crack_vacuum_size - call set_lattice(at_tmp, lattice_tmp, scale_positions=.false.) - !call calc_connect(at_tmp) - - neigh_removed = .false. - - if (.not. get_value(at_tmp%params, 'OrigWidth', width)) & - call system_abort('crack_check_coordination_boundaries: "OrigWidth" parameter missing') - - do i = 1, at%n - print *, i - if(at%Z(i).eq.params%crack_check_coordination_atom_type.and.(abs(at%pos(1,i)) > width/2.0_dp - params%crack_check_coordination_region)) then - call crack_check_coordination(at,params,i, x_boundaries=.true., neigh_removed=neigh_removed, at_for_connectivity=at_tmp) - !call crack_check_coordination(at,params,i, x_boundaries=.true.) - endif - enddo - - end subroutine crack_check_coordination_boundaries - - - function crack_mm_calc_args(mm_args_str, extra_mm_args, extra_args_str) - character(len=*), intent(in) :: mm_args_str, extra_mm_args, extra_args_str - character(len=len_trim(mm_args_str)+len_trim(" ")+len_trim(extra_mm_args)+1+len_trim(extra_args_str)) :: crack_mm_calc_args - - crack_mm_calc_args = trim(mm_args_str)//" "//trim(extra_mm_args)//" "//trim(extra_args_str) - call print("crack_mm_calc_args "//crack_mm_calc_args, PRINT_VERBOSE) - - end function crack_mm_calc_args - - - function crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args_str) - character(len=*), intent(in) :: qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args_str - character(len=len("qm_args_str={")+len_trim(qm_args_str)+1+len_trim(extra_qm_args)+& - len("} mm_args_str={")+len_trim(mm_args_str)+1+len(extra_mm_args)+len("} ")+len_trim(extra_args_str)) :: crack_hybrid_calc_args - - crack_hybrid_calc_args = "qm_args_str={"//trim(qm_args_str)//" "//trim(extra_qm_args)//& - "} mm_args_str={"//trim(mm_args_str)//" "//trim(extra_mm_args)//"} "//trim(extra_args_str) - call print("crack_hybrid_calc_args "//crack_hybrid_calc_args, PRINT_VERBOSE) - - end function crack_hybrid_calc_args - - -end module CrackTools_module diff --git a/src/Utils/elasticity.f95 b/src/Utils/elasticity.f95 deleted file mode 100644 index 06d49429fe..0000000000 --- a/src/Utils/elasticity.f95 +++ /dev/null @@ -1,736 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module elasticity_module - - use libatoms_module - - use Potential_module - implicit none - - private - - public :: calc_elastic_constants - interface calc_elastic_constants - module procedure pot_calc_elastic_constants - end interface - - public :: youngs_modulus, poisson_ratio, graphene_elastic, einstein_frequencies, elastic_fields - - -contains - - subroutine pot_calc_elastic_constants(this, at, fd, args_str, c, c0, relax_initial, return_relaxed, relax_tol, relax_method, linmin_method) - type(Potential), intent(inout) :: this - type(Atoms), intent(inout) :: at !% Atoms object for which to compute $C_{ij}$ - real(dp), intent(in), optional :: fd !% Finite strain to apply. Default $10^{-2}$. - character(len=*), intent(in), optional :: args_str !% Optional args_str to pass to 'minim' - real(dp), intent(out), optional :: c(6,6) !% Elastic constants (with relaxation) - real(dp), intent(out), optional :: c0(6,6) !% Elastic constants (without relaxation) - logical, optional :: relax_initial !% Should the initial cell be relaxed? - logical, optional :: return_relaxed !% If true, overwrite 'at' with relaxed positions and lattice (default false) - real(dp), optional :: relax_tol !% Relaxation df$^2$ tolerance. Default 1e-8 - character(len=*), optional :: relax_method !% method to pass for minim - character(len=*), optional :: linmin_method !% method to pass for minim - - logical my_relax_initial, my_return_relaxed - integer ii, jj - type(atoms) :: at_bulk - type(atoms) :: at_t - real(dp) :: my_fd, my_relax_tol - real(dp) :: volume - real(dp) :: Fp(3,3), Fm(3,3) - real(dp) :: V0p(3,3), V0m(3,3), Vp(3,3), Vm(3,3) - integer iter - character(len=100) :: my_relax_method, my_linmin_method - - real(dp) :: e0, V0(3,3) - - my_fd = optional_default(1.0e-2_dp, fd) - my_relax_tol = optional_default(1e-8_dp, relax_tol) - my_relax_initial = optional_default(.true., relax_initial) - my_return_relaxed = optional_default(.false., return_relaxed) - my_relax_method = trim(optional_default('cg_n', relax_method)) - my_linmin_method = trim(optional_default('FAST_LINMIN', linmin_method)) - - at_bulk = at - call set_cutoff(at_bulk, cutoff(this)) - call calc_connect(at_bulk) - - if (current_verbosity() > PRINT_VERBOSE) then - call verbosity_push_decrement(PRINT_NERD) - call calc(this, at_bulk, energy=e0, virial=v0, args_str=args_str) - call verbosity_pop() - call print("initial config") - call write(at_bulk, 'stdout') - call print("e " // e0) - call print("V") - call print(V0) - endif - - if (my_relax_initial) then - call verbosity_push_decrement(PRINT_VERBOSE) - iter = minim(this, at_bulk, my_relax_method, my_relax_tol, 1000, trim(my_linmin_method), do_print=.false., & - do_pos=.true., do_lat=.true., args_str=args_str) - call verbosity_pop() - - if (current_verbosity() >= PRINT_VERBOSE) then - call verbosity_push_decrement(PRINT_VERBOSE) - call calc(this, at_bulk, energy=e0, virial=v0, args_str=args_str) - call verbosity_pop() - call print("relaxed config") - call write(at_bulk, 'stdout') - call print("e " // e0) - call print("V") - call print(V0) - endif - - if (my_return_relaxed) at = at_bulk - endif - - volume = cell_volume(at_bulk) - - call print("volume " // volume, PRINT_VERBOSE) - - do ii=1, 3 - do jj=ii, 3 - call print("doing strain [" // ii // "," // jj//"]", PRINT_VERBOSE) - Fp = 0.0_dp; call add_identity(Fp) - Fm = 0.0_dp; call add_identity(Fm) - - Fp(ii,jj) = Fp(ii,jj) + my_fd - Fm(ii,jj) = Fm(ii,jj) - my_fd - - at_t = at_bulk - call set_lattice(at_t, Fp .mult. at_t%lattice, scale_positions=.true.) - call calc_connect(at_t) - call calc(this, at_t, energy=e0, virial=V0p, args_str=args_str) - call verbosity_push_decrement(PRINT_VERBOSE) - call print("plus perturbed config") - call write(at_t, 'stdout') - call print("E0p" // e0) - call print("V0p") - call print(V0p) - call verbosity_pop() - - if (present(c)) then - call verbosity_push_decrement(PRINT_VERBOSE) - iter = minim(this, at_t, my_relax_method, my_relax_tol, 1000, trim(my_linmin_method), do_print=.false., & - do_pos=.true., do_lat=.false., args_str=args_str) - call verbosity_pop() - - call calc_connect(at_t) - call calc(this, at_t, energy=e0, virial=Vp, args_str=args_str) - call verbosity_push_decrement(PRINT_VERBOSE) - call print("plus perturbed relaxed config") - call write(at_t, 'stdout') - call print("Ep" // e0) - call print("Vp") - call print(Vp) - call verbosity_pop() - endif - - at_t = at_bulk - call set_lattice(at_t, Fm .mult. at_t%lattice, scale_positions=.true.) - call calc_connect(at_t) - call calc(this, at_t, energy=e0, virial=V0m, args_str=args_str) - call verbosity_push_decrement(PRINT_VERBOSE) - call print("minus perturbed config") - call write(at_t, 'stdout') - call print("E0m" // e0) - call print("V0m") - call print(V0m) - call verbosity_pop() - - if (present(c)) then - call verbosity_push_decrement(PRINT_VERBOSE) - iter = minim(this, at_t, my_relax_method, my_relax_tol, 1000, trim(my_linmin_method), do_print=.false., & - do_pos=.true., do_lat=.false., args_str=args_str) - call verbosity_pop() - - call calc_connect(at_t) - call calc(this, at_t, energy=e0, virial=Vm, args_str=args_str) - call verbosity_push_decrement(PRINT_VERBOSE) - call print("minus perturbed relaxed config") - call write(at_t, 'stdout') - call print("Em" // e0) - call print("Vm") - call print(Vm) - call verbosity_pop() - endif - - if (present(c0)) then - c0(strain_index(ii,jj),strain_index(1,1)) = V0m(1,1)-V0p(1,1) - c0(strain_index(ii,jj),strain_index(1,2)) = V0m(1,2)-V0p(1,2) - c0(strain_index(ii,jj),strain_index(1,3)) = V0m(1,3)-V0p(1,3) - c0(strain_index(ii,jj),strain_index(2,2)) = V0m(2,2)-V0p(2,2) - c0(strain_index(ii,jj),strain_index(2,3)) = V0m(2,3)-V0p(2,3) - c0(strain_index(ii,jj),strain_index(3,3)) = V0m(3,3)-V0p(3,3) - c0(strain_index(1,1),strain_index(ii,jj)) = c0(strain_index(ii,jj),strain_index(1,1)) - c0(strain_index(1,2),strain_index(ii,jj)) = c0(strain_index(ii,jj),strain_index(1,2)) - c0(strain_index(1,3),strain_index(ii,jj)) = c0(strain_index(ii,jj),strain_index(1,3)) - c0(strain_index(2,2),strain_index(ii,jj)) = c0(strain_index(ii,jj),strain_index(2,2)) - c0(strain_index(2,3),strain_index(ii,jj)) = c0(strain_index(ii,jj),strain_index(2,3)) - c0(strain_index(3,3),strain_index(ii,jj)) = c0(strain_index(ii,jj),strain_index(3,3)) - endif - if (present(c)) then - c(strain_index(ii,jj),strain_index(1,1)) = Vm(1,1)-Vp(1,1) - c(strain_index(ii,jj),strain_index(1,2)) = Vm(1,2)-Vp(1,2) - c(strain_index(ii,jj),strain_index(1,3)) = Vm(1,3)-Vp(1,3) - c(strain_index(ii,jj),strain_index(2,2)) = Vm(2,2)-Vp(2,2) - c(strain_index(ii,jj),strain_index(2,3)) = Vm(2,3)-Vp(2,3) - c(strain_index(ii,jj),strain_index(3,3)) = Vm(3,3)-Vp(3,3) - c(strain_index(1,1),strain_index(ii,jj)) = c(strain_index(ii,jj),strain_index(1,1)) - c(strain_index(1,2),strain_index(ii,jj)) = c(strain_index(ii,jj),strain_index(1,2)) - c(strain_index(1,3),strain_index(ii,jj)) = c(strain_index(ii,jj),strain_index(1,3)) - c(strain_index(2,2),strain_index(ii,jj)) = c(strain_index(ii,jj),strain_index(2,2)) - c(strain_index(2,3),strain_index(ii,jj)) = c(strain_index(ii,jj),strain_index(2,3)) - c(strain_index(3,3),strain_index(ii,jj)) = c(strain_index(ii,jj),strain_index(3,3)) - endif - end do - end do - - if (present(c0)) c0 = c0 / (2.0_dp*my_fd*volume) - if (present(c)) c = c / (2.0_dp*my_fd*volume) - - end subroutine pot_calc_elastic_constants - - function strain_index(i, j) - integer, intent(in) :: i, j - integer :: strain_index - - if (i == j) strain_index = i - if ((i == 2 .and. j == 3) .or. (i == 3 .and. j == 2)) strain_index = 4 - if ((i == 3 .and. j == 1) .or. (i == 1 .and. j == 3)) strain_index = 5 - if ((i == 1 .and. j == 2) .or. (i == 2 .and. j == 1)) strain_index = 6 - end function strain_index - - - !% Calculate Youngs modulus $E_l$ from $6\times6$ elastic constants matrix $C_{ij}$ - !% This is the modulus for loading in the $l$ direction. - !% Formula is from W. Brantley, Calculated elastic constants for stress problems associated - !% with semiconductor devices. J. Appl. Phys., 44, 534 (1973). - function youngs_modulus(c, l) result(E) - real(dp), intent(in) :: c(6,6) - real(dp), dimension(3), intent(in) :: l - real(dp) :: E - - real(dp) :: s(6,6) - real(dp), dimension(3) :: lhat - - call inverse(c, s) - - ! Normalise directions - lhat = l/norm(l) - - ! Youngs modulus in direction l, ratio of stress sigma_l - ! to strain response epsilon_l - E = 1.0_dp/(S(1,1)-2.0_dp*(s(1,1)-s(1,2)-0.5_dp*s(4,4))*(lhat(1)*lhat(1)*lhat(2)*lhat(2) + & - lhat(2)*lhat(2)*lhat(3)*lhat(3) + & - lhat(1)*lhat(1)*lhat(3)*lhat(3))) - - end function youngs_modulus - - !% Calculate Poisson ratio $\nu_{lm}$ from $6\times6$ elastic - !% constant matrix $C_{ij}$. This is the response in $m$ direction - !% to pulling in $l$ direction. Result is dimensionless. - !% Formula is from W. Brantley, Calculated elastic constants for stress problems associated - !% with semiconductor devices. J. Appl. Phys., 44, 534 (1973). - function poisson_ratio(cc, l, m) result(v) - real(dp), intent(in) :: cc(6,6) - real(dp), dimension(3), intent(in) :: l, m - real(dp) :: v - - real(dp) :: s(6,6) - real(dp), dimension(3) :: lhat, mhat - - call inverse(cc, s) - - ! Normalise directions - lhat = l/norm(l) - mhat = m/norm(m) - - ! Poisson ratio v_lm: response in m direction to strain in - ! l direction, v_lm = - epsilon_m/epsilon_l - v = -((s(1,2) + (s(1,1)-s(1,2)-0.5_dp*s(4,4))*(lhat(1)*lhat(1)*mhat(1)*mhat(1) + & - lhat(2)*lhat(2)*mhat(2)*mhat(2) + & - lhat(3)*lhat(3)*mhat(3)*mhat(3))) / & - (s(1,1) - 2.0_dp*(s(1,1)-s(1,2)-0.5_dp*s(4,4))*(lhat(1)*lhat(1)*lhat(2)*lhat(2) + & - lhat(2)*lhat(2)*lhat(3)*lhat(3) + & - lhat(1)*lhat(1)*lhat(3)*lhat(3)))) - end function poisson_ratio - - !% Calculate in-plane elastic constants of a graphene sheet with lattice - !% parameter 'a' using the Potential 'pot'. On exit, 'poisson' - !% will contain the in plane poisson ratio (dimensionless) and 'young' the - !% in plane Young's modulus (GPa). - subroutine Graphene_Elastic(pot, a, poisson, young, args_str, cb) - type(Potential), intent(inout) :: pot - real(dp), intent(out) :: a, poisson, young - character(len=*), intent(in), optional :: args_str !% arg_str for potential_calc - real(dp), intent(out), optional :: cb - - type(Atoms) :: cube, at, at2, tube - real(dp) :: a0, v(3,3), eps(3,3) - integer :: steps, tube_i, i, n, m - real(dp) :: fix(3,3) - integer, parameter :: nx = 2, ny = 3 - real(dp) :: tube_r(12), tube_energy(12), graphene_e_per_atom, radius, energy, c(1), chisq - - a0 = 1.45_dp - cube = Graphene_Cubic(a0) - - call Supercell(at, cube, nx, ny, 1) - call Set_Cutoff(at, cutoff(pot)) - call randomise(at%pos, 0.01_dp) - call calc_connect(at) - - ! fix lattice in x and y directions - fix = 1.0_dp - fix(1,1) = 0.0_dp - fix(2,2) = 0.0_dp - call set_param_value(at, "Minim_Lattice_Fix", fix) - - ! Geometry optimise with variable lattice - steps = minim(pot, at, 'cg', 1e-6_dp, 100, & - 'FAST_LINMIN', do_pos=.true.,do_lat=.true.,do_print=.false.) - - ! Set a to average of x and y lattice constants - a = 0.5_dp*(at%lattice(1,1)/(3.0_dp*nx) + at%lattice(2,2)/(sqrt(3.0_dp)*ny)) - - call calc(pot, at, energy=graphene_e_per_atom, args_str=args_str) - graphene_e_per_atom = graphene_e_per_atom/at%N - - cube = Graphene_Cubic(a) - call Supercell(at2, cube, nx, ny, 1) - call Set_Cutoff(at2, cutoff(pot)) - call calc_connect(at2) - - ! Apply small strain in x direction - eps = 0.0_dp; call add_identity(eps) - eps(1,1) = eps(1,1)+0.001_dp - call set_lattice(at2, eps .mult. at2%lattice, scale_positions=.true.) - - ! Fix lattice in x direction - fix = 1.0_dp - fix(1,1) = 0.0_dp - call set_param_value(at, "Minim_Lattice_Fix", fix) - - ! Geometry optimse, allowing to contract in y direction - steps = minim(pot, at2, 'cg', 1e-6_dp, 100, & - 'FAST_LINMIN', do_print=.false., do_pos=.true.,do_lat=.true.) - - poisson = -((at2%lattice(2,2) - at%lattice(2,2))/at%lattice(2,2))/ & - ((at2%lattice(1,1) - at%lattice(1,1))/at%lattice(1,1)) - - ! Calculate stress to find Young's modulus - call Calc(pot, at2, virial=v) - - young = -v(1,1)/(eps(1,1)-1.0_dp)*EV_A3_IN_GPA/cell_volume(at2) - - if (present(cb)) then - ! Finally, calculate bending modulus by fitting strain energy per atom to - ! curve 1/2 c_b/r**2 for a series of nanotubes. We use 12 nanotubes (n,m) - ! where n runs from 10 to 20 in steps of 2 and m is either 0 or n. - tube_i = 1 - tube_r = 0.0_dp - tube_energy = 0.0_dp - call verbosity_push_decrement(PRINT_VERBOSE) - do n=10,20,2 - do m=0,n,n - radius = graphene_tube(tube, a, n, m, 3) - call set_cutoff(tube, cutoff(pot)) - call calc_connect(tube) - - - i = minim(pot, tube, 'cg', 1e-5_dp, 1000, 'FAST_LINMIN', do_print=.false., & - do_pos=.true., do_lat=.false.) - - call calc(pot, tube, energy=energy, args_str=args_str) - - tube_r(tube_i) = tube_radius(tube) - tube_energy(tube_i) = energy/tube%N - graphene_e_per_atom - tube_i = tube_i + 1 - end do - end do - call verbosity_pop() - - call least_squares(tube_r, tube_energy, (/ ( 1.0_dp, i=1,12) /), & - c, chisq, inverse_square) - cb = 2.0_dp*c(1) - - call finalise(tube) - end if - - call Finalise(cube) - call Finalise(at) - call Finalise(at2) - - end subroutine Graphene_Elastic - - subroutine inverse_square(x,afunc) - real(dp) :: x, afunc(:) - - afunc(1) = 1.0_dp/(x*x) - - end subroutine inverse_square - - - function einstein_frequencies(pot, at, args_str, ii, delta) result(w_e) - type(Potential), intent(inout) :: pot !% Potential to use - type(Atoms), intent(in) :: at !% Atoms structure - should be equilibrium bulk configuation - character(len=*), intent(in), optional :: args_str !% arg_str for potential_calc - integer, optional, intent(in) :: ii !% The atom to displace (default 1) - real(dp), optional, intent(in) :: delta !% How much to displace it (default 1e-4_dp) - real(dp), dimension(3) :: w_e - - type(Atoms) :: myatoms - integer :: myi, j - real(dp) :: mydelta, mass - real(dp), allocatable, dimension(:,:) :: f - - myatoms = at - myi = optional_default(1, ii) - mydelta = optional_default(1e-4_dp, delta) - - if (has_property(at, 'mass')) then - mass = at%mass(myi) - else - mass = ElementMass(at%Z(myi)) - end if - - allocate(f(3,at%N)) - - call set_cutoff(myatoms, cutoff(pot)+0.5_dp) - call calc_connect(myatoms) - - do j=1,3 - myatoms%pos = at%pos - myatoms%pos(j,myi) = myatoms%pos(j,myi) + mydelta - call calc_connect(myatoms) - call calc(pot, myatoms, force=f, args_str=args_str) - w_e(j) = sqrt(-f(j,myi)/(mass*mydelta))*ONESECOND - end do - - deallocate(f) - - end function einstein_frequencies - - - subroutine elastic_fields(at, a, C11, C12, C44, Cij) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: a - real(dp), intent(in), optional :: C11, C12, C44 - real(dp), intent(in), optional :: Cij(6,6) - - real(dp) :: C(6,6), strain(6), stress(6), b - real(dp), dimension(3) :: n1,n2,n3, d - real(dp), dimension(3,3) :: rotXYZ, E123, EEt, V, S, R, SS, Sig, RSigRt, RtE, SigEvecs - integer :: i, j, m, nn, ngood, maxnn - - real(dp), pointer, dimension(:) :: S_xx_sub1, S_yy_sub1, S_zz_sub1, S_yz, S_xz, S_xy, & - Sig_xx, Sig_yy, Sig_zz, Sig_yz, Sig_xz, Sig_xy, SigEval1, SigEval2, SigEval3, & - von_mises_stress, von_mises_strain, atomic_vol, energy_density - - real(dp), pointer, dimension(:,:) :: SigEvec1, SigEvec2, SigEvec3 - logical :: dum - real(dp), dimension(:), allocatable :: dist - real(dp), dimension(:,:), allocatable :: ndiff - - - rotXYZ = 0.0_dp - rotXYZ(1,2) = 1.0_dp - rotXYZ(2,3) = 1.0_dp - rotXYZ(3,1) = 1.0_dp - - ! Elastic constants matrix C_{ij} - if (present(C11) .and. present(C12) .and. present(C44)) then - C = 0.0_dp - C(1,1) = C11; C(2,2) = C11; C(3,3) = C11; - C(4,4) = C44; C(5,5) = C44; C(6,6) = C44; - C(1,2) = C12; C(1,3) = C12; C(2,3) = C12; - C(2,1) = C12; C(3,1) = C12; C(3,2) = C12; - else if (present(Cij)) then - C = Cij - else - call system_abort('elastic_fields: either C11, C12 and C44 (for cubic cell) or full Cij matrix must be present') - end if - - - ! Create properties and assign pointers - - call add_property(at, 'S_xx_sub1', 0.0_dp) - call add_property(at, 'S_yy_sub1', 0.0_dp) - call add_property(at, 'S_zz_sub1', 0.0_dp) - call add_property(at, 'S_yz', 0.0_dp) - call add_property(at, 'S_xz', 0.0_dp) - call add_property(at, 'S_xy', 0.0_dp) - - call add_property(at, 'Sig_xx', 0.0_dp) - call add_property(at, 'Sig_yy', 0.0_dp) - call add_property(at, 'Sig_zz', 0.0_dp) - call add_property(at, 'Sig_yz', 0.0_dp) - call add_property(at, 'Sig_xz', 0.0_dp) - call add_property(at, 'Sig_xy', 0.0_dp) - - call add_property(at, 'SigEval1', 0.0_dp) - call add_property(at, 'SigEval2', 0.0_dp) - call add_property(at, 'SigEval3', 0.0_dp) - call add_property(at, 'SigEvec1', 0.0_dp, n_cols=3) - call add_property(at, 'SigEvec2', 0.0_dp, n_cols=3) - call add_property(at, 'SigEvec3', 0.0_dp, n_cols=3) - - call add_property(at, 'von_mises_stress', 0.0_dp) - call add_property(at, 'von_mises_strain', 0.0_dp) - - call add_property(at, 'atomic_vol', 0.0_dp) - call add_property(at, 'energy_density', 0.0_dp) - - dum = assign_pointer(at, 'S_xx_sub1', S_xx_sub1) - dum = assign_pointer(at, 'S_yy_sub1', S_yy_sub1) - dum = assign_pointer(at, 'S_zz_sub1', S_zz_sub1) - dum = assign_pointer(at, 'S_yz', S_yz) - dum = assign_pointer(at, 'S_xz', S_xz) - dum = assign_pointer(at, 'S_xy', S_xy) - - dum = assign_pointer(at, 'Sig_xx', Sig_xx) - dum = assign_pointer(at, 'Sig_yy', Sig_yy) - dum = assign_pointer(at, 'Sig_zz', Sig_zz) - dum = assign_pointer(at, 'Sig_yz', Sig_yz) - dum = assign_pointer(at, 'Sig_xz', Sig_xz) - dum = assign_pointer(at, 'Sig_xy', Sig_xy) - - dum = assign_pointer(at, 'SigEval1', SigEval1) - dum = assign_pointer(at, 'SigEval2', SigEval2) - dum = assign_pointer(at, 'SigEval3', SigEval3) - dum = assign_pointer(at, 'SigEvec1', SigEvec1) - dum = assign_pointer(at, 'SigEvec2', SigEvec2) - dum = assign_pointer(at, 'SigEvec3', SigEvec3) - - dum = assign_pointer(at, 'von_mises_stress', von_mises_stress) - dum = assign_pointer(at, 'von_mises_strain', von_mises_strain) - - dum = assign_pointer(at, 'atomic_vol', atomic_vol) - dum = assign_pointer(at, 'energy_density', energy_density) - - call calc_connect(at) - - ! Check max number of nearest neighbours - maxnn = 0 - do i=1,at%N - nn = 0 - do m=1, n_neighbours(at,i) - if (is_nearest_neighbour(at,i,m)) nn = nn + 1 - end do - if (nn > maxnn) maxnn = nn - end do - call print('Max number of nearest neighbours: '//maxnn, PRINT_VERBOSE) - - allocate(dist(maxnn), ndiff(3,maxnn)) - - ! Loop over all atoms - ngood = 0 - do i=1,at%N - - call print('Atom '//i, PRINT_VERBOSE) - - ! Count number of nearest neighbours - nn = 0 - do m=1,n_neighbours(at, i) - if (is_nearest_neighbour(at,i,m)) then - nn = nn + 1 - j = neighbour(at, i, m, distance=dist(nn), diff=ndiff(:,nn)) - - if (at%Z(j) == 1) then ! Skip hydrogen neighbours - nn = nn - 1 - cycle - end if - - call print(nn//': '//dist(nn)//ndiff(:,nn), PRINT_VERBOSE) - if (nn > 5) exit - end if - end do - - if (nn == 4) then - - ngood = ngood + 1 - - ! Find cubic axes from neighbours - n1 = ndiff(:,2)-ndiff(:,1) - n2 = ndiff(:,3)-ndiff(:,1) - n3 = ndiff(:,4)-ndiff(:,1) - - call print('n1 '//norm(n1)//n1, PRINT_VERBOSE) - call print('n2 '//norm(n2)//n2, PRINT_VERBOSE) - call print('n3 '//norm(n3)//n3, PRINT_VERBOSE) - - ! Estimate volume of Voronoi cell as rhombic dodecahedron with volume 16/9*sqrt(3)*b**3 * 1/2 - b = (norm(ndiff(:,1)) + norm(ndiff(:,2)) + norm(ndiff(:,3)))/3.0_dp - atomic_vol(i) = 16.0_dp/9.0_dp*sqrt(3.0_dp)*b**3/2.0_dp - call print('atomic volume '//atomic_vol(i), PRINT_VERBOSE) - - e123(:,1) = (n1 + n2 - n3)/a - e123(:,2) = (n2 + n3 - n1)/a - e123(:,3) = (n3 + n1 - n2)/a - - ! Kill near zero elements - where (abs(e123) < 1.0e-6_dp) e123 = 0.0_dp - - if (all(e123 < 0.0_dp)) e123 = -e123 - - call print('det(e) = '//matrix3x3_det(e123), PRINT_VERBOSE) - call print(e123, PRINT_VERBOSE) - - if (matrix3x3_det(e123) < 0) then - e123(:,3) = -e123(:,3) - call print('reflected axis 3', PRINT_VERBOSE) - call print(e123, PRINT_VERBOSE) - end if - - ! Find polar decomposition: e123 = S*R where S is symmetric, - ! and R is a rotation - ! - ! EEt = E*E', EEt = VDV' D diagonal, S = V D^1/2 V', R = S^-1*E - - EEt = e123 .mult. transpose(e123) ! Normal - call diagonalise(EEt, D, V) - - ! Check positive definite - if (any(D < 0)) then - call print(e123, PRINT_VERBOSE) - call system_abort("EE' is not positive definite") - end if - - S = V .mult. diag(sqrt(D)) .mult. transpose(V) - R = V .mult. diag(D ** (-0.5_dp)) .mult. transpose(V) .mult. e123 - - call print('S:', PRINT_VERBOSE); call print(S, PRINT_VERBOSE) - call print('R:', PRINT_VERBOSE); call print(R, PRINT_VERBOSE) - - RtE = transpose(R) .mult. e123 - - ! Check for permutations - which way does x point? - if (RtE(2,1) > RtE(1,1) .and. RtE(2,1) > RtE(3,1)) then - ! y direction - R = rotXYZ .mult. R - else if (RtE(3,1) > RtE(1,1) .and. RtE(3,1) > RtE(2,1)) then - ! z direction - R = transpose(rotXYZ) .mult. R - end if - - SS = transpose(R) .mult. S .mult. R - - call print('R:', PRINT_VERBOSE); call print(R, PRINT_VERBOSE) - call print('RtE:', PRINT_VERBOSE); call print(RtE, PRINT_VERBOSE) - call print('RtSR:', PRINT_VERBOSE); call print(SS, PRINT_VERBOSE) - - ! Strain(1:6) = (/eps11,eps22,eps33,eps23,eps13,eps12/) - strain(1) = SS(1,1) - 1.0_dp - strain(2) = SS(2,2) - 1.0_dp - strain(3) = SS(3,3) - 1.0_dp - strain(4) = 2.0_dp*SS(2,3) - strain(5) = 2.0_dp*SS(1,3) - strain(6) = 2.0_dp*SS(1,2) - else - strain = 0.0_dp - S = 0.0_dp - S(1,1) = 1.0_dp; S(2,2) = 1.0_dp; S(3,3) = 1.0_dp - end if - - stress = C .mult. strain - - ! Now stress(1:6) = (/sig11,sig22,sig33,sig23,sig13,sig12/) - - sig = 0.0_dp - sig(1,1) = stress(1) - sig(2,2) = stress(2) - sig(3,3) = stress(3) - - sig(1,2) = stress(6) - sig(1,3) = stress(5) - sig(2,3) = stress(4) - - sig(2,1) = stress(6) - sig(3,1) = stress(5) - sig(3,2) = stress(4) - - von_mises_stress(i) = sqrt(0.5*((stress(1) - stress(2))**2.0_dp + & - (stress(2) - stress(3))**2.0_dp + & - (stress(3) - stress(1))**2.0_dp)) - - von_mises_strain(i) = sqrt(strain(6)**2.0_dp + strain(5)**2.0_dp + & - strain(4)**2.0_dp + & - 1.0_dp/6.0_dp*((strain(2) - strain(3))**2.0_dp + & - (strain(1) - strain(3))**2.0_dp + & - (strain(1) - strain(2))**2.0_dp)) - - RSigRt = R .mult. sig .mult. transpose(R) - - call symmetrise(RSigRt) - call diagonalise(RSigRt,D,SigEvecs) - - ! Return strain in such a way that vector (S_xx_sub1, S_yy_sub1, S_zz_sub1, S_yz, S_xz, S_xy) - ! yields (sig_xx, sig_yy, sig_zz, sig_yz, sig_xz, sig_xy) when multiplied by C_ij matrix - ! i.e. we return (e1,e2,e3,e4,e5,e6) according to compressed Voigt notation. - S_xx_sub1(i) = S(1,1) - 1.0_dp - S_yy_sub1(i) = S(2,2) - 1.0_dp - S_zz_sub1(i) = S(3,3) - 1.0_dp - S_yz(i) = 2.0_dp*S(2,3) - S_xz(i) = 2.0_dp*S(1,3) - S_xy(i) = 2.0_dp*S(1,2) - - Sig_xx(i) = RSigRt(1,1) - Sig_yy(i) = RSigRt(2,2) - Sig_zz(i) = RSigRt(3,3) - Sig_yz(i) = RSigRt(2,3) - Sig_xz(i) = RSigRt(1,3) - Sig_xy(i) = RSigRt(1,2) - - SigEval1(i) = D(1) - SigEval2(i) = D(2) - SigEval3(i) = D(3) - - SigEvec1(:,i) = SigEvecs(:,1) - SigEvec2(:,i) = SigEvecs(:,2) - SigEvec3(:,i) = SigEvecs(:,3) - - ! energy density in eV/A**3, from u = 1/2*stress*strain - energy_density(i) = 0.5_dp*( (/Sig_xx(i), Sig_yy(i), Sig_zz(i), Sig_yz(i), Sig_xz(i), Sig_xy(i) /) .dot. & - (/S_xx_sub1(i), S_yy_sub1(i), S_zz_sub1(i), S_yz(i), S_xz(i), S_xy(i) /) )/EV_A3_IN_GPA - - end do - - call print('Processed '//ngood//' of '//at%N//' atoms.', PRINT_VERBOSE) - deallocate(dist, ndiff) - - end subroutine elastic_fields - - -end module elasticity_module diff --git a/src/Utils/force_machine_learning_module.f95 b/src/Utils/force_machine_learning_module.f95 deleted file mode 100644 index 5aadf3466e..0000000000 --- a/src/Utils/force_machine_learning_module.f95 +++ /dev/null @@ -1,1256 +0,0 @@ -! This Fortran95 Code/Module performs Machine Learning Force prediction based on XYZ structural Files; -! Sorting/Selecting Algorithms are used to construct sub training database during heavy machine learning task; -! Database can be updated according to an error_threshold, e.g. pred_err; -! Internal Vector representation is used for describing the atomic structures; -! Any issues or bugs regarding this code please contact Zhenwei Li (zhenwei.li@unibas.ch) -! Reference article : Molecular Dynamics with On-the-Fly Machine Learning of Quantum-Mechanical Forces, Zhenwei Li, James Kermode, Alessandro De Vita, PRL, 114, 096405 (2015) -module force_machine_learning_module - - use libAtoms_module - use potential_module - implicit none - - type optimise_likelihood - logical use_qr - real(dp), dimension(:,:), pointer :: distance_matrix, covariance_matrix, force_covariance_matrix, t - endtype optimise_likelihood - -public :: write_distance -interface write_distance - module procedure write_distance_file - module procedure write_distance_file_real -end interface - - contains - - function likelihood(x,am_data) - real(dp), dimension(:) :: x - character(len=1), dimension(:), optional :: am_data - real(dp) :: likelihood - - type(optimise_likelihood) :: am - real(dp) :: sigma_error, sigma_covariance - real(dp), dimension(:,:), allocatable :: ICF - integer :: i - type(LA_Matrix) :: LA_covariance - - am = transfer(am_data,am) - sigma_error = x(1) - sigma_covariance = x(2) - - am%covariance_matrix = exp(-0.5_dp * am%distance_matrix/sigma_covariance**2) - do i = 1, size(am%covariance_matrix,1) - am%covariance_matrix(i,i) = am%covariance_matrix(i,i) + sigma_error**2 - enddo - - LA_covariance = am%covariance_matrix - allocate(ICF(size(am%covariance_matrix,1),size(am%covariance_matrix,1))) - - if (am%use_qr) then - call Matrix_QR_Solve(LA_covariance,am%force_covariance_matrix,ICF) - else - call Matrix_Solve(LA_covariance,am%force_covariance_matrix,ICF) - end if - - likelihood = 1.5_dp * LA_Matrix_LogDet(LA_covariance) + 0.5_dp * trace(ICF) -! write(*,*) "DEBUG Likelihood value: ", likelihood - - call finalise(LA_covariance) - if(allocated(ICF)) deallocate(ICF) - - endfunction likelihood - - function dlikelihood(x,am_data) - real(dp), dimension(:) :: x - character(len=1), dimension(:), optional :: am_data - real(dp), dimension(size(x)) :: dlikelihood - - type(optimise_likelihood) :: am - real(dp) :: sigma_error, sigma_covariance - real(dp), dimension(:,:), allocatable :: ICF, IC, ICDCDS, DCDS - integer :: i, n - type(LA_Matrix) :: LA_covariance - - am = transfer(am_data,am) - sigma_error = x(1) - sigma_covariance = x(2) - - n = size(am%covariance_matrix,1) - allocate(ICF(n,n),DCDS(n,n),IC(n,n),ICDCDS(n,n)) - - am%covariance_matrix = exp(-0.5_dp * am%distance_matrix/sigma_covariance**2) - DCDS = am%covariance_matrix * am%distance_matrix / sigma_covariance**3 - - do i = 1, n - am%covariance_matrix(i,i) = am%covariance_matrix(i,i) + sigma_error**2 - enddo - - LA_covariance = am%covariance_matrix - - if (am%use_qr) then - call Matrix_QR_Solve(LA_covariance,am%force_covariance_matrix,ICF) - call Matrix_QR_Solve(LA_covariance,DCDS,ICDCDS) - call LA_Matrix_QR_Inverse(LA_covariance,IC) - else - call Matrix_Solve(LA_covariance,am%force_covariance_matrix,ICF) - call Matrix_Solve(LA_covariance,DCDS,ICDCDS) - call LA_Matrix_Inverse(LA_covariance,IC) - end if - - dlikelihood(1) = sigma_error * (3*trace(IC) - sum(IC*ICF) ) - dlikelihood(2) = 1.5_dp * trace(ICDCDS) - 0.5_dp * sum(ICDCDS*transpose(ICF)) - ! write(*,*) "DEBUG dlikelihood", dlikelihood(1)**2, dlikelihood(2)**2 - - call finalise(LA_covariance) - if(allocated(ICF)) deallocate(ICF) - if(allocated(DCDS)) deallocate(DCDS) - if(allocated(IC)) deallocate(IC) - if(allocated(ICDCDS)) deallocate(ICDCDS) - - endfunction dlikelihood - - function weight_neighbour(r, r0, m, weight_index) - - real(dp), intent(in) :: r, r0, m - integer, intent(in), optional :: weight_index - integer :: selector - real(dp) :: weight_neighbour, kernel - - if (present(weight_index)) then - selector=weight_index - else - selector=0 - endif - - SELECT CASE (selector) - CASE (0) - weight_neighbour = exp(-((r/r0)**m)) /r - CASE (1) - weight_neighbour = exp(-((r/r0)**m)) - !CASE (2) - ! kernel=sqrt(m*2_dp)*(r/r0) - ! weight_neighbour= (1_dp/GAMMA(m) / (2_dp**(m-1)) ) * (kernel**m) * BESYN(int(m), kernel) - END SELECT - - end function weight_neighbour - - function ionic_charge(z) - ! no partial charges - integer :: i, ionic_charge - integer :: x(8) - integer, allocatable :: i_index(:) - real(dp), allocatable :: xx(:) - integer, intent(in) :: z - ! - x=[0, 2, 10, 18, 36, 64, 86, 118] - allocate(xx(size(x))) - allocate(i_index(size(x))) - do i=1, size(x) - i_index(i) = i - xx(i) = 1.0_dp*abs(x(i) - z) - enddo - call heap_sort(xx,i_data=i_index) - ionic_charge = z- x(i_index(1)) - ! - deallocate(xx, i_index) - endfunction ionic_charge - -function char_weight(z1, z2, do_atz_index) - integer, intent(in) :: z1, z2 - integer, intent(in), optional :: do_atz_index - real(dp) :: char_weight - integer :: selector - - if (present(do_atz_index) ) then - selector=do_atz_index - else - selector=0 - endif - -select case (selector) -case (0) - char_weight=1.0_dp -case (1) - char_weight=real(z1*z2, dp) -case (2) - char_weight=real(ionic_charge(z1)*ionic_charge(z2), dp) -end select -! -endfunction char_weight - -! -function internal_vector(at, r0, m, species_number, n_center_atom, weight_index, do_atz_index) - real(dp) :: internal_vector(3), delta_r(3), delta_r_len - real(dp), intent(in) :: r0, m - type(Atoms), intent(in) :: at - integer, intent(in), optional :: weight_index, do_atz_index - integer, intent(in) :: species_number - integer :: i, j, n_center_atom - ! - internal_vector = 0.0_dp - do i=1, n_neighbours(at, n_center_atom) - j = neighbour(at, n_center_atom, i, distance=delta_r_len, diff=delta_r) - ! - if ((at%z(j) .eq. species_number) .or. (species_number.eq.0)) then - internal_vector = internal_vector + delta_r * weight_neighbour(delta_r_len, r0, m, weight_index) * char_weight(at%z(j), at%z(n_center_atom), do_atz_index=do_atz_index) - endif - enddo - ! -endfunction internal_vector - - subroutine load_iv_params(data_dir, r_grid, m_grid, species, k, add_vector, n_data) - - ! reads r and m from iv_params file. The first line must contain the number - ! of internal vector, and the following lines should be formatted in two columns - ! with commas as spacers (a common csv file) - character(STRING_LENGTH), intent(in) :: data_dir - real(dp), dimension(:), intent(out), allocatable :: r_grid, m_grid - integer, dimension(:), intent(out), allocatable :: species - integer :: i, m - integer, intent(out) :: k, add_vector - integer, intent(out), optional :: n_data - - open (unit=22, file=trim(data_dir)//'grid.dat', status='old', action='read') - read(22,*) k, add_vector, m - - call print("Number of iv: "//k) - if (present(n_data)) n_data=m - if (.not. allocated(r_grid)) allocate(r_grid(k)) - if (.not. allocated(m_grid)) allocate(m_grid(k)) - if (.not. allocated(species)) allocate(species(k)) - - call print(" Reading internal vectors parameters from file "//trim(data_dir)//"grid.dat") - - do i=1, k - read(22,*) r_grid(i), m_grid(i), species(i) - call print("Vector "//i//" : "//r_grid(i)//" "//m_grid(i)//" "//species(i)) - end do - close(22) - - end subroutine load_iv_params - - subroutine write_iv_params(data_dir, r_grid, m_grid, species, k_in, add_vector, n_data) - character(STRING_LENGTH), intent(in) :: data_dir - real(dp), dimension(:), intent(in) :: r_grid, m_grid - integer, dimension(:), intent(in) :: species - integer :: i - integer, intent(in) :: k_in, n_data, add_vector - - open (unit=22, status='replace', file=trim(data_dir)//'grid.dat', form='FORMATTED') - - write(22, *) k_in, add_vector, n_data - do i=1, k_in - write(22, *) r_grid(i), m_grid(i), species(i) - enddo - close(unit=22) - - end subroutine write_iv_params - - function cov_dij(sigma_cov, dist, func_type) - real(dp), intent(in) :: sigma_cov, dist - real(dp) :: cov_dij, d_sq - integer, intent(in), optional :: func_type - integer :: selector - - d_sq = dist - - if (present(func_type)) then - selector=func_type - else - selector=0 - endif - - SELECT CASE (selector) - CASE (0) - cov_dij = exp(-0.5_dp*d_sq/sigma_cov**2) - CASE (1) - cov_dij = sqrt(d_sq) - CASE (2) - cov_dij = d_sq - CASE (3) - cov_dij = (sqrt(d_sq))**3 - CASE (4) - cov_dij = d_sq**2 - END SELECT - - end function cov_dij - - function cov(feature_matrix1, feature_matrix2, bent_space1, bent_space2, iv_weights, sigma_cov, distance, func_type) - - real(dp), intent(in) :: feature_matrix1(:,:), feature_matrix2(:,:), bent_space1(:,:), bent_space2(:,:), iv_weights(:), sigma_cov - real(dp), intent(out), optional :: distance - real(dp) :: cov, d_sq - integer, intent(in), optional :: func_type - integer :: i, k, selector - - k = size(feature_matrix1(:,1)) - d_sq = 0.0_dp - do i=1, k - d_sq = d_sq + (distance_in_bent_space(feature_matrix1(i,:), feature_matrix2(i,:), bent_space1, bent_space2))**2 / (2.0_dp * (iv_weights(i)**2)) - enddo - - ! norm with the dimensionality k of the Internal Space - d_sq = d_sq/real(k,dp) - - if (present(distance)) distance = d_sq ! N.B. distance squared - - if (present(func_type)) then - selector=func_type - else - selector=0 - endif - - SELECT CASE (selector) - CASE (0) - cov = exp(-0.5_dp*d_sq / sigma_cov**2) - CASE (1) - cov = sqrt(d_sq) - CASE (2) - cov = d_sq - CASE (3) - cov = (sqrt(d_sq))**3 - CASE (4) - cov = d_sq**2 - CASE (5) ! Laplace - cov = exp(- sqrt(d_sq) / sigma_cov) - END SELECT - - endfunction cov - - - function distance_in_bent_space(vect1, vect2, bent_space1, bent_space2) - - real(dp), intent(in) :: vect1(3), vect2(3), bent_space1(:,:), bent_space2(:,:) - real(dp) :: distance_in_bent_space - - distance_in_bent_space = norm( (bent_space1 .mult. vect1) - (bent_space2 .mult. vect2)) - - endfunction distance_in_bent_space - -! function eval_lhood(covariance_matrix,FCM) -! real(dp), dimension(:,:), intent(in) :: covariance_matrix, FCM -! real(dp) :: eval_lhood -! real(dp), dimension(:,:), allocatable :: ICF -! type(LA_Matrix) :: LA_covariance - -! LA_covariance = covariance_matrix -! allocate(ICF(size(FCM,1),size(FCM,1))) - -! call Matrix_QR_Solve(LA_covariance, FCM, ICF) - !write(*,*) "DEBUG ICF: ", ICF - -! eval_lhood = 1.5_dp * LA_Matrix_LogDet(LA_covariance) + 0.5_dp * trace(ICF) - -! call finalise(LA_covariance) -! if(allocated(ICF)) deallocate(ICF) - -! endfunction eval_lhood - - - subroutine matrix_statistics(in_matrix, max_value, mean_value, deviation_value, n) - - real(dp), intent(in) :: in_matrix(:,:) - integer, intent(in) :: n - integer :: i, j, t - real(dp), intent(out) :: max_value, mean_value, deviation_value - real(dp), allocatable :: data_array(:) - - allocate(data_array(n*(n-1)/2)) - - t=0 - do i=1, n - do j=1,n - if (i>j) then - t=t+1 - data_array(t) = in_matrix(i,j) - endif - enddo - enddo - mean_value = sum(data_array)/real(size(data_array),dp) - max_value = maxval(data_array) - - deviation_value = 0.0_dp - do i=1, size(data_array) - deviation_value = deviation_value + ( (data_array(i) - mean_value)**2 ) - enddo - deviation_value = sqrt(deviation_value/real(size(data_array),dp)) - - deallocate(data_array) - - end subroutine matrix_statistics - - - subroutine sorting_configuration(matrix_predict, matrix_data, matrix_predict_norm, matrix_data_norm, sigma, distance_confs_unsorted, distance_index) - - ! returns a list of indexes corresponding to the configurations ordered according to their distance to target - real(dp), intent(in) :: matrix_predict(:,:), matrix_data(:,:,:), matrix_predict_norm(:,:), matrix_data_norm(:,:,:), sigma(:) - real(dp), intent(inout) :: distance_confs_unsorted(:) - real(dp), allocatable :: distance_confs(:) ! only for sorting - integer, intent(inout) :: distance_index(:) - real(dp) :: cov_tmp - integer :: i - - call system_timer('Distance Calculation for sorting') - - !$omp parallel default(none) shared(matrix_data, matrix_data_norm, matrix_predict, matrix_predict_norm, sigma, distance_confs_unsorted, distance_index) private(i, cov_tmp) - !$omp do - do i=1, size(matrix_data(1,1,:)) - cov_tmp = cov(matrix_predict, matrix_data(:,:,i), matrix_predict_norm, matrix_data_norm(:,:,i), sigma, 1.0_dp, distance=distance_confs_unsorted(i)) - distance_index(i) = i - enddo - !$omp end parallel - - call system_timer('Distance Calculation for sorting') - - call system_timer('Sorting the DATABASE') - - allocate(distance_confs(size(distance_confs_unsorted))) - distance_confs = distance_confs_unsorted - call heap_sort(distance_confs, i_data=distance_index) - call system_timer('Sorting the DATABASE') - deallocate(distance_confs) - end subroutine sorting_configuration - - - subroutine real_expection_sampling_components(ivs_direction_matrix, internal_component_matrix, target_force) - - real(dp), intent(in) :: ivs_direction_matrix(:,:), internal_component_matrix(:) - real(dp), intent(out) :: target_force(3) - real(dp), allocatable :: force_array(:,:) - real(dp) :: const=0.1_dp, f_deviv(3), converting_matrix(3,3), converting_matrix_inv(3,3), force_value_matrix(3) - integer :: i, j, t, f_counter, s - - f_counter=0 - - s=size(internal_component_matrix) ! the number of internal directions, equavalent to 'k' - allocate(force_array(s*(s-1)*(s-2)/6,3)) ! number of combinations: C_{k}^{3} - force_array=0.0_dp - - do i=1, s-2 - do j=i+1, s-1 - do t=j+1, s - f_counter = f_counter + 1 - converting_matrix(:,1)=ivs_direction_matrix(i,:) - converting_matrix(:,2)=ivs_direction_matrix(j,:) - converting_matrix(:,3)=ivs_direction_matrix(t,:) - force_value_matrix(1)=internal_component_matrix(i) - force_value_matrix(2)=internal_component_matrix(j) - force_value_matrix(3)=internal_component_matrix(t) - - if ((norm(converting_matrix(:,1) .cross. converting_matrix(:,2)) > const) .and. (norm(converting_matrix(:,2) & - .cross. converting_matrix(:,3)) > const) .and. (norm(converting_matrix(:,3) .cross. converting_matrix(:,1)) > const)) then - f_counter = f_counter + 1 - - write(*,*) "the converting matrix", converting_matrix - call inverse_svd_threshold(converting_matrix, 10.0_dp, result_inv=converting_matrix_inv) - force_array(f_counter,:)=transpose(converting_matrix_inv) .mult. force_value_matrix - write(*,*) "the inverse matrix : ", converting_matrix_inv - write(*,*) "the number of sequence of ivs:", i, j, t - call print("Target Force Distribution : "//force_array(f_counter,1)//" "//force_array(f_counter,2)//" "//force_array(f_counter,3)) - endif - enddo - enddo - enddo - - do i=1, 3 - target_force(i) = sum(force_array(:,i)) / real(f_counter, dp) - enddo - f_deviv=0.0_dp - do j=1, 3 - do i=1,f_counter - f_deviv(j) = f_deviv(j) + (force_array(i,j)-target_force(j))**2 - enddo - enddo - do j=1, 3 - f_deviv(j) = sqrt(f_deviv(j)/ real(f_counter,dp)) - enddo - write(*,*) "deviation of the prediction: ", f_deviv - deallocate(force_array) - end subroutine real_expection_sampling_components - - subroutine internal_dimension_mark(in_matrix, TOL, mark) - - real(dp), intent(in) :: in_matrix(:,:), TOL - integer, intent(out) :: mark(3) - integer :: i - - mark(:)=1 - do i=1,3 - !if (sum(abs(in_matrix(:,i))/size(in_matrix(:,1)))< TOL) then ! using Mean as Indicator - if ( maxval(abs(in_matrix(:,i))) < TOL ) then ! using Max as indicator - call print("dimension index: "//maxval(abs(in_matrix(:,i))) ) - mark(i)=0 - call print('the '//i//'-th dimension is zero') - endif - enddo - - end subroutine internal_dimension_mark - - - subroutine rank_lowered_inverse(in_matrix, out_inv) - - real(dp), intent(in) :: in_matrix(3,3) - real(dp), intent(out) :: out_inv(3,3) - real(dp) :: a, b, c, d, m_factor - - a=in_matrix(1,1) - b=in_matrix(1,2) - c=in_matrix(2,1) - d=in_matrix(2,2) - m_factor = a*d-b*c - out_inv=0.0_dp - - out_inv(1,1) = d/m_factor - out_inv(1,2) = -b/m_factor - out_inv(2,1) = -c/m_factor - out_inv(2,2) = a/m_factor - - end subroutine rank_lowered_inverse - - subroutine do_optimise_likelihood(sigma_error, sigma_covariance) - - type(optimise_likelihood) :: am_likelihood - logical :: use_qr - integer :: am_data_size - character(len=1), dimension(1) :: am_mold - character(len=1), allocatable :: am_data(:) - real(dp) :: x_sigma(2), covariance_tol - real(dp), intent(inout) :: sigma_error, sigma_covariance - ! real(dp), dimension(:,:), target :: distance_matrix, covariance_matrix, force_covariance_matrix - - - covariance_tol = 1.0e-2 - use_qr=.true. - -! am_likelihood%use_qr = use_qr ! filling the am_likelihood container -! am_likelihood%distance_matrix => distance_matrix -! am_likelihood%covariance_matrix => covariance_matrix -! am_likelihood%force_covariance_matrix => force_covariance_matrix - - am_data_size = size(transfer(am_likelihood,am_mold)) - allocate(am_data(am_data_size)) - am_data = transfer(am_likelihood,am_mold) ! pouring the content of am_likelihood into am_data - - ! Testing the implementation of likelihood and dlikelihood. - if(.false.) then - call print('starting test gradient') - call verbosity_push(PRINT_VERBOSE) - write (*,*) test_gradient((/sigma_error,sigma_covariance/),likelihood,dlikelihood,data=am_data) - call verbosity_pop() - endif - call print_title('likelihood optimisation') - - if (use_qr) then - call print('doing likelihood optimisation with QR decomposition') - else - call print('doing likelihood optimisation with Cholesky decomposition') - end if - x_sigma = (/sigma_error, sigma_covariance/) ! starting points for the values - ! n = minim( x_sigma, likelihood, dlikelihood, method='cg', convergence_tol=covariance_tol, max_steps = 100, data=am_data) - ! x_sigma is the input vector, lh is the target function to minimise (using dlh), using conjugate gradient, with that tolerance, - ! with that max number of steps, and using the data contained in am_data - write(*,*) "Fixed LIKELIHOOD", likelihood(x_sigma, am_data), dlikelihood(x_sigma, am_data) - deallocate(am_data) - - sigma_error = x_sigma(1) - sigma_covariance = x_sigma(2) ! return the values of sigma_error and sigma_covariance after the optimisation - call print('Optimised hypers. ERROR = '//sigma_error//' COVARIANCE = '//sigma_covariance) - - end subroutine do_optimise_likelihood - -subroutine sigma_factor_from_single_dimension(ivs_set, sigma, print_verbosity, TOL_REAL, data_dir) - ! calculation normalisation factor on IV_i - integer :: t, i, j, n, k - real(dp) :: dist_primitive, distance_ivs_stati, feature_len - real(dp), intent(inout) :: sigma(:) -real(dp), allocatable :: distance_ivs(:,:), mean_value(:), max_value(:), deviation_value(:), ivs_set_norm(:,:,:) - real(dp), intent(in) :: ivs_set(:,:,:), TOL_REAL - logical, intent(in) :: print_verbosity - character(STRING_LENGTH),intent(in) :: data_dir - - n=size(ivs_set(1,1,:)) - k=size(ivs_set(:,1,1)) -allocate(ivs_set_norm(k,3,n)) - - do j=1, n - do t=1, k -feature_len=norm(ivs_set(t,:,j)) - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - call print("WARNING: Numerical Limit in getting the unit direction of IVs : Generating sigma.dat") - endif - ivs_set_norm(t,:,j) = ivs_set(t,:,j)/feature_len - enddo - enddo - -allocate(distance_ivs(n,n), mean_value(k), max_value(k), deviation_value(k)) - - call system_timer('Getting Hyper-parameters from the DATABASE') - - dist_primitive=0.0_dp - do t = 1, k - do i = 1, n - do j=1, n -distance_ivs(i,j) = distance_in_bent_space(ivs_set(t,:,i), ivs_set(t,:,j), ivs_set_norm(:,:,i), ivs_set_norm(:,:,j)) - if ((i>j) .and. (print_verbosity)) call print("Dimensional Distance : "//distance_ivs(i, j)//" dimension : "//t) - enddo ! i - enddo ! j - -call matrix_statistics(distance_ivs, max_value(t), mean_value(t), deviation_value(t), n) - call print("Statistics max value: "//max_value(t)//" mean value: "//mean_value(t)//" deviation_value: "//deviation_value(t)) - dist_primitive = dist_primitive + (mean_value(t)/deviation_value(t)/2.0_dp)**2 - enddo - -dist_primitive = sqrt(dist_primitive / real(k,dp)) - call print("primitive_distance : "//dist_primitive) - - if (print_verbosity) then - ! norm distance with hyperparameters derived from statistics analysis - do i=1,n - do j=1,n - distance_ivs_stati = 0.0_dp - do t=1, k - distance_ivs_stati = distance_ivs_stati + & - (distance_in_bent_space(ivs_set(t,:,i), ivs_set(t,:,j), ivs_set_norm(:,:,i), ivs_set_norm(:,:,j))/2.0_dp/deviation_value(t))**2 - enddo - distance_ivs_stati = sqrt(distance_ivs_stati/real(k,dp)) ! to take the square root and get a norm distance - if (i>j) call print("Normalised Dimensional Distance : "//distance_ivs_stati//" Normalised Value : "//distance_ivs_stati/dist_primitive) - enddo - enddo - endif ! print_verbosity - - ! to write the derived sigma vector into file "sigma.dat" for later use - ! sigma array is derived from the standard deviation on each single dimension of the IVs space - sigma = deviation_value - open(unit=1, status='replace', file=trim(data_dir)//'sigma.dat') - write(1,*) sigma - close(unit=1) - - deallocate(distance_ivs, mean_value, max_value, deviation_value, ivs_set_norm) - call system_timer('Getting hyper-parameters from the DATABASE') -end subroutine sigma_factor_from_single_dimension - -subroutine write_distance_file_real(d, data_dir) - - character(STRING_LENGTH), intent(in) :: data_dir - real(dp), intent(in) :: d - -! OPEN(2, status='replace',file=trim(data_dir)//'Dist.dat', form='UNFORMATTED') -! !write(2) d -! close(2) - call fwrite_array_d(1, (/0.0_dp/), trim(data_dir)//'Dist.dat') -end subroutine write_distance_file_real - -!subroutine refresh_info(data_dir, f_proj, f_norm, ivs_set) -! -! character(STRING_LENGTH), intent(in) :: data_dir -! real(dp), intent(in) :: f_proj(:), ivs_set(:,:) -! real(dp), intent(in) :: f_norm -! integer :: i -! call write_distance(0.0_dp, data_dir) ! always refresh the Dist.dat whenever print_data -! -! OPEN(2,status='replace',file=trim(data_dir)//'Force.dat', form='UNFORMATTED') -! OPEN(3,status='replace',file=trim(data_dir)//'IV.dat', form='UNFORMATTED') -! -! write(2) f_proj(:), f_norm -! -! do i=1,3 -! write(3) ivs_set(:,i) -! enddo -! close(2) -! close(3) -!end subroutine refresh_info - -subroutine write_distance_file(distance_confs_unsorted, data_dir) - - character(STRING_LENGTH), intent(in) :: data_dir - real(dp), intent(in), dimension(:) :: distance_confs_unsorted - - call system_timer('Writing Distance File : Trivial Usually') -! OPEN(2, status='old',file=trim(data_dir)//'Dist.dat', form='UNFORMATTED', position='APPEND') -! write(2) distance_confs_unsorted(:) -! close(2) - call fwrite_array_d(size(distance_confs_unsorted), distance_confs_unsorted(:), trim(data_dir)//'Dist.dat') - call system_timer('Writing Distance File : Trivial Usually') - -end subroutine write_distance_file - -subroutine read_distance_file(distance_matrix, data_dir) - - character(STRING_LENGTH), intent(in) :: data_dir - real(dp), intent(inout), dimension(:, :) :: distance_matrix - integer :: i, j - - call system_timer('Read Pair Distance and Bulid Covariance') - ! OPEN(2,status='old',file=trim(data_dir)//'Dist.dat',form='UNFORMATTED') - call fread_array_d(1, distance_matrix(1,1:1), trim(data_dir)//'Dist.dat') - - do i=2, size(distance_matrix(:,1)) - call fread_array_d(i-1, distance_matrix(i,:(i-1)), trim(data_dir)//'Dist.dat') - ! read(2) distance_matrix(i,:(i-1)) ! for row <= column - distance_matrix(i,i)=0.0_dp - enddo - - do i=1, size(distance_matrix(:,1)) - do j= i, size(distance_matrix(:,1)) - distance_matrix(i,j) = distance_matrix(j,i) ! for row > column - enddo - enddo - ! close(2) - call system_timer('Read Pair Distance and Bulid Covariance') - -end subroutine read_distance_file -! -function fgp_calc(at_in) - - type(Atoms) :: at_in, fgp_calc - type(Potential) :: pot - type(Dictionary) :: params - real(dp) :: r_cut, feature_len, thresh, sigma_error, error_ls, error_gp, error_gp_sq, time, error_ls_max - real(dp) :: sigma_covariance, sigma_cov, dist_shift_factor, dim_tol, error_frame, force_magntd_pred, dist - real(dp), dimension(:), allocatable :: r_grid, m_grid, sigma, covariance_pred,force_magntd_data,force_magntd_data_select - real(dp), dimension(:), allocatable :: force_proj_test, force_proj_ivs_pred, distance_confs_unsorted - real(dp), parameter :: TOL_REAL=1e-7_dp, SCALE_IVS=100.0_dp - real(dp) :: force(3), variance_xyz(3), feature_inner_matrix(3,3), feature_inv(3,3), kappa - real(dp), dimension(:,:,:), allocatable :: ivs_set_norm, ivs_set, ivs_set_pred, nearest_data - real(dp), dimension(:,:), allocatable :: force_proj_ivs, force_proj_ivs_select, inv_covariance, out_u, out_vt, geometry_matrix - real(dp), dimension(:,:), allocatable, target :: covariance, distance_matrix, distance_matrix_dij, force_covariance_matrix, covariance_tiny - real(dp), dimension(:,:), allocatable :: ivs_set_norm_pred, ivs_set_norm_pred_t - real(dp), dimension(:,:), pointer :: force_ptr, force_ptr_mm, force_ptr_tff - real(dp), dimension(:), pointer :: pred_err - integer :: i,j, k, n, t, n_center_atom, error - integer :: add_vector, n_teach, func_type, weight_index, temp_integer, ii, do_atz_index - integer :: local_ml_optim_size, dimension_mark(3) - integer, dimension(:), allocatable :: distance_index, mark_zero_ivs, species - logical :: do_gp, do_sigma, least_sq, do_svd, print_verbosity, do_insert, do_dynamic_x, write_data_dij, read_data_dij - character(STRING_LENGTH) :: data_dir - - ! set by default exc. at_in - call initialise(params) - call param_register(params, 'r_cut', '8.0', r_cut, "the cutoff radius for the spherical atomic environment") - call param_register(params, 'thresh', '10.0', thresh, "the threshold for doing the Singular Value Decompostion of the Covariance Matrix") - call param_register(params, 'weight_index', '0', weight_index, "Type of weight function in deriving IVs") - call param_register(params, 'sigma_error', '0.05', sigma_error, "the noise assumed on the teaching data") - call param_register(params, 'func_type', '0', func_type, "which kernel function is used to build the covariance matrix") - call param_register(params, 'do_gp', 'T', do_gp, "true for doing a gaussian processes") - call param_register(params, 'n_teach', '1000', n_teach, "the number of relevant confs you would like to do machine learning with") - call param_register(params, 'do_sigma', 'F', do_sigma, "set true to print out the distance on every single dimension of the IVs space") - call param_register(params, 'do_dynamic_x', 'F', do_dynamic_x, "true for updating sigma.dat every test configuration based on nearest data points") - !call param_register(params, 'top_teach', 'T', top_teach, "only the first configuration is considered when doing teaching") - call param_register(params, 'least_sq', 'T', least_sq, "if true, the internal force components will be tranformed to real force using least squares") - call param_register(params, 'do_svd', 'F', do_svd, "if true, doing inverting by SVD") - call param_register(params, 'sigma_cov', '1.0', sigma_cov, "correlation length for pairs of data points") - call param_register(params, 'dist_shift_factor', '0.2', dist_shift_factor, "distance shifted with a given factor") - ! optional for updating sigma_cov - call param_register(params, 'do_atz_index', '0', do_atz_index, "0: charge-weight disabled; 1: using at%Z, 2: using ionic charge instead") - call param_register(params, 'dim_tol', '0.00005', dim_tol, "threshold for determing the dimensionality of the group of IVs") - !call param_register(params, 'test_file', 'test.xyz', test_file, "file to read the testing configurations from") - call param_register(params, 'data_dir', './info/', data_dir, "the directory where data files locate") - call param_register(params, 'do_insert', 'F', do_insert, "INsert any addiitional vector as force_plus") - call param_register(params, 'print_verbosity', 'F', print_verbosity, "if true, print out verbosity stuff") - !call param_register(params, 'out_file', 'out.xyz', out_file, "output configuration file containing the predicted forces") - call param_register(params, 'read_data_dij', 'F', read_data_dij, 'whether or not writing the distance file') - call param_register(params, 'write_data_dij', 'F', write_data_dij, 'whether or not reading the pair distnace matrix') - call param_register(params, 'local_ml_optim_size', '0', local_ml_optim_size, "Optimise sigma_error and sigma_cov using local_ml_optim_size LS confs. If 0, no optimisation is performed") - - if (.not. param_read_args(params, task="fgp command line params")) then - call print("Usage: fgp [options]") - call system_abort("Confused by command line arguments") - end if - - call print_title('params') - call param_print(params) - call finalise(params) - - call print_title('READING TEACHING INFORMATION') - call system_timer('Collecting Information From Files') - call load_iv_params(data_dir, r_grid, m_grid, species, k, add_vector, n_data=n) - k = k + add_vector ! adding the Classical Force Vectors - - allocate(force_proj_ivs(k,n)) - allocate(ivs_set(k,3,n)) - allocate(ivs_set_norm(k,3,n)) - allocate(force_magntd_data(n)) - allocate(sigma(k)) - - OPEN(2,status='old',file=trim(data_dir)//'Force.dat',form='UNFORMATTED') - OPEN(3,status='old',file=trim(data_dir)//'IV.dat',form='UNFORMATTED') - - do t=1, n - read(2) force_proj_ivs(:, t), force_magntd_data(t) - !write(*,*) "%", force_proj_ivs(:, t), force_magntd_data(t) - do i=1, 3 - read(3) ivs_set(:,i,t) - enddo - !write(*,*) "$", ivs_set(:,:,t) - enddo - close(2) - close(3) - - ! calculating the normalised vectors - do t=1, n - do j=1, k - feature_len = norm(ivs_set(j,:, t)) - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - call print("WARNING: TEACHING, encountered the numerical limit in getting the unit direction of IVs") - endif - ivs_set_norm(j,:,t)=ivs_set(j,:, t)/feature_len - enddo - enddo - - ! reading sigma file - open(unit=1, status='old', file=trim(data_dir)//'sigma.dat', form='formatted') - read(1, *) sigma - close(unit=1) - call system_timer('Collecting Information From Files') - call print('sigma is: '//sigma) - -! -if (n_teach > n) then - n_teach = n - call print("the Actual Number of Configs for Prediction: "//n_teach) - call print("WARNNING: Trying to select more configurations than the database has") -endif -! -allocate(covariance_pred(n_teach)) -allocate(force_proj_ivs_pred(k)) -allocate(mark_zero_ivs(k)) -allocate(geometry_matrix(3,k)) -allocate(covariance(n_teach,n_teach)) -allocate(distance_confs_unsorted(n), distance_index(n)) -if (local_ml_optim_size > 0) then -allocate(distance_matrix(local_ml_optim_size,local_ml_optim_size), force_covariance_matrix(local_ml_optim_size,local_ml_optim_size), covariance_tiny(local_ml_optim_size,local_ml_optim_size)) -endif -allocate(inv_covariance(n_teach,n_teach)) -allocate(force_proj_ivs_select(k, n_teach)) -allocate(force_magntd_data_select(n_teach)) -allocate(ivs_set_norm_pred(k,3)) -if (read_data_dij) allocate(distance_matrix_dij(n, n)) - -if (read_data_dij) then - call system_timer('Read Pair Distance and Bulid Covariance') - call read_distance_file(distance_matrix_dij(:,:), data_dir) - !write(*,*) 'Distance Read', distance_matrix_dij - call system_timer('Read Pair Distance and Bulid Covariance') -endif - - if (.not. get_value(at_in%params, 'time', time)) then - call print("TIME of FRAME : UNKOWN") - else - call print("TIME of FRAME :"//time) - endif - call add_property(at_in, 'force', 0.0_dp, n_cols=3, overwrite=.false.) ! false in case DFT force is reading in - call assign_property_pointer(at_in, 'force', ptr=force_ptr) - - ! for writing out the predicted error - call add_property(at_in, 'pred_err', 0.0_dp, n_cols=1, overwrite=.true.) - call assign_property_pointer(at_in, 'pred_err', ptr=pred_err) - - if (add_vector > 0) then - if (do_insert) then - call assign_property_pointer(at_in, 'force_plus', ptr=force_ptr_mm) - else - call Potential_Filename_Initialise(pot, args_str='IP SW', param_filename='SW.xml') - call calc(pot, at_in, args_str='force=force_mm', error=error) - call assign_property_pointer(at_in, 'force_mm', ptr=force_ptr_mm) - call finalise(pot) - endif - endif - if (add_vector>1) call assign_property_pointer(at_in, 'force_i', ptr=force_ptr_tff) - - call set_cutoff(at_in, r_cut) - call calc_connect(at_in) - - allocate(ivs_set_pred(k,3,at_in%N)) - - error_frame=0.0_dp ! for calculating the average error of the system. - - do n_center_atom=1, at_in%N ! loop over atoms in the Frame, make prediction (incl. error) - - do j=1, k ! reset the mark for zero internal vectors - mark_zero_ivs(j)=1 - enddo - - do j= 1, k-add_vector - ivs_set_pred(j,:,n_center_atom) = internal_vector(at_in, r_grid(j), m_grid(j), species(j), n_center_atom, weight_index, do_atz_index) *SCALE_IVS - call print("internal vectors ( "//r_grid(j)//" "//m_grid(j)//" "//species(j)//" ): "//ivs_set_pred(j,1,n_center_atom)//" "//ivs_set_pred(j,2,n_center_atom)//" "//ivs_set_pred(j,3,n_center_atom)) - feature_len = norm(ivs_set_pred(j,:,n_center_atom)) - - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - mark_zero_ivs(j)=0 - call print("WARNING: PREDICTION, encountered the numerical limit in getting the unit direction of IVs") - endif - - ivs_set_norm_pred(j,:) = ivs_set_pred(j,:,n_center_atom)/feature_len - enddo - - if (add_vector>0) then - do j = k-add_vector+1, k - temp_integer=k-j - select case (temp_integer) - case (0) - ivs_set_pred(j,:,n_center_atom)=force_ptr_mm(:, n_center_atom) - case (1) - ivs_set_pred(j,:,n_center_atom)=force_ptr_tff(:, n_center_atom) - end select - feature_len = norm(ivs_set_pred(j,:,n_center_atom)) - - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - mark_zero_ivs(j)=0 - call print("WARNING: PREDICTION, encountered the numerical limit in getting the unit direction of IVs") - endif - - ivs_set_norm_pred(j,:) = ivs_set_pred(j,:,n_center_atom)/feature_len - if (print_verbosity) call print("added internal vectors : "//ivs_set_pred(j,1,n_center_atom)//" "//ivs_set_pred(j,2,n_center_atom)//" "//ivs_set_pred(j,3,n_center_atom)) - enddo - endif - - - if (print_verbosity) then - do j=1, k - do ii=1, k - if(print_verbosity) then - call print("ATOM : "//n_center_atom//" ivs_set: ("//j//" "//ii//") "//dot_product(ivs_set_pred(j,:,n_center_atom), ivs_set_norm_pred(ii,:)) ) - endif - enddo - enddo - endif - - - ! initialise distance_index(:) - do t=1, n - distance_index(t) =t - enddo - - ! do the sorting and selection - call sorting_configuration(ivs_set_pred(:,:,n_center_atom), ivs_set, ivs_set_norm_pred, ivs_set_norm, sigma, distance_confs_unsorted, distance_index) - call print("Min and Max DISTANCE with Index after Sorting: "//distance_confs_unsorted(distance_index(1))//" and "// & - distance_confs_unsorted(distance_index(n_teach))//" the INDEX: "//distance_index(1)//" and "//distance_index(n_teach)) - !!!!!!!!!!!!! - if (do_dynamic_x) then - allocate(nearest_data(k,3,n_teach)) - do ii=1, n_teach - nearest_data(:,:,ii)=ivs_set(:,:,distance_index(ii)) - enddo - call sigma_factor_from_single_dimension(nearest_data, sigma, print_verbosity, TOL_REAL, data_dir) - ! update 'sigma.dat' - deallocate(nearest_data) - endif - - if ( distance_confs_unsorted( distance_index(1) ) > dist_shift_factor) then - ! distance_confs_unsorted: the pair distance betwen test and database. - ! sigma_cov: the original input for covariance length - sigma_covariance = sigma_cov*distance_confs_unsorted(distance_index(1))/dist_shift_factor - ! this intrinsically changes the value of SIGMA_COVARIANCE and enters next loop - call print("sigma_covariance are shifted by a factor of :"//distance_confs_unsorted(distance_index(1))/dist_shift_factor) - call print("Modified sigma_covariance :"//sigma_covariance) - else - sigma_covariance = sigma_cov - ! the sigma_covariance used in GP - endif - - if (.false.) then - ! massive output, only for testing use - call print("Detail on the teaching information") - do ii = 1, n_teach - call print("Index: "//distance_index(ii)//" Distance: "//distance_confs_unsorted(ii)) - call print("Force in IVs space: "//force_proj_ivs(:,distance_index(ii))) - enddo - endif - - ! max marginal likelihood - if (local_ml_optim_size > 0) call print("Optimise: "//local_ml_optim_size) - !!! ML optimisation here: first calculates the necessary input matrices, then optimises - if (local_ml_optim_size > 0) then - call print("Local Maximum Likelihood selected") - do t = 1, local_ml_optim_size ! loop to generate the force_cov_mat and the distance_matrix of the restricted subset of the LS - do j = t, local_ml_optim_size - force_covariance_matrix(t,j) = dot_product(force_proj_ivs(:,distance_index(t)), force_proj_ivs(:,distance_index(j))) - ! check if possible, may be a wreck because IVs make absolute representation of the force impossible - force_covariance_matrix(j,t) = force_covariance_matrix(t,j) - covariance_tiny(t,j) = cov(ivs_set(:,:,distance_index(t)), ivs_set(:,:,distance_index(j)), & - ivs_set_norm(:,:,distance_index(t)), ivs_set_norm(:,:,distance_index(j)), sigma, sigma_covariance, func_type=func_type, & - distance=distance_matrix(t,j)) - covariance_tiny(j,t) = covariance_tiny(t,j) - distance_matrix(j,t) = distance_matrix(t,j) - enddo - enddo - call do_optimise_likelihood(sigma_error, sigma_covariance) - endif - - if (read_data_dij) then - do t = 1, n_teach ! loop to generate the covariance matrix of the learning set - dist=distance_matrix_dij(distance_index(t), distance_index(t)) - covariance(t,t) = cov_dij(sigma_covariance, dist, func_type) - ! write(*,*) 'diagoanl value', covariance(t,t) - if (do_gp) covariance(t,t) = covariance(t,t) + sigma_error**2 - do j = t+1, n_teach ! above diagonal - dist=distance_matrix_dij(distance_index(t),distance_index(j)) - covariance(t,j) = cov_dij(sigma_covariance, dist, func_type) - covariance(j,t) = covariance(t,j) - enddo - enddo - else - call system_timer('Evaluating the Cov') - !Generate covariance matrix - !$omp parallel default(none) shared(covariance, n_teach, ivs_set, ivs_set_norm, distance_index, sigma, sigma_error, sigma_covariance, do_gp, func_type), private(j) - !$omp do - do t = 1, n_teach ! loop to generate the covariance matrix of the learning set - covariance(t,t) = cov(ivs_set(:,:,distance_index(t)), ivs_set(:,:,distance_index(t)), & - ivs_set_norm(:,:,distance_index(t)), ivs_set_norm(:,:,distance_index(t)), sigma, sigma_covariance, func_type=func_type) - if (do_gp) covariance(t,t) = covariance(t,t) + sigma_error**2 - do j = t+1, n_teach ! above diagonal - covariance(t,j) = cov(ivs_set(:,:,distance_index(t)), ivs_set(:,:,distance_index(j)), & - ivs_set_norm(:,:,distance_index(t)), ivs_set_norm(:,:,distance_index(j)), sigma, sigma_covariance, func_type=func_type) - covariance(j,t) = covariance(t,j) - enddo - enddo - !$omp end parallel - call system_timer('Evaluating the Cov') - endif ! not read_data_dij - - call system_timer('Inverting the Covariance Matrix') - if (do_gp) then - call inverse(covariance, inv_covariance) - else - ! To Do Sigular Value Decomposition (SVD): A = U*SIGMA*VT - call inverse_svd_threshold(covariance, thresh, result_inv=inv_covariance) - endif - call system_timer('Inverting the Covariance Matrix') - - - do t=1, n_teach - force_proj_ivs_select(:,t)=force_proj_ivs(:,distance_index(t)) - force_magntd_data_select(t) = force_magntd_data(distance_index(t)) - enddo - - ! the test configuration covariance vector - do t= 1, n_teach - covariance_pred(t) = cov(ivs_set_pred(:,:,n_center_atom), ivs_set(:,:,distance_index(t)), ivs_set_norm_pred, & - ivs_set_norm(:,:,distance_index(t)), sigma, sigma_covariance, func_type=func_type) - enddo - - ! the predicted force components on each of the internal directions - force_proj_ivs_pred(:) = matmul(covariance_pred, matmul(inv_covariance, transpose(force_proj_ivs_select(:,:)) )) - - ! Predict the Force Magnitude - force_magntd_pred = dot_product(covariance_pred, matmul(inv_covariance, force_magntd_data_select)) - - ! we need to mannually set the force components to be zero, projected on the zero internal-vector directions - do j=1, k - force_proj_ivs_pred(j)=force_proj_ivs_pred(j)*real(mark_zero_ivs(j), dp) - enddo - - if (print_verbosity) then - do j=1, k - call print("ivs_set_norm_pred"//ivs_set_norm_pred(j,:)) - enddo - endif - - allocate(out_u(3,3), out_vt(3,3)) ! to obtain the transformation matrix with the principal axis - call inverse_svd_threshold(transpose(ivs_set_norm_pred) .mult. ivs_set_norm_pred, thresh, u_out=out_u, vt_out=out_vt) - - allocate(ivs_set_norm_pred_t(k,3)) - - call internal_dimension_mark(ivs_set_pred(:,:,n_center_atom) .mult. out_u, dim_tol, dimension_mark) - - ivs_set_norm_pred_t = ivs_set_norm_pred .mult. out_u - - ! ivs_set_pred_t contains the Internal-directions after PCA transformation. - if (print_verbosity) then - do j=1, k - write(*,*) "ivs_set_norm_pred_t : ", ivs_set_norm_pred_t(j, :) - enddo - endif - - select case (sum(dimension_mark(:))) - case(0) - force= 0.0_dp - case(1) - force=(transpose(ivs_set_norm_pred) .mult. force_proj_ivs_pred )/real(sum(mark_zero_ivs),dp) - case(2) - feature_inner_matrix=transpose(ivs_set_norm_pred_t) .mult. ivs_set_norm_pred_t - call rank_lowered_inverse(feature_inner_matrix, feature_inv) - force = out_u .mult. feature_inv .mult. transpose(ivs_set_norm_pred_t) .mult. force_proj_ivs_pred - case(3) - - feature_inner_matrix=transpose(ivs_set_norm_pred) .mult. ivs_set_norm_pred - if (do_svd) then - if (print_verbosity) write(*,*) "feature inner matrix :", feature_inner_matrix - call inverse_svd_threshold(feature_inner_matrix, thresh, result_inv=feature_inv) - if (print_verbosity) write(*,*) "inverse feature inner matrix :", feature_inv - else - if (print_verbosity) write(*,*) "feature_inner_matrix :", feature_inner_matrix - call inverse(feature_inner_matrix, feature_inv) - if (print_verbosity) write(*,*) "inverse feature inner matrix :", feature_inv - endif - - if (least_sq) then - force = feature_inv .mult. transpose(ivs_set_norm_pred) .mult. force_proj_ivs_pred - else - call real_expection_sampling_components(ivs_set_norm_pred, force_proj_ivs_pred, force) - endif - end select - - deallocate(out_u) - deallocate(out_vt) - deallocate(ivs_set_norm_pred_t) - - call print("Predicted Force Magnitude: "//force_magntd_pred) - call print("force in external space : "//force//" Magnitude: "//norm(force)) - call print("the original force:"//force_ptr(:, n_center_atom)//" Magnitude: "//norm(force_ptr(:, n_center_atom))) - call print("max error : "//maxval(abs(force_ptr(:,n_center_atom)-force))//" norm error : "//norm(force_ptr(:,n_center_atom)-force)) - - ! measure the consistence between the least-square inference and the components obtained from GP processes - if (least_sq) then - error_ls=0.0_dp - do j=1, k - error_ls = error_ls + (dot_product(ivs_set_norm_pred(j,:), force(:)) - force_proj_ivs_pred(j))**2 - enddo - error_ls = sqrt(error_ls / real(k,dp)) - call print("deviation of least-square inference : "//error_ls) - error_ls_max=maxval(abs( matmul(ivs_set_norm_pred, force) - force_proj_ivs_pred(:) )) - call print("Max deviation Component of LS : "//error_ls_max) - endif - - kappa = cov(ivs_set_pred(:,:,n_center_atom), ivs_set_pred(:,:,n_center_atom), ivs_set_norm_pred, ivs_set_norm_pred, sigma, sigma_covariance, func_type=func_type) + sigma_error**2 - ! the passing of uncertainty from Gaussian Processes to the Force Vector - error_gp_sq = kappa - covariance_pred .dot. matmul(inv_covariance, covariance_pred) - error_gp = sqrt(abs(error_gp_sq)) - geometry_matrix = feature_inv .mult. transpose(ivs_set_norm_pred) - - do j=1, 3 ! Deviation in External Cartesian Coordinate - variance_xyz(j)= sqrt(dot_product(geometry_matrix(j,:), geometry_matrix(j,:))) * (error_gp) - !call print("Predicted Error Factor :"//sum(abs(geometry_matrix(j,:)))//" Dimension :"//j) - enddo - - call print("GP Uncertainty in Cartesian Coordinate: "//variance_xyz//" GP variance: "//error_gp//" variance Squre :"//error_gp_sq) - pred_err(n_center_atom)=norm(variance_xyz) - force_ptr(:,n_center_atom)=force -! -enddo ! loop over positions - -error_frame = maxval(pred_err) ! Cautious. could generate crazy numbers -call print("Error Bar of the Frame :"//error_frame) - -deallocate(ivs_set_pred) -deallocate(ivs_set_norm_pred) -deallocate(geometry_matrix) -deallocate(r_grid, m_grid, species, sigma) -deallocate(force_proj_ivs_pred) -deallocate(ivs_set_norm) -deallocate(force_magntd_data, force_magntd_data_select) -deallocate(ivs_set) -deallocate(mark_zero_ivs) -deallocate(force_proj_ivs) -deallocate(force_proj_ivs_select) -deallocate(covariance, inv_covariance) -deallocate(covariance_pred) -deallocate(distance_index, distance_confs_unsorted) -if(allocated(force_covariance_matrix)) deallocate(force_covariance_matrix) -if(allocated(covariance_tiny)) deallocate(covariance_tiny) -if(allocated(distance_matrix)) deallocate(distance_matrix) -if (allocated(distance_matrix_dij)) deallocate(distance_matrix_dij) -! -fgp_calc=at_in ! output the updated atomic object -! -end function fgp_calc ! return updated at_in -! -!subroutine update_database(at) ! update database based on all info in at -!! -! type(Atoms) :: at -! real(dp), allocatable, dimension(:) :: r_grid, m_grid, force_proj_test -! real(dp), allocatable, dimension(:,:,:) :: ivs_set_pred -! character(STRING_LEN) :: data_dir -! integer :: i, j, k, add_vector, n, n_center_atom, n0 -! logical :: write_data_dij -! real(dp), dimension(:,:), pointer :: force_ptr -! integer, dimension(:), allocatable :: species -! -! call system_timer('Updating the DATABSE : grid.dat force.dat ivs.dat, exclud. dist.dat') -! ! probably first load the grid file -! call load_iv_params(data_dir, r_grid, m_grid, species, k, add_vector, n_data=n_0) -! ! the current k is number of defined internal vectors -! if (add_vector > 0) k=k+add_vector -! ! becomes the number of internal dimensions -! allocate(force_proj_test(k)) -! -! do i=1, at%N -! -! do j = 1, k -! force_proj_test(j) = dot_product(force_ptr(:,n_center_atom), ivs_set_norm_pred(j,:) ) -! enddo -! -! call write_iv_params(data_dir, r_grid, m_grid, species, k-add_vector, add_vector, n+1) -! -! !if (write_data_dij) call write_distance(distance_confs_unsorted, data_dir) ! append distance file -! !write(*,*) 'Distance', distance_confs_unsorted(:) -! -! OPEN(2,status='old',file=trim(data_dir)//'Force.dat', form='UNFORMATTED', position='APPEND') -! OPEN(3,status='old',file=trim(data_dir)//'IV.dat', form='UNFORMATTED', position='APPEND') -! write(2) force_proj_test(:), norm(force_ptr(:,n_center_atom)) -! do j=1, 3 -! write(3) ivs_set_pred(:,j,n_center_atom) -! enddo -! -! enddo ! loop on positions -! close(2) -! close(3) -! deallocate(force_proj_test) -! call system_timer('Updating the DATABSE : dist.dat force.dat ivs.dat') -!! -!end subroutine update_database -! -subroutine optimisation_ivs_subset(data_dir, x_index) - ! giving x_index in the order of decreasing weight - ! - integer :: k, t, add_vector, n, i, j - real(dp), dimension(:,:,:), allocatable :: ivs_set - real(dp), dimension(:,:), allocatable :: force_proj_ivs - real(dp), dimension(:), allocatable :: force_magntd_data, uni_ave, norm_ave, r_grid, m_grid - integer, dimension(:), allocatable :: species - integer, dimension(:), allocatable, intent(out) :: x_index - real(dp) :: max_corr - type(Dictionary) :: params - character(STRING_LENGTH), intent(in) :: data_dir - - call load_iv_params(data_dir, r_grid, m_grid, species, k, add_vector, n_data=n) - - k=k+add_vector ! adding the Classical Force Vectors - call print_title('Starting optimise the IVs directions') - - allocate(force_proj_ivs(k,n), ivs_set(k,3,n), force_magntd_data(n)) - allocate(uni_ave(k), norm_ave(k), x_index(k)) - - OPEN(2,status='old',file=trim(data_dir)//'Force.dat',form='UNFORMATTED') - OPEN(3,status='old',file=trim(data_dir)//'IV.dat',form='UNFORMATTED') - - do t=1, n - read(2) force_proj_ivs(:, t), force_magntd_data(t) - do i=1, 3 - read(3) ivs_set(:,i,t) - enddo - enddo - close(2) - close(3) - - ! output force_proj_ivs, force_magntd_data, norm of ivs - do i=1, k - uni_ave(i) = -1.0_dp* abs(sum(force_proj_ivs(i,:)) / real(n, dp)) - ! universal average. to be confirmed - norm_ave(i) = sum(abs(force_proj_ivs(i,:))) / real(n, dp) - x_index(i) =i - enddo - ! - call heap_sort(uni_ave, i_data=x_index) - ! what if reversed order is required. - ! - deallocate(force_proj_ivs, ivs_set, force_magntd_data, uni_ave, norm_ave) - call print_title('Starting optimise the IVs directions') - ! -end subroutine optimisation_ivs_subset -! -end module force_machine_learning_module diff --git a/src/Utils/phonons.f95 b/src/Utils/phonons.f95 deleted file mode 100644 index 36d5ac6450..0000000000 --- a/src/Utils/phonons.f95 +++ /dev/null @@ -1,1241 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! IR intensities from K. Jackson, M. R. Pederson, and D. Porezag, -! Z. Hajnal, and T. Frauenheim, Phys. Rev. B v. 55, 2549 (1997). -#include "error.inc" -module phonons_module -use libatoms_module -use mpi_context_module, only : free_context -use potential_module -use libatoms_misc_utils_module -implicit none -private - -real(dp), parameter :: PHONON_FORCE_TOLERANCE = 1.0e-12_dp - -public :: Phonon_fine -type Phonon_fine - integer :: n_qvectors, n_modes - real(dp), dimension(:,:), allocatable :: q, frequency, hessian - complex(dp), dimension(:,:,:,:), allocatable :: eigenvector - logical :: initialised = .false. -endtype Phonon_fine - -public phonons_all, dynamical_matrix_solve, Phonon_fine_calc_print, eval_frozen_phonon - -public :: initialise -interface initialise - module procedure Phonon_fine_initialise -endinterface initialise - -public :: finalise -interface finalise - module procedure Phonon_fine_finalise -endinterface finalise - -public :: calc -interface calc - module procedure Phonon_fine_calc -endinterface calc - -public :: print -interface print - module procedure Phonon_fine_print -endinterface print - -contains - - subroutine Phonon_fine_initialise(this,error) - type(Phonon_fine), intent(inout) :: this - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(this%initialised) call finalise(this,error) - - this%initialised = .true. - endsubroutine Phonon_fine_initialise - - subroutine Phonon_fine_allocate(this,n_modes,n_qvectors,error) - type(Phonon_fine), intent(inout) :: this - integer, intent(in) :: n_modes, n_qvectors - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if( mod(n_modes,3) /= 0 ) then - RAISE_ERROR('Phonon_fine_allocate: number of modes must be multiple of 3, n_modes = '//n_modes, error) - endif - - if(this%initialised) call finalise(this,error) - this%n_qvectors = n_qvectors - this%n_modes = n_modes - allocate(this%q(3,this%n_qvectors)) - allocate(this%frequency(this%n_modes,this%n_qvectors)) - allocate(this%eigenvector(3,n_modes/3,n_modes,n_qvectors)) - - this%initialised = .true. - - endsubroutine Phonon_fine_allocate - - subroutine Phonon_fine_finalise(this,error) - type(Phonon_fine), intent(inout) :: this - integer, intent(out), optional :: error - - INIT_ERROR(error) - - if(.not. this%initialised) return - if(allocated(this%q)) deallocate( this%q ) - if(allocated(this%frequency)) deallocate( this%frequency ) - if(allocated(this%eigenvector)) deallocate( this%eigenvector ) - if(allocated(this%hessian)) deallocate( this%hessian ) - this%n_qvectors = 0 - - this%initialised = .false. - - endsubroutine Phonon_fine_finalise - - subroutine Phonon_fine_print(this,file,error) - type(Phonon_fine), intent(inout) :: this - type(Inoutput), intent(inout), target, optional :: file - integer, intent(out), optional :: error - - type(Inoutput), pointer :: my_file => null() - integer :: k, t_real_precision - - INIT_ERROR(error) - - if(.not. this%initialised) then - RAISE_ERROR('Phonon_fine_print: not initialised', error) - endif - - if(present(file)) then - my_file => file - else - my_file => mainlog - endif - - t_real_precision = my_file%default_real_precision - call print("PHONON results begin", file=my_file) - call print(" q-vector (1/Angstrom) frequency (THz)", file=my_file) - do k = 1, this%n_qvectors - my_file%default_real_precision=6 - call print("PHONONS_FINE "//this%q(:,k), nocr=.true.,file=my_file) - my_file%default_real_precision=9 - call print(" "//this%frequency(:,k)*1000.0_dp,file=my_file) - enddo - call print("PHONON results end", file=my_file) - my_file%default_real_precision = t_real_precision - - my_file => null() - - endsubroutine Phonon_fine_print - - subroutine Phonon_fine_calc(this,pot, at_in, dx, & - phonon_supercell, phonon_supercell_fine, calc_args, do_parallel, & - phonons_path_start, phonons_path_end, phonons_path_steps, do_phonopy_force_const_mat, error) - - type(Phonon_fine), intent(inout) :: this - - type(Potential), intent(inout) :: pot - type(Atoms), intent(inout) :: at_in - real(dp), intent(in) :: dx - character(len=*), intent(in), optional :: calc_args - logical, intent(in), optional :: do_phonopy_force_const_mat - logical :: my_phonopy_force_const_mat - logical, intent(in), optional :: do_parallel - integer, dimension(3), intent(in), optional :: phonon_supercell, phonon_supercell_fine - real(dp), dimension(3), intent(in), optional :: phonons_path_start, phonons_path_end - integer, intent(in), optional :: phonons_path_steps - integer, intent(out), optional :: error - - type(Atoms) :: at, at_fine - integer :: i, j, k, alpha, beta, n, n1, n2, n3, jn, j_fine - integer, dimension(3) :: do_phonon_supercell, do_phonon_supercell_fine - integer, dimension(:,:,:,:), allocatable :: map_at_fine - - real(dp) :: r_ij, dm(3), at_max_cutoff - complex(dp) :: exp_I_k_R - real(dp), dimension(3) :: pp, diff_ij - integer, dimension(3) :: shift_ij, j_SI, j_SI_fine - real(dp), dimension(:), allocatable :: evals, at_in_sqrt_mass - real(dp), dimension(:,:), allocatable :: pos0 - real(dp), dimension(:,:,:,:), allocatable :: fp0, fm0, fp0_fine, fm0_fine - complex(dp), dimension(:,:), allocatable :: dmft, evecs - integer, dimension(:,:), pointer :: phonons_SI, phonons_fine_SI - logical, dimension(:), allocatable :: at_fine_mapped - - real(dp), dimension(:,:), allocatable :: frac - integer :: do_phonons_path_steps - - integer :: primcell_counter,i_n,n1i,n2i,n3i,n1eff,n2eff,n3eff,jneff - real(dp), dimension(:,:,:,:), allocatable :: fine_force_const - real(dp), dimension(3,3) :: super_cell_lattice,fract_matrix - !character(2), dimension(1,len(at_in%species)) :: species_array - integer :: i_species - - INIT_ERROR(error) - - call finalise(this, error) - - my_phonopy_force_const_mat = optional_default(.false., do_phonopy_force_const_mat) - - do_phonon_supercell = optional_default((/1,1,1/),phonon_supercell) - do_phonon_supercell_fine = optional_default(do_phonon_supercell,phonon_supercell_fine) - - if( any( do_phonon_supercell_fine < do_phonon_supercell ) ) then - RAISE_ERROR("phonons_fine: phonon_supercell = ("//phonon_supercell//") greater than phonon_supercell_fine =("//phonon_supercell_fine//")",error) - endif - - call supercell(at,at_in,do_phonon_supercell(1),do_phonon_supercell(2),do_phonon_supercell(3),supercell_index_name="phonons_SI") - - if (present(phonons_path_start) .and. present(phonons_path_end)) then - do_phonons_path_steps = optional_default(3, phonons_path_steps) - call Phonon_fine_allocate(this,at_in%N*3,do_phonons_path_steps + 2,error) - - do i = 1, this%n_qvectors - this%q(:, i) = 2.0_dp * PI * matmul((phonons_path_start + ((phonons_path_end - phonons_path_start) * (real((i - 1), dp) / real((this%n_qvectors - 1), dp)))), at_in%g) - enddo - else - call Phonon_fine_allocate(this,at_in%N*3,product(do_phonon_supercell_fine),error) - - i = 0 - do n1 = 0, do_phonon_supercell_fine(1)-1 - do n2 = 0, do_phonon_supercell_fine(2)-1 - do n3 = 0, do_phonon_supercell_fine(3)-1 - i = i + 1 - - this%q(:,i) = 2*PI*matmul( ( (/real(n1,dp),real(n2,dp),real(n3,dp)/) / do_phonon_supercell_fine ), at_in%g ) - enddo - enddo - enddo - endif - - allocate(pos0(3,at%N)) - - if (dx == 0.0_dp) then - RAISE_ERROR("phonons called with dx == 0.0",error) - endif - - call set_cutoff(at, cutoff(pot), cutoff_skin=0.5_dp) - - pos0 = at%pos - - allocate(fp0(3,at%N,3,at_in%N),fm0(3,at%N,3,at_in%N)) - - if(allocated(this%hessian)) deallocate(this%hessian) - allocate(this%hessian(3*at%N,3*at_in%N)) - - fp0 = 0.0_dp - fm0 = 0.0_dp - - call system_timer("Phonon_fine_calc/force") - call print("Starting force calculations") - do i = 1, at_in%N - call print('Displacing atom '//i//' of '//at_in%N) - do alpha = 1, 3 - at%pos = pos0 - at%pos(alpha,i) = at%pos(alpha,i) + dx - call calc_dists(at) - call calc(pot, at, force=fp0(:,:,alpha,i), args_str=calc_args) - - at%pos = pos0 - at%pos(alpha,i) = at%pos(alpha,i) - dx - call calc_dists(at) - call calc(pot, at, force=fm0(:,:,alpha,i), args_str=calc_args) - enddo - enddo - call print("Finished force calculations") - call system_timer("Phonon_fine_calc/force") - - do i = 1, at_in%N - do alpha = 1, 3 - do j = 1, at%N - do beta = 1, 3 - this%hessian((j-1)*3+beta,(i-1)*3+alpha) = - (fp0(beta,j,alpha,i) - fm0(beta,j,alpha,i)) / 2.0_dp / dx - enddo - enddo - enddo - enddo - - at%pos = pos0 - call calc_dists(at) - deallocate(pos0) - - call supercell(at_fine,at_in,do_phonon_supercell_fine(1),do_phonon_supercell_fine(2),do_phonon_supercell_fine(3),supercell_index_name="phonons_fine_SI") - - if(.not. assign_pointer(at,"phonons_SI",phonons_SI) .or. .not. assign_pointer(at_fine,"phonons_fine_SI",phonons_fine_SI)) then - RAISE_ERROR("phonons_fine: couldn't assign phonons_SI and phonons_fine_SI pointers",error) - endif - - allocate(fp0_fine(3,at_fine%N,3,at_in%N),fm0_fine(3,at_fine%N,3,at_in%N)) - fp0_fine = 0.0_dp - fm0_fine = 0.0_dp - - allocate(map_at_fine(0:at_in%N-1,0:do_phonon_supercell_fine(1)-1,0:do_phonon_supercell_fine(2)-1,0:do_phonon_supercell_fine(3)-1)) - do i = 1, at_fine%N - map_at_fine(mod(i,at_in%N),phonons_fine_SI(1,i),phonons_fine_SI(2,i),phonons_fine_SI(3,i)) = i - enddo - - if( all(do_phonon_supercell == do_phonon_supercell_fine) ) then - fp0_fine = fp0 - fm0_fine = fm0 - else - at_max_cutoff = max_cutoff(at%lattice,error) - if( at_max_cutoff <= cutoff(pot) ) then - RAISE_ERROR("phonons_fine: if cutoff sphere cannot fit in supercell, it is not possible to map supercell atoms to supercell_fine atoms",error) - endif - - do i = 1, at_in%N - fp0_fine(:,i,:,i) = fp0(:,i,:,i) - fm0_fine(:,i,:,i) = fm0(:,i,:,i) - - do j = 1, at%N - r_ij = distance_min_image(at,i,j,shift=shift_ij) - if( r_ij >= at_max_cutoff ) then - if( any(abs(fp0(:,j,:,i)) > PHONON_FORCE_TOLERANCE) .or. any(abs(fm0(:,j,:,i)) > PHONON_FORCE_TOLERANCE) ) then - call print_message('WARNING', "Phonon_fine_calc: in the supercell there are non-zero forces on atoms outside of the minimum-image cutoff sphere. & - Phonons computed in the fine supercell may be inaccurate. This problem may be eliminated by increasing phonon_supercell. & - Atoms in supercell: "//i//" and"//j//" from "//r_ij//" A from each other, forces are: "//reshape(fp0(:,j,:,i),(/9/)) & - //" "//reshape(fm0(:,j,:,i),(/9/)) ) - endif - endif - shift_ij = phonons_SI(:,j) + shift_ij * do_phonon_supercell - - j_SI_fine = mod(shift_ij + do_phonon_supercell_fine,do_phonon_supercell_fine) - j_fine = map_at_fine(mod(j,at_in%N),j_SI_fine(1),j_SI_fine(2),j_SI_fine(3)) - fp0_fine(:,j_fine,:,i) = fp0(:,j,:,i) - fm0_fine(:,j_fine,:,i) = fm0(:,j,:,i) - enddo - enddo - - endif - - call system_timer("Phonon_fine_calc/phonon") - call print("Starting phonon calculations") - -! Printing out the force constant and atomic positions in the phonopy format: - if_my_phonopy_force_const_mat: if (my_phonopy_force_const_mat) then - call print_message('WARNING', "phonopy_force_const_mat: This program prints out the force constants and atoms in the way phonopy 1.12.4 expects them. It is not guaranteed to work with other versions and does only support a single atomic species at a time (no alloys).") - !species_array = at_in%species -! do i_species = 2,len(at_in%species) -! print *, at_in%species(:,1) -! if ( (at_in%species(:,1)) /= (at_in%species(:,i_species)) ) then -! print *, at_in%species(:,i_species) -! call system_abort("Only one species is supported. Aborting program.") -! endif -! enddo - call print("Force constant matrix using supercell/supercell fine:") - - allocate(fine_force_const(at_in%N,3,do_phonon_supercell_fine(1)*do_phonon_supercell_fine(2)*do_phonon_supercell_fine(3)*at_in%N,3)) - - do i = 1, at_in%N - do alpha = 1, 3 - do beta = 1, 3 - primcell_counter = 0 - do n1 = 0, do_phonon_supercell_fine(1)-1 - do n2 = 0, do_phonon_supercell_fine(2)-1 - do n3= 0, do_phonon_supercell_fine(3)-1 - do j = 1, at_in%N - primcell_counter = primcell_counter + 1 - jn = ((n1*do_phonon_supercell_fine(2)+n2)*do_phonon_supercell_fine(3)+n3)*at_in%N+j - - fine_force_const(i,alpha,jn,beta) = -(fp0_fine(beta,jn,alpha,i)-fm0_fine(beta,jn,alpha,i))/(2.0_dp*dx) - enddo ! j - enddo ! n3 - enddo ! n2 - enddo ! n1 - enddo ! beta - enddo ! alpha - enddo ! i - - print *, do_phonon_supercell_fine(1)*do_phonon_supercell_fine(2)*do_phonon_supercell_fine(3)*at_in%N - - -!Some loops needed to be reveresed compared to the phonon calculation further below as phonopy orders the supercell atoms differently than we do: - do i = 1, at_in%N - do n3i = 0, do_phonon_supercell_fine(3)-1 - do n2i = 0, do_phonon_supercell_fine(2)-1 - do n1i = 0, do_phonon_supercell_fine(1)-1 -! i_n = ((n1i*do_phonon_supercell_fine(2)+n2i)*do_phonon_supercell_fine(3)+n3i)*at_in%N+i - i_n = 1 + (((i-1)*do_phonon_supercell_fine(3)+n3i)*do_phonon_supercell_fine(2)+n2i)*do_phonon_supercell_fine(1)+n1i - primcell_counter = 0 - do j = 1, at_in%N - do n3 = 0, do_phonon_supercell_fine(3)-1 - do n2 = 0, do_phonon_supercell_fine(2)-1 - do n1 = 0, do_phonon_supercell_fine(1)-1 - jn = 1 + (((j-1)*do_phonon_supercell_fine(3)+n3)*do_phonon_supercell_fine(2)+n2)*do_phonon_supercell_fine(1)+n1 - - n1eff = mod(do_phonon_supercell_fine(1) + n1 - n1i,do_phonon_supercell_fine(1)) - n2eff = mod(do_phonon_supercell_fine(2) + n2 - n2i,do_phonon_supercell_fine(2)) - n3eff = mod(do_phonon_supercell_fine(3) + n3 - n3i,do_phonon_supercell_fine(3)) - - !This makes sure that we use the right atom (regarding the supercell as well as the phonopy atom numbering convention). - jneff = ((n1eff*do_phonon_supercell_fine(2)+n2eff)*do_phonon_supercell_fine(3)+n3eff)*at_in%N+j - - print *, i_n, jn - do alpha = 1, 3 - - print *, fine_force_const(i,1,jneff,alpha), fine_force_const(i,2,jneff,alpha), & - & fine_force_const(i,3,jneff,alpha) - - enddo ! beta - - enddo ! n1 - enddo ! n2 - enddo ! n3 - enddo ! j - enddo ! n1i - enddo ! n2i - enddo ! n3i - enddo ! i - - - deallocate(fine_force_const) - - print *, "Atom postions for above given force constant in format for phonopy:" - - print *, at_in%species(:,1) - print *, 1.0_dp - super_cell_lattice(1,:) = at_in%lattice .mult. (/do_phonon_supercell_fine(1),0,0/) - super_cell_lattice(2,:) = at_in%lattice .mult. (/0,do_phonon_supercell_fine(2),0/) - super_cell_lattice(3,:) = at_in%lattice .mult. (/0,0,do_phonon_supercell_fine(3)/) - do i = 1,3 - print *, super_cell_lattice(i,:) - enddo - print *, do_phonon_supercell_fine(1)*do_phonon_supercell_fine(2)*do_phonon_supercell_fine(3)*at_in%N - print *, "Direct" - - fract_matrix = transpose(super_cell_lattice) - call inverse(fract_matrix) - - - do j = 1, at_in%N - do n3= 0, do_phonon_supercell_fine(3)-1 - do n2 = 0, do_phonon_supercell_fine(2)-1 - do n1 = 0, do_phonon_supercell_fine(1)-1 - - pp = at_in%lattice .mult. (/n1,n2,n3/) - - print *, (fract_matrix .mult. (at_in%pos(:,j) + pp)) - enddo ! n1 - enddo ! n2 - enddo ! n3 - enddo ! j - - print *, "Finished atom postions for above given force constant in format for phonopy:" - endif if_my_phonopy_force_const_mat -! Finished phonopy force constant and atom positions - - - allocate(at_in_sqrt_mass(at_in%N)) - do i = 1, at_in%N - at_in_sqrt_mass(i) = sqrt(ElementMass(at_in%Z(i))) - enddo - - !$omp parallel default(none) private(dmft,evals,evecs) shared(this,at_in,do_phonon_supercell_fine,fp0_fine,fm0_fine,dx,at_in_sqrt_mass,map_at_fine) - allocate(dmft(at_in%N*3,at_in%N*3)) - allocate(evals(at_in%N*3), evecs(at_in%N*3,at_in%N*3)) - !$omp do private(k,i,j,alpha,diff_ij,n1,n2,n3,pp,jn,dm,exp_I_k_R) - do k = 1, this%n_qvectors - call system_timer("Phonon_fine_calc/dynamical_matrix") - dmft = CPLX_ZERO - do n1 = 0, do_phonon_supercell_fine(1)-1 - do n2 = 0, do_phonon_supercell_fine(2)-1 - do n3= 0, do_phonon_supercell_fine(3)-1 - pp = at_in%lattice .mult. (/n1,n2,n3/) - - do j = 1, at_in%N - !jn = ((n1*do_phonon_supercell_fine(2)+n2)*do_phonon_supercell_fine(3)+n3)*at_in%N+j - jn = map_at_fine(mod(j,at_in%N),n1,n2,n3) - - do i = 1, at_in%N - diff_ij = at_in%pos(:,j) - at_in%pos(:,i) + pp - exp_I_k_R = exp( CPLX_IMAG * dot_product(this%q(:,k),diff_ij) ) - - - do alpha = 1, 3 - dm = - (fp0_fine(:,jn,alpha,i)-fm0_fine(:,jn,alpha,i))/(2.0_dp*dx) / (at_in_sqrt_mass(i) * at_in_sqrt_mass(j)) - - dmft((i-1)*3+alpha,(j-1)*3+1:j*3) = dmft((i-1)*3+alpha,(j-1)*3+1:j*3) + dm * exp_I_k_R - enddo ! alpha - - enddo ! i - enddo ! j - enddo ! n3 - enddo ! n2 - enddo ! n1 - - do i = 1, 3*at_in%N - dmft(i,i) = CPLX_ONE*real(dmft(i,i)) - do j = i+1, 3*at_in%N - dmft(i,j) = conjg(dmft(j,i)) - enddo - enddo - call system_timer("Phonon_fine_calc/dynamical_matrix") - - call system_timer("Phonon_fine_calc/eig") - call diagonalise(dmft, evals, evecs) - call system_timer("Phonon_fine_calc/eig") - this%frequency(:,k) = sign(sqrt(abs(evals)),evals)/2.0_dp/PI - this%eigenvector(:,:,:,k) = reshape( evecs, (/3, at_in%N, 3*at_in%N /) ) - - enddo ! k - !$omp end do - deallocate(dmft) - deallocate(evecs,evals) - !$omp end parallel - call print("Finished phonon calculations") - call system_timer("Phonon_fine_calc/phonon") - - deallocate(fp0, fp0_fine, fm0, fm0_fine, at_in_sqrt_mass) - deallocate(map_at_fine) - call finalise(at,at_fine) - endsubroutine Phonon_fine_calc - - subroutine Phonon_fine_calc_print(pot, at_in, dx, & - phonon_supercell, phonon_supercell_fine, calc_args, do_parallel, & - phonons_path_start, phonons_path_end, phonons_path_steps, file, do_phonopy_force_const_mat, error) - - type(Potential), intent(inout) :: pot - type(Atoms), intent(inout) :: at_in - real(dp), intent(in) :: dx - character(len=*), intent(in), optional :: calc_args - logical, intent(in), optional :: do_phonopy_force_const_mat - logical, intent(in), optional :: do_parallel - integer, dimension(3), intent(in), optional :: phonon_supercell, phonon_supercell_fine - real(dp), dimension(3), intent(in), optional :: phonons_path_start, phonons_path_end - integer, intent(in), optional :: phonons_path_steps - type(Inoutput), intent(inout), optional :: file - integer, intent(out), optional :: error - - type(Phonon_fine) :: my_phonon_fine - - call calc(my_phonon_fine, pot, at_in, dx, & - phonon_supercell, phonon_supercell_fine, calc_args, do_parallel, & - phonons_path_start, phonons_path_end, phonons_path_steps, do_phonopy_force_const_mat, error) - - call print(my_phonon_fine,file,error) - call finalise(my_phonon_fine, error) - - endsubroutine Phonon_fine_calc_print - -function eval_frozen_phonon(pot, at, dx, evec, calc_args) - type(Potential), intent(inout) :: pot - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: dx - real(dp), intent(in) :: evec(:) - character(len=*), intent(in), optional :: calc_args - real(dp) :: eval_frozen_phonon ! result - - real(dp) :: Ep, E0, Em -! for potentially more accurate, 4th order fit -! real(dp) :: Ep2, Em2 - real(dp), allocatable :: pos0(:,:), dpos(:,:) - real(dp) :: b, d, t1, t2 - - allocate(pos0(3,at%N)) - allocate(dpos(3,at%N)) - - pos0 = at%pos - - dpos = reshape(evec, (/ 3, at%N /) ) - dpos = dpos / sqrt(sum(dpos**2)) - - call calc_dists(at) - call calc(pot, at, energy=E0, args_str=calc_args) - mainlog%prefix="FROZ_E0" - call set_value(at%params, "frozen_phonon_E0", E0) - call write(at, 'stdout') - call remove_value(at%params, "frozen_phonon_E0") - mainlog%prefix="" - - at%pos = pos0 + dx*dpos - - call calc_dists(at) - call calc(pot, at, energy=Ep, args_str=calc_args) - call set_value(at%params, "frozen_phonon_Ep", Ep) - call write(at, 'stdout', prefix='FROZ_EP') - call remove_value(at%params, "frozen_phonon_Ep") - - at%pos = pos0 - dx*dpos - - call calc_dists(at) - call calc(pot, at, energy=Em, args_str=calc_args) - call set_value(at%params, "frozen_phonon_Em", Em) - call write(at, 'stdout', prefix='FROZ_EM') - call remove_value(at%params, "frozen_phonon_Em") - - call print("frozen phonon Em " // Em // " E0 " // E0 // " Ep " // Ep, PRINT_VERBOSE) - - eval_frozen_phonon = ((Ep-E0)/dx - (E0-Em)/dx)/dx - -! more accurate 4th order fit. -! -! at%pos = pos0 + 2.0_dp*dx*dpos -! -! call calc_dists(at) -! call calc(pot, at, energy=Ep2, args_str=calc_args) -! mainlog%prefix="FROZ_EP2" -! call set_value(at%params, "frozen_phonon_Ep2", Ep2) -! call print_xyz(at, mainlog, real_format='f14.6', properties="pos:phonon") -! call remove_value(at%params, "frozen_phonon_Ep2") -! mainlog%prefix="" -! -! at%pos = pos0 - 2.0_dp*dx*dpos -! -! call calc_dists(at) -! call calc(pot, at, energy=Em2, args_str=calc_args) -! mainlog%prefix="FROZ_EM2" -! call set_value(at%params, "frozen_phonon_Em2", Em2) -! call print_xyz(at, mainlog, real_format='f14.6', properties="pos:phonon") -! call remove_value(at%params, "frozen_phonon_Em2") -! mainlog%prefix="" -! t1 = (Ep + Em - 2.0_dp*E0)/(2.0_dp*dx**2) -! t2 = (Ep2 + Em2 - 2.0_dp*E0)/(8.0_dp*dx**2) -! d = (t2-t1)/(3.0_dp*dx**2) -! b = t1 - d*dx**2 -! eval_frozen_phonon = 2.0_dp*b - - at%pos = pos0 - call calc_dists(at) - - deallocate(dpos) - deallocate(pos0) - -end function eval_frozen_phonon - -subroutine dynamical_matrix_solve(at, fc_mat, evals, evecs, zero_translation, zero_rotation) - type(Atoms), intent(inout) :: at - real(dp), intent(inout) :: fc_mat(:,:) - real(dp), intent(inout) :: evals(:) - real(dp), intent(inout), optional :: evecs(:,:) - logical, intent(in), optional :: zero_translation, zero_rotation - - logical :: do_zero_translation, do_zero_rotation - integer :: n_zero - logical :: override_zero_freq_phonons = .true. - real(dp), allocatable :: phonon(:,:), zero_phonon(:,:), zero_phonon_p(:,:), P(:,:), fc_mat_t(:,:) - integer :: i, j, beta - real(dp) :: phonon_norm, CoM(3), axis(3), dr_proj(3) - integer :: err - real(dp), allocatable :: zero_overlap_inv(:,:) - real(dp) :: sym_val - - do_zero_translation = optional_default(.true., zero_translation) - do_zero_rotation = optional_default(.false., zero_rotation) - - ! transform from generalized eigenproblem to regular eigenproblem - do i=1, at%N - do j=1, at%N -fc_mat((i-1)*3+1:(i-1)*3+3,(j-1)*3+1:(j-1)*3+3) = fc_mat((i-1)*3+1:(i-1)*3+3,(j-1)*3+1:(j-1)*3+3) / & - sqrt(ElementMass(at%Z(i))*ElementMass(at%Z(j))) - end do - end do - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - n_zero = 0 - if (do_zero_translation) n_zero = n_zero + 3 - if (do_zero_rotation) n_zero = n_zero + 3 - - if (n_zero > 0) then - allocate(zero_phonon(at%N*3,n_zero)) - allocate(zero_phonon_p(at%N*3,n_zero)) - allocate(phonon(3,at%N)) - do i=1, n_zero - if (do_zero_translation .and. i <= 3) then ! if zeroing both, then 1st 3 are translation - beta = i - phonon = 0.0_dp - phonon(beta,:) = 1.0_dp - else ! rotation - if (i > 3) then ! must have already done zero_rotation - beta = i-3 - else - beta = i - end if - CoM = centre_of_mass(at) - axis = 0.0_dp; axis(beta) = 1.0_dp - do j=1, at%N - dr_proj = at%pos(:,j)-CoM - dr_proj(beta) = 0.0_dp - phonon(:,j) = dr_proj .cross. axis - end do - endif - phonon_norm=sqrt(sum(ElementMass(at%Z)*sum(phonon**2,1))) - zero_phonon(:,i) = reshape(phonon/phonon_norm, (/ 3*at%N /) ) - end do ! i - deallocate(phonon) - - ! transform from generalized eigenproblem to regular eigenproblem - do i=1, at%N - zero_phonon((i-1)*3+1:(i-1)*3+3,:) = zero_phonon((i-1)*3+1:(i-1)*3+3,:)*sqrt(ElementMass(at%Z(i))) - end do - - allocate(zero_overlap_inv(n_zero,n_zero)) - ! project out zero frequency modes - do i=1, n_zero - do j=1, n_zero - zero_overlap_inv(i,j) = sum(zero_phonon(:,i)*zero_phonon(:,j)) - end do - end do - call inverse(zero_overlap_inv) - - zero_phonon_p = 0.0_dp; call matrix_product_sub(zero_phonon_p, zero_phonon, zero_overlap_inv) - deallocate(zero_overlap_inv) - - allocate(fc_mat_t(at%N*3,at%N*3)) - allocate(P(at%N*3,at%N*3)) - P = 0.0_dp; call matrix_product_sub(P, zero_phonon_p, zero_phonon, .false., .true.) - deallocate(zero_phonon_p) - P = -P - call add_identity(P) - - fc_mat_t = 0.0_dp; call matrix_product_sub(fc_mat_t, fc_mat, P) - fc_mat = 0.0_dp; call matrix_product_sub(fc_mat, P, fc_mat_t) - deallocate(fc_mat_t) - deallocate(P) - end if - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! symmetrize dynamical matrix exactly - do i=1, 3*at%N - do j=i+1, 3*at%N - sym_val = 0.5_dp*(fc_mat(j,i)+fc_mat(i,j)) - fc_mat(i,j) = sym_val - fc_mat(j,i) = sym_val - end do - end do - - call print("fc_mat", PRINT_NERD) - call print(fc_mat, PRINT_NERD) - - ! diagonalise dynamical matrix - call diagonalise(fc_mat, evals, evecs, error=err) - if (err /= 0) then - call system_abort("calc_phonons got error " // err // " in diagonalise") - endif - - if (override_zero_freq_phonons .and. do_zero_rotation) then - zero_phonon(:,n_zero-1) = zero_phonon(:,n_zero-1)-zero_phonon(:,n_zero-2)*sum(zero_phonon(:,n_zero-1)*zero_phonon(:,n_zero-2)) - zero_phonon(:,n_zero-1) = zero_phonon(:,n_zero-1)/sqrt(sum(zero_phonon(:,n_zero-1)**2)) - zero_phonon(:,n_zero) = zero_phonon(:,n_zero)-zero_phonon(:,n_zero-2)*sum(zero_phonon(:,n_zero)*zero_phonon(:,n_zero-2)) - zero_phonon(:,n_zero) = zero_phonon(:,n_zero)-zero_phonon(:,n_zero-1)*sum(zero_phonon(:,n_zero)*zero_phonon(:,n_zero-1)) - zero_phonon(:,n_zero) = zero_phonon(:,n_zero)/sqrt(sum(zero_phonon(:,n_zero)**2)) - evecs(:,1:n_zero) = zero_phonon - endif - if (n_zero > 0) deallocate(zero_phonon) - -end subroutine dynamical_matrix_solve - -subroutine phonons_all(pot, at, dx, evals, evecs, effective_masses, calc_args, IR_intensities, do_parallel, & - zero_translation, zero_rotation, force_const_mat) - type(Potential), intent(inout) :: pot - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: dx - real(dp), intent(out) :: evals(at%N*3) - real(dp), intent(out), optional :: evecs(at%N*3,at%N*3) - real(dp), intent(out), optional :: effective_masses(at%N*3) - character(len=*), intent(in), optional :: calc_args - real(dp), intent(out), optional :: IR_intensities(:) - logical, intent(in), optional :: do_parallel - logical, intent(in), optional :: zero_translation, zero_rotation - real(dp), intent(out), optional :: force_const_mat(:,:) - - integer i, j, alpha, beta - integer err - real(dp), allocatable :: pos0(:,:), f0(:,:), fp(:,:), fm(:,:) - real(dp) :: E0, Ep, Em - real(dp), allocatable :: dm(:,:) - - real(dp) :: mu_m(3), mu_p(3), dmu_dq(3) - real(dp), allocatable :: dmu_dr(:,:,:) - real(dp), pointer :: local_dn(:), mass(:) - - integer :: n_zero - logical :: do_zero_translation, do_zero_rotation - - integer :: ind - logical :: my_do_parallel - type(MPI_context) :: mpi_glob - - my_do_parallel = optional_default(.false., do_parallel) - - if (my_do_parallel) then - call initialise(mpi_glob) - endif - - do_zero_translation = optional_default(.true., zero_translation) - do_zero_rotation = optional_default(.false., zero_rotation) - - allocate(pos0(3,at%N)) - allocate(f0(3,at%N)) - allocate(fp(3,at%N)) - allocate(fm(3,at%N)) - allocate(dm(at%N*3,at%N*3)) - allocate(dmu_dr(3, at%N, 3)) - - if (present(force_const_mat)) then - if (size(force_const_mat,1) /= size(dm,1) .or. size(force_const_mat,2) /= size(dm,2)) & - call system_abort("phonons received force_const_mat, shape="//shape(force_const_mat) // & - " which doesn't match shape(dm)="//shape(dm)) - endif - - if (present(IR_intensities)) then - if (.not. assign_pointer(at, 'local_dn', local_dn)) then - call add_property(at, 'local_dn', 0.0_dp, 1) - endif - endif - - if (dx == 0.0_dp) & - call system_abort("phonons called with dx == 0.0") - - if (my_do_parallel) then - dm = 0.0_dp - dmu_dr = 0.0_dp - endif - - call set_cutoff(at, cutoff(pot)) - call calc_connect(at) - - call calc(pot, at, energy=E0, force=f0, args_str=calc_args) - pos0 = at%pos - - ! calculate dynamical matrix with finite differences - ind = -1 - do i=1, at%N - do alpha=1,3 - ind = ind + 1 - if (my_do_parallel) then - if (mod(ind, mpi_glob%n_procs) /= mpi_glob%my_proc) cycle - endif - - at%pos = pos0 - at%pos(alpha,i) = at%pos(alpha,i) + dx - call calc_dists(at) - call calc(pot, at, energy=Ep, force=fp, args_str=calc_args) - if (present(IR_intensities)) then - if (.not. assign_pointer(at, 'local_dn', local_dn)) & - call system_abort("phonons impossible failure to assign pointer for local_dn") - mu_p = dipole_moment(at%pos, local_dn) - endif - - at%pos = pos0 - at%pos(alpha,i) = at%pos(alpha,i) - dx - call calc_dists(at) - call calc(pot, at, energy=Em, force=fm, args_str=calc_args) - if (present(IR_intensities)) then - if (.not. assign_pointer(at, 'local_dn', local_dn)) & - call system_abort("phonons impossible failure to assign pointer for local_dn") - mu_m = dipole_moment(at%pos, local_dn) - endif - - call print("dynamical matrix energy check (Em-E0) " // (Em-E0) // " (Ep-E0) " // (Ep-E0), PRINT_NERD) - call print("dynamical matrix magnitude check |fp-f0| " // sqrt(sum(normsq(fp-f0,2))) // " |fm-f0| " // sqrt(sum(normsq(fm-f0,2))) // & - " |fp-f0|-|fm-f0| " // (sqrt(sum(normsq(fp-f0,2)))-sqrt(sum(normsq(fm-f0,2)))), PRINT_NERD) - call print("dynamical matrix harmonicity check (|fp+fm|/2 - f0)/(0.5*(|fp-f0|+|fm-f0|)) "// & - (sqrt(sum(normsq(0.5_dp*(fp+fm)-f0,2)))/(0.5_dp*(sqrt(sum(normsq(fp-f0,2)))+sqrt(sum(normsq(fm-f0,2)))))) , PRINT_NERD) - - dmu_dr(alpha, i, :) = (mu_p-mu_m)/(2.0_dp*dx) - - do j=1, at%N - do beta=1,3 - dm((i-1)*3+alpha,(j-1)*3+beta) = -((fp(beta,j)-fm(beta,j))/(2.0_dp*dx)) - end do - end do - - end do - end do - - at%pos = pos0 - call calc_dists(at) - - if (my_do_parallel) then - call sum_in_place(mpi_glob, dm) - call sum_in_place(mpi_glob, dmu_dr) - endif - - if (.not. assign_pointer(at, 'mass', mass)) & - call add_property(at, 'mass', 0.0_dp, 1) - if (.not. assign_pointer(at, 'mass', mass)) & - call system_abort("impossible failure to assign pointer for mass") - do i=1, at%N - mass(i) = ElementMass(at%Z(i)) - end do - - if (present(force_const_mat)) then - force_const_mat = dm - endif - - call dynamical_matrix_solve(at, dm, evals, evecs, zero_translation, zero_rotation) - - ! transform from evecs of regular eigenproblem to evecs of original generalized eigenproblem - if (present(evecs)) then - do i=1, at%N - evecs((i-1)*3+1:(i-1)*3+3,:) = evecs((i-1)*3+1:(i-1)*3+3,:) / sqrt(ElementMass(at%Z(i))) - end do - endif - - ! calculate effective masses - if (present(effective_masses)) then - do i=1, 3*at%N - effective_masses(i) = 0.0_dp - do j=1, at%N - effective_masses(i) = 1.0_dp/sum(evecs(:,i)**2) - end do - end do - endif - - if (present(IR_intensities)) then - do i=1, at%N*3 - dmu_dq(1) = sum(dmu_dr(:,:,1)*reshape(evecs(:,i), (/ 3, at%N /) ) ) - dmu_dq(2) = sum(dmu_dr(:,:,2)*reshape(evecs(:,i), (/ 3, at%N /) ) ) - dmu_dq(3) = sum(dmu_dr(:,:,3)*reshape(evecs(:,i), (/ 3, at%N /) ) ) - IR_intensities(i) = 3.0_dp/(PI*3.0*10**3)*sum(dmu_dq**2) - end do - endif - - call print("evals", PRINT_VERBOSE) - call print(evals, PRINT_VERBOSE) - if (present(evecs)) then - call print("evecs", PRINT_NERD) - call print(evecs, PRINT_NERD) - endif - if (present(effective_masses)) then - call print("effective masses", PRINT_VERBOSE) - call print(effective_masses, PRINT_VERBOSE) - endif - if (present(IR_intensities)) then - call print("IR intensities", PRINT_VERBOSE) - call print(IR_intensities, PRINT_VERBOSE) - endif - - deallocate(dmu_dr) - deallocate(pos0) - deallocate(fp) - deallocate(fm) - deallocate(dm) - -end subroutine phonons_all - -!subroutine phonons_fine(pot, at_in, dx, phonon_supercell, phonon_supercell_fine, calc_args, do_parallel, phonons_output_file, phonons_path_start, phonons_path_end, phonons_path_steps) -! -! type(Potential), intent(inout) :: pot -! type(Atoms), intent(inout) :: at_in -! real(dp), intent(in) :: dx -! character(len=*), intent(in), optional :: calc_args -! logical, intent(in), optional :: do_parallel -! integer, dimension(3), intent(in), optional :: phonon_supercell, phonon_supercell_fine -! character(len=*), intent(in), optional :: phonons_output_file -! real(dp), dimension(3), intent(in), optional :: phonons_path_start, phonons_path_end -! integer, intent(in), optional :: phonons_path_steps -! -! type(Atoms) :: at, at_fine -! integer :: i, j, k, alpha, beta, nk, n1, n2, n3, jn -! integer, dimension(3) :: do_phonon_supercell, do_phonon_supercell_fine -! -! real(dp), dimension(3) :: pp, diff_ij -! real(dp), dimension(:,:), allocatable :: evals -! real(dp), dimension(:,:), allocatable :: q, pos0 -! real(dp), dimension(:,:,:,:), allocatable :: fp0, fm0, fp0_fine, fm0_fine -! complex(dp), dimension(:,:), allocatable :: dmft -! complex(dp), dimension(:,:,:), allocatable :: evecs -! integer, dimension(:,:), pointer :: phonons_fine_SI, phonons_fine_SI_fine -! -! type(inoutput) :: phonons_output -! real(dp), dimension(:,:), allocatable :: frac -! integer :: do_phonons_path_steps -! integer :: t_real_precision -! -! -! do_phonon_supercell = optional_default((/1,1,1/),phonon_supercell) -! do_phonon_supercell_fine = optional_default(do_phonon_supercell,phonon_supercell_fine) -! -! if( any( do_phonon_supercell_fine < do_phonon_supercell ) ) & -! call system_abort("phonons_fine: phonon_supercell = ("//phonon_supercell//") greater than phonon_supercell_fine =("//phonon_supercell_fine//")") -! -! call supercell(at,at_in,do_phonon_supercell(1),do_phonon_supercell(2),do_phonon_supercell(3),supercell_index_name="phonons_fine_SI") -! -! if (present(phonons_path_start) .and. present(phonons_path_end)) then -! do_phonons_path_steps = optional_default(3, phonons_path_steps) -! nk = do_phonons_path_steps + 2 -! allocate(q(3, nk)) -! -! do i = 1, nk -! q(:, i) = 2.0_dp * PI * matmul((phonons_path_start + ((phonons_path_end - phonons_path_start) * (real((i - 1), dp) / real((nk - 1), dp)))), at_in%g) -! enddo -! else -! nk = product(do_phonon_supercell_fine) -! allocate(q(3,nk)) -! -! i = 0 -! do n1 = 0, do_phonon_supercell_fine(1)-1 -! do n2 = 0, do_phonon_supercell_fine(2)-1 -! do n3 = 0, do_phonon_supercell_fine(3)-1 -! i = i + 1 -! -! q(:,i) = 2*PI*matmul( ( (/real(n1,dp),real(n2,dp),real(n3,dp)/) / do_phonon_supercell_fine ), at_in%g ) -! enddo -! enddo -! enddo -! endif -! -! allocate(evals(at_in%N*3,nk), evecs(at_in%N*3,at_in%N*3,nk)) !, dm(at%N*3,at%N*3)) -! allocate(pos0(3,at%N)) -! -! if (dx == 0.0_dp) & -! call system_abort("phonons called with dx == 0.0") -! -! call set_cutoff(at, cutoff(pot)+0.5_dp) -! call calc_connect(at) -! -! pos0 = at%pos -! -! ! calculate dynamical matrix with finite differences -!! do i=1, at%N -!! do alpha=1,3 -!! -!! at%pos = pos0 -!! at%pos(alpha,i) = at%pos(alpha,i) + dx -!! call calc_dists(at) -!! call calc(pot, at, force=fp, args_str=calc_args) -!! -!! at%pos = pos0 -!! at%pos(alpha,i) = at%pos(alpha,i) - dx -!! call calc_dists(at) -!! call calc(pot, at, force=fm, args_str=calc_args) -!! -!! do j=1, at%N -!! do beta=1,3 -!! dm((i-1)*3+alpha,(j-1)*3+beta) = -((fp(beta,j)-fm(beta,j))/(2.0_dp*dx)) -!! end do -!! end do -!! -!! end do -!! end do -! -! ! that works for perfect diamond cells only -! allocate(fp0(3,at%N,3,at_in%N),fm0(3,at%N,3,at_in%N)) -! -! do i = 1, at_in%N -! call print('Displacing atom '//i//' of '//at_in%N) -! do alpha = 1, 3 -! at%pos = pos0 -! at%pos(alpha,i) = at%pos(alpha,i) + dx -! call calc_dists(at) -! call calc(pot, at, force=fp0(:,:,alpha,i), args_str=calc_args) -! -! at%pos = pos0 -! at%pos(alpha,i) = at%pos(alpha,i) - dx -! call calc_dists(at) -! call calc(pot, at, force=fm0(:,:,alpha,i), args_str=calc_args) -! enddo -! enddo -! -! at%pos = pos0 -! call calc_dists(at) -! -!! do i = 1, at_in%N ! move atom i -!! -!! do ni1 = 0, do_phonon_supercell(1)-1 -!! do ni2 = 0, do_phonon_supercell(2)-1 -!! do ni3= 0, do_phonon_supercell(3)-1 -!! ni = ((ni1*do_phonon_supercell(2)+ni2)*do_phonon_supercell(3)+ni3)*at_in%N+i -!! -!! do alpha = 1, 3 -!! do j = 1, at_in%N ! force on atom j -!! do nj1 = 0, do_phonon_supercell(1)-1 -!! do nj2 = 0, do_phonon_supercell(2)-1 -!! do nj3= 0, do_phonon_supercell(3)-1 -!! shift = (/nj1,nj2,nj3/) - (/ni1,ni2,ni3/) + do_phonon_supercell -!! shift(1) = mod(shift(1),do_phonon_supercell(1)) -!! shift(2) = mod(shift(2),do_phonon_supercell(2)) -!! shift(3) = mod(shift(3),do_phonon_supercell(3)) -!! nj = ((nj1*do_phonon_supercell(2)+nj2)*do_phonon_supercell(3)+nj3)*at_in%N+j -!! nj_orig = ((shift(1)*do_phonon_supercell(2)+shift(2))*do_phonon_supercell(3)+shift(3))*at_in%N+j -!! do beta = 1, 3 -!! dm((ni-1)*3+alpha,(nj-1)*3+beta) = & -!! & -((fp0(beta,nj_orig,alpha,i)-fm0(beta,nj_orig,alpha,i))/(2.0_dp*dx)) -!! enddo -!! enddo -!! enddo -!! enddo -!! enddo -!! enddo -!! enddo -!! enddo -!! enddo -!! enddo -! -!! deallocate(fp0,fm0) -! -! at%pos = pos0 -! call calc_dists(at) -! deallocate(pos0) -! -! call supercell(at_fine,at_in,do_phonon_supercell_fine(1),do_phonon_supercell_fine(2),do_phonon_supercell_fine(3),supercell_index_name="phonons_fine_SI_fine") -! if(.not. assign_pointer(at,"phonons_fine_SI",phonons_fine_SI) .or. .not. assign_pointer(at_fine,"phonons_fine_SI_fine",phonons_fine_SI_fine)) & -! call system_abort("phonons_fine: couldn't assign phonons_fine_SI and phonons_fine_SI_fine pointers") -! -! allocate(fp0_fine(3,at_fine%N,3,at_in%N),fm0_fine(3,at_fine%N,3,at_in%N)) -! fp0_fine = 0.0_dp -! fm0_fine = 0.0_dp -! -! do i = 1, at%N -! do j = 1, at_fine%N -! !print*,phonons_fine_SI(:,i) -! !print*,phonons_fine_SI_fine(:,i) -! if( all( & -! ( phonons_fine_SI(:,i) - nint( real(phonons_fine_SI(:,i),dp) / real(do_phonon_supercell,dp) ) * do_phonon_supercell ) & -! == & -! ( phonons_fine_SI_fine(:,j) - nint( real(phonons_fine_SI_fine(:,j),dp) / real(do_phonon_supercell_fine,dp) ) * do_phonon_supercell_fine ) & -! ) .and. mod(i,at_in%N) == mod(j,at_in%N) ) then -! fp0_fine(:,j,:,:) = fp0(:,i,:,:) -! fm0_fine(:,j,:,:) = fm0(:,i,:,:) -! endif -! enddo -! enddo -! -! ! transform from generalized eigenproblem to regular eigenproblem -!! do i = 1, at%N -!! do j = 1, at%N -!! dm((i-1)*3+1:(i-1)*3+3,(j-1)*3+1:(j-1)*3+3) = dm((i-1)*3+1:(i-1)*3+3,(j-1)*3+1:(j-1)*3+3) / & -!! sqrt(ElementMass(at%Z(i))*ElementMass(at%Z(j))) -!! enddo -!! enddo -! -! ! symmetrize dynamical matrix exactly -!! do i = 1, 3*at%N -!! do j = i+1, 3*at%N -!! dm(i,j) = dm(j,i) -!! enddo -!! enddo -! -!!$omp parallel private(dmft) -! allocate(dmft(at_in%N*3,at_in%N*3)) -!!$omp do private(k,i,j,alpha,beta,diff_ij,n1,n2,n3,pp,jn) -! do k = 1, nk -! dmft = CPLX_ZERO -! do i = 1, at_in%N -! do alpha = 1, 3 -! do j = 1, at_in%N -! diff_ij = at_in%pos(:,j) - at_in%pos(:,i) -! do beta = 1, 3 -! -! do n1 = 0, do_phonon_supercell_fine(1)-1 -! do n2 = 0, do_phonon_supercell_fine(2)-1 -! do n3= 0, do_phonon_supercell_fine(3)-1 -! -! pp = at_in%lattice .mult. (/n1,n2,n3/) -! jn = ((n1*do_phonon_supercell_fine(2)+n2)*do_phonon_supercell_fine(3)+n3)*at_in%N+j -! -! dmft((i-1)*3+alpha,(j-1)*3+beta) = dmft((i-1)*3+alpha,(j-1)*3+beta) & -! & - ((fp0_fine(beta,jn,alpha,i)-fm0_fine(beta,jn,alpha,i))/(2.0_dp*dx)) / & -! & sqrt(ElementMass(at_in%Z(i))*ElementMass(at_in%Z(j))) & -! & * exp( CPLX_IMAG * dot_product(q(:,k),(diff_ij+pp)) ) -! -! enddo -! enddo -! enddo -! enddo -! enddo -! enddo -! enddo -! do i = 1, 3*at_in%N -! dmft(i,i) = CPLX_ONE*real(dmft(i,i)) -! do j = i+1, 3*at_in%N -! dmft(i,j) = conjg(dmft(j,i)) -! enddo -! enddo -! call diagonalise(dmft, evals(:,k), evecs(:,:,k)) -! enddo -!!$omp end do -!deallocate(dmft) -!!$omp end parallel -! -! t_real_precision = mainlog%default_real_precision -! do k = 1, nk -!! call print('q: '//q(:,k)*a/(2*PI)) -! !call print(evecs(:,:,k)) -! mainlog%default_real_precision=6 -! call print("PHONONS_FINE "//q(:,k), nocr=.true.) -! mainlog%default_real_precision=9 -! call print(" "//sign(sqrt(abs(evals(:,k))),evals(:,k))/2.0_dp/PI*1000.0_dp) -! ! print '("PHONONS_FINE ",3F12.6," ",'//at_in%N*3//'f15.9)',q(:,k),sign(sqrt(abs(evals(:,k))),evals(:,k))/2.0_dp/PI*1000.0_dp -! enddo -! mainlog%default_real_precision = t_real_precision -! -!! if (present(phonons_output_file)) then -!! call initialise(phonons_output, phonons_output_file, action=OUTPUT) -!! -!! call print(" BEGIN header", file=phonons_output) -!! call print(" Number of ions " // at_in%N, file=phonons_output) -!! call print(" Number of branches " // (at_in%N*3), file=phonons_output) -!! call print(" Number of wavevectors " // nk, file=phonons_output) -!! call print(" Frequencies in fs-1", file=phonons_output) -!! call print(" Unit cell vectors (A)", file=phonons_output) -!! do i = 1, 3 -!! call print(" " // at_in%lattice(1, i) // " " // at_in%lattice(2, i) // " " // at_in%lattice(3, i), file=phonons_output) -!! enddo -!! call print(" Fractional Co-ordinates", file=phonons_output) -!! allocate(frac(3, at_in%N)) -!! frac = at_in%g .mult. at_in%pos -!! do i = 1, at_in%N -!! call print(" " // i // " " // frac(1, i) // " " // frac(2, i) // " " // frac(3, i) & -!! & // " " // ElementName(at_in%Z(i)) // " " // ElementMass(at_in%Z(i)), file=phonons_output) -!! enddo -!! deallocate(frac) -!! call print(" END header", file=phonons_output) -!! -!! do i = 1, nk -!! call print(" q-pt= " // i // " " // q(1, i) // " " // q(2, i) // " " // q(3, i) // " " // (1.0_dp / real(nk, dp)), file=phonons_output) -!! do j = 1, (at_in%N*3) -!! call print(" " // j // " " // (sign(sqrt(abs(evals(j,i))),evals(j,i))/2.0_dp/PI*1000.0_dp), file=phonons_output) -!! enddo -!! call print(" Phonon Eigenvectors", file=phonons_output) -!! call print("Mode Ion X Y Z", file=phonons_output) -!! do j = 1, (at_in%N*3) -!! do k = 1, at_in%N -!! call print(" " // j // " " // k // " " // evecs(j, (3 * (k - 1)) + 1, i) & -!! & // " " // evecs(j, (3 * (k - 1)) + 2, i) & -!! & // " " // evecs(j, (3 * (k - 1)) + 3, i), file=phonons_output) -!! enddo -!! enddo -!! enddo -!! -!! call finalise(phonons_output) -!! endif -! -! deallocate(q, evals, evecs) -! call finalise(at) -! -!endsubroutine phonons_fine -endmodule phonons_module diff --git a/src/Utils/real_space_covariance.f95 b/src/Utils/real_space_covariance.f95 deleted file mode 100644 index 8701ffaebc..0000000000 --- a/src/Utils/real_space_covariance.f95 +++ /dev/null @@ -1,1101 +0,0 @@ -module real_space_covariance_module - - use libatoms_module - - implicit none - - private - - !% 24-point quaternion grid from centers of the cells of a - !% truncated-cubic tetracontaoctachoron (48-cell), coverage angle - !% alpha=62.8 degrees. See http://charles.karney.info/orientation - real(dp), dimension(4,24) :: quat_grid_c48u1 = reshape( & - (/1. , 0. , 0. , 0. , & - 0. , 1. , 0. , 0. , & - 0. , 0. , 1. , 0. , & - 0. , 0. , 0. , 1. , & - 0.5 , 0.5 , 0.5 , 0.5 , & - 0.5 , 0.5 , 0.5 , -0.5 , & - 0.5 , 0.5 , -0.5 , 0.5 , & - 0.5 , 0.5 , -0.5 , -0.5 , & - 0.5 , -0.5 , 0.5 , 0.5 , & - 0.5 , -0.5 , 0.5 , -0.5 , & - 0.5 , -0.5 , -0.5 , 0.5 , & - 0.5 , -0.5 , -0.5 , -0.5 , & - 0.70710678, 0.70710678, 0. , 0. , & - 0.70710678, -0.70710678, 0. , 0. , & - 0.70710678, 0. , 0.70710678, 0. , & - 0.70710678, 0. , -0.70710678, 0. , & - 0.70710678, 0. , 0. , 0.70710678, & - 0.70710678, 0. , 0. , -0.70710678, & - 0. , 0.70710678, 0.70710678, 0. , & - 0. , 0.70710678, -0.70710678, 0. , & - 0. , 0.70710678, 0. , 0.70710678, & - 0. , 0.70710678, 0. , -0.70710678, & - 0. , 0. , 0.70710678, 0.70710678, & - 0. , 0. , 0.70710678, -0.70710678 /), (/4, 24/)) - - public RealSpaceCovariance - type RealSpaceCovariance - integer n, n_grid_minim - type(Atoms), dimension(:), allocatable :: data - real(dp) :: sigma_alpha, sigma_beta, sigma_covariance, sigma_error, cutoff, transition_width, covariance_tol - real(dp), allocatable, dimension(:) :: k - real(dp), allocatable, dimension(:,:) :: covariance_matrix, cov_inv, q_min, rot_force, & - distance_matrix, force_covariance_matrix, force_difference_matrix - real(dp), allocatable, dimension(:,:,:) :: alignment - end type RealSpaceCovariance - - type minimise_overlap - integer tag1, tag2 - type(atoms), pointer :: at1, at2 - type(RealSpaceCovariance), pointer :: rscov - endtype minimise_overlap - - type optimise_likelihood - logical use_qr - type(RealSpaceCovariance), pointer :: rscov - endtype optimise_likelihood - - public initialise - interface initialise - module procedure realspacecovariance_initialise - end interface initialise - - public finalise - interface finalise - module procedure realspacecovariance_finalise - end interface finalise - - public teach - interface teach - module procedure realspacecovariance_teach - end interface teach - - public predict - interface predict - module procedure realspacecovariance_predict - end interface predict - - public predict_2 - interface predict_2 - module procedure realspacecovariance_predict_2 - end interface predict_2 - - public predict_3 - interface predict_3 - module procedure realspacecovariance_predict_3 - end interface predict_3 - - public covariance - interface covariance - module procedure realspacecovariance_covariance - end interface covariance - - public align - interface align - module procedure realspacecovariance_align_pair - module procedure realspacecovariance_align_with_data_set - module procedure realspacecovariance_align_data_sets - end interface align - - public set_n - interface set_n - module procedure realspacecovariance_set_n - end interface set_n - - public centre_on_atom_1 - - - public minimise_overlap - public overlap_func, doverlap_func - public random_quaternion, rotmat_quaternion, drotmat_dquaternion - - contains - - subroutine realspacecovariance_finalise(this) - type(realspacecovariance), intent(inout) :: this - integer i - - if (allocated(this%data)) then - do i=1,size(this%data) - call finalise(this%data(i)) - end do - deallocate(this%data) - end if - this%n = 0 - if (allocated(this%covariance_matrix)) deallocate(this%covariance_matrix) - if (allocated(this%cov_inv)) deallocate(this%cov_inv) - if (allocated(this%distance_matrix)) deallocate(this%distance_matrix) - if (allocated(this%force_covariance_matrix)) deallocate(this%force_covariance_matrix) - if (allocated(this%force_difference_matrix)) deallocate(this%force_difference_matrix) - if (allocated(this%q_min)) deallocate(this%q_min) - if (allocated(this%rot_force)) deallocate(this%rot_force) - if (allocated(this%k)) deallocate(this%k) - if (allocated(this%alignment)) deallocate(this%alignment) - - end subroutine realspacecovariance_finalise - - subroutine realspacecovariance_initialise(this, n, n_grid_minim, sigma_alpha, sigma_beta, & - sigma_covariance, sigma_error, cutoff_in, transition_width, covariance_tol) - type(realspacecovariance), intent(inout) :: this - integer, intent(in) :: n, n_grid_minim - real(dp), intent(in) :: sigma_alpha, sigma_beta, sigma_covariance, sigma_error, cutoff_in, transition_width, covariance_tol - - integer i, j - real(dp) tmp_lattice(3,3) - - call finalise(this) - - this%n = n - this%n_grid_minim = n_grid_minim - this%sigma_alpha = sigma_alpha - this%sigma_beta = sigma_beta - this%sigma_covariance = sigma_covariance - this%sigma_error = sigma_error - this%cutoff = cutoff_in - this%transition_width = transition_width - this%covariance_tol = covariance_tol - - allocate(this%data(n)) - allocate(this%covariance_matrix(size(this%data),size(this%data)), this%cov_inv(size(this%data),size(this%data))) - allocate(this%distance_matrix(size(this%data),size(this%data)), this%force_covariance_matrix(size(this%data),size(this%data)) ) - allocate(this%force_difference_matrix(size(this%data),size(this%data)) ) - allocate(this%q_min(4,size(this%data))) - allocate(this%rot_force(3,size(this%data))) - allocate(this%k(size(this%data))) - allocate(this%alignment(4,size(this%data),size(this%data))) - - tmp_lattice(:,:) = 0.0_dp - do i=1,size(this%data) - call initialise(this%data(i), 0, tmp_lattice) - this%q_min(:,i) = (/ 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp /) - do j=1,size(this%data) - this%alignment(:,i,j) = (/ 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp /) - end do - end do - - end subroutine realspacecovariance_initialise - - subroutine realspacecovariance_set_n(this, n) - type(realspacecovariance), intent(inout) :: this - integer, intent(in) :: n - - call finalise(this) - call initialise(this, n, this%n_grid_minim, this%sigma_alpha, this%sigma_beta, this%sigma_covariance, & - this%sigma_error, this%cutoff, this%transition_width, this%covariance_tol) - - end subroutine realspacecovariance_set_n - - - ! Return uniform random unit quaternion. From - ! K. Shoesmith, Uniform Random Rotations, in D. Kirk (ed.) - ! Graphics Gems III, pages 124-132, Academic Press (1992). - function random_quaternion() - real(dp), dimension(4) :: random_quaternion - - real(dp) :: rand0, rand1, rand2, r1, r2, t1, t2 - - rand0 = ran_uniform() - rand1 = ran_uniform() - rand2 = ran_uniform() - - r1 = sqrt(1.0_dp - rand0) - r2 = sqrt(rand0) - t1 = PI*2.0_dp * rand1 - t2 = PI*2.0_dp * rand2 - random_quaternion = (/cos(t2)*r2, sin(t1)*r1, & - cos(t1)*r1, sin(t2)*r2/) - - end function random_quaternion - - subroutine overlap_rho_rot_rho(this,at1,at2,q,overlap,doverlap) - type(RealSpaceCovariance), intent(in) :: this - type(Atoms), intent(in) :: at1, at2 - real(dp), dimension(4), intent(in), optional :: q - real(dp), dimension(4), intent(out), optional :: doverlap - real(dp), intent(out), optional :: overlap - - real(dp) :: diff_ij(3), rot(3,3), drot(3,3,4), overlap_ij, r_i, r_j, fcut_i, fcut_j, sigma_i, sigma_j - real(dp), dimension(:,:), allocatable :: pos - real(dp), dimension(:,:,:), allocatable :: dpos - integer :: i, j, k - - if(.not. present(overlap) .and. .not.present(doverlap)) return - - allocate(pos(3,at2%N)) - - if (present(q)) then - rot = rotmat_quaternion(q) - pos = matmul(rot,at2%pos) - else - pos = at2%pos - end if - - if(present(overlap)) overlap = 0.0_dp - - if(present(doverlap)) then - allocate(dpos(3,at2%N,4)) - if (present(q)) then - drot = drotmat_dquaternion(q) - else - drot = 0.0_dp - end if - - do i = 1, 4 - dpos(:,:,i) = matmul(drot(:,:,i),at2%pos) - enddo - doverlap = 0.0_dp - endif - - do i = 2, at1%N - r_i = norm(at1%pos(:,i)) - if (r_i > this%cutoff) cycle - fcut_i = coordination_function(r_i, this%cutoff, this%transition_width) - sigma_i = this%sigma_alpha*r_i**2 + this%sigma_beta - - do j = 2, at2%N - r_j = norm(at2%pos(:,j)) - if (r_j > this%cutoff) cycle - fcut_j = coordination_function(r_j, this%cutoff, this%transition_width) - sigma_j = this%sigma_alpha*r_j**2 + this%sigma_beta - - diff_ij = at1%pos(:,i)-pos(:,j) - overlap_ij = sigma_i*sigma_j/sqrt(sigma_i**2 + sigma_j**2) * & - exp(-sum( diff_ij**2 ) /(2.0_dp*(sigma_i**2 + sigma_j**2)))*fcut_i*fcut_j - - !write (*,*) i, j, r_i, r_j, sigma_i, sigma_j, overlap_ij - - if(present(overlap)) overlap = overlap + overlap_ij - - if(present(doverlap)) then - do k = 1, 4 - doverlap(k) = doverlap(k) + dot_product(diff_ij,dpos(:,j,k))*overlap_ij / (sigma_i**2 + sigma_j**2) - enddo - endif - - enddo - enddo - - if(allocated(dpos)) deallocate(dpos) - if(allocated(pos)) deallocate(pos) - - endsubroutine overlap_rho_rot_rho - - function overlap_func(x,am_data) - real(dp), dimension(:) :: x - character(len=1), dimension(:), optional :: am_data - - real(dp) :: overlap_func - type(minimise_overlap) :: am - - am = transfer(am_data,am) - call overlap_rho_rot_rho(am%rscov,am%at1,am%at2,x,overlap=overlap_func) - - overlap_func = -overlap_func - endfunction overlap_func - - function doverlap_func(x,am_data) - real(dp), dimension(:) :: x - character(len=1), dimension(:), optional :: am_data - - real(dp), dimension(size(x)) :: doverlap_func - type(minimise_overlap) :: am - - am = transfer(am_data,am) - call overlap_rho_rot_rho(am%rscov,am%at1,am%at2,x,doverlap=doverlap_func) - - doverlap_func = -doverlap_func - endfunction doverlap_func - - function sum_overlap_func(x,am_data) - real(dp), dimension(:) :: x - character(len=1), dimension(:), optional :: am_data - - integer i, j - integer tag_i, tag_j - real(dp) :: time_i, time_j - real(dp) :: overlap, sum_overlap_func, weight - type(minimise_overlap) :: am - - am = transfer(am_data,am) - - if (am%tag2 == 0) then - if (.not. get_value(am%at1%params, 'time', time_j)) then - call system_abort('cannot find time in at1') - end if - end if - - sum_overlap_func = 0.0_dp - do i=1,size(am%rscov%data) - if (.not. get_value(am%rscov%data(i)%params, 'tag', tag_i)) then - call system_abort('cannot find tag in rscov%data('//i//')') - end if - if (.not. get_value(am%rscov%data(i)%params, 'time', time_i)) then - call system_abort('cannot find time in rscov%data('//i//')') - end if - if (tag_i /= am%tag1) cycle - - if (am%tag2 /= 0) then - do j=1,size(am%rscov%data) - if(.not. get_value(am%rscov%data(j)%params, 'tag', tag_j)) then - call system_abort('cannot find tag in rscov%data('//j//')') - end if - if (tag_j /= am%tag2) cycle - - call overlap_rho_rot_rho(am%rscov,am%rscov%data(i),am%rscov%data(j),x,overlap=overlap) - weight = 1.0_dp !exp(-abs(time_i-time_j)/am%rscov%tau) - sum_overlap_func = sum_overlap_func + weight*overlap - end do - else - call overlap_rho_rot_rho(am%rscov,am%rscov%data(i),am%at1,x,overlap=overlap) - weight = 1.0_dp !exp(-abs(time_i-time_j)/am%rscov%tau) - sum_overlap_func = sum_overlap_func + weight*overlap - end if - end do - sum_overlap_func = -sum_overlap_func - - end function sum_overlap_func - - function sum_doverlap_func(x,am_data) - real(dp), dimension(:) :: x - character(len=1), dimension(:), optional :: am_data - - integer i, j - integer :: tag_i, tag_j - real(dp) :: time_i, time_j, weight - real(dp) :: doverlap(size(x)), sum_doverlap_func(size(x)) - type(minimise_overlap) :: am - - am = transfer(am_data,am) - - if (am%tag2 == 0) then - if (.not. get_value(am%at1%params, 'time', time_j)) then - call system_abort('cannot find time in at1') - end if - end if - - sum_doverlap_func = 0.0_dp - do i=1,size(am%rscov%data) - if(.not. get_value(am%rscov%data(i)%params, 'tag', tag_i)) then - call system_abort('cannot find tag in rscov%data('//i//')') - end if - if (.not. get_value(am%rscov%data(i)%params, 'time', time_i)) then - call system_abort('cannot find time in rscov%data('//i//')') - end if - if (tag_i /= am%tag1) cycle - - if (am%tag2 /= 0) then - do j=1,size(am%rscov%data) - if(.not. get_value(am%rscov%data(j)%params, 'tag', tag_j)) then - call system_abort('cannot find tag in rscov%data('//j//')') - end if - if (.not. get_value(am%rscov%data(j)%params, 'time', time_j)) then - call system_abort('cannot find time in rscov%data('//i//')') - end if - if (tag_j /= am%tag2) cycle - - call overlap_rho_rot_rho(am%rscov,am%rscov%data(i),am%rscov%data(j),x,doverlap=doverlap) - weight = 1.0_dp !exp(-abs(time_i-time_j)/am%rscov%tau) - sum_doverlap_func = sum_doverlap_func + weight*doverlap - end do - else - call overlap_rho_rot_rho(am%rscov,am%rscov%data(i),am%at1,x,doverlap=doverlap) - weight = 1.0_dp !exp(-abs(time_i-time_j)/am%rscov%tau) - sum_doverlap_func = sum_doverlap_func + weight*doverlap - end if - end do - sum_doverlap_func = -sum_doverlap_func - - end function sum_doverlap_func - - function rotmat(a) - real(dp), dimension(3), intent(in) :: a - real(dp), dimension(3,3) :: rotmat - - real(dp) :: c1, c2, c3, s1, s2, s3 - - c1 = cos(a(1)) - c2 = cos(a(2)) - c3 = cos(a(3)) - s1 = sin(a(1)) - s2 = sin(a(2)) - s3 = sin(a(3)) - - rotmat(1,1) = c1*c2*c3 - s1*s3; rotmat(1,2) = -c1*s2; rotmat(1,3) = c2*c1*s3 + c3*s1 - rotmat(2,1) = c3*s2; rotmat(2,2) = c2; rotmat(2,3) = s3*s2 - rotmat(3,1) = -c1*s3 - c3*c2*s1; rotmat(3,2) = s2*s1; rotmat(3,3) = c1*c3 - c2*s1*s3 - - endfunction rotmat - - - !% Find the quaterion corresponding to the rotation which maximise the overlap - !% between the atomic densities of at1 and at2, starting minimisations at each - !% quaterion in the (4,n) array qs - function realspacecovariance_align_pair(this, at1, at2, qs, overlap) result(q) - type(RealSpaceCovariance), intent(in), target :: this - type(Atoms), intent(in), target :: at1, at2 - real(dp), intent(in) :: qs(:,:) - real(dp), optional, intent(out) :: overlap - real(dp) q(4) - - real(dp) :: this_overlap, max_overlap, this_q(4) - type(minimise_overlap) :: am - integer :: am_data_size, n_minim, i - character(len=1), dimension(1) :: am_mold - character(len=1), allocatable :: am_data(:) - - am_data_size = size(transfer(am,am_mold)) - allocate(am_data(am_data_size)) - am%rscov => this - am%at1 => at1 - am%at2 => at2 - am_data = transfer(am,am_mold) - max_overlap = -huge(1.0_dp) - - do i=1,size(qs,2) - this_q = qs(:,i) - n_minim = minim(this_q, overlap_func,doverlap_func, method='cg', & - convergence_tol=this%covariance_tol, max_steps = 100, data=am_data) - - this_overlap = -overlap_func(this_q,am_data=am_data) - if (this_overlap > max_overlap) then - max_overlap = this_overlap - q = this_q - end if - end do - - q = q/norm(q) - if (present(overlap)) overlap = max_overlap - deallocate(am_data) - - end function realspacecovariance_align_pair - - !% Align the configuration 'at' with the set of configurations in 'this%data' - !% which have tag equal to 'tag'. Objective function is sum of overlaps. - !% A single minimisation is performed, starting from quaterions in 'qs'. - function realspacecovariance_align_with_data_set(this, at, tag, qs, overlap) result(q) - type(RealSpaceCovariance), intent(in), target :: this - type(Atoms), intent(in), target :: at - integer, intent(in) :: tag - real(dp), intent(in) :: qs(:,:) - real(dp), optional, intent(out) :: overlap - real(dp) :: q(4) - - real(dp) :: this_overlap, max_overlap, this_q(4) - type(minimise_overlap) :: am - integer :: am_data_size, n_minim, i - character(len=1), dimension(1) :: am_mold - character(len=1), allocatable :: am_data(:) - - am_data_size = size(transfer(am,am_mold)) - allocate(am_data(am_data_size)) - am%rscov => this - am%at1 => at - am%tag1 = tag - am%tag2 = 0 - am_data = transfer(am, am_mold) - max_overlap = -huge(1.0_dp) - - call n_test_gradient(q,sum_overlap_func,sum_doverlap_func,data=am_data) - print*, test_gradient(q,overlap_func,doverlap_func,data=am_data) - - do i=1,size(qs,2) - this_q = qs(:,i) - n_minim = minim(this_q, sum_overlap_func, sum_doverlap_func, method='cg', & - convergence_tol=this%covariance_tol, max_steps = 100, data=am_data) - this_overlap = -sum_overlap_func(this_q,am_data=am_data) - if (this_overlap > max_overlap) then - max_overlap = this_overlap - q = this_q - end if - end do - - q = q/norm(q) - if (present(overlap)) overlap = max_overlap - deallocate(am_data) - - end function realspacecovariance_align_with_data_set - - - !% Align two sets of configurations, identified by the tags 'tag1' and 'tag2' - function realspacecovariance_align_data_sets(this, tag1, tag2, qs, overlap) result(q) - type(RealSpaceCovariance), intent(in), target :: this - integer, intent(in) :: tag1, tag2 - real(dp), intent(in) :: qs(:,:) - real(dp), optional, intent(out) :: overlap - real(dp) q(4) - - real(dp) :: this_overlap, max_overlap, this_q(4) - type(minimise_overlap) :: am - integer :: am_data_size, n_minim, i - character(len=1), dimension(1) :: am_mold - character(len=1), allocatable :: am_data(:) - - am_data_size = size(transfer(am,am_mold)) - allocate(am_data(am_data_size)) - am%rscov => this - am%tag1 = tag1 - am%tag2 = tag2 - am_data = transfer(am, am_mold) - max_overlap = -huge(1.0_dp) - - - - do i=1,size(qs,2) - this_q = qs(:,i) - n_minim = minim( this_q, sum_overlap_func, sum_doverlap_func, method='cg', & - convergence_tol=this%covariance_tol, max_steps = 100, data=am_data) - this_overlap = -sum_overlap_func(this_q,am_data=am_data) - if (this_overlap > max_overlap) then - max_overlap = this_overlap - q = this_q - end if - end do - - q = q/norm(q) - if (present(overlap)) overlap = -sum_overlap_func(q,am_data=am_data) - deallocate(am_data) - - end function realspacecovariance_align_data_sets - - function realspacecovariance_covariance(this, at1, at2, q, distance, force_covariance, force_difference, do_align) result(covariance) - type(realspacecovariance), intent(inout) :: this - type(Atoms), intent(in) :: at1, at2 - real(dp), intent(inout) :: q(4) - real(dp), intent(out), optional :: distance, force_covariance, force_difference - logical, intent(in), optional :: do_align - - real(dp) :: covariance - real(dp) :: d2, rho1_2, rho2_2, rho_12, rot(3,3) - real(dp), dimension(:,:), pointer :: force1_ptr, force2_ptr - logical my_do_align - - my_do_align = optional_default(.true., do_align) - if (my_do_align) then - q = align(this, at1, at2, reshape(q, (/1,4/))) - end if - - if(present(force_covariance) .or. present(force_difference)) then - rot = rotmat_quaternion(q) - call assign_property_pointer(at1, 'force', ptr=force1_ptr) - call assign_property_pointer(at2, 'force', ptr=force2_ptr) - if (present(force_difference)) & - force_difference = sqrt(sum((force1_ptr(:,1) - matmul(rot, force2_ptr(:,1)))**2)) - if (present(force_covariance)) & - force_covariance = dot_product( force1_ptr(:,1), matmul(rot,force2_ptr(:,1)) ) - endif - - call overlap_rho_rot_rho(this,at1,at1,overlap=rho1_2) - call overlap_rho_rot_rho(this,at2,at2,overlap=rho2_2) - call overlap_rho_rot_rho(this,at1,at2,q=q, overlap=rho_12) - d2 = rho1_2 + rho2_2 - 2.0_dp*rho_12 - if(present(distance)) distance = d2 - covariance = exp(-0.5_dp*d2/this%sigma_covariance**2) - - end function realspacecovariance_covariance - - subroutine realspacecovariance_teach(this, do_optimise, use_qr) - type(realspacecovariance), intent(inout), target :: this - logical, intent(in) :: do_optimise, use_qr - - integer :: am_data_size - character(len=1), dimension(1) :: am_mold - character(len=1), allocatable :: am_data(:) - real(dp) :: x_sigma(2) - - type(optimise_likelihood) :: am_likelihood - integer i,j,n - - do i=1,size(this%data) - call centre_on_atom_1(this%data(i)) - end do - - call system_timer('covariance') - call verbosity_push(PRINT_SILENT) - !$omp parallel default(none) shared(this) private(j) - !$omp do - do i=1,size(this%data) - do j=i,size(this%data) - this%covariance_matrix(i,j) = covariance(this, this%data(i), this%data(j), & - q=this%alignment(:,i,j), & - distance=this%distance_matrix(i,j), force_covariance=this%force_covariance_matrix(i,j), & - force_difference=this%force_difference_matrix(i,j)) - - this%covariance_matrix(j,i) = this%covariance_matrix(i,j) - this%distance_matrix(j,i) = this%distance_matrix(i,j) - this%force_covariance_matrix(j,i) = this%force_covariance_matrix(i,j) - this%force_difference_matrix(j,i) = this%force_difference_matrix(i,j) - this%alignment(:,j,i) = (/ this%alignment(1,i,j), -this%alignment(2:4,j,i) /) !quaterion conjugate - end do - this%covariance_matrix(i,i) = this%covariance_matrix(i,i) + this%sigma_error**2 - end do - !$omp end parallel - call system_timer('covariance') - call verbosity_pop() - - mainlog%prefix = 'DISTANCE ' - call print(this%distance_matrix) - - mainlog%prefix = 'FORCEDIF ' - call print(this%force_difference_matrix) - - mainlog%prefix = 'FORCECOV ' - call print(this%force_covariance_matrix) - - mainlog%prefix = 'COV1 ' - call print(this%covariance_matrix) - - call inverse(this%covariance_matrix, this%cov_inv) - mainlog%prefix = 'INV1 ' - call print(this%cov_inv) - mainlog%prefix = '' - - if (do_optimise) then - am_likelihood%use_qr = use_qr - am_likelihood%rscov => this - am_data_size = size(transfer(am_likelihood,am_mold)) - allocate(am_data(am_data_size)) - am_data = transfer(am_likelihood,am_mold) - - ! Testing the implementation of likelihood and dlikelihood. - if(.false.) then - call print('starting test gradient') - call verbosity_push(PRINT_VERBOSE) - write (*,*) test_gradient((/this%sigma_error,this%sigma_covariance/),likelihood,dlikelihood,data=am_data) - call verbosity_pop() - endif - call print_title('likelihood optimisation') - - if (use_qr) then - call print('doing likelihood optimisation with QR decomposition') - else - call print('doing likelihood optimisation with Cholesky decomposition') - end if - x_sigma = (/this%sigma_error,this%sigma_covariance/) - n = minim( x_sigma, likelihood,dlikelihood, method='cg', convergence_tol=this%covariance_tol, max_steps = 100, data=am_data) - - deallocate(am_data) - - this%sigma_error = x_sigma(1) - this%sigma_covariance = x_sigma(2) - call print('Optimisied hypers. ERROR = '//this%sigma_error//' COVARIANCE = '//this%sigma_covariance) - - ! update covariance matrix - this%covariance_matrix = exp(-0.5_dp * this%distance_matrix/this%sigma_covariance**2) - do i = 1, size(this%covariance_matrix,1) - this%covariance_matrix(i,i) = this%covariance_matrix(i,i) + this%sigma_error**2 - enddo - end if - - mainlog%prefix = 'COV2 ' - call print(this%covariance_matrix) - - call inverse(this%covariance_matrix, this%cov_inv) - mainlog%prefix = 'INV2 ' - call print(this%cov_inv) - mainlog%prefix = '' - - end subroutine realspacecovariance_teach - - subroutine realspacecovariance_predict(this, test, force, error) - type(realspacecovariance), intent(inout), target :: this - type(Atoms), intent(inout), target :: test - real(dp), intent(out) :: force(3) - real(dp), intent(out) :: error - - type(Atoms), save :: rot_at - real(dp) :: rot(3,3), d2, rho1_2, rho2_2, rho_12, kappa, unit_q(4) - real(dp), pointer, dimension(:,:) :: rot_force_ptr - integer i - - !$omp threadprivate(rot_at) - - call centre_on_atom_1(test) - call overlap_rho_rot_rho(this,test,test,overlap=rho2_2) - - force(:) = 0.0_dp - this%rot_force(:,:) = 0.0_dp - - call verbosity_push(PRINT_SILENT) - !$omp parallel default(none) shared(test, this, rho2_2) private(rot, rot_force_ptr, d2, rho1_2, rho_12) - !$omp do - do i=1,size(this%data) - this%q_min(:,i) = align(this, test, this%data(i), reshape(this%q_min(:,i), (/1,4/))) - rot = rotmat_quaternion(this%q_min(:,i)) - - call atoms_copy_without_connect(rot_at, this%data(i)) - rot_at%pos = matmul(rot,rot_at%pos) - call assign_property_pointer(rot_at, 'force', ptr=rot_force_ptr) - rot_force_ptr(:,:) = matmul(rot, rot_force_ptr) - this%rot_force(:,i) = rot_force_ptr(:,1) - - call overlap_rho_rot_rho(this,rot_at,rot_at,overlap=rho1_2) - call overlap_rho_rot_rho(this,rot_at,test,overlap=rho_12) - d2 = rho1_2 + rho2_2 - 2.0_dp*rho_12 - - this%k(i) = exp(-0.5_dp*d2/this%sigma_covariance**2) - end do - !$omp end parallel - call verbosity_pop() - - force = matmul(this%rot_force, matmul(this%cov_inv, this%k)) - - unit_q = (/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp/) - kappa = covariance(this, test, test, q=unit_q) - error = sqrt(kappa - min(kappa, (this%k .dot. matmul(this%cov_inv, this%k)))) - - end subroutine realspacecovariance_predict - - subroutine realspacecovariance_predict_2(this, test, force, error) - type(realspacecovariance), intent(inout), target :: this - type(Atoms), intent(inout), target :: test - real(dp), intent(out) :: force(3) - real(dp), intent(out) :: error - - type(Atoms), save :: rot_at - real(dp) :: rot(3,3), d2, rho1_2, rho2_2, rho_12, kappa, unit_q(4) - real(dp), pointer, dimension(:,:) :: rot_force_ptr - integer i,j - - !$omp threadprivate(rot_at) - - call centre_on_atom_1(test) - call overlap_rho_rot_rho(this,test,test,overlap=rho2_2) - - force(:) = 0.0_dp - this%rot_force(:,:) = 0.0_dp - - call verbosity_push(PRINT_SILENT) - - !$omp parallel default(none) shared(test, this) - !$omp do - do i=1,size(this%data) - this%q_min(:,i) = align(this, test, this%data(i), reshape(this%q_min(:,i), (/1,4/))) - end do - !$omp end parallel - - call verbosity_pop() - - !$omp parallel default(none) shared(this, test, rho2_2) private(j, rot, rot_force_ptr, d2, rho1_2, rho_12) - !$omp do - do i=1,size(this%data) - ! rotate data(i) into frame of test config - rot = rotmat_quaternion(this%q_min(:,i)) - call atoms_copy_without_connect(rot_at, this%data(i)) - rot_at%pos = matmul(rot,rot_at%pos) - - do j=i+1,size(this%data) - - ! compute covariance when data(j) is also rotated into frame of test config - this%covariance_matrix(i,j) = covariance(this, rot_at, this%data(j), & - distance=this%distance_matrix(i,j), q=this%q_min(:,j)) - - write (*,*) i, j, this%distance_matrix(i,j) - - this%distance_matrix(j,i) = this%distance_matrix(i,j) - this%covariance_matrix(j,i) = this%covariance_matrix(i,j) - - end do - this%distance_matrix(i,i) = 0.0_dp - this%covariance_matrix(i,i) = 1.0_dp + this%sigma_error**2 - - call overlap_rho_rot_rho(this,rot_at,rot_at,overlap=rho1_2) - call overlap_rho_rot_rho(this,rot_at,test,overlap=rho_12) - d2 = rho1_2 + rho2_2 - 2.0_dp*rho_12 - this%k(i) = exp(-0.5_dp*d2/this%sigma_covariance**2) - - ! store rotated force - call assign_property_pointer(rot_at, 'force', ptr=rot_force_ptr) - rot_force_ptr(:,:) = matmul(rot, rot_force_ptr) - this%rot_force(:,i) = rot_force_ptr(:,1) - - end do - !$omp end parallel - - call inverse(this%covariance_matrix, this%cov_inv) - call print('cov=') - call print(this%covariance_matrix) - call print('inv=') - call print(this%cov_inv) - - force = matmul(this%rot_force, matmul(this%cov_inv, this%k)) - unit_q = (/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp/) - kappa = covariance(this, test, test, q=unit_q) - error = sqrt(kappa - min(kappa, (this%k .dot. matmul(this%cov_inv, this%k)))) - - end subroutine realspacecovariance_predict_2 - - subroutine realspacecovariance_predict_3(this, test, crystal, k, force, error) - type(realspacecovariance), intent(inout), target :: this - type(Atoms), intent(inout), target :: test, crystal - integer, intent(in) :: k - real(dp), intent(out) :: force(3) - real(dp), intent(out) :: error - - type(Atoms), save :: rot_at - type(Quaternion) :: QQ_Ci, QQ_Cj, QQ_Ti, QQ_Tj, QQ_Tk, QQ_ij - real(dp) :: rot(3,3), d2, rho1_2, rho2_2, rho_12, kappa, unit_q(4), q_Tk(4), q_Ti(4), q_Tj(4), q_ij(4) - real(dp), pointer, dimension(:,:) :: rot_force_ptr - integer i,j - - !$omp threadprivate(rot_at) - - call centre_on_atom_1(test) - call overlap_rho_rot_rho(this,test,test,overlap=rho2_2) - - force(:) = 0.0_dp - this%rot_force(:,:) = 0.0_dp - - call verbosity_push(PRINT_SILENT) - - ! (1) align all learning set to cold crystal - - !$omp parallel default(none) shared(test, crystal, this) - !$omp do - do i=1,size(this%data) - this%q_min(:,i) = align(this, crystal, this%data(i), reshape(this%q_min(:,i), (/1,4/))) - end do - !$omp end parallel - - call verbosity_pop() - - ! (2) align test config to one representative element k of the learning set - q_Tk = (/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp/) - q_Tk = align(this, test, this%data(k), reshape(q_Tk, (/1,4/))) - call print('q_Tk = '//q_Tk) - QQ_Tk = q_Tk - - !$omp parallel default(none) shared(this, test, rho2_2, QQ_Tk) private(j, rot, rot_force_ptr, d2, rho1_2, rho_12, QQ_Ci, QQ_Ti, q_Ti, QQ_Cj, QQ_Tj, q_Tj, QQ_ij, q_ij) - !$omp do - do i=1,size(this%data) - - ! q_T,i = conj(q_C,k) * q_C,i * q_T,k - - QQ_Ci = this%q_min(:,i) - QQ_Ti = (.conj. QQ_Tk) * QQ_Ci * QQ_Tk - q_Ti = QQ_Ti - - ! rotate data(i) into frame of test config - rot = rotmat_quaternion(q_Ti) - call atoms_copy_without_connect(rot_at, this%data(i)) - rot_at%pos = matmul(rot,rot_at%pos) - - do j=i+1,size(this%data) - - ! q_T,j = conj(q_C,k) * q_C,j * q_T,k - ! q_i,j = conj(q_T,i) * q_T,j - - QQ_Cj = this%q_min(:,j) - QQ_Tj = (.conj. QQ_Tk) * QQ_Cj * QQ_Tk - q_Tj = QQ_Tj - - QQ_ij = (.conj. QQ_Ti) * QQ_Tj - q_ij = QQ_ij - - write (*,*) i, j, q_ij - - this%covariance_matrix(i,j) = covariance(this, rot_at, this%data(j), & - distance=this%distance_matrix(i,j), q=q_ij, do_align=.false.) - - this%distance_matrix(j,i) = this%distance_matrix(i,j) - this%covariance_matrix(j,i) = this%covariance_matrix(i,j) - - end do - this%distance_matrix(i,i) = 0.0_dp - this%covariance_matrix(i,i) = 1.0_dp + this%sigma_error**2 - - call overlap_rho_rot_rho(this,rot_at,rot_at,overlap=rho1_2) - call overlap_rho_rot_rho(this,rot_at,test,overlap=rho_12) - d2 = rho1_2 + rho2_2 - 2.0_dp*rho_12 - this%k(i) = exp(-0.5_dp*d2/this%sigma_covariance**2) - - ! store rotated force - call assign_property_pointer(rot_at, 'force', ptr=rot_force_ptr) - rot_force_ptr(:,:) = matmul(rot, rot_force_ptr) - this%rot_force(:,i) = rot_force_ptr(:,1) - - end do - !$omp end parallel - - call inverse(this%covariance_matrix, this%cov_inv) - call print('cov=') - call print(this%covariance_matrix) - call print('inv=') - call print(this%cov_inv) - - force = matmul(this%rot_force, matmul(this%cov_inv, this%k)) - unit_q = (/1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp/) - kappa = covariance(this, test, test, q=unit_q, do_align=.false.) - error = sqrt(kappa - min(kappa, (this%k .dot. matmul(this%cov_inv, this%k)))) - - end subroutine realspacecovariance_predict_3 - - - function rotmat_quaternion(q) - real(dp), dimension(4), intent(in) :: q - real(dp), dimension(3,3) :: rotmat_quaternion - - real(dp), dimension(4) :: q_in - - q_in = q / sqrt(dot_product(q,q)) - - rotmat_quaternion(1,1) = 1.0_dp - 2.0_dp*q_in(3)**2 - 2.0_dp*q_in(4)**2 - rotmat_quaternion(1,2) = 2.0_dp*q_in(2)*q_in(3) - 2.0_dp*q_in(1)*q_in(4) - rotmat_quaternion(1,3) = 2.0_dp*q_in(1)*q_in(3) + 2.0_dp*q_in(2)*q_in(4) - rotmat_quaternion(2,1) = 2.0_dp*q_in(2)*q_in(3) + 2.0_dp*q_in(1)*q_in(4) - rotmat_quaternion(2,2) = 1.0_dp - 2.0_dp*q_in(2)**2 - 2.0_dp*q_in(4)**2 - rotmat_quaternion(2,3) = -2.0_dp*q_in(1)*q_in(2) + 2.0_dp*q_in(3)*q_in(4) - rotmat_quaternion(3,1) = -2.0_dp*q_in(1)*q_in(3) + 2.0_dp*q_in(2)*q_in(4) - rotmat_quaternion(3,2) = 2.0_dp*q_in(1)*q_in(2) + 2.0_dp*q_in(3)*q_in(4) - rotmat_quaternion(3,3) = 1.0_dp - 2.0_dp*q_in(2)**2 - 2.0_dp*q_in(3)**2 - - endfunction rotmat_quaternion - - function drotmat_dquaternion(q) - real(dp), dimension(4), intent(in) :: q - real(dp), dimension(3,3,4) :: drotmat_dquaternion - - drotmat_dquaternion(1,1,1) = 4*q(1)*(q(3)**2 + q(4)**2) - drotmat_dquaternion(1,2,1) = -4*q(1)*q(2)*q(3) + 2*q(1)**2*q(4) - 2*q(4)*(q(2)**2 + q(3)**2 + q(4)**2) - drotmat_dquaternion(1,3,1) = 2*(-(q(1)**2*q(3)) - 2*q(1)*q(2)*q(4) + q(3)*(q(2)**2 + q(3)**2 + q(4)**2)) - drotmat_dquaternion(2,1,1) = 2*(-2*q(1)*q(2)*q(3) - q(1)**2*q(4) + q(4)*(q(2)**2 + q(3)**2 + q(4)**2)) - drotmat_dquaternion(2,2,1) = 4*q(1)*(q(2)**2 + q(4)**2) - drotmat_dquaternion(2,3,1) = 2*q(1)**2*q(2) - 4*q(1)*q(3)*q(4) - 2*q(2)*(q(2)**2 + q(3)**2 + q(4)**2) - drotmat_dquaternion(3,1,1) = 2*q(1)**2*q(3) - 4*q(1)*q(2)*q(4) - 2*q(3)*(q(2)**2 + q(3)**2 + q(4)**2) - drotmat_dquaternion(3,2,1) = 2*(-(q(1)**2*q(2)) - 2*q(1)*q(3)*q(4) + q(2)*(q(2)**2 + q(3)**2 + q(4)**2)) - drotmat_dquaternion(3,3,1) = 4*q(1)*(q(2)**2 + q(3)**2) - - drotmat_dquaternion(1,1,2) = 4*q(2)*(q(3)**2 + q(4)**2) - drotmat_dquaternion(1,2,2) = 2*(q(1)**2*q(3) + 2*q(1)*q(2)*q(4) + q(3)*(-q(2)**2 + q(3)**2 + q(4)**2)) - drotmat_dquaternion(1,3,2) = 2*(-2*q(1)*q(2)*q(3) + (q(1)**2 - q(2)**2 + q(3)**2)*q(4) + q(4)**3) - drotmat_dquaternion(2,1,2) = 2*(q(1)**2*q(3) - 2*q(1)*q(2)*q(4) + q(3)*(-q(2)**2 + q(3)**2 + q(4)**2)) - drotmat_dquaternion(2,2,2) = -4*q(2)*(q(1)**2 + q(3)**2) - drotmat_dquaternion(2,3,2) = -2*(q(1)**3 + 2*q(2)*q(3)*q(4) + q(1)*(-q(2)**2 + q(3)**2 + q(4)**2)) - drotmat_dquaternion(3,1,2) = 2*(2*q(1)*q(2)*q(3) + (q(1)**2 - q(2)**2 + q(3)**2)*q(4) + q(4)**3) - drotmat_dquaternion(3,2,2) = 2*(q(1)**3 - 2*q(2)*q(3)*q(4) + q(1)*(-q(2)**2 + q(3)**2 + q(4)**2)) - drotmat_dquaternion(3,3,2) = -4*q(2)*(q(1)**2 + q(4)**2) - - drotmat_dquaternion(1,1,3) = -4*(q(1)**2 + q(2)**2)*q(3) - drotmat_dquaternion(1,2,3) = 2*(q(1)**2*q(2) + 2*q(1)*q(3)*q(4) + q(2)*(q(2)**2 - q(3)**2 + q(4)**2)) - drotmat_dquaternion(1,3,3) = 2*(q(1)**3 - 2*q(2)*q(3)*q(4) + q(1)*(q(2)**2 - q(3)**2 + q(4)**2)) - drotmat_dquaternion(2,1,3) = 2*(q(1)**2*q(2) - 2*q(1)*q(3)*q(4) + q(2)*(q(2)**2 - q(3)**2 + q(4)**2)) - drotmat_dquaternion(2,2,3) = 4*q(3)*(q(2)**2 + q(4)**2) - drotmat_dquaternion(2,3,3) = 2*(2*q(1)*q(2)*q(3) + (q(1)**2 + q(2)**2 - q(3)**2)*q(4) + q(4)**3) - drotmat_dquaternion(3,1,3) = -2*(q(1)**3 + 2*q(2)*q(3)*q(4) + q(1)*(q(2)**2 - q(3)**2 + q(4)**2)) - drotmat_dquaternion(3,2,3) = 2*(-2*q(1)*q(2)*q(3) + (q(1)**2 + q(2)**2 - q(3)**2)*q(4) + q(4)**3) - drotmat_dquaternion(3,3,3) = -4*q(3)*(q(1)**2 + q(4)**2) - - drotmat_dquaternion(1,1,4) = -4*(q(1)**2 + q(2)**2)*q(4) - drotmat_dquaternion(1,2,4) = -2*(q(1)**3 + 2*q(2)*q(3)*q(4) + q(1)*(q(2)**2 + q(3)**2 - q(4)**2)) - drotmat_dquaternion(1,3,4) = 2*q(2)*(q(1)**2 + q(2)**2 + q(3)**2) - 4*q(1)*q(3)*q(4) - 2*q(2)*q(4)**2 - drotmat_dquaternion(2,1,4) = 2*(q(1)**3 - 2*q(2)*q(3)*q(4) + q(1)*(q(2)**2 + q(3)**2 - q(4)**2)) - drotmat_dquaternion(2,2,4) = -4*(q(1)**2 + q(3)**2)*q(4) - drotmat_dquaternion(2,3,4) = 2*q(3)*(q(1)**2 + q(2)**2 + q(3)**2) + 4*q(1)*q(2)*q(4) - 2*q(3)*q(4)**2 - drotmat_dquaternion(3,1,4) = 2*q(2)*(q(1)**2 + q(2)**2 + q(3)**2) + 4*q(1)*q(3)*q(4) - 2*q(2)*q(4)**2 - drotmat_dquaternion(3,2,4) = 2*q(3)*(q(1)**2 + q(2)**2 + q(3)**2) - 4*q(1)*q(2)*q(4) - 2*q(3)*q(4)**2 - drotmat_dquaternion(3,3,4) = 4*(q(2)**2 + q(3)**2)*q(4) - - drotmat_dquaternion = drotmat_dquaternion / dot_product(q,q)**2 - - endfunction drotmat_dquaternion - - function likelihood(x,am_data) - real(dp), dimension(:) :: x - character(len=1), dimension(:), optional :: am_data - real(dp) :: likelihood - - type(optimise_likelihood) :: am - real(dp) :: sigma_error, sigma_covariance - real(dp), dimension(:,:), allocatable :: ICF - integer :: i - type(LA_Matrix) :: LA_covariance - - am = transfer(am_data,am) - sigma_error = x(1) - sigma_covariance = x(2) - - am%rscov%covariance_matrix = exp(-0.5_dp * am%rscov%distance_matrix/sigma_covariance**2) - do i = 1, size(am%rscov%covariance_matrix,1) - am%rscov%covariance_matrix(i,i) = am%rscov%covariance_matrix(i,i) + sigma_error**2 - enddo - - LA_covariance = am%rscov%covariance_matrix - allocate(ICF(size(am%rscov%covariance_matrix,1),size(am%rscov%covariance_matrix,1))) - - if (am%use_qr) then - call Matrix_QR_Solve(LA_covariance,am%rscov%force_covariance_matrix,ICF) - else - call Matrix_Solve(LA_covariance,am%rscov%force_covariance_matrix,ICF) - end if - - likelihood = 3 * 0.5_dp * LA_Matrix_LogDet(LA_covariance) + 0.5_dp * trace(ICF) - - call finalise(LA_covariance) - if(allocated(ICF)) deallocate(ICF) - - endfunction likelihood - - function dlikelihood(x,am_data) - real(dp), dimension(:) :: x - character(len=1), dimension(:), optional :: am_data - real(dp), dimension(size(x)) :: dlikelihood - - type(optimise_likelihood) :: am - real(dp) :: sigma_error, sigma_covariance - real(dp), dimension(:,:), allocatable :: ICF, IC, ICDCDS, DCDS - integer :: i, n - type(LA_Matrix) :: LA_covariance - - am = transfer(am_data,am) - sigma_error = x(1) - sigma_covariance = x(2) - - n = size(am%rscov%covariance_matrix,1) - allocate(ICF(n,n),DCDS(n,n),IC(n,n),ICDCDS(n,n)) - - am%rscov%covariance_matrix = exp(-0.5_dp * am%rscov%distance_matrix/sigma_covariance**2) - DCDS = am%rscov%covariance_matrix * am%rscov%distance_matrix / sigma_covariance**3 - - do i = 1, n - am%rscov%covariance_matrix(i,i) = am%rscov%covariance_matrix(i,i) + sigma_error**2 - enddo - - LA_covariance = am%rscov%covariance_matrix - - if (am%use_qr) then - call Matrix_QR_Solve(LA_covariance,am%rscov%force_covariance_matrix,ICF) - call Matrix_QR_Solve(LA_covariance,DCDS,ICDCDS) - call LA_Matrix_QR_Inverse(LA_covariance,IC) - else - call Matrix_Solve(LA_covariance,am%rscov%force_covariance_matrix,ICF) - call Matrix_Solve(LA_covariance,DCDS,ICDCDS) - call LA_Matrix_Inverse(LA_covariance,IC) - end if - - dlikelihood(1) = sigma_error * (3*trace(IC) - sum(IC*ICF) ) - dlikelihood(2) = + 0.5_dp * 3*trace(ICDCDS) - 0.5_dp * sum(ICDCDS*transpose(ICF)) - - call finalise(LA_covariance) - if(allocated(ICF)) deallocate(ICF) - if(allocated(DCDS)) deallocate(DCDS) - if(allocated(IC)) deallocate(IC) - if(allocated(ICDCDS)) deallocate(ICDCDS) - - endfunction dlikelihood - - subroutine centre_on_atom_1(at) - type(Atoms), intent(inout) :: at - - integer i - - ! make all positions relative to first atom in file - do i = 2, at%N - at%pos(:,i) = diff_min_image(at,1,i) - enddo - at%pos(:,1) = 0.0_dp - - end subroutine centre_on_atom_1 - -endmodule real_space_covariance_module - diff --git a/src/Utils/restraints_constraints_xml.f95 b/src/Utils/restraints_constraints_xml.f95 deleted file mode 100644 index 511ec80475..0000000000 --- a/src/Utils/restraints_constraints_xml.f95 +++ /dev/null @@ -1,446 +0,0 @@ -module restraints_constraints_xml_module -use system_module, only : dp, system_abort, operator(//) -use constraints_module -use dynamicalsystem_module -use quip_common_module -implicit none -private - -type(DynamicalSystem), pointer, private :: parse_ds -logical, private :: parse_in_restraints = .false., parse_in_constraints = .false. - -public :: init_restraints_constraints - -contains - - subroutine restraints_constraints_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - character(len=1024) :: value - integer :: status, di_status, tau_status, t0_status - integer :: n - integer :: atom_1, atom_2, atom_3, Z - real(dp) :: k - character(len=1024) :: bound_str - integer :: bound - real(dp) :: c - real(dp) :: d, plane_n(3), di, p, q(3), SF - real(dp) :: t0, tau - real(dp) :: egap - real(dp) :: tol - character(len=20) :: type_str - logical :: print_summary - - if (parse_in_restraints) type_str = "restraint" - if (parse_in_constraints) type_str = "constraint" - - if (name == 'restraints' .or. name == 'constraints') then ! new restraints stanze - if (name == 'restraints') then - parse_in_restraints = .true. - parse_in_constraints = .false. - call QUIP_FoX_get_value(attributes, "N", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read N in restraints stanza") - read (value, *) n - call print("allocating array for "//n//" restraints") - if (allocated(parse_ds%restraint)) deallocate(parse_ds%restraint) - allocate(parse_ds%restraint(n)) - else ! constraints - parse_in_constraints = .true. - parse_in_restraints = .false. - call QUIP_FoX_get_value(attributes, "N", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read N in constraints stanza") - read (value, *) n - call print("allocating array for "//n//" constraints") - if (allocated(parse_ds%constraint)) deallocate(parse_ds%constraint) - allocate(parse_ds%constraint(n)) - endif - - else if (parse_in_restraints .or. parse_in_constraints) then - call QUIP_FoX_get_value(attributes, "print_summary", value, status) - if (status == 0) then - read (value, *) print_summary - else - print_summary=.true. - endif - - if (parse_in_restraints) then - call QUIP_FoX_get_value(attributes, "k", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read k in bond_length "//trim(type_str)) - read (value, *) k - call QUIP_FoX_get_value(attributes, "bound", value, status) - if (status == 0) then - read (value, *) bound_str - call interpret_bound_string(trim(bound_str),bound) - else - bound = BOTH_UPPER_AND_LOWER_BOUNDS - endif - else - call QUIP_FoX_get_value(attributes, "tol", value, status) !constraint tolerance - if (status == 0) then - read (value, *) tol - else - tol=-1._dp !default - endif - endif - - if (name == 'bond_length') then - call QUIP_FoX_get_value(attributes, "atom_1", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_1 in bond_length "// & - trim(type_str)) - read (value, *) atom_1 - call QUIP_FoX_get_value(attributes, "atom_2", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_2 in bond_length "// & - trim(type_str)) - read (value, *) atom_2 - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read d in bond_length "//trim(type_str)) - read (value, *) d - - tau = -1.0_dp - di = -1.0_dp - call QUIP_FoX_get_value(attributes, "tau", value, status) - if (status == 0) then - read (value, *) tau - endif - call QUIP_FoX_get_value(attributes, "di", value, status) - if (status == 0) then - read (value, *) di - endif - call QUIP_FoX_get_value(attributes, "t0", value, status) - if (status == 0) then - read (value, *) t0 - endif - if ((status == 0 .and. (tau <= 0.0_dp .or. di < 0.0_dp)) .or. & - (status /= 0 .and. (tau > 0.0_dp .or. di >= 0.0_dp))) then - call system_abort("got t0, but tau or di is missing or invalid") - endif - - if (tau > 0.0_dp) then - if (parse_in_restraints) then - call constrain_bondlength(parse_ds, atom_1, atom_2, d, di=di, t0=t0, tau=tau, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondlength(parse_ds, atom_1, atom_2, d, di=di, t0=t0, tau=tau, tol=tol, print_summary=print_summary) - endif - else - if (parse_in_restraints) then - call constrain_bondlength(parse_ds, atom_1, atom_2, d, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondlength(parse_ds, atom_1, atom_2, d, tol=tol, print_summary=print_summary) - endif - endif - - else if (name == 'bond_length_dev_pow') then - call QUIP_FoX_get_value(attributes, "atom_1", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_1 in bond_length_dev_pow "// & - trim(type_str)) - read (value, *) atom_1 - call QUIP_FoX_get_value(attributes, "atom_2", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_2 in bond_length_dev_pow "// & - trim(type_str)) - read (value, *) atom_2 - call QUIP_FoX_get_value(attributes, "p", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read p in bond_length_dev_pow "//trim(type_str)) - read (value, *) p - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read d in bond_length_dev_pow "//trim(type_str)) - read (value, *) d - - tau = -1.0_dp - di = -1.0_dp - call QUIP_FoX_get_value(attributes, "tau", value, status) - if (status == 0) then - read (value, *) tau - endif - call QUIP_FoX_get_value(attributes, "di", value, status) - if (status == 0) then - read (value, *) di - endif - call QUIP_FoX_get_value(attributes, "t0", value, status) - if (status == 0) then - read (value, *) t0 - endif - if ((status == 0 .and. (tau <= 0.0_dp .or. di < 0.0_dp)) .or. & - (status /= 0 .and. (tau > 0.0_dp .or. di >= 0.0_dp))) then - call system_abort("got t0, but tau or di is missing or invalid") - endif - - if (tau > 0.0_dp) then - if (parse_in_restraints) then - call constrain_bondlength_dev_pow(parse_ds, atom_1, atom_2, p, d, di=di, t0=t0, tau=tau, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondlength_dev_pow(parse_ds, atom_1, atom_2, p, d, di=di, t0=t0, tau=tau, tol=tol, print_summary=print_summary) - endif - else - if (parse_in_restraints) then - call constrain_bondlength_dev_pow(parse_ds, atom_1, atom_2, p, d, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondlength_dev_pow(parse_ds, atom_1, atom_2, p, d, tol=tol, print_summary=print_summary) - endif - endif - - else if (name == 'bond_length_sq') then - - call QUIP_FoX_get_value(attributes, "atom_1", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_1 in bond_length_sq "//trim(type_str)) - read (value, *) atom_1 - call QUIP_FoX_get_value(attributes, "atom_2", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_2 in bond_length_sq "//trim(type_str)) - read (value, *) atom_2 - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status == 0) then - read (value, *) d - if (parse_in_restraints) then - call constrain_bondlength_sq(parse_ds, atom_1, atom_2, d, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondlength_sq(parse_ds, atom_1, atom_2, d, tol=tol, print_summary=print_summary) - endif - else - if (parse_in_restraints) then - call constrain_bondlength_sq(parse_ds, atom_1, atom_2, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondlength_sq(parse_ds, atom_1, atom_2, tol=tol, print_summary=print_summary) - endif - endif - - else if (name == 'bond_angle_cos') then - - call QUIP_FoX_get_value(attributes, "atom_1", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_1 in bond_angle_cos "//trim(type_str)) - read (value, *) atom_1 - call QUIP_FoX_get_value(attributes, "atom_2", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_2 in bond_angle_cos "//trim(type_str)) - read (value, *) atom_2 - call QUIP_FoX_get_value(attributes, "atom_3", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_3 in bond_angle_cos "//trim(type_str)) - read (value, *) atom_3 - call QUIP_FoX_get_value(attributes, "c", value, status) - if (status == 0) then - read (value, *) c - if (parse_in_restraints) then - call constrain_bondanglecos(parse_ds, atom_1, atom_2, atom_3, c, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondanglecos(parse_ds, atom_1, atom_2, atom_3, c, tol=tol, print_summary=print_summary) - endif - else - if (parse_in_restraints) then - call constrain_bondanglecos(parse_ds, atom_1, atom_2, atom_3, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondanglecos(parse_ds, atom_1, atom_2, atom_3, tol=tol, print_summary=print_summary) - endif - endif - - else if (name == 'bond_length_diff') then - - call QUIP_FoX_get_value(attributes, "atom_1", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_1 in bond_length_diff "//trim(type_str)) - read (value, *) atom_1 - call QUIP_FoX_get_value(attributes, "atom_2", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_2 in bond_length_diff "//trim(type_str)) - read (value, *) atom_2 - call QUIP_FoX_get_value(attributes, "atom_3", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom_3 in bond_length_diff "//trim(type_str)) - read (value, *) atom_3 - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read d in bond_length_diff "//trim(type_str)) - read (value, *) d - - call QUIP_FoX_get_value(attributes, "di", value, di_status) - if (di_status == 0) read (value, *) di - call QUIP_FoX_get_value(attributes, "tau", value, tau_status) - if (tau_status == 0) read (value, *) tau - call QUIP_FoX_get_value(attributes, "t0", value, t0_status) - if (t0_status == 0) read (value, *) t0 - if (count( (/ di_status, tau_status, t0_status /) == 0) /= 0 .and. & - count( (/ di_status, tau_status, t0_status /) == 0) /= 3) then - call system_abort("restraint_startElement_handler needs either all or none of di, tau, t0") - endif - - if (di_status == 0) then ! relax target value with time - if (parse_in_restraints) then - call constrain_bondlength_diff(parse_ds, atom_1, atom_2, atom_3, d, di=di, tau=tau, t0=t0, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondlength_diff(parse_ds, atom_1, atom_2, atom_3, d, di=di, tau=tau, t0=t0, tol=tol, print_summary=print_summary) - endif - else ! fixed target value - if (parse_in_restraints) then - call constrain_bondlength_diff(parse_ds, atom_1, atom_2, atom_3, d, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_bondlength_diff(parse_ds, atom_1, atom_2, atom_3, d, tol=tol, print_summary=print_summary) - endif - endif - - else if (name == 'gap_energy') then - - call QUIP_FoX_get_value(attributes, "egap", value, status) - if (status == 0) then - read (value, *) egap - if (parse_in_restraints) then - call constrain_gap_energy(parse_ds, egap, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_gap_energy(parse_ds, egap, tol=tol, print_summary=print_summary) - endif - else - call system_abort("restraint_startElement_handler failed to read egap in gap_energy "//trim(type_str)) - !if (parse_in_restraints) then - ! call constrain_gap_energy(parse_ds, restraint_k=k, print_summary=print_summary) - !else - ! call constrain_gap_energy(parse_ds, tol=tol, print_summary=print_summary) - !endif - endif - - else if (name == 'atom_plane') then - - call QUIP_FoX_get_value(attributes, "atom", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read atom in atom_plane "//trim(type_str)) - read (value, *) atom_1 - call QUIP_FoX_get_value(attributes, "normal", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read normal in atom_plane "//trim(type_str)) - read (value, *) plane_n - call QUIP_FoX_get_value(attributes, "d", value, status) - if (status == 0) then - read (value, *) d - if (parse_in_restraints) then - call constrain_atom_plane(parse_ds, atom_1, plane_n, d, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_atom_plane(parse_ds, atom_1, plane_n, d, tol=tol, print_summary=print_summary) - endif - else - if (parse_in_restraints) then - call constrain_atom_plane(parse_ds, atom_1, plane_n, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_atom_plane(parse_ds, atom_1, plane_n, tol=tol, print_summary=print_summary) - endif - endif - - else if (name == 'struct_factor_like_mag') then - - call QUIP_FoX_get_value(attributes, "Z", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read Z in struct_factor_like_mag "//trim(type_str)) - read (value, *) Z - call QUIP_FoX_get_value(attributes, "q", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read q in struct_factor_like_mag "//trim(type_str)) - read (value, *) q - call QUIP_FoX_get_value(attributes, "SF", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read SF in struct_factor_like_mag "//trim(type_str)) - read (value, *) SF - if (parse_in_restraints) then - call constrain_struct_factor_like_mag(parse_ds, Z, q, SF, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_struct_factor_like_mag(parse_ds, Z, q, SF, tol=tol, print_summary=print_summary) - endif - - else if (name == 'struct_factor_like_r') then - - call QUIP_FoX_get_value(attributes, "Z", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read Z in struct_factor_like_r "//trim(type_str)) - read (value, *) Z - call QUIP_FoX_get_value(attributes, "q", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read q in struct_factor_like_r "//trim(type_str)) - read (value, *) q - call QUIP_FoX_get_value(attributes, "SF", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read SF in struct_factor_like_r "//trim(type_str)) - read (value, *) SF - if (parse_in_restraints) then - call constrain_struct_factor_like_r(parse_ds, Z, q, SF, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_struct_factor_like_r(parse_ds, Z, q, SF, tol=tol, print_summary=print_summary) - endif - - else if (name == 'struct_factor_like_i') then - - call QUIP_FoX_get_value(attributes, "Z", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read Z in struct_factor_like_i "//trim(type_str)) - read (value, *) Z - call QUIP_FoX_get_value(attributes, "q", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read q in struct_factor_like_i "//trim(type_str)) - read (value, *) q - call QUIP_FoX_get_value(attributes, "SF", value, status) - if (status /= 0) call system_abort("restraint_startElement_handler failed to read SF in struct_factor_like_i "//trim(type_str)) - read (value, *) SF - if (parse_in_restraints) then - call constrain_struct_factor_like_i(parse_ds, Z, q, SF, restraint_k=k, bound=bound, print_summary=print_summary) - else - call constrain_struct_factor_like_i(parse_ds, Z, q, SF, tol=tol, print_summary=print_summary) - endif - - else - call system_abort("unknown " // trim(type_str) //" type '"//name//"' in " // trim(type_str) //"s xml stanza") - endif - endif - - end subroutine - - subroutine restraints_constraints_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (name == 'restraints') then ! end of restraints stanza - parse_in_restraints = .false. - else if (name == 'constraints') then ! end of constraints stanza - parse_in_constraints = .false. - endif - - end subroutine - - !% Initialise restraints and constraints for a dynamical system from an XML containing string. - !% - !% XML format for constraints - !% - !% \begin{verbatim} - !% - !% - !% - !% - !% - !% - !% \end{verbatim} - !% - !% In all types, constraint value (c or d) is optional. If not - !% specified, defaults to value at initialization time, just like - !% underlying constraint adding routines. - !% - !% Format for restraints is similar, except surrounding stanza name - !% is `restraints', and the additional {\tt k} attribute - !% specifying spring constant for each restraint - ! - subroutine init_restraints_constraints(this, param_str) - type(DynamicalSystem), intent(inout), target :: this - character(len=*), intent(in) :: param_str - - type(xml_t) :: fxml - - if (len_trim(param_str) == 0) return - - parse_ds => this - - call open_xml_string(fxml, param_str) - - call parse(fxml, startElement_handler = restraints_constraints_startElement_handler, & - endElement_handler = restraints_constraints_endElement_handler) - - call close_xml_t(fxml) - - end subroutine init_restraints_constraints - - subroutine interpret_bound_string(bound_str,bound) - character(len=*), intent(in) :: bound_str - integer, intent(out) :: bound - - if ( trim(bound_str) == trim(BOUND_STRING(UPPER_BOUND)) ) then - bound = UPPER_BOUND - elseif ( trim(bound_str) == trim(BOUND_STRING(LOWER_BOUND)) ) then - bound = LOWER_BOUND - elseif ( trim(bound_str) == trim(BOUND_STRING(BOTH_UPPER_AND_LOWER_BOUNDS)) ) then - bound = BOTH_UPPER_AND_LOWER_BOUNDS - else - call system_abort("bound must take a value of "//trim(BOUND_STRING(UPPER_BOUND))//", "// & - trim(BOUND_STRING(LOWER_BOUND))//" and "//trim(BOUND_STRING(BOTH_UPPER_AND_LOWER_BOUNDS))) - endif - - end subroutine interpret_bound_string - -end module restraints_constraints_xml_module diff --git a/src/Utils/structure_analysis_traj_routines.f95 b/src/Utils/structure_analysis_traj_routines.f95 deleted file mode 100644 index 3539f33ab6..0000000000 --- a/src/Utils/structure_analysis_traj_routines.f95 +++ /dev/null @@ -1,1844 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General - ! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! do various structural analysis to a trajectory, save an intermediate file -! to be postprocessed (mean, variance, correlation, etc) -! #/vol density on a radial mesh -! #/vol density on a grid -! RDF, possibly as a function of distance of center from a fixed point -! to be added: ADF - -module structure_analysis_routines_module -use libatoms_module -implicit none -private - -public :: density_sample_radial_mesh_Gaussians, rdfd_calc, xrd_calc, propdf_radial_calc, adfd_calc, & - density_sample_rectilinear_mesh_Gaussians, density_bin_rectilinear_mesh, & - geometry_calc, shift_silica_to_edges, density_axial_calc, num_hbond_calc, & - water_orientation_calc - -real(dp), dimension(0:total_elements) :: ASF_c = (/ & - 0.0, & - 0.001305, & - 0.0064, & - 0.0377, & - 0.0385, & - -0.1932, & - 0.2156, & - -11.529, & - 0.2508, & - 0.2776, & - 0.3515, & - 0.676, & - 0.8584, & - 1.1151, & - 1.1407, & - 1.1149, & - 0.8669, & - -9.5574, & - 1.4445, & - 1.4228, & - 1.3751, & - 1.3329, & - 1.2807, & - 1.2199, & - 1.1832, & - 1.0896, & - 1.0369, & - 1.0118, & - 1.0341, & - 1.191, & - 1.3041, & - 1.7189, & - 2.1313, & - 2.531, & - 2.8409, & - 2.9557, & - 2.825, & - 3.4873, & - 2.5064, & - 1.91213, & - 2.06929, & - 3.75591, & - 4.3875, & - 5.40428, & - 5.37814, & - 5.328, & - 5.26593, & - 5.179, & - 5.0694, & - 4.9391, & - 4.7821, & - 4.5909, & - 4.352, & - 4.0712, & - 3.7118, & - 3.3352, & - 2.7731, & - 2.14678, & - 1.86264, & - 2.0583, & - 1.98486, & - 2.02876, & - 2.20963, & - 2.5745, & - 2.4196, & - 3.58324, & - 4.29728, & - 4.56796, & - 5.92046, & - 1.63929, & - 7.56672, & - 7.97628, & - 8.58154, & - 9.24354, & - 9.8875, & - 10.472, & - 11.0005, & - 11.4722, & - 11.6883, & - 12.0658, & - 12.6089, & - 13.1746, & - 13.4118, & - 13.5782, & - 13.677, & - 13.7108, & - 13.6905, & - 13.7247, & - 13.6211, & - 13.5266, & - 13.4314, & - 13.4287, & - 13.3966, & - 13.3573, & - 13.3812, & - 13.3592, & - 13.2887, & - 13.2754, & - 13.2674, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0, & - 1.0 /) - -real(dp), dimension(4,0:total_elements) :: ASF_a = reshape( (/ & - 0.0, 0.0, 0.0, 0.0, & - 0.489918, 0.262003, 0.196767, 0.049879, & - 0.8734, 0.6309, 0.3112, 0.178, & - 1.1282, 0.7508, 0.6175, 0.4653, & - 1.5919, 1.1278, 0.5391, 0.7029, & - 2.0545, 1.3326, 1.0979, 0.7068, & - 2.31, 1.02, 1.5886, 0.865, & - 12.2126, 3.1322, 2.0125, 1.1663, & - 3.0485, 2.2868, 1.5463, 0.867, & - 3.5392, 2.6412, 1.517, 1.0243, & - 3.9553, 3.1125, 1.4546, 1.1251, & - 4.7626, 3.1736, 1.2674, 1.1128, & - 5.4204, 2.1735, 1.2269, 2.3073, & - 6.4202, 1.9002, 1.5936, 1.9646, & - 6.2915, 3.0353, 1.9891, 1.541, & - 6.4345, 4.1791, 1.78, 1.4908, & - 6.9053, 5.2034, 1.4379, 1.5863, & - 11.4604, 7.1964, 6.2556, 1.6455, & - 7.4845, 6.7723, 0.6539, 1.6442, & - 8.2186, 7.4398, 1.0519, 0.8659, & - 8.6266, 7.3873, 1.5899, 1.0211, & - 9.189, 7.3679, 1.6409, 1.468, & - 9.7595, 7.3558, 1.6991, 1.9021, & - 10.2971, 7.3511, 2.0703, 2.0571, & - 10.6406, 7.3537, 3.324, 1.4922, & - 11.2819, 7.3573, 3.0193, 2.2441, & - 11.7695, 7.3573, 3.5222, 2.3045, & - 12.2841, 7.3409, 4.0034, 2.3488, & - 12.8376, 7.292, 4.4438, 2.38, & - 13.338, 7.1676, 5.6158, 1.6735, & - 14.0743, 7.0318, 5.1652, 2.41, & - 15.2354, 6.7006, 4.3591, 2.9623, & - 16.0816, 6.3747, 3.7068, 3.683, & - 16.6723, 6.0701, 3.4313, 4.2779, & - 17.0006, 5.8196, 3.9731, 4.3543, & - 17.1789, 5.2358, 5.6377, 3.9851, & - 17.3555, 6.7286, 5.5493, 3.5375, & - 17.1784, 9.6435, 5.1399, 1.5292, & - 17.5663, 9.8184, 5.422, 2.6694, & - 17.776, 10.2946, 5.72629, 3.26588, & - 17.8765, 10.948, 5.41732, 3.65721, & - 17.6142, 12.0144, 4.04183, 3.53346, & - 3.7025, 17.2356, 12.8876, 3.7429, & - 19.1301, 11.0948, 4.64901, 2.71263, & - 19.2674, 12.9182, 4.86337, 1.56756, & - 19.2957, 14.3501, 4.73425, 1.28918, & - 19.3319, 15.5017, 5.29537, 0.605844, & - 19.2808, 16.6885, 4.8045, 1.0463, & - 19.2214, 17.6444, 4.461, 1.6029, & - 19.1624, 18.5596, 4.2948, 2.0396, & - 19.1889, 19.1005, 4.4585, 2.4663, & - 19.6418, 19.0455, 5.0371, 2.6827, & - 19.9644, 19.0138, 6.14487, 2.5239, & - 20.1472, 18.9949, 7.5138, 2.2735, & - 20.2933, 19.0298, 8.9767, 1.99, & - 20.3892, 19.1062, 10.662, 1.4953, & - 20.3361, 19.297, 10.888, 2.6959, & - 20.578, 19.599, 11.3727, 3.28719, & - 21.1671, 19.7695, 11.8513, 3.33049, & - 22.044, 19.6697, 12.3856, 2.82428, & - 22.6845, 19.6847, 12.774, 2.85137, & - 23.3405, 19.6095, 13.1235, 2.87516, & - 24.0042, 19.4258, 13.4396, 2.89604, & - 24.6274, 19.0886, 13.7603, 2.9227, & - 25.0709, 19.0798, 13.8518, 3.54545, & - 25.8976, 18.2185, 14.3167, 2.95354, & - 26.507, 17.6383, 14.5596, 2.96577, & - 26.9049, 17.294, 14.5583, 3.63837, & - 27.6563, 16.4285, 14.9779, 2.98233, & - 28.1819, 15.8851, 15.1542, 2.98706, & - 28.6641, 15.4345, 15.3087, 2.98963, & - 28.9476, 15.2208, 15.1, 3.71601, & - 29.144, 15.1726, 14.7586, 4.30013, & - 29.2024, 15.2293, 14.5135, 4.76492, & - 29.0818, 15.43, 14.4327, 5.11982, & - 28.7621, 15.7189, 14.5564, 5.44174, & - 28.1894, 16.155, 14.9305, 5.67589, & - 27.3049, 16.7296, 15.6115, 5.83377, & - 27.0059, 17.7639, 15.7131, 5.7837, & - 16.8819, 18.5913, 25.5582, 5.86, & - 20.6809, 19.0417, 21.6575, 5.9676, & - 27.5446, 19.1584, 15.538, 5.52593, & - 31.0617, 13.0637, 18.442, 5.9696, & - 33.3689, 12.951, 16.5877, 6.4692, & - 34.6726, 15.4733, 13.1138, 7.02588, & - 35.3163, 19.0211, 9.49887, 7.42518, & - 35.5631, 21.2816, 8.0037, 7.4433, & - 35.9299, 23.0547, 12.1439, 2.11253, & - 35.763, 22.9064, 12.4739, 3.21097, & - 35.6597, 23.1032, 12.5977, 4.08655, & - 35.5645, 23.4219, 12.7473, 4.80703, & - 35.8847, 23.2948, 14.1891, 4.17287, & - 36.0228, 23.4128, 14.9491, 4.188, & - 36.1874, 23.5964, 15.6402, 4.1855, & - 36.5254, 23.8083, 16.7707, 3.47947, & - 36.6706, 24.0992, 17.3415, 3.49331, & - 36.6488, 24.4096, 17.399, 4.21665, & - 36.7881, 24.7736, 17.8919, 4.23284, & - 36.9185, 25.1995, 18.3317, 4.24391, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0 /), (/ 4, total_elements + 1 /) ) - -real(dp), dimension(4,0:total_elements) :: ASF_b = reshape( (/ & - 0.0, 0.0, 0.0, 0.0, & - 20.6593, 7.74039, 49.5519, 2.20159, & - 9.1037, 3.3568, 22.9276, 0.9821, & - 3.9546, 1.0524, 85.3905, 68.261, & - 43.6427, 1.8623, 103.483, 0.542, & - 23.2185, 1.021, 60.3498, 0.1403, & - 20.8439, 10.2075, 0.5687, 51.6512, & - 0.0057, 9.8933, 28.9975, 0.5826, & - 13.2771, 5.7011, 0.3239, 32.9089, & - 10.2825, 4.2944, 0.2615, 26.1476, & - 8.4042, 3.4262, 0.2306, 21.7184, & - 3.285, 8.8422, 0.3136, 129.424, & - 2.8275, 79.2611, 0.3808, 7.1937, & - 3.0387, 0.7426, 31.5472, 85.0886, & - 2.4386, 32.3337, 0.6785, 81.6937, & - 1.9067, 27.157, 0.526, 68.1645, & - 1.4679, 22.2151, 0.2536, 56.172, & - 0.0104, 1.1662, 18.5194, 47.7784, & - 0.9072, 14.8407, 43.8983, 33.3929, & - 12.7949, 0.7748, 213.187, 41.6841, & - 10.4421, 0.6599, 85.7484, 178.437, & - 9.0213, 0.5729, 136.108, 51.3531, & - 7.8508, 0.5, 35.6338, 116.105, & - 6.8657, 0.4385, 26.8938, 102.478, & - 6.1038, 0.392, 20.2626, 98.7399, & - 5.3409, 0.3432, 17.8674, 83.7543, & - 4.7611, 0.3072, 15.3535, 76.8805, & - 4.2791, 0.2784, 13.5359, 71.1692, & - 3.8785, 0.2565, 12.1763, 66.3421, & - 3.5828, 0.247, 11.3966, 64.8126, & - 3.2655, 0.2333, 10.3163, 58.7097, & - 3.0669, 0.2412, 10.7805, 61.4135, & - 2.8509, 0.2516, 11.4468, 54.7625, & - 2.6345, 0.2647, 12.9479, 47.7972, & - 2.4098, 0.2726, 15.2372, 43.8163, & - 2.1723, 16.5796, 0.2609, 41.4328, & - 1.9384, 16.5623, 0.2261, 39.3972, & - 1.7888, 17.3151, 0.2748, 164.934, & - 1.5564, 14.0988, 0.1664, 132.376, & - 1.4029, 12.8006, 0.125599, 104.354, & - 1.27618, 11.916, 0.117622, 87.6627, & - 1.18865, 11.766, 0.204785, 69.7957, & - 0.2772, 1.0958, 11.004, 61.6584, & - 0.864132, 8.14487, 21.5707, 86.8472, & - 0.80852, 8.43467, 24.7997, 94.2928, & - 0.751536, 8.21758, 25.8749, 98.6062, & - 0.698655, 7.98929, 25.2052, 76.8986, & - 0.6446, 7.4726, 24.6605, 99.8156, & - 0.5946, 6.9089, 24.7008, 87.4825, & - 0.5476, 6.3776, 25.8499, 92.8029, & - 5.8303, 0.5031, 26.8909, 83.9571, & - 5.3034, 0.4607, 27.9074, 75.2825, & - 4.81742, 0.420885, 28.5284, 70.8403, & - 4.347, 0.3814, 27.766, 66.8776, & - 3.9282, 0.344, 26.4659, 64.2658, & - 3.569, 0.3107, 24.3879, 213.904, & - 3.216, 0.2756, 20.2073, 167.202, & - 2.94817, 0.244475, 18.7726, 133.124, & - 2.81219, 0.226836, 17.6083, 127.113, & - 2.77393, 0.222087, 16.7669, 143.644, & - 2.66248, 0.210628, 15.885, 137.903, & - 2.5627, 0.202088, 15.1009, 132.721, & - 2.47274, 0.196451, 14.3996, 128.007, & - 2.3879, 0.1942, 13.7546, 123.174, & - 2.25341, 0.181951, 12.9331, 101.398, & - 2.24256, 0.196143, 12.6648, 115.362, & - 2.1802, 0.202172, 12.1899, 111.874, & - 2.07051, 0.19794, 11.4407, 92.6566, & - 2.07356, 0.223545, 11.3604, 105.703, & - 2.02859, 0.238849, 10.9975, 102.961, & - 1.9889, 0.257119, 10.6647, 100.417, & - 1.90182, 9.98519, 0.261033, 84.3298, & - 1.83262, 9.5999, 0.275116, 72.029, & - 1.77333, 9.37046, 0.295977, 63.3644, & - 1.72029, 9.2259, 0.321703, 57.056, & - 1.67191, 9.09227, 0.3505, 52.0861, & - 1.62903, 8.97948, 0.382661, 48.1647, & - 1.59279, 8.86553, 0.417916, 45.0011, & - 1.51293, 8.81174, 0.424593, 38.6103, & - 0.4611, 8.6216, 1.4826, 36.3956, & - 0.545, 8.4484, 1.5729, 38.3246, & - 0.65515, 8.70751, 1.96347, 45.8149, & - 0.6902, 2.3576, 8.618, 47.2579, & - 0.704, 2.9238, 8.7937, 48.0093, & - 0.700999, 3.55078, 9.55642, 47.0045, & - 0.68587, 3.97458, 11.3824, 45.4715, & - 0.6631, 4.0691, 14.0422, 44.2473, & - 0.646453, 4.17619, 23.1052, 150.645, & - 0.616341, 3.87135, 19.9887, 142.325, & - 0.589092, 3.65155, 18.599, 117.02, & - 0.563359, 3.46204, 17.8309, 99.1722, & - 0.547751, 3.41519, 16.9235, 105.251, & - 0.5293, 3.3253, 16.0927, 100.613, & - 0.511929, 3.25396, 15.3622, 97.4908, & - 0.499384, 3.26371, 14.9455, 105.98, & - 0.483629, 3.20647, 14.3136, 102.273, & - 0.465154, 3.08997, 13.4346, 88.4834, & - 0.451018, 3.04619, 12.8946, 86.003, & - 0.437533, 3.00775, 12.4044, 83.7881, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.0, 0.0, 0.0 /), (/ 4, total_elements+1 /) ) - - -contains - -subroutine is_in_mask(mask_a, at, mask_str) - type(Atoms), intent(in) :: at - logical, intent(out) :: mask_a(at%N) - character(len=*), intent(in) :: mask_str - - integer :: i_at, i_Z - integer :: Zmask - type(Table) :: atom_indices - character(len=4) :: species(128) - integer :: n_species - character(len=len(mask_str)) :: fields(2) - integer :: n_fields - - integer :: i_val - logical :: l_val - - integer, pointer :: p_i(:) - logical, pointer :: p_l(:) - - if (len_trim(mask_str) == 0) then - mask_a = .true. - return - endif - - mask_a = .false. - if (mask_str(1:1)=='@') then ! list of indices - call parse_atom_mask(mask_str,atom_indices) - do i_at=1, atom_indices%N - mask_a(atom_indices%int(1,i_at)) = .true. - end do - else if (scan(mask_str,'=')/=0) then ! arbitrary property - call split_string(mask_str,'=','""', fields,n_fields) - if (assign_pointer(at, trim(fields(1)), p_i)) then - ! integer match - read (unit=fields(2), fmt=*) i_val - mask_a = (p_i == i_val) - else if (assign_pointer(at, trim(fields(1)), p_l)) then - ! integer match - read (unit=fields(2), fmt=*) l_val - mask_a = (p_l .eqv. l_val) - else - call system_abort("mask is arbitrary property match, but apparently not integer or logical, so unsupported") - endif - else ! species (via atomic number) - call split_string(mask_str, ' ,', '""', species, n_species) - do i_Z=1, n_species - Zmask = Atomic_Number(species(i_Z)) - do i_at=1, at%N - if (at%Z(i_at) == Zmask) mask_a(i_at) = .true. - end do - end do - end if -end subroutine is_in_mask - -subroutine density_sample_radial_mesh_Gaussians(histogram, at, center_pos, center_i, rad_bin_width, n_rad_bins, gaussian_sigma, mask_str, radial_pos, accumulate, quantity) - real(dp), intent(inout) :: histogram(:) - type(Atoms), intent(inout) :: at - real(dp), intent(in), optional :: center_pos(3) - integer, intent(in), optional :: center_i - real(dp), intent(in) :: rad_bin_width - integer, intent(in) :: n_rad_bins - real(dp), intent(in) :: gaussian_sigma - character(len=*), optional, intent(in) :: mask_str - real(dp), intent(out), optional :: radial_pos(:) - logical, optional, intent(in) :: accumulate - character(len=*), optional, intent(in) :: quantity - - logical :: my_accumulate - - real(dp) :: use_center_pos(3), d, r0, s_sq, s_cu, h_val - real(dp), parameter :: SQROOT_PI = sqrt(PI), PI_THREE_HALVES = PI**(3.0_dp/2.0_dp) - logical, allocatable :: mask_a(:) - integer :: at_i, rad_sample_i - real(dp) :: rad_sample_r, exp_arg, ep, em - logical :: quantity_1, quantity_KE - real(dp) :: sample_weight - - if (present(center_pos) .and. present(center_i)) then - call system_abort("density_sample_radial_mesh_Gaussians received both center_pos and center_i") - else if (.not. present(center_pos) .and. .not. present(center_i)) then - call system_abort("density_sample_radial_mesh_Gaussians received neither center_pos nor center_i") - endif - - quantity_1 = .false. - quantity_KE = .false. - if (present(quantity)) then - select case (quantity) - case("1") - quantity_1 = .true. - case("KE") - quantity_KE = .true. - case default - call system_abort("density_sample_radial_mesh_Gaussians called with unknown quantity='"//trim(quantity)//"'") - end select - else - quantity_1 = .true. - endif - if (quantity_1) sample_weight = 1.0_dp - - my_accumulate = optional_default(.false., accumulate) - if (.not. my_accumulate) histogram = 0.0_dp - - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - - if (present(radial_pos)) then - do rad_sample_i=1, n_rad_bins - rad_sample_r = (rad_sample_i-1)*rad_bin_width - radial_pos(rad_sample_i) = rad_sample_r - end do - endif - - ! ratio of 20/4=5 is bad - ! ratio of 20/3=6.66 is bad - ! ratio of 20/2.5=8 is borderline (2e-4) - ! ratio of 20/2.22=9 is fine (error 2e-5) - ! ratio of 20/2=10 is definitely fine - if (min(norm(at%lattice(:,1)), norm(at%lattice(:,2)), norm(at%lattice(:,3))) < 9.0_dp*gaussian_sigma) & - call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) - - if (present(center_i)) then - use_center_pos = at%pos(:,center_i) - else - use_center_pos = center_pos - end if - - s_sq = gaussian_sigma**2 - s_cu = s_sq*gaussian_sigma - do at_i=1, at%N - if (.not. mask_a(at_i)) cycle - if (present(center_i)) then - if (at_i == center_i) cycle - endif - if (quantity_KE) then - if (associated(at%velo)) then - sample_weight = kinetic_energy(ElementMass(at%Z(at_i)), at%velo(1:3,at_i)) - else - sample_weight = 0.0_dp - endif - endif - d = distance_min_image(at,use_center_pos,at%pos(:,at_i)) - ! skip if atom is outside range - if (d > (n_rad_bins-1)*rad_bin_width+6.0_dp*gaussian_sigma) cycle - do rad_sample_i=1, n_rad_bins - rad_sample_r = (rad_sample_i-1)*rad_bin_width - r0 = rad_sample_r - ep = 0.0_dp - exp_arg = -(r0+d)**2/s_sq - if (exp_arg > -20.0_dp) ep = exp(exp_arg) - em = 0.0_dp - exp_arg = -(r0-d)**2/s_sq - if (exp_arg > -20.0_dp) em = exp(exp_arg) - ! should really fix d->0 limit - if (d .feq. 0.0_dp) then - h_val = 0.0_dp - exp_arg = -r0**2/s_sq - if (exp_arg > -20.0_dp) & - h_val = exp(exp_arg) / (PI_THREE_HALVES * s_cu) - else if (r0 .feq. 0.0_dp) then - h_val = 0.0_dp - exp_arg = -d**2/s_sq - if (exp_arg > -20.0_dp) & - h_val = exp(exp_arg) / (PI_THREE_HALVES * s_cu) - else - h_val = (r0/(SQROOT_PI * gaussian_sigma * d) * (em - ep)) / (4.0_dp * PI * r0**2) - endif - histogram(rad_sample_i) = histogram(rad_sample_i) + sample_weight*h_val - end do ! rad_sample_i - end do ! at_i - -end subroutine density_sample_radial_mesh_Gaussians - -! from LAMMPS "compute xrd" documentation -subroutine xrd_calc(xrd, at, lambda, range_2theta, n_2theta, k_spacing, do_Lorentz_polarization, pos_2theta) - real(dp), intent(inout) :: xrd(:) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: lambda - real(dp), intent(in) :: range_2theta(2) - integer, intent(in) :: n_2theta - real(dp), intent(in) :: k_spacing - logical, intent(in) :: do_Lorentz_polarization - real(dp) , intent(inout), optional :: pos_2theta(:) - - integer :: i_at, i_2theta - real(dp) :: min_norm_k, max_norm_k - integer :: n_k, k1, k2, k3, k_max, last_n_k - real(dp) :: k(3) - integer :: theta_i - integer, allocatable :: theta_i_of_k(:), Z_of_type(:) - real(dp), allocatable :: ks(:,:), sin_sq_theta_over_lambda_sq(:), ASF(:), k_dot_r(:,:), theta(:) - complex(dp), allocatable :: exp_2_pi_i_k_dot_r(:,:), F_k(:) - integer :: i_type, i_Z, n_types, i_k - complex(dp) :: two_pi_i - integer :: i_div, n_k_div - real(dp) :: k_grid(3,3) - logical :: done_any - - if (present(pos_2theta)) then - do i_2theta=1, n_2theta - pos_2theta(i_2theta) = range_2theta(1) + & - (i_2theta-1)*(range_2theta(2)-range_2theta(1)) / real(n_2theta-1.0_dp,dp) - end do - end if - - do i_div=1, 3 - if (k_spacing > 0) then - !NB g^T - n_k_div = max(1,nint(norm(at%g(i_div,:))/k_spacing)) - else - n_k_div = -nint(k_spacing) - endif - !NB g^T - k_grid(:,i_div) = at%g(i_div,:)/n_k_div - end do - - min_norm_k = 2.0*sin(range_2theta(1)/2.0)/lambda - max_norm_k = 2.0*sin(range_2theta(2)/2.0)/lambda - ! print *, "norm k range ", min_norm_k, max_norm_k - ! print *, "k range ", k_max - last_n_k = -1 - n_k = 0 - k_max = 0 - done_any = .false. - do while (last_n_k /= n_k .or. .not. done_any) - last_n_k = n_k - do k1 = -k_max, k_max - do k2 = -k_max, k_max - do k3 = -k_max, k_max - if (abs(k1) == k_max .or. abs(k2) == k_max .or. abs(k3) == k_max) then - k = k1*k_grid(:,1) + k2*k_grid(:,2) + k3*k_grid(:,3) - if (norm(k) >= min_norm_k .and. norm(k) <= max_norm_k) then - n_k = n_k + 1 - done_any = .true. - end if - end if - end do - end do - end do - k_max = k_max + 1 - end do - - print *, "n_k ", n_k, " norm(k_grid) ", norm(k_grid(:,1)),norm(k_grid(:,2)),norm(k_grid(:,3)) - - allocate(ks(n_k,3)) - allocate(theta_i_of_k(n_k), sin_sq_theta_over_lambda_sq(n_k), theta(n_k)) - - last_n_k = -1 - n_k = 0 - k_max = 0 - done_any = .false. - do while (last_n_k /= n_k .or. .not. done_any) - last_n_k = n_k - do k1 = -k_max, k_max - do k2 = -k_max, k_max - do k3 = -k_max, k_max - if (abs(k1) == k_max .or. abs(k2) == k_max .or. abs(k3) == k_max) then - k = k1*k_grid(:,1) + k2*k_grid(:,2) + k3*k_grid(:,3) - if (norm(k) >= min_norm_k .and. norm(k) <= max_norm_k) then - done_any = .true. - n_k = n_k + 1 - ks(n_k,:) = k - theta(n_k) = asin(norm(k)*lambda/2.0) - sin_sq_theta_over_lambda_sq(n_k) = (norm(k)/2.0)**2 - theta_i = int(n_2theta*(2.0*theta(n_k) - range_2theta(1))/(range_2theta(2)-range_2theta(1)))+1 - theta_i_of_k(n_k) = theta_i - endif - endif - end do - end do - end do - k_max = k_max + 1 - end do - - allocate(exp_2_pi_i_k_dot_r(n_k, at%n)) - allocate(k_dot_r(n_k, at%n)) - ! ks: N_kx3 - ! pos: 3xN_at - ! ks * pos = N_k * N_at - call matrix_product_sub(k_dot_r, ks, at%pos) - deallocate(ks) - two_pi_i = 2.0*PI*cmplx(0.0_dp, 1.0_dp) - !$omp parallel do - do i_k=1, n_k - exp_2_pi_i_k_dot_r(i_k,:) = exp(two_pi_i*k_dot_r(i_k,:)) - end do - !$omp end parallel do - deallocate(k_dot_r) - - allocate(Z_of_type(at%n)) - allocate(ASF(n_k)) - n_types = 0 - do i_Z=1, maxval(at%Z) - if (any(at%Z == i_Z)) then - n_types = n_types + 1 - Z_of_type(n_types) = i_Z - endif - end do - do i_type=1, n_types - ! omp parallel inside function - ASF = atomic_structure_factor(Z_of_type(i_type), sin_sq_theta_over_lambda_sq(:)) - do i_at = 1, at%n - if (at%Z(i_at) == Z_of_type(i_type)) then - !$omp parallel do - do i_k = 1, n_k - exp_2_pi_i_k_dot_r(i_k,i_at) = exp_2_pi_i_k_dot_r(i_k,i_at) * ASF(i_k) - end do - !$omp end parallel do - endif - end do - end do - deallocate(ASF, Z_of_type, sin_sq_theta_over_lambda_sq) - - allocate(F_k(n_k)) - ! F_k = sum(exp_2_pi_i_k_dot_r, dim=2) - !$omp parallel do - do i_k=1, n_k - F_k(i_k) = sum(exp_2_pi_i_k_dot_r(i_k,:)) - end do - !$omp end parallel do - deallocate(exp_2_pi_i_k_dot_r) - - if (do_Lorentz_polarization) then - !$omp parallel do - do i_k=1, n_k - F_k(i_k) = F_k(i_k) * (1.0+cos(2.0*theta(i_k))**2)/(cos(theta(i_k))*sin(theta(i_k))**2) - end do - !$omp end parallel do - endif - deallocate(theta) - - !$omp parallel do - do i_2theta = 1, n_2theta - xrd(i_2theta) = sum(abs(F_k)**2, mask=(theta_i_of_k == i_2theta)) / at%n - end do - !$omp end parallel do - deallocate(theta_i_of_k) - - deallocate(F_k) - -end subroutine xrd_calc - -function atomic_structure_factor(Z, sin_sq_theta_over_lambda_sq) result (ASF) - integer :: Z - real(dp) :: sin_sq_theta_over_lambda_sq(:) - real(dp) :: ASF(size(sin_sq_theta_over_lambda_sq)) - - integer :: i, i_k - - ! print *, "Z ", Z, ASF_c(Z), ASF_a(:,Z), ASF_b(:,Z) - ASF = ASF_c(Z) - do i=1, 4 - !$omp parallel do - do i_k=1, size(ASF) - ASF(i_k) = ASF(i_k) + ASF_a(i,Z)*exp(-ASF_b(i,Z)*sin_sq_theta_over_lambda_sq(i_k)) - end do - !$omp end parallel do - end do -end function - -subroutine rdfd_calc(rdfd, at, zone_center, zone_atom_center, bin_width, n_bins, zone_width, n_zones, gaussian_smoothing, gaussian_sigma, & - center_mask_str, neighbour_mask_str, bin_pos, zone_pos) - real(dp), intent(inout) :: rdfd(:,:) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: zone_center(3), bin_width, zone_width - integer :: zone_atom_center - integer, intent(in) :: n_bins, n_zones - logical, intent(in) :: gaussian_smoothing - real(dp), intent(in) :: gaussian_sigma - character(len=*), intent(in) :: center_mask_str, neighbour_mask_str - real(dp), intent(inout), optional :: bin_pos(:), zone_pos(:) - - logical, allocatable :: center_mask_a(:), neighbour_mask_a(:) - integer :: i_at, j_at, i_bin, i_zone - integer, allocatable :: n_in_zone(:) - real(dp) :: r, bin_inner_rad, bin_outer_rad, my_zone_center(3) - - allocate(center_mask_a(at%N)) - allocate(neighbour_mask_a(at%N)) - call is_in_mask(center_mask_a, at, center_mask_str) - call is_in_mask(neighbour_mask_a, at, neighbour_mask_str) - - allocate(n_in_zone(n_zones)) - n_in_zone = 0 - - if (present(zone_pos)) then - if (zone_width > 0.0_dp) then - do i_zone=1, n_zones - zone_pos(i_zone) = (real(i_zone,dp)-0.5_dp)*zone_width - end do - else - zone_pos(1) = -1.0_dp - endif - endif - if (present(bin_pos)) then - do i_bin=1, n_bins - if (gaussian_smoothing) then - bin_pos(i_bin) = (i_bin-1)*bin_width - else - bin_pos(i_bin) = (real(i_bin,dp)-0.5_dp)*bin_width - endif - end do - endif - -! if (gaussian_smoothing) then -! call set_cutoff(at, n_bins*bin_width+5.0_dp*gaussian_sigma) -! call calc_connect(at) -! endif - - rdfd = 0.0_dp - do i_at=1, at%N ! loop over center atoms - if (.not. center_mask_a(i_at)) cycle - - !calc which zone the atom is in - if (zone_width > 0.0_dp) then - if (zone_atom_center > 0) then - if (zone_atom_center <= at%N) then - my_zone_center = at%pos(:,zone_atom_center) - else - call system_abort("rdfd_calc got zone_atom_center="//zone_atom_center//" out of range (1.."//at%N//")") - endif - else - my_zone_center = zone_center - endif - r = distance_min_image(at, my_zone_center, at%pos(:,i_at)) - i_zone = int(r/zone_width)+1 - if (i_zone > n_zones) cycle - else - i_zone = 1 - endif - - !count the number of atoms in that zone - n_in_zone(i_zone) = n_in_zone(i_zone) + 1 - - !calc rdfd in each bin for this zone - if (gaussian_smoothing) then - call density_sample_radial_mesh_Gaussians(rdfd(:,i_zone), at, center_i=i_at, rad_bin_width=bin_width, n_rad_bins=n_bins, & - gaussian_sigma=gaussian_sigma, mask_str=neighbour_mask_str, accumulate = .true.) - else - !loop over atoms and advance the bins - do j_at=1, at%N - if (j_at == i_at) cycle - if (.not. neighbour_mask_a(j_at)) cycle - r = distance_min_image(at, i_at, j_at) - i_bin = int(r/bin_width)+1 - if (i_bin <= n_bins) rdfd(i_bin,i_zone) = rdfd(i_bin,i_zone) + 1.0_dp - end do ! j_at - endif ! gaussian_smoothing - end do ! i_at - - if (.not. gaussian_smoothing) then - !calculate local density by dividing bins with their volumes - do i_bin=1, n_bins - bin_inner_rad = real(i_bin-1,dp)*bin_width - bin_outer_rad = real(i_bin,dp)*bin_width - rdfd(i_bin,:) = rdfd(i_bin,:)/(4.0_dp/3.0_dp*PI*bin_outer_rad**3 - 4.0_dp/3.0_dp*PI*bin_inner_rad**3) - end do - end if - - ! normalise zones by the number of atoms in that zone - do i_zone=1, n_zones - if (n_in_zone(i_zone) > 0) rdfd(:,i_zone) = rdfd(:,i_zone)/real(n_in_zone(i_zone),dp) - end do - ! normalise with the global density - if (count(neighbour_mask_a) > 0) then - rdfd = rdfd / (count(neighbour_mask_a)/cell_volume(at)) - endif - -end subroutine rdfd_calc - -subroutine propdf_radial_calc(histograms, at, bin_width, n_bins, & - zone_center, zone_width, n_zones, gaussian_sigma, mask_str, property, bin_pos, zone_pos) - real(dp), intent(inout) :: histograms(:,:) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: bin_width, zone_width - integer, intent(in) :: n_bins, n_zones - real(dp), intent(in) :: gaussian_sigma - real(dp), intent(in) :: zone_center(3) - character(len=*), intent(in) :: mask_str, property - real(dp), intent(inout), optional :: bin_pos(:), zone_pos(:) - - logical, allocatable :: mask_a(:) - integer :: i_at, i_bin_ctr, i_bin, i_zone - integer, allocatable :: n_in_zone(:) - real(dp) :: n, quant, r, bin_ctr - logical :: has_mass - logical :: doing_KE - real(dp), pointer :: prop_a(:), prop_3a(:,:) - logical :: prop_is_scalar - - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - - doing_KE = (trim(property) == 'KE') - - if (len_trim(property) == 0) & - call system_abort("propdf_radial_calc has no property specified. Are you sure you passed a propdf_radial_property value?") - - if (doing_KE) then ! KE is a special case - has_mass = has_property(at, 'mass') - if (.not. has_property(at, 'velo')) & - call system_abort("propdf_radial_calc has no 'velo' property in Atoms structure") - else ! assign pointers for property - if (.not. has_property(at, property)) & - call system_abort("propdf_radial_calc has no '"//trim(property)//"' property in Atoms structure") - - prop_is_scalar = .true. - if (.not. assign_pointer(at, trim(property), prop_a)) then - prop_is_scalar = .false. - if (.not. assign_pointer(at, trim(property), prop_3a)) then - call system_abort("propdf_radial_calc failed to assign 1- or 3-array real(dp) pointer for property '"//trim(property)) - endif - endif - endif - - allocate(n_in_zone(n_zones)) - n_in_zone = 0 - - if (present(zone_pos)) then - if (zone_width > 0.0_dp) then - do i_zone=1, n_zones - zone_pos(i_zone) = (real(i_zone,dp)-0.5_dp)*zone_width - end do - else - zone_pos(1) = -1.0_dp - endif - endif - if (present(bin_pos)) then - do i_bin=1, n_bins - bin_pos(i_bin) = (i_bin-1)*bin_width - end do - endif - - histograms = 0.0_dp - do i_at=1, at%N ! loop over atoms - if (.not. mask_a(i_at)) cycle - - !calc which zone the atom is in - if (zone_width > 0.0_dp) then - r = distance_min_image(at, zone_center, at%pos(:,i_at)) - i_zone = int(r/zone_width)+1 - if (i_zone > n_zones) cycle - else - i_zone = 1 - endif - - !count the number of atoms in that zone - n_in_zone(i_zone) = n_in_zone(i_zone) + 1 - - if (doing_KE) then - !calc KE for this atom - if (has_mass) then - quant = kinetic_energy(at%mass(i_at), at%velo(:,i_at)) - else - quant = kinetic_energy(ElementMass(at%Z(i_at)), at%velo(:,i_at)) - endif - else - if (prop_is_scalar) then - quant = prop_a(i_at) - else - quant = norm(prop_3a(:,i_at)) - endif - endif - i_bin_ctr = quant/bin_width - do i_bin=max(1,i_bin_ctr-floor(6*gaussian_sigma/bin_width)), min(n_bins,i_bin_ctr+floor(6*gaussian_sigma/bin_width)) - bin_ctr = (i_bin-1)*bin_width - histograms(i_bin,i_zone) = histograms(i_bin,i_zone) + exp(-0.5*(quant-bin_ctr)**2/gaussian_sigma**2) - end do - end do ! i_at - - ! normalise zones by the number of atoms in that zone - n = gaussian_sigma/sqrt(2.0_dp*PI) - do i_zone=1, n_zones - if (n_in_zone(i_zone) > 0) histograms(:,i_zone) = n*histograms(:,i_zone)/real(n_in_zone(i_zone),dp) - end do - -end subroutine propdf_radial_calc - -subroutine adfd_calc(adfd, at, zone_center, n_angle_bins, dist_bin_width, n_dist_bins, zone_width, n_zones, & - center_mask_str, neighbour_1_mask_str, neighbour_1_max_dist, neighbour_2_mask_str, & - dist_bin_rc2, angle_bin_pos, dist_bin_pos, zone_pos) - real(dp), intent(inout) :: adfd(:,:,:) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: zone_center(3), dist_bin_width, zone_width - integer, intent(in) :: n_angle_bins, n_dist_bins, n_zones - character(len=*), intent(in) :: center_mask_str, neighbour_1_mask_str, neighbour_2_mask_str - real(dp), intent(in) :: neighbour_1_max_dist - logical, intent(in) :: dist_bin_rc2 - real(dp), intent(inout), optional :: angle_bin_pos(:), dist_bin_pos(:), zone_pos(:) - - logical, allocatable :: center_mask_a(:), neighbour_1_mask_a(:), neighbour_2_mask_a(:) - integer :: i_at, j_at, k_at, i_dist_bin, i_angle_bin, i_zone, ji, ki - integer, allocatable :: n_in_zone(:) - real(dp) :: dist_bin_inner_rad, dist_bin_outer_rad, angle_bin_width, angle_bin_min, angle_bin_max - real(dp) :: r, r_ij, r_ik, r_jk, jik_angle - integer :: sj(3), sk(3) - real(dp) :: c_ij(3), c_ik(3) - - allocate(center_mask_a(at%N), neighbour_1_mask_a(at%N), neighbour_2_mask_a(at%N)) - call is_in_mask(center_mask_a, at, center_mask_str) - call is_in_mask(neighbour_1_mask_a, at, neighbour_1_mask_str) - call is_in_mask(neighbour_2_mask_a, at, neighbour_2_mask_str) - - allocate(n_in_zone(n_zones)) - n_in_zone = 0 - - if (present(zone_pos)) then - if (zone_width > 0.0_dp) then - do i_zone= 1, n_zones - zone_pos(i_zone) = (real(i_zone,dp)-0.5_dp)*zone_width - end do - else - zone_pos(1) = -1.0_dp - end if - end if - if (present(dist_bin_pos)) then - do i_dist_bin=1, n_dist_bins - dist_bin_pos(i_dist_bin) = (real(i_dist_bin,dp)-0.5_dp)*dist_bin_width - end do - end if - angle_bin_width = PI/real(n_angle_bins,dp) - if (present(angle_bin_pos)) then - do i_angle_bin=1, n_angle_bins - angle_bin_pos(i_angle_bin) = (real(i_angle_bin,dp)-0.5_dp)*angle_bin_width - end do - end if - - adfd = 0.0_dp - call set_cutoff(at, max(neighbour_1_max_dist,2*n_dist_bins*dist_bin_width)) - call calc_connect(at) - do i_at=1, at%N ! center atom - if (.not. center_mask_a(i_at)) cycle - if (zone_width > 0.0_dp) then - r = distance_min_image(at, zone_center, at%pos(:,i_at)) - i_zone = int(r/zone_width)+1 - if (i_zone > n_zones) cycle - else - i_zone = 1 - endif - n_in_zone(i_zone) = n_in_zone(i_zone) + 1 - do ji=1, n_neighbours(at, i_at) - j_at = neighbour(at, i_at, ji, shift=sj, cosines=c_ij, distance=r_ij) - if (r_ij == 0.0_dp) cycle - if (.not. neighbour_1_mask_a(j_at)) cycle - if (neighbour_1_max_dist > 0.0_dp) then - if (r_ij > neighbour_1_max_dist) cycle - else - if (r_ij > bond_length(at%Z(i_at),at%Z(j_at))*at%nneightol) cycle - endif - do ki=1, n_neighbours(at, i_at) - k_at = neighbour(at, i_at, ki, shift=sk, cosines=c_ik, distance=r_ik) - if (r_ik == 0.0_dp .or. (k_at == j_at .and. all (sj == sk))) cycle - if (.not. neighbour_2_mask_a(k_at)) cycle - r_jk = distance_min_image(at, j_at, k_at) - if (dist_bin_rc2) then - i_dist_bin = int(r_ik/dist_bin_width)+1 - else - i_dist_bin = int(r_jk/dist_bin_width)+1 - endif - if (i_dist_bin > n_dist_bins) cycle -! call print("doing triplet ijk " // i_at // " " // j_at // " "// k_at, PRINT_ALWAYS) -! call print(" Zijk " // at%Z(i_at) // " " // at%Z(j_at) // " " // at%Z(k_at), PRINT_ALWAYS) -! call print(" pi " // at%pos(:,i_at), PRINT_ALWAYS) -! call print(" pj " // at%pos(:,j_at), PRINT_ALWAYS) -! call print(" pk " // at%pos(:,k_at), PRINT_ALWAYS) -! call print(" r_ij " // diff_min_image(at,i_at,j_at) // " " // r_ij, PRINT_ALWAYS) -! call print(" r_jk " // diff_min_image(at,j_at,k_at) // " " // distance_min_image(at, j_at, k_at), PRINT_ALWAYS) -! call print(" r_ik " // diff_min_image(at,i_at,k_at) // " " // distance_min_image(at, i_at, k_at), PRINT_ALWAYS) - ! jik_angle = angle(diff_min_image(at,i_at,j_at), diff_min_image(at,i_at,k_at)) - jik_angle = angle(c_ij, c_ik) -! call print(" r_ij " // r_ij // " r_jk " // r_jk // " jik_angle " // (jik_angle*180.0/PI), PRINT_ALWAYS) - i_angle_bin = int(jik_angle/angle_bin_width)+1 - if (i_angle_bin > n_angle_bins) i_angle_bin = n_angle_bins - adfd(i_angle_bin,i_dist_bin,i_zone) = adfd(i_angle_bin,i_dist_bin,i_zone) + 1.0_dp ! /(2.0_dp*PI*sin(jik_angle)) - end do ! k_at - end do ! j_at - end do ! i_at - - do i_angle_bin=1, n_angle_bins - angle_bin_min = real(i_angle_bin-1,dp)*angle_bin_width - angle_bin_max = real(i_angle_bin,dp)*angle_bin_width - do i_dist_bin=1, n_dist_bins - dist_bin_inner_rad = real(i_dist_bin-1,dp)*dist_bin_width - dist_bin_outer_rad = real(i_dist_bin,dp)*dist_bin_width - adfd(i_angle_bin,i_dist_bin,:) = adfd(i_angle_bin,i_dist_bin,:) / (2.0_dp*PI * ((dist_bin_outer_rad**3 - dist_bin_inner_rad**3)/3.0_dp) * (cos(angle_bin_min)-cos(angle_bin_max))) - ! adfd(i_angle_bin,i_dist_bin,:) = adfd(i_angle_bin,i_dist_bin,:) / (4.0_dp/3.0_dp*PI * (dist_bin_outer_rad**3 - dist_bin_inner_rad**3)) - end do - end do - - ! normalise zones by the number of atoms in that zone - do i_zone=1, n_zones - if (n_in_zone(i_zone) > 0) adfd(:,:,i_zone) = adfd(:,:,i_zone)/real(n_in_zone(i_zone),dp) - end do - ! normalise with the global density - if (count(neighbour_2_mask_a) > 0) then - adfd = adfd / (count(neighbour_2_mask_a)/cell_volume(at)) - endif - -end subroutine adfd_calc - -subroutine density_sample_rectilinear_mesh_Gaussians(histogram, at, min_p, sample_dist, n_bins, gaussian_sigma, mask_str, grid_pos, accumulate) - real(dp), intent(inout) :: histogram(:,:,:) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: min_p(3), sample_dist(3) - integer, intent(in) :: n_bins(3) - real(dp), intent(in) :: gaussian_sigma - character(len=*), optional, intent(in) :: mask_str - real(dp), intent(out), optional :: grid_pos(:,:,:,:) - logical, optional, intent(in) :: accumulate - - logical :: my_accumulate - integer :: at_i, i1, i2, i3 - real(dp) :: p(3), w, dist - logical, allocatable :: mask_a(:) - - my_accumulate = optional_default(.false., accumulate) - if (.not. my_accumulate) histogram = 0.0_dp - - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - -! ratio of 20/4=5 is bad -! ratio of 20/3=6.66 is bad -! ratio of 20/2.5=8 is borderline (2e-4) -! ratio of 20/2.22=9 is fine (error 2e-5) -! ratio of 20/2=10 is fine - if ( (norm(at%lattice(:,1)) < 9.0_dp*gaussian_sigma) .or. & - (norm(at%lattice(:,2)) < 9.0_dp*gaussian_sigma) .or. & - (norm(at%lattice(:,3)) < 9.0_dp*gaussian_sigma) ) & - call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) - - w = 1.0_dp / (gaussian_sigma*sqrt(2.0_dp*PI))**3 - - if (present(grid_pos)) then - do i1=1, n_bins(1) - p(1) = min_p(1) + (i1-1)*sample_dist(1) - do i2=1, n_bins(2) - p(2) = min_p(2) + (i2-1)*sample_dist(2) - do i3=1, n_bins(3) - p(3) = min_p(3) + (i3-1)*sample_dist(3) - grid_pos(:,i1,i2,i3) = p - end do - end do - end do - endif - - do at_i=1, at%N - if (.not. mask_a(at_i)) cycle - do i1=1, n_bins(1) - p(1) = min_p(1) + (i1-1)*sample_dist(1) - do i2=1, n_bins(2) - p(2) = min_p(2) + (i2-1)*sample_dist(2) - do i3=1, n_bins(3) - p(3) = min_p(3) + (i3-1)*sample_dist(3) - dist = distance_min_image(at,p,at%pos(:,at_i)) - histogram(i1,i2,i3) = histogram(i1,i2,i3) + exp(-0.5_dp*(dist/(gaussian_sigma))**2)*w - end do ! i3 - end do ! i2 - end do ! i1 - end do ! at_i - - deallocate(mask_a) -end subroutine density_sample_rectilinear_mesh_Gaussians - -subroutine density_bin_rectilinear_mesh(histogram, at, min_p, bin_width, n_bins, mask_str, grid_pos, accumulate) - real(dp), intent(inout) :: histogram(:,:,:) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: min_p(3), bin_width(3) - integer, intent(in) :: n_bins(3) - character(len=*), optional, intent(in) :: mask_str - real(dp), intent(out), optional :: grid_pos(:,:,:,:) - logical, optional, intent(in) :: accumulate - - logical :: my_accumulate - integer :: i, i1, i2, i3, bin(3) - logical, allocatable :: mask_a(:) - real(dp) :: p(3) - - my_accumulate = optional_default(.false., accumulate) - if (.not. my_accumulate) histogram = 0.0_dp - - if (present(grid_pos)) then - do i1=1, n_bins(1) - p(1) = min_p(1) + (real(i1,dp)-0.5_dp)*bin_width(1) - do i2=1, n_bins(2) - p(2) = min_p(2) + (real(i2,dp)-0.5_dp)*bin_width(2) - do i3=1, n_bins(3) - p(3) = min_p(3) + (real(i3,dp)-0.5_dp)*bin_width(3) - grid_pos(:,i1,i2,i3) = p - end do - end do - end do - endif - - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - - do i=1, at%N - if (.not. mask_a(i)) cycle - bin = floor((at%pos(:,i)-min_p)/bin_width)+1 - if (all(bin >= 1) .and. all (bin <= n_bins)) histogram(bin(1),bin(2),bin(3)) = histogram(bin(1),bin(2),bin(3)) + 1.0_dp - end do - - deallocate(mask_a) - -end subroutine density_bin_rectilinear_mesh - -!Calculates distances, angles, dihedrals of the given atoms -subroutine geometry_calc(histogram, at, geometry_params, central_atom, geometry_pos, geometry_label) - - real(dp), intent(inout) :: histogram(:) - type(Atoms), intent(inout) :: at - type(Table), intent(in) :: geometry_params - integer, intent(in) :: central_atom - real(dp), intent(out), optional :: geometry_pos(:) - character(STRING_LENGTH), intent(out), optional :: geometry_label(:) - - integer :: i, j, geom_type - integer :: atom1, atom2, atom3, atom4 - real(dp) :: shift(3), bond12(3),bond23(3),bond34(3) - real(dp) :: a, b, c, dist, min_dist - logical :: found - - !center around central_atom if requested - if (central_atom.gt.at%N) call system_abort('central atom is greater than atom number '//at%N) - if (central_atom.gt.0) then !center around central_atom - shift = at%pos(1:3,central_atom) - do j=1,at%N - at%pos(1:3,j) = at%pos(1:3,j) - shift(1:3) - enddo - call map_into_cell(at) !only in this case, otherwise it has been mapped - endif - - !loop over the parameters to calculate - do i=1, geometry_params%N - geom_type=geometry_params%int(1,i) - atom1 = geometry_params%int(2,i) - atom2 = geometry_params%int(3,i) - atom3 = geometry_params%int(4,i) - atom4 = geometry_params%int(5,i) - select case (geom_type) - case(1) !y coord atom1 - if (atom1<1.or.atom1>at%N) call system_abort('atom1 must be >0 and < '//at%N) - histogram(i) = at%pos(2,atom1) - case(2) !distance atom1-atom2 - if (atom1<1.or.atom1>at%N) call system_abort('atom1 must be >0 and < '//at%N) - if (atom2<1.or.atom2>at%N) call system_abort('atom2 must be >0 and < '//at%N) - !histogram(i) = norm(at%pos(1:3,atom1)-at%pos(1:3,atom2)) - histogram(i) = distance_min_image(at,atom1,atom2) - case(3) !angle atom1-atom2-atom3 - if (atom1<1.or.atom1>at%N) call system_abort('atom1 must be >0 and < '//at%N) - if (atom2<1.or.atom2>at%N) call system_abort('atom2 must be >0 and < '//at%N) - if (atom3<1.or.atom2>at%N) call system_abort('atom3 must be >0 and < '//at%N) - !histogram(i) = angle(at%pos(1:3,atom1)-at%pos(1:3,atom2), & - ! at%pos(1:3,atom3)-at%pos(1:3,atom2)) - histogram(i) = angle(diff_min_image(at,atom2,atom1), & - diff_min_image(at,atom2,atom3)) - case(4) !dihedral atom1-(bond12)->atom2-(bond23)->atom3-(bond34)->atom4 - if (atom1<1.or.atom1>at%N) call system_abort('atom1 must be >0 and < '//at%N) - if (atom2<1.or.atom2>at%N) call system_abort('atom2 must be >0 and < '//at%N) - if (atom3<1.or.atom2>at%N) call system_abort('atom3 must be >0 and < '//at%N) - if (atom4<1.or.atom2>at%N) call system_abort('atom4 must be >0 and < '//at%N) - !bond12(1:3) = at%pos(1:3,atom2)-at%pos(1:3,atom1) - bond12(1:3) = diff_min_image(at,atom1,atom2) - !bond23(1:3) = at%pos(1:3,atom3)-at%pos(1:3,atom2) - bond23(1:3) = diff_min_image(at,atom2,atom3) - !bond34(1:3) = at%pos(1:3,atom4)-at%pos(1:3,atom3) - bond34(1:3) = diff_min_image(at,atom3,atom4) - histogram(i) = atan2(norm(bond23(1:3)) * bond12(1:3).dot.(bond23(1:3).cross.bond34(1:3)), & - (bond12(1:3).cross.bond23(1:3)) .dot. (bond23(1:3).cross.bond34(1:3))) - case(5) !distance of atom3-Z from atom1-atom2 bond - min_dist=HUGE(1._dp) - found=.false. - do j=1, at%N - if (j==atom1 .or. j==atom2) cycle - if (at%Z(j)/=atom3) cycle - if (j<=6) cycle !CH3Cl2- specific!!! - !only close ones - a = distance_min_image(at,atom1,atom2) - b = distance_min_image(at,atom1,j) - c = distance_min_image(at,atom2,j) -! if (b>4.0_dp .or. c>4.0_dp) cycle - if (b>a .or. c>a) cycle - dist = 0.25_dp*sqrt((a+b+c)*(b+c-a)*(c+a-b)*(a+b-c)) / (0.5_dp*a) - if (dist0) return - - !find the com of the silica (using the Si atoms) and move that to the edges in this direction - shift(1:3) = at%pos(1:3,1) - do i=1,at%N - at%pos(1:3,i) = at%pos(1:3,i) - shift(1:3) - enddo - call map_into_cell(at) - allocate(mask_silica(at%N)) - call is_in_mask(mask_silica, at, "Si") - allocate(Si_atoms(count(mask_silica))) - counter = 0 - do i=1,at%N - if (mask_silica(i)) then - counter = counter + 1 - Si_atoms(counter) = i - endif - enddo - !allocate(at%mass(at%N)) - !at%mass = ElementMass(at%Z) - call add_property(at,"mass",0._dp) - if (.not.(assign_pointer(at, "mass", mass_p))) call system_abort('??') - mass_p = ElementMass(at%Z) - com = centre_of_mass(at,index_list=Si_atoms(1:size(Si_atoms)),origin=1) - !shift axis to the edge (-0.5*edge_length) - at%pos(axis,1:at%N) = at%pos(axis,1:at%N) - 0.5_dp * at%lattice(axis,axis) - com(axis) - call map_into_cell(at) !everyone becomes -0.5b0) then ! silica - call shift_silica_to_edges(at, axis, silica_center_i, mask_str) - endif - - !now bins are from -axis/2 to axis/2 - !shift everyone to positive coordinate along axis - at%pos(axis,1:at%N) = at%pos(axis,1:at%N) + 0.5_dp * at%lattice(axis,axis) - - - !simply check distances and bin them - - - ! ratio of 20/4=5 is bad - ! ratio of 20/3=6.66 is bad - ! ratio of 20/2.5=8 is borderline (2e-4) - ! ratio of 20/2.22=9 is fine (error 2e-5) - ! ratio of 20/2=10 is fine - if ( gaussian_smoothing .and. (at%lattice(axis,axis) < 9.0_dp*gaussian_sigma) ) & - call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) - - if (gaussian_smoothing) then - - do at_i=1, at%N - if (silica_center_i>0 .and. at_i<=silica_center_i) cycle !ignore silica atoms - if (.not. mask_a(at_i)) cycle - r = at%pos(axis,at_i) - do ax_sample_i=1, n_bins - - ax_sample_r = (real(ax_sample_i,dp)-0.5_dp)*bin_width - dist = abs(r - ax_sample_r) -!Include all the atoms, slow but minimises error -! if (dist > 4.0_dp*gaussian_sigma) cycle - exp_arg = -0.5_dp*(dist/(gaussian_sigma))**2 - if (exp_arg > -20.0_dp) then ! good to about 1e-8 - histogram(ax_sample_i) = histogram(ax_sample_i) + exp(exp_arg)/(gaussian_sigma*sqrt(2.0_dp*PI)) !Gaussian in 1 dimension - endif - - end do ! ax_sample_i - end do ! at_i - - else !no gaussian_smoothing - - do at_i=1, at%N - if (silica_center_i>0 .and. at_i<=silica_center_i) cycle !ignore silica atoms - if (.not. mask_a(at_i)) cycle - r = at%pos(axis,at_i) - - histogram(int(r/bin_width)+1) = histogram(int(r/bin_width)+1) + 1 - - end do ! at_i - - endif - - deallocate(mask_a) -end subroutine density_axial_calc - -! -! Calculates the number of H-bonds along an axis -! -- 1st center around atom 1 -! -- then calculate COM of Si atoms -! -- then shift the centre of mass along the y axis to y=0 -! -- calculate H bonds for -! water - water -! water - silica -! silica - water -! silica - silica -! interactions -! -- the definition of a H-bond (O1-H1 - - O2): -! d(O1,O2) < 3.5 A -! d(O2,H1) < 2.45 A -! angle(H1,O1,O2) < 30 degrees -! source: P. Jedlovszky, J.P. Brodholdt, F. Bruni, M.A. Ricci and R. Vallauri, J. Chem. Phys. 108, 8525 (1998) -! -subroutine num_hbond_calc(histogram, at, axis, silica_center_i,n_bins, gaussian_smoothing, gaussian_sigma, mask_str, num_hbond_pos, num_hbond_type_code, num_hbond_type_label,accumulate) - real(dp), intent(inout) :: histogram(:,:) - type(Atoms), intent(inout) :: at - integer, intent(in) :: axis - integer, intent(in) :: silica_center_i - integer, intent(in) :: n_bins - logical, intent(in) :: gaussian_smoothing - real(dp), intent(in) :: gaussian_sigma - character(len=*), optional, intent(in) :: mask_str - real(dp), optional, intent(out) :: num_hbond_pos(:) - integer, optional, intent(out) :: num_hbond_type_code(:) - character(STRING_LENGTH), optional, intent(out) :: num_hbond_type_label(:) - logical, optional, intent(in) :: accumulate - - logical :: my_accumulate - real(dp) :: num_hbond_sample_r, dist, r, exp_arg - logical, allocatable :: mask_a(:) - integer :: num_hbond_sample_i - real(dp) :: bin_width - real(dp), parameter :: dist_O2_H1 = 2.45_dp - real(dp), parameter :: dist_O1_O2 = 3.5_dp - real(dp), parameter :: angle_H1_O1_O2 = 30._dp -real(dp) :: min_distance, distance, HOO_angle -integer :: H1, O1, i, j, k, O2, num_atoms, hbond_type - - my_accumulate = optional_default(.false., accumulate) - if (.not. my_accumulate) histogram = 0.0_dp - - !atommask - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - - !bin labels - bin_width = at%lattice(axis,axis) / n_bins - if (present(num_hbond_pos)) then - do num_hbond_sample_i=1, n_bins - num_hbond_sample_r = (real(num_hbond_sample_i,dp)-0.5_dp)*bin_width !the middle of the bin - num_hbond_pos(num_hbond_sample_i) = num_hbond_sample_r - end do - endif - if (present(num_hbond_type_label)) then - num_hbond_type_label(1)="water-water" - num_hbond_type_label(2)="water-silica" - num_hbond_type_label(3)="silica-water" - num_hbond_type_label(4)="silica-silica" - endif - if (present(num_hbond_type_code)) then - num_hbond_type_code(1)=11 - num_hbond_type_code(2)=10 - num_hbond_type_code(3)=01 - num_hbond_type_code(4)=00 - endif - - if (silica_center_i>0) then ! silica - call shift_silica_to_edges(at, axis, silica_center_i, mask_str) - endif - - !!calc_connect now, before shifting positions to positive, because it would remap the positions!! - !call calc_connect including the H-bonds - call set_cutoff(at,dist_O2_H1) - call calc_connect(at) - - !now bins are from -axis/2 to axis/2 - !shift everyone to positive coordinate along axis - at%pos(axis,1:at%N) = at%pos(axis,1:at%N) + 0.5_dp * at%lattice(axis,axis) - - !simply check hbonds and bin them - - - ! ratio of 20/4=5 is bad - ! ratio of 20/3=6.66 is bad - ! ratio of 20/2.5=8 is borderline (2e-4) - ! ratio of 20/2.22=9 is fine (error 2e-5) - ! ratio of 20/2=10 is fine - if ( gaussian_smoothing .and. (at%lattice(axis,axis) < 9.0_dp*gaussian_sigma) ) & - call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) - -! call set_cutoff(at,dist_O2_H1) -! call calc_connect(at) - - num_atoms = 0 - do H1=1, at%N - if(at%Z(H1)/=1) cycle !find H: H1 - !Count the atoms - call print('Found H'//H1//ElementName(at%Z(H1)),PRINT_ANALYSIS) - num_atoms = num_atoms + 1 - - !find closest O: O1 - min_distance = huge(1._dp) - O1 = 0 - k = 0 - do i = 1, n_neighbours(at,H1) - j = neighbour(at,H1,i,distance) - if (distancesilica_center_i .and. O2>silica_center_i) then ! water - water - call print('Found water-water H-bond.',PRINT_ANALYSIS) - hbond_type = 1 - elseif (O1>silica_center_i .and. O2<=silica_center_i) then ! water - silica - call print('Found water-silica H-bond.',PRINT_ANALYSIS) - hbond_type = 2 - elseif (O1<=silica_center_i .and. O2>silica_center_i) then ! silica - water - call print('Found silica-water H-bond.',PRINT_ANALYSIS) - hbond_type = 3 - elseif (O1<=silica_center_i .and. O2<=silica_center_i) then ! silica - silica - call print('Found silica-silica H-bond.',PRINT_ANALYSIS) - hbond_type = 4 - endif - - !Build histogram - r = at%pos(axis,H1) !the position of H1 - - if (gaussian_smoothing) then !smear the position along axis - do num_hbond_sample_i=1, n_bins - num_hbond_sample_r = (real(num_hbond_sample_i,dp)-0.5_dp)*bin_width - dist = abs(r - num_hbond_sample_r) -!!!!!!Include all the atoms, slow but minimises error -!!!!!! if (dist > 4.0_dp*gaussian_sigma) cycle - exp_arg = -0.5_dp*(dist/(gaussian_sigma))**2 - if (exp_arg > -20.0_dp) then ! good to about 1e-8 - histogram(num_hbond_sample_i,hbond_type) = histogram(num_hbond_sample_i,hbond_type) + exp(exp_arg)/(gaussian_sigma*sqrt(2.0_dp*PI)) !Gaussian in 1 dimension - endif - end do ! num_hbond_sample_i - else !no gaussian_smoothing - histogram(int(r/bin_width)+1,hbond_type) = histogram(int(r/bin_width)+1,hbond_type) + 1 - endif - end do ! i, atom_neighbours - - end do ! H1 - - deallocate(mask_a) - -end subroutine num_hbond_calc - -! -! Calculates the orientation of water molecules along the y axis -! -- 1st center around atom 1 -! -- then calculate COM of Si atoms -! -- then shift the centre of mass along the y axis to y=0 -! -- calculate the orientation of the {dipole moment} / {angle half line} of the water: if skip_atoms is set to the last atom of the silica -! -subroutine water_orientation_calc(histogram, at, axis, silica_center_i,n_pos_bins, n_angle_bins, gaussian_smoothing, pos_gaussian_sigma, pos_bin, angle_bin, angle_bin_w, use_dipole_rather_than_angle_bisector, accumulate) -!subroutine water_orientation_calc(histogram, at, axis, silica_center_i,n_pos_bins, n_angle_bins, gaussian_smoothing, pos_gaussian_sigma, angle_gaussian_sigma, pos_bin, angle_bin, angle_bin_w, use_dipole_rather_than_angle_bisector, accumulate) - real(dp), intent(inout) :: histogram(:,:) - type(Atoms), intent(inout) :: at - integer, intent(in) :: axis - integer, intent(in) :: silica_center_i - integer, intent(in) :: n_pos_bins, n_angle_bins - logical, intent(in) :: gaussian_smoothing - real(dp), intent(in) :: pos_gaussian_sigma !, angle_gaussian_sigma - real(dp), optional, intent(out) :: pos_bin(:), angle_bin(:) - real(dp), optional, intent(inout) :: angle_bin_w(:) - logical, optional, intent(in) :: use_dipole_rather_than_angle_bisector - logical, optional, intent(in) :: accumulate - - logical :: my_accumulate - real(dp) :: sample_r, sample_angle, r - ! logical, allocatable :: mask_a(:) - integer :: sample_i - real(dp) :: pos_bin_width, angle_bin_width - real(dp) :: sum_w -integer :: n, num_atoms -integer :: O, H1, H2 - real(dp) :: surface_normal(3) - logical :: use_dipole -real(dp) :: vector_OH1(3), vector_OH2(3) -real(dp) :: bisector_vector(3) -real(dp) :: dipole(3) -real(dp) :: orientation_angle - real(dp), parameter :: charge_O = -0.834_dp - real(dp), parameter :: charge_H = 0.417_dp -real(dp) :: sum_counts -real(dp) :: dist, exp_arg - - my_accumulate = optional_default(.false., accumulate) - if (.not. my_accumulate) histogram = 0.0_dp - - use_dipole = optional_default(.true.,use_dipole_rather_than_angle_bisector) - if (use_dipole) then - call print("Using dipole to calculate angle with the surface normal.",PRINT_VERBOSE) - else - call print("Using HOH angle bisector to calculate angle with the surface normal.",PRINT_VERBOSE) - endif - - !pos bin labels along axis - pos_bin_width = at%lattice(axis,axis) / real(n_pos_bins,dp) - if (present(pos_bin)) then - do sample_i=1, n_pos_bins - sample_r = (real(sample_i,dp)-0.5_dp)*pos_bin_width !the middle of the bin - pos_bin(sample_i) = sample_r - end do - endif - - !angle bin labels - angle_bin_width = PI/n_angle_bins - if (present(pos_bin)) then - sum_w = 0._dp - do sample_i=1, n_angle_bins - sample_angle = (real(sample_i,dp)-0.5_dp)*angle_bin_width !the middle of the bin - angle_bin(sample_i) = sample_angle - !the normalised solid angle is (1/4pi) * 2pi * sin((fi_north)-sin(fi_south)) where fi e [-pi/2,pi/2] - angle_bin_w(sample_i) = 0.5_dp * ( sin(0.5_dp*PI - real(sample_i-1,dp)*angle_bin_width) - & - sin(0.5_dp*PI - real(sample_i, dp)*angle_bin_width) ) - sum_w = sum_w + angle_bin_w(sample_i) - end do - angle_bin_w(1:n_angle_bins) = angle_bin_w(1:n_angle_bins) / sum_w - endif - - !shift silica slab to the edges, water in the middle || . . . || - if (silica_center_i>0) then ! silica - call shift_silica_to_edges(at, axis, silica_center_i) - endif - - !!calc_connect now, before shifting positions to positive, because it would remap the positions!! - !call calc_connect including the H-bonds - call set_cutoff(at,0._dp) - call calc_connect(at) - - !now bins are from -axis/2 to axis/2 - !shift everyone to positive coordinate along axis - at%pos(axis,1:at%N) = at%pos(axis,1:at%N) + 0.5_dp * at%lattice(axis,axis) - - !simply check water orientations and bin them - - -! if (gaussian_smoothing) call system_abort('not implemented.') - - surface_normal(1:3) = 0._dp - surface_normal(axis) = 1._dp - - num_atoms = 0 - do O=silica_center_i+1, at%N !only check water molecules - if(at%Z(O)==1) cycle !find O - !Count the atoms - call print('Found O'//O//ElementName(at%Z(O)),PRINT_ANALYSIS) - num_atoms = num_atoms + 1 - - !find H neighbours - n = n_neighbours(at,O) - if (n.ne.2) then ! O with =2 nearest neighbours - call print("WARNING! water(?) oxygen with "//n//"/=2 neighbours will be skipped!") - cycle - endif - H1 = neighbour(at,O,1) - H2 = neighbour(at,O,2) - if ((at%Z(H1).ne.1).or.(at%Z(H2).ne.1)) then !2 H neighbours - call print("WARNING! water(?) oxygen with non H neighbour will be skipped!") - cycle - endif - - !We've found a water molecule. - - !Build histogram - r = at%pos(axis,H1) !the position of O - !HOH_angle = angle(diff_min_image(at,O,H1), & - ! diff_min_image(at,O,H2)) !the H-O-H angle - - if (.not. use_dipole) then - !VERSION 1. - !the direction of the HH->O vector, the bisector of the HOH angle - !vector that is compared to the surface normal: - ! point from the bisector of the 2 Hs (scaled to have the same bond length) - ! to the O - vector_OH1(1:3) = diff_min_image(at, O, H1) - if (norm(vector_OH1) > 1.2_dp) & - call system_abort('too long OH bond? '//O//' '//H1//' '//norm(vector_OH1)) - vector_OH2(1:3) = diff_min_image(at, O, H2) - if (norm(vector_OH2) > 1.2_dp) & - call system_abort('too long OH bond? '//O//' '//H2//' '//norm(vector_OH1)) - bisector_vector(1:3) = vector_OH1(1:3) / norm(vector_OH1) * norm(vector_OH2) - - ! a.dot.b = |a|*|b|*cos(angle) - orientation_angle = dot_product((bisector_vector(1:3)),surface_normal(1:3)) / & - sqrt(dot_product(bisector_vector(1:3),bisector_vector(1:3))) / & - sqrt(dot_product(surface_normal(1:3),surface_normal(1:3))) - else ! use_dipole - - !VERSION 2. - !the dipole of the water molecule = sum(q_i*r_i) - !Calculate the dipole and its angle compared to the surface normal - - ! - dipole(1:3) = ( diff_min_image(at,O,H1)*charge_H + & - diff_min_image(at,O,H2)*charge_H ) - if (norm(diff_min_image(at,O,H1)).gt.1.2_dp) call system_abort('too long O-H1 bond (atoms '//O//'-'//H1//'): '//norm(diff_min_image(at,O,H1))) - if (norm(diff_min_image(at,O,H2)).gt.1.2_dp) call system_abort('too long O-H2 bond (atoms '//O//'-'//H2//'): '//norm(diff_min_image(at,O,H2))) -!call print ('dipole '//dipole(1:3)) - - ! a.dot.b = |a|*|b|*cos(angle) - orientation_angle = dot_product((dipole(1:3)),surface_normal(1:3)) / & - sqrt(dot_product(dipole(1:3),dipole(1:3))) / & - sqrt(dot_product(surface_normal(1:3),surface_normal(1:3))) - endif - - if (orientation_angle.gt.1._dp) then - call print('WARNING | correcting cos(angle) to 1.0 = '//orientation_angle) - orientation_angle = 1._dp - else if (orientation_angle.lt.-1._dp) then - call print('WARNING | correcting cos(angle) to -1.0 = '//orientation_angle) - orientation_angle = -1._dp - endif - orientation_angle = acos(orientation_angle) - if (orientation_angle.lt.0._dp) then - call print('WARNING | correcting angle to 0.0: '//orientation_angle) - orientation_angle = 0._dp - endif - if (orientation_angle.gt.PI) then - call print('WARNING | correcting angle to pi : '//orientation_angle) - orientation_angle = PI - endif -!call print ('angle '//(orientation_angle*180._dp/pi)) - - call print('Storing angle for water '//O//'--'//H1//'--'//H2//' with reference = '//round(orientation_angle,5)//'degrees',PRINT_ANALYSIS) - call print(' with distance -1/2 b -- '//O//' = '//round(r,5)//'A',PRINT_ANALYSIS) - - if (gaussian_smoothing) then !smear the position along axis - !call system_abort('not implemented.') - do sample_i=1, n_pos_bins - sample_r = (real(sample_i,dp)-0.5_dp)*pos_bin_width - dist = abs(r - sample_r) - !Include all the atoms, slow but minimises error - !if (dist > 4.0_dp*gaussian_sigma) cycle - exp_arg = -0.5_dp*(dist/(pos_gaussian_sigma))**2 - if (exp_arg > -20.0_dp) then ! good to about 1e-8 - histogram(int(orientation_angle/angle_bin_width)+1,sample_i) = histogram(int(orientation_angle/angle_bin_width)+1,sample_i) + exp(exp_arg)/(pos_gaussian_sigma*sqrt(2.0_dp*PI)) !Gaussian in 1 dimension - endif - end do ! sample_i - - else !no gaussian_smoothing - histogram(int(orientation_angle/angle_bin_width)+1,int(r/pos_bin_width)+1) = histogram(int(orientation_angle/angle_bin_width)+1,int(r/pos_bin_width)+1) + 1._dp - endif - - end do ! O - - !normalise for the number of molecules in each pos_bin - do sample_i=1,n_pos_bins - sum_counts = sum(histogram(1:n_angle_bins,sample_i)) - if (sum_counts /= 0) histogram(1:n_angle_bins,sample_i) = histogram(1:n_angle_bins,sample_i) / sum_counts - enddo - - !normalise for different solid angles of each angle_bin - do sample_i=1, n_angle_bins - histogram(sample_i,1:n_pos_bins) = histogram(sample_i,1:n_pos_bins) / angle_bin_w(sample_i) - enddo - -end subroutine water_orientation_calc - -end module structure_analysis_routines_module diff --git a/src/Utils/transition_state.f95 b/src/Utils/transition_state.f95 deleted file mode 100644 index 8bedd9c5bb..0000000000 --- a/src/Utils/transition_state.f95 +++ /dev/null @@ -1,802 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module ts_module - -use libatoms_module -use Potential_module -use tsParams_module - -implicit none - -type images - type(atoms) :: at - logical :: mobile - real(dp) :: energy - real(dp) :: frac -end type images - -type chain_of_states - integer :: N !% Number of images belonging to the elastic band - type(Images), allocatable, dimension(:) :: image !% images -end type chain_of_states - -type TS - type (chain_of_states) :: cos - logical :: lneb - logical :: lsm - type (tsparams) :: params -end type TS - -interface initialise - module procedure TS_Initialise_interp, TS_Initialise_nointerp -end interface initialise - -interface Finalise - module procedure TS_Finalise -end interface Finalise - -interface Calc - module procedure TS_Calc -end interface Calc - -interface Print - module procedure TS_print -end interface Print - -interface write - module procedure TS_write -end interface - -interface fix - module procedure TS_fix -end interface fix - -contains - -!-------------------------------------------------------------------------- -subroutine TS_Initialise(this,params) - type(TS), intent(inout) :: this - type(tsParams), intent(in) :: params - - select case(params%simulation_method) - - case("neb") - this%lneb = .true. - case("sm") - this%lsm = .true. - case("default") - stop "Warning:: I do not recognise the method!" - end select - -end subroutine TS_Initialise - -!-------------------------------------------------------------------------- -subroutine TS_Initialise_interp(this,at_in,at_fin,N,params) - type(TS), intent(inout) :: this - type(Atoms), intent(inout) :: at_in - type(Atoms), intent(inout) :: at_fin - integer,optional :: N - type(tsParams),optional :: params - integer :: im - logical, allocatable :: lmobile(:) - - call finalise(this) - - if(present(params)) then - this%params = params - else - call Initialise(this%params) - end if - - select case(this%params%simulation_method) - case("neb") - this%lneb = .true. - case("sm") - this%lsm = .true. - case("default") - stop "Warning:: I do not recognise the method!" - end select - - - if(present(N)) this%cos%N = N - - allocate(this%cos%image(this%cos%N)) - this%cos%image(1:this%cos%N)%mobile = .true. - - call initialise(this%cos%image(1)%at,at_in%N,at_in%lattice) - call initialise(this%cos%image(this%cos%N)%at,at_fin%N,at_fin%lattice) - - this%cos%image(1)%at = at_in - this%cos%image(this%cos%N)%at = at_fin - - do im = 2, this%cos%N-1 - call initialise(this%cos%image(im)%at,at_in%N,at_in%lattice) - this%cos%image(im)%at = at_in - enddo - - if(this%cos%image(1)%at%N.ne. this%cos%image(this%cos%N)%at%N) then - call system_abort('TS: Initialise: # of Atoms in first and last images are different') - endif -!' - - call Interpolate_images(this) - - allocate(lmobile(this%cos%N)) - lmobile = .true. - lmobile(1) = this%params%chain_mobile_first - lmobile(this%cos%N) = this%params%chain_mobile_last - call fix(this,lmobile) - deallocate(lmobile) - - call TS_initilise_fractionate_chain(this) - -end subroutine TS_Initialise_interp -!----------------------------------------------------------------------------- -subroutine TS_Initialise_nointerp(this,at_ref,conf,params) - type(TS), intent(inout) :: this - type(Atoms), intent(in) :: at_ref - real(dp), dimension(this%cos%N,3*at_ref%N) :: conf - type(tsParams),optional :: params - integer :: im - logical, allocatable :: lmobile(:) - - call finalise(this) - - - if(present(params)) then - this%params = params - else - call Initialise(this%params) - end if - - select case(this%params%simulation_method) - case("neb") - this%lneb = .true. - case("sm") - this%lsm = .true. - case("default") - stop "Warning:: I do not recognise the method!" - end select - - allocate(this%cos%image(this%cos%N)) - this%cos%image(:)%mobile = .true. - - do im = 1, this%cos%N - call initialise(this%cos%image(im)%at,at_ref%N,at_ref%lattice) - this%cos%image(im)%at = at_ref - this%cos%image(im)%at%pos = reshape(conf(im,:), (/3, at_ref%N/)) - this%cos%image(im)%at%Z(:) = at_ref%Z(:) - this%cos%image(im)%at%cutoff = at_ref%cutoff - if(associated(at_ref%move_mask)) & - this%cos%image(im)%at%move_mask = at_ref%move_mask - enddo - - allocate(lmobile(this%cos%N)) - lmobile = .true. - lmobile(1) = this%params%chain_mobile_first - lmobile(this%cos%N) = this%params%chain_mobile_last - call fix(this,lmobile) - deallocate(lmobile) - - call TS_initilise_fractionate_chain(this) - -end subroutine TS_Initialise_nointerp -!----------------------------------------------------------------------------- -subroutine TS_initilise_fractionate_chain(this) - type(TS), intent(inout) :: this - real(dp) :: dx - integer :: i - - dx = 1.d0 / dble(this%cos%N - 1._dp) - do i = 1, this%cos%N - this%cos%image(i)%frac = dble(i - 1._dp) * dx - enddo - -end subroutine TS_initilise_fractionate_chain -!----------------------------------------------------------------------------- -subroutine Interpolate_images(this) - type(TS), intent(inout) :: this - real(dp), allocatable, dimension(:,:) :: increm - integer :: im,i - real(dp), dimension(3) :: pos_in, pos_fin - - if(allocated(increm)) deallocate(increm) - allocate(increm(3,this%cos%image(1)%at%N) ) - - do i = 1, this%cos%image(1)%at%N - pos_in = this%cos%image(1)%at%pos(:,i) - pos_fin = this%cos%image(this%cos%N)%at%pos(:,i) - increm(:,i) = diff_min_image(this%cos%image(1)%at,pos_in,pos_fin) - enddo - increm = increm / real(this%cos%N-1,dp) - - do im = 2, this%cos%N -1 - this%cos%image(im)%at%pos(:,:) = this%cos%image(1)%at%pos(:,:) + real(im-1) * increm(:,:) - this%cos%image(im)%at%Z(:) = this%cos%image(1)%at%Z(:) - this%cos%image(im)%at%cutoff = this%cos%image(1)%at%cutoff - if(associated(this%cos%image(1)%at%move_mask)) & - this%cos%image(im)%at%move_mask = this%cos%image(1)%at%move_mask - enddo - -end subroutine Interpolate_images -!----------------------------------------------------------------------------- -subroutine TS_Finalise(this) - type(TS), intent(inout) :: this - integer :: im - - if(allocated(this%cos%image)) then - do im = 1, size(this%cos%image(:)) - call finalise(this%cos%image(im)%at) - enddo - deallocate(this%cos%image) - end if - - this%lneb = .false. - this%lsm = .false. - -end subroutine TS_Finalise - -!------------------------------------------------------------------------------ -subroutine TS_Calc(this,pot,niterout,params,xyzlogfile) - type(TS), intent(inout) :: this - type(Potential), intent(inout) :: pot - type(tsParams),optional :: params - type(CInoutput), intent(inout), optional :: xyzlogfile - integer, optional, intent(out) :: niterout - - - real(dp), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: forces, forces_old, oldpos - real(dp), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: tau - real(dp), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: forces_pot, forces_spring - real(dp), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: forces2 - real(dp), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: forces_4c - real(dp), dimension(this%cos%N) :: energy, gfac, error - real(dp) :: fnorma, gmaxstepfact, rmaxstep, energy_save - logical :: lcheck(this%cos%N), do_fixed_step - integer :: i, iat, is, niter - real(dp) :: energy_temp - type(tsParams) :: myparams - - - if(present(params)) then - myparams = params - else - myparams = this%params - end if - - rmaxstep = 0.1_dp - gfac = myparams%minim_gfac - forces_pot = 0.0_dp - do i = 1, this%cos%N - call calc_connect(this%cos%image(i)%at) - energy_temp = 0.0_dp - if(.not.myparams%simulation_hybrid) then - call calc(pot,this%cos%image(i)%at,energy=this%cos%image(i)%energy,force=forces_pot(i,:,:),args_str=myparams%classical_args_str) - call integrate_forces(this, i, forces_pot, energy_temp) - call print('Check energy and force integral '// i // " " // this%cos%image(i)%energy // " " // energy_temp) - else - call calc(pot,this%cos%image(i)%at,force=forces_pot(i,:,:)) - call integrate_forces(this, i, forces_pot, this%cos%image(i)%energy) - call print('Force integral '// i // " " // this%cos%image(i)%energy) - endif - - energy(i) = this%cos%image(i)%energy - - enddo - - ! print starting config - if(present(xyzlogfile)) call write(this,xyzlogfile) - - lcheck = .false. - - do_fixed_step = .true. - - steepest_loop : DO niter = 1, myparams%minim_max_steps - tau = 0._dp - call calc_tangent(this,myparams%simulation_newtangent,energy,tau) - forces_old = forces - call calc_force_perp(this, forces_pot, tau, forces) - call print('TS: ================ Tangent force^2 ==============') - do i = 1, this%cos%N - call print('TS: image ' // i // ' tangent force^2 ' // (sqrt(sum(forces(i,:,:)*forces(i,:,:) )) ), PRINT_NORMAL ) - enddo - - if(this%lneb) then - call calc_spring(this, tau, forces_spring, myparams%simulation_spring_constant) - if(niter.gt.myparams%simulation_climbing_steps.and.myparams%simulation_climbing) then - is = isaddle(this) - do i = 1, this%cos%N - if(i.eq.is) then - call calc_force_4c(this,is,forces_pot,tau,forces_4c) - forces(i,:,:) = forces_4c(i,:,:) - else - forces(i,:,:) = forces(i,:,:) + forces_spring(i,:,:) - endif - enddo - else - forces = forces + forces_spring - endif - - do i=1, this%cos%N - call print('TS: NEB: image ' // i // ' parallel spring ' // (sqrt(sum(forces_spring(i,:,:)*forces_spring(i,:,:) )) ), PRINT_NORMAL) - enddo - - endif - - forces2 = forces * forces - - ! loop over images - do i = 1, this%cos%N - - if(.not.this%cos%image(i)%mobile) then - cycle - endif - fnorma = 0.0_dp - do iat = 1, this%cos%image(i)%at%N - fnorma = fnorma + sum(forces2(i,:,iat)) - enddo - fnorma = dsqrt(fnorma) - gmaxstepfact = 1.0_dp - if (gfac(i) * fnorma > rmaxstep) then - gmaxstepfact = 1.d0/fnorma/gfac(i) * rmaxstep - end if - - energy_save = energy(i) - if(.not.this%cos%image(i)%mobile) cycle - - if(niter == 1 .or. do_fixed_step .or. maxval(abs(forces(i,:,:))) > 0.5_dp) then - gfac(i) = 0.01_dp - else - gfac(i) = -((this%cos%image(i)%at%pos-oldpos(i,:,:)) .dot. (this%cos%image(i)%at%pos-oldpos(i,:,:)))/((this%cos%image(i)%at%pos-oldpos(i,:,:)) .dot. (forces(i,:,:)-forces_old(i,:,:))) - end if - oldpos(i,:,:) = this%cos%image(i)%at%pos(:,:) - - do iat = 1, this%cos%image(i)%at%N - if(associated(this%cos%image(i)%at%move_mask)) then - if(this%cos%image(i)%at%move_mask(iat).eq.0) cycle - end if - !this%cos%image(i)%at%pos(:,iat) = this%cos%image(i)%at%pos(:,iat) + gfac(i) * forces(i,:,iat) * gmaxstepfact - this%cos%image(i)%at%pos(:,iat) = this%cos%image(i)%at%pos(:,iat) + gfac(i) * forces(i,:,iat) - - enddo - - call calc_connect(this%cos%image(i)%at) - - if(.not.myparams%simulation_hybrid) then - call calc(pot,this%cos%image(i)%at,energy=this%cos%image(i)%energy,force=forces_pot(i,:,:),args_str=myparams%classical_args_str) - else - call calc(pot,this%cos%image(i)%at,force=forces_pot(i,:,:)) - call integrate_forces(this, i, forces_pot, this%cos%image(i)%energy) - endif - - energy(i) = this%cos%image(i)%energy - if(niter.gt.1) call check(this, energy_save, energy(i), myparams%minim_energy_tol, myparams%minim_force_tol, fnorma, error(i), lcheck(i)) - - enddo ! end loop over images - - if(mod(niter,myparams%io_print_interval).eq.0) then - call print ("TS: ================ Path energy ===================") - do i = 1, this%cos%N - call print ("TS: image="// i // " Energy="// this%cos%image(i)%energy // " deltaE=" // (this%cos%image(i)%energy-this%cos%image(1)%energy) ) - end do - end if - - if(all(lcheck(:))) then - call print ('TS: convergence reached at step ' // niter) - exit - endif - - if(this%lsm.and. mod(niter,myparams%simulation_freq_rep).eq.0) then - call calc_reparameterisation(this) - do_fixed_step = .true. - else - do_fixed_step = .false. - endif - - if(mod(niter,myparams%io_print_interval).eq.0) then - if(present(xyzlogfile)) call write(this, xyzlogfile) - is = isaddle(this) - call print("TS: iter " // niter // "; Saddle index = " // is ) - endif -!" - end do steepest_loop - niter = niter - 1 - - if(present(niterout)) niterout = niter - -end subroutine TS_Calc - -!---------------------------------------------------------------------------- -subroutine calc_tangent(this,lnewtangent,energy, tau) -!---------------------------------------------------------------------------- -! Tangent computed according to G. Henkelman, H Jonsson, JCP 113, 9978 (2000) -! Notice: on the first and last image tau = 0. -! It should be = tauP (tauM) but it is necessary to handle when E_0 > E_i -! and E_N > E_N-1 -!---------------------------------------------------------------------------- - type(TS), intent(in) :: this - logical, intent(in) :: lnewtangent - real(dp), intent(inout), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: tau - real(dp), intent(in), dimension(this%cos%N) :: energy - real(dp), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: tauP, tauM - real(dp), dimension(3) :: pos_1, pos_2 - integer :: im, iat - real(dp) :: E1, E2, Emin, Emax - real(dp) :: taunorm - - tau = 0._dp - if(lnewtangent) then - do im = 1, this%cos%N - do iat = 1, this%cos%image(1)%at%N - if(im.ne.this%cos%N) then - pos_1 = this%cos%image(im+1)%at%pos(:,iat) - pos_2 = this%cos%image(im)%at%pos(:,iat) - tauP(im,:,iat) = diff_min_image(this%cos%image(1)%at,pos_2,pos_1) - endif - if(im.ne.1) then - pos_1 = this%cos%image(im)%at%pos(:,iat) - pos_2 = this%cos%image(im-1)%at%pos(:,iat) - tauM(im,:,iat) = diff_min_image(this%cos%image(1)%at,pos_2,pos_1) - endif - enddo - enddo - do im = 2, this%cos%N-1 - if(energy(im+1).gt.energy(im).and.energy(im).gt.energy(im-1)) then - tau(im,1:3,:) = tauP(im,1:3,:) - elseif(energy(im+1).lt.energy(im).and.energy(im).lt.energy(im-1)) then - tau(im,1:3,:) = tauM(im,1:3,:) - else - E1 = abs(energy(im+1) - energy(im)) - E2 = abs(energy(im-1) - energy(im)) - if(E1.gt.E2) then - Emax = E1 - Emin = E2 - else - Emin = E1 - Emax = E2 - endif - if(energy(im+1).gt.energy(im-1)) then - tau(im,1:3,:) = tauP(im,1:3,:) * Emax + tauM(im,1:3,:) * Emin - elseif(energy(im+1).lt.energy(im-1)) then - tau(im,1:3,:) = tauP(im,1:3,:) * Emin + tauM(im,1:3,:) * Emax - endif - endif - do iat = 1, this%cos%image(1)%at%N - taunorm = sqrt(sum(tau(im,:,iat) * tau(im,:,iat) ) ) - if(taunorm.gt.0.00001_dp) tau(im,:,iat) = tau(im,:,iat) / taunorm - if(associated(this%cos%image(1)%at%move_mask)) then - if(this%cos%image(1)%at%move_mask(iat).eq.0) tau(im,:,iat) = 0._dp - end if - enddo - enddo - else - do im = 1, this%cos%N - do iat = 1, this%cos%image(1)%at%N - if(im.ne.this%cos%N) then - pos_1 = this%cos%image(im+1)%at%pos(:,iat) - pos_2 = this%cos%image(im)%at%pos(:,iat) - tauP(im,:,iat) = diff_min_image(this%cos%image(1)%at,pos_2,pos_1) - endif - if(im.ne.1) then - pos_1 = this%cos%image(im)%at%pos(:,iat) - pos_2 = this%cos%image(im-1)%at%pos(:,iat) - tauM(im,:,iat) = diff_min_image(this%cos%image(1)%at,pos_2,pos_1) - endif - tau(im,:,iat) = 0.0_dp - if(abs(sum(tauP(im,:,iat))).gt.1.0d-10) & - tau(im,:,iat) = tau(im,:,iat) + tauP(im,:,iat)/sqrt(sum(tauP(im,:,iat)*tauP(im,:,iat)) ) - - if(abs(sum(tauM(im,:,iat))).gt.1.0d-10) & - tau(im,:,iat) = tau(im,:,iat) + tauM(im,:,iat)/sqrt(sum(tauM(im,:,iat)*tauM(im,:,iat)) ) - taunorm = sqrt(sum(tau(im,:,iat) * tau(im,:,iat) ) ) - if(taunorm.gt.0.00001_dp) tau(im,:,iat) = tau(im,:,iat) / taunorm - if(associated(this%cos%image(1)%at%move_mask)) then - if(this%cos%image(1)%at%move_mask(iat).eq.0) tau(im,:,iat) = 0._dp - end if - enddo - enddo - endif - -end subroutine calc_tangent - -!-------------------------------------------------------------------- -!% Compute the force perpendicular to the path for each image -subroutine calc_force_perp(this, forces, tau, forces_perp) - type(TS), intent(in) :: this - real(dp), intent(in), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: tau - real(dp), intent(inout), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: forces, forces_perp - integer :: im, iat - real(dp) :: ftemp - - do im = 1, this%cos%N - do iat = 1, this%cos%image(1)%at%N - ftemp = sum(forces(im,:,iat) * tau(im,:,iat)) - forces_perp(im,:,iat) = forces(im,:,iat) - ftemp * tau(im,:,iat) - enddo - enddo - -end subroutine calc_force_perp -!-------------------------------------------------------------------- -!% Compute the effective force changing the sign of the parallel component -!% Used for the climbing image method -subroutine calc_force_4c(this, im, forces, tau, forces_4c) - type(TS), intent(in) :: this - real(dp), intent(in), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: tau - real(dp), intent(inout), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: forces, forces_4c - integer :: im, iat - real(dp) :: ftemp - - forces_4c = 0._dp - do iat = 1, this%cos%image(1)%at%N - ftemp = sum(forces(im,:,iat) * tau(im,:,iat)) - forces_4c(im,:,iat) = forces(im,:,iat) - 2._dp * ftemp * tau(im,:,iat) - enddo - -end subroutine calc_force_4c -!-------------------------------------------------------------------- -!% Compute the force due to the spring for each image -subroutine calc_spring(this, tau, forces, spring_constant) - type(TS), intent(in) :: this - real(dp), intent(in), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: tau - real(dp), intent(inout), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: forces - real(dp), dimension(3) :: pos_im,pos_imP, pos_imM, diff_p, diff_m - integer :: im, iat - real(dp) :: ftemp, spring_constant - - forces = 0._dp - do im = 2, this%cos%N-1 - do iat = 1, this%cos%image(1)%at%N - pos_imP = this%cos%image(im+1)%at%pos(:,iat) - pos_im = this%cos%image(im)%at%pos(:,iat) - pos_imM = this%cos%image(im-1)%at%pos(:,iat) - diff_p = diff_min_image(this%cos%image(1)%at,pos_im,pos_imP) - diff_m = diff_min_image(this%cos%image(1)%at,pos_imM,pos_im) - ftemp = sqrt(sum(diff_p(:)*diff_p(:))) - sqrt(sum(diff_m(:)*diff_m(:))) - forces(im,:,iat) = spring_constant * ftemp * tau(im,:,iat) - enddo - enddo - -end subroutine calc_spring -!-------------------------------------------------------------------- -subroutine calc_reparameterisation(this) - type(TS), intent(inout) :: this - real(dp), dimension(this%cos%N,3,this%cos%image(1)%at%N) :: dis, pos_temp_im - real(dp), dimension(this%cos%N,this%cos%image(1)%at%N) :: ldist - real(dp), dimension(3) :: pos_im, pos_imM - real(dp) :: psum - integer :: nim, nat, i, iat - - nim = this%cos%N - nat = this%cos%image(1)%at%N - dis = 0._dp - do i=2, nim - do iat = 1, nat -! pos_im = realpos(this%cos%image(i)%at,iat) -! pos_imM = realpos(this%cos%image(i-1)%at,iat) -! dis(i,:,iat) = pos_im - pos_imM - - pos_im = this%cos%image(i)%at%pos(:,iat) - pos_imM = this%cos%image(i-1)%at%pos(:,iat) - dis(i,:,iat) = diff_min_image(this%cos%image(1)%at,pos_imM,pos_im) - enddo - enddo - - psum =0._dp - ldist = 0._dp - do iat = 1, nat - psum = 0_dp - do i = 1, nim - psum = psum + sqrt(sum (dis(i,:,iat) * dis(i,:,iat) ) ) - ldist(i,iat) = psum - pos_temp_im(i,:,iat) = realpos(this%cos%image(i)%at,iat) - enddo - ldist(:,iat) = ldist(:,iat)/ldist(nim,iat) - enddo - - do i = 1, nim - do iat = 1, nat - !if(associated(this%cos%image(i)%at%move_mask)) then - ! if(this%cos%image(i)%at%move_mask(iat).eq.0) cycle - !end if - pos_im(1) = interp1(nim,ldist(:,iat),pos_temp_im(:,1,iat),this%cos%image(i)%frac) - pos_im(2) = interp1(nim,ldist(:,iat),pos_temp_im(:,2,iat),this%cos%image(i)%frac) - pos_im(3) = interp1(nim,ldist(:,iat),pos_temp_im(:,3,iat),this%cos%image(i)%frac) - this%cos%image(i)%at%pos(:,iat) = pos_im(:) - (this%cos%image(i)%at%lattice .mult. this%cos%image(i)%at%travel(:,iat)) - enddo - enddo - -end subroutine calc_reparameterisation -!--------------------------------------------------------------------- -function interp1(n,xa,ya,x) -integer :: n -real(dp) :: xa(n), ya(n) -real(dp) :: x -real(dp) :: a, b -integer :: k, klo, khi -real(dp) :: interp1 - -klo=1 -khi=n -1 if (khi-klo.gt.1) then - k=(khi+klo)/2 - if(xa(k).gt.x)then - khi=k - else - klo=k - endif - goto 1 -endif - -if(abs(xa(klo)-xa(khi)).lt.0.0000001_dp) then - interp1 = (ya(klo) - ya(khi))/2._dp -else - b = (ya(klo) - ya(khi))/(xa(klo) - xa(khi)) - a = ya(klo) - b * xa(klo) - interp1 = a + b * x -endif - -return -end function interp1 - - -!-------------------------------------------------------------------- -subroutine check(this, e_old, e_new, toll, force_tol, fnorma, error, lcheck) - type(TS) :: this - real(dp) :: e_old, e_new - real(dp) :: fnorma, toll - real(dp) :: force_tol, error - logical :: lcheck, lcheck_ene, lcheck_force - - lcheck = .false. - lcheck_ene = .false. - lcheck_force = .false. - - if((e_old-e_new).lt.toll) then - lcheck_ene = .true. - error = e_old-e_new - else - error = e_old-e_new - endif - if(fnorma/real(this%cos%image(1)%at%N,dp) .lt. force_tol) lcheck_force = .true. - if(lcheck_ene.and.lcheck_force) lcheck = .true. - -end subroutine check -!-------------------------------------------------------------------- -subroutine check_forces(this, force_tol, fnorma, error, lcheck) - type(TS) :: this - real(dp) :: fnorma - real(dp) :: force_tol, error - logical :: lcheck - - lcheck = .false. - if(fnorma/real(this%cos%image(1)%at%N,dp) .lt. force_tol) lcheck = .true. - -end subroutine check_forces -!------------------------------------------------------------------ -subroutine integrate_forces (this, final_image, forces_pot, ene) - type(TS) :: this - integer :: final_image - real(dp) :: forces_pot(this%cos%N,3,this%cos%image(1)%at%N) - real(dp) :: ene, f_dr - real(dp), allocatable, dimension(:,:) :: dr - integer :: im - - - allocate(dr(3,this%cos%image(1)%at%N)) - - ene = 0.0_dp - do im = 2, final_image - dr = this%cos%image(im)%at%pos - this%cos%image(im-1)%at%pos - f_dr = - forces_pot(im,:,:) .dot. dr - - if (im == this%cos%N) then - ene = ene + f_dr/3.0_dp - else if (mod(im,2) == 0) then - ene = ene + 2.0_dp/3.0_dp*f_dr - else - ene = ene + 4.0_dp/3.0_dp*f_dr - end if - enddo - -end subroutine integrate_forces -!------------------------------------------------------------------ -subroutine TS_fix(this,lfix) - type(TS) :: this - logical :: lfix(this%cos%N) - - this%cos%image(:)%mobile = lfix(:) - -end subroutine TS_fix -!------------------------------------------------------------------ - -subroutine TS_write(this, file) - type(TS) :: this - type(CInOutput) :: file - integer :: im - - do im =1, this%cos%N - call write(this%cos%image(im)%at, file) - enddo - -end subroutine TS_write - - -!----------------------------------------------------------------- -subroutine TS_print(this) - type(TS) :: this - - call print( ' ') - call Print_title('Parameters') - call Print('Chain of state with ' // this%cos%N // ' images') - !' - if(this%cos%image(1)%mobile) then - call print ('First image: mobile') - else - call print ('First image: frozen') - endif - if(this%cos%image(this%cos%N)%mobile) then - call print ('Last image : mobile') - else - call print ('Last image : frozen') - endif - - call print( ' ') - if(this%lneb) then - call print ('Transition state compute with NEB') - call print ('Climbing image ' // this%params%simulation_climbing) - call print ('Spring Constant ' // this%params%simulation_spring_constant) - call print ('Climbing Image method ' // this%params%simulation_climbing) - else - call print ('Transition state compute with String method') - call print ('Reparameterisation performed every ' // this%params%simulation_freq_rep // ' steps') - endif - call print ('Tangent computed with the newtangent method ' // this%params%simulation_newtangent) - -end subroutine TS_print - -!------------------------------------------------------------------ -function isaddle(this) - type(TS) :: this - real(dp) :: Emax - integer :: i - integer :: isaddle - - Emax = -1.d13 - do i = 1, this%cos%N - if(this%cos%image(i)%energy.gt.Emax) then - isaddle = i - Emax = this%cos%image(i)%energy - endif - enddo - if(isaddle.gt. this%cos%N) call system_abort('TS: saddle point not found!') -end function - -end module ts_module diff --git a/src/Utils/ts_params.f95 b/src/Utils/ts_params.f95 deleted file mode 100644 index d60389793b..0000000000 --- a/src/Utils/ts_params.f95 +++ /dev/null @@ -1,400 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -module tsparams_module - -use libAtoms_module -use QUIP_Common_module -use potential_module -use system_module, only : verbosity_of_str - -implicit none - -private - -public :: tsparams - -type tsparams - - character(STRING_LENGTH) :: classical_args !% Arguments used to initialise classical potential - character(STRING_LENGTH) :: classical_args_str !% Arguments used by Calc Potential - real(dp) :: classical_force_reweight = 1.0_dp ! Fraction - - character(STRING_LENGTH) :: qm_args !% Arguments used to initialise QM potential - character(STRING_LENGTH) :: qm_args_str !% Arguments used by QM potential - - logical :: minim_end - character(STRING_LENGTH) :: minim_end_method !% Minimisation method: use 'cg' for conjugate gradients or 'sd' for steepest descent. - !% See 'minim()' in 'libAtoms/minimisation.f95' for details. - real(dp) :: minim_end_tol !% Target force tolerance - geometry optimisation is considered to be - !% converged when $|\mathbf{f}|^2 <$ 'tol' - real(dp) :: minim_end_eps_guess !% Initial guess for line search step size $\epsilon$. - integer :: minim_end_max_steps !% Maximum number of minimisation steps. - character(STRING_LENGTH) :: minim_end_linminroutine !% Linmin routine, e.g. 'FAST_LINMIN' for classical potentials with total energy, or - !% 'LINMIN_DERIV' when doing a LOTF hybrid simulation and only forces are available. - - real(dp) :: minim_gfac - real(dp) :: minim_force_tol - real(dp) :: minim_energy_tol - integer :: minim_max_steps - - integer :: io_verbosity !% Output verbosity. In XML file, this should be specified as one of - integer :: io_print_interval - - logical :: simulation_hybrid - logical :: simulation_restart - character(STRING_LENGTH) :: simulation_method - logical :: simulation_climbing - logical :: simulation_newtangent - integer :: simulation_climbing_steps - integer :: simulation_freq_rep !% Frequency of reparametrization for string method - real(dp) :: simulation_spring_constant - - integer :: chain_nfix - integer :: chain_nimages - logical :: chain_mobile_last - logical :: chain_mobile_first - character(STRING_LENGTH) :: chain_first_conf - character(STRING_LENGTH) :: chain_last_conf - -end type tsparams - -type(tsparams), pointer :: parse_ts -logical :: parse_in_ts - -public :: initialise -interface initialise - module procedure tsparams_Initialise -end interface - -public :: finalise -interface finalise - module procedure tsParams_finalise -end interface finalise - -public :: print -interface print - module procedure tsparams_print -end interface - -public :: read_xml -interface read_xml - module procedure tsparams_read_xml -end interface - - -contains - -subroutine tsparams_Initialise(this) - type(tsparams), intent(inout) :: this - - this%classical_args = 'IP SW' - this%classical_args_str = ' ' - this%classical_force_reweight = 1.0_dp ! Fraction - - ! QM parameters - this%qm_args = 'FilePot command=./castep_driver.py property_list=pos:embed' - this%qm_args_str = ' ' - - this%minim_end = .false. - this%minim_end_method = 'cg' - this%minim_end_tol = 1e-6_dp ! normsq(force) eV/A - this%minim_end_eps_guess = 0.01_dp ! Angstrom - this%minim_end_max_steps = 1000 ! number - - this%io_verbosity = PRINT_NORMAL - this%io_print_interval = 10 - - this%simulation_hybrid = .false. - this%simulation_restart = .false. - this%simulation_method = 'sm' - this%simulation_spring_constant = 0.1 - this%simulation_newtangent = .true. - this%simulation_climbing = .false. - this%simulation_climbing_steps = 10 - this%simulation_freq_rep = 1 - - this%minim_gfac = 0.01 - this%minim_force_tol = 0.001_dp - this%minim_energy_tol = 0.01_dp - this%minim_max_steps = 1000 - - this%chain_first_conf = 'first.xyz' - this%chain_last_conf = 'last.xyz' - this%chain_nfix = 0 - this%chain_nimages = 10 - this%chain_mobile_last = .false. - this%chain_mobile_first = .false. -end subroutine tsparams_Initialise - -subroutine tsParams_finalise(this) - type(tsParams), intent(inout) :: this - - ! do nothing - -end subroutine tsParams_finalise - -subroutine tsParams_read_xml(this, xmlfile) - type(tsParams), intent(inout), target :: this - type(Inoutput) :: xmlfile - - type (xml_t) :: fxml - type(extendable_str) :: ss - - call initialise(this) - - call Initialise(ss) - call read(ss, xmlfile%unit, convert_to_string=.true.) - - if (len(trim(string(ss))) <= 0) return - - call open_xml_string(fxml, string(ss)) - - parse_ts => this - parse_in_ts = .false. - - call parse(fxml, & - startElement_handler = tsparams_startElement_handler, & - endElement_handler = tsparams_endElement_handler) - - call close_xml_t(fxml) - - call Finalise(ss) - -end subroutine tsparams_read_xml - -subroutine tsparams_startElement_handler(URI, localname, name, attributes) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - type(dictionary_t), intent(in) :: attributes - - integer status - character(len=1024) :: value - - if (name == 'ts_params') then ! new crack_params stanza - - parse_in_ts = .true. - - elseif (parse_in_ts .and. name == 'chain') then - call QUIP_FoX_get_value(attributes, "first_conf", value, status) - if (status == 0) then - parse_ts%chain_first_conf = value - end if - - call QUIP_FoX_get_value(attributes, "last_conf", value, status) - if (status == 0) then - parse_ts%chain_last_conf = value - end if - - call QUIP_FoX_get_value(attributes, "nfix", value, status) - if (status == 0) then - read (value, *) parse_ts%chain_nfix - end if - - call QUIP_FoX_get_value(attributes, "nimages", value, status) - if (status == 0) then - read (value, *) parse_ts%chain_nimages - end if - - call QUIP_FoX_get_value(attributes, "mobile_last", value, status) - if (status == 0) then - read (value, *) parse_ts%chain_mobile_last - end if - - call QUIP_FoX_get_value(attributes, "mobile_first", value, status) - if (status == 0) then - read (value, *) parse_ts%chain_mobile_first - end if - - elseif (parse_in_ts .and. name == 'simulation') then - - call QUIP_FoX_get_value(attributes, "hybrid", value, status) - if (status == 0) then - read (value, *) parse_ts%simulation_hybrid - end if - - call QUIP_FoX_get_value(attributes, "restart", value, status) - if (status == 0) then - read (value,*) parse_ts%simulation_restart - end if - - call QUIP_FoX_get_value(attributes, "method", value, status) - if (status == 0) then - parse_ts%simulation_method = value - end if - - call QUIP_FoX_get_value(attributes, "newtangent", value, status) - if (status == 0) then - read(value,*) parse_ts%simulation_newtangent - end if - - call QUIP_FoX_get_value(attributes, "climbing", value, status) - if (status == 0) then - read(value,*) parse_ts%simulation_climbing - end if - - call QUIP_FoX_get_value(attributes, "climbing_steps", value, status) - if (status == 0) then - read(value,*) parse_ts%simulation_climbing_steps - end if - - call QUIP_FoX_get_value(attributes, "freq_rep", value, status) - if (status == 0) then - read (value, *) parse_ts%simulation_freq_rep - end if - - call QUIP_FoX_get_value(attributes, "spring_constant", value, status) - if (status == 0) then - read (value, *) parse_ts%simulation_spring_constant - end if - - elseif (parse_in_ts .and. name == 'io') then - - call QUIP_FoX_get_value(attributes, "verbosity", value, status) - if (status == 0) then - parse_ts%io_verbosity = verbosity_of_str(value) - end if - - call QUIP_FoX_get_value(attributes, "print_interval", value, status) - if (status == 0) then - read (value, *) parse_ts%io_print_interval - end if - - elseif (parse_in_ts .and. name == 'qm') then - - call QUIP_FoX_get_value(attributes, "args", value, status) - if (status == 0) then - parse_ts%qm_args = value - end if - - call QUIP_FoX_get_value(attributes, "args_str", value, status) - if (status == 0) then - parse_ts%qm_args_str = value - end if - - elseif (parse_in_ts .and. name == 'classical') then - - call QUIP_FoX_get_value(attributes, "args", value, status) - if (status == 0) then - parse_ts%classical_args = value - end if - - call QUIP_FoX_get_value(attributes, "args_str", value, status) - if (status == 0) then - parse_ts%classical_args_str = value - end if - - call QUIP_FoX_get_value(attributes, "force_reweight", value, status) - if (status == 0) then - read (value, *) parse_ts%classical_force_reweight - end if - - elseif (parse_in_ts .and. name == 'minim') then - print *, 'AAA' - - - call QUIP_FoX_get_value(attributes, "gfac", value, status) - if (status == 0) then - read (value, *) parse_ts%minim_gfac - end if - - call QUIP_FoX_get_value(attributes, "force_tol", value, status) - if (status == 0) then - read (value, *) parse_ts%minim_force_tol - end if - - call QUIP_FoX_get_value(attributes, "energy_tol", value, status) - if (status == 0) then - read (value, *) parse_ts%minim_energy_tol - end if - - call QUIP_FoX_get_value(attributes, "max_steps", value, status) - if (status == 0) then - read (value, *) parse_ts%minim_max_steps - end if - - elseif (parse_in_ts .and. name == 'minim_end') then - - call QUIP_FoX_get_value(attributes, "optimise_end", value, status) - if (status == 0) then - read(value,*) parse_ts%minim_end - end if - - call QUIP_FoX_get_value(attributes, "method", value, status) - if (status == 0) then - parse_ts%minim_end_method = value - end if - - call QUIP_FoX_get_value(attributes, "tol", value, status) - if (status == 0) then - read (value, *) parse_ts%minim_end_tol - end if - - call QUIP_FoX_get_value(attributes, "eps_guess", value, status) - if (status == 0) then - read (value, *) parse_ts%minim_end_eps_guess - end if - - call QUIP_FoX_get_value(attributes, "max_steps", value, status) - if (status == 0) then - read (value, *) parse_ts%minim_end_max_steps - end if - - call QUIP_FoX_get_value(attributes, "linminroutine", value, status) - if (status == 0) then - parse_ts%minim_end_linminroutine = value - end if - - endif - -end subroutine tsparams_startElement_handler - -subroutine tsparams_endElement_handler(URI, localname, name) - character(len=*), intent(in) :: URI - character(len=*), intent(in) :: localname - character(len=*), intent(in) :: name - - if (parse_in_ts) then - if (name == 'ts_params') then - parse_in_ts = .false. - endif - endif - -end subroutine tsparams_endElement_handler - - -subroutine tsparams_print(this,file) - type(tsparams), intent(in) :: this - type(Inoutput), optional, intent(in) :: file - -end subroutine tsparams_print - -end module tsparams_module From 22b11db2e6c9c52e051b55ca53fbf84e005d466a Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 18:14:29 +0100 Subject: [PATCH 09/47] renamed source files to have F90 extension --- src/Potentials/AdjustablePotential.F90 | 1316 ++++++ src/Potentials/ApproxFermi.F90 | 293 ++ src/Potentials/CallbackPot.F90 | 310 ++ src/Potentials/ElectrostaticEmbed.F90 | 544 +++ src/Potentials/Ewald.F90 | 830 ++++ src/Potentials/FilePot.F90 | 495 +++ src/Potentials/Functions.F90 | 451 ++ src/Potentials/IP.F90 | 1155 +++++ src/Potentials/IPEwald.F90 | 554 +++ src/Potentials/IPModel_ASAP.F90 | 1027 +++++ src/Potentials/IPModel_BOP.F90 | 800 ++++ src/Potentials/IPModel_BornMayer.F90 | 571 +++ src/Potentials/IPModel_Brenner.F90 | 713 +++ src/Potentials/IPModel_Brenner_2002.F90 | 399 ++ src/Potentials/IPModel_Brenner_Screened.F90 | 404 ++ src/Potentials/IPModel_CH4.F90 | 204 + src/Potentials/IPModel_ConfiningMonomer.F90 | 340 ++ src/Potentials/IPModel_Coulomb.F90 | 563 +++ src/Potentials/IPModel_Custom.F90 | 192 + src/Potentials/IPModel_DispTS.F90 | 647 +++ .../IPModel_EAM_Ercolessi_Adams.F90 | 814 ++++ src/Potentials/IPModel_Einstein.F90 | 369 ++ src/Potentials/IPModel_FB.F90 | 455 ++ src/Potentials/IPModel_FC.F90 | 714 +++ src/Potentials/IPModel_FC4.F90 | 836 ++++ src/Potentials/IPModel_FS.F90 | 589 +++ src/Potentials/IPModel_FX.F90 | 367 ++ src/Potentials/IPModel_GAP.F90 | 987 +++++ src/Potentials/IPModel_Glue.F90 | 905 ++++ src/Potentials/IPModel_HFdimer.F90 | 208 + src/Potentials/IPModel_KIM.F90 | 683 +++ src/Potentials/IPModel_LJ.F90 | 747 ++++ src/Potentials/IPModel_LMTO_TBE.F90 | 362 ++ src/Potentials/IPModel_LinearSOAP.F90 | 535 +++ src/Potentials/IPModel_MBD.F90 | 275 ++ src/Potentials/IPModel_MTP.F90 | 255 ++ src/Potentials/IPModel_Morse.F90 | 569 +++ src/Potentials/IPModel_Multipoles.F90 | 700 +++ src/Potentials/IPModel_PartridgeSchwenke.F90 | 709 +++ src/Potentials/IPModel_RS.F90 | 575 +++ src/Potentials/IPModel_SCME.F90 | 336 ++ src/Potentials/IPModel_SW.F90 | 920 ++++ src/Potentials/IPModel_SW_VP.F90 | 1218 +++++ src/Potentials/IPModel_Si_MEAM.F90 | 714 +++ src/Potentials/IPModel_Spring.F90 | 259 ++ src/Potentials/IPModel_Sutton_Chen.F90 | 458 ++ src/Potentials/IPModel_TS.F90 | 968 ++++ src/Potentials/IPModel_Template.F90 | 295 ++ src/Potentials/IPModel_Tersoff.F90 | 735 +++ src/Potentials/IPModel_Tether.F90 | 197 + src/Potentials/IPModel_WaterDimer_Gillan.F90 | 1027 +++++ src/Potentials/IPModel_WaterTrimer_Gillan.F90 | 700 +++ src/Potentials/IPModel_ZBL.F90 | 311 ++ src/Potentials/IPModel_vdW.F90 | 899 ++++ src/Potentials/Multipole_Interactions.F90 | 764 ++++ src/Potentials/Multipoles.F90 | 642 +++ src/Potentials/Partridge_Schwenke_Dipole.F90 | 713 +++ src/Potentials/Potential.F90 | 2442 ++++++++++ src/Potentials/Potential_Cluster_header.F90 | 65 + src/Potentials/Potential_Cluster_routines.F90 | 163 + src/Potentials/Potential_EVB_header.F90 | 46 + src/Potentials/Potential_EVB_routines.F90 | 400 ++ .../Potential_ForceMixing_header.F90 | 128 + .../Potential_ForceMixing_routines.F90 | 783 ++++ src/Potentials/Potential_Hybrid_utils.F90 | 284 ++ .../Potential_Local_E_Mix_header.F90 | 83 + .../Potential_Local_E_Mix_routines.F90 | 435 ++ src/Potentials/Potential_ONIOM_header.F90 | 81 + src/Potentials/Potential_ONIOM_routines.F90 | 410 ++ src/Potentials/Potential_Precon_Minim.F90 | 1659 +++++++ src/Potentials/Potential_Sum_header.F90 | 32 + src/Potentials/Potential_Sum_routines.F90 | 174 + src/Potentials/Potential_simple.F90 | 1612 +++++++ src/Potentials/QC_QUIP_Wrapper.F90 | 310 ++ src/Potentials/QUIP_Common.F90 | 113 + src/Potentials/QUIP_module.F90 | 74 + src/Potentials/RS_SparseMatrix.F90 | 2146 +++++++++ src/Potentials/SocketPot.F90 | 341 ++ src/Potentials/TB.F90 | 2360 ++++++++++ src/Potentials/TBMatrix.F90 | 1310 ++++++ src/Potentials/TBModel.F90 | 674 +++ src/Potentials/TBModel_Bowler.F90 | 1089 +++++ src/Potentials/TBModel_DFTB.F90 | 1143 +++++ src/Potentials/TBModel_GSP.F90 | 1385 ++++++ src/Potentials/TBModel_NRL_TB.F90 | 1921 ++++++++ src/Potentials/TBModel_NRL_TB_defs.F90 | 48 + src/Potentials/TBSystem.F90 | 3943 +++++++++++++++++ src/Potentials/TB_Common.F90 | 335 ++ src/Potentials/TB_GreensFunctions.F90 | 649 +++ src/Potentials/TB_Kpoints.F90 | 818 ++++ src/Potentials/TB_Mixing.F90 | 518 +++ src/Potentials/Yukawa.F90 | 594 +++ src/Potentials/quip_lammps_wrapper.F90 | 199 + src/Potentials/quip_unified_wrapper.F90 | 333 ++ 94 files changed, 63718 insertions(+) create mode 100644 src/Potentials/AdjustablePotential.F90 create mode 100644 src/Potentials/ApproxFermi.F90 create mode 100644 src/Potentials/CallbackPot.F90 create mode 100644 src/Potentials/ElectrostaticEmbed.F90 create mode 100644 src/Potentials/Ewald.F90 create mode 100644 src/Potentials/FilePot.F90 create mode 100644 src/Potentials/Functions.F90 create mode 100644 src/Potentials/IP.F90 create mode 100644 src/Potentials/IPEwald.F90 create mode 100644 src/Potentials/IPModel_ASAP.F90 create mode 100644 src/Potentials/IPModel_BOP.F90 create mode 100644 src/Potentials/IPModel_BornMayer.F90 create mode 100644 src/Potentials/IPModel_Brenner.F90 create mode 100644 src/Potentials/IPModel_Brenner_2002.F90 create mode 100644 src/Potentials/IPModel_Brenner_Screened.F90 create mode 100644 src/Potentials/IPModel_CH4.F90 create mode 100644 src/Potentials/IPModel_ConfiningMonomer.F90 create mode 100644 src/Potentials/IPModel_Coulomb.F90 create mode 100644 src/Potentials/IPModel_Custom.F90 create mode 100644 src/Potentials/IPModel_DispTS.F90 create mode 100644 src/Potentials/IPModel_EAM_Ercolessi_Adams.F90 create mode 100644 src/Potentials/IPModel_Einstein.F90 create mode 100644 src/Potentials/IPModel_FB.F90 create mode 100644 src/Potentials/IPModel_FC.F90 create mode 100644 src/Potentials/IPModel_FC4.F90 create mode 100644 src/Potentials/IPModel_FS.F90 create mode 100644 src/Potentials/IPModel_FX.F90 create mode 100644 src/Potentials/IPModel_GAP.F90 create mode 100644 src/Potentials/IPModel_Glue.F90 create mode 100644 src/Potentials/IPModel_HFdimer.F90 create mode 100644 src/Potentials/IPModel_KIM.F90 create mode 100644 src/Potentials/IPModel_LJ.F90 create mode 100644 src/Potentials/IPModel_LMTO_TBE.F90 create mode 100644 src/Potentials/IPModel_LinearSOAP.F90 create mode 100644 src/Potentials/IPModel_MBD.F90 create mode 100644 src/Potentials/IPModel_MTP.F90 create mode 100644 src/Potentials/IPModel_Morse.F90 create mode 100644 src/Potentials/IPModel_Multipoles.F90 create mode 100644 src/Potentials/IPModel_PartridgeSchwenke.F90 create mode 100644 src/Potentials/IPModel_RS.F90 create mode 100644 src/Potentials/IPModel_SCME.F90 create mode 100644 src/Potentials/IPModel_SW.F90 create mode 100644 src/Potentials/IPModel_SW_VP.F90 create mode 100644 src/Potentials/IPModel_Si_MEAM.F90 create mode 100644 src/Potentials/IPModel_Spring.F90 create mode 100644 src/Potentials/IPModel_Sutton_Chen.F90 create mode 100644 src/Potentials/IPModel_TS.F90 create mode 100644 src/Potentials/IPModel_Template.F90 create mode 100644 src/Potentials/IPModel_Tersoff.F90 create mode 100644 src/Potentials/IPModel_Tether.F90 create mode 100644 src/Potentials/IPModel_WaterDimer_Gillan.F90 create mode 100644 src/Potentials/IPModel_WaterTrimer_Gillan.F90 create mode 100644 src/Potentials/IPModel_ZBL.F90 create mode 100644 src/Potentials/IPModel_vdW.F90 create mode 100644 src/Potentials/Multipole_Interactions.F90 create mode 100644 src/Potentials/Multipoles.F90 create mode 100644 src/Potentials/Partridge_Schwenke_Dipole.F90 create mode 100644 src/Potentials/Potential.F90 create mode 100644 src/Potentials/Potential_Cluster_header.F90 create mode 100644 src/Potentials/Potential_Cluster_routines.F90 create mode 100644 src/Potentials/Potential_EVB_header.F90 create mode 100644 src/Potentials/Potential_EVB_routines.F90 create mode 100644 src/Potentials/Potential_ForceMixing_header.F90 create mode 100644 src/Potentials/Potential_ForceMixing_routines.F90 create mode 100644 src/Potentials/Potential_Hybrid_utils.F90 create mode 100644 src/Potentials/Potential_Local_E_Mix_header.F90 create mode 100644 src/Potentials/Potential_Local_E_Mix_routines.F90 create mode 100644 src/Potentials/Potential_ONIOM_header.F90 create mode 100644 src/Potentials/Potential_ONIOM_routines.F90 create mode 100644 src/Potentials/Potential_Precon_Minim.F90 create mode 100644 src/Potentials/Potential_Sum_header.F90 create mode 100644 src/Potentials/Potential_Sum_routines.F90 create mode 100644 src/Potentials/Potential_simple.F90 create mode 100644 src/Potentials/QC_QUIP_Wrapper.F90 create mode 100644 src/Potentials/QUIP_Common.F90 create mode 100644 src/Potentials/QUIP_module.F90 create mode 100644 src/Potentials/RS_SparseMatrix.F90 create mode 100644 src/Potentials/SocketPot.F90 create mode 100644 src/Potentials/TB.F90 create mode 100644 src/Potentials/TBMatrix.F90 create mode 100644 src/Potentials/TBModel.F90 create mode 100644 src/Potentials/TBModel_Bowler.F90 create mode 100644 src/Potentials/TBModel_DFTB.F90 create mode 100644 src/Potentials/TBModel_GSP.F90 create mode 100644 src/Potentials/TBModel_NRL_TB.F90 create mode 100644 src/Potentials/TBModel_NRL_TB_defs.F90 create mode 100644 src/Potentials/TBSystem.F90 create mode 100644 src/Potentials/TB_Common.F90 create mode 100644 src/Potentials/TB_GreensFunctions.F90 create mode 100644 src/Potentials/TB_Kpoints.F90 create mode 100644 src/Potentials/TB_Mixing.F90 create mode 100644 src/Potentials/Yukawa.F90 create mode 100644 src/Potentials/quip_lammps_wrapper.F90 create mode 100644 src/Potentials/quip_unified_wrapper.F90 diff --git a/src/Potentials/AdjustablePotential.F90 b/src/Potentials/AdjustablePotential.F90 new file mode 100644 index 0000000000..6968a294ed --- /dev/null +++ b/src/Potentials/AdjustablePotential.F90 @@ -0,0 +1,1316 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Learn-on-the-fly (LOTF) hybrid molecular dynamics code +!X +!X +!X Authors: Gabor Csanyi, Alessio Commisso, Steven Winfield +!X James Kermode, Gianpietro Moras, Michael Payne, Alessandro De Vita +!X +!X Copyright 2005, All Rights Reserved +!X +!X This source code is confidential, all distribution is +!X prohibited. Making unauthorized copies is also prohibited +!X +!X When using this software, the following should be referenced: +!X +!X Gabor Csanyi, Tristan Albaret, Mike C. Payne and Alessandro De Vita +!X "Learn on the fly": a hybrid classical and quantum-mechanical +!X molecular dynamics simulation +!X Physical Review Letters 93 p. 175503 (2004) >>PDF [626 KB] +!X +!X Gabor Csanyi, T. Albaret, G. Moras, M. C. Payne, A. De Vita +!X Multiscale hybrid simulation methods for material systems +!X J. Phys. Cond. Mat. 17 R691-R703 Topical Review (2005) +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X AdjustablePotential_linear module +!X +!X a set of linear potentials that can be adapted a reproduce +!X given forces on atoms +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +module AdjustablePotential_module + use system_module, only : dp, print, inoutput, PRINT_VERBOSE, PRINT_NERD, line, optional_default, mainlog, value, system_abort, reallocate, print_message, operator(//), mpi_id, abort_on_mpi_error + use linearalgebra_module + use table_module + use sparse_module + use minimization_module + + use atoms_types_module + use atoms_module + use clusters_module + +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif + implicit none +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif + private + SAVE + + public :: adjustable_potential_init, adjustable_potential_optimise, adjustable_potential_force, adjustable_potential_finalise + + + ! ratio of smallest to largest eigenvalue of spring space spanning matrix + ! for an atom to be considered not well described + real(dp), parameter :: AP_bad_atom_threshold = 0.1_dp + + ! Threshold for spring constants above which a warning will be issued + real(dp), parameter :: adjustable_potential_max_spring_constant = 1.0_dp + + integer, parameter :: adjustable_potential_nparams = 1 + + ! are we initialised or not + logical::adjustable_potential_initialised = .false. + + ! have we got some parameters saved + logical::adjustable_potential_parameters_saved = .false. + + ! this table contains the pairs of atoms for which we have a two-body + ! adjustable spring potential, together with their distance + ! and the potential parameters. the parameters are just the y values of the spring + ! !!!the integer indices refer to the order of atoms in the fitlist + ! argument of the init() routine!!! + ! + ! int real + ! + !fitlist indexes -> fi,fj,shift rij, fij <- fij: variable parameter + type(table)::twobody + + ! this table is used as a store for old data which can be used to initialise + ! parameters to values from the last interpolation step. It also stores + ! parameters from one end point during interpolation + type(table)::twobody_old + + real(dp), dimension(:,:), allocatable:: fitforce_old + + !The exclusion list table is used to prevent springs being created between + !certain pairs of atoms, e.g. if there is a bond length constraint between + !them. + type(table) :: exclusion_list + logical :: exclusions = .false. + + ! Operation twobody twobody_old + ! + ! Extrapolate from t1 -> t2 using parameters P1 P1 --, -- + ! Compute parameters P2' at t2 P2' `--> P1 + ! Interpolate from t1 -> t2 using P1 and P2' P2' --, P1 + ! Call CalcConnect -- `--> P2' + ! Create parameters P2 using P2' as initial values P2 P2' + ! Extrapolate from t2 -> t3 using parameters P2 P2 -- + ! ... + + ! local copy of target force to fit to: F1x,F1yF1z,F2x,F2y,F2z... + real(dp), allocatable, dimension(:) ::target_force + + ! local copy of fitlist indices + ! atomlist%int(1,fi) = i, fi: index in fitlist, i: index in Atoms structure + type(Table) :: atomlist, atomlist_old +!!$ type(Table) :: fitlist_old + + ! forcematrix multiplied onto the vector of + ! parameters (fij...) + ! gives the force vector on the atoms. the number of columns + ! is the number of parameters, the number of rows is 3*the number of atoms + ! + ! force = forcematrix * params + ! + ! ...0..y1_x y2_x...0...... + ! ...0..y1_y y2_y...0...... + ! ...0..y1_z y2_z...0...... + type(sparse) ::forcematrix ! linear part + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Initialize adjustable potential + !X + !X inputs are an atoms structure and a table with a single list integers + !X of atoms for which target forces are to be fitted. + !X + !X The adjustable potential will be fitted to the difference between + !X a quantum mechanical force and a classical force. + !X + !X An adjustable potential will be created between every pair of neighbouring + !X atoms that are given in the fitlist. + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + + ! this is called with a table + subroutine adjustable_potential_init(atoms_in, fitlist, directionN, spring_hops, & + map, method, nnonly) + type(Atoms), intent(in) :: atoms_in + type(Table), intent(in) :: fitlist + integer, intent(in) :: directionN + integer, optional, intent(in) :: spring_hops + logical, optional, intent(in) :: map, nnonly + character(len=*),optional,intent(in):: method + + + real(dp):: ratio, evals(3), evecs(3,3), small_evec(3), r_ij, u_ij(3), cos_theta, oldratio + real(dp), allocatable, dimension(:)::default_row + real(dp), allocatable, dimension(:,:) :: df + integer::Nfit_components, i, j, fi, fj, nj, n, hops, atomcount, oldn, & + shift(3), k, best_j, best_fj, best_shift(3), sloc(1), sx, sy, sz + type(Table) :: springs, newsprings, tmpsprings,cand_springs + logical :: do_map, do_nnonly + logical :: do_refit + + do_map = .false. + if (present(map)) do_map = map + + do_nnonly = .true. + if (present(nnonly)) do_nnonly = nnonly + + hops = 2 + if(present(spring_hops)) then + hops = spring_hops + end if + + ! If QM region hasn't changed since we last made out spring list, then + ! there's nothing to be done now. + + if(do_map) then + ! this save makes the twobody_old equal to twobody + call adjustable_potential_save_parameters + call print("Saving old parameters ....", PRINT_VERBOSE) + end if + +!!$ if (first_time) then +!!$ first_time = .false. +!!$ else if (fitlist%N == fitlist_old%N) then +!!$ +!!$ allocate(s1(fitlist%N),s2(fitlist%N)) +!!$ s1 = fitlist%int(1,1:fitlist%N) +!!$ s2 = atomlist%int(1,1:atomlist%N) +!!$ call sort_array(s1) +!!$ call sort_array(s2) +!!$ +!!$ if (all(int_part(fitlist) == int_part(fitlist_old))) then +!!$ call print('fitlist unchanged, nothing to be done in adjustable_potential_init', PRINT_VERBOSE) +!!$ deallocate(s1) +!!$ deallocate(s2) + + ! Atom set matches, but it's possible some of the shifts have changed + ! if any fit atoms have crossed a periodic boundary since last call to + ! adjustable_potential_init. Let's overwrite with new shifts. +!!$ do n=1,twobody%N +!!$ i = atomlist%int(1,twobody%int(1,n)) +!!$ j = atomlist%int(1,twobody%int(2,n)) +!!$ ! overwrite old shift in twobody%int(3:5,n) with correct shift +!!$ r = distance_min_image(atoms_in, i, j, shift=shift) +!!$ +!!$ if (abs(r-twobody%real(1,i)) < 0.1_dp) then +!!$ call print('shift update: '//shift//' '//twobody%int(3:5,i)//' '//r//' '//twobody%real(1,i)) +!!$ twobody%int(3:5,i) = shift +!!$ end if +!!$ +!!$ !! for the thin crack system, not all springs are min +!!$ !! image springs; some of them span periodic boundary. +!!$ !! how can we get round this? +!!$ +!!$ end do +!!$ +!!$ return +!!$ end if +!!$ +!!$ deallocate(s1) +!!$ deallocate(s2) +!!$ end if +!!$ call wipe(fitlist_old) +!!$ call append(fitlist_old, fitlist) + + call print("Setting up adjustable potential....", PRINT_VERBOSE) + + ! test table size + if(fitlist%intsize /= 4 .and. fitlist%intsize /= 1) & + call system_abort("adjustable_potential_init: fitlist%intsize must be 1 or 4") + if(fitlist%realsize /= 0) & + call system_abort("adjustable_potential_init: fitlist%realsize /= 0") + + if (multiple_images(fitlist)) & + call system_abort('adjustable_potential_init: fitlist contains repeated atom indices') + + call print("Fitting on atoms:", PRINT_VERBOSE) + call print(fitlist, PRINT_VERBOSE) + call print("", PRINT_VERBOSE) + + ! allocate globals + call print("Allocating target_force", PRINT_NERD) + Nfit_components = fitlist%N*3 + + call reallocate(target_force,Nfit_components) + target_force = 0.0_dp + + ! copy atom indices from argument to global + + call wipe(atomlist) + call allocate(atomlist,1,0,0,0,fitlist%N) + call append(atomlist, fitlist%int(1,1:fitlist%N)) + + ! set up twobody table that holds pairs of atom indices and shiftts + ! and the associated potential parameters (initialized to 0) + + ! wipe previous table + call print("Wiping twobody table", PRINT_NERD) + call wipe(twobody) + call allocate(twobody, 5, 1+2*adjustable_potential_nparams,0,0) + + call allocate(springs, 4, 0, 0, 0) + call allocate(newsprings, 4, 0, 0, 0) + call allocate(tmpsprings, 4, 0, 0, 0) + + + ! default parameters + allocate(default_row(1+2*adjustable_potential_nparams)) + default_row = 0.0_dp + + + ! First we try to add springs between pairs of atoms in fitlist within 'hops' + ! bond hops of one another + call print('Adding default springs') + do fi=1,atomlist%N ! loop through fit atoms + i = atomlist%int(1,fi) + + call wipe(newsprings) + call append(newsprings, (/i,0,0,0/)) + call bfs_grow(atoms_in, newsprings, hops, nneighb_only = do_nnonly) + + do nj = 1, newsprings%N + + j = newsprings%int(1,nj) + shift = newsprings%int(2:4,nj) + + fj = find(atomlist, j) + if (fj == 0) cycle ! not in fitlist + if (i == j) cycle ! don't join to self or images of self + + ! Have we already got this spring? + ! always store in order fi, fj with fi < fj + if (find(twobody, (/min(fi,fj), max(fi,fj), sign(1,fj-fi)*shift/)) /= 0) cycle + + ! Is this pair excluded? + if (exclusions) then + if (is_excluded(i,j,shift)) cycle + end if + + default_row(1) = distance(atoms_in, i, j, shift) + call append(twobody, (/min(fi,fj), max(fi,fj), sign(1,fj-fi)*shift/), default_row) + end do + + end do + write(line, '(a,i0,a)') 'Got ', twobody%N, ' springs' ; call print(line) + write(line, '(a,f0.2)') 'Searching for difficult atoms, anisotropy threshold: ', AP_bad_atom_threshold + call print(line, PRINT_VERBOSE) + + oldn = twobody%N + atomcount = 0 + ! For those fit atoms that we require directionality for, check how well the + ! springs connected to it span 3D space. If necessary add more springs for those atoms. + do fi=1,directionN + i = atomlist%int(1, fi) + + ! Find who atom i is connected to with springs, and get associated shifts + call wipe(springs) + do j = 1, twobody%N + if (twobody%int(1,j) == fi) & + call append(springs, (/atomlist%int(1,twobody%int(2,j)), twobody%int(3:5,j)/)) + if (twobody%int(2,j) == fi) & + call append(springs, (/atomlist%int(1,twobody%int(1,j)),-twobody%int(3:5,j)/)) + end do + + ! How well do these springs span 3D space? + if (springs%N > 2) then + call directionality(atoms_in, i, springs, evals, evecs, method=2) + ratio = minval(evals)/maxval(evals) + else + ratio = 0.0_dp ! less than three springs - really bad! + end if + + sloc = minloc(evals) + small_evec = evecs(:,sloc(1)) + + if (ratio < AP_bad_atom_threshold) then + + write (line,'(a,i6,a,i6,a,f10.3)') 'Atom ', i, ' with ', springs%N, & + ' springs has ratio ', ratio + call print(line, PRINT_VERBOSE) + call print('Smallest evect ='//small_evec, PRINT_VERBOSE) + + ! Not well enough + atomcount = atomcount + 1 + + ! Tabulate candidate springs + call allocate(cand_springs, 5, 2, 0, 0) + do fj = 1,atomlist%N + j = atomlist%int(1,fj) + + if (i == j) cycle ! Don't join to self + + do sx=-1,1 + do sy=-1,1 + do sz=-1,1 + + shift = (/sx,sy,sz/) + + if (find(springs, (/j,shift/)) /= 0) cycle ! We've tried this spring already + + ! Don't add if this pair is excluded + if (exclusions) then + if (is_excluded(i,j,shift)) cycle + end if + + r_ij = distance(atoms_in,i,j,shift) + u_ij = diff(atoms_in,i,j,shift) + cos_theta = abs(small_evec .dot. u_ij) / (norm(small_evec)*norm(u_ij)) + + call append(cand_springs, (/j,fj,shift/), (/r_ij,cos_theta/)) + + end do + end do + end do + end do + + ! Try to add springs until ratio exceeds thresholds + n = 0 + do while (ratio < AP_bad_atom_threshold .and. n < 8) + + ! Find candidate spring with largest cos_theta + sloc = maxloc(cand_springs%real(2,1:cand_springs%N)) + k = sloc(1) + + best_j = cand_springs%int(1,k) + best_fj = cand_springs%int(2,k) + best_shift = cand_springs%int(3:5,k) + r_ij = cand_springs%real(1,k) + + call print('Trying spring to atom '//best_j//' (index '//best_fj//') shift '//best_shift//' length '//r_ij) + + call delete(cand_springs, k) + + call append(springs, (/best_j,best_shift/)) + + oldratio = ratio + + call directionality(atoms_in, i, springs, evals, evecs, 2) + ratio = minval(evals)/maxval(evals) + + ! Add this spring to twobody only if it improves ratio + if (ratio > oldratio) then + default_row(1) = r_ij + call append(twobody,(/min(fi,best_fj),max(fi,best_fj),sign(1,best_fj-fi)*best_shift/), default_row) + + write (line, '(a,i0,a,f0.3)') ' Now got ', springs%N,' springs. Ratio improved to ', ratio + call print(line, PRINT_VERBOSE) + end if + + n = n + 1 + +!!$ newsprings = springs +!!$ +!!$ call bfs_step(atoms_in, newsprings, tmpsprings, nneighb_only = .true.) +!!$ call append(newsprings, tmpsprings) +!!$ +!!$ if (tmpsprings%N == 0) then +!!$ ! Didn't manage to add any atoms, so try nneigb_only = false, since +!!$ ! these are the 'bad' atoms and their neighbours are +!!$ ! probably some distance away +!!$ +!!$ call bfs_step(atoms_in, newsprings, tmpsprings, nneighb_only = .false.) +!!$ call append(newsprings, tmpsprings) +!!$ end if +!!$ +!!$ do nj = 1, newsprings%N +!!$ j = newsprings%int(1,nj) +!!$ shift = newsprings%int(2:4,nj) +!!$ fj = find(atomlist, j) +!!$ if (fj == 0) cycle ! not in fitlist +!!$ if (i == j) cycle ! don't join to self or images of self +!!$ +!!$ ! already got this spring +!!$ if (find(twobody, (/min(fi,fj), max(fi,fj), sign(1,fj-fi)*shift/)) /= 0) cycle +!!$ +!!$ ! Don't add if this pair is excluded +!!$ if (exclusions) then +!!$ if (is_excluded(i,j,shift)) cycle +!!$ end if +!!$ +!!$ default_row(1) = distance(atoms_in, i, j, shift) +!!$ call append(twobody,(/min(fi,fj),max(fi,fj),sign(1,fj-fi)*shift/), default_row) +!!$ end do +!!$ +!!$ ! Work out the springs again +!!$ call wipe(springs) +!!$ do j = 1, twobody%N +!!$ if (twobody%int(1,j) == fi) & +!!$ call append(springs, (/atomlist%int(1,twobody%int(2,j)), twobody%int(3:5,j)/)) +!!$ if (twobody%int(2,j) == fi) & +!!$ call append(springs, (/atomlist%int(1,twobody%int(1,j)),-twobody%int(3:5,j)/)) +!!$ end do +!!$ +!!$ ! Did we fail to add any springs at all? If so system has probably exploded +!!$ if (springs%N == 0) then +!!$ write(line, '(a,i0)') 'adjustable_potential_init: can''t add any springs for atom ', i +!!$ call system_abort(line) +!!$ end if +!!$ +!!$ call directionality(atoms_in, i, springs, evals, evecs, 2) +!!$ ratio = minval(evals)/maxval(evals) +!!$ +!!$ write (line, '(a,i0,a,f0.3)') ' Now got ', springs%N,' springs. Ratio improved to ', ratio +!!$ call print(line, PRINT_VERBOSE) +!!$ +!!$ n = n + 1 + end do + if (n == 8 .and. ratio < AP_bad_atom_threshold) then + call system_abort('adjustable_potential_init: failed to sufficiently improve bad spring space spanning') + end if + + end if + + end do + + if(atomcount > 0) then + write(line, '(a,i0,a,i0,a)') 'Added ', twobody%N-oldn, ' springs to fix ', atomcount, ' atoms' + call print(line) + end if + + call finalise(springs) + call finalise(newsprings) + call finalise(tmpsprings) + deallocate(default_row) + + call print("Allocating twobody table to proper size", PRINT_NERD) + call allocate(twobody) ! reduce table to proper length + + write(line, '(a,i0)') "Number of force components: ", size(target_force) ; call print(line) + write(line, '(a,i0)') "Number of parameters: ", twobody%N*adjustable_potential_nparams ; call print(line) + + adjustable_potential_initialised = .true. + + if(do_map) then + ! this maps from the twobody_old with the old structure into twobody with the new structure + call adjustable_potential_map_parameters + + ! Only need to refit if spline set has changed since last time + do_refit = .false. + ! if sizes don't match definitely need to refit + if (twobody%N /= twobody_old%N) then + do_refit = .true. + else + do i=1,twobody%N + ! As soon as we can't find a new spring in twobody_old, know we have to refit + if (find(twobody_old,twobody%int(:,i)) == 0) then + do_refit = .true. + exit + end if + end do + end if + + ! reoptimise with new springs to reproduce old forces at new positions + ! if fit region has changed, just copy the target force components that + ! are in both the old and new regions + if (do_refit) then + call print('Springs changed, refitting old forces with new spring set') + allocate(df(3,atomlist%N)) + df = 0.0_dp + do i=1,atomlist_old%N + fi = find(atomlist, atomlist_old%int(:,i)) ! find old fit atom in new fitlist + if (fi /= 0) df(:,fi) = fitforce_old(:,i) ! if found, copy target force + end do + call adjustable_potential_optimise(atoms_in, df, method=method) + deallocate(df) + end if + + endif + + ! this save makes the twobody_old equal to twobody (both new structure) + call adjustable_potential_save_parameters + + end subroutine adjustable_potential_init + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_finalise() + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + subroutine adjustable_potential_finalise() + if(allocated(target_force)) deallocate(target_force) + call finalise(atomlist) + call finalise(atomlist_old) + call finalise(twobody) + call finalise(twobody_old) + call adjustable_potential_delete_saved_parameters + call sparse_finalise(forcematrix) + if (exclusions) call finalise(exclusion_list) + end subroutine adjustable_potential_finalise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_delete_saved_parameters + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine adjustable_potential_delete_saved_parameters + call finalise(twobody_old) + call finalise(atomlist_old) + adjustable_potential_parameters_saved = .false. + end subroutine adjustable_potential_delete_saved_parameters + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_save_parameters + !X + !X Makes a copy of the twobody and atomlist data, avoiding a + !X reallocation if possible + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine adjustable_potential_save_parameters + if (.not.adjustable_potential_initialised) & + call system_abort('Adjustable_Potential_Save_Parameters: No parameters exist to save') + call wipe(twobody_old) + call append(twobody_old,twobody) + + call wipe(atomlist_old) + call append(atomlist_old, atomlist) + + adjustable_potential_parameters_saved = .true. + + end subroutine adjustable_potential_save_parameters + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_map_parameters + !X + !X Given an old set of data (twobody_old, atomlist_old), fill in the + !X y1 and y2 values which were used previously + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine adjustable_potential_map_parameters + integer :: i, j, fi, fj, n, m, k, shift(3) + + if(.not.adjustable_potential_initialised) & + call system_abort('Adjustable_Potential_Map_Parameters: No parameters to map!') + if (twobody_old%N == 0) & + call system_abort('Adjustable_Potential_Map_Parameters: No parameters are saved') + + if (twobody%N >= twobody_old%N) then ! loop over the smallest table + + !Loop over the entries in the old table + do n = 1, twobody_old%N + + !look up the atom indices + i = atomlist_old%int(1,twobody_old%int(1,n)) + j = atomlist_old%int(1,twobody_old%int(2,n)) + shift = twobody_old%int(3:5,n) + + !try to find the corresponding atoms in the new list + fi = find(atomlist,i) + if (fi == 0) cycle !atom i is not present in the new list + fj = find(atomlist,j) + if (fj == 0) cycle !atom j is not present in the new list + + !find the entry in the new twobody table + m = find(twobody,(/min(fi,fj),max(fi,fj),sign(1,fj-fi)*shift/)) + if (m == 0) cycle ! i and j are no longer connected + + ! copy the parameter values across + do k=1,2*adjustable_potential_nparams + twobody%real(1+k,m) = twobody_old%real(1+k,n) + end do + + end do + + else + + !Loop over the entries in the new table + do n = 1, twobody%N + + !look up the atom indices + i = atomlist%int(1,twobody%int(1,n)) + j = atomlist%int(1,twobody%int(2,n)) + shift = twobody%int(3:5,n) + + !try to find the corresponding atoms in the old list + fi = find(atomlist_old, i) + if (fi == 0) cycle !atom i is not present in the old list + fj = find(atomlist_old, j) + if (fj == 0) cycle !atom j is not present in the old list + + !find the entry in the old twobody table + m = find(twobody_old,(/min(fi,fj),max(fi,fj),sign(1,fj-fi)*shift/)) + if (m == 0) cycle ! i and j were not neighbours + + !copy the param values across + do k=1,2*adjustable_potential_nparams + twobody%real(1+k,n) = twobody_old%real(1+k,m) + end do + + end do + + end if + + end subroutine adjustable_potential_map_parameters + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_force(atoms, force) + !X + !X force and energy from the adjustable potential, using the interatomic + !X distance information from atoms. If interp is given, then interpolate + !X the parameters between twobody_old and twobody + !X + !X the force(:) array is the same size as the stored atomlist. + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine adjustable_potential_force(atoms_in, force, interp, interp_space, interp_order, energy, power) + type(Atoms), intent(in) :: atoms_in + real(dp), dimension(3,atomlist%N), intent(out) :: force + real(dp), optional, intent(in) :: interp + logical, optional, intent(in) :: interp_space + character(len=*),optional, intent(in) :: interp_order + real(dp), optional, intent(out) :: energy, power + + ! local + integer:: i, a1, a2, fi, fj, shift(3), my_interp_order + real(dp), dimension(3)::f + real(dp)::fij, r, interp_point, dalpha + logical::interpolate, do_interp_space + + do_interp_space = optional_default(.false., interp_space) + + interpolate = present(interp) .or. do_interp_space + if(interpolate .and. .not.adjustable_potential_parameters_saved) & + call System_Abort('Adjustable_Potential_Force: No parameters saved to interpolate with') + + my_interp_order = 1 + if(present(interp_order)) then + if(trim(interp_order) .eq. 'linear') then + my_interp_order = 1 + else if(trim(interp_order) .eq. 'quadratic') then + my_interp_order = 2 + else if(trim(interp_order) .eq. 'cubic') then + my_interp_order = 3 + else + call System_Abort("Invalid interpolation order `"//interp_order//"'in Adjustable_Potential_Force") + end if + end if + + force = 0.0_dp + + if(present(energy)) energy = 0.0_dp + if(present(power)) power = 0.0_dp + + do i=1,twobody%N + + fi = twobody%int(1,i) + fj = twobody%int(2,i) + shift = twobody%int(3:5,i) + + a1 = atomlist%int(1,fi) + a2 = atomlist%int(1,fj) + r = distance(atoms_in, a1, a2, shift) + + if(interpolate) then + if(do_interp_space) then + interp_point = (r - twobody_old%real(1,i))/(twobody%real(1,i)-twobody_old%real(1,i)) + fij = linear_interpolate(0.0_dp,twobody_old%real(2,i),& ! x0,y0 + 1.0_dp,twobody%real(2,i),interp_point) !x1, y1, x + else + select case(my_interp_order) + case(1) ! linear interpolation + fij = linear_interpolate(0.0_dp,twobody_old%real(2,i),& ! x0,y0 + 1.0_dp,twobody%real(2,i),interp) !x1, y1, x + + dalpha = (twobody%real(2,i) - twobody_old%real(2,i)) + case(2) ! quadratic using the derivative info at start point + fij = twobody_old%real(2,i)+interp*twobody_old%real(3,i)& + +interp*interp*(twobody%real(2,i)-twobody_old%real(2,i)-twobody_old%real(3,i)) + + dalpha = 0.0_dp + case(3) ! cubic with zero derivatives at endpoints + fij = cubic_interpolate(0.0_dp,twobody_old%real(2,i),& ! x0,y0 + 1.0_dp,twobody%real(2,i),interp) ! x1,y1, x + + dalpha = 0.0_dp + case default + call System_Abort("Invalid interpolation order in Adjustable_Potential_Force") + end select + end if + else + ! Extrapolate + fij = twobody%real(2,i) + dalpha = 0.0_dp ! Parameters don't change during extrap + end if + + ! optionally calculate energy and power + if(present(energy)) energy = energy + r*fij + if(present(power)) power = power + r*dalpha ! (since dV_dalpha = r, and dt = 1 here) + + if (value(mainlog%verbosity_stack) >= PRINT_NERD) & + call print(i//' '//a1//' '//a2//' '//r//' '//fij//' <-- SPRING', PRINT_NERD) + + ! get force + f = direction_cosines(atoms_in,a1,a2,shift)*fij + force(:,fi) = force(:,fi) + f + force(:,fj) = force(:,fj) - f + end do + + end subroutine adjustable_potential_force + + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_force_sparse(params) + !X + !X force from the adjustable potential, using the precomputed + !X sparse matrix + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + function adjustable_potential_force_sparse(params) result(force) + real(dp)::params(:) + real(dp)::force(size(target_force)) + + if(.not.adjustable_potential_initialised) & + call system_abort("adjustable_potential_force_sparse: not initialised!") + + force = (forcematrix .mult. params) + end function adjustable_potential_force_sparse + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_force_error(params) + !X + !X normsq() of difference between target and adjustable force + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + function adjustable_potential_force_error(params,data) result(error) + real(dp)::params(:) + character,optional :: data(:) + real(dp)::error + + if(.not.adjustable_potential_initialised) & + call system_abort("adjustable_potential_force_error: not initialised!") + + if(value(mainlog%verbosity_stack) .ge. PRINT_NERD) then + write(line, *) "adjustable_potential_force_error: params(", size(params), ")" + call print(line, PRINT_NERD) + call print(params, PRINT_NERD) + end if + + error = normsq(target_force - (forcematrix .mult. params)) + + end function adjustable_potential_force_error + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_force_error_deriv(params) + !X + !X derivative of the force_error wrt variable parameters + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + function adjustable_potential_force_error_deriv(params,data) result(deriv) + real(dp)::params(:) + character,optional :: data(:) + real(dp)::force(size(target_force)) + real(dp)::deriv(size(params)) + + if(.not.adjustable_potential_initialised) & + call system_abort("adjustable_potential_force_error_deriv: not initialised!") + + if(value(mainlog%verbosity_stack) .ge. PRINT_NERD) then + write(line, *) "adjustable_potential_force_error_deriv: params(", size(params), ")" + call print(line, PRINT_NERD) + call print(params, PRINT_NERD) + end if + + force = (forcematrix .mult. params) + deriv = (-2.0_dp * (target_force - force)) .mult. forcematrix + end function adjustable_potential_force_error_deriv + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_create_forcematrix() + !X + !X creates the sparse matrix forcematrix that we + !X use to compute the adjustable forces quickly for different + !X parameters, but unchanging atomic positions + !X + !X forcematrix has as many rows as the 3*number of atoms to be fitted + !X on, so same as size(target_force), and as many columns as the + !X number of adjustable parameters, so twobody%N*adjustable_potential_nparams + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + + subroutine adjustable_potential_create_forcematrix(atoms_in, precondition) + type(Atoms), intent(IN)::atoms_in + real(dp), intent(in) :: precondition(:) + + ! temporary hack to go via a full matrix. to be redone + real(dp), allocatable, dimension(:,:)::tmpmatrix + integer, parameter::nparams = adjustable_potential_nparams + integer::i, j, k, a1, a2, fi, fj, shift(3) + real(dp)::cosi(3) + integer, allocatable::colcounter(:), tmpcolumns(:,:) + + + write(line, *) "Setting up adjustable potential forcematrix.." ; call print(line, PRINT_VERBOSE) + write(line, *) ; call print(line, PRINT_VERBOSE) + + allocate(tmpmatrix(size(target_force), twobody%N*nparams)) + allocate(colcounter(size(target_force))) + allocate(tmpcolumns(size(target_force), twobody%N*nparams)) + tmpmatrix = 0.0_dp + colcounter = 0 + tmpcolumns = 0 + + ! loop through the springs + do i=1,twobody%N + ! we take and cache the distance from atoms_in, as it might have changed since time + ! we initialised the twobody table + fi = twobody%int(1,i) + fj = twobody%int(2,i) + shift = twobody%int(3:5,i) + a1 = atomlist%int(1,fi) + a2 = atomlist%int(1,fj) + + twobody%real(1,i) = distance(atoms_in, a1, a2, shift) + cosi = direction_cosines(atoms_in, a1, a2, shift) + + fi = (twobody%int(1,i)-1) ! subtract 1 so we can use it as index + do k=1,3 + colcounter(fi*3+k) = colcounter(fi*3+k) + 1 + ! Multiply by preconditioning factor for this spring + tmpmatrix (fi*3+k, colcounter(fi*3+k)) = cosi(k)*precondition(i) + tmpcolumns(fi*3+k, colcounter(fi*3+k)) = (i-1)*nparams+1 + end do + fj = (twobody%int(2,i)-1) ! subtract 1 so we can use it as index + do k=1,3 + colcounter(fj*3+k) = colcounter(fj*3+k) + 1 + ! Multiply by preconditioning factor for this spring + tmpmatrix (fj*3+k, colcounter(fj*3+k)) = -cosi(k)*precondition(i) + tmpcolumns(fj*3+k, colcounter(fj*3+k)) = (i-1)*nparams+1 + end do + end do ! i=1,twobody%N + + + ! fill in sparse matrix from values in tmpmatrix and tmpcolumns + call sparse_init(forcematrix, size(target_force), twobody%N*nparams) + do i=1,size(target_force) + forcematrix%rows(i) = forcematrix%table%N+1 + do j=1,colcounter(i) + call append(forcematrix%table, tmpcolumns(i,j), tmpmatrix(i,j)) + end do + end do + ! put in last row value + forcematrix%rows(i) = forcematrix%table%N+1 + + deallocate(tmpmatrix) + deallocate(tmpcolumns) + deallocate(colcounter) + + ! print it + if(value(mainlog%verbosity_stack) .ge. PRINT_NERD) then + call print('Forcematrix:',PRINT_NERD) + call print(forcematrix, PRINT_NERD) + call print('',PRINT_NERD) + end if + end subroutine adjustable_potential_create_forcematrix + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_optimise() + !X + !X the whole point of this module: vary the adjustable parameters + !X to minimize the force_error() + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine adjustable_potential_optimise(atoms_in, fitforce, fromscratch, method, prec_func, parallel_svd) + type(Atoms), intent(in):: atoms_in + real(dp), dimension(:,:), intent(in):: fitforce + logical, optional :: fromscratch + + logical :: do_fromscratch + character(len=*),optional,intent(in):: method + logical, optional, intent(in) :: parallel_svd + logical::do_svd, do_parallel_svd + integer, parameter::nparam = adjustable_potential_nparams + integer::nparamtot, bad_spring + real(dp), allocatable::params(:) + integer::steps, i, shift(3), k + real(dp):: err, ferr(3, atomlist%N) + real(dp), parameter::eigenvalue_threshold=1e-10_dp + real(dp), allocatable::full_forcematrix(:,:), X(:,:), S(:), WORK(:), precondition(:) + integer::LWORK, INFO, maxmn, minmn, M,N, RANK, a1, a2, error_code + optional :: prec_func + + interface + function prec_func(r) + use System_module + real(dp), intent(in) :: r + real(dp) :: prec_func + end function prec_func + end interface + + if(twobody%N == 0) then + call print("There are no parameters to optimise") + return + end if + + do_fromscratch = .true. + if(present(fromscratch)) do_fromscratch = fromscratch + + do_svd = .true. + if(present(method)) then + if(trim(method) .eq. "SVD") then + do_svd = .true. + else if(trim(method) .eq. "minim") then + do_svd = .false. + else + call system_abort("Adjustable_potential_optimise: invalid method '" // trim(method) // "'") + end if + end if + + !If the chosen method is SVD then the default is to run serially to + !avoid memory bottlenecks when all processors do SVD. + do_parallel_svd = optional_default(.false.,parallel_svd) + + if(size(target_force) /= size(fitforce)) & + call system_abort("adjustable_potential_optimise: target force is wrong size") + + ! Calculate preconditioning factors for each spring + allocate(precondition(twobody%N)) + if (present(prec_func)) then + do i=1,twobody%N + a1 = atomlist%int(1,twobody%int(1,i)) + a2 = atomlist%int(1,twobody%int(2,i)) + shift = twobody%int(3:5,i) + precondition(i) = prec_func(distance(atoms_in, a1, a2, shift)) + end do + else + precondition = 1.0_dp + end if + + ! create matrices for fast evaluation + call adjustable_potential_create_forcematrix(atoms_in, precondition) + + + target_force = reshape(fitforce, (/size(target_force)/)) + + nparamtot = twobody%N*nparam + allocate(params(nparamtot)) + + if(.not.adjustable_potential_initialised) & + call system_abort("adjustable_potential_optimise: not initialised!") + + call print("Target force:", PRINT_NERD) + call print(target_force, PRINT_NERD) + + call print('Optimising '//nparamtot//' adjustable parameters') + call print("RMS force component error before optimisation : "// & + sqrt(normsq(target_force)/(real(atomlist%N,dp)*3.0_dp))) + call print("Max force component error before optimisation : "//& + maxval(abs(target_force))) + + if(do_fromscratch) then + params = 0.0_dp + else + params = reshape(twobody%real(2:1+nparam,1:twobody%N), (/nparamtot/)) + endif + + if(do_svd) then + +#ifdef _MPI + + if (do_parallel_svd .or. mpi_id()==0) then + +#endif + + ! Solution by SVD + call print('Using SVD for least squares fit, eigenvalue threshold = '//eigenvalue_threshold) + allocate(full_forcematrix(size(target_force), size(params))) + full_forcematrix = forcematrix + M = size(full_forcematrix,1) + N = size(full_forcematrix,2) + minmn = minval((/M,N/)) + maxmn = maxval((/M,N/)) + allocate(X(maxmn,1)) + allocate(S(minmn)) + + allocate(WORK(1)) + + X(1:M,1) = target_force + + ! Do a workspace query first + call dgelss(M, N, 1, full_forcematrix, M, X,maxmn,S, eigenvalue_threshold, RANK, WORK, -1, INFO ) + + ! Allocate optimal size workspace + LWORK = WORK(1) + deallocate(WORK) + allocate(WORK(LWORK)) + + ! Do the SVD + call dgelss(M, N, 1, full_forcematrix, M, X,maxmn,S, eigenvalue_threshold, RANK, WORK, LWORK, INFO ) + + if (INFO /= 0) then + call system_abort('adjustable_potential_optimise: DGELSS failed with error code '//INFO) + end if + + params = X(1:N,1) + deallocate(WORK) + deallocate(S) + deallocate(X) + deallocate(full_forcematrix) + +#ifdef _MPI + + endif + + !Broadcast the params to each process if SVD only done on proc 0 + if (.not.do_parallel_svd) then + call MPI_BCAST(params,size(params),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,error_code) + !check for errors + call abort_on_mpi_error(error_code, "Adjustable_Potentia_Optimise: Params MPI_Bcast()") + end if + +#endif + + else + !! Solution by minimisation + steps = minim(params,& + adjustable_potential_force_error, & + adjustable_potential_force_error_deriv,& + "cg",1e-10_dp,1000,"FAST_LINMIN") + end if + + + ! compute RMS after optimisation + err = sqrt(adjustable_potential_force_error(params)/(real(atomlist%N,dp)*3.0_dp)) + + ! Print all magnitudes of force errors if we're a NERD + call print('Force errors', PRINT_NERD) + ferr = reshape(target_force - (forcematrix .mult. params), & + (/3, atomlist%N/)) + +!!$ call print('sparse force=') +!!$ call Print(forcematrix .mult. params) +!!$ call print('') + + do i=1,atomlist%N + write (line, '(i4,f12.6)') i, sqrt(normsq(ferr(:,i))) + call print(line, PRINT_NERD) + end do + call Print('', PRINT_NERD) + + write(line, '(a,e10.2)') "RMS force component error after optimisation : ", err + call print(line) + write(line, '(a,e10.2)') "Max force component error after optimisation : ", & + maxval(abs(target_force - (forcematrix .mult. params))) + call print(line) + + if (value(mainlog%verbosity_stack) >= PRINT_NERD) then + call Print('Final Springs:', PRINT_NERD) + do i=1,twobody%N + write (line, '(3i8,4f16.8)') i, atomlist%int(1,twobody%int(1,i)), atomlist%int(1,twobody%int(2,i)), twobody%real(1,i), precondition(i), params(i), params(i)*precondition(i) + call Print(line, PRINT_NERD) + end do + call Print('', PRINT_NERD) + end if + + ! Get physical spring constants by multiplying by precondition factor + do i=1,twobody%N + params(i) = params(i)*precondition(i) + end do + + twobody%real(2:1+nparam,1:twobody%N) = reshape(params, (/nparam,twobody%N/)) + + write(line, '(a,e10.2)') "Max abs spring constant after optimisation : ", maxval(abs(params)) + call print(line) + + if (maxval(abs(params)) > adjustable_potential_max_spring_constant) then + write(line, '(a,f10.2)') "WARNING: Max spring constant value after optimisation is large : ", & + maxval(abs(params)) + call print(line) + bad_spring = maxloc(abs(params),1) + write(line,'(2(a,i0))')' Max spring constant belongs to spring ', & + atomlist%int(1,twobody%int(1,bad_spring)),'--',atomlist%int(1,twobody%int(2,bad_spring)) + call print(line) + end if + + call print('') + + deallocate(params) + deallocate(precondition) + + ! calculate new parameter derivatives + do i=1,min(twobody%N,twobody_old%N) + do k=1,nparam + twobody%real(1+nparam+k,i) = twobody_old%real(1+nparam+k, i)+2.0_dp*(twobody%real(1+k,i)-twobody_old%real(1+k,i)-twobody_old%real(1+nparam+k,i)) + end do + end do + + ! Save the old fit force + if (allocated(fitforce_old)) deallocate(fitforce_old) + allocate(fitforce_old(size(fitforce,1),size(fitforce,2))) + fitforce_old = fitforce + + end subroutine adjustable_potential_optimise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X adjustable_potential_print_params() + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine adjustable_potential_print_params() + real(dp)::f(size(target_force)) + integer::np + + if(.not.adjustable_potential_initialised) & + call system_abort("adjustable_potential_print_params: not initialised!") + + + write(line,*) "Atoms Shift Parameters" ; call print(line) + write(line,*) "-----------------------------------------------------" + call print(line) + call print(twobody) + write(line, *) ; call print(line) + + + write(line, *) "Force matrix: " ; call print(line) + write(line, *) ; call print(line) + call print_full(forcematrix) + write(line, *) ; call print(line) + + write(line,*) "Forces from force matrix:" ; call print( line) + np = twobody%N*adjustable_potential_nparams + f = adjustable_potential_force_sparse(reshape(twobody%real(2:1+adjustable_potential_nparams,1:twobody%N), (/np/))) + call print(transpose(reshape(f, (/3,atomlist%N/)))) + write(line, *) ; call print(line) + + end subroutine adjustable_potential_print_params + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Set up, alter and query the exclusion list + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine adjustable_potential_add_exclusion(atom1,atom2,shift) + + integer, intent(in) :: atom1,atom2,shift(3) + + if (atom1 == atom2) then + call print_message('WARNING', 'Adjustable_Potential_Add_Exclusion: Atom1 = Atom2') + return + end if + + if (.not.exclusions) then !Set up the exclusion table + call allocate(exclusion_list,5,0,0,0) + exclusions = .true. + end if + + !Append (/a, b, shift/) where a < b + if (atom1 < atom2) then + call append(exclusion_list,(/atom1,atom2,shift/)) + else + call append(exclusion_list,(/atom2,atom1,-shift/)) + end if + + end subroutine adjustable_potential_add_exclusion + + subroutine adjustable_potential_delete_exclusion(atom1,atom2,shift) + + integer, intent(in) :: atom1, atom2, shift(3) + + if (atom1 < atom2) then + call delete(exclusion_list,(/atom1,atom2,shift/)) + else + call delete(exclusion_list,(/atom2,atom1,-shift/)) + end if + + if (exclusion_list%N == 0) then + call finalise(exclusion_list) + exclusions = .false. + end if + + end subroutine adjustable_potential_delete_exclusion + + function is_excluded(atom1,atom2, shift) + + integer, intent(in) :: atom1, atom2, shift(3) + logical :: Is_Excluded + + if (atom1 < atom2) then + if (find(exclusion_list,(/atom1,atom2,shift/))==0) then + Is_Excluded = .false. + else + Is_Excluded = .true. + end if + else + if (find(exclusion_list,(/atom2,atom1,-shift/))==0) then + Is_Excluded = .false. + else + Is_Excluded = .true. + end if + + end if + + end function is_excluded + +end module AdjustablePotential_module + diff --git a/src/Potentials/ApproxFermi.F90 b/src/Potentials/ApproxFermi.F90 new file mode 100644 index 0000000000..c8f51269fb --- /dev/null +++ b/src/Potentials/ApproxFermi.F90 @@ -0,0 +1,293 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X ApproxFermi module +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +module ApproxFermi_module + +use System_module +use linearalgebra_module ! for .feq. +use Units_module +use Functions_module + +implicit none + +private + +public :: ApproxFermi +type ApproxFermi + integer :: n_poles = 0 + complex(dp), allocatable :: a(:), z(:) + real(dp) :: Fermi_E, band_width +end type ApproxFermi + +public :: Initialise +interface Initialise + module procedure ApproxFermi_Initialise, ApproxFermi_Initialise_lowlevel +end interface Initialise + +public :: Finalise +interface Finalise + module procedure ApproxFermi_Finalise +end interface Finalise + +public :: Wipe +interface Wipe + module procedure ApproxFermi_Wipe +end interface Wipe + +public :: Print +interface Print + module procedure ApproxFermi_Print +end interface Print + +public :: approx_f_fermi, approx_f_fermi_deriv + +contains + +subroutine ApproxFermi_Finalise(this) + type(ApproxFermi), intent(inout) :: this + + call Wipe(this) + +end subroutine + +subroutine ApproxFermi_Wipe(this) + type(ApproxFermi), intent(inout) :: this + + if (allocated(this%a)) deallocate(this%a) + if (allocated(this%z)) deallocate(this%z) + this%n_poles = 0 + +end subroutine + +subroutine ApproxFermi_Print(this,out) + type(ApproxFermi), intent(in) :: this + type(Inoutput), intent(inout),optional:: out + + integer::i + + call Print('ApproxFermi: Fermi_E ' // this%Fermi_E // ' band_width ' // this%band_width // ' n_poles ' // this%n_poles, file=out) + + if (this%n_poles > 0) then + do i=1, size(this%a) + call Print ('GreensFunc : a z ' // i // ' ' // this%a(i) // ' ' // this%z(i), PRINT_VERBOSE, out) + end do + endif + +end subroutine ApproxFermi_Print + +subroutine ApproxFermi_Initialise(this, Fermi_E, Fermi_T, band_width) + type(ApproxFermi), intent(inout) :: this + real(dp), intent(in) :: Fermi_E, Fermi_T, band_width + + call Finalise(this) + + call calc_poles_from_T(this, Fermi_E, Fermi_T, band_width) + +end subroutine + +subroutine ApproxFermi_Initialise_lowlevel(this, n_poles, Fermi_E, band_width) + type(ApproxFermi), intent(inout) :: this + integer, intent(in) :: n_poles + real(dp), intent(in) :: Fermi_E, band_width + + call calc_poles(this, Fermi_E, n_poles, band_width) + +end subroutine + +subroutine calc_poles(this, Fermi_E, n_poles, band_width) + type(ApproxFermi), intent(inout) :: this + real(dp), intent(in) :: Fermi_E, band_width + integer, intent(in) :: n_poles + + if (n_poles == 0 .or. (band_width .feq. 0.0_dp)) then + call system_abort("Can't calc_poles with n_poles or band_width = 0") + endif + + this%Fermi_E = Fermi_E + this%n_poles = n_poles + this%band_width = band_width + + if (allocated(this%a)) then + if (size(this%a) /= this%n_poles) deallocate(this%a) + endif + if (allocated(this%z)) then + if (size(this%z) /= this%n_poles) deallocate(this%z) + endif + + if (.not.allocated(this%z)) allocate(this%z(this%n_poles)) + if (.not.allocated(this%a)) allocate(this%a(this%n_poles)) + + call calc_pole_values(this) + +end subroutine calc_poles + +subroutine calc_poles_from_T(this, Fermi_E, Fermi_T, band_width) + type(ApproxFermi), intent(inout) :: this + real(dp), intent(in) :: Fermi_E, Fermi_T, band_width + + if (band_width .feq. 0.0_dp) then + call system_abort("Can't calc_poles_from_T with band_width = 0") + endif + + this%n_poles = guess_n_poles(Fermi_T, band_width, this%band_width) + + call calc_poles(this, Fermi_E, this%n_poles, this%band_width) + +end subroutine calc_poles_from_T + +function guess_n_poles(Fermi_T, band_width_in, band_width) + real(dp), intent(in) :: Fermi_T, band_width_in + real(dp), intent(out) :: band_width + integer :: guess_n_poles + + type(ApproxFermi) t_AF + real(dp) :: Fermi_slope, AF_slope + integer np + + Fermi_slope = f_Fermi_deriv(0.0_dp, Fermi_T, 0.0_dp) + + do np=4, 1000, 4 + call Initialise(t_AF, np, 0.0_dp, band_width_in) + AF_slope = approx_f_Fermi_deriv(t_AF, 0.0_dp) + if (AF_slope < Fermi_slope) then + guess_n_poles = np + band_width = band_width_in*(AF_slope/Fermi_slope) + return + endif + call Finalise(t_AF) + end do + + call system_abort ("Couldn't find appropriate band_width and n_poles in guess_n_poles") + +end function guess_n_poles + +elemental function approx_f_Fermi(this, E) + type(ApproxFermi), intent(in) :: this + real(dp), intent(in) :: E + real(dp) :: approx_f_Fermi + + integer i + + approx_f_Fermi = 0.0_dp + do i=1, this%n_poles + approx_f_Fermi = approx_f_Fermi + this%a(i)/(E-this%z(i)) + end do + +end function approx_f_Fermi + +elemental function approx_f_Fermi_deriv(this, E) + type(ApproxFermi), intent(in) :: this + real(dp), intent(in) :: E + real(dp) :: approx_f_Fermi_deriv + + integer i + + approx_f_Fermi_deriv = 0.0_dp + do i=1, this%n_poles + approx_f_Fermi_deriv = approx_f_Fermi_deriv - this%a(i)/((E-this%z(i))**2) + end do + +end function approx_f_Fermi_deriv + +subroutine calc_pole_values(this) + type(ApproxFermi), intent(inout) :: this + + integer :: n_poles + real(dp) :: n_poles_d + + complex(dp) :: a, b, c, aa, bb, cc, x + integer i, j + real(dp) i_d + + real(dp) :: gamma, x_bot, scale, shift + ! real(dp) :: f_max + + n_poles = this%n_poles * 2 + n_poles_d = n_poles + + gamma = 3.0_dp-sqrt(8.0_dp) + ! f_max = 1.0_dp/( ((4.0_dp*((1.0_dp-gamma)**-2) - 1.0_dp)**(n_poles_d/2)) + 1.0_dp ) + x_bot = -4.0_dp*(2.0_dp*n_poles_d-12.0_dp+6.0_dp*gamma)/((1.0_dp+gamma)**2) + + do i=1, this%n_poles/2 + i_d = i-1 + a = (1.0_dp + gamma) / (2.0_dp*n_poles_d) + b = (1.0_dp - gamma) / (n_poles_d) + c = cmplx( cos(PI/(n_poles_d/2.0_dp) + i_d*PI/(n_poles_d/4.0_dp)), & + sin(PI/(n_poles_d/2.0_dp) + i_d*PI/(n_poles_d/4.0_dp)), dp ) + + aa = a*a + bb = (2.0_dp*a + b*c) + cc = (1.0_dp-c) + + this%z(i) = conjg ( (-bb - sqrt(bb*bb - 4.0_dp*aa*cc) ) / (2.0_dp * aa) ) + this%z(n_poles/2-i+1) = (-bb + sqrt(bb*bb - 4.0_dp*aa*cc) ) / (2.0_dp * aa) + end do + + do i=1, this%n_poles/2 + x = this%z(i) + this%z(i) = this%z(this%n_poles-i+1) + this%z(this%n_poles-i+1) = x + end do + + scale = -this%band_width/x_bot + shift = this%Fermi_E + + do i=1, this%n_poles + this%z(i) = this%z(i) * scale + shift + end do + + do i=1, this%n_poles + x = this%z(i) + + this%a(i) = (scale**(n_poles/2))*((1.0_dp-((x-shift)/scale)*(1.0_dp-gamma)/n_poles_d)**(n_poles/2)) + + do j=1, this%n_poles + if (j == i) then + this%a(i) = scale*(((n_poles_d*2.0_dp)/(1.0_dp+gamma))**2)*this%a(i) / & + (x-conjg(this%z(j))) + else + this%a(i) = scale*(((n_poles_d*2.0_dp)/(1.0_dp+gamma))**2)*this%a(i) / & + ( (x-this%z(j))*(x-conjg(this%z(j))) ) + endif + end do + + this%a(i) = this%a(i) * 2.0_dp + end do + +end subroutine + +end module ApproxFermi_module diff --git a/src/Potentials/CallbackPot.F90 b/src/Potentials/CallbackPot.F90 new file mode 100644 index 0000000000..66cebad88b --- /dev/null +++ b/src/Potentials/CallbackPot.F90 @@ -0,0 +1,310 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Callbackpot Module +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" +module Callbackpot_module + +use error_module +use system_module, only : dp, inoutput, print, current_verbosity, PRINT_NORMAL, operator(//) +use mpi_context_module +use dictionary_module +use paramreader_module +use atoms_types_module +use atoms_module + +implicit none +private + +integer, parameter :: MAX_CALLBACKS = 200 +integer :: n_callbacks = 0 + +public :: Callbackpot_type +type CallbackPot_type + character(len=STRING_LENGTH) :: init_args_str + character(len=STRING_LENGTH) :: label + integer :: callback_id + type(MPI_context) :: mpi +end type CallbackPot_type + +public :: Initialise +interface Initialise + module procedure Callbackpot_Initialise +end interface Initialise + +public :: Finalise +interface Finalise + module procedure Callbackpot_Finalise +end interface Finalise + +public :: cutoff +interface cutoff + module procedure Callbackpot_cutoff +end interface + +public :: Wipe +interface Wipe + module procedure Callbackpot_Wipe +end interface Wipe + +public :: Print +interface Print + module procedure Callbackpot_Print +end interface Print + +public :: calc +interface calc + module procedure Callbackpot_Calc +end interface + +public :: set_callback +interface set_callback + module procedure callbackpot_set_callback +end interface + + +interface + subroutine register_callbackpot_sub(sub) + interface + subroutine sub(at) + integer, intent(in) :: at(12) + end subroutine sub + end interface + end subroutine register_callbackpot_sub +end interface + +interface + subroutine call_callbackpot_sub(i,at) + integer, intent(in) :: at(12) + integer, intent(in) :: i + end subroutine call_callbackpot_sub +end interface + + +contains + + +subroutine Callbackpot_Initialise(this, args_str, mpi, error) + type(Callbackpot_type), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='CallbackPot_initialise')) then + RAISE_ERROR('CallbackPot_Initialise failed to parse args_str="'//trim(args_str)//"'", error) + endif + call finalise(params) + + this%init_args_str = args_str + if (present(mpi)) this%mpi = mpi + +end subroutine Callbackpot_Initialise + +subroutine callbackpot_set_callback(this, callback, error) + type(Callbackpot_type), intent(inout) :: this + interface + subroutine callback(at) + integer, intent(in) :: at(12) + end subroutine callback + end interface + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if (n_callbacks >= MAX_CALLBACKS) then + RAISE_ERROR('CallbackPot_Initialise: Too many registered callback routines', error) + endif + this%callback_id = n_callbacks + n_callbacks = n_callbacks + 1 + call register_callbackpot_sub(callback) + +end subroutine Callbackpot_Set_callback + +subroutine Callbackpot_Finalise(this) + type(Callbackpot_type), intent(inout) :: this + + call wipe(this) + +end subroutine Callbackpot_Finalise + +subroutine Callbackpot_Wipe(this) + type(Callbackpot_type), intent(inout) :: this + + this%callback_id = -1 + +end subroutine Callbackpot_Wipe + +function Callbackpot_cutoff(this) + type(Callbackpot_type), intent(in) :: this + real(dp) :: Callbackpot_cutoff + Callbackpot_cutoff = 0.0_dp ! return zero, because Callbackpot does its own connection calculation +end function Callbackpot_cutoff + +subroutine Callbackpot_Print(this, file) + type(Callbackpot_type), intent(in) :: this + type(Inoutput), intent(inout),optional,target:: file + + if (current_verbosity() < PRINT_NORMAL) return + + call print("Callbackpot: callback_id="//this%callback_id) + call print("Callbackpot: label="//this%label) + +end subroutine Callbackpot_Print + +subroutine Callbackpot_Calc(this, at, energy, local_e, forces, virial, local_virial, args_str, error) + type atoms_ptr_type + type(atoms), pointer :: p + end type atoms_ptr_type + type(Callbackpot_type), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: energy + real(dp), intent(out), target, optional :: local_e(:) + real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) + real(dp), intent(out), optional :: virial(3,3) + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + type(Atoms), target :: at_copy + type(atoms_ptr_type) :: at_ptr + integer :: at_ptr_i(12) + real(dp), pointer :: local_e_ptr(:), force_ptr(:,:), local_virial_ptr(:,:) + logical :: calc_energy, calc_local_e, calc_force, calc_virial, calc_local_virial + + INIT_ERROR(error) + + calc_energy = .false. + calc_local_e = .false. + calc_force = .false. + calc_virial = .false. + calc_local_virial = .false. + if (present(energy)) then + energy = 0.0_dp + calc_energy = .true. + end if + if (present(local_e)) then + local_e = 0.0_dp + calc_local_e = .true. + end if + if (present(forces)) then + forces = 0.0_dp + calc_force = .true. + end if + if (present(virial)) then + virial = 0.0_dp + calc_virial = .true. + end if + if (present(local_virial)) then + local_virial = 0.0_dp + calc_local_virial = .true. + end if + + if (this%callback_id < 0) then + RAISE_ERROR('callbackpot_calc: callback_id < 0', error) + endif + + at_copy = at + call set_value(at_copy%params, 'calc_energy', calc_energy) + call set_value(at_copy%params, 'calc_local_e', calc_local_e) + call set_value(at_copy%params, 'calc_virial', calc_virial) + call set_value(at_copy%params, 'calc_force', calc_force) + call set_value(at_copy%params, 'calc_local_virial', calc_local_virial) + call set_value(at_copy%params, 'callback_id', this%callback_id) + call set_value(at_copy%params, 'label', this%label) + if (present(args_str)) then + call set_value(at_copy%params, 'calc_args_str', args_str) + end if + + at_ptr%p => at_copy + at_ptr_i = transfer(at_ptr, at_ptr_i) + call call_callbackpot_sub(this%callback_id, at_ptr_i) + + if (present(energy)) then + if (.not. get_value(at_copy%params, 'energy', energy)) then + call print('WARNING Callbackpot_calc: "energy" requested but not returned by callback') + endif + end if + + if (present(local_e)) then + if (.not. assign_pointer(at_copy, 'local_e', local_e_ptr)) then + call print('WARNING Callbackpot_calc: "local_e" requested but not returned by callback') + else + local_e(:) = local_e_ptr + end if + end if + + if (present(forces)) then + if (.not. assign_pointer(at_copy, 'force', force_ptr)) then + call print('WARNING Callbackpot_calc: "forces" requested but not returned by callback') + else + forces(:,:) = force_ptr + end if + end if + + if (present(virial)) then + if (.not. get_value(at_copy%params, 'virial', virial)) then + call print('WARNING Callbackpot_calc: "virial" requested but not returned by callback') + end if + end if + + if (present(local_virial)) then + if (.not. assign_pointer(at_copy, 'local_virial', local_virial_ptr)) then + call print('WARNING Callbackpot_calc: "local_virial" requested but not returned by callback') + else + local_virial(:,:) = local_virial_ptr + end if + end if + + if (this%mpi%active) then + ! Share results with other nodes + if (present(energy)) call bcast(this%mpi, energy) + if (present(local_e)) call bcast(this%mpi, local_e) + + if (present(forces)) call bcast(this%mpi, forces) + if (present(virial)) call bcast(this%mpi, virial) + if (present(local_virial)) call bcast(this%mpi, local_virial) + end if + + call finalise(at_copy) + +end subroutine Callbackpot_calc + +end module Callbackpot_module diff --git a/src/Potentials/ElectrostaticEmbed.F90 b/src/Potentials/ElectrostaticEmbed.F90 new file mode 100644 index 0000000000..a0d5de2d50 --- /dev/null +++ b/src/Potentials/ElectrostaticEmbed.F90 @@ -0,0 +1,544 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!% ElectrostaticEmbed - tools for electrostatic embedding of potentials + +#include "error.inc" + +module ElectrostaticEmbed_module + + use error_module + use system_module, only : dp, inoutput, optional_default, initialise, OUTPUT, operator(//), system_timer + use units_module + use periodictable_module + use linearalgebra_module + use dictionary_module + use connection_module + use atoms_types_module + use atoms_module + use clusters_module + + use QUIP_Common_module + use Functions_module + use Potential_module +#ifdef HAVE_THIRDPARTY + use cube_tools +#endif + + implicit none + private + + integer, private, parameter :: nspins = 2 + + public :: extent_to_ngrid, assign_grid_coordinates, calc_electrostatic_potential, & +#ifdef HAVE_THIRDPARTY + write_electrostatic_potential_cube, & +#endif + make_periodic_potential + +contains + + subroutine extent_to_ngrid(extent, fine_gmax, ngrid) + real(dp), intent(in) :: extent(3), fine_gmax + integer, intent(out) :: ngrid(3) + + integer i + + do i=1,3 + ngrid(i) = ceiling(fine_gmax*extent(i)/BOHR/PI) + call round_prime_factors(ngrid(i)) + end do + + end subroutine extent_to_ngrid + + subroutine assign_grid_coordinates(ngrid, origin, extent, grid_size, r_real_grid) + integer, intent(in) :: ngrid(3) + real(dp), intent(in) :: origin(3), extent(3) + real(dp), intent(out) :: grid_size(3) + real(dp), dimension(:,:), intent(out) :: r_real_grid + + real(dp) :: lattice(3,3) + integer :: nx, ny, nz, point + + lattice(:,:) = 0.0_dp + lattice(1,1) = extent(1) + lattice(2,2) = extent(2) + lattice(3,3) = extent(3) + + point = 0 + do nz=1,ngrid(3) + do ny=1,ngrid(2) + do nx=1,ngrid(1) + + point=point+1 + + r_real_grid(1,point) = real(nx-1,dp)*lattice(1,1)/real(ngrid(1),dp) +& + & real(ny-1,dp)*lattice(2,1)/real(ngrid(2),dp) +& + & real(nz-1,dp)*lattice(3,1)/real(ngrid(3),dp) + origin(1) + r_real_grid(2,point) = real(nx-1,dp)*lattice(1,2)/real(ngrid(1),dp) +& + & real(ny-1,dp)*lattice(2,2)/real(ngrid(2),dp) +& + & real(nz-1,dp)*lattice(3,2)/real(ngrid(3),dp) + origin(2) + r_real_grid(3,point) = real(nx-1,dp)*lattice(1,3)/real(ngrid(1),dp) +& + & real(ny-1,dp)*lattice(2,3)/real(ngrid(2),dp) +& + & real(nz-1,dp)*lattice(3,3)/real(ngrid(3),dp) + origin(3) + + end do + end do + end do + + grid_size(1) = extent(1)/real(ngrid(1), dp) + grid_size(2) = extent(2)/real(ngrid(2), dp) + grid_size(3) = extent(3)/real(ngrid(3), dp) + + end subroutine assign_grid_coordinates + +#ifdef HAVE_THIRDPARTY + subroutine write_electrostatic_potential_cube(at, filename, ngrid, origin, extent, pot, & + write_efield, flip_sign, convert_to_atomic_units, error) + type(Atoms), intent(inout) :: at + character(len=*), intent(in) :: filename + integer, intent(in) :: ngrid(3) + real(dp), intent(in) :: origin(3), extent(3) + real(dp), dimension(:,:,:), intent(in) :: pot + logical, optional, intent(in) :: write_efield, flip_sign, convert_to_atomic_units + integer, optional, intent(out) :: error + + type(InOutput) :: out + type(cube_type) :: cube + type(Dictionary) :: metadata + integer i, j, n, z!, na, nb, nc + real(dp), pointer, dimension(:) :: charge, es_pot + real(dp), pointer, dimension(:,:) :: es_efield + integer, dimension(size(ElementMass)) :: nsp + logical do_efield, do_atomic_units, do_flip_sign + + INIT_ERROR(error) + + do_efield = optional_default(.true., write_efield) + do_flip_sign = optional_default(.false., flip_sign) + do_atomic_units = optional_default(.true., convert_to_atomic_units) + + if (do_efield) then + call assign_property_pointer(at, 'es_pot', es_pot, error) + PASS_ERROR(error) + + call assign_property_pointer(at, 'es_efield', es_efield, error) + PASS_ERROR(error) + else + call assign_property_pointer(at, 'charge', charge, error) + PASS_ERROR(error) + end if + + call cube_clear(cube) + cube%comment1 = trim(filename) + cube%N = at%n + cube%r0 = real(origin) + cube%na = ngrid(1)+1 + cube%nb = ngrid(2)+1 + cube%nc = ngrid(3)+1 + + ! Size of voxels + cube%da = 0.0_dp; cube%da(1) = real(extent(1)/ngrid(1)) + cube%db = 0.0_dp; cube%db(2) = real(extent(2)/ngrid(2)) + cube%dc = 0.0_dp; cube%dc(3) = real(extent(3)/ngrid(3)) + + ! We sort atoms by atomic number for compatibility with CASTEP + + ! Count number of each species + nsp(:) = 0 + do i=1,at%n + nsp(at%z(i)) = nsp(at%z(i)) + 1 + end do + + ! Fill in atomic information + allocate(cube%atoms(cube%n)) + n = 0 + do z = 1,size(nsp) + if (nsp(z) == 0) cycle + + do j=1,at%n + if (at%z(j) /= z) cycle + + n = n + 1 + cube%atoms(n)%number = at%z(j) + if (do_efield) then + ! Potential on ions and electric field + cube%atoms(n)%unknown = real(es_pot(j)) + if (do_flip_sign) cube%atoms(n)%unknown = -cube%atoms(n)%unknown + cube%atoms(n)%r(:) = real(es_efield(:,j)) + if (do_flip_sign) cube%atoms(n)%r = -cube%atoms(n)%r + else + ! Charge and position of ions + cube%atoms(n)%unknown = real(charge(j)) + cube%atoms(n)%r(:) = real(at%pos(:,j)) + end if + end do + end do + + ! Fill in volumetric information - note conversion to single precision + cube%NMOs=1 + allocate(cube%voxels(cube%na,cube%nb,cube%nc,cube%NMOs)) + cube%voxels(1:cube%na-1,1:cube%nb-1,1:cube%nc-1,1) = real(pot) + + ! periodic boundary conditions: in cube file format, values of + ! n{a,b,c}=1 entries are repeated at n{a,b,c} = cube%n{a,b,c} + cube%voxels(cube%na,:,:,1) = real(cube%voxels(1,:,:,1)) + cube%voxels(:,cube%nb,:,1) = real(cube%voxels(:,1,:,1)) + cube%voxels(:,:,cube%nc,1) = real(cube%voxels(:,:,1,1)) + + if (do_flip_sign) cube%voxels = -cube%voxels + + if (do_atomic_units) then + cube%da = cube%da/BOHR + cube%db = cube%db/BOHR + cube%dc = cube%dc/BOHR + cube%r0 = cube%r0/BOHR + cube%voxels = cube%voxels/HARTREE ! convert potential to Hartree + if (do_efield) then + ! convert potential and electric field to atomic units + do n=1,cube%n + cube%atoms(n)%unknown = cube%atoms(n)%unknown/HARTREE + cube%atoms(n)%r(:) = cube%atoms(n)%r(:)/(HARTREE/BOHR) + end do + else + ! convert positions to bohr + do n=1,cube%n + cube%atoms(n)%r = cube%atoms(n)%r/BOHR + end do + end if + end if + + ! Write meta-data into second line of .cube file + call initialise(metadata) + call set_value(metadata, 'volumetric_data', 'electrostatic_potential') + if (do_atomic_units) then + call set_value(metadata, 'units', 'atomic') + else + call set_value(metadata, 'units', 'eV_A_fs') + end if + if (do_efield) then + call set_value(metadata, 'atom_data', 'z:pot:efield') + else + call set_value(metadata, 'atom_data', 'z:charge:pos') + end if + cube%comment2 = write_string(metadata) + call finalise(metadata) + + call initialise(out, filename, OUTPUT) + call cube_write(cube, out%unit, error) + PASS_ERROR(error) + call finalise(out) + deallocate(cube%atoms) + deallocate(cube%voxels) + + end subroutine write_electrostatic_potential_cube +#endif + + subroutine make_periodic_potential(at, real_grid, ngrid, is_periodic, cutoff_radius, cutoff_width, mark_name, pot, error) + type(Atoms), intent(inout) :: at + real(dp), dimension(:,:), intent(in) :: real_grid + integer, intent(in) :: ngrid(3) + logical, intent(in) :: is_periodic(3) + real(dp), intent(in) :: cutoff_radius, cutoff_width + character(len=*), intent(in) :: mark_name + real(dp), intent(inout) :: pot(:,:,:) + integer, optional, intent(out) :: error + + integer i,j,k,a,igrid, nsurface, cell_image_Na, cell_image_Nb, cell_image_Nc + logical save_is_periodic(3), dir_mask(3) + real(dp) :: cutoff, surface_avg, d(3), fc, dfc, masked_d + logical, dimension(:), allocatable :: atom_mask + integer, pointer, dimension(:) :: mark + + INIT_ERROR(error) + + call print('is_periodic = '//is_periodic) + save_is_periodic = at%is_periodic + at%is_periodic = is_periodic + dir_mask = .not. is_periodic + call calc_connect(at) + call print('at%is_periodic = '//at%is_periodic//' dir_mask='//dir_mask) + + ! Calculate average value of potential on open surfaces + nsurface = 0 + surface_avg = 0.0_dp + if (dir_mask(1)) then + surface_avg = surface_avg + sum(pot(1,:,:)) + sum(pot(ngrid(1),:,:)) + nsurface = nsurface + 2*ngrid(2)*ngrid(3) + end if + if (dir_mask(2)) then + surface_avg = surface_avg + sum(pot(:,1,:)) + sum(pot(:,ngrid(2),:)) + nsurface = nsurface + 2*ngrid(1)*ngrid(3) + end if + if (dir_mask(3)) then + surface_avg = surface_avg + sum(pot(:,:,1)) + sum(pot(:,:,ngrid(3))) + nsurface = nsurface + 2*ngrid(1)*ngrid(2) + end if + surface_avg = surface_avg/nsurface + + if (.not. assign_pointer(at, mark_name, mark)) then + RAISE_ERROR('make_periodic_potential: failed to assign pointer to "'//trim(mark_name)//'" property', error) + end if + allocate(atom_mask(at%n)) + atom_mask = mark /= HYBRID_ELECTROSTATIC_MARK + + call fit_box_in_cell(cutoff_radius+cutoff_width, cutoff_radius+cutoff_width, cutoff_radius+cutoff_width, & + at%lattice, cell_image_Na, cell_image_Nb, cell_image_Nc) + cell_image_Na = max(1,(cell_image_Na+1)/2) + cell_image_Nb = max(1,(cell_image_Nb+1)/2) + cell_image_Nc = max(1,(cell_image_Nc+1)/2) + + ! Smoothly interpolate potential to surface_avg away from atoms + igrid = 0 + do k=1,ngrid(3) + do j=1,ngrid(2) + do i=1,ngrid(1) + igrid = igrid + 1 + a = closest_atom(at, real_grid(:,igrid), cell_image_Na, cell_image_Nb, cell_image_Nc, mask=atom_mask, diff=d) + + ! project difference vector to mask out periodic directions + masked_d = norm(pack(d, dir_mask)) + + ! if this grid point is on an open surface, check we're at least cutoff_radius + cutoff_width away from closest atom + if (dir_mask(1) .and. i==1 .or. dir_mask(2) .and. j==1 .or. dir_mask(3) .and. k==1) then + if (masked_d < cutoff_radius+cutoff_width) then + RAISE_ERROR('atom '//a//' pos='//at%pos(:,a)//' too close to surface cell=['//i//' '//j//' '//k//'] pos=['//real_grid(:,igrid)//'] d='//masked_d, error) + end if + end if + + call smooth_cutoff(masked_d, cutoff_radius, cutoff_width, fc, dfc) + pot(i,j,k) = pot(i,j,k)*fc + surface_avg*(1.0_dp-fc) + end do + end do + end do + + ! restore periodic directions + at%is_periodic = save_is_periodic + call calc_connect(at) + + deallocate(atom_mask) + + end subroutine make_periodic_potential + + !% Evaluate electrostatic potential on a grid by adding test atoms at grid points + subroutine calc_electrostatic_potential(this, at, cluster, mark_name, ngrid, origin, extent, real_grid, pot, args_str, error) +#ifdef _OPENMP + use omp_lib +#endif + + type(Potential), intent(inout) :: this + type(Atoms), intent(in) :: at + type(Atoms), intent(inout) :: cluster + character(len=*), intent(in) :: args_str, mark_name + integer, intent(in) :: ngrid(3) + real(dp), intent(in) :: origin(3), extent(3) + real(dp), intent(inout) :: real_grid(:,:), pot(:,:,:) + integer, optional, intent(out) :: error + + type(Atoms) :: at_copy + type(Atoms), save :: private_at_copy + real(dp) :: grid_size(3), tmp_cutoff + real(dp), pointer :: at_charge(:), cluster_charge(:), cluster_es_pot(:), cluster_es_efield(:,:), es_pot(:), es_efield(:,:) + real(dp), allocatable :: local_e(:) + integer, pointer, dimension(:) :: mark + integer, allocatable, dimension(:) :: z + integer, allocatable, dimension(:,:) :: lookup + logical, pointer, dimension(:) :: atom_mask, source_mask + logical, allocatable, dimension(:) :: select_mask +#ifdef _OPENMP + logical old_nested +#endif + integer i, j, k, n, igrid, offset, stride, npoint, select_n + + !$omp threadprivate(private_at_copy) + + INIT_ERROR(error) + call system_timer('calc_electrostatic_potential') + + call assign_grid_coordinates(ngrid, origin, extent, grid_size, real_grid) + + + call assign_property_pointer(at, mark_name, mark, error) + PASS_ERROR(error) + + ! Make copy of atoms within cutoff distance of a marked atom + ! so we can add test atoms at grid points + +! allocate(select_mask(at%n)) +! tmp_cutoff = cutoff(this) +! select_mask = .false. +! do i=1,at%n +! dr = diff_min_image(at, at%pos(:,i), origin+extent/2.0_dp) +! if (all(abs(dr(:)) < extent/2.0_dp+tmp_cutoff)) select_mask(i) = .true. +! end do +! call select(at_copy, at, mask=select_mask) +! select_n = at_copy%n +! deallocate(select_mask) + + allocate(select_mask(at%n)) + tmp_cutoff = cutoff(this) + select_mask = .false. + do i=1,at%n + if (mark(i) == HYBRID_NO_MARK) cycle + select_mask(i) = .true. + do j=1,at%n + if (mark(j) /= HYBRID_NO_MARK) cycle + if (distance_min_image(at, i, j) < tmp_cutoff) select_mask(j) = .true. + end do + end do + call select(at_copy, at, mask=select_mask) + select_n = at_copy%n + + call assign_property_pointer(at_copy, mark_name, mark, error) + PASS_ERROR(error) + + call assign_property_pointer(at_copy, 'charge', at_charge, error) + PASS_ERROR(error) + + ! choose balance between number of evaluations and number of simulataneous grid points + npoint = select_n + stride = max(1,size(real_grid, 2)/npoint) + npoint = size(real_grid(:,1:size(real_grid,2):stride), 2) + call print('npoint = '//npoint//' stride = '//stride) + + allocate(z(npoint)) + z(:) = 0 + call add_atoms(at_copy, real_grid(:,1:size(real_grid,2):stride), z) + + ! added atoms so must reassign pointers + if (.not. assign_pointer(at_copy, mark_name, mark)) then + RAISE_ERROR('calc_electrostatic_potential_calc failed to assign pointer to "'//trim(mark_name)//'" property', error) + end if + if (.not. assign_pointer(at_copy, 'charge', at_charge)) then + RAISE_ERROR('calc_electrostatic_potential_calc failed to assign pointer to "charge" property', error) + endif + at_charge(select_n+1:at_copy%n) = 1.0_dp + + ! atom_mask is true for atoms for which we want the local potential energy, i.e grid point atoms + call add_property(at_copy, 'atom_mask', .false., overwrite=.true., ptr=atom_mask, error=error) + PASS_ERROR(error) + atom_mask = .false. + atom_mask(select_n+1:at_copy%n) = .true. + + ! source_mask is true for atoms which should act as electrostatic sources + call add_property(at_copy, 'source_mask', .false., overwrite=.true., ptr=source_mask, error=error) + PASS_ERROR(error) + source_mask(1:select_n) = mark(1:select_n) == HYBRID_ELECTROSTATIC_MARK + source_mask(select_n+1:at_copy%n) = .false. + + call print('calc_electrostatic_potential: evaluating electrostatic potential due to '//count(source_mask)//' sources') + + ! Construct mapping from igrid to (i,j,k) + igrid = 0 + allocate(lookup(3,size(real_grid,2))) + do k=1,ngrid(3) + do j=1,ngrid(2) + do i=1,ngrid(1) + igrid = igrid + 1 + lookup(:,igrid) = (/i,j,k/) + end do + end do + end do + +#ifdef _OPENMP + old_nested = omp_get_nested() + call omp_set_nested(.false.) +#endif + !$omp parallel default(none) shared(at_copy,stride,args_str,grid_size,this,pot,real_grid,select_n,at_charge,lookup) private(local_e,npoint,igrid) + + call atoms_copy_without_connect(private_at_copy, at_copy) + call set_cutoff(private_at_copy, cutoff(this)) + + allocate(local_e(private_at_copy%n)) + + !$omp do + do offset=1,stride + npoint = size(real_grid(:,offset:size(real_grid,2):stride),2) + private_at_copy%n = select_n + npoint + private_at_copy%nbuffer = select_n + npoint + private_at_copy%pos(:,select_n+1:private_at_copy%n) = real_grid(:,offset:size(real_grid,2):stride) + call calc_connect(private_at_copy, skip_zero_zero_bonds=.true.) + + local_e = 0.0_dp + call calc(this, private_at_copy, local_energy=local_e(1:private_at_copy%n), & + args_str=trim(args_str)//' atom_mask_name=atom_mask source_mask_name=source_mask grid_size='//minval(grid_size)) + do n=1,npoint + igrid = (n-1)*stride + offset + pot(lookup(1,igrid),lookup(2,igrid),lookup(3,igrid)) = 2.0_dp*local_e(select_n+n)/at_charge(select_n+n) + end do + end do + + call finalise(private_at_copy) + deallocate(local_e) + + !$omp end parallel +#ifdef _OPENMP + call omp_set_nested(old_nested) +#endif + + ! Now do a single calculation of potential and field at ion positions in cluster + if (cluster%n > (size(at_copy%z)-select_n)) then + RAISE_ERROR("cluster contains too many atoms!", error) + end if + at_copy%n = select_n + cluster%n + at_copy%nbuffer = select_n + cluster%n + at_copy%pos(:,select_n+1:at_copy%n) = cluster%pos(:,:) + if (.not. assign_pointer(cluster, 'charge', cluster_charge)) then + RAISE_ERROR('calc_electrostatic_potential failed to assign pointer to cluster "charge" property', error) + end if + at_charge(select_n+1:at_copy%n) = 1.0_dp + at_copy%z(select_n+1:at_copy%n) = 0 ! treat as non-interacting dummy atoms + call calc_connect(at_copy, skip_zero_zero_bonds=.true.) + + call add_property(at_copy, 'es_efield', 0.0_dp, n_cols=3, overwrite=.true., ptr2=es_efield, error=error) + PASS_ERROR(error) + call add_property(at_copy, 'es_pot', 0.0_dp, overwrite=.true., ptr=es_pot, error=error) + PASS_ERROR(error) + call add_property(cluster, 'es_efield', 0.0_dp, n_cols=3, overwrite=.true., ptr2=cluster_es_efield, error=error) + PASS_ERROR(error) + call add_property(cluster, 'es_pot', 0.0_dp, overwrite=.true., ptr=cluster_es_pot, error=error) + PASS_ERROR(error) + + call calc(this, at_copy, args_str=trim(args_str)//' efield=es_efield local_energy=es_pot atom_mask_name=atom_mask source_mask_name=source_mask', error=error) + PASS_ERROR(error) + + ! Electrostatic potential at ion positions is 2*local_energy/charge + cluster_es_pot = 2.0_dp*es_pot(select_n+1:at_copy%n)/cluster_charge + cluster_es_efield = es_efield(:,select_n+1:at_copy%n) + + deallocate(select_mask) + deallocate(lookup,z) + call finalise(at_copy) + call system_timer('calc_electrostatic_potential') + + end subroutine calc_electrostatic_potential + + +end module ElectrostaticEmbed_module diff --git a/src/Potentials/Ewald.F90 b/src/Potentials/Ewald.F90 new file mode 100644 index 0000000000..d259671c31 --- /dev/null +++ b/src/Potentials/Ewald.F90 @@ -0,0 +1,830 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Ewald module +!X +!% This module computes the Ewald sum. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +module Ewald_module + +use system_module +use units_module + +use functions_module + +implicit none + +private + +integer max_n_r, max_n_q +integer n_r, n_q +integer, allocatable:: r_list(:,:), q_list(:,:) + +integer:: last_N_A = 0 +integer:: n_pairs +integer, allocatable:: pair_list(:,:) + +public add_madelung_matrix, add_dmadelung_matrix, add_dmadelung_matrix_dr + +contains + +!| subroutine add_madelung_matrix +!| calculate Madelung matrix (interactions of pt charges in 3-D periodic supercell) +!| +!|I integer N_A: number of atoms +!|I real(dp) a1(3), a2(3), a3(3): periodic supercell vectors +!|I real(dp) A(3,N_A): atomic positions +!|O real(dp) madelung_matrix(N_A,N_A): Madelung matrix +!|I logical redo_lattice: if true, redo whole calculation, rather than +!| just summing over periodic images that had significant contributions +!| last time +!| +!| Noam Bernstein 9/12/2001 +!| From Fundamental Formulas of Physics, p. 599 +!% Calculate Madelung matrix (interactions of pt charges in 3-D periodic supercell). +!% It is possible to choose between redoing the whole calculation and summing over those periodic images +!% that had significant contributions last time by setting the logical variable redo_lattice. +subroutine add_madelung_matrix(N_A, a1_in, a2_in, a3_in, A_in, madelung_matrix, redo_lattice) + integer, intent(in) :: N_A !% number of atoms (input) + real(dp), intent(in) :: a1_in(3), a2_in(3), a3_in(3) !% periodic supercell vectors (input) + real(dp), intent(in) :: A_in(3,N_A) !% atomic positions (input) + real(dp), intent(inout) :: madelung_matrix(N_A,N_A) !% Madelung matrix (output) + logical, intent(in), optional :: redo_lattice !% if true, redo whole calculation, rather than just summing over periodic images that had significant contributions last time (input) + + integer i, j, range_a(3) + integer s_a(3), s2, s3 + real(dp) b1(3), b2(3), b3(3), h(3,3) + real(dp) vol + real(dp) K(3), ri(3), rj(3), t, tv(3), Kmagsq, Rmag + + real(dp) :: a1(3), a2(3), a3(3) + real(dp), allocatable :: A(:,:) + + integer rr, qq + + real(dp) epsilon, fourepsilonsq + real(dp) recip_space_prefac, K_dep_factor + real(dp) phase + real(dp) conv_crit, prev_conv_crit + + integer ni, nip1, nip2 + real(dp) b1mag, b2mag, b3mag + real(dp) a1mag, a2mag, a3mag + + logical use_this_one + real(dp) convf + + logical u_redo_lattice + + integer i_pair + + integer nv + + allocate(A(3,N_A)) + a1 = a1_in / Bohr + a2 = a2_in / Bohr + a3 = a3_in / Bohr + A = A_in / Bohr + + u_redo_lattice = .true. + if (present(redo_lattice)) u_redo_lattice = redo_lattice + + !convf = 1.0D-10 + convf = 1.0D-14 + + h(1:3,1) = a1(1:3) + h(1:3,2) = a2(1:3) + h(1:3,3) = a3(1:3) + vol = calc_volume(h) + call cross_3 (a1, a2, b3) + call cross_3 (a2, a3, b1) + call cross_3 (a3, a1, b2) + b1 = 2.0_dp*PI* b1 / vol + b2 = 2.0_dp*PI* b2 / vol + b3 = 2.0_dp*PI* b3 / vol + + !epsilon = 0.7_dp/nn_dist + + epsilon = 1.5_dp / ( 1.0_dp/sqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) + !epsilon = 2.25_dp / ( 1.0_dp/sqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) + + fourepsilonsq = 4.0_dp*epsilon**2 + + recip_space_prefac = 4.0_dp*PI/vol + + prev_conv_crit = 0.0_dp + conv_crit = prev_conv_crit+1.0_dp + + b1mag = sqrt(sum(b1**2)) + b2mag = sqrt(sum(b2**2)) + b3mag = sqrt(sum(b3**2)) + + nv = 0 + range_a = 0 + + if (u_redo_lattice) then + + if (N_A .ne. last_N_A) then + if (allocated(pair_list)) deallocate(pair_list) + call assign_atom_pairs(N_A, n_pairs, pair_list) + last_N_A = N_A + end if + + max_n_r = 2000 + max_n_q = 2000 + if (allocated(r_list)) deallocate(r_list) + if (allocated(q_list)) deallocate(q_list) + allocate(r_list(3,max_n_r)) + allocate(q_list(3,max_n_q)) + n_r = 0 + n_q = 0 + + + ! reciprocal space + do while (abs(conv_crit-prev_conv_crit) .gt. 1.0e-14_dp) + + !!!!! + do ni=1,3 + range_a(ni) = range_a(ni) + 1 + nip1 = mod(ni,3)+1 + nip2 = mod(ni+1,3)+1 + + s_a(ni) = -range_a(ni) + do s2 = -range_a(nip1), range_a(nip1) + s_a(nip1) = s2 + do s3 = -range_a(nip2), range_a(nip2) + s_a(nip2) = s3 + + use_this_one = .false. + + K = s_a(1)*b1 + s_a(2)*b2 + s_a(3)*b3 + Kmagsq = sum(K**2) + K_dep_factor = recip_space_prefac*exp(-Kmagsq/fourepsilonsq)/Kmagsq + + do i_pair = 1, n_pairs + + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + phase = sum(K*(ri-rj)) + t = Hartree*K_dep_factor*cos(phase) + madelung_matrix(i,j) = madelung_matrix(i,j) + 2*t + + if (i /= j) madelung_matrix(j,i) = madelung_matrix(j,i) + 2*t + + if (t /= 0.0_dp .and. abs((2.0_dp*t)/madelung_matrix(i,j)) > convf) then +! workaround for buggy Cray MTA compiler +#ifndef cray_mta + use_this_one = .true. +#endif + end if + + end do + + if (use_this_one) then + n_q = n_q + 1 + q_list(1:3,n_q) = s_a + end if + + nv = nv + 1 + + end do ! s3 + end do ! s2 + end do ! ni + + prev_conv_crit = conv_crit + !NO_PARALLEL t_conv_crit = sum(abs(madelung_matrix)) + !NO_PARALLEL call global_sum(t_conv_crit, conv_crit) + conv_crit = sum(abs(madelung_matrix)) + ! print *, "G conv ", range_a, conv_crit, prev_conv_crit + + end do ! while not conv + ! print *, "nv ", nv + + + !NO_PARALLEL t_conv_crit = sum(abs(madelung_matrix)) + !NO_PARALLEL call global_sum(t_conv_crit,prev_conv_crit) + prev_conv_crit = sum(abs(madelung_matrix)) + conv_crit = prev_conv_crit+1.0_dp + + ! real space shift=0 + a1mag = sqrt(sum(a1**2)) + a2mag = sqrt(sum(a2**2)) + a3mag = sqrt(sum(a3**2)) + + tv = 0.0_dp + + do i_pair = 1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + if (i .eq. j) cycle + + ri = A(1:3,i) + rj = A(1:3,j) + + Rmag = sqrt(sum((rj+tv-ri)**2)) + t = Hartree * erfc(epsilon*Rmag)/Rmag + madelung_matrix(i,j) = madelung_matrix(i,j) + t + if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t + end do + + + prev_conv_crit = conv_crit + !NO_PARALLEL t_conv_crit = sum(dabs(madelung_matrix)) + !NO_PARALLEL call global_sum(t_conv_crit, conv_crit) + conv_crit = sum(abs(madelung_matrix)) + ! print *, "R conv ", range, conv_crit, prev_conv_crit + + nv = 0 + range_a = 0 + + ! real space shift /= 0 + do while (abs(conv_crit-prev_conv_crit) .gt. 1.0e-14_dp) + + ! amag_a(1) = a1mag*(range_a(1)+1) + ! amag_a(2) = a2mag*(range_a(2)+1) + ! amag_a(3) = a3mag*(range_a(3)+1) + ! next_increment = minloc(amag_a) + ! ni = next_increment(1) + + !!!!! + do ni=1,3 + + range_a(ni) = range_a(ni) + 1 + nip1 = mod(ni,3)+1 + nip2 = mod(ni+1,3)+1 + + s_a(ni) = -range_a(ni) + do s2 = -range_a(nip1), range_a(nip1) + s_a(nip1) = s2 + do s3 = -range_a(nip2), range_a(nip2) + s_a(nip2) = s3 + + use_this_one = .false. + + tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 + + do i_pair = 1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + Rmag = sqrt(sum((rj+tv-ri)**2)) + t = Hartree * erfc(epsilon*Rmag)/Rmag + madelung_matrix(i,j) = madelung_matrix(i,j) + t + if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t + if (t .ne. 0 .and. abs(t/madelung_matrix(i,j)) .gt. convf) then + use_this_one = .true. + end if + + end do + + !NO_PARALLEL call global_or(use_this_one, g_use_this_one) + !NO_PARALLEL use_this_one = g_use_this_one + + if (use_this_one) then + n_r = n_r + 1 + r_list(1:3,n_r) = s_a + end if + + nv = nv + 1 + end do + end do + + s_a(ni) = range_a(ni) + do s2 = -range_a(nip1), range_a(nip1) + s_a(nip1) = s2 + do s3 = -range_a(nip2), range_a(nip2) + s_a(nip2) = s3 + + use_this_one = .false. + + tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 + do i_pair = 1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + Rmag = sqrt(sum((rj+tv-ri)**2)) + t = Hartree * erfc(epsilon*Rmag)/Rmag + madelung_matrix(i,j) = madelung_matrix(i,j) + t + if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t + + if (t .ne. 0 .and. abs(t/madelung_matrix(i,j)) .gt. convf) then + use_this_one = .true. + end if + + end do + + !NO_PARALLEL call global_or(use_this_one, g_use_this_one) + !NO_PARALLEL use_this_one = g_use_this_one + + if (use_this_one) then + n_r = n_r + 1 + r_list(1:3,n_r) = s_a + end if + + nv = nv + 1 + end do + end do + + !!!!! + end do ! ni + + + prev_conv_crit = conv_crit + !NO_PARALLEL t_conv_crit = sum(abs(madelung_matrix)) + !NO_PARALLEL call global_sum(t_conv_crit, conv_crit) + conv_crit = sum(abs(madelung_matrix)) + ! print *, "R conv ", range, conv_crit, prev_conv_crit + + end do ! while conv_crit + + ! print *, "nv ", nv + ! print *, "n_r, n_q ", n_r, n_q + else ! don't redo lattice + + do qq=1, n_q + + s_a = q_list(1:3,qq) + + K = s_a(1)*b1 + s_a(2)*b2 + s_a(3)*b3 + Kmagsq = sum(K**2) + K_dep_factor = recip_space_prefac*exp(-Kmagsq/fourepsilonsq)/Kmagsq + do i_pair = 1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + phase = sum(K*(ri-rj)) + t = Hartree * K_dep_factor*cos(phase) + madelung_matrix(i,j) = madelung_matrix(i,j) + 2*t + if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + 2*t + end do + + end do + + tv = 0.0_dp + do i_pair = 1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + if (i .eq. j) cycle + ri = A(1:3,i) + rj = A(1:3,j) + + Rmag = sqrt(sum((rj+tv-ri)**2)) + t = Hartree * erfc(epsilon*Rmag)/Rmag + madelung_matrix(i,j) = madelung_matrix(i,j) + t + if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t + end do + + do rr=1, n_r + s_a = r_list(1:3,rr) + + tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 + do i_pair = 1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + Rmag = sqrt(sum((rj+tv-ri)**2)) + t = Hartree * erfc(epsilon*Rmag)/Rmag + madelung_matrix(i,j) = madelung_matrix(i,j) + t + if (i .ne. j) madelung_matrix(j,i) = madelung_matrix(j,i) + t + end do + end do + + end if + + conv_crit = sum(abs(madelung_matrix)) + ! print *, "overall conv ", conv_crit + + do i=1, N_A + madelung_matrix(i,i) = madelung_matrix(i,i) - Hartree * 2.0_dp*epsilon/sqrt(PI) + end do + + madelung_matrix = madelung_matrix - Hartree * PI/(vol*epsilon**2) +madelung_matrix = madelung_matrix + 0.61_dp + + deallocate(A) + +end subroutine add_madelung_matrix + +!| subroutine add_dmadelung_matrix +!| calculate derivative of Madelung matrix (interactions of pt charges in +!| 3-D periodic supercell) +!| +!|I integer N_A: number of atoms +!|I real(dp) a1(3), a2(3), a3(3): periodic supercell vectors +!|I real(dp) A(3,N_A): atomic positions +!|O real(dp) dmadelung_matrix(N_A,N_A): derivative of Madelung matrix +!| +!| Noam Bernstein 9/12/2001 +!% This subroutine calculate derivative of Madelung matrix (interactions of pt charges in +!% 3-D periodic supercell). +subroutine add_dmadelung_matrix(N_A, a1_in, a2_in, a3_in, A_in, dmadelung_matrix) + integer :: N_A !% number of atoms + real(dp) :: a1_in(3), a2_in(3), a3_in(3) !% periodic supercell vectors + real(dp) :: A_in(3,N_A) !% atomic positions + real(dp) :: dmadelung_matrix(N_A,N_A,3) !% derivative of Madelung matrix + + !NO PARALLEL real(dp), allocatable:: t_dmadelung_matrix(:,:,:) + + integer i, j + integer s_a(3) + real(dp) b1(3), b2(3), b3(3), h(3,3) + real(dp) vol + real(dp) K(3), ri(3), rj(3), dt, tv(3), Kmagsq, Rmag, dr(3) + + real(dp) :: a1(3), a2(3), a3(3) + real(dp), allocatable :: A(:,:) + + integer i_pair + integer rr, qq + + real(dp) epsilon, fourepsilonsq + real(dp) recip_space_prefac, K_dep_factor + real(dp) phase + + allocate(A(3,N_A)) + a1 = a1_in / Bohr + a2 = a2_in / Bohr + a3 = a3_in / Bohr + A = A_in / Bohr + + h(1:3,1) = a1(1:3) + h(1:3,2) = a2(1:3) + h(1:3,3) = a3(1:3) + vol = calc_volume(h) + call cross_3 (a1, a2, b3) + call cross_3 (a2, a3, b1) + call cross_3 (a3, a1, b2) + b1 = 2.0_dp*PI* b1 / vol + b2 = 2.0_dp*PI* b2 / vol + b3 = 2.0_dp*PI* b3 / vol + + !epsilon = 0.7_dp/nn_dist + + epsilon = 1.5_dp / ( 1.0_dp/sqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) + !epsilon = 2.25_dp / ( 1.0_dp/sqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) + + fourepsilonsq = 4.0_dp*epsilon**2 + + recip_space_prefac = 4.0_dp*PI/vol + + do qq=1, n_q + + s_a = q_list(1:3,qq) + + K = s_a(1)*b1 + s_a(2)*b2 + s_a(3)*b3 + Kmagsq = sum(K**2) + K_dep_factor = recip_space_prefac*exp(-Kmagsq/fourepsilonsq)/Kmagsq + do i_pair=1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + phase = sum(K*(ri-rj)) + dt = Hartree/Bohr * K_dep_factor*(-sin(phase)) + dmadelung_matrix(i,j,1:3) = dmadelung_matrix(i,j,1:3) + 2.0_dp*dt*K(1:3) + if (i .ne. j) dmadelung_matrix(j,i,1:3) = dmadelung_matrix(j,i,1:3) - 2.0_dp*dt*K(1:3) + end do + + end do + + tv = 0.0_dp + do i_pair=1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + if (i .eq. j) cycle + ri = A(1:3,i) + rj = A(1:3,j) + + dr = ri-tv-rj + Rmag = sqrt(sum(dr**2)) + dt = Hartree/Bohr * ( (-2.0_dp/sqrt(PI))*Rmag*epsilon*exp(-(epsilon*Rmag)**2) - erfc(epsilon*Rmag) ) / Rmag**2 + dmadelung_matrix(i,j,1:3) = dmadelung_matrix(i,j,1:3) + dt*dr/Rmag + if (i .ne. j) dmadelung_matrix(j,i,1:3) = dmadelung_matrix(j,i,1:3) - dt*dr/Rmag + + end do + + do rr=1, n_r + s_a = r_list(1:3,rr) + + tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 + do i_pair=1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + dr = ri-tv-rj + Rmag = sqrt(sum(dr**2)) + dt = Hartree/Bohr * ( (-2.0_dp/sqrt(PI))*Rmag*epsilon*exp(-(epsilon*Rmag)**2) - erfc(epsilon*Rmag) ) / Rmag**2 + dmadelung_matrix(i,j,1:3) = dmadelung_matrix(i,j,1:3) + dt*dr/Rmag + if (i .ne. j) dmadelung_matrix(j,i,1:3) = dmadelung_matrix(j,i,1:3) - dt*dr/Rmag + + end do + end do + + !NO_PARALLEL allocate(t_dmadelung_matrix(N_A,N_A,3)) + !NO_PARALLEL t_dmadelung_matrix = dmadelung_matrix + !NO_PARALLEL dmadelung_matrix = 0.0_dp + !NO_PARALLEL call global_sum(t_dmadelung_matrix, dmadelung_matrix) + !NO_PARALLEL deallocate(t_dmadelung_matrix) + + deallocate(A) + +end subroutine add_dmadelung_matrix + +!| subroutine add_dmadelung_matrix_dr +!% Calculate derivative of Madelung matrix (interactions of pt charges in +!% 3-D periodic supercell) dotted with atomic positions. +!% From Nielsen and Martin, Phys. Rev. B {\bf 32}, (1985). +!| +!|I integer N_A: number of atoms +!|I real(dp) a1(3), a2(3), a3(3): periodic supercell vectors +!|I real(dp) A(3,N_A): atomic positions +!|O real(dp) dmadelung_matrix_dr(N_A,N_A): derivative of Madelung matrix +!| dotted with atomic positions +!| +!| Noam Bernstein 9/12/2001 +!| From Nielsen and Martin, PRB _32_, 1985. + +subroutine add_dmadelung_matrix_dr(N_A, a1_in, a2_in, a3_in, A_in, component, dmadelung_matrix_dr) + integer :: N_A !% number of atoms (input) + real(dp) :: a1_in(3), a2_in(3), a3_in(3) !% periodic supercell vectors (input) + real(dp) :: A_in(3,N_A) !% atomic positions (input) + integer :: component + real(dp) :: dmadelung_matrix_dr(N_A,N_A,3) !% derivative of Madelung matrix dotted with atomic positions (output) + + integer i, j + integer s_a(3) + real(dp) b1(3), b2(3), b3(3), h(3,3) + real(dp) vol + real(dp) K(3), ri(3), rj(3), dt, tv(3), Kmagsq, Rmag, dr(3) + real(dp) t_ij(3) + + real(dp) :: a1(3), a2(3), a3(3) + real(dp), allocatable :: A(:,:) + + integer i_pair + integer rr, qq + + real(dp) epsilon, fourepsilonsq + real(dp) recip_space_prefac, K_dep_factor + real(dp) phase + + allocate(A(3,N_A)) + a1 = a1_in / Bohr + a2 = a2_in / Bohr + a3 = a3_in / Bohr + A = A_in / Bohr + + h(1:3,1) = a1(1:3) + h(1:3,2) = a2(1:3) + h(1:3,3) = a3(1:3) + vol = calc_volume(h) + call cross_3 (a1, a2, b3) + call cross_3 (a2, a3, b1) + call cross_3 (a3, a1, b2) + b1 = 2.0_dp*PI* b1 / vol + b2 = 2.0_dp*PI* b2 / vol + b3 = 2.0_dp*PI* b3 / vol + + !epsilon = 0.7_dp/nn_dist + + epsilon = 1.5_dp / ( 1.0_dp/dsqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) + !epsilon = 2.25_dp / ( 1.0_dp/dsqrt(PI) * 2.0_dp * ((3.0_dp*vol)/(4.0_dp*PI))**(1.0_dp/3.0_dp) ) + + fourepsilonsq = 4.0_dp*epsilon**2 + + recip_space_prefac = PI/(vol*epsilon**2) + + do qq=1, n_q + + s_a = q_list(1:3,qq) + + K = s_a(1)*b1 + s_a(2)*b2 + s_a(3)*b3 + Kmagsq = sum(K**2) + + K_dep_factor = recip_space_prefac*dexp(-Kmagsq/fourepsilonsq)/(Kmagsq/fourepsilonsq) + + do i_pair=1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + dr = ri-rj + phase = sum(K*(ri-rj)) + + dt = Hartree * K_dep_factor*2.0_dp*dcos(phase) + + if (component .eq. 0) then + t_ij(1:3) = dt * (2.0_dp*K(1:3)*K(1:3)/Kmagsq * (Kmagsq/fourepsilonsq + 1.0_dp) - 1.0_dp) + dmadelung_matrix_dr(i,j,1) = dmadelung_matrix_dr(i,j,1) - sum(t_ij(1:3)) + if (i .ne. j) dmadelung_matrix_dr(j,i,1) = dmadelung_matrix_dr(j,i,1) - sum(t_ij(1:3)) + else + t_ij(1:3) = dt * (2.0_dp*K(component)*K(1:3)/Kmagsq * (Kmagsq/fourepsilonsq + 1.0_dp)) + t_ij(component) = t_ij(component) - dt + dmadelung_matrix_dr(i,j,1:3) = dmadelung_matrix_dr(i,j,1:3) - t_ij(1:3) + if (i .ne. j) dmadelung_matrix_dr(j,i,1:3) = dmadelung_matrix_dr(j,i,1:3) - t_ij(1:3) + end if + end do + + end do + + tv = 0.0_dp + do i_pair=1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + if (i .eq. j) cycle + ri = A(1:3,i) + rj = A(1:3,j) + + dr = ri-tv-rj + Rmag = sqrt(sum(dr**2)) + if (component .eq. 0) then + t_ij(1:3) = Hartree * 0.5_dp*epsilon*2.0_dp*Hprime(epsilon*Rmag)*dr(1:3)*dr(1:3)/Rmag**2 + dmadelung_matrix_dr(i,j,1) = dmadelung_matrix_dr(i,j,1) - sum(t_ij(1:3)) + if (i .ne. j) dmadelung_matrix_dr(j,i,1) = dmadelung_matrix_dr(j,i,1) - sum(t_ij(1:3)) + else + t_ij(1:3) = Hartree * 0.5_dp*epsilon*2.0_dp*Hprime(epsilon*Rmag)*dr(component)*dr(1:3)/Rmag**2 + dmadelung_matrix_dr(i,j,1:3) = dmadelung_matrix_dr(i,j,1:3) - t_ij(1:3) + if (i .ne. j) dmadelung_matrix_dr(j,i,1:3) = dmadelung_matrix_dr(j,i,1:3) - t_ij(1:3) + end if + end do + + do rr=1, n_r + s_a = r_list(1:3,rr) + + tv = s_a(1)*a1 + s_a(2)*a2 + s_a(3)*a3 + do i_pair=1, n_pairs + i = pair_list(1,i_pair) + j = pair_list(2,i_pair) + ri = A(1:3,i) + rj = A(1:3,j) + + dr = ri-tv-rj + Rmag = sqrt(sum(dr**2)) + if (component .eq. 0) then + t_ij(1:3) = Hartree * 0.5_dp*epsilon*2.0_dp*Hprime(epsilon*Rmag)*dr(1:3)*dr(1:3)/Rmag**2 + dmadelung_matrix_dr(i,j,1) = dmadelung_matrix_dr(i,j,1) - sum(t_ij(1:3)) + if (i .ne. j) dmadelung_matrix_dr(j,i,1) = dmadelung_matrix_dr(j,i,1) - sum(t_ij(1:3)) + else + t_ij(1:3) = Hartree * 0.5_dp*epsilon*2.0_dp*Hprime(epsilon*Rmag)*dr(component)*dr(1:3)/Rmag**2 + dmadelung_matrix_dr(i,j,1:3) = dmadelung_matrix_dr(i,j,1:3) - t_ij(1:3) + if (i .ne. j) dmadelung_matrix_dr(j,i,1:3) = dmadelung_matrix_dr(j,i,1:3) - t_ij(1:3) + end if + end do + end do + + if (component .eq. 0) then + dmadelung_matrix_dr(1:N_A,1:N_A,1) = dmadelung_matrix_dr(1:N_A,1:N_A,1) - & + Hartree * 3.0_dp*PI/(vol*epsilon**2) + else + dmadelung_matrix_dr(1:N_A,1:N_A,1:3) = dmadelung_matrix_dr(1:N_A,1:N_A,1:3) - & + Hartree * PI/(vol*epsilon**2) + end if + +!NO_PARALLEL if (component .eq. 0) then +!NO_PARALLEL allocate(t_dmadelung_matrix_dr(N_A,N_A,1)) +!NO_PARALLEL t_dmadelung_matrix_dr(1:N_A,1:N_A,1) = dmadelung_matrix_dr(1:N_A,1:N_A,1) +!NO_PARALLEL dmadelung_matrix_dr(1:N_A,1:N_A,1) = 0.0_dp +!NO_PARALLEL call global_sum(t_dmadelung_matrix_dr, dmadelung_matrix_dr) +!NO_PARALLEL deallocate(t_dmadelung_matrix_dr) +!NO_PARALLEL else +!NO_PARALLEL allocate(t_dmadelung_matrix_dr(N_A,N_A,3)) +!NO_PARALLEL t_dmadelung_matrix_dr = dmadelung_matrix_dr +!NO_PARALLEL dmadelung_matrix_dr = 0.0_dp +!NO_PARALLEL call global_sum(t_dmadelung_matrix_dr, dmadelung_matrix_dr) +!NO_PARALLEL deallocate(t_dmadelung_matrix_dr) +!NO_PARALLEL endif + + deallocate(A) + +end subroutine add_dmadelung_matrix_dr + +!| subroutine cross_3 +!% Calculate cross product of 2 3-vectors. a(3), b(3): vectors to be crossed, c(3): cross product. +!| +!|I real(dp) a(3), b(3): vectors to be crossed +!|O real(dp) c(3): cross product +!| +!| Noam Bernstein 9/12/2001 + +subroutine cross_3(a, b, c) + real(dp) a(3), b(3), c(3) + + c(1) = a(2)*b(3)-a(3)*b(2) + c(2) = a(3)*b(1)-a(1)*b(3) + c(3) = a(1)*b(2)-a(2)*b(1) + +end subroutine cross_3 + +!| real(dp) function calc_volume +!| calculate volume of periodic supercell +!| returns volume of supercell +!| +!|I real(dp) a(3,3): matrix of peridic supercell vectors +!| +!| Noam Bernstein 9/12/2001 + +real(dp) function calc_volume(mat) + real(dp) mat(3,3) + + calc_volume = abs(det_3_by_3(mat)) +end function calc_volume + +!| real(dp) function det_3_by_3 +!| calculate determinant of 3x3 matrix +!| returns determinant of matrix +!| +!|I real(dp) a(3,3): matrix +!| +!| Noam Bernstein 9/12/2001 + +real(dp) function det_3_by_3(a) + real(dp) a(3,3) + + det_3_by_3 = -a(1,3)*a(2,2)*a(3,1) + a(1,2)*a(2,3)*a(3,1) + a(1,3)*a(2,1)*a(3,2) - & + a(1,1)*a(2,3)*a(3,2) - a(1,2)*a(2,1)*a(3,3) + a(1,1)*a(2,2)*a(3,3) +end function det_3_by_3 + +!| real(dp) function Hprime +!| calculate Hprime function for dMadelung_matrix/dr . r +!| returns value of Hprime(x) +!| +!|I real(dp) x: argument +!| +!| Noam Bernstein 9/12/2001 + +real(dp) function Hprime(x) + real(dp) x + + Hprime = (-2.0_dp/sqrt(PI))*exp(-x**2) - erfc(x)/x + +end function Hprime + +subroutine assign_atom_pairs(N, n_pairs, pair_list) + integer, intent(in) :: N + integer, intent(out) :: n_pairs + integer, allocatable, intent(inout) :: pair_list(:,:) + + integer cur_pair_i, i, j + + n_pairs = N*(N+1)/2 + + if (allocated(pair_list)) deallocate(pair_list) + allocate(pair_list(2,n_pairs)) + + cur_pair_i = 1 + do i=1, N + do j=i, N + pair_list(1,cur_pair_i) = i + pair_list(2,cur_pair_i) = j + cur_pair_i = cur_pair_i + 1 + end do + end do + +end subroutine assign_atom_pairs + +end module Ewald_module diff --git a/src/Potentials/FilePot.F90 b/src/Potentials/FilePot.F90 new file mode 100644 index 0000000000..465664cef7 --- /dev/null +++ b/src/Potentials/FilePot.F90 @@ -0,0 +1,495 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X FilePot Module +!X +!% FilePot is a potential that computes things by writing atomic config to a +!% file, running a command, and reading its output +!% +!% it takes an argument string on initialization with one mandatory parameter +!%> command=path_to_command +!% and three optional parameters +!%> property_list=prop1:T1:N1:prop2:T2:N2... +!% which defaults to 'pos', +!%> filename= +!% which defaults to 'filepot', and +!%> min_cutoff=cutoff +!% which default to zero. If min_cutoff is non zero and the cell is narrower +!% than $2*min_cutoff$ in any direction then it will be replicated before +!% being written to the file. The forces are taken from the primitive cell +!% and the energy is reduced by a factor of the number of repeated copies. +!% +!% The command takes 2 arguments, the names of the input and the output files. +!% command output is in extended xyz form. +!% +!% energy and virial (both optional) are passed via the comment, labeled as +!% 'energy=E' and 'virial="vxx vxy vxz vyx vyy vyz vzx vzy vzz"'. +!% +!% per atoms data is at least atomic type and optionally +!% a local energy (labeled 'local_e:R:1') +!% and +!% forces (labeled 'force:R:3') +!% +!% right now (14/2/2008) the atoms_xyz reader requires the 1st 3 columns after +!% the atomic type to be the position. +!% +!% If you ask for some quantity from FilePot_Calc and it's not in the output file, it +!% returns an error status or crashes (if err isn't present). +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! some day implement calculation queues +! how to do this? one possibility: +! add args_str to FilePot_Calc, and indicate +! queued_force=i to indicate this atoms structure should be queued for the calculation +! of forces on atom i (or a list, or a range?) +! or +! process_queue, which would process the queue and fill in all the forces +#include "error.inc" +module FilePot_module + +use error_module +use system_module, only : dp, print, PRINT_NORMAL, PRINT_ALWAYS, PRINT_VERBOSE, inoutput, current_verbosity, system_command, optional_default, parse_string, operator(//) +use mpi_context_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use connection_module +use atoms_types_module +use atoms_module +use structures_module +use CInOutput_module + +implicit none +private + + +public :: FilePot_type +type FilePot_type + character(len=STRING_LENGTH) :: command + character(len=STRING_LENGTH) :: command_addl_args + character(len=STRING_LENGTH) :: property_list + character(len=STRING_LENGTH) :: read_extra_property_list + character(len=STRING_LENGTH) :: read_extra_param_list + character(len=STRING_LENGTH) :: property_list_prefixes + character(len=STRING_LENGTH) :: filename + real(dp) :: min_cutoff + + character(len=STRING_LENGTH) :: init_args_str + type(MPI_context) :: mpi + +end type FilePot_type + +public :: Initialise +interface Initialise + module procedure FilePot_Initialise +end interface Initialise + +public :: Finalise +interface Finalise + module procedure FilePot_Finalise +end interface Finalise + +public :: cutoff +interface cutoff + module procedure FilePot_cutoff +end interface + +public :: Wipe +interface Wipe + module procedure FilePot_Wipe +end interface Wipe + +public :: Print +interface Print + module procedure FilePot_Print +end interface Print + +public :: calc +interface calc + module procedure FilePot_Calc +end interface + +contains + + +subroutine FilePot_Initialise(this, args_str, mpi, error) + type(FilePot_type), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + character(len=STRING_LENGTH) :: command, property_list, read_extra_property_list, & + read_extra_param_list, property_list_prefixes, command_addl_args, filename + real(dp) :: min_cutoff + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + this%init_args_str = args_str + + call initialise(params) + call param_register(params, 'command', PARAM_MANDATORY, command, help_string="system command to execute that should read the structure file, run the model and deposit the output file") + call param_register(params, 'command_addl_args', '', command_addl_args, help_string="additional args to be appended to the command line after xyzfile and outfile") + call param_register(params, 'property_list', 'species:pos', property_list, help_string="list of properties to print with the structure file") + call param_register(params, 'read_extra_property_list', '', read_extra_property_list, help_string="names of extra properties to read from filepot.out files") + call param_register(params, 'property_list_prefixes', '', property_list_prefixes, help_string="list of prefixes to which run_suffix will be applied during calc()") + call param_register(params, 'read_extra_param_list', 'QM_cell', read_extra_param_list, help_string="list of extra params (comment line in XYZ) to read from filepot.out files. Default is 'QM_cell'") + call param_register(params, 'filename', 'filepot', filename, help_string="seed name for directory and structure files to be used") + call param_register(params, 'min_cutoff', '0.0', min_cutoff, help_string="if the unit cell does not fit into this cutoff, it is periodically replicated so that it does") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='filepot_initialise args_str')) then + RAISE_ERROR("FilePot_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("FilePot_Initialise: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + this%command = command + this%command_addl_args = command_addl_args + this%property_list = property_list + this%read_extra_property_list = read_extra_property_list + this%read_extra_param_list = read_extra_param_list + this%property_list_prefixes = property_list_prefixes + this%min_cutoff = min_cutoff + this%filename = filename + if (present(mpi)) this%mpi = mpi + +end subroutine FilePot_Initialise + +subroutine FilePot_Finalise(this) + type(FilePot_type), intent(inout) :: this + + call wipe(this) + +end subroutine FilePot_Finalise + +subroutine FilePot_Wipe(this) + type(FilePot_type), intent(inout) :: this + + this%command="" + this%command_addl_args="" + this%property_list="" + this%read_extra_property_list="" + this%read_extra_param_list="" + this%min_cutoff = 0.0_dp + this%filename = "" + +end subroutine FilePot_Wipe + +function FilePot_cutoff(this) + type(FilePot_type), intent(in) :: this + real(dp) :: FilePot_cutoff + FilePot_cutoff = 0.0_dp ! return zero, because FilePot does its own connection calculation +end function FilePot_cutoff + +subroutine FilePot_Print(this, file) + type(FilePot_type), intent(in) :: this + type(Inoutput), intent(inout),optional,target:: file + + if (current_verbosity() < PRINT_NORMAL) return + + call print("FilePot: command='"//trim(this%command)// & + "' command_addl_args='"//trim(this%command_addl_args)// & + "' filename='"//trim(this%filename)//& + "' property_list='"//trim(this%property_list)//& + "' read_extra_property_list='"//trim(this%read_extra_property_list)//& + "' read_extra_param_list='"//trim(this%read_extra_param_list)//& + "' property_list_prefixes='"//trim(this%property_list_prefixes)//& + "' min_cutoff="//this%min_cutoff,file=file) + +end subroutine FilePot_Print + +subroutine FilePot_Calc(this, at, energy, local_e, forces, virial, local_virial, args_str, error) + type(FilePot_type), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: energy + real(dp), intent(out), target, optional :: local_e(:) + real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) + real(dp), intent(out), optional :: virial(3,3) + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + character(len=STRING_LENGTH) :: xyzfile, outfile, filename, run_suffix + character(len=STRING_LENGTH) :: my_args_str + integer :: nx, ny, nz, i + type(Atoms) :: sup + integer :: status, n_properties, my_err + character(len=STRING_LENGTH) :: read_extra_property_list, read_extra_param_list, property_list, tmp_properties_array(100) + type(Dictionary) :: cli + logical :: FilePot_log, filename_override + + INIT_ERROR(error) + + if (present(energy)) energy = 0.0_dp + if (present(local_e)) local_e = 0.0_dp + if (present(forces)) forces = 0.0_dp + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) local_virial = 0.0_dp + my_args_str = '' + if (present(args_str)) my_args_str = args_str + + call initialise(cli) + call param_register(cli, "FilePot_log", "T", FilePot_log, help_string="if True, save logfile of all the filepot.xyz and filepot.out") + call param_register(cli, "read_extra_property_list", trim(this%read_extra_property_list), read_extra_property_list, help_string="extra properties to read from filepot.out. Overrides init_args version.") + call param_register(cli, "read_extra_param_list", trim(this%read_extra_param_list), read_extra_param_list, help_string="extra params to read from filepot.out. Overrides init_args version.") + call param_register(cli, "run_suffix", '', run_suffix, help_string="suffix to apply to property names in this%property_list_prefixes") + call param_register(cli, 'filename', 'filepot', filename, has_value_target=filename_override, help_string="seed name for directory and structure files to be used") + + if (.not. param_read_line(cli, my_args_str, ignore_unknown=.true.,task='filepot_calc args_str')) then + RAISE_ERROR("FilePot_calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(cli) + + if(filename_override) then + this%filename = filename + end if + + ! Run external command either if MPI object is not active, or if it is active and we're the + ! master process. Function does not return on any node until external command is finished. + + if (.not. this%mpi%active .or. (this%mpi%active .and. this%mpi%my_proc == 0)) then + + if(this%mpi%active) then + xyzfile=(trim(this%filename)//"."//this%mpi%my_proc//".xyz") + outfile=(trim(this%filename)//"."//this%mpi%my_proc//".out") + else + xyzfile=(trim(this%filename)//".xyz") + outfile=(trim(this%filename)//".out") + end if + + call print("FilePot: filename seed=`"//trim(this%filename)//"'", PRINT_VERBOSE) + call print("FilePot: outfile=`"//trim(outfile)//"'", PRINT_VERBOSE) + call print("FilePot: xyzfile=`"//trim(xyzfile)//"'", PRINT_VERBOSE) + call system_command("rm -f "//trim(outfile), status=status) + if (status /= 0) call print("WARNING: FilePot_calc failed to delete outfile="//trim(outfile)//" before running filepot command", PRINT_ALWAYS) + call system_command("rm -f "//trim(xyzfile)//".idx", status=status) + if (status /= 0) call print("WARNING: FilePot_calc failed to delete index file="//trim(xyzfile)//".idx before running filepot command", PRINT_ALWAYS) + call system_command("rm -f "//trim(outfile)//".idx", status=status) + if (status /= 0) call print("WARNING: FilePot_calc failed to delete index file="//trim(outfile)//".idx before running filepot command", PRINT_ALWAYS) + + ! Do we need to replicate cell to exceed min_cutoff ? + if (this%min_cutoff .fne. 0.0_dp) then + call fit_box_in_cell(this%min_cutoff, this%min_cutoff, this%min_cutoff, at%lattice, nx, ny, nz) + else + nx = 1; ny = 1; nz = 1 + end if + + property_list = this%property_list + if (len_trim(this%property_list_prefixes) /= 0) then + call parse_string(this%property_list_prefixes, ':', tmp_properties_array, n_properties, error=error) + do i=1, n_properties + property_list = trim(property_list)//':'//trim(tmp_properties_array(i))//run_suffix + end do + end if + + if (nx /= 1 .or. ny /= 1 .or. nz /= 1) then + call Print('FilePot: replicating cell '//nx//'x'//ny//'x'//nz//' times.') + call supercell(sup, at, nx, ny, nz) + call write(sup, xyzfile, properties=property_list) + else + call write(at, xyzfile, properties=property_list) + end if + + if (FilePot_log) then + if (nx /= 1 .or. ny /= 1 .or. nz /= 1) then + call write(sup, "FilePot_pos_log.xyz", properties=property_list,append=.true.) + else + call write(at, "FilePot_pos_log.xyz", properties=property_list,append=.true.) + endif + endif + +! call print("FilePot: invoking external command "//trim(this%command)//" "//' '//trim(xyzfile)//" "// & +! trim(outfile)//" on "//at%N//" atoms...") + call print("FilePot: invoking external command "//trim(this%command)//' '//trim(xyzfile)//" "// & + trim(outfile)//" "//trim(this%command_addl_args)//" "//trim(my_args_str)//" on "//at%N//" atoms...") + + ! call the external command here +! call system_command(trim(this%command)//" "//trim(xyzfile)//" "//trim(outfile),status=status) + call system_command(trim(this%command)//' '//trim(xyzfile)//" "//trim(outfile)//" "//& + trim(this%command_addl_args)//" "//trim(my_args_str),status=status) + call print("FilePot: got status " // status // " from external command") + + ! read back output from external command + call filepot_read_output(outfile, at, nx, ny, nz, energy, local_e, forces, virial, local_virial, & + read_extra_property_list, read_extra_param_list, run_suffix, filepot_log=FilePot_log, error=error) + PASS_ERROR_WITH_INFO("Filepot_Calc reading output", error) + end if + + if (this%mpi%active) then + ! Share results with other nodes + if (present(energy)) call bcast(this%mpi, energy) + if (present(local_e)) call bcast(this%mpi, local_e) + + if (present(forces)) call bcast(this%mpi, forces) + if (present(virial)) call bcast(this%mpi, virial) + if (present(local_virial)) call bcast(this%mpi, local_virial) + + call bcast(this%mpi, my_err) + end if + +end subroutine FilePot_calc + +subroutine filepot_read_output(outfile, at, nx, ny, nz, energy, local_e, forces, virial, local_virial, & + read_extra_property_list, read_extra_param_list, run_suffix, filepot_log, error) + character(len=*), intent(in) :: outfile + type(Atoms), intent(inout) :: at + integer, intent(in) :: nx, ny, nz + real(dp), intent(out), optional :: energy + real(dp), intent(out), target, optional :: local_e(:) + real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) + real(dp), intent(out), optional :: virial(3,3) + character(len=*), intent(in) :: read_extra_property_list, read_extra_param_list, run_suffix + logical, intent(in), optional :: filepot_log + integer, intent(out), optional :: error + + character(STRING_LENGTH) :: tmp_params_array(100), copy_keys(100) + integer :: i, n_params, n_copy + type(atoms) :: at_out, primitive + integer, pointer :: Z_p(:) + real(dp) :: virial_1d(9) + real(dp), pointer :: local_e_p(:), forces_p(:,:), local_virial_p(:,:) + logical :: my_filepot_log + + INIT_ERROR(error) + + my_filepot_log = optional_default(.false., filepot_log) + + call print('Filepot: reading back results from file '//trim(outfile)) + call read(at_out, outfile, error=error) + PASS_ERROR(error) + + if (nx /= 1 .or. ny /= 1 .or. nz /= 1) then + ! Discard atoms outside the primitive cell + call select(primitive, at_out, list=(/ (i, i=1,at_out%N/(nx*ny*nz) ) /)) + at_out = primitive + call finalise(primitive) + end if + + call print("FilePot: the following keys were found in the atoms structure:") + call print_keys(at_out%params) + + if (at_out%N /= at%N) then + RAISE_ERROR("filepot_read_output in '"//trim(outfile)//"' got N="//at_out%N//" /= at%N="//at%N, error) + endif + + if (.not. assign_pointer(at_out,'Z',Z_p)) then + RAISE_ERROR("filepot_read_output in '"//trim(outfile)//"' couldn't assign pointer for field Z", error) + endif + do i=1, at%N + if (at%Z(i) /= Z_p(i)) then + RAISE_ERROR("filepot_read_output in '"//trim(outfile)//"' got Z("//i//")="//at_out%Z(i)//" /= at%Z("//i//")="//at%Z(i), error) + endif + end do + + if (present(energy)) then + if (.not. get_value(at_out%params,'energy',energy)) then + RAISE_ERROR("filepot_read_output needed energy, but couldn't find energy in '"//trim(outfile)//"'", error) + endif + ! If cell was repeated, reduce energy by appropriate factor + ! to give energy of primitive cell. + if (nx /= 1 .or. ny /= 1 .or. nz /= 1) & + energy = energy/(nx*ny*nz) + endif + + if (present(virial)) then + if (nx /= 1 .or. ny /= 1 .or. nz /= 1) then + RAISE_ERROR("filepot_read_output: don't know how to rescale virial for repicated system", error) + endif + + if ( get_value(at_out%params,'virial',virial_1d)) then + virial(:,1) = virial_1d(1:3) + virial(:,2) = virial_1d(4:6) + virial(:,3) = virial_1d(7:9) + elseif( .not. get_value(at_out%params,'virial',virial) ) then + RAISE_ERROR("filepot_read_output needed virial, but couldn't find virial in '"//trim(outfile)//"'", error) + endif + endif + + if (present(local_e)) then + if (.not. assign_pointer(at_out, 'local_e', local_e_p)) then + RAISE_ERROR("filepot_read_output needed local_e, but couldn't find local_e in '"//trim(outfile)//"'", error) + endif + local_e = local_e_p + endif + + if (present(forces)) then + if (.not. assign_pointer(at_out, 'force', forces_p)) then + RAISE_ERROR("filepot_read_output needed forces, but couldn't find force in '"//trim(outfile)//"'", error) + endif + forces = forces_p + endif + + if (present(local_virial)) then + if (.not. assign_pointer(at_out, 'local_virial', local_virial_p)) then + RAISE_ERROR("filepot_read_output needed local_virial, but couldn't find local_virial in '"//trim(outfile)//"'", error) + endif + local_virial = local_virial_p + endif + + if (len_trim(read_extra_property_list) > 0) then + call copy_properties(at, at_out, trim(read_extra_property_list)) + endif + + if (len_trim(read_extra_param_list) > 0) then + call parse_string(read_extra_param_list, ':', tmp_params_array, n_params, error=error) + PASS_ERROR(error) + + n_copy = 0 + do i=1,n_params + if (has_key(at_out%params, trim(tmp_params_array(i)))) then + n_copy = n_copy + 1 + copy_keys(n_copy) = tmp_params_array(i) + call print("FilePot copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) + else if (has_key(at_out%params, trim(tmp_params_array(i))//trim(run_suffix))) then + n_copy = n_copy + 1 + copy_keys(n_copy) = trim(tmp_params_array(i))//trim(run_suffix) + call print("FilePot copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) + end if + end do + + call subset(at_out%params, copy_keys(1:n_copy), at%params, out_no_initialise=.true.) + end if + + if (my_filepot_log) then + call write(at_out, "FilePot_out_log.xyz", append=.true.) + endif + + call finalise(at_out) + +end subroutine filepot_read_output + +end module FilePot_module diff --git a/src/Potentials/Functions.F90 b/src/Potentials/Functions.F90 new file mode 100644 index 0000000000..78601fc65b --- /dev/null +++ b/src/Potentials/Functions.F90 @@ -0,0 +1,451 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Functions Module +!X +!% The Functions Module contains useful subroutines and functions +!% to compute the Fermi occupation $n(E)$ of given energy levels, +!% and error functions. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +module functions_module + +use System_module + +implicit none +private + +public erf, erfc +public :: f_Fermi, f_Fermi_deriv, smooth_cutoff + +contains + +!% Calculate the Fermi occupation for en energy level ('E'), +!% at a given temperature ('T'), +!% and chemical potential ('mu'). +elemental function f_Fermi(mu, T, E) + real(dp), intent(in) :: mu, T, E + real(dp) :: f_Fermi + + if (abs(T) < 1.0e-10_dp) then + if (E-mu < 0.0_dp) then + f_Fermi = 1.0_dp + else if (E-mu > 0.0_dp) then + f_Fermi = 0.0_dp + else + f_Fermi = 0.5_dp + endif + else + f_Fermi = 1.0_dp/(1.0_dp+exp((E-mu)/T)) + endif +end function f_Fermi + +elemental function f_Fermi_deriv(mu, T, E) + real(dp), intent(in) :: mu, T, E + real(dp) :: f_Fermi_deriv + + real(dp) :: arg + + if (abs(T) < 1.0e-10_dp) then + f_Fermi_deriv = 0.0_dp + else + arg = abs((E-mu)/T) + f_Fermi_deriv = -1.0_dp/((1.0_dp+exp(-arg))**2 * exp(arg) * T) + endif +end function f_Fermi_deriv + + +!| double precision function erf +!| calculate error function of argument +!| returns error function of argument +!| +!|I double precision x: argument +!| +!| Noam Bernstein 9/12/2001 + +double precision function erf(x) +implicit none + double precision x + + if (x .lt. 0.0D0) then + erf = -gammp_half(x*x) + else + erf = gammp_half(x*x) + end if + +end function + +!| double precision function erfc +!| calculate error function complement of argument +!| returns error function complement of argument +!| +!|I double precision x: argument +!| +!| Noam Bernstein 9/12/2001 + +double precision function erfc(x) +implicit none + double precision x + + if (x .lt. 0.0D0) then + erfc = 1.0D0 + gammp_half(x*x) + else + erfc = gammq_half(x*x) + end if +end function + +!| double precision function gammp_half +!| calculate incomplete gamma p function of (0.5,x) +!| returns incomplete gamma p function of (0.5,x) +!| +!|I double precision x: argument +!| +!| Noam Bernstein 9/12/2001 + +double precision function gammp_half(x) +implicit none + double precision x + + double precision Gamma_half ! = sqrt(pi) + parameter ( Gamma_half = 1.77245385090552D0 ) + + gammp_half = 2.0D0/Gamma_half * sqrt(x) * p_F0(x) + +end function + +!| double precision function gammq_half +!| calculate incomplete gamma q function (complement of gamma p) of (0.5,x) +!| returns incomplete gamma q function (complement of gamma p) of (0.5,x) +!| +!|I double precision x: argument +!| +!| Noam Bernstein 9/12/2001 + +double precision function gammq_half(x) +implicit none + double precision x + + double precision Gamma_half ! = sqrt(pi) + parameter ( Gamma_half = 1.77245385090552D0 ) + + if (x .ne. 0) then + gammq_half = 2.0D0/Gamma_half * sqrt(x) * p_F0C(x) + else + gammq_half = 1.0D0 + end if + +end function + +!| double precision function p_F0(x) +!| calculate F_m(x) for m=0 using FFFMT3 +!| returns value of F_0(x) +!| +!|I double precision x: argument +!| +!| Noam Bernstein 9/13/2001 + +double precision function p_F0(x) +implicit none + double precision x + + double precision xx(1) + double precision s1(1,5) + + xx(1) = x + call FFFMT3_F90(1, 1, xx, s1) + + p_F0 = s1(1,1) + +end function + +!| double precision function p_F0C(x) +!| calculate sqrt(pi/x)/2-F_m(x) for m=0 using FFFMT3C +!| returns value of sqrt(pi/x)/2-F_0(x) +!| +!|I double precision x: argument +!| +!| Noam Bernstein 9/13/2001 + +double precision function p_F0C(x) +implicit none + double precision x + + double precision xx(1) + double precision s1(1,5) + + xx(1) = x + call FFFMT3C_F90(1, 1, xx, s1) + + p_F0C = s1(1,1) + +end function + +!| subroutine FFFMT3_F90(x) +!% Calculate $F_m(x)$ for $m=0$ using 'FFFMT3C' +!| +!|I integer MX, NPTS: maximum, actual number of pts to be evaluated +!|I double precision xx(NPTS): arguments +!|O double precision s1(NPTS,5): returned values +!| +!| Noam Bernstein 9/13/2001 +!| From Mark Pederson's code + +subroutine FFFMT3_F90(MX,NPTS,XX,S1) +! MODIFIED BY MARK R PEDERSON (1990) +! To FORTRAN 90 by Noam Bernstein +implicit none + integer MX, NPTS + double precision XX(MX),S1(MX,5) + + logical, save:: FIRST = .true. + double precision, save:: F(10,1601) + + double precision ONEOVRI(5) + double precision G(20) + + double precision:: ROOTPI = 1.77245385090551602728D0 + double precision:: ONEOVER3 = 1.0D0/3.0D0 + + integer I, L, K, KK, IT, IPTS + double precision T, X, DEN, TERM, SUM, FACT, Q, EPS, EX + double precision RT, POL1, RECT1, DT + + IF (NPTS.GT.MX) THEN + PRINT *,'FFFMT3: MX MUST BE AT LEAST: ',NPTS + stop + END IF + IF (FIRST) THEN + ! ONEOVER3 = 1.0D0/3.0D0 + FACT = 1.0D0 + DO I = 1,5 + ONEOVRI(I) = 1.0D0/I + FACT = FACT*ONEOVRI(I) + END DO + FIRST = .FALSE. + EPS = 1.0D-12 + DO I = 1,10 + F(I,1) = 1.0D0/(2*I-1) + END DO + T = 0.0D0 + DO L = 2,1601 + T = (1.0D-2)*(L-1) + X = 2*T + DEN = 39.0D0 + TERM = 1.0D0/DEN + SUM = TERM + !DO 130 I = 2,100 + DO I = 2,100 + DEN = DEN+2.0D0 + TERM = TERM*X/DEN + SUM = SUM+TERM + Q = TERM/SUM + ! IF (Q-EPS) 140,140,130 + if (Q .le. EPS) exit + END DO + ! 130 CONTINUE + ! 140 EX = EXP(-T) + EX = EXP(-T) + G(20) = EX*SUM + ! + ! USE DOWNWARD RECURSION + ! + DO I = 1,19 + K = 21-I + KK = K-1 + G(KK) = (X*G(K)+EX)/(2*KK-1) + END DO + DO I = 1,10 + F(I,L) = G(I) + END DO + END DO + DO L = 1,1601 + F(5,L) = F(5,L)/2.0D0 + F(6,L) = F(6,L)/6.0D0 + END DO + END IF + ! + DO IPTS = 1,NPTS + IF (XX(IPTS) .GT. 16.0D0) THEN + POL1 = -EXP(-XX(IPTS)) + RT = SQRT(XX(IPTS))*ROOTPI + RECT1 = 0.5D0/XX(IPTS) + S1(IPTS,1) = RECT1*(RT+POL1) + S1(IPTS,2) = RECT1*(S1(IPTS,1)+POL1) + S1(IPTS,3) = RECT1*(3*S1(IPTS,2)+POL1) + ELSE + IT = INT(100*XX(IPTS)+1.5D0) + POL1 = EXP(-XX(IPTS)) + RECT1 = 2*XX(IPTS) + DT = (1.0D-2)*(IT-1)-XX(IPTS) + S1(IPTS,3) = F(3,IT)+DT*(F(4,IT)+DT*(F(5,IT)+DT*F(6,IT))) + S1(IPTS,2) = (S1(IPTS,3)*RECT1+POL1)*ONEOVER3 + S1(IPTS,1) = (S1(IPTS,2)*RECT1+POL1) + END IF + END DO + RETURN +end subroutine + +!| subroutine FFFMT3C_F90(x) +!% Calculate $\frac{1}{2}\sqrt{\frac{\pi}{x}}-F_m(x)$ for $m=0$ using FFFMT3C +!| +!|I integer MX, NPTS: maximum, actual number of pts to be evaluated +!|I double precision xx(NPTS): arguments +!|O double precision s1(NPTS,5): returned values +!| +!| Noam Bernstein 9/13/2001 +!| Modified for F_0(x) complement from Mark Pederson's code + +subroutine FFFMT3C_F90(MX,NPTS,XX,S1) +! MODIFIED BY MARK R PEDERSON (1990) +! To FORTRAN 90 by Noam Bernstein +implicit none + integer MX, NPTS + double precision XX(MX),S1(MX,5) + + logical, save:: FIRST = .true. + double precision, save:: F(10,1601) + + double precision ONEOVRI(5) + double precision G(20) + + double precision:: ROOTPI = 1.77245385090551602728D0 + double precision:: ONEOVER3 = 1.0D0/3.0D0 + + integer I, L, K, KK, IT, IPTS + double precision T, X, DEN, TERM, SUM, FACT, Q, EPS, EX + double precision RT, POL1, RECT1, DT + + IF (NPTS.GT.MX) THEN + PRINT *,'FFFMT3: MX MUST BE AT LEAST: ',NPTS + stop + END IF + IF (FIRST) THEN + ! ONEOVER3 = 1.0D0/3.0D0 + FACT = 1.0D0 + DO I = 1,5 + ONEOVRI(I) = 1.0D0/I + FACT = FACT*ONEOVRI(I) + END DO + FIRST = .FALSE. + EPS = 1.0D-12 + DO I = 1,10 + F(I,1) = 1.0D0/(2*I-1) + END DO + T = 0.0D0 + DO L = 2,1601 + T = (1.0D-2)*(L-1) + X = 2*T + DEN = 39.0D0 + TERM = 1.0D0/DEN + SUM = TERM + !DO 130 I = 2,100 + DO I = 2,100 + DEN = DEN+2.0D0 + TERM = TERM*X/DEN + SUM = SUM+TERM + Q = TERM/SUM + ! IF (Q-EPS) 140,140,130 + if (Q .le. EPS) exit + END DO + ! 130 CONTINUE + ! 140 EX = EXP(-T) + EX = EXP(-T) + G(20) = EX*SUM + ! + ! USE DOWNWARD RECURSION + ! + DO I = 1,19 + K = 21-I + KK = K-1 + G(KK) = (X*G(K)+EX)/(2*KK-1) + END DO + DO I = 1,10 + F(I,L) = G(I) + END DO + END DO + DO L = 1,1601 + F(5,L) = F(5,L)/2.0D0 + F(6,L) = F(6,L)/6.0D0 + END DO + END IF + ! + DO IPTS = 1,NPTS + IF (XX(IPTS) .GT. 16.0D0) THEN + POL1 = -EXP(-XX(IPTS)) + RT = SQRT(XX(IPTS))*ROOTPI + RECT1 = 0.5D0/XX(IPTS) + !! S1(IPTS,1) = RECT1*(RT+POL1) + ! for computing the complement of F0 + S1(IPTS,1) = -RECT1*POL1 + ! S1(IPTS,2) = RECT1*(S1(IPTS,1)+POL1) + ! S1(IPTS,3) = RECT1*(3*S1(IPTS,2)+POL1) + ELSE + IT = INT(100*XX(IPTS)+1.5D0) + POL1 = EXP(-XX(IPTS)) + RECT1 = 2*XX(IPTS) + DT = (1.0D-2)*(IT-1)-XX(IPTS) + S1(IPTS,3) = F(3,IT)+DT*(F(4,IT)+DT*(F(5,IT)+DT*F(6,IT))) + S1(IPTS,2) = (S1(IPTS,3)*RECT1+POL1)*ONEOVER3 + S1(IPTS,1) = (S1(IPTS,2)*RECT1+POL1) + ! for computing the complement of F0 + S1(IPTS,1) = ROOTPI/(2.0D0*sqrt(XX(IPTS))) - S1(IPTS,1) + END IF + END DO + RETURN +end subroutine + + +!% Smooth cutoff function from D.J. Cole \emph{et al.}, J. Chem. Phys. {\bf 127}, 204704 (2007). +subroutine smooth_cutoff(x,R,D,fc,dfc_dx) + + real(dp), intent(in) :: x,R,D + real(dp), intent(out) :: fc,dfc_dx + real(dp), parameter :: pi = dacos(-1.0d0) + + if (x .lt. (R-D)) then + fc = 1.0d0 + dfc_dx = 0.0d0 + return + else if (x .gt. (R+D)) then + fc = 0.0d0 + dfc_dx = 0.0d0 + return + else + fc = 1.0d0 - (x-R+D)/(2.0d0*D) + 1.0d0/(2.0d0*pi)*dsin((pi/D)*(x-R+D)) + dfc_dx = 1.0d0/(2.0d0*D)* (dcos((pi/D)*(x-R+D)) - 1.0d0) + return + end if +end subroutine smooth_cutoff + + +end module functions_module diff --git a/src/Potentials/IP.F90 b/src/Potentials/IP.F90 new file mode 100644 index 0000000000..d16b864484 --- /dev/null +++ b/src/Potentials/IP.F90 @@ -0,0 +1,1155 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IP module +!X +!% General object which manages all the possible interatomic potentials (IP), addressing +!% the calls to the right modules. The available IPs are the following: +!% \begin{itemize} +!% \item Gaussian Approximation Potential ({\bf IPModel_GAP}) +!% \item Lennard-Jones Potential ({\bf IPModel_LJ}) +!% \item Morse Potential ({\bf IPModel_Morse}) +!% \item Force-Constant Potential ({\bf IPModel_FC}) +!% \item Stillinger and Weber Potential for Silicon ({\bf IPModel_SW}) +!% \item Tersoff potential for C/Si/Ge ({\bf IPModel_Tersoff}) +!% \item Embedded Atom Potential of Ercolessi Adam ({\bf IPModel_EAM_ErcolAd}) +!% \item Brenner Potential ({\bf IPModel_Brenner}) +!% \item FB Potential for SiO2 ({\bf IPModel_FB}) +!% \item Silicon Modified Embedded Atom Potentia l ({\bf IPModel_Si_MEAM}) +!% \item Finnis-Sinclair ({\bf IPModel_FS}) +!% \item Bond Order Potential ({\bf IPModel_BOP}) +!% \item Screened Brenner Potential (interface) ({\bf IPModel_Brenner_Screened}) +!% \item 2nd generation Brenner Potential (interface) ({\bf IPModel_Brenner_2002}) +!% \item Partridge-Schwenke potential ({\bf IPModel_PartridgeSchwenke}) +!% \item van der Waals potential ({\bf IPModel_vdW}) +!% \item Einstein crystal potential ({\bf IPModel_Einstein}) +!% \item Coulomb potential ({\bf IPModel_Coulomb}) +!% \item Sutton-Chen potential ({\bf IPModel_Sutton_Chen}) +!% \item Simple potential for an HF dimer ({\bf IPModel_HFdimer}) +!% \item 2-body potential for water dimer ({\bf IPModel_WaterDimer_Gillan}) +!% \item Born-Mayer potential ({\bf IPModel_BornMayer}) +!% \item Customised (hardwired) potential ({\bf IPModel_Custom}) +!% \item Tether a selection of atoms to the origin with a spring ({\bf IPModel_Tether}) +!% \item Fourth-order force-constant potential ({\bf IPModel_FC4}) +!% \item Dispersion correction from Tkatchenko and Scheffler ({\bf IPModel_DispTS}) +!% \item SCME multipole model for water ({\bf IPModel_SCME}) +!% \item MTP potential ({\bf IPModel_MTP}) +!% \item Many-body dispersion ({\bf IPModel_MBD}) +!% \item ZBL potential ({\bf IPModel_ZBL}) +!% \item LinearSOAP potential ({\bf IPModel_LinearSOAP}) +!% \item TTM-nF multipole model for water ({\bf IPModel_nF}) +!% \item CH4 potential ({\bf IPModel_CH4}) +!% \item Confining monomer potential ({\bf IPModel_ConfiningMonomer}) +!% \item Repulsive Step potential ({\bf IPModel_RS}) +!% \item Template potential ({\bf IPModel_Template}) +!% \end{itemize} +!% The IP_type object contains details regarding the selected IP. +!% When a type Potential is defined +!%> type(Potential) :: pot +!% it is then necessary to initialise the IP parameters (readable from an external input file or +!% from an internal string) and to define the IP type: +!%> call Initialise(pot, IP_type, params) +!% where IP_type can be +!% \begin{itemize} +!% \item 'IP GAP' +!% \item 'IP LJ' +!% \item 'IP Morse' +!% \item 'IP FC' +!% \item 'IP SW' +!% \item 'IP Tersoff' +!% \item 'IP EAM_ErcolAd' +!% \item 'IP Brenner' +!% \item 'IP FB' +!% \item 'IP Si_MEAM' +!% \item 'IP FS' +!% \item 'IP BOP' +!% \item 'IP Brenner_Screened' +!% \item 'IP Brenner_2002' +!% \item 'IP PartridgeSchwenke' +!% \item 'IP vdW' +!% \item 'IP Einstein' +!% \item 'IP Coulomb' +!% \item 'IP ConfiningMonomer' +!% \item 'IP Sutton_Chen' +!% \item 'IP HFdimer' +!% \item 'IP BornMayer' +!% \item 'IP_WaterDimer_Gillan' +!% \item 'IP_WaterTrimer_Gillan' +!% \item 'IP Custom' +!% \item 'IP Tether' +!% \item 'IP LMTO_TBE' +!% \item 'IP Multipoles' +!% \item 'IP FC4' +!% \item 'IP DispTS' +!% \item 'IP SCME' +!% \item 'IP MTP' +!% \item 'IP MBD' +!% \item 'IP ZBL' +!% \item 'IP LinearSOAP' +!% \item 'IP TTM_nF' +!% \item 'IP CH4' +!% \item 'IP RS' +!% \item 'IP Template' +!% \end{itemize} +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" +module IP_module + +! use system_module, only : dp +use error_module +use system_module, only : dp, inoutput, initialise, INPUT, print, print_message, PRINT_VERBOSE, PRINT_ALWAYS, system_timer +use units_module +use mpi_context_module +use extendable_str_module +use dictionary_module +use paramreader_module +use atoms_module + +use QUIP_Common_module +use IPModel_GAP_module, only : ipmodel_gap, initialise, finalise, calc, print +use IPModel_LJ_module, only : ipmodel_lj, initialise, finalise, calc, print +use IPModel_Morse_module, only : ipmodel_morse, initialise, finalise, calc, print +use IPModel_FC_module, only : ipmodel_fc, initialise, finalise, calc, print +use IPModel_SW_module, only : ipmodel_sw, initialise, finalise, calc, print +use IPModel_Tersoff_module, only : ipmodel_tersoff, initialise, finalise, calc, print +use IPModel_EAM_ErcolAd_module, only : ipmodel_eam_ercolad, initialise, finalise, calc, print +use IPModel_Brenner_module, only : ipmodel_brenner, initialise, finalise, calc, print +use IPModel_FB_module, only : ipmodel_fb, initialise, finalise, calc, print +use IPModel_Si_MEAM_module, only : ipmodel_si_meam, initialise, finalise, calc, print +use IPModel_FS_module, only : ipmodel_fs, initialise, finalise, calc, print +use IPModel_BOP_module, only : ipmodel_bop, initialise, finalise, calc, print +use IPModel_Brenner_Screened_module, only : ipmodel_brenner_screened, initialise, finalise, calc, print +use IPModel_Brenner_2002_module, only : ipmodel_brenner_2002, initialise, finalise, calc, print +#ifdef HAVE_ASAP +use IPModel_ASAP_module, only : ipmodel_asap, initialise, finalise, calc, print +#endif +use IPModel_TS_module, only : ipmodel_ts, initialise, finalise, calc, print, setup_atoms +use IPModel_Glue_module, only : ipmodel_glue, initialise, finalise, calc, print +use IPModel_PartridgeSchwenke_module, only : ipmodel_partridgeschwenke, initialise, finalise, calc, print +use IPModel_Einstein_module, only : ipmodel_einstein, initialise, finalise, calc, print +use IPModel_Coulomb_module, only : ipmodel_coulomb, initialise, finalise, calc, print +use IPModel_Sutton_Chen_module, only : ipmodel_sutton_chen, initialise, finalise, calc, print +use IPModel_LMTO_TBE_module, only: ipmodel_lmto_tbe, initialise, finalise, calc, print +use IPModel_ZBL_module, only : ipmodel_zbl, initialise, finalise, calc, print +use IPModel_LinearSOAP_module, only: ipmodel_linearsoap, initialise, finalise, calc, print +use IPModel_CH4_module, only : ipmodel_CH4, initialise, finalise, calc, print +#ifdef HAVE_KIM +use IPModel_KIM_module, only : ipmodel_kim, initialise, finalise, calc, print +#endif +use IPModel_FX_module, only : ipmodel_fx, initialise, finalise, calc, print +use IPModel_HFdimer_module, only : ipmodel_hfdimer, initialise, finalise, calc, print +use IPModel_WaterDimer_Gillan_module, only : ipmodel_waterdimer_gillan, initialise, finalise, calc, print +use IPModel_WaterTrimer_Gillan_module, only : ipmodel_watertrimer_gillan, initialise, finalise, calc, print +use IPModel_BornMayer_module, only : ipmodel_bornmayer, initialise, finalise, calc, print +use IPModel_Custom_module, only : ipmodel_custom, initialise, finalise, calc, print +use IPModel_ConfiningMonomer_module, only : ipmodel_confiningmonomer, initialise, finalise, calc, print +use IPModel_Tether_module, only : ipmodel_tether, initialise, finalise, calc, print +use IPModel_Spring_module, only : ipmodel_Spring, initialise, finalise, calc, print +use IPModel_SW_VP_module, only : ipmodel_sw_vp, initialise, finalise, calc, print +use IPModel_Multipoles_module, only : ipmodel_multipoles, initialise, finalise, calc, print +use IPModel_FC4_module, only : ipmodel_fc4, initialise, finalise, calc, print +use IPModel_DispTS_module, only : ipmodel_dispts, initialise, finalise, calc, print +use IPModel_SCME_module, only : ipmodel_scme, initialise, finalise, calc, print +use IPModel_MTP_module, only : ipmodel_mtp, initialise, finalise, calc, print +use IPModel_MBD_module, only : ipmodel_mbd, initialise, finalise, calc, print +use IPModel_TTM_nF_module, only : ipmodel_ttm_nf, initialise, finalise, calc, print +use IPModel_vdW_module, only : ipmodel_vdW, initialise, finalise, calc, print +use IPModel_RS_module, only : ipmodel_rs, initialise, finalise, calc, print +! Add new IP here +use IPModel_Template_module, only : ipmodel_template, initialise, finalise, calc, print + +implicit none + +private + +integer, parameter :: FF_LJ = 1, FF_SW = 2, FF_Tersoff = 3, FF_EAM_ErcolAd = 4, & + FF_Brenner = 5, FF_GAP = 6, FF_FS = 7, FF_BOP = 8, FF_FB = 9, FF_Si_MEAM = 10, FF_Brenner_Screened = 11, & + FF_Brenner_2002 = 12, FF_ASAP = 13, FF_TS = 14, FF_FC = 15, FF_Morse = 16, FF_GLUE = 17, FF_PartridgeSchwenke = 18, & + FF_Einstein = 19, FF_Coulomb = 20, FF_Sutton_Chen = 21, FF_KIM = 22, FF_FX = 23, FF_HFdimer = 24, FF_Custom = 25, FF_SW_VP=26, & + FF_BornMayer = 27, FF_WaterDimer_Gillan=28, FF_WaterTrimer_Gillan=29, FF_Tether=30, FF_LMTO_TBE=31, FF_FC4 = 32, FF_Spring=33, & + FF_Multipoles=34, FF_SCME = 35, FF_MTP = 36, FF_ZBL=37, FF_LinearSOAP=38, & + FF_MBD=39, FF_DispTS=40, FF_TTM_NF = 41, FF_CH4=42, FF_ConfiningMonomer=43, FF_vdW = 44, FF_RS=45, & ! Add new IPs here + FF_Template = 99 + +public :: IP_type +type IP_type + integer :: functional_form = 0 + + type(IPModel_GAP) ip_gap + type(IPModel_LJ) ip_lj + type(IPModel_Morse) ip_morse + type(IPModel_FC) ip_fc + type(IPModel_SW) ip_sw + type(IPModel_Tersoff) ip_Tersoff + type(IPModel_EAM_ErcolAd) ip_EAM_ErcolAd + type(IPModel_Brenner) ip_Brenner + type(IPModel_FB) ip_FB + type(IPModel_Si_MEAM) ip_Si_MEAM + type(IPModel_FS) ip_fs + type(IPModel_BOP) ip_BOP + type(IPModel_Brenner_Screened) ip_Brenner_Screened + type(IPModel_Brenner_2002) ip_Brenner_2002 +#ifdef HAVE_ASAP + type(IPModel_ASAP) ip_ASAP +#endif + type(IPModel_TS) ip_TS + type(IPModel_Glue) ip_Glue + type(IPModel_PartridgeSchwenke) ip_PartridgeSchwenke + type(IPModel_Einstein) ip_Einstein + type(IPModel_Coulomb) ip_Coulomb + type(IPModel_Sutton_Chen) ip_Sutton_Chen +#ifdef HAVE_KIM + type(IPModel_KIM) ip_KIM +#endif + type(IPModel_FX) ip_FX + type(IPModel_BornMayer) ip_BornMayer + type(IPModel_Custom) ip_Custom + type(IPModel_ConfiningMonomer) ip_ConfiningMonomer + type(IPModel_HFdimer) ip_HFdimer + type(IPModel_SW_VP) ip_sw_vp + type(IPModel_WaterDimer_Gillan) ip_waterdimer_gillan + type(IPModel_WaterTrimer_Gillan) ip_watertrimer_gillan + type(IPModel_Tether) ip_Tether + type(IPModel_Spring) ip_Spring + type(IPModel_LMTO_TBE) ip_LMTO_TBE + type(IPModel_Multipoles) ip_Multipoles + type(IPModel_FC4) ip_fc4 + type(IPModel_DispTS) ip_dispts + type(IPModel_SCME) ip_SCME + type(IPModel_MTP) ip_MTP + type(IPModel_ZBL) ip_ZBL + type(IPModel_MBD) ip_MBD + type(IPModel_LinearSOAP) ip_LinearSOAP + type(IPModel_TTM_nF) ip_TTM_nF + ! Add new IP here + type(IPModel_CH4) ip_CH4 + type(IPModel_vdW) ip_vdW + type(IPModel_RS) ip_RS + type(IPModel_Template) ip_Template + type(mpi_context) :: mpi_glob, mpi_local + +end type IP_type + +!% Initialise IP_type object defining the IP model and the corresponding parameters. If necessary +!% it initialises the input file for the potential parameters. +public :: Initialise +public :: IP_Initialise_filename +interface Initialise + module procedure IP_Initialise_inoutput, IP_Initialise_str +end interface Initialise + +public :: Finalise +interface Finalise + module procedure IP_Finalise +end interface Finalise + +!% Return the cutoff of this interatomic potential +public :: cutoff +interface cutoff + module procedure IP_cutoff +end interface + +!% Print the parameters of the selected IP model +public :: Print +interface Print + module procedure IP_Print +end interface Print + +!% Hook routine called before calc() is invoked. Can be used to add required properties. +public :: setup_atoms +interface setup_atoms + module procedure ip_setup_atoms +end interface + +!% Call the potential calculator for the selected IP model +public :: Calc +private :: IP_Calc +interface Calc + module procedure IP_Calc +end interface Calc + +!% set up optimal parameters for parallel computation for a given system +public :: setup_parallel +private :: IP_setup_parallel +interface setup_parallel + module procedure IP_setup_parallel +end interface setup_parallel + +contains + +!% OMIT +subroutine IP_Initialise_filename(this, args_str, filename, mpi_obj, error) + type(IP_type), intent(inout) :: this + character(len=*), intent(in) :: args_str + character(len=*), intent(in) :: filename !% File name containing the IP parameters + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(inoutput) io + + INIT_ERROR(error) + + call Initialise(io, filename, INPUT) + + call Initialise(this, args_str, io, mpi_obj) + + call Finalise(io) + +end subroutine + + +subroutine IP_Initialise_inoutput(this, args_str, io_obj, mpi_obj, error) + type(IP_type), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(inoutput), intent(inout), optional :: io_obj + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(extendable_str) :: ss + + INIT_ERROR(error) + + call Initialise(ss) + if (present(io_obj)) then + if (present(mpi_obj)) then + call read(ss, io_obj%unit, convert_to_string=.true., mpi_comm=mpi_obj%communicator, mpi_id=mpi_obj%my_proc) + else + call read(ss, io_obj%unit, convert_to_string=.true.) + endif + endif + call Initialise(this, args_str, string(ss), mpi_obj) + call Finalise(ss) + +end subroutine IP_Initialise_inoutput + +subroutine IP_Initialise_str(this, args_str, param_str, mpi_obj, error) + type(IP_type), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(Dictionary) :: params + logical is_GAP, is_LJ, is_FC, is_Morse, is_SW, is_Tersoff, is_EAM_ErcolAd, is_Brenner, is_FS, is_BOP, is_FB, is_Si_MEAM, & + is_Brenner_Screened, is_Brenner_2002, is_ASAP, is_TS, is_Glue, is_PartridgeSchwenke, is_Einstein, is_Coulomb, & + is_Sutton_Chen, is_KIM, is_FX, is_HFdimer, is_BornMayer, is_Custom, is_SW_VP, is_WaterDimer_Gillan , & + is_WaterTrimer_Gillan, is_Tether, is_Spring, is_LMTO_TBE, is_FC4 , is_Multipoles, is_SCME, is_MTP, & + is_MBD, is_ZBL, is_LinearSOAP, is_DispTS, is_TTM_nF, is_CH4, is_ConfiningMonomer, is_vdW, is_RS, &! Add new IPs here + is_Template + + INIT_ERROR(error) + + call Finalise(this) + + call initialise(params) + call param_register(params, 'GAP', 'false', is_GAP, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'LJ', 'false', is_LJ, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Morse', 'false', is_Morse, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'FC', 'false', is_FC, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SW', 'false', is_SW, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Tersoff', 'false', is_Tersoff, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'EAM_ErcolAd', 'false', is_EAM_ErcolAd, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Brenner', 'false', is_Brenner, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'FB', 'false', is_FB, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Si_MEAM', 'false', is_Si_MEAM, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'FS', 'false', is_FS, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'BOP', 'false', is_BOP, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Brenner_Screened', 'false', is_Brenner_Screened, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Brenner_2002', 'false', is_Brenner_2002, help_string="No help yet. This source file was $LastChangedBy$") +#ifdef HAVE_ASAP + call param_register(params, 'ASAP', 'false', is_ASAP, help_string="No help yet. This source file was $LastChangedBy$") +#else + is_ASAP = .false. +#endif + call param_register(params, 'TS', 'false', is_TS, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Glue', 'false', is_Glue, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'PartridgeSchwenke', 'false', is_PartridgeSchwenke, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Einstein', 'false', is_Einstein, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Coulomb', 'false', is_Coulomb, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Sutton_Chen', 'false', is_Sutton_Chen, help_string="No help yet. This source file was $LastChangedBy$") +#ifdef HAVE_KIM + call param_register(params, 'KIM', 'false', is_KIM, help_string="No help yet. This source file was $LastChangedBy$") +#else + is_KIM = .false. +#endif + call param_register(params, 'FX', 'false', is_FX, help_string="Fanourgakis-Xantheas model of water") + call param_register(params, 'BornMayer', 'false', is_BornMayer, help_string="Born-Mayer potential") + call param_register(params, 'Custom', 'false', is_Custom, help_string="Customised (hard wired) potential") + call param_register(params, 'ConfiningMonomer', 'false', is_ConfiningMonomer, help_string="Confining potential for monomers, currently hardcoded for CH4") + call param_register(params, 'HFdimer', 'false', is_HFdimer, help_string="HF dimer potential") + call param_register(params, 'SW_VP', 'false', is_SW_VP, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'WaterDimer_Gillan', 'false', is_WaterDimer_Gillan, help_string='Water Dimer 2-body potential by Mike Gillan') + call param_register(params, 'WaterTrimer_Gillan', 'false', is_WaterTrimer_Gillan, help_string='Water Trimer 3-body potential by Mike Gillan') + call param_register(params, 'Tether', 'false', is_Tether, help_string="Tether a selection of atoms to the origin with a spring") + call param_register(params, 'Spring', 'false', is_Spring, help_string="Tether a selection of atoms to each other with a spring") + call param_register(params, 'LMTO_TBE', 'false', is_LMTO_TBE, help_string="Interface to LMTO empirical Tight Binding code") + call param_register(params, 'Multipoles', 'false', is_Multipoles, help_string="Electrostatics including charges, dipoles, polarisabilities") + call param_register(params, 'FC4', 'false', is_FC4, help_string="Fourth-order force-constant potential of Esfarjani et al") + call param_register(params, 'DispTS', 'false', is_DispTS, help_string="Dispersion correction from Tkatchenko and Scheffler (PRL, 2009)") + call param_register(params, 'SCME', 'false', is_SCME, help_string="SCME water potential") + call param_register(params, 'MTP', 'false', is_MTP, help_string="MTP potential") + call param_register(params, 'MBD', 'false', is_MBD, help_string="Many-body dispersion correction") + call param_register(params, 'ZBL', 'false', is_ZBL, help_string="ZBL potential") + call param_register(params, 'TTM_nF', 'false', is_TTM_nF, help_string="TTM_nF water potentials") + call param_register(params, 'LinearSOAP', 'false', is_LinearSOAP, help_string="LinearSOAP potential") + ! Add new IP here + call param_register(params, 'CH4', 'false', is_CH4, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'vdW', 'false', is_vdW, help_string="van der Waals correction") + call param_register(params, 'RS', 'false', is_RS, help_string="Repulsive Step potential") + call param_register(params, 'Template', 'false', is_Template, help_string="No help yet. This source file was $LastChangedBy$") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IP_Initialise_str args_str')) then + RAISE_ERROR("IP_Initialise_str failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if (count((/is_GAP, is_LJ, is_FC, is_Morse, is_SW, is_Tersoff, is_EAM_ErcolAd, is_Brenner, is_FS, is_BOP, is_FB, is_Si_MEAM, & + is_Brenner_Screened, is_Brenner_2002, is_ASAP, is_TS, is_Glue, is_PartridgeSchwenke, is_Einstein, is_Coulomb, & + is_Sutton_Chen, is_KIM, is_FX, is_HFdimer, is_BornMayer, is_Custom, is_SW_VP, is_WaterDimer_Gillan,is_WaterTrimer_Gillan, & + is_Tether, is_Spring, is_LMTO_TBE, is_FC4, is_Multipoles, is_DispTS, is_SCME, is_MTP, is_MBD, is_ZBL,is_linearSOAP, & + is_TTM_nF, is_CH4, is_ConfiningMonomer, is_vdW, is_RS, & ! add new IPs here + is_Template /)) /= 1) then + RAISE_ERROR("IP_Initialise_str found too few or too many IP Model types args_str='"//trim(args_str)//"'", error) + endif + + if (is_GAP) then + this%functional_form = FF_GAP + call Initialise(this%ip_gap, args_str, param_str) + else if (is_LJ) then + this%functional_form = FF_LJ + call Initialise(this%ip_lj, args_str, param_str) + else if (is_Morse) then + this%functional_form = FF_Morse + call Initialise(this%ip_morse, args_str, param_str) + else if (is_FC) then + this%functional_form = FF_FC + call Initialise(this%ip_fc, args_str, param_str) + else if (is_SW) then + this%functional_form = FF_SW + call Initialise(this%ip_sw, args_str, param_str) + else if (is_Tersoff) then + this%functional_form = FF_Tersoff + call Initialise(this%ip_tersoff, args_str, param_str) + else if (is_EAM_ErcolAd) then + this%functional_form = FF_EAM_ErcolAd + call Initialise(this%ip_EAM_ErcolAd, args_str, param_str) + else if (is_Brenner) then + this%functional_form = FF_Brenner + call Initialise(this%ip_Brenner, args_str, param_str) + else if (is_FB) then + this%functional_form = FF_FB + call Initialise(this%ip_FB, args_str, param_str) + else if (is_Si_MEAM) then + this%functional_form = FF_Si_MEAM + call Initialise(this%ip_Si_MEAM, args_str, param_str) + else if (is_FS) then + this%functional_form = FF_FS + call Initialise(this%ip_fs, args_str, param_str) + else if (is_BOP) then + this%functional_form = FF_BOP + call Initialise(this%ip_bop, args_str, param_str) + else if (is_Brenner_Screened) then + this%functional_form = FF_Brenner_Screened + call Initialise(this%ip_brenner_screened, args_str, param_str) + else if (is_Brenner_2002) then + this%functional_form = FF_Brenner_2002 + call Initialise(this%ip_brenner_2002, args_str, param_str) +#ifdef HAVE_ASAP + else if (is_ASAP) then + this%functional_form = FF_ASAP + call Initialise(this%ip_ASAP, args_str, param_str) +#endif + else if (is_TS) then + this%functional_form = FF_TS + call Initialise(this%ip_TS, args_str, param_str) + else if (is_Glue) then + this%functional_form = FF_GLUE + call Initialise(this%ip_Glue, args_str, param_str) + else if (is_PartridgeSchwenke) then + this%functional_form = FF_PartridgeSchwenke + call Initialise(this%ip_PartridgeSchwenke, args_str, param_str) + else if (is_Einstein) then + this%functional_form = FF_Einstein + call Initialise(this%ip_Einstein, args_str, param_str) + else if (is_Coulomb) then + this%functional_form = FF_Coulomb + call Initialise(this%ip_Coulomb, args_str, param_str) + else if (is_Sutton_Chen) then + this%functional_form = FF_Sutton_Chen + call Initialise(this%ip_Sutton_Chen, args_str, param_str) +#ifdef HAVE_KIM + else if (is_KIM) then + this%functional_form = FF_KIM + call Initialise(this%ip_KIM, args_str, param_str) +#endif + else if (is_FX) then + this%functional_form = FF_FX + call Initialise(this%ip_fx, args_str, param_str) + else if (is_BornMayer) then + this%functional_form = FF_BornMayer + call Initialise(this%ip_bornmayer, args_str, param_str) + else if (is_Custom) then + this%functional_form = FF_Custom + call Initialise(this%ip_custom, args_str, param_str) + else if (is_ConfiningMonomer) then + this%functional_form = FF_ConfiningMonomer + call Initialise(this%ip_confiningmonomer, args_str, param_str) + else if (is_HFdimer) then + this%functional_form = FF_HFdimer + call Initialise(this%ip_HFdimer, args_str, param_str) + else if (is_SW_VP) then + this%functional_form = FF_SW_VP + call Initialise(this%ip_sw_vp, args_str, param_str) + else if (is_WaterDimer_Gillan) then + this%functional_form = FF_WaterDimer_Gillan + call Initialise(this%ip_waterdimer_gillan, args_str, param_str) + else if (is_WaterTrimer_Gillan) then + this%functional_form = FF_WaterTrimer_Gillan + call Initialise(this%ip_watertrimer_gillan, args_str, param_str) + else if (is_Tether) then + this%functional_form = FF_Tether + call Initialise(this%ip_tether, args_str, param_str) + else if (is_Spring) then + this%functional_form = FF_Spring + call Initialise(this%ip_Spring, args_str, param_str) + else if (is_LMTO_TBE) then + this%functional_form = FF_LMTO_TBE + call Initialise(this%ip_LMTO_TBE, args_str, param_str) + else if (is_FC4) then + this%functional_form = FF_FC4 + call Initialise(this%ip_FC4, args_str, param_str) + else if (is_Multipoles) then + this%functional_form = FF_Multipoles + call Initialise(this%ip_Multipoles, args_str, param_str) + else if (is_DispTS) then + this%functional_form = FF_DispTS + call Initialise(this%ip_dispts, args_str, param_str) + else if (is_SCME) then + this%functional_form = FF_SCME + call Initialise(this%ip_SCME, args_str, param_str) + else if (is_MTP) then + this%functional_form = FF_MTP + call Initialise(this%ip_MTP, args_str, param_str) + else if (is_MBD) then + this%functional_form = FF_MBD + call Initialise(this%ip_MBD, args_str, param_str) + else if (is_ZBL) then + this%functional_form = FF_ZBL + call Initialise(this%ip_ZBL, args_str, param_str) + else if (is_LinearSOAP) then + this%functional_form = FF_LinearSOAP + call Initialise(this%ip_LinearSOAP, args_str, param_str) + else if (is_TTM_nF) then + this%functional_form = FF_TTM_nF + call Initialise(this%ip_TTM_nF, args_str, param_str) + else if (is_CH4) then + this%functional_form = FF_CH4 + call Initialise(this%ip_CH4, args_str, param_str) + else if (is_vdW) then + this%functional_form = FF_vdW + call Initialise(this%ip_vdW, args_str, param_str) + else if (is_RS) then + this%functional_form = FF_RS + call Initialise(this%ip_RS, args_str, param_str) + ! Add new IP here + else if (is_Template) then + this%functional_form = FF_Template + call Initialise(this%ip_Template, args_str, param_str) + end if + + if (present(mpi_obj)) this%mpi_glob = mpi_obj + +end subroutine IP_Initialise_str + +subroutine IP_Finalise(this) + type(IP_type), intent(inout) :: this + + if (this%mpi_local%active) call free_context(this%mpi_local) + select case (this%functional_form) + case (FF_GAP) + call Finalise(this%ip_gap) + case (FF_LJ) + call Finalise(this%ip_lj) + case (FF_Morse) + call Finalise(this%ip_morse) + case (FF_FC) + call Finalise(this%ip_fc) + case (FF_SW) + call Finalise(this%ip_sw) + case (FF_Tersoff) + call Finalise(this%ip_tersoff) + case (FF_EAM_ErcolAd) + call Finalise(this%ip_EAM_ErcolAd) + case(FF_Brenner) + call Finalise(this%ip_Brenner) + case(FF_FB) + call Finalise(this%ip_fb) + case(FF_Si_MEAM) + call Finalise(this%ip_Si_MEAM) + case (FF_FS) + call Finalise(this%ip_fs) + case (FF_BOP) + call Finalise(this%ip_bop) + case (FF_Brenner_Screened) + call Finalise(this%ip_brenner_screened) + case (FF_Brenner_2002) + call Finalise(this%ip_brenner_2002) +#ifdef HAVE_ASAP + case (FF_ASAP) + call Finalise(this%ip_ASAP) +#endif + case (FF_TS) + call Finalise(this%ip_TS) + case (FF_GLUE) + call Finalise(this%ip_Glue) + case (FF_PartridgeSchwenke) + call Finalise(this%ip_PartridgeSchwenke) + case (FF_Einstein) + call Finalise(this%ip_Einstein) + case (FF_Coulomb) + call Finalise(this%ip_Coulomb) + case (FF_Sutton_Chen) + call Finalise(this%ip_Sutton_Chen) +#ifdef HAVE_KIM + case (FF_KIM) + call Finalise(this%ip_KIM) +#endif + case (FF_FX) + call Finalise(this%ip_FX) + case(FF_BornMayer) + call Finalise(this%ip_BornMayer) + case (FF_Custom) + call Finalise(this%ip_Custom) + case (FF_ConfiningMonomer) + call Finalise(this%ip_confiningmonomer) + case (FF_HFdimer) + call Finalise(this%ip_HFdimer) + case (FF_SW_VP) + call Finalise(this%ip_sw_vp) + case (FF_WaterDimer_Gillan) + call Finalise(this%ip_waterdimer_gillan) + case (FF_WaterTrimer_Gillan) + call Finalise(this%ip_watertrimer_gillan) + case (FF_Tether) + call Finalise(this%ip_Tether) + case (FF_Spring) + call Finalise(this%ip_Spring) + case (FF_LMTO_TBE) + call Finalise(this%ip_LMTO_TBE) + case (FF_FC4) + call Finalise(this%ip_FC4) + case (FF_Multipoles) + call Finalise(this%ip_Multipoles) + case (FF_DispTS) + call Finalise(this%ip_dispts) + case (FF_SCME) + call Finalise(this%ip_SCME) + case (FF_MTP) + call Finalise(this%ip_MTP) + case (FF_MBD) + call Finalise(this%ip_MBD) + case (FF_ZBL) + call Finalise(this%ip_ZBL) + case (FF_LinearSOAP) + call Finalise(this%ip_LinearSOAP) + case (FF_TTM_nF) + call Finalise(this%ip_TTM_nF) + case (FF_CH4) + call Finalise(this%ip_CH4) + case (FF_vdW) + call Finalise(this%ip_vdW) + case (FF_RS) + call Finalise(this%ip_RS) + ! add new IP here + case (FF_Template) + call Finalise(this%ip_Template) + end select + +end subroutine IP_Finalise + +function IP_cutoff(this) + type(IP_type), intent(in) :: this + real(dp) :: IP_cutoff + + select case (this%functional_form) + case (FF_GAP) + IP_cutoff = this%ip_gap%cutoff + case (FF_LJ) + IP_cutoff = this%ip_lj%cutoff + case (FF_Morse) + IP_cutoff = this%ip_morse%cutoff + case (FF_FC) + IP_cutoff = this%ip_fc%cutoff + case (FF_SW) + IP_cutoff = this%ip_sw%cutoff + case (FF_Tersoff) + IP_cutoff = this%ip_tersoff%cutoff + case (FF_EAM_ErcolAd) + IP_cutoff = this%ip_EAM_ErcolAd%cutoff + case(FF_Brenner) + IP_cutoff = this%ip_Brenner%cutoff + case(FF_FB) + IP_cutoff = this%ip_FB%cutoff + case(FF_Si_MEAM) + IP_cutoff = this%ip_Si_MEAM%cutoff + case (FF_FS) + IP_cutoff = this%ip_fs%cutoff + case (FF_BOP) + IP_cutoff = this%ip_bop%cutoff + case (FF_Brenner_Screened) + IP_cutoff = this%ip_brenner_screened%cutoff + case (FF_Brenner_2002) + IP_cutoff = this%ip_brenner_2002%cutoff +#ifdef HAVE_ASAP + case (FF_ASAP) + IP_cutoff = max(this%ip_asap%cutoff_ms, this%ip_asap%cutoff_coulomb)*BOHR +#endif + case (FF_TS) + IP_cutoff = max(this%ip_TS%cutoff_ms, this%ip_TS%cutoff_coulomb)*BOHR + case (FF_GLUE) + IP_cutoff = this%ip_Glue%cutoff + case (FF_PartridgeSchwenke) + IP_cutoff = this%ip_PartridgeSchwenke%cutoff + case (FF_Einstein) + IP_cutoff = this%ip_Einstein%cutoff + case (FF_Coulomb) + IP_cutoff = this%ip_Coulomb%cutoff + case (FF_Sutton_Chen) + IP_cutoff = this%ip_Sutton_Chen%cutoff +#ifdef HAVE_KIM + case (FF_KIM) + IP_cutoff = this%ip_kim%cutoff +#endif + case (FF_FX) + IP_cutoff = this%ip_fx%cutoff + case (FF_BornMayer) + IP_cutoff = this%ip_BornMayer%cutoff + case (FF_Custom) + IP_cutoff = this%ip_custom%cutoff + case (FF_ConfiningMonomer) + IP_cutoff = this%ip_confiningmonomer%cutoff + case (FF_HFdimer) + IP_cutoff = this%ip_HFdimer%cutoff + case (FF_SW_VP) + IP_cutoff = this%ip_sw_vp%cutoff + case (FF_WaterDimer_Gillan) + IP_cutoff = this%ip_waterdimer_gillan%cutoff + case (FF_WaterTrimer_Gillan) + IP_cutoff = this%ip_watertrimer_gillan%cutoff + case (FF_Tether) + IP_cutoff = this%ip_tether%cutoff + case (FF_Spring) + IP_cutoff = this%ip_Spring%cutoff + case(FF_LMTO_TBE) + IP_cutoff = this%ip_LMTO_TBE%cutoff + case(FF_FC4) + IP_cutoff = this%ip_FC4%cutoff + case (FF_Multipoles) + IP_cutoff = this%ip_multipoles%cutoff + case (FF_DispTS) + IP_cutoff = this%ip_dispts%cutoff + case (FF_SCME) + IP_cutoff = this%ip_SCME%cutoff + case (FF_MTP) + IP_cutoff = this%ip_MTP%cutoff + case (FF_MBD) + IP_cutoff = this%ip_MBD%cutoff + case (FF_ZBL) + IP_cutoff = this%ip_ZBL%cutoff + case (FF_LinearSOAP) + IP_cutoff = this%ip_LinearSOAP%cutoff + case (FF_TTM_nF) + IP_cutoff = this%ip_TTM_nF%cutoff + case (FF_CH4) + IP_cutoff = this%ip_CH4%cutoff + case (FF_vdW) + IP_cutoff = this%ip_vdW%cutoff + case (FF_RS) + IP_cutoff = this%ip_RS%cutoff + ! Add new IP here + case (FF_Template) + IP_cutoff = this%ip_Template%cutoff + case default + IP_cutoff = 0.0_dp + end select +end function IP_cutoff + +subroutine IP_setup_atoms(this, at) + type(IP_type), intent(in) :: this + type(Atoms), intent(inout) :: at + + select case (this%functional_form) + case (FF_TS) + call setup_atoms(this%ip_TS, at) + end select + +end subroutine IP_setup_atoms + +subroutine IP_Calc(this, at, energy, local_e, f, virial, local_virial, args_str, error) + type(IP_type), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: energy, local_e(:) !% \texttt{energy} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) + real(dp), intent(out), optional :: virial(3,3) + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + type(Dictionary) :: params + integer :: pgroup_size + integer :: n_groups + logical :: has_pgroup_size = .false. + logical :: do_auto_pgroups = .true. + + INIT_ERROR(error) + + call initialise(params) + call param_register(params, 'pgroup_size', '0', pgroup_size, has_value_target=has_pgroup_size, & + help_string="Explicitly specify the parallel group size, i.e. the number of & + MPI processes") + if (present(args_str)) then + if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='IP_Calc')) then + call system_abort("IP_Calc failed to parse args_str " // args_str) + endif + endif + call finalise(params) + + call system_timer("IP_Calc") + + if (this%mpi_glob%active .and. .not. this%mpi_local%active) then + do_auto_pgroups = .true. + if (has_pgroup_size) then + if ((pgroup_size > 0) .and. (pgroup_size <= this%mpi_glob%n_procs)) then + n_groups = this%mpi_glob%n_procs / pgroup_size + if (n_groups * pgroup_size == this%mpi_glob%n_procs) then + do_auto_pgroups = .false. + else + call print_message('WARNING', "Invalid parallel group size specified: " // pgroup_size) + call print_message('WARNING', "Falling back to automatic selection") + endif + else + call print_message('WARNING', "Invalid parallel group size specified: " // pgroup_size) + call print_message('WARNING', "Falling back to automatic selection") + endif + endif + if (do_auto_pgroups) then + call setup_parallel(this, at, energy, local_e, f, virial, local_virial) + else + call setup_parallel_groups(this, this%mpi_glob, pgroup_size) + endif + endif + + select case (this%functional_form) + case (FF_GAP) + call calc(this%ip_gap, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_LJ) + call calc(this%ip_lj, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + PASS_ERROR(error) + case (FF_Morse) + call calc(this%ip_morse, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_FC) + call calc(this%ip_fc, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_SW) + call calc(this%ip_sw, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Tersoff) + call calc(this%ip_tersoff, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_EAM_ErcolAd) + call calc(this%ip_EAM_ErcolAd, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case(FF_Brenner) + call calc(this%ip_Brenner, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case(FF_FB) + call calc(this%ip_FB, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case(FF_Si_MEAM) + call calc(this%ip_Si_MEAM, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_FS) + call calc(this%ip_fs, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_BOP) + call calc(this%ip_bop, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Brenner_Screened) + call calc(this%ip_brenner_screened, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Brenner_2002) + call calc(this%ip_brenner_2002, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) +#ifdef HAVE_ASAP + case (FF_ASAP) + call calc(this%ip_asap, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) +#endif + case (FF_TS) + call calc(this%ip_TS, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_GLUE) + call calc(this%ip_Glue, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_PartridgeSchwenke) + call calc(this%ip_PartridgeSchwenke, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Einstein) + call calc(this%ip_Einstein, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Coulomb) + call calc(this%ip_Coulomb, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Sutton_Chen) + call calc(this%ip_Sutton_Chen, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) +#ifdef HAVE_KIM + case (FF_KIM) + call calc(this%ip_KIM, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + PASS_ERROR(error) +#endif + case (FF_FX) + call calc(this%ip_FX, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_BornMayer) + call calc(this%ip_BornMayer, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Custom) + call calc(this%ip_Custom, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_ConfiningMonomer) + call calc(this%ip_confiningmonomer, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_HFdimer) + call calc(this%ip_HFdimer, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_SW_VP) + call calc(this%ip_sw_vp, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_WaterDimer_Gillan) + call calc(this%ip_waterdimer_gillan, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_WaterTrimer_Gillan) + call calc(this%ip_watertrimer_gillan, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Tether) + call calc(this%ip_Tether, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Spring) + call calc(this%ip_Spring, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_LMTO_TBE) + call calc(this%ip_LMTO_TBE, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_FC4) + call calc(this%ip_FC4, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_Multipoles) + call calc(this%ip_Multipoles, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_DispTS) + call calc(this%ip_dispts, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_SCME) + call calc(this%ip_SCME, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_MTP) + call calc(this%ip_MTP, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_MBD) + call calc(this%ip_MBD, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_ZBL) + call calc(this%ip_ZBL, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_LinearSOAP) + call calc(this%ip_LinearSOAP, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_TTM_nF) + call calc(this%ip_TTM_nF, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_CH4) + call calc(this%ip_CH4, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_vdW) + call calc(this%ip_vdW, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case (FF_RS) + call calc(this%ip_RS, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + ! Add new IP here + case (FF_Template) + call calc(this%ip_Template, at, energy, local_e, f, virial, local_virial, args_str, mpi=this%mpi_local, error=error) + case default + RAISE_ERROR("IP_Calc confused by functional_form " // this%functional_form, error) + end select + + call system_timer("IP_Calc") +end subroutine IP_Calc + + +subroutine IP_Print(this, file, dict, error) + type(IP_type), intent(inout) :: this + type(Inoutput), intent(inout),optional :: file + type(Dictionary), intent(inout), optional :: dict + integer, intent(out), optional :: error + + INIT_ERROR(error) + + call Print ("IP : " // this%functional_form, file=file) + + select case (this%functional_form) + case (FF_GAP) + call Print(this%ip_gap, file=file, dict=dict) + case (FF_LJ) + call Print(this%ip_lj, file=file) + case (FF_Morse) + call Print(this%ip_morse, file=file) + case (FF_FC) + call Print(this%ip_fc, file=file) + case (FF_SW) + call Print(this%ip_sw, file=file) + case (FF_Tersoff) + call Print(this%ip_tersoff, file=file) + case (FF_EAM_ErcolAd) + call Print(this%ip_EAM_ErcolAd, file=file) + case (FF_Brenner) + call Print(this%ip_Brenner, file=file) + case (FF_FB) + call Print(this%ip_FB, file=file) + case (FF_Si_MEAM) + call Print(this%ip_Si_MEAM, file=file) + case (FF_FS) + call Print(this%ip_fs, file=file) + case (FF_BOP) + call Print(this%ip_bop, file=file) + case (FF_Brenner_Screened) + call Print(this%ip_brenner_screened, file=file) + case (FF_Brenner_2002) + call Print(this%ip_brenner_2002, file=file) +#ifdef HAVE_ASAP + case (FF_ASAP) + call Print(this%ip_asap, file=file) +#endif + case (FF_TS) + call Print(this%ip_TS, file=file) + case (FF_GLUE) + call Print(this%ip_Glue, file=file) + case (FF_PartridgeSchwenke) + call Print(this%ip_PartridgeSchwenke, file=file) + case (FF_Einstein) + call Print(this%ip_Einstein, file=file) + case (FF_Coulomb) + call Print(this%ip_Coulomb, file=file) + case (FF_Sutton_Chen) + call Print(this%ip_Sutton_Chen, file=file) +#ifdef HAVE_KIM + case (FF_KIM) + call Print(this%ip_kim, file=file) +#endif + case (FF_FX) + call Print(this%ip_fx, file=file) + case (FF_BornMayer) + call Print(this%ip_BornMayer, file=file) + case (FF_Custom) + call Print(this%ip_custom, file=file) + case (FF_ConfiningMonomer) + call Print(this%ip_confiningmonomer, file=file) + case (FF_HFdimer) + call Print(this%ip_HFdimer, file=file) + case (FF_SW_VP) + call Print(this%ip_sw_vp, file=file) + case (FF_WaterDimer_Gillan) + call Print(this%ip_waterdimer_gillan, file=file) + case (FF_WaterTrimer_Gillan) + call Print(this%ip_watertrimer_gillan, file=file) + case (FF_Tether) + call Print(this%ip_tether, file=file) + case (FF_Spring) + call Print(this%ip_Spring, file=file) + case (FF_LMTO_TBE) + call Print(this%ip_LMTO_TBE, file=file) + case (FF_FC4) + call Print(this%ip_FC4, file=file) + case (FF_Multipoles) + call Print(this%ip_Multipoles, file=file) + case (FF_DispTS) + call Print(this%ip_dispts, file=file) + case (FF_SCME) + call Print(this%ip_SCME, file=file) + case (FF_MTP) + call Print(this%ip_MTP, file=file) + case (FF_MBD) + call Print(this%ip_MBD, file=file) + case (FF_ZBL) + call Print(this%ip_ZBL, file=file) + case (FF_LinearSOAP) + call Print(this%ip_LinearSOAP, file=file) + case (FF_TTM_nF) + call Print(this%ip_TTM_nF, file=file) + case (FF_CH4) + call Print(this%ip_CH4, file=file) + case (FF_vdW) + call Print(this%ip_vdW, file=file) + case (FF_RS) + call Print(this%ip_RS, file=file) + ! add new IP here + case (FF_Template) + call Print(this%ip_Template, file=file) + case default + RAISE_ERROR("IP_Print confused by functional_form " // this%functional_form, error) + end select + +end subroutine IP_Print + +subroutine IP_setup_parallel(this, at, energy, local_e, f, virial, local_virial, args_str) + type(IP_type), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: energy, local_e(:) !% \texttt{energy} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), intent(in), optional :: args_str + + + integer :: pgroup_size, prev_pgroup_size + integer :: n_groups + real(dp) :: prev_time, this_time + + prev_time = 1.0e38_dp + prev_pgroup_size = 0 + + call print('IP_Setup_Parallel timings', PRINT_VERBOSE) + call print('IP_Setup_Parallel group_size time/sec', PRINT_VERBOSE) + + call print("IP_Setup_Parallel at%N "//at%N// " present(energy) "//present(energy)// " present(local_e) "//present(local_e)// " present(f) "//present(f)// " present(virial) "//present(virial)// " present(local_virial) "//present(local_virial), PRINT_VERBOSE) + + call setup_atoms(this, at) + do pgroup_size=this%mpi_glob%n_procs, 1, -1 + n_groups = this%mpi_glob%n_procs / pgroup_size + if (n_groups*pgroup_size == this%mpi_glob%n_procs) then + call setup_parallel_groups(this, this%mpi_glob, pgroup_size) + call system_timer("IP_parallel", do_always = .true., do_print = .false.) + call calc(this, at, energy, local_e, f, virial, local_virial, args_str) + call system_timer("IP_parallel", do_always = .true., time_elapsed = this_time, do_print = .false.) + this_time = max(this%mpi_glob, this_time) + call print("IP_Setup_Parallel "//pgroup_size//' '//this_time, PRINT_VERBOSE) + if (this_time > prev_time) then + call setup_parallel_groups(this, this%mpi_glob, prev_pgroup_size) + exit + else + prev_time = this_time + prev_pgroup_size = pgroup_size + endif + endif + end do + + call print("Parallelizing IP using group_size " // prev_pgroup_size, PRINT_ALWAYS) +end subroutine IP_setup_parallel + +subroutine setup_parallel_groups(this, mpi, pgroup_size, error) + type(IP_type), intent(inout) :: this + type(mpi_context), intent(in) :: mpi + integer, intent(in) :: pgroup_size + integer, intent(out), optional :: error + + integer :: split_index + + INIT_ERROR(error) + + if (this%mpi_local%active) call free_context(this%mpi_local) + + if (mpi%active) then + split_index = mpi%my_proc/pgroup_size + call split_context(mpi, split_index, this%mpi_local) + endif + +end subroutine setup_parallel_groups + +end module IP_module diff --git a/src/Potentials/IPEwald.F90 b/src/Potentials/IPEwald.F90 new file mode 100644 index 0000000000..8aadd83514 --- /dev/null +++ b/src/Potentials/IPEwald.F90 @@ -0,0 +1,554 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPEwald_module + +use error_module +use system_module, only : dp, optional_default, PRINT_ANALYSIS, operator(//) +use units_module +use Atoms_module +use linearalgebra_module +use functions_module + +implicit none + +real(dp), parameter :: reciprocal_time_by_real_time = 1.0_dp / 3.0_dp + +private +public :: Ewald_calc, Ewald_corr_calc, Direct_Coulomb_Calc, DSF_Coulomb_calc + +contains + + ! Ewald routine + ! input: atoms object, has to have charge property + ! input, optional: ewald_error (controls speed and ewald_error) + ! input, optional: use_ewald_cutoff (forces original cutoff to be used) + ! output: energy, force, virial + + ! procedure to determine optimal Ewald parameters: + ! Optimization of the Ewald sum for large systems, Mol. Simul. 13 (1994), no. 1, 1-9. + + subroutine Ewald_calc(at_in, charge, e, f, virial, ewald_error, use_ewald_cutoff, smooth_coulomb_cutoff, error) + + type(Atoms), intent(in), target :: at_in + real(dp), dimension(:), intent(in) :: charge + + real(dp), intent(out), optional :: e + real(dp), dimension(:,:), intent(out), optional :: f + real(dp), dimension(3,3), intent(out), optional :: virial + real(dp), intent(in), optional :: ewald_error + logical, intent(in), optional :: use_ewald_cutoff + real(dp), intent(in), optional :: smooth_coulomb_cutoff + integer, intent(out), optional :: error + + integer :: i, j, k, n, n1, n2, n3, not_needed !for reciprocal force + integer, dimension(3) :: nmax !how many reciprocal vectors are to be taken + + logical :: my_use_ewald_cutoff + + real(dp) :: r_ij, erfc_ar, arg, my_ewald_error, alpha, kmax, kmax2, prefac, infac, two_alpha_over_sqrt_pi, v, & + & ewald_precision, ewald_cutoff, my_cutoff, my_smooth_coulomb_cutoff, smooth_arg, smooth_f, dsmooth_f + + real(dp), dimension(3) :: force, u_ij, a, b, c, h + real(dp), dimension(3,3) :: identity3x3, k3x3 + real(dp), dimension(:,:,:,:), allocatable :: coskr, sinkr + real(dp), dimension(:,:,:,:), allocatable :: k_vec ! reciprocal vectors + real(dp), dimension(:,:,:,:), allocatable :: force_factor + real(dp), dimension(:,:,:), allocatable :: energy_factor + real(dp), dimension(:,:,:), allocatable :: mod2_k !square of length of reciprocal vectors + + type(Atoms), target :: my_at + type(Atoms), pointer :: at + + INIT_ERROR(error) + + call check_size('charge',charge,at_in%N,'IPEwald',error) + + identity3x3 = 0.0_dp + call add_identity(identity3x3) + + ! Set up Ewald calculation + my_ewald_error = optional_default(1e-06_dp,ewald_error) * 4.0_dp * PI * EPSILON_0 ! convert eV to internal units + my_use_ewald_cutoff = optional_default(.true.,use_ewald_cutoff) ! can choose between optimal Ewald + my_smooth_coulomb_cutoff = optional_default(0.0_dp, smooth_coulomb_cutoff) ! default is not to use smooth Coulomb + + a = at_in%lattice(:,1); b = at_in%lattice(:,2); c = at_in%lattice(:,3) + v = cell_volume(at_in) + + h(1) = v / norm(b .cross. c) + h(2) = v / norm(c .cross. a) + h(3) = v / norm(a .cross. b) + + ewald_precision = -log(my_ewald_error) + ewald_cutoff = sqrt(ewald_precision/PI) * reciprocal_time_by_real_time**(1.0_dp/6.0_dp) * & + & minval(sqrt( sum(at_in%lattice(:,:)**2,dim=1) )) / at_in%N**(1.0_dp/6.0_dp) + + call print('Ewald cutoff = '//ewald_cutoff,PRINT_ANALYSIS) + + if( my_use_ewald_cutoff .and. (ewald_cutoff > at_in%cutoff) ) then + my_at = at_in + call set_cutoff(my_at,ewald_cutoff) + call calc_connect(my_at) + at => my_at + else + at => at_in + endif + + if( my_use_ewald_cutoff ) then + my_cutoff = ewald_cutoff + else + my_cutoff = at_in%cutoff + endif + + if( my_cutoff < my_smooth_coulomb_cutoff ) then + RAISE_ERROR('Cutoff='//my_cutoff//' is smaller than the smooth region specified by smooth_coulomb_cutoff='//my_smooth_coulomb_cutoff, error) + endif + + alpha = sqrt(ewald_precision) / my_cutoff + call print('Ewald alpha = '//alpha,PRINT_ANALYSIS) + + kmax = 2.0_dp * ewald_precision / my_cutoff + kmax2 = kmax**2 + call print('Ewald kmax = '//kmax,PRINT_ANALYSIS) + + nmax = nint( kmax * h / 2.0_dp / PI ) + call print('Ewald nmax = '//nmax,PRINT_ANALYSIS) + + two_alpha_over_sqrt_pi = 2.0_dp * alpha / sqrt(PI) + + prefac = 4.0_dp * PI / v + infac = - 1.0_dp / (4.0_dp * alpha**2.0_dp) + + allocate( k_vec(3,-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1)), & + & mod2_k(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1) ), & + & force_factor(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1),3), & + & energy_factor(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1) ) ) + + allocate( coskr(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1),at%N), & + & sinkr(-nmax(3):nmax(3),-nmax(2):nmax(2),0:nmax(1),at%N) ) + + k_vec = 0.0_dp + mod2_k = 0.0_dp + force_factor = 0.0_dp + energy_factor = 0.0_dp + + coskr = 0.0_dp + sinkr = 0.0_dp + + not_needed = ( 2*nmax(3) + 1 ) * nmax(2) + nmax(3) + 1 ! lot of symmetries for k and -k so count only + + n = 0 + do n1 = 0, nmax(1) + do n2 = -nmax(2), nmax(2) + do n3 = -nmax(3), nmax(3) + + n = n + 1 + + if( n>not_needed ) then + k_vec(:,n3,n2,n1) = ( at%g(1,:)*n1 + at%g(2,:)*n2 + at%g(3,:)*n3 ) * 2.0_dp * PI + mod2_k(n3,n2,n1) = normsq( k_vec(:,n3,n2,n1) ) + + force_factor(n3,n2,n1,:) = 1.0_dp/mod2_k(n3,n2,n1) * & + & exp(mod2_k(n3,n2,n1)*infac) * k_vec(:,n3,n2,n1) + energy_factor(n3,n2,n1) = 1.0_dp/mod2_k(n3,n2,n1) * exp(infac*mod2_k(n3,n2,n1)) + endif + + enddo + enddo + enddo + + do i = 1, at%N + n = 0 + do n1 = 0, nmax(1) + do n2 = -nmax(2), nmax(2) + do n3 = -nmax(3), nmax(3) + + n = n + 1 + + if( (n>not_needed) .and. ( mod2_k(n3,n2,n1) my_cutoff ) cycle + + if( r_ij < my_smooth_coulomb_cutoff ) then + smooth_arg = r_ij * PI / my_smooth_coulomb_cutoff / 2.0_dp + smooth_f = ( 1.0_dp - sin(smooth_arg) ) / r_ij + dsmooth_f = cos(smooth_arg) * PI / my_smooth_coulomb_cutoff / 2.0_dp + else + smooth_f = 0.0_dp + dsmooth_f = 0.0_dp + endif + + erfc_ar = erfc(r_ij*alpha)/r_ij + + if( present(e) ) e = e + 0.5_dp * charge(i)*charge(j)* ( erfc_ar - smooth_f ) + + if( present(f) .or. present(virial) ) then + force(:) = charge(i)*charge(j) * & + & ( two_alpha_over_sqrt_pi * exp(-(r_ij*alpha)**2) + erfc_ar - smooth_f - dsmooth_f) / r_ij * u_ij(:) + + if(present(f)) then + f(:,i) = f(:,i) - force(:) + endif + + if (present(virial)) virial = virial + 0.5_dp * (force .outer. u_ij) * r_ij + endif + + enddo + enddo + + ! reciprocal energy + if(present(e)) e = e + sum((sum(coskr,dim=4)**2 + sum(sinkr,dim=4)**2)*energy_factor) * prefac & + & - sum(charge**2) * alpha / sqrt(PI) - PI / ( 2.0_dp * alpha**2 * v ) * sum(charge)**2 + + ! reciprocal force + if( present(f) ) then + do i = 1, at%N + do j = 1, at%N + + if( i<=j ) cycle + + force = (/( sum(force_factor(:,:,:,k) * & + & ( sinkr(:,:,:,j)*coskr(:,:,:,i) - sinkr(:,:,:,i)*coskr(:,:,:,j) ) ), k=1,3 )/) * prefac * 2.0_dp + + !force acting on atom j by atom i + f(:,i) = f(:,i) - force(:) + f(:,j) = f(:,j) + force(:) + + enddo + enddo + endif + + ! reciprocal contribution to virial + if(present(virial)) then + n = 0 + do n1 = 0, nmax(1) + do n2 = -nmax(2), nmax(2) + do n3 = -nmax(3), nmax(3) + + n = n + 1 + + if( (n>not_needed) .and. ( mod2_k(n3,n2,n1) null() + + INIT_ERROR(error) + call check_size('charge',charge,(/at_in%N/),'Ewald_corr_calc',error) + + my_cutoff = optional_default(at_in%cutoff,cutoff) + + if( present(cutoff) .and. (my_cutoff > at_in%cutoff) ) then + my_at = at_in + call set_cutoff(my_at,cutoff) + call calc_connect(my_at) + at => my_at + else + at => at_in + endif + + if( present(e) ) e = 0.0_dp + if( present(f) ) f = 0.0_dp + if( present(virial) ) virial = 0.0_dp + + do i = 1, at%N + !Loop over neighbours + do n = 1, n_neighbours(at,i) + j = neighbour(at,i,n,distance=r_ij,cosines=u_ij) ! nth neighbour of atom i + if( r_ij > my_cutoff ) cycle + + de = 0.5_dp * ( cos(r_ij*PI/my_cutoff) + 1.0_dp ) / r_ij + + if( present(e) ) e = e + 0.5_dp * de * charge(i)*charge(j) + + if( present(f) .or. present(virial) ) then + force = charge(i)*charge(j) * & + & ( -de - 0.5*PI*sin(r_ij*PI/my_cutoff)/my_cutoff ) / r_ij * u_ij + + if(present(f)) then + f(:,i) = f(:,i) + force + endif + + if (present(virial)) virial = virial - 0.5_dp * (force .outer. u_ij) * r_ij + endif + + enddo + enddo + + if(present(e)) e = e * HARTREE*BOHR ! convert from internal units to eV + if(present(f)) f = f * HARTREE*BOHR ! convert from internal units to eV/A + if(present(virial)) virial = virial * HARTREE*BOHR + + if(associated(at,my_at)) call finalise(my_at) + at => null() + + endsubroutine Ewald_corr_calc + + subroutine Direct_Coulomb_calc(at_in,charge, e,f,virial,local_e,cutoff,error) + + type(Atoms), intent(in), target :: at_in + real(dp), dimension(:), intent(in) :: charge + + real(dp), intent(out), optional :: e + real(dp), dimension(:,:), intent(out), optional :: f + real(dp), dimension(3,3), intent(out), optional :: virial + real(dp), dimension(:), intent(out), optional :: local_e + real(dp), intent(in), optional :: cutoff + integer, intent(out), optional :: error + + integer :: i, j, n + + real(dp) :: my_cutoff, r_ij, de + real(dp), dimension(3) :: force, u_ij + + real(dp), dimension(:), pointer :: my_charge + + type(Atoms), target :: my_at + type(Atoms), pointer :: at => null() + + INIT_ERROR(error) + call check_size('charge',charge,(/at_in%N/),'Ewald_corr_calc',error) + + my_cutoff = optional_default(at_in%cutoff,cutoff) + + if( present(cutoff) .and. (my_cutoff > at_in%cutoff) ) then + my_at = at_in + call set_cutoff(my_at,cutoff) + call calc_connect(my_at) + at => my_at + else + at => at_in + endif + + if( present(e) ) e = 0.0_dp + if( present(f) ) f = 0.0_dp + if( present(virial) ) virial = 0.0_dp + if( present(local_e) ) local_e = 0.0_dp + + do i = 1, at%N + !Loop over neighbours + do n = 1, n_neighbours(at,i) + j = neighbour(at,i,n,distance=r_ij,cosines=u_ij) ! nth neighbour of atom i + if( r_ij > my_cutoff ) cycle + + de = 0.5_dp * charge(i)*charge(j) / r_ij + + if( present(e) ) e = e + de + if( present(local_e) ) local_e(i) = local_e(i) + de + + if( present(f) .or. present(virial) ) then + force = - de / r_ij * u_ij + + if(present(f)) then + f(:,i) = f(:,i) + force + f(:,j) = f(:,j) - force + endif + + if (present(virial)) virial = virial - (force .outer. u_ij) * r_ij + endif + + enddo + enddo + + if(present(e)) e = e * HARTREE*BOHR ! convert from internal units to eV + if(present(f)) f = f * HARTREE*BOHR ! convert from internal units to eV/A + if(present(virial)) virial = virial * HARTREE*BOHR + + if(associated(at,my_at)) call finalise(my_at) + at => null() + + endsubroutine Direct_Coulomb_calc + + subroutine DSF_Coulomb_calc(at_in,charge, alpha, e, f, virial, local_e, e_potential, e_field, cutoff, error) + + type(Atoms), intent(in), target :: at_in + real(dp), dimension(:), intent(in) :: charge + real(dp), intent(in) :: alpha + + real(dp), intent(out), optional :: e + real(dp), dimension(:,:), intent(out), optional :: f + real(dp), dimension(3,3), intent(out), optional :: virial + real(dp), dimension(:), intent(out), optional :: local_e + real(dp), dimension(:), intent(out), optional :: e_potential + real(dp), dimension(:,:), intent(out), optional :: e_field + real(dp), intent(in), optional :: cutoff + integer, intent(out), optional :: error + + integer :: i, j, n + + real(dp) :: my_cutoff, r_ij, phi_i, e_i, v_ij, dv_ij, v_cutoff, dv_cutoff, two_alpha_over_square_root_pi + + real(dp), dimension(3) :: u_ij, dphi_i, dphi_ij + real(dp), dimension(3,3) :: dphi_ij_outer_r_ij + + type(Atoms), target :: my_at + type(Atoms), pointer :: at => null() + + INIT_ERROR(error) + call check_size('charge',charge,(/at_in%N/),'DSF_Coulomb_calc',error) + + my_cutoff = optional_default(at_in%cutoff,cutoff) + + two_alpha_over_square_root_pi = 2.0_dp * alpha / sqrt(pi) + + v_cutoff = erfc(alpha * my_cutoff) / my_cutoff + dv_cutoff = ( v_cutoff + two_alpha_over_square_root_pi*exp(-(alpha*my_cutoff)**2) ) / my_cutoff + + if( present(cutoff) .and. (my_cutoff > at_in%cutoff) ) then + my_at = at_in + call set_cutoff(my_at,cutoff) + call calc_connect(my_at) + at => my_at + else + at => at_in + endif + + if( present(e) ) e = 0.0_dp + if( present(f) ) f = 0.0_dp + if( present(virial) ) virial = 0.0_dp + if( present(local_e) ) local_e = 0.0_dp + if( present(e_potential) ) e_potential = 0.0_dp + if( present(e_field) ) e_field = 0.0_dp + + do i = 1, at%N + !Loop over neighbours + + phi_i = 0.0_dp + dphi_i = 0.0_dp + dphi_ij_outer_r_ij = 0.0_dp + + + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, max_dist=my_cutoff) ! nth neighbour of atom i + if (j <= 0) cycle + if (r_ij .feq. 0.0_dp) cycle + + v_ij = erfc(alpha*r_ij) / r_ij + phi_i = phi_i + charge(j) * ( v_ij - v_cutoff + dv_cutoff * (r_ij - my_cutoff) ) + + if( present(f) .or. present(virial) .or. present(e_field) ) then + dv_ij = ( v_ij + two_alpha_over_square_root_pi * exp(-(alpha*r_ij)**2) ) / r_ij + dphi_ij = charge(j) * ( dv_ij - dv_cutoff ) * u_ij + dphi_i = dphi_i + dphi_ij + + if(present(virial) ) dphi_ij_outer_r_ij = dphi_ij_outer_r_ij + ( dphi_ij .outer. u_ij ) * r_ij + endif + enddo + + if( present(e) .or. present(local_e) ) then + e_i = 0.5_dp * phi_i * charge(i) + if( present(e) ) e = e + e_i + if( present(local_e) ) local_e(i) = e_i + endif + + if(present(e_potential)) e_potential(i) = phi_i + + if(present(f)) f(:,i) = f(:,i) - dphi_i * charge(i) + + if (present(virial)) virial = virial + 0.5_dp * charge(i) * dphi_ij_outer_r_ij + + if(present(e_field)) e_field(:,i) = dphi_i + enddo + + if(present(e)) e = e * HARTREE*BOHR ! convert from internal units to eV + if(present(local_e)) local_e = local_e * HARTREE*BOHR ! convert from internal units to eV + if(present(f)) f = f * HARTREE*BOHR ! convert from internal units to eV/A + if(present(virial)) virial = virial * HARTREE*BOHR + + if(associated(at,my_at)) call finalise(my_at) + at => null() + + endsubroutine DSF_Coulomb_calc + +endmodule IPEwald_module diff --git a/src/Potentials/IPModel_ASAP.F90 b/src/Potentials/IPModel_ASAP.F90 new file mode 100644 index 0000000000..b4beec065a --- /dev/null +++ b/src/Potentials/IPModel_ASAP.F90 @@ -0,0 +1,1027 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_ASAP +!X +!% Interface to ASAP potential. +!% P. Tangney and S. Scandolo, +!% An ab initio parametrized interatomic force field for silica +!% J. Chem. Phys, 117, 8898 (2002). +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_ASAP_module + +use libAtoms_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +logical, private :: asap_initialised = .false. + +public :: IPModel_ASAP +type IPModel_ASAP + integer :: n_types = 0, n_atoms = 0 + real(dp) :: betapol, tolpol, yukalpha, yuksmoothlength + integer :: maxipol, pred_order + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + real(dp), allocatable, dimension(:) :: pol, z + real(dp), allocatable, dimension(:,:) :: D_ms, gamma_ms, R_ms, B_pol, C_pol + logical :: tewald, tdip_sr + real :: raggio, a_ew, gcut + integer :: iesr(3) + + real(dp) :: cutoff_coulomb, cutoff_ms + + character(len=STRING_LENGTH) :: label + logical :: initialised + +end type IPModel_ASAP + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_ASAP), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_ASAP_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_ASAP_Finalise +end interface Finalise + +interface Print + module procedure IPModel_ASAP_Print +end interface Print + +interface Calc + module procedure IPModel_ASAP_Calc +end interface Calc + +contains + +#ifdef HAVE_ASAP + subroutine asap_singlepoint_finalise() + + use atoms + use verlet + use neighbour + use pot_parameters + use stuff + use energy_i + use print65 + use electric_field + use nndim + use neighbour3 + use fixpar + use distortion, only : taimsp,rmin_aim + use thermal_cond + use shakes + use compress + use quench + use forcetest + use iteration + use changepress + use metric + use netquant + use universal + use initstuff + use plot_efield + use polar + use structopt + use parameters + use presstemp + use testf + use minimiser + implicit none + + deallocate(mass,spind,objind,numobj,numobjsp) + deallocate(nnlist,nnlist2,nnlist3) + deallocate(nnat,nnat2,nnat3,nn_imag) + deallocate(nn_imag2,nn_imag3) + deallocate(s,sm) + deallocate(r,rm) + deallocate(Z,bij,Cij) + deallocate(Dij,alphaij) + deallocate(Eij,Nij) + deallocate(pol,bpol,cpol) + deallocate(theta0jik,bjik) + deallocate(b_tt,r_ms) + deallocate(gamma_ms,d_ms) + deallocate(c_harm,rmin,rmin_aim) + deallocate(adist,bdist,cdist,ddist) + deallocate(bu1,alphau1) + deallocate(sigma1,sigma2,sigma3,sigma4) + deallocate(bu2,alphau2) + deallocate(taimsp,minr,mindistl) + deallocate(elements) + deallocate(aelements) + deallocate(ielements) + deallocate(dt2bym, aumass) + deallocate(parf, tparf) + deallocate(posobj,velobj,dipobj) + deallocate(timposepos,timposevel,timposedip) + deallocate(zerovec,falseimp) + if (allocated(dip_perm)) deallocate(dip_perm) + if (t_therm) deallocate(nzave,ztempave) + + if (allocated(efield_old)) deallocate(efield_old) + if (allocated(efield)) deallocate(efield) + if (allocated(fqdip)) deallocate(fqdip) + if (allocated(fdipdip)) deallocate(fdipdip) + if (allocated(force_ew)) deallocate(force_ew) + if (allocated(efield_ew)) deallocate(efield_ew) + if (allocated(dip)) deallocate(dip) + if (allocated(stress_ew)) deallocate(stress_ew) + if (allocated(dip_sr)) deallocate(dip_sr) + if (allocated(efield_old)) deallocate(efield_old) + if (allocated(force_pol)) deallocate(force_pol) + if (allocated(stress_pol)) deallocate(stress_pol) + if (allocated(testt)) deallocate(testt) + + end subroutine asap_singlepoint_finalise + +#endif + + +subroutine IPModel_ASAP_Initialise_str(this, args_str, param_str) + use system_module, only : dp + type(IPModel_ASAP), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + this%initialised = .false. + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_ASAP_Initialise_str args_str')) then + call system_abort("IPModel_ASAP_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_ASAP_read_params_xml(this, param_str) + this%n_atoms = 0 + this%initialised = .true. + +end subroutine IPModel_ASAP_Initialise_str + +subroutine IPModel_ASAP_Finalise(this) + use system_module, only : dp + type(IPModel_ASAP), intent(inout) :: this + +#ifdef HAVE_ASAP + if (asap_initialised) then + call asap_singlepoint_finalise() + asap_initialised = .false. + end if + this%initialised = .false. +#else + call system_abort('ASAP potential is not compiled in. Recompile with HAVE_ASAP=1') +#endif + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%pol)) deallocate(this%pol) + if (allocated(this%z)) deallocate(this%z) + if (allocated(this%D_ms)) deallocate(this%D_ms) + if (allocated(this%gamma_ms)) deallocate(this%gamma_ms) + if (allocated(this%R_ms)) deallocate(this%R_ms) + if (allocated(this%B_pol)) deallocate(this%B_pol) + if (allocated(this%C_pol)) deallocate(this%C_pol) + this%n_types = 0 + this%label = '' +end subroutine IPModel_ASAP_Finalise + + +subroutine IPModel_ASAP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) +#ifdef HAVE_ASAP + use neighbour!, only : nsp,nat,iesr,spind,rcut + use neighbour3 + use pot_parameters + use logical_stuff + use polar + use stuff + use distortion, only : xgmin,xgmax,taimsp + use parameters + use testf + use initstuff + use atoms + use verlet + use iteration + use nndim + use metric + use fixpar, only: ntype, tpbc, treadpar + use energy_i + use print65 + use electric_field + use nndim + use distortion, only : taimsp,rmin_aim + use thermal_cond + use shakes + use compress + use quench + use forcetest + use iteration + use changepress + use metric + use netquant + use universal, only: au_to_kbar, small + use initstuff + use plot_efield + use polar + use structopt + use parameters + use presstemp + use testf + use minimiser + +#endif + use libAtoms_module, only : myAtoms => Atoms, Dictionary, BOHR, HARTREE, & + ElementMass, massconvert, initialise, param_read_line, finalise, & + ElementName, print, operator(//), cell_volume, has_property, & + assign_pointer, add_property, system_abort, fit_box_in_cell, & + param_register, check_size, operator(.fne.), assign_property_pointer + + type(IPModel_ASAP), intent(inout):: this + type(myAtoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional, intent(in) :: args_str + type(MPI_Context), intent(in), optional :: mpi + + integer, intent(out), optional :: error + type(Dictionary) :: params + real(dp) :: asap_e, asap_stress(3,3), a_ew, f_ew + logical smlra,smlrc,smlgc,smlrc2,smlrc3,smlrc4 + logical nsmlra,nsmlrc,nsmlgc + real*8 rarec,gcrec,rcrec,root2 + real*8 raggio_in,rcut_in,gcut_in + real(dp), allocatable :: asap_f(:,:) + real(dp), pointer :: dipoles_ptr(:,:), ext_efield_ptr(:,:) + integer :: i, ti, tj + logical :: do_restart, calc_dipoles + integer at0, atf + integer idebug + real(dp) dtold,dtnew + logical tzeroc + logical sumewald + real(dp) mass_cel + logical tscaled + logical readnat + logical texist + logical tpow,tgmin + integer nesr + + logical :: has_atom_mask_name, applied_efield + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + +#ifdef HAVE_ASAP + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_ASAP_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_ASAP_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_ASAP_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_ASAP_Calc: local_virial calculation requested but not supported yet.", error) + endif + + allocate(asap_f(3,at%N)) + + call initialise(params) + this%label='' + call param_register(params, 'restart', 'F', do_restart, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'calc_dipoles', 'T', calc_dipoles, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + call param_register(params, 'applied_efield', 'F', applied_efield, help_string="No help yet. This source file was $LastChangedBy$") + + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_ASAP_Calc args_str')) then + call system_abort("IPModel_ASAP_Initialise_str failed to parse args_str="//trim(args_str)) + endif + call finalise(params) + + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_ASAP_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_ASAP_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + if (.not. asap_initialised .or. this%n_atoms /= at%n) then + + if (asap_initialised) then + call asap_singlepoint_finalise() + asap_initialised = .false. + end if + + this%n_atoms = at%n + + idebug = 0 + nat = this%n_atoms + nsp = this%n_types + at0 = 1 + atf = nat + nobj = 1 + + nthermo = min(atf-at0+1,nat-1) + allocate(mass(this%n_types)) + + tsinglepoint = .true. + tangstrom = .false. + irestart = -1 + itsave = 0 + readunit = 90 + saveunit = 90 + readnat = .false. + dtold = 0.0d0 + dtnew = 0.0d0 + ntstep = 0 + iprint = 0 + iprintxyz = 0 + deltat = dtnew + tcenter = .false. + timposepbc = .false. + tremovetrans = .false. + treadxyz = .false. + tfirst_xyzprint = .true. + treadpar = .false. + tappendfiles = .false. + tstructopt = .false. + tsdp = .false. + tpbc = .true. + tpow = .false. + tgmin = .false. + testewald = .false. + ttime = .true. + tforcetest = .false. + tscaled = .false. + tangstrom = .false. + texist = .false. + tprint65 = .false. + tenergy_i = .false. + tbin65 = .false. + iprint65 = 1 + tzeroc = .false. + tcel = .false. + tsdc = .false. + cell_dir = 3 + press = 0.0d0 + mass_cel = 2.0d6 + press = press / au_to_kbar + wc = mass_cel + trescale = .false. + tnosep = .false. + tboltz = .false. + tshake = .false. + tcompress = .false. + tquench = .false. + tchangeP= .false. + tpolwrite = .false. + t_therm = .false. + tshowforce = .false. + tplot_efield = .false. + tfirst_efield_plot = .true. + tewald = .false. + write_sr = .false. + read_sr= .false. + calc_sr=.false. + calc_pol = .false. + write_pol=.false. + read_pol=.false. + calc_gvec=.false. + write_gvec=.false. + read_gvec=.false. + write_aim = .false. + read_aim= .false. + calc_aim=.false. + tzvar=.false. + tpolvar=.false. + tsrvar=.false. + tpol=.false. + tsr=.false. + taim = .false. + tz=.false. + hafta=.false. + tbegin = .true. + tyukawa = .true. + + sumewald = .true. + allocate(spind(nat),objind(nat),numobj(nobj),numobjsp(nobj,nsp)) + allocate(z(nsp),bij(nsp,nsp),Cij(nsp,nsp)) + allocate(Dij(nsp,nsp),alphaij(nsp,nsp)) + allocate(Eij(nsp,nsp),Nij(nsp,nsp)) + allocate(pol(nsp),bpol(nsp,nsp),cpol(nsp,nsp)) + allocate(theta0jik(nsp,nsp,nsp),bjik(nsp,nsp,nsp)) + allocate(b_tt(3,nsp,nsp),r_ms(nsp,nsp)) + allocate(gamma_ms(nsp,nsp),d_ms(nsp,nsp)) + allocate(c_harm(nsp,nsp),rmin(nsp,nsp)) + allocate(rmin_aim(nsp,nsp)) + rmin_aim = 0.d0 + allocate(adist(nsp,nsp),bdist(nsp,nsp)) + allocate(cdist(nsp),ddist(nsp,nsp)) + allocate(bu1(nsp,nsp),alphau1(nsp,nsp)) + allocate(sigma1(nsp),sigma2(nsp),sigma3(nsp),sigma4(nsp)) + allocate(bu2(nsp,nsp),alphau2(nsp,nsp)) + allocate(taimsp(nsp)) + allocate(minr(nsp,nsp),mindistl(nsp,nsp)) + mindistl = 0.d0 + + allocate(s(3,nat),sm(3,nat)) + allocate(r(3,nat),rm(3,nat)) + allocate(dt2bym(nat),aumass(nat)) + allocate(elements(nsp)) + allocate(aelements(nat)) + allocate(ielements(nat)) + nparm = (nsp*nsp*nsp+21*nsp*nsp+28*nsp)/2 + 4*nsp + allocate (parf(nparm),tparf(nparm)) + tgen = .false. + testforce = .false. + npar = 1 + + ntnlist = (/1,1/) + nnatmax = 100000 + nnatmax_sr = 30000 + allocate(posobj(3,nobj),velobj(3,nobj),dipobj(3,nobj)) + allocate(timposepos(nobj),timposevel(nobj),timposedip(nobj)) + allocate(zerovec(3,nobj),falseimp(nobj)) + zerovec = 0.0d0! + + falseimp = .false. + XNOS2M = 0.D0 + XNOSM = 0.D0 + XNOS0 = 0.D0 + VRNOS = 0.D0 + + it = 1 + + c_harm = 0.0_dp + rmin = 0.0_dp + + ! Per type parameters + do ti=1,this%n_types + mass(ti) = ElementMass(this%atomic_num(ti))/MASSCONVERT + elements(ti) = ElementName(this%atomic_num(ti)) + z(ti) = this%z(ti) + pol(ti) = this%pol(ti) + ntype(ti) = count(at%Z == this%atomic_num(ti)) + end do + + write(6,'(/," Nos of each species:",10i6)') (ntype(i),i=1,nsp) + write(6,'(/," Masses :",2(1x,f10.5))') mass + + ! Ewald parameters + tewald = this%tewald + raggio = this%raggio + a_ew = this%a_ew + gcut = this%gcut + rcut(1) = this%cutoff_coulomb + rcut(3) = this%cutoff_ms + iesr = this%iesr + + call print('tewald :'//tewald) + write(6,'(/," Raggio :",1x,f10.5)') raggio + write(6,'(" A_ew :",1x,e10.5)') a_ew + write(6,'(" iesr :",3i3)') iesr + write(6,'(" Gcut :",1x,f10.5,/)') gcut + + smlgc = gcut.lt.small + smlrc = rcut(1).lt.small + smlra = raggio.lt.small + smlrc2 = rcut(2).lt.small + smlrc3 = rcut(3).lt.small + smlrc4 = rcut(4).lt.small + + nsmlgc = .not.smlgc ! iesr will be computed later from rcut and cell + + nsmlrc = .not.smlrc + nsmlra = .not.smlra + + f_ew = dsqrt(-1.0d0*log(a_ew)) + root2 = dsqrt(2.0d0) + + rarec = 0.0d0 + rcrec = 0.0d0 + gcrec = 0.0d0 + + raggio_in = raggio + gcut_in = gcut + rcut_in = rcut(1) + + if (smlrc.and.smlgc.and.smlra) then + rarec = 3.0d0 + gcrec = f_ew*root2/rarec + rcrec = gcut*rarec*rarec + else if (nsmlrc.and.smlgc.and.smlra) then + rarec = rcut(1)/f_ew/root2 + gcrec = f_ew*root2/rarec + raggio = rarec + gcut = gcrec + else if (smlrc.and.nsmlgc.and.smlra) then + rarec = f_ew*root2/gcut + rcrec = gcut*rarec*rarec + raggio = rarec + rcut(1) = rcrec + else if (smlrc.and.smlgc.and.nsmlra) then + gcrec = f_ew*dsqrt(2.0d0)/raggio + rcrec = gcrec*raggio*raggio + gcut = gcrec + rcut(1) = rcrec + else if (nsmlrc.and.nsmlgc.and.smlra) then + rarec = rcut(1)/f_ew/root2 + gcrec = f_ew*root2/raggio + raggio = rarec + else if (nsmlrc.and.smlgc.and.nsmlra) then + rarec = rcut(1)/f_ew/root2 + gcrec = f_ew*root2/raggio + gcut = gcrec + else if (smlrc.and.nsmlgc.and.nsmlra) then + gcrec = f_ew*root2/raggio + rcrec = gcrec*raggio*raggio + rcut(1) = rcrec + else if (nsmlrc.and.nsmlgc.and.nsmlra) then + write(6,*) 'raggio, rcut, gcut, are all defined!!' + endif + + if (smlrc2) rcut(2) = rcut(1) + if (smlrc3) rcut(3) = rcut(1) + if (smlrc4) rcut(4) = rcut(1) + + write(6,'(/," Input Raggio : ",f10.5)')raggio_in + write(6,'(" Input r-space cutoff : ",f10.5)')rcut_in + write(6,'(" Input g-space cutoff : ",f10.5)')gcut_in + write(6,'(/," Recommended Raggio : ",f10.5)')rarec + write(6,'(" Recommended r-space cutoff : ",f10.5)')rcrec + write(6,'(" Recommended g-space cutoff : ",f10.5)')gcrec + write(6,'(/," Using Raggio : ",f10.5)')raggio + write(6,'(" Using r-space cutoff : ",f10.5)')rcut(1) + write(6,'(" Using g-space cutoff : ",f10.5)')gcut + write(6,'(/," Secondary r-space cutoff : ",f10.5)')rcut(2) + write(6,'(" Tertiary r-space cutoff : ",f10.5)')rcut(3) + write(6,'(" Quaternary r-space cutoff : ",f10.5)')rcut(4) + + netcharge = 0.0d0 + do i=1,this%n_types + netcharge = netcharge + z(i)*dfloat(ntype(i)) + if (dabs(z(i)).gt.1.d-10) tz = .true. + end do + + write(6,'(/," Charges : ",100(e13.5))') z + write(6,'(/," Net charge ",e13.5)') netcharge + write(6,*) + + ! Short range parameters + tsr = .true. + alphaij = 0.0_dp + bij = 0.0_dp + cij = 0.0_dp + dij = 0.0_dp + eij = 0.0_dp + nij = 0.0_dp + b_tt = 0.0_dp + gamma_ms = 0.d0 + r_ms = 0.0d0 + d_ms= 0.0d0 + do ti=1,this%n_types + do tj=1,this%n_types + d_ms(ti,tj) = this%d_ms(ti,tj) + gamma_ms(ti,tj) = this%gamma_ms(ti,tj) + R_ms(ti,tj) = this%R_ms(ti,tj) + end do + end do + + ! Polarisation + betapol = this%betapol + maxipol = this%maxipol + tolpol = this%tolpol + pred_order = this%pred_order + + tpol = any(dabs(pol) > 1.0e-6_dp) + tpolvar = tpol + call Print('tpol = '//tpol) + call Print('tpolvar = '//tpolvar) + call Print('Polarisation: '//pol) + + bpol = 0.0_dp + cpol = 0.0_dp + do ti=1,this%n_types + do tj=1,this%n_types + bpol(ti,tj) = this%B_pol(ti,tj) + cpol(ti,tj) = this%C_pol(ti, tj) + end do + end do + + ! Smoothing + smooth = .false. + + ! Yukawa parameters + yukalpha = this%yukalpha + yuksmoothlength = this%yuksmoothlength + tdip_sr = this%tdip_sr + + asap_initialised = .true. + end if + + spind = 0 + do i=1,this%n_types + where(at%Z == this%atomic_num(i)) spind = i + end do + + ! ASAP uses atomic units - lengths are in Bohr, energies in Hartree, + ! forces in Hartree/Bohr and stress in Hartree/Bohr**3 + + r(:,:) = at%pos(:,:)/BOHR ! positions + rm(:,:) = at%pos(:,:)/BOHR + htm = transpose(at%lattice/BOHR) ! lattice + ht = transpose(at%lattice/BOHR) + restart = do_restart ! reset electric field + + if (applied_efield) then + call assign_property_pointer(at, 'ext_efield', ext_efield_ptr, error) + PASS_ERROR(error) + + ! check electric field is constant + if (maxval(abs(sum(ext_efield_ptr,2)/real(size(ext_efield_ptr,2),dp) - ext_efield_ptr(:,1))) > 1.0e-6_dp) then + RAISE_ERROR('IPModel_ASAP_calc: external efield must be constant (same for all atoms)', error) + end if + + telectric = .true. + tfieldion = .true. + e_applied = ext_efield_ptr(:,1)/(HARTREE/BOHR) ! external applied electric field + else + telectric = .false. + tfieldion = .false. + e_applied(:) = 0.0_dp + end if + + objind = 1 + numobj(1) = nat + ntype = 1 + numobjsp = 0 + do i=1,nat + ntype(spind(i)) = ntype(spind(i)) + 1 + numobjsp(1,spind(i)) = numobjsp(1,spind(i)) + 1 + end do + + call inv3(ht,htm1,omega) + + if (all(iesr == -1)) then + ! given rcut(1) and lattice, compute iesr + call fit_box_in_cell(rcut(1),rcut(1),rcut(1), at%lattice, iesr(1), iesr(2), iesr(3)) + iesr = iesr/2 + end if + + nesr = (2*iesr(1)+1)*(2*iesr(2)+1)*(2*iesr(3)+1) + nnatmax = min(nnatmax,nat*nesr) + nnatmax = nnatmax + 10 + + if (allocated(nnat)) deallocate(nnat) + if (allocated(nnat2)) deallocate(nnat2) + if (allocated(nnat3)) deallocate(nnat3) + if (allocated(nnlist)) deallocate(nnlist) + if (allocated(nnlist2)) deallocate(nnlist2) + if (allocated(nnlist3)) deallocate(nnlist3) + if (allocated(nn_imag)) deallocate(nn_imag) + if (allocated(nn_imag2)) deallocate(nn_imag2) + if (allocated(nn_imag3)) deallocate(nn_imag3) + + call label_elements + call init + call prepare_traj + + if((mod(it,ntnlist(1)).eq.1).or.(ntnlist(1).eq.1)) then + call nbrlist(r,nnatmax) + call nbrlist3(r) + endif + + if(mod(it,ntnlist(2)).eq.1) then + call nbrlist3(r) + endif + + call force_ft(asap_e, asap_f, asap_stress, 0) + it = it + 1 + + ! Convert to {eV, A, fs} units + if (present(e)) e = asap_e*HARTREE + if (present(f)) f = asap_f*(HARTREE/BOHR) + if (present(virial)) virial = asap_stress*(HARTREE/(BOHR**3))*cell_volume(at) + if (present(local_e)) local_e = 0.0_dp + + if (calc_dipoles .and. tpol) then + if (.not. has_property(at, 'dipoles')) call add_property(at, 'dipoles', 0.0_dp, n_cols=3) + call assign_property_pointer(at, 'dipoles', dipoles_ptr, error) + PASS_ERROR(error) + dipoles_ptr = dip*BOHR + end if + + deallocate(asap_f) +#else + RAISE_ERROR('ASAP potential is not compiled in. Recompile with HAVE_ASAP=1', error) +#endif + +end subroutine IPModel_ASAP_Calc + + +subroutine IPModel_ASAP_Print(this, file) + use system_module, only : dp + type(IPModel_ASAP), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_ASAP : ASAP Potential", file=file) + call Print("IPModel_ASAP : n_types = " // this%n_types //" n_atoms = "//this%n_atoms, file=file) + call Print("IPModel_ASAP : betapol = "//this%betapol//" maxipol = "//this%maxipol//" tolpol = "//this%tolpol//" pred_order = "//this%pred_order, file=file) + call Print("IPModel_ASAP : yukalpha = "//this%yukalpha//" yuksmoothlength = "//this%yuksmoothlength, file=file) + call Print("IPModel_ASAP : cutoff_coulomb = "//this%cutoff_coulomb//" cutoff_ms = "//this%cutoff_ms, file=file) + + do ti=1, this%n_types + call Print ("IPModel_ASAP : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call Print ("IPModel_ASAP : pol = "//this%pol(ti), file=file) + call Print ("IPModel_ASAP : z = "//this%z(ti), file=file) + call verbosity_push_decrement() + do tj =1,this%n_types + call Print ("IPModel_ASAP : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) //& + " " // this%atomic_num(tj), file=file) + call Print ("IPModel_ASAP : pair " // this%D_ms(ti,tj) // " " // this%gamma_ms(ti,tj) // " " & + // this%R_ms(ti,tj) // " " // this%B_pol(ti,tj) // " " // this%C_pol(ti, tj), file=file) + end do + call verbosity_pop() + end do + +end subroutine IPModel_ASAP_Print + +subroutine IPModel_ASAP_read_params_xml(this, param_str) + use system_module, only : dp + type(IPModel_ASAP), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_ASAP_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_ASAP_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + use system_module, only : dp + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: val + + integer ti, tj, Zi, Zj + + if (name == 'TS_params') then ! new ASAP stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call Quip_fox_get_value(attributes, 'label', val, status) + if (status /= 0) val = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (val == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call Quip_fox_get_value(attributes, 'n_types', val, status) + if (status == 0) then + read (val, *), parse_ip%n_types + else + call system_abort("Can't find n_types in TS_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + allocate(parse_ip%pol(parse_ip%n_types)) + parse_ip%pol = 0.0_dp + allocate(parse_ip%z(parse_ip%n_types)) + + allocate(parse_ip%D_ms(parse_ip%n_types,parse_ip%n_types)) + parse_ip%D_ms = 0.0_dp + allocate(parse_ip%gamma_ms(parse_ip%n_types,parse_ip%n_types)) + parse_ip%gamma_ms = 0.0_dp + allocate(parse_ip%R_ms(parse_ip%n_types,parse_ip%n_types)) + parse_ip%R_ms = 0.0_dp + allocate(parse_ip%B_pol(parse_ip%n_types,parse_ip%n_types)) + parse_ip%B_pol = 0.0_dp + allocate(parse_ip%C_pol(parse_ip%n_types,parse_ip%n_types)) + parse_ip%C_pol = 0.0_dp + + call QUIP_FoX_get_value(attributes, "cutoff_coulomb", val, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find cutoff_coulomb") + read (val, *) parse_ip%cutoff_coulomb + + call QUIP_FoX_get_value(attributes, "cutoff_ms", val, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find cutoff_ms") + read (val, *) parse_ip%cutoff_ms + + call Quip_fox_get_value(attributes, "betapol", val, status) + if (status == 0) read (val, *) parse_ip%betapol + + call Quip_fox_get_value(attributes, "maxipol", val, status) + if (status == 0) read (val, *) parse_ip%maxipol + + call Quip_fox_get_value(attributes, "tolpol", val, status) + if (status == 0) read (val, *) parse_ip%tolpol + + call Quip_fox_get_value(attributes, "pred_order", val, status) + if (status == 0) read (val, *) parse_ip%pred_order + + call Quip_fox_get_value(attributes, "yukalpha", val, status) + if (status == 0) read (val, *) parse_ip%yukalpha + + call Quip_fox_get_value(attributes, "yuksmoothlength", val, status) + if (status == 0) read (val, *) parse_ip%yuksmoothlength + + parse_ip%tewald = .false. + call Quip_fox_get_value(attributes, "tewald", val, status) + if (status == 0) read (val, *), parse_ip%tewald + + parse_ip%tdip_sr = .true. + call Quip_fox_get_value(attributes, "tdip_sr", val, status) + if (status == 0) read (val, *), parse_ip%tdip_sr + + parse_ip%raggio = 0.0_dp + call Quip_fox_get_value(attributes, "raggio", val, status) + if (status == 0) read (val, *), parse_ip%raggio + + parse_ip%a_ew = 0.0_dp + call Quip_fox_get_value(attributes, "a_ew", val, status) + if (status == 0) read (val, *), parse_ip%a_ew + + parse_ip%gcut = 0.0_dp + call Quip_fox_get_value(attributes, "gcut", val, status) + if (status == 0) read (val, *), parse_ip%gcut + + parse_ip%iesr = 0 + call Quip_fox_get_value(attributes, "iesr", val, status) + if (status == 0) read (val, *), parse_ip%iesr + + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call Quip_fox_get_value(attributes, "type", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find type") + read (val, *) ti + + call Quip_fox_get_value(attributes, "atomic_num", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find atomic_num") + read (val, *) parse_ip%atomic_num(ti) + + call Quip_fox_get_value(attributes, "pol", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find pol") + read (val, *) parse_ip%pol(ti) + + call Quip_fox_get_value(attributes, "z", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find z") + read (val, *) parse_ip%z(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call Quip_fox_get_value(attributes, "atnum_i", val, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_i") + read (val, *) Zi + call Quip_fox_get_value(attributes, "atnum_j", val, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_j") + read (val, *) Zj + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + + call Quip_fox_get_value(attributes, "D_ms", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find D_ms") + read (val, *) parse_ip%D_ms(ti,tj) + call Quip_fox_get_value(attributes, "gamma_ms", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find gamma_ms") + read (val, *) parse_ip%gamma_ms(ti,tj) + call Quip_fox_get_value(attributes, "R_ms", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find R_ms") + read (val, *) parse_ip%R_ms(ti,tj) + call Quip_fox_get_value(attributes, "B_pol", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find B_pol") + read (val, *) parse_ip%B_pol(ti,tj) + call Quip_fox_get_value(attributes, "C_pol", val, status) + if (status /= 0) call system_abort ("IPModel_ASAP_read_params_xml cannot find C_pol") + read (val, *) parse_ip%C_pol(ti,tj) + + if (ti /= tj) then + parse_ip%D_ms(tj,ti) = parse_ip%D_ms(ti,tj) + parse_ip%gamma_ms(tj,ti) = parse_ip%gamma_ms(ti,tj) + parse_ip%R_ms(tj,ti) = parse_ip%R_ms(ti,tj) + parse_ip%B_pol(tj,ti) = parse_ip%B_pol(ti,tj) + parse_ip%C_pol(tj,ti) = parse_ip%C_pol(ti,tj) + endif + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + use system_module, only : dp + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'TS_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_ASAP_module diff --git a/src/Potentials/IPModel_BOP.F90 b/src/Potentials/IPModel_BOP.F90 new file mode 100644 index 0000000000..1e0100bf08 --- /dev/null +++ b/src/Potentials/IPModel_BOP.F90 @@ -0,0 +1,800 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_BOP module +!X +!% Module for Bond-Order potential +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_BOP_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_VERBOSE, PRINT_NERD, current_verbosity, initialise, OUTPUT, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use table_module +use atoms_types_module +use connection_module +use atoms_module +use clusters_module +use structures_module +use cinoutput_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_BOP +type IPModel_BOP + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + + integer :: n + type(Atoms) :: at + integer, allocatable, dimension(:) :: aptr + integer, allocatable, dimension(:) :: bptr + integer :: bptr_num + + character(len=STRING_LENGTH) :: label + +end type IPModel_BOP + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_BOP), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_BOP_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_BOP_Finalise +end interface Finalise + +interface Print + module procedure IPModel_BOP_Print, IPModel_BOP_Print_ptr +end interface Print + +interface Calc + module procedure IPModel_BOP_Calc +end interface Calc + +contains + +subroutine IPModel_BOP_Initialise_str(this, args_str, param_str) + type(IPModel_BOP), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BOP_Initialise_str args_str')) then + call system_abort("IPModel_BOP_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_BOP_read_params_xml(this, param_str) + +end subroutine IPModel_BOP_Initialise_str + +subroutine IPModel_BOP_Finalise(this) + type(IPModel_BOP), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_BOP_Finalise + + +! nat is the number of atoms whose energy and forces have to be computed with bop library +subroutine IPModel_BOP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_BOP), intent(inout):: this + type(Atoms), intent(inout) :: at !Active + buffer atoms + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), allocatable, dimension(:,:) :: f_bop +! real(dp), allocatable, dimension(:) :: local_e_bop + integer, allocatable, dimension(:) :: map_tobop + type(Atoms) :: at_bop !Active + buffer atoms + type(Atoms) :: at_tmp + real(dp) :: e_bop + integer :: nat !Number of active atoms, the first nat of at + type(Dictionary) :: params + integer :: i, nreplicate_x, nreplicate_y, nreplicate_z + logical :: lpbc, lreplicate_cell, lprint_xyz, lcrack,latoms + integer, pointer, dimension(:) :: map,map_bop, active, original_cell, hybrid + real(dp), pointer, dimension(:,:):: forces_bop +! real(dp), pointer, dimension(:) :: local_energy + integer :: nsafe, natoms_active + + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_BOP_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_BOP_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_BOP_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_BOP_Calc: local_virial calculation requested but not supported yet.", error) + endif + + lpbc = .false. + if (present(args_str)) then + call initialise(params) + call param_register(params, 'nat', '0', nat, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'pbc', '.false.', lpbc, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'replicate_x', '1', nreplicate_x, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'replicate_y', '1', nreplicate_y, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'replicate_z', '1', nreplicate_z, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'print_xyz', 'F', lprint_xyz, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'crack', 'F', lcrack, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'all_atoms', 'F', latoms, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BOP_Calc args_str')) then + call system_abort("IPModel_BOP_Calc failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_BOP_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_BOP_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + else + nat = 1 + endif + + + if(latoms.and.lcrack) call system_abort('IPModel_BOP: all_atoms ' // latoms// " and crack " // lcrack) + + if(nat.eq.0) then + if(lcrack) then + if (.not. assign_pointer(at, 'hybrid', hybrid)) & + call system_abort('IPModel_BOP: atoms structure is missing hybrid property') + natoms_active = count(hybrid/=0) + this%n = at%N + elseif(latoms) then + this%n = at%N + else + this%n = 1 + endif + else + this%n = nat + endif + + lreplicate_cell = .false. + if(nreplicate_x.ne.1.or.nreplicate_y.ne.1.or.nreplicate_z.ne.1) then + lreplicate_cell = .true. + endif + + if(lreplicate_cell.and.lpbc) then + call system_abort("IPModel_BOP_Calc: or PBC or replicates the unit cell") + endif + + at_tmp = at + call add_property(at_tmp, 'map', 0) + if (.not. assign_pointer(at_tmp, 'map', map)) & + call system_abort('active pointer assignment failed') + do i=1,at_tmp%N + map(i) = i + enddo + + if(lreplicate_cell) then + nsafe = 1 + call print("Replicate cell : "//nreplicate_x//" "// nreplicate_y //" "// nreplicate_z, PRINT_NERD) +! call supercell_minus_plus(at_bop, at_tmp, nreplicate_x, nsafe, nsafe) +! call supercell_minus_plus(at_tmp, at_bop, nsafe, nreplicate_y, nsafe) +! call supercell_minus_plus(at_bop, at_tmp, nsafe, nsafe,nreplicate_z) + call supercell(at_bop, at_tmp, nreplicate_x, nsafe, nsafe) + call supercell(at_tmp, at_bop, nsafe, nreplicate_y, nsafe) + call supercell(at_bop, at_tmp, nsafe, nsafe,nreplicate_z) + elseif(lpbc) then + call print ("Periodic boundary condition applied", PRINT_NERD) + call IPModel_BOP_compute_buffer(this,at,at_bop) + at_bop = at_tmp + else ! no pbc + at_bop = at_tmp + endif +! Assign map property for computing forces with BOP library + if (.not. has_property(at_bop, 'map')) & + call system_abort('IPModel_BOP: atoms structure has no "map" property') + if (.not. assign_pointer(at_bop, 'map', map_bop)) & + call system_abort('IPModel_BOP passed atoms structure with no map property') + allocate(map_tobop(at_bop%N)) + map_tobop = map_bop + +! A vacuum region surrounding the cluster has to be applied before computing the connecting + at_bop%lattice = at_bop%lattice * 3.0_dp +! Cutoff set to the potential value in order to reduce the number of neighbours for the BOP library + call set_cutoff(at_bop, this%cutoff) +! Recompute connectivity + call print('IPModel_BOP : cutoff used for connectivity' // at_bop%cutoff, PRINT_NERD) + call set_lattice(at_bop,at_bop%lattice,scale_positions=.false., remap=.true.,reconnect=.true.) + +! Atoms to be passed to the Bop library + this%at = at_bop + + if(this%n.gt.this%at%N) then + call system_abort("IPModel_BOP_Calc: number of atoms for BOP library "// this%n // " > at%N = " // this%at%N) + endif + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + local_e = 0.0_dp + if(size(local_e).gt.this%at%N) then + call system_abort("IPModel_BOP_Calc: reallocate local_e to the right value = (" // this%n // ") !") + endif + endif + if (present(f)) then + f = 0.0_dp + if(size(f,2).gt.this%at%N) then + call system_abort("IPModel_BOP_Calc: reallocate f to the right value = (3," // this%n // ") !") + endif + endif + if (present(virial)) virial = 0.0_dp + +! Compute the two pointer vectors required by the BOP library for the at_bop object + call print('Computing pointers for BOP library', PRINT_NERD) + call IPModel_BOP_Calc_ptr(this) + + if(allocated(f_bop)) deallocate(f_bop) + allocate(f_bop(3,this%n)) +! if(allocated(local_e_bop)) deallocate(local_e_bop) +! allocate(local_e_bop(this%n)) + f_bop = 0.0_dp + e_bop = 0.0_dp + +! Compute forces and energy with BOP library +#ifdef HAVE_BOP + call print('Calling BOP library : active atoms='// this%n// " on "//this%at%N ) + call system_timer('BOP') + call bop(this%n,this%at%N,this%at%pos,this%aptr,this%bptr_num,this%bptr,map_tobop,e_bop,f_bop) + call system_timer('BOP') + call print('BOP energy : ' // e_bop) +#else + call print('No BOP library!!!') +#endif + +! Print properties if print_xyz=T is passed in args_str + if(lprint_xyz) then + call add_property(at_bop, 'active', 0) + if (.not. assign_pointer(at_bop, 'active', active)) & + call system_abort('active pointer assignment failed') + active(1:this%n) = 1 + call add_property(at_bop, 'original_cell', 0) + if (.not. assign_pointer(at_bop, 'original_cell', original_cell)) & + call system_abort('original_cell pointer assignment failed') + original_cell(1:at%n) = 1 + call add_property(at_bop, 'forces_bop', 0.0_dp, n_cols=3) + if (.not. assign_pointer(at_bop, 'forces_bop', forces_bop)) & + call system_abort('forces_bop: failed to assign pointer to forces_bop') + forces_bop(:,1:this%n) = f_bop(:,1:this%n) +! call add_property(at_bop, 'local_energy', 0.0_dp) +! if (.not. assign_pointer(at_bop, 'local_energy', local_energy)) & +! call system_abort('local_energy: failed to assign pointer to local_bop') +! local_energy(1:this%n) = local_e_bop(1:this%n) + call write(at_bop, "bop_cell.xyz", properties='active:original_cell:map:forces_bop') + endif + + if(present(f)) then +! if (present(mpi)) call sum_in_place(mpi, f_bop) + if(lcrack) then + f(:,1:natoms_active) = f_bop(:,1:natoms_active) + else + f(:,1:this%n) = f_bop(:,1:this%n) + endif + endif + if(present(e)) e = e_bop +! if (present(mpi) .and. present(e)) e = sum(mpi, e_bop) + call print('Energy computed with BOP library : ' // e_bop // " eV ",PRINT_NERD) + if (present(mpi)) then + if (present(local_e)) call sum_in_place(mpi, local_e) + endif + if(current_verbosity() >= PRINT_NERD) then + do i =1, this%n + call print('Forces computed with BOP library on atom ' // i // " : " // f_bop(1,i) // " "// f_bop(2,i) // " " // f_bop(3,i) ) + enddo + endif + + call finalise(at_bop) + call finalise(at_tmp) + +end subroutine IPModel_BOP_Calc + +! compute aptr and bptr vectors required by the BOP library. +subroutine IPModel_BOP_Calc_ptr(this) + type(IPModel_BOP), intent(inout) :: this + integer :: nn, iat + integer :: ik, k, itemp + real(dp) :: rik + + if(allocated(this%aptr)) deallocate(this%aptr) + allocate(this%aptr(this%at%N)) + if(allocated(this%bptr)) deallocate(this%bptr) + nn = 0 + do iat = 1, this%at%N + nn = nn + n_neighbours(this%at, iat) + 2 + enddo + nn = nn + 1 + this%bptr_num = nn + allocate(this%bptr(this%bptr_num)) + + itemp = -1000000 + nn = 0 + do iat = 1, this%at%N + nn = nn + 1 + this%bptr(nn) = iat + this%aptr(iat) = nn + if(nn.ge.this%bptr_num) then + call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num") + endif + do ik = 1, n_neighbours(this%at, iat) + nn = nn + 1 + k = neighbour(this%at, iat, ik, rik) + this%bptr(nn) = k + if(nn.ge.this%bptr_num) then + call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num") + endif + enddo + nn = nn + 1 + this%bptr(nn) = itemp + if(nn.ge.this%bptr_num) then + call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num") + endif + enddo + this%bptr(this%bptr_num) = 0 + if(current_verbosity() >= PRINT_VERBOSE) then + call print(this,this%aptr,this%bptr) + endif + +end subroutine IPModel_BOP_Calc_ptr + +subroutine IPModel_BOP_Print(this, file) + type(IPModel_BOP), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_BOP : Bond-Order-Potential", file=file) + call Print("IPModel_BOP : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_BOP : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_BOP : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_BOP_Print + +subroutine IPModel_BOP_Print_ptr(this, aptr, bptr) + type(IPModel_BOP), intent(in) :: this + integer, intent(inout), dimension(:) :: aptr + integer, intent(inout), dimension(:) :: bptr + type(inoutput) :: file_a + type(inoutput) :: file_b + integer :: i + + call print("Printing aptr and bptr") + call initialise(file_a,'aptr.in', OUTPUT) + call initialise(file_b,'bptr.in', OUTPUT) + call print(this%at%N, file=file_a) + do i = 1, this%at%N + call print(" " // i // " " // this%aptr(i), file=file_a) + enddo + call print(this%bptr_num, file=file_b) + do i = 1, this%bptr_num + call print(" " // i // " " // this%bptr(i), file=file_b) + enddo + call finalise(file_a) + call finalise(file_b) + +end subroutine IPModel_BOP_Print_ptr + +subroutine IPModel_BOP_read_params_xml(this, param_str) + type(IPModel_BOP), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_BOP_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_BOP_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + integer ti + + if (name == 'BOP_params') then ! new BOP stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in BOP_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + endif + + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'BOP_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_BOP_compute_buffer(this,at,at_bop) + type(IPModel_BOP), intent(inout):: this + type(Atoms), intent(inout) :: at + type(Atoms), intent(inout) :: at_bop + integer :: cellsNa,cellsNb,cellsNc, n_atom + integer :: cellsNa2,cellsNb2,cellsNc2 + real(dp) :: cutoff + integer :: i_atom, i, j, k + type(table) :: list + + cutoff = this%cutoff + call print("calc_connect: cutoff calc_connect " // cutoff) + cellsNa = at%connect%cellsNa + cellsNb = at%connect%cellsNb + cellsNc = at%connect%cellsNc + cellsNa2 = nint(real(cellsNa,dp) / 2.0_dp ) + cellsNb2 = nint(real(cellsNb,dp) / 2.0_dp ) + cellsNc2 = nint(real(cellsNc,dp) / 2.0_dp ) + call print("calc_connect: cells_N[abc] " // cellsNa // " " // cellsNb // " " // cellsNc) + + call calc_connect(at) + +! pick an atom in the middle of the unit box + i_atom = -1 + loop_c : do k = cellsNc2, cellsNc + loop_b : do j = cellsNb2, cellsNb + loop_a : do i = cellsNa2, cellsNa +! n_atom = at%connect%cell(i,j,k)%N + n_atom = at%connect%cell_heads(i,j,k) + if(n_atom.ne.0) then +! i_atom = at%connect%cell(i,j,k)%int(1,1) + i_atom = n_atom + exit loop_c + endif + enddo loop_a + enddo loop_b + enddo loop_c + if(i_atom == -1) call system_abort("IPModel_BOP_compute_buffer : no atom in the halved simulation cell") + + call append(list, (/i_atom,0,0,0/)) + call BFS_grow(at, list, 4) + call print('---------------cluster--------------------', PRINT_NERD) + call print(list, PRINT_NERD) + call print('--------------end cluster-----------------', PRINT_NERD) + + call build_cluster(at, list, at_bop) + +end subroutine IPModel_BOP_compute_buffer + +subroutine build_cluster(at, list, at_bop) + type(Atoms), intent(inout) :: at + type(Atoms), intent(inout) :: at_bop + type(table) :: list + real(dp), dimension(3) :: dist, rmax, length + integer, dimension(3) :: n_cell_rep + integer :: iatom, jatom, i + + call print ('Number of atoms belonging to the cluster : ' // list%N ) + call print ('Cluster center atom : ' // list%int(1,1) ) + call print (' shift : ' // list%int(2:4,1) ) + +! Find how many cells have to be added + iatom = list%int(1,1) + rmax = 0.0_dp + do i = 2, list%N + jatom = list%int(1,i) + dist = abs( at%pos(:,iatom) - pos_j(at, jatom, list%int(2:4,i)) ) + if(dist(1) .gt. rmax(1)) rmax(1) = dist(1) + if(dist(2) .gt. rmax(2)) rmax(2) = dist(2) + if(dist(3) .gt. rmax(3)) rmax(3) = dist(3) + enddo + length(1) = at%lattice(1,1) / real(at%connect%cellsNa,dp) + length(2) = at%lattice(2,2) / real(at%connect%cellsNb,dp) + length(3) = at%lattice(3,3) / real(at%connect%cellsNc,dp) + + n_cell_rep = int(rmax/length) + 1 + call print("Number of cell repeated along the three directions : " // n_cell_rep(1:3) ) + +! Add to the simulation cell the just computed number of cells + call add_cells(at, n_cell_rep, at_bop) + +end subroutine build_cluster + +subroutine add_cells(at, n_cell_rep, at_bop) + type(Atoms), intent(inout) :: at + type(Atoms), intent(inout) :: at_bop + integer, dimension(3) :: cells, n_cell_rep, periodicity + integer :: i, j, k, ic, ic_right_p, ic_right_m, ii, iatom + real(dp) :: pos(3), length + + cells(1) = at%connect%cellsNa + cells(2) = at%connect%cellsNb + cells(3) = at%connect%cellsNc + + at_bop = at + do i = 1, 3 ! x, y, z + if(n_cell_rep(i).eq.0) cycle !skip this direction + do ic = 1, n_cell_rep(i) + ic_right_p = cells(i) - ic + 1 + int((ic - 1) / cells(i)) * cells(i) + ic_right_m = ic - 1 - int((ic - 1) / cells(i)) * cells(i) + + periodicity = 0 + periodicity(i) = int( (ic-1)/cells(i) + 1 ) + call print ("ic_right_p " // ic_right_p // " ; ic " // ic, PRINT_NERD) + call print ("ic_right_m " // ic_right_m // " ; ic " // ic, PRINT_NERD) + call print ("periodicity " // periodicity, PRINT_NERD) + + if(i.eq.1) then + do j = 1, cells(2) + do k = 1, cells(3) +! do ii = 1, at%connect%cell(ic_right_p,j,k)%N +! iatom = at%connect%cell(ic_right_p,j,k)%int(1,ii) + iatom = at%connect%cell_heads(ic_right_p,j,k) + do while(iatom > 0) + call print( j //" "// k // " atom : " // iatom // " " // cell_n(at%connect, ic_right_p,j,k)) + pos = at%pos(:,iatom) + real(periodicity,dp) * at%lattice(i,i) + call add_atoms(at_bop, pos, at%Z(iatom)) + iatom = at%connect%next_atom_in_cell(iatom) + enddo + +! do ii = 1, at%connect%cell(ic_right_m,j,k)%N +! iatom = at%connect%cell(ic_right_m,j,k)%int(1,ii) + iatom = at%connect%cell_heads(ic_right_m,j,k) + do while (iatom > 0) + call print( j //" "// k // " atom : " // iatom // " " // cell_n(at%connect, ic_right_m,j,k)) + pos = at%pos(:,iatom) + real(periodicity,dp) * at%lattice(i,i) + call add_atoms(at_bop, pos, at%Z(iatom)) + iatom = at%connect%next_atom_in_cell(iatom) + enddo + enddo + enddo + elseif(i.eq.2) then + + elseif(i.eq.3) then + + endif + + enddo + length = at%lattice(i,i) / cells(i) + at_bop%lattice(i,i) = at_bop%lattice(i,i) + n_cell_rep(i) * length * 2.0_dp + + enddo + + stop + +end subroutine add_cells + +function pos_j(at, j, shift) + type(Atoms), intent(inout) :: at + real(dp), dimension(3) :: pos_j + integer, dimension(3) :: shift + integer :: j + + pos_j = (at%lattice .mult. shift) + at%pos(:,j) + +end function pos_j + +!!$ subroutine supercell_minus_plus(aa, a, n1, n2, n3) +!!$ type(Atoms), intent(out)::aa !% Output (big) cell +!!$ type(Atoms), intent(in)::a !% Input cell +!!$ integer, intent(inout)::n1, n2, n3 +!!$ real(dp)::lattice(3,3), p(3) +!!$ integer::i,j,k,n +!!$ type(Table) :: big_data +!!$ integer :: nn1, n1save, n2save, n3save +!!$ integer, pointer, dimension(:) :: map_new, map +!!$ +!!$ n1save = n1 +!!$ n2save = n2 +!!$ n3save = n3 +!!$ n1 = 2 * n1 - 1 +!!$ n2 = 2 * n2 - 1 +!!$ n3 = 2 * n3 - 1 +!!$ +!!$ call allocate(big_data,a%data%intsize,a%data%realsize,& +!!$ a%data%strsize, a%data%logicalsize, a%N*n1*n2*n3) +!!$ +!!$ ! Replicate atomic data n1*n2*n3 times +!!$ do i=1,n1*n2*n3 +!!$ call append(big_data,a%data) +!!$ end do +!!$ +!!$ lattice(:,1) = a%lattice(:,1)*n1save +!!$ lattice(:,2) = a%lattice(:,2)*n2save +!!$ lattice(:,3) = a%lattice(:,3)*n3save +!!$ call atoms_initialise(aa, a%N*n1*n2*n3, lattice, data=big_data, properties=a%properties) +!!$ if (a%use_uniform_cutoff) then +!!$ call set_cutoff(aa, a%cutoff) +!!$ else +!!$ call set_cutoff_factor(aa, a%cutoff) +!!$ end if +!!$ +!!$ if (.not. assign_pointer(a, 'map', map)) & +!!$ call system_abort('active pointer assignment failed') +!!$ if (.not. assign_pointer(aa, 'map', map_new)) & +!!$ call system_abort('active pointer assignment failed') +!!$ +!!$ nn1 = 0 +!!$ do i = 0,n1save-1 +!!$ do j = 0,n2save-1 +!!$ do k = 0,n3save-1 +!!$ p = a%lattice .mult. (/i,j,k/) +!!$ do n = 1,a%N +!!$ ! overwrite position with shifted pos +!!$ nn1 = nn1 + 1 +!!$ aa%pos(:,nn1) = a%pos(:,n)+p +!!$ map_new(nn1) = map(n) +!!$ end do +!!$ if(i.eq.0.and.j.eq.0.and.k.eq.0) cycle +!!$ do n = 1,a%N +!!$ ! overwrite position with shifted pos +!!$ nn1 = nn1 + 1 +!!$ aa%pos(:,nn1) = a%pos(:,n)-p +!!$ map_new(nn1) = map(n) +!!$ end do +!!$ end do +!!$ end do +!!$ end do +!!$ +!!$ call finalise(big_data) +!!$ +!!$ end subroutine supercell_minus_plus + +end module IPModel_BOP_module diff --git a/src/Potentials/IPModel_BornMayer.F90 b/src/Potentials/IPModel_BornMayer.F90 new file mode 100644 index 0000000000..87ad935624 --- /dev/null +++ b/src/Potentials/IPModel_BornMayer.F90 @@ -0,0 +1,571 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_BornMayer +!X +!% BornMayer potential of the form $V_{ij} = A_{ij} exp(-b_{ij} r_{ij}) - c_{ij}/r_{ij}^6$ +!% Use together with an IPModel_Coulomb to include long range forces +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_BornMayer_module + + use error_module + use system_module, only : dp, inoutput, print, PRINT_VERBOSE, PRINT_ANALYSIS, current_verbosity, operator(//) + use dictionary_module + use paramreader_module + use linearalgebra_module + use atoms_types_module + use atoms_module + + use mpi_context_module + use QUIP_Common_module + + implicit none + private + + include 'IPModel_interface.h' + + public :: IPModel_BornMayer + type IPModel_BornMayer + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + real(dp), allocatable :: A(:,:), b(:,:), c(:,:), cutoff_a(:,:), & + energy_shift(:,:), linear_force_shift(:,:) + + real(dp) :: cutoff = 0.0_dp + + character(len=STRING_LENGTH) :: label + + end type IPModel_BornMayer + + logical, private :: parse_in_ip, parse_matched_label + type(IPModel_BornMayer), private, pointer :: parse_ip + + interface Initialise + module procedure IPModel_BornMayer_Initialise_str + end interface Initialise + + interface Finalise + module procedure IPModel_BornMayer_Finalise + end interface Finalise + + interface Print + module procedure IPModel_BornMayer_Print + end interface Print + + interface Calc + module procedure IPModel_BornMayer_Calc + end interface Calc + +contains + + subroutine IPModel_BornMayer_Initialise_str(this, args_str, param_str) + type(IPModel_BornMayer), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BornMayer_Initialise_str args_str')) then + call system_abort("IPModel_BornMayer_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_BornMayer_read_params_xml(this, param_str) + + this%cutoff = maxval(this%cutoff_a) + + end subroutine IPModel_BornMayer_Initialise_str + + subroutine IPModel_BornMayer_Finalise(this) + type(IPModel_BornMayer), intent(inout) :: this + + ! Add finalisation code here + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%A)) deallocate(this%A) + if (allocated(this%b)) deallocate(this%b) + if (allocated(this%c)) deallocate(this%c) + if (allocated(this%cutoff_a)) deallocate(this%cutoff_a) + if (allocated(this%energy_shift)) deallocate(this%energy_shift) + if (allocated(this%linear_force_shift)) deallocate(this%linear_force_shift) + + this%n_types = 0 + this%label = '' + end subroutine IPModel_BornMayer_Finalise + + + subroutine IPModel_BornMayer_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_BornMayer), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + integer i, ji, j, ti, tj, n_neigh_i + real(dp) :: drij(3), drij_mag + real(dp) :: drij_dri(3), drij_drj(3) + real(dp) :: virial_i(3,3) + real(dp) :: de, de_dr, de_drij + + +#ifdef _OPENMP + real(dp) :: private_virial(3,3), private_e + real(dp), allocatable :: private_f(:,:), private_local_e(:), private_local_virial(:,:) +#endif + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_BornMayer_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_BornMayer_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_BornMayer_Calc', error) + local_virial = 0.0_dp + endif + + atom_mask_pointer => null() + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of property containing logical mask for calculation") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BornMayer_Calc args_str')) then + RAISE_ERROR("IPModel_BornMayer_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_BornMayer_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + else + atom_mask_pointer => null() + endif + else + do_rescale_r = .false. + do_rescale_E = .false. + endif + + if (do_rescale_r) call print('IPModel_BornMayer_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) + if (do_rescale_E) call print('IPModel_BornMayer_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) + + +#ifdef _OPENMP + !$omp parallel default(none) private(i, ji, j, drij, drij_mag, ti, tj, drij_dri, drij_drj, de, de_dr, de_drij, private_virial, private_e, private_f, private_local_e, private_local_virial, n_neigh_i, virial_i) shared(this, at, e, virial, atom_mask_pointer, mpi, do_rescale_r, r_scale, f, local_e, local_virial) + + if (present(e)) private_e = 0.0_dp + if (present(local_e)) then + allocate(private_local_e(at%N)) + private_local_e = 0.0_dp + endif + if (present(f)) then + allocate(private_f(3,at%N)) + private_f = 0.0_dp + endif + if (present(virial)) private_virial = 0.0_dp + if (present(local_virial)) then + allocate(private_local_virial(9,at%N)) + private_local_virial = 0.0_dp + endif + + !$omp do +#endif + do i=1, at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_BornMayer_Calc i " // i // " " // n_neighbours(at,i), PRINT_ANALYSIS) + n_neigh_i = n_neighbours(at, i) + do ji=1, n_neigh_i + j = neighbour(at, i, ji, drij_mag, cosines=drij, max_dist=this%cutoff) + if (j <= 0) cycle + if (drij_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) drij_mag = drij_mag*r_scale + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_BornMayer_Calc i j " // i // " " // j, PRINT_ANALYSIS) + + if (present(e) .or. present(local_e)) then + + de = IPModel_BornMayer_pairenergy(this, ti, tj, drij_mag) + + if (present(local_e)) then +#ifdef _OPENMP + private_local_e(i) = private_local_e(i) + de +#else + local_e(i) = local_e(i) + de +#endif + endif + if (present(e)) then +#ifdef _OPENMP + private_e = private_e + de +#else + e = e + de +#endif + endif + endif + + if (present(f) .or. present(virial) .or. present(local_virial)) then + + de_dr = IPModel_BornMayer_pairenergy_deriv(this, ti, tj, drij_mag) + + if (present(f)) then +#ifdef _OPENMP + private_f(:,i) = private_f(:,i) + de_dr*drij + private_f(:,j) = private_f(:,j) - de_dr*drij +#else + f(:,i) = f(:,i) + de_dr*drij + f(:,j) = f(:,j) - de_dr*drij +#endif + endif + + if(present(virial) .or. present(local_virial)) virial_i = de_dr*(drij .outer. drij)*drij_mag + + if (present(virial)) then +#ifdef _OPENMP + private_virial = private_virial - virial_i +#else + virial = virial - virial_i +#endif + endif + if (present(local_virial)) then +#ifdef _OPENMP + private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i, (/9/)) +#else + local_virial(:,i) = local_virial(:,i) - reshape(virial_i, (/9/)) +#endif + endif + + endif + end do + end do + +#ifdef _OPENMP + !$omp critical + if (present(e)) e = e + private_e + if (present(f)) f = f + private_f + if (present(local_e)) local_e = local_e + private_local_e + if (present(virial)) virial = virial + private_virial + if (present(local_virial)) local_virial = local_virial + private_local_virial + !$omp end critical + + if(allocated(private_f)) deallocate(private_f) + if(allocated(private_local_e)) deallocate(private_local_e) + if(allocated(private_local_virial)) deallocate(private_local_virial) + + !$omp end parallel +#endif + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) call sum_in_place(mpi, f) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(local_virial)) call sum_in_place(mpi, local_virial) + endif + + if (do_rescale_r) then + if (present(f)) f = f*r_scale + end if + + if (do_rescale_E) then + if (present(e)) e = e*E_scale + if (present(local_e)) local_e = local_e*E_scale + if (present(f)) f = f*E_scale + if (present(virial)) virial=virial*E_scale + if (present(local_virial)) local_virial=local_virial*E_scale + end if + + atom_mask_pointer => null() + + end subroutine IPModel_BornMayer_Calc + + function IPModel_BornMayer_pairenergy(this, ti, tj, r) + type(IPModel_BornMayer), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_BornMayer_pairenergy + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then + IPModel_BornMayer_pairenergy = 0.0_dp + return + endif + + IPModel_BornMayer_pairenergy = 0.5_dp*((this%A(ti,tj)*exp(-this%b(ti,tj)*r) - this%c(ti,tj)/(r**6.0_dp)) & + - this%energy_shift(ti,tj) - this%linear_force_shift(ti,tj)*(r-this%cutoff_a(ti,tj))) + + end function IPModel_BornMayer_pairenergy + + function IPModel_BornMayer_pairenergy_deriv(this, ti, tj, r) + type(IPModel_BornMayer), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_BornMayer_pairenergy_deriv + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then + IPModel_BornMayer_pairenergy_deriv = 0.0_dp + return + endif + + IPModel_BornMayer_pairenergy_deriv = 0.5_dp*(-this%b(ti,tj)*this%A(ti,tj)*exp(-this%b(ti,tj)*r) & + + 6.0_dp*this%c(ti,tj)/(r**7.0_dp) - this%linear_force_shift(ti,tj)) + + end function IPModel_BornMayer_pairenergy_deriv + + + subroutine IPModel_BornMayer_Print(this, file) + type(IPModel_BornMayer), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_BornMayer : BornMayer Potential", file=file) + call Print("IPModel_BornMayer : n_types = " // this%n_types, file=file) + do ti=1, this%n_types + call Print ("IPModel_BornMayer : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + do tj=1, this%n_types + call Print ("IPModel_BornMayer : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) // & + " " // this%atomic_num(tj), file=file) + call Print ("IPModel_BornMayer : pair A=" // this%A(ti,tj) // " b=" // this%b(ti,tj) // " c=" //this%c(ti,tj), file=file) + call Print (" cutoff="//this%cutoff_a(ti,tj)//" energy_shift="//this%energy_shift(ti,tj), file=file) + call Print (" linear_force_shift="//this%linear_force_shift(ti,tj), file=file) + end do + end do + + end subroutine IPModel_BornMayer_Print + + subroutine IPModel_BornMayer_read_params_xml(this, param_str) + type(IPModel_BornMayer), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_BornMayer_read_params_xml parsed file, but n_types = 0") + endif + + end subroutine IPModel_BornMayer_read_params_xml + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !% XML param reader functions + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + logical :: energy_shift, linear_force_shift + + integer :: status + character(len=STRING_LENGTH) :: value + + integer ti, tj, Zi, Zj + + if (name == 'BornMayer_params') then ! new BornMayer stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in BornMayer_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + allocate(parse_ip%A(parse_ip%n_types,parse_ip%n_types)) + parse_ip%A = 0.0_dp + allocate(parse_ip%b(parse_ip%n_types,parse_ip%n_types)) + parse_ip%b = 0.0_dp + allocate(parse_ip%c(parse_ip%n_types,parse_ip%n_types)) + parse_ip%c = 0.0_dp + allocate(parse_ip%cutoff_a(parse_ip%n_types,parse_ip%n_types)) + parse_ip%cutoff_a = 0.0_dp + allocate(parse_ip%energy_shift(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%linear_force_shift(parse_ip%n_types,parse_ip%n_types)) + parse_ip%energy_shift = 0.0_dp + parse_ip%linear_force_shift = 0.0_dp + endif + + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + parse_ip%energy_shift = 0.0_dp + parse_ip%linear_force_shift = 0.0_dp + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "atnum_i", value, status) + if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find atnum_i") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find atnum_j") + read (value, *) Zj + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "A", value, status) + if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find A") + read (value, *) parse_ip%A(ti,tj) + call QUIP_FoX_get_value(attributes, "b", value, status) + if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find b") + read (value, *) parse_ip%b(ti,tj) + call QUIP_FoX_get_value(attributes, "c", value, status) + if (status /= 0) call system_abort ("IPModel_BornMayer_read_params_xml cannot find c") + read (value, *) parse_ip%c(ti,tj) + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff_a(ti,tj) + + call QUIP_FoX_get_value(attributes, "energy_shift", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find energy_shift") + read (value, *) energy_shift + if (energy_shift) parse_ip%energy_shift(ti,tj) = IPModel_BornMayer_pairenergy(parse_ip, ti, tj, parse_ip%cutoff_a(ti,tj)) + + call QUIP_FoX_get_value(attributes, "linear_force_shift", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find linear_force_shift") + read (value, *) linear_force_shift + if (linear_force_shift) parse_ip%linear_force_shift(ti,tj) = IPModel_BornMayer_pairenergy_deriv(parse_ip, ti, tj, parse_ip%cutoff_a(ti,tj)) + + if (ti /= tj) then + parse_ip%A(tj,ti) = parse_ip%A(ti,tj) + parse_ip%b(tj,ti) = parse_ip%b(ti,tj) + parse_ip%c(tj,ti) = parse_ip%c(ti,tj) + parse_ip%cutoff_a(tj,ti) = parse_ip%cutoff_a(ti,tj) + parse_ip%energy_shift(tj,ti) = parse_ip%energy_shift(ti,tj) + parse_ip%linear_force_shift(tj,ti) = parse_ip%linear_force_shift(ti,tj) + endif + end if + + end subroutine IPModel_startElement_handler + + subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'BornMayer_params') then + parse_in_ip = .false. + end if + endif + + end subroutine IPModel_endElement_handler + +end module IPModel_BornMayer_module diff --git a/src/Potentials/IPModel_Brenner.F90 b/src/Potentials/IPModel_Brenner.F90 new file mode 100644 index 0000000000..b6ea2be178 --- /dev/null +++ b/src/Potentials/IPModel_Brenner.F90 @@ -0,0 +1,713 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Brenner module +!X +!% Module for computing energy, forces and virial with Brenner potential for hydrocarbons. +!% Ref. D. W. Brenner, Empirical potential for hydrocarbons for use in +!% simulating the chemical vapor deposition of diamond films. +!% Phys. Rev. B {\bf 42}, 9458 (1990). +!% The 'IPModel_Brenner' object reads parameters from a 'Brenner_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Brenner_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use units_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Brenner +type IPModel_Brenner + integer :: n_types = 0 !% Number of atomic types + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} + + real(dp) :: cutoff = 0.0_dp + + real(dp), allocatable :: R1(:,:), R2(:,:), De(:,:), S(:,:), beta(:,:) !% IP parameters + real(dp), allocatable :: delta(:,:), Re(:,:), a0(:,:,:), c0(:,:,:), d0(:,:,:) !% IP parameters + real(dp), allocatable :: shift(:,:) + + character(len=STRING_LENGTH) :: label + +end type IPModel_Brenner + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Brenner), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Brenner_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Brenner_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Brenner_Print +end interface Print + +interface Calc + module procedure IPModel_Brenner_Calc +end interface Calc + +contains + +subroutine IPModel_Brenner_Initialise_str(this, args_str, param_str) + type(IPModel_Brenner), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_Initialise_str args_str')) then + call system_abort("IPModel_Brenner_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Brenner_read_params_xml(this, param_str) + +end subroutine IPModel_Brenner_Initialise_str + +subroutine IPModel_Brenner_Finalise(this) + type(IPModel_Brenner), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%R1)) deallocate(this%R1) + if (allocated(this%R2)) deallocate(this%R2) + if (allocated(this%De)) deallocate(this%De) + if (allocated(this%S)) deallocate(this%S) + if (allocated(this%beta)) deallocate(this%beta) + if (allocated(this%delta)) deallocate(this%delta) + if (allocated(this%Re)) deallocate(this%Re) + if (allocated(this%a0)) deallocate(this%a0) + if (allocated(this%c0)) deallocate(this%c0) + if (allocated(this%d0)) deallocate(this%d0) + if (allocated(this%shift)) deallocate(this%shift) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Brenner_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X The potential calculator +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!% This routine computes energy, forces and the virial. +!% Derivatives by James Kermode jrk33@cam.ac.uk +subroutine IPModel_Brenner_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Brenner), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer :: i,j,k,m,n,r,s,p, max_neighb + integer :: ti,tj,tk,tr,ts + real(dp) :: r_ij, fc_ij, dfc_ij, & + Vr1, Va1, Vr, Va, dVr_ij, dVa_ij, G_sum, B(2), Bbar, & + t1, t2, prefactor + real(dp), dimension(:), allocatable :: cos_theta, r_rk, fc_rk, dfc_rk, & + G, dG_dcostheta + real(dp), dimension(3) :: u_ij, u_rs, grad_s, grad_k, f_s, f_k, f_ij + real(dp), dimension(:,:), allocatable :: u_rk + real(dp), pointer :: w_e(:) + real(dp) :: De_ij, R1_ij, R2_ij, Re_ij, S_ij, beta_ij, delta_ij, shift_ij, w_f + real(dp) :: a0_ijk, c0_2_ijk, d0_2_ijk, R1_rk, R2_rk, de + + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) then + e = 0.0_dp + endif + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Brenner_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_Brenner_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) then + virial = 0.0_dp + endif + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_Brenner_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_Brenner_Calc: local_virial calculation requested but not supported yet", error) + endif + + if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Brenner_Calc args_str')) then + RAISE_ERROR("IPModel_Brenner_Calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then + RAISE_ERROR("IPModel_Brenner_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.",error) + endif + else + atom_mask_pointer => null() + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_Brenner_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + endif + + ! Find maximum number of neighbours and allocate + ! temporary storage for bond vectors and angles + max_neighb = 0 + do i=1,at%N + n = n_neighbours(at, i) + if (n > max_neighb) max_neighb = n + end do + + allocate(cos_theta(max_neighb)) + allocate(r_rk(max_neighb), u_rk(3,max_neighb)) + allocate(fc_rk(max_neighb), dfc_rk(max_neighb)) + allocate(G(max_neighb), dG_dcostheta(max_neighb)) + + do i=1,at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + ! Loop over neighbour of atom i + do n=1, n_neighbours(at, i) + j = neighbour(at, i, n,r_ij,cosines=u_ij) + if (r_ij .feq. 0.0_dp) cycle + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + R1_ij = this%R1(ti,tj) + R2_ij = this%R2(ti,tj) + + if (r_ij < R2_ij) then + De_ij = this%De(ti,tj) + Re_ij = this%Re(ti,tj) + S_ij = this%S(ti,tj) + beta_ij = this%beta(ti,tj) + delta_ij = this%delta(ti,tj) + shift_ij = this%shift(ti,tj) + else + cycle ! Outside range of cutoff function + end if + + call brenner_cutoff(r_ij, R1_ij, R2_ij, fc_ij, dfc_ij) + + ! Evaluate attractive and repulsive pair potentials + Vr1 = De_ij/(S_ij-1.0_dp)* & + exp(-sqrt(2.0_dp*S_ij)*beta_ij*(r_ij-Re_ij)) + Va1 = De_ij*S_ij/(S_ij-1.0_dp)* & + exp(-sqrt(2.0_dp/S_ij)*beta_ij*(r_ij-Re_ij)) + + Vr = Vr1*fc_ij + Va = Va1*fc_ij + + ! Derivatives of Vr and Va wrt r_ij + dVr_ij = Vr1*(-sqrt(2.0_dp*S_ij)*beta_ij*fc_ij + dfc_ij) + dVa_ij = Va1*(-sqrt(2.0_dp/S_ij)*beta_ij*fc_ij + dfc_ij) + + ! Repeat twice, first centred on atom i -> B_ij and derivatives + ! second time centred on atom j -> B_ji and derivatives + do p = 1,2 + + if (p == 1) then + r = i; s = j + tr = ti; ts = tj; + u_rs = u_ij + else + r = j; s = i + tr = tj; ts = ti; + u_rs = -u_ij ! reverse bond vector 2nd time + end if + + ! First we loop over neighbours of atom r (i or j) + ! to get get total bond order factors B_ij and B_ji. + ! Store r_rk, u_rk, cos_theta, fc_rk, dfc_rk, G, + ! and dG_dcostheta for each neighbour to save having + ! to recalculate them below when we evaluate forces + G_sum = 0.0_dp + do m=1, n_neighbours(at, r) + k = neighbour(at, r, m, r_rk(m), cosines=u_rk(:,m)) + if (k == i .or. k == j) cycle + if (r_rk(m) .feq. 0.0_dp) cycle + + tk = get_type(this%type_of_atomic_num, at%Z(k)) + + R1_rk = this%R1(tr,tk) + R2_rk = this%R2(tr,tk) + + ! First time: r_rk = r_ik + ! Second time: r_rk = r_jk + if (r_rk(m) > R2_rk) cycle ! Outside range of cutoff function + + a0_ijk = this%a0(ti,tj,tk) + c0_2_ijk = this%c0(ti,tj,tk)*this%c0(ti,tj,tk) + d0_2_ijk = this%d0(ti,tj,tk)*this%d0(ti,tj,tk) + + ! first time: theta_ijk + ! Second time: theta_jik + call brenner_cutoff(r_rk(m), R1_rk, R2_rk, fc_rk(m), dfc_rk(m)) + + cos_theta(m) = u_rs .dot. u_rk(:,m) + + t1 = (1.0_dp + cos_theta(m)); t2 = t1*t1 + G(m) = a0_ijk*(1.0_dp + c0_2_ijk/d0_2_ijk - & + c0_2_ijk/(d0_2_ijk + t2)) + dG_dcostheta(m) = 2.0_dp*a0_ijk*c0_2_ijk*t1/ & + ((d0_2_ijk + t2)**2) + + G_sum = G_sum + G(m)*fc_rk(m) + end do + + ! This is the bond order factor + B(p) = (1.0_dp + G_sum)**(-delta_ij) + + ! Now we need to loop over neigbours again to work out + ! derivaties of B_ij or B_ji wrt atom positions. We + ! get gradient from chain rule and the results that: + ! + ! grad_j(cos_theta_ijk) = (u_ik - cos_theta*u_ij)/r_ij + ! grad_k(cos_theta_ijk) = (u_ij - cos_theta*u_ik)/r_ik + ! grad_i(cos_theta_ijk) = -(grad_j + grad_k) + ! + ! Use previously cached data for each neighbour + + if (associated(w_e)) then + w_f = 0.5_dp*(w_e(i)+w_e(j)) + else + w_f = 1.0_dp + endif + + if (present(f) .or. present(virial)) then + + prefactor = 0.5_dp*w_f*0.5_dp*Va*delta_ij/ & + ((1.0_dp + G_sum)**(1.0_dp + delta_ij)) + + do m=1, n_neighbours(at, r) + k = neighbour(at, r, m) + if (k == i .or. k == j) cycle + if (r_rk(m) > R2_ij) cycle ! Outside range of cutoff function + + ! force on atom k depends on r_ik or r_jk, hence second term + ! First time: F_k ~ grad_k(theta_ijk) + grad_k(r_ik) + ! Second time: F_k ~ grad_k(theta_jik) + grad_k(r_jk) + grad_k = (u_rs - cos_theta(m)*u_rk(:,m))/r_rk(m) + f_k = -prefactor*(grad_k*dG_dcostheta(m)*fc_rk(m) + G(m)*dfc_rk(m)*u_rk(:,m)) + if (present(f)) then + f(:,k) = f(:,k) + f_k + end if + + ! First time: F_j ~ grad_j(theta_ijk) + ! Second time: F_i ~ grad_i(theta_jik) + grad_s = (u_rk(:,m) - cos_theta(m)*u_rs)/r_ij + f_s = -prefactor*(grad_s*dG_dcostheta(m)*fc_rk(m)) + if (present(f)) then + f(:,s) = f(:,s) + f_s + end if + + ! First time: F_i = -(F_k + F_j) + ! Second time: F_j = -(F_k + F_i) + if (present(f)) then + f(:,r) = f(:,r) - (f_k + f_s) + end if + + if (present(virial)) then + virial = virial + ((u_rs*r_ij) .outer. f_s) + & + ((u_rk(:,m)*r_rk(m)) .outer. f_k) + end if + + end do + end if + end do + + ! Finally, average bond order factors B_ij and B_ji + Bbar = 0.5_dp*(B(1) + B(2)) + shift_ij + + ! Add two-body part of f + if (present(f) .or. present(virial)) then + t1 = dVr_ij - Bbar*dVa_ij + f_ij = 0.5_dp*w_f*t1*u_ij + + if (present(f)) then + f(:,i) = f(:,i) + f_ij + f(:,j) = f(:,j) - f_ij + end if + + ! 2 body contribution to virial + if (present(virial)) then + virial = virial - ((u_ij*r_ij) .outer. f_ij) + end if + + end if + + if (present(e) .or. present(local_e)) then + de = 0.5_dp*(Vr - Bbar*Va) + if (present(local_e)) then + local_e(i) = local_e(i) + 0.5_dp*de + local_e(j) = local_e(j) + 0.5_dp*de + end if + if (present(e)) then + e = e + de*w_f + end if + end if + + end do + end do + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) call sum_in_place(mpi, f) + if (present(virial)) call sum_in_place(mpi, virial) + endif + + deallocate(cos_theta) + deallocate(r_rk, u_rk) + deallocate(fc_rk, dfc_rk) + deallocate(G, dG_dcostheta) + +end subroutine IPModel_Brenner_Calc + + +!% Evaluate cutoff function \texttt{fc} and its derivative \texttt{dfc} wrt r +subroutine brenner_cutoff(r, R1, R2, fc, dfc) + real(dp), intent(in) :: r, R1, R2 + real(dp), intent(out) :: fc, dfc + + if (r < R1) then + fc = 1.0_dp + dfc = 0.0_dp !fc constant, so d(fc)/dr = 0 + else + fc = 0.5_dp*(1.0_dp + cos(PI*(r-R1)/(R2-R1))) + dfc = -0.5_dp*PI*sin(PI*(r-R1)/(R2-R1))/(R2-R1) + end if +end subroutine brenner_cutoff + + + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% Parameters can be given using an external input file or with an internal string. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: value + + integer ti, tj, tk, Zi, Zj, Zk + + if (name == 'Brenner_params') then ! new Brenner stanza + + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered Brenner_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, "n_types", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find n_types") + read (value, *) parse_ip%n_types + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + allocate(parse_ip%R1(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%R2(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%De(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%S(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%beta(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%delta(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%Re(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%a0(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%c0(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%d0(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%shift(parse_ip%n_types,parse_ip%n_types)) + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "atnum_i", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_i") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_j") + read (value, *) Zj + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "R1", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find R1") + read (value, *) parse_ip%R1(ti,tj) + call QUIP_FoX_get_value(attributes, "R2", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find R2") + read (value, *) parse_ip%R2(ti,tj) + call QUIP_FoX_get_value(attributes, "De", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find De") + read (value, *) parse_ip%De(ti,tj) + call QUIP_FoX_get_value(attributes, "S", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find S") + read (value, *) parse_ip%S(ti,tj) + call QUIP_FoX_get_value(attributes, "beta", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find beta") + read (value, *) parse_ip%beta(ti,tj) + call QUIP_FoX_get_value(attributes, "delta", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find delta") + read (value, *) parse_ip%delta(ti,tj) + call QUIP_FoX_get_value(attributes, "Re", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find Re") + read (value, *) parse_ip%Re(ti,tj) + call QUIP_FoX_get_value(attributes, "shift", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find shift") + read (value, *) parse_ip%shift(ti,tj) + + + if (ti /= tj) then + parse_ip%R1(tj,ti) = parse_ip%R1(ti,tj) + parse_ip%R2(tj,ti) = parse_ip%R2(ti,tj) + parse_ip%De(tj,ti) = parse_ip%De(ti,tj) + parse_ip%S(tj,ti) = parse_ip%S(ti,tj) + parse_ip%beta(tj,ti) = parse_ip%beta(ti,tj) + parse_ip%delta(tj,ti) = parse_ip%delta(ti,tj) + parse_ip%Re(tj,ti) = parse_ip%Re(ti,tj) + parse_ip%shift(tj,ti) = parse_ip%shift(ti,tj) + endif + + parse_ip%cutoff = maxval(parse_ip%R2) + + elseif (parse_in_ip .and. name == 'per_triplet_data') then + + call QUIP_FoX_get_value(attributes, "atnum_c", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_c") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_j") + read (value, *) Zj + call QUIP_FoX_get_value(attributes, "atnum_k", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find atnum_k") + read (value, *) Zk + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + tk = get_type(parse_ip%type_of_atomic_num,Zk) + + call QUIP_FoX_get_value(attributes, "a0", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find a0") + read (value, *) parse_ip%a0(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "c0", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find c0") + read (value, *) parse_ip%c0(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "d0", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_read_params_xml cannot find d0") + read (value, *) parse_ip%d0(ti,tj,tk) + + if (tj /= tk) then + parse_ip%a0(ti,tk,tj) = parse_ip%a0(ti,tj,tk) + parse_ip%c0(ti,tk,tj) = parse_ip%c0(ti,tj,tk) + parse_ip%d0(ti,tk,tj) = parse_ip%d0(ti,tj,tk) + endif + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Brenner_params') then + parse_in_ip = .false. + endif + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_Brenner_read_params_xml(this, param_str) + type(IPModel_Brenner), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type (xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_ip => this + parse_in_ip = .false. + parse_matched_label = .false. + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Brenner_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_Brenner_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of Brenner potential parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_Brenner_Print (this, file) + type(IPModel_Brenner), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj, tk + + call Print("IPModel_Brenner : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print("IPModel_Brenner : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + do tj=1, this%n_types + call Print ("IPModel_Brenner : pair "// ti // " " // tj // " R1 " // this%R1(ti,tj) & + // " R2 " // this%R2(ti,tj)// " De " // this%De(ti,tj)// " S " // this%S(ti,tj) & + // " beta " // this%beta(ti,tj)// " delta " // this%delta(ti,tj) & + // " Re " // this%Re(ti,tj)// " shift " // this%shift(ti,tj), file=file) + do tk=1,this%n_types + call Print("IPModel_Brenner : triplet "// ti //" "//tj//" "//tk//" a0 "//this%a0(ti,tj,tk)& + //" c0 "//this%c0(ti,tj,tj)//" d0 "//this%d0(ti,tj,tk),file=file) + end do + end do + call verbosity_pop() + end do + +end subroutine IPModel_Brenner_Print + +end module IPModel_Brenner_module diff --git a/src/Potentials/IPModel_Brenner_2002.F90 b/src/Potentials/IPModel_Brenner_2002.F90 new file mode 100644 index 0000000000..fcd5d0349c --- /dev/null +++ b/src/Potentials/IPModel_Brenner_2002.F90 @@ -0,0 +1,399 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Brenner_Screened module +!X +!% Module for interfacing to Brenner Potential as described in +!% Brenner et al. `A second-generation reactive empirical bond order (REBO) potential +!% energy expression for hydrocarbons', J. Phys.: Cond Mat (2002) vol. 14 (4) pp. 783-802 +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Brenner_2002_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +#ifdef HAVE_MDCORE +use force_brenner2002, only: force_brenner2002_kernel +use db_brenner2002, only: db_brenner2002_init +#endif + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Brenner_2002 +type IPModel_Brenner_2002 + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + + integer :: n + type(Atoms) :: at + integer, allocatable, dimension(:) :: aptr + integer, allocatable, dimension(:) :: bptr + integer :: bptr_num + + character(len=STRING_LENGTH) :: label + +end type IPModel_Brenner_2002 + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Brenner_2002), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Brenner_2002_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Brenner_2002_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Brenner_2002_Print +end interface Print + +interface Calc + module procedure IPModel_Brenner_2002_Calc +end interface Calc + +contains + +subroutine IPModel_Brenner_2002_Initialise_str(this, args_str, param_str) + type(IPModel_Brenner_2002), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + character(len=STRING_LENGTH) label + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_2002_Initialise_str args_str')) then + call system_abort("IPModel_Brenner_2002_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Brenner_2002_read_params_xml(this, param_str) + +#ifdef HAVE_MDCORE + call db_brenner2002_init() + this%cutoff = 2.0_dp +#else + call system_abort('IPModel_Brenner_2002_Initialise - support for mdcore not compiled in') +#endif + +end subroutine IPModel_Brenner_2002_Initialise_str + +subroutine IPModel_Brenner_2002_Finalise(this) + type(IPModel_Brenner_2002), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Brenner_2002_Finalise + + +subroutine IPModel_Brenner_2002_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Brenner_2002), intent(inout):: this + type(Atoms), intent(inout) :: at !Active + buffer atoms + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer:: i,n + real(dp), dimension(:,:), allocatable :: pos_in, force_out, dr + real(dp) :: brenner_e, brenner_virial(3,3) + + real(dp), dimension(:,:,:), allocatable :: w_per_at + integer, dimension(:), allocatable :: aptr, bptr, k_typ + integer :: n_tot, neighb + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Brenner_2002_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Brenner_2002_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Brenner_2002_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_Brenner_2002_Calc: local_virial calculation requested but not supported yet.", error) + endif + + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_2002_Calc args_str')) then + RAISE_ERROR("IPModel_Brenner_2002_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_Brenner_2002_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_Brenner_2002_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + endif + + + n_tot = 0 + do i=1,at%N + n_tot = n_tot + n_neighbours(at, i) + end do + + allocate(aptr(at%N+1),bptr(n_tot+at%n+1),dr(n_tot+at%n+1,3), w_per_at(3,3,at%n), & + pos_in(at%n,3),force_out(at%n,3),k_typ(at%N)) + force_out = 0.0_dp + dr = 0.0_dp + brenner_e = 0.0_dp + aptr = 0 + bptr = 0 + + k_typ = 1 + + neighb = 1 + do i=1,at%N + pos_in(i,:) = at%pos(:,i) + + aptr(i) = neighb + do n=1,n_neighbours(at,i) + bptr(neighb) = neighbour(at,i,n, diff=dr(neighb,:)) + dr(neighb,:) = -dr(neighb,:) ! opposite sign convention + + neighb = neighb + 1 + end do + neighb = neighb + 1 + end do + bptr(neighb) = 0 + aptr(at%N+1) = neighb + + brenner_virial = 0.0_dp +#ifdef HAVE_MDCORE + call force_brenner2002_kernel(at%N,pos_in,k_typ,brenner_e,force_out, brenner_virial, & + aptr, bptr, size(bptr), dr, w_per_at) +#else + call system_abort('IPModel_Brenner_2002 - mdcore support not compiled in') +#endif + + if (present(local_e)) call system_abort('IPModel_Brenner_2002 - no support for local energies') + + if (present(e)) e = brenner_e + + if (present(f)) then + do i=1,at%N + f(:,i) = force_out(i,:) + end do + end if + + if (present(virial)) then + virial = -brenner_virial + end if + + deallocate(aptr,bptr,dr,pos_in,force_out,w_per_at) + +end subroutine IPModel_Brenner_2002_Calc + + +subroutine IPModel_Brenner_2002_Print(this, file) + type(IPModel_Brenner_2002), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_Brenner_2002 : 2nd generation Brenner Potential", file=file) + call Print(" J. Phys.: Cond Mat (2002) vol. 14 (4) pp. 783-802", file=file) + call Print("IPModel_Brenner_2002 : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_Brenner_2002 : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_Brenner_2002 : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_Brenner_2002_Print + +subroutine IPModel_Brenner_2002_read_params_xml(this, param_str) + type(IPModel_Brenner_2002), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Brenner_2002_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_Brenner_2002_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + logical shifted + integer ti, tj + + if (name == 'Brenner_2002_params') then ! new Brenner_2002 stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in Brenner_2002_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_2002_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + endif + + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_2002_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_2002_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Brenner_2002_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_Brenner_2002_module diff --git a/src/Potentials/IPModel_Brenner_Screened.F90 b/src/Potentials/IPModel_Brenner_Screened.F90 new file mode 100644 index 0000000000..b7c40db575 --- /dev/null +++ b/src/Potentials/IPModel_Brenner_Screened.F90 @@ -0,0 +1,404 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Brenner_Screened module +!X +!% Module for interfacing to Screened Brenner Potential as described in +!% +!% ``Describing bond-breaking processes by reactive potentials: +!% Importance of an environment-dependent interaction range.'' +!% Lars Pastewka, Pablo Pou, Rubén Pérez, Peter Gumbsch, Michael Moseler. +!% Phys. Rev. B (2008) vol. 78 (16) pp. 4 +!% http://dx.doi.org/10.1103/PhysRevB.78.161402 +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Brenner_Screened_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +#ifdef HAVE_MDCORE +use force_brenner2002_exp, only: force_brenner2002_exp_kernel +use db_brenner2002_exp, only: with_dihedral, db_brenner2002_init +#endif + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Brenner_Screened +type IPModel_Brenner_Screened + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + + integer :: n + type(Atoms) :: at + integer, allocatable, dimension(:) :: aptr + integer, allocatable, dimension(:) :: bptr + integer :: bptr_num + + character(len=STRING_LENGTH) :: label + +end type IPModel_Brenner_Screened + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Brenner_Screened), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Brenner_Screened_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Brenner_Screened_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Brenner_Screened_Print +end interface Print + +interface Calc + module procedure IPModel_Brenner_Screened_Calc +end interface Calc + +contains + +subroutine IPModel_Brenner_Screened_Initialise_str(this, args_str, param_str) + type(IPModel_Brenner_Screened), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + character(len=STRING_LENGTH) label + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_Screened_Initialise_str args_str')) then + call system_abort("IPModel_Brenner_Screened_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Brenner_Screened_read_params_xml(this, param_str) + +#ifdef HAVE_MDCORE + with_dihedral = 0 + call db_brenner2002_init() + this%cutoff = 4.0_dp +#else + call system_abort('IPModel_Brenner_Screened_Initialise - support for mdcore not compiled in') +#endif + +end subroutine IPModel_Brenner_Screened_Initialise_str + +subroutine IPModel_Brenner_Screened_Finalise(this) + type(IPModel_Brenner_Screened), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Brenner_Screened_Finalise + + +subroutine IPModel_Brenner_Screened_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Brenner_Screened), intent(inout):: this + type(Atoms), intent(inout) :: at !Active + buffer atoms + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer:: i,n + real(dp), dimension(:,:), allocatable :: pos_in, force_out, dr + real(dp) :: brenner_e, brenner_virial(3,3) + + real(dp), dimension(:), allocatable :: abs_dr + integer, dimension(:), allocatable :: aptr, bptr, k_typ + integer :: n_tot, neighb + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Brenner_Screened_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Brenner_Screened_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Brenner_Screened_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_Brenner_Screened_Calc: local_virial calculation requested but not supported yet.", error) + endif + + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Brenner_Screened_Calc args_str')) then + RAISE_ERROR("IPModel_Brenner_Screened_Calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_Brenner_Screened_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_Brenner_Screened_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + endif + + n_tot = 0 + do i=1,at%N + n_tot = n_tot + n_neighbours(at, i) + end do + + allocate(aptr(at%N+1),bptr(n_tot+at%n+1),dr(n_tot+at%n+1,3), abs_dr(n_tot+at%n+1), & + pos_in(at%n,3),force_out(at%n,3),k_typ(at%N)) + force_out = 0.0_dp + dr = 0.0_dp + brenner_e = 0.0_dp + aptr = 0 + bptr = 0 + + k_typ = 1 + + neighb = 1 + do i=1,at%N + pos_in(i,:) = at%pos(:,i) + + aptr(i) = neighb + do n=1,n_neighbours(at,i) + bptr(neighb) = neighbour(at,i,n, diff=dr(neighb,:),distance=abs_dr(neighb)) + dr(neighb,:) = -dr(neighb,:) ! opposite sign convention + + neighb = neighb + 1 + end do + neighb = neighb + 1 + end do + bptr(neighb) = 0 + aptr(at%N+1) = neighb + + brenner_virial = 0.0_dp +#ifdef HAVE_MDCORE + call force_brenner2002_exp_kernel(at%N,pos_in,k_typ,brenner_e,force_out, brenner_virial, & + aptr, bptr, size(bptr), dr, abs_dr) +#else + call system_abort('IPModel_Brenner_Screened - mdcore support not compiled in') +#endif + + if (present(local_e)) call system_abort('IPModel_Brenner_Screened - no support for local energies') + + if (present(e)) e = brenner_e + + if (present(f)) then + do i=1,at%N + f(:,i) = force_out(i,:) + end do + end if + + if (present(virial)) then + virial = -brenner_virial + end if + + deallocate(aptr,bptr,dr,pos_in,force_out,abs_dr) + +end subroutine IPModel_Brenner_Screened_Calc + + +subroutine IPModel_Brenner_Screened_Print(this, file) + type(IPModel_Brenner_Screened), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_Brenner_Screened : Screnned Brenner Potential", file=file) + call Print(" Phys. Rev. B (2008) vol. 78 (16) pp. 4 ", file=file) + call Print("IPModel_Brenner_Screened : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_Brenner_Screened : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_Brenner_Screened : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_Brenner_Screened_Print + +subroutine IPModel_Brenner_Screened_read_params_xml(this, param_str) + type(IPModel_Brenner_Screened), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Brenner_Screened_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_Brenner_Screened_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + logical shifted + integer ti, tj + + if (name == 'Brenner_Screened_params') then ! new Brenner_Screened stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in Brenner_Screened_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_Screened_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + endif + + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_Screened_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Brenner_Screened_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Brenner_Screened_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_Brenner_Screened_module diff --git a/src/Potentials/IPModel_CH4.F90 b/src/Potentials/IPModel_CH4.F90 new file mode 100644 index 0000000000..12d2e7fb20 --- /dev/null +++ b/src/Potentials/IPModel_CH4.F90 @@ -0,0 +1,204 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_CH4 +!X +!% CH4 module for use when implementing a new Interatomic Potential +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_CH4_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use units_module +use atoms_module +use topology_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_CH4 +type IPModel_CH4 + real(dp) :: cutoff = 0.0_dp + + character(len=STRING_LENGTH) :: label + +end type IPModel_CH4 + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_CH4), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_CH4_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_CH4_Finalise +end interface Finalise + +interface Print + module procedure IPModel_CH4_Print +end interface Print + +interface Calc + module procedure IPModel_CH4_Calc +end interface Calc + +interface + function ch4pot_func_10(r) + real(8), intent(in) :: r(10) + real(8) :: ch4pot_func_10 + endfunction ch4pot_func_10 +endinterface + +contains + +subroutine IPModel_CH4_Initialise_str(this, args_str, param_str) + type(IPModel_CH4), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_CH4_Initialise_str args_str')) then + call system_abort("IPModel_CH4_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + this%cutoff = 2.0 + +end subroutine IPModel_CH4_Initialise_str + +subroutine IPModel_CH4_Finalise(this) + type(IPModel_CH4), intent(inout) :: this + + ! Add finalisation code here + + this%label = '' + this%cutoff = 0.0_dp +end subroutine IPModel_CH4_Finalise + + +subroutine IPModel_CH4_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_CH4), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer, dimension(5) :: signature + integer, dimension(:,:), allocatable :: monomer_index + logical, dimension(:), allocatable :: is_associated + real(dp), dimension(3,4) :: pos + real(dp), dimension(4,4) :: bmat, bmati + real(dp), dimension(10) :: rten + integer :: i, j, iC, iH, n_monomers + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_CH4_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_CH4_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_CH4_Calc', error) + local_virial = 0.0_dp + endif + + signature = (/6,1,1,1,1/) + allocate(is_associated(at%N)) + + + is_associated = .false. + call find_general_monomer(at,monomer_index,signature,is_associated,this%cutoff,error=error) + + n_monomers = size(monomer_index,2) + +#ifdef HAVE_CH4 + call ch4_initialise(bmat,bmati) +#endif + + do i = 1, n_monomers + iC = monomer_index(1,i) + do j = 1, 4 + iH = monomer_index(j+1,i) + pos(:,j) = diff_min_image(at,iC,iH) / BOHR + enddo +#ifdef HAVE_CH4 + call bond_cart2radau_int10(pos,bmati,rten) + if(present(e)) e = e + ch4pot_func_10(rten) * INVERSE_CM +#endif + enddo + + if(allocated(monomer_index)) deallocate(monomer_index) + if(allocated(is_associated)) deallocate(is_associated) + +end subroutine IPModel_CH4_Calc + + +subroutine IPModel_CH4_Print(this, file) + type(IPModel_CH4), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_CH4 : CH4 Potential", file=file) + call Print("IPModel_CH4 : cutoff = " // this%cutoff, file=file) + +end subroutine IPModel_CH4_Print + +end module IPModel_CH4_module diff --git a/src/Potentials/IPModel_ConfiningMonomer.F90 b/src/Potentials/IPModel_ConfiningMonomer.F90 new file mode 100644 index 0000000000..b017bf056d --- /dev/null +++ b/src/Potentials/IPModel_ConfiningMonomer.F90 @@ -0,0 +1,340 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2017. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_ConfiningMonomer +!X +!% Potential to keep monomers together, currently hardcoded for methane +!% (but should be easy to modify for any single-centre molecule) +!% +!% Simple harmonic on C-H bonds and H-C-H angle cosines +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_ConfiningMonomer_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_VERBOSE, PRINT_NERD, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use topology_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_ConfiningMonomer +type IPModel_ConfiningMonomer + real(dp) :: cutoff = 0.0_dp + real(dp) :: kbond = 0.0_dp + real(dp) :: kangle = 0.0_dp + real(dp) :: bond_r0 = 0.0_dp + real(dp) :: angle_cos0 = 0.0_dp +end type IPModel_ConfiningMonomer + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_ConfiningMonomer), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_ConfiningMonomer_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_ConfiningMonomer_Finalise +end interface Finalise + +interface Print + module procedure IPModel_ConfiningMonomer_Print +end interface Print + +interface Calc + module procedure IPModel_ConfiningMonomer_Calc +end interface Calc + +contains + +subroutine IPModel_ConfiningMonomer_Initialise_str(this, args_str, param_str, error) + type(IPModel_ConfiningMonomer), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out):: error + + + INIT_ERROR(error) + call Finalise(this) + + call initialise(params) + call param_register(params, 'kbond', '0.0', this%kbond, help_string='Strength of quadratic restraint on C-H bonds. Potential is kconf*(r-r0)^2') + call param_register(params, 'kangle', '0.0', this%kangle, help_string='Strength of quadratic restraint on H-C-H cosines. Potential is kconf*(cos(theta)-cos(theta0))^2') + call param_register(params, 'bond_r0', '0.0', this%bond_r0, help_string='Equilibrium bond length for C-H bonds.') + call param_register(params, 'angle_cos0', '0.0', this%angle_cos0, help_string='Cosine of equilibrium bond angle for H-C-H triplets.') + call param_register(params, 'cutoff', '0.0', this%cutoff, help_string='Cutoff for finding methane monomers') + if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_ConfiningMonomer_Initialise args_str')) then + RAISE_ERROR("IPModel_ConfiningMonomer_Init failed to parse args_str='"//trim(args_str)//"'", error) + end if + call finalise(params) + +end subroutine IPModel_ConfiningMonomer_Initialise_str + +subroutine IPModel_ConfiningMonomer_Finalise(this) + type(IPModel_ConfiningMonomer), intent(inout) :: this + + ! Add finalisation code here + +end subroutine IPModel_ConfiningMonomer_Finalise + + +subroutine IPModel_ConfiningMonomer_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_ConfiningMonomer), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + ! Add calc() code here + + ! Confining potential for methanes - first find general monomers, then place + ! harmonic restraints on bonds and angles. + + integer, dimension(:,:), allocatable :: monomer_index + logical, dimension(:), allocatable :: is_associated + real(dp) :: energy, force(3,at%N) + + type(Dictionary) :: params + character(STRING_LENGTH) :: atom_mask_name, pers_idces_name + logical :: has_atom_mask_name, has_pers_idces_name + logical, dimension(:), pointer :: atom_mask_pointer + integer, dimension(:), pointer :: pers_idces_pointer + logical :: called_from_lammps + + integer :: mon_i, i_atomic, atom_i, rank_j, atom_j, rank_k, atom_k + real(dp) :: e_pair, d_epair_dr, rij(3), rik(3), rij_mag, rik_mag, rij_norm(3), rik_norm(3) + real(dp) :: e_trip, d_etrip_dcos, cos_ijk, fij(3), fik(3) + real(dp) :: virial_i(3,3), virial_j(3,3), virial_k(3,3) + + + INIT_ERROR(error) + + if(present(args_str)) then + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For monomers where this property is true the Potential is " // & + "calculated.") + + call param_register(params, 'lammps', 'F', called_from_lammps, help_string="Should be true if this potential is called from LAMMPS") + + call param_register(params, 'pers_idces_name', 'NONE', pers_idces_name, has_value_target=has_pers_idces_name, & + help_string="Name of an integer property in the atoms object containing the original LAMMPS atom ids (only needed if & + called from lammps)") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='general_dimer_calc args_str')) then + RAISE_ERROR("IPModel_ConfiningMonomer_Calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name), atom_mask_pointer)) then + RAISE_ERROR("IPModel_ConfiningMonomer_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + + if( called_from_lammps ) then + if (.not. has_pers_idces_name) then + RAISE_ERROR("IPModel_ConfiningMonomer_Calc needs persistent indices if working with lammps.", error) + endif + if (.not. assign_pointer(at, trim(pers_idces_name), pers_idces_pointer)) then + RAISE_ERROR("IPModel_ConfiningMonomer_Calc did not find "//trim(pers_idces_name)//" property in the atoms object.", error) + endif + endif + else + called_from_lammps = .false. + atom_mask_pointer => null() + endif + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_ConfiningMonomer_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_ConfiningMonomer_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_ConfiningMonomer_Calc', error) + local_virial = 0.0_dp + endif + + allocate(is_associated(at%N)) + is_associated = .false. + if (called_from_lammps) then + call shuffle(at, pers_idces_pointer, error) + endif + call find_general_monomer(at, monomer_index, (/6, 1, 1, 1, 1/), is_associated, this%cutoff, general_ordercheck=.false., error=error) + + call print("Found " // size(monomer_index, 2) // " monomers", PRINT_VERBOSE) + if(.not. all(is_associated)) then + call print("WARNING: IP ConfiningMonomer: not all atoms assigned to a methane monomer. If you have partial monomers this is OK.", PRINT_VERBOSE) + end if + + ! First, loop over monomers. These are also the centres of angle triplets. + do mon_i = 1, size(monomer_index, 2) + ! Copied from IPModel_SW.f95 -- let's hope this works. + if (present(mpi)) then + if (mpi%active) then + if (mod(mon_i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + atom_i = monomer_index(1, mon_i) + ! Only evaluate the monomer if the central C atom is local - should check + ! how lammps accounts for forces on non-local atoms + if (associated(atom_mask_pointer)) then + if (.not. atom_mask_pointer(atom_i)) cycle + end if + + call print("Atom " // atom_i // " has " // n_neighbours(at, atom_i, max_dist=this%cutoff) // " neighbours", PRINT_VERBOSE) + do rank_j = 1, n_neighbours(at, atom_i) + atom_j = neighbour(at, atom_i, rank_j, distance=rij_mag, diff=rij, cosines=rij_norm, max_dist=this%cutoff) + if (atom_j .eq. 0) cycle ! Neighbour outside of cutoff + if (rij_mag .feq. 0.0_dp) cycle ! Somehow got self + ! This really shouldn't happen in any normal cases, but account for it anyways + if (.not. (any(monomer_index(2:5, mon_i) .eq. atom_j))) then + call print("WARNING: Stray neighbour " // atom_j // ", rank " // rank_j // ", of atom " // atom_i // " detected!", PRINT_VERBOSE) + cycle + end if + + ! Pairwise forces and energies + e_pair = this%kbond * (rij_mag - this%bond_r0)**2 + d_epair_dr = 2.0_dp * this%kbond * (rij_mag - this%bond_r0) + + if (present(e)) e = e + e_pair + if (present(local_e)) then + ! Eh, let's just concentrate all the 'local' quantities on the monomer centres. + local_e(atom_i) = local_e(atom_i) + e_pair + end if + if (present(f)) then + f(:, atom_j) = f(:, atom_j) - 1.0_dp * d_epair_dr * rij_norm + f(:, atom_i) = f(:, atom_i) + 1.0_dp * d_epair_dr * rij_norm + end if + if (present(virial) .or. present(local_virial)) then + virial_i = -1.0 * d_epair_dr * rij_mag * (rij_norm .outer. rij_norm) + end if + if (present(virial)) virial = virial + virial_i + if (present(local_virial)) then + local_virial(:, atom_i) = local_virial(:, atom_i) + reshape(virial_i, (/9/)) + end if + + do rank_k = 1, n_neighbours(at, atom_i) + atom_k = neighbour(at, atom_i, rank_k, distance=rik_mag, diff=rik, cosines=rik_norm, max_dist=this%cutoff) + if (atom_k .eq. 0) cycle + ! Again, shouldn't happen, but better to be safe + if (.not. (any(monomer_index(2:5, mon_i) .eq. atom_k))) cycle + if (atom_k <= atom_j) cycle + + cos_ijk = sum(rij_norm*rik_norm) + e_trip = this%kangle * (cos_ijk - this%angle_cos0)**2 + d_etrip_dcos = 2.0_dp * this%kangle * (cos_ijk - this%angle_cos0) + if (present(e)) e = e + e_trip + if (present(local_e)) then + ! Hm, the triplet local quantities can be assigned to the outer atoms + local_e(atom_j) = local_e(atom_j) + 0.5_dp * e_trip + local_e(atom_k) = local_e(atom_k) + 0.5_dp * e_trip + end if + if (present(f) .or. present(virial) .or. present(local_virial)) then + ! Apparently these need to have the opposite sign from what I + ! originally thought - isn't it f_i = -grad_i(e) though? + fij = 1.0_dp * d_etrip_dcos * (rik_norm - rij_norm*cos_ijk) / rij_mag + fik = 1.0_dp * d_etrip_dcos * (rij_norm - rik_norm*cos_ijk) / rik_mag + end if + if (present(f)) then + f(:, atom_i) = f(:, atom_i) + fij + fik + f(:, atom_j) = f(:, atom_j) - fij + f(:, atom_k) = f(:, atom_k) - fik + end if + if (present(virial) .or. present(local_virial)) then + ! TODO check these signs + virial_j = -1.0_dp * d_etrip_dcos * ((rik_norm .outer. rij_norm) - (rij_norm .outer. rij_norm)*cos_ijk) + virial_k = -1.0_dp * d_etrip_dcos * ((rij_norm .outer. rik_norm) - (rik_norm .outer. rik_norm)*cos_ijk) + end if + if (present(virial)) virial = virial + virial_j + virial_k + if (present(local_virial)) then + local_virial(:, atom_i) = local_virial(:, atom_i) + reshape(virial_j, (/9/)) + reshape(virial_k, (/9/)) + end if + end do + end do + end do + + ! Copied from IPModel_SW.xml + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) call sum_in_place(mpi, f) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(local_virial)) call sum_in_place(mpi, local_virial) + endif + + deallocate(monomer_index) + deallocate(is_associated) + +end subroutine IPModel_ConfiningMonomer_Calc + + +subroutine IPModel_ConfiningMonomer_Print(this, file) + type(IPModel_ConfiningMonomer), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_ConfiningMonomer : ConfiningMonomer Potential", file=file) + call Print("IPModel_ConfiningMonomer : cutoff = " // this%cutoff, file=file) + call Print("IPModel_ConfiningMonomer : kbond = " // this%kbond, file=file) + call Print("IPModel_ConfiningMonomer : kangle = " // this%kangle, file=file) + call Print("IPModel_ConfiningMonomer : bond_r0 = " // this%bond_r0, file=file) + call Print("IPModel_ConfiningMonomer : angle_cos0 = " // this%angle_cos0, file=file) + +end subroutine IPModel_ConfiningMonomer_Print + + +end module IPModel_ConfiningMonomer_module diff --git a/src/Potentials/IPModel_Coulomb.F90 b/src/Potentials/IPModel_Coulomb.F90 new file mode 100644 index 0000000000..c3509a2cff --- /dev/null +++ b/src/Potentials/IPModel_Coulomb.F90 @@ -0,0 +1,563 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X IPModel_Coulomb +!X +!% Coulomb module. Calculates electrostatic interactions between charged +!% species. Supported methods: +!% Direct: the $1/r$ potential +!% Yukawa: Yukawa-screened electrostatic interactions +!% Ewald: Ewald summation technique +!% DSF: Damped Shifted Force Coulomb potential. The interaction is damped by the +!% error function and the potential is force-shifted so both the potential and its +!% derivative goes smoothly to zero at the cutoff. Reference: JCP, 124, 234104 (2006) +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module IPModel_Coulomb_module + +use error_module +use system_module, only : dp, inoutput, print, lower_case, verbosity_push_decrement, verbosity_pop, operator(//), split_string, string_to_int +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use units_module + +use mpi_context_module +use QUIP_Common_module + +use Yukawa_module +use IPEwald_module +use Ewald_module + + +implicit none +private + +include 'IPModel_interface.h' + +integer, parameter :: IPCoulomb_Method_Direct = 1 +integer, parameter :: IPCoulomb_Method_Yukawa = 2 +integer, parameter :: IPCoulomb_Method_Ewald = 3 +integer, parameter :: IPCoulomb_Method_DSF = 4 +integer, parameter :: IPCoulomb_Method_Ewald_NB = 5 + +public :: IPModel_Coulomb +type IPModel_Coulomb + + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + real(dp), dimension(:), allocatable :: charge + integer :: method = 0 + integer :: damping = 0 + integer :: screening = 0 + + real(dp) :: cutoff = 0.0_dp + + real(dp) :: yukawa_alpha = 0.0_dp + real(dp) :: yukawa_smooth_length = 0.0_dp + real(dp) :: yukawa_grid_size = 0.0_dp + logical :: yukawa_pseudise = .false. + + real(dp) :: ewald_error + real(dp) :: smooth_coulomb_cutoff + + real(dp) :: dsf_alpha = 0.0_dp + + character(len=STRING_LENGTH) :: label + + +endtype IPModel_Coulomb + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Coulomb), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Coulomb_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Coulomb_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Coulomb_Print +end interface Print + +interface Calc + module procedure IPModel_Coulomb_Calc +end interface Calc + +contains + +subroutine IPModel_Coulomb_Initialise_str(this, args_str, param_str) + type(IPModel_Coulomb), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + character(len=STRING_LENGTH) :: method_str + logical :: has_method + + call Finalise(this) + call initialise(params) + this%label='' + method_str='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'method', '', method_str, help_string="If present, method for Coulomb calculation. Will be overridden & + by xml parameters if present", has_value_target=has_method) + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Coulomb_Initialise_str args_str')) then + call system_abort("IPModel_Coulomb_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Coulomb_read_params_xml(this, param_str) + + if(this%method == 0) then + if(has_method) then + this%method = IPModel_Coulomb_get_method(method_str) + else + call system_abort("IPModel_Coulomb_Initialise_str: no method specified either in XML or arguments") + endif + endif + + + ! Add initialisation code here + +end subroutine IPModel_Coulomb_Initialise_str + +function IPModel_Coulomb_get_method(this) + character(len=*), intent(in) :: this + integer :: IPModel_Coulomb_get_method + + select case(lower_case(trim(this))) + case("direct") + IPModel_Coulomb_get_method = IPCoulomb_Method_Direct + case("yukawa") + IPModel_Coulomb_get_method = IPCoulomb_Method_Yukawa + case("ewald") + IPModel_Coulomb_get_method = IPCoulomb_Method_Ewald + case("ewald_nb") + IPModel_Coulomb_get_method = IPCoulomb_Method_Ewald_NB + case("dsf") + IPModel_Coulomb_get_method = IPCoulomb_Method_DSF + case default + call system_abort ("IPModel_Coulomb_get_method: method "//trim(this)//" unknown") + end select + +endfunction IPModel_Coulomb_get_method + +subroutine IPModel_Coulomb_Finalise(this) + type(IPModel_Coulomb), intent(inout) :: this + + ! Add finalisation code here + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%charge)) deallocate(this%charge) + + this%n_types = 0 + this%label = '' + this%cutoff = 0.0_dp + this%method = 0 + +end subroutine IPModel_Coulomb_Finalise + +recursive subroutine IPModel_Coulomb_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Coulomb), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + real(dp), dimension(:), allocatable, target :: my_charge + real(dp), dimension(:), pointer :: charge + real(dp), dimension(:,:), allocatable :: dummy_force + real(dp) :: r_scale, E_scale, e_pre_calc + logical :: do_rescale_r, do_rescale_E, do_pairwise_by_Z,do_e, do_f + + real(dp), pointer :: local_e_by_Z(:,:), local_e_contrib(:) + integer, allocatable :: Z_s(:), Z_u(:) + integer :: n_uniq_Zs + + + real(dp), allocatable :: gamma_mat(:,:) + + integer :: i, i_Z + + character(len=STRING_LENGTH) :: charge_property_name, atom_mask_name, source_mask_name + + INIT_ERROR(error) + do_f=present(f) + do_e=present(e) + + if (do_e) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Coulomb_Calc', error) + local_e = 0.0_dp + endif + if (do_f) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Coulomb_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Coulomb_Calc', error) + local_virial = 0.0_dp + endif + + if (present(args_str)) then + call initialise(params) + call param_register(params, 'charge_property_name', 'charge', charge_property_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'atom_mask_name', '', atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'source_mask_name', '', source_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.") + call param_register(params, 'pairwise_by_Z', 'F',do_pairwise_by_Z, help_string="If true, calculate pairwise contributions to local_e broken down by Z") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Coulomb_Calc args_str')) then + RAISE_ERROR("IPModel_Coulomb_Calc failed to parse args_str="//trim(args_str), error) + endif + call finalise(params) + if (do_rescale_r ) then + RAISE_ERROR("IPModel_Coulomb_Calc: rescaling of potential with r_scale not yet implemented!", error) + end if + else + charge_property_name = 'charge' + endif + + if(has_property(at,charge_property_name)) then + if(.not. assign_pointer(at, charge_property_name, charge)) then + RAISE_ERROR('IPModel_Coulomb_Calc failed to assign pointer to '//trim(charge_property_name)//' property', error) + endif + else + allocate(my_charge(at%N)) + charge => my_charge + charge = 0.0_dp + do i = 1, at%N + charge(i) = this%charge(this%type_of_atomic_num(at%Z(i))) + enddo + endif + + + selectcase(this%method) + case(IPCoulomb_Method_Direct) + call Direct_Coulomb_calc(at, charge, e=e, f=f, virial=virial, error = error) + case(IPCoulomb_Method_Yukawa) + call yukawa_charges(at, charge, this%cutoff, this%yukawa_alpha, this%yukawa_smooth_length, & + e, local_e, f, virial, & + mpi=mpi, atom_mask_name=atom_mask_name, source_mask_name=source_mask_name, type_of_atomic_num=this%type_of_atomic_num, & + pseudise=this%yukawa_pseudise, grid_size=this%yukawa_grid_size, error=error) + case(IPCoulomb_Method_Ewald) + call Ewald_calc(at, charge, e, f, virial, ewald_error=this%ewald_error, use_ewald_cutoff=.false., smooth_coulomb_cutoff=this%smooth_coulomb_cutoff, error=error) + case(IPCoulomb_Method_Ewald_NB) + if (present(f) .or. present(virial) .or. present(local_virial)) then + RAISE_ERROR("IPModel_Coulomb_Calc: method ewald_nb doesn't have F or V implemented yet", error) + endif + allocate(gamma_mat(at%n,at%n)) + gamma_mat = 0.0_dp + call add_madelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, gamma_mat, redo_lattice=.true.) +call print("gamma_mat") +call print(gamma_mat) + if (present(e)) e = 0.5_dp*sum(charge*matmul(gamma_mat, charge)) + if (present(local_e)) local_e = 0.5_dp*charge*matmul(gamma_mat, charge) + if (do_pairwise_by_Z) then + allocate(Z_s(at%n)) + Z_s = at%Z + call sort_array(Z_s) + call uniq(Z_s, Z_u) + deallocate(Z_s) + +call print("local_pot "//matmul(gamma_mat, charge)) + + n_uniq_Zs = size(Z_u) + if (has_property(at, "local_e_pairwise_by_Z")) call remove_property(at, "local_e_pairwise_by_Z") + call add_property(at, "local_e_pairwise_by_Z", 0.0_dp, n_cols=n_uniq_Zs, ptr2 = local_e_by_Z) + allocate(local_e_contrib(at%N)) + do i=1, at%N + local_e_contrib = 0.5_dp * gamma_mat(i,:) * charge(:) * charge(i) +call print("local_e_contrib "//i //" "//local_e_contrib) + do i_Z = 1, n_uniq_Zs + local_e_by_Z(i_Z,i) = sum(local_e_contrib, mask=(at%Z == Z_u(i_Z))) + end do + end do + deallocate(local_e_contrib) + + endif + deallocate(gamma_mat) + case(IPCoulomb_Method_DSF) + call DSF_Coulomb_calc(at, charge, this%DSF_alpha, e=e, local_e=local_e, f=f, virial=virial, cutoff=this%cutoff, error = error) + case default + RAISE_ERROR("IPModel_Coulomb_Calc: unknown method", error) + endselect + + + charge => null() + if(allocated(my_charge)) deallocate(my_charge) + + if (do_rescale_E) then + if (present(e)) e = e*E_scale + if (present(local_e)) local_e = local_e*E_scale + if (present(f)) f = f*E_scale + if (present(virial)) virial=virial*E_scale + if (present(local_virial)) local_virial=local_virial*E_scale + end if + +end subroutine IPModel_Coulomb_Calc + + +subroutine IPModel_Coulomb_Print(this, file) + type(IPModel_Coulomb), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti , tj + + call Print("IPModel_Coulomb : Coulomb Potential", file=file) + select case(this%method) + case(IPCoulomb_Method_Direct) + call Print("IPModel_Coulomb method: Direct") + case(IPCoulomb_Method_Yukawa) + call Print("IPModel_Coulomb method: Yukawa") + case(IPCoulomb_Method_Ewald) + call Print("IPModel_Coulomb method: Ewald") + case(IPCoulomb_Method_Ewald_NB) + call Print("IPModel_Coulomb method: Ewald_NB") + case(IPCoulomb_Method_DSF) + call Print("IPModel_Coulomb method: Damped Shifted Force Coulomb") + case default + call system_abort ("IPModel_Coulomb: method identifier "//this%method//" unknown") + endselect + + call Print("IPModel_Coulomb : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_Coulomb : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_Coulomb : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_Coulomb_Print + +subroutine IPModel_Coulomb_read_params_xml(this, param_str) + type(IPModel_Coulomb), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0 ) then + call system_abort("IPModel_Coulomb_read_params_xml parsed file, but n_types = 0 ") + endif + +end subroutine IPModel_Coulomb_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + + character(len=STRING_LENGTH) :: value, signature_string, pos_type_str + character(len=STRING_LENGTH), dimension(99) :: signature_fields + + logical :: energy_shift, linear_force_shift + integer :: ti, tj, i ,n_atoms + real(dp) :: alpha_au + + if (name == 'Coulomb_params') then ! new Coulomb stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (trim(value) == trim(parse_ip%label)) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'method', value, status) + if (status == 0) then + parse_ip%method = IPModel_Coulomb_get_method(value) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in Coulomb_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + allocate(parse_ip%charge(parse_ip%n_types)) + parse_ip%charge = 0.0_dp + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_Coulomb_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + + + call QUIP_FoX_get_value(attributes, "yukawa_alpha", value, status) + if (status /= 0) then + if( parse_ip%method == IPCoulomb_Method_Yukawa ) call system_abort("IPModel_Coulomb_read_params_xml: Yukawa method requested but no yukawa_alpha parameter found.") + else + read (value, *) parse_ip%yukawa_alpha + endif + + call QUIP_FoX_get_value(attributes, "yukawa_smooth_length", value, status) + if (status == 0) then + read (value, *) parse_ip%yukawa_smooth_length + else + parse_ip%yukawa_smooth_length = 0.0_dp + endif + + call QUIP_FoX_get_value(attributes, "yukawa_pseudise", value, status) + if (status == 0) then + read (value, *) parse_ip%yukawa_pseudise + else + parse_ip%yukawa_pseudise = .false. + endif + + call QUIP_FoX_get_value(attributes, "yukawa_grid_size", value, status) + if (status == 0) then + read (value, *) parse_ip%yukawa_grid_size + else + parse_ip%yukawa_grid_size = 0.0_dp + endif + + call QUIP_FoX_get_value(attributes, "ewald_error", value, status) + if (status == 0) then + read (value, *) parse_ip%ewald_error + else + parse_ip%ewald_error = 1.0e-6_dp + endif + + call QUIP_FoX_get_value(attributes, "smooth_coulomb_cutoff", value, status) + if (status == 0) then + read (value, *) parse_ip%smooth_coulomb_cutoff + else + parse_ip%smooth_coulomb_cutoff = 0.0_dp + endif + + call QUIP_FoX_get_value(attributes, "dsf_alpha", value, status) + if (status /= 0) then + if( parse_ip%method == IPCoulomb_Method_DSF ) call system_abort("IPModel_Coulomb_read_params_xml: Damped Shifted Force method requested but no dsf_alpha parameter found.") + else + read (value, *) parse_ip%dsf_alpha + endif + + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Coulomb_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Coulomb_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + call QUIP_FoX_get_value(attributes, "charge", value, status) + if (status /= 0) call system_abort ("IPModel_Coulomb_read_params_xml cannot find charge") + read (value, *) parse_ip%charge(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + endif + + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Coulomb_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_Coulomb_module diff --git a/src/Potentials/IPModel_Custom.F90 b/src/Potentials/IPModel_Custom.F90 new file mode 100644 index 0000000000..88ce669335 --- /dev/null +++ b/src/Potentials/IPModel_Custom.F90 @@ -0,0 +1,192 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Custom +!X +!% Customised interatomic potential: +!% +!% Energy and Force routines are hardwired +!% Cutoff is hardwired +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Custom_module + +use error_module +use system_module, only : dp, inoutput, print, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Custom +type IPModel_Custom + real(dp) :: cutoff = 0.0_dp + real(dp) :: kconf = 0.0_dp +end type IPModel_Custom + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Custom), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Custom_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Custom_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Custom_Print +end interface Print + +interface Calc + module procedure IPModel_Custom_Calc +end interface Calc + +contains + +subroutine IPModel_Custom_Initialise_str(this, args_str, param_str, error) + type(IPModel_Custom), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out):: error + + + INIT_ERROR(error) + call Finalise(this) + + call initialise(params) + call param_register(params, 'kconf', '0.0', this%kconf, help_string='strength of quadratic confinement potential on O atoms. potential is kconf*(rO)^2') + if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_Custom_Initialise args_str')) then + RAISE_ERROR("IPModel_Custom_Init failed to parse args_str='"//trim(args_str)//"'", error) + end if + call finalise(params) + +end subroutine IPModel_Custom_Initialise_str + +subroutine IPModel_Custom_Finalise(this) + type(IPModel_Custom), intent(inout) :: this + + ! Add finalisation code here + +end subroutine IPModel_Custom_Finalise + + +subroutine IPModel_Custom_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Custom), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + ! Add calc() code here + + + real(dp) :: energy, force(3,at%N) + real(dp) :: rO1, rO2, drO1(3), drO2(3) + + INIT_ERROR(error) + + ! Harmonic confining potential on Os + + rO1 = distance_min_image(at, 1, (/0.0_dp, 0.0_dp, 0.0_dp/)) + rO2 = distance_min_image(at, 4, (/0.0_dp, 0.0_dp, 0.0_dp/)) + + + energy = this%kConf*rO1**2 + this%kConf*rO2**2 + + !Forces + + force = 0.0_dp + + if(rO1 .feq. 0.0_dp) then + drO1 = 0.0_dp + else + drO1 = diff_min_image(at, 1, (/0.0_dp, 0.0_dp, 0.0_dp/))/rO1 + end if + + if(rO2 .feq. 0.0_dp) then + drO2 = 0.0_dp + else + drO2 = diff_min_image(at, 4, (/0.0_dp, 0.0_dp, 0.0_dp/))/rO2 + end if + + force(:,1) = 2.0_dp*this%kConf*rO1*drO1 + force(:,4) = 2.0_dp*this%kConf*rO2*drO2 + + + if (present(e)) e = energy + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Custom_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Custom_Calc', error) + f = force + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Custom_Calc', error) + local_virial = 0.0_dp + endif + + +end subroutine IPModel_Custom_Calc + + +subroutine IPModel_Custom_Print(this, file) + type(IPModel_Custom), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_Custom : Custom Potential", file=file) + call Print("IPModel_Custom : cutoff = " // this%cutoff, file=file) + call Print("IPModel_Custom : kconf = " // this%kconf, file=file) + +end subroutine IPModel_Custom_Print + + +end module IPModel_Custom_module diff --git a/src/Potentials/IPModel_DispTS.F90 b/src/Potentials/IPModel_DispTS.F90 new file mode 100644 index 0000000000..9684b7155e --- /dev/null +++ b/src/Potentials/IPModel_DispTS.F90 @@ -0,0 +1,647 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2017. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_DispTS +!X +!% Pairwise dispersion correction from Tkatchenko and Scheffler, +!% PRL 102(7) 073005 (2009). +!% +!% Free-atom reference data must be supplied in the XML file; Hirshfeld volumes +!% must be supplied in the Atoms object. +!% +!% Free-atom reference data is available e.g. from Chu and Dalgarno, +!% JCP 121, 4083 (2004) (used in original implementation) or from +!% Gould and BuÄko, JCTC 12(8), 3603 (2016) (better coverage) +!% +!% Tail corrections for the energy and virial are available for +!% this potential. Doing them properly, however, requires +!% an integral over the smooth cutoff function; this involves the +!% the special Ci and Si functions (sine and cosine integrals). +!% Those are not yet implemented here, so instead this potential +!% asks for a precomputed constant that depends only on the cutoff +!% and transition width: +!% \[ +!% I = -\frac{2}{3} \pi (r_{in}^{-3} - 3 \int_{r_{in}}^{r_{out}} r^{-4} S(r) dr) +!% \] +!% where r_{out} is this potential's cutoff, r_{in} is the cutoff +!% minus the cutoff_transition_width, and S(r) is the switching +!% function that goes smoothly from 1 at r_{in} to 0 at r_{out}. +!% In this potential, S(r) is the first half of a cosine (shifted +!% and scaled). +!% +!% To use tail corrections, compute this integral using any +!% method you like and supply it ($I$) as 'tail_correction_const' +!% in the parameter file or on the command line (or use an existing +!% parameter file that already has it). Alternatively, supply a +!% factor $\lambda$ (called 'tail_corr_factor') between 0 and 1 where: +!% \[ +!% \lambda = \frac{-3 \int_{r_{in}}^{r_{out}} r^{-4} S(r) dr}{r_{out}^{-3} - r_{in}^{-3}} +!% \] +!% which may be more intuitive as the fraction of "missing" energy +!% within the transition region. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_DispTS_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_NERD, verbosity_push_decrement, verbosity_pop, operator(//) +use units_module, only : GPA_TO_EV_A3, PI +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_DispTS +type IPModel_DispTS + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + real(dp), allocatable :: c6_free(:), alpha_free(:), r_vdW_free(:) + logical :: only_inter_resid = .false. + logical :: do_tail_corrections = .true. + + real(dp) :: cutoff = 0.0_dp + real(dp) :: cutoff_transition_width = 0.5_dp + + real(dp) :: tail_corr_smooth_factor = 0.0_dp + real(dp) :: tail_correction_const = 0.0_dp + + ! Constants for now... + real(dp) :: damp_steepness = 20.0_dp + real(dp) :: damp_scale = 0.94 !PBE + + character(len=STRING_LENGTH) :: label + +end type IPModel_DispTS + + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_DispTS), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_DispTS_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_DispTS_Finalise +end interface Finalise + +interface Print + module procedure IPModel_DispTS_Print +end interface Print + +interface Calc + module procedure IPModel_DispTS_Calc +end interface Calc + + +contains + + +subroutine IPModel_DispTS_Initialise_str(this, args_str, param_str) + type(IPModel_DispTS), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + logical :: use_smooth_factor + + call Finalise(this) + + call initialise(params) + this%label='' + use_smooth_factor = .false. + call param_register(params, 'label', '', this%label, help_string="Label to identify the potential") + call param_register(params, 'only_inter_resid', 'F', this%only_inter_resid, & + help_string="If True, only calculate interactions between atoms with different ResIDs (requires 'resid' property to be present)") + !call param_register(params, 'do_tail_corrections', this%do_tail_corrections, & + ! help_string="If True, apply long-range corrections to the energy and virial") + call param_register(params, 'tail_correction_const', '0.0', this%tail_correction_const, has_value_target=this%do_tail_corrections, & + help_string="Constant used to calculate tail corrections. Both the energy and virial corrections are equal to this value divided by the cell volume & + multiplied by the sum of all pairwise C6 coefficients. Units: Ang^-3.") + call param_register(params, 'tail_corr_factor', '0.0', this%tail_corr_smooth_factor, has_value_target=use_smooth_factor, & + help_string="Proportion of missing energy in the transition region; used to calculate tail corrections instead of 'tail_correction_const'.") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_DispTS_Initialise_str args_str')) then + call system_abort("IPModel_DispTS_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_DispTS_read_params_xml(this, param_str) + if (this%tail_corr_smooth_factor .fne. 0.0_dp) then + use_smooth_factor = .true. + endif + + if (use_smooth_factor) then + if (this%do_tail_corrections) then + call system_abort("IPModel_DispTS_Initialise_str: Supply only one of 'tail_corr_factor' or 'tail_correction_const'") + else + this%tail_correction_const = -2.0 * PI / 3.0 * & + ((1.0_dp - this%tail_corr_smooth_factor)/(this%cutoff - this%cutoff_transition_width)**3 + & + this%tail_corr_smooth_factor/this%cutoff**3) + this%do_tail_corrections = .true. + endif + endif + +end subroutine IPModel_DispTS_Initialise_str + + +subroutine IPModel_DispTS_Finalise(this) + type(IPModel_DispTS), intent(inout) :: this + + ! Add finalisation code here + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%c6_free)) deallocate(this%c6_free) + if (allocated(this%alpha_free)) deallocate(this%alpha_free) + if (allocated(this%r_vdW_free)) deallocate(this%r_vdW_free) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_DispTS_Finalise + + +subroutine IPModel_DispTS_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_DispTS), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + + character(len=*), optional :: args_str + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer, pointer, dimension(:) :: resid + real(dp), pointer, dimension(:) :: my_hirshfeld_volume + character(STRING_LENGTH) :: hirshfeld_vol_name + + integer :: i, j, d, ji, ti, tj + real(dp) :: dr(3), dr_mag, de, de_dr, vi, vj + real(dp) :: damp, dfdamp + real(dp) :: tail_correction, c6_sum + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_DispTS_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_DispTS_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_DispTS_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_DispTS_Calc: local_virial calculation requested but not supported yet.", error) + endif + + tail_correction = 0.0_dp + c6_sum = 0.0_dp + + if (this%only_inter_resid) then + if (.not. assign_pointer(at, "resid", resid)) then + RAISE_ERROR("IPModel_DispTS_Calc calculation with only_inter_resid=T requires resid field", error) + endif + end if + + if (present(args_str)) then + if (len_trim(args_str) > 0) then + call initialise(params) + call param_register(params, 'hirshfeld_vol_name', 'hirshfeld_rel_volume', hirshfeld_vol_name, & + help_string='Name of the Atoms property containing relative Hirshfeld volumes $v/v_{free}$') + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0', r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0', E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_MBD_Calc args_str')) then + RAISE_ERROR("IPModel_DispTS_Calc failed to parse args_str '"//trim(args_str)//"'", error) + endif + call finalise(params) + call assign_property_pointer(at, trim(hirshfeld_vol_name), my_hirshfeld_volume, error) + PASS_ERROR_WITH_INFO("IPModel_DispTS_Calc could not find '"//trim(hirshfeld_vol_name)//"' property in the Atoms object", error) + endif + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_LJ_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_LJ_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + else + call assign_property_pointer(at, 'hirshfeld_rel_volume', my_hirshfeld_volume, error) + PASS_ERROR_WITH_INFO("IPModel_DispTS_Calc could not find 'hirshfeld_rel_volume' property in the Atoms object", error) + endif + + ! Adapted from IPModel_LJ.f95 as a general pair potential + do i = 1, at%N + + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + vi = my_hirshfeld_volume(i) + + if (this%do_tail_corrections) then + do j = 1, at%n + if (i == j) cycle + if (this%only_inter_resid) then + if (resid(i) == resid(j)) cycle + endif + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + vj = my_hirshfeld_volume(j) + c6_sum = c6_sum + IPModel_DispTS_pair_c6(this, ti, tj, vi, vj) + enddo + endif + + do ji = 1, n_neighbours(at, i) + j = neighbour(at, i, ji, dr_mag, cosines = dr) + + if (dr_mag .feq. 0.0_dp) cycle + if ((i < j)) cycle + + if (this%only_inter_resid) then + if (resid(i) == resid(j)) cycle + endif + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + vj = my_hirshfeld_volume(j) + + damp = 0.0_dp + dfdamp = 0.0_dp + if (present(f) .or. present(virial)) then + call IPModel_DispTS_fdamp(this, ti, tj, vi, vj, dr_mag, damp, dfdamp) + else if (present(e) .or. present(local_e)) then + call IPModel_DispTS_fdamp(this, ti, tj, vi, vj, dr_mag, damp) + endif + + if (present(e) .or. present(local_e)) then + de = IPModel_DispTS_pairenergy(this, ti, tj, vi, vj, dr_mag, damp) + + if (present(local_e)) then + local_e(i) = local_e(i) + 0.5_dp*de + if(i/=j) local_e(j) = local_e(j) + 0.5_dp*de + endif + if (present(e)) then + if(i==j) then + e = e + 0.5_dp*de + else + e = e + de + endif + endif + endif + if (present(f) .or. present(virial)) then + de_dr = IPModel_DispTS_pairenergy_deriv(this, ti, tj, vi, vj, dr_mag, damp, dfdamp) + if (present(f)) then + f(:,i) = f(:,i) + de_dr*dr + if(i/=j) f(:,j) = f(:,j) - de_dr*dr + endif + if (present(virial)) then + if(i==j) then + virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*dr_mag + else + virial = virial - de_dr*(dr .outer. dr)*dr_mag + endif + endif + endif + end do + end do + + if (this%do_tail_corrections) then + tail_correction = c6_sum * this%tail_correction_const / cell_volume(at) + if (present(e)) e = e + tail_correction + if (present(virial)) then + do d = 1, 3 + virial(d, d) = virial(d, d) + tail_correction + enddo + endif + ! Already taken care of in energy and virial sums + !if (present(mpi)) then + ! tail_correction = sum(mpi, tail_correction) + !endif + call print("Energy tail correction: " // tail_correction // " eV", PRINT_NERD) + call print("Pressure tail correction: " // (tail_correction / cell_volume(at) / GPA_TO_EV_A3) // " GPa", PRINT_NERD) + endif + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(f)) call sum_in_place(mpi, f) + endif + +end subroutine IPModel_DispTS_Calc + + +subroutine IPModel_DispTS_fdamp(this, ti, tj, vi, vj, r, damp, dfdamp) + type(IPModel_DispTS), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r, vi, vj ! Pair distance and relative Hirshfeld volumes + real(dp), intent(out), optional :: damp + real(dp), intent(out), optional :: dfdamp + + real(dp) :: rfree ! Inner cutoff distance + + rfree = this%r_vdW_free(ti)*vi**(1/3.0_dp) + this%r_vdW_free(tj)*vj**(1/3.0_dp) + if (present(damp)) then + damp = 1.0_dp / (1.0_dp + exp(-1.0_dp * this%damp_steepness * (r/rfree/this%damp_scale - 1.0_dp))) + endif + if (present(dfdamp)) then + dfdamp = this%damp_steepness / (2.0_dp * this%damp_scale * rfree) & + / (cosh(this%damp_steepness * (r/rfree/this%damp_scale - 1.0_dp)) + 1.0_dp) + endif + +end subroutine IPModel_DispTS_fdamp + + +function IPModel_DispTS_pair_c6(this, ti, tj, vi, vj) + type(IPModel_DispTS), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: vi, vj ! relative Hirshfeld volumes + real(dp) :: IPModel_DispTS_pair_c6 + + real(dp) :: c6, c6i, c6j ! VdW R^-6 coefficients + real(dp) :: alphai, alphaj + + c6i = this%c6_free(ti) * vi**2 + c6j = this%c6_free(tj) * vj**2 + alphai = this%alpha_free(ti) * vi + alphaj = this%alpha_free(tj) * vj + c6 = 2*c6i*c6j / (alphai/alphaj * c6j + alphaj/alphai * c6i) + IPModel_DispTS_pair_c6 = c6 + +end function IPModel_DispTS_pair_c6 + + +function IPModel_DispTS_pairenergy(this, ti, tj, vi, vj, r, damp) + type(IPModel_DispTS), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r, vi, vj ! Pair distance and relative Hirshfeld volumes + real(dp), intent(in) :: damp ! Damping factor (precalculated) + real(dp) :: IPModel_DispTS_pairenergy + + real(dp) :: c6 ! VdW R^-6 coefficient + real(dp) :: cut ! Smooth cutoff function + + c6 = IPModel_DispTS_pair_c6(this, ti, tj, vi, vj) + cut = coordination_function(r, this%cutoff, this%cutoff_transition_width) + IPModel_DispTS_pairenergy = -1.0_dp * c6 * r**(-6) * damp * cut + +end function IPModel_DispTS_pairenergy + + +function IPModel_DispTS_pairenergy_deriv(this, ti, tj, vi, vj, r, damp, dfdamp) + type(IPModel_DispTS), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r, vi, vj ! Pair distance and relative Hirshfeld volumes + real(dp), intent(in) :: damp, dfdamp ! Damping function and derivative + real(dp) :: IPModel_DispTS_pairenergy_deriv + + real(dp) :: c6 ! VdW R^-6 coefficient + real(dp) :: cut, dcut ! Cutoff function and derivative + + c6 = IPModel_DispTS_pair_c6(this, ti, tj, vi, vj) + cut = coordination_function(r, this%cutoff, this%cutoff_transition_width) + dcut = dcoordination_function(r, this%cutoff, this%cutoff_transition_width) + + IPModel_DispTS_pairenergy_deriv = -1.0_dp * c6 * r**(-6) & + * (dfdamp*cut + damp*dcut - 6.0_dp/r * damp*cut) + +end function IPModel_DispTS_pairenergy_deriv + + +subroutine IPModel_DispTS_Print(this, file) + type(IPModel_DispTS), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_DispTS : T-S dispersion correction potential", file=file) + call Print("IPModel_DispTS : n_types = " // this%n_types // " cutoff = " // this%cutoff // & + " transition width = " // this%cutoff_transition_width, file=file) + + do ti=1, this%n_types + call Print("IPModel_DispTS : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call Print("IPModel_DispTS : type " // ti // " free-atom: C6 " // this%c6_free(ti) & + // " polarizability " // this%alpha_free(ti) & + // " vdW radius " // this%r_vdW_free(ti), file=file) + end do + if (this%do_tail_corrections) then + call Print("IPModel_DispTS : Tail corrections with integral constant " // & + this%tail_correction_const, file=file) + else + call Print("IPModel_DispTS : No tail corrections", file=file) + endif + +end subroutine IPModel_DispTS_Print + + +subroutine IPModel_DispTS_read_params_xml(this, param_str) + type(IPModel_DispTS), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_DispTS_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_DispTS_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + integer ti + + if (name == 'DispTS_params') then ! new DispTS stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in DispTS_params") + endif + + call QUIP_FoX_get_value(attributes, 'only_inter_resid', value, status) + if (status == 0) then + read (value, *) parse_ip%only_inter_resid + else + parse_ip%only_inter_resid = .false. + endif + call QUIP_FoX_get_value(attributes, 'tail_correction_const', value, status) + if (status == 0) then + read (value, *) parse_ip%tail_correction_const + parse_ip%do_tail_corrections = .true. + else + parse_ip%tail_correction_const = 0.0_dp + parse_ip%do_tail_corrections = .false. + endif + + call QUIP_FoX_get_value(attributes, 'tail_corr_factor', value, status) + if (status == 0) then + read (value, *) parse_ip%tail_corr_smooth_factor + else + parse_ip%tail_corr_smooth_factor = 0.0_dp + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + allocate(parse_ip%c6_free(parse_ip%n_types)) + allocate(parse_ip%alpha_free(parse_ip%n_types)) + allocate(parse_ip%r_vdW_free(parse_ip%n_types)) + parse_ip%atomic_num = 0 + parse_ip%c6_free = 0.0_dp + parse_ip%alpha_free = 0.0_dp + parse_ip%r_vdW_free = 0.0_dp + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + call QUIP_FoX_get_value(attributes, "cutoff_transition_width", value, status) + if (status == 0) then + read (value, *) parse_ip%cutoff_transition_width + endif + endif + + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + call QUIP_FoX_get_value(attributes, "c6_free", value, status) + if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find c6_free") + read (value, *) parse_ip%c6_free(ti) + + call QUIP_FoX_get_value(attributes, "alpha_free", value, status) + if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find alpha_free") + read (value, *) parse_ip%alpha_free(ti) + + call QUIP_FoX_get_value(attributes, "r_vdW_free", value, status) + if (status /= 0) call system_abort ("IPModel_DispTS_read_params_xml cannot find r_vdW_free") + read (value, *) parse_ip%r_vdW_free(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'DispTS_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_DispTS_module diff --git a/src/Potentials/IPModel_EAM_Ercolessi_Adams.F90 b/src/Potentials/IPModel_EAM_Ercolessi_Adams.F90 new file mode 100644 index 0000000000..bcc9769526 --- /dev/null +++ b/src/Potentials/IPModel_EAM_Ercolessi_Adams.F90 @@ -0,0 +1,814 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_EAM_ErcolAd module +!X +!% Module for the Embedded Atom Potential of Liu, Ercolessi, Adams. +!% (Ref. Liu, Ercolessi, Adams, {\it Modelling Simul. Mater. Sci. Eng.} {\bf 12}, 665-670, (2004)). +!% In this potential no analytic function is assumed for the actractive and repulsive terms. +!% Each function is described as a set of points, whose values are the IP parameters. +!% A cubic spline function is then used for interpolation between those points. +!% The 'IPModel_EAM_ErcolAd' object contains all the parameters (the grid points) +!% read from an 'EAM_ErcolAd_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_EAM_ErcolAd_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_VERBOSE, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use spline_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +#define PAIR +#define EMBED + +include 'IPModel_interface.h' + +public :: IPModel_EAM_ErcolAd +type IPModel_EAM_ErcolAd + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + + real(dp), allocatable :: r_min(:,:), r_cut(:,:) + real(dp), allocatable :: spline_V(:,:,:,:), spline_rho(:,:,:), spline_F(:,:,:) !% Cubic spline for interpolation between the mesh points. + + type(Spline), allocatable :: V(:,:),rho(:),F(:) + real(dp), allocatable :: V_F_shift(:) + + character(len=STRING_LENGTH) :: label + +end type IPModel_EAM_ErcolAd + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_EAM_ErcolAd), private, pointer :: parse_ip +integer :: parse_cur_type_i, parse_cur_type_j, parse_cur_point +logical :: parse_in_spline_V, parse_in_spline_rho, parse_in_spline_F + +interface Initialise + module procedure IPModel_EAM_ErcolAd_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_EAM_ErcolAd_Finalise +end interface Finalise + +interface Print + module procedure IPModel_EAM_ErcolAd_Print +end interface Print + +interface Calc + module procedure IPModel_EAM_ErcolAd_Calc +end interface Calc + +contains + +subroutine IPModel_EAM_ErcolAd_Initialise_str(this, args_str, param_str) + type(IPModel_EAM_ErcolAd), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_EAM_ErcolAd_Initialise_str args_str')) then + call system_abort("IPModel_EAM_ErcolAd_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_EAM_ErcolAd_read_params_xml(this, param_str) + +end subroutine IPModel_EAM_ErcolAd_Initialise_str + +subroutine IPModel_EAM_ErcolAd_Finalise(this) + type(IPModel_EAM_ErcolAd), intent(inout) :: this + + integer i, j + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%r_min)) deallocate(this%r_min) + if (allocated(this%r_cut)) deallocate(this%r_cut) + + if (allocated(this%spline_V)) deallocate(this%spline_V) + if (allocated(this%spline_rho)) deallocate(this%spline_rho) + if (allocated(this%spline_F)) deallocate(this%spline_F) + + if (allocated(this%rho)) then + do i=1,this%n_types + call Finalise(this%rho(i)) + end do + deallocate(this%rho) + endif + + if (allocated(this%F)) then + do i=1,this%n_types + call Finalise(this%F(i)) + end do + deallocate(this%F) + endif + + if (allocated(this%V)) then + do i=1,this%n_types + do j=1,this%n_types + call finalise(this%V(i,j)) + end do + end do + deallocate(this%V) + endif + + this%n_types = 0 + this%label = '' +end subroutine IPModel_EAM_ErcolAd_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator. It computes energy, forces and virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_EAM_ErcolAd_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_EAM_ErcolAd), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp) :: de, rho_i, drho_i_dri(3), drho_i_drj(3), drho_i_drij_outer_rij(3,3), w_f, V_r, rho_r + real(dp), pointer :: w_e(:) + integer :: i, ji, j, ti, tj + real(dp) :: r_ij_mag, r_ij_hat(3) + real(dp) :: F_n, dF_n, e_in + real(dp) :: spline_rho_d_val, spline_V_d_val, virial_factor(3,3), virial_i(3,3), virial_in(3,3) + real(dp), allocatable, dimension(:,:) :: f_in + + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) then + e = 0.0_dp + endif + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_EAM_ErcolAd_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_EAM_ErcolAd_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) then + virial = 0.0_dp + endif + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_EAM_ErcolAd_Calc', error) + local_virial = 0.0_dp + endif + + if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_EAM_ErcolAd_Calc args_str')) & + call system_abort("IPModel_EAM_ErcolAd_Calc failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_EAM_ErcolAd_Calc did not find "//trim(atom_mask_name)//" propery in the atoms object.") + else + atom_mask_pointer => null() + endif + else + do_rescale_r = .false. + do_rescale_E = .false. + endif + + if (do_rescale_r) call print('IPModel_Tersoff_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) + if (do_rescale_E) call print('IPModel_Tersoff_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) + + ! Has to be allocated because it is in the reduction clause + allocate(f_in(3,at%N)) + f_in = 0.0_dp + e_in = 0.0_dp + virial_in = 0.0_dp + +!$omp parallel do default(none) shared(this,at,mpi,atom_mask_pointer,do_rescale_r,r_scale,w_e,e,f,virial,local_e,local_virial) & +!$omp private(i,j,ti,tj,ji,w_f,rho_i,drho_i_dri,drho_i_drj,drho_i_drij_outer_rij,r_ij_mag,r_ij_hat,V_r,rho_r,de,virial_i) & +!$omp private(spline_rho_d_val,spline_V_d_val,F_n,dF_n,virial_factor) & +!$omp reduction(+:e_in,f_in,virial_in) + do i=1, at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + w_f = 1.0_dp + + rho_i = 0.0_dp + drho_i_dri = 0.0_dp + drho_i_drij_outer_rij = 0.0_dp + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, r_ij_mag, cosines = r_ij_hat) + if (r_ij_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) r_ij_mag = r_ij_mag*r_scale + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (associated(w_e)) w_f = 0.5_dp*(w_e(i)+w_e(j)) + + if (r_ij_mag < this%r_min(ti,tj)) cycle + if (r_ij_mag >= this%r_cut(ti,tj)) cycle + + V_r = eam_spline_V(this, ti, tj, r_ij_mag) + rho_r = eam_spline_rho(this, tj, r_ij_mag) + + V_r = V_r - 2.0_dp*this%V_F_shift(ti)*rho_r + + rho_i = rho_i + rho_r + + de = 0.5_dp*V_r +#ifdef PAIR + if (present(e)) e_in = e_in + de*w_f + if (present(local_e)) local_e(i) = local_e(i) + de +#endif + + if (present(f) .or. present(virial) .or. present(local_virial)) then + spline_rho_d_val = eam_spline_rho_d(this,tj,r_ij_mag) + spline_V_d_val = eam_spline_V_d(this,ti,tj,r_ij_mag) + spline_V_d_val = spline_V_d_val - 2.0_dp*this%V_F_shift(ti)*spline_rho_d_val + if (present(f)) then + drho_i_dri = drho_i_dri + spline_rho_d_val*r_ij_hat +#ifdef PAIR + f_in(:,i) = f_in(:,i) + 0.5_dp*w_f*spline_V_d_val*r_ij_hat + f_in(:,j) = f_in(:,j) - 0.5_dp*w_f*spline_V_d_val*r_ij_hat +#endif + endif + if (present(virial) .or. present(local_virial)) then + virial_factor = (r_ij_hat .outer. r_ij_hat)*r_ij_mag + drho_i_drij_outer_rij = drho_i_drij_outer_rij + spline_rho_d_val*virial_factor + virial_i = 0.5_dp * w_f*spline_V_d_val*virial_factor + endif +#ifdef PAIR + if (present(virial) ) virial_in = virial_in - virial_i + if (present(local_virial) ) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) +#endif + endif + + enddo ! ji + + if (associated(w_e)) w_f = w_e(i) + +#ifdef EMBED + if (present(e) .or. present(local_e)) then + F_n = eam_spline_F(this, ti, rho_i) + F_n = F_n + this%V_F_shift(ti)*rho_i + de = F_n + if (present(e)) e_in = e_in + de*w_f + if (present(local_e)) local_e(i) = local_e(i) + de + endif + + if (present(f) .or. present(virial) .or. present(local_virial)) then + dF_n = eam_spline_F_d(this, ti, rho_i) + dF_n = dF_n + this%V_F_shift(ti) + if (present(f)) f_in(:,i) = f_in(:,i) + w_f*dF_n*drho_i_dri + if (present(virial) .or. present(local_virial)) virial_i = w_f*dF_n*drho_i_drij_outer_rij + if (present(virial)) virial_in = virial_in - virial_i + if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) + + if (present(f)) then + ! cross terms for forces + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, r_ij_mag, cosines = r_ij_hat) + if (r_ij_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) r_ij_mag = r_ij_mag*r_scale + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + drho_i_drj = -eam_spline_rho_d(this, tj, r_ij_mag)*r_ij_hat + f_in(:,j) = f_in(:,j) + w_f*dF_n*drho_i_drj + end do + end if + + endif +#endif + + enddo ! i + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e_in) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) then + call sum_in_place(mpi, f_in) + f = f_in + endif + if (present(virial)) then + call sum_in_place(mpi, virial_in) + virial = virial_in + endif + if (present(local_virial)) call sum_in_place(mpi, local_virial) + endif + + if (do_rescale_r) then + if (present(f)) f = f*r_scale + end if + + if (do_rescale_E) then + if (present(e)) e = e*E_scale + if (present(local_e)) local_e = local_e*E_scale + if (present(f)) f = f*E_scale + if (present(virial)) virial=virial*E_scale + if (present(local_virial)) local_virial=local_virial*E_scale + end if + if(allocated(f_in)) deallocate(f_in) + +end subroutine IPModel_EAM_ErcolAd_Calc + +function eam_spline_V(this, ti, tj, r) + type(IPModel_EAM_ErcolAd), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r + real(dp) :: eam_spline_V + + if (r < min_knot(this%V(ti,tj)) .or. r >= max_knot(this%V(ti,tj))) then + eam_spline_V = 0.0_dp + else + eam_spline_V = spline_value(this%V(ti,tj),r) + endif + +end function eam_spline_V + +function eam_spline_rho(this, ti, r) + type(IPModel_EAM_ErcolAd), intent(in) :: this + integer, intent(in) :: ti + real(dp), intent(in) :: r + real(dp) :: eam_spline_rho + + if (r < min_knot(this%rho(ti)) .or. r >= max_knot(this%rho(ti))) then + eam_spline_rho = 0.0_dp + else + eam_spline_rho = spline_value(this%rho(ti),r) + endif + +end function eam_spline_rho + +function eam_spline_F(this, ti, rho) + type(IPModel_EAM_ErcolAd), intent(in) :: this + integer, intent(in) :: ti + real(dp), intent(in) :: rho + real(dp) :: eam_spline_F + + if (rho < min_knot(this%F(ti)) .or. rho >= max_knot(this%F(ti))) then + eam_spline_F = 0.0_dp + else + eam_spline_F = spline_value(this%F(ti),rho) + endif + +end function eam_spline_F + +function eam_spline_V_d(this, ti, tj, r) + type(IPModel_EAM_ErcolAd), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r + real(dp) :: eam_spline_V_d + + if (r < min_knot(this%V(ti,tj)) .or. r >= max_knot(this%V(ti,tj))) then + eam_spline_V_d = 0.0_dp + else + eam_spline_V_d = spline_deriv(this%V(ti,tj),r) + endif + +end function eam_spline_V_d + +function eam_spline_rho_d(this, ti, r) + type(IPModel_EAM_ErcolAd), intent(in) :: this + integer, intent(in) :: ti + real(dp), intent(in) :: r + real(dp) :: eam_spline_rho_d + + if (r < min_knot(this%rho(ti)) .or. r >= max_knot(this%rho(ti))) then + eam_spline_rho_d = 0.0_dp + else + eam_spline_rho_d = spline_deriv(this%rho(ti),r) + endif + +end function eam_spline_rho_d + +function eam_spline_F_d(this, ti, rho) + type(IPModel_EAM_ErcolAd), intent(in) :: this + integer, intent(in) :: ti + real(dp), intent(in) :: rho + real(dp) :: eam_spline_F_d + + if (rho < min_knot(this%F(ti)) .or. rho >= max_knot(this%F(ti))) then + eam_spline_F_d = 0.0_dp + else + eam_spline_F_d = spline_deriv(this%F(ti),rho) + endif + +end function eam_spline_F_d + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: value + + integer ti, Zi, Zj + integer n_types, n_spline_V, n_spline_rho, n_spline_F + real(dp) :: v + + if (name == 'EAM_ErcolAd_params') then ! new Ercolessi Adams stanza + + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered EAM_ErcolAd_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, "n_types", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find n_types") + read (value, *) parse_ip%n_types + n_types = parse_ip%n_types + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + allocate(parse_ip%r_min(n_types,n_types)) + allocate(parse_ip%r_cut(n_types,n_types)) + parse_ip%r_min = 0.0_dp + parse_ip%r_cut = 0.0_dp + + allocate(parse_ip%V_F_shift(n_types)) + parse_ip%V_F_shift = 0.0_dp + + call QUIP_FoX_get_value(attributes, "n_spline_V", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find n_spline_V") + read (value, *) n_spline_V + call QUIP_FoX_get_value(attributes, "n_spline_rho", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find n_spline_rho") + read (value, *) n_spline_rho + call QUIP_FoX_get_value(attributes, "n_spline_F", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find n_spline_F") + read (value, *) n_spline_F + + allocate(parse_ip%spline_V(5,n_spline_V,n_types,n_types)) + allocate(parse_ip%spline_rho(5,n_spline_rho,n_types)) + allocate(parse_ip%spline_F(5,n_spline_F,n_types)) + + allocate(parse_ip%V(n_types,n_types)) + allocate(parse_ip%rho(n_types)) + allocate(parse_ip%F(n_types)) + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find type") + read (value, *) ti + + if (ti < 1 .or. ti > parse_ip%n_types) call system_abort("IPModel_EAM_ErcolAd_read_params_xml got" // & + " per_type_data type out of range " // ti // " n_types " // parse_ip%n_types) + + parse_cur_type_i = ti + parse_cur_type_j = ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + call QUIP_FoX_get_value(attributes, "V_F_shift", value, status) + if (status == 0) then + read (value, *) parse_ip%V_F_shift(parse_cur_type_i) + endif + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "atomic_num_i", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find atomic_num_i") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atomic_num_j", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find atomic_num_j") + read (value, *) Zj + + parse_cur_type_i = get_type(parse_ip%type_of_atomic_num,Zi) + parse_cur_type_j = get_type(parse_ip%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "r_min", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r_min") + read (value, *) parse_ip%r_min(parse_cur_type_i, parse_cur_type_j) + + call QUIP_FoX_get_value(attributes, "r_cut", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r_cut") + read (value, *) parse_ip%r_cut(parse_cur_type_i, parse_cur_type_j) + + if (parse_cur_type_i /= parse_cur_type_j) then + parse_ip%r_min(parse_cur_type_j, parse_cur_type_i) = parse_ip%r_min(parse_cur_type_i, parse_cur_type_j) + parse_ip%r_cut(parse_cur_type_j, parse_cur_type_i) = parse_ip%r_cut(parse_cur_type_i, parse_cur_type_j) + end if + + elseif (parse_in_ip .and. name == 'spline_V') then + parse_in_spline_V = .true. + parse_cur_point = 1 + elseif (parse_in_ip .and. name == 'spline_rho') then + parse_in_spline_rho = .true. + parse_cur_point = 1 + elseif (parse_in_ip .and. name == 'spline_F') then + parse_in_spline_F = .true. + parse_cur_point = 1 + elseif (parse_in_ip .and. name == 'point') then + + if (parse_in_spline_V) then + + if (parse_cur_point > size(parse_ip%spline_V,2)) call system_abort ("IPModel_EAM_ErcolAd got too " // & + "many points " // parse_cur_point // " type " // parse_cur_type_i // " " // parse_cur_type_j // " in_spline_V") + + call QUIP_FoX_get_value(attributes, "r", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r") + read (value, *) v + parse_ip%spline_V(1,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v + + call QUIP_FoX_get_value(attributes, "y", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find y") + read (value, *) v + parse_ip%spline_V(2,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v + + call QUIP_FoX_get_value(attributes, "b", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find b") + read (value, *) v + parse_ip%spline_V(3,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v + + call QUIP_FoX_get_value(attributes, "c", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find c") + read (value, *) v + parse_ip%spline_V(4,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v + + call QUIP_FoX_get_value(attributes, "d", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find d") + read (value, *) v + parse_ip%spline_V(5,parse_cur_point,parse_cur_type_i,parse_cur_type_j) = v + + if (parse_cur_type_i /= parse_cur_type_j) then + parse_ip%spline_V(1:5,parse_cur_point,parse_cur_type_j,parse_cur_type_i) = & + parse_ip%spline_V(1:5,parse_cur_point,parse_cur_type_i,parse_cur_type_j) + endif + + else if (parse_in_spline_rho) then + + if (parse_cur_point > size(parse_ip%spline_rho,2)) call system_abort ("IPModel_EAM_ErcolAd got " // & + "too many points " // parse_cur_point // " type " // parse_cur_type_i // " in_spline_rho") + + call QUIP_FoX_get_value(attributes, "r", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r") + read (value, *) v + parse_ip%spline_rho(1,parse_cur_point,parse_cur_type_i) = v + + call QUIP_FoX_get_value(attributes, "y", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find y") + read (value, *) v + parse_ip%spline_rho(2,parse_cur_point,parse_cur_type_i) = v + + call QUIP_FoX_get_value(attributes, "b", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find b") + read (value, *) v + parse_ip%spline_rho(3,parse_cur_point,parse_cur_type_i) = v + + call QUIP_FoX_get_value(attributes, "c", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find c") + read (value, *) v + parse_ip%spline_rho(4,parse_cur_point,parse_cur_type_i) = v + + call QUIP_FoX_get_value(attributes, "d", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find d") + read (value, *) v + parse_ip%spline_rho(5,parse_cur_point,parse_cur_type_i) = v + + else if (parse_in_spline_F) then + + if (parse_cur_point > size(parse_ip%spline_F,2)) call system_abort ("IPModel_EAM_ErcolAd got " // & + "too many points " // parse_cur_point // " type " // parse_cur_type_i // " in_spline_F") + + call QUIP_FoX_get_value(attributes, "r", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find r") + read (value, *) v + parse_ip%spline_F(1,parse_cur_point,parse_cur_type_i) = v + + call QUIP_FoX_get_value(attributes, "y", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find y") + read (value, *) v + parse_ip%spline_F(2,parse_cur_point,parse_cur_type_i) = v + + call QUIP_FoX_get_value(attributes, "b", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find b") + read (value, *) v + parse_ip%spline_F(3,parse_cur_point,parse_cur_type_i) = v + + call QUIP_FoX_get_value(attributes, "c", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find c") + read (value, *) v + parse_ip%spline_F(4,parse_cur_point,parse_cur_type_i) = v + + call QUIP_FoX_get_value(attributes, "d", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_ErcolAd_read_params_xml cannot find d") + read (value, *) v + parse_ip%spline_F(5,parse_cur_point,parse_cur_type_i) = v + endif + + parse_cur_point = parse_cur_point + 1 + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'EAM_ErcolAd_params') then + parse_in_ip = .false. + elseif (parse_in_ip .and. name == 'spline_V') then + parse_in_spline_V = .false. + elseif (parse_in_ip .and. name == 'spline_rho') then + parse_in_spline_rho = .false. + elseif (parse_in_ip .and. name == 'spline_F') then + parse_in_spline_F = .false. + endif + endif + + end subroutine IPModel_endElement_handler + +subroutine IPModel_EAM_ErcolAd_read_params_xml(this, param_str) + type(IPModel_EAM_ErcolAd), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type (xml_t) :: fxml + integer ti, tj + + if (len(trim(param_str)) <= 0) return + + parse_ip => this + parse_in_ip = .false. + parse_matched_label = .false. + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types == 0) call system_abort("EAM_ErcolAd Tried to parse, but n_types still 0") + + do ti=1, this%n_types + call initialise(this%rho(ti),this%spline_rho(1,:,ti),this%spline_rho(2,:,ti),huge(1.0_dp),0.0_dp) + call initialise(this%F(ti),this%spline_F(1,:,ti),this%spline_F(2,:,ti),huge(1.0_dp),huge(1.0_dp)) + do tj=1, this%n_types + call initialise(this%V(ti,tj),this%spline_V(1,:,ti,tj),this%spline_V(2,:,ti,tj),huge(1.0_dp),0.0_dp) + end do + end do + + parse_ip%cutoff = maxval(parse_ip%r_cut) + +end subroutine IPModel_EAM_ErcolAd_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of potential parameters: number of different types, cutoff radius, atomic numbers, ect. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_EAM_ErcolAd_Print (this, file) + type(IPModel_EAM_ErcolAd), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_EAM_ErcolAd : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print("IPModel_EAM_ErcolAd : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print("IPModel_EAM_ErcolAd : spline_rho ", file=file) + call Print(this%rho(ti), file=file) + call Print("IPModel_EAM_ErcolAd : spline_F ", file=file) + call Print(this%F(ti), file=file) + do tj=1, this%n_types + call Print("IPModel_EAM_ErcolAd : pair "// ti // " " // tj // " r_min " // this%r_min(ti,tj) // " r_cut " // this%r_cut(ti,tj), file=file) + call Print("IPModel_EAM_ErcolAd : pair spline_V ", file=file) + call Print(this%V(ti,tj), file=file) + end do + call verbosity_pop() + end do + +end subroutine IPModel_EAM_ErcolAd_Print + +end module IPModel_EAM_ErcolAd_module diff --git a/src/Potentials/IPModel_Einstein.F90 b/src/Potentials/IPModel_Einstein.F90 new file mode 100644 index 0000000000..f896af7f65 --- /dev/null +++ b/src/Potentials/IPModel_Einstein.F90 @@ -0,0 +1,369 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Einstein +!X +!% Einstein module +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Einstein_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use cinoutput_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Einstein +type IPModel_Einstein + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + real(dp), dimension(:), allocatable :: spring_constant + + type(atoms) :: ref + character(len=STRING_LENGTH) :: ref_file + + real(dp) :: cutoff = 0.0_dp + + character(len=STRING_LENGTH) :: label + +end type IPModel_Einstein + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Einstein), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Einstein_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Einstein_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Einstein_Print +end interface Print + +interface Calc + module procedure IPModel_Einstein_Calc +end interface Calc + +contains + +subroutine IPModel_Einstein_Initialise_str(this, args_str, param_str) + type(IPModel_Einstein), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Einstein_Initialise_str args_str')) then + call system_abort("IPModel_Einstein_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Einstein_read_params_xml(this, param_str) + + call read(this%ref,trim(this%ref_file)) + ! Add initialisation code here + +end subroutine IPModel_Einstein_Initialise_str + +subroutine IPModel_Einstein_Finalise(this) + type(IPModel_Einstein), intent(inout) :: this + + ! Add finalisation code here + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%spring_constant)) deallocate(this%spring_constant) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Einstein_Finalise + + +subroutine IPModel_Einstein_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Einstein), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), dimension(3) :: diff + real(dp), dimension(3,3) :: virial_i + real(dp) :: ki, ei + integer :: i, ti + ! Add calc() code here + + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Einstein_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Einstein_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Einstein_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_Einstein_Calc: local_virial calculation requested but not supported yet.", error) + endif + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Einstein_Calc args_str')) & + call system_abort("IPModel_Einstein_Calc failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_Einstein_Calc did not find "//trim(atom_mask_name)//" propery in the atoms object.") + else + atom_mask_pointer => null() + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_Einstein_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + endif + + + if(at%N /= this%ref%N) call system_abort("IPModel_Einstein_Calc: number of atoms "//at%N//" does not match the number of atoms "//this%ref%N//" in the & + reference structure") + + do i = 1, at%N + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + ki = this%spring_constant(ti) + + diff = diff_min_image(at,this%ref%pos(:,i),at%pos(:,i)) + if(present(local_e) .or. present(e)) ei = 0.5_dp * ki * sum(diff**2) + + if(present(local_e)) local_e(i) = ei + if(present(e)) e = e + ei + + if(present(f)) f(:,i) = f(:,i) - ki*diff + if(present(virial) .or. present(local_virial)) virial_i = ki*(diff .outer. at%pos(:,i)) + + if(present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) + if(present(virial)) virial = virial - virial_i + enddo + +end subroutine IPModel_Einstein_Calc + + +subroutine IPModel_Einstein_Print(this, file) + type(IPModel_Einstein), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_Einstein : Einstein Potential", file=file) + call Print("IPModel_Einstein : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_Einstein : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call Print ("IPModel_Einstein : type " // ti // " spring_constant " // this%spring_constant(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_Einstein : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_Einstein_Print + +subroutine IPModel_Einstein_read_params_xml(this, param_str) + type(IPModel_Einstein), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Einstein_read_params_xml parsed file, but n_types = 0") + endif +end subroutine IPModel_Einstein_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + integer ti + + if (name == 'Einstein_params') then ! new Einstein stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in Einstein_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%spring_constant(parse_ip%n_types)) + parse_ip%spring_constant = 0.0_dp + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + + call QUIP_FoX_get_value(attributes, "ref_file", value, status) + if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find ref_file") + parse_ip%ref_file = trim(value) + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + call QUIP_FoX_get_value(attributes, "spring_constant", value, status) + if (status /= 0) call system_abort ("IPModel_Einstein_read_params_xml cannot find spring_constant") + read (value, *) parse_ip%spring_constant(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Einstein_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_Einstein_module diff --git a/src/Potentials/IPModel_FB.F90 b/src/Potentials/IPModel_FB.F90 new file mode 100644 index 0000000000..9897226f55 --- /dev/null +++ b/src/Potentials/IPModel_FB.F90 @@ -0,0 +1,455 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_FB module +!% +!% Module for Flikkema \& Bromley interatomic potential +!% +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_FB_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_FB +type IPModel_FB + integer :: n_types = 0 !% Number of atomic types. + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + real(dp), dimension(:,:), allocatable :: A, B, C + + character(len=STRING_LENGTH) label + +end type IPModel_FB + +logical, private :: parse_in_ip, parse_matched_label +integer :: parse_cur_type_i, parse_cur_type_j +type(IPModel_FB), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_FB_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_FB_Finalise +end interface Finalise + +interface Print + module procedure IPModel_FB_Print +end interface Print + +interface Calc + module procedure IPModel_FB_Calc +end interface Calc + +contains + +subroutine IPModel_FB_Initialise_str(this, args_str, param_str) + type(IPModel_FB), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label = '' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FB_Initialise_str args_str')) then + call system_abort("IPModel_FB_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_FB_read_params_xml(this, param_str) + +end subroutine IPModel_FB_Initialise_str + +subroutine IPModel_FB_Finalise(this) + type(IPModel_FB), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%A)) deallocate(this%A) + if (allocated(this%B)) deallocate(this%B) + if (allocated(this%C)) deallocate(this%C) + + this%n_types = 0 + this%cutoff = 0.0_dp + this%label = '' +end subroutine IPModel_FB_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_FB_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_FB), intent(in) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out), optional :: e !% \texttt{e} = System total energy + real(dp), dimension(:), intent(out), optional :: local_e !% \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), dimension(3,3), intent(out), optional :: virial !% Virial + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer :: i, j, n, ti, tj + real(dp) :: r_ij, de, de_dr + real(dp), dimension(3) :: u_ij + real(dp), dimension(3,3) :: virial_i + + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + type(Atoms) :: at_ew + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_FB_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_FB_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_FB_Calc', error) + local_virial = 0.0_dp + endif + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_FB_Calc args_str')) then + RAISE_ERROR("IPModel_FB_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then + RAISE_ERROR("IPModel_FB_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.",error) + endif + else + atom_mask_pointer => null() + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_FB_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + endif + + do i = 1, at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + do n = 1, n_neighbours(at, i) + j = neighbour(at, i, n, distance=r_ij, cosines = u_ij) + if (r_ij .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + if (present(e) .or. present(local_e)) then + de = 0.5_dp * (this%A(ti,tj) * exp( - r_ij / this%B(ti,tj) ) - this%C(ti,tj) / r_ij**6) + if (present(local_e)) local_e(i) = local_e(i) + de + if (present(e)) e = e + de + endif + if (present(f) .or. present(virial)) then + de_dr = 0.5_dp * (-this%A(ti,tj) * exp( - r_ij / this%B(ti,tj) ) / this%B(ti,tj) + & + & 6.0_dp * this%C(ti,tj) / r_ij**7 ) + if (present(f)) then + f(:,i) = f(:,i) + de_dr*u_ij + f(:,j) = f(:,j) - de_dr*u_ij + endif + if (present(virial) .or. present(local_virial)) virial_i = de_dr*(u_ij .outer. u_ij)*r_ij + if (present(virial)) virial = virial - virial_i + if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) + endif + end do + end do + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(f)) call sum_in_place(mpi, f) + endif + +end subroutine IPModel_FB_Calc + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for XML stanza is given below. +!% +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + integer :: ti, Zi, Zj + + if (name == 'FB_params') then ! new FB stanza + + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered FB_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in FB_params") + endif + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if (status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort("Can't find cutoff in FB_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%A(parse_ip%n_types,parse_ip%n_types)) + parse_ip%A = 0.0_dp + allocate(parse_ip%B(parse_ip%n_types,parse_ip%n_types)) + parse_ip%B = 0.0_dp + allocate(parse_ip%C(parse_ip%n_types,parse_ip%n_types)) + parse_ip%C = 0.0_dp + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "atomic_num_i", value, status) + if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find atomic_num_i") + read (value, *) Zi + + call QUIP_FoX_get_value(attributes, "atomic_num_j", value, status) + if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find atomic_num_i") + read (value, *) Zj + + parse_cur_type_i = get_type(parse_ip%type_of_atomic_num,Zi) + parse_cur_type_j = get_type(parse_ip%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "A", value, status) + if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find A") + read (value, *) parse_ip%A(parse_cur_type_i,parse_cur_type_j) + + call QUIP_FoX_get_value(attributes, "B", value, status) + if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find B") + read (value, *) parse_ip%B(parse_cur_type_i,parse_cur_type_j) + + call QUIP_FoX_get_value(attributes, "C", value, status) + if (status /= 0) call system_abort ("IPModel_FB_read_params_xml cannot find C") + read (value, *) parse_ip%C(parse_cur_type_i,parse_cur_type_j) + + if (parse_cur_type_i /= parse_cur_type_j) then + parse_ip%A(parse_cur_type_j,parse_cur_type_i) = parse_ip%A(parse_cur_type_i,parse_cur_type_j) + parse_ip%B(parse_cur_type_j,parse_cur_type_i) = parse_ip%B(parse_cur_type_i,parse_cur_type_j) + parse_ip%C(parse_cur_type_j,parse_cur_type_i) = parse_ip%C(parse_cur_type_i,parse_cur_type_j) + end if + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'FB_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_FB_read_params_xml(this, param_str) + type(IPModel_FB), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_FB_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_FB_read_params_xml + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of FB parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_FB_Print (this, file) + type(IPModel_FB), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_FB : Flikkema Bromley", file=file) + call Print("IPModel_FB : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call verbosity_push_decrement() + do tj=1, this%n_types + call Print ("IPModel_FB : interaction " // ti // " " // tj // " A " // this%A(ti,tj) // " B " // & + & this%B(ti,tj) // " C " // this%C(ti,tj), file=file) + end do + call verbosity_pop() + end do + +end subroutine IPModel_FB_Print + +end module IPModel_FB_module + diff --git a/src/Potentials/IPModel_FC.F90 b/src/Potentials/IPModel_FC.F90 new file mode 100644 index 0000000000..c2613e5cdb --- /dev/null +++ b/src/Potentials/IPModel_FC.F90 @@ -0,0 +1,714 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_FC module +!X +!% Module for Force-Constant (Guggenheim-McGlashan) pair potential. +!% \begin{equation} +!% \nonumber +!% V(r) = 1/2 phi2 (r-r0)^2 + 1/6 phi3 (r-r0)^3 + 1.24 phi4 (r-r0)^4 +!% \end{equation} +!% +!% Proc. Royal Soc. London A, v. 255, p. 456 (1960) +!% Used, e.g. by Bernstein, Feldman, and Singh, Phys. Rev. B (2010) +!% +!% The IPModel_FC object contains all the parameters read from a +!% 'FC_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" +#define NEIGHBOR_LOOP_OPTION 1 + +module IPModel_FC_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_NERD, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use table_module +use connection_module +use atoms_types_module +use atoms_module +use cinoutput_module + +use mpi_context_module +use QUIP_Common_module + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_FC +type IPModel_FC + integer :: n_types = 0 !% Number of atomic types. + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + real(dp), allocatable :: r0(:,:,:), phi2(:,:,:), phi3(:,:,:), phi4(:,:,:) !% IP parameters. + integer, allocatable :: n_fcs(:,:) + + character(len=STRING_LENGTH) :: ideal_struct_file + type(Atoms) :: ideal_struct + + character(len=STRING_LENGTH) label + +end type IPModel_FC + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_FC), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_FC_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_FC_Finalise +end interface Finalise + +interface Print + module procedure IPModel_FC_Print +end interface Print + +interface Calc + module procedure IPModel_FC_Calc +end interface Calc + +contains + +subroutine IPModel_FC_Initialise_str(this, args_str, param_str) + type(IPModel_FC), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + integer, allocatable :: sorted_index(:) + real(dp), allocatable :: t_phi(:) + integer :: ti, tj + + integer :: i, ji, j, s(3), fc_i, tind, t_s(3) + real(dp) :: ideal_v(3), ideal_dr_mag + integer, pointer :: travel(:) + + call Finalise(this) + + call initialise(params) + this%label = '' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "ideal_struct_file", PARAM_MANDATORY, this%ideal_struct_file, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FC_Initialise_str args_str')) then + call system_abort("IPModel_FC_Initialise_str failed to find mandatory ideal_struct_file or parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_FC_read_params_xml(this, param_str) + + call read(this%ideal_struct, trim(this%ideal_struct_file)) +#if NEIGHBOR_LOOP_OPTION == 1 || NEIGHBOR_LOOP_OPTION == 2 + ! will do nothing if travel already exists, but it must exist for inlined neighbor stuff in _Calc() + call add_property(this%ideal_struct, "travel", value=0, n_cols=3, overwrite=.false.) +#endif + + do ti=1, this%n_types + do tj=1, this%n_types + this%n_fcs(ti,tj) = count(this%r0(ti,tj,:) > 0.0_dp) + if (this%n_fcs(ti,tj) > 1) then + allocate(sorted_index(this%n_fcs(ti,tj))) + allocate(t_phi(this%n_fcs(ti,tj))) + sorted_index = [(i, i = 1, size(sorted_index))] + call insertion_sort(this%r0(ti,tj,1:this%n_fcs(ti,tj)), i_data=sorted_index) + t_phi = this%phi2(ti,tj,sorted_index); this%phi2(ti,tj,1:this%n_fcs(ti,tj)) = t_phi + t_phi = this%phi3(ti,tj,sorted_index); this%phi3(ti,tj,1:this%n_fcs(ti,tj)) = t_phi + t_phi = this%phi4(ti,tj,sorted_index); this%phi4(ti,tj,1:this%n_fcs(ti,tj)) = t_phi + deallocate(sorted_index) + deallocate(t_phi) + endif + end do + end do + + call set_cutoff(this%ideal_struct, this%cutoff) + call calc_connect(this%ideal_struct) + do i = 1, this%ideal_struct%N + ti = get_type(this%type_of_atomic_num, this%ideal_struct%Z(i)) + ji = 1 + do while (ji <= n_neighbours(this%ideal_struct, i)) + ji = 1 + do while (ji <= n_neighbours(this%ideal_struct, i)) + j = neighbour(this%ideal_struct, i, ji, distance=ideal_dr_mag, shift=s) + + ! if (dr_mag .feq. 0.0_dp) cycle + ! if ((i < j) .and. i_is_min_image) cycle + + tj = get_type(this%type_of_atomic_num, this%ideal_struct%Z(j)) + + fc_i = find_fc_i(this, ti, tj, ideal_dr_mag) + if (fc_i <= 0) then + call remove_bond(this%ideal_struct%connect, i, j, s) + exit + end if + ji = ji + 1 + end do ! while ji inner + end do ! while ji outer + end do ! j + +end subroutine IPModel_FC_Initialise_str + +subroutine IPModel_FC_Finalise(this) + type(IPModel_FC), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%r0)) deallocate(this%r0) + if (allocated(this%phi2)) deallocate(this%phi2) + if (allocated(this%phi3)) deallocate(this%phi3) + if (allocated(this%phi4)) deallocate(this%phi4) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_FC_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_FC_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_FC), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), pointer :: w_e(:) + integer i, ji, j, ti, tj, fc_i + real(dp) :: dr(3), dr_mag, ideal_dr_mag, ideal_v(3) + real(dp) :: de, de_dr + integer :: s(3) + logical :: i_is_min_image + + integer :: i_calc, n_extra_calcs + character(len=20) :: extra_calcs_list(10) + + logical :: do_flux = .false. + real(dp), pointer :: velo(:,:) + real(dp) :: flux(3) + integer :: tind, dr_shift(3) + type(Table), pointer :: t + logical :: is_j + real(dp) :: dr_v(3) +#if NEIGHBOR_LOOP_OPTION == 2 + integer :: i_n1n, j_n1n +#endif + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_FC_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_FC_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) virial = 0.0_dp + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_FC_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_FC_Calc: local_virial calculation requested but not supported yet.", error) + endif + + atom_mask_pointer => null() + if (present(args_str)) then + if (len_trim(args_str) > 0) then + n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) + if (n_extra_calcs > 0) then + do i_calc=1, n_extra_calcs + select case(trim(extra_calcs_list(i_calc))) + case("flux") + if (.not. assign_pointer(at, "velo", velo)) & + call system_abort("IPModel_FC_Calc Flux calculation requires velo field") + do_flux = .true. + flux = 0.0_dp + case default + call system_abort("Unsupported extra_calc '"//trim(extra_calcs_list(i_calc))//"'") + end select + end do + endif ! n_extra_calcs + endif ! len_trim(args_str) + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_FC_Calc args_str')) then + RAISE_ERROR("IPModel_FC_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + + if( has_atom_mask_name ) then + RAISE_ERROR('IPModel_FC_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_FC_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + endif ! present(args_str) + + if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) + + do i = 1, at%N + i_is_min_image = this%ideal_struct%connect%is_min_image(i) + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + do ji = 1, n_neighbours(this%ideal_struct, i) +#if NEIGHBOR_LOOP_OPTION == 0 + j = neighbour(at, i, ji, dr_mag, cosines = dr, shift=s) +#endif +#if NEIGHBOR_LOOP_OPTION == 1 || NEIGHBOR_LOOP_OPTION == 2 +#if NEIGHBOR_LOOP_OPTION == 1 + j = neighbour_index(this%ideal_struct, i, ji, tind, t, is_j) +#else + i_n1n = ji-this%ideal_struct%connect%neighbour2(i)%t%N + if (ji <= this%ideal_struct%connect%neighbour2(i)%t%N) then + j = this%ideal_struct%connect%neighbour2(i)%t%int(1,ji) + j_n1n = this%ideal_struct%connect%neighbour2(i)%t%int(2,ji) + tind = j_n1n + t => this%ideal_struct%connect%neighbour1(j)%t + is_j = .true. + else if (i_n1n <= this%ideal_struct%connect%neighbour1(i)%t%N) then + j = this%ideal_struct%connect%neighbour1(i)%t%int(1,i_n1n) + tind = i_n1n + t => this%ideal_struct%connect%neighbour1(i)%t + is_j = .false. + endif +#endif + if((i < j) .and. i_is_min_image) cycle + ideal_dr_mag = t%real(1,tind) + if (ideal_dr_mag .feq. 0.0_dp) cycle + if (is_j) then + s = -t%int(2:4,tind) + else + s = t%int(2:4,tind) + endif +#endif + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + fc_i = find_fc_i(this, ti, tj, ideal_dr_mag) + if (fc_i <= 0) cycle + +#if NEIGHBOR_LOOP_OPTION == 1 || NEIGHBOR_LOOP_OPTION == 2 + ! v = (p(j) - lat . travel(j)) - (p(i) - lat . travel(i)) + lat . s + ! = p(j) - p(i) + lat . (travel(i) - travel(j) + s) + dr_shift = - at%travel(:,i) + at%travel(:,j) + this%ideal_struct%travel(:,i) - this%ideal_struct%travel(:,j) + s(:) + dr_v = at%pos(:,j) - at%pos(:,i) + ( at%lattice(:,1) * dr_shift(1) + & + at%lattice(:,2) * dr_shift(2) + & + at%lattice(:,3) * dr_shift(3) ) + dr_mag = sqrt(dr_v(1)*dr_v(1) + dr_v(2)*dr_v(2) + dr_v(3)*dr_v(3)) +#endif + + if (present(e) .or. present(local_e)) then + de = IPModel_FC_pairenergy(this, ti, tj, fc_i, dr_mag) + if (present(local_e)) then + local_e(i) = local_e(i) + 0.5_dp*de + if (i_is_min_image) local_e(j) = local_e(j) + 0.5_dp*de + endif + if (present(e)) then + if (associated(w_e)) then + de = de*0.5_dp*(w_e(i)+w_e(j)) + endif + if(i_is_min_image) then + e = e + de + else + e = e + 0.5_dp*de + endif + endif + endif + if (present(f) .or. present(virial) .or. do_flux) then + de_dr = IPModel_FC_pairenergy_deriv(this, ti, tj, fc_i, dr_mag) + if (associated(w_e)) then + de_dr = de_dr*0.5_dp*(w_e(i)+w_e(j)) + endif + dr = dr_v/dr_mag + if (present(f)) then + f(:,i) = f(:,i) + de_dr*dr + if(i_is_min_image) f(:,j) = f(:,j) - de_dr*dr + endif + if (do_flux) then + ! -0.5 (v_i + v_j) . F_ij * dr_ij + flux = flux - 0.5_dp*sum((velo(:,i)+velo(:,j))*(de_dr*dr))*(dr*dr_mag) + endif + if (present(virial)) then + if(i_is_min_image) then + virial = virial - de_dr*(dr .outer. dr)*dr_mag + else + virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*dr_mag + endif + endif + endif + end do + end do ! i + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(f)) call sum_in_place(mpi, f) + endif + if (do_flux) then + flux = flux / cell_volume(at) + if (present(mpi)) call sum_in_place(mpi, flux) + call set_value(at%params, "Flux", flux) + endif + +end subroutine IPModel_FC_Calc + +!% This routine computes the two-body term for a pair of atoms separated by a distance r. +function IPModel_FC_pairenergy(this, ti, tj, fc_i, r) + type(IPModel_FC), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + integer, intent(in) :: fc_i !% Force-constant index + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_FC_pairenergy + + real(dp) :: dr, dr2, dr3, dr4 + real(dp), parameter :: c2 = 1.0_dp/2.0_dp, c3 = 1.0_dp/6.0_dp, c4 = 1.0_dp/24.0_dp + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff)) then + IPModel_FC_pairenergy = 0.0 + return + endif + + dr = r - this%r0(ti,tj,fc_i) + dr2 = dr*dr + dr3 = dr2*dr + dr4 = dr2*dr2 + IPModel_FC_pairenergy = c2*this%phi2(ti,tj,fc_i)*dr2 + & + c3*this%phi3(ti,tj,fc_i)*dr3 + & + c4*this%phi4(ti,tj,fc_i)*dr4 +end function IPModel_FC_pairenergy + +!% Derivative of the two-body term. +function IPModel_FC_pairenergy_deriv(this, ti, tj, fc_i, r) + type(IPModel_FC), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + integer, intent(in) :: fc_i !% FC index + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_FC_pairenergy_deriv + + real(dp) :: dr, dr2, dr3 + real(dp), parameter :: c2 = 1.0_dp, c3 = 1.0_dp/2.0_dp, c4 = 1.0_dp/6.0_dp + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff)) then + IPModel_FC_pairenergy_deriv = 0.0 + return + endif + + dr = r - this%r0(ti,tj,fc_i) + dr2 = dr*dr + dr3 = dr2*dr + IPModel_FC_pairenergy_deriv = c2*this%phi2(ti,tj,fc_i)*dr + & + c3*this%phi3(ti,tj,fc_i)*dr2 + & + c4*this%phi4(ti,tj,fc_i)*dr3 +end function IPModel_FC_pairenergy_deriv + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for XML stanza is given below, please notice that +!% they are simply dummy parameters for testing purposes, with no physical meaning. +!% +!%> +!%> +!%> +!%> +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + integer atnum_i, atnum_j, fc_i, ti, tj, max_n_fcs, ti_a(1) + + if (name == 'FC_params') then ! new FC stanza + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered FC_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in FC_params") + endif + + call QUIP_FoX_get_value(attributes, 'max_n_fcs', value, status) + if (status == 0) then + read (value, *) max_n_fcs + else + call system_abort("Can't find max_n_fcs in FC_params") + endif + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if (status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort("Can't find this%cutoff in FC_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%r0(parse_ip%n_types,parse_ip%n_types,max_n_fcs)) + allocate(parse_ip%phi2(parse_ip%n_types,parse_ip%n_types,max_n_fcs)) + allocate(parse_ip%phi3(parse_ip%n_types,parse_ip%n_types,max_n_fcs)) + allocate(parse_ip%phi4(parse_ip%n_types,parse_ip%n_types,max_n_fcs)) + allocate(parse_ip%n_fcs(parse_ip%n_types,parse_ip%n_types)) + + parse_ip%r0 = 0.0_dp + parse_ip%phi2 = 0.0_dp + parse_ip%phi3 = 0.0_dp + parse_ip%phi4 = 0.0_dp + + endif ! parse_in_ip + elseif (parse_in_ip .and. name == 'FC') then + + call QUIP_FoX_get_value(attributes, "atnum_i", value, status) + if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find atnum_i") + read (value, *) atnum_i + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find atnum_j") + read (value, *) atnum_j + call QUIP_FoX_get_value(attributes, "fc_i", value, status) + if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find fc_i") + read (value, *) fc_i + + if (all(parse_ip%atomic_num /= atnum_i)) then + ti_a = minloc(parse_ip%atomic_num) + parse_ip%atomic_num(ti_a(1)) = atnum_i + endif + if (all(parse_ip%atomic_num /= atnum_j)) then + ti_a = minloc(parse_ip%atomic_num) + parse_ip%atomic_num(ti_a(1)) = atnum_j + endif + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + ti = parse_ip%type_of_atomic_num(atnum_i) + tj = parse_ip%type_of_atomic_num(atnum_j) + + call QUIP_FoX_get_value(attributes, "r0", value, status) + if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find r0") + read (value, *) parse_ip%r0(ti,tj,fc_i) + call QUIP_FoX_get_value(attributes, "phi2", value, status) + if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find phi2") + read (value, *) parse_ip%phi2(ti,tj,fc_i) + call QUIP_FoX_get_value(attributes, "phi3", value, status) + if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find phi3") + read (value, *) parse_ip%phi3(ti,tj,fc_i) + call QUIP_FoX_get_value(attributes, "phi4", value, status) + if (status /= 0) call system_abort ("IPModel_FC_read_params_xml cannot find phi4") + read (value, *) parse_ip%phi4(ti,tj,fc_i) + + if (ti /= tj) then + parse_ip%r0(tj,ti,fc_i) = parse_ip%r0(ti,tj,fc_i) + parse_ip%phi2(tj,ti,fc_i) = parse_ip%phi2(ti,tj,fc_i) + parse_ip%phi3(tj,ti,fc_i) = parse_ip%phi3(ti,tj,fc_i) + parse_ip%phi4(tj,ti,fc_i) = parse_ip%phi4(ti,tj,fc_i) + endif + + endif ! parse_in_ip .and. name = 'FC' + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'FC_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_FC_read_params_xml(this, param_str) + type(IPModel_FC), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_FC_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_FC_read_params_xml + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of FC parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_FC_Print (this, file) + type(IPModel_FC), intent(inout) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj, fc_i + + call Print("IPModel_FC : Force-Constant (Guggenheim-McGlashan)", file=file) + call Print("IPModel_FC : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_FC : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + do tj=1, this%n_types + do fc_i=1, this%n_fcs(ti,tj) + call Print ("IPModel_FC : interaction " // ti // " " // tj // " r0 " // this%r0(ti,tj,fc_i) // " phi2,3,4 " // & + this%phi2(ti,tj,fc_i) // " " // this%phi3(ti,tj,fc_i) // " " // this%phi4(ti,tj,fc_i), file=file) + end do + end do + call verbosity_pop() + end do + + call verbosity_push_decrement(PRINT_NERD) + call print("IPModel_FC : ideal_struct_file='"//trim(this%ideal_struct_file)//"'", file=file) + call print("IPModel_FC : ideal_struct", file=file) + call write(this%ideal_struct,'stdout') + call verbosity_pop() + +end subroutine IPModel_FC_Print + +function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) + character(len=*), intent(in) :: args_str + character(len=*), intent(out) :: extra_calcs_list(:) + integer :: n_extra_calcs + + character(len=STRING_LENGTH) :: extra_calcs_str + type(Dictionary) :: params + + n_extra_calcs = 0 + call initialise(params) + call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") + if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then + if (len_trim(extra_calcs_str) > 0) then + call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") + end if + end if + call finalise(params) + +end function parse_extra_calcs + +function find_fc_i(this, ti, tj, ideal_dr_mag) + type(IPModel_FC), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: ideal_dr_mag + integer find_fc_i + + integer :: fc_i + + find_fc_i = 0 + do fc_i=1, this%n_fcs(ti,tj) + if (abs(this%r0(ti,tj,fc_i)-ideal_dr_mag) < 1.0e-4_dp) then + find_fc_i = fc_i + return + endif + end do +end function find_fc_i + +end module IPModel_FC_module diff --git a/src/Potentials/IPModel_FC4.F90 b/src/Potentials/IPModel_FC4.F90 new file mode 100644 index 0000000000..e3a5444956 --- /dev/null +++ b/src/Potentials/IPModel_FC4.F90 @@ -0,0 +1,836 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_FC4 module +!X +!% Module for the Fourth-order force-constant potential, described in +!% Esfarjani, Chen and Stokes, Phys. Rev. B {\bf 84} 085204 (2011) +!% +!% Calculation works as follows: The atom positions and velocities in +!% 'at' correspond to a supercell of the primitive lattice, read into +!% 'ideal_struct'. The 'cell_offset' property of 'at' contains the +!% multiples of the lattice vectors mapping this atom from the +!% primitive cell to the supercell, and the 'prim_index' property is +!% the index of the atom within this cell. A third file contains the +!% neighbours (described as 'neighbourshell', 'atom_shl' in Esfarjani) +!% to which force constants are computed. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_FC4_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use minimization_module, only: KahanSum +use atoms_types_module +use atoms_module +use cinoutput_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_FC4 +type IPModel_FC4 + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + + character(len=STRING_LENGTH) :: label + + character(len=STRING_LENGTH) :: ideal_struct_file + type(Atoms) :: ideal_struct + integer, pointer :: ideal_struct_prim_index(:) + integer, pointer :: ideal_struct_cell_offset(:,:) + + character(len=STRING_LENGTH) :: atom_shl_file + type(Atoms) :: atom_shl + integer, pointer :: atom_shl_prim_index(:) + integer, pointer :: atom_shl_cell_offset(:,:) + + character(len=STRING_LENGTH) :: fc2_file, fc3_file, fc4_file + + integer :: nfc2, nfc2_indep, nfc3, nfc3_indep, nfc4, nfc4_indep + + integer , allocatable :: igroup_2(:) + integer , allocatable :: iatomterm_2(:,:) + integer , allocatable :: ixyzterm_2(:,:) + real(dp), allocatable :: fcs_2(:) + real(dp), allocatable :: ampterm_2(:) + + integer , allocatable :: igroup_3(:) + integer , allocatable :: iatomterm_3(:,:) + integer , allocatable :: ixyzterm_3(:,:) + real(dp), allocatable :: fcs_3(:) + real(dp), allocatable :: ampterm_3(:) + + integer , allocatable :: igroup_4(:) + integer , allocatable :: iatomterm_4(:,:) + integer , allocatable :: ixyzterm_4(:,:) + real(dp), allocatable :: fcs_4(:) + real(dp), allocatable :: ampterm_4(:) + + integer, allocatable :: findatom_sc_array(:,:,:,:) + integer sc_min(3), sc_max(3) + + real(dp) :: superlattice(3,3), inv_superlattice(3,3) + +end type IPModel_FC4 + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_FC4), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_FC4_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_FC4_Finalise +end interface Finalise + +interface Print + module procedure IPModel_FC4_Print +end interface Print + +interface Calc + module procedure IPModel_FC4_Calc +end interface Calc + +contains + +subroutine IPModel_FC4_Initialise_str(this, args_str, param_str) + type(IPModel_FC4), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + integer :: ntau + + call Finalise(this) + + this%label = '' + this%ideal_struct_file = '' + this%atom_shl_file = '' + this%fc2_file = '' + this%fc3_file = '' + this%fc4_file = '' + + call initialise(params) + + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "ideal_struct_file", PARAM_MANDATORY, this%ideal_struct_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "atom_shl_file", PARAM_MANDATORY, this%atom_shl_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "fc2_file", PARAM_MANDATORY, this%fc2_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "fc3_file", '', this%fc3_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "fc4_file", '', this%fc4_file, help_string="No help yet. This source file was $LastChangedBy$") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FC4_Initialise_str args_str')) then + call system_abort("IPModel_FC4_Initialise_str failed to find mandatory ideal_struct_file or fc2_file, or parse label from args_str="//trim(args_str)) + endif + + call finalise(params) + + call IPModel_FC4_read_params_xml(this, param_str) + + ! + ! Read the ideal structure + ! + call read(this%ideal_struct, trim(this%ideal_struct_file)) + call get_param_value(this%ideal_struct, "Superlattice", this%superlattice) + call matrix3x3_inverse(this%superlattice, this%inv_superlattice) + call add_property(this%ideal_struct, "cell_offset", value=0, n_cols=3, overwrite=.false.) + call add_property(this%ideal_struct, "prim_index", value=0, n_cols=1, overwrite=.false.) + if (.not.assign_pointer(this%ideal_struct, "prim_index", this%ideal_struct_prim_index)) & + call system_abort("IPModel_FC4 requires 'prim_index' field in ideal struct file") + if (.not.assign_pointer(this%ideal_struct, "cell_offset", this%ideal_struct_cell_offset)) & + call system_abort("IPModel_FC4 requires 'cell_offset' field in ideal struct file") + + allocate(this%igroup_2(this%nfc2), & + this%iatomterm_2(2,this%nfc2), & + this%ixyzterm_2(2,this%nfc2), & + this%fcs_2(this%nfc2), & + this%ampterm_2(this%nfc2)) + + allocate(this%igroup_3(this%nfc3), & + this%iatomterm_3(3,this%nfc3), & + this%ixyzterm_3(3,this%nfc3), & + this%fcs_3(this%nfc3), & + this%ampterm_3(this%nfc3)) + + allocate(this%igroup_4(this%nfc4), & + this%iatomterm_4(4,this%nfc4), & + this%ixyzterm_4(4,this%nfc4), & + this%fcs_4(this%nfc4), & + this%ampterm_4(this%nfc4)) + + this%sc_min = minval(this%ideal_struct_cell_offset,2) + this%sc_max = maxval(this%ideal_struct_cell_offset,2) + ntau = maxval(this%ideal_struct_prim_index) + + allocate(this%findatom_sc_array(ntau, this%sc_min(1):this%sc_max(1), & + this%sc_min(2):this%sc_max(2), & + this%sc_min(3):this%sc_max(3))) + + call fill_findatom_sc_array(this%findatom_sc_array, ntau, this%sc_min, this%sc_max, this%ideal_struct) + + ! + ! Read the atom_shl atoms + ! + call read(this%atom_shl, trim(this%atom_shl_file)) + call add_property(this%atom_shl, "cell_offset", value=0, n_cols=3, overwrite=.false.) + call add_property(this%atom_shl, "prim_index", value=0, n_cols=1, overwrite=.false.) + if (.not.assign_pointer(this%atom_shl, "prim_index", this%atom_shl_prim_index)) & + call system_abort("IPModel_FC4 requires 'prim_index' field in atom_shl file") + if (.not.assign_pointer(this%atom_shl, "cell_offset", this%atom_shl_cell_offset)) & + call system_abort("IPModel_FC4 requires 'cell_offset' field in atom_shl file") + + ! + ! Read the force constants + ! + call read_fcs(2, this%nfc2, trim(this%fc2_file), this%igroup_2, this%iatomterm_2, this%ixyzterm_2, this%fcs_2, this%ampterm_2) + if (this%nfc3.gt.0) call read_fcs(3, this%nfc3, trim(this%fc3_file), this%igroup_3, this%iatomterm_3, this%ixyzterm_3, this%fcs_3, this%ampterm_3) + if (this%nfc4.gt.0) call read_fcs(4, this%nfc4, trim(this%fc4_file), this%igroup_4, this%iatomterm_4, this%ixyzterm_4, this%fcs_4, this%ampterm_4) + +end subroutine IPModel_FC4_Initialise_str + +subroutine IPModel_FC4_Finalise(this) + type(IPModel_FC4), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%igroup_2)) deallocate(this%igroup_2) + if (allocated(this%iatomterm_2)) deallocate(this%iatomterm_2) + if (allocated(this%ixyzterm_2)) deallocate(this%ixyzterm_2) + if (allocated(this%fcs_2)) deallocate(this%fcs_2) + if (allocated(this%ampterm_2)) deallocate(this%ampterm_2) + + if (allocated(this%igroup_3)) deallocate(this%igroup_3) + if (allocated(this%iatomterm_3)) deallocate(this%iatomterm_3) + if (allocated(this%ixyzterm_3)) deallocate(this%ixyzterm_3) + if (allocated(this%fcs_3)) deallocate(this%fcs_3) + if (allocated(this%ampterm_3)) deallocate(this%ampterm_3) + + if (allocated(this%igroup_4)) deallocate(this%igroup_4) + if (allocated(this%iatomterm_4)) deallocate(this%iatomterm_4) + if (allocated(this%ixyzterm_4)) deallocate(this%ixyzterm_4) + if (allocated(this%fcs_4)) deallocate(this%fcs_4) + if (allocated(this%ampterm_4)) deallocate(this%ampterm_4) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_FC4_Finalise + + +subroutine IPModel_FC4_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_FC4), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer :: ia, ja, ka, la, i0, j0, k0, l0, alpha, beta, gamma, delta + integer ix + integer :: ifc, ni(3), taui, tauj + real(dp) :: disp_alpha_i, disp_beta_j, phi, de, df, fsum(3) + real(dp) :: displacement(3,at%N) + real(dp) :: local_virial_sq(3,3,at%N) + real(dp) :: local_e_tmp(at%N) + + real(dp) :: r_ij(3), com_offset(3) + integer n_extra_calcs, i_calc + character(len=20) :: extra_calcs_list(10) + + logical :: do_flux = .false. + real(dp), pointer :: velo(:,:) + real(dp) :: flux(3) +! real(dp), allocatable :: local_flux(:,:) + + INIT_ERROR(error) + +! allocate(local_flux(3,at%N)) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_FC4_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_FC4_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_FC4_Calc', error) + local_virial = 0.0_dp + endif + + if (present(args_str)) then + if (len_trim(args_str) > 0) then + n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) + if (n_extra_calcs > 0) then + do i_calc=1, n_extra_calcs + select case(trim(extra_calcs_list(i_calc))) + case("flux") + if (.not. assign_pointer(at, "velo", velo)) then + RAISE_ERROR("IPModel_LJ_Calc Flux calculation requires velo field", error) + endif + do_flux = .true. + case default + RAISE_ERROR("Unsupported extra_calc '"//trim(extra_calcs_list(i_calc))//"'", error) + end select + end do + endif ! n_extra_calcs + endif ! len_trim(args_str) + end if ! present(args_str) + + local_virial_sq = 0 + local_e_tmp = 0 + flux = 0 +! local_flux = 0 + +! Remap positions by the mean position to avoid loss of precision in +! the forces if there is a drift. Don't use 'centre_of_mass' because +! the `mass' property might not be present. Using the precise centre +! of mass is not important. + do ix=1,3 + com_offset(ix) = KahanSum( (/ (at%pos(ix,ia) - this%ideal_struct%pos(ix,ia), ia=1,at%N) /) ) / at%N + end do + + do ia=1,at%N + displacement(:,ia) = -diff_min_image(at, ia, this%ideal_struct%pos(:,ia) + com_offset) + end do + + do ia=1,at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(ia-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + taui = this%ideal_struct_prim_index(ia) ! the primitive-cell atom index (taui) + ni = this%ideal_struct_cell_offset(:,ia) ! the image cell of the atom (ni) + ! + ! second order + do ifc=1,this%nfc2 + i0 = this%iatomterm_2(1,ifc) + if (this%atom_shl_prim_index(i0).ne.taui.or.any(this%atom_shl_cell_offset(:,i0).ne.0)) cycle + + j0 = this%iatomterm_2(2,ifc) + alpha = this%ixyzterm_2(1,ifc) + beta = this%ixyzterm_2(2,ifc) + ja = findatom_sc(this, this%atom_shl_prim_index(j0), this%atom_shl_cell_offset(:,j0) + ni, at) + + phi = this%fcs_2(ifc) * this%ampterm_2(ifc) + df = -phi * displacement(beta,ja) + + if (present(local_e).or.present(e)) local_e_tmp(ia) = local_e_tmp(ia) + 0.5*phi * displacement(alpha,ia) * displacement(beta,ja) + if (present(f)) f(alpha,ia) = f(alpha,ia) + df + if (do_flux) then + r_ij = diff_min_image(at, ia, ja) + flux = flux + r_ij(:) * phi * displacement(alpha,ia) * velo(beta,ja) / 2 + end if + if (present(local_virial).or.present(virial)) then + local_virial_sq(alpha,:,ia) = local_virial_sq(alpha,:,ia) + at%pos(:,ia) * df + end if + end do + + ! + ! third order + do ifc=1,this%nfc3 + i0 = this%iatomterm_3(1,ifc) + if (this%atom_shl_prim_index(i0).ne.taui.or.any(this%atom_shl_cell_offset(:,i0).ne.0)) cycle + j0 = this%iatomterm_3(2,ifc) + k0 = this%iatomterm_3(3,ifc) + + alpha = this%ixyzterm_3(1,ifc) + beta = this%ixyzterm_3(2,ifc) + gamma = this%ixyzterm_3(3,ifc) + + ja = findatom_sc(this, this%atom_shl_prim_index(j0), this%atom_shl_cell_offset(:,j0) + ni, at) + ka = findatom_sc(this, this%atom_shl_prim_index(k0), this%atom_shl_cell_offset(:,k0) + ni, at) + + phi = this%fcs_3(ifc) * this%ampterm_3(ifc) + + df = -phi * displacement(beta,ja) * displacement(gamma,ka) / 2 + + if (present(local_e).or.present(e)) local_e_tmp(ia) = local_e_tmp(ia) + phi * displacement(alpha,ia) * displacement(beta,ja) * displacement(gamma,ka) / 6 + if (present(f)) f(alpha,ia) = f(alpha,ia) + df + if (do_flux) then + r_ij = diff_min_image(at, ia, ja) + flux = flux + r_ij(:) * phi * displacement(alpha,ia) * displacement(gamma,ka) * velo(beta,ja) / 3 + end if + if (present(local_virial).or.present(virial)) then + local_virial_sq(alpha,:,ia) = local_virial_sq(alpha,:,ia) + at%pos(:,ia) * df + end if + end do + + ! + ! fourth order + do ifc=1,this%nfc4 + i0 = this%iatomterm_4(1,ifc) + if (this%atom_shl_prim_index(i0).ne.taui.or.any(this%atom_shl_cell_offset(:,i0).ne.0)) cycle + j0 = this%iatomterm_4(2,ifc) + k0 = this%iatomterm_4(3,ifc) + l0 = this%iatomterm_4(4,ifc) + + alpha = this%ixyzterm_4(1,ifc) + beta = this%ixyzterm_4(2,ifc) + gamma = this%ixyzterm_4(3,ifc) + delta = this%ixyzterm_4(4,ifc) + + ja = findatom_sc(this, this%atom_shl_prim_index(j0), this%atom_shl_cell_offset(:,j0) + ni, at) + ka = findatom_sc(this, this%atom_shl_prim_index(k0), this%atom_shl_cell_offset(:,k0) + ni, at) + la = findatom_sc(this, this%atom_shl_prim_index(l0), this%atom_shl_cell_offset(:,l0) + ni, at) + + phi = this%fcs_4(ifc) * this%ampterm_4(ifc) + + df = -phi * displacement(beta,ja) * displacement(gamma,ka) * displacement(delta,la) / 6 + if (present(local_e).or.present(e)) local_e_tmp(ia) = local_e_tmp(ia) + & + phi * displacement(alpha,ia) * displacement(beta,ja) * displacement(gamma,ka) * displacement(delta,la) / 24 + if (present(f)) f(alpha,ia) = f(alpha,ia) + df + if (do_flux) then + ! distance between current positions of atoms i and j (same meaning as the anh_md code) + r_ij = diff_min_image(at, ia, ja) +! local_flux(:,ia) = local_flux(:,ia) + r_ij * phi * displacement(alpha,ia) * displacement(gamma,ka) * displacement(delta,la) * velo(beta,ja) / 8 + flux = flux + r_ij(:) * phi * displacement(alpha,ia) * displacement(gamma,ka) * displacement(delta,la) * velo(beta,ja) / 8 + end if + !if (present(local_virial).or.present(virial)) then + local_virial_sq(alpha,:,ia) = local_virial_sq(alpha,:,ia) + at%pos(:,ia) * df + !local_virial_sq(alpha,:,ja) = local_virial_sq(alpha,:,ja) + at%pos(:,ia) * df / 4 + !local_virial_sq(alpha,:,ka) = local_virial_sq(alpha,:,ka) + at%pos(:,ia) * df / 4 + !local_virial_sq(alpha,:,la) = local_virial_sq(alpha,:,la) + at%pos(:,ia) * df / 4 + !end if + end do + end do + + if (present(local_virial)) local_virial = reshape(local_virial_sq, (/ 9, at%N /)) + if (present(virial)) virial = sum(local_virial_sq,3) + if (present(local_e)) local_e = local_e_tmp + if (present(e)) e = KahanSum(local_e_tmp) + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(virial)) call sum_in_place(mpi, local_virial) + if (present(f)) call sum_in_place(mpi, f) + endif + if (present(f)) then + do ix=1,3 + fsum(ix) = KahanSum(f(ix,:)) / at%N + end do + do ia=1,at%N + f(:,ia) = f(:,ia) - fsum + end do + end if + + + if (do_flux) then + if (present(mpi)) call sum_in_place(mpi, flux) +! local_flux = local_flux / cell_volume(at) +! flux = sum(local_flux,2) + flux = flux / cell_volume(at) + call set_value(at%params, "Flux", flux) + end if + +end subroutine IPModel_FC4_Calc + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + integer atnum_i, atnum_j, fc_i, ti, tj, max_n_fcs, ti_a(1) + + if (name == 'FC4_params') then ! new FC4 stanza + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered FC4_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in FC4_params") + endif + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if (status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort("Can't find cutoff in FC4_params") + endif + + call QUIP_FoX_get_value(attributes, 'nfc2', value, status) + if (status == 0) then + read (value, *) parse_ip%nfc2 + else + call system_abort("Can't find nfc2 in FC4_params") + endif + call QUIP_FoX_get_value(attributes, 'nfc2_indep', value, status) + if (status == 0) then + read (value, *) parse_ip%nfc2_indep + else + parse_ip%nfc2_indep = parse_ip%nfc2 + endif + + call QUIP_FoX_get_value(attributes, 'nfc3', value, status) + if (status == 0) then + read (value, *) parse_ip%nfc3 + else + parse_ip%nfc3 = 0 + endif + call QUIP_FoX_get_value(attributes, 'nfc3_indep', value, status) + if (status == 0) then + read (value, *) parse_ip%nfc3_indep + else + parse_ip%nfc3_indep = parse_ip%nfc3 + endif + + call QUIP_FoX_get_value(attributes, 'nfc4', value, status) + if (status == 0) then + read (value, *) parse_ip%nfc4 + else + parse_ip%nfc4 = 0 + endif + call QUIP_FoX_get_value(attributes, 'nfc4_indep', value, status) + if (status == 0) then + read (value, *) parse_ip%nfc4_indep + else + parse_ip%nfc4_indep = parse_ip%nfc4 + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + endif ! parse_in_ip + elseif (parse_in_ip .and. name == 'FC4') then + + call QUIP_FoX_get_value(attributes, "atnum_i", value, status) + if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find atnum_i") + read (value, *) atnum_i + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find atnum_j") + read (value, *) atnum_j + call QUIP_FoX_get_value(attributes, "fc_i", value, status) + if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find fc_i") + read (value, *) fc_i + + ! if (all(parse_ip%atomic_num /= atnum_i)) then + ! ti_a = minloc(parse_ip%atomic_num) + ! parse_ip%atomic_num(ti_a(1)) = atnum_i + ! endif + ! if (all(parse_ip%atomic_num /= atnum_j)) then + ! ti_a = minloc(parse_ip%atomic_num) + ! parse_ip%atomic_num(ti_a(1)) = atnum_j + ! endif + ! if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + ! allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + ! parse_ip%type_of_atomic_num = 0 + ! do ti=1, parse_ip%n_types + ! if (parse_ip%atomic_num(ti) > 0) & + ! parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + ! end do + + ! ti = parse_ip%type_of_atomic_num(atnum_i) + ! tj = parse_ip%type_of_atomic_num(atnum_j) + + ! call QUIP_FoX_get_value(attributes, "r0", value, status) + ! if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find r0") + ! read (value, *) parse_ip%r0(ti,tj,fc_i) + ! call QUIP_FoX_get_value(attributes, "phi2", value, status) + ! if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find phi2") + ! read (value, *) parse_ip%phi2(ti,tj,fc_i) + ! call QUIP_FoX_get_value(attributes, "phi3", value, status) + ! if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find phi3") + ! read (value, *) parse_ip%phi3(ti,tj,fc_i) + ! call QUIP_FoX_get_value(attributes, "phi4", value, status) + ! if (status /= 0) call system_abort ("IPModel_FC4_read_params_xml cannot find phi4") + ! read (value, *) parse_ip%phi4(ti,tj,fc_i) + + ! if (ti /= tj) then + ! parse_ip%r0(tj,ti,fc_i) = parse_ip%r0(ti,tj,fc_i) + ! parse_ip%phi2(tj,ti,fc_i) = parse_ip%phi2(ti,tj,fc_i) + ! parse_ip%phi3(tj,ti,fc_i) = parse_ip%phi3(ti,tj,fc_i) + ! parse_ip%phi4(tj,ti,fc_i) = parse_ip%phi4(ti,tj,fc_i) + ! endif + + endif ! parse_in_ip .and. name = 'FC4' + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'FC4_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_FC4_read_params_xml(this, param_str) + type(IPModel_FC4), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_FC4_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_FC4_read_params_xml + + +subroutine IPModel_FC4_Print(this, file) + type(IPModel_FC4), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_FC4 : FC4 Potential", file=file) + call Print("IPModel_FC4 : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + call Print("IPModel_FC4 : label = " // this%label, file=file) + + do ti=1, this%n_types + call Print ("IPModel_FC4 : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_FC4 : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_FC4_Print + +function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) + character(len=*), intent(in) :: args_str + character(len=*), intent(out) :: extra_calcs_list(:) + integer :: n_extra_calcs + + character(len=STRING_LENGTH) :: extra_calcs_str + type(Dictionary) :: params + + n_extra_calcs = 0 + call initialise(params) + call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") + if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then + if (len_trim(extra_calcs_str) > 0) then + call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") + end if + end if + call finalise(params) + +end function parse_extra_calcs + +! subroutine read_fc2(nfc2, file, igroup_2, iatomterm_2, ixyzterm_2, ampterm_2, fcs_2) +! character(len=*), intent(in) :: file +! integer, intent(in) :: nfc2 + +! integer, intent(out) :: igroup_2(nfc2) +! integer, intent(out) :: iatomterm_2(2,nfc2) +! integer, intent(out) :: ixyzterm_2(2,nfc2) +! real(dp), intent(out) :: fcs_2(nfc2) +! real(dp), intent(out) :: ampterm_2(nfc2) + +! integer t,i ! ,mx +! character(len=999) line + +! integer, parameter :: iunit = 1111 +! open(unit=iunit, file=file) + +! read(iunit,'(a)') line +! do i=1,nfc2 +! read (iunit,*,err=92) t,igroup_2(i), & +! iatomterm_2(1,i),ixyzterm_2(1,i),iatomterm_2(2,i),ixyzterm_2(2,i), & +! fcs_2(i),ampterm_2(i) +! end do +! return +! 92 call system_abort("IPModel_FC4_Initialise_str: End of file while reading second order force constants from "//file//", after t="//t) +! end subroutine read_fc2 + +subroutine read_fcs(rank, nfc, file, igroup, iatomterm, ixyzterm, ampterm, fcs) + integer, intent(in) :: rank, nfc + character(len=*), intent(in) :: file + + integer, intent(out) :: igroup(nfc) + integer, intent(out) :: iatomterm(rank,nfc) + integer, intent(out) :: ixyzterm(rank,nfc) + real(dp), intent(out) :: fcs(nfc) + real(dp), intent(out) :: ampterm(nfc) + + integer t,i,r ! ,mx + character(len=999) line + + integer, parameter :: iunit = 1111 + + open(unit=iunit, file=file) + + read (iunit,'(a)') line + read (iunit,*,err=92,end=92) (t,igroup(i), (iatomterm(r,i), ixyzterm(r,i), r=1,rank), fcs(i), ampterm(i), i=1,nfc) + return +92 call system_abort("IPModel_FC4_Initialise_str: End of file while reading force constants from "//file//", after t="//t) +end subroutine read_fcs + +subroutine fill_findatom_sc_array(findatom_sc_array, ntau, mn, mx, at) + integer, intent(in) :: ntau, mn(3), mx(3) + type(Atoms), intent(in) :: at ! check: should have 'n(3)' and 'tau' field + integer, intent(out) :: findatom_sc_array(ntau,mn(1):mx(1),mn(2):mx(2),mn(3):mx(3)) + + integer, pointer :: prim_index(:) + integer, pointer :: cell_offset(:,:) + + integer i + + if(.not.assign_pointer(at, "prim_index", prim_index)) & + call system_abort("IPModel_FC4 requires 'prim_index' field") + if(.not.assign_pointer(at, "cell_offset", cell_offset)) & + call system_abort("IPModel_FC4 requires 'cell_offset' field") + + findatom_sc_array = -1 + do i=1,at%N + findatom_sc_array(prim_index(i), cell_offset(1,i), cell_offset(2,i), cell_offset(3,i)) = i + end do +end subroutine fill_findatom_sc_array + +function findatom_sc(this, tau, n, at) + integer findatom_sc + type(IPModel_FC4), intent(in) :: this + integer, intent(in) :: tau, n(3) ! the primitive cell index and offset + type(Atoms), intent(in) :: at + integer nwrap(3), nsc(3), tau_sc_idx + real(dp) :: wrap(3), prim_cell_pos(3), prim_cell(3,3), inv_prim_cell(3,3), tau_prim(3), tau_frac(3), tau_frac_remap(3), n_frac(3) + + namelist/NMLDEBUG/tau,n,prim_cell,inv_prim_cell,tau_sc_idx,tau_prim,tau_frac,tau_frac_remap,prim_cell_pos,wrap,nwrap + +! Common case: just see if it is in the array + if (all(n.ge.this%sc_min.and.n.le.this%sc_max)) then + findatom_sc = this%findatom_sc_array(tau,n(1),n(2),n(3)) + if (findatom_sc.ge.0) return + end if + +! Otherwise, try to wrap it + + ! the primitive cell + prim_cell = this%ideal_struct%lattice + inv_prim_cell = this%ideal_struct%g + + tau_sc_idx = this%findatom_sc_array(tau,0,0,0) + tau_prim = this%ideal_struct%pos(:,tau_sc_idx) + + ! express the primitive cell we asked for as a fractional + ! coordinates of the simulation box. + tau_frac = matmul(this%inv_superlattice, matmul(prim_cell, n) + tau_prim) + + ! remap to [0,1) + tau_frac_remap = modulo(tau_frac, 1.0_dp) + + prim_cell_pos = matmul(this%superlattice, tau_frac_remap) - tau_prim + + ! find the offset of the primitive cell this location coresponds to + wrap = matmul(inv_prim_cell, prim_cell_pos) + if (any(abs(modulo(wrap+0.5_dp,1.0_dp)-0.5_dp).gt.1D-6)) then + write (*,'(2(3F18.12,x))') modulo(wrap,1.0_dp), wrap + call system_abort("Findatom_sc: got fractional box!") + endif + + nwrap = nint(wrap) + + findatom_sc = this%findatom_sc_array(tau,nwrap(1),nwrap(2),nwrap(3)) + + ! express in terms of primitive cell coords + + if (findatom_sc < 0) then + write (*,nml=NMLDEBUG) + call system_abort("Findatom_sc: requested atom tau=" // tau & + // ", n=" // n // " does not exist in the supercell") + end if + +end function findatom_sc + +end module IPModel_FC4_module diff --git a/src/Potentials/IPModel_FS.F90 b/src/Potentials/IPModel_FS.F90 new file mode 100644 index 0000000000..9a09e19a2c --- /dev/null +++ b/src/Potentials/IPModel_FS.F90 @@ -0,0 +1,589 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_FS module +!X +!% Module for Finnis-Sinclair embedded-atom potential +!% (Ref. Philosophical Magazine A, {\bf 50}, 45 (1984)). +!% +!% The IPModel_FS object contains all the parameters read from a +!% 'FS_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_FS_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_VERBOSE, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_FS +type IPModel_FS + integer :: n_types = 0 !% Number of atomic types. + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + real(dp), allocatable :: c(:,:), c0(:,:), c1(:,:), c2(:,:) + real(dp), allocatable :: A(:,:), beta(:,:), d(:,:) + + character(len=STRING_LENGTH) :: label + +end type IPModel_FS + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_FS), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_FS_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_FS_Finalise +end interface Finalise + +interface Print + module procedure IPModel_FS_Print +end interface Print + +interface Calc + module procedure IPModel_FS_Calc +end interface Calc + +contains + +subroutine IPModel_FS_Initialise_str(this, args_str, param_str) + type(IPModel_FS), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label = '' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FS_Initialise_str args_str')) then + call system_abort("IPModel_FS_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_FS_read_params_xml(this, param_str) + +! Two cutoff radius: this%d > this%c + this%cutoff = maxval(this%d) + +end subroutine IPModel_FS_Initialise_str + +subroutine IPModel_FS_Finalise(this) + type(IPModel_FS), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%c)) deallocate(this%c) + if (allocated(this%c0)) deallocate(this%c0) + if (allocated(this%c1)) deallocate(this%c1) + if (allocated(this%c2)) deallocate(this%c2) + if (allocated(this%A)) deallocate(this%A) + if (allocated(this%beta)) deallocate(this%beta) + if (allocated(this%d)) deallocate(this%d) + + this%n_types = 0 + this%label = '' + +end subroutine IPModel_FS_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_FS_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_FS), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer i, ji, j, ti, tj + real(dp) :: rij(3), rij_mag, drij(3) + real(dp) :: phi_tot, sqrt_phi_tot + real(dp) :: Ui, dU + + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + ! private variables for open-mp + real(dp) :: private_virial(3,3), private_e, virial_i(3,3) + real(dp), allocatable, dimension(:,:) :: private_f + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_FS_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_FS_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_FS_Calc', error) + local_virial = 0.0_dp + endif + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_FS_Calc args_str')) then + RAISE_ERROR("IPModel_FS_Calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then + RAISE_ERROR("IPModel_FS_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + else + do_rescale_r = .false. + do_rescale_E = .false. + endif + + if (do_rescale_r) call print('IPModel_Tersoff_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) + if (do_rescale_E) call print('IPModel_Tersoff_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) + +!$omp parallel private(i,ji,j,ti,tj,phi_tot,sqrt_phi_tot,dU,Ui,drij,rij_mag,private_virial, virial_i,private_f,private_e) + + if (present(e)) private_e = 0.0_dp + if (present(virial)) private_virial = 0.0_dp + if (present(f)) then + allocate(private_f(3,at%N)) + private_f = 0.0_dp + endif + +!$omp do + do i=1, at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + phi_tot = 0.0_dp + + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, rij_mag) + if (rij_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) rij_mag = rij_mag*r_scale + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + phi_tot = phi_tot + this%A(ti,tj) * this%A(ti,tj) * phi_ij(this, ti, tj, rij_mag) + enddo + + sqrt_phi_tot = dsqrt(phi_tot) + + if (present(e)) then + private_e = private_e - sqrt_phi_tot + endif + if (present(local_e)) then + local_e(i) = local_e(i) - sqrt_phi_tot + endif + + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, rij_mag, cosines = drij) + if (rij_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) rij_mag = rij_mag*r_scale + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (present(e) .or. present(local_e)) then + Ui = 0.5_dp * Vij(this, ti, tj, rij_mag) + if (present(local_e)) then + local_e(i) = local_e(i) + Ui + endif + if (present(e)) then + private_e = private_e + Ui + endif + endif + + if (present(f) .or. present(virial)) then + + dU = 0.5_dp * dVij(this, ti, tj, rij_mag) - this%A(ti,tj) * this%A(ti,tj) * dphi_ij(this, ti, tj, rij_mag) / 2.0_dp / sqrt_phi_tot + + if (present(f)) then + private_f(:,i) = private_f(:,i) + dU * drij(:) + private_f(:,j) = private_f(:,j) - dU * drij(:) + endif + if (present(virial).or.present(local_virial)) virial_i = dU*(drij .outer. drij)*rij_mag + if (present(virial)) private_virial = private_virial - virial_i + if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) + endif + + end do + + end do + +!$omp critical + if(present(e)) e = e + private_e + if(present(virial)) virial = virial + private_virial + if(present(f)) f = f + private_f +!$omp end critical + + if(allocated(private_f)) deallocate(private_f) +!$omp end parallel + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) call sum_in_place(mpi, f) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(local_virial)) call sum_in_place(mpi, local_virial) + endif + + if (do_rescale_r) then + if (present(f)) f = f*r_scale + end if + + if (do_rescale_E) then + if (present(e)) e = e*E_scale + if (present(local_e)) local_e = local_e*E_scale + if (present(f)) f = f*E_scale + if (present(virial)) virial=virial*E_scale + if (present(local_virial)) local_virial=local_virial*E_scale + end if + +end subroutine IPModel_FS_Calc + +function Vij(this, ti, tj, r) + type(IPModel_FS), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r + real(dp) :: Vij + + if ((r .feq. 0.0_dp) .or. (r > this%c(ti,tj))) then + Vij = 0.0 + return + endif + + Vij = (r - this%c(ti,tj))*(r - this%c(ti,tj))*(this%c0(ti,tj) + r * this%c1(ti,tj) + r * r * this%c2(ti,tj) ) + +end function Vij + + +function dVij(this, ti, tj, r) + type(IPModel_FS), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r + real(dp) :: dVij + + if ((r .feq. 0.0_dp) .or. (r > this%c(ti,tj))) then + dVij = 0.0 + return + endif + + dVij = 2.0_dp * (r - this%c(ti,tj))*(this%c0(ti,tj) + r * this%c1(ti,tj) + r * r * this%c2(ti,tj)) + & + (r - this%c(ti,tj))*(r - this%c(ti,tj))*(this%c1(ti,tj) + 2.0_dp * r * this%c2(ti,tj)) +end function dVij + + +function phi_ij(this, ti, tj, r) + type(IPModel_FS), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r + real(dp) :: num + real(dp) :: phi_ij + + if ((r .feq. 0.0_dp) .or. (r > this%d(ti,tj))) then + phi_ij = 0.0 + return + endif + + num = r - this%d(ti,tj) + phi_ij = num * num + this%beta(ti,tj) * (num * num * num) / this%d(ti,tj) + +end function phi_ij + +function dphi_ij(this, ti, tj, r) + type(IPModel_FS), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: r + real(dp) :: num + real(dp) :: dphi_ij + + if ((r .feq. 0.0_dp) .or. (r > this%d(ti,tj))) then + dphi_ij = 0.0 + return + endif + + num = r - this%d(ti,tj) + dphi_ij = 2.0_dp * num + 3.0_dp * this%beta(ti,tj) * (num * num) / this%d(ti,tj) + +end function dphi_ij + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + integer ti, tj + + if (name == 'FS_params') then ! new FS stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in FS_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%c(parse_ip%n_types,parse_ip%n_types)) + parse_ip%c = 0.0_dp + allocate(parse_ip%c0(parse_ip%n_types,parse_ip%n_types)) + parse_ip%c0 = 0.0_dp + allocate(parse_ip%c1(parse_ip%n_types,parse_ip%n_types)) + parse_ip%c1 = 0.0_dp + allocate(parse_ip%c2(parse_ip%n_types,parse_ip%n_types)) + parse_ip%c2 = 0.0_dp + allocate(parse_ip%A(parse_ip%n_types,parse_ip%n_types)) + parse_ip%A = 0.0_dp + allocate(parse_ip%beta(parse_ip%n_types,parse_ip%n_types)) + parse_ip%beta = 0.0_dp + allocate(parse_ip%d(parse_ip%n_types,parse_ip%n_types)) + parse_ip%d = 0.0_dp + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "type1", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find type1") + read (value, *) ti + call QUIP_FoX_get_value(attributes, "type2", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find type2") + read (value, *) tj + + call QUIP_FoX_get_value(attributes, "c", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find c") + read (value, *) parse_ip%c(ti,tj) + call QUIP_FoX_get_value(attributes, "c0", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find c0") + read (value, *) parse_ip%c0(ti,tj) + call QUIP_FoX_get_value(attributes, "c1", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find c1") + read (value, *) parse_ip%c1(ti,tj) + call QUIP_FoX_get_value(attributes, "c2", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find c2") + read (value, *) parse_ip%c2(ti,tj) + call QUIP_FoX_get_value(attributes, "A", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find A") + read (value, *) parse_ip%A(ti,tj) + call QUIP_FoX_get_value(attributes, "beta", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find beta") + read (value, *) parse_ip%beta(ti,tj) + call QUIP_FoX_get_value(attributes, "d", value, status) + if (status /= 0) call system_abort ("IPModel_FS_read_params_xml cannot find d") + read (value, *) parse_ip%d(ti,tj) + + if (ti /= tj) then + parse_ip%c(tj,ti) = parse_ip%c(ti,tj) + parse_ip%c0(tj,ti) = parse_ip%c0(ti,tj) + parse_ip%c1(tj,ti) = parse_ip%c1(ti,tj) + parse_ip%c2(tj,ti) = parse_ip%c2(ti,tj) + parse_ip%A(tj,ti) = parse_ip%A(ti,tj) + parse_ip%beta(tj,ti) = parse_ip%beta(ti,tj) + parse_ip%d(tj,ti) = parse_ip%d(ti,tj) + end if + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'FS_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_FS_read_params_xml(this, param_str) + type(IPModel_FS), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_FS_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_FS_read_params_xml + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X printing +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_FS_Print (this, file) + type(IPModel_FS), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_FS : Finnis-Sinclair", file=file) + call Print("IPModel_FS : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_FS : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + do tj=1, this%n_types + call Print ("IPModel_FS : interaction " // ti // " " // tj // " c, c0, c1, c2 " // this%c(ti,tj) // " " // & + this%c0(ti,tj) // " " // this%c1(ti,tj) // " " // this%c2(ti,tj) // " " // & + " d " // this%d(ti,tj) // " " // & + " A " // this%a(ti,tj) // " " // " beta " // & + this%beta(ti,tj), file=file) + end do + call verbosity_pop() + end do + +end subroutine IPModel_FS_Print + +end module IPModel_FS_module diff --git a/src/Potentials/IPModel_FX.F90 b/src/Potentials/IPModel_FX.F90 new file mode 100644 index 0000000000..ba660c0ba6 --- /dev/null +++ b/src/Potentials/IPModel_FX.F90 @@ -0,0 +1,367 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_FX +!X +!% polarisable water model +!% G. S. Fanourgakis and S. S. Xantheas, Journal of Chemical Physics 128, 074506 (2008) +!% This is a wrapper for a code downloaded from http://www.pnl.gov/science/ttm3f.asp +!% WARNING: it does not deal with periodic boundary conditions +!% UNITS: KCal/mol for energies and Angstroms for distance for the original FX code, of course the QUIP calculator converts to eVs. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_FX_module + +use error_module +use system_module, only : dp, inoutput, print, operator(//) +use units_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use spline_module +use atoms_types_module +use atoms_module +use topology_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_FX +type IPModel_FX + real(dp) :: cutoff = 2.0_dp + logical :: return_one_body = .false. + logical :: return_two_body = .false. + real(dp) :: two_body_weight_roo = 0.0_dp + real(dp) :: two_body_weight_delta = 0.0_dp + logical :: do_two_body_weight = .false. + type(Spline) :: two_body_weight + logical :: OHH_ordercheck = .true. + real(dp) :: E_scale + ! some modifiable FX parameters, defaults are from the FX source code + real(dp) :: polarM=1.444_dp + real(dp) :: vdwC=-0.72298855E+03_dp,vdwD=0.10211829E+06_dp, vdwE=0.37170376E+01_dp +end type IPModel_FX + + +interface Initialise + module procedure IPModel_FX_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_FX_Finalise +end interface Finalise + +interface Print + module procedure IPModel_FX_Print +end interface Print + +interface Calc + module procedure IPModel_FX_Calc +end interface Calc + +contains + +subroutine IPModel_FX_Initialise_str(this, args_str, param_str, error) + type(IPModel_FX), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + call Finalise(this) + +#ifndef HAVE_FX + RAISE_ERROR('IPModel_FX_Calc: FX model was not compiled in. Check the HAVE_FX flag in the Makefiles.', error) +#else + + call initialise(params) + call param_register(params, 'return_two_body', 'F', this%return_two_body, help_string="if set, return the two_body energy and force as the main return data") + call param_register(params, 'return_one_body', 'F', this%return_one_body, help_string="if set, return the one_body energy and force as the main return data") + call param_register(params, 'two_body_weight_roo', '0.0', this%two_body_weight_roo, has_value_target=this%do_two_body_weight, help_string="if set, apply weight function to 2-body energy and force based on O-O distance. For a positive two_body_weight_delta, weight is 1 for rOO < two_body_weight_roo-two_body_weight_delta and weight is 0 for rOO > two_body_weight_roo+two_body_weight_delta") + call param_register(params, 'two_body_weight_delta', '0.25', this%two_body_weight_delta, help_string="width of weighting function for two_body energy and force based on O-O distance. For weighting to take effect, two_body_weight_roo needs to be explicitly set. For a positive two_body_weight_delta, weight is 1 for rOO < two_body_weight_roo-two_body_weight_delta and weight is 0 for rOO > two_body_weight_roo+two_body_weight_delta") + call param_register(params, 'OHH_ordercheck', 'T', this%OHH_ordercheck, help_string="if FALSE, skip transforming atomic order to OHHOHHOHH... and assume atoms are in that order. This also skips cutoff checking for OH bonds. default: TRUE") + call param_register(params, 'E_scale', '1.0', this%E_scale, 'Scale the potential by this factor') + call param_register(params, 'polarM', '1.444', this%polarM, help_string="polarisability on the M site") + call param_register(params, 'vdwC', '-0.72298855E+03', this%vdwC, help_string="vdwC parameter") + call param_register(params, 'vdwD', '0.10211829E+06', this%vdwD, help_string="vdwD parameter") + call param_register(params, 'vdwE', '0.37170376E+01', this%vdwE, help_string="vdwE parameter") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FX_Initialise args_str')) then + RAISE_ERROR("IPModel_FX_Init failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if(this%do_two_body_weight) then + call initialise(this%two_body_weight, (/this%two_body_weight_roo - this%two_body_weight_delta, this%two_body_weight_roo + this%two_body_weight_delta/), (/1.0_dp, 0.0_dp/), 0.0_dp, 0.0_dp) + end if +#endif +end subroutine IPModel_FX_Initialise_str + +subroutine IPModel_FX_Finalise(this) + type(IPModel_FX), intent(inout) :: this +end subroutine IPModel_FX_Finalise + + +subroutine IPModel_FX_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_FX), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), dimension(3,at%N) :: RR, dRR + real(dp) :: energy + integer, dimension(at%N) :: rindex + integer :: i, j, k, kk, Oi, Oj + + type(Dictionary) :: params + logical :: has_atom_mask_name, do_one_body, do_two_body + character(STRING_LENGTH) :: atom_mask_name, one_body_name, two_body_name + logical :: OHH_ordercheck = .true., do_OHH_ordercheck + + integer, dimension(:,:), allocatable :: water_monomer_index + real(dp), allocatable :: one_body_energy(:), one_body_force(:,:), two_body_force(:,:) + real(dp) :: watpos(3,3), wat2pos(3,6), watRR(3,3), watdRR(3,3), wat2RR(3,6), wat2dRR(3,6), wat2_force(3,6) + real(dp) :: two_body_energy, diff_OiOj(3), watE, wat2E, two_body_energy_ij + integer :: wat_rindex(3), wat2_rindex(6), watZ(3), wat2Z(6) + real(dp):: weight, dweight(3), rOiOj + + INIT_ERROR(error) + +#ifndef HAVE_FX + RAISE_ERROR('IPModel_FX_Calc: FX model was not compiled in. Check the HAVE_FX flag in the Makefiles.', error) +#else + + if(present(local_e)) then + RAISE_ERROR('IPModel_FX_Calc: local_e calculation requested but not supported yet.', error) + end if + if(present(virial)) then + RAISE_ERROR('IPModel_FX_Calc: virial calculation requested but not supported yet.', error) + end if + if (present(local_virial)) then + RAISE_ERROR("IPModel_FX_Calc: local_virial calculation requested but not supported yet.", error) + endif + + if(.not. present(e) .and. .not. present(f)) return ! nothing to do + + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy: nb326 $") + call param_register(params, 'one_body', 'one_body', one_body_name, has_value_target=do_one_body, help_string="compute one-body terms of the cluster expansion and store it using this name") + call param_register(params, 'two_body', 'two_body', two_body_name, has_value_target=do_two_body, help_string="compute two-body terms of the cluster expansion and store it using this name") + call param_register(params, 'OHH_ordercheck', 'T', OHH_ordercheck, has_value_target=do_OHH_ordercheck, help_string="if FALSE, skip transforming atomic order to OHHOHHOHH... and assume atoms are in that order. This also skips cutoff checking for OH bonds.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_FX_Calc args_str')) then + RAISE_ERROR("IPModel_FX_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_FX_Calc: atom_mask_name found, but not supported', error) + endif + endif + + + if(do_OHH_ordercheck) then + do_OHH_ordercheck = OHH_ordercheck + else + do_OHH_ordercheck = this%OHH_ordercheck + end if + + call nttm3f_readXYZ(at%N/3, at%Z, at%pos, RR, rindex, do_OHH_ordercheck) + call ttm3f(at%N/3,RR, dRR, energy, this%polarM, this%vdwC, this%vdwD, this%vdwE) + + + if(present(e)) e=energy * KCAL_MOL * this%E_scale + if(present(f)) then + do i=1,at%N + f(:,i)=-dRR(:,rindex(i)) * KCAL_MOL * this%E_scale + end do + end if + + ! cluster expansion + + + if(do_one_body .or. do_two_body .or. this%return_one_body .or. this%return_two_body) then + + allocate(water_monomer_index(3,at%N/3)) + + call find_water_monomer(at,water_monomer_index, OHH_ordercheck=do_OHH_ordercheck,error=error) + PASS_ERROR(error) + + allocate(one_body_energy(at%N/3)) + allocate(one_body_force(3,at%N)) + ! compute monomer energies and forces + do i=1,at%N/3 + Oi = water_monomer_index(1,i) + watpos(:,1) = at%pos(:,Oi) + watZ(1) = 8 ! Oxygen + watpos(:,2) = at%pos(:,Oi)+diff_min_image(at, Oi, water_monomer_index(2,i)) + watpos(:,3) = at%pos(:,Oi)+diff_min_image(at, Oi, water_monomer_index(3,i)) + watZ(2:3) = 1 ! Hydrogens + + call nttm3f_readXYZ(1, watZ, watpos, watRR, wat_rindex, do_OHH_ordercheck) + call ttm3f(1, watRR, watdRR, watE, this%polarM, this%vdwC, this%vdwD, this%vdwE) + one_body_energy(i) = watE*KCAL_MOL*this%E_scale + do k=1,3 + one_body_force(:,water_monomer_index(k,i)) = -watdRR(:,wat_rindex(k)) * KCAL_MOL * this%E_scale + end do + end do + + ! if one body terms were asked for, store them + if(this%return_one_body) then + if(present(e)) then + e = sum(one_body_energy) + end if + if(present(f)) then + f = one_body_force + end if + end if + + if(do_one_body) then + call set_value(at%params, trim(one_body_name)//"_energy", sum(one_body_energy)) + call add_property(at, trim(one_body_name)//"_force", one_body_force) + end if + + ! compute dimer energies and forces + if(do_two_body .or. this%return_two_body) then + allocate(two_body_force(3,at%N)) + two_body_energy = 0.0_dp + two_body_force = 0.0_dp + do i=1,at%N/3 + do j=i+1,at%N/3 + Oi = water_monomer_index(1,i) + Oj = water_monomer_index(1,j) + wat2pos(:,1) = at%pos(:,Oi) + wat2Z(1) = 8 ! first Oxygen + wat2pos(:,2) = at%pos(:,Oi) + diff_min_image(at, Oi, water_monomer_index(2,i)) + wat2pos(:,3) = at%pos(:,Oi) + diff_min_image(at, Oi, water_monomer_index(3,i)) + wat2Z(2:3) = 1 ! first Hydrogens + diff_OiOj = diff_min_image(at, Oi, Oj) + wat2pos(:,4) = at%pos(:,Oi) + diff_OiOj + wat2Z(4) = 8 ! second Oxygen + wat2pos(:,5) = at%pos(:,Oi) + diff_OiOj+diff_min_image(at, Oj, water_monomer_index(2,j)) + wat2pos(:,6) = at%pos(:,Oi) + diff_OiOj+diff_min_image(at, Oj, water_monomer_index(3,j)) + wat2Z(5:6) = 1 ! first Hydrogens + + call nttm3f_readXYZ(2, wat2Z, wat2pos, wat2RR, wat2_rindex, do_OHH_ordercheck) + call ttm3f(2, wat2RR, wat2dRR, wat2E, this%polarM, this%vdwC, this%vdwD, this%vdwE) + + rOiOj = norm(diff_OiOj) + if(this%do_two_body_weight) then + weight = spline_value(this%two_body_weight, rOiOj) + dweight = spline_deriv(this%two_body_weight, rOiOj) + else + weight = 1.0_dp + dweight = 0.0_dp + end if + + two_body_energy_ij = (wat2E * KCAL_MOL * this%E_scale - one_body_energy(i) - one_body_energy(j)) + two_body_energy = two_body_energy + two_body_energy_ij*weight + + do k=1,6 + wat2_force(:,k) = -wat2dRR(:,wat2_rindex(k)) * KCAL_MOL * this%E_scale + end do + do k=1,3 + kk = water_monomer_index(k, i) + two_body_force(:,kk) = two_body_force(:,kk) + (wat2_force(:,k)-one_body_force(:,kk))*weight + if(k==1) two_body_force(:,kk) = two_body_force(:,kk) + two_body_energy_ij*dweight*diff_OiOj/rOiOj + + kk = water_monomer_index(k, j) + two_body_force(:,kk) = two_body_force(:,kk) + (wat2_force(:,3+k)-one_body_force(:,kk))*weight + if(k==1) two_body_force(:,kk) = two_body_force(:,kk) - two_body_energy_ij*dweight*diff_OiOj/rOiOj + end do + end do + end do + + if(this%return_two_body) then + if(present(e)) then + e = two_body_energy + end if + if(present(f)) then + f = two_body_force + end if + end if + + ! store two-body terms + if(do_two_body) then + call set_value(at%params, trim(two_body_name)//"_energy", two_body_energy) + call add_property(at, trim(two_body_name)//"_force", two_body_force) + end if + end if + endif + +#endif + +end subroutine IPModel_FX_Calc + + +subroutine IPModel_FX_Print(this, file) + type(IPModel_FX), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + call Print("IPModel_FX : ", file=file) + +#ifndef HAVE_FX + call Print(" not compiled in. Check the HAVE_FX flag in the Makefiles.", file=file) +#else + call print("polarisable model for water", file=file) + call print("by G. S. Fanourgakis and S. S. Xantheas", file=file) + call print("Journal of Chemical Physics 128, 074506 (2008)", file=file) + if(this%return_two_body) then + call print("Returning 2-body term as a result of calc()", file=file) + end if + if(this%return_one_body) then + call print("Returning 1-body term as a result of calc()", file=file) + end if + if(this%do_two_body_weight) then + call print("Two-body term is weighted with parameters x0="//this%two_body_weight_roo//" delta="//this%two_body_weight_delta, file=file) + end if + if(this%OHH_ordercheck) then + call print("Performing reordering of atoms into OHHOHH.. order and checking O-H cutoff distances") + else + call print("SKIPPING reordering of atoms into OHHOHH.. order and checking O-H cutoff distances") + end if +#endif +end subroutine IPModel_FX_Print + + +end module IPModel_FX_module diff --git a/src/Potentials/IPModel_GAP.F90 b/src/Potentials/IPModel_GAP.F90 new file mode 100644 index 0000000000..1352d5c6dd --- /dev/null +++ b/src/Potentials/IPModel_GAP.F90 @@ -0,0 +1,987 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_GAP module +!X +!% Module for Gaussian Approximation Potential. +!% +!% The IPModel_GAP object contains all the parameters read from a +!% 'GAP_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_GAP_module + +use error_module +use system_module, only : dp, inoutput, string_to_int, reallocate, system_timer , print, PRINT_NERD +use dictionary_module +use periodictable_module, only: total_elements +use extendable_str_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +#ifdef HAVE_GAP +use descriptors_module +use gp_predict_module +#endif + +implicit none + +private + +include 'IPModel_interface.h' + +#ifdef GAP_VERSION + integer, parameter :: gap_version = GAP_VERSION +#else + integer, parameter :: gap_version = 0 +#endif + +! this stuff is here for now, but it should live somewhere else eventually +! lower down in the GP + +public :: IPModel_GAP + +type IPModel_GAP + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + real(dp) :: E_scale = 0.0_dp !% scale factor for the potential + + ! bispectrum parameters + integer :: j_max = 0 + real(dp) :: z0 = 0.0_dp + integer :: n_species = 0 !% Number of atomic types. + integer, dimension(:), allocatable :: Z + real(dp), dimension(total_elements) :: z_eff = 0.0_dp + real(dp), dimension(total_elements) :: w_Z = 1.0_dp + real(dp), dimension(total_elements) :: e0 = 0.0_dp + + ! qw parameters + integer :: qw_l_max = 0 + integer :: qw_f_n = 0 + logical :: qw_do_q = .false. + logical :: qw_do_w = .false. + real(dp), allocatable :: qw_cutoff(:) + integer, allocatable :: qw_cutoff_f(:) + real(dp), allocatable :: qw_cutoff_r1(:) + + integer :: cosnx_l_max, cosnx_n_max + + real(dp), dimension(:), allocatable :: pca_mean, NormFunction + real(dp), dimension(:,:), allocatable :: pca_matrix, RadialTransform + + logical :: do_pca = .false. + + character(len=256) :: coordinates !% Coordinate system used in GAP database + + character(len=STRING_LENGTH) :: label + +#ifdef HAVE_GAP + type(gpSparse) :: my_gp + type(descriptor), dimension(:), allocatable :: my_descriptor +#endif + logical :: initialised = .false. + type(extendable_str) :: command_line + integer :: xml_version + +end type IPModel_GAP + +logical, private :: parse_in_ip, parse_in_gap_data, parse_matched_label, parse_in_ip_done +integer, private :: parse_n_row, parse_cur_row + +type(IPModel_GAP), private, pointer :: parse_ip +type(extendable_str), save :: parse_cur_data + +interface Initialise + module procedure IPModel_GAP_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_GAP_Finalise +end interface Finalise + +interface Print + module procedure IPModel_GAP_Print +end interface Print + +interface Calc + module procedure IPModel_GAP_Calc +end interface Calc + +contains + +subroutine IPModel_GAP_Initialise_str(this, args_str, param_str) + type(IPModel_GAP), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + + integer :: i_coordinate + real(dp) :: gap_variance_regularisation + logical :: has_gap_variance_regularisation + + call Finalise(this) + + ! now initialise the potential +#ifndef HAVE_GAP + call system_abort('IPModel_GAP_Initialise_str: must be compiled with HAVE_GAP') +#else + + call initialise(params) + this%label='' + + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'E_scale', '1.0', this%E_scale, help_string="rescaling factor for the potential") + call param_register(params, 'gap_variance_regularisation', '0.001', gap_variance_regularisation, & + has_value_target=has_gap_variance_regularisation, help_string="Regularisation value for variance calculation.") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Initialise_str args_str')) & + call system_abort("IPModel_GAP_Initialise_str failed to parse label from args_str="//trim(args_str)) + call finalise(params) + + call IPModel_GAP_read_params_xml(this, param_str) + call gp_readXML(this%my_gp, param_str,label=trim(this%label)) + if (.not. this%my_gp%fitted) call system_abort('IPModel_GAP_Initialise_str: GAP model has not been fitted.') + allocate(this%my_descriptor(this%my_gp%n_coordinate)) + + this%cutoff = 0.0_dp + do i_coordinate = 1, this%my_gp%n_coordinate + call concat(this%my_gp%coordinate(i_coordinate)%descriptor_str," xml_version="//this%xml_version) + call initialise(this%my_descriptor(i_coordinate),string(this%my_gp%coordinate(i_coordinate)%descriptor_str)) + this%cutoff = max(this%cutoff,cutoff(this%my_descriptor(i_coordinate))) + if( has_gap_variance_regularisation) call gpCoordinates_initialise_variance_estimate(this%my_gp%coordinate(i_coordinate), gap_variance_regularisation) + enddo + +#endif + +end subroutine IPModel_GAP_Initialise_str + +subroutine IPModel_GAP_Finalise(this) + type(IPModel_GAP), intent(inout) :: this +#ifdef HAVE_GAP + if (allocated(this%qw_cutoff)) deallocate(this%qw_cutoff) + if (allocated(this%qw_cutoff_f)) deallocate(this%qw_cutoff_f) + if (allocated(this%qw_cutoff_r1)) deallocate(this%qw_cutoff_r1) + + if (allocated(this%Z)) deallocate(this%Z) + + if (this%my_gp%initialised) call finalise(this%my_gp) + + + this%cutoff = 0.0_dp + this%j_max = 0 + this%z0 = 0.0_dp + this%n_species = 0 + this%z_eff = 0.0_dp + this%w_Z = 1.0_dp + this%qw_l_max = 0 + this%qw_f_n = 0 + this%qw_do_q = .false. + this%qw_do_w = .false. + + this%coordinates = '' + + this%label = '' + this%initialised = .false. +#endif + + call finalise(this%command_line) + +end subroutine IPModel_GAP_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_GAP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_GAP), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + +#ifdef HAVE_GAP + real(dp), pointer :: w_e(:) + real(dp) :: e_i, e_i_cutoff + real(dp), dimension(:), allocatable :: local_e_in, energy_per_coordinate + real(dp), dimension(:,:,:), allocatable :: virial_in + integer :: d, i, j, n, m, i_coordinate, i_pos0 + + real(dp), dimension(:,:), allocatable :: f_in + + real(dp), dimension(3) :: pos, f_gp + real(dp), dimension(3,3) :: virial_i + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical, dimension(:), allocatable :: mpi_local_mask + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name, calc_local_gap_variance, calc_energy_per_coordinate + real(dp) :: r_scale, E_scale + + real(dp) :: gap_variance_i_cutoff + real(dp), dimension(:), allocatable :: gap_variance, local_gap_variance_in + real(dp), dimension(:), pointer :: local_gap_variance_pointer + real(dp), dimension(:,:), allocatable :: gap_variance_gradient_in + real(dp), dimension(:,:), pointer :: gap_variance_gradient_pointer + real(dp) :: gap_variance_regularisation + logical :: do_rescale_r, do_rescale_E, do_gap_variance, print_gap_variance, do_local_gap_variance, do_energy_per_coordinate + integer :: only_descriptor + logical :: do_select_descriptor + logical :: mpi_parallel_descriptor + + type(descriptor_data) :: my_descriptor_data + type(extendable_str) :: my_args_str + real(dp), dimension(:), allocatable :: gradPredict, grad_variance_estimate + + INIT_ERROR(error) + + if (present(e)) then + e = 0.0_dp + endif + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_GAP_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_GAP_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) then + virial = 0.0_dp + endif + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_GAP_Calc', error) + local_virial = 0.0_dp + endif + + ! Has to be allocated as it's in the reduction clause. + allocate(local_e_in(at%N)) + local_e_in = 0.0_dp + + allocate(energy_per_coordinate(this%my_gp%n_coordinate)) + energy_per_coordinate = 0.0_dp + + allocate(f_in(3,at%N)) + f_in = 0.0_dp + + allocate(virial_in(3,3,at%N)) + virial_in = 0.0_dp + + if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) + + ! initialise this one since param parser doesn't set it + atom_mask_pointer => null() + has_atom_mask_name = .false. + atom_mask_name = "" + only_descriptor = 0 + + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true, energies, forces, virials etc. are " // & + "calculated") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.") + + call param_register(params, 'local_gap_variance', '', calc_local_gap_variance, help_string="Compute variance estimate of the GAP prediction per atom and return it in the Atoms object.") + call param_register(params, 'print_gap_variance', 'F', print_gap_variance, help_string="Compute variance estimate of the GAP prediction per descriptor and prints it.") + call param_register(params, 'gap_variance_regularisation', '0.001', gap_variance_regularisation, help_string="Regularisation value for variance calculation.") + + call param_register(params, 'only_descriptor', '0', only_descriptor, has_value_target=do_select_descriptor, help_string="Only select a single coordinate") + call param_register(params, 'energy_per_coordinate', '', calc_energy_per_coordinate, help_string="Compute energy per GP coordinate and return it in the Atoms object.") + + call param_register(params, 'mpi_parallel_descriptor', 'F', mpi_parallel_descriptor, help_string="Do MPI parallelism over descriptor instances rather than atoms") + + if(present(args_str)) then + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_GAP_Calc args_str')) & + call system_abort("IPModel_GAP_Calc failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_GAP_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_GAP_Calc: rescaling of potential at the calc() stage with r_scale and E_scale not yet implemented!", error) + end if + + my_args_str = trim(args_str) + else + ! call parser to set defaults + if (.not. param_read_line(params,"",ignore_unknown=.true.,task='IPModel_GAP_Calc args_str')) & + call system_abort("IPModel_GAP_Calc failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + call initialise(my_args_str) + endif + + call concat(my_args_str," xml_version="//this%xml_version) + + do_local_gap_variance = len_trim(calc_local_gap_variance) > 0 + do_gap_variance = do_local_gap_variance .or. print_gap_variance + do_energy_per_coordinate = len_trim(calc_energy_per_coordinate) > 0 + + ! Has to be allocated as it's in the reduction clause. + allocate( local_gap_variance_in(at%N) ) + local_gap_variance_in = 0.0_dp + allocate( gap_variance_gradient_in(3,at%N) ) + gap_variance_gradient_in = 0.0_dp + + if( present(mpi) ) then + if(mpi%active) then + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_GAP: atom_mask_name '//trim(atom_mask_name)//' present while running MPI version.'// \ + 'The use of atom_mask_name is intended for serial-compiled code called from an external parallel code, such as LAMMPS',error) + endif + + if( has_property(at,"mpi_local_mask") ) then + RAISE_ERROR("IPModel_GAP: mpi_local_mask property already present", error) + endif + + if (.not. mpi_parallel_descriptor) then + allocate(mpi_local_mask(at%N)) + call add_property_from_pointer(at,'mpi_local_mask',mpi_local_mask,error=error) + + call concat(my_args_str," atom_mask_name=mpi_local_mask") + endif + endif + endif + + + if(print_gap_variance) then + call print('GAP_VARIANCE potential '//trim(this%label)//' calculating for '//this%my_gp%n_coordinate//' descriptors') + end if + + loop_over_descriptors: do i_coordinate = 1, this%my_gp%n_coordinate + if (do_select_descriptor .and. (this%my_gp%n_coordinate > 1)) then + if (i_coordinate /= only_descriptor) then + call print("GAP label="//trim(this%label)//" skipping coordinate "//i_coordinate, PRINT_NERD) + cycle + end if + end if + + if (.not. mpi_parallel_descriptor) then ! If parallelising over atoms, not descriptors + if(mpi%active) call descriptor_MPI_setup(this%my_descriptor(i_coordinate),at,mpi,mpi_local_mask,error) + endif + + d = descriptor_dimensions(this%my_descriptor(i_coordinate)) + + if(do_gap_variance) then + call gpCoordinates_initialise_variance_estimate(this%my_gp%coordinate(i_coordinate), gap_variance_regularisation) + endif + + if(present(f) .or. present(virial) .or. present(local_virial)) then + if (allocated(gradPredict)) deallocate(gradPredict) + allocate(gradPredict(d)) + + if(allocated(grad_variance_estimate)) deallocate(grad_variance_estimate) + allocate(grad_variance_estimate(d)) + end if + call calc(this%my_descriptor(i_coordinate),at,my_descriptor_data, & + do_descriptor=.true.,do_grad_descriptor=present(f) .or. present(virial) .or. present(local_virial), args_str=trim(string(my_args_str)), error=error) + PASS_ERROR(error) + allocate(gap_variance(size(my_descriptor_data%x))) + + call system_timer('IPModel_GAP_Calc_gp_predict') + +!$omp parallel default(none) private(i,gradPredict, grad_variance_estimate, e_i,n,m,j,pos,f_gp,e_i_cutoff,virial_i,i_pos0,gap_variance_i_cutoff) & +!$omp shared(this,at,i_coordinate,my_descriptor_data,e,virial,local_virial,local_e,do_gap_variance,do_local_gap_variance,gap_variance,f,do_energy_per_coordinate,mpi,mpi_parallel_descriptor) & +!$omp reduction(+:local_e_in,f_in,virial_in,local_gap_variance_in, gap_variance_gradient_in, energy_per_coordinate) + +!$omp do schedule(dynamic) + loop_over_descriptor_instances: do i = 1, size(my_descriptor_data%x) + if( .not. my_descriptor_data%x(i)%has_data ) cycle + + if (mpi_parallel_descriptor .and. mpi%active) then + ! This blocking strategy should yield a good, memory-local distribution of descriptors to processors + if (.not. ((i - 1) * mpi%n_procs / size(my_descriptor_data%x)) == mpi%my_proc) cycle + endif + + !call system_timer('IPModel_GAP_Calc_gp_predict') + + if(present(f) .or. present(virial) .or. present(local_virial)) then + call reallocate(gradPredict,size(my_descriptor_data%x(i)%data(:)),zero=.true.) + e_i = gp_predict(this%my_gp%coordinate(i_coordinate) , xStar=my_descriptor_data%x(i)%data(:), gradPredict = gradPredict, variance_estimate=gap_variance(i), do_variance_estimate=do_gap_variance, grad_variance_estimate=grad_variance_estimate) + else + e_i = gp_predict(this%my_gp%coordinate(i_coordinate) , xStar=my_descriptor_data%x(i)%data(:), variance_estimate=gap_variance(i), do_variance_estimate=do_gap_variance) + endif + !call system_timer('IPModel_GAP_Calc_gp_predict') + if(present(e) .or. present(local_e)) then + + e_i_cutoff = e_i * my_descriptor_data%x(i)%covariance_cutoff / size(my_descriptor_data%x(i)%ci) + call print("GAPDEBUG ci="//my_descriptor_data%x(i)%ci//" e_i="//e_i//" e_i_cutoff="//e_i_cutoff, PRINT_NERD) + + do n = 1, size(my_descriptor_data%x(i)%ci) + local_e_in( my_descriptor_data%x(i)%ci(n) ) = local_e_in( my_descriptor_data%x(i)%ci(n) ) + e_i_cutoff + enddo + endif + + if( do_energy_per_coordinate ) energy_per_coordinate(i_coordinate) = energy_per_coordinate(i_coordinate) + e_i * my_descriptor_data%x(i)%covariance_cutoff + + if( do_local_gap_variance ) then + gap_variance_i_cutoff = gap_variance(i) * my_descriptor_data%x(i)%covariance_cutoff**2 / size(my_descriptor_data%x(i)%ci) + + do n = 1, size(my_descriptor_data%x(i)%ci) + local_gap_variance_in( my_descriptor_data%x(i)%ci(n) ) = local_gap_variance_in( my_descriptor_data%x(i)%ci(n) ) + gap_variance_i_cutoff + enddo + endif + + if(present(f) .or. present(virial) .or. present(local_virial)) then + i_pos0 = lbound(my_descriptor_data%x(i)%ii,1) + + do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1) + if( .not. my_descriptor_data%x(i)%has_grad_data(n) ) cycle + j = my_descriptor_data%x(i)%ii(n) + pos = my_descriptor_data%x(i)%pos(:,n) + f_gp = matmul( gradPredict,my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff + & + e_i * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) + if( present(f) ) then + f_in(:,j) = f_in(:,j) - f_gp + endif + if( do_local_gap_variance ) then + gap_variance_gradient_in(:,j) = gap_variance_gradient_in(:,j) + & + matmul( grad_variance_estimate, my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff**2 + & + 2.0_dp * gap_variance(i) * my_descriptor_data%x(i)%covariance_cutoff * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) + endif + if( present(virial) .or. present(local_virial) ) then + virial_i = ((pos-my_descriptor_data%x(i)%pos(:,i_pos0)) .outer. f_gp) + virial_in(:,:,j) = virial_in(:,:,j) - virial_i + + !virial_i = (pos .outer. f_gp) / size(my_descriptor_data%x(i)%ci) + !do m = 1, size(my_descriptor_data%x(i)%ci) + ! virial_in(:,:,my_descriptor_data%x(i)%ci(m)) = virial_in(:,:,my_descriptor_data%x(i)%ci(m)) - virial_i + !enddo + endif + enddo + endif + enddo loop_over_descriptor_instances +!$omp end do + if(allocated(gradPredict)) deallocate(gradPredict) +!$omp end parallel + call system_timer('IPModel_GAP_Calc_gp_predict') + + if(print_gap_variance) then + if( size(my_descriptor_data%x) > 0 ) then + do i = 1, size(my_descriptor_data%x) + if( .not. my_descriptor_data%x(i)%has_data ) cycle + call print('GAP_VARIANCE potential '//trim(this%label)//' descriptor '//i_coordinate//' var( '//i//' ) = '//(gap_variance(i))//" * "//(my_descriptor_data%x(i)%covariance_cutoff**2)//" cutoff") + if(allocated(my_descriptor_data%x(i)%ii)) call print('GAP_VARIANCE potential '//trim(this%label)//' descriptor '//i_coordinate//' ii( '//i//' ) = '//my_descriptor_data%x(i)%ii) + enddo + else + call print('GAP_VARIANCE potential '//trim(this%label)//' descriptor '//i_coordinate//' not found') + endif + endif + if(allocated(gap_variance)) deallocate(gap_variance) + + call finalise(my_descriptor_data) + + enddo loop_over_descriptors + + if(present(f)) f = f_in + if(present(e)) e = sum(local_e_in) + if(present(local_e)) local_e = local_e_in + if(present(virial)) virial = sum(virial_in,dim=3) + + if(present(local_virial)) then + do i = 1, at%N + local_virial(:,i) = reshape(virial_in(:,:,i),(/9/)) + enddo + endif + + if(allocated(local_e_in)) deallocate(local_e_in) + if(allocated(f_in)) deallocate(f_in) + if(allocated(virial_in)) deallocate(virial_in) + + if (present(mpi)) then + if( mpi%active ) then + if(present(f)) call sum_in_place(mpi,f) + if(present(virial)) call sum_in_place(mpi,virial) + if(present(local_virial)) call sum_in_place(mpi,local_virial) + if(present(e)) e = sum(mpi,e) + if(present(local_e) ) call sum_in_place(mpi,local_e) + if(do_local_gap_variance) then + call sum_in_place(mpi, local_gap_variance_in) + if(present(f) .or. present(virial) .or. present(local_virial)) call sum_in_place(mpi, gap_variance_gradient_in) + endif + if(do_energy_per_coordinate) call sum_in_place(mpi,energy_per_coordinate) + + if (.not. mpi_parallel_descriptor) then + call remove_property(at,'mpi_local_mask', error=error) + deallocate(mpi_local_mask) + endif + endif + endif + + if( do_local_gap_variance ) then + call add_property(at, trim(calc_local_gap_variance), 0.0_dp, ptr = local_gap_variance_pointer, error=error) + PASS_ERROR(error) + local_gap_variance_pointer = local_gap_variance_in + + if(present(f) .or. present(virial) .or. present(local_virial)) then + call add_property(at, "gap_variance_gradient", 0.0_dp, n_cols=3, ptr2 = gap_variance_gradient_pointer, error=error) + PASS_ERROR(error) + gap_variance_gradient_pointer = gap_variance_gradient_in + endif + endif + + if( do_energy_per_coordinate ) call set_param_value(at,trim(calc_energy_per_coordinate),energy_per_coordinate) + + if(allocated(local_gap_variance_in)) deallocate(local_gap_variance_in) + if(allocated(gap_variance_gradient_in)) deallocate(gap_variance_gradient_in) + if(allocated(energy_per_coordinate)) deallocate(energy_per_coordinate) + + if(present(e)) then + if( associated(atom_mask_pointer) ) then + e = e + sum(this%e0(at%Z),mask=atom_mask_pointer) + else + e = e + sum(this%e0(at%Z)) + endif + endif + + if(present(local_e)) then + if( associated(atom_mask_pointer) ) then + where (atom_mask_pointer) local_e = local_e + this%e0(at%Z) + else + local_e = local_e + this%e0(at%Z) + endif + endif + + if(present(f)) f = this%E_scale * f + if(present(e)) e = this%E_scale * e + if(present(local_e)) local_e = this%E_scale * local_e + if(present(virial)) virial = this%E_scale * virial + if(present(local_virial)) local_virial = this%E_scale * local_virial + + atom_mask_pointer => null() + local_gap_variance_pointer => null() + gap_variance_gradient_pointer => null() + call finalise(my_args_str) + +#endif + +end subroutine IPModel_GAP_Calc + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for XML stanza is given below, please notice that +!% they are simply dummy parameters for testing purposes, with no physical meaning. +!% +!%> +!%> +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + integer :: ri, Z + + if(name == 'GAP_params') then ! new GAP stanza + + if(parse_in_ip) & + call system_abort("IPModel_startElement_handler entered GAP_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if(parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if(status /= 0) value = '' + + if(len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if(value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + parse_ip%label = trim(value) ! if we found a label, AND didn't have one originally, pass it back to the object. + endif + + if(parse_in_ip) then + if(parse_ip%initialised) call finalise(parse_ip) + endif + + + call QUIP_FoX_get_value(attributes, 'gap_version', value, status) + if( (status == 0) ) then + parse_ip%xml_version = string_to_int(value) + if( parse_ip%xml_version > gap_version ) & + call system_abort( & + 'Database was created with a later version of the code.' // & + 'Version of code used to generate the database is '//trim(value)//'.'// & + 'Version of current code is '//gap_version//'. Please update your code.') + else + parse_ip%xml_version = 0 + endif + + elseif(parse_in_ip .and. name == 'GAP_data') then + + call QUIP_FoX_get_value(attributes, 'e0', value, status) + if(status == 0) then + read (value, *) parse_ip%e0(1) + parse_ip%e0 = parse_ip%e0(1) + endif + + call QUIP_FoX_get_value(attributes, 'do_pca', value, status) + if(status == 0) then + read (value, *) parse_ip%do_pca + else + parse_ip%do_pca = .false. + endif + + allocate( parse_ip%Z(parse_ip%n_species) ) + parse_in_gap_data = .true. + + elseif(parse_in_ip .and. parse_in_gap_data .and. name == 'e0') then + call QUIP_FoX_get_value(attributes, 'Z', value, status) + if(status == 0) then + read (value, *) Z + else + call system_abort('IPModel_GAP_read_params_xml cannot find Z') + endif + if( Z > size(parse_ip%e0) ) call system_abort('IPModel_GAP_read_params_xml: attribute Z = '//Z//' > '//size(parse_ip%e0)) + + call QUIP_FoX_get_value(attributes, 'value', value, status) + if(status == 0) then + read (value, *) parse_ip%e0(Z) + else + call system_abort('IPModel_GAP_read_params_xml cannot find value in e0') + endif + + elseif(parse_in_ip .and. name == 'water_monomer_params') then + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if(status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') + endif + + elseif(parse_in_ip .and. name == 'hf_dimer_params') then + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if(status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') + endif + + elseif(parse_in_ip .and. name == 'water_dimer_params') then + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if(status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') + endif + + elseif(parse_in_ip .and. name == 'bispectrum_so4_params') then + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if(status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') + endif + + call QUIP_FoX_get_value(attributes, 'j_max', value, status) + if(status == 0) then + read (value, *) parse_ip%j_max + else + call system_abort('IPModel_GAP_read_params_xml cannot find j_max') + endif + + call QUIP_FoX_get_value(attributes, 'z0', value, status) + if(status == 0) then + read (value, *) parse_ip%z0 + else + call system_abort('IPModel_GAP_read_params_xml cannot find z0') + endif + + elseif(parse_in_ip .and. name == 'cosnx_params') then + + call QUIP_FoX_get_value(attributes, 'l_max', value, status) + if(status == 0) then + read (value, *) parse_ip%cosnx_l_max + else + call system_abort('IPModel_GAP_read_params_xml cannot find l_max') + endif + + call QUIP_FoX_get_value(attributes, 'n_max', value, status) + if(status == 0) then + read (value, *) parse_ip%cosnx_n_max + else + call system_abort('IPModel_GAP_read_params_xml cannot find n_max') + endif + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if(status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') + endif + + allocate(parse_ip%NormFunction(parse_ip%cosnx_n_max), parse_ip%RadialTransform(parse_ip%cosnx_n_max,parse_ip%cosnx_n_max)) + + elseif(parse_in_ip .and. name == 'qw_so3_params') then + + call QUIP_FoX_get_value(attributes, 'l_max', value, status) + if(status == 0) then + read (value, *) parse_ip%qw_l_max + else + call system_abort('IPModel_GAP_read_params_xml cannot find l_max') + endif + + call QUIP_FoX_get_value(attributes, 'n_radial', value, status) + if(status == 0) then + read (value, *) parse_ip%qw_f_n + else + call system_abort('IPModel_GAP_read_params_xml cannot find n_radial') + endif + + call QUIP_FoX_get_value(attributes, 'do_q', value, status) + if(status == 0) then + read (value, *) parse_ip%qw_do_q + else + call system_abort('IPModel_GAP_read_params_xml cannot find do_q') + endif + + call QUIP_FoX_get_value(attributes, 'do_w', value, status) + if(status == 0) then + read (value, *) parse_ip%qw_do_w + else + call system_abort('IPModel_GAP_read_params_xml cannot find do_w') + endif + + allocate(parse_ip%qw_cutoff(parse_ip%qw_f_n), parse_ip%qw_cutoff_f(parse_ip%qw_f_n), parse_ip%qw_cutoff_r1(parse_ip%qw_f_n)) + + elseif(parse_in_ip .and. name == 'radial_function') then + + call QUIP_FoX_get_value(attributes, 'i', value, status) + if(status == 0) then + read (value, *) ri + else + call system_abort('IPModel_GAP_read_params_xml cannot find i') + endif + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if(status == 0) then + read (value, *) parse_ip%qw_cutoff(ri) + else + call system_abort('IPModel_GAP_read_params_xml cannot find cutoff') + endif + + call QUIP_FoX_get_value(attributes, 'cutoff_type', value, status) + if(status == 0) then + read (value, *) parse_ip%qw_cutoff_f(ri) + else + call system_abort('IPModel_GAP_read_params_xml cannot find cutoff_type') + endif + + call QUIP_FoX_get_value(attributes, 'cutoff_r1', value, status) + if(status == 0) then + read (value, *) parse_ip%qw_cutoff_r1(ri) + else + call system_abort('IPModel_GAP_read_params_xml cannot find cutoff_r1') + endif + + elseif(parse_in_ip .and. name == 'NormFunction') then + + parse_n_row = parse_ip%cosnx_n_max + call zero(parse_cur_data) + + elseif(parse_in_ip .and. name == 'command_line') then + call zero(parse_cur_data) + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + character(len=100*parse_n_row) :: val + + if (parse_in_ip) then + if(name == 'GAP_params') then + parse_in_ip = .false. + parse_in_ip_done = .true. + elseif(name == 'GAP_data') then + parse_in_gap_data = .false. + + elseif(name == 'bispectrum_so4_params') then + + elseif(name == 'hf_dimer_params') then + + elseif(name == 'water_monomer_params') then + + elseif(name == 'water_dimer_params') then + + elseif(name == 'qw_so3_params') then + + elseif(name == 'radial_function') then + + elseif(name == 'per_type_data') then + + elseif(name == 'PCA_mean') then + + val = string(parse_cur_data) + read(val,*) parse_ip%pca_mean + + elseif(name == 'row') then + + val = string(parse_cur_data) + read(val,*) parse_ip%pca_matrix(:,parse_cur_row) + + elseif(name == 'NormFunction') then + + val = string(parse_cur_data) + read(val,*) parse_ip%NormFunction + + elseif(name == 'RadialTransform_row') then + + val = string(parse_cur_data) + read(val,*) parse_ip%RadialTransform(:,parse_cur_row) + + elseif(name == 'command_line') then + parse_ip%command_line = parse_cur_data + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_characters_handler(in) + character(len=*), intent(in) :: in + + if(parse_in_ip) then + call concat(parse_cur_data, in, keep_lf=.false.) + endif + +end subroutine IPModel_characters_handler + +subroutine IPModel_GAP_read_params_xml(this, param_str) + type(IPModel_GAP), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) then + call system_abort('IPModel_GAP_read_params_xml: invalid param_str length '//len(trim(param_str)) ) + else + parse_in_ip = .false. + parse_in_ip_done = .false. + parse_matched_label = .false. + parse_ip => this + call initialise(parse_cur_data) + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler, & + characters_handler = IPModel_characters_handler) + call close_xml_t(fxml) + + call finalise(parse_cur_data) + + if(.not. parse_in_ip_done) & + call system_abort('IPModel_GAP_read_params_xml: could not initialise GAP potential. No GAP_params present?') + this%initialised = .true. + endif + +end subroutine IPModel_GAP_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of GAP parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_GAP_Print (this, file, dict) + type(IPModel_GAP), intent(inout) :: this + type(Inoutput), intent(inout),optional :: file + type(Dictionary), intent(inout), optional :: dict + integer :: i + + real(dp), dimension(:), allocatable :: log_likelihood + +#ifdef HAVE_GAP + call Print("IPModel_GAP : Gaussian Approximation Potential", file=file) + call Print("IPModel_GAP : label = "//this%label, file=file) + call Print("IPModel_GAP : cutoff = "//this%cutoff, file=file) + call Print("IPModel_GAP : E_scale = "//this%E_scale, file=file) + call Print("IPModel_GAP : command_line = "//string(this%command_line),file=file) + + allocate(log_likelihood(this%my_gp%n_coordinate)) + do i = 1, this%my_gp%n_coordinate + log_likelihood(i) = gp_log_likelihood(this%my_gp%coordinate(i)) + enddo + + call Print("IPModel_GAP : log likelihood = "//log_likelihood,file=file) +#else + allocate(log_likelihood(1)) + log_likelihood = 0.0_dp +#endif + + if( present(dict) ) then + if( dict%N == 0 ) call initialise(dict) + call set_value(dict,"log_likelihood_"//trim(this%label),log_likelihood) + endif + + if(allocated(log_likelihood)) deallocate(log_likelihood) + +end subroutine IPModel_GAP_Print + +end module IPModel_GAP_module diff --git a/src/Potentials/IPModel_Glue.F90 b/src/Potentials/IPModel_Glue.F90 new file mode 100644 index 0000000000..922fde3684 --- /dev/null +++ b/src/Potentials/IPModel_Glue.F90 @@ -0,0 +1,905 @@ +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X QUIP: quantum mechanical and interatomic potential simulation package +!X +!X Portions written by Noam Bernstein, while working at the +!X Naval Research Laboratory, Washington DC. +!X +!X Portions written by Gabor Csanyi, Copyright 2006-2007. +!X +!X When using this software, please cite the following reference: +!X +!X reference +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X IPModel_Glue +!X +!% Generic implementation of Glue potentials. Glue potentials are described +!% in the XML params file. +!X +!X Copyright Tim Green 2010. Licensed under the Gnu Public License version 3. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Glue_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use spline_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +type SplineDataContainer + real(dp), allocatable, dimension(:,:) :: data + real(dp) :: y1, yn +end type SplineDataContainer + +public :: IPModel_Glue +type IPModel_Glue + integer :: n_types = 0 ! Number of different species we have + + ! Maps from atomic number to type and vice versa + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + real(dp), allocatable, dimension(:) :: poly + + type(SplineDataContainer), allocatable, dimension(:) :: spline_data_potential, spline_data_density + type(SplineDataContainer), allocatable, dimension(:,:) :: spline_data_pair + type(Spline), allocatable :: potential(:) + type(Spline), allocatable :: pair(:,:) + type(Spline), allocatable :: density(:) + logical, dimension(:), allocatable :: do_density_spline + + character(len=STRING_LENGTH) :: label + +end type IPModel_Glue + +logical, private :: parse_in_ip, parse_matched_label, parse_in_density_potential, parse_in_neighbours_potential, parse_in_density, parse_in_potential_pair +type(IPModel_Glue), private, pointer :: parse_ip +integer :: parse_curr_type_i = 0, parse_curr_type_j = 0, parse_curr_point, parse_n_neighbours + +interface Initialise + module procedure IPModel_Glue_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Glue_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Glue_Print +end interface Print + +interface Calc + module procedure IPModel_Glue_Calc +end interface Calc + +contains + +subroutine IPModel_Glue_Initialise_str(this, args_str, param_str) + type(IPModel_Glue), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Glue_Initialise_str args_str')) then + call system_abort("IPModel_Glue_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Glue_read_params_xml(this, param_str) + +end subroutine IPModel_Glue_Initialise_str + +subroutine IPModel_Glue_Finalise(this) + type(IPModel_Glue), intent(inout) :: this + integer :: i, j + + ! Add finalisation code here + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%spline_data_density)) then + do i=1,this%n_types + if(allocated(this%spline_data_density(i)%data)) deallocate(this%spline_data_density(i)%data) + enddo + deallocate(this%spline_data_density) + endif + + if(allocated(this%do_density_spline)) deallocate(this%do_density_spline) + + if (allocated(this%spline_data_potential)) then + do i=1,this%n_types + if(allocated(this%spline_data_potential(i)%data)) deallocate(this%spline_data_potential(i)%data) + enddo + deallocate(this%spline_data_potential) + endif + + if (allocated(this%spline_data_pair)) then + do i=1,this%n_types + do j=1,this%n_types + if(allocated(this%spline_data_pair(j,i)%data)) deallocate(this%spline_data_pair(j,i)%data) + enddo + enddo + deallocate(this%spline_data_pair) + endif + + if(allocated(this%poly)) deallocate(this%poly) + + if (allocated(this%potential)) then + do i=1,this%n_types + call finalise(this%potential(i)) + enddo + deallocate(this%potential) + endif + + if (allocated(this%density)) then + do i=1,this%n_types + call finalise(this%density(i)) + enddo + deallocate(this%density) + endif + + if (allocated(this%pair)) then + do i=1,this%n_types + do j = 1, this%n_types + call finalise(this%pair(j,i)) + enddo + enddo + deallocate(this%pair) + endif + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Glue_Finalise + +subroutine IPModel_Glue_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Glue), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + real(dp), dimension(:), allocatable :: local_e_in, rho_local + real(dp), dimension(:,:), allocatable :: f_in + real(dp), dimension(:,:,:), allocatable :: local_virial_in + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E, unknown_type + ! Loop variables + integer :: i, ji, j, ti, tj + + real(dp) :: r_ij_mag, r_ij_hat(3), pair_e_ij, dpair_e_ij ! Neighbour vector info + + ! For calculating forces and the virial tensor + real(dp) :: dpotential_drho_drho_i_drij(3), dpotential_drho + + INIT_ERROR(error) + + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Glue_Calc', error) + endif + + if(present(e) .or. present(local_e)) then + allocate(local_e_in(at%N)) + local_e_in = 0.0_dp + else + allocate(local_e_in(1)) + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_Glue_Calc', error) + allocate(f_in(3,at%N)) + f_in = 0.0_dp + else + allocate(f_in(1,1)) + end if + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_Glue_Calc', error) + local_virial = 0.0_dp + endif + + if(present(virial) .or. present(local_virial)) then + allocate(local_virial_in(3,3,at%N)) + local_virial_in = 0.0_dp + else + allocate(local_virial_in(1,1,1)) + endif + + atom_mask_pointer => null() + + if(present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Glue_Calc args_str')) then + RAISE_ERROR("IPModel_Glue_Calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then + RAISE_ERROR("IPModel_Glue_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_Glue_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + endif + + ! Iterate over atoms + allocate(rho_local(at%N)) + rho_local = 0.0_dp + +!$omp parallel do default(none) shared(this,at,atom_mask_pointer,rho_local) private(i,j,ji,ti,tj,r_ij_mag,unknown_type) + do i = 1, at%N + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ! Get the type of this species from its atomic number + ti = get_type(this%type_of_atomic_num, at%Z(i), unknown_type=unknown_type) + if( unknown_type ) cycle + + ! Iterate over our nighbours + do ji = 1, n_neighbours(at, i) + j = neighbour(at, i, ji, distance = r_ij_mag) + tj = get_type(this%type_of_atomic_num, at%Z(j), unknown_type=unknown_type) + if( unknown_type ) cycle + + if (r_ij_mag < glue_cutoff(this, tj)) then ! Skip atoms beyond the cutoff + rho_local(i) = rho_local(i) + eam_density(this, tj, r_ij_mag) + endif + enddo + enddo +!$omp end parallel do + + ! Iterate over atoms +!$omp parallel do default(none) shared(this,at,atom_mask_pointer,rho_local,local_e_in,e,f,virial,local_e,local_virial) & +!$omp private(i,ji,j,ti,tj,r_ij_mag,r_ij_hat,dpotential_drho, dpotential_drho_drho_i_drij, pair_e_ij, dpair_e_ij, unknown_type) & +!$omp reduction(+:f_in,local_virial_in) + do i = 1, at%N + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ! Get the type of this species from its atomic number + ti = get_type(this%type_of_atomic_num, at%Z(i), unknown_type=unknown_type) + if( unknown_type ) cycle + + dpotential_drho = eam_spline_potential_deriv(this, ti, rho_local(i)) + + ! Iterate over our nighbours + do ji = 1, n_neighbours(at, i) + j = neighbour(at, i, ji, r_ij_mag, cosines=r_ij_hat) + tj = get_type(this%type_of_atomic_num, at%Z(j), unknown_type=unknown_type) + if( unknown_type ) cycle + + if (r_ij_mag < glue_cutoff(this, tj)) then ! Skip atoms beyond the cutoff + if( present(f) .or. present(virial) .or. present(local_virial) ) then + dpotential_drho_drho_i_drij = dpotential_drho * eam_density_deriv(this, tj, r_ij_mag) * r_ij_hat + endif + + if(present(f)) then + f_in(:,j) = f_in(:,j) - dpotential_drho_drho_i_drij + f_in(:,i) = f_in(:,i) + dpotential_drho_drho_i_drij + endif + + if(present(virial) .or. present(local_virial)) local_virial_in(:,:,j) = local_virial_in(:,:,j) - ( dpotential_drho_drho_i_drij .outer. r_ij_hat ) * r_ij_mag + endif + + if( r_ij_mag < pair_cutoff(this,ti,tj) ) then + pair_e_ij = eam_spline_pair(this,ti,tj,r_ij_mag) + if( present(local_e) .or. present(e) ) local_e_in(i) = local_e_in(i) + 0.5_dp * pair_e_ij + if( present(f) .or. present(virial) .or. present(local_virial) ) dpair_e_ij = eam_spline_pair_deriv(this,ti, tj, r_ij_mag) + if( present(f) ) f_in(:,i) = f_in(:,i) + 0.5 * dpair_e_ij * r_ij_hat + if( present(f) ) f_in(:,j) = f_in(:,j) - 0.5 * dpair_e_ij * r_ij_hat + if( present(virial) .or. present(local_virial) ) local_virial_in(:,:,j) = local_virial_in(:,:,j) - 0.5_dp * dpair_e_ij * (r_ij_hat .outer. r_ij_hat) * r_ij_mag + endif + + enddo ! ji + + if(present(local_e) .or. present(e)) local_e_in(i) = local_e_in(i) + eam_spline_potential(this, ti, rho_local(i)) + end do ! i +!$omp end parallel do + + + if(present(e)) e = sum(local_e_in) + if(present(f)) f = f_in + if(present(local_e)) local_e = local_e_in + if(present(virial)) virial = sum(local_virial_in,dim=3) + if(present(local_virial)) local_virial = reshape(local_virial_in,(/9,at%N/)) + + if(allocated(rho_local)) deallocate(rho_local) + if(allocated(local_e_in)) deallocate(local_e_in) + if(allocated(f_in)) deallocate(f_in) + if(allocated(local_virial_in)) deallocate(local_virial_in) + +end subroutine IPModel_Glue_Calc + +function glue_cutoff(this, ti, error) + type(IPModel_Glue), intent(in) :: this + integer, intent(in) :: ti + integer, intent(out), optional :: error + real(dp) :: glue_cutoff + + INIT_ERROR(error) + + if( .not. this%density(ti)%initialised ) then + RAISE_ERROR("glue_cutoff: spline not initialised", error) + endif + + glue_cutoff = max_knot(this%density(ti)) + +end function glue_cutoff + +function pair_cutoff(this, ti, tj, error) + type(IPModel_Glue), intent(in) :: this + integer, intent(in) :: ti, tj + integer, intent(out), optional :: error + real(dp) :: pair_cutoff + + INIT_ERROR(error) + + if( .not. this%pair(ti,tj)%initialised ) then + pair_cutoff = 0.0_dp + else + pair_cutoff = max_knot(this%pair(ti,tj)) + endif + +end function pair_cutoff + +function eam_density(this, ti, r, error) + type(IPModel_Glue), intent(in) :: this + integer, intent(in) :: ti + real(dp), intent(in) :: r + integer, intent(out), optional :: error + real(dp) :: eam_density + + INIT_ERROR(error) + + if( .not. this%density(ti)%initialised ) then + RAISE_ERROR("eam_density: spline not initialised", error) + endif + + if (r < glue_cutoff(this, ti)) then + if(this%do_density_spline(ti)) then + eam_density = spline_value(this%density(ti),r) + else + eam_density = this%poly(ti)*(glue_cutoff(this, ti)-r)**3 + endif + else + eam_density = 0.0_dp + endif +end function eam_density + +function eam_density_deriv(this, ti, r, error) + type(IPModel_Glue), intent(in) :: this + integer, intent(in) :: ti + real(dp), intent(in) :: r + integer, intent(out), optional :: error + real(dp) :: eam_density_deriv + + INIT_ERROR(error) + + if( .not. this%density(ti)%initialised ) then + RAISE_ERROR("eam_density_deriv: spline not initialised", error) + endif + + if (r < glue_cutoff(this, ti)) then + if(this%do_density_spline(ti)) then + eam_density_deriv = spline_deriv(this%density(ti),r) + else + eam_density_deriv = -3.0_dp * this%poly(ti)*(glue_cutoff(this, ti)-r)**2 + endif + else + eam_density_deriv = 0.0_dp + endif +end function eam_density_deriv + +function eam_spline_potential(this, ti, rho, error) + ! Evaluate the potential spline at r for the ti^th species + type(IPModel_Glue), intent(in) :: this + integer, intent(in) :: ti + real(dp), intent(in) :: rho + integer, intent(out), optional :: error + real(dp) :: eam_spline_potential + + INIT_ERROR(error) + + if( .not. this%potential(ti)%initialised ) then + RAISE_ERROR("eam_spline_potential: spline not initialised", error) + endif + + eam_spline_potential = spline_value(this%potential(ti), rho) + +end function eam_spline_potential + +function eam_spline_potential_deriv(this, ti, rho, error) + ! Evaluate the potential spline derivitive at r for the ti^th species + type(IPModel_Glue), intent(in) :: this + integer, intent(in) :: ti + real(dp), intent(in) :: rho + integer, intent(out), optional :: error + real(dp) :: eam_spline_potential_deriv + + INIT_ERROR(error) + + if( .not. this%potential(ti)%initialised ) then + RAISE_ERROR("eam_spline_potential_deriv: spline not initialised", error) + endif + + eam_spline_potential_deriv = spline_deriv(this%potential(ti), rho) + +end function eam_spline_potential_deriv + +function eam_spline_pair(this, ti, tj, rho, error) + ! Evaluate the potential spline at r for the ti^th species + type(IPModel_Glue), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: rho + integer, intent(out), optional :: error + real(dp) :: eam_spline_pair + + INIT_ERROR(error) + + if( .not. this%pair(ti,tj)%initialised ) then + eam_spline_pair = 0.0_dp + else + eam_spline_pair = spline_value(this%pair(ti,tj), rho) + endif + + +end function eam_spline_pair + +function eam_spline_pair_deriv(this, ti, tj, rho, error) + ! Evaluate the potential spline derivitive at r for the ti^th species + type(IPModel_Glue), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: rho + integer, intent(out), optional :: error + real(dp) :: eam_spline_pair_deriv + + INIT_ERROR(error) + + if( .not. this%pair(ti,tj)%initialised ) then + eam_spline_pair_deriv = 0.0_dp + else + eam_spline_pair_deriv = spline_deriv(this%pair(ti, tj), rho) + endif + + +end function eam_spline_pair_deriv + +subroutine IPModel_Glue_Print(this, file) + type(IPModel_Glue), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_Glue : Glue Potential", file=file) + call Print("IPModel_Glue : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_Glue : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_Glue : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_Glue_Print + +subroutine IPModel_Glue_read_params_xml(this, param_str) + type(IPModel_Glue), intent(inout), target :: this + character(len=*), intent(in) :: param_str + integer :: ti, tj + real(dp) :: max_cutoff + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Glue_read_params_xml parsed file, but n_types = 0") + endif + + ! Initialise the spline data structures with the spline data + do ti = 1, this%n_types + + if(allocated(this%spline_data_density(ti)%data)) then + call initialise(this%density(ti), this%spline_data_density(ti)%data(:,1), this%spline_data_density(ti)%data(:,2), & + this%spline_data_density(ti)%y1, this%spline_data_density(ti)%yn) + endif + if(allocated(this%spline_data_potential(ti)%data)) then + call initialise(this%potential(ti), this%spline_data_potential(ti)%data(:,1), this%spline_data_potential(ti)%data(:,2), this%spline_data_potential(ti)%y1,this%spline_data_potential(ti)%yn) + endif + + do tj = 1, this%n_types + if(allocated(this%spline_data_pair(tj,ti)%data)) then + call initialise(this%pair(tj,ti), this%spline_data_pair(tj,ti)%data(:,1), this%spline_data_pair(tj,ti)%data(:,2), this%spline_data_pair(tj,ti)%y1, this%spline_data_pair(tj,ti)%yn) + call initialise(this%pair(ti,tj), this%spline_data_pair(tj,ti)%data(:,1), this%spline_data_pair(tj,ti)%data(:,2), this%spline_data_pair(tj,ti)%y1, this%spline_data_pair(tj,ti)%yn) + endif + enddo + + this%poly(ti) = dot_product(this%spline_data_density(ti)%data(:,2), (glue_cutoff(this,ti) - & + this%spline_data_density(ti)%data(:,1))**3) / & + dot_product((glue_cutoff(this,ti)-this%spline_data_density(ti)%data(:,1))**3, & + (glue_cutoff(this,ti)-this%spline_data_density(ti)%data(:,1))**3) + end do + + max_cutoff = 0.0_dp + ! Find the largest cutoff + do ti = 1, this%n_types + max_cutoff = max(glue_cutoff(this,ti),max_cutoff) + do tj = 1, this%n_types + max_cutoff = max(pair_cutoff(this,tj,ti),max_cutoff) + enddo + enddo + this%cutoff = max_cutoff + +end subroutine IPModel_Glue_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + integer :: ti, tj, num_points + real(dp) :: v + + if (name == 'Glue_params') then ! new Template stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in Glue_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + ! Allocate n_types spline data objects for further allocation + allocate(parse_ip%spline_data_density(parse_ip%n_types)) + allocate(parse_ip%spline_data_potential(parse_ip%n_types)) + allocate(parse_ip%spline_data_pair(parse_ip%n_types,parse_ip%n_types)) + + allocate(parse_ip%do_density_spline(parse_ip%n_types)) + + ! Allocate the splines + allocate(parse_ip%pair(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%potential(parse_ip%n_types)) + allocate(parse_ip%density(parse_ip%n_types)) + allocate(parse_ip%poly(parse_ip%n_types)) + endif + + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find type") + read (value, *) ti ! This is the index of this particular species + + parse_curr_type_i = ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) ! This is the atomic number of this particular species + + ! Re-do the atomic number -> species index map + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "type1", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find type") + read (value, *) ti ! This is the index of this particular species + + parse_curr_type_i = ti + + call QUIP_FoX_get_value(attributes, "type2", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find type") + read (value, *) tj ! This is the index of this particular species + + parse_curr_type_j = tj + + elseif (parse_in_ip .and. parse_curr_type_i /= 0 .and. name == 'density') then + ! Density is modelled as scale*exp(-extent*x). Could probably determine scale from normalization, but I won't. + + parse_in_density = .true. + parse_curr_point = 1 + + call QUIP_FoX_get_value(attributes, "num_points", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml density but no num_points") + read (value, *) num_points ! + + call QUIP_FoX_get_value(attributes, "do_spline", value, status) + if (status /= 0) then + parse_ip%do_density_spline(parse_curr_type_i) = .false. + else + read (value, *) parse_ip%do_density_spline(parse_curr_type_i) + endif + + call QUIP_FoX_get_value(attributes, "density_y1", value, status) ! endpoint derivative + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml density but no density_y1") + read (value, *) parse_ip%spline_data_density(parse_curr_type_i)%y1 + + call QUIP_FoX_get_value(attributes, "density_yn", value, status) ! endpoint derivative + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml density but no density_yn") + read (value, *) parse_ip%spline_data_density(parse_curr_type_i)%yn + + ! Allocate num_points in the current type + allocate(parse_ip%spline_data_density(parse_curr_type_i)%data(num_points,2)) + + elseif (parse_in_ip .and. parse_curr_type_i /= 0 .and. name == 'potential_density') then + + ! Potential supplied as density vs. energy + parse_in_density_potential = .true. + parse_curr_point = 1 + + call QUIP_FoX_get_value(attributes, "num_points", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml potential_density but no num_points") + read (value, *) num_points ! + + call QUIP_FoX_get_value(attributes, "y1", value, status) ! endpoint derivative + if (status /= 0) then + parse_ip%spline_data_potential(parse_curr_type_i)%y1 = 2.0e30_dp + else + read (value, *) parse_ip%spline_data_potential(parse_curr_type_i)%y1 + endif + + call QUIP_FoX_get_value(attributes, "yn", value, status) ! endpoint derivative + if (status /= 0) then + parse_ip%spline_data_potential(parse_curr_type_i)%yn = 2.0e30_dp + else + read (value, *) parse_ip%spline_data_potential(parse_curr_type_i)%yn + endif + + ! Allocate num_points in the current type + allocate(parse_ip%spline_data_potential(parse_curr_type_i)%data(num_points,2)) + + elseif (parse_in_ip .and. parse_curr_type_i /= 0 .and. name == 'potential_neighbours') then + + ! Potential supplied as distance to nearest neighbour vs. energy, along with number of neighbours + parse_in_neighbours_potential = .true. + parse_curr_point = 1 + + call QUIP_FoX_get_value(attributes, "num_neighbours", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml missing num_neighbours on potential_neighbouring") + read (value, *) parse_n_neighbours + + call QUIP_FoX_get_value(attributes, "num_points", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml potential_neighbours but no num_points") + read (value, *) num_points ! scale of the electron density for this element + + ! Allocate num_points in the current type + allocate(parse_ip%spline_data_potential(parse_curr_type_i)%data(num_points,2)) + + elseif (parse_in_ip .and. parse_curr_type_i /= 0 .and. parse_curr_type_j /= 0 .and. name == 'potential_pair') then + + ! Pair potential + parse_in_potential_pair = .true. + parse_curr_point = 1 + + call QUIP_FoX_get_value(attributes, "num_points", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml potential_pair but no num_points") + read (value, *) num_points + + call QUIP_FoX_get_value(attributes, "y1", value, status) ! endpoint derivative + if (status /= 0) then + parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%y1 = 0.0_dp + else + read (value, *) parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%y1 + endif + + call QUIP_FoX_get_value(attributes, "yn", value, status) ! endpoint derivative + if (status /= 0) then + parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%yn = 0.0_dp + else + read (value, *) parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%yn + endif + + ! Allocate num_points in the current type + allocate(parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%data(num_points,2)) + + elseif (parse_in_ip .and. name == 'point') then + + if (parse_in_density_potential) then + + ! + ! Potential defined as a rho->E map + ! + + if (parse_curr_point > size(parse_ip%spline_data_potential(parse_curr_type_i)%data,1)) call system_abort ("IPModel_Glue got too " // & + "many points " // parse_curr_point // " type " // parse_curr_type_i // " in potential_density") + + call QUIP_FoX_get_value(attributes, "rho", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find rho") + read (value, *) v + parse_ip%spline_data_potential(parse_curr_type_i)%data(parse_curr_point,1) = v + + call QUIP_FoX_get_value(attributes, "E", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find E") + read (value, *) v + parse_ip%spline_data_potential(parse_curr_type_i)%data(parse_curr_point,2) = v + + elseif (parse_in_potential_pair) then + + if (parse_curr_point > size(parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%data,1)) call system_abort ("IPModel_Glue got too " // & + "many points " // parse_curr_point // " type " // parse_curr_type_i // " in potential_pair") + + call QUIP_FoX_get_value(attributes, "r", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find r") + read (value, *) v + parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%data(parse_curr_point,1) = v + + call QUIP_FoX_get_value(attributes, "E", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find E") + read (value, *) v + parse_ip%spline_data_pair(parse_curr_type_i,parse_curr_type_j)%data(parse_curr_point,2) = v + + elseif (parse_in_neighbours_potential) then + + ! + ! Potential defined as a a->E map for N nearest neighbours + ! + + if (parse_curr_point > size(parse_ip%spline_data_potential(parse_curr_type_i)%data,1)) call system_abort ("IPModel_Glue got too " // & +"many points " // parse_curr_point // " type " // parse_curr_type_i // " in potential_neighbours") + + call QUIP_FoX_get_value(attributes, "a", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find a") + read (value, *) v + + ! This implies that the denstiy must be defined above the potential + parse_ip%spline_data_potential(parse_curr_type_i)%data(parse_curr_point,1) = eam_density(parse_ip, parse_curr_type_i, v) * parse_n_neighbours + + call QUIP_FoX_get_value(attributes, "E", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find E") + read (value, *) v + parse_ip%spline_data_potential(parse_curr_type_i)%data(parse_curr_point,2) = v + + ! call print(parse_ip%spline_data(parse_curr_type_i)%spline_potential(1, parse_curr_point) // " " // parse_ip%spline_data(parse_curr_type_i)%spline_potential(2, parse_curr_point) // " " ) + + elseif (parse_in_density) then + + ! + ! Potential defined as a a->E map for N nearest neighbours + ! + + if (parse_curr_point > size(parse_ip%spline_data_density(parse_curr_type_i)%data,1)) call system_abort ("IPModel_Glue got too " // & +"many points " // parse_curr_point // " type " // parse_curr_type_i // " in density") + + call QUIP_FoX_get_value(attributes, "a", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find a") + read (value, *) v + + ! This implies that the denstiy must be defined above the potential + parse_ip%spline_data_density(parse_curr_type_i)%data(parse_curr_point,1) = v + + call QUIP_FoX_get_value(attributes, "rho", value, status) + if (status /= 0) call system_abort ("IPModel_Glue_read_params_xml cannot find rho") + read (value, *) v + parse_ip%spline_data_density(parse_curr_type_i)%data(parse_curr_point,2) = v + + ! call print(parse_ip%spline_data(parse_curr_type_i)%spline_potential(1, parse_curr_point) // " " // parse_ip%spline_data(parse_curr_type_i)%spline_potential(2, parse_curr_point) // " " ) + + endif + + parse_curr_point = parse_curr_point + 1 + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Glue_params') then + parse_in_ip = .false. + elseif (name == 'potential_density') then + parse_in_density_potential = .false. + elseif (name == 'potential_pair') then + parse_in_potential_pair = .false. + elseif (name == 'potential_neighbours') then + parse_in_neighbours_potential = .false. + elseif (name == 'density') then + parse_in_density = .false. + elseif (name == 'per_type_data') then + parse_curr_type_i = 0 + elseif (name == 'per_pair_data') then + parse_curr_type_i = 0 + parse_curr_type_j = 0 + endif + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_Glue_module diff --git a/src/Potentials/IPModel_HFdimer.F90 b/src/Potentials/IPModel_HFdimer.F90 new file mode 100644 index 0000000000..9b949a56a5 --- /dev/null +++ b/src/Potentials/IPModel_HFdimer.F90 @@ -0,0 +1,208 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_HFdimer +!X +!% Simple interatomic potential for an HF dimer: +!% +!% Includes a linear spring between bonded H and F atoms, Coulomb interaction and short-range repulsion +!% between nonbonded atoms. The parametrisation was done from MP2 calculations. +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_HFdimer_module + +use error_module +use system_module, only : dp, inoutput, print, operator(//) +use units_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_HFdimer +type IPModel_HFdimer + real(dp) :: cutoff = 10.0_dp +end type IPModel_HFdimer + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_HFdimer), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_HFdimer_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_HFdimer_Finalise +end interface Finalise + +interface Print + module procedure IPModel_HFdimer_Print +end interface Print + +interface Calc + module procedure IPModel_HFdimer_Calc +end interface Calc + +contains + +subroutine IPModel_HFdimer_Initialise_str(this, args_str, param_str) + type(IPModel_HFdimer), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + ! Add initialisation code here + +end subroutine IPModel_HFdimer_Initialise_str + +subroutine IPModel_HFdimer_Finalise(this) + type(IPModel_HFdimer), intent(inout) :: this + + ! Add finalisation code here + +end subroutine IPModel_HFdimer_Finalise + + +subroutine IPModel_HFdimer_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_HFdimer), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + ! Add calc() code here + + + real(dp) :: energy, force(3,4) + real(dp) :: rHF1, rHF2, rFF, rF1, rF2, dr1(3), dr2(3), drFF(3), drF1(3), drF2(3), rHH, rH1F2, rH2F1, drHH(3), drH1F2(3), drH2F1(3), q2 + real(dp), parameter :: kHF = 0.0_dp ! 37.84_dp ! H-F spring constant + real(dp), parameter :: kConf = 0.0_dp ! 0.15_dp ! confinement + real(dp), parameter :: d0HF = 0.9_dp, BFF = 0.269268123658040_dp, r0FF = 2.0312819622_dp, r0HF = 1.1564_dp, BHF = 0.141733063687659_dp, q=0.43_dp + + INIT_ERROR(error) + + + + ! Hydrogen Fluoride dimer potential + ! spring constant between H-F and repulsive interaction between Fs, repulsive interaction between nonbonded HFs, Coulomb interaction between nonbonded things + ! The order in the Atoms object must be H-F H-F + ! + ! Harmonic confining potential on Fs + + rHF1 = distance_min_image(at, 1, 2) + rHF2 = distance_min_image(at, 3, 4) + rFF = distance_min_image(at, 2, 4) + rHH = distance_min_image(at,1,3) + rH1F2 = distance_min_image(at,1,4) + rH2F1 = distance_min_image(at,2,3) + + rF1 = distance_min_image(at, 2, (/0.0_dp, 0.0_dp, 0.0_dp/)) + rF2 = distance_min_image(at, 4, (/0.0_dp, 0.0_dp, 0.0_dp/)) + + ! Bonded energy terms + energy = kHF*(rHF1-d0HF)**2 + kHF*(rHF2-d0HF)**2 + + ! repulsive terms + energy = energy + exp(-(rFF-r0FF)/BFF) + exp(-(rH1F2-r0HF)/BHF) + exp(-(rH2F1-r0HF)/BHF) + + ! confinement + energy = energy + kConf*rF1**2 + kConf*rF2**2 + + ! Coulomb Energy + q2 = HARTREE*BOHR*q*q + energy = energy + q2*(& + (+1.0_dp)/rHH + & ! H1-H2 + (-1.0_dp)/rH1F2 + & ! H1-F2 + (+1.0_dp)/rFF + & ! F1-F2 + (-1.0_dp)/rH2F1) ! F1-H2 + + !Forces + + dr1 = diff_min_image(at, 1, 2)/rHF1 + dr2 = diff_min_image(at, 3, 4)/rHF2 + drFF = diff_min_image(at, 2, 4)/rFF + drF1 = diff_min_image(at, 2, (/0.0_dp, 0.0_dp, 0.0_dp/))/rF1 + drF2 = diff_min_image(at, 4, (/0.0_dp, 0.0_dp, 0.0_dp/))/rF2 + + drHH = diff_min_image(at,1,3)/rHH + drH1F2 = diff_min_image(at,1,4)/rH1F2 + drH2F1 = diff_min_image(at,2,3)/rH2F1 + + force(:,1) = 2.0_dp*kHF*(rHF1-d0HF)*dr1 -q2/rHH**2*drHH + q2/rH1F2**2*drH1F2 - 1.0_dp/BHF*exp(-(rH1F2-r0HF)/BHF)*drH1F2 + force(:,2) = -2.0_dp*kHF*(rHF1-d0HF)*dr1 - 1.0_dp/BFF*exp(-(rFF-r0FF)/BFF) * drFF + 2.0_dp*kConf*rF1*drF1 +q2/rH2F1**2*drH2F1 -q2/rFF**2*drFF - 1.0_dp/BHF*exp(-(rH2F1-r0HF)/BHF)*drH2F1 + force(:,3) = 2.0_dp*kHF*(rHF2-d0HF)*dr2 +q2/rHH**2*drHH - q2/rH2F1**2*drH2F1 + 1.0_dp/BHF*exp(-(rH2F1-r0HF)/BHF)*drH2F1 + force(:,4) = -2.0_dp*kHF*(rHF2-d0HF)*dr2 + 1.0_dp/BFF*exp(-(rFF-r0FF)/BFF) * drFF + 2.0_dp*kConf*rF2*drF2 -q2/rH1F2**2*drH1F2 +q2/rFF**2*drFF + 1.0_dp/BHF*exp(-(rH1F2-r0HF)/BHF)*drH1F2 + + + if (present(e)) e = energy + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_HFdimer_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_HFdimer_Calc', error) + f = force + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_HFdimer_Calc', error) + local_virial = 0.0_dp + endif + + +end subroutine IPModel_HFdimer_Calc + + +subroutine IPModel_HFdimer_Print(this, file) + type(IPModel_HFdimer), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_HFdimer : HFdimer Potential", file=file) + call Print("IPModel_HFdimer : cutoff = " // this%cutoff, file=file) + +end subroutine IPModel_HFdimer_Print + + +end module IPModel_HFdimer_module diff --git a/src/Potentials/IPModel_KIM.F90 b/src/Potentials/IPModel_KIM.F90 new file mode 100644 index 0000000000..c01787cc45 --- /dev/null +++ b/src/Potentials/IPModel_KIM.F90 @@ -0,0 +1,683 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_KIM module +!X +!% Module for KIM (Knowledgebase of Interatomic potential Models) +!% +!% The IPModel_KIM object contains all the parameters read from a +!% 'KIM_params' XML stanza. (?) +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" +#include "KIM_API_status.h" + + + +module IPModel_KIM_module + +use error_module +use system_module, only : dp, inoutput, quip_new_line, split_string_simple +use periodictable_module +use extendable_str_module +use linearalgebra_module +use dictionary_module +use paramreader_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module +use KIM_API + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_KIM +type IPModel_KIM + integer(kind=kim_intptr) :: pkim = 0 + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + character(len=STRING_LENGTH) KIM_Model_name, KIM_Test_name + + logical :: kim_is_initialised = .false. + + integer, pointer :: atomTypeOfZ(:) => null() + character(len=512), pointer :: model_optional_outputs(:) => null() + + logical :: kim_model_has_energy, kim_model_has_forces, kim_model_has_particleenergy, kim_model_has_virial + +end type IPModel_KIM + +!NB in an ideal world these should not be global variables, but that requires +!NB passing in a neighObject explicitly into the iterator, rather than just a pkim +!NB maybe something can be done with a KIM buffer? +integer :: kim_iterator_current_i = -1 +type(Atoms), pointer :: kim_at + +interface Initialise + module procedure IPModel_KIM_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_KIM_Finalise +end interface Finalise + +interface Print + module procedure IPModel_KIM_Print +end interface Print + +interface Calc + module procedure IPModel_KIM_Calc +end interface Calc + +contains + +subroutine IPModel_KIM_Initialise_str(this, args_str, param_str) + type(IPModel_KIM), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + integer :: n_atom_types, kim_at_type_code, Z_i, at_type_i, j, k + character(len=KIM_KEY_STRING_LENGTH) atom_types_list(1); pointer(p_atom_types_list, atom_types_list) + + type(Dictionary) :: params + integer :: kim_error + type(Extendable_Str) :: test_kim_es + + + ! Some day it would be nice if this could be cleaner with F2003 pointers + real(dp) :: cutoffstub; pointer(pcutoff,cutoffstub); + + call Finalise(this) + + ! get params from QUIP, specifically KIM model and test names + call initialise(params) + call param_register(params, 'KIM_Model_name', PARAM_MANDATORY, this%KIM_Model_name, help_string="Name of KIM Model to initialise") + call param_register(params, 'KIM_Test_name', '-', this%KIM_Test_name, help_string="Name of KIM Test to initialise. If '-', autogenerate test.kim file") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_KIM_Initialise_str args_str')) then + call system_abort("IPModel_KIM_Initialise_str failed to parse args_str="//trim(args_str)) + endif + call finalise(params) + +#ifdef KIM_NO_AUTOGENERATE_TEST_KIM + if (trim(this%KIM_Test_name) == '-') then + call system_abort("IPModel_KIM_Initialise_str: no support for KIM_Test_name=- autogenerate test.kim file") + endif +#endif + +#ifndef KIM_NO_AUTOGENERATE_TEST_KIM + if (trim(this%KIM_Test_name) == '-') then + ! create KIM test file string from model kim string + call write_test_kim_file_from_model(this, test_kim_es) + + ! KIM routines to initialise pkim based on this%KIM_Test_name string + kim_error = KIM_API_string_init_f(this%pkim, string(test_kim_es)//char(0), this%KIM_Model_name) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_init_str_testname_f failed", kim_error) /= KIM_STATUS_OK) then + call print(test_kim_es) + call system_abort("IPModel_KIM_Initialise_str: kim_api_init_str_testname_f with Test='"//trim(this%KIM_Test_name)// & + "' and Model='"//trim(this%KIM_Model_name)//"' failed") + endif + + else +#endif + ! KIM routines to initialise pkim based on this%KIM_Test_name + kim_error = KIM_API_init_f(this%pkim, this%KIM_Test_name, this%KIM_Model_name) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_init_f failed", kim_error) /= KIM_STATUS_OK) & + call system_abort("IPModel_KIM_Initialise_str: kim_api_init_f with Test='"//trim(this%KIM_Test_name)// & + "' and Model='"//trim(this%KIM_Model_name)//"' failed") +#ifndef KIM_NO_AUTOGENERATE_TEST_KIM + endif +#endif + + this%kim_is_initialised = .true. + kim_iterator_current_i = -1 + nullify(kim_at) + + ! create array for conversion of atomic numbers to KIM atom type codes + p_atom_types_list = KIM_API_get_model_partcl_typs_f(this%pkim, n_atom_types, kim_error) + + allocate(this%atomTypeOfZ(size(ElementName))) + this%atomTypeOfZ(:) = -1 + do at_type_i=1, n_atom_types + ! replace null termination with space padding (C -> Fortran) + do j=1, KIM_KEY_STRING_LENGTH + if (atom_types_list(at_type_i)(j:j) == char(0)) then + do k=j, KIM_KEY_STRING_LENGTH + atom_types_list(at_type_i)(k:k) = ' ' + end do + exit + endif + end do + kim_at_type_code = KIM_API_get_partcl_type_code_f(this%pkim, trim(atom_types_list(at_type_i)), kim_error) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_get_partcl_type_code_f failed", kim_error) /= KIM_STATUS_OK) & + call system_abort("failed to find name of atom type "//at_type_i//" '"//trim(atom_types_list(at_type_i))//"' in pkim") + Z_i = find_in_array(ElementName, trim(atom_types_list(at_type_i))) + if (Z_i < 1) then + call system_abort("failed to find atomic number for name of atom type "//at_type_i//" '"//trim(atom_types_list(at_type_i))//"'") + endif + Z_i = Z_i - 1 + this%atomTypeOfZ(Z_i) = kim_at_type_code + end do + + ! register the neighbor list iterator + kim_error = kim_api_set_data_f(this%pkim, "get_neigh", int(1,8), loc(quip_neighbour_iterator)) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_set_data_f failed", kim_error) /= KIM_STATUS_OK) & + call system_abort("IPModel_KIM_Initialise_str failed to register quip_neighbour_iterator in kim") + + ! register the cutoff + kim_error = kim_api_set_data_f(this%pkim, "cutoff", int(1,8), loc(this%cutoff)) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_set_data_f failed", kim_error) /= KIM_STATUS_OK) & + call system_abort("IPModel_KIM_Initialise_str failed to register cutoff in kim") + + ! initialize the model + kim_error = KIM_API_model_init_f(this%pkim) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_model_init_f failed", kim_error) /= KIM_STATUS_OK) & + call system_abort("IPModel_KIM_Initialise_str: kim_api_model_init_f failed") + +end subroutine IPModel_KIM_Initialise_str + +function quip_neighbour_iterator(pkim, iterator_mode, request, atom, nneigh, p_neigh_list, p_neigh_rij) result(outval) + integer(kind=kim_intptr) :: pkim + integer :: iterator_mode, request, atom, nneigh + + !NB 512 should be replaced with a KIM constant + integer, save :: neigh_list(512) + integer :: neigh_list_stub(1); pointer (p_neigh_list, neigh_list_stub) + + !NB 512 should be replaced with a KIM constant + real(dp), save :: neigh_rij(3,512) + real(dp) :: neigh_rij_stub(3,1); pointer (p_neigh_rij, neigh_rij_stub) + + integer :: outval + + integer :: ji + + p_neigh_rij = loc(neigh_rij(1,1)) + p_neigh_list = loc(neigh_list(1)) + + if (iterator_mode == 1) then ! locator mode + if (request < 1 .or. request > kim_at%N) then + outval = KIM_STATUS_NEIGH_INVALID_REQUEST + return + endif + atom = request + else if (iterator_mode == 0) then ! iterator mode + if (request == 0) then + kim_iterator_current_i = 1 + outval = KIM_STATUS_NEIGH_ITER_INIT_OK + return + else if (request == 1) then + if (kim_iterator_current_i > kim_at%N) then + outval = KIM_STATUS_NEIGH_ITER_PAST_END + return + endif + atom = kim_iterator_current_i + kim_iterator_current_i = kim_iterator_current_i + 1 + else ! other iterator requests + outval = KIM_STATUS_NEIGH_INVALID_REQUEST + return + endif + else ! other mode + outval = KIM_STATUS_NEIGH_INVALID_MODE + return + endif + + nneigh = n_neighbours(kim_at, atom) + do ji=1, nneigh + neigh_list(ji) = neighbour(kim_at, atom, ji, diff = neigh_rij(1:3,ji)) + end do + + outval = KIM_STATUS_OK + +end function quip_neighbour_iterator + +subroutine IPModel_KIM_Finalise(this) + type(IPModel_KIM), intent(inout) :: this + + integer :: kim_error + + !! BAD - bug in gfortran 4.5 makes (apparently) this%kim_is_initialised is not set correctly for new structures, so we can't trust it + if (this%kim_is_initialised) then + kim_error = kim_api_model_destroy_f(this%pkim) + call kim_api_free_f(this%pkim, kim_error) + endif + + this%KIM_Test_name = '' + this%KIM_Model_name = '' + this%cutoff = 0.0_dp + this%kim_is_initialised = .false. + kim_iterator_current_i = -1 + if (this%pkim /= 0) then + if (associated(this%AtomTypeOfZ)) deallocate(this%AtomTypeOfZ) + if (associated(this%model_optional_outputs)) deallocate(this%model_optional_outputs) + endif + this%pkim = 0 + nullify(kim_at) +end subroutine IPModel_KIM_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_KIM_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_KIM), intent(inout) :: this + type(Atoms), intent(inout), target :: at + real(dp), intent(out), target, optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), target, optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + character(len=STRING_LENGTH) :: extra_calcs_list(10) + integer :: n_extra_calcs + integer*8 :: ppos, pf, pe, pN, pNlocal + integer*8 :: Nstub + + real(dp) :: virial_sym(6) + integer :: i + integer :: numberAtomTypes + integer, allocatable :: atomTypes(:) + integer kim_error + integer :: bad_i(1) + + real(dp), target :: t_e + real(dp), allocatable, target :: t_local_e(:), t_f(:,:) + real(dp), pointer :: p_e, p_local_e(:), p_f(:,:) + + INIT_ERROR(error) + + ! check for unsupported output quantities + if (present(local_virial)) then + RAISE_ERROR("IPModel_KIM_Calc can't handle local_virial yet", error) + endif + if (present(args_str)) then + if (len_trim(args_str) > 0) then + n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) + if (n_extra_calcs > 0) then + RAISE_ERROR("No extra calcs supported, found "//n_extra_calcs//" in args_str " // trim(args_str), error) + endif + endif + endif + + ! allocate atomTypes array for conversion from atomic number to atom type + allocate(atomTypes(at%N)) + atomTypes(1:at%N) = this%atomTypeOfZ(at%Z(1:at%N)) + if (any(atomTypes < 0)) then + bad_i = minloc(atomTypes) + RAISE_ERROR("Some Z mapped to an invalid atom type, e.g. atom "//bad_i(1)//" Z "//at%Z(bad_i(1)), error) + endif + numberAtomTypes = maxval(this%atomTypeOfZ) + + ! register config input information + call kim_api_setm_data_f(this%pkim, kim_error, & + "numberOfParticles", int(1,8), loc(at%N), KIM_L(.true.), & + "coordinates", int(3*at%N,8), loc(at%pos(1,1)), KIM_L(.true.), & + "numberParticleTypes", int(numberAtomTypes,8), loc(numberAtomTypes), KIM_L(.true.), & + "particleTypes", int(at%N,8), loc(atomTypes(1)), KIM_L(.true.)) + ! deal with ghost atoms later (numberOfContributingAtoms) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_setm_data_f for inputs failed", kim_error) /= KIM_STATUS_OK) then + RAISE_ERROR("Failed to setm_data for numberOfParticles, coordinates, particleTypes fields in pkim", error) + endif + + ! it would be nice to know if model outputs are optional or not, so we don't have to allocate them + ! if we don't need to + if (present(e)) then + if (.not. this%kim_model_has_energy) & + call system_abort("IPModel_KIM_calc got energy, but kim model does not return energy") + p_e => e + else + p_e => t_e + endif + if (present(f)) then + if (.not. this%kim_model_has_forces) & + call system_abort("IPModel_KIM_calc got forces, but kim model does not return forces") + p_f => f + else + if (this%kim_model_has_forces) then + allocate(t_f(3, at%N)) + else + allocate(t_f(1, 1)) + endif + p_f => t_f + endif + if (present(local_e)) then + if (.not. this%kim_model_has_particleenergy) & + call system_abort("IPModel_KIM_calc got local_e, but kim model does not return particleEnergy") + p_f => f + else + if (this%kim_model_has_particleenergy) then + allocate(t_local_e(at%N)) + else + allocate(t_local_e(1)) + endif + p_local_e => t_local_e + endif + ! virial is already dealt with because virial_sym needs to be defined separately from virial (6 vs. 3x3) + + ! register config output information + call kim_api_setm_data_f(this%pkim, kim_error, & + "energy", int(1,8), loc(p_e), KIM_L(.true.), & + "particleEnergy", int(at%N,8), loc(p_local_e(1)), KIM_L(.true.), & + "forces", int(3*at%N,8), loc(p_f(1,1)), KIM_L(.true.), & + "virial", int(6,8), loc(virial_sym(1)), KIM_L(.true.)) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_setm_data_f for output failed", kim_error) /= KIM_STATUS_OK) then + RAISE_ERROR("Failed to setm_data for energy, particleEnergy, forces, virial fields in pkim", error) + endif + + ! set compute for config output information + call kim_api_setm_compute_f(this%pkim, kim_error, & + "energy", KIM_COMPUTE_L(present(e)), KIM_L(.true.), & + "particleEnergy", KIM_COMPUTE_L(present(local_e)), KIM_L(.true.), & + "forces", KIM_COMPUTE_L(present(f)), KIM_L(.true.), & + "virial", KIM_COMPUTE_L(present(virial)), KIM_L(.true.)) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_setm_compute_f for outputs failed", kim_error) /= KIM_STATUS_OK) then + RAISE_ERROR("Failed to setm_compute for energy, particleEnergy, forces, virial field in pkim", error) + endif + + ! set data for neighbor stuff + + kim_at => at + + kim_error = kim_api_set_data_f(this%pkim, "neighObject", int(1,8), loc(at%N)) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_set_data_f for neighObject failed", kim_error) /= KIM_STATUS_OK) then + RAISE_ERROR("Failed to create neighObject field in pkim", error) + endif + + kim_error = kim_api_model_compute_f(this%pkim) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_model_compute_f failed", kim_error) /= KIM_STATUS_OK) then + RAISE_ERROR("Failed to compute with KIM Model", error) + endif + + if (present(virial)) then + virial(1,1) = -virial_sym(1) + virial(2,2) = -virial_sym(2) + virial(3,3) = -virial_sym(3) + virial(2,3) = -virial_sym(4) + virial(3,2) = -virial_sym(4) + virial(1,3) = -virial_sym(5) + virial(3,1) = -virial_sym(5) + virial(1,2) = -virial_sym(6) + virial(2,1) = -virial_sym(6) + endif + + deallocate(atomTypes) + if (allocated(t_f)) deallocate(t_f) + if (allocated(t_local_e)) deallocate(t_local_e) + +end subroutine IPModel_KIM_Calc + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of KIM parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_KIM_Print (this, file) + type(IPModel_KIM), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_KIM : KIM", file=file) + call Print("IPModel_KIM : Test name = " // trim(this%KIM_Test_name) // " Model name = " // & + trim(this%KIM_Model_Name) // " cutoff = " // this%cutoff, file=file) + +end subroutine IPModel_KIM_Print + +function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) + character(len=*), intent(in) :: args_str + character(len=*), intent(out) :: extra_calcs_list(:) + integer :: n_extra_calcs + + character(len=STRING_LENGTH) :: extra_calcs_str + type(Dictionary) :: params + + n_extra_calcs = 0 + call initialise(params) + call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") + if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then + if (len_trim(extra_calcs_str) > 0) then + call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") + end if + end if + call finalise(params) + +end function parse_extra_calcs + +subroutine write_test_kim_file_from_model(this, test_kim_es) + type(IPModel_KIM), intent(inout) :: this + type(Extendable_Str) :: test_kim_es + + integer kim_error + integer :: i, str_len + character(len=1) :: model_str_stub(1); pointer(p_model_str, model_str_stub) + + integer :: sec_start, sec_end + character(len=80) :: cur_sec_name + integer :: t_index + integer(kind=kim_intptr) :: t_pkim = 0 + character(len=1000) :: test_model_output + + + p_model_str = kim_api_get_model_kim_str_f(trim(this%KIM_model_name), str_len, kim_error) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_get_model_kim_str failed", kim_error) /= KIM_STATUS_OK) & + call system_abort("Failed to get model .kim string") + + call initialise(test_kim_es) + do i=1, str_len + call concat(test_kim_es, model_str_stub(i), no_trim=.true.) + end do + + ! keep SUPPORTED_ATOM/PARTICLE_TYPES - will fail at compute type if it doesn't match + + ! get rid of MODEL_PARAMETERS section + call find_section(test_kim_es, "MODEL_PARAMETERS", sec_start, sec_end) + if (sec_start > 0) then + call substr_replace(test_kim_es, sec_start, sec_end, "") + endif + + ! set CONVENTIONS section to QUIP's restrictions + call find_section(test_kim_es, "CONVENTIONS", sec_start, sec_end) + if (sec_start > 0) then + call substr_replace(test_kim_es, sec_start, sec_end, & + "CONVENTIONS:"//quip_new_line// & + " OneBasedLists flag"//quip_new_line// & + " Neigh_BothAccess flag"//quip_new_line// & + " NEIGH_RVEC_F flag"//quip_new_line//quip_new_line// & + "################################################################################") + else + call system_abort("write_test_kim_file_from_model failed to find CONVENTIONS section") + endif + + ! set MODEL_INPUT section to what QUIP supports + call find_section(test_kim_es, "MODEL_INPUT", sec_start, sec_end) + if (sec_start > 0) then + call substr_replace(test_kim_es, sec_start, sec_end, & + "MODEL_INPUT:"//quip_new_line// & + "# Name Type Unit Shape Requirements"//quip_new_line// & + "numberOfParticles integer none []"//quip_new_line// & + "numberParticleTypes integer none []"//quip_new_line// & + "particleTypes integer none [numberOfParticles]"//quip_new_line// & + "coordinates real*8 length [numberOfParticles,3]"//quip_new_line// & + "get_neigh method none []"//quip_new_line// & + "neighObject pointer none []"//quip_new_line// & + "#######################################################################################################") + else + call system_abort("write_test_kim_file_from_model failed to find MODEL_INPUT section") + endif + + ! promise to use every model output + kim_error = KIM_API_model_info_f(t_pkim, this%KIM_Model_name) + if (KIM_API_report_error_f(__LINE__, __FILE__, "KIM_API_model_info_f failed", kim_error) /= KIM_STATUS_OK) & + call system_abort("Failed to get info for kim model "//trim(this%KIM_model_name)) + + t_index = KIM_API_get_index_f(t_pkim, "energy", kim_error) + this%kim_model_has_energy = (kim_error == KIM_STATUS_OK) + t_index = KIM_API_get_index_f(t_pkim, "forces", kim_error) + this%kim_model_has_forces = (kim_error == KIM_STATUS_OK) + t_index = KIM_API_get_index_f(t_pkim, "particleEnergy", kim_error) + this%kim_model_has_particleenergy = (kim_error == KIM_STATUS_OK) + t_index = KIM_API_get_index_f(t_pkim, "virial", kim_error) + this%kim_model_has_virial = (kim_error == KIM_STATUS_OK) + + test_model_output = & + "destroy method none []"//quip_new_line// & + "compute method none []"//quip_new_line// & + "cutoff real*8 length []"//quip_new_line + if (this%kim_model_has_energy) & + test_model_output = trim(test_model_output)// & + "energy real*8 energy []"//quip_new_line + if (this%kim_model_has_forces) & + test_model_output = trim(test_model_output)// & + "forces real*8 force [numberOfParticles,3]"//quip_new_line + if (this%kim_model_has_particleenergy) & + test_model_output = trim(test_model_output)// & + "particleEnergy real*8 energy [numberOfParticles]"//quip_new_line + if (this%kim_model_has_virial) & + test_model_output = trim(test_model_output)// & + "virial real*8 energy [6]"//quip_new_line + + call find_section(test_kim_es, "MODEL_OUTPUT", sec_start, sec_end) + if (sec_start > 0) then + call substr_replace(test_kim_es, sec_start, sec_end, & + "MODEL_OUTPUT:"//quip_new_line// & + "# Name Type Unit Shape "//quip_new_line// & + trim(test_model_output)// & + "#######################################################################################################") + else + call system_abort("write_test_kim_file_from_model failed to find MODEL_OUTPUT section") + endif + +end subroutine write_test_kim_file_from_model + +subroutine find_section(test_kim_es, sec_name, sec_start, sec_end) + type(Extendable_Str) :: test_kim_es + character(len=*), intent(in) :: sec_name + integer, intent(out) :: sec_start, sec_end + + integer :: cur_sec_loc, next_sec_loc + character(len=80) :: cur_sec_name + + sec_start = -1 + sec_end = -1 + + cur_sec_loc = find_section_label(test_kim_es, 1, cur_sec_name) + do while (cur_sec_loc > 0) + if (trim(cur_sec_name) == trim(sec_name)) then + sec_start = cur_sec_loc + next_sec_loc = find_section_label(test_kim_es, cur_sec_loc+len_trim(cur_sec_name)+1) + if (next_sec_loc <= 0) then + sec_end = test_kim_es%len + else + sec_end = next_sec_loc - 2 + endif + return + endif + cur_sec_loc = find_section_label(test_kim_es, cur_sec_loc+len_trim(cur_sec_name)+1, cur_sec_name) + end do + +end subroutine find_section + +function find_section_label(test_kim_es, start, sec_name) result(sec_loc) + type(Extendable_Str) :: test_kim_es + integer, intent(in) :: start + character(len=*), optional :: sec_name + integer :: sec_loc + + integer :: i + logical :: after_newline, in_section, is_newline, is_section_char, is_section_end + character(len=80) :: t_sec_name + + after_newline = (start == 1) + + sec_loc = -1 + in_section = .false. + do i=start, test_kim_es%len + is_newline = (substr(test_kim_es,i,i) == quip_new_line) + is_section_char = (scan(substr(test_kim_es,i,i),"ABCDEFGHIJKLMNOPQRSTUVWXYZ_") > 0) + is_section_end = (substr(test_kim_es,i,i) == ':') + if (after_newline) then + if (is_section_char) then + in_section = .true. + t_sec_name = substr(test_kim_es, i, i) + endif + else ! not after newline + if (in_section) then + if (is_section_end) then + sec_loc = i-len_trim(t_sec_name) + if (present(sec_name)) sec_name = trim(t_sec_name) + return + else if (is_section_char) then + t_sec_name = trim(t_sec_name) // substr(test_kim_es, i, i) + else + sec_loc = -1 + in_section = .false. + endif + endif + endif + after_newline = is_newline + end do + + sec_loc = -1 + in_section = .false. + +end function find_section_label + +function KIM_L(l) + logical, intent(in) :: l + integer :: KIM_L + + if (l) then + KIM_L = 1 + else + KIM_L = 0 + endif +end function KIM_L + +function KIM_COMPUTE_L(l) + logical, intent(in) :: l + integer :: KIM_COMPUTE_L + + if (l) then + KIM_COMPUTE_L = KIM_COMPUTE_TRUE + else + KIM_COMPUTE_L = KIM_COMPUTE_FALSE + endif +end function KIM_COMPUTE_L + +end module IPModel_KIM_module diff --git a/src/Potentials/IPModel_LJ.F90 b/src/Potentials/IPModel_LJ.F90 new file mode 100644 index 0000000000..f3a694c144 --- /dev/null +++ b/src/Potentials/IPModel_LJ.F90 @@ -0,0 +1,747 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_LJ module +!X +!% Module for Lennard-Jones pair potential. +!% \begin{equation} +!% \nonumber +!% V(r) = 4 \epsilon \left[ \left( \frac{\sigma}{r} \right)^{12} - \left( \frac{\sigma}{r} \right)^6 \right] +!% \end{equation} +!% For parameters see Ashcroft and Mermin, {\it Solid State Physics}. +!% +!% NB: The energy calculation in the code is +!% \begin{equation*} +!% V(r) = \epsilon_{12} (\sigma/r)^{12} - \epsilon_6 (\sigma/r)^6 +!% \end{equation*} +!% (plus energy and linear force shift, if applicable) +!% hence the factor 4 has to be included in the potential XML file. +!% +!% If requested, tail corrections are added for all pairs with a +!% nonzero $\epsilon_6$ (i.e. a nonzero sixth-power tail). This +!% requires all such pairs to have equal cutoffs and smooth cutoff +!% widths. See the documentation for the 'DispTS' potential for +!% more information on how these corrections are computed in QUIP. +!% +!% The IPModel_LJ object contains all the parameters read from a +!% 'LJ_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_LJ_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use units_module, only : PI +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_LJ +type IPModel_LJ + integer :: n_types = 0 !% Number of atomic types. + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + real(dp), allocatable :: sigma(:,:), eps6(:,:), eps12(:,:), cutoff_a(:,:), energy_shift(:,:), linear_force_shift(:,:), smooth_cutoff_width(:,:) !% IP parameters. + real(dp) :: tail_corr_smooth_factor + real(dp) :: tail_corr_const + real(dp), allocatable :: tail_c6_coeffs(:,:) + logical :: only_inter_resid = .false. + logical :: do_tail_corrections = .false. + logical :: tail_smooth_cutoff = .false. + + character(len=STRING_LENGTH) label + +end type IPModel_LJ + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_LJ), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_LJ_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_LJ_Finalise +end interface Finalise + +interface Print + module procedure IPModel_LJ_Print +end interface Print + +interface Calc + module procedure IPModel_LJ_Calc +end interface Calc + +contains + +subroutine IPModel_LJ_Initialise_str(this, args_str, param_str) + type(IPModel_LJ), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + real(dp) :: tc_cutoff = -1.0_dp + real(dp) :: tc_ctw = -1.0_dp + integer :: ti,tj + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label = '' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LJ_Initialise_str args_str')) then + call system_abort("IPModel_LJ_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_LJ_read_params_xml(this, param_str) + + this%cutoff = maxval(this%cutoff_a) + + ! Check whether we can even do tail corrections, then set up the constants + if (this%do_tail_corrections) then + tc_cutoff = -1.0_dp + allocate(this%tail_c6_coeffs(this%n_types, this%n_types)) + do ti = 1,this%n_types + do tj = ti,this%n_types + if (this%eps6(ti,tj) .fne. 0.0_dp) then + + if ((this%energy_shift(ti,tj) .fne. 0.0_dp) .or. & + (this%linear_force_shift(ti,tj) .fne. 0.0_dp)) then + call system_abort("IPModel_LJ_Initialise_str: Tail corrections not implemented with & + energy or force shifts") + endif + + if (tc_cutoff .feq. -1.0_dp) then + tc_cutoff = this%cutoff_a(ti,tj) + tc_ctw = this%smooth_cutoff_width(ti,tj) + else if (this%cutoff_a(ti,tj) .fne. tc_cutoff) then + call system_abort("IPModel_LJ_Initialise_str: Tail corrections require all & + cutoffs to be equal; " // this%cutoff_a(ti,tj) //" =/= "// tc_cutoff) + else if (this%smooth_cutoff_width(ti,tj) .fne. tc_ctw) then + call system_abort("IPModel_LJ_Initialise_str: Tail corrections require all & + cutoff transition widths to be equal; " // this%smooth_cutoff_width(ti,tj) //" =/= "// tc_ctw) + endif + this%tail_c6_coeffs(ti,tj) = this%eps6(ti,tj) * this%sigma(ti,tj)**6 + else + this%tail_c6_coeffs(ti,tj) = 0.0_dp + endif + this%tail_c6_coeffs(tj,ti) = this%tail_c6_coeffs(ti,tj) + enddo + enddo + if (tc_cutoff .fgt. 0.0_dp) then + if (tc_ctw .fgt. 0.0_dp) then + this%tail_smooth_cutoff = .true. + this%tail_corr_const = -2.0_dp * PI / 3.0_dp * & + ((1.0_dp - this%tail_corr_smooth_factor) / (tc_cutoff - tc_ctw)**3 & + + this%tail_corr_smooth_factor / tc_cutoff**3) + else + this%tail_smooth_cutoff = .false. + this%tail_corr_const = -2.0_dp * PI / 3.0_dp / tc_cutoff**3 + endif + else + this%tail_corr_const = 0.0_dp + this%do_tail_corrections = .false. + endif + endif + +end subroutine IPModel_LJ_Initialise_str + +subroutine IPModel_LJ_Finalise(this) + type(IPModel_LJ), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%sigma)) deallocate(this%sigma) + if (allocated(this%eps6)) deallocate(this%eps6) + if (allocated(this%eps12)) deallocate(this%eps12) + if (allocated(this%cutoff_a)) deallocate(this%cutoff_a) + if (allocated(this%energy_shift)) deallocate(this%energy_shift) + if (allocated(this%linear_force_shift)) deallocate(this%linear_force_shift) + if (allocated(this%smooth_cutoff_width)) deallocate(this%smooth_cutoff_width) + if (allocated(this%tail_c6_coeffs)) deallocate(this%tail_c6_coeffs) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_LJ_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_LJ_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_LJ), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), pointer :: w_e(:) + integer i, ji, j, ti, tj, d + real(dp) :: dr(3), dr_mag + real(dp) :: de, de_dr + logical :: i_is_min_image + + integer :: i_calc, n_extra_calcs + character(len=20) :: extra_calcs_list(10) + + logical :: do_flux = .false. + real(dp), pointer :: velo(:,:) + real(dp) :: flux(3) + + integer, pointer :: resid(:) + real(dp) :: c6_sum, tail_correction + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_LJ_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_LJ_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_LJ_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_LJ_Calc: local_virial calculation requested but not supported yet.", error) + endif + + if (this%only_inter_resid) then + if (.not. assign_pointer(at, "resid", resid)) then + RAISE_ERROR("IPModel_LJ_Calc calculation with only_inter_resid=T requires resid field", error) + endif + end if + + if (present(args_str)) then + if (len_trim(args_str) > 0) then + n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) + if (n_extra_calcs > 0) then + do i_calc=1, n_extra_calcs + select case(trim(extra_calcs_list(i_calc))) + case("flux") + if (.not. assign_pointer(at, "velo", velo)) then + RAISE_ERROR("IPModel_LJ_Calc Flux calculation requires velo field", error) + endif + do_flux = .true. + flux = 0.0_dp + case default + RAISE_ERROR("Unsupported extra_calc '"//trim(extra_calcs_list(i_calc))//"'", error) + end select + end do + endif ! n_extra_calcs + endif ! len_trim(args_str) + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LJ_Calc args_str')) then + RAISE_ERROR("IPModel_LJ_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_LJ_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_LJ_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + endif ! present(args_str) + + if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) + + c6_sum = 0.0_dp + do i = 1, at%N + i_is_min_image = is_min_image(at,i) + + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + ! Might be optimized if we have only_inter_resid=F + ! Can then just count number of pairs of each type + if (this%do_tail_corrections) then + do j = i+1, at%N + if (this%only_inter_resid) then + if (resid(i) == resid(j)) cycle + endif + tj = get_type(this%type_of_atomic_num, at%Z(j)) + if (this%tail_c6_coeffs(tj,ti) .fne. 0.0_dp) then + c6_sum = c6_sum + 2*this%tail_c6_coeffs(tj,ti) + endif + enddo + endif + + do ji = 1, n_neighbours(at, i) + j = neighbour(at, i, ji, dr_mag, cosines = dr) + + if (dr_mag .feq. 0.0_dp) cycle + !if ((i < j) .and. i_is_min_image) cycle + if ((i < j)) cycle + + if (this%only_inter_resid) then + if (resid(i) == resid(j)) cycle + end if + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (present(e) .or. present(local_e)) then + de = IPModel_LJ_pairenergy(this, ti, tj, dr_mag) + + if (present(local_e)) then + local_e(i) = local_e(i) + 0.5_dp*de + !if(i_is_min_image) local_e(j) = local_e(j) + 0.5_dp*de + if(i/=j) local_e(j) = local_e(j) + 0.5_dp*de + endif + if (present(e)) then + if (associated(w_e)) then + de = de*0.5_dp*(w_e(i)+w_e(j)) + endif + !if(i_is_min_image) then + ! e = e + de + !else + if(i==j) then + e = e + 0.5_dp*de + else + e = e + de + endif + !endif + endif + endif + if (present(f) .or. present(virial) .or. do_flux) then + de_dr = IPModel_LJ_pairenergy_deriv(this, ti, tj, dr_mag) + if (associated(w_e)) then + de_dr = de_dr*0.5_dp*(w_e(i)+w_e(j)) + endif + if (present(f)) then + f(:,i) = f(:,i) + de_dr*dr + !if(i_is_min_image) f(:,j) = f(:,j) - de_dr*dr + if(i/=j) f(:,j) = f(:,j) - de_dr*dr + endif + if (do_flux) then + ! -0.5 (v_i + v_j) . F_ij * dr_ij + flux = flux - 0.5_dp*sum((velo(:,i)+velo(:,j))*(de_dr*dr))*(dr*dr_mag) + endif + if (present(virial)) then + !if(i_is_min_image) then + ! virial = virial - de_dr*(dr .outer. dr)*dr_mag + !else + if(i==j) then + virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*dr_mag + else + virial = virial - de_dr*(dr .outer. dr)*dr_mag + endif + !endif + endif + endif + end do + end do + + if (this%do_tail_corrections) then + tail_correction = c6_sum * this%tail_corr_const / cell_volume(at) + if (present(e)) e = e + tail_correction + if (present(virial)) then + do d = 1, 3 + if (this%tail_smooth_cutoff) then + ! Seems counterintuitive, but the math works out (for r^-6 potentials) + virial(d,d) = virial(d,d) + tail_correction + else + virial(d,d) = virial(d,d) + 2*tail_correction + endif + enddo + endif + endif + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(f)) call sum_in_place(mpi, f) + endif + if (do_flux) then + flux = flux / cell_volume(at) + if (present(mpi)) call sum_in_place(mpi, flux) + call set_value(at%params, "Flux", flux) + endif + +end subroutine IPModel_LJ_Calc + +!% This routine computes the two-body term for a pair of atoms separated by a distance r. +function IPModel_LJ_pairenergy(this, ti, tj, r) + type(IPModel_LJ), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_LJ_pairenergy + + real(dp) :: tpow + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then + IPModel_LJ_pairenergy = 0.0_dp + return + endif + + tpow = (this%sigma(ti,tj)/r)**6 + + IPModel_LJ_pairenergy = (this%eps12(ti,tj)*tpow*tpow - this%eps6(ti,tj)*tpow) - this%energy_shift(ti,tj) - & + & this%linear_force_shift(ti,tj)*(r-this%cutoff_a(ti,tj)) + + if (.not. (this%smooth_cutoff_width(ti,tj) .feq. 0.0_dp)) then + IPModel_LJ_pairenergy = IPModel_LJ_pairenergy*poly_switch(r,this%cutoff_a(ti,tj),this%smooth_cutoff_width(ti,tj)) + end if + +end function IPModel_LJ_pairenergy + +!% Derivative of the two-body term. +function IPModel_LJ_pairenergy_deriv(this, ti, tj, r) + type(IPModel_LJ), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_LJ_pairenergy_deriv + + real(dp) :: tpow + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then + IPModel_LJ_pairenergy_deriv = 0.0_dp + return + endif + + tpow = (this%sigma(ti,tj)/r)**6 + + IPModel_LJ_pairenergy_deriv = (-12.0_dp*this%eps12(ti,tj)*tpow*tpow + 6.0_dp*this%eps6(ti,tj)*tpow)/r - this%linear_force_shift(ti,tj) + + if (.not. (this%smooth_cutoff_width(ti,tj) .feq. 0.0_dp)) then + IPModel_LJ_pairenergy_deriv = IPModel_LJ_pairenergy_deriv * poly_switch(r,this%cutoff_a(ti,tj),this%smooth_cutoff_width(ti,tj)) & + +IPModel_LJ_pairenergy(this, ti, tj, r) * dpoly_switch(r,this%cutoff_a(ti,tj),this%smooth_cutoff_width(ti,tj)) + + end if + +end function IPModel_LJ_pairenergy_deriv + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for XML stanza is given below, please notice that +!% they are simply dummy parameters for testing purposes, with no physical meaning. +!% +!%> +!%> +!%> +!%> eps12="1.0" cutoff="6.0" energy_shift="T" linear_force_shift="F" /> +!%> eps12="2.0" cutoff="7.5" energy_shift="T" linear_force_shift="F" /> +!%> eps12="1.5" cutoff="6.75" energy_shift="T" linear_force_shift="F" /> +!%> +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + logical :: energy_shift, linear_force_shift,smooth_cutoff_width + integer :: ti, tj + + if (name == 'LJ_params') then ! new LJ stanza + + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered LJ_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in LJ_params") + endif + + call QUIP_FoX_get_value(attributes, 'only_inter_resid', value, status) + if (status == 0) then + read (value, *) parse_ip%only_inter_resid + else + parse_ip%only_inter_resid = .false. + endif + + call QUIP_FoX_get_value(attributes, 'tail_corr_factor', value, status) + if (status == 0) then + read (value, *) parse_ip%tail_corr_smooth_factor + parse_ip%do_tail_corrections = .true. + else + parse_ip%do_tail_corrections = .false. + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%sigma(parse_ip%n_types,parse_ip%n_types)) + parse_ip%sigma = 1.0_dp + allocate(parse_ip%eps6(parse_ip%n_types,parse_ip%n_types)) + parse_ip%eps6 = 0.0_dp + allocate(parse_ip%eps12(parse_ip%n_types,parse_ip%n_types)) + parse_ip%eps12 = 0.0_dp + allocate(parse_ip%cutoff_a(parse_ip%n_types,parse_ip%n_types)) + parse_ip%cutoff_a = 0.0_dp + allocate(parse_ip%energy_shift(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%linear_force_shift(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%smooth_cutoff_width(parse_ip%n_types,parse_ip%n_types)) + parse_ip%energy_shift = 0.0_dp + parse_ip%linear_force_shift = 0.0_dp + parse_ip%smooth_cutoff_width = 0.0_dp + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find type") + read (value, *) ti + + if (ti < 1) call system_abort("IPModel_LJ_read_params_xml got per_type_data type="//ti//" < 1") + if (ti > parse_ip%n_types) call system_abort("IPModel_LJ_read_params_xml got per_type_data type="//ti//" > n_types="//parse_ip%n_types) + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + parse_ip%energy_shift = 0.0_dp + parse_ip%linear_force_shift = 0.0_dp + parse_ip%smooth_cutoff_width = 0.0_dp + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "type1", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find type1") + read (value, *) ti + call QUIP_FoX_get_value(attributes, "type2", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find type2") + read (value, *) tj + + if (ti < 1) call system_abort("IPModel_LJ_read_params_xml got per_type_data type1="//ti//" < 1") + if (ti > parse_ip%n_types) call system_abort("IPModel_LJ_read_params_xml got per_pair_data type1="//ti//" > n_types="//parse_ip%n_types) + if (tj < 1) call system_abort("IPModel_LJ_read_params_xml got per_type_data type2="//tj//" < 1") + if (tj > parse_ip%n_types) call system_abort("IPModel_LJ_read_params_xml got per_pair_data type2="//tj//" > n_types="//parse_ip%n_types) + + call QUIP_FoX_get_value(attributes, "sigma", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find sigma") + read (value, *) parse_ip%sigma(ti,tj) + call QUIP_FoX_get_value(attributes, "eps6", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find eps6") + read (value, *) parse_ip%eps6(ti,tj) + call QUIP_FoX_get_value(attributes, "eps12", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find eps12") + read (value, *) parse_ip%eps12(ti,tj) + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff_a(ti,tj) + + call QUIP_FoX_get_value(attributes, "energy_shift", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find energy_shift") + read (value, *) energy_shift + if (energy_shift) parse_ip%energy_shift(ti,tj) = IPModel_LJ_pairenergy(parse_ip, ti, tj, parse_ip%cutoff_a(ti,tj)) + + call QUIP_FoX_get_value(attributes, "linear_force_shift", value, status) + if (status /= 0) call system_abort ("IPModel_LJ_read_params_xml cannot find linear_force_shift") + read (value, *) linear_force_shift + if (linear_force_shift) parse_ip%linear_force_shift(ti,tj) = IPModel_LJ_pairenergy_deriv(parse_ip, ti, tj, parse_ip%cutoff_a(ti,tj)) + + call QUIP_FoX_get_value(attributes, "smooth_cutoff_width", value, status) + if (status == 0) read (value, *) parse_ip%smooth_cutoff_width(ti,tj) + + if (ti /= tj) then + parse_ip%eps6(tj,ti) = parse_ip%eps6(ti,tj) + parse_ip%eps12(tj,ti) = parse_ip%eps12(ti,tj) + parse_ip%sigma(tj,ti) = parse_ip%sigma(ti,tj) + parse_ip%cutoff_a(tj,ti) = parse_ip%cutoff_a(ti,tj) + parse_ip%energy_shift(tj,ti) = parse_ip%energy_shift(ti,tj) + parse_ip%linear_force_shift(tj,ti) = parse_ip%linear_force_shift(ti,tj) + parse_ip%smooth_cutoff_width(tj,ti) = parse_ip%smooth_cutoff_width(ti,tj) + end if + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'LJ_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_LJ_read_params_xml(this, param_str) + type(IPModel_LJ), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_LJ_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_LJ_read_params_xml + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of LJ parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_LJ_Print (this, file) + type(IPModel_LJ), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_LJ : Lennard-Jones", file=file) + call Print("IPModel_LJ : n_types = " // this%n_types // " cutoff = " // this%cutoff // & + " only_inter_resid = " // this%only_inter_resid // " do_tail_corrections = " // this%do_tail_corrections, file=file) + + do ti=1, this%n_types + call Print ("IPModel_LJ : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + do tj=1, this%n_types + call Print ("IPModel_LJ : interaction " // ti // " " // tj // " sigma " // this%sigma(ti,tj) // " eps6,12 " // & + this%eps6(ti,tj) // " " // this%eps12(ti,tj) // " cutoff_a " // this%cutoff_a(ti,tj) // " energy_shift " // & + this%energy_shift(ti,tj) // " linear_force_shift " // this%linear_force_shift(ti,tj) // & + " smooth_cutoff_width " // this%smooth_cutoff_width(ti,tj) , file=file) + end do + call verbosity_pop() + end do + +end subroutine IPModel_LJ_Print + +function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) + character(len=*), intent(in) :: args_str + character(len=*), intent(out) :: extra_calcs_list(:) + integer :: n_extra_calcs + + character(len=STRING_LENGTH) :: extra_calcs_str + type(Dictionary) :: params + + n_extra_calcs = 0 + call initialise(params) + call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") + if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then + if (len_trim(extra_calcs_str) > 0) then + call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") + end if + end if + call finalise(params) + +end function parse_extra_calcs + +end module IPModel_LJ_module diff --git a/src/Potentials/IPModel_LMTO_TBE.F90 b/src/Potentials/IPModel_LMTO_TBE.F90 new file mode 100644 index 0000000000..9d64b9dbc0 --- /dev/null +++ b/src/Potentials/IPModel_LMTO_TBE.F90 @@ -0,0 +1,362 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_LMTO_TBE +!X +!% Interface to empirical Tight Binding code within LM suite +!% (https://bitbucket.org/lmto/lm/branch/libtbe) +!% +!% Requires linking with LMTO code (HAVE_LMTO_TBE=1 in Makefile.inc). +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_LMTO_TBE_module + +use error_module +use units_module, only: RYDBERG, BOHR +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +#ifdef HAVE_LMTO_TBE +use libtbe, only: tbinit, tbsc +#endif + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_LMTO_TBE +type IPModel_LMTO_TBE + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + real(dp) :: cutoff = 0.0_dp !% cutoff is always zero as LMTO code does its own neighbour calculation + character(len=STRING_LENGTH) :: label, control_file + type(Atoms) :: oldat + +end type IPModel_LMTO_TBE + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_LMTO_TBE), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_LMTO_TBE_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_LMTO_TBE_Finalise +end interface Finalise + +interface Print + module procedure IPModel_LMTO_TBE_Print +end interface Print + +interface Calc + module procedure IPModel_LMTO_TBE_Calc +end interface Calc + +contains + +subroutine IPModel_LMTO_TBE_Initialise_str(this, args_str, param_str) + type(IPModel_LMTO_TBE), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LMTO_TBE_Initialise_str args_str')) then + call system_abort("IPModel_LMTO_TBE_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_LMTO_TBE_read_params_xml(this, param_str) + +#ifdef HAVE_LMTO_TBE + call tbinit(this%control_file) +#else + call system_abort("IPModel_LMTO_TBE can only be used when compiled with HAVE_LMTO_TBE enabled") +#endif + + +end subroutine IPModel_LMTO_TBE_Initialise_str + +subroutine IPModel_LMTO_TBE_Finalise(this) + type(IPModel_LMTO_TBE), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_LMTO_TBE_Finalise + + +subroutine IPModel_LMTO_TBE_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_LMTO_TBE), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer i + logical :: reorder = .false. + integer, allocatable :: atypes(:) + real(dp), allocatable :: force(:,:), atpos(:,:) + real(dp) :: energy, atlattice(3,3) + integer, pointer :: index(:), oldindex(:) + + INIT_ERROR(error) + +#ifdef HAVE_LMTO_TBE + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_LMTO_TBE_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_LMTO_TBE_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_LMTO_TBE_Calc', error) + local_virial = 0.0_dp + endif + + ! check if Atoms is "equivalent" (isoatomic) to previous Atoms + ! if not we need to re-initialise the TB code + if (at%n /= this%oldat%n) then + call print('LMTO_TBE_Calc: natoms changed, reordering') + reorder = .true. + else if (maxval(abs(at%lattice - this%oldat%lattice)) > 1e-7_dp) then + call print('LMTO_TBE_Calc: lattice components changed, reordering') + reorder = .true. + else if (any(at%z /= this%oldat%z)) then + call print('LMTO_TBE_Calc: atomic numbers changed, reordering') + reorder = .true. + else if (has_property(at, 'index')) then + ! clusters have an 'index' property that points back to original atom + if (has_property(this%oldat, 'index')) then + call assign_property_pointer(at, 'index', index, error) + PASS_ERROR(error) + call assign_property_pointer(this%oldat, 'index', oldindex, error) + PASS_ERROR(error) + if (any(index /= oldindex)) then + call print('LMTO_TBE_Calc: atomic numbers changed, reordering') + reorder = .true. + end if + else + call print('LMTO_TBE_Calc: new atoms has "index" property, old does not, reordering') + reorder = .true. + end if + end if + + allocate(atypes(at%n), force(3, at%n), atpos(3, at%n)) + do i=1, at%N + atypes(i) = get_type(this%type_of_atomic_num, at%Z(i)) + end do + + call print('LMTO_TBE_Calc: invoking tbsc() on '//at%n//' atoms with reorder='//reorder) + + atlattice = at%lattice/BOHR + atpos = at%pos/BOHR + ! libtbe expects the force to be initialised as it will accumulate forces + force = 0.0_dp + + call tbsc(atlattice, at%n, atpos, atypes, energy, force, & + reorder=reorder, incomm=mpi%communicator) + if (present(e)) then + e = energy*RYDBERG + end if + if (present(f)) then + f = force*(RYDBERG/BOHR) + end if + + deallocate(atypes, force, atpos) + + call atoms_copy_without_connect(this%oldat, at) +#else + RAISE_ERROR("IPModel_LMTO_TBE_Calc() called but LMTO_TBE support not compiled in", error) +#endif + +end subroutine IPModel_LMTO_TBE_Calc + + +subroutine IPModel_LMTO_TBE_Print(this, file) + type(IPModel_LMTO_TBE), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_LMTO_TBE : LMTO_TBE Potential", file=file) + call Print("IPModel_LMTO_TBE : n_types = " // this%n_types, file=file) + + do ti=1, this%n_types + call Print ("IPModel_LMTO_TBE : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_LMTO_TBE", file=file) + call verbosity_pop() + end do + +end subroutine IPModel_LMTO_TBE_Print + +subroutine IPModel_LMTO_TBE_read_params_xml(this, param_str) + type(IPModel_LMTO_TBE), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_LMTO_TBE_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_LMTO_TBE_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + integer ti + + if (name == 'LMTO_TBE_params') then ! new LMTO_TBE stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in LMTO_TBE_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + call QUIP_FoX_get_value(attributes, "control_file", value, status) + if (status /= 0) call system_abort ("IPModel_LMTO_TBE_read_params_xml cannot find control_file") + read (value, *) parse_ip%control_file + + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_LMTO_TBE_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_LMTO_TBE_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'LMTO_TBE_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_LMTO_TBE_module diff --git a/src/Potentials/IPModel_LinearSOAP.F90 b/src/Potentials/IPModel_LinearSOAP.F90 new file mode 100644 index 0000000000..b94909ab8d --- /dev/null +++ b/src/Potentials/IPModel_LinearSOAP.F90 @@ -0,0 +1,535 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_LinearSOAP module +!X +!% Module for a Linear SOAP potential. +!% \begin{equation} +!% \nonumber +!% E = \sum_i \beta \cdot p_{ss'nn'l,i} +!% \end{equation} +!% where $p_{ss'nn'l,i}$ is the SOAP sphericial power spectrum of atom i, and +!% $\beta$ is a vector of coefficients. +!% +!% The IPModel_LinearSOAP object contains all the parameters read from a +!% 'LinearSOAP_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_LinearSOAP_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +#ifdef HAVE_GAP +use descriptors_module +#endif +use mpi_context_module +use QUIP_Common_module +use extendable_str_module + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_LinearSOAP +type IPModel_LinearSOAP + integer :: n_types = 0 !% Number of atomic types. + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + real(dp) :: atom_sigma = 0.0_dp !% atom_sigma to be passed to SOAP + integer :: l_max = 0 + integer :: n_max = 0 + integer :: pissnl_dimension !% actual dimension of fit. + real(dp), allocatable :: e0(:) !% energy shift per atom + real(dp), allocatable :: beta(:,:) !% pissnl coefficients. size is the maximum of the pissnl_dimensions over all species + + character(len=STRING_LENGTH) label + +end type IPModel_LinearSOAP + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_LinearSOAP), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_LinearSOAP_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_LinearSOAP_Finalise +end interface Finalise + +interface Print + module procedure IPModel_LinearSOAP_Print +end interface Print + +interface Calc + module procedure IPModel_LinearSOAP_Calc +end interface Calc + +contains + +subroutine IPModel_LinearSOAP_Initialise_str(this, args_str, param_str) + type(IPModel_LinearSOAP), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + +! now initialise the potential +#ifndef HAVE_GAP + call system_abort('IPModel_LinearSOAP_Initialise_str: must be compiled with HAVE_GAP') +#else + + call initialise(params) + this%label = '' + call param_register(params, 'label', '', this%label, help_string="XML label of the potential") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LinearSOAP_Initialise_str args_str')) then + call system_abort("IPModel_LinearSOAP_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_LinearSOAP_read_params_xml(this, param_str) +#endif +end subroutine IPModel_LinearSOAP_Initialise_str + +subroutine IPModel_LinearSOAP_Finalise(this) + type(IPModel_LinearSOAP), intent(inout) :: this + +#ifdef HAVE_GAP + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%beta)) deallocate(this%beta) + if (allocated(this%e0)) deallocate(this%e0) + + this%n_types = 0 + this%label = '' + +#endif +end subroutine IPModel_LinearSOAP_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_LinearSOAP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_LinearSOAP), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + +#ifdef HAVE_GAP + + integer i, atomtype, d + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale, e_i + logical :: do_rescale_r, do_rescale_E + + logical, dimension(:), allocatable :: mpi_local_mask + real(dp), dimension(:), allocatable :: local_e_in + logical, dimension(:), pointer :: atom_mask_pointer + + type(descriptor), dimension(:), allocatable :: my_descriptor + type(descriptor_data) :: my_descriptor_data + type(extendable_str) :: Zstring + type(extendable_str) :: my_args_str + + + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_LinearSOAP_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_LinearSOAP_Calc', error) + f = 0.0_dp + RAISE_ERROR("IPModel_LinearSOAP_Calc: force calculation requested but not supported yet.", error) + end if + if (present(virial)) then + virial = 0.0_dp + RAISE_ERROR("IPModel_LinearSOAP_Calc: virial calculation requested but not supported yet.", error) + end if + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_LinearSOAP_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_LinearSOAP_Calc: local_virial calculation requested but not supported yet.", error) + endif + + + allocate(local_e_in(at%N)) + local_e_in = 0.0_dp + + atom_mask_pointer => null() + has_atom_mask_name = .false. + atom_mask_name = "" + + + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_LinearSOAP_Calc args_str')) then + RAISE_ERROR("IPModel_LinearSOAP_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + + if(has_atom_mask_name) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_GAP_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + else + atom_mask_pointer => null() + endif + + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_LinearSOAP_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + my_args_str = trim(args_str) + else + call initialise(my_args_str) + endif ! present(args_str) + + + + allocate(my_descriptor(this%n_types)) + + + ! compute descriptors for all atoms in the cell + + call initialise(Zstring) + call concat(Zstring," species_Z={") + do atomtype=1,this%n_types + call concat(Zstring, " "//this%atomic_num(atomtype)) + end do + call concat(Zstring, "} ") + + if( present(mpi) ) then + if(mpi%active) then + if(has_atom_mask_name) then + RAISE_ERROR("IPModel_GAP: atom_mask_name "//trim(atom_mask_name)//" present while running MPI version."// \ + "The use of atom_mask_name is intended for serial-compiled code called from an external parallel code, such as LAMMPS",error) + endif + + if( has_property(at,"mpi_local_mask") ) then + RAISE_ERROR("IPModel_GAP: mpi_local_mask property already present", error) + endif + + allocate(mpi_local_mask(at%N)) + call add_property_from_pointer(at,'mpi_local_mask',mpi_local_mask,error=error) + + call concat(my_args_str," atom_mask_name=mpi_local_mask") + endif + endif + + + do atomtype=1,this%n_types + call initialise(my_descriptor(atomtype),"soap cutoff="//this%cutoff//" n_max="//this%n_max//" l_max="//this%l_max//" atom_sigma="//this%atom_sigma//" n_species="//this%n_types//" Z="//this%atomic_num(atomtype)//Zstring//" "//string(my_args_str)) + + if(mpi%active) call descriptor_MPI_setup(my_descriptor(atomtype),at,mpi,mpi_local_mask,error) + + d = descriptor_dimensions(my_descriptor(atomtype)) + + ! compute descriptors for this atom type center + call calc(my_descriptor(atomtype),at,my_descriptor_data, & + do_descriptor=.true.,do_grad_descriptor=.false., & + args_str=trim(string(my_args_str)), error=error) + PASS_ERROR(error) + + ! this loop is over the found descriptors, i.e. all atoms of the current type + do i=1,size(my_descriptor_data%x) + + !beta . pissnl + e_i = sum(this%beta(:,atomtype) * my_descriptor_data%x(i)%data(:)) + + local_e_in(my_descriptor_data%x(i)%ci(1)) = e_i + end do + + call finalise(my_descriptor_data) + end do + + ! + ! collect data and cleanup + + if(present(e)) e = sum(local_e_in) + if(present(local_e)) local_e = local_e_in + + if (present(mpi)) then + if( mpi%active ) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(f)) call sum_in_place(mpi, f) + + call remove_property(at,'mpi_local_mask', error=error) + deallocate(mpi_local_mask) + end if + endif + + ! cleanup + if(allocated(local_e_in)) deallocate(local_e_in) + +#endif + +end subroutine IPModel_LinearSOAP_Calc + + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for XML stanza is given below, please notice that +!% they are simply dummy parameters for testing purposes, with no physical meaning. +!% +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + +#ifdef HAVE_GAP + integer :: status + character(len=1024) :: value + + integer :: ti, atomtype, i + real(dp) :: v + + if (name == 'LinearSOAP_params') then ! new LinearSOAP stanza + + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered LinearSOAP_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in LinearSOAP_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%e0(parse_ip%n_types)) + parse_ip%e0 = 0.0_dp + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(108)) + parse_ip%type_of_atomic_num = 0 + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "atomtype", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find atomtype") + read (value, *) ti + + if (ti < 1) call system_abort("IPModel_LinearSOAP_read_params_xml got per_type_data type="//ti//" < 1") + if (ti > parse_ip%n_types) call system_abort("IPModel_LinearSOAP_read_params_xml got per_type_data type="//ti//" > n_types="//parse_ip%n_types) + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + + call QUIP_FoX_get_value(attributes, "e0", value, status) + if(status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find e0") + read (value, *) parse_ip%e0(ti) + + + elseif (parse_in_ip .and. name == 'params') then + + call QUIP_FoX_get_value(attributes, "l_max", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find l_max") + read (value, *) parse_ip%l_max + + call QUIP_FoX_get_value(attributes, "n_max", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find n_max") + read (value, *) parse_ip%n_max + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + + call QUIP_FoX_get_value(attributes, "atom_sigma", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find atom_sigma") + read (value, *) parse_ip%atom_sigma + + call QUIP_FoX_get_value(attributes, "pissnl_dimension", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find pissnl_dimension") + read (value, *) parse_ip%pissnl_dimension + + if(allocated(parse_ip%beta)) deallocate(parse_ip%beta) + allocate(parse_ip%beta(parse_ip%pissnl_dimension, parse_ip%n_types)) + + elseif (parse_in_ip .and. name == 'beta') then + + if(.not. allocated(parse_ip%beta)) call system_abort ("IPModel_LinearSOAP_read_params_xml encountered stanza but beta array is not yet allcoated") + + call QUIP_FoX_get_value(attributes, "atomtype", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find atomtype in stanza") + read (value, *) atomtype + + call QUIP_FoX_get_value(attributes, "i", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find i in stanza") + read (value, *) i + + call QUIP_FoX_get_value(attributes, "value", value, status) + if (status /= 0) call system_abort ("IPModel_LinearSOAP_read_params_xml cannot find value in stanza") + read (value, *) v + + if (i > parse_ip%pissnl_dimension) call system_abort("IPModel_LinearSOAP_read_params_xml: i > pissnl_dimension in stanza") + if (atomtype > parse_ip%n_types) call system_abort("IPModel_LinearSOAP_read_params_xml: atomtype > n_types in stanza") + + parse_ip%beta(i,atomtype) = v + + + endif +#endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'LinearSOAP_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_LinearSOAP_read_params_xml(this, param_str) + type(IPModel_LinearSOAP), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_LinearSOAP_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_LinearSOAP_read_params_xml + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of LinearSOAP parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_LinearSOAP_Print (this, file) + type(IPModel_LinearSOAP), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_LinearSOAP ", file=file) + call Print("IPModel_LinearSOAP : n_types = " // this%n_types // " cutoff = " // this%cutoff // " l_max = " // this%l_max // " n_max = " // this%n_max // " atom_sigma = " // this%atom_sigma // " pissnl_dimension = " // this%pissnl_dimension, file=file) + + do ti=1, this%n_types + call Print ("IPModel_LinearSOAP : type " // ti // " atomic_num " // this%atomic_num(ti) // " e0 = " // this%e0(ti), file=file) + end do + +end subroutine IPModel_LinearSOAP_Print + + +end module IPModel_LinearSOAP_module diff --git a/src/Potentials/IPModel_MBD.F90 b/src/Potentials/IPModel_MBD.F90 new file mode 100644 index 0000000000..57c7dbca62 --- /dev/null +++ b/src/Potentials/IPModel_MBD.F90 @@ -0,0 +1,275 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_MBD +!X +!% Many-body van der Waals correction from +!% Tkatchenko, DiStasio, Car, & Scheffler +!% Phys. Rev. Lett. 108, 236402 (2012). +!% +!% Requires the MBD code from http://www.fhi-berlin.mpg.de/~tkatchen/MBD/MBD.tar +!% Download and extract into ThirdParty/MBD +!% TODO the Makefile should automatically patch their UTILS.F90 and compile it +!% in +!% +!% For more information on the method and parameters see ThirdParty/MBD/README +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_MBD_module + +use error_module +use system_module, only : dp, inoutput, print, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use units_module, only : QPI => PI, QBOHR => BOHR, HARTREE +#ifdef HAVE_MBD +use MBD_UTILS +#endif + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_MBD +type IPModel_MBD + real(dp) :: cutoff = 0.0_dp ! Cutoff in the quip sense doesn't really apply here + integer :: xc = 1 ! PBE + real(dp) :: mbd_cfdm_dip_cutoff = 100.d0 ! Angstrom + real(dp) :: mbd_supercell_cutoff= 25.d0 ! Angstrom + real(dp) :: mbd_scs_dip_cutoff = 120.0 ! Angstrom + logical :: mbd_scs_vacuum_axis(3) +end type IPModel_MBD + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_MBD), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_MBD_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_MBD_Finalise +end interface Finalise + +interface Print + module procedure IPModel_MBD_Print +end interface Print + +interface Calc + module procedure IPModel_MBD_Calc +end interface Calc + +contains + +subroutine IPModel_MBD_Initialise_str(this, args_str, param_str, error) + type(IPModel_MBD), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out):: error + + + INIT_ERROR(error) + call Finalise(this) + + call initialise(params) + ! Some of these should definitely be in the xml file, but use command line for now + call param_register(params, 'xc_type', '1', this%xc, help_string='Type of X-C functional that was used: dial 1 for PBE, 2 for PBE0, or 3 for HSE') + call param_register(params, 'cfdm_dip_cutoff', '100.0', this%mbd_cfdm_dip_cutoff, help_string='MBD dipole field integration cutoff') + call param_register(params, 'scs_dip_cutoff', '120.0', this%mbd_scs_dip_cutoff, help_string='Periodic SCS integration cutoff - important for low-dim systems') + call param_register(params, 'supercell_cutoff', '25.0', this%mbd_supercell_cutoff, help_string='Radius used to make periodic supercell - important convergence parameter') + call param_register(params, 'vacuum_x', 'false', this%mbd_scs_vacuum_axis(1), help_string='Which directions should be treated as vacuum instead of periodic: X') + call param_register(params, 'vacuum_y', 'false', this%mbd_scs_vacuum_axis(2), help_string='Which directions should be treated as vacuum instead of periodic: Y') + call param_register(params, 'vacuum_z', 'false', this%mbd_scs_vacuum_axis(3), help_string='Which directions should be treated as vacuum instead of periodic: Z') + if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_MBD_Initialise args_str')) then + RAISE_ERROR("IPModel_MBD_Init failed to parse args_str='"//trim(args_str)//"'", error) + end if + call finalise(params) + +#ifdef HAVE_MBD + ! MBD pi = QUIP Units pi + pi = QPI + bohr = QBOHR ! Used in the code - nasty arithmetic errors if uninitialized + three_by_pi = 3.0 / pi + flag_xc = this%xc + mbd_cfdm_dip_cutoff = this%mbd_cfdm_dip_cutoff + mbd_supercell_cutoff= this%mbd_supercell_cutoff + mbd_scs_dip_cutoff = this%mbd_scs_dip_cutoff + n_periodic = 0 + mbd_scs_vacuum_axis = this%mbd_scs_vacuum_axis + ! And that replaces MBD_UTILS::init_constants() + ! MPI stuff: + ! Um, this was supposed to be set in MPI_INIT but I can't find a way to access it + mpiierror = 0 +#endif + +end subroutine IPModel_MBD_Initialise_str + +subroutine IPModel_MBD_Finalise(this) + type(IPModel_MBD), intent(inout) :: this + + ! Add finalisation code here + +end subroutine IPModel_MBD_Finalise + + +subroutine IPModel_MBD_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_MBD), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + logical :: mpi_active + integer, intent(out), optional :: error + + type(Dictionary) :: params + real(dp), pointer, dimension(:) :: my_hirshfeld_volume + character(STRING_LENGTH) :: hirshfeld_vol_name + real(dp) :: energy = 0.0_dp + integer :: at_idx + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + !TODO lammps usually asks for this though - is there another way? + RAISE_ERROR("IPModel_MBD does not have local energies", error) + endif + ! Need finite differences for forces and virials + if (present(f) .or. present(virial) .or. present(local_virial)) then + RAISE_ERROR("IPModel_MBD does not yet provide analytical gradients", error) + endif + + if (present(args_str)) then + if (len_trim(args_str) > 0) then + call initialise(params) + call param_register(params, 'hirshfeld_vol_name', 'hirshfeld_rel_volume', hirshfeld_vol_name, & + help_string='Name of the Atoms property containing relative Hirshfeld volumes $v/v_{free}$') + + if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_MBD_Calc args_str')) then + RAISE_ERROR("IPModel_MBD_Calc failed to parse args_str '"//trim(args_str)//"'", error) + endif + call finalise(params) + call assign_property_pointer(at, trim(hirshfeld_vol_name), my_hirshfeld_volume, error) + PASS_ERROR_WITH_INFO("IPModel_MBD_Calc could not find '"//trim(hirshfeld_vol_name)//"' property in the Atoms object", error) + endif + else + call assign_property_pointer(at, 'hirshfeld_rel_volume', my_hirshfeld_volume, error) + endif + +#ifdef HAVE_MBD + mpi_active = .false. + if (present(mpi)) then + if (mpi%active) then + mpi_active = .true. + endif + endif + + n_atoms = at%N + if (mpi_active) then + mpicomm = mpi%communicator + myid = mpi%my_proc + n_tasks = mpi%n_procs + call allocate_task() + else ! assume serial + myid = 0 + n_tasks = 1 + call allocate_task() + endif + + ! Note: many of these variables come from the MBD_UTILS module + if(.not.allocated(coords)) allocate(coords(3,n_atoms)) + if(.not.allocated(atom_name)) allocate(atom_name(n_atoms)) + if(.not.allocated(hirshfeld_volume)) allocate(hirshfeld_volume(n_atoms)) + lattice_vector = at%lattice / QBOHR + ! TODO maybe this should count the number of periodic dimensions - even + ! though MBD_UTILS only distinguishes 0 and >0 + ! Related: Maybe want to support non-periodic calculations if all the lattice + ! directions are specified as vacuum + n_periodic = 3 ! I think this means use PBC + coords = at%pos / QBOHR + do at_idx = 1, at%N + atom_name(at_idx) = at%species(1, at_idx) // at%species(2, at_idx) + enddo + hirshfeld_volume = my_hirshfeld_volume + + call MBD_at_rsSCS(energy) +#ifdef _MPI + PASS_MPI_ERROR(mpiierror, error) +#endif /*MPI*/ +#endif /*MBD*/ + +#ifdef HAVE_MBD + if (present(e)) e = energy * HARTREE + + if (allocated(coords)) deallocate(coords) + if (allocated(atom_name)) deallocate(atom_name) + if (allocated(hirshfeld_volume)) deallocate(hirshfeld_volume) +#endif + +end subroutine IPModel_MBD_Calc + + +subroutine IPModel_MBD_Print(this, file) + type(IPModel_MBD), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_MBD : Many-body dispersion", file=file) + select case(this%xc) + case(1) + call Print("IPModel_MBD : xc type PBE", file=file) + case(2) + call Print("IPModel_MBD : xc type PBE0", file=file) + case(3) + call Print("IPModel_MBD : xc type HSE", file=file) + case default + call Print("IPModel_MBD : xc type unknown", file=file) + end select + call Print("IPModel_MBD : mbd_supercell_cutoff = " // this%mbd_supercell_cutoff, file=file) + call Print("IPModel_MBD : mbd_scs_dip_cutoff = " // this%mbd_scs_dip_cutoff, file=file) + call Print("IPModel_MBD : mbd_cfdm_dip_cutoff = " // this%mbd_cfdm_dip_cutoff, file=file) + call Print("IPModel_MBD : mbd_scs_vacuum_axis = " // this%mbd_scs_vacuum_axis, file=file) + +end subroutine IPModel_MBD_Print + + +end module IPModel_MBD_module diff --git a/src/Potentials/IPModel_MTP.F90 b/src/Potentials/IPModel_MTP.F90 new file mode 100644 index 0000000000..a0897d97da --- /dev/null +++ b/src/Potentials/IPModel_MTP.F90 @@ -0,0 +1,255 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_MTP +!X +!% MTP interatomic potential: interface to Alex Shapeev's C++ code. +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_MTP_module + +use iso_c_binding, only : C_NULL_CHAR +use error_module +use system_module, only : dp, inoutput, print, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use CInOutput_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_MTP +type IPModel_MTP + real(dp) :: cutoff = 0.0_dp +end type IPModel_MTP + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_MTP), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_MTP_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_MTP_Finalise +end interface Finalise + +interface Print + module procedure IPModel_MTP_Print +end interface Print + +interface Calc + module procedure IPModel_MTP_Calc +end interface Calc + +#ifdef HAVE_MTP +interface + subroutine alex_initialise(filename, cutoff, error) bind(C) + use iso_c_binding, only: c_double, c_char, c_int + character(kind=c_char) :: filename(*) + real(kind=c_double) :: cutoff + integer(kind=c_int) :: error + endsubroutine alex_initialise +endinterface + +interface + subroutine alex_compute(neigh_count,neigh_len,input_pos,out_force,out_site_en, error) bind(C) + use iso_c_binding, only: c_ptr, c_int + integer(kind=c_int) :: neigh_count + type(c_ptr), value :: neigh_len + type(c_ptr), value :: input_pos + type(c_ptr), value :: out_force + type(c_ptr), value :: out_site_en + integer(kind=c_int) :: error + endsubroutine alex_compute +endinterface +#endif + +contains + +subroutine IPModel_MTP_Initialise_str(this, args_str, param_str, error) + type(IPModel_MTP), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out):: error + + character(len=STRING_LENGTH) :: alex_filename + integer :: mtp_error + + INIT_ERROR(error) + call Finalise(this) + + call initialise(params) + call param_register(params, 'alex_filename', '', alex_filename, help_string='filename for coefficiets') + if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_MTP_Initialise args_str')) then + RAISE_ERROR("IPModel_MTP_Init failed to parse args_str='"//trim(args_str)//"'", error) + end if + call finalise(params) + +#ifdef HAVE_MTP + call alex_initialise(trim(alex_filename)//C_NULL_CHAR, this%cutoff,mtp_error) + if( mtp_error /= 0 ) then + RAISE_ERROR("IPModel_MTP_Init received error "//mtp_error//" from alex_initialise()",error) + endif +#else + RAISE_ERROR("support for MTP not compiled in. Obtain MTP code first, and HAVE_MTP = 1 in your Makefile.inc, and recompile QUIP",error) +#endif + +end subroutine IPModel_MTP_Initialise_str + +subroutine IPModel_MTP_Finalise(this) + type(IPModel_MTP), intent(inout) :: this + + ! Add finalisation code here + +end subroutine IPModel_MTP_Finalise + + +subroutine IPModel_MTP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + use iso_c_binding, only : c_int, c_double, c_loc + type(IPModel_MTP), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + ! Add calc() code here + + + integer :: i, j, n, neighbour_index + real(dp) :: r_ij + real(dp), dimension(3) :: diff_ij, f_ij + integer(kind=c_int), dimension(:), allocatable, target :: alex_n_neighbours + real(kind=c_double), dimension(:), allocatable, target :: alex_energy, alex_r_neighbours, alex_f_neighbours + integer :: mtp_error + + INIT_ERROR(error) + + allocate(alex_n_neighbours(at%N), alex_energy(at%N)) + + do i = 1, at%N + alex_n_neighbours(i) = n_neighbours(at,i,max_dist=this%cutoff) + enddo + + allocate(alex_r_neighbours(3*sum(alex_n_neighbours)), alex_f_neighbours(3*sum(alex_n_neighbours))) + + neighbour_index = 0 + + do i = 1, at%N + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance=r_ij, diff=diff_ij) + if( r_ij > this%cutoff ) cycle + + neighbour_index = neighbour_index + 1 + alex_r_neighbours(3*(neighbour_index-1)+1:3*neighbour_index) = diff_ij + enddo + enddo + +#ifdef HAVE_MTP + call alex_compute(at%N,c_loc(alex_n_neighbours), c_loc(alex_r_neighbours), c_loc(alex_f_neighbours), c_loc(alex_energy), mtp_error) + if( mtp_error /= 0 ) then + call write(at, 'stdout', prefix='MTP_ERROR') + RAISE_ERROR("IPModel_MTP_Calc received error "//mtp_error//" from alex_compute()",error) + endif +#endif + + if (present(e)) e = sum(alex_energy) + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_MTP_Calc', error) + local_e = alex_energy + endif + + if (present(f).or.present(virial)) then + if(present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_MTP_Calc', error) + f = 0.0_dp + endif + if(present(virial)) virial = 0.0_dp + + neighbour_index = 0 + do i = 1, at%N + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance=r_ij, diff=diff_ij) + if( r_ij > this%cutoff ) cycle + + neighbour_index = neighbour_index + 1 + f_ij = alex_f_neighbours(3*(neighbour_index-1)+1:3*neighbour_index) + if(present(f)) then + f(:,j) = f(:,j) - f_ij + f(:,i) = f(:,i) + f_ij + endif + if(present(virial)) then + virial = virial - ( diff_ij .outer. f_ij ) + endif + enddo + enddo + + end if + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_MTP_Calc', error) + local_virial = 0.0_dp + endif + + if(allocated(alex_n_neighbours)) deallocate(alex_n_neighbours) + if(allocated(alex_energy)) deallocate(alex_energy) + if(allocated(alex_r_neighbours)) deallocate(alex_r_neighbours) + if(allocated(alex_f_neighbours)) deallocate(alex_f_neighbours) + +end subroutine IPModel_MTP_Calc + + +subroutine IPModel_MTP_Print(this, file) + type(IPModel_MTP), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_MTP : MTP Potential", file=file) + call Print("IPModel_MTP : cutoff = " // this%cutoff, file=file) + +end subroutine IPModel_MTP_Print + + +end module IPModel_MTP_module diff --git a/src/Potentials/IPModel_Morse.F90 b/src/Potentials/IPModel_Morse.F90 new file mode 100644 index 0000000000..771283137a --- /dev/null +++ b/src/Potentials/IPModel_Morse.F90 @@ -0,0 +1,569 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Morse module +!X +!% Module for Morse pair potential. +!% \begin{equation} +!% \nonumber +!% V(r) = D \left( \exp(-2 \alpha (r-r_0)) - 2 \exp( -\alpha (r-r_0)) \right) +!% \end{equation} +!% +!% The IPModel_Morse object contains all the parameters read from a +!% 'Morse_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Morse_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + + +use mpi_context_module +use QUIP_Common_module + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_Morse +type IPModel_Morse + integer :: n_types = 0 !% Number of atomic types. + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + real(dp), allocatable :: D(:,:), alpha(:,:), r0(:,:), cutoff_a(:,:) !% IP parameters. + + character(len=STRING_LENGTH) label + +end type IPModel_Morse + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Morse), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Morse_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Morse_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Morse_Print +end interface Print + +interface Calc + module procedure IPModel_Morse_Calc +end interface Calc + +contains + +subroutine IPModel_Morse_Initialise_str(this, args_str, param_str) + type(IPModel_Morse), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label = '' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Morse_Initialise_str args_str')) then + call system_abort("IPModel_Morse_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Morse_read_params_xml(this, param_str) + + this%cutoff = maxval(this%cutoff_a) + +end subroutine IPModel_Morse_Initialise_str + +subroutine IPModel_Morse_Finalise(this) + type(IPModel_Morse), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%r0)) deallocate(this%r0) + if (allocated(this%D)) deallocate(this%D) + if (allocated(this%alpha)) deallocate(this%alpha) + if (allocated(this%cutoff_a)) deallocate(this%cutoff_a) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Morse_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_Morse_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Morse), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), pointer :: w_e(:) + integer i, ji, j, ti, tj + real(dp) :: dr(3), dr_mag + real(dp) :: de, de_dr + logical :: i_is_min_image + + integer :: i_calc, n_extra_calcs + character(len=20) :: extra_calcs_list(10) + + logical :: do_flux = .false. + real(dp), pointer :: velo(:,:) + real(dp) :: flux(3) + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Morse_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_Morse_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) virial = 0.0_dp + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_Morse_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_Morse_Calc: local_virial calculation requested but not supported yet.", error) + endif + + if (present(args_str)) then + if (len_trim(args_str) > 0) then + n_extra_calcs = parse_extra_calcs(args_str, extra_calcs_list) + if (n_extra_calcs > 0) then + do i_calc=1, n_extra_calcs + select case(trim(extra_calcs_list(i_calc))) + case("flux") + if (.not. assign_pointer(at, "velo", velo)) & + call system_abort("IPModel_Morse_Calc Flux calculation requires velo field") + do_flux = .true. + flux = 0.0_dp + case default + call system_abort("Unsupported extra_calc '"//trim(extra_calcs_list(i_calc))//"'") + end select + end do + endif ! n_extra_calcs + endif ! len_trim(args_str) + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Morse_Calc args_str')) then + RAISE_ERROR("IPModel_Morse_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_Morse_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_Morse_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + endif ! present(args_str) + + if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) + + do i = 1, at%N + i_is_min_image = at%connect%is_min_image(i) + + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + do ji = 1, n_neighbours(at, i) + j = neighbour(at, i, ji, dr_mag, cosines = dr) + + if (dr_mag .feq. 0.0_dp) cycle + if ((i < j) .and. i_is_min_image) cycle + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (present(e) .or. present(local_e)) then + de = IPModel_Morse_pairenergy(this, ti, tj, dr_mag) + if (present(local_e)) then + local_e(i) = local_e(i) + 0.5_dp*de + if(i_is_min_image) local_e(j) = local_e(j) + 0.5_dp*de + endif + if (present(e)) then + if (associated(w_e)) then + de = de*0.5_dp*(w_e(i)+w_e(j)) + endif + if(i_is_min_image) then + e = e + de + else + e = e + 0.5_dp*de + endif + endif + endif + if (present(f) .or. present(virial) .or. do_flux) then + de_dr = IPModel_Morse_pairenergy_deriv(this, ti, tj, dr_mag) + if (associated(w_e)) then + de_dr = de_dr*0.5_dp*(w_e(i)+w_e(j)) + endif + if (present(f)) then + f(:,i) = f(:,i) + de_dr*dr + if(i_is_min_image) f(:,j) = f(:,j) - de_dr*dr + endif + if (do_flux) then + ! -0.5 (v_i + v_j) . F_ij * dr_ij + flux = flux - 0.5_dp*sum((velo(:,i)+velo(:,j))*(de_dr*dr))*(dr*dr_mag) + endif + if (present(virial)) then + if(i_is_min_image) then + virial = virial - de_dr*(dr .outer. dr)*dr_mag + else + virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*dr_mag + endif + endif + endif + end do + end do + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(f)) call sum_in_place(mpi, f) + endif + if (do_flux) then + flux = flux / cell_volume(at) + if (present(mpi)) call sum_in_place(mpi, flux) + call set_value(at%params, "Flux", flux) + endif + +end subroutine IPModel_Morse_Calc + +!% This routine computes the two-body term for a pair of atoms separated by a distance r. +function IPModel_Morse_pairenergy(this, ti, tj, r) + type(IPModel_Morse), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_Morse_pairenergy + + real(dp) :: texp + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then + IPModel_Morse_pairenergy = 0.0 + return + endif + + texp = exp(-this%alpha(ti,tj)*(r-this%r0(ti,tj))) + + IPModel_Morse_pairenergy = this%D(ti,tj) * ( texp*texp - 2.0_dp*texp ) +end function IPModel_Morse_pairenergy + +!% Derivative of the two-body term. +function IPModel_Morse_pairenergy_deriv(this, ti, tj, r) + type(IPModel_Morse), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_Morse_pairenergy_deriv + + real(dp) :: texp, texp_d + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff_a(ti,tj))) then + IPModel_Morse_pairenergy_deriv = 0.0 + return + endif + + texp = exp(-this%alpha(ti,tj)*(r-this%r0(ti,tj))) + texp_d = -this%alpha(ti,tj) * texp + + IPModel_Morse_pairenergy_deriv = this%D(ti,tj) * ( 2.0_dp*texp*texp_d - 2.0_dp * texp_d) +end function IPModel_Morse_pairenergy_deriv + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for XML stanza is given below. Please notice that +!% these are simply dummy parameters for testing purposes, with no physical meaning. +!% +!%> +!%> +!%> +!%> +!%> +!% +!% cutoff defaults to r0 - log(1e-8) / alpha +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + integer atnum_i, atnum_j, ti, tj, ti_a(1) + + if (name == 'Morse_params') then ! new Morse stanza + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered Morse_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in Morse_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%r0(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%D(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%alpha(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%cutoff_a(parse_ip%n_types,parse_ip%n_types)) + + parse_ip%r0 = 0.0_dp + parse_ip%D = 0.0_dp + parse_ip%alpha = 0.0_dp + + endif ! parse_in_ip + elseif (parse_in_ip .and. name == 'pair') then + + call QUIP_FoX_get_value(attributes, "atnum_i", value, status) + if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find atnum_i") + read (value, *) atnum_i + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find atnum_j") + read (value, *) atnum_j + + if (all(parse_ip%atomic_num /= atnum_i)) then + ti_a = minloc(parse_ip%atomic_num) + parse_ip%atomic_num(ti_a(1)) = atnum_i + endif + if (all(parse_ip%atomic_num /= atnum_j)) then + ti_a = minloc(parse_ip%atomic_num) + parse_ip%atomic_num(ti_a(1)) = atnum_j + endif + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + ti = parse_ip%type_of_atomic_num(atnum_i) + tj = parse_ip%type_of_atomic_num(atnum_j) + + call QUIP_FoX_get_value(attributes, "r0", value, status) + if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find r0") + read (value, *) parse_ip%r0(ti,tj) + call QUIP_FoX_get_value(attributes, "D", value, status) + if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find D") + read (value, *) parse_ip%D(ti,tj) + call QUIP_FoX_get_value(attributes, "alpha", value, status) + if (status /= 0) call system_abort ("IPModel_Morse_read_params_xml cannot find alpha") + read (value, *) parse_ip%alpha(ti,tj) + + parse_ip%cutoff_a(ti,tj) = -1.0_dp + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status == 0) read (value, *) parse_ip%cutoff_a(ti,tj) + + if (ti /= tj) then + parse_ip%r0(tj,ti) = parse_ip%r0(ti,tj) + parse_ip%D(tj,ti) = parse_ip%D(ti,tj) + parse_ip%alpha(tj,ti) = parse_ip%alpha(ti,tj) + parse_ip%cutoff_a(tj,ti) = parse_ip%cutoff_a(ti,tj) + endif + + endif ! parse_in_ip .and. name = 'Morse' + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Morse_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_Morse_read_params_xml(this, param_str) + type(IPModel_Morse), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + integer :: ti, tj + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Morse_read_params_xml parsed file, but n_types = 0") + endif + + ! default cutoff: + ! exp(-alpha (r-r0)) < 1e-8 + ! -alpha (r-r0) < log(1e-8) + ! r - r0 < log(1e-8) / -alpha + ! r < r0 + log(1e-8) / -alpha + ! r < r0 + 13.8 / alpha + + do ti=1, this%n_types + do tj=1, this%n_types + if (this%cutoff_a(ti,tj) < 0.0_dp) this%cutoff_a(ti,tj) = this%r0(ti,tj) - log(1.0e-8_dp) / this%alpha(ti,tj) + end do + end do + this%cutoff = maxval(this%cutoff_a) + +end subroutine IPModel_Morse_read_params_xml + + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of Morse parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_Morse_Print (this, file) + type(IPModel_Morse), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_Morse : Morse", file=file) + call Print("IPModel_Morse : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_Morse : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + do tj=1, this%n_types + call Print ("IPModel_Morse : interaction " // ti // " " // tj // " r0 " // this%r0(ti,tj) // " D " // & + this%D(ti,tj) // " alpha " // this%alpha(ti,tj) // " cutoff_a " // this%cutoff_a(ti,tj), file=file) + end do + call verbosity_pop() + end do + +end subroutine IPModel_Morse_Print + +function parse_extra_calcs(args_str, extra_calcs_list) result(n_extra_calcs) + character(len=*), intent(in) :: args_str + character(len=*), intent(out) :: extra_calcs_list(:) + integer :: n_extra_calcs + + character(len=STRING_LENGTH) :: extra_calcs_str + type(Dictionary) :: params + + n_extra_calcs = 0 + call initialise(params) + call param_register(params, "extra_calcs", "", extra_calcs_str, help_string="No help yet. This source file was $LastChangedBy$") + if (param_read_line(params, args_str, ignore_unknown=.true.,task='parse_extra_calcs')) then + if (len_trim(extra_calcs_str) > 0) then + call split_string_simple(extra_calcs_str, extra_calcs_list, n_extra_calcs, ":") + end if + end if + call finalise(params) + +end function parse_extra_calcs + +end module IPModel_Morse_module diff --git a/src/Potentials/IPModel_Multipoles.F90 b/src/Potentials/IPModel_Multipoles.F90 new file mode 100644 index 0000000000..a950e4c783 --- /dev/null +++ b/src/Potentials/IPModel_Multipoles.F90 @@ -0,0 +1,700 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Multipoles +!X +!% Multipoles interatomic potential: +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Multipoles_module + +use error_module +!use system_module, only : dp, inoutput, print, lower_case, verbosity_push_decrement, verbosity_pop, operator(//), split_string, string_to_int,PRINT_ANALYSIS,reallocate +use system_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use Multipoles_module +use units_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +integer, parameter :: IPMultipoles_Method_Direct = 1 +integer, parameter :: IPMultipoles_Method_Yukawa = 2 +integer, parameter :: IPMultipoles_Method_Ewald = 3 + +integer, parameter :: Multipole_Position_Atomic = 1 +integer, parameter :: Multipole_Position_Centre_of_Mass = 2 +integer, parameter :: Multipole_Position_M_Site = 3 + +integer, parameter :: Charge_Method_None = 0 +integer, parameter :: Charge_Method_Fixed = 1 +integer, parameter :: Charge_Method_GAP = 2 +integer, parameter :: Charge_Method_Partridge_Schwenke = 3 + +integer, parameter :: Dipole_Method_None = 0 +integer, parameter :: Dipole_Method_Partridge_Schwenke = 1 +integer, parameter :: Dipole_Method_GAP = 2 + +integer, parameter :: Polarisation_Method_None = 0 +integer, parameter :: Polarisation_Method_FPI = 1 +integer, parameter :: Polarisation_Method_GMRES = 2 +integer, parameter :: Polarisation_Method_QR = 3 + +integer, parameter :: Damping_None = 0 +integer, parameter :: Damping_Exp = 1 +integer, parameter :: Damping_Erf = 2 +integer, parameter :: Damping_Erf_Uniform = 3 + +integer, parameter :: Screening_None = 0 +integer, parameter :: Screening_Yukawa = 1 +integer, parameter :: Screening_Erfc_Uniform = 2 + +public :: IPModel_Multipoles +type IPModel_Multipoles + + type(Multipole_Moments) :: multipoles + + integer :: n_monomer_types = 0 + + integer :: method = 0 + integer :: damping = 0 + integer :: screening = 0 + integer :: polarisation = 0 + + real(dp) :: cutoff = 0.0_dp + + real(dp) :: ewald_error + real(dp) :: smooth_coulomb_cutoff + + character(len=STRING_LENGTH) :: label + +end type IPModel_Multipoles + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Multipoles), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Multipoles_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Multipoles_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Multipoles_Print +end interface Print + +interface Calc + module procedure IPModel_Multipoles_Calc +end interface Calc + +contains + +subroutine IPModel_Multipoles_Initialise_str(this, args_str, param_str, error) + type(IPModel_Multipoles), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out):: error + + + INIT_ERROR(error) + call Finalise(this) + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_Multipoles_Initialise args_str')) then + RAISE_ERROR("IPModel_Multipoles_Init failed to parse args_str='"//trim(args_str)//"'", error) + end if + + call finalise(params) + + call IPModel_Multipoles_read_params_xml(this, param_str) + +end subroutine IPModel_Multipoles_Initialise_str + +subroutine IPModel_Multipoles_Finalise(this) + type(IPModel_Multipoles), intent(inout) :: this + + ! Add finalisation code here + call finalise(this%multipoles) + +end subroutine IPModel_Multipoles_Finalise + + +subroutine IPModel_Multipoles_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Multipoles), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Atoms) :: dummy_atoms + real(dp),dimension(:,:), allocatable :: pol_matrix + type(Ewald_arrays) :: ewald + type(Dictionary) :: params + real(dp) :: r_scale, E_scale, pol_energy + logical :: do_rescale_r, do_rescale_E,do_e, do_f, strict + + logical :: my_use_ewald_cutoff + + INIT_ERROR(error) + do_f=present(f) + do_e=present(e) + if(do_e)e=0.0_dp + if (do_f) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Coulomb_Calc', error) + f = 0.0_dp + end if + if (present(args_str)) then + call initialise(params) + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Not supported in multipole calcs.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.") + call param_register(params, 'strict', 'T',strict, help_string="If true, make sure every atom in system belongs to one of the monomers in this potential, default T") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Multipoles_Calc args_str')) then + RAISE_ERROR("IPModel_Multipoles_Calc failed to parse args_str="//trim(args_str), error) + endif + call finalise(params) + if (do_rescale_r ) then + RAISE_ERROR("IPModel_Multipoles_Calc: rescaling of potential with r_scale not yet implemented!", error) + end if + endif + + call multipole_sites_setup(at,this%multipoles,dummy_atoms,do_f,strict) ! multipoles includes exclude_list + + if (this%method == IPMultipoles_Method_Ewald) then + call ewald_setup(dummy_atoms,this%multipoles,ewald,this%ewald_error) ! changes this%multipoles%cutoff + end if + + if (this%polarisation /= Polarisation_Method_None) then + call electrostatics_calc(dummy_atoms,this%multipoles,ewald,do_field=.true.) + call build_polarisation_matrix(dummy_atoms,this%multipoles,pol_matrix,ewald) ! A^-1-T + call calc_induced_dipoles(pol_matrix,this%multipoles,this%polarisation,pol_energy) ! this updates the dipoles on any polarisable sites + if(do_e) e = pol_energy + end if + + call electrostatics_calc(dummy_atoms,this%multipoles,ewald,e=e,do_force=.true.) + if (present(f)) then + call atomic_forces_from_sites(this%multipoles%sites,f=f) ! no support for virial or local stuff yet + end if + + if (do_rescale_E) then + if (present(e)) e = e*E_scale + if (present(local_e)) local_e = local_e*E_scale + if (present(f)) f = f*E_scale + if (present(virial)) virial=virial*E_scale + if (present(local_virial)) local_virial=local_virial*E_scale + end if + + ! clean up + if(allocated(pol_matrix)) deallocate(pol_matrix) + call finalise(dummy_atoms) + +end subroutine IPModel_Multipoles_Calc + + +subroutine IPModel_Multipoles_Print(this, file) + type(IPModel_Multipoles), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti , tj + + call Print("IPModel_Multipoles : Multipoles Potential", file=file) + select case(this%method) + case(IPMultipoles_Method_Direct) + call Print("IPModel_Multipoles method: Direct") + case(IPMultipoles_Method_Yukawa) + call Print("IPModel_Multipoles method: Yukawa") + case(IPMultipoles_Method_Ewald) + call Print("IPModel_Multipoles method: Ewald") + case default + call system_abort ("IPModel_Multipoles: method identifier "//this%method//" unknown") + endselect + + call Print("IPModel_Multipoles : n_monomer_types = " // this%n_monomer_types // " cutoff = " // this%cutoff, file=file) + + call print("Electrostatics Options for multipole interactions",file=file) + select case(this%multipoles%calc_opts%damping) + case(Damping_None) + call Print("IPModel_Multipoles damping : No damping, bare electrostatic interactions at short range",file=file) + case(Damping_Erf) + call Print("IPModel_Multipoles damping : Gaussian damping of electrostatic interactions at short range",file=file) + case(Damping_Exp) + call Print("IPModel_Multipoles damping : Exponential damping of electrostatic interactions at short range",file=file) + call Print("IPModel_Multipoles damping : Exponential damping rank : "//this%multipoles%calc_opts%damp_exp_order,file=file) + call Print("IPModel_Multipoles damping : Exponential damping scale : "//this%multipoles%calc_opts%damp_exp_scale,file=file) + case default + call Print("IPModel_Multipoles damping : Unknown damping scheme",file=file) + endselect + + select case(this%multipoles%calc_opts%screening) + case(Screening_None) + call Print("IPModel_Multipoles screening : No screening, including all long range electrostatic interactions",file=file) + case(Screening_Yukawa) + call Print("IPModel_Multipoles screening : Yukawa screening of long range electrostatic interactions",file=file) + call Print("IPModel_Multipoles screening : yukawa alpha : "//this%multipoles%calc_opts%yukawa_alpha,file=file) + call Print("IPModel_Multipoles screening : yukawa smooth_length : "//this%multipoles%calc_opts%yukawa_smooth_length,file=file) + case default + call Print("IPModel_Multipoles screening : Unknown screening scheme",file=file) + endselect + + do ti=1,this%n_monomer_types + call print("IPModel_Multipoles : monomer " // ti // " signature " // this%multipoles%monomer_types(ti)%signature, file=file) + do tj=1,size(this%multipoles%monomer_types(ti)%site_types) + call print("IPModel_Multipoles : site " // tj // " d " // this%multipoles%monomer_types(ti)%site_types(tj)%d, file=file) + call print("IPModel_Multipoles : site " // tj //" charge method : "//this%multipoles%monomer_types(ti)%site_types(tj)%charge_method, file=file) + call print("IPModel_Multipoles : site " // tj //" dipole method : "//this%multipoles%monomer_types(ti)%site_types(tj)%dipole_method, file=file) + call print("IPModel_Multipoles : site " // tj //" pos_type " // this%multipoles%monomer_types(ti)%site_types(tj)%pos_type, file=file) + call print("IPModel_Multipoles : site " // tj //" polarisable : "//this%multipoles%monomer_types(ti)%site_types(tj)%polarisable, file=file) + call print("IPModel_Multipoles : site " // tj //" polarisability : "//this%multipoles%monomer_types(ti)%site_types(tj)%alpha, file=file) + call print("IPModel_Multipoles : site " // tj //" damping radius : "//this%multipoles%monomer_types(ti)%site_types(tj)%damp_rad, file=file) + end do + end do + + +end subroutine IPModel_Multipoles_Print + +subroutine IPModel_Multipoles_read_params_xml(this, param_str) + type(IPModel_Multipoles), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_monomer_types == 0) then + call system_abort("IPModel_Multipoles_read_params_xml parsed file, but n_monomer_types = 0") + endif + +end subroutine IPModel_Multipoles_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + + character(len=STRING_LENGTH) :: value, signature_string, pos_type_str, moments_method_str + character(len=STRING_LENGTH), dimension(99) :: signature_fields + + logical :: energy_shift, linear_force_shift + integer :: ti, tj, i , j, n_atoms,n_sites, n_pairs,cursor + real(dp) :: alpha_au + + if (name == 'Multipoles_params') then ! new Multipoles stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + + if (parse_ip%n_monomer_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_monomer_types', value, status) + if (status /= 0) then + value='0' + endif + read (value, *) parse_ip%n_monomer_types + + allocate(parse_ip%multipoles%monomer_types(parse_ip%n_monomer_types)) + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + parse_ip%multipoles%cutoff = parse_ip%cutoff + + call QUIP_FoX_get_value(attributes, 'dipole_tolerance', value, status) + if (status /= 0) then + value='0.0D0' + endif + read (value, *) parse_ip%multipoles%dipole_tolerance + + call QUIP_FoX_get_value(attributes, 'intermolecular_only', value, status) + if (status == 0) then + read (value, *) parse_ip%multipoles%intermolecular_only + endif + + + call QUIP_FoX_get_value(attributes, "method", value, status) + if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find method") + select case(lower_case(trim(value))) + case("direct") + parse_ip%method = IPMultipoles_Method_Direct + case("yukawa") + parse_ip%method = IPMultipoles_Method_Yukawa + case("ewald") + parse_ip%method = IPMultipoles_Method_Ewald + case default + call system_abort ("IPModel_Multipoles_read_params_xml: method "//trim(value)//" unknown") + endselect + + call QUIP_FoX_get_value(attributes, "polarisation", value, status) + if (status /= 0) value = "none" + select case(lower_case(trim(value))) + case("fpi") + parse_ip%polarisation = Polarisation_Method_FPI + case("gmres") + parse_ip%polarisation = Polarisation_Method_GMRES + case("qr") + parse_ip%polarisation = Polarisation_Method_QR + case("none") + parse_ip%polarisation = Polarisation_Method_None + case default + parse_ip%polarisation = Polarisation_Method_None + endselect + + call QUIP_FoX_get_value(attributes, "damping", value, status) + if (status /= 0) value = "none" + select case(lower_case(trim(value))) + case("exp") + parse_ip%multipoles%calc_opts%damping = Damping_Exp + case("erf") + parse_ip%multipoles%calc_opts%damping = Damping_Erf + case("none") + parse_ip%multipoles%calc_opts%damping = Damping_None + case default + parse_ip%multipoles%calc_opts%damping = Damping_None + endselect + + + call QUIP_FoX_get_value(attributes, "damp_exp_scale", value, status) ! global param to adjust strength of damping, just a convenience param for damping_exp + if (status == 0) then + if (parse_ip%multipoles%calc_opts%damping == Damping_Exp) then + read (value, *) parse_ip%multipoles%calc_opts%damp_exp_scale + else + call system_abort("IPModel_Multipoles_read_params_xml: damp_exp_scale specified but exponential damping not selected") + end if + else + parse_ip%multipoles%calc_opts%damp_exp_scale = 1.0_dp + endif + + call QUIP_FoX_get_value(attributes, "damp_exp_order", value, status) ! order of exponential damping, typically 3 or 4, default 3 like in FX water model + if (status == 0) then + if (parse_ip%multipoles%calc_opts%damping == Damping_Exp) then + read (value, *) parse_ip%multipoles%calc_opts%damp_exp_order + else + call system_abort("IPModel_Multipoles_read_params_xml: damp_exp_order specified but exponential damping not selected") + end if + else + parse_ip%multipoles%calc_opts%damp_exp_order = 3 + endif + + call QUIP_FoX_get_value(attributes, "yukawa_alpha", value, status) + if (status /= 0) then + if( parse_ip%method == IPMultipoles_Method_Yukawa ) call system_abort("IPModel_Multipoles_read_params_xml: Yukawa method requested but no yukawa_alpha parameter found.") + else + read (value, *) parse_ip%multipoles%calc_opts%yukawa_alpha + parse_ip%screening = Screening_Yukawa + parse_ip%multipoles%calc_opts%screening = Screening_Yukawa + endif + + call QUIP_FoX_get_value(attributes, "yukawa_smooth_length", value, status) + if (status /= 0) then + if( parse_ip%screening == Screening_Yukawa ) call system_abort("IPModel_Multipoles_read_params_xml: Yukawa method requested but no yukawa_smooth_length parameter found.") + else + read (value, *) parse_ip%multipoles%calc_opts%yukawa_smooth_length + endif + + call QUIP_FoX_get_value(attributes, "ewald_error", value, status) + if (status == 0) then + read (value, *) parse_ip%ewald_error + else + parse_ip%ewald_error = 1.0e-6_dp + endif + + call QUIP_FoX_get_value(attributes, "smooth_coulomb_cutoff", value, status) + if (status == 0) then + read (value, *) parse_ip%smooth_coulomb_cutoff + else + parse_ip%smooth_coulomb_cutoff = 0.0_dp + endif + + endif + + elseif (parse_in_ip .and. name == 'monomer') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find type") + read (value, *) ti + if (ti < 1) call system_abort("IPModel_Multipoles_read_params_xml got monomer type="//ti//" < 1") + if (ti > parse_ip%n_monomer_types) call system_abort("IPModel_Multipoles_read_params_xml got monomer type="//ti//" > n_monomer_types="//parse_ip%n_monomer_types) + + call QUIP_FoX_get_value(attributes, "signature", value, status) + if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find signature") + + read (value, *) signature_string + call split_string(signature_string,'_','{}',signature_fields(:),n_atoms,matching=.true.) !read the signature + allocate(parse_ip%multipoles%monomer_types(ti)%signature(n_atoms)) + allocate(parse_ip%multipoles%monomer_types(ti)%masses(n_atoms)) + + do i=1,n_atoms + parse_ip%multipoles%monomer_types(ti)%signature(i) = string_to_int(signature_fields(i)) ! pass it to the monomer type + end do + + !call QUIP_FoX_get_value(attributes, "exclude_pairs", value, status) + + call QUIP_FoX_get_value(attributes, "monomer_cutoff", value, status) + if (size(parse_ip%multipoles%monomer_types(ti)%signature) > 1) then + if (status /= 0 ) then + call system_abort ("IPModel_Multipoles_read_params_xml cannot find monomer_cutoff") + else + read (value, *) parse_ip%multipoles%monomer_types(ti)%monomer_cutoff + end if + else + parse_ip%multipoles%monomer_types(ti)%monomer_cutoff = 0.01_dp + end if + + call QUIP_FoX_get_value(attributes, "n_sites", value, status) + if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find number of sites") + n_sites=string_to_int(value) + allocate(parse_ip%multipoles%monomer_types(ti)%site_types(n_sites)) + if(parse_ip%multipoles%intermolecular_only) then + n_pairs=(n_sites*(n_sites-1))/2 + call reallocate(parse_ip%multipoles%monomer_types(ti)%excluded_pairs,2,n_pairs,zero=.true.) + cursor=0 + do i=1,n_sites-1 + do j=i+1,n_sites + cursor=cursor+1 + parse_ip%multipoles%monomer_types(ti)%excluded_pairs(1,cursor)=i + parse_ip%multipoles%monomer_types(ti)%excluded_pairs(2,cursor)=j + end do + end do + end if + + call QUIP_FoX_get_value(attributes, "step", value, status) + if (status /= 0) value = '1D-08' + read (value, *) parse_ip%multipoles%monomer_types(ti)%step + + call QUIP_FoX_get_value(attributes, "gammaM", value, status) + if (status == 0) read (value, *) parse_ip%multipoles%monomer_types(ti)%gammaM + + + elseif (parse_in_ip .and. name == 'per_site_data') then + + call QUIP_FoX_get_value(attributes, "monomer", value, status) + if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find which monomer this site belongs to, specify with monomer='n' n=0,1,2...") + read (value, *) ti + if (ti < 1) call system_abort("IPModel_Multipoles_read_params_xml got monomer type="//ti//" < 1") + if (.not. allocated(parse_ip%multipoles%monomer_types(ti)%signature)) call system_abort("IPModel_Multipoles_read_params_xml, site specified but monomer not initialised") + + call QUIP_FoX_get_value(attributes, "site", value, status) + if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find site number (e.g. site='1') ") + + read (value, *) tj + + if (tj < 1) call system_abort("IPModel_Multipoles_read_params_xml got site type="//tj//" < 1") + if (tj > size(parse_ip%multipoles%monomer_types(ti)%site_types)) call system_abort("IPModel_Multipoles_read_params_xml got site type="//tj//" > n_sites="//size(parse_ip%multipoles%monomer_types(ti)%site_types)) + call QUIP_FoX_get_value(attributes, "charge", value, status) + if (status == 0) then + read (value, *) parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = 1 + else + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge = 0.0_dp + end if + + call QUIP_FoX_get_value(attributes, "pos_type", value, status) + if (status /= 0) call system_abort ("IPModel_Multipoles_read_params_xml cannot find site pos_type ") + read (value, *) pos_type_str + + if (trim(pos_type_str) /= "") then + select case(lower_case(trim(pos_type_str))) + case("atom") + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%pos_type = Multipole_Position_Atomic + case("com") + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%pos_type = Multipole_Position_Centre_of_Mass + case("m-site") + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%pos_type = Multipole_Position_M_Site + case default + call system_abort ("IPModel_Multipoles_read_params_xml: pos_type "//trim(value)//" unknown") + end select + end if + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) value='0' + read (value, *) parse_ip%multipoles%monomer_types(ti)%site_types(tj)%atomic_number + + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = 0 + + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge_method = Charge_Method_None + call QUIP_FoX_get_value(attributes, "charge_method", value, status) + if (status == 0) then + read (value, *) moments_method_str + select case(lower_case(trim(moments_method_str))) + case("none") + continue + case("fixed") + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge_method = Charge_Method_Fixed + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 1 + case("gap") + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge_method = Charge_Method_GAP + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 1 + case("partridge_schwenke") + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%charge_method = Charge_Method_Partridge_Schwenke + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 1 + case default + call system_abort ("IPModel_Multipoles_read_params_xml: moments_method "//trim(value)//" unknown") + end select + end if + + call QUIP_FoX_get_value(attributes, "dipole_method", value, status) + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%dipole_method = Dipole_Method_None + if (status == 0) then + read (value, *) moments_method_str + select case(lower_case(trim(moments_method_str))) + case("none") + continue + case("gap") + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%dipole_method = Dipole_Method_GAP + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 3 + case("partridge_schwenke") + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%dipole_method = Dipole_Method_Partridge_Schwenke + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 3 + case default + call system_abort ("IPModel_Multipoles_read_params_xml: moments_method "//trim(value)//" unknown") + end select + end if + + call QUIP_FoX_get_value(attributes, "pol_alpha", value, status) + if (status /= 0) then + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%polarisable=.false. + else + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%polarisable=.true. + if (parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d .lt. 3 ) parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%d + 3 + read (value, *) alpha_au + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%alpha=alpha_au*CUBIC_BOHR + if (parse_ip%multipoles%calc_opts%damping==Damping_None) then + call system_abort("IPModel_Multipoles_read_params_xml: Cannot have polarsiable sites present with undamped interactions") + end if + end if + + ! by default, polarisable sites are damped and unpolarisable ones are not, can override default behaviour by setting damp_rad + ! if damp_rad=0.0, then no damping occurs. If want to damp a non-polarisable site, have to provide a radius manually + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damped = parse_ip%multipoles%monomer_types(ti)%site_types(tj)%polarisable + + call QUIP_FoX_get_value(attributes, "damp_rad", value, status) + if (status /= 0) then + if (parse_ip%multipoles%calc_opts%damping==Damping_Erf) then + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damp_rad = (alpha_au*sqrt(2.0_dp/PI)/3.0_dp)**(1.0_dp/3.0_dp)*BOHR + else if (parse_ip%multipoles%calc_opts%damping==Damping_Exp) then + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damp_rad = (alpha_au)**(1.0_dp/3.0_dp)*BOHR + end if + else + if (parse_ip%multipoles%calc_opts%damping==Damping_None) then + call system_abort("IPModel_Multipoles_read_params_xml: damp_rad specified but no damping type selected, please specify damping=exp or damping=erf") + else + read (value, *) parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damp_rad ! override default damp_rad value + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damped = .true. + end if + end if + + if (.not. parse_ip%multipoles%monomer_types(ti)%site_types(tj)%damped ) then + if ( parse_ip%multipoles%calc_opts%damping/=Damping_None ) then + call system_abort ("IPModel_Multipoles_read_params_xml: damping requested but no radii specified for non-polarisable sites ") + else + do i=1,tj-1 + if (parse_ip%multipoles%monomer_types(ti)%site_types(i)%polarisable) then + call system_abort ("IPModel_Multipoles_read_params_xml: cannot have undamped charges in combination with polarisable sites. Please ensure all sites have a damp_rad set. ") + end if + end do + end if + end if + + parse_ip%multipoles%monomer_types(ti)%site_types(tj)%initialised = .true. + + endif + + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Multipoles_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + + +end module IPModel_Multipoles_module diff --git a/src/Potentials/IPModel_PartridgeSchwenke.F90 b/src/Potentials/IPModel_PartridgeSchwenke.F90 new file mode 100644 index 0000000000..f68bcd20f6 --- /dev/null +++ b/src/Potentials/IPModel_PartridgeSchwenke.F90 @@ -0,0 +1,709 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_PartridgeSchwenke +!X +!% Partridge-Schwenke model for a water monomer. This is a wrapper for the +!% code downloaded from EPAPS from the JCP website. +!% EPAPS code: E-JCPSA-106-4618 +!% +!% Reference: +!% Authors: Harry Partridge and David W. Schwenke +!% Title: The determination of an accurate isotope dependent potential energy +!% surface for water ... +!% Journal: Journal of Chemical Physics, Volume 106, No.11, 15 March 1997-Page 4618 +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_PartridgeSchwenke_module + +use error_module +use system_module, only : dp, inoutput, print +use units_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use topology_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_PartridgeSchwenke +type IPModel_PartridgeSchwenke + real(dp) :: cutoff = 1.7_dp + logical :: OHH_ordercheck = .true. +end type IPModel_PartridgeSchwenke + +real(dp) :: c5z(245),cbasis(245),ccore(245), crest(245) +integer::i, idx(245,3) +data (idx(i,1),i=1,245)/& + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & + 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 4, 4, 4, 4, 4, 4, 4, 4, & + 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, & + 6, 6, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, & + 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 5, & + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, & + 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, & + 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 9, 9, & + 9, 9, 9, 9, 9/ +data (idx(i,2),i=1,245)/& + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4, 4, & + 4, 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, & + 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 5, 5, 5, 5, 5, 5, 5, 4, 4, 4, & + 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 1, 1, & + 1, 1, 1, 1, 1/ +data (idx(i,3),i=1,245)/& + 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 1, 2, 3, 4, 5, & + 6, 7, 8, 9,10,11,12,13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, & + 12,13, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, & + 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, & + 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, & + 11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, & + 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, & + 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9, & + 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, & + 3, 4, 5, 6, 7, 8, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4, 5, 6, & + 7, 8, 1, 2, 3, 4, 5, 6, 7, 8, 1, 2, 3, 4, 5, 6, 7, 1, 2, 3, & + 4, 5, 6, 7, 1, 2, 3, 4, 5, 6, 7, 1, 2, 3, 4, 5, 6, 7, 1, 2, & + 3, 4, 5, 6, 7/ +data (c5z(i),i=1,245)/& + 4.2278462684916D+04, 4.5859382909906D-02, 9.4804986183058D+03, & + 7.5485566680955D+02, 1.9865052511496D+03, 4.3768071560862D+02, & + 1.4466054104131D+03, 1.3591924557890D+02,-1.4299027252645D+03, & + 6.6966329416373D+02, 3.8065088734195D+03,-5.0582552618154D+02, & + -3.2067534385604D+03, 6.9673382568135D+02, 1.6789085874578D+03, & + -3.5387509130093D+03,-1.2902326455736D+04,-6.4271125232353D+03, & + -6.9346876863641D+03,-4.9765266152649D+02,-3.4380943579627D+03, & + 3.9925274973255D+03,-1.2703668547457D+04,-1.5831591056092D+04, & + 2.9431777405339D+04, 2.5071411925779D+04,-4.8518811956397D+04, & + -1.4430705306580D+04, 2.5844109323395D+04,-2.3371683301770D+03, & + 1.2333872678202D+04, 6.6525207018832D+03,-2.0884209672231D+03, & + -6.3008463062877D+03, 4.2548148298119D+04, 2.1561445953347D+04, & + -1.5517277060400D+05, 2.9277086555691D+04, 2.6154026873478D+05, & + -1.3093666159230D+05,-1.6260425387088D+05, 1.2311652217133D+05, & + -5.1764697159603D+04, 2.5287599662992D+03, 3.0114701659513D+04, & + -2.0580084492150D+03, 3.3617940269402D+04, 1.3503379582016D+04, & + -1.0401149481887D+05,-6.3248258344140D+04, 2.4576697811922D+05, & + 8.9685253338525D+04,-2.3910076031416D+05,-6.5265145723160D+04, & + 8.9184290973880D+04,-8.0850272976101D+03,-3.1054961140464D+04, & + -1.3684354599285D+04, 9.3754012976495D+03,-7.4676475789329D+04, & + -1.8122270942076D+05, 2.6987309391410D+05, 4.0582251904706D+05, & + -4.7103517814752D+05,-3.6115503974010D+05, 3.2284775325099D+05, & + 1.3264691929787D+04, 1.8025253924335D+05,-1.2235925565102D+04, & + -9.1363898120735D+03,-4.1294242946858D+04,-3.4995730900098D+04, & + 3.1769893347165D+05, 2.8395605362570D+05,-1.0784536354219D+06, & + -5.9451106980882D+05, 1.5215430060937D+06, 4.5943167339298D+05, & + -7.9957883936866D+05,-9.2432840622294D+04, 5.5825423140341D+03, & + 3.0673594098716D+03, 8.7439532014842D+04, 1.9113438435651D+05, & + -3.4306742659939D+05,-3.0711488132651D+05, 6.2118702580693D+05, & + -1.5805976377422D+04,-4.2038045404190D+05, 3.4847108834282D+05, & + -1.3486811106770D+04, 3.1256632170871D+04, 5.3344700235019D+03, & + 2.6384242145376D+04, 1.2917121516510D+05,-1.3160848301195D+05, & + -4.5853998051192D+05, 3.5760105069089D+05, 6.4570143281747D+05, & + -3.6980075904167D+05,-3.2941029518332D+05,-3.5042507366553D+05, & + 2.1513919629391D+03, 6.3403845616538D+04, 6.2152822008047D+04, & + -4.8805335375295D+05,-6.3261951398766D+05, 1.8433340786742D+06, & + 1.4650263449690D+06,-2.9204939728308D+06,-1.1011338105757D+06, & + 1.7270664922758D+06, 3.4925947462024D+05,-1.9526251371308D+04, & + -3.2271030511683D+04,-3.7601575719875D+05, 1.8295007005531D+05, & + 1.5005699079799D+06,-1.2350076538617D+06,-1.8221938812193D+06, & + 1.5438780841786D+06,-3.2729150692367D+03, 1.0546285883943D+04, & + -4.7118461673723D+04,-1.1458551385925D+05, 2.7704588008958D+05, & + 7.4145816862032D+05,-6.6864945408289D+05,-1.6992324545166D+06, & + 6.7487333473248D+05, 1.4361670430046D+06,-2.0837555267331D+05, & + 4.7678355561019D+05,-1.5194821786066D+04,-1.1987249931134D+05, & + 1.3007675671713D+05, 9.6641544907323D+05,-5.3379849922258D+05, & + -2.4303858824867D+06, 1.5261649025605D+06, 2.0186755858342D+06, & + -1.6429544469130D+06,-1.7921520714752D+04, 1.4125624734639D+04, & + -2.5345006031695D+04, 1.7853375909076D+05,-5.4318156343922D+04, & + -3.6889685715963D+05, 4.2449670705837D+05, 3.5020329799394D+05, & + 9.3825886484788D+03,-8.0012127425648D+05, 9.8554789856472D+04, & + 4.9210554266522D+05,-6.4038493953446D+05,-2.8398085766046D+06, & + 2.1390360019254D+06, 6.3452935017176D+06,-2.3677386290925D+06, & + -3.9697874352050D+06,-1.9490691547041D+04, 4.4213579019433D+04, & + 1.6113884156437D+05,-7.1247665213713D+05,-1.1808376404616D+06, & + 3.0815171952564D+06, 1.3519809705593D+06,-3.4457898745450D+06, & + 2.0705775494050D+05,-4.3778169926622D+05, 8.7041260169714D+03, & + 1.8982512628535D+05,-2.9708215504578D+05,-8.8213012222074D+05, & + 8.6031109049755D+05, 1.0968800857081D+06,-1.0114716732602D+06, & + 1.9367263614108D+05, 2.8678295007137D+05,-9.4347729862989D+04, & + 4.4154039394108D+04, 5.3686756196439D+05, 1.7254041770855D+05, & + -2.5310674462399D+06,-2.0381171865455D+06, 3.3780796258176D+06, & + 7.8836220768478D+05,-1.5307728782887D+05,-3.7573362053757D+05, & + 1.0124501604626D+06, 2.0929686545723D+06,-5.7305706586465D+06, & + -2.6200352535413D+06, 7.1543745536691D+06,-1.9733601879064D+04, & + 8.5273008477607D+04, 6.1062454495045D+04,-2.2642508675984D+05, & + 2.4581653864150D+05,-9.0376851105383D+05,-4.4367930945690D+05, & + 1.5740351463593D+06, 2.4563041445249D+05,-3.4697646046367D+03, & + -2.1391370322552D+05, 4.2358948404842D+05, 5.6270081955003D+05, & + -8.5007851251980D+05,-6.1182429537130D+05, 5.6690751824341D+05, & + -3.5617502919487D+05,-8.1875263381402D+02,-2.4506258140060D+05, & + 2.5830513731509D+05, 6.0646114465433D+05,-6.9676584616955D+05, & + 5.1937406389690D+05, 1.7261913546007D+05,-1.7405787307472D+04, & + -3.8301842660567D+05, 5.4227693205154D+05, 2.5442083515211D+06, & + -1.1837755702370D+06,-1.9381959088092D+06,-4.0642141553575D+05, & + 1.1840693827934D+04,-1.5334500255967D+05, 4.9098619510989D+05, & + 6.1688992640977D+05, 2.2351144690009D+05,-1.8550462739570D+06, & + 9.6815110649918D+03,-8.1526584681055D+04,-8.0810433155289D+04, & + 3.4520506615177D+05, 2.5509863381419D+05,-1.3331224992157D+05, & + -4.3119301071653D+05,-5.9818343115856D+04, 1.7863692414573D+03, & + 8.9440694919836D+04,-2.5558967650731D+05,-2.2130423988459D+04, & + 4.4973674518316D+05,-2.2094939343618D+05/ +data (cbasis(i),i=1,245)/& + 6.9770019624764D-04,-2.4209870001642D+01, 1.8113927151562D+01, & + 3.5107416275981D+01,-5.4600021126735D+00,-4.8731149608386D+01, & + 3.6007189184766D+01, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + -7.7178474355102D+01,-3.8460795013977D+01,-4.6622480912340D+01, & + 5.5684951167513D+01, 1.2274939911242D+02,-1.4325154752086D+02, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00,-6.0800589055949D+00, & + 8.6171499453475D+01,-8.4066835441327D+01,-5.8228085624620D+01, & + 2.0237393793875D+02, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 3.3525582670313D+02, 7.0056962392208D+01,-4.5312502936708D+01, & + -3.0441141194247D+02, 2.8111438108965D+02, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-1.2983583774779D+02, 3.9781671212935D+01, & + -6.6793945229609D+01,-1.9259805675433D+02, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-8.2855757669957D+02,-5.7003072730941D+01, & + -3.5604806670066D+01, 9.6277766002709D+01, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 8.8645622149112D+02,-7.6908409772041D+01, & + 6.8111763314154D+01, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 2.5090493428062D+02,-2.3622141780572D+02, 5.8155647658455D+02, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 2.8919570295095D+03, & + -1.7871014635921D+02,-1.3515667622500D+02, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-3.6965613754734D+03, 2.1148158286617D+02, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00,-1.4795670139431D+03, & + 3.6210798138768D+02, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + -5.3552886800881D+03, 3.1006384016202D+02, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 1.6241824368764D+03, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 4.3764909606382D+03, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 1.0940849243716D+03, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 3.0743267832931D+03, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00/ +data (ccore(i),i=1,245)/& + 2.4332191647159D-02,-2.9749090113656D+01, 1.8638980892831D+01, & + -6.1272361746520D+00, 2.1567487597605D+00,-1.5552044084945D+01, & + 8.9752150543954D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + -3.5693557878741D+02,-3.0398393196894D+00,-6.5936553294576D+00, & + 1.6056619388911D+01, 7.8061422868204D+01,-8.6270891686359D+01, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00,-3.1688002530217D+01, & + 3.7586725583944D+01,-3.2725765966657D+01,-5.6458213299259D+00, & + 2.1502613314595D+01, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 5.2789943583277D+02,-4.2461079404962D+00,-2.4937638543122D+01, & + -1.1963809321312D+02, 2.0240663228078D+02, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-6.2574211352272D+02,-6.9617539465382D+00, & + -5.9440243471241D+01, 1.4944220180218D+01, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-1.2851139918332D+03,-6.5043516710835D+00, & + 4.0410829440249D+01,-6.7162452402027D+01, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 1.0031942127832D+03, 7.6137226541944D+01, & + -2.7279242226902D+01, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + -3.3059000871075D+01, 2.4384498749480D+01,-1.4597931874215D+02, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 1.6559579606045D+03, & + 1.5038996611400D+02,-7.3865347730818D+01, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-1.9738401290808D+03,-1.4149993809415D+02, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00,-1.2756627454888D+02, & + 4.1487702227579D+01, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + -1.7406770966429D+03,-9.3812204399266D+01, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-1.1890301282216D+03, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 2.3723447727360D+03, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-1.0279968223292D+03, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 5.7153838472603D+02, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00/ +data (crest(i),i=1,245)/& + 0.0000000000000D+00,-4.7430930170000D+00,-1.4422132560000D+01, & + -1.8061146510000D+01, 7.5186735000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + -2.7962099800000D+02, 1.7616414260000D+01,-9.9741392630000D+01, & + 7.1402447000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00,-7.8571336480000D+01, & + 5.2434353250000D+01, 7.7696745000000D+01, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 1.7799123760000D+02, 1.4564532380000D+02, 2.2347226000000D+02, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-4.3823284100000D+02,-7.2846553000000D+02, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00,-2.6752313750000D+02, 3.6170310000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00, 0.0000000000000D+00, & + 0.0000000000000D+00, 0.0000000000000D+00/ +real(dp) :: reoh, thetae, b1, roh, alphaoh, deoh, phh1, phh2 +data reoh,thetae,b1,roh,alphaoh,deoh,phh1,phh2/0.958649d0,& + 104.3475d0,2.0d0,0.9519607159623009d0,2.587949757553683d0,& + 42290.92019288289d0,16.94879431193463d0,12.66426998162947d0/ +real(dp) :: f5z, fbasis, fcore, frest +data f5z,fbasis,fcore,frest/0.99967788500000d0,& + 0.15860145369897d0,-1.6351695982132d0,1d0/ + +interface Initialise + module procedure IPModel_PartridgeSchwenke_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_PartridgeSchwenke_Finalise +end interface Finalise + +interface Print + module procedure IPModel_PartridgeSchwenke_Print +end interface Print + +interface Calc + module procedure IPModel_PartridgeSchwenke_Calc +end interface Calc + +contains + +subroutine IPModel_PartridgeSchwenke_Initialise_str(this, args_str, param_str, error) + type(IPModel_PartridgeSchwenke), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out) :: error + + call Finalise(this) + + call initialise(params) + call param_register(params, 'OHH_ordercheck', 'T', this%OHH_ordercheck, help_string="if FALSE, skip transforming atomic order to OHHOHHOHH... and assume atoms are in that order. This also skips cutoff checking for OH bonds. default: TRUE") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_PartridgeSchwenke_Initialise args_str')) then + RAISE_ERROR("IPModel_PartridgeSchwenke failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + +end subroutine IPModel_PartridgeSchwenke_Initialise_str + +subroutine IPModel_PartridgeSchwenke_Finalise(this) + type(IPModel_PartridgeSchwenke), intent(inout) :: this +end subroutine IPModel_PartridgeSchwenke_Finalise + + +subroutine IPModel_PartridgeSchwenke_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_PartridgeSchwenke), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), dimension(at%N/3,3) :: rij ! array to pass to vibpot containing geometry + real(dp), dimension(at%N/3) :: v ! result from vibpot containing energy + integer :: i, o, h1, h2 + integer, dimension(3,at%N/3) :: water_index + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if(present(local_e)) then + RAISE_ERROR('local_e not implemented', error) + end if + if(present(f)) then + RAISE_ERROR('forces not implemented', error) + end if + if(present(virial)) then + RAISE_ERROR('virial not implemented', error) + end if + if (present(local_virial)) then + RAISE_ERROR("IPModel_PartridgeSchwenke_Calc: local_virial calculation requested but not supported yet.", error) + endif + + if(.not. present(e)) return ! nothing to do + + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_PartridgeSchwenke_Calc args_str')) then + RAISE_ERROR("IPModel_PartridgeSchwenke_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_PartridgeSchwenke_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_PartridgeSchwenke_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + endif + + ! loop through atoms, find oxygens and their closest hydrogens + + call find_water_monomer(at,water_index,this%OHH_ordercheck,error=error) + + do i = 1, at%N/3 + o = water_index(1,i) + h1 = water_index(2,i) + h2 = water_index(3,i) + rij(i,1) = distance_min_image(at,o,h1) + rij(i,2) = distance_min_image(at,o,h2) + rij(i,3) = acos(cosine(at,o,h1,h2)) + end do + + ! convert distances to atomic units + do i = 1, at%N/3 + rij(i,1) = rij(i,1)/BOHR + rij(i,2) = rij(i,2)/BOHR + end do + call vibpot(rij, v, at%N/3) ! actually call energy calculator + e = sum(v)*HARTREE ! convert result into eV + +end subroutine IPModel_PartridgeSchwenke_Calc + + +subroutine IPModel_PartridgeSchwenke_Print(this, file) + type(IPModel_PartridgeSchwenke), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + call Print("IPModel_PartridgeSchwenke : Partridge-Schwenke water molecule potential", file=file) + call print("pes for h2o", file=file) + call print("by Harry Partridge and David W. Schwenke", file=file) + call print("submitted to J. Chem. Phys. Aug. 28, 1996", file=file) +end subroutine IPModel_PartridgeSchwenke_Print + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X the following is the original code accompanying the article +!X modified to f90 freeform format and some printing commented out +!X parameter declarations were moved out into the module scope +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine vibpot(rij,v,n) + integer :: n + real(dp), dimension(n, 3) :: rij + real(dp), dimension(n) :: v + +! +! pes for h2o, +! Harry Partridge and David W. Schwenke, J. Chem. Phys., +! submitted Aug. 28, 1996. +! rij(i,1)& rij(i,2) are oh distances in au +! rij(i,3) is hoh angle in rad +! v(i) is pes in au +! n is number of geometries +! + real(dp) :: fmat(15,3) + integer :: ifirst = 0 + integer :: i, j + real(dp) :: ce, ex, rad, rhh, term, vhh, voh1, voh2, x1, x2, x3 + save + + if(ifirst.eq.0)then + ifirst=1 +! write(6,1) +! 1 format(/1x,'pes for h2o', +! $ /1x,'by Harry Partridge and David W. Schwenke', +! $ /1x,'submitted to J. Chem. Phys. Aug. 28, 1996') +! write(6,56) +! 56 format(/1x,'parameters before adjustment') +! write(6,55)phh1,phh2,deoh,alphaoh,roh +! 55 format(/1x,'two body potential parameters:', +! $ /1x,'hh: phh1 = ',f10.1,' phh2 = ',f5.2, +! $ /1x,'oh: deoh = ',f10.1,' alpha = ',f7.4, +! $ ' re = ',f7.4) +! write(6,4)reoh,thetae,b1 +! 4 format(/1x,'three body parameters:', +! $ /1x,'reoh = ',f10.4,' thetae = ',f10.4, +! $ /1x,'betaoh = ',f10.4, +! $ /1x,' i j k',7x,'c5z',9x,'cbasis',10x,'ccore', +! $ 10x,'crest') + do i=1,245 +! write(6,5)(idx(i,j)-1,j=1,3),c5z(i),cbasis(i),ccore(i),crest(i) +! 5 format(1x,3i5,1p4e15.7) + c5z(i)=f5z*c5z(i)+fbasis*cbasis(i)+fcore*ccore(i) & + +frest*crest(i) + end do +! write(6,57)f5z,fbasis,fcore,frest +! 57 format(/1x,'adjusting parameters using scale factors ', +! $ /1x,'f5z = ',f11.8, +! $ /1x,'fbasis = ',f11.8, +! $ /1x,'fcore = ',f11.8, +! $ /1x,'frest = ',f11.8) + phh1=phh1*f5z + deoh=deoh*f5z +! write(6,55)phh1,phh2,deoh,alphaoh,roh +! write(6,58)reoh,thetae,b1,((idx(i,j)-1,j=1,3),c5z(i),i=1,245) +! 58 format(/1x,'three body parameters:', +! $ /1x,'reoh = ',f10.4,' thetae = ',f10.4, +! $ /1x,'betaoh = ',f10.4, +! $ /1x,' i j k cijk', +! $ /(1x,3i5,1pe15.7)) +! +! convert parameters from 1/cm, angstrom to a.u. +! + reoh=reoh/0.529177249d0 + b1=b1*0.529177249d0*0.529177249d0 + do i=1,245 + c5z(i)=c5z(i)*4.556335d-6 + end do + rad=acos(-1d0)/1.8d2 + ce=cos(thetae*rad) + phh1=phh1*exp(phh2) + phh1=phh1*4.556335d-6 + phh2=phh2*0.529177249d0 + deoh=deoh*4.556335d-6 + roh=roh/0.529177249d0 + alphaoh=alphaoh*0.529177249d0 + c5z(1)=c5z(1)*2d0 + end if + + do i=1,n + x1=(rij(i,1)-reoh)/reoh + x2=(rij(i,2)-reoh)/reoh + x3=cos(rij(i,3))-ce + rhh=sqrt(rij(i,1)**2+rij(i,2)**2-2d0*rij(i,1)*rij(i,2)*cos(rij(i,3))) + vhh=phh1*exp(-phh2*rhh) + ex=exp(-alphaoh*(rij(i,1)-roh)) + voh1=deoh*ex*(ex-2d0) + ex=exp(-alphaoh*(rij(i,2)-roh)) + voh2=deoh*ex*(ex-2d0) + fmat(1,1)=1d0 + fmat(1,2)=1d0 + fmat(1,3)=1d0 + do j=2,15 + fmat(j,1)=fmat(j-1,1)*x1 + fmat(j,2)=fmat(j-1,2)*x2 + fmat(j,3)=fmat(j-1,3)*x3 + end do + v(i)=0d0 + do j=2,245 + term=c5z(j)*(fmat(idx(j,1),1)*fmat(idx(j,2),2) & + +fmat(idx(j,2),1)*fmat(idx(j,1),2)) & + *fmat(idx(j,3),3) + v(i)=v(i)+term + end do + v(i)=v(i)*exp(-b1*((rij(i,1)-reoh)**2+(rij(i,2)-reoh)**2)) & + +c5z(1) & + +voh1+voh2+vhh + end do + return +end subroutine vibpot + +end module IPModel_PartridgeSchwenke_module diff --git a/src/Potentials/IPModel_RS.F90 b/src/Potentials/IPModel_RS.F90 new file mode 100644 index 0000000000..8fdad875ff --- /dev/null +++ b/src/Potentials/IPModel_RS.F90 @@ -0,0 +1,575 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_RS module +!X +!% Module for a Repulsive Step pair potential. +!% \begin{equation} +!% \nonumber +!% V(r) = \epsilon \left[ \left( \frac{\sigma}{r} \right)^{14} + \frac{1}{2} \left( 1 - \tanh (k (r - \sigma_1)) \right) \right] +!% \end{equation} +!% From J. Chem. Phys. 129, 064512 (2008) +!% +!% The IPModel_RS object contains all the parameters read from a +!% 'RS_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_RS_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, split_string_simple, string_to_numerical, operator(//) +use extendable_str_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use units_module, only : PI +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_RS +type shoulder_params_t + integer :: n = 0 + real(dp), dimension(:), allocatable :: sigma1, lambda, k + real(dp) :: lambda0 = 0.0_dp +endtype shoulder_params_t + +type IPModel_RS + integer :: n_types = 0 !% Number of atomic types. + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types}. + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + real(dp), allocatable :: eps(:,:), sigma(:,:) + type(shoulder_params_t), dimension(:,:), allocatable :: shoulder_params + + character(len=STRING_LENGTH) label + +end type IPModel_RS + +logical, private :: parse_in_ip, parse_matched_label +integer, private :: parse_ti, parse_tj +type(extendable_str), private, save :: parse_element_data +type(IPModel_RS), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_RS_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_RS_Finalise +end interface Finalise + +interface Print + module procedure IPModel_RS_Print +end interface Print + +interface Calc + module procedure IPModel_RS_Calc +end interface Calc + +contains + +subroutine IPModel_RS_Initialise_str(this, args_str, param_str) + type(IPModel_RS), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label = '' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_RS_Initialise_str args_str')) then + call system_abort("IPModel_RS_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_RS_read_params_xml(this, param_str) + +end subroutine IPModel_RS_Initialise_str + +subroutine IPModel_RS_Finalise(this) + type(IPModel_RS), intent(inout) :: this + integer :: i, j + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%sigma)) deallocate(this%sigma) + if (allocated(this%eps)) deallocate(this%eps) + if (allocated(this%shoulder_params)) then + do i = 1, this%n_types + do j = 1, this%n_types + if(allocated(this%shoulder_params(j,i)%sigma1)) deallocate(this%shoulder_params(j,i)%sigma1) + if(allocated(this%shoulder_params(j,i)%lambda)) deallocate(this%shoulder_params(j,i)%lambda) + if(allocated(this%shoulder_params(j,i)%k)) deallocate(this%shoulder_params(j,i)%k) + this%shoulder_params(j,i)%n = 0 + this%shoulder_params(j,i)%lambda0 = 0.0_dp + enddo + enddo + deallocate(this%shoulder_params) + endif + + this%n_types = 0 + this%label = '' +end subroutine IPModel_RS_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_RS_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_RS), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), pointer :: w_e(:) + integer i, ji, j, ti, tj + real(dp) :: dr(3), dr_mag + real(dp) :: de, de_dr, virial_i(3,3) + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_RS_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_RS_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_RS_Calc', error) + local_virial = 0.0_dp + endif + + atom_mask_pointer => null() + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of logical property used to mask atoms") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_RS_Calc args_str')) then + RAISE_ERROR("IPModel_RS_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_RS_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + else + atom_mask_pointer => null() + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_RS_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + + endif ! present(args_str) + + if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) + + do i = 1, at%N + + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + do ji = 1, n_neighbours(at, i) + j = neighbour(at, i, ji, dr_mag, cosines = dr) + + if (dr_mag .feq. 0.0_dp) cycle + !if (j <= 0) cycle + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (present(e) .or. present(local_e)) then + de = 0.5_dp * IPModel_RS_pairenergy(this, ti, tj, dr_mag) + + if (present(local_e)) then + local_e(i) = local_e(i) + de + endif + if (present(e)) then + if (associated(w_e)) then + de = de*0.5_dp*(w_e(i)+w_e(j)) + endif + e = e + de + endif + endif + if (present(f) .or. present(virial)) then + de_dr = 0.5_dp*IPModel_RS_pairenergy_deriv(this, ti, tj, dr_mag) + if (associated(w_e)) then + de_dr = de_dr*0.5_dp*(w_e(i)+w_e(j)) + endif + if (present(f)) then + f(:,i) = f(:,i) + de_dr*dr + f(:,j) = f(:,j) - de_dr*dr + endif + + if (present(virial) .or. present(local_virial) ) virial_i = de_dr*(dr .outer. dr)*dr_mag + if (present(virial)) virial = virial - virial_i + if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i, (/9/)) + endif + end do + end do + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(local_virial)) call sum_in_place(mpi, local_virial) + if (present(f)) call sum_in_place(mpi, f) + endif + +end subroutine IPModel_RS_Calc + +!% This routine computes the two-body term for a pair of atoms separated by a distance r. +function IPModel_RS_pairenergy(this, ti, tj, r) + type(IPModel_RS), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_RS_pairenergy + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff)) then + IPModel_RS_pairenergy = 0.0_dp + return + endif + + IPModel_RS_pairenergy = this%eps(ti,tj) * ( & + ( this%sigma(ti,tj) / r )**14 + & + sum( this%shoulder_params(ti,tj)%lambda * tanh( this%shoulder_params(ti,tj)%k * ( r - this%shoulder_params(ti,tj)%sigma1 ) ) ) + & + this%shoulder_params(ti,tj)%lambda0 ) + +end function IPModel_RS_pairenergy + +!% Derivative of the two-body term. +function IPModel_RS_pairenergy_deriv(this, ti, tj, r) + type(IPModel_RS), intent(in) :: this + integer, intent(in) :: ti, tj !% Atomic types. + real(dp), intent(in) :: r !% Distance. + real(dp) :: IPModel_RS_pairenergy_deriv + + if ((r .feq. 0.0_dp) .or. (r > this%cutoff)) then + IPModel_RS_pairenergy_deriv = 0.0_dp + return + endif + + IPModel_RS_pairenergy_deriv = this%eps(ti,tj) * ( & + - 14.0_dp * ( this%sigma(ti,tj) / r )**14 / r + & + sum( this%shoulder_params(ti,tj)%lambda * & + this%shoulder_params(ti,tj)%k / cosh( this%shoulder_params(ti,tj)%k * ( r - this%shoulder_params(ti,tj)%sigma1 ) )**2 ) ) + +end function IPModel_RS_pairenergy_deriv + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for XML stanza is given below, please notice that +!% they are simply dummy parameters for testing purposes, with no physical meaning. +!% +!% +!% +!% +!% +!% -0.5 +!% 1.35 +!% 10 +!% +!% +!% +!% +!% +!% -0.8 0.3 +!% 1.35 1.80 +!% 10 10 +!% +!% +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + if (name == 'RS_params') then ! new RS stanza + + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered RS_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in RS_params") + endif + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if (status == 0) then + read (value, *) parse_ip%cutoff + else + call system_abort("Can't find cutoff in RS_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%sigma(parse_ip%n_types,parse_ip%n_types)) + parse_ip%sigma = 1.0_dp + allocate(parse_ip%eps(parse_ip%n_types,parse_ip%n_types)) + parse_ip%eps = 0.0_dp + allocate(parse_ip%shoulder_params(parse_ip%n_types,parse_ip%n_types)) + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find type") + read (value, *) parse_ti + + if (parse_ti < 1) call system_abort("IPModel_RS_read_params_xml got per_type_data type="//parse_ti//" < 1") + if (parse_ti > parse_ip%n_types) call system_abort("IPModel_RS_read_params_xml got per_type_data type="//parse_ti//" > n_types="//parse_ip%n_types) + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(parse_ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do parse_ti=1, parse_ip%n_types + if (parse_ip%atomic_num(parse_ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(parse_ti)) = parse_ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "type1", value, status) + if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find type1") + read (value, *) parse_ti + call QUIP_FoX_get_value(attributes, "type2", value, status) + if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find type2") + read (value, *) parse_tj + + if (parse_ti < 1) call system_abort("IPModel_RS_read_params_xml got per_type_data type1="//parse_ti//" < 1") + if (parse_ti > parse_ip%n_types) call system_abort("IPModel_RS_read_params_xml got per_pair_data type1="//parse_ti//" > n_types="//parse_ip%n_types) + if (parse_tj < 1) call system_abort("IPModel_RS_read_params_xml got per_type_data type2="//parse_tj//" < 1") + if (parse_tj > parse_ip%n_types) call system_abort("IPModel_RS_read_params_xml got per_pair_data type2="//parse_tj//" > n_types="//parse_ip%n_types) + + call QUIP_FoX_get_value(attributes, "sigma", value, status) + if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find sigma") + read (value, *) parse_ip%sigma(parse_ti,parse_tj) + call QUIP_FoX_get_value(attributes, "eps", value, status) + if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find eps6") + read (value, *) parse_ip%eps(parse_ti,parse_tj) + + + + call QUIP_FoX_get_value(attributes, "n", value, status) + if (status /= 0) call system_abort ("IPModel_RS_read_params_xml cannot find n") + read (value, *) parse_ip%shoulder_params(parse_ti,parse_tj)%n + allocate( parse_ip%shoulder_params(parse_ti,parse_tj)%sigma1( parse_ip%shoulder_params(parse_ti,parse_tj)%n ), & + parse_ip%shoulder_params(parse_ti,parse_tj)%lambda( parse_ip%shoulder_params(parse_ti,parse_tj)%n ), & + parse_ip%shoulder_params(parse_ti,parse_tj)%k( parse_ip%shoulder_params(parse_ti,parse_tj)%n ) ) + + if (parse_ti /= parse_tj) then + parse_ip%eps(parse_tj,parse_ti) = parse_ip%eps(parse_ti,parse_tj) + parse_ip%sigma(parse_tj,parse_ti) = parse_ip%sigma(parse_ti,parse_tj) + parse_ip%shoulder_params(parse_tj,parse_ti)%n = parse_ip%shoulder_params(parse_ti,parse_tj)%n + + allocate( parse_ip%shoulder_params(parse_tj,parse_ti)%sigma1( parse_ip%shoulder_params(parse_tj,parse_ti)%n ), & + parse_ip%shoulder_params(parse_tj,parse_ti)%lambda( parse_ip%shoulder_params(parse_tj,parse_ti)%n ), & + parse_ip%shoulder_params(parse_tj,parse_ti)%k( parse_ip%shoulder_params(parse_tj,parse_ti)%n ) ) + end if + + elseif (parse_in_ip .and. name == 'lambda') then + call zero(parse_element_data) + elseif (parse_in_ip .and. name == 'sigma1') then + call zero(parse_element_data) + elseif (parse_in_ip .and. name == 'k') then + call zero(parse_element_data) + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'RS_params') then + parse_in_ip = .false. + elseif( name == "lambda" ) then + call string_to_numerical( string(parse_element_data), parse_ip%shoulder_params(parse_ti,parse_tj)%lambda ) + parse_ip%shoulder_params(parse_ti,parse_tj)%lambda0 = -sum(parse_ip%shoulder_params(parse_ti,parse_tj)%lambda) + if( parse_ti /= parse_tj ) then + parse_ip%shoulder_params(parse_tj,parse_ti)%lambda = parse_ip%shoulder_params(parse_ti,parse_tj)%lambda + parse_ip%shoulder_params(parse_tj,parse_ti)%lambda0 = parse_ip%shoulder_params(parse_ti,parse_tj)%lambda0 + endif + elseif( name == "sigma1" ) then + call string_to_numerical( string(parse_element_data), parse_ip%shoulder_params(parse_ti,parse_tj)%sigma1 ) + if( parse_ti /= parse_tj ) parse_ip%shoulder_params(parse_tj,parse_ti)%sigma1 = parse_ip%shoulder_params(parse_ti,parse_tj)%sigma1 + elseif( name == "k" ) then + call string_to_numerical( string(parse_element_data), parse_ip%shoulder_params(parse_ti,parse_tj)%k ) + if( parse_ti /= parse_tj ) parse_ip%shoulder_params(parse_tj,parse_ti)%k = parse_ip%shoulder_params(parse_ti,parse_tj)%k + end if + + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_characters_handler(in) + character(len=*), intent(in) :: in + + if( parse_in_ip ) then + call concat(parse_element_data, in, keep_lf=.false.,lf_to_whitespace=.true.) + endif +endsubroutine IPModel_characters_handler + +subroutine IPModel_RS_read_params_xml(this, param_str) + type(IPModel_RS), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + call initialise(parse_element_data) + + call open_xml_string(fxml, param_str) + call parse(fxml, & + characters_handler = IPModel_characters_handler, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + call finalise(parse_element_data) + + if (this%n_types == 0) then + call system_abort("IPModel_RS_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_RS_read_params_xml + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of RS parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_RS_Print (this, file) + type(IPModel_RS), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_RS : Repulsive Step", file=file) + call Print("IPModel_RS : label = "//this%label, file=file) + call Print("IPModel_RS : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_RS : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + do tj=1, this%n_types + call Print ("IPModel_RS : interaction " // ti // " " // tj // " sigma " // this%sigma(ti,tj) // " eps " // & + this%eps(ti,tj) // " sigma1 " // this%shoulder_params(ti,tj)%sigma1 // " k " // this%shoulder_params(ti,tj)%k // & + " lambda " // this%shoulder_params(ti,tj)%lambda, file=file) + end do + call verbosity_pop() + end do + +end subroutine IPModel_RS_Print + +end module IPModel_RS_module diff --git a/src/Potentials/IPModel_SCME.F90 b/src/Potentials/IPModel_SCME.F90 new file mode 100644 index 0000000000..c0d51f69ec --- /dev/null +++ b/src/Potentials/IPModel_SCME.F90 @@ -0,0 +1,336 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_SCME +!X +!% SCME module for the single-centre multipole expansion water module, developed by Thor Wikfeldt +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_SCME_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use linearalgebra_module, only: is_diagonal +use topology_module, only: find_water_monomer +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +#ifdef HAVE_SCME +use scme, only : scme_calculate +#endif + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_SCME +type IPModel_SCME + !integer :: n_types = 0 + !integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + logical :: full_interaction_order, use_repulsion, use_PS_PES + + character(len=STRING_LENGTH) :: label + +end type IPModel_SCME + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_SCME), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_SCME_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_SCME_Finalise +end interface Finalise + +interface Print + module procedure IPModel_SCME_Print +end interface Print + +interface Calc + module procedure IPModel_SCME_Calc +end interface Calc + +contains + +subroutine IPModel_SCME_Initialise_str(this, args_str, param_str) + type(IPModel_SCME), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'full_interaction_order', 'T', this%full_interaction_order, help_string="Whether to truncate the interaction order calculation at 5th order") + call param_register(params, 'use_repulsion', 'F', this%use_repulsion, help_string="Whether to use repulsion in SCME") + call param_register(params, 'use_PS_PES', 'T', this%use_PS_PES, help_string="Whether to use the PS potential energy surface") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SCME_Initialise_str args_str')) then + call system_abort("IPModel_SCME_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + if( trim(this%label) /= "version_20170802" ) then + call system_abort("IPModel_SCME_Initialise_str: SCME with updated parameters/damping. Make sure your potential is compatible. Proceed with caution, email Albert for instructions if in doubt.") + endif + !call IPModel_SCME_read_params_xml(this, param_str) + this%cutoff = 2.0_dp + + ! Add initialisation code here + +end subroutine IPModel_SCME_Initialise_str + +subroutine IPModel_SCME_Finalise(this) + type(IPModel_SCME), intent(inout) :: this + + ! Add finalisation code here + this%cutoff = 0.0_dp + + this%label = '' +end subroutine IPModel_SCME_Finalise + + + + + + + +!///////////////////////////////// +subroutine IPModel_SCME_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_SCME), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:) !j + real(dp), intent(out), optional :: local_virial(:,:) !j + !j real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer :: nWater, i, a, m + integer, dimension(:,:), allocatable :: water_monomer_index + real(dp) :: uTot + real(dp), dimension(3) :: lattice + real(dp), dimension(:), allocatable :: raOri + real(dp), dimension(:,:), allocatable :: coords !j + real(dp), dimension(:,:), allocatable :: fa !j + + INIT_ERROR(error) +#ifndef HAVE_SCME + RAISE_ERROR('IPModel_SCME_Calc - not linked to the scme library',error) +#endif + + if (present(e)) e = 0.0_dp + + if (present(local_e)) then + RAISE_ERROR('IPModel_SCME_Calc - local energies not implemented',error) + call check_size('Local_E',local_e,(/at%N/),'IPModel_SCME_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + RAISE_ERROR('IPModel_SCME_Calc - forces not implemented',error) + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_SCME_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) then + RAISE_ERROR('IPModel_SCME_Calc - virials not implemented',error) + virial = 0.0_dp + endif + + if (present(local_virial)) then + RAISE_ERROR('IPModel_SCME_Calc - local virials not implemented',error) + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_SCME_Calc', error) + local_virial = 0.0_dp + endif + + nWater = count(at%Z==8) + allocate(water_monomer_index(3,nWater)) + call find_water_monomer(at,water_monomer_index,error=error) + + !j allocate(raOri(3*at%N),fa(3*at%N)) + allocate(raOri(3*at%N),fa(3,at%N)) !j + allocate( coords(3,at%N) ) !j + + if( is_diagonal(at%lattice) ) then + do i = 1, 3 + lattice(i) = at%lattice(i,i) + enddo + else + RAISE_ERROR('IPModel_SCME_Calc - lattice must be orthorhombic',error) + endif + + do i = 1, nWater !j molecules. I should change raOrig to at(3,n_atoms) or at(3,3,n_water) + + ! This is the new 3 by N_atoms coordinate matrix + coords(:,(i-1)*3+1) = at%pos(:,water_monomer_index(2,i)) !j coords is hho ordered in scme + coords(:,(i-1)*3+2) = at%pos(:,water_monomer_index(3,i)) + coords(:,(i-1)*3+3) = at%pos(:,water_monomer_index(1,i)) + + ! This is the old version: + do a = 1, 3 !j xyz + raOri( (i-1)*6 + a ) = at%pos(a,water_monomer_index(2,i)) !j h + raOri( (i-1)*6 + a + 3 ) = at%pos(a,water_monomer_index(3,i)) !j h + raOri( (i-1)*3 + nWater*6 + a ) = at%pos(a,water_monomer_index(1,i)) !j o + enddo + enddo + +#ifdef HAVE_SCME + !call scme_calculate(at%N,raOri, lattice, fa, uTot) + call scme_calculate(at%N,coords, lattice, fa, uTot,in_FULL=this%full_interaction_order, in_USE_REP=this%use_repulsion, in_USE_PS_PES=this%use_PS_PES) +#endif + + + if(present(f))then + do m = 1,nWater !jö Rearange from HHO (in fa in SCME) to OHH ( in f in QUIP) + f(:,(m-1)*3+1)=fa(:,(m-1)*3+3) !O + f(:,(m-1)*3+2)=fa(:,(m-1)*3+1) !H1 + f(:,(m-1)*3+3)=fa(:,(m-1)*3+2) !H1 + enddo + endif + + !if(present(f)) f = fa !j copy over the forces to the quip-defined array f from scme-specified fa ! How come the order gets correct? + + if (present(e)) e = uTot !j if (present): Refers to optional arguments + + if(allocated(water_monomer_index)) deallocate(water_monomer_index) + if(allocated(raOri)) deallocate(raOri) + if(allocated(fa)) deallocate(fa) + +end subroutine IPModel_SCME_Calc +!/////////////////////////////////////////////////////////// + + + + + + +subroutine IPModel_SCME_Print(this, file) + type(IPModel_SCME), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_SCME : SCME Potential", file=file) + +end subroutine IPModel_SCME_Print + +subroutine IPModel_SCME_read_params_xml(this, param_str) + type(IPModel_SCME), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + +end subroutine IPModel_SCME_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + if (name == 'SCME_params') then ! new SCME stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if(parse_in_ip) then + call finalise(parse_ip) + endif + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'SCME_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_SCME_module diff --git a/src/Potentials/IPModel_SW.F90 b/src/Potentials/IPModel_SW.F90 new file mode 100644 index 0000000000..1b21f02f57 --- /dev/null +++ b/src/Potentials/IPModel_SW.F90 @@ -0,0 +1,920 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_SW module +!X +!% Module for the Stillinger and Weber potential for silicon +!% (Ref. Phys. Rev. B {\bf 31}, 5262, (1984)). +!% The IPModel_SW object contains all the parameters read +!% from an 'SW_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_SW_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_NERD, PRINT_VERBOSE, PRINT_ANALYSIS, current_verbosity, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_SW +type IPModel_SW + integer :: n_types = 0 !% Number of atomic types + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} + + real(dp) :: cutoff = 0.0_dp + + real(dp), allocatable :: a(:,:), AA(:,:), BB(:,:), p(:,:), q(:,:), sigma(:,:), eps2(:,:) !% IP parameters + real(dp), allocatable :: lambda(:,:,:), gamma(:,:,:), eps3(:,:,:) !% IP parameters + + character(len=STRING_LENGTH) :: label + +end type IPModel_SW + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_SW), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_SW_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_SW_Finalise +end interface Finalise + +interface Print + module procedure IPModel_SW_Print +end interface Print + +interface Calc + module procedure IPModel_SW_Calc +end interface Calc + +contains + +subroutine IPModel_SW_Initialise_str(this, args_str, param_str) + type(IPModel_SW), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Initialise_str args_str')) then + call system_abort("IPModel_SW_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_SW_read_params_xml(this, param_str) + +end subroutine IPModel_SW_Initialise_str + +subroutine IPModel_SW_Finalise(this) + type(IPModel_SW), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%a)) deallocate(this%a) + if (allocated(this%AA)) deallocate(this%AA) + if (allocated(this%BB)) deallocate(this%BB) + if (allocated(this%p)) deallocate(this%p) + if (allocated(this%q)) deallocate(this%q) + if (allocated(this%sigma)) deallocate(this%sigma) + if (allocated(this%eps2)) deallocate(this%eps2) + if (allocated(this%lambda)) deallocate(this%lambda) + if (allocated(this%gamma)) deallocate(this%gamma) + if (allocated(this%eps3)) deallocate(this%eps3) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_SW_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator. It computes energy, forces and virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_SW_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_SW), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), pointer :: w_e(:) + integer i, ji, j, ki, k + real(dp) :: drij(3), drij_mag, drik(3), drik_mag, drij_dot_drik + real(dp) :: w_f + + integer ti, tj, tk + + real(dp) :: drij_dri(3), drij_drj(3), drik_dri(3), drik_drk(3) + real(dp) :: dcos_ijk_dri(3), dcos_ijk_drj(3), dcos_ijk_drk(3) + real(dp) :: virial_i(3,3), virial_j(3,3), virial_k(3,3) + + real(dp) :: de, de_dr, de_drij, de_drik, de_dcos_ijk + real(dp) :: cur_cutoff + + integer :: n_neigh_i + + type(Dictionary) :: params + logical :: has_atom_mask_name, atom_mask_exclude_all + character(STRING_LENGTH) :: atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + +#ifdef _OPENMP + real(dp) :: private_virial(3,3), private_e + real(dp), allocatable :: private_f(:,:), private_local_e(:), private_local_virial(:,:) +#endif + + INIT_ERROR(error) + + call print("IPModel_SW_Calc starting ", PRINT_ANALYSIS) + if (present(e)) e = 0.0_dp + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_SW_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_SW_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) virial = 0.0_dp + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_SW_Calc', error) + local_virial = 0.0_dp + endif + + atom_mask_pointer => null() + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of logical property used to mask atoms") + call param_register(params, 'atom_mask_exclude_all', 'F', atom_mask_exclude_all, help_string="If true, exclude contributions made by atoms with atom_mask==.false. on their neighbour with atom_mask==.true., i.e. behave as if excluded atoms were not there at all") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Calc args_str')) then + RAISE_ERROR("IPModel_SW_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_SW_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + else + atom_mask_pointer => null() + endif + else + do_rescale_r = .false. + do_rescale_E = .false. + endif + + if (do_rescale_r) call print('IPModel_SW_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) + if (do_rescale_E) call print('IPModel_SW_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) + + if (.not.assign_pointer(at,"weight", w_e)) nullify(w_e) + +#ifdef _OPENMP +!$omp parallel private(i, ji, j, ki, k, drij, drij_mag, drik, drik_mag, drij_dot_drik, w_f, ti, tj, tk, drij_dri, drij_drj, drik_dri, drik_drk, dcos_ijk_dri, dcos_ijk_drj, dcos_ijk_drk, de, de_dr, de_drij, de_drik, de_dcos_ijk, cur_cutoff, private_virial, private_e, private_f, private_local_e, private_local_virial, n_neigh_i, virial_i, virial_j, virial_k) + + if (present(e)) private_e = 0.0_dp + if (present(local_e)) then + allocate(private_local_e(at%N)) + private_local_e = 0.0_dp + endif + if (present(f)) then + allocate(private_f(3,at%N)) + private_f = 0.0_dp + endif + if (present(virial)) private_virial = 0.0_dp + if (present(local_virial)) then + allocate(private_local_virial(9,at%N)) + private_local_virial = 0.0_dp + endif + +!$omp do +#endif + do i=1, at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_Calc i " // i // " " // n_neighbours(at,i), PRINT_ANALYSIS) + cur_cutoff = maxval(this%a(ti,:)*this%sigma(ti,:)) + n_neigh_i = n_neighbours(at, i) + do ji=1, n_neigh_i + + if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then + if(.not. atom_mask_pointer(j)) cycle + endif + + j = neighbour(at, i, ji, drij_mag, cosines = drij, max_dist = cur_cutoff) + if (j <= 0) cycle + if (drij_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) drij_mag = drij_mag*r_scale + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (drij_mag/this%sigma(ti,tj) > this%a(ti,tj)) cycle + + if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_Calc i j " // i // " " // j, PRINT_ANALYSIS) + + if (associated(w_e)) then + w_f = 0.5_dp*(w_e(i)+w_e(j)) + else + w_f = 1.0_dp + endif + + if (present(e) .or. present(local_e)) then + ! factor of 0.5 because SW definition goes over each pair only once + de = 0.5_dp*this%eps2(ti,tj)*f2(this, drij_mag, ti, tj) + if (present(local_e)) then +#ifdef _OPENMP + private_local_e(i) = private_local_e(i) + de +#else + local_e(i) = local_e(i) + de +#endif + endif + if (present(e)) then +#ifdef _OPENMP + private_e = private_e + de*w_f +#else + e = e + de*w_f +#endif + endif + endif + + if (present(f) .or. present(virial) .or. present(local_virial)) then + de_dr = 0.5_dp*this%eps2(ti,tj)*df2_dr(this, drij_mag, ti, tj) + if (present(f)) then +#ifdef _OPENMP + private_f(:,i) = private_f(:,i) + de_dr*w_f*drij + private_f(:,j) = private_f(:,j) - de_dr*w_f*drij +#else + f(:,i) = f(:,i) + de_dr*w_f*drij + f(:,j) = f(:,j) - de_dr*w_f*drij +#endif + endif + + if(present(virial) .or. present(local_virial)) virial_i = de_dr*w_f*(drij .outer. drij)*drij_mag + + if (present(virial)) then +#ifdef _OPENMP + private_virial = private_virial - virial_i +#else + virial = virial - virial_i +#endif + endif + if (present(local_virial)) then +#ifdef _OPENMP + private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i, (/9/)) +#else + local_virial(:,i) = local_virial(:,i) - reshape(virial_i, (/9/)) +#endif + endif + + endif + + if (associated(w_e)) then + w_f = w_e(i) + else + w_f = 1.0_dp + endif + + do ki=1, n_neigh_i + if (ki <= ji) cycle + k = neighbour(at, i, ki, drik_mag, cosines = drik, max_dist=cur_cutoff) + + if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then + if(.not. atom_mask_pointer(k)) cycle + endif + + if (k <= 0) cycle + if (drik_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) drik_mag = drik_mag*r_scale + + tk = get_type(this%type_of_atomic_num, at%Z(k)) + + if (drik_mag/this%sigma(ti,tk) > this%a(ti,tk)) cycle + + drij_dot_drik = sum(drij*drik) + if (present(e) .or. present(local_e)) then + de = this%eps3(ti,tj,tk)*f3(this, drij_mag, drik_mag, drij_dot_drik, ti, tj, tk) + if (present(local_e)) then +#ifdef _OPENMP + private_local_e(i) = private_local_e(i) + de +#else + local_e(i) = local_e(i) + de +#endif + endif + if (present(e)) then +#ifdef _OPENMP + private_e = private_e + de*w_f +#else + e = e + de*w_f +#endif + endif + endif + if (present(f) .or. present(virial) .or. present(local_virial)) then + call df3_dr(this, drij_mag, drik_mag, drij_dot_drik, ti, tj, tk, de_drij, de_drik, de_dcos_ijk) + drij_dri = drij + drij_drj = -drij + drik_dri = drik + drik_drk = -drik + +! dcos_ijk = drij_dot_drik +! (ri_x - rj_x)*(ri_x - rk_x) + (ri_y - rj_y)*(ri_y-rk_y) / (rij rik) +! +! d/dri +! +! ((rij rik)(rij_x + rik_x) - (rij . rik)(rij rik_x / rik + rik rij_x/rij)) / (rij rik)^2 +! +! rij rik ( rij_x + rik_x) - (rij.rik)(rij rik_x / rik + rik rij_x/rij) +! --------------------------------------------------------------------- +! rij^2 rik^2 +! +! rij_x + rik_x cos_ijk (rij rik_x / rik + rik rij_x /rij) +! ------------- - ------------------------------------------ +! rij rik rij rik +! +! rij_x + rik_x +! ------------- - cos_ijk (rik_x / rik^2 + rij_x / rij^2) +! rij rik +! +! +! rhatij_x/rik + rhatik_x/rij - cos_ijk(rhatik_x/rik + rhatij_x/rij) +! +! +! d/drj +! +! ((rij rik)(-rik_x) - (rij.rik)(rik (-rij_x)/rij)) / (rij rik)^2 +! +! -rik_x (rij.rik) ( rik rij_x/rij) +! ------- + --------------------------- +! rij rik rij^2 rik^2 +! +! -rhatik_x/rij + cos_ijk rhatij_x/rij +! +! d/drij +! +! (ri_x - rj_x)*(ri_x - rk_x) + (ri_y - rj_y)*(ri_y-rk_y) / (rij rik) +! +! (rij rik) rik_x - (rij . rik) (rij_x/rij rik) +! --------------------------------------------- +! (rij rik)^2 +! +! rik_x (rij.rik) rij_x +! ------ - --------------- +! rij rik rij^3 rik +! +! rhatik_x (rhatij . rhatik) rhatij_x +! -------- - ------------------------ +! rij rij +! +! rhatik_x cos_ijk * rhatij_x +! -------- - ------------------ +! rij rij + + dcos_ijk_dri = drij/drik_mag + drik/drij_mag - drij_dot_drik * (drik/drik_mag + drij/drij_mag) + dcos_ijk_drj = -drik/drij_mag + drij_dot_drik * drij/drij_mag + dcos_ijk_drk = -drij/drik_mag + drij_dot_drik * drik/drik_mag + + if (present(f)) then +#ifdef _OPENMP + private_f(:,i) = private_f(:,i) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_dri(:) + de_drik*drik_dri(:) + & + de_dcos_ijk * dcos_ijk_dri(:)) + private_f(:,j) = private_f(:,j) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_drj(:) + de_dcos_ijk*dcos_ijk_drj(:)) + private_f(:,k) = private_f(:,k) + w_f*this%eps3(ti,tj,tk)*(de_drik*drik_drk(:) + de_dcos_ijk*dcos_ijk_drk(:)) +#else + f(:,i) = f(:,i) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_dri(:) + de_drik*drik_dri(:) + & + de_dcos_ijk * dcos_ijk_dri(:)) + f(:,j) = f(:,j) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_drj(:) + de_dcos_ijk*dcos_ijk_drj(:)) + f(:,k) = f(:,k) + w_f*this%eps3(ti,tj,tk)*(de_drik*drik_drk(:) + de_dcos_ijk*dcos_ijk_drk(:)) +#endif + end if + + if( present(virial) .or. present(local_virial) ) then + virial_i = w_f*this%eps3(ti,tj,tk)*( & + de_drij*(drij .outer. drij)*drij_mag + de_drik*(drik .outer. drik)*drik_mag + & + de_dcos_ijk * ((drik .outer. drij) - drij_dot_drik * (drij .outer. drij)) + & + de_dcos_ijk * ((drij .outer. drik) - drij_dot_drik * (drik .outer. drik)) ) + + virial_j = w_f*this%eps3(ti,tj,tk)*( & + de_drij*(drij .outer. drij)*drij_mag + & + de_dcos_ijk * ((drik .outer. drij) - drij_dot_drik * (drij .outer. drij)) ) + + virial_k = w_f*this%eps3(ti,tj,tk)*( & + de_drik*(drik .outer. drik)*drik_mag + & + de_dcos_ijk * ((drij .outer. drik) - drij_dot_drik * (drik .outer. drik)) ) + endif + + if (present(virial)) then +#ifdef _OPENMP + private_virial = private_virial - virial_i +#else + virial = virial - virial_i +#endif + end if + if (present(local_virial)) then +#ifdef _OPENMP + !private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i,(/9/)) + private_local_virial(:,j) = private_local_virial(:,j) - reshape(virial_j,(/9/)) + private_local_virial(:,k) = private_local_virial(:,k) - reshape(virial_k,(/9/)) +#else + !local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) + local_virial(:,j) = local_virial(:,j) - reshape(virial_j,(/9/)) + local_virial(:,k) = local_virial(:,k) - reshape(virial_k,(/9/)) +#endif + end if + endif + + end do ! ki + + end do + end do + +#ifdef _OPENMP +!$omp critical + if (present(e)) e = e + private_e + if (present(f)) f = f + private_f + if (present(local_e)) local_e = local_e + private_local_e + if (present(virial)) virial = virial + private_virial + if (present(local_virial)) local_virial = local_virial + private_local_virial +!$omp end critical + + if(allocated(private_f)) deallocate(private_f) + if(allocated(private_local_e)) deallocate(private_local_e) + if(allocated(private_local_virial)) deallocate(private_local_virial) + +!$omp end parallel +#endif + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) call sum_in_place(mpi, f) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(local_virial)) call sum_in_place(mpi, local_virial) + endif + + if (do_rescale_r) then + if (present(f)) f = f*r_scale + end if + + if (do_rescale_E) then + if (present(e)) e = e*E_scale + if (present(local_e)) local_e = local_e*E_scale + if (present(f)) f = f*E_scale + if (present(virial)) virial=virial*E_scale + if (present(local_virial)) local_virial=local_virial*E_scale + end if + + atom_mask_pointer => null() + +end subroutine IPModel_SW_Calc + +function f3(this, rij_i, rik_i, cos_ijk, ti, tj, tk) + type(IPModel_SW), intent(in) :: this + real(dp), intent(in) :: rij_i, rik_i, cos_ijk + integer, intent(in) :: ti, tj, tk + real(dp) :: f3 + + real(dp) :: rij, rik + real(dp), parameter :: one_third = 1.0_dp/3.0_dp + + rij = rij_i/this%sigma(ti,tj) + rik = rik_i/this%sigma(ti,tk) + + if (rij >= this%a(ti,tj) .or. rik >= this%a(ti,tk)) then + f3 = 0.0_dp + return + endif + + f3 = this%lambda(ti,tj,tk)*exp( this%gamma(ti,tj,tk)/(rij-this%a(ti,tj)) + this%gamma(ti,tj,tk)/(rik-this%a(ti,tk)) )* & + (cos_ijk + one_third)**2 + +end function f3 + +subroutine df3_dr(this, rij_i, rik_i, cos_ijk, ti, tj, tk, de_drij, de_drik, de_dcos_ijk) + type(IPModel_SW), intent(in) :: this + real(dp), intent(in) :: rij_i, rik_i, cos_ijk + integer, intent(in) :: ti, tj, tk + real(dp), intent(out) :: de_drij, de_drik, de_dcos_ijk + + real(dp) :: rij, rik, r_scale_ij, r_scale_ik + real(dp) :: expf, cosf + + real(dp), parameter :: one_third = 1.0_dp/3.0_dp + + rij = rij_i/this%sigma(ti,tj) + rik = rik_i/this%sigma(ti,tk) + + if (rij >= this%a(ti,tj) .or. rik >= this%a(ti,tk)) then + de_drij = 0.0_dp + de_drik = 0.0_dp + de_dcos_ijk = 0.0_dp + return + endif + + r_scale_ij = 1.0_dp/this%sigma(ti,tj) + r_scale_ik = 1.0_dp/this%sigma(ti,tk) + + expf = this%lambda(ti,tj,tk)*exp(this%gamma(ti,tj,tk)/(rij - this%a(ti,tj)) + this%gamma(ti,tj,tk)/(rik - this%a(ti,tk))) + cosf = (cos_ijk + one_third) + + de_drij = -expf * this%gamma(ti,tj,tk)/(rij-this%a(ti,tj))**2 * cosf**2 * r_scale_ij + de_drik = -expf * this%gamma(ti,tj,tk)/(rik-this%a(ti,tk))**2 * cosf**2 * r_scale_ik + de_dcos_ijk = expf * 2.0_dp * cosf + +end subroutine df3_dr + + +function f2(this, ri, ti, tj) + type(IPModel_SW), intent(in) :: this + real(dp), intent(in) :: ri + integer, intent(in) :: ti, tj + real(dp) :: f2 + + real(dp) r + + r = ri/this%sigma(ti,tj) + + if (r >= this%a(ti,tj)) then + f2 = 0.0_dp + return + endif + + f2 = this%AA(ti,tj)*(this%BB(ti,tj) * r**(-this%p(ti,tj)) - r**(-this%q(ti,tj))) * exp(1.0_dp/(r-this%a(ti,tj))) + +end function f2 + +function df2_dr(this, ri, ti, tj) + type(IPModel_SW), intent(in) :: this + real(dp), intent(in) :: ri + integer, intent(in) :: ti, tj + real(dp) :: df2_dr + + real(dp) r, dr_dri + real(dp) :: expf, dexpf_dr, powf, dpowf_dr + + r = ri/this%sigma(ti,tj) + + if (r >= this%a(ti,tj)) then + df2_dr = 0.0_dp + return + endif + + dr_dri = 1.0_dp/this%sigma(ti,tj) + + expf = exp(1.0_dp/(r-this%a(ti,tj))) + dexpf_dr = -expf/(r-this%a(ti,tj))**2 + + powf = this%BB(ti,tj)*(r**(-this%p(ti,tj))) - r**(-this%q(ti,tj)) + dpowf_dr = -this%p(ti,tj)*this%BB(ti,tj)*(r**(-this%p(ti,tj)-1)) + this%q(ti,tj)*r**(-this%q(ti,tj)-1) + + df2_dr = this%AA(ti,tj)*(powf*dexpf_dr + dpowf_dr*expf)*dr_dri + +end function df2_dr + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for the input file. +!% First the general parameters and pair terms: +!%> +!%> +!%> +!%> p="0" q="0" a="5.0" sigma="1.0" eps="0.0" /> +!%> p="4" q="0" a="1.25" sigma="2.537884" eps="2.1672" /> +!%> p="4" q="0" a="1.80" sigma="2.0951" eps="2.1675" /> +!% Now the triplet terms: atnum_c is the center atom, neighbours j and k +!%> lambda="21.0" gamma="1.20" eps="2.1675" /> +!%> lambda="21.0" gamma="1.20" eps="2.1675" /> +!%> lambda="21.0" gamma="1.20" eps="2.1675" /> +!%> +!%> lambda="21.0" gamma="1.20" eps="2.1675" /> +!%> lambda="21.0" gamma="1.20" eps="2.1675" /> +!%> lambda="21.0" gamma="1.20" eps="2.1675" /> +!%> +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: value + integer ti, tj, tk, Zi, Zj, Zk + + if (name == 'SW_params') then ! new SW stanza + call print("startElement_handler SW_params", PRINT_NERD) + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered SW_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) then + call print("SW_params startElement_handler bailing because we already matched our label", PRINT_NERD) + return ! we already found an exact match for this label + end if + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + call print("SW_params startElement_handler found xml label '"//trim(value)//"'", PRINT_NERD) + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + call print("SW_params startElement_handler was passed in label '"//trim(parse_ip%label)//"'", PRINT_NERD) + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + call print("SW_params startElement_handler got label didn't match", PRINT_NERD) + parse_in_ip = .false. + endif + else ! no label passed in + call print("SW_params startElement_handler was not passed in a label", PRINT_NERD) + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call print("SW_params startElement_handler finalising old data, restarting to parse new section", PRINT_NERD) + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, "n_types", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find n_types") + read (value, *) parse_ip%n_types + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%a(parse_ip%n_types,parse_ip%n_types)) + parse_ip%a = 0.0_dp + allocate(parse_ip%AA(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%BB(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%p(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%q(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%sigma(parse_ip%n_types,parse_ip%n_types)) + parse_ip%sigma = 0.0_dp + allocate(parse_ip%eps2(parse_ip%n_types,parse_ip%n_types)) + + allocate(parse_ip%lambda(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%gamma(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%eps3(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "atnum_i", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_i") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_j") + read (value, *) Zj + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "AA", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find AA") + read (value, *) parse_ip%AA(ti,tj) + call QUIP_FoX_get_value(attributes, "BB", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find BB") + read (value, *) parse_ip%BB(ti,tj) + call QUIP_FoX_get_value(attributes, "p", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find p") + read (value, *) parse_ip%p(ti,tj) + call QUIP_FoX_get_value(attributes, "q", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find q") + read (value, *) parse_ip%q(ti,tj) + call QUIP_FoX_get_value(attributes, "a", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find a") + read (value, *) parse_ip%a(ti,tj) + call QUIP_FoX_get_value(attributes, "sigma", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find sigma") + read (value, *) parse_ip%sigma(ti,tj) + call QUIP_FoX_get_value(attributes, "eps", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find eps") + read (value, *) parse_ip%eps2(ti,tj) + + if (ti /= tj) then + parse_ip%AA(tj,ti) = parse_ip%AA(ti,tj) + parse_ip%BB(tj,ti) = parse_ip%BB(ti,tj) + parse_ip%p(tj,ti) = parse_ip%p(ti,tj) + parse_ip%q(tj,ti) = parse_ip%q(ti,tj) + parse_ip%a(tj,ti) = parse_ip%a(ti,tj) + parse_ip%sigma(tj,ti) = parse_ip%sigma(ti,tj) + parse_ip%eps2(tj,ti) = parse_ip%eps2(ti,tj) + endif + + parse_ip%cutoff = maxval(parse_ip%a*parse_ip%sigma) + + elseif (parse_in_ip .and. name == 'per_triplet_data') then + + call QUIP_FoX_get_value(attributes, "atnum_c", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_c") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_j") + read (value, *) Zj + call QUIP_FoX_get_value(attributes, "atnum_k", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_k") + read (value, *) Zk + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + tk = get_type(parse_ip%type_of_atomic_num,Zk) + + call QUIP_FoX_get_value(attributes, "lambda", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find lambda") + read (value, *) parse_ip%lambda(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "gamma", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find gamma") + read (value, *) parse_ip%gamma(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "eps", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find eps") + read (value, *) parse_ip%eps3(ti,tj,tk) + + if (tj /= tk) then + parse_ip%lambda(ti,tk,tj) = parse_ip%lambda(ti,tj,tk) + parse_ip%gamma(ti,tk,tj) = parse_ip%gamma(ti,tj,tk) + parse_ip%eps3(ti,tk,tj) = parse_ip%eps3(ti,tj,tk) + endif + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'SW_params') then + call print("endElement_handler SW_params", PRINT_NERD) + parse_in_ip = .false. + endif + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_SW_read_params_xml(this, param_str) + type(IPModel_SW), intent(inout), target :: this + character(len=*) :: param_str + + type (xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_ip => this + parse_in_ip = .false. + parse_matched_label = .false. + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_SW_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X printing +!% Printing of SW parameters: number of different types, cutoff radius, atomic numbers, ect. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +subroutine IPModel_SW_Print (this, file) + type(IPModel_SW), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer ti, tj, tk + + call Print("IPModel_SW : Stillinger-Weber", file=file) + call Print("IPModel_SW : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_SW : type "// ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + do tj=1, this%n_types + call Print ("IPModel_SW : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) // & + " " // this%atomic_num(tj), file=file) + call Print ("IPModel_SW : pair " // this%AA(ti,tj) // " " // this%BB(ti,tj) // " " // this%p(ti,tj) // " " // & + this%q(ti,tj) // " " // this%a(ti,tj), file=file) + call Print ("IPModel_SW : " // this%sigma(ti,tj) // " " // this%eps2(ti,tj), file=file) + do tk=1, this%n_types + call Print ("IPModel_SW : triplet interaction ti tj " // ti // " " // tj // " " // tk // & + " Zi Zj Zk " // this%atomic_num(ti) // " " // this%atomic_num(tj) // " " // this%atomic_num(tk), file=file) + call Print ("IPModel_SW : triplet " // this%lambda(ti,tj,tk) // " " // this%gamma(ti,tj,tk) // " " // & + this%eps3(ti,tj,tk), file=file) + end do + end do + call verbosity_pop() + end do + +end subroutine IPModel_SW_Print + +end module IPModel_SW_module diff --git a/src/Potentials/IPModel_SW_VP.F90 b/src/Potentials/IPModel_SW_VP.F90 new file mode 100644 index 0000000000..4939d772be --- /dev/null +++ b/src/Potentials/IPModel_SW_VP.F90 @@ -0,0 +1,1218 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_SW_VP module +!X +!% Danny potential J ChemPhys 127, 204704(2007) for SiO_2. +!% +!% Only the case of fourfold coordinated silcon and twofold coordinated +!% is considered. (-->Fixed charges). +!% +!% The IPModel_SW_VP object contains all the parameters read +!% from an 'SW_VP_params' XML stanza. +!X +!X Contribution from Anke Butenuth +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_SW_VP_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_NERD, PRINT_ANALYSIS, current_verbosity, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module +use Functions_module +implicit none + +private + +include 'IPModel_interface.h' + +public :: IPModel_SW_VP +type IPModel_SW_VP + integer :: n_types = 0 !% Number of atomic types + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} + + real(dp) :: cutoff = 0.0_dp + + + real(dp), allocatable :: a(:,:), AA(:,:), BB(:,:), p(:,:), q(:,:), sigma(:,:), eps2(:,:), C_0(:,:), C_1(:,:), b(:,:), D_SiO(:,:), C_OOprime(:,:), D_OOprime(:,:) !% IP parameters + real(dp), allocatable :: lambda(:,:,:), d1(:,:,:), d2(:,:,:), gamma1(:,:,:), gamma2(:,:,:), eps3(:,:,:), costheta0(:,:,:) !% IP parameters + + + character(len=STRING_LENGTH) :: label + +end type IPModel_SW_VP + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_SW_VP), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_SW_VP_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_SW_VP_Finalise +end interface Finalise + +interface Print + module procedure IPModel_SW_VP_Print +end interface Print + +interface Calc + module procedure IPModel_SW_VP_Calc +end interface Calc + +contains + +subroutine IPModel_SW_VP_Initialise_str(this, args_str, param_str) + type(IPModel_SW_VP), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy: nb326 $") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_VP_Initialise_str args_str')) then + call system_abort("IPModel_SW_VP_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_SW_VP_read_params_xml(this, param_str) + +end subroutine IPModel_SW_VP_Initialise_str + +subroutine IPModel_SW_VP_Finalise(this) + type(IPModel_SW_VP), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%a)) deallocate(this%a) + if (allocated(this%AA)) deallocate(this%AA) + if (allocated(this%BB)) deallocate(this%BB) + if (allocated(this%p)) deallocate(this%p) + if (allocated(this%q)) deallocate(this%q) + if (allocated(this%sigma)) deallocate(this%sigma) + if (allocated(this%eps2)) deallocate(this%eps2) + if (allocated(this%lambda)) deallocate(this%lambda) + if (allocated(this%gamma1)) deallocate(this%gamma1) + if (allocated(this%gamma2)) deallocate(this%gamma2) + if (allocated(this%eps3)) deallocate(this%eps3) + if (allocated(this%costheta0)) deallocate(this%costheta0) + if (allocated(this%d1)) deallocate(this%d1) + if (allocated(this%d2)) deallocate(this%d2) + if (allocated(this%C_0)) deallocate(this%C_0) + if (allocated(this%C_1)) deallocate(this%C_1) + if (allocated(this%b)) deallocate(this%b) + if (allocated(this%D_SiO)) deallocate(this%D_SiO) + if (allocated(this%C_OOprime)) deallocate(this%C_OOprime) + if (allocated(this%D_OOprime)) deallocate(this%D_OOprime) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_SW_VP_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator. It computes energy, forces and virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_SW_VP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_SW_VP), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), pointer :: w_e(:) + integer i, ji, j, ki, k + real(dp) :: drij(3), drij_mag, drik(3), drik_mag, drij_dot_drik + real(dp) :: w_f + + integer ti, tj, tk + + real(dp) :: drij_dri(3), drij_drj(3), drik_dri(3), drik_drk(3) + real(dp) :: dcos_ijk_dri(3), dcos_ijk_drj(3), dcos_ijk_drk(3) + real(dp) :: virial_i(3,3) + + real(dp) :: de, de_dr, de_drij, de_drik, de_dcos_ijk + real(dp) :: cur_cutoff + + + integer :: n_neigh_i + + type(Dictionary) :: params + logical :: has_atom_mask_name, atom_mask_exclude_all + character(STRING_LENGTH) :: atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + +#ifdef _OPENMP + real(dp) :: private_virial(3,3), private_e + real(dp), allocatable :: private_f(:,:), private_local_e(:), private_local_virial(:,:) +#endif + + INIT_ERROR(error) + + call print("IPModel_SW_VP_Calc starting ", PRINT_ANALYSIS) + if (present(e)) e = 0.0_dp + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_SW_VP_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_SW_VP_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) virial = 0.0_dp + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_GAP_Calc', error) + local_virial = 0.0_dp + endif + + atom_mask_pointer => null() + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of logical property used to mask atoms") + call param_register(params, 'atom_mask_exclude_all', 'F', atom_mask_exclude_all, help_string="If true, exclude contributions made by atoms with atom_mask==.false. on their neighbour with atom_mask==.true., i.e. behave as if excluded atoms were not there at all") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_VP_Calc args_str')) then + RAISE_ERROR("IPModel_SW_VP_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_SW_VP_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + else + atom_mask_pointer => null() + endif + endif + + if (.not.assign_pointer(at,"weight", w_e)) nullify(w_e) + +#ifdef _OPENMP + !$omp parallel default(none) private(i, ji, j, ki, k, drij, drij_mag, drik, drik_mag, drij_dot_drik, w_f, ti, tj, tk, drij_dri, drij_drj, drik_dri, drik_drk, dcos_ijk_dri, dcos_ijk_drj, dcos_ijk_drk, de, de_dr, de_drij, de_drik, de_dcos_ijk, cur_cutoff, private_virial, private_e, private_f, private_local_e, private_local_virial, n_neigh_i, virial_i) shared(this,at,e,local_e,f,virial,local_virial,mpi,atom_mask_pointer,atom_mask_exclude_all,w_e) + + if (present(e)) private_e = 0.0_dp + if (present(local_e)) then + allocate(private_local_e(at%N)) + private_local_e = 0.0_dp + endif + if (present(f)) then + allocate(private_f(3,at%N)) + private_f = 0.0_dp + endif + if (present(virial)) private_virial = 0.0_dp + if (present(local_virial)) then + allocate(private_local_virial(9,at%N)) + private_local_virial = 0.0_dp + endif + +!$omp do +#endif + do i=1, at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_VP_Calc i " // i // " " // n_neighbours(at,i), PRINT_ANALYSIS) + cur_cutoff = maxval(this%a(ti,:)*this%sigma(ti,:)) + n_neigh_i = n_neighbours(at, i) + + + do ji=1, n_neigh_i + j = neighbour(at, i, ji, drij_mag, cosines = drij, max_dist = cur_cutoff) + + if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then + if(.not. atom_mask_pointer(j)) cycle + endif + + if (j <= 0) cycle + if (drij_mag .feq. 0.0_dp) cycle + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (drij_mag/this%sigma(ti,tj) > this%a(ti,tj)) cycle + + + if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_VP_Calc i j " // i // " " // j, PRINT_ANALYSIS) + + if (associated(w_e)) then + w_f = 0.5_dp*(w_e(i)+w_e(j)) ! + else + w_f = 1.0_dp + endif + + if (present(e) .or. present(local_e)) then + ! factor of 0.5 because SW_VP definition goes over each pair only once + + ! select functional form of pair potentials depending on species : oxygen -oxygen + if ((ti .eq. 2) .and. (tj .eq. 2)) then ! + de = 0.5_dp*this%eps2(ti,tj)*f2OO(this, drij_mag, ti, tj) + + elseif ((ti .eq. 2) .and. (tj .eq. 3)) then ! Oxygen Silicon + de = 0.5_dp*this%eps2(ti,tj)*f2SiO(this, drij_mag, ti, tj) + + + elseif ((ti .eq. 3) .and. (tj .eq.2 )) then ! Calls the Silicon-Oxygen function again + de = 0.5_dp*this%eps2(ti,tj)*f2SiO(this, drij_mag, ti, tj) + + elseif ((ti .eq. 3) .and. (tj .eq. 3)) then ! Silicon -Silicon + de = 0.5_dp*this%eps2(ti,tj)*f2SiSi(this, drij_mag, ti, tj) + + else + de= 0.0_dp + endif + + + + if (present(local_e)) then +#ifdef _OPENMP + private_local_e(i) = private_local_e(i) + de +#else + local_e(i) = local_e(i) + de +#endif + endif + if (present(e)) then +#ifdef _OPENMP + private_e = private_e + de*w_f +#else + e = e + de*w_f +#endif + endif + endif + + if (present(f) .or. present(virial) .or. present(local_virial)) then + + + !select pair potentials depending on species : oxygen-oxygen + if ((ti .eq. 2) .and. (tj .eq. 2)) then + de_dr = 0.5_dp*this%eps2(ti,tj)*df2OO_dr(this, drij_mag, ti, tj) + + elseif ((ti .eq. 3) .and. (tj .eq. 2)) then ! oxygen-silicon + de_dr = 0.5_dp*this%eps2(ti,tj)* df2SiO_dr(this, drij_mag, ti, tj) + + elseif ((ti.eq. 2) .and. (tj .eq. 3 )) then ! Calls the silicon-oxygen function again + de_dr = 0.5_dp*this%eps2(ti,tj)* df2SiO_dr(this, drij_mag, ti, tj) + + elseif ((ti .eq. 3 ) .and. (tj .eq. 3)) then ! silicon-silicon + de_dr = 0.5_dp*this%eps2(ti,tj)*df2SiSi_dr(this, drij_mag, ti, tj) + else + de_dr = 0.0_dp + endif + + + + + if (present(f)) then +#ifdef _OPENMP + private_f(:,i) = private_f(:,i) + de_dr*w_f*drij + private_f(:,j) = private_f(:,j) - de_dr*w_f*drij +#else + f(:,i) = f(:,i) + de_dr*w_f*drij + f(:,j) = f(:,j) - de_dr*w_f*drij +#endif + endif + + if(present(virial) .or. present(local_virial)) virial_i = de_dr*w_f*(drij .outer. drij)*drij_mag + + + + if (present(virial)) then +#ifdef _OPENMP + private_virial = private_virial - virial_i +#else + virial = virial - virial_i +#endif + endif + if (present(local_virial)) then +#ifdef _OPENMP + private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i, (/9/)) +#else + local_virial(:,i) = local_virial(:,i) - reshape(virial_i, (/9/)) +#endif + endif + + endif + + if (associated(w_e)) then + w_f = w_e(i) + else + w_f = 1.0_dp + endif + enddo ! closes j loop + enddo ! closes i loop + + ! New loop for three body terms, because (see parameters/ip.params.SW_VP.xml) cutoff for three body terms is in SiSiO case larger then the SiSi cutoff + + !$omp do + do i=1, at%N + + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) ! + + + ! if (current_verbosity() >= PRINT_ANALYSIS) call print ("IPModel_SW_VP_Calc i " // i // " " // n_neighbours(at,i), PRINT_ANALYSIS) + cur_cutoff = maxval(this%a(ti,:)*this%sigma(ti,:)) + n_neigh_i = n_neighbours(at, i) + + + do ji=1, n_neigh_i + j = neighbour(at, i, ji, drij_mag, cosines = drij, max_dist = cur_cutoff) + + if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then + if(.not. atom_mask_pointer(j)) cycle + endif + + if (j <= 0) cycle + if (drij_mag .feq. 0.0_dp) cycle + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + + + do ki=1, n_neigh_i + + if (ki <= ji) cycle + + k = neighbour(at, i, ki, drik_mag, cosines = drik, max_dist=cur_cutoff) + + if(associated(atom_mask_pointer) .and. atom_mask_exclude_all) then + if(.not. atom_mask_pointer(k)) cycle + endif + + if (k <= 0) cycle + if (drik_mag .feq. 0.0_dp) cycle + + tk = get_type(this%type_of_atomic_num, at%Z(k)) + if (drik_mag > this%d2(ti, tj, tk)) cycle + if (drij_mag > this%d1(ti, tj, tk)) cycle + + drij_dot_drik = sum(drij*drik) + if (present(e) .or. present(local_e)) then + de = this%eps3(ti,tj,tk)*f3(this, drij_mag, drik_mag, drij_dot_drik, ti, tj, tk) + + + if (present(local_e)) then +#ifdef _OPENMP + private_local_e(i) = private_local_e(i) + de +#else + local_e(i) = local_e(i) + de +#endif + endif + if (present(e)) then +#ifdef _OPENMP + private_e = private_e + de*w_f +#else + e = e + de*w_f +#endif + endif + endif + if (present(f) .or. present(virial)) then + call df3_dr(this, drij_mag, drik_mag, drij_dot_drik, ti, tj, tk, de_drij, de_drik, de_dcos_ijk) + drij_dri = drij + drij_drj = -drij !grad.|vec(r_i) -vec(r_j)|= -( vec(r_i) -vec(r_j))/|vec(r_i) -vec(r_j)| = -drij + drik_dri = drik + drik_drk = -drik + +! dcos_ijk = drij_dot_drik +! (ri_x - rj_x)*(ri_x - rk_x) + (ri_y - rj_y)*(ri_y-rk_y) / (rij rik) +! +! d/dri +! +! ((rij rik)(rij_x + rik_x) - (rij . rik)(rij rik_x / rik + rik rij_x/rij)) / (rij rik)^2 +! +! rij rik ( rij_x + rik_x) - (rij.rik)(rij rik_x / rik + rik rij_x/rij) +! --------------------------------------------------------------------- +! rij^2 rik^2 +! +! rij_x + rik_x cos_ijk (rij rik_x / rik + rik rij_x /rij) +! ------------- - ------------------------------------------ +! rij rik rij rik +! +! rij_x + rik_x +! ------------- - cos_ijk (rik_x / rik^2 + rij_x / rij^2) +! rij rik +! +! +! rhatij_x/rik + rhatik_x/rij - cos_ijk(rhatik_x/rik + rhatij_x/rij) +! +! +! d/drj +! +! ((rij rik)(-rik_x) - (rij.rik)(rik (-rij_x)/rij)) / (rij rik)^2 +! +! -rik_x (rij.rik) ( rik rij_x/rij) +! ------- + --------------------------- +! rij rik rij^2 rik^2 +! +! -rhatik_x/rij + cos_ijk rhatij_x/rij +! +! d/drij +! +! (ri_x - rj_x)*(ri_x - rk_x) + (ri_y - rj_y)*(ri_y-rk_y) / (rij rik) +! +! (rij rik) rik_x - (rij . rik) (rij_x/rij rik) +! --------------------------------------------- +! (rij rik)^2 +! +! rik_x (rij.rik) rij_x +! ------ - --------------- +! rij rik rij^3 rik +! +! rhatik_x (rhatij . rhatik) rhatij_x +! -------- - ------------------------ +! rij rij +! +! rhatik_x cos_ijk * rhatij_x +! -------- - ------------------ +! rij rij + + dcos_ijk_dri = drij/drik_mag + drik/drij_mag - drij_dot_drik * (drik/drik_mag + drij/drij_mag) + dcos_ijk_drj = -drik/drij_mag + drij_dot_drik * drij/drij_mag + dcos_ijk_drk = -drij/drik_mag + drij_dot_drik * drik/drik_mag + + + + + if (present(f)) then +#ifdef _OPENMP + private_f(:,i) = private_f(:,i) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_dri(:) + de_drik*drik_dri(:) + & + de_dcos_ijk * dcos_ijk_dri(:)) + private_f(:,j) = private_f(:,j) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_drj(:) + de_dcos_ijk*dcos_ijk_drj(:)) + private_f(:,k) = private_f(:,k) + w_f*this%eps3(ti,tj,tk)*(de_drik*drik_drk(:) + de_dcos_ijk*dcos_ijk_drk(:)) +#else + f(:,i) = f(:,i) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_dri(:) + de_drik*drik_dri(:) + & + de_dcos_ijk * dcos_ijk_dri(:)) + f(:,j) = f(:,j) + w_f*this%eps3(ti,tj,tk)*(de_drij*drij_drj(:) + de_dcos_ijk*dcos_ijk_drj(:)) + f(:,k) = f(:,k) + w_f*this%eps3(ti,tj,tk)*(de_drik*drik_drk(:) + de_dcos_ijk*dcos_ijk_drk(:)) +#endif + end if + + if( present(virial) .or. present(local_virial) ) virial_i = & + w_f*this%eps3(ti,tj,tk)*( & + de_drij*(drij .outer. drij)*drij_mag + de_drik*(drik .outer. drik)*drik_mag + & + de_dcos_ijk * ((drik .outer. drij) - drij_dot_drik * (drij .outer. drij)) + & + de_dcos_ijk * ((drij .outer. drik) - drij_dot_drik * (drik .outer. drik)) ) + + if (present(virial)) then +#ifdef _OPENMP + private_virial = private_virial - virial_i +#else + virial = virial - virial_i +#endif + end if + if (present(local_virial)) then +#ifdef _OPENMP + private_local_virial(:,i) = private_local_virial(:,i) - reshape(virial_i,(/9/)) +#else + local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) +#endif + end if + endif + + end do + + end do + end do + +#ifdef _OPENMP +!$omp critical + if (present(e)) e = e + private_e + if (present(f)) f = f + private_f + if (present(local_e)) local_e = local_e + private_local_e + if (present(virial)) virial = virial + private_virial + if (present(local_virial)) local_virial = local_virial + private_local_virial +!$omp end critical + + if(allocated(private_f)) deallocate(private_f) + if(allocated(private_local_e)) deallocate(private_local_e) + if(allocated(private_local_virial)) deallocate(private_local_virial) + +!$omp end parallel +#endif + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) call sum_in_place(mpi, f) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(local_virial)) call sum_in_place(mpi, local_virial) + endif + +end subroutine IPModel_SW_VP_Calc + + + + +function f3(this, rij_i, rik_i, cos_ijk, ti, tj, tk) + type(IPModel_SW_VP), intent(in) :: this + real(dp), intent(in) :: rij_i, rik_i, cos_ijk + integer, intent(in) :: ti, tj, tk + real(dp) :: f3 + + real(dp) :: rij, rik + !We give all cosines as parameters from xml file + + rij = rij_i + rik = rik_i + + if (rij_i >= this%d1(ti,tj,tk) .or. rik_i >= this%d2(ti,tj,tk)) then + f3 = 0.0_dp + return + endif + + f3 = this%lambda(ti,tj,tk)*exp( this%gamma1(ti,tj,tk)/(rij-this%d1(ti,tj,tk)) + this%gamma2(ti,tj,tk)/(rik-this%d2(ti,tj,tk)) )* & + (cos_ijk - this%costheta0(ti,tj,tk))**2 + + + +end function f3 + +subroutine df3_dr(this, rij_i, rik_i, cos_ijk, ti, tj, tk, de_drij, de_drik, de_dcos_ijk) + type(IPModel_SW_VP), intent(in) :: this + real(dp), intent(in) :: rij_i, rik_i, cos_ijk + integer, intent(in) :: ti, tj, tk + real(dp), intent(out) :: de_drij, de_drik, de_dcos_ijk + + real(dp) :: rij, rik + real(dp) :: expf, cosf + + + rij = rij_i + rik = rik_i + + if (rij_i >= this%d1(ti,tj,tk) .or. rik_i >= this%d2(ti,tj,tk)) then ! Anke_new + de_drij = 0.0_dp + de_drik = 0.0_dp + de_dcos_ijk = 0.0_dp + return + endif + + + expf = this%lambda(ti,tj,tk)*exp(this%gamma1(ti,tj,tk)/(rij - this%d1(ti,tj,tk)) + this%gamma2(ti,tj,tk)/(rik - this%d2(ti,tj,tk))) + cosf = (cos_ijk -this%costheta0(ti,tj,tk)) + + de_drij = -expf * this%gamma1(ti,tj,tk)/(rij-this%d1(ti,tj,tk))**2 * cosf**2 + de_drik = -expf * this%gamma2(ti,tj,tk)/(rik-this%d2(ti,tj,tk))**2 * cosf**2 + de_dcos_ijk = expf * 2.0_dp * cosf + + + + + +end subroutine df3_dr + + + + +!************Begin: Anke modification********** + + + + +function f2SiSi(this, ri, ti, tj) + type(IPModel_SW_VP), intent(in) :: this + real(dp), intent(in) :: ri + integer, intent(in) :: ti, tj + + real(dp) :: f2SiSi + + +! if (ri >= this%a(ti,tj)) then +! f2SiSi = 0.0_dp +! return +! endif + +! f2SiSi = this%AA(ti,tj)*(1.0_dp+3.2_dp*qi*qj)*faqj*faqi*(this%BB(ti,tj) * r**(-this%p(ti,tj)) - r**(-this%q(ti,tj))) * exp(1.0_dp/(r-this%a(ti,tj))) +! for now, fixed coordination. If Si is fourfold coordinated, in Si0_2 is faq(Si) = 0. +! +! Potential has to be modified if one wants Si-Si interactions as well + + f2SiSi = 0.0_dp + +end function f2SiSi + +function df2SiSi_dr(this, ri, ti, tj) + type(IPModel_SW_VP), intent(in) :: this + real(dp), intent(in) :: ri + integer, intent(in) :: ti, tj + real(dp) :: df2SiSi_dr + + real(dp) :: expf, dexpf_dr, powf, dpowf_dr + + + ! if (r >= this%a(ti,tj)) then + ! df2SiSi_dr = 0.0_dp + + ! return + ! endif + + + ! expf = exp(this%sigma(ti,tj)/(r-this%a(ti,tj))) + ! dexpf_dr = -expf*this%sigma(ti,tj)/(r-this%a(ti,tj))**2 + + ! powf = this%BB(ti,tj)*(r**(-this%p(ti,tj))) - r**(-this%q(ti,tj)) + ! dpowf_dr = -this%p(ti,tj)*this%BB(ti,tj)*(r**(-this%p(ti,tj)-1)) + this%q(ti,tj)*r**(-this%q(ti,tj)-1) + + df2SiSi_dr = 0.0_dp + +end function df2SiSi_dr + + +function f2SiO(this, r, ti, tj) + type(IPModel_SW_VP), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: f2SiO + + real(dp) :: expf + real(dp) :: f2SiO_at_cutoff, df2SiO_dr_at_cutoff + +! Cutoff sigma*a for longrange non-coulombic terms + + if (r >= (this%sigma(ti,tj)*this%a(ti,tj))) then + f2SiO = 0.0_dp + return + endif + + + + expf = exp(-r/this%a(ti,tj)) + f2SiO_at_cutoff = (this%C_0(ti,tj)-this%C_1(ti,tj)*1.6_dp)*(this%sigma(ti,tj)*this%a(ti,tj))**(-9.0_dp)-this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj))**(-4.0_dp)*exp(-this%sigma(ti,tj)) + df2SiO_dr_at_cutoff= -9.0_dp*(this%C_0(ti, tj)-this%C_1(ti,tj)*1.6_dp)*(this%sigma(ti,tj)*this%a(ti,tj)) **(-10.0_dp) & + + 4.0_dp*this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj)) **(-5.0_dp)* exp(-this%sigma(ti,tj)) & + + this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-4.0_dp)*exp(-this%sigma(ti,tj))/this%a(ti,tj) + + + + f2SiO = (this%C_0(ti,tj)-this%C_1(ti,tj)*1.6_dp)*r**(-9.0_dp) - this%D_SiO(ti,tj)*r**(-4.0_dp)*expf - f2SiO_at_cutoff - (r - this%sigma(ti,tj)*this%a(ti,tj))*df2SiO_dr_at_cutoff + + + +end function f2SiO + + + +function df2SiO_dr(this, r, ti, tj) + type(IPModel_SW_VP), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: df2SiO_dr + real(dp) :: expf + real(dp) :: df2SiO_dr_at_cutoff + + if (r >= (this%sigma(ti,tj)*this%a(ti,tj))) then + df2SiO_dr = 0.0_dp + return + endif + + + + expf = exp(-r/this%a(ti,tj)) + df2SiO_dr_at_cutoff= -9.0_dp*(this%C_0(ti, tj)-this%C_1(ti,tj)*1.6_dp)*(this%sigma(ti,tj)*this%a(ti,tj)) **(-10.0_dp) & + + 4.0_dp*this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj)) **(-5.0_dp)* exp(-this%sigma(ti,tj)) & + + this%D_SiO(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-4.0_dp)*exp(-this%sigma(ti,tj))/this%a(ti,tj) + + + df2SiO_dr = -9.0_dp*(this%C_0(ti, tj)-this%C_1(ti,tj)*1.6_dp)*r**(-10.0_dp) + 4.0_dp*this%D_SiO(ti,tj)*r**(-5.0_dp)*expf + this%D_SiO(ti,tj)*r**(-4.0_dp)*expf/this%a(ti,tj) - df2SiO_dr_at_cutoff + + + +end function df2SiO_dr + + +function f2OO(this, r, ti, tj) + type(IPModel_SW_VP), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: f2OO + real(dp) :: expf + real(dp) :: f2OO_at_cutoff, df2OO_dr_at_cutoff + + if (r >= (this%sigma(ti,tj)*this%a(ti,tj))) then + f2OO = 0.0_dp + return + endif + + + expf = exp(-r/this%a(ti,tj)) + f2OO_at_cutoff= (this%C_OOprime(ti, tj))*(this%sigma(ti,tj)*this%a(ti,tj))**(-7.0_dp) - this%D_OOprime(ti, tj)*(this%sigma(ti,tj)*this%a(ti,tj))**(-4.0_dp)*exp(-this%sigma(ti,tj)) + ! Cutoff is at r = sigma*a, thus can be altered via parameter list + df2OO_dr_at_cutoff= -7.0_dp*(this%C_OOprime(ti,tj))*(this%sigma(ti,tj)*this%a(ti,tj) )**(-8.0_dp) + 4.0_dp*this%D_OOprime(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-5.0_dp)* exp(-this%sigma(ti,tj)) & + + this%D_OOprime(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-4.0_dp)*exp(-this%sigma(ti,tj))/this%a(ti,tj) + + f2OO = (this%C_OOprime(ti, tj))*r**(-7.0_dp) - this%D_OOprime(ti, tj)*r**(-4.0_dp)*expf - f2OO_at_cutoff & + - (r - this%sigma(ti,tj)*this%a(ti,tj))*df2OO_dr_at_cutoff + + +end function f2OO + + +function df2OO_dr(this, r, ti, tj) + type(IPModel_SW_VP), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: df2OO_dr, df2OO_dr_at_cutoff + + real(dp) :: expf + + if (r >= (this%sigma(ti,tj)*this%a(ti,tj))) then + df2OO_dr = 0.0_dp + return + endif + + + expf = exp(-r/this%a(ti,tj)) + + df2OO_dr_at_cutoff = -7.0_dp*(this%C_OOprime(ti,tj))*(this%sigma(ti,tj)*this%a(ti,tj) )**(-8.0_dp) + 4.0_dp*this%D_OOprime(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-5.0_dp)* exp(-this%sigma(ti,tj)) & + + this%D_OOprime(ti,tj)*(this%sigma(ti,tj)*this%a(ti,tj) )**(-4.0_dp)*exp(-this%sigma(ti,tj))/this%a(ti,tj) + + df2OO_dr = -7.0_dp*(this%C_OOprime(ti,tj))*r**(-8.0_dp) + 4.0_dp*this%D_OOprime(ti,tj)*r**(-5.0_dp)*expf + this%D_OOprime(ti,tj)*r**(-4.0_dp)*expf/this%a(ti,tj)- df2OO_dr_at_cutoff + + + +end function df2OO_dr + + + + +!*************End: Anke modification********** + + + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for the input file. +!% +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> +!%> Danny potential J ChemPhys 127, 204704(2007).The potential has to be called as a pot_init_args='Sum init_args_pot1={IP SW_VP} init_args_pot2={IP Coulomb}' +!%> +!%> +!%> +!%> p="0" q="0" a="1.0" sigma="1.0" eps="0.0" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="0" D_OOprime="0" /> +!%> p="0" q="0" a="1.0" sigma="1.0" eps="0.0" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="0" D_OOprime="0" /> +!%> p="4" q="0" a="1.25" sigma="2.537884" eps="0.000" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="0" D_OOprime="0"/> +!%> p="0" q="0" a="4.43" sigma="1.24" eps="14.39" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="51.692" D_OOprime="1.536"/> +!%> p="0" q="0" a="4.43" sigma="1.24" eps="14.39" C_0="14.871" C_1="2.178" D_SiO="3.072" C_OOprime="0.0" D_OOprime="0.0"/> +!%> p="4" q="0" a="1.80" sigma="2.0951" eps="0" C_0="0.0" C_1="0.0" D_SiO="0" C_OOprime="0.0" D_OOprime="0.0"/> +!%> +!%> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="3.46" gamma1="0.48" gamma2="0.48" d1="1.24" d2="1.24" costheta0="-0.5373" eps="0.0" /> +!%> lambda="3.46" gamma1="0.48" gamma2="0.48" d1="1.24" d2="1.24" costheta0="-0.5373" eps="0.0" /> +!%> lambda="0.521" gamma1="1" gamma2="1" d1="2.6" d2="2.6" costheta0="-0.5373" eps="14.39" /> +!%> lambda="3.46" gamma1="0.48" gamma2="0.48" d1="1.24" d2="1.24" costheta0="-0.5373" eps="0.0" /> +!%> lambda="3.46" gamma1="0.48" gamma2="0.48" d1="1.24" d2="1.24" costheta0="-0.5373" eps="0.0" /> +!%> lambda="1.4" gamma1="1" gamma2="1" d1="2.6" d2="2.6" costheta0="-0.777" eps="14.39" /> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="21.0" gamma1="1.20" gamma2="1.20" d1="1.80" d2="1.80" costheta0="-0.333" eps="0.0" /> +!%> lambda="0.350" gamma1="1" gamma2="1" d1="2.6" d2="2.6" costheta0="-0.333" eps="14.39" /> +!%> +!%> lambda="3.164" gamma1="4.06" gamma2="0.52" d1="3.981" d2="2.933" costheta0="-0.333" eps="14.39" /> +!%> lambda="3.164" gamma1="2.51" gamma2="2.51" d1="3.771" d2="3.771" costheta0="-0.333" eps="14.39" /> +!%> +!%> +!%> +!%> +!%> +!%> +!% +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: value + integer ti, tj, tk, Zi, Zj, Zk + + if (name == 'SW_VP_params') then ! new SW_VP stanza + call print("startElement_handler SW_VP_params", PRINT_NERD) + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered SW_VP_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) then + call print("SW_VP_params startElement_handler bailing because we already matched our label", PRINT_NERD) + return ! we already found an exact match for this label + end if + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + call print("SW_VP_params startElement_handler found xml label '"//trim(value)//"'", PRINT_NERD) + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + call print("SW_VP_params startElement_handler was passed in label '"//trim(parse_ip%label)//"'", PRINT_NERD) + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + call print("SW_VP_params startElement_handler got label didn't match", PRINT_NERD) + parse_in_ip = .false. + endif + else ! no label passed in + call print("SW_VP_params startElement_handler was not passed in a label", PRINT_NERD) + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call print("SW_VP_params startElement_handler finalising old data, restarting to parse new section", PRINT_NERD) + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, "n_types", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find n_types") + read (value, *) parse_ip%n_types + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%a(parse_ip%n_types,parse_ip%n_types)) + parse_ip%a = 0.0_dp + allocate(parse_ip%AA(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%BB(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%p(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%q(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%sigma(parse_ip%n_types,parse_ip%n_types)) + parse_ip%sigma = 0.0_dp + allocate(parse_ip%eps2(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%C_0(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%C_1(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%D_SiO(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%C_OOprime(parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%D_OOprime(parse_ip%n_types,parse_ip%n_types)) + + allocate(parse_ip%lambda(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%gamma1(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%gamma2(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%eps3(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%d1(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%d2(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + allocate(parse_ip%costheta0(parse_ip%n_types,parse_ip%n_types,parse_ip%n_types)) + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "atnum_i", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_i") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_j") + read (value, *) Zj + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "AA", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find AA") + read (value, *) parse_ip%AA(ti,tj) + call QUIP_FoX_get_value(attributes, "BB", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find BB") + read (value, *) parse_ip%BB(ti,tj) + call QUIP_FoX_get_value(attributes, "p", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find p") + read (value, *) parse_ip%p(ti,tj) + call QUIP_FoX_get_value(attributes, "q", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find q") + read (value, *) parse_ip%q(ti,tj) + call QUIP_FoX_get_value(attributes, "a", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find a") + read (value, *) parse_ip%a(ti,tj) + call QUIP_FoX_get_value(attributes, "sigma", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find sigma") + read (value, *) parse_ip%sigma(ti,tj) + call QUIP_FoX_get_value(attributes, "eps", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find eps") + read (value, *) parse_ip%eps2(ti,tj) + call QUIP_FoX_get_value(attributes, "C_0", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find C_0") + read (value, *) parse_ip%C_0(ti,tj) + call QUIP_FoX_get_value(attributes, "C_1", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find C_1") + read (value, *) parse_ip%C_1(ti,tj) + call QUIP_FoX_get_value(attributes, "D_SiO", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find D_SiO") + read (value, *) parse_ip%D_SiO(ti,tj) + call QUIP_FoX_get_value(attributes, "C_OOprime", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find C_OOprime") + read (value, *) parse_ip%C_OOprime(ti,tj) + call QUIP_FoX_get_value(attributes, "D_OOprime", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find D_OOprime") + read (value, *) parse_ip%D_OOprime(ti,tj) + + if (ti /= tj) then + parse_ip%AA(tj,ti) = parse_ip%AA(ti,tj) + parse_ip%BB(tj,ti) = parse_ip%BB(ti,tj) + parse_ip%p(tj,ti) = parse_ip%p(ti,tj) + parse_ip%q(tj,ti) = parse_ip%q(ti,tj) + parse_ip%a(tj,ti) = parse_ip%a(ti,tj) + parse_ip%sigma(tj,ti) = parse_ip%sigma(ti,tj) + parse_ip%eps2(tj,ti) = parse_ip%eps2(ti,tj) + parse_ip%C_0(tj,ti) = parse_ip%C_0(ti,tj) + parse_ip%C_1(tj,ti) = parse_ip%C_1(ti,tj) + parse_ip%D_SiO(tj,ti) = parse_ip%D_SiO(ti,tj) + parse_ip%C_OOprime(tj,ti) = parse_ip%C_OOprime(ti,tj) + parse_ip%D_OOprime(tj,ti) = parse_ip%D_OOprime(ti,tj) + endif + + parse_ip%cutoff = maxval(parse_ip%a*parse_ip%sigma) + + elseif (parse_in_ip .and. name == 'per_triplet_data') then + + call QUIP_FoX_get_value(attributes, "atnum_c", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_c") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_j") + read (value, *) Zj + call QUIP_FoX_get_value(attributes, "atnum_k", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find atnum_k") + read (value, *) Zk + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + tk = get_type(parse_ip%type_of_atomic_num,Zk) + + call QUIP_FoX_get_value(attributes, "lambda", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find lambda") + read (value, *) parse_ip%lambda(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "gamma1", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find gamma1") + read (value, *) parse_ip%gamma1(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "gamma2", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find gamma2") + read (value, *) parse_ip%gamma2(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "d1", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find d1") + read (value, *) parse_ip%d1(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "d2", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find d2") + read (value, *) parse_ip%d2(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "costheta0", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find costheta0") + read (value, *) parse_ip%costheta0(ti,tj,tk) + call QUIP_FoX_get_value(attributes, "eps", value, status) + if (status /= 0) call system_abort ("IPModel_SW_VP_read_params_xml cannot find eps") + read (value, *) parse_ip%eps3(ti,tj,tk) + + + if (tj /= tk) then + parse_ip%lambda(ti,tk,tj) = parse_ip%lambda(ti,tj,tk) + parse_ip%gamma1(ti,tk,tj) = parse_ip%gamma2(ti,tj,tk) ! ti is central atom for tj /=tk, the legs change and hence gamma1 and gamma2 interchange + parse_ip%gamma2(ti,tk,tj) = parse_ip%gamma1(ti,tj,tk) ! + parse_ip%d1(ti,tk,tj) = parse_ip%d2(ti,tj,tk) ! ti is central atom for tj /=tk, the legs change and hence d1 and d2 interchange + parse_ip%d2(ti,tk,tj) = parse_ip%d1(ti,tj,tk) ! + parse_ip%eps3(ti,tk,tj) = parse_ip%eps3(ti,tj,tk) + parse_ip%costheta0(ti,tk,tj) = parse_ip%costheta0(ti,tj,tk) + endif + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'SW_VP_params') then + call print("endElement_handler SW_VP_params", PRINT_NERD) + parse_in_ip = .false. + endif + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_SW_VP_read_params_xml(this, param_str) + type(IPModel_SW_VP), intent(inout), target :: this + character(len=*) :: param_str + + type (xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_ip => this + parse_in_ip = .false. + parse_matched_label = .false. + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_SW_VP_read_params_xml parsed file, but n_types = 0") + endif + + end subroutine IPModel_SW_VP_read_params_xml + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X printing +!% Printing of SW_VP parameters: number of different types, cutoff radius, atomic numbers, ect. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +subroutine IPModel_SW_VP_Print (this, file) + type(IPModel_SW_VP), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer ti, tj, tk + + call Print("IPModel_SW_VP : Combined Stillinger-Weber/Vashishta potential", file=file) + call Print("IPModel_SW_VP : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_SW_VP : type "// ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + do tj=1, this%n_types + call Print ("IPModel_SW_VP : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) // & + " " // this%atomic_num(tj), file=file) + call Print ("IPModel_SW_VP : pair " // this%AA(ti,tj) // " " // this%BB(ti,tj) // " " // this%p(ti,tj) // " " // & + this%q(ti,tj) // " " // this%a(ti,tj), file=file) + call Print ("IPModel_SW_VP : " // this%sigma(ti,tj) // " " // this%eps2(ti,tj), file=file) + do tk=1, this%n_types + call Print ("IPModel_SW_VP : triplet interaction ti tj " // ti // " " // tj // " " // tk // & + " Zi Zj Zk " // this%atomic_num(ti) // " " // this%atomic_num(tj) // " " // this%atomic_num(tk), file=file) + call Print ("IPModel_SW_VP : triplet " // this%lambda(ti,tj,tk) // " " // this%gamma1(ti,tj,tk) // " " // & + this%eps3(ti,tj,tk), file=file) + end do + end do + call verbosity_pop() + end do + +end subroutine IPModel_SW_VP_Print + +end module IPModel_SW_VP_module diff --git a/src/Potentials/IPModel_Si_MEAM.F90 b/src/Potentials/IPModel_Si_MEAM.F90 new file mode 100644 index 0000000000..e3fe783d71 --- /dev/null +++ b/src/Potentials/IPModel_Si_MEAM.F90 @@ -0,0 +1,714 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Si_MEAM module +!X +!% Module for the Modified Embedded Atom Method potential for Si +!% The IPModel_Si_MEAM object contains all the parameters read +!% from an 'Si_MEAN_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! +#include "error.inc" + +module IPModel_Si_MEAM_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use spline_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + + +implicit none +private + +type IPModel_Si_MEAM + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + + type(spline), dimension(:,:), allocatable :: phi + type(spline), dimension(:,:), allocatable :: rho + type(spline), dimension(:,:), allocatable :: f + type(spline), dimension(:), allocatable :: U + type(spline), dimension(:,:,:), allocatable :: g + + real(dp), dimension(:,:), allocatable :: r_cut_phi + real(dp), dimension(:,:), allocatable :: r_cut_rho + real(dp), dimension(:,:), allocatable :: r_cut_f + + character(len=STRING_LENGTH) :: label +endtype IPModel_Si_MEAM + +interface Initialise + module procedure IPModel_Si_MEAM_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Si_MEAM_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Si_MEAM_Print +end interface Print + +interface Calc + module procedure IPModel_Si_MEAM_Calc +end interface Calc + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Si_MEAM), private, pointer :: parse_ip +integer :: parse_cur_type_i, parse_cur_type_j, parse_cur_type_k, parse_cur_point, n_spline + +real(dp) :: yp1, ypn +real(dp), dimension(:), allocatable :: spline_x, spline_y +character(len=100) :: spline_function + +public :: IPModel_Si_MEAM, Initialise, Finalise, Print, Calc + +contains + +subroutine IPModel_Si_MEAM_Initialise_str(this, args_str, param_str) + type(IPModel_Si_MEAM), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Si_MEAM_Initialise_str args_str')) then + call system_abort("IPModel_Si_MEAM_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Si_MEAM_read_params_xml(this, param_str) + +end subroutine IPModel_Si_MEAM_Initialise_str + +subroutine IPModel_Si_MEAM_Finalise(this) + type(IPModel_Si_MEAM), intent(inout) :: this + + integer :: ti, tj, tk + + do ti=1, this%n_types + call finalise(this%U(ti)) + do tj=1, this%n_types + call finalise(this%phi(ti,tj)) + call finalise(this%rho(ti,tj)) + call finalise(this%f(ti,tj)) + do tk=1, this%n_types + call finalise(this%g(ti,tj,tk)) + enddo + end do + end do + + if(allocated(this%phi)) deallocate(this%phi) + if(allocated(this%rho)) deallocate(this%rho) + if(allocated(this%f)) deallocate(this%f) + if(allocated(this%U)) deallocate(this%U) + if(allocated(this%g)) deallocate(this%g) + if(allocated(this%atomic_num)) deallocate(this%atomic_num) + if(allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if(allocated(this%r_cut_phi)) deallocate(this%r_cut_phi) + if(allocated(this%r_cut_rho)) deallocate(this%r_cut_rho) + if(allocated(this%r_cut_f)) deallocate(this%r_cut_f) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Si_MEAM_Finalise + +subroutine IPModel_Si_MEAM_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Si_MEAM), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out), optional :: e !% \texttt{e} = System total energy + real(dp), dimension(:), intent(out), optional :: local_e !% \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), dimension(3,3), intent(out), optional :: virial !% Virial + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + !local + integer :: i, j, k, n, nn, ti, tj, tk + + real(dp) :: r_ij, r_ik, n_i, f_ij, f_ik, theta_jik, g_jik, U_i, phi_ij, & + & dphi_ij, df_ij, df_ik, dg_jik, dU_i, drho_ij + real(dp), dimension(3) :: u_ij, u_ik, dn_i, dn_j, dn_i_dr_ij, diff_ij, diff_ik + real(dp), dimension(3,3) :: dn_i_drij_outer_rij + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Si_MEAM_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Si_MEAM_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Si_MEAM_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_Si_MEAM_Calc: local_virial calculation requested but not supported yet.", error) + endif + + atom_mask_pointer => null() + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="Name of logical property used to mask atoms") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Si_MEAM_Calc args_str')) then + RAISE_ERROR("IPModel_Si_MEAM_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_SW_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + else + atom_mask_pointer => null() + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_Si_MEAM_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + endif + + !Loop over atoms + do i = 1, at%N + + if (present(mpi)) then + if(mpi%active) then + if(mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + n_i = 0.0_dp + dn_i = 0.0_dp + dn_i_drij_outer_rij = 0.0_dp + !Loop over neighbours + do n = 1, n_neighbours(at,i) + + j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, diff=diff_ij) ! nth neighbour of atom i + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if( r_ij < this%r_cut_phi(ti,tj) ) then + if(present(local_e) .or. present(e)) phi_ij = spline_value(this%phi(ti,tj),r_ij) + if(present(local_e)) local_e(i) = local_e(i) + phi_ij*0.5_dp + if(present(e)) e = e + phi_ij*0.5_dp + + if(present(f) .or. present(virial) ) dphi_ij = spline_deriv(this%phi(ti,tj),r_ij) + if(present(f)) then + f(:,i) = f(:,i) + 0.5_dp*dphi_ij*u_ij + f(:,j) = f(:,j) - 0.5_dp*dphi_ij*u_ij + endif + if(present(virial)) virial = virial - 0.5_dp * dphi_ij*(u_ij .outer. u_ij)*r_ij + endif + + if( (r_ij >= this%r_cut_rho(ti,tj)).or.(r_ij >= this%r_cut_f(ti,tj)) ) cycle + + n_i = n_i + spline_value(this%rho(ti,tj),r_ij) + if(present(f) .or. present(virial) ) then + dn_i_dr_ij = spline_deriv(this%rho(ti,tj),r_ij)*u_ij + if(present(f)) dn_i = dn_i + dn_i_dr_ij + if(present(virial)) dn_i_drij_outer_rij = dn_i_drij_outer_rij + (dn_i_dr_ij .outer. u_ij) * r_ij + endif + + f_ij = spline_value(this%f(ti,tj),r_ij) + if(present(f) .or. present(virial)) df_ij = spline_deriv(this%f(ti,tj),r_ij) + + do nn = 1, n_neighbours(at,i) + + k = neighbour(at, i, nn, distance=r_ik, cosines=u_ik, diff=diff_ik) + tk = get_type(this%type_of_atomic_num, at%Z(k)) + + !if( j>=k ) cycle + if( norm(diff_ij-diff_ik) .feq. 0.0_dp ) cycle + if( r_ik >= this%r_cut_f(ti,tk) ) cycle + + theta_jik = dot_product(u_ij,u_ik) !cosine( at, i, j, k ) + + f_ik = spline_value(this%f(ti,tk),r_ik) + if(present(f) .or. present(virial)) df_ik = spline_deriv(this%f(ti,tk),r_ik) + + g_jik = spline_value(this%g(ti,tj,tk),theta_jik) + if(present(f) .or. present(virial)) dg_jik = spline_deriv(this%g(ti,tj,tk),theta_jik) + + n_i = n_i + 0.5_dp * f_ij * f_ik * g_jik + + if( present(f) ) & + & dn_i = dn_i + 0.5_dp * ( g_jik * & + & ( df_ij * f_ik * u_ij + & + & df_ik * f_ij * u_ik ) + & + & f_ij * f_ik * dg_jik * & + & ( u_ij / r_ik + u_ik / r_ij - & + & theta_jik * ( u_ij / r_ij + u_ik / r_ik ) ) ) + + if( present(virial) ) & + & dn_i_drij_outer_rij = dn_i_drij_outer_rij + & + & 0.5_dp * ( g_jik * ( df_ij * f_ik * (u_ij.outer.u_ij) * r_ij + & + df_ik * f_ij * (u_ik.outer.u_ik) * r_ik ) + & + & f_ij * f_ik * dg_jik * & + & ( (u_ij .outer. u_ik) - theta_jik * (u_ij .outer. u_ij) + & + & (u_ik .outer. u_ij) - theta_jik * (u_ik .outer. u_ik) ) ) + enddo + + enddo + if(present(local_e) .or. present(e)) U_i = spline_value(this%U(ti),n_i) + if(present(f) .or. present(virial)) dU_i = spline_deriv(this%U(ti),n_i) + + if(present(local_e)) local_e(i) = local_e(i) + U_i + if(present(e)) e = e + U_i + if(present(f)) f(:,i) = f(:,i) + dU_i * dn_i + if(present(virial)) virial = virial - dU_i * dn_i_drij_outer_rij + + if(present(f)) then + do n = 1, n_neighbours(at,i) !cross-terms + + j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, diff=diff_ij) ! nth neighbour of atom i + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + if( (r_ij >= this%r_cut_rho(ti,tj)).or.(r_ij >= this%r_cut_f(ti,tj)) ) cycle + + drho_ij = spline_deriv(this%rho(ti,tj),r_ij) + + f(:,j) = f(:,j) - dU_i * drho_ij * u_ij + + f_ij = spline_value(this%f(ti,tj),r_ij) + df_ij = spline_deriv(this%f(ti,tj),r_ij) + + dn_j = 0.0_dp + + do nn = 1, n_neighbours(at,i) + + k = neighbour(at, i, nn, distance=r_ik, cosines=u_ik, diff=diff_ik) + tk = get_type(this%type_of_atomic_num, at%Z(k)) + + if( norm(diff_ij-diff_ik) .feq. 0.0_dp ) cycle + if( r_ik >= this%r_cut_f(ti,tk) ) cycle + + theta_jik = dot_product(u_ij,u_ik) !cosine( at, i, j, k ) + + f_ik = spline_value(this%f(ti,tk),r_ik) + df_ik = spline_deriv(this%f(ti,tk),r_ik) + + g_jik = spline_value(this%g(ti,tj,tk),theta_jik) + dg_jik = spline_deriv(this%g(ti,tj,tk),theta_jik) + + dn_j = dn_j + df_ij * f_ik * g_jik * u_ij + & + & f_ij * f_ik * dg_jik * ( u_ik / r_ij - theta_jik * u_ij / r_ij ) + + enddo + + f(:,j) = f(:,j) - dU_i * dn_j + enddo + endif + enddo + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) call sum_in_place(mpi, f) + if (present(virial)) call sum_in_place(mpi, virial) + endif + +endsubroutine IPModel_Si_MEAM_Calc + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: value + + integer :: ti, Zi, Zj, Zk + integer :: n_types + real(dp) :: v + + if (name == 'Si_MEAM_params') then + + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered Si_MEAM_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, "n_types", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find n_types") + read (value, *) parse_ip%n_types + n_types = parse_ip%n_types + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + allocate(parse_ip%r_cut_phi(n_types,n_types)) + parse_ip%r_cut_phi = 0.0_dp + allocate(parse_ip%r_cut_rho(n_types,n_types)) + parse_ip%r_cut_rho = 0.0_dp + allocate(parse_ip%r_cut_f(n_types,n_types)) + parse_ip%r_cut_f = 0.0_dp + + allocate( parse_ip%phi(n_types,n_types)) + allocate( parse_ip%rho(n_types,n_types)) + allocate( parse_ip%f(n_types,n_types)) + allocate( parse_ip%U(n_types)) + allocate( parse_ip%g(n_types,n_types,n_types)) + + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find type") + read (value, *) ti + + if (ti < 1 .or. ti > parse_ip%n_types) call system_abort("IPModel_Si_MEAM_read_params_xml got" // & + " per_type_data type out of range " // ti // " n_types " // parse_ip%n_types) + + parse_cur_type_i = ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "atomic_num_i", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_i") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atomic_num_j", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_j") + read (value, *) Zj + + parse_cur_type_i = get_type(parse_ip%type_of_atomic_num,Zi) + parse_cur_type_j = get_type(parse_ip%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "r_cut_phi", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find r_cut_phi") + read (value, *) parse_ip%r_cut_phi(parse_cur_type_i, parse_cur_type_j) + call QUIP_FoX_get_value(attributes, "r_cut_rho", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find r_cut_rho") + read (value, *) parse_ip%r_cut_rho(parse_cur_type_i, parse_cur_type_j) + call QUIP_FoX_get_value(attributes, "r_cut_f", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find r_cut_f") + read (value, *) parse_ip%r_cut_f(parse_cur_type_i, parse_cur_type_j) + + elseif (parse_in_ip .and. name == 'per_triplet_data') then + + call QUIP_FoX_get_value(attributes, "atomic_num_i", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_i") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atomic_num_j", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_j") + read (value, *) Zj + call QUIP_FoX_get_value(attributes, "atomic_num_k", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find atomic_num_k") + read (value, *) Zk + + parse_cur_type_i = get_type(parse_ip%type_of_atomic_num,Zi) + parse_cur_type_j = get_type(parse_ip%type_of_atomic_num,Zj) + parse_cur_type_k = get_type(parse_ip%type_of_atomic_num,Zk) + + elseif (parse_in_ip .and. name == 'spline') then + call QUIP_FoX_get_value(attributes, "spline_function", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find spline_function") + read (value, *) spline_function + call QUIP_FoX_get_value(attributes, "n_spline", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find n_spline") + read (value, *) n_spline + call QUIP_FoX_get_value(attributes, "yp1", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find yp1") + read (value, *) yp1 + call QUIP_FoX_get_value(attributes, "ypn", value, status) + if (status /= 0) call system_abort ("IPModel_Si_MEAM_read_params_xml cannot find ypn") + read (value, *) ypn + allocate( spline_x(n_spline), spline_y(n_spline) ) + parse_cur_point = 1 + elseif (parse_in_ip .and. name == 'point') then + + if (parse_cur_point > n_spline) call system_abort ("IPModel_Si_MEAM got too " // & + &"many points " // parse_cur_point // " type " // parse_cur_type_i // " " // parse_cur_type_j // & + & " in spline "// trim(spline_function)) + + call QUIP_FoX_get_value(attributes, "x", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_Ercolessi_Adams_read_params_xml cannot find x") + read (value, *) v + spline_x(parse_cur_point) = v + + call QUIP_FoX_get_value(attributes, "y", value, status) + if (status /= 0) call system_abort ("IPModel_EAM_Ercolessi_Adams_read_params_xml cannot find y") + read (value, *) v + spline_y(parse_cur_point) = v + + parse_cur_point = parse_cur_point + 1 + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Si_MEAM_params') then + parse_in_ip = .false. + elseif (name == 'spline') then + selectcase(trim(spline_function)) + case('phi') + call initialise(parse_ip%phi(parse_cur_type_i,parse_cur_type_j), spline_x, spline_y, yp1, ypn) + if( parse_cur_type_i /= parse_cur_type_j ) & + & call initialise(parse_ip%phi(parse_cur_type_j,parse_cur_type_i), spline_x, spline_y, yp1, ypn) + case('rho') + call initialise(parse_ip%rho(parse_cur_type_i,parse_cur_type_j), spline_x, spline_y, yp1, ypn) + if( parse_cur_type_i /= parse_cur_type_j ) & + & call initialise(parse_ip%rho(parse_cur_type_j,parse_cur_type_i), spline_x, spline_y, yp1, ypn) + case('f') + call initialise(parse_ip%f(parse_cur_type_i,parse_cur_type_j), spline_x, spline_y, yp1, ypn) + if( parse_cur_type_i /= parse_cur_type_j ) & + & call initialise(parse_ip%f(parse_cur_type_j,parse_cur_type_i), spline_x, spline_y, yp1, ypn) + case('U') + call initialise(parse_ip%U(parse_cur_type_i), spline_x, spline_y, yp1, ypn) + case('g') + call initialise(parse_ip%g(parse_cur_type_i,parse_cur_type_j,parse_cur_type_k), & + & spline_x, spline_y, yp1, ypn) + if( parse_cur_type_j /= parse_cur_type_k ) & + & call initialise(parse_ip%g(parse_cur_type_i,parse_cur_type_k,parse_cur_type_j), & + & spline_x, spline_y, yp1, ypn) + case default + call system_abort('') + endselect + deallocate(spline_x, spline_y) + endif + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_Si_MEAM_read_params_xml(this, param_str) + type(IPModel_Si_MEAM), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type (xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_ip => this + parse_in_ip = .false. + parse_matched_label = .false. + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types == 0) call system_abort("Si_MEAM Tried to parse, but n_types still 0") + + parse_ip%cutoff = max(maxval(parse_ip%r_cut_phi),maxval(parse_ip%r_cut_rho),maxval(parse_ip%r_cut_f)) + +end subroutine IPModel_Si_MEAM_read_params_xml + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of potential parameters: number of different types, cutoff radius, atomic numbers, ect. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_Si_MEAM_Print (this, file) + type(IPModel_Si_MEAM), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj, tk + + call Print("IPModel_Si_MEAM : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print("IPModel_Si_MEAM : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print("IPModel_Si_MEAM : U ", file=file) + call Print(this%U(ti), file=file) + do tj=1, this%n_types + call Print("IPModel_Si_MEAM : pair "// ti // " " // tj // " r_cut_phi " // this%r_cut_phi(ti,tj), file=file) + call Print("IPModel_Si_MEAM : pair phi ", file=file) + call Print(this%phi(ti,tj), file=file) + + call Print("IPModel_Si_MEAM : pair "// ti // " " // tj // " r_cut_rho " // this%r_cut_rho(ti,tj), file=file) + call Print("IPModel_Si_MEAM : pair rho ", file=file) + call Print(this%rho(ti,tj), file=file) + + call Print("IPModel_Si_MEAM : pair "// ti // " " // tj // " r_cut_f " // this%r_cut_f(ti,tj), file=file) + call Print("IPModel_Si_MEAM : pair f ", file=file) + call Print(this%f(ti,tj), file=file) + do tk=1, this%n_types + call Print("IPModel_Si_MEAM : triplet g", file=file) + call Print(this%g(ti,tj,tk), file=file) + enddo + end do + call verbosity_pop() + end do + +end subroutine IPModel_Si_MEAM_Print + +endmodule IPModel_Si_MEAM_module +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! +! diff --git a/src/Potentials/IPModel_Spring.F90 b/src/Potentials/IPModel_Spring.F90 new file mode 100644 index 0000000000..b81b2b2650 --- /dev/null +++ b/src/Potentials/IPModel_Spring.F90 @@ -0,0 +1,259 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Spring +!X +!% Tethers two groups of atoms (their Centers of Geometry) together with a spring: +!% +!% Energy and Force routines are hardwired +!% Cutoff is hardwired +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Spring_module + +use error_module +use system_module, only : dp, inoutput, print, operator(//), split_string,string_to_int +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use topology_module, only : calc_mean_pos + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Spring +type IPModel_Spring + real(dp) :: cutoff = 0.0_dp + real(dp) :: force_constant = 0.0_dp + real(dp) :: left = 0.0_dp + real(dp) :: right = 0.0_dp + logical :: use_com = .true. + integer,allocatable,dimension(:) :: spring_indices1 + integer,allocatable,dimension(:) :: spring_indices2 +end type IPModel_Spring + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Spring), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Spring_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Spring_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Spring_Print +end interface Print + +interface Calc + module procedure IPModel_Spring_Calc +end interface Calc + +contains + +subroutine IPModel_Spring_Initialise_str(this, args_str, param_str, error) + type(IPModel_Spring), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out):: error + character(len=STRING_LENGTH) :: indices1_string, indices2_string + character(len=STRING_LENGTH), dimension(99) :: indices1_fields, indices2_fields + integer:: i,n_group1,n_group2 + + INIT_ERROR(error) + call Finalise(this) + + call initialise(params) + call param_register(params, 'cutoff', '0.0', this%cutoff, help_string='Not used') + call param_register(params, 'force_constant', '0.0', this%force_constant, help_string='Force constant for quadratic confinement potential. Energy is 0.5*force_constant*displacement^2') + call param_register(params, 'left', '0.0', this%left, help_string='Inner distance at which left harmonic wall ends') + call param_register(params, 'right', '0.0', this%right, help_string='Outer distance at which right harmonic wall begins') + call param_register(params, 'use_com', 'T', this%use_com, help_string='T: use centre of mass. F: use centre of geometry.') + call param_register(params, 'indices1', PARAM_MANDATORY, indices1_string, help_string="Indices (1-based) of the first group of atoms you wish to tether, format {i1 i2 i3 ...}") + call param_register(params, 'indices2', PARAM_MANDATORY, indices2_string, help_string="Indices (1-based) of the second group of atoms you wish to tether, format {i1 i2 i3 ...}") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_Spring_Initialise args_str')) then + RAISE_ERROR("IPModel_Spring_Init failed to parse args_str='"//trim(args_str)//"'", error) + end if + call finalise(params) + + call split_string(indices1_string,' ','{}',indices1_fields(:),n_group1,matching=.true.) + call split_string(indices2_string,' ','{}',indices2_fields(:),n_group2,matching=.true.) + allocate(this%spring_indices1(n_group1)) + allocate(this%spring_indices2(n_group2)) + + do i=1,n_group1 + this%spring_indices1(i) = string_to_int(indices1_fields(i)) + end do + do i=1,n_group2 + this%spring_indices2(i) = string_to_int(indices2_fields(i)) + end do + + +end subroutine IPModel_Spring_Initialise_str + +subroutine IPModel_Spring_Finalise(this) + type(IPModel_Spring), intent(inout) :: this + + ! Add finalisation code here + +end subroutine IPModel_Spring_Finalise + + +subroutine IPModel_Spring_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Spring), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + + real(dp) :: energy, force(3,at%N), r, dr(3), com1(3), com2(3), theforce(3), disp + integer :: i , n_group1, n_group2, i_group11, i_group1i, i_group21, i_group2i + real(dp), allocatable :: weight1(:), weight2(:) + + n_group1=size(this%spring_indices1) + n_group2=size(this%spring_indices2) + + INIT_ERROR(error) + + allocate(weight1(n_group1), weight2(n_group2)) + + if (this%use_com) then + if (.not. has_property(at, 'mass')) then + RAISE_ERROR('IPModel_Spring_Calc: Atoms has no mass property', error) + end if + + do i=1,n_group1 + weight1(i) = at%mass(this%spring_indices1(i)) + end do + weight1 = weight1 / sum(weight1) + + do i=1,n_group2 + weight2(i) = at%mass(this%spring_indices2(i)) + end do + weight2 = weight2 / sum(weight2) + else + weight1 = 1.0_dp / n_group1 + weight2 = 1.0_dp / n_group2 + end if + + if (this%use_com) then + com1 = centre_of_mass(at, index_list=this%spring_indices1) + com2 = centre_of_mass(at, index_list=this%spring_indices2) + else + com1 = calc_mean_pos(at, this%spring_indices1) + com2 = calc_mean_pos(at, this%spring_indices2) + end if + + r = distance_min_image(at, com1, com2) + + energy = 0.0_dp + force = 0.0_dp + + disp = 0.0_dp + if (r .fgt. this%right) then + disp = r - this%right + end if + if (r .flt. this%left) then + disp = r - this%left + end if + + dr = diff_min_image(at, com1, com2) / r + + ! Harmonic confining potential on tethered atoms + ! energy + energy = energy + 0.5_dp * this%force_constant * disp**2 + + ! force + theforce = ( this%force_constant * disp ) * dr + do i=1,n_group1 + force(:,this%spring_indices1(i)) = theforce * weight1(i) + end do + do i=1,n_group2 + force(:,this%spring_indices2(i)) = - theforce * weight2(i) + end do + + deallocate(weight1) + deallocate(weight2) + + + if (present(e)) e = energy + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Spring_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Spring_Calc', error) + f = force + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Spring_Calc', error) + local_virial = 0.0_dp + endif + +end subroutine IPModel_Spring_Calc + + +subroutine IPModel_Spring_Print(this, file) + type(IPModel_Spring), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_Spring : Spring Potential", file=file) + call Print("IPModel_Spring : cutoff = " // this%cutoff, file=file) + call Print("IPModel_Spring : force_constant = " // this%force_constant, file=file) + call Print("IPModel_Spring : left = " // this%left, file=file) + call Print("IPModel_Spring : right = " // this%right, file=file) + call Print("IPModel_Spring : use_com = " // this%use_com, file=file) + call Print("IPModel_Spring : group 1 atoms = " // this%spring_indices1, file=file) + call Print("IPModel_Spring : group 2 atoms = " // this%spring_indices2, file=file) + +end subroutine IPModel_Spring_Print + + +end module IPModel_Spring_module diff --git a/src/Potentials/IPModel_Sutton_Chen.F90 b/src/Potentials/IPModel_Sutton_Chen.F90 new file mode 100644 index 0000000000..4ac2d28fc6 --- /dev/null +++ b/src/Potentials/IPModel_Sutton_Chen.F90 @@ -0,0 +1,458 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Sutton_Chen +!X +!% Sutton_Chen module for use when implementing a new Interatomic Potential +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Sutton_Chen_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Sutton_Chen +type IPModel_Sutton_Chen + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp), dimension(:), allocatable :: a, epsilon, c, v_cutoff, rho_cutoff, & + dv_cutoff, drho_cutoff + integer, dimension(:), allocatable :: m, n + real(dp) :: cutoff = 0.0_dp + + character(len=STRING_LENGTH) :: label + +end type IPModel_Sutton_Chen + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Sutton_Chen), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Sutton_Chen_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Sutton_Chen_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Sutton_Chen_Print +end interface Print + +interface Calc + module procedure IPModel_Sutton_Chen_Calc +end interface Calc + +contains + +subroutine IPModel_Sutton_Chen_Initialise_str(this, args_str, param_str) + type(IPModel_Sutton_Chen), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + integer :: ti + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Sutton_Chen_Initialise_str args_str')) then + call system_abort("IPModel_Sutton_Chen_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Sutton_Chen_read_params_xml(this, param_str) + + do ti = 1, this%n_types + this%v_cutoff(ti) = ( this%a(ti) / this%cutoff )**this%n(ti) + this%dv_cutoff(ti) = - this%n(ti) * ( this%a(ti) / this%cutoff )**this%n(ti) / this%cutoff + this%rho_cutoff(ti) = ( this%a(ti) / this%cutoff )**this%m(ti) + this%drho_cutoff(ti) = - this%m(ti) * ( this%a(ti) / this%cutoff )**this%m(ti) / this%cutoff + enddo + +end subroutine IPModel_Sutton_Chen_Initialise_str + +subroutine IPModel_Sutton_Chen_Finalise(this) + type(IPModel_Sutton_Chen), intent(inout) :: this + + ! Add finalisation code here + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%a)) deallocate(this%a) + if (allocated(this%epsilon)) deallocate(this%epsilon) + if (allocated(this%c)) deallocate(this%c) + if (allocated(this%m)) deallocate(this%m) + if (allocated(this%n)) deallocate(this%n) + if (allocated(this%v_cutoff)) deallocate(this%v_cutoff) + if (allocated(this%dv_cutoff)) deallocate(this%dv_cutoff) + if (allocated(this%rho_cutoff)) deallocate(this%rho_cutoff) + if (allocated(this%drho_cutoff)) deallocate(this%drho_cutoff) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Sutton_Chen_Finalise + + +subroutine IPModel_Sutton_Chen_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Sutton_Chen), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer :: i, j, n, ti, tj + real(dp) :: r_ij, rho_i, v_i, a_over_r, drho_i_drij, dv_i_drij, df_i, e_i + real(dp), dimension(3) :: drho_i_dri, dv_i_dri, u_ij + real(dp), dimension(3,3) :: drho_i_drij_outer_rij, dv_i_drij_outer_rij, virial_i + + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Sutton_Chen_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Sutton_Chen_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Sutton_Chen_Calc', error) + local_virial = 0.0_dp + endif + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Sutton_Chen_Calc args_str')) then + RAISE_ERROR("IPModel_Sutton_Chen_Calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then + RAISE_ERROR("IPModel_Sutton_Chen_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + else + atom_mask_pointer => null() + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_Sutton_Chen_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + endif + + do i = 1, at%N + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + rho_i = 0.0_dp ! Local density from neighbours + v_i = 0.0_dp + + drho_i_dri = 0.0_dp + dv_i_dri = 0.0_dp + + drho_i_drij_outer_rij = 0.0_dp + dv_i_drij_outer_rij = 0.0_dp + + ! Get the type of this species from its atomic number + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + do n = 1, n_neighbours(at, i) + j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, max_dist=this%cutoff) + if( j <= 0 ) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + a_over_r = this%a(tj) / r_ij + + rho_i = rho_i + ( a_over_r**this%m(tj) - this%rho_cutoff(tj) ) + v_i = v_i + ( a_over_r**this%n(tj) - this%v_cutoff(tj) ) + + if( present(f) .or. present(virial) .or. present(local_virial) ) then + drho_i_drij = - this%m(tj) * a_over_r**this%m(tj) / r_ij + dv_i_drij = -this%n(tj) * a_over_r**this%n(tj) / r_ij + + if( present(f) ) then + drho_i_dri = drho_i_dri + drho_i_drij * u_ij + dv_i_dri = dv_i_dri + dv_i_drij * u_ij + endif + + if( present(virial) .or. present(local_virial) ) then + drho_i_drij_outer_rij = drho_i_drij_outer_rij + drho_i_drij*(u_ij .outer. u_ij)*r_ij + dv_i_drij_outer_rij = dv_i_drij_outer_rij + dv_i_drij*(u_ij .outer. u_ij)*r_ij + endif + endif + enddo + + df_i = - 0.5_dp * this%c(ti) / sqrt(rho_i) + + if(present(f)) then + f(:,i) = f(:,i) + this%epsilon(ti) * ( drho_i_dri * df_i + dv_i_dri ) + do n = 1, n_neighbours(at, i) + j = neighbour(at, i, n, distance=r_ij, cosines=u_ij, max_dist=this%cutoff) + if( j <= 0 ) cycle + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + a_over_r = this%a(tj) / r_ij + drho_i_drij = - this%m(tj) * a_over_r**this%m(tj) / r_ij + + f(:,j) = f(:,j) - this%epsilon(tj) * df_i * drho_i_drij * u_ij + enddo + endif + + if( present(e) .or. present(local_e) ) then + e_i = this%epsilon(ti) * ( 0.5_dp * v_i - this%c(ti) * sqrt(rho_i) ) + if( present(e) ) e = e + e_i + if( present(local_e) ) local_e(i) = e_i + endif + + if( present(virial) .or. present(local_virial) ) then + virial_i = this%epsilon(ti) * ( - 0.5_dp * dv_i_drij_outer_rij - & + df_i * drho_i_drij_outer_rij ) + + if(present(virial)) virial = virial + virial_i + if(present(local_virial)) local_virial(:,i) = local_virial(:,i) + reshape(virial_i,(/9/)) + endif + enddo ! i + + atom_mask_pointer => null() + +end subroutine IPModel_Sutton_Chen_Calc + + +subroutine IPModel_Sutton_Chen_Print(this, file) + type(IPModel_Sutton_Chen), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_Sutton_Chen : Sutton_Chen Potential", file=file) + call Print("IPModel_Sutton_Chen : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_Sutton_Chen : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_Sutton_Chen : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_Sutton_Chen_Print + +subroutine IPModel_Sutton_Chen_read_params_xml(this, param_str) + type(IPModel_Sutton_Chen), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Sutton_Chen_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_Sutton_Chen_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + integer ti + + if (name == 'Sutton_Chen_params') then ! new Sutton_Chen stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in Sutton_Chen_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + allocate(parse_ip%a(parse_ip%n_types)) + parse_ip%a = 0.0_dp + allocate(parse_ip%epsilon(parse_ip%n_types)) + parse_ip%epsilon = 0.0_dp + allocate(parse_ip%c(parse_ip%n_types)) + parse_ip%c = 0.0_dp + allocate(parse_ip%m(parse_ip%n_types)) + parse_ip%m = 0 + allocate(parse_ip%n(parse_ip%n_types)) + parse_ip%n = 0 + allocate(parse_ip%v_cutoff(parse_ip%n_types)) + parse_ip%v_cutoff = 0.0_dp + allocate(parse_ip%dv_cutoff(parse_ip%n_types)) + parse_ip%dv_cutoff = 0.0_dp + allocate(parse_ip%rho_cutoff(parse_ip%n_types)) + parse_ip%rho_cutoff = 0.0_dp + allocate(parse_ip%drho_cutoff(parse_ip%n_types)) + parse_ip%drho_cutoff = 0.0_dp + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + call QUIP_FoX_get_value(attributes, "a", value, status) + if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find a") + read (value, *) parse_ip%a(ti) + + call QUIP_FoX_get_value(attributes, "epsilon", value, status) + if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find epsilon") + read (value, *) parse_ip%epsilon(ti) + + call QUIP_FoX_get_value(attributes, "c", value, status) + if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find c") + read (value, *) parse_ip%c(ti) + + call QUIP_FoX_get_value(attributes, "m", value, status) + if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find m") + read (value, *) parse_ip%m(ti) + + call QUIP_FoX_get_value(attributes, "n", value, status) + if (status /= 0) call system_abort ("IPModel_Sutton_Chen_read_params_xml cannot find n") + read (value, *) parse_ip%n(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + enddo + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Sutton_Chen_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_Sutton_Chen_module diff --git a/src/Potentials/IPModel_TS.F90 b/src/Potentials/IPModel_TS.F90 new file mode 100644 index 0000000000..0fd2d05b01 --- /dev/null +++ b/src/Potentials/IPModel_TS.F90 @@ -0,0 +1,968 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_TS +!X +!% Reimplementation of TS potential: +!% P. Tangney and S. Scandolo, +!% An ab initio parametrized interatomic force field for silica +!% J. Chem. Phys, 117, 8898 (2002). +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_TS_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_VERBOSE, current_verbosity, line, system_timer, verbosity_push_decrement, verbosity_pop, operator(//) +use units_module +use periodictable_module +use mpi_context_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use cinoutput_module + + +use functions_module +use QUIP_Common_module +use Yukawa_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_TS +type IPModel_TS + integer :: n_types = 0 + real(dp) :: betapol, tolpol, yukalpha, yuksmoothlength + integer :: maxipol, pred_order + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + real(dp), allocatable, dimension(:) :: pol, z, pseudise_sigma + real(dp), allocatable, dimension(:,:) :: D_ms, gamma_ms, R_ms, B_pol, C_pol + + real(dp) :: cutoff_coulomb, cutoff_ms, smoothlength_ms + + character(len=STRING_LENGTH) :: label + logical :: initialised, tdip_sr + +end type IPModel_TS + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_TS), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_TS_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_TS_Finalise +end interface Finalise + +interface Print + module procedure IPModel_TS_Print +end interface Print + +public :: setup_atoms +interface setup_atoms + module procedure IPModel_TS_setup_atoms +end interface + +interface Calc + module procedure IPModel_TS_Calc +end interface Calc + +contains + + +subroutine IPModel_TS_Initialise_str(this, args_str, param_str) + type(IPModel_TS), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + this%initialised = .false. + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_TS_Initialise_str args_str')) then + call system_abort("IPModel_TS_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_TS_read_params_xml(this, param_str) + this%initialised = .true. + +end subroutine IPModel_TS_Initialise_str + +subroutine IPModel_TS_Finalise(this) + type(IPModel_TS), intent(inout) :: this + + this%initialised = .false. + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%pol)) deallocate(this%pol) + if (allocated(this%z)) deallocate(this%z) + if (allocated(this%D_ms)) deallocate(this%D_ms) + if (allocated(this%gamma_ms)) deallocate(this%gamma_ms) + if (allocated(this%R_ms)) deallocate(this%R_ms) + if (allocated(this%B_pol)) deallocate(this%B_pol) + if (allocated(this%C_pol)) deallocate(this%C_pol) + if (allocated(this%pseudise_sigma)) deallocate(this%pseudise_sigma) + this%n_types = 0 + this%label = '' +end subroutine IPModel_TS_Finalise + +subroutine asap_short_range_dipole_moments(this, at, charge, dip_sr, mpi) + type(IPModel_TS), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), dimension(:), intent(in) :: charge + real(dp), dimension(:,:), intent(out) :: dip_sr + type(MPI_Context), intent(in), optional :: mpi + + integer :: i, ti, m, j, tj, k + real(dp) :: r_ij, u_ij(3), qj, bij, cij, dist3, dist5, gij, factork, expfactor, fc, dfc_dr + integer, parameter :: nk = 4 + real(dp), allocatable :: private_dip_sr(:,:) + + call system_timer('asap_short_range_dipole_moments') + + dip_sr = 0.0_dp + + !$omp parallel default(none) shared(this, mpi, at, charge, dip_sr) private(ti, m, j, tj, k, r_ij, u_ij, qj, bij, cij, dist3, dist5, gij, factork, expfactor, fc, dfc_dr, private_dip_sr) + + allocate(private_dip_sr(size(dip_sr,1),size(dip_sr,2))) + private_dip_sr = 0.0_dp + + !$omp do schedule(runtime) + do i=1, at%n + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + if (.not. (abs(this%pol(ti)) > 0.0_dp)) cycle + + do m = 1, n_neighbours(at, i) + + j = neighbour(at, i, m, distance=r_ij, diff=u_ij, max_dist=(this%cutoff_ms*BOHR)) + if (j <= 0) cycle + if (r_ij .feq. 0.0_dp) cycle + + r_ij = r_ij/BOHR + u_ij = u_ij/BOHR + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + qj = charge(j) + bij = this%b_pol(ti, tj) + cij = this%c_pol(ti, tj) + + dist3 = r_ij**3.0_dp + dist5 = r_ij**5.0_dp + + gij = 0.0_dp + factork = cij*exp(-bij*r_ij) + do k=1,nk + gij = gij + factork + factork = factork*bij*r_ij/real(k,dp) + enddo + gij = gij + factork + + expfactor = exp(-this%yukalpha*r_ij) + call smooth_cutoff(r_ij, this%cutoff_coulomb-this%yuksmoothlength, this%yuksmoothlength, fc, dfc_dr) + + private_dip_sr(:,i) = private_dip_sr(:,i) - this%pol(ti)*qj*u_ij*gij/dist3*expfactor*fc + end do + end do + !$omp end do + + if (present(mpi)) then + if (mpi%active) call sum_in_place(mpi, private_dip_sr) + endif + + !$omp critical + dip_sr = dip_sr + private_dip_sr*BOHR + !$omp end critical + + deallocate(private_dip_sr) + !$omp end parallel + + call system_timer('asap_short_range_dipole_moments') + +end subroutine asap_short_range_dipole_moments + +!% Morse-stretch potential, defined by +!% \begin{displaymath} +!% U_ij = D_ij \left[ e^{\gamma_{ij}\left( 1 - r_{ij}/r^0_{ij} \right)} +!% - 2 e^{\gamma_{ij}/2\left( 1 - r_{ij}/r^0_{ij} \right)} \right] +!% \end{displaymath} +subroutine asap_morse_stretch(this, at, e, local_e, f, virial, mpi) +#ifdef _OPENMP + use omp_lib +#endif + type(IPModel_TS), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:) + real(dp), intent(out), optional :: virial(3,3) + type(MPI_Context), intent(in), optional :: mpi + + integer i, j, m, ti, tj + real(dp) :: r_ij, u_ij(3), dms, gammams, rms + real(dp) :: exponentms, factorms, phi, de + real(dp) :: dforce, fc, dfc_dr + real(dp) :: elimitij(this%n_types, this%n_types) + logical :: i_is_min_image, j_is_min_image + + real(dp) :: private_virial(3,3), private_e + real(dp), allocatable :: private_f(:,:), private_local_e(:) + + call system_timer('asap_morse_stretch') + + ! Evaluate potential at cutoff. Will be subtracted from total energy. + elimitij = 0.0_dp + do ti=1,this%n_types + do tj=1,this%n_types + phi = exp(this%gamma_ms(ti,tj)*(1.0_dp - this%cutoff_ms/this%r_ms(ti,tj))) + elimitij(ti,tj) = this%d_ms(ti,tj)*(phi - 2.0_dp*sqrt(phi)) + end do + end do + + !$omp parallel default(none) shared(this, mpi, at, e, local_e, f, virial, elimitij) private(i, j, m, ti, tj, r_ij, u_ij, dms, gammams, rms, exponentms, factorms, phi, de, dforce, i_is_min_image, j_is_min_image, private_virial, private_e, private_f, private_local_e, fc, dfc_dr) + + if (present(e)) private_e = 0.0_dp + if (present(local_e)) then + allocate(private_local_e(at%N)) + private_local_e = 0.0_dp + endif + if (present(f)) then + allocate(private_f(3,at%N)) + private_f = 0.0_dp + endif + if (present(virial)) private_virial = 0.0_dp + + !$omp do schedule(runtime) + do i=1, at%n + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if (allocated(at%connect%is_min_image)) then + i_is_min_image = at%connect%is_min_image(i) + else + i_is_min_image = is_min_image(at, i) + end if + ti = get_type(this%type_of_atomic_num, at%Z(i)) + do m = 1, n_neighbours(at, i) + + j = neighbour(at, i, m, distance=r_ij, cosines=u_ij, max_dist=(this%cutoff_ms*BOHR)) + + if (j <= 0) cycle + if (r_ij .feq. 0.0_dp) cycle + + if (allocated(at%connect%is_min_image)) then + j_is_min_image = at%connect%is_min_image(j) + else + j_is_min_image = is_min_image(at, j) + end if + + if (i < j .and. i_is_min_image .and. j_is_min_image) cycle + + r_ij = r_ij/BOHR + + call smooth_cutoff(r_ij, this%cutoff_ms-this%smoothlength_ms, this%smoothlength_ms, fc, dfc_dr) + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + dms = this%d_ms(ti,tj) + gammams = this%gamma_ms(ti,tj) + rms = this%r_ms(ti, tj) + + exponentms = gammams*(1.0_dp-r_ij/rms) + factorms = gammams/rms + phi = exp(exponentms) + + if (present(e) .or. present(local_e)) then + de = (dms*(phi - 2.0_dp*sqrt(phi)) - elimitij(ti, tj))*fc + + if (present(e)) then + if (i_is_min_image .and. j_is_min_image) then + private_e = private_e + de + else + private_e = private_e + 0.5_dp*de + end if + end if + + if (present(local_e)) then + private_local_e(i) = private_local_e(i) + 0.5_dp*de + if (i_is_min_image .and. j_is_min_image) private_local_e(j) = private_local_e(j) + 0.5_dp*de + end if + end if + + if (present(f) .or. present(virial)) then + dforce = -dms*(factorms*phi - factorms*dsqrt(phi))*fc + (dms*(phi - 2.0_dp*sqrt(phi)) - elimitij(ti, tj))*dfc_dr + + if (present(f)) then + private_f(:,i) = private_f(:,i) + dforce*u_ij + if (i_is_min_image .and. j_is_min_image) private_f(:,j) = private_f(:,j) - dforce*u_ij + end if + if (present(virial)) then + if (i_is_min_image .and. j_is_min_image) then + private_virial = private_virial - dforce*(u_ij .outer. u_ij)*r_ij + else + private_virial = private_virial - 0.5_dp*dforce*(u_ij .outer. u_ij)*r_ij + end if + end if + end if + end do + end do + + if (present(mpi)) then + if (mpi%active) then + if (present(e)) private_e = sum(mpi, private_e) + if (present(local_e)) call sum_in_place(mpi, private_local_e) + if (present(f)) call sum_in_place(mpi, private_f) + if (present(virial)) call sum_in_place(mpi, private_virial) + end if + end if + + !$omp critical + if (present(e)) e = e + private_e*HARTREE + if (present(f)) f = f + private_f*(HARTREE/BOHR) + if (present(local_e)) local_e = local_e + private_local_e*HARTREE + if (present(virial)) virial = virial + private_virial*HARTREE + !$omp end critical + + if (allocated(private_f)) deallocate(private_f) + if (allocated(private_local_e)) deallocate(private_local_e) + + !$omp end parallel + + call system_timer('asap_morse_stretch') + +end subroutine asap_morse_stretch + +subroutine IPModel_TS_setup_atoms(this, at) + type(IPModel_TS), intent(in):: this + type(Atoms), intent(inout) :: at + + logical :: dummy + integer :: i, ti + real(dp), dimension(:), pointer :: charge + + ! If charge property doesn't exist, we add and initialise it now + + if (.not. has_property(at, 'charge')) then + call add_property(at, 'charge', 0.0_dp) + dummy = assign_pointer(at, 'charge', charge) + do i=1, at%N + ti = get_type(this%type_of_atomic_num, at%Z(i)) + charge(i) = this%z(ti) + end do + end if + + if (.not. has_property(at, 'fixdip')) call add_property(at, 'fixdip', .false.) + if (.not. has_property(at, 'efield')) call add_property(at, 'efield', 0.0_dp, n_cols=3) + if (.not. has_property(at, 'dipoles')) call add_property(at, 'dipoles', 0.0_dp, n_cols=3) + if (.not. has_property(at, 'efield_old1')) call add_property(at, 'efield_old1', 0.0_dp, n_cols=3) + if (.not. has_property(at, 'efield_old2')) call add_property(at, 'efield_old2', 0.0_dp, n_cols=3) + if (.not. has_property(at, 'efield_old3')) call add_property(at, 'efield_old3', 0.0_dp, n_cols=3) + + ! Increment at%cutoff if necessary + call set_cutoff_minimum(at, max(this%cutoff_ms, this%cutoff_coulomb)*BOHR) + +end subroutine IPModel_TS_setup_atoms + +subroutine IPModel_TS_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_TS), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional, intent(in) :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + logical :: restart, applied_efield, save_dipole_velo, & + calc_charge, calc_sc_dipoles, calc_dipoles, calc_short_range + real(dp), allocatable, target :: efield_int_old(:,:) + real(dp), allocatable :: efield_charge(:,:), efield_dipole(:,:), dip_sr(:,:) + real(dp), pointer, dimension(:) :: charge + real(dp), pointer, dimension(:,:) :: efield, dipoles, efield_old1, efield_old2, efield_old3, ext_efield, dip_velo + logical, pointer, dimension(:) :: fixdip + real(dp) :: diff, diff_old + integer :: n_efield_old + integer :: i, npol, ti, vv + character(len=STRING_LENGTH) :: efield_name, dipoles_name, atom_mask_name, source_mask_name + logical :: pseudise + real(dp) :: grid_size + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + real, parameter :: difftol = 500.0_dp + + INIT_ERROR(error) + + call system_timer('asap_calc') + vv = current_verbosity() + + if (present(args_str)) then + call initialise(params) + call param_register(params, 'efield', 'efield', efield_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'dipoles', 'dipoles', dipoles_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'save_dipole_velo', 'F', save_dipole_velo, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'restart', 'F', restart, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'applied_efield', 'F', applied_efield, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'calc_charge', 'T', calc_charge, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'calc_sc_dipoles', 'T', calc_sc_dipoles, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'calc_dipoles', 'T', calc_dipoles, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'calc_short_range', 'T', calc_short_range, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'atom_mask_name', '', atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'source_mask_name', '', source_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'pseudise', 'F', pseudise, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'grid_size', '0.0', grid_size, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_TS_Calc args_str')) then + RAISE_ERROR("IPModel_TS_Calc failed to parse args_str="//trim(args_str), error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_TS_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + call finalise(params) + else + efield_name = 'efield' + dipoles_name = 'dipoles' + save_dipole_velo = .false. + restart = .false. + applied_efield = .false. + calc_charge = .true. + calc_sc_dipoles = .true. + calc_short_range = .true. + atom_mask_name = '' + source_mask_name = '' + pseudise = .false. + grid_size = 0.0_dp + r_scale = 1.0_dp + E_scale = 1.0_dp + end if + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_TS_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_TS_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_TS_Calc', error) + local_virial = 0.0_dp + RAISE_ERROR("IPModel_TS_Calc: local_virial calculation requested but not supported yet.", error) + endif + + allocate(efield_charge(3,at%n), efield_dipole(3,at%n)) + + ! Assign pointers + if (.not. assign_pointer(at, efield_name, efield)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "'//trim(efield_name)//'" property', error) + endif + + if (.not. assign_pointer(at, dipoles_name, dipoles)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "'//trim(dipoles_name)//'" property', error) + endif + + if (save_dipole_velo .and. maxval(abs(dipoles)) > 0.0_dp) then + if (.not. assign_pointer(at, 'dip_velo', dip_velo)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer ot "dip_velo" property', error) + endif + do i=1,at%n + dip_velo(:,i) = -dipoles(:,i) + end do + end if + + if (applied_efield) then + if (.not. assign_pointer(at, 'ext_efield', ext_efield)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "ext_efield" property', error) + endif + end if + + if (.not. assign_pointer(at, 'charge', charge)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "charge" property', error) + endif + if (.not. assign_pointer(at, 'fixdip', fixdip)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "fixdip" property', error) + endif + if (.not. assign_pointer(at, 'efield_old1', efield_old1)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "efield_old1" property', error) + endif + if (.not. assign_pointer(at, 'efield_old2', efield_old2)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "efield_old2" property', error) + endif + if (.not. assign_pointer(at, 'efield_old3', efield_old3)) then + RAISE_ERROR('IPModel_TS_calc failed to assign pointer to "efield_old3" property', error) + endif + + if (.not. get_value(at%params, 'n_efield_old', n_efield_old)) n_efield_old = 0 + + if (restart) then + efield_old1(:,:) = 0.0_dp + efield_old2(:,:) = 0.0_dp + efield_old3(:,:) = 0.0_dp + n_efield_old = 0 + end if + + efield_dipole = 0.0_dp + if (calc_sc_dipoles) then + do i=1,at%n + if (.not. fixdip(i)) dipoles(:,i) = 0.0_dp + end do + + ! Extrapolate from the old electric efield + if (this%pred_order == 0 .or. n_efield_old < 2) then + efield_dipole = efield_old1(:,:) + end if + + if (this%pred_order == 1 .and. n_efield_old >= 2) then + efield_dipole = 2.0_dp*efield_old1(:,:) - efield_old2(:,:) + end if + + if (this%pred_order == 2 .and. n_efield_old >= 3) then + efield_dipole = 3.0_dp*efield_old1(:,:) - 3.0_dp*efield_old2(:,:) + efield_old3(:,:) + end if + + if (this%pred_order /= 0) then + if (this%pred_order == 1) then + efield_old2 = efield_old1 + else if (this%pred_order == 2) then + efield_old3 = efield_old2 + efield_old2 = efield_old1 + end if + end if + + call set_value(at%params, 'n_efield_old', min(n_efield_old+1,3)) + end if + + efield_charge = 0.0_dp + if (calc_charge) then + if (maxval(abs(this%z)) > 0.0_dp) then + call yukawa_charges(at, charge, this%cutoff_coulomb*BOHR, this%yukalpha/BOHR, this%yuksmoothlength*BOHR, & + e, local_e, f, virial, efield_charge, mpi, atom_mask_name, source_mask_name, this%type_of_atomic_num, & + pseudise, this%pseudise_sigma*BOHR, grid_size, error=error) + end if + end if + + if (calc_sc_dipoles) then + allocate(dip_sr(3,at%n)) + dip_sr = 0.0_dp + if (this%tdip_sr) call asap_short_range_dipole_moments(this, at, charge, dip_sr, mpi) + + allocate(efield_int_old(3,at%n)) + efield_int_old = 0.0_dp + + if (maxval(abs(this%pol)) > 0.0_dp .and. .not. all(fixdip)) then + + call print('Entering TS Self-consistent dipole loop with '//count(.not. fixdip)//' variable dipole moments', PRINT_VERBOSE) + + ! Self-consistent determination of dipole moments + diff_old = 1.0_dp + npol = 1 + call system_timer('asap_self_consistent_dipoles') + do + ! Mix current and previous total efields + if (npol == 1) then + efield = efield_dipole + efield_charge + else + efield = this%betapol*efield_dipole + & + (1.0_dp - this%betapol)*efield_int_old + efield_charge + end if + + ! Add external field if present + if (applied_efield) then + do i=1,at%n + efield(:,i) = efield(:,i) + ext_efield(:,i) + end do + end if + + ! Calculate dipole moment in response to total efield + do i=1,at%n + if (fixdip(i)) cycle + ti = get_type(this%type_of_atomic_num, at%Z(i)) + if (abs(this%pol(ti)) > 0.0_dp) then + dipoles(:,i) = efield(:,i)*((BOHR**2/HARTREE)*this%pol(ti)) + dip_sr(:,i) + end if + end do + + ! Calculate new efield and measure of convergence + efield_int_old = efield_dipole + efield_dipole = 0.0_dp + call yukawa_dipoles(at, charge, dipoles, this%cutoff_coulomb*BOHR, this%yukalpha/BOHR, this%yuksmoothlength*BOHR, & + (BOHR**2/HARTREE)*this%pol, this%b_pol, this%c_pol, this%type_of_atomic_num, this%tdip_sr, efield=efield_dipole, & + mpi=mpi, error=error) + + diff = 0.0_dp + do i=1,at%n + ti = get_type(this%type_of_atomic_num, at%Z(i)) + diff = diff + (BOHR/HARTREE)**2*((efield_dipole(:,i) - efield_old1(:,i)) .dot. (efield_dipole(:,i) - efield_old1(:,i)))*& + this%pol(ti)*this%pol(ti) + end do + diff = sqrt(diff/at%n) + efield_old1 = efield_dipole + + if (vv >= PRINT_VERBOSE) then + write (line,'("Polarisation iteration : ",i5,3e16.8)') npol, diff_old, diff + call print(line, PRINT_VERBOSE) + end if + + if (diff > difftol) then + call write(at, 'ipmodel_asap_polarisation_divergence.xyz') + RAISE_ERROR('IPModel_TS_calc: Polarisation diverges - diff='//diff, error) + end if + + if (abs(diff - diff_old) < this%tolpol) exit + + diff_old = diff + npol = npol + 1 + if (npol >= this%maxipol) then + call write(at, 'ipmodel_asap_polarisation_not_converged.xyz') + RAISE_ERROR('IPModel_TS_calc: Polarisation not converged in '//this%maxipol//' steps - diff='//diff, error) + endif + + end do + call system_timer('asap_self_consistent_dipoles') + + ! Save final dipole field for next time + efield_old1 = efield_dipole + end if + end if + + efield_dipole = 0.0_dp + if (calc_dipoles) then + ! Compute final energy, local energies, forces, virial and electric efield + if (maxval(abs(dipoles)) > 0.0_dp) then + call yukawa_dipoles(at, charge, dipoles, this%cutoff_coulomb*BOHR, this%yukalpha/BOHR, this%yuksmoothlength*BOHR, & + (BOHR**2/HARTREE)*this%pol, this%b_pol, this%c_pol, this%type_of_atomic_num, this%tdip_sr, & + e, local_e, f, virial, efield_dipole, mpi, atom_mask_name, source_mask_name, pseudise, & + this%pseudise_sigma*BOHR, grid_size, error=error) + + if (save_dipole_velo) then + ! dip_velo = dipoles_{N-1} - dipoles_N (we do not divide by timestep here) + do i=1,at%n + dip_velo(:,i) = dip_velo(:,i) + dipoles(:,i) + end do + end if + end if + end if + + efield(:,1:at%n) = efield_charge + efield_dipole + + ! Finally, add the short-range contribution + if (calc_short_range) then + call asap_morse_stretch(this, at, e, local_e, f, virial, mpi) + end if + + if (allocated(efield_charge)) deallocate(efield_charge) + if (allocated(efield_dipole)) deallocate(efield_dipole) + if (allocated(dip_sr)) deallocate(dip_sr) + if (allocated(efield_int_old)) deallocate(efield_int_old) + + call system_timer('asap_calc') + +end subroutine IPModel_TS_Calc + + +subroutine IPModel_TS_Print(this, file) + type(IPModel_TS), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_TS : TS Potential", file=file) + call Print("IPModel_TS : n_types = " // this%n_types, file=file) + call Print("IPModel_TS : betapol = "//this%betapol//" maxipol = "//this%maxipol//" tolpol = "//this%tolpol//" pred_order = "//this%pred_order, file=file) + call Print("IPModel_TS : yukalpha = "//this%yukalpha//" yuksmoothlength = "//this%yuksmoothlength, file=file) + call Print("IPModel_TS : cutoff_coulomb = "//this%cutoff_coulomb//" cutoff_ms = "//this%cutoff_ms//" smoothlength_ms="//this%smoothlength_ms, file=file) + + do ti=1, this%n_types + call Print ("IPModel_TS : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call Print ("IPModel_TS : pol = "//this%pol(ti), file=file) + call Print ("IPModel_TS : z = "//this%z(ti), file=file) + call Print ("IPModel_TS : pseudise_sigma = "//this%pseudise_sigma(ti), file=file) + call verbosity_push_decrement() + do tj =1,this%n_types + call Print ("IPModel_TS : pair interaction ti tj " // ti // " " // tj // " Zi Zj " // this%atomic_num(ti) //& + " " // this%atomic_num(tj), file=file) + call Print ("IPModel_TS : pair " // this%D_ms(ti,tj) // " " // this%gamma_ms(ti,tj) // " " & + // this%R_ms(ti,tj) // " " // this%B_pol(ti,tj) // " " // this%C_pol(ti, tj), file=file) + + end do + call verbosity_pop() + end do + +end subroutine IPModel_TS_Print + +subroutine IPModel_TS_read_params_xml(this, param_str) + type(IPModel_TS), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + integer :: ti + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_TS_read_params_xml parsed file, but n_types = 0") + endif + + ! pseudise_sigma defaults to covalent radii + do ti=1,this%n_types + if (this%pseudise_sigma(ti) .feq. 0.0_dp) then + this%pseudise_sigma(ti) = ElementCovRad(this%atomic_num(ti))/BOHR + end if + end do + +end subroutine IPModel_TS_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + integer ti, tj, Zi, Zj + + if (name == 'TS_params') then ! new ASAP stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in TS_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + allocate(parse_ip%pol(parse_ip%n_types)) + parse_ip%pol = 0.0_dp + allocate(parse_ip%z(parse_ip%n_types)) + allocate(parse_ip%pseudise_sigma(parse_ip%n_types)) + parse_ip%pseudise_sigma = 0.0_dp + + allocate(parse_ip%D_ms(parse_ip%n_types,parse_ip%n_types)) + parse_ip%D_ms = 0.0_dp + allocate(parse_ip%gamma_ms(parse_ip%n_types,parse_ip%n_types)) + parse_ip%gamma_ms = 0.0_dp + allocate(parse_ip%R_ms(parse_ip%n_types,parse_ip%n_types)) + parse_ip%R_ms = 0.0_dp + allocate(parse_ip%B_pol(parse_ip%n_types,parse_ip%n_types)) + parse_ip%B_pol = 0.0_dp + allocate(parse_ip%C_pol(parse_ip%n_types,parse_ip%n_types)) + parse_ip%C_pol = 0.0_dp + + call QUIP_FoX_get_value(attributes, "cutoff_coulomb", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find cutoff_coulomb") + read (value, *) parse_ip%cutoff_coulomb + + call QUIP_FoX_get_value(attributes, "cutoff_ms", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find cutoff_ms") + read (value, *) parse_ip%cutoff_ms + + parse_ip%smoothlength_ms = 0.0_dp + call QUIP_FoX_get_value(attributes, "smoothlength_ms", value, status) + if (status == 0) read (value, *) parse_ip%smoothlength_ms + + call QUIP_FoX_get_value(attributes, "betapol", value, status) + if (status == 0) read (value, *) parse_ip%betapol + + call QUIP_FoX_get_value(attributes, "maxipol", value, status) + if (status == 0) read (value, *) parse_ip%maxipol + + call QUIP_FoX_get_value(attributes, "tolpol", value, status) + if (status == 0) read (value, *) parse_ip%tolpol + + call QUIP_FoX_get_value(attributes, "pred_order", value, status) + if (status == 0) read (value, *) parse_ip%pred_order + + call QUIP_FoX_get_value(attributes, "yukalpha", value, status) + if (status == 0) read (value, *) parse_ip%yukalpha + + call QUIP_FoX_get_value(attributes, "yuksmoothlength", value, status) + if (status == 0) read (value, *) parse_ip%yuksmoothlength + + parse_ip%tdip_sr = .true. + call QUIP_FoX_get_value(attributes, "tdip_sr", value, status) + if (status == 0) read (value, *) parse_ip%tdip_sr + + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + call QUIP_FoX_get_value(attributes, "pol", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find pol") + read (value, *) parse_ip%pol(ti) + + call QUIP_FoX_get_value(attributes, "z", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find z") + read (value, *) parse_ip%z(ti) + + call QUIP_FoX_get_value(attributes, "pseudise_sigma", value, status) + if (status == 0) then + read (value, *) parse_ip%pseudise_sigma(ti) + end if + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "atnum_i", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_i") + read (value, *) Zi + call QUIP_FoX_get_value(attributes, "atnum_j", value, status) + if (status /= 0) call system_abort ("IPModel_SW_read_params_xml cannot find atnum_j") + read (value, *) Zj + + ti = get_type(parse_ip%type_of_atomic_num,Zi) + tj = get_type(parse_ip%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "D_ms", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find D_ms") + read (value, *) parse_ip%D_ms(ti,tj) + call QUIP_FoX_get_value(attributes, "gamma_ms", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find gamma_ms") + read (value, *) parse_ip%gamma_ms(ti,tj) + call QUIP_FoX_get_value(attributes, "R_ms", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find R_ms") + read (value, *) parse_ip%R_ms(ti,tj) + call QUIP_FoX_get_value(attributes, "B_pol", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find B_pol") + read (value, *) parse_ip%B_pol(ti,tj) + call QUIP_FoX_get_value(attributes, "C_pol", value, status) + if (status /= 0) call system_abort ("IPModel_TS_read_params_xml cannot find C_pol") + read (value, *) parse_ip%C_pol(ti,tj) + + if (ti /= tj) then + parse_ip%D_ms(tj,ti) = parse_ip%D_ms(ti,tj) + parse_ip%gamma_ms(tj,ti) = parse_ip%gamma_ms(ti,tj) + parse_ip%R_ms(tj,ti) = parse_ip%R_ms(ti,tj) + parse_ip%B_pol(tj,ti) = parse_ip%B_pol(ti,tj) + parse_ip%C_pol(tj,ti) = parse_ip%C_pol(ti,tj) + endif + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'TS_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_TS_module diff --git a/src/Potentials/IPModel_Template.F90 b/src/Potentials/IPModel_Template.F90 new file mode 100644 index 0000000000..914ead9042 --- /dev/null +++ b/src/Potentials/IPModel_Template.F90 @@ -0,0 +1,295 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Template +!X +!% Template module for use when implementing a new Interatomic Potential +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Template_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Template +type IPModel_Template + integer :: n_types = 0 + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) + + real(dp) :: cutoff = 0.0_dp + + character(len=STRING_LENGTH) :: label + +end type IPModel_Template + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Template), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Template_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Template_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Template_Print +end interface Print + +interface Calc + module procedure IPModel_Template_Calc +end interface Calc + +contains + +subroutine IPModel_Template_Initialise_str(this, args_str, param_str) + type(IPModel_Template), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Template_Initialise_str args_str')) then + call system_abort("IPModel_Template_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Template_read_params_xml(this, param_str) + + ! Add initialisation code here + +end subroutine IPModel_Template_Initialise_str + +subroutine IPModel_Template_Finalise(this) + type(IPModel_Template), intent(inout) :: this + + ! Add finalisation code here + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Template_Finalise + + +subroutine IPModel_Template_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Template), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + ! Add calc() code here + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Template_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Template_Calc', error) + f = 0.0_dp + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Template_Calc', error) + local_virial = 0.0_dp + endif + + RAISE_ERROR('IPModel_Calc - not implemented',error) + +end subroutine IPModel_Template_Calc + + +subroutine IPModel_Template_Print(this, file) + type(IPModel_Template), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti + + call Print("IPModel_Template : Template Potential", file=file) + call Print("IPModel_Template : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print ("IPModel_Template : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_Template : " // & + "cutoff " // this%cutoff , & + file=file) + call verbosity_pop() + end do + +end subroutine IPModel_Template_Print + +subroutine IPModel_Template_read_params_xml(this, param_str) + type(IPModel_Template), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_ip = .false. + parse_matched_label = .false. + parse_ip => this + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Template_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_Template_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + integer ti + + if (name == 'Template_params') then ! new Template stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, 'n_types', value, status) + if (status == 0) then + read (value, *) parse_ip%n_types + else + call system_abort("Can't find n_types in Template_params") + endif + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + call QUIP_FoX_get_value(attributes, "cutoff", value, status) + if (status /= 0) call system_abort ("IPModel_Template_read_params_xml cannot find cutoff") + read (value, *) parse_ip%cutoff + endif + + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Template_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Template_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Template_params') then + parse_in_ip = .false. + end if + endif + +end subroutine IPModel_endElement_handler + +end module IPModel_Template_module diff --git a/src/Potentials/IPModel_Tersoff.F90 b/src/Potentials/IPModel_Tersoff.F90 new file mode 100644 index 0000000000..09f1c3e03e --- /dev/null +++ b/src/Potentials/IPModel_Tersoff.F90 @@ -0,0 +1,735 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Tersoff module +!X +!% Module for computing energy using the Tersoff potential for C/Si/Ge and alloys +!% (Ref. J. Tersoff, Phys. Rev. B {\bf 39}, 5566 (1989)). +!% The IPModel_Tersoff object contains all the parameters read from a 'Tersoff_params' +!% XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Tersoff_module + +use error_module +use system_module, only : dp, inoutput, print, PRINT_VERBOSE, verbosity_push_decrement, verbosity_pop, operator(//) +use units_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Tersoff +type IPModel_Tersoff + integer :: n_types = 0 !% Number of atomic types + integer, allocatable :: atomic_num(:), type_of_atomic_num(:) !% Atomic number dimensioned as \texttt{n_types} + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connections + + real(dp), allocatable :: A(:), B(:), lambda(:), mu(:), beta(:) !% IP parameters dimensioned as \texttt{n_types} + real(dp), allocatable :: n(:), c(:), d(:), h(:), R(:), S(:) !% IP parameters dimensioned as \texttt{n_types} + real(dp), allocatable :: chi(:,:) !% IP parameter depending on the pair interaction (mixing hentalpy), dimensioned as \texttt{(n_types,n_types)} + + character(len=STRING_LENGTH) :: label + +end type IPModel_Tersoff + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Tersoff), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Tersoff_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Tersoff_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Tersoff_Print +end interface Print + +interface Calc + module procedure IPModel_Tersoff_Calc +end interface Calc + +contains + +subroutine IPModel_Tersoff_Initialise_str(this, args_str, param_str) + type(IPModel_Tersoff), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_Tersoff_Initialise_str args_str')) then + call system_abort("IPModel_Tersoff_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call IPModel_Tersoff_read_params_xml(this, param_str) + +end subroutine IPModel_Tersoff_Initialise_str + +subroutine IPModel_Tersoff_Finalise(this) + type(IPModel_Tersoff), intent(inout) :: this + + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + + if (allocated(this%A)) deallocate(this%A) + if (allocated(this%B)) deallocate(this%B) + if (allocated(this%lambda)) deallocate(this%lambda) + if (allocated(this%mu)) deallocate(this%mu) + if (allocated(this%beta)) deallocate(this%beta) + if (allocated(this%n)) deallocate(this%n) + if (allocated(this%c)) deallocate(this%c) + if (allocated(this%d)) deallocate(this%d) + if (allocated(this%h)) deallocate(this%h) + if (allocated(this%R)) deallocate(this%R) + if (allocated(this%S)) deallocate(this%S) + if (allocated(this%chi)) deallocate(this%chi) + + this%n_types = 0 + this%label = '' +end subroutine IPModel_Tersoff_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator. It computes energy, forces and virial. +!% Derivatives are taken from M. Tang, Ph.D. Thesis, MIT 1995. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +subroutine IPModel_Tersoff_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Tersoff), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp), pointer :: w_e(:) + integer i, ji, j, ki, k + integer ti, tj, tk + real(dp) :: dr_ij(3), dr_ij_mag, dr_ik(3), dr_ik_mag, dr_jk(3), dr_jk_mag + real(dp) :: dr_ij_diff(3), dr_ik_diff(3) + real(dp) :: w_f + + real(dp), allocatable :: z_ij(:) + real(dp) :: AA_ij, BB_ij, lambda_ij, mu_ij, beta_i, n_i, c_i, d_i, h_i, R_ij, S_ij, chi_ij; + real(dp) :: zeta_ij, b_ij, V_ij_R, V_ij_A, f_C_ij; + real(dp) :: R_ik, S_ik, cos_theta_ijk; + real(dp) :: exp_lambda_ij, exp_mu_ij + + real(dp) :: de + + real(dp) :: dr_ij_mag_dr_i(3), dr_ij_mag_dr_j(3) + real(dp) :: dr_ik_mag_dr_i(3), dr_ik_mag_dr_k(3) + real(dp) :: dr_jk_mag_dr_j(3), dr_jk_mag_dr_k(3) + real(dp) :: f_C_ij_d, dV_ij_R_dr_ij_mag + real(dp) :: f_C_ik + + real(dp) :: dcos_theta_ijk_dr_ij_mag, dcos_theta_ijk_dr_ik_mag, dcos_theta_ijk_dr_jk_mag + real(dp) :: dg_dcos_theta_ijk + + real(dp) :: beta_i_db_ij_dz_ij + real(dp) :: dzeta_ij_dr_ij_mag, dzeta_ij_dr_ik_mag, dzeta_ij_dr_jk_mag + real(dp) :: db_ij_dr_ij_mag, db_ij_dr_ik_mag, db_ij_dr_jk_mag + real(dp) :: dV_ij_A_dr_ij_mag, dV_ij_A_dr_ik_mag, dV_ij_A_dr_jk_mag + real(dp) :: virial_i(3,3) + + type(Dictionary) :: params + logical, dimension(:), pointer :: atom_mask_pointer + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + if (present(e)) e = 0.0_dp + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Tersoff_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_Tersoff_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) then + virial = 0.0_dp + endif + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_Tersoff_Calc', error) + local_virial = 0.0_dp + endif + + if (.not. assign_pointer(at, "weight", w_e)) nullify(w_e) + + atom_mask_pointer => null() + if(present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_Tersoff_Calc args_str')) & + call system_abort("IPModel_Tersoff_Calc failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_Tersoff_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + else + atom_mask_pointer => null() + endif + else + do_rescale_r = .false. + do_rescale_E = .false. + endif + + if (do_rescale_r) call print('IPModel_Tersoff_Calc: rescaling distances by factor '//r_scale, PRINT_VERBOSE) + if (do_rescale_E) call print('IPModel_Tersoff_Calc: rescaling energy by factor '//E_scale, PRINT_VERBOSE) + + do i=1, at%N + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if(associated(atom_mask_pointer)) then + if(.not. atom_mask_pointer(i)) cycle + endif + + allocate(z_ij(n_neighbours(at,i))) + ti = get_type(this%type_of_atomic_num, at%Z(i)) + + ! calculate z_ij = beta_i zeta_ij + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dr_ij_mag, cosines = dr_ij) + if (dr_ij_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) dr_ij_mag = dr_ij_mag*r_scale + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + S_ij = sqrt(this%S(ti)*this%S(tj)) + if (dr_ij_mag < S_ij) then + beta_i = this%beta(ti) + R_ij = sqrt(this%R(ti)*this%R(tj)) + c_i = this%c(ti) + d_i = this%d(ti) + h_i = this%h(ti) + else + cycle + endif + + zeta_ij = 0.0_dp + do ki=1, n_neighbours(at, i) + if (ki == ji) cycle + k = neighbour(at, i, ki, dr_ik_mag, cosines = dr_ik) + if (dr_ik_mag .feq. 0.0_dp) cycle + if (do_rescale_r) dr_ik_mag = dr_ik_mag*r_scale + + tk = get_type(this%type_of_atomic_num, at%Z(k)) + + R_ik = sqrt(this%R(ti)*this%R(tk)) + S_ik = sqrt(this%S(ti)*this%S(tk)) + cos_theta_ijk = sum(dr_ij*dr_ik) + zeta_ij = zeta_ij + f_C(dr_ik_mag, R_ik, S_ik)*g(cos_theta_ijk, c_i, d_i, h_i) + end do + z_ij(ji) = beta_i*zeta_ij + end do ! ji (calc z_ij) + + ! calculate energies, forces, etc + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dr_ij_mag, dr_ij_diff, dr_ij) + if (dr_ij_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) then + dr_ij_mag = dr_ij_mag * r_scale + dr_ij_diff = dr_ij_diff * r_scale + end if + + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + S_ij = sqrt(this%S(ti)*this%S(tj)) + if (dr_ij_mag < S_ij) then + n_i = this%n(ti) + R_ij = sqrt(this%R(ti)*this%R(tj)) + AA_ij = sqrt(this%A(ti)*this%A(tj)) + BB_ij = sqrt(this%B(ti)*this%B(tj)) + lambda_ij = 0.5_dp*(this%lambda(ti)+this%lambda(tj)) + mu_ij = 0.5_dp*(this%mu(ti)+this%mu(tj)) + chi_ij = this%chi(ti,tj) + else + cycle + endif + + b_ij = chi_ij*(1.0_dp + z_ij(ji)**n_i)**(-1.0_dp/(2*n_i)) + f_C_ij = f_C(dr_ij_mag, R_ij, S_ij) + exp_lambda_ij = exp(-lambda_ij*dr_ij_mag) + exp_mu_ij = exp(-mu_ij*dr_ij_mag) + V_ij_R = f_C_ij * (AA_ij * exp_lambda_ij) + V_ij_A = f_C_ij * (-b_ij*BB_ij * exp_mu_ij) + + if (associated(w_e)) then + w_f = 0.5_dp*(w_e(i)+w_e(j)) + else + w_f = 1.0_dp + endif + + if (present(e) .or. present(local_e)) then + ! factor of 0.5 because Tersoff definition goes over each pair only once + de = 0.5_dp*(V_ij_R + v_ij_A) + if (present(local_e)) then + local_e(i) = local_e(i) + de + endif + if (present(e)) then + e = e + de*w_f + endif + endif + + if (present(f) .or. present(virial) .or. present(local_virial)) then + dr_ij_mag_dr_i = -dr_ij + dr_ij_mag_dr_j = dr_ij + + f_C_ij_d = f_C_d(dr_ij_mag, R_ij, S_ij) + dV_ij_R_dr_ij_mag = f_C_ij_d*AA_ij*exp_lambda_ij + f_C_ij*AA_ij*(-lambda_ij)*exp_lambda_ij + if (present(f)) then + f(:,i) = f(:,i) - 0.5_dp*w_f * dV_ij_R_dr_ij_mag * dr_ij_mag_dr_i(:) + f(:,j) = f(:,j) - 0.5_dp*w_f * dV_ij_R_dr_ij_mag * dr_ij_mag_dr_j(:) + endif + if (present(virial) .or. present(local_virial)) virial_i = 0.5_dp*w_f * dV_ij_R_dr_ij_mag * (dr_ij .outer. dr_ij) * dr_ij_mag + if (present(virial)) virial = virial - virial_i + if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) + + if (z_ij(ji) .fne. 0.0_dp) then + beta_i_db_ij_dz_ij = beta_i* ( -0.5_dp*chi_ij * & + ( ( 1.0_dp+z_ij(ji)**n_i)**(-(1.0_dp+2.0_dp*n_i)/(2.0_dp*n_i)) ) * & + ( z_ij(ji)**(n_i-1.0_dp) ) ) + else + beta_i_db_ij_dz_ij = -1.0_dp + endif + + do ki=1, n_neighbours(at,i) + if (ki == ji) cycle + k = neighbour(at, i, ki, dr_ik_mag, dr_ik_diff, dr_ik) + if (dr_ik_mag .feq. 0.0_dp) cycle + + if (do_rescale_r) then + dr_ik_mag = dr_ik_mag * r_scale + dr_ik_diff = dr_ik_diff * r_scale + end if + + tk = get_type(this%type_of_atomic_num, at%Z(k)) + + dr_ik_mag_dr_i = -dr_ik + dr_ik_mag_dr_k = dr_ik + + cos_theta_ijk = sum(dr_ij*dr_ik) + + dcos_theta_ijk_dr_ij_mag = 1.0_dp/dr_ik_mag - cos_theta_ijk/dr_ij_mag + dcos_theta_ijk_dr_ik_mag = 1.0_dp/dr_ij_mag - cos_theta_ijk/dr_ik_mag + + dr_jk = dr_ik_diff - dr_ij_diff + dr_jk_mag = sqrt(sum(dr_jk*dr_jk)) + dr_jk = dr_jk/dr_jk_mag + + dr_jk_mag_dr_j = -dr_jk + dr_jk_mag_dr_k = dr_jk + + dcos_theta_ijk_dr_jk_mag = -dr_jk_mag/(dr_ij_mag*dr_ik_mag) + dg_dcos_theta_ijk = dg_dcos_theta(cos_theta_ijk, c_i, d_i, h_i) + + R_ik = sqrt(this%R(ti)*this%R(tk)) + S_ik = sqrt(this%S(ti)*this%S(tk)) + f_C_ik = f_C(dr_ik_mag, R_ik, S_ik) + + dzeta_ij_dr_ij_mag = f_C_ik * dg_dcos_theta_ijk * dcos_theta_ijk_dr_ij_mag + dzeta_ij_dr_jk_mag = f_C_ik * dg_dcos_theta_ijk * dcos_theta_ijk_dr_jk_mag + + dzeta_ij_dr_ik_mag = f_C_ik * dg_dcos_theta_ijk * dcos_theta_ijk_dr_ik_mag + & + f_C_d(dr_ik_mag, R_ik, S_ik) * g(cos_theta_ijk, c_i, d_i, h_i) + + db_ij_dr_ij_mag = beta_i_db_ij_dz_ij*dzeta_ij_dr_ij_mag + db_ij_dr_ik_mag = beta_i_db_ij_dz_ij*dzeta_ij_dr_ik_mag + db_ij_dr_jk_mag = beta_i_db_ij_dz_ij*dzeta_ij_dr_jk_mag + + dV_ij_A_dr_ij_mag = f_C_ij*(-db_ij_dr_ij_mag*BB_ij*exp_mu_ij) + dV_ij_A_dr_ik_mag = f_C_ij*(-db_ij_dr_ik_mag*BB_ij*exp_mu_ij) + dV_ij_A_dr_jk_mag = f_C_ij*(-db_ij_dr_jk_mag*BB_ij*exp_mu_ij) + + if (present(f)) then + f(:,i) = f(:,i) - w_f*( 0.5_dp * dV_ij_A_dr_ik_mag*dr_ik_mag_dr_i(:) + & + 0.5_dp * dV_ij_A_dr_ij_mag*dr_ij_mag_dr_i(:) ) + + f(:,j) = f(:,j) - w_f*( 0.5_dp * dV_ij_A_dr_jk_mag*dr_jk_mag_dr_j(:) + & + 0.5_dp * dV_ij_A_dr_ij_mag*dr_ij_mag_dr_j(:) ) + + f(:,k) = f(:,k) - w_f*( 0.5_dp*dV_ij_A_dr_ik_mag*dr_ik_mag_dr_k(:) + & + 0.5_dp*dV_ij_A_dr_jk_mag*dr_jk_mag_dr_k(:) ) + end if + + if (present(virial) .or. present(local_virial)) virial_i = & + w_f*0.5_dp*( dV_ij_A_dr_ij_mag*(dr_ij .outer. dr_ij)*dr_ij_mag + & + dV_ij_A_dr_ik_mag*(dr_ik .outer. dr_ik)*dr_ik_mag + & + dV_ij_A_dr_jk_mag*(dr_jk .outer. dr_jk)*dr_jk_mag) + + if (present(virial)) virial = virial - virial_i + if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) + + end do ! ki + dV_ij_A_dr_ij_mag = f_C_ij_d*(-b_ij*BB_ij*exp_mu_ij) + & + f_C_ij*(-b_ij*BB_ij*(-mu_ij)*exp_mu_ij) + + if (present(f)) then + f(:,i) = f(:,i) - 0.5_dp*w_f * dV_ij_A_dr_ij_mag * dr_ij_mag_dr_i(:) + f(:,j) = f(:,j) - 0.5_dp*w_f * dV_ij_A_dr_ij_mag * dr_ij_mag_dr_j(:) + endif + if (present(virial)) virial_i = & + 0.5_dp*w_f * dV_ij_A_dr_ij_mag*(dr_ij .outer. dr_ij)*dr_ij_mag + if (present(virial)) virial = virial - virial_i + if (present(local_virial)) local_virial(:,i) = local_virial(:,i) - reshape(virial_i,(/9/)) + + endif ! present(f) + + end do ! ji + deallocate(z_ij) + end do ! i + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(f)) call sum_in_place(mpi, f) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(local_virial)) call sum_in_place(mpi, local_virial) + endif + + if (do_rescale_r) then + if (present(f)) f = f*r_scale + end if + + if (do_rescale_E) then + if (present(e)) e = e*E_scale + if (present(local_e)) local_e = local_e*E_scale + if (present(f)) f = f*E_scale + if (present(virial)) virial=virial*E_scale + if (present(local_virial)) local_virial=local_virial*E_scale + end if + + atom_mask_pointer => null() + +end subroutine IPModel_Tersoff_Calc + +!% Compute the cutoff function. +function f_C(r, RR, SS) + real(dp), intent(in) :: r + real(dp), intent(in) :: RR, SS + real(dp) :: f_C + + if (r <= RR) then + f_C = 1.0_dp + else if (r <= SS) then + f_C = 0.5+0.5*cos(PI*(r-RR)/(SS-RR)) + else + f_C = 0.0_dp + endif +end function f_C + +!% Compute the derivative of the cutoff function. +function f_C_d(r, RR, SS) + real(dp), intent(in) :: r + real(dp), intent(in) :: RR, SS + real(dp) :: f_C_d + + if (r <= RR) then + f_C_d = 0.0_dp + else if (r <= SS) then + f_C_d = -0.5*PI/(SS-RR) * sin(PI*(r-RR)/(SS-RR)) + else + f_C_d = 0.0_dp + endif +end function f_C_d + +!% Compute the angular term g for the bond-order coefficient. +function g(cos_theta, c, d, h) + real(dp), intent(in) :: cos_theta + real(dp), intent(in) :: c, d, h + real(dp) :: g + + g = 1.0 + (c*c)/(d*d) - (c*c)/(d*d+(h-cos_theta)*(h-cos_theta)); +end function g + +!% Compute the derivative of the angular term for the bond-order coefficient. +function dg_dcos_theta(cos_theta, c, d, h) + real(dp), intent(in) :: cos_theta + real(dp), intent(in) :: c, d, h + real(dp) :: dg_dcos_theta + + real(dp) :: t + + t = d*d + (h-cos_theta)*(h-cos_theta); + dg_dcos_theta = (-2.0_dp*c*c*(h-cos_theta))/(t*t) + +end function dg_dcos_theta + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X XML param reader functions +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: value + + integer ti, tj + + if (name == 'Tersoff_params') then ! new Tersoff stanza + + if (parse_in_ip) & + call system_abort("IPModel_startElement_handler entered Tersoff_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if (value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + endif + + if (parse_in_ip) then + if (parse_ip%n_types /= 0) then + call finalise(parse_ip) + endif + + call QUIP_FoX_get_value(attributes, "n_types", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find n_types") + read (value, *) parse_ip%n_types + + allocate(parse_ip%atomic_num(parse_ip%n_types)) + parse_ip%atomic_num = 0 + + allocate(parse_ip%A(parse_ip%n_types)) + allocate(parse_ip%B(parse_ip%n_types)) + allocate(parse_ip%lambda(parse_ip%n_types)) + allocate(parse_ip%mu(parse_ip%n_types)) + allocate(parse_ip%beta(parse_ip%n_types)) + allocate(parse_ip%n(parse_ip%n_types)) + allocate(parse_ip%c(parse_ip%n_types)) + allocate(parse_ip%d(parse_ip%n_types)) + allocate(parse_ip%h(parse_ip%n_types)) + allocate(parse_ip%R(parse_ip%n_types)) + allocate(parse_ip%S(parse_ip%n_types)) + allocate(parse_ip%chi(parse_ip%n_types,parse_ip%n_types)) + + endif + + elseif (parse_in_ip .and. name == 'per_type_data') then + + call QUIP_FoX_get_value(attributes, "type", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find type") + read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find atomic_num") + read (value, *) parse_ip%atomic_num(ti) + + call QUIP_FoX_get_value(attributes, "A", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find A") + read (value, *) parse_ip%A(ti) + call QUIP_FoX_get_value(attributes, "B", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find B") + read (value, *) parse_ip%B(ti) + call QUIP_FoX_get_value(attributes, "lambda", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find lambda") + read (value, *) parse_ip%lambda(ti) + call QUIP_FoX_get_value(attributes, "mu", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find mu") + read (value, *) parse_ip%mu(ti) + call QUIP_FoX_get_value(attributes, "beta", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find beta") + read (value, *) parse_ip%beta(ti) + call QUIP_FoX_get_value(attributes, "n", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find n") + read (value, *) parse_ip%n(ti) + call QUIP_FoX_get_value(attributes, "c", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find c") + read (value, *) parse_ip%c(ti) + call QUIP_FoX_get_value(attributes, "d", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find d") + read (value, *) parse_ip%d(ti) + call QUIP_FoX_get_value(attributes, "h", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find h") + read (value, *) parse_ip%h(ti) + call QUIP_FoX_get_value(attributes, "R", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find R") + read (value, *) parse_ip%R(ti) + call QUIP_FoX_get_value(attributes, "S", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find S") + read (value, *) parse_ip%S(ti) + + parse_ip%cutoff = maxval(parse_ip%S) + + if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num) + allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num))) + parse_ip%type_of_atomic_num = 0 + do ti=1, parse_ip%n_types + if (parse_ip%atomic_num(ti) > 0) & + parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti + end do + + elseif (parse_in_ip .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "type1", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find type1") + read (value, *) ti + call QUIP_FoX_get_value(attributes, "type2", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find type2") + read (value, *) tj + + call QUIP_FoX_get_value(attributes, "chi", value, status) + if (status /= 0) call system_abort ("IPModel_Tersoff_read_params_xml cannot find chi") + read (value, *) parse_ip%chi(ti,tj) + if (ti /= tj) then + parse_ip%chi(tj,ti) = parse_ip%chi(ti,tj) + endif + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if (name == 'Tersoff_params') then + parse_in_ip = .false. + endif + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_Tersoff_read_params_xml(this, param_str) + type(IPModel_Tersoff), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type (xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_ip => this + parse_in_ip = .false. + parse_matched_label = .false. + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types == 0) then + call system_abort("IPModel_Tersoff_read_params_xml parsed file, but n_types = 0") + endif + +end subroutine IPModel_Tersoff_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of Tersoff parameters: number of different types, cutoff radius, atomic numbers, ect. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_Tersoff_Print (this, file) + type(IPModel_Tersoff), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer :: ti, tj + + call Print("IPModel_Tersoff : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file) + + do ti=1, this%n_types + call Print("IPModel_Tersoff : type " // ti // " atomic_num " // this%atomic_num(ti), file=file) + call verbosity_push_decrement() + call Print ("IPModel_Tersoff : params A "//this%A(ti) //" B "// this%B(ti)//" lambda "// this%lambda(ti)//" mu "// & + this%mu(ti)// " beta " // this%beta(ti), file=file) + call Print ("IPModel_Tersoff : params n "// this%n(ti)//" c "// this%c(ti)//" d "// this%d(ti)//" h "// this%h(ti) & + // " R "// this%R(ti)//" S " // this%S(ti), file=file) + do tj=1, this%n_types + call Print ("IPModel_tersoff : pair "// ti // " " // tj // " chi " // this%chi(ti,tj), file=file) + end do + call verbosity_pop() + end do + +end subroutine IPModel_Tersoff_Print + +end module IPModel_Tersoff_module diff --git a/src/Potentials/IPModel_Tether.F90 b/src/Potentials/IPModel_Tether.F90 new file mode 100644 index 0000000000..9128d45288 --- /dev/null +++ b/src/Potentials/IPModel_Tether.F90 @@ -0,0 +1,197 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_Tether +!X +!% Tether a selection of atoms to the origin with a spring: +!% +!% Energy and Force routines are hardwired +!% Cutoff is hardwired +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_Tether_module + +use error_module +use system_module, only : dp, inoutput, print, operator(//), split_string,string_to_int +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_Tether +type IPModel_Tether + real(dp) :: cutoff = 0.0_dp + real(dp) :: r0 = 0.0_dp + real(dp) :: kconf = 0.0_dp + integer,allocatable,dimension(:) :: tether_indices +end type IPModel_Tether + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_Tether), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_Tether_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_Tether_Finalise +end interface Finalise + +interface Print + module procedure IPModel_Tether_Print +end interface Print + +interface Calc + module procedure IPModel_Tether_Calc +end interface Calc + +contains + +subroutine IPModel_Tether_Initialise_str(this, args_str, param_str, error) + type(IPModel_Tether), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out):: error + character(len=STRING_LENGTH) :: indices_string + character(len=STRING_LENGTH), dimension(99) :: indices_fields + integer:: i,n_tethered + + INIT_ERROR(error) + call Finalise(this) + + call initialise(params) + call param_register(params, 'kconf', '0.0', this%kconf, help_string='strength of quadratic confinement potential on atoms. potential is kconf*(r - r0)^2') + call param_register(params, 'r0', '0.0', this%r0, help_string='distance at which quadratic confinement potential on atoms begins. potential is kconf*(r - r0)^2') + call param_register(params, 'indices', PARAM_MANDATORY, indices_string, help_string="Indices (1-based) of the atoms you wish to tether, format {i1 i2 i3 ...}") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_Tether_Initialise args_str')) then + RAISE_ERROR("IPModel_Tether_Init failed to parse args_str='"//trim(args_str)//"'", error) + end if + call finalise(params) + + call split_string(indices_string,' ','{}',indices_fields(:),n_tethered,matching=.true.) + allocate(this%tether_indices(n_tethered)) + + do i=1,n_tethered + this%tether_indices(i) = string_to_int(indices_fields(i)) + end do + + +end subroutine IPModel_Tether_Initialise_str + +subroutine IPModel_Tether_Finalise(this) + type(IPModel_Tether), intent(inout) :: this + + ! Add finalisation code here + +end subroutine IPModel_Tether_Finalise + + +subroutine IPModel_Tether_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_Tether), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + + real(dp) :: energy, force(3,at%N), r, disp, dr(3), origin(3)=0.0_dp + integer :: i , n_tethered, i_teth + + n_tethered=size(this%tether_indices) + + INIT_ERROR(error) + + ! Harmonic confining potential on tethered atoms + energy = 0.0_dp + force = 0.0_dp + do i=1,n_tethered + i_teth = this%tether_indices(i) + + r = distance_min_image(at, i_teth , origin) + + if(r .fgt. this%r0) then + disp = r - this%r0 + ! energy + energy = energy + this%kConf*disp**2 + ! force + dr = diff_min_image(at, i_teth, origin)/r + force(:,i_teth) = ( 2.0_dp*this%kConf*disp ) * dr + end if + end do + + if (present(e)) e = energy + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_Tether_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_Tether_Calc', error) + f = force + end if + if (present(virial)) virial = 0.0_dp + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_Tether_Calc', error) + local_virial = 0.0_dp + endif + +end subroutine IPModel_Tether_Calc + + +subroutine IPModel_Tether_Print(this, file) + type(IPModel_Tether), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_Tether : Tether Potential", file=file) + call Print("IPModel_Tether : cutoff = " // this%cutoff, file=file) + call Print("IPModel_Tether : kconf = " // this%kconf, file=file) + call Print("IPModel_Tether : tethered atoms = " // this%tether_indices, file=file) + +end subroutine IPModel_Tether_Print + + +end module IPModel_Tether_module diff --git a/src/Potentials/IPModel_WaterDimer_Gillan.F90 b/src/Potentials/IPModel_WaterDimer_Gillan.F90 new file mode 100644 index 0000000000..fdae127062 --- /dev/null +++ b/src/Potentials/IPModel_WaterDimer_Gillan.F90 @@ -0,0 +1,1027 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_WaterDimer_Gillan +!X +!% Interaction of two water molecules, parametrised by Mike Gillan in 2011 +!% +!% only expected to be accurate at long range ($> 5 \AA$). Parameters are +!% fitted to MP2 AVTZ energies +!% +!% Energy only +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_WaterDimer_Gillan_module + +use error_module +use system_module, only : dp, inoutput, print, operator(//) +use units_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use spline_module +use quaternions_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_WaterDimer_Gillan +type IPModel_WaterDimer_Gillan + real(dp) :: cutoff = 0.0_dp + character(len=STRING_LENGTH) :: fname_d, fname_q + real(dp) :: two_body_weight_roo = 0.0_dp + real(dp) :: two_body_weight_delta = 0.0_dp + logical :: do_two_body_weight = .false. + type(Spline) :: two_body_weight +end type IPModel_WaterDimer_Gillan + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_WaterDimer_Gillan), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_WaterDimer_Gillan_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_WaterDimer_Gillan_Finalise +end interface Finalise + +interface Print + module procedure IPModel_WaterDimer_Gillan_Print +end interface Print + +interface Calc + module procedure IPModel_WaterDimer_Gillan_Calc +end interface Calc + + +! module-gobal variables + +integer, parameter :: ngrid_mx=20 +integer :: lin3d_2_igotdata, lin3d_2_itab_print, lin3d_2_nxsup, lin3d_2_nysup, lin3d_2_nzsup +real(dp) :: lin3d_2_xinf, lin3d_2_xsup, lin3d_2_yinf, lin3d_2_ysup, lin3d_2_zinf, lin3d_2_zsup +real(dp) :: lin3d_2_deltax, lin3d_2_deltay, lin3d_2_deltaz +real(dp) :: lin3d_2_f1tab(ngrid_mx, ngrid_mx, ngrid_mx), lin3d_2_f2tab(ngrid_mx, ngrid_mx, ngrid_mx) +integer :: lin3d_3_igotdata, lin3d_3_itab_print, lin3d_3_nxsup, lin3d_3_nysup, lin3d_3_nzsup +real(dp) :: lin3d_3_xinf, lin3d_3_xsup, lin3d_3_yinf, lin3d_3_ysup, lin3d_3_zinf, lin3d_3_zsup +real(dp) :: lin3d_3_deltax, lin3d_3_deltay, lin3d_3_deltaz +real(dp) :: lin3d_3_f1tab(ngrid_mx, ngrid_mx, ngrid_mx), lin3d_3_f2tab(ngrid_mx, ngrid_mx, ngrid_mx), lin3d_3_f3tab(ngrid_mx, ngrid_mx, ngrid_mx) +contains + +subroutine IPModel_WaterDimer_Gillan_Initialise_str(this, args_str, param_str, error) + type(IPModel_WaterDimer_Gillan), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out) :: error + integer:: init3d + real(dp) :: theta, r1, r2, f1, f2, f3 + + INIT_ERROR(error) + + call Finalise(this) + + + call initialise(params) + call param_register(params, 'dipole_file', PARAM_MANDATORY, this%fname_d, help_string="name of file which contains the dipole tables") + call param_register(params, 'quadrupole_file', PARAM_MANDATORY, this%fname_q, help_string="name of file which contains the quadrupole tables") + call param_register(params, 'two_body_weight_roo', '0.0', this%two_body_weight_roo, has_value_target=this%do_two_body_weight, help_string="if set, apply weight function to 2-body energy and force based on O-O distance. For a positive two_body_weight_delta, weight is 1 for rOO < two_body_weight_roo-two_body_weight_delta and weight is 0 for rOO > two_body_weight_roo+two_body_weight_delta") + call param_register(params, 'two_body_weight_delta', '0.25', this%two_body_weight_delta, help_string="width of weighting function for two_body energy and force based on O-O distance. For weighting to take effect, two_body_weight_roo needs to be explicitly set. For a positive two_body_weight_delta, weight is 1 for rOO < two_body_weight_roo-two_body_weight_delta and weight is 0 for rOO > two_body_weight_roo+two_body_weight_delta") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_WaterDimer_Gillan_Initialise args_str')) then + RAISE_ERROR("IPModel_WaterDimer_Gillan_Init failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + + if(this%do_two_body_weight) then + call initialise(this%two_body_weight, (/this%two_body_weight_roo - this%two_body_weight_delta, this%two_body_weight_roo + this%two_body_weight_delta/), (/1.0_dp, 0.0_dp/), 0.0_dp, 0.0_dp) + end if + + ! read interpolation tables + init3d = 0 + + + call lin3d_2(init3d,theta,r1,r2,f1,f2, this%fname_d) + call lin3d_3(init3d,theta,r1,r2,f1,f2,f3,this%fname_q) + + +end subroutine IPModel_WaterDimer_Gillan_Initialise_str + + +subroutine IPModel_WaterDimer_Gillan_Finalise(this) + type(IPModel_WaterDimer_Gillan), intent(inout) :: this + + ! Add finalisation code here + + call finalise(this%two_body_weight) + +end subroutine IPModel_WaterDimer_Gillan_Finalise + + +subroutine IPModel_WaterDimer_Gillan_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_WaterDimer_Gillan), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + real(dp) :: dip_frac, pol_o, pol_h, c6oo, c6oh, c6hh + real(dp) :: atpos(2,3,3), axis(3) + real(dp) :: e_dqtot, e_ind, e_disp, elong_tot + integer :: nmolec, init3d + type(Quaternion) :: quat + + real(dp):: weight, dweight(3), rOiOj + + INIT_ERROR(error) + + ! Parameters + + dip_frac = 0.4_dp + pol_o = 7.0_dp + pol_h = 2.0_dp + c6oo = 25.0_dp + c6oh = 4.5_dp + c6hh = 2.0_dp + nmolec = 2 + + ! Rotate atoms so that rOO is along the z axis and O1 is at the origin + + !get rotation axis + axis = (at%pos(:,4)-at%pos(:,1)) .cross. (/0.0_dp,0.0_dp,1.0_dp/) + atpos(1,1,:) = at%pos(:,1)-at%pos(:,1) + atpos(1,2,:) = at%pos(:,2)-at%pos(:,1) + atpos(1,3,:) = at%pos(:,3)-at%pos(:,1) + atpos(2,1,:) = at%pos(:,4)-at%pos(:,1) + atpos(2,2,:) = at%pos(:,5)-at%pos(:,1) + atpos(2,3,:) = at%pos(:,6)-at%pos(:,1) + + if(axis .fne. (/0.0_dp,0.0_dp,0.0_dp/)) then + quat = orientation(at%pos(:,4)-at%pos(:,1), axis, (/0.0_dp,0.0_dp,1.0_dp/), axis) + + call rotate(atpos(1,1,:), quat) + call rotate(atpos(1,2,:), quat) + call rotate(atpos(1,3,:), quat) + call rotate(atpos(2,1,:), quat) + call rotate(atpos(2,2,:), quat) + call rotate(atpos(2,3,:), quat) + end if + + ! make that call + call h2o_dimer_far(dip_frac,pol_o,pol_h,c6oo,c6oh,c6hh,atpos,e_dqtot,e_ind,e_disp,elong_tot) + + if(this%do_two_body_weight) then + rOiOj = norm(diff_min_image(at, 1, 4)) + weight = spline_value(this%two_body_weight, rOiOj) + dweight = spline_deriv(this%two_body_weight, rOiOj) + else + weight = 1.0_dp + dweight = 0.0_dp + end if + + if (present(e)) e = elong_tot*HARTREE*weight + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_WaterDimer_Gillan_Calc', error) + local_e = 0.0_dp + endif + if (present(f)) then + f = 0.0_dp + !RAISE_ERROR('Forces not implemented', error) + end if + if (present(virial)) then + RAISE_ERROR('Virial not implemented', error) + else + virial = 0.0_dp + end if + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_WaterDimer_Gillan_Calc', error) + local_virial = 0.0_dp + endif + + +end subroutine IPModel_WaterDimer_Gillan_Calc + + +subroutine IPModel_WaterDimer_Gillan_Print(this, file) + type(IPModel_WaterDimer_Gillan), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_WaterDimer_Gillan : WaterDimer_Gillan Potential", file=file) + call Print("IPModel_WaterDimer_Gillan : cutoff = " // this%cutoff, file=file) + if(this%do_two_body_weight) then + call print("Two-body term is weighted with parameters x0="//this%two_body_weight_roo//" delta="//this%two_body_weight_delta, file=file) + end if + +end subroutine IPModel_WaterDimer_Gillan_Print + +! ===================================================================== +! sbrt computes long-range 2-body energy of H2O dimer, using simple +! distributed multipole model plus simple models for induction +! and dispersion. +! --------------------------------------------------------------------- + subroutine h2o_dimer_far(dip_frac,pol_o,pol_h,c6oo,c6oh,c6hh,atpos,e_dqtot,e_ind,e_disp,elong_tot) + implicit none +! ... variables in argument list + real(dp):: dip_frac, pol_o, pol_h, c6oo, c6oh, c6hh + real(dp):: atpos(2,3,3) + real(dp):: e_dqtot, e_ind, e_disp, elong_tot +! ... local variables + real*8 pi, bohr + parameter (pi = 3.14159265359, bohr = 0.52917720859) + integer init3d + integer mo, na, ns, i, j, k, m + real*8 f1, f2, f3 + real*8 r1, r2, theta, theta_deg, r1sq, r2sq, scprod + real*8 sinfun, cosfun, tanfun, cotfun + real*8 mux, muz, qxx, qzz, qxz, rmu_scal + real*8 xmagsq, zmagsq, xnorm, znorm + real*8 bvec_0(2,3), bvec_bohr_0(2,3), bvec_r(2,2,3) + real*8 rlocvec(3,3) + real*8 univec(2,3) + real*8 dipvec_0(3) + real*8 quadten_0(9), quadten_d(9) + real*8 ddvec_0(3,3) + real*8 ddvec_r(2,3,3) + real*8 quadten_r(2,9) + real*8 dv1o(3), dv1h1(3), dv1h2(3), dv2o(3), dv2h1(3),dv2h2(3) + real*8 qt1(9) ,qt2(9), sepoo(3) + real*8 rroo(3), rroh1(3), rroh2(3), rrh1o(3), rrh1h1(3), rrh1h2(3), rrh2o(3), rrh2h1(3), rrh2h2(3) + real*8 dd_int_oo, dd_int_oh1, dd_int_oh2, dd_int_h1o, dd_int_h1h1, dd_int_h1h2, dd_int_h2o, dd_int_h2h1, dd_int_h2h2, dd_int + real*8 dq_int_oo, dq_int_h1o, dq_int_h2o, dq_int + real*8 qd_int_oo, qd_int_oh1, qd_int_oh2, qd_int, qq_int + real*8 e_ind_1o, e_ind_1h1, e_ind_1h2, e_ind_2o, e_ind_2h1, e_ind_2h2 + real*8 d6oo, d6oh1, d6oh2, d6h1o, d6h1h1, d6h1h2, d6h2o, d6h2h1, d6h2h2 + real*8 evec1(3), evec2(3), evec3(3), evec4(3), evect(3) + character(len=STRING_LENGTH) fname +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! begin loop over monomers +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + do mo = 1, 2 +! ... make the two bond vectors bvec_r drawn from O to H1 and O to H2 +! ... for present monomer +! write(*,111) +! 111 format(/'bond lengths r1, r2 and bond angle theta ', +! * 'for monomers:') +! write(*,112) mo +! 112 format('monomer no:',i5) + r1sq = 0.d0 + r2sq = 0.d0 + scprod = 0.d0 + do i = 1, 3 + bvec_r(mo,1,i) = atpos(mo,2,i) - atpos(mo,1,i) + r1sq = r1sq + bvec_r(mo,1,i)*bvec_r(mo,1,i) + bvec_r(mo,2,i) = atpos(mo,3,i) - atpos(mo,1,i) + r2sq = r2sq + bvec_r(mo,2,i)*bvec_r(mo,2,i) + scprod = scprod + bvec_r(mo,1,i)*bvec_r(mo,2,i) + enddo + r1 = sqrt(r1sq) + r2 = sqrt(r2sq) + theta = acos(scprod/(r1*r2)) + theta_deg = (180.d0/pi)*theta +! write(*,113) r1 +! 113 format('bond length O-H1:',f15.6,' angstrom') +! write(*,114) r2 +! 114 format('bond length O-H2:',f15.6,' angstrom') +! write(*,115) theta_deg +! 115 format('bond angle H-O-H:',f15.6,' degrees') +! ... unit vectors along local x, y and z axes + do i = 1, 3 + univec(1,i) = bvec_r(mo,1,i)/r1 + univec(2,i) = bvec_r(mo,2,i)/r2 + enddo + xmagsq = 0.d0 + zmagsq = 0.d0 + do i = 1, 3 + rlocvec(1,i) = univec(1,i) - univec(2,i) + xmagsq = xmagsq + rlocvec(1,i)*rlocvec(1,i) + rlocvec(3,i) = univec(1,i) + univec(2,i) + zmagsq = zmagsq + rlocvec(3,i)*rlocvec(3,i) + enddo + xnorm = sqrt(xmagsq) + znorm = sqrt(zmagsq) + do i = 1, 3 + rlocvec(1,i) = rlocvec(1,i)/xnorm + rlocvec(3,i) = rlocvec(3,i)/znorm + enddo + rlocvec(2,1) = rlocvec(3,2)*rlocvec(1,3) - rlocvec(3,3)*rlocvec(1,2) + rlocvec(2,2) = rlocvec(3,3)*rlocvec(1,1) - rlocvec(3,1)*rlocvec(1,3) + rlocvec(2,3) = rlocvec(3,1)*rlocvec(1,2) - rlocvec(3,2)*rlocvec(1,1) +! write(*,121) +! 121 format(/'local x, y and z unit vectors:') +! do ns = 1, 3 +! write(*,122) (rlocvec(ns,i), i = 1, 3) +! 122 format(3x,3f12.6) +! enddo +! ... bond vectors in local frame + sinfun = sin(0.5d0*theta) + cosfun = cos(0.5d0*theta) + tanfun = sinfun/cosfun + cotfun = cosfun/sinfun + bvec_0(1,1) = r1*sinfun + bvec_0(1,2) = 0.d0 + bvec_0(1,3) = r1*cosfun + bvec_0(2,1) = -r2*sinfun + bvec_0(2,2) = 0.d0 + bvec_0(2,3) = r2*cosfun + do ns = 1, 2 + do i = 1, 3 + bvec_bohr_0(ns,i) = bvec_0(ns,i)/bohr + enddo + enddo +! ... for present monomer, compute components of +! ... dipole vector and quadrupole tensor in local frame. +! ... Local frame is defined thus: +! ... z-axis is along bisector of H-O-H angle, with bond vectors drawn +! ... from O to H having positive z-components +! ... x-axis is in molecular plane and is perpendicular to z-axis, +! ... with bond vector drawn from O to H1 having positive x-component +! ... bond vector from O to H2 having negative x-component. +! ... y-axis is perpendicular to x- and z-axes, in direction such that +! ... x-, y- and z-axes form a normal right-handed set. +! ... dipole vector + init3d = 1 + fname=repeat(' ',20) + call lin3d_2(init3d,theta_deg,r1,r2,mux,muz,fname) + dipvec_0(1) = mux + dipvec_0(2) = 0.d0 + dipvec_0(3) = muz +! write(*,131) +! 131 format('x-, y- and z-components of dipole vector:') +! write(*,132) (dipvec_0(i), i = 1, 3) +! 132 format(3x,3f15.6) +! ... compute components of quadrupole tensor + init3d = 1 + fname=repeat(' ',20) + call lin3d_3(init3d,theta_deg,r1,r2,qxx,qzz,qxz,fname) + quadten_0(1) = qxx + quadten_0(2) = 0.d0 + quadten_0(3) = qxz + quadten_0(4) = 0.d0 + quadten_0(5) = -qxx - qzz + quadten_0(6) = 0.d0 + quadten_0(7) = qxz + quadten_0(8) = 0.d0 + quadten_0(9) = qzz +! write(*,141) +! 141 format('xx, xy, xz, yx, yy, yz, zx, zy, zz components of ', +! * 'quadrupole tensor:') +! do i = 1, 3 +! write(*,142) (quadten_0(3*(i-1)+j), j = 1, 3) +! 142 format(3x,3f15.6) +! enddo +! ... distribute dipole vector between O and H atoms + ddvec_0(1,1) = (1.d0 - dip_frac)*dipvec_0(1) + ddvec_0(1,2) = 0.d0 + ddvec_0(1,3) = (1.d0 - dip_frac)*dipvec_0(3) + ddvec_0(2,1) = 0.5d0*dip_frac*(dipvec_0(1) + tanfun*dipvec_0(3)) + ddvec_0(2,2) = 0.d0 + ddvec_0(2,3) = 0.5d0*dip_frac*(cotfun*dipvec_0(1) + dipvec_0(3)) + ddvec_0(3,1) = 0.5d0*dip_frac*(dipvec_0(1) - tanfun*dipvec_0(3)) + ddvec_0(3,2) = 0.d0 + ddvec_0(3,3) = 0.5d0*dip_frac*(-cotfun*dipvec_0(1) + dipvec_0(3)) +! write(*,151) +! 151 format('components of dipole vectors on O, H1 and H2: ') +! do i = 1, 3 +! write(*,152) (ddvec_0(i,j), j = 1, 3) +! 152 format(3x,3f15.6) +! enddo +! ... adjust quadrupole tensor to compensate for distributed dipole + do ns = 1, 2 + rmu_scal = 0.d0 + do i = 1, 3 + rmu_scal = rmu_scal + bvec_bohr_0(ns,i)*ddvec_0(ns+1,i) + enddo + do i = 1, 3 + k = 3*(i-1) + i + quadten_0(k) = quadten_0(k) + rmu_scal + enddo + do i = 1, 3 + do j = 1, 3 + k = 3*(i-1) + j + quadten_0(k) = quadten_0(k) - 1.5d0*(bvec_bohr_0(ns,i)*ddvec_0(ns+1,j) + ddvec_0(ns+1,i)*bvec_bohr_0(ns,j)) + enddo + enddo + enddo +! write(*,161) +! 161 format('quad tensor adj to compensate for distrib dip: ') +! do i = 1, 3 +! write(*,162) (quadten_0(3*(i-1)+j), j = 1, 3) +! 162 format(3x,3f15.6) +! enddo +! ... distributed dipole vectors in lab frame + do ns = 1, 3 + do i = 1, 3 + ddvec_r(mo,ns,i) = 0.d0 + do k = 1, 3 + ddvec_r(mo,ns,i) = ddvec_r(mo,ns,i) + ddvec_0(ns,k)*rlocvec(k,i) + enddo + enddo + enddo +! write(*,171) +! 171 format(/'distributed dipole vectors in lab frame:') +! do ns = 1, 3 +! write(*,172) (ddvec_r(mo,ns,i), i = 1, 3) +! 172 format(3x,3f15.6) +! enddo +! ... quadrupole tensor in lab frame + do i = 1, 3 + do j = 1, 3 + m = 3*(i-1) + j + quadten_d(m) = 0.d0 + do k = 1, 3 + ns = 3*(i-1) + k + quadten_d(m) = quadten_d(m) + quadten_0(ns)*rlocvec(k,j) + enddo + enddo + enddo + do i = 1, 3 + do j = 1, 3 + m = 3*(i-1) + j + quadten_r(mo,m) = 0.d0 + do k = 1, 3 + ns = 3*(k-1) + j + quadten_r(mo,m) = quadten_r(mo,m) + rlocvec(k,i)*quadten_d(ns) + enddo + enddo + enddo +! write(*,181) +! 181 format(/'quadrupole tensor in lab frame:') +! do i = 1, 3 +! write(*,182) (quadten_r(mo,3*(i-1)+j), j = 1, 3) +! 182 format(3x,3f15.6) +! enddo + enddo +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +! end loop over monomers +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +! +! ... calculate 1st-order electrostatic interactions ......... +! write(*,211) +! 211 format(/75('-')) +! write(*,212) +! 212 format(/'d-d, d-q, q-d and q-q interactions: (a.u.)') +! ... temp arrays for distributed dipoles and quadrupoles + do i = 1, 3 + dv1o(i) = ddvec_r(1,1,i) + dv1h1(i) = ddvec_r(1,2,i) + dv1h2(i) = ddvec_r(1,3,i) + dv2o(i) = ddvec_r(2,1,i) + dv2h1(i) = ddvec_r(2,2,i) + dv2h2(i) = ddvec_r(2,3,i) + enddo + do k = 1, 9 + qt1(k) = quadten_r(1,k) + qt2(k) = quadten_r(2,k) + enddo +! ... vector posn of O in 2nd monomer relative to O in 1st monomer + do i = 1, 3 + sepoo(i) = atpos(2,1,i) - atpos(1,1,i) + enddo +! ... make interatomic separation vectors + do i = 1, 3 + rroo(i) = sepoo(i)/bohr + rroh1(i) = (bvec_r(2,1,i) + sepoo(i))/bohr + rroh2(i) = (bvec_r(2,2,i) + sepoo(i))/bohr + rrh1o(i) = (-bvec_r(1,1,i) + sepoo(i))/bohr + rrh1h1(i) = (bvec_r(2,1,i) - bvec_r(1,1,i) + sepoo(i))/bohr + rrh1h2(i) = (bvec_r(2,2,i) - bvec_r(1,1,i) + sepoo(i))/bohr + rrh2o(i) = (-bvec_r(1,2,i) + sepoo(i))/bohr + rrh2h1(i) = (bvec_r(2,1,i) - bvec_r(1,2,i) + sepoo(i))/bohr + rrh2h2(i) = (bvec_r(2,2,i) - bvec_r(1,2,i) + sepoo(i))/bohr + enddo +! ... dipole-dipole interactions + call dip_dip(dv1o,dv2o,rroo,dd_int_oo) + call dip_dip(dv1o,dv2h1,rroh1,dd_int_oh1) + call dip_dip(dv1o,dv2h2,rroh2,dd_int_oh2) + call dip_dip(dv1h1,dv2o,rrh1o,dd_int_h1o) + call dip_dip(dv1h1,dv2h1,rrh1h1,dd_int_h1h1) + call dip_dip(dv1h1,dv2h2,rrh1h2,dd_int_h1h2) + call dip_dip(dv1h2,dv2o,rrh2o,dd_int_h2o) + call dip_dip(dv1h2,dv2h1,rrh2h1,dd_int_h2h1) + call dip_dip(dv1h2,dv2h2,rrh2h2,dd_int_h2h2) + dd_int = dd_int_oo + dd_int_oh1 + dd_int_oh2 + dd_int_h1o + dd_int_h1h1 + dd_int_h1h2 + dd_int_h2o + dd_int_h2h1 + dd_int_h2h2 +! ... dipole-quadrupole interactions + call dip_quad(dv1o,qt2,rroo,dq_int_oo) + call dip_quad(dv1h1,qt2,rrh1o,dq_int_h1o) + call dip_quad(dv1h2,qt2,rrh2o,dq_int_h2o) + dq_int = dq_int_oo + dq_int_h1o + dq_int_h2o +! ... quadrupole-dipole interactions + call quad_dip(qt1,dv2o,rroo,qd_int_oo) + call quad_dip(qt1,dv2h1,rroh1,qd_int_oh1) + call quad_dip(qt1,dv2h2,rroh2,qd_int_oh2) + qd_int = qd_int_oo + qd_int_oh1 + qd_int_oh2 +! ... quadrupole-quadrupole interaction + call quad_quad(qt1,qt2,rroo,qq_int) +! write(*,221) dd_int, dq_int, qd_int, qq_int +! 221 format(3x,4e15.6) + e_dqtot = dd_int + dq_int + qd_int + qq_int +! --- induction energy ------------------------------------------------ +! ... pol of mono2/O from dip and quad on mono1 + call dip_field(rroo,dv1o,evec1) + call dip_field(rrh1o,dv1h1,evec2) + call dip_field(rrh2o,dv1h2,evec3) + call quad_field(rroo,qt1,evec4) + do i = 1, 3 + evect(i) = evec1(i) + evec2(i) + evec3(i) + evec4(i) + enddo + e_ind_2o = -0.5d0*pol_o*(evect(1)**2 + evect(2)**2 + evect(3)**2) +! ... pol of mono2/H1 from dip and quad on mono1 + call dip_field(rroh1,dv1o,evec1) + call dip_field(rrh1h1,dv1h1,evec2) + call dip_field(rrh2h1,dv1h2,evec3) + call quad_field(rroh1,qt1,evec4) + do i = 1, 3 + evect(i) = evec1(i) + evec2(i) + evec3(i) + evec4(i) + enddo + e_ind_2h1 = -0.5d0*pol_h*(evect(1)**2 + evect(2)**2 + evect(3)**2) +! ... pol of mono2/H2 from dip and quad on mono1 + call dip_field(rroh2,dv1o,evec1) + call dip_field(rrh1h2,dv1h1,evec2) + call dip_field(rrh2h2,dv1h2,evec3) + call quad_field(rroh2,qt1,evec4) + do i = 1, 3 + evect(i) = evec1(i) + evec2(i) + evec3(i) + evec4(i) + enddo + e_ind_2h2 = -0.5d0*pol_h*(evect(1)**2 + evect(2)**2 + evect(3)**2) +! ... pol of mono1/O from dip and quad on mono2 + call dip_field(rroo,dv2o,evec1) + call dip_field(rroh1,dv2h1,evec2) + call dip_field(rroh2,dv2h2,evec3) + call quad_field(rroo,qt2,evec4) + do i = 1, 3 + evect(i) = evec1(i) + evec2(i) + evec3(i) - evec4(i) + enddo + e_ind_1o = -0.5d0*pol_o*(evect(1)**2 + evect(2)**2 + evect(3)**2) +! ... pol of mono1/H1 from dip and quad on mono2 + call dip_field(rrh1o,dv2o,evec1) + call dip_field(rrh1h1,dv2h1,evec2) + call dip_field(rrh1h2,dv2h2,evec3) + call quad_field(rrh1o,qt2,evec4) + do i = 1, 3 + evect(i) = evec1(i) + evec2(i) + evec3(i) - evec4(i) + enddo + e_ind_1h1 = -0.5d0*pol_h*(evect(1)**2 + evect(2)**2 + evect(3)**2) +! ... pol of mono1/H2 from dip and quad on mono2 + call dip_field(rrh2o,dv2o,evec1) + call dip_field(rrh2h1,dv2h1,evec2) + call dip_field(rrh2h2,dv2h2,evec3) + call quad_field(rrh2o,qt2,evec4) + do i = 1, 3 + evect(i) = evec1(i) + evec2(i) + evec3(i) - evec4(i) + enddo + e_ind_1h2 = -0.5d0*pol_h*(evect(1)**2 + evect(2)**2 + evect(3)**2) + e_ind = e_ind_1o + e_ind_1h1 + e_ind_1h2 + e_ind_2o + e_ind_2h1 + e_ind_2h2 +! --- dispersion energy ---------------------------------------------- + d6oo = (rroo(1)**2 + rroo(2)**2 + rroo(3)**2)**3 + d6oh1 = (rroh1(1)**2 + rroh1(2)**2 + rroh1(3)**2)**3 + d6oh2 = (rroh2(1)**2 + rroh2(2)**2 + rroh2(3)**2)**3 + d6h1o = (rrh1o(1)**2 + rrh1o(2)**2 + rrh1o(3)**2)**3 + d6h1h1 = (rrh1h1(1)**2 + rrh1h1(2)**2 + rrh1h1(3)**2)**3 + d6h1h2 = (rrh1h2(1)**2 + rrh1h2(2)**2 + rrh1h2(3)**2)**3 + d6h2o = (rrh2o(1)**2 + rrh2o(2)**2 + rrh2o(3)**2)**3 + d6h2h1 = (rrh2h1(1)**2 + rrh2h1(2)**2 + rrh2h1(3)**2)**3 + d6h2h2 = (rrh2h2(1)**2 + rrh2h2(2)**2 + rrh2h2(3)**2)**3 + e_disp = -(c6oo/d6oo + c6oh/d6oh1 + c6oh/d6oh2 + c6oh/d6h1o + c6hh/d6h1h1 + c6hh/d6h1h2 + c6oh/d6h2o + c6hh/d6h2h1 + c6hh/d6h2h2) +! ... output components of and total 2-body energy + elong_tot = e_dqtot + e_ind + e_disp +! write(*,231) +! 231 format('1st-order e-stat, induct, disp, total energy (a.u.):') +! write(*,232) e_dqtot, e_ind, e_disp, elong_tot +! 232 format(3x,3e15.6,3x,e15.6) +! --------------------------------------------------------------------- + return + end subroutine h2o_dimer_far +! ===================================================================== + +! ===================================================================== +! sbrt lin3d_2: performs 3D linear interpolation to evaluate two +! functions f1, f2 of 3 variables, the values of the functions +! being given on a regular 3D grid. Sbrt is called first with +! flag init3d = 0, whereupon it reads in the grid data from +! a file, which contains also the numbers of grid points and +! the upper and lower limits of x, y and z. On subsequent call +! with init3d != 0, sbrt uses linear interpolation to evaluate +! f1 and f2 at requested point (x,y,z). +! --------------------------------------------------------------------- + subroutine lin3d_2(init3d,x,y,z,f1,f2,fname) + implicit none + character(len=STRING_LENGTH) fname + integer ngrid3_mx + parameter (ngrid3_mx = ngrid_mx*ngrid_mx*ngrid_mx) + integer init3d + real*8 x, y, z, f1, f2 + integer ix, iy, iz, nx, ny, nz + integer nxsup, nysup, nzsup + real*8 xi, eta, zeta, px, py, pz, qx, qy, qz +! --------------------------------------------------------------------- + if(init3d .eq. 0) then + lin3d_2_igotdata = 1 + open(unit=21,file=trim(fname)) + read(21,*) lin3d_2_nxsup, lin3d_2_xinf, lin3d_2_xsup + read(21,*) lin3d_2_nysup, lin3d_2_yinf, lin3d_2_ysup + read(21,*) lin3d_2_nzsup, lin3d_2_zinf, lin3d_2_zsup + lin3d_2_deltax = (lin3d_2_xsup - lin3d_2_xinf)/float(lin3d_2_nxsup - 1) + lin3d_2_deltay = (lin3d_2_ysup - lin3d_2_yinf)/float(lin3d_2_nysup - 1) + lin3d_2_deltaz = (lin3d_2_zsup - lin3d_2_zinf)/float(lin3d_2_nzsup - 1) +! ..................................................................... + do nx = 1, lin3d_2_nxsup + do ny = 1, lin3d_2_nysup + do nz = 1, lin3d_2_nzsup + read(21,*) ix, iy, iz, lin3d_2_f1tab(ix,iy,iz), lin3d_2_f2tab(ix,iy,iz) + enddo + enddo + enddo + close(unit=21) + else + xi = (x - lin3d_2_xinf)/lin3d_2_deltax + if((x - lin3d_2_xinf) .lt. 0.d0) then + ix = 0 + elseif(((x - lin3d_2_xinf) .ge. 0.d0) .and. ((x - lin3d_2_xsup) .le. 0.d0)) then + ix = int(xi) + else + ix = lin3d_2_nxsup - 2 + endif + px = xi - float(ix) + qx = 1.d0 - px + ix = ix + 1 + eta = (y - lin3d_2_yinf)/lin3d_2_deltay + if((y - lin3d_2_yinf) .lt. 0.d0) then + iy = 0 + elseif(((y - lin3d_2_yinf) .ge. 0.d0) .and. ((y - lin3d_2_ysup) .le. 0.d0)) then + iy = int(eta) + else + iy = lin3d_2_nysup - 2 + endif + py = eta - float(iy) + qy = 1.d0 - py + iy = iy + 1 + zeta = (z - lin3d_2_zinf)/lin3d_2_deltaz + if((z - lin3d_2_zinf) .lt. 0.d0) then + iz = 0 + elseif(((z - lin3d_2_zinf) .ge. 0.d0) .and. ((z - lin3d_2_zsup) .le. 0.d0)) then + iz = int(zeta) + else + iz = lin3d_2_nzsup - 2 + endif + pz = zeta - float(iz) + qz = 1.d0 - pz + iz = iz + 1 + f1 = qx*qy*qz*lin3d_2_f1tab(ix,iy,iz) + qx*qy*pz*lin3d_2_f1tab(ix,iy,iz+1) + qx*py*qz*lin3d_2_f1tab(ix,iy+1,iz) + qx*py*pz*lin3d_2_f1tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_2_f1tab(ix+1,iy,iz) + px*qy*pz*lin3d_2_f1tab(ix+1,iy,iz+1) + px*py*qz*lin3d_2_f1tab(ix+1,iy+1,iz) + px*py*pz*lin3d_2_f1tab(ix+1,iy+1,iz+1) + f2 = qx*qy*qz*lin3d_2_f2tab(ix,iy,iz) + qx*qy*pz*lin3d_2_f2tab(ix,iy,iz+1) + qx*py*qz*lin3d_2_f2tab(ix,iy+1,iz) + qx*py*pz*lin3d_2_f2tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_2_f2tab(ix+1,iy,iz) + px*qy*pz*lin3d_2_f2tab(ix+1,iy,iz+1) + px*py*qz*lin3d_2_f2tab(ix+1,iy+1,iz) + px*py*pz*lin3d_2_f2tab(ix+1,iy+1,iz+1) + endif +! --------------------------------------------------------------------- + return + end subroutine lin3d_2 +! ===================================================================== + + +! ===================================================================== +! sbrt lin3d_3: performs 3D linear interpolation to evaluate three +! functions f1, f2, f3 of 3 variables, the values of the functions +! being given on a regular 3D grid. Sbrt is called first with +! flag init3d = 0, whereupon it reads in the grid data from +! a file, which contains also the numbers of grid points and +! the upper and lower limits of x, y and z. On subsequent call +! with init3d != 0, sbrt uses linear interpolation to evaluate +! f1, f2 and f3 at requested point (x,y,z). +! --------------------------------------------------------------------- + subroutine lin3d_3(init3d,x,y,z,f1,f2,f3,fname) + implicit none + character(len=STRING_LENGTH) fname + integer ngrid3_mx + parameter (ngrid3_mx = ngrid_mx*ngrid_mx*ngrid_mx) + integer init3d + real*8 x, y, z, f1, f2, f3 + integer ix, iy, iz, nx, ny, nz + real*8 xi, eta, zeta, px, py, pz, qx, qy, qz +! --------------------------------------------------------------------- + if(init3d .eq. 0) then + lin3d_3_igotdata = 1 + open(unit=21,file=trim(fname)) + read(21,*) lin3d_3_nxsup, lin3d_3_xinf, lin3d_3_xsup + read(21,*) lin3d_3_nysup, lin3d_3_yinf, lin3d_3_ysup + read(21,*) lin3d_3_nzsup, lin3d_3_zinf, lin3d_3_zsup + lin3d_3_deltax = (lin3d_3_xsup - lin3d_3_xinf)/float(lin3d_3_nxsup - 1) + lin3d_3_deltay = (lin3d_3_ysup - lin3d_3_yinf)/float(lin3d_3_nysup - 1) + lin3d_3_deltaz = (lin3d_3_zsup - lin3d_3_zinf)/float(lin3d_3_nzsup - 1) +! ..................................................................... + do nx = 1, lin3d_3_nxsup + do ny = 1, lin3d_3_nysup + do nz = 1, lin3d_3_nzsup + read(21,*) ix, iy, iz, lin3d_3_f1tab(ix,iy,iz), lin3d_3_f2tab(ix,iy,iz), lin3d_3_f3tab(ix,iy,iz) + enddo + enddo + enddo + close(unit=21) + else + xi = (x - lin3d_3_xinf)/lin3d_3_deltax + if((x - lin3d_3_xinf) .lt. 0.d0) then + ix = 0 + elseif(((x - lin3d_3_xinf) .ge. 0.d0) .and. ((x - lin3d_3_xsup) .le. 0.d0)) then + ix = int(xi) + else + ix = lin3d_3_nxsup - 2 + endif + px = xi - float(ix) + qx = 1.d0 - px + ix = ix + 1 + if((ix .lt. 1) .or. (ix .gt. lin3d_3_nxsup)) then + write(*,931) ix + 931 format(//'error: index ix out of range: ',i10) + stop + endif + eta = (y - lin3d_3_yinf)/lin3d_3_deltay + if((y - lin3d_3_yinf) .lt. 0.d0) then + iy = 0 + elseif(((y - lin3d_3_yinf) .ge. 0.d0) .and. ((y - lin3d_3_ysup) .le. 0.d0)) then + iy = int(eta) + else + iy = lin3d_3_nysup - 2 + endif + py = eta - float(iy) + qy = 1.d0 - py + iy = iy + 1 + if((iy .lt. 1) .or. (iy .gt. lin3d_3_nysup)) then + write(*,932) iy + 932 format(//'error: index iy out of range: ',i10) + stop + endif + zeta = (z - lin3d_3_zinf)/lin3d_3_deltaz + if((z - lin3d_3_zinf) .lt. 0.d0) then + iz = 0 + elseif(((z - lin3d_3_zinf) .ge. 0.d0) .and. ((z - lin3d_3_zsup) .le. 0.d0)) then + iz = int(zeta) + else + iz = lin3d_3_nzsup - 2 + endif + pz = zeta - float(iz) + qz = 1.d0 - pz + iz = iz + 1 + if((iz .lt. 1) .or. (iz .gt. lin3d_3_nzsup)) then + write(*,933) iz + 933 format(//'error: index iz out of range: ',i10) + stop + endif + f1 = qx*qy*qz*lin3d_3_f1tab(ix,iy,iz) + qx*qy*pz*lin3d_3_f1tab(ix,iy,iz+1) + qx*py*qz*lin3d_3_f1tab(ix,iy+1,iz) + qx*py*pz*lin3d_3_f1tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_3_f1tab(ix+1,iy,iz) + px*qy*pz*lin3d_3_f1tab(ix+1,iy,iz+1) + px*py*qz*lin3d_3_f1tab(ix+1,iy+1,iz) + px*py*pz*lin3d_3_f1tab(ix+1,iy+1,iz+1) + f2 = qx*qy*qz*lin3d_3_f2tab(ix,iy,iz) + qx*qy*pz*lin3d_3_f2tab(ix,iy,iz+1) + qx*py*qz*lin3d_3_f2tab(ix,iy+1,iz) + qx*py*pz*lin3d_3_f2tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_3_f2tab(ix+1,iy,iz) + px*qy*pz*lin3d_3_f2tab(ix+1,iy,iz+1) + px*py*qz*lin3d_3_f2tab(ix+1,iy+1,iz) + px*py*pz*lin3d_3_f2tab(ix+1,iy+1,iz+1) + f3 = qx*qy*qz*lin3d_3_f3tab(ix,iy,iz) + qx*qy*pz*lin3d_3_f3tab(ix,iy,iz+1) + qx*py*qz*lin3d_3_f3tab(ix,iy+1,iz) + qx*py*pz*lin3d_3_f3tab(ix,iy+1,iz+1) + px*qy*qz*lin3d_3_f3tab(ix+1,iy,iz) + px*qy*pz*lin3d_3_f3tab(ix+1,iy,iz+1) + px*py*qz*lin3d_3_f3tab(ix+1,iy+1,iz) + px*py*pz*lin3d_3_f3tab(ix+1,iy+1,iz+1) + endif +! --------------------------------------------------------------------- + return + end subroutine lin3d_3 +! ===================================================================== + + +! ============================================================ +! sbrt dip_dip: evaluates dipole-dipole interaction energy +! ------------------------------------------------------------ + subroutine dip_dip(dv1,dv2,rr,vdd) + implicit none + real*8 vdd + real*8 dv1(*), dv2(*), rr(*) + real*8 d1_d2, d1_r, d2_r, r +! ... scalar product of dipoles + d1_d2 = dv1(1)*dv2(1) + dv1(2)*dv2(2) + dv1(3)*dv2(3) +! ... scalar products of dipoles and separation vector + d1_r = dv1(1)*rr(1) + dv1(2)*rr(2) + dv1(3)*rr(3) + d2_r = dv2(1)*rr(1) + dv2(2)*rr(2) + dv2(3)*rr(3) +! ... distance + r = sqrt(rr(1)*rr(1) + rr(2)*rr(2) + rr(3)*rr(3)) +! ... dipole-dipole interaction energy + vdd = -(3.d0*d1_r*d2_r/(r*r) - d1_d2)/(r*r*r) + return + end subroutine dip_dip +! ============================================================ + +! ============================================================ +! sbrt dip_quad: evaluates dipole-quadrupole interaction energy +! ------------------------------------------------------------ + subroutine dip_quad(dv,qt,rr,vdq) + implicit none + real*8 vdq + real*8 dv(*), qt(*), rr(*) + integer i, j, k + real*8 d_r, r_q_r, r_q_d, r +! ... scalar product of dipole vector and separation vector + d_r = 0.d0 + do i = 1, 3 + d_r = d_r + dv(i)*rr(i) + enddo +! ... scalar product separation with quad tensor with separation + r_q_r = 0.d0 + do i = 1, 3 + do j = 1, 3 + k = 3*(i-1) + j + r_q_r = r_q_r + rr(i)*qt(k)*rr(j) + enddo + enddo +! ... scalar product separation with quad tensor with dipole + r_q_d = 0.d0 + do i = 1, 3 + do j = 1, 3 + k = 3*(i-1) + j + r_q_d = r_q_d + rr(i)*qt(k)*dv(j) + enddo + enddo +! ... distance + r = sqrt(rr(1)*rr(1) + rr(2)*rr(2) + rr(3)*rr(3)) +! ... dipole-quadrupole interaction energy + vdq = 5.d0*d_r*r_q_r/(r**7) - 2.d0*r_q_d/(r**5) +! ... + return + end subroutine dip_quad +! ============================================================= + +! ============================================================ +! sbrt quad_dip: evaluates quadrupole-dipole interaction energy +! ------------------------------------------------------------ + subroutine quad_dip(qt,dv,rr,vqd) + implicit none + real*8 vqd + real*8 dv(*), qt(*), rr(*) + integer i, j, k + real*8 d_r, r_q_r, r_q_d, r +! ... scalar product of dipole vector and separation vector + d_r = 0.d0 + do i = 1, 3 + d_r = d_r + dv(i)*rr(i) + enddo +! ... scalar product separation with quad tensor with separation + r_q_r = 0.d0 + do i = 1, 3 + do j = 1, 3 + k = 3*(i-1) + j + r_q_r = r_q_r + rr(i)*qt(k)*rr(j) + enddo + enddo +! ... scalar product separation with quad tensor with dipole + r_q_d = 0.d0 + do i = 1, 3 + do j = 1, 3 + k = 3*(i-1) + j + r_q_d = r_q_d + rr(i)*qt(k)*dv(j) + enddo + enddo +! ... distance + r = sqrt(rr(1)*rr(1) + rr(2)*rr(2) + rr(3)*rr(3)) +! ... quadrupole-dipole interaction energy + vqd = -5.d0*d_r*r_q_r/(r**7) + 2.d0*r_q_d/(r**5) +! ... + return + end subroutine quad_dip +! ============================================================= + +! ============================================================= +! sbrt quad_quad: evaluates quadrupole-quadrupole interaction energy +! ------------------------------------------------------------- + subroutine quad_quad(qt1,qt2,rr,vqq) + implicit none + real*8 vqq + real*8 qt1(*), qt2(*), rr(*) + integer i, j, k + real*8 tr_q_q, r_q1_r, r_q2_r, r_q_q_r, s1, s2, r +! ... trace of qt1*qt2 + tr_q_q = 0.d0 + do i = 1, 3 + do j = 1, 3 + k = 3*(i-1) + j + tr_q_q = tr_q_q + qt1(k)*qt2(k) + enddo + enddo +! ... scalar products r*qt1*r and r*qt2*r + r_q1_r = 0.d0 + r_q2_r = 0.d0 + do i = 1, 3 + do j = 1, 3 + k = 3*(i-1) + j + r_q1_r = r_q1_r + rr(i)*qt1(k)*rr(j) + r_q2_r = r_q2_r + rr(i)*qt2(k)*rr(j) + enddo + enddo +! ... scalar product r*qt1*qt2*r + r_q_q_r = 0.d0 + do i = 1, 3 + s1 = 0.d0 + s2 = 0.d0 + do j = 1, 3 + k = 3*(i-1) + j + s1 = s1 + qt1(k)*rr(j) + s2 = s2 + qt2(k)*rr(j) + enddo + r_q_q_r = r_q_q_r + s1*s2 + enddo +! ... distance + r = sqrt(rr(1)*rr(1) + rr(2)*rr(2) + rr(3)*rr(3)) +! ... quad-quad interaction energy + vqq = 2.d0*tr_q_q/(3.d0*(r**5)) - 20.d0*r_q_q_r/(3.d0*(r**7)) + 35.d0*r_q1_r*r_q2_r/(3.d0*(r**9)) +! ... + return + end subroutine quad_quad +! =============================================================== + +! =============================================================== +! sbrt dip_field: computes electric field vector evec2 at vector +! position pos2 due to electric dipole vector mu1 at origin +! --------------------------------------------------------------- + subroutine dip_field(pos2,mu1,evec2) + implicit none + real*8 pos2(*), mu1(*), evec2(*) + integer n + real*8 drr, mudotr, drr3, drr5 +! --------------------------------------------------------------- + drr = 0.d0 + mudotr = 0.d0 + do n = 1, 3 + drr = drr + pos2(n)*pos2(n) + mudotr = mudotr + mu1(n)*pos2(n) + enddo + drr = sqrt(drr) + drr3 = drr*drr*drr + drr5 = drr*drr*drr3 + do n = 1, 3 + evec2(n) = 3.d0*mudotr*pos2(n)/drr5 - mu1(n)/drr3 + enddo +! --------------------------------------------------------------- + return + end subroutine dip_field +! =============================================================== + +! =============================================================== +! sbrt quad_field: computes electric field evec2 at vector +! position pos2 due to electric quadrupole tensor q1 at origin +! --------------------------------------------------------------- + subroutine quad_field(pos2,q1,evec2) + implicit none + real*8 pos2(*), q1(*), evec2(*) + integer k, m, n + real*8 drr, drr5, drr7, rdqdr + real*8 qdotr(3) +! --------------------------------------------------------------- + drr = 0.d0 + rdqdr = 0.d0 + do m = 1, 3 + drr = drr + pos2(m)*pos2(m) + qdotr(m) = 0.d0 + do n = 1, 3 + k = 3*(m-1) + n + rdqdr = rdqdr + pos2(m)*q1(k)*pos2(n) + qdotr(m) = qdotr(m) + q1(k)*pos2(n) + enddo + enddo + drr = sqrt(drr) + drr5 = drr*drr*drr*drr*drr + drr7 = drr*drr*drr5 + do n = 1, 3 + evec2(n) = 5.d0*rdqdr*pos2(n)/drr7 - 2.d0*qdotr(n)/drr5 + enddo +! ---------------------------------------------------------------- + return + end subroutine quad_field +! ================================================================ + + + + end module IPModel_WaterDimer_Gillan_module diff --git a/src/Potentials/IPModel_WaterTrimer_Gillan.F90 b/src/Potentials/IPModel_WaterTrimer_Gillan.F90 new file mode 100644 index 0000000000..12a1747d2a --- /dev/null +++ b/src/Potentials/IPModel_WaterTrimer_Gillan.F90 @@ -0,0 +1,700 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_WaterTrimer_Gillan +!X +!% 3-body interaction of three water molecules, parametrised by Mike Gillan in 2013 +!% +!% Based on polynomial basis functions of Paesani 2012 +!% +!% Energy only +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_WaterTrimer_Gillan_module + +use error_module +use system_module, only : dp, inoutput, print, operator(//) +use units_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use spline_module +use quaternions_module +use atoms_types_module +use atoms_module +use topology_module + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_WaterTrimer_Gillan +type IPModel_WaterTrimer_Gillan + real(dp) :: cutoff = 8.0_dp + character(len=STRING_LENGTH) :: coeff_file + logical :: OHH_ordercheck = .true. + type(Spline) :: fcut + real (dp) :: fcut_delta = 0.5 +end type IPModel_WaterTrimer_Gillan + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_WaterTrimer_Gillan), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_WaterTrimer_Gillan_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_WaterTrimer_Gillan_Finalise +end interface Finalise + +interface Print + module procedure IPModel_WaterTrimer_Gillan_Print +end interface Print + +interface Calc + module procedure IPModel_WaterTrimer_Gillan_Calc +end interface Calc + +! module-gobal variables + +integer,parameter :: nbas_tot_max=150 + +integer ibas_code, nbas_tot, nbas_totp +integer natom, nbas_2deg, nbas_3deg +integer iswitch(nbas_tot_max) +real(dp):: drep(nbas_tot_max) +real(dp):: basis(nbas_tot_max) + + + +contains + +subroutine IPModel_WaterTrimer_Gillan_Initialise_str(this, args_str, param_str, error) + type(IPModel_WaterTrimer_Gillan), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + integer, optional, intent(out) :: error + integer :: i, nb1 + real(dp) :: rr(3,9) + + INIT_ERROR(error) + + call Finalise(this) + + call initialise(params) + call param_register(params, 'coeff_file', PARAM_MANDATORY, this%coeff_file, help_string="name of file which contains the polynomial coefficients") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_WaterTrimer_Gillan_Initialise args_str')) then + RAISE_ERROR("IPModel_WaterTrimer_Gillan_Init failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + open(unit=21,file=this%coeff_file) + read(21,*) ibas_code +! write(*,121) ibas_code +! 121 format(/'basis code: ',i3) + read(21,*) nbas_tot +! write(*,122) nbas_tot +! 122 format(/'total no. of basis functions: ',i5) + if(nbas_tot .gt. nbas_tot_max) then +! write(*,901) +! 901 format(/'error: too many basis functions') + RAISE_ERROR('error: too many basis functions', error) + endif + +!c ... initial call of basis calculator + call calc_basis(0,ibas_code,nbas_2deg,nbas_3deg,nbas_tot_max,rr,basis) +! write(*,126) nbas_2deg, nbas_3deg +! 126 format(/'after initial call to basis calculator:'/ +! * 'no. of deg-2 basis functions: ',i5/ +! * 'no. of deg-3 basis functions: ',i5) + nbas_totp = nbas_2deg + nbas_3deg +! write(*,127) nbas_totp +! 127 format(/'hence total no. of basis functions: ',i5) + if(nbas_totp .ne. nbas_tot) then +! write(*,905) +! 905 format(//'error: conflicting no. of basis functions') + RAISE_ERROR('error: conflicting no. of basis functions', error) + endif +!c ... read basis coeffs +! write(*,131) +! 131 format(/'switch flags, basis coeffs:') + do i = 1, nbas_tot + read(21,*) nb1, iswitch(i), drep(i) +! write(*,132) nb, iswitch(nb), drep(nb) +! 132 format(i5,3x,i3,3x,e15.6) + enddo + close(unit=21) + + call initialise(this%fcut, (/this%cutoff - this%fcut_delta, this%cutoff/), (/1.0_dp, 0.0_dp/), 0.0_dp, 0.0_dp) + + + end subroutine IPModel_WaterTrimer_Gillan_Initialise_str + +subroutine IPModel_WaterTrimer_Gillan_Finalise(this) + type(IPModel_WaterTrimer_Gillan), intent(inout) :: this + + ! Add finalisation code here + call finalise(this%fcut) + + +end subroutine IPModel_WaterTrimer_Gillan_Finalise + + +subroutine IPModel_WaterTrimer_Gillan_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_WaterTrimer_Gillan), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer :: i, w1, w2, w3, w1O, w2O, w3O + integer, dimension(3,at%N/3) :: water_index + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + real(dp) rr(3,9) + real(dp) e_trimer + + INIT_ERROR(error) + + if(present(local_e)) then + RAISE_ERROR('IPModel_WaterTrimer_Gillan_Calc: local_e not implemented', error) + end if + if(present(f)) then + RAISE_ERROR('IPModel_WaterTrimer_Gillan_Calc: forces not implemented', error) + end if + if(present(virial)) then + RAISE_ERROR('IPModel_WaterTrimer_Gillan_Calc: virial not implemented', error) + end if + if (present(local_virial)) then + RAISE_ERROR("IPModel_WaterTrimer_Gillan_Calc: local_virial calculation requested but not supported yet.", error) + endif + + if(.not. present(e)) return ! nothing to do + + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy: nb326 $") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + + if(.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_WaterTrimer_Gillan_Calc args_str')) then + RAISE_ERROR("IPModel_WaterTrimer_Gillan_Calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if(has_atom_mask_name) then + RAISE_ERROR('IPModel_WaterTrimer_Gillan_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_WaterTrimer_Gillan_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error) + end if + endif + + ! loop through atoms, find oxygens and their closest hydrogens + + call find_water_monomer(at,water_index,this%OHH_ordercheck,error=error) + + e = 0.d0 + + ! triple loop through monomers + do w1 = 1, at%N/3 + do w2 = w1+1, at%N/3 + do w3 = w2+1, at%N/3 + + w1O = water_index(1,w1) + rr(:,1) = at%pos(:,w1O) ! O + rr(:,2) = rr(:,1) + diff_min_image(at, w1O, water_index(2,w1)) ! H + rr(:,3) = rr(:,1) + diff_min_image(at, w1O, water_index(3,w1)) ! H + + w2O = water_index(1,w2) + rr(:,4) = rr(:,1) + diff_min_image(at, w1O, w2O) ! O + rr(:,5) = rr(:,1) + diff_min_image(at, w1O, water_index(2,w2)) ! H + rr(:,6) = rr(:,1) + diff_min_image(at, w1O, water_index(3,w2)) ! H + + w3O = water_index(1,w3) + rr(:,7) = rr(:,1) + diff_min_image(at, w1O, w3O) ! O + rr(:,8) = rr(:,1) + diff_min_image(at, w1O, water_index(2,w3)) ! H + rr(:,9) = rr(:,1) + diff_min_image(at, w1O, water_index(3,w3)) ! H + +!c ... calculate values of basis functions for current config + call calc_basis(1,ibas_code,nbas_2deg,nbas_3deg,nbas_tot_max, rr,basis) + e_trimer = 0.0_dp + do i = 1, nbas_tot + if(iswitch(i) .eq. 1) then + e_trimer = e_trimer + drep(i)*basis(i) + endif + enddo + e = e+e_trimer* spline_value(this%fcut, distance_min_image(at, w1O, w2O)) * & + spline_value(this%fcut, distance_min_image(at, w1O,w3O))* & + spline_value(this%fcut, distance_min_image(at, w2O, w3O)) + + + ! write(*,231) nc, e3bas + ! 231 format(/'config. no. ',i5,' 3-body correction: ',e15.6) + ! write(13,232) nc, e3bas + ! 232 format(i5,3x,e15.6) + enddo + end do + end do + !c ... end loop over configs + + + e = e*HARTREE + + +end subroutine IPModel_WaterTrimer_Gillan_Calc + + +subroutine IPModel_WaterTrimer_Gillan_Print(this, file) + type(IPModel_WaterTrimer_Gillan), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_WaterTrimer_Gillan : WaterTrimer_Gillan Potential", file=file) + call Print("IPModel_WaterTrimer_Gillan : cutoff = " // this%cutoff, file=file) + call Print("IPModel_WaterTrimer_Gillan : cutoff_delta = " // this%fcut_delta, file=file) + call Print("IPModel_WaterTrimer_Gillan : WARNING: no multiple periodic images implemented, so minimum-image convention applies to this potential!!! ", file=file) + +end subroutine IPModel_WaterTrimer_Gillan_Print + +!c ===================================================================== +!c Subroutine calc_basis: directs calculation to appropriate +!c version calc_basis_n() according to value of flag ibas_code. +!c The only versions implemented so far are ibas_code = 0, 1 +!c and any other values will cause the code to stop. +!c --------------------------------------------------------------------- + subroutine calc_basis(iret,ibas_code,nbas_2deg,nbas_3deg,nbas_tot_max,rr,basis) + implicit none + integer iret, ibas_code, nbas_2deg, nbas_3deg, nbas_tot_max + real*8 rr(3,9) + real*8 basis(nbas_tot_max) +!c --------------------------------------------------------------------- + if(ibas_code .eq. 0) then + call calc_basis_0(iret,nbas_2deg,nbas_3deg,nbas_tot_max,rr,basis) + elseif(ibas_code .eq. 1) then + call calc_basis_1(iret,nbas_2deg,nbas_3deg,nbas_tot_max,rr,basis) + else +! write(*,901) +! 901 format(//'error: sbrt calc_basis called with flag nbas_2deg ', +! * 'out of range') + stop + endif +!c --------------------------------------------------------------------- + return + end subroutine calc_basis +!c ===================================================================== + +!c ================================================================= +!c Subroutine calc_basis_0: computes deg-2 and deg-3 3-body +!c basis functions for model where only O-O distances are used +!c and at most one distance factor is allowed for each +!c O-O distance. +!c ------------------------------------------------------------------ + subroutine calc_basis_0(iret,nbas_2deg,nbas_3deg,nbas_tot_max, rr,basis) + implicit none + integer iret, nbas_2deg, nbas_3deg, nbas_tot_max + real*8 rr(3,9) + real*8 basis(nbas_tot_max) + real*8 kOO, dOO + real*8 d14, d17, d47, e14, e17, e47 +!c --------------------------------------------------------------------- + nbas_2deg = 1 + nbas_3deg = 1 + if(iret .eq. 0) return + kOO = 1.3d0 + dOO = 3.d0 +!c ... + d14 = sqrt((rr(1,4) - rr(1,1))**2 + (rr(2,4) - rr(2,1))**2 + (rr(3,4) - rr(3,1))**2) + d17 = sqrt((rr(1,7) - rr(1,1))**2 + (rr(2,7) - rr(2,1))**2 + (rr(3,7) - rr(3,1))**2) + d47 = sqrt((rr(1,4) - rr(1,7))**2 + (rr(2,4) - rr(2,7))**2 + (rr(3,4) - rr(3,7))**2) + e14 = exp(-kOO*(d14 - dOO)) + e17 = exp(-kOO*(d17 - dOO)) + e47 = exp(-kOO*(d47 - dOO)) + basis(1) = e14*e17 + e14*e47 + e17*e47 + basis(2) = e14*e17*e47 +!c --------------------------------------------------------------------- + return + end subroutine calc_basis_0 +!c ===================================================================== + +!c ================================================================= +!c Subroutine calc_basis_1: computes deg-2 and deg-3 3-body +!c basis functions for model where O-O, O-H and H-H distances are +!c used and at most one distance factor is allowed for each +!c monomer pair. +!c ------------------------------------------------------------------ + subroutine calc_basis_1(iret,nbas_2deg,nbas_3deg,nbas_tot_max, rr,basis) + implicit none + integer iret, nbas_2deg, nbas_3deg, nbas_tot_max + real*8 rr(3,9) + real*8 basis(nbas_tot_max) +!c ... + real*8 kOO, dOO, kOH, dOH, kHH, dHH + real*8 d14, d15, d16, d17, d18, d19, d24, d25, d26, d27, d28, d29, d34, d35, d36, d37, d38, d39, d47, d48, d49, d57, d58, d59, d67, d68, d69 + real*8 e14, e15, e16, e17, e18, e19, e24, e25, e26, e27, e28, e29, e34, e35, e36, e37, e38, e39, e47, e48, e49, e57, e58, e59, e67, e68, e69 +!c --------------------------------------------------------------------- + nbas_2deg = 13 + nbas_3deg = 30 + if(iret .eq. 0) return +!c --------------------------------------------------------------------- + kOO = 0.6d0 + dOO = 3.d0 + kOH = 1.4d0 + dOH = 3.d0 + kHH = 1.0d0 + dHH = 3.d0 +!c --------------------------------------------------------------------- + d14 = sqrt((rr(1,4) - rr(1,1))**2 + (rr(2,4) - rr(2,1))**2 + (rr(3,4) - rr(3,1))**2) + d15 = sqrt((rr(1,5) - rr(1,1))**2 + (rr(2,5) - rr(2,1))**2 + (rr(3,5) - rr(3,1))**2) + d16 = sqrt((rr(1,6) - rr(1,1))**2 + (rr(2,6) - rr(2,1))**2 + (rr(3,6) - rr(3,1))**2) + d17 = sqrt((rr(1,7) - rr(1,1))**2 + (rr(2,7) - rr(2,1))**2 + (rr(3,7) - rr(3,1))**2) + d18 = sqrt((rr(1,8) - rr(1,1))**2 + (rr(2,8) - rr(2,1))**2 + (rr(3,8) - rr(3,1))**2) + d19 = sqrt((rr(1,9) - rr(1,1))**2 + (rr(2,9) - rr(2,1))**2 + (rr(3,9) - rr(3,1))**2) + d24 = sqrt((rr(1,4) - rr(1,2))**2 + (rr(2,4) - rr(2,2))**2 + (rr(3,4) - rr(3,2))**2) + d25 = sqrt((rr(1,5) - rr(1,2))**2 + (rr(2,5) - rr(2,2))**2 + (rr(3,5) - rr(3,2))**2) + d26 = sqrt((rr(1,6) - rr(1,2))**2 + (rr(2,6) - rr(2,2))**2 + (rr(3,6) - rr(3,2))**2) + d27 = sqrt((rr(1,7) - rr(1,2))**2 + (rr(2,7) - rr(2,2))**2 + (rr(3,7) - rr(3,2))**2) + d28 = sqrt((rr(1,8) - rr(1,2))**2 + (rr(2,8) - rr(2,2))**2 + (rr(3,8) - rr(3,2))**2) + d29 = sqrt((rr(1,9) - rr(1,2))**2 + (rr(2,9) - rr(2,2))**2 + (rr(3,9) - rr(3,2))**2) + d34 = sqrt((rr(1,4) - rr(1,3))**2 + (rr(2,4) - rr(2,3))**2 + (rr(3,4) - rr(3,3))**2) + d35 = sqrt((rr(1,5) - rr(1,3))**2 + (rr(2,5) - rr(2,3))**2 + (rr(3,5) - rr(3,3))**2) + d36 = sqrt((rr(1,6) - rr(1,3))**2 + (rr(2,6) - rr(2,3))**2 + (rr(3,6) - rr(3,3))**2) + d37 = sqrt((rr(1,7) - rr(1,3))**2 + (rr(2,7) - rr(2,3))**2 + (rr(3,7) - rr(3,3))**2) + d38 = sqrt((rr(1,8) - rr(1,3))**2 + (rr(2,8) - rr(2,3))**2 + (rr(3,8) - rr(3,3))**2) + d39 = sqrt((rr(1,9) - rr(1,3))**2 + (rr(2,9) - rr(2,3))**2 + (rr(3,9) - rr(3,3))**2) + d47 = sqrt((rr(1,7) - rr(1,4))**2 + (rr(2,7) - rr(2,4))**2 + (rr(3,7) - rr(3,4))**2) + d48 = sqrt((rr(1,8) - rr(1,4))**2 + (rr(2,8) - rr(2,4))**2 + (rr(3,8) - rr(3,4))**2) + d49 = sqrt((rr(1,9) - rr(1,4))**2 + (rr(2,9) - rr(2,4))**2 + (rr(3,9) - rr(3,4))**2) + d57 = sqrt((rr(1,7) - rr(1,5))**2 + (rr(2,7) - rr(2,5))**2 + (rr(3,7) - rr(3,5))**2) + d58 = sqrt((rr(1,8) - rr(1,5))**2 + (rr(2,8) - rr(2,5))**2 + (rr(3,8) - rr(3,5))**2) + d59 = sqrt((rr(1,9) - rr(1,5))**2 + (rr(2,9) - rr(2,5))**2 + (rr(3,9) - rr(3,5))**2) + d67 = sqrt((rr(1,7) - rr(1,6))**2 + (rr(2,7) - rr(2,6))**2 + (rr(3,7) - rr(3,6))**2) + d68 = sqrt((rr(1,8) - rr(1,6))**2 + (rr(2,8) - rr(2,6))**2 + (rr(3,8) - rr(3,6))**2) + d69 = sqrt((rr(1,9) - rr(1,6))**2 + (rr(2,9) - rr(2,6))**2 + (rr(3,9) - rr(3,6))**2) + + e14 = exp(-kOO*(d14 - dOO)) + e15 = exp(-kOH*(d15 - dOH)) + e16 = exp(-kOH*(d16 - dOH)) + e17 = exp(-kOO*(d17 - dOO)) + e18 = exp(-kOH*(d18 - dOH)) + e19 = exp(-kOH*(d19 - dOH)) + e24 = exp(-kOH*(d24 - dOH)) + e25 = exp(-kHH*(d25 - dHH)) + e26 = exp(-kHH*(d26 - dHH)) + e27 = exp(-kOH*(d27 - dOH)) + e28 = exp(-kHH*(d28 - dHH)) + e29 = exp(-kHH*(d29 - dHH)) + e34 = exp(-kOH*(d34 - dOH)) + e35 = exp(-kHH*(d35 - dHH)) + e36 = exp(-kHH*(d36 - dHH)) + e37 = exp(-kOH*(d37 - dOH)) + e38 = exp(-kHH*(d38 - dHH)) + e39 = exp(-kHH*(d39 - dHH)) + e47 = exp(-kOO*(d47 - dOO)) + e48 = exp(-kOH*(d48 - dOH)) + e49 = exp(-kOH*(d49 - dOH)) + e57 = exp(-kOH*(d57 - dOH)) + e58 = exp(-kHH*(d58 - dHH)) + e59 = exp(-kHH*(d59 - dHH)) + e67 = exp(-kOH*(d67 - dOH)) + e68 = exp(-kHH*(d68 - dHH)) + e69 = exp(-kHH*(d69 - dHH)) +!c + basis(1) = e14*e17 + e14*e47 + e17*e47 +!c + basis(2) = e14*e18 + e14*e19 + e24*e47 + e34*e47 + e17*e57 + e17*e67 + e14*e48 + e14*e49 + e27*e47 + e37*e47 + e15*e17 + e16*e17 +!c + basis(3) = e14*e27 + e14*e37 + e15*e47 + e16*e47 + e17*e48 + e17*e49 + e14*e57 + e14*e67 + e18*e47 + e19*e47 + e17*e24 + e17*e34 +!c + basis(4) = e14*e28 + e14*e29 + e14*e38 + e14*e39 + e25*e47 + e35*e47 + e26*e47 + e36*e47 + e17*e58 + e17*e68 + e17*e59 + e17*e69 + e14*e58 + e14*e59 + e14*e68 + e14*e69 + e28*e47 + e38*e47 + e29*e47 + e39*e47 + e17*e25 + e17*e26 + e17*e35 + e17*e36 +!c + basis(5) = e15*e18 + e15*e19 + e16*e18 + e16*e19 + e24*e48 + e34*e48 + e24*e49 + e34*e49 + e27*e57 + e27*e67 + e37*e57 + e37*e67 +!c + basis(6) = e15*e27 + e16*e27 + e15*e37 + e16*e37 + e15*e48 + e15*e49 + e16*e48 + e16*e49 + e27*e48 + e37*e48 + e27*e49 + e37*e49 + e24*e57 + e34*e57 + e24*e67 + e34*e67 + e18*e57 + e18*e67 + e19*e57 + e19*e67 + e18*e24 + e19*e24 + e18*e34 + e19*e34 +!c + basis(7) = e15*e28 + e15*e29 + e16*e28 + e16*e29 + e15*e38 + e15*e39 + e16*e38 + e16*e39 + e25*e48 + e35*e48 + e25*e49 + e35*e49 + e26*e48 + e36*e48 + e26*e49 + e36*e49 + e27*e58 + e27*e68 + e37*e58 + e37*e68 + e27*e59 + e27*e69 + e37*e59 + e37*e69 + e24*e58 + e24*e59 + e34*e58 + e34*e59 + e24*e68 + e24*e69 + e34*e68 + e34*e69 + e28*e57 + e38*e57 + e28*e67 + e38*e67 + e29*e57 + e39*e57 + e29*e67 + e39*e67 + e18*e25 + e18*e26 + e19*e25 + e19*e26 + e18*e35 + e18*e36 + e19*e35 + e19*e36 +!c + basis(8) = e15*e57 + e16*e67 + e18*e48 + e19*e49 + e24*e27 + e34*e37 +!c + basis(9) = e15*e58 + e15*e59 + e16*e68 + e16*e69 + e28*e48 + e38*e48 + e29*e49 + e39*e49 + e25*e27 + e26*e27 + e35*e37 + e36*e37 + e24*e28 + e24*e29 + e34*e38 + e34*e39 + e25*e57 + e35*e57 + e26*e67 + e36*e67 + e18*e58 + e18*e68 + e19*e59 + e19*e69 +!c + basis(10) = e15*e67 + e16*e57 + e19*e48 + e18*e49 + e27*e34 + e24*e37 +!c + basis(11) = e15*e68 + e15*e69 + e16*e58 + e16*e59 + e29*e48 + e39*e48 + e28*e49 + e38*e49 + e27*e35 + e27*e36 + e25*e37 + e26*e37 + e24*e38 + e24*e39 + e28*e34 + e29*e34 + e26*e57 + e36*e57 + e25*e67 + e35*e67 + e18*e59 + e18*e69 + e19*e58 + e19*e68 +!c + basis(12) = e25*e28 + e25*e29 + e26*e28 + e26*e29 + e35*e38 + e35*e39 + e36*e38 + e36*e39 + e25*e58 + e35*e58 + e25*e59 + e35*e59 + e26*e68 + e36*e68 + e26*e69 + e36*e69 + e28*e58 + e28*e68 + e38*e58 + e38*e68 + e29*e59 + e29*e69 + e39*e59 + e39*e69 +!c + basis(13) = e25*e38 + e25*e39 + e26*e38 + e26*e39 + e28*e35 + e29*e35 + e28*e36 + e29*e36 + e26*e58 + e36*e58 + e26*e59 + e36*e59 + e25*e68 + e35*e68 + e25*e69 + e35*e69 + e28*e59 + e28*e69 + e38*e59 + e38*e69 + e29*e58 + e29*e68 + e39*e58 + e39*e68 +!c + basis(14) = e14*e17*e47 +!c + basis(15) = e14*e17*e48 + e14*e17*e49 + e14*e27*e47 + e14*e37*e47 + e15*e17*e47 + e16*e17*e47 + e14*e18*e47 + e14*e19*e47 + e17*e24*e47 + e17*e34*e47 + e14*e17*e57 + e14*e17*e67 +!c + basis(16) = e14*e17*e58 + e14*e17*e59 + e14*e17*e68 + e14*e17*e69 + e14*e28*e47 + e14*e38*e47 + e14*e29*e47 + e14*e39*e47 + e17*e25*e47 + e17*e26*e47 + e17*e35*e47 + e17*e36*e47 +!c + basis(17) = e14*e18*e48 + e14*e19*e49 + e24*e27*e47 + e34*e37*e47 + e15*e17*e57 + e16*e17*e67 +!c + basis(18) = e14*e18*e49 + e14*e19*e48 + e24*e37*e47 + e27*e34*e47 + e16*e17*e57 + e15*e17*e67 +!c + basis(19) = e14*e18*e57 + e14*e19*e57 + e14*e18*e67 + e14*e19*e67 + e18*e24*e47 + e18*e34*e47 + e19*e24*e47 + e19*e34*e47 + e17*e24*e57 + e17*e24*e67 + e17*e34*e57 + e17*e34*e67 + e14*e27*e48 + e14*e27*e49 + e14*e37*e48 + e14*e37*e49 + e15*e27*e47 + e15*e37*e47 + e16*e27*e47 + e16*e37*e47 + e15*e17*e48 + e16*e17*e48 + e15*e17*e49 + e16*e17*e49 +!c + basis(20) = e14*e18*e58 + e14*e19*e59 + e14*e18*e68 + e14*e19*e69 + e24*e28*e47 + e34*e38*e47 + e24*e29*e47 + e34*e39*e47 + e17*e25*e57 + e17*e26*e67 + e17*e35*e57 + e17*e36*e67 + e14*e28*e48 + e14*e29*e49 + e14*e38*e48 + e14*e39*e49 + e25*e27*e47 + e35*e37*e47 + e26*e27*e47 + e36*e37*e47 + e15*e17*e58 + e16*e17*e68 + e15*e17*e59 + e16*e17*e69 +!c + basis(21) = e14*e18*e59 + e14*e19*e58 + e14*e18*e69 + e14*e19*e68 + e24*e38*e47 + e28*e34*e47 + e24*e39*e47 + e29*e34*e47 + e17*e26*e57 + e17*e25*e67 + e17*e36*e57 + e17*e35*e67 + e14*e29*e48 + e14*e28*e49 + e14*e39*e48 + e14*e38*e49 + e27*e35*e47 + e25*e37*e47 + e27*e36*e47 + e26*e37*e47 + e15*e17*e68 + e16*e17*e58 + e15*e17*e69 + e16*e17*e59 +!c + basis(22) = e14*e27*e57 + e14*e27*e67 + e14*e37*e57 + e14*e37*e67 + e15*e18*e47 + e15*e19*e47 + e16*e18*e47 + e16*e19*e47 + e17*e24*e48 + e17*e34*e48 + e17*e24*e49 + e17*e34*e49 +!c + basis(23) = e14*e27*e58 + e14*e27*e59 + e14*e27*e68 + e14*e27*e69 + e14*e37*e58 + e14*e37*e59 + e14*e37*e68 + e14*e37*e69 + e15*e28*e47 + e15*e38*e47 + e15*e29*e47 + e15*e39*e47 + e16*e28*e47 + e16*e38*e47 + e16*e29*e47 + e16*e39*e47 + e17*e25*e48 + e17*e26*e48 + e17*e35*e48 + e17*e36*e48 + e17*e25*e49 + e17*e26*e49 + e17*e35*e49 + e17*e36*e49 + e14*e28*e57 + e14*e29*e57 + e14*e38*e57 + e14*e39*e57 + e14*e28*e67 + e14*e29*e67 + e14*e38*e67 + e14*e39*e67 + e18*e25*e47 + e18*e35*e47 + e18*e26*e47 + e18*e36*e47 + e19*e25*e47 + e19*e35*e47 + e19*e26*e47 + e19*e36*e47 + e17*e24*e58 + e17*e24*e68 + e17*e24*e59 + e17*e24*e69 + e17*e34*e58 + e17*e34*e68 + e17*e34*e59 + e17*e34*e69 +!c + basis(24) = e14*e28*e58 + e14*e29*e59 + e14*e28*e68 + e14*e29*e69 + e14*e38*e58 + e14*e39*e59 + e14*e38*e68 + e14*e39*e69 + e25*e28*e47 + e35*e38*e47 + e25*e29*e47 + e35*e39*e47 + e26*e28*e47 + e36*e38*e47 + e26*e29*e47 + e36*e39*e47 + e17*e25*e58 + e17*e26*e68 + e17*e35*e58 + e17*e36*e68 + e17*e25*e59 + e17*e26*e69 + e17*e35*e59 + e17*e36*e69 +!c + basis(25) = e14*e28*e59 + e14*e29*e58 + e14*e28*e69 + & + e14*e29*e68 + e14*e38*e59 + e14*e39*e58 + & + e14*e38*e69 + e14*e39*e68 + e25*e38*e47 + & + e28*e35*e47 + e25*e39*e47 + e29*e35*e47 + & + e26*e38*e47 + e28*e36*e47 + e26*e39*e47 + & + e29*e36*e47 + e17*e26*e58 + e17*e25*e68 + & + e17*e36*e58 + e17*e35*e68 + e17*e26*e59 + & + e17*e25*e69 + e17*e36*e59 + e17*e35*e69 +!c + basis(26) = e15*e18*e48 + e15*e19*e49 + e16*e18*e48 + & + e16*e19*e49 + e24*e27*e48 + e34*e37*e48 + & + e24*e27*e49 + e34*e37*e49 + e15*e27*e57 + & + e16*e27*e67 + e15*e37*e57 + e16*e37*e67 + & + e18*e24*e48 + e19*e24*e49 + e18*e34*e48 + & + e19*e34*e49 + e24*e27*e57 + e34*e37*e57 + & + e24*e27*e67 + e34*e37*e67 + e15*e18*e57 + & + e16*e18*e67 + e15*e19*e57 + e16*e19*e67 +!c + basis(27) = e15*e18*e49 + e15*e19*e48 + e16*e18*e49 + & + e16*e19*e48 + e24*e37*e48 + e27*e34*e48 + & + e24*e37*e49 + e27*e34*e49 + e16*e27*e57 + & + e15*e27*e67 + e16*e37*e57 + e15*e37*e67 + & + e19*e24*e48 + e18*e24*e49 + e19*e34*e48 + & + e18*e34*e49 + e27*e34*e57 + e24*e37*e57 + & + e27*e34*e67 + e24*e37*e67 + e15*e18*e67 + & + e16*e18*e57 + e15*e19*e67 + e16*e19*e57 +!c + basis(28) = e15*e18*e58 + e15*e19*e59 + e16*e18*e68 + & + e16*e19*e69 + e24*e28*e48 + e34*e38*e48 + & + e24*e29*e49 + e34*e39*e49 + e25*e27*e57 + & + e26*e27*e67 + e35*e37*e57 + e36*e37*e67 +!c + basis(29) = e15*e18*e59 + e15*e19*e58 + e16*e18*e69 + & + e16*e19*e68 + e24*e38*e48 + e28*e34*e48 + & + e24*e39*e49 + e29*e34*e49 + e26*e27*e57 + & + e25*e27*e67 + e36*e37*e57 + e35*e37*e67 + & + e24*e29*e48 + e24*e28*e49 + e34*e39*e48 + & + e34*e38*e49 + e27*e35*e57 + e25*e37*e57 + & + e27*e36*e67 + e26*e37*e67 + e15*e18*e68 + & + e16*e18*e58 + e15*e19*e69 + e16*e19*e59 +!c + basis(30) = e15*e18*e69 + e15*e19*e68 + e16*e18*e59 + & + e16*e19*e58 + e24*e39*e48 + e29*e34*e48 + & + e24*e38*e49 + e28*e34*e49 + e27*e36*e57 + & + e27*e35*e67 + e26*e37*e57 + e25*e37*e67 +!c + basis(31) = e15*e27*e48 + e15*e27*e49 + e16*e27*e48 + & + e16*e27*e49 + e15*e37*e48 + e15*e37*e49 + & + e16*e37*e48 + e16*e37*e49 + e18*e24*e57 + & + e19*e24*e57 + e18*e34*e57 + e19*e34*e57 + & + e18*e24*e67 + e19*e24*e67 + e18*e34*e67 + & + e19*e34*e67 +!c + basis(32) = e15*e27*e58 + e15*e27*e59 + e16*e27*e68 + & + e16*e27*e69 + e15*e37*e58 + e15*e37*e59 + & + e16*e37*e68 + e16*e37*e69 + e15*e28*e48 + & + e15*e38*e48 + e15*e29*e49 + e15*e39*e49 + & + e16*e28*e48 + e16*e38*e48 + e16*e29*e49 + & + e16*e39*e49 + e25*e27*e48 + e26*e27*e48 + & + e35*e37*e48 + e36*e37*e48 + e25*e27*e49 + & + e26*e27*e49 + e35*e37*e49 + e36*e37*e49 + & + e24*e28*e57 + e24*e29*e57 + e34*e38*e57 + & + e34*e39*e57 + e24*e28*e67 + e24*e29*e67 + & + e34*e38*e67 + e34*e39*e67 + e18*e25*e57 + & + e18*e35*e57 + e18*e26*e67 + e18*e36*e67 + & + e19*e25*e57 + e19*e35*e57 + e19*e26*e67 + & + e19*e36*e67 + e18*e24*e58 + e18*e24*e68 + & + e19*e24*e59 + e19*e24*e69 + e18*e34*e58 + & + e18*e34*e68 + e19*e34*e59 + e19*e34*e69 +!c + basis(33) = e15*e27*e68 + e15*e27*e69 + e16*e27*e58 + & + e16*e27*e59 + e15*e37*e68 + e15*e37*e69 + & + e16*e37*e58 + e16*e37*e59 + e15*e29*e48 + & + e15*e39*e48 + e15*e28*e49 + e15*e38*e49 + & + e16*e29*e48 + e16*e39*e48 + e16*e28*e49 + & + e16*e38*e49 + e27*e35*e48 + e27*e36*e48 + & + e25*e37*e48 + e26*e37*e48 + e27*e35*e49 + & + e27*e36*e49 + e25*e37*e49 + e26*e37*e49 + & + e24*e38*e57 + e24*e39*e57 + e28*e34*e57 + & + e29*e34*e57 + e24*e38*e67 + e24*e39*e67 + & + e28*e34*e67 + e29*e34*e67 + e18*e26*e57 + & + e18*e36*e57 + e18*e25*e67 + e18*e35*e67 + & + e19*e26*e57 + e19*e36*e57 + e19*e25*e67 + & + e19*e35*e67 + e18*e24*e59 + e18*e24*e69 + & + e19*e24*e58 + e19*e24*e68 + e18*e34*e59 + & + e18*e34*e69 + e19*e34*e58 + e19*e34*e68 +!c + basis(34) = e15*e28*e57 + e15*e29*e57 + e16*e28*e67 + & + e16*e29*e67 + e15*e38*e57 + e15*e39*e57 + & + e16*e38*e67 + e16*e39*e67 + e18*e25*e48 + & + e18*e35*e48 + e19*e25*e49 + e19*e35*e49 + & + e18*e26*e48 + e18*e36*e48 + e19*e26*e49 + & + e19*e36*e49 + e24*e27*e58 + e24*e27*e68 + & + e34*e37*e58 + e34*e37*e68 + e24*e27*e59 + & + e24*e27*e69 + e34*e37*e59 + e34*e37*e69 +!c + basis(35) = e15*e28*e58 + e15*e29*e59 + e16*e28*e68 + & + e16*e29*e69 + e15*e38*e58 + e15*e39*e59 + & + e16*e38*e68 + e16*e39*e69 + e25*e28*e48 + & + e35*e38*e48 + e25*e29*e49 + e35*e39*e49 + & + e26*e28*e48 + e36*e38*e48 + e26*e29*e49 + & + e36*e39*e49 + e25*e27*e58 + e26*e27*e68 + & + e35*e37*e58 + e36*e37*e68 + e25*e27*e59 + & + e26*e27*e69 + e35*e37*e59 + e36*e37*e69 + & + e24*e28*e58 + e24*e29*e59 + e34*e38*e58 + & + e34*e39*e59 + e24*e28*e68 + e24*e29*e69 + & + e34*e38*e68 + e34*e39*e69 + e25*e28*e57 + & + e35*e38*e57 + e26*e28*e67 + e36*e38*e67 + & + e25*e29*e57 + e35*e39*e57 + e26*e29*e67 + & + e36*e39*e67 + e18*e25*e58 + e18*e26*e68 + & + e19*e25*e59 + e19*e26*e69 + e18*e35*e58 + & + e18*e36*e68 + e19*e35*e59 + e19*e36*e69 +!c + basis(36) = e15*e28*e59 + e15*e29*e58 + e16*e28*e69 + & + e16*e29*e68 + e15*e38*e59 + e15*e39*e58 + & + e16*e38*e69 + e16*e39*e68 + e25*e38*e48 + & + e28*e35*e48 + e25*e39*e49 + e29*e35*e49 + & + e26*e38*e48 + e28*e36*e48 + e26*e39*e49 + & + e29*e36*e49 + e26*e27*e58 + e25*e27*e68 + & + e36*e37*e58 + e35*e37*e68 + e26*e27*e59 + & + e25*e27*e69 + e36*e37*e59 + e35*e37*e69 + & + e24*e29*e58 + e24*e28*e59 + e34*e39*e58 + & + e34*e38*e59 + e24*e29*e68 + e24*e28*e69 + & + e34*e39*e68 + e34*e38*e69 + e28*e35*e57 + & + e25*e38*e57 + e28*e36*e67 + e26*e38*e67 + & + e29*e35*e57 + e25*e39*e57 + e29*e36*e67 + & + e26*e39*e67 + e18*e25*e68 + e18*e26*e58 + & + e19*e25*e69 + e19*e26*e59 + e18*e35*e68 + & + e18*e36*e58 + e19*e35*e69 + e19*e36*e59 +!c + basis(37) = e15*e28*e67 + e15*e29*e67 + e16*e28*e57 + & + e16*e29*e57 + e15*e38*e67 + e15*e39*e67 + & + e16*e38*e57 + e16*e39*e57 + e19*e25*e48 + & + e19*e35*e48 + e18*e25*e49 + e18*e35*e49 + & + e19*e26*e48 + e19*e36*e48 + e18*e26*e49 + & + e18*e36*e49 + e27*e34*e58 + e27*e34*e68 + & + e24*e37*e58 + e24*e37*e68 + e27*e34*e59 + & + e27*e34*e69 + e24*e37*e59 + e24*e37*e69 +!c + basis(38) = e15*e28*e68 + e15*e29*e69 + e16*e28*e58 + & + e16*e29*e59 + e15*e38*e68 + e15*e39*e69 + & + e16*e38*e58 + e16*e39*e59 + e25*e29*e48 + & + e35*e39*e48 + e25*e28*e49 + e35*e38*e49 + & + e26*e29*e48 + e36*e39*e48 + e26*e28*e49 + & + e36*e38*e49 + e27*e35*e58 + e27*e36*e68 + & + e25*e37*e58 + e26*e37*e68 + e27*e35*e59 + & + e27*e36*e69 + e25*e37*e59 + e26*e37*e69 + & + e24*e38*e58 + e24*e39*e59 + e28*e34*e58 + & + e29*e34*e59 + e24*e38*e68 + e24*e39*e69 + & + e28*e34*e68 + e29*e34*e69 + e26*e28*e57 + & + e36*e38*e57 + e25*e28*e67 + e35*e38*e67 + & + e26*e29*e57 + e36*e39*e57 + e25*e29*e67 + & + e35*e39*e67 + e18*e25*e59 + e18*e26*e69 + & + e19*e25*e58 + e19*e26*e68 + e18*e35*e59 + & + e18*e36*e69 + e19*e35*e58 + e19*e36*e68 +!c + basis(39) = e15*e28*e69 + e15*e29*e68 + e16*e28*e59 + & + e16*e29*e58 + e15*e38*e69 + e15*e39*e68 + & + e16*e38*e59 + e16*e39*e58 + e25*e39*e48 + & + e29*e35*e48 + e25*e38*e49 + e28*e35*e49 + & + e26*e39*e48 + e29*e36*e48 + e26*e38*e49 + & + e28*e36*e49 + e27*e36*e58 + e27*e35*e68 + & + e26*e37*e58 + e25*e37*e68 + e27*e36*e59 + & + e27*e35*e69 + e26*e37*e59 + e25*e37*e69 + & + e24*e39*e58 + e24*e38*e59 + e29*e34*e58 + & + e28*e34*e59 + e24*e39*e68 + e24*e38*e69 + & + e29*e34*e68 + e28*e34*e69 + e28*e36*e57 + & + e26*e38*e57 + e28*e35*e67 + e25*e38*e67 + & + e29*e36*e57 + e26*e39*e57 + e29*e35*e67 + & + e25*e39*e67 + e18*e25*e69 + e18*e26*e59 + & + e19*e25*e68 + e19*e26*e58 + e18*e35*e69 + & + e18*e36*e59 + e19*e35*e68 + e19*e36*e58 +!c + basis(40) = e25*e28*e58 + e25*e29*e59 + e26*e28*e68 + & + e26*e29*e69 + e35*e38*e58 + e35*e39*e59 + & + e36*e38*e68 + e36*e39*e69 +!c + basis(41) = e25*e28*e59 + e25*e29*e58 + e26*e28*e69 + & + e26*e29*e68 + e35*e38*e59 + e35*e39*e58 + & + e36*e38*e69 + e36*e39*e68 + e25*e38*e58 + & + e28*e35*e58 + e25*e39*e59 + e29*e35*e59 + & + e26*e38*e68 + e28*e36*e68 + e26*e39*e69 + & + e29*e36*e69 + e26*e28*e58 + e25*e28*e68 + & + e36*e38*e58 + e35*e38*e68 + e26*e29*e59 + & + e25*e29*e69 + e36*e39*e59 + e35*e39*e69 +!c + basis(42) = e25*e28*e69 + e25*e29*e68 + e26*e28*e59 + & + e26*e29*e58 + e35*e38*e69 + e35*e39*e68 + & + e36*e38*e59 + e36*e39*e58 + e25*e39*e58 + & + e29*e35*e58 + e25*e38*e59 + e28*e35*e59 + & + e26*e39*e68 + e29*e36*e68 + e26*e38*e69 + & + e28*e36*e69 + e28*e36*e58 + e28*e35*e68 + & + e26*e38*e58 + e25*e38*e68 + e29*e36*e59 + & + e29*e35*e69 + e26*e39*e59 + e25*e39*e69 +!c + basis(43) = e25*e38*e69 + e25*e39*e68 + e26*e38*e59 + & + e26*e39*e58 + e28*e35*e69 + e29*e35*e68 + & + e28*e36*e59 + e29*e36*e58 +!c --------------------------------------------------------------------- + return + end subroutine calc_basis_1 + + end module IPModel_WaterTrimer_Gillan_module + + + diff --git a/src/Potentials/IPModel_ZBL.F90 b/src/Potentials/IPModel_ZBL.F90 new file mode 100644 index 0000000000..a612f8553c --- /dev/null +++ b/src/Potentials/IPModel_ZBL.F90 @@ -0,0 +1,311 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_ZBL +!X +!% Module for Ziegler-Biersack-Littmark potential for +!% screened nuclear repulsion +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_ZBL_module + +use error_module +use system_module, only : dp, inoutput, print, verbosity_push_decrement, verbosity_pop, operator(//) +use units_module +use dictionary_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use periodictable_module, only : ElementCovRad + +use mpi_context_module +use QUIP_Common_module + +implicit none +private + +include 'IPModel_interface.h' + +public :: IPModel_ZBL +type IPModel_ZBL + real(dp) :: cutoff = 0.0 + real(dp) :: use_cutoff = 0.0 + real(dp) :: cutoff_width = 0.0 + logical :: shift_cutoff = .false., cutoff_scale_cov_rad = .false. + real(dp) :: a_pre_exp = 0.46850 + real(dp) :: a_exp = 0.23 + real(dp) :: p_pre_exp_1 = 0.18175 + real(dp) :: p_exp_1 = -3.19980 + real(dp) :: p_pre_exp_2 = 0.50986 + real(dp) :: p_exp_2 = -0.94229 + real(dp) :: p_pre_exp_3 = 0.28022 + real(dp) :: p_exp_3 = -0.40290 + real(dp) :: p_pre_exp_4 = 0.02817 + real(dp) :: p_exp_4 = -0.20162 + real(dp) :: E_scale + character(len=STRING_LENGTH) :: label + +end type IPModel_ZBL + +logical, private :: parse_in_ip, parse_matched_label +type(IPModel_ZBL), private, pointer :: parse_ip + +interface Initialise + module procedure IPModel_ZBL_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_ZBL_Finalise +end interface Finalise + +interface Print + module procedure IPModel_ZBL_Print +end interface Print + +interface Calc + module procedure IPModel_ZBL_Calc +end interface Calc + +contains + +subroutine IPModel_ZBL_Initialise_str(this, args_str, param_str) + type(IPModel_ZBL), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_ZBL_Initialise_str args_str')) then + call system_abort("IPModel_ZBL_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call param_register(params, 'E_scale', '1.0', this%E_scale, help_string="E_scale") + call param_register(params, 'cutoff', '0.0', this%cutoff, help_string="cutoff") + call param_register(params, 'cutoff_width', '0.0', this%cutoff_width, help_string="smooth cutoff width") + call param_register(params, 'shift_cutoff', 'F', this%shift_cutoff, help_string="shift value at cutoff to equal 0") + call param_register(params, 'cutoff_scale_cov_rad', 'F', this%cutoff_scale_cov_rad, help_string="multiply cutoff by sum of covalent radii (but cutoff_width is absolute)") + call param_register(params, 'a_pre_exp', '0.46850', this%a_pre_exp, help_string="pre-exponential factor for screening parameter") + call param_register(params, 'a_exp', '0.23', this%a_exp, help_string="exponent of charge of nuclei") + call param_register(params, 'p_pre_exp_1', '0.18175', this%p_pre_exp_1, help_string="first pre-exponential factor of screening function") + call param_register(params, 'p_exp_1', '-3.19980', this%p_exp_1, help_string="first exponent of screening function") + call param_register(params, 'p_pre_exp_2', '0.50986', this%p_pre_exp_2, help_string="second pre-exponential factor of screening function") + call param_register(params, 'p_exp_2', '-0.94229', this%p_exp_2, help_string="second exponent of screening function") + call param_register(params, 'p_pre_exp_3', '0.28022', this%p_pre_exp_3, help_string="third pre-exponential factor of screening function") + call param_register(params, 'p_exp_3', '-0.40290', this%p_exp_3, help_string="third exponent of screening function") + call param_register(params, 'p_pre_exp_4', '0.02817', this%p_pre_exp_4, help_string="fourth pre-exponential factor of screening function") + call param_register(params, 'p_exp_4', '-0.20162', this%p_exp_4, help_string="fourth exponent of screening function") + + if (param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_ZBL_Initialise_str args_str')) then + end if + + ! by default cutoff used is cutoff set + this%use_cutoff = this%cutoff + if (this%cutoff_scale_cov_rad) then + ! if cutoff is actually scale for covalent rad sum, set externally accessible + ! cutoff to be max possible value for any element + this%cutoff = 2.0*maxval(ElementCovRad) + endif + + call finalise(params) + +end subroutine IPModel_ZBL_Initialise_str + +subroutine IPModel_ZBL_Finalise(this) + type(IPModel_ZBL), intent(inout) :: this + + this%label = '' +end subroutine IPModel_ZBL_Finalise + +subroutine IPModel_ZBL_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_ZBL), intent(inout):: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) + character(len=*), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + integer :: i, ji, j + logical :: i_is_min_image + real(dp) :: ke_e2 = 14.3996458521 !% Coulomb's constant x elemntary charge^{2} in eV*A + real(dp) :: r, rs, dr(3) + real(dp) :: a, c + real(dp) :: t_1, t_2, t_3, t_4 + real(dp) :: rs_shifted, t_1_shifted, t_2_shifted, t_3_shifted, t_4_shifted, c_shifted + real(dp) :: de, de_dr + real(dp) :: f_cut = 1.0, df_cut = 0.0 + real(dp) :: use_cutoff + + type(Dictionary) :: params + logical :: has_atom_mask_name + logical, dimension(:), pointer :: atom_mask_pointer + character(STRING_LENGTH) :: atom_mask_name + + INIT_ERROR(error) + + if (present(e)) e = 0.0 + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_ZBL_Calc', error) + local_e = 0.0 + endif + if (present(f)) then + call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_ZBL_Calc', error) + f = 0.0 + end if + if (present(virial)) virial = 0.0 + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_ZBL_Calc', error) + local_virial = 0.0 + RAISE_ERROR('IPModel_ZBL_Calc: local_virial calculation requested but not supported yet',error) + endif + if (present(local_e)) then + RAISE_ERROR('IPModel_ZBL_Calc: local_e calculation requested but not supported yet',error) + end if + + atom_mask_pointer => null() + if (present(args_str)) then + call initialise(params) + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target = has_atom_mask_name, help_string="name of atom_mask property") + if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='IPModel_ZBL_args_str')) then + RAISE_ERROR("IPModel_ZBL_Calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + endif + if (has_atom_mask_name) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) then + RAISE_ERROR("IPModel_ZBL_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.", error) + endif + endif + + use_cutoff = this%use_cutoff + do i = 1, at%N + if (associated(atom_mask_pointer)) then + if (.not. atom_mask_pointer(i)) cycle + endif + + i_is_min_image = is_min_image(at,i) + + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + do ji = 1, n_neighbours(at, i) + j = neighbour(at, i, ji, distance=r, cosines=dr) + + ! if (i < j) cycle + + if (this%cutoff_scale_cov_rad) use_cutoff = this%use_cutoff * (ElementCovRad(at%Z(i))+ElementCovRad(at%Z(j))) + + if (use_cutoff == 0.0 .or. r <= use_cutoff) then + c = ke_e2*real(at%Z(i))*real(at%Z(j))/r + a = this%a_pre_exp/(real(at%Z(i))**this%a_exp + real(at%Z(j))**this%a_exp) + rs = r/a + t_1 = this%p_pre_exp_1*exp(this%p_exp_1*rs) + t_2 = this%p_pre_exp_2*exp(this%p_exp_2*rs) + t_3 = this%p_pre_exp_3*exp(this%p_exp_3*rs) + t_4 = this%p_pre_exp_4*exp(this%p_exp_4*rs) + if (use_cutoff > 0.0 .and. this%cutoff_width > 0.0) f_cut = poly_switch(r, use_cutoff, this%cutoff_width) + de = c*(t_1+t_2+t_3+t_4) + if (this%shift_cutoff) then + c_shifted = ke_e2*real(at%Z(i))*real(at%Z(j))/use_cutoff + rs_shifted = use_cutoff/a + t_1_shifted = this%p_pre_exp_1*exp(this%p_exp_1*rs_shifted) + t_2_shifted = this%p_pre_exp_2*exp(this%p_exp_2*rs_shifted) + t_3_shifted = this%p_pre_exp_3*exp(this%p_exp_3*rs_shifted) + t_4_shifted = this%p_pre_exp_4*exp(this%p_exp_4*rs_shifted) + de = de - c_shifted*(t_1_shifted+t_2_shifted+t_3_shifted+t_4_shifted) + endif + if (present(e)) then + e = e + 0.5*de*f_cut + end if + if (present(f) .or. present(virial)) then + if (use_cutoff > 0.0 .and. this%cutoff_width > 0.0) df_cut = dpoly_switch(r, use_cutoff, this%cutoff_width) + de_dr = -c/r*(t_1+t_2+t_3+t_4) + c/a*(this%p_exp_1*t_1+this%p_exp_2*t_2+this%p_exp_3*t_3+this%p_exp_4*t_4) + de_dr = de_dr*f_cut + de*df_cut + if (present(f)) then + f(:,i) = f(:,i) + 0.5*de_dr*dr + f(:,j) = f(:,j) - 0.5*de_dr*dr + end if + if (present(virial)) then + virial = virial - 0.5_dp*de_dr*(dr .outer. dr)*r + endif + end if + end if + end do + end do + + if(present(e)) e = e*this%E_scale + if(present(f)) f = f*this%E_scale + if(present(virial)) virial = virial*this%E_scale + if(present(local_e)) local_e = local_e*this%E_scale + + if (present(mpi)) then + if (present(e)) e = sum(mpi, e) + if (present(local_e)) call sum_in_place(mpi, local_e) + if (present(virial)) call sum_in_place(mpi, virial) + if (present(f)) call sum_in_place(mpi, f) + endif + +end subroutine IPModel_ZBL_Calc + + +subroutine IPModel_ZBL_Print(this, file) + type(IPModel_ZBL), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call Print("IPModel_ZBL : ZBL Potential", file=file) + call Print("IPModel_ZBL : cutoff = " // this%cutoff, file=file) + call Print("IPModel_ZBL : cutoff_width = " // this%cutoff_width, file=file) + call Print("IPModel_ZBL : a_pre_exp = " // this%a_pre_exp, file=file) + call Print("IPModel_ZBL : a_exp = " // this%a_exp, file=file) + call Print("IPModel_ZBL : p_pre_exp_1 = " // this%p_pre_exp_1, file=file) + call Print("IPModel_ZBL : p_exp_1 = " // this%p_exp_1, file=file) + call Print("IPModel_ZBL : p_pre_exp_2 = " // this%p_pre_exp_2, file=file) + call Print("IPModel_ZBL : p_exp_2 = " // this%p_exp_2, file=file) + call Print("IPModel_ZBL : p_pre_exp_3 = " // this%p_pre_exp_3, file=file) + call Print("IPModel_ZBL : p_exp_3 = " // this%p_exp_3, file=file) + call Print("IPModel_ZBL : p_pre_exp_4 = " // this%p_pre_exp_4, file=file) + call Print("IPModel_ZBL : p_exp_4 = " // this%p_exp_4, file=file) + +end subroutine IPModel_ZBL_Print + +end module IPModel_ZBL_module diff --git a/src/Potentials/IPModel_vdW.F90 b/src/Potentials/IPModel_vdW.F90 new file mode 100644 index 0000000000..1a1607f26c --- /dev/null +++ b/src/Potentials/IPModel_vdW.F90 @@ -0,0 +1,899 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IPModel_vdW module +!X +!% Module for Gaussian Approximation Potential. +!% +!% The IPModel_vdW object contains all the parameters read from a +!% 'vdW_params' XML stanza. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module IPModel_vdW_module + +use error_module +use system_module, only : idp, dp, inoutput, string_to_int, reallocate, system_timer , print, PRINT_NERD +use units_module +use dictionary_module +use periodictable_module, only: total_elements +use extendable_str_module +use paramreader_module +use linearalgebra_module +use atoms_types_module +use atoms_module + +use mpi_context_module +use QUIP_Common_module + +#ifdef HAVE_GAP +use descriptors_module +use gp_predict_module +#endif + +implicit none + +private + +include 'IPModel_interface.h' + +#ifdef GAP_VERSION + integer, parameter :: gap_version = GAP_VERSION +#else + integer, parameter :: gap_version = 0 +#endif + +! this stuff is here for now, but it should live somewhere else eventually +! lower down in the GP + +public :: IPModel_vdW + +type IPModel_vdW + + real(dp) :: cutoff = 0.0_dp !% Cutoff for computing connection. + + real(dp) :: E_scale = 0.0_dp !% scale factor for the potential + real(dp) :: sr = 0.0_dp + real(dp) :: d = 0.0_dp + real(dp) :: vdW_cutoff = 0.0_dp + real(dp) :: vdW_cutoff_buffer = 0.0_dp + + character(len=STRING_LENGTH) :: label + +#ifdef HAVE_GAP + type(gpSparse) :: my_gp + type(descriptor), dimension(:), allocatable :: my_descriptor +#endif + real(dp), dimension(total_elements) :: e0 = 0.0_dp + integer(idp), dimension(total_elements) :: map = -1 + integer :: n_types = 0 + integer, dimension(:), allocatable :: Z + real(dp), dimension(:), allocatable :: r0 + real(dp), dimension(:), allocatable :: alpha0 + real(dp), dimension(:), allocatable :: c6 + real(dp), dimension(:,:), allocatable :: c6_pair + + + logical :: initialised = .false. + type(extendable_str) :: command_line + integer :: xml_version + +end type IPModel_vdW + +logical, private :: parse_in_ip, parse_in_vdW_data, parse_matched_label, parse_in_ip_done + +type(IPModel_vdW), private, pointer :: parse_ip +type(extendable_str), save :: parse_cur_data + +interface Initialise + module procedure IPModel_vdW_Initialise_str +end interface Initialise + +interface Finalise + module procedure IPModel_vdW_Finalise +end interface Finalise + +interface Print + module procedure IPModel_vdW_Print +end interface Print + +interface Calc + module procedure IPModel_vdW_Calc +end interface Calc + +contains + +subroutine IPModel_vdW_Initialise_str(this, args_str, param_str) + type(IPModel_vdW), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(Dictionary) :: params + + integer :: n, m, i_coordinate + + call Finalise(this) + + ! now initialise the potential +#ifndef HAVE_GAP + call system_abort('IPModel_vdW_Initialise_str: must be compiled with HAVE_GAP') +#else + + call initialise(params) + this%label='' + + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'E_scale', '1.0', this%E_scale, help_string="rescaling factor for the potential") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_SW_Initialise_str args_str')) & + call system_abort("IPModel_vdW_Initialise_str failed to parse label from args_str="//trim(args_str)) + call finalise(params) + + call IPModel_vdW_read_params_xml(this, param_str) + call gp_readXML(this%my_gp, param_str,label=trim(this%label)) + + do n = 1, this%n_types + this%map(this%Z(n)) = n + enddo + + allocate(this%c6_pair(this%n_types,this%n_types)) + do n = 1, this%n_types + do m = 1, this%n_types + this%c6_pair(m,n) = 2.0_dp * ( this%alpha0(n)*this%alpha0(m)*this%c6(n)*this%c6(m) ) / & + ( this%alpha0(n)**2 * this%c6(m) + this%alpha0(m)**2 * this%c6(n) ) + enddo + enddo + + allocate(this%my_descriptor(this%my_gp%n_coordinate)) + + this%cutoff = 0.0_dp + do i_coordinate = 1, this%my_gp%n_coordinate + call concat(this%my_gp%coordinate(i_coordinate)%descriptor_str," xml_version="//this%xml_version) + call initialise(this%my_descriptor(i_coordinate),string(this%my_gp%coordinate(i_coordinate)%descriptor_str)) + this%cutoff = max(this%cutoff,cutoff(this%my_descriptor(i_coordinate))) + enddo + this%cutoff = max(this%cutoff,this%vdW_cutoff) + +#endif + +end subroutine IPModel_vdW_Initialise_str + +subroutine IPModel_vdW_Finalise(this) + type(IPModel_vdW), intent(inout) :: this +#ifdef HAVE_GAP + + if (this%my_gp%initialised) call finalise(this%my_gp) + if(allocated(this%Z)) deallocate(this%Z) + if(allocated(this%r0)) deallocate(this%r0) + if(allocated(this%alpha0)) deallocate(this%alpha0) + if(allocated(this%c6)) deallocate(this%c6) + if(allocated(this%c6_pair)) deallocate(this%c6_pair) + this%n_types = 0 + this%map = -1 + + this%cutoff = 0.0_dp + this%vdW_cutoff = 0.0_dp + this%sr = 0.0_dp + this%d = 0.0_dp + + this%label = '' + this%initialised = .false. +#endif + + call finalise(this%command_line) + +end subroutine IPModel_vdW_Finalise + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% The potential calculator: this routine computes energy, forces and the virial. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_vdW_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error) + type(IPModel_vdW), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: e, local_e(:) !% \texttt{e} = System total energy, \texttt{local_e} = energy of each atom, vector dimensioned as \texttt{at%N}. + real(dp), intent(out), optional :: f(:,:), local_virial(:,:) !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)} + real(dp), intent(out), optional :: virial(3,3) !% Virial + character(len=*), intent(in), optional :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + +#ifdef HAVE_GAP + type v_data + real(dp) :: v + integer :: n_lo, n_up + integer, dimension(:), allocatable :: j + real(dp), dimension(:,:), allocatable :: deriv + real(dp), dimension(:,:), allocatable :: diff + endtype v_data + + character(STRING_LENGTH) :: atom_mask_name + + logical :: has_atom_mask_name, do_rescale_r, do_rescale_E, do_select_descriptor, do_derivative + logical, dimension(:), pointer :: atom_mask_pointer + logical, dimension(:), allocatable :: mpi_local_mask + + integer :: only_descriptor, i_coordinate, d, i, j, k, i_desc, n, m + + real(dp) :: r_scale, E_scale, v_i, v_i_cutoff, r_ij, & + r6_ij, dr6_ij_dr_ij, scaled_buffer, f_cut_ij, df_cut_ij_dr_ij, & + c6_eff, r0_ij, d_sR_r0_ij, exp_factor, f_damp, e_i, & + df_damp_dr_ij, df_damp_dr0_ij, df_damp_dvi, df_damp_dvj, dc6_eff_dvi, dc6_eff_dvj, & + de_i_dr_ij + real(dp), dimension(3) :: v_deriv, u_ij, f_ij, de_i_drk + real(dp), dimension(:), allocatable :: grad_predict, r0_eff, dr0_eff_dv + real(dp), dimension(:), allocatable :: local_e_in + real(dp), dimension(:,:), allocatable :: f_in + real(dp), dimension(:,:,:), allocatable :: virial_in + + type(Dictionary) :: params + type(descriptor_data), target :: my_descriptor_data + type(extendable_str) :: my_args_str + type(v_data), dimension(:), allocatable :: local_v + + !real(dp) :: e_i, e_i_cutoff + !integer :: d, i, j, n, m, i_coordinate, i_pos0 + + + !real(dp), dimension(3) :: pos, f_gp + !real(dp), dimension(3,3) :: virial_i + !type(Dictionary) :: params + !logical :: has_atom_mask_name + !character(STRING_LENGTH) :: atom_mask_name, calc_local_gap_variance, calc_energy_per_coordinate + !real(dp) :: r_scale, E_scale + + !real(dp) :: gap_variance_i_cutoff + !real(dp), dimension(:), allocatable :: gap_variance, local_gap_variance_in + !real(dp), dimension(:), pointer :: local_gap_variance_pointer + !real(dp), dimension(:,:), allocatable :: gap_variance_gradient_in + !real(dp), dimension(:,:), pointer :: gap_variance_gradient_pointer + !real(dp) :: gap_variance_regularisation + !logical :: do_rescale_r, do_rescale_E, do_gap_variance, print_gap_variance, do_local_gap_variance, do_energy_per_coordinate + !integer :: only_descriptor + !logical :: do_select_descriptor + !logical :: mpi_parallel_descriptor + + !type(descriptor_data) :: my_descriptor_data + !type(extendable_str) :: my_args_str + + INIT_ERROR(error) + + if (present(e)) then + e = 0.0_dp + endif + + if (present(local_e)) then + call check_size('Local_E',local_e,(/at%N/),'IPModel_vdW_Calc', error) + local_e = 0.0_dp + endif + + if (present(f)) then + call check_size('Force',f,(/3,at%N/),'IPModel_vdW_Calc', error) + f = 0.0_dp + end if + + if (present(virial)) then + virial = 0.0_dp + endif + + if (present(local_virial)) then + call check_size('Local_virial',local_virial,(/9,at%N/),'IPModel_vdW_Calc', error) + local_virial = 0.0_dp + endif + + do_derivative = present(f) .or. present(virial) .or. present(local_virial) + + atom_mask_pointer => null() + has_atom_mask_name = .false. + atom_mask_name = "" + only_descriptor = 0 + + if( any(this%map(at%Z) == -1) ) then + RAISE_ERROR("IPModel_vdW_Calc: atoms object contains atom types for which vdW parameters were not specified",error) + endif + + call initialise(params) + + call param_register(params, 'atom_mask_name', 'NONE',atom_mask_name,has_value_target=has_atom_mask_name, & + help_string="Name of a logical property in the atoms object. For atoms where this property is true, energies, forces, virials etc. are " // & + "calculated") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Rescaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Rescaling factor for energy. Default 1.0.") + call param_register(params, 'only_descriptor', '0', only_descriptor, has_value_target=do_select_descriptor, help_string="Only select a single coordinate") + + if(present(args_str)) then + if (.not. param_read_line(params,args_str,ignore_unknown=.true.,task='IPModel_vdW_Calc args_str')) & + call system_abort("IPModel_vdW_Calc failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + + if( has_atom_mask_name ) then + if (.not. assign_pointer(at, trim(atom_mask_name) , atom_mask_pointer)) & + call system_abort("IPModel_vdW_Calc did not find "//trim(atom_mask_name)//" property in the atoms object.") + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("IPModel_vdW_Calc: rescaling of potential at the calc() stage with r_scale and E_scale not yet implemented!", error) + end if + + my_args_str = trim(args_str) + else + ! call parser to set defaults + if (.not. param_read_line(params,"",ignore_unknown=.true.,task='IPModel_vdW_Calc args_str')) & + call system_abort("IPModel_vdW_Calc failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + call initialise(my_args_str) + endif + + if( present(mpi) ) then + if(mpi%active) then + if(has_atom_mask_name) then + RAISE_ERROR("IPModel_vdW: atom_mask_name "//trim(atom_mask_name)//" present while running MPI version."// \ + " The use of atom_mask_name is intended for serial-compiled code called from an external parallel code, such as LAMMPS",error) + endif + + if( has_property(at,"mpi_local_mask") ) then + RAISE_ERROR("IPModel_vdW: mpi_local_mask property already present", error) + endif + + allocate(mpi_local_mask(at%N)) + call add_property_from_pointer(at,'mpi_local_mask',mpi_local_mask,error=error) + call concat(my_args_str," atom_mask_name=mpi_local_mask") + endif + endif + + call concat(my_args_str," xml_version="//this%xml_version) + + allocate(local_v(at%N)) + do i = 1, at%N + local_v(i)%v = this%e0(at%Z(i)) + enddo + + do i_coordinate = 1, this%my_gp%n_coordinate + + if (do_select_descriptor .and. (this%my_gp%n_coordinate > 1)) then + if (i_coordinate /= only_descriptor) then + call print("vdW label="//trim(this%label)//" skipping coordinate "//i_coordinate, PRINT_NERD) + cycle + end if + end if + + if(mpi%active) call descriptor_MPI_setup(this%my_descriptor(i_coordinate),at,mpi,mpi_local_mask,error) + + d = descriptor_dimensions(this%my_descriptor(i_coordinate)) + + if( do_derivative ) then + if (allocated(grad_predict)) deallocate(grad_predict) + allocate(grad_predict(d)) + end if + call calc(this%my_descriptor(i_coordinate),at,my_descriptor_data, & + do_descriptor=.true.,do_grad_descriptor=present(f) .or. present(virial) .or. present(local_virial), args_str=trim(string(my_args_str)), error=error) + PASS_ERROR(error) + do i_desc = 1, size(my_descriptor_data%x) + if( size(my_descriptor_data%x(i_desc)%ci) /= 1 ) then + RAISE_ERROR("IPModel_vdW_Calc: descriptor is not local and atomic",error) + endif + i = my_descriptor_data%x(i_desc)%ci(1) + + if ( do_derivative ) then + local_v(i)%n_lo = lbound(my_descriptor_data%x(i_desc)%ii,1) + local_v(i)%n_up = ubound(my_descriptor_data%x(i_desc)%ii,1) + allocate(local_v(i)%deriv(3,local_v(i)%n_lo:local_v(i)%n_up), & + local_v(i)%j(local_v(i)%n_lo:local_v(i)%n_up), & + local_v(i)%diff(3,local_v(i)%n_lo:local_v(i)%n_up)) + do n = local_v(i)%n_lo, local_v(i)%n_up + local_v(i)%diff(:,n) = my_descriptor_data%x(i_desc)%pos(:,n) - & + my_descriptor_data%x(i_desc)%pos(:,local_v(i)%n_lo) + enddo + local_v(i)%j = my_descriptor_data%x(i_desc)%ii + local_v(i)%deriv = 0.0_dp + endif + enddo + +!$omp parallel default(none) private(i_desc,n,i,grad_predict,v_i,v_i_cutoff,v_deriv) & +!$omp shared(this,d,i_coordinate,my_descriptor_data,f,virial,local_virial,local_v,do_derivative) +!$omp do schedule(dynamic) + do i_desc = 1, size(my_descriptor_data%x) + if(present(f) .or. present(virial) .or. present(local_virial)) then + call reallocate(grad_predict,d,zero=.true.) + v_i = gp_predict(this%my_gp%coordinate(i_coordinate), & + xStar=my_descriptor_data%x(i_desc)%data(:), & + gradPredict = grad_predict ) + else + v_i = gp_predict(this%my_gp%coordinate(i_coordinate), xStar=my_descriptor_data%x(i_desc)%data(:)) + endif + + v_i_cutoff = v_i * my_descriptor_data%x(i_desc)%covariance_cutoff + i = my_descriptor_data%x(i_desc)%ci(1) + local_v(i)%v = local_v(i)%v + v_i_cutoff + + if( do_derivative ) then + do n = lbound(my_descriptor_data%x(i_desc)%ii,1), ubound(my_descriptor_data%x(i_desc)%ii,1) + if( .not. my_descriptor_data%x(i_desc)%has_grad_data(n) ) cycle + v_deriv = matmul( grad_predict,my_descriptor_data%x(i_desc)%grad_data(:,:,n)) * my_descriptor_data%x(i_desc)%covariance_cutoff + & + v_i * my_descriptor_data%x(i_desc)%grad_covariance_cutoff(:,n) + local_v(i)%deriv(:,n) = local_v(i)%deriv(:,n) + v_deriv + enddo + endif + enddo +!$omp end do + if(allocated(grad_predict)) deallocate(grad_predict) +!$omp end parallel + call finalise(my_descriptor_data) + enddo + + ! Has to be allocated as it's in the reduction clause. + allocate(local_e_in(at%N)) + local_e_in = 0.0_dp + + allocate(f_in(3,at%N)) + f_in = 0.0_dp + + allocate(virial_in(3,3,at%N)) + virial_in = 0.0_dp + + allocate(r0_eff(at%N)) + if( do_derivative ) then + allocate(dr0_eff_dv(at%N)) + endif + + do i = 1, at%N + r0_eff(i) = local_v(i)%v**(1.0_dp/3.0_dp) * this%r0(this%map(at%Z(i))) + if( do_derivative ) then + dr0_eff_dv(i) = r0_eff(i) / local_v(i)%v / 3.0_dp + endif + enddo + + +!$omp parallel default(none) private(i,j,k,n,m,r_ij,u_ij,r6_ij,dr6_ij_dr_ij,scaled_buffer,f_cut_ij,df_cut_ij_dr_ij, & +!$omp c6_eff,r0_ij,d_sR_r0_ij,exp_factor,f_damp,e_i,df_damp_dr_ij,df_damp_dr0_ij,df_damp_dvi,df_damp_dvj, & +!$omp dc6_eff_dvi,dc6_eff_dvj,de_i_dr_ij,f_ij,de_i_drk) & +!$omp shared(this,at,e,f,virial,do_derivative,local_v,r0_eff,dr0_eff_dv) & +!$omp reduction(+:local_e_in,f_in,virial_in) +!$omp do schedule(dynamic) + do i = 1, at%N + do n = 1, n_neighbours(at,i) + j = neighbour(at, i, n, distance=r_ij, cosines=u_ij) + + if( r_ij > this%vdW_cutoff ) cycle + + r6_ij = 1.0_dp / r_ij**6 + if( do_derivative ) dr6_ij_dr_ij = -6.0_dp * r6_ij / r_ij + + if( r_ij > this%vdW_cutoff - this%vdW_cutoff_buffer ) then + scaled_buffer = ( r_ij - this%vdW_cutoff + this%vdW_cutoff_buffer ) / this%vdW_cutoff_buffer + f_cut_ij = 1.0_dp - 3.0_dp*scaled_buffer**2 + 2.0_dp*scaled_buffer**3 + + if( do_derivative ) then + df_cut_ij_dr_ij = -6.0_dp*(scaled_buffer+scaled_buffer**2) / this%vdW_cutoff_buffer + dr6_ij_dr_ij = dr6_ij_dr_ij*f_cut_ij + r6_ij*df_cut_ij_dr_ij + endif + r6_ij = r6_ij*f_cut_ij + endif + + c6_eff = local_v(i)%v * local_v(j)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i))) + r0_ij = r0_eff(i) + r0_eff(j) + + d_sR_r0_ij = this%d / this%sR / r0_ij + exp_factor = exp( -d_sR_r0_ij*r_ij + this%d ) + f_damp = 1.0_dp / ( 1.0_dp + exp_factor ) + + e_i = -0.5*f_damp*c6_eff*r6_ij + local_e_in(i) = local_e_in(i) + e_i + + if(do_derivative) then + df_damp_dr_ij = f_damp**2 * exp_factor * d_sR_r0_ij + df_damp_dr0_ij = -df_damp_dr_ij * r_ij / r0_ij + + df_damp_dvi = df_damp_dr0_ij * dr0_eff_dv(i) + df_damp_dvj = df_damp_dr0_ij * dr0_eff_dv(j) + + dc6_eff_dvi = local_v(j)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i))) + dc6_eff_dvj = local_v(i)%v * this%c6_pair(this%map(at%Z(j)),this%map(at%Z(i))) + + de_i_dr_ij = 0.5_dp*(f_damp*c6_eff*dr6_ij_dr_ij + df_damp_dr_ij*c6_eff*r6_ij) + f_ij = de_i_dr_ij*u_ij + if(present(f)) then + f_in(:,i) = f_in(:,i) - f_ij + f_in(:,j) = f_in(:,j) + f_ij + endif + if(present(virial)) then + virial_in(:,:,j) = virial_in(:,:,j) + ( f_ij .outer. u_ij ) * r_ij + endif + + do m = local_v(i)%n_lo, local_v(i)%n_up + k = local_v(i)%j(m) + de_i_drk = (df_damp_dvi*c6_eff + f_damp*dc6_eff_dvi)*r6_ij* & + local_v(i)%deriv(:,m) + if(present(f)) f_in(:,k) = f_in(:,k) + de_i_drk + if(present(virial)) then + virial_in(:,:,k) = virial_in(:,:,k) + (de_i_drk .outer. local_v(i)%diff(:,m)) + endif + enddo + endif + + enddo + enddo +!$omp end do +!$omp end parallel + + if(present(f)) f = f_in + if(present(e)) e = sum(local_e_in) + if(present(local_e)) local_e = local_e_in + if(present(virial)) virial = sum(virial_in,dim=3) + + if(present(local_virial)) then + do i = 1, at%N + local_virial(:,i) = reshape(virial_in(:,:,i),(/9/)) + enddo + endif + + if(allocated(local_e_in)) deallocate(local_e_in) + if(allocated(f_in)) deallocate(f_in) + if(allocated(virial_in)) deallocate(virial_in) + + if (present(mpi)) then + if( mpi%active ) then + if(present(f)) call sum_in_place(mpi,f) + if(present(virial)) call sum_in_place(mpi,virial) + if(present(local_virial)) call sum_in_place(mpi,local_virial) + if(present(e)) e = sum(mpi,e) + if(present(local_e) ) call sum_in_place(mpi,local_e) + + call remove_property(at,'mpi_local_mask', error=error) + deallocate(mpi_local_mask) + endif + endif + +! if(present(e)) then +! if( associated(atom_mask_pointer) ) then +! e = e + sum(this%e0(at%Z),mask=atom_mask_pointer) +! else +! e = e + sum(this%e0(at%Z)) +! endif +! endif +! +! if(present(local_e)) then +! if( associated(atom_mask_pointer) ) then +! where (atom_mask_pointer) local_e = local_e + this%e0(at%Z) +! else +! local_e = local_e + this%e0(at%Z) +! endif +! endif + + if(present(f)) f = this%E_scale * f + if(present(e)) e = this%E_scale * e + if(present(local_e)) local_e = this%E_scale * local_e + if(present(virial)) virial = this%E_scale * virial + if(present(local_virial)) local_virial = this%E_scale * local_virial + + atom_mask_pointer => null() + call finalise(my_args_str) + + if(allocated(local_v)) then + do i = 1, at%N + local_v(i)%v = 0.0_dp + if(allocated(local_v(i)%deriv)) deallocate(local_v(i)%deriv) + if(allocated(local_v(i)%j)) deallocate(local_v(i)%j) + if(allocated(local_v(i)%diff)) deallocate(local_v(i)%diff) + enddo + deallocate(local_v) + endif + if( allocated(r0_eff) ) deallocate(r0_eff) + if( allocated(dr0_eff_dv) ) deallocate(dr0_eff_dv) + +! if(present(e) .or. present(local_e)) then +! +! e_i_cutoff = e_i * my_descriptor_data%x(i)%covariance_cutoff / size(my_descriptor_data%x(i)%ci) +! call print("vdWDEBUG ci="//my_descriptor_data%x(i)%ci//" e_i="//e_i//" e_i_cutoff="//e_i_cutoff, PRINT_NERD) +! +! do n = 1, size(my_descriptor_data%x(i)%ci) +! local_e_in( my_descriptor_data%x(i)%ci(n) ) = local_e_in( my_descriptor_data%x(i)%ci(n) ) + e_i_cutoff +! enddo +! endif +! +! if(present(f) .or. present(virial) .or. present(local_virial)) then +! i_pos0 = lbound(my_descriptor_data%x(i)%ii,1) +! +! do n = lbound(my_descriptor_data%x(i)%ii,1), ubound(my_descriptor_data%x(i)%ii,1) +! if( .not. my_descriptor_data%x(i)%has_grad_data(n) ) cycle +! j = my_descriptor_data%x(i)%ii(n) +! pos = my_descriptor_data%x(i)%pos(:,n) +! f_gp = matmul( gradPredict,my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff + & +! e_i * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) +! if( present(f) ) then +! f_in(:,j) = f_in(:,j) - f_gp +! endif +! if( do_local_gap_variance ) then +! gap_variance_gradient_in(:,j) = gap_variance_gradient_in(:,j) + & +! matmul( grad_variance_estimate, my_descriptor_data%x(i)%grad_data(:,:,n)) * my_descriptor_data%x(i)%covariance_cutoff**2 + & +! 2.0_dp * gap_variance(i) * my_descriptor_data%x(i)%covariance_cutoff * my_descriptor_data%x(i)%grad_covariance_cutoff(:,n) +! endif +! if( present(virial) .or. present(local_virial) ) then +! virial_i = ((pos-my_descriptor_data%x(i)%pos(:,i_pos0)) .outer. f_gp) +! virial_in(:,:,j) = virial_in(:,:,j) - virial_i +! +! !virial_i = (pos .outer. f_gp) / size(my_descriptor_data%x(i)%ci) +! !do m = 1, size(my_descriptor_data%x(i)%ci) +! ! virial_in(:,:,my_descriptor_data%x(i)%ci(m)) = virial_in(:,:,my_descriptor_data%x(i)%ci(m)) - virial_i +! !enddo +! endif +! enddo +! endif +! enddo loop_over_descriptor_instances +! call system_timer('IPModel_vdW_Calc_gp_predict') + +#endif + +end subroutine IPModel_vdW_Calc + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% XML param reader functions. +!% An example for XML stanza is given below, please notice that +!% they are simply dummy parameters for testing purposes, with no physical meaning. +!% +!%> +!%> +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + + integer :: ri, Z + + if(name == 'vdW_params') then ! new vdW stanza + + if(parse_in_ip) & + call system_abort("IPModel_startElement_handler entered vdW_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if(parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if(status /= 0) value = '' + + if(len(trim(parse_ip%label)) > 0) then ! we were passed in a label + if(value == parse_ip%label) then ! exact match + parse_matched_label = .true. + parse_in_ip = .true. + else ! no match + parse_in_ip = .false. + endif + else ! no label passed in + parse_in_ip = .true. + parse_ip%label = trim(value) ! if we found a label, AND didn't have one originally, pass it back to the object. + endif + + if(parse_in_ip) then + if(parse_ip%initialised) call finalise(parse_ip) + endif + + + call QUIP_FoX_get_value(attributes, 'gap_version', value, status) + if( (status == 0) ) then + parse_ip%xml_version = string_to_int(value) + if( parse_ip%xml_version > gap_version ) & + call system_abort( & + 'Database was created with a later version of the code.' // & + 'Version of code used to generate the database is '//trim(value)//'.'// & + 'Version of current code is '//gap_version//'. Please update your code.') + else + parse_ip%xml_version = 0 + endif + + call QUIP_FoX_get_value(attributes, 'sR', value, status) + if(status == 0) then + read (value, *) parse_ip%sR + else + call system_abort('IPModel_vdW_read_params_xml cannot find sR') + endif + + call QUIP_FoX_get_value(attributes, 'd', value, status) + if(status == 0) then + read (value, *) parse_ip%d + else + call system_abort('IPModel_vdW_read_params_xml cannot find d') + endif + + call QUIP_FoX_get_value(attributes, 'cutoff', value, status) + if(status == 0) then + read (value, *) parse_ip%vdW_cutoff + else + call system_abort('IPModel_vdW_read_params_xml cannot find cutoff') + endif + + call QUIP_FoX_get_value(attributes, 'cutoff_buffer', value, status) + if(status == 0) then + read (value, *) parse_ip%vdW_cutoff_buffer + else + call system_abort('IPModel_vdW_read_params_xml cannot find cutoff_buffer') + endif + + ! For good measure + parse_ip%map = -1 + + elseif(parse_in_ip .and. name == 'GAP_data') then + + call QUIP_FoX_get_value(attributes, 'e0', value, status) + if(status == 0) then + read (value, *) parse_ip%e0(1) + parse_ip%e0 = parse_ip%e0(1) + endif + + parse_in_vdW_data = .true. + + elseif(parse_in_ip .and. parse_in_vdW_data .and. name == 'e0') then + call QUIP_FoX_get_value(attributes, 'Z', value, status) + if(status == 0) then + read (value, *) Z + else + call system_abort('IPModel_vdW_read_params_xml cannot find Z') + endif + if( Z > size(parse_ip%e0) ) call system_abort('IPModel_vdW_read_params_xml: attribute Z = '//Z//' > '//size(parse_ip%e0)) + + call QUIP_FoX_get_value(attributes, 'value', value, status) + if(status == 0) then + read (value, *) parse_ip%e0(Z) + else + call system_abort('IPModel_vdW_read_params_xml cannot find value in e0') + endif + + elseif(parse_in_ip .and. name == 'per_type_data') then + parse_ip%n_types = parse_ip%n_types + 1 + call reallocate(parse_ip%Z,parse_ip%n_types,copy=.true.) + call reallocate(parse_ip%r0,parse_ip%n_types,copy=.true.) + call reallocate(parse_ip%alpha0,parse_ip%n_types,copy=.true.) + call reallocate(parse_ip%c6,parse_ip%n_types,copy=.true.) + + call QUIP_FoX_get_value(attributes, 'Z', value, status) + if(status == 0) then + read (value, *) parse_ip%Z(parse_ip%n_types) + else + call system_abort('IPModel_vdW_read_params_xml cannot find Z') + endif + + call QUIP_FoX_get_value(attributes, 'r0', value, status) + if(status == 0) then + read (value, *) parse_ip%r0(parse_ip%n_types) + else + call system_abort('IPModel_vdW_read_params_xml cannot find r0') + endif + + call QUIP_FoX_get_value(attributes, 'alpha0', value, status) + if(status == 0) then + read (value, *) parse_ip%alpha0(parse_ip%n_types) + else + call system_abort('IPModel_vdW_read_params_xml cannot find alpha0') + endif + + call QUIP_FoX_get_value(attributes, 'c6', value, status) + if(status == 0) then + read (value, *) parse_ip%c6(parse_ip%n_types) + else + call system_abort('IPModel_vdW_read_params_xml cannot find c6') + endif + endif + +end subroutine IPModel_startElement_handler + +subroutine IPModel_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_ip) then + if(name == 'vdW_params') then + parse_in_ip = .false. + parse_in_ip_done = .true. + elseif(name == 'vdW_data') then + parse_in_vdW_data = .false. + + elseif(name == 'per_type_data') then + + elseif(name == 'command_line') then + parse_ip%command_line = parse_cur_data + end if + endif + +end subroutine IPModel_endElement_handler + +subroutine IPModel_characters_handler(in) + character(len=*), intent(in) :: in + + if(parse_in_ip) then + call concat(parse_cur_data, in, keep_lf=.false.) + endif + +end subroutine IPModel_characters_handler + +subroutine IPModel_vdW_read_params_xml(this, param_str) + type(IPModel_vdW), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) then + call system_abort('IPModel_vdW_read_params_xml: invalid param_str length '//len(trim(param_str)) ) + else + parse_in_ip = .false. + parse_in_ip_done = .false. + parse_matched_label = .false. + parse_ip => this + call initialise(parse_cur_data) + + call open_xml_string(fxml, param_str) + call parse(fxml, & + startElement_handler = IPModel_startElement_handler, & + endElement_handler = IPModel_endElement_handler, & + characters_handler = IPModel_characters_handler) + call close_xml_t(fxml) + + call finalise(parse_cur_data) + + if(.not. parse_in_ip_done) & + call system_abort('IPModel_vdW_read_params_xml: could not initialise vdW potential. No vdW_params present?') + this%initialised = .true. + endif + +end subroutine IPModel_vdW_read_params_xml + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Printing of vdW parameters: number of different types, cutoff radius, atomic numbers, etc. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine IPModel_vdW_Print (this, file, dict) + type(IPModel_vdW), intent(inout) :: this + type(Inoutput), intent(inout),optional :: file + type(Dictionary), intent(inout), optional :: dict + integer :: i + +#ifdef HAVE_GAP + call Print("IPModel_vdW : Gaussian Approximation Potential", file=file) + call Print("IPModel_vdW : label = "//this%label, file=file) + call Print("IPModel_vdW : cutoff = "//this%cutoff, file=file) + call Print("IPModel_vdW : E_scale = "//this%E_scale, file=file) + call Print("IPModel_vdW : command_line = "//string(this%command_line),file=file) + +#else +#endif + +end subroutine IPModel_vdW_Print + +end module IPModel_vdW_module diff --git a/src/Potentials/Multipole_Interactions.F90 b/src/Potentials/Multipole_Interactions.F90 new file mode 100644 index 0000000000..d9bc198f94 --- /dev/null +++ b/src/Potentials/Multipole_Interactions.F90 @@ -0,0 +1,764 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +#include "error.inc" + +module multipole_interactions_module + + use system_module + use units_module + use extendable_str_module + use linearalgebra_module + use dictionary_module + use table_module + use periodictable_module + use connection_module + use atoms_types_module + use atoms_module + use clusters_module + use structures_module + use units_module + use functions_module + use gamma_module + + implicit none + private + +integer, parameter :: Damping_None = 0 +integer, parameter :: Damping_Exp = 1 +integer, parameter :: Damping_Erf = 2 +integer, parameter :: Damping_Erf_Uniform = 3 + +integer, parameter :: Screening_None = 0 +integer, parameter :: Screening_Yukawa = 1 +integer, parameter :: Screening_Erfc_Uniform = 2 + + + +public :: Multipole_Moments_Site_Site_Interaction, assignment(=), T_rank_zero, T_rank_one, T_rank_two, T_rank_three, finalise + +public :: Multipole_Calc_Opts +type Multipole_Calc_Opts + integer :: damping=Damping_None,screening=Screening_None,damp_exp_order + real(dp) :: erf_kappa_uniform,erfc_kappa_uniform,damp_exp_scale,yukawa_alpha,yukawa_smooth_length + logical :: do_energy, do_force, do_test, do_field, do_pot + !______________________________________________________________________________________________________ + ! Only certain dmaping/screening combinations make sense. The interactions can be damped(smeared) at short range and screened at long range + ! Short range damping can be gaussian or exponential + ! + ! erf_kappa - + ! inverse length parameter for gaussian short-range damping, used in the reciprical part of Ewald + ! but also in preventing divergence in polarisable models + ! + ! damp_exp_scale, damp_exp_order + ! + ! Exponential short-range damping as used in the TTM , FX, and AMOEBA water potentials, among others. + ! the damping goes like exp(-a(r/r0)**m) where m=damp_exp_order. Models use m=3 or m=4. a is the damp_exp_scale + ! (optional, default 1.0), and r0 is related to the damp_rad of each site, see function site_site_params. + ! + ! yukawa_alpha,smooth_length,cutoff + ! parameters for yukawa exponential screening of long-range interactions + ! + ! erfc_kappa - + ! inverse length parameter for Ewald long-range screening + ! + ! + !______________________________________________________________________________________________________ + +end type Multipole_Calc_Opts + +public :: Multipole_Interactions_Site +type Multipole_Interactions_Site + ! alpha is scalar polarisability + integer :: pos_type, charge_method, dipole_method, atomic_number, d ! d is the number of multipole components on this site, 1 if just a charge, 3 if dipole, 4 if charge+dipole + real(dp) :: charge = 0.0_dp, potential=0.0_dp, alpha=0.0_dp , e_grad_charge=0.0_dp , damp_rad=0.0_dp + real(dp), dimension(3) :: position, dipole, e_grad_pos=(/0.0_dp,0.0_dp,0.0_dp/), e_field=(/0.0_dp,0.0_dp,0.0_dp/), e_grad_dipole=(/0.0_dp,0.0_dp,0.0_dp/) + ! real(dp), dimension(3,3) :: quadrupole ! no quadrupolar interactions implemented but could be straighforwardly added + integer, dimension(:), allocatable :: atom_indices + real(dp), dimension(:,:,:), allocatable :: charge_grad_positions, dipole_grad_positions, pos_grad_positions ! are derivatives of the multipole position and components with respect to atomic positions + logical :: initialised, polarisable,damped +end type Multipole_Interactions_Site + +!% Overloaded assigment operator. +private :: Multipole_Site_Assignment +interface assignment(=) + module procedure Multipole_Site_Assignment +end interface assignment(=) + +interface finalise + module procedure Multipole_Site_Finalise +end interface finalise + +contains + +subroutine Multipole_Site_Assignment(to,from) + + type(Multipole_Interactions_Site), intent(inout) :: to + type(Multipole_Interactions_Site), intent(in) :: from + + call Multipole_Site_Finalise(to) + + to%pos_type = from%pos_type + to%polarisable = from%polarisable + to%alpha = from%alpha + to%damped = from%damped + to%damp_rad = from%damp_rad + to%charge = from%charge + to%potential = from%potential + to%e_field = from%e_field + to%d=from%d + to%atomic_number = from%atomic_number + to%position = from%position + to%dipole=from%dipole + to%e_grad_pos = from%e_grad_pos + to%charge_method = from%charge_method + to%dipole_method = from%dipole_method + to%e_grad_charge=from%e_grad_charge + to%e_grad_dipole=from%e_grad_dipole + + if (allocated(from%charge_grad_positions)) then + allocate(to%charge_grad_positions(size(from%charge_grad_positions,1),size(from%charge_grad_positions,2),size(from%charge_grad_positions,3))) + to%charge_grad_positions=from%charge_grad_positions + end if + + if (allocated(from%dipole_grad_positions)) then + allocate(to%dipole_grad_positions(size(from%dipole_grad_positions,1),size(from%dipole_grad_positions,2),size(from%dipole_grad_positions,3))) + to%dipole_grad_positions=from%dipole_grad_positions + end if + + if (allocated(from%pos_grad_positions)) then + allocate(to%pos_grad_positions(size(from%pos_grad_positions,1),size(from%pos_grad_positions,2),size(from%pos_grad_positions,3))) + to%pos_grad_positions=from%pos_grad_positions + end if + + to%initialised=.true. + +end subroutine Multipole_Site_Assignment + +subroutine Multipole_Site_Finalise(this) + + type(Multipole_Interactions_Site), intent(inout) :: this + + if (allocated(this%charge_grad_positions)) deallocate(this%charge_grad_positions) + if (allocated(this%dipole_grad_positions)) deallocate(this%dipole_grad_positions) + if (allocated(this%pos_grad_positions)) deallocate(this%pos_grad_positions) + + this%d=0 + this%charge = 0.0_dp + this%dipole = 0.0_dp + + this%atomic_number=0 + this%pos_type = 0 + this%charge_method = 0 + this%dipole_method = 0 + + this%alpha = 0.0_dp + this%damp_rad = 0.0_dp + this%potential = 0.0_dp + this%e_field = 0.0_dp + this%position = 0.0_dp + + this%initialised=.false. + +end subroutine Multipole_Site_Finalise + +! calculate pairwise damping coeffs for exponential, gaussian damping +subroutine Site_Site_Params(do_damp,do_screen,damp_rad_pairwise,erf_kappa_pairwise,radius_one,radius_two,calc_opts) + real (dp), intent(in) :: radius_one,radius_two + type(Multipole_Calc_Opts) :: calc_opts + real(dp),intent(out) :: erf_kappa_pairwise,damp_rad_pairwise + logical,intent(out)::do_damp,do_screen + + do_screen = calc_opts%screening /= Screening_None + do_damp = calc_opts%damping /= Damping_None + + if(calc_opts%damping==Damping_Erf_Uniform) then + erf_kappa_pairwise = calc_opts%erf_kappa_uniform + else if (do_damp) then + damp_rad_pairwise = sqrt(radius_one*radius_two) + damp_rad_pairwise = damp_rad_pairwise/(calc_opts%damp_exp_scale**(1.0_dp/calc_opts%damp_exp_order)) + erf_kappa_pairwise = 1.0_dp/norm((/radius_one,radius_two/)) !! equations 12,13 in J. Phys.: Condens. Matter 26 (2014) 213202 + end if + +end subroutine Site_Site_Params + + +! calculates interactions between multipole moments on two sites. +! site%d refers to the total number of multipole components on that site. If d=1 there is only a charge, if d=3 there is only a dipole +! if d=4 then the site has both a charge and a dipole. +! if multiple sites are present then the energies and forces from the different interactions are added together +recursive subroutine Multipole_Moments_Site_Site_Interaction(energy,site_one,site_two,calc_opts, cutoff,error,test) + real(dp), intent(out) :: energy + type(Multipole_Interactions_Site), intent(inout) :: site_one, site_two + type(Multipole_Calc_Opts) :: calc_opts + real(dp), optional :: cutoff + logical, optional,intent(in) :: test + integer, optional, intent(out) :: error + + integer :: i + real(dp) :: e0, e_plus, step=1.0D-8, q + real(dp), dimension(3) :: pos, dip + logical, dimension(2) :: has_charge, has_dipole + logical :: do_test + + do_test=optional_default(.false.,test) + + if (calc_opts%do_energy) energy=0.0_dp +!call print("do energy ? "//calc_opts%do_energy) +!call print("site site interaction") +!call print("position 1 "//site_one%position) +!call print("position 2 "//site_two%position) + + if (calc_opts%do_force) then + site_one%e_grad_pos = 0.0_dp + site_one%e_grad_charge = 0.0_dp + site_one%e_grad_dipole = 0.0_dp + + site_two%e_grad_pos = 0.0_dp + site_two%e_grad_charge = 0.0_dp + site_two%e_grad_dipole = 0.0_dp + end if + if (calc_opts%do_field) then + site_one%e_field = 0.0_dp + site_two%e_field = 0.0_dp + end if + if (calc_opts%do_pot) then + site_one%potential = 0.0_dp + site_two%potential = 0.0_dp + end if + + has_charge(1) = (site_one%d .eq. 1 .or. site_one%d .eq. 4) + has_charge(2) = (site_two%d .eq. 1 .or. site_two%d .eq. 4) + + has_dipole(1) = (site_one%d .eq. 3 .or. site_one%d .eq. 4) + has_dipole(2) = (site_two%d .eq. 3 .or. site_two%d .eq. 4) + + if (has_charge(1)) then + if (has_charge(2)) then + call Multipole_Interactions_Charge_Charge(energy,site_one, site_two,calc_opts,cutoff=cutoff) + end if + if (has_dipole(2)) then + call Multipole_Interactions_Charge_Dipole(energy,site_one, site_two,calc_opts,cutoff=cutoff) + end if + end if + if (has_dipole(1)) then + if (has_charge(2)) then + call Multipole_Interactions_Charge_Dipole(energy,site_two, site_one,calc_opts,cutoff=cutoff) + end if + if (has_dipole(2)) then + call Multipole_Interactions_Dipole_Dipole(energy,site_one, site_two,calc_opts,cutoff=cutoff) + end if + end if + ! if a site has both a charge and a dipole we iwll have double counted the pot and field + if (site_one%d == 4) then + site_one%e_field = 0.5_dp * site_one%e_field + site_one%potential = 0.5_dp * site_one%potential + end if + if (site_two%d == 4) then + site_two%e_field = 0.5_dp * site_two%e_field + site_two%potential = 0.5_dp * site_two%potential + end if + + +! call print("site site interaction energy is "//energy) + + + if (do_test) then + call print("testing gradients of site-site interactions with step size "//step) +! call print(" diff vec : "//site_two%position-site_one%position) + e0=energy + pos=site_one%position + do i=1,3 + site_one%position(i) = pos(i) + step + call Multipole_Moments_Site_Site_Interaction(e_plus,site_one, site_two,calc_opts,cutoff=cutoff,test=.false.) + call print("r_"//i//" : "//(site_two%position(i)-site_one%position(i))//" gradient : "//site_one%e_grad_pos(i)//" e diff : "//(e_plus-e0)//" fd grad : " // (e_plus-e0)/(step) ) + site_one%position(i) = pos(i) + end do + pos=site_two%position + do i=1,3 + site_two%position(i) = pos(i) + step + call Multipole_Moments_Site_Site_Interaction(e_plus,site_one, site_two,calc_opts,cutoff=cutoff,test=.false.) + call print("r_"//i//" : "//(site_two%position(i)-site_one%position(i))//" gradient : "//site_two%e_grad_pos(i)//" e diff : "//(e_plus-e0)//" fd grad : " // (e_plus-e0)/(step) ) + site_two%position(i) = pos(i) + end do + end if + +end subroutine Multipole_Moments_Site_Site_Interaction + + +subroutine Multipole_Interactions_Charge_Charge(energy,site_one, site_two,calc_opts,cutoff,error) + type(Multipole_Interactions_Site), intent(inout) :: site_one, site_two + type(Multipole_Calc_Opts) :: calc_opts + real(dp),intent(out) :: energy + real(dp), optional :: cutoff + integer, intent(out), optional :: error + real(dp), dimension(3) :: r_one_two, e_grad_pos, T1 + real(dp) :: T0 + + ! vector pointing from site one to site two. position of second site should already be set to correct image position + r_one_two = site_two%position - site_one%position + + + T0 = T_rank_zero(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) + T1 = T_rank_one(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) + if (calc_opts%do_energy) energy = energy + site_one%charge * T0 * site_two%charge + + ! force + if (calc_opts%do_force) then + e_grad_pos = site_one%charge * T1 * site_two%charge ! NB this should be negative of the force + site_one%e_grad_pos = site_one%e_grad_pos - e_grad_pos + site_two%e_grad_pos = site_two%e_grad_pos + e_grad_pos + + site_one%e_grad_charge = site_one%e_grad_charge + T0 * site_two%charge + site_two%e_grad_charge = site_two%e_grad_charge + T0 * site_one%charge + end if + + if (calc_opts%do_pot) then + site_one%potential = site_one%potential + T0 * site_two%charge + site_two%potential = site_two%potential + T0 * site_one%charge + end if + + if (calc_opts%do_field) then + site_one%e_field = site_one%e_field + T1 * site_two%charge + site_two%e_field = site_two%e_field - T1 * site_one%charge + end if + + return + +end subroutine Multipole_Interactions_Charge_Charge + +subroutine Multipole_Interactions_Charge_Dipole(energy,site_one, site_two,calc_opts,cutoff,error) + type(Multipole_Interactions_Site), intent(inout) :: site_one, site_two + type(Multipole_Calc_Opts) :: calc_opts + real(dp),intent(out) :: energy + real(dp), optional :: cutoff + integer, intent(out), optional :: error + real(dp), dimension(3) :: r_one_two, e_grad_pos, T1 + real(dp), dimension(3,3) :: T2 + real(dp) :: T0 + + ! site one is the charge, site two is the dipole + + ! vector pointing from site one to site two. position of second site should already be set to correct image position + r_one_two = site_two%position - site_one%position + + T0 = T_rank_zero(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) + T1 = T_rank_one(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) + T2 = T_rank_two(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) + + if (calc_opts%do_energy) energy = energy + site_one%charge * dot_product(T1, site_two%dipole) + + ! force + if (calc_opts%do_force) then + e_grad_pos = - site_one%charge * matmul(T2,site_two%dipole) !NB grad of energy so minus the force + site_one%e_grad_pos = site_one%e_grad_pos + e_grad_pos + site_two%e_grad_pos = site_two%e_grad_pos - e_grad_pos + + site_one%e_grad_charge = site_one%e_grad_charge + dot_product(T1, site_two%dipole) + site_two%e_grad_dipole = site_two%e_grad_dipole + site_one%charge * T1 + end if + + if (calc_opts%do_pot) then + site_one%potential = site_one%potential + dot_product(T1, site_two%dipole) + site_two%potential = site_two%potential + site_one%charge * T0 + end if + + if (calc_opts%do_field) then + site_one%e_field = site_one%e_field + matmul(T2,site_two%dipole) + site_two%e_field = site_two%e_field - T1 *site_one%charge + end if + + return + +end subroutine Multipole_Interactions_Charge_Dipole + +subroutine Multipole_Interactions_Dipole_Dipole(energy,site_one, site_two,calc_opts,cutoff,error) + type(Multipole_Interactions_Site), intent(inout) :: site_one, site_two + type(Multipole_Calc_Opts) :: calc_opts + real(dp),intent(out) :: energy + real(dp), optional :: cutoff + integer, intent(out), optional :: error + real(dp), dimension(3) :: r_one_two, e_grad_pos, temp1, T1 + real(dp), dimension(3,3) :: T2, temp2 + real(dp), dimension(3,3,3) :: T3 + integer :: i,j,k + + ! vector pointing from site one to site two. position of second site should already be set to correct image position + r_one_two = site_two%position - site_one%position + + T1 = T_rank_one(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) + T2 = T_rank_two(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) + T3 = T_rank_three(r_one_two,calc_opts,site_one%damp_rad,site_two%damp_rad,cutoff=cutoff) + + temp1 = matmul(T2,site_two%dipole) + + if (calc_opts%do_energy) energy = energy - dot_product(site_one%dipole, temp1) + + ! force + if (calc_opts%do_force) then + do i=1,3 + do j=1,3 + temp1 = T3(i,j,:) + temp2(i,j) = dot_product(temp1,site_two%dipole) + end do + end do + temp2 = transpose(temp2) + e_grad_pos = matmul(temp2,site_one%dipole) + site_one%e_grad_pos = site_one%e_grad_pos + e_grad_pos + site_two%e_grad_pos = site_two%e_grad_pos - e_grad_pos + + site_one%e_grad_dipole = site_one%e_grad_dipole - matmul(T2, site_two%dipole) + site_two%e_grad_dipole = site_two%e_grad_dipole - matmul(T2, site_one%dipole) + end if + + if (calc_opts%do_pot) then + site_one%potential = site_one%potential - dot_product(T1, site_two%dipole) + site_two%potential = site_two%potential + dot_product(T1, site_one%dipole) + end if + + if (calc_opts%do_field) then + site_one%e_field = site_one%e_field + matmul(T2,site_two%dipole) + site_two%e_field = site_two%e_field + matmul(T2,site_one%dipole) + end if + + return + +end subroutine Multipole_Interactions_Dipole_Dipole + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +!______________________________________________________________________________________________________ +! +! T tensors with damping/screening using notation from J Chem Phys 133, 234101 +! note parity of these tensors is (-1)^r where r is the rank of the tensor, minus signs in brackets +! indicate that the sign of 'diff' (the first argument) matters. +! +! Units are as follows : +! T_rank_zero : eV /(electron charge)^2 +! T_rank_one : Angstrom^-1 * eV /(electron charge)^2 +! T_rank_two : Angstrom^-2 * eV /(electron charge)^2 +! T_rank_three : Angstrom^-3 * eV /(electron charge)^2 +! +! so that the potential, electric field, and field gradient due to a charge are given by: +! pot = charge * T_rank_zero +! E_field = (-) charge * T_rank_one +! grad(E_field) = charge * T_rank_two +! +! And for a dipole in units of Ang*(electron charge) +! pot = (-) dot_product(dipole, T_rank_one) +! E_field = matmul(T_rank_two,dipole) +! grad(E_field) = (-) T_rank_three * dipole (a rank two tensor arising from multiplication of a rank 3 and rank 1 tensor) +! +!______________________________________________________________________________________________________ + +function T_rank_zero(diff, calc_opts,radius_one,radius_two,cutoff,error) + ! generalised 1/r including damping and screening + real(dp), dimension(3),intent(in) :: diff + type(Multipole_Calc_Opts) :: calc_opts + real(dp),intent(in) :: radius_one,radius_two + real(dp), intent(in), optional :: cutoff + integer, optional :: error + + real(dp) :: r, T_rank_zero, a, f, s0, s0_damp, s0_screen,u,um + real(dp) :: damp_rad_exp,erf_kappa,erfc_kappa + logical :: do_screen, do_damp + integer :: m + + call Site_Site_Params(do_screen,do_damp,damp_rad_exp,erf_kappa,radius_one,radius_two,calc_opts) + r=norm(diff) + + if (do_damp .and. do_screen) then + s0 = -1.0_dp + else if (do_damp .or. do_screen) then + s0 = 0.0_dp + else + s0 = 1.0_dp + end if + + s0_damp=0.0_dp + s0_screen=0.0_dp + + if (calc_opts%damping == Damping_Erf .or. calc_opts%damping == Damping_Erf_Uniform) then + s0_damp=erf(erf_kappa*r) + end if + if (calc_opts%damping == Damping_Exp ) then + m=calc_opts%damp_exp_order + u=(r/damp_rad_exp) + um=u**m + s0_damp=1.0_dp-exp(-um)+u*gamma_incomplete_upper((1.0_dp-1.0_dp/m),um) + end if + + if (calc_opts%screening == Screening_Erfc_Uniform) then + erfc_kappa=calc_opts%erfc_kappa_uniform + s0_screen= erfc(erfc_kappa*r) + end if + if (calc_opts%screening == Screening_Yukawa) then + a = calc_opts%yukawa_alpha + f = poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + s0_screen= exp(-a*r)*f + end if + s0 = s0 + s0_damp + s0_screen + T_rank_zero = (HARTREE*BOHR)*s0/r + +end function T_rank_zero + +function T_rank_one(diff, calc_opts,radius_one,radius_two,cutoff,error) + ! generalised grad(1/r) including damping and screening + real(dp), dimension(3),intent(in) :: diff + type(Multipole_Calc_Opts) :: calc_opts + real(dp),intent(in) :: radius_one,radius_two + real(dp), intent(in), optional :: cutoff + integer, optional :: error + real(dp) :: damp_rad_exp,erf_kappa,erfc_kappa + real(dp) :: r,r3, a,f,df, u,um,s0_damp, s0_screen, s1,s1_damp,s1_screen + real(dp), dimension(3) :: T_rank_one + logical :: do_damp, do_screen + integer:: m + r=norm(diff) + r3=r*r*r + + call Site_Site_Params(do_screen,do_damp,damp_rad_exp,erf_kappa,radius_one,radius_two,calc_opts) + + if (do_damp .and. do_screen) then + s1 = -1.0_dp + else if (do_damp .or. do_screen) then + s1 = 0.0_dp + else + s1 = 1.0_dp + end if + + s0_damp=0.0_dp + s0_screen=0.0_dp + s1_damp=0.0_dp + s1_screen=0.0_dp + + if (calc_opts%damping == Damping_Erf .or. calc_opts%damping == Damping_Erf_Uniform) then + s0_damp=erf(erf_kappa*r) + s1_damp = s0_damp - (2.0_dp*r*erf_kappa/sqrt(PI)) * exp(-(erf_kappa*r)**2) + end if + if (calc_opts%damping == Damping_Exp ) then + m=calc_opts%damp_exp_order + u=(r/damp_rad_exp) + um=u**m + s1_damp=1.0_dp-exp(-um) + end if + + if (calc_opts%screening == Screening_Erfc_Uniform) then + erfc_kappa=calc_opts%erfc_kappa_uniform + s0_screen= erfc(erfc_kappa*r) + s1_screen = s0_screen + (2.0_dp*r*erfc_kappa/sqrt(PI)) * exp(-(erfc_kappa*r)**2) + end if + if (calc_opts%screening == Screening_Yukawa) then + a = calc_opts%yukawa_alpha + f = poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + df = dpoly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + s0_screen = exp(-a*r)*f + s1_screen= s0_screen - r*exp(-a*r)*(df - a*f) + end if + + s1 = s1+s1_damp+s1_screen + T_rank_one = -(HARTREE*BOHR)*s1/r3 * diff +end function T_rank_one + +function T_rank_two(diff, calc_opts,radius_one,radius_two,cutoff,error) + real(dp), dimension(3),intent(in) :: diff + type(Multipole_Calc_Opts) :: calc_opts + real(dp),intent(in) :: radius_one,radius_two + real(dp), intent(in), optional :: cutoff + integer, optional :: error + real(dp) :: damp_rad_exp,erf_kappa,erfc_kappa + real(dp) :: r,r3,r5, a, f,df,d2f,u,um, & + s0_damp=0.0_dp, s0_screen=0.0_dp, s1=0.0_dp,s1_damp=0.0_dp,s1_screen=0.0_dp,s2=0.0_dp,s2_damp=0.0_dp,s2_screen=0.0_dp + real(dp), dimension(3,3) :: T_rank_two, identity + logical :: do_damp, do_screen + integer :: m + + r=norm(diff) + r3=r*r*r + r5=r3*r*r + + call Site_Site_Params(do_screen,do_damp,damp_rad_exp,erf_kappa,radius_one,radius_two,calc_opts) + + identity=0.0_dp + call add_identity(identity) + + s0_damp=0.0_dp + s0_screen=0.0_dp + s1_damp=0.0_dp + s1_screen=0.0_dp + s2_damp=0.0_dp + s2_screen=0.0_dp + + if (do_damp .and. do_screen) then + s1 = -1.0_dp + s2 = -1.0_dp + else if (do_damp .or. do_screen) then + s1 = 0.0_dp + s2 = 0.0_dp + else + s1 = 1.0_dp + s2 = 1.0_dp + end if + + if (calc_opts%damping == Damping_Erf .or. calc_opts%damping == Damping_Erf_Uniform) then + s0_damp=erf(erf_kappa*r) + s1_damp = s0_damp - (2.0_dp*r*erf_kappa/sqrt(PI)) * exp(-(erf_kappa*r)**2) + s2_damp = s1_damp - (4.0_dp/(3.0_dp*sqrt(PI)))*((r*erf_kappa)**3) * exp(-(erf_kappa*r)**2) + end if + if (calc_opts%damping == Damping_Exp ) then + m=calc_opts%damp_exp_order + u=(r/damp_rad_exp) + um=u**m + s1_damp=1.0_dp-exp(-um) + s2_damp=1.0_dp-(1.0_dp+(m/3.0_dp)*um)*exp(-um) + end if + if (calc_opts%screening == Screening_Erfc_Uniform) then + erfc_kappa=calc_opts%erfc_kappa_uniform + s0_screen= erfc(erfc_kappa*r) + s1_screen = s0_screen + (2.0_dp*r*erfc_kappa/sqrt(PI)) * exp(-(erfc_kappa*r)**2) + s2_screen = s1_screen + (4.0_dp/(3.0_dp*sqrt(PI)))*((r*erfc_kappa)**3)* exp(-(erfc_kappa*r)**2) + end if + if (calc_opts%screening == Screening_Yukawa) then + a = calc_opts%yukawa_alpha + f = poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + df = dpoly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + d2f = d2poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + s0_screen = exp(-a*r)*f + s1_screen= s0_screen - r*exp(-a*r)*(df - a*f) + s2_screen = s1_screen + (r*r/3.0_dp)* exp(-a*r) *( (a**2)*f - 2.0_dp*a*df + d2f ) + end if + + s1 = s1+s1_damp+s1_screen + s2 = s2+s2_damp+s2_screen + + T_rank_two = (3.0_dp*s2/r5) * (diff .outer. diff) - (s1/r3) * identity + T_rank_two = (HARTREE*BOHR)*T_rank_two +end function T_rank_two + + +function T_rank_three(diff,calc_opts,radius_one,radius_two,cutoff,error) + real(dp), dimension(3),intent(in) :: diff + type(Multipole_Calc_Opts) :: calc_opts + real(dp),intent(in) :: radius_one,radius_two + real(dp), intent(in), optional :: cutoff + integer, optional :: error + real(dp) :: damp_rad_exp, erf_kappa, erfc_kappa + real(dp) :: r,r5,r7,c1, c2, a, f, df, d2f, d3f, u,um,& + s0_damp, s0_screen,s1_damp,s1_screen, & + s2_damp,s2_screen, s2, & + s3_damp,s3_screen, s3 + real(dp), dimension(3,3,3) :: T_rank_three + logical :: do_damp, do_screen + integer :: i,j,k,m + + r=norm(diff) + r5=r**5 + r7=r5*r*r + + call Site_Site_Params(do_screen,do_damp,damp_rad_exp,erf_kappa,radius_one,radius_two,calc_opts) + + s0_damp=0.0_dp + s0_screen=0.0_dp + s1_damp=0.0_dp + s1_screen=0.0_dp + s2_damp=0.0_dp + s2_screen=0.0_dp + s3_damp=0.0_dp + s3_screen=0.0_dp + + if (do_damp .and. do_screen) then + s2 = -1.0_dp + s3 = -1.0_dp + else if (do_damp .or. do_screen) then + s2 = 0.0_dp + s3 = 0.0_dp + else + s2 = 1.0_dp + s3 = 1.0_dp + end if + + if (calc_opts%damping == Damping_Erf .or. calc_opts%damping == Damping_Erf_Uniform) then + s0_damp=erf(erf_kappa*r) + s1_damp = s0_damp - (2.0_dp/sqrt(PI))*(r*erf_kappa) * exp(-(erf_kappa*r)**2) + s2_damp = s1_damp - (4.0_dp/(3.0_dp*sqrt(PI)))*((r*erf_kappa)**3) * exp(-(erf_kappa*r)**2) + s3_damp = s2_damp - (8.0_dp/(15.0_dp*sqrt(PI)))*((r*erf_kappa)**5) * exp(-(erf_kappa*r)**2) + end if + if (calc_opts%damping == Damping_Exp ) then + m=calc_opts%damp_exp_order + u=(r/damp_rad_exp) + um=u**m + s1_damp=1.0_dp-exp(-um) + s2_damp=1.0_dp-(1.0_dp+(m/3.0_dp)*um)*exp(-um) + s3_damp=1.0_dp-(1.0_dp+(m*(8.0_dp-m)/15.0)*um+(m**2/15.0_dp)*um*um)*exp(-um) + end if + if (calc_opts%screening == Screening_Erfc_Uniform) then + erfc_kappa=calc_opts%erfc_kappa_uniform + s0_screen= erfc(erfc_kappa*r) + s1_screen = s0_screen + (2.0_dp*r*erfc_kappa/sqrt(PI)) * exp(-(erfc_kappa*r)**2) + s2_screen = s1_screen + (4.0_dp/(3.0_dp*sqrt(PI)))*((r*erfc_kappa)**3)* exp(-(erfc_kappa*r)**2) + s3_screen = s2_screen + (8.0_dp/(15.0_dp*sqrt(PI)))*((r*erfc_kappa)**5)* exp(-(erfc_kappa*r)**2) + end if + if (calc_opts%screening == Screening_Yukawa) then + a = calc_opts%yukawa_alpha + f = poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + df = dpoly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + d2f = d2poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + d3f = d3poly_switch(r,cutoff,calc_opts%yukawa_smooth_length) + + s0_screen = exp(-a*r)*f + s1_screen= s0_screen - r*exp(-a*r)*(df - a*f) + s2_screen = s1_screen + (r*r/3.0_dp)* exp(-a*r) *( (a**2)*f - 2.0_dp*a*df + d2f ) + c1 = ( (a**2)*f*(1.0_dp+a*r) - a*df*(2.0_dp+3.0_dp*a*r) + d2f*(1.0_dp + 3.0_dp*a*r) - d3f*r ) + s3_screen = s2_screen + (r*r/15.0_dp)* c1 * exp(-a*r) + end if + + s2 = s2+s2_damp+s2_screen + s3 = s3+s3_damp+s3_screen + c1 = (-s3*15.0_dp/r7) + c2 = (s2*3.0_dp/r5) + T_rank_three = 0.0_dp + do i=1,3 + do j=1,3 + do k=1,3 + T_rank_three(i,j,k) = c1*diff(i)*diff(j)*diff(k) + if (j .eq. k ) T_rank_three(i,j,k) = T_rank_three(i,j,k) + c2*diff(i) + if (i .eq. k ) T_rank_three(i,j,k) = T_rank_three(i,j,k) + c2*diff(j) + if (i .eq. j ) T_rank_three(i,j,k) = T_rank_three(i,j,k) + c2*diff(k) + end do + end do + end do + T_rank_three = (HARTREE*BOHR)*T_rank_three + +end function T_rank_three + + +end module multipole_interactions_module diff --git a/src/Potentials/Multipoles.F90 b/src/Potentials/Multipoles.F90 new file mode 100644 index 0000000000..dcd4f9fa3d --- /dev/null +++ b/src/Potentials/Multipoles.F90 @@ -0,0 +1,642 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +#include "error.inc" + +module Multipoles_module + +use error_module +!use system_module, only : dp, print, inoutput, optional_default, system_timer, operator(//), print_message +use system_module +use cinoutput_module +use units_module +use dictionary_module +use paramreader_module +use periodictable_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use topology_module +use extendable_str_module +use table_module +use connection_module +use clusters_module +use structures_module +use multipole_interactions_module +use partridge_schwenke_dipole_module + + +#ifdef HAVE_GAP +use descriptors_module +#endif + +use mpi_context_module +use QUIP_Common_module + + +implicit none +private +public :: multipole_sites_setup, atomic_forces_from_sites, electrostatics_calc,finalise, build_polarisation_matrix, calc_induced_dipoles,ewald_setup + +integer, parameter :: Multipole_Position_Atomic = 1 +integer, parameter :: Multipole_Position_Centre_of_Mass = 2 +integer, parameter :: Multipole_Position_M_Site = 3 + +integer, parameter :: Charge_Method_None = 0 +integer, parameter :: Charge_Method_Fixed = 1 +integer, parameter :: Charge_Method_GAP = 2 +integer, parameter :: Charge_Method_Partridge_Schwenke = 3 + +integer, parameter :: Dipole_Method_None = 0 +integer, parameter :: Dipole_Method_Partridge_Schwenke = 1 +integer, parameter :: Dipole_Method_GAP = 2 + +integer, parameter :: Polarisation_Method_None = 0 +integer, parameter :: Polarisation_Method_FPI = 1 +integer, parameter :: Polarisation_Method_GMRES = 2 +integer, parameter :: Polarisation_Method_QR = 3 + +integer, parameter :: Damping_None = 0 +integer, parameter :: Damping_Exp = 1 +integer, parameter :: Damping_Erf = 2 +integer, parameter :: Damping_Erf_Uniform = 3 + +integer, parameter :: Screening_None = 0 +integer, parameter :: Screening_Yukawa = 1 +integer, parameter :: Screening_Erfc_Uniform = 2 + +real(dp), parameter :: reciprocal_time_by_real_time = 1.0_dp / 3.0_dp + +type Monomers + type(Multipole_Interactions_Site), dimension(:), allocatable :: site_types ! this just a dummy list of site types with no actual positions + integer, dimension(:), allocatable :: signature + integer, dimension(:,:), allocatable :: excluded_pairs,monomer_indices + real(dp), dimension(:), allocatable :: masses + real(dp) :: monomer_cutoff = 0.0_dp, step ! step size (Angstroms) used for finite difference gradient calculations + real(dp) :: gammaM = 0.426706882_dp ! param for determining M-site position in water models +end type Monomers + +public :: Multipole_Moments +type Multipole_Moments + real(dp) :: cutoff = 0.0_dp, dipole_tolerance=1e-7_dp + type(Monomers), dimension(:), allocatable :: monomer_types + type(Multipole_Calc_Opts) :: calc_opts + type(Multipole_Interactions_Site), dimension(:), allocatable :: sites ! 1 to 1 correspondence w dummy atom sites + logical :: strict=.true., initialised=.false.,intermolecular_only = .true. + + integer, dimension(:), allocatable :: pol_idx + logical, dimension(:), allocatable :: site_polarisable + integer, dimension(:,:), allocatable :: exclude_list +end type Multipole_Moments + +public :: Ewald_arrays +type Ewald_arrays + real(dp), dimension(:,:), allocatable :: Q + logical :: do_ewald = .false. +end type Ewald_arrays + +interface Finalise + module procedure Multipole_Moments_Finalise + module procedure Monomers_Finalise +end interface Finalise + +contains + + +subroutine Multipole_Moments_Finalise(this) + + type(Multipole_Moments),intent(inout) :: this + integer::i + + if (allocated(this%monomer_types)) then + do i=1,size(this%monomer_types) + call finalise(this%monomer_types(i)) + end do + deallocate(this%monomer_types) + end if + if (allocated(this%sites)) then + do i=1,size(this%sites) + call finalise(this%sites(i)) + end do + deallocate(this%sites) + end if + + if (allocated(this%pol_idx)) deallocate(this%pol_idx) + if (allocated(this%site_polarisable)) deallocate(this%site_polarisable) + if (allocated(this%exclude_list)) deallocate(this%exclude_list) + + this%initialised = .False. + +end subroutine Multipole_Moments_Finalise + +subroutine Monomers_Finalise(this) + + type(Monomers),intent(inout) :: this + integer :: i + + this%monomer_cutoff = 0.0_dp + if (allocated(this%site_types)) then + do i=1,size(this%site_types) + call finalise(this%site_types(i)) + end do + deallocate(this%site_types) + end if + if (allocated(this%signature)) deallocate(this%signature) + if (allocated(this%excluded_pairs)) deallocate(this%excluded_pairs) + if (allocated(this%monomer_indices)) deallocate(this%monomer_indices) + if (allocated(this%masses)) deallocate(this%masses) + +end subroutine Monomers_Finalise + +subroutine clear_sites(this) + type(Multipole_Moments),intent(inout) :: this + integer::i + + if (allocated(this%monomer_types)) then + do i=1,size(this%monomer_types) + if (allocated(this%monomer_types(i)%monomer_indices)) deallocate(this%monomer_types(i)%monomer_indices) + end do + end if + + if (allocated(this%sites)) then + do i=1,size(this%sites) + call finalise(this%sites(i)) + end do + deallocate(this%sites) + end if + + if (allocated(this%pol_idx)) deallocate(this%pol_idx) + if (allocated(this%site_polarisable)) deallocate(this%site_polarisable) + if (allocated(this%exclude_list)) deallocate(this%exclude_list) + +end subroutine clear_sites + +subroutine multipole_sites_setup(at,multipoles,dummy_atoms,do_grads,strict) + type(Atoms) :: at,dummy_atoms + type(Multipole_Moments) :: multipoles + logical, optional :: do_grads,strict + + logical,dimension(:), allocatable :: associated_to_monomer + integer, dimension(3) :: shift + integer :: n_sites, n_mono_types, cursor,i,j + logical :: my_do_grads,my_strict + + my_do_grads=optional_default(.false.,do_grads) + my_strict=optional_default(.true.,strict) + + call clear_sites(multipoles) + + call reallocate(associated_to_monomer,at%N,zero=.true.) + n_sites=0 + n_mono_types=size(multipoles%monomer_types) + do i=1,n_mono_types ! can introduce a case switch here if want to support more monomer finding routines + if(allocated(multipoles%monomer_types(i)%monomer_indices))deallocate(multipoles%monomer_types(i)%monomer_indices) + call find_general_monomer(at,multipoles%monomer_types(i)%monomer_indices,multipoles%monomer_types(i)%signature,associated_to_monomer,multipoles%monomer_types(i)%monomer_cutoff) + n_sites = n_sites + size(multipoles%monomer_types(i)%site_types) * size(multipoles%monomer_types(i)%monomer_indices,2) + end do + +! if (.not. all(associated_to_monomer)) then +! RAISE_ERROR('Multipoles: Not all atoms are assigned to a monomer', error) +! end if + allocate(multipoles%sites(n_sites)) + + + cursor=0 + do i=1,n_mono_types ! fill in list of sites and exclude list + do j=1,size(multipoles%monomer_types(i)%monomer_indices,2) + call add_sites_for_monomer(at,multipoles%sites,cursor,multipoles%exclude_list,multipoles%monomer_types(i),multipoles%monomer_types(i)%monomer_indices(:,j),my_do_grads) + end do + end do + + call initialise(dummy_atoms,0,at%lattice) ! set up dummy atoms obj + do i=1,n_sites + call add_atoms(dummy_atoms,multipoles%sites(i)%position,1) ! all dummy atoms are Hydrogens + end do + call set_cutoff(dummy_atoms,multipoles%cutoff) + call calc_connect(dummy_atoms) + + !call write(dummy_atoms, 'stdout', prefix='DUMMY',real_format='%16.8f') + + + ! if want to implement this way for efficiency, will probably have to create a second Connection object, which doesn't contain excluded interactions + ! this is because for calculated induced dipoles we typically don't ignore intramolecular interactions, so we shuold ignore the exclude list. +!!$ +!!$ do i=1,size(exclude_list,2) ! delete bonds in exclude list +!!$ call distance_min_image(dummy_atoms,exclude_list(1,i),exclude_list(2,i),shift=shift) +!!$ call remove_bond(dummy_atoms%connection,exclude_list(1,i),exclude_list(2,i),shift=shift) +!!$ end do + + deallocate(associated_to_monomer) + +end subroutine multipole_sites_setup + +subroutine ewald_setup(dummy_atoms,multipoles,ewald,my_ewald_error) + type(Atoms) :: dummy_atoms + type(Multipole_Moments) :: multipoles + type(Ewald_arrays) :: ewald + + real(dp) :: r_ij, erfc_ar, arg, my_ewald_error, alpha, kmax, kmax2, prefac, infac, two_alpha_over_sqrt_pi, v, & + & ewald_precision, ewald_cutoff, my_cutoff, my_smooth_coulomb_cutoff, smooth_arg, smooth_f, dsmooth_f + + ewald_precision = -log(my_ewald_error) + ewald_cutoff = sqrt(ewald_precision/PI) * reciprocal_time_by_real_time**(1.0_dp/6.0_dp) * & + & minval(sqrt( sum(dummy_atoms%lattice(:,:)**2,dim=1) )) / dummy_atoms%N**(1.0_dp/6.0_dp) + call print('Ewald cutoff = '//ewald_cutoff,PRINT_ANALYSIS) + multipoles%cutoff = ewald_cutoff + + write(*,*) "more to do to fill these arrays" + +end subroutine ewald_setup + +subroutine add_sites_for_monomer(at,sites,offset,exclude_list,monomer_type,atom_indices,do_grads) + type(Atoms) :: at + type(Multipole_Interactions_Site), dimension(:) :: sites + integer :: offset + integer, dimension(:,:), allocatable :: exclude_list + type(Monomers) :: monomer_type + integer, dimension(:) :: atom_indices + logical :: do_grads + + real(dp),dimension(:,:),allocatable :: atomic_positions + integer :: monomer_size,sites_per_mono,exclude_offset,n_exclude + integer :: i_atom_site,i_site_glob,i_atom,i_site,i + integer, dimension(3) :: water_signature = (/1,1,8/) + real(dp), dimension(3,3) :: identity3x3 + real(dp), dimension(3) :: com_pos + + real(dp) :: monomer_mass + integer,dimension(:), allocatable :: signature_copy,site_atom_map + + + identity3x3 = 0.0_dp + call add_identity(identity3x3) + + monomer_size = size(monomer_type%signature) + sites_per_mono = size(monomer_type%site_types) + + allocate(atomic_positions(3,monomer_size)) + do i=1,monomer_size + monomer_type%masses(i) =ElementMass(monomer_type%signature(i)) + end do + monomer_mass = sum(monomer_type%masses) + + allocate(site_atom_map(sites_per_mono)) + allocate(signature_copy(monomer_size)) + signature_copy = monomer_type%signature + site_atom_map=0 + + do i_site=1,sites_per_mono + if (monomer_type%site_types(i_site)%pos_type .eq. Multipole_Position_Atomic) then + i_atom_site=find_in_array(signature_copy,monomer_type%site_types(i_site)%atomic_number) + signature_copy(i_atom_site)=0 ! make sure we don't put two sites on the same atom + site_atom_map(i_site) =i_atom_site + end if + end do + + atomic_positions=0.0_dp + com_pos=0.0_dp + + ! find positions of atoms and centre of mass + do i=1,monomer_size + i_atom = atom_indices(i) + atomic_positions(:,i) = at%pos(:,i_atom) + com_pos = com_pos + monomer_type%masses(i) * at%pos(:,i_atom) + end do + + com_pos = com_pos * (1.0_dp/monomer_mass) + + do i_site=1,sites_per_mono + + i_site_glob=offset+i_site + + sites(i_site_glob) = monomer_type%site_types(i_site) ! copy info from template site + + sites(i_site_glob)%charge = 0.0_dp + sites(i_site_glob)%dipole = 0.0_dp + + allocate(sites(i_site_glob)%atom_indices(monomer_size)) + sites(i_site_glob)%atom_indices = atom_indices + + selectcase(monomer_type%site_types(i_site)%pos_type) ! assign positions + case(Multipole_Position_Centre_of_Mass) + sites(i_site_glob)%position = com_pos + case(Multipole_Position_Atomic) + sites(i_site_glob)%position = atomic_positions(:,site_atom_map(i_site)) + case(Multipole_Position_M_Site) + call m_site_position(atomic_positions,monomer_type%gammaM,sites(i_site_glob)%position) + case default + call print("site position param : "//sites(i_site_glob)%pos_type) + call system_abort("Multipole_Moments_Assign doesn't know where to put this multipole moment") + end select + + + selectcase(sites(i_site_glob)%charge_method) ! assign charges + case(Charge_Method_Fixed) + sites(i_site_glob)%charge = monomer_type%site_types(i_site)%charge + case(Charge_Method_GAP) + call system_abort("GAP moments not yet implemented") ! call charge_GAP() + case(Charge_Method_Partridge_Schwenke) +!#ifndef HAVE_FX +! RAISE_ERROR('Multipoles: PS water as charges requested but FX model was not compiled in. Check the HAVE_FX flag in the Makefiles.', error) +!#endif + call charges_PS(atomic_positions,sites(i_site_glob)%charge,i_site,monomer_type%gammaM) + call test_charge_grads_PS(atomic_positions,monomer_type%gammaM) + end select + selectcase(sites(i_site_glob)%dipole_method) ! assign dipoles + case(Dipole_Method_GAP) + continue ! call dipole_moment_GAP() + case(Dipole_Method_Partridge_Schwenke) + if (any(monomer_type%signature .ne. water_signature)) then + call system_abort(" Signature of water monomer must be "//water_signature) + end if + call dipole_moment_PS(atomic_positions,sites(i_site_glob)%dipole) + !call print("PS dipole : "//sites(i_site_glob)%dipole) + end select + + if (do_grads) then + + allocate(sites(i_site_glob)%pos_grad_positions(3,3,monomer_size)) ! gradients of position of site wrt atomic positions + allocate(sites(i_site_glob)%charge_grad_positions(1,3,monomer_size)) ! gradients of charge wrt atomic positions + allocate(sites(i_site_glob)%dipole_grad_positions(3,3,monomer_size)) ! gradients of dipole components wrt atomic positions + + sites(i_site_glob)%e_grad_pos = 0.0_dp + sites(i_site_glob)%e_grad_charge = 0.0_dp + sites(i_site_glob)%e_grad_dipole = 0.0_dp + + sites(i_site_glob)%charge_grad_positions = 0.0_dp + sites(i_site_glob)%dipole_grad_positions = 0.0_dp + sites(i_site_glob)%pos_grad_positions=0.0_dp + + ! calc gradient of this site's multipole components with respect to atomic positions + selectcase(sites(i_site_glob)%charge_method) ! assign charge gradients + case(Charge_Method_Fixed) + continue ! gradients are zero + case(Charge_Method_GAP) + call system_abort("GAP moments not yet implemented") + ! something like call charge_gradients_GAP() + case(Charge_Method_Partridge_Schwenke) + call charge_gradients_PS(atomic_positions,sites(i_site_glob)%charge_grad_positions,monomer_type%gammaM,i_site) + end select + selectcase(sites(i_site_glob)%dipole_method) + case(Dipole_Method_Partridge_Schwenke) + call dipole_moment_gradients_PS(atomic_positions,sites(i_site_glob)%dipole_grad_positions,step=monomer_type%step) + case(Dipole_Method_GAP) + call system_abort("GAP moments not yet implemented") + ! something like call dipole_gradients_GAP() + end select + + ! calc gradients of this site's position with respect to atomic positions + selectcase(sites(i_site_glob)%pos_type) + case(Multipole_Position_Centre_of_Mass) + do i=1,monomer_size + sites(i_site_glob)%pos_grad_positions(:,:,i) = ( monomer_type%masses(i) / monomer_mass) * identity3x3 + end do + case(Multipole_Position_Atomic) + sites(i_site_glob)%pos_grad_positions(:,:,site_atom_map(i_site)) = identity3x3 + case(Multipole_Position_M_Site) + call m_site_position_grads(monomer_type%gammaM,sites(i_site_glob)%pos_grad_positions) + case default + call system_abort("Multipole_Moments_Assign doesn't know how multipole position varies with atomic positions") + end select + end if + + end do + + exclude_offset=0 + if(allocated(exclude_list)) then + exclude_offset=size(exclude_list,2) + end if + if(allocated(monomer_type%excluded_pairs)) then + n_exclude=size(monomer_type%excluded_pairs,2) + call reallocate(exclude_list,2,exclude_offset+n_exclude,copy=.true.) + do i=1,n_exclude + exclude_list(1,exclude_offset+i)=offset+monomer_type%excluded_pairs(1,i) + exclude_list(2,exclude_offset+i)=offset+monomer_type%excluded_pairs(2,i) + end do + end if + offset = offset+sites_per_mono + + deallocate(atomic_positions) + +end subroutine add_sites_for_monomer + +subroutine electrostatics_calc(at,multipoles,ewald,do_pot,do_field,do_force,e) + type(Atoms) :: at + type(Multipole_Moments) :: multipoles + type(Ewald_arrays) :: ewald + logical,optional :: do_pot,do_field,do_force + real(dp),optional :: e + + real(dp) :: my_energy,r_ij,site_site_energy + integer :: i_site,n,j_site + real(dp), dimension(3) :: diff + type(Multipole_Interactions_Site) :: site1,site2 + + + multipoles%calc_opts%do_pot = optional_default(.false.,do_pot) + multipoles%calc_opts%do_field = optional_default(.false.,do_field) + multipoles%calc_opts%do_force = optional_default(.false.,do_force) + + if(.not. allocated(multipoles%exclude_list)) allocate(multipoles%exclude_list(2,0)) +!call print("doing calc w cutoff "//multipoles%cutoff) +!call print("exclude list ") +!call print(multipoles%exclude_list) + ! real space part + do i_site=1,at%N + + multipoles%sites(i_site)%e_field=0.0_dp + multipoles%sites(i_site)%potential=0.0_dp + multipoles%sites(i_site)%e_grad_pos=0.0_dp + multipoles%sites(i_site)%e_grad_charge=0.0_dp + multipoles%sites(i_site)%e_grad_dipole=0.0_dp + + site1 = multipoles%sites(i_site) + do n = 1, n_neighbours(at,i_site) + j_site = neighbour(at,i_site,n,distance=r_ij,diff=diff) + + if( r_ij > multipoles%cutoff ) cycle + + if ( find_in_array(multipoles%exclude_list,(/i_site,j_site/)) + find_in_array(multipoles%exclude_list,(/j_site,i_site/)) .gt. 0 ) cycle + + site2 = multipoles%sites(j_site) + site2%position = site1%position + diff ! make a copy of neighbour site and move it to the correct position + + call Multipole_Moments_Site_Site_Interaction(site_site_energy,site1,site2, multipoles%calc_opts, cutoff=multipoles%cutoff) + + my_energy = my_energy + 0.5_dp * site_site_energy ! double counting + + multipoles%sites(i_site)%e_field = multipoles%sites(i_site)%e_field + site1%e_field + multipoles%sites(i_site)%potential = multipoles%sites(i_site)%potential + site1%potential + multipoles%sites(i_site)%e_grad_pos = multipoles%sites(i_site)%e_grad_pos + site1%e_grad_pos + multipoles%sites(i_site)%e_grad_charge = multipoles%sites(i_site)%e_grad_charge + site1%e_grad_charge + multipoles%sites(i_site)%e_grad_dipole = multipoles%sites(i_site)%e_grad_dipole + site1%e_grad_dipole + + end do + end do + +call print("real space energy "//my_energy) + ! if ewald + ! recip part + ! self part + + if (present(e))e=e+my_energy + +end subroutine electrostatics_calc + + +subroutine atomic_forces_from_sites(sites,f) + type(Multipole_Interactions_Site), dimension(:) :: sites + real(dp), intent(out), dimension(:,:),optional :: f + + integer :: i, j, k, a, n_atoms,i_site,i_atom + + + do i_site=1,size(sites) ! add up force contributions in most transparent way possible + + n_atoms = size(sites(i_site)%atom_indices) + + do a=1,n_atoms ! a is atom number, i component of atomic position, j component of dipole, k component of site position + i_atom=sites(i_site)%atom_indices(a) + do i=1,3 + f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_charge * sites(i_site)%charge_grad_positions(1,i,a) ! NB force is minus grad + do j=1,3 + f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_dipole(j) * sites(i_site)%dipole_grad_positions(j,i,a) + end do + do k=1,3 + f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_pos(k) * sites(i_site)%pos_grad_positions(k,i,a) + end do + end do + end do + + end do + +end subroutine atomic_forces_from_sites + +subroutine build_polarisation_matrix(at,multipoles,pol_matrix,ewald) + type(Atoms) :: at + type(Multipole_Moments) :: multipoles + real(dp), dimension(:,:),allocatable :: pol_matrix + type(Ewald_arrays) :: ewald + + integer :: N_pol,i,i_pol,j_pol,i_site,j_site,n,ii + type(Multipole_Interactions_Site) :: site1,site2 + + real(dp), dimension(3,3) :: prop_mat ! temporary storage of dipole field tensor + real(dp), dimension(3) :: diff + real(dp) :: r_ij + + N_pol=0 + call reallocate(multipoles%pol_idx,at%N,zero=.true.) + do i_site=1,at%N + if(multipoles%sites(i_site)%polarisable) then + N_pol=N_pol+1 + multipoles%pol_idx(i_site)=N_pol + end if + end do + + call reallocate(pol_matrix,3*N_pol,3*N_pol,zero=.true.) + + do i_site=1,at%N + i_pol=multipoles%pol_idx(i_site) + if(i_pol .eq. 0) cycle + do ii=3*i_pol-2,3*i_pol + pol_matrix(ii,ii) = 1.0_dp / multipoles%sites(i_site)%alpha + end do + end do + + do i_site=1,at%N + i_pol=multipoles%pol_idx(i_site) + if(i_pol .eq. 0) cycle + site1 = multipoles%sites(i_site) + + do n = 1, n_neighbours(at,i_site) + j_site = neighbour(at,i_site,n,distance=r_ij,diff=diff) + j_pol = multipoles%pol_idx(j_site) + if( r_ij > multipoles%cutoff .or. j_pol .eq. 0) cycle +!prop_mat=T_rank_two(diff,multipoles%calc_opts,site1%damp_rad,site2%damp_rad,cutoff=multipoles%cutoff) +!call print(prop_mat) + pol_matrix(3*i_pol-2:3*i_pol,3*j_pol-2:3*j_pol) = - T_rank_two(diff,multipoles%calc_opts,site1%damp_rad,site2%damp_rad,cutoff=multipoles%cutoff) + end do + + end do + +end subroutine build_polarisation_matrix + +subroutine calc_induced_dipoles(pol_matrix,multipoles,polarisation,pol_energy) + real(dp), dimension(:,:) :: pol_matrix + type(Multipole_Moments) :: multipoles + integer :: polarisation + real(dp),intent(out) :: pol_energy + + type(LA_Matrix) :: la_pol_matrix + real(dp),dimension(:),allocatable :: perm_field,induced_dipoles + integer:: i_pol,i_site,N_pol,N_sites,ii + + N_sites=size(multipoles%pol_idx) + N_pol=count(multipoles%pol_idx .ne. 0) + + call reallocate(perm_field,3*N_pol,zero=.true.) + call reallocate(induced_dipoles,3*N_pol,zero=.true.) + call initialise(la_pol_matrix,pol_matrix) + + ! extract permanent fields from sites + do i_site=1,N_sites + i_pol=multipoles%pol_idx(i_site) + if(i_pol .eq. 0) cycle + ii=3*i_pol-2 + perm_field(ii:ii+2) = multipoles%sites(i_site)%e_field + end do +!call print("perm_field") +!call print(perm_field) + + ! solve system with QR or GMRES + if ( polarisation == Polarisation_Method_QR) then + call LA_Matrix_QR_Factorise(la_pol_matrix) + call LA_Matrix_QR_Solve_Vector(la_pol_matrix,perm_field,induced_dipoles) + end if + + pol_energy=0.0_dp + ! update dipoles on sites and sum induction energy + do i_site=1,N_sites + i_pol=multipoles%pol_idx(i_site) + if(i_pol .eq. 0) cycle + ii=3*i_pol-2 + multipoles%sites(i_site)%dipole = multipoles%sites(i_site)%dipole + induced_dipoles(ii:ii+2) + pol_energy = pol_energy + 0.5_dp*(normsq(induced_dipoles(ii:ii+2))/multipoles%sites(i_site)%alpha) + end do +call print("polarisation energy "//pol_energy) +!call print("dipoles") +!call print(induced_dipoles) + + +end subroutine calc_induced_dipoles + +end module Multipoles_module diff --git a/src/Potentials/Partridge_Schwenke_Dipole.F90 b/src/Potentials/Partridge_Schwenke_Dipole.F90 new file mode 100644 index 0000000000..e331df00e1 --- /dev/null +++ b/src/Potentials/Partridge_Schwenke_Dipole.F90 @@ -0,0 +1,713 @@ +#include "error.inc" + + +module partridge_schwenke_dipole_module + +use error_module +use system_module, only : dp, print, inoutput, optional_default, system_timer, operator(//), system_abort +use units_module +use linearalgebra_module, only : add_identity +implicit none +private + +public :: dipole_moment_PS, dipole_moment_gradients_PS,charges_PS,charge_gradients_PS,m_site_position,m_site_position_grads,test_charge_grads_PS + +real(dp) :: coef(823) +integer ::i, idx(823,3) +data (idx(i,1),i=1,823 )/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, & + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, & + 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, & + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, & + 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,10,10,10,10,10,10,10,10,10,10, & +11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11,11, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, & + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & + 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, & + 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,10,10,10,10,10,10,10,10,10, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, & + 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, & + 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 9, 9, 9, & + 9, 9, 9, 9, 9, 9, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, & + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, & + 7, 7, 7, 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, & + 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, & + 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, & + 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, 6, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, & + 5, 5, 5, 5, 5, 5, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, & + 4, 4, 4, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1/ +data (idx(i,2),i=1,823 )/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, & + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, & + 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, & + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, & + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, & + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, & + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, & + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 6, & + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, & + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 7, 7, 7, 7, 7, & + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, & + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, & + 7, 7, 7, 7, 7, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, & + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, & + 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, & + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,10,10,10,10,10,10,10,10,10,10, & +10,10,10,10,10,10,10,10,10,11,11,11,11,11,11,11,11,11/ +data (idx(i,3),i=1,823)/ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, & +15,16,17,18,19, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17, & +18, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17, 1, 2, 3, 4, & + 5, 6, 7, 8, 9,10,11,12,13,14,15,16, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, & +11,12,13,14,15, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, 1, 2, 3, & + 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, & + 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, & + 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17,18, 1, 2, 3, 4, 5, & + 6, 7, 8, 9,10,11,12,13,14,15,16,17,18, 1, 2, 3, 4, 5, 6, 7, 8, 9, & +10,11,12,13,14,15,16,17, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, & +15,16, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 1, 2, 3, 4, 5, & + 6, 7, 8, 9,10,11,12,13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, & + 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, & +11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, & + 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16,17, 1, 2, 3, 4, 5, 6, 7, & + 8, 9,10,11,12,13,14,15,16, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, & +14,15, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14, 1, 2, 3, 4, 5, 6, & + 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, & + 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, & + 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,16, 1, & + 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, 1, 2, 3, 4, 5, 6, 7, 8, & + 9,10,11,12,13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, & + 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, & + 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, & + 6, 7, 8, 9,10,11,12,13,14,15, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, & +13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, 6, 7, & + 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, & + 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9, & +10,11,12,13,14, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13, 1, 2, 3, 4, & + 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, & + 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, & + 7, 8, 9,10,11,12,13, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, & + 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, & + 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12, 1, 2, 3, 4, 5, & + 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, 2, 3, 4, 5, 6, & + 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11, 1, 2, 3, 4, 5, 6, 7, 8, & + 9,10, 1, 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 1, & + 2, 3, 4, 5, 6, 7, 8, 9, 1, 2, 3, 4, 5, 6, 7, 8, 9/ +data (coef(i),i=1,296 )/3.3059356035504D-01,-6.5251838873142D-02, & + 4.1240972465648D-02, -2.2116144218802D-02, 1.2580837420455D-02, & + 7.8310787716761D-03, 2.2288047625127D-02, -1.3669697654061D-01, & + 2.4937882844205D-02, 4.3657889120529D-01, -4.6471342590799D-01, & + -5.5058444686450D-01, 1.5887018737408D+00, -6.5038773968250D-01, & + -1.9774754735667D+00, 2.3124888370313D+00, 3.8251566080155D-01, & + -1.6334099937156D+00, 6.2881257157520D-01, -1.8927984910357D-01, & + -7.2499911946761D-02, -3.1228675269345D-02, -5.6242287160400D-02, & + -1.3290140915015D-02, -1.1339837953158D-01, 4.1911643453876D-01, & + 1.0878140964594D+00, -2.1578445557330D+00, -6.0750507724534D+00, & + 9.1561006195652D+00, 1.3224003890557D+01, -2.0748430357416D+01, & + -1.0449365066054D+01, 2.1628595870529D+01, -4.2431457957766D-01, & + -7.5571164522298D+00, 2.0524343250386D+00, 5.5868906350997D-01, & + -5.9721805154700D-02, 9.3334456754609D-02, 1.0923671353769D-01, & + -3.3757729524242D-03, -8.1955430151354D-01, 5.6496735493995D-01, & + -1.3011057288355D+00, 5.3901118329658D+00, 1.3568988621720D+01, & + -3.7808429693587D+01, -2.0739014515304D+01, 8.3199919232595D+01, & + -9.8755630053578D+00, -6.1652207627820D+01, 2.7023074052020D+01, & + 2.4525958185483D+00, -5.5149034988337D-01, 1.5103514025733D-01, & + -2.4618413187533D-01, -4.1804716531894D-01, 2.6714852474484D+00, & + -3.9168656863665D+00, -2.4125252717845D+01, 4.3527442372053D+01, & + 5.9633945281439D+01, -1.4203637448798D+02, -2.5686288988000D+01, & + 1.8623562080820D+02, -7.1111780955171D+01, -8.1445438601723D+01, & + 7.5998791997709D+01, -1.9604047605233D+01, 6.9877155195411D-01, & + 2.7810300377705D-01, -5.2931179377996D-01, -1.0053094346116D+01, & + 1.4814307367778D+01, 7.8108768923701D+01, -1.0805092078057D+02, & + -2.3239081566836D+02, 3.7213457783017D+02, 3.0496349672975D+02, & + -6.3411783219992D+02, -1.4879340998406D+02, 5.0022502992215D+02, & + -1.3111459794329D+01, -1.2290268190725D+02, -5.8654536308254D-01, & + -3.2431931793368D+00, -4.3010113145914D+00, 6.0041429939524D+01, & + -5.6492374908452D+01, -2.3766509586367D+02, 5.7464248240814D+02, & + -1.1755625188188D+01, -1.3722806921925D+03, 1.1416528991599D+03, & + 1.0319638945490D+03, -1.3181474199324D+03, -2.8780475896443D+02, & + 4.8041729027996D+02, 2.5765411421547D-01, 3.0320582307308D+00, & + 1.8801635566723D+01, -1.0807887522259D+01, -9.2855800489316D+01, & + -2.0023372590061D+02, 3.7208691892624D+01, 1.2333932023660D+03, & + -2.3854122885654D+02, -2.2719119490167D+03, 1.2845178202043D+03, & + 1.0639169133522D+03, -8.1775958686613D+02, -2.5657303999430D+00, & + 3.2500673972889D+01, 2.7614957583093D+01, -6.3541800745099D+02, & + 3.7542804251488D+02, 3.1023608042457D+03, -3.2841743471965D+03, & + -3.9310047363443D+03, 5.9367773903877D+03, -5.6931755253618D+02, & + -1.6343922939315D+03, 5.6921856317329D+02, 6.9934412991284D+00, & + -9.0226351470208D+01, -1.6210263409154D+02, 1.5895772244284D+03, & + -2.3411885205624D+02, -7.0717394064325D+03, 6.2987514309228D+03, & + 7.4402200861379D+03, -1.1416901914882D+04, 3.3350622040450D+03, & + 3.1195654244768D+02, -6.2871212585897D+00, 7.9926393798994D+01, & + 1.7167392636067D+02, -1.3658290879599D+03, -5.6544576497080D+01, & + 5.9229738209174D+03, -4.7443933784239D+03, -6.0256769257614D+03, & + 9.1534258978092D+03, -3.1293931276615D+03, 1.6169861139146D+00, & + -2.0468415192255D+01, -4.6075981473614D+01, 3.4557095272353D+02, & + 2.6381121398946D+01, -1.4631669362241D+03, 1.2299345022018D+03, & + 1.2705573668289D+03, -2.5152540533899D+03, 1.7151603225554D+03, & + 8.6865937684802D+01, -1.6707195632608D+03, 6.2315981153506D+02, & + 1.4270102465207D+03, -1.0493951381706D+03, -3.7380369214480D+02, & + 5.5457941332705D+02, -1.4236914052765D+02, -6.1540053279229D-02, & + 1.5531427659386D-01, -3.1860760875349D-02, 3.2654417741389D-02, & + -2.2987178066698D-01, 3.0488522568491D-01, 2.2933076978782D+00, & + -3.7563267358823D+00, -1.0753342561066D+01, 2.0419223364673D+01, & + 2.2747341950651D+01, -5.4709940439901D+01, -1.5369671127204D+01, & + 7.1082849961840D+01, -1.2914573886419D+01, -3.5970581259398D+01, & + 1.6891394219063D+01, -7.5177127154281D-02, -5.5097454571807D-02, & + 1.3178003090885D-02, -7.3713198218206D-02, 1.0116574180841D-01, & + -5.6479840733797D-01, 7.0154865623363D-01, 1.0496975433616D+00, & + -5.0788071354498D+00, 5.5950672093606D+00, 8.3560432301710D+00, & + -2.4631240429059D+01, 6.4228976148411D+00, 2.9716418329629D+01, & + -2.5429959665417D+01, -7.0743350880142D+00, 1.6290654019047D+01, & + -5.5863925933866D+00, -1.2201221052153D-01, 2.9211663541558D-01, & + -5.0527445973303D-02, -1.1499331650193D+00, -1.1524746330230D+00, & + 1.4889417611659D+01, 1.8304400502439D+01, -7.0581115296041D+01, & + -7.0486462006098D+01, 1.9124714847398D+02, 1.0441968375963D+02, & + -2.7288439929057D+02, -6.4888829584091D+01, 1.8924747244095D+02, & + 2.4269853698223D+01, -6.0338716812716D+01, -3.5328088267763D-02, & + 3.0902606918779D-01, 1.2053004980265D+00, -6.0803513996890D+00, & + -1.7483113565255D-01, -6.2625401449884D+00, -2.7246752169995D+01, & + 2.0444304756919D+02, -7.7839322800197D+01, -5.3730625493358D+02, & + 4.7830647603102D+02, 4.6597134541889D+02, -6.1259392504536D+02, & + -1.1548852899995D+02, 2.3547566621563D+02, -2.3347154414735D-02, & + -1.1968693854390D+00, 1.0224938597971D+01, 5.3446850508065D+01, & + -1.4111836292138D+02, -3.1522742996746D+02, 4.8421928937666D+02, & + 6.7783542838211D+02, -5.2424354383194D+02, -9.1849951039291D+02, & + 2.9732037903974D+01, 1.0861777943385D+03, 3.0719961746829D+01, & + -5.0010435278295D+02, 1.8839519932092D+00, -1.7599267033384D+01, & + -1.0219850683350D+02, 1.8829260033990D+02, 7.3803356268807D+02, & + -3.8632754653668D+02, -1.7644793500072D+03, -8.8777283880817D+02, & + 2.9449590358391D+03, 2.0536359693554D+03, -3.3452415814017D+03, & + -3.1293172119834D+02, 1.0127512420257D+03, -3.0193368209445D+00, & + 4.1095352165196D+01, 4.4348552320534D+01, -7.9321796890387D+02, & + 3.2539233560467D+02, 3.1868226505597D+03, -2.0997414646993D+03, & + -1.8521962831455D+03, 9.1469297093176D+02, -2.3634831297013D+03, & + 3.4289073363414D+03, -1.1416454795844D+03, -1.5199034217066D+01, & + 1.4232675696336D+02, 9.3114014166986D+02, -1.4217668280744D+03, & + -6.6892280796250D+03, 4.5183848177059D+03, 1.2162309555107D+04, & + -6.0881419416832D+03, -6.5629804880923D+03, 4.3337118077328D+03, & + -8.1558350744764D+02, 4.3004262747050D+01, -4.5882304802650D+02, & + -2.0410524329200D+03, 6.1474199330111D+03, 1.1724980372884D+04, & + -2.3175030314049D+04, -1.1837559831675D+04, 2.5197118132844D+04, & + -3.2683703679870D+03, -2.7866974850481D+03, -2.8591617842506D+01, & + 3.1751114848550D+02, 1.2298684178193D+03, -4.5417151814417D+03, & + -6.2204390702960D+03, 1.7700472889577D+04, 2.6246105174545D+03/ +data (coef(i),i=297,590 ) / & + -1.8861366382775D+04, 7.9585442979514D+03, 3.9716425665863D-02, & + -7.6680420565681D-02, -2.9794073611373D-02, 2.9651275363141D-01, & + 2.3617540011178D-01, -5.3814608941930D+00, 4.0147726416215D+00, & + 3.7532098679521D+01, -3.9135190680333D+01, -1.1925521735589D+02, & + 1.2926060949759D+02, 1.9857026702725D+02, -2.0774883055076D+02, & + -1.7655360260354D+02, 1.7333813535796D+02, 6.9917438328193D+01, & + -6.5021997846616D+01, 3.8151219229796D-02, 4.3843768950232D-02, & + -2.4086574908239D-01, 2.3158689464466D-02, 6.9158105021969D+00, & + -1.2586455424488D+01, -5.0585593269608D+01, 7.3347518061775D+01, & + 1.4968744302400D+02, -1.6800393040240D+02, -2.4320433942912D+02, & + 2.0861481767385D+02, 2.1775727676924D+02, -1.6369018032037D+02, & + -7.3208995085005D+01, 5.4436885233608D+01, 1.1600348167678D-01, & + -4.9809340646254D-01, 1.5047843655988D+00, 8.3092068539797D+00, & + -3.8274991517389D+01, -1.4955961155500D+01, 2.0476668028645D+02, & + -1.4680118753568D+02, -3.4810875016780D+02, 4.4949122123679D+02, & + 2.1140330213824D+02, -3.4203945153975D+02, -1.7142290576617D+02, & + 8.0503251494110D+01, 1.0907423981457D+02, -3.0813919972698D-01, & + 5.3469826239172D+00, 4.1194843505592D+00, -1.1308670564800D+02, & + 4.5037871493300D+01, 6.4697558804757D+02, -3.3915227244081D+02, & + -1.3127082959971D+03, 4.7475537719540D+02, 8.1252490358818D+02, & + 3.0426799712395D+02, 2.9160486418388D+02, -6.4609348432963D+02, & + -2.1720015797288D+02, -4.0717901122888D-01, -2.1775365635881D+00, & + 2.0109616610057D+01, 1.1840212900112D+02, -2.3299581294368D+01, & + -1.3804184017780D+03, -3.7864690931221D+02, 5.4422454262195D+03, & + 1.1731401502819D+02, -7.8538796156468D+03, 1.2681623750875D+03, & + 2.4245427250637D+03, 5.2537243990115D+02, 4.9012179973933D+00, & + -5.8422833107136D+01, -1.1959337380958D+02, 7.6197184851275D+02, & + -5.4004121440061D+02, -6.5752094811032D+02, 5.0117235022499D+03, & + -8.3195437886163D+03, -4.0923671328069D+03, 1.4067572094755D+04, & + -5.1926504471740D+03, -1.8352378595347D+03, 1.8348460774400D+00, & + 4.4232889207825D+01, -2.8532180098981D+02, -5.7783235501804D+02, & + 4.7469633395506D+03, -2.7717073870747D+03, -1.5477480217467D+04, & + 2.0164435060594D+04, 7.6472187060327D+03, -1.4329906429453D+04, & + 2.7654174295895D+03, -2.4933719687704D+01, 1.6938637652995D+02, & + 1.1725472236032D+03, -2.6185152590142D+03, -9.5402134640010D+03, & + 1.7455906770618D+04, 1.7071726465930D+04, -4.2977938350785D+04, & + 8.3240887122425D+03, 8.9751790796763D+03, 2.1229895778839D+01, & + -1.8436561758379D+02, -8.5222313684980D+02, 2.8331698142703D+03, & + 5.3669935127176D+03, -1.4884070826991D+04, -4.6728813976088D+03, & + 2.8923002872424D+04, -1.5729684853032D+04, -9.1001855777311D-02, & + 1.2606953268180D-01, -3.1519952720694D-01, 1.0882246949699D-02, & + 6.1775970589028D+00, 4.0310495365214D+00, -6.9928682686748D+01, & + 9.0965453694424D+00, 3.2158833968308D+02, -1.6194149323382D+02, & + -6.7791173776787D+02, 4.6669667687548D+02, 6.5699669870691D+02, & + -5.2009876671815D+02, -2.3449493492895D+02, 2.0039592779180D+02, & + 3.8802318093898D-03, -4.9919819499055D-01, -2.6557572554758D+00, & + 2.2769271640128D+00, 1.7001242162874D+01, 3.3420756287497D+01, & + -2.9261140751289D+01, -2.1451913425330D+02, -8.3514798161063D+01, & + 6.0390350949326D+02, 2.4911128495358D+02, -8.8970779087907D+02, & + -6.1341985024217D+01, 5.2339793092702D+02, -1.4773870434232D+02, & + -7.3018652841179D-02, 1.2511869964145D-01, -9.0051305439079D-01, & + 1.5938093544128D+01, 3.6086128531278D+01, -1.5519028779513D+02, & + -3.6378153009876D+02, 7.4515812347262D+02, 9.4098545547879D+02, & + -2.0232105093403D+03, -6.3656643380741D+02, 2.2768813182156D+03, & + -1.1769679117170D+02, -7.5095701817072D+02, -6.3164626178965D-02, & + -2.4973821350993D+00, 7.5448861484495D+00, 1.1635606223809D+02, & + -2.2524693749573D+02, -1.0556395012207D+03, 1.8778696180785D+03, & + 2.4814533070907D+03, -4.9001417316772D+03, 2.8787017655091D+02, & + 1.9230152500049D+03, -2.4720091192153D+03, 2.2231531670467D+03, & + -1.5972254758261D+00, 3.3358952350678D+01, -1.5349485484053D+02, & + -1.0222605060145D+03, 2.6058333596737D+03, 5.5066961210604D+03, & + -1.0260746375597D+04, -9.5244944213392D+03, 1.4445465194127D+04, & + 6.7693189472350D+03, -7.0519076729418D+03, -2.2351446735772D+03, & + -4.0377331481523D+00, -2.1309356232702D+01, 1.0932116051132D+03, & + 1.8951040191421D+03, -1.2638353905062D+04, -7.8334339454752D+03, & + 3.7355822038927D+04, -3.2070232783474D+02, -2.7752315703767D+04, & + 3.0703700646355D+03, 6.7196527978088D+03, 1.8589753977584D+01, & + -1.1531237755348D+02, -1.9071791312915D+03, -5.0507717540472D+02, & + 1.8671838329812D+04, 1.8782898019424D+03, -4.9077963825250D+04, & + 1.9663501548405D+04, 1.6775956075880D+04, -6.8797694636129D+03, & + -1.5392769605278D+01, 1.4314231518070D+02, 9.2742914488985D+02, & + -8.6369670411176D+02, -7.5732720415571D+03, 1.2303421777411D+03, & + 1.9655249072421D+04, -1.1356364687235D+04, -1.5516005133570D+03, & + 7.7063768526421D-02, 7.0426469599854D-02, 2.0761670250555D+00, & + -2.8634959354359D+00, -3.1164263380429D+01, 6.3325838362807D+01, & + 1.3440137971042D+02, -4.2450130534225D+02, -1.7557989913336D+02, & + 1.1703417590195D+03, -1.5736118502704D+02, -1.4314931107424D+03, & + 5.4735799135351D+02, 6.5228691636034D+02, -3.4649449001593D+02, & + 3.3658722082134D-01, -5.0676809602213D+00, -2.9106727200001D+00, & + 8.2676750156482D+01, -1.3148704459247D+02, -2.5035771616523D+02, & + 8.8155125325036D+02, 1.5760038417742D+01, -1.7669112592171D+03, & + 3.7903643238106D+02, 1.3940556790468D+03, 9.5473923100084D+01, & + -5.9488289804203D+02, -1.0375305686597D+02, 1.0611853628745D-01, & + 6.8018645407458D-01, -3.8241143585196D+01, -1.4180657093351D+02, & + 5.5839462134171D+02, 8.9083861487365D+02, -2.2428731955568D+03, & + -1.0696194575091D+03, 3.3044661448638D+03, -1.1680010201567D+02, & + -1.7920012637278D+03, -6.1232642612491D+02, 1.3836367193425D+03, & + 2.0417520570553D-01, -7.9433513459797D+00, 4.9941677146710D+01, & + 3.8556761998824D+02, -4.3354401901645D+02, -2.9252579756013D+03, & + 7.0787648712498D+02, 7.4494602120593D+03, -7.2827828707273D+02, & + -6.2503713255535D+03, 9.7289221009631D+02, 7.7312858527177D+01, & + -6.6197854413995D+00, 1.0995202663404D+02, 4.2496312130364D+02, & + -1.0926295063977D+03, -3.4735863505250D+03, 3.8366949704567D+03, & + 6.8787898380604D+03, -5.5632277387875D+03, -4.8778452478220D+03, & + 3.2616178520528D+03, 2.0068291316213D+03, 3.5777786501690D+00, & + -5.7449163082074D+01, -1.1330140975813D+03, -2.3867994586921D+02, & + 1.2486261487440D+04, -2.9307104402199D+03, -2.7262386305868D+04, & + 1.3625571370624D+04, 9.8571450057540D+03, -5.6749289072923D+03/ +data (coef(i),i=591,823)/ & + 4.1553990812089D+00, -7.9039807148033D+01, 8.8968879497294D+02, & + 1.3455454325898D+03, -1.0988450257158D+04, 2.1243056081888D+03, & + 2.2695927933545D+04, -1.6151195263114D+04, 5.7162399438863D+02, & + -1.4707745858430D-01, 9.7352979651830D-01, -1.3963979746230D+00, & + -5.0620597759579D+00, 4.1889115153715D+01, -1.6750935186307D+02, & + 5.4153300234594D+01, 8.6519209898296D+02, -9.9771562423031D+02, & + -1.1954597331072D+03, 1.9130571891052D+03, 3.2970524550364D+02, & + -1.0799252122230D+03, 2.3188545562150D+02, -2.3260472371895D+00, & + 2.8778841876862D+01, 7.3729117301464D+01, -3.9665840600899D+02, & + -1.0492975222219D+02, 9.8391313374665D+02, -8.7153556883620D+02, & + 1.2925482149096D+02, 2.8407542775704D+03, -2.5510566959515D+03, & + -2.6562766587407D+03, 1.9418505402370D+03, 6.4880930217887D+02, & + -6.6339523191321D-01, -6.7652338227873D+00, 1.2595758727568D+02, & + 2.6358517711430D+02, -1.9491350746858D+03, -8.1556544124539D+02, & + 8.0674120988159D+03, -2.8030710355945D+03, -8.2835866894133D+03, & + 8.5200522744880D+03, -1.4823246514080D+03, -1.8582682447107D+03, & + 1.3411433749499D+01, -1.0724377110067D+02, -7.3011900696809D+02, & + 3.2986284159027D+02, 5.4422009200589D+03, 5.1612586434237D+03, & + -1.5408182231606D+04, -1.7219721238496D+04, 2.3099974160780D+04, & + 7.5627594219128D+03, -7.2222488902078D+03, 9.0134473169245D+00, & + -1.8141737623666D+02, -1.6250043077780D+02, 2.7734466811064D+03, & + -1.7603482955414D+03, -8.4261842852894D+03, 1.1505910416517D+04, & + 2.3905813350797D+03, -9.9322452343220D+03, 2.5033774697627D+03, & + -1.5504722193729D+01, 2.3356522943559D+02, 5.0446696501510D+02, & + -2.7974049426340D+03, -2.1728892649799D+03, 8.8232547331869D+03, & + -8.8130817256117D+02, -5.5988385752909D+03, 2.4600534679954D+03, & + 2.9839839544840D-01, -2.5151376007022D+00, -1.6128107429533D+01, & + 1.5815400376918D+01, 1.7510608940292D+02, 9.2482388065900D+01, & + -9.7809220540734D+02, -2.4201666223881D+02, 2.3142988047960D+03, & + -4.5860050306794D+02, -1.8750958557472D+03, 7.4085721397343D+02, & + 2.8053172515762D+02, 4.1947911256955D-02, 1.0075005360980D+01, & + -6.7719600149183D+01, -3.0685585897860D+02, 1.1072385861168D+03, & + 1.6789916295748D+03, -4.8695580803695D+03, -2.0262753920751D+03, & + 5.5980332463152D+03, 6.2850579996277D+02, 2.3166144606877D+02, & + -2.2309515494369D+03, 2.5859761872220D+00, -1.0732897589540D+01, & + -1.4608367222295D+02, 7.3151950872768D+02, 2.0691657871185D+03, & + -6.2964172055131D+03, -7.0631065409304D+03, 1.3988300813956D+04, & + -6.8942777509668D+02, -7.6064339013414D+03, 5.2175199344330D+03, & + -2.9738335062942D+01, 2.6716014780161D+02, 1.4275147307938D+03, & + -2.6294668536922D+03, -9.2629448907848D+03, 3.1355735803168D+03, & + 2.1600693888086D+04, 3.6602362688419D+03, -2.6634480984280D+04, & + 7.9284616538140D+03, 6.7932985538261D+00, -4.0715244679510D+01, & + -2.9625172153656D+02, 6.2654153362437D+01, 3.1592520545123D+03, & + -1.2656094035574D+03, -6.9719119937501D+03, 5.0452169759528D+03, & + 6.3580318228825D+02, 4.9487190936163D-01, -8.1704383753618D+00, & + 3.0866575425802D+01, 1.2890521782151D+02, -7.1868218834493D+02, & + 1.2673007356194D+02, 2.5550860147502D+03, -1.7241055434141D+03, & + -2.3386125844583D+03, 1.9632048623696D+03, 4.8684298042802D+02, & + -6.0019082249152D+02, 1.8914198671144D+01, -2.5768302141778D+02, & + -4.5268033914720D+02, 4.0156097099637D+03, -1.2034046445670D+03, & + -1.2847127836559D+04, 1.2601534082468D+04, 1.0123828204742D+04, & + -1.8277570534558D+04, 4.9534460864680D+03, 1.7746905955483D+03, & + -5.6579196192910D+00, 6.8763882806458D+01, 8.2283065915338D+01, & + -2.4462084382260D+03, -4.0910387942633D+02, 1.5800388896523D+04, & + -1.5542381059831D+03, -2.2695400772600D+04, 1.4191039695857D+04, & + -3.1236918418556D+03, 1.5730605077744D+01, -1.4806541142544D+02, & + -7.3549773901344D+02, 1.9567318545056D+03, 3.8451428102190D+03, & + -5.0356609530826D+03, -5.0370354604727D+03, 1.8104166969353D+03, & + 3.4573735155463D+03, -2.2310791296488D+00, 3.0309038289269D+01, & + 2.4387010913574D-02, -4.0609309840901D+02, 9.8147125540770D+02, & + -1.2887853697751D+02, -2.9863513297012D+03, 2.9859066623897D+03, & + 7.5810452433204D+02, -1.3633646747081D+03, 2.3494005037572D+02, & + -3.6049971507842D+01, 4.6341305915926D+02, 1.0179406463565D+03, & + -6.8412635604360D+03, -3.4856750931568D+02, 1.9896790284724D+04, & + -1.0548394707187D+04, -1.5786132878027D+04, 1.5616388325597D+04, & + -3.8177104809982D+03, 3.9840698767479D+00, -5.5640306634995D+01, & + -4.1773631283442D+01, 1.6530852321701D+03, 3.5846651873594D+01, & + -1.0125455268494D+04, 1.4310619082953D+03, 1.4684788370590D+04, & + -7.5655604775677D+03, 2.1863563084839D+00, -2.8676540512968D+01, & + -2.5470438201247D+01, 3.6758591398511D+02, -5.7140314000597D+02, & + 3.8434447269712D+01, 1.5820008738722D+03, -2.0663067220802D+03, & + 3.5807377993698D+02, 2.8966278527317D+02, 1.9992892131663D+01, & + -2.5091839059403D+02, -5.9493849732297D+02, 3.6040463692465D+03, & + 6.8425945490518D+02, -9.8117448904512D+03, 2.9842697258990D+03, & + 7.8691352095489D+03, -4.3817966235099D+03, -5.5702600343214D-01, & + 7.2587027792799D+00, 8.6351336949194D+00, -8.9552953762538D+01, & + 1.1575980363922D+02, -3.0029982429047D+01, -2.8073588184232D+02, & + 5.1929492676140D+02, -2.3951066467556D+02/ + +contains + ! some wrapper functions and the Partridge Schwenke Dipole moment surface for water - published + ! J. Chem. Phys. 113, 6592 (2000); http://dx.doi.org/10.1063/1.1311392 + ! retreived from EPAPS : EPAPS Document No. E-JCPSA6-113-304040 + + subroutine m_site_position(atomic_positions,gammaM,pos) + real(dp), dimension(3,3),intent(in) :: atomic_positions + real(dp), intent(in) :: gammaM + real(dp),dimension(3),intent(out) :: pos + + pos = (1.0_dp-gammaM)*atomic_positions(:,3) + 0.5_dp*gammaM*(atomic_positions(:,1)+atomic_positions(:,2)) + end subroutine m_site_position + + subroutine m_site_position_grads(gammaM,grads) + real(dp), intent(in) :: gammaM + real(dp), dimension(3,3,3),intent(out) :: grads + real(dp), dimension(3,3) :: identity3x3 + + identity3x3 = 0.0_dp + call add_identity(identity3x3) + + grads(:,:,1) = (0.5_dp*gammaM) *identity3x3 + grads(:,:,2) = (0.5_dp*gammaM) *identity3x3 + grads(:,:,3) = (1.0_dp-gammaM) *identity3x3 + + end subroutine m_site_position_grads + + subroutine test_charge_grads_PS(atomic_positions,gammaM) + real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom, as dms_nasa expects + real(dp) :: gammaM + + real(dp) :: q0,q_plus,step + real(dp), dimension(3,3) :: x + real(dp), dimension(1,3,3) :: grad + integer :: i_site,i,j + + step=1e-8_dp + do i_site=1,3 + call charges_PS(atomic_positions,q0,i_site,gammaM) + call charge_gradients_PS(atomic_positions,grad,gammaM,i_site) + do i=1,3 ! loop over position components + do j=1,3 ! loop over atoms + x=atomic_positions + x(i,j)= x(i,j)+step + call charges_PS(x,q_plus,i_site,gammaM) + call print(" Step Size : "// step //" (q(i)-q0(i)) / (grad*step) : "//(q_plus -q0)/ (grad(1,i,j)*step)) + end do + end do + end do + end subroutine test_charge_grads_PS + + subroutine charges_PS(atomic_positions,charge,i_site,gammaM) + real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom, as dms_nasa expects + real(dp),intent(inout) :: charge + integer, intent(in) :: i_site + real(dp),intent(inout) :: gammaM + + real(dp), dimension(3) :: q + real(dp), dimension(3,3) :: x + real(dp), dimension(3,3,3) :: charge_grads + real(dp) :: tmp + integer :: i + + ! vibdip function wants atomic order to be H,H,O, whereas dms_nasa expects O,H,H, so have to switch + do i=1,3 + x(:,i)=atomic_positions(:,4-i) + end do + + tmp=0.5_dp*gammaM/(1.0_dp-gammaM) +#ifdef HAVE_FX + call dms_nasa(x,q,charge_grads) +#endif + ! sites 1 and 2 are hydrogens, site 3 is the M-site + select case(i_site) + case(1) + charge = q(3)+tmp*(q(2)+q(3)) + case(2) + charge = q(2)+tmp*(q(2)+q(3)) + case(3) + charge = q(1) / (1.0_dp-gammaM) + case default + call system_abort("invalid i_site passed to charges_PS, only 3 sites per monomer") + end select +call print("array of charges "//q) + end subroutine charges_PS + + subroutine charge_gradients_PS(atomic_positions,grad,gammaM,i_site) + ! PS definitions ! QUIP structure + ! charge grad components (1,3,3) -> ! grad array which we return has structure (1,3,3) + ! 1st index labels the atom wrt which we differentiate ! 1st index labels charge + ! 2nd index labels the charge (H1,H2,O) whose charge is 'changing' ! 2nd index labels cartesian component + ! 3rd index labels the cartesian component of atom i's position ! 3rd index labels the atom + + real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom + real(dp), dimension(1,3,3),intent(inout) :: grad ! indices: (1,position component,atom) index 1 is the site(fixed), 2 is pos component, 3 is atom + real(dp),intent(inout) :: gammaM + integer, intent(in) :: i_site + + real(dp), dimension(3,3,3) :: charge_grads ! indices: (atom,charge,position component) + real(dp), dimension(3,3) :: x,dq_dqa !! gradients of site charges (as def in TTM models) wrt atomic charges from dms + real(dp), dimension(3) :: q + integer :: i_charge,i_atom,i_pos + real(dp) :: a, b + + ! ordering of sites is HHM, ordering of dms charges is OHH + + b=0.5_dp*gammaM + a=1.0_dp-b + + !gradients of site charges (q) wrt atomic dms charges (qa) which we get from PS function. + dq_dqa = (1.0_dp /( 1.0_dp-gammaM)) * reshape((/0.0_dp,0.0_dp,1.0_dp,b,a,0.0_dp,a,b,0.0_dp/),shape(dq_dqa)) + + +do i_atom=1,3 +call print(" "//dq_dqa(i_atom,:)) +end do + + ! switch to OHH atom ordering + do i_atom=1,3 + x(:,i_atom)=atomic_positions(:,4-i_atom) + end do +#ifdef HAVE_FX + call dms_nasa(x,q,charge_grads) +#endif + + + grad=0.0_dp + do i_atom=1,3 + do i_charge=1,3 + grad(1,:,i_atom) = grad(1,:,i_atom) + dq_dqa(i_site,i_charge) * charge_grads(4-i_atom,i_charge,:) ! 4-i_atom because switching from OHH to HHO ordering + end do +call print("atom number "//i_atom) +call print(""//grad(1,:,i_atom)) + end do + + end subroutine charge_gradients_PS + + subroutine dipole_moment_PS(atomic_positions,dipole) + real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom + real(dp), dimension(3),intent(inout) :: dipole + real(dp), dimension(1,3,3) :: x ! rank 3 array because that's what vibdip takes as an argument + real(dp), dimension(1,3) :: d ! rank 2 array because that's what vibdip takes as an argument + x(1,:,:) = atomic_positions *(1.0_dp/BOHR) ! convert to a.u. + call vibdip(x,d,1) + dipole = d(1,:)* BOHR ! convert from a.u. + end subroutine dipole_moment_PS + + subroutine dipole_moment_gradients_PS(atomic_positions,grad,step,test) + + ! calculate gradients of dipole moment components wrt atomic positions, using finite differences + ! step is an optional parameter, but should be chosen to get maximal precision in the gradients + + real(dp),intent(in), optional :: step ! distance in Angstroms to move atoms for finite diff + logical,intent(in), optional :: test ! whether to test to find the best step size + real(dp) :: my_step + real(dp), dimension(1,3) :: d_plus, d_minus, d_plus_fd, d0 + real(dp), dimension(3,3),intent(in) :: atomic_positions ! dimension 1 is component, dimension 2 is atom + real(dp), dimension(1,3,3) :: x ! working array to hold temporary positions + real(dp), dimension(3,3,3),intent(inout) :: grad + integer :: i, j ,k + logical :: do_test + + do_test = optional_default(.False.,test) + my_step = optional_default(1e-8_dp *BOHR, step) + + if (do_test) then + call print("RESULT OF GRADIENT TESTING THE FINITE DIFFERENCE GRADS") + end if + + grad = 0.0_dp + + do i=1,3 ! loop over atoms + do j=1,3 ! loop over position components + x(1,:,:) = atomic_positions *(1.0_dp/BOHR) + x(1,j,i) = x(1,j,i) + my_step + call vibdip(x,d_plus,1) + x(1,j,i) = x(1,j,i) - 2.0_dp*my_step + call vibdip(x,d_minus,1) + do k=1,3 ! loop over dipole components + grad(k,j,i) = (d_plus(1,k) - d_minus(1,k)) / (2.0_dp * my_step) ! this already in QUIP units, since dipole gradient with position just has units of charge (e). + end do + end do + end do + + if (do_test) then + call print("Testing gradient of PS dipole moment components wrt atomic positions : ") + my_step = 0.9_dp*my_step + do i=1,3 ! loop over atoms + do j=1,3 ! loop over position components + do k=1,3 ! loop over dipole components + x(1,:,:) = atomic_positions *(1.0_dp/BOHR) + call vibdip(x,d0,1) + x(1,j,i) = x(1,j,i) + my_step + call vibdip(x,d_plus,1) + call print(" Step Size : "// my_step //" (d(i)-d0(i)) / (grad*step) : "//(d_plus(1,k) -d0(1,k))/ (grad(k,j,i)*my_step)) + end do + end do + end do + end if + + end subroutine dipole_moment_gradients_PS + + subroutine vibdip(x,d,n) + integer :: n, isump,nf,i,j, ifirst=0 + real(dp), dimension(n,3,3) :: x + real(dp), dimension(n,3) :: d + real(dp), dimension(19,3) :: fmat + real(dp) :: reoh, thetae,b1,toang,rad,cabc,ce,r1x,r1y,r1z,r1,r2x,r2y,r2z,r2, & + x1,x2,x3,p1,p2,damp1,damp2,term,term1,term2 + save + + !!$c + !!$c dipole moment surface for h2o, + !!$c David W. Schwenke and Harry Partridge, J. Chem. Phys., + !!$c submitted May, 2000. + !!$c + !!$c x(i,j,k) is cartesian coordinate (in a.u.) of atoms in some frame + !!$c of reference, i is geometry no., j=1 x, j=2 y, j=3 z, + !!$c k=1,2 h, k=3 o. + !!$c n is number of geometries. + !!$c + !!$c return dipole moment d(i,j) (in a.u.), i is geometry no., j=1 x, + !!$c j=2 y, j=3 z in the same frame of reference as input + !!$c cartesians. + !!$c + + if(ifirst.eq.0)then + ifirst=1 + ! write(6,1) + !!$1 format(/1x,'dipole moment surface for h2o', + !!$ $ /1x,'by David W. Schwenke and Harry Partridge ', + !!$ $ /1x,'submitted to J. Chem. Phys. May, 2000', + !!$ $ /1x,'use parameters for FIT2') !6d6s00 + reoh= 0.958648999999999973d0 + thetae= 104.347499999999997d0 + b1= 1.50000000000000000d0 + !!$ write(6,4)reoh,thetae,b1 + !!$ 4 format(/1x,'reoh = ',f10.4,' thetae = ',f10.4, + !!$ $ /1x,'beta = ',f10.4) + nf=1 + isump=0 + toang=1d0/1.889725989d0 + reoh=reoh*1.889725989d0 + b1=b1/1.889725989d0**2 + nf=823 !6d6s00 + do i=1,nf !6d6s00 + !write(6,5)(idx(i,j),j=1,3),coef(i) + !5 format(1x,3i5,1pe15.7) + isump=max(isump,idx(i,1),idx(i,2),idx(i,3)) + end do + rad=acos(-1d0)/1.8d2 + ce=cos(thetae*rad) + end if + + + do i=1,n + + r1x=x(i,1,1)-x(i,1,3) + r1y=x(i,2,1)-x(i,2,3) + r1z=x(i,3,1)-x(i,3,3) + r1=sqrt(r1x**2+r1y**2+r1z**2) + r2x=x(i,1,2)-x(i,1,3) + r2y=x(i,2,2)-x(i,2,3) + r2z=x(i,3,2)-x(i,3,3) + r2=sqrt(r2x**2+r2y**2+r2z**2) + cabc=(r1x*r2x+r1y*r2y+r1z*r2z)/(r1*r2) + x1=(r1-reoh)/reoh + x2=(r2-reoh)/reoh + x3=cabc-ce + fmat(1,1)=1d0 + fmat(1,2)=1d0 + fmat(1,3)=1d0 + + do j=2,isump + + fmat(j,1)=fmat(j-1,1)*x1 + fmat(j,2)=fmat(j-1,2)*x2 + fmat(j,3)=fmat(j-1,3)*x3 + end do + p1=0d0 + p2=0d0 + damp1=exp(-b1*((r1-reoh)**2)) !6d6s00 + damp2=exp(-b1*((r2-reoh)**2)) !6d6s00 + + do j=1,nf + term=coef(j)*fmat(idx(j,3),3) + term1=term*fmat(idx(j,1),1)*fmat(idx(j,2),2) + term2=term*fmat(idx(j,2),1)*fmat(idx(j,1),2) + if(idx(j,2).gt.1.or.idx(j,3).gt.1)then !2d26s99 + term1=term1*damp2 !2d26s99 + term2=term2*damp1 !2d26s99 + end if !2d26s99 + p1=p1+term1 + p2=p2+term2 + end do + p1=p1*damp1 + p2=p2*damp2 + d(i,1)=p1*(x(i,1,1)-x(i,1,3))+p2*(x(i,1,2)-x(i,1,3)) + d(i,2)=p1*(x(i,2,1)-x(i,2,3))+p2*(x(i,2,2)-x(i,2,3)) + d(i,3)=p1*(x(i,3,1)-x(i,3,3))+p2*(x(i,3,2)-x(i,3,3)) + end do + return + end subroutine vibdip + +end module partridge_schwenke_dipole_module diff --git a/src/Potentials/Potential.F90 b/src/Potentials/Potential.F90 new file mode 100644 index 0000000000..560329acda --- /dev/null +++ b/src/Potentials/Potential.F90 @@ -0,0 +1,2442 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!% This module encapsulates all the interatomic potentials implemented in QUIP +!% +!% A Potential object represents an interatomic potential, a +!% tight binding model or an interface to an external code used to +!% perform calculations. It is initialised from an `args_str` +!% describing the type of potential, and an XML formatted string +!% `param_str` giving the parameters. +!% +!% Types of Potential: +!% +!% ==================== ========================================================== +!% `args_str` prefix Description +!% ==================== ========================================================== +!% ``IP`` Interatomic Potential +!% ``TB`` Tight Binding Model +!% ``FilePot`` File potential, used to communicate with external program +!% ``CallbackPot`` Callback potential, computation done by Python function +!% ``Sum`` Sum of two other potentials +!% ``ForceMixing`` Combination of forces from two other potentials +!% ==================== ========================================================== +!% +!% +!% Types of interatomic potential available: +!% +!% ======================== ========================================================== +!% `args_str` prefix Description +!% ======================== ========================================================== +!% ``IP BOP`` Bond order potential for metals +!% ``IP BornMayer`` Born-Mayer potential for oxides +!% (e.g. BKS potential for silica) +!% ``IP Brenner`` Brenner (1990) potential for carbon +!% ``IP Brenner_2002`` Brenner (2002) reactive potential for carbon +!% ``IP Brenner_Screened`` Interface to Pastewka et al. screened Brenner reactive +!% potential for carbon +!% ``IP Coulomb`` Coulomb interaction: support direct summation, +!% Ewald and damped shifted force Coulomb potential +!% ``IP Einstein`` Einstein crystal potential +!% ``IP EAM_ErcolAd`` Embedded atom potential of Ercolessi and Adams +!% ``IP FB`` Flikkema and Bromley potential +!% ``IP FS`` Finnis-Sinclair potential for metals +!% ``IP FX`` Wrapper around ttm3f water potential of +!% Fanourgakis-Xantheas +!% ``IP GAP`` Gaussian approximation potential +!% ``IP Glue`` Generic implementation of 'glue' potential +!% ``IP HFdimer`` Simple interatomic potential for an HF dimer, from +!% MP2 calculations +!% ``IP KIM`` Interface to KIM, the Knowledgebase of Interatomic +!% potential Models (www.openkim.org) +!% ``IP LJ`` Lennard-Jones potential +!% ``IP Morse`` Morse potential +!% ``IP PartridgeSchwenke`` Partridge-Schwenke model for a water monomer +!% ``IP SW`` Stillinger-Weber potential for silicon +!% ``IP SW_VP`` Combined Stillinger-Weber and Vashista potential +!% for Si and :mol:`SiO_2`. +!% ``IP Si_MEAM`` Silicon modified embedded attom potential +!% ``IP Sutton_Chen`` Sutton-Chen potential +!% ``IP TS`` Tangney-Scandolo polarisable potential for oxides +!% ``IP Tersoff`` Tersoff potential for silicon +!% ``IP WaterDimer_Gillan`` 2-body potential for water dimer +!% ======================== ========================================================== +!% +!% Types of tight binding potential available: +!% +!% ======================= ========================================================== +!% `args_str` prefix Description +!% ======================= ========================================================== +!% ``TB Bowler`` Bowler tight binding model +!% ``TB DFTB`` Density functional tight binding +!% ``TB GSP`` Goodwin-Skinner-Pettifor tight binding model +!% ``TB NRL_TB`` Naval Research Laboratory tight binding model +!% ======================= ========================================================== +!% +!% Examples of the XML parameters for each of these potential can be +!% found in the `src/Parameters `_ +!% directory of the QUIP git repository. +!% +!%!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#ifdef HAVE_LOCAL_E_MIX +#define HAVE_HYBRID +#endif +#ifdef HAVE_ONIOM +#define HAVE_HYBRID +#endif + +#include "error.inc" +module Potential_module + + use error_module + use system_module, only : dp, inoutput, print, PRINT_ALWAYS, PRINT_NORMAL, PRINT_VERBOSE, PRINT_NERD, initialise, finalise, INPUT, & + optional_default, current_verbosity, mainlog, round, verbosity_push_decrement, verbosity_push, verbosity_pop, print_message, system_timer, system_abort, operator(//) + use units_module, only : EV_A3_IN_GPA + use periodictable_module, only : ElementCovRad, ElementMass + use extendable_str_module, only : extendable_str, initialise, read, string, finalise + use linearalgebra_module , only : norm, trace, matrix3x3_det, normsq, least_squares, add_identity, inverse, diagonalise, symmetric_linear_solve, operator(.fne.), operator(.mult.), operator(.feq.), print + use dictionary_module, only : dictionary, STRING_LENGTH, lookup_entry_i, write_string, get_value, has_key, read_string, set_value, remove_value, initialise, finalise + use paramreader_module, only : param_register, param_read_line + use mpi_context_module, only : mpi_context + use table_module, only : table, find, int_part, wipe, append, finalise + use minimization_module , only : minim, n_minim, fire_minim, test_gradient, n_test_gradient + use connection_module, only : connection + use atoms_types_module, only : atoms, assign_pointer, add_property, assign_property_pointer, add_property_from_pointer, diff_min_image, distance_min_image + use atoms_module, only : has_property, cell_volume, neighbour, n_neighbours, set_lattice, is_nearest_neighbour, & + get_param_value, remove_property, calc_connect, set_cutoff, set_cutoff_minimum, set_param_value, calc_dists, atoms_repoint, finalise, assignment(=) + use cinoutput_module, only : cinoutput, write, quip_chdir, quip_dirname, quip_basename, quip_getcwd + use dynamicalsystem_module, only : dynamicalsystem, ds_print_status, advance_verlet1, advance_verlet2 + use clusters_module, only : HYBRID_ACTIVE_MARK, HYBRID_NO_MARK, HYBRID_BUFFER_MARK, create_embed_and_fit_lists_from_cluster_mark, create_embed_and_fit_lists, & + create_hybrid_weights, add_cut_hydrogens, create_cluster_info_from_mark, bfs_grow, carve_cluster + + use QUIP_Common_module +#ifdef HAVE_TB + use TB_module +#endif + use Potential_simple_module + + use adjustablepotential_module, only: adjustable_potential_init, adjustable_potential_optimise, & + adjustable_potential_force, adjustable_potential_finalise + + implicit none + +#ifndef POTENTIAL_NO_DEFAULT_PRIVATE + private +#endif + + logical, save :: printed_cutoff_warning = .false. + + !************************************************************************* + !* + !* Potential header + !* + !************************************************************************* + + integer :: hack_restraint_i(2) + real(dp) :: hack_restraint_r, hack_restraint_k + public :: hack_restraint_i, hack_restraint_r, hack_restraint_k + + public :: Potential + !% Potential type which abstracts all QUIP interatomic potentials + !% + !% Provides interface to all energy/force/virial calculating schemes, + !% including actual calculations, as well as abstract hybrid schemes + !% such as LOTF, Force Mixing, ONIOM, and the local energy scheme. + !% + !% Typically a Potential is constructed from an initialisation + !% args_str and an XML parameter file, e.g. in Fortran:: + !% + !% type(InOutput) :: xml_file + !% type(Potential) :: pot + !% ... + !% call initialise(xml_file, 'SW.xml', INPUT) + !% call initialise(pot, 'IP SW', param_file=xml_file) + !% + !% Or, equivaently in Python:: + !% + !% pot = Potential('IP SW', param_filename='SW.xml') + !% + !% creates a Stillinger-Weber potential using the parameters from + !% the file 'SW.xml'. The XML parameters can also be given directly + !% as a string, via the `param_str` argument. + !% + !% The main workhorse is the :meth:`calc` routine, which is used + !% internally to perform all calculations, e.g. to calculate forces:: + !% + !% type(Atoms) :: at + !% real(dp) :: force(3,8) + !% ... + !% call diamond(at, 5.44, 14) + !% call randomise(at%pos, 0.01) + !% call calc(pot, at, force=force) + !% + !% Note that there is now no need to set the 'Atoms%cutoff' attribute to the + !% cutoff of this Potential: if it is less than this it will be increased + !% automatically and a warning will be printed. + !% The neighbour lists are updated automatically with the + !% :meth:`~quippy.atoms.Atoms.calc_connect` routine. For efficiency, + !% it's a good idea to set at%cutoff_skin greater than zero to decrease + !% the frequency at which the connectivity needs to be rebuilt. + !% + !% A Potential can be used to optimise the geometry of an + !% :class:`~quippy.atoms.Atoms` structure, using the :meth:`minim` routine, + !% (or, in Python, via the :class:`Minim` wrapper class). + type Potential + type(MPI_context) :: mpi + character(len=STRING_LENGTH) :: init_args_pot1, init_args_pot2, xml_label, xml_init_args, calc_args = "" + + logical :: is_simple = .false. + type(Potential_simple) :: simple + + type(Potential), pointer :: l_mpot1 => null() ! local copies of potentials, if they are created by potential_initialise from an args string + type(Potential), pointer :: l_mpot2 => null() ! local copies of potentials, if they are created by potential_initialise from an args string + + logical :: is_sum = .false. + type(Potential_Sum), pointer :: sum => null() + + logical :: is_forcemixing = .false. + type(Potential_FM), pointer :: forcemixing => null() + + logical :: is_evb = .false. + type(Potential_EVB), pointer :: evb => null() + +#ifdef HAVE_LOCAL_E_MIX + logical :: is_local_e_mix = .false. + type(Potential_Local_E_Mix), pointer :: local_e_mix => null() +#endif + +#ifdef HAVE_ONIOM + logical :: is_oniom = .false. + type(Potential_ONIOM), pointer :: oniom => null() +#endif + + logical :: is_cluster = .false. + type(Potential_Cluster), pointer :: cluster => null() + + logical :: do_rescale_r, do_rescale_E + real(dp) :: r_scale, E_scale + + end type Potential + + public :: Initialise, Potential_Filename_Initialise + interface Initialise + module procedure Potential_Initialise, Potential_Initialise_inoutput + end interface + + public :: Finalise + interface Finalise + module procedure Potential_Finalise + end interface + + public :: Setup_Parallel + interface Setup_Parallel + module procedure Potential_Setup_Parallel + end interface + + public :: Print + interface Print + module procedure Potential_Print + end interface + + + !% Return the cutoff of this 'Potential', in Angstrom. This is the + !% minimum neighbour connectivity cutoff that should be used: if + !% you're doing MD you'll want to use a slightly larger cutoff so + !% that new neighbours don't drift in to range between connectivity + !% updates + public :: Cutoff + interface Cutoff + module procedure Potential_Cutoff + end interface + + public :: Calc + + !% Apply this Potential to the Atoms object + !% 'at'. Atoms%calc_connect is automatically called to update the + !% connecticvity information -- if efficiency is important to you, + !% ensure that at%cutoff_skin is set to a non-zero value to decrease + !% the frequence of connectivity updates. + !% optional arguments determine what should be calculated and how + !% it will be returned. Each physical quantity has a + !% corresponding optional argument, which can either be an 'True' + !% to store the result inside the Atoms object (i.e. in + !% Atoms%params' or in 'Atoms%properties' with the + !% default name, a string to specify a different property or + !% parameter name, or an array of the the correct shape to + !% receive the quantity in question, as set out in the table + !% below. + !% + !% ================ ============= ================ ========================= + !% Array argument Quantity Shape Default storage location + !% ================ ============= ================ ========================= + !% ``energy`` Energy ``()`` ``energy`` param + !% ``local_energy`` Local energy ``(at.n,)`` ``local_energy`` property + !% ``force`` Force ``(3,at.n)`` ``force`` property + !% ``virial`` Virial tensor ``(3,3)`` ``virial`` param + !% ``local_virial`` Local virial ``(3,3,at.n)`` ``local_virial`` property + !% ================ ============= ================ ========================= + !% + !% The 'args_str' argument is an optional string containing + !% additional arguments which depend on the particular Potential + !% being used. + !% + !% Not all Potentials support all of these quantities: an error + !% will be raised if you ask for something that is not supported. + interface Calc + module procedure Potential_Calc + end interface + + !% Minimise the configuration 'at' under the action of this + !% Potential. Returns number of minimisation steps taken. If + !% an error occurs or convergence is not reached within 'max_steps' + !% steps, 'status' will be set to 1 on exit. + !% + !% Example usage (in Python, Fortran code is similar. See + !% :ref:`geomopt` in the quippy tutorial for full + !% explanation):: + !% + !%> at0 = diamond(5.44, 14) + !%> pot = Potential('IP SW', param_str=''' + !%> Stillinger and Weber, Phys. Rev. B 31 p 5262 (1984) + !%> + !%> + !%> p="4" q="0" a="1.80" sigma="2.0951" eps="2.1675" /> + !%> + !%> lambda="21.0" gamma="1.20" eps="2.1675" /> + !%> ''') + !%> pot.minim(at0, 'cg', 1e-7, 100, do_pos=True, do_lat=True) + public :: Minim + interface Minim + module procedure Potential_Minim + end interface + + public :: test_gradient + interface test_gradient + module procedure pot_test_gradient + end interface + + public :: n_test_gradient + interface n_test_gradient + module procedure pot_n_test_gradient + end interface + + public :: set_callback + interface set_callback + module procedure potential_set_callback + end interface + + ! Allow Potential_Precon_Minim access to some Potential Functions + public :: energy_func + public :: gradient_func + public :: print_hook + public :: pack_pos_dg + public :: unpack_pos_dg + public :: fix_atoms_deform_grad + public :: prep_atoms_deform_grad + public :: max_rij_change + public :: constrain_virial + + + public :: potential_minimise + type Potential_minimise + real(dp) :: minim_pos_lat_preconditioner = 1.0_dp + + real(dp) :: minim_save_lat(3,3) + character(len=STRING_LENGTH) :: minim_args_str + logical :: minim_do_pos, minim_do_lat + integer :: minim_n_eval_e, minim_n_eval_f, minim_n_eval_ef + real(dp) :: pos_lat_preconditioner_factor + type(Atoms), pointer :: minim_at => null() + real(dp), pointer :: last_connect_x(:) => null() + type(Potential), pointer :: minim_pot => null() + type(CInoutput), pointer :: minim_cinoutput_movie => null() + real(dp), dimension(3,3) :: external_pressure = 0.0_dp + + logical :: connectivity_rebuilt = .false. + + end type Potential_minimise + + type(Potential), pointer :: parse_pot + logical, save :: parse_in_pot, parse_in_pot_done, parse_matched_label + + public :: run + + interface run + module procedure dynamicalsystem_run + end interface run + +#include "Potential_Sum_header.F90" +#include "Potential_ForceMixing_header.F90" +#include "Potential_EVB_header.F90" + +#ifdef HAVE_LOCAL_E_MIX +#include "Potential_Local_E_Mix_header.F90" +#endif +#ifdef HAVE_ONIOM +#include "Potential_ONIOM_header.F90" +#endif +#include "Potential_Cluster_header.F90" + + ! Public interfaces from Potential_Hybrid_utils.F90 + + public :: bulk_modulus + interface bulk_modulus + module procedure potential_bulk_modulus + end interface bulk_modulus + + public :: test_local_virial + interface test_local_virial + module procedure potential_test_local_virial + end interface test_local_virial + +#ifdef HAVE_TB + public :: calc_TB_matrices + interface calc_TB_matrices + module procedure Potential_calc_TB_matrices + end interface +#endif + + contains + + !************************************************************************* + !* + !* Potential routines + !* + !************************************************************************* + +recursive subroutine potential_Filename_Initialise(this, args_str, param_filename, bulk_scale, mpi_obj, error) + type(Potential), intent(inout) :: this + character(len=*), intent(in) :: args_str !% Valid arguments are 'Sum', 'ForceMixing', 'EVB', 'Local_E_Mix' and 'ONIOM', and any type of simple_potential + character(len=*), intent(in) :: param_filename !% name of xml parameter file for potential initializers + type(Atoms), optional, intent(inout) :: bulk_scale !% optional bulk structure for calculating space and E rescaling + type(MPI_Context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(inoutput) :: io + type(extendable_str) :: my_cwd, param_file_dirname, param_file_basename + + INIT_ERROR(error) + + if (len_trim(param_filename) == 0) then + RAISE_ERROR("potential_Filename_Initialise: empty filename",error) + endif + + my_cwd = quip_getcwd() + param_file_dirname = quip_dirname(trim(param_filename)) + param_file_basename = quip_basename(trim(param_filename)) + + call quip_chdir(param_file_dirname) + + call initialise(io, trim(string(param_file_basename)), INPUT, master_only=.true.) + call initialise(this, args_str, io, bulk_scale=bulk_scale, mpi_obj=mpi_obj, error=error) + PASS_ERROR(error) + call finalise(io) + + call quip_chdir(my_cwd) + +end subroutine potential_Filename_Initialise + +subroutine potential_initialise_inoutput(this, args_str, io_obj, bulk_scale, mpi_obj, error) + type(Potential), intent(inout) :: this + character(len=*), intent(in) :: args_str !% Valid arguments are 'Sum', 'ForceMixing', 'EVB', 'Local_E_Mix' and 'ONIOM', and any type of simple_potential + type(InOutput), intent(in) :: io_obj !% name of xml parameter inoutput for potential initializers + type(Atoms), optional, intent(inout) :: bulk_scale !% optional bulk structure for calculating space and E rescaling + type(MPI_Context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(extendable_str) :: es + + INIT_ERROR(error) + + call initialise(es) + if (io_obj%initialised) then + if (present(mpi_obj)) then + call read(es, io_obj%unit, convert_to_string=.true., mpi_comm=mpi_obj%communicator, mpi_id=mpi_obj%my_proc) + else + call read(es, io_obj%unit, convert_to_string=.true.) + endif + else + call initialise(es) + endif + + call initialise(this, args_str=args_str, param_str=string(es), bulk_scale=bulk_scale, mpi_obj=mpi_obj, error=error) + PASS_ERROR(error) + call finalise(es) + +end subroutine potential_initialise_inoutput + +recursive subroutine potential_initialise(this, args_str, pot1, pot2, param_str, bulk_scale, mpi_obj, error) + type(Potential), intent(inout) :: this + character(len=*), optional, intent(in) :: args_str !% Valid arguments are 'Sum', 'ForceMixing', 'EVB', 'Local_E_Mix' and 'ONIOM', and any type of simple_potential + type(Potential), optional, intent(in), target :: pot1 !% Optional first Potential upon which this Potential is based + type(Potential), optional, intent(in), target :: pot2 !% Optional second potential + character(len=*), optional, intent(in) :: param_str !% contents of xml parameter file for potential initializers, if needed + type(Atoms), optional, intent(inout) :: bulk_scale !% optional bulk structure for calculating space and E rescaling + type(MPI_Context), optional, intent(in) :: mpi_obj + integer, intent(out), optional :: error + + type(Potential), pointer :: u_pot1, u_pot2 + type(Dictionary) :: params + + logical :: has_xml_label, minimise_bulk, has_target_vol, has_target_B, has_r_scale, has_E_scale + real(dp) :: target_vol, target_B, r_scale, vol, B + character(len=STRING_LENGTH) :: my_args_str, init_args_str, first_tag, xml_label + type(Atoms) :: bulk + integer :: it, tag_start, tag_end + + INIT_ERROR(error) + + call finalise(this) + + my_args_str = '' + if (present(args_str)) my_args_str = args_str + + ! Default init_args are xml_label=LABEL, extracting LABEL from first XML tag + if (len_trim(my_args_str) == 0) then + if (.not. present(param_str)) then + RAISE_ERROR('No init_args given and param_str not present', error) + end if + if (len_trim(param_str) == 0) then + RAISE_ERROR('No init_args given and param_str is empty', error) + end if + tag_start = index(param_str, '<') + tag_end = index(param_str, '>') + xml_label = param_str(tag_start+1:tag_end-1) + call print_message('INFO', 'Potential_initialise using default init_args "Potential xml_label='//trim(xml_label)//'"', PRINT_VERBOSE) + my_args_str = 'Potential xml_label='//xml_label + end if + + call initialise(params) + call param_register(params, 'xml_label', '', this%xml_label, has_value_target=has_xml_label, help_string="Label in xml file Potential stanza to match") + call param_register(params, 'calc_args', '', this%calc_args, help_string="Default calc_args that are passed each time calc() is called") + if(.not. param_read_line(params, my_args_str, ignore_unknown=.true.,task='Potential_Initialise args_str')) then + RAISE_ERROR("Potential_initialise failed to parse args_str='"//trim(my_args_str)//"'", error) + endif + call finalise(params) + + my_args_str = "" + if(has_xml_label) then + call Potential_read_params_xml(this, param_str) + my_args_str = trim(this%xml_init_args) + endif + my_args_str = trim(my_args_str) // " " // trim(args_str) + + call initialise(params) + call param_register(params, 'init_args_pot1', '', this%init_args_pot1, help_string="Argument string for initializing pot1 (for non-simple potentials") + call param_register(params, 'init_args_pot2', '', this%init_args_pot2, help_string="Argument string for initializing pot2 (for non-simple potentials") + call param_register(params, 'Sum', 'false', this%is_sum, help_string="Potential that's a sum of 2 other potentials") + call param_register(params, 'ForceMixing', 'false', this%is_forcemixing, help_string="Potential that's force-mixing of 2 other potentials") + call param_register(params, 'EVB', 'false', this%is_evb, help_string="Potential using empirical-valence bond to mix 2 other potentials") +#ifdef HAVE_LOCAL_E_MIX + call param_register(params, 'Local_E_Mix', 'false', this%is_local_e_mix, help_string="Potential that's local energy mixing of 2 other potentials") +#endif /* HAVE_LOCAL_E_MIX */ +#ifdef HAVE_ONIOM + call param_register(params, 'ONIOM', 'false', this%is_oniom, help_string="Potential from ONIOM mixing of two other potential energies") +#endif /* HAVE_ONIOM */ + call param_register(params, 'Cluster', 'false', this%is_cluster, help_string="Potential evaluated using clusters") + call param_register(params, 'do_rescale_r', 'F', this%do_rescale_r, help_string="If true, rescale distances by factor r_scale.") + call param_register(params, 'r_scale', '1.0', this%r_scale, has_value_target=has_r_scale, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'do_rescale_E', 'F', this%do_rescale_E, help_string="If true, rescale energy by factor E_scale.") + call param_register(params, 'E_scale', '1.0', this%E_scale, has_value_target=has_E_scale, help_string="Recaling factor for energy. Default 1.0.") + call param_register(params, "minimise_bulk", "F", minimise_bulk, help_string="If true, minimise bulk_scale structure before measuring eqm. volume and bulk modulus for rescaling") + call param_register(params, "target_vol", "0.0", target_vol, has_value_target=has_target_vol, & + help_string="Target volume per cell used if do_rescale_r=T Unit is A^3.") + call param_register(params, "target_B", "0.0", target_B, has_value_target=has_target_B, & + help_string="Target bulk modulus used if do_rescale_E=T. Unit is GPa.") + + if(.not. param_read_line(params, my_args_str, ignore_unknown=.true.,task='Potential_Initialise args_str')) then + RAISE_ERROR("Potential_initialise failed to parse args_str='"//trim(my_args_str)//"'", error) + endif + call finalise(params) + + if (present(pot1) .and. len_trim(this%init_args_pot1) > 0) then + RAISE_ERROR("Potential_initialise got both pot and args_str with init_args_pot1 passed in, conflict", error) + endif + if (present(pot2) .and. len_trim(this%init_args_pot2) > 0) then + RAISE_ERROR("Potential_initialise got both pot2 and args_str with init_args_pot2 passed in, conflict", error) + endif + + if (len_trim(this%init_args_pot1) > 0) then + allocate(this%l_mpot1) + call initialise(this%l_mpot1, args_str=this%init_args_pot1, param_str=param_str, bulk_scale=bulk_scale, mpi_obj=mpi_obj, error=error) + PASS_ERROR_WITH_INFO("Initializing pot1", error) + u_pot1 => this%l_mpot1 + else + u_pot1 => pot1 + endif + if (len_trim(this%init_args_pot2) > 0) then + allocate(this%l_mpot2) + call initialise(this%l_mpot2, args_str=this%init_args_pot2, param_str=param_str, bulk_scale=bulk_scale, mpi_obj=mpi_obj, error=error) + PASS_ERROR_WITH_INFO("Initializing pot2", error) + u_pot2 => this%l_mpot2 + else + if (present(pot2)) then + u_pot2 => pot2 + else + nullify(u_pot2) + endif + endif + + if (present(mpi_obj)) this%mpi = mpi_obj + + this%is_simple = .not. any( (/ this%is_sum, this%is_forcemixing, this%is_evb & +#ifdef HAVE_LOCAL_E_MIX + , this%is_local_e_mix & +#endif +#ifdef HAVE_ONIOM + , this%is_oniom & +#endif + , this%is_cluster & + /) ) + + if (count( (/this%is_simple, this%is_sum, this%is_forcemixing, this%is_evb & +#ifdef HAVE_LOCAL_E_MIX + , this%is_local_e_mix & +#endif /* HAVE_LOCAL_E_MIX */ +#ifdef HAVE_ONIOM + , this%is_oniom & +#endif /* HAVE_ONIOM */ + , this%is_cluster & + /) ) /= 1) then + RAISE_ERROR("Potential_initialise found too few or two many Potential types args_str='"//trim(my_args_str)//"'", error) + end if + + if (this%is_simple) then + if (present(bulk_scale) .and. .not. has_target_vol .and. .not. has_target_B) call print("Potential_initialise Simple ignoring bulk_scale passed in", PRINT_ALWAYS) + + call initialise(this%simple, my_args_str, param_str, mpi_obj, error=error) + PASS_ERROR_WITH_INFO("Initializing pot", error) + else if (this%is_sum) then + if (present(bulk_scale)) call print("Potential_initialise Sum ignoring bulk_scale passed in", PRINT_ALWAYS) + + if (.not. associated(u_pot2)) then + RAISE_ERROR('Potential_initialise: two potentials needs for sum potential', error) + endif + + allocate(this%sum) + call initialise(this%sum, my_args_str, u_pot1, u_pot2, mpi_obj, error=error) + PASS_ERROR_WITH_INFO("Initializing sum", error) + + else if (this%is_forcemixing) then + + allocate(this%forcemixing) + if(associated(u_pot2)) then + call initialise(this%forcemixing, my_args_str, u_pot1, u_pot2, bulk_scale, mpi_obj, error=error) + else + ! if only one pot is given, assign it to QM. this is useful for time-embedding LOTF + call initialise(this%forcemixing, my_args_str, qmpot=u_pot1, reference_bulk=bulk_scale, mpi=mpi_obj, error=error) + endif + PASS_ERROR_WITH_INFO("Initializing forcemixing", error) + + else if (this%is_evb) then + if (present(bulk_scale)) call print("Potential_initialise EVB ignoring bulk_scale passed in", PRINT_ALWAYS) + + !1 is enough, everything is the same apart from the passed topology + if (associated(u_pot2)) then + call print('WARNING! Potential_initialise EVB ignoring u_pot2 (it will use u_pot1 twice)', PRINT_ALWAYS) + endif + + allocate(this%evb) + call initialise(this%evb, my_args_str, u_pot1, mpi_obj, error=error) + PASS_ERROR_WITH_INFO("Initializing evb", error) + +#ifdef HAVE_LOCAL_E_MIX + else if (this%is_local_e_mix) then + if (.not. associated(u_pot2)) then + RAISE_ERROR('Potential_initialise: two potentials needs for local_e_mix potential', error) + endif + + allocate(this%local_e_mix) + call initialise(this%local_e_mix, my_args_str, u_pot1, u_pot2, bulk_scale, mpi_obj, error=error) + PASS_ERROR_WITH_INFO("Initializing local_e_mix", error) +#endif /* HAVE_LOCAL_E_MIX */ +#ifdef HAVE_ONIOM + else if (this%is_oniom) then + if (.not. associated(u_pot2)) then + RAISE_ERROR('Potential_initialise: two potentials needs for oniom potential', error) + endif + + allocate(this%oniom) + call initialise(this%oniom, my_args_str, u_pot1, u_pot2, bulk_scale, mpi_obj, error=error) + PASS_ERROR_WITH_INFO("Initializing oniom", error) +#endif /* HAVE_ONIOM */ + + else if (this%is_cluster) then + allocate(this%cluster) + call initialise(this%cluster, my_args_str, u_pot1, mpi_obj, error=error) + PASS_ERROR_WITH_INFO("Initializing Cluster", error) + end if + + if (this%is_simple .and. (this%do_rescale_r .or. this%do_rescale_E)) then + if (this%do_rescale_r) then + if (.not. has_r_scale .and. .not. has_target_vol) then + RAISE_ERROR("potential_initialise: do_rescale_r=T but neither r_scale nor target_vol present", error) + end if + end if + if (this%do_rescale_E) then + if (.not. has_E_scale .and. .not. has_target_B) then + RAISE_ERROR("potential_initialise: do_rescale_E=T but neither E_scale nor target_B present", error) + end if + end if + + ! Automatic calculation of rescaling factors r_scale and E_scale to match target_vol and/or target_B + if (has_target_vol .or. has_target_B) then + if (.not. present(bulk_scale)) then + RAISE_ERROR("potential_initialise: target_vol or target_B present but no bulk_scale provided", error) + end if + + bulk = bulk_scale + call set_cutoff(bulk, cutoff(this)+1.0_dp) + call calc_connect(bulk) + if (minimise_bulk) then + call print("MINIMISING bulk in potential", PRINT_VERBOSE) + call verbosity_push_decrement() + it = minim(this, at=bulk, method='cg', convergence_tol=1e-6_dp, max_steps=100, linminroutine='NR_LINMIN', & + do_print = .false., do_lat = .true., args_str=args_str) + call verbosity_pop() + endif + + r_scale = 1.0_dp + if (this%do_rescale_r) then + vol = cell_volume(bulk) + r_scale = (vol/target_vol)**(1.0_dp/3.0_dp) + call print("do_rescale_r: original cell volume (from minim) is "//vol//" A^3") + call print("do_rescale_r: setting potential r_scale to "//r_scale//" to match target cell volume of "//target_vol//" A^3") + end if + + if (this%do_rescale_E) then + call bulk_modulus(this, bulk, B, vol, minimise_bulk, args_str=args_str) + this%E_scale = target_B/(B*r_scale**3) + call print("do_rescale_E: original cell volume (from quadratic fit) is "//vol//" A^3") + call print("do_rescale_E: original bulk modulus (from quadratic fit) is "//B//" GPa") + call print("do_rescale_E: setting potential E_scale to "//this%E_scale//" to match target bulk modulus of "//target_B//" GPa") + end if + + if (this%do_rescale_r) this%r_scale = r_scale + end if + end if + + end subroutine potential_initialise + + recursive subroutine potential_finalise(this, error) + type(Potential), intent(inout) :: this + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if (this%is_simple) then + call finalise(this%simple) + else if (this%is_sum) then + call finalise(this%sum) + deallocate(this%sum) + else if (this%is_forcemixing) then + call finalise(this%forcemixing) + deallocate(this%forcemixing) + else if (this%is_evb) then + call finalise(this%evb) + deallocate(this%evb) +#ifdef HAVE_LOCAL_E_MIX + else if (this%is_local_e_mix) then + call finalise(this%local_e_mix) + deallocate(this%local_e_mix) +#endif /* HAVE_LOCAL_E_MIX */ +#ifdef HAVE_ONIOM + else if (this%is_oniom) then + call finalise(this%oniom) + deallocate(this%oniom) +#endif /* HAVE_ONIOM */ + else if (this%is_cluster) then + call finalise(this%cluster) + deallocate(this%cluster) + end if + + if (associated(this%l_mpot1)) call finalise(this%l_mpot1) + if (associated(this%l_mpot2)) call finalise(this%l_mpot2) + nullify(this%l_mpot1) + nullify(this%l_mpot2) + + this%is_simple = .false. + this%is_sum = .false. + this%is_forcemixing = .false. + this%is_evb = .false. +#ifdef HAVE_LOCAL_E_MIX + this%is_local_e_mix = .false. +#endif +#ifdef HAVE_ONIOM + this%is_oniom = .false. +#endif + this%is_cluster = .false. + + end subroutine potential_finalise + + recursive subroutine potential_calc(this, at, energy, force, virial, local_energy, local_virial, args_str, error) + type(Potential), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: energy + real(dp), intent(out), optional :: force(:,:) + real(dp), intent(out), optional :: virial(3,3) + real(dp), intent(out), optional :: local_virial(:,:) + real(dp), intent(out), optional :: local_energy(:) + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:), at_local_virial_ptr(:,:) + type(Dictionary) :: params + character(len=STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, extra_args_str + character(len=STRING_LENGTH) :: use_calc_energy, use_calc_force, use_calc_virial, use_calc_local_energy, use_calc_local_virial + real(dp) :: r_scale, E_scale + logical :: has_r_scale, has_E_scale, do_calc_connect + integer i + + INIT_ERROR(error) + + calc_energy = "" + calc_virial = "" + calc_force = "" + calc_local_energy = "" + calc_local_virial = "" + + call initialise(params) + call param_register(params, "energy", "", calc_energy, help_string="If present, calculate energy and put it in field with this string as name") + call param_register(params, "virial", "", calc_virial, help_string="If present, calculate virial and put it in field with this string as name") + call param_register(params, "force", "", calc_force, help_string="If present, calculate force and put it in field with this string as name") + call param_register(params, "local_energy", "", calc_local_energy, help_string="If present, calculate local energy and put it in field with this string as name") + call param_register(params, "local_virial", "", calc_local_virial, help_string="If present, calculate local virial and put it in field with this string as name") + call param_register(params, "r_scale", "0.0", r_scale, has_value_target=has_r_scale, help_string="Distance rescale factor. Overrides r_scale init arg") + call param_register(params, "E_scale", "0.0", E_scale, has_value_target=has_E_scale, help_string="Energy rescale factor. Overrides E_scale init arg") + call param_register(params, "do_calc_connect", "T", do_calc_connect, help_string="Switch on/off automatic calc_connect() calls.") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Calc args_str')) then + RAISE_ERROR('Potential_Calc failed to parse args_str="'//trim(args_str)//'"', error) + endif + call finalise(params) + + if (cutoff(this) > 0.0_dp .and. do_calc_connect) then + ! For Potentials which need connectivity information, ensure Atoms cutoff is >= Potential cutoff + ! Also call calc_connect() to update connectivity information. This incurrs minimial overhead + ! if at%cutoff_skin is non-zero, as the full rebuild will only be done when atoms have moved sufficiently + if (at%cutoff < cutoff(this)) then + if (printed_cutoff_warning) call verbosity_push_decrement() + ! print warning unless cutoff was 0.0 or -1, these are defaults for "no cutoff", so probably no warning needed + if (at%cutoff /= 0.0_dp .and. at%cutoff /= -1.0_dp) then + call print_message('WARNING', 'Potential_calc: cutoff of Atoms object ('//at%cutoff//') < Potential cutoff ('//cutoff(this)//') - increasing it now') + end if + if (printed_cutoff_warning) call verbosity_pop() + printed_cutoff_warning = .true. + call set_cutoff(at, cutoff(this)) + end if + call calc_connect(at) + end if + + extra_args_str = "" + + ! create property/param names and possibly storage + use_calc_energy = trim(calc_energy) + if (present(energy) .and. len_trim(calc_energy) == 0) then ! have optional and no args_str - make new name for param + use_calc_energy = "energy" + do while (lookup_entry_i(at%params, trim(use_calc_energy)) > 0) + use_calc_energy = "T"//trim(use_calc_energy) + end do + extra_args_str = trim(extra_args_str) // " energy="//trim(use_calc_energy) + endif + + use_calc_force = trim(calc_force) + + if (present(force)) then + if (len_trim(calc_force) == 0) then ! have force optional but not args_str - add property from pointer in new property name + use_calc_force = "force" + do while (has_property(at, trim(use_calc_force))) + use_calc_force = "T"//trim(use_calc_force) + end do + extra_args_str = trim(extra_args_str) // " force="//trim(use_calc_force) + call add_property_from_pointer(at, trim(use_calc_force), force) + else ! has force optional _and_ args_str - add property with its own storage + call add_property(at, trim(calc_force), 0.0_dp, n_cols=3, ptr2=at_force_ptr) + endif + else if (len_trim(calc_force) > 0) then ! no optional, have args_str - add property with its own storage + call add_property(at, trim(calc_force), 0.0_dp, n_cols=3, ptr2=at_force_ptr) + endif + + use_calc_virial = trim(calc_virial) ! have optional and no args_str - make new name for param + if (present(virial) .and. len_trim(calc_virial) == 0) then + use_calc_virial = "virial" + do while (lookup_entry_i(at%params, trim(use_calc_virial)) > 0) + use_calc_virial = "T"//trim(use_calc_virial) + end do + extra_args_str = trim(extra_args_str) // " virial="//trim(use_calc_virial) + endif + + use_calc_local_energy = trim(calc_local_energy) + if (present(local_energy)) then + if (len_trim(calc_local_energy) == 0) then ! have local_energy optional but not args_str - add property from pointer in new property name + use_calc_local_energy = "local_energy" + do while (has_property(at, trim(use_calc_local_energy))) + use_calc_local_energy = "T"//trim(use_calc_local_energy) + end do + extra_args_str = trim(extra_args_str) // " local_energy="//trim(use_calc_local_energy) + call add_property_from_pointer(at, trim(use_calc_local_energy), local_energy) + else ! has local_energy optional _and_ args_str - add property with its own storage + call add_property(at, trim(calc_local_energy), 0.0_dp, n_cols=1, ptr=at_local_energy_ptr) + endif + else if (len_trim(calc_local_energy) > 0) then ! no optional, have args_str - add property with its own storage + call add_property(at, trim(calc_local_energy), 0.0_dp, n_cols=1, ptr=at_local_energy_ptr) + endif + + use_calc_local_virial = trim(calc_local_virial) + if (present(local_virial)) then + if (len_trim(calc_local_virial) == 0) then ! have local_virial optional but not args_str - add property from pointer in new property name + use_calc_local_virial = "local_virial" + do while (has_property(at, trim(use_calc_local_virial))) + use_calc_local_virial = "T"//trim(use_calc_local_virial) + end do + extra_args_str = trim(extra_args_str) // " local_virial="//trim(use_calc_local_virial) + call add_property_from_pointer(at, trim(use_calc_local_virial), local_virial) + else ! has local_virial optional _and_ args_str - add property with its own storage + call add_property(at, trim(calc_local_virial), 0.0_dp, n_cols=9, ptr2=at_local_virial_ptr) + endif + else if (len_trim(calc_local_virial) > 0) then ! no optional, have args_str - add property with its own storage + call add_property(at, trim(calc_local_virial), 0.0_dp, n_cols=9, ptr2=at_local_virial_ptr) + endif + + ! Set r_scale, E_scale in extra_args_str if not present in args_str + if (this%do_rescale_r .and. .not. has_r_scale) extra_args_str = trim(extra_args_str)//" r_scale="//this%r_scale + if (this%do_rescale_E .and. .not. has_E_scale) extra_args_str = trim(extra_args_str)//" E_scale="//this%E_scale + + ! do actual calculation using args_str + if (this%is_simple) then + call Calc(this%simple, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) + PASS_ERROR(error) + else if (this%is_sum) then + call Calc(this%sum, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) + PASS_ERROR(error) + else if (this%is_forcemixing) then + call Calc(this%forcemixing, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) + PASS_ERROR(error) + else if (this%is_evb) then + call Calc(this%evb, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) + PASS_ERROR(error) +#ifdef HAVE_LOCAL_E_MIX + else if (this%is_local_e_mix) then + call Calc(this%local_e_mix, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) + PASS_ERROR(error) +#endif /* HAVE_local_e_mix */ +#ifdef HAVE_ONIOM + else if (this%is_oniom) then + call Calc(this%oniom, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) + PASS_ERROR(error) +#endif /* HAVE_ONIOM */ + else if (this%is_cluster) then + call Calc(this%cluster, at, trim(this%calc_args)//" "//trim(args_str)//" "//trim(extra_args_str), error=error) + PASS_ERROR(error) + else + RAISE_ERROR('Potential_Calc: no potential type is set',error) + endif + + ! get values from property/param if necessary, and remove temporary if only optional was passed in + if (present(energy)) then + call get_param_value(at, trim(use_calc_energy), energy) + if (len_trim(calc_energy) == 0) call remove_value(at%params, trim(use_calc_energy)) + endif + if (present(force)) then + if (len_trim(calc_force) == 0) then ! property should be a pointer to force optional + call remove_property(at, trim(use_calc_force)) + else + force = at_force_ptr + endif + endif + if (present(virial)) then + call get_param_value(at, trim(use_calc_virial), virial) + if (len_trim(calc_virial) == 0) call remove_value(at%params, trim(use_calc_virial)) + endif + if (present(local_energy)) then + if (len_trim(calc_local_energy) == 0) then ! property should be pointer to local_energy optional + call remove_property(at, trim(use_calc_local_energy)) + else + local_energy = at_local_energy_ptr + endif + endif + if (present(local_virial)) then + if (len_trim(calc_local_virial) == 0) then ! property should be pointer to local_virial optional + call remove_property(at, trim(use_calc_local_virial)) + else + local_virial = at_local_virial_ptr + endif + endif + + end subroutine potential_calc + + subroutine Potential_setup_parallel(this, at, args_str, error) + type(Potential), intent(inout) :: this + type(Atoms), intent(inout) :: at !% The atoms structure to compute energy and forces + character(len=*), intent(in) :: args_str + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if(this%is_simple) then + call setup_parallel(this%simple, at, args_str) + endif + end subroutine Potential_setup_parallel + + recursive subroutine potential_print(this, file, dict, error) + type(Potential), intent(inout) :: this + type(Inoutput), intent(inout), optional :: file + type(Dictionary), intent(inout), optional :: dict + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if (this%is_simple) then + call Print('Potential containing potential') + call Print(this%simple, file=file, dict=dict) + else if (this%is_sum) then + call Print(this%sum, file=file,dict=dict) + else if (this%is_forcemixing) then + call Print(this%forcemixing, file=file) + else if (this%is_evb) then + call Print(this%evb, file=file) +#ifdef HAVE_LOCAL_E_MIX + else if (this%is_local_e_mix) then + call Print(this%local_e_mix, file=file) +#endif /* HAVE_LOCAL_E_MIX */ +#ifdef HAVE_ONIOM + else if (this%is_oniom) then + call Print(this%oniom, file=file) +#endif /* HAVE_ONIOM */ + else if (this%is_cluster) then + call Print(this%cluster, file=file) + else + RAISE_ERROR('Potential_Print: no potential type is set', error) + end if + end subroutine potential_print + + + recursive function potential_cutoff(this, error) + type(Potential), intent(in) :: this + integer, intent(out), optional :: error + real(dp) :: potential_cutoff + + INIT_ERROR(error) + + if (this%is_simple) then + potential_cutoff = cutoff(this%simple) + else if (this%is_sum) then + potential_cutoff = cutoff(this%sum) + else if (this%is_forcemixing) then + potential_cutoff = cutoff(this%forcemixing) + else if (this%is_evb) then + potential_cutoff = cutoff(this%evb) +#ifdef HAVE_LOCAL_E_MIX + else if (this%is_local_e_mix) then + potential_cutoff = cutoff(this%local_e_mix) +#endif /* HAVE_local_e_mix */ +#ifdef HAVE_ONIOM + else if (this%is_oniom) then + potential_cutoff = cutoff(this%oniom) +#endif /* HAVE_ONIOM */ + else if (this%is_cluster) then + potential_cutoff = cutoff(this%cluster) + else + RAISE_ERROR('Potential_Cutoff: no potential type is set', error) + end if + end function potential_cutoff + + + subroutine potential_set_calc_args_str(this, args_str, error) + type(Potential), intent(inout) :: this + character(len=*), intent(in) :: args_str + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if(len_trim(args_str) > len(this%calc_args)) then + RAISE_ERROR('potential_set_calc_args_str: args_str longer than the avaiable calc_args field', error) + endif + + this%calc_args = trim(args_str) + + endsubroutine potential_set_calc_args_str + + function potential_get_calc_args_str(this, error) + type(Potential), intent(inout) :: this + integer, intent(out), optional :: error + character(len=STRING_LENGTH) :: potential_get_calc_args_str + + INIT_ERROR(error) + + if(len_trim(this%calc_args) > len(potential_get_calc_args_str)) then + RAISE_ERROR('potential_get_calc_args_str: calc_args field too long', error) + endif + + potential_get_calc_args_str = trim(this%calc_args) + + endfunction potential_get_calc_args_str + + !************************************************************************* + !* + !* Minimisation routines + !* + !************************************************************************* + + + function potential_minim(this, at, method, convergence_tol, max_steps, linminroutine, do_print, print_inoutput, print_cinoutput, & + do_pos, do_lat, args_str, eps_guess, fire_minim_dt0, fire_minim_dt_max, external_pressure, use_precond, & + hook_print_interval, error) + type(Potential), intent(inout), target :: this !% potential to evaluate energy/forces with + type(Atoms), intent(inout), target :: at !% starting configuration + character(*), intent(in) :: method !% passed to minim() + real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ + !% 'convergence_tol'. + integer, intent(in) :: max_steps !% Maximum number of steps + character(*), intent(in),optional :: linminroutine !% Name of the line minisation routine to use, passed to base minim() + logical, optional :: do_print !% if true, print configurations using minim's hook() + type(inoutput), intent(inout), optional, target :: print_inoutput !% inoutput object to print configs to, needed if do_print is true + type(cinoutput), intent(inout), optional, target :: print_cinoutput !% cinoutput object to print configs to, needed if do_print is true + logical, optional :: do_pos, do_lat !% do relaxation w.r.t. positions and/or lattice (if neither is included, do both) + character(len=*), intent(in), optional :: args_str !% arguments to pass to calc() + real(dp), intent(in), optional :: eps_guess !% eps_guess argument to pass to minim + real(dp), intent(in), optional :: fire_minim_dt0 !% if using fire minim, initial value for time step + real(dp), intent(in), optional :: fire_minim_dt_max !% if using fire minim, max value for time step + real(dp), dimension(3,3), optional :: external_pressure + logical, intent(in), optional :: use_precond + integer, intent(in), optional :: hook_print_interval !% how often to print xyz from hook function + integer, intent(out), optional :: error !% set to 1 if an error occurred during minimisation + integer::potential_minim + + character(len=100) :: use_method + + logical :: my_use_precond + integer n_iter, n_iter_tot + real(dp), allocatable :: x(:) + real(dp) :: deform_grad(3,3) + logical my_do_print + logical done + real(dp) :: my_eps_guess + real(dp) :: my_fire_minim_dt0, my_fire_minim_dt_max + + real(dp) :: initial_E, final_E, mass + type(potential_minimise) am + integer :: am_data_size + character, allocatable :: am_data(:) + character, dimension(1) :: am_mold + integer :: status + + INIT_ERROR(error) + + my_use_precond = optional_default(.false., use_precond) + + am_data_size = size(transfer(am, am_mold)) + allocate(am_data(am_data_size)) + + use_method = trim(method) + + my_fire_minim_dt0 = optional_default(1.0_dp, fire_minim_dt0) + my_fire_minim_dt_max = optional_default(20.0_dp, fire_minim_dt_max) + + my_eps_guess = optional_default(1.0e-2_dp/at%N, eps_guess) + if (my_eps_guess .feq. 0.0_dp) my_eps_guess = 1.0e-2_dp/at%N + + if (cutoff(this) > 0.0_dp) then + ! For Potentials which need connectivity information, ensure Atoms cutoff is >= Potential cutoff + ! Also call calc_connect() to update connectivity information. This incurrs minimial overhead + ! if at%cutoff_skin is non-zero, as the full rebuild will only be done when atoms have moved sufficiently + if (at%cutoff < cutoff(this)) then + if (printed_cutoff_warning) call verbosity_push_decrement() + ! print warning unless cutoff was 0.0 or -1, these are defaults for "no cutoff", so probably no warning needed + if (at%cutoff /= 0.0_dp .and. at%cutoff /= -1.0_dp) then + call print_message('WARNING', 'Potential_calc: cutoff of Atoms object ('//at%cutoff//') < Potential cutoff ('//cutoff(this)//') - increasing it now') + end if + if (printed_cutoff_warning) call verbosity_pop() + printed_cutoff_warning = .true. + call set_cutoff(at, cutoff(this)) + end if + call calc_connect(at) + end if + + am%minim_at => at + am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*am%minim_at%N + + if (present(args_str)) then + am%minim_args_str = args_str + else + am%minim_args_str = "" + endif + am%minim_pot => this + + if (.not.present(do_pos) .and. .not. present(do_lat)) then + am%minim_do_pos = .true. + am%minim_do_lat = .true. + else + am%minim_do_pos = optional_default(.false., do_pos) + am%minim_do_lat = optional_default(.false., do_lat) + endif + + am%external_pressure = 0.0_dp + if (present(external_pressure)) then + am%external_pressure = external_pressure + if( (am%external_pressure(1,1) .fne. am%external_pressure(2,2)) .or. & + & (am%external_pressure(1,1) .fne. am%external_pressure(3,3)) .or. & + & (am%external_pressure(1,2) .fne. 0.0_dp) .or. & + & (am%external_pressure(1,3) .fne. 0.0_dp) .or. & + & (am%external_pressure(2,1) .fne. 0.0_dp) .or. & + & (am%external_pressure(2,3) .fne. 0.0_dp) .or. & + & (am%external_pressure(3,1) .fne. 0.0_dp) .or. & + & (am%external_pressure(3,2) .fne. 0.0_dp) ) then + if(trim(use_method) /= 'fire') then + call print_message('WARNING', 'Anisotrpic pressure is being used. Switching to fire_minim.') + use_method = 'fire' + endif + endif + endif + + my_do_print = optional_default(.false., do_print) + + if (my_do_print .and. .not. present(print_inoutput) .and. .not. present(print_cinoutput)) & + call system_abort("potential_minim: do_print is true, but no print_inoutput or print_cinoutput present") + + if (my_do_print) then + if (present(print_cinoutput)) then + am%minim_cinoutput_movie => print_cinoutput + if (this%is_forcemixing) & + this%forcemixing%minim_cinoutput_movie => print_cinoutput +#ifdef HAVE_LOCAL_E_MIX + if (this%is_local_e_mix) & + this%local_e_mix%minim_cinoutput_movie => print_cinoutput +#endif /* HAVE_LOCAL_E_MIX */ +#ifdef HAVE_ONIOM + if (this%is_oniom) & + this%oniom%minim_cinoutput_movie => print_cinoutput +#endif /* HAVE_ONIOM */ + end if + else + nullify(am%minim_cinoutput_movie) + endif + + am%minim_n_eval_e = 0 + am%minim_n_eval_f = 0 + + allocate(x(9+am%minim_at%N*3)) + allocate(am%last_connect_x(size(x))) + am%last_connect_x=1.0e38_dp + deform_grad = 0.0_dp; call add_identity(deform_grad) + call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) + + am_data = transfer(am, am_data) + if (trim(use_method) == 'cg_n') then + n_iter = n_minim(x, both_func, my_use_precond, apply_precond_func, initial_E, final_E, my_eps_guess, max_steps, convergence_tol, print_hook, & + hook_print_interval=hook_print_interval, data=am_data, error=error) + PASS_ERROR(error) + else if (trim(use_method) == 'fire') then + if (has_property(at, 'mass')) then + mass = at%mass(1) + else + mass = ElementMass(at%Z(1)) + end if + n_iter = fire_minim(x, mass, dummy_energy_func, gradient_func, my_fire_minim_dt0, convergence_tol, max_steps, & + print_hook, hook_print_interval=hook_print_interval, data=am_data, dt_max=my_fire_minim_dt_max, status=status) + else + n_iter = minim(x, energy_func, gradient_func, use_method, convergence_tol, max_steps, linminroutine, & + print_hook, hook_print_interval=hook_print_interval, eps_guess=my_eps_guess, data=am_data, status=status) + endif + call print("minim relax w.r.t. both n_iter " // n_iter, PRINT_VERBOSE) + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + if(am%minim_at%cutoff > 0.0_dp) then + call calc_connect(am%minim_at) + end if + n_iter_tot = n_iter + done = .true. + deallocate(am%last_connect_x) + deallocate(x) + call print("MINIM_N_EVAL E " // am%minim_n_eval_e // " F " // am%minim_n_eval_f // & + " EF " // am%minim_n_eval_ef, PRINT_VERBOSE) + + potential_minim = n_iter_tot + + deallocate(am_data) + + end function potential_minim + + subroutine potential_test_local_virial(this, at, args_str) + type(Atoms), intent(inout), target :: at + type(Potential), target, intent(inout) :: this + character(len=*), intent(in), optional :: args_str + + real(dp) :: dx, r_ik + real(dp), dimension(3) :: diff_ik + real(dp), dimension(3,3) :: virial + real(dp), dimension(:), allocatable :: local_energy_p, local_energy_m + real(dp), dimension(:,:), allocatable :: tmp_local_virial, pos0 + real(dp), dimension(:,:,:), allocatable :: local_virial, local_virial_fd + + integer :: d, i, k, n, alpha + + call print_message('WARNING', "TLV: potential_test_local_virial: your cell has to be big enough so no multiple images are used for any atom.") + + if(at%cutoff < cutoff(this)) call set_cutoff(at,cutoff(this)) + + if(at%cutoff > 0.0_dp) then + call calc_connect(at) + end if + + allocate(tmp_local_virial(9,at%N), local_virial(3,3,at%N), local_virial_fd(3,3,at%N), & + local_energy_p(at%N), local_energy_m(at%N), pos0(3,at%N)) + + call calc(this,at,local_virial = tmp_local_virial, virial = virial) + local_virial = reshape(tmp_local_virial,(/3,3,at%N/)) + + call print("TLV: RMS difference between virial and local virial summed over atoms = "//sqrt( sum( (virial - sum(local_virial,dim=3))**2 ) )) + + pos0 = at%pos + + dx = 1.0_dp + + print"(a,a16,a20)", "TLV", "dx", "RMS" + do d = 1, 10 + dx = dx * 0.1_dp + local_virial_fd = 0.0_dp + + do i = 1, at%N + + do alpha = 1, 3 + at%pos(alpha,i) = pos0(alpha,i) + dx + if(at%cutoff > 0.0_dp) then + call calc_connect(at) + end if + call calc(this,at,local_energy=local_energy_p,args_str=args_str) + + at%pos(alpha,i) = pos0(alpha,i) - dx + if(at%cutoff > 0.0_dp) then + call calc_connect(at) + end if + call calc(this,at,local_energy=local_energy_m,args_str=args_str) + + at%pos(alpha,i) = pos0(alpha,i) + if(at%cutoff > 0.0_dp) then + call calc_connect(at) + end if + + do n = 1, n_neighbours(at,i) + k = neighbour(at,i,n,distance = r_ik, diff = diff_ik) + + if( r_ik > cutoff(this) ) cycle + + local_virial_fd(:,alpha,i) = local_virial_fd(:,alpha,i) + diff_ik * ( local_energy_p(k) - local_energy_m(k) ) / 2.0_dp / dx + enddo + enddo + enddo + + print"(a,f16.10,e20.10)", "TLV", dx, sqrt(sum((local_virial_fd - local_virial)**2)) + enddo + + endsubroutine potential_test_local_virial + + subroutine undo_travel(at) + type(Atoms), intent(inout) :: at + +! if (any(at%travel /= 0)) then +! at%pos = at%pos + (at%lattice .mult. at%travel) +! at%travel = 0 +! endif +end subroutine undo_travel + + ! test the gradient given a potential, string to pass to calc, and atoms structure + function pot_test_gradient(pot, at, do_pos, do_lat, args_str, dir_field) + type(Atoms), intent(inout), target :: at + type(Potential), target, intent(inout) :: pot + logical, intent(in), optional :: do_pos, do_lat + character(len=*), intent(in), optional :: args_str + character(len=*), intent(in), optional :: dir_field + logical pot_test_gradient + + real(dp) :: dg(3,3) + real(dp), allocatable :: x(:), dir_x(:) + real(dp), pointer :: dir_p(:,:) + integer :: am_data_size + type(potential_minimise) :: am + character, allocatable :: am_data(:) + character, dimension(1) :: am_mold + + am_data_size = size(transfer(am, am_mold)) + allocate(am_data(am_data_size)) + + pot_test_gradient = .true. + + if (present(args_str)) then + am%minim_args_str = args_str + else + am%minim_args_str = "" + endif + am%minim_pot => pot + + ! neither do_pos not do_lat is specified, so do both by default + if (.not. present(do_pos) .and. .not. present(do_lat)) then + am%minim_do_pos= .true. + am%minim_do_lat= .true. + else ! something is specified, so do exactly that + am%minim_do_pos = optional_default(.false., do_pos) + am%minim_do_lat = optional_default(.false., do_lat) + endif + + am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*at%N + + if (present(dir_field)) then + if (.not. assign_pointer(at, trim(dir_field), dir_p)) & + call system_abort("pot_test_gradient got dir_field '"//trim(dir_field)//"' but can't assign pointer to it") + call print("pot_test_gradient using '"//trim(dir_field)//"' field for gradient test direction") + else + nullify(dir_p) + endif + + am%minim_at => at + allocate(x(at%N*3+9)) + allocate(am%last_connect_x(at%N*3+9)) + am%last_connect_x=1.0e38_dp + dg = 0.0_dp; call add_identity(dg) + call pack_pos_dg(at%pos, dg, x, am%pos_lat_preconditioner_factor) + if (associated(dir_p)) then + allocate(dir_x(at%N*3+9)) + dg = 0.0_dp + call pack_pos_dg(dir_p, dg, dir_x, am%pos_lat_preconditioner_factor) + endif + am_data = transfer(am, am_data) + if (associated(dir_p)) then + pot_test_gradient = test_gradient(x, energy_func, gradient_func, dir=dir_x, data=am_data) + else + pot_test_gradient = test_gradient(x, energy_func, gradient_func, data=am_data) + endif + deallocate(x) + if (allocated(dir_x)) deallocate(dir_x) + deallocate(am%last_connect_x) + + deallocate(am_data) + + end function pot_test_gradient + + ! test the gradient given a potential, string to pass to calc, and atoms structure + subroutine pot_n_test_gradient(pot, at, do_pos, do_lat, args_str, dir_field) + type(Potential), target, intent(inout) :: pot + type(Atoms), intent(inout), target :: at + logical, intent(in), optional :: do_pos, do_lat + character(len=*), intent(in), optional :: args_str + character(len=*), intent(in), optional :: dir_field + + real(dp), allocatable :: x(:), dir_x(:) + real(dp), pointer :: dir_p(:,:) + real(dp) :: dg(3,3) + integer :: am_data_size + type(potential_minimise) :: am + character, allocatable :: am_data(:) + character, dimension(1) :: am_mold + + am_data_size = size(transfer(am, am_mold)) + allocate(am_data(am_data_size)) + + if (present(args_str)) then + am%minim_args_str = args_str + else + am%minim_args_str = "" + endif + am%minim_pot => pot + + ! neither do_pos not do_lat is specified, so do both by default + if (.not. present(do_pos) .and. .not. present(do_lat)) then + am%minim_do_pos= .true. + am%minim_do_lat= .true. + else ! something is specified, so do exactly that + am%minim_do_pos = optional_default(.false., do_pos) + am%minim_do_lat = optional_default(.false., do_lat) + endif + + am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*at%N + + if (present(dir_field)) then + if (.not. assign_pointer(at, trim(dir_field), dir_p)) & + call system_abort("pot_test_gradient got dir_field '"//trim(dir_field)//"' but can't assign pointer to it") + call print("pot_test_gradient using '"//trim(dir_field)//"' field for gradient test direction") + else + nullify(dir_p) + endif + + am%minim_at => at + allocate(x(at%N*3+9)) + allocate(am%last_connect_x(at%N*3+9)) + am%last_connect_x=1.0e38_dp + dg = 0.0_dp; call add_identity(dg) + call pack_pos_dg(at%pos, dg, x, am%pos_lat_preconditioner_factor) + if (associated(dir_p)) then + allocate(dir_x(at%N*3+9)) + dg = 0.0_dp + call pack_pos_dg(dir_p, dg, dir_x, am%pos_lat_preconditioner_factor) + endif + am_data = transfer(am, am_data) + if (associated(dir_p)) then + call n_test_gradient(x, energy_func, gradient_func, data=am_data, dir=dir_x) + else + call n_test_gradient(x, energy_func, gradient_func, data=am_data) + endif + deallocate(x) + if (allocated(dir_x)) deallocate(dir_x) + deallocate(am%last_connect_x) + + deallocate(am_data) + + end subroutine pot_n_test_gradient + + ! hook for minim to print configuration during position relaxation + subroutine print_hook(x,dx,E,done,do_print,am_data) + real(dp), intent(in) :: x(:), dx(:) + real(dp), intent(in) :: E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character, intent(in), optional :: am_data(:) + + real(dp), allocatable :: f(:,:) + real(dp), pointer :: f_p(:,:) + integer, pointer, dimension(:) :: hybrid_mark + real(dp) :: virial(3,3), deform_grad(3,3), deform_grad_inv(3,3) + type(potential_minimise) :: am + logical :: my_do_print + + if (.not. present(am_data)) call system_abort("potential_minimise print_hook must have am_data") + my_do_print = optional_default(.true., do_print) + + am = transfer(am_data, am) + ! beware of transfer and pointers !!! + call atoms_repoint(am%minim_at) + + if (associated(am%minim_cinoutput_movie)) then + if (size(x) /= am%minim_at%N*3+9) call system_abort("Called gradient_func() with size mismatch " // & + size(x) // " /= " // am%minim_at%N // "*3+9") + + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + + allocate(f(3,am%minim_at%N)) + f = reshape(dx(10:), (/3,am%minim_at%N/)) + f = transpose(deform_grad) .mult. f + + virial = reshape(dx(1:9), (/3,3/) ) + call inverse(deform_grad, deform_grad_inv) + virial = virial .mult. transpose(deform_grad_inv) + + ! Set atom parameters to print energy, maxforce and maxvirial + call set_value(am%minim_at%params, 'E', E) + if (am%minim_do_pos) then + call set_value(am%minim_at%params, 'MaxForce', maxval(norm(f,1))) + call set_value(am%minim_at%params, 'df2', normsq(reshape(f,(/3*am%minim_at%N/)))) + + + if (am%minim_pot%is_forcemixing) then + !NB This should really be an arbitrary field name, but no obvious way to pass print_hook info on what + !NB the name is (no run_suffix args_str argument, for example) + if (assign_pointer(am%minim_at, 'hybrid_mark', hybrid_mark)) then + if (.not. am%minim_pot%forcemixing%minimise_mm) then + call set_value(am%minim_at%params, 'QM_MaxForce', & + maxval(abs(f(:,find(hybrid_mark == HYBRID_ACTIVE_MARK))))) + + call set_value(am%minim_at%params, 'QM_df2', & + normsq(reshape(f(:,find(hybrid_mark == HYBRID_ACTIVE_MARK)),& + (/3*count(hybrid_mark == HYBRID_ACTIVE_MARK)/)))) + + end if + end if + end if + + end if + + if (am%minim_do_lat) & + call set_value(am%minim_at%params, 'MaxVirial', maxval(abs(virial))) + + if (assign_pointer(am%minim_at, "forces", f_p)) f_p = -f + if (assign_pointer(am%minim_at, "force", f_p)) f_p = -f ! compatibility with crack program + + if (my_do_print) then + if (associated(am%minim_cinoutput_movie)) then + if (trim(am%minim_cinoutput_movie%filename) == "stdout") then + if (.not. am%minim_pot%mpi%active .or. (am%minim_pot%mpi%active .and. am%minim_pot%mpi%my_proc == 0)) & + call write(am%minim_cinoutput_movie, am%minim_at, prefix="MINIM_TRAJ") + else + if (.not. am%minim_pot%mpi%active .or. (am%minim_pot%mpi%active .and. am%minim_pot%mpi%my_proc == 0)) & + call write(am%minim_cinoutput_movie, am%minim_at) + end if + end if + end if + + deallocate(f) + call fix_atoms_deform_grad(deform_grad, am%minim_at,am) + endif + done = .false. + + end subroutine print_hook + + function dummy_energy_func(xx, am_data) + real(dp) :: xx(:) + character(len=1), optional :: am_data(:) + real(dp) :: dummy_energy_func + + dummy_energy_func = 0.0_dp + + end function dummy_energy_func + + + ! compute energy + function energy_func(x, am_data) + real(dp) :: x(:) + character(len=1), optional :: am_data(:) + real(dp) :: energy_func + + real(dp) :: max_atom_rij_change + real(dp) :: deform_grad(3,3) + type(potential_minimise) :: am + real(dp), pointer :: minim_applied_force(:,:) + + call system_timer("energy_func") + + if (.not. present(am_data)) call system_abort("potential_minimise energy_func must have am_data") + am = transfer(am_data, am) + call atoms_repoint(am%minim_at) + + am%minim_n_eval_e = am%minim_n_eval_e + 1 + + if (size(x) /= am%minim_at%N*3+9) call system_abort("Called energy_func() with size mismatch " // & + size(x) // " /= " // am%minim_at%N // "*3+9") + + ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter + max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & + 1.0_dp/am%pos_lat_preconditioner_factor) + + call print("energy_func got x " // x, PRINT_NERD) + + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + + ! Safety factor of 1.1, just in case + ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter + if (1.1*max_atom_rij_change >= am%minim_at%cutoff - cutoff(am%minim_pot)) then + call print("gradient_func: Do calc_connect, atoms moved " // max_atom_rij_change // & + "*1.1 >= buffer " // (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) + if(am%minim_at%cutoff > 0.0_dp) then + call calc_connect(am%minim_at) + end if + am%last_connect_x = x + else + call print("gradient_func: Do calc_dists, atoms moved " // max_atom_rij_change // & + " *1.1 < buffer " // (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) + call calc_dists(am%minim_at) + end if + + call print("energy_func using am%minim_at", PRINT_NERD) + if (current_verbosity() >= PRINT_NERD) call write(am%minim_at, 'stdout') + + call calc(am%minim_pot, am%minim_at, energy = energy_func, args_str = am%minim_args_str) + call print ("energy_func got energy " // energy_func, PRINT_NERD) + + energy_func = energy_func + cell_volume(am%minim_at)*trace(am%external_pressure) / 3.0_dp + call print ("energy_func got enthalpy " // energy_func, PRINT_NERD) + + ! add extra forces + if (assign_pointer(am%minim_at, "minim_applied_force", minim_applied_force)) then + energy_func = energy_func - sum(minim_applied_force*am%minim_at%pos) + end if + + call fix_atoms_deform_grad(deform_grad, am%minim_at, am) + call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) + + am_data = transfer(am, am_data) + + call system_timer("energy_func") + + end function energy_func + + ! compute gradient (forces and virial) + ! x is vectorized version of atomic positions + ! result is vectorized version of forces + function gradient_func(x, am_data) + real(dp) :: x(:) + character(len=1), optional :: am_data(:) + real(dp) :: gradient_func(size(x)) + + real(dp) :: deform_grad(3,3), virial(3,3), deform_grad_inv(3,3) + real(dp), allocatable :: f(:,:) + real(dp) :: max_atom_rij_change + integer :: t_i(2), i, j + integer, pointer, dimension(:) :: move_mask, fixed_pot + integer, pointer, dimension(:,:) :: move_mask_3 + real(dp), pointer :: minim_applied_force(:,:) + + type(potential_minimise) :: am + + call system_timer("gradient_func") + + if (.not. present(am_data)) call system_abort("potential_minimise gradient_func must have am_data") + am = transfer(am_data, am) + ! beware of transfer and pointers !!! + call atoms_repoint(am%minim_at) + + am%minim_n_eval_e = am%minim_n_eval_e + 1 + + am%minim_n_eval_f = am%minim_n_eval_f + 1 + + if (size(x) /= am%minim_at%N*3+9) call system_abort("Called gradient_func() with size mismatch " // & + size(x) // " /= " // am%minim_at%N // "*3+9") + + ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter + max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & + 1.0_dp/am%pos_lat_preconditioner_factor) + + if (current_verbosity() >= PRINT_NERD) call print("gradient_func got x " // x, PRINT_NERD) + + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + + ! Safety factor of 1.1, just in case + ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter + if (1.1*max_atom_rij_change >= am%minim_at%cutoff - cutoff(am%minim_pot)) then + call print("gradient_func: Do calc_connect, atoms moved " // max_atom_rij_change // & + "*1.1 >= buffer " // (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) + if(am%minim_at%cutoff > 0.0_dp) then + call calc_connect(am%minim_at) + end if + am%last_connect_x = x + else + call print("gradient_func: Do calc_dists, atoms moved " // max_atom_rij_change // & + " *1.1 < buffer " // (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) + call calc_dists(am%minim_at) + end if + + if (current_verbosity() >= PRINT_NERD) call add_property(am%minim_at, "force", 0.0_dp, 3) + + allocate(f(3,am%minim_at%N)) + f = 0.0_dp + virial = 0.0_dp + if (am%minim_do_pos .and. am%minim_do_lat) then + call calc(am%minim_pot, am%minim_at, force = f, virial = virial, args_str = am%minim_args_str) + else if (am%minim_do_pos) then + call calc(am%minim_pot, am%minim_at, force = f, args_str = am%minim_args_str) + else + call calc(am%minim_pot, am%minim_at, virial = virial, args_str = am%minim_args_str) + endif + + call print("gradient_func used am%minim_at, got forces", PRINT_NERD) + if (current_verbosity() >= PRINT_NERD) call write(am%minim_at,'stdout') + + ! zero forces if fixed by potential + if (am%minim_do_pos .and. assign_pointer(am%minim_at, "fixed_pot", fixed_pot)) then + do i=1, am%minim_at%N + if (fixed_pot(i) /= 0) f(:,i) = 0.0_dp + end do + endif + + ! Zero force on any fixed atoms + if (assign_pointer(am%minim_at, 'move_mask', move_mask)) then + do i=1,am%minim_at%N + if (move_mask(i) == 0) f(:,i) = 0.0_dp + end do + endif + if (assign_pointer(am%minim_at, 'move_mask_3', move_mask_3)) then + do i=1,am%minim_at%N + do j=1, 3 + if (move_mask_3(j,i) == 0) f(j,i) = 0.0_dp + end do + end do + end if + + ! add extra forces + if (assign_pointer(am%minim_at, "minim_applied_force", minim_applied_force)) then + f = f + minim_applied_force + ! val = val - sum(minim_applied_force*am%minim_at%pos) + endif + + if (current_verbosity() >= PRINT_NERD) then + call print ("gradient_func got f", PRINT_NERD) + call print(f, PRINT_NERD) + call print ("gradient_func got virial", PRINT_NERD) + call print(virial, PRINT_NERD) + end if + virial = virial - am%external_pressure*cell_volume(am%minim_at) + + if (current_verbosity() >= PRINT_NERD) then + call print ("gradient_func got virial, external pressure subtracted", PRINT_NERD) + call print(virial, PRINT_NERD) + end if + + f = transpose(deform_grad) .mult. f + + call constrain_virial(am%minim_at, virial) + + call inverse(deform_grad, deform_grad_inv) + virial = virial .mult. transpose(deform_grad_inv) + + call pack_pos_dg(-f, -virial, gradient_func, 1.0_dp/am%pos_lat_preconditioner_factor) + if (current_verbosity() >= PRINT_NERD) then + call print ("gradient_func packed as", PRINT_NERD) + call print (gradient_func, PRINT_NERD) + endif + + t_i = maxloc(abs(f)) + call print ("gradient_func got max force component " // f(t_i(1),t_i(2)) // " on atom " // t_i(2) // & + " max virial component " // maxval(abs(virial))) + + deallocate(f) + + call fix_atoms_deform_grad(deform_grad, am%minim_at,am) + call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) + am_data = transfer(am, am_data) + + call system_timer("gradient_func") + + end function gradient_func + +! Cristoph Ortner's simple Hessian preconditioner, dense matrix inverse right now + subroutine apply_precond_func(x,g,P_g,am_data,error) + real(dp) :: x(:), g(:), P_g(:) + character(len=1), optional :: am_data(:) + integer, optional :: error + + type(potential_minimise) :: am + real(dp) :: deform_grad(3,3) + real(dp), allocatable :: P(:,:) + real(dp) :: c0, c1 + integer :: i, jj, j + real(dp) :: max_atom_rij_change + integer :: n_nearest + integer, pointer :: move_mask(:), move_mask_3(:,:) + + INIT_ERROR(error) + + am = transfer(am_data, am) + call atoms_repoint(am%minim_at) + + max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & + 1.0_dp/am%pos_lat_preconditioner_factor) + !max_atom_rij_change = 1.038_dp !FIXME this line shouldn't be here either + + call print("apply_precond_func got x " // x, PRINT_NERD) + + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + + ! Safety factor of 1.1, just in case + ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter + if (1.1*max_atom_rij_change >= am%minim_at%cutoff - cutoff(am%minim_pot)) then + call print("apply_precond_func: Do calc_connect, atoms moved " // max_atom_rij_change // "*1.1 >= buffer " // & + (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) + if(am%minim_at%cutoff > 0.0_dp) then + call calc_connect(am%minim_at) + end if + am%last_connect_x = x + else + call print("apply_precond_func: Do calc_dists, atoms moved " // max_atom_rij_change // " *1.1 < buffer " // & + (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) + call calc_dists(am%minim_at) + end if + + ! identity + ! c0 = 1.0_dp + ! c1 = 0.0_dp + ! simplest expression of connectivity + c0 = 0.01_dp + c1 = 1.0_dp + + allocate(P(3*am%minim_at%N,3*am%minim_at%N)) + P = 0.0_dp + do i=1, am%minim_at%N + n_nearest = 0 + do jj=1, n_neighbours(am%minim_at, i) + if (is_nearest_neighbour(am%minim_at, i, jj)) then + n_nearest = n_nearest + 1 + j = neighbour(am%minim_at, i, jj) + P(3*(i-1)+1,3*(j-1)+1) = -c1 + P(3*(i-1)+2,3*(j-1)+2) = -c1 + P(3*(i-1)+3,3*(j-1)+3) = -c1 + endif + end do + P(3*(i-1)+1,3*(i-1)+1) = c0+c1*n_nearest + P(3*(i-1)+2,3*(i-1)+2) = c0+c1*n_nearest + P(3*(i-1)+3,3*(i-1)+3) = c0+c1*n_nearest + end do + + if (assign_pointer(am%minim_at, 'move_mask', move_mask)) then + do i=1,am%minim_at%N + if (move_mask(i) == 0) then + P(3*(i-1)+1:3*(i-1)+3,:) = 0.0_dp + P(:,3*(i-1)+1:3*(i-1)+3) = 0.0_dp + P(3*(i-1)+1,3*(i-1)+1) = 1.0_dp + P(3*(i-1)+2,3*(i-1)+2) = 1.0_dp + P(3*(i-1)+3,3*(i-1)+3) = 1.0_dp + endif + end do + endif + if (assign_pointer(am%minim_at, 'move_mask_3', move_mask_3)) then + do i=1,am%minim_at%N + do j=1, 3 + if (move_mask_3(j,i) == 0) then + P(3*(i-1)+j:3*(i-1)+j,:) = 0.0_dp + P(:,3*(i-1)+j:3*(i-1)+j) = 0.0_dp + P(3*(i-1)+j,3*(i-1)+j) = 1.0_dp + endif + end do + end do + endif + + P_g(1:9) = g(1:9) + call symmetric_linear_solve(P, g(10:10+am%minim_at%N*3-1), P_g(10:10+am%minim_at%N*3-1)) + + end subroutine apply_precond_func + ! compute energy and gradient (forces and virial) + ! x is vectorized version of atomic positions + ! result is vectorized version of forces + subroutine both_func(x,val,grad,am_data,error) + real(dp) :: x(:) + real(dp) :: val + real(dp) :: grad(:) + character(len=1), optional :: am_data(:) + integer, optional :: error + + real(dp) :: deform_grad(3,3), virial(3,3), deform_grad_inv(3,3) + real(dp), allocatable :: f(:,:) + real(dp) :: max_atom_rij_change + integer :: t_i(2), i, j + integer, pointer, dimension(:) :: move_mask, fixed_pot + integer, pointer, dimension(:,:) :: move_mask_3 + real(dp), pointer :: minim_applied_force(:,:) + + type(potential_minimise) :: am + + real(dp) :: hack_restraint_E, hack_restraint_F(3), dr + + INIT_ERROR(error) + + call system_timer("both_func") + + if (.not. present(am_data)) call system_abort("potential_minimise both_func must have am_data") + am = transfer(am_data, am) + ! beware of transfer and pointers !!! + call atoms_repoint(am%minim_at) + + am%minim_n_eval_ef = am%minim_n_eval_ef + 1 + + if (size(x) /= am%minim_at%N*3+9) call system_abort("Called both_func() with size mismatch " // & + size(x) // " /= " // am%minim_at%N // "*3+9") + + ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter + max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & + 1.0_dp/am%pos_lat_preconditioner_factor) + !max_atom_rij_change = 1.038_dp ! FIXME this line shouldn't be here, right? + + call print("both_func got x " // x, PRINT_NERD) + + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + + ! Safety factor of 1.1, just in case + ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter + if (1.1*max_atom_rij_change >= am%minim_at%cutoff - cutoff(am%minim_pot)) then + call print("both_func: Do calc_connect, atoms moved " // max_atom_rij_change // "*1.1 >= buffer " // & + (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) + if(am%minim_at%cutoff > 0.0_dp) then + call calc_connect(am%minim_at) + end if + am%last_connect_x = x + else + call print("both_func: Do calc_dists, atoms moved " // max_atom_rij_change // " *1.1 < buffer " // & + (am%minim_at%cutoff - cutoff(am%minim_pot)), PRINT_NERD) + call calc_dists(am%minim_at) + end if + + call print("both_func using am%minim_at", PRINT_NERD) + if (current_verbosity() >= PRINT_NERD) call write(am%minim_at,'stdout') + + allocate(f(3,am%minim_at%N)) + f = 0.0_dp + virial = 0.0_dp + if (am%minim_do_pos .and. am%minim_do_lat) then + call calc(am%minim_pot, am%minim_at, energy = val, force = f, virial = virial, args_str = am%minim_args_str) + else if (am%minim_do_pos) then + call calc(am%minim_pot, am%minim_at, energy = val, force = f, args_str = am%minim_args_str) + else + call calc(am%minim_pot, am%minim_at, energy = val, virial = virial, args_str = am%minim_args_str) + endif + +if (am%minim_do_pos) then + if (all(hack_restraint_i > 0) .and. all(hack_restraint_i <= am%minim_at%n)) then + call print("hack_restraint i "//hack_restraint_i// " k " // hack_restraint_k // " r " // hack_restraint_r, PRINT_ALWAYS) + dr = distance_min_image(am%minim_at, hack_restraint_i(1), hack_restraint_i(2)) + hack_restraint_E = 0.5_dp * hack_restraint_k*(dr - hack_restraint_r)**2 + val = val + hack_restraint_E + hack_restraint_F = hack_restraint_k*(dr - hack_restraint_r)*diff_min_image(am%minim_at, hack_restraint_i(1), hack_restraint_i(2))/dr + call print("hack_restraint dr-r "//(dr-hack_restraint_r)//"E "//hack_restraint_E// " F " // hack_restraint_F, PRINT_ALWAYS) + f(:,hack_restraint_i(1)) = f(:,hack_restraint_i(1)) + hack_restraint_F + f(:,hack_restraint_i(2)) = f(:,hack_restraint_i(2)) - hack_restraint_F + endif +endif + + if (assign_pointer(am%minim_at, "minim_applied_force", minim_applied_force)) then + f = f + minim_applied_force + val = val - sum(minim_applied_force*am%minim_at%pos) + endif + + call print ("both_func got f", PRINT_NERD) + call print(f, PRINT_NERD) + call print ("both_func got virial", PRINT_NERD) + call print(virial, PRINT_NERD) + + virial = virial - am%external_pressure*cell_volume(am%minim_at) + call print ("both_func got virial, external pressure subtracted", PRINT_NERD) + call print(virial, PRINT_NERD) + + val = val + cell_volume(am%minim_at)*trace(am%external_pressure) / 3.0_dp + call print ("both_func got enthalpy " // val, PRINT_NERD) + ! zero forces if fixed by potential + if (am%minim_do_pos .and. assign_pointer(am%minim_at, "fixed_pot", fixed_pot)) then + do i=1, am%minim_at%N + if (fixed_pot(i) /= 0) f(:,i) = 0.0_dp + end do + endif + + ! Zero force on any fixed atoms + if (assign_pointer(am%minim_at, 'move_mask', move_mask)) then + do i=1,am%minim_at%N + if (move_mask(i) == 0) f(:,i) = 0.0_dp + end do + end if + if (assign_pointer(am%minim_at, 'move_mask_3', move_mask_3)) then + do i=1,am%minim_at%N + do j=1, 3 + if (move_mask_3(j,i) == 0) f(j,i) = 0.0_dp + end do + end do + end if + + f = transpose(deform_grad) .mult. f + + call constrain_virial(am%minim_at, virial) + + call inverse(deform_grad, deform_grad_inv) + virial = virial .mult. transpose(deform_grad_inv) + + call pack_pos_dg(-f, -virial, grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call print ("both_func gradient packed as", PRINT_NERD) + call print (grad, PRINT_NERD) + + t_i = maxloc(abs(f)) + call print ("both_func got max force component " // f(t_i(1),t_i(2)) // " on atom " // t_i(2) // & + " max virial component " // maxval(abs(virial))) + + deallocate(f) + + call fix_atoms_deform_grad(deform_grad, am%minim_at,am) + call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) + + am_data = transfer(am, am_data) + + call system_timer("both_func") + + end subroutine both_func + + function max_rij_change(last_connect_x, x, r_cut, lat_factor) + real(dp), intent(inout) :: last_connect_x(:) + real(dp), intent(in) :: x(:) + real(dp), intent(in) :: r_cut, lat_factor + real(dp) :: max_rij_change + + real(dp) :: F0(3,3), F0_evals(3), dF(3,3), dF_evals(3) + + call print("max_rij_change, size(last_connect_x) " // size(last_connect_x) // & + " size(x) " // size(x), PRINT_NERD) + if (size(last_connect_x) == size(x)) then + F0 = lat_factor*reshape(last_connect_x(1:9), (/ 3,3 /)) + dF = lat_factor*reshape(x(1:9), (/ 3,3 /)) - F0 + call diagonalise(matmul(F0,transpose(F0)), F0_evals) + call diagonalise(matmul(dF,transpose(dF)), dF_evals) + F0_evals = sqrt(F0_evals) + dF_evals = sqrt(dF_evals) + call print("max_rij_change = " // maxval(abs(F0_evals)) //"*2.0_dp*"// & + maxval(abs(last_connect_x-x))*sqrt(3.0_dp) // & + " + " // maxval(abs(dF_evals))//"*"//r_cut, PRINT_VERBOSE) + max_rij_change = maxval(abs(F0_evals))*2.0_dp*maxval(abs(last_connect_x-x))*sqrt(3.0_dp) + & + maxval(abs(dF_evals))*r_cut + else + call system_abort("max_rij_change: size(last_connect_x)="//size(last_connect_x)// & + " /= size(x)="//size(x)) + endif + + end function max_rij_change + + ! prepare atoms structure given a deformation gradient matrix + subroutine prep_atoms_deform_grad(deform_grad, at, am) + real(dp), intent(in) :: deform_grad(3,3) + type(Atoms), intent(inout) :: at + type(potential_minimise), intent(inout) :: am + + am%minim_save_lat = at%lattice + call set_lattice(at, deform_grad .mult. am%minim_save_lat, scale_positions=.true.) + end subroutine prep_atoms_deform_grad + + ! remove effect of deformation gradient applied by prep_atoms_deform_grad + subroutine fix_atoms_deform_grad(deform_grad, at,am) + real(dp), intent(in) :: deform_grad(3,3) + type(Atoms), intent(inout) :: at + type(potential_minimise), intent(inout) :: am + + real(dp) :: deform_grad_inv(3,3) + + call inverse(deform_grad, deform_grad_inv) + at%pos = deform_grad_inv .mult. at%pos + call set_lattice(at, am%minim_save_lat, scale_positions=.false.) + + end subroutine fix_atoms_deform_grad + + ! unpack a deformation grad and a pos array from 1-D array into a atoms%pos 2-D array + subroutine unpack_pos_dg(xx, at_N, at_pos, dg, lat_factor) + real(dp), intent(in) :: xx(:) + integer :: at_N + real(dp), intent(inout) :: at_pos(:,:) + real(dp) :: dg(3,3) + real(dp), intent(in) :: lat_factor + + if (3*at_N+9 /= size(xx)) call system_abort("Called unpack_pos with mismatching sizes x " // size(xx) // " at " // at_N) + + dg = lat_factor*reshape(xx(1:9), (/ 3,3 /) ) + at_pos = reshape(xx(10:), (/ 3, at_N /) ) + +end subroutine unpack_pos_dg + + ! pack a 3xN 2-D array into a 1-D array + subroutine pack_pos_dg(x2d, dg2d, x, lat_factor) + real(dp), intent(in) :: x2d(:,:) + real(dp), intent(in) :: dg2d(3,3) + real(dp), intent(out) :: x(:) + real(dp), intent(in) :: lat_factor + + if (size(x2d,1) /= 3) call system_abort("Called pack with mismatching size(x2d,1) " // & + size(x2d,1) // " != 3") + + if (size(dg2d,1) /= 3 .or. size(dg2d,2) /= 3) & + call system_abort("Called pack with mismatching size(dg2d,1) " // shape(dg2d) // " != 3x3") + if (size(x) /= (size(x2d)+size(dg2d))) & + call system_abort("Called pack with mismatching size x " // size(x) // " x2d " // size(x2d) // & + " dg2d " // size(dg2d)) + + x(1:9) = lat_factor*reshape(dg2d, (/ 9 /) ) + + x(10:) = reshape(x2d, (/ size(x2d) /) ) + +end subroutine pack_pos_dg + + subroutine Potential_read_params_xml(this, param_str) + type(Potential), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) & + call system_abort('Potential_read_params_xml: invalid param_str length '//len(trim(param_str)) ) + + parse_in_pot = .false. + parse_in_pot_done = .false. + parse_matched_label = .false. + parse_pot => this + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = Potential_startElement_handler, & + endElement_handler = Potential_endElement_handler) + call close_xml_t(fxml) + + if(.not. parse_in_pot_done) then + if (len_trim(param_str) > 10000) then + call system_abort('Potential_read_params_xml: could not initialise potential from xml_label. param_str(1:10000)='//trim(param_str(1:10000))) + else + call system_abort('Potential_read_params_xml: could not initialise potential from xml_label. param_str='//trim(param_str)) + endif + endif + + endsubroutine Potential_read_params_xml + + subroutine Potential_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=STRING_LENGTH) :: value + + if(name == 'Potential') then ! new Potential stanza + + if(parse_in_pot) & + call system_abort("Potential_startElement_handler entered with parse_in true. Probably a forgotten /> at the end of a tag.") + + if(parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if(status /= 0) value = '' + + if(len(trim(parse_pot%xml_label)) > 0) then ! we were passed in a label + if(trim(value) == trim(parse_pot%xml_label)) then ! exact match + parse_matched_label = .true. + parse_in_pot = .true. + else ! no match + parse_in_pot = .false. + endif + else ! no label passed in + call system_abort("Potential_startElement_handler: no label passed in") + endif + + call QUIP_FoX_get_value(attributes, 'init_args', value, status) + if(status == 0) then + read (value, '(a)') parse_pot%xml_init_args + else + call system_abort("Potential_startElement_handler: no init_args attribute found") + endif + + endif + + endsubroutine Potential_startElement_handler + + subroutine Potential_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if(parse_in_pot) then + if(name == 'Potential') then + parse_in_pot = .false. + parse_in_pot_done = .true. + endif + endif + + endsubroutine Potential_endElement_handler + + subroutine potential_set_callback(this, callback) + type(Potential), intent(inout) :: this + interface + subroutine callback(at) + integer, intent(in) :: at(12) + end subroutine callback + end interface + + if (this%is_simple) then + call set_callback(this%simple, callback) + else + call system_abort('potential_set_callback() only implemented for simple Potentials.') + end if + + end subroutine potential_set_callback + +#ifdef HAVE_TB + !% Calculate TB Hamiltonian and overlap matrices and optionally their derivatives wrt atomic positions. + !% This always triggers a force calculation, since the elements for dH and dS are assembled on the fly for each atom. + subroutine potential_calc_TB_matrices(this, at, args_str, Hd, Sd, Hz, Sz, dH, dS, index) + type(Potential), intent(inout) :: this + type(atoms), intent(inout) :: at !% Atomic structure to use for TB matrix calculation + character(len=*), intent(in), optional :: args_str !% Additional arguments to pass to TB `calc()` routine + real(dp), intent(inout), optional, dimension(:,:) :: Hd, Sd !% Hamiltonian and overlap for real wavefunctions (gamma point) + complex(dp), intent(inout), optional, dimension(:,:) :: Hz, Sz !% Complex Hamiltonian and overlap (multiple kpoints) + real(dp), intent(inout), optional, dimension(:,:,:,:) :: dH, dS !% Derivative of H and S wrt atomic positiions. Shape is `(3, N_atoms, N_elecs, N_elecs)` + integer, optional, intent(in) :: index + + if (this%is_simple) then + call calc_TB_matrices(this%simple, at, args_str, Hd, Sd, Hz, Sz, dH, dS, index=index) + else + call system_abort('potential_calc_TB_matrices() only implemented for simple Potentials.') + end if + + end subroutine potential_calc_TB_matrices +#endif + +#include "Potential_Sum_routines.F90" +#include "Potential_ForceMixing_routines.F90" +#include "Potential_EVB_routines.F90" + +#ifdef HAVE_LOCAL_E_MIX +#include "Potential_Local_E_Mix_routines.F90" +#endif +#ifdef HAVE_ONIOM +#include "Potential_ONIOM_routines.F90" +#endif + +#include "Potential_Cluster_routines.F90" +#include "Potential_Hybrid_utils.F90" + + + !% Run 'n_steps' of dynamics using forces from Potential 'pot'. + !% + !% For each step, forces are evaluated using the Potential + !% 'pot' and the DynamicalSystem is advanced by a time 'dt' + !% (default 1 fs). 'n_steps' (default 10 steps) are carried out in + !% total, with snapshots saved every 'save_interval' steps. The + !% connectivity is recalculated every 'connect_interval' steps. + !% 'args_str' can be used to supply extra arguments to 'Potential%calc'. + subroutine DynamicalSystem_run(this, pot, dt, n_steps, hook, hook_interval, summary_interval, write_interval, trajectory, args_str, error) + type(DynamicalSystem), intent(inout), target :: this + type(Potential), intent(inout) :: pot + real(dp), intent(in) :: dt + integer, intent(in) :: n_steps + integer, intent(in), optional :: summary_interval, hook_interval, write_interval + type(CInOutput), intent(inout), optional :: trajectory + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + interface + subroutine hook() + end subroutine hook + end interface + + integer :: n, my_summary_interval, my_hook_interval, my_write_interval + real(dp) :: e + real(dp), pointer, dimension(:,:) :: f + character(len=STRING_LENGTH) :: my_args_str + type(Dictionary) :: params + + INIT_ERROR(error) + + my_summary_interval = optional_default(1, summary_interval) + my_hook_interval = optional_default(1, hook_interval) + my_write_interval = optional_default(1, write_interval) + my_args_str = optional_default("", args_str) + call initialise(params) + call read_string(params, my_args_str) + if (.not. has_key(params, 'energy')) call set_value(params, 'energy') + if (.not. has_key(params, 'force')) call set_value(params, 'force') + my_args_str = write_string(params) + call finalise(params) + + call calc(pot, this%atoms, args_str=my_args_str, error=error) + PASS_ERROR(error) + call set_value(this%atoms%params, 'time', this%t) + if (.not. get_value(this%atoms%params, 'energy', e)) & + call system_abort("dynamicalsystem_run failed to get energy") + if (.not. assign_pointer(this%atoms, 'force', f)) & + call system_abort("dynamicalsystem_run failed to get forces") + if (my_summary_interval > 0) call ds_print_status(this, epot=e) + call hook() + if (present(trajectory)) call write(trajectory, this%atoms) + + ! initialize accelerations from forces, so first call to verlet1 will be correct + this%atoms%acc(1,:) = f(1,:)/this%atoms%mass + this%atoms%acc(2,:) = f(2,:)/this%atoms%mass + this%atoms%acc(3,:) = f(3,:)/this%atoms%mass + + do n=1,n_steps + call advance_verlet1(this, dt) + call calc(pot, this%atoms, args_str=my_args_str, error=error) + PASS_ERROR(error) + call advance_verlet2(this, dt, f) + if (.not. get_value(this%atoms%params, 'energy', e)) & + call system_abort("dynamicalsystem_run failed to get energy") + if (.not. assign_pointer(this%atoms, 'force', f)) & + call system_abort("dynamicalsystem_run failed to get forces") + if (my_summary_interval > 0 .and. mod(n, my_summary_interval) == 0) call ds_print_status(this, epot=e) + call set_value(this%atoms%params, 'time', this%t) + + if (my_hook_interval > 0 .and. mod(n,my_hook_interval) == 0) call hook() + if (present(trajectory) .and. my_write_interval > 0 .and. mod(n,my_write_interval) == 0) call write(trajectory, this%atoms) + if (cutoff(pot) > 0.0_dp .and. this%atoms%cutoff > 0.0_dp) call calc_connect(this%atoms) + end do + + end subroutine DynamicalSystem_run + + subroutine constrain_DG(at, deform_grad) + type(Atoms), intent(in) :: at + real(dp), intent(inout) :: deform_grad(3,3) + + logical :: minim_constant_volume + real(dp) :: scaled_ident(3,3), DG_det + integer :: error + + minim_constant_volume = .false. + call get_param_value(at, "Minim_Constant_Volume", minim_constant_volume, error=error) + + ! zero out trace component, which changes volume + if (minim_constant_volume) then + DG_det = matrix3x3_det(deform_grad) + scaled_ident = 0.0_dp + call add_identity(scaled_ident) + scaled_ident = scaled_ident * (DG_det**(-1.0/3.0)) + deform_grad = matmul(deform_grad, scaled_ident) + endif + end subroutine constrain_DG + + subroutine constrain_virial(at, virial) + type(Atoms), intent(in) :: at + real(dp), intent(inout) :: virial(3,3) + + integer :: error + logical :: minim_hydrostatic_strain, minim_constant_volume + logical :: minim_lattice_fix_mask(3,3) + real(dp) :: minim_lattice_fix(3,3) + real(dp) :: scaled_ident + + real(dp) :: virial_trace + + minim_hydrostatic_strain = .false. + call get_param_value(at, "Minim_Hydrostatic_Strain", minim_hydrostatic_strain, error=error) + CLEAR_ERROR(error) + + minim_lattice_fix = 0.0_dp + call get_param_value(at, "Minim_Lattice_Fix", minim_lattice_fix, error=error) + CLEAR_ERROR(error) + minim_lattice_fix_mask = (minim_lattice_fix /= 0.0_dp) + + minim_constant_volume = .false. + call get_param_value(at, "Minim_Constant_Volume", minim_constant_volume, error=error) + CLEAR_ERROR(error) + + ! project onto identity + if (minim_hydrostatic_strain) then + virial_trace = trace(virial) + virial = 0.0_dp + virial(1,1) = virial_trace/3.0_dp + virial(2,2) = virial_trace/3.0_dp + virial(3,3) = virial_trace/3.0_dp + endif + ! Zero out components corresponding to fixed lattice elements + if (any(minim_lattice_fix_mask)) then + virial = merge(0.0_dp, virial, minim_lattice_fix_mask) + end if + + if (minim_constant_volume) then + virial_trace = virial(1,1) + virial(2,2) + virial(3,3) + virial(1,1) = virial(1,1) - virial_trace/3.0 + virial(2,2) = virial(2,2) - virial_trace/3.0 + virial(3,3) = virial(3,3) - virial_trace/3.0 + endif + + end subroutine constrain_virial + + + +end module Potential_module diff --git a/src/Potentials/Potential_Cluster_header.F90 b/src/Potentials/Potential_Cluster_header.F90 new file mode 100644 index 0000000000..758d7d2caa --- /dev/null +++ b/src/Potentials/Potential_Cluster_header.F90 @@ -0,0 +1,65 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Cluster header stuff to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + public :: Potential_Cluster + type Potential_Cluster + type(Potential), pointer :: inner_pot + real(dp):: r_scale_pot1 = 1.0_dp, E_scale_pot1 = 1.0_dp + character(STRING_LENGTH) :: run_suffix + + end type Potential_Cluster + + interface Print + module procedure potential_cluster_print + end interface Print + + interface Cutoff + module procedure potential_cluster_cutoff + end interface Cutoff + + interface Calc + module procedure potential_cluster_calc + end interface Calc + + interface Initialise + module procedure potential_cluster_initialise + end interface Initialise + + interface Finalise + module procedure potential_cluster_finalise + end interface Finalise diff --git a/src/Potentials/Potential_Cluster_routines.F90 b/src/Potentials/Potential_Cluster_routines.F90 new file mode 100644 index 0000000000..58d9b16170 --- /dev/null +++ b/src/Potentials/Potential_Cluster_routines.F90 @@ -0,0 +1,163 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Cluster routines to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + recursive subroutine potential_Cluster_initialise(this, args_str, inner_pot, mpi_obj, error) + type(Potential_Cluster), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(Potential), intent(inout), target :: inner_pot + type(MPI_Context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(Dictionary) :: params + logical :: minimise_bulk + logical :: do_rescale_r, do_rescale_E, do_tb_defaults + + INIT_ERROR(error) + + call initialise(params) + call param_register(params, "run_suffix", "", this%run_suffix, help_string="Suffix to apply to hybrid mark properties$") + call param_register(params, "r_scale", "1.0", this%r_scale_pot1, help_string="Rescaling factor for cluster positions") + call param_register(params, "E_scale", "1.0", this%E_scale_pot1, help_string="Rescaling factor for cluster energies (and hence also forces)") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Cluster_initialise args_str') ) then + RAISE_ERROR("Potential_Cluster_initialise failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + + if (this%r_scale_pot1 <= 0.0_dp) this%r_scale_pot1 = 1.0_dp + if (this%E_scale_pot1 <= 0.0_dp) this%E_scale_pot1 = 1.0_dp + + call print ("Rescaling positions in region1 potential by " // this%r_scale_pot1 // " to match lattice constants") + call print ("Rescaling energies in region1 potential by " // this%E_scale_pot1 // " to match bulk modulus") + + this%inner_pot => inner_pot + + end subroutine + + recursive subroutine potential_Cluster_finalise(this) + type(Potential_Cluster), intent(inout) :: this + + nullify(this%inner_pot) + + end subroutine potential_Cluster_finalise + + + recursive function potential_Cluster_cutoff(this) + type(Potential_Cluster), intent(in) :: this + real(dp) :: potential_Cluster_cutoff + + potential_Cluster_cutoff = cutoff(this%inner_pot) + + end function potential_Cluster_cutoff + + recursive subroutine potential_Cluster_print(this, file) + type(Potential_Cluster), intent(inout) :: this + type(Inoutput),intent(inout),optional:: file + + call print('Cluster potential:', file=file) + call print('Inner Potential:', file=file) + call print('================', file=file) + call print(this%inner_pot, file=file) + call print('') + call print('r_scale_pot1=' // this%r_scale_pot1 // ' E_scale_pot1=' // this%E_scale_pot1, file=file) + call print('') + end subroutine potential_Cluster_print + + + recursive subroutine potential_Cluster_calc(this, at, args_str, error) + type(Potential_Cluster), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + type(Dictionary) :: params + character(STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, run_suffix + logical single_cluster, little_clusters + + INIT_ERROR(error) + + if (.not. associated(this%inner_pot)) then + RAISE_ERROR("Potential_Cluster_calc: this%inner_pot", error) + endif + + call initialise(params) + call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "energy", "", calc_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "force", "", calc_force, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "virial", "", calc_virial, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "local_energy", "", calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "local_virial", "", calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'single_cluster', 'F', single_cluster, & + help_string="If true, calculate all active/transition atoms with a single big cluster") + call param_register(params, 'little_clusters', 'F', little_clusters, & + help_string="If true, calculate forces (only) by doing each atom separately surrounded by a little buffer cluster") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Cluster_Calc args_str') ) then + RAISE_ERROR("Potential_Cluster_calc_energy failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + + if (len_trim(calc_energy) /= 0 .or. len_trim(calc_local_energy) /= 0 .or. & + len_trim(calc_virial) /= 0 .or. len_trim(calc_local_virial) /= 0) then + RAISE_ERROR("Potential_Cluster_calc: can only calculate forces, not energies or virials", error) + end if + + if (single_cluster .and. little_clusters) then + RAISE_ERROR('Potential_Cluster_calc: single_cluster and little_clusters options are mutually exclusive', error) + end if + + end subroutine potential_Cluster_calc + + + subroutine calc_single_cluster(this, at, args_str, error) + type(Potential_Cluster), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + INIT_ERROR(error) + + end subroutine calc_single_cluster + + subroutine calc_little_clusters(this, at, args_str, error) + type(Potential_Cluster), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + INIT_ERROR(error) + + end subroutine calc_little_clusters diff --git a/src/Potentials/Potential_EVB_header.F90 b/src/Potentials/Potential_EVB_header.F90 new file mode 100644 index 0000000000..9b0dbc10ce --- /dev/null +++ b/src/Potentials/Potential_EVB_header.F90 @@ -0,0 +1,46 @@ + + public :: Potential_EVB + type Potential_EVB + type(MPI_context) :: mpi + + type(Potential), pointer :: pot1 => null() !% The underlying MM potential, pot1 and pot2 + + character(STRING_LENGTH) :: mm_args_str !% Args string to be passed to 'calc' method of pot1 and pot2 + + character(STRING_LENGTH) :: topology_suffix1 !% Suffix in topology filename, to be added to mm_args_str of pot1 + character(STRING_LENGTH) :: topology_suffix2 !% Suffix in topology filename, to be added to mm_args_str of pot2 + + integer :: form_bond(2) !% Atom pair that is bonded in EVB1 only + integer :: break_bond(2) !% Atom pair that is bonded in EVB2 only + + real(dp) :: diagonal_dE2 !% The energy offset to E2 + real(dp) :: offdiagonal_A12 !% The offdiagonal pre-exponent factor of EVB Hamiltonian + real(dp) :: offdiagonal_mu12 !% The offdiagonal exponent factor of the EVB Hamiltonian + real(dp) :: offdiagonal_mu12_square !% The offdiagonal exponent factor of the EVB Hamiltonian: A exp(-mu12(r-r0)-mu12_square(r-r0)^2) + real(dp) :: offdiagonal_r0 !% The offdiagonal exponent of the EVB Hamiltonian + + logical :: save_forces !% Whether to save forces from the 2 MM calculations in the Atoms object (needed for force on E_GAP) + logical :: save_energies !% Whether to save energies from the 2 MM calculations in the Atoms object (needed for E_GAP) + + end type Potential_EVB + + interface Initialise + module procedure Potential_EVB_Initialise + end interface + + interface Finalise + module procedure Potential_EVB_Finalise + end interface + + interface Print + module procedure Potential_EVB_Print + end interface + + interface Cutoff + module procedure Potential_EVB_Cutoff + end interface + + interface Calc + module procedure Potential_EVB_Calc + end interface + diff --git a/src/Potentials/Potential_EVB_routines.F90 b/src/Potentials/Potential_EVB_routines.F90 new file mode 100644 index 0000000000..768f40ac43 --- /dev/null +++ b/src/Potentials/Potential_EVB_routines.F90 @@ -0,0 +1,400 @@ + + !************************************************************************* + !* + !* Potential_EVB routines + !* + !************************************************************************* + + recursive subroutine Potential_EVB_Initialise(this, args_str, pot1, mpi, error) + type(Potential_EVB), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(Potential), intent(in), target :: pot1 + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + !Only 1 potential for the 2 MM calculations + this%pot1 => pot1 + + call initialise(params) + call param_register(params, 'mm_args_str', '', this%mm_args_str, help_string="Argumentum string to be passed on to the underlying MM potential(s) of the EVB method.") + call param_register(params, 'topology_suffix1', '_EVB1', this%topology_suffix1, help_string="Suffix of the first topology file of the EVB method.") + call param_register(params, 'topology_suffix2', '_EVB2', this%topology_suffix2, help_string="Suffix of the second topology file of the EVB method.") + call param_register(params, 'form_bond', '0 0', this%form_bond, help_string="Which bond to form in the first topology and break in the second topology used in the EVB calculation.") + call param_register(params, 'break_bond', '0 0', this%break_bond, help_string="Which bond to break in the first topology and form in the second topology used in the EVB calculation.") + call param_register(params, 'diagonal_dE2', '0.0', this%diagonal_dE2, help_string="Energy offset between the energy minima of the two topologies of the EVB method.") + call param_register(params, 'offdiagonal_A12', '0.0', this%offdiagonal_A12, help_string="A12 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") + call param_register(params, 'offdiagonal_mu12', '0.0', this%offdiagonal_mu12, help_string="mu12 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") + call param_register(params, 'offdiagonal_mu12_square', '0.0', this%offdiagonal_mu12_square, help_string="mu12_square parameter of the coupling parameter A12*exp(-mu12*r0-mu12_square*r0**2.0).") + call param_register(params, 'offdiagonal_r0', '0.0', this%offdiagonal_r0, help_string="r0 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") + call param_register(params, 'save_forces', 'T', this%save_forces, help_string="Whether to save forces in atoms%params as EVB1_$forces$ EVB2_$forces$ if $forces$ is given when calling calc.") + call param_register(params, 'save_energies', 'T', this%save_energies, help_string="Whether to save energies in atoms%params as EVB1_$energy$ and EVB2_$energy$ if $energy$ is given when calling calc.") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_EVB_initialise args_str')) then + RAISE_ERROR('Potential_EVB_initialise failed to parse args_str="'//trim(args_str)//'"', error) + endif + call finalise(params) + + if (present(mpi)) this%mpi = mpi + + end subroutine Potential_EVB_Initialise + + recursive subroutine Potential_EVB_Finalise(this) + type(Potential_EVB), intent(inout) :: this + + nullify(this%pot1) + + this%mm_args_str = "" + this%topology_suffix1 = "" + this%topology_suffix2 = "" + this%form_bond(1:2) = 0 + this%break_bond(1:2) = 0 + this%diagonal_dE2 = 0._dp + this%offdiagonal_A12 = 0._dp + this%offdiagonal_mu12 = 0._dp + this%offdiagonal_mu12_square = 0._dp + this%offdiagonal_r0 = 0._dp + this%save_forces = .false. + this%save_energies = .false. + + end subroutine Potential_EVB_Finalise + + recursive subroutine Potential_EVB_Print(this, file) + type(Potential_EVB), intent(inout) :: this + type(Inoutput), intent(inout), optional :: file + + call print('Potential_EVB:', file=file) + call print(' mm_args_str='//trim(this%mm_args_str), file=file) + call print(' topology_suffix1='//trim(this%topology_suffix1), file=file) + call print(' topology_suffix2='//trim(this%topology_suffix2), file=file) + call print(' evb1-form and evb2-break bond: '//this%form_bond(1:2), file=file) + call print(' evb1-break and evb2-form bond: '//this%break_bond(1:2), file=file) + call print(' diagonal E2(shift to E2): '//this%diagonal_dE2, file=file) + call print(' offdiagonal A12(pre-exponent factor): '//this%offdiagonal_A12, file=file) + call print(' offdiagonal mu12(exponent factor): '//this%offdiagonal_mu12, file=file) + call print(' offdiagonal mu12_square(exponent factor): '//this%offdiagonal_mu12_square, file=file) + call print(' offdiagonal r0(exponent): '//this%offdiagonal_r0, file=file) + call print(' save_forces: '//this%save_forces, file=file) + call print(' save_energies: '//this%save_energies, file=file) + call print('', file=file) + if (associated(this%pot1)) then + call print('Potential 1:', file=file) + call print(this%pot1, file=file) + call print('', file=file) + else + call print('Potential 1 not initialised', file=file) + call print('', file=file) + end if + call print('Potential 2: same as Potential 1', file=file) + call print('', file=file) + + end subroutine Potential_EVB_Print + + recursive subroutine Potential_EVB_Calc(this, at, args_str, error) + type(Potential_EVB), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + real(dp) :: e, virial + real(dp), pointer :: at_force_ptr(:,:), dgap_dr_ptr(:,:) + + real(dp) :: gap, term1 + type(Dictionary) :: params + character(STRING_LENGTH) :: mm_args_str + character(STRING_LENGTH) :: topology_suffix1, topology_suffix2 + integer :: form_bond(2), break_bond(2), atom1, atom3 + logical :: have_form_bond, have_break_bond + + logical :: save_energies, save_forces + real(dp) :: my_e_1, my_e_2, e_offdiag + real(dp), allocatable :: my_f_1(:,:), my_f_2(:,:), de_offdiag_dr(:,:) + real(dp) :: offdiagonal_A12, offdiagonal_r0, offdiagonal_mu12, offdiagonal_mu12_square, diagonal_dE2, & + rab, d_rab_dx(3) + logical :: no_coupling, dummy + character(STRING_LENGTH) :: extra_calc_args + + character(STRING_LENGTH) :: psf_print + character(STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, calc_EVB_gap + character(STRING_LENGTH) :: use_calc_energy + character(STRING_LENGTH) :: new_args_str + + INIT_ERROR(error) + + !read args_str + call initialise(params) + call param_register(params, 'mm_args_str', ''//this%mm_args_str, mm_args_str, help_string="Argumentum string to be passed on to the underlying MM potential(s) of the EVB method.") + call param_register(params, 'topology_suffix1', ''//this%topology_suffix1, topology_suffix1, help_string="Suffix of the first topology file of the EVB method.") + call param_register(params, 'topology_suffix2', ''//this%topology_suffix2, topology_suffix2, help_string="Suffix of the second topology file of the EVB method.") + call param_register(params, 'form_bond', ''//this%form_bond, form_bond, help_string="Which bond to form in the first topology and break in the second topology used in the EVB calculation.") + call param_register(params, 'break_bond', ''//this%break_bond, break_bond, help_string="Which bond to break in the first topology and form in the second topology used in the EVB calculation.") + call param_register(params, 'diagonal_dE2', ''//this%diagonal_dE2, diagonal_dE2, help_string="Energy offset between the energy minima of the two topologies of the EVB method.") + call param_register(params, 'offdiagonal_A12', ''//this%offdiagonal_A12, offdiagonal_A12, help_string="A12 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") + call param_register(params, 'offdiagonal_mu12', ''//this%offdiagonal_mu12, offdiagonal_mu12, help_string="mu12 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") + call param_register(params, 'offdiagonal_mu12_square', ''//this%offdiagonal_mu12_square, offdiagonal_mu12_square, help_string="mu12_square parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") + call param_register(params, 'offdiagonal_r0', ''//this%offdiagonal_r0, offdiagonal_r0, help_string="r0 parameter of the coupling term A12*exp(-mu12*r0-mu12_square*r0**2.0).") + call param_register(params, 'save_forces', ''//this%save_forces, save_forces, help_string="Whether to save forces in atoms%params as EVB1_$forces$ EVB2_$forces$ if $forces$ is given when calling calc.") + call param_register(params, 'save_energies', ''//this%save_energies, save_energies, help_string="Whether to save energies in atoms%params as EVB1_$energy$ and EVB2_$energy$ if $energy$ is given when calling calc.") + call param_register(params, 'energy', '', calc_energy, help_string="Under what name to save the EVB energies (EVB1_$energy$ and EVB2_$energy$) in atoms%params.") + call param_register(params, 'force', '', calc_force, help_string="Under what name to save the EVB forces (EVB1_$force$ and EVB2_$force$) in atoms%data.") + call param_register(params, 'virial', '', calc_virial, help_string="Whether to calculate virial. This option is not supported in EVB calculations.$") + call param_register(params, 'local_energy', '', calc_local_energy, help_string="Whether to calculate local energy. This option is not supported in EVB calculations.") + call param_register(params, 'local_virial', '', calc_local_virial, help_string="Whether to calculate local virial. This option is not supported in EVB calculations.") + call param_register(params, 'EVB_gap', '', calc_EVB_gap, help_string="Under what name to save the EVB gap energy in atoms%params. Forces on the gap energy will be saved in $EVB_gap$_force property.") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_EVB_calc args_str')) then + RAISE_ERROR('Potential_EVB_calc failed to parse args_str="'//trim(args_str)//'"', error) + endif + call finalise(params) + + !CHECK ARGUMENTS + + if (len_trim(calc_virial) > 0 .or. len_trim(calc_local_energy) > 0 .or. len_trim(calc_local_virial) > 0) then + RAISE_ERROR('Potential_EVB_calc: supports only energy and forces, not virial, local_energy or local_virial', error) + endif + + if (len_trim(calc_force) > 0) then + call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) + PASS_ERROR_WITH_INFO("Potential_EVB_Calc assigning pointer for force property '"//trim(calc_force)//"'", error) + endif + + !coupling parameters + if (offdiagonal_A12 .feq. 0._dp) then + call print('WARNING! Offdiagonal A12 is set to 0. No coupling between resonance states.') + no_coupling = .true. + else + if (offdiagonal_A12 < 0._dp .or. offdiagonal_mu12 < 0._dp .or. offdiagonal_mu12_square < 0._dp .or. offdiagonal_r0 < 0._dp ) then + RAISE_ERROR('Potential_EVB_calc offdiagonal parameters must be positive or 0 for no coupling. Got offdiagonal_A12: '//offdiagonal_A12 //' and offdiagonal_mu12: '//offdiagonal_mu12//' and offdiagonal_mu12_square: '//offdiagonal_mu12_square//' and offdiagonal_r0: '//offdiagonal_r0, error) + endif + no_coupling = .false. + endif + + !form_bond + have_form_bond = .true. + if(any(form_bond<1) .or. any(form_bond>at%N)) then + !check whether all 0 (skip) + if (all(form_bond==0)) then + have_form_bond = .false. + else + RAISE_ERROR('Potential_EVB_calc form_bond is out of range 1--'//at%N//': '//form_bond, error) + endif + endif + + !break_bond + have_break_bond = .true. + if(any(break_bond<1) .or. any(break_bond>at%N)) then + !check whether all 0 (skip) + if (all(break_bond==0)) then + have_break_bond = .false. + else + RAISE_ERROR('Potential_EVB_calc break_bond is out of range 1--'//at%N//': '//break_bond, error) + endif + endif + + if (.not.(have_form_bond .or. have_break_bond)) then + RAISE_ERROR('Potential_EVB_calc no bonds to form neither to break. ', error) + endif + + !CALCULATE E,F WITH DIFFERENT TOPOLOGIES + + ! allocate local arrays + if (len_trim(calc_force) > 0) then + allocate(my_f_1(3,at%N)) + allocate(my_f_2(3,at%N)) + allocate(de_offdiag_dr(3,at%N)) + endif + + ! SETUP CALC_ARGS, AND CALL CALC FOR TOPOLOGY 1 + ! topology suffix + extra_calc_args="topology_suffix="//trim(topology_suffix1) + ! add energy= arg if needed + use_calc_energy=trim(calc_energy) + if (len_trim(calc_energy) == 0) then + use_calc_energy="energy" + do while (has_key(at%params, trim(use_calc_energy))) + use_calc_energy = "T"//trim(use_calc_energy) + end do + endif + extra_calc_args=trim(extra_calc_args)//" energy="//trim(use_calc_energy) + if (len_trim(calc_force) > 0) extra_calc_args=trim(extra_calc_args)//" force="//trim(calc_force) + ! add args to form/break bonds for topology 1 + if (have_form_bond) extra_calc_args=trim(extra_calc_args)//" form_bond={"//form_bond(1:2)//"}" + if (have_break_bond) extra_calc_args=trim(extra_calc_args)//" break_bond={"//break_bond(1:2)//"}" + !calc with topology1 +call print("EVB1 ARGS_STR "//trim(mm_args_str)//" "//trim(extra_calc_args)) + call calc(this%pot1, at, args_str=trim(mm_args_str)//" "//trim(extra_calc_args), error=error) + PASS_ERROR(error) + + call get_param_value(at, trim(use_calc_energy), my_e_1, error=error) + PASS_ERROR_WITH_INFO("getting energy parameter '"//trim(use_calc_energy)//"' for topology 1", error) + if (len_trim(calc_energy) == 0) call remove_value(at%params, trim(use_calc_energy)) + if (len_trim(calc_force) > 0) my_f_1 = at_force_ptr + + ! SETUP CALC_ARGS, AND CALL CALC FOR TOPOLOGY 2 + ! topology suffix + extra_calc_args="topology_suffix="//trim(topology_suffix2) + ! add energy and force args if needed + use_calc_energy=trim(calc_energy) + if (len_trim(calc_energy) == 0) then + use_calc_energy="energy" + do while (has_key(at%params, trim(use_calc_energy))) + use_calc_energy = "T"//trim(use_calc_energy) + end do + endif + extra_calc_args=trim(extra_calc_args)//" energy="//trim(use_calc_energy) + if (len_trim(calc_force) > 0) extra_calc_args=trim(extra_calc_args)//" force="//trim(calc_force) + ! form/break bonds for topology 2 + if (have_form_bond) extra_calc_args=trim(extra_calc_args)//" break_bond={"//form_bond(1:2)//"}" + if (have_break_bond) extra_calc_args=trim(extra_calc_args)//" form_bond={"//break_bond(1:2)//"}" + !calc with topology2 +call print("EVB2 ARGS_STR "//trim(mm_args_str)//" "//trim(extra_calc_args)) + call calc(this%pot1, at, args_str=trim(mm_args_str)//" "//trim(extra_calc_args), error=error) + PASS_ERROR(error) + + call get_param_value(at, trim(use_calc_energy), my_e_2, error=error) + PASS_ERROR_WITH_INFO("getting energy parameter '"//trim(use_calc_energy)//"' for topology 2", error) + my_e_2 = my_e_2 + diagonal_dE2 + if (len_trim(calc_energy) == 0) call remove_value(at%params, trim(use_calc_energy)) + if (len_trim(calc_force) > 0) my_f_2 = at_force_ptr + + call print("EVB energies my_e_1 " // my_e_1 // " " // my_e_2, PRINT_VERBOSE) + + !CALCULATE EVB ENERGY AND FORCES + + !distance or distance difference + if (no_coupling) then + call print("EVB no coupling", PRINT_VERBOSE) + !take the E, F of the resonance state with the smaller E + if (my_e_1 < my_e_2) then + if (len_trim(calc_energy) > 0) call set_param_value(at, trim(calc_energy), my_e_1) + if (len_trim(calc_force) > 0) at_force_ptr = my_f_1 + else + if (len_trim(calc_energy) > 0) call set_param_value(at, trim(calc_energy), my_e_2) + if (len_trim(calc_force) > 0) at_force_ptr = my_f_2 + endif + if (len_trim(calc_EVB_gap) > 0) then + gap=my_e_1-my_e_2 + call set_param_value(at, trim(calc_EVB_gap), gap) + call print("EVB gap " // gap, PRINT_VERBOSE) + if (len_trim(calc_force) > 0) then + call add_property(at, trim(calc_EVB_gap)//"_force", 0.0_dp, n_cols=3, ptr2=dgap_dr_ptr, error=error) + PASS_ERROR(error) + dgap_dr_ptr = my_f_1 - my_f_2 + !dgap_dr_ptr = ((my_e_1 - my_e_2)*(my_f_1 - my_f_2) - 4.0_dp*e_offdiag*de_offdiag_dr) / sqrt((my_e_1 - my_e_2)**2.0_dp + 4._dp*e_offdiag**2) + endif + endif + else + !calculate coupling terms -- rab is the bondlength or the sum of the bond length + rab = 0._dp + if (have_form_bond.and.have_break_bond) then + !the distance of the two atoms around the central one + atom1=form_bond(1) + atom3=form_bond(2) + if (break_bond(1)==atom1) then + atom1=break_bond(2) + elseif (break_bond(1)==atom3) then + atom3=break_bond(2) + elseif (break_bond(2)==atom1) then + atom1=break_bond(1) + elseif (break_bond(2)==atom3) then + atom3=break_bond(1) + else + call system_abort("The forming and breaking bonds are not around a common atom. This case has not yet been implemented.") + endif + rab = distance_min_image(at,atom1,atom3) + else + !use the only bond that breaks/forms + if (have_form_bond) then + rab = distance_min_image(at,form_bond(1),form_bond(2)) + elseif (have_break_bond) then + rab = distance_min_image(at,break_bond(1),break_bond(2)) + endif + endif + + + if (len_trim(calc_energy) > 0 .or. len_trim(calc_force) > 0) then + !original by Warshel + !e_offdiag = offdiagonal_A12 * exp(-offdiagonal_mu12 * abs(rab)) + !Letif's modification (the original is too strong and sucks the two Cl atoms together) + e_offdiag = offdiagonal_A12 * exp(-offdiagonal_mu12 * (rab - offdiagonal_r0) - offdiagonal_mu12_square * (rab - offdiagonal_r0)**2._dp) + call print("EVB e_offidag " // e_offdiag, PRINT_VERBOSE) + endif + + !energy + term1 = sqrt((my_e_1 - my_e_2)**2._dp + 4._dp*e_offdiag**2) + if (len_trim(calc_energy) > 0) then + e = 0.5_dp * (my_e_1 + my_e_2) - 0.5_dp * term1 + call set_param_value(at, trim(calc_energy), e) + call print("EVB coupled energy " // e, PRINT_VERBOSE) + endif + if (len_trim(calc_EVB_gap) > 0) then + gap=my_e_1-my_e_2 + call set_param_value(at, trim(calc_EVB_gap), gap) + call print("EVB gap " // gap, PRINT_VERBOSE) + endif + + !force + if (len_trim(calc_force) > 0) then + !force coupling term + de_offdiag_dr = 0._dp + if (have_form_bond.and.have_break_bond) then !breaking and forming bonds around the same atom + d_rab_dx = diff_min_image(at,atom1,atom3)/distance_min_image(at,atom1,atom3) + de_offdiag_dr(1:3,atom1) = de_offdiag_dr(1:3,atom1) + e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) + de_offdiag_dr(1:3,atom3) = de_offdiag_dr(1:3,atom3) - e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) + elseif (have_form_bond) then !only 1 forming bond + d_rab_dx = diff_min_image(at,form_bond(1),form_bond(2))/distance_min_image(at,form_bond(1),form_bond(2)) + de_offdiag_dr(1:3,form_bond(1)) = de_offdiag_dr(1:3,form_bond(1)) + e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) + de_offdiag_dr(1:3,form_bond(2)) = de_offdiag_dr(1:3,form_bond(2)) - e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) + elseif (have_break_bond) then !only 1 breaking bond + d_rab_dx = diff_min_image(at,break_bond(1),break_bond(2))/distance_min_image(at,break_bond(1),break_bond(2)) + de_offdiag_dr(1:3,break_bond(1)) = de_offdiag_dr(1:3,break_bond(1)) + e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) + de_offdiag_dr(1:3,break_bond(2)) = de_offdiag_dr(1:3,break_bond(2)) - e_offdiag * ( offdiagonal_mu12 + 2._dp * offdiagonal_mu12_square * (rab-offdiagonal_r0) ) * d_rab_dx(1:3) + endif + !force + at_force_ptr = 0.5_dp * (my_f_1 + my_f_2) - & + 0.5_dp * ((my_e_1 - my_e_2)*(my_f_1 - my_f_2) - 4.0_dp*e_offdiag*de_offdiag_dr) / sqrt((my_e_1 - my_e_2)**2.0_dp + 4._dp*e_offdiag**2) + if (len_trim(calc_EVB_gap) > 0) then + call add_property(at, trim(calc_EVB_gap)//"_force", 0.0_dp, n_cols=3, ptr2=dgap_dr_ptr, error=error) + PASS_ERROR(error) + dgap_dr_ptr = my_f_1 - my_f_2 + !dgap_dr_ptr = ((my_e_1 - my_e_2)*(my_f_1 - my_f_2) - 4.0_dp*e_offdiag*de_offdiag_dr) / sqrt((my_e_1 - my_e_2)**2.0_dp + 4._dp*e_offdiag**2) + endif + endif + endif + + !SAVE E,F IF NEEDED + +if (len_trim(calc_energy) > 0) then +call print("DEBUG EVB E1 " // my_e_1 // " E2 " // my_e_2 // " e " // e, PRINT_ALWAYS) +endif + if (save_energies .and. len_trim(calc_energy) > 0) then + call set_param_value(at,'EVB1_'//trim(calc_energy),my_e_1) + call set_param_value(at,'EVB2_'//trim(calc_energy),my_e_2) + endif + + if (save_forces .and. len_trim(calc_force) > 0) then + call add_property(at, 'EVB1_'//trim(calc_force), my_f_1) + call add_property(at, 'EVB2_'//trim(calc_force), my_f_2) + endif + + if (allocated(my_f_1)) deallocate(my_f_1) + if (allocated(my_f_2)) deallocate(my_f_2) + if (allocated(de_offdiag_dr)) deallocate(de_offdiag_dr) + + end subroutine Potential_EVB_Calc + + recursive function Potential_EVB_Cutoff(this) + type(Potential_EVB), intent(in) :: this + real(dp) :: potential_EVB_cutoff + + if(associated(this%pot1)) then + potential_EVB_cutoff = cutoff(this%pot1) + else + potential_EVB_cutoff = 0.0_dp + endif + + end function Potential_EVB_Cutoff + diff --git a/src/Potentials/Potential_ForceMixing_header.F90 b/src/Potentials/Potential_ForceMixing_header.F90 new file mode 100644 index 0000000000..56bb821ebb --- /dev/null +++ b/src/Potentials/Potential_ForceMixing_header.F90 @@ -0,0 +1,128 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Force Mixing header stuff to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + public :: Potential_FM + type Potential_FM + + type(Potential), pointer :: mmpot => null() + type(Potential), pointer :: qmpot => null() + type(MPI_context) :: mpi + + character(STRING_LENGTH) :: init_args_str + + logical :: minimise_mm !% Should classical degrees of freedom be minimised in each calc? + logical :: calc_weights !% Should weights be recalculated on each call to 'calc()' + character(STRING_LENGTH) :: method !% What fit method to use. Options are: + !% \begin{itemize} + !% \item 'lotf_adj_pot_svd' --- LOTF using SVD to optimised the Adj Pot + !% \item 'lotf_adj_pot_minim' --- LOTF using conjugate gradients to optimise the Adj Pot + !% \item 'conserve_momentum' --- divide the total force on QM region over the fit atoms to conserve momentum + !% \item 'force_mixing' --- force mixing with details depending on values of + !% 'buffer_hops', 'transtion_hops' and 'weight_interpolation' + !% \item 'force_mixing_abrupt' --- simply use QM forces on QM atoms and MM forces on MM atoms + !% (shorthand for 'method=force_mixing buffer_hops=0 transition_hops=0') + !% \item 'force_mixing_smooth' --- use QM forces in QM region, MM forces in MM region and + !% linearly interpolate in buffer region (shorthand for 'method=force_mixing weight_interpolation=hop_ramp') + !% \item 'force_mixing_super_smooth' --- as above, but weight forces on each atom by distance from + !% centre of mass of core region (shorthand for 'method=force_mixing weight_interpolation=distance_ramp') + !% \end{itemize} + !% Default method is 'conserve_momentum'. + character(STRING_LENGTH) :: run_suffix !% string to append to 'hybrid_mark' for actual hybrid_mark property + real(dp) :: mm_reweight !% Factor by which to reweight classical forces in embed zone + character(STRING_LENGTH) :: conserve_momentum_weight_method !% Weight method to use with 'method=conserve_momentum'. Should be one of + !% 'uniform' (default), 'mass', 'mass^2' or 'user', + !% with the last referring to a 'conserve_momentum_weight' + !% property in the Atoms object. + character(STRING_LENGTH) :: mm_args_str !% Args string to be passed to 'calc' method of 'mmpot' + character(STRING_LENGTH) :: qm_args_str !% Args string to be passed to 'calc' method of 'qmpot' + integer :: qm_little_clusters_buffer_hops !% Number of bond hops used for buffer region for qm calcs with little clusters + logical :: use_buffer_for_fitting !% Whether to generate the fit region or just use the buffer as the fit region. Only for method=conserve_momentum + integer :: fit_hops !% Number of bond hops used for fit region. Applies to 'conserve_momentum' and 'lotf_*' methods only. + logical :: add_cut_H_in_fitlist !% Whether to extend the fit region where a cut hydrogen is cut after the fitlist selection. + !% This will ensure to only include whole water molecules in the fitlist. + logical :: randomise_buffer !% If true, then positions of outer layer of buffer atoms will be randomised slightly. Default false. + logical :: save_forces !% If true, save MM, QM and total forces as properties in the Atoms object (default true) + + integer :: lotf_spring_hops !% Maximum lengths of springs for LOTF 'adj_pot_svd' and 'adj_pot_minim' methods (default is 2). + character(STRING_LENGTH) :: lotf_interp_order !% Interpolation order: should be one of 'linear', 'quadratic', or 'cubic'. Default is 'linear'. + logical :: lotf_interp_space !% Do spatial rather than temporal interpolation of adj pot parameters. Default is false. + logical :: lotf_nneighb_only !% If true (which is the default), uses nearest neigbour hopping to determine fit atoms + logical :: do_rescale_r !% If true rescale positions in QM region by r_scale_pot1 + logical :: do_rescale_E !% If true rescale energies in QM region by E_scale_pot1 + real(dp) :: r_scale_pot1 !% Rescale positions in QM region by this factor + real(dp) :: E_scale_pot1 !% Rescale energy in QM region by this factor + + character(STRING_LENGTH) :: minim_mm_method + real(dp) :: minim_mm_tol, minim_mm_eps_guess + integer :: minim_mm_max_steps + character(STRING_LENGTH) :: minim_mm_linminroutine + logical :: minim_mm_do_pos, minim_mm_do_lat + logical :: minim_mm_do_print + + character(STRING_LENGTH) :: minim_mm_args_str + + type(Dictionary) :: create_hybrid_weights_params !% extra arguments to pass create_hybrid_weights + + type(Potential), pointer :: relax_pot + type(Inoutput), pointer :: minim_inoutput_movie + type(CInoutput), pointer :: minim_cinoutput_movie + + type(Table) :: embedlist, fitlist + + end type Potential_FM + + interface Initialise + module procedure Potential_FM_initialise + end interface + + interface Finalise + module procedure Potential_FM_Finalise + end interface + + interface Print + module procedure Potential_FM_Print + end interface + + interface Cutoff + module procedure Potential_FM_Cutoff + end interface + + interface Calc + module procedure Potential_FM_Calc + end interface + + diff --git a/src/Potentials/Potential_ForceMixing_routines.F90 b/src/Potentials/Potential_ForceMixing_routines.F90 new file mode 100644 index 0000000000..6ed3ca51ea --- /dev/null +++ b/src/Potentials/Potential_ForceMixing_routines.F90 @@ -0,0 +1,783 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Force Mixing routines to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + recursive subroutine Potential_FM_initialise(this, args_str, mmpot, qmpot, reference_bulk, mpi, error) + type(Potential_FM), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(Potential), intent(inout), target :: qmpot + type(Potential), optional, intent(inout), target :: mmpot !% if mmpot is not given, a zero potential is assumed, this is most useful in LOTF mode + type(Atoms), optional, intent(inout) :: reference_bulk + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + logical :: minimise_bulk, do_tb_defaults, do_rescale_r, do_rescale_E + real(dp) :: dummy_E + + INIT_ERROR(error) + + call finalise(this) + + this%init_args_str = args_str + + call initialise(params) + call param_register(params, 'run_suffix', '', this%run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minimise_mm', 'F', this%minimise_mm, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'calc_weights', 'T', this%calc_weights, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'method', 'conserve_momentum', this%method, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'mm_reweight', '1.0', this%mm_reweight, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'conserve_momentum_weight_method', 'uniform', this%conserve_momentum_weight_method, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'mm_args_str', '', this%mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'qm_args_str', '', this%qm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'qm_little_clusters_buffer_hops', '3', this%qm_little_clusters_buffer_hops, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'use_buffer_for_fitting', 'F', this%use_buffer_for_fitting, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'fit_hops', '3', this%fit_hops, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'add_cut_H_in_fitlist', 'F', this%add_cut_H_in_fitlist, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'randomise_buffer', 'F', this%randomise_buffer, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'save_forces', 'T', this%save_forces, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_spring_hops', '2', this%lotf_spring_hops, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_interp_order', 'linear', this%lotf_interp_order, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_interp_space', 'F', this%lotf_interp_space, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_nneighb_only', 'T', this%lotf_nneighb_only, help_string="No help yet. This source file was $LastChangedBy$") + + ! Parameters for the MM minimisation + call param_register(params, 'minim_mm_method', 'cg', this%minim_mm_method, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_tol', '1e-6', this%minim_mm_tol, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_eps_guess', '1e-4', this%minim_mm_eps_guess, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_max_steps', '1000', this%minim_mm_max_steps, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_linminroutine', 'FAST_LINMIN', this%minim_mm_linminroutine, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_pos', 'T', this%minim_mm_do_pos, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_lat', 'F', this%minim_mm_do_lat, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_print', 'F', this%minim_mm_do_print, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_args_str', '', this%minim_mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + + ! Parameters for do_reference_bulk calculation, init time only + call param_register(params, "minimise_bulk", "F", minimise_bulk, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "do_tb_defaults", "F", do_tb_defaults, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'do_rescale_r', 'F', do_rescale_r, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'do_rescale_E', 'F', do_rescale_E, help_string="No help yet. This source file was $LastChangedBy$") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_FM_initialise args_str')) then + RAISE_ERROR('Potential_FM_initialise failed to parse args_str="'//trim(args_str)//'"', error) + endif + + call finalise(params) + + call initialise(this%create_hybrid_weights_params) + call read_string(this%create_hybrid_weights_params, args_str) + call remove_value(this%create_hybrid_weights_params, 'forcemixing') + call remove_value(this%create_hybrid_weights_params, 'init_args_pot1') + call remove_value(this%create_hybrid_weights_params, 'init_args_pot2') + call remove_value(this%create_hybrid_weights_params, 'run_suffix') + call remove_value(this%create_hybrid_weights_params, 'minimise_mm') + call remove_value(this%create_hybrid_weights_params, 'calc_weights') + call remove_value(this%create_hybrid_weights_params, 'method') + call remove_value(this%create_hybrid_weights_params, 'mm_reweight') + call remove_value(this%create_hybrid_weights_params, 'conserve_momentum_weight_method') + call remove_value(this%create_hybrid_weights_params, 'mm_args_str') + call remove_value(this%create_hybrid_weights_params, 'qm_args_str') + call remove_value(this%create_hybrid_weights_params, 'qm_little_clusters_buffer_hops') + call remove_value(this%create_hybrid_weights_params, 'use_buffer_for_fitting') + call remove_value(this%create_hybrid_weights_params, 'fit_hops') + call remove_value(this%create_hybrid_weights_params, 'add_cut_H_in_fitlist') + call remove_value(this%create_hybrid_weights_params, 'randomise_buffer') + call remove_value(this%create_hybrid_weights_params, 'save_forces') + call remove_value(this%create_hybrid_weights_params, 'lotf_spring_hops') + call remove_value(this%create_hybrid_weights_params, 'lotf_interp_order') + call remove_value(this%create_hybrid_weights_params, 'lotf_interp_space') + call remove_value(this%create_hybrid_weights_params, 'lotf_nneighb_only') + call remove_value(this%create_hybrid_weights_params, 'do_rescale_r') + call remove_value(this%create_hybrid_weights_params, 'do_rescale_E') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_method') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_tol') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_eps_guess') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_max_steps') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_linminroutine') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_pos') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_lat') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_print') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_args_str') + call remove_value(this%create_hybrid_weights_params, 'minimise_bulk') + call remove_value(this%create_hybrid_weights_params, 'do_tb_defaults') + + this%do_rescale_r = .false. + this%do_rescale_E = .false. + this%r_scale_pot1 = 1.0_dp + this%E_scale_pot1 = 1.0_dp + + if (do_rescale_r .or. do_rescale_E) then + + this%do_rescale_r = do_rescale_r + this%do_rescale_E = do_rescale_E + + if (.not. present(reference_bulk)) then + RAISE_ERROR("potential_forcemixing_initialise got do_rescale_r=T do_tb_defaults="//do_tb_defaults//" but reference_bulk is not present", error) + endif + + if (.not. present(mmpot)) then + RAISE_ERROR("potential_forcemixing_initialise got do_rescale_r=T but no mmpot was given", error) + endif + + call do_reference_bulk(reference_bulk, qmpot, mmpot, minimise_bulk, do_rescale_r, do_rescale_E, & + this%r_scale_pot1, this%E_scale_pot1, do_tb_defaults) + + if (this%r_scale_pot1 <= 0.0_dp) this%r_scale_pot1 = 1.0_dp + if (this%E_scale_pot1 <= 0.0_dp) this%E_scale_pot1 = 1.0_dp + if (do_rescale_r) call print ("Rescaling positions in QM potential by " // this%r_scale_pot1 // " to match lattice constants") + if (do_rescale_E) call print ("Rescaling energies in QM potential by " // this%E_scale_pot1 // " to match bulk moduli") + end if + + this%qmpot => qmpot + if(present(mmpot)) then + this%mmpot => mmpot + else + this%mmpot => null() + end if + + if (this%minimise_mm .and. present(mmpot)) then + ! call initialise(this%relax_pot, "Simple", mmpot) + this%relax_pot => mmpot + endif + + if (present(mpi)) this%mpi = mpi + + end subroutine Potential_FM_initialise + + + recursive subroutine Potential_FM_finalise(this) + type(Potential_FM), intent(inout) :: this + + nullify(this%mmpot) + nullify(this%qmpot) + call finalise(this%embedlist) + call finalise(this%fitlist) + call finalise(this%create_hybrid_weights_params) + + end subroutine Potential_FM_finalise + + + recursive subroutine Potential_FM_print(this, file) + type(Potential_FM), intent(inout) :: this + type(Inoutput), intent(inout), optional :: file + + if (current_verbosity() < PRINT_NORMAL) return + + call Print('Potential_FM:',file=file) + call Print(' minimise_mm='//this%minimise_mm,file=file) + call Print(' calc_weights='//this%calc_weights,file=file) + call Print(' method='//trim(this%method),file=file) + call Print(' mm_reweight='//this%mm_reweight,file=file) + call Print(' conserve_momentum_weight_method='//this%conserve_momentum_weight_method) + call Print(' mm_args_str='//trim(this%mm_args_str), file=file) + call Print(' qm_args_str='//trim(this%qm_args_str), file=file) + call Print(' qm_little_clusters_buffer_hops='//this%qm_little_clusters_buffer_hops, file=file) + call print(' use_buffer_for_fitting='//this%use_buffer_for_fitting) + call Print(' fit_hops='//this%fit_hops, file=file) + call print(' add_cut_H_in_fitlist='//this%add_cut_H_in_fitlist,file=file) + call Print(' randomise_buffer='//this%randomise_buffer, file=file) + call Print(' save_forces='//this%save_forces, file=file) + call Print(' lotf_spring_hops='//this%lotf_spring_hops, file=file) + call Print(' lotf_interp_order='//this%lotf_interp_order, file=file) + call Print(' lotf_interp_space='//this%lotf_interp_space, file=file) + call Print(' lotf_nneighb_only='//this%lotf_nneighb_only, file=file) + call Print(' r_scale_pot1='//this%r_scale_pot1, file=file) + call Print(' E_scale_pot1='//this%E_scale_pot1, file=file) + call Print('',file=file) + call Print(' minim_mm_method='//this%minim_mm_method,file=file) + call Print(' minim_mm_tol='//this%minim_mm_tol,file=file) + call Print(' minim_mm_eps_guess='//this%minim_mm_eps_guess,file=file) + call Print(' minim_mm_max_steps='//this%minim_mm_max_steps,file=file) + call Print(' minim_mm_linminroutine='//this%minim_mm_linminroutine,file=file) + call Print(' minim_mm_do_pos='//this%minim_mm_do_pos,file=file) + call Print(' minim_mm_do_lat='//this%minim_mm_do_lat,file=file) + call Print(' minim_mm_do_print='//this%minim_mm_do_print,file=file) + call Print(' minim_mm_args_str='//trim(this%minim_mm_args_str),file=file) + call Print('',file=file) + call Print(' create_hybrid_weights_params '//write_string(this%create_hybrid_weights_params), file=file) + call Print('',file=file) + if (associated(this%mmpot)) then + call Print('MM Potential:',file=file) + call Print(this%mmpot,file=file) + call Print('',file=file) + else + call print('MM potential not initialised') + end if + if (associated(this%qmpot)) then + call Print('QM potential:',file=file) + call Print(this%qmpot,file=file) + else + call print('QM potential not initialised') + end if + call Print('',file=file) + + end subroutine Potential_FM_print + + + recursive subroutine Potential_FM_calc(this, at, args_str, error) + type(Potential_FM), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + real(dp), pointer :: at_force_ptr(:,:) + + real(dp), allocatable, dimension(:,:) :: df, df_fit + real(dp), allocatable, dimension(:,:) :: f_mm, f_qm + real(dp), pointer, dimension(:,:) :: force_ptr + real(dp), pointer, dimension(:) :: weight_region1, conserve_momentum_weight + integer, pointer, dimension(:) :: hybrid, hybrid_mark + logical, pointer, dimension(:) :: hybrid_mask + integer :: i, j, k, n + type(Dictionary) :: params, calc_create_hybrid_weights_params + type(Connection) :: saved_connect + logical :: dummy + logical :: minimise_mm, calc_weights, save_forces, lotf_do_init, & + lotf_do_map, lotf_do_fit, lotf_do_interp, lotf_do_qm, lotf_interp_space, & + randomise_buffer, lotf_nneighb_only + character(STRING_LENGTH) :: method, mm_args_str, qm_args_str, conserve_momentum_weight_method, & + AP_method, lotf_interp_order, atom_mask + real(dp) :: mm_reweight, dV_dt, f_tot(3), w_tot, weight, lotf_interp, origin(3), extent(3,3) + integer :: fit_hops + + character(STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, run_suffix, qm_run_suffix, & + create_hybrid_weights_params_str + + integer :: weight_method, qm_little_clusters_buffer_hops, lotf_spring_hops + integer, parameter :: UNIFORM_WEIGHT=1, MASS_WEIGHT=2, MASS2_WEIGHT=3, USER_WEIGHT=4, CM_WEIGHT_REGION1=5 + integer, allocatable, dimension(:) :: embed, fit + !NB workaround for pgf90 bug (as of 9.0-1) + real(dp) :: t_norm + !NB end of workaround for pgf90 bug (as of 9.0-1) + + INIT_ERROR(error) + + ! Override parameters with those given in args_str + call initialise(params) + call param_register(params, "run_suffix", ''//this%run_suffix, run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "minimise_mm", ''//this%minimise_mm, minimise_mm, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "calc_weights", ''//this%calc_weights, calc_weights, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "method", this%method, method, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "mm_reweight", ''//this%mm_reweight, mm_reweight, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'conserve_momentum_weight_method', ''//this%conserve_momentum_weight_method, & + conserve_momentum_weight_method, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'mm_args_str', this%mm_args_str, mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'qm_args_str', this%qm_args_str, qm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'qm_little_clusters_buffer_hops', ''//this%qm_little_clusters_buffer_hops, qm_little_clusters_buffer_hops, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'use_buffer_for_fitting', ''//this%use_buffer_for_fitting, this%use_buffer_for_fitting, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'fit_hops', ''//this%fit_hops, fit_hops, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'add_cut_H_in_fitlist', ''//this%add_cut_H_in_fitlist,this%add_cut_H_in_fitlist, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'randomise_buffer', ''//this%randomise_buffer, randomise_buffer, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'save_forces', ''//this%save_forces, save_forces, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_spring_hops', ''//this%lotf_spring_hops, lotf_spring_hops, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_interp_order', this%lotf_interp_order, lotf_interp_order, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_interp_space', ''//this%lotf_interp_space, lotf_interp_space, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_nneighb_only', ''//this%lotf_nneighb_only, lotf_nneighb_only, help_string="No help yet. This source file was $LastChangedBy$") + + ! override args_str parameters for the MM minimisation + call param_register(params, 'minim_mm_method', 'cg', this%minim_mm_method, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_tol', '1e-6', this%minim_mm_tol, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_eps_guess', '1e-4', this%minim_mm_eps_guess, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_max_steps', '1000', this%minim_mm_max_steps, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_linminroutine', 'FAST_LINMIN', this%minim_mm_linminroutine, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_pos', 'T', this%minim_mm_do_pos, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_lat', 'F', this%minim_mm_do_lat, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_print', 'F', this%minim_mm_do_print, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_args_str', '', this%minim_mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + + ! lotf parameters, calc time only + call param_register(params, 'lotf_do_init', 'T', lotf_do_init, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_do_map', 'F', lotf_do_map, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_do_qm', 'T', lotf_do_qm, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_do_fit', 'T', lotf_do_fit, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_do_interp', 'F', lotf_do_interp, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'lotf_interp', '0.0', lotf_interp, help_string="No help yet. This source file was $LastChangedBy$") + + call param_register(params, 'energy', '', calc_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'force', '', calc_force, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'virial', '', calc_virial, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'local_energy', '', calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'local_virial', '', calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_FM_Calc args_str') ) then + RAISE_ERROR("Potential_FM_calc failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if (current_verbosity().ge.PRINT_NERD) call print(this) + + call initialise(calc_create_hybrid_weights_params) + call read_string(calc_create_hybrid_weights_params, write_string(this%create_hybrid_weights_params)) + call read_string(calc_create_hybrid_weights_params, args_str, append=.true.) + + call remove_value(calc_create_hybrid_weights_params, 'minimise_mm') + call remove_value(calc_create_hybrid_weights_params, 'calc_weights') + call remove_value(calc_create_hybrid_weights_params, 'method') + call remove_value(calc_create_hybrid_weights_params, 'mm_reweight') + call remove_value(calc_create_hybrid_weights_params, 'conserve_momentum_weight_method') + call remove_value(calc_create_hybrid_weights_params, 'mm_args_str') + call remove_value(calc_create_hybrid_weights_params, 'qm_args_str') + call remove_value(calc_create_hybrid_weights_params, 'qm_little_clusters_buffer_hops') + call remove_value(calc_create_hybrid_weights_params, 'use_buffer_for_fitting') + call remove_value(calc_create_hybrid_weights_params, 'fit_hops') + call remove_value(calc_create_hybrid_weights_params, 'add_cut_H_in_fitlist') + call remove_value(calc_create_hybrid_weights_params, 'randomise_buffer') + call remove_value(calc_create_hybrid_weights_params, 'save_forces') + call remove_value(calc_create_hybrid_weights_params, 'lotf_spring_hops') + call remove_value(calc_create_hybrid_weights_params, 'lotf_interp_order') + call remove_value(calc_create_hybrid_weights_params, 'lotf_interp_space') + call remove_value(calc_create_hybrid_weights_params, 'lotf_nneighb_only') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_method') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_tol') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_eps_guess') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_max_steps') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_linminroutine') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_do_pos') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_do_lat') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_do_print') + call remove_value(calc_create_hybrid_weights_params, 'minim_mm_args_str') + call remove_value(calc_create_hybrid_weights_params, 'lotf_do_init') + call remove_value(calc_create_hybrid_weights_params, 'lotf_do_map') + call remove_value(calc_create_hybrid_weights_params, 'lotf_do_qm') + call remove_value(calc_create_hybrid_weights_params, 'lotf_do_fit') + call remove_value(calc_create_hybrid_weights_params, 'lotf_do_interp') + call remove_value(calc_create_hybrid_weights_params, 'lotf_interp') + + ! Apply + if (trim(method) == 'force_mixing_abrupt') then + call set_value(calc_create_hybrid_weights_params, 'buffer_hops', 0) + call set_value(calc_create_hybrid_weights_params, 'transition_hops', 0) + call set_value(calc_create_hybrid_weights_params, 'weight_interpolation', 'hop_ramp') + else if (trim(method) == 'force_mixing_smooth') then + call set_value(calc_create_hybrid_weights_params, 'weight_interpolation', 'hop_ramp') + else if (trim(method) == 'force_mixing_super_smooth') then + call set_value(calc_create_hybrid_weights_params, 'weight_interpolation', 'distance_ramp') + end if + + if (len_trim(calc_energy) > 0 .or. len_trim(calc_virial) > 0 .or. len_trim(calc_local_energy) > 0 .or. len_trim(calc_local_virial) > 0 .or. & + len_trim(calc_force) <= 0) then + RAISE_ERROR('Potential_FM_calc: supports only forces, not energy, virial, local_energy or local_virial', error) + endif + + allocate(f_mm(3,at%N),f_qm(3,at%N)) + f_mm = 0.0_dp + f_qm = 0.0_dp + call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) + PASS_ERROR(error) + + if (calc_weights) then + + call system_timer('calc_weights') + + if (.not. has_property(at, 'hybrid_mark'//trim(run_suffix))) & + call add_property(at, 'hybrid_mark'//trim(run_suffix), HYBRID_NO_MARK) + + if (.not. assign_pointer(at, "hybrid"//trim(run_suffix), hybrid)) then + RAISE_ERROR("Potential_FM_calc: at doesn't have hybrid"//trim(run_suffix)//" property and calc_weights was specified", error) + endif + + if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then + RAISE_ERROR('Potential_FM_Calc: hybrid_mark'//trim(run_suffix)//' property missing', error) + endif + + if(any((hybrid.ne.HYBRID_ACTIVE_MARK).and.(hybrid.ne.HYBRID_NO_MARK))) then + RAISE_ERROR('Potential_FM_calc: hybrid property must contain only 1 (for QM) and 0 (anywhere else).', error) + endif + !update only the active region, the buffer region will be updated in create_hybrid_weights + + ! if we have a hysteretic buffer, set marks to allow previously active atoms to become buffer atoms + ! if we don't, then this is irrelevant anyway + ! create_hybrid_weights will then set the buffer marks + where (hybrid_mark == HYBRID_ACTIVE_MARK) hybrid_mark = HYBRID_BUFFER_MARK + where (hybrid == HYBRID_ACTIVE_MARK) hybrid_mark = HYBRID_ACTIVE_MARK + + call Print('Potential_FM_calc: got '//count(hybrid /= 0)//' active atoms.', PRINT_VERBOSE) + + if (count(hybrid_mark == HYBRID_ACTIVE_MARK) == 0) then + RAISE_ERROR('Potential_ForceMixing_Calc: zero active atoms and calc_weights was specified', error) + endif + + create_hybrid_weights_params_str = write_string(calc_create_hybrid_weights_params) + call finalise(calc_create_hybrid_weights_params) + call create_hybrid_weights(at, create_hybrid_weights_params_str) + call set_value(at%params, 'create_hybrid_weights_params', create_hybrid_weights_params_str) ! save how we did the calc_weights call + + call system_timer('calc_weights') + + end if + + if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then + RAISE_ERROR('Potential_FM_Calc: hybrid_mark'//trim(run_suffix)//' property missing', error) + endif + + ! Do the MM minimisation, freezing the atoms marked as active + if (minimise_mm) then + call do_minimise_mm(this%relax_pot, at, this%minim_mm_method, this%minim_mm_tol, this%minim_mm_max_steps, & + this%minim_mm_linminroutine, this%minim_mm_do_pos, this%minim_mm_do_lat, this%minim_mm_do_print, & + this%minim_mm_args_str, this%minim_mm_eps_guess, this%minim_inoutput_movie, & + this%minim_cinoutput_movie, find(hybrid_mark == HYBRID_ACTIVE_MARK)) + endif + + ! Do the classical calculation + if(associated(this%mmpot)) then + mm_args_str=trim(mm_args_str)//' force='//trim(calc_force) + call calc(this%mmpot, at, args_str=mm_args_str, error=error) + f_mm = at_force_ptr + else + f_mm = 0.0_dp + end if + + ! Save MM forces if requested to be saved + if (save_forces) call add_property(at, 'FM_MM_'//trim(calc_force), f_mm, overwrite=.true.) + + !Potential calc could have added properties e.g. old_cluster_mark + if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then + RAISE_ERROR('Potential_FM_Calc: hybrid_mark property missing', error) + endif + if (.not. any(hybrid_mark /= HYBRID_NO_MARK)) then + at_force_ptr = f_mm + return + end if + + call print('Potential_FM_Calc: reweighting classical forces by '//mm_reweight//' in active region', PRINT_VERBOSE) + do i=1,at%N + if (hybrid_mark(i) /= HYBRID_ACTIVE_MARK) cycle + f_mm(:,i) = mm_reweight*f_mm(:,i) + end do + + !Fitlist construction has been moved to after the cluster carving in case the cluster is used as the fitlist. + + ! Do the expensive QM calculation. For the LOTF methods we only do this if lotf_do_qm is true + if (method(1:4) /= 'lotf' .or. (method(1:4) == 'lotf' .and. lotf_do_qm)) then + + call initialise(params) + call read_string(params, qm_args_str) + + call set_value(params, 'force='//trim(calc_force)) + + !! TODO - possibly want to set more default options in the qm_args_str here + if (.not. has_key(params, 'buffer_hops')) & + call set_value(params, 'buffer_hops', qm_little_clusters_buffer_hops) + + call set_value(params, 'randomise_buffer', randomise_buffer) + call set_value(params, 'calc_weights', calc_weights) ! Let QM know if we changed the weights + + if (get_value(params, 'run_suffix', qm_run_suffix)) then + ! if args_str and qm_args_str both defin a run_suffix, then assert that they match + if (trim(run_suffix) /= trim(qm_run_suffix)) then + RAISE_ERROR('Potential_FM_calc: run_suffix args_str ('//trim(run_suffix)//') does not match qm_args_str value ('//trim(qm_run_suffix)//')', error) + end if + else + ! copy run_suffix from our args_str to qm_args_str + call set_value(params, 'run_suffix', run_suffix) + end if + + if (this%do_rescale_r) call set_value(params, 'r_scale', this%r_scale_pot1) + if (this%do_rescale_E) call set_value(params, 'E_scale', this%E_scale_pot1) + + if (has_key(params, 'atom_mask')) then + if (.not. get_value(params, 'atom_mask', atom_mask)) then + RAISE_ERROR('Potential_FM_Calc: atom_mask present in qm_args_str, but not of type string', error) + end if + call add_property(at, 'hybrid_mask', .false., overwrite=.true., ptr=hybrid_mask) + if (trim(atom_mask) == "active") then + ! Mark the active atoms + hybrid_mask = hybrid_mark == HYBRID_ACTIVE_MARK + else if (trim(atom_mask) == "active_plus_buffer") then + ! Mark active and buffer atoms + hybrid_mask = hybrid_mark /= HYBRID_NO_MARK + else if (trim(atom_mask) == "active_plus_cutoff") then + ! Mark active atom and their neighbours (within QM pot cutoff) + hybrid_mask = hybrid_mark == HYBRID_ACTIVE_MARK + do i=1,at%n + if (hybrid_mark(i) == HYBRID_ACTIVE_MARK) then + do n=1,n_neighbours(at, i) + j = neighbour(at, i, n, max_dist=cutoff(this%qmpot)) + if (j == 0) cycle + hybrid_mask(j) = .true. + end do + end if + end do + else + RAISE_ERROR('Potential_FM_Calc: unexpected atom_mask value "'//trim(atom_mask)//'"', error) + end if + call print('Potential_FM_Calc: got atom_mask with '//count(hybrid_mark == HYBRID_ACTIVE_MARK)//' marked atoms.', PRINT_VERBOSE) + call set_value(params, 'atom_mask_name', 'hybrid_mask') + end if + + qm_args_str = write_string(params, real_format='f16.8') + call finalise(params) + + ! Do the QM. If qm_args_str contatins 'single_cluster' or 'little_clusters' options + ! then potential calc() will do cluster carving. If it contains 'atom_mask_name' we + ! don't make a cluster, but only compute forces on marked atoms. + call calc(this%qmpot, at, args_str=qm_args_str, error=error) + f_qm = at_force_ptr + + ! Save QM forces if requested to be saved + if (save_forces) call add_property(at, 'FM_QM_'//trim(calc_force), f_qm, overwrite=.true.) + + end if + + !Fitlist construction has been moved here. + + ! Make embed and fit lists if we need them + if (method(1:4) == 'lotf' .or. trim(method) == 'conserve_momentum') then + + if ((method(1:4) == 'lotf' .and. lotf_do_init) .or. trim(method) == 'conserve_momentum') then + if (this%use_buffer_for_fitting) then + if (trim(method).ne.'conserve_momentum') then + RAISE_ERROR('use_buffer_for_fitting=T only works for method=conserve_momentum', error) + endif + !create lists according to hybrid_mark property, use BUFFER/TRANS/BUFFER_OUTER_LAYER as fitlist + call create_embed_and_fit_lists_from_cluster_mark(at,this%embedlist,this%fitlist, mark_name='hybrid_mark'//trim(run_suffix)) +! if (this%add_cut_H_in_fitlist) then !no cut H on the fitlist's border +! call add_cut_hydrogens(at,this%fitlist) +! endif + else + call create_embed_and_fit_lists(at, fit_hops, this%embedlist, this%fitlist, & + cluster_hopping_nneighb_only=lotf_nneighb_only, min_images_only=.true., mark_name='hybrid_mark'//trim(run_suffix)) + if (this%add_cut_H_in_fitlist) then !no cut H on the fitlist's border + call add_cut_hydrogens(at,this%fitlist) + endif + + end if + endif + + ! Make some convenient arrays of embed and fit list + allocate(embed(this%embedlist%N)) + embed = int_part(this%embedlist,1) + allocate(fit(this%fitlist%N)) + fit = int_part(this%fitlist,1) + end if + + if (method(1:4) == 'lotf') then + + if (trim(method) == 'lotf_adj_pot_svd' .or. trim(method) == 'lotf_adj_pot_minim') then + + if (trim(method) == 'lotf_adj_pot_svd') then + AP_method = 'SVD' + else + AP_method = 'minim' + end if + + ! Optimise the adjustable potential + allocate(df(3,this%fitlist%N)) + df = 0.0_dp + df(:,1:this%embedlist%N) = f_qm(:,embed) - f_mm(:,embed) + + if (lotf_do_init) then + call print('Initialising adjustable potential with map='//lotf_do_map, PRINT_VERBOSE) + call adjustable_potential_init(at, this%fitlist, directionN=this%embedlist%N, & + method=AP_method, nnonly=lotf_nneighb_only, & + spring_hops=lotf_spring_hops, map=lotf_do_map) + end if + + if (lotf_do_qm .and. lotf_do_fit) then + call system_timer('lotf_adj_pot_fit') + call adjustable_potential_optimise(at, df, method=AP_method) + call system_timer('lotf_adj_pot_fit') + end if + + if (lotf_do_interp) then + call adjustable_potential_force(at, df, interp=lotf_interp, & + interp_space=lotf_interp_space, interp_order=lotf_interp_order,power=dV_dt) + else + call adjustable_potential_force(at, df, power=dV_dt) + end if + + at_force_ptr = f_mm ! Start with classical forces + at_force_ptr(:,fit) = at_force_ptr(:,fit) + df ! Add correction in fit region + + deallocate(df) + + else if (trim(this%method) == 'lotf_adj_pot_sw') then + + RAISE_ERROR('lotf_adj_pot_sw no longer supported.', error) + + ! old style adj pot: SW with variable parameters + +!!$ allocate(df(3,this%fitlist%N)) +!!$ +!!$ ! old style method: we fit to QM force in embed region and MM force in outer fit region, +!!$ ! not to force difference +!!$ df = f_mm(:,fit) +!!$ df(:,1:this%embedlist%N) = f_qm(:,embed) +!!$ +!!$ if (lotf_do_init) & +!!$ call adjustable_potential_sw_init(at, this%fitlist) +!!$ +!!$ if (lotf_do_qm .and. lotf_do_fit) & +!!$ call adjustable_potential_sw_optimise(at, df) +!!$ +!!$ if (lotf_do_interp) then +!!$ call adjustable_potential_force(at, df, interp=lotf_interp) +!!$ else +!!$ call adjustable_potential_force(at, df) +!!$ end if +!!$ +!!$ f = f_mm ! start with classical forces +!!$ f(:,fit) = df ! replace with fitted force +!!$ +!!$ deallocate(df) + + end if + + else if (trim(method) == 'conserve_momentum') then + + call verbosity_push(PRINT_NORMAL) + + call print('Conserving momentum using fit list with '//this%fitlist%N//' atoms', PRINT_VERBOSE) + + select case(conserve_momentum_weight_method) + case ('uniform') + weight_method = UNIFORM_WEIGHT + call print('conserve_momentum: uniform weighting', PRINT_VERBOSE) + case ('mass') + weight_method = MASS_WEIGHT + call print('conserve_momentum: using mass weighting', PRINT_VERBOSE) + case ('mass^2') + weight_method = MASS2_WEIGHT + call print('conserve_momentum: using mass squared weighting', PRINT_VERBOSE) + case ('user') + weight_method = USER_WEIGHT + call print('conserve_momentum: using user defined weighting', PRINT_VERBOSE) + case ('weight_region1') + weight_method = CM_WEIGHT_REGION1 + call print('conserve_momentum: using user defined weighting', PRINT_VERBOSE) + case default + RAISE_ERROR('Potential_FM_Calc: unknown conserve_momentum_weight method: '//trim(conserve_momentum_weight_method), error) + end select + + if (weight_method == USER_WEIGHT) then + if (.not. assign_pointer(at, 'conserve_momentum_weight', conserve_momentum_weight)) then + RAISE_ERROR('Potential_FM_Calc: missing property conserve_momentum_weight', error) + endif + end if + + allocate(df(3,at%N),df_fit(3,this%fitlist%N)) + + if (.not. assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1)) then + RAISE_ERROR('Potential_FM_Calc: missing weight_region1 property - try setting calc_weights=T in args_str', error) + endif + + ! Straight forward force mixing using weight_region1 created by create_hybrid_weights() + do i=1,at%N + df(:,i) = (weight_region1(i)*f_qm(:,i) + (1.0_dp - weight_region1(i))*f_mm(:,i)) - f_mm(:,i) + end do + + f_tot = sum(df,dim=2) + call print('conserve_momentum: norm(sum of target forces) = '//round(norm(f_tot),15), PRINT_VERBOSE) + + w_tot = 0.0_dp + do i = 1, this%fitlist%N + select case(weight_method) + case(UNIFORM_WEIGHT) + weight = 1.0_dp + case(MASS_WEIGHT) + if (.not. associated(at%mass)) then + RAISE_ERROR('Potential_FM_Calc MASS_WEIGHT, but at%mass is not associated', error) + endif + weight = at%mass(fit(i)) + case(MASS2_WEIGHT) + if (.not. associated(at%mass)) then + RAISE_ERROR('Potential_FM_Calc MASS2_WEIGHT, but at%mass is not associated', error) + endif + weight = at%mass(fit(i))*at%mass(fit(i)) + case(USER_WEIGHT) + weight = conserve_momentum_weight(fit(i)) + case(CM_WEIGHT_REGION1) + weight = weight_region1(fit(i)) + end select + df_fit(:,i) = -weight * f_tot + w_tot = w_tot + weight + end do + df_fit = (df_fit / w_tot) + + !NB workaround for pgf90 bug (as of 9.0-1) + t_norm = norm(sum(df_fit,dim=2));call print('conserve_momentum: norm(sum of fit forces) = '//round(t_norm, 15), PRINT_VERBOSE) + !NB end of workaround for pgf90 bug (as of 9.0-1) + + ! Final forces are classical forces plus corrected QM forces + at_force_ptr = f_mm + df + at_force_ptr(:,fit) = at_force_ptr(:,fit) + df_fit + + call verbosity_pop() + + deallocate(df, df_fit) + + else if (method(1:12) == 'force_mixing') then + + if (.not. assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1)) then + RAISE_ERROR('Potential_FM_Calc: missing weight_region1 property - try setting calc_weights=T in args_str', error) + endif + + ! Straight forward force mixing using weight_region1 created by create_hybrid_weights() + do i=1,at%N + at_force_ptr(:,i) = weight_region1(i)*f_qm(:,i) + (1.0_dp - weight_region1(i))*f_mm(:,i) + end do + + else + RAISE_ERROR('Potential_FM_calc: unknown method '//trim(method), error) + end if + + deallocate(f_mm,f_qm) + + if (allocated(embed)) deallocate(embed) + if (allocated(fit)) deallocate(fit) + + end subroutine Potential_FM_calc + + + recursive function Potential_FM_cutoff(this) + type(Potential_FM), intent(in) :: this + real(dp) :: potential_fm_cutoff + + ! Return larger of QM and MM cutoffs + if(associated(this%mmpot) .and. associated(this%qmpot)) then + potential_fm_cutoff = max(cutoff(this%mmpot), cutoff(this%qmpot)) + else if(associated(this%qmpot)) then + potential_fm_cutoff = cutoff(this%qmpot) + else if(associated(this%mmpot)) then + potential_fm_cutoff = cutoff(this%mmpot) + else + potential_fm_cutoff = 0.0_dp + endif + + end function Potential_FM_cutoff + + diff --git a/src/Potentials/Potential_Hybrid_utils.F90 b/src/Potentials/Potential_Hybrid_utils.F90 new file mode 100644 index 0000000000..7237c9f5d5 --- /dev/null +++ b/src/Potentials/Potential_Hybrid_utils.F90 @@ -0,0 +1,284 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X misc routines to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + subroutine linear_square(x,afunc) + real(dp) :: x, afunc(:) + + afunc(1) = x*x + afunc(2) = x + afunc(3) = 1 + + end subroutine linear_square + + subroutine potential_bulk_modulus(pot, at, B, V0, minimise_bulk, eps, args_str) + type(Potential), intent(inout) :: pot + type(Atoms), intent(in) :: at + real(dp), intent(out) :: V0, B + logical, intent(in), optional :: minimise_bulk + real(dp), intent(in), optional :: eps + character(len=*), intent(in), optional :: args_str + + integer :: i,j, steps + real(dp) :: E(11), V(11), a(3), chisq, use_eps + type(Atoms) :: at0, at1 + logical :: do_minimise_bulk + + do_minimise_bulk = optional_default(.true., minimise_bulk) + use_eps = optional_default(2.0e-3_dp, eps) + + at0 = at + if (do_minimise_bulk) then + ! Minimise initial cell + call verbosity_push_decrement() + steps = minim(pot, at0, 'cg', 1e-6_dp, 100, & + 'LINMIN_DERIV', do_pos=.true.,do_lat=.true., do_print=.false., args_str=args_str) + call verbosity_pop() + end if + + do i = 1, 11 + at1 = at0 + call set_lattice(at1, at1%lattice*(1.0_dp - real(i-6,dp)*use_eps), scale_positions=.true.) + V(i) = cell_volume(at1) + call set_cutoff (at1, cutoff(pot)+1.0_dp) + call calc_connect(at1) + + if (do_minimise_bulk) then + ! Minimise positions with lattice fixed + call verbosity_push_decrement() + steps = minim(pot, at1, 'cg', 1e-6_dp, 100, & + 'LINMIN_DERIV', do_pos=.true.,do_lat=.false., do_print=.false., args_str=args_str) + call verbosity_pop() + end if + + call calc(pot, at1, energy=E(i), args_str=args_str) + call print('bulk_modulus V='//V(i)//' E='//E(i), PRINT_NERD) + end do + + call least_squares(V, E, (/ ( 1.0_dp, j=1,11) /), & + a, chisq, linear_square) + + V0 = -a(2)/(2*a(1)) + B = -1.0*a(2)*EV_A3_IN_GPA + + end subroutine potential_bulk_modulus + +!% We define a potential energy function $E(r)$, and then a scaled function +!% \[ +!% E\'(r) = \beta E(\alpha r) +!% \] +!% The corresponding force in the original coordinate system is +!% \[ +!% F\'(r) = -\frac{\partial E\'}{\partial r} = -\beta \alpha \frac{\partial E\'}{\partial r} = \beta \alpha\, F +!% \] +!% The equilibrium lattice constant changes from $a_0$ to $a_0\'$ and the equilbrium cell volume changes from $V_0$ to $V_0\'$ according to +!% \begin{eqnarray*} +!% a_0' & = & \frac{a_0}{\alpha} \\ V_0' & = & \frac{V_0}{\alpha^3} +!% \end{eqnarray*} +!% The scaled bulk modulus is +!% \begin{eqnarray*} +!% B' & = & V \frac{\partial^2 E'}{\partial V^2} \\ & = & \beta \alpha^3 V \frac{\partial^2E}{\partial V^2} \\ & = & \beta \alpha^3 B +!% \end{eqnarray*} +!% Thus if we want to match a target volume $V_0\'$ and bulk modulus $B\'$ we should use +!% \begin{eqnarray*} +!% \alpha & = & \left( \frac{V_0}{V_0'} \right)^\frac{1}{3} = \frac{a_0}{a_0'} \\ \beta & = & \frac{B'}{B \alpha^3} +!% \end{eqnarray*} +!% where $a_0$ and $a_0\'$ are the lattice constants before and after rescaling. +!% +!% For QM/MM force mixing, where we label the QM potential as region 1 and the classical (MM) potential +!% as region 2, the aim is to rescale the QM potential to match the MM lattice constant $a_2$ and bulk +!% modulus $B_2$, so we have +!% \begin{eqnarray*} +!% \alpha & = & \frac{a_1}{a_2} \\ \beta & = & \frac{B_2}{B_1 \alpha^3} +!% \end{eqnarray*} +!% where $a_1$ and $B_1$ are the unmodified QM lattice constant and bulk modulus, respectively. +!% Note that this is equivalent to rescaling the MM \emph{positions} to match the QM lattice constant. + + subroutine do_reference_bulk(reference_bulk, region1_pot, region2_pot, minimise_bulk, do_rescale_r, do_rescale_E, & + r_scale_pot1, E_scale_pot1, do_tb_defaults) + type(Atoms), intent(inout) :: reference_bulk + type(Potential), intent(inout), target :: region1_pot, region2_pot + logical, intent(in) :: minimise_bulk, do_rescale_r, do_rescale_E, do_tb_defaults + real(dp), intent(inout) :: r_scale_pot1, E_scale_pot1 + + real(dp) :: e_bulk, B_region2, B_region1, vol + + type(Atoms) :: bulk_region1, bulk_region2 + integer :: it + + call verbosity_push_decrement(PRINT_NERD) + call print("potential_local_e_mix_initialise called with reference_bulk") + call write(reference_bulk, "stdout") + call verbosity_pop() + + ! set up region1 stuff + bulk_region1 = reference_bulk + call set_cutoff(bulk_region1, cutoff(region1_pot)+0.5_dp) + call calc_connect(bulk_region1) +! call initialise(region1_pot, "Simple", region1_pot) + if (minimise_bulk) then + call print("MINIMISING bulk in region1 potential", PRINT_VERBOSE) + call verbosity_push_decrement() + it = minim(region1_pot, at=bulk_region1, method='cg', convergence_tol=0.001_dp, max_steps=100, linminroutine='NR_LINMIN', & + do_print = .false., do_lat = .true., args_str='solver=DIAG SCF_NONE') + call verbosity_pop() + endif + call calc(region1_pot, bulk_region1, energy=e_bulk, args_str='solver=DIAG SCF_NONE') + call print("region1 Potential energy " // e_bulk) + call print("region1 Potential lattice") + call print(bulk_region1%lattice) + +#ifdef HAVE_TB + if (do_tb_defaults .and. associated(region1_pot%simple%tb)) then + region1_pot%simple%tb%tbsys%tbmodel%default_fermi_E = region1_pot%simple%tb%fermi_E + region1_pot%simple%tb%tbsys%tbmodel%has_default_fermi_E = .true. + region1_pot%simple%tb%tbsys%tbmodel%default_band_width = (region1_pot%simple%tb%fermi_E - minval(TB_evals(region1_pot%simple%tb)))*1.2_dp + region1_pot%simple%tb%tbsys%tbmodel%has_default_band_width = .true. + region1_pot%simple%tb%tbsys%tbmodel%default_fermi_T = 0.2_dp + region1_pot%simple%tb%tbsys%tbmodel%has_default_fermi_T = .true. + + region1_pot%simple%tb%tbsys%scf%conv_tol = 1e-8_dp + endif +#endif + + ! set up region2 stuff + bulk_region2 = reference_bulk +! call initialise(region2_pot, "Simple", region2_pot) + call set_cutoff(bulk_region2, cutoff(region2_pot)+0.5_dp) + call calc_connect(bulk_region2) + if (minimise_bulk) then + call print("MINIMISING bulk in region2 potential", PRINT_VERBOSE) + call verbosity_push_decrement() + it = minim(region2_pot, at=bulk_region2, method='cg', convergence_tol=0.001_dp, max_steps=100, linminroutine='NR_LINMIN', & + do_print = .false., do_lat = .true.) + call verbosity_pop() + end if + call calc(region2_pot, bulk_region2, energy=e_bulk) + call print("region2 Potential Bulk energy = " // e_bulk) + call print("region2 Potential lattice") + call print(bulk_region2%lattice) + +#ifdef HAVE_TB + if (do_tb_defaults .and. associated(region2_pot%simple%tb)) then + region2_pot%simple%tb%tbsys%tbmodel%default_fermi_E = region2_pot%simple%tb%fermi_E + region2_pot%simple%tb%tbsys%tbmodel%has_default_fermi_E = .true. + region2_pot%simple%tb%tbsys%tbmodel%default_band_width = (region2_pot%simple%tb%fermi_E - minval(TB_evals(region2_pot%simple%tb)))*1.2_dp + region2_pot%simple%tb%tbsys%tbmodel%has_default_band_width = .true. + region2_pot%simple%tb%tbsys%tbmodel%default_fermi_T = 0.2_dp + region2_pot%simple%tb%tbsys%tbmodel%has_default_fermi_T = .true. + + region2_pot%simple%tb%tbsys%scf%conv_tol = 1e-8_dp + endif +#endif + r_scale_pot1 = 1.0_dp + if (do_rescale_r) then + ! compute scale, assuming that lattices are only off by a uniform scale + r_scale_pot1 = maxval(abs(bulk_region1%lattice(:,1)))/maxval(abs(bulk_region2%lattice(:,1))) + endif + + E_scale_pot1 = 1.0_dp + if (do_rescale_E) then + call bulk_modulus(region2_pot, bulk_region2, B_region2, vol, minimise_bulk) + call bulk_modulus(region1_pot, bulk_region1, B_region1, vol, minimise_bulk) + + call print('Bulk modulus in region 1 = '//B_region1//' GPa') + call print('Bulk modulus in region 2 = '//B_region2//' GPa') + + E_scale_pot1 = B_region2/(B_region1*r_scale_pot1**3) + end if + + call finalise(bulk_region1) + call finalise(bulk_region2) + end subroutine do_reference_bulk + + subroutine do_minimise_mm(relax_pot, at, minim_mm_method, minim_mm_tol, minim_mm_max_steps, & + minim_mm_linminroutine, minim_mm_do_pos, minim_mm_do_lat, minim_mm_do_print, & + minim_mm_args_str, minim_mm_eps_guess, minim_inoutput_movie, & + minim_cinoutput_movie, & + constrained_list) + type(Potential), intent(inout) :: relax_pot + type(Atoms), intent(inout) :: at + character(len=*), intent(in) :: minim_mm_method + real(dp), intent(in) :: minim_mm_tol + integer, intent(in) :: minim_mm_max_steps + character(len=*), intent(in) :: minim_mm_linminroutine + logical, intent(in) :: minim_mm_do_pos, minim_mm_do_lat, minim_mm_do_print + character(len=*), intent(in) :: minim_mm_args_str + real(dp), intent(in) :: minim_mm_eps_guess + type(Inoutput), intent(inout) :: minim_inoutput_movie + type(CInoutput), intent(inout) :: minim_cinoutput_movie + integer, intent(in) :: constrained_list(:) + + integer, pointer :: fixed_pot(:) + integer :: mm_steps + + if (.not. assign_pointer(at, "fixed_pot", fixed_pot)) then + call add_property(at, "fixed_pot", 0) + if (.not. assign_pointer(at, "fixed_pot", fixed_pot)) & + call system_abort("do_minimise_mm failed to assign pointer for property 'fixed_pot'") + endif + + if (minval(constrained_list) < 1 .or. maxval(constrained_list) > size(fixed_pot)) then + call print("do_minimise_mm: size(fixed_pot) " // size(fixed_pot) // & + " size(constrained_list) " // size(constrained_list), PRINT_ALWAYS) + call print("do_minimise_mm: constrained_list", PRINT_ALWAYS) + call print(constrained_list, PRINT_ALWAYS) + call system_abort("do_minimise_mm with invalid value in constrained list") + endif + + fixed_pot = 0 + fixed_pot(constrained_list) = 1 + + call verbosity_push_decrement() + mainlog%prefix="NESTED_MINIM" + mm_steps = minim(relax_pot, at, minim_mm_method, minim_mm_tol, minim_mm_max_steps, & + linminroutine=minim_mm_linminroutine, do_pos=minim_mm_do_pos, do_lat=minim_mm_do_lat, & + do_print=minim_mm_do_print, args_str=minim_mm_args_str, & + eps_guess=minim_mm_eps_guess, print_inoutput=minim_inoutput_movie, & + print_cinoutput=minim_cinoutput_movie) + mainlog%prefix="" + call verbosity_pop() + call print("Potential_local_e_mix_calc minimise_mm got mm_steps " // mm_steps, PRINT_VERBOSE) + + call calc_connect(at) + + call print("MM minimisation done in "//mm_steps//" steps", PRINT_VERBOSE) + + fixed_pot=0 + + end subroutine do_minimise_mm + diff --git a/src/Potentials/Potential_Local_E_Mix_header.F90 b/src/Potentials/Potential_Local_E_Mix_header.F90 new file mode 100644 index 0000000000..6839aaf871 --- /dev/null +++ b/src/Potentials/Potential_Local_E_Mix_header.F90 @@ -0,0 +1,83 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Local Energy Mixing header stuff to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + public :: Potential_Local_E_Mix + type Potential_Local_E_Mix + type(Potential), pointer :: pot_region1 + type(Potential), pointer :: pot_region2 + logical :: terminate = .true. + real(dp):: r_scale_pot1 = 1.0_dp, E_scale_pot1 = 1.0_dp + + type(Potential) :: relax_pot + + character(STRING_LENGTH) :: run_suffix + logical :: minimise_mm + character(STRING_LENGTH) :: minim_mm_method + real(dp) :: minim_mm_tol, minim_mm_eps_guess + integer :: minim_mm_max_steps + character(STRING_LENGTH) :: minim_mm_linminroutine + logical :: minim_mm_do_pos, minim_mm_do_lat + logical :: minim_mm_do_print + character(STRING_LENGTH) :: minim_mm_args_str + + type(Dictionary) :: create_hybrid_weights_params + + type(Inoutput), pointer :: minim_inoutput_movie + type(CInoutput), pointer :: minim_cinoutput_movie + + end type Potential_Local_E_Mix + + interface Print + module procedure potential_local_e_mix_print + end interface Print + + interface Cutoff + module procedure potential_local_e_mix_cutoff + end interface Cutoff + + interface Calc + module procedure potential_local_e_mix_calc + end interface Calc + + interface Initialise + module procedure potential_local_e_mix_initialise + end interface Initialise + + interface Finalise + module procedure potential_local_e_mix_finalise + end interface Finalise diff --git a/src/Potentials/Potential_Local_E_Mix_routines.F90 b/src/Potentials/Potential_Local_E_Mix_routines.F90 new file mode 100644 index 0000000000..896a148b0b --- /dev/null +++ b/src/Potentials/Potential_Local_E_Mix_routines.F90 @@ -0,0 +1,435 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Local Energy Mixing routines to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + recursive subroutine potential_local_e_mix_initialise(this, args_str, region1_pot, region2_pot, reference_bulk, mpi_obj, error) + type(Potential_Local_E_Mix), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(Potential), intent(inout), target :: region1_pot, region2_pot + type(Atoms), optional, intent(inout) :: reference_bulk + type(MPI_Context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(Dictionary) :: params + logical :: minimise_bulk + logical :: do_rescale_r, do_rescale_E, do_tb_defaults + + INIT_ERROR(error) + + call initialise(params) + call param_register(params, "run_suffix", "", this%run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "r_scale", "1.0", this%r_scale_pot1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "E_scale", "1.0", this%E_scale_pot1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "terminate", "T", this%terminate, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "minimise_bulk", "F", minimise_bulk, help_string="No help yet. This source file was $LastChangedBy$") + + call param_register(params, "do_rescale_r", "F", do_rescale_r, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "do_rescale_E", "F", do_rescale_E, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "do_tb_defaults", "T", do_tb_defaults, help_string="No help yet. This source file was $LastChangedBy$") + + call param_register(params, "minimise_mm", "F", this%minimise_mm, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "minim_mm_method", "cg", this%minim_mm_method, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_tol', '1e-6', this%minim_mm_tol, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_eps_guess', '1e-4', this%minim_mm_eps_guess, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_max_steps', '500', this%minim_mm_max_steps, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_linminroutine', 'FAST_LINMIN', this%minim_mm_linminroutine, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_pos', 'T', this%minim_mm_do_pos, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_lat', 'F', this%minim_mm_do_lat, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_print', 'F', this%minim_mm_do_print, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_args_str', '', this%minim_mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Local_E_Mix_initialise args_str') ) then + RAISE_ERROR("Potential_Local_E_Mix_initialise failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + call initialise(this%create_hybrid_weights_params) + call read_string(this%create_hybrid_weights_params, args_str) + call remove_value(this%create_hybrid_weights_params, 'run_suffix') + call remove_value(this%create_hybrid_weights_params, 'r_scale') + call remove_value(this%create_hybrid_weights_params, 'E_scale') + call remove_value(this%create_hybrid_weights_params, 'terminate') + call remove_value(this%create_hybrid_weights_params, 'minimise_bulk') + call remove_value(this%create_hybrid_weights_params, 'do_rescale_r') + call remove_value(this%create_hybrid_weights_params, 'do_rescale_E') + call remove_value(this%create_hybrid_weights_params, 'do_tb_defaults') + call remove_value(this%create_hybrid_weights_params, 'minimise_mm') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_method') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_tol') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_eps_guess') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_max_steps') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_linminroutine') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_pos') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_lat') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_do_print') + call remove_value(this%create_hybrid_weights_params, 'minim_mm_args_str') + + if (this%minimise_mm) then + call initialise(this%relax_pot, "Simple", region2_pot) + endif + + if (do_rescale_r .or. do_rescale_E .or. do_tb_defaults) then + if (.not. present(reference_bulk)) then + RAISE_ERROR("potential_local_e_mix_initialise got do_rescale_r="//do_rescale_r//" do_rescale_E="//do_rescale_E//" do_tb_defaults="//do_tb_defaults//" but reference_bulk is not present", error) + endif + + call do_reference_bulk(reference_bulk, region1_pot, region2_pot, minimise_bulk, do_rescale_r, do_rescale_E, & + this%r_scale_pot1, this%E_scale_pot1, do_tb_defaults) + + endif + + if (this%r_scale_pot1 <= 0.0_dp) this%r_scale_pot1 = 1.0_dp + if (this%E_scale_pot1 <= 0.0_dp) this%E_scale_pot1 = 1.0_dp + + call print ("Rescaling positions in region1 potential by " // this%r_scale_pot1 // " to match lattice constants") + call print ("Rescaling energies in region1 potential by " // this%E_scale_pot1 // " to match bulk modulus") + + this%pot_region1 => region1_pot + this%pot_region2 => region2_pot + + end subroutine + + recursive subroutine potential_local_e_mix_finalise(this) + type(Potential_Local_E_Mix), intent(inout) :: this + + call finalise(this%pot_region1) + call finalise(this%pot_region2) + + deallocate(this%pot_region1) + deallocate(this%pot_region2) + end subroutine potential_local_e_mix_finalise + + + recursive function potential_local_e_mix_cutoff(this) + type(Potential_Local_E_Mix), intent(in) :: this + real(dp) :: potential_local_e_mix_cutoff + + potential_local_e_mix_cutoff = max(cutoff(this%pot_region1), cutoff(this%pot_region2)) + end function potential_local_e_mix_cutoff + + recursive subroutine potential_local_e_mix_print(this, file) + type(Potential_Local_E_Mix), intent(inout) :: this + type(Inoutput),intent(inout),optional:: file + + call print('Local_E_Mix potential:', file=file) + call print('Potential in region 1 (embedded):', file=file) + call print('=======================', file=file) + call print(this%pot_region1, file=file) + call print('') + call print('Potential in region 2 (surroundings):', file=file) + call print('=======================', file=file) + call print(this%pot_region2, file=file) + call print('do_terminate ' // this%terminate, file=file) + call print('r_scale_pot1=' // this%r_scale_pot1 // ' E_scale_pot1=' // this%E_scale_pot1, file=file) + call print('') + end subroutine potential_local_e_mix_print + + recursive subroutine potential_local_e_mix_calc(this, at, args_str, error) + type(Potential_Local_E_Mix), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + logical :: calc_weights + integer :: core_hops, transition_hops, buffer_hops + type(Dictionary) :: params, calc_create_hybrid_weights_params + type(Table) :: region1_table + integer :: i + integer, pointer :: hybrid(:), hybrid_mark(:) + character(len=STRING_LENGTH) :: run_suffix + + INIT_ERROR(error) + + if (.not. associated(this%pot_region1) .or. .not. associated(this%pot_region2)) & + call system_abort("Potential_Local_E_Mix_calc: this%pot_region1 or this%pot_region2 not initialised") + + call initialise(params) + call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "calc_weights", "F", calc_weights, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "core_hops", "0", core_hops, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Local_E_Mix_Calc args_str') ) & + call system_abort("Potential_Local_E_Mix_calc_energy failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + + if (calc_weights) then + call print("Potential_Local_E_Mix_calc got calc_weights core_hops " // core_hops, PRINT_VERBOSE) + call add_property(at, "weight_region1", 0.0_dp) + call add_property(at, "hybrid_mark"//trim(run_suffix), HYBRID_NO_MARK) + if (.not. assign_pointer(at, "hybrid"//trim(run_suffix), hybrid)) & + call system_abort("QC_QUIP_calc at doesn't have hybrid property and calc_weights was specified") + if (.not. assign_pointer(at, "hybrid_mark"//trim(run_suffix), hybrid_mark)) & + call system_abort("QC_QUIP_calc Failed to add hybrid_mark property to at") + + call calc_connect(at) + + call wipe(region1_table) + hybrid_mark = HYBRID_NO_MARK + do i=1, size(hybrid) + if (hybrid(i) /= 0) call append(region1_table, (/ i, 0, 0, 0 /) ) + end do + call bfs_grow(at, region1_table, core_hops, nneighb_only = .false.) + hybrid_mark(int_part(region1_table,1)) = HYBRID_ACTIVE_MARK + + call read_string(calc_create_hybrid_weights_params, write_string(this%create_hybrid_weights_params)) + call read_string(calc_create_hybrid_weights_params, trim(args_str), append=.true.) + call create_hybrid_weights(at, write_string(calc_create_hybrid_weights_params)) + endif + + call calc_local_energy_mix(this, at, args_str, error=error) + PASS_ERROR(error) + + end subroutine potential_local_e_mix_calc + + recursive subroutine calc_local_energy_mix(this, at, args_str, error) + type(Potential_Local_E_Mix), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + real(dp) :: energy, virial(3,3) + real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:) + + ! local variables + integer :: i + integer, pointer :: hybrid_mark(:), index(:), termindex(:) + real(dp), pointer :: weight(:), weight_region1(:), rescale(:), c_weight(:) + real(dp), pointer :: f_cluster(:,:), local_e_cluster(:) + real(dp), allocatable :: weight_saved(:), local_e_weight(:), local_e_region2(:), local_e_region1(:), f_region1(:,:) + real(dp) :: e_cluster + logical :: dummy + type(Atoms) :: cluster + type(Table) :: cluster_info + type(Dictionary) :: params + character(STRING_LENGTH) :: cc_args_str + + real(dp), pointer :: local_e_pot1(:), local_e_pot2(:) + character(STRING_LENGTH) :: calc_energy, calc_force, calc_local_energy, calc_virial, calc_local_virial, local_energy_args_str, local_energy_name, run_suffix + + INIT_ERROR(error) + + allocate(weight_saved(at%N)) + allocate(local_e_weight(at%N)) + allocate(local_e_region2(at%N)) + allocate(local_e_region1(at%N)) + allocate(f_region1(3,at%N)) + + call system_timer("calc_local_energy_mix") + + call initialise(params) + call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'energy', '', calc_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'force', '', calc_force, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'local_energy', '', calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'virial', '', calc_virial, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'local_virial', '', calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Local_E_Mix args_str') ) & + call system_abort("Potential_Local_E_Mix failed to parse args_str='"//trim(args_str)//"'") + call finalise(params) + + if(.not. (associated(this%pot_region1) .and. associated(this%pot_region2))) then + call system_abort('local_e_mix_calc_energy_mix: potential for region 1 or region 2 is not initialised') + end if + + ! check for a compatible weight property, create it if necessary + if (.not.assign_pointer(at, 'weight', weight)) then + call add_property(at, 'weight', 1.0_dp) + if(.not.assign_pointer(at, 'weight', weight)) & + call system_abort("Impossible failure to create weight property in calc_local_energy_mix") + weight_saved = 1.0_dp + else + weight_saved = weight + endif + ! check for a compatible hybrid and weight_region1 property. they must be present + if (.not.assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) & + call system_abort('hybrid_calc_energy_mix: atoms structure has no "hybrid_mark'//trim(run_suffix)//'" property') + if (.not.assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1)) & + call system_abort('hybrid_calc_energy_mix: atoms structure has no "weight_region1'//trim(run_suffix)//'" property') + + if(.not. all(hybrid_mark == HYBRID_NO_MARK)) then + if(len_trim(calc_virial) > 0 .or. len_trim(calc_local_virial) > 0) then + RAISE_ERROR('hybrid_calc_energy_mix: virial or local_virial not yet implemented when QM region is active', error) + end if + endif + + ! if hybrid is active, carve cluster and do minimisation if necessary + if(any(hybrid_mark /= HYBRID_NO_MARK)) then + call initialise(params) + call set_value(params, 'terminate', this%terminate) + call set_value(params, 'cluster_allow_modification', 'F') + call set_value(params, 'cluster_periodic_x', 'T') + call set_value(params, 'cluster_periodic_y', 'T') + call set_value(params, 'cluster_periodic_z', 'T') + call set_value(params, 'randomise_buffer', 'F') + cc_args_str = write_string(params) + call finalise(params) + cluster_info = create_cluster_info_from_mark(at, cc_args_str) + call carve_cluster(at, cc_args_str, cluster_info, cluster) + + if (this%minimise_mm) then + dummy = assign_pointer(cluster, 'index', index) + call do_minimise_mm(this%relax_pot, at, this%minim_mm_method, this%minim_mm_tol, this%minim_mm_max_steps, & + this%minim_mm_linminroutine, this%minim_mm_do_pos, this%minim_mm_do_lat, this%minim_mm_do_print, & + this%minim_mm_args_str, this%minim_mm_eps_guess, this%minim_inoutput_movie, & + this%minim_cinoutput_movie, index) + endif + endif + + if (len_trim(calc_local_energy) > 0) then + call assign_property_pointer(at, trim(local_energy_name), at_local_energy_ptr, error=error) + PASS_ERROR(error) + local_energy_name = trim(calc_local_energy) + local_energy_args_str = "" + else + local_energy_name = "LEMIX_local_energy" + PASS_ERROR(error) + call add_property(at, trim(local_energy_name), 0.0_dp, ptr=at_local_energy_ptr) + local_energy_args_str = "local_energy="//trim(local_energy_name) + endif + if (len_trim(calc_force) > 0) then + call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) + PASS_ERROR(error) + endif + + ! do calculation in region 2 first + weight = weight_saved-weight_region1 ! "negate" the weights + + call system_timer("calc_local_energy_mix/calc_region_2") + call Calc(this%pot_region2, at, args_str=args_str//" "//trim(local_energy_args_str)) + call system_timer("calc_local_energy_mix/calc_region_2") + if (len_trim(calc_energy) > 0) call get_param_value(at, trim(calc_energy), energy) + local_e_region2 = at_local_energy_ptr + + if (assign_pointer(at, "local_e_pot2", local_e_pot2)) local_e_pot2 = local_e_region2 + + call system_timer("calc_local_energy_mix/prep_cluster") + if(len_trim(calc_local_energy) > 0) then + local_e_weight = 1.0_dp-weight_region1 + at_local_energy_ptr = local_e_weight * local_e_region2 + endif + + ! if there are no marked atoms, we are done, so return + if(all(hybrid_mark == HYBRID_NO_MARK)) then + ! restore weights + weight = weight_saved + call print('No REGION 1 marks, not carving REGION 1 cluster') + return + end if + + ! Now compute region 1 + + ! copy weight_region1 back into cluster for region1 calculation + if (.not.assign_pointer(cluster, 'weight', c_weight)) & + call system_abort("calc_local_energy_mix didn't find weight property for cluster") + if (.not. assign_pointer(cluster, 'index', index)) & + call system_abort("calc_local_energy_mix didn't find index property for cluster") + c_weight = weight_region1(index) + + ! rescale cluster + call set_lattice(cluster, this%r_scale_pot1 * cluster%lattice, scale_positions=.true.) + + call calc_connect(cluster) + + call system_timer("calc_local_energy_mix/prep_cluster") + call system_timer("calc_local_energy_mix/calc_region_1") + call Calc(this%pot_region1, cluster, args_str = args_str//" solver=DIAG_GF SCF=GLOBAL_U "//trim(local_energy_args_str)) + if (len_trim(calc_force) > 0) then + call assign_property_pointer(cluster, trim(calc_force), f_cluster, error=error) + PASS_ERROR_WITH_INFO("Potential_Local_E_Mix failed to assign pointer for region 1 force property '"//trim(calc_force)//"'", error) + ! scale back forces + f_cluster = f_cluster*this%E_scale_pot1*this%r_scale_pot1 + endif + if (len_trim(calc_energy) > 0) call get_param_value(at, trim(calc_energy), e_cluster) + call assign_property_pointer(at, trim(local_energy_name), local_e_cluster, error=error) + PASS_ERROR_WITH_INFO("Potential_Local_E_Mix failed to assign pointer for region 1 local_energy property '"//trim(calc_local_energy)//"'", error) + + if (len_trim(calc_energy) > 0) e_cluster = e_cluster*this%E_scale_pot1 + if (len_trim(calc_local_energy) > 0) local_e_cluster = local_e_cluster*this%E_scale_pot1 + call system_timer("calc_local_energy_mix/calc_region_1") + + call system_timer("calc_local_energy_mix/combine") + if(current_verbosity() > PRINT_VERBOSE) call write(cluster, "cluster.cfg") + + ! redistribute local energies and weights from the cluster to region 1 + if (.not. assign_pointer(cluster, 'index', index)) & + call system_abort('calc_local_energy_mix: cluster structure has no "index" property') + if (.not. assign_pointer(cluster, 'rescale', rescale)) & + call system_abort('calc_local_energy_mix: cluster structure has no "rescale" property') + if (.not. assign_pointer(cluster, 'termindex', termindex)) & + call system_abort('calc_local_energy_mix: cluster structure has no "termindex" property') + ! first add terms arising from the fact that the position of the rescaled termination atoms + ! depends on the position of the atoms they are terminating + local_e_region1 = 0.0_dp + f_region1 = 0.0_dp + if(len_trim(calc_force) > 0) then + do i=1,cluster%N + if(termindex(i) > 0) & + f_cluster(:,termindex(i)) = f_cluster(:,termindex(i)) + (1.0_dp-rescale(i))*f_cluster(:,i) + end do + end if + ! now do the redistribution + do i=1,cluster%N + if(len_trim(calc_force) > 0) f_region1(:,index(i)) = f_region1(:,index(i)) + f_cluster(:,i)*rescale(i) + if(len_trim(calc_local_energy) > 0) local_e_region1(index(i)) = local_e_region1(index(i)) + local_e_cluster(i) + end do + + if (assign_pointer(at, "local_e_pot1", local_e_pot1)) local_e_pot1 = local_e_region1 + + ! finally add region 1 stuff to the output variables + if(len_trim(calc_energy) > 0) then + energy = energy + e_cluster + call set_param_value(at, trim(calc_energy), energy) + endif + if(len_trim(calc_local_energy) > 0) then + local_e_weight = weight_region1 + at_local_energy_ptr = at_local_energy_ptr + local_e_weight * local_e_region1 + endif + if(len_trim(calc_force) > 0) at_force_ptr = at_force_ptr + f_region1 + + weight = weight_saved + + call finalise(cluster) + + deallocate(weight_saved) + deallocate(local_e_weight) + deallocate(local_e_region2) + deallocate(local_e_region1) + deallocate(f_region1) + + if (len_trim(calc_local_energy) == 0) call remove_property(at, trim(local_energy_name)) + + call system_timer("calc_local_energy_mix/combine") + call system_timer("calc_local_energy_mix") + end subroutine calc_local_energy_mix diff --git a/src/Potentials/Potential_ONIOM_header.F90 b/src/Potentials/Potential_ONIOM_header.F90 new file mode 100644 index 0000000000..13add01c71 --- /dev/null +++ b/src/Potentials/Potential_ONIOM_header.F90 @@ -0,0 +1,81 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X ONIOM header stuff to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + public :: Potential_ONIOM + type Potential_ONIOM + type(Potential), pointer :: pot_region1 + type(Potential), pointer :: pot_region2 + logical :: terminate = .true. + real(dp):: r_scale_pot1 = 1.0_dp, E_scale_pot1 = 1.0_dp + + type(Potential) :: relax_pot + + character(STRING_LENGTH) :: run_suffix + logical :: minimise_mm + character(STRING_LENGTH) :: minim_mm_method + real(dp) :: minim_mm_tol, minim_mm_eps_guess + integer :: minim_mm_max_steps + character(STRING_LENGTH) :: minim_mm_linminroutine + logical :: minim_mm_do_pos, minim_mm_do_lat + logical :: minim_mm_do_print + character(STRING_LENGTH) :: minim_mm_args_str + + type(Inoutput), pointer :: minim_inoutput_movie + type(CInoutput), pointer :: minim_cinoutput_movie + + end type Potential_ONIOM + + interface Print + module procedure potential_oniom_print + end interface Print + + interface Cutoff + module procedure potential_oniom_cutoff + end interface Cutoff + + interface Calc + module procedure potential_oniom_calc + end interface Calc + + interface Initialise + module procedure potential_oniom_initialise + end interface Initialise + + interface Finalise + module procedure potential_oniom_finalise + end interface Finalise diff --git a/src/Potentials/Potential_ONIOM_routines.F90 b/src/Potentials/Potential_ONIOM_routines.F90 new file mode 100644 index 0000000000..2542611e41 --- /dev/null +++ b/src/Potentials/Potential_ONIOM_routines.F90 @@ -0,0 +1,410 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X ONIOM routines to be included in Potential.f95 +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + recursive subroutine potential_ONIOM_initialise(this, args_str, region1_pot, region2_pot, reference_bulk, mpi_obj, error) + type(Potential_ONIOM), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(Potential), intent(inout), target :: region1_pot, region2_pot + type(Atoms), optional, intent(inout) :: reference_bulk + type(MPI_Context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(Dictionary) :: params + logical :: minimise_bulk + logical :: do_rescale_r, do_rescale_E, do_tb_defaults + + INIT_ERROR(error) + + call initialise(params) + call param_register(params, "run_suffix", "", this%run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + + call param_register(params, "r_scale", "1.0", this%r_scale_pot1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "E_scale", "1.0", this%E_scale_pot1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "terminate", "T", this%terminate, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "minimise_bulk", "F", minimise_bulk, help_string="No help yet. This source file was $LastChangedBy$") + + call param_register(params, "do_rescale_r", "F", do_rescale_r, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "do_rescale_E", "F", do_rescale_E, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "do_tb_defaults", "F", do_tb_defaults, help_string="No help yet. This source file was $LastChangedBy$") + + call param_register(params, "minimise_mm", "F", this%minimise_mm, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "minim_mm_method", "cg", this%minim_mm_method, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_tol', '1e-6', this%minim_mm_tol, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_eps_guess', '1e-4', this%minim_mm_eps_guess, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_max_steps', '500', this%minim_mm_max_steps, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_linminroutine', 'FAST_LINMIN', this%minim_mm_linminroutine, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_pos', 'T', this%minim_mm_do_pos, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_lat', 'F', this%minim_mm_do_lat, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_do_print', 'F', this%minim_mm_do_print, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'minim_mm_args_str', '', this%minim_mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_ONIOM_initialise args_str') ) then + RAISE_ERROR("Potential_ONIOM_initialise failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + + if (this%minimise_mm) then + call initialise(this%relax_pot, "Simple", region2_pot) + endif + + if (do_rescale_r .or. do_rescale_E .or. do_tb_defaults) then + if (.not. present(reference_bulk)) then + RAISE_ERROR("potential_local_e_mix_initialise got do_rescale_r="//do_rescale_r//" do_rescale_E="//do_rescale_E//" do_tb_defaults="//do_tb_defaults//" but reference_bulk is not present", error) + endif + + call do_reference_bulk(reference_bulk, region1_pot, region2_pot, minimise_bulk, do_rescale_r, do_rescale_E, & + this%r_scale_pot1, this%E_scale_pot1, do_tb_defaults) + + endif + + if (this%r_scale_pot1 <= 0.0_dp) this%r_scale_pot1 = 1.0_dp + if (this%E_scale_pot1 <= 0.0_dp) this%E_scale_pot1 = 1.0_dp + + call print ("Rescaling positions in region1 potential by " // this%r_scale_pot1 // " to match lattice constants") + call print ("Rescaling energies in region1 potential by " // this%E_scale_pot1 // " to match bulk modulus") + + this%pot_region1 => region1_pot + this%pot_region2 => region2_pot + + end subroutine + + recursive subroutine potential_ONIOM_finalise(this) + type(Potential_ONIOM), intent(inout) :: this + + call finalise(this%pot_region1) + call finalise(this%pot_region2) + + deallocate(this%pot_region1) + deallocate(this%pot_region2) + end subroutine potential_ONIOM_finalise + + + recursive function potential_ONIOM_cutoff(this) + type(Potential_ONIOM), intent(in) :: this + real(dp) :: potential_ONIOM_cutoff + + potential_ONIOM_cutoff = max(cutoff(this%pot_region1), cutoff(this%pot_region2)) + end function potential_ONIOM_cutoff + + recursive subroutine potential_ONIOM_print(this, file) + type(Potential_ONIOM), intent(inout) :: this + type(Inoutput),intent(inout),optional:: file + + call print('ONIOM potential:', file=file) + call print('Potential in region 1 (embedded):', file=file) + call print('=======================', file=file) + call print(this%pot_region1, file=file) + call print('') + call print('Potential in region 2 (surroundings):', file=file) + call print('=======================', file=file) + call print(this%pot_region2, file=file) + call print('do_terminate ' // this%terminate, file=file) + call print('r_scale_pot1=' // this%r_scale_pot1 // ' E_scale_pot1=' // this%E_scale_pot1, file=file) + call print('') + end subroutine potential_ONIOM_print + + + recursive subroutine potential_ONIOM_calc(this, at, args_str, error) + type(Potential_ONIOM), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + logical :: calc_weights + integer :: core_hops + type(Dictionary) :: params + type(Table) :: region1_table + integer :: i + integer, pointer :: hybrid(:), hybrid_mark(:) + character(len=STRING_LENGTH) :: run_suffix + + INIT_ERROR(error) + + if (.not. associated(this%pot_region1) .or. .not. associated(this%pot_region2)) then + RAISE_ERROR("Potential_ONIOM_calc: this%pot_region1 or this%pot_region2 not initialised", error) + endif + + call initialise(params) + call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "calc_weights", "F", calc_weights, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "core_hops", "0", core_hops, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_ONIOM_Calc args_str') ) then + RAISE_ERROR("Potential_ONIOM_calc_energy failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(params) + if (calc_weights) then + call print("Potential_ONIOM_calc got calc_weights core_hops " // core_hops, PRINT_VERBOSE) + call add_property(at, "weight_region1"//trim(run_suffix), 0.0_dp) + call add_property(at, "hybrid_mark"//trim(run_suffix), HYBRID_NO_MARK) + if (.not. assign_pointer(at, "hybrid"//trim(run_suffix), hybrid)) then + RAISE_ERROR("QC_QUIP_calc at doesn't have hybrid"//trim(run_suffix)//" property and calc_weights was specified", error) + endif + if (.not. assign_pointer(at, "hybrid_mark"//trim(run_suffix), hybrid_mark)) then + RAISE_ERROR("QC_QUIP_calc Failed to add hybrid_mark"//trim(run_suffix)//" property to at", error) + endif + + call calc_connect(at) + + call wipe(region1_table) + hybrid_mark = HYBRID_NO_MARK + do i=1, size(hybrid) + if (hybrid(i) /= 0) call append(region1_table, (/ i, 0, 0, 0 /) ) + end do + call bfs_grow(at, region1_table, core_hops, nneighb_only = .false.) + hybrid_mark(int_part(region1_table,1)) = HYBRID_ACTIVE_MARK + + call create_hybrid_weights(at, args_str="transition_hops=0 buffer_hops=0") + endif + + call calc_oniom(this, at, args_str, error) + PASS_ERROR(error) + + end subroutine potential_ONIOM_calc + + + recursive subroutine calc_oniom(this, at, args_str, error) + type(Potential_ONIOM), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + real(dp) :: energy, virial(3,3) + real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:), at_local_virial_ptr(:,:) + + type(Atoms) :: cluster + type(Table) :: cluster_info + type(Dictionary) :: params + character(STRING_LENGTH) :: cc_args_str + + real(dp) :: cluster_energy_1, cluster_energy_2 + real(dp), allocatable :: cluster_local_e_1(:), cluster_local_e_2(:) + real(dp), pointer :: cluster_force_ptr(:,:), cluster_local_energy_ptr(:), cluster_local_virial_ptr(:,:) + real(dp), allocatable :: cluster_force_1(:,:), cluster_force_2(:,:), cluster_local_virial_1(:,:), cluster_local_virial_2(:,:) + real(dp) :: cluster_virial_1(3,3), cluster_virial_2(3,3) + + integer, pointer :: hybrid_mark(:), index(:), termindex(:) + real(dp), pointer :: rescale(:) + logical :: dummy + integer i + + character(STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy, calc_local_virial, run_suffix + + INIT_ERROR(error) + + call system_timer("calc_oniom") + + call initialise(params) + call param_register(params, "run_suffix", trim(this%run_suffix), run_suffix, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "energy", "", calc_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "force", "", calc_force, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "virial", "", calc_virial, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "local_energy", "", calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "local_virial", "", calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Calc_ONIOM args_str')) then + RAISE_ERROR("Calc_ONIOM failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if(.not. (associated(this%pot_region1) .and. associated(this%pot_region2))) then + RAISE_ERROR('calc_oniom: potential for region 1 or region 2 is not initialised', error) + end if + + ! Check for a compatible hybrid_mark property. It must be present. + if (.not.assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then + RAISE_ERROR('calc_oniom: atoms structure has no "hybrid_mark'//trim(run_suffix)//'" property', error) + endif + + ! if hybrid is active, carve cluster and do minimisation if necessary + if(any(hybrid_mark /= HYBRID_NO_MARK)) then + + call initialise(params) + call set_value(params, 'terminate', this%terminate) + call set_value(params, 'cluster_allow_modification', 'F') + call set_value(params, 'cluster_periodic_x', 'T') + call set_value(params, 'cluster_periodic_y', 'T') + call set_value(params, 'cluster_periodic_z', 'T') + call set_value(params, 'randomise_buffer', 'F') + cc_args_str = write_string(params) + cluster_info = create_cluster_info_from_mark(at, cc_args_str) + call carve_cluster(at, cc_args_str, cluster_info, cluster) + + + if (this%minimise_mm) then + dummy = assign_pointer(cluster, 'index', index) + call do_minimise_mm(this%relax_pot, at, this%minim_mm_method, this%minim_mm_tol, this%minim_mm_max_steps, & + this%minim_mm_linminroutine, this%minim_mm_do_pos, this%minim_mm_do_lat, this%minim_mm_do_print, & + this%minim_mm_args_str, this%minim_mm_eps_guess, this%minim_inoutput_movie, & + this%minim_cinoutput_movie, index) + endif + endif + + if (len_trim(calc_force) > 0) then + call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) + PASS_ERROR(error) + endif + if (len_trim(calc_local_energy) > 0) then + call assign_property_pointer(at, trim(calc_local_energy), at_local_energy_ptr, error=error) + PASS_ERROR(error) + endif + if (len_trim(calc_local_virial) > 0) then + call assign_property_pointer(at, trim(calc_local_virial), at_local_virial_ptr, error=error) + PASS_ERROR(error) + endif + + ! do calculation in whole system first using pot_region2 + call system_timer("calc_oniom/calc_whole_sys") + call Calc(this%pot_region2, at, args_str=args_str) + call system_timer("calc_oniom/calc_whole_sys") + if (len_trim(calc_energy) > 0) call get_param_value(at, trim(calc_energy), energy) + if (len_trim(calc_virial) > 0) call get_param_value(at, trim(calc_virial), virial) + + call system_timer("calc_oniom/prep_cluster") + + ! if there are no marked atoms, we are done, so return + if(all(hybrid_mark == HYBRID_NO_MARK)) then + call print('WARNING: ONIOM with No REGION 1 marks, not carving REGION 1 cluster') + return + end if + + ! rescale cluster + call set_lattice(cluster, this%r_scale_pot1 * cluster%lattice, scale_positions=.true.) + + call calc_connect(cluster) + + call system_timer("calc_oniom/prep_cluster") + + call system_timer("calc_oniom/calc_cluster_1") + allocate(cluster_force_1(3,cluster%N)) + allocate(cluster_local_e_1(cluster%N)) + allocate(cluster_local_virial_1(9,cluster%N)) + call Calc(this%pot_region1, cluster, args_str=args_str) + if (len_trim(calc_force) > 0) then + call assign_property_pointer(cluster, trim(calc_force), cluster_force_ptr, error=error) + PASS_ERROR_WITH_INFO("Calc_ONIOM failed to get value for force property '"//trim(calc_force)//"'", error) + cluster_force_1 = cluster_force_ptr*this%E_scale_pot1*this%r_scale_pot1 + endif + if (len_trim(calc_virial) > 0) then + call get_param_value(cluster, trim(calc_virial), cluster_virial_1) + cluster_virial_1 = cluster_virial_1*this%E_scale_pot1 + endif + if (len_trim(calc_energy) > 0) then + call get_param_value(cluster, trim(calc_energy), cluster_energy_1) + cluster_energy_1 = cluster_energy_1*this%E_scale_pot1 + endif + if (len_trim(calc_local_energy) > 0) then + call assign_property_pointer(cluster, trim(calc_local_energy), cluster_local_energy_ptr, error=error) + RAISE_ERROR("Calc_ONIOM failed to get value for local_energy property '"//trim(calc_local_energy)//"'", ERROR) + cluster_local_e_1 = cluster_local_energy_ptr*this%E_scale_pot1 + endif + if (len_trim(calc_local_virial) > 0) then + call assign_property_pointer(cluster, trim(calc_local_virial), cluster_local_virial_ptr, error=error) + PASS_ERROR_WITH_INFO("Calc_ONIOM failed to get value for local_virial property '"//trim(calc_local_virial)//"'", error) + cluster_local_virial_1 = cluster_local_virial_ptr*this%E_scale_pot1 + endif + call system_timer("calc_oniom/calc_cluster_1") + + ! unrescale cluster + call set_lattice(cluster, cluster%lattice / this%r_scale_pot1, scale_positions=.true.) + + call calc_connect(cluster) + + call system_timer("calc_oniom/calc_cluster_2") + allocate(cluster_force_2(3,cluster%N)) + allocate(cluster_local_e_2(cluster%N)) + allocate(cluster_local_virial_2(9,cluster%N)) + call Calc(this%pot_region2, cluster, args_str=args_str) + if (len_trim(calc_force) > 0) cluster_force_2 = cluster_force_ptr + if (len_trim(calc_virial) > 0) call get_param_value(cluster, trim(calc_virial), cluster_virial_2) + if (len_trim(calc_energy) > 0) call get_param_value(cluster, trim(calc_energy), cluster_energy_2) + if (len_trim(calc_local_energy) > 0) cluster_local_e_2 = cluster_local_energy_ptr + if (len_trim(calc_local_virial) > 0) cluster_local_virial_2 = cluster_local_virial_ptr + call system_timer("calc_oniom/calc_cluster_2") + + call system_timer("calc_oniom/combine") + if(current_verbosity() > PRINT_VERBOSE) & + call write(cluster, "cluster.cfg") + + ! redistribute local energies and weights from the cluster to region 1 + dummy = assign_pointer(cluster, 'index', index) + dummy = assign_pointer(cluster, 'rescale', rescale) + dummy = assign_pointer(cluster, 'termindex', termindex) + ! first add terms arising from the fact that the position of the rescaled termination atoms + ! depends on the position of the atoms they are terminating + if(len_trim(calc_force) > 0) then + do i=1,cluster%N + if(termindex(i) > 0) then + cluster_force_1(:,termindex(i)) = cluster_force_1(:,termindex(i)) + (1.0_dp-rescale(i))*cluster_force_1(:,i) + cluster_force_2(:,termindex(i)) = cluster_force_2(:,termindex(i)) + (1.0_dp-rescale(i))*cluster_force_2(:,i) + endif + end do + end if + ! now do the redistribution + if(len_trim(calc_force) > 0) then + do i=1,cluster%N + at_force_ptr(:,index(i)) = at_force_ptr(:,index(i)) + cluster_force_1(:,i)*rescale(i) - cluster_force_2(:,i)*rescale(i) + end do + end if + if(len_trim(calc_virial) > 0) then + virial = virial + cluster_virial_1 - cluster_virial_2 + call set_param_value(at, trim(calc_virial), virial) + endif + if(len_trim(calc_local_energy) > 0) then + do i=1,cluster%N + at_local_energy_ptr(index(i)) = at_local_energy_ptr(index(i)) + cluster_local_e_1(i) - cluster_local_e_2(i) + end do + end if + if(len_trim(calc_energy) > 0) then + energy = energy + cluster_energy_1 - cluster_energy_2 + call set_param_value(at, trim(calc_energy), energy) + endif + if(len_trim(calc_local_virial) > 0) then + do i=1,cluster%N + at_local_virial_ptr(:,index(i)) = at_local_virial_ptr(:,index(i)) + cluster_local_virial_1(:,i) - cluster_local_virial_2(:,i) + end do + end if + call system_timer("calc_oniom/combine") + + call finalise(cluster) + deallocate(cluster_force_1) + deallocate(cluster_local_e_1) + deallocate(cluster_local_virial_1) + deallocate(cluster_force_2) + deallocate(cluster_local_e_2) + deallocate(cluster_local_virial_2) + + call system_timer("calc_oniom") + end subroutine calc_oniom diff --git a/src/Potentials/Potential_Precon_Minim.F90 b/src/Potentials/Potential_Precon_Minim.F90 new file mode 100644 index 0000000000..969a3ef2e8 --- /dev/null +++ b/src/Potentials/Potential_Precon_Minim.F90 @@ -0,0 +1,1659 @@ + +#include "error.inc" +module Potential_Precon_Minim_module + + + use Potential_Module, only : Potential, potential_minimise, energy_func, gradient_func, cutoff, max_rij_change, calc, print_hook, constrain_virial, fix_atoms_deform_grad, pack_pos_dg, unpack_pos_dg, prep_atoms_deform_grad + use error_module + use system_module, only : dp, inoutput, print, PRINT_ALWAYS, PRINT_NORMAL, PRINT_VERBOSE, PRINT_NERD, initialise, finalise, INPUT, & + optional_default, current_verbosity, mainlog, round, verbosity_push_decrement, verbosity_push,verbosity_push_increment, verbosity_pop, print_message, system_timer, system_abort, operator(//) + use units_module, only : EV_A3_IN_GPA + use periodictable_module, only : ElementCovRad, ElementMass + use extendable_str_module, only : extendable_str, initialise, read, string, finalise + use linearalgebra_module , only : norm, trace, matrix3x3_det, normsq, least_squares, add_identity, inverse, diagonalise, symmetric_linear_solve, operator(.fne.), operator(.mult.), operator(.feq.), print + use dictionary_module, only : dictionary, STRING_LENGTH, lookup_entry_i, write_string, get_value, has_key, read_string, set_value, remove_value, initialise, finalise + use paramreader_module, only : param_register, param_read_line + use mpi_context_module, only : mpi_context + use table_module, only : table, find, int_part, wipe, append, finalise + use minimization_module , only : minim, n_minim, fire_minim, test_gradient, n_test_gradient, precon_data, preconminim, precondimer + use connection_module, only : connection + use atoms_types_module, only : atoms, assign_pointer, add_property, assign_property_pointer, add_property_from_pointer, diff_min_image, distance_min_image + use atoms_module, only : has_property, cell_volume, neighbour, n_neighbours, set_lattice, is_nearest_neighbour, & + get_param_value, remove_property, calc_connect, set_cutoff_minimum, set_param_value, calc_dists, atoms_repoint, finalise, assignment(=) + use cinoutput_module, only : cinoutput, write + use dynamicalsystem_module, only : dynamicalsystem, ds_print_status, advance_verlet1, advance_verlet2 + use clusters_module, only : HYBRID_ACTIVE_MARK, HYBRID_NO_MARK, HYBRID_BUFFER_MARK, create_embed_and_fit_lists_from_cluster_mark, create_embed_and_fit_lists, & + create_hybrid_weights, add_cut_hydrogens, create_cluster_info_from_mark, bfs_grow, carve_cluster + + implicit none + + public :: Precon_Minim + interface Precon_Minim + module procedure Precon_Potential_Minim + end interface + + public :: Precon_Dimer + interface Precon_Dimer + module procedure Precon_Potential_Dimer + end interface + +! public :: Precon_MEP +! interface Precon_MEP +! module procedure Precon_Potential_MEP +! end interface + + contains + + + subroutine allocate_precon(this,at,precon_id,nneigh,energy_scale,length_scale,cutoff,res2,max_iter,max_sub,bulk_modulus,number_density,auto_mu) + type (precon_data), intent(inout) :: this + type (Atoms) :: at + character(*) :: precon_id + integer :: nneigh,max_iter,max_sub + real(dp) :: energy_scale, length_scale, cutoff,res2,bulk_modulus,number_density + real(dp) :: scalingnumer, scalingdenom, thisdist, this_r2 + logical :: auto_mu + integer :: I,J, thisind, thisneighcount + + this%precon_id = precon_id + this%nneigh = nneigh + this%energy_scale = energy_scale + this%length_scale = length_scale + this%cutoff = cutoff + this%res2 = res2 + this%mat_mult_max_iter = max_iter + this%max_sub = max_sub + this%bulk_modulus = bulk_modulus + this%number_density = number_density + + if (has_property(at, 'move_mask')) then + this%has_fixed = .TRUE. + else + this%has_fixed = .FALSE. + end if + + allocate(this%preconrowlengths(at%N)) + allocate(this%preconindices(nneigh+1,at%N)) + + if (trim(precon_id) == "LJ" .OR. trim(precon_id) == "ID" .OR. trim(precon_id) == "C1" .OR. trim(precon_id) == "exp") then + this%multI = .TRUE. + elseif (trim(precon_id) == "LJdense") then + this%dense = .true. + else + call print ("Unrecognized Preconditioner, exiting") + call exit() + end if + + + call set_cutoff_minimum(at, this%cutoff) + if(at%cutoff > 0.0_dp) call calc_connect(at) + + if (this%multI .eqv. .true.) then + allocate(this%preconcoeffs(nneigh+1,at%N,1)) + elseif (this%dense .eqv. .true.) then + allocate(this%preconcoeffs(nneigh+1,at%N,6)) + end if + call print('allocate_precon: auto_mu='//auto_mu) + if (auto_mu .and. (trim(precon_id) == "C1" .or. trim(precon_id) == "LJ" .or. trim(precon_id) == "exp")) then + this%mu=25.5/(this%cutoff**2.0) + elseif (.not. auto_mu .and. (trim(precon_id) == "C1" .or. trim(precon_id) == "LJ" .or. trim(precon_id) == "exp")) then + ! compute approximation to best \mu using + ! C1: mu = 3 (bulk-mod) * \sum_n vol[n] / \sum_{n, r} |r|^2 + ! LJ: mu = 3 (bulk-mod) * \sum_n vol[n] / \sum_{n, r} C(|r|) |r|^2 + ! where C(|r|) is the preconditioner coefficient for this bond + scalingnumer = 0.0_dp + scalingdenom = 0.0_dp + do I = 1,(at%N) + scalingnumer = scalingnumer + 1.0 + thisneighcount = n_neighbours(at,I) + do J = 1,thisneighcount + thisind = neighbour(at,I,J,distance=thisdist) + if (thisind > 0 .and. (thisdist <= this%cutoff)) then + if (this%precon_id == "LJ" .or. this%precon_id == "C1" .or. this%precon_id == "exp") then + this_r2 = thisdist**2.0 + if (this%precon_id == "LJ") then + ! if preconditoner is LJ, we scale the coefficient by C(|r|) + this_r2 = this_r2 * (thisdist/this%length_scale)**(-6.0_dp) + else if (this%precon_id == "exp") then + this_r2 = this_r2 * exp(-thisdist/this%length_scale) + end if + scalingdenom = scalingdenom + this_r2 + end if + end if + end do + end do + scalingnumer = scalingnumer*bulk_modulus/number_density + this%mu = (2.0*scalingnumer)/(scalingdenom/3.0) + else + this%mu=1.0 + end if + call print('allocate_precon: selected mu='//this%mu) + + end subroutine allocate_precon + + subroutine build_precon(this,am_data) + + implicit none + + type (precon_data),intent(inout) :: this + character(len=1) :: am_data(:) + + type (potential_minimise) :: am + + real(dp) :: conconstant + integer :: I,J,thisneighcount,thisneighcountlocal,thisind,thisind2 + real(dp) :: thisdist, thiscoeff + real(dp) :: thisdiff(3) + integer :: nearneighcount + logical :: did_rebuild, fixed_neighbour + integer :: didcount + real(dp) :: scalingcoeff, scalingnumer, scalingdenom + + call system_timer('build_precon') + am = transfer(am_data,am) + + call atoms_repoint(am%minim_at) + call set_cutoff_minimum(am%minim_at, this%cutoff) + + if(am%minim_at%cutoff > 0.0_dp) call calc_connect(am%minim_at,did_rebuild=did_rebuild) + if (did_rebuild .eqv. .true.) then + call print("Connectivity rebuilt by preconditioner") + am%connectivity_rebuilt = .true. + end if + +!: call print(this%precon_id == "C1") +!: !Bail out if the preconditioner does not need updating +!: if (am%connectivity_rebuilt .eqv. .false. .and. this%precon_id == "C1") then +!: call print("Saved a recompute") +!: return +!: end if + !conconstant = 1.0_dp/am%minim_at%N + !conconstant = 1.0_dp + conconstant = 0.01_dp ! stabilisation parameter + + scalingnumer = 0.0 + scalingdenom = 0.0 + + this%preconrowlengths = 0 + this%preconindices = 0 + this%preconcoeffs = 0.0 + !call print('Building precon with cutoff ' // this%cutoff) + + if(this%precon_id /= "ID") then + didcount = 0 + do I = 1,(am%minim_at%N) + !call print("rah") + !if(am%minim_at%move_mask(I) == 1) then + + if(this%has_fixed) then + if (am%minim_at%move_mask(I) == 0) then + this%preconcoeffs(1,I,1) = 1.0 + this%preconindices(1,I) = I + this%preconrowlengths(I) = 1 + cycle + end if + end if + + scalingnumer = scalingnumer + 1 + didcount = didcount+1 + thisneighcount = n_neighbours(am%minim_at,I) + thisneighcountlocal = n_neighbours(am%minim_at,I,max_dist=this%cutoff) + !call print(thisneighcount) + + ! call print(thisneighcount // ' ' // thisneighcountlocal) + ! do J=1,thisneighcount + ! call print(neighbour(am%minim_at,I,J)) + ! end do + ! call exit() + + if(thisneighcountlocal > this%nneigh) then + call print("Not enough memory was allocated for preconditioner, increase value of nneigh, undefined behaviour (probably runtime error) follows",PRINT_ALWAYS) + end if + + this%preconindices(1,I) = I + this%preconcoeffs(1,I,1) = conconstant + nearneighcount = 1 + do J = 1,thisneighcount + + thisind = neighbour(am%minim_at,I,J,distance=thisdist,diff=thisdiff,index=thisind2) + if (thisind > 0 .and. (thisdist <= this%cutoff) .and. thisind /= I) then + !call print(thisdist // ' ' // this%cutoff) + !call print( I // ' '// J // ' '// thisneighcount// ' ' // thisind // ' ' // thisdist) + !call print( I // ' ' // thisind // ' ' //thisind2 // ' ' // thisdist) + + + !call writevec(reshape(this%preconcoeffs(1,I,1:6),(/6/)),'coeffs0.dat') + if (this%precon_id == "LJ" .or. this%precon_id == "C1" .or. this%precon_id == "exp") then + + if (this%precon_id == "LJ") then + thiscoeff = ( thisdist/this%length_scale)**(-6.0_dp) + ! thiscoeff = 1.0_dp!max(min(thiscoeff,10.0_dp),0.1_dp) + !call print(thiscoeff) + else if (this%precon_id == "exp") then + thiscoeff = exp(-thisdist/this%length_scale) + else if (this%precon_id == "C1") then + thiscoeff = 1.0_dp + end if + + this%preconcoeffs(1,I,1) = this%preconcoeffs(1,I,1) + thiscoeff + scalingdenom = scalingdenom + thisdist**2.0 + + fixed_neighbour = this%has_fixed .and. (am%minim_at%move_mask(thisind) /= 1) + if (.not. fixed_neighbour) then + nearneighcount = nearneighcount+1 + this%preconcoeffs(nearneighcount,I,1) = -thiscoeff + this%preconindices(nearneighcount,I) = thisind + end if + + !this%preconcoeffs(1,I,1) = this%preconcoeffs(1,I,1) + thiscoeff + !this%preconcoeffs(nearneighcount,I,1) = -thiscoeff + + !nearneighcount = nearneighcount+1 +! elseif (this%precon_id == "LJdense") then +! +! ! Coeff 1 +! thiscoeff = this%energy_scale * ( (thisdiff(1)**2.0)*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & +! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0)) & +! + 12.0*this%length_scale**12.0/(thisdist**14.0) - 12.0*this%length_scale**6.0/(thisdist**8.0)) +! this%preconcoeffs(nearneighcount,I,1) = thiscoeff +! this%preconcoeffs(1,I,1) = this%preconcoeffs(1,I,1) - thiscoeff +! +! ! Coeff 2 +! thiscoeff = this%energy_scale * ( (thisdiff(1)*thisdiff(2))*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & +! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0))) +! this%preconcoeffs(nearneighcount,I,2) = thiscoeff +! this%preconcoeffs(1,I,2) = this%preconcoeffs(1,I,2) - thiscoeff +! +! ! Coeff 3 +! thiscoeff = this%energy_scale * ( (thisdiff(1)*thisdiff(3))*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & +! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0))) +! this%preconcoeffs(nearneighcount,I,3) = thiscoeff +! this%preconcoeffs(1,I,3) = this%preconcoeffs(1,I,3) - thiscoeff +! +! ! Coeff 4 +! thiscoeff = this%energy_scale * ( (thisdiff(2)**2.0)*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & +! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0)) & +! + 12.0*this%length_scale**12.0/(thisdist**14.0) - 12.0*this%length_scale**6.0/(thisdist**8.0)) +! this%preconcoeffs(nearneighcount,I,4) = thiscoeff +! this%preconcoeffs(1,I,4) = this%preconcoeffs(1,I,4) - thiscoeff +! +! ! Coeff 5 +! thiscoeff = this%energy_scale * ( (thisdiff(2)*thisdiff(3))*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & +! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0))) +! this%preconcoeffs(nearneighcount,I,5) = thiscoeff +! this%preconcoeffs(1,I,5) = this%preconcoeffs(1,I,5) - thiscoeff +! +! ! Coeff 6 +! thiscoeff = this%energy_scale * ( (thisdiff(3)**2.0)*( -42.0*4.0*this%length_scale**12.0/(thisdist**16.0) & +! +24.0*4.0*this%length_scale**6.0/(thisdist**10.0)) & +! + 12.0*this%length_scale**12.0/(thisdist**14.0) - 12.0*this%length_scale**6.0/(thisdist**8.0)) +! this%preconcoeffs(nearneighcount,I,6) = thiscoeff +! this%preconcoeffs(1,I,6) = this%preconcoeffs(1,I,6) - thiscoeff +! +! !call writevec(reshape(this%preconcoeffs(1,I,1:6),(/6/)),'coeffs1.dat') +! !call writevec(reshape(this%preconcoeffs(nearneighcount,I,1:6),(/6/)),'coeffs2.dat') +! !call writevec(thisdiff,'diff.dat') +! !call exit() +! + end if + + + end if + end do + + !call print(nearneighcount) + this%preconrowlengths(I) = nearneighcount + !end if + end do + else if (this%precon_id == 'ID') then + do I = 1,(am%minim_at%N) + this%preconcoeffs(1,I,1) = 1.0 + this%preconrowlengths(I) = 1 + this%preconindices(1,I) = I + end do + end if + + if(this%precon_id == 'LJ' .or. this%precon_id == 'C1' .or. this%precon_id == 'exp') then + ! scalingdenom = scalingdenom/3.0 + ! scalingnumer = 2.0*scalingnumer*this%bulk_modulus/this%number_density + !scalingcoeff = scalingnumer/scalingdenom + !scalingcoeff =this%bulk_modulus + + !call print(this%number_density) + call print('build_precon: using mu='//this%mu, PRINT_VERBOSE) + this%preconcoeffs= this%preconcoeffs*this%mu + end if + am%connectivity_rebuilt = .false. + !call exit() + + this%cell_coeff = 1.0_dp/(sum(this%preconcoeffs(1,:,1))/size(this%preconcoeffs,2)) + + call system_timer('build_precon') + + end subroutine build_precon + + subroutine getdenseC1precon(prmat,at,cutoff) + + implicit none + + real(dp), intent(inout) :: prmat(:,:) !The dense precon matrix will be stored here, it should be (N*3+9)x(N*3+9) + type (Atoms), target :: at ! The atoms the precon will be built from + real(dp) :: cutoff + type (precon_data) :: pr + character, allocatable :: am_data(:) + character, dimension(1) :: am_mold + type (potential_minimise) :: am + integer :: I, J, target_elements(3), row_elements(3), thisind, am_data_size, K + real(dp) :: scoeff + + call allocate_precon(pr,at,'C1',125,1.0_dp,1.0_dp,cutoff,10.0_dp**(-10.0),100,20,0.625_dp,0.1_dp,.true.) + + am%minim_at => at + am_data_size = size(transfer(am, am_mold)) + allocate(am_data(am_data_size)) + am_data = transfer(am, am_data) + call build_precon(pr,am_data) + prmat = 0.0 + do I = 1,9 + prmat(I,I) = 1.0 + end do + do I = 1,size(pr%preconindices,DIM=2) + + !call print(pr%preconindices(1:pr%preconrowlengths(I),I)) + target_elements = (/ I*3-2+9, I*3-1+9, I*3+9 /) + if (pr%preconrowlengths(I) >= 1) then + do J = 1,(pr%preconrowlengths(I)) + + thisind = pr%preconindices(J,I) + row_elements = (/ thisind*3-2+9, thisind*3-1+9, thisind*3+9/) + + scoeff = pr%preconcoeffs(J,I,1) + !call print(scoeff) + do K = 1,3 + prmat(row_elements(K),target_elements(K)) = prmat(row_elements(K),target_elements(K)) + scoeff + prmat(target_elements(K),row_elements(K)) = prmat(target_elements(K),row_elements(K)) + scoeff + end do + end do + end if + end do + end subroutine + + function Precon_Potential_Minim(this, at, method, convergence_tol, max_steps,efuncroutine, linminroutine, do_print, print_inoutput, print_cinoutput, & + do_pos, do_lat, args_str,external_pressure, & + hook, hook_print_interval, & + error,precon_id,length_scale,energy_scale,precon_cutoff,nneigh,res2,mat_mult_max_iter,max_sub,infoverride,convchoice,bulk_modulus,number_density,auto_mu) + + implicit none + + type(Potential), intent(inout), target :: this !% potential to evaluate energy/forces with + type(Atoms), intent(inout), target :: at !% starting configuration + character(*), intent(in) :: method !% passed to precon_minim() +! Options for method +! 'preconSD' - preconditioned steepest descent +! 'preconCG' - preconditioned safeguarded Polak-Ribiere conjugate gradient +! 'preconLBFGS - preconditioned LBFGS + + real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ + !% 'convergence_tol'. + integer, intent(in) :: max_steps !% Maximum number of steps + + character(*), intent(in), optional :: efuncroutine !% How to evaluate change in energy in a step +!Options for efuncroutine +! 'basic' - naive summation (default) +! 'kahan' - kahan summation of local energy differences (QUIPs potential must provide local_energy, if it does turn this on) + + character(*), intent(in),optional :: linminroutine !% Name of the line minisation routine to use +! Options for linminroutine +! 'basic' - simple backtracking, each iteration satisfies armijo +! 'standard' - bracket and zoom by cubic interpolation, with bisection as backup, each iteration satisfies wolfe +! 'none' - no linesearch, relies on estimating alpha from previous gradients etc, very dangerous + + logical, optional :: do_print !% if true, print configurations using minim's hook() + type(inoutput), intent(inout), optional, target :: print_inoutput !% inoutput object to print configs to, needed if do_print is true + type(cinoutput), intent(inout), optional, target :: print_cinoutput !% cinoutput object to print configs to, needed if do_print is true + logical, optional :: do_pos, do_lat !% do relaxation w.r.t. positions and/or lattice (if neither is included, do both) + character(len=*), intent(in), optional :: args_str !% arguments to pass to calc() + real(dp), dimension(3,3), optional :: external_pressure + optional :: hook + INTERFACE + subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + end subroutine hook + END INTERFACE + integer, intent(in), optional :: hook_print_interval !% how often to print xyz from hook function + integer, intent(out), optional :: error !% set to 1 if an error occurred during minimisation + + character(*), intent(in),optional :: precon_id +! Eventually will support multiple preconditioners for now just supports: +! 'ID' - identity preconditioner (default) i.e. no preconditioner +! 'C1' - binary connectivity precontioner +! 'LJ' - connectivity preconditioner based on LJ potential + + real(dp), intent(in), optional :: length_scale !length scale of potential (reference lattice distance, approximately will be probably good enough), default 1.0 + real(dp), intent(in), optional :: energy_scale !prefactor of the potential energy, default 1.0 + real(dp), intent(in), optional :: precon_cutoff !cutoff radius of the preconditioner, default 1.5, probably set this midway between first and second neighbour distances, assuming first neighbours contribute much more to the energy, if the potential is more or less 'flat' then may need to include second neighbours + integer, intent(in), optional :: nneigh !maximum number of neighbours expected in precon_cutoff radius, may be removed when this becomes automatic, default is 125, only necessary to edit if you run out of memory + + + real(dp), intent(in), optional :: bulk_modulus + real(dp), intent(in), optional :: number_density + + real(dp), intent(in), optional :: res2 !criteria for the residual squared of the approximate preconditioner inverse, probably dont need to change this + integer, intent(in), optional :: mat_mult_max_iter !max number of iterations of the preconditioner inverter, probably dont need to change this + integer, intent(in), optional :: max_sub !max number of iterations of the inverter before restarting, probably dont need to change this + + real(dp), optional :: infoverride !optional override to max step in infinity norm + logical, optional :: auto_mu + + character(*), intent(in),optional :: convchoice + + integer:: Precon_Potential_Minim + + character(len=STRING_LENGTH) :: use_method + + integer n_iter, n_iter_tot + real(dp), allocatable :: x(:) + real(dp) :: deform_grad(3,3) + logical my_do_print + logical done + + type(potential_minimise) am + integer :: am_data_size + character, allocatable :: am_data(:) + character, dimension(1) :: am_mold + integer :: status + + type (precon_data) :: pr + real(dp) :: my_length_scale, my_energy_scale, my_precon_cutoff, my_res2, my_bulk_modulus,my_number_density + integer :: my_nneigh, my_mat_mult_max_iter, my_max_sub + character(10) :: my_precon_id + logical :: doinfnorm, my_auto_mu + + + INIT_ERROR(error) + + doinfnorm = .false. + if (present(convchoice)) then + if (trim(convchoice) == 'infnorm') then + + doinfnorm = .true. + call print("Using inf_norm for convergence") + else + call print("Unrecognized choice of convergence metric, defaulting to 2 norm") + end if + + else + call print("Defaulting to 2 norm for convergence") + end if + + + my_bulk_modulus = optional_default(0.625_dp,bulk_modulus) + my_number_density = optional_default(0.01_dp,number_density) + + my_precon_id = optional_default('ID',precon_id) + if ((present(length_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then + call print("No length_scale specified, defaulting to reference lattice distance = 1.0. Unless this is a good estimate preconditioning may work VERY POORLY, if in doubt estimate high, set optional argument length_scale.") + end if + +! if ((present(energy_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then +! call print("No energy_scale specified, defaulting to prefactor = 1.0. Unless this is a good estimate preconditioning may work very poorly, set optional argument energy_scale.") +! end if + + if ((present(precon_cutoff) .eqv. .false.) .and. (trim(my_precon_id) /= 'ID')) then + call print("No precon cutoff specified, using the potential's own cutoff = "//cutoff(this)//". Decreasing this may improve performance, set optional argument precon_cutoff.") + end if + + am_data_size = size(transfer(am, am_mold)) + allocate(am_data(am_data_size)) + + use_method = trim(method) + + if(at%cutoff > 0.0_dp) call calc_connect(at) + am%minim_at => at + am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*am%minim_at%N + + if (present(args_str)) then + am%minim_args_str = args_str + else + am%minim_args_str = "" + endif + am%minim_pot => this + + if (.not.present(do_pos) .and. .not. present(do_lat)) then + am%minim_do_pos = .true. + am%minim_do_lat = .true. + else + am%minim_do_pos = optional_default(.false., do_pos) + am%minim_do_lat = optional_default(.false., do_lat) + endif + + am%external_pressure = 0.0_dp + if (present(external_pressure)) then + am%external_pressure = external_pressure + if( (am%external_pressure(1,1) .fne. am%external_pressure(2,2)) .or. & + & (am%external_pressure(1,1) .fne. am%external_pressure(3,3)) .or. & + & (am%external_pressure(1,2) .fne. 0.0_dp) .or. & + & (am%external_pressure(1,3) .fne. 0.0_dp) .or. & + & (am%external_pressure(2,1) .fne. 0.0_dp) .or. & + & (am%external_pressure(2,3) .fne. 0.0_dp) .or. & + & (am%external_pressure(3,1) .fne. 0.0_dp) .or. & + & (am%external_pressure(3,2) .fne. 0.0_dp) ) then + if(trim(use_method) /= 'fire') then + call print_message('WARNING', 'Anisotrpic pressure is being used. Switching to fire_minim.') + use_method = 'fire' + endif + endif + endif + + my_do_print = optional_default(.false., do_print) + + if (my_do_print .and. .not. present(print_inoutput) .and. .not. present(print_cinoutput)) & + call system_abort("potential_minim: do_print is true, but no print_inoutput or print_cinoutput present") + + if (my_do_print) then + if (present(print_cinoutput)) then + am%minim_cinoutput_movie => print_cinoutput + if (this%is_forcemixing) & + this%forcemixing%minim_cinoutput_movie => print_cinoutput +#ifdef HAVE_LOCAL_E_MIX + if (this%is_local_e_mix) & + this%local_e_mix%minim_cinoutput_movie => print_cinoutput +#endif /* HAVE_LOCAL_E_MIX */ +#ifdef HAVE_ONIOM + if (this%is_oniom) & + this%oniom%minim_cinoutput_movie => print_cinoutput +#endif /* HAVE_ONIOM */ + end if + else + nullify(am%minim_cinoutput_movie) + endif + + am%minim_n_eval_e = 0 + am%minim_n_eval_f = 0 + + allocate(x(9+am%minim_at%N*3)) + allocate(am%last_connect_x(size(x))) + am%last_connect_x=1.0e38_dp + deform_grad = 0.0_dp; call add_identity(deform_grad) + call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) + + am_data = transfer(am, am_data) + my_nneigh = optional_default(125,nneigh) + my_energy_scale = optional_default(1.0_dp,energy_scale) + my_length_scale = optional_default(1.0_dp,length_scale) + my_precon_cutoff = optional_default(cutoff(this),precon_cutoff) + my_res2 = optional_default(10.0_dp**(-5.0_dp),res2) + my_mat_mult_max_iter = optional_default(am%minim_at%N*3,mat_mult_max_iter) + my_auto_mu = optional_default(.true.,auto_mu) + my_max_sub = 30 + + if (my_length_scale < 0.5_dp) then + call print("WARNING: You have set your atomistic length scale (approximate first neighbour distance) to: "//my_length_scale // " this is very low and probably constitutes an incorrect input",PRINT_ALWAYS) + end if + + call allocate_precon(pr,at,my_precon_id,my_nneigh,my_energy_scale,my_length_scale,my_precon_cutoff,my_res2,my_mat_mult_max_iter,my_max_sub,my_bulk_modulus,my_number_density,my_auto_mu) + + n_iter = preconminim(x, energy_func_local, gradient_func, build_precon, pr, use_method, convergence_tol, max_steps, & + efuncroutine=efuncroutine, linminroutine=linminroutine, hook=hook, hook_print_interval=hook_print_interval, & + am_data=am_data, status=status, writehessian=writeapproxhessiangrad,gethessian=getapproxhessian,getfdhconnectivity=getfdhconnectivity,& + infoverride = infoverride, infconvext = doinfnorm) + + + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + if(am%minim_at%cutoff > 0.0_dp) call calc_connect(am%minim_at) + n_iter_tot = n_iter + done = .true. + deallocate(am%last_connect_x) + deallocate(x) + call print("MINIM_N_EVAL E " // am%minim_n_eval_e // " F " // am%minim_n_eval_f // & + " EF " // am%minim_n_eval_ef, PRINT_VERBOSE) + + Precon_Potential_Minim = n_iter_tot + deallocate(am_data) + + end function + + function Precon_Potential_Dimer(this, at,at2, method, convergence_tol, max_steps,efuncroutine, linminroutine, do_print, print_inoutput, print_cinoutput, & + do_pos, do_lat, args_str,external_pressure, & + hook,hook_print_interval,& + error,precon_id,length_scale,energy_scale,precon_cutoff,nneigh,res2,mat_mult_max_iter,max_sub,infoverride,bulk_modulus,number_density,auto_mu) + + implicit none + + type(Potential), intent(inout), target :: this !% potential to evaluate energy/forces with + type(Atoms), intent(inout), target :: at ! final configuration + type(Atoms), intent(in), target :: at2 ! start configuration 2 + character(*), intent(in) :: method !% passed to precon_minim() +! Options for method +! 'preconSD' - preconditioned steepest descent +! 'preconCG' - preconditioned safeguarded Polak-Ribiere conjugate gradient + + real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ + !% 'convergence_tol'. + integer, intent(in) :: max_steps !% Maximum number of steps + + character(*), intent(in), optional :: efuncroutine !% How to evaluate change in energy in a step +!Options for efuncroutine +! 'basic' - naive summation (default) +! 'kahan' - kahan summation of local energy differences (QUIPs potential must provide local_energy) + + character(*), intent(in),optional :: linminroutine !% Name of the line minisation routine to use +! Options for linminroutine +! 'basic' - simple backtracking, each iteration satisfies armijo +! 'basicpp' - cubic backtracking, tries to satisfy armijo +! 'standard' - bracket and zoom by cubic interpolation, with bisection as backup, each iteration satisfies wolfe +! 'none' - no linesearch, relies on estimating alpha from previous gradients etc, very dangerous + + logical, optional :: do_print !% if true, print configurations using minim's hook() + type(inoutput), intent(inout), optional, target :: print_inoutput !% inoutput object to print configs to, needed if do_print is true + type(cinoutput), intent(inout), optional, target :: print_cinoutput !% cinoutput object to print configs to, needed if do_print is true + logical, optional :: do_pos, do_lat !% do relaxation w.r.t. positions and/or lattice (if neither is included, do both) + character(len=*), intent(in), optional :: args_str !% arguments to pass to calc() + real(dp), dimension(3,3), optional :: external_pressure + integer, intent(in), optional :: hook_print_interval !% how often to print xyz from hook function + integer, intent(out), optional :: error !% set to 1 if an error occurred during minimisation + optional :: hook + INTERFACE + subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + end subroutine hook + END INTERFACE + + character(*), intent(in),optional :: precon_id +! Eventually will support multiple preconditioners for now just supports: +! 'ID' - identity preconditioner (default) i.e. no preconditioner +! 'C1' - binary connectivity precontioner +! 'LJ' - connectivity preconditioner based on LJ potential + + real(dp), intent(in), optional :: length_scale !length scale of potential (reference lattice distance, approximately will be probably good enough), default 1.0 + real(dp), intent(in), optional :: energy_scale !prefactor of the potential energy, default 1.0 + real(dp), intent(in), optional :: precon_cutoff !cutoff radius of the preconditioner, default 1.5, probably set this midway between first and second neighbour distances, assuming first neighbours contribute much more to the energy, if the potential is more or less 'flat' then may need to include second neighbours + integer, intent(in), optional :: nneigh !maximum number of neighbours expected in precon_cutoff radius, may be removed when this becomes automatic, default is 125 + + real(dp), intent(in), optional :: res2 !criteria for the residual squared of the approximate preconditioner inverse, probably dont need to change this + integer, intent(in), optional :: mat_mult_max_iter !max number of iterations of the preconditioner inverter, probably dont need to change this + integer, intent(in), optional :: max_sub !max number of iterations of the inverter before restarting + + real(dp), intent(in), optional :: bulk_modulus + real(dp), intent(in), optional :: number_density + logical, optional :: auto_mu + + integer:: Precon_Potential_Dimer + + character(len=STRING_LENGTH) :: use_method + + integer n_iter, n_iter_tot + real(dp), allocatable :: x(:),v(:),vpos(:,:) + real(dp) :: deform_grad(3,3) + logical my_do_print + logical done + + type(potential_minimise) am + integer :: am_data_size + character, allocatable :: am_data(:) + character, dimension(1) :: am_mold + integer :: status + + type (precon_data) :: pr + real(dp) :: my_length_scale, my_energy_scale, my_precon_cutoff, my_res2,my_bulk_modulus,my_number_density + integer :: my_nneigh, my_mat_mult_max_iter, my_max_sub + character(10) :: my_precon_id + logical :: my_auto_mu + + real(dp), optional :: infoverride + + INIT_ERROR(error) + + my_precon_id = optional_default('ID',precon_id) + if ((present(length_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then + call print("No length_scale specified, defaulting to reference lattice distance = 1.0. Unless this is a good estimate preconditioning may work VERY POORLY, if in doubt estimate high, set optional argument length_scale.") + end if + + if ((present(energy_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then + call print("No energy_scale specified, defaulting to prefactor = 1.0. Unless this is a good estimate preconditioning may work very poorly, set optional argument energy_scale.") + end if + + if ((present(precon_cutoff) .eqv. .false.) .and. (trim(my_precon_id) /= 'ID')) then + call print("No precon cutoff specified, using the potential's own cutoff = "//cutoff(this)//". Decreasing this may improve performance, set optional argument precon_cutoff.") + end if + + + am_data_size = size(transfer(am, am_mold)) + allocate(am_data(am_data_size)) + + use_method = trim(method) + + at%pos = (at%pos + at2%pos)/2.0 + allocate(vpos(at%N,3)) + vpos = (at%pos - at2%pos) + + my_bulk_modulus = optional_default(0.625_dp,bulk_modulus) + my_number_density = optional_default(0.01_dp,number_density) + + + if(at%cutoff > 0.0_dp) call calc_connect(at) + am%minim_at => at + am%pos_lat_preconditioner_factor = am%minim_pos_lat_preconditioner*am%minim_at%N + + if (present(args_str)) then + am%minim_args_str = args_str + else + am%minim_args_str = "" + endif + am%minim_pot => this + +! am%minim_do_lat = .false. + am%minim_do_lat = .false. +! if (.not.present(do_pos) .and. .not. present(do_lat)) then +! am%minim_do_pos = .true. +! am%minim_do_lat = .true. +! else +! am%minim_do_pos = optional_default(.false., do_pos) +! am%minim_do_lat = optional_default(.false., do_lat) +! endif + + am%external_pressure = 0.0_dp + if (present(external_pressure)) then + am%external_pressure = external_pressure + if( (am%external_pressure(1,1) .fne. am%external_pressure(2,2)) .or. & + & (am%external_pressure(1,1) .fne. am%external_pressure(3,3)) .or. & + & (am%external_pressure(1,2) .fne. 0.0_dp) .or. & + & (am%external_pressure(1,3) .fne. 0.0_dp) .or. & + & (am%external_pressure(2,1) .fne. 0.0_dp) .or. & + & (am%external_pressure(2,3) .fne. 0.0_dp) .or. & + & (am%external_pressure(3,1) .fne. 0.0_dp) .or. & + & (am%external_pressure(3,2) .fne. 0.0_dp) ) then + if(trim(use_method) /= 'fire') then + call print_message('WARNING', 'Anisotrpic pressure is being used. Switching to fire_minim.') + use_method = 'fire' + endif + endif + endif + + my_do_print = optional_default(.false., do_print) + + if (my_do_print .and. .not. present(print_inoutput) .and. .not. present(print_cinoutput)) & + call system_abort("potential_minim: do_print is true, but no print_inoutput or print_cinoutput present") + + if (my_do_print) then + if (present(print_cinoutput)) then + am%minim_cinoutput_movie => print_cinoutput + if (this%is_forcemixing) & + this%forcemixing%minim_cinoutput_movie => print_cinoutput +#ifdef HAVE_LOCAL_E_MIX + if (this%is_local_e_mix) & + this%local_e_mix%minim_cinoutput_movie => print_cinoutput +#endif /* HAVE_LOCAL_E_MIX */ +#ifdef HAVE_ONIOM + if (this%is_oniom) & + this%oniom%minim_cinoutput_movie => print_cinoutput +#endif /* HAVE_ONIOM */ + end if + else + nullify(am%minim_cinoutput_movie) + endif + + am%minim_n_eval_e = 0 + am%minim_n_eval_f = 0 + + allocate(x(9+am%minim_at%N*3),v(9+am%minim_at%N*3)) + allocate(am%last_connect_x(size(x))) + am%last_connect_x=1.0e38_dp + deform_grad = 0.0_dp; call add_identity(deform_grad) + call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) + + call pack_pos_dg(vpos, deform_grad, v, 0.0_dp) + !call print(x) + !call exit() + + + am_data = transfer(am, am_data) + my_nneigh = optional_default(125,nneigh) + my_energy_scale = optional_default(1.0_dp,energy_scale) + my_length_scale = optional_default(1.0_dp,length_scale) + my_precon_cutoff = optional_default(cutoff(this),precon_cutoff) + my_res2 = optional_default(10.0_dp**(-5.0_dp),res2) + my_mat_mult_max_iter = optional_default(am%minim_at%N*3,mat_mult_max_iter) + my_max_sub = 30 + my_auto_mu = optional_default(.true.,auto_mu) + + call allocate_precon(pr,at,my_precon_id,my_nneigh,my_energy_scale,my_length_scale,my_precon_cutoff,my_res2,my_mat_mult_max_iter,my_max_sub,my_bulk_modulus,my_number_density,my_auto_mu) + !call print(use_method) + n_iter = precondimer(x,v, energy_func_local, gradient_func, build_precon, pr, use_method, convergence_tol, max_steps,efuncroutine=efuncroutine, linminroutine=linminroutine, & + hook=print_hook, hook_print_interval=hook_print_interval, am_data=am_data, status=status, writehessian=writeapproxhessiangrad,gethessian=getapproxhessian) +! n_iter = minim(x, energy_func, gradient_func, use_method, convergence_tol, max_steps, linminroutine, & + ! print_hook, hook_print_interval=hook_print_interval, eps_guess=my_eps_guess, data=am_data, status=status) + + + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + if(am%minim_at%cutoff > 0.0_dp ) call calc_connect(am%minim_at) + n_iter_tot = n_iter + done = .true. + deallocate(am%last_connect_x) + deallocate(x) + + call print("Precon dimer exiting") + Precon_Potential_Dimer = n_iter_tot + + deallocate(am_data) + + end function + + +! function Precon_Potential_MEP(this,allat,at1,at2, method, convergence_tol, max_steps, linminroutine,efuncroutine,k, do_print, print_inoutput, print_cinoutput, & +! do_pos, do_lat, args_str,external_pressure, & +! hook_print_interval, error,precon_id,length_scale,energy_scale,precon_cutoff,nneigh,NatMax,fix_ends,res2,mat_mult_max_iter,max_sub,deltat) +! +! implicit none +! +! type(Potential), intent(in), target :: this !% potential to evaluate energy/forces with +! type(Atoms), intent(inout), target, dimension(:) :: allat +! type(Atoms), intent(in), target :: at1 !% start of the chain +! type(Atoms), intent(in), target :: at2 !% end of the chain !Number of states in the chain +! character(*), intent(in) :: method !% passed to precon_minim() +!! Options for method +!! 'preconSD' - preconditioned steepest descent +!! 'preconCG' - preconditioned safeguarded Polak-Ribiere conjugate gradient +! +! real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ +! !% 'convergence_tol'. +! integer, intent(in) :: max_steps !% Maximum number of steps +! character(*), intent(in),optional :: linminroutine !% Name of the line minisation routine to use +!! Options for linminroutine +!! 'basic' - simple backtracking, each iteration satisfies armijo +!! 'basicpp' - cubic backtracking, tries to satisfy armijo +!! 'standard' - bracket and zoom by cubic interpolation, with bisection as backup, each iteration satisfies wolfe +!! 'none' - no linesearch, relies on estimating alpha from previous gradients etc, very dangerous +! +! character(*), intent(in), optional :: efuncroutine !% How to evaluate change in energy in a step +! real(dp), optional ::k +! logical, optional :: do_print !% if true, print configurations using minim's hook() +! type(inoutput), intent(inout), optional, target :: print_inoutput !% inoutput object to print configs to, needed if do_print is true +! type(cinoutput), intent(inout), optional, target :: print_cinoutput !% cinoutput object to print configs to, needed if do_print is true +! logical, optional :: do_pos, do_lat !% do relaxation w.r.t. positions and/or lattice (if neither is included, do both) +! character(len=*), intent(in), optional :: args_str !% arguments to pass to calc() +! real(dp), dimension(3,3), optional :: external_pressure +! integer, intent(in), optional :: hook_print_interval !% how often to print xyz from hook function +! integer, intent(out), optional :: error !% set to 1 if an error occurred during minimisation +! +! character(*), intent(in),optional :: precon_id +!! Eventually will support multiple preconditioners for now just supports: +!! 'ID' - identity preconditioner (default) i.e. no preconditioner +!! 'C1' - binary connectivity precontioner +!! 'LJ' - connectivity preconditioner based on LJ potential +! +! real(dp), intent(in), optional :: length_scale !length scale of potential (reference lattice distance, approximately will be probably good enough), default 1.0 +! real(dp), intent(in), optional :: energy_scale !prefactor of the potential energy, default 1.0 +! real(dp), intent(in), optional :: precon_cutoff !cutoff radius of the preconditioner, default 1.5, probably set this midway between first and second neighbour distances +! integer, intent(in), optional :: nneigh !maximum number of neighbours expected in precon_cutoff radius, may be removed when this becomes automatic, default is 125 +! integer :: status +! integer, intent(in), optional :: NatMax +! logical, intent(in), optional :: fix_ends +! real(dp), intent(in), optional :: res2 !criteria for the residual squared of the approximate preconditioner inverse, probably dont need to change this +! integer, intent(in), optional :: mat_mult_max_iter !max number of iterations of the preconditioner inverter, probably dont need to change this +! integer, intent(in), optional :: max_sub !max number of iterations of the inverter before restarting +! real(dp), optional :: deltat +! +! integer :: Precon_Potential_MEP +! type (potential_minimise), allocatable, dimension(:) :: am +! real (dp), allocatable, dimension(:) :: x1, x2 +! real (dp), allocatable, dimension(:,:) :: allx +! integer :: I, Nd, Nat +! integer :: am_data_size +! character, dimension(1) :: am_mold +! real(dp) :: deform_grad(3,3) +! logical my_do_print +! character(len=100) :: use_method +! character, allocatable, dimension(:,:) :: am_data +! real(dp) :: var +! real(dp) :: myk +! +! type (precon_data), allocatable, dimension (:) :: pr +! real(dp) :: my_length_scale, my_energy_scale, my_precon_cutoff, my_res2 +! integer :: my_nneigh, my_mat_mult_max_iter,my_max_sub +! character(10) :: my_precon_id +! integer :: n_iter +! logical :: my_fix_ends +! +! my_fix_ends = .true. +! if( present(fix_ends) ) my_fix_ends = fix_ends +! +! my_precon_id = optional_default('ID',precon_id) +! if ((present(length_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then +! call print("No length_scale specified, defaulting to reference lattice distance = 1.0. Unless this is a good estimate preconditioning may work VERY POORLY, if in doubt estimate high, set optional argument length_scale.") +! end if +! +! if ((present(energy_scale) .eqv. .false.) .and. (trim(my_precon_id) == 'LJ')) then +! call print("No energy_scale specified, defaulting to prefactor = 1.0. Unless this is a good estimate preconditioning may work very poorly, set optional argument energy_scale.") +! end if +! +! if ((present(precon_cutoff) .eqv. .false.) .and. (trim(my_precon_id) /= 'ID')) then +! call print("No precon cutoff specified, using the potential's own cutoff = "//cutoff(this)//". Decreasing this may improve performance, set optional argument precon_cutoff.") +! end if +! +! myk = 1.0 +! if (present(k)) myk=k +! +! Nat = size(allat) +! allocate(am(Nat)) +! allocate(pr(Nat)) +! +! ! build the Atoms types +! do I = 1,Nat +! call initialise(allat(I),at1%N,at1%lattice) +! end do +! +! ! just for now most Atoms are copies of at1 +! do I = 1,(Nat-1) +! allat(I) = at1 +! end do +! allat(Nat) = at2 +! +! +! Nd = 9+at1%N*3 +! call print("Nd " // Nd) +! +! ! setup minimization +! use_method = trim(method) +! do I = 1,Nat +! call calc_connect(allat(I)) +! am(I)%minim_at => allat(I) +! am(I)%pos_lat_preconditioner_factor = am(I)%minim_pos_lat_preconditioner*am(I)%minim_at%N +! +! if (present(args_str)) then +! am(I)%minim_args_str = args_str +! else +! am(I)%minim_args_str = "" +! endif +! am(I)%minim_pot => this +! +! if (.not.present(do_pos) .and. .not. present(do_lat)) then +! am(I)%minim_do_pos = .true. +! am(I)%minim_do_lat = .true. +! else +! am(I)%minim_do_pos = optional_default(.false., do_pos) +! am(I)%minim_do_lat = optional_default(.false., do_lat) +! endif +! +! am(I)%external_pressure = 0.0_dp +! if (present(external_pressure)) then +! am(I)%external_pressure = external_pressure +! if( (am(I)%external_pressure(1,1) .fne. am(1)%external_pressure(2,2)) .or. & +! & (am(I)%external_pressure(1,1) .fne. am(1)%external_pressure(3,3)) .or. & +! & (am(I)%external_pressure(1,2) .fne. 0.0_dp) .or. & +! & (am(I)%external_pressure(1,3) .fne. 0.0_dp) .or. & +! & (am(I)%external_pressure(2,1) .fne. 0.0_dp) .or. & +! & (am(I)%external_pressure(2,3) .fne. 0.0_dp) .or. & +! & (am(I)%external_pressure(3,1) .fne. 0.0_dp) .or. & +! & (am(I)%external_pressure(3,2) .fne. 0.0_dp) ) then +! if(trim(use_method) /= 'fire') then +! call print_message('WARNING', 'Anisotrpic pressure is being used. Switching to fire_minim.') +! use_method = 'fire' +! endif +! endif +! endif +! +! my_do_print = optional_default(.false., do_print) +! +! if (my_do_print .and. .not. present(print_inoutput) .and. .not. present(print_cinoutput)) & +! call system_abort("potential_minim: do_print is true, but no print_inoutput or print_cinoutput present") +! +! if (my_do_print) then +! if (present(print_cinoutput)) then +! am(I)%minim_cinoutput_movie => print_cinoutput +! if (this%is_forcemixing) & +! this%forcemixing%minim_cinoutput_movie => print_cinoutput +!#ifdef HAVE_LOCAL_E_MIX +! if (this%is_local_e_mix) & +! this%local_e_mix%minim_cinoutput_movie => print_cinoutput +!#endif /* HAVE_LOCAL_E_MIX */ +!#ifdef HAVE_ONIOM +! if (this%is_oniom) & +! this%oniom%minim_cinoutput_movie => print_cinoutput +!#endif /* HAVE_ONIOM */ +! end if +! else +! nullify(am(I)%minim_cinoutput_movie) +! endif +! +! am(I)%minim_n_eval_e = 0 +! am(I)%minim_n_eval_f = 0 +! +! allocate(am(I)%last_connect_x(Nd)) +! am(I)%last_connect_x=1.0e38_dp +! end do +! +! allocate(x1(Nd)) +! allocate(x2(Nd)) +! allocate(allx(Nd,Nat)) +! +! deform_grad = 0.0_dp; call add_identity(deform_grad) +! call pack_pos_dg(am(1)%minim_at%pos, deform_grad, x1, am(1)%pos_lat_preconditioner_factor) +! call pack_pos_dg(am(Nat)%minim_at%pos, deform_grad, x2, am(Nat)%pos_lat_preconditioner_factor) +! allx(1:Nd,1) = x1 +! allx(1:Nd,Nat) = x2 +! +! ! place atoms linearly along the path +! do I=2,(Nat-1) +! var = (I-1.0)/(Nat-1.0) +! allx(1:Nd,I) = x1 + var*(x2-x1) +! call unpack_pos_dg(allx(1:Nd,I) , am(I)%minim_at%N, am(I)%minim_at%pos, deform_grad, 1.0_dp/am(I)%pos_lat_preconditioner_factor) +! end do +! +! am_data_size = size(transfer(am, am_mold)) +! +! my_nneigh = optional_default(125,nneigh) +! my_energy_scale = optional_default(1.0_dp,energy_scale) +! my_length_scale = optional_default(1.0_dp,length_scale) +! my_precon_cutoff = optional_default(cutoff(this),precon_cutoff) +! my_res2 = optional_default(10.0_dp**(-10.0_dp),res2) +! my_mat_mult_max_iter = optional_default(am(1)%minim_at%N*3,mat_mult_max_iter) +! my_max_sub = optional_default(200,max_sub) +! +! allocate(am_data(am_data_size,Nat)) +! do I=1,Nat +! am_data(1:am_data_size,I) = transfer(am(I), am_data(1:am_data_size,I)) +! call allocate_precon(pr(I),allat(I),my_precon_id,my_nneigh,my_energy_scale,my_length_scale,my_precon_cutoff,my_res2,my_mat_mult_max_iter,my_max_sub) +! end do +! +! n_iter = preconMEP(allx,energy_func, gradient_func, build_precon, pr, use_method,my_fix_ends, convergence_tol, max_steps, linminroutine=linminroutine,efuncroutine=efuncroutine,k=myk, & +! hook=print_hook, hook_print_interval=hook_print_interval, am_data=am_data,status=status,deltat=deltat) +! +! do I=1,Nat +! call unpack_pos_dg(allx(1:Nd,I) , am(I)%minim_at%N, am(I)%minim_at%pos, deform_grad, 1.0_dp/am(I)%pos_lat_preconditioner_factor) +! end do +! +! +! +! end function + + ! compute energy + function energy_func_local(x, am_data, local_energy_inout,gradient_inout) + real(dp) :: x(:) + character(len=1), optional :: am_data(:) + real(dp) :: energy_func_local + real(dp), intent(inout),optional :: local_energy_inout(:), gradient_inout(:) + + real(dp) :: max_atom_rij_change + real(dp) :: deform_grad(3,3) + type(potential_minimise) :: am + real(dp) , allocatable :: f(:,:) + real(dp) :: virial(3,3), deform_grad_inv(3,3) + integer :: i + integer, pointer, dimension(:) :: move_mask, fixed_pot + real(dp), pointer :: minim_applied_force(:,:) + logical :: did_rebuild + + call system_timer("energy_func") + + if (.not. present(am_data)) call system_abort("potential_minimise energy_func must have am_data") + am = transfer(am_data, am) + call atoms_repoint(am%minim_at) + + am%minim_n_eval_e = am%minim_n_eval_e + 1 + + if (size(x) /= am%minim_at%N*3+9) call system_abort("Called energy_func() with size mismatch " // & + size(x) // " /= " // am%minim_at%N // "*3+9") + + ! Note: TB will return 0 for cutoff(am%minim_pot), but TB does its own calc_connect, so doesn't matter + max_atom_rij_change = max_rij_change(am%last_connect_x, x, cutoff(am%minim_pot), & + 1.0_dp/am%pos_lat_preconditioner_factor) + !call print(max_atom_rij_change// ' '//am%minim_at%cutoff // ' '// cutoff(am%minim_pot)) + !call print(am%minim_at%connect%neighbour1(302)%t%int(1,1:)) + + if (current_verbosity() >= PRINT_NERD) call print("energy_func got x " // x, PRINT_NERD) + + call unpack_pos_dg(x, am%minim_at%N, am%minim_at%pos, deform_grad, 1.0_dp/am%pos_lat_preconditioner_factor) + call prep_atoms_deform_grad(deform_grad, am%minim_at, am) + + if(am%minim_at%cutoff > 0.0_dp) call calc_connect(am%minim_at,did_rebuild=did_rebuild) + am%last_connect_x = x + + if (did_rebuild .eqv. .true.) then + call print("Connectivity rebuilt in objective function",PRINT_NERD) + am%connectivity_rebuilt = .true. + end if + + if (current_verbosity() >= PRINT_NERD) then + call print("energy_func using am%minim_at", PRINT_NERD) + call write(am%minim_at, 'stdout') + end if + + if( .not. present(gradient_inout) ) then + call calc(am%minim_pot, am%minim_at, energy = energy_func_local, local_energy = local_energy_inout, args_str = am%minim_args_str) + else + allocate(f(3,am%minim_at%N)) + f = 0.0_dp + virial = 0.0_dp + if (am%minim_do_pos .and. am%minim_do_lat) then + call calc(am%minim_pot, am%minim_at, energy = energy_func_local, local_energy = local_energy_inout, force = f, virial = virial, args_str = am%minim_args_str) + else if (am%minim_do_pos) then + call calc(am%minim_pot, am%minim_at, energy = energy_func_local, local_energy = local_energy_inout, force = f, args_str = am%minim_args_str) + else + call calc(am%minim_pot, am%minim_at, energy = energy_func_local, local_energy = local_energy_inout, virial = virial, args_str = am%minim_args_str) + endif + + + ! zero forces if fixed by potential + if (am%minim_do_pos .and. assign_pointer(am%minim_at, "fixed_pot", fixed_pot)) then + do i=1, am%minim_at%N + if (fixed_pot(i) /= 0) f(:,i) = 0.0_dp + end do + endif + + ! Zero force on any fixed atoms + if (assign_pointer(am%minim_at, 'move_mask', move_mask)) then + do i=1,am%minim_at%N + if (move_mask(i) == 0) f(:,i) = 0.0_dp + end do + end if + + ! add applied forces + if (am%minim_do_pos .and. assign_pointer(am%minim_at, "minim_applied_force", minim_applied_force)) then + f = f + minim_applied_force + energy_func_local = energy_func_local - sum(minim_applied_force*am%minim_at%pos) + endif + + if (current_verbosity() >= PRINT_NERD) then + call print ("energy_func_local got f", PRINT_NERD) + call print(f, PRINT_NERD) + call print ("energy_func_local got virial", PRINT_NERD) + call print(virial, PRINT_NERD) + end if + + virial = virial - am%external_pressure*cell_volume(am%minim_at) + + if (current_verbosity() >= PRINT_NERD) then + call print ("energy_func_local got virial, external pressure subtracted", PRINT_NERD) + call print(virial, PRINT_NERD) + end if + + f = transpose(deform_grad) .mult. f + + call constrain_virial(am%minim_at, virial) + + call inverse(deform_grad, deform_grad_inv) + virial = virial .mult. transpose(deform_grad_inv) + + call pack_pos_dg(-f, -virial, gradient_inout, 1.0_dp/am%pos_lat_preconditioner_factor) + end if + + call print ("energy_func got energy " // energy_func_local, PRINT_NERD) + energy_func_local = energy_func_local + cell_volume(am%minim_at)*trace(am%external_pressure) / 3.0_dp + call print ("energy_func got enthalpy " // energy_func_local, PRINT_NERD) + + call fix_atoms_deform_grad(deform_grad, am%minim_at, am) + call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) + + am_data = transfer(am, am_data) + + call system_timer("energy_func") + + end function energy_func_local + + ! utility function to dump a vector into a file (for checking,debugging) + subroutine writevec(vec,filename) + real(dp) :: vec(:) + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) vec + close(outid) + + end subroutine + + subroutine writemat(mat,filename) + real(dp) :: mat(:,:) + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) mat + close(outid) + + end subroutine + + subroutine writematint(mat,filename) + integer :: mat(:,:) + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) mat + close(outid) + + end subroutine + + subroutine writeapproxhessian(x,data,filename) + + implicit none + + real(dp) :: x(:) + character(len=1) :: data(:) + character(*) :: filename + + type(potential_minimise) :: am + + real(dp),parameter :: eps = 10.0**(-5) + integer,parameter :: nneigh = 500 + real(dp), allocatable :: hess(:) + integer, allocatable :: hessinds(:,:)! ,hxcounts(:) + integer :: I, J, thisneighcount, thisind, thisotherind, II, JJ, hxcount + real(dp), allocatable :: xpp(:), xpm(:), xmm(:), xmp(:), lepp(:), lepm(:), lemm(:), lemp(:) + real(dp) :: fpp, fpm, fmm, fmp + integer :: hx,hy + real(dp) :: fx + am = transfer(data,am) + + !call atoms_repoint(am%minim_at) + !call calc_connect(am%minim_at) + !call calc_dists(am%minim_at) + + !call fix_atoms_deform_grad(deform_grad, am%minim_at, am) + !call pack_pos_dg(am%minim_at%pos, deform_grad, x, am%pos_lat_preconditioner_factor) + + allocate(xpp(size(x)),xpm(size(x)),xmm(size(x)),xmp(size(x))) + allocate(lepp(am%minim_at%N),lepm(am%minim_at%N),lemm(am%minim_at%N),lemp(am%minim_at%N)) + allocate(hess(3*am%minim_at%N*nneigh)) + allocate(hessinds(3*am%minim_at%N*nneigh,2)) + !allocate(hxcounts(3*am%minim_at%N)) + hessinds = 0 + hess = 0.0 + fx = energy_func_local(x,data,lepp) + fx = KahanSum(lepp) + hxcount = 1 + do I = 1,(am%minim_at%N) ! Loop over atoms + call print(I) + thisneighcount = n_neighbours(am%minim_at,I) + !call print(x) + !call exit() + if(thisneighcount > 3*nneigh) then + call print("Not enough memory was allocated for Hessian, increase value of nneigh") + end if + + do II = 1,3 ! Loop over coordinates of atom I + hx = 3*(I-1) + II + + do J = 1,(thisneighcount+1) ! Loop over neighbours of atom I + if (J > 1) then + thisind = neighbour(am%minim_at,I,J-1,index=thisotherind) + else + thisind = I + end if + do JJ = 1,3 ! Loop over coordinates of atom J + hy = 3*(thisind-1) + JJ + + if(hy .eq. hx) then + xpp = x + xmm = x + xpp(hx+9) = xpp(hx+9) + eps + xmm(hx+9) = xmm(hx+9) - eps + + fpp = energy_func_local(xpp,data,lepp) + fmm = energy_func_local(xmm,data,lemm) + fpp = KahanSum(lepp) + fmm = KahanSum(lemm) + hess(hxcount) = (fpp - 2.0*fx + fmm)/(eps**2.0) + hessinds(hxcount,1) = hx + hessinds(hxcount,2) = hx + !call print(I // ' ' // II // ' '// thisind// ' '//JJ//' ' // J // ' '// hx // ' '//hy// ' '//hess(hxcount)) + hxcount = hxcount + 1 + + elseif(hy .gt. hx) then + xpp = x + xpm = x + xmp = x + xmm = x + xpp(hx+9) = xpp(hx+9) + eps + xpp(hy+9) = xpp(hy+9) + eps + xpm(hx+9) = xpm(hx+9) + eps + xpm(hy+9) = xpm(hy+9) - eps + xmp(hx+9) = xmp(hx+9) - eps + xmp(hy+9) = xmp(hy+9) + eps + xmm(hx+9) = xmm(hx+9) - eps + xmm(hy+9) = xmm(hy+9) - eps + + + fpp = energy_func_local(xpp,data,lepp) + fpm = energy_func_local(xpm,data,lepm) + fmp = energy_func_local(xmp,data,lemp) + fmm = energy_func_local(xmm,data,lemm) + fpp = KahanSum(lepp) + fpm = KahanSum(lepm) + fmp = KahanSum(lemp) + fmm = KahanSum(lemm) + hess(hxcount) = (fpp + fmm - fmp - fpm)/(4.0*eps**2.0) + hessinds(hxcount,1) = hx + hessinds(hxcount,2) = hy + !call print(I // ' ' // II // ' '// thisind// ' '//JJ//' ' // J // ' '// hx // ' '//hy// ' '//hess(hxcount)) + hxcount = hxcount + 1 + endif + !call print(fpp// ' '//fpm// ' '//fmp // ' '// fmm// ' '//fpp+fmm-fmp-fpm) + end do + end do + end do + end do + + call writevec(hess,filename // 'hess.dat') + call writematint(hessinds, filename // 'hessinds.dat') + + end subroutine + + function KahanSum(vec) + + real(dp) :: vec(:) + real(dp) :: KahanSum + + integer :: I,N + real(dp) :: C,T,Y + + N = size(vec) + + KahanSum = 0.0 + C = 0.0 + do I = 1,N + y = vec(I) - C + T = KahanSum + Y + C = (T - KahanSum) - Y + KahanSum = T + end do + + end function + + subroutine writeapproxhessiangrad(x,data,filename) + + implicit none + + real(dp) :: x(:) + character(len=1) :: data(:) + character(*) :: filename + + type(potential_minimise) :: am + + real(dp),parameter :: eps = 10.0**(-3) + + real(dp), allocatable :: hess(:) + integer, allocatable :: hessinds(:,:) + real(dp),allocatable :: gp(:,:), gm(:,:), g(:), xm(:) + + integer :: I,J,II,JJ,N + integer :: hx, hy, thisind, hxcount + integer :: nneigh = 500 + integer :: thisneighcount, thisotherind + + N = size(x) + am = transfer(data,am) + allocate(xm(N),g(N)) + allocate(gp(N,N-9)) + allocate(gm(N,N-9)) + allocate(hessinds(3*am%minim_at%N*nneigh,2)) + allocate(hess(3*am%minim_at%N*nneigh)) + + hess = 0.0 + hessinds = 0 + gp = 0.0 + gm = 0.0 + call verbosity_push_decrement() + do I = 10,N + xm = x + xm(I) = xm(I) + 1.0*eps + g = gradient_func(xm,data) + !call print(g) + !call exit() + gp(1:N,I-9) = g + xm(I) = xm(I) - 2.0*eps + g = gradient_func(xm,data) + gm(1:N,I-9) = g + !call print(gp(1:N,I-9)) + end do + call verbosity_pop() + !call exit() + hxcount = 1 + do I = 1,(am%minim_at%N) ! Loop over atoms + !call print(I) + thisneighcount = n_neighbours(am%minim_at,I) + !call print(x) + !call exit() + if(thisneighcount > 3*nneigh) then + call print("Not enough memory was allocated for Hessian, increase value of nneigh") + end if + + do II = 1,3 ! Loop over coordinates of atom I + hx = 3*(I-1) + II + + do J = 1,(thisneighcount+1) ! Loop over neighbours of atom I + if (J > 1) then + thisind = neighbour(am%minim_at,I,J-1,index=thisotherind) + else + thisind = I + end if + do JJ = 1,3 ! Loop over coordinates of atom J + hy = 3*(thisind-1) + JJ + if (hy >= hx) then + !call print(hx //" "//hy//" "//gp(hy+9,hx) // " "// gm(hy+9,hx) // " "// gp(hx+9,hy)// " "//gm(hx+9,hy)) + !call print(gp(1:N,1)) + !call exit() + hess(hxcount) = (gp(hy+9,hx) - gm(hy+9,hx))/(4.0*eps) + (gp(hx+9,hy) - gm(hx+9,hy))/(4.0*eps) + hessinds(hxcount,1) = hx + hessinds(hxcount,2) = hy + !call print(I // ' ' // II // ' '// thisind// ' '//JJ//' ' // J // ' '// hx // ' '//hy// ' '//hess(hxcount)) + hxcount = hxcount + 1 + end if + !call print(fpp// ' '//fpm// ' '//fmp // ' '// fmm// ' '//fpp+fmm-fmp-fpm) + end do + end do + end do + end do + !call exit() + call writevec(hess,filename // 'hess.dat') + call writematint(hessinds, filename // 'hessinds.dat') + !call exit() + end subroutine + + subroutine getapproxhessian(x,data,hessout) + + implicit none + + real(dp),intent(in) :: x(:) + character(len=1),intent(in) :: data(:) + real(dp),intent(inout) :: hessout(:,:) + + type(potential_minimise) :: am + + real(dp),parameter :: eps = 10.0**(-3) + + real(dp),allocatable :: gp(:,:), gm(:,:), g(:), xm(:) + real(dp) :: hesscoeff + integer :: I,J,II,JJ,N + integer :: hx, hy, thisind, hxcount + integer :: nneigh = 500 + integer :: thisneighcount, thisotherind + + N = size(x) + am = transfer(data,am) + allocate(xm(N),g(N)) + allocate(gp(N,N-9)) + allocate(gm(N,N-9)) + + hessout = 0.0_dp + + gp = 0.0 + gm = 0.0 + call verbosity_push_decrement() + do I = 10,N + xm = x + xm(I) = xm(I) + 1.0*eps + g = gradient_func(xm,data) + !call print(g) + !call exit() + gp(1:N,I-9) = g + xm(I) = xm(I) - 2.0*eps + g = gradient_func(xm,data) + gm(1:N,I-9) = g + !call print(gp(1:N,I-9)) + end do + call verbosity_pop() + !call exit() + hxcount = 1 + do I = 1,9 + hessout(I,I) = 1 + end do + do I = 1,(am%minim_at%N) ! Loop over atoms + !call print(I) + thisneighcount = n_neighbours(am%minim_at,I) + !call print(x) + !call exit() + if(thisneighcount > 3*nneigh) then + call print("Not enough memory was allocated for Hessian, increase value of nneigh") + end if + + do II = 1,3 ! Loop over coordinates of atom I + hx = 3*(I-1) + II + + do J = 1,(thisneighcount+1) ! Loop over neighbours of atom I + if (J > 1) then + thisind = neighbour(am%minim_at,I,J-1,index=thisotherind) + else + thisind = I + end if + do JJ = 1,3 ! Loop over coordinates of atom J + hy = 3*(thisind-1) + JJ + if (hy >= hx) then + !call print(hx //" "//hy//" "//gp(hy+9,hx) // " "// gm(hy+9,hx) // " "// gp(hx+9,hy)// " "//gm(hx+9,hy)) + !call print(gp(1:N,1)) + !call exit() + hesscoeff = (gp(hy+9,hx) - gm(hy+9,hx))/(4.0*eps) + (gp(hx+9,hy) - gm(hx+9,hy))/(4.0*eps) + hessout(hx+9,hy+9) = hessout(hx+9,hy+9) + hesscoeff + if (hy > hx) then + hessout(hy+9,hx+9) = hessout(hy+9,hx+9) + hesscoeff + end if + !call print(I // ' ' // II // ' '// thisind// ' '//JJ//' ' // J // ' '// hx // ' '//hy// ' '//hess(hxcount)) + hxcount = hxcount + 1 + end if + !call print(fpp// ' '//fpm// ' '//fmp // ' '// fmm// ' '//fpp+fmm-fmp-fpm) + end do + end do + end do + end do + deallocate(xm,g,gp,gm) + !call exit() + !call exit() + end subroutine + + subroutine getfdhconnectivity(rows,diag,rn,data) + + implicit none + + integer, intent(inout) :: rows(:), diag(:) + character(len=1),intent(in) :: data(:) + integer, intent(out) :: rn + + type(potential_minimise) :: am + integer :: rowsindex + integer :: thisneighcount,thisind + integer :: I, J, II, JJ, hx, hy + integer :: buffer(300) + integer :: bufferindex + integer :: cleanN + + diag(1:9) = (/1, 2, 3, 4, 5, 6, 7, 8, 9/) + rows(1:9) = (/1, 2, 3, 4, 5, 6, 7, 8, 9/) + am = transfer(data,am) + + rowsindex = 10 + do I = 1,(am%minim_at%N) + thisneighcount = n_neighbours(am%minim_at,I) + + do II = 1,3 ! Loop over coordinates of atom I + + hx = 3*(I-1) + II + 9 + diag(hx) = rowsindex + buffer = 3*am%minim_at%N + 10 + bufferindex = 1 + do J = 1,(thisneighcount+1) ! Loop over neighbours of atom I + + if (J > 1) then + thisind = neighbour(am%minim_at,I,J-1) + else + thisind = I + end if + !if (thisind >= I) then + do JJ = 1,3 + hy = 3*(thisind-1) + JJ + 9 + if (hy>=hx) then + buffer(bufferindex) = hy + bufferindex = bufferindex+1 + !rows(rowsindex) = hy + !rowsindex = rowsindex + 1 + end if + end do + !end if + end do + !call print(" ") + !call print(buffer) + call fdhcleaner(buffer,3*am%minim_at%N+10,cleanN) + !call print(buffer(1:cleanN)) + rows(rowsindex:(rowsindex+cleanN-1)) = buffer(1:cleanN) + rowsindex = rowsindex + cleanN + end do + end do + rn = rowsindex-1 + end subroutine + + recursive function qsort( data ) result( sorted ) + integer, dimension(:), intent(in) :: data + integer, dimension(1:size(data)) :: sorted + if ( size(data) > 1 ) then + sorted = (/ qsort( pack( data(2:), abs(data(2:)) <= abs(data(1)) ) ), data(1), qsort( pack( data(2:), abs(data(2:)) > abs(data(1)) ) ) /) + else + sorted = data + endif + end function + + subroutine fdhcleaner(data,data_max,cleanN) + + implicit none + + integer, intent(inout) :: data(:) + integer, intent(in) :: data_max + integer, intent(out) :: cleanN + + integer :: I, N + + N = size(data) + data = qsort(data) + + !call print(data) + !call exit() + I = 1 + do + !call print(I // ' ' // N // ' '// data(I:) // ' '// data_max) + if (data(I) == data(I+1)) then + data(I+1:N-1) = data(I+2:N) + else + I = I+1 + end if + if(I == N .or. data(I) >= data_max) then + exit + end if + end do + cleanN = I-1 + + end subroutine + +end module diff --git a/src/Potentials/Potential_Sum_header.F90 b/src/Potentials/Potential_Sum_header.F90 new file mode 100644 index 0000000000..e4b0f92c29 --- /dev/null +++ b/src/Potentials/Potential_Sum_header.F90 @@ -0,0 +1,32 @@ + + public :: Potential_Sum + type Potential_Sum + type(MPI_context) :: mpi + + type(Potential), pointer :: pot1 => null() + type(Potential), pointer :: pot2 => null() + + logical :: subtract_pot1 + logical :: subtract_pot2 + end type Potential_Sum + + interface Initialise + module procedure Potential_Sum_Initialise + end interface + + interface Finalise + module procedure Potential_Sum_Finalise + end interface + + interface Print + module procedure Potential_Sum_Print + end interface + + interface Cutoff + module procedure Potential_Sum_Cutoff + end interface + + interface Calc + module procedure Potential_Sum_Calc + end interface + diff --git a/src/Potentials/Potential_Sum_routines.F90 b/src/Potentials/Potential_Sum_routines.F90 new file mode 100644 index 0000000000..bd2f3646ca --- /dev/null +++ b/src/Potentials/Potential_Sum_routines.F90 @@ -0,0 +1,174 @@ + + !************************************************************************* + !* + !* Potential_Sum routines + !* + !************************************************************************* + + recursive subroutine Potential_Sum_Initialise(this, args_str, pot1, pot2, mpi, error) + type(Potential_Sum), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(Potential), intent(in), target :: pot1, pot2 + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + INIT_ERROR(error) + + call finalise(this) + + this%pot1 => pot1 + this%pot2 => pot2 + + if (present(mpi)) this%mpi = mpi + + end subroutine Potential_Sum_Initialise + + recursive subroutine Potential_Sum_Finalise(this) + type(Potential_Sum), intent(inout) :: this + + nullify(this%pot1) + nullify(this%pot2) + + end subroutine Potential_Sum_Finalise + + recursive subroutine Potential_Sum_Print(this, file, dict) + type(Potential_Sum), intent(inout) :: this + type(Inoutput), intent(inout), optional :: file + type(Dictionary), intent(inout), optional :: dict + + call print('Potential_Sum:', file=file) + call print('', file=file) + if (associated(this%pot1)) then + call print('Potential 1:', file=file) + call print(this%pot1, file=file, dict=dict) + call print('', file=file) + else + call print('Potential 1 not initialised', file=file) + call print('', file=file) + end if + if (associated(this%pot2)) then + call print('Potential 2:', file=file) + call Print(this%pot2, file=file, dict=dict) + call print('', file=file) + else + call print('Potential 2 not initialised', file=file) + call print('', file=file) + end if + + end subroutine Potential_Sum_Print + + recursive subroutine Potential_Sum_Calc(this, at, args_str, error) + type(Potential_Sum), intent(inout) :: this + type(Atoms), intent(inout) :: at + character(*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + real(dp) :: energy, virial(3,3) + real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:), at_local_virial_ptr(:,:) + + real(dp) :: my_e_1, my_e_2 + real(dp), allocatable :: my_local_e_1(:) + real(dp), allocatable :: my_f_1(:,:), my_local_virial_1(:,:) + real(dp) :: my_virial_1(3,3) + type(Dictionary) :: params + character(STRING_LENGTH) :: calc_energy, calc_force, calc_local_energy, calc_virial, calc_local_virial, calc_args_pot1, calc_args_pot2, my_args_str + logical :: store_contributions + + INIT_ERROR(error) + + call initialise(params) + call param_register(params,"energy", "", calc_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"force", "", calc_force, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"virial", "", calc_virial, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"local_energy", "", calc_local_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"local_virial", "", calc_local_virial, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"calc_args_pot1", "", calc_args_pot1, help_string="additional args_str to pass along to pot1") + call param_register(params,"calc_args_pot2", "", calc_args_pot2, help_string="additional args_str to pass along to pot2") + call param_register(params,"store_contributions", "F", store_contributions, help_string="if true, store contributions to sum with _pot1 and _pot2 suffixes") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Sum_calc args_str')) then + RAISE_ERROR('Potential_Sum_calc failed to parse args_str="'//trim(args_str)//'"', error) + endif + call finalise(params) + + my_args_str = optional_default("", args_str) + + call calc(this%pot1, at, args_str=trim(my_args_str)//" "//calc_args_pot1, error=error) + PASS_ERROR(error) + if (len_trim(calc_energy) > 0) then + call get_param_value(at, trim(calc_energy), my_e_1) + call print("Potential_sum my_e_1 " // my_e_1, PRINT_VERBOSE) + if (store_contributions) call set_param_value(at, trim(calc_energy)//"_pot1", my_e_1) + endif + if (len_trim(calc_virial) > 0) then + call get_param_value(at, trim(calc_virial), my_virial_1) + if (store_contributions) call set_param_value(at, trim(calc_virial)//"_pot1", my_virial_1) + endif + if (len_trim(calc_local_energy) > 0) then + call assign_property_pointer(at, trim(calc_local_energy), at_local_energy_ptr, error=error) + PASS_ERROR(error) + allocate(my_local_e_1(at%N)) + my_local_e_1 = at_local_energy_ptr + if (store_contributions) call add_property(at, trim(calc_local_energy)//"_pot1", at_local_energy_ptr, overwrite=.true.) + endif + if (len_trim(calc_force) > 0) then + call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) + PASS_ERROR(error) + allocate(my_f_1(3, at%N)) + my_f_1 = at_force_ptr + if (store_contributions) call add_property(at, trim(calc_force)//"_pot1", at_force_ptr, overwrite=.true.) + endif + if (len_trim(calc_local_virial) > 0) then + call assign_property_pointer(at, trim(calc_local_virial), at_local_virial_ptr, error=error) + PASS_ERROR(error) + allocate(my_local_virial_1(9, at%N)) + my_local_virial_1 = at_local_virial_ptr + if (store_contributions) call add_property(at, trim(calc_local_virial)//"_pot1", at_local_virial_ptr, overwrite=.true.) + endif + + + call calc(this%pot2, at, args_str=trim(my_args_str)//" "//calc_args_pot2, error=error) + PASS_ERROR(error) + if (len_trim(calc_energy) > 0) then + call get_param_value(at, trim(calc_energy), energy) + call print("Potential_sum my_e_2 " // energy, PRINT_VERBOSE) + if (store_contributions) call set_param_value(at, trim(calc_energy)//"_pot2", energy) + energy = my_e_1 + energy + call set_param_value(at, trim(calc_energy), energy) + endif + if (len_trim(calc_virial) > 0) then + call get_param_value(at, trim(calc_virial), virial) + if (store_contributions) call set_param_value(at, trim(calc_virial)//"_pot2", virial) + virial = my_virial_1 + virial + call set_param_value(at, trim(calc_virial), virial) + endif + if (len_trim(calc_local_energy) > 0) then + if (store_contributions) call add_property(at, trim(calc_local_energy)//"_pot2", at_local_energy_ptr, overwrite=.true.) + at_local_energy_ptr = my_local_e_1 + at_local_energy_ptr + endif + if (len_trim(calc_force) > 0) then + if (store_contributions) call add_property(at, trim(calc_force)//"_pot2", at_force_ptr, overwrite=.true.) + at_force_ptr = my_f_1 + at_force_ptr + end if + if (len_trim(calc_local_virial) > 0) then + if (store_contributions) call add_property(at, trim(calc_local_virial)//"_pot2", at_local_virial_ptr, overwrite=.true.) + at_local_virial_ptr = my_local_virial_1 + at_local_virial_ptr + end if + + if (allocated(my_local_e_1)) deallocate(my_local_e_1) + if (allocated(my_f_1)) deallocate(my_f_1) + if (allocated(my_local_virial_1)) deallocate(my_local_virial_1) + + end subroutine Potential_Sum_Calc + + recursive function Potential_Sum_Cutoff(this) + type(Potential_Sum), intent(in) :: this + real(dp) :: potential_sum_cutoff + + if(associated(this%pot1) .and. associated(this%pot2)) then + potential_sum_cutoff = max(cutoff(this%pot1), cutoff(this%pot2)) + else + potential_sum_cutoff = 0.0_dp + endif + + end function Potential_Sum_Cutoff + diff --git a/src/Potentials/Potential_simple.F90 b/src/Potentials/Potential_simple.F90 new file mode 100644 index 0000000000..fe0bdb2aac --- /dev/null +++ b/src/Potentials/Potential_simple.F90 @@ -0,0 +1,1612 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Potential_simple module +!X +!% The Potential_simple module handles the first-level selection of the +!% desidered force field (tight-binding \texttt{TB_type}, empirical potential \texttt{IP_type} or +!% hybrid description \texttt{FilePot_type}). +!% It contains the interfaces \texttt{Initialise}, \texttt{Finalise}, \texttt{cutoff}, +!% \texttt{Calc}, \texttt{Print}, which have the only role to +!% re-addressing the calls to the corresponding +!% modules. +!% A Potential object simply contains a pointer to the desired force field type +!% (only one of the three can be selected). +!% It is initialised with +!%> call Initialise(pot,arg_str,io_obj,[mpi_obj]) +!% where, \texttt{arg_str} is a string defining the potential type and +!% possible some additional options. +!% For interatomic potentials \texttt{arg_str} will start with 'IP'; there are several different IPs defined: +!% see documentation for the 'IP_module' module. For tight binding, 'arg_str' should start with 'TB'; +!% see docuementation for 'TB_module' for more details. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" +module Potential_simple_module + + use error_module + use system_module, only : dp, inoutput, PRINT_VERBOSE, PRINT_NERD, PRINT_ALWAYS, PRINT_ANALYSIS, current_verbosity, INPUT, optional_default, parse_string, verbosity_push, verbosity_pop + use extendable_str_module + use dictionary_module + use paramreader_module + use linearalgebra_module + use table_module + use atoms_types_module + use atoms_module + use connection_module, only: is_in_subregion + use cinoutput_module + use clusters_module + use partition_module + + use QUIP_Common_module + use MPI_context_module + use IP_module +#ifdef HAVE_TB + use TB_module +#endif + use FilePot_module + use CallbackPot_module + use SocketPot_module + + implicit none + private + + public :: potential_simple + type Potential_Simple + type(MPI_context) :: mpi + + character(len=124) :: type_args_str + + ! only one of these can be allocated at any given time +#ifdef HAVE_TB + type(TB_type), pointer :: tb => null() +#endif + type(IP_type), pointer :: ip => null() + type(FilePot_type), pointer :: filepot => null() + type(CallbackPot_type), pointer :: callbackpot => null() + type(SocketPot_type), pointer :: socketpot => null() + logical :: is_wrapper + logical :: little_clusters + logical :: force_using_fd + logical :: virial_using_fd + + end type Potential_Simple + +!% Initialise a Potential object (selecting the force field) and, if necessary, the input file for potential parameters. + public :: Initialise + public :: Potential_Simple_Filename_Initialise + interface Initialise + module procedure Potential_Simple_Initialise_inoutput, Potential_Simple_Initialise_str + end interface Initialise + +!% Finalise the Potential_Simple object + public :: Finalise + interface Finalise + module procedure Potential_Simple_Finalise + end interface Finalise + +!% Print potential details + public :: Print + interface Print + module procedure Potential_Simple_Print + end interface Print + +!% Set potential cutoff + public :: cutoff + interface cutoff + module procedure Potential_Simple_cutoff + end interface cutoff + +!% Potential_Simple calculator for energy, forces and virial + public :: Calc + interface Calc + module procedure Potential_Simple_Calc + end interface Calc + +!% Set up what you need for parallel calculation + public :: setup_parallel + interface setup_parallel + module procedure Potential_Simple_setup_parallel + end interface setup_parallel + + public :: set_callback + interface set_callback + module procedure Potential_Simple_set_callback + end interface + +#ifdef HAVE_TB + public :: calc_TB_matrices + interface calc_TB_matrices + module procedure Potential_Simple_calc_TB_matrices + end interface calc_TB_matrices +#endif + +contains + + subroutine Potential_Simple_Filename_Initialise(this, args_str, filename, mpi_obj, no_parallel, error) + type(Potential_simple), intent(inout) :: this + character(len=*), intent(in) :: args_str + character(len=*), intent(in) :: filename + type(MPI_context), intent(in), optional :: mpi_obj + logical, intent(in), optional :: no_parallel + integer, intent(out), optional :: error + + type(inoutput) :: io + + INIT_ERROR(error) + + ! WARNING: setting master_only=.true. may lead to failure if not all processes are calling the initialise + call Initialise(io, filename, INPUT, master_only = .true.) + call Initialise(this, args_str, io, mpi_obj, no_parallel, error=error) + PASS_ERROR(error) + call Finalise(io) + + end subroutine Potential_Simple_Filename_Initialise + + subroutine Potential_simple_Initialise_inoutput(this, args_str, io_obj, mpi_obj, no_parallel, error) + type(Potential_simple), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(Inoutput), intent(inout) :: io_obj + type(MPI_context), intent(in), optional :: mpi_obj + logical, intent(in), optional :: no_parallel + integer, intent(out), optional :: error + + type(extendable_str) :: es + logical my_no_parallel + + INIT_ERROR(error) + + my_no_parallel = optional_default(.false., no_parallel) + call Initialise(es) + if (present(mpi_obj)) then + call read(es, io_obj%unit, convert_to_string=.true., mpi_comm = mpi_obj%communicator, mpi_id=mpi_obj%my_proc) + else + call read(es, io_obj%unit, convert_to_string=.true.) + endif + if (my_no_parallel) then + call Initialise(this, args_str, string(es), error=error) + else + call Initialise(this, args_str, string(es), mpi_obj, error=error) + endif + PASS_ERROR(error) + + call Finalise(es) + + end subroutine Potential_Simple_Initialise_inoutput + + subroutine Potential_Simple_Initialise_str(this, args_str, param_str, mpi_obj, error) + type(Potential_Simple), intent(inout) :: this + character(len=*), intent(in) :: args_str + character(len=*), intent(in), optional :: param_str + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + logical is_TB, is_IP, is_FilePot, is_wrapper, is_callbackpot, is_socketpot + type(Dictionary) :: params + + INIT_ERROR(error) + + call Finalise(this) + + call initialise(params) + call param_register(params, 'TB', 'false', is_TB, help_string="If true, a tight-binding model") + call param_register(params, 'IP', 'false', is_IP, help_string="If true, an interatomic potential model") + call param_register(params, 'FilePot', 'false', is_FilePot, help_string="If true, a potential that interacts with another executable by reading/writing files") + call param_register(params, 'wrapper', 'false', is_wrapper, help_string="If true, a hardcoded wrapper function") + call param_register(params, 'CallbackPot', 'false', is_CallbackPot, help_string="If true, a callback potential (calls arbitrary passed by user)") + call param_register(params, 'SocketPot', 'false', is_SocketPot, help_string="If true, a socket potential that communicates via TCP/IP sockets") + call param_register(params, 'little_clusters', 'false', this%little_clusters, help_string="If true, uses little cluster, calculate forces only") + call param_register(params, 'force_using_fd', 'F', this%force_using_fd, & + help_string="If true, and if 'force' is also present in the calc argument list, calculate forces using finite difference.") + call param_register(params, 'virial_using_fd', 'F', this%virial_using_fd, & + help_string="If true, and if 'virial' is also present in the calc argument list, calculate virial using finite difference.") + + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Simple_Initialise_str args_str')) then + call system_abort("Potential_Simple_Initialise_str failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + + if (count( (/is_TB, is_IP, is_FilePot, is_wrapper, is_callbackpot, is_socketpot /) ) /= 1) then + call system_abort("Potential_Simple_Initialise_str found too few or too many Potential_Simple types args_str='"//trim(args_str)//"'") + endif + + if (is_IP) then + allocate(this%ip) + if(present(param_str)) then + if (this%little_clusters) then + call Initialise(this%ip, args_str, param_str, error=error) + else + call Initialise(this%ip, args_str, param_str, mpi_obj, error=error) + end if + PASS_ERROR(error) + else + RAISE_ERROR('Potential_Simple_initialise: no param_str present during IP init', error) + endif +#ifdef HAVE_TB + else if (is_TB) then + allocate(this%tb) + if(present(param_str)) then + if (this%little_clusters) then + call Initialise(this%tb, args_str, param_str, error=error) + else + call Initialise(this%tb, args_str, param_str, mpi_obj=mpi_obj, error=error) + end if + PASS_ERROR(error) + else + RAISE_ERROR('Potential_Simple_initialise: no param_str present during TB init', error) + endif +#else + else if (is_TB) then + RAISE_ERROR('Potential_Simple_initialise: TB support not compiled in', error) +#endif + else if (is_FilePot) then + allocate(this%filepot) + if (this%little_clusters) then + call Initialise(this%filepot, args_str, error=error) + else + call Initialise(this%filepot, args_str, mpi_obj, error=error) + end if + + PASS_ERROR(error) + else if (is_CallbackPot) then + allocate(this%CallbackPot) + if (this%little_clusters) then + call Initialise(this%callbackpot, args_str, error=error) + else + call Initialise(this%callbackpot, args_str, mpi=mpi_obj, error=error) + end if + PASS_ERROR(error) + else if (is_SocketPot) then + allocate(this%SocketPot) + if (this%little_clusters) then + call Initialise(this%socketpot, args_str, error=error) + else + call Initialise(this%socketpot, args_str, mpi=mpi_obj, error=error) + end if + PASS_ERROR(error) + else if(is_wrapper) then + this%is_wrapper = .true. + endif + + if (present(mpi_obj)) this%mpi = mpi_obj + + end subroutine Potential_Simple_Initialise_str + + subroutine Potential_Simple_Finalise(this, error) + type(Potential_Simple), intent(inout) :: this + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if(associated(this%ip)) then + call Finalise(this%ip) + deallocate(this%ip) +#ifdef HAVE_TB + else if(associated(this%tb)) then + call Finalise(this%tb) + deallocate(this%tb) +#endif + elseif(associated(this%filepot)) then + call Finalise(this%filepot) + deallocate(this%filepot) + elseif(associated(this%callbackpot)) then + call Finalise(this%callbackpot) + deallocate(this%callbackpot) + elseif(associated(this%socketpot)) then + call Finalise(this%socketpot) + deallocate(this%socketpot) + end if + this%is_wrapper = .false. + end subroutine Potential_Simple_Finalise + + function Potential_Simple_cutoff(this) + type(Potential_Simple), intent(in) :: this + real(dp) :: Potential_Simple_cutoff + + if(associated(this%ip)) then + Potential_Simple_cutoff = cutoff(this%ip) +#ifdef HAVE_TB + else if(associated(this%tb)) then + Potential_Simple_cutoff = cutoff(this%tb) +#endif + elseif(associated(this%filepot)) then + Potential_Simple_cutoff = cutoff(this%filepot) + elseif(associated(this%callbackpot)) then + Potential_Simple_cutoff = cutoff(this%callbackpot) + elseif(associated(this%socketpot)) then + Potential_Simple_cutoff = cutoff(this%socketpot) + else + Potential_Simple_cutoff = 0.0_dp + end if + end function Potential_Simple_cutoff + + recursive subroutine Potential_Simple_Calc(this, at, args_str, error) + type(Potential_Simple), intent(inout) :: this + type(Atoms), intent(inout) :: at !% The atoms structure to compute energy and forces + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + real(dp) :: energy, virial(3,3), deform(3,3), lat_save(3,3) + real(dp), allocatable :: allpos_save(:,:) + real(dp), pointer :: at_force_ptr(:,:), at_local_energy_ptr(:), at_local_virial_ptr(:,:) + + integer:: i,j,k,n, zero_loc(1) + real(dp):: e_plus, e_minus, pos_save, r_scale, E_scale, cluster_box_buffer + type(Dictionary) :: params + logical :: single_cluster, little_clusters, dummy, do_rescale_r, do_rescale_E, has_cluster_box_buffer + integer :: partition_k_clusters + real(dp) :: partition_nneightol + logical :: partition_do_ripening + character(len=STRING_LENGTH) :: my_args_str, cluster_args_str, new_args_str + integer, pointer, dimension(:) :: hybrid_mark, cluster_index, termindex, modified_hybrid_mark + real(dp), pointer, dimension(:) :: weight_region1, at_prop_ptr_r, cluster_prop_ptr_r + integer, allocatable, dimension(:) :: hybrid_mark_saved + logical, allocatable, dimension(:) :: cluster_mask + real(dp), allocatable, dimension(:) :: weight_region1_saved + real(dp), pointer, dimension(:,:) :: f_cluster + logical :: do_carve_cluster + type(Table) :: cluster_info, cut_bonds, t + integer, pointer :: cut_bonds_p(:,:), old_cut_bonds_p(:,:) + integer :: i_inner, i_outer, n_non_term + type(Atoms) :: cluster + character(len=STRING_LENGTH), target :: calc_force, calc_energy, calc_local_energy, calc_virial, calc_local_virial + logical :: do_calc_force, do_calc_energy, do_calc_local_energy, do_calc_virial, do_calc_local_virial + + integer, pointer :: cluster_mark_p(:), at_prop_ptr_i(:), cluster_prop_ptr_i(:) + integer, pointer :: old_cluster_mark_p(:) + character(len=STRING_LENGTH) :: run_suffix + logical :: force_using_fd, use_ridders + real(dp) :: force_fd_delta + logical :: virial_using_fd + real(dp) :: virial_fd_delta + real(dp) :: origin(3), extent(3,3), extent_inv(3,3), subregion_center(3) + + character(len=STRING_LENGTH) :: read_extra_param_list, read_extra_property_list + character(STRING_LENGTH) :: tmp_params_array(100), copy_keys(100) + integer :: n_copy, n_params, prop_j + + integer, parameter :: ridders_ntab = 10 + real(dp), parameter :: ridders_con = 1.4_dp + real(dp), parameter :: ridders_con2 = ridders_con**2 + real(dp), parameter :: ridders_safe = 2.0_dp + integer :: ridders_itab, ridders_jtab + real(dp) :: ridders_hh, ridders_error, ridders_errort, ridders_fac, ridders_a(ridders_ntab,ridders_ntab) + + + INIT_ERROR(error) + + if (at%N <= 0) then + RAISE_ERROR("Potential_Simple_Calc called with at%N <= 0", error) + endif + + if (present(args_str)) then + call print('Potential_Simple_calc got args_str "'//trim(args_str)//'"', PRINT_VERBOSE) + my_args_str = args_str + else + call print('Potential_Simple_calc got no args_str', PRINT_VERBOSE) + my_args_str = "" + endif + + call initialise(params) + call param_register(params, 'single_cluster', 'F', single_cluster, & + help_string="If true, calculate all active/transition atoms with a single big cluster") + call param_register(params, 'run_suffix', '', run_suffix, & + help_string="suffix to append to hybrid_mark field used") + call param_register(params, 'carve_cluster', 'T', do_carve_cluster, & + help_string="If true, calculate active region atoms by carving out a cluster") + call param_register(params, 'little_clusters', 'F', little_clusters, & + help_string="If true, calculate forces (only) by doing each atom separately surrounded by a little buffer cluster") + call param_register(params, 'partition_k_clusters', '0', partition_k_clusters, & + help_string="If given and K > 1, partition QM core region into K sub-clusters using partition_qm_list() routine") + call param_register(params, 'partition_nneightol', '0.0', partition_nneightol, & + help_string="If given override at%nneightol used to generate connectivity matrix for partitioning") + call param_register(params, 'partition_do_ripening', 'F', partition_do_ripening, & + help_string="If true, enable digestive ripening to refine the METIS-generated K-way partitioning (not yet implemented)") + call param_register(params, 'cluster_box_buffer', '0.0', cluster_box_buffer, has_value_target=has_cluster_box_buffer, & + help_string="If present, quickly cut out atoms in box within cluster_box_radius of any active atoms, rather than doing it properly") + call param_register(params, 'r_scale', '1.0', r_scale, has_value_target=do_rescale_r, & + help_string="rescale calculated positions (and correspondingly forces) by this factor") + call param_register(params, 'E_scale', '1.0', E_scale, has_value_target=do_rescale_E, & + help_string="rescale calculate energies (and correspondingly forces) by this factor") + call param_register(params, 'use_ridders', 'F', use_ridders, & + help_string="If true and using numerical derivatives, use the Ridders method.") + call param_register(params, 'force_using_fd', 'F', force_using_fd, & + help_string="If true, and if 'force' is also present in the argument list, calculate forces using finite difference.") + call param_register(params, 'force_fd_delta', '1.0e-4', force_fd_delta, & + help_string="Displacement to use with finite difference force calculation") + call param_register(params, 'virial_using_fd', 'F', virial_using_fd, & + help_string="If true, and if 'virial' is also present in the argument list, calculate virial using finite difference.") + call param_register(params, 'virial_fd_delta', '1.0e-4', virial_fd_delta, & + help_string="Displacement to use with finite difference virial calculation") + call param_register(params, 'energy', '', calc_energy, & + help_string="If present, calculate energy and put it in field with this string as name") + call param_register(params, 'force', '', calc_force, & + help_string="If present, calculate force and put it in field with this string as name") + call param_register(params, 'local_energy', '', calc_local_energy, & + help_string="If present, calculate local_energy and put it in field with this string as name") + call param_register(params, 'virial', '', calc_virial, & + help_string="If present, calculate virial and put it in field with this string as name") + call param_register(params, 'local_virial', '', calc_local_virial, & + help_string="If present, calculate local_virial and put it in field with this string as name") + call param_register(params, "read_extra_param_list", '', read_extra_param_list, & + help_string="if single_cluster=T and carve_cluster=T, extra params to copy back from cluster") + call param_register(params, "read_extra_property_list", '', read_extra_property_list, & + help_string="if single_cluster=T and carve_cluster=T, extra properties to copy back from cluster") + + if (.not. param_read_line(params, my_args_str, ignore_unknown=.true.,task='Potential_Simple_Calc_str args_str') ) then + RAISE_ERROR("Potential_Simple_calc failed to parse args_str='"//trim(my_args_str)//"'", error) + endif + call finalise(params) + + if(this%force_using_fd) then + force_using_fd = .true. + end if + if(this%virial_using_fd) then + virial_using_fd = .true. + end if + + if (count((/single_cluster, little_clusters, partition_k_clusters > 1/)) > 1) then + RAISE_ERROR('Potential_Simple_calc: single_cluster and little_clusters options are mutually exclusive', error) + endif + + if (len_trim(calc_force) > 0) then + call assign_property_pointer(at, trim(calc_force), at_force_ptr, error=error) + PASS_ERROR(error) + endif + if (len_trim(calc_local_energy) > 0) then + call assign_property_pointer(at, trim(calc_local_energy), at_local_energy_ptr, error=error) + PASS_ERROR(error) + endif + if (len_trim(calc_local_virial) > 0) then + call assign_property_pointer(at, trim(calc_local_virial), at_local_virial_ptr, error=error) + PASS_ERROR(error) + endif + + if (little_clusters) then + + if (.not. this%little_clusters) then + RAISE_ERROR('Potential_Simple_calc: little_clusters=T in calc() args_str but not in initialise() args_str.', error) + end if + + if (len_trim(calc_energy) > 0 .or. len_trim(calc_local_energy) > 0 .or. len_trim(calc_virial) > 0 .or. len_trim(calc_local_virial) > 0 .or. & + len_trim(calc_force) <= 0) then + RAISE_ERROR('Potential_Simple_calc: little_clusters option only supports calculation of forces, not energies, local energies or virials', error) + endif + + ! modified args_str options for create_cluster_info() and carve_cluster() + call initialise(params) + call read_string(params, my_args_str) + call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE + if (do_rescale_r) call set_value(params, 'do_rescale_r', .true.) + cluster_args_str = write_string(params, real_format='f16.8') + call finalise(params) + + ! modified args_str options for potential calc() on clusters + ! must remove "little_clusters" from args_str so that recursion terminates + ! We rescale cluster explicity, so remove from args_str so that underlying potential doesn't do it + call initialise(params) + call read_string(params, my_args_str) + call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE + call remove_value(params, 'little_clusters') + call remove_value(params, 'r_scale') + call remove_value(params, 'E_scale') + new_args_str = write_string(params, real_format='f16.8') + call finalise(params) + + if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then + RAISE_ERROR('Potential_Simple_calc: cannot assign pointer to hybrid_mark property ', error) + endif + + if (.not. any(hybrid_mark == HYBRID_ACTIVE_MARK)) then + at_force_ptr = 0.0_dp + return + end if + + ! Save hybrid_mark and weight_region1, because we're going to overwrite them + allocate(hybrid_mark_saved(at%N)) + hybrid_mark_saved = hybrid_mark + + if (has_property(at, 'weight_region1'//trim(run_suffix))) then + dummy = assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1) + allocate(weight_region1_saved(at%N)) + weight_region1_saved = weight_region1 + end if + + ! call ourselves once for each active or transition atom + at_force_ptr = 0.0_dp + n = 0 + do i=1,at%N + if (hybrid_mark_saved(i) /= HYBRID_ACTIVE_MARK .and. hybrid_mark_saved(i) /= HYBRID_TRANS_MARK) cycle + + if (this%mpi%active) then + n = n + 1 + call print('Potential_Simple_calc: cluster '//n//' around atom '//i//' assigned to proc '//mod(n-1,this%mpi%n_procs)//' of '//(this%mpi%n_procs), PRINT_VERBOSE) + if (mod(n-1, this%mpi%n_procs) .ne. this%mpi%my_proc) cycle + end if + call print('Potential_Simple_calc: constructing little_cluster around atom '//i, PRINT_VERBOSE) + hybrid_mark = HYBRID_NO_MARK + hybrid_mark(i) = HYBRID_ACTIVE_MARK + call create_hybrid_weights(at, cluster_args_str) + cluster_info = create_cluster_info_from_mark(at, cluster_args_str,mark_name='hybrid_mark'//trim(run_suffix),error=error) + PASS_ERROR_WITH_INFO("potential_calc: creating little cluster ="//i//" from hybrid_mark", error) + call carve_cluster(at, cluster_args_str, cluster_info, cluster) + call finalise(cluster_info) + + ! Reassign pointers - create_cluster_info_from_mark() might have broken them + if (has_property(at, 'hybrid_mark'//trim(run_suffix))) & + dummy = assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark) + if (has_property(at, 'weight_region1'//trim(run_suffix))) & + dummy = assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1) + + if (current_verbosity() >= PRINT_NERD) then + call write(cluster, 'stdout', prefix='LITTLE_CLUSTER') + endif + call print('ARGS0 | '//cluster_args_str,PRINT_VERBOSE) + + ! Disable MPI for duration of calc() call, since we're doing parallelisation at level of clusters + call calc(this, cluster, args_str=new_args_str) + if (.not. assign_pointer(cluster, trim(calc_force), f_cluster)) then + RAISE_ERROR('Potential_Simple_calc: small_clusters failed to get a valid '//trim(calc_force)//' property in cluster from calc',error) + endif + + if (do_rescale_r) f_cluster = f_cluster*r_scale + if (do_rescale_E) f_cluster = f_cluster*E_scale + at_force_ptr(:,i) = f_cluster(:,1) + call finalise(cluster) + end do + + if (this%mpi%active) then + call sum_in_place(this%mpi, at_force_ptr) + end if + hybrid_mark = hybrid_mark_saved + deallocate(hybrid_mark_saved) + + if (allocated(weight_region1_saved)) then + weight_region1 = weight_region1_saved + deallocate(weight_region1_saved) + end if + + else if (partition_k_clusters > 1) then + + ! Split QM cluster into K pieces using METIS graph partitioning library call + + if (partition_nneightol == 0.0_dp) partition_nneightol = at%nneightol + call partition_qm_list(at, partition_k_clusters, partition_nneightol, partition_do_ripening) + call write(at, 'partitioned.xyz') + + ! ... FIXME need to loop over the sub-clusters and call ourselves recursively on each + + else if (single_cluster) then + + if (len_trim(calc_energy) > 0 .or. len_trim(calc_local_energy) > 0 .or. len_trim(calc_virial) > 0 .or. len_trim(calc_local_virial) > 0 .or. & + len_trim(calc_force) <= 0) then + RAISE_ERROR('Potential_Simple_calc: single_cluster option only supports calculation of forces, not energies, local energies or virials', error) + endif + + if (.not. assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then + RAISE_ERROR('Potential_Simple_calc: single_cluster cannot assign pointer to hybrid_mark'//trim(run_suffix)//' property ', error) + endif + + if (.not. any(hybrid_mark == HYBRID_ACTIVE_MARK)) then + at_force_ptr = 0.0_dp + return + end if + + ! modified args_str options for create_cluster_info() and carve_cluster() + call initialise(params) + call read_string(params, my_args_str) + call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE + if (do_rescale_r) call set_value(params, 'do_rescale_r', .true.) + cluster_args_str = write_string(params, real_format='f16.8') + call finalise(params) + + ! modified args_str options for potential calc() on clusters + ! must remove "single_cluster" from args_str so that recursion terminates + ! We rescale cluster explicity, so remove from args_str so that underlying potential doesn't do it + call initialise(params) + call read_string(params, my_args_str) + call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE + call remove_value(params, 'single_cluster') + call remove_value(params, 'r_scale') + call remove_value(params, 'E_scale') + new_args_str = write_string(params, real_format='f16.8') + call finalise(params) + + ! call ourselves on a cluster formed from marked atoms + call print('Potential_Simple_calc: constructing single_cluster', PRINT_VERBOSE) + + if (do_carve_cluster) then + call print('Potential_Simple_calc: carving cluster', PRINT_VERBOSE) + + if (has_cluster_box_buffer) then + call print('Doing quick cluster carving using cluster box buffer '//cluster_box_buffer//' A') + + call estimate_origin_extent(at, hybrid_mark == HYBRID_ACTIVE_MARK, cluster_box_buffer, origin, extent) + call matrix3x3_inverse(extent,extent_inv) + subregion_center = origin + 0.5_dp*sum(extent,2) + allocate(cluster_mask(at%n)) + do i=1, at%N + cluster_mask(i) = is_in_subregion(at%pos(:,i), subregion_center, at%lattice, at%g, extent_inv) + end do + call select(cluster, at, mask=cluster_mask, orig_index=.true.) + deallocate(cluster_mask) + + ! move orig_index property to index//run_suffix + call assign_property_pointer(cluster, 'orig_index', cluster_index, error=error) + PASS_ERROR(error) + call add_property(cluster, 'index'//trim(run_suffix), cluster_index) + call remove_property(cluster, 'orig_index', error=error) + PASS_ERROR(error) + ! there are no terminating atoms + call add_property(cluster, 'termindex'//trim(run_suffix), 0) + else + cluster_info = create_cluster_info_from_mark(at, cluster_args_str, mark_name='hybrid_mark'//trim(run_suffix), error=error) + PASS_ERROR_WITH_INFO("potential_calc: creating cluster info from hybrid_mark", error) + + ! Check there are no repeated indices among the non-termination atoms in the cluster + n_non_term = count(cluster_info%int(6,1:cluster_info%n) == 0) + t = int_subtable(cluster_info,(/ (i,i=1,n_non_term) /),(/1/)) + if (multiple_images(t)) then + RAISE_ERROR('Potential_Simple_calc: single_cluster=T not yet implemented when cluster contains repeated periodic images', error) + endif + call finalise(t) + + call carve_cluster(at, cluster_args_str, cluster_info, cluster, mark_name='hybrid_mark'//trim(run_suffix), error=error) + PASS_ERROR_WITH_INFO("potential_calc: carving cluster", error) + call finalise(cluster_info) + end if + if (current_verbosity() >= PRINT_NERD) then + call write(cluster, 'stdout', prefix='CLUSTER') + endif + if (.not. assign_pointer(cluster, 'index'//trim(run_suffix), cluster_index)) then + RAISE_ERROR('Potential_Simple_calc: cluster is missing index property', error) + endif + if (.not. assign_pointer(cluster, 'termindex'//trim(run_suffix), termindex)) then + RAISE_ERROR('Potential_Simple_calc: cluster is missing termindex property', error) + endif + call print('ARGS1 | '//cluster_args_str,PRINT_VERBOSE) + + call calc(this, cluster, args_str=new_args_str, error=error) + PASS_ERROR_WITH_INFO('potential_calc after calc in carve_cluster', error) + + call assign_property_pointer(cluster, trim(calc_force), f_cluster, error=error) + PASS_ERROR_WITH_INFO('Potential_Simple_calc: single_cluster failed to get a valid '//trim(calc_force)//' property in cluster from calc',error) + if (do_rescale_r) f_cluster = f_cluster*r_scale + if (do_rescale_E) f_cluster = f_cluster*E_scale + + ! Reassign pointers - create_cluster_info_from_mark() might have broken them + if (has_property(at, 'hybrid_mark'//trim(run_suffix))) & + dummy = assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark) + + ! copy forces for all active and transition atoms + at_force_ptr = 0.0_dp + do i=1,cluster%N + if (termindex(i) /= 0) cycle ! skip termination atoms + if (hybrid_mark(cluster_index(i)) == HYBRID_ACTIVE_MARK .or. & + hybrid_mark(cluster_index(i)) == HYBRID_TRANS_MARK) & + at_force_ptr(:,cluster_index(i)) = f_cluster(:,i) + end do + nullify(f_cluster) + + ! might need to copy some params from cluster to main Atoms object, for compatibility with filepot + if (len_trim(read_extra_param_list) > 0) then + call parse_string(read_extra_param_list, ':', tmp_params_array, n_params, error=error) + PASS_ERROR(error) + + n_copy = 0 + do i=1,n_params + if (has_key(cluster%params, trim(tmp_params_array(i)))) then + n_copy = n_copy + 1 + copy_keys(n_copy) = tmp_params_array(i) + call print("Potential_simple calc() copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) + else if (has_key(cluster%params, trim(tmp_params_array(i))//trim(run_suffix))) then + n_copy = n_copy + 1 + copy_keys(n_copy) = trim(tmp_params_array(i))//trim(run_suffix) + call print("Potential_simple calc() copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) + end if + end do + call subset(cluster%params, copy_keys(1:n_copy), at%params, out_no_initialise=.true.) + end if + + ! do the same for any extra properties to be copied back + if (len_trim(read_extra_property_list) > 0) then + call parse_string(read_extra_property_list, ':', tmp_params_array, n_params, error=error) + PASS_ERROR(error) + + n_copy = 0 + do i=1,n_params + if (has_key(cluster%properties, trim(tmp_params_array(i)))) then + n_copy = n_copy + 1 + copy_keys(n_copy) = tmp_params_array(i) + call print("Potential_simple calc() copying property key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) + else if (has_key(cluster%properties, trim(tmp_params_array(i))//trim(run_suffix))) then + n_copy = n_copy + 1 + copy_keys(n_copy) = trim(tmp_params_array(i))//trim(run_suffix) + call print("Potential_simple calc() copying property key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) + end if + end do + + do j=1, n_copy + prop_j = lookup_entry_i(cluster%properties, copy_keys(j)) + if (cluster%properties%entries(prop_j)%type == T_INTEGER_A) then + if (.not. has_property(at, copy_keys(j))) call add_property(at, copy_keys(j), 0) + call assign_property_pointer(at, copy_keys(j), at_prop_ptr_i, error=error) + PASS_ERROR(error) + call assign_property_pointer(cluster, copy_keys(j), cluster_prop_ptr_i, error=error) + PASS_ERROR(error) + do i=1,cluster%N + at_prop_ptr_i(cluster_index(i)) = cluster_prop_ptr_i(i) + end do + else if (cluster%properties%entries(prop_j)%type == T_REAL_A) then + if (.not. has_property(at, copy_keys(j))) call add_property(at, copy_keys(j), 0.0_dp) + call assign_property_pointer(at, copy_keys(j), at_prop_ptr_r, error=error) + PASS_ERROR(error) + call assign_property_pointer(cluster, copy_keys(j), cluster_prop_ptr_r, error=error) + PASS_ERROR(error) + do i=1,cluster%N + at_prop_ptr_r(cluster_index(i)) = cluster_prop_ptr_r(i) + end do + else + RAISE_ERROR('unsupported property type '//cluster%properties%entries(prop_j)%type, error) + end if + end do + end if + + call finalise(cluster) + else ! not do_carve_cluster + call print('Potential_Simple_calc: not carving cluster', PRINT_VERBOSE) + cluster_info = create_cluster_info_from_mark(at, trim(cluster_args_str) // " cluster_same_lattice", cut_bonds, mark_name='hybrid_mark'//trim(run_suffix), error=error) + PASS_ERROR_WITH_INFO('potential_calc creating cluster info from hybrid mark with carve_cluster=F', error) + + call add_property(at, 'cluster_mark'//trim(run_suffix), HYBRID_NO_MARK) + call add_property(at, 'old_cluster_mark'//trim(run_suffix), HYBRID_NO_MARK) + if (.not. assign_pointer(at, 'cluster_mark'//trim(run_suffix), cluster_mark_p)) then + RAISE_ERROR("Potential_Simple_calc failed to assing pointer for cluster_mark"//trim(run_suffix)//" pointer", error) + endif + if (.not. assign_pointer(at, 'old_cluster_mark'//trim(run_suffix), old_cluster_mark_p)) then + RAISE_ERROR("Potential_Simple_calc failed to assing pointer for old_cluster_mark"//trim(run_suffix)//" pointer", error) + endif + old_cluster_mark_p = cluster_mark_p + cluster_mark_p = HYBRID_NO_MARK + if (.not. assign_pointer(at, 'modified_hybrid_mark'//trim(run_suffix), modified_hybrid_mark)) then + cluster_mark_p = hybrid_mark + else + cluster_mark_p = modified_hybrid_mark + endif + + !save cut bonds in cut_bonds property + call add_property(at, 'old_cut_bonds'//trim(run_suffix), 0, n_cols=MAX_CUT_BONDS) + if (.not. assign_pointer(at, 'old_cut_bonds'//trim(run_suffix), old_cut_bonds_p)) then + RAISE_ERROR("Potential_Simple_calc failed to assing pointer for cut_bonds pointer", error) + endif + call add_property(at, 'cut_bonds'//trim(run_suffix), 0, n_cols=MAX_CUT_BONDS) + if (.not. assign_pointer(at, 'cut_bonds'//trim(run_suffix), cut_bonds_p)) then + RAISE_ERROR("Potential_Simple_calc failed to assing pointer for cut_bonds pointer", error) + endif + old_cut_bonds_p = cut_bonds_p + cut_bonds_p = 0 + do i=1, cut_bonds%N + i_inner = cut_bonds%int(1,i) + i_outer = cut_bonds%int(2,i) + zero_loc = minloc(cut_bonds_p(:,i_inner)) + if (cut_bonds_p(zero_loc(1),i_inner) == 0) then ! free space for a cut bond + cut_bonds_p(zero_loc(1),i_inner) = i_outer + else + call print("cut_bonds table:", PRINT_VERBOSE) + call print(cut_bonds, PRINT_VERBOSE) + call print("ERROR: Potential_Simple_calc ran out of space to store cut_bonds information", PRINT_ALWAYS) + call print("ERROR: inner atom " // i_inner // " already has cut_bonds to " // cut_bonds_p(:,i_inner) // & + " no space to add cut bond to " // i_outer, PRINT_ALWAYS) + RAISE_ERROR("Potential_Simple_calc out of space to store cut_bonds information", error) + endif + end do + call finalise(cut_bonds) + if (current_verbosity() >= PRINT_ANALYSIS) then + ! prefix should be "UNCARVED_CLUSTER" + call write(at, 'stdout') + endif + call calc(this, at, args_str=new_args_str, error=error) + PASS_ERROR_WITH_INFO('potential_calc after calc with carve_cluster=F', error) + if (do_rescale_r) at_force_ptr = at_force_ptr*r_scale + if (do_rescale_E) at_force_ptr = at_force_ptr*E_scale + endif ! do_carve_cluster + else ! little_clusters and single_cluster are false.. + + ! For IP, call setup_atoms() hook now in case any properties must be added. + ! This must be done *before* we assign pointers to force, local_e etc. + if (associated(this%ip)) then + call setup_atoms(this%ip, at) + end if + + do_calc_force = (len_trim(calc_force) > 0) .and. .not. force_using_fd + do_calc_energy = len_trim(calc_energy) > 0 + do_calc_local_energy = len_trim(calc_local_energy) > 0 + do_calc_virial = (len_trim(calc_virial) > 0) .and. .not. virial_using_fd + do_calc_local_virial = len_trim(calc_local_virial) > 0 + call print("do_calc_force= "//do_calc_force//" calc_force="//trim(calc_force), PRINT_VERBOSE) + call print("force_using_fd= "//force_using_fd, PRINT_VERBOSE) + call print("virial_using_fd= "//virial_using_fd, PRINT_VERBOSE) + call print("do_calc_energy= "//do_calc_energy//" calc_energy="//trim(calc_energy), PRINT_VERBOSE) + call print("do_calc_local_energy= "//do_calc_local_energy//" calc_local_energy="//trim(calc_local_energy), PRINT_VERBOSE) + call print("do_calc_virial= "//do_calc_virial//" calc_virial="//trim(calc_virial), PRINT_VERBOSE) + call print("do_calc_local_virial= "//do_calc_local_virial//" calc_local_virial="//trim(calc_local_virial), PRINT_VERBOSE) + + if(do_calc_virial .or. do_calc_energy .or. do_calc_force .or. do_calc_local_energy .or. do_calc_local_virial) then + if(associated(this%ip)) then + + if (do_calc_local_virial) then + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, f=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, local_e=at_local_energy_ptr, f=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, energy=energy, f=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, f=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, f=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, local_e=at_local_energy_ptr, f=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, energy=energy, f=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, f=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + end if + else ! no local virials + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, f=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, local_e=at_local_energy_ptr, f=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, energy=energy, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, energy=energy, f=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, f=at_force_ptr, virial=virial, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, f=at_force_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, local_e=at_local_energy_ptr, f=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, energy=energy, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, energy=energy, f=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%ip, at, energy=energy, local_e=at_local_energy_ptr, f=at_force_ptr, args_str=args_str, error=error) + end if + end if + endif +#ifdef HAVE_TB + else if(associated(this%tb)) then + + if (do_calc_local_virial) then + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, energy=energy, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, energy=energy, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + end if + else ! no local virials + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, energy=energy, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, energy=energy, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, forces=at_force_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, energy=energy, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, energy=energy, forces=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%tb, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) + end if + end if + endif + +#endif + elseif(associated(this%filepot)) then + + if (do_calc_local_virial) then + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, energy=energy, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, energy=energy, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + end if + else ! no local virials + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, energy=energy, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, energy=energy, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, forces=at_force_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, energy=energy, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, energy=energy, forces=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%filepot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) + end if + end if + endif + + elseif(associated(this%callbackpot)) then + + if (do_calc_local_virial) then + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + end if + else ! no local virials + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, forces=at_force_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, forces=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%callbackpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) + end if + end if + endif + + + elseif(associated(this%socketpot)) then + + if (do_calc_local_virial) then + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, local_virial = at_local_virial_ptr, args_str=args_str, error=error) + end if + end if + else ! no local virials + if (do_calc_virial) then + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, virial=virial, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, virial=virial, args_str=args_str, error=error) + end if + else + if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, forces=at_force_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (.not. do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, args_str=args_str, error=error) + else if (do_calc_energy .and. .not. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, forces=at_force_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. .not. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, args_str=args_str, error=error) + else if (do_calc_energy .and. do_calc_local_energy .and. do_calc_force) then + call Calc(this%socketpot, at, energy=energy, local_e=at_local_energy_ptr, forces=at_force_ptr, args_str=args_str, error=error) + end if + end if + endif + + elseif(this%is_wrapper) then + ! + ! put here hardcoded energy and force functions + ! + !if(present(e)) e = wrapper_energy(at) + !if(present(f)) call wrapper_force(at, f) + RAISE_ERROR("Potential_Simple_Calc: hardcoded wrapper functions are not defined", error) + else + RAISE_ERROR ("Potential_Simple_Calc: Potential_Simple is not initialised", error) + end if + PASS_ERROR_WITH_INFO('potential_calc after actual calc', error) + + if (len_trim(calc_energy) /= 0) then + call set_value(at%params, trim(calc_energy), energy) + call print("Setting parameter `"//trim(calc_energy)//"' to "//energy, PRINT_VERBOSE) + end if + if (len_trim(calc_virial) /= 0) then + call set_value(at%params, trim(calc_virial), virial) + end if + + end if + + if (force_using_fd .and. len_trim(calc_force) > 0) then ! do forces by finite difference + + call print("Calculating force by finite differences with displacement="//force_fd_delta, PRINT_VERBOSE) + + ! must remove 'force_using_fd' from args_str if it's there (and the rest, or properties get overwritten) + call initialise(params) + call read_string(params, my_args_str) + call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE + call remove_value(params, 'force_using_fd') + call remove_value(params, 'force') + call remove_value(params, 'energy') + call remove_value(params, 'local_energy') + call remove_value(params, 'virial') + call set_value(params, "energy", "fd_energy") + new_args_str = write_string(params, real_format='f16.8') + call finalise(params) + call print("calc_force="//trim(calc_force), PRINT_ANALYSIS) + call print("New_args_str: "//new_args_str, PRINT_ANALYSIS) + + + if(use_ridders) then + do i = 1, at%N + do k = 1, 3 + pos_save = at%pos(k,i) + ridders_hh = force_fd_delta + + at%pos(k,i) = pos_save + ridders_hh + if(at%cutoff > 0) call calc_dists(at) + call calc(this, at, args_str=new_args_str, error=error) + call get_param_value(at, "fd_energy", e_plus, error=error) + PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) + + at%pos(k,i) = pos_save - ridders_hh + if(at%cutoff > 0) call calc_dists(at) + call calc(this, at, args_str=new_args_str, error=error) + call get_param_value(at, "fd_energy", e_minus, error=error) + PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) + + ridders_a(1,1) = (e_plus - e_minus) / (2.0_dp*ridders_hh) + ridders_error = huge(1.0_dp) + + do ridders_itab = 2, ridders_ntab + ridders_hh = ridders_hh / ridders_con + + at%pos(k,i) = pos_save + ridders_hh + if(at%cutoff > 0) call calc_dists(at) + call calc(this, at, args_str=new_args_str, error=error) + call get_param_value(at, "fd_energy", e_plus, error=error) + PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) + + at%pos(k,i) = pos_save - ridders_hh + if(at%cutoff > 0) call calc_dists(at) + call calc(this, at, args_str=new_args_str, error=error) + call get_param_value(at, "fd_energy", e_minus, error=error) + PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) + + ridders_a(1,ridders_itab) = (e_plus - e_minus) / (2.0_dp*ridders_hh) + ridders_fac = ridders_con2 + + do ridders_jtab = 2, ridders_itab + ridders_a(ridders_jtab,ridders_itab) = (ridders_a(ridders_jtab-1,ridders_itab)*ridders_fac - & + ridders_a(ridders_jtab-1,ridders_itab-1))/(ridders_fac-1.0_dp) + ridders_fac = ridders_con2*ridders_fac + ridders_errort = max(abs(ridders_a(ridders_jtab,ridders_itab)-ridders_a(ridders_jtab-1,ridders_itab)), & + abs(ridders_a(ridders_jtab,ridders_itab)-ridders_a(ridders_jtab-1,ridders_itab-1))) + + if( ridders_errort <= ridders_error ) then + ridders_error = ridders_errort + at_force_ptr(k,i) = -ridders_a(ridders_jtab,ridders_itab) + endif + enddo ! jtab + + if( abs(ridders_a(ridders_itab,ridders_itab)-ridders_a(ridders_itab-1,ridders_itab-1) ) >= ridders_SAFE*ridders_error) exit + enddo ! itab + at%pos(k,i) = pos_save + !error_force(alpha,i) = abs(error) + enddo ! k + enddo ! i + else + do i=1,at%N + do k=1,3 + pos_save = at%pos(k,i) + at%pos(k,i) = pos_save + force_fd_delta + if(at%cutoff > 0) call calc_dists(at) + call calc(this, at, args_str=new_args_str, error=error) + call get_param_value(at, "fd_energy", e_plus, error=error) + PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) + at%pos(k,i) = pos_save - force_fd_delta + if(at%cutoff > 0) call calc_dists(at) + call calc(this, at, args_str=new_args_str, error=error) + call get_param_value(at, "fd_energy", e_minus, error=error) + PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd forces failed to get energy property fd_energy", error) + at%pos(k,i) = pos_save + if(at%cutoff > 0) call calc_dists(at) + at_force_ptr(k,i) = (e_minus-e_plus)/(2.0_dp*force_fd_delta) ! force is -ve gradient + end do + end do + endif + + call remove_value(at%params, "fd_energy") + call print("Done with finite difference force calculation", PRINT_VERBOSE) + end if + if(virial_using_fd .and. len_trim(calc_virial) > 0) then ! do virial by finite difference + call print("Calculating virial by finite differences with displacement="//virial_fd_delta, PRINT_VERBOSE) + + ! must remove 'virial_using_fd' from args_str if it's there (and the rest, or properties get overwritten) + call initialise(params) + call read_string(params, my_args_str) + call set_value(params, 'run_suffix', run_suffix) ! ensure that run_suffix doesn't have value T_NONE + call remove_value(params, 'virial_using_fd') + call remove_value(params, 'force') + call remove_value(params, 'energy') + call remove_value(params, 'local_energy') + call remove_value(params, 'virial') + call set_value(params, "energy", "fd_energy") + new_args_str = write_string(params, real_format='f16.8') + call finalise(params) + + call print("Virial finite difference calculation: new_args_str=`"//new_args_str//"'", PRINT_VERBOSE) + + allocate(allpos_save(3,at%N)) + allpos_save = at%pos + lat_save = at%lattice + do i=1,3 + do j=i,3 + + deform = 0.0_dp + call add_identity(deform) + deform(i,j) = deform(i,j) + virial_fd_delta + if(i /= j) deform(j,i) = deform(j,i) + virial_fd_delta + call set_lattice(at, matmul(deform,lat_save), scale_positions=.true.) + if(at%cutoff > 0) call calc_dists(at) +! call verbosity_push(PRINT_ANALYSIS) +! call print(at) +! call verbosity_pop() + call calc(this, at, args_str=new_args_str, error=error) +! call verbosity_push(PRINT_ANALYSIS) +! call print(at) +! call verbosity_pop() + call get_param_value(at, "fd_energy", e_plus, error=error) + PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd virial failed to get energy property fd_energy", error) + + deform = 0.0_dp + call add_identity(deform) + deform(i,j) = deform(i,j) - virial_fd_delta + if(i /= j) deform(j,i) = deform(j,i) - virial_fd_delta + call set_lattice(at, matmul(deform,lat_save), scale_positions=.true.) + if(at%cutoff > 0) call calc_dists(at) + call calc(this, at, args_str=new_args_str, error=error) + call get_param_value(at, "fd_energy", e_minus, error=error) + PASS_ERROR_WITH_INFO("Potential_Simple_calc doing fd virial failed to get energy property fd_energy", error) + virial(i,j) = -(e_plus-e_minus)/(2.0_dp*virial_fd_delta) + virial(j,i) = virial(i,j) + end do + end do + call set_value(at%params, trim(calc_virial), virial) + at%pos = allpos_save + call set_lattice(at, lat_save, scale_positions=.false.) + call remove_value(at%params, "fd_energy") + if(at%cutoff > 0) call calc_dists(at) + deallocate(allpos_save) + call print("Done with finite difference virial calculation", PRINT_VERBOSE) + end if + end if + + end subroutine Potential_Simple_Calc + +! function Potential_Simple_Brief_Description(this) result desc +! type(Potential_Simple), intent(inout) :: this +! character(30), intent(out) :: desc +! if(associated(this%tb)) then +! desc = '' +! elseif(associated(this%ip)) then +! desc = Brief_Description(this%ip) +! elseif(associated(this%filepot)) then +! desc = '' +! elseif(this%is_wrapper) then +! desc = '' +! else +! call system_abort ("Potential_Simple_Brief_Description: Potential_Simple is not initialised") +! end if +! +! end function Potential_Simple_Brief_Description + + + subroutine Potential_Simple_Print(this, file, dict, error) + type(Potential_Simple), intent(inout) :: this + type(Inoutput), intent(inout),optional:: file + type(Dictionary), intent(inout), optional :: dict + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if(associated(this%ip)) then + call Print(this%ip, file=file, dict=dict) +#ifdef HAVE_TB + else if(associated(this%tb)) then + call Print(this%tb, file=file) +#endif + elseif(associated(this%filepot)) then + call Print(this%filepot, file=file) + elseif(associated(this%callbackpot)) then + call Print(this%callbackpot, file=file) + elseif(associated(this%socketpot)) then + call Print(this%socketpot, file=file) + elseif(this%is_wrapper) then + call print("Potential_Simple: wrapper Potential_Simple") + else + RAISE_ERROR ("Potential_Simple_Print: no potential type is set", error) + end if + + end subroutine Potential_Simple_Print + + subroutine Potential_Simple_setup_parallel(this, at, args_str, error) + type(Potential_Simple), intent(inout) :: this + type(Atoms), intent(inout) :: at !% The atoms structure to compute energy and forces + character(len=*), intent(in) :: args_str + integer, intent(out), optional :: error + + real(dp) :: e + real(dp), allocatable :: f(:,:) + type(Dictionary) :: params + character(STRING_LENGTH) :: calc_energy, calc_force + + INIT_ERROR(error) + + call initialise(params) + call param_register(params, "energy", "", calc_energy, help_string="If present, calculate energy. Also name of parameter to put energy into") + call param_register(params, "force", "", calc_force, help_string="If present, calculate forces. Also name of property to put forces into") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Potential_Simple_setup_parallel args_str')) then + RAISE_ERROR("Potential_Simple_setup_parallel failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + + if(associated(this%ip)) then + if (len_trim(calc_energy) > 0) then + if (len_trim(calc_force) > 0) then + allocate(f(3,at%n)) + call setup_parallel(this%ip, at, energy=e, f=f, args_str=args_str) + deallocate(f) + else + call setup_parallel(this%ip, at, energy=e, args_str=args_str) + endif + else + if (len_trim(calc_force) > 0) then + allocate(f(3,at%n)) + call setup_parallel(this%ip, at, f=f, args_str=args_str) + deallocate(f) + else + call setup_parallel(this%ip, at, args_str=args_str) + endif + endif +#ifdef HAVE_TB + else if(associated(this%tb)) then + return +#endif + elseif(associated(this%filepot)) then + return + elseif(associated(this%callbackpot)) then + return + elseif(associated(this%socketpot)) then + return + elseif(this%is_wrapper) then + return + else + RAISE_ERROR ("Potential_Simple_Print: Potential_Simple is not initialised", error) + end if + + if (allocated(f)) deallocate(f) + + end subroutine Potential_Simple_setup_parallel + + subroutine Potential_Simple_set_callback(this, callback, error) + type(Potential_Simple), intent(inout) :: this + interface + subroutine callback(at) + integer, intent(in) :: at(12) + end subroutine callback + end interface + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if (.not. associated(this%callbackpot)) then + RAISE_ERROR('Potential_Simple_set_callback: this Potential_Simple is not a CallbackPot', error) + endif + call set_callback(this%callbackpot, callback) + + end subroutine Potential_Simple_set_callback + +#ifdef HAVE_TB + subroutine Potential_Simple_calc_TB_matrices(this, at, args_str, Hd, Sd, Hz, Sz, dH, dS, index, error) + type(Potential_Simple), intent(inout) :: this + type(atoms), intent(inout) :: at + character(len=*), intent(in), optional :: args_str + real(dp), intent(inout), optional, dimension(:,:) :: Hd, Sd + complex(dp), intent(inout), optional, dimension(:,:) :: Hz, Sz + real(dp), intent(inout), optional, dimension(:,:,:,:) :: dH, dS + integer, intent(in), optional :: index + integer, intent(out), optional :: error + + character(len=STRING_LENGTH) :: my_args_str + real(dp), allocatable, dimension(:,:) :: tmp_forces + + INIT_ERROR(error) + + if (.not. associated(this%tb)) then + RAISE_ERROR('Potential_Simple_copy_TB_matrices: this Potential_Simple is not a TB potential', error) + endif + + my_args_str = "" + if (present(args_str)) my_args_str = trim(args_str) + + allocate(tmp_forces(3,at%N)) + call calc(this%tb, at, args_str=trim(my_args_str), forces=tmp_forces, dH=dH, dS=dS, index=index) + call copy_matrices(this%tb, Hd, Sd, Hz, Sz, index=index) + deallocate(tmp_forces) + + end subroutine Potential_Simple_calc_TB_matrices + +#endif + +end module Potential_Simple_module diff --git a/src/Potentials/QC_QUIP_Wrapper.F90 b/src/Potentials/QC_QUIP_Wrapper.F90 new file mode 100644 index 0000000000..ee1e485766 --- /dev/null +++ b/src/Potentials/QC_QUIP_Wrapper.F90 @@ -0,0 +1,310 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield, +! H0 X Tamas K Stenczel +! H0 X +! H0 X Copyright 2006-2021. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X wrapper for quasicontinuum code to use QUIP potentials +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module QC_QUIP_Wrapper_module + use system_module, only : dp, system_initialise, INPUT, system_abort, & + verbosity_push, verbosity_pop, PRINT_SILENT, operator(//), inoutput, PRINT_ALWAYS + use extendable_str_module, only : extendable_str, string, read + use table_module, only : table, wipe, int_part + use atoms_types_module, only : atoms, assign_pointer, add_property, add_property_from_pointer + use atoms_module, only : initialise, calc_connect, set_lattice, assignment(=) + use potential_module, only : potential, initialise, finalise, calc + use mpi_context_module, only : mpi_context + implicit none + private + + type (Potential), save :: pot + type (Atoms), save :: at + type (MPI_context), save :: mpi_glob + + real(dp), private :: vacuum_dist = 5.0_dp + + public :: verbosity_push, verbosity_pop, PRINT_SILENT + public :: QC_QUIP_initialise, QC_QUIP_calc, MakeLine + type (Potential), save :: pot_ip +#if defined(HAVE_LOCAL_E_MIX) || defined(HAVE_ONIOM) + type (Potential), save :: pot_qm + public :: QC_QUIP_initialise_hybrid, QC_QUIP_calc_hybrid +#endif + +contains + + subroutine MakeLine(str1, real1, str2, real2, strout) + character(len = *), intent(in) :: str1, str2 + real(dp), intent(in) :: real1, real2 + character(len = *), intent(out) :: strout + + strout = trim(str1) // real1 // trim(str2) // real2 + end subroutine MakeLine + + subroutine QC_QUIP_initialise(str, err) + character(len = *), intent(in) :: str + integer, intent(out), optional :: err + + type(inoutput) :: params + type(extendable_str) :: params_str + + call system_initialise() + call Initialise(params, "quip_params.xml", INPUT) + call Initialise(params_str) + call read(params_str, params%unit) + + call Initialise(pot, args_str = str, param_str = string(params_str)) + if (present(err)) err = 0 + end subroutine + + subroutine QC_QUIP_calc(Lz, pos, Z, w, local_e, f, err) + real(dp), intent(in) :: Lz + real(dp), intent(in) :: pos(:, :) + integer, intent(in) :: Z(:) + real(dp), intent(in) :: w(:) + real(dp), intent(out) :: local_e(:), f(:, :) + integer, intent(out) :: err + + integer N + real(dp), pointer :: weight(:) + + if (.not. matching_array_sizes(Z, pos, w, local_e, f, N)) then + call system_abort("Mismatched array sizes in QC_QUIP_calc") + endif + + call qc_setup_atoms(at, N, Lz, pos, Z) + + if (.not. assign_pointer(at, "weight", weight)) then + call add_property(at, "weight", 0.0_dp) + if (.not. assign_pointer(at, "weight", weight)) & + call system_abort("QC_QUIP_calc Failed to add weight property to at") + weight = w + endif + + call add_property_from_pointer(at, "local_energy", local_e) + call add_property_from_pointer(at, "force", f) + call calc(pot, at, args_str = "local_energy force", error = err) + + end subroutine + +#if defined(HAVE_LOCAL_E_MIX) || defined(HAVE_ONIOM) + subroutine QC_QUIP_initialise_hybrid(str_ip, str_qm, str_hybrid, lat, Z, pos, err) + + ! moduel level imports + ! gcc10: these are needed to be discovered by the compiler to realise that there + ! in indeed no argument mismatch + use system_module, only : print + use potential_module, only : print + + character(len = *), intent(in) :: str_ip, str_qm, str_hybrid + real(dp), intent(in), optional :: lat(3, 3) + integer, intent(in), optional :: Z(:) + real(dp), intent(in), optional :: pos(:, :) + integer, intent(out), optional :: err + + type(inoutput) :: params + type(extendable_str) :: params_str + ! type(atoms) :: bulk + integer :: n_present + + call system_initialise(enable_timing = .true.) + + call initialise(mpi_glob) + + call initialise(params, "quip_params.xml", INPUT) + call initialise(params_str) + call read(params_str, params%unit, convert_to_string = .true., & + mpi_comm = mpi_glob%communicator, mpi_id = mpi_glob%my_proc) + + ! call initialise(pot_ip, str_ip, string(params_str)) + ! call initialise(pot_qm, str_qm, string(params_str), mpi_obj = mpi_glob) + + call finalise(params_str) + + n_present = count ((/present(lat), present(Z), present(pos) /)) + if (n_present == 3) then + if (.not. matching_array_sizes(Z, pos = pos)) then + call system_abort("Mismatched array sizes in QC_QUIP_initialise_hybrid") + endif + call print("QC_QUIP_initialise_hybrid was passed in bulk structure, & + &ignoring it", PRINT_ALWAYS) + ! call initialise(bulk, size(Z), lat) + ! bulk%Z = Z + ! bulk%pos = pos + ! call initialise(pot, str_hybrid, pot_qm, pot_ip, bulk) + ! call finalise(bulk) + call initialise(pot, str_hybrid // " init_args_pot2=" // trim(str_ip) & + // " init_args_pot1=" // trim(str_qm), mpi_obj = mpi_glob) + else if (n_present == 0) then + call initialise(pot, str_hybrid // " init_args_pot2=" // trim(str_ip) & + // " init_args_pot1=" // trim(str_qm), mpi_obj = mpi_glob) + else + call system_abort("QC_QUIP_initialise_hybrid called with some but not & + &all of lat, Z, pos present") + endif + + call print("QC_QUIP using hybrid potential:") + call print(pot) + + if (present(err)) err = 0 + end subroutine QC_QUIP_initialise_hybrid + + subroutine QC_QUIP_calc_hybrid(Lz, pos, Z, w, qm_list, local_e, f, & + qm_region_width, buffer_region_width, err) + real(dp), intent(in) :: Lz + real(dp), intent(in) :: pos(:, :) + integer, intent(in) :: Z(:) + real(dp), intent(in) :: w(:) + integer, intent(in) :: qm_list(:) + real(dp), intent(out) :: local_e(:), f(:, :) + integer, intent(in) :: qm_region_width, buffer_region_width + integer, intent(out) :: err + + integer i, N + real(dp), pointer :: weight(:) + integer, pointer :: hybrid(:) + type(table) :: qm_table + + if (.not. matching_array_sizes(Z, pos, w, local_e, f, N)) then + call system_abort("Mismatched array sizes in QC_QUIP_calc_hybrid") + endif + + if (buffer_region_width > 0 .and. pot%is_oniom) & + call system_abort("Don't do buffer_region_width = " // & + buffer_region_width // " > 0 with ONIOM") + + call qc_setup_atoms(at, N, Lz, pos, Z) + + call add_property(at, "weight", 0.0_dp) + call add_property(at, "hybrid", 0) + + if (.not. assign_pointer(at, "weight", weight)) & + call system_abort("QC_QUIP_calc Failed to add weight property to at") + if (.not. assign_pointer(at, "hybrid", hybrid)) & + call system_abort("QC_QUIP_calc Failed to add hybrid property to at") + + call calc_connect(at) + + hybrid = 0 + call wipe(qm_table) + do i = 1, size(qm_list) + if (qm_list(i) > at%N) call system_abort("QC_QUIP_calc_hybrid got qm_list(" // i // ")=" & + // qm_list(i) // " > at%N=" // at%N) + if (qm_list(i) > 0) call append(qm_table, (/ qm_list(i), 0, 0, 0 /)) + end do + + hybrid(int_part(qm_table, 1)) = 1 + + weight = w + + call add_property_from_pointer(at, "local_energy", local_e) + call add_property_from_pointer(at, "force", f) + + if (pot%is_oniom) then + call calc(pot, at, args_str = "local_energy force calc_weights" // & + " core_hops=" // qm_region_width // " transition_hops=0 buffer_hops=" // buffer_region_width, error = err) + else + call calc(pot, at, args_str = "local_energy force calc_weights" // & + " core_hops=" // qm_region_width // " transition_hops=0 buffer_hops=" // buffer_region_width // & + " solver=DIAG_GF SCF_GLOBAL_U GLOBAL_U=20.0", error = err) + endif + + end subroutine QC_QUIP_calc_hybrid +#endif + + function matching_array_sizes(Z, pos, w, local_e, f, N) + integer, intent(in) :: Z(:) + real(dp), intent(in), optional :: pos(:, :) + real(dp), intent(in), optional :: w(:) + real(dp), intent(in), optional :: local_e(:), f(:, :) + integer, intent(out), optional :: N + logical :: matching_array_sizes + + integer my_N + + matching_array_sizes = .true. + my_N = size(Z) + if (present(N)) N = my_N + if (present(pos)) then + if (3 /= size(pos, 1) .or. my_N /= size(pos, 2)) then + matching_array_sizes = .false. + return + endif + endif + if (present(w)) then + if (my_N /= size(w)) then + matching_array_sizes = .false. + return + endif + endif + if (present(local_e)) then + if (my_N /= size(local_e)) then + matching_array_sizes = .false. + return + endif + endif + if (present(f)) then + if (3 /= size(f, 1) .or. my_N /= size(f, 2)) then + matching_array_sizes = .false. + return + endif + endif + + end function matching_array_sizes + + subroutine qc_setup_atoms(at, N, Lz, pos, Z) + type(atoms), intent(inout) :: at + integer, intent(in) :: N + real(dp), intent(in) :: Lz + real(dp), intent(in) :: pos(:, :) + integer, intent(in) :: Z(:) + + real(dp) :: lattice(3, 3) + + lattice = 0.0_dp + lattice(1, 1) = maxval(pos(1, :)) - minval(pos(1, :)) + vacuum_dist + lattice(2, 2) = maxval(pos(2, :)) - minval(pos(2, :)) + vacuum_dist + lattice(3, 3) = Lz + + if (at%N /= N) then + call Initialise(at, N, lattice) + end if + call set_lattice(at, lattice, scale_positions = .false.) + at%pos = pos + at%Z = Z + + call calc_connect(at) + end subroutine qc_setup_atoms + +end module QC_QUIP_Wrapper_module diff --git a/src/Potentials/QUIP_Common.F90 b/src/Potentials/QUIP_Common.F90 new file mode 100644 index 0000000000..18c8a2157c --- /dev/null +++ b/src/Potentials/QUIP_Common.F90 @@ -0,0 +1,113 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X QUIP_Common_module +!X +!% The QUIP_Common module contains functions to get the atom type from +!% the atomic number or +!% a token from a string. +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module QUIP_Common_module + +use FoX_sax, only: xml_t, dictionary_t, haskey, getvalue, open_xml_string, close_xml_t, parse +use System_module + +implicit none + +private + +public :: get_type +public :: xml_t, dictionary_t, open_xml_string, close_xml_t, parse +public :: QUIP_FoX_get_value + +public :: pauli_sigma +complex(dp), parameter :: pauli_sigma(2,2,3) = reshape( (/ & + cmplx(0.0_dp,0.0_dp,dp), cmplx(1.0_dp,0.0_dp,dp), cmplx(1.0_dp,0.0_dp,dp), cmplx(0.0_dp,0.0_dp,dp), & + cmplx(0.0_dp,0.0_dp,dp), cmplx(0.0_dp,1.0_dp,dp), -cmplx(0.0_dp,1.0_dp,dp), cmplx(0.0_dp,0.0_dp,dp), & + cmplx(1.0_dp,0.0_dp,dp), cmplx(0.0_dp,0.0_dp,dp), cmplx(0.0_dp,0.0_dp,dp), cmplx(-1.0_dp,0.0_dp,dp) /) , & + (/ 2, 2, 3 /) ) + + +contains + +!% Get the type from the atomic number, with error checking. +function get_type(type_of_atomic_num, Z, unknown_type) + integer, intent(in) :: type_of_atomic_num(:) + integer, intent(in) :: Z + logical, intent(out), optional :: unknown_type + + integer get_type + + if (Z < 1 .or. Z > size(type_of_atomic_num)) then + if(present(unknown_type)) then + unknown_type = .true. + get_type = -1 + return + else + call system_abort ('get_type: Atomic number '//Z //' out of range') + endif + endif + + if (type_of_atomic_num(Z) == 0) then + if(present(unknown_type)) then + unknown_type = .true. + get_type = -1 + return + else + call system_abort ('get_type: Atomic number '//Z//' does not correspond to a defined type') + endif + endif + + get_type = type_of_atomic_num(Z) + if(present(unknown_type)) unknown_type = .false. + +end function get_type + +subroutine QUIP_FoX_get_value(attributes, key, val, status) + type(dictionary_t), intent(in) :: attributes + character(len=*), intent(in) :: key + character(len=*), intent(inout) :: val + integer, intent(out), optional :: status + + if (HasKey(attributes,key)) then + val = GetValue(attributes, trim(key)) + if (present(status)) status = 0 + else + val = "" + if (present(status)) status = 1 + endif +end subroutine + +end module QUIP_Common_module diff --git a/src/Potentials/QUIP_module.F90 b/src/Potentials/QUIP_module.F90 new file mode 100644 index 0000000000..5ba9e7ca52 --- /dev/null +++ b/src/Potentials/QUIP_module.F90 @@ -0,0 +1,74 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X QUIP Module +!X +!% This is a container module. ``use" it if you want to use QUIP stuff +!%> use QUIP_module +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module QUIP_internals_module + use functions_module + use quip_common_module + use ewald_module + use IPModel_lj_module + use IPModel_sw_module + use IPModel_tersoff_module +#ifdef HAVE_TB + use tb_mixing_module + use tb_common_module + use tbmodel_bowler_module + use tbmodel_dftb_module + use tbmodel_nrl_tb_module +#endif +end module QUIP_internals_module + +!% This is a container module. ``use" it if you want to use QUIP stuff +!%> use QUIP_module +module QUIP_module + use mpi_context_module + use scalapack_module + use matrix_module + use rs_sparsematrix_module +#ifdef HAVE_TB + use approxfermi_module + use tb_kpoints_module + use tbmodel_module + use tbmatrix_module + use tbsystem_module + use tb_greensfunctions_module + use tb_module +#endif + use ip_module + use potential_module +end module QUIP_module diff --git a/src/Potentials/RS_SparseMatrix.F90 b/src/Potentials/RS_SparseMatrix.F90 new file mode 100644 index 0000000000..01020ecd8b --- /dev/null +++ b/src/Potentials/RS_SparseMatrix.F90 @@ -0,0 +1,2146 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X RS_SparseMatrix module +!X +!% Module for sparce matrix math. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module RS_SparseMatrix_module + +use System_module +use MPI_Context_module +use linearalgebra_module +use Atoms_module +use ScaLAPACK_module +use Matrix_module +implicit none +private + +public :: RS_SparseMatrixL +type RS_SparseMatrixL + integer :: N = 0, N_dense_rows = 0 + integer :: n_blocks = 0, data_size = 0 + integer, allocatable :: block_size(:), dense_row_of_row(:) + integer, allocatable :: row_indices(:), data_ptrs(:) + integer, allocatable :: col(:) + + integer :: cur_row = 1, cur_col_offset = 0 +end type RS_SparseMatrixL + +public :: RS_SparseMatrixD +type RS_SparseMatrixD + type(RS_SparseMatrixL) :: l + real(dp), allocatable :: data(:) +end type RS_SParseMatrixD + +public :: RS_SparseMatrixZ +type RS_SparseMatrixZ + type(RS_SparseMatrixL) :: l + complex(dp), allocatable :: data(:) +end type RS_SParseMatrixZ + +public :: Initialise +interface Initialise + module procedure RS_SparseMatrixL_Initialise_at, RS_SparseMatrixL_Initialise_prod + module procedure RS_SparseMatrixD_Initialise_at, RS_SparseMatrixD_Initialise_prod + module procedure RS_SparseMatrixZ_Initialise_at, RS_SparseMatrixZ_Initialise_prod +end interface Initialise + + +public :: Finalise +interface Finalise + module procedure RS_SparseMatrixL_Finalise + module procedure RS_SparseMatrixD_Finalise + module procedure RS_SparseMatrixZ_Finalise +end interface Finalise + +public :: Wipe +interface Wipe + module procedure RS_SparseMatrixL_Wipe + module procedure RS_SparseMatrixD_Wipe + module procedure RS_SparseMatrixZ_Wipe +end interface Wipe + +public :: Zero +interface Zero + module procedure RS_SparseMatrixD_Zero + module procedure RS_SparseMatrixZ_Zero +end interface Zero + +public :: Print +interface Print + module procedure RS_SparseMatrixD_Print + module procedure RS_SparseMatrixZ_Print +end interface Print + +public :: Print_simple +interface Print_simple + module procedure RS_SparseMatrixD_Print_simple +! module procedure RS_SparseMatrixZ_Print +end interface Print_simple + +public :: copy +interface copy + module procedure copy_dd_dsp + module procedure copy_zd_zsp + module procedure copy_dsp_dd + module procedure copy_zsp_zd +end interface + +public :: matrix_product_sub +interface matrix_product_sub + module procedure matrix_product_sub_dsp_dsp_dsp, matrix_product_sub_dden_dden_dsp + module procedure matrix_product_sub_zsp_zsp_zsp + module procedure matrix_product_sub_dden_dden_zsp, matrix_product_sub_zden_dden_zsp, matrix_product_sub_zden_zden_zsp + module procedure matrix_product_sub_zden_zden_dsp +end interface matrix_product_sub + +public :: add_block +interface add_block + module procedure RS_SparseMatrixD_add_block + module procedure RS_SparseMatrixZ_add_block +end interface + +public :: partial_TraceMult +interface partial_TraceMult + module procedure RS_SparseMatrix_partial_TraceMult_dden_dsp + module procedure RS_SparseMatrix_partial_TraceMult_dden_zsp + module procedure RS_SparseMatrix_partial_TraceMult_zden_dsp + module procedure RS_SparseMatrix_partial_TraceMult_zden_zsp + module procedure RS_SparseMatrix_partial_TraceMult_dsp_zden + module procedure RS_SparseMatrix_partial_TraceMult_dsp_dden + module procedure RS_SparseMatrix_partial_TraceMult_zsp_zden +end interface partial_TraceMult + +public :: TraceMult +interface TraceMult + module procedure RS_SparseMatrix_TraceMult_dden_dsp + module procedure RS_SparseMatrix_TraceMult_dden_zsp + module procedure RS_SparseMatrix_TraceMult_zden_dsp + module procedure RS_SparseMatrix_TraceMult_zden_zsp + module procedure RS_SparseMatrix_TraceMult_dsp_zden + module procedure RS_SparseMatrix_TraceMult_dsp_dden + module procedure RS_SparseMatrix_TraceMult_zsp_zden +end interface TraceMult + +public :: multDiagRL +interface multDiagRL + module procedure RS_SparseMatrixD_multDiagRL_d, RS_SparseMatrixZ_multDiagRL_d +end interface multDiagRL + +public :: check_sparse +interface check_sparse + module procedure check_sparse_layout +end interface check_sparse + +interface get_dense_block + module procedure get_dense_blockD, get_dense_blockZ +end interface get_dense_block + +contains + +subroutine RS_SparseMatrixL_Initialise_at(this, at, first_orb_of_atom, cutoff, mpi_obj) + type(RS_SparseMatrixL), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: first_orb_of_atom(:) + real(dp), intent(in), optional :: cutoff + type(MPI_context), intent(in), optional :: mpi_obj + + integer :: i, ji, j + integer :: cur_data_pos, cur_row_offset + integer, allocatable :: neighbour_sorted(:) + real(dp), allocatable :: neighbour_distance_sorted(:) + integer :: n_uniq + + real(dp) :: my_cutoff + + if (present(mpi_obj)) then + call System_abort("No support for parallel sparse matrix") + end if + + my_cutoff = HUGE(1.0_dp) + if (present(cutoff)) my_cutoff = cutoff + + call Wipe(this) + + this%N = at%N + if (size(first_orb_of_atom) /= at%N+1) call system_abort("RS_SparseMatrixL_Initialise_at size(first_orb_of_atom) = " // size(first_orb_of_atom) // " != at%N+1 = " // (at%N+1)) + this%N_dense_rows = first_orb_of_atom(at%N+1)-1 + + allocate(this%block_size(at%N)) + call ALLOC_TRACE("RS_L_init block_size", size(this%block_size)*INTEGER_SIZE) + allocate(this%dense_row_of_row(at%N)) + call ALLOC_TRACE("RS_L_init dense_row_of_row", size(this%dense_row_of_row)*INTEGER_SIZE) + this%block_size(:) = first_orb_of_atom(2:at%N+1)-first_orb_of_atom(1:at%N) + this%dense_row_of_row(:) = first_orb_of_atom(1:at%N) + + allocate(this%row_indices(at%N+1)) + call ALLOC_TRACE("RS_L_init row_indices", size(this%row_indices)*INTEGER_SIZE) + + this%n_blocks = 0 + this%data_size = 0 + + this%row_indices = 0 + do i=1, at%N + + allocate(neighbour_sorted(n_neighbours(at, i))) + allocate(neighbour_distance_sorted(n_neighbours(at, i))) + do ji=1, n_neighbours(at, i) + neighbour_sorted(ji) = neighbour(at, i, ji, neighbour_distance_sorted(ji)) + end do + call sort_array(neighbour_sorted, r_data=neighbour_distance_sorted) + + n_uniq = uniq_minval(neighbour_sorted, neighbour_distance_sorted) + + if(n_uniq == 0) call system_abort("atoms with no neighbours, not even itself!?!?!?") + + do ji=1, n_uniq + j = neighbour_sorted(ji) + if (ji > 1) then + if (j == neighbour_sorted(ji-1)) cycle + end if + + ! insert data for regular element + if (neighbour_distance_sorted(ji) <= my_cutoff) then + this%row_indices(i+1) = this%row_indices(i+1) + 1 + this%n_blocks = this%n_blocks + 1 + this%data_size = this%data_size + this%block_size(i)*this%block_size(j) + end if + + end do + + deallocate(neighbour_sorted) + deallocate(neighbour_distance_sorted) + + end do + + this%row_indices(1) = 1 + do i=2, at%N+1 + this%row_indices(i) = this%row_indices(i) + this%row_indices(i-1) + end do + + if (this%n_blocks == 0) then + allocate(this%col(1)) + allocate(this%data_ptrs(1)) + else + allocate(this%col(this%n_blocks)) + allocate(this%data_ptrs(this%n_blocks)) + end if + call ALLOC_TRACE("RS_L_init col", size(this%col)*INTEGER_SIZE) + call ALLOC_TRACE("RS_L_init data_ptrs", size(this%data_ptrs)*INTEGER_SIZE) + + cur_data_pos = 1 + do i=1, at%N + + allocate(neighbour_sorted(n_neighbours(at, i))) + allocate(neighbour_distance_sorted(n_neighbours(at, i))) + do ji=1, n_neighbours(at, i) + neighbour_sorted(ji) = neighbour(at, i, ji, neighbour_distance_sorted(ji)) + end do + call sort_array(neighbour_sorted, r_data=neighbour_distance_sorted) + + n_uniq = uniq_minval(neighbour_sorted, neighbour_distance_sorted) + + if(n_uniq == 0) call system_abort("atoms with no neighbours, not even itself!?!?!?") + + cur_row_offset = 0 + + do ji=1, n_uniq + j = neighbour_sorted(ji) + if (ji > 1) then + if (j == neighbour_sorted(ji-1)) cycle + end if + + ! insert data for regular element + if (neighbour_distance_sorted(ji) <= my_cutoff) then + this%col(this%row_indices(i)+cur_row_offset) = j + this%data_ptrs(this%row_indices(i)+cur_row_offset) = cur_data_pos + cur_row_offset = cur_row_offset + 1 + cur_data_pos = cur_data_pos + this%block_size(i)*this%block_size(j) + end if + + end do + + deallocate(neighbour_sorted) + deallocate(neighbour_distance_sorted) + + end do +end subroutine RS_SparseMatrixL_Initialise_at + +function uniq_minval(i_data, r_data) + integer, intent(inout) :: i_data(:) + real(dp), intent(inout) :: r_data(:) + integer :: uniq_minval + + real(dp) :: min_r_data + integer :: data_len, i, ii, imin, imax + + data_len = size(i_data) + if (data_len == 0) then + uniq_minval=0 + return + end if + + ii = 1 + do i=1, data_len + if (i == 1) then + imin = i + cycle + end if + if (i_data(i) /= i_data(i-1)) then + imax = i-1 + min_r_data = minval(r_data(imin:imax)) + i_data(ii) = i_data(imin) + r_data(ii) = min_r_data + ii = ii + 1 + imin = i + end if + end do + min_r_data = minval(r_data(imin:data_len)) + i_data(ii) = i_data(imin) + r_data(ii) = min_r_data + + uniq_minval = ii +end function uniq_minval + +subroutine RS_SparseMatrixD_Initialise_at(this, at, first_orb_of_atom, cutoff, mpi_obj) + type(RS_SparseMatrixD), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: first_orb_of_atom(:) + real(dp), intent(in), optional :: cutoff + type(MPI_context), intent(in), optional :: mpi_obj + + call Wipe(this) + + call Initialise(this%l, at, first_orb_of_atom, cutoff, mpi_obj) + + allocate(this%data(this%l%data_size)) + call ALLOC_TRACE("RS_D_init data", size(this%data)*REAL_SIZE) +end subroutine RS_SparseMatrixD_Initialise_at + +subroutine RS_SparseMatrixZ_Initialise_at(this, at, first_orb_of_atom, cutoff, mpi_obj) + type(RS_SparseMatrixZ), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: first_orb_of_atom(:) + real(dp), intent(in), optional :: cutoff + type(MPI_context), intent(in), optional :: mpi_obj + + call Wipe(this) + + call Initialise(this%l, at, first_orb_of_atom, cutoff, mpi_obj) + + allocate(this%data(this%l%data_size)) + call ALLOC_TRACE("RS_Z_init data", size(this%data)*COMPLEX_SIZE) +end subroutine RS_SparseMatrixZ_Initialise_at + +subroutine RS_SparseMatrixL_Initialise_prod(this, al, bl, mpi_obj) + type(RS_SparseMatrixL), intent(inout) :: this + type(RS_SparseMatrixL), intent(in) :: al, bl + type(MPI_context), intent(in), optional :: mpi_obj + + integer is, kk, ks, jj, js + integer cur_entry, p, pd + logical, allocatable :: col_used(:) + integer, allocatable :: col_list(:) + + if (present(mpi_obj)) then + call System_abort("No support for mpi_obj in sparse matrix") + end if + + this%N = al%N + this%N_dense_rows = al%N_dense_rows + allocate(this%block_size(this%N)) + call ALLOC_TRACE("RS_L_init_product block_size", size(this%block_size)*INTEGER_SIZE) + allocate(this%dense_row_of_row(this%N)) + call ALLOC_TRACE("RS_L_init_product dense_row_of_row", size(this%dense_row_of_row)*INTEGER_SIZE) + this%block_size = al%block_size + this%dense_row_of_row = al%dense_row_of_row + + allocate(this%row_indices(this%N+1)) + call ALLOC_TRACE("RS_L_init_product row_indices", size(this%row_indices)*INTEGER_SIZE) + this%row_indices = 0 + this%n_blocks = 0 + this%data_size = 0 + + allocate(col_used(al%N)) + allocate(col_list(al%N)) + col_used = .false. + + do is=1, al%N + do kk=al%row_indices(is), al%row_indices(is+1)-1 + ks = al%col(kk) + cur_entry = 0 + do jj=bl%row_indices(ks), bl%row_indices(ks+1)-1 + js = bl%col(jj) + if (.not.col_used(js)) then + cur_entry = cur_entry + 1 + col_list(cur_entry) = js + col_used(js) = .true. + this%n_blocks = this%n_blocks + 1 + this%data_size = this%data_size + al%block_size(is)*bl%block_size(js) + end if + end do + end do + do jj=1, cur_entry + col_used(col_list(jj)) = .false. + end do + end do + + allocate(this%col(this%n_blocks)) + allocate(this%data_ptrs(this%n_blocks)) + call ALLOC_TRACE("RS_L_init_product col", size(this%col)*INTEGER_SIZE) + call ALLOC_TRACE("RS_L_init_product data_ptrs", size(this%data_ptrs)*INTEGER_SIZE) + + p = 1 + pd = 1 + do is=1, al%N + this%row_indices(is) = p + do kk=al%row_indices(is), al%row_indices(is+1)-1 + ks = al%col(kk) + cur_entry = 0 + do jj=bl%row_indices(ks), bl%row_indices(ks+1)-1 + js = bl%col(jj) + if (.not.col_used(js)) then + cur_entry = cur_entry + 1 + col_list(cur_entry) = js + col_used(js) = .true. + + this%col(p) = js + this%data_ptrs(p) = pd + p = p + 1 + pd = pd + al%block_size(is)*bl%block_size(js) + end if + end do + end do + do jj=1, cur_entry + col_used(col_list(jj)) = .false. + end do + end do + this%row_indices(al%N+1) = p + + deallocate(col_used) + deallocate(col_list) +end subroutine RS_SparseMatrixL_Initialise_prod + +subroutine RS_SparseMatrixD_Initialise_prod(this, al, bl, mpi_obj) + type(RS_SparseMatrixD), intent(inout) :: this + type(RS_SparseMatrixL), intent(in) :: al, bl + type(MPI_context), intent(in), optional :: mpi_obj + + call Wipe(this) + + call Initialise(this%l, al, bl) + + allocate(this%data(this%l%data_size)) + call ALLOC_TRACE("RS_D_init_product data", size(this%data)*REAL_SIZE) + +end subroutine RS_SparseMatrixD_Initialise_prod + +subroutine RS_SparseMatrixZ_Initialise_prod(this, al, bl, mpi_obj) + type(RS_SparseMatrixZ), intent(inout) :: this + type(RS_SparseMatrixL), intent(in) :: al, bl + type(MPI_context), intent(in), optional :: mpi_obj + + call Wipe(this) + + call Initialise(this%l, al, bl) + + allocate(this%data(this%l%data_size)) + call ALLOC_TRACE("RS_Z_init_product data", size(this%data)*COMPLEX_SIZE) + +end subroutine RS_SparseMatrixZ_Initialise_prod + +subroutine RS_SparseMatrixL_Finalise(this) + type(RS_SparseMatrixL), intent(inout) :: this + + call Wipe(this) +end subroutine RS_SparseMatrixL_Finalise + +subroutine RS_SparseMatrixD_Finalise(this) + type(RS_SparseMatrixD), intent(inout) :: this + + call Wipe(this) +end subroutine RS_SparseMatrixD_Finalise + +subroutine RS_SparseMatrixZ_Finalise(this) + type(RS_SparseMatrixZ), intent(inout) :: this + + call Wipe(this) +end subroutine RS_SparseMatrixZ_Finalise + +subroutine RS_SparseMatrixL_Wipe(this) + type(RS_SparseMatrixL), intent(inout) :: this + + call DEALLOC_TRACE("RS_L_wipe block_size", size(this%block_size)*INTEGER_SIZE) + if (allocated(this%block_size)) deallocate(this%block_size) + call DEALLOC_TRACE("RS_L_wipe dense_row_of_row", size(this%dense_row_of_row)*INTEGER_SIZE) + if (allocated(this%dense_row_of_row)) deallocate(this%dense_row_of_row) + call DEALLOC_TRACE("RS_L_wipe row_indices", size(this%row_indices)*INTEGER_SIZE) + if (allocated(this%row_indices)) deallocate(this%row_indices) + call DEALLOC_TRACE("RS_L_wipe data_ptrs", size(this%data_ptrs)*INTEGER_SIZE) + if (allocated(this%data_ptrs)) deallocate(this%data_ptrs) + call DEALLOC_TRACE("RS_L_wipe col", size(this%col)*INTEGER_SIZE) + if (allocated(this%col)) deallocate(this%col) + + this%N = 0 + this%N_dense_rows = 0 + this%n_blocks = 0 + this%data_size = 0 +end subroutine RS_SparseMatrixL_Wipe + +subroutine RS_SparseMatrixD_Wipe(this) + type(RS_SparseMatrixD), intent(inout) :: this + + call Wipe(this%l) + call DEALLOC_TRACE("RS_D_wipe data", size(this%data)*REAL_SIZE) + if (allocated(this%data)) deallocate(this%data) + +end subroutine RS_SparseMatrixD_Wipe + +subroutine RS_SparseMatrixZ_Wipe(this) + type(RS_SparseMatrixZ), intent(inout) :: this + + call Wipe(this%l) + call DEALLOC_TRACE("RS_Z_wipe data", size(this%data)*COMPLEX_SIZE) + if (allocated(this%data)) deallocate(this%data) + +end subroutine RS_SparseMatrixZ_Wipe + +subroutine RS_SparseMatrixD_Zero(this, d_mask, od_mask) + type(RS_SparseMatrixD), intent(inout) :: this + logical, intent(in), optional :: d_mask(:), od_mask(:) + + integer i, ji, j, block_nr, block_nc + + if (present(d_mask) .or. present(od_mask)) then + do i=1, this%l%N + block_nr = this%l%block_size(i) + do ji=this%l%row_indices(i), this%l%row_indices(i+1)-1 + j = this%l%col(ji) + block_nc = this%l%block_size(j) + if (present(d_mask) .and. i == j) then + if (d_mask(i)) this%data(this%l%data_ptrs(ji):this%l%data_ptrs(ji)+block_nr*block_nc-1) = 0.0_dp + end if + if (present(od_mask) .and. i /= j) then + if (od_mask(i) .or. od_mask(j)) this%data(this%l%data_ptrs(ji):this%l%data_ptrs(ji)+block_nr*block_nc-1) = 0.0_dp + end if + end do + end do + else + this%data = 0.0_dp + end if + +end subroutine RS_SparseMatrixD_Zero + +subroutine RS_SparseMatrixZ_Zero(this, d_mask, od_mask) + type(RS_SparseMatrixZ), intent(inout) :: this + logical, intent(in), optional :: d_mask(:), od_mask(:) + + integer i, ji, j, block_nr, block_nc + + if (present(d_mask) .or. present(od_mask)) then + do i=1, this%l%N + block_nr = this%l%block_size(i) + do ji=this%l%row_indices(i), this%l%row_indices(i+1)-1 + j = this%l%col(ji) + block_nc = this%l%block_size(j) + if (present(d_mask) .and. i == j) then + if (d_mask(i)) this%data(this%l%data_ptrs(ji):this%l%data_ptrs(ji)+block_nr*block_nc-1) = 0.0_dp + end if + if (present(od_mask) .and. i /= j) then + if (od_mask(i) .or. od_mask(j)) this%data(this%l%data_ptrs(ji):this%l%data_ptrs(ji)+block_nr*block_nc-1) = 0.0_dp + end if + end do + end do + else + this%data = 0.0_dp + end if + +end subroutine RS_SparseMatrixZ_Zero + +subroutine RS_SparseMatrixD_Print(this,file) + type(RS_SparseMatrixD), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer :: i, j + integer :: block_nr, block_nc + + call Print ('RS_SparseMatrixD : N ' // this%l%N, file=file) + + call Print ('RS_SparseMatrixD : n_blocks data_size ' // this%l%n_blocks // " " // this%l%data_size, file=file) + + do i=1, this%l%N + call Print ('RS_SparseMatrixD : row, block_size dense_row ' // i // " " // this%l%block_size(i) // " " // & + this%l%dense_row_of_row(i), file=file) + do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 + call Print ("RS_SparseMatrixD entry j "// j // " col " // this%l%col(j) // " data_ptr " // this%l%data_ptrs(j), & + file=file) + block_nr = this%l%block_size(i) + block_nc = this%l%block_size(this%l%col(j)) + call Print(reshape( & + this%data(this%l%data_ptrs(j):this%l%data_ptrs(j)+block_nr*block_nc-1),(/block_nr,block_nc/) ), & + file=file) + end do + end do + +end subroutine RS_SparseMatrixD_Print + +subroutine RS_SparseMatrixZ_Print(this,file) + type(RS_SparseMatrixZ), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer :: i, j + integer :: block_nr, block_nc + + call Print('RS_SparseMatrixZ : ', file=file) + + call Print ('RS_SparseMatrixZ : N ' // this%l%N, file=file) + + call Print ('RS_SparseMatrixZ : n_blocks data_size ' // this%l%n_blocks // this%l%data_size, file=file) + + do i=1, this%l%N + call Print ('RS_SparseMatrixZ : row, block_size dense_row ' // i // " " // this%l%block_size(i) // " " // & + this%l%dense_row_of_row(i), file=file) + do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 + call Print ("RS_SparseMatrixZ entry j " // j // " col " // this%l%col(j) // " data_ptr " // this%l%data_ptrs(j), file=file) + block_nr = this%l%block_size(i) + block_nc = this%l%block_size(this%l%col(j)) + call Print(reshape( & + this%data(this%l%data_ptrs(j):this%l%data_ptrs(j)+block_nr*block_nc-1),(/block_nr,block_nc/) ), file=file) + end do + end do + +end subroutine RS_SparseMatrixZ_Print + +subroutine RS_SparseMatrixD_Print_simple(this,file) + type(RS_SparseMatrixD), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer :: i, tj, j, ii, jj + integer :: block_nr, block_nc + integer :: n_entries + + n_entries = 0 + do i=1, this%l%N + block_nr = this%l%block_size(i) + do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 + block_nc = this%l%block_size(this%l%col(j)) + n_entries = n_entries + block_nr*block_nc + end do + end do + + call print(this%l%N // " " // n_entries, file=file) + + do i=1, this%l%N + block_nr = this%l%block_size(i) + do tj=this%l%row_indices(i), this%l%row_indices(i+1)-1 + j = this%l%col(tj) + do ii=1, block_nr + do jj=1, block_nc + call print((this%l%dense_row_of_row(i)+ii-1) // " " // (this%l%dense_row_of_row(j)+jj-1) // " " // & + this%data(this%l%data_ptrs(tj)+ii-1+(jj-1)*block_nr), file=file) + end do + end do + end do + end do +end subroutine RS_SparseMatrixD_Print_simple + +subroutine copy_dsp_dd(this, dense) + type(RS_SparseMatrixD), intent(in) :: this + real(dp), intent(inout), dimension(:,:) :: dense + + integer :: i, tj, j, ii, jj + integer :: block_nr, block_nc + integer :: n_entries + + !if (any(shape(dense) /= (/this%l%N, this%l%N/))) call system_abort("size of dense matrix wrong: expecting "//this%l%N) + + n_entries = 0 + do i=1, this%l%N + block_nr = this%l%block_size(i) + do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 + block_nc = this%l%block_size(this%l%col(j)) + n_entries = n_entries + block_nr*block_nc + end do + end do + + do i=1, this%l%N + block_nr = this%l%block_size(i) + do tj=this%l%row_indices(i), this%l%row_indices(i+1)-1 + j = this%l%col(tj) + do ii=1, block_nr + do jj=1, block_nc + dense(this%l%dense_row_of_row(i)+ii-1, & + this%l%dense_row_of_row(j)+jj-1) = & + this%data(this%l%data_ptrs(tj)+ii-1+(jj-1)*block_nr) + end do + end do + end do + end do +end subroutine copy_dsp_dd + +subroutine copy_zsp_zd(this, dense) + type(RS_SparseMatrixZ), intent(in) :: this + complex(dp), intent(inout), dimension(:,:) :: dense + + integer :: i, tj, j, ii, jj + integer :: block_nr, block_nc + integer :: n_entries + + if (any(shape(dense) /= (/this%l%N, this%l%N/))) call system_abort("size of dense matrix wrong: expecting "//this%l%N) + + n_entries = 0 + do i=1, this%l%N + block_nr = this%l%block_size(i) + do j=this%l%row_indices(i), this%l%row_indices(i+1)-1 + block_nc = this%l%block_size(this%l%col(j)) + n_entries = n_entries + block_nr*block_nc + end do + end do + + do i=1, this%l%N + block_nr = this%l%block_size(i) + do tj=this%l%row_indices(i), this%l%row_indices(i+1)-1 + j = this%l%col(tj) + do ii=1, block_nr + do jj=1, block_nc + dense(this%l%dense_row_of_row(i)+ii-1, & + this%l%dense_row_of_row(j)+jj-1) = & + this%data(this%l%data_ptrs(tj)+ii-1+(jj-1)*block_nr) + end do + end do + end do + end do +end subroutine copy_zsp_zd + +subroutine copy_dd_dsp(a, b, d_mask, od_mask) + type(MatrixD), intent(inout) :: a + type(RS_SparseMatrixD), intent(in) :: b + logical, optional :: d_mask(:), od_mask(:) + + integer is, jj, js, id, jd + + a%data = 0.0_dp + do is=1, b%l%N + id = b%l%dense_row_of_row(is) + do jj=b%l%row_indices(is), b%l%row_indices(is+1)-1 + js = b%l%col(jj) + if (present(d_mask)) then + if ((is == js) .and. .not. d_mask(is)) cycle + endif + if (present(od_mask)) then + if ((is /= js) .and. .not. od_mask(is) .and. .not. od_mask(js)) cycle + endif + jd = b%l%dense_row_of_row(js) + a%data(id:id+b%l%block_size(is)-1,jd:jd+b%l%block_size(js)-1) = & + reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+b%l%block_size(is)*b%l%block_size(js)-1), & + (/b%l%block_size(is), b%l%block_size(js)/) ) + end do + end do +end subroutine copy_dd_dsp + +subroutine copy_zd_zsp(a, b, d_mask, od_mask) + type(MatrixZ), intent(inout) :: a + type(RS_SparseMatrixZ), intent(in) :: b + logical, optional :: d_mask(:), od_mask(:) + + integer is, jj, js, id, jd + + a%data = 0.0_dp + do is=1, b%l%N + id = b%l%dense_row_of_row(is) + do jj=b%l%row_indices(is), b%l%row_indices(is+1)-1 + js = b%l%col(jj) + if (present(d_mask)) then + if ((is == js) .and. .not. d_mask(is)) cycle + endif + if (present(od_mask)) then + if ((is /= js) .and. .not. od_mask(is) .and. .not. od_mask(js)) cycle + endif + jd = b%l%dense_row_of_row(js) + a%data(id:id+b%l%block_size(is)-1,jd:jd+b%l%block_size(js)-1) = & + reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+b%l%block_size(is)*b%l%block_size(js)-1), & + (/b%l%block_size(is), b%l%block_size(js)/) ) + end do + end do +end subroutine copy_zd_zsp + +subroutine matrix_product_sub_dsp_dsp_dsp(c,a,b, a_transpose, b_transpose) + type(RS_SparseMatrixD), intent(inout) :: c + type(RS_SparseMatrixD), intent(in) :: a + type(RS_SparseMatrixD), intent(in) :: b + logical, intent(in), optional :: a_transpose, b_transpose + + integer is, kk, ks, jj_b, jj_c + integer block_ni, block_nj, block_nk + integer max_block_size + real(dp), allocatable :: a_block(:,:) + + c%data = 0.0_dp + + if (present(a_transpose)) then + if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(b_transpose)) then + if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + + max_block_size = maxval(a%l%block_size) + allocate(a_block(max_block_size,max_block_size)) + + do is=1, a%l%N + block_ni = a%l%block_size(is) + do kk=a%l%row_indices(is), a%l%row_indices(is+1)-1 + ks = a%l%col(kk) + block_nk = a%l%block_size(ks) + a_block(1:block_ni,1:block_nk) = reshape(a%data(a%l%data_ptrs(kk):a%l%data_ptrs(kk)+block_ni*block_nk-1), & + (/block_ni,block_nk/)) + + jj_c = c%l%row_indices(is) + jj_b = b%l%row_indices(ks) + do while (jj_c < c%l%row_indices(is+1) .and. jj_b < b%l%row_indices(ks+1)) + if (b%l%col(jj_b) == c%l%col(jj_c)) then + block_nj = b%l%block_size(b%l%col(jj_b)) + c%data(c%l%data_ptrs(jj_c):c%l%data_ptrs(jj_c)+block_ni*block_nj-1) = & + c%data(c%l%data_ptrs(jj_c):c%l%data_ptrs(jj_c)+block_ni*block_nj-1) + reshape( & + matmul( a_block(1:block_ni,1:block_nk), & + reshape(b%data(b%l%data_ptrs(jj_b):b%l%data_ptrs(jj_b)+block_nk*block_nj-1), & + (/block_nk,block_nj/)) ), & + (/block_ni*block_nj/) ) + jj_b = jj_b + 1 + jj_c = jj_c + 1 + else if (b%l%col(jj_b) < c%l%col(jj_c)) then + jj_b = jj_b + 1 + else + jj_c = jj_c + 1 + end if + end do + + end do + end do + + deallocate(a_block) + +end subroutine matrix_product_sub_dsp_dsp_dsp + +subroutine matrix_product_sub_zsp_zsp_zsp(c,a,b, a_transpose, a_conjugate, b_transpose, b_conjugate) + type(RS_SparseMatrixZ), intent(inout) :: c + type(RS_SparseMatrixZ), intent(in) :: a + type(RS_SparseMatrixZ), intent(in) :: b + logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose, b_conjugate + + integer is, kk, ks, jj_b, jj_c + integer block_ni, block_nj, block_nk + integer max_block_size + complex(dp), allocatable :: a_block(:,:) + + c%data = 0.0_dp + + if (present(a_transpose)) then + if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(b_transpose)) then + if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(a_conjugate)) then + if (a_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") + end if + if (present(b_conjugate)) then + if (b_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") + end if + + max_block_size = maxval(a%l%block_size) + allocate(a_block(max_block_size,max_block_size)) + + do is=1, a%l%N + block_ni = a%l%block_size(is) + do kk=a%l%row_indices(is), a%l%row_indices(is+1)-1 + ks = a%l%col(kk) + block_nk = a%l%block_size(ks) + a_block(1:block_ni,1:block_nk) = reshape(a%data(a%l%data_ptrs(kk):a%l%data_ptrs(kk)+block_ni*block_nk-1), & + (/block_ni,block_nk/)) + + jj_c = c%l%row_indices(is) + jj_b = b%l%row_indices(ks) + do while (jj_c < c%l%row_indices(is+1) .and. jj_b < b%l%row_indices(ks+1)) + if (b%l%col(jj_b) == c%l%col(jj_c)) then + block_nj = b%l%block_size(b%l%col(jj_b)) + c%data(c%l%data_ptrs(jj_c):c%l%data_ptrs(jj_c)+block_ni*block_nj-1) = & + c%data(c%l%data_ptrs(jj_c):c%l%data_ptrs(jj_c)+block_ni*block_nj-1) + reshape( & + matmul( a_block(1:block_ni,1:block_nk), & + reshape(b%data(b%l%data_ptrs(jj_b):b%l%data_ptrs(jj_b)+block_nk*block_nj-1), & + (/block_nk,block_nj/)) ), & + (/block_ni*block_nj/) ) + jj_b = jj_b + 1 + jj_c = jj_c + 1 + else if (b%l%col(jj_b) < c%l%col(jj_c)) then + jj_b = jj_b + 1 + else + jj_c = jj_c + 1 + end if + end do + + end do + end do + + deallocate(a_block) + +end subroutine matrix_product_sub_zsp_zsp_zsp + +subroutine matrix_product_sub_dden_dden_dsp(c,a,b,a_transpose, b_transpose, diag_mask, offdiag_mask) + type(MatrixD), intent(inout) :: c + type(MatrixD), intent(in) :: a + type(RS_SparseMatrixD), intent(in) :: b + logical, intent(in), optional :: a_transpose, b_transpose + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + + integer id, is, kd, ks, jj, jd, js + integer block_ni, block_nj, block_nk + + c%data = 0.0_dp + + if (present(a_transpose)) then + if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(b_transpose)) then + if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + + id = 1 + is = 1 + do while (id <= a%N) + block_ni = b%l%block_size(is) + kd = 1 + ks = 1 + do while (kd <= a%M) + block_nk = b%l%block_size(ks) + do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 + js = b%l%col(jj) + jd = b%l%dense_row_of_row(js) + block_nj = b%l%block_size(js) + + if (present(diag_mask)) then + if (js == ks .and. .not. diag_mask(ks)) cycle + end if + if (present(offdiag_mask)) then + if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle + end if + + c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & + c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & + matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & + reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1), & + (/block_nk,block_nj/)) ) + end do + kd = kd + b%l%block_size(ks) + ks = ks + 1 + end do + id = id + b%l%block_size(is) + is = is + 1 + end do +end subroutine + +subroutine matrix_product_sub_dden_dden_zsp(c,a,b,a_transpose, b_transpose, diag_mask, offdiag_mask) + type(MatrixD), intent(inout) :: c + type(MatrixD), intent(in) :: a + type(RS_SparseMatrixZ), intent(in) :: b + logical, intent(in), optional :: a_transpose, b_transpose + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + + integer id, is, kd, ks, jj, jd, js + integer block_ni, block_nj, block_nk + + c%data = 0.0_dp + + if (present(a_transpose)) then + if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(b_transpose)) then + if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + + id = 1 + is = 1 + do while (id <= a%N) + block_ni = b%l%block_size(is) + kd = 1 + ks = 1 + do while (kd <= a%M) + block_nk = b%l%block_size(ks) + do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 + js = b%l%col(jj) + jd = b%l%dense_row_of_row(js) + block_nj = b%l%block_size(js) + + if (present(diag_mask)) then + if (js == ks .and. .not. diag_mask(ks)) cycle + end if + if (present(offdiag_mask)) then + if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle + end if + + c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & + c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & + matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & + reshape(real(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1)), & + (/block_nk,block_nj/)) ) + end do + kd = kd + b%l%block_size(ks) + ks = ks + 1 + end do + id = id + b%l%block_size(is) + is = is + 1 + end do +end subroutine + +subroutine matrix_product_sub_zden_dden_zsp(c,a,b,a_transpose, b_transpose, b_conjugate, diag_mask, offdiag_mask) + type(MatrixZ), intent(inout) :: c + type(MatrixD), intent(in) :: a + type(RS_SparseMatrixZ), intent(in) :: b + logical, intent(in), optional :: a_transpose, b_transpose, b_conjugate + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + + integer id, is, kd, ks, jj, jd, js + integer block_ni, block_nj, block_nk + + c%data = 0.0_dp + + if (present(a_transpose)) then + if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(b_transpose)) then + if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(b_conjugate)) then + if (b_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") + end if + + id = 1 + is = 1 + do while (id <= a%N) + block_ni = b%l%block_size(is) + kd = 1 + ks = 1 + do while (kd <= a%M) + block_nk = b%l%block_size(ks) + do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 + js = b%l%col(jj) + jd = b%l%dense_row_of_row(js) + block_nj = b%l%block_size(js) + + if (present(diag_mask)) then + if (js == ks .and. .not. diag_mask(ks)) cycle + end if + if (present(offdiag_mask)) then + if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle + end if + + c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & + c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & + matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & + reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1), & + (/block_nk,block_nj/)) ) + end do + kd = kd + b%l%block_size(ks) + ks = ks + 1 + end do + id = id + b%l%block_size(is) + is = is + 1 + end do +end subroutine + +subroutine matrix_product_sub_zden_zden_zsp(c,a,b,a_transpose, a_conjugate, b_transpose, b_conjugate, diag_mask, offdiag_mask) + type(MatrixZ), intent(inout) :: c + type(MatrixZ), intent(in) :: a + type(RS_SparseMatrixZ), intent(in) :: b + logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose, b_conjugate + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + + integer id, is, kd, ks, jj, jd, js + integer block_ni, block_nj, block_nk + + c%data = 0.0_dp + + if (present(a_transpose)) then + if (a_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(b_transpose)) then + if (b_transpose) call system_abort("Can't do sparse = sparse * sparse with transposed matrices") + end if + if (present(a_conjugate)) then + if (a_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") + end if + if (present(b_conjugate)) then + if (b_conjugate) call system_abort("Can't do sparse = sparse * sparse with conjugate matrices") + end if + + id = 1 + is = 1 + do while (id <= a%N) + block_ni = b%l%block_size(is) + kd = 1 + ks = 1 + do while (kd <= a%M) + block_nk = b%l%block_size(ks) + do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 + js = b%l%col(jj) + jd = b%l%dense_row_of_row(js) + block_nj = b%l%block_size(js) + + if (present(diag_mask)) then + if (js == ks .and. .not. diag_mask(ks)) cycle + end if + if (present(offdiag_mask)) then + if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle + end if + + c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & + c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & + matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & + reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1), & + (/block_nk,block_nj/)) ) + end do + kd = kd + b%l%block_size(ks) + ks = ks + 1 + end do + id = id + b%l%block_size(is) + is = is + 1 + end do +end subroutine + +subroutine matrix_product_sub_zden_zden_dsp(c,a,b,a_transpose, a_conjugate, b_transpose, diag_mask, offdiag_mask) + type(MatrixZ), intent(inout) :: c + type(MatrixZ), intent(in) :: a + type(RS_SparseMatrixD), intent(in) :: b + logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + + integer id, is, kd, ks, jj, jd, js + integer block_ni, block_nj, block_nk + + if (present(a_transpose)) then + if (a_transpose) call system_abort("Can't do dense = dense * sparse with transposed matrices") + end if + if (present(b_transpose)) then + if (b_transpose) call system_abort("Can't do dense = dense * sparse with transposed matrices") + end if + if (present(a_conjugate)) then + if (a_conjugate) call system_abort("Can't do dense = dense * sparse with conjugate matrices") + end if + + c%data = 0.0_dp + + id = 1 + is = 1 + do while (id <= a%N) + block_ni = b%l%block_size(is) + kd = 1 + ks = 1 + do while (kd <= a%M) + block_nk = b%l%block_size(ks) + do jj=b%l%row_indices(ks), b%l%row_indices(ks+1)-1 + js = b%l%col(jj) + jd = b%l%dense_row_of_row(js) + block_nj = b%l%block_size(js) + + if (present(diag_mask)) then + if (js == ks .and. .not. diag_mask(ks)) cycle + end if + if (present(offdiag_mask)) then + if (js /= ks .and. .not. offdiag_mask(ks) .and. .not. offdiag_mask(js)) cycle + end if + + c%data(id:id+block_ni-1,jd:jd+block_nj-1) = & + c%data(id:id+block_ni-1,jd:jd+block_nj-1) + & + matmul( a%data(id:id+block_ni-1,kd:kd+block_nk-1), & + reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_nk*block_nj-1), & + (/block_nk,block_nj/)) ) + end do + kd = kd + b%l%block_size(ks) + ks = ks + 1 + end do + id = id + b%l%block_size(is) + is = is + 1 + end do +end subroutine + +subroutine RS_SparseMatrixD_add_block(this, block, block_nr, block_nc, at_row, at_col) + type(RS_SparseMatrixD), intent(inout) :: this + real(dp), intent(in) :: block(:,:) + integer, intent(in) :: block_nr, block_nc + integer, intent(in), optional :: at_row, at_col + + integer n_cols + integer cur_col, col_offset + + if (.not. present(at_row) .or. .not. present(at_col)) then + call System_abort("need at_row and at_col for add_block to RS_SparseMatrixD") + end if + + if (at_row > this%l%N .or. at_col > this%l%N) then + call system_abort("RS_SparseMatrixD_add_block tried to add block outside of matrix bounds "//at_row//","//at_col//" "//this%l%N) + end if + + if (this%l%cur_row /= at_row) then + this%l%cur_row = at_row + this%l%cur_col_offset = 0 + end if + + cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+this%l%cur_col_offset) + if (cur_col == at_col) then + call add_block_d(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) + return + else if (cur_col > at_col) then + do col_offset = this%l%cur_col_offset-1, 0, -1 + cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+col_offset) + if (cur_col == at_col) then + this%l%cur_col_offset = col_offset + call add_block_d(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) + return + end if + end do + else + n_cols = this%l%row_indices(this%l%cur_row+1)-this%l%row_indices(this%l%cur_row) + do col_offset = this%l%cur_col_offset+1, n_cols-1 + cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+col_offset) + if (cur_col == at_col) then + this%l%cur_col_offset = col_offset + call add_block_d(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) + return + end if + end do + end if + +end subroutine RS_SparseMatrixD_add_block + +subroutine RS_SparseMatrixZ_add_block(this, block, block_nr, block_nc, at_row, at_col) + type(RS_SparseMatrixZ), intent(inout) :: this + complex(dp), intent(in) :: block(:,:) + integer, intent(in) :: block_nr, block_nc + integer, intent(in) :: at_row, at_col + + integer n_cols + integer cur_col, col_offset + + if (at_row > this%l%N .or. at_col > this%l%N) then + call system_abort("RS_SparseMatrixZ_add_block_tried to add block outside of matrix bounds "//at_row//","//at_col//" "//this%l%N) + end if + + if (this%l%cur_row /= at_row) then + this%l%cur_row = at_row + this%l%cur_col_offset = 0 + end if + + cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+this%l%cur_col_offset) + if (cur_col == at_col) then + call add_block_z(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) + return + else if (cur_col > at_col) then + do col_offset = this%l%cur_col_offset-1, 0, -1 + cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+col_offset) + if (cur_col == at_col) then + this%l%cur_col_offset = col_offset + call add_block_z(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) + return + end if + end do + else + n_cols = this%l%row_indices(this%l%cur_row+1)-this%l%row_indices(this%l%cur_row) + do col_offset = this%l%cur_col_offset+1, n_cols-1 + cur_col = this%l%col(this%l%row_indices(this%l%cur_row)+col_offset) + if (cur_col == at_col) then + this%l%cur_col_offset = col_offset + call add_block_z(this, this%l%cur_row, this%l%cur_col_offset, block_nr, block_nc, block) + return + end if + end do + end if + +end subroutine RS_SparseMatrixZ_add_block + +subroutine add_block_d(this, cur_row, cur_col_offset, in_nr, in_nc, block) + type(RS_SparseMatrixD), intent(inout) :: this + integer, intent(in) :: cur_row, cur_col_offset + integer, intent(in) :: in_nr, in_nc + real(dp), intent(in) :: block(:,:) + + integer ptr_i, this_nr, this_nc + + ptr_i = this%l%row_indices(cur_row)+cur_col_offset + this_nr = this%l%block_size(cur_row) + this_nc = this%l%block_size(this%l%col(ptr_i)) + if (in_nr /= this_nr .or. in_nc /= this_nc) then + call System_abort("add_block_d tried to add block of wrong shape in_nr,nc "//in_nr// " "//in_nc//" sp_nr,nc "//this_nr//" "//this_nc) + end if + this%data(this%l%data_ptrs(ptr_i):this%l%data_ptrs(ptr_i)+this_nr*this_nc-1) = & + this%data(this%l%data_ptrs(ptr_i):this%l%data_ptrs(ptr_i)+this_nr*this_nc-1) + & + reshape( block(1:in_nr,1:in_nc), (/this_nr*this_nc/) ) +end subroutine add_block_d + +subroutine add_block_z(this, cur_row, cur_col_offset, in_nr, in_nc, block) + type(RS_SparseMatrixZ), intent(inout) :: this + integer, intent(in) :: cur_row, cur_col_offset + integer, intent(in) :: in_nr, in_nc + complex(dp), intent(in) :: block(:,:) + + integer ptr_i, this_nr, this_nc + + ptr_i = this%l%row_indices(cur_row)+cur_col_offset + this_nr = this%l%block_size(cur_row) + this_nc = this%l%block_size(this%l%col(ptr_i)) + if (in_nr /= this_nr .or. in_nc /= this_nc) then + call System_abort("add_block_z tried to add block of wrong shape in_nr,nc "//in_nr// " "//in_nc//" sp_nr,nc "//this_nr//" "//this_nc) + end if + this%data(this%l%data_ptrs(ptr_i):this%l%data_ptrs(ptr_i)+this_nr*this_nc-1) = & + this%data(this%l%data_ptrs(ptr_i):this%l%data_ptrs(ptr_i)+this_nr*this_nc-1) + & + reshape( block(1:in_nr,1:in_nc), (/this_nr*this_nc/) ) +end subroutine add_block_z + +function RS_SparseMatrix_partial_TraceMult_dden_dsp(a, b, a_T, b_T, diag_mask, offdiag_mask) result(v) + type(MatrixD), intent(in) :: a + type(RS_SparseMatrixD), intent(in) :: b + logical, intent(in), optional :: a_T, b_T + logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) + complex(dp) :: v(a%N) + + logical u_a_T, u_b_T + integer i, ji, j, tt + integer block_ni, block_nj, max_block_size + real(dp), allocatable :: a_block(:,:), b_block(:,:) + logical, pointer :: d_mask(:), od_mask(:) + logical use_a_ij_transpose + logical have_any + + max_block_size = maxval(b%l%block_size) + allocate(a_block(max_block_size,max_block_size)) + allocate(b_block(max_block_size,max_block_size)) + if (present(diag_mask)) then + d_mask => diag_mask + else + allocate(d_mask(b%l%N)) + d_mask = .true. + end if + if (present(offdiag_mask)) then + od_mask => offdiag_mask + else + allocate(od_mask(b%l%N)) + od_mask = .true. + end if + + u_a_T = optional_default(.false., a_T) + u_b_T = optional_default(.false., b_T) + + use_a_ij_transpose = .false. + if ((u_a_T .and. u_b_T) .or. (.not. u_a_T .and. .not. u_b_T)) use_a_ij_transpose = .true. + + v = 0.0_dp + do i=1, b%l%N + block_ni = b%l%block_size(i) + do ji=b%l%row_indices(i), b%l%row_indices(i+1)-1 + j = b%l%col(ji) + if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle + block_nj = b%l%block_size(j) + have_any = get_dense_block(a%data, a%scalapack_info_obj, use_a_ij_transpose, i, j, b%l, block_ni, block_nj, a_block) + + if (have_any) then + b_block(1:block_ni,1:block_nj) = reshape(b%data(b%l%data_ptrs(ji):b%l%data_ptrs(ji)+block_ni*block_nj-1),(/block_ni,block_nj/)) + + if (u_b_T) then + do tt=1, block_nj + v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) = & + v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) + & + a_block(1:block_ni,tt)*b_block(1:block_ni,tt) + end do + else + do tt=1, block_ni + v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) = & + v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) + & + a_block(tt,1:block_nj)*b_block(tt,1:block_nj) + end do + end if + end if + + end do + end do + + deallocate(a_block) + deallocate(b_block) + if (.not.present(diag_mask)) deallocate(d_mask) + if (.not.present(offdiag_mask)) deallocate(od_mask) + +end function RS_SparseMatrix_partial_TraceMult_dden_dsp + +function RS_SparseMatrix_partial_TraceMult_dden_zsp(a, b, a_T, b_H, diag_mask, offdiag_mask) result(v) + type(MatrixD), intent(in) :: a + type(RS_SparseMatrixZ), intent(in) :: b + logical, intent(in), optional :: a_T, b_H + logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) + complex(dp) :: v(a%N) + + logical u_a_T, u_b_H + integer i, jj, j, tt + integer block_ni, block_nj, max_block_size + real(dp), allocatable :: a_block(:,:) + complex(dp), allocatable :: b_block(:,:) + logical, pointer :: d_mask(:), od_mask(:) + logical :: use_a_ij_transpose + logical have_any + + max_block_size = maxval(b%l%block_size) + allocate(a_block(max_block_size,max_block_size)) + allocate(b_block(max_block_size,max_block_size)) + if (present(diag_mask)) then + d_mask => diag_mask + else + allocate(d_mask(b%l%N)) + d_mask = .true. + end if + if (present(offdiag_mask)) then + od_mask => offdiag_mask + else + allocate(od_mask(b%l%N)) + od_mask = .true. + end if + + u_a_T = optional_default(.false., a_T) + u_b_H = optional_default(.false., b_H) + + use_a_ij_transpose = .false. + if ((u_a_T .and. u_b_H) .or. (.not. u_a_T .and. .not. u_b_H)) use_a_ij_transpose = .true. + + v = 0.0_dp + do i=1, b%l%N + block_ni = b%l%block_size(i) + do jj=b%l%row_indices(i), b%l%row_indices(i+1)-1 + j = b%l%col(jj) + if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle + block_nj = b%l%block_size(j) + have_any = get_dense_block(a%data, a%scalapack_info_obj, use_a_ij_transpose, i, j, b%l, block_ni, block_nj, a_block) + + if (have_any) then + b_block(1:block_ni,1:block_nj) = reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) + if (u_b_H) b_block = conjg(b_block) + + if (u_b_H) then + do tt=1, block_nj + v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) = & + v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) + & + a_block(1:block_ni,tt)*b_block(1:block_ni,tt) + end do + else + do tt=1, block_ni + v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) = & + v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) + & + a_block(tt,1:block_nj)*b_block(tt,1:block_nj) + end do + end if + end if + + end do + end do + + deallocate(a_block) + deallocate(b_block) + if (.not.present(diag_mask)) deallocate(d_mask) + if (.not.present(offdiag_mask)) deallocate(od_mask) + +end function RS_SparseMatrix_partial_TraceMult_dden_zsp + +function RS_SparseMatrix_partial_TraceMult_zden_dsp(a, b, a_H, b_T, diag_mask, offdiag_mask) result(v) + type(MatrixZ), intent(in) :: a + type(RS_SparseMatrixD), intent(in) :: b + logical, intent(in), optional :: a_H, b_T + logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) + complex(dp) :: v(a%N) + + logical u_a_H, u_b_T + integer i, jj, j, tt + integer block_ni, block_nj, max_block_size + complex(dp), allocatable :: a_block(:,:) + real(dp), allocatable :: b_block(:,:) + logical, pointer :: d_mask(:), od_mask(:) + logical :: use_a_ij_transpose + logical have_any + + max_block_size = maxval(b%l%block_size) + allocate(a_block(max_block_size,max_block_size)) + allocate(b_block(max_block_size,max_block_size)) + if (present(diag_mask)) then + d_mask => diag_mask + else + allocate(d_mask(b%l%N)) + d_mask = .true. + end if + if (present(offdiag_mask)) then + od_mask => offdiag_mask + else + allocate(od_mask(b%l%N)) + od_mask = .true. + end if + + u_a_H = optional_default(.false., a_H) + u_b_T = optional_default(.false., b_T) + + use_a_ij_transpose = .false. + if ((u_a_H .and. u_b_T) .or. (.not. u_a_H .and. .not. u_b_T)) use_a_ij_transpose = .true. + + v = 0.0_dp + do i=1, b%l%N + block_ni = b%l%block_size(i) + do jj=b%l%row_indices(i), b%l%row_indices(i+1)-1 + j = b%l%col(jj) + if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle + block_nj = b%l%block_size(j) + have_any = get_dense_block(a%data, a%scalapack_info_obj, use_a_ij_transpose, i, j, b%l, block_ni, block_nj, a_block) + if (u_a_H) a_block = conjg(a_block) + + if (have_any) then + b_block(1:block_ni,1:block_nj) = reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) + + if (u_b_T) then + do tt=1, block_nj + v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) = & + v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) + & + a_block(1:block_ni,tt)*b_block(1:block_ni,tt) + end do + else + do tt=1, block_ni + v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) = & + v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) + & + a_block(tt,1:block_nj)*b_block(tt,1:block_nj) + end do + end if + end if + + end do + end do + + deallocate(a_block) + deallocate(b_block) + if (.not.present(diag_mask)) deallocate(d_mask) + if (.not.present(offdiag_mask)) deallocate(od_mask) + +end function RS_SparseMatrix_partial_TraceMult_zden_dsp + +function RS_SparseMatrix_partial_TraceMult_zden_zsp(a, b, a_H, b_H, diag_mask, offdiag_mask) result(v) + type(MatrixZ), intent(in) :: a + type(RS_SparseMatrixZ), intent(in) :: b + logical, intent(in), optional :: a_H, b_H + logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) + complex(dp) :: v(a%N) + + logical u_a_H, u_b_H + integer i, jj, j, tt + integer block_ni, block_nj, max_block_size + complex(dp), allocatable :: a_block(:,:), b_block(:,:) + logical, pointer :: d_mask(:), od_mask(:) + logical :: use_a_ij_transpose + logical have_any + + max_block_size = maxval(b%l%block_size) + allocate(a_block(max_block_size,max_block_size)) + allocate(b_block(max_block_size,max_block_size)) + if (present(diag_mask)) then + d_mask => diag_mask + else + allocate(d_mask(b%l%N)) + d_mask = .true. + end if + if (present(offdiag_mask)) then + od_mask => offdiag_mask + else + allocate(od_mask(b%l%N)) + od_mask = .true. + end if + + u_a_H = optional_default(.false., a_H) + u_b_H = optional_default(.false., b_H) + + use_a_ij_transpose = .false. + if ((u_a_H .and. u_b_H) .or. (.not. u_a_H .and. .not. u_b_H)) use_a_ij_transpose = .true. + + v = 0.0_dp + do i=1, b%l%N + block_ni = b%l%block_size(i) + do jj=b%l%row_indices(i), b%l%row_indices(i+1)-1 + j = b%l%col(jj) + if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle + block_nj = b%l%block_size(j) + have_any = get_dense_block(a%data, a%scalapack_info_obj, use_a_ij_transpose, i, j, b%l, block_ni, block_nj, a_block) + if (u_a_H) a_block = conjg(a_block) + + if (have_any) then + b_block(1:block_ni,1:block_nj) = reshape(b%data(b%l%data_ptrs(jj):b%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) + if (u_b_H) b_block = conjg(b_block) + + if (u_b_H) then + do tt=1, block_nj + v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) = & + v(b%l%dense_row_of_row(i):b%l%dense_row_of_row(i)+block_ni-1) + & + a_block(1:block_ni,tt)*b_block(1:block_ni,tt) + end do + else + do tt=1, block_ni + v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) = & + v(b%l%dense_row_of_row(j):b%l%dense_row_of_row(j)+block_nj-1) + & + a_block(tt,1:block_nj)*b_block(tt,1:block_nj) + end do + end if + end if + + end do + end do + + deallocate(a_block) + deallocate(b_block) + if (.not.present(diag_mask)) deallocate(d_mask) + if (.not.present(offdiag_mask)) deallocate(od_mask) + +end function RS_SparseMatrix_partial_TraceMult_zden_zsp + +function RS_SparseMatrix_partial_TraceMult_dsp_zden(a, b, a_T, b_H, diag_mask, offdiag_mask) result(v) + type(RS_SparseMatrixD), intent(in) :: a + type(MatrixZ), intent(in) :: b + logical, intent(in), optional :: a_T, b_H + logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) + complex(dp) :: v(b%N) + + logical u_a_T, u_b_H + integer i, jj, j, tt + integer block_ni, block_nj, max_block_size + real(dp), allocatable :: a_block(:,:) + complex(dp), allocatable :: b_block(:,:) + logical, pointer :: d_mask(:), od_mask(:) + logical use_b_ij_transpose + logical have_any + + max_block_size = maxval(a%l%block_size) + allocate(b_block(max_block_size,max_block_size)) + allocate(a_block(max_block_size,max_block_size)) + if (present(diag_mask)) then + d_mask => diag_mask + else + allocate(d_mask(a%l%N)) + d_mask = .true. + end if + if (present(offdiag_mask)) then + od_mask => offdiag_mask + else + allocate(od_mask(a%l%N)) + od_mask = .true. + end if + + u_a_T = optional_default(.false., a_T) + u_b_H = optional_default(.false., b_H) + + use_b_ij_transpose = .false. + if ((u_a_T .and. u_b_H) .or. (.not. u_a_T .and. .not. u_b_H)) use_b_ij_transpose = .true. + + v = 0.0_dp + do i=1, a%l%N + block_ni = a%l%block_size(i) + do jj=a%l%row_indices(i), a%l%row_indices(i+1)-1 + j = a%l%col(jj) + if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle + block_nj = a%l%block_size(j) + have_any = get_dense_block(b%data, b%scalapack_info_obj, use_b_ij_transpose, i, j, a%l, block_ni, block_nj, b_block) + if (u_b_H) b_block = conjg(b_block) + + if (have_any) then + a_block(1:block_ni,1:block_nj) = reshape(a%data(a%l%data_ptrs(jj):a%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) + + if (u_a_T) then + do tt=1, block_ni + v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) = & + v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) + & + a_block(tt,1:block_nj)*b_block(tt,1:block_nj) + end do + else + do tt=1, block_nj + v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) = & + v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) + & + a_block(1:block_ni,tt)*b_block(1:block_ni,tt) + end do + end if + end if + + end do + end do + + deallocate(b_block) + deallocate(a_block) + if (.not.present(diag_mask)) deallocate(d_mask) + if (.not.present(offdiag_mask)) deallocate(od_mask) + +end function RS_SparseMatrix_partial_TraceMult_dsp_zden + +function RS_SparseMatrix_partial_TraceMult_zsp_zden(a, b, a_H, b_H, diag_mask, offdiag_mask) result(v) + type(RS_SparseMatrixZ), intent(in) :: a + type(MatrixZ), intent(in) :: b + logical, intent(in), optional :: a_H, b_H + logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) + complex(dp) :: v(b%N) + + logical u_a_H, u_b_H + integer i, jj, j, tt + integer block_ni, block_nj, max_block_size + complex(dp), allocatable :: a_block(:,:) + complex(dp), allocatable :: b_block(:,:) + logical, pointer :: d_mask(:), od_mask(:) + logical use_b_ij_transpose + logical have_any + + max_block_size = maxval(a%l%block_size) + allocate(b_block(max_block_size,max_block_size)) + allocate(a_block(max_block_size,max_block_size)) + if (present(diag_mask)) then + d_mask => diag_mask + else + allocate(d_mask(a%l%N)) + d_mask = .true. + end if + if (present(offdiag_mask)) then + od_mask => offdiag_mask + else + allocate(od_mask(a%l%N)) + od_mask = .true. + end if + + u_a_H = optional_default(.false., a_H) + u_b_H = optional_default(.false., b_H) + + use_b_ij_transpose = .false. + if ((u_a_H .and. u_b_H) .or. (.not. u_a_H .and. .not. u_b_H)) use_b_ij_transpose = .true. + + v = 0.0_dp + do i=1, a%l%N + block_ni = a%l%block_size(i) + do jj=a%l%row_indices(i), a%l%row_indices(i+1)-1 + j = a%l%col(jj) + if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle + block_nj = a%l%block_size(j) + have_any = get_dense_block(b%data, b%scalapack_info_obj, use_b_ij_transpose, i, j, a%l, block_ni, block_nj, b_block) + if (u_b_H) b_block = conjg(b_block) + + if (have_any) then + a_block(1:block_ni,1:block_nj) = reshape(a%data(a%l%data_ptrs(jj):a%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) + if (u_a_H) a_block = conjg(a_block) + + if (u_a_H) then + do tt=1, block_ni + v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) = & + v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) + & + a_block(tt,1:block_nj)*b_block(tt,1:block_nj) + end do + else + do tt=1, block_nj + v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) = & + v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) + & + a_block(1:block_ni,tt)*b_block(1:block_ni,tt) + end do + end if + end if + + end do + end do + + deallocate(b_block) + deallocate(a_block) + if (.not.present(diag_mask)) deallocate(d_mask) + if (.not.present(offdiag_mask)) deallocate(od_mask) + +end function RS_SparseMatrix_partial_TraceMult_zsp_zden + +function RS_SparseMatrix_partial_TraceMult_dsp_dden(a, b, a_T, b_T, diag_mask, offdiag_mask) result(v) + type(RS_SparseMatrixD), intent(in) :: a + type(MatrixD), intent(in) :: b + logical, intent(in), optional :: a_T, b_T + logical, intent(in), optional, target :: diag_mask(:), offdiag_mask(:) + complex(dp) :: v(b%N) + + logical u_a_T, u_b_T + integer i, jj, j, tt + integer block_ni, block_nj, max_block_size + real(dp), allocatable :: a_block(:,:) + real(dp), allocatable :: b_block(:,:) + logical, pointer :: d_mask(:), od_mask(:) + logical use_b_ij_transpose + logical have_any + + max_block_size = maxval(a%l%block_size) + allocate(b_block(max_block_size,max_block_size)) + allocate(a_block(max_block_size,max_block_size)) + if (present(diag_mask)) then + d_mask => diag_mask + else + allocate(d_mask(a%l%N)) + d_mask = .true. + end if + if (present(offdiag_mask)) then + od_mask => offdiag_mask + else + allocate(od_mask(a%l%N)) + od_mask = .true. + end if + + u_a_T = optional_default(.false., a_T) + u_b_T = optional_default(.false., b_T) + + use_b_ij_transpose = .false. + if ((u_a_T .and. u_b_T) .or. (.not. u_a_T .and. .not. u_b_T)) use_b_ij_transpose = .true. + + v = 0.0_dp + do i=1, a%l%N + block_ni = a%l%block_size(i) + do jj=a%l%row_indices(i), a%l%row_indices(i+1)-1 + j = a%l%col(jj) + if ((i == j .and. .not. d_mask(i)) .or. ((i /= j) .and. .not. od_mask(i) .and. .not. od_mask(j))) cycle + block_nj = a%l%block_size(j) + have_any = get_dense_block(b%data, b%scalapack_info_obj, use_b_ij_transpose, i, j, a%l, block_ni, block_nj, b_block) + + if (have_any) then + a_block(1:block_ni,1:block_nj) = reshape(a%data(a%l%data_ptrs(jj):a%l%data_ptrs(jj)+block_ni*block_nj-1),(/block_ni,block_nj/)) + + if (u_a_T) then + do tt=1, block_ni + v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) = & + v(a%l%dense_row_of_row(j):a%l%dense_row_of_row(j)+block_nj-1) + & + a_block(tt,1:block_nj)*b_block(tt,1:block_nj) + end do + else + do tt=1, block_nj + v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) = & + v(a%l%dense_row_of_row(i):a%l%dense_row_of_row(i)+block_ni-1) + & + a_block(1:block_ni,tt)*b_block(1:block_ni,tt) + end do + end if + end if + + end do + end do + + deallocate(b_block) + deallocate(a_block) + if (.not.present(diag_mask)) deallocate(d_mask) + if (.not.present(offdiag_mask)) deallocate(od_mask) + +end function RS_SparseMatrix_partial_TraceMult_dsp_dden + +function get_dense_blockD(a_data, a_scalapack_info_obj, use_a_ij_transpose, i, j, b_l, block_ni, block_nj, a_block) + real(dp), intent(in) :: a_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack_info_obj + logical, intent(in) :: use_a_ij_transpose + integer, intent(in) :: i, j + type(RS_SparseMatrixL), intent(in) :: b_l + integer, intent(in) :: block_ni, block_nj + real(dp), intent(out) :: a_block(:,:) + logical :: get_dense_blockD + + integer io, jo, g_i, g_j, l_i, l_j + + if (a_scalapack_info_obj%active) then + get_dense_blockD = .false. + do io = 0, block_ni-1 + do jo = 0, block_nj-1 + g_i = b_l%dense_row_of_row(i) + io + g_j = b_l%dense_row_of_row(j) + jo + if (use_a_ij_transpose) then + call coords_global_to_local(a_scalapack_info_obj, g_j, g_i, l_i, l_j) + if (l_i > 0 .and. l_j > 0) then + a_block(io+1,jo+1) = a_data(l_i,l_j) + get_dense_blockD = .true. + else + a_block(io+1,jo+1) = 0.0_dp + end if + else + call coords_global_to_local(a_scalapack_info_obj, g_i, g_j, l_i, l_j) + if (l_i > 0 .and. l_j > 0) then + a_block(io+1,jo+1) = a_data(l_i,l_j) + get_dense_blockD = .true. + else + a_block(io+1,jo+1) = 0.0_dp + end if + end if + end do + end do + else + get_dense_blockD = .true. + if (use_a_ij_transpose) then + a_block(1:block_ni,1:block_nj) = transpose(a_data(b_l%dense_row_of_row(j):b_l%dense_row_of_row(j)+block_nj-1, & + b_l%dense_row_of_row(i):b_l%dense_row_of_row(i)+block_ni-1)) + else + a_block(1:block_ni,1:block_nj) = a_data(b_l%dense_row_of_row(i):b_l%dense_row_of_row(i)+block_ni-1, & + b_l%dense_row_of_row(j):b_l%dense_row_of_row(j)+block_nj-1) + end if + end if + +end function get_dense_blockD + +function get_dense_blockZ(a_data, a_scalapack_info_obj, use_a_ij_transpose, i, j, b_l, block_ni, block_nj, a_block) + complex(dp), intent(in) :: a_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack_info_obj + logical, intent(in) :: use_a_ij_transpose + integer, intent(in) :: i, j + type(RS_SparseMatrixL), intent(in) :: b_l + integer, intent(in) :: block_ni, block_nj + complex(dp), intent(out) :: a_block(:,:) + logical :: get_dense_blockZ + + integer io, jo, g_i, g_j, l_i, l_j + + if (a_scalapack_info_obj%active) then + get_dense_blockZ = .false. + do io = 0, block_ni-1 + do jo = 0, block_nj-1 + g_i = b_l%dense_row_of_row(i) + io + g_j = b_l%dense_row_of_row(j) + jo + if (use_a_ij_transpose) then + call coords_global_to_local(a_scalapack_info_obj, g_j, g_i, l_i, l_j) + if (l_i > 0 .and. l_j > 0) then + a_block(io+1,jo+1) = a_data(l_i,l_j) + get_dense_blockZ = .true. + else + a_block(io+1,jo+1) = 0.0_dp + end if + else + call coords_global_to_local(a_scalapack_info_obj, g_i, g_j, l_i, l_j) + if (l_i > 0 .and. l_j > 0) then + a_block(io+1,jo+1) = a_data(l_i,l_j) + get_dense_blockZ = .true. + else + a_block(io+1,jo+1) = 0.0_dp + end if + end if + end do + end do + else + get_dense_blockZ = .true. + if (use_a_ij_transpose) then + a_block(1:block_ni,1:block_nj) = transpose(a_data(b_l%dense_row_of_row(j):b_l%dense_row_of_row(j)+block_nj-1, & + b_l%dense_row_of_row(i):b_l%dense_row_of_row(i)+block_ni-1)) + else + a_block(1:block_ni,1:block_nj) = a_data(b_l%dense_row_of_row(i):b_l%dense_row_of_row(i)+block_ni-1, & + b_l%dense_row_of_row(j):b_l%dense_row_of_row(j)+block_nj-1) + end if + end if + +end function get_dense_blockZ + +function RS_SparseMatrix_TraceMult_dden_dsp(a, b, w, a_T, b_T, diag_mask, offdiag_mask) + type(MatrixD), intent(in) :: a + type(RS_SparseMatrixD), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_T, b_T + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + real(dp) :: RS_SparseMatrix_TraceMult_dden_dsp + + if (present(w)) then + RS_SparseMatrix_TraceMult_dden_dsp = sum(partial_TraceMult(a, b, a_T, b_T, diag_mask, offdiag_mask)*w) + else + RS_SparseMatrix_TraceMult_dden_dsp = sum(partial_TraceMult(a, b, a_T, b_T, diag_mask, offdiag_mask)) + end if + +end function RS_SparseMatrix_TraceMult_dden_dsp + +function RS_SparseMatrix_TraceMult_dden_zsp(a, b, w, a_T, b_H, diag_mask, offdiag_mask) + type(MatrixD), intent(in) :: a + type(RS_SparseMatrixZ), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_T, b_H + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: RS_SparseMatrix_TraceMult_dden_zsp + + if (present(w)) then + RS_SparseMatrix_TraceMult_dden_zsp = sum(partial_TraceMult(a, b, a_T, b_H, diag_mask, offdiag_mask)*w) + else + RS_SparseMatrix_TraceMult_dden_zsp = sum(partial_TraceMult(a, b, a_T, b_H, diag_mask, offdiag_mask)) + end if + +end function RS_SparseMatrix_TraceMult_dden_zsp + +function RS_SparseMatrix_TraceMult_zden_dsp(a, b, w, a_H, b_T, diag_mask, offdiag_mask) + type(MatrixZ), intent(in) :: a + type(RS_SparseMatrixD), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_H, b_T + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: RS_SparseMatrix_TraceMult_zden_dsp + + if (present(w)) then + RS_SparseMatrix_TraceMult_zden_dsp = sum(partial_TraceMult(a, b, a_H, b_T, diag_mask, offdiag_mask)*w) + else + RS_SparseMatrix_TraceMult_zden_dsp = sum(partial_TraceMult(a, b, a_H, b_T, diag_mask, offdiag_mask)) + end if + +end function RS_SparseMatrix_TraceMult_zden_dsp + +function RS_SparseMatrix_TraceMult_dsp_zden(a, b, w, a_T, b_H, diag_mask, offdiag_mask) + type(RS_SparseMatrixD), intent(in) :: a + type(MatrixZ), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_T, b_H + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: RS_SparseMatrix_TraceMult_dsp_zden + + if (present(w)) then + RS_SparseMatrix_TraceMult_dsp_zden = sum(partial_TraceMult(a, b, a_T, b_H, diag_mask, offdiag_mask)*w) + else + RS_SparseMatrix_TraceMult_dsp_zden = sum(partial_TraceMult(a, b, a_T, b_H, diag_mask, offdiag_mask)) + end if + +end function RS_SparseMatrix_TraceMult_dsp_zden + +function RS_SparseMatrix_TraceMult_dsp_dden(a, b, w, a_T, b_T, diag_mask, offdiag_mask) + type(RS_SparseMatrixD), intent(in) :: a + type(MatrixD), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_T, b_T + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: RS_SparseMatrix_TraceMult_dsp_dden + + if (present(w)) then + RS_SparseMatrix_TraceMult_dsp_dden = sum(partial_TraceMult(a, b, a_T, b_T, diag_mask, offdiag_mask)*w) + else + RS_SparseMatrix_TraceMult_dsp_dden = sum(partial_TraceMult(a, b, a_T, b_T, diag_mask, offdiag_mask)) + end if + +end function RS_SparseMatrix_TraceMult_dsp_dden + +function RS_SparseMatrix_TraceMult_zsp_zden(a, b, w, a_H, b_H, diag_mask, offdiag_mask) + type(RS_SparseMatrixZ), intent(in) :: a + type(MatrixZ), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_H, b_H + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: RS_SparseMatrix_TraceMult_zsp_zden + + if (present(w)) then + RS_SparseMatrix_TraceMult_zsp_zden = sum(partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask)*w) + else + RS_SparseMatrix_TraceMult_zsp_zden = sum(partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask)) + end if + +end function RS_SparseMatrix_TraceMult_zsp_zden + +function RS_SparseMatrix_TraceMult_zden_zsp(a, b, w, a_H, b_H, diag_mask, offdiag_mask) + type(MatrixZ), intent(in) :: a + type(RS_SparseMatrixZ), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_H, b_H + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: RS_SparseMatrix_TraceMult_zden_zsp + + if (present(w)) then + RS_SparseMatrix_TraceMult_zden_zsp = sum(partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask)*w) + else + RS_SparseMatrix_TraceMult_zden_zsp = sum(partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask)) + end if + +end function RS_SparseMatrix_TraceMult_zden_zsp + +subroutine RS_SparseMatrixD_multDiagRL_d(this, A, diag) + type(RS_SparseMatrixD), intent(inout) :: this + type(RS_SparseMatrixD), intent(in) :: A + real(dp), intent(in) :: diag(:) + + integer i, jj, j, block_ni, block_nj, io, jo + real(dp) fac + + do i=1, A%l%N + block_ni = A%l%block_size(i) + do jj=A%l%row_indices(i), A%l%row_indices(i+1)-1 + j = A%l%col(jj) + block_nj = A%l%block_size(j) + do jo=0, block_nj-1 + do io=0, block_ni-1 + fac = 0.5_dp*(diag(this%l%dense_row_of_row(i)+io)+diag(this%l%dense_row_of_row(j)+jo)) + this%data(this%l%data_ptrs(jj)+io+block_ni*jo) = fac*A%data(this%l%data_ptrs(jj)+io+block_ni*jo) + end do + end do + end do + end do + +end subroutine RS_SparseMatrixD_multDiagRL_d + +subroutine RS_SparseMatrixZ_multDiagRL_d(this, A, diag) + type(RS_SparseMatrixZ), intent(inout) :: this + type(RS_SparseMatrixZ), intent(in) :: A + real(dp), intent(in) :: diag(:) + + integer i, jj, j, block_ni, block_nj, io, jo + real(dp) fac + + do i=1, A%l%N + block_ni = A%l%block_size(i) + do jj=A%l%row_indices(i), A%l%row_indices(i+1)-1 + j = A%l%col(jj) + block_nj = A%l%block_size(j) + do jo=0, block_nj-1 + do io=0, block_ni-1 + fac = 0.5_dp*(diag(this%l%dense_row_of_row(i)+io)+diag(this%l%dense_row_of_row(j)+jo)) + this%data(this%l%data_ptrs(jj)+io+block_ni*jo) = fac*A%data(this%l%data_ptrs(jj)+io+block_ni*jo) + end do + end do + end do + end do + +end subroutine RS_SparseMatrixZ_multDiagRL_d + +subroutine check_sparse_layout(l) + type(RS_SparseMatrixL), intent(in) :: l + integer i, ji, j + + do i=1, l%N + do ji=l%row_indices(i), l%row_indices(i+1)-1 + j = l%col(ji) + + call print("check_sparse " // i // " " // j) + + if (ji > l%row_indices(i)) then + if (j <= l%col(ji-1)) then + call print("ERROR row " // i // " col " // j // " (ji="//ji//") out of order") + call print(l%col(l%row_indices(i):l%row_indices(i+1)-1)) + end if + end if + + if (.not. any(l%col(l%row_indices(j):l%row_indices(j+1)-1) == i)) then + call print ("ERROR row "//i//" col "//j//" has no transpose match") + call print(l%col(l%row_indices(j):l%row_indices(j+1)-1)) + end if + + end do + end do +end subroutine + +end module RS_SparseMatrix_module diff --git a/src/Potentials/SocketPot.F90 b/src/Potentials/SocketPot.F90 new file mode 100644 index 0000000000..194ef1dc1a --- /dev/null +++ b/src/Potentials/SocketPot.F90 @@ -0,0 +1,341 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X SocketPot Module +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" +module SocketPot_module + +use error_module +use system_module +use mpi_context_module +use dictionary_module +use paramreader_module +use atoms_types_module +use atoms_module +use SocketTools_module + +implicit none +private + +public :: SocketPot_type +type SocketPot_type + character(len=STRING_LENGTH) :: init_args_str + character(len=STRING_LENGTH) :: ip + character(len=STRING_LENGTH) :: property_list + character(len=STRING_LENGTH) :: property_list_prefixes + character(len=STRING_LENGTH) :: read_extra_property_list + character(len=STRING_LENGTH) :: read_extra_param_list + integer :: port, client_id, label, last_label, buffsize + type(MPI_context) :: mpi +end type SocketPot_type + +public :: Initialise +interface Initialise + module procedure SocketPot_Initialise +end interface Initialise + +public :: Finalise +interface Finalise + module procedure SocketPot_Finalise +end interface Finalise + +public :: cutoff +interface cutoff + module procedure SocketPot_cutoff +end interface + +public :: Wipe +interface Wipe + module procedure SocketPot_Wipe +end interface Wipe + +public :: Print +interface Print + module procedure SocketPot_Print +end interface Print + +public :: calc +interface calc + module procedure SocketPot_Calc +end interface + +contains + + +subroutine SocketPot_Initialise(this, args_str, mpi, error) + type(SocketPot_type), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(MPI_Context), intent(in), optional :: mpi + integer, intent(out), optional :: error + + type(Dictionary) :: params + + INIT_ERROR(error) + + call finalise(this) + + call initialise(params) + call param_register(params, 'server_ip', '', this%ip, help_string="IP address to send configs to") + call param_register(params, 'server_port', '0', this%port, help_string="TCP port number to send configs to. Default 0.") + call param_register(params, 'client_id', '0', this%client_id, help_string="Identity of this client. Default 0.") + call param_register(params, 'buffsize', '1000000', this%buffsize, help_string='Size of recv buffer in bytes. Default 100000') + call param_register(params, 'property_list', 'species:pos', this%property_list, help_string="list of properties to send with the structure") + call param_register(params, 'read_extra_property_list', '', this%read_extra_property_list, help_string="names of extra properties to read back") + call param_register(params, 'read_extra_param_list', 'QM_cell', this%read_extra_param_list, help_string="list of extra params (comment line in XYZ) to read back. Default is 'QM_cell'") + call param_register(params, 'property_list_prefixes', '', this%property_list_prefixes, help_string="list of prefixes to which run_suffix will be applied during calc()") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='SocketPot_initialise')) then + RAISE_ERROR('SocketPot_Initialise failed to parse args_str="'//trim(args_str)//"'", error) + endif + call finalise(params) + + this%label = 0 + this%init_args_str = args_str + if (present(mpi)) this%mpi = mpi + +end subroutine SocketPot_Initialise + +subroutine SocketPot_Finalise(this) + type(SocketPot_type), intent(inout) :: this + + call wipe(this) + +end subroutine SocketPot_Finalise + +subroutine SocketPot_Wipe(this) + type(SocketPot_type), intent(inout) :: this + + this%ip = '' + this%port = 0 + this%client_id = 0 + this%buffsize = 1000000 + this%property_list="" + this%read_extra_property_list="" + this%read_extra_param_list="" + this%property_list_prefixes="" + +end subroutine SocketPot_Wipe + +function SocketPot_cutoff(this) + type(SocketPot_type), intent(in) :: this + real(dp) :: SocketPot_cutoff + SocketPot_cutoff = 0.0_dp ! return zero, because SocketPot does its own connection calculation +end function SocketPot_cutoff + +subroutine SocketPot_Print(this, file) + type(SocketPot_type), intent(in) :: this + type(Inoutput), intent(inout),optional,target:: file + + if (current_verbosity() < PRINT_NORMAL) return + + call print('SocketPot: connecting to QUIP server on host '//trim(this%ip)//':'//this%port//' with client_id '//this%client_id, file=file) + call print(" buffsize="//this%buffsize//& + " property_list='"//trim(this%property_list)//& + "' read_extra_property_list='"//trim(this%read_extra_property_list)//& + "' read_extra_param_list='"//trim(this%read_extra_param_list)//& + "' property_list_prefixes='"//trim(this%property_list_prefixes)//"'", file=file) + +end subroutine SocketPot_Print + +subroutine SocketPot_Calc(this, at, energy, local_e, forces, virial, local_virial, args_str, error) + type(SocketPot_type), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: energy + real(dp), intent(out), target, optional :: local_e(:) + real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) + real(dp), intent(out), optional :: virial(3,3) + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + type(Atoms) :: at_copy + type(Dictionary) :: cli + integer n_params, n_copy, i, n_properties, label + real(dp), pointer :: local_e_ptr(:), force_ptr(:,:), local_virial_ptr(:,:) + logical :: calc_energy, calc_local_e, calc_force, calc_virial, calc_local_virial + character(STRING_LENGTH) :: my_args_str, tmp_params_array(100), copy_keys(100), property_list, & + read_extra_property_list, read_extra_param_list, run_suffix, tmp_properties_array(100) + + INIT_ERROR(error) + + my_args_str = '' + if (present(args_str)) my_args_str = args_str + + call param_register(cli, "property_list", trim(this%property_list), property_list, help_string="properties to send. Overrides init_args version.") + call param_register(cli, "read_extra_property_list", trim(this%read_extra_property_list), read_extra_property_list, help_string="extra properties to read. Overrides init_args version.") + call param_register(cli, "read_extra_param_list", trim(this%read_extra_param_list), read_extra_param_list, help_string="extra params to read. Overrides init_args version.") + call param_register(cli, "run_suffix", '', run_suffix, help_string="suffix to apply to property names in this%property_list_prefixes") + + if (.not. param_read_line(cli, my_args_str, ignore_unknown=.true.,task='socketpot_calc args_str')) then + RAISE_ERROR("FilePot_calc failed to parse args_str='"//trim(args_str)//"'",error) + endif + call finalise(cli) + + if (.not. this%mpi%active .or. (this%mpi%active .and. this%mpi%my_proc == 0)) then + calc_energy = .false. + calc_local_e = .false. + calc_force = .false. + calc_virial = .false. + calc_local_virial = .false. + if (present(energy)) then + energy = 0.0_dp + calc_energy = .true. + end if + if (present(local_e)) then + local_e = 0.0_dp + calc_local_e = .true. + end if + if (present(forces)) then + forces = 0.0_dp + calc_force = .true. + end if + if (present(virial)) then + virial = 0.0_dp + calc_virial = .true. + end if + if (present(local_virial)) then + local_virial = 0.0_dp + calc_local_virial = .true. + end if + + at_copy = at ! work with a copy of original Atoms + call set_value(at_copy%params, 'calc_energy', calc_energy) + call set_value(at_copy%params, 'calc_local_e', calc_local_e) + call set_value(at_copy%params, 'calc_virial', calc_virial) + call set_value(at_copy%params, 'calc_force', calc_force) + call set_value(at_copy%params, 'calc_local_virial', calc_local_virial) + call set_value(at_copy%params, 'label', this%label) + if (present(args_str)) then + call set_value(at_copy%params, 'calc_args_str', args_str) + end if + + if (len_trim(this%property_list_prefixes) /= 0) then + call parse_string(this%property_list_prefixes, ':', tmp_properties_array, n_properties, error=error) + do i=1, n_properties + property_list = trim(property_list)//':'//trim(tmp_properties_array(i))//run_suffix + end do + end if + + call system_timer('socket_send') + call socket_send_xyz(this%ip, this%port, this%client_id, at_copy, properties=property_list) + call system_timer('socket_send') + + this%label = this%label + 1 + + call system_timer('socket_recv') + call socket_recv_xyz(this%ip, this%port, this%client_id, this%buffsize, at_copy) + call system_timer('socket_recv') + + if (.not. get_value(at_copy%params, 'label', label)) then + RAISE_ERROR('SocketPot_Calc: missing label param in received atoms', error) + end if + if (label /= this%label) then + RAISE_ERROR('SocketPot_Calc: mismatch between labels expected ('//this%label//') and received ('//label//').', error) + end if + + if (present(energy)) then + if (.not. get_value(at_copy%params, 'energy', energy)) then + call print('WARNING SocketPot_calc: "energy" requested but not returned by callback') + endif + end if + + if (present(local_e)) then + if (.not. assign_pointer(at_copy, 'local_e', local_e_ptr)) then + call print('WARNING SocketPot_calc: "local_e" requested but not returned by callback') + else + local_e(:) = local_e_ptr + end if + end if + + if (present(forces)) then + if (.not. assign_pointer(at_copy, 'force', force_ptr)) then + call print('WARNING SocketPot_calc: "forces" requested but not returned by callback') + else + forces(:,:) = force_ptr + end if + end if + + if (present(virial)) then + if (.not. get_value(at_copy%params, 'virial', virial)) then + call print('WARNING SocketPot_calc: "virial" requested but not returned by callback') + end if + end if + + if (present(local_virial)) then + if (.not. assign_pointer(at_copy, 'local_virial', local_virial_ptr)) then + call print('WARNING SocketPot_calc: "local_virial" requested but not returned by callback') + else + local_virial(:,:) = local_virial_ptr + end if + end if + + if (len_trim(read_extra_property_list) > 0) then + call copy_properties(at, at_copy, trim(read_extra_property_list)) + endif + + if (len_trim(read_extra_param_list) > 0) then + call parse_string(read_extra_param_list, ':', tmp_params_array, n_params, error=error) + PASS_ERROR(error) + + n_copy = 0 + do i=1,n_params + if (has_key(at_copy%params, trim(tmp_params_array(i)))) then + n_copy = n_copy + 1 + copy_keys(n_copy) = tmp_params_array(i) + call print("SocketPot copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) + else if (has_key(at_copy%params, trim(tmp_params_array(i))//trim(run_suffix))) then + n_copy = n_copy + 1 + copy_keys(n_copy) = trim(tmp_params_array(i))//trim(run_suffix) + call print("SocketPot copying param key "//trim(copy_keys(n_copy)), PRINT_VERBOSE) + end if + end do + + call subset(at_copy%params, copy_keys(1:n_copy), at%params, out_no_initialise=.true.) + end if + end if + + if (this%mpi%active) then + ! Share results with other nodes + if (present(energy)) call bcast(this%mpi, energy) + if (present(local_e)) call bcast(this%mpi, local_e) + + if (present(forces)) call bcast(this%mpi, forces) + if (present(virial)) call bcast(this%mpi, virial) + if (present(local_virial)) call bcast(this%mpi, local_virial) + end if + + call finalise(at_copy) + +end subroutine SocketPot_calc + +end module SocketPot_module diff --git a/src/Potentials/TB.F90 b/src/Potentials/TB.F90 new file mode 100644 index 0000000000..012db28980 --- /dev/null +++ b/src/Potentials/TB.F90 @@ -0,0 +1,2360 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X TB module +!X +!% General object which handles all the possible tight-binding potentials (TB), re-addressing +!% the calls to the right routines. +!% +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" +module TB_module + +use error_module +use system_module, only : dp, inoutput, initialise, finalise, INPUT, current_verbosity, print, & + DEALLOC_TRACE, PRINT_NORMAL, PRINT_VERBOSE, PRINT_ALWAYS, PRINT_NERD, PRINT_ANALYSIS, optional_default, mpi_id, REAL_SIZE, ALLOC_TRACE, & + verbosity_push_decrement, verbosity_push, verbosity_pop, system_timer, operator(//) +use mpi_context_module, only : mpi_context, finalise +use linearalgebra_module, only : operator(.feq.), operator(.fne.), operator(.mult.) +use extendable_str_module, only : extendable_str, initialise, finalise, read, string +use dictionary_module, only : dictionary, get_value, set_value, STRING_LENGTH +use paramreader_module, only : param_register, param_read_line +use atoms_types_module, only : assign_pointer +use atoms_module, only : atoms, calc_connect, set_cutoff, assignment(=) +use CInOutput_module, only : write + +use QUIP_common_module + +use Functions_module, only : f_fermi, f_fermi_deriv +use ApproxFermi_module, only : approxfermi, approx_f_fermi, approx_f_fermi_deriv, initialise, finalise, print +use Matrix_module, only : matrixd, add_identity, inverse +! use RS_SparseMatrix_module +use TB_KPoints_module, only : kpoints, ksum_dup, ksum_distrib, local_ksum, min, max, ksum_distrib_inplace, collect +use TBModel_module, only : has_band_width, has_Fermi_T, has_Fermi_E, get_local_rep_E, get_local_rep_E_force, get_local_rep_E_virial +use TBMatrix_module, only : tbmatrix, tbvector, finalise, wipe, diagonalise, partial_TraceMult, Re_diag, diag_spinor, partial_TraceMult_spinor, TraceMult, matrix_product_sub, & + multDiag, multDiagRL, zero, transpose_sub, accum_scaled_elem_product, scaled_accum, copy +use TBSystem_module, only : tbsystem, initialise, finalise, wipe, print, setup_atoms, update_orb_local_pot, atom_orbital_spread, & + scf_e_correction, scf_f_correction, scf_virial_correction, atom_orbital_sum, fill_matrices, fill_dmatrices, fill_these_matrices, & + SCF_LCN, SCF_GCN, SCF_LOCAL_U, SCF_NONLOCAL_U_DFTB, SCF_NONLOCAL_U_NRL_TB, n_elec, scf_set_atomic_n_mom, scf_set_global_n, & + calc_orb_local_pot, scf_get_atomic_n_mom, scf_get_global_n, set_type, local_scf_e_correction, fill_sc_matrices, setup_deriv_matrices, & + add_term_d2scfe_dn2_times_vec, add_term_dscf_e_correction_dn, add_term_d2scfe_dgndn, atom_orbital_spread_mat, ksum_atom_orbital_sum_mat, & + add_term_dscf_e_correction_dgn, copy_matrices +use TB_GreensFunctions_module, only : greensfunctions, initialise, finalise, wipe, print, calc_dm_from_gs, calc_gs, calc_mod_dm_from_gs, gsum_distrib_inplace + +implicit none +private + +public :: TB_type +type TB_type + type(TBSystem) tbsys + type(Atoms) at + integer method + + type(TBVector) :: evals, E_fillings, F_fillings, eval_F_fillings + type(TBMatrix) :: evecs + type(TBMatrix) :: dm, Hdm, scaled_evecs + + type(MPI_context) :: mpi + + type (GreensFunctions) gf + + logical :: calc_done = .false. + real(dp) :: fermi_E, fermi_T + real(dp) :: fermi_E_precision = 1.0e-9_dp + real(dp) :: homo_e, lumo_e + + character(len=1024) :: init_args_str + character(len=1024) :: calc_args_str + +end type TB_type + +public :: Initialise +public :: TB_Initialise_filename +interface Initialise + module procedure TB_Initialise_inoutput, TB_Initialise_str +end interface Initialise + +public :: Finalise +interface Finalise + module procedure TB_Finalise +end interface Finalise + +public :: cutoff +interface cutoff + module procedure TB_cutoff +end interface + +public :: Wipe +interface Wipe + module procedure TB_Wipe +end interface Wipe + +public :: Print +interface Print + module procedure TB_Print +end interface Print + +public :: Setup_atoms +interface Setup_atoms + module procedure TB_Setup_atoms +end interface Setup_atoms + +public :: solve_diag +interface solve_diag + module procedure TB_solve_diag +end interface + +public :: calc +interface calc + module procedure TB_calc +end interface + +public :: calc_diag +interface calc_diag + module procedure TB_calc_diag +end interface + +public :: calc_GF +interface calc_GF + module procedure TB_calc_GF +end interface + +public :: TB_evals + +public :: absorption + +interface find_fermi_E + module procedure TB_find_fermi_E +end interface find_fermi_E + +interface calc_E_fillings + module procedure TB_calc_E_fillings +end interface calc_E_fillings + +interface calc_F_fillings + module procedure TB_calc_F_fillings +end interface calc_F_fillings + +interface realloc_match_tbsys + module procedure realloc_match_tbsys_vec, realloc_match_tbsys_mat +end interface realloc_match_tbsys + +public :: copy_matrices +interface copy_matrices + module procedure TB_copy_matrices +end interface copy_matrices + +contains + + +subroutine TB_Initialise_filename(this, args_str, filename, kpoints_obj, mpi_obj, error) + type(TB_type), intent(inout) :: this + character(len=*), intent(in) :: args_str + character(len=*), intent(in) :: filename + type(KPoints), intent(in), optional :: kpoints_obj + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(inoutput) io + + INIT_ERROR(error) + + call Initialise(io, filename, INPUT) + + call Initialise(this, args_str, io, kpoints_obj, mpi_obj, error) + PASS_ERROR(error) + + call Finalise(io) + +end subroutine TB_Initialise_filename + +subroutine TB_Initialise_inoutput(this, args_str, io_obj, kpoints_obj, mpi_obj, error) + type(TB_type), intent(inout) :: this + character(len=*), intent(in) :: args_str + type(Inoutput), intent(inout), optional :: io_obj + type(KPoints), intent(in), optional :: kpoints_obj + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + type(extendable_str) :: ss + + INIT_ERROR(error) + + call Initialise(ss) + if (present(io_obj)) then + if (present(mpi_obj)) then + call read(ss, io_obj%unit, convert_to_string=.true., mpi_comm = mpi_obj%communicator, mpi_id = mpi_obj%my_proc) + else + call read(ss, io_obj%unit, convert_to_string=.true.) + endif + endif + call Initialise(this, args_str, string(ss), kpoints_obj, mpi_obj, error) + PASS_ERROR(error) + + call Finalise(ss) + +end subroutine TB_Initialise_inoutput + + +subroutine TB_Initialise_str(this, args_str, param_str, kpoints_obj, mpi_obj, error) + type(TB_type), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(KPoints), intent(in), optional :: kpoints_obj + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + INIT_ERROR(error) + + call Finalise(this) + + this%init_args_str = args_str + + if (present(mpi_obj)) then + this%mpi = mpi_obj + endif + call Initialise(this%tbsys, args_str, param_str, kpoints_obj, mpi_obj) +end subroutine TB_Initialise_str + +subroutine TB_Finalise(this) + type(TB_type), intent(inout) :: this + + call Wipe(this) + call Finalise(this%tbsys) + call Finalise(this%mpi) + call Finalise(this%evals) + call Finalise(this%E_fillings) + call Finalise(this%F_fillings) + call Finalise(this%eval_F_fillings) + call Finalise(this%evecs) + call Finalise(this%dm) + call Finalise(this%Hdm) + call Finalise(this%gf) +end subroutine + +subroutine TB_Wipe(this) + type(TB_type), intent(inout) :: this + + call Wipe(this%tbsys) + call Wipe(this%evals) + call Wipe(this%E_fillings) + call Wipe(this%F_fillings) + call Wipe(this%eval_F_fillings) + call Wipe(this%evecs) + call Wipe(this%dm) + call Wipe(this%Hdm) + call Wipe(this%gf) + + this%calc_done = .false. + +end subroutine + +function TB_cutoff(this) + type(TB_type), intent(in) :: this + real(dp) :: TB_cutoff + TB_cutoff = 0.0_dp ! return zero, because TB does its own connection calculation +end function TB_cutoff + +subroutine TB_Print(this, file) + type(TB_type), intent(in) :: this + type(Inoutput), intent(inout),optional,target:: file + + if (current_verbosity() < PRINT_NORMAL) return + + call Print('TB : ', file=file) + + if (this%calc_done) then + call print("Fermi_E " // this%Fermi_E //" Fermi_T " // this%Fermi_T) + else + call print("Fermi_E, Fermi_T not yet set (no calc done)") + endif + + call Print (this%tbsys, file=file) + if (this%calc_done) then + call print ("homo " // this%homo_e // " lumo " // this%lumo_e // " gap " // (this%lumo_e-this%homo_e), file=file) + else + call print("homo, lumo, gap not yet set (no calc done)") + endif + call verbosity_push_decrement() + call print("evals", file=file) + call Print (this%evals, file=file) + call verbosity_push_decrement() + call print("E_fillings", file=file) + call Print (this%E_fillings, file=file) + call print("F_fillings", file=file) + call Print (this%F_fillings, file=file) + call print("eval_F_fillings", file=file) + call Print (this%eval_F_fillings, file=file) + call verbosity_push_decrement() + call print("evecs", file=file) + call Print (this%evecs, file=file) + call print("dm", file=file) + call Print (this%dm, file=file) + call print("Hdm", file=file) + call Print (this%Hdm, file=file) + call print("gf", file=file) + call Print (this%gf, file=file) + call verbosity_pop() + call verbosity_pop() + call verbosity_pop() + +end subroutine TB_Print + +subroutine TB_copy_matrices(this, Hd, Sd, Hz, Sz, index) + type(TB_type), intent(in) :: this + real(dp), intent(inout), optional, dimension(:,:) :: Hd, Sd + complex(dp), intent(inout), optional, dimension(:,:) :: Hz, Sz + integer, intent(in), optional :: index + + call copy_matrices(this%tbsys, Hd, Sd, Hz, Sz, index) +end subroutine TB_copy_matrices + + +subroutine TB_Setup_atoms(this, at, is_noncollinear, is_spinpol_no_scf, args_str, error) + type(TB_type), intent(inout) :: this + type(Atoms), intent(in) :: at + logical, intent(in), optional :: is_noncollinear, is_spinpol_no_scf + character(len=*), intent(in), optional :: args_str + integer, intent(out), optional :: error + + INIT_ERROR(error) + + call wipe(this%tbsys) + call setup_atoms(this%tbsys, at, is_noncollinear, is_spinpol_no_scf, args_str, this%mpi, error=error) + PASS_ERROR(error) + + this%at = at + call set_cutoff(this%at, this%tbsys%tbmodel%cutoff) + call calc_connect(this%at, own_neighbour=.true.) + +end subroutine TB_setup_atoms + + +subroutine realloc_match_tbsys_vec(tbsys, vec) + type(TBSystem), intent(in) :: tbsys + type(TBVector), intent(inout) :: vec + + if (vec%N /= tbsys%N .or. vec%n_vectors /= tbsys%n_matrices) then + call Finalise(vec) + call Initialise(vec, tbsys%N, tbsys%n_matrices) + endif +end subroutine realloc_match_tbsys_vec + +subroutine realloc_match_tbsys_mat(tbsys, mat) + type(TBSystem), intent(in) :: tbsys + type(TBMatrix), intent(inout) :: mat + + if (mat%N /= tbsys%N .or. mat%n_matrices /= tbsys%n_matrices) then + call Finalise(mat) + call Initialise(mat, tbsys%N, tbsys%n_matrices, tbsys%complex_matrices, & + scalapack_obj=tbsys%scalapack_my_matrices) + endif +end subroutine realloc_match_tbsys_mat + +subroutine TB_solve_diag(this, need_evecs, use_fermi_E, fermi_E, w_n, use_prev_charge, AF, error) + type(TB_type), intent(inout) :: this + logical, intent(in), optional :: need_evecs + logical, optional, intent(in) :: use_Fermi_E + real(dp), optional, intent(inout) :: fermi_E + real(dp), pointer, intent(in) :: w_n(:) + logical, optional, intent(in) :: use_prev_charge + type(ApproxFermi), intent(inout), optional :: AF + integer, intent(out), optional :: error + + logical my_use_prev_charge + + real(dp), pointer :: scf_orbital_n(:), scf_orbital_m(:,:) + real(dp) :: global_N + real(dp), pointer :: local_N(:), local_mom(:,:), local_pot(:) + logical do_evecs + + integer diag_error + integer :: max_iter = 1 + integer iter + logical scf_converged + + INIT_ERROR(error) + + my_use_prev_charge = optional_default(.false., use_prev_charge) + + if (this%at%cutoff < this%tbsys%tbmodel%cutoff) & + call print ("WARNING: Called TB_solve_diag with messed up cutoff in atoms: cutoff "// & + this%at%cutoff // " < " // this%tbsys%tbmodel%cutoff) + + if (present(AF)) then + if (present(use_fermi_E)) then + if (use_fermi_E) then + if (AF%n_poles == 0) then + call system_abort("Called solve_diag with use_fermi_E and AF that is uninitialized") + endif + else + if (AF%band_width .feq. 0.0_dp) then + call system_abort("Called solve_diag with .not. use_fermi_E and AF that has no band_width") + endif + endif + endif + endif + + if (this%tbsys%scf%active) then + max_iter= this%tbsys%scf%max_iter + endif + + if (this%tbsys%scf%active) then + if (my_use_prev_charge) then + + if (assign_pointer(this%at, 'local_N', local_N)) then + call print("TB_solve_diag calling set_atomic_n_mom(this%tbsys%scf) using this%at:local_N", PRINT_VERBOSE) + else + call print("TB_solve_diag got use_prev_charge, but no local_N value is defined", PRINT_ALWAYS) + endif + if (assign_pointer(this%at, 'local_mom', local_mom)) then + call print("TB_solve_diag calling set_atomic_n_mom(this%tbsys%scf) using this%at:local_mom", PRINT_VERBOSE) + else + call print("TB_solve_diag got use_prev_charge, but no local_mom value is defined", PRINT_ALWAYS) + endif + if (assign_pointer(this%at, 'local_pot', local_pot)) then + call print("TB_solve_diag calling set_atomic_n_mom(this%tbsys%scf) using this%at:local_pot", PRINT_VERBOSE) + else + call print("TB_solve_diag got use_prev_charge, but no local_pot value is defined", PRINT_ALWAYS) + endif + + call scf_set_atomic_n_mom(this%tbsys, local_N, local_mom, local_pot) + + if (get_value(this%at%params, 'global_N', global_N)) then + call print("TB_solve_diag calling set_global_N(this%tbsys%scf from this%at:global_N", PRINT_VERBOSE) + call scf_set_global_N(this%tbsys, w_n, global_N) + else + call scf_set_global_N(this%tbsys, w_n) + call print("TB_solve_diag got use_prev_charge, but no global_N value is defined", PRINT_ALWAYS) + endif + + else + nullify(local_N) + nullify(local_mom) + nullify(local_pot) + call scf_set_atomic_n_mom(this%tbsys, local_N, local_mom, local_pot) + call scf_set_global_N(this%tbsys, w_n) + endif + endif + + do_evecs = .false. + if (present(need_evecs)) do_evecs = need_evecs + do_evecs = do_evecs .or. this%tbsys%scf%active + + call realloc_match_tbsys(this%tbsys, this%evals) + if (do_evecs) then + call realloc_match_tbsys(this%tbsys, this%evecs) + endif + + nullify(scf_orbital_n) + nullify(scf_orbital_m) + if (this%tbsys%scf%active) then + allocate(scf_orbital_n(this%tbsys%N)) + if (this%tbsys%noncollinear) then + allocate(scf_orbital_m(3,this%tbsys%N)) + endif + endif + call fill_sc_matrices(this%tbsys, this%at) + + call calc_orb_local_pot(this%tbsys, w_n) + + iter = 1 + scf_converged = .false. + if(this%tbsys%scf%active) call print("TB starting SCF iterations") + do while (iter <= max_iter .and. .not. scf_converged) + + call fill_matrices(this%tbsys, this%at) + + if (this%tbsys%tbmodel%is_orthogonal) then + if (do_evecs) then + call diagonalise(this%tbsys%H, this%evals, this%evecs, ignore_symmetry = .true., error = diag_error) + else + call diagonalise(this%tbsys%H, this%evals, ignore_symmetry = .true., error = diag_error) + end if + else + if (do_evecs) then + call diagonalise(this%tbsys%H, this%tbsys%S, this%evals, this%evecs, ignore_symmetry = .true., error = diag_error) + else + call diagonalise(this%tbsys%H, this%tbsys%S, this%evals, ignore_symmetry = .true., error = diag_error) + endif + endif + + if (diag_error /= 0) then + if (this%mpi%my_proc == 0) then + call write(this%at, "atom_dump_bad_diagonalise."//mpi_id()//".xyz") + endif + RAISE_ERROR_WITH_KIND(diag_error, "TB_solve_diag got error " // diag_error // " from diagonalise", error) + endif + + if (this%tbsys%scf%active) then + call calc_E_fillings(this, use_fermi_e, fermi_E, AF, w_n) + call calc_dm_from_evecs(this) + call calc_local_orbital_num(this, scf_orbital_n) + if (this%tbsys%noncollinear) call calc_local_orbital_mom(this, scf_orbital_m) + scf_converged = update_orb_local_pot(this%tbsys, this%at, iter, w_n, scf_orbital_n, scf_orbital_m) + else + scf_converged = .true. + endif + iter = iter + 1 + + if (current_verbosity() >= PRINT_VERBOSE) then + if (this%tbsys%scf%active) then + if (assign_pointer(this%at, 'local_N', local_N) .or. assign_pointer(this%at, 'local_mom', local_mom) .or. & + assign_pointer(this%at, 'local_pot', local_pot)) then + call scf_get_atomic_n_mom(this%tbsys, local_N, local_mom, local_pot) + endif + if (get_value(this%at%params, 'global_N', global_N)) then + call scf_get_global_N(this%tbsys, global_N) + call set_value(this%at%params, 'global_N', global_N) + endif + endif + call write(this%at, 'stdout', prefix="SCF_ITER_"//iter) + endif ! VERBOSE + + end do + + if (this%tbsys%scf%active) then + if (assign_pointer(this%at, 'local_N', local_N) .or. assign_pointer(this%at, 'local_mom', local_mom) .or. & + assign_pointer(this%at, 'local_pot', local_pot)) then + call scf_get_atomic_n_mom(this%tbsys, local_N, local_mom, local_pot) + endif + if (get_value(this%at%params, 'global_N', global_N)) then + call scf_get_global_N(this%tbsys, global_N) + call set_value(this%at%params, 'global_N', global_N) + endif + endif + + if (associated(scf_orbital_n)) deallocate(scf_orbital_n) + if (associated(scf_orbital_m)) deallocate(scf_orbital_m) + + if (.not. scf_converged) then + call print("WARNING: TB_solve_diag failed to converge SCF in TB_solve_diag", PRINT_ALWAYS) + endif + + if (this%tbsys%scf%active .and. scf_converged ) call print("TB SCF iterations converged") +end subroutine TB_solve_diag + +subroutine TB_calc(this, at, energy, local_e, forces, virial, local_virial, args_str, & + use_fermi_E, fermi_E, fermi_T, band_width, AF, dH, dS, index, error) + + type(TB_type), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(out), optional :: energy + real(dp), intent(out), optional :: local_e(:) + real(dp), intent(out), optional :: forces(:,:), local_virial(:,:) + real(dp), intent(out), optional :: virial(3,3) + character(len=*), intent(in), optional :: args_str + logical, optional :: use_fermi_E + real(dp), intent(inout), optional :: fermi_E, fermi_T, band_width + type(ApproxFermi), intent(inout), optional :: AF + real(dp), optional, intent(inout), dimension(:,:,:,:) :: dH + real(dp), optional, intent(inout), dimension(:,:,:,:) :: dS + integer, optional, intent(in) :: index + integer, intent(out), optional :: error + + real(dp) :: my_energy + logical :: my_use_Fermi_E + real(dp) :: my_Fermi_E, my_Fermi_T, my_band_width + character(len=STRING_LENGTH) :: solver_arg + logical :: noncollinear, spinpol_no_scf, use_prev_charge, do_evecs + type(ApproxFermi) :: my_AF + logical :: do_at_local_N + real(dp), pointer :: local_N_p(:) + + type(Dictionary) :: params + logical :: has_atom_mask_name + character(STRING_LENGTH) :: atom_mask_name + real(dp) :: r_scale, E_scale + logical :: do_rescale_r, do_rescale_E + + INIT_ERROR(error) + + call system_timer("TB_calc") + call system_timer("TB_calc/prep") + + if (present(args_str)) then + this%calc_args_str = args_str + call initialise(params) + call param_register(params, 'solver', 'DIAG', solver_arg, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'noncollinear', 'F', noncollinear, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'spinpol_no_scf', 'F', spinpol_no_scf, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'use_prev_charge', 'F', use_prev_charge, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'do_at_local_N', 'F', do_at_local_N, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'do_evecs', 'F', do_evecs, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.") + call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TB_Calc args_str')) then + call system_abort("TB_calc failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + + call set_type(this%tbsys%scf, args_str) + + if(has_atom_mask_name) then + RAISE_ERROR('TB_Calc: atom_mask_name found, but not supported', error) + endif + if (do_rescale_r .or. do_rescale_E) then + RAISE_ERROR("TB_Calc: rescaling of potential with r_scale and E_scale not implemented!", error) + end if + else + this%calc_args_str = '' + solver_arg = 'DIAG' + noncollinear = .false. + spinpol_no_scf = .false. + do_evecs = .false. + use_prev_charge = .false. + do_at_local_N = .false. + endif + call setup_atoms(this, at, noncollinear, spinpol_no_scf, args_str, error=error) + PASS_ERROR(error) + + if( present(local_virial) ) then + RAISE_ERROR("TB_Calc: local_virial calculation requested, but not implemented yet",error) + endif + + if(current_verbosity() > PRINT_NERD) then + call write(this%at, "tb_calc_atomslog.xyz", append=.true.) + end if + + call system_timer("TB_calc/prep") + + ! local_N_p points to at property local_N if do_at_local_N is true and at property local_N is defined + nullify(local_N_p) + if (do_at_local_N) then + if (.not. assign_pointer(this%at, 'local_N', local_N_p)) & + call system_abort("TB_calc got do_at_local_N=T, but failed to find local_N property") + endif + + select case (trim(solver_arg)) + case ('DIAG') + call system_timer("TB_calc/DIAG_calc_diag") + my_energy = calc_diag(this, use_fermi_E, fermi_E, fermi_T, local_e, local_N_p, forces, virial, & + use_prev_charge = use_prev_charge, AF=AF, do_evecs = do_evecs, dH=dH, dS=dS, index=index, error=error) + call system_timer("TB_calc/DIAG_calc_diag") + case ('GF') + call system_timer("TB_calc/GF_calc_GF") + if (present(virial)) call system_abort("No virial with GF (yet?)") + my_energy = calc_GF(this, use_fermi_E, fermi_E, fermi_T, band_width, local_e, local_N_p, forces, AF) + call system_timer("TB_calc/GF_calc_GF") + case ('DIAG_GF') + call system_timer("TB_calc/DIAG_GF") + call system_timer("TB_calc/DIAG_GF_prep") + if (present(virial)) call system_abort("No virial with GF (yet?)") + + if (.not. has_Fermi_T(my_fermi_T, this%tbsys%tbmodel, Fermi_T, this%calc_args_str)) & + call system_abort("TB_calc called without Fermi_T for model without default Fermi_T") + if (.not. has_band_width(my_band_width, this%tbsys%tbmodel, band_width, this%calc_args_str)) & + call system_abort("TB_calc called without band_width for model without default band_width") + + ! default to constant mu, for now at least + my_use_fermi_E = optional_default(.true., use_fermi_E) + + if (my_use_Fermi_E .and. .not. present(AF)) then + if (.not. has_Fermi_E(my_Fermi_E, this%tbsys%tbmodel, Fermi_E, this%calc_args_str)) & + call system_abort("Called TB_calc with use_Fermi_E but neither AF nor Fermi_E nor TB Model with default Fermi_E") + endif + + if (present(AF)) then + my_AF = AF + else + call Initialise(my_AF, my_Fermi_E, my_Fermi_T, my_band_width) + end if + call system_timer("TB_calc/DIAG_GF_prep") + + call system_timer("TB_calc/DIAG_GF_calc_diag") + my_energy = calc_diag(this, my_use_fermi_E, local_e = local_e, & + local_N = local_N_p, use_prev_charge = use_prev_charge, do_evecs = do_evecs, & + AF = my_AF) + call system_timer("TB_calc/DIAG_GF_calc_diag") + if (present(forces)) then + call system_timer("TB_calc/DIAG_GF_calc_GF") + my_energy = calc_GF(this, use_fermi_E = .true., local_e = local_e, local_N = local_N_p, forces = forces, AF = my_AF) + call system_timer("TB_calc/DIAG_GF_calc_GF") + endif + call finalise(my_AF) + call system_timer("TB_calc/DIAG_GF") + case default + call system_abort("TB_calc confused by args '" // trim(solver_arg) // "'") + end select + + if (present(energy)) energy = my_energy + call system_timer("TB_calc") + + this%calc_done = .true. + + call copy_atoms_fields(this%at, at) + + +end subroutine TB_calc + +subroutine copy_atoms_fields(from_at, to_at) + type(Atoms), intent(in):: from_at + type(Atoms), intent(inout):: to_at + + real(dp), pointer :: from_R1(:), to_R1(:), from_R2(:,:), to_R2(:,:) + real(dp) :: from_R + + if (assign_pointer(from_at, 'local_N', from_R1) .and. & + assign_pointer(to_at, 'local_N', to_R1)) then + to_R1 = from_R1 + endif + if (assign_pointer(from_at, 'local_mom', from_R2) .and. & + assign_pointer(to_at, 'local_mom', to_R2)) then + to_R2 = from_R2 + endif + if (assign_pointer(from_at, 'local_N', from_R1) .and. & + assign_pointer(to_at, 'local_N', to_R1)) then + to_R1 = from_R1 + endif + if (assign_pointer(from_at, 'local_E', from_R1) .and. & + assign_pointer(to_at, 'local_E', to_R1)) then + to_R1 = from_R1 + endif + if (assign_pointer(from_at, 'local_pot', from_R1) .and. & + assign_pointer(to_at, 'local_pot', to_R1)) then + to_R1 = from_R1 + endif + + if (get_value(from_at%params, 'global_dN', from_R)) then + call set_value(to_at%params, 'global_dN', from_R) + endif + +end subroutine copy_atoms_fields + +function TB_calc_diag(this, use_fermi_E, fermi_E, fermi_T, local_e, local_N, forces, virial, use_prev_charge, AF, do_evecs, dH, dS, index, error) + type(TB_type), intent(inout) :: this + logical, optional :: use_fermi_E + real(dp), intent(inout), optional :: fermi_E, fermi_T + real(dp), intent(out), target, optional :: local_e(:) + real(dp), intent(out), pointer, optional :: local_N(:) + real(dp), intent(out), optional :: forces(:,:) + real(dp), intent(out), optional :: virial(3,3) + logical, optional, intent(in) :: use_prev_charge + type(ApproxFermi), intent(inout), optional :: AF + logical, optional :: do_evecs + real(dp), optional, intent(inout), dimension(:,:,:,:) :: dH + real(dp), optional, intent(inout), dimension(:,:,:,:) :: dS + integer, optional, intent(in) :: index + integer, intent(out), optional :: error + real(dp) :: TB_calc_diag + + real(dp), allocatable :: forces_scf(:,:) + real(dp) :: virial_scf(3,3) + real(dp), allocatable :: local_e_scf(:), local_e_rep(:) + real(dp) :: global_e_scf + real(dp), pointer :: u_local_e(:) + real(dp) :: u_e, u_e_scf, u_e_rep + integer :: i + logical :: u_do_evecs, do_local_N, do_local_e + + type(Dictionary) :: params + + real(dp), pointer :: w_e(:) + real(dp), pointer :: w_n(:) + + INIT_ERROR(error) + + call system_timer("TB_calc_diag") + call system_timer("TB_calc_diag/prep") + call print("TB_calc_diag starting", PRINT_VERBOSE) + + if (.not. assign_pointer(this%at, "weight", w_e)) then + nullify(w_e) + else + call print("Using weight from atom properties for w_e", PRINT_VERBOSE) + endif + if (.not. assign_pointer(this%at, "weight_n", w_n)) then + if (.not. assign_pointer(this%at, "weight", w_n)) then + nullify(w_n) + else + call print("Using weight from atom properties for w_n", PRINT_VERBOSE) + endif + else + call print("Using weight_n from atom properties for w_n", PRINT_VERBOSE) + endif + + if (associated(w_e) .and. (present(forces) .or. present(virial))) then + if (maxval(w_e) .ne. 1.0_dp .or. minval(w_e) .ne. 1.0_dp) then + call system_abort ("TB_calc_diag can't do forces or virial of weighted energy") + endif + endif + + do_local_N = .false. + if (present(local_N)) then + if (associated(local_N)) then + if (size(local_N) == this%at%N) then + do_local_N = .true. + else + if (size(local_N) /= 0) & + call system_abort("TB_calc_diag called with size(local_N)="//size(local_N)// & + " not 0, and not matching this%at%N="//this%at%N) + endif + endif + endif + do_local_e = .false. + if (present(local_e)) then + if (size(local_e) == this%at%N) then + do_local_e = .true. + else + if (size(local_e) /= 0) & + call system_abort("TB_calc_diag called with size(local_e)="//size(local_e)// & + " not 0, and not matching this%at%N="//this%at%N) + endif + endif + + u_do_evecs = optional_default(.false., do_evecs) .or. present(forces) .or. present(virial) .or. & + do_local_e .or. associated(w_e) .or. & + do_local_N .or. associated(w_n) .or. this%tbsys%scf%active + if (u_do_evecs) call print("evecs are needed", PRINT_VERBOSE) + + if (.not. has_fermi_T(this%fermi_T, this%tbsys%tbmodel, fermi_T, this%calc_args_str)) & + call system_abort("TB_calc_diag called without fermi_T for a TB model without default fermi T") + call system_timer("TB_calc_diag/prep") + + call initialise(params) + call param_register(params, 'fermi_e_precision', ''//this%fermi_E_precision, this%fermi_E_precision, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, this%calc_args_str, ignore_unknown=.true.,task='TB_calc_diag fermi_e_precision')) then + call system_abort("TBModel_has_fermi_e failed to parse this%calc_args_str='"//trim(this%calc_args_str)//"'") + endif + call finalise(params) + + call system_timer("TB_calc_diag/solve_diag") + call print("TB_calc_diag solve_diag", PRINT_VERBOSE) + call solve_diag(this, u_do_evecs, use_fermi_e, Fermi_E, w_n, use_prev_charge=use_prev_charge, AF=AF, error=error) + call system_timer("TB_calc_diag/solve_diag") + PASS_ERROR_WITH_INFO("TB_calc got error from solve_diag", error) + + call system_timer("TB_calc_diag/calc_EFV") + allocate(local_e_rep(this%at%N)) + do i=1, this%at%N + local_e_rep(i) = get_local_rep_E(this%tbsys%tbmodel, this%at, i) + end do + + if (present(fermi_T)) then + if (fermi_T .fne. this%fermi_T) then + this%fermi_T = fermi_T + endif + endif + if (present(fermi_E)) then + if (fermi_E .fne. this%fermi_E) then + this%fermi_E = fermi_E + endif + endif + + call system_timer("TB_calc_diag/calc_EFV/calc_E_fillings") + call calc_E_fillings(this, use_fermi_E, fermi_E, AF, w_n) + call system_timer("TB_calc_diag/calc_EFV/calc_E_fillings") + if (present(AF)) then + call print("TB_calc_diag using AF Fermi_E " // AF%Fermi_E // " band_width " // AF%band_width // " n_poles " // AF%n_poles, PRINT_VERBOSE) + else + call print("TB_calc_diag has Fermi_E " // this%Fermi_E // " Fermi_T " // this%Fermi_T, PRINT_VERBOSE) + endif + + if (do_local_e .or. associated(w_e) .or. do_local_N .or. associated(w_n)) then + call print("TB_calc_diag calculating per atom stuff", PRINT_VERBOSE) + call system_timer("TB_calc_diag/calc_EFV/calc_dm_for_local_stuff") + call calc_dm_from_evecs(this, .false.) + call system_timer("TB_calc_diag/calc_EFV/calc_dm_for_local_stuff") + + call system_timer("TB_calc_diag/calc_EFV/calc_local_stuff") + if (do_local_e) then + u_local_e => local_e + else + allocate(u_local_e(this%at%N)) + endif + allocate(local_e_scf(this%at%N)) + + call calc_local_atomic_energy(this, u_local_e) + call local_scf_e_correction(this%tbsys, this%at, local_e_scf, global_e_scf, w_n) + call print("TB_calc_diag got sum(local_energies) eval " // sum(u_local_e) // & + " scf " // sum(local_e_scf) // " rep " // sum(local_e_rep), PRINT_VERBOSE) + u_local_e = u_local_e + local_e_scf + local_e_rep + + if (associated(w_e)) then + u_local_e = u_local_e + global_e_scf/sum(w_e) + TB_calc_diag = sum(w_e*u_local_e) + else + u_local_e = u_local_e + global_e_scf/size(u_local_e) + TB_calc_diag = sum(u_local_e) + endif + + deallocate(local_e_scf) + if (.not. present(local_e)) deallocate(u_local_e) + + if (do_local_N) call calc_local_atomic_num(this, local_N) + + call system_timer("TB_calc_diag/calc_EFV/calc_local_stuff") + else ! no local E or N required + call system_timer("TB_calc_diag/calc_EFV/E_calc") + u_e = ksum_dup(this%tbsys%kpoints, sum(this%evals%data_d*this%E_fillings%data_d,dim=1)) + u_e_rep = sum(local_e_rep) + u_e_scf = scf_e_correction(this%tbsys, this%at, w_n) + call print("TB_calc_diag got energies eval " // u_e // " scf " // u_e_scf // " rep " // u_e_rep, PRINT_VERBOSE) + TB_calc_diag = u_e + u_e_rep + u_e_scf + call system_timer("TB_calc_diag/calc_EFV/E_calc") + endif + + if (present(forces) .or. present(virial)) then + call print("TB_calc_diag calculating forces", PRINT_VERBOSE) + call calc_F_fillings(this, .not. this%tbsys%tbmodel%is_orthogonal, AF) + call system_timer("TB_calc_diag/calc_EFV/calc_dm_for_FV") + call calc_dm_from_evecs(this, .true.) + call system_timer("TB_calc_diag/calc_EFV/calc_dm_for_FV") + if (present(forces)) then + call system_timer("TB_calc_diag/calc_EFV/calculate_forces") + forces = calculate_forces_diag(this, dH, dS, index) + allocate(forces_scf(3,this%at%N)) + forces_scf = scf_f_correction(this%tbsys, this%at) + forces = forces + forces_scf + deallocate(forces_scf) + call system_timer("TB_calc_diag/calc_EFV/calculate_forces") + end if + if (present(virial)) then + call system_timer("TB_calc_diag/calc_EFV/calculate_virial") + virial = calculate_virial_diag(this) + virial_scf = scf_virial_correction(this%tbsys, this%at) + virial = virial + virial_scf + call system_timer("TB_calc_diag/calc_EFV/calculate_virial") + end if + endif + + call system_timer("TB_calc_diag/calc_EFV") + call system_timer("TB_calc_diag") + call print("TB_calc_diag ending", PRINT_VERBOSE) + +end function TB_calc_diag + + +function TB_calc_GF(this, use_fermi_E, fermi_E, fermi_T, band_width, local_e, local_N, forces, AF, SelfEnergy) + type(TB_type), intent(inout) :: this + logical, intent(in), optional :: use_fermi_E + real(dp), intent(inout), optional :: fermi_E + real(dp), intent(in), optional :: fermi_T, band_width + real(dp), intent(out), target, optional :: local_e(:) + real(dp), intent(out), pointer, optional :: local_N(:) + real(dp), intent(out), optional :: forces(:,:) + type(ApproxFermi), intent(inout), optional, target :: AF + type(TBMatrix), intent(in), optional :: SelfEnergy(:) + real(dp) :: TB_calc_GF + + logical find_new_fermi_E + type(ApproxFermi), pointer :: u_AF + logical local_u_AF + real(dp), allocatable :: forces_scf(:,:) + + integer i + + real(dp), pointer :: u_local_e(:) + real(dp), allocatable :: local_e_rep(:), local_e_scf(:) + real(dp) :: global_e_scf + + real(dp), pointer :: w_e(:) + real(dp), pointer :: w_n(:) + real(dp) :: use_band_width + + logical :: do_local_e, do_local_N + + call system_timer("TB_calc_GF") + call print("TB_calc_GF starting", PRINT_VERBOSE) + + do_local_N = .false. + if (present(local_N)) then + if (associated(local_N)) then + if (size(local_N) == this%at%N) then + do_local_N = .true. + else + if (size(local_N) /= 0) & + call system_abort("TB_calc_diag called with size(local_N)="//size(local_N)// & + " not 0, and not matching this%at%N="//this%at%N) + endif + endif + endif + do_local_e = .false. + if (present(local_e)) then + if (size(local_e) == this%at%N) then + do_local_e = .true. + else + if (size(local_e) /= 0) & + call system_abort("TB_calc_diag called with size(local_e)="//size(local_e)// & + " not 0, and not matching this%at%N="//this%at%N) + endif + endif + + call system_timer("TB_calc_GF_prep") + if (.not. assign_pointer(this%at, "weight", w_e)) then + nullify(w_e) + else + call print("Using weights from atom properties for w_e", PRINT_VERBOSE) + endif + if (.not. assign_pointer(this%at, "weight", w_n)) then + nullify(w_n) + else + call print("Using weights from atom properties for w_n", PRINT_VERBOSE) + endif + + find_new_fermi_E = .false. + if (present(use_fermi_E)) find_new_fermi_E = .not. use_fermi_E + + if (find_new_fermi_E .and. present(forces)) then + call system_abort("TB_calc_GF an't do constant N with forces yet") + endif + + if (.not. find_new_fermi_E .and. (.not. has_fermi_E(this%fermi_e, this%tbsys%tbmodel, fermi_E, this%calc_args_str) .and. & + .not. present(AF))) then + call system_abort("called calc_GF with use_fermi_E but no fermi_E or AF") + endif + + if ((present(fermi_E) .or. present(fermi_T) .or. present(band_width)) .and. present(AF)) then + call system_abort("calc_GF has AF as well as fermi_e, fermi_T, or band_width present - don't know which one to use") + endif + + if (present(AF)) then + u_AF => AF + local_u_AF = .false. + else + allocate(u_AF) + local_u_AF = .true. + endif + + if (find_new_fermi_E) then + call print("TB_calc_GF: finding our own Fermi level", PRINT_VERBOSE) + + if (.not. has_fermi_T(this%fermi_T, this%tbsys%tbmodel, fermi_T, this%calc_args_str)) & + call system_abort("TB_calc_GF called without Fermi_T for TB Model without default Fermi_T") + + if (.not. has_band_width(u_AF%band_width, this%tbsys%tbmodel, band_width, this%calc_args_str)) & + call system_abort("TB_calc_GF called without band_width for TB Model without default band_width") + + !call verbosity_push_increment() + call solve_diag(this, .false., fermi_E = fermi_E, w_n = w_n, AF = u_AF) + !call verbosity_pop() + else + if (has_fermi_E(this%fermi_e, this%tbsys%tbmodel, fermi_E, this%calc_args_str) .and. & + has_fermi_T(this%fermi_T, this%tbsys%tbmodel, fermi_T, this%calc_args_str) .and. & + has_band_width(use_band_width, this%tbsys%tbmodel, band_width, this%calc_args_str)) then + call print("Initialising ApproxFermi using fermi_e " // this%fermi_e // " fermi_T " // this%fermi_T // & + " band_width "// use_band_width, PRINT_VERBOSE) + call Initialise(u_AF, this%Fermi_E, this%fermi_T, use_band_width) + else + call system_abort("find_new_fermi_E is false, but we are missing fermi_e, fermi_T or band_width for Initialise(AF...)") + endif + endif + + call print("TB_calc_diag has Fermi_E " // this%Fermi_E // " Fermi_T " // this%Fermi_T, PRINT_VERBOSE) + + call verbosity_push_decrement() + call print("TB_calc_GF using ApproxFermi:") + call print(u_AF) + call verbosity_pop() + + call Initialise(this%gf, u_AF%z, u_AF%a, this%tbsys) + this%gf%tbsys%scf = this%tbsys%scf + + if (local_u_AF) then + call finalise(u_AF) + endif + call system_timer("TB_calc_GF_prep") + + call system_timer("TB_calc_GF_calc_Gs") + call print("TB_calc_GF calculating Gs", PRINT_VERBOSE) + call calc_Gs(this%gf, this%at, SelfEnergy) + call system_timer("TB_calc_GF_calc_Gs") + + call system_timer("TB_calc_GF_calc_EFV") + call print("TB_calc_GF calculating dm from Gs", PRINT_VERBOSE) + call calc_dm_from_Gs(this%gf) + + call print("TB_calc_GF calculating energy, number", PRINT_VERBOSE) + + if (do_local_e) then + u_local_e => local_e + else + allocate(u_local_e(this%at%N)) + endif + + allocate(local_e_rep(this%at%N)) + allocate(local_e_scf(this%at%N)) + do i=1, this%at%N + local_e_rep(i) = get_local_rep_E(this%tbsys%tbmodel, this%at, i) + end do + + call calc_local_atomic_energy_GF(this, u_local_e) + call local_scf_e_correction(this%tbsys, this%at, local_e_scf, global_e_scf, w_n) + u_local_e = u_local_e + local_e_scf + local_e_rep + + if (associated(w_e)) then + u_local_e = u_local_e + global_e_scf/sum(w_e) + TB_calc_GF = sum(u_local_e*w_e) + else + u_local_e = u_local_e + global_e_scf/size(u_local_e) + TB_calc_GF = sum(u_local_e) + endif + + if (.not. present(local_e)) deallocate(u_local_e) + deallocate(local_e_rep) + deallocate(local_e_scf) + + if (do_local_N) call calc_local_atomic_num_GF(this, local_N) + + if (present(forces)) then + call print("TB_calc_GF calculating forces", PRINT_VERBOSE) + forces = calculate_forces_GF(this, w_e, w_n) + allocate(forces_scf(3,this%at%N)) + forces_scf = scf_f_correction(this%gf%tbsys, this%at) + forces = forces + forces_scf + deallocate(forces_scf) + endif + call system_timer("TB_calc_GF_calc_EFV") + call system_timer("TB_calc_GF") + + call print("TB_calc_GF finished", PRINT_VERBOSE) + +end function TB_calc_GF + +subroutine calc_local_atomic_energy_GF(this, local_e) + type(TB_type), intent(inout) :: this + real(dp), intent(inout) :: local_e(:) + + local_e = local_ksum(this%gf%tbsys%kpoints, atom_orbital_sum(this%gf%tbsys, & + real(partial_TraceMult(this%gf%dm, this%gf%tbsys%H, & + a_H=.true., b_H=.false.)))) + call ksum_distrib_inplace(this%gf%tbsys%kpoints, local_e) +end subroutine calc_local_atomic_energy_GF + +subroutine calc_local_atomic_num_GF(this, local_N) + type(TB_type), intent(inout) :: this + real(dp), intent(inout) :: local_N(:) + + local_N = local_ksum(this%gf%tbsys%kpoints, atom_orbital_sum(this%gf%tbsys, & + real(partial_TraceMult(this%gf%dm, this%gf%tbsys%S, & + a_H=.true., b_H=.false.)))) + call ksum_distrib_inplace(this%gf%tbsys%kpoints, local_N) +end subroutine calc_local_atomic_num_GF + +subroutine calc_local_atomic_energy(this, local_e) + type(TB_type), intent(inout) :: this + real(dp), intent(inout) :: local_e(:) + + local_e = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, & + real(partial_TraceMult(this%dm, this%tbsys%H, & + a_H=.true., b_H=.false.)))) + call ksum_distrib_inplace(this%tbsys%kpoints, local_e) +end subroutine calc_local_atomic_energy + +subroutine calc_local_atomic_num(this, local_N) + type(TB_type), intent(inout) :: this + real(dp), intent(inout) :: local_N(:) + + if (this%tbsys%tbmodel%is_orthogonal) then + local_N = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, Re_diag(this%dm))) + else + local_N = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, & + real(partial_TraceMult(this%dm, this%tbsys%S, & + a_H=.true., b_H=.false.)))) + endif + call ksum_distrib_inplace(this%tbsys%kpoints, local_N) +end subroutine calc_local_atomic_num + +subroutine calc_local_orbital_num(this, local_N) + type(TB_type), intent(inout) :: this + real(dp), intent(inout) :: local_N(:) + + if (this%tbsys%tbmodel%is_orthogonal) then + local_N = local_ksum(this%tbsys%kpoints, Re_diag(this%dm)) + else + local_N = local_ksum(this%tbsys%kpoints, real(partial_TraceMult(this%dm, this%tbsys%S, a_H=.true., b_H=.false.))) + endif + call ksum_distrib_inplace(this%tbsys%kpoints, local_N) +end subroutine calc_local_orbital_num + +subroutine calc_local_orbital_mom(this, local_m) + type(TB_type), intent(inout) :: this + real(dp), intent(inout) :: local_m(:,:) + + integer :: i + complex(dp), allocatable :: local_spinor(:,:,:) + + local_m = 0.0_dp + + if (.not. this%tbsys%noncollinear) then + return + endif + + call fill_matrices(this%tbsys, this%at, need_H=.false., need_S=.true., no_S_spin=.true.) + + allocate(local_spinor(2,2,this%tbsys%N/2)) + + if (this%tbsys%tbmodel%is_orthogonal) then + local_spinor = local_ksum(this%tbsys%kpoints, diag_spinor(this%dm)) + else + local_spinor = local_ksum(this%tbsys%kpoints, partial_TraceMult_spinor(this%dm, this%tbsys%S, a_H=.true., b_H=.false.)) + endif + + do i=1, this%tbsys%N/2 + local_m(1,(i-1)*2+1) = sum(conjg(pauli_sigma(:,:,1))*local_spinor(:,:,i)) + local_m(2,(i-1)*2+1) = sum(conjg(pauli_sigma(:,:,2))*local_spinor(:,:,i)) + local_m(3,(i-1)*2+1) = sum(conjg(pauli_sigma(:,:,3))*local_spinor(:,:,i)) + end do + call ksum_distrib_inplace(this%tbsys%kpoints, local_m) + + deallocate(local_spinor) + + call fill_matrices(this%tbsys, this%at, need_H=.false., need_S=.true., no_S_spin=.false.) + +end subroutine calc_local_orbital_mom + + +function calculate_forces_diag(this, dH, dS, index) result(forces) + type(TB_type), intent(inout) :: this + real(dp) :: forces(3,this%at%N) ! result + real(dp), optional, intent(inout), dimension(:,:,:,:) :: dH + real(dp), optional, intent(inout), dimension(:,:,:,:) :: dS + integer, optional, intent(in) :: index + + logical, allocatable :: od_mask(:), d_mask(:) + + integer i + + if (this%at%cutoff < this%tbsys%tbmodel%cutoff) & + call print ("WARNING: Called calculate_forces_diag with messed up cutoff in atoms: cutoff" // & + this%at%cutoff // " < " // this%tbsys%tbmodel%cutoff) + + forces = 0.0_dp + allocate(od_mask(this%at%N)) + allocate(d_mask(this%at%N)) + + call Setup_deriv_matrices(this%tbsys, this%at) + do i=1, this%at%N + call fill_dmatrices(this%tbsys, this%at, i, diag_mask=d_mask, offdiag_mask=od_mask) + if (current_verbosity() >= PRINT_NERD) then + call print("force dH x "//i) + call print(this%tbsys%dH(1)) + call print("force dH y "//i) + call print(this%tbsys%dH(2)) + call print("force dH z "//i) + call print(this%tbsys%dH(3)) + call print("force dS x "//i) + call print(this%tbsys%dS(1)) + call print("force dS y "//i) + call print(this%tbsys%dS(2)) + call print("force dS z "//i) + call print(this%tbsys%dS(3)) + endif + if (present(dH)) then + call copy(this%tbsys%dH(1), dH(1,i,:,:), index=index) + call copy(this%tbsys%dH(2), dH(2,i,:,:), index=index) + call copy(this%tbsys%dH(3), dH(3,i,:,:), index=index) + endif + if (present(dS)) then + call copy(this%tbsys%dS(1), dS(1,i,:,:), index=index) + call copy(this%tbsys%dS(2), dS(2,i,:,:), index=index) + call copy(this%tbsys%dS(3), dS(3,i,:,:), index=index) + endif + + forces(1,i) = forces(1,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(1), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + forces(2,i) = forces(2,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(2), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + forces(3,i) = forces(3,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(3), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + if (.not. this%tbsys%tbmodel%is_orthogonal) then + forces(1,i) = forces(1,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(1), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + forces(2,i) = forces(2,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(2), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + forces(3,i) = forces(3,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(3), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + endif + end do + + deallocate(od_mask) + deallocate(d_mask) + + call ksum_distrib_inplace(this%tbsys%kpoints, forces) + + do i=1, this%at%N + forces = forces + get_local_rep_E_force(this%tbsys%tbmodel, this%at, i) + end do + +end function calculate_forces_diag + +function calculate_virial_diag(this) result(virial) + type(TB_type), intent(inout) :: this + real(dp) :: virial(3,3) ! result + + logical, allocatable :: od_mask(:), d_mask(:) + + integer i + + if (this%at%cutoff < this%tbsys%tbmodel%cutoff) & + call print ("WARNING: Called calculate_virial_diag with messed up cutoff in atoms: cutoff" // & + this%at%cutoff // " < " // this%tbsys%tbmodel%cutoff) + + virial = 0.0_dp + allocate(od_mask(this%at%N)) + allocate(d_mask(this%at%N)) + + call Setup_deriv_matrices(this%tbsys, this%at) + do i=1, 3 + call fill_dmatrices(this%tbsys, this%at, -i, diag_mask=d_mask, offdiag_mask=od_mask) + + virial(1,i) = virial(1,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(1), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + virial(2,i) = virial(2,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(2), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + virial(3,i) = virial(3,i) - local_ksum(this%tbsys%kpoints, real(TraceMult(this%dm,this%tbsys%dH(3), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + if (.not. this%tbsys%tbmodel%is_orthogonal) then + virial(1,i) = virial(1,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(1), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + virial(2,i) = virial(2,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(2), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + virial(3,i) = virial(3,i) + local_ksum(this%tbsys%kpoints, real(TraceMult(this%Hdm,this%tbsys%dS(3), & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + endif + end do + + call ksum_distrib_inplace(this%tbsys%kpoints, virial) + do i=1, this%at%N + virial = virial + get_local_rep_E_virial(this%tbsys%tbmodel, this%at, i) + end do + + deallocate(od_mask) + deallocate(d_mask) + +end function calculate_virial_diag + +function calculate_forces_GF(this, w_e, w_n) result (forces) + type(TB_type), intent(inout) :: this + real(dp), intent(in), pointer :: w_e(:), w_n(:) + real(dp) :: forces(3,this%at%N) ! result + + logical, allocatable :: od_mask(:), d_mask(:) + + integer i + + call system_timer("calculate_forces_GF") + + if (this%at%cutoff < this%gf%tbsys%tbmodel%cutoff) & + call print("WARNING: Called calculate_forces_GF with messed up cutoff in atoms: cutoff" // & + this%at%cutoff // " < " // this%gf%tbsys%tbmodel%cutoff) + + call system_timer("calculate_forces_GF_calc_mod_dm") + call calc_mod_dm_from_Gs(this%gf, w_e, w_n) + call system_timer("calculate_forces_GF_calc_mod_dm") + + call system_timer("calculate_forces_GF_Tr") + forces = 0.0_dp + allocate(od_mask(this%at%N)) + allocate(d_mask(this%at%N)) + + call Setup_deriv_matrices(this%gf%tbsys, this%at) + do i=1, this%at%N + call fill_dmatrices(this%gf%tbsys, this%at, i, diag_mask=d_mask, offdiag_mask=od_mask) + + forces(1,i) = forces(1,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_H, this%gf%tbsys%dH(1), & + a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) + forces(2,i) = forces(2,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_H, this%gf%tbsys%dH(2), & + a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) + forces(3,i) = forces(3,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_H, this%gf%tbsys%dH(3), & + a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) + if (.not. this%gf%tbsys%tbmodel%is_orthogonal) then + forces(1,i) = forces(1,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_S, this%gf%tbsys%dS(1), & + a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) + forces(2,i) = forces(2,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_S, this%gf%tbsys%dS(2), & + a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) + forces(3,i) = forces(3,i) - local_ksum(this%gf%tbsys%kpoints, real(TraceMult(this%gf%mod_dm_S, this%gf%tbsys%dS(3), & + a_H=.false., b_H=.true., diag_mask=d_mask, offdiag_mask=od_mask))) + endif + end do + + deallocate(od_mask) + deallocate(d_mask) + + call system_timer("calculate_forces_GF_Tr") + + call system_timer("calculate_forces_GF_accum") + call ksum_distrib_inplace(this%gf%tbsys%kpoints, forces) + + call system_timer("calculate_forces_GF_scf") + forces = forces + scf_f_correction_GF(this%gf, this%at, w_e, w_n) + call system_timer("calculate_forces_GF_scf") + + do i=1, this%at%N + if (associated(w_e)) then + forces = forces + w_e(i) * get_local_rep_E_force(this%gf%tbsys%tbmodel, this%at, i) + else + forces = forces + get_local_rep_E_force(this%gf%tbsys%tbmodel, this%at, i) + endif + end do + call system_timer("calculate_forces_GF_accum") + call system_timer("calculate_forces_GF") + +end function calculate_forces_GF + +function scf_f_correction_GF(gf, at, w_e, w_n) result(forces) + type(GreensFunctions), intent(inout) :: gf + type(Atoms), intent(in) :: at + real(dp), intent(in), pointer :: w_e(:), w_n(:) + real(dp) :: forces(3,gf%tbsys%N_atoms) + + real(dp), allocatable :: n(:), dn_dr_mat(:,:,:), dgN_dr_vec(:,:) + real(dp), allocatable :: dlpot(:) + real(dp) :: dglobal_pot + real(dp), allocatable :: ww_e(:) + integer N_atoms + + type(TBMatrix) :: sp_Stwid, sp_S + logical, allocatable :: d_mask(:), od_mask(:) + + integer i, j + + if (at%cutoff < gf%tbsys%tbmodel%cutoff) & + call print ("WARNING: Called scf_f_correction_GF with messed up cutoff in atoms: cutoff" // & + at%cutoff // " < " // gf%tbsys%tbmodel%cutoff) + + N_atoms = gf%tbsys%N_atoms + + allocate(d_mask(N_atoms)) + allocate(od_mask(N_atoms)) + + forces = 0.0_dp + if (.not. gf%tbsys%scf%active) then + return + endif + + if (size(gf%tbsys%scf%terms) /= 1) then + call system_abort("GreensFunc_scf_f_correction_GF not yet implemented for more than 1 type of SCF defined") + endif + + if (gf%tbsys%scf%terms(1)%type == SCF_LCN .or. gf%tbsys%scf%terms(1)%type == SCF_GCN) then + call system_abort("GreensFunc_scf_f_correction_GF not yet implemented for local or global charge neutrality") + endif + + allocate(dlpot(gf%tbsys%N)) + + call Initialise(sp_Stwid, at, gf%tbsys%first_orb_of_atom, gf%tbsys%n_matrices, gf%tbsys%complex_matrices) + call Initialise(sp_S, at, gf%tbsys%first_orb_of_atom, gf%tbsys%n_matrices, gf%tbsys%complex_matrices) + + call fill_these_matrices(gf%tbsys, at, do_S = .true., S = sp_S) + + allocate(n(gf%tbsys%N)) + n = local_ksum(gf%tbsys%kpoints, real(partial_TraceMult(gf%dm, gf%tbsys%S, a_H=.true., b_H=.false.))) + call ksum_distrib_inplace(gf%tbsys%kpoints, n) + + if (gf%tbsys%scf%terms(1)%type == SCF_LOCAL_U .or. & + gf%tbsys%scf%terms(1)%type == SCF_NONLOCAL_U_DFTB .or. & + gf%tbsys%scf%terms(1)%type == SCF_NONLOCAL_U_NRL_TB) then + + allocate(dn_dr_mat(3,N_atoms,gf%tbsys%N)) + call ALLOC_TRACE("scf_f_correction_GF dn_dr_mat", size(dn_dr_mat)*REAL_SIZE) + + ! calculate derivative of dn w.r.t r + call calc_dn_dr_mat(gf, at, dn_dr_mat) + + ! calculate correction to forces using dn_dr_mat + + ! correct forces by derivative of shift of Hamiltonian + do i=1, N_atoms + call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) + do j=1, 3 + call add_term_d2SCFE_dn2_times_vec(gf%tbsys%scf%terms(1), gf%tbsys, dn_dr_mat(j,i,:), dlpot) + + call multDiagRL(sp_Stwid, sp_S, dlpot) + forces(j,i) = forces(j,i) + local_ksum(gf%tbsys%kpoints, real(TraceMult(gf%mod_dm_H, sp_Stwid, a_H=.false., b_H=.true.))) + + ! Tr [ mod_dm 0.5 (lpot dS lpot) ] was necessary in SIMPLE (C+) version, since dH_ij/dr didn't + ! include 0.5 ( lpot(i) + lpot(j) dS_ij/dr. Here it does include it, so this + ! isn't necessary + + end do ! j=1, 3 + end do ! i=1, N_atoms + call ksum_distrib_inplace(gf%tbsys%kpoints, forces) + + call add_term_dscf_e_correction_dn(gf%tbsys%scf%terms(1), gf%tbsys, dlpot) + + allocate(ww_e(gf%tbsys%N)) + if (associated(w_e)) then + ww_e = atom_orbital_spread(gf%tbsys, w_e) + else + ww_e = 1.0_dp + endif + + ! correct forces by derivative of double counting terms + do i=1, N_atoms + do j=1, 3 + forces(j,i) = forces(j,i) - sum(ww_e(:)*dlpot(:)*dn_dr_mat(j,i,:)) + end do + end do + + call ALLOC_TRACE("scf_f_correction_GF dn_dr_mat", size(dn_dr_mat)*REAL_SIZE) + deallocate(dn_dr_mat) + + else ! global U + + allocate(dgN_dr_vec(3,N_atoms)) + + if (.not. associated(w_n)) & + call system_abort("called scf_f_correction_GF with GLOBAL_U but no global_at_weight") + + call calc_dgN_dr_vec(gf, at, dgN_dr_vec, w_n, sp_S, sp_Stwid) + + do i=1, at%N + call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) + do j=1, 3 + call add_term_d2SCFE_dgNdn(gf%tbsys%scf%terms(1), gf%tbsys, w_n, dlpot) + dlpot = dlpot*dgN_dr_vec(j,i) + + call multDiagRL(sp_Stwid, sp_S, dlpot) + forces(j,i) = forces(j,i) + local_ksum(gf%tbsys%kpoints, real(TraceMult(gf%mod_dm_H, sp_Stwid, a_H=.false., b_H=.true.))) + + ! Tr [ mod_dm 0.5 (lpot dS lpot) ] was necessary in SIMPLE (C+) version, since dH_ij/dr didn't + ! include 0.5 ( lpot(i) + lpot(j) dS_ij/dr. Here we do, so this + ! isn't necessary + + end do ! j=1, 3 + end do ! i=1, N_atoms + call ksum_distrib_inplace(gf%tbsys%kpoints, forces) + + call add_term_dscf_e_correction_dgN(gf%tbsys%scf%terms(1), dglobal_pot) + + ! correct forces by derivative of double counting terms + forces(:,:) = forces(:,:) - dglobal_pot*dgN_dr_vec(:,:) + + deallocate(dgN_dr_vec) + + endif ! local or global u + + call finalise(sp_Stwid) + call finalise(sp_S) + + deallocate(d_mask) + deallocate(od_mask) + +end function scf_f_correction_GF + +subroutine calc_dn_dr_mat(gf, at, dn_dr_mat) + type(GreensFunctions), intent(inout) :: gf + type(Atoms), intent(in) :: at + real(dp), intent(out) :: dn_dr_mat(:,:,:) + + type(TBMatrix) :: M2_raw + type(MatrixD) :: M2, M2inv + integer N_atoms, N_eff + + real(dp), allocatable :: dn0_dr_mat(:,:,:), t_dn0_dr_mat(:,:,:) + real(dp), allocatable :: dn0_dr(:) + type(TBMatrix) :: GS, G_dAdr, GU, GSU, SGS_T, GS_T + complex(dp) :: a, az + + real(dp), allocatable :: U_spread(:), gamma_spread(:,:) + integer ip, i, j, ii + logical, allocatable :: d_mask(:), od_mask(:) + + if (at%cutoff < gf%tbsys%tbmodel%cutoff) & + call print ("WARNING: Called calc_dn_dr_mat with messed up cutoff in atoms: cutoff" // & + at%cutoff // " < " // gf%tbsys%tbmodel%cutoff) + + N_eff = gf%tbsys%N + + allocate(d_mask(N_atoms)) + allocate(od_mask(N_atoms)) + + if (allocated(gf%tbsys%scf%terms(1)%gamma)) then + allocate(gamma_spread(gf%tbsys%N,gf%tbsys%N)) + call atom_orbital_spread_mat(gf%tbsys, gf%tbsys%scf%terms(1)%gamma, gamma_spread) + endif + if (allocated(gf%tbsys%scf%terms(1)%U)) then + allocate(U_spread(gf%tbsys%N)) + U_spread = atom_orbital_spread(gf%tbsys, gf%tbsys%scf%terms(1)%U) + endif + + allocate(dn0_dr_mat(3,N_atoms,N_eff)) + dn0_dr_mat = 0.0_dp + + call Initialise(M2_raw, gf%tbsys%S%N, gf%tbsys%S%n_matrices, .false.) + call Initialise(M2, N_eff) + call Initialise(M2inv, N_eff) + call zero(M2_raw) + + do ip=1, gf%N_G + if (ip == 1) then + allocate(t_dn0_dr_mat(3,N_atoms,N_eff)) + call ALLOC_TRACE("calc_dn_dr_mat t_dn0_dr_mat",size(t_dn0_dr_mat)*REAL_SIZE) + call Initialise(GS, gf%G(1)) + call Initialise(GS_T, gf%G(1)) + call Initialise(G_dAdr, gf%G(1)) + call Initialise(SGS_T, gf%G(1)) + call Initialise(GU, gf%G(1)) + call Initialise(GSU, gf%G(1)) + allocate(dn0_dr(N_eff)) + endif + + t_dn0_dr_mat = 0.0_dp + + if (.not. gf%tbsys%complex_matrices) then ! factor of 2.0, instead of doing G(z) and G(conjg(z)) separately + a = 2.0_dp * gf%a(ip) + az = 2.0_dp * gf%a(ip)*gf%z(ip) + else + a = gf%a(ip) + az = gf%a(ip)*gf%z(ip) + endif + + call matrix_product_sub(GS, gf%G(ip), gf%tbsys%S) + + do i=1, at%N + ! this version of fill_dmatrices returns scf-local-potential-shifted + ! dH (i.e. dH(i,j) + 0.5(lpot(i)+lpot(j))dS(i,j) + ! SIMPLE (C+) version didn't give shifted dH, and that contribution to dn/dr + ! was accounted for in "M1". This version doesn't need that + + call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) + do j=1, 3 + ! Tr [ rho dS/dr WI ] + if (.not. gf%tbsys%tbmodel%is_orthogonal) then + if (ip == 1 .and. gf%mpi_across_poles%my_proc == 0) then + dn0_dr = local_ksum(gf%tbsys%kpoints, & + real(partial_TraceMult(gf%dm, gf%tbsys%dS(j), a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + call ksum_distrib_inplace(gf%tbsys%kpoints, dn0_dr) + do ii=1, N_eff + !NB sign determined empirically :( + t_dn0_dr_mat(j,i,ii) = -dn0_dr(ii) + end do + end if + end if + + dn0_dr = 0.0_dp + + ! Tr [ drho0/dr S WI ] = Tr [ sum_i ( a_i z_i G_i dS/dr G_i - a_i G_i dH0/dr G_i ) S WI = + ! Tr [ sum_i a_i z_i G_i dS/dr G_i S WI - sum_i a_i G_i dH0/dr G_i S WI + if (.not. gf%tbsys%tbmodel%is_orthogonal) then + call matrix_product_sub(G_dAdr, gf%G(ip), gf%tbsys%dS(j), diag_mask=d_mask, offdiag_mask=od_mask) + + dn0_dr = dn0_dr + real(az*local_ksum(gf%tbsys%kpoints, partial_TraceMult(G_dAdr, GS))) + endif + + call matrix_product_sub(G_dAdr, gf%G(ip), gf%tbsys%dH(j), diag_mask=d_mask, offdiag_mask=od_mask) + + dn0_dr = dn0_dr - real(a*local_ksum(gf%tbsys%kpoints, partial_TraceMult(G_dAdr, GS))) + + call ksum_distrib_inplace(gf%tbsys%kpoints, dn0_dr) + + ! factor of 2 folded into a and az (or explicit evaluation of G(conjg(z))) + t_dn0_dr_mat(j,i,:) = t_dn0_dr_mat(j,i,:) - dn0_dr(:) + + end do ! j + end do ! i + + call transpose_sub(GS_T, GS) + + ! (SGS)^T = (S GS)^T = (GS)^T S^T + call matrix_product_sub(SGS_T, GS_T, gf%tbsys%S, A_transpose = .false., B_transpose = .true.) + + if (allocated(gamma_spread)) then + call matrix_product_sub(GU, gf%G(ip), gamma_spread) + else + call multDiag(GU, gf%G(ip), U_spread) + endif + + if (allocated(gamma_spread)) then + call matrix_product_sub(GSU, GS, gamma_spread) + else + call multDiag(GSU, GS, U_spread) + endif + + ! factor of 0.5 to compensate for factor of 2 in a (or explicit eval of G(conjg(z)) + ! OMP critical + call accum_scaled_elem_product(GU, SGS_T, 0.5_dp*a, M2_raw) + call accum_scaled_elem_product(GSU, GS_T, 0.5_dp*a, M2_raw) + + ! OMP critical + dn0_dr_mat = dn0_dr_mat + t_dn0_dr_mat + + if (gf%tbsys%complex_matrices) then + + t_dn0_dr_mat = 0.0_dp + + a = conjg(gf%a(ip)) + az = conjg(gf%a(ip)*gf%z(ip)) + + call matrix_product_sub(GS, gf%G_conjg(ip), gf%tbsys%S) + + do i=1, at%N + ! this version of fill_dmatrices returns scf-local-potential-shifted + ! dH (i.e. dH(i,j) + 0.5(lpot(i)+lpot(j))dS(i,j) + ! SIMPLE (C+) version didn't give shifted dH, and that contribution to dn/dr + ! was accounted for in "M1". This version doesn't need that + + call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) + do j=1, 3 + + dn0_dr = 0.0_dp + + ! Tr [ drho0/dr S WI ] = Tr [ sum_i ( a_i z_i G_i dS/dr G_i - a_i G_i dH0/dr G_i ) S WI = + ! Tr [ sum_i a_i z_i G_i dS/dr G_i S WI - sum_i a_i G_i dH0/dr G_i S WI + if (.not. gf%tbsys%tbmodel%is_orthogonal) then + call matrix_product_sub(G_dAdr, gf%G_conjg(ip), gf%tbsys%dS(j), diag_mask=d_mask, offdiag_mask=od_mask) + + dn0_dr = dn0_dr + real(az*local_ksum(gf%tbsys%kpoints, partial_TraceMult(G_dAdr, GS))) + endif + + call matrix_product_sub(G_dAdr, gf%G_conjg(ip), gf%tbsys%dH(j), diag_mask=d_mask, offdiag_mask=od_mask) + + dn0_dr = dn0_dr - real(a*local_ksum(gf%tbsys%kpoints, partial_TraceMult(G_dAdr, GS))) + call ksum_distrib_inplace(gf%tbsys%kpoints, dn0_dr) + + ! factor of 2 folded into a and az (or explicit evaluation of G(conjg(z))) + t_dn0_dr_mat(j,i,:) = t_dn0_dr_mat(j,i,:) - dn0_dr(:) + + end do ! j + end do ! i + + call transpose_sub(GS_T, GS) + + ! (SGS)^T = S^T (GS)^T + call matrix_product_sub(SGS_T, GS_T, gf%tbsys%S, A_transpose = .false., B_transpose = .true.) + + if (allocated(gamma_spread)) then + call matrix_product_sub(GU, gf%G_conjg(ip), gamma_spread) + else + call multDiag(GU, gf%G_conjg(ip), U_spread) + endif + + if (allocated(gamma_spread)) then + call matrix_product_sub(GSU, GS, gamma_spread) + else + call multDiag(GSU, GS, U_spread) + endif + + ! factor of 0.5 to compensate for factor of 2 in a (or explicit eval of G(conjg(z)) + ! OMP critical + call accum_scaled_elem_product(GU, SGS_T, 0.5_dp*a, M2_raw) + call accum_scaled_elem_product(GSU, GS_T, 0.5_dp*a, M2_raw) + + ! OMP critical + dn0_dr_mat = dn0_dr_mat + t_dn0_dr_mat + + endif ! non-gamma + end do ! ip = 1..N_G + + call ksum_atom_orbital_sum_mat(gf%tbsys, M2_raw, M2) + + call Gsum_distrib_inplace(gf, dn0_dr_mat) + call Gsum_distrib_inplace(gf, M2) + + ! dn[I]/dr = dn0[I]/dr + sum_M M2[I][M] dn[M]/dr + ! x = v0 + M.x + ! x - M.x = v0 + ! (I-M) . x = v0 + ! x = (I-M)^-1 . v0 + + !NB sign determined empirically + !NB call scale(M2, -1.0_dp) + call add_identity(M2) + call inverse(M2, M2inv, .false.) + + do i=1, at%N + do j=1, 3 + dn_dr_mat(j,i,:) = M2inv%data .mult. dn0_dr_mat(j,i,:) + end do + end do + + call finalise(M2_raw) + call finalise(M2) + call finalise(M2inv) + + call Finalise(GS) + call Finalise(GS_T) + call Finalise(G_dAdr) + call Finalise(SGS_T) + call Finalise(GU) + call Finalise(GSU) + + call DEALLOC_TRACE("calc_dn_dr_mat gamma_spread", size(gamma_spread)*REAL_SIZE) + deallocate(gamma_spread) + call DEALLOC_TRACE("calc_dn_dr_mat U_spread", size(U_spread)*REAL_SIZE) + deallocate(U_spread) + call DEALLOC_TRACE("calc_dn_dr_mat dn0_dr_mat", size(dn0_dr_mat)*REAL_SIZE) + deallocate(dn0_dr_mat) + call DEALLOC_TRACE("calc_dn_dr_mat t_dn_dr_mat", size(t_dn0_dr_mat)*REAL_SIZE) + deallocate(t_dn0_dr_mat) + call DEALLOC_TRACE("calc_dn_dr_mat dn0_dr", size(dn0_dr)*REAL_SIZE) + deallocate(dn0_dr) + + deallocate(d_mask) + deallocate(od_mask) + +end subroutine calc_dn_dr_mat + +subroutine calc_dgN_dr_vec(gf, at, dgN_dr_vec, w_n, sp_S, sp_Stwid) + type(GreensFunctions), intent(inout) :: gf + type(Atoms), intent(in) :: at + real(dp), intent(out) :: dgN_dr_vec(:,:) + real(dp), intent(in) :: w_n(:) + type(TBMatrix), intent(in) :: sp_S + type(TBmatrix), intent(inout) :: sp_Stwid + + real(dp), allocatable :: ww_n(:) + real(dp) dgN_dr_denom + complex(dp) :: a, az + + logical, allocatable :: d_mask(:), od_mask(:) + + integer ip, i, j + + type(TBMatrix) :: GWN, SG, aGWNSG, azGWNSG, GWNSG + + if (at%cutoff < gf%tbsys%tbmodel%cutoff) & + call print ("WARNING: Called calc_dgN_dr_vec with messed up cutoff in atoms: uniform" // & + at%cutoff // " < " // gf%tbsys%tbmodel%cutoff) + + allocate(ww_n(gf%tbsys%N)) + ww_n = atom_orbital_spread(gf%tbsys, w_n) + + allocate(d_mask(at%N)) + allocate(od_mask(at%N)) + + call multDiagRL(sp_Stwid, sp_S, gf%tbsys%scf%global_U*ww_n) + + do ip=1, gf%N_G + if (ip == 1) then + call Initialise(SG, gf%G(1)) + call Initialise(GWN, gf%G(1)) + call Initialise(aGWNSG, gf%G(1)) + call Initialise(azGWNSG, gf%G(1)) + call Initialise(GWNSG, gf%G(1)) + call zero(aGWNSG) + call zero(azGWNSG) + endif + + + if (.not. gf%tbsys%complex_matrices) then ! factor of 2.0, instead of doing G(z) and G(conjg(z)) separately + a = 2.0_dp*gf%a(ip) + az = 2.0_dp*gf%a(ip)*gf%z(ip) + else + a = gf%a(ip) + az = gf%a(ip)*gf%z(ip) + endif + + call multDiag(GWN, gf%G(ip), ww_n) + call matrix_product_sub(SG, gf%tbsys%S, gf%G(ip)) + call matrix_product_sub(GWNSG, GWN, SG) + + ! omp critical + call scaled_accum(aGWNSG, a, GWNSG) + call scaled_accum(azGWNSG, az, GWNSG) + + if (gf%tbsys%complex_matrices) then + a = conjg(gf%a(ip)) + az = conjg(gf%a(ip)*gf%z(ip)) + + call multDiag(GWN, gf%G_conjg(ip), ww_n) + call matrix_product_sub(SG, gf%tbsys%S, gf%G_conjg(ip)) + call matrix_product_sub(GWNSG, GWN, SG) + + ! omp critical + call scaled_accum(aGWNSG, a, GWNSG) + call scaled_accum(azGWNSG, az, GWNSG) + + endif + end do + + call Finalise(SG) + call Finalise(GWN) + call Finalise(GWNSG) + + call Gsum_distrib_inplace(gf, aGWNSG) + call Gsum_distrib_inplace(gf, azGWNSG) + + !NB sign set empirically + ! factor of 2 shifted into aGWNSG + dgN_dr_denom = 1.0_dp + ksum_distrib(gf%tbsys%kpoints, real(local_ksum(gf%tbsys%kpoints, TraceMult(sp_Stwid, aGWNSG, & + a_H=.true., b_H=.false.)))) + + dgN_dr_vec = 0.0_dp + + do i=1, at%N + call fill_dmatrices(gf%tbsys, at, i, diag_mask=d_mask, offdiag_mask=od_mask) + do j=1, 3 + if (.not. gf%tbsys%tbmodel%is_orthogonal) then + ! Tr [ dS/dr rho wN ] + ! NB sign set empirically + dgN_dr_vec(j,i) = dgN_dr_vec(j,i) - sum(ww_n * & + local_ksum(gf%tbsys%kpoints, real(partial_TraceMult(gf%tbsys%dS(j), gf%dm, & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask)))) + ! factor of 2 shifted into aGWNSG and azGWNSG + dgN_dr_vec(j,i) = dgN_dr_vec(j,i) - local_ksum(gf%tbsys%kpoints, real(TraceMult(gf%tbsys%dS(j), azGWNSG, & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + end if + dgN_dr_vec(j,i) = dgN_dr_vec(j,i) + & + local_ksum(gf%tbsys%kpoints, real(TraceMult(gf%tbsys%dH(j), aGWNSG, & + a_H=.true., b_H=.false., diag_mask=d_mask, offdiag_mask=od_mask))) + + ! NB SIMPLE (C+) implementation needs to add something because its dH_ij/dr doesn't + ! include the 0.5 (lpot(i) + lpot(j) dS_ij/dr part + end do + end do + + call ksum_distrib_inplace(gf%tbsys%kpoints, dgN_dr_vec) + + dgN_dr_vec = dgN_dr_vec / dgN_dr_denom + + call Finalise(aGWNSG) + call Finalise(azGWNSG) + + deallocate(d_mask) + deallocate(od_mask) + +end subroutine calc_dgN_dr_vec + + +subroutine calc_dm_from_evecs(this, for_forces) + type(TB_type), intent(inout) :: this + logical, intent(in), optional :: for_forces + + logical do_forces + + do_forces = .false. + if (present(for_forces)) do_forces = for_forces + + call realloc_match_tbsys(this%tbsys, this%dm) + call realloc_match_tbsys(this%tbsys, this%scaled_evecs) + call Zero(this%dm) + if (do_forces .and. .not. this%tbsys%tbmodel%is_orthogonal) then + call realloc_match_tbsys(this%tbsys, this%Hdm) + call Zero(this%Hdm) + endif + + if (do_forces) then + call multDiag(this%scaled_evecs, this%evecs, this%F_fillings) + call matrix_product_sub(this%dm, this%scaled_evecs, this%evecs, b_conjugate = .true.) + if (.not. this%tbsys%tbmodel%is_orthogonal) then + call multDiag(this%scaled_evecs, this%evecs, this%eval_F_fillings) + call matrix_product_sub(this%Hdm, this%scaled_evecs, this%evecs, b_conjugate = .true.) + endif + else + call multDiag(this%scaled_evecs, this%evecs, this%E_fillings) + call matrix_product_sub(this%dm, this%scaled_evecs, this%evecs, b_conjugate = .true.) + endif + +end subroutine calc_dm_from_evecs + +subroutine TB_calc_E_fillings(this, use_fermi_E, fermi_E, AF, w_n) + type(TB_type), intent(inout) :: this + logical, intent(in), optional :: use_fermi_E + real(dp), intent(in), optional :: fermi_E + type(ApproxFermi), intent(inout), optional :: AF + real(dp), intent(in), pointer :: w_n(:) + + logical find_new_fermi_E + real(dp) :: degeneracy + + if (present(use_fermi_E) .and. .not. present(AF)) then + if (.not. has_fermi_E(this%fermi_E, this%tbsys%tbmodel, fermi_E, this%calc_args_str)) & + call system_abort("called calc_E_fillings with use_fermi_E, but no Fermi_E or AF") + endif + + find_new_fermi_E = .true. + if (present(use_fermi_E)) find_new_fermi_E = .not. use_fermi_E + + if (present(AF)) call print("calc_E_fillings using approx fermi function", PRINT_VERBOSE) + + if (find_new_fermi_E) then + call print("calc_E_fillings finding new fermi level", PRINT_VERBOSE) + else + call print("calc_E_fillings using current fermi level", PRINT_VERBOSE) + endif + + call realloc_match_tbsys(this%tbsys, this%E_fillings) + + if (find_new_fermi_E) then + ! not so useful for Fermi E to be set based on w_n. + ! mostly w_n applies to SCF_GCN and SCF_LOBAL_U. + ! can be restored if necessary, but should probably have a different + ! name for the property than weight_n + call find_fermi_E(this, AF) + call print ("TB_calc_E_fillings got new Fermi_E " // this%Fermi_E, PRINT_VERBOSE) + else + if (present(fermi_E)) then + this%fermi_E = fermi_E + endif + if (this%tbsys%noncollinear) then + degeneracy = 1.0_dp + else + degeneracy = 2.0_dp + endif + if (present(AF)) then + call calc_fermi_factors(this%E_fillings, this%evals, AF = AF, degeneracy=degeneracy) + else + call calc_fermi_factors(this%E_fillings, this%evals, fermi_E = this%fermi_E, fermi_T = this%fermi_T, degeneracy=degeneracy) + endif + endif + +end subroutine TB_calc_E_fillings + +subroutine TB_calc_F_fillings(this, need_eval_F_fillings, AF) + type(TB_type), intent(inout) :: this + logical, intent(in), optional :: need_eval_F_fillings + type(ApproxFermi), intent(inout), optional :: AF + + call realloc_match_tbsys(this%tbsys, this%F_fillings) + + if (present(AF)) then + call calc_mod_fermi_factors(this, this%E_fillings, this%F_fillings, AF = AF) + else + call calc_mod_fermi_factors(this, this%E_fillings, this%F_fillings, fermi_E = this%fermi_E, fermi_T = this%fermi_T) + endif + + if (present(need_eval_F_fillings)) then + if (need_eval_F_fillings) then + call realloc_match_tbsys(this%tbsys, this%eval_F_fillings) + this%eval_F_fillings%data_d = this%F_fillings%data_d*this%evals%data_d + endif + endif + +end subroutine TB_calc_F_fillings + +subroutine TB_find_fermi_E(this, AF, w_n) + type(TB_type), intent(inout) :: this + type(ApproxFermi), intent(inout), optional :: AF + real(dp), intent(in), pointer, optional :: w_n(:) + + integer iter + integer, parameter :: max_iter = 200 + real(dp) :: e_min, e_max, e_try + real(dp) :: N_try + logical :: have_w_n + + real(dp), allocatable :: local_N(:) + real(dp) :: N_e + real(dp) :: EPS + real(dp) :: degeneracy + + call print("called find_fermi_E fermi_T " // this%fermi_T // " " // (this%fermi_T < 1e-8_dp), PRINT_ANALYSIS) + + have_w_n = .false. + if (present(w_n)) then + if (associated(w_n)) have_w_n = .true. + endif + + N_e = n_elec(this%tbsys, this%at, w_n) + + if (present(AF)) then + if (AF%n_poles == 0 .or. (AF%band_width .feq. 0.0_dp)) then + call system_abort("called find_fermi_E with AF present but n_poles of band_width == 0") + endif + endif + + if (this%fermi_T < 1e-8_dp) then + call system_abort ("find_fermi_E can't handle fermi_T < 1e-8") + else + e_min = min(this%tbsys%kpoints, this%evals%data_d(1,:)) - 10.0_dp + e_max = max(this%tbsys%kpoints, this%evals%data_d(this%evals%N,:)) + 10.0_dp + + call Print("find_Fermi_E N_e " // N_e // " e_min " // e_min // " e_max " // e_max, PRINT_ANALYSIS) + + if (have_w_n) allocate(local_N(this%tbsys%N_atoms)) + + iter = 0 + N_try = N_e + 1 + do while (abs(N_try-N_e) > this%fermi_E_precision) + e_try = (e_min + e_max) / 2.0_dp + if (this%tbsys%noncollinear) then + degeneracy = 1.0_dp + else + degeneracy = 2.0_dp + endif + if (present(AF)) then + AF%z = AF%z - AF%fermi_E + e_try + AF%fermi_E = e_try + call calc_fermi_factors(this%E_fillings, this%evals, AF = AF, degeneracy=degeneracy) + else + call calc_fermi_factors(this%E_fillings, this%evals, fermi_E = e_try, fermi_T = this%fermi_T, degeneracy=degeneracy) + endif + if (have_w_n) then + ! could be done more efficiency, by precomputing for each state the + ! occupation on each atom + call calc_dm_from_evecs(this, .false.) + call calc_local_atomic_num(this, local_N) + N_try = sum(w_n*local_N) + else + N_try = ksum_dup(this%tbsys%kpoints, sum(this%E_fillings%data_d,dim=1)) + endif + call Print("find_Fermi_E e_try n_try " // (iter+1) // " " // e_try // " " // n_try, PRINT_ANALYSIS) + if (N_try < N_e) then + e_min = e_try + else + e_max = e_try + endif + iter = iter + 1 + if (iter .gt. max_iter) then + call print("N_e " // N_e // " N_try " // N_try, PRINT_ALWAYS) + call print("e_min " // e_min // " e_max " // e_max // " e_try " // e_try, PRINT_ALWAYS) + call print("this%evals", PRINT_ALWAYS) + call verbosity_push(PRINT_NORMAL) + call print(this%evals) + call verbosity_pop() + call system_abort("Ran out of iterations in find_fermi_E") + endif + if ((abs(N_try-N_e) > this%fermi_E_precision) .and. (e_min == e_max)) then + call print("N_e " // N_e // " N_try " // N_try, PRINT_ALWAYS) + call print("e_min " // e_min // " e_max " // e_max // " e_try " // e_try, PRINT_ALWAYS) + call print("this%evals", PRINT_ALWAYS) + call verbosity_push(PRINT_NORMAL) + call print(this%evals) + call verbosity_pop() + call system_abort("Ran out of precision in find_fermi_E") + endif + end do + + this%fermi_E = e_try + endif + + EPS=1e-4_dp + this%homo_e = maxval(this%evals%data_d, this%evals%data_d <= this%fermi_E+EPS) + this%lumo_e = minval(this%evals%data_d, this%evals%data_d >= this%fermi_E-EPS) + this%homo_e = max(this%tbsys%kpoints, this%homo_e) + this%lumo_e = min(this%tbsys%kpoints, this%lumo_e) + + if (allocated(local_N)) deallocate(local_N) + +end subroutine TB_find_fermi_E + +subroutine calc_fermi_factors(fermi_factors, evals, fermi_E, fermi_T, AF, degeneracy) + type(TBVector), intent(inout) :: fermi_factors + type(TBVector), intent(in) :: evals + real(dp), intent(in), optional :: fermi_E, fermi_T + type(ApproxFermi), intent(in), optional :: AF + real(dp), intent(in), optional :: degeneracy + + real(dp) :: u_degeneracy + + u_degeneracy = optional_default(2.0_dp, degeneracy) + + if (present(AF)) then + fermi_factors%data_d(:,:) = u_degeneracy*approx_f_fermi(AF, evals%data_d(:,:)) + else if (present(Fermi_E) .and. present(Fermi_T)) then + fermi_factors%data_d(:,:) = u_degeneracy*f_fermi(fermi_E, fermi_T, evals%data_d(:,:)) + else + call system_abort("Called calc_fermi_factors without sufficient inputs for exact or approx fermi function") + endif +end subroutine calc_fermi_factors + +subroutine calc_fermi_derivs(fermi_factors, evals, fermi_E, fermi_T, AF, degeneracy) + type(TBVector), intent(inout) :: fermi_factors + type(TBVector), intent(in) :: evals + real(dp), intent(in), optional :: fermi_E, fermi_T + type(ApproxFermi), intent(in), optional :: AF + real(dp), intent(in), optional :: degeneracy + + real(dp) :: u_degeneracy + + u_degeneracy = optional_default(2.0_dp, degeneracy) + + if (present(AF) .and. (present(fermi_E) .or. present(fermi_T))) then + call system_abort("Called calc_fermi_factors with both ApproxFermi and Fermi_E or Fermi_T") + endif + + if (present(AF)) then + fermi_factors%data_d(:,:) = u_degeneracy*approx_f_fermi_deriv(AF, evals%data_d(:,:)) + else if (present(Fermi_E) .and. present(Fermi_T)) then + fermi_factors%data_d(:,:) = u_degeneracy*f_fermi_deriv(fermi_E, fermi_T, evals%data_d(:,:)) + else + call system_abort("Called calc_fermi_factors without sufficient inputs for exact or approx fermi function") + endif + +end subroutine calc_fermi_derivs + +subroutine calc_mod_fermi_factors(this, fermi_factors, mod_fermi_factors, fermi_E, fermi_T, AF) + type(TB_type), intent(inout) :: this + type(TBVector), intent(in) :: fermi_factors + type(TBVector), intent(inout) :: mod_fermi_factors + real(dp), intent(in), optional :: Fermi_E, Fermi_T + type(ApproxFermi), intent(in), optional :: AF + + real(dp) numerator, denominator, theta + type(TBVector) :: fermi_derivs + real(dp) :: degeneracy + + if (present(AF) .and. (present(fermi_E) .or. present(fermi_T))) then + call system_abort("Called calc_mod_fermi_factors with both ApproxFermi and Fermi_E or Fermi_T") + endif + + call Initialise(fermi_derivs, fermi_factors%N, fermi_factors%n_vectors) + + if (this%tbsys%noncollinear) then + degeneracy = 1.0_dp + else + degeneracy = 2.0_dp + endif + + call calc_fermi_derivs(fermi_derivs, this%evals, fermi_E, fermi_T, AF, degeneracy) + + denominator = ksum_dup(this%tbsys%kpoints, sum(fermi_derivs%data_d,dim=1)) + + if (denominator .feq. 0.0_dp) then + mod_fermi_factors%data_d = fermi_factors%data_d + else + numerator = ksum_dup(this%tbsys%kpoints, sum(this%evals%data_d*fermi_derivs%data_d,dim=1)) + theta = numerator/denominator + +! constant mu + ! mod_fermi_factors%data_d = fermi_factors%data_d + & + ! fermi_derivs%data_d*(this%evals%data_d) + +! constant N + mod_fermi_factors%data_d = fermi_factors%data_d + & + fermi_derivs%data_d*(this%evals%data_d-theta) + + endif + + call Finalise(fermi_derivs) +end subroutine calc_mod_fermi_factors + +function TB_evals(this) + type(TB_type) :: this + real(dp) :: TB_evals(this%tbsys%N,this%tbsys%kpoints%g_N) + + if(allocated(this%evals%data_d)) then + call collect(this%tbsys%kpoints, this%evals%data_d, TB_evals) + else + call system_abort("TB_evals() call with unallocated evals%data_d array") + end if + +end function TB_evals + +! calculation optical absorption with formula from +! Snyder and Rotkin, Small v. 4, p. 1284-1286 +subroutine absorption(this, polarization, freqs, gamma, a) + type(TB_type), intent(inout) :: this + complex(dp), intent(in) :: polarization(3) + real(dp), intent(in) :: freqs(:), gamma + real(dp), intent(out) :: a(:) + + complex(dp) :: polarization_hat(3) + type(TBMatrix) :: dipole_evecs(3) + integer :: i, f, ik, i_freq + real(dp), allocatable :: absorption_contrib(:) + + if (this%evecs%N == 0 .or. this%evecs%n_matrices == 0) & + call system_abort("Absorption needs eigenvectors to be already calculated") + + call dipole_matrix(this, dipole_evecs) + + call verbosity_push_decrement() + call print("dipole_evecs(1)") + call print(dipole_evecs(1)) + call print("dipole_evecs(2)") + call print(dipole_evecs(2)) + call print("dipole_evecs(3)") + call print(dipole_evecs(3)) + call verbosity_pop() + + polarization_hat = polarization / sqrt(sum(abs(polarization)**2)) + + allocate(absorption_contrib(this%evecs%n_matrices)) + + do i_freq=1, size(freqs) + absorption_contrib = 0.0_dp + do ik=1, this%evecs%n_matrices + do i=1, this%evecs%N + do f=i+1, this%evecs%N + if ((this%E_fillings%data_d(i,ik) .fne. 0.0_dp) .and. (this%E_fillings%data_d(f,ik) .fne. 1.0_dp)) then + if (dipole_evecs(1)%is_complex) then + absorption_contrib(ik) = absorption_contrib(ik) + & + ( (abs(dipole_evecs(1)%data_z(ik)%data(i,f)*polarization_hat(1) + & + dipole_evecs(2)%data_z(ik)%data(i,f)*polarization_hat(2) + & + dipole_evecs(3)%data_z(ik)%data(i,f)*polarization_hat(3))**2)/(freqs(i_freq)) ) * & + ( (this%E_fillings%data_d(i,ik)/2.0_dp*(1.0_dp-this%E_fillings%data_d(f,ik)/2.0_dp)) / & + ((this%evals%data_d(f,ik)-this%evals%data_d(i,ik)-freqs(i_freq))**2 + gamma**2) ) + else + absorption_contrib(ik) = absorption_contrib(ik) + & + ( (abs(dipole_evecs(1)%data_d(ik)%data(i,f)*polarization_hat(1) + & + dipole_evecs(2)%data_d(ik)%data(i,f)*polarization_hat(2) + & + dipole_evecs(3)%data_d(ik)%data(i,f)*polarization_hat(3))**2)/(freqs(i_freq)) ) * & + ( (this%E_fillings%data_d(i,ik)/2.0_dp*(1.0_dp-this%E_fillings%data_d(f,ik)/2.0_dp)) / & + ((this%evals%data_d(f,ik)-this%evals%data_d(i,ik)-freqs(i_freq))**2 + gamma**2) ) + endif + endif + end do ! f + end do ! i + end do ! ik + + a(i_freq) = ksum_distrib(this%tbsys%kpoints, local_ksum(this%tbsys%kpoints, absorption_contrib)) + end do + + deallocate(absorption_contrib) + + call finalise(dipole_evecs(1)) + call finalise(dipole_evecs(2)) + call finalise(dipole_evecs(3)) + +end subroutine absorption + +subroutine dipole_matrix(this, dipole_evecs) + type(TB_type), intent(inout) :: this + type(TBMatrix), intent(inout) :: dipole_evecs(3) + + type(TBMatrix) :: dipole_basis(3), t + + integer :: i + + do i=1, 3 + call realloc_match_tbsys(this%tbsys, dipole_basis(i)) + call realloc_match_tbsys(this%tbsys, dipole_evecs(i)) + end do + call realloc_match_tbsys(this%tbsys, t) + + call fill_these_matrices(this%tbsys, this%at, do_dipole=.true., dipole=dipole_basis) + + call verbosity_push_decrement(PRINT_NERD) + call print("dipole_basis(1)") + call print(dipole_basis(1)) + call print("dipole_basis(2)") + call print(dipole_basis(2)) + call print("dipole_basis(3)") + call print(dipole_basis(3)) + call verbosity_pop() + + do i=1,3 + call matrix_product_sub(t, dipole_basis(i), this%evecs, a_conjugate=.false., b_conjugate = .false.) + call matrix_product_sub(dipole_evecs(i), this%evecs, t, a_conjugate=.true., b_conjugate = .false.) + end do + + do i=1, 3 + call finalise(dipole_basis(i)) + end do + call finalise(t) + +end subroutine dipole_matrix + +end module TB_module diff --git a/src/Potentials/TBMatrix.F90 b/src/Potentials/TBMatrix.F90 new file mode 100644 index 0000000000..6c8b88a5ca --- /dev/null +++ b/src/Potentials/TBMatrix.F90 @@ -0,0 +1,1310 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X IP module +!X +!% Contain objects for handling TB matrices (\texttt{type TBMatrix}) and vectors +!% (\texttt{type TBVector}). +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module TBMatrix_module + +use error_module +use system_module, only : dp, current_verbosity, inoutput, PRINT_NORMAL, operator(//), optional_default +use mpi_context_module +use linearalgebra_module +use atoms_module + +use ScaLAPACK_module +use Matrix_module +use RS_SparseMatrix_module +use TBModel_module + +implicit none +private + +public :: TBVector +type TBVector + integer :: N = 0 + integer :: n_vectors = 0 + logical :: is_complex = .false. !% Logical variable to define if vector elements are complex + + real(dp), allocatable :: data_d(:,:) + complex(dp), allocatable :: data_z(:,:) +end type TBVector + +public :: TBMatrix +type TBMatrix + integer :: N = 0 + integer :: n_matrices = 0 + logical :: is_complex = .false. !% Logical variable to define if matrix elements are complex + logical :: is_sparse = .false. !% Logical variable to define if such matrix is sparse + + type(MatrixD), allocatable :: data_d(:) + type(MatrixZ), allocatable :: data_z(:) + type(RS_SparseMatrixD), allocatable :: sdata_d(:) + type(RS_SparseMatrixZ), allocatable :: sdata_z(:) +end type TBMatrix + +public :: Initialise +interface Initialise + module procedure TBMatrix_Initialise, TBMatrix_Initialise_tbm, TBVector_Initialise + module procedure TBMatrix_Initialise_sp +end interface Initialise + +public :: Finalise +interface Finalise + module procedure TBMatrix_Finalise, TBVector_Finalise +end interface Finalise + +public :: Wipe +interface Wipe + module procedure TBMatrix_Wipe, TBVector_Wipe +end interface Wipe + +public :: Zero +interface Zero + module procedure TBMatrix_Zero, TBVector_Zero +end interface Zero + +public :: Print +interface Print + module procedure TBMatrix_Print, TBVector_Print +end interface Print + +public :: copy +interface copy + module procedure TBMatrix_copy_d + module procedure TBMatrix_copy_z +end interface copy + +public :: add_block +interface add_block + module procedure TBMatrix_add_block_d, TBMatrix_add_block_z +end interface add_block + +public :: diagonalise +interface diagonalise + module procedure TBMatrix_diagonalise, TBmatrix_diagonalise_gen +end interface diagonalise + +public :: multDiag +interface multDiag + module procedure TBMatrix_multDiag, TBMatrix_multDiag_d, TBMatrix_multDiag_z +end interface multDiag + +public :: multDiagRL +interface multDiagRL + module procedure TBMatrix_multDiagRL_d +end interface multDiagRL + +public :: matrix_product_sub +interface matrix_product_sub + module procedure TBMatrix_matrix_product_sub, TBMatrix_matrix_product_sub_r2 +end interface matrix_product_sub + +public operator(.DOT.) +interface operator(.DOT.) + module procedure TBVector_dotproduct +end interface + +public :: partial_TraceMult +interface partial_TraceMult + module procedure TBMatrix_partial_TraceMult +end interface partial_TraceMult + +public :: partial_TraceMult_spinor +interface partial_TraceMult_spinor + module procedure TBMatrix_partial_TraceMult_spinor +end interface partial_TraceMult_spinor + +public :: TraceMult +interface TraceMult + module procedure TBMatrix_TraceMult +end interface TraceMult + +public :: Re_diag +interface Re_diag + module procedure TBMatrix_Re_diag +end interface Re_diag + +public :: diag_spinor +interface diag_spinor + module procedure TBMatrix_diag_spinor +end interface diag_spinor + +public :: scaled_sum +interface scaled_sum + module procedure TBMatrix_scaled_sum +end interface scaled_sum + +public :: scaled_accum +interface scaled_accum + module procedure TBMatrix_scaled_accum +end interface scaled_accum + +public :: inverse +interface inverse + module procedure TBMatrix_inverse +end interface inverse + +public :: sum_in_place +interface sum_in_place + module procedure TBMatrix_sum_in_place +end interface sum_in_place + +public :: accum_scaled_elem_product +interface accum_scaled_elem_product + module procedure TBMatrix_accum_scaled_elem_product +end interface accum_scaled_elem_product + +public :: sum_matrices +interface sum_matrices + module procedure TBMatrix_sum_matrices_d +end interface sum_matrices + +public :: transpose_sub +interface transpose_sub + module procedure TBMatrix_transpose_sub +end interface transpose_sub + + +public :: make_hermitian +interface make_hermitian + module procedure TBMatrix_make_hermitian +end interface make_hermitian + +contains + +subroutine TBMatrix_sum_in_place(this, mpi) + type(TBMatrix), intent(inout) :: this + type(MPI_context) :: mpi + + integer i + + do i=1, this%n_matrices + if (this%is_complex) then + if (this%is_sparse) then + call sum_in_place(mpi, this%sdata_z(i)%data) + else + call sum_in_place(mpi, this%data_z(i)%data) + endif + else + if (this%is_sparse) then + call sum_in_place(mpi, this%sdata_d(i)%data) + else + call sum_in_place(mpi, this%data_d(i)%data) + endif + endif + end do + +end subroutine TBMatrix_sum_in_place + +subroutine TBMatrix_Initialise(this, N, n_matrices, is_complex, scalapack_obj) + type(TBMatrix), intent(inout) :: this + integer, intent(in) :: N + integer, intent(in), optional :: n_matrices + logical, intent(in), optional :: is_complex + type(ScaLAPACK), intent(in), optional :: scalapack_obj + + integer i + + call Finalise(this) + + this%N = N + if (present(n_matrices)) then + this%n_matrices = n_matrices + else + this%n_matrices = 1 + endif + if (present(is_complex)) then + this%is_complex = is_complex + endif + + if (this%is_complex) then + allocate(this%data_z(this%n_matrices)) + do i=1, this%n_matrices + call Initialise(this%data_z(i), this%N, scalapack_obj=scalapack_obj) + end do + else + allocate(this%data_d(this%n_matrices)) + do i=1, this%n_matrices + call Initialise(this%data_d(i), this%N, scalapack_obj=scalapack_obj) + end do + endif + +end subroutine TBMatrix_Initialise + +subroutine TBMatrix_Initialise_tbm(this, from) + type(TBMatrix), intent(inout) :: this + type(TBMatrix), intent(in) :: from + + integer i + + call Finalise(this) + + this%N = from%N + this%n_matrices = from%n_matrices + this%is_complex = from%is_complex + + if (this%is_complex) then + if (this%n_matrices > 0) allocate(this%data_z(this%n_matrices)) + do i=1, this%n_matrices + call Initialise(this%data_z(i), from%data_z(i)) + end do + else + if (this%n_matrices > 0) allocate(this%data_d(this%n_matrices)) + do i=1, this%n_matrices + call Initialise(this%data_d(i), from%data_d(i)) + end do + endif + +end subroutine TBMatrix_Initialise_tbm + +subroutine TBMatrix_Initialise_sp(this, at, first_orb_of_atom, n_matrices, is_complex, mpi_obj) + type(TBMatrix), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: first_orb_of_atom(:) + integer, intent(in), optional :: n_matrices + logical, intent(in), optional :: is_complex + type(MPI_Context), intent(in), optional :: mpi_obj + + integer i + + call Finalise(this) + + this%is_sparse = .true. + + this%N = first_orb_of_atom(at%N+1)-1 + if (present(n_matrices)) then + this%n_matrices = n_matrices + else + this%n_matrices = 1 + endif + if (present(is_complex)) then + this%is_complex = is_complex + endif + + if (this%is_complex) then + if (this%n_matrices > 0) allocate(this%sdata_z(this%n_matrices)) + do i=1, this%n_matrices + call Initialise(this%sdata_z(i), at, first_orb_of_atom, mpi_obj=mpi_obj) + end do + else + if (this%n_matrices > 0) allocate(this%sdata_d(this%n_matrices)) + do i=1, this%n_matrices + call Initialise(this%sdata_d(i), at, first_orb_of_atom, mpi_obj=mpi_obj) + end do + endif + +end subroutine TBMatrix_Initialise_sp + +subroutine TBMatrix_Finalise(this) + type(TBMatrix), intent(inout) :: this + + call Wipe(this) + +end subroutine TBMatrix_Finalise + +subroutine TBMatrix_Zero(this, d_mask, od_mask) + type(TBMatrix), intent(inout) :: this + logical, intent(in), optional :: d_mask(:), od_mask(:) + + integer i + + if (allocated(this%data_d)) then + do i=1, size(this%data_d) + call Zero(this%data_d(i), d_mask, od_mask) + end do + end if + if (allocated(this%data_z)) then + do i=1, size(this%data_z) + call Zero(this%data_z(i), d_mask, od_mask) + end do + end if + if (allocated(this%sdata_d)) then + do i=1, size(this%sdata_d) + call Zero(this%sdata_d(i), d_mask, od_mask) + end do + end if + if (allocated(this%sdata_z)) then + do i=1, size(this%sdata_z) + call Zero(this%sdata_z(i), d_mask, od_mask) + end do + end if +end subroutine TBMatrix_Zero + +subroutine TBMatrix_Wipe(this) + type(TBMatrix), intent(inout) :: this + + integer :: i + + if (allocated(this%data_d)) then + do i=1, size(this%data_d) + call Finalise(this%data_d(i)) + end do + deallocate(this%data_d) + endif + if (allocated(this%data_z)) then + do i=1, size(this%data_z) + call Finalise(this%data_z(i)) + end do + deallocate(this%data_z) + end if + if (allocated(this%sdata_d)) then + do i=1, size(this%sdata_d) + call Finalise(this%sdata_d(i)) + end do + deallocate(this%sdata_d) + endif + if (allocated(this%sdata_z)) then + do i=1, size(this%sdata_z) + call Finalise(this%sdata_z(i)) + end do + deallocate(this%sdata_z) + endif + + this%N = 0 + this%n_matrices = 0 +end subroutine TBMatrix_Wipe + +subroutine TBMatrix_Print(this,file) + type(TBMatrix), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer::i + + if (current_verbosity() < PRINT_NORMAL) return + + call Print('TBMatrix : ', file=file) + + call Print ('TBMatrix : N n_matrices ' // this%N // " " // this%n_matrices, file=file) + call Print ('TBMatrix : is_complex ' // this%is_complex, file=file) + + if (allocated(this%data_d)) then + do i=1, size(this%data_d) + call Print ('TBMatrix : data_d ' // i, file=file) + call Print(this%data_d(i), file=file) + end do + endif + + if (allocated(this%data_z)) then + do i=1, size(this%data_z) + call Print ('TBMatrix : data_z ' // i, file=file) + call Print(this%data_z(i), file=file) + end do + endif + + if (allocated(this%sdata_d)) then + do i=1, size(this%sdata_d) + call Print ('TBMatrix : sdata_d ' // i, file=file) + call print_simple(this%sdata_d(i), file=file) + !call Print(this%sdata_d(i), file=file) + end do + endif + + if (allocated(this%sdata_z)) then + do i=1, size(this%sdata_z) + call Print ('TBMatrix : sdata_z ' // i, file=file) + !call print_simple(this%sdata_z(i), file=file) + call Print(this%sdata_z(i), file=file) + end do + endif + +end subroutine TBMatrix_Print + +subroutine TBMatrix_copy_d(this, data_d, index) + type(TBMatrix), intent(in) :: this + real(dp), intent(inout), dimension(:,:) :: data_d + integer, optional, intent(in) :: index + integer my_index + + my_index = optional_default(1, index) + + call Print('TBMatrix : ') + call Print ('TBMatrix : N n_matrices ' // this%N // " " // this%n_matrices) + call Print ('TBMatrix : is_complex ' // this%is_complex) + + if (allocated(this%data_d)) then + if (my_index > size(this%data_d)) call system_abort("index > size(data_d)") + data_d(:,:) = this%data_d(my_index)%data + else if (allocated(this%sdata_d)) then + if (my_index > size(this%sdata_d)) call system_abort("index > size(sdata_d)") + call copy(this%sdata_d(my_index), data_d) + endif +end subroutine TBmatrix_copy_d + +subroutine TBMatrix_copy_z(this, data_z, index) + type(TBMatrix), intent(in) :: this + complex(dp), intent(inout), dimension(:,:) :: data_z + integer, optional, intent(in) :: index + integer my_index + + my_index = optional_default(1, index) + + call Print('TBMatrix : ') + call Print ('TBMatrix : N n_matrices ' // this%N // " " // this%n_matrices) + call Print ('TBMatrix : is_complex ' // this%is_complex) + + if (allocated(this%data_z)) then + if (my_index > size(this%data_z)) call system_abort("index > size(data_z)") + if (any(shape(data_z) /= shape(this%data_z(my_index)%data))) call system_abort("data_z size mismatch") + data_z(:,:) = this%data_z(my_index)%data + else if (allocated(this%sdata_z)) then + call copy(this%sdata_z(my_index), data_z) + endif +end subroutine TBMatrix_copy_z + +subroutine TBVector_Initialise(this, N, n_vectors, is_complex) + type(TBVector), intent(inout) :: this + integer, intent(in) :: N + integer, intent(in), optional :: n_vectors + logical, intent(in), optional :: is_complex + + call Finalise(this) + + this%N = N + if (present(n_vectors)) then + this%n_vectors = n_vectors + else + this%n_vectors = 1 + endif + if (present(is_complex)) then + this%is_complex = is_complex + endif + + if (this%is_complex) then + allocate(this%data_z(this%N,this%n_vectors)) + else + allocate(this%data_d(this%N,this%n_vectors)) + endif + +end subroutine TBVector_Initialise + +subroutine TBVector_Finalise(this) + type(TBVector), intent(inout) :: this + + call Wipe(this) + +end subroutine TBVector_Finalise + +subroutine TBVector_Wipe(this) + type(TBVector), intent(inout) :: this + + if (allocated(this%data_d)) deallocate(this%data_d) + if (allocated(this%data_z)) deallocate(this%data_z) + + this%N = 0 + this%n_vectors = 0 +end subroutine TBVector_Wipe + +subroutine TBVector_Zero(this) + type(TBVector), intent(inout) :: this + + if (allocated(this%data_d)) this%data_d = 0.0_dp + if (allocated(this%data_z)) this%data_z = 0.0_dp + +end subroutine TBVector_Zero + +subroutine TBVector_Print(this,file) + type(TBVector), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer::i + + if (current_verbosity() < PRINT_NORMAL) return + + call Print('TBVector : ', file=file) + + call Print ('TBVector : N n_vectors ' // this%N // ' ' // this%n_vectors, file=file) + call Print ('TBVector : is_complex ' // this%is_complex, file=file) + + if (allocated(this%data_d)) then + do i=1, size(this%data_d,2) + call Print ('TBVector : data_d ' // i, file=file) + call Print(this%data_d(:,i), file=file) + end do + endif + + if (allocated(this%data_z)) then + do i=1, size(this%data_z,2) + call Print ('TBVector : data_z ' // i, file=file) + call Print(this%data_z(:,i), file=file) + end do + endif + +end subroutine TBVector_Print + +subroutine TBMatrix_add_block_d(this, im, block, block_nr, block_nc, first_row, first_col, at_row, at_col) + type(TBMatrix), intent(inout) :: this + integer, intent(in) :: im + real(dp), intent(in) :: block(:,:) + integer, intent(in) :: block_nr, block_nc + integer, intent(in) :: first_row, first_col + integer, intent(in), optional :: at_row, at_col + + + if (this%is_complex) then + if (this%is_sparse) then + call add_block(this%sdata_z(im), cmplx(block, 0.0_dp, dp), block_nr, block_nc, at_row, at_col) + else + call add_block(this%data_z(im), cmplx(block, 0.0_dp, dp), block_nr, block_nc, first_row, first_col) + endif + else + if (this%is_sparse) then + call add_block(this%sdata_d(im), block, block_nr, block_nc, at_row, at_col) + else + call add_block(this%data_d(im), block, block_nr, block_nc, first_row, first_col) + endif + endif + +end subroutine TBMatrix_add_block_d + +subroutine TBMatrix_add_block_z(this, im, block, block_nr, block_nc, first_row, first_col, at_row, at_col) + type(TBMatrix), intent(inout) :: this + integer, intent(in) :: im + complex(dp), intent(in) :: block(:,:) + integer, intent(in) :: block_nr, block_nc + integer, intent(in) :: first_row, first_col + integer, intent(in), optional :: at_row, at_col + + if (this%is_complex) then + if (this%is_sparse) then + call add_block(this%sdata_z(im), block, block_nr, block_nc, at_row, at_col) + else + call add_block(this%data_z(im), block, block_nr, block_nc, first_row, first_col) + endif + else + call system_abort ("tried to add complex block to real TBMatrix") + endif + +end subroutine TBMatrix_add_block_z + +subroutine TBMatrix_diagonalise_gen(this, overlap, evals, evecs, ignore_symmetry, error) + type(TBMatrix), intent(in) :: this + type(TBMatrix), intent(in) :: overlap + type(TBVector), intent(inout) :: evals + type(TBMatrix), intent(inout), optional :: evecs + logical, intent(in), optional :: ignore_symmetry + integer, intent(out), optional :: error + + integer i + + INIT_ERROR(error) + + if (this%is_sparse) then + RAISE_ERROR("can't diagonalize_gen sparse matrix", error) + endif + + if (this%is_complex) then + do i=1, this%n_matrices + if (present(evecs)) then + call diagonalise(this%data_z(i), overlap%data_z(i), evals%data_d(:,i), evecs%data_z(i), ignore_symmetry=ignore_symmetry, error = error) + else + call diagonalise(this%data_z(i), overlap%data_z(i), evals%data_d(:,i), ignore_symmetry=ignore_symmetry, error = error) + endif + end do + else + do i=1, this%n_matrices + if (present(evecs)) then + call diagonalise(this%data_d(i), overlap%data_d(i), evals%data_d(:,i), evecs%data_d(i), ignore_symmetry=ignore_symmetry, error = error) + else + call diagonalise(this%data_d(i), overlap%data_d(i), evals%data_d(:,i), ignore_symmetry=ignore_symmetry, error = error) + endif + end do + endif + PASS_ERROR(error) +end subroutine TBMatrix_diagonalise_gen + +subroutine TBMatrix_diagonalise(this, evals, evecs, ignore_symmetry, error) + type(TBMatrix), intent(in) :: this + type(TBVector), intent(inout) :: evals + type(TBMatrix), intent(inout), optional :: evecs + logical, intent(in), optional :: ignore_symmetry + integer, intent(out), optional :: error + + integer i + + INIT_ERROR(error) + + if (this%is_sparse) then + RAISE_ERROR("can't diagonalize sparse matrix", error) + endif + + if (this%is_complex) then + do i=1, this%n_matrices + if (present(evecs)) then + call diagonalise(this%data_z(i), evals%data_d(:,i), evecs%data_z(i), ignore_symmetry=ignore_symmetry, error = error) + else + call diagonalise(this%data_z(i), evals%data_d(:,i), ignore_symmetry=ignore_symmetry, error = error) + endif + end do + else + do i=1, this%n_matrices + if (present(evecs)) then + call diagonalise(this%data_d(i), evals%data_d(:,i), evecs%data_d(i), ignore_symmetry = ignore_symmetry, error = error) + else + call diagonalise(this%data_d(i), evals%data_d(:,i), ignore_symmetry = ignore_symmetry, error = error) + endif + end do + endif + PASS_ERROR(error) +end subroutine TBMatrix_diagonalise + +function TBVector_dotproduct(this, that) + type(TBVector), intent(in) :: this, that + real(dp) :: TBVector_dotproduct + + if (this%is_complex .or. that%is_complex) then + call system_abort ("TBVector_dotproduct can't handle complex vectors") + endif + + TBVector_dotproduct = this%data_d .dot. this%data_d +end function TBVector_dotproduct + +!subroutine accum_tbmatrix_col_outer_product(this, mati, i, TBV_f) +! type(TBMatrix), intent(inout) :: this +! type(TBMatrix), intent(in) :: mati +! integer, intent(in) :: i +! type(TBVector), intent(in) :: TBV_f +! +! integer ik +! +! if (mati%is_sparse) then +! call System_abort("can't accum_tbmatrix_col_outer_product of sparse matrix") +! endif +! +! do ik=1, mati%n_matrices +! if (TBV_f%data_d(i,ik) .fne. 0.0_dp) then +! if (mati%is_complex) then +! if (this%is_complex) then +! call accum_col_outer_product(this%data_z(ik), mati%data_z(ik), i, TBV_f%data_d(i,ik)) +! else +! call system_abort("tried to add outer product of columns of real TBMatrix to complex TBMatrix") +! endif +! else +! if (.not. this%is_complex) then +! call accum_col_outer_product(this%data_d(ik), mati%data_d(ik), i, TBV_f%data_d(i,ik)) +! else +! call system_abort("tried to add outer product of columns of complex TBMatrix to real TBMatrix") +! endif +! endif +! endif +! end do +!end subroutine + +function TBMatrix_TraceMult(a, b, w, a_H, b_H, diag_mask, offdiag_mask) + type(TBMatrix), intent(in) :: a, b + real(dp), intent(in), optional, target :: w(:) + logical, intent(in), optional :: a_H, b_H + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: TBMatrix_TraceMult(a%n_matrices) + + integer im + + do im=1, a%n_matrices + ! dense-sparse + if (.not. a%is_complex .and. .not. a%is_sparse .and. .not. b%is_complex .and. b%is_sparse) then + TBMatrix_TraceMult(im) = TraceMult(a%data_d(im), b%sdata_d(im), w, a_H, b_H, diag_mask, offdiag_mask) + else if (a%is_complex .and. .not. a%is_sparse .and. b%is_complex .and. b%is_sparse) then + TBMatrix_TraceMult(im) = TraceMult(a%data_z(im), b%sdata_z(im), w, a_H, b_H, diag_mask, offdiag_mask) + ! sparse-dense + else if (.not. a%is_complex .and. a%is_sparse .and. .not. b%is_complex .and. .not. b%is_sparse) then + TBMatrix_TraceMult(im) = TraceMult(a%sdata_d(im), b%data_d(im), w, a_H, b_H, diag_mask, offdiag_mask) + else if (.not. a%is_complex .and. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then + TBMatrix_TraceMult(im) = TraceMult(a%sdata_d(im), b%data_z(im), w, a_H, b_H, diag_mask, offdiag_mask) + else if (a%is_complex .and. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then + TBMatrix_TraceMult(im) = TraceMult(a%sdata_z(im), b%data_z(im), w, a_H, b_H, diag_mask, offdiag_mask) + else + call system_abort ("No TBMatrix_TraceMult implemented yet for " // & + " a%c " // a%is_complex // " a%s " // a%is_sparse // & + " b%c " // b%is_complex // " b%s " // b%is_sparse ) + endif + end do + +end function TBMatrix_TraceMult + +function TBMatrix_partial_TraceMult(a, b, a_H, b_H, diag_mask, offdiag_mask) + type(TBMatrix), intent(in) :: a, b + logical, intent(in), optional :: a_H, b_H + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: TBMatrix_partial_TraceMult(a%N, a%n_matrices) + + integer im + + do im=1, a%n_matrices + if (.not. a%is_complex .and. .not. a%is_sparse .and. .not. b%is_complex .and. .not. b%is_sparse) then + if (present(diag_mask) .or. present(offdiag_mask)) call system_abort("Can't do diag_mask for TraceMult of 2 dense matrices") + TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%data_d(im), b%data_d(im), a_H, b_H) + else if (.not. a%is_complex .and. .not. a%is_sparse .and. .not. b%is_complex .and. b%is_sparse) then + TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%data_d(im), b%sdata_d(im), a_H, b_H, diag_mask,offdiag_mask) + else if (.not. a%is_complex .and. a%is_sparse .and. .not. b%is_complex .and. .not. b%is_sparse) then + TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%sdata_d(im), b%data_d(im), a_H, b_H, diag_mask,offdiag_mask) + else if (a%is_complex .and. .not. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then + if (present(diag_mask) .or. present(offdiag_mask)) call system_abort("Can't do diag_mask for TraceMult of 2 dense matrices") + TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%data_z(im), b%data_z(im), a_H, b_H) + else if (a%is_complex .and. .not. a%is_sparse .and. b%is_complex .and. b%is_sparse) then + TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%data_z(im), b%sdata_z(im), a_H, b_H, diag_mask,offdiag_mask) + else if (a%is_complex .and. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then + TBMatrix_partial_TraceMult(:,im) = partial_TraceMult(a%sdata_z(im), b%data_z(im), a_H, b_H, diag_mask,offdiag_mask) + else + call system_abort ("No TBMatrix_partial_TraceMult implemented yet for " // & + " a%c " // a%is_complex // " a%s " // a%is_sparse // & + " b%c " // b%is_complex // " b%s " // b%is_sparse ) + endif + end do + +end function TBMatrix_partial_TraceMult + +function TBMatrix_partial_TraceMult_spinor(a, b, a_H, b_H, diag_mask, offdiag_mask) + type(TBMatrix), intent(in) :: a, b + logical, intent(in), optional :: a_H, b_H + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + complex(dp) :: TBMatrix_partial_TraceMult_spinor(2,2,a%N/2, a%n_matrices) + + integer im + + do im=1, a%n_matrices + if (a%is_complex .and. .not. a%is_sparse .and. b%is_complex .and. .not. b%is_sparse) then + if (present(diag_mask) .or. present(offdiag_mask)) call system_abort("Can't do diag_mask for TraceMult_spinor of 2 dense matrices") + TBMatrix_partial_TraceMult_spinor(:,:,:,im) = partial_TraceMult_spinor(a%data_z(im), b%data_z(im), a_H, b_H) + else + call system_abort ("No TBMatrix_partial_TraceMult_spinor implemented yet for " // & + " a%c " // a%is_complex // " a%s " // a%is_sparse // & + " b%c " // b%is_complex // " b%s " // b%is_sparse ) + endif + end do + +end function TBMatrix_partial_TraceMult_spinor + + +function TBMatrix_Re_diag(a) + type(TBMatrix), intent(in) :: a + real(dp) :: TBMatrix_Re_diag(a%N, a%n_matrices) + + integer im + + do im=1, a%n_matrices + if (a%is_complex) then + TBMatrix_Re_diag(:,im) = Re_diag(a%data_z(im)) + else + TBMatrix_Re_diag(:,im) = Re_diag(a%data_d(im)) + endif + end do + +end function TBMatrix_Re_diag + +function TBMatrix_diag_spinor(a) + type(TBMatrix), intent(in) :: a + complex(dp) :: TBMatrix_diag_spinor(2,2,a%N/2, a%n_matrices) + + integer im + + do im=1, a%n_matrices + if (a%is_complex) then + TBMatrix_diag_spinor(:,:,:,im) = diag_spinor(a%data_z(im)) + else + TBMatrix_diag_spinor(:,:,:,im) = diag_spinor(a%data_d(im)) + endif + end do + +end function TBMatrix_diag_spinor + +subroutine TBMatrix_scaled_sum(this, f1_z, m1, f2, m2) + type(TBMatrix), intent(inout) :: this + complex(dp), intent(in) :: f1_z + type(TBMatrix), intent(in) :: m1 + real(dp), intent(in) :: f2 + type(TBMatrix), intent(in) :: m2 + + complex(dp) f2_z + + integer im + + if (this%is_sparse) call system_abort("No TBMatrix_scaled_sum for sparse matrices") + + f2_z = f2 + + do im=1, this%n_matrices + if (this%is_complex) then + if (m1%is_complex) then + if (m2%is_complex) then + call scaled_sum(this%data_z(im), f1_z, m1%data_z(im), f2_z, m2%data_z(im)) + else + ! call scaled_sum(this%data_z(im), f1_z, m1%data_z(im), f2_z, m2%data_d(im)) + call system_abort ("Can't do scaled sum for Z Z D") + endif + else + if (m2%is_complex) then + ! call scaled_sum(this%data_z(im), f1_z, m1%data_d(im), f2_z, m2%data_z(im)) + call system_abort ("Can't do scaled sum for Z D Z") + else + call scaled_sum(this%data_z(im), f1_z, m1%data_d(im), f2_z, m2%data_d(im)) + endif + endif + else + if (m1%is_complex) then + if (m2%is_complex) then + ! call scaled_sum(this%data_d(im), f1_z, m1%data_z(im), f2_z, m2%data_z(im)) + call system_abort ("Can't do scaled sum for D Z Z") + else + ! call scaled_sum(this%data_d(im), f1_z, m1%data_z(im), f2_z, m2%data_d(im)) + call system_abort ("Can't do scaled sum for D Z D") + endif + else + if (m2%is_complex) then + ! call scaled_sum(this%data_d(im), f1_z, m1%data_d(im), f2_z, m2%data_z(im)) + call system_abort ("Can't do scaled sum for D D Z") + else + ! call scaled_sum(this%data_d(im), f1_z, m1%data_d(im), f2_z, m2%data_d(im)) + call system_abort ("Can't do scaled sum for D D D") + endif + endif + endif + end do + +end subroutine TBMatrix_scaled_sum + +subroutine TBMatrix_scaled_accum(this, f1_z, m1) + type(TBMatrix), intent(inout) :: this + complex(dp), intent(in) :: f1_z + type(TBMatrix), intent(in) :: m1 + + integer im + + if (this%is_sparse) call system_abort("No TBMatrix_accum for sparse matrices") + + do im=1, this%n_matrices + if (this%is_complex) then + if (m1%is_complex) then + call scaled_accum(this%data_z(im), f1_z, m1%data_z(im)) + else + ! call scaled_accum(this%data_z(im), f1_z, m1%data_d(im)) + call system_abort ("Can't do scaled accum for Z D") + endif + else + if (m1%is_complex) then + call scaled_accum(this%data_d(im), f1_z, m1%data_z(im)) + else + ! call scaled_accum(this%data_d(im), f1_z, m1%data_d(im)) + call system_abort ("Can't do scaled accum for D D") + endif + endif + end do + +end subroutine TBMatrix_scaled_accum + +subroutine TBMatrix_inverse(this, inv, positive) + type(TBMatrix), intent(inout) :: this + type(TBMatrix), intent(out), optional :: inv + logical, intent(in), optional :: positive + + integer im + + if (this%is_sparse) call system_abort("No TBMatrix_inverse for sparse matrices") + + do im=1, this%n_matrices + if (this%is_complex) then + if (present(inv)) then + if (.not. (inv%is_complex)) then + call system_abort("Called TBMatrix_inverse with complex matrix but real inverse") + endif + call inverse(this%data_z(im), inv%data_z(im), positive) + else + call inverse(this%data_z(im), positive=positive) + endif + else + if (present(inv)) then + if (inv%is_complex) then + call system_abort("Called TBMatrix_inverse with real matrix but complex inverse") + endif + call inverse(this%data_d(im), inv%data_d(im), positive) + else + call inverse(this%data_d(im), positive=positive) + endif + endif + end do +end subroutine TBMatrix_inverse + +subroutine TBMatrix_multDiag(this, A, diag) + type(TBMatrix), intent(inout) :: this + type(TBMatrix), intent(in) :: A + type(TBVector), intent(in) :: diag + + integer im + + if (this%N /= diag%N) then + call system_abort("Called TBMatrix_multDiag with mismatched sizes") + endif + + if (this%is_sparse) call system_abort("No TBMatrix_multDiag for sparse matrices") + if (A%is_sparse) call system_abort("No TBMatrix_multDiag for sparse matrices") + + if ((this%is_complex .and. .not. A%is_complex) .or. & + (.not. this%is_complex .and. A%is_complex)) call system_abort ("TBMatrix_multDiag with mismatched types") + + do im=1, this%n_matrices + if (this%is_complex) then + if (diag%is_complex) then + call multDiag(this%data_z(im), A%data_z(im), diag%data_z(:,im)) + else + call multDiag(this%data_z(im), A%data_z(im), diag%data_d(:,im)) + endif + else + if (diag%is_complex) then + call system_abort("Can't TBMatrix_multDiag of a real matrix time complex diag") + else + call multDiag(this%data_d(im), A%data_d(im), diag%data_d(:,im)) + endif + endif + end do +end subroutine TBMatrix_multDiag + +subroutine TBMatrix_multDiag_d(this, A, diag) + type(TBMatrix), intent(inout) :: this + type(TBMatrix), intent(in) :: A + real(dp), intent(in) :: diag(:) + + integer im + + if (this%N /= size(diag)) then + call system_abort("Called TBMatrix_multDiag_d with mismatched sizes") + endif + + if (this%is_sparse) call system_abort("No TBMatrix_multDiag_d for sparse matrices") + if (A%is_sparse) call system_abort("No TBMatrix_multDiag_d for sparse matrices") + + if ((this%is_complex .and. .not. A%is_complex) .or. & + (.not. this%is_complex .and. A%is_complex)) call system_abort ("TBMatrix_multDiag_d with mismatched types") + + do im=1, this%n_matrices + if (this%is_complex) then + call multDiag(this%data_z(im), A%data_z(im), diag) + else + call multDiag(this%data_d(im), A%data_d(im), diag) + endif + end do +end subroutine TBMatrix_multDiag_d + + +subroutine TBMatrix_multDiag_z(this, A, diag) + type(TBMatrix), intent(inout) :: this + type(TBMatrix), intent(in) :: A + complex(dp), intent(in) :: diag(:) + + integer im + + if (this%N /= size(diag)) then + call system_abort("Called TBMatrix_multDiag_z with mismatched sizes") + endif + + if (this%is_sparse) call system_abort("No TBMatrix_multDiag_z for sparse matrices") + if (A%is_sparse) call system_abort("No TBMatrix_multDiag_z for sparse matrices") + + if ((this%is_complex .and. .not. A%is_complex) .or. & + (.not. this%is_complex .and. A%is_complex)) call system_abort ("TBMatrix_multDiag_z with mismatched types") + + do im=1, this%n_matrices + if (this%is_complex) then + call multDiag(this%data_z(im), A%data_z(im), diag) + else + call system_abort ("TBMatrix_multDiag_z Can't multiply a real matrix by a complex diag") + endif + end do +end subroutine TBMatrix_multDiag_z + +subroutine TBMatrix_multDiagRL_d(this, A, diag) + type(TBMatrix), intent(inout) :: this + type(TBMatrix), intent(in) :: A + real(dp) :: diag(:) + + integer im + + if (this%N /= size(diag)) & + call system_abort("Called TBMatrix_multDiagRL_d with mismatched sizes") + + if ((A%is_sparse .and. .not. this%is_sparse) .or. & + (.not. A%is_sparse .and. this%is_sparse)) & + call system_abort ("Called TBMatrix_multDiagRL_d with mismatched sparsity") + + if ((this%is_complex .and. .not. A%is_complex) .or. & + (.not. this%is_complex .and. A%is_complex)) call system_abort ("TBMatrix_multDiagRL_d with mismatched types") + + do im=1, this%n_matrices + if (this%is_sparse) then + if (this%is_complex) then + call multDiagRL(this%sdata_z(im), A%sdata_z(im), diag) + else + call multDiagRL(this%sdata_d(im), A%sdata_d(im), diag) + endif + else + if (this%is_complex) then + call multDiagRL(this%data_z(im), A%data_z(im), diag) + else + call multDiagRL(this%data_d(im), A%data_d(im), diag) + endif + endif + end do +end subroutine TBMatrix_multDiagRL_d + +subroutine TBMatrix_matrix_product_sub(C, A, B, A_transpose, A_conjugate, B_transpose, B_conjugate, & + diag_mask, offdiag_mask) + type(TBMatrix), intent(inout) :: C + type(TBMatrix), intent(in) :: A, B + logical, intent(in), optional :: A_transpose, A_conjugate, B_transpose, B_conjugate + logical, intent(in), optional :: diag_mask(:), offdiag_mask(:) + + logical a_transp, a_conjg, b_transp, b_conjg + integer im + + if (C%N /= A%N .or. C%N /= B%N) call system_abort ("TBMatrix_matrix_product_sub with C vs A, B size mismatch" & + // C%N // " " // A%N // " " // B%N ) + + if (C%is_sparse .or. A%is_sparse) & + call system_abort("Can't do TBMatrix_matrix_product_sub C=A*B for sparse C or A matrices") + + a_transp = .false. + b_transp = .false. + a_conjg = .false. + b_conjg = .false. + if (present(a_transpose)) a_transp = a_transpose + if (present(b_transpose)) b_transp = b_transpose + if (present(a_conjugate)) a_conjg = a_conjugate + if (present(b_conjugate)) b_conjg = b_conjugate + + if (a_transp .and. a_conjg) then + call system_abort("TBMatrix_matrix_product_sub called with a_transp and a_conj both true") + endif + if (b_transp .and. b_conjg) then + call system_abort("TBMatrix_matrix_product_sub called with b_transp and b_conj both true") + endif + + do im=1, C%n_matrices + if (C%is_complex) then + if (A%is_complex) then + if (B%is_complex) then + if (B%is_sparse) then + call matrix_product_sub(C%data_z(im), A%data_z(im), B%sdata_z(im), a_transpose, a_conjugate, b_transpose, b_conjugate, & + diag_mask, offdiag_mask) + else + if (present(diag_mask) .or. present(offdiag_mask)) & + call system_abort("TBMatrix_matrix_product_sub can't use masks when B isn't sparse") + call matrix_product_sub(C%data_z(im), A%data_z(im), B%data_z(im), a_transpose, a_conjugate, b_transpose, b_conjugate) + endif + else ! B is real + if (B%is_sparse) then + call matrix_product_sub(C%data_z(im), A%data_z(im), B%sdata_d(im), a_transpose, a_conjugate, b_transp .or. b_conjg, & + diag_mask, offdiag_mask) + else + if (present(diag_mask) .or. present(offdiag_mask)) & + call system_abort("TBMatrix_matrix_product_sub can't use masks when B isn't sparse") + call matrix_product_sub(C%data_z(im), A%data_z(im), B%data_d(im), a_transpose, a_conjugate, b_transp .or. b_conjg) + endif + endif + else ! A is real + if (B%is_complex) then + if (B%is_sparse) then + call matrix_product_sub(C%data_z(im), A%data_d(im), B%sdata_z(im), a_transp .or. a_conjg, b_transpose, b_conjugate, & + diag_mask, offdiag_mask) + else + if (present(diag_mask) .or. present(offdiag_mask)) & + call system_abort("TBMatrix_matrix_product_sub can't use masks when B isn't sparse") + call matrix_product_sub(C%data_z(im), A%data_d(im), B%data_z(im), a_transp .or. a_conjg, b_transpose, b_conjugate) + endif + else + call system_abort ("No TBMatrix_matrix_product_sub for C = R R") + endif + endif + else ! C is real + if (A%is_complex) then + call system_abort("No TBMatrix_matrix_product for R = C * ?") + else ! A is real + if (B%is_complex) then + call system_abort("No TBMatrix_matrix_product for R = ?* C") + else ! B is real + if (B%is_sparse) then + call matrix_product_sub(C%data_d(im), A%data_d(im), B%sdata_d(im), a_transp .or. a_conjg, b_transp .or. b_conjg, & + diag_mask, offdiag_mask) + else + if (present(diag_mask) .or. present(offdiag_mask)) & + call system_abort("TBMatrix_matrix_product_sub can't use masks when B isn't sparse") + call matrix_product_sub(C%data_d(im), A%data_d(im), B%data_d(im), a_transp .or. a_conjg, b_transp .or. b_conjg) + endif + endif + endif + endif + end do +end subroutine TBMatrix_matrix_product_sub + +subroutine TBMatrix_matrix_product_sub_r2(C, A, B, a_transpose, a_conjugate, b_transpose) + type(TBMatrix), intent(inout) :: C + type(TBMatrix), intent(in) :: A + real(dp), intent(in) :: B(:,:) + logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose + + logical :: a_transp, a_conjg + + integer im + + a_transp = .false. + a_conjg = .false. + if (present(a_transpose)) a_transp = a_transpose + if (present(a_conjugate)) a_conjg = a_conjugate + + if (a_transp .and. a_conjg) call system_abort("Called TBMatrix_matrix_product_sub_r2 with a_transp and a_conjg") + + if (C%N /= A%N .or. C%N /= size(B,2)) call system_abort ("TBMatrix_matrix_product with C vs A, B size mismatch") + + if (C%is_sparse .or. A%is_sparse) & + call system_abort("Can't do TBMatrix_matrix_product_r2 for sparse matrices") + + do im=1, C%n_matrices + if (C%is_complex) then + call system_abort ("No TBMatrix_matrix_product for C = ? ?") + else ! C is real + if (A%is_complex) then + call system_abort ("No TBMatrix_matrix_product for R = C ?") + else + call matrix_product_sub(C%data_d(im), A%data_d(im), B, a_transp .or. a_conjg, b_transpose) + endif + endif + end do +end subroutine TBMatrix_matrix_product_sub_r2 + +subroutine TBMatrix_accum_scaled_elem_product(A, B, s, C) + type(TBMatrix), intent(in) :: A, B + complex(dp), intent(in) :: s + type(TBMatrix), intent(inout) :: C + + integer im + + if (A%N /= B%N .or. A%N /= C%N) & + call system_abort ("TBMatrix_accum_scaled_elem_product called with size mismatch") + if (A%n_matrices /= B%n_matrices .or. A%n_matrices /= C%n_matrices) & + call system_abort ("TBMatrix_accum_scaled_elem_product called with n_matrices mismatch") + + if (A%is_sparse .or. B%is_sparse .or. C%is_sparse) then + call system_abort ("TBMatrix_accum_scaled_elem_product called with sparse matrix") + endif + + do im=1, A%n_matrices + if (C%is_complex) then + call system_abort("No TBMatrix_accum_scaled_elem_product for complex C") + else + if (A%is_complex) then + if (B%is_complex) then + C%data_d(im)%data = C%data_d(im)%data + real(s * A%data_z(im)%data * B%data_z(im)%data) + else + call system_abort("No TBMatrix_accum_scaled_elem_product for real B") + endif + else + call system_abort("No TBMatrix_accum_scaled_elem_product for real A") + endif + + endif + end do +end subroutine TBMatrix_accum_scaled_elem_product + +subroutine TBMatrix_sum_matrices_d(this, weights, m) + type(TBMatrix), intent(in) :: this + real(dp), intent(in) :: weights(:) + type(MatrixD), intent(inout) :: m + + integer im + + if (this%N /= m%N .or. this%N /= m%M) call system_abort("TBMatrix_sum_matrices_d called with size mismatch") + if (this%n_matrices /= size(weights)) call system_abort("TBMatrix_sum_matrices_d called with n_matrices mismatch") + + if (this%is_sparse) call system_abort("Can't do TBMatrix_sum_matrices_d on a sparse TBMatrix") + + m%data = 0.0_dp + + do im=1, this%n_matrices + if (this%is_complex) then + m%data = m%data + weights(im)*this%data_z(im)%data + else + m%data = m%data + weights(im)*this%data_d(im)%data + endif + end do +end subroutine TBMatrix_sum_matrices_d + +subroutine TBMatrix_transpose_sub(this, m) + type(TBMatrix), intent(inout) :: this + type(TBMatrix), intent(in) :: m + + integer im + + if (this%N /= m%N) call system_abort("TBMatrix_transpose_sub called with size mismatch") + if (this%n_matrices /= m%n_matrices) call system_abort("TBMatrix_transpose_sub called with n_matrices mismatch") + + if (this%is_sparse .or. m%is_sparse) call system_abort("Can't do TBMatrix_transpose_sub on a sparse TBMatrix") + + do im=1, this%n_matrices + if (this%is_complex) then + if (m%is_complex) then + call transpose_sub(this%data_z(im), m%data_z(im)) + else + call system_abort("Can't TBMatrix_transpose_sub from real matrix into complex") + ! call transpose_sub(this%data_z(im), m%data_d(im)) + endif + else + if (m%is_complex) then + ! call transpose_sub(this%data_d(im), m%data_z(im)) + call system_abort("Can't TBMatrix_transpose_sub from complex matrix into real") + else + call transpose_sub(this%data_d(im), m%data_d(im)) + endif + endif + end do + +end subroutine TBMatrix_transpose_sub + +subroutine TBMatrix_make_hermitian(this) + type(TBMatrix), intent(inout) :: this + + integer :: im + + if (this%is_sparse) call system_abort("Can't do TBMatrix_make_hermitian on a sparse TBMatrix") + + do im=1, this%n_matrices + if (this%is_complex) then + call make_hermitian(this%data_z(im)) + else + call make_hermitian(this%data_d(im)) + endif + end do + +end subroutine TBMatrix_make_hermitian + +end module TBMatrix_module diff --git a/src/Potentials/TBModel.F90 b/src/Potentials/TBModel.F90 new file mode 100644 index 0000000000..6a71cd2139 --- /dev/null +++ b/src/Potentials/TBModel.F90 @@ -0,0 +1,674 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X TBModel module +!X +!% General object which handles the possible TB scheme, addressing +!% the calls to the right modules. +!% The available models are the following +!% \begin{itemize} +!% \item "NRL_TB", whose related object is \texttt{TBModel_NRL_TB} +!% \item "Bowler", whose related object is \texttt{TBModel_Bowler} +!% \item "DFTB" , whose related object is \texttt{TBModel_DFTB} +!% \item "GSP" , whose related object is \texttt{TBModel_GSP} +!% \end{itemize} +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module TBModel_module + +use system_module, only : dp, print, inoutput, PRINT_VERBOSE, system_abort, operator(//) +use dictionary_module +use paramreader_module +use atoms_module + +use QUIP_Common_module +use TBModel_NRL_TB_module +use TBModel_Bowler_module +use TBModel_DFTB_module +use TBModel_GSP_module + +implicit none +private + +integer, parameter :: FF_NONE = 0, FF_NRL_TB = 1, FF_Bowler = 2, FF_DFTB = 3, FF_GSP = 4 +character(len=6) :: ff_names(0:4) = (/ & + 'NONE ', & + 'NRL_TB', & + 'Bowler', & + 'DFTB ', & + 'GSP '/) + +include 'TBModel_interface.h' + +public :: TBModel +type TBModel + real(dp) cutoff + + logical is_orthogonal + integer :: functional_form = FF_NONE + + type(TBModel_NRL_TB) tbmodel_nrl_tb + type(TBModel_Bowler) tbmodel_bowler + type(TBModel_DFTB) tbmodel_dftb + type(TBModel_GSP) tbmodel_gsp + + logical :: has_default_fermi_E, has_default_fermi_T, has_default_band_width, has_default_k_density + real(dp) :: default_fermi_E, default_fermi_T, default_band_width, default_k_density + +end type TBModel + +interface Initialise + module procedure TBModel_Initialise_str +end interface Initialise + +interface Finalise + module procedure TBModel_Finalise +end interface Finalise + +interface Print + module procedure TBModel_Print +end interface Print + +interface n_orbs_of_Z + module procedure TBModel_n_orbs_of_Z +end interface n_orbs_of_Z + +interface n_orb_sets_of_Z + module procedure TBModel_n_orb_sets_of_Z +end interface n_orb_sets_of_Z + +interface n_orbs_of_orb_set_of_Z + module procedure TBModel_n_orbs_of_orb_set_of_Z +end interface n_orbs_of_orb_set_of_Z + +interface orb_type_of_orb_set_of_Z + module procedure TBModel_orb_type_of_orb_set_of_Z +end interface orb_type_of_orb_set_of_Z + +interface n_elecs_of_Z + module procedure TBModel_n_elecs_of_Z +end interface n_elecs_of_Z + +interface get_HS_blocks + module procedure TBModel_get_HS_blocks +end interface get_HS_blocks + +interface get_dHS_masks + module procedure TBModel_get_dHS_masks +end interface get_dHS_masks + +interface get_dHS_blocks + module procedure TBModel_get_dHS_blocks +end interface get_dHS_blocks + +interface get_local_rep_E + module procedure TBModel_get_local_rep_E +end interface get_local_rep_E + +interface get_local_rep_E_force + module procedure TBModel_get_local_rep_E_force +end interface get_local_rep_E_force + +interface get_local_rep_E_virial + module procedure TBModel_get_local_rep_E_virial +end interface get_local_rep_E_virial + +public :: has_fermi_E +interface has_fermi_E + module procedure TBModel_has_fermi_E +end interface has_fermi_E + +public :: has_fermi_T +interface has_fermi_T + module procedure TBModel_has_fermi_T +end interface has_fermi_T + +public :: has_band_width +interface has_band_width + module procedure TBModel_has_band_width +end interface has_band_width + +public :: has_k_density +interface has_k_density + module procedure TBModel_has_k_density +end interface has_k_density + +contains + +subroutine TBModel_Initialise_str(this, args_str, param_str) + type(TBModel), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + logical :: is_nrl_tb, is_bowler, is_dftb, is_gsp + real(dp) :: str_fermi_e, str_fermi_T, str_band_width, str_k_density + logical, target :: has_str_fermi_e, has_str_fermi_T, has_str_band_width, has_str_k_density + + call Initialise(params) + call param_register(params, 'NRL-TB', 'false', is_nrl_tb, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'Bowler', 'false', is_bowler, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'DFTB', 'false', is_dftb, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'GSP', 'false', is_gsp, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'fermi_e', '0.0', str_fermi_e, has_value_target=has_str_fermi_e, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'fermi_T', '0.0', str_fermi_T, has_value_target=has_str_fermi_T, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'band_width', '0.0', str_band_width, has_value_target=has_str_band_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'k_density', '0.0', str_k_density, has_value_target=has_str_k_density, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_Initialise_str args_str')) then + call system_abort("TBModel_Initialise_str failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + + if (count((/is_nrl_tb, is_bowler, is_dftb, is_gsp/)) /= 1) then + call system_abort("TBModel_Initialise_str found too few or too many TB Model types args_str='"//trim(args_str)//"'") + endif + + if (is_nrl_tb) then + this%functional_form = FF_NRL_TB + call Initialise(this%tbmodel_nrl_tb, args_str, param_str) + this%cutoff=this%tbmodel_nrl_tb%cutoff + this%is_orthogonal = this%tbmodel_nrl_tb%is_orthogonal + this%has_default_fermi_e = this%tbmodel_nrl_tb%has_default_fermi_e + this%has_default_fermi_T = this%tbmodel_nrl_tb%has_default_fermi_T + this%has_default_band_width = this%tbmodel_nrl_tb%has_default_band_width + this%has_default_k_density = this%tbmodel_nrl_tb%has_default_k_density + this%default_fermi_e = this%tbmodel_nrl_tb%default_fermi_e + this%default_fermi_T = this%tbmodel_nrl_tb%default_fermi_T + this%default_band_width = this%tbmodel_nrl_tb%default_band_width + this%default_k_density = this%tbmodel_nrl_tb%default_k_density + else if (is_bowler) then + this%functional_form = FF_Bowler + call Initialise(this%tbmodel_bowler, args_str, param_str) + this%cutoff=this%tbmodel_bowler%cutoff + this%is_orthogonal = this%tbmodel_bowler%is_orthogonal + this%has_default_fermi_e = this%tbmodel_bowler%has_default_fermi_e + this%has_default_fermi_T = this%tbmodel_bowler%has_default_fermi_T + this%has_default_band_width = this%tbmodel_bowler%has_default_band_width + this%has_default_k_density = this%tbmodel_bowler%has_default_k_density + this%default_fermi_e = this%tbmodel_bowler%default_fermi_e + this%default_fermi_T = this%tbmodel_bowler%default_fermi_T + this%default_band_width = this%tbmodel_bowler%default_band_width + this%default_k_density = this%tbmodel_bowler%default_k_density + else if(is_dftb) then + this%functional_form = FF_DFTB + call Initialise(this%tbmodel_dftb, args_str, param_str) + this%cutoff=this%tbmodel_dftb%cutoff + this%is_orthogonal = this%tbmodel_dftb%is_orthogonal + this%has_default_fermi_e = this%tbmodel_dftb%has_default_fermi_e + this%has_default_fermi_T = this%tbmodel_dftb%has_default_fermi_T + this%has_default_band_width = this%tbmodel_dftb%has_default_band_width + this%has_default_k_density = this%tbmodel_dftb%has_default_k_density + this%default_fermi_e = this%tbmodel_dftb%default_fermi_e + this%default_fermi_T = this%tbmodel_dftb%default_fermi_T + this%default_band_width = this%tbmodel_dftb%default_band_width + this%default_k_density = this%tbmodel_dftb%default_k_density + else if (is_gsp) then + this%functional_form = FF_GSP + call Initialise(this%tbmodel_gsp, args_str, param_str) + this%cutoff=this%tbmodel_gsp%cutoff + this%is_orthogonal = this%tbmodel_gsp%is_orthogonal + this%has_default_fermi_e = this%tbmodel_gsp%has_default_fermi_e + this%has_default_fermi_T = this%tbmodel_gsp%has_default_fermi_T + this%has_default_band_width = this%tbmodel_gsp%has_default_band_width + this%has_default_k_density = this%tbmodel_gsp%has_default_k_density + this%default_fermi_e = this%tbmodel_gsp%default_fermi_e + this%default_fermi_T = this%tbmodel_gsp%default_fermi_T + this%default_band_width = this%tbmodel_gsp%default_band_width + this%default_k_density = this%tbmodel_gsp%default_k_density + end if + + if (has_str_fermi_e) then + this%has_default_fermi_e = .true. + this%default_fermi_e = str_fermi_e + endif + if (has_str_fermi_T) then + this%has_default_fermi_T = .true. + this%default_fermi_T = str_fermi_T + endif + if (has_str_band_width) then + this%has_default_band_width = .true. + this%default_band_width = str_band_width + endif + if (has_str_k_density) then + this%has_default_k_density = .true. + this%default_k_density = str_k_density + endif + +end subroutine TBModel_Initialise_str + +subroutine TBModel_Finalise(this) + type(TBModel), intent(inout) :: this + + select case(this%functional_form) + case (FF_NRL_TB) + call Finalise(this%tbmodel_nrl_tb) + case (FF_Bowler) + call Finalise(this%tbmodel_bowler) + case (FF_DFTB) + call Finalise(this%tbmodel_dftb) + case (FF_GSP) + call Finalise(this%tbmodel_gsp) + case (FF_NONE) + return + case default + call system_abort ('TBModel_Finalise confused by functional_form' // this%functional_form) + end select + +end subroutine TBModel_Finalise + +function TBModel_n_orbs_of_Z(this, Z) + type(TBModel), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_n_orbs_of_Z + + select case(this%functional_form) + case (FF_NRL_TB) + TBModel_n_orbs_of_Z = n_orbs_of_Z(this%tbmodel_nrl_tb,Z) + case (FF_Bowler) + TBModel_n_orbs_of_Z = n_orbs_of_Z(this%tbmodel_bowler,Z) + case (FF_DFTB) + TBModel_n_orbs_of_Z = n_orbs_of_Z(this%tbmodel_dftb,Z) + case (FF_GSP) + TBModel_n_orbs_of_Z = n_orbs_of_Z(this%tbmodel_gsp,Z) + case default + call system_abort ('TBModel_n_orbs_of_Z confused by functional_form' // this%functional_form) + end select + +end function TBModel_n_orbs_of_Z + +function TBModel_n_orb_sets_of_Z(this, Z) + type(TBModel), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_n_orb_sets_of_Z + + select case(this%functional_form) + case (FF_NRL_TB) + TBModel_n_orb_sets_of_Z = n_orb_sets_of_Z(this%tbmodel_nrl_tb,Z) + case (FF_Bowler) + TBModel_n_orb_sets_of_Z = n_orb_sets_of_Z(this%tbmodel_bowler,Z) + case (FF_DFTB) + TBModel_n_orb_sets_of_Z = n_orb_sets_of_Z(this%tbmodel_dftb,Z) + case (FF_GSP) + TBModel_n_orb_sets_of_Z = n_orb_sets_of_Z(this%tbmodel_gsp,Z) + case default + call system_abort ('TBModel_n_orb_sets_of_Z confused by functional_form' // this%functional_form) + end select + +end function TBModel_n_orb_sets_of_Z + +function TBModel_n_orbs_of_orb_set_of_Z(this, Z, i_set) + type(TBModel), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_n_orbs_of_orb_set_of_Z + + select case(this%functional_form) + case (FF_NRL_TB) + TBModel_n_orbs_of_orb_set_of_Z = n_orbs_of_orb_set_of_Z(this%tbmodel_nrl_tb,Z,i_set) + case (FF_Bowler) + TBModel_n_orbs_of_orb_set_of_Z = n_orbs_of_orb_set_of_Z(this%tbmodel_bowler,Z,i_set) + case (FF_DFTB) + TBModel_n_orbs_of_orb_set_of_Z = n_orbs_of_orb_set_of_Z(this%tbmodel_dftb,Z,i_set) + case (FF_GSP) + TBModel_n_orbs_of_orb_set_of_Z = n_orbs_of_orb_set_of_Z(this%tbmodel_gsp,Z,i_set) + case default + call system_abort ('TBModel_n_orbs_of_orb_set_of_Z confused by functional_form' // this%functional_form) + end select + +end function TBModel_n_orbs_of_orb_set_of_Z + +function TBModel_orb_type_of_orb_set_of_Z(this, Z, i_set) + type(TBModel), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_orb_type_of_orb_set_of_Z + + select case(this%functional_form) + case (FF_NRL_TB) + TBModel_orb_type_of_orb_set_of_Z = orb_type_of_orb_set_of_Z(this%tbmodel_nrl_tb,Z,i_set) + case (FF_Bowler) + TBModel_orb_type_of_orb_set_of_Z = orb_type_of_orb_set_of_Z(this%tbmodel_bowler,Z,i_set) + case (FF_DFTB) + TBModel_orb_type_of_orb_set_of_Z = orb_type_of_orb_set_of_Z(this%tbmodel_dftb,Z,i_set) + case (FF_GSP) + TBModel_orb_type_of_orb_set_of_Z = orb_type_of_orb_set_of_Z(this%tbmodel_gsp,Z,i_set) + case default + call system_abort ('TBModel_orb_type_of_orb_set_of_Z confused by functional_form' // this%functional_form) + end select + +end function TBModel_orb_type_of_orb_set_of_Z + +function TBModel_n_elecs_of_Z(this, Z) + type(TBModel), intent(in) :: this + integer, intent(in) :: Z + real(dp) TBModel_n_elecs_of_Z + + select case(this%functional_form) + case (FF_NRL_TB) + TBModel_n_elecs_of_Z = n_elecs_of_Z(this%tbmodel_nrl_tb,Z) + case (FF_Bowler) + TBModel_n_elecs_of_Z = n_elecs_of_Z(this%tbmodel_bowler,Z) + case (FF_DFTB) + TBModel_n_elecs_of_Z = n_elecs_of_Z(this%tbmodel_dftb,Z) + case (FF_GSP) + TBModel_n_elecs_of_Z = n_elecs_of_Z(this%tbmodel_gsp,Z) + case default + call system_abort ('TBModel_n_elecs_of_Z confused by functional_form' // this%functional_form) + end select + +end function TBModel_n_elecs_of_Z + +subroutine TBModel_Print(this,file) + type(TBModel), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + call print("TBModel: is_orthogonal " // this%is_orthogonal, PRINT_VERBOSE) + call print("TBModel: functional_form " // ff_names(this%functional_form), PRINT_VERBOSE) + call print("TBModel: has_default_fermi_e " // this%has_default_fermi_e // " default_fermi_e " // & + this%default_fermi_e, PRINT_VERBOSE) + call print("TBModel: has_default_fermi_T " // this%has_default_fermi_T // " default_fermi_T " // & + this%default_fermi_T, PRINT_VERBOSE) + call print("TBModel: has_default_band_width " // this%has_default_band_width // " default_band_width " // & + this%default_band_width, PRINT_VERBOSE) + call print("TBModel: has_default_k_density " // this%has_default_k_density // " default_k_density " // & + this%default_k_density, PRINT_VERBOSE) + + select case(this%functional_form) + case (FF_NRL_TB) + call Print(this%tbmodel_nrl_tb, file=file) + case (FF_Bowler) + call Print(this%tbmodel_bowler, file=file) + case (FF_DFTB) + call Print(this%tbmodel_dftb, file=file) + case (FF_GSP) + call Print(this%tbmodel_gsp, file=file) + case default + call system_abort ('TBModel_Print confused by functional_form' // this%functional_form) + end select + +end subroutine + +subroutine TBModel_get_HS_blocks(this, at, i, j, dv_hat, dv_mag, b_H, b_S, i_mag) + type(TBModel), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i, j + real(dp), intent(in) :: dv_hat(3), dv_mag + real(dp), intent(out) :: b_H(:,:), b_S(:,:) + integer, intent(in), optional :: i_mag + + select case(this%functional_form) + case (FF_NRL_TB) + call get_HS_blocks(this%tbmodel_nrl_tb, at, i, j, dv_hat, dv_mag, b_H, b_S, i_mag) + case (FF_Bowler) + call get_HS_blocks(this%tbmodel_bowler, at, i, j, dv_hat, dv_mag, b_H, b_S, i_mag) + case (FF_DFTB) + call get_HS_blocks(this%tbmodel_dftb, at, i, j, dv_hat, dv_mag, b_H, b_S, i_mag) + case (FF_GSP) + call get_HS_blocks(this%tbmodel_gsp, at, i, j, dv_hat, dv_mag, b_H, b_S) + case default + call system_abort ('TBModel_get_HS_blocks confused by functional_form' // this%functional_form) + end select + +end subroutine + +subroutine TBModel_get_dHS_masks(this, at, at_ind, d_mask, od_mask) + type(TBModel), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_ind + logical, intent(out), optional :: d_mask(:), od_mask(:) + + select case(this%functional_form) + case (FF_NRL_TB) + call get_dHS_masks(this%tbmodel_nrl_tb, at, at_ind, d_mask, od_mask) + case (FF_Bowler) + call get_dHS_masks(this%tbmodel_bowler, at, at_ind, d_mask, od_mask) + case (FF_DFTB) + call get_dHS_masks(this%tbmodel_dftb, at, at_ind, d_mask, od_mask) + case (FF_GSP) + call get_dHS_masks(this%tbmodel_gsp, at_ind, d_mask, od_mask) + case default + call system_abort ('TBModel_get_HS_masks confused by functional_form' // this%functional_form) + end select + +end subroutine + +function TBModel_get_dHS_blocks(this, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) + type(TBModel), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i, j + real(dp), intent(in) :: dv_hat(3), dv_mag + integer, intent(in) :: at_ind + real(dp), intent(out) :: b_dH(:,:,:), b_dS(:,:,:) + integer, intent(in), optional :: i_mag + logical TBModel_get_dHS_blocks + + select case(this%functional_form) + case (FF_NRL_TB) + TBModel_get_dHS_blocks = get_dHS_blocks(this%tbmodel_nrl_tb, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) + case (FF_Bowler) + TBModel_get_dHS_blocks = get_dHS_blocks(this%tbmodel_bowler, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) + case (FF_DFTB) + TBModel_get_dHS_blocks = get_dHS_blocks(this%tbmodel_dftb, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) + case (FF_GSP) + TBModel_get_dHS_blocks = get_dHS_blocks(this%tbmodel_gsp, at, i, j, dv_hat, dv_mag, at_ind, b_dH, b_dS) + case default + call system_abort ('TBModel_get_HS_blocks confused by functional_form' // this%functional_form) + end select + +end function TBModel_get_dHS_blocks + +function TBModel_get_local_rep_E(this, at, i) + type(TBModel), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: TBModel_get_local_rep_E + + select case(this%functional_form) + case (FF_NRL_TB) + TBModel_get_local_rep_E = get_local_rep_E(this%tbmodel_nrl_tb, at, i) + case (FF_Bowler) + TBModel_get_local_rep_E = get_local_rep_E(this%tbmodel_bowler, at, i) + case (FF_DFTB) + TBModel_get_local_rep_E = get_local_rep_E(this%tbmodel_dftb, at, i) + case (FF_GSP) + TBModel_get_local_rep_E = get_local_rep_E(this%tbmodel_gsp, at, i) + case default + call system_abort ('TBModel_get_local_rep_E confused by functional_form' // this%functional_form) + end select +end function TBModel_get_local_rep_E + +function TBModel_get_local_rep_E_force(this, at, i) result(force) + type(TBModel), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: force(3,at%N) + + select case(this%functional_form) + case (FF_NRL_TB) + force = get_local_rep_E_force(this%tbmodel_nrl_tb, at, i) + case (FF_Bowler) + force = get_local_rep_E_force(this%tbmodel_bowler, at, i) + case (FF_DFTB) + force = get_local_rep_E_force(this%tbmodel_dftb, at, i) + case (FF_GSP) + force = get_local_rep_E_force(this%tbmodel_gsp, at, i) + case default + call system_abort ('TBModel_get_local_rep_E_force confused by functional_form' // this%functional_form) + end select +end function TBModel_get_local_rep_E_force + +function TBModel_get_local_rep_E_virial(this, at, i) result(virial) + type(TBModel), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: virial(3,3) + + select case(this%functional_form) + case (FF_NRL_TB) + virial = get_local_rep_E_virial(this%tbmodel_nrl_tb, at, i) + case (FF_Bowler) + virial = get_local_rep_E_virial(this%tbmodel_bowler, at, i) + case (FF_DFTB) + virial = get_local_rep_E_virial(this%tbmodel_dftb, at, i) + case (FF_GSP) + virial = get_local_rep_E_virial(this%tbmodel_gsp, at, i) + case default + call system_abort ('TBModel_get_local_rep_E_virial confused by functional_form' // this%functional_form) + end select +end function TBModel_get_local_rep_E_virial + +function TBModel_has_Fermi_E(out_Fermi_E, this, Fermi_E, args_str) + real(dp), intent(out) :: out_Fermi_E + type(TBModel), intent(in) :: this + real(dp), optional, intent(in) :: Fermi_E + character(len=*), optional, intent(in) :: args_str + logical :: TBModel_has_Fermi_E + + type(Dictionary) :: params + logical :: has_str_fermi_e + + TBModel_has_Fermi_E = .false. + if (present(Fermi_E)) then + out_Fermi_E = Fermi_E + TBModel_has_Fermi_E = .true. + else + if (this%has_default_fermi_E) then + out_Fermi_E = this%default_Fermi_E + TBModel_has_Fermi_E = .true. + endif + if (present(args_str)) then + call initialise(params) + call param_register(params, 'fermi_e', ''//out_fermi_E, out_fermi_E, has_value_target=has_str_fermi_e, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_has_Fermi_E args_str')) then + call system_abort("TBModel_has_fermi_e failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + if (has_str_fermi_e) TBModel_has_fermi_E = .true. + endif + endif + +end function TBModel_has_Fermi_E + +function TBModel_has_Fermi_T(out_Fermi_T, this, Fermi_T, args_str) + real(dp), intent(out) :: out_Fermi_T + type(TBModel), intent(in) :: this + real(dp), optional, intent(in) :: Fermi_T + character(len=*), optional, intent(in) :: args_str + logical :: TBModel_has_Fermi_T + + type(Dictionary) :: params + logical :: has_str_fermi_T + + TBModel_has_Fermi_T = .false. + if (present(Fermi_T)) then + out_Fermi_T = Fermi_T + TBModel_has_Fermi_T = .true. + else + if (this%has_default_fermi_T) then + out_Fermi_T = this%default_Fermi_T + TBModel_has_Fermi_T = .true. + endif + if (present(args_str)) then + call initialise(params) + call param_register(params, 'fermi_T', ''//out_fermi_T, out_fermi_T, has_value_target=has_str_fermi_T, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_has_Fermi_T args_str')) then + call system_abort("TBModel_has_fermi_T failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + if (has_str_fermi_T) TBModel_has_fermi_T = .true. + endif + endif + +end function TBModel_has_Fermi_T + +function TBModel_has_band_width(out_band_width, this, band_width, args_str) + real(dp), intent(out) :: out_band_width + type(TBModel), intent(in) :: this + real(dp), optional, intent(in) :: band_width + character(len=*), optional, intent(in) :: args_str + logical :: TBModel_has_band_width + + type(Dictionary) :: params + logical :: has_str_band_width + + TBModel_has_band_width = .false. + if (present(band_width)) then + out_band_width = band_width + TBModel_has_band_width = .true. + else + if (this%has_default_band_width) then + out_band_width = this%default_band_width + TBModel_has_band_width = .true. + endif + if (present(args_str)) then + call initialise(params) + call param_register(params, 'band_width', ''//out_band_width, out_band_width, has_value_target=has_str_band_width, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_has_band_width args_str')) then + call system_abort("TBModel_has_band_width failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + if (has_str_band_width) TBModel_has_band_width = .true. + endif + endif + +end function TBModel_has_band_width + +function TBModel_has_k_density(out_k_density, this, k_density, args_str) + real(dp), intent(out) :: out_k_density + type(TBModel), intent(in) :: this + real(dp), optional, intent(in) :: k_density + character(len=*), optional, intent(in) :: args_str + logical :: TBModel_has_k_density + + type(Dictionary) :: params + logical :: has_str_k_density + + TBModel_has_k_density = .false. + if (present(k_density)) then + out_k_density = k_density + TBModel_has_k_density = .true. + else + if (this%has_default_k_density) then + out_k_density = this%default_k_density + TBModel_has_k_density = .true. + endif + if (present(args_str)) then + call initialise(params) + call param_register(params, 'k_density', ''//out_k_density, out_k_density, has_value_target=has_str_k_density, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_has_k_density args_str')) then + call system_abort("TBModel_has_k_density failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + if (has_str_k_density) TBModel_has_k_density = .true. + endif + endif + +end function TBModel_has_k_density + +end module TBModel_module diff --git a/src/Potentials/TBModel_Bowler.F90 b/src/Potentials/TBModel_Bowler.F90 new file mode 100644 index 0000000000..1f02d1464c --- /dev/null +++ b/src/Potentials/TBModel_Bowler.F90 @@ -0,0 +1,1089 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X TBModel_Bowler module +!X +!% Calculate energies using Bowler tight-binding model +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module TBModel_Bowler_module + +use system_module, only : dp, print, inoutput, system_abort, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use spline_module +use atoms_module + +use TB_Common_module +use QUIP_Common_module + +implicit none +private + +integer, parameter :: max_n_orb_sets = 2 + +include 'TBModel_interface.h' + +public :: TBModel_Bowler +type TBModel_Bowler + integer :: n_types = 0 + character(len=STRING_LENGTH) label + + real(dp) :: cutoff = 0.0_dp + logical :: is_orthogonal = .true. + + integer, allocatable :: type_of_atomic_num(:) + integer, allocatable :: n_orbs(:), n_elecs(:), n_orb_sets(:), orb_set_type(:,:) + integer, allocatable :: atomic_num(:) + + !! Bowler parameters + real(dp), allocatable :: H_coeff(:,:,:), Vrep(:,:) + real(dp), allocatable :: r0(:,:), rc(:,:), n(:,:), nc(:,:), dc(:,:), m(:,:), mc(:,:) + real(dp) :: tailx0 + + real(dp), allocatable :: E(:,:) + + type(spline), allocatable :: H_tail_spline(:,:) + type(spline), allocatable :: Vrep_tail_spline(:,:) + + logical :: has_default_fermi_E = .false., has_default_fermi_T = .true., has_default_band_width = .false., has_default_k_density=.false. + real(dp) :: default_fermi_E, default_fermi_T = 0.001_dp, default_band_width, default_k_density + +end type + +integer, private :: parse_cur_type +logical, private :: parse_in_tbm, parse_matched_label +type(TBModel_Bowler), private, pointer :: parse_tbm + +interface Initialise + module procedure TBModel_Bowler_Initialise_str +end interface Initialise + +interface Finalise + module procedure TBModel_Bowler_Finalise +end interface Finalise + +interface Print + module procedure TBModel_Bowler_Print +end interface Print + +interface n_orbs_of_Z + module procedure TBModel_Bowler_n_orbs_of_Z +end interface n_orbs_of_Z + +interface n_orb_sets_of_Z + module procedure TBModel_Bowler_n_orb_sets_of_Z +end interface n_orb_sets_of_Z + +interface n_orbs_of_orb_set_of_Z + module procedure TBModel_Bowler_n_orbs_of_orb_set_of_Z +end interface n_orbs_of_orb_set_of_Z + +interface orb_type_of_orb_set_of_Z + module procedure TBModel_Bowler_orb_type_of_orb_set_of_Z +end interface orb_type_of_orb_set_of_Z + +interface n_elecs_of_Z + module procedure TBModel_Bowler_n_elecs_of_Z +end interface n_elecs_of_Z + +interface get_HS_blocks + module procedure TBModel_Bowler_get_HS_blocks +end interface get_HS_blocks + +interface get_dHS_masks + module procedure TBModel_Bowler_get_dHS_masks +end interface get_dHS_masks + +interface get_dHS_blocks + module procedure TBModel_Bowler_get_dHS_blocks +end interface get_dHS_blocks + +interface get_local_rep_E + module procedure TBModel_Bowler_get_local_rep_E +end interface get_local_rep_E + +interface get_local_rep_E_force + module procedure TBModel_Bowler_get_local_rep_E_force +end interface get_local_rep_E_force + +interface get_local_rep_E_virial + module procedure TBModel_Bowler_get_local_rep_E_virial +end interface get_local_rep_E_virial + +interface calc_H_coeff + module procedure TBModel_Bowler_calc_H_coeff +end interface calc_H_coeff + +interface calc_H_coeff_deriv + module procedure TBModel_Bowler_calc_H_coeff_deriv +end interface calc_H_coeff_deriv + +contains + +subroutine TBModel_Bowler_Initialise_str(this, args_str, param_str) + type(TBModel_Bowler), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_Bowler_Initialise_str args_str')) then + call system_abort("TBModel_Bowler_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call TBModel_Bowler_read_params_xml(this, param_str) +end subroutine TBModel_Bowler_Initialise_str + +subroutine TBModel_Bowler_Finalise(this) + type(TBModel_Bowler), intent(inout) :: this + + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%n_orbs)) deallocate(this%n_orbs) + if (allocated(this%n_elecs)) deallocate(this%n_elecs) + if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) + if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + + if (allocated(this%H_coeff)) deallocate(this%H_coeff) + if (allocated(this%Vrep)) deallocate(this%Vrep) + + if (allocated(this%r0)) deallocate(this%r0) + if (allocated(this%rc)) deallocate(this%rc) + if (allocated(this%n)) deallocate(this%n) + if (allocated(this%nc)) deallocate(this%nc) + if (allocated(this%dc)) deallocate(this%dc) + if (allocated(this%m)) deallocate(this%m) + if (allocated(this%mc)) deallocate(this%mc) + + if (allocated(this%E)) deallocate(this%E) + + if (allocated(this%H_tail_spline)) deallocate(this%H_tail_spline) + if (allocated(this%Vrep_tail_spline)) deallocate(this%Vrep_tail_spline) + + this%n_types = 0 + this%label = '' +end subroutine TBModel_Bowler_Finalise + +subroutine TBM_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + character(len=1024) :: value + integer status + integer ti, tj, Zi, Zj + + if (name == 'Bowler_params') then ! new Bowler stanza + + if (parse_in_tbm) & + call system_abort("IPModel_startElement_handler entered Bowler_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_tbm%label)) > 0) then ! we were passed in a label + if (value == parse_tbm%label) then ! exact match + parse_matched_label = .true. + parse_in_tbm = .true. + else ! no match + parse_in_tbm = .false. + endif + else ! no label passed in + parse_in_tbm = .true. + endif + + if (parse_in_tbm) then + if (parse_tbm%n_types /= 0) then + call finalise(parse_tbm) + endif + + parse_cur_type = 1 + + call QUIP_FoX_get_value(attributes, "n_types", value, status); + if (status == 0) read (value, *) parse_tbm%n_types + call QUIP_FoX_get_value(attributes, "tailx0", value, status); + if (status == 0) read (value, *) parse_tbm%tailx0 + call QUIP_FoX_get_value(attributes, "cutoff", value, status); + if (status == 0) read (value, *) parse_tbm%cutoff + + allocate(parse_tbm%atomic_num(parse_tbm%n_types)) + parse_tbm%atomic_num = 0 + allocate(parse_tbm%n_orbs(parse_tbm%n_types)) + allocate(parse_tbm%n_elecs(parse_tbm%n_types)) + allocate(parse_tbm%n_orb_sets(parse_tbm%n_types)) + allocate(parse_tbm%orb_set_type(max_n_orb_sets,parse_tbm%n_types)) + allocate(parse_tbm%E(max_n_orb_sets,parse_tbm%n_types)) + + allocate(parse_tbm%H_coeff(4, parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%Vrep(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%rc(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%r0(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%n(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%nc(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%dc(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%m(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%mc(parse_tbm%n_types, parse_tbm%n_types)) + + parse_tbm%H_coeff = 0.0_dp + parse_tbm%Vrep = 0.0_dp + parse_tbm%rc = 1.0_dp + parse_tbm%r0 = 0.0_dp + parse_tbm%n = 0.0_dp + parse_tbm%nc = 0.0_dp + parse_tbm%dc = 1.0_dp + parse_tbm%m = 0.0_dp + parse_tbm%mc = 0.0_dp + endif + + elseif (parse_in_tbm .and. name == 'per_type_data') then + if (parse_cur_type > parse_tbm%n_types) & + call system_abort('Too many types defined in Bowler_params') + + call QUIP_FoX_get_value(attributes, "Z", value, status); + if (status == 0) read (value, *) parse_tbm%atomic_num(parse_cur_type) + + call QUIP_FoX_get_value(attributes, "n_orbs", value, status); + if (status == 0) read (value, *) parse_tbm%n_orbs(parse_cur_type) + if (parse_tbm%n_orbs(parse_cur_type) == 1) then + parse_tbm%n_orb_sets(parse_cur_type) = 1 + parse_tbm%orb_set_type(1,parse_cur_type) = ORB_S + call QUIP_FoX_get_value(attributes, "E_s", value, status); + if (status == 0) read (value, *) parse_tbm%E(ORB_S,parse_cur_type) + else if (parse_tbm%n_orbs(parse_cur_type) == 4) then + parse_tbm%n_orb_sets(parse_cur_type) = 2 + parse_tbm%orb_set_type(1,parse_cur_type) = ORB_S + parse_tbm%orb_set_type(2,parse_cur_type) = ORB_P + call QUIP_FoX_get_value(attributes, "E_s", value, status); + if (status == 0) read (value, *) parse_tbm%E(ORB_S,parse_cur_type) + call QUIP_FoX_get_value(attributes, "E_p", value, status); + if (status == 0) read (value, *) parse_tbm%E(ORB_P,parse_cur_type) + else + call system_abort("TBModel_Bowler_read_params_xml can only do Bowler with s or sp") + endif + + call QUIP_FoX_get_value(attributes, "n_elecs", value, status); + if (status == 0) read (value, *) parse_tbm%n_elecs(parse_cur_type) + + if (allocated(parse_tbm%type_of_atomic_num)) deallocate(parse_tbm%type_of_atomic_num) + allocate(parse_tbm%type_of_atomic_num(maxval(parse_tbm%atomic_num(:)))) + parse_tbm%type_of_atomic_num(:) = 0 + do ti=1, parse_tbm%n_types + if (parse_Tbm%atomic_num(ti) > 0) & + parse_tbm%type_of_atomic_num(parse_tbm%atomic_num(ti)) = ti + end do + + parse_cur_type = parse_cur_type + 1 + + elseif (parse_in_tbm .and. name == 'defaults') then + + call QUIP_FoX_get_value(attributes, "fermi_e", value, status) + if (status == 0) then + parse_tbm%has_default_fermi_e = .true. + read (value, *) parse_tbm%default_fermi_e + endif + call QUIP_FoX_get_value(attributes, "fermi_T", value, status) + if (status == 0) then + parse_tbm%has_default_fermi_T = .true. + read (value, *) parse_tbm%default_fermi_T + endif + call QUIP_FoX_get_value(attributes, "band_width", value, status) + if (status == 0) then + parse_tbm%has_default_band_width = .true. + read (value, *) parse_tbm%default_band_width + endif + call QUIP_FoX_get_value(attributes, "k_density", value, status) + if (status == 0) then + parse_tbm%has_default_k_density = .true. + read (value, *) parse_tbm%default_k_density + endif + + elseif (parse_in_tbm .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "Z1", value, status); + if (status == 0) read (value, *) Zi + call QUIP_FoX_get_value(attributes, "Z2", value, status); + if (status == 0) read (value, *) Zj + + ti = get_type(parse_tbm%type_of_atomic_num,Zi) + tj = get_type(parse_tbm%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "rc", value, status); + if (status == 0) read (value, *) parse_tbm%rc(ti,tj) + call QUIP_FoX_get_value(attributes, "r0", value, status); + if (status == 0) read (value, *) parse_tbm%r0(ti,tj) + call QUIP_FoX_get_value(attributes, "n", value, status); + if (status == 0) read (value, *) parse_tbm%n(ti,tj) + call QUIP_FoX_get_value(attributes, "nc", value, status); + if (status == 0) read (value, *) parse_tbm%nc(ti,tj) + call QUIP_FoX_get_value(attributes, "dc", value, status); + if (status == 0) read (value, *) parse_tbm%dc(ti,tj) + call QUIP_FoX_get_value(attributes, "m", value, status); + if (status == 0) read (value, *) parse_tbm%m(ti,tj) + call QUIP_FoX_get_value(attributes, "mc", value, status); + if (status == 0) read (value, *) parse_tbm%mc(ti,tj) + + call QUIP_FoX_get_value(attributes, "H_sss", value, status); + if (status == 0) read (value, *) parse_tbm%H_coeff(SK_SSS,ti,tj) + call QUIP_FoX_get_value(attributes, "H_sps", value, status); + if (status == 0) read (value, *) parse_tbm%H_coeff(SK_SPS,ti,tj) + call QUIP_FoX_get_value(attributes, "H_pps", value, status); + if (status == 0) read (value, *) parse_tbm%H_coeff(SK_PPS,ti,tj) + call QUIP_FoX_get_value(attributes, "H_ppp", value, status); + if (status == 0) read (value, *) parse_tbm%H_coeff(SK_PPP,ti,tj) + call QUIP_FoX_get_value(attributes, "Vrep", value, status); + if (status == 0) read (value, *) parse_tbm%Vrep(ti,tj) + + if (ti /= tj) then + parse_tbm%rc(tj,ti) = parse_tbm%rc(ti,tj) + parse_tbm%r0(tj,ti) = parse_tbm%r0(ti,tj) + parse_tbm%n(tj,ti) = parse_tbm%n(ti,tj) + parse_tbm%nc(tj,ti) = parse_tbm%nc(ti,tj) + parse_tbm%dc(tj,ti) = parse_tbm%dc(ti,tj) + parse_tbm%m(tj,ti) = parse_tbm%m(ti,tj) + parse_tbm%mc(tj,ti) = parse_tbm%mc(ti,tj) + parse_tbm%H_coeff(SK_SSS:SK_PPP,tj,ti) = parse_tbm%H_coeff(SK_SSS:SK_PPP,ti,tj) + parse_tbm%Vrep(tj,ti) = parse_tbm%Vrep(ti,tj) + + call QUIP_FoX_get_value(attributes, "H_pss", value, status); + if (status == 0) read (value, *) parse_tbm%H_coeff(SK_SPS,tj,ti) + end if + endif + +end subroutine TBM_startElement_handler + +subroutine TBM_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (name == 'Bowler_params') then + parse_in_tbm = .false. + endif + +end subroutine TBM_endElement_handler + +subroutine TBModel_Bowler_read_params_xml(this, param_str) + type(TBModel_Bowler), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_tbm = .false. + parse_matched_label = .false. + parse_tbm => this + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = TBM_startElement_handler, & + endElement_handler = TBM_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types <= 0) call system_abort("TBModel_Bowler_read_params_xml couldn't find any types defined") + + call TBModel_Bowler_fix_tails(this) + +end subroutine TBModel_Bowler_read_params_xml +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! type(inoutput), pointer :: in +! +! integer ti, tj, Zi, Zj, tt +! +! integer status +! type(dictionary_t) :: attributes +! type(xml_t) :: fxml +! character(len=1024) :: value +! integer :: ndata +! character(len=10240) :: pcdata +! +! if (present(from_io)) then +! in => from_io +! else +! allocate(in) +! call Initialise(in, trim(bowler_default_file), INPUT) +! endif +! +! call open_xmlfile(in%unit, fxml, status) +!! call enable_debug(sax=.true.) +! if (status /= 0) call system_abort('TBModel_Bowler_read_params_xml Cannot open xml file') +! +! call rewind_xmlfile(fxml) +! +! call get_node(fxml, path='//Bowler_params', attributes=attributes, status=status) +! if (status /= 0) call system_abort('TBModel_Bowler_read_params_xml Cannot find /Bowler_params/header') +! call QUIP_FoX_get_value(attributes, "name", value, status); +! if (status == 0) read (value, *) this%name +! +! call QUIP_FoX_get_value(attributes, "n_types", value, status); +! if (status == 0) read (value, *) this%n_types +! call QUIP_FoX_get_value(attributes, "tailx0", value, status); +! if (status == 0) read (value, *) this%tailx0 +! call QUIP_FoX_get_value(attributes, "cutoff", value, status); +! if (status == 0) read (value, *) this%cutoff +! +! allocate(this%atomic_num(this%n_types)) +! allocate(this%n_orbs(this%n_types)) +! allocate(this%n_elecs(this%n_types)) +! allocate(this%n_orb_sets(this%n_types)) +! allocate(this%orb_set_type(max_n_orb_sets,this%n_types)) +! allocate(this%E(max_n_orb_sets,this%n_types)) +! +! call rewind_xmlfile(fxml) +! +! !! read bowler params +! do ti=1, this%n_types +! call get_node(fxml, path='//Bowler_params/per_type_data', attributes=attributes, status=status) +! if (status /= 0) call system_abort("Couldn't find per_type_data for " // str(ti)) +! +! call QUIP_FoX_get_value(attributes, "Z", value, status); +! if (status == 0) read (value, *) this%atomic_num(ti) +! +! call QUIP_FoX_get_value(attributes, "n_orbs", value, status); +! if (status == 0) read (value, *) this%n_orbs(ti) +! if (this%n_orbs(ti) == 1) then +! this%n_orb_sets(ti) = 1 +! this%orb_set_type(1,ti) = ORB_S +! call QUIP_FoX_get_value(attributes, "E_s", value, status); +! if (status == 0) read (value, *) this%E(ORB_S,ti) +! else if (this%n_orbs(ti) == 4) then +! this%n_orb_sets(ti) = 2 +! this%orb_set_type(1,ti) = ORB_S +! this%orb_set_type(2,ti) = ORB_P +! call QUIP_FoX_get_value(attributes, "E_s", value, status); +! if (status == 0) read (value, *) this%E(ORB_S,ti) +! call QUIP_FoX_get_value(attributes, "E_p", value, status); +! if (status == 0) read (value, *) this%E(ORB_P,ti) +! else +! call system_abort("TBModel_Bowler_read_params_xml can only do Bowler with s or sp") +! endif +! +! call QUIP_FoX_get_value(attributes, "n_elecs", value, status); +! if (status == 0) read (value, *) this%n_elecs(ti) +! +! end do +! +! allocate(this%type_of_atomic_num(maxval(this%atomic_num(:)))) +! this%type_of_atomic_num(:) = 0 +! do ti=1, this%n_types +! this%type_of_atomic_num(this%atomic_num(ti)) = ti +! end do +! +! allocate(this%H_coeff(4, this%n_types, this%n_types)) +! allocate(this%Vrep(this%n_types, this%n_types)) +! allocate(this%rc(this%n_types, this%n_types)) +! allocate(this%r0(this%n_types, this%n_types)) +! allocate(this%n(this%n_types, this%n_types)) +! allocate(this%nc(this%n_types, this%n_types)) +! allocate(this%dc(this%n_types, this%n_types)) +! allocate(this%m(this%n_types, this%n_types)) +! allocate(this%mc(this%n_types, this%n_types)) +! call rewind_xmlfile(fxml) +! +! this%H_coeff = 0.0_dp +! this%Vrep = 0.0_dp +! this%rc = 1.0_dp +! this%r0 = 0.0_dp +! this%n = 0.0_dp +! this%nc = 0.0_dp +! this%dc = 1.0_dp +! this%m = 0.0_dp +! this%mc = 0.0_dp +! +! do tt=1, (this%n_types*(this%n_types+1))/2 +! call get_node(fxml, path='//Bowler_params/per_pair_data', attributes=attributes, status=status) +! if (status /= 0) call system_abort("Couldn't find per_pair_data for " // trim(str(ti)) // ' ' // trim(str(tj))) +! +! call QUIP_FoX_get_value(attributes, "Z1", value, status); +! if (status == 0) read (value, *) Zi +! call QUIP_FoX_get_value(attributes, "Z2", value, status); +! if (status == 0) read (value, *) Zj +! +! ti = get_type(this%type_of_atomic_num,Zi) +! tj = get_type(this%type_of_atomic_num,Zj) +! +! call QUIP_FoX_get_value(attributes, "rc", value, status); +! if (status == 0) read (value, *) this%rc(ti,tj) +! call QUIP_FoX_get_value(attributes, "r0", value, status); +! if (status == 0) read (value, *) this%r0(ti,tj) +! call QUIP_FoX_get_value(attributes, "n", value, status); +! if (status == 0) read (value, *) this%n(ti,tj) +! call QUIP_FoX_get_value(attributes, "nc", value, status); +! if (status == 0) read (value, *) this%nc(ti,tj) +! call QUIP_FoX_get_value(attributes, "dc", value, status); +! if (status == 0) read (value, *) this%dc(ti,tj) +! call QUIP_FoX_get_value(attributes, "m", value, status); +! if (status == 0) read (value, *) this%m(ti,tj) +! call QUIP_FoX_get_value(attributes, "mc", value, status); +! if (status == 0) read (value, *) this%mc(ti,tj) +! +! call QUIP_FoX_get_value(attributes, "H_sss", value, status); +! if (status == 0) read (value, *) this%H_coeff(SK_SSS,ti,tj) +! call QUIP_FoX_get_value(attributes, "H_sps", value, status); +! if (status == 0) read (value, *) this%H_coeff(SK_SPS,ti,tj) +! call QUIP_FoX_get_value(attributes, "H_pps", value, status); +! if (status == 0) read (value, *) this%H_coeff(SK_PPS,ti,tj) +! call QUIP_FoX_get_value(attributes, "H_ppp", value, status); +! if (status == 0) read (value, *) this%H_coeff(SK_PPP,ti,tj) +! call QUIP_FoX_get_value(attributes, "Vrep", value, status); +! if (status == 0) read (value, *) this%Vrep(ti,tj) +! +! if (ti /= tj) then +! this%rc(tj,ti) = this%rc(ti,tj) +! this%r0(tj,ti) = this%r0(ti,tj) +! this%n(tj,ti) = this%n(ti,tj) +! this%nc(tj,ti) = this%nc(ti,tj) +! this%dc(tj,ti) = this%dc(ti,tj) +! this%m(tj,ti) = this%m(ti,tj) +! this%mc(tj,ti) = this%mc(ti,tj) +! this%H_coeff(SK_SSS:SK_PPP,tj,ti) = this%H_coeff(SK_SSS:SK_PPP,ti,tj) +! this%Vrep(tj,ti) = this%Vrep(ti,tj) +! +! call QUIP_FoX_get_value(attributes, "H_pss", value, status); +! if (status == 0) read (value, *) this%H_coeff(SK_SPS,tj,ti) +! endif +! end do +! +! call TBModel_Bowler_fix_tails(this) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine TBModel_Bowler_fix_tails(this) + type(TBModel_Bowler), intent(inout) :: this + + integer ti, tj + real(dp) :: x(2), y(2), yd1, yd2 + + x(1) = this%tailx0 + x(2) = this%cutoff + y(2) = 0.0_dp + yd2 = 0.0_dp + + allocate(this%H_tail_spline(this%n_types, this%n_types)) + allocate(this%Vrep_tail_spline(this%n_types, this%n_types)) + + do ti=1, this%n_types + do tj=1, this%n_types + y(1) = TBModel_Bowler_dist_scaling(x(1), this%r0(ti,tj), this%n(ti,tj), this%rc(ti,tj), this%nc(ti,tj)) + yd1 = TBModel_Bowler_dist_scaling_deriv(x(1), this%r0(ti,tj), this%n(ti,tj), this%rc(ti,tj), this%nc(ti,tj)) + call initialise(this%H_tail_spline(ti,tj), x, y, yd1, yd2) + + y(1) = TBModel_Bowler_dist_scaling(x(1), this%r0(ti,tj), this%m(ti,tj), this%dc(ti,tj), this%mc(ti,tj)) + yd1 = TBModel_Bowler_dist_scaling_deriv(x(1), this%r0(ti,tj), this%m(ti,tj), this%dc(ti,tj), this%mc(ti,tj)) + call initialise(this%Vrep_tail_spline(ti,tj), x, y, yd1, yd2) + end do + end do + +end subroutine TBModel_Bowler_fix_tails + +subroutine TBModel_Bowler_Print(this,file) + type(TBModel_Bowler), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer:: ti, tj + + if(this%n_types == 0) call System_Abort('TBModel_Bowler_Print: TBModel_Bowler structure not initialised') + + call Print('TBModel_Bowler Structure:', file=file) + + !! print bowler params + call Print ("TBModel_Bowler tailx0 " // this%tailx0 // " cutoff " // this%cutoff, file=file) + do ti=1, this%n_types + call Print ("TBModel_Bowler type " // ti // " Z " // this%atomic_num(ti) // " n_orbs " // this%n_orbs(ti) // & + " n_elecs " // this%n_elecs(ti), file=file) + if (this%n_orb_sets(ti) == 1) then + call Print ("TBModel_Bowler E " // this%E(1,ti), file=file) + else + call Print ("TBModel_Bowler E " // this%E(1:2,ti), file=file) + endif + end do + + call verbosity_push_decrement() + do ti=1, this%n_types + do tj=1, this%n_types + call Print ("TBModel_Bowler interaction " // & + ti // " " // tj // " Z " // this%atomic_num(ti) // " " // this%atomic_num(tj), file=file) + + call Print ("TBModel_Bowler r0 " // this%r0(ti,tj), file=file) + + call Print ("TBModel_Bowler SK " // this%H_coeff(:,ti,tj), file=file) + call Print ("TBModel_Bowler H scaling rc n nc " // & + this%rc(ti,tj) // " " // this%n(ti,tj) // " " // this%nc(ti,tj), file=file) + call Print (this%H_tail_spline(ti,tj), file=file) + + call Print ("TBModel_Bowler Vrep " // this%Vrep(ti,tj), file=file) + call Print ("TBModel_Bowler Vrep scaling dc m mc " // & + this%dc(ti,tj) // " " // this%m(ti,tj) // this%mc(ti,tj), file=file) + call Print (this%Vrep_tail_spline(ti,tj), file=file) + + end do + end do + call verbosity_pop() + +end subroutine TBModel_Bowler_Print + +function TBModel_Bowler_n_orbs_of_Z(this, Z) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_Bowler_n_orbs_of_Z + + TBModel_Bowler_n_orbs_of_Z = this%n_orbs(get_type(this%type_of_atomic_num,Z)) +end function TBModel_Bowler_n_orbs_of_Z + +function TBModel_Bowler_n_orb_sets_of_Z(this, Z) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_Bowler_n_orb_sets_of_Z + + TBModel_Bowler_n_orb_sets_of_Z = this%n_orb_sets(get_type(this%type_of_atomic_num,Z)) +end function TBModel_Bowler_n_orb_sets_of_Z + +function TBModel_Bowler_n_orbs_of_orb_set_of_Z(this, Z, i_set) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_Bowler_n_orbs_of_orb_set_of_Z + + TBModel_Bowler_n_orbs_of_orb_set_of_Z = N_ORBS_OF_SET(this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z))) + +end function TBModel_Bowler_n_orbs_of_orb_set_of_Z + +function TBModel_Bowler_orb_type_of_orb_set_of_Z(this, Z, i_set) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_Bowler_orb_type_of_orb_set_of_Z + + TBModel_Bowler_orb_type_of_orb_set_of_Z = this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z)) + +end function TBModel_Bowler_orb_type_of_orb_set_of_Z + +function TBModel_Bowler_n_elecs_of_Z(this, Z) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: Z + real(dp) TBModel_Bowler_n_elecs_of_Z + + TBModel_Bowler_n_elecs_of_Z = this%n_elecs(get_type(this%type_of_atomic_num,Z)) +end function TBModel_Bowler_n_elecs_of_Z + +subroutine TBModel_Bowler_get_HS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, b_H, b_S, i_mag) + type(TBModel_Bowler), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, at_j + real(dp), intent(in) :: dv_hat(3), dv_mag + real(dp), intent(out) :: b_H(:,:) + real(dp), intent(out) :: b_S(:,:) + integer, intent(in), optional :: i_mag + + integer ti, tj, is, js, i_set, j_set + integer i, j + real(dp) SK_frad_H(N_SK) + real(dp) dv_hat_sq(3) + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + tj = get_type(this%type_of_atomic_num,at%Z(at_j)) + + b_S = 0.0_dp + + if (dv_mag .feq. 0.0_dp) then + b_H = 0.0_dp + + i = 1 + do i_set = 1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + b_H(i,i) = onsite_function(this, ti, this%orb_set_type(i_set,ti)) + b_S(i,i) = 1.0_dp + i = i + 1 + end do + end do + + else + + dv_hat_sq = dv_hat**2 + + i = 1 + do i_set=1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + j = 1 + do j_set=1, this%n_orb_sets(tj) + call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H) + do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) + + b_H(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H) + j = j + 1 + end do + end do + i = i + 1 + end do + end do + endif + +end subroutine TBModel_Bowler_get_HS_blocks + +subroutine TBModel_Bowler_get_dHS_masks(this, at, at_ind, d_mask, od_mask) + type(TBModel_Bowler), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_ind + logical, intent(out), optional :: d_mask(:), od_mask(:) + + if (at_ind < 0) then + if (present(d_mask)) d_mask = .true. + if (present(od_mask)) od_mask = .true. + else + if (present(d_mask)) d_mask = .false. + if (present(od_mask)) then + od_mask = .false. + od_mask(at_ind) = .true. + endif + endif +end subroutine TBModel_Bowler_get_dHS_masks + +function TBModel_Bowler_get_dHS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) + type(TBModel_Bowler), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, at_j + real(dp), intent(in) :: dv_hat(3), dv_mag + integer, intent(in) :: at_ind + real(dp), intent(out) :: b_dH(:,:,:) + real(dp), intent(out) :: b_dS(:,:,:) + integer, intent(in), optional :: i_mag + logical :: TBModel_Bowler_get_dHS_blocks + + integer ti, tj, is, js, i_set, j_set + integer i, j + real(dp) SK_frad_H(N_SK) + real(dp) SK_dfrad_H(N_SK) + real(dp) dv_hat_sq(3) + real(dp) virial_outerprod_fac + + if ((at_ind > 0 .and. at_i /= at_ind .and. at_j /= at_ind) .or. & + (at_ind > 0 .and. at_i == at_j) .or. & + (dv_mag > this%cutoff) .or. & + (dv_mag .feq. 0.0_dp)) then + TBModel_Bowler_get_dHS_blocks = .false. + return + endif + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + tj = get_type(this%type_of_atomic_num,at%Z(at_j)) + + b_dS = 0.0_dp + + dv_hat_sq = dv_hat**2 + + + i = 1 + do i_set=1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + j = 1 + do j_set=1, this%n_orb_sets(tj) + call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H) + call dradial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_dfrad_H) + do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) + + if (at_ind > 0) then + virial_outerprod_fac = 1.0_dp + else + virial_outerprod_fac = -dv_mag*dv_hat(-at_ind) + end if + b_dH(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & + this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H, SK_dfrad_H)*virial_outerprod_fac + j = j + 1 + end do + end do + i = i + 1 + end do + end do + + if (at_ind == at_j) b_dH = -b_dH + + TBModel_Bowler_get_dHS_blocks = .true. + return + +end function TBModel_Bowler_get_dHS_blocks + +subroutine radial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, is, js, f_H) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dv_mag + integer, intent(in) :: orb_set_type_i, orb_set_type_j + integer, intent(in) :: is, js + real(dp), intent(out) :: f_H(N_SK) + + if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then + f_H(SK_SSS) = calc_H_coeff(this, SK_SSS, dv_mag, ti, tj) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then + f_H(SK_SPS) = calc_H_coeff(this, SK_SPS, dv_mag, ti, tj) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then + f_H(SK_SPS) = -calc_H_coeff( this, SK_SPS, dv_mag, tj, ti) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then + f_H(SK_PPS) = calc_H_coeff(this, SK_PPS, dv_mag, ti, tj) + f_H(SK_PPP) = calc_H_coeff(this, SK_PPP, dv_mag, ti, tj) + else + call system_abort("TBModel_Bowler radial_functions got invalide orb_set_type "//orb_set_type_i//" or "//orb_set_type_j) + endif +end subroutine radial_functions + +subroutine dradial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, is, js, f_dH) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dv_mag + integer, intent(in) :: orb_set_type_i, orb_set_type_j + integer, intent(in) :: is, js + real(dp), intent(out) :: f_dH(N_SK) + + if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then + f_dH(SK_SSS) = calc_H_coeff_deriv(this, SK_SSS, dv_mag, ti, tj) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then + f_dH(SK_SPS) = calc_H_coeff_deriv(this, SK_SPS, dv_mag, ti, tj) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then + f_dH(SK_SPS) = -calc_H_coeff_deriv( this, SK_SPS, dv_mag, tj, ti) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then + f_dH(SK_PPS) = calc_H_coeff_deriv(this, SK_PPS, dv_mag, ti, tj) + f_dH(SK_PPP) = calc_H_coeff_deriv(this, SK_PPP, dv_mag, ti, tj) + else + call system_abort("TBModel_Bowler dradial_functions got invalide orb_set_type "//orb_set_type_i//" or "//orb_set_type_j) + endif +end subroutine dradial_functions + +function TBModel_Bowler_calc_H_coeff(this, sk_ind, dist, ti, tj) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: sk_ind + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_Bowler_calc_H_coeff + + TBModel_Bowler_calc_H_coeff = this%H_coeff(sk_ind, ti, tj)* & + TBModel_Bowler_H_dist_func(this, dist, ti, tj) + +end function TBModel_Bowler_calc_H_coeff + +function TBModel_Bowler_calc_H_coeff_deriv(this, sk_ind, dist, ti, tj) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: sk_ind + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_Bowler_calc_H_coeff_deriv + + TBModel_Bowler_calc_H_coeff_deriv = this%H_coeff(sk_ind, ti, tj)* & + TBModel_Bowler_H_dist_func_deriv(this, dist, ti, tj) + +end function TBModel_Bowler_calc_H_coeff_deriv + +function TBModel_Bowler_H_dist_func(this, dist, ti, tj) + type(TBModel_Bowler), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_Bowler_H_dist_func + + if (dist <= this%cutoff) then + if (dist <= this%tailx0) then + TBModel_Bowler_H_dist_func = TBModel_Bowler_dist_scaling(dist, & + this%r0(ti,tj), this%n(ti,tj), this%rc(ti, tj), this%nc(ti, tj)) + else + TBModel_Bowler_H_dist_func = spline_value(this%H_tail_spline(ti,tj), dist) + endif + else + TBModel_Bowler_H_dist_func = 0.0_dp + endif +end function TBModel_Bowler_H_dist_func + +function TBModel_Bowler_H_dist_func_deriv(this, dist, ti, tj) + type(TBModel_Bowler), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_Bowler_H_dist_func_deriv + + if (dist <= this%cutoff) then + if (dist <= this%tailx0) then + TBModel_Bowler_H_dist_func_deriv = TBModel_Bowler_dist_scaling_deriv(dist, & + this%r0(ti,tj), this%n(ti,tj), this%rc(ti, tj), this%nc(ti, tj)) + else + TBModel_Bowler_H_dist_func_deriv = spline_deriv(this%H_tail_spline(ti,tj), dist) + endif + else + TBModel_Bowler_H_dist_func_deriv = 0.0_dp + endif +end function TBModel_Bowler_H_dist_func_deriv + +function TBModel_Bowler_Vrep_dist_func(this, dist, ti, tj) + type(TBModel_Bowler), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_Bowler_Vrep_dist_func + + if (dist <= this%cutoff) then + if (dist <= this%tailx0) then + TBModel_Bowler_Vrep_dist_func = TBModel_Bowler_dist_scaling(dist, & + this%r0(ti,tj), this%m(ti,tj), this%dc(ti, tj), this%mc(ti, tj)) + else + TBModel_Bowler_Vrep_dist_func = spline_value(this%Vrep_tail_spline(ti,tj), dist) + endif + else + TBModel_Bowler_Vrep_dist_func = 0.0_dp + endif +end function TBModel_Bowler_Vrep_dist_func + +function TBModel_Bowler_Vrep_dist_func_deriv(this, dist, ti, tj) + type(TBModel_Bowler), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_Bowler_Vrep_dist_func_deriv + + if (dist <= this%cutoff) then + if (dist <= this%tailx0) then + TBModel_Bowler_Vrep_dist_func_deriv = TBModel_Bowler_dist_scaling_deriv(dist, & + this%r0(ti,tj), this%m(ti,tj), this%dc(ti, tj), this%mc(ti, tj)) + else + TBModel_Bowler_Vrep_dist_func_deriv = spline_deriv(this%Vrep_tail_spline(ti,tj), dist) + endif + else + TBModel_Bowler_Vrep_dist_func_deriv = 0.0_dp + endif +end function TBModel_Bowler_Vrep_dist_func_deriv + +function TBModel_Bowler_dist_scaling(r, r0, n, rc, nc) + real(dp), intent(in) :: r, r0, n, rc, nc + real(dp) :: TBModel_Bowler_dist_scaling + + TBModel_Bowler_dist_scaling = (r0/r)**n * exp(n* ((r0/rc)**nc - (r/rc)**nc)) +end function TBModel_Bowler_dist_scaling + +function TBModel_Bowler_dist_scaling_deriv(r, r0, n, rc, nc) + real(dp), intent(in) :: r, r0, n, rc, nc + real(dp) :: TBModel_Bowler_dist_scaling_deriv + + real(dp) tmp1, tmp2 + + tmp1 = (r0/r)**n + tmp2 = exp(n*((r0/rc)**nc - (r/rc)**nc)) + + TBModel_Bowler_dist_scaling_deriv = n*tmp1/(-r)*tmp2 + tmp1*tmp2*(-n)*nc*((r/rc)**nc)/r +end function TBModel_Bowler_dist_scaling_deriv + +function onsite_function(this, ti, orb_set_type) + type(TBModel_Bowler), intent(in) :: this + integer, intent(in) :: ti, orb_set_type + real(dp) :: onsite_function + + onsite_function = this%E(orb_set_type, ti) + +end function onsite_function + +function TBModel_Bowler_get_local_rep_E(this, at, i) + type(TBModel_Bowler), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: TBModel_Bowler_get_local_rep_E + + real(dp) E, dist + integer ji, j, ti, tj + + TBModel_Bowler_get_local_rep_E = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + E = this%Vrep(ti,tj) * TBModel_Bowler_Vrep_dist_func(this, dist, ti, tj) + TBModel_Bowler_get_local_rep_E = TBModel_Bowler_get_local_rep_E + E/2.0_dp + end do + +end function TBModel_Bowler_get_local_rep_E + +function TBModel_Bowler_get_local_rep_E_force(this, at, i) result(force) + type(TBModel_Bowler), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: force(3,at%N) + + real(dp) dE_dr, dist, dv_hat(3) + integer ji, j, ti, tj + + force = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist, cosines = dv_hat) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + dE_dr = this%Vrep(ti,tj) * TBModel_Bowler_Vrep_dist_func_deriv(this, dist, ti, tj) + force(:,i) = force(:,i) + dE_dr*dv_hat(:)/2.0_dp + force(:,j) = force(:,j) - dE_dr*dv_hat(:)/2.0_dp + end do + +end function TBModel_Bowler_get_local_rep_E_force + +function TBModel_Bowler_get_local_rep_E_virial(this, at, i) result(virial) + type(TBModel_Bowler), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: virial(3,3) + + real(dp) dE_dr, dist, dv_hat(3) + integer ji, j, ti, tj + + virial = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist, cosines = dv_hat) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + dE_dr = this%Vrep(ti,tj) * TBModel_Bowler_Vrep_dist_func_deriv(this, dist, ti, tj) + virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist / 2.0_dp + end do + +end function TBModel_Bowler_get_local_rep_E_virial + +end module TBModel_Bowler_module diff --git a/src/Potentials/TBModel_DFTB.F90 b/src/Potentials/TBModel_DFTB.F90 new file mode 100644 index 0000000000..fca8de2a00 --- /dev/null +++ b/src/Potentials/TBModel_DFTB.F90 @@ -0,0 +1,1143 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X TBModel_DFTB module +!X +!% Calculate energies using DFTB tight-binding model +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +module TBModel_DFTB_module + +use system_module, only : dp, inoutput, print, PRINT_NORMAL, PRINT_ALWAYS, PRINT_NERD, current_verbosity, increase_stack, system_abort, verbosity_push_decrement, verbosity_pop +use units_module +use extendable_str_module +use linearalgebra_module +use spline_module +use dictionary_module +use paramreader_module +use atoms_module + +use TB_Common_module +use QUIP_Common_module + +implicit none +private + +include 'TBModel_interface.h' + +public :: TBModel_DFTB +type TBModel_DFTB + integer :: n_types = 0 + character(len=STRING_LENGTH) label + + real(dp) :: cutoff = 0.0_dp + logical :: is_orthogonal = .false. + + integer, allocatable :: type_of_atomic_num(:) + integer, allocatable :: n_orbs(:), n_elecs(:), n_orb_sets(:), orb_set_type(:,:) + integer, allocatable :: atomic_num(:) + + !! DFTB parameters + real(dp), allocatable:: E(:,:) + + real(dp), allocatable:: SK_cutoff(:,:), Vrep_cutoff(:,:) + + type(spline), allocatable :: H_spline(:,:,:), S_spline(:,:,:), Vrep_spline(:,:) + + logical :: has_default_fermi_E = .false., has_default_fermi_T = .true., has_default_band_width = .false., has_default_k_density = .false. + real(dp) :: default_fermi_E, default_fermi_T = 0.001_dp, default_band_width, default_k_density + +end type TBModel_DFTB + +type(extendable_str), private, save :: parse_cur_data +logical, private :: parse_in_tbm, parse_matched_label +logical :: parse_in_H_spline, parse_in_S_spline, parse_in_Vrep_spline +integer :: parse_cur_type_i, parse_cur_type_j, parse_cur_point_i +type (TBModel_DFTB), pointer :: parse_tbm +real(dp), allocatable :: parse_SK_r(:), parse_H_vals(:,:), parse_S_vals(:,:) +real(dp), allocatable :: parse_Vrep_r(:), parse_Vrep_vals(:) + +interface Initialise + module procedure TBModel_DFTB_Initialise_str +end interface Initialise + +interface Finalise + module procedure TBModel_DFTB_Finalise +end interface Finalise + +interface Print + module procedure TBModel_DFTB_Print +end interface Print + +interface n_orbs_of_Z + module procedure TBModel_DFTB_n_orbs_of_Z +end interface n_orbs_of_Z + +interface n_orb_sets_of_Z + module procedure TBModel_DFTB_n_orb_sets_of_Z +end interface n_orb_sets_of_Z + +interface n_orbs_of_orb_set_of_Z + module procedure TBModel_DFTB_n_orbs_of_orb_set_of_Z +end interface n_orbs_of_orb_set_of_Z + +interface orb_type_of_orb_set_of_Z + module procedure TBModel_DFTB_orb_type_of_orb_set_of_Z +end interface orb_type_of_orb_set_of_Z + +interface n_elecs_of_Z + module procedure TBModel_DFTB_n_elecs_of_Z +end interface n_elecs_of_Z + +interface get_HS_blocks + module procedure TBModel_DFTB_get_HS_blocks +end interface get_HS_blocks + +interface get_dHS_masks + module procedure TBModel_DFTB_get_dHS_masks +end interface get_dHS_masks + +interface get_dHS_blocks + module procedure TBModel_DFTB_get_dHS_blocks +end interface get_dHS_blocks + +interface get_local_rep_E + module procedure TBModel_DFTB_get_local_rep_E +end interface get_local_rep_E + +interface get_local_rep_E_force + module procedure TBModel_DFTB_get_local_rep_E_force +end interface get_local_rep_E_force + +interface get_local_rep_E_virial + module procedure TBModel_DFTB_get_local_rep_E_virial +end interface get_local_rep_E_virial + +contains + +subroutine TBModel_DFTB_Initialise_str(this, args_str, param_str) + type(TBModel_DFTB), intent(inout) :: this + character(len=*) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_DFTB_Initialise_str args_str')) then + call system_abort("TBModel_DFTB_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call TBModel_DFTB_read_params_xml(this, param_str) +end subroutine TBModel_DFTB_Initialise_str + +subroutine TBModel_DFTB_Finalise(this) + type(TBModel_DFTB), intent(inout) :: this + + integer ti, tj, i + + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%n_orbs)) deallocate(this%n_orbs) + if (allocated(this%n_elecs)) deallocate(this%n_elecs) + if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) + if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + + if (allocated(this%E)) deallocate(this%E) + if (allocated(this%SK_cutoff)) deallocate(this%SK_cutoff) + if (allocated(this%Vrep_cutoff)) deallocate(this%Vrep_cutoff) + + if (allocated(this%H_spline)) then + do ti=1, size(this%H_spline,2) + do tj=1, size(this%H_spline,3) + do i=1, size(this%H_spline,1) + call finalise(this%H_spline(i,ti,tj)) + end do + end do + end do + deallocate(this%H_spline) + endif + if (allocated(this%S_spline)) then + do ti=1, size(this%S_spline,2) + do tj=1, size(this%S_spline,3) + do i=1, size(this%S_spline,1) + call finalise(this%S_spline(i,ti,tj)) + end do + end do + end do + deallocate(this%S_spline) + endif + if (allocated(this%Vrep_spline)) then + do ti=1, size(this%Vrep_spline,1) + do tj=1, size(this%Vrep_spline,2) + call finalise(this%Vrep_spline(ti,tj)) + end do + end do + deallocate(this%Vrep_spline) + endif + + this%n_types = 0 + this%label = '' +end subroutine TBModel_DFTB_Finalise + +subroutine TBM_characters_handler(in) + character(len=*), intent(in) :: in + + if (parse_in_tbm) then + call concat(parse_cur_data, in, keep_lf=.false.) + endif +end subroutine + +subroutine TBM_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: value + + integer max_n_orb_sets, SK_npts, Vrep_npts + integer ti, tj + + call zero(parse_cur_data) + + if (name == 'DFTB_params') then ! new DFTB stanza + call print("DFTB_params startElement_handler", PRINT_NERD) + + if (parse_in_tbm) & + call system_abort("IPModel_startElement_handler entered DFTB_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) then + call print("DFTB_params startElement_handler bailing because we already matched our label", PRINT_NERD) + return ! we already found an exact match for this label + endif + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + call print("DFTB_params startElement_handler found xml label '"//trim(value)//"'", PRINT_NERD) + + if (len(trim(parse_tbm%label)) > 0) then ! we were passed in a label + call print("DFTB_params startElement_handler was passed in label '"//trim(parse_tbm%label)//"'", PRINT_NERD) + if (value == parse_tbm%label) then ! exact match + call print("DFTB_params startElement_handler got label exact match", PRINT_NERD) + parse_matched_label = .true. + parse_in_tbm = .true. + else ! no match + call print("DFTB_params startElement_handler got label didn't match", PRINT_NERD) + parse_in_tbm = .false. + endif + else ! no label passed in + call print("DFTB_params startElement_handler was not passed in a label", PRINT_NERD) + parse_in_tbm = .true. + call print("DFTB_params startElement_handler was not passed in a label", PRINT_NERD) + endif + + call print("DFTB_params startElement_handler parse_in_tbm " // parse_in_tbm, PRINT_NERD) + + if (parse_in_tbm) then + call initialise(parse_cur_data) + if (parse_tbm%n_types /= 0) then + call print("DFTB_params startElement_handler finalising old data, restarting to parse new section", PRINT_NERD) + call finalise(parse_tbm) + endif + endif + + elseif (parse_in_tbm .and. name == 'defaults') then + + call QUIP_FoX_get_value(attributes, "fermi_e", value, status) + if (status == 0) then + parse_tbm%has_default_fermi_e = .true. + read (value, *) parse_tbm%default_fermi_e + endif + call QUIP_FoX_get_value(attributes, "fermi_T", value, status) + if (status == 0) then + parse_tbm%has_default_fermi_T = .true. + read (value, *) parse_tbm%default_fermi_T + endif + call QUIP_FoX_get_value(attributes, "band_width", value, status) + if (status == 0) then + parse_tbm%has_default_band_width = .true. + read (value, *) parse_tbm%default_band_width + endif + call QUIP_FoX_get_value(attributes, "k_density", value, status) + if (status == 0) then + parse_tbm%has_default_k_density = .true. + read (value, *) parse_tbm%default_k_density + endif + + elseif (parse_in_tbm .and. name == 'n_types') then + call QUIP_FoX_get_value(attributes, "v", value, status); + if (status == 0) read (value, *) parse_tbm%n_types + + allocate(parse_tbm%atomic_num(parse_tbm%n_types)) + parse_tbm%atomic_num = 0 + allocate(parse_tbm%n_orbs(parse_tbm%n_types)) + allocate(parse_tbm%n_elecs(parse_tbm%n_types)) + allocate(parse_tbm%n_orb_sets(parse_tbm%n_types)) + + allocate(parse_tbm%H_spline(10,parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%S_spline(10,parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%Vrep_spline(parse_tbm%n_types,parse_tbm%n_types)) + + allocate(parse_tbm%SK_cutoff(parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%Vrep_cutoff(parse_tbm%n_types,parse_tbm%n_types)) + + elseif (parse_in_tbm .and. name == 'cutoff') then + call QUIP_FoX_get_value(attributes, "v", value, status); + if (status == 0) read (value, *) parse_tbm%cutoff + parse_tbm%cutoff = parse_tbm%cutoff*BOHR + elseif (parse_in_tbm .and. name == 'max_n_orb_sets') then + call QUIP_FoX_get_value(attributes, "v", value, status); + if (status == 0) read (value, *) max_n_orb_sets + allocate(parse_tbm%orb_set_type(max_n_orb_sets,parse_tbm%n_types)) + allocate(parse_tbm%E(max_n_orb_sets,parse_tbm%n_types)) + elseif (parse_in_tbm .and. name == 'per_type_data') then + call QUIP_FoX_get_value(attributes, "type", value, status); + if (status == 0) read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_num", value, status); + if (status == 0) read (value, *) parse_tbm%atomic_num(ti) + call QUIP_FoX_get_value(attributes, "n_orbs", value, status); + if (status == 0) read (value, *) parse_tbm%n_orbs(ti) + call QUIP_FoX_get_value(attributes, "n_orb_sets", value, status); + if (status == 0) read (value, *) parse_tbm%n_orb_sets(ti) + call QUIP_FoX_get_value(attributes, "n_elecs", value, status); + if (status == 0) read (value, *) parse_tbm%n_elecs(ti) + + parse_cur_type_i = ti + parse_cur_type_j = ti + + if (allocated(parse_tbm%type_of_atomic_num)) deallocate(parse_tbm%type_of_atomic_num) + allocate(parse_tbm%type_of_atomic_num(maxval(parse_tbm%atomic_num(:)))) + parse_tbm%type_of_atomic_num(:) = 0 + do ti=1, parse_tbm%n_types + if (parse_tbm%atomic_num(ti) > 0) & + parse_tbm%type_of_atomic_num(parse_tbm%atomic_num(ti)) = ti + end do + + elseif (parse_in_tbm .and. name == 'per_pair_data') then + call QUIP_FoX_get_value(attributes, "type1", value, status); + if (status == 0) read (value, *) ti + call QUIP_FoX_get_value(attributes, "type2", value, status); + if (status == 0) read (value, *) tj + call QUIP_FoX_get_value(attributes, "SK_npts", value, status); + if (status == 0) read (value, *) SK_npts + call QUIP_FoX_get_value(attributes, "Vrep_npts", value, status); + if (status == 0) read (value, *) Vrep_npts + call QUIP_FoX_get_value(attributes, "SK_cutoff", value, status); + if (status == 0) read (value, *) parse_tbm%SK_cutoff(ti,tj) + parse_tbm%SK_cutoff(ti,tj) = parse_tbm%SK_cutoff(ti,tj)*BOHR + call QUIP_FoX_get_value(attributes, "Vrep_cutoff", value, status); + if (status == 0) read (value, *) parse_tbm%Vrep_cutoff(ti,tj) + parse_tbm%Vrep_cutoff(ti,tj) = parse_tbm%Vrep_cutoff(ti,tj)*BOHR + + allocate(parse_SK_r(SK_npts)) + allocate(parse_H_vals(10,SK_npts)) + allocate(parse_S_vals(10,SK_npts)) + allocate(parse_Vrep_r(Vrep_npts)) + allocate(parse_Vrep_vals(Vrep_npts)) + + parse_cur_type_i = ti + parse_cur_type_j = tj + + elseif (parse_in_tbm .and. name == 'H_spline') then + parse_in_H_spline = .true. + parse_cur_point_i = 1 + elseif (parse_in_tbm .and. name == 'S_spline') then + parse_in_S_spline = .true. + parse_cur_point_i = 1 + elseif (parse_in_tbm .and. name == 'Vrep_spline') then + parse_in_Vrep_spline = .true. + parse_cur_point_i = 1 + elseif (parse_in_tbm .and. name == 'point') then + if (parse_in_H_spline .or. parse_in_S_spline) then + call QUIP_FoX_get_value(attributes, "r", value, status); + if (status == 0) read (value, *) parse_SK_r(parse_cur_point_i) + parse_SK_r(parse_cur_point_i) = parse_SK_r(parse_cur_point_i) * BOHR + elseif (parse_in_Vrep_spline) then + call QUIP_FoX_get_value(attributes, "r", value, status); + if (status == 0) read (value, *) parse_Vrep_r(parse_cur_point_i) + parse_Vrep_r(parse_cur_point_i) = parse_Vrep_r(parse_cur_point_i) * BOHR + else + call system_abort('Found point in DFTB_params but not in H_spline, S_spline, or Vrep_spline') + endif + endif + +end subroutine TBM_startElement_handler + +subroutine TBM_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + character(len=10240) :: val + integer ii + + if (parse_in_tbm) then + if (name == 'DFTB_params') then + parse_in_tbm = .false. + elseif (name == 'orb_set_type') then + val = string(parse_cur_data) + read (val, *) parse_tbm%orb_set_type(1:parse_tbm%n_orb_sets(parse_cur_type_i),parse_cur_type_i) + elseif (name == 'E') then + val = string(parse_cur_data) + read (val, *) parse_tbm%E(1:parse_tbm%n_orb_sets(parse_cur_type_i),parse_cur_type_i) + parse_tbm%E(:,parse_cur_type_i) = parse_tbm%E(:,parse_cur_type_i) * HARTREE + elseif (name == 'per_pair_data') then + if (allocated(parse_SK_r)) deallocate(parse_SK_r) + if (allocated(parse_H_vals)) deallocate(parse_H_vals) + if (allocated(parse_S_vals)) deallocate(parse_S_vals) + if (allocated(parse_Vrep_r)) deallocate(parse_Vrep_r) + if (allocated(parse_Vrep_vals)) deallocate(parse_Vrep_vals) + elseif (parse_in_tbm .and. name == 'H_spline') then + do ii=1, 10 + call initialise(parse_tbm%H_spline(ii,parse_cur_type_i,parse_cur_type_j), parse_SK_r, parse_H_vals(ii,:), 0.0_dp, 0.0_dp) + end do + parse_in_H_spline = .false. + elseif (parse_in_tbm .and. name == 'S_spline') then + do ii=1, 10 + call initialise(parse_tbm%S_spline(ii,parse_cur_type_i,parse_cur_type_j), parse_SK_r, parse_S_vals(ii,:), 0.0_dp, 0.0_dp) + end do + parse_in_S_spline = .false. + elseif (parse_in_tbm .and. name == 'Vrep_spline') then + call initialise(parse_tbm%Vrep_spline(parse_cur_type_i,parse_cur_type_j), parse_Vrep_r, parse_Vrep_vals, 0.0_dp, 0.0_dp) + parse_in_Vrep_spline = .false. + elseif (name == 'point') then + if (parse_in_H_spline) then + val = string(parse_cur_data) + parse_H_vals(1:10,parse_cur_point_i) = 0.0_dp + read (val, *, end=1000) parse_H_vals(1:10,parse_cur_point_i) +1000 continue + parse_H_vals(1:10,parse_cur_point_i) = parse_H_vals(1:10,parse_cur_point_i) * HARTREE + elseif (parse_in_S_spline) then + val = string(parse_cur_data) + parse_S_vals(1:10,parse_cur_point_i) = 0.0_dp + read (val, *, end=1010) parse_S_vals(1:10,parse_cur_point_i) +1010 continue + elseif (parse_in_Vrep_spline) then + val = string(parse_cur_data) + read (val, *) parse_Vrep_vals(parse_cur_point_i) + parse_Vrep_vals(parse_cur_point_i) = parse_Vrep_vals(parse_cur_point_i) * HARTREE + else + call system_abort('Found point in DFTB_params but not in H_spline, S_spline, or Vrep_Spline') + endif + parse_cur_point_i = parse_cur_point_i + 1 + endif + endif + +end subroutine TBM_endElement_handler + + +subroutine TBModel_DFTB_read_params_xml(this, param_str) + type(TBModel_DFTB), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + integer :: err + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_tbm => this + parse_in_tbm = .false. + parse_matched_label = .false. + parse_in_H_spline = .false. + parse_in_S_spline = .false. + parse_in_Vrep_spline = .false. + + err = increase_stack(5*len(param_str)) + if (err /= 0)then + call print("TBModel_DfTB_Initialise_str Failed to increase stack before calling parse_xml", PRINT_ALWAYS) + endif + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + characters_handler = TBM_characters_handler, & + startElement_handler = TBM_startElement_handler, & + endElement_handler = TBM_endElement_handler) + + call close_xml_t(fxml) + +end subroutine + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! type(inoutput), pointer :: in +! +! integer ti, tj, Zi, Zj, tt, i, j, ii, jj +! integer max_n_orb_sets +! +! integer SK_npts, Vrep_npts +! real(dp), allocatable :: SK_r(:), H_vals(:,:), S_vals(:,:), Vrep_r(:), Vrep_vals(:) +! +! integer status +! type(dictionary_t) :: attributes +! type(xml_t) :: fxml +! character(len=1024) :: value +! integer :: ndata +! character(len=10240) :: pcdata +! integer cur_i +! +! if (present(from_io)) then +! in => from_io +! else +! allocate(in) +! call Initialise(in, trim(dftb_default_file), INPUT) +! endif +! +! call open_xmlfile(in%unit, fxml, status) +!! call enable_debug(sax=.true.) +! if (status /= 0) call system_abort('TBModel_DFTB_read_params_xml Cannot open xml file') +! +! call rewind_xmlfile(fxml) +! +! call get_node(fxml, path='//DFTB_params', attributes=attributes, status=status) +! if (status /= 0) call system_abort('TBModel_DFTB_read_params_xml Cannot find /DFTB_params/header') +! +! call get_node(fxml, path='//DFTB_params/n_types', attributes=attributes, status=status) +! call QUIP_FoX_get_value(attributes, "v", value, status); +! if (status == 0) read (value, *) this%n_types +! +! call get_node(fxml, path='//DFTB_params/cutoff', attributes=attributes, status=status) +! call QUIP_FoX_get_value(attributes, "v", value, status); +! if (status == 0) read (value, *) this%cutoff +! this%cutoff = this%cutoff*BOHR +! +! call get_node(fxml, path='//DFTB_params/max_n_orb_sets', attributes=attributes, status=status) +! call QUIP_FoX_get_value(attributes, "v", value, status); +! if (status == 0) read (value, *) max_n_orb_sets +! +! allocate(this%atomic_num(this%n_types)) +! allocate(this%n_orbs(this%n_types)) +! allocate(this%n_elecs(this%n_types)) +! allocate(this%n_orb_sets(this%n_types)) +! allocate(this%orb_set_type(max_n_orb_sets,this%n_types)) +! allocate(this%E(max_n_orb_sets,this%n_types)) +! +! call rewind_xmlfile(fxml) +! +! !! read DFTB per-type params +! do tt=1, this%n_types +! call get_node(fxml, path='//DFTB_params/per_type_data', attributes=attributes, status=status) +! if (status /= 0) call system_abort("Couldn't find per_type_data for " // str(ti)) +! +! call QUIP_FoX_get_value(attributes, "type", value, status); +! if (status == 0) then +! read (value, *) ti +! else +! call system_abort ("failed to find type in per_type_data " // str(tt)) +! endif +! +! call QUIP_FoX_get_value(attributes, "atomic_num", value, status); +! if (status == 0) read (value, *) this%atomic_num(ti) +! +! call QUIP_FoX_get_value(attributes, "n_orbs", value, status); +! if (status == 0) read (value, *) this%n_orbs(ti) +! +! call QUIP_FoX_get_value(attributes, "n_orb_sets", value, status); +! if (status == 0) read (value, *) this%n_orb_sets(ti) +! +! call QUIP_FoX_get_value(attributes, "n_elecs", value, status); +! if (status == 0) read (value, *) this%n_elecs(ti) +! +! call get_node(fxml, path='orb_set_type', attributes=attributes, pcdata=pcdata, status=status) +! ndata = 0 +! call build_data_array(pcdata, this%orb_set_type(1:this%n_orb_sets(ti),ti), ndata) +! if (ndata /= this%n_orb_sets(ti)) call system_abort ('Mismatch in amount of data reading orb_set_type '// trim(str(ti)) // & +! ' ' // trim(str(ndata))) +! +! call get_node(fxml, path='E', attributes=attributes, pcdata=pcdata, status=status) +! ndata = 0 +! call build_data_array(pcdata, this%E(1:this%n_orb_sets(ti),ti), ndata) +! if (ndata /= this%n_orb_sets(ti)) call system_abort ('Mismatch in amount of data reading E '// trim(str(ti)) // & +! ' ' // trim(str(ndata))) +! this%E(:,ti) = this%E(:,ti)*HARTREE +! +! end do +! +! allocate(this%type_of_atomic_num(maxval(this%atomic_num(:)))) +! this%type_of_atomic_num(:) = 0 +! do ti=1, this%n_types +! this%type_of_atomic_num(this%atomic_num(ti)) = ti +! end do +! +! allocate(this%H_spline(10,this%n_types,this%n_types)) +! allocate(this%S_spline(10,this%n_types,this%n_types)) +! allocate(this%Vrep_spline(this%n_types,this%n_types)) +! +! allocate(this%SK_cutoff(this%n_types,this%n_types)) +! allocate(this%Vrep_cutoff(this%n_types,this%n_types)) +! +! call rewind_xmlfile(fxml) +! +! do ii=1, this%n_types +! do jj=1, this%n_types +! call get_node(fxml, path='//DFTB_params/per_pair_data', attributes=attributes, status=status) +! if (status /= 0) then +! call system_abort("Can't find per_pair_data for " // str(ii) // ' ' // str(jj)) +! endif +! call QUIP_FoX_get_value(attributes, "type1", value, status); +! if (status == 0) read (value, *) ti +! call QUIP_FoX_get_value(attributes, "type2", value, status); +! if (status == 0) read (value, *) tj +! call QUIP_FoX_get_value(attributes, "SK_npts", value, status); +! if (status == 0) read (value, *) SK_npts +! call QUIP_FoX_get_value(attributes, "Vrep_npts", value, status); +! if (status == 0) read (value, *) Vrep_npts +! call QUIP_FoX_get_value(attributes, "SK_cutoff", value, status); +! if (status == 0) read (value, *) this%SK_cutoff(ti,tj) +! this%SK_cutoff(ti,tj) = this%SK_cutoff(ti,tj)*BOHR +! call QUIP_FoX_get_value(attributes, "Vrep_cutoff", value, status); +! if (status == 0) read (value, *) this%Vrep_cutoff(ti,tj) +! this%Vrep_cutoff(ti,tj) = this%Vrep_cutoff(ti,tj)*BOHR +! +! allocate(SK_r(SK_npts)) +! allocate(H_vals(10,SK_npts)) +! allocate(S_vals(10,SK_npts)) +! +! allocate(Vrep_r(Vrep_npts)) +! allocate(Vrep_vals(Vrep_npts)) +! +! call mark_node(fxml, path='//DFTB_params/per_pair_data/H_spline', attributes=attributes, status=status) +! if (status /= 0) then +! call system_abort("Can't find H_spline for " // str(ii) // ' ' // str(jj)) +! endif +! do i=1, SK_npts +! call get_node(fxml, path='point', attributes=attributes, pcdata=pcdata, status=status) +! if (status /= 0) then +! call system_abort("Can't find H_spline/point for " // str(ii) // ' ' // str(jj)) +! endif +! +! call QUIP_FoX_get_value(attributes, "r", value, status); +! if (status == 0) read (value, *) SK_r(i) +! +! ndata = 0 +! call build_data_array(pcdata, H_vals(1:10,i), ndata) +! end do +! SK_r = SK_r*BOHR +! H_vals = H_vals*HARTREE +! do i=1, 10 +! call initialise(this%H_spline(i,ti,tj), SK_r, H_vals(i,:), 0.0_dp, 0.0_dp) +! end do +! +! call mark_node(fxml, path='//DFTB_params/per_pair_data/S_spline', attributes=attributes, status=status) +! if (status /= 0) then +! call system_abort("Can't find S_spline for " // str(ii) // ' ' // str(jj)) +! endif +! do i=1, SK_npts +! call get_node(fxml, path='point', attributes=attributes, pcdata=pcdata, status=status) +! if (status /= 0) then +! call system_abort("Can't find S_spline/point for " // str(ii) // ' ' // str(jj)) +! endif +! +! call QUIP_FoX_get_value(attributes, "r", value, status); +! if (status == 0) read (value, *) SK_r(i) +! +! ndata = 0 +! call build_data_array(pcdata, S_vals(1:10,i), ndata) +! end do +! SK_r = SK_r*BOHR +! do i=1, 10 +! call initialise(this%S_spline(i,ti,tj), SK_r, S_vals(i,:), 0.0_dp, 0.0_dp) +! end do +! +! call mark_node(fxml, path='//DFTB_params/per_pair_data/Vrep_spline', attributes=attributes, status=status) +! if (status /= 0) then +! call system_abort("Can't find Vrep_spline for " // str(ii) // ' ' // str(jj)) +! endif +! do i=1, Vrep_npts +! call get_node(fxml, path='point', attributes=attributes, pcdata=pcdata, status=status) +! if (status /= 0) then +! call system_abort("Can't find Vrep_spline/point for " // str(ii) // ' ' // str(jj)) +! endif +! +! call QUIP_FoX_get_value(attributes, "r", value, status); +! if (status == 0) read (value, *) Vrep_r(i) +! +! ndata = 0 +! call build_data_array(pcdata, Vrep_vals(i:i), ndata) +! end do +! Vrep_r = Vrep_r*BOHR +! Vrep_vals = Vrep_vals*HARTREE +! call initialise(this%Vrep_spline(ti,tj), Vrep_r, Vrep_vals, 0.0_dp, 0.0_dp) +! +! deallocate(SK_r) +! deallocate(H_vals) +! deallocate(S_vals) +! deallocate(Vrep_r) +! deallocate(Vrep_vals) +! end do +! end do +! +!end subroutine TBModel_DFTB_read_params_xml +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine TBModel_DFTB_Print(this,file) + type(TBModel_DFTB), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer:: ti, tj, i + + if(this%n_types == 0) call System_Abort('TBModel_DFTB_Print: TBModel_DFTB structure not initialised') + + call Print('TBModel_DFTB Structure:', file=file) + + !! print DFTB params + call Print ("TBModel_DFTB cutoff " // this%cutoff, file=file) + do ti=1, this%n_types + call Print ("TBModel_DFTB type " // ti // " Z " // this%atomic_num(ti) // " n_orbs " // this%n_orbs(ti) // & + " n_elecs " // this%n_elecs(ti), file=file) + if (this%n_orb_sets(ti) == 1) then + call Print ("TBModel_DFTB E " // this%E(1,ti), file=file) + else if (this%n_orb_sets(ti) == 2) then + call Print ("TBModel_DFTB E " // this%E(1:2,ti), file=file) + else + call Print ("TBModel_DFTB E " //this%E(1:3,ti), file=file) + endif + end do + + call verbosity_push_decrement(PRINT_NERD) + if (current_verbosity() >= PRINT_NORMAL) then + do ti=1, this%n_types + do tj=1, this%n_types + call Print ("TBModel_DFTB interaction " // ti // " " // tj // " Z " // this%atomic_num(ti) // " " // & + this%atomic_num(tj), file=file) + + do i=1, 10 + call Print ("H_spline " // i, file=file) + call Print (this%H_spline(i,ti,tj), file=file) + end do + do i=1, 10 + call Print ("S_spline " // i, file=file) + call Print (this%S_spline(i,ti,tj), file=file) + end do + call Print ("Vrep_spline", file=file) + call Print (this%Vrep_spline(ti,tj), file=file) + + end do + end do + endif + call verbosity_pop() + +end subroutine TBModel_DFTB_Print + +function TBModel_DFTB_n_orbs_of_Z(this, Z) + type(TBModel_DFTB), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_DFTB_n_orbs_of_Z + + TBModel_DFTB_n_orbs_of_Z = this%n_orbs(get_type(this%type_of_atomic_num,Z)) +end function TBModel_DFTB_n_orbs_of_Z + +function TBModel_DFTB_n_orb_sets_of_Z(this, Z) + type(TBModel_DFTB), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_DFTB_n_orb_sets_of_Z + + TBModel_DFTB_n_orb_sets_of_Z = this%n_orb_sets(get_type(this%type_of_atomic_num,Z)) +end function TBModel_DFTB_n_orb_sets_of_Z + +function TBModel_DFTB_n_orbs_of_orb_set_of_Z(this, Z, i_set) + type(TBModel_DFTB), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_DFTB_n_orbs_of_orb_set_of_Z + + TBModel_DFTB_n_orbs_of_orb_set_of_Z = N_ORBS_OF_SET(this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z))) + +end function TBModel_DFTB_n_orbs_of_orb_set_of_Z + +function TBModel_DFTB_orb_type_of_orb_set_of_Z(this, Z, i_set) + type(TBModel_DFTB), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_DFTB_orb_type_of_orb_set_of_Z + + TBModel_DFTB_orb_type_of_orb_set_of_Z = this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z)) + +end function TBModel_DFTB_orb_type_of_orb_set_of_Z + +function TBModel_DFTB_n_elecs_of_Z(this, Z) + type(TBModel_DFTB), intent(in) :: this + integer, intent(in) :: Z + real(dp) TBModel_DFTB_n_elecs_of_Z + + TBModel_DFTB_n_elecs_of_Z = this%n_elecs(get_type(this%type_of_atomic_num,Z)) +end function TBModel_DFTB_n_elecs_of_Z + +subroutine TBModel_DFTB_get_HS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, b_H, b_S, i_mag) + type(TBModel_DFTB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, at_j + real(dp), intent(in) :: dv_hat(3), dv_mag + real(dp), intent(out) :: b_H(:,:) + real(dp), intent(out) :: b_S(:,:) + integer, intent(in), optional :: i_mag + + integer ti, tj, is, js, i_set, j_set + integer i, j + real(dp) SK_frad_H(N_SK), SK_frad_S(N_SK) + real(dp) dv_hat_sq(3) + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + tj = get_type(this%type_of_atomic_num,at%Z(at_j)) + + + if (dv_mag .feq. 0.0_dp) then + b_H = 0.0_dp + b_S = 0.0_dp + + i = 1 + do i_set = 1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + b_H(i,i) = this%E(i_set,ti) + b_S(i,i) = 1.0_dp + i = i + 1 + end do + end do + + else + + dv_hat_sq = dv_hat**2 + + i = 1 + do i_set=1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + j = 1 + do j_set=1, this%n_orb_sets(tj) + call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H, SK_frad_S) + do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) + + b_H(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H) + b_S(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_S) + j = j + 1 + end do + end do + i = i + 1 + end do + end do + endif + +end subroutine TBModel_DFTB_get_HS_blocks + +subroutine TBModel_DFTB_get_dHS_masks(this, at, at_ind, d_mask, od_mask) + type(TBModel_DFTB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_ind + logical, intent(out), optional :: d_mask(:), od_mask(:) + + if (at_ind < 0) then + if (present(d_mask)) d_mask = .true. + if (present(od_mask)) od_mask = .true. + else + if (present(d_mask)) d_mask = .false. + if (present(od_mask)) then + od_mask = .false. + od_mask(at_ind) = .true. + endif + endif + +end subroutine + +function TBModel_DFTB_get_dHS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) + type(TBModel_DFTB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, at_j + real(dp), intent(in) :: dv_hat(3), dv_mag + integer, intent(in) :: at_ind + real(dp), intent(out) :: b_dH(:,:,:) + real(dp), intent(out) :: b_dS(:,:,:) + integer, intent(in), optional :: i_mag + logical :: TBModel_DFTB_get_dHS_blocks + + integer ti, tj, is, js, i_set, j_set + integer i, j + real(dp) SK_frad_H(N_SK), SK_frad_S(N_SK) + real(dp) SK_dfrad_H(N_SK), SK_dfrad_S(N_SK) + real(dp) dv_hat_sq(3) + real(dp) virial_outerprod_fac + + if ((at_ind > 0 .and. at_i /= at_ind .and. at_j /= at_ind) .or. & + (at_ind > 0 .and. at_i == at_j) .or. & + (dv_mag > this%cutoff) .or. & + (dv_mag .feq. 0.0_dp)) then + TBModel_DFTB_get_dHS_blocks = .false. + return + endif + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + tj = get_type(this%type_of_atomic_num,at%Z(at_j)) + + if (dv_mag > this%SK_cutoff(ti,tj)) then + TBModel_DFTB_get_dHS_blocks = .false. + return + endif + + dv_hat_sq = dv_hat**2 + + i = 1 + do i_set=1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + j = 1 + do j_set=1, this%n_orb_sets(tj) + call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H, SK_frad_S) + call dradial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_dfrad_H, SK_dfrad_S) + do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) + + if (at_ind > 0) then + virial_outerprod_fac = 1.0_dp + else + virial_outerprod_fac = -dv_mag*dv_hat(-at_ind) + end if + b_dH(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & + this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H, SK_dfrad_H)*virial_outerprod_fac + b_dS(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & + this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_S, SK_dfrad_S)*virial_outerprod_fac + j = j + 1 + end do + end do + i = i + 1 + end do + end do + + if (at_ind == at_j) then + b_dH = -b_dH + b_dS = -b_dS + end if + + TBModel_DFTB_get_dHS_blocks = .true. + return + + +end function TBModel_DFTB_get_dHS_blocks + +subroutine radial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, is, js, f_H, f_S) + type(TBModel_DFTB), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dv_mag + integer, intent(in) :: orb_set_type_i, orb_set_type_j + integer, intent(in) :: is, js + real(dp), intent(out) :: f_H(N_SK), f_S(N_SK) + + if (dv_mag > this%SK_cutoff(ti,tj)) then + f_H = 0.0_dp + f_S = 0.0_dp + return + endif + + if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then + f_H(SK_SSS) = spline_value(this%H_spline(1,ti,tj), dv_mag) + f_S(SK_SSS) = spline_value(this%S_spline(1,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then + f_H(SK_SPS) = spline_value(this%H_spline(2,ti,tj), dv_mag) + f_S(SK_SPS) = spline_value(this%S_spline(2,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then + f_H(SK_SPS) = -spline_value(this%H_spline(2,tj,ti), dv_mag) + f_S(SK_SPS) = -spline_value(this%S_spline(2,tj,ti), dv_mag) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then + f_H(SK_PPS) = spline_value(this%H_spline(3,ti,tj), dv_mag) + f_S(SK_PPS) = spline_value(this%S_spline(3,ti,tj), dv_mag) + f_H(SK_PPP) = spline_value(this%H_spline(4,ti,tj), dv_mag) + f_S(SK_PPP) = spline_value(this%S_spline(4,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_D) then + f_H(SK_SDS) = spline_value(this%H_spline(5,ti,tj), dv_mag) + f_S(SK_SDS) = spline_value(this%S_spline(5,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_S) then + f_H(SK_SDS) = spline_value(this%H_spline(5,tj,ti), dv_mag) + f_S(SK_SDS) = spline_value(this%S_spline(5,tj,ti), dv_mag) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_D) then + f_H(SK_PDS) = spline_value(this%H_spline(6,ti,tj), dv_mag) + f_S(SK_PDS) = spline_value(this%S_spline(6,ti,tj), dv_mag) + f_H(SK_PDP) = spline_value(this%H_spline(7,ti,tj), dv_mag) + f_S(SK_PDP) = spline_value(this%S_spline(7,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_P) then + f_H(SK_PDS) = -spline_value(this%H_spline(6,tj,ti), dv_mag) + f_S(SK_PDS) = -spline_value(this%S_spline(6,tj,ti), dv_mag) + f_H(SK_PDP) = spline_value(this%H_spline(7,tj,ti), dv_mag) + f_S(SK_PDP) = spline_value(this%S_spline(7,tj,ti), dv_mag) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then + f_H(SK_DDS) = spline_value(this%H_spline(9,ti,tj), dv_mag) + f_S(SK_DDS) = spline_value(this%S_spline(8,ti,tj), dv_mag) + f_H(SK_DDP) = spline_value(this%H_spline(9,ti,tj), dv_mag) + f_S(SK_DDP) = spline_value(this%S_spline(9,ti,tj), dv_mag) + f_H(SK_DDD) = spline_value(this%H_spline(10,ti,tj), dv_mag) + f_S(SK_DDD) = spline_value(this%S_spline(10,ti,tj), dv_mag) + else + call system_abort("TBModel_DFTB radial_functions got invalide orb_set_type "//orb_set_type_i//" or "//orb_set_type_j) + endif + end subroutine radial_functions + + subroutine dradial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, is, js, f_dH, f_dS) + type(TBModel_DFTB), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dv_mag + integer, intent(in) :: orb_set_type_i, orb_set_type_j + integer, intent(in) :: is, js + real(dp), intent(out) :: f_dH(N_SK), f_dS(N_SK) + + if (dv_mag > this%SK_cutoff(ti,tj)) then + f_dH = 0.0_dp + f_dS = 0.0_dp + return + endif + + if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then + f_dH(SK_SSS) = spline_deriv(this%H_spline(1,ti,tj), dv_mag) + f_dS(SK_SSS) = spline_deriv(this%S_spline(1,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then + f_dH(SK_SPS) = spline_deriv(this%H_spline(2,ti,tj), dv_mag) + f_dS(SK_SPS) = spline_deriv(this%S_spline(2,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then + f_dH(SK_SPS) = -spline_deriv(this%H_spline(2,tj,ti), dv_mag) + f_dS(SK_SPS) = -spline_deriv(this%S_spline(2,tj,ti), dv_mag) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then + f_dH(SK_PPS) = spline_deriv(this%H_spline(3,ti,tj), dv_mag) + f_dS(SK_PPS) = spline_deriv(this%S_spline(3,ti,tj), dv_mag) + f_dH(SK_PPP) = spline_deriv(this%H_spline(4,ti,tj), dv_mag) + f_dS(SK_PPP) = spline_deriv(this%S_spline(4,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_D) then + f_dH(SK_SDS) = spline_deriv(this%H_spline(5,ti,tj), dv_mag) + f_dS(SK_SDS) = spline_deriv(this%S_spline(5,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_S) then + f_dH(SK_SDS) = spline_deriv(this%H_spline(5,tj,ti), dv_mag) + f_dS(SK_SDS) = spline_deriv(this%S_spline(5,tj,ti), dv_mag) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_D) then + f_dH(SK_PDS) = spline_deriv(this%H_spline(6,ti,tj), dv_mag) + f_dS(SK_PDS) = spline_deriv(this%S_spline(6,ti,tj), dv_mag) + f_dH(SK_PDP) = spline_deriv(this%H_spline(7,ti,tj), dv_mag) + f_dS(SK_PDP) = spline_deriv(this%S_spline(7,ti,tj), dv_mag) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_P) then + f_dH(SK_PDS) = -spline_deriv(this%H_spline(6,tj,ti), dv_mag) + f_dS(SK_PDS) = -spline_deriv(this%S_spline(6,tj,ti), dv_mag) + f_dH(SK_PDP) = spline_deriv(this%H_spline(7,tj,ti), dv_mag) + f_dS(SK_PDP) = spline_deriv(this%S_spline(7,tj,ti), dv_mag) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then + f_dH(SK_DDS) = spline_deriv(this%H_spline(9,ti,tj), dv_mag) + f_dS(SK_DDS) = spline_deriv(this%S_spline(8,ti,tj), dv_mag) + f_dH(SK_DDP) = spline_deriv(this%H_spline(9,ti,tj), dv_mag) + f_dS(SK_DDP) = spline_deriv(this%S_spline(9,ti,tj), dv_mag) + f_dH(SK_DDD) = spline_deriv(this%H_spline(10,ti,tj), dv_mag) + f_dS(SK_DDD) = spline_deriv(this%S_spline(10,ti,tj), dv_mag) + else + call system_abort("TBModel_DFTB dradial_functions got invalide orb_set_type "//orb_set_type_i//" or "//orb_set_type_j) + endif + +end subroutine dradial_functions + +function TBModel_DFTB_get_local_rep_E(this, at, i) + type(TBModel_DFTB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: TBModel_DFTB_get_local_rep_E + + real(dp) E, dist + integer ji, j, ti, tj + + TBModel_DFTB_get_local_rep_E = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (dist < this%Vrep_cutoff(ti,tj)) then + E = spline_value(this%Vrep_spline(ti,tj), dist) + TBModel_DFTB_get_local_rep_E = TBModel_DFTB_get_local_rep_E + E/2.0_dp + endif + end do + +end function TBModel_DFTB_get_local_rep_E + +function TBModel_DFTB_get_local_rep_E_force(this, at, i) result(force) + type(TBModel_DFTB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: force(3,at%N) + + real(dp) dE_dr, dist, dv_hat(3) + integer ji, j, ti, tj + + force = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist, cosines = dv_hat) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (dist < this%Vrep_cutoff(ti,tj)) then + dE_dr = spline_deriv(this%Vrep_spline(ti,tj),dist) + force(:,i) = force(:,i) + dE_dr*dv_hat(:)/2.0_dp + force(:,j) = force(:,j) - dE_dr*dv_hat(:)/2.0_dp + end if + end do + +end function TBModel_DFTB_get_local_rep_E_force + +function TBModel_DFTB_get_local_rep_E_virial(this, at, i) result(virial) + type(TBModel_DFTB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: virial(3,3) + + real(dp) dE_dr, dist, dv_hat(3) + integer ji, j, ti, tj + + virial = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist, cosines = dv_hat) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + + if (dist < this%Vrep_cutoff(ti,tj)) then + dE_dr = spline_deriv(this%Vrep_spline(ti,tj),dist) + virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist / 2.0_dp + end if + end do + +end function TBModel_DFTB_get_local_rep_E_virial + +end module TBModel_DFTB_module diff --git a/src/Potentials/TBModel_GSP.F90 b/src/Potentials/TBModel_GSP.F90 new file mode 100644 index 0000000000..c59421cb4c --- /dev/null +++ b/src/Potentials/TBModel_GSP.F90 @@ -0,0 +1,1385 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X TBModel_GSP module +!X +!% Calculate energies using Goodwin-Skinner-Pettifor tight-binding model +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +module TBModel_GSP_module + +use system_module, only : dp, inoutput, system_abort, verbosity_push_decrement, verbosity_pop, operator(//) +use dictionary_module +use paramreader_module +use linearalgebra_module +use spline_module +use atoms_types_module +use atoms_module + +use TB_Common_module +use QUIP_Common_module + +implicit none +private + +integer, parameter :: max_n_orb_sets = 3 + +include 'TBModel_interface.h' + +public :: TBModel_GSP +type TBModel_GSP + integer :: n_types = 0 + character(len=STRING_LENGTH) label + + real(dp) :: cutoff = 0.0_dp + real(dp) :: cutoff_H = 0.0_dp + logical :: is_orthogonal = .true. + + integer, allocatable :: type_of_atomic_num(:) + integer, allocatable :: n_orbs(:), n_orb_sets(:), orb_set_type(:,:) + real(dp), allocatable :: n_elecs(:) + integer, allocatable :: atomic_num(:) + +! GSP parameters + real(dp), allocatable :: H_coeff(:,:,:) + real(dp), allocatable :: O_coeff(:,:,:) + real(dp), allocatable :: Atau(:,:,:) + real(dp), allocatable :: deltatau0(:,:,:) + real(dp), allocatable :: r0(:,:), rc(:,:), na(:,:), nb(:,:), nc(:,:) + + real(dp), allocatable :: B(:,:), Rcore(:,:), lambda0(:), C(:), nu(:), m(:) + real(dp), allocatable :: Rtail(:), Rcut(:) + + real(dp), allocatable :: Ai(:,:,:), Ri(:,:,:) + + real(dp) :: tailx0 + + real(dp), allocatable :: E(:,:) + + type(spline), allocatable :: H_tail_spline(:,:) + type(spline), allocatable :: Vrep_env_emb_tail_spline(:) + + logical :: has_default_fermi_E = .false., has_default_fermi_T = .true., has_default_band_width = .false., has_default_k_density=.false. + real(dp) :: default_fermi_E, default_fermi_T = 0.001_dp, default_band_width, default_k_density + +end type + +integer, private :: parse_cur_type +logical, private :: parse_in_tbm, parse_matched_label +type(TBModel_GSP), pointer :: parse_tbm + +interface Initialise + module procedure TBModel_GSP_Initialise_str +end interface Initialise + +interface Finalise + module procedure TBModel_GSP_Finalise +end interface Finalise + +interface Print + module procedure TBModel_GSP_Print +end interface Print + +interface n_orbs_of_Z + module procedure TBModel_GSP_n_orbs_of_Z +end interface n_orbs_of_Z + +interface n_orb_sets_of_Z + module procedure TBModel_GSP_n_orb_sets_of_Z +end interface n_orb_sets_of_Z + +interface n_orbs_of_orb_set_of_Z + module procedure TBModel_GSP_n_orbs_of_orb_set_of_Z +end interface n_orbs_of_orb_set_of_Z + +interface orb_type_of_orb_set_of_Z + module procedure TBModel_GSP_orb_type_of_orb_set_of_Z +end interface orb_type_of_orb_set_of_Z + +interface n_elecs_of_Z + module procedure TBModel_GSP_n_elecs_of_Z +end interface n_elecs_of_Z + +interface get_HS_blocks + module procedure TBModel_GSP_get_HS_blocks +end interface get_HS_blocks + +interface get_dHS_masks + module procedure TBModel_GSP_get_dHS_masks +end interface get_dHS_masks + +interface get_dHS_blocks + module procedure TBModel_GSP_get_dHS_blocks +end interface get_dHS_blocks + +interface get_local_rep_E + module procedure TBModel_GSP_get_local_rep_E +end interface get_local_rep_E + +interface get_local_rep_E_force + module procedure TBModel_GSP_get_local_rep_E_force +end interface get_local_rep_E_force + +interface get_local_rep_E_virial + module procedure TBModel_GSP_get_local_rep_E_virial +end interface get_local_rep_E_virial + +interface calc_H_coeff + module procedure TBModel_GSP_calc_H_coeff +end interface calc_H_coeff + +interface calc_H_coeff_deriv + module procedure TBModel_GSP_calc_H_coeff_deriv +end interface calc_H_coeff_deriv + +contains + +subroutine TBModel_GSP_Initialise_str(this, args_str, param_str) + type(TBModel_GSP), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_GSP_Initialise_str args_str')) then + call system_abort("TBModel_GSP_Initialise_str parse problems"//trim(args_str)) + endif + call finalise(params) + + call TBModel_GSP_read_params_xml(this, param_str) +end subroutine TBModel_GSP_Initialise_str + +subroutine TBModel_GSP_Finalise(this) + type(TBModel_GSP), intent(inout) :: this + + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%n_orbs)) deallocate(this%n_orbs) + if (allocated(this%n_elecs)) deallocate(this%n_elecs) + if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) + if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + + if (allocated(this%H_coeff)) deallocate(this%H_coeff) + if (allocated(this%O_coeff)) deallocate(this%O_coeff) + if (allocated(this%Atau)) deallocate(this%Atau) + if (allocated(this%deltatau0)) deallocate(this%deltatau0) + + if (allocated(this%r0)) deallocate(this%r0) + if (allocated(this%rc)) deallocate(this%rc) + if (allocated(this%na)) deallocate(this%na) + if (allocated(this%nb)) deallocate(this%nb) + if (allocated(this%nc)) deallocate(this%nc) + + if (allocated(this%B)) deallocate(this%B) + if (allocated(this%Rcore)) deallocate(this%Rcore) + if (allocated(this%lambda0)) deallocate(this%lambda0) + if (allocated(this%C)) deallocate(this%C) + if (allocated(this%nu)) deallocate(this%nu) + if (allocated(this%m)) deallocate(this%m) + if (allocated(this%Rtail)) deallocate(this%Rtail) + if (allocated(this%Rcut)) deallocate(this%Rcut) + + if (allocated(this%Ai)) deallocate(this%Ai) + if (allocated(this%Ri)) deallocate(this%Ri) + + if (allocated(this%E)) deallocate(this%E) + + if (allocated(this%H_tail_spline)) deallocate(this%H_tail_spline) + if (allocated(this%Vrep_env_emb_tail_spline)) deallocate(this%Vrep_env_emb_tail_spline) + + this%n_types = 0 + this%label = '' +end subroutine TBModel_GSP_Finalise + +subroutine TBM_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + character(len=1024) :: value + integer status + integer ti, tj, Zi, Zj + + if (name == 'GSP_params') then ! new GSP stanza + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_tbm%label)) > 0) then ! we were passed in a label + if (value == parse_tbm%label) then ! exact match + parse_matched_label = .true. + parse_in_tbm = .true. + else ! no match + parse_in_tbm = .false. + endif + else ! no label passed in + parse_in_tbm = .true. + endif + + if (parse_in_tbm) then + if (parse_tbm%n_types /= 0) then + call finalise(parse_tbm) + endif + + parse_cur_type = 1 + + call QUIP_FoX_get_value(attributes, "n_types", value, status); + if (status == 0) read (value, *) parse_tbm%n_types + call QUIP_FoX_get_value(attributes, "tailx0", value, status); + if (status == 0) read (value, *) parse_tbm%tailx0 + call QUIP_FoX_get_value(attributes, "cutoff", value, status); + if (status == 0) read (value, *) parse_tbm%cutoff + call QUIP_FoX_get_value(attributes, "cutoff_H", value, status); + if (status == 0) read (value, *) parse_tbm%cutoff_H + + allocate(parse_tbm%atomic_num(parse_tbm%n_types)) + parse_tbm%atomic_num = 0 + allocate(parse_tbm%n_orbs(parse_tbm%n_types)) + allocate(parse_tbm%n_elecs(parse_tbm%n_types)) + allocate(parse_tbm%n_orb_sets(parse_tbm%n_types)) + allocate(parse_tbm%orb_set_type(max_n_orb_sets,parse_tbm%n_types)) + allocate(parse_tbm%E(max_n_orb_sets,parse_tbm%n_types)) + allocate(parse_tbm%B(parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%Rcore(parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%lambda0(parse_tbm%n_types)) + allocate(parse_tbm%C(parse_tbm%n_types)) + allocate(parse_tbm%nu(parse_tbm%n_types)) + allocate(parse_tbm%m(parse_tbm%n_types)) + allocate(parse_tbm%Rtail(parse_tbm%n_types)) + allocate(parse_tbm%Rcut(parse_tbm%n_types)) + allocate(parse_tbm%Ai(4,parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%Ri(4,parse_tbm%n_types,parse_tbm%n_types)) + + allocate(parse_tbm%H_coeff(10, parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%O_coeff(10, parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%Atau(10, parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%deltatau0(10, parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%rc(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%r0(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%na(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%nb(parse_tbm%n_types, parse_tbm%n_types)) + allocate(parse_tbm%nc(parse_tbm%n_types, parse_tbm%n_types)) + + parse_tbm%H_coeff = 0.0_dp + parse_tbm%O_coeff = 0.0_dp + parse_tbm%Atau = 0.0_dp + parse_tbm%deltatau0 = 0.0_dp + parse_tbm%rc = 1.0_dp + parse_tbm%r0 = 0.0_dp + parse_tbm%na = 0.0_dp + parse_tbm%nb = 1.0_dp + parse_tbm%nc = 0.0_dp + parse_tbm%B = 1.0_dp + parse_tbm%Rcore = 0.0_dp + parse_tbm%lambda0 = 0.0_dp + parse_tbm%C = 0.0_dp + parse_tbm%nu = 0.0_dp + parse_tbm%m = 0.0_dp + parse_tbm%Rtail = 0.0_dp + parse_tbm%Rcut = 0.0_dp + parse_tbm%Ai = 0.0_dp + parse_tbm%Ri = 0.0_dp + endif + + elseif (parse_in_tbm .and. name == 'per_type_data') then + if (parse_cur_type > parse_tbm%n_types) & + call system_abort('Too many types defined in GSP_params') + + call QUIP_FoX_get_value(attributes, "Z", value, status); + if (status == 0) read (value, *) parse_tbm%atomic_num(parse_cur_type) + + call QUIP_FoX_get_value(attributes, "n_orbs", value, status); + if (status == 0) read (value, *) parse_tbm%n_orbs(parse_cur_type) + if (parse_tbm%n_orbs(parse_cur_type) == 5) then + parse_tbm%n_orb_sets(parse_cur_type) = 1 + parse_tbm%orb_set_type(1,parse_cur_type) = ORB_D + call QUIP_FoX_get_value(attributes, "E_d", value, status); + if (status == 0) read (value, *) parse_tbm%E(ORB_D,parse_cur_type) + else + call system_abort("TBModel_GSP_read_params_xml can only do d") + endif + + call QUIP_FoX_get_value(attributes, "n_elecs", value, status); + if (status == 0) read (value, *) parse_tbm%n_elecs(parse_cur_type) + + if (allocated(parse_tbm%type_of_atomic_num)) deallocate(parse_tbm%type_of_atomic_num) + allocate(parse_tbm%type_of_atomic_num(maxval(parse_tbm%atomic_num(:)))) + parse_tbm%type_of_atomic_num(:) = 0 + do ti=1, parse_tbm%n_types + if (parse_Tbm%atomic_num(ti) > 0) & + parse_tbm%type_of_atomic_num(parse_tbm%atomic_num(ti)) = ti + end do + +! Parameters of the repulsive environment-dependent term + call QUIP_FoX_get_value(attributes, "lambda0", value, status); + if (status == 0) read (value, *) parse_tbm%lambda0(parse_cur_type) + call QUIP_FoX_get_value(attributes, "C", value, status); + if (status == 0) read (value, *) parse_tbm%C(parse_cur_type) + call QUIP_FoX_get_value(attributes, "nu", value, status); + if (status == 0) read (value, *) parse_tbm%nu(parse_cur_type) + call QUIP_FoX_get_value(attributes, "m", value, status); + if (status == 0) read (value, *) parse_tbm%m(parse_cur_type) + call QUIP_FoX_get_value(attributes, "Rtail", value, status); + if (status == 0) read (value, *) parse_tbm%Rtail(parse_cur_type) + call QUIP_FoX_get_value(attributes, "Rcut", value, status); + if (status == 0) read (value, *) parse_tbm%Rcut(parse_cur_type) + + parse_cur_type = parse_cur_type + 1 + + elseif (parse_in_tbm .and. name == 'defaults') then + + call QUIP_FoX_get_value(attributes, "fermi_e", value, status) + if (status == 0) then + parse_tbm%has_default_fermi_e = .true. + read (value, *) parse_tbm%default_fermi_e + endif + call QUIP_FoX_get_value(attributes, "fermi_T", value, status) + if (status == 0) then + parse_tbm%has_default_fermi_T = .true. + read (value, *) parse_tbm%default_fermi_T + endif + call QUIP_FoX_get_value(attributes, "band_width", value, status) + if (status == 0) then + parse_tbm%has_default_band_width = .true. + read (value, *) parse_tbm%default_band_width + endif + call QUIP_FoX_get_value(attributes, "k_density", value, status) + if (status == 0) then + parse_tbm%has_default_k_density = .true. + read (value, *) parse_tbm%default_k_density + endif + + elseif (parse_in_tbm .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "Z1", value, status); + if (status == 0) read (value, *) Zi + call QUIP_FoX_get_value(attributes, "Z2", value, status); + if (status == 0) read (value, *) Zj + + ti = get_type(parse_tbm%type_of_atomic_num,Zi) + tj = get_type(parse_tbm%type_of_atomic_num,Zj) + + call QUIP_FoX_get_value(attributes, "rc", value, status); + if (status == 0) read (value, *) parse_tbm%rc(ti,tj) + call QUIP_FoX_get_value(attributes, "r0", value, status); + if (status == 0) read (value, *) parse_tbm%r0(ti,tj) + call QUIP_FoX_get_value(attributes, "na", value, status); + if (status == 0) read (value, *) parse_tbm%na(ti,tj) + call QUIP_FoX_get_value(attributes, "nb", value, status); + if (status == 0) read (value, *) parse_tbm%nb(ti,tj) + call QUIP_FoX_get_value(attributes, "nc", value, status); + if (status == 0) read (value, *) parse_tbm%nc(ti,tj) + +! parameters of the repulsive environment-dependent term + call QUIP_FoX_get_value(attributes, "B", value, status); + if (status == 0) read (value, *) parse_tbm%B(ti,tj) + call QUIP_FoX_get_value(attributes, "Rcore", value, status); + if (status == 0) read (value, *) parse_tbm%Rcore(ti,tj) + + call QUIP_FoX_get_value(attributes, "A1", value, status); + if (status == 0) read (value, *) parse_tbm%Ai(1,ti,tj) + call QUIP_FoX_get_value(attributes, "A2", value, status); + if (status == 0) read (value, *) parse_tbm%Ai(2,ti,tj) + call QUIP_FoX_get_value(attributes, "A3", value, status); + if (status == 0) read (value, *) parse_tbm%Ai(3,ti,tj) + call QUIP_FoX_get_value(attributes, "A4", value, status); + if (status == 0) read (value, *) parse_tbm%Ai(4,ti,tj) + call QUIP_FoX_get_value(attributes, "R1", value, status); + if (status == 0) read (value, *) parse_tbm%Ri(1,ti,tj) + call QUIP_FoX_get_value(attributes, "R2", value, status); + if (status == 0) read (value, *) parse_tbm%Ri(2,ti,tj) + call QUIP_FoX_get_value(attributes, "R3", value, status); + if (status == 0) read (value, *) parse_tbm%Ri(3,ti,tj) + call QUIP_FoX_get_value(attributes, "R4", value, status); + if (status == 0) read (value, *) parse_tbm%Ri(4,ti,tj) + + call QUIP_FoX_get_value(attributes, "H_dds", value, status); + if (status == 0) read (value, *) parse_tbm%H_coeff(SK_DDS,ti,tj) + call QUIP_FoX_get_value(attributes, "H_ddp", value, status); + if (status == 0) read (value, *) parse_tbm%H_coeff(SK_DDP,ti,tj) + call QUIP_FoX_get_value(attributes, "H_ddd", value, status); + if (status == 0) read (value, *) parse_tbm%H_coeff(SK_DDD,ti,tj) + + call QUIP_FoX_get_value(attributes, "O_dds", value, status); + if (status == 0) read (value, *) parse_tbm%O_coeff(SK_DDS,ti,tj) + call QUIP_FoX_get_value(attributes, "O_ddp", value, status); + if (status == 0) read (value, *) parse_tbm%O_coeff(SK_DDP,ti,tj) + call QUIP_FoX_get_value(attributes, "O_ddd", value, status); + if (status == 0) read (value, *) parse_tbm%O_coeff(SK_DDD,ti,tj) + + call QUIP_FoX_get_value(attributes, "Atau_dds", value, status); + if (status == 0) read (value, *) parse_tbm%Atau(SK_DDS,ti,tj) + call QUIP_FoX_get_value(attributes, "Atau_ddp", value, status); + if (status == 0) read (value, *) parse_tbm%Atau(SK_DDP,ti,tj) + call QUIP_FoX_get_value(attributes, "Atau_ddd", value, status); + if (status == 0) read (value, *) parse_tbm%Atau(SK_DDD,ti,tj) + + call QUIP_FoX_get_value(attributes, "deltatau0_dds", value, status); + if (status == 0) read (value, *) parse_tbm%deltatau0(SK_DDS,ti,tj) + call QUIP_FoX_get_value(attributes, "deltatau0_ddp", value, status); + if (status == 0) read (value, *) parse_tbm%deltatau0(SK_DDP,ti,tj) + call QUIP_FoX_get_value(attributes, "deltatau0_ddd", value, status); + if (status == 0) read (value, *) parse_tbm%deltatau0(SK_DDD,ti,tj) + + if (ti /= tj) then + parse_tbm%rc(tj,ti) = parse_tbm%rc(ti,tj) + parse_tbm%r0(tj,ti) = parse_tbm%r0(ti,tj) + parse_tbm%na(tj,ti) = parse_tbm%na(ti,tj) + parse_tbm%nb(tj,ti) = parse_tbm%nb(ti,tj) + parse_tbm%nc(tj,ti) = parse_tbm%nc(ti,tj) + parse_tbm%B(tj,ti) = parse_tbm%B(ti,tj) + parse_tbm%Rcore(tj,ti) = parse_tbm%Rcore(ti,tj) + parse_tbm%Ai(1,tj,ti) = parse_tbm%Ai(1,ti,tj) + parse_tbm%Ai(2,tj,ti) = parse_tbm%Ai(2,ti,tj) + parse_tbm%Ai(3,tj,ti) = parse_tbm%Ai(3,ti,tj) + parse_tbm%Ai(4,tj,ti) = parse_tbm%Ai(4,ti,tj) + parse_tbm%Ri(1,tj,ti) = parse_tbm%Ri(1,ti,tj) + parse_tbm%Ri(2,tj,ti) = parse_tbm%Ri(2,ti,tj) + parse_tbm%Ri(3,tj,ti) = parse_tbm%Ri(3,ti,tj) + parse_tbm%Ri(4,tj,ti) = parse_tbm%Ri(4,ti,tj) + parse_tbm%H_coeff(SK_DDS,tj,ti) = parse_tbm%H_coeff(SK_DDS,ti,tj) + parse_tbm%H_coeff(SK_DDP,tj,ti) = parse_tbm%H_coeff(SK_DDP,ti,tj) + parse_tbm%H_coeff(SK_DDD,tj,ti) = parse_tbm%H_coeff(SK_DDD,ti,tj) + parse_tbm%O_coeff(SK_DDS,tj,ti) = parse_tbm%O_coeff(SK_DDS,ti,tj) + parse_tbm%O_coeff(SK_DDP,tj,ti) = parse_tbm%O_coeff(SK_DDP,ti,tj) + parse_tbm%O_coeff(SK_DDD,tj,ti) = parse_tbm%O_coeff(SK_DDD,ti,tj) + parse_tbm%Atau(SK_DDS,tj,ti) = parse_tbm%Atau(SK_DDS,ti,tj) + parse_tbm%Atau(SK_DDP,tj,ti) = parse_tbm%Atau(SK_DDP,ti,tj) + parse_tbm%Atau(SK_DDD,tj,ti) = parse_tbm%Atau(SK_DDD,ti,tj) + parse_tbm%deltatau0(SK_DDS,tj,ti) = parse_tbm%deltatau0(SK_DDS,ti,tj) + parse_tbm%deltatau0(SK_DDP,tj,ti) = parse_tbm%deltatau0(SK_DDP,ti,tj) + parse_tbm%deltatau0(SK_DDD,tj,ti) = parse_tbm%deltatau0(SK_DDD,ti,tj) + end if + endif + +end subroutine TBM_startElement_handler + +subroutine TBM_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (name == 'GSP_params') then + parse_in_tbm = .false. + endif + +end subroutine TBM_endElement_handler + +subroutine TBModel_GSP_read_params_xml(this, param_str) + type(TBModel_GSP), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_tbm = .false. + parse_matched_label = .false. + parse_tbm => this + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + startElement_handler = TBM_startElement_handler, & + endElement_handler = TBM_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types <= 0) call system_abort("TBModel_GSP_read_params_xml couldn't find any types defined") +!" + call TBModel_GSP_fix_tails(this) + +end subroutine + +subroutine TBModel_GSP_fix_tails(this) + type(TBModel_GSP), intent(inout) :: this + + integer ti, tj + real(dp) :: x(2), y(2), yd1, yd2, x_env(2) + + x(1) = this%tailx0 + x(2) = this%cutoff_H + y(2) = 0.0_dp + yd2 = 0.0_dp + + allocate(this%H_tail_spline(this%n_types, this%n_types)) + allocate(this%Vrep_env_emb_tail_spline(this%n_types)) + + do ti=1, this%n_types + do tj=1, this%n_types + y(1) = TBModel_GSP_dist_scaling(x(1),this%r0(ti,tj), & + this%rc(ti,tj),this%na(ti,tj),this%nb(ti,tj),this%nc(ti,tj)) + yd1 = TBModel_GSP_dist_scaling_deriv(x(1),this%r0(ti,tj), & + this%rc(ti,tj),this%na(ti,tj),this%nb(ti,tj),this%nc(ti,tj)) + call initialise(this%H_tail_spline(ti,tj), x, y, yd1, yd2) + end do + + x_env(1) = this%Rtail(ti) + x_env(2) = this%Rcut(ti) + y(1) = TBModel_GSP_Vrep_env_emb_term(x_env(1),this%C(ti),this%nu(ti)) + yd1 = TBModel_GSP_Vrep_env_emb_term_deriv(x_env(1),this%C(ti),this%nu(ti)) + call initialise(this%Vrep_env_emb_tail_spline(ti), x_env, y, yd1, yd2) + end do + +end subroutine + +subroutine TBModel_GSP_Print(this,file) + type(TBModel_GSP), intent(in) :: this + type(Inoutput), intent(inout),optional :: file + + integer:: ti, tj + + if(this%n_types == 0) call System_Abort('TBModel_GSP_Print: TBModel_GSP structure not initialised') +!' + call Print('TBModel_GSP Structure:', file=file) + + !! print GSP params + call Print ("TBModel_GSP tailx0 " // this%tailx0 // " cutoff " // this%cutoff, file=file) + call Print (" " // " cutoff_H " // this%cutoff_H, file=file) + do ti=1, this%n_types + call Print ("TBModel_GSP type " // ti // " Z " // this%atomic_num(ti) // " n_orbs " // this%n_orbs(ti) // & + " n_elecs " // this%n_elecs(ti), file=file) + if (this%n_orb_sets(ti) == 1) then + call Print ("TBModel_GSP E " // this%E(1,ti), file=file) + else + call Print ("TBModel_GSP Es " // this%E(ORB_S,ti), file=file) + call Print ("TBModel_GSP Ed " // this%E(ORB_D,ti), file=file) + endif + end do + + call verbosity_push_decrement() + do ti=1, this%n_types + do tj=1, this%n_types + call Print ("TBModel_GSP interaction " // & + ti // " " // tj // " Z " // this%atomic_num(ti) // " " // this%atomic_num(tj), file=file) + + call Print ("TBModel_GSP r0 " // this%r0(ti,tj), file=file) + + call Print ("TBModel_GSP SK dds " // this%H_coeff(SK_DDS,ti,tj), file=file) + call Print ("TBModel_GSP SK ddp " // this%H_coeff(SK_DDP,ti,tj), file=file) + call Print ("TBModel_GSP SK ddd " // this%H_coeff(SK_DDD,ti,tj), file=file) + call Print ("TBModel_GSP Overlap coefficients dds " // this%O_coeff(SK_DDS,ti,tj), file=file) + call Print ("TBModel_GSP Overlap coefficients ddp " // this%O_coeff(SK_DDP,ti,tj), file=file) + call Print ("TBModel_GSP Overlap coefficients ddd " // this%O_coeff(SK_DDD,ti,tj), file=file) + call Print ("TBModel_GSP Atau dds " // this%Atau(SK_DDS,ti,tj), file=file) + call Print ("TBModel_GSP Atau ddp " // this%Atau(SK_DDP,ti,tj), file=file) + call Print ("TBModel_GSP Atau ddd " // this%Atau(SK_DDD,ti,tj), file=file) + call Print ("TBModel_GSP deltatau0 dds " // this%deltatau0(SK_DDS,ti,tj), file=file) + call Print ("TBModel_GSP deltatau0 ddp " // this%deltatau0(SK_DDP,ti,tj), file=file) + call Print ("TBModel_GSP deltatau0 ddd " // this%deltatau0(SK_DDD,ti,tj), file=file) + call Print ("TBModel_GSP H scaling rc na nb nc " // & + this%rc(ti,tj) // " " // this%na(ti,tj) // " " // this%nb(ti,tj) // " " // this%nc(ti,tj), file=file) + + call Print (this%H_tail_spline(ti,tj), file=file) + call Print (this%Vrep_env_emb_tail_spline(ti), file=file) + + call Print ("TBModel_GSP pair potential Vrep A1 A2 A3 A4 " // & + this%Ai(1,ti,tj) // " " // this%Ai(2,ti,tj) // " " // & + this%Ai(3,ti,tj) // " " // this%Ai(4,ti,tj), file=file) + call Print ("TBModel_GSP pair potential Vrep R1 R2 R3 R4 " // & + this%Ri(1,ti,tj) // " " // this%Ri(2,ti,tj) // " " // & + this%Ri(3,ti,tj) // " " // this%Ri(4,ti,tj), file=file) + + call Print ("TBModel_GSP Environmental Vrep : B Rcore " // & + this%B(ti,tj) // " " // this%Rcore(ti,tj), file=file) + end do + call Print ("TBModel_GSP Environmental Vrep : lambda0 nu " // & + this%lambda0(ti) // " " // this%nu(ti) , file=file) + call Print ("TBModel_GSP Environmental Vrep : C m " // & + this%c(ti) // " " // this%m(ti), file=file) + call Print ("TBModel_GSP Environmental Vrep : Rtail Rcut " // & + this%Rtail(ti) // " " // this%Rcut(ti), file=file) + end do + call verbosity_pop() + +end subroutine TBModel_GSP_Print + +function TBModel_GSP_n_orbs_of_Z(this, Z) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_GSP_n_orbs_of_Z + + TBModel_GSP_n_orbs_of_Z = this%n_orbs(get_type(this%type_of_atomic_num,Z)) +end function TBModel_GSP_n_orbs_of_Z + +function TBModel_GSP_n_orb_sets_of_Z(this, Z) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_GSP_n_orb_sets_of_Z + + TBModel_GSP_n_orb_sets_of_Z = this%n_orb_sets(get_type(this%type_of_atomic_num,Z)) +end function TBModel_GSP_n_orb_sets_of_Z + +function TBModel_GSP_n_orbs_of_orb_set_of_Z(this, Z, i_set) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_GSP_n_orbs_of_orb_set_of_Z + + TBModel_GSP_n_orbs_of_orb_set_of_Z = N_ORBS_OF_SET(this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z))) + +end function TBModel_GSP_n_orbs_of_orb_set_of_Z + +function TBModel_GSP_orb_type_of_orb_set_of_Z(this, Z, i_set) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_GSP_orb_type_of_orb_set_of_Z + + TBModel_GSP_orb_type_of_orb_set_of_Z = this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z)) + +end function TBModel_GSP_orb_type_of_orb_set_of_Z + +function TBModel_GSP_n_elecs_of_Z(this, Z) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: Z + real(dp) TBModel_GSP_n_elecs_of_Z + + TBModel_GSP_n_elecs_of_Z = this%n_elecs(get_type(this%type_of_atomic_num,Z)) +end function TBModel_GSP_n_elecs_of_Z + +subroutine TBModel_GSP_get_HS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, b_H, b_S) + type(TBModel_GSP), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, at_j + real(dp), intent(in) :: dv_hat(3), dv_mag + real(dp), intent(out) :: b_H(:,:) + real(dp), intent(out) :: b_S(:,:) + + integer i, j, ti, tj, is, js, i_set, j_set + real(dp) SK_frad_H(N_SK) + real(dp) dv_hat_sq(3) + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + tj = get_type(this%type_of_atomic_num,at%Z(at_j)) + + b_S = 0.0_dp + + if (dv_mag .feq. 0.0_dp) then + b_H = 0.0_dp + + i = 1 + do i_set = 1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + b_H(i,i) = onsite_function(this, ti, this%orb_set_type(i_set,ti)) + b_S(i,i) = 1.0_dp + i = i + 1 + end do + end do + + else + + dv_hat_sq = dv_hat**2 + + i = 1 + do i_set=1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + j = 1 + do j_set=1, this%n_orb_sets(tj) + call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + SK_frad_H) + do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) + + b_H(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H) + j = j + 1 + end do + end do + i = i + 1 + end do + end do + endif + +end subroutine TBModel_GSP_get_HS_blocks + +subroutine TBModel_GSP_get_dHS_masks(this, at_ind, d_mask, od_mask) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: at_ind + logical, intent(out), optional :: d_mask(:), od_mask(:) + + if (at_ind < 0) then + if (present(d_mask)) d_mask = .true. + if (present(od_mask)) od_mask = .true. + else + if (present(d_mask)) d_mask = .false. + if (present(od_mask)) then + od_mask = .false. + od_mask(at_ind) = .true. + endif + endif +end subroutine + +function TBModel_GSP_get_dHS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, at_ind, b_dH, b_dS) + type(TBModel_GSP), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, at_j + real(dp), intent(in) :: dv_hat(3), dv_mag + integer, intent(in) :: at_ind + real(dp), intent(out) :: b_dH(:,:,:) + real(dp), intent(out) :: b_dS(:,:,:) + logical :: TBModel_GSP_get_dHS_blocks + + integer :: i, j, ti, tj, is, js, i_set, j_set + real(dp) SK_frad_H(N_SK) + real(dp) SK_dfrad_H(N_SK) + real(dp) dv_hat_sq(3) + real(dp) virial_outerprod_fac + + if ((at_ind > 0 .and. at_i /= at_ind .and. at_j /= at_ind) .or. & + (at_ind > 0 .and. at_i == at_j) .or. & + (dv_mag > this%cutoff_H) .or. & + (dv_mag .feq. 0.0_dp)) then + TBModel_GSP_get_dHS_blocks = .false. + return + endif + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + tj = get_type(this%type_of_atomic_num,at%Z(at_j)) + + b_dS = 0.0_dp + + dv_hat_sq = dv_hat**2 + + i = 1 + do i_set=1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + j = 1 + do j_set=1, this%n_orb_sets(tj) + call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + SK_frad_H) + call dradial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + SK_dfrad_H) + do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) + + if (at_ind > 0) then + virial_outerprod_fac = 1.0_dp + else + virial_outerprod_fac = -dv_mag*dv_hat(-at_ind) + end if + b_dH(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & + this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H, SK_dfrad_H)*virial_outerprod_fac + j = j + 1 + end do + end do + i = i + 1 + end do + end do + + if (at_ind == at_j) b_dH = -b_dH + + TBModel_GSP_get_dHS_blocks = .true. + return + +end function TBModel_GSP_get_dHS_blocks + +subroutine radial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, f_H) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dv_mag + integer, intent(in) :: orb_set_type_i, orb_set_type_j + real(dp), intent(out) :: f_H(N_SK) + + if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then + f_H(SK_DDS) = calc_H_coeff(this, SK_DDS, dv_mag, ti, tj) + f_H(SK_DDP) = calc_H_coeff(this, SK_DDP, dv_mag, ti, tj) + f_H(SK_DDD) = calc_H_coeff(this, SK_DDD, dv_mag, ti, tj) + endif +end subroutine radial_functions + +subroutine dradial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, f_dH) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dv_mag + integer, intent(in) :: orb_set_type_i, orb_set_type_j + real(dp), intent(out) :: f_dH(N_SK) + + if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then + f_dH(SK_DDS) = calc_H_coeff_deriv(this, SK_DDS, dv_mag, ti, tj) + f_dH(SK_DDP) = calc_H_coeff_deriv(this, SK_DDP, dv_mag, ti, tj) + f_dH(SK_DDD) = calc_H_coeff_deriv(this, SK_DDD, dv_mag, ti, tj) + endif +end subroutine dradial_functions + +function TBModel_GSP_calc_H_coeff(this, sk_ind, dist, ti, tj) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: sk_ind + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_GSP_calc_H_coeff + + TBModel_GSP_calc_H_coeff = this%H_coeff(sk_ind, ti, tj)* & + TBModel_GSP_H_dist_func(this, dist, ti, tj) + +end function TBModel_GSP_calc_H_coeff + +function TBModel_GSP_calc_H_coeff_deriv(this, sk_ind, dist, ti, tj) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: sk_ind + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_GSP_calc_H_coeff_deriv + + TBModel_GSP_calc_H_coeff_deriv = this%H_coeff(sk_ind, ti, tj)* & + TBModel_GSP_H_dist_func_deriv(this, dist, ti, tj) + +end function TBModel_GSP_calc_H_coeff_deriv + +function TBModel_GSP_calc_O_coeff(this, sk_ind, dist, ti, tj) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: sk_ind + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_GSP_calc_O_coeff + + TBModel_GSP_calc_O_coeff = this%O_coeff(sk_ind, ti, tj)* & + TBModel_GSP_H_dist_func(this, dist, ti, tj) + +end function TBModel_GSP_calc_O_coeff + +function TBModel_GSP_calc_O_coeff_deriv(this, sk_ind, dist, ti, tj) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: sk_ind + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_GSP_calc_O_coeff_deriv + + TBModel_GSP_calc_O_coeff_deriv = this%O_coeff(sk_ind, ti, tj)* & + TBModel_GSP_H_dist_func_deriv(this, dist, ti, tj) + +end function TBModel_GSP_calc_O_coeff_deriv + +function TBModel_GSP_H_dist_func(this, dist, ti, tj) + type(TBModel_GSP), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_GSP_H_dist_func + + if (dist <= this%cutoff_H) then + if (dist <= this%tailx0) then + TBModel_GSP_H_dist_func = TBModel_GSP_dist_scaling(dist, & + this%r0(ti,tj),this%rc(ti,tj),this%na(ti,tj),this%nb(ti,tj),this%nc(ti,tj)) + else + TBModel_GSP_H_dist_func = spline_value(this%H_tail_spline(ti,tj), dist) + endif + else + TBModel_GSP_H_dist_func = 0.0_dp + endif +end function TBModel_GSP_H_dist_func + +function TBModel_GSP_H_dist_func_deriv(this, dist, ti, tj) + type(TBModel_GSP), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp) :: TBModel_GSP_H_dist_func_deriv + + if (dist <= this%cutoff_H) then + if (dist <= this%tailx0) then + TBModel_GSP_H_dist_func_deriv = TBModel_GSP_dist_scaling_deriv(dist, & + this%r0(ti,tj),this%rc(ti,tj),this%na(ti,tj),this%nb(ti,tj),this%nc(ti,tj)) + else + TBModel_GSP_H_dist_func_deriv = spline_deriv(this%H_tail_spline(ti,tj), dist) + endif + else + TBModel_GSP_H_dist_func_deriv = 0.0_dp + endif +end function TBModel_GSP_H_dist_func_deriv + +! Compute the screening function Sij_tau +function TBModel_GSP_screening(this,sk_ind,at,i,j,dist,ti,tj) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: sk_ind + type(Atoms) :: at + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + integer :: i,j + real(dp) :: TBModel_GSP_screening + + TBModel_GSP_screening = & + (TBModel_GSP_screening_c(this,sk_ind,at,i,j,dist,ti,tj) & + - TBModel_GSP_screening_mu(this) )/ & + (1._dp + TBModel_GSP_calc_O_coeff(this,sk_ind,dist,ti,tj)**2.0_dp - & + 2._dp * TBModel_GSP_screening_mu(this) ) + +end function TBModel_GSP_screening + +function TBModel_GSP_screening_c(this,sk_ind,at, i,j,dist,ti,tj) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: sk_ind + type(Atoms) :: at + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dist + integer :: i,j + real(dp) :: TBModel_GSP_screening_c + real(dp) :: c_temp + real(dp) :: rik, rjk + real(dp) :: g_i, g_j, g_j2, theta_i, theta_j + integer :: k, kk, ki, kj, tk + logical :: lgo + real(dp) :: cterm(15) + + c_temp = 0._dp + do ki = 1, n_neighbours(at, i) + k = neighbour(at, i, ki, rik) + if (rik .feq. 0.0_dp) cycle + tk = get_type(this%type_of_atomic_num, at%Z(k)) + rjk = distance(at, j, k, (/0, 0, 0/)) + + theta_i = cosine_neighbour(at,i,j,k) + theta_j = cosine_neighbour(at,j,i,k) + g_i = TBModel_GSP_screening_g(sk_ind,theta_i) + g_j = TBModel_GSP_screening_g(sk_ind,theta_j) + g_j2 = TBModel_GSP_screening_g(sk_ind,-theta_j) + + call TBModel_GSP_calc_c_terms(this) + !call TBModel_GSP_calc_c_terms(this,sk_ind,dist,rik,rjk,ti,tj,tk,g_i,g_j,g_j2,cterm) + + c_temp = c_temp + (cterm(1)*cterm(2) + cterm(3)*cterm(4))*cterm(5)*cterm(6) - & + cterm(7) *cterm(8) *cterm(9) *cterm(10)*cterm(10) - & + cterm(11)*cterm(12)*cterm(13)*cterm(14)*cterm(14) + enddo + + do kj =1, n_neighbours(at, j) + k = neighbour(at, j, kj, rjk) + if (rjk .feq. 0.0_dp) cycle + tk = get_type(this%type_of_atomic_num, at%Z(k)) + lgo = .true. + do ki=1, n_neighbours(at, i) + kk = neighbour(at, i, ki) + if(k.eq.kk) then + exit + lgo = .false. + endif + enddo + if(.not.lgo) cycle + rik = distance(at, i, k, (/0, 0, 0/)) + + theta_i = cosine_neighbour(at,i,j,k) + theta_j = cosine_neighbour(at,j,i,k) + g_i = TBModel_GSP_screening_g(sk_ind,theta_i) + g_j = TBModel_GSP_screening_g(sk_ind,theta_j) + g_j2 = TBModel_GSP_screening_g(sk_ind,-theta_j) + + !call TBModel_GSP_calc_c_terms(this,sk_ind,dist,rik,rjk,ti,tj,tk,g_i,g_j,g_j2,cterm) + call TBModel_GSP_calc_c_terms(this) + + c_temp = c_temp + (cterm(1)*cterm(2) + cterm(3)*cterm(4))*cterm(5)*cterm(6) - & + cterm(7) *cterm(8) *cterm(9) *cterm(10)*cterm(10) - & + cterm(11)*cterm(12)*cterm(13)*cterm(14)*cterm(14) + enddo + + TBModel_GSP_screening_c = & + this%Atau(sk_ind,ti,tj)*(1._dp + this%deltatau0(sk_ind,ti,tj))/4._dp/ & + TBModel_GSP_calc_H_coeff (this,sk_ind,dist,ti,tj) * c_temp + +end function TBModel_GSP_screening_c + +function TBModel_GSP_screening_c_deriv(this) + type(TBModel_GSP), intent(in) :: this + real(dp) :: TBModel_GSP_screening_c_deriv + + TBModel_GSP_screening_c_deriv = 0.d0 + +end function TBModel_GSP_screening_c_deriv + +function TBModel_GSP_screening_mu(this) + type(TBModel_GSP), intent(in) :: this + real(dp) :: TBModel_GSP_screening_mu + + TBModel_GSP_screening_mu = 0._dp + +end function TBModel_GSP_screening_mu + +function TBModel_GSP_screening_g(sk_ind,theta) + integer, intent(in) :: sk_ind + real(dp) :: theta + real(dp) :: TBModel_GSP_screening_g + + if(sk_ind.eq.SK_DDS) then + TBModel_GSP_screening_g = (1._dp/4._dp) * (1._dp + 3._dp* dcos(2._dp*theta)) + elseif(sk_ind.eq.SK_DDP) then + TBModel_GSP_screening_g = (dsqrt(3._dp)/2._dp)*dsin(2._dp*theta) + elseif(sk_ind.eq.SK_DDD) then + TBModel_GSP_screening_g = (dsqrt(3._dp)/4._dp)*(1._dp - dcos(2._dp*theta)) + endif + +end function TBModel_GSP_screening_g + +subroutine TBModel_GSP_calc_c_terms(this) + type(TBModel_GSP), intent(in) :: this +! integer, intent(in) :: sk_ind +! integer, intent(in) :: ti, tj, tk +! real(dp), intent(in) :: rij, rik, rjk +! real(dp) :: g_i, g_j, g_j2 +! real(dp) :: cterm(15) + +! cterm(1) = TBModel_GSP_calc_H_coeff(this,SK_SDS,rik,ti,tk) +! cterm(2) = TBModel_GSP_calc_O_coeff(this,SK_SDS,rjk,tk,tj) +! cterm(3) = TBModel_GSP_calc_O_coeff(this,SK_SDS,rik,ti,tk) +! cterm(4) = TBModel_GSP_calc_H_coeff(this,SK_SDS,rjk,tk,tj) +! cterm(5) = g_i +! cterm(6) = g_j2 +! cterm(7) = TBModel_GSP_calc_H_coeff(this,SK_SDS,rik,ti,tk) +! cterm(8) = TBModel_GSP_calc_O_coeff(this,SK_SDS,rik,tk,ti) +! cterm(9) = TBModel_GSP_calc_O_coeff(this,sk_ind,rij,ti,tj) +! cterm(10)= g_i +! cterm(11)= TBModel_GSP_calc_O_coeff(this,sk_ind,rij,ti,tj) +! cterm(12)= TBModel_GSP_calc_O_coeff(this,SK_SDS,rjk,tj,tk) +! cterm(13)= TBModel_GSP_calc_H_coeff(this,SK_SDS,rjk,tk,tj) +! cterm(14)= g_j +end subroutine TBModel_GSP_calc_c_terms + +subroutine TBModel_GSP_calc_c_terms_deriv(this) + type(TBModel_GSP), intent(in) :: this +! integer, intent(in) :: sk_ind +! integer, intent(in) :: ti, tj, tk +! real(dp), intent(in) :: rij, rik, rjk +! real(dp) :: dg_i, dg_j, dg_j2 +! real(dp) :: cterm_deriv(15) + +! cterm_deriv(1) = TBModel_GSP_calc_H_coeff_deriv(this,SK_SDS,rik,ti,tk) +! cterm_deriv(2) = TBModel_GSP_calc_O_coeff_deriv(this,SK_SDS,rjk,tk,tj) +! cterm_deriv(3) = TBModel_GSP_calc_O_coeff_deriv(this,SK_SDS,rik,ti,tk) +! cterm_deriv(4) = TBModel_GSP_calc_H_coeff_deriv(this,SK_SDS,rjk,tk,tj) +! cterm_deriv(5) = dg_i +! cterm_deriv(6) = dg_j2 +! cterm_deriv(7) = TBModel_GSP_calc_H_coeff_deriv(this,SK_SDS,rik,ti,tk) +! cterm_deriv(8) = TBModel_GSP_calc_O_coeff_deriv(this,SK_SDS,rik,tk,ti) +! cterm_deriv(9) = TBModel_GSP_calc_O_coeff_deriv(this,sk_ind,rij,ti,tj) +! cterm_deriv(10)= dg_i +! cterm_deriv(11)= TBModel_GSP_calc_O_coeff_deriv(this,sk_ind,rij,ti,tj) +! cterm_deriv(12)= TBModel_GSP_calc_O_coeff_deriv(this,SK_SDS,rjk,tj,tk) +! cterm_deriv(13)= TBModel_GSP_calc_H_coeff_deriv(this,SK_SDS,rjk,tk,tj) +! cterm_deriv(14)= dg_j +end subroutine TBModel_GSP_calc_c_terms_deriv + +!Compute the repulsive pair potential V(Rij) = sum_k A_k (R_k - Rij)**3 +function TBModel_GSP_Vrep_dist_func(this, dist, ti, tj) + type(TBModel_GSP), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + integer :: i + real(dp) :: TBModel_GSP_Vrep_dist_func + + TBModel_GSP_Vrep_dist_func = 0.0_dp + + do i = 1, 4 + if(dist.gt.this%Ri(i,ti,tj) ) cycle + TBModel_GSP_Vrep_dist_func = TBModel_GSP_Vrep_dist_func + this%Ai(i,ti,tj) * (this%Ri(i,ti,tj) - dist)**3.0_dp + enddo + +end function + +! Compute the derivative of the repulsive pair potential V(Rij) = sum_k A_k (R_k - Rij)**3 +function TBModel_GSP_Vrep_dist_func_deriv(this, dist, ti, tj) + type(TBModel_GSP), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + integer :: i + real(dp) :: TBModel_GSP_Vrep_dist_func_deriv + + TBModel_GSP_Vrep_dist_func_deriv = 0.0_dp + do i = 1, 4 + if(dist.gt.this%Ri(i,ti,tj) ) cycle + TBModel_GSP_Vrep_dist_func_deriv = TBModel_GSP_Vrep_dist_func_deriv - 3.0_dp * this%Ai(i,ti,tj) * (this%Ri(i,ti,tj) - dist)**2.0_dp + enddo +end function TBModel_GSP_Vrep_dist_func_deriv + +! Compute the environmental Repulsive pair potential +function TBModel_GSP_Vrep_env(this,dist,lambda,ti,tj) + type(TBModel_GSP), intent(in) :: this + real(dp), intent(in) :: dist + real(dp) :: lambda + integer, intent(in) :: ti, tj + real(dp) :: TBModel_GSP_Vrep_env + + TBModel_GSP_Vrep_env = this%B(ti,tj)/dist * & + dexp(-lambda*(dist - 2.0_dp* this%Rcore(ti,tj))) + +end function TBModel_GSP_Vrep_env + +! Compute the derivative (term ij) of the environmental Repulsive pair potential +function TBModel_GSP_Vrep_env_deriv_ij(this,dist,ti,tj,lambda) + + type(TBModel_GSP), intent(in) :: this + real(dp), intent(in) :: dist + integer, intent(in) :: ti, tj + real(dp), intent(in) :: lambda + real(dp) :: TBModel_GSP_Vrep_env_deriv_ij + + TBModel_GSP_Vrep_env_deriv_ij = - this%B(ti,tj)/dist * & + dexp(-lambda*(dist - 2.0_dp* this%Rcore(ti,tj))) * & + (1.0_dp/dist + lambda) + +end function TBModel_GSP_Vrep_env_deriv_ij + +! Compute the derivative (term wk) of the environmental Repulsive pair potential +function TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,ti,tj,emb_i,lambda) + type(TBModel_GSP), intent(in) :: this + real(dp), intent(in) :: dist, dist_k + integer, intent(in) :: ti, tj + real(dp) :: emb_i + real(dp) :: lambda + real(dp) :: emb_term_deriv + real(dp) :: TBModel_GSP_Vrep_env_deriv_wk + + if(dist_k.lt.this%Rtail(ti)) then + emb_term_deriv = TBModel_GSP_Vrep_env_emb_term_deriv(dist_k,this%C(ti),this%nu(ti)) + elseif(dist_k.lt.this%Rcut(ti)) then + emb_term_deriv = spline_deriv(this%Vrep_env_emb_tail_spline(ti), dist_k) + else + emb_term_deriv = 0.0_dp + endif + + TBModel_GSP_Vrep_env_deriv_wk = - this%B(ti,tj)/dist/this%m(ti)/2.0_dp * & + (dist - 2.0_dp* this%Rcore(ti,tj)) * & + dexp(-lambda * (dist - 2.0_dp* this%Rcore(ti,tj)))*& + emb_i ** ((1-this%m(ti))/this%m(ti)) * & + emb_term_deriv + +end function TBModel_GSP_Vrep_env_deriv_wk + +! Compute the embedded-atom expression => Sum C exp(-nu Rik) +function TBModel_GSP_Vrep_env_emb(this, at, i, ti) + type(TBModel_GSP), intent(in) :: this + type(Atoms), intent(in) :: at + integer :: i, ti, k + integer :: ki + real(dp) :: emb, rik + real(dp) :: TBModel_GSP_Vrep_env_emb + + emb = 0.0_dp + do ki=1, n_neighbours(at, i) + k = neighbour(at, i, ki, rik) + if (rik .feq. 0.0_dp) cycle + if(rik.lt.this%Rtail(ti)) then + emb = emb + TBModel_GSP_Vrep_env_emb_term(rik,this%C(ti),this%nu(ti)) + elseif(rik.lt.this%Rcut(ti)) then + emb = emb + spline_value(this%Vrep_env_emb_tail_spline(ti),rik) + endif + enddo + TBModel_GSP_Vrep_env_emb = emb +end function TBModel_GSP_Vrep_env_emb + +! compute C exp(-nu Rij) +function TBModel_GSP_Vrep_env_emb_term(dist,C, nu) + real(dp), intent(in) :: C, nu + real(dp), intent(in) :: dist + real(dp) :: TBModel_GSP_Vrep_env_emb_term + + TBModel_GSP_Vrep_env_emb_term = C * dexp(-nu*dist) + +end function TBModel_GSP_Vrep_env_emb_term + +! compute derivative of C exp(-nu Rij) +function TBModel_GSP_Vrep_env_emb_term_deriv(dist,C, nu) + real(dp), intent(in) :: C, nu + real(dp), intent(in) :: dist + real(dp) :: TBModel_GSP_Vrep_env_emb_term_deriv + + TBModel_GSP_Vrep_env_emb_term_deriv = - nu * C * dexp(-nu*dist) + +end function TBModel_GSP_Vrep_env_emb_term_deriv + +! Compute lambda, necessary for the embedded-atom like repulsive potential +function TBModel_GSP_Vrep_env_lambda(this,ti,tj,emb_i,emb_j) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp) :: emb_i, emb_j + real(dp) :: lambda_i, lambda_j + real(dp) :: TBModel_GSP_Vrep_env_lambda + + lambda_i = this%lambda0(ti) + emb_i**(1/this%m(ti)) + lambda_j = this%lambda0(tj) + emb_j**(1/this%m(tj)) + TBModel_GSP_Vrep_env_lambda = (lambda_i + lambda_j)/2.0_dp + +end function TBModel_GSP_Vrep_env_lambda + +! Scaling factor for the hopping parameters +function TBModel_GSP_dist_scaling(r, r0, rc, na, nb, nc) + real(dp), intent(in) :: r, r0, rc, na, nb, nc + real(dp) :: TBModel_GSP_dist_scaling + + TBModel_GSP_dist_scaling = (r0/r)**na * exp(nb* ((r0/rc)**nc - (r/rc)**nc)) + +end function TBModel_GSP_dist_scaling + +! Scaling factor derivative for the hopping parameters +function TBModel_GSP_dist_scaling_deriv(r, r0, rc, na, nb, nc) + real(dp), intent(in) :: r, r0, rc, na, nb, nc + real(dp) :: TBModel_GSP_dist_scaling_deriv + + real(dp) tmp1, tmp2 + + tmp1 = (r0/r)**na + tmp2 = exp(nb*((r0/rc)**nc - (r/rc)**nc)) + + TBModel_GSP_dist_scaling_deriv = na*tmp1/(-r)*tmp2 + tmp1*tmp2*(-nb)*nc*((r/rc)**nc)/r +end function TBModel_GSP_dist_scaling_deriv + +function onsite_function(this, ti, orb_set_type) + type(TBModel_GSP), intent(in) :: this + integer, intent(in) :: ti, orb_set_type + real(dp) :: onsite_function + + onsite_function = this%E(orb_set_type, ti) + +end function onsite_function + +!Repulsive term: Pure two body potential + Repulsive embedded-atom like potential +function TBModel_GSP_get_local_rep_E(this, at, i) + type(TBModel_GSP), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: emb_i, emb_j, lambda_ij + real(dp) :: TBModel_GSP_get_local_rep_E + + real(dp) :: E, dist + integer ji, j, ti, tj + + TBModel_GSP_get_local_rep_E = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + emb_i = TBModel_GSP_Vrep_env_emb(this, at, i, ti) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + emb_j = TBModel_GSP_Vrep_env_emb(this, at, j, tj) + lambda_ij = TBModel_GSP_Vrep_env_lambda(this,ti,tj,emb_i,emb_j) + + E = TBModel_GSP_Vrep_dist_func(this,dist,ti,tj) + & + TBModel_GSP_Vrep_env(this,dist,lambda_ij,ti,tj) + + TBModel_GSP_get_local_rep_E = TBModel_GSP_get_local_rep_E + E/2.0_dp + end do + +end function TBModel_GSP_get_local_rep_E + +! Forces due to the repulsive term: two body potential + embedded-atom like potential +function TBModel_GSP_get_local_rep_E_force(this, at, i) result(force) + type(TBModel_GSP), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: force(3,at%N) + + real(dp) :: dE_dr, dist, dist_k, dv_hat(3) + real(dp) :: emb_i, emb_j + real(dp) :: lambda_ij + integer :: ji, j, ti, tj + integer :: k, ik, jk + + force = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + emb_i = TBModel_GSP_Vrep_env_emb(this, at, i, ti) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist, cosines = dv_hat) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + emb_j = TBModel_GSP_Vrep_env_emb(this, at, j, tj) + lambda_ij = TBModel_GSP_Vrep_env_lambda(this,ti,tj,emb_i,emb_j) + + dE_dr = TBModel_GSP_Vrep_dist_func_deriv(this, dist, ti, tj) + & + TBModel_GSP_Vrep_env_deriv_ij(this,dist,ti,tj,lambda_ij) + force(:,i) = force(:,i) + dE_dr*dv_hat(:)/2.0_dp + force(:,j) = force(:,j) - dE_dr*dv_hat(:)/2.0_dp + + do ik = 1, n_neighbours(at, i) + k = neighbour(at, i, ik, dist_k, cosines = dv_hat) + if (dist_k .feq. 0.0_dp) cycle + dE_dr = TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,ti,tj,emb_i,lambda_ij) + force(:,i) = force(:,i) + dE_dr*dv_hat(:)/2.0_dp + force(:,k) = force(:,k) - dE_dr*dv_hat(:)/2.0_dp + enddo + + do jk = 1, n_neighbours(at, j) + k = neighbour(at, j, jk, dist_k, cosines = dv_hat) + if (dist_k .feq. 0.0_dp) cycle + dE_dr = TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,tj,ti,emb_j,lambda_ij) + force(:,j) = force(:,j) + dE_dr*dv_hat(:)/2.0_dp + force(:,k) = force(:,k) - dE_dr*dv_hat(:)/2.0_dp + enddo + end do +end function TBModel_GSP_get_local_rep_E_force + +function TBModel_GSP_get_local_rep_E_virial(this, at, i) result(virial) + type(TBModel_GSP), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: virial(3,3) + real(dp) :: lambda_ij + + real(dp) :: emb_i, emb_j + real(dp) :: dE_dr, dist, dist_k, dv_hat(3) + integer :: ji, j, ti, tj, k, ik, jk + + virial = 0.0_dp + + ti = get_type(this%type_of_atomic_num, at%Z(i)) + emb_i = TBModel_GSP_Vrep_env_emb(this, at, i, ti) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dist, cosines = dv_hat) + if (dist .feq. 0.0_dp) cycle + tj = get_type(this%type_of_atomic_num, at%Z(j)) + emb_j = TBModel_GSP_Vrep_env_emb(this, at, j, tj) + lambda_ij = TBModel_GSP_Vrep_env_lambda(this,ti,tj,emb_i,emb_j) + + dE_dr = TBModel_GSP_Vrep_dist_func_deriv(this, dist, ti, tj) + & + TBModel_GSP_Vrep_env_deriv_ij(this,dist,ti,tj,lambda_ij) + virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist / 2.0_dp + + do ik = 1, n_neighbours(at, i) + k = neighbour(at, i, ik, dist_k, cosines = dv_hat) + if (dist_k .feq. 0.0_dp) cycle + dE_dr = TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,ti,tj,emb_i,lambda_ij) + virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist_k / 2.0_dp + enddo + + do jk = 1, n_neighbours(at, j) + k = neighbour(at, j, jk, dist_k, cosines = dv_hat) + if (dist_k .feq. 0.0_dp) cycle + dE_dr = TBModel_GSP_Vrep_env_deriv_wk(this,dist,dist_k,tj,ti,emb_j,lambda_ij) + virial = virial - dE_dr*(dv_hat .outer. dv_hat) * dist_k / 2.0_dp + enddo + end do + +end function TBModel_GSP_get_local_rep_E_virial + +end module TBModel_GSP_module + diff --git a/src/Potentials/TBModel_NRL_TB.F90 b/src/Potentials/TBModel_NRL_TB.F90 new file mode 100644 index 0000000000..d343a2dc08 --- /dev/null +++ b/src/Potentials/TBModel_NRL_TB.F90 @@ -0,0 +1,1921 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X TBModel_NRL_TB module +!X +!% Calculate energies using NRL-TB tight-binding model +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module TBModel_NRL_TB_module + +use system_module, only : dp, print, inoutput, optional_default, system_abort, verbosity_push_decrement, verbosity_pop +use periodictable_module +use units_module +use linearalgebra_module +use dictionary_module +use extendable_str_module +use paramreader_module +use atoms_module +use error_module + +use TB_Common_module +use QUIP_Common_module +use TBModel_NRL_TB_defs_module + +implicit none +private + +! character(30) :: nrltb_default_file = "tightbind.parms.NRL_TB.xml" + +include 'TBModel_interface.h' + +public :: TBModel_NRL_TB +type TBModel_NRL_TB + integer :: n_types = 0, n_mag = 0 + logical :: is_orthogonal = .true., is_magnetic = .false., has_pair_repulsion = .false., & + overlap_zero_limit = .true., force_harrison_signs = .false., has_short_ranged_splines = .false. + character(len=STRING_LENGTH) label + + real(dp) :: cutoff = 0.0_dp + + integer, allocatable :: type_of_atomic_num(:) + integer, allocatable :: n_orbs(:), n_elecs(:), n_orb_sets(:), orb_set_type(:,:) + integer, allocatable :: atomic_num(:) + + real(dp), allocatable :: atomic_mass(:) + real(dp), allocatable :: r_cut(:,:), screen_l(:,:) + real(dp), allocatable :: pair_rep_inner(:,:), pair_rep_outer(:,:) + real(dp), allocatable :: r_min_spline(:,:), sigma_spline(:,:) + + real(dp), allocatable :: lambda_sq(:,:) + real(dp), allocatable :: abcd(:,:,:,:,:) + + real(dp), allocatable :: H_coeff(:,:,:,:,:), S_coeff(:,:,:,:,:) + + logical :: has_default_fermi_e = .false., has_default_fermi_T = .true., has_default_band_width = .false., has_default_k_density=.false. + real(dp) :: default_fermi_e, default_fermi_T = 0.001_dp, default_band_width, default_k_density + +end type TBModel_NRL_TB + +integer :: parse_cur_type_i, parse_cur_type_j +type(extendable_str), private, save :: parse_cur_data +logical, private :: parse_in_tbm, parse_matched_label +type (TBModel_NRL_TB), pointer :: parse_tbm + + + +interface Initialise + module procedure TBModel_NRL_TB_Initialise_str +end interface Initialise + +interface Finalise + module procedure TBModel_NRL_TB_Finalise +end interface Finalise + +interface Print + module procedure TBModel_NRL_TB_Print +end interface Print + +interface n_orbs_of_Z + module procedure TBModel_NRL_TB_n_orbs_of_Z +end interface n_orbs_of_Z + +interface n_orb_sets_of_Z + module procedure TBModel_NRL_TB_n_orb_sets_of_Z +end interface n_orb_sets_of_Z + +interface n_orbs_of_orb_set_of_Z + module procedure TBModel_NRL_TB_n_orbs_of_orb_set_of_Z +end interface n_orbs_of_orb_set_of_Z + +interface orb_type_of_orb_set_of_Z + module procedure TBModel_NRL_TB_orb_type_of_orb_set_of_Z +end interface orb_type_of_orb_set_of_Z + +interface n_elecs_of_Z + module procedure TBModel_NRL_TB_n_elecs_of_Z +end interface n_elecs_of_Z + +interface get_HS_blocks + module procedure TBModel_NRL_TB_get_HS_blocks +end interface get_HS_blocks + +interface get_dHS_masks + module procedure TBModel_NRL_TB_get_dHS_masks +end interface get_dHS_masks + +interface get_dHS_blocks + module procedure TBModel_NRL_TB_get_dHS_blocks +end interface get_dHS_blocks + +interface get_local_rep_E + module procedure TBModel_NRL_TB_get_local_rep_E +end interface get_local_rep_E + +interface get_local_rep_E_force + module procedure TBModel_NRL_TB_get_local_rep_E_force +end interface get_local_rep_E_force + +interface get_local_rep_E_virial + module procedure TBModel_NRL_TB_get_local_rep_E_virial +end interface get_local_rep_E_virial + +contains + +subroutine TBModel_NRL_TB_Initialise_str(this, args_str, param_str) + type(TBModel_NRL_TB), intent(inout) :: this + character(len=*), intent(in) :: args_str + character(len=*), intent(in) :: param_str + + type(Dictionary) :: params + + call Finalise(this) + + call initialise(params) + this%label='' + call param_register(params, 'label', '', this%label, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBModel_NRL_TB_Initialise_str args_str')) then + call system_abort("TBModel_NRL_TB_Initialise_str failed to parse label from args_str="//trim(args_str)) + endif + call finalise(params) + + call TBModel_NRL_TB_read_params_xml(this, param_str) +end subroutine TBModel_NRL_TB_Initialise_str + +subroutine TBModel_NRL_TB_Finalise(this) + type(TBModel_NRL_TB), intent(inout) :: this + + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%n_orbs)) deallocate(this%n_orbs) + if (allocated(this%n_elecs)) deallocate(this%n_elecs) + if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) + if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) + + if (allocated(this%atomic_mass)) deallocate(this%atomic_mass) + if (allocated(this%r_cut)) deallocate(this%r_cut) + if (allocated(this%screen_l)) deallocate(this%screen_l) + if (allocated(this%pair_rep_inner)) deallocate(this%pair_rep_inner) + if (allocated(this%pair_rep_outer)) deallocate(this%pair_rep_outer) + + if (allocated(this%lambda_sq)) deallocate(this%lambda_sq) + if (allocated(this%abcd)) deallocate(this%abcd) + if (allocated(this%H_coeff)) deallocate(this%H_coeff) + if (allocated(this%S_coeff)) deallocate(this%S_coeff) + + this%n_types = 0 + this%n_mag = 0 + this%label = '' +end subroutine TBModel_NRL_TB_Finalise + +subroutine TBM_characters_handler(in) + character(len=*), intent(in) :: in + + if (parse_in_tbm) then + call concat(parse_cur_data, in, keep_lf=.false.) + endif +end subroutine TBM_characters_handler + +subroutine TBM_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: value + + integer ii, ti, tj + + print *, "TBM_startElement_handler" + + call zero(parse_cur_data) + + if (name == 'NRL_TB_params') then ! new NRL_TB stanza + + if (parse_in_tbm) & + call system_abort("IPModel_startElement_handler entered NRL_TB_params with parse_in true. Probably a bug in FoX (4.0.1, e.g.)") + + if (parse_matched_label) return ! we already found an exact match for this label + + call QUIP_FoX_get_value(attributes, 'label', value, status) + if (status /= 0) value = '' + + if (len(trim(parse_tbm%label)) > 0) then ! we were passed in a label + if (value == parse_tbm%label) then ! exact match + parse_matched_label = .true. + parse_in_tbm = .true. + else ! no match + parse_in_tbm = .false. + endif + else ! no label passed in + parse_in_tbm = .true. + endif + + if (parse_in_tbm) then + call Initialise(parse_cur_data) + if (parse_tbm%n_types /= 0) then + call finalise(parse_tbm) + endif + endif + + elseif (parse_in_tbm .and. name == 'defaults') then + + call QUIP_FoX_get_value(attributes, "fermi_e", value, status) + if (status == 0) then + parse_tbm%has_default_fermi_e = .true. + read (value, *) parse_tbm%default_fermi_e + endif + call QUIP_FoX_get_value(attributes, "fermi_T", value, status) + if (status == 0) then + parse_tbm%has_default_fermi_T = .true. + read (value, *) parse_tbm%default_fermi_T + endif + call QUIP_FoX_get_value(attributes, "band_width", value, status) + if (status == 0) then + parse_tbm%has_default_band_width = .true. + read (value, *) parse_tbm%default_band_width + endif + call QUIP_FoX_get_value(attributes, "k_density", value, status) + if (status == 0) then + parse_tbm%has_default_k_density = .true. + read (value, *) parse_tbm%default_k_density + endif + + elseif (parse_in_tbm .and. name == 'header') then + + call QUIP_FoX_get_value(attributes, "is_orthogonal", value, status); + if (status == 0) read (value, *) parse_tbm%is_orthogonal + call QUIP_FoX_get_value(attributes, "is_magnetic", value, status) + if (status == 0) read (value, *) parse_tbm%is_magnetic + if (parse_tbm%is_magnetic) then + parse_tbm%n_mag = 2 + else + parse_tbm%n_mag = 1 + endif + call QUIP_FoX_get_value(attributes, "has_pair_repulsion", value, status) + if (status == 0) read (value, *) parse_tbm%has_pair_repulsion + call QUIP_FoX_get_value(attributes, "overlap_zero_limit", value, status) + if (status == 0) read (value, *) parse_tbm%overlap_zero_limit + call QUIP_FoX_get_value(attributes, "force_harrison_signs", value, status) + if (status == 0) read (value, *) parse_tbm%force_harrison_signs + call QUIP_FoX_get_value(attributes, "has_short_ranged_splines", value, status) + if (status == 0) read (value, *) parse_tbm%has_short_ranged_splines + + elseif (parse_in_tbm .and. name == 'n_types') then + + call QUIP_FoX_get_value(attributes, "v", value, status); + if (status == 0) read (value, *) parse_tbm%n_types + + allocate(parse_tbm%atomic_num(parse_tbm%n_types)) + parse_tbm%atomic_num = 0 + allocate(parse_tbm%atomic_mass(parse_tbm%n_types)) + allocate(parse_tbm%n_orbs(parse_tbm%n_types)) + allocate(parse_tbm%n_elecs(parse_tbm%n_types)) + allocate(parse_tbm%n_orb_sets(parse_tbm%n_types)) + allocate(parse_tbm%orb_set_type(max_n_orb_sets,parse_tbm%n_types)) + allocate(parse_tbm%r_cut(parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%screen_l(parse_tbm%n_types,parse_tbm%n_types)) + if (parse_tbm%has_pair_repulsion) then + allocate(parse_tbm%pair_rep_inner(parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%pair_rep_outer(parse_tbm%n_types,parse_tbm%n_types)) + endif + if (parse_tbm%has_short_ranged_splines) then + allocate(parse_tbm%r_min_spline(parse_tbm%n_types,parse_tbm%n_types)) + allocate(parse_tbm%sigma_spline(parse_tbm%n_types,parse_tbm%n_types)) + endif + allocate(parse_tbm%lambda_sq(parse_tbm%n_types,parse_tbm%n_mag)) + allocate(parse_tbm%abcd(4,max_n_orb_sets,parse_tbm%n_types,parse_tbm%n_types,parse_tbm%n_mag)) + allocate(parse_tbm%H_coeff(4,N_SK,parse_tbm%n_types,parse_tbm%n_types,parse_tbm%n_mag)) + allocate(parse_tbm%S_coeff(4,N_SK,parse_tbm%n_types,parse_tbm%n_types,parse_tbm%n_mag)) + + elseif (parse_in_tbm .and. name == 'per_type_data') then + + if (parse_tbm%n_types == 0) & + call system_abort("NRL_TB_params got to per_type_data before finding n_types") + + call QUIP_FoX_get_value(attributes, "type", value, status); + if (status == 0) read (value, *) ti + + call QUIP_FoX_get_value(attributes, "atomic_mass", value, status); + if (status == 0) read (value, *) parse_tbm%atomic_mass(ti) + parse_tbm%atomic_num(ti) = 0 + call QUIP_FoX_get_value(attributes, "atomic_num", value, status); + if (status == 0) read (value, *) parse_tbm%atomic_num(ti) + if (parse_tbm%atomic_num(ti) == 0) then + parse_tbm%atomic_num(ti) = Atomic_Number_from_Mass(parse_tbm%atomic_mass(ti)) + endif + call QUIP_FoX_get_value(attributes, "n_orbs", value, status); + if (status == 0) read (value, *) parse_tbm%n_orbs(ti) + call QUIP_FoX_get_value(attributes, "n_elecs", value, status); + if (status == 0) read (value, *) parse_tbm%n_elecs(ti) + call QUIP_FoX_get_value(attributes, "n_orb_sets", value, status); + if (status == 0) read (value, *) parse_tbm%n_orb_sets(ti) + if (parse_tbm%is_magnetic) then + call QUIP_FoX_get_value(attributes, "lambda_sq_up", value, status); + if (status == 0) read (value, *) parse_tbm%lambda_sq(ti,1) + call QUIP_FoX_get_value(attributes, "lambda_sq_down", value, status); + if (status == 0) read (value, *) parse_tbm%lambda_sq(ti,2) + else + call QUIP_FoX_get_value(attributes, "lambda_sq", value, status); + if (status == 0) read (value, *) parse_tbm%lambda_sq(ti,:) + endif + + if (allocated(parse_tbm%type_of_atomic_num)) deallocate(parse_tbm%type_of_atomic_num) + allocate(parse_tbm%type_of_atomic_num(maxval(parse_tbm%atomic_num(:)))) + parse_tbm%type_of_atomic_num(:) = 0 + do ii=1, parse_tbm%n_types + if (parse_tbm%atomic_num(ii) > 0) & + parse_tbm%type_of_atomic_num(parse_tbm%atomic_num(ii)) = ii + end do + + parse_cur_type_i = ti + parse_cur_type_j = ti + + elseif (parse_in_tbm .and. name == 'orb_set_type') then + + call zero(parse_cur_data) + + elseif (parse_in_tbm .and. name == 'per_pair_data') then + + call QUIP_FoX_get_value(attributes, "type1", value, status); + if (status == 0) read (value, *) ti + call QUIP_FoX_get_value(attributes, "type2", value, status); + if (status == 0) read (value, *) tj + call QUIP_FoX_get_value(attributes, "r_cut", value, status); + if (status == 0) read (value, *) parse_tbm%r_cut(ti,tj) + call QUIP_FoX_get_value(attributes, "screen_l", value, status); + if (status == 0) read (value, *) parse_tbm%screen_l(ti,tj) + if (parse_tbm%has_pair_repulsion) then + call QUIP_FoX_get_value(attributes, "pair_rep_inner", value, status); + if (status == 0) read (value, *) parse_tbm%pair_rep_inner(ti,tj) + call QUIP_FoX_get_value(attributes, "pair_rep_outer", value, status); + if (status == 0) read (value, *) parse_tbm%pair_rep_outer(ti,tj) + endif + if (parse_tbm%has_short_ranged_splines) then + call QUIP_FoX_get_value(attributes, "r_min_spline", value, status); + if (status == 0) read (value, *) parse_tbm%r_min_spline(ti,tj) + call QUIP_FoX_get_value(attributes, "sigma_spline", value, status); + if (status == 0) read (value, *) parse_tbm%sigma_spline(ti,tj) + endif + + parse_cur_type_i = ti + parse_cur_type_j = tj + + elseif (parse_in_tbm .and. name == 'abcd') then + + call zero(parse_cur_data) + + elseif (parse_in_tbm .and. name == 'H_coeff') then + + call zero(parse_cur_data) + + elseif (parse_in_tbm .and. name == 'S_coeff') then + + call zero(parse_cur_data) + + endif + +end subroutine TBM_startElement_handler + +subroutine TBM_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + character(len=10240) :: val + real(dp) :: abcd_v(32), coeff_v(160) + integer k + + if (parse_in_tbm) then + if (name == 'NRL_TB_params') then + parse_in_tbm = .false. + elseif (name == 'orb_set_type') then + val = string(parse_cur_data) + read (val, *) parse_tbm%orb_set_type(1:parse_tbm%n_orb_sets(parse_cur_type_i),parse_cur_type_i) + elseif (name == 'abcd') then + val = string(parse_cur_data) + if (parse_tbm%is_magnetic) then + if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals + read (val, *) abcd_v(1:32) + parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(1:4) + parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(5:8) + parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(9:12) + parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(13:16) + parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(17:20) + parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(21:24) + parse_tbm%abcd(1:4,4,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(25:28) + parse_tbm%abcd(1:4,4,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(29:32) + else ! no f orbitals + read (val, *) abcd_v(1:24) + parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(1:4) + parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(5:8) + parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(9:12) + parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(13:16) + parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(17:20) + parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,2) = abcd_v(21:24) + endif + else + if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals + read (val, *) abcd_v(1:16) + parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(1:4) + parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(5:8) + parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(9:12) + parse_tbm%abcd(1:4,4,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(13:16) + else ! no f orbitals + read (val, *) abcd_v(1:12) + parse_tbm%abcd(1:4,1,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(1:4) + parse_tbm%abcd(1:4,2,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(5:8) + parse_tbm%abcd(1:4,3,parse_cur_type_i,parse_cur_type_j,1) = abcd_v(9:12) + endif + endif + elseif (name == 'H_coeff') then + val = string(parse_cur_data) + if (parse_tbm%is_magnetic) then + if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals + read (val, *) coeff_v(1:160) + else ! no f orbitals + read (val, *) coeff_v(1:80) + coeff_v(81:160) = 0.0_dp + endif + do k=1, 20 + parse_tbm%H_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,1) = coeff_v(8*(k-1)+1:8*(k-1)+4) + parse_tbm%H_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,2) = coeff_v(8*(k-1)+5:8*(k-1)+8) + end do + else + if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals + read (val, *) coeff_v(1:80) + else ! no f orbitals + read (val, *) coeff_v(1:40) + coeff_v(41:80) = 0.0_dp + endif + do k=1, 20 + parse_tbm%H_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,1) = coeff_v(4*(k-1)+1:4*(k-1)+4) + end do + endif + elseif (name == 'S_coeff') then + val = string(parse_cur_data) + if (parse_tbm%is_magnetic) then + if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals + read (val, *) coeff_v(1:160) + else ! no f orbitals + read (val, *) coeff_v(1:80) + coeff_v(81:160) = 0.0_dp + endif + do k=1, 20 + parse_tbm%S_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,1) = coeff_v(8*(k-1)+1:8*(k-1)+4) + parse_tbm%S_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,2) = coeff_v(8*(k-1)+5:8*(k-1)+8) + end do + else + if (parse_tbm%n_orb_sets(parse_cur_type_i) == 4) then ! f orbitals + read (val, *) coeff_v(1:80) + else ! no f orbitals + read (val, *) coeff_v(1:40) + coeff_v(41:80) = 0.0_dp + endif + do k=1, 20 + parse_tbm%S_coeff(1:4,k,parse_cur_type_i,parse_cur_type_j,1) = coeff_v(4*(k-1)+1:4*(k-1)+4) + end do + endif + endif + endif + +end subroutine TBM_endElement_handler + +subroutine TBModel_NRL_TB_read_params_xml(this, param_str) + type(TBModel_NRL_TB), intent(inout), target :: this + character(len=*), intent(in) :: param_str + + type(xml_t) :: fxml + + if (len(trim(param_str)) <= 0) return + + parse_in_tbm = .false. + parse_matched_label = .false. + parse_tbm => this + call Initialise(parse_cur_data) + + call open_xml_string(fxml, param_str) + + call parse(fxml, & + characters_handler = TBM_characters_handler, & + startElement_handler = TBM_startElement_handler, & + endElement_handler = TBM_endElement_handler) + + call close_xml_t(fxml) + + if (this%n_types == 0) call system_abort("Called TBModel_NRL_TB_read_params_xml but no types are defined") + + this%cutoff = maxval(this%r_cut) + + call TBModel_NRL_TB_change_units(this) + + call finalise(parse_cur_data) + +end subroutine TBModel_NRL_TB_read_params_xml + +subroutine TBModel_NRL_TB_change_units(this) + type(TBModel_NRL_TB), intent(inout) :: this + + integer :: i, j + + this%r_cut = this%r_cut * BOHR + this%cutoff = this%cutoff * BOHR + this%screen_l = this%screen_l * BOHR + + if (this%has_pair_repulsion) then + this%pair_rep_inner = this%pair_rep_inner * BOHR + this%pair_rep_outer = this%pair_rep_outer * BOHR + endif + + if (this%has_short_ranged_splines) then + this%r_min_spline = this%r_min_spline * BOHR + this%sigma_spline = this%sigma_spline * BOHR + endif + + this%lambda_sq = this%lambda_sq / BOHR + this%abcd = this%abcd * RYDBERG + + this%H_coeff(MC_E,:,:,:,:) = this%H_coeff(MC_E,:,:,:,:) * RYDBERG + this%H_coeff(MC_F,:,:,:,:) = this%H_coeff(MC_F,:,:,:,:) * RYDBERG / BOHR + this%H_coeff(MC_FB,:,:,:,:) = this%H_coeff(MC_FB,:,:,:,:) * RYDBERG / BOHR**2 + this%H_coeff(MC_G_SQ,:,:,:,:) = this%H_coeff(MC_G_SQ,:,:,:,:) / BOHR + + do i=1, this%n_types + do j=1, this%n_types + if (i == j .and. this%overlap_zero_limit) then + this%S_coeff(MC_E,:,i,j,:) = this%S_coeff(MC_E,:,i,j,:) / BOHR + this%S_coeff(MC_F,:,i,j,:) = this%S_coeff(MC_F,:,i,j,:) / BOHR**2 + this%S_coeff(MC_FB,:,i,j,:) = this%S_coeff(MC_FB,:,i,j,:) / BOHR**3 + this%S_coeff(MC_G_SQ,:,i,j,:) = this%S_coeff(MC_G_SQ,:,i,j,:) / BOHR + else + this%S_coeff(MC_F,:,i,j,:) = this%S_coeff(MC_F,:,i,j,:) / BOHR + this%S_coeff(MC_FB,:,i,j,:) = this%S_coeff(MC_FB,:,i,j,:) / BOHR**2 + this%S_coeff(MC_G_SQ,:,i,j,:) = this%S_coeff(MC_G_SQ,:,i,j,:) / BOHR + endif + end do + end do + +end subroutine TBModel_NRL_TB_change_units + +subroutine TBModel_NRL_TB_Print(this,file) + type(TBModel_NRL_TB), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer::i, j, ii, i_mag, n_sk_use, max_spdf + + if(this%n_types == 0) call System_Abort('TBModel_NRL_TB_Print: TBModel_NRL_TB structure not initialised') + + call Print('TBModel_NRL_TB n_types:' // this%n_types, file=file) + + call Print ('TBModel_NRL_TB: is_orthogonal ' // this%is_orthogonal // & + ' is_magnetic '// this%is_magnetic// ' has_pair_repulsion '// this%has_pair_repulsion// & + ' overlap_zero_limit '// this%overlap_zero_limit// ' force_harrison_signs '// this%force_harrison_signs// ' has_short_ranged_splines '//this%has_short_ranged_splines, file=file) + + if (any(this%orb_set_type == ORB_F)) then + n_sk_use = 20 + max_spdf = SPDF_F + else + n_sk_use = 10 + max_spdf = SPDF_D + endif + + do i=1, this%n_types + call Print ('TBModel_NRL_TB: atomic num mass n_orbs n_elecs ' // this%atomic_num(i) // " " // this%atomic_mass(i) // & + " " // this%n_orbs(i) // " " // this%n_elecs(i), file=file) + call verbosity_push_decrement() + do j=1, this%n_types + call Print ("TBModel_NRL_TB: types " // i // " " // j, file=file) + call Print ('TBModel_NRL_TB: r_cut screen_l ' // this%r_cut(i,j) // " " // this%screen_l(i,j), file=file) + if (this%has_pair_repulsion) then + call Print ('TBModel_NRL_TB: pair_rep inner outer ' // this%pair_rep_inner(i,j) // " " // this%pair_rep_outer(i,j), file=file) + endif + if (this%has_short_ranged_splines) then + call Print ('TBModel_NRL_TB: r_min_spline sigma_spline ' // this%r_min_spline(i,j) // " " // this%sigma_spline(i,j), file=file) + endif + do i_mag=1, this%n_mag + if (this%is_magnetic .and. i_mag == 1) call print("TBModel_NRL_TB: spin up") + if (this%is_magnetic .and. i_mag == 2) call print("TBModel_NRL_TB: spin down") + if (i == j) then + call Print ('TBModel_NRL_TB: lambda_sq ' // this%lambda_sq(i,i_mag), file=file) + endif + call Print ('TBModel_NRL_TB: a_s b_s c_s d_s ' // this%abcd(ABCD_A:ABCD_D,SPDF_S,i,j,i_mag), file=file) + call Print ('TBModel_NRL_TB: a_p b_p c_p d_p ' // this%abcd(ABCD_A:ABCD_D,SPDF_P,i,j,i_mag), file=file) + call Print ('TBModel_NRL_TB: a_d b_d c_d d_d ' // this%abcd(ABCD_A:ABCD_D,SPDF_D,i,j,i_mag), file=file) + if (max_spdf >= SPDF_F) & + call Print ('TBModel_NRL_TB: a_f b_f c_f d_f ' // this%abcd(ABCD_A:ABCD_D,SPDF_F,i,j,i_mag), file=file) + + do ii=1, n_sk_use + call Print ('TBModel_NRL_TB: H e f fb g_sq ' // ii // " " // this%H_coeff(MC_E:MC_G_SQ,ii,i,j,i_mag), file=file) + end do + + do ii=1, n_sk_use + call Print ('TBModel_NRL_TB: S e f fb g_sq ' // ii // " " // this%S_coeff(MC_E:MC_G_SQ,ii,i,j,i_mag), file=file) + end do + end do ! i_mag + + end do + call verbosity_pop() + end do + +end subroutine TBModel_NRL_TB_Print + +function TBModel_NRL_TB_n_orbs_of_Z(this, Z) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_NRL_TB_n_orbs_of_Z + + TBModel_NRL_TB_n_orbs_of_Z = this%n_orbs(get_type(this%type_of_atomic_num,Z)) +end function TBModel_NRL_TB_n_orbs_of_Z + +function TBModel_NRL_TB_n_orb_sets_of_Z(this, Z) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: Z + integer TBModel_NRL_TB_n_orb_sets_of_Z + + TBModel_NRL_TB_n_orb_sets_of_Z = this%n_orb_sets(get_type(this%type_of_atomic_num,Z)) +end function TBModel_NRL_TB_n_orb_sets_of_Z + +function TBModel_NRL_TB_n_orbs_of_orb_set_of_Z(this, Z, i_set) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_NRL_TB_n_orbs_of_orb_set_of_Z + + TBModel_NRL_TB_n_orbs_of_orb_set_of_Z = N_ORBS_OF_SET(this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z))) + +end function TBModel_NRL_TB_n_orbs_of_orb_set_of_Z + +function TBModel_NRL_TB_orb_type_of_orb_set_of_Z(this, Z, i_set) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: Z, i_set + integer TBModel_NRL_TB_orb_type_of_orb_set_of_Z + + TBModel_NRL_TB_orb_type_of_orb_set_of_Z = this%orb_set_type(i_set,get_type(this%type_of_atomic_num,Z)) + +end function TBModel_NRL_TB_orb_type_of_orb_set_of_Z + +function TBModel_NRL_TB_n_elecs_of_Z(this, Z) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: Z + real(dp) TBModel_NRL_TB_n_elecs_of_Z + + TBModel_NRL_TB_n_elecs_of_Z = this%n_elecs(get_type(this%type_of_atomic_num,Z)) +end function TBModel_NRL_TB_n_elecs_of_Z + +subroutine TBModel_NRL_TB_get_HS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, b_H, b_S, i_mag) + type(TBModel_NRL_TB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, at_j + real(dp), intent(in) :: dv_hat(3), dv_mag + real(dp), intent(out) :: b_H(:,:), b_S(:,:) + integer, intent(in), optional :: i_mag + + integer ti, tj, is, js, i_set, j_set + integer i, j + real(dp) SK_frad_H(N_SK), SK_frad_S(N_SK) + real(dp) dv_hat_sq(3) + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + tj = get_type(this%type_of_atomic_num,at%Z(at_j)) + + b_H = 0.0_dp + b_S = 0.0_dp + + if (dv_mag .feq. 0.0_dp) then + i = 1 + do i_set = 1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + b_H(i,i) = onsite_function(this, at, at_i, this%orb_set_type(i_set,ti), i_mag) + b_S(i,i) = 1.0D0 + i = i + 1 + end do + end do + else + + dv_hat_sq = dv_hat**2 + + i = 1 + do i_set=1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + j = 1 + do j_set=1, this%n_orb_sets(tj) + SK_frad_H = 0.0_dp + SK_frad_S = 0.0_dp + call radial_functions(this, ti, tj, dv_mag, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + SK_frad_H, SK_frad_S, i_mag) + do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) + + b_H(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H) + + if (this%is_orthogonal) then + b_S(i,j) = 0.0_dp + else + b_S(i,j) = angular_function(dv_hat, dv_hat_sq, this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_S) + endif + + j = j + 1 + end do + end do + i = i + 1 + end do + end do + endif ! onsite + +end subroutine TBModel_NRL_TB_get_HS_blocks + +subroutine TBModel_NRL_TB_get_dHS_masks(this, at, at_ind, d_mask, od_mask) + type(TBModel_NRL_TB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_ind + logical, intent(out), optional :: d_mask(:), od_mask(:) + + integer ji, j + + if (present(d_mask)) then + if (at_ind < 0) then + d_mask = .true. + else + d_mask = .false. + d_mask(at_ind) = .true. + do ji=1, n_neighbours(at, at_ind) + j = neighbour(at, at_ind, ji) + d_mask(j) = .true. + end do + endif + endif + + if (present(od_mask)) then + if (at_ind < 0) then + od_mask = .true. + else + od_mask = .false. + od_mask(at_ind) = .true. + endif + endif + +end subroutine TBModel_NRL_TB_get_dHS_masks + + +function TBModel_NRL_TB_get_dHS_blocks(this, at, at_i, at_j, dv_hat, dv_mag, at_ind, b_dH, b_dS, i_mag) + type(TBModel_NRL_TB), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, at_j + real(dp), intent(in) :: dv_hat(3), dv_mag + integer, intent(in) :: at_ind + real(dp), intent(out) :: b_dH(:,:,:), b_dS(:,:,:) + integer, intent(in), optional :: i_mag + logical TBModel_NRL_TB_get_dHS_blocks + + integer ti, tj, is, js, i_set, j_set + integer i, j + real(dp) SK_frad_H(N_SK), SK_frad_S(N_SK), SK_dfrad_H(N_SK), SK_dfrad_S(N_SK) + real(dp) dv_hat_sq(3) + real(dp) virial_outerprod_fac + + if (at_i /= at_j) then ! off-diagonal block + ! for force derivatives, only matching rows contribute + if (at_ind > 0 .and. at_ind /= at_i .and. at_ind /= at_j) then + TBModel_NRL_TB_get_dHS_blocks = .false. + return + endif + else ! diagonal block + ! only atoms within cutoff contribute + if (dv_mag > this%cutoff) then + TBModel_NRL_TB_get_dHS_blocks = .false. + return + endif + endif + + ! force derivative off-diagonal masquerading as diagonal don't contribute + if (at_ind > 0 .and. at_i == at_j .and. (dv_mag .fne. 0.0_dp)) then + b_dH = 0.0_dp + b_dS = 0.0_dp + TBModel_NRL_TB_get_dHS_blocks = .true. + return + endif + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + tj = get_type(this%type_of_atomic_num,at%Z(at_j)) + + b_dH = 0.0_dp + b_dS = 0.0_dp + + if (dv_mag .feq. 0.0_dp) then ! on-site + i = 1 + do i_set = 1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + b_dH(i,i,:) = donsite_function(this, at, at_i, this%orb_set_type(i_set,ti), at_ind, i_mag) + b_dS(i,i,:) = 0.0D0 + i = i + 1 + end do + end do + + else ! hopping (even if on diagonal matrix block) + + dv_hat_sq = dv_hat**2 + + i = 1 + do i_set=1, this%n_orb_sets(ti) + do is=1, N_ORBS_OF_SET(this%orb_set_type(i_set,ti)) + j = 1 + do j_set=1, this%n_orb_sets(tj) + call radial_functions(this, ti, tj, dv_mag, & + this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + SK_frad_H, SK_frad_S, i_mag) + call dradial_functions(this, ti, tj, dv_mag, & + this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + SK_dfrad_H, SK_dfrad_S, i_mag) + do js=1, N_ORBS_OF_SET(this%orb_set_type(j_set,tj)) + + if (at_ind > 0) then + virial_outerprod_fac = 1.0_dp + else + virial_outerprod_fac = -dv_mag*dv_hat(-at_ind) + endif + b_dH(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & + this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_H, SK_dfrad_H)*virial_outerprod_fac + + if (this%is_orthogonal) then + b_dS(i,j,:) = 0.0_dp + else + b_dS(i,j,:) = dangular_function(dv_mag, dv_hat, dv_hat_sq, & + this%orb_set_type(i_set,ti), this%orb_set_type(j_set, tj), & + is, js, SK_frad_S, SK_dfrad_S)*virial_outerprod_fac + endif + + j = j + 1 + end do + end do + i = i + 1 + end do + end do + + if (at_ind == at_j) then + b_dH = -b_dH + if (.not. this%is_orthogonal) then + b_dS = -b_dS + endif + endif + + endif ! hopping + + TBModel_NRL_TB_get_dHS_blocks = .true. + return + +end function TBModel_NRL_TB_get_dHS_blocks + +function TBModel_NRL_TB_get_local_rep_E(this, at, i) + type(TBModel_NRL_TB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: TBModel_NRL_TB_get_local_rep_E + + TBModel_NRL_TB_get_local_rep_E = 0.0_dp + +end function TBModel_NRL_TB_get_local_rep_E + +function TBModel_NRL_TB_get_local_rep_E_force(this, at, i) result(force) + type(TBModel_NRL_TB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: force(3,at%N) + + force = 0.0_dp + +end function TBModel_NRL_TB_get_local_rep_E_force + +function TBModel_NRL_TB_get_local_rep_E_virial(this, at, i) result(virial) + type(TBModel_NRL_TB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp) :: virial(3,3) + + virial = 0.0_dp + +end function TBModel_NRL_TB_get_local_rep_E_virial + +subroutine radial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, f_H, f_S, i_mag) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dv_mag + integer, intent(in) :: orb_set_type_i, orb_set_type_j + real(dp), intent(out) :: f_H(N_SK), f_S(N_SK) + integer, intent(in), optional :: i_mag + + integer :: u_i_mag + + u_i_mag = optional_default(1, i_mag) + + if (this%n_mag == 1) u_i_mag = 1 + if (u_i_mag > this%n_mag) call system_abort("NRL_TB_Model radial_functions called for spin " // u_i_mag // " max spin only " // this%n_mag) + + if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then + f_H(SK_SSS) = calc_SK_coeff_H(this, SK_SSS,ti,tj, dv_mag,u_i_mag) + f_S(SK_SSS) = calc_SK_coeff_S_zero_limit(this, SK_SSS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j, u_i_mag) + if (this%force_harrison_signs) f_H(SK_SSS) = harrison_sign_sss*abs(f_H(SK_SSS)) + if (this%force_harrison_signs) f_S(SK_SSS) = harrison_sign_sss*abs(f_S(SK_SSS)) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then + f_H(SK_SPS) = calc_SK_coeff_H(this, SK_SPS,ti,tj, dv_mag,u_i_mag) + f_S(SK_SPS) = calc_SK_coeff_S_zero_limit(this, SK_SPS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_H(SK_SPS) = harrison_sign_sps*abs(f_H(SK_SPS)) + if (this%force_harrison_signs) f_S(SK_SPS) = harrison_sign_sps*abs(f_S(SK_SPS)) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then + f_H(SK_SPS) = -calc_SK_coeff_H(this, SK_SPS,tj,ti, dv_mag,u_i_mag) + f_S(SK_SPS) = -calc_SK_coeff_S_zero_limit(this, SK_SPS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_H(SK_SPS) = -harrison_sign_sps*abs(f_H(SK_SPS)) + if (this%force_harrison_signs) f_S(SK_SPS) = -harrison_sign_sps*abs(f_S(SK_SPS)) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then + f_H(SK_PPS) = calc_SK_coeff_H(this, SK_PPS,ti,tj, dv_mag,u_i_mag) + f_H(SK_PPP) = calc_SK_coeff_H(this, SK_PPP,ti,tj, dv_mag,u_i_mag) + f_S(SK_PPS) = calc_SK_coeff_S_zero_limit(this, SK_PPS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_PPP) = calc_SK_coeff_S_zero_limit(this, SK_PPP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_H(SK_PPS) = harrison_sign_pps*abs(f_H(SK_PPS)) + if (this%force_harrison_signs) f_S(SK_PPS) = harrison_sign_pps*abs(f_S(SK_PPS)) + if (this%force_harrison_signs) f_H(SK_PPP) = harrison_sign_ppp*abs(f_H(SK_PPP)) + if (this%force_harrison_signs) f_S(SK_PPP) = harrison_sign_ppp*abs(f_S(SK_PPP)) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_D) then + f_H(SK_SDS) = calc_SK_coeff_H(this, SK_SDS,ti,tj, dv_mag,u_i_mag) + f_S(SK_SDS) = calc_SK_coeff_S_zero_limit(this, SK_SDS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_H(SK_SDS) = harrison_sign_sds*abs(f_H(SK_SDS)) + if (this%force_harrison_signs) f_S(SK_SDS) = harrison_sign_sds*abs(f_S(SK_SDS)) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_S) then + f_H(SK_SDS) = calc_SK_coeff_H(this, SK_SDS,tj,ti, dv_mag,u_i_mag) + f_S(SK_SDS) = calc_SK_coeff_S_zero_limit(this, SK_SDS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_H(SK_SDS) = harrison_sign_sds*abs(f_H(SK_SDS)) + if (this%force_harrison_signs) f_S(SK_SDS) = harrison_sign_sds*abs(f_S(SK_SDS)) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_D) then + f_H(SK_PDS) = calc_SK_coeff_H(this, SK_PDS,ti,tj, dv_mag,u_i_mag) + f_H(SK_PDP) = calc_SK_coeff_H(this, SK_PDP,ti,tj, dv_mag,u_i_mag) + f_S(SK_PDS) = calc_SK_coeff_S_zero_limit(this, SK_PDS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_PDP) = calc_SK_coeff_S_zero_limit(this, SK_PDP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_H(SK_PDS) = harrison_sign_pds*abs(f_H(SK_PDS)) + if (this%force_harrison_signs) f_S(SK_PDS) = harrison_sign_pds*abs(f_S(SK_PDS)) + if (this%force_harrison_signs) f_H(SK_PDP) = harrison_sign_pdp*abs(f_H(SK_PDP)) + if (this%force_harrison_signs) f_S(SK_PDP) = harrison_sign_pdp*abs(f_S(SK_PDP)) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_P) then + f_H(SK_PDS) = -calc_SK_coeff_H(this, SK_PDS,tj,ti, dv_mag,u_i_mag) + f_H(SK_PDP) = -calc_SK_coeff_H(this, SK_PDP,tj,ti, dv_mag,u_i_mag) + f_S(SK_PDS) = -calc_SK_coeff_S_zero_limit(this, SK_PDS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_PDP) = -calc_SK_coeff_S_zero_limit(this, SK_PDP,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_H(SK_PDS) = -harrison_sign_pds*abs(f_H(SK_PDS)) + if (this%force_harrison_signs) f_S(SK_PDS) = -harrison_sign_pds*abs(f_S(SK_PDS)) + if (this%force_harrison_signs) f_H(SK_PDP) = -harrison_sign_pdp*abs(f_H(SK_PDP)) + if (this%force_harrison_signs) f_S(SK_PDP) = -harrison_sign_pdp*abs(f_S(SK_PDP)) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then + f_H(SK_DDS) = calc_SK_coeff_H(this, SK_DDS,tj,ti, dv_mag,u_i_mag) + f_H(SK_DDP) = calc_SK_coeff_H(this, SK_DDP,tj,ti, dv_mag,u_i_mag) + f_H(SK_DDD) = calc_SK_coeff_H(this, SK_DDD,tj,ti, dv_mag,u_i_mag) + f_S(SK_DDS) = calc_SK_coeff_S_zero_limit(this, SK_DDS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_DDP) = calc_SK_coeff_S_zero_limit(this, SK_DDP,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_DDD) = calc_SK_coeff_S_zero_limit(this, SK_DDD,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_H(SK_DDS) = harrison_sign_dds*abs(f_H(SK_DDS)) + if (this%force_harrison_signs) f_S(SK_DDS) = harrison_sign_dds*abs(f_S(SK_DDS)) + if (this%force_harrison_signs) f_H(SK_DDP) = harrison_sign_ddp*abs(f_H(SK_DDP)) + if (this%force_harrison_signs) f_S(SK_DDP) = harrison_sign_ddp*abs(f_S(SK_DDP)) + + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_F) then + f_H(SK_SFS) = calc_SK_coeff_H(this, SK_SFS,ti,tj, dv_mag,u_i_mag) + f_S(SK_SFS) = calc_SK_coeff_S_zero_limit(this, SK_SFS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_S) then + f_H(SK_SFS) = -calc_SK_coeff_H(this, SK_SFS,tj,ti, dv_mag,u_i_mag) + f_S(SK_SFS) = -calc_SK_coeff_S_zero_limit(this, SK_SFS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_F) then + f_H(SK_PFS) = calc_SK_coeff_H(this, SK_PFS,ti,tj, dv_mag,u_i_mag) + f_H(SK_PFP) = calc_SK_coeff_H(this, SK_PFP,ti,tj, dv_mag,u_i_mag) + f_S(SK_PFS) = calc_SK_coeff_S_zero_limit(this, SK_PFS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_PFP) = calc_SK_coeff_S_zero_limit(this, SK_PFP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_P) then + f_H(SK_PFS) = calc_SK_coeff_H(this, SK_PFS,tj,ti, dv_mag,u_i_mag) + f_H(SK_PFP) = calc_SK_coeff_H(this, SK_PFP,tj,ti, dv_mag,u_i_mag) + f_S(SK_PFS) = calc_SK_coeff_S_zero_limit(this, SK_PFS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_PFP) = calc_SK_coeff_S_zero_limit(this, SK_PFP,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_F) then + f_H(SK_DFS) = calc_SK_coeff_H(this, SK_DFS,ti,tj, dv_mag,u_i_mag) + f_H(SK_DFP) = calc_SK_coeff_H(this, SK_DFP,ti,tj, dv_mag,u_i_mag) + f_H(SK_DFD) = calc_SK_coeff_H(this, SK_DFD,ti,tj, dv_mag,u_i_mag) + f_S(SK_DFS) = calc_SK_coeff_S_zero_limit(this, SK_DFS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_DFP) = calc_SK_coeff_S_zero_limit(this, SK_DFP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_DFD) = calc_SK_coeff_S_zero_limit(this, SK_DFD,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_D) then + f_H(SK_DFS) = -calc_SK_coeff_H(this, SK_DFS,tj,ti, dv_mag,u_i_mag) + f_H(SK_DFP) = -calc_SK_coeff_H(this, SK_DFP,tj,ti, dv_mag,u_i_mag) + f_H(SK_DFD) = -calc_SK_coeff_H(this, SK_DFD,tj,ti, dv_mag,u_i_mag) + f_S(SK_DFS) = -calc_SK_coeff_S_zero_limit(this, SK_DFS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_DFP) = -calc_SK_coeff_S_zero_limit(this, SK_DFP,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_DFD) = -calc_SK_coeff_S_zero_limit(this, SK_DFD,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_F) then + f_H(SK_FFS) = calc_SK_coeff_H(this, SK_FFS,ti,tj, dv_mag,u_i_mag) + f_H(SK_FFP) = calc_SK_coeff_H(this, SK_FFP,ti,tj, dv_mag,u_i_mag) + f_H(SK_FFD) = calc_SK_coeff_H(this, SK_FFD,ti,tj, dv_mag,u_i_mag) + f_H(SK_FFF) = calc_SK_coeff_H(this, SK_FFF,ti,tj, dv_mag,u_i_mag) + f_S(SK_FFS) = calc_SK_coeff_S_zero_limit(this, SK_FFS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_FFP) = calc_SK_coeff_S_zero_limit(this, SK_FFP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_FFD) = calc_SK_coeff_S_zero_limit(this, SK_FFD,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_S(SK_FFF) = calc_SK_coeff_S_zero_limit(this, SK_FFF,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + endif + +end subroutine radial_functions + +subroutine dradial_functions(this, ti, tj, dv_mag, orb_set_type_i, orb_set_type_j, f_dH, f_dS, i_mag) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dv_mag + integer, intent(in) :: orb_set_type_i, orb_set_type_j + real(dp), intent(out) :: f_dH(N_SK), f_dS(N_SK) + integer, intent(in), optional :: i_mag + + integer :: u_i_mag + + u_i_mag = optional_default(1, i_mag) + + if (this%n_mag == 1) u_i_mag = 1 + if (u_i_mag > this%n_mag) call system_abort("NRL_TB_Model dradial_functions called for spin " // u_i_mag // " max spin only " // this%n_mag) + + if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_S) then + f_dH(SK_SSS) = calc_SK_coeff_H_d(this, SK_SSS,ti,tj, dv_mag,u_i_mag) + f_dS(SK_SSS) = calc_SK_coeff_S_d_zero_limit(this, SK_SSS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_SSS) = harrison_sign_sss*abs(f_dH(SK_SSS)) + if (this%force_harrison_signs) f_dS(SK_SSS) = harrison_sign_sss*abs(f_dS(SK_SSS)) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_P) then + f_dH(SK_SPS) = calc_SK_coeff_H_d(this, SK_SPS,ti,tj, dv_mag,u_i_mag) + f_dS(SK_SPS) = calc_SK_coeff_S_d_zero_limit(this, SK_SPS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_SPS) = harrison_sign_sps*abs(f_dH(SK_SPS)) + if (this%force_harrison_signs) f_dS(SK_SPS) = harrison_sign_sps*abs(f_dS(SK_SPS)) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_S) then + f_dH(SK_SPS) = -calc_SK_coeff_H_d(this, SK_SPS,tj,ti, dv_mag,u_i_mag) + f_dS(SK_SPS) = -calc_SK_coeff_S_d_zero_limit(this, SK_SPS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_SPS) = -harrison_sign_sps*abs(f_dH(SK_SPS)) + if (this%force_harrison_signs) f_dS(SK_SPS) = -harrison_sign_sps*abs(f_dS(SK_SPS)) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_P) then + f_dH(SK_PPS) = calc_SK_coeff_H_d(this, SK_PPS,ti,tj, dv_mag,u_i_mag) + f_dH(SK_PPP) = calc_SK_coeff_H_d(this, SK_PPP,ti,tj, dv_mag,u_i_mag) + f_dS(SK_PPS) = calc_SK_coeff_S_d_zero_limit(this, SK_PPS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_PPP) = calc_SK_coeff_S_d_zero_limit(this, SK_PPP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_PPS) = harrison_sign_pps*abs(f_dH(SK_PPS)) + if (this%force_harrison_signs) f_dS(SK_PPS) = harrison_sign_pps*abs(f_dS(SK_PPS)) + if (this%force_harrison_signs) f_dH(SK_PPP) = harrison_sign_ppp*abs(f_dH(SK_PPP)) + if (this%force_harrison_signs) f_dS(SK_PPP) = harrison_sign_ppp*abs(f_dS(SK_PPP)) + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_D) then + f_dH(SK_SDS) = calc_SK_coeff_H_d(this, SK_SDS,ti,tj, dv_mag,u_i_mag) + f_dS(SK_SDS) = calc_SK_coeff_S_d_zero_limit(this, SK_SDS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_SDS) = harrison_sign_sds*abs(f_dH(SK_SDS)) + if (this%force_harrison_signs) f_dS(SK_SDS) = harrison_sign_sds*abs(f_dS(SK_SDS)) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_S) then + f_dH(SK_SDS) = calc_SK_coeff_H_d(this, SK_SDS,tj,ti, dv_mag,u_i_mag) + f_dS(SK_SDS) = calc_SK_coeff_S_d_zero_limit(this, SK_SDS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_SDS) = harrison_sign_sds*abs(f_dH(SK_SDS)) + if (this%force_harrison_signs) f_dS(SK_SDS) = harrison_sign_sds*abs(f_dS(SK_SDS)) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_D) then + f_dH(SK_PDS) = calc_SK_coeff_H_d(this, SK_PDS,ti,tj, dv_mag,u_i_mag) + f_dH(SK_PDP) = calc_SK_coeff_H_d(this, SK_PDP,ti,tj, dv_mag,u_i_mag) + f_dS(SK_PDS) = calc_SK_coeff_S_d_zero_limit(this, SK_PDS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_PDP) = calc_SK_coeff_S_d_zero_limit(this, SK_PDP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_PDS) = harrison_sign_pds*abs(f_dH(SK_PDS)) + if (this%force_harrison_signs) f_dS(SK_PDS) = harrison_sign_pds*abs(f_dS(SK_PDS)) + if (this%force_harrison_signs) f_dH(SK_PDP) = harrison_sign_pdp*abs(f_dH(SK_PDP)) + if (this%force_harrison_signs) f_dS(SK_PDP) = harrison_sign_pdp*abs(f_dS(SK_PDP)) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_P) then + f_dH(SK_PDS) = -calc_SK_coeff_H_d(this, SK_PDS,tj,ti, dv_mag,u_i_mag) + f_dH(SK_PDP) = -calc_SK_coeff_H_d(this, SK_PDP,tj,ti, dv_mag,u_i_mag) + f_dS(SK_PDS) = -calc_SK_coeff_S_d_zero_limit(this, SK_PDS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_PDP) = -calc_SK_coeff_S_d_zero_limit(this, SK_PDP,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_PDS) = -harrison_sign_pds*abs(f_dH(SK_PDS)) + if (this%force_harrison_signs) f_dS(SK_PDS) = -harrison_sign_pds*abs(f_dS(SK_PDS)) + if (this%force_harrison_signs) f_dH(SK_PDP) = -harrison_sign_pdp*abs(f_dH(SK_PDP)) + if (this%force_harrison_signs) f_dS(SK_PDP) = -harrison_sign_pdp*abs(f_dS(SK_PDP)) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_D) then + f_dH(SK_DDS) = calc_SK_coeff_H_d(this, SK_DDS,tj,ti, dv_mag,u_i_mag) + f_dH(SK_DDP) = calc_SK_coeff_H_d(this, SK_DDP,tj,ti, dv_mag,u_i_mag) + f_dH(SK_DDD) = calc_SK_coeff_H_d(this, SK_DDD,tj,ti, dv_mag,u_i_mag) + f_dS(SK_DDS) = calc_SK_coeff_S_d_zero_limit(this, SK_DDS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_DDP) = calc_SK_coeff_S_d_zero_limit(this, SK_DDP,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_DDD) = calc_SK_coeff_S_d_zero_limit(this, SK_DDD,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + if (this%force_harrison_signs) f_dH(SK_DDS) = harrison_sign_dds*abs(f_dH(SK_DDS)) + if (this%force_harrison_signs) f_dS(SK_DDS) = harrison_sign_dds*abs(f_dS(SK_DDS)) + if (this%force_harrison_signs) f_dH(SK_DDP) = harrison_sign_ddp*abs(f_dH(SK_DDP)) + if (this%force_harrison_signs) f_dS(SK_DDP) = harrison_sign_ddp*abs(f_dS(SK_DDP)) + + else if (orb_set_type_i == ORB_S .and. orb_set_type_j == ORB_F) then + f_dH(SK_SFS) = calc_SK_coeff_H_d(this, SK_SFS,ti,tj, dv_mag,u_i_mag) + f_dS(SK_SFS) = calc_SK_coeff_S_d_zero_limit(this, SK_SFS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_S) then + f_dH(SK_SFS) = -calc_SK_coeff_H_d(this, SK_SFS,tj,ti, dv_mag,u_i_mag) + f_dS(SK_SFS) = -calc_SK_coeff_S_d_zero_limit(this, SK_SFS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_P .and. orb_set_type_j == ORB_F) then + f_dH(SK_PFS) = calc_SK_coeff_H_d(this, SK_PFS,ti,tj, dv_mag,u_i_mag) + f_dH(SK_PFP) = calc_SK_coeff_H_d(this, SK_PFP,ti,tj, dv_mag,u_i_mag) + f_dS(SK_PFS) = calc_SK_coeff_S_d_zero_limit(this, SK_PFS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_PFP) = calc_SK_coeff_S_d_zero_limit(this, SK_PFP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_P) then + f_dH(SK_PFS) = calc_SK_coeff_H_d(this, SK_PFS,tj,ti, dv_mag,u_i_mag) + f_dH(SK_PFP) = calc_SK_coeff_H_d(this, SK_PFP,tj,ti, dv_mag,u_i_mag) + f_dS(SK_PFS) = calc_SK_coeff_S_d_zero_limit(this, SK_PFS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_PFP) = calc_SK_coeff_S_d_zero_limit(this, SK_PFP,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_D .and. orb_set_type_j == ORB_F) then + f_dH(SK_DFS) = calc_SK_coeff_H_d(this, SK_DFS,ti,tj, dv_mag,u_i_mag) + f_dH(SK_DFP) = calc_SK_coeff_H_d(this, SK_DFP,ti,tj, dv_mag,u_i_mag) + f_dH(SK_DFD) = calc_SK_coeff_H_d(this, SK_DFD,ti,tj, dv_mag,u_i_mag) + f_dS(SK_DFS) = calc_SK_coeff_S_d_zero_limit(this, SK_DFS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_DFP) = calc_SK_coeff_S_d_zero_limit(this, SK_DFP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_DFD) = calc_SK_coeff_S_d_zero_limit(this, SK_DFD,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_D) then + f_dH(SK_DFS) = -calc_SK_coeff_H_d(this, SK_DFS,tj,ti, dv_mag,u_i_mag) + f_dH(SK_DFP) = -calc_SK_coeff_H_d(this, SK_DFP,tj,ti, dv_mag,u_i_mag) + f_dH(SK_DFD) = -calc_SK_coeff_H_d(this, SK_DFD,tj,ti, dv_mag,u_i_mag) + f_dS(SK_DFS) = -calc_SK_coeff_S_d_zero_limit(this, SK_DFS,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_DFP) = -calc_SK_coeff_S_d_zero_limit(this, SK_DFP,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_DFD) = -calc_SK_coeff_S_d_zero_limit(this, SK_DFD,tj,ti, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + else if (orb_set_type_i == ORB_F .and. orb_set_type_j == ORB_F) then + f_dH(SK_FFS) = calc_SK_coeff_H_d(this, SK_FFS,ti,tj, dv_mag,u_i_mag) + f_dH(SK_FFP) = calc_SK_coeff_H_d(this, SK_FFP,ti,tj, dv_mag,u_i_mag) + f_dH(SK_FFD) = calc_SK_coeff_H_d(this, SK_FFD,ti,tj, dv_mag,u_i_mag) + f_dH(SK_FFF) = calc_SK_coeff_H_d(this, SK_FFF,ti,tj, dv_mag,u_i_mag) + f_dS(SK_FFS) = calc_SK_coeff_S_d_zero_limit(this, SK_FFS,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_FFP) = calc_SK_coeff_S_d_zero_limit(this, SK_FFP,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_FFD) = calc_SK_coeff_S_d_zero_limit(this, SK_FFD,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + f_dS(SK_FFF) = calc_SK_coeff_S_d_zero_limit(this, SK_FFF,ti,tj, dv_mag, & + ti == tj, orb_set_type_i == orb_set_type_j,u_i_mag) + endif +end subroutine dradial_functions + +recursive function calc_SK_coeff_H(this, SK_type, ti, tj, dist, i_mag) result(calc_SK_coeff_H_result) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: SK_type + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dist + integer, intent(in), optional :: i_mag + real(dp) :: calc_SK_coeff_H_result, R_min, sigma + + real(dp) :: H_0, H_0_d, H_0_dd + integer :: u_i_mag + + + u_i_mag = optional_default(1, i_mag) + + if (this%has_short_ranged_splines) then + R_min = this%r_min_spline(ti,tj) + sigma = this%sigma_spline(ti,tj) + if (dist >= R_min) then + calc_SK_coeff_H_result = calc_SK_poly(this%H_coeff(1:4,SK_type, ti, tj, u_i_mag), dist) + calc_SK_coeff_H_result = calc_SK_coeff_H_result * NRLTB_cutoff_function(this, dist, ti, tj) + else + H_0 = calc_SK_coeff_H(this, SK_type, ti, tj, R_min, i_mag) + H_0_d = calc_SK_coeff_H_d(this, SK_type, ti, tj, R_min, i_mag) + H_0_dd = calc_SK_coeff_H_dd(this, SK_type, ti, tj, R_min, i_mag) + if (dist < R_min - sigma) then + calc_SK_coeff_H_result = short_ranged_spline(H_0, H_0_d, H_0_dd, sigma, 0.0_dp) + else + calc_SK_coeff_H_result = short_ranged_spline(H_0, H_0_d, H_0_dd, sigma, dist-R_min+sigma) + endif + endif + else + calc_SK_coeff_H_result = calc_SK_poly(this%H_coeff(1:4,SK_type, ti, tj, u_i_mag), dist) + calc_SK_coeff_H_result = calc_SK_coeff_H_result * NRLTB_cutoff_function(this, dist, ti, tj) + endif +end function calc_SK_coeff_H + +recursive function calc_SK_coeff_H_d(this, SK_type, ti, tj, dist, i_mag) result(calc_SK_coeff_H_d_result) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: SK_type + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dist + integer, intent(in), optional :: i_mag + real(dp) :: calc_SK_coeff_H_d_result + + real(dp) :: R_min, sigma + real(dp) :: H_0, H_0_d, H_0_dd + real(dp) :: SK, SKd, co, cod + real(dp) :: SK_0, SK_0_d, co_0, co_0_d + integer :: u_i_mag + + u_i_mag = optional_default(1, i_mag) + + SKd = calc_SK_poly_deriv(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) + SK = calc_SK_poly(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) + co = NRLTB_cutoff_function(this, dist, ti, tj) + cod = NRLTB_cutoff_function_d(this, dist, ti, tj) + + if (this%has_short_ranged_splines) then + R_min = this%r_min_spline(ti,tj) + sigma = this%sigma_spline(ti,tj) + if (dist >= R_min) then + calc_SK_coeff_H_d_result = SK*cod + SKd*co + elseif (dist < R_min - sigma) then + calc_SK_coeff_H_d_result = 0.0_dp + else + H_0 = calc_SK_coeff_H(this, SK_type, ti, tj, R_min, i_mag) + H_0_d = calc_SK_coeff_H_d(this, SK_type, ti, tj, R_min, i_mag) + H_0_dd = calc_SK_coeff_H_dd(this, SK_type, ti, tj, R_min, i_mag) + + calc_SK_coeff_H_d_result = short_ranged_spline_d(H_0, H_0_d, H_0_dd, sigma, dist-R_min+sigma) + endif + else + calc_SK_coeff_H_d_result = SK*cod + SKd*co + endif + + +end function calc_SK_coeff_H_d + + +function calc_SK_coeff_H_dd(this, SK_type, ti, tj, dist, i_mag, error) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: SK_type + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dist + integer, intent(in), optional :: i_mag + real(dp) :: calc_SK_coeff_H_dd + + real(dp) :: R_min, sigma + real(dp) :: SK, SKd, SKdd, co, cod, codd + integer :: u_i_mag + + integer, intent(out), optional :: error + + INIT_ERROR(error) + + u_i_mag = optional_default(1, i_mag) + + SK = calc_SK_poly(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) + SKd = calc_SK_poly_deriv(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) + SKdd = calc_SK_poly_2nd_deriv(this%H_coeff(1:4,SK_type, ti, tj,u_i_mag), dist) + + co = NRLTB_cutoff_function(this, dist, ti, tj) + cod = NRLTB_cutoff_function_d(this, dist, ti, tj) + codd = NRLTB_cutoff_function_dd(this, dist, ti, tj) + if (this%has_short_ranged_splines) then + R_min = this%r_min_spline(ti,tj) + sigma = this%sigma_spline(ti,tj) + if (dist >= R_min) then + calc_SK_coeff_H_dd = SK*codd + 2.0_dp*SKd*cod + SKdd*co + else + RAISE_ERROR("calc_SK_coeff_H_dd not defined yet below R_min if short ranged spline active.", error) + endif + else + calc_SK_coeff_H_dd = SK*codd + 2.0_dp*SKd*cod + SKdd*co + endif +end function calc_SK_coeff_H_dd + +recursive function calc_SK_coeff_S_zero_limit(this, SK_type, ti, tj, dist, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) & + result(calc_SK_coeff_S_zero_limit_result) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: SK_type + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dist + logical, intent(in) :: ti_eq_tj, orb_ti_eq_orb_tj + integer, intent(in), optional :: i_mag + real(dp) :: calc_SK_coeff_S_zero_limit_result + + real(dp) :: R_min, sigma + real(dp) :: S_0, S_0_d, S_0_dd + integer :: u_i_mag + + u_i_mag = optional_default(1, i_mag) + + if (this%has_short_ranged_splines) then + R_min = this%r_min_spline(ti,tj) + sigma = this%sigma_spline(ti,tj) + if (dist >= R_min) then + calc_SK_coeff_S_zero_limit_result = calc_SK_poly_zero_limit(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & + this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + calc_SK_coeff_S_zero_limit_result = calc_SK_coeff_S_zero_limit_result * NRLTB_cutoff_function(this, dist, ti, tj) + else + S_0 = calc_SK_coeff_S_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) + S_0_d = calc_SK_coeff_S_d_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) + S_0_dd = calc_SK_coeff_S_dd_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) + if (dist < R_min - sigma) then + calc_SK_coeff_S_zero_limit_result = short_ranged_spline(S_0, S_0_d, S_0_dd, sigma, 0.0_dp) + else + calc_SK_coeff_S_zero_limit_result = short_ranged_spline(S_0, S_0_d, S_0_dd, sigma, dist-R_min+sigma) + endif + endif + else + calc_SK_coeff_S_zero_limit_result = calc_SK_poly_zero_limit(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & + this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + calc_SK_coeff_S_zero_limit_result = calc_SK_coeff_S_zero_limit_result * NRLTB_cutoff_function(this, dist, ti, tj) + endif +end function calc_SK_coeff_S_zero_limit + + +recursive function calc_SK_coeff_S_d_zero_limit(this, SK_type, ti, tj, dist, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) & + result(calc_SK_coeff_S_d_zero_limit_result) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: SK_type + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dist + logical, intent(in) :: ti_eq_tj, orb_ti_eq_orb_tj + integer, intent(in), optional :: i_mag + real(dp) :: calc_SK_coeff_S_d_zero_limit_result + + real(dp) :: R_min, sigma + real(dp) :: SK_0, SK_0_d, co_0, co_0_d + real(dp) :: S_0, S_0_d, S_0_dd + real(dp) :: SK, SKd, co, cod + integer :: u_i_mag + + u_i_mag = optional_default(1, i_mag) + + SK = calc_SK_poly_zero_limit(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & + this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + SKd = calc_SK_poly_zero_limit_deriv(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & + this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + co = NRLTB_cutoff_function(this, dist, ti, tj) + cod = NRLTB_cutoff_function_d(this, dist, ti, tj) + + + if (this%has_short_ranged_splines) then + R_min = this%r_min_spline(ti,tj) + sigma = this%sigma_spline(ti,tj) + if (dist >= R_min) then + calc_SK_coeff_S_d_zero_limit_result = SK*cod + SKd*co + elseif (dist < R_min - sigma) then + calc_SK_coeff_S_d_zero_limit_result = 0.0_dp + else + S_0 = calc_SK_coeff_S_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) + S_0_d = calc_SK_coeff_S_d_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) + S_0_dd = calc_SK_coeff_S_dd_zero_limit(this, SK_type, ti, tj, R_min, ti_eq_tj, orb_ti_eq_orb_tj, i_mag) + calc_SK_coeff_S_d_zero_limit_result = short_ranged_spline_d(S_0, S_0_d, S_0_dd, sigma, dist-R_min+sigma) + endif + else + calc_SK_coeff_S_d_zero_limit_result = SK*cod + SKd*co + endif + +end function calc_SK_coeff_S_d_zero_limit + + +function calc_SK_coeff_S_dd_zero_limit(this, SK_type, ti, tj, dist, ti_eq_tj, orb_ti_eq_orb_tj, i_mag, error) + type(TBModel_NRL_TB), intent(in) :: this + integer, intent(in) :: SK_type + integer, intent(in) :: ti, tj + real(dp), intent(in) :: dist + logical, intent(in) :: ti_eq_tj, orb_ti_eq_orb_tj + integer, intent(in), optional :: i_mag + real(dp) :: calc_SK_coeff_S_dd_zero_limit + + real(dp) :: R_min, sigma + real(dp) :: SK, SKd, SKdd, co, cod, codd + integer :: u_i_mag + + integer, intent(out), optional :: error + + INIT_ERROR(error) + + u_i_mag = optional_default(1, i_mag) + + SK = calc_SK_poly_zero_limit(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & + this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + SKd = calc_SK_poly_zero_limit_deriv(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & + this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + SKdd = calc_SK_poly_zero_limit_2nd_deriv(this%S_coeff(1:4,SK_type, ti, tj, u_i_mag), dist, & + this%overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + co = NRLTB_cutoff_function(this, dist, ti, tj) + cod = NRLTB_cutoff_function_d(this, dist, ti, tj) + codd = NRLTB_cutoff_function_dd(this, dist, ti, tj) + + if (this%has_short_ranged_splines) then + R_min = this%r_min_spline(ti,tj) + sigma = this%sigma_spline(ti,tj) + if (dist >= R_min) then + calc_SK_coeff_S_dd_zero_limit = SK*codd + 2.0_dp*SKd*cod + SKdd*co + else + RAISE_ERROR("calc_SK_coeff_S_dd_zero_limit not defined yet below R_min if short ranged spline active.", error) + endif + else + calc_SK_coeff_S_dd_zero_limit = SK*codd + 2.0_dp*SKd*cod + SKdd*co + endif + +end function calc_SK_coeff_S_dd_zero_limit + + +function calc_SK_poly(coeff, dist) + real(dp), intent(in) :: coeff(4) + real(dp), intent(in) :: dist + real(dp) :: calc_SK_poly + + calc_SK_poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist))*exp(-coeff(MC_G_SQ)*dist) +end function calc_SK_poly + +function calc_SK_poly_deriv(coeff, dist) + real(dp), intent(in) :: coeff(4) + real(dp), intent(in) :: dist + real(dp) :: calc_SK_poly_deriv + + real(dp) poly, poly_d, expv, expv_d + + expv = exp(-coeff(MC_G_SQ)*dist) + expv_d = expv*(-coeff(MC_G_SQ)) + poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist)) + poly_d = coeff(MC_F) + 2.0_dp*coefF(MC_FB)*dist + + calc_SK_poly_deriv = expv*poly_d + expv_d*poly +end function calc_SK_poly_deriv + +function calc_SK_poly_2nd_deriv(coeff, dist) + + real(dp), intent(in) :: coeff(4) + real(dp), intent(in) :: dist + real(dp) :: calc_SK_poly_2nd_deriv + + real(dp) poly, poly_d, poly_dd, expv, expv_d, expv_dd + + expv = exp(-coeff(MC_G_SQ)*dist) + expv_d = expv*(-coeff(MC_G_SQ)) + expv_dd = expv*(-coeff(MC_G_SQ))**2 + + poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist)) + poly_d = coeff(MC_F) + 2.0_dp*coefF(MC_FB)*dist + poly_dd = 2.0_dp*coefF(MC_FB) + + calc_SK_poly_2nd_deriv = expv*poly_dd + 2*expv_d*poly_d + expv_dd * poly + +end function calc_SK_poly_2nd_deriv + +function calc_SK_poly_zero_limit(coeff, dist, overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + real(dp), intent(in) :: coeff(4) + real(dp), intent(in) :: dist + logical, intent(in) :: overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj + real(dp) :: calc_SK_poly_zero_limit + + real(dp) zero_limit + + if (overlap_zero_limit .and. ti_eq_tj .and. orb_ti_eq_orb_tj) then + zero_limit = 1.0_dp + else + zero_limit = 0.0_dp + end if + + if (overlap_zero_limit .and. ti_eq_tj) then + calc_SK_poly_zero_limit = (zero_limit + dist*(coeff(MC_E) + dist*(coeff(MC_F) + & + coeff(MC_FB)*dist)))*exp(-COEFF(MC_G_SQ)*dist) + else + calc_SK_poly_zero_limit = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist))* & + exp(-coeff(MC_G_SQ)*dist) + endif +end function calc_SK_poly_zero_limit + +function calc_SK_poly_zero_limit_deriv(coeff, dist, overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + real(dp), intent(in) :: coeff(4) + real(dp), intent(in) :: dist + logical, intent(in) :: overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj + real(dp) :: calc_SK_poly_zero_limit_deriv + + real(dp) zero_limit + real(dp) poly, poly_d, expv, expv_d + + if (overlap_zero_limit .and. ti_eq_tj .and. orb_ti_eq_orb_tj) then + zero_limit = 1.0_dp + else + zero_limit = 0.0_dp + end if + + expv = exp(-COEFF(MC_G_SQ)*dist) + expv_d = expv*(-COEFF(MC_G_SQ)) + + if (overlap_zero_limit .and. ti_eq_tj) then + poly = (zero_limit + dist*(coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist))) + poly_d = coeff(MC_E) + dist*(2.0_dp*coeff(MC_F) + 3.0_dp*coeff(MC_FB)*dist) + else + poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist)) + poly_d = coeff(MC_F) + 2.0_dp*coeff(MC_FB)*dist + endif + + calc_SK_poly_zero_limit_deriv = expv * poly_d + expv_d * poly +end function calc_SK_poly_zero_limit_deriv + +function calc_SK_poly_zero_limit_2nd_deriv(coeff, dist, overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj) + real(dp), intent(in) :: coeff(4) + real(dp), intent(in) :: dist + logical, intent(in) :: overlap_zero_limit, ti_eq_tj, orb_ti_eq_orb_tj + real(dp) :: calc_SK_poly_zero_limit_2nd_deriv + + real(dp) zero_limit + real(dp) poly, poly_d, poly_dd, expv, expv_d, expv_dd + + if (overlap_zero_limit .and. ti_eq_tj .and. orb_ti_eq_orb_tj) then + zero_limit = 1.0_dp + else + zero_limit = 0.0_dp + end if + + expv = exp(-COEFF(MC_G_SQ)*dist) + expv_d = expv*(-COEFF(MC_G_SQ)) + expv_dd = expv*(-COEFF(MC_G_SQ))**2 + + if (overlap_zero_limit .and. ti_eq_tj) then + poly = (zero_limit + dist*(coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist))) + poly_d = coeff(MC_E) + dist*(2.0_dp*coeff(MC_F) + 3.0_dp*coeff(MC_FB)*dist) + poly_dd = 2.0_dp*coeff(MC_F) + 6.0_dp*coeff(MC_FB)*dist + else + poly = (coeff(MC_E) + dist*(coeff(MC_F) + coeff(MC_FB)*dist)) + poly_d = coeff(MC_F) + 2.0_dp*coeff(MC_FB)*dist + poly_dd = 2.0_dp*coeff(MC_FB) + endif + + calc_SK_poly_zero_limit_2nd_deriv = expv*poly_dd + 2*expv_d*poly_d + expv_dd * poly +end function calc_SK_poly_zero_limit_2nd_deriv + + +function onsite_function(this, at, at_i, orb_set_type,i_mag) + type(TBModel_NRL_TB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, orb_set_type + integer, intent(in), optional :: i_mag + real(dp) :: onsite_function + + integer :: ji, j, ti, tj + real(dp) :: dist + real(dp) :: density(this%n_types) + real(dp) :: f_cut, expv + integer :: u_i_mag + + u_i_mag = optional_default(1, i_mag) + + if (this%n_mag == 1) u_i_mag = 1 + if (u_i_mag > this%n_mag) call system_abort("NRL_TB_Model onsite_functions called for spin " // u_i_mag // " max spin only " // this%n_mag) + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + + density = 0.0_dp + do ji=1, n_neighbours(at, at_i) + j = neighbour(at, at_i, ji, dist) + tj = get_type(this%type_of_atomic_num,at%Z(j)) + + f_cut = NRLTB_cutoff_function(this, dist, ti, tj) + expv = exp(-this%lambda_sq(tj,u_i_mag)*dist) + density(tj) = density(tj) + expv*f_cut + end do + + onsite_function = 0.0_dp + do tj=1, this%n_types + onsite_function = onsite_function + onsite_poly(this%abcd(1:4,orb_set_type,tj,ti,u_i_mag), density(tj)) + end do + +end function onsite_function + +function donsite_function(this, at, at_i, orb_set_type, at_ind, i_mag) + type(TBModel_NRL_TB), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_i, orb_set_type, at_ind + integer, intent(in), optional :: i_mag + real(dp) :: donsite_function(3) + + integer :: ji, j, ti, tj + real(dp) :: dist + real(dp) :: density(this%n_types), density_d(this%n_types,3) + real(dp) :: f_cut, expv, f_cut_d, expv_d, dircos(3) + real(dp) :: virial_outerprod_fac + integer :: u_i_mag + + u_i_mag = optional_default(1, i_mag) + + if (this%n_mag == 1) u_i_mag = 1 + if (u_i_mag > this%n_mag) call system_abort("NRL_TB_Model donsite_functions called for spin " // u_i_mag // " max spin only " // this%n_mag) + + ti = get_type(this%type_of_atomic_num,at%Z(at_i)) + + density = 0.0_dp + density_d = 0.0_dp + do ji=1, n_neighbours(at, at_i) + j = neighbour(at, at_i, ji, dist, cosines = dircos) + tj = get_type(this%type_of_atomic_num,at%Z(j)) + + f_cut = NRLTB_cutoff_function(this, dist, ti, tj) + f_cut_d = NRLTB_cutoff_function_d(this, dist, ti, tj) + expv = exp(-this%lambda_sq(tj,u_i_mag)*dist) + expv_d = expv*(-this%lambda_sq(tj,u_i_mag)) + density(tj) = density(tj) + expv*f_cut + if (at_i == at_ind) then + density_d(tj,:) = density_d(tj,:) + (expv*f_cut_d + expv_d*f_cut)*(-dircos(:)) + else if (j == at_ind) then + density_d(tj,:) = density_d(tj,:) + (expv*f_cut_d + expv_d*f_cut)*dircos(:) + else if (at_ind < 0) then + virial_outerprod_fac = -dist*dircos(-at_ind) + density_d(tj,:) = density_d(tj,:) + (expv*f_cut_d + expv_d*f_cut)*(-dircos(:))*virial_outerprod_fac + endif + end do + + donsite_function = 0.0_dp + do tj=1, this%n_types + donsite_function(1) = donsite_function(1) + donsite_poly(this%abcd(1:4,orb_set_type,tj,ti,u_i_mag), & + density(tj), density_d(tj,1)) + donsite_function(2) = donsite_function(2) + donsite_poly(this%abcd(1:4,orb_set_type,tj,ti,u_i_mag), & + density(tj), density_d(tj,2)) + donsite_function(3) = donsite_function(3) + donsite_poly(this%abcd(1:4,orb_set_type,tj,ti,u_i_mag), & + density(tj), density_d(tj,3)) + end do + +end function donsite_function + +function onsite_poly(abcd, density) + real(dp), intent(in) :: abcd(4) + real(dp), intent(in) :: density + real(dp) :: onsite_poly + + onsite_poly = abcd(ABCD_A) + abcd(ABCD_B)*density**(2.0_dp/3.0_dp) + & + abcd(ABCD_C)*density**(4.0_dp/3.0_dp) + abcd(ABCD_D)*density**2 + +end function onsite_poly + +function donsite_poly(abcd, density, density_d) + real(dp), intent(in) :: abcd(4) + real(dp), intent(in) :: density, density_d + real(dp) :: donsite_poly + + if (density .feq. 0.0_dp) then + donsite_poly = 0.0_dp + else + donsite_poly = (abcd(ABCD_B)*(2.0_dp/3.0_dp)*density**(-1.0_dp/3.0_dp) + & + abcd(ABCD_C)*(4.0_dp/3.0_dp)*density**(1.0_dp/3.0_dp) + abcd(ABCD_D)*2.0_dp*density)*density_d + endif + +end function donsite_poly + + +function short_ranged_spline(H_0, H_0_d, H_0_dd, sigma, u) +! spline function for TB potential evaluation proposed by Trinkle et al., Empirical tight-binding model for titanium phase transformations, Phys. Rev. B 73 (2006) 094123 + real(dp), intent(in) :: H_0, H_0_d, H_0_dd, sigma, u + real(dp) :: short_ranged_spline + + short_ranged_spline = H_0 - 0.5_dp*sigma*H_0_d + 1.0_dp/12.0_dp*sigma**2*H_0_dd + & + (sigma*H_0_d - 1.0_dp/3.0_dp*sigma**2*H_0_dd)*u**3/sigma**3 + & + (-0.5_dp*sigma*H_0_d + 0.25_dp*sigma**2*H_0_dd)*u**4/sigma**4 +end function short_ranged_spline + +function short_ranged_spline_d(H_0, H_0_d, H_0_dd, sigma, u) +! derivative of the above given spline function of Trinkle et al., Empirical tight-binding model for titanium phase transformations, Phys. Rev. B 73 (2006) 094123 + real(dp), intent(in) :: H_0, H_0_d, H_0_dd, sigma, u + real(dp) :: short_ranged_spline_d + + short_ranged_spline_d = 3.0_dp*(sigma*H_0_d - 1.0_dp/3.0_dp*sigma**2*H_0_dd)*u**2/sigma**3 + & + 4.0_dp*(-0.5_dp*sigma*H_0_d + 0.25_dp*sigma**2*H_0_dd)*u**3/sigma**4 + + +end function short_ranged_spline_d + +function NRLTB_cutoff_function(this, r, ti, tj) + type(TBModel_NRL_TB), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: NRLTB_cutoff_function + + double precision screen_R0 + double precision cutoff_smooth + double precision expv + + if (r .gt. 10.0_dp**(-4)) then + + screen_R0 = this%r_cut(ti,tj) - 5.0D0*abs(this%screen_l(ti,tj)) + + expv = exp((r-screen_R0)/abs(this%screen_l(ti,tj))) + + cutoff_smooth = NRLTB_cutoff_func_smooth(this, r, ti, tj) + NRLTB_cutoff_function = ( 1.0_dp/(1.0_dp+expv) ) * cutoff_smooth + else + NRLTB_cutoff_function = 0.0_dp + end if + +end function NRLTB_cutoff_function + +function NRLTB_cutoff_function_d(this, r, ti, tj) + type(TBModel_NRL_TB), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: NRLTB_cutoff_function_d + + double precision screen_R0 + double precision cutoff_smooth, cutoff_smooth_d + double precision expv, expv_d + + if (r .gt. 10.0_dp**(-4)) then + + screen_R0 = this%r_cut(ti,tj) - 5.0D0*abs(this%screen_l(ti,tj)) + + expv = exp((r-screen_R0)/abs(this%screen_l(ti,tj))) + expv_d = expv * 1.0_dp/abs(this%screen_l(ti,tj)) + + cutoff_smooth = NRLTB_cutoff_func_smooth(this, r, ti, tj) + cutoff_smooth_d = NRLTB_cutoff_func_smooth_d(this, r, ti, tj) + + NRLTB_cutoff_function_d = ( 1.0_dp/(1.0_dp+expv) ) * cutoff_smooth_d - & + (1.0_dp/(1.0_dp+expv)**2)*expv_d * cutoff_smooth + else + NRLTB_cutoff_function_d = 0.0_dp + end if + +end function NRLTB_cutoff_function_d + + +function NRLTB_cutoff_function_dd(this, r, ti, tj) + type(TBModel_NRL_TB), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: NRLTB_cutoff_function_dd + + double precision screen_R0 + double precision cutoff_smooth, cutoff_smooth_d, cutoff_smooth_dd + double precision expv, expv_d, expv_dd + + if (r .gt. 10.0_dp**(-4)) then + + screen_R0 = this%r_cut(ti,tj) - 5.0D0*abs(this%screen_l(ti,tj)) + + expv = exp((r-screen_R0)/abs(this%screen_l(ti,tj))) + expv_d = expv * 1.0_dp/abs(this%screen_l(ti,tj)) + expv_dd = expv_d * 1.0_dp/abs(this%screen_l(ti,tj)) + + cutoff_smooth = NRLTB_cutoff_func_smooth(this, r, ti, tj) + cutoff_smooth_d = NRLTB_cutoff_func_smooth_d(this, r, ti, tj) + cutoff_smooth_dd = NRLTB_cutoff_func_smooth_dd(this, r, ti, tj) + + NRLTB_cutoff_function_dd = ( -1.0_dp/(1.0_dp+expv)**2 )*expv_d * cutoff_smooth_d + ( 1.0_dp/(1.0_dp+expv) ) * cutoff_smooth_dd - & + ((-2.0_dp/(1.0_dp+expv)**3)*expv_d**2 * cutoff_smooth + (1.0_dp/(1.0_dp+expv)**2)*expv_dd * cutoff_smooth + (1.0_dp/(1.0_dp+expv)**2)*expv_d * cutoff_smooth_d) + else + NRLTB_cutoff_function_dd = 0.0_dp + end if + +end function NRLTB_cutoff_function_dd + +function NRLTB_cutoff_func_smooth(this, r, ti, tj) + type(TBModel_NRL_TB), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: NRLTB_cutoff_func_smooth + + double precision R_MIN, R_MAX + + double precision PI + parameter (PI = 3.14159265358979323846264338327950288_dp) + + + if (this%screen_l(ti,tj) .lt. 0.0_dp) then + NRLTB_cutoff_func_smooth = 1.0_dp + return + endif + + R_MAX = this%r_cut(ti,tj) + R_MIN = R_MAX - abs(this%screen_l(ti,tj)) + + if (r .lt. R_MIN) then + NRLTB_cutoff_func_smooth = 1.0_dp + else if (r .gt. R_MAX) then + NRLTB_cutoff_func_smooth = 0.0_dp + else + NRLTB_cutoff_func_smooth = 1.0_dp - (1.0_dp - cos( (r-R_MIN)*PI / (R_MAX-R_MIN) ))/2.0_dp + end if + +end function NRLTB_cutoff_func_smooth + +function NRLTB_cutoff_func_smooth_d(this, r, ti, tj) + type(TBModel_NRL_TB), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: NRLTB_cutoff_func_smooth_d + + double precision R_MIN, R_MAX + + double precision PI + parameter (PI = 3.14159265358979323846264338327950288_dp) + + + if (this%screen_l(ti,tj) .lt. 0.0_dp) then + NRLTB_cutoff_func_smooth_d = 1.0_dp + return + endif + + R_MAX = this%r_cut(ti,tj) + R_MIN = R_MAX - abs(this%screen_l(ti,tj)) + + if (r .lt. R_MIN) then + NRLTB_cutoff_func_smooth_d = 0.0_dp + else if (r .gt. R_MAX) then + NRLTB_cutoff_func_smooth_d = 0.0_dp + else + NRLTB_cutoff_func_smooth_d = -sin( (r-R_MIN)*PI / (R_MAX-R_MIN) )/2.0_dp * (PI/(R_MAX-R_MIN)) + end if + +end function NRLTB_cutoff_func_smooth_d + +function NRLTB_cutoff_func_smooth_dd(this, r, ti, tj) + type(TBModel_NRL_TB), intent(in) :: this + real(dp), intent(in) :: r + integer, intent(in) :: ti, tj + real(dp) :: NRLTB_cutoff_func_smooth_dd + + double precision R_MIN, R_MAX + + double precision PI + parameter (PI = 3.14159265358979323846264338327950288_dp) + + + if (this%screen_l(ti,tj) .lt. 0.0_dp) then + NRLTB_cutoff_func_smooth_dd = 0.0_dp + return + endif + + R_MAX = this%r_cut(ti,tj) + R_MIN = R_MAX - abs(this%screen_l(ti,tj)) + + if (r .lt. R_MIN) then + NRLTB_cutoff_func_smooth_dd = 0.0_dp + else if (r .gt. R_MAX) then + NRLTB_cutoff_func_smooth_dd = 0.0_dp + else + NRLTB_cutoff_func_smooth_dd = -cos( (r-R_MIN)*PI / (R_MAX-R_MIN) )/2.0_dp * (PI/(R_MAX-R_MIN))**2 + end if + +end function NRLTB_cutoff_func_smooth_dd + +end module TBModel_NRL_TB_module diff --git a/src/Potentials/TBModel_NRL_TB_defs.F90 b/src/Potentials/TBModel_NRL_TB_defs.F90 new file mode 100644 index 0000000000..00afcf50b1 --- /dev/null +++ b/src/Potentials/TBModel_NRL_TB_defs.F90 @@ -0,0 +1,48 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X TBModel_NRL_TB_defs module +!X +!% Definitions for NRL-TB model, to be shared with format conversion program +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +module TBModel_NRL_TB_defs_module +implicit none +public + integer, parameter :: max_n_orb_sets = 4 + + integer, parameter :: ABCD_A = 1, ABCD_B = 2, ABCD_C = 3, ABCD_D = 4 + integer, parameter :: SPDF_S = 1, SPDF_P = 2, SPDF_D = 3, SPDF_F = 4 + + integer, parameter :: MC_E = 1, MC_F = 2, MC_FB = 3, MC_G_SQ = 4 +end module TBModel_NRL_TB_defs_module diff --git a/src/Potentials/TBSystem.F90 b/src/Potentials/TBSystem.F90 new file mode 100644 index 0000000000..d8fbdfbacb --- /dev/null +++ b/src/Potentials/TBSystem.F90 @@ -0,0 +1,3943 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X TBSystem module +!X +!% Code to contain a TB calculation, and evaluate H and S matrices etc. +!% Also contains much code to support self-consitency, dipole matrix elements +!% and spin-orbit coupling +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +module TBSystem_module + +use error_module +use system_module, only : dp, print, inoutput, PRINT_NORMAL, PRINT_ALWAYS, PRINT_NERD, current_verbosity, optional_default, operator(//), verbosity_push_decrement, verbosity_pop, verbosity_push, PRINT_ANALYSIS +use units_module, only : Hartree, Bohr, PI +use periodictable_module, only : ElementName +use linearalgebra_module, only : operator(.mult.), operator(.feq.), norm, print +use mpi_context_module, only : mpi_context, initialise, finalise +use dictionary_module, only : dictionary, initialise, finalise +use paramreader_module, only : param_register, param_read_line +use atoms_module, only : atoms, n_neighbours, neighbour, assignment(=) + +! use Functions_module +use QUIP_Common_module ! , only : xml_t, dictionary_t, pauli_sigma +use ScaLAPACK_module, only : scalapack, initialise +use TB_Common_module +use TBModel_module, only : tbmodel, initialise, finalise, print, & + n_orb_sets_of_Z, orb_type_of_orb_set_of_Z, n_orbs_of_orb_set_of_Z, n_orbs_of_Z, n_elecs_of_Z, & + get_HS_blocks, get_dHS_blocks, get_dHS_masks +use Matrix_module, only : matrixd, initialise, finalise, zero +use TBMatrix_module, only : tbmatrix, initialise, finalise, wipe, print, zero, add_block, sum_matrices, copy, make_hermitian +use TB_KPoints_module, only : kpoints, initialise, finalise, calc_phase, print, init_mpi, ksum_distrib_inplace +use TB_mixing_module, only : do_mix_simple, do_ridders_residual, do_mix_broyden +use ewald_module, only : add_madelung_matrix, add_dmadelung_matrix, add_dmadelung_matrix_dr + + +implicit none +private + +! character(40) :: sc_default_file = "self_consistency.data.xml" + +integer, parameter, public :: & + SCF_NONE = 0, & + SCF_LOCAL_U = 1, & + SCF_GLOBAL_U = 2, & + SCF_LCN = 3, & + SCF_GCN = 4, & + SCF_NONLOCAL_U_DFTB = 5, & + SCF_NONLOCAL_U_NRL_TB = 6, & + SCF_SPIN_DIR = 7, & + SCF_SPIN_STONER = 8 + +character(len=30), parameter :: scf_names(0:8) = (/ & +'NONE ', & +'LOCAL_U ', & +'GLOBAL_U ', & +'LCN ', & +'GCN ', & +'NONLOCAL_U_DFTB ', & +'NONLOCAL_U_NRL_TB ', & +'SPIN_DIR ', & +'SPIN_STONER ' /) + +! LOCAL_U F = sum_a U_a (n_a-n0_a)^2 +! GLOBAL_U F = U (sum_a n_a-n0_a)^2 +! LCN +! GCN +! NONLOCAL_U_DFTB F = sum_ab (n_a-n0_a) gamma_ab (n_b-n0_b) +! NONLOCAL_U_NRL_TB F = sum_ab (n_a-n0_a) gamma_ab (n_b-n0_b) +! SPIN_DIR F = -0.5 sum_a splitting_a | atomic_mom_a(i) | +! SPIN_STONER F = -0.25 sum_a stoner_param_a | atomic_mom_a(i) | ^2 + +public :: Self_Consistency_Term +type Self_Consistency_Term + logical :: active = .false. + integer :: type = SCF_NONE + integer :: N = 0, N_atoms = 0, N_manifolds = 0 + integer :: n_dof = 0 + + ! for SCF_GLOBAL_U + real(dp) :: global_U + real(dp) :: global_N + + ! for SCF_GLOBAL_U + real(dp) :: global_pot + + ! for SCF_LOCAL_U and SCF_NONLOCAL_U + real(dp), allocatable :: U(:) + real(dp), allocatable :: atomic_n(:), atomic_n0(:) + real(dp), allocatable :: datomic_local_pot_dr(:,:) + ! for SCF_LCN + real(dp), allocatable :: atomic_local_pot(:) + + ! for SCF_NONLOCAL_U_* + real(dp), allocatable :: gamma(:,:), dgamma_dr(:,:,:) + + ! for SCF_SPIN_* + real(dp), allocatable :: manifold_mom(:,:) + ! for SCF_SPIN_DIR + real(dp), allocatable :: spin_splitting(:) + ! for SCF_SPIN_STONER + real(dp), allocatable :: stoner_param(:) + +end type Self_Consistency_Term + +public :: Self_Consistency +type Self_Consistency + logical :: active = .false. + + integer :: N = 0, N_atoms = 0, N_manifolds = 0 + + real(dp) :: global_U + real(dp), allocatable :: U(:), stoner_param(:,:) + + type(Self_Consistency_Term), allocatable :: terms(:) + real(dp), allocatable :: orb_local_pot(:), orb_exch_field(:,:) + + real(dp) :: alpha = 0.01_dp, w0 = 0.02_dp + real(dp) :: conv_tol = 1.0e-10_dp + real(dp) :: mix_simple_end_tol = -1.0e-2_dp, mix_simple_start_tol=1.0e38_dp + + integer :: max_iter = 100 + + logical :: mix_simple = .false. + +end type Self_Consistency + +public :: TB_Dipole_Model +type TB_Dipole_Model + logical :: active = .false. + + integer :: n_types + integer, allocatable :: type_of_atomic_num(:), atomic_num(:) + integer, allocatable :: n_orb_sets(:), orb_set_type(:,:), orb_set_phase(:,:) + real(dp), allocatable :: gaussian_width(:,:) + +end type TB_Dipole_Model + +public :: TB_Spin_Orbit_Coupling +type TB_Spin_Orbit_Coupling + logical :: active = .false. + + integer :: n_types + integer, allocatable :: type_of_atomic_num(:), atomic_num(:) + integer, allocatable :: n_orb_sets(:), orb_set_type(:,:) + real(dp), allocatable :: SO_param(:,:) +end type TB_Spin_Orbit_Coupling + +public :: TBSystem +type TBSystem + + ! model and atomic config + integer :: N = 0, N_atoms = 0, N_manifolds = 0 + integer, allocatable :: at_Z(:) + type(TBModel) tbmodel + ! first_orb_of_atom: index into array of all orbitals of first orbital associated with each atom + ! first_manifold_of_atom: index into array of all manifolds of first manifold (s, p, d, etc) associated with each atom + ! first_orb_of_manifold: index into array of all orbitals of first orbital associated with each manifold + integer, allocatable :: first_orb_of_atom(:), first_manifold_of_atom(:), first_orb_of_manifold(:) + + logical :: noncollinear = .false. + logical :: spinpol_no_scf = .false. + logical :: complex_matrices = .false. + + integer :: max_block_size = 0 + + ! matrices + integer :: n_matrices = 0 + type(TBMatrix) :: H + type(TBMatrix) :: S + + type(TBMatrix) :: dH(3) + type(TBMatrix) :: dS(3) + + ! k points + logical :: kpoints_generate_dynamically = .false., kpoints_generate_next_dynamically = .false., kpoints_use_mp = .true. + real(dp) :: kpoints_k_space_density = 1.0_dp + type(KPoints) :: kpoints + + ! self consistency + type(Self_Consistency) :: scf + type(TB_Dipole_model) :: dipole_model + type(TB_Spin_Orbit_Coupling) :: SO + + type(MPI_context) :: mpi_global, mpi_my_matrices + type(ScaLAPACK) :: scalapack_my_matrices + +end type TBSystem + +logical :: parse_in_self_consistency +type(Self_Consistency), pointer :: parse_self_consistency + +logical :: parse_in_dipole_model +type(TB_Dipole_Model), pointer :: parse_dipole_model + +logical :: parse_in_spin_orbit_coupling +type(TB_Spin_Orbit_Coupling), pointer :: parse_spin_orbit_coupling + +public :: Initialise +interface Initialise + module procedure TBSystem_Initialise_str, TBSystem_Initialise_from_tbsys + module procedure Self_Consistency_Initialise_str, TB_Dipole_Model_Initialise_str + module procedure TB_Spin_Orbit_Coupling_Initialise_str +end interface Initialise + +public :: Setup_atoms +interface Setup_atoms + module procedure TBSystem_Setup_atoms_from_atoms, TBSystem_Setup_atoms_from_tbsys, TBSystem_setup_atoms_from_arrays +end interface Setup_atoms + +public :: Setup_deriv_matrices +interface Setup_deriv_matrices + module procedure TBSystem_Setup_deriv_matrices +end interface Setup_deriv_matrices + +interface Setup_system + module procedure Self_Consistency_setup_system + module procedure Self_Consistency_Term_setup_system +end interface Setup_system + +public :: Finalise +interface Finalise + module procedure TBSystem_Finalise, Self_Consistency_Finalise, Self_Consistency_Term_Finalise + module procedure TB_Dipole_Model_Finalise, TB_Spin_Orbit_Coupling_Finalise +end interface Finalise + +public :: Print +interface Print + module procedure TBSystem_Print, Self_Consistency_Print, Self_Consistency_Term_Print + module procedure TB_Dipole_Model_Print, TB_Spin_Orbit_Coupling_Print +end interface Print + +public :: Wipe +interface Wipe + module procedure TBSystem_Wipe, Self_Consistency_Wipe, Self_Consistency_Term_Wipe +end interface Wipe + +interface read_params_xml + module procedure Self_Consistency_read_params_xml, TB_Dipole_Model_read_params_xml, TB_Spin_Orbit_Coupling_read_params_xml +end interface read_params_xml + +public :: fill_matrices +interface fill_matrices + module procedure TBSystem_fill_matrices +end interface fill_matrices + +public :: fill_these_matrices +interface fill_these_matrices + module procedure TBSystem_fill_these_matrices +end interface fill_these_matrices + +public :: fill_dmatrices +interface fill_dmatrices + module procedure TBSystem_fill_dmatrices +end interface fill_dmatrices + +public :: fill_sc_matrices +interface fill_sc_matrices + module procedure TBSystem_fill_sc_matrices, Self_Consistency_Term_fill_sc_matrices +end interface fill_sc_matrices + +public :: fill_sc_dmatrices +interface fill_sc_dmatrices + module procedure TBSystem_fill_sc_dmatrices, Self_Consistency_Term_fill_sc_dmatrices +end interface fill_sc_dmatrices + +public :: atom_orbital_sum +interface atom_orbital_sum + module procedure TBSystem_atom_orbital_sum_real1, TBSystem_atom_orbital_sum_real2 + module procedure TBSystem_atom_orbital_sum_complex2 +end interface atom_orbital_sum + +public :: manifold_orbital_sum +interface manifold_orbital_sum + module procedure TBSystem_manifold_orbital_sum_real2 +end interface manifold_orbital_sum + +public :: atom_orbital_spread +interface atom_orbital_spread + module procedure TBSystem_atom_orbital_spread_real1 +end interface atom_orbital_spread + +public :: atom_orbital_spread_mat +interface atom_orbital_spread_mat + module procedure TBSystem_atom_orbital_spread_mat_r +end interface atom_orbital_spread_mat + +public :: ksum_atom_orbital_sum_mat +interface ksum_atom_orbital_sum_mat + module procedure TBSystem_ksum_atom_orbital_sum_mat_d +end interface ksum_atom_orbital_sum_mat + +public :: atom_orbital_sum_mat +interface atom_orbital_sum_mat + module procedure TBSystem_atom_orbital_sum_mat_r +end interface atom_orbital_sum_mat + +public :: set_type +interface set_type + module procedure Self_Consistency_set_type_str +end interface set_type + +public :: calc_orb_local_pot +interface calc_orb_local_pot + module procedure TBSystem_calc_orb_local_pot +end interface calc_orb_local_pot + +public :: update_orb_local_pot +interface update_orb_local_pot + module procedure TBSystem_update_orb_local_pot +end interface update_orb_local_pot + +public :: scf_e_correction, local_scf_e_correction, scf_f_correction, scf_virial_correction + +public :: n_elec +interface n_elec + module procedure TBSystem_n_elec +end interface n_elec + +public :: scf_get_atomic_n_mom +interface scf_get_atomic_n_mom + module procedure TBSystem_scf_get_atomic_n_mom +end interface scf_get_atomic_n_mom + +public :: scf_get_global_N +interface scf_get_global_N + module procedure TBSystem_scf_get_global_N +end interface scf_get_global_N + +public :: scf_set_atomic_n_mom +interface scf_set_atomic_n_mom + module procedure TBSystem_scf_set_atomic_n_mom +end interface scf_set_atomic_n_mom + +public :: scf_set_global_N +interface scf_set_global_N + module procedure TBSystem_scf_set_global_N +end interface scf_set_global_N + +public :: add_term_d2SCFE_dgNdn, add_term_dscf_e_correction_dgN, add_term_d2SCFE_dn2_times_vec, add_term_dscf_e_correction_dn + +public :: initialise_kpoints +interface initialise_kpoints + module procedure TBSystem_initialise_kpoints +end interface initialise_kpoints + +public :: copy_matrices +interface copy_matrices + module procedure TBSystem_copy_matrices +end interface copy_matrices + +contains +subroutine TBSystem_Initialise_str(this, args_str, param_str, kpoints_obj, mpi_obj) + type(TBSystem), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + type(KPoints), intent(in), optional :: kpoints_obj + type(MPI_context), intent(in), optional :: mpi_obj + + call Finalise(this) + + call Initialise(this%tbmodel, args_str, param_str) + + if (present(kpoints_obj)) then + call Initialise(this%kpoints, kpoints_obj, mpi_obj) + call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) + else + call initialise_kpoints(this, args_str, param_str, mpi_obj, from_tbsystem_initialise=.true.) + endif + + call Initialise(this%scf, args_str, param_str) + call Initialise(this%dipole_model, args_str, param_str) + call Initialise(this%SO, args_str, param_str) + +end subroutine TBSystem_Initialise_str + +subroutine check_dipole_model_consistency(dipole_model, tbm, Z) + type(TB_Dipole_Model), intent(in) :: dipole_model + type(TBModel), intent(in) :: tbm + integer, intent(in) :: Z(:) + + integer :: i_at + integer :: i_type, i_orb_set + + do i_at=1, size(Z) + i_type = dipole_model%type_of_atomic_num(Z(i_at)) + if (dipole_model%n_orb_sets(i_type) /= n_orb_sets_of_Z(tbm, Z(i_at))) & + call system_abort("check_dipole_model_consistency found mismatch in number of orbitals sets for Z="//Z(i_at) // & + " dipole_model " // dipole_model%n_orb_sets(i_type) // " tbmodel " // n_orb_sets_of_Z(tbm, Z(i_at)) ) + do i_orb_set=1, dipole_model%n_orb_sets(i_type) + if (dipole_model%orb_set_type(i_orb_set,i_type) /= orb_type_of_orb_set_of_Z(tbm, Z(i_at), i_orb_set)) & + call system_abort("check_dipole_model_consistency found mismatch in orbital set type for Z="//Z(i_at) // & + " i_orb_set="//i_orb_set// " dipole_model " // dipole_model%orb_set_type(i_orb_set,i_type) // " tbmodel " // orb_type_of_orb_set_of_Z(tbm, Z(i_at), i_orb_set) ) + end do + end do +end subroutine check_dipole_model_consistency + +subroutine check_spin_orbit_coupling_consistency(spin_orbit_coupling, tbm, Z) + type(TB_Spin_Orbit_Coupling), intent(in) :: spin_orbit_coupling + type(TBModel), intent(in) :: tbm + integer, intent(in) :: Z(:) + + integer :: i_at + integer :: i_type, i_orb_set + + do i_at=1, size(Z) + i_type = spin_orbit_coupling%type_of_atomic_num(Z(i_at)) + if (spin_orbit_coupling%n_orb_sets(i_type) /= n_orb_sets_of_Z(tbm, Z(i_at))) & + call system_abort("check_spin_orbit_coupling_consistency found mismatch in number of orbitals sets for Z="//Z(i_at) // & + " spin_orbit_coupling " // spin_orbit_coupling%n_orb_sets(i_type) // " tbmodel " // n_orb_sets_of_Z(tbm, Z(i_at)) ) + do i_orb_set=1, spin_orbit_coupling%n_orb_sets(i_type) + if (spin_orbit_coupling%orb_set_type(i_orb_set,i_type) /= orb_type_of_orb_set_of_Z(tbm, Z(i_at), i_orb_set)) & + call system_abort("check_spin_orbit_coupling_consistency found mismatch in orbital set type for Z="//Z(i_at) // & + " i_orb_set="//i_orb_set// " spin_orbit_coupling " // spin_orbit_coupling%orb_set_type(i_orb_set,i_type) // " tbmodel " // & + orb_type_of_orb_set_of_Z(tbm, Z(i_at), i_orb_set) ) + end do + end do +end subroutine check_spin_orbit_coupling_consistency + +subroutine TBSystem_Initialise_from_tbsys(this, from, mpi_obj) + type(TBSystem), intent(inout) :: this + type(TBSystem), intent(in) :: from + type(MPI_context), intent(in), optional :: mpi_obj + + call Finalise(this) + + this%tbmodel = from%tbmodel + this%complex_matrices = from%complex_matrices + this%noncollinear = from%noncollinear + this%spinpol_no_scf = from%spinpol_no_scf + + this%kpoints = from%kpoints + this%kpoints_generate_dynamically = from%kpoints_generate_dynamically + this%kpoints_generate_next_dynamically = from%kpoints_generate_next_dynamically + this%kpoints_use_mp = from%kpoints_use_mp + this%kpoints_k_space_density = from%kpoints_k_space_density + call init_mpi(this%kpoints, mpi_obj) + + call initialise_tbsystem_k_dep_stuff(this, mpi_obj) + + this%scf = from%scf + this%dipole_model = from%dipole_model + + call setup_atoms(this, from) +end subroutine TBSystem_Initialise_from_tbsys + +subroutine initialise_tbsystem_k_dep_stuff(this, mpi_obj) + type(TBSystem), intent(inout) :: this + type(MPI_Context), optional, intent(in) :: mpi_obj + + if (this%kpoints%N > 0) then + this%n_matrices = this%kpoints%N + else + this%n_matrices = 0 + endif + + if (present(mpi_obj)) then + this%mpi_global = this%kpoints%mpi_global + call Initialise(this%scalapack_my_matrices, this%kpoints%mpi_my_kpt) + if (.not. this%scalapack_my_matrices%active .and. this%kpoints%mpi_my_kpt%n_procs > 1) then + this%kpoints%no_sum_over_my_kpt = .true. + endif + this%mpi_my_matrices = this%kpoints%mpi_my_kpt + endif + +end subroutine Initialise_tbsystem_k_dep_stuff + +subroutine TBSystem_Finalise(this) + type(TBSystem), intent(inout) :: this + + call Wipe(this) + + call Finalise(this%tbmodel) + call Finalise(this%kpoints) + call Finalise(this%scf) + call Finalise(this%dipole_model) + + call Finalise(this%H) + call Finalise(this%dH(1)) + call Finalise(this%dH(2)) + call Finalise(this%dH(3)) + call Finalise(this%S) + call Finalise(this%dS(1)) + call Finalise(this%dS(2)) + call Finalise(this%dS(3)) + + call Finalise(this%mpi_global) +end subroutine TBSystem_Finalise + +subroutine TBSystem_Wipe(this) + type(TBSystem), intent(inout) :: this + + if (allocated(this%first_orb_of_atom)) deallocate(this%first_orb_of_atom) + if (allocated(this%first_orb_of_manifold)) deallocate(this%first_orb_of_manifold) + if (allocated(this%first_manifold_of_atom)) deallocate(this%first_manifold_of_atom) + if (allocated(this%at_Z)) deallocate(this%at_Z) + + call Wipe(this%scf) + call Wipe(this%H) + call Wipe(this%S) + call Wipe(this%dH(1)) + call Wipe(this%dH(2)) + call Wipe(this%dH(3)) + call Wipe(this%dS(1)) + call Wipe(this%dS(2)) + call Wipe(this%dS(3)) + + call Finalise(this%mpi_my_matrices) + + this%N = 0 + this%N_atoms = 0 + this%N_manifolds = 0 + this%max_block_size = 0 +end subroutine TBSystem_Wipe + +function TBSystem_n_elec(this, at, w_n) + type(TBSystem), intent(in) :: this + type(Atoms), intent(in) :: at + real(dp), intent(in), pointer, optional :: w_n(:) + real(dp) :: TBSystem_n_elec + + integer i + + TBSystem_n_elec = 0 + do i=1, this%N_atoms + if (present(w_n)) then + if (associated(w_n)) then + TBSystem_n_elec = TBSystem_n_elec + w_n(i)*n_elecs_of_Z(this%tbmodel, at%Z(i)) + else + TBSystem_n_elec = TBSystem_n_elec + n_elecs_of_Z(this%tbmodel, at%Z(i)) + end if + else + TBSystem_n_elec = TBSystem_n_elec + n_elecs_of_Z(this%tbmodel, at%Z(i)) + endif + end do +end function TBSystem_n_elec + +subroutine TBSystem_Setup_atoms_from_atoms(this, at, noncollinear, spinpol_no_scf, args_str, mpi_obj, error) + type(TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + logical, intent(in), optional :: noncollinear, spinpol_no_scf + character(len=*), intent(in), optional :: args_str + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + + INIT_ERROR(error) + + call initialise_kpoints(this, args_str=args_str, mpi_obj=mpi_obj) + if (this%kpoints_generate_dynamically) then + call initialise(this%kpoints, at%lattice, this%kpoints_k_space_density, this%kpoints_use_mp, mpi_obj) + call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) + this%kpoints_generate_dynamically = this%kpoints_generate_next_dynamically + endif + call setup_atoms(this, at%N, at%Z, noncollinear, spinpol_no_scf, error=error) + PASS_ERROR(error) + +end subroutine TBSystem_Setup_atoms_from_atoms + +subroutine TBSystem_Setup_atoms_from_tbsys(this, from, error) + type(TBSystem), intent(inout) :: this + type(TBSystem), intent(in) :: from + integer, intent(out), optional :: error + + INIT_ERROR(error) + + call setup_atoms(this, from%N_atoms, from%at_Z, from%noncollinear, from%spinpol_no_scf, error=error) + PASS_ERROR(error) + +end subroutine TBSystem_Setup_Atoms_from_tbsys + +subroutine TBSystem_Setup_atoms_from_arrays(this, at_N, at_Z, noncollinear, spinpol_no_scf, error) + type(TBSystem), intent(inout) :: this + integer, intent(in) :: at_N, at_Z(:) + logical, intent(in), optional :: noncollinear, spinpol_no_scf + integer, intent(out), optional :: error + + integer :: i_at, i_man, man_offset, last_man_offset + integer :: n_mag + + INIT_ERROR(error) + + call Wipe(this) + + this%noncollinear = optional_default(this%noncollinear, noncollinear) + this%spinpol_no_scf = optional_default(this%spinpol_no_scf, spinpol_no_scf) + + this%N_atoms = at_N + allocate(this%at_Z(this%N_atoms)) + this%at_Z = at_Z + + if (this%noncollinear) then + n_mag = 2 + else + n_mag = 1 + end if + + ! fill in first_orb_of_atom and first_manifold_of_atom arrays + allocate(this%first_orb_of_atom(this%N_atoms+1)) + allocate(this%first_manifold_of_atom(this%N_atoms+1)) + this%first_orb_of_atom(1) = 1 + this%first_manifold_of_atom(1) = 1 + do i_at=2, this%N_atoms+1 + this%first_orb_of_atom(i_at) = this%first_orb_of_atom(i_at-1) + & + n_mag*n_orbs_of_Z(this%tbmodel, at_Z(i_at-1)) + this%first_manifold_of_atom(i_at) = this%first_manifold_of_atom(i_at-1) + & + n_orb_sets_of_Z(this%tbmodel, at_Z(i_at-1)) + end do + + this%N = this%first_orb_of_atom(this%N_atoms+1)-1 + this%N_manifolds = this%first_manifold_of_atom(this%N_atoms+1)-1 + + ! fill in first_orb_of_manifold array + allocate(this%first_orb_of_manifold(this%N_manifolds+1)) + this%first_orb_of_manifold(1) = 1 + ! don't really need this, but some compilers complain because it's used before set (even though + ! thing that uses it (last_man_offset) isn't actually used until it has a meaningul value) + man_offset = 1 + ! set in case first atom has only 1 manifold + last_man_offset = 1 + do i_at=1, this%N_atoms + do i_man=this%first_manifold_of_atom(i_at), this%first_manifold_of_atom(i_at+1)-1 + ! if this is very first manifold, it was already set before entering loop, so skip + if (i_man == 1) cycle + + ! save man_offset in case we need it for next atom's first manifold + last_man_offset = man_offset + ! man_offset says which manifold (1...) of this atom the loop is currently at + man_offset = i_man - this%first_manifold_of_atom(i_at) + 1 + + if (man_offset == 1) then + ! first manifold of this atom + ! first orb is first orb of first manifold of previous atom + number of orbs in that manifold + this%first_orb_of_manifold(i_man) = this%first_orb_of_manifold(i_man-1) + & + n_mag*n_orbs_of_orb_set_of_Z(this%tbmodel, at_Z(i_at-1), last_man_offset) + else + ! second or later manifold of this atom + ! first orb is first orb of previous manifold + number of orbs in that manifold + this%first_orb_of_manifold(i_man) = this%first_orb_of_manifold(i_man-1) + & + n_mag*n_orbs_of_orb_set_of_Z(this%tbmodel, at_Z(i_at), man_offset-1) + endif + if (i_at == this%N_atoms+1) exit + end do + end do + + ! set last orb of last manifold + this%first_orb_of_manifold(this%N_manifolds+1) = this%first_orb_of_manifold(this%N_manifolds) + & + n_mag*n_orbs_of_orb_set_of_Z(this%tbmodel, at_Z(this%N_atoms), n_orb_sets_of_Z(this%tbmodel, at_Z(this%N_atoms))) + + this%max_block_size = maxval(this%first_orb_of_atom(2:this%N_atoms+1) - & + this%first_orb_of_atom(1:this%N_atoms)) + + this%complex_matrices = this%kpoints%non_gamma .or. this%noncollinear + call Initialise(this%H, this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) + if (.not. this%tbmodel%is_orthogonal) then + call Initialise(this%S, this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) + endif + + call setup_system(this%scf, this%N, this%tbmodel, this%N_atoms, this%at_Z, this%N_manifolds) + +end subroutine TBSystem_Setup_Atoms_from_arrays + +subroutine TBSystem_Setup_deriv_matrices(this, at, dense, need_S) + type(TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + logical, intent(in), optional :: dense, need_S + + logical do_S, my_dense + + do_S = .not. this%tbmodel%is_orthogonal + if (present(need_S)) do_S = do_S .or. need_S + + if (this%N == 0 .or. this%N_atoms == 0) then + call system_abort ('Called TBSystem_Setup_deriv_matrices on uninitialized TBSystem') + endif + + my_dense = optional_default(.false., dense) + + call Finalise(this%dH(1)) + call Finalise(this%dH(2)) + call Finalise(this%dH(3)) + call Finalise(this%dS(1)) + call Finalise(this%dS(2)) + call Finalise(this%dS(3)) + + if (my_dense) then + call Initialise(this%dH(1), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) + call Initialise(this%dH(2), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) + call Initialise(this%dH(3), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) + if (do_S) then + call Initialise(this%dS(1), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) + call Initialise(this%dS(2), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) + call Initialise(this%dS(3), this%N, this%n_matrices, this%complex_matrices, this%scalapack_my_matrices) + endif + else + call Initialise(this%dH(1), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) + call Initialise(this%dH(2), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) + call Initialise(this%dH(3), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) + if (do_S) then + call Initialise(this%dS(1), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) + call Initialise(this%dS(2), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) + call Initialise(this%dS(3), at, this%first_orb_of_atom, this%n_matrices, this%complex_matrices) + endif + endif + +end subroutine + +subroutine TBSystem_fill_matrices(this, at, need_H, need_S, no_S_spin) + type (TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + logical, intent(in), optional :: need_H, need_S, no_S_spin + + logical :: do_need_H, do_need_S, do_no_S_spin + + do_need_S = .not. this%tbmodel%is_orthogonal + if (present(need_S)) do_need_S = do_need_S .or. need_S + + do_need_H = optional_default(.true., need_H) + do_no_S_spin = optional_default(.false., no_S_spin) + + if (do_need_S .and. this%S%N == 0) then + call Initialise(this%S, this%N, this%n_matrices, this%complex_matrices) + endif + + call fill_these_matrices(this, at, do_need_H, this%H, do_need_S, this%S, do_no_S_spin) + +end subroutine + +subroutine TBSystem_fill_these_matrices(this, at, do_H, H, do_S, S, no_S_spin, do_dipole, dipole) + type (TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + logical, intent(in), optional :: do_H + type(TBMatrix), intent(inout), optional :: H + logical, intent(in), optional :: do_S + type(TBMatrix), intent(inout), optional :: S + logical, intent(in), optional :: no_S_spin + logical, intent(in), optional :: do_dipole + type(TBMatrix), intent(inout), optional :: dipole(3) + + integer :: i, ji, j, ik, ii, jj, iii, jjj + real(dp), allocatable :: block_H(:,:), block_S(:,:), block_H_up(:,:), block_H_down(:,:), block_dipole(:,:,:) + complex(dp), allocatable :: block_H_z(:,:), block_S_z(:,:), block_H_z_phase(:,:), block_S_z_phase(:,:) + complex(dp), allocatable :: block_dipole_z(:,:,:), block_dipole_z_phase(:,:,:) + complex(dp), allocatable :: block_SO(:,:) + real(dp) :: dv_hat(3), dv_hat_ij(3), dv_hat_ji(3), dv_mag + integer :: shift(3) + complex(dp) :: expf + + integer :: block_nr, block_nc + + logical :: u_do_S, u_do_S_block, u_do_H, u_no_S_spin, u_do_dipole + + u_do_S = optional_default(.false., do_S) + u_do_H = optional_default(.false., do_H) + u_no_S_spin = optional_default(.false., no_S_spin) + u_do_dipole = optional_default(.false., do_dipole) + + u_do_S_block = u_do_S .or. this%scf%active + + if (u_do_H .and. .not. present(H)) call system_abort("Called TBSystem_fill_some_matrices with do_H but no H") + if (u_do_S .and. .not. present(S)) call system_abort("Called TBSystem_fill_some_matrices with do_S but no S") + if (u_do_dipole .and. .not. present(dipole)) call system_abort("Called TBSystem_fill_some_matrices with do_dipole but no dipole") + + if (u_do_H) call Zero(H) + if (u_do_S) call Zero(S) + if (u_do_dipole) then + call Zero(dipole(1)) + call Zero(dipole(2)) + call Zero(dipole(3)) + call check_dipole_model_consistency(this%dipole_model, this%tbmodel, at%Z) + endif + + allocate(block_H(this%max_block_size, this%max_block_size)) + allocate(block_S(this%max_block_size, this%max_block_size)) + allocate(block_dipole(this%max_block_size, this%max_block_size,3)) + block_H = 0.0_dp + block_S = 0.0_dp + block_dipole = 0.0_dp + if (this%complex_matrices) then + allocate(block_H_z(this%max_block_size, this%max_block_size)) + allocate(block_S_z(this%max_block_size, this%max_block_size)) + allocate(block_dipole_z(this%max_block_size, this%max_block_size,3)) + block_H_z = 0.0_dp + block_S_z = 0.0_dp + block_dipole_z = 0.0_dp + if (this%kpoints%non_gamma) then + allocate(block_H_z_phase(this%max_block_size, this%max_block_size)) + allocate(block_S_z_phase(this%max_block_size, this%max_block_size)) + allocate(block_dipole_z_phase(this%max_block_size, this%max_block_size,3)) + block_H_z_phase = 0.0_dp + block_S_z_phase = 0.0_dp + block_dipole_z_phase = 0.0_dp + endif + endif + if (this%noncollinear) then + allocate(block_H_up(this%max_block_size, this%max_block_size)) + allocate(block_H_down(this%max_block_size, this%max_block_size)) + block_H_up = 0.0_dp + block_H_down = 0.0_dp + if (this%SO%active) then + allocate(block_SO(this%max_block_size, this%max_block_size)) + block_SO = 0.0_dp + call check_spin_orbit_coupling_consistency(this%SO, this%tbmodel, at%Z) + endif + else + if (this%SO%active) then + call print("WARNING: fill_these_matrices got active spin-orbit coupling, but noncollinear is off") + endif + endif + + do i=1, at%N + block_nr = this%first_orb_of_atom(i+1)-this%first_orb_of_atom(i) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dv_mag, shift = shift) + + ! do our own direction cosine, since atom_neighbour() result isn't antisymmetric enough + if (i == j) then + dv_hat = at%lattice .mult. shift + else + dv_hat_ij = at%pos(:,j) - at%pos(:,i) + (at%lattice .mult. shift) + dv_hat_ji = at%pos(:,i) - at%pos(:,j) - (at%lattice .mult. shift) + dv_hat = 0.5_dp*(dv_hat_ij - dv_hat_ji) + endif + if (maxval(abs(dv_hat)) .feq. 0.0_dp) then + dv_hat = 0.0_dp + else + dv_hat = dv_hat / norm(dv_hat) + endif + + block_nc = this%first_orb_of_atom(j+1)-this%first_orb_of_atom(j) + + if (this%noncollinear) then + if (.not. this%complex_matrices) call system_abort("noncollinear supported for complex matrices only") + call get_HS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, block_H_up, block_S, i_mag=1) + call get_HS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, block_H_down, block_S, i_mag=2) + block_H_z = 0.0_dp + if (this%spinpol_no_scf) then + block_H_z(1:block_nr:2,1:block_nc:2) = block_H_up(1:block_nr/2,1:block_nc/2) + block_H_z(2:block_nr:2,2:block_nc:2) = block_H_down(1:block_nr/2,1:block_nc/2) + else + block_H_z(1:block_nr:2,1:block_nc:2) = 0.5_dp*(block_H_up(1:block_nr/2,1:block_nc/2)+block_H_down(1:block_nr/2,1:block_nc/2)) + block_H_z(2:block_nr:2,2:block_nc:2) = 0.5_dp*(block_H_up(1:block_nr/2,1:block_nc/2)+block_H_down(1:block_nr/2,1:block_nc/2)) + endif + block_S_z = 0.0_dp + block_S_z(1:block_nr:2,1:block_nc:2) = block_S(1:block_nr/2,1:block_nc/2) + block_S_z(2:block_nr:2,2:block_nc:2) = block_S(1:block_nr/2,1:block_nc/2) + if (u_no_S_spin) then + block_S_z(1:block_nr:2,2:block_nc:2) = block_S(1:block_nr/2,1:block_nc/2) + block_S_z(2:block_nr:2,1:block_nc:2) = block_S(1:block_nr/2,1:block_nc/2) + endif + if (this%SO%active .and. (i == j) .and. (dv_mag .feq. 0.0_dp)) then + call get_SO_block(this%SO, this%tbmodel, at%Z(i), block_SO) + block_H_z = block_H_z + block_SO + endif + if (u_do_dipole) call system_abort("No dipole for noncollinear magnetism yet") + else ! not noncollinear + call get_HS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, block_H, block_S) + if (this%complex_matrices) then + block_H_z = block_H + block_S_z = block_S + endif + if (u_do_dipole) then + call get_dipole_block(this%dipole_model, at, i, j, dv_hat, dv_mag, block_dipole) + if (this%complex_matrices) then + block_dipole_z = block_dipole + endif + endif + endif + + if (u_do_H) then + if (this%scf%active) then + do ii=1, this%first_orb_of_atom(i+1)-this%first_orb_of_atom(i) + do jj=1, this%first_orb_of_atom(j+1)-this%first_orb_of_atom(j) + if (this%complex_matrices) then + block_H_z(ii,jj) = block_H_z(ii,jj) + & + 0.5_dp*( this%scf%orb_local_pot(this%first_orb_of_atom(i)+ii-1) + & + this%scf%orb_local_pot(this%first_orb_of_atom(j)+jj-1) ) * block_S_z(ii,jj) + else + block_H(ii,jj) = block_H(ii,jj) + & + 0.5_dp*( this%scf%orb_local_pot(this%first_orb_of_atom(i)+ii-1) + & + this%scf%orb_local_pot(this%first_orb_of_atom(j)+jj-1) ) * block_S(ii,jj) + endif + end do + end do + + if (this%noncollinear) then + do ii=1, block_nr, 2 + do jj=1, block_nc, 2 + iii = (ii-1)/2+1 + jjj = (jj-1)/2+1 + call add_exch_field_local_pot(0.5_dp*(this%scf%orb_exch_field(1:3,this%first_orb_of_atom(i)+ii-1) + & + this%scf%orb_exch_field(1:3,this%first_orb_of_atom(j)+jj-1)), & + block_S(iii,jjj), block_H_z(ii:ii+1,jj:jj+1) ) + end do + end do + endif + + endif + endif + + if (this%complex_matrices) then + if (this%kpoints%non_gamma) then + do ik=1, this%kpoints%N + expf = calc_phase(this%kpoints, ik, shift) + if (u_do_H) then + block_H_z_phase = block_H_z*expf + call add_block(H, ik, block_H_z_phase, block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + if (u_do_S) then + block_S_z_phase = block_S_z*expf + call add_block(S, ik, block_S_z_phase, block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + if (u_do_dipole) then + block_dipole_z_phase = block_dipole_z*expf + call add_block(dipole(1), ik, block_dipole_z_phase(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(dipole(2), ik, block_dipole_z_phase(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(dipole(3), ik, block_dipole_z_phase(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + end do + else ! gamma-point + if (u_do_H) then + call add_block(H, 1, block_H_z, block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + if (u_do_S) then + call add_block(S, 1, block_S_z, block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + if (u_do_dipole) then + call add_block(dipole(1), 1, block_dipole_z(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(dipole(2), 1, block_dipole_z(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(dipole(3), 1, block_dipole_z(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + endif ! non gamma + else ! real matrices + do ik=1, this%n_matrices + if (u_do_H) then + call add_block(H, ik, block_H, block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + if (u_do_S) then + call add_block(S, ik, block_S, block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + if (u_do_dipole) then + call add_block(dipole(1), ik, block_dipole(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(dipole(2), ik, block_dipole(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(dipole(3), ik, block_dipole(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + end do + endif ! complex matrices + + end do + end do + + if (allocated(block_H)) deallocate(block_H) + if (allocated(block_H_up)) deallocate(block_H_up) + if (allocated(block_H_down)) deallocate(block_H_down) + if (allocated(block_S)) deallocate(block_S) + if (allocated(block_dipole)) deallocate(block_dipole) + if (allocated(block_H_z)) deallocate(block_H_z) + if (allocated(block_S_z)) deallocate(block_S_z) + if (allocated(block_dipole_z)) deallocate(block_dipole_z) + if (allocated(block_H_z_phase)) deallocate(block_H_z_phase) + if (allocated(block_S_z_phase)) deallocate(block_S_z_phase) + if (allocated(block_dipole_z_phase)) deallocate(block_dipole_z_phase) + + ! if (do_H) call make_hermitian(H) + ! if (do_S) call make_hermitian(S) + +end subroutine TBSystem_fill_these_matrices + +subroutine add_exch_field_local_pot(exch_field, block_S, block_H_z) + real(dp), intent(in) :: exch_field(3) + real(dp), intent(in) :: block_S + complex(dp), intent(inout) :: block_H_z(2,2) + + complex(dp) :: E_dot_sigma(2,2) + + E_dot_sigma(:,:) = exch_field(1)*pauli_sigma(:,:,1) + exch_field(2)*pauli_sigma(:,:,2) + exch_field(3)*pauli_sigma(:,:,3) + + block_H_z = block_H_z + block_S*E_dot_sigma + +end subroutine add_exch_field_local_pot + +subroutine TBSystem_fill_dmatrices(this, at, at_ind, need_S, dense, diag_mask, offdiag_mask) + type (TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: at_ind + logical, intent(in), optional :: need_S, dense + logical, intent(out), optional, target :: diag_mask(:), offdiag_mask(:) + + integer :: i, ji, j, ik, ii, jj + real(dp), allocatable :: block_dH(:,:,:), block_dS(:,:,:), block_dH_up(:,:,:), block_dH_down(:,:,:) + complex(dp), allocatable :: block_dH_z(:,:,:), block_dS_z(:,:,:) + complex(dp), allocatable :: block_dH_z_phase(:,:,:), block_dS_z_phase(:,:,:) + real(dp) :: dv_hat(3), dv_mag + integer :: shift(3) + + logical, pointer :: d_mask(:), od_mask(:) + + logical :: do_S, do_S_block + logical :: block_active + + complex(dp) :: expf + + integer block_nr, block_nc + + if (at_ind >= 0) then + if (at_ind < 1 .or. at_ind > at%N) & + call system_abort("Called TBSystem_fill_dmatrices for atom with at_ind " // at_ind // " > 0, but out of range " // 1 // " " // at%N) + else + if (at_ind < -3 .or. at_ind > -1) & + call system_abort("Called TBSystem_fill_dmatrices for virial with at_ind " // at_ind // " < 0, but out of range " // -3 // " " // -3) + end if + + do_S = .not. this%tbmodel%is_orthogonal + if (present(need_S)) do_S = do_S .or. need_S + do_S_block = do_S .or. this%scf%active + + allocate(block_dH(this%max_block_size, this%max_block_size, 3)) + allocate(block_dH_up(this%max_block_size, this%max_block_size, 3)) + allocate(block_dH_down(this%max_block_size, this%max_block_size, 3)) + allocate(block_dS(this%max_block_size, this%max_block_size, 3)) + block_dH = 0.0_dp + block_dH_up = 0.0_dp + block_dH_down = 0.0_dp + block_dS = 0.0_dp + if (this%complex_matrices) then + allocate(block_dH_z(this%max_block_size, this%max_block_size, 3)) + allocate(block_dS_z(this%max_block_size, this%max_block_size, 3)) + block_dH_z = 0.0_dp + block_dS_z = 0.0_dp + if (this%kpoints%non_gamma) then + allocate(block_dH_z_phase(this%max_block_size, this%max_block_size, 3)) + allocate(block_dS_z_phase(this%max_block_size, this%max_block_size, 3)) + block_dH_z_phase = 0.0_dp + block_dS_z_phase = 0.0_dp + endif + endif + + if (present(diag_mask)) then + d_mask => diag_mask + else + allocate(d_mask(at%N)) + endif + if (present(offdiag_mask)) then + od_mask => offdiag_mask + else + allocate(od_mask(at%N)) + endif + call get_dHS_masks(this%tbmodel, at, at_ind, d_mask, od_mask) + + call Zero(this%dH(1), d_mask, od_mask) + call Zero(this%dH(2), d_mask, od_mask) + call Zero(this%dH(3), d_mask, od_mask) + if (do_S) then + call Zero(this%dS(1), d_mask, od_mask) + call Zero(this%dS(2), d_mask, od_mask) + call Zero(this%dS(3), d_mask, od_mask) + endif + + do i=1, at%N + block_nr = this%first_orb_of_atom(i+1)-this%first_orb_of_atom(i) + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, dv_mag, cosines = dv_hat, shift = shift) + block_nc = this%first_orb_of_atom(j+1)-this%first_orb_of_atom(j) + + + if ((i == j .and. .not. d_mask(i)) .or. & + (i /= j .and. .not. od_mask(i) .and. .not. od_mask(j))) then + cycle + endif + + if (this%noncollinear) then + if (.not. this%complex_matrices) call system_abort("noncollinear supported for complex matrices only") + if (.not. this%spinpol_no_scf) call system_abort("noncollinear forces only supported for spinpol_no_scf") + block_active = get_dHS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, at_ind, block_dH_up, block_dS, i_mag=1) + block_active = get_dHS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, at_ind, block_dH_down, block_dS, i_mag=2) + if (block_active .and. this%complex_matrices) then + block_dH_z(1:block_nr:2,1:block_nc:2,:) = block_dH_up(1:block_nr/2,1:block_nc/2,:) + block_dH_z(2:block_nr:2,2:block_nc:2,:) = block_dH_down(1:block_nr/2,1:block_nc/2,:) + if (do_S_block) then + block_dS_z(1:block_nr:2,1:block_nc:2,:) = block_dS(1:block_nr/2,1:block_nc/2,:) + block_dS_z(2:block_nr:2,2:block_nc:2,:) = block_dS(1:block_nr/2,1:block_nc/2,:) + endif + endif + else + block_active = get_dHS_blocks(this%tbmodel, at, i, j, dv_hat, dv_mag, at_ind, block_dH, block_dS) + if (block_active .and. this%complex_matrices) then + block_dH_z = block_dH + if (do_S_block) block_dS_z = block_dS + endif + endif + + if (block_active .and. this%scf%active) then + do ii=1, this%first_orb_of_atom(i+1)-this%first_orb_of_atom(i) + do jj=1, this%first_orb_of_atom(j+1)-this%first_orb_of_atom(j) + if (this%complex_matrices) then + block_dH_z(ii,jj,:) = block_dH_z(ii,jj,:) + & + 0.5_dp*( this%scf%orb_local_pot(this%first_orb_of_atom(i)+ii-1) + & + this%scf%orb_local_pot(this%first_orb_of_atom(j)+jj-1) ) * block_dS_z(ii,jj,:) + else + block_dH(ii,jj,:) = block_dH(ii,jj,:) + & + 0.5_dp*( this%scf%orb_local_pot(this%first_orb_of_atom(i)+ii-1) + & + this%scf%orb_local_pot(this%first_orb_of_atom(j)+jj-1) ) * block_dS(ii,jj,:) + endif + end do + end do + ! need to add noncollinear stuff here !!! + endif + + if (block_active) then + if (this%complex_matrices) then + if (this%kpoints%non_gamma) then + do ik=1, this%kpoints%N + expf = calc_phase(this%kpoints, ik, shift) + block_dH_z_phase = block_dH_z*expf + call add_block(this%dH(1), ik, block_dH_z_phase(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dH(2), ik, block_dH_z_phase(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dH(3), ik, block_dH_z_phase(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + if (do_S) then + block_dS_z_phase = block_dS_z*expf + call add_block(this%dS(1), ik, block_dS_z_phase(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dS(2), ik, block_dS_z_phase(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dS(3), ik, block_dS_z_phase(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + end do + else ! gamma + call add_block(this%dH(1), 1, block_dH_z(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dH(2), 1, block_dH_z(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dH(3), 1, block_dH_z(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + if (do_S) then + call add_block(this%dS(1), 1, block_dS_z(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dS(2), 1, block_dS_z(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dS(3), 1, block_dS_z(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + endif ! non_gamma + else ! real matrices + call add_block(this%dH(1), 1, block_dH(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dH(2), 1, block_dH(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dH(3), 1, block_dH(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + if (do_S) then + call add_block(this%dS(1), 1, block_dS(:,:,1), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dS(2), 1, block_dS(:,:,2), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + call add_block(this%dS(3), 1, block_dS(:,:,3), block_nr, block_nc, & + this%first_orb_of_atom(i), this%first_orb_of_atom(j), i, j) + endif + endif ! complex_matrices + endif ! block_active + + end do ! i + end do ! j + + if (allocated(block_dH)) deallocate(block_dH) + if (allocated(block_dS)) deallocate(block_dS) + if (allocated(block_dH_z)) deallocate(block_dH_z) + if (allocated(block_dS_z)) deallocate(block_dS_z) + if (allocated(block_dH_z_phase)) deallocate(block_dH_z_phase) + if (allocated(block_dS_z_phase)) deallocate(block_dS_z_phase) + + if (.not. present(diag_mask)) deallocate(d_mask) + if (.not. present(offdiag_mask)) deallocate(od_mask) + +end subroutine + +subroutine TBSystem_ksum_mat_d(this, tbm, m) + type(TBSystem), intent(in) :: this + type(TBMatrix), intent(in) :: tbm + type(MatrixD), intent(inout) :: m + + call sum_matrices(tbm, this%kpoints%weights, m) +end subroutine + +subroutine TBSystem_ksum_atom_orbital_sum_mat_d(this, tbm, m) + type(TBSystem), intent(in) :: this + type(TBMatrix), intent(in) :: tbm + type(MatrixD), intent(inout) :: m + + type(MatrixD) :: t_m + + call Initialise(t_m, this%N) + call Zero(t_m) + + call sum_matrices(tbm, this%kpoints%weights, t_m) + call ksum_distrib_inplace(this%kpoints, t_m%data) + + call atom_orbital_sum_mat(this, t_m%data, m%data) +end subroutine + +function TBSystem_atom_orbital_sum_real2(this,a) + type(TBSystem), intent(in) :: this + real(dp), intent(in) :: a(:,:) + real(dp) :: TBSystem_atom_orbital_sum_real2(this%N_atoms,size(a,2)) + + integer i + + if (size(a,1) /= this%N) then + call system_abort("Called TBSystem_atom_orbital_sum_real2 with wrong size array") + endif + + do i=1, this%N_atoms + TBSystem_atom_orbital_sum_real2(i,:) = sum(a(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1,:),1) + end do +end function TBSystem_atom_orbital_sum_real2 + + +function TBSystem_atom_orbital_sum_real1(this,a) + type(TBSystem), intent(in) :: this + real(dp), intent(in) :: a(:) + real(dp) :: TBSystem_atom_orbital_sum_real1(this%N_atoms) + + integer i + + if (size(a) /= this%N) then + call system_abort("Called TBSystem_atom_orbital_sum_real1 with wrong size array") + endif + + do i=1, this%N_atoms + TBSystem_atom_orbital_sum_real1(i) = sum(a(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1)) + end do +end function TBSystem_atom_orbital_sum_real1 + +function TBSystem_atom_orbital_sum_complex2(this,a) + type(TBSystem), intent(in) :: this + complex(dp), intent(in) :: a(:,:) + complex(dp) :: TBSystem_atom_orbital_sum_complex2(this%N_atoms, size(a,2)) + + integer i + + if (size(a,1) /= this%N) then + call system_abort("Called TBSystem_atom_orbital_sum_complex2 with wrong size array") + endif + + do i=1, this%N_atoms + TBSystem_atom_orbital_sum_complex2(i,:) = sum(a(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1,:),1) + end do +end function TBSystem_atom_orbital_sum_complex2 + +function TBSystem_atom_orbital_spread_real1(this,a) + type(TBSystem), intent(in) :: this + real(dp), intent(in) :: a(:) + real(dp) :: TBSystem_atom_orbital_spread_real1(this%N) + + integer i + + if (size(a) /= this%N_atoms) then + call system_abort("Called TBSystem_atom_orbital_spread_real1 with wrong size array a " // & + size(a) // " this%N_atoms " // this%N_atoms) + endif + + do i=1, this%N_atoms + TBSystem_atom_orbital_spread_real1(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1) = a(i) + end do +end function TBSystem_atom_orbital_spread_real1 + +subroutine TBSystem_atom_orbital_sum_mat_r(this,a, out) + type(TBSystem), intent(in) :: this + real(dp), intent(in) :: a(:,:) + real(dp), intent(out) :: out(:,:) + + integer i, j + + if (size(a,1) /= this%N .or. size(a,2) /= this%N) then + call system_abort("Called TBSystem_atom_orbital_sum_mat_r with wrong size input") + endif + if (size(out,1) /= this%N_atoms .or. size(out,2) /= this%N_atoms) then + call system_abort("Called TBSystem_atom_orbital_sum_mat_r with wrong size output") + endif + + do j=1, this%N_atoms + do i=1, this%N_atoms + out(i,j) = sum(a(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1, & + this%first_orb_of_atom(j):this%first_orb_of_atom(j+1)-1)) + end do + end do +end subroutine TBSystem_atom_orbital_sum_mat_r + +subroutine TBSystem_atom_orbital_spread_mat_r(this,a, out) + type(TBSystem), intent(in) :: this + real(dp), intent(in) :: a(:,:) + real(dp), intent(out) :: out(:,:) + + integer i, j + + if (size(a,1) /= this%N_atoms .or. size(a,2) /= this%N_atoms) then + call system_abort("Called TBSystem_atom_orbital_spread_mat_r with wrong size input") + endif + if (size(out,1) /= this%N .or. size(out,2) /= this%N) then + call system_abort("Called TBSystem_atom_orbital_spread_mat_r with wrong size output") + endif + + do j=1, this%N_atoms + do i=1, this%N_atoms + out(this%first_orb_of_atom(i):this%first_orb_of_atom(i+1)-1, & + this%first_orb_of_atom(j):this%first_orb_of_atom(j+1)-1) = a(i,j) + end do + end do +end subroutine TBSystem_atom_orbital_spread_mat_r + +function TBSystem_manifold_orbital_sum_real2(this,a) + type(TBSystem), intent(in) :: this + real(dp), intent(in) :: a(:,:) + real(dp) :: TBSystem_manifold_orbital_sum_real2(size(a,1),this%N_manifolds) + + integer i + + if (size(a,2) /= this%N) then + call system_abort("Called TBSystem_manifold_orbital_sum_real2 with wrong size array shape(a) " // shape(a) // " this%N " // (this%N)) + endif + + do i=1, this%N_manifolds + TBSystem_manifold_orbital_sum_real2(:,i) = sum(a(:,this%first_orb_of_manifold(i):this%first_orb_of_manifold(i+1)-1),2) + end do +end function TBSystem_manifold_orbital_sum_real2 + +subroutine TBSystem_Print(this,file) + type(TBSystem), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + if (current_verbosity() < PRINT_NORMAL) return + + call Print ('TBSystem : N N_atoms ' // this%N // " " // this%N_atoms, file=file) + + call Print (this%tbmodel, file=file) + + if (this%kpoints%non_gamma) then + call Print (this%kpoints, file=file) + endif + if (this%scf%active) then + call Print (this%scf, file=file) + endif + if (this%dipole_model%active) then + call Print (this%dipole_model, file=file) + endif + + if (this%SO%active) then + call Print (this%SO, file=file) + endif + + if (this%N > 0) then + call verbosity_push_decrement(PRINT_NERD) + call Print("first_orb_of_atom", file=file) + call Print(this%first_orb_of_atom, file=file) + + call Print("first_manifold_of_atom", file=file) + call Print(this%first_manifold_of_atom, file=file) + + call Print("first_orb_of_manifold", file=file) + call Print(this%first_orb_of_manifold, file=file) + + call print("H", file=file) + call Print (this%H, file=file) + call print("S", file=file) + call Print (this%S, file=file) + call verbosity_pop() + endif + +end subroutine TBSystem_Print + +subroutine TBSystem_copy_matrices(this, Hd, Sd, Hz, Sz, index) + type(TBSystem), intent(in) :: this + real(dp), intent(inout), optional, dimension(:,:) :: Hd, Sd + complex(dp), intent(inout), optional, dimension(:,:) :: Hz, Sz + integer, intent(in), optional :: index + + if (present(Hd)) call copy(this%H, Hd, index=index) + if (present(Hz)) call copy(this%H, Hz, index=index) + if (present(Sd)) call copy(this%S, Sd, index=index) + if (present(Sz)) call copy(this%S, Sz, index=index) +end subroutine TBSystem_copy_matrices + +subroutine Self_Consistency_Initialise_str(this, args_str, param_str) + type(Self_Consistency), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + call Finalise(this) + + call read_params_xml(this, param_str) + + call set_type(this, args_str) + +end subroutine Self_Consistency_Initialise_str + +subroutine TB_Dipole_Model_Initialise_str(this, args_str, param_str) + type(TB_Dipole_Model), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + call Finalise(this) + + call read_params_xml(this, param_str) + +end subroutine TB_Dipole_Model_Initialise_str + +subroutine TB_Spin_Orbit_Coupling_Initialise_str(this, args_str, param_str) + type(TB_Spin_Orbit_Coupling), intent(inout) :: this + character(len=*), intent(in) :: args_str, param_str + + type(Dictionary) :: params + + call Finalise(this) + + call read_params_xml(this, param_str) + + call initialise(params) + call param_register(params, 'spin_orbit_coupling', 'F', this%active, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TB_Spin_Orbit_Coupling_Initialise_str args_str')) then + call system_abort("TB_Spin_Orbit_Coupling_Initialise_str failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + +end subroutine TB_Spin_Orbit_Coupling_Initialise_str + +subroutine Self_Consistency_set_type_str(this, args_str) + type(Self_Consistency), intent(inout) :: this + character(len=*), intent(in) :: args_str + + type(Dictionary) :: params + real(dp) :: global_U + logical :: is_SCF(8) + integer :: i, i_term, N_terms + + call initialise(params) + + call param_register(params, 'SCF_LOCAL_U', 'F', is_SCF(SCF_LOCAL_U), help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_NONLOCAL_U_DFTB', 'F', is_SCF(SCF_NONLOCAL_U_DFTB), help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_NONLOCAL_U_NRL_TB', 'F', is_SCF(SCF_NONLOCAL_U_NRL_TB), help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_GLOBAL_U', 'F', is_SCF(SCF_GLOBAL_U), help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_LCN', 'F', is_SCF(SCF_LCN), help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_GCN', 'F', is_SCF(SCF_GCN), help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_SPIN_DIR', 'F', is_SCF(SCF_SPIN_DIR), help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_SPIN_STONER', 'F', is_SCF(SCF_SPIN_STONER), help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'GLOBAL_U', '-1.0', global_U, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_ALPHA', ''//this%alpha, this%alpha, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_W0', ''//this%w0, this%w0, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_MAX_ITER', ''//this%max_iter, this%max_iter, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_MIX_SIMPLE', ''//this%mix_simple, this%mix_simple, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_CONV_TOL', ''//this%conv_tol, this%conv_tol, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_MIX_SIMPLE_END_TOL', ''//this%mix_simple_end_tol, this%mix_simple_end_tol, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'SCF_MIX_SIMPLE_START_TOL', ''//this%mix_simple_start_tol, this%mix_simple_start_tol, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='Self_Consistency_set_type_str args_str')) then + call system_abort("Self_Consistency_Initialise_str failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + + if (count(is_SCF) == 0) return + + if (is_SCF(SCF_LCN) .or. is_SCF(SCF_GCN)) then + if (count(is_SCF) /= 1) & + call system_abort("Self_Consistency_set_type_str got SCF_LCN or SCF_GCN, but also some other sort of SCF") + endif + + this%active = .true. + + N_terms = count(is_SCF) + if (allocated(this%terms)) then + do i_term=1, size(this%terms) + call Finalise(this%terms(i_term)) + end do + deallocate(this%terms) + endif + allocate(this%terms(N_terms)) + i_term = 0 + do i=1, size(is_SCF) + if (is_SCF(i)) then + i_term = i_term + 1 + this%terms(i_term)%type = i + this%terms(i_term)%active = .true. + end if + end do + +end subroutine Self_Consistency_set_type_str + +subroutine Self_Consistency_Finalise(this) + type(Self_Consistency), intent(inout) :: this + + integer :: i_term + + call Wipe(this) + + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%stoner_param)) deallocate(this%stoner_param) + + if (allocated(this%terms)) then + do i_term=1, size(this%terms) + call Finalise(this%terms(i_term)) + end do + deallocate(this%terms) + end if + + this%active = .false. + +end subroutine Self_Consistency_Finalise + +subroutine Self_Consistency_Term_Finalise(this) + type(Self_Consistency_Term), intent(inout) :: this + + call wipe(this) + + this%type = SCF_NONE + this%N = 0 + this%N_atoms = 0 + this%N_manifolds = 0 + + this%global_U = 0.0_dp + + this%active = .false. + +end subroutine Self_Consistency_Term_Finalise + +subroutine Self_Consistency_Wipe(this) + type(Self_Consistency), intent(inout) :: this + + integer :: i_term + + if (allocated(this%orb_local_pot)) deallocate(this%orb_local_pot) + if (allocated(this%orb_exch_field)) deallocate(this%orb_exch_field) + + if (allocated(this%terms)) then + do i_term=1, size(this%terms) + call Wipe(this%terms(i_term)) + end do + end if + + this%N = 0 + this%N_atoms = 0 + this%N_manifolds = 0 +end subroutine Self_Consistency_Wipe + +subroutine Self_Consistency_Term_Wipe(this) + type(Self_Consistency_Term), intent(inout) :: this + + this%N = 0 + this%N_atoms = 0 + this%N_manifolds = 0 + this%n_dof = 0 + + this%global_N = 0.0 + this%global_pot = 0.0 + + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%spin_splitting)) deallocate(this%spin_splitting) + if (allocated(this%stoner_param)) deallocate(this%stoner_param) + if (allocated(this%atomic_n)) deallocate(this%atomic_n) + if (allocated(this%atomic_n0)) deallocate(this%atomic_n0) + if (allocated(this%manifold_mom)) deallocate(this%manifold_mom) + if (allocated(this%atomic_local_pot)) deallocate(this%atomic_local_pot) + if (allocated(this%datomic_local_pot_dr)) deallocate(this%datomic_local_pot_dr) + if (allocated(this%gamma)) deallocate(this%gamma) + if (allocated(this%dgamma_dr)) deallocate(this%dgamma_dr) + +end subroutine Self_Consistency_Term_Wipe + +subroutine TB_Dipole_Model_Finalise(this) + type(TB_Dipole_Model), intent(inout) :: this + + this%n_types = 0 + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) + if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) + if (allocated(this%orb_set_phase)) deallocate(this%orb_set_phase) + if (allocated(this%gaussian_width)) deallocate(this%gaussian_width) + + this%active = .false. + +end subroutine TB_Dipole_Model_Finalise + +subroutine TB_Spin_Orbit_Coupling_Finalise(this) + type(TB_Spin_Orbit_Coupling), intent(inout) :: this + + this%n_types = 0 + if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num) + if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) + if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) + if (allocated(this%SO_param)) deallocate(this%SO_param) + + this%active = .false. + +end subroutine TB_Spin_Orbit_Coupling_Finalise + +subroutine TBSystem_scf_set_atomic_n_mom(this, atomic_n, atomic_mom, atomic_pot) + type(TBSystem), intent(inout) :: this + real(dp), intent(in), pointer :: atomic_n(:), atomic_mom(:,:), atomic_pot(:) + + integer :: i_term, i_at, i_man + + do i_term=1, size(this%scf%terms) + if (allocated(this%scf%terms(i_term)%atomic_n)) then + if (associated(atomic_n)) then + this%scf%terms(i_term)%atomic_n = atomic_n + else + this%scf%terms(i_term)%atomic_n = this%scf%terms(i_term)%atomic_n0 + endif + end if + if (allocated(this%scf%terms(i_term)%manifold_mom)) then + if (associated(atomic_mom)) then + this%scf%terms(i_term)%manifold_mom = 0.0_dp + do i_at=1, this%N_atoms + do i_man = this%first_manifold_of_atom(i_at), this%first_manifold_of_atom(i_at+1)-1 + if (i_man == this%first_manifold_of_atom(i_at+1)-1) then + this%scf%terms(i_term)%manifold_mom(:,i_man) = atomic_mom(:,i_at) + else + this%scf%terms(i_term)%manifold_mom(:,i_man) = 1.0e-6_dp*atomic_mom(:,i_at) + endif + end do + end do + else + this%scf%terms(i_term)%manifold_mom = 0.0_dp + endif + end if ! manifold_mom is allocated + if (allocated(this%scf%terms(i_term)%atomic_local_pot)) then + if (associated(atomic_pot)) then + this%scf%terms(i_term)%atomic_local_pot = atomic_pot + else + this%scf%terms(i_term)%atomic_local_pot = 0.0_dp + endif + end if + end do ! atomic_local_pot is allocated +end subroutine TBSystem_scf_set_atomic_n_mom + +subroutine TBSystem_scf_set_global_N(this, global_at_weight, global_N) + type(TBSystem), intent(inout) :: this + real(dp), intent(in), pointer :: global_at_weight(:) + real(dp), intent(in), optional :: global_N + + integer i_term + + ! if global weight isn't associated, we can't set global_N. + ! If it's actually needed by some SCF terms, they'll complain + if (.not. associated(global_at_weight)) return + + do i_term=1, size(this%scf%terms) + if (present(global_N)) then + this%scf%terms(i_term)%global_N = global_N + else + this%scf%terms(i_term)%global_N = sum(this%scf%terms(i_term)%atomic_n0*global_at_weight) + endif + end do +end subroutine TBSystem_scf_set_global_N + +subroutine TBSystem_scf_get_atomic_n_mom(this, atomic_n, atomic_mom, atomic_pot) + type(TBSystem), intent(inout) :: this + real(dp), intent(out), pointer :: atomic_n(:), atomic_mom(:,:), atomic_pot(:) + + integer i_term, i_at, i_man + logical got_atomic_n, got_manifold_mom, got_atomic_pot + + if (associated(atomic_n)) then + atomic_n = 0.0_dp + got_atomic_n = .false. + do i_term=1, size(this%scf%terms) + if (allocated(this%scf%terms(i_term)%atomic_n)) then + if (got_atomic_n) & + call system_abort("TBSystem_scf_get_atomic_n_mom found atomic_n allocated in more than 1 term") + atomic_n = this%scf%terms(i_term)%atomic_n + got_atomic_n = .true. + end if + end do + + if (.not. got_atomic_n) & + call print("WARNING: TBSystem_scf_get_atomic_n_mom was passed atomic_n but didn't find " // & + "atomic_n allocated in any terms", PRINT_ALWAYS) + end if + + if (associated(atomic_mom)) then + got_manifold_mom = .false. + do i_term=1, size(this%scf%terms) + if (allocated(this%scf%terms(i_term)%manifold_mom)) then + if (got_manifold_mom) & + call system_abort("TBSystem_scf_get_atomic_n_mom found manifold_mom allocated in more than 1 term") + do i_at=1, this%N_atoms + i_man = this%first_manifold_of_atom(i_at+1)-1 + atomic_mom(:,i_at) = this%scf%terms(i_term)%manifold_mom(:,i_man) + end do + got_manifold_mom = .true. + end if + end do + + if (.not. got_manifold_mom) & + call print("WARNING: TBSystem_scf_get_atomic_n_mom was passed atomic_mom but didn't find " // & + "manifold_mom allocated in any terms", PRINT_ALWAYS) + end if + + if (associated(atomic_pot)) then + atomic_pot = 0.0_dp + got_atomic_pot = .false. + do i_term=1, size(this%scf%terms) + if (allocated(this%scf%terms(i_term)%atomic_local_pot)) then + if (got_atomic_pot) & + call system_abort("TBSystem_scf_get_atomic_n_mom found atomic_pot allocated in more than 1 term") + atomic_pot = this%scf%terms(i_term)%atomic_local_pot + got_atomic_pot = .true. + end if + end do + + if (.not. got_atomic_pot) & + call print("WARNING: TBSystem_scf_get_atomic_n_mom was passed atomic_pot but didn't find " // & + "atomic_pot allocated in any terms", PRINT_ALWAYS) + end if + +end subroutine TBSystem_scf_get_atomic_n_mom + +subroutine TBSystem_scf_get_global_N(this, global_N) + type(TBSystem), intent(inout) :: this + real(dp), intent(out) :: global_N + + integer i_term + logical got_global_N + + got_global_N = .false. + do i_term=1, size(this%scf%terms) + if (this%scf%terms(i_term)%global_U > 0.0_dp) then + if (got_global_N) & + call system_abort("TBSystem_scf_get_global_N found global_N allocated in more than 1 term") + global_N = this%scf%terms(i_term)%global_N + got_global_N = .true. + endif + end do + + if (.not. got_global_N) & + call system_abort("TBSystem_scf_get_global_N didn't find global_N allocated in any terms") +end subroutine TBSystem_scf_get_global_N + +subroutine SC_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_self_consistency) then + if (name == "self_consistency") then + parse_in_self_consistency = .false. + endif + endif +end subroutine SC_endElement_handler + +subroutine SC_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + integer :: max_stoner_manifolds, n_stoner_params + integer :: atnum + + if (name == "self_consistency") then + parse_in_self_consistency = .true. + + call QUIP_FoX_get_value(attributes, 'tolerance', value, status) + if (status /= 0) then + call print("Can't find tolerance in self_consistency", PRINT_ALWAYS) + else + read (value, *) parse_self_consistency%conv_tol + endif + + call QUIP_FoX_get_value(attributes, 'global_U', value, status) + if (status == 0) read (value, *) parse_self_consistency%global_U + + if (allocated(parse_self_consistency%U)) deallocate(parse_self_consistency%U) + allocate(parse_self_consistency%U(size(ElementName))) + parse_self_consistency%U = 0.0_dp + + call QUIP_FoX_get_value(attributes, 'max_stoner_manifolds', value, status) + if (status == 0) then + read (value, *) max_stoner_manifolds + if (allocated(parse_self_consistency%stoner_param)) deallocate(parse_self_consistency%stoner_param) + allocate(parse_self_consistency%stoner_param(max_stoner_manifolds,size(ElementName))) + parse_self_consistency%stoner_param = 0.0_dp + endif + + else if (parse_in_self_consistency .and. name == "U") then + + call QUIP_FoX_get_value(attributes, 'Z', value, status) + if (status /= 0) call system_abort('Self_Consistency_read_params_xml cannot find Z attribute in U') + read (value, *) atnum + + if (atnum <= 0 .or. atnum > size(parse_self_consistency%U)) & + call system_abort ("SC parse xml atnum " // atnum // " out of range " // 1 // " " // size(parse_self_consistency%U)) + call QUIP_FoX_get_value(attributes, 'U', value, status) + if (status /= 0) call system_abort('Self_Consistency_read_params_xml cannot find U attribute') + read (value, *) parse_self_consistency%U(atnum) + + else if (parse_in_self_consistency .and. name == "stoner_params") then + + call QUIP_FoX_get_value(attributes, 'Z', value, status) + if (status /= 0) call system_abort('Self_Consistency_read_params_xml cannot find Z attribute in stoner_params') + read (value, *) atnum + + call QUIP_FoX_get_value(attributes, 'n_stoner_params', value, status) + if (status == 0) then + read (value, *) n_stoner_params + if (n_stoner_params > 0) then + call QUIP_FoX_get_value(attributes, 'stoner_params', value, status) + if (status /= 0) & + call system_abort("parse self consistency got n_stoner_params " // n_stoner_params // " for Z=" // atnum // " but can't find actual stoner_params") + read (value, *) parse_self_consistency%stoner_param(1:n_stoner_params,atnum) + end if + end if + endif + +end subroutine SC_startElement_handler + +subroutine Self_Consistency_read_params_xml(this, in) + type(Self_Consistency), intent(inout), target :: this + character(len=*) :: in + + type(xml_t) :: fxml + + if (len(trim(in)) <= 0) then + return + endif + + parse_in_self_consistency = .false. + parse_self_consistency => this + + call open_xml_string(fxml, in) + + call parse(fxml, & + startElement_handler = SC_startElement_handler, & + endElement_handler = SC_endElement_handler) + + call close_xml_t(fxml) + +end subroutine Self_Consistency_read_params_xml + +subroutine DM_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_dipole_model) then + if (name == "dipole_model") then + parse_in_dipole_model = .false. + endif + endif +end subroutine DM_endElement_handler + +subroutine DM_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + integer :: atnum, i_type, new_n_orb_sets, i + character(len=1), allocatable :: orb_set_types_str(:) + + if (name == "dipole_model") then + parse_in_dipole_model = .true. + + parse_dipole_model%n_types = 0 + + if (allocated(parse_dipole_model%type_of_atomic_num)) deallocate(parse_dipole_model%type_of_atomic_num) + allocate(parse_dipole_model%type_of_atomic_num(size(ElementName))) + parse_dipole_model%type_of_atomic_num = 0 + + else if (parse_in_dipole_model .and. name == "element") then + parse_dipole_model%active = .true. + i_type = parse_dipole_model%n_types + 1 + + call QUIP_FoX_get_value(attributes, 'Z', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find Z attribute in type ' // status) + read (value, *) atnum + if (atnum <= 0 .or. atnum > size(parse_dipole_model%type_of_atomic_num)) & + call system_abort ("DM parse xml atnum " // atnum // " out of range " // 1 // " " // size(parse_dipole_model%type_of_atomic_num)) + + parse_dipole_model%type_of_atomic_num(atnum) = i_type + + call QUIP_FoX_get_value(attributes, 'n_orb_sets', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find n_orb_sets attribute ' // status) + read (value, *) new_n_orb_sets + + call realloc_dipole_model(parse_dipole_model, i_type, new_n_orb_sets) + + parse_dipole_model%atomic_num(i_type) = atnum + parse_dipole_model%n_orb_sets(i_type) = new_n_orb_sets + + allocate(orb_set_types_str(parse_dipole_model%n_orb_sets(i_type))) + call QUIP_FoX_get_value(attributes, 'orb_set_types', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find orb_set_types attribute ' // status) + read (value, *) orb_set_types_str + do i=1, parse_dipole_model%n_orb_sets(i_type) + if (orb_set_types_str(i) == 's' .or. orb_set_types_str(i) == 'S') then + parse_dipole_model%orb_set_type(i,i_type) = ORB_S + else if (orb_set_types_str(i) == 'p' .or. orb_set_types_str(i) == 'P') then + parse_dipole_model%orb_set_type(i,i_type) = ORB_P + else if (orb_set_types_str(i) == 'd' .or. orb_set_types_str(i) == 'D') then + parse_dipole_model%orb_set_type(i,i_type) = ORB_D + endif + end do + + call QUIP_FoX_get_value(attributes, 'gaussian_widths', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find gaussian_widths attribute ' // status) + read (value, *) parse_dipole_model%gaussian_width(1:parse_dipole_model%n_orb_sets(i_type),i_type) + + call QUIP_FoX_get_value(attributes, 'orb_set_phases', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find orb_set_phase attribute ' // status) + read (value, *) parse_dipole_model%orb_set_phase(1:parse_dipole_model%n_orb_sets(i_type),i_type) + + endif + +end subroutine DM_startElement_handler + +subroutine SO_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + if (parse_in_spin_orbit_coupling) then + if (name == "spin_orbit_coupling") then + parse_in_spin_orbit_coupling = .false. + endif + endif +end subroutine SO_endElement_handler + +subroutine SO_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer :: status + character(len=1024) :: value + integer :: atnum, i_type, new_n_orb_sets, i + character(len=1), allocatable :: orb_set_types_str(:) + + if (name == "spin_orbit_coupling") then + parse_in_spin_orbit_coupling = .true. + + parse_spin_orbit_coupling%n_types = 0 + + if (allocated(parse_spin_orbit_coupling%type_of_atomic_num)) deallocate(parse_spin_orbit_coupling%type_of_atomic_num) + allocate(parse_spin_orbit_coupling%type_of_atomic_num(size(ElementName))) + parse_spin_orbit_coupling%type_of_atomic_num = 0 + + else if (parse_in_spin_orbit_coupling .and. name == "element") then + parse_spin_orbit_coupling%active = .true. + i_type = parse_spin_orbit_coupling%n_types + 1 + + call QUIP_FoX_get_value(attributes, 'Z', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find Z attribute in type ' // status) + read (value, *) atnum + if (atnum <= 0 .or. atnum > size(parse_spin_orbit_coupling%type_of_atomic_num)) & + call system_abort ("SO parse xml atnum " // atnum // " out of range " // 1 // " " // size(parse_spin_orbit_coupling%type_of_atomic_num)) + + parse_spin_orbit_coupling%type_of_atomic_num(atnum) = i_type + + call QUIP_FoX_get_value(attributes, 'n_orb_sets', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find n_orb_sets attribute ' // status) + read (value, *) new_n_orb_sets + + call realloc_spin_orbit_coupling(parse_spin_orbit_coupling, i_type, new_n_orb_sets) + + parse_spin_orbit_coupling%atomic_num(i_type) = atnum + parse_spin_orbit_coupling%n_orb_sets(i_type) = new_n_orb_sets + + allocate(orb_set_types_str(parse_spin_orbit_coupling%n_orb_sets(i_type))) + call QUIP_FoX_get_value(attributes, 'orb_set_types', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find orb_set_types attribute ' // status) + read (value, *) orb_set_types_str + do i=1, parse_spin_orbit_coupling%n_orb_sets(i_type) + if (orb_set_types_str(i) == 's' .or. orb_set_types_str(i) == 'S') then + parse_spin_orbit_coupling%orb_set_type(i,i_type) = ORB_S + else if (orb_set_types_str(i) == 'p' .or. orb_set_types_str(i) == 'P') then + parse_spin_orbit_coupling%orb_set_type(i,i_type) = ORB_P + else if (orb_set_types_str(i) == 'd' .or. orb_set_types_str(i) == 'D') then + parse_spin_orbit_coupling%orb_set_type(i,i_type) = ORB_D + endif + end do + + call QUIP_FoX_get_value(attributes, 'SO_params', value, status) + if (status /= 0) call system_abort('TB_Dipole_Model_read_params_xml cannot find SO_params attribute ' // status) + read (value, *) parse_spin_orbit_coupling%SO_param(1:parse_spin_orbit_coupling%n_orb_sets(i_type),i_type) + + endif + +end subroutine SO_startElement_handler + +subroutine TB_Dipole_Model_read_params_xml(this, in) + type(TB_Dipole_Model), intent(inout), target :: this + character(len=*) :: in + + type(xml_t) :: fxml + + if (len(trim(in)) <= 0) then + return + endif + + parse_in_dipole_model = .false. + parse_dipole_model => this + + call open_xml_string(fxml, in) + + call parse(fxml, & + startElement_handler = DM_startElement_handler, & + endElement_handler = DM_endElement_handler) + + call close_xml_t(fxml) + +end subroutine + +subroutine TB_Spin_Orbit_Coupling_read_params_xml(this, in) + type(TB_Spin_Orbit_Coupling), intent(inout), target :: this + character(len=*) :: in + + type(xml_t) :: fxml + + if (len(trim(in)) <= 0) then + return + endif + + parse_in_spin_orbit_coupling = .false. + parse_spin_orbit_coupling => this + + call open_xml_string(fxml, in) + + call parse(fxml, & + startElement_handler = SO_startElement_handler, & + endElement_handler = SO_endElement_handler) + + call close_xml_t(fxml) + +end subroutine + +subroutine Self_Consistency_setup_system(this, N, tbm, at_N, at_Z, N_manifolds) + type(Self_Consistency), intent(inout) :: this + integer, intent(in) :: N + type(TBModel), intent(in) :: tbm + integer, intent(in) :: at_N, at_Z(:), N_manifolds + + integer :: i_term + + call wipe(this) + + + this%N = N + this%N_atoms = at_N + this%N_manifolds = N_manifolds + + allocate(this%orb_local_pot(this%N)) + if (allocated(this%terms)) then + do i_term=1, size(this%terms) + if (this%terms(i_term)%type == SCF_SPIN_DIR .or. this%terms(i_term)%type == SCF_SPIN_STONER) then + allocate(this%orb_exch_field(3,this%N)) + exit + endif + end do + + do i_term=1, size(this%terms) + call setup_system(this%terms(i_term), this%N, tbm, at_N, at_Z, this%global_U, this%N_manifolds) + end do + end if + +end subroutine Self_Consistency_setup_system + +subroutine Self_Consistency_Term_setup_system(this, N, tbm, at_N, at_Z, global_U, N_manifolds) + type(Self_Consistency_Term), intent(inout) :: this + integer, intent(in) :: N + type(TBModel), intent(in) :: tbm + integer, intent(in) :: at_N, at_Z(:) + real(dp), intent(in) :: global_U + integer, intent(in) :: N_manifolds + + integer :: i + + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%stoner_param)) deallocate(this%stoner_param) + if (allocated(this%spin_splitting)) deallocate(this%spin_splitting) + if (allocated(this%atomic_n)) deallocate(this%atomic_n) + if (allocated(this%atomic_n0)) deallocate(this%atomic_n0) + if (allocated(this%manifold_mom)) deallocate(this%manifold_mom) + if (allocated(this%atomic_local_pot)) deallocate(this%atomic_local_pot) + if (allocated(this%gamma)) deallocate(this%gamma) + if (allocated(this%dgamma_dr)) deallocate(this%dgamma_dr) + + if (.not. this%active) return + + this%N = N + this%N_atoms = at_N + this%N_manifolds = N_manifolds + select case (this%type) + case(SCF_NONE) + this%n_dof = 0 + return + case(SCF_GCN) + this%n_dof = 1 + allocate(this%atomic_n0(this%N_atoms)) + do i=1, at_N + this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) + end do + this%global_pot = 0.0_dp + return + case(SCF_GLOBAL_U) + this%n_dof = 1 + this%global_U = global_U + allocate(this%atomic_n0(this%N_atoms)) + do i=1, at_N + this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) + end do + return + case(SCF_LCN) + this%n_dof = this%N_atoms + allocate(this%atomic_n0(this%N_atoms)) + do i=1, at_N + this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) + end do + allocate(this%atomic_n(this%N_atoms)) + allocate(this%atomic_local_pot(this%N_atoms)) + this%atomic_local_pot = 0.0_dp + return + case(SCF_LOCAL_U) + this%n_dof = this%N_atoms + allocate(this%U(this%N_atoms)) + this%U = 0.0_dp + allocate(this%atomic_n(this%N_atoms)) + allocate(this%atomic_n0(this%N_atoms)) + do i=1, at_N + this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) + end do + return + case(SCF_NONLOCAL_U_DFTB) + this%n_dof = this%N_atoms + allocate(this%gamma(this%N_atoms,this%N_atoms)) + this%gamma = 0.0_dp + allocate(this%atomic_n(this%N_atoms)) + allocate(this%atomic_n0(this%N_atoms)) + do i=1, at_N + this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) + end do + case(SCF_NONLOCAL_U_NRL_TB) + this%n_dof = this%N_atoms + allocate(this%gamma(this%N_atoms,this%N_atoms)) + this%gamma = 0.0_dp + allocate(this%atomic_n(this%N_atoms)) + allocate(this%atomic_n0(this%N_atoms)) + do i=1, at_N + this%atomic_n0(i) = n_elecs_of_Z(tbm,at_Z(i)) + end do + return + case(SCF_SPIN_DIR) + this%n_dof = 3*this%N_manifolds + allocate(this%manifold_mom(3,this%N_manifolds)) + allocate(this%spin_splitting(this%N_manifolds)) + this%spin_splitting = 0.0_dp + return + case(SCF_SPIN_STONER) + this%n_dof = 3*this%N_manifolds + allocate(this%manifold_mom(3,this%N_manifolds)) + allocate(this%stoner_param(this%N_manifolds)) + this%stoner_param = 0.0_dp + return + case default + call system_abort("Self_Consistency_Term_setup_system confused by this%type="//this%type) + end select + +end subroutine Self_Consistency_Term_setup_system + +subroutine TB_Dipole_Model_Print(this,file) + type(TB_Dipole_Model), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer :: i_type, i_orb_set + + if (current_verbosity() < PRINT_NORMAL) return + + call Print('TB_Dipole_Model : active='//this%active, file=file) + call Print('TB_Dipole_Model : n_types='//this%n_types, file=file) + do i_type = 1, this%n_types + call print('TB_Dipole_Model : type ' // i_type // ' atomic_num ' // this%atomic_num(i_type) // & + ' n_orb_sets ' // this%n_orb_sets(i_type), file=file) + do i_orb_set = 1, this%n_orb_sets(i_type) + call print('TB_Dipole_model: i_orb_set ' // i_orb_set // ' orb_type ' // this%orb_set_type(i_orb_set,i_type) // & + ' width ' // this%gaussian_width(i_orb_set, i_type) // ' phase ' // this%orb_set_phase(i_orb_set, i_type), file=file) + end do + end do + +end subroutine TB_Dipole_Model_Print + +subroutine TB_Spin_Orbit_Coupling_Print(this,file) + type(TB_Spin_Orbit_Coupling), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer :: i_type, i_orb_set + + if (current_verbosity() < PRINT_NORMAL) return + + call Print('TB_Spin_Orbit_Coupling : active='//this%active, file=file) + call Print('TB_Spin_Orbit_Coupling : n_types='//this%n_types, file=file) + do i_type = 1, this%n_types + call print('TB_Spin_Orbit_Coupling : type ' // i_type // ' atomic_num ' // this%atomic_num(i_type) // & + ' n_orb_sets ' // this%n_orb_sets(i_type), file=file) + do i_orb_set = 1, this%n_orb_sets(i_type) + call print('TB_Spin_Orbit_Coupling: i_orb_set ' // i_orb_set // ' orb_type ' // this%orb_set_type(i_orb_set,i_type) // & + ' SO_param ' // this%SO_param(i_orb_set, i_type), file=file) + end do + end do + +end subroutine TB_Spin_Orbit_Coupling_Print + +subroutine Self_Consistency_Print(this,file) + type(Self_Consistency), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer::i + + if (current_verbosity() < PRINT_NORMAL) return + + call Print('Self_Consistency : active='//this%active, file=file) + + call Print("Self_Consistency : global_U " // this%global_U, file=file) + + call Print("Self_Consistency : allocated(this%U) " // allocated(this%U), file=file) + if (allocated(this%U)) then + call Print("Self_Consistency : size(this%U) " // size(this%U), file=file) + do i=1, size(this%U) + if (this%U(i) /= 0.0_dp) then + call Print('Self_Consistency : U ' // i // " " // this%U(i), file=file) + endif + end do + else + call Print("Self_Consistency : size(this%U) 0", file=file) + endif + if (allocated(this%stoner_param)) then + call Print("Self_Consistency : size(this%stoner_param) " // size(this%stoner_param), file=file) + do i=1, size(this%stoner_param,2) + if (maxval(this%stoner_param(:,i)) /= 0.0_dp) then + call Print('Self_Consistency : stoner_param ' // i // " " // this%stoner_param(:,i), file=file) + endif + end do + else + call Print("Self_Consistency : size(this%stoner_param) 0", file=file) + endif + + if (allocated(this%terms)) then + do i=1, size(this%terms) + call Print('Self_Consistency : term ' // i, file=file) + call Print(this%terms(i),file=file) + end do + end if + + call verbosity_push_decrement() + + if (allocated(this%orb_local_pot)) then + call Print('Self_Consistency : orb_local_pot ', file=file) + call Print(this%orb_local_pot, file=file) + endif + + if (allocated(this%orb_exch_field)) then + call Print('Self_Consistency : orb_exch_field ', file=file) + call Print(this%orb_exch_field, file=file) + endif + + call verbosity_pop() + +end subroutine Self_Consistency_Print + +subroutine Self_Consistency_Term_Print(this, file) + type(Self_Consistency_Term), intent(in) :: this + type(Inoutput), intent(inout), optional :: file + + integer :: i + + if (current_verbosity() < PRINT_NORMAL) return + + if (.not. this%active) return + + call Print('Self_Consistency_Term type : ' // scf_names(this%type), file=file) + + call Print('Self_Consistency_Term n_dof : ' // this%n_dof, file=file) + + if (this%type == SCF_GLOBAL_U) & + call Print('Self_Consistency_Term global_U ' // this%global_U // ' global_N ' // this%global_N, file=file) + + if (this%type == SCF_GCN) & + call Print('Self_Consistency_Term global_pot ' // this%global_pot // ' global_N ' // this%global_N, file=file) + + if (allocated(this%atomic_n)) then + call Print('Self_Consistency_Term : atomic_n ', file=file) + call Print(this%atomic_n, file=file) + endif + + if (allocated(this%manifold_mom)) then + call Print('Self_Consistency_Term : manifold_mom ', file=file) + do i=1, size(this%manifold_mom,2) + call Print(i // " " // this%manifold_mom(:,i) // " mag " // norm(this%manifold_mom(:,i)), file=file) + end do + endif + + call verbosity_push_decrement() + + if (allocated(this%U)) then + call Print('Self_Consistency_Term : U ', file=file) + call Print(this%U, file=file) + endif + + if (allocated(this%spin_splitting)) then + call Print('Self_Consistency_Term : spin_splitting ', file=file) + call Print(this%spin_splitting, file=file) + endif + + if (allocated(this%stoner_param)) then + call Print('Self_Consistency_Term : stoner_param ', file=file) + call Print(this%stoner_param, file=file) + endif + + if (allocated(this%atomic_n0)) then + call Print('Self_Consistency_Term : atomic_n0 ', file=file) + call Print(this%atomic_n0, file=file) + endif + + if (allocated(this%atomic_local_pot)) then + call Print('Self_Consistency_Term : atomic_local_pot ', file=file) + call Print(this%atomic_local_pot, file=file) + endif + + call verbosity_push_decrement() + + if (allocated(this%gamma)) then + call Print('Self_Consistency : gamma ', file=file) + call Print(this%gamma, file=file) + endif + if (allocated(this%dgamma_dr)) then + call Print('Self_Consistency : dgamma_dr(:,:,1) ', file=file) + call Print(this%dgamma_dr(:,:,1), file=file) + call Print('Self_Consistency : dgamma_dr(:,:,2) ', file=file) + call Print(this%dgamma_dr(:,:,2), file=file) + call Print('Self_Consistency : dgamma_dr(:,:,3) ', file=file) + call Print(this%dgamma_dr(:,:,3), file=file) + endif + + call verbosity_pop() + call verbosity_pop() +end subroutine Self_Consistency_Term_Print + +subroutine TBSystem_fill_sc_matrices(this, at) + type(TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + + integer i + + if (allocated(this%scf%terms)) then + do i=1, size(this%scf%terms) + call fill_sc_matrices(this%scf%terms(i), at, this%scf%U, this%scf%stoner_param, this%first_orb_of_atom, & + this%first_manifold_of_atom, this%first_orb_of_manifold, this%tbmodel) + end do + end if +end subroutine TBSystem_fill_sc_matrices + +subroutine Self_Consistency_Term_fill_sc_matrices(this, at, U, stoner_param, first_orb_of_atom, first_manifold_of_atom, first_orb_of_manifold, tbm) + type(Self_Consistency_Term), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(in), allocatable :: U(:), stoner_param(:,:) + integer, intent(in) :: first_orb_of_atom(:), first_manifold_of_atom(:), first_orb_of_manifold(:) + type(TBModel), intent(in) :: tbm + + real(dp), allocatable :: block_H_up(:,:), block_H_down(:,:), block_S(:,:) + integer :: i_at, i_man, n_i, orb_offset, man_offset + + select case(this%type) + case (SCF_NONE) + return + case (SCF_LCN) + return + case (SCF_GCN) + return + case (SCF_GLOBAL_U) + return + case (SCF_LOCAL_U) + if (.not. allocated(U)) & + call system_abort("self_consistency_term_fill_sc_matrices called with SCF_LOCAL_U but U not allocated") + if (minval(at%Z) < 1 .or. maxval(at%Z) > size(U)) & + call system_abort("self_consistency_term_fill_scf_matrices SCF_LOCAL_U called with at%Z element out of range 1.."//size(U)) + if (minval(U(at%Z)) <= 0) & + call system_abort("Tried to do a local U for atom " // minloc(U(at%Z)) // " Z " // at%Z(minloc(U(at%Z))) // " which has nonsense U") + this%U = U(at%Z) + case (SCF_NONLOCAL_U_DFTB) + if (.not. allocated(U)) & + call system_abort("self_consistency_term_fill_sc_matrices called with SCF_NONLOCAL_U_DFTB but U not allocated") + if (minval(at%Z) < 1 .or. maxval(at%Z) > size(U)) & + call system_abort("self_consistency_term_fill_scf_matrices SCF_NONLOCAL_U_DFTB called with at%Z element out of range 1.." // size(U)) + call calc_gamma_dftb(at, U, this%gamma) + case (SCF_NONLOCAL_U_NRL_TB) + if (.not. allocated(U)) & + call system_abort("self_consistency_term_fill_sc_matrices called with SCF_NONLOCAL_U_NRL_TB but U not allocated") + if (minval(at%Z) < 1 .or. maxval(at%Z) > size(U)) & + call system_abort("self_consistency_term_fill_scf_matrices SCF_NONLOCAL_U_NRL_TB called with at%Z element out of range 1.." // size(U)) + call calc_gamma_nrl_tb(at, U, this%gamma) + case (SCF_SPIN_DIR) + do i_at=1, at%N + n_i = first_orb_of_atom(i_at+1)-first_orb_of_atom(i_at) + allocate(block_H_up(n_i,n_i)) + allocate(block_H_down(n_i,n_i)) + allocate(block_S(n_i,n_i)) + call get_HS_blocks(tbm, at, i_at, i_at, (/ 0.0_dp, 0.0_dp, 0.0_dp /), 0.0_dp, block_H_up, block_S, i_mag=1) + call get_HS_blocks(tbm, at, i_at, i_at, (/ 0.0_dp, 0.0_dp, 0.0_dp /), 0.0_dp, block_H_down, block_S, i_mag=2) + do i_man=first_manifold_of_atom(i_at), first_manifold_of_atom(i_at+1)-1 + orb_offset = first_orb_of_manifold(i_man)-first_orb_of_atom(i_at)+1 + this%spin_splitting(i_man) = -0.5_dp*(block_H_up(orb_offset,orb_offset)-block_H_down(orb_offset,orb_offset)) + end do + deallocate(block_H_up) + deallocate(block_H_down) + deallocate(block_S) + end do + case (SCF_SPIN_STONER) + if (.not. allocated(stoner_param)) & + call system_abort("self_consistency_term_fill_sc_matrices called with SCF_SPIN_STONER but stoner_param not allocated") + if (minval(at%Z) < 1 .or. maxval(at%Z) > size(stoner_param)) & + call system_abort("self_consistency_term_fill_scf_matrices SCF_SPIN_STONER called with at%Z element out of range 1.."//size(stoner_param)) + do i_at=1, at%N + do i_man=first_manifold_of_atom(i_at), first_manifold_of_atom(i_at+1)-1 + man_offset = i_man - first_manifold_of_atom(i_at) + 1 + this%stoner_param(i_man) = stoner_param(man_offset, at%Z(i_at)) + this%stoner_param(i_man) = stoner_param(man_offset, at%Z(i_at)) + end do + end do + case default + call system_abort("Self_Consistency_Term_fill_sc_matrices confused by this%type="//this%type) + end select +end subroutine Self_Consistency_Term_fill_sc_matrices + +subroutine realloc_dgamma_dr(this) + type(Self_Consistency_Term), intent(inout) :: this + + if (.not. allocated(this%gamma)) then + call system_abort ("Called realloc_dgamma_dr with gamma not allocated") + endif + + if (allocated(this%dgamma_dr)) then + if (size(this%dgamma_dr,1) /= size(this%gamma,1) .or. & + size(this%dgamma_dr,2) /= size(this%gamma,2)) then + deallocate(this%dgamma_dr) + endif + endif + + if (.not.allocated(this%dgamma_dr)) then + allocate(this%dgamma_dr(size(this%gamma,1),size(this%gamma,2),3)) + endif +end subroutine realloc_dgamma_dr + +subroutine TBSystem_fill_sc_dmatrices(this, at, virial_component) + type(TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in), optional :: virial_component + + integer i_term + + if (allocated(this%scf%terms)) then + do i_term=1, size(this%scf%terms) + call fill_sc_dmatrices(this%scf%terms(i_term), at, this%scf%U, virial_component) + end do + end if +end subroutine TBSystem_fill_sc_dmatrices + +subroutine Self_Consistency_Term_fill_sc_dmatrices(this, at, U, virial_component) + type(Self_Consistency_Term), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(in) :: U(:) + integer, intent(in), optional :: virial_component + + select case(this%type) + case (SCF_NONE) + return + case (SCF_LCN) + return + case (SCF_GCN) + return + case (SCF_GLOBAL_U) + return + case (SCF_LOCAL_U) + return + case (SCF_NONLOCAL_U_DFTB) + call realloc_dgamma_dr(this) + call calc_dgamma_dr_dftb(at, U, this%dgamma_dr, virial_component) + case (SCF_NONLOCAL_U_NRL_TB) + call realloc_dgamma_dr(this) + call calc_dgamma_dr_nrl_tb(at, U, this%dgamma_dr, virial_component) + case (SCF_SPIN_DIR) + call system_abort("fill_sc_dmatrices: no SCF_SPIN_DIR yet") + return + case (SCF_SPIN_STONER) + return + case default + call system_abort("Self_Consistency_Term_fill_sc_dmatrices Confused by this%type="//this%type) + end select +end subroutine Self_Consistency_Term_fill_sc_dmatrices + +! from a (input) scf system and a new (output) orbital_n vector, compute new +! control parameters (density, local potential) for next SCF step +function TBSystem_update_orb_local_pot(this, at, iter, global_at_weight, new_orbital_n, new_orbital_m) + type(TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: iter + real(dp), intent(in), pointer :: global_at_weight(:) + real(dp), intent(in), pointer :: new_orbital_n(:), new_orbital_m(:,:) + logical :: TBSystem_update_orb_local_pot + + integer :: broyden_iter + integer :: i_term, n_dof, cur_dof, last_dof + real(dp) :: resid + logical :: done + + real(dp), allocatable :: to_zero_vec(:), control_vec(:), new_control_vec(:) + + if (.not. this%scf%active .or. size(this%scf%terms) == 0) then + TBSystem_update_orb_local_pot = .true. + return + endif + + n_dof = 0 + if (allocated(this%scf%terms)) then + do i_term=1, size(this%scf%terms) + n_dof = n_dof + this%scf%terms(i_term)%n_dof + end do + end if + + allocate(to_zero_vec(n_dof), control_vec(n_dof), new_control_vec(n_dof)) + + cur_dof = 1 + if (allocated(this%scf%terms)) then + do i_term=1, size(this%scf%terms) + last_dof = cur_dof + this%scf%terms(i_term)%n_dof - 1 + call get_vecs(this%scf%terms(i_term), this, to_zero_vec(cur_dof:last_dof), control_vec(cur_dof:last_dof), global_at_weight, new_orbital_n, new_orbital_m) + cur_dof = last_dof+1 + end do + end if + + if (this%scf%mix_simple) then + call do_mix_simple(iter, control_vec, to_zero_vec, new_control_vec, this%scf%alpha) + else + if (n_dof == 1) then + call do_ridders_residual(iter, control_vec(1), to_zero_vec(1), new_control_vec(1)) + else + broyden_iter = mod(iter-1,100)+1 ! throw out Broyden history every 100 steps + call do_mix_broyden(broyden_iter, control_vec, to_zero_vec, new_control_vec, this%scf%alpha, this%scf%w0) + endif + endif + + resid = maxval(abs(to_zero_vec)) + call Print("SCF iteration " // iter // " residual " // resid) + + done = (resid < this%scf%conv_tol) + + if (.not. done .and. this%scf%mix_simple .and. resid < this%scf%mix_simple_end_tol) then + call print("mix_simple is active, resid < this%scf%mix_simple_end_tol, switching simple mixing off", PRINT_ALWAYS) + this%scf%mix_simple = .false. + endif + if (.not. done .and. .not. this%scf%mix_simple .and. resid > this%scf%mix_simple_start_tol) then + call print("mix_simple is not active, resid > this%scf%mix_simple_start_tol, switching simple mixing on", PRINT_ALWAYS) + this%scf%mix_simple = .true. + endif + + cur_dof = 1 + if (allocated(this%scf%terms)) then + do i_term=1, size(this%scf%terms) + last_dof = cur_dof + this%scf%terms(i_term)%n_dof - 1 + ! SCF_SPIN_DIR isn't self consistent, so always update + if ((.not. done) .or. this%scf%terms(i_term)%type == SCF_SPIN_DIR) then + call set_vec(this%scf%terms(i_term), new_control_vec(cur_dof:last_dof)) + end if + cur_dof = last_dof+1 + end do + end if + + call calc_orb_local_pot(this, global_at_weight) + + deallocate(to_zero_vec, control_vec, new_control_vec) + + TBSystem_update_orb_local_pot = done + +end function TBSystem_update_orb_local_pot + +subroutine get_vecs(this, tbsys, to_zero_vec, control_vec, global_at_weight, new_orbital_n, new_orbital_m) + type(Self_Consistency_Term), intent(inout) :: this + type(TBSystem), intent(in) :: tbsys + real(dp), intent(out) :: to_zero_vec(:), control_vec(:) + real(dp), intent(in), pointer :: new_orbital_n(:), new_orbital_m(:,:) + real(dp), intent(in), pointer :: global_at_weight(:) + + integer :: i, N_mom + real(dp), allocatable :: new_manifold_m(:,:) + + if (this%type == SCF_NONE) return + + select case(this%type) + case (SCF_NONE) + return + case (SCF_LCN) + if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_LCN") + to_zero_vec = atom_orbital_sum(tbsys, new_orbital_n) - this%atomic_n0 + control_vec = this%atomic_local_pot + if (current_verbosity() >= PRINT_NERD) then + call print("get_vecs SCF_LCN delta_n" // to_zero_vec, PRINT_NERD) + endif + case(SCF_GCN) + if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_GCN") + if (.not. associated(global_at_weight)) & + call system_abort("Self_Consistency_Term_get_vecs SCF_GCN but no global_at_weight") + to_zero_vec = sum(global_at_weight*(atom_orbital_sum(tbsys, new_orbital_n)-this%atomic_n0)) + control_vec = this%global_pot + if (current_verbosity() >= PRINT_NERD) then + call print("get_vecs SCF_GCN delta_n" // to_zero_vec, PRINT_NERD) + endif + case(SCF_GLOBAL_U) + if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_GLOBAL_U") + if (.not. associated(global_at_weight)) & + call system_abort("Self_Consistency_Term_get_vecs SCF_GCN but no global_at_weight") + to_zero_vec = sum(global_at_weight*(atom_orbital_sum(tbsys, new_orbital_n)))-this%global_N + control_vec = this%global_N + if (current_verbosity() >= PRINT_NERD) then + call print("get_vecs SCF_GLOBAL_U delta_n" // to_zero_vec, PRINT_NERD) + endif + case (SCF_LOCAL_U) + if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_LOCAL_U") + to_zero_vec = atom_orbital_sum(tbsys, new_orbital_n) - this%atomic_n + control_vec = this%atomic_n + if (current_verbosity() >= PRINT_NERD) then + call print("get_vecs SCF_LOCAL_U delta_n" // to_zero_vec, PRINT_NERD) + endif + case (SCF_NONLOCAL_U_DFTB) + if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_NONLOCAL_U_DFTB") + to_zero_vec = atom_orbital_sum(tbsys, new_orbital_n) - this%atomic_n + control_vec = this%atomic_n + if (current_verbosity() >= PRINT_NERD) then + call print("get_vecs SCF_NONLOCAL_U_DFTB delta_n" // to_zero_vec, PRINT_NERD) + endif + case (SCF_NONLOCAL_U_NRL_TB) + if (.not. associated(new_orbital_n)) call system_abort("get_vecs needs new_orbital_n for SCF_NONLOCAL_U_NRL_TB") + to_zero_vec = atom_orbital_sum(tbsys, new_orbital_n) - this%atomic_n + control_vec = this%atomic_n + if (current_verbosity() >= PRINT_NERD) then + call print("get_vecs SCF_NONLOCAL_U_NRL_TB delta_n" // to_zero_vec, PRINT_NERD) + endif + case (SCF_SPIN_DIR) + if (.not. associated(new_orbital_m)) call system_abort("get_vecs needs new_orbital_m for SCF_SPIN_DIR") + allocate(new_manifold_m(3,tbsys%N_manifolds)) + N_mom = tbsys%N_manifolds + new_manifold_m = manifold_orbital_sum(tbsys, new_orbital_m) + to_zero_vec(1:3*N_mom:3) = new_manifold_m(1,1:N_mom) - this%manifold_mom(1,1:N_mom) + to_zero_vec(2:3*N_mom:3) = new_manifold_m(2,1:N_mom) - this%manifold_mom(2,1:N_mom) + to_zero_vec(3:3*N_mom:3) = new_manifold_m(3,1:N_mom) - this%manifold_mom(3,1:N_mom) + control_vec(1:3*N_mom:3) = this%manifold_mom(1,1:N_mom) + control_vec(2:3*N_mom:3) = this%manifold_mom(2,1:N_mom) + control_vec(3:3*N_mom:3) = this%manifold_mom(3,1:N_mom) + if (current_verbosity() >= PRINT_NERD) then + call print("get_vecs SCF_SPIN_DIR current manifold moment", PRINT_NERD) + do i=1, tbsys%N_manifolds + call print(" " // i // " " // new_manifold_m(:,i), PRINT_NERD) + end do + endif + deallocate(new_manifold_m) + case (SCF_SPIN_STONER) + if (.not. associated(new_orbital_m)) call system_abort("get_vecs needs new_orbital_m for SCF_SPIN_STONER") + allocate(new_manifold_m(3,tbsys%N_manifolds)) + N_mom = tbsys%N_manifolds + new_manifold_m = manifold_orbital_sum(tbsys, new_orbital_m) + if (current_verbosity() >= PRINT_NERD) then + call print("get_vecs SCF_SPIN_STONER current manifold moment", PRINT_NERD) + do i=1, tbsys%N_manifolds + call print(" " // i // " " // new_manifold_m(:,i), PRINT_NERD) + end do + endif + to_zero_vec(1:3*N_mom:3) = new_manifold_m(1,1:N_mom) - this%manifold_mom(1,1:N_mom) + to_zero_vec(2:3*N_mom:3) = new_manifold_m(2,1:N_mom) - this%manifold_mom(2,1:N_mom) + to_zero_vec(3:3*N_mom:3) = new_manifold_m(3,1:N_mom) - this%manifold_mom(3,1:N_mom) + control_vec(1:3*N_mom:3) = this%manifold_mom(1,1:N_mom) + control_vec(2:3*N_mom:3) = this%manifold_mom(2,1:N_mom) + control_vec(3:3*N_mom:3) = this%manifold_mom(3,1:N_mom) + deallocate(new_manifold_m) + case default + call system_abort("Self_Consistency_Term_get_vecs confused by this%type="//this%type) + end select +end subroutine get_vecs + +subroutine set_vec(this, new_control_vec) + type(Self_Consistency_Term), intent(inout) :: this + real(dp), intent(in) :: new_control_vec(:) + + integer :: N_mom + + select case(this%type) + case (SCF_NONE) + return + case (SCF_LCN) + this%atomic_local_pot = new_control_vec + case(SCF_GCN) + this%global_pot = new_control_vec(1) + case (SCF_GLOBAL_U) + this%global_N = new_control_vec(1) + case (SCF_LOCAL_U) + this%atomic_n = new_control_vec + case (SCF_NONLOCAL_U_DFTB) + this%atomic_n = new_control_vec + case (SCF_NONLOCAL_U_NRL_TB) + this%atomic_n = new_control_vec + case (SCF_SPIN_DIR) + N_mom = size(this%manifold_mom,2) + this%manifold_mom(1,1:N_mom) = new_control_vec(1:3*N_mom:3) + this%manifold_mom(2,1:N_mom) = new_control_vec(2:3*N_mom:3) + this%manifold_mom(3,1:N_mom) = new_control_vec(3:3*N_mom:3) + case (SCF_SPIN_STONER) + N_mom = size(this%manifold_mom,2) + this%manifold_mom(1,1:N_mom) = new_control_vec(1:3*N_mom:3) + this%manifold_mom(2,1:N_mom) = new_control_vec(2:3*N_mom:3) + this%manifold_mom(3,1:N_mom) = new_control_vec(3:3*N_mom:3) + case default + call system_abort("Self_Consistency_Term_set_vec confused by this%type="//this%type) + end select +end subroutine set_vec + +! calculate orbital local potential from terms aready set in SCF object (local pot +! for LCN and GCN, and global_N or atomic_n for U based SCF. +subroutine TBSystem_calc_orb_local_pot(this, global_at_weight) + type(TBSystem), intent(inout) :: this + real(dp), intent(in), pointer :: global_at_weight(:) + + integer :: i_term + + this%scf%orb_local_pot = 0.0_dp + + if (.not. this%scf%active) return + + if (allocated(this%scf%terms)) then + do i_term=1, size(this%scf%terms) + if (allocated(this%scf%orb_local_pot)) & + call add_term_dSCFE_dn(this%scf%terms(i_term), this, global_at_weight, this%scf%orb_local_pot) + if (allocated(this%scf%orb_exch_field)) & + call add_term_dSCFE_dm(this%scf%terms(i_term), this, global_at_weight, this%scf%orb_exch_field) + end do + end if + +end subroutine TBSystem_calc_orb_local_pot + +subroutine add_term_dSCFE_dn(this, tbsys, global_at_weight, dSCFE_dn) + type(Self_Consistency_Term), intent(inout) :: this + type(TBSystem), intent(in) :: tbsys + real(dp), intent(in), pointer :: global_at_weight(:) + real(dp), intent(out) :: dSCFE_dn(:) + + dSCFE_dn = 0.0_dp + + select case (this%type) + case (SCF_NONE) + return + case (SCF_LCN) + dSCFE_dn = atom_orbital_spread(tbsys, this%atomic_local_pot) + case (SCF_GCN) + if (.not. associated(global_at_weight)) & + call system_abort("add_term_dSCFE_dn with SCF_GCN but no global_at_weight") + dSCFE_dn = atom_orbital_spread(tbsys, global_at_weight*this%global_pot) + case (SCF_GLOBAL_U) + if (.not. associated(global_at_weight)) & + call system_abort("add_term_dSCFE_dn with SCF_GLOBAL_U but no global_at_weight") + dSCFE_dn = atom_orbital_spread(tbsys, global_at_weight*this%global_U*(this%global_N-sum(global_at_weight*this%atomic_n0))) + case (SCF_LOCAL_U) + dSCFE_dn = atom_orbital_spread(tbsys, this%U*(this%atomic_n-this%atomic_n0)) + case (SCF_NONLOCAL_U_DFTB) + dSCFE_dn = atom_orbital_spread(tbsys, matmul(this%gamma,(this%atomic_n-this%atomic_n0))) + case (SCF_NONLOCAL_U_NRL_TB) + dSCFE_dn = atom_orbital_spread(tbsys, matmul(this%gamma,(this%atomic_n-this%atomic_n0))) + case (SCF_SPIN_DIR) + return + case (SCF_SPIN_STONER) + return + case default + call system_abort("add_term_dSCFE_dn confused by this%type="//this%type) + end select +end subroutine add_term_dSCFE_dn + +subroutine add_term_dSCFE_dm(this, tbsys, global_at_weight, dSCFE_dm) + type(Self_Consistency_Term), intent(inout) :: this + type(TBSystem), intent(in) :: tbsys + real(dp), intent(in), pointer :: global_at_weight(:) + real(dp), intent(out) :: dSCFE_dm(:,:) + + integer :: i_man, i_orb + real(dp) :: e(3) + + dSCFE_dm = 0.0_dp + + select case (this%type) + case (SCF_NONE) + return + case (SCF_LCN) + return + case (SCF_GCN) + return + case (SCF_GLOBAL_U) + return + case (SCF_LOCAL_U) + return + case (SCF_NONLOCAL_U_DFTB) + return + case (SCF_NONLOCAL_U_NRL_TB) + return + case (SCF_SPIN_DIR) + do i_man=1, tbsys%N_manifolds + e = this%manifold_mom(:,i_man) + if (norm(e) .feq. 0.0_dp) then + e = (/ 0.0_dp, 0.0_dp, 1.0_dp /) + else + e = e / norm(e) + endif + do i_orb = tbsys%first_orb_of_manifold(i_man), tbsys%first_orb_of_manifold(i_man+1)-1 + ! F = -0.5 sum_a spin_split_a |m_a| + ! dF/dm_i = -0.5 spin_split_a (|m_a| 2*m_a - |m_a|^2 m_a/|m_a|) / |m_a|^2 + ! = -0.5 spin_split_a ( 2*m_a/|m_a| - m_a/|m_a| ) + ! = -0.5 spin_split_a m_a/|m_a| + dSCFE_dm(1:3,i_orb) = -0.5_dp * this%spin_splitting(i_man)*e(1:3) + end do + end do + return + case (SCF_SPIN_STONER) + do i_man=1, tbsys%N_manifolds + do i_orb=tbsys%first_orb_of_manifold(i_man), tbsys%first_orb_of_manifold(i_man+1)-1 + ! F = -0.25 sum_a stoner_param_a * |m_a|^2 + ! dF/dm_i = -0.25 stoner_param_a 2 |m_a| m_a/|m_a| + ! = -0.5 stoner_param_a m_a + dSCFE_dm(1:3,i_orb) = -0.5_dp * this%stoner_param(i_man)*this%manifold_mom(1:3,i_man) + end do + end do + return + case default + call system_abort("add_term_dSCFE_dn confused by this%type="//this%type) + end select + +end subroutine add_term_dSCFE_dm + +subroutine add_term_d2SCFE_dgNdn(this, tbsys, global_at_weight, d2SCFE_dgNdn) + type(Self_Consistency_Term), intent(inout) :: this + type(TBSystem), intent(in) :: tbsys + real(dp), intent(in):: global_at_weight(:) + real(dp), intent(out) :: d2SCFE_dgNdn(:) + + d2SCFE_dgNdn = 0.0_dp + + if (.not. this%active) return + + select case (this%type) + case (SCF_NONE) + return + case (SCF_GLOBAL_U) + d2SCFE_dgNdn = atom_orbital_spread(tbsys, global_at_weight*this%global_U) + case default + call system_abort("add_term_d2SCFE_dgNdn only defined for GLOBAL_U") + end select +end subroutine add_term_d2SCFE_dgNdn + +subroutine add_term_d2SCFE_dn2_times_vec(this, tbsys, vec, d2SCFE_dn2_times_vec) + type(Self_Consistency_Term), intent(inout) :: this + type(TBSystem), intent(in) :: tbsys + real(dp), intent(in) :: vec(:) + real(dp), intent(out) :: d2SCFE_dn2_times_vec(:) + + d2SCFE_dn2_times_vec = 0.0_dp + + if (.not. this%active) return + + select case (this%type) + case (SCF_NONE) + return + case (SCF_LOCAL_U) + d2SCFE_dn2_times_vec = atom_orbital_spread(tbsys, this%U*vec) + case (SCF_NONLOCAL_U_DFTB) + d2SCFE_dn2_times_vec = atom_orbital_spread(tbsys, matmul(this%gamma,vec)) + case (SCF_NONLOCAL_U_NRL_TB) + d2SCFE_dn2_times_vec = atom_orbital_spread(tbsys, matmul(this%gamma,vec)) + case default + call system_abort("add_term_d2SCFE_dgNdn only defined for LOCAL_U and NONLOCAL_U_*") + end select +end subroutine add_term_d2SCFE_dn2_times_vec + +subroutine calc_gamma_dftb(at, U, gamma) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: U(:) + real(dp), intent(out) :: gamma(:,:) + + integer :: i, j + real(dp) :: U_i, U_j + real(dp) :: val + + real(dp) :: max_val + integer s1, s2, s3, s_range + real(dp) :: pi(3), pj(3), o(3), dr(3) + + gamma = 0.0_dp + + do i=1, at%N + if (U(at%Z(i)) <= 0) call system_abort("Tried to do a local U for atom " // i // " Z " // at%Z(i) // " which has nonsense U") + U_i = U(at%Z(i)) + gamma(i,i) = U_i + end do + + max_val = 1.0_dp + s_range = 1 + do while (max_val > 1.0e-12_dp) + max_val = 0.0_dp + do s1 = -s_range, s_range + do s2 = -s_range, s_range + do s3 = -s_range, s_range + if ((s_range > 1) .and. & + (s1 /= -s_range) .and. (s1 /= s_range) .and. & + (s2 /= -s_range) .and. (s2 /= s_range) .and. & + (s3 /= -s_range) .and. (s3 /= s_range)) cycle + do i=1, at%N + U_i = U(at%Z(i)) + pi = at%pos(1:3,i) + do j=i, at%N + if (i == j .and. s1 == 0 .and. s2 == 0 .and. s3 == 0) cycle + U_j = U(at%Z(j)) + pj = at%pos(1:3,j) + o = s1*at%lattice(:,1) + s2*at%lattice(:,2) + s3*at%lattice(:,3) + dr = (pi - pj - o) + val = Hartree*dftb_s(U_i/Hartree, U_j/Hartree, sqrt(sum(dr*dr))/Bohr) + if (abs(val) > max_val) max_val = abs(val) + gamma(i,j) = gamma(i,j) - val + gamma(j,i) = gamma(j,i) - val + end do + end do + end do + end do + end do + s_range = s_range + 1 + end do + + call add_madelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, gamma) + +end subroutine calc_gamma_dftb + +subroutine calc_dgamma_dr_dftb(at, U, dgamma_dr, virial_component) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: U(:) + real(dp), intent(out) :: dgamma_dr(:,:,:) + integer, intent(in), optional :: virial_component + + integer :: i, j + real(dp) :: U_i, U_j + real(dp) :: dval + + real(dp) :: max_val + integer s1, s2, s3, s_range + real(dp) :: pi(3), pj(3), o(3), dr(3), dr_mag + + integer my_virial_component + + my_virial_component = 0 + if (present(virial_component)) my_virial_component = virial_component + + dgamma_dr = 0.0_dp + + max_val = 1.0_dp + s_range = 1 + do while (max_val > 1.0e-12_dp) + max_val = 0.0_dp + do s1=-s_range,s_range + do s2=-s_range,s_range + do s3=-s_range,s_range + if ((s_range > 1) .and. & + (s1 /= -s_range) .and. (s1 /= s_range) .and. & + (s2 /= -s_range) .and. (s2 /= s_range) .and. & + (s3 /= -s_range) .and. (s3 /= s_range)) cycle + do i=1, at%N + if (U(at%Z(i)) <= 0) call system_abort("Tried to do a local U for atom " // i // " Z " // at%Z(i) // " which has nonsense U") + U_i = U(at%Z(i)) + pi = at%pos(1:3,i) + do j=i+1, at%N + if (U(at%Z(j)) <= 0) call system_abort("Tried to do a local U for atom " // j // " Z " // at%Z(j) // " which has nonsense U") + U_j = U(at%Z(j)) + pj = at%pos(1:3,j) + o = s1*at%lattice(:,1) + s2*at%lattice(:,2) + s3*at%lattice(:,3) + dr = (pi - pj - o) + dr_mag = sqrt(sum(dr*dr)) + dr = dr/dr_mag + dval = Hartree/Bohr * dftb_s_deriv(U_i/Hartree, U_j/Hartree, dr_mag/Bohr) + if (abs(dval) > max_val) max_val = abs(dval) + if (my_virial_component > 0) then + dgamma_dr(i,j,:) = dgamma_dr(i,j,:) + dval*dr*dr_mag*dr(my_virial_component) + dgamma_dr(j,i,:) = dgamma_dr(j,i,:) + dval*dr*dr_mag*dr(my_virial_component) + else + dgamma_dr(i,j,:) = dgamma_dr(i,j,:) - dval*dr + dgamma_dr(j,i,:) = dgamma_dr(j,i,:) + dval*dr + endif + end do + end do + end do + end do + end do + s_range = s_range + 1 + end do + + if (my_virial_component > 0) then + call add_dmadelung_matrix_dr(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, my_virial_component, dgamma_dr) + else + call add_dmadelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, dgamma_dr) + endif + +end subroutine calc_dgamma_dr_dftb + +subroutine calc_gamma_nrl_tb(at, U, gamma) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: U(:) + real(dp), intent(out) :: gamma(:,:) + + integer :: i, j + real(dp) :: U_i, U_j + real(dp) :: val + + real(dp) :: max_val + integer s1, s2, s3, s_range + real(dp) :: pi(3), pj(3), o(3), dr(3) + + gamma = 0.0_dp + + do i=1, at%N + if (at%Z(i) < 1 .or. at%Z(i) > size(U)) & + call system_abort("calc_gamma_nrl_tb got at%Z("//i//") out of range 1..size(U)="//size(U)) + if (U(at%Z(i)) <= 0) & + call system_abort("calc_gamma_nrl_tb tried to do a local U for atom " // i // " Z " // at%Z(i) // " which has nonsense U") + U_i = U(at%Z(i)) + gamma(i,i) = U_i + end do + + max_val = 1.0_dp + s_range = 1 + do while (max_val > 1.0e-10_dp) + max_val = 0.0_dp + do s1=-s_range,s_range + do s2=-s_range,s_range + do s3=-s_range,s_range + if ((s_range > 1) .and. & + (s1 /= -s_range) .and. (s1 /= s_range) .and. & + (s2 /= -s_range) .and. (s2 /= s_range) .and. & + (s3 /= -s_range) .and. (s3 /= s_range)) cycle + do i=1, at%N + U_i = U(at%Z(i)) + pi = at%pos(1:3,i) + do j=i, at%N + if (i == j .and. s1 == 0 .and. s2 == 0 .and. s3 == 0) cycle + U_j = U(at%Z(j)) + pj = at%pos(1:3,j) + o = s1*at%lattice(:,1) + s2*at%lattice(:,2) + s3*at%lattice(:,3) + dr = (pi - pj - o) + val = Hartree*nrl_tb_s(U_i/Hartree, U_j/Hartree, sqrt(sum(dr*dr))/Bohr) + if (abs(val) > max_val) max_val = abs(val) + gamma(i,j) = gamma(i,j) - val + gamma(j,i) = gamma(j,i) - val + end do + end do + end do + end do + end do + s_range = s_range + 1 + end do + + call add_madelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, gamma) + +end subroutine calc_gamma_nrl_tb + +subroutine calc_dgamma_dr_nrl_tb(at, U, dgamma_dr, virial_component) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: U(:) + real(dp), intent(out) :: dgamma_dr(:,:,:) + integer, intent(in), optional :: virial_component + + integer :: i, j + real(dp) :: U_i, U_j + real(dp) :: dval + + real(dp) :: max_val + integer s1, s2, s3, s_range + real(dp) :: pi(3), pj(3), o(3), dr(3), dr_mag + integer my_virial_component + + my_virial_component = 0 + if (present(virial_component)) my_virial_component = virial_component + + dgamma_dr = 0.0_dp + + max_val = 1.0_dp + s_range = 1 + do while (max_val > 1.0e-10_dp) + max_val = 0.0_dp + do s1=-s_range,s_range + do s2=-s_range,s_range + do s3=-s_range,s_range + if ((s_range > 1) .and. & + (s1 /= -s_range) .and. (s1 /= s_range) .and. & + (s2 /= -s_range) .and. (s2 /= s_range) .and. & + (s3 /= -s_range) .and. (s3 /= s_range)) cycle + do i=1, at%N + if (U(at%Z(i)) <= 0) call system_abort("Tried to do a local U for atom " // i // " Z " // at%Z(i) // " which has nonsense U") + U_i = U(at%Z(i)) + pi = at%pos(1:3,i) + do j=i+1, at%N + if (U(at%Z(j)) <= 0) call system_abort("Tried to do a local U for atom " // j // " Z " // at%Z(j) // " which has nonsense U") + U_j = U(at%Z(j)) + pj = at%pos(1:3,j) + o = s1*at%lattice(:,1) + s2*at%lattice(:,2) + s3*at%lattice(:,3) + dr = (pi - pj - o) + dr_mag = sqrt(sum(dr*dr)) + dr = dr/dr_mag + dval = Hartree/Bohr * nrl_tb_s_deriv(U_i/Hartree, U_j/Hartree, dr_mag/Bohr) + if (abs(dval) > max_val) max_val = abs(dval) + if (my_virial_component > 0) then + dgamma_dr(i,j,:) = dgamma_dr(i,j,:) + dval*dr*dr_mag*dr(my_virial_component) + dgamma_dr(j,i,:) = dgamma_dr(j,i,:) + dval*dr*dr_mag*dr(my_virial_component) + else + dgamma_dr(i,j,:) = dgamma_dr(i,j,:) - dval*dr + dgamma_dr(j,i,:) = dgamma_dr(j,i,:) + dval*dr + endif + end do + end do + end do + end do + end do + s_range = s_range + 1 + end do + + if (my_virial_component > 0) then + call add_dmadelung_matrix_dr(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, my_virial_component, dgamma_dr) + else + call add_dmadelung_matrix(at%N, at%lattice(:,1), at%lattice(:,2), at%lattice(:,3), at%pos, dgamma_dr) + endif + +end subroutine calc_dgamma_dr_nrl_tb + +! From Michael Strenberg's Ph.D. Thesis, p. 27, Paderborn 2001 +function dftb_s(u_a, u_b, R) + real(dp), intent(in) :: u_a, u_b, R + real(dp) :: dftb_s + + real(dp) tau_a, tau_b + + tau_a = 16.0_dp/5.0_dp * u_a + tau_b = 16.0_dp/5.0_dp * u_b + + if (tau_a /= tau_b) then + dftb_s = & + exp(-tau_a*R)* ( (tau_b**4 * tau_a) / (2.0_dp * (tau_a**2 - tau_b**2)**2) - & + (tau_b**6 - 3.0_dp*tau_b**4*tau_a**2) / (R * (tau_a**2-tau_b**2)**3) ) + & + exp(-tau_b*R)* ( (tau_a**4 * tau_b) / (2.0_dp * (tau_b**2 - tau_a**2)**2) - & + (tau_a**6 - 3.0_dp*tau_a**4*tau_b**2) / (R * (tau_b**2-tau_a**2)**3) ) + else + dftb_s = & + exp(-tau_a*R) * (48.0_dp + 33.0_dp * tau_a * R + 9.0_dp * (tau_a*R)**2 + (tau_a*R)**3) / & + (48.0_dp * R) + endif +end function dftb_s + +function dftb_s_deriv(u_a, u_b, R) + real(dp), intent(in) :: u_a, u_b, R + real(dp) :: dftb_s_deriv + + real(dp) tau_a, tau_b + real(dp) exp_v, rat_v, exp_v_deriv, rat_v_deriv + + tau_a = 16.0_dp/5.0_dp * u_a + tau_b = 16.0_dp/5.0_dp * u_b + + if (tau_a /= tau_b) then + exp_v = exp(-tau_a*R) + exp_v_deriv = -tau_a*exp_v + rat_v = (tau_b**4 * tau_a) / (2.0_dp * (tau_a**2 - tau_b**2)**2) - & + (tau_b**6 - 3.0_dp*tau_b**4*tau_a**2) / (R * (tau_a**2-tau_b**2)**3) + rat_v_deriv = (tau_b**6 - 3.0_dp*tau_b**4*tau_a**2) / (R**2 * (tau_a**2-tau_b**2)**3) + dftb_s_deriv = exp_v*rat_v_deriv + exp_v_deriv*rat_v + + exp_v = exp(-tau_b*R) + exp_v_deriv = -tau_b*exp_v + rat_v = (tau_a**4 * tau_b) / (2.0_dp * (tau_b**2 - tau_a**2)**2) - & + (tau_a**6 - 3.0_dp*tau_a**4*tau_b**2) / (R * (tau_b**2-tau_a**2)**3) + rat_v_deriv = (tau_a**6 - 3.0_dp*tau_a**4*tau_b**2) / (R**2 * (tau_b**2-tau_a**2)**3) + + dftb_s_deriv = dftb_s_deriv + exp_v*rat_v_deriv + exp_v_deriv*rat_v + + else + exp_v = exp(-tau_a*R) + exp_v_deriv = -tau_a*exp_v + rat_v = (48.0_dp + 33.0_dp * tau_a * R + 9.0_dp * (tau_a*R)**2 + (tau_a*R)**3) / (48.0_dp * R) + rat_v_deriv = ( (48.0_dp*R) * (33.0_dp * tau_a + 18.0_dp * tau_a**2 * R + 3*(tau_a*R)**2 * tau_a) - & + (48.0_dp + 33.0_dp * tau_a * R + 9.0_dp * (tau_a*R)**2 + (tau_a*R)**3) * 48.0_dp ) / & + ((48.0_dp*R)**2) + + dftb_s_deriv = exp_v*rat_v_deriv + exp_v_deriv*rat_v + endif +end function dftb_s_deriv + +function nrl_tb_s_deriv(u_a, u_b, R) + real(dp), intent(in) :: u_a, u_b, R + real(dp) :: nrl_tb_s_deriv + + real(dp) a, c + + a = PI/2.0D0 * u_a**2 + c = PI/2.0D0 * u_b**2 + + nrl_tb_s_deriv = -1.0D0/R**2 - ( (a*c)**1.5D0 / PI**3 ) * & + 2.0D0*PI**2.5D0 / (a*c*sqrt(a+c)) * dF0(a,c,R) +end function nrl_tb_s_deriv + +function nrl_tb_s(u_a, u_b, R) + real(dp), intent(in) :: u_a, u_b, R + real(dp) :: nrl_tb_s + + real(dp) :: a, c + + a = PI/2.0_dp * u_a**2 + c = PI/2.0_dp * u_b**2 + + nrl_tb_s = 1.0_dp/R - ( (a*c)**1.5_dp / PI**3 ) * & + 2.0_dp*PI**2.5_dp / (a*c*sqrt(a+c)) * F0(a,c,R) +end function nrl_tb_s + +function F0(a, c, R) + real(dp), intent(in) :: a, c, R + real(dp) :: F0 + + double precision coeff, q + + ! gamma(a,b,c,d) = 1 + ! from G&R 3.321 + 8.250 + coeff = a*c/(a+c) * R**2 + q = sqrt(coeff) + + F0 = sqrt(PI)/(2*q) * erf(q) + +end function F0 + +function dF0(a,c,R) + real(dp), intent(in) :: a, c, R + real(dp) :: dF0 + + real(dp) coeff, q + + ! gamma(a,b,c,d) = 1 + ! from G&R 3.321 + 8.250 + coeff = a*c/(a+c) * R**2 + q = sqrt(coeff) + + dF0 = ( exp(-q*q)/q - sqrt(PI)/(2*q*q) * erf(q) ) * sqrt((a*c)/(a+c)) + +end function + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine local_scf_e_correction(this, at, local_e, global_E, global_at_weight) + type(TBSystem), intent(in) :: this + type(Atoms), intent(in) :: at + real(dp), intent(out) :: local_e(:), global_E + real(dp), pointer, intent(in), optional :: global_at_weight(:) + + integer :: i_term + + local_e = 0.0_dp + global_e = 0.0_dp + + if (.not. this%scf%active) return + + if (allocated(this%scf%terms)) then + do i_term=1, size(this%scf%terms) + call add_term_local_scf_e_correction(this%scf%terms(i_term), local_e, global_E, this%N_atoms, this%first_manifold_of_atom, global_at_weight) + end do + end if + +end subroutine local_scf_e_correction + +! for SCF energy, + SCFE - dSCFE_dn * n +! for charge neutrality, -pot*n0 +subroutine add_term_local_scf_e_correction(this, local_e, global_E, N_atoms, first_manifold_of_atom, global_at_weight) + type(Self_Consistency_Term), intent(in) :: this + real(dp), intent(out) :: local_e(:), global_E + integer :: N_atoms, first_manifold_of_atom(:) + real(dp), pointer, intent(in), optional :: global_at_weight(:) + + integer :: i_at, i_man + + select case(this%type) + case (SCF_NONE) + return + case (SCF_LCN) + local_e = local_e - this%atomic_local_pot*this%atomic_n0 + case (SCF_GCN) + if (.not. present(global_at_weight)) & + call system_abort ("local_scf_e_correction with SCF_GCN but without global_at_weight") + if (.not. associated(global_at_weight)) & + call system_abort ("local_scf_e_correction with SCF_GCN but with unassociated global_at_weight") + global_e = global_e - this%global_pot*sum(global_at_weight*this%atomic_n0) + case (SCF_GLOBAL_U) + if (.not. present(global_at_weight)) & + call system_abort ("local_scf_e_correction with SCF_GLOBAL_U but without global_at_weight") + if (.not. associated(global_at_weight)) & + call system_abort ("local_scf_e_correction with SCF_GLOBAL_U but with unassociated global_at_weight") + global_e = global_e + 0.5_dp*this%global_U*(this%global_N-sum(global_at_weight*this%atomic_n0))**2 - & + this%global_U*(this%global_N-sum(global_at_weight*this%atomic_n0))*this%global_N + case (SCF_LOCAL_U) + local_e = local_e + 0.5_dp*this%U*(this%atomic_n-this%atomic_n0)**2 - this%U*(this%atomic_n-this%atomic_n0)*this%atomic_n + case (SCF_NONLOCAL_U_DFTB) + local_e = local_e + 0.5_dp*((this%atomic_n-this%atomic_n0) * matmul(this%gamma, this%atomic_n-this%atomic_n0)) - & + (this%atomic_n * matmul(this%gamma,this%atomic_n-this%atomic_n0)) + case (SCF_NONLOCAL_U_NRL_TB) + local_e = local_e + 0.5_dp*((this%atomic_n-this%atomic_n0) * matmul(this%gamma, this%atomic_n-this%atomic_n0)) - & + (this%atomic_n * matmul(this%gamma,this%atomic_n-this%atomic_n0)) + case (SCF_SPIN_DIR) + return + case (SCF_SPIN_STONER) + do i_at=1, N_atoms + do i_man=first_manifold_of_atom(i_at), first_manifold_of_atom(i_at+1)-1 + ! add F({m_i}) + local_e(i_at) = local_e(i_at) - 0.25_dp*this%stoner_param(i_man)*norm(this%manifold_mom(1:3,i_man))**2 + ! subtract dF/dm_i . m_i + local_e(i_at) = local_e(i_at) + 0.5_dp*this%stoner_param(i_man)*norm(this%manifold_mom(1:3,i_man))**2 + end do + end do + case default + call system_abort("add_term_local_scf_e_correction confused by this%type="//this%type) + end select + +end subroutine add_term_local_scf_e_correction + +subroutine add_term_dscf_e_correction_dgN(this, dglobal_E_dgN) + type(Self_Consistency_Term), intent(in) :: this + real(dp), intent(out) :: dglobal_E_dgN + + dglobal_E_dgN = 0.0_dp + + if (.not. this%active) return + + select case(this%type) + case (SCF_NONE) + return + case (SCF_GLOBAL_U) + dglobal_E_dgN = this%global_U*this%global_N + case default + call system_abort("add_term_dscf_e_correction_dgN only defined for GLOBAL_U") + end select +end subroutine + +subroutine add_term_dscf_e_correction_dn(this, tbsys, dlocal_E_dn) + type(Self_Consistency_Term), intent(in) :: this + type(TBSystem), intent(in) :: tbsys + real(dp), intent(out) :: dlocal_E_dn(:) + + dlocal_E_dn = 0.0_dp + + if (.not. this%active) return + + select case(this%type) + case (SCF_NONE) + return + case (SCF_LOCAL_U) + dlocal_E_dn = atom_orbital_spread(tbsys, this%U*this%atomic_n) + case (SCF_NONLOCAL_U_DFTB) + dlocal_E_dn = atom_orbital_spread(tbsys, matmul(this%gamma,this%atomic_n)) + case (SCF_NONLOCAL_U_NRL_TB) + dlocal_E_dn = atom_orbital_spread(tbsys, matmul(this%gamma,this%atomic_n)) + case default + call system_abort("add_term_dscf_e_correction_dgN only defined for GLOBAL_U") + end select +end subroutine + +subroutine realloc_datomic_local_pot_dr(this) + type(Self_Consistency_Term), intent(inout) :: this + + if (.not. allocated(this%atomic_n)) then + call system_abort ("realloc_datomic_local_pot_dr with local_pot not allocated") + endif + + if (allocated(this%datomic_local_pot_dr)) then + if (size(this%datomic_local_pot_dr,1) /= size(this%atomic_n,1)) then + deallocate(this%datomic_local_pot_dr) + endif + endif + + if (.not.allocated(this%datomic_local_pot_dr)) then + allocate(this%datomic_local_pot_dr(size(this%atomic_n,1),3)) + endif +end subroutine realloc_datomic_local_pot_dr + +function scf_f_correction(this, at) result(forces_scf) + type(TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp) :: forces_scf(3,at%N) ! result + + integer i_term + + forces_scf = 0.0 + + call fill_sc_dmatrices(this, at) + + if (allocated(this%scf%terms)) then + do i_term=1, size(this%scf%terms) + forces_scf = forces_scf + add_term_scf_f_correction(this%scf%terms(i_term), at) + end do + end if + +end function scf_f_correction + +function add_term_scf_f_correction(this, at) result (forces_scf) + type(Self_Consistency_Term), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp) :: forces_scf(3,at%N) ! result + + forces_scf = 0.0_dp + + select case(this%type) + case (SCF_NONE) + return + case (SCF_GCN) + return + case (SCF_GLOBAL_U) + return + case (SCF_LCN) + return + case (SCF_LOCAL_U) + return + case (SCF_NONLOCAL_U_DFTB) + call realloc_datomic_local_pot_dr(this) + this%datomic_local_pot_dr(:,1) = matmul(this%dgamma_dr(:,:,1),(this%atomic_n-this%atomic_n0)) + this%datomic_local_pot_dr(:,2) = matmul(this%dgamma_dr(:,:,2),(this%atomic_n-this%atomic_n0)) + this%datomic_local_pot_dr(:,3) = matmul(this%dgamma_dr(:,:,3),(this%atomic_n-this%atomic_n0)) + forces_scf(1,:) = -this%datomic_local_pot_dr(:,1)*(this%atomic_n-this%atomic_n0) + forces_scf(2,:) = -this%datomic_local_pot_dr(:,2)*(this%atomic_n-this%atomic_n0) + forces_scf(3,:) = -this%datomic_local_pot_dr(:,3)*(this%atomic_n-this%atomic_n0) + case (SCF_NONLOCAL_U_NRL_TB) + call realloc_datomic_local_pot_dr(this) + this%datomic_local_pot_dr(:,1) = matmul(this%dgamma_dr(:,:,1),(this%atomic_n-this%atomic_n0)) + this%datomic_local_pot_dr(:,2) = matmul(this%dgamma_dr(:,:,2),(this%atomic_n-this%atomic_n0)) + this%datomic_local_pot_dr(:,3) = matmul(this%dgamma_dr(:,:,3),(this%atomic_n-this%atomic_n0)) + forces_scf(1,:) = -this%datomic_local_pot_dr(:,1)*(this%atomic_n-this%atomic_n0) + forces_scf(2,:) = -this%datomic_local_pot_dr(:,2)*(this%atomic_n-this%atomic_n0) + forces_scf(3,:) = -this%datomic_local_pot_dr(:,3)*(this%atomic_n-this%atomic_n0) + case (SCF_SPIN_DIR) + call system_abort("add_term_scf_f_correction not implemented for SCF_SPIN_DIR yet") + case (SCF_SPIN_STONER) + return + case default + call system_abort("add_term_scf_f_correction confused by this%type="//this%type) + end select +end function add_term_scf_f_correction + +function scf_virial_correction(this, at) result(virial_scf) + type(TBSystem), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp) :: virial_scf(3,3) ! result + + integer :: component, i_term + + virial_scf = 0.0_dp + do component=1,3 + call fill_sc_dmatrices(this, at, component) + if (allocated(this%scf%terms)) then + do i_term=1, size(this%scf%terms) + virial_scf(:,component) = virial_scf(:,component) + add_term_scf_virial_correction(this%scf%terms(i_term), at) + end do + end if + end do +end function scf_virial_correction + +function add_term_scf_virial_correction(this, at) result (virial_scf) + type(Self_Consistency_Term), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp) :: virial_scf(3) ! result + + virial_scf = 0.0_dp + + select case(this%type) + case (SCF_NONE) + return + case (SCF_GCN) + return + case (SCF_GLOBAL_U) + return + case (SCF_LCN) + return + case (SCF_LOCAL_U) + return + case (SCF_NONLOCAL_U_DFTB) + call realloc_datomic_local_pot_dr(this) + this%datomic_local_pot_dr(:,1) = matmul(this%dgamma_dr(:,:,1),(this%atomic_n-this%atomic_n0)) + this%datomic_local_pot_dr(:,2) = matmul(this%dgamma_dr(:,:,2),(this%atomic_n-this%atomic_n0)) + this%datomic_local_pot_dr(:,3) = matmul(this%dgamma_dr(:,:,3),(this%atomic_n-this%atomic_n0)) + virial_scf(1) = 0.5_dp*sum(this%datomic_local_pot_dr(:,1)*(this%atomic_n-this%atomic_n0)) + virial_scf(2) = 0.5_dp*sum(this%datomic_local_pot_dr(:,2)*(this%atomic_n-this%atomic_n0)) + virial_scf(3) = 0.5_dp*sum(this%datomic_local_pot_dr(:,3)*(this%atomic_n-this%atomic_n0)) + case (SCF_NONLOCAL_U_NRL_TB) + call realloc_datomic_local_pot_dr(this) + this%datomic_local_pot_dr(:,1) = matmul(this%dgamma_dr(:,:,1),(this%atomic_n-this%atomic_n0)) + this%datomic_local_pot_dr(:,2) = matmul(this%dgamma_dr(:,:,2),(this%atomic_n-this%atomic_n0)) + this%datomic_local_pot_dr(:,3) = matmul(this%dgamma_dr(:,:,3),(this%atomic_n-this%atomic_n0)) + virial_scf(1) = 0.5_dp*sum(this%datomic_local_pot_dr(:,1)*(this%atomic_n-this%atomic_n0)) + virial_scf(2) = 0.5_dp*sum(this%datomic_local_pot_dr(:,2)*(this%atomic_n-this%atomic_n0)) + virial_scf(3) = 0.5_dp*sum(this%datomic_local_pot_dr(:,3)*(this%atomic_n-this%atomic_n0)) + case (SCF_SPIN_DIR) + call system_abort("add_term_scf_virial_correction not implemented for SCF_SPIN_DIR yet") + case (SCF_SPIN_STONER) + return + case default + call system_abort("calc_datomic_local_pot_dr confused by this%type="//this%type) + end select +end function add_term_scf_virial_correction + +function scf_e_correction(this, at, global_at_weight) + type(TBSystem), intent(in) :: this + type(Atoms), intent(in) :: at + real(dp), pointer, intent(in), optional :: global_at_weight(:) + real(dp) :: scf_e_correction + + real(dp), allocatable :: local_e_scf(:) + real(dp) :: global_e_scf + + allocate(local_e_scf(at%N)) + + call local_scf_e_correction(this, at, local_e_scf, global_e_scf, global_at_weight) + scf_e_correction = sum(local_e_scf) + global_e_scf + deallocate(local_e_scf) + +end function scf_e_correction + +subroutine get_dipole_block(this, at, i, j, dv_hat, dv_mag, block_dipole) + type(TB_Dipole_Model), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i, j + real(dp), intent(in) :: dv_hat(3), dv_mag + real(dp), intent(out) :: block_dipole(:,:,:) + + real(dp) :: pi(3), pj(3), sigi, sigj + integer :: phasei, phasej + integer :: i_type, j_type, i_orb_set, j_orb_set, i_offset, j_offset + integer :: first_i, last_i, first_j, last_j + real(dp) :: W(10,10,4), W_T(9,9,4), trans_mat_i(10,9), trans_mat_j(10,9) + + pi = at%pos(1:3,i) + pj = at%pos(1:3,i) + dv_hat(1:3)*dv_mag + + i_type = this%type_of_atomic_num(at%Z(i)) + j_type = this%type_of_atomic_num(at%Z(j)) + + i_offset = 1 + do i_orb_set=1, this%n_orb_sets(i_type) + sigi = this%gaussian_width(i_orb_set, i_type) + phasei = this%orb_set_phase(i_orb_set, i_type) + + call init_transform(trans_mat_i, sigi, phasei) + + j_offset = 1 + do j_orb_set=1, this%n_orb_sets(j_type) + sigj = this%gaussian_width(j_orb_set, j_type) + phasej = this%orb_set_phase(j_orb_set, j_type) + + call init_transform(trans_mat_j, sigj, phasej) + ! Mark Pederson's dipole matrix element routine + call GINTED(sigi, sigj, pi, pj, W) + W_T(1:9,1:9,1) = matmul(matmul(transpose(trans_mat_i),W(1:10,1:10,1)),trans_mat_j) + W_T(1:9,1:9,2) = matmul(matmul(transpose(trans_mat_i),W(1:10,1:10,2)),trans_mat_j) + W_T(1:9,1:9,3) = matmul(matmul(transpose(trans_mat_i),W(1:10,1:10,3)),trans_mat_j) + + if (this%orb_set_type(i_orb_set,i_type) == ORB_S) then + first_i = 1 + last_i = 1 + else if (this%orb_set_type(i_orb_set,i_type) == ORB_P) then + first_i = 2 + last_i = 4 + else if (this%orb_set_type(i_orb_set,i_type) == ORB_D) then + first_i = 5 + last_i = 9 + else + call system_abort("get_dipole_block got unknown orb_set_type for i_orb_set " // this%orb_set_type(i_orb_set,i_type)) + endif + if (this%orb_set_type(j_orb_set,j_type) == ORB_S) then + first_j = 1 + last_j = 1 + else if (this%orb_set_type(j_orb_set,j_type) == ORB_P) then + first_j = 2 + last_j = 4 + else if (this%orb_set_type(j_orb_set,j_type) == ORB_D) then + first_j = 5 + last_j = 9 + else + call system_abort(" get_dipole_block got unknown orb_set_type for j_orb_set " // this%orb_set_type(j_orb_set,j_type)) + endif + block_dipole(i_offset:i_offset+N_ORBS_OF_SET(this%orb_set_type(i_orb_set,i_type))-1, & + j_offset:j_offset+N_ORBS_OF_SET(this%orb_set_type(j_orb_set,j_type))-1, 1:3) = W_T(first_i:last_i,first_j:last_j,1:3) + j_offset = j_offset + N_ORBS_OF_SET(this%orb_set_type(j_orb_set,j_type)) + end do ! j_orb_set + i_offset = i_offset + N_ORBS_OF_SET(this%orb_set_type(i_orb_set,i_type)) + end do ! i_orb_set + +end subroutine get_dipole_block + +subroutine init_transform(trans, sigma, phase) +implicit none + real(dp), intent(out) :: trans(10,9) + real(dp), intent(in) :: sigma + integer, intent(in) :: phase + + integer O_S, O_PX, O_PY, O_PZ + parameter (O_S = 1, O_PX = 2, O_PY = 3, O_PZ = 4) + integer O_DXX, O_DYY, O_DZZ, O_DXY, O_DYZ, O_DXZ + parameter (O_DXX = 5, O_DYY = 6, O_DZZ = 7, O_DXY = 8, O_DXZ = 9, O_DYZ = 10) + + integer OT_S, OT_PX, OT_PY, OT_PZ + parameter (OT_S = 1, OT_PY = 2, OT_PZ = 3, OT_PX = 4) + integer OT_DXY, OT_DYZ, OT_DZX, OT_DXXYY, OT_DZZRR + parameter (OT_DXY = 5, OT_DYZ = 6, OT_DZZRR = 7, OT_DZX = 8, OT_DXXYY = 9) + real(dp) :: inv_rt2, inv_rt6 + real(dp) :: rt2 + + real(dp) :: base_norm_factor, rt_sigma + + inv_rt2 = 1.0_dp/sqrt(2.0_dp) + inv_rt6 = 1.0_dp/sqrt(6.0_dp) + rt2 = sqrt(2.0_dp) + + base_norm_factor = 1.0D0/(PI/(2.0_dp*sigma))**(3.0_dp/4.0_dp) + rt_sigma = sqrt(sigma) + + trans = 0.0D0 + + trans(O_S,OT_S) = base_norm_factor + + trans(O_PX,OT_PX) = -2.0_dp*base_norm_factor*rt_sigma + trans(O_PY,OT_PY) = -2.0_dp*base_norm_factor*rt_sigma + trans(O_PZ,OT_PZ) = -2.0_dp*base_norm_factor*rt_sigma + + trans(O_DXY,OT_DXY) = 4.0_dp*base_norm_factor*sigma + trans(O_DYZ,OT_DYZ) = 4.0_dp*base_norm_factor*sigma + trans(O_DXZ,OT_DZX) = 4.0_dp*base_norm_factor*sigma + + trans(O_DXX,OT_DXXYY) = inv_rt2*rt2*2.0_dp*base_norm_factor*sigma + trans(O_DYY,OT_DXXYY) = -inv_rt2*rt2*2.0_dp*base_norm_factor*sigma + + trans(O_DXX,OT_DZZRR) = -inv_rt6*rt2*2.0_dp*base_norm_factor*sigma + trans(O_DYY,OT_DZZRR) = -inv_rt6*rt2*2.0_dp*base_norm_factor*sigma + trans(O_DZZ,OT_DZZRR) = 2.0D0*inv_rt6*rt2*2.0_dp*base_norm_factor*sigma + + trans = trans*phase + +end subroutine init_transform + +subroutine realloc_dipole_model(this, new_n_types, new_n_orb_sets) + type(TB_Dipole_Model), intent(inout) :: this + integer, intent(in) :: new_n_types, new_n_orb_sets + + integer :: max_n_orb_sets + integer, allocatable :: t_atomic_num(:), t_n_orb_sets(:), t_orb_set_type(:,:), t_orb_set_phase(:,:) + real(dp), allocatable :: t_gaussian_width(:,:) + + if (size(this%n_orb_sets) > 0) then + max_n_orb_sets = maxval(this%n_orb_sets,1) + else + max_n_orb_sets = 0 + endif + if (new_n_types > this%n_types .or. new_n_orb_sets > max_n_orb_sets) then + ! allocate temporaries if necessary + if (this%n_types > 0) then + allocate(t_n_orb_sets(this%n_types)) + t_n_orb_sets = this%n_orb_sets(1:this%n_types) + allocate(t_atomic_num(this%n_types)) + t_atomic_num = this%atomic_num(1:this%n_types) + if (max_n_orb_sets > 0) then + allocate(t_orb_set_type(max_n_orb_sets,this%n_types)) + allocate(t_gaussian_width(max_n_orb_sets,this%n_types)) + allocate(t_orb_set_phase(max_n_orb_sets,this%n_types)) + t_orb_set_type = this%orb_set_type(1:max_n_orb_sets,1:this%n_types) + t_gaussian_width = this%gaussian_width(1:max_n_orb_sets,1:this%n_types) + t_orb_set_phase = this%orb_set_phase(1:max_n_orb_sets,1:this%n_types) + endif + endif + + ! deallocate and reallocate real arrays + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) + if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) + if (allocated(this%gaussian_width)) deallocate(this%gaussian_width) + if (allocated(this%orb_set_phase)) deallocate(this%orb_set_phase) + allocate(this%atomic_num(new_n_types)) + allocate(this%n_orb_sets(new_n_types)) + allocate(this%orb_set_type(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) + allocate(this%orb_set_phase(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) + allocate(this%gaussian_width(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) + this%atomic_num = 0 + this%n_orb_sets = 0 + this%orb_set_type = 0 + this%gaussian_width = 0.0_dp + this%orb_set_phase = 0 + + ! copy from temporaries if necessary + if (this%n_types > 0) then + this%atomic_num(1:this%n_types) = t_atomic_num(1:this%n_types) + this%n_orb_sets(1:this%n_types) = t_n_orb_sets(1:this%n_types) + if (max_n_orb_sets > 0) then + this%orb_set_type(1:max_n_orb_sets,1:this%n_types) = t_orb_set_type(1:max_n_orb_sets, 1:this%n_types) + this%gaussian_width(1:max_n_orb_sets,1:this%n_types) = t_gaussian_width(1:max_n_orb_sets, 1:this%n_types) + this%orb_set_phase(1:max_n_orb_sets,1:this%n_types) = t_orb_set_phase(1:max_n_orb_sets, 1:this%n_types) + endif + endif + this%n_types = max(this%n_types, new_n_types) + + if (allocated(t_atomic_num)) deallocate(t_atomic_num) + if (allocated(t_n_orb_sets)) deallocate(t_n_orb_sets) + if (allocated(t_orb_set_type)) deallocate(t_orb_set_type) + if (allocated(t_gaussian_width)) deallocate(t_gaussian_width) + if (allocated(t_orb_set_phase)) deallocate(t_orb_set_phase) + endif +end subroutine realloc_dipole_model + +subroutine realloc_spin_orbit_coupling(this, new_n_types, new_n_orb_sets) + type(TB_Spin_Orbit_Coupling), intent(inout) :: this + integer, intent(in) :: new_n_types, new_n_orb_sets + + integer :: max_n_orb_sets + integer, allocatable :: t_atomic_num(:), t_n_orb_sets(:), t_orb_set_type(:,:) + real(dp), allocatable :: t_SO_param(:,:) + + if (size(this%n_orb_sets) > 0) then + max_n_orb_sets = maxval(this%n_orb_sets,1) + else + max_n_orb_sets = 0 + endif + if (new_n_types > this%n_types .or. new_n_orb_sets > max_n_orb_sets) then + ! allocate temporaries if necessary + if (this%n_types > 0) then + allocate(t_n_orb_sets(this%n_types)) + t_n_orb_sets = this%n_orb_sets(1:this%n_types) + allocate(t_atomic_num(this%n_types)) + t_atomic_num = this%atomic_num(1:this%n_types) + if (max_n_orb_sets > 0) then + allocate(t_orb_set_type(max_n_orb_sets,this%n_types)) + allocate(t_SO_param(max_n_orb_sets,this%n_types)) + t_orb_set_type = this%orb_set_type(1:max_n_orb_sets,1:this%n_types) + t_SO_param = this%SO_param(1:max_n_orb_sets,1:this%n_types) + endif + endif + + ! deallocate and reallocate real arrays + if (allocated(this%atomic_num)) deallocate(this%atomic_num) + if (allocated(this%n_orb_sets)) deallocate(this%n_orb_sets) + if (allocated(this%orb_set_type)) deallocate(this%orb_set_type) + if (allocated(this%SO_param)) deallocate(this%SO_param) + allocate(this%atomic_num(new_n_types)) + allocate(this%n_orb_sets(new_n_types)) + allocate(this%orb_set_type(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) + allocate(this%SO_param(max(new_n_orb_sets,max_n_orb_sets), new_n_types)) + this%atomic_num = 0 + this%n_orb_sets = 0 + this%orb_set_type = 0 + this%SO_param = 0.0_dp + + ! copy from temporaries if necessary + if (this%n_types > 0) then + this%atomic_num(1:this%n_types) = t_atomic_num(1:this%n_types) + this%n_orb_sets(1:this%n_types) = t_n_orb_sets(1:this%n_types) + if (max_n_orb_sets > 0) then + this%orb_set_type(1:max_n_orb_sets,1:this%n_types) = t_orb_set_type(1:max_n_orb_sets, 1:this%n_types) + this%SO_param(1:max_n_orb_sets,1:this%n_types) = t_SO_param(1:max_n_orb_sets, 1:this%n_types) + endif + endif + this%n_types = max(this%n_types, new_n_types) + + if (allocated(t_atomic_num)) deallocate(t_atomic_num) + if (allocated(t_n_orb_sets)) deallocate(t_n_orb_sets) + if (allocated(t_orb_set_type)) deallocate(t_orb_set_type) + if (allocated(t_SO_param)) deallocate(t_SO_param) + endif +end subroutine realloc_spin_orbit_coupling + +subroutine get_SO_block(this, tbm, Z, block_SO) + type(TB_Spin_Orbit_Coupling), intent(in) :: this + type(TBModel), intent(in) :: tbm + integer, intent(in) :: Z + complex(dp), intent(out) :: block_SO(:,:) + + complex(dp) :: V(2,2) + integer :: i_orb_set, i_orb_dir, j_orb_dir, i_orb_type + integer :: offset_base, i_offset, j_offset + integer :: i_type + + i_type = this%type_of_atomic_num(Z) + block_SO = 0.0_dp + offset_base = 0 + do i_orb_set=1, n_orb_sets_of_Z(tbm, Z) + i_orb_type = orb_type_of_orb_set_of_Z(tbm, Z, i_orb_set) + do i_orb_dir=1, n_orbs_of_orb_set_of_Z(tbm, Z, i_orb_set) + do j_orb_dir=1, n_orbs_of_orb_set_of_Z(tbm, Z, i_orb_set) + i_offset = offset_base + i_orb_dir - 1 + j_offset = offset_base + j_orb_dir - 1 + V = spin_orbit_function(i_orb_type, i_orb_dir, j_orb_dir) + block_SO(2*i_offset+1:2*i_offset+2,2*j_offset+1:2*j_offset+2) = this%SO_param(i_orb_set, i_type) * V(1:2,1:2) + end do + end do + offset_base = offset_base + n_orbs_of_orb_set_of_Z(tbm, Z, i_orb_set) + end do + +end subroutine get_SO_block + +subroutine tbsystem_initialise_kpoints(this, args_str, param_str, mpi_obj, from_tbsystem_initialise) + type(TBSystem), intent(inout) :: this + character(len=*), intent(in), optional :: args_str + character(len=*), intent(in), optional :: param_str + type(MPI_context), intent(in), optional :: mpi_obj + logical, intent(in), optional :: from_tbsystem_initialise + + type(Dictionary) :: params + logical :: use_k_density, use_k_density_once, k_use_mp + integer :: k_mesh(3) + logical :: my_from_tbsystem_initialise + real(dp) :: k_density + + my_from_tbsystem_initialise = optional_default(.false., from_tbsystem_initialise) + + if (present(args_str)) then + call initialise(params) + call param_register(params, "k_density", "-1.0", k_density, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "use_k_density", "F", use_k_density, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "use_k_density_once", "F", use_k_density_once, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "k_mesh", "-1 -1 -1", k_mesh, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, "k_use_mp", ""//this%kpoints_use_mp, k_use_mp, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='TBSystem_Initialise_KPoints')) then + call system_abort("tbsystem_initialise_kpoints failed to parse args_str='"//trim(args_str)//"'") + endif + call finalise(params) + else + use_k_density = .false. + use_k_density_once = .false. + k_mesh = (/ -1, -1, -1 /) + k_use_mp = .true. + endif + + if (use_k_density .and. use_k_density_once) then + call system_abort("tbsystem_initialise_kpoints confused because user passed both use_k_density and use_k_density_once") + endif + + if (.not. my_from_tbsystem_initialise .and. use_k_density_once) then + call system_abort("tbsystem_initialise_kp[oints use_k_density_once can only be passed from tbsystem_initialise") + endif + + if ((use_k_density .or. use_k_density_once) .and. any(k_mesh > 0)) then + call system_abort("tbsystem_initialise_kpoints confused by having both use_k_density ("//use_k_density// & + ") or use_k_density_once("//use_k_density_once//") and signs of intent to use k_mesh ("//k_mesh//")") + endif + + if (my_from_tbsystem_initialise) then + if (use_k_density .or. use_k_density_once) then + this%kpoints_generate_dynamically = .true. + this%kpoints_generate_next_dynamically = .not. use_k_density_once + this%kpoints_use_mp = k_use_mp + if (k_density >= 0.0_dp) then + this%kpoints_k_space_density = k_density + else if (this%tbmodel%has_default_k_density) then + this%kpoints_k_space_density = this%tbmodel%default_k_density + else + this%kpoints_k_space_density = -1.0_dp + endif + else if (any(k_mesh > 0)) then + call initialise(this%kpoints, k_mesh, k_use_mp, mpi_obj) + call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) + else + if (present(param_str)) then + call initialise(this%kpoints, param_str, mpi_obj) + call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) + endif + endif + else ! not from tbsystem_initialise + if (use_k_density) then + this%kpoints_generate_dynamically = .true. + this%kpoints_generate_next_dynamically = .true. + this%kpoints_use_mp = k_use_mp + if (k_density >= 0.0_dp) then + this%kpoints_k_space_density = k_density + else if (this%tbmodel%has_default_k_density) then + this%kpoints_k_space_density = this%tbmodel%default_k_density + else + this%kpoints_k_space_density = -1.0_dp + endif + else if (any(k_mesh > 0)) then + call initialise(this%kpoints, k_mesh, k_use_mp, mpi_obj) + call Initialise_tbsystem_k_dep_stuff(this, mpi_obj) + endif + endif + + +end subroutine tbsystem_initialise_kpoints + +end module TBSystem_module diff --git a/src/Potentials/TB_Common.F90 b/src/Potentials/TB_Common.F90 new file mode 100644 index 0000000000..51de2bde0a --- /dev/null +++ b/src/Potentials/TB_Common.F90 @@ -0,0 +1,335 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X TB_Common_module +!X +!% TB module computes the tight-binding Hamiltonian matrix elements +!% in the two-center approximation, applying the general expressions +!% derived by A.V. Podolskiy and P. Vogl Phys. Rev. B {\bf 69}, 233101 (2004). +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +module TB_Common_module + +use System_module +implicit none +private + +integer, parameter, public :: ORB_S = 1, ORB_P = 2, ORB_D = 3, ORB_F = 4 + +integer, parameter, public :: N_ORBS_OF_SET(4) = (/1, 3, 5, 7/) + + + +integer, parameter, public :: harrison_sign_sss = -1, harrison_sign_sps = 1, & + harrison_sign_pps = 1, harrison_sign_ppp = -1, & + harrison_sign_sds = -1, harrison_sign_pds = -1, & + harrison_sign_pdp = 1, harrison_sign_dds = -1, & + harrison_sign_ddp = 1 + +integer, parameter, public :: N_SK = 20 +integer, parameter, public :: SK_SSS = 1, SK_SPS = 2, SK_PPS = 3, SK_PPP = 4, & + SK_SDS = 5, SK_PDS = 6, SK_PDP = 7, SK_DDS = 8, SK_DDP = 9, SK_DDD = 10, & + SK_SFS = 11, SK_PFS = 12, SK_PFP = 13, SK_DFS = 14, SK_DFP = 15, SK_DFD = 16, & + SK_FFS = 17, SK_FFP = 18, SK_FFD = 19, SK_FFF = 20 + +public :: angular_function, dangular_function, spin_orbit_function + +contains + +function angular_function(dcos, dcos_sq, orb_type_i, orb_type_j, orb_dir_i, orb_dir_j, sk) result(V) + real(dp), intent(in) :: dcos(3), dcos_sq(3) + integer, intent(in) :: orb_type_i, orb_type_j + integer, intent(in) :: orb_dir_i, orb_dir_j + real(dp), intent(in) :: sk(N_SK) + real(dp) :: V + + real(dp) :: u_V_sss, u_V_sps, u_V_pps, u_V_ppp + real(dp) :: u_V_sds, u_V_pds, u_V_pdp + real(dp) :: u_V_dds, u_V_ddp, u_V_ddd + real(dp) :: u_V_sfs, u_V_pfs, u_V_pfp + real(dp) :: u_V_dfs, u_V_dfp, u_V_dfd + real(dp) :: u_V_ffs, u_V_ffp, u_V_ffd, u_V_fff + + real(dp) :: L, M, N, Lsq, Msq, Nsq, Nsq_denom + + real(dp) :: root_3 + + root_3 = sqrt(3.0_dp) + + ! L on L + u_V_sss = sk(SK_SSS) + + u_V_pps = sk(SK_PPS) + u_V_ppp = sk(SK_PPP) + + u_V_dds = sk(SK_DDS) + u_V_ddp = sk(SK_DDP) + u_V_ddd = sk(SK_DDD) + + u_V_ffs = sk(SK_FFS) + u_V_ffp = sk(SK_FFP) + u_V_ffd = sk(SK_FFD) + u_V_fff = sk(SK_FFF) + + ! L on L +/- 2 + u_V_sds = sk(SK_SDS) + + u_V_pfs = sk(SK_PFS) + u_V_pfp = sk(SK_PFP) + + ! SK_vogl.h does also its own sign flip + if (orb_type_i < orb_type_j) then + ! L on L +/- 1 + u_V_sps = sk(SK_SPS) + + u_V_pds = sk(SK_PDS) + u_V_pdp = sk(SK_PDP) + + u_V_dfs = sk(SK_DFS) + u_V_dfp = sk(SK_DFP) + u_V_dfd = sk(SK_DFD) + + ! L on L +/- 3 + u_V_sfs = sk(SK_SFS) + else + ! L on L +/- 1 + u_V_sps = -sk(SK_SPS) + + u_V_pds = -sk(SK_PDS) + u_V_pdp = -sk(SK_PDP) + + u_V_dfs = -sk(SK_DFS) + u_V_dfp = -sk(SK_DFP) + u_V_dfd = -sk(SK_DFD) + + ! L on L +/- 3 + u_V_sfs = -sk(SK_SFS) + endif + + L = dcos(1) + M = dcos(2) + N = dcos(3) + Lsq = dcos_sq(1) + Msq = dcos_sq(2) + Nsq = dcos_sq(3) + ! work around division by (-1 + Nsq) in SK_vogl.h by defining special variant of + ! Nsq that is regularized, so that numerator which is 0 can correctly drive + ! expression to 0 instead of getting NaN + Nsq_denom = Nsq + if (Nsq == 1.0) then + Nsq_denom = Nsq - 1.0e-5 + endif + + ! seems to prevent intel 9.1.051 -O3 optimizer from breaking S1-D5 matrix element (and maybe others?) + if (orb_type_i < 0) call print("") + +include 'SK_vogl.h' + +end function angular_function + +function spin_orbit_function(orb_type_i, orb_dir_i, orb_dir_j) result(V) + integer, intent(in) :: orb_type_i, orb_dir_i, orb_dir_j + complex(dp) :: V(2,2) + + real(dp) :: root_3 + + root_3 = sqrt(3.0_dp) + + ! spin-orbit term + ! from Podolskiy and Vogl, Phys. Rev. B v. 69, p 233101 (2004) + +include 'SK_SO_vogl.h' + +end function spin_orbit_function + +function dangular_function(dist, dcos, dcos_sq, orb_type_i, orb_type_j, & + orb_dir_i, orb_dir_j, sk, dsk) + real(dp), intent(in) :: dist, dcos(3), dcos_sq(3) + integer, intent(in) :: orb_type_i, orb_type_j + integer, intent(in) :: orb_dir_i, orb_dir_j + real(dp), intent(in) :: sk(N_SK), dsk(N_SK) + real(dp) :: dangular_function(3) + + real(dp) :: rVd(3), rVd_t + + real(dp) :: u_V_sss, u_V_sps, u_V_pps, u_V_ppp + real(dp) :: u_V_sds, u_V_pds, u_V_pdp + real(dp) :: u_V_dds, u_V_ddp, u_V_ddd + real(dp) :: u_V_sfs, u_V_pfs, u_V_pfp + real(dp) :: u_V_dfs, u_V_dfp, u_V_dfd + real(dp) :: u_V_ffs, u_V_ffp, u_V_ffd, u_V_fff + + real(dp) :: u_Vd_sss, u_Vd_sps, u_Vd_pps, u_Vd_ppp + real(dp) :: u_Vd_sds, u_Vd_pds, u_Vd_pdp + real(dp) :: u_Vd_dds, u_Vd_ddp, u_Vd_ddd + real(dp) :: u_Vd_sfs, u_Vd_pfs, u_Vd_pfp + real(dp) :: u_Vd_dfs, u_Vd_dfp, u_Vd_dfd + real(dp) :: u_Vd_ffs, u_Vd_ffp, u_Vd_ffd, u_Vd_fff + + real(dp) :: L, M, N, Lsq, Msq, Nsq, Nsq_denom + real(dp) :: dL_dr(3), dM_dr(3), dN_dr(3) + + real(dp) :: root_3 + + root_3 = sqrt(3.0_dp) + + ! L on L + u_V_sss = sk(SK_SSS) + + u_V_pps = sk(SK_PPS) + u_V_ppp = sk(SK_PPP) + + u_V_dds = sk(SK_DDS) + u_V_ddp = sk(SK_DDP) + u_V_ddd = sk(SK_DDD) + + u_V_ffs = sk(SK_FFS) + u_V_ffp = sk(SK_FFP) + u_V_ffd = sk(SK_FFD) + u_V_fff = sk(SK_FFF) + + u_Vd_sss = dsk(SK_SSS) + + u_Vd_pps = dsk(SK_PPS) + u_Vd_ppp = dsk(SK_PPP) + + u_Vd_dds = dsk(SK_DDS) + u_Vd_ddp = dsk(SK_DDP) + u_Vd_ddd = dsk(SK_DDD) + + u_Vd_ffs = dsk(SK_FFS) + u_Vd_ffp = dsk(SK_FFP) + u_Vd_ffd = dsk(SK_FFD) + u_Vd_fff = dsk(SK_FFF) + + ! L on L +/- 2 + u_V_sds = sk(SK_SDS) + + u_V_pfs = sk(SK_PFS) + u_V_pfp = sk(SK_PFP) + + u_Vd_sds = dsk(SK_SDS) + + u_Vd_pfs = dsk(SK_PFS) + u_Vd_pfp = dsk(SK_PFP) + + ! SK_vogl.h does also its own sign flip + if (orb_type_i < orb_type_j) then + ! L on L +/- 1 + u_V_sps = sk(SK_SPS) + + u_V_pds = sk(SK_PDS) + u_V_pdp = sk(SK_PDP) + + u_V_dfs = sk(SK_DFS) + u_V_dfp = sk(SK_DFP) + u_V_dfd = sk(SK_DFD) + + u_Vd_sps = dsk(SK_SPS) + + u_Vd_pds = dsk(SK_PDS) + u_Vd_pdp = dsk(SK_PDP) + + u_Vd_dfs = dsk(SK_DFS) + u_Vd_dfp = dsk(SK_DFP) + u_Vd_dfd = dsk(SK_DFD) + + ! L on L +/- 3 + u_V_sfs = sk(SK_SFS) + + u_Vd_sfs = dsk(SK_SFS) + else + ! L on L +/- 1 + u_V_sps = -sk(SK_SPS) + + u_V_pds = -sk(SK_PDS) + u_V_pdp = -sk(SK_PDP) + + u_V_dfs = -sk(SK_DFS) + u_V_dfp = -sk(SK_DFP) + u_V_dfd = -sk(SK_DFD) + + u_Vd_sps = -dsk(SK_SPS) + + u_Vd_pds = -dsk(SK_PDS) + u_Vd_pdp = -dsk(SK_PDP) + + u_Vd_dfs = -dsk(SK_DFS) + u_Vd_dfp = -dsk(SK_DFP) + u_Vd_dfd = -dsk(SK_DFD) + + ! L on L +/- 3 + u_V_sfs = -sk(SK_SFS) + + u_Vd_sfs = -dsk(SK_SFS) + endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + L = dcos(1) + M = dcos(2) + N = dcos(3) + Lsq = dcos_sq(1) + Msq = dcos_sq(2) + Nsq = dcos_sq(3) + ! work around division by (-1 + Nsq) in SKd_vogl.h by defining special variant of + ! Nsq that is regularized, so that numerator which is 0 can correctly drive + ! expression to 0 instead of getting NaN + Nsq_denom = Nsq + if (Nsq == 1.0) then + Nsq_denom = Nsq - 1.0e-5 + endif + + ! seems to prevent intel 9.1.051 -O3 optimizer from breaking S1-D5 matrix element (and maybe others?) + if (orb_type_i < 0) call print("") + +include 'SKd_vogl.h' + + dL_dr(1) = (-1.0_dp+L**2)/dist + dL_dr(2) = L*M/dist + dL_dr(3) = L*N/dist + + dM_dr(1) = M*L/dist + dM_dr(2) = (-1.0_dp+M**2)/dist + dM_dr(3) = M*N/dist + + dN_dr(1) = N*L/dist + dN_dr(2) = N*M/dist + dN_dr(3) = (-1.0_dp+N**2)/dist + + dangular_function(:) = (rVd(1)*dL_dr(:) + rVd(2)*dM_dr(:) + rVd(3)*dN_dr(:) - rVd_t*dcos(:)) + +end function dangular_function + +end module TB_Common_module diff --git a/src/Potentials/TB_GreensFunctions.F90 b/src/Potentials/TB_GreensFunctions.F90 new file mode 100644 index 0000000000..67d59a7225 --- /dev/null +++ b/src/Potentials/TB_GreensFunctions.F90 @@ -0,0 +1,649 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX! +!X +!X TB_GreensFunctions module +!X +!% Contain Green's functions of a TB model, calculate them, +!% and compute derivatives of energies by summing over GFs +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX! +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX! +module TB_GreensFunctions_module + +use system_module, only : dp, print, inoutput, mainlog, PRINT_NERD, verbosity_push_decrement, verbosity_pop, system_abort, operator(//) +use mpi_context_module +use atoms_module + +use Functions_module +use ApproxFermi_module +use Matrix_module +use TBMatrix_module +use TB_Kpoints_module +use TBSystem_module + +implicit none +private + +public :: GreensFunctions +type GreensFunctions + integer :: N_G = 0 + complex(dp), allocatable :: a(:), z(:) + + type(TBSystem) :: tbsys + type(TBMatrix), allocatable :: G(:), G_conjg(:) + type(TBMatrix) :: dm, mod_dm_H, mod_dm_S + type(MPI_Context) :: mpi_global, mpi_my_poles, mpi_across_poles +end type GreensFunctions + +public :: Initialise +interface Initialise + module procedure GreensFunctions_Initialise +end interface Initialise + +public :: Finalise +interface Finalise + module procedure GreensFunctions_Finalise +end interface Finalise + +public :: Wipe +interface Wipe + module procedure GreensFunctions_Wipe +end interface Wipe + +public :: Print +interface Print + module procedure GreensFunctions_Print +end interface Print + +public :: Setup_system +interface Setup_system + module procedure GreensFunctions_Setup_system +end interface Setup_system + +interface init_mpi + module procedure GreensFunctions_init_mpi +end interface init_mpi + +interface end_mpi + module procedure GreensFunctions_end_mpi +end interface end_mpi + +public :: calc_Gs +interface calc_Gs + module procedure GreensFunctions_calc_Gs +end interface calc_Gs + +public :: calc_dm_from_Gs +interface calc_dm_from_Gs + module procedure GreensFunctions_calc_dm_from_Gs +end interface calc_dm_from_Gs + +public :: calc_mod_dm_from_Gs +interface calc_mod_dm_from_Gs + module procedure GreensFunctions_calc_mod_dm_from_Gs +end interface calc_mod_dm_from_Gs + +public :: Gsum_distrib_inplace +interface Gsum_distrib_inplace + module procedure GreensFunctions_Gsum_distrib_inplace_tbm, GreensFunctions_Gsum_distrib_inplace_r2 + module procedure GreensFunctions_Gsum_distrib_inplace_r3, GreensFunctions_Gsum_distrib_inplace_matd +end interface Gsum_distrib_inplace + +public :: Gsum_distrib +interface Gsum_distrib + module procedure GreensFunctions_Gsum_distrib_d +end interface Gsum_distrib + +contains + +subroutine GreensFunctions_Finalise(this) + type(GreensFunctions), intent(inout) :: this + + call end_mpi(this) + + call Wipe(this) + call Finalise(this%dm) + call Finalise(this%mod_dm_H) + call Finalise(this%mod_dm_S) + call Finalise(this%tbsys) + call Finalise(this%mpi_global) + call Finalise(this%mpi_my_poles) + call Finalise(this%mpi_across_poles) +end subroutine GreensFunctions_Finalise + +subroutine GreensFunctions_Wipe(this) + type(GreensFunctions), intent(inout) :: this + + integer :: i + + call Wipe(this%tbsys) + + if (allocated(this%G)) then + do i=1, size(this%G) + call Finalise(this%G(i)) + end do + deallocate(this%G) + endif + if (allocated(this%G_conjg)) then + do i=1, size(this%G_conjg) + call Finalise(this%G_conjg(i)) + end do + deallocate(this%G_conjg) + endif + if (allocated(this%a)) deallocate(this%a) + if (allocated(this%z)) deallocate(this%z) + this%N_G = 0 + + call finalise(this%dm) + call finalise(this%mod_dm_H) + call finalise(this%mod_dm_S) +end subroutine GreensFunctions_Wipe + +subroutine GreensFunctions_Print(this,file) + type(GreensFunctions), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer::i + + call Print('GreensFunctions : ', file=file) + + call Print ('GreensFunctions: N_G ' // this%N_G, file=file) + if (this%N_G > 0) then + do i=1, size(this%a) + call Print ("GreensFunctions : a z " // i // " " // this%a(i) // " " // this%z(i), file=file) + end do + call verbosity_push_decrement() + do i=1, size(this%G) + call Print(this%G(i), file=file) + end do + do i=1, size(this%G_conjg) + call Print(this%G_conjg(i), file=file) + end do + call verbosity_pop() + endif +end subroutine GreensFunctions_Print + +subroutine GreensFunctions_init_mpi(this, mpi_obj) + type(GreensFunctions), intent(inout) :: this + type(MPI_Context), intent(in) :: mpi_obj + + integer i + integer local_N_G, n_procs_per_pole, t + integer my_split_ident + integer, allocatable :: local_index(:) + complex(dp), allocatable :: t_a(:), t_z(:) + logical :: no_pole_here + + this%mpi_global = mpi_obj + + if (this%N_G > this%mpi_global%n_procs) then + n_procs_per_pole = 1 + else + n_procs_per_pole = this%mpi_global%n_procs/this%N_G + endif + + allocate(local_index(this%N_G)) + local_N_G = 0 + do i=0, this%N_G-1 + t = this%mpi_global%my_proc/n_procs_per_pole + if (mod(i,this%mpi_global%n_procs) == t) then + local_N_G = local_N_G + 1 + local_index(local_N_G) = i+1 + end if + end do + + if (local_N_G == 0) then + local_N_G = 1 + no_pole_here = .true. + local_index(1) = this%N_G + else + no_pole_here = .false. + endif + + if (this%mpi_global%active) then + my_split_ident = this%mpi_global%my_proc/n_procs_per_pole + call split_context(this%mpi_global, my_split_ident, this%mpi_my_poles) + + my_split_ident = this%mpi_my_poles%my_proc + call split_context(this%mpi_global, my_split_ident, this%mpi_across_poles) + endif + + allocate(t_a(local_N_G)) + allocate(t_z(local_N_G)) + t_a(1:local_N_G) = this%a(local_index(1:local_N_G)) + t_z(1:local_N_G) = this%z(local_index(1:local_N_G)) + + deallocate(this%a) + deallocate(this%z) + this%N_G = local_N_G + allocate(this%a(this%N_G)) + allocate(this%z(this%N_G)) + this%a = t_a + this%z = t_z + if (no_pole_here) this%a = 0.0_dp + deallocate(t_a) + deallocate(t_z) +end subroutine GreensFunctions_init_mpi + +subroutine GreensFunctions_end_mpi(this) + type(GreensFunctions), intent(inout) :: this + + if (this%mpi_global%active) then + call free_context(this%mpi_my_poles) + call free_context(this%mpi_across_poles) + endif +end subroutine GreensFunctions_end_mpi + + +subroutine GreensFunctions_Initialise(this, z, a, tbsys, mpi_obj) + type(GreensFunctions), intent(inout) :: this + complex(dp) :: z(:), a(:) + type(TBSystem), intent(in), optional :: tbsys + type(MPI_Context), intent(in), optional :: mpi_obj + + + if (size(z) /= size(a)) call system_abort("Called GreensFunctions_Initialise with mismatching z and a arrays") + + call Finalise(this) + + this%N_G = size(z) + if (allocated(this%z)) deallocate(this%z) + if (allocated(this%a)) deallocate(this%a) + allocate(this%z(size(z))) + allocate(this%a(size(a))) + this%z = z + this%a = a + + if (present(mpi_obj)) then + call init_mpi(this, mpi_obj) + else + call init_mpi(this, tbsys%mpi_global) + endif + + if (present(tbsys)) then + call Setup_system(this, tbsys) + endif + +end subroutine GreensFunctions_Initialise + +subroutine GreensFunctions_Setup_system(this, tbsys) + type(GreensFunctions), intent(inout) :: this + type(TBSystem), intent(in) :: tbsys + + integer i + + call Finalise(this%tbsys) + + if (allocated(this%G)) then + do i=1, size(this%G) + call Finalise(this%G(i)) + end do + deallocate(this%G) + endif + if (allocated(this%G_conjg)) then + do i=1, size(this%G_conjg) + call Finalise(this%G_conjg(i)) + end do + deallocate(this%G_conjg) + endif + + call Initialise(this%tbsys, tbsys, mpi_obj=this%mpi_my_poles) + this%tbsys%scf = tbsys%scf + + allocate(this%G(this%N_G)) + do i=1, this%N_G + call Initialise(this%G(i), this%tbsys%N, this%tbsys%n_matrices, .true., this%tbsys%scalapack_my_matrices) + end do + if (this%tbsys%complex_matrices) then + allocate(this%G_conjg(this%N_G)) + do i=1, this%N_G + call Initialise(this%G_conjg(i), this%tbsys%N, this%tbsys%n_matrices, .true., this%tbsys%scalapack_my_matrices) + end do + endif + + call Initialise(this%dm, this%tbsys%N, this%tbsys%n_matrices, this%tbsys%complex_matrices, & + scalapack_obj=this%tbsys%scalapack_my_matrices) + call Initialise(this%mod_dm_H, this%tbsys%N, this%tbsys%n_matrices, this%tbsys%complex_matrices, & + scalapack_obj=this%tbsys%scalapack_my_matrices) + if (.not. this%tbsys%tbmodel%is_orthogonal) then + call Initialise(this%mod_dm_S, this%tbsys%N, this%tbsys%n_matrices, this%tbsys%complex_matrices, & + scalapack_obj=this%tbsys%scalapack_my_matrices) + endif + +end subroutine + +subroutine GreensFunctions_calc_Gs(this, at, SelfEnergy) + type(GreensFunctions), intent(inout) :: this + type(Atoms), intent(inout) :: at + type(TBMatrix), intent(in), optional :: SelfEnergy(:) + + integer i + + + call fill_matrices(this%tbsys, at, .true.) + + if (present(SelfEnergy)) then + if (this%N_G /= size(SelfEnergy)) & + call system_abort("Called GreensFunctions_calc_Gs with SelfEnergy size mismatch " // size(SelfEnergy) // " " // this%N_G) + endif + +!$omp parallel do + do i=1, this%N_G + mainlog%mpi_all_inoutput_flag=.true. + call print("GreensFunctions_calc_Gs doing i="//i, PRINT_NERD) + mainlog%mpi_all_inoutput_flag=.false. + call scaled_sum(this%G(i), this%z(i), this%tbsys%S, -1.0_dp, this%tbsys%H) + if (present(SelfEnergy)) then + call scaled_accum(this%G(i), cmplx(1.0_dp, 0.0_dp, dp), SelfEnergy(i)) + endif + call inverse(this%G(i), positive = .false.) + if (this%tbsys%complex_matrices) then + call scaled_sum(this%G_conjg(i), conjg(this%z(i)), this%tbsys%S, -1.0_dp, this%tbsys%H) + call inverse(this%G_conjg(i), positive = .false.) + endif + end do + +end subroutine GreensFunctions_calc_Gs + +subroutine GreensFunctions_calc_dm_from_Gs(this) + type(GreensFunctions), intent(inout) :: this + + integer i + + call zero(this%dm) + do i=1, this%N_G + if (this%tbsys%complex_matrices) then + call scaled_accum(this%dm, -this%a(i), this%G(i)) + call scaled_accum(this%dm, -conjg(this%a(i)), this%G_conjg(i)) + else + call scaled_accum(this%dm, -2.0_dp*this%a(i), this%G(i)) + endif + end do + + call Gsum_distrib_inplace(this, this%dm) +end subroutine + +subroutine GreensFunctions_calc_mod_dm_from_Gs(this, w_e, w_n, do_const_N) + type(GreensFunctions), intent(inout) :: this + real(dp), intent(in), pointer :: w_e(:), w_n(:) + logical, intent(in), optional :: do_const_N + + real(dp), allocatable :: ww_e(:), ww_n(:) + logical :: const_N = .false. + real(dp) chempot + type(TBMatrix),save :: GWE, GWE_H_G, GWN, GWN_S_G + +!$OMP threadprivate(GWE,GWN,GWE_H_G,GWN_S_G) + + complex(dp) a, az + + integer i + + if (present(do_const_N)) const_N = do_const_N + + call zero(this%mod_dm_H) + if (.not. this%tbsys%tbmodel%is_orthogonal) then + call zero(this%mod_dm_S) + endif + + allocate(ww_e(this%tbsys%N)) + allocate(ww_n(this%tbsys%N)) + + if (associated(w_e)) then + ww_e = atom_orbital_spread(this%tbsys, w_e) + else + ww_e = 1.0_dp + endif + if (associated(w_n)) then + ww_n = atom_orbital_spread(this%tbsys, w_n) + else + ww_n = 1.0_dp + endif + + if (const_N) chempot = GreensFunctions_calc_chempot(this, w_e, w_n) + + +!$omp parallel private(a,az) + call Initialise(GWE, this%tbsys%N, this%tbsys%n_matrices, is_complex = .true., scalapack_obj=this%tbsys%scalapack_my_matrices) + call Initialise(GWE_H_G, this%tbsys%N, this%tbsys%n_matrices, is_complex = .true., scalapack_obj=this%tbsys%scalapack_my_matrices) + if (const_N) then + call Initialise(GWN, this%tbsys%N, this%tbsys%n_matrices, is_complex = .true., scalapack_obj=this%tbsys%scalapack_my_matrices) + call Initialise(GWN_S_G, this%tbsys%N, this%tbsys%n_matrices, is_complex = .true., scalapack_obj=this%tbsys%scalapack_my_matrices) + endif +!$omp do + do i=1, this%N_G + mainlog%mpi_all_inoutput_flag=.true. + call print("GreensFunctions_calc_mod_dm_from_Gs doing i="//i, PRINT_NERD) + mainlog%mpi_all_inoutput_flag=.false. + call multDiag(GWE, this%G(i), ww_e) + if (const_N) call multDiag(GWN, this%G(i), ww_n) + + call calc_GWAG(GWE, this%G(i), this%tbsys%H, GWE_H_G) + if (const_N) call calc_GWAG(GWN, this%G(i), this%tbsys%S, GWE_H_G) + + a = this%a(i) + az = this%a(i)*this%z(i) + + if (.not. this%tbsys%complex_matrices) then ! double instead of doing G(z) and G(conjg(z)) separately + a = 2.0_dp*a + az = 2.0_dp*az + endif + + ! const mu + ! F = Re d/dr sum_i Tr [ H a_i (z_i S-H)^-1 W ] + ! pull Re and sum in + ! = d/dr Tr [ H Re sum_i a_i (z_i S - H)^-1 W ] + ! chain rule + ! = Tr [ dH/dr Re sum_i a_i G_i W ] + Tr [ H Re sum_i a_i -G_i (z_i dS/dr - dH/dr) G_i W ] + ! expand + ! = Tr [ dH/dr Re sum_i a_i G_i W ] + Tr [ dH/dr Re sum_i a_i (G_i W H G_i ) + + ! dS/dr Re sum_i -a_i z_i G_i W H G_i ]; + ! = Tr [ dH/dr sum_i Re ( a_i G_i W + a_i G_i W H W G_i ) ] + Tr [ dS/dr Re (sum_i -az_i G_i W H G_i) ] + ! const N + ! F = Re d/dr Tr [ H sum_i a_i G_i WE - mu S sum_i a_i G_i WN ]; mu = dE / dN + ! = f_mu - mu Tr [ dS/dr Re sum_i a_i G_i WN ] - mu Tr [ S Re sum_i a_i -G_i (z_i dS/dr - dH/dr) G_i WN ] + ! = f_mu - mu Tr [ dS/dr Re sum_i a_i G_i WN ] - mu Tr [ dH/dr Re sum_i a_i G_i WN S G_i - + ! dS/dr Re sum_i az_i G_i WN S G_i ] + ! = f_mu + Tr [ dH/dr Re sum_i -mu a_i G_i WN S G_i ] + Tr [ dS/dr Re sum_i -mu a_i G_i WN + + ! dS/dr Re sum_i mu az_i G_i WN S G_i ] + +!$omp critical + call scaled_accum(this%mod_dm_H, -a, GWE) ! Tr dH/dr G W contribution to E + call scaled_accum(this%mod_dm_H, -a, GWE_H_G) ! Tr H dG/dr W = Tr H G dH/dr G W = Tr dH/dr G W H G + + if (const_N) then + call scaled_accum(this%mod_dm_H, a*chempot, GWN_S_G) ! Tr S dG/dr W = Tr S G dH/dr G W = Tr dH/dr G W S G + endif + + if (.not. this%tbsys%tbmodel%is_orthogonal) then + call scaled_accum(this%mod_dm_S, az, GWE_H_G) ! Tr H dG/dr W = Tr H G dS/dr G W = Tr dS/dr G W H G + if (const_N) then + call scaled_accum(this%mod_dm_S, a*chempot, GWN) ! Tr dS/dr G W contribution to mu N + call scaled_accum(this%mod_dm_S, -az*chempot, GWN_S_G) ! Tr S dG/dr W = Tr S G dS/dr G W = Tr dS/dr G W S G + endif + endif +!$omp end critical + + if (this%tbsys%complex_matrices) then ! need to do G(conjg(z)) explicitly + call multDiag(GWE, this%G_conjg(i), ww_e) + if (const_N) call multDiag(GWN, this%G_conjg(i), ww_n) + + call calc_GWAG(GWE, this%G_conjg(i), this%tbsys%H, GWE_H_G) + if (const_N) call calc_GWAG(GWN, this%G_conjg(i), this%tbsys%S, GWE_H_G) + + a = conjg(this%a(i)) + az = conjg(this%a(i)*this%z(i)) + +!$omp critical + call scaled_accum(this%mod_dm_H, -a, GWE) ! Tr dH/dr G W contribution to E + call scaled_accum(this%mod_dm_H, -a, GWE_H_G) ! Tr H dG/dr W = Tr H G dH/dr G W = Tr dH/dr G W H G + + if (const_N) then + call scaled_accum(this%mod_dm_H, a*chempot, GWN_S_G) ! Tr S dG/dr W = Tr S G dH/dr G W = Tr dH/dr G W S G + endif + + if (.not. this%tbsys%tbmodel%is_orthogonal) then + + call scaled_accum(this%mod_dm_S, az, GWE_H_G) ! Tr H dG/dr W = Tr H G dS/dr G W = Tr dS/dr G W H G + if (const_N) then + call scaled_accum(this%mod_dm_S, a*chempot, GWN) ! Tr dS/dr G W contribution to mu N + call scaled_accum(this%mod_dm_S, -az*chempot, GWN_S_G) ! Tr S dG/dr W = Tr S G dS/dr G W = Tr dS/dr G W S G + endif + endif +!$omp end critical + + endif + end do + call Finalise(GWE) + call Finalise(GWE_H_G) + if (const_N) then + call Finalise(GWN) + call Finalise(GWN_S_G) + endif +!$omp end parallel + + call Gsum_distrib_inplace(this, this%mod_dm_H) + if (.not. this%tbsys%tbmodel%is_orthogonal) then + call Gsum_distrib_inplace(this, this%mod_dm_S) + endif + + deallocate(ww_e, ww_n) + + +end subroutine + +function GreensFunctions_calc_chempot(this, w_e, w_n) + type(GreensFunctions), intent(in) :: this + real(dp), pointer :: w_e(:), w_n(:) + real(dp) :: GreensFunctions_calc_chempot + + integer i + real(dp) :: dE_dmu = 0.0_dp, dN_dmu = 0.0_dp + + complex(dp), allocatable :: pTr_GSGS(:), pTr_GSGH(:) + complex(dp) :: Tr_GSGS, Tr_GSGH + + type(TBMatrix) :: GS, GH + complex a + + call Initialise(GS, this%tbsys%N, this%tbsys%n_matrices, .true., scalapack_obj = this%tbsys%scalapack_my_matrices) + call Initialise(GH, this%tbsys%N, this%tbsys%n_matrices, .true., scalapack_obj = this%tbsys%scalapack_my_matrices) + + allocate(pTR_GSGS(this%tbsys%N_atoms)) + allocate(pTR_GSGH(this%tbsys%N_atoms)) + + do i=1, this%N_G + a = this%a(i) + + call matrix_product_sub(GS, this%G(i), this%tbsys%S) + call matrix_product_sub(GH, this%G(i), this%tbsys%H) + + pTr_GSGS = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, partial_TraceMult(GS, GS))) + call ksum_distrib_inplace(this%tbsys%kpoints, pTr_GSGS) + if (associated(w_n)) then + Tr_GSGS = sum(w_n*pTR_GSGS) + else + Tr_GSGS = sum(pTR_GSGS) + endif + + pTr_GSGH = local_ksum(this%tbsys%kpoints, atom_orbital_sum(this%tbsys, partial_TraceMult(GS, GH))) + call ksum_distrib_inplace(this%tbsys%kpoints, pTr_GSGH) + if (associated(w_e)) then + Tr_GSGH = sum(w_e*pTR_GSGH) + else + Tr_GSGH = sum(pTR_GSGH) + endif + + dE_dmu = dE_dmu - 2.0_dp*a*Tr_GSGH + dN_dmu = dN_dmu - 2.0_dp*a*Tr_GSGS + end do + + dE_dmu = Gsum_distrib(this, dE_dmu) + dN_dmu = Gsum_distrib(this, dN_dmu) + + GreensFunctions_calc_chempot = dE_dmu / dN_dmu + +end function GreensFunctions_calc_chempot + +subroutine calc_GWAG(GW, G, A, GWAG) + type(TBMatrix), intent(in) :: GW, A, G + type(TBMatrix), intent(inout) :: GWAG + + type(TBMatrix) :: t + + call Initialise(t, GW) + + call matrix_product_sub(t, A, G) + call matrix_product_sub(GWAG, GW, t) + + call Finalise(t) +end subroutine calc_GWAG + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine GreensFunctions_Gsum_distrib_inplace_tbm(this, M) + type(GreensFunctions), intent(in) :: this + type(TBMatrix), intent(inout) :: M + + call sum_in_place(M, this%mpi_across_poles) +end subroutine + +subroutine GreensFunctions_Gsum_distrib_inplace_r2(this, M) + type(GreensFunctions), intent(in) :: this + real(dp), intent(inout) :: M(:,:) + + call sum_in_place(this%mpi_across_poles, M) +end subroutine + +subroutine GreensFunctions_Gsum_distrib_inplace_r3(this, M) + type(GreensFunctions), intent(in) :: this + real(dp), intent(inout) :: M(:,:,:) + + call sum_in_place(this%mpi_across_poles, M) +end subroutine + +subroutine GreensFunctions_Gsum_distrib_inplace_matd(this, M) + type(GreensFunctions), intent(in) :: this + type(MatrixD), intent(inout) :: M + + call sum_in_place(this%mpi_across_poles, M%data) +end subroutine + +function GreensFunctions_Gsum_distrib_d(this, d) + type(GreensFunctions), intent(in) :: this + real(dp), intent(in) :: d + real(dp) :: GreensFunctions_Gsum_distrib_d + + GreensFunctions_Gsum_distrib_d = sum(this%mpi_across_poles, d) +end function GreensFunctions_Gsum_distrib_d + +end module TB_GreensFunctions_module diff --git a/src/Potentials/TB_Kpoints.F90 b/src/Potentials/TB_Kpoints.F90 new file mode 100644 index 0000000000..08e2629cc8 --- /dev/null +++ b/src/Potentials/TB_Kpoints.F90 @@ -0,0 +1,818 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X TB_KPoints Module +!X +!% This is a module for doing (weighted and unweighted) k-points sums, +!% sorting, computing phase factors. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module TB_KPoints_module + +use system_module, only : dp, inoutput, initialise, INPUT, is_file_readable, NUMERICAL_ZERO, system_abort +use units_module +use extendable_str_module +use linearalgebra_module +use mpi_context_module +use quip_Common_module + +implicit none + +private + +character(len=20) :: kpt_default_file = "k_pt_mesh.data.xml" + +!% Structure for storing k-points and doing k-points sums (in parallel) +public :: KPoints +type KPoints + integer :: N = 0, g_N = 0 + real(dp), allocatable :: k_pts(:,:), weights(:), g_k_pts(:,:), g_weights(:) + logical :: non_gamma = .false. + logical :: no_sum_over_my_kpt = .false. + type(MPI_context) :: mpi_global, mpi_my_kpt, mpi_across_kpts +end type + +type(extendable_str), save :: cur_data +logical :: parse_in_kp +integer :: parse_cur_kp +type(KPoints), pointer :: parse_kp + +!% Initialise by reading parameters from file/inoutput +public :: Initialise +public :: KPoints_Initialise_filename +interface Initialise + module procedure KPoints_Initialise_inoutput, KPoints_Initialise_str, KPoints_Initialise_kp + module procedure KPoints_Initialise_mesh, KPoints_Initialise_density +end interface Initialise + +!% Prepare splitting according to mpi. +public :: init_mpi +interface init_mpi + module procedure KPoints_init_mpi +end interface init_mpi + +!% Interface to deallocate everything. +public :: Finalise +interface Finalise + module procedure KPoints_Finalise +end interface Finalise + +!% Free mpi_contexts generated in init_mpi. +public :: end_mpi +interface end_mpi + module procedure KPoints_end_mpi +end interface end_mpi + +!% Interface to print everything. +public :: Print +interface Print + module procedure KPoints_Print +end interface Print + +!% Calculate a phase factor for a given k-point and cell shift. +public :: calc_phase +interface calc_phase + module procedure KPoints_calc_phase +end interface + +!% Read params in XML format. +private :: KPoints_read_points_xml +interface read_points_xml + module procedure KPoints_read_points_xml +end interface read_points_xml + +!% Minimum over k-points of a quantity that's duplicated among processors of each k-point. +public :: min +interface min + module procedure KPoints_kmin_real, KPoints_kmin_real1 +end interface min + +!% Maximum over k-points of a quantity that's duplicated among processors of each k-point. +public :: max +interface max + module procedure KPoints_kmax_real, KPoints_kmax_real1 +end interface max + +!% Weighted sum over k-points of a quantity that's duplicated among processors of each k-point. +public :: ksum_dup +interface ksum_dup + module procedure KPoints_ksum_dup_r1, KPoints_ksum_dup_c1 +end interface ksum_dup + +!% Local weighted sum over k-points of a quantity. +public :: local_ksum +interface local_ksum + module procedure KPoints_local_ksum_real1, KPoints_local_ksum_real2 + module procedure KPoints_local_ksum_complex1, KPoints_local_ksum_complex2, KPoints_local_ksum_complex4 +end interface local_ksum + +!% UNweighted sum over k-points of an array that's distributed among processors of each k-point. +public :: ksum_distrib +interface ksum_distrib + module procedure KPoints_ksum_distrib_real +end interface ksum_distrib + +!% in-place UNweighted sum over k-points of an array that's distributed among processors of each k-point. +public :: ksum_distrib_inplace +interface ksum_distrib_inplace + module procedure KPoints_ksum_distrib_inplace_real1, KPoints_ksum_distrib_inplace_real2 + module procedure KPoints_ksum_distrib_inplace_complex1 +end interface ksum_distrib_inplace + +public :: collect +interface collect + module procedure Kpoints_collect_real2 +end interface collect + +contains + +subroutine KPoints_Initialise_filename(this, filename, mpi_obj) + type(KPoints), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_context), intent(in), optional :: mpi_obj + + type(inoutput) io + + call Initialise(io,filename,INPUT) + call Initialise(this,io,mpi_obj) + call Finalise(io) + +end subroutine + +subroutine KPoints_Initialise_inoutput(this, from_io, mpi_obj) + type(KPoints), intent(inout) :: this + type(inoutput), intent(inout), target, optional :: from_io + type(MPI_context), intent(in), optional :: mpi_obj + + logical file_present + type(inoutput), pointer :: in + type(extendable_str) :: ss + + file_present = .true. + + if (present(from_io)) then + in => from_io + else + if (is_file_readable(trim(kpt_default_file))) then + allocate(in) + call Initialise(in, trim(kpt_default_file), INPUT) + else + file_present = .false. + endif + endif + + call Initialise(ss) + if (file_present) then + if (present(mpi_obj)) then + call read(ss, in%unit, convert_to_string=.true., mpi_comm=mpi_obj%communicator, mpi_id=mpi_obj%my_proc) + else + call read(ss, in%unit, convert_to_string=.true.) + endif + endif + + call Initialise(this, string(ss), mpi_obj) + + call Finalise(ss) + +end subroutine + +subroutine KPoints_Initialise_str(this, from_str, mpi_obj) + type(KPoints), intent(inout) :: this + character(len=*), intent(in) :: from_str + type(MPI_context), intent(in), optional :: mpi_obj + + call Finalise(this) + + call KPoints_read_points_xml(this, from_str) + + call finish_initialise(this, mpi_obj) + +end subroutine KPoints_Initialise_str + +subroutine KPoints_Initialise_kp(this, from_kpoints, mpi_obj) + type(KPoints), intent(inout) :: this + type(KPoints), intent(in) :: from_kpoints + type(MPI_context), intent(in), optional :: mpi_obj + + call Finalise(this) + + this%non_gamma = from_kpoints%non_gamma + this%N = from_kpoints%g_N + if (this%N > 0) then + allocate(this%k_pts(3,this%N)) + allocate(this%weights(this%N)) + this%k_pts = from_kpoints%g_k_pts + this%weights = from_kpoints%g_weights + endif + + call finish_initialise(this, mpi_obj) + +end subroutine KPoints_Initialise_kp + +function reciprocal_lattice(lattice) + real(dp), intent(in) :: lattice(3,3) + real(dp) :: reciprocal_lattice(3,3) + + call matrix3x3_inverse(lattice,reciprocal_lattice) + reciprocal_lattice = -2.0_dp*PI*transpose(reciprocal_lattice) + +end function reciprocal_lattice + +subroutine KPoints_Initialise_density(this, lattice, k_space_density, monkhorst_pack, mpi_obj) + type(KPoints), intent(inout) :: this + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: k_space_density + logical, intent(in), optional :: monkhorst_pack + type(MPI_context), intent(in), optional :: mpi_obj + + integer :: n(3) + real(dp) :: recip_lattice(3,3) + + if (k_space_density > 0.0_dp) then + recip_lattice = reciprocal_lattice(lattice) + + call matrix3x3_inverse(lattice,recip_lattice) + recip_lattice = -2.0_dp*PI*transpose(recip_lattice) + + n(1) = norm(recip_lattice(:,1))*k_space_density+1.0_dp-NUMERICAL_ZERO + n(2) = norm(recip_lattice(:,2))*k_space_density+1.0_dp-NUMERICAL_ZERO + n(3) = norm(recip_lattice(:,3))*k_space_density+1.0_dp-NUMERICAL_ZERO + where (n == 0) + n = 1 + end where + where (n > 1) + n = n + mod(n,2) + end where + else + n = 1 + endif + call initialise(this, n, monkhorst_pack, mpi_obj) + +end subroutine KPoints_initialise_density + +subroutine KPoints_Initialise_mesh(this, n, monkhorst_pack, mpi_obj) + type(KPoints), intent(inout) :: this + integer, intent(in) :: n(3) + logical, intent(in), optional :: monkhorst_pack + type(MPI_context), intent(in), optional :: mpi_obj + + integer :: i, i1, i2, i3, ik + integer :: min(3), max(3), step(3) + real(dp) :: denom(3) + logical :: shift(3) + real(dp), allocatable :: mesh_wt(:,:,:) + + call Finalise(this) + + if (minval(n) < 1) call system_abort("Called KPoints_initialise_mesh with garbage mesh size " // n) + + if (maxval(n) > 1) then + shift = .false. + if (present(monkhorst_pack)) then + if (monkhorst_pack .and. mod(n(1),2) == 0) then + shift(1) = .true. + end if + if (monkhorst_pack .and. mod(n(2),2) == 0) then + shift(2) = .true. + end if + if (monkhorst_pack .and. mod(n(3),2) == 0) then + shift(3) = .true. + end if + endif + + this%N = 0 + do i=1, 3 + if (shift(i)) then + if (mod(n(i),2) == 0) then + min(i) = -(n(i)-1) + max(i) = n(i)-1 + step(i) = 2 + denom(i) = 2*n(i) + else + call system_abort("kpoints_initialise_mesh tried to Monkhorst-Pack shift odd dimension " // i) + endif + else + if (mod(n(i),2) == 0) then + min(i) = -n(i)/2+1 + max(i) = n(i)/2 + step(i) = 1 + denom(i) = n(i) + else + if (n(i) == 1) then + min(i) = 0 + max(i) = 0 + step(i) = 1 + denom(i) = 1 + else + min(i) = -(n(i)-1)/2 + max(i) = (n(i)-1)/2 + step(i) = 1 + denom(i) = n(i) + end if + end if + endif + end do + + allocate(mesh_wt(min(1):max(1),min(2):max(2),min(3):max(3))) + mesh_wt = 1.0_dp + do i1=min(1), max(1), step(1) + do i2=min(2), max(2), step(2) + do i3=min(3), max(3), step(3) + if (-i1 >= min(1) .and. -i1 <= max(1) .and. & + -i2 >= min(2) .and. -i2 <= max(2) .and. & + -i3 >= min(3) .and. -i3 <= max(3)) then ! reflected k-point is in range + if ((i1 /= 0 .or. i2 /= 0 .or. i3 /= 0) .and. & + (mesh_wt(i1,i2,i3) > 0.0_dp .and. mesh_wt(-i1,-i2,-i3) > 0.0_dp)) then ! not gamma and both points have weight + mesh_wt(-i1,-i2,-i3) = mesh_wt(-i1,-i2,-i3) + mesh_wt(i1,i2,i3) + mesh_wt(i1,i2,i3) = 0.0_dp + endif + endif + end do + end do + end do + + this%N = 0 + do i1=min(1), max(1), step(1) + do i2=min(2), max(2), step(2) + do i3=min(3), max(3), step(3) + if (mesh_wt(i1,i2,i3) > 0.0_dp) this%N = this%N + 1 + end do + end do + end do + allocate(this%k_pts(3,this%N)) + allocate(this%weights(this%N)) + + ik = 1 + do i1=min(1), max(1), step(1) + do i2=min(2), max(2), step(2) + do i3=min(3), max(3), step(3) + if (mesh_wt(i1,i2,i3) > 0.0_dp) then + this%k_pts(1,ik) = real(i1,dp)/denom(1) + this%k_pts(2,ik) = real(i2,dp)/denom(2) + this%k_pts(3,ik) = real(i3,dp)/denom(3) + this%weights(ik) = mesh_wt(i1,i2,i3) + ik = ik + 1 + endif + end do + end do + end do + + deallocate(mesh_wt) + else ! maxval(n) <= 1 + this%non_gamma = .false. + this%N = 1 + allocate(this%k_pts(3,this%N)) + allocate(this%weights(this%N)) + this%k_pts = 0.0_dp + this%weights = 1.0_dp + endif + + call finish_initialise(this, mpi_obj) + +end subroutine KPoints_initialise_mesh + +subroutine finish_initialise(this, mpi_obj) + type(KPoints), intent(inout) :: this + type(MPI_Context), intent(in), optional :: mpi_obj + + if (this%N > 0) then + this%weights = this%weights / sum(this%weights) + this%non_gamma = (maxval(abs(this%k_pts(1:3,1:this%N))) > 0.0_dp) + else + this%N = 1 + allocate(this%k_pts(3,1)) + allocate(this%weights(1)) + this%k_pts(1:3,1) = 0.0_dp + this%weights(1) = 1.0_dp + this%non_gamma = .false. + endif + + this%g_N = this%N + allocate(this%g_k_pts(3,this%g_N)) + allocate(this%g_weights(this%g_N)) + this%g_k_pts = this%k_pts + this%g_weights = this%weights + + if (present(mpi_obj)) then + call KPoints_init_mpi(this, mpi_obj) + endif + +end subroutine finish_initialise + +subroutine KPoints_init_mpi(this, mpi_obj) + type(KPoints), intent(inout) :: this + type(MPI_context), intent(in) :: mpi_obj + + integer i + integer t, local_N + integer, allocatable :: local_index(:) + integer my_split_ident + integer n_procs_per_matrix + real(dp), allocatable :: t_k_pts(:,:), t_weights(:) + + this%mpi_global = mpi_obj + + if (this%g_N >= this%mpi_global%n_procs) then + n_procs_per_matrix = 1 + else + n_procs_per_matrix = this%mpi_global%n_procs/this%g_N + endif + + allocate(local_index(this%g_N)) + local_N = 0 + do i=0, this%g_N-1 + t = this%mpi_global%my_proc/n_procs_per_matrix + if (mod(i,this%mpi_global%n_procs) == t) then + local_N = local_N + 1 + local_index(local_N) = i+1 + endif + end do + + if (this%mpi_global%active) then + + my_split_ident = this%mpi_global%my_proc/n_procs_per_matrix + call split_context(this%mpi_global, my_split_ident, this%mpi_my_kpt) + + my_split_ident = this%mpi_my_kpt%my_proc + call split_context(this%mpi_global, my_split_ident, this%mpi_across_kpts) + endif + + allocate(t_k_pts(3,local_N)) + allocate(t_weights(local_N)) + t_k_pts(1:3,1:local_N) = this%g_k_pts(1:3,local_index(1:local_N)) + t_weights(1:local_N) = this%g_weights(local_index(1:local_N)) + + deallocate(this%k_pts) + deallocate(this%weights) + this%N = local_N + allocate(this%k_pts(3,this%N)) + allocate(this%weights(this%N)) + this%k_pts = t_k_pts + this%weights = t_weights + deallocate(t_k_pts) + deallocate(t_weights) + +end subroutine KPoints_init_mpi + +subroutine KP_characters_handler(in) + character(len=*), intent(in) :: in + + if (parse_in_kp) call concat(cur_data, in, keep_lf=.false.) +end subroutine + +subroutine KP_startElement_handler(URI, localname, name, attributes) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + type(dictionary_t), intent(in) :: attributes + + integer status + character(len=1024) :: val + + if (name == "KPoints") then + parse_in_kp = .true. + parse_cur_kp=1 + call QUIP_FoX_get_value(attributes, "N", val, status) + if (status /= 0) & + call system_abort("parse kpoints xml: KPoints doesn't have N attribute") + read(val, *) parse_kp%N + if (parse_kp%N > 0) then + allocate(parse_kp%k_pts(3,parse_kp%N)) + allocate(parse_kp%weights(parse_kp%N)) + endif + elseif (parse_in_kp .and. name == "point") then + if (parse_cur_kp > parse_kp%N) & + call system_abort("parse kpoints xml found too many point elements " // parse_cur_kp // " > " // parse_kp%N) + call QUIP_FoX_get_value(attributes, "weight", val, status) + if (status /= 0) & + call system_abort("parse kpoints xml: point " // parse_cur_kp // " doesn't have weight attribute") + read(val, *) parse_kp%weights(parse_cur_kp) + endif + + call zero(cur_data) + +end subroutine + +subroutine KP_endElement_handler(URI, localname, name) + character(len=*), intent(in) :: URI + character(len=*), intent(in) :: localname + character(len=*), intent(in) :: name + + character(len=1024) :: str + + if (name == "KPoints") then + parse_in_kp = .false. + else if (parse_in_kp .and. name == "point") then + if (parse_cur_kp > parse_kp%N) & + call system_abort("parse kpoints xml: too many points specified, at least " // parse_cur_kp) + str = string(cur_data) + read(str, *) parse_kp%k_pts(1:3,parse_cur_kp) + parse_cur_kp = parse_cur_kp + 1 + call zero(cur_data) + endif + +end subroutine + +subroutine KPoints_read_points_xml(this, str) + type(KPoints), intent(inout), target :: this + character(len=*), intent(in) :: str + + type(xml_t) :: fxml + + if (len(trim(str)) <= 0) then + this%N = 0 + return + endif + + parse_cur_kp = 1 + parse_kp => this + + call open_xml_string(fxml, str) + + call parse(fxml, & + characters_handler=KP_characters_handler, & + startElement_handler=KP_startElement_handler, & + endElement_handler=KP_endElement_handler) + + call close_xml_t(fxml) + +end subroutine + +subroutine KPoints_Finalise(this) + type(KPoints), intent(inout) :: this + + call end_mpi(this) + + if (allocated(this%k_pts)) deallocate(this%k_pts) + if (allocated(this%weights)) deallocate(this%weights) + if (allocated(this%g_k_pts)) deallocate(this%g_k_pts) + if (allocated(this%g_weights)) deallocate(this%g_weights) + + this%N = 0 + this%g_N = 0 + this%non_gamma = .false. + +end subroutine KPoints_Finalise + +subroutine KPoints_end_mpi(this) + type(KPoints), intent(inout) :: this + + call free_context(this%mpi_my_kpt) + call free_context(this%mpi_across_kpts) +end subroutine KPoints_end_mpi + +subroutine KPoints_Print(this,file) + type(KPoints), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + integer::i + + call Print('KPoints : ', file=file) + + call Print ('KPoints : non_gamma ' // this%non_gamma, file=file) + call Print ('KPoints : g_N ' // this%g_N, file=file) + do i=1, this%g_N + call Print ('KPoints : g_k_pt ' // i // " " // this%g_k_pts(1:3,i) // " " // this%g_weights(i), file=file) + end do + +end subroutine KPoints_Print + +function KPoints_calc_phase(this, ik, shift) + type(KPoints), intent(in) :: this + integer, intent(in) :: ik + integer, intent(in) :: shift(3) + complex(dp) :: KPoints_calc_phase + + real(dp) phase + + phase = 2.0_dp*PI*sum(shift(1:3)*this%k_pts(1:3,ik)) + KPoints_calc_phase = cmplx(cos(phase), sin(phase), KIND(phase)) + +end function KPoints_calc_phase + + +function KPoints_kmin_real(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v + real(dp) :: KPoints_kmin_real + + if (this%mpi_my_kpt%my_proc == 0) then + KPoints_kmin_real = min(this%mpi_across_kpts, v) + endif + + call bcast(this%mpi_my_kpt, KPoints_kmin_real) +end function KPoints_kmin_real + +function KPoints_kmin_real1(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v(:) + real(dp) :: KPoints_kmin_real1 + + if (this%mpi_my_kpt%my_proc == 0) then + KPoints_kmin_real1 = min(this%mpi_across_kpts, minval(v)) + endif + + call bcast(this%mpi_my_kpt, KPoints_kmin_real1) +end function KPoints_kmin_real1 + +function KPoints_kmax_real(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v + real(dp) :: KPoints_kmax_real + + if (this%mpi_my_kpt%my_proc == 0) then + KPoints_kmax_real = max(this%mpi_across_kpts, v) + endif + + call bcast(this%mpi_my_kpt, KPoints_kmax_real) +end function KPoints_kmax_real + +function KPoints_kmax_real1(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v(:) + real(dp) :: KPoints_kmax_real1 + + if (this%mpi_my_kpt%my_proc == 0) then + KPoints_kmax_real1 = max(this%mpi_across_kpts, maxval(v)) + endif + + call bcast(this%mpi_my_kpt, KPoints_kmax_real1) +end function KPoints_kmax_real1 + +function KPoints_ksum_dup_r1(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v(:) + real(dp) :: KPoints_ksum_dup_r1 + + if (this%mpi_my_kpt%my_proc == 0) then + if (size(v) /= size(this%weights)) call System_abort("size mismatch in KPoints_ksum_dup_r1") + KPoints_ksum_dup_r1 = sum(this%mpi_across_kpts, dot_product(v,this%weights)) + endif + + call bcast(this%mpi_my_kpt, KPoints_ksum_dup_r1) +end function KPoints_ksum_dup_r1 + +function KPoints_ksum_dup_c1(this, v) + type(KPoints), intent(in) :: this + complex(dp), intent(in) :: v(:) + complex(dp) :: KPoints_ksum_dup_c1 + + if (this%mpi_my_kpt%my_proc == 0) then + if (size(v) /= size(this%weights)) call System_abort("size mismatch in KPoints_ksum_dup_c1") + KPoints_ksum_dup_c1 = sum(this%mpi_across_kpts, dot_product(v,this%weights)) + endif + + call bcast(this%mpi_my_kpt, KPoints_ksum_dup_c1) +end function KPoints_ksum_dup_c1 + +function KPoints_local_ksum_real1(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v(:) + real(dp) :: KPoints_local_ksum_real1 + + KPoints_local_ksum_real1 = dot_product(v,this%weights) +end function KPoints_local_ksum_real1 + +function KPoints_local_ksum_real2(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v(:,:) + real(dp) :: KPoints_local_ksum_real2(size(v,1)) + + integer ik + + KPoints_local_ksum_real2(:) = 0.0_dp + do ik=1, this%N + KPoints_local_ksum_real2(:) = KPoints_local_ksum_real2(:) + v(:,ik)*this%weights(ik) + end do +end function KPoints_local_ksum_real2 + +function KPoints_local_ksum_complex1(this, v) + type(KPoints), intent(in) :: this + complex(dp), intent(in) :: v(:) + complex(dp) :: KPoints_local_ksum_complex1 + + KPoints_local_ksum_complex1 = dot_product(v,this%weights) +end function KPoints_local_ksum_complex1 + +function KPoints_local_ksum_complex2(this, v) + type(KPoints), intent(in) :: this + complex(dp), intent(in) :: v(:,:) + complex(dp) :: KPoints_local_ksum_complex2(size(v,1)) + + integer ik + + KPoints_local_ksum_complex2(:) = 0.0_dp + do ik=1, this%N + KPoints_local_ksum_complex2(:) = KPoints_local_ksum_complex2(:) + v(:,ik)*this%weights(ik) + end do +end function KPoints_local_ksum_complex2 + +function KPoints_local_ksum_complex4(this, v) + type(KPoints), intent(in) :: this + complex(dp), intent(in) :: v(:,:,:,:) + complex(dp) :: KPoints_local_ksum_complex4(size(v,1),size(v,2),size(v,3)) + + integer ik + + KPoints_local_ksum_complex4(:,:,:) = 0.0_dp + do ik=1, this%N + KPoints_local_ksum_complex4(:,:,:) = KPoints_local_ksum_complex4(:,:,:) + v(:,:,:,ik)*this%weights(ik) + end do +end function KPoints_local_ksum_complex4 + +function KPoints_ksum_distrib_real(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v + real(dp) :: KPoints_ksum_distrib_real + + if (this%no_sum_over_my_kpt) then + KPoints_ksum_distrib_real = sum(this%mpi_across_kpts, v) + else + KPoints_ksum_distrib_real = sum(this%mpi_across_kpts, sum(this%mpi_my_kpt, v)) + endif +end function KPoints_ksum_distrib_real + +subroutine KPoints_ksum_distrib_inplace_real2(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(inout) :: v(:,:) + + if (.not. this%no_sum_over_my_kpt) then + call sum_in_place(this%mpi_my_kpt, v) + endif + call sum_in_place(this%mpi_across_kpts, v) +end subroutine KPoints_ksum_distrib_inplace_real2 + +subroutine KPoints_ksum_distrib_inplace_real1(this, v) + type(KPoints), intent(in) :: this + real(dp), intent(inout) :: v(:) + + if (.not. this%no_sum_over_my_kpt) then + call sum_in_place(this%mpi_my_kpt, v) + endif + call sum_in_place(this%mpi_across_kpts, v) +end subroutine KPoints_ksum_distrib_inplace_real1 + +subroutine KPoints_ksum_distrib_inplace_complex1(this, v) + type(KPoints), intent(in) :: this + complex(dp), intent(inout) :: v(:) + + if (.not. this%no_sum_over_my_kpt) then + call sum_in_place(this%mpi_my_kpt, v) + endif + call sum_in_place(this%mpi_across_kpts, v) +end subroutine KPoints_ksum_distrib_inplace_complex1 + +subroutine KPoints_collect_real2(this, v_in, v_out) + type(KPoints), intent(in) :: this + real(dp), intent(in) :: v_in(:,:) + real(dp), intent(out) :: v_out(:,:) + + if (size(v_in,1) /= size(v_out,1)) then + call system_abort("Called KPoints_collect_real2 with vector size mismatch v_in " // & + size(v_in,1) // " v_out " // size(v_out,1)) + endif + + if (size(v_in,2) /= this%N) then + call system_abort("Called KPoints_collect_real2 with local N_k mismatch v_in " // & + size(v_in,2) // " this%N " // this%N) + end if + + if (size(v_out,2) /= this%g_N) then + call system_abort("Called KPoints_collect_real2 with local N_k mismatch v_in " // & + size(v_in,2) // " this%N " // this%N) + end if + + call allgatherv(this%mpi_across_kpts, v_in, v_out) +end subroutine KPoints_collect_real2 + +end module TB_KPoints_module diff --git a/src/Potentials/TB_Mixing.F90 b/src/Potentials/TB_Mixing.F90 new file mode 100644 index 0000000000..8c9f5eea6c --- /dev/null +++ b/src/Potentials/TB_Mixing.F90 @@ -0,0 +1,518 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X TB_Mixing module +!X +!% do charge mixing for self-consistent TB models +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +module tb_mixing_module + +use System_module +use linearalgebra_module +implicit none + +private + +integer:: n_hist = 20 + +! Broyden +real(dp), allocatable:: u(:,:), dF(:,:), last_F(:), last_n(:) +real(dp), allocatable:: dn_mm1(:) +real(dp), allocatable:: a(:,:), beta(:,:), gamma(:,:), c(:,:), t(:,:), w(:) + +! Ridders +real(dp):: xmin, fmin, xmax, fmax +real(dp):: bracket_step +logical:: need_bracket = .true. +real(dp):: x3, f3, x4, f4 +logical:: got_f3, got_f4 + +public :: do_mix_broyden +interface do_mix_broyden + module procedure do_mix_broyden_array, do_mix_broyden_scalar +end interface do_mix_broyden + +public :: do_mix_simple +interface do_mix_simple + module procedure do_mix_simple_array, do_mix_simple_scalar +end interface do_mix_simple + +public :: do_ridders_residual + +contains + +! From Johnson PRB vol. 38, p. 12807 +subroutine do_mix_broyden_array(iter, n, F, np1, alpha, w0) + integer, intent(in) :: iter + real(dp), intent(in) :: n(:), F(:) + real(dp), intent(out) :: np1(:) + real(dp), intent(in) :: alpha, w0 + + integer mi, i, j, ki, li, ni + integer :: iter_offset + integer :: effective_iter + real(dp) :: dF_norm + + iter_offset = 0 + + if (realloc_hist_dep_stuff()) then + if (iter /= 1) then + call print("WARNING: had to realloc hist_dep_stuff but iter /= 1") + iter_offset = iter-1 + endif + endif + if (realloc_size_dep_stuff(size(n))) then + if (iter /= 1) then + call print("WARNING:had to realloc size_dep_stuff but iter /= 1") + iter_offset = iter-1 + endif + endif + + effective_iter = iter - iter_offset + + mi = min(effective_iter, n_hist) + + np1 = n + alpha * F + + if (effective_iter == 1) then + last_F = F + last_n = n + else + if (effective_iter .gt. n_hist) then + do i=1, mi-2 + dF(:,i) = dF(:,i+1) + w(i) = w(i+1) + u(:,i) = u(:,i+1) + end do + do i=1, mi-2 + do j=1, mi-2 + a(i,j) = a(i+1,j+1) + end do + end do + do i=1, mi-1 + do j=1, mi-1 + c(i,j) = c(i,j+1) + gamma(i,j) = gamma(i+1,j) + end do + end do + end if ! iter > n_hist + + ! calculate dF_(m-1) + dF(:,mi-1) = F(:) - last_F(:) + !!!dF_norm = sqrt(sum(dF**2)) + dF_norm = sqrt(sum(dF(:,mi-1)**2)) + dF(:,mi-1) = dF(:,mi-1) / dF_norm + last_F = F + +!! dF(:,mi-1) +!! w(mi-1) +!! a(1:mi-1,mi-1) a(mi-1,1:mi-1) +!! u(1:N_A,mi-1) +!! c(1:mi-1,mi) +!! gamma(mi,1:mi-1) + + ! calculate dn_(m-1) + dn_mm1(:) = (n(:) - last_n(:)) / dF_norm + last_n = n + + ! as per DD Johnson's suggestion in paper + w(mi-1) = min(1.0_dp/sqrt(sum(F**2)), 1.0_dp) + + ! update a_ij + do i=1, mi-1 + a(i,mi-1) = w(i)*w(mi-1)*sum(dF(:,i)*dF(:,mi-1)) + if (i .ne. mi-1) then + a(mi-1,i) = a(i,mi-1) + end if + end do + + ! compute beta = (w0^2 + a ) ^ -1 + t = a + do i=1, mi-1 + t(i,i) = t(i,i) + w0**2 + end do + call inverse(t(1:mi-1,1:mi-1), beta(1:mi-1,1:mi-1), .false.) + + ! compute u_(m-1) + u(:,mi-1) = alpha*dF(:,mi-1) + dn_mm1(:) + + ! compute c_k^m + do ki=1, mi-1 + c(ki,mi) = w(ki)*sum(dF(:,ki)*F(:)) + end do + do li=1, mi-1 + gamma(mi,li) = 0.0_dp + do ki=1, mi-1 + gamma(mi,li) = gamma(mi,li) + c(ki,mi)*beta(ki,li) + end do + end do + do ni=1, mi-1 + np1(:) = np1(:) - w(ni)*gamma(mi,ni)*u(:,ni) + end do + endif + +end subroutine do_mix_broyden_array + +subroutine do_mix_broyden_scalar(iter, n, F, np1, alpha, w0) + integer, intent(in) :: iter + real(dp), intent(in) :: n, F + real(dp), intent(out) :: np1 + real(dp), intent(in) :: alpha, w0 + + real(dp) :: na(1), Fa(1), np1a(1) + + na = n + Fa = F + np1a = np1 + + call do_mix_broyden(iter, na, Fa, np1a, alpha, w0) + + np1 = np1a(1) + +end subroutine do_mix_broyden_scalar + +subroutine do_mix_simple_array(iter, n, F, np1, alpha) + integer, intent(in) :: iter + real(dp), intent(in) :: n(:), F(:) + real(dp), intent(out) :: np1(:) + real(dp), intent(in) :: alpha + + np1 = n + alpha * F + +end subroutine do_mix_simple_array + +subroutine do_mix_simple_scalar(iter, n, F, np1, alpha) + integer, intent(in) :: iter + real(dp), intent(in) :: n, F + real(dp), intent(out) :: np1 + real(dp), intent(in) :: alpha + + real(dp) :: na(1), Fa(1), np1a(1) + + na = n + Fa = F + np1a = np1 + + call do_mix_simple(iter, na, Fa, np1a, alpha) + + np1 = np1a(1) + +end subroutine do_mix_simple_scalar + +function realloc_hist_dep_stuff() + logical :: realloc_hist_dep_stuff + + realloc_hist_dep_stuff = .false. + + if (allocated(a)) then + if (size(a,1) /= n_hist .or. size(a,2) /= n_hist) then + deallocate(a) + endif + endif + if (.not. allocated(a)) then + allocate(a(n_hist,n_hist)) + realloc_hist_dep_stuff = .true. + a = 0.0_dp + endif + + if (allocated(beta)) then + if (size(beta,1) /= n_hist .or. size(beta,2) /= n_hist) then + deallocate(beta) + endif + endif + if (.not. allocated(beta)) then + allocate(beta(n_hist,n_hist)) + realloc_hist_dep_stuff = .true. + beta = 0.0_dp + endif + + if (allocated(gamma)) then + if (size(gamma,1) /= n_hist .or. size(gamma,2) /= n_hist) then + deallocate(gamma) + endif + endif + if (.not. allocated(gamma)) then + allocate(gamma(n_hist,n_hist)) + realloc_hist_dep_stuff = .true. + endif + gamma = 0.0_dp + + if (allocated(c)) then + if (size(c,1) /= n_hist .or. size(c,2) /= n_hist) then + deallocate(c) + endif + endif + if (.not. allocated(c)) then + allocate(c(n_hist,n_hist)) + realloc_hist_dep_stuff = .true. + c = 0.0_dp + endif + + if (allocated(t)) then + if (size(t,1) /= n_hist .or. size(t,2) /= n_hist) then + deallocate(t) + endif + endif + if (.not. allocated(t)) then + allocate(t(n_hist,n_hist)) + realloc_hist_dep_stuff = .true. + t = 0.0_dp + endif + + if (allocated(w)) then + if (size(w) /= n_hist) then + deallocate(w) + endif + endif + if (.not. allocated(w)) then + allocate(w(n_hist)) + realloc_hist_dep_stuff = .true. + w = 0.0_dp + endif + +end function realloc_hist_dep_stuff + +function realloc_size_dep_stuff(new_n) + integer, intent(in) :: new_n + logical :: realloc_size_dep_stuff + + realloc_size_dep_stuff = .false. + + if (allocated(u)) then + if (size(u,1) /= new_n .or. size(u,2) /= n_hist) then + deallocate(u) + endif + endif + if (.not. allocated(u)) then + allocate(u(new_n, n_hist)) + realloc_size_dep_stuff = .true. + u = 0.0_dp + endif + + if (allocated(dF)) then + if (size(dF,1) /= new_n .or. size(dF,2) /= n_hist) then + deallocate(dF) + endif + endif + if (.not. allocated(dF)) then + allocate(dF(new_n, n_hist)) + realloc_size_dep_stuff = .true. + dF = 0.0_dp + endif + + if (allocated(last_F)) then + if (size(last_F) /= new_n) then + deallocate(last_F) + endif + endif + if (.not. allocated(last_F)) then + allocate(last_F(new_n)) + realloc_size_dep_stuff = .true. + last_F = 0.0_dp + endif + + if (allocated(last_n)) then + if (size(last_n) /= new_n) then + deallocate(last_n) + endif + endif + if (.not. allocated(last_n)) then + allocate(last_n(new_n)) + realloc_size_dep_stuff = .true. + last_n = 0.0_dp + endif + + if (allocated(dn_mm1)) then + if (size(dn_mm1) /= new_n) then + deallocate(dn_mm1) + endif + endif + if (.not. allocated(dn_mm1)) then + allocate(dn_mm1(new_n)) + realloc_size_dep_stuff = .true. + dn_mm1 = 0.0_dp + endif + +end function realloc_size_dep_stuff + +!subroutine inverse (ns, n, a, b, err) +! integer, intent(in) :: ns, n +! real(dp), intent(inout) :: a(ns,ns) +! real(dp), intent(out) :: b(ns,ns) +! integer, intent(out) :: err +! +! real(dp) :: td(ns), ad(ns), bd(ns) +! +! integer i, j, k +! +! do i=1, n +! if (dabs(a(i,i)) .lt. 1.0D-12) then +! print *, "Matrix has zero diagonal element ", i +! err = 1 +! return +! end if +! end do +! +! if (n .eq. 1) then +! b(1,1) = 1.0_dp/a(1,1) +! return +! end if +! +! b = 0.0_dp +! do i=1, n +! b(i,i) = 1.0_dp +! end do +! +! do i=1, n +! do j=1, n +! td(j) = a(j,i) / a(i,i) +! end do +! +! td(i) = 0.0_dp +! do k=1, n +! bd(k) = b(i,k) +! ad(k) = a(i,k) +! end do +! +! do k=1, n +! do j=1, n +! b(j,k) = b(j,k) - (td(j)*bd(k)) +! a(j,k) = a(j,k) - (td(j)*ad(k)) +! end do +! end do +! +! end do +! +! do i=1, n +! do j=1, n +! b(j,i) = b(j,i) / a(j,j) +! end do +! end do +! +! err = 0 +! +!end subroutine + +! From Numerical Recipes in C++, 2nd ed. +subroutine do_ridders_residual(iter, cur_x, cur_f, next_x) + integer, intent(in) :: iter + real(dp), intent(in) :: cur_x, cur_f + real(dp), intent(out) :: next_x + + real(dp) t, num, denom + + if (iter == 1) need_bracket = .true. + + if (need_bracket) then + if (iter == 1) then + xmin = cur_x; + fmin = cur_f; + next_x = 0.99_dp*cur_x + 0.01_dp*(cur_f+cur_x); + bracket_step = next_x - cur_x; + return + endif + if (sign(1.0_dp,cur_f) == sign(1.0_dp,fmin)) then + bracket_step = bracket_step*1.5 + if (abs(cur_f) < abs(fmin)) then + xmin = cur_x + fmin = cur_f + next_x = cur_x + bracket_step + else + next_x = cur_x - bracket_step + endif + return + else + xmax = cur_x + fmax = cur_f + if (xmin > xmax) then + t = xmin; xmin = xmax; xmax = t + t = fmin; fmin = fmax; fmax = t + endif + x3 = (xmin+xmax)/2.0_dp + next_x = x3 + need_bracket = .false. + got_f4 = .false. + got_f3 = .true. + return + endif + endif + + if (got_f3) then + f3 = cur_f + num = sign(1.0_dp,fmin-fmax)*f3 + denom = sqrt(f3*f3 - fmin*fmax) + if (denom == 0.0) then + next_x = x3 + return + endif + x4 = x3 + (x3-xmin)*num/denom + next_x = x4; + got_f3 = .false. + got_f4 = .true. + return + endif + + if (got_f4) then + f4 = cur_f + if (x3 < x4) then + if (sign(1.0_dp,fmin) /= sign (1.0_dp,f3)) then + xmax = x3 + fmax = f3 + else if (sign(1.0_dp,f3) /= sign(1.0_dp,f4)) then + xmin = x3; fmin = f3; + xmax = x4; fmax = f4; + else if (sign(1.0_dp,f4) /= sign(1.0_dp,fmax)) then + xmin = x4; fmin = f4; + endif + else + if (sign(1.0_dp,fmin) /= sign (1.0_dp,f4)) then + xmax = x4; + fmax = f4; + else if (sign(1.0_dp,f4) /= sign(1.0_dp,f3)) then + xmin = x4; fmin = f4; + xmax = x3; fmax = f3; + else if (sign(1.0_dp,f3) /= sign(1.0_dp,fmax)) then + xmin = x3; fmin = f3; + endif + endif + + x3 = (xmin+xmax)/2.0_dp; + next_x = x3; + got_f4 = .false. + got_f3 = .true. + return + endif +end subroutine do_ridders_residual + +end module tb_mixing_module diff --git a/src/Potentials/Yukawa.F90 b/src/Potentials/Yukawa.F90 new file mode 100644 index 0000000000..d9095bb0a4 --- /dev/null +++ b/src/Potentials/Yukawa.F90 @@ -0,0 +1,594 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module Yukawa_module + +use error_module +use system_module, only : dp, optional_default, system_timer +use units_module +use linearalgebra_module +use mpi_context_module +use atoms_types_module +use atoms_module +use functions_module +use QUIP_Common_module + +implicit none +private + +public :: yukawa_charges, yukawa_dipoles + +real(dp), parameter :: sqrt_2 = 1.41421356237309504880168872421_dp +real(dp), parameter :: sqrt_pi = 1.77245385090551602729816748334_dp + +contains + +!% Charge-charge interactions, screened by Yukawa function +subroutine yukawa_charges(at, charge, cutoff, alpha, smoothlength, & + e, local_e, f, virial, efield, mpi, atom_mask_name, source_mask_name, type_of_atomic_num, pseudise, pseudise_sigma, grid_size, error) + type(Atoms), intent(inout) :: at + real(dp), dimension(:), intent(in) :: charge !% charges, in units of the electronic charge + real(dp), intent(in) :: cutoff !% cutoff distance in A + real(dp), intent(in) :: alpha !% inverse screening length, in $A^{-1}$ + real(dp), intent(in) :: smoothlength !% distance over which potential is smoothly turned off, in A + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:) + real(dp), intent(out), optional :: virial(3,3) + real(dp), intent(out), optional :: efield(:,:) + type(MPI_Context), intent(in), optional :: mpi + character(len=*), optional, intent(in) :: atom_mask_name, source_mask_name + integer, intent(in), optional :: type_of_atomic_num(:) + logical, optional, intent(in) :: pseudise + real(dp), optional, intent(in) :: pseudise_sigma(:) + real(dp), optional, intent(in) :: grid_size + integer, intent(out), optional :: error + + real(dp) :: erf_val, erf_deriv + integer i, j, m, ti, tj + real(dp) :: r_ij, u_ij(3), zv2, gamjir, gamjir3, gamjir2, fc, dfc_dr + real(dp) :: de, dforce, expfactor, defield(3) + logical :: i_is_min_image, j_is_min_image, do_pseudise + real(dp) :: private_virial(3,3), private_e, sigma + real(dp), allocatable :: private_f(:,:), private_efield(:,:), private_local_e(:) + logical, pointer, dimension(:) :: atom_mask, source_mask + real(dp) :: yukcutoff, yukalpha, yuksmoothlength + + INIT_ERROR(error) + call system_timer('yukawa_charges') + + ! Unit conversion of arguments from eV/A/fs to atomic units + ! (charges are not affected) + yukcutoff = cutoff/BOHR + yukalpha = alpha*BOHR + yuksmoothlength = smoothlength/BOHR + + do_pseudise = optional_default(.false., pseudise) + if (do_pseudise .and. (.not. present(pseudise_sigma) .or. .not. present(type_of_atomic_num))) then + RAISE_ERROR("pseudise=T but pseudise_sigma or type_of_atomic_num arguments not present", error) + end if + atom_mask => null() + if (present(atom_mask_name)) then + if (trim(atom_mask_name) /= '') then + call assign_property_pointer(at, atom_mask_name, atom_mask, error) + PASS_ERROR(error) + end if + end if + + source_mask => null() + if (present(source_mask_name)) then + if (trim(source_mask_name) /= '') then + call assign_property_pointer(at, source_mask_name, source_mask, error) + PASS_ERROR(error) + end if + end if + + !$omp parallel default(none) shared(mpi, charge, at, e, local_e, f, virial, efield, atom_mask, source_mask, yukcutoff, cutoff, yukalpha, yuksmoothlength, grid_size, do_pseudise, pseudise_sigma, type_of_atomic_num) private(i, j, m, r_ij, u_ij, zv2, gamjir, gamjir3, gamjir2, fc, dfc_dr, de, dforce, expfactor, i_is_min_image, j_is_min_image, private_virial, private_e, private_f, private_local_e, private_efield, erf_val, erf_deriv, sigma, defield, ti, tj) + + if (present(e)) private_e = 0.0_dp + if (present(local_e)) then + allocate(private_local_e(at%N)) + private_local_e = 0.0_dp + endif + if (present(f)) then + allocate(private_f(3,at%N)) + private_f = 0.0_dp + endif + if (present(efield)) then + allocate(private_efield(3,at%N)) + private_efield = 0.0_dp + end if + if (present(virial)) private_virial = 0.0_dp + + !$omp do schedule(runtime) + do i=1, at%n + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if (associated(atom_mask)) then + if (.not. atom_mask(i)) cycle + i_is_min_image = .false. + else + if (allocated(at%connect%is_min_image)) then + i_is_min_image = at%connect%is_min_image(i) + else + i_is_min_image = is_min_image(at, i) + end if + end if + + ti = 0 + if (do_pseudise .and. at%Z(i) /= 0) ti = get_type(type_of_atomic_num, at%Z(i)) + + do m = 1, n_neighbours(at, i) + + j = neighbour(at, i, m, distance=r_ij, cosines=u_ij, max_dist=cutoff) + if (j <= 0) cycle + + if (associated(source_mask)) then + if (.not. source_mask(j)) cycle + end if + + if (r_ij .feq. 0.0_dp) then + if (present(grid_size)) then + r_ij = grid_size/BOHR + else + cycle + end if + end if + + if (allocated(at%connect%is_min_image)) then + j_is_min_image = at%connect%is_min_image(j) + else + j_is_min_image = is_min_image(at, j) + end if + + if (i < j .and. i_is_min_image .and. j_is_min_image) cycle + + r_ij = r_ij/BOHR + zv2 = charge(i)*charge(j) + + tj = 0 + if (do_pseudise .and. at%Z(j) /= 0) tj = get_type(type_of_atomic_num, at%Z(j)) + + gamjir = zv2/r_ij + gamjir3 = gamjir/(r_ij**2.0_dp) + gamjir2 = zv2/(r_ij**2.0_dp) + expfactor = exp(-yukalpha*r_ij) + + call smooth_cutoff(r_ij, yukcutoff-yuksmoothlength, yuksmoothlength, fc, dfc_dr) + + if (do_pseudise) then + sigma = pseudise_sigma(tj)/BOHR + erf_val = 1.0_dp + erf_deriv = 0.0_dp + ! pseudise if sigma > 0, correction for r >= 9s is < 1e-16 + if (sigma > 0.0_dp .and. r_ij < 9.0_dp*sigma) then + erf_val = erf(r_ij/(sqrt_2 * sigma)) + erf_deriv = sqrt_2/(sqrt_pi*sigma)*exp(-r_ij*r_ij/(2.0_dp*sigma*sigma)) + end if + end if + + if (present(e) .or. present(local_e)) then + de = gamjir*expfactor*fc + if (do_pseudise) de = de*erf_val + + if (present(e)) then + if (i_is_min_image .and. j_is_min_image) then + private_e = private_e + de + else + private_e = private_e + 0.5_dp*de + end if + end if + if (present(local_e)) then + private_local_e(i) = private_local_e(i) + 0.5_dp*de + if (i_is_min_image .and. j_is_min_image) private_local_e(j) = private_local_e(j) + 0.5_dp*de + end if + end if + + if (present(f) .or. present(virial) .or. present(efield)) then + dforce = gamjir3*expfactor*fc*r_ij + gamjir*(yukalpha*fc - dfc_dr)*expfactor + if (do_pseudise) dforce = dforce*erf_val - gamjir*expfactor*fc*erf_deriv + + if (present(f)) then + private_f(:,i) = private_f(:,i) - dforce*u_ij + if (i_is_min_image .and. j_is_min_image) private_f(:,j) = private_f(:,j) + dforce*u_ij + end if + + if (present(virial)) then + if (i_is_min_image .and. j_is_min_image) then + private_virial = private_virial + dforce*(u_ij .outer. u_ij)*r_ij + else + private_virial = private_virial + 0.5_dp*dforce*(u_ij .outer. u_ij)*r_ij + end if + end if + + if (present(efield)) then + defield = gamjir3*expfactor*fc*u_ij*r_ij + if (do_pseudise) defield = defield*erf_val + private_efield(:,i) = private_efield(:,i) - defield/charge(i) + if (i_is_min_image .and. j_is_min_image) private_efield(:,j) = private_efield(:,j) + defield/charge(j) + end if + end if + + end do + end do + + if (present(mpi)) then + if (mpi%active) then + if (present(e)) private_e = sum(mpi, private_e) + if (present(local_e)) call sum_in_place(mpi, private_local_e) + if (present(f)) call sum_in_place(mpi, private_f) + if (present(virial)) call sum_in_place(mpi, private_virial) + if (present(efield)) call sum_in_place(mpi, private_efield) + end if + end if + + ! Unit conversion of output to eV/A/fs + !$omp critical + if (present(e)) e = e + private_e*HARTREE + if (present(local_e)) local_e = local_e + private_local_e*HARTREE + if (present(f)) f = f + private_f*(HARTREE/BOHR) + if (present(virial)) virial = virial + private_virial*HARTREE + if (present(efield)) efield = efield + private_efield*(HARTREE/BOHR) + !$omp end critical + + if (allocated(private_f)) deallocate(private_f) + if (allocated(private_local_e)) deallocate(private_local_e) + if (allocated(private_efield)) deallocate(private_efield) + + !$omp end parallel + + call system_timer('yukawa_charges') + + end subroutine yukawa_charges + + +!% Charge-dipole and dipole-dipole interactions, screened by Yukawa function +subroutine yukawa_dipoles(at, charge, dip, cutoff, alpha, smoothlength, pol, b_pol, c_pol, & + type_of_atomic_num, tdip_sr, e, local_e, f, virial, efield, mpi, atom_mask_name, source_mask_name, pseudise, & + pseudise_sigma, grid_size, error) +#ifdef _OPENMP + use omp_lib +#endif + + type(Atoms), intent(inout) :: at + real(dp), intent(in) :: charge(:) !% charges, in units of the electronic charge + real(dp), intent(in) :: dip(:,:) !% (3,N) array of dipoles moments in units of (electron charge)*A + real(dp), intent(in) :: cutoff !% cutoff distance in A + real(dp), intent(in) :: alpha !% inverse screening length, in $A^{-1}$ + real(dp), intent(in) :: smoothlength !% distance over which potential is smoothly turned off, in A + real(dp), intent(in) :: pol(:) !% polarisabilities of each species, ordered by type_num + real(dp), intent(in) :: b_pol(:,:), c_pol(:,:) !% parameters for Madden short-range dipole moments + integer, intent(in) :: type_of_atomic_num(:) + logical, intent(in) :: tdip_sr + real(dp), intent(out), optional :: e, local_e(:) + real(dp), intent(out), optional :: f(:,:) + real(dp), intent(out), optional :: virial(3,3) + real(dp), intent(out), optional :: efield(:,:) + type(MPI_Context), intent(in), optional :: mpi + character(len=*), optional, intent(in) :: atom_mask_name, source_mask_name + logical, optional, intent(in) :: pseudise + real(dp), optional, intent(in) :: pseudise_sigma(:) + real(dp), optional, intent(in) :: grid_size + integer, intent(out), optional :: error + + integer i, j, m, ti, tj, k + real(dp) :: r_ij, u_ij(3), gamjir3, gamjir2, fc, dfc_dr, de, sigma, dforce(3), erf_val, erf_deriv + real(dp) :: expfactor, dipi(3), dipj(3), qj, qi, pp, pri, prj, defield_i(3), defield_j(3) + real(dp) :: de_ind, de_dd, de_qd, dfqdip(3), dfdipdip(3), factor1, dist3, dist5 + real(dp) :: const1, const2, factork, de_sr, df_sr(3), gij, dgijdrij, bij, cij + logical :: i_is_min_image, j_is_min_image, tpoli, tpolj, qipj, qjpi, pipj, do_pseudise + + real(dp) :: private_virial(3,3), private_e + real(dp), allocatable :: private_f(:,:), private_local_e(:), private_efield(:,:) + logical, pointer, dimension(:) :: atom_mask, source_mask + + real(dp) :: yukcutoff, yukalpha, yuksmoothlength, yukpol(size(pol)) + + INIT_ERROR(error) + call system_timer('yukawa_dipoles') + + ! Unit conversion of arguments from eV/A/fs to atomic units + yukcutoff = cutoff/BOHR + yukalpha = alpha*BOHR + yuksmoothlength = smoothlength/BOHR + yukpol = pol/(BOHR**2/HARTREE) + + do_pseudise = optional_default(.false., pseudise) + if (do_pseudise .and. .not. present(pseudise_sigma)) then + RAISE_ERROR("pseudise=T but pseudise_sigma argument not present", error) + end if + + atom_mask => null() + if (present(atom_mask_name)) then + if (trim(atom_mask_name) /= '') then + call assign_property_pointer(at, atom_mask_name, atom_mask, error) + PASS_ERROR(error) + end if + end if + + source_mask => null() + if (present(source_mask_name)) then + if (trim(source_mask_name) /= '') then + call assign_property_pointer(at, source_mask_name, source_mask, error) + PASS_ERROR(error) + end if + end if + + !$omp parallel default(none) shared(yukcutoff, yukpol, mpi, at, charge, dip, e, local_e, f, virial, efield, type_of_atomic_num, cutoff, yukalpha, yuksmoothlength, pol, b_pol, c_pol, tdip_sr, do_pseudise, atom_mask, source_mask, grid_size, pseudise_sigma) private(i, j, m, ti, tj, k, r_ij, u_ij, gamjir3, gamjir2, fc, dfc_dr, expfactor, dipi, dipj, qj, qi, pp, pri, prj, de_ind, de_dd, de_qd, dfqdip, dfdipdip, factor1, dist3, dist5, const1, const2, factork, de_sr, df_sr, gij, dgijdrij, bij, cij, i_is_min_image, j_is_min_image, tpoli, tpolj, qipj, qjpi, pipj, private_e, private_local_e, private_virial, private_f, private_efield, sigma, erf_val, erf_deriv, de, defield_i, defield_j, dforce) + + if (present(e)) private_e = 0.0_dp + if (present(local_e)) then + allocate(private_local_e(at%N)) + private_local_e = 0.0_dp + endif + if (present(f)) then + allocate(private_f(3,at%N)) + private_f = 0.0_dp + endif + if (present(efield)) then + allocate(private_efield(3,at%N)) + private_efield = 0.0_dp + end if + if (present(virial)) private_virial = 0.0_dp + + !$omp do schedule(runtime) + do i=1, at%n + if (present(mpi)) then + if (mpi%active) then + if (mod(i-1, mpi%n_procs) /= mpi%my_proc) cycle + endif + endif + + if (associated(atom_mask)) then + if (.not. atom_mask(i)) cycle + i_is_min_image = .false. + else + if (allocated(at%connect%is_min_image)) then + i_is_min_image = at%connect%is_min_image(i) + else + i_is_min_image = is_min_image(at, i) + end if + end if + ti = 0 + if (at%Z(i) /= 0) ti = get_type(type_of_atomic_num, at%Z(i)) + + qi = charge(i) + dipi = dip(:,i)/BOHR + tpoli = .false. + if (ti /= 0) tpoli = abs(yukpol(ti)) > 0.0_dp + + ! Induced contribution to energy + if ((present(e) .or. present(local_e)) .and. tpoli) then + de_ind = 0.5_dp*(dipi .dot. dipi)/yukpol(ti) + if (present(e)) private_e = private_e + de_ind + if (present(local_e)) private_local_e(i) = private_local_e(i) + de_ind + end if + + do m = 1, n_neighbours(at, i) + + j = neighbour(at, i, m, distance=r_ij, diff=u_ij, max_dist=cutoff) + if (j <= 0) cycle + + if (associated(source_mask)) then + if (.not. source_mask(j)) cycle + end if + + if (r_ij .feq. 0.0_dp) then + if (present(grid_size)) then + r_ij = grid_size/BOHR + else + cycle + end if + end if + + if (allocated(at%connect%is_min_image)) then + j_is_min_image = at%connect%is_min_image(j) + else + j_is_min_image = is_min_image(at, j) + end if + + if (i < j .and. i_is_min_image .and. j_is_min_image) cycle + + r_ij = r_ij/BOHR + u_ij = u_ij/BOHR + tj = 0 + if (at%Z(j) /= 0) tj = get_type(type_of_atomic_num, at%Z(j)) + + qj = charge(j) + dipj = dip(:,j)/BOHR + tpolj = .false. + if (tj /= 0) tpolj = abs(yukpol(tj)) > 0.0_dp + + qipj = (abs(qi) > 0.0_dp) .and. tpolj + qjpi = (abs(qj) > 0.0_dp) .and. tpoli + pipj = tpoli .and. tpolj + + if (.not. (pipj .or. qipj .or. qjpi)) cycle + + gamjir2 = 1.0_dp/r_ij**2.0_dp + gamjir3 = gamjir2/r_ij + factor1 = 3.0_dp*gamjir2*gamjir3 + + expfactor = exp(-yukalpha*r_ij) + + call smooth_cutoff(r_ij, yukcutoff-yuksmoothlength, yuksmoothlength, fc, dfc_dr) + + pp = 0.0_dp + if (pipj) pp = dipi .dot. dipj + pri = 0.0_dp + if (tpoli) pri = dipi .dot. u_ij + + prj = 0.0_dp + if (tpolj) prj = dipj .dot. u_ij + + if (do_pseudise) then + sigma = pseudise_sigma(tj)/BOHR + erf_val = 1.0_dp + erf_deriv = 0.0_dp + ! pseudise if sigma > 0, correction for r >= 9s is < 1e-16 + if (sigma > 0.0_dp .and. r_ij < 9.0_dp*sigma) then + erf_val = erf(r_ij/(sqrt_2 * sigma)) + erf_deriv = sqrt_2/(sqrt_pi*sigma)*exp(-r_ij*r_ij/(2.0_dp*sigma*sigma)) + end if + end if + + if (present(efield)) then + defield_i = (3.0_dp*prj*u_ij*gamjir2 - dipj)*gamjir2*dsqrt(gamjir2)*expfactor*fc + defield_j = (3.0_dp*pri*u_ij*gamjir2 - dipi)*gamjir2*dsqrt(gamjir2)*expfactor*fc + if (do_pseudise) then + defield_i = defield_i*erf_val + defield_j = defield_j*erf_val + end if + private_efield(:,i) = private_efield(:,i) + defield_i + if (i_is_min_image .and. j_is_min_image) private_efield(:,j) = private_efield(:,j) + defield_j + end if + + if (present(e) .or. present(local_e) .or. present(virial) .or. present(f)) then + + de_dd = (pp - 3.0_dp*pri*prj*gamjir2)*gamjir3 + de_qd = -(qi*prj - qj*pri)*gamjir3 + + de_sr = 0.0_dp + df_sr = 0.0_dp + if (tdip_sr .and. ti /= 0 .and. tj /= 0) then + + bij = b_pol(ti, tj) + cij = c_pol(ti, tj) + + dist3 = 1.0_dp/(r_ij**3.0_dp) + dist5 = 1.0_dp/(r_ij**5.0_dp) + + gij = 0.0_dp + factork = cij*exp(-bij*r_ij) + do k=1,4 + gij = gij + factork + factork = factork*bij*r_ij/float(k) + enddo + gij = gij + factork + dgijdrij = -bij*factork + + const1 = gij*dist3 + const2 = (qj*pri-qi*prj) & + * (r_ij*dgijdrij-3.0_dp*gij)*dist5 + + de_sr = -(qi*prj - qj*pri)*gij*dist3 + + df_sr = ((qj*dipi-qi*dipj)*const1 + u_ij*const2) & + *expfactor*fc & + -de_sr*(yukalpha*fc - dfc_dr)*expfactor/r_ij*u_ij + end if + + de = (de_dd + de_qd + de_sr)*expfactor*fc + if (do_pseudise) de = de*erf_val + + if (present(e)) then + if (i_is_min_image .and. j_is_min_image) then + private_e = private_e + de + else + private_e = private_e + 0.5_dp*de + end if + end if + + if (present(local_e)) then + private_local_e(i) = private_local_e(i) + 0.5_dp*de + if (i_is_min_image .and. j_is_min_image) private_local_e(j) = private_local_e(j) + 0.5_dp*de + end if + + if (present(f) .or. present(virial)) then + dfqdip = .0_dp + if (qipj .or. qjpi) then + dfqdip = ((qj*dipi(:) - qi*dipj(:) & + - 3.0_dp*(qj*pri-qi*prj)*u_ij*gamjir2)*gamjir3)*expfactor*fc & + - de_qd*(yukalpha*fc - dfc_dr)*expfactor/r_ij*u_ij + end if + + dfdipdip = 0.0_dp + if (pipj) then + dfdipdip = (-(pp*u_ij + dipj(:)*pri+dipi(:)*prj & + - 5.0_dp*prj*pri*u_ij(:)*gamjir2)*factor1)*expfactor*fc & + - de_dd*(yukalpha*fc - dfc_dr)*expfactor/r_ij*u_ij(:) + end if + + dforce = dfqdip + dfdipdip + df_sr + if (do_pseudise) dforce = dforce*erf_val + (de_dd + de_qd + de_sr)*expfactor*fc*erf_deriv*u_ij/r_ij + + if (present(f)) then + private_f(:,i) = private_f(:,i) + dforce + if (i_is_min_image .and. j_is_min_image) private_f(:,j) = private_f(:,j) - dforce + end if + + if (present(virial)) then + if (i_is_min_image .and. j_is_min_image) then + private_virial = private_virial - (dforce .outer. u_ij) + else + private_virial = private_virial - 0.5_dp*(dforce .outer. u_ij) + end if + end if + end if + end if + + end do + end do + !$omp end do + + if (present(mpi)) then + if (mpi%active) then + if (present(e)) private_e = sum(mpi, private_e) + if (present(local_e)) call sum_in_place(mpi, private_local_e) + if (present(f)) call sum_in_place(mpi, private_f) + if (present(virial)) call sum_in_place(mpi, private_virial) + if (present(efield)) call sum_in_place(mpi, private_efield) + end if + end if + + !$omp critical + if (present(e)) e = e + private_e*HARTREE + if (present(local_e)) local_e = local_e + private_local_e*HARTREE + if (present(f)) f = f + private_f*(HARTREE/BOHR) + if (present(virial)) virial = virial + private_virial*HARTREE + if (present(efield)) efield = efield + private_efield*(HARTREE/BOHR) + !$omp end critical + + if (allocated(private_f)) deallocate(private_f) + if (allocated(private_local_e)) deallocate(private_local_e) + if (allocated(private_efield)) deallocate(private_efield) + + !$omp end parallel + + call system_timer('yukawa_dipoles') + +end subroutine yukawa_dipoles + +end module Yukawa_module diff --git a/src/Potentials/quip_lammps_wrapper.F90 b/src/Potentials/quip_lammps_wrapper.F90 new file mode 100644 index 0000000000..14c859d0dc --- /dev/null +++ b/src/Potentials/quip_lammps_wrapper.F90 @@ -0,0 +1,199 @@ +module QUIP_LAMMPS_wrapper_module + + use system_module + use linearalgebra_module + use connection_module + use atoms_types_module + use atoms_module + + use potential_module + implicit none + + private + integer, parameter :: API_VERSION = 1 ! Manually increment for each _incompatible_ API change + + public :: quip_lammps_wrapper, quip_lammps_potential_initialise, quip_lammps_api_version + + type quip_lammps_potential + type(Potential), pointer :: pot + endtype quip_lammps_potential + + contains + + function quip_lammps_api_version() bind(c) + use iso_c_binding, only: c_int + integer(kind=c_int) :: quip_lammps_api_version + + quip_lammps_api_version = API_VERSION + end function quip_lammps_api_version + + subroutine quip_lammps_wrapper(nlocal, nghost, atomic_numbers, lmptag, & + inum, sum_num_neigh, ilist, & + quip_num_neigh, quip_neigh, lattice, & + quip_potential, n_quip_potential, quip_x, & + quip_e, quip_local_e, quip_virial, quip_local_virial, quip_force) bind(c) + + use iso_c_binding, only: c_double, c_int + + integer(kind=c_int), intent(in) :: nlocal ! number of local atoms in process + integer(kind=c_int), intent(in) :: nghost ! number of ghost atoms in process + integer(kind=c_int), intent(in) :: inum ! size of ilist, the list of local atoms (should be nlocal in most cases) + integer(kind=c_int), intent(in) :: sum_num_neigh ! number of all neighbours + + integer(kind=c_int), intent(in), dimension(nlocal+nghost) :: atomic_numbers ! list of atomic numbers of all atoms + integer(kind=c_int), intent(in), dimension(nlocal+nghost) :: lmptag ! list of lammps atom ids + integer(kind=c_int), intent(in), dimension(inum) :: ilist ! list of local atoms + integer(kind=c_int), intent(in), dimension(inum) :: quip_num_neigh ! number of neighbours of each local atom + integer(kind=c_int), intent(in), dimension(sum_num_neigh) :: quip_neigh ! list of neighbours of local atoms, packaged + real(kind=c_double), intent(in), dimension(3,3) :: lattice ! lattice parameters + integer(kind=c_int), intent(in), dimension(n_quip_potential) :: quip_potential ! integer array transfering the location of the QUIP potential in the memory + integer(kind=c_int), intent(in) :: n_quip_potential ! size of quip_potential + real(kind=c_double), intent(in), dimension(3,(nlocal+nghost)) :: quip_x ! atomic positions + real(kind=c_double), intent(out) :: quip_e ! energy + real(kind=c_double), intent(out), dimension(nlocal+nghost) :: quip_local_e ! atomic energies + real(kind=c_double), intent(out), dimension(3,3) :: quip_virial ! virial + real(kind=c_double), intent(out), dimension(9,(nlocal+nghost)) :: quip_local_virial ! atomic virials + real(kind=c_double), intent(out), dimension(3,(nlocal+nghost)) :: quip_force ! force + + integer :: i, j, n, nn, ni, i_n1n, j_n2n, error + integer, save :: nn_guess = 0 + type(atoms), save :: at + type(quip_lammps_potential) :: am + type(Potential), pointer :: pot + logical, dimension(:), pointer :: local + real(dp) :: r_ij + + real(dp), parameter :: small_number = 1.0e-10_dp + +#ifdef _MPI + call system_abort("quip_lammps_wrapper: code compiled with MPI. This plugin must be compiled with a serial compiler.") +#endif + + if( n_quip_potential == 0 ) then + call system_abort('quip_lammps_wrapper: quip_potential not initialised') + else + am = transfer(quip_potential,am) + pot => am%pot + endif + + ! if this region is vacuum, don't do anything. + if(nlocal > 0) then + + ! Initialise atoms object. If number of atoms does not change, keep the + ! object. Allocate connection table, be generous with the number of + ! neighbours. + if( .not. is_initialised(at) .or. at%N /= (nlocal+nghost) .or. nn_guess < maxval(quip_num_neigh) ) then + call finalise(at) + call initialise(at,(nlocal+nghost),lattice) + call set_cutoff(at,cutoff(pot)) + nn_guess = 2*maxval(quip_num_neigh) + call connection_fill(at%connect,at%N,at%N,nn_guess=nn_guess) + endif + + ! Transport atomic numbers and positions. + at%Z = atomic_numbers + at%pos = quip_x + + ! Add atom mask to atoms object. Potentials will only include these atoms + ! in the calculation. + call add_property(at,'local',.false.,ptr = local, overwrite=.true., error=error) + + ! And the lammps atom ids, for distinguishability + call add_property(at, 'lmptag', lmptag, overwrite=.true., error=error) + + ! Zero all connections. + do i = 1, at%N + at%connect%neighbour1(i)%t%N = 0 + at%connect%neighbour2(i)%t%N = 0 + enddo + + ! Fill connection table. + nn = 0 + do ni = 1, inum + ! Look up ni-th atom as atom i. + i = ilist(ni) + 1 + ! Set local flag - include in potential calculation. + local(i) = .true. + + i_n1n = 0 + do n = 1, quip_num_neigh(ni) + nn = nn + 1; + j = quip_neigh(nn) + + ! j is atom i's n-th neighbour. Fill the connection table for both i + ! and j at the same time. As LAMMPS repeats periodic images + ! explicitly, shift is set to 0. For the same reason, the lattice + ! variable is not really important, except in calculating the + ! virial. + if( i <= j ) then + i_n1n = i_n1n + 1 + at%connect%neighbour1(i)%t%N = at%connect%neighbour1(i)%t%N + 1 ! Increase size of neighbour list by one + at%connect%neighbour1(i)%t%int(1,i_n1n) = j ! The last neighbour is j + at%connect%neighbour1(i)%t%int(2:4,i_n1n) = 0 ! Set the shift to zero + + r_ij = norm(at%pos(:,i) - at%pos(:,j)) + if( r_ij < small_number ) call system_abort('quip_lammps_wrapper: atoms '//i//' and '//j//' overlap exactly.') + at%connect%neighbour1(i)%t%real(1,i_n1n) = r_ij + + at%connect%neighbour2(j)%t%N = at%connect%neighbour2(j)%t%N + 1 ! Fill the connection for the other atom in the pair. + j_n2n = at%connect%neighbour2(j)%t%N + at%connect%neighbour2(j)%t%int(1,j_n2n) = i + at%connect%neighbour2(j)%t%int(2,j_n2n) = i_n1n + endif + enddo + enddo + + ! Call the QUIP potential. + call calc(pot,at,energy=quip_e,local_energy=quip_local_e,force=quip_force,virial=quip_virial,local_virial=quip_local_virial,args_str="atom_mask_name=local pers_idces_name=lmptag lammps do_calc_connect=F") + else + quip_e = 0.0_dp + quip_local_e = 0.0_dp + quip_virial = 0.0_dp + quip_local_virial = 0.0_dp + quip_force = 0.0_dp + endif + + endsubroutine quip_lammps_wrapper + + subroutine quip_lammps_potential_initialise(quip_potential,n_quip_potential,quip_cutoff,quip_file,n_quip_file,quip_string,n_quip_string) bind(c) + + use iso_c_binding, only: c_double, c_int, c_char + + integer(kind=c_int), intent(out), dimension(n_quip_potential) :: quip_potential + integer(kind=c_int), intent(inout) :: n_quip_potential + real(kind=c_double), intent(out) :: quip_cutoff + character(kind=c_char), intent(in) :: quip_file(n_quip_file) + integer(kind=c_int), intent(in) :: n_quip_file + character(kind=c_char), intent(in) :: quip_string(n_quip_string) + integer(kind=c_int), intent(in) :: n_quip_string + + type(Potential), target, save :: pot + type(quip_lammps_potential) :: am + + integer, dimension(1) :: ammold + +#ifdef _MPI + call system_abort("quip_lammps_wrapper: code compiled with MPI. This plugin must be compiled with a serial compiler.") +#endif + ! In this routine we initialise the QUIP potential and set a pointer to + ! it. The pointer will then be transferred as an integer array to the + ! wrapper. + ! Routine has to be called twice. The integer array used to transfer the + ! pointer will be allocated by LAMMPS. The first call sends the size of + ! the array, and the second call transfers the pointer via the array. + if( n_quip_potential == 0 ) then + call system_initialise(verbosity=PRINT_SILENT) + call Potential_Filename_Initialise(pot, trim(a2s(quip_string)), trim(a2s(quip_file))) + am%pot => pot + n_quip_potential = size(transfer(am,ammold)) + else + am%pot => pot + quip_potential = transfer(am,ammold) + endif + + ! Cutoff returned. + quip_cutoff = cutoff(pot) + + endsubroutine quip_lammps_potential_initialise + +endmodule QUIP_LAMMPS_wrapper_module diff --git a/src/Potentials/quip_unified_wrapper.F90 b/src/Potentials/quip_unified_wrapper.F90 new file mode 100644 index 0000000000..d1e18eec16 --- /dev/null +++ b/src/Potentials/quip_unified_wrapper.F90 @@ -0,0 +1,333 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X Tamas K. Stenczel +! H0 X +! H0 X Copyright 2006-2020. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X quip_wrapper subroutine +!X +!% wrapper to make it nicer for non-QUIP programs to use a QUIP potential +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module quip_unified_wrapper_module + +use system_module, only : dp, print, system_initialise, system_abort, PRINT_ANALYSIS, PRINT_VERBOSE, PRINT_NORMAL, PRINT_SILENT, verbosity_push, & + verbosity_pop, optional_default +use dictionary_module, only : dictionary, STRING_LENGTH +use periodictable_module, only : atomic_number_from_symbol +use mpi_context_module, only : mpi_context, initialise +use atoms_types_module, only : assign_pointer +use atoms_module, only : atoms, initialise, finalise, set_cutoff, calc_connect, set_lattice, get_param_value +use potential_module, only : potential, potential_filename_initialise, calc, cutoff, print, Finalise +implicit none + +contains + +subroutine quip_unified_wrapper(N,pos,frac_pos,lattice,symbol,Z, & + quip_param_file,quip_param_file_len,init_args_str,init_args_str_len,calc_args_str,calc_args_str_len, & + energy,force,virial,do_energy,do_force,do_virial,output_unit,mpi_communicator,reload_pot) + !% Unified wrapper for QUIP potentials + !% + !% Notes: (tks32) + !% - changes in the potential on the fly are picked up only if reload_pot is specified + !% - MPI context cannot be changed on the fly + + use system_module, only: optional_default, print + implicit none + + ! arguments in call order + integer, intent(in) :: N + real(dp), dimension(3,N), intent(in), optional :: pos + real(dp), dimension(3,N), intent(in), optional :: frac_pos + real(dp), dimension(3,3), intent(in), optional :: lattice + character(len=*), dimension(N), intent(in), optional :: symbol + integer, dimension(N), intent(in), optional :: Z + integer, intent(in) :: quip_param_file_len + character(len=quip_param_file_len) :: quip_param_file + integer, intent(in) :: init_args_str_len + character(len=init_args_str_len) :: init_args_str + integer, intent(in) :: calc_args_str_len + character(len=calc_args_str_len) :: calc_args_str + real(dp), intent(out), optional :: energy + real(dp), dimension(3,N), intent(out), optional :: force + real(dp), dimension(3,3), intent(out), optional :: virial + logical, intent(in), optional :: do_energy + logical, intent(in), optional :: do_force + logical, intent(in), optional :: do_virial + integer, intent(in), optional :: output_unit + integer, intent(in), optional :: mpi_communicator + logical, intent(in), optional :: reload_pot ! reloads the potential + + ! internal variables + integer :: i + real(dp), dimension(:,:), pointer :: quip_wrapper_force + character(len=STRING_LENGTH) :: use_calc_args + real(dp) :: use_lattice(3,3) + logical :: use_do_energy, use_do_force, use_do_virial + + ! saved stuff + type(atoms), save :: at + type(Potential), save :: pot + type(MPI_context), save :: mpi_glob + logical, save :: first_run = .true. + + if (present(lattice)) then + use_lattice = lattice + else + use_lattice = 0.0_dp + endif + + if( first_run ) then + call system_initialise(verbosity=PRINT_SILENT,mainlog_unit=output_unit) + call Initialise(mpi_glob,communicator=mpi_communicator) + call Potential_Filename_Initialise(pot, args_str=trim(init_args_str), param_filename=quip_param_file,mpi_obj=mpi_glob) + call verbosity_push(PRINT_NORMAL) + call Print(pot) + call verbosity_pop() + call initialise(at,N,use_lattice) + end if + + if (optional_default(.false., reload_pot)) then + ! deallocate old potential -- this was initialised in first_run + call Finalise(pot) + ! initialise with new parameters + call Potential_Filename_Initialise(pot, args_str=trim(init_args_str), param_filename=quip_param_file,mpi_obj=mpi_glob) + call Print(pot) + endif + + if( .not. first_run .and. (N /= at%N) ) then + call finalise(at) + call initialise(at,N,use_lattice) + endif + + call set_lattice(at,use_lattice, scale_positions=.false.) + + if (present(Z)) then + if (present(symbol)) call system_abort("quip_unified_wrapper got both Z and symbol, don't know which to use") + at%Z = Z + else ! no Z, use symbol + if (.not. present(symbol)) call system_abort("quip_unified_wrapper got neither Z nor symbol") + do i = 1, at%N + at%Z(i) = atomic_number_from_symbol(symbol(i)) + enddo + endif + + if (present(pos)) then + if (present(frac_pos)) call system_abort("quip_unified_wrapper got both pos and frac_pos, don't know which to use") + at%pos = pos + else ! no pos, use frac_pos + if (.not. present(frac_pos)) call system_abort("quip_unified_wrapper got neither pos nor frac_pos") + at%pos = matmul(at%lattice,frac_pos) + endif + + if(at%cutoff > 0) call calc_connect(at) + + use_calc_args = trim(calc_args_str) + use_do_energy = optional_default(present(energy), do_energy) + use_do_force = optional_default(present(force), do_force) + use_do_virial = optional_default(present(virial), do_virial) + if (use_do_energy .and. .not. present(energy)) call system_abort("quip_unified_wrapper got do_energy=.true. but not present(energy)") + if (use_do_force .and. .not. present(force)) call system_abort("quip_unified_wrapper got do_force=.true. but not present(force)") + if (use_do_virial .and. .not. present(virial)) call system_abort("quip_unified_wrapper got do_virial=.true. but not present(virial)") + if(use_do_energy) use_calc_args = trim(use_calc_args)//" energy=quip_wrapper_energy " + if(use_do_force) use_calc_args = trim(use_calc_args)//" force=quip_wrapper_force " + if(use_do_virial) use_calc_args = trim(use_calc_args)//" virial=quip_wrapper_virial " + + call calc(pot,at,args_str=trim(use_calc_args)) + + if(use_do_energy) call get_param_value(at, "quip_wrapper_energy", energy) + if(use_do_virial) call get_param_value(at, "quip_wrapper_virial", virial) + if(use_do_force) then + if(.not. assign_pointer(at,"quip_wrapper_force",quip_wrapper_force) ) call system_abort("Could not calculate forces") + force = quip_wrapper_force + endif + + first_run = .false. + +end subroutine quip_unified_wrapper + +end module quip_unified_wrapper_module + +subroutine quip_wrapper(N,lattice,symbol,pos,args_str,args_str_len,energy,force,virial,do_energy,do_force,do_virial) + + use system_module, only : dp + use quip_unified_wrapper_module + + implicit none + + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + integer, intent(in) :: args_str_len + character(len=args_str_len) :: args_str + real(dp), dimension(3,N), intent(in) :: pos + real(dp), intent(out) :: energy + real(dp), dimension(3,N), intent(out) :: force + real(dp), dimension(3,3), intent(out) :: virial + logical, intent(in) :: do_energy, do_force, do_virial + + call quip_unified_wrapper(N=N,lattice=lattice,symbol=symbol,pos=pos,init_args_str=args_str,init_args_str_len=args_str_len, & + energy=energy,force=force,virial=virial,do_energy=do_energy,do_force=do_force,do_virial=do_virial, & + quip_param_file="quip_params.xml", quip_param_file_len=15, calc_args_str="",calc_args_str_len=0) + + +endsubroutine quip_wrapper + +subroutine quip_wrapper_castep(N,lattice,frac_pos,symbol, & + quip_param_file,quip_param_file_len,init_args_str,init_args_str_len,calc_args_str,calc_args_str_len, & + energy,force,virial,do_energy,do_force,do_virial,output_unit, reload_pot, mpi_communicator, use_mpi) + + !% Castep wrapper for QUIP potentials + !% + !% Notes: (tks32) + !% - added reload_pot optional arg + !% - lattice was intent(inout), made no sense so changed it to intent(in) + !% as it is in the unitied wrapper as well + + use system_module, only : dp + use quip_unified_wrapper_module + + implicit none + + integer, intent(in) :: N + real(dp), dimension(3,N), intent(in) :: frac_pos + real(dp), dimension(3,3), intent(in) :: lattice + character(len=3), dimension(N), intent(in) :: symbol + integer, intent(in) :: quip_param_file_len + character(len=quip_param_file_len), intent(in) :: quip_param_file + integer, intent(in) :: init_args_str_len + character(len=init_args_str_len), intent(in) :: init_args_str + integer, intent(in) :: calc_args_str_len + character(len=calc_args_str_len), intent(in) :: calc_args_str + real(dp), intent(out) :: energy + real(dp), dimension(3,N), intent(out) :: force + real(dp), dimension(3,3), intent(out) :: virial + logical, intent(in) :: do_energy + logical, intent(in) :: do_force + logical, intent(in) :: do_virial + integer, intent(in) :: output_unit + logical, intent(in) :: reload_pot ! reloads the potential + ! we should not have optional arguments, + ! so we get told here if we should use MPI or not + integer, intent(in) :: mpi_communicator + logical, intent(in) :: use_mpi + + if (use_mpi) then + call quip_unified_wrapper(N=N,frac_pos=frac_pos,lattice=lattice,symbol=symbol, & + quip_param_file=quip_param_file, quip_param_file_len=quip_param_file_len, & + init_args_str=init_args_str,init_args_str_len=init_args_str_len, & + calc_args_str=calc_args_str,calc_args_str_len=calc_args_str_len, & + energy=energy,force=force,virial=virial,& + do_energy=do_energy,do_force=do_force,do_virial=do_virial,output_unit=output_unit, & + reload_pot=reload_pot, mpi_communicator=mpi_communicator) + else + call quip_unified_wrapper(N=N,frac_pos=frac_pos,lattice=lattice,symbol=symbol, & + quip_param_file=quip_param_file, quip_param_file_len=quip_param_file_len, & + init_args_str=init_args_str,init_args_str_len=init_args_str_len, & + calc_args_str=calc_args_str,calc_args_str_len=calc_args_str_len, & + energy=energy,force=force,virial=virial,& + do_energy=do_energy,do_force=do_force,do_virial=do_virial,output_unit=output_unit, & + reload_pot=reload_pot) + end if + +endsubroutine quip_wrapper_castep + + +subroutine quip_wrapper_onetep(N, lattice, pos, Z, & + quip_param_file_len, quip_param_file, & + init_args_str_len, init_args_str, & + calc_args_str_len, calc_args_str, & + energy, force, & + do_energy, do_force, & + output_unit, reload_pot) + + !% ONETEP wrapper for QUIP potentials + !% does not interface virials, because onetep does not implement stresses + !% + !% written by T. K. Stenczel, July 2021 + + use system_module, only : dp + use quip_unified_wrapper_module + + implicit none + + integer, intent(in) :: N + real(dp), dimension(3,N), intent(in) :: pos + real(dp), dimension(3,3), intent(in) :: lattice + integer, dimension(N), intent(in) :: Z + integer, intent(in) :: quip_param_file_len + character(len=quip_param_file_len), intent(in) :: quip_param_file + integer, intent(in) :: init_args_str_len + character(len=init_args_str_len), intent(in) :: init_args_str + integer, intent(in) :: calc_args_str_len + character(len=calc_args_str_len), intent(in) :: calc_args_str + real(dp), intent(out) :: energy + real(dp), dimension(3,N), intent(out) :: force + logical, intent(in) :: do_energy + logical, intent(in) :: do_force + integer, intent(in) :: output_unit + logical, intent(in) :: reload_pot ! reloads the potential + + call quip_unified_wrapper(N=N, pos=pos, lattice=lattice, Z=Z, & + quip_param_file=quip_param_file, quip_param_file_len=quip_param_file_len, & + init_args_str=init_args_str, init_args_str_len=init_args_str_len, & + calc_args_str=calc_args_str, calc_args_str_len=calc_args_str_len, & + energy=energy, force=force, & + do_energy=do_energy, do_force=do_force, output_unit=output_unit, & + reload_pot=reload_pot) + + +endsubroutine quip_wrapper_onetep + +subroutine quip_wrapper_simple(N,lattice,Z,pos,energy,force,virial) + + use system_module, only : dp + use quip_unified_wrapper_module + + implicit none + + integer, intent(in) :: N + real(dp), dimension(3,3), intent(inout) :: lattice + integer, dimension(N), intent(in)::Z + real(dp), dimension(3,N), intent(in) :: pos + real(dp), intent(out) :: energy + real(dp), dimension(3,N), intent(out) :: force + real(dp), dimension(3,3), intent(out) :: virial + + + call quip_unified_wrapper(N=N,lattice=lattice,Z=Z,pos=pos,init_args_str="xml_label=default",init_args_str_len=17, & + energy=energy,force=force,virial=virial,do_energy=.true.,do_force=.true.,do_virial=.true., & + quip_param_file="quip_params.xml", quip_param_file_len=15, calc_args_str="",calc_args_str_len=0) + + +endsubroutine quip_wrapper_simple + From 200bf52f5aa7d67faf4e99e20aad9870ed027547 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 18:15:53 +0100 Subject: [PATCH 10/47] renamed source files to have F90 extension --- src/libAtoms/Atoms.F90 | 3546 ++++++++++ src/libAtoms/Atoms_ll.F90 | 391 ++ src/libAtoms/Atoms_types.F90 | 1779 +++++ src/libAtoms/Barostat.F90 | 682 ++ src/libAtoms/CInOutput.F90 | 1090 +++ src/libAtoms/Connection.F90 | 2239 ++++++ src/libAtoms/Constraints.F90 | 1828 +++++ src/libAtoms/Dictionary.F90 | 3198 +++++++++ src/libAtoms/DomainDecomposition.F90 | 1605 +++++ src/libAtoms/DynamicalSystem.F90 | 3287 +++++++++ src/libAtoms/ExtendableStr.F90 | 716 ++ src/libAtoms/Group.F90 | 812 +++ src/libAtoms/LinkedList.F90 | 957 +++ src/libAtoms/MPI_context.F90 | 1834 +++++ src/libAtoms/Matrix.F90 | 1722 +++++ src/libAtoms/ParamReader.F90 | 1061 +++ src/libAtoms/PeriodicTable.F90 | 204 + src/libAtoms/Quaternions.F90 | 782 +++ src/libAtoms/RigidBody.F90 | 885 +++ src/libAtoms/ScaLAPACK.F90 | 1662 +++++ src/libAtoms/SocketTools.F90 | 326 + src/libAtoms/Sparse.F90 | 724 ++ src/libAtoms/Spline.F90 | 463 ++ src/libAtoms/Structures.F90 | 3499 ++++++++++ src/libAtoms/System.F90 | 3779 ++++++++++ src/libAtoms/Table.F90 | 2134 ++++++ src/libAtoms/Thermostat.F90 | 1929 ++++++ src/libAtoms/Topology.F90 | 3462 ++++++++++ src/libAtoms/Units.F90 | 150 + src/libAtoms/angular_functions.F90 | 710 ++ src/libAtoms/clusters.F90 | 4304 ++++++++++++ src/libAtoms/error.F90 | 425 ++ src/libAtoms/f90wrap_stub.F90 | 8 + src/libAtoms/find_surface_atoms.F90 | 333 + src/libAtoms/frametools.F90 | 240 + src/libAtoms/gamma_functions.F90 | 244 + src/libAtoms/histogram1d.F90 | 1991 ++++++ src/libAtoms/histogram2d.F90 | 826 +++ src/libAtoms/k_means_clustering.F90 | 245 + src/libAtoms/kind_module.F90 | 25 + src/libAtoms/libAtoms.F90 | 78 + src/libAtoms/libAtoms_misc_utils.F90 | 56 + src/libAtoms/libAtoms_utils_no_module.F90 | 409 ++ src/libAtoms/linearalgebra.F90 | 7677 +++++++++++++++++++++ src/libAtoms/lobpcg.F90 | 686 ++ src/libAtoms/minimal_md.F90 | 102 + src/libAtoms/minimization.F90 | 6246 +++++++++++++++++ src/libAtoms/nye_tensor.F90 | 310 + src/libAtoms/partition.F90 | 414 ++ src/libAtoms/ringstat.F90 | 469 ++ src/libAtoms/statistics.F90 | 83 + src/libAtoms/steinhardt_nelson_qw.F90 | 243 + src/libAtoms/task_manager.F90 | 358 + src/libAtoms/test_gamma.F90 | 76 + 54 files changed, 73304 insertions(+) create mode 100644 src/libAtoms/Atoms.F90 create mode 100644 src/libAtoms/Atoms_ll.F90 create mode 100644 src/libAtoms/Atoms_types.F90 create mode 100644 src/libAtoms/Barostat.F90 create mode 100644 src/libAtoms/CInOutput.F90 create mode 100644 src/libAtoms/Connection.F90 create mode 100644 src/libAtoms/Constraints.F90 create mode 100644 src/libAtoms/Dictionary.F90 create mode 100644 src/libAtoms/DomainDecomposition.F90 create mode 100644 src/libAtoms/DynamicalSystem.F90 create mode 100644 src/libAtoms/ExtendableStr.F90 create mode 100644 src/libAtoms/Group.F90 create mode 100644 src/libAtoms/LinkedList.F90 create mode 100644 src/libAtoms/MPI_context.F90 create mode 100644 src/libAtoms/Matrix.F90 create mode 100644 src/libAtoms/ParamReader.F90 create mode 100644 src/libAtoms/PeriodicTable.F90 create mode 100644 src/libAtoms/Quaternions.F90 create mode 100644 src/libAtoms/RigidBody.F90 create mode 100644 src/libAtoms/ScaLAPACK.F90 create mode 100644 src/libAtoms/SocketTools.F90 create mode 100644 src/libAtoms/Sparse.F90 create mode 100644 src/libAtoms/Spline.F90 create mode 100644 src/libAtoms/Structures.F90 create mode 100644 src/libAtoms/System.F90 create mode 100644 src/libAtoms/Table.F90 create mode 100644 src/libAtoms/Thermostat.F90 create mode 100644 src/libAtoms/Topology.F90 create mode 100644 src/libAtoms/Units.F90 create mode 100644 src/libAtoms/angular_functions.F90 create mode 100644 src/libAtoms/clusters.F90 create mode 100644 src/libAtoms/error.F90 create mode 100644 src/libAtoms/f90wrap_stub.F90 create mode 100644 src/libAtoms/find_surface_atoms.F90 create mode 100644 src/libAtoms/frametools.F90 create mode 100644 src/libAtoms/gamma_functions.F90 create mode 100644 src/libAtoms/histogram1d.F90 create mode 100644 src/libAtoms/histogram2d.F90 create mode 100644 src/libAtoms/k_means_clustering.F90 create mode 100644 src/libAtoms/kind_module.F90 create mode 100644 src/libAtoms/libAtoms.F90 create mode 100644 src/libAtoms/libAtoms_misc_utils.F90 create mode 100644 src/libAtoms/libAtoms_utils_no_module.F90 create mode 100644 src/libAtoms/linearalgebra.F90 create mode 100644 src/libAtoms/lobpcg.F90 create mode 100644 src/libAtoms/minimal_md.F90 create mode 100644 src/libAtoms/minimization.F90 create mode 100644 src/libAtoms/nye_tensor.F90 create mode 100644 src/libAtoms/partition.F90 create mode 100644 src/libAtoms/ringstat.F90 create mode 100644 src/libAtoms/statistics.F90 create mode 100644 src/libAtoms/steinhardt_nelson_qw.F90 create mode 100644 src/libAtoms/task_manager.F90 create mode 100644 src/libAtoms/test_gamma.F90 diff --git a/src/libAtoms/Atoms.F90 b/src/libAtoms/Atoms.F90 new file mode 100644 index 0000000000..85c0d1b1e5 --- /dev/null +++ b/src/libAtoms/Atoms.F90 @@ -0,0 +1,3546 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Atoms module +!X +!% An atoms object contains atomic numbers, all dynamical variables +!% and connectivity information for all the atoms in the simulation cell. +!% It is initialised like this: +!%> call initialise(MyAtoms,N,lattice) +!% where 'N' is the number of atoms to allocate space for and 'lattice' is a $3\times3$ +!% matrix of lattice vectors given as column vectors, so that lattice(:,i) is the i-th lattice vector. +!% +!% Atoms also contains a Connection object, which stores distance information about +!% the atom neighbours after 'calc_connect' has been called. Rather than using a minimum +!% image convention, all neighbours are stored up to a radius of 'cutoff', including images. +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module atoms_module + + use error_module + use system_module + use units_module + use mpi_context_module + use linearalgebra_module + use extendable_str_module + use dictionary_module + use table_module + use paramreader_module + use periodictable_module + use Atoms_types_module + use Connection_module + use DomainDecomposition_module + use minimization_module + use Quaternions_module + + implicit none + private + public :: atoms, initialise, initialise_ptr, is_initialised, is_domain_decomposed, shallowcopy, finalise + public :: finalise_ptr, zero, assignment(=), deepcopy, set_cutoff_minimum, set_cutoff + public :: add_atoms, remove_atoms, get_param_value, set_param_value, has_property, remove_property + public :: print, set_lattice, select, cell_volume, map_into_cell, unskew_cell + public :: bcast, copy_properties, transform_basis, rotate, index_to_z_index, z_index_to_index + public :: calc_connect, calc_connect_hysteretic, is_min_image, set_comm_property, set_Zs, sort + public :: shuffle, n_neighbours, neighbour, centre_of_mass, atoms_copy_without_connect + public :: calc_dists, atoms_repoint, is_nearest_neighbour, is_nearest_neighbour_abs_index + public :: termination_bond_rescale, make_lattice, neighbour_index, cosine, cosine_neighbour, direction_cosines + public :: directionality, closest_atom, set_atoms, get_lattice_params, list_matching_prop + public :: coalesce_in_one_periodic_image, prop_names_string, parse_atom_mask, complement + public :: direction_cosines_min_image, difference, set_map_shift + public :: undo_pbc_jumps, undo_com_motion, calc_msd, fake_smooth_pos + + integer, parameter :: NOT_NEIGHBOUR = 0 !% Returned by 'Find_Neighbour' if unsuccessful + + logical :: printed_stack_warning = .false. !% OMIT + + real(dp), allocatable, target, private, save :: save_prev_pos(:,:), save_orig_pos(:,:), save_smooth_pos(:,:) + real(dp) :: save_smooth_lattice(3,3) + real(dp), allocatable, private, save :: save_orig_CoM(:) + + private :: ess_max_len + + private :: atoms_initialise + interface initialise + module procedure atoms_initialise + end interface initialise + + !% Initialise type(Atoms), pointer objects. Shallow copies of these will + !% survive even if the initial declaration goes out of scope. The object will + !% automatically deallocate upon calling finalise_ptr when the last shallow + !% copy goes out of scope + private :: atoms_initialise_ptr + interface initialise_ptr + module procedure atoms_initialise_ptr + endinterface initialise_ptr + + private :: atoms_is_initialised + interface is_initialised + module procedure atoms_is_initialised + end interface is_initialised + + private :: atoms_is_domain_decomposed + interface is_domain_decomposed + module procedure atoms_is_domain_decomposed + endinterface is_domain_decomposed + + private :: atoms_shallowcopy + interface shallowcopy + module procedure atoms_shallowcopy + end interface shallowcopy + + !% Free up the memory associated with one or more objects. + private :: atoms_finalise,atoms_finalise_multi + interface finalise + module procedure atoms_finalise, atoms_finalise_multi + end interface finalise + + !% Finalise type(Atoms), pointer objects. Shallow copies of these will + !% The object will when ref_count == 0. + private :: atoms_finalise_ptr + interface finalise_ptr + module procedure atoms_finalise_ptr + endinterface finalise_ptr + + private :: atoms_zero + interface zero + module procedure atoms_zero + end interface + + !% Overloaded assigment operators for Atoms objects. + private :: atoms_assignment + interface assignment(=) + module procedure atoms_assignment + end interface assignment(=) + interface deepcopy + module procedure atoms_assignment + endinterface + + private :: atoms_set_atoms, atoms_set_atoms_singlez + + !% Set atomic numbers (in the 'z' integer property), species names + !% (in 'species' string property) and optionally masses (if 'mass' + !% property exists in the Atoms object). + interface set_atoms + module procedure atoms_set_atoms, atoms_set_atoms_singlez + end interface + + !% increase cutoff + private :: atoms_set_cutoff_minimum + interface set_cutoff_minimum + module procedure atoms_set_cutoff_minimum + end interface + + !% set a uniform cutoff + private :: atoms_set_cutoff + interface set_cutoff + module procedure atoms_set_cutoff + end interface + + !% Add one or more atoms to an Atoms object. + !% To add a single atom, 'pos' should be an array of size 3 and 'z a + !% single integer. To add multiple atoms either arrays of length + !% 'n_new' should be passed, or another Atoms from which to copy data + !% should be given as the 'from' argument. + private :: add_atom_single, add_atom_multiple, atoms_join + interface add_atoms + module procedure add_atom_single, add_atom_multiple, atoms_join + end interface add_atoms + + !% Remove one or more atoms from an Atoms object. + private :: remove_atom_single, remove_atom_multiple + interface remove_atoms + module procedure remove_atom_single, remove_atom_multiple + module procedure remove_atom_multiple_mask + end interface remove_atoms + + !% get a (per-configuration) value from the atoms%params dictionary + private :: atoms_get_param_value_int, atoms_get_param_value_int_a + private :: atoms_get_param_value_real, atoms_get_param_value_real_a, atoms_get_param_value_real_a2 + private :: atoms_get_param_value_str, atoms_get_param_value_es + private :: atoms_get_param_value_logical + interface get_param_value + module procedure atoms_get_param_value_int, atoms_get_param_value_int_a + module procedure atoms_get_param_value_real, atoms_get_param_value_real_a, atoms_get_param_value_real_a2 + module procedure atoms_get_param_value_str, atoms_get_param_value_es + module procedure atoms_get_param_value_logical + end interface get_param_value + + !% set a (per-configuration) value from the atoms%params dictionary + private :: atoms_set_param_value_int, atoms_set_param_value_int_a + private :: atoms_set_param_value_real, atoms_set_param_value_real_a, atoms_set_param_value_real_a2 + private :: atoms_set_param_value_str + private :: atoms_set_param_value_logical + interface set_param_value + module procedure atoms_set_param_value_int, atoms_set_param_value_int_a + module procedure atoms_set_param_value_real, atoms_set_param_value_real_a, atoms_set_param_value_real_a2 + module procedure atoms_set_param_value_str + module procedure atoms_set_param_value_logical + end interface set_param_value + + !% Convenience function to test if a property is present. No checking + !% of property type is done. Property names are case-insensitive. + private :: atoms_has_property + interface has_property + module procedure atoms_has_property + end interface + + !% Remove a property from this atoms object + private :: atoms_remove_property + interface remove_property + module procedure atoms_remove_property + end interface + + !% Print a verbose textual description of an Atoms object to the default logger or to + !% a specificied Inoutput object. + private :: atoms_print + interface print + module procedure atoms_print + end interface print + + !% set the lattice of an atoms object - please use this, rather than setting atoms%lattice + !% directly, because it also set up reciprocal lattice and orthorhombic/periodic logical flags + private :: atoms_set_lattice + interface set_lattice + module procedure atoms_set_lattice + end interface set_lattice + + !% Select a subset of the atoms in an atoms object, either using a logical + !% mask array or a Table, in which case the first 'int' column is taken to + !% be a list of the atoms that should be retained. + private :: atoms_select + interface select + module procedure atoms_select + end interface select + + !% calculate volume of unit cell + private :: atoms_cell_volume + interface cell_volume + module procedure atoms_cell_volume + end interface + + private :: atoms_map_into_cell + !% Map atomic positions into the unit cell so that lattice + !% coordinates satisfy $-0.5 \le t_x,t_y,t_z < 0.5$ + interface map_into_cell + module procedure atoms_map_into_cell + end interface + + private :: atoms_unskew_cell + !% Unskew lattice so the cosines of the lattice angles fall between + !% $-0.5$ and $0.5$ + interface unskew_cell + module procedure atoms_unskew_cell + end interface + + private :: atoms_bcast + interface bcast + module procedure atoms_bcast + end interface + + private :: atoms_copy_properties + interface copy_properties + module procedure atoms_copy_properties + endinterface copy_properties + + private :: atoms_transform_basis + interface transform_basis + module procedure atoms_transform_basis + end interface transform_basis + + private :: atoms_rotate + interface rotate + module procedure atoms_rotate + end interface rotate + + private :: atoms_index_to_z_index + interface index_to_z_index + module procedure atoms_index_to_z_index + end interface index_to_z_index + + private :: atoms_z_index_to_index + interface z_index_to_index + module procedure atoms_z_index_to_index + end interface z_index_to_index + + private :: atoms_calc_connect + interface calc_connect + module procedure atoms_calc_connect + endinterface + + private :: atoms_calc_dists + interface calc_dists + module procedure atoms_calc_dists + end interface calc_dists + + private :: atoms_calc_connect_hysteretic + interface calc_connect_hysteretic + module procedure atoms_calc_connect_hysteretic + endinterface + + private :: atoms_is_min_image + interface is_min_image + module procedure atoms_is_min_image + endinterface + + private :: atoms_set_comm_property + interface set_comm_property + module procedure atoms_set_comm_property + endinterface set_comm_property + + private :: atoms_set_Zs + interface set_Zs + module procedure atoms_set_Zs + endinterface + + private :: atoms_sort_by_rindex + interface sort + module procedure atoms_sort, atoms_sort_by_rindex + endinterface + + private :: atoms_shuffle + interface shuffle + module procedure atoms_shuffle + endinterface + + !% Neighbour list stuff + interface n_neighbours + module procedure atoms_n_neighbours + endinterface + + !% Neighbour list stuff + interface neighbour_index + module procedure atoms_neighbour_index + endinterface + + interface neighbour + module procedure atoms_neighbour + endinterface + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Initialisation and Finalisation + ! + ! N : number of atoms + ! lattice: 3x3 matrix of lattice vectors as column vectors + ! data: optional initial values for data table + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Initialise an Atoms object to store 'N' atoms and specify the initial lattice. + subroutine atoms_initialise(this,N,lattice,& + properties,params,fixed_size,Nbuffer,error) + + type(Atoms), intent(inout) :: this + integer, intent(in) :: N + real(dp), dimension(3,3), intent(in) :: lattice + type(Dictionary), optional, intent(in) :: properties, params + logical, optional, intent(in) :: fixed_size + integer, optional, intent(in) :: Nbuffer + integer, optional, intent(out) :: error + + integer :: stack_size, stack_size_err, i, type + + INIT_ERROR(error) + !call atoms_finalise(this) + + if (present(params)) then + this%params = params ! deep copy + else + call initialise(this%params) + end if + + call initialise(this%domain, error=error) + PASS_ERROR(error) + + this%N = N + this%Ndomain = N + this%Nbuffer = N + + if (present(Nbuffer)) this%Nbuffer = Nbuffer + + this%fixed_size = optional_default(.false., fixed_size) + + if (present(properties)) then + ! check types and sizes of properties passed in + do i=1,properties%N + type = properties%entries(i)%type + if (type == T_INTEGER_A .or. type == T_REAL_A .or. type == T_LOGICAL_A) then + if (properties%entries(i)%len /= this%Nbuffer) then + RAISE_ERROR('atoms_initialise: bad array size for array key='//string(properties%keys(i))//' size('//properties%entries(i)%len//') != this%Nbuffer('//this%Nbuffer//')', error) + end if + else if (type == T_INTEGER_A2 .or. type == T_REAL_A2 .or. type == T_CHAR_A) then + if (properties%entries(i)%len2(2) /= this%Nbuffer) then + RAISE_ERROR('atoms_initialise: bad array size for array key='//properties%keys(i)//' shape='//properties%entries(i)%len2, error) + end if + else + RAISE_ERROR('atoms_initialise: bad property type='//type//' in properties argument', error) + end if + end do + + this%properties = properties ! deep copy of data from properties argument + else + ! By default, we just add properties for Z, species name and position + call initialise(this%properties) + + call add_property(this, 'Z', 0, error=error) + PASS_ERROR(error) + call add_property(this, 'pos', 0.0_dp, n_cols=3, error=error) + PASS_ERROR(error) + call add_property(this, 'species', repeat(' ', TABLE_STRING_LENGTH), & + error=error) + PASS_ERROR(error) + end if + + call set_comm_property(this, 'Z', & + comm_atoms=.true., comm_ghosts=.true.) + call set_comm_property(this, 'pos', & + comm_atoms=.true., comm_ghosts=.true.) + call set_comm_property(this, 'species', & + comm_atoms=.true.) + + call atoms_repoint(this) + + stack_size = 3*N*8/1024 + if (stack_size > 4000 .and. .not. printed_stack_warning) then + call print('Atoms_Initialise: Stack size must be at least '//stack_size//& + ' kb, or we get seg faults when functions return arrays.') + printed_stack_warning = .true. + call print('Atoms_Initialise: trying to increase stack limit') + stack_size = int(stack_size/1024)*1024 + stack_size_err = increase_stack(stack_size) + if (stack_size_err /= 0) then + call print("Atoms_Initialise: error calling increase_stack err = "// stack_size_err) + endif + end if + + call atoms_set_lattice(this, lattice, .false.) + + this%ref_count = 1 + + call print("atoms_initialise: Initialised, " // & + "ref_count = " // this%ref_count, PRINT_ANALYSIS) + + end subroutine atoms_initialise + + + subroutine atoms_initialise_ptr(this,N,lattice,& + properties,params,fixed_size,Nbuffer,error) + type(Atoms), pointer :: this + integer, intent(in) :: N + real(dp), dimension(3,3), intent(in) :: lattice + type(Dictionary), optional, intent(in) :: properties, params + logical, optional, intent(in) :: fixed_size + integer, optional, intent(in) :: Nbuffer + integer, optional, intent(out) :: error + + ! --- + + INIT_ERROR(error) + + if (associated(this)) then + this%own_this = .false. + else + allocate(this) + this%own_this = .true. + endif + + call initialise(this, N, lattice, properties, params, fixed_size, & + Nbuffer, error) + PASS_ERROR(error) + + endsubroutine atoms_initialise_ptr + + + !% Is this atoms object initialised? + logical function atoms_is_initialised(this) + type(Atoms), intent(in) :: this + atoms_is_initialised = this%ref_count > 0 + end function atoms_is_initialised + + + !% Is this atoms object domain decomposed? + logical function atoms_is_domain_decomposed(this) + type(Atoms), intent(in) :: this + atoms_is_domain_decomposed = this%domain%decomposed + end function atoms_is_domain_decomposed + + + !% Shallow copy of this Atoms object + subroutine atoms_shallowcopy(this, from) + !NB gfortran 4.3.4 seg faults if this is intent(out) + !NB type(Atoms), pointer, intent(out) :: this + type(Atoms), pointer :: this + !NB + type(Atoms), target :: from + + ! --- + + this => from + this%ref_count = this%ref_count + 1 + + call print("atoms_shallowcopy: Created shallow copy, " // & + "ref_count = " // this%ref_count, PRINT_ANALYSIS) + + end subroutine atoms_shallowcopy + + + subroutine atoms_finalise(this) + type(Atoms), intent(inout) :: this + + this%ref_count = this%ref_count - 1 + ! Note: this has to be == 0, rather than <= 0. Otherwise it will fail if + ! finalise is called more than once + if (this%ref_count == 0) then + + call print("atoms_finalise: ref_count = 0, finalising", PRINT_ANALYSIS) + + call finalise(this%domain) + + call finalise(this%properties) + call finalise(this%params) + + ! Nullify pointers + nullify(this%Z, this%travel, this%mass) + nullify(this%move_mask, this%thermostat_region, this%damp_mask) + nullify(this%pos, this%velo, this%acc, this%avgpos, this%oldpos, this%avg_ke) + + call finalise(this%connect) + call finalise(this%hysteretic_connect) + + this%N = 0 + this%Ndomain = 0 + this%Nbuffer = 0 + + else + if (this%ref_count > 0) then + call print("atoms_finalise: Not yet finalising, " // & + "ref_count = " // this%ref_count, PRINT_ANALYSIS) + endif + endif + + call print("atoms_finalise: ref_count = " // this%ref_count, PRINT_ANALYSIS) + + end subroutine atoms_finalise + + + subroutine atoms_finalise_ptr(this) + type(Atoms), pointer :: this + + ! --- + + call finalise(this) + if (this%own_this .and. this%ref_count == 0) then + deallocate(this) + this => NULL() + endif + + endsubroutine atoms_finalise_ptr + + !Quick multiple finalisations + subroutine atoms_finalise_multi(at1,at2,at3,at4,at5,at6,at7,at8,at9,at10) + type(Atoms), intent(inout) :: at1,at2 + type(Atoms), optional, intent(inout) :: at3,at4,at5,at6,at7,at8,at9,at10 + call atoms_finalise(at1) + call atoms_finalise(at2) + if (present(at3)) call atoms_finalise(at3) + if (present(at4)) call atoms_finalise(at4) + if (present(at5)) call atoms_finalise(at5) + if (present(at6)) call atoms_finalise(at6) + if (present(at7)) call atoms_finalise(at7) + if (present(at8)) call atoms_finalise(at8) + if (present(at9)) call atoms_finalise(at9) + if (present(at10)) call atoms_finalise(at10) + end subroutine atoms_finalise_multi + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Overloaded Assignment + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_assignment(to,from) + + type(Atoms), intent(inout) :: to + type(Atoms), intent(in) :: from + + ! We do not fail if *from* is unitialised, since overloaded operator + ! routines are outside scope of error handling mechanism. + if(.not. is_initialised(from)) then + call finalise(to) +! to%ref_count = 0 + return + end if + + call atoms_initialise(to, from%N, from%lattice, from%properties, from%params, from%fixed_size, from%Nbuffer) + + to%cutoff = from%cutoff + to%cutoff_skin = from%cutoff_skin + to%nneightol = from%nneightol + to%is_orthorhombic = from%is_orthorhombic + to%is_periodic = from%is_periodic + to%fixed_size = from%fixed_size + + call deepcopy(to%connect, from%connect) + call deepcopy(to%hysteretic_connect, from%hysteretic_connect) + call deepcopy(to%domain, from%domain) + + end subroutine atoms_assignment + + + pure function ess_max_len(ess) + type(extendable_str), intent(in) :: ess(:) + integer :: ess_max_len + + integer :: i + + ess_max_len = 0 + do i=1, size(ess) + if (ess(i)%len > ess_max_len) ess_max_len = ess(i)%len + end do + end function ess_max_len + + !% Make a copy of the atoms object 'from' without including + !% connectivity information. Useful for saving the state of a + !% dynamical simulation without incurring too great a memory + !% cost. + subroutine atoms_copy_without_connect(to, from, properties, properties_array, error) + + type(Atoms), intent(inout) :: to + type(Atoms), intent(in) :: from + character(len=*), optional, intent(in) :: properties + character(len=*), optional, intent(in) :: properties_array(:) + integer, intent(out), optional :: error + character(len=ess_max_len(from%properties%keys)) :: tmp_properties_array(from%properties%n) + integer n_properties + + INIT_ERROR(error) + ASSERT(is_initialised(from), "atoms_copy_without_connect: 'from' object is not initialised", error) + + to%N = from%N + to%Nbuffer = from%Nbuffer + to%Ndomain = from%Ndomain + call set_lattice(to, from%lattice, .false.) + + if (present(properties) .or. present(properties_array)) then + if (present(properties_array)) then + call subset(from%properties, properties_array, to%properties, error=error) + PASS_ERROR(error) + else + call parse_string(properties, ':', tmp_properties_array, n_properties, error=error) + PASS_ERROR(error) + call subset(from%properties, tmp_properties_array(1:n_properties), to%properties, error=error) + PASS_ERROR(error) + end if + else + call deepcopy(to%properties, from%properties, error=error) + PASS_ERROR(error) + endif + to%params = from%params + to%fixed_size = from%fixed_size + to%cutoff = from%cutoff + to%cutoff_skin = from%cutoff_skin + to%nneightol = from%nneightol + to%is_orthorhombic = from%is_orthorhombic + to%is_periodic = from%is_periodic + to%fixed_size = from%fixed_size + + call deepcopy(to%domain, from%domain) + + call atoms_repoint(to) + to%ref_count = 1 + + end subroutine atoms_copy_without_connect + + subroutine atoms_select(to, from, mask, list, orig_index, error) + type(Atoms), intent(inout) :: to + type(Atoms), intent(in) :: from + logical, intent(in), optional :: mask(:) + integer, intent(in), optional, target :: list(:) + logical, optional, intent(in) :: orig_index + integer, intent(out), optional :: error + + integer :: i, n_list + integer, allocatable, dimension(:), target :: my_list + integer, pointer, dimension(:) :: orig_index_ptr, use_list + logical :: do_orig_index + + INIT_ERROR(error) + + do_orig_index = optional_default(.true., orig_index) + + if ((.not. present(list) .and. .not. present(mask)) .or. (present(list) .and. present(mask))) then + RAISE_ERROR('atoms_select: either list or mask must be present (but not both)', error) + end if + + if (present(mask)) then + if (size(mask) /= from%N) then + RAISE_ERROR("atoms_select: mismatched sizes of from " // from%N // " and mask " // size(mask), error) + end if + call atoms_initialise(to, count(mask), from%lattice) + else + call atoms_initialise(to, size(list), from%lattice) + end if + + call finalise(to%params) + to%params = from%params + to%fixed_size = from%fixed_size + to%cutoff = from%cutoff + to%cutoff_skin = from%cutoff_skin + to%nneightol = from%nneightol + + if(present(mask)) then + allocate(my_list(count(mask))) + ! build up a list + N_list = 1 + do i=1, from%N + if (mask(i)) then + my_list(n_list) = i + n_list = n_list + 1 + endif + end do + use_list => my_list + else + use_list => list + end if + + do i=1,from%properties%N + select case (from%properties%entries(i)%type) + + case(T_INTEGER_A) + call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%i_a(use_list)) + + case(T_REAL_A) + call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%r_a(use_list)) + + case(T_LOGICAL_A) + call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%l_a(use_list)) + + case(T_INTEGER_A2) + call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%i_a2(:,use_list)) + + case(T_REAL_A2) + call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%r_a2(:,use_list)) + + case(T_CHAR_A) + call set_value(to%properties, string(from%properties%keys(i)), from%properties%entries(i)%s_a(:,use_list)) + + case default + RAISE_ERROR('atoms_select: bad property type '//from%properties%entries(i)%type//' key='//from%properties%keys(i), error) + + end select + end do + call atoms_repoint(to) + + if (do_orig_index) then + call add_property(to, 'orig_index', 0, ptr=orig_index_ptr, error=error) + PASS_ERROR(error) + orig_index_ptr(:) = use_list(:) + end if + if (allocated(my_list)) deallocate(my_list) + + call atoms_repoint(to) + end subroutine atoms_select + + subroutine atoms_remove_property(this, name, error) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if (.not. has_property(this, name)) then + RAISE_ERROR('atoms_remove_property: no such property "'//trim(name)//'" exists', error) + end if + call remove_value(this%properties, name) + + end subroutine atoms_remove_property + + function atoms_has_property(this, name) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + logical :: atoms_has_property + + atoms_has_property = has_key(this%properties, name) + + end function atoms_has_property + + subroutine atoms_set_param_value_int(this, key, value) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value + + call set_value(this%params, key, value) + end subroutine atoms_set_param_value_int + subroutine atoms_set_param_value_int_a(this, key, value) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value(:) + + call set_value(this%params, key, value) + end subroutine atoms_set_param_value_int_a + subroutine atoms_set_param_value_real(this, key, value) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value + + call set_value(this%params, key, value) + end subroutine atoms_set_param_value_real + subroutine atoms_set_param_value_real_a(this, key, value) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value(:) + + call set_value(this%params, key, value) + end subroutine atoms_set_param_value_real_a + subroutine atoms_set_param_value_real_a2(this, key, value) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value(:,:) + + call set_value(this%params, key, value) + end subroutine atoms_set_param_value_real_a2 + subroutine atoms_set_param_value_logical(this, key, value) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: key + logical, intent(in) :: value + + call set_value(this%params, key, value) + end subroutine atoms_set_param_value_logical + + subroutine atoms_set_param_value_str(this, key, value) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + + call set_value(this%params, key, value) + end subroutine atoms_set_param_value_str + + subroutine atoms_get_param_value_int(this, key, value, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: key + integer, intent(out) :: value + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. get_value(this%params, key, value)) then + RAISE_ERROR("atoms_get_param_value failed to get int value for key='"//trim(key)//"' from this%params", error) + endif + end subroutine atoms_get_param_value_int + subroutine atoms_get_param_value_int_a(this, key, value, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: key + integer, intent(out) :: value(:) + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. get_value(this%params, key, value)) then + RAISE_ERROR("atoms_get_param_value failed to get int array value for key='"//trim(key)//"' from this%params", error) + endif + end subroutine atoms_get_param_value_int_a + subroutine atoms_get_param_value_real(this, key, value, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: key + real(dp), intent(out) :: value + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. get_value(this%params, key, value)) then + call verbosity_push(PRINT_ANALYSIS) + call print(this) + RAISE_ERROR("atoms_get_param_value failed to get real value for key='"//trim(key)//"' from this%params", error) + endif + end subroutine atoms_get_param_value_real + subroutine atoms_get_param_value_real_a(this, key, value, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: key + real(dp), intent(out) :: value(:) + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. get_value(this%params, key, value)) then + RAISE_ERROR("atoms_get_param_value failed to get real array value for key='"//trim(key)//"' from this%params", error) + endif + end subroutine atoms_get_param_value_real_a + subroutine atoms_get_param_value_real_a2(this, key, value, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: key + real(dp), intent(out) :: value(:,:) + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. get_value(this%params, key, value)) then + RAISE_ERROR("atoms_get_param_value failed to get real array value for key='"//trim(key)//"' from this%params", error) + endif + end subroutine atoms_get_param_value_real_a2 + subroutine atoms_get_param_value_str(this, key, value, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: key + character(STRING_LENGTH), intent(out) :: value + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. get_value(this%params, key, value)) then + RAISE_ERROR("atoms_get_param_value failed to get str value for key='"//trim(key)//"' from this%params", error) + endif + end subroutine atoms_get_param_value_str + subroutine atoms_get_param_value_es(this, key, value, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: key + type(Extendable_Str), intent(inout) :: value + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. get_value(this%params, key, value)) then + RAISE_ERROR("atoms_get_param_value failed to get es value for key='"//trim(key)//"' from this%params", error) + endif + end subroutine atoms_get_param_value_es + subroutine atoms_get_param_value_logical(this, key, value, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: key + logical, intent(out) :: value + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. get_value(this%params, key, value)) then + RAISE_ERROR("atoms_get_param_value failed to get logical value for key='"//trim(key)//"' from this%params", error) + endif + end subroutine atoms_get_param_value_logical + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Set the cutoff to at least the requested value + !% Optionally set 'cutoff_skin' at the same time. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_set_cutoff_minimum(this, cutoff, cutoff_skin) + type(Atoms), intent(inout) :: this + real(dp), intent(in) :: cutoff + real(dp), optional, intent(in) :: cutoff_skin + + this%cutoff = max(this%cutoff, cutoff) + this%cutoff_skin = max(this%cutoff_skin, cutoff_skin) + + end subroutine atoms_set_cutoff_minimum + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Specify a uniform neighbour cutoff throughout the system. + !% Optionally set 'cutoff_skin' at the same time. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_set_cutoff(this, cutoff, cutoff_skin) + type(Atoms), intent(inout) :: this + real(dp), intent(in) :: cutoff + real(dp), optional, intent(in) :: cutoff_skin + + this%cutoff = cutoff + if (present(cutoff_skin)) then + this%cutoff_skin = cutoff_skin + end if + + end subroutine atoms_set_cutoff + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Zero data in an Atoms structure --- + !% this doesn\'t finalise it or change it\'s size. We zero 'this%pos', + !% 'this%Z' and 'this%species'. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_zero(this,indices) + + type(Atoms), intent(inout) :: this + integer, optional, intent(in) :: indices !% Optionally only zero the specified indices. + + if(present(indices)) then + this%pos(:,indices) = 0.0_dp + this%Z(indices) = 0 + this%species(:,indices) = ' ' + else + this%pos = 0.0_dp + this%Z = 0 + this%species = ' ' + end if + + end subroutine atoms_zero + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Change the lattice vectors, keeping the inverse lattice vectors + !% up to date. Optionally map the existing atoms into the new cell + !% and recalculate connectivity. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_set_lattice(this,new_lattice,scale_positions,remap,reconnect) + + type(Atoms), intent(inout) :: this + real(dp), dimension(3,3), intent(in) :: new_lattice + logical, intent(in) :: scale_positions + logical, optional, intent(in) :: remap, reconnect + real(dp), dimension(:,:), allocatable :: frac + real(dp) :: zeros(3,3), test_lattice(3,3), x, y + + ! only do the allocation if needed + if(scale_positions) then + allocate(frac(3,this%N)) + frac = matmul(this%g,this%pos) + end if + + this%lattice = new_lattice + + if(scale_positions) then + this%pos = matmul(this%lattice,frac) + deallocate(frac) + end if + + call matrix3x3_inverse(this%lattice,this%g) + + if (present(reconnect)) then + if (reconnect) then + call calc_connect(this) + return + end if + end if + + if (present(remap)) then + if (remap) call set_map_shift(this) + end if + + zeros(:,:) = 0.0_dp + test_lattice = this%lattice + test_lattice(1,1) = 0.0_dp ! zero diagonal elements + test_lattice(2,2) = 0.0_dp + test_lattice(3,3) = 0.0_dp + this%is_orthorhombic = test_lattice .feq. zeros + + !write (*,*) x, y, (abs(x-y) <= NUMERICAL_ZERO * (abs(x)+abs(y))/2.0_dp) .or. (abs(x-y) <= NUMERICAL_ZERO), x .feq. y, TINY(1.0_dp) + + test_lattice = 0.0_dp + test_lattice(:,1) = this%lattice(:,1) + this%is_periodic(1) = test_lattice .fne. zeros + + test_lattice = 0.0_dp + test_lattice(:,2) = this%lattice(:,2) + this%is_periodic(2) = test_lattice .fne. zeros + + test_lattice = 0.0_dp + test_lattice(:,3) = this%lattice(:,3) + this%is_periodic(3) = test_lattice .fne. zeros + + end subroutine atoms_set_lattice + + subroutine atoms_set_atoms_singlez(this, Z) + type(Atoms), intent(inout) :: this + integer, intent(in) :: Z + integer, allocatable, dimension(:) :: Zarray + + allocate(Zarray(this%N)) + Zarray = Z + call atoms_set_atoms(this, Zarray) + deallocate(Zarray) + end subroutine atoms_set_atoms_singlez + + !% Set atomic numbers and optionally masses (if mass property is present) + !% If 'mass' is not specified then 'ElementMass(Z)' is used. + subroutine atoms_set_atoms(this, Z, mass) + type(Atoms), intent(inout) :: this + integer, dimension(:), intent(in) :: Z + real(dp), optional, dimension(:), intent(in) :: mass + + integer i + + this%Z = Z + if (has_property(this, 'mass')) then + this%mass = ElementMass(Z) + ! Optionally override with user specified masses + if (present(mass)) this%mass = mass + end if + if (has_property(this, 'species')) then + do i=1,this%N + this%species(:,i) = ' ' + this%species(1:len(ElementName(Z(i))),i) = s2a(ElementName(Z(i))) + end do + end if + + end subroutine atoms_set_atoms + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Simple query functions + ! + !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + + !% Return the number of neighbour that atom 'i' has. If the + !% optional arguments max_dist or max_factor are present then only + !% neighbours closer than this cutoff are included. Do not use + !% 'max_dist' when iterating only over neighbours within a certain + !% distance; instead, iterate over the full list and discard + !% unnecessary neighbours in 'atoms_neighbour'. + !% + !% 'alt_connect' + !% can be set to another Connection object to use alternative + !% connectivity information, for example 'hysteretic_connect'. + function atoms_n_neighbours(this, i, max_dist, max_factor, alt_connect, error) result(n) + type(Atoms), intent(in) :: this + integer, intent(in) :: i + real(dp), optional, intent(in) :: max_dist, max_factor + type(Connection), optional, intent(in), target :: alt_connect + integer, intent(out), optional :: error + integer :: n + + INIT_ERROR(error) + if (present(alt_connect)) then + n = n_neighbours(alt_connect, this, i, max_dist, max_factor, error) + PASS_ERROR(error) + else + n = n_neighbours(this%connect, this, i, max_dist, max_factor, error) + PASS_ERROR(error) + endif + + end function atoms_n_neighbours + + function atoms_neighbour_index(this, i, n, index, t, is_j, alt_connect, error) result(j) + type(Atoms), intent(in) :: this + integer, intent(in) :: i, n + integer, intent(out) :: index + type(Table), pointer, intent(out) :: t + logical, intent(out) :: is_j + type(Connection), optional, intent(in), target :: alt_connect + integer, intent(out), optional :: error + integer :: j + + INIT_ERROR(error) + if (present(alt_connect)) then + j = neighbour_index(alt_connect, & + i, n, index, t, is_j, error) + PASS_ERROR(error) + else + j = neighbour_index(this%connect, & + i, n, index, t, is_j, error) + PASS_ERROR(error) + endif + + end function atoms_neighbour_index + + function atoms_neighbour_minimal(this, i, n, shift, index, alt_connect) result(j) + type(Atoms), intent(in), target :: this + integer ::i, j, n + integer, intent(out) :: shift(3) + integer, intent(out) :: index + type(Connection), optional, intent(in), target :: alt_connect + + if (present(alt_connect)) then + j = neighbour_minimal(alt_connect, i, n, shift, index) + else + j = neighbour_minimal(this%connect, i, n, shift, index) + endif + + end function atoms_neighbour_minimal + + !% Return the index of the $n^\mathrm{th}$ neighbour of atom $i$. Together with the + !% previous function, this facilites a loop over the neighbours of atom $i$. Optionally, we + !% return other geometric information, such as distance, direction cosines and difference vector, + !% and also a direct index into the neighbour tables. If $i <= j$, this is an index into 'neighbour1(i)'; + !% if $i > j$, it is an index into 'neighbour1(j)'. + !% + !%> do n = 1,atoms_n_neighbours(at, i) + !%> j = atoms_neighbour(at, i, n, distance, diff, cosines, shift, index) + !%> + !%> ... + !%> end do + !% + !% If distance $>$ 'max_dist', return 0, and do not waste time calculating other quantities. + !% This enables efficient iteration over the subset of neighbours located within the radius + !% 'max_dist'. However, as the neighbour list is not sorted, + !% you must first iterate over the whole list (i.e. do *not* use the + !% 'max_dist' parameter in 'atoms_n_neighbours'), then skip those + !% neighbours where this function returns 0. + !% + !% 'alt_connect' has the same meaning as in 'n_neighbours'. + !% + !% Here's a typical loop construct in Python. Note how `r` and `u` + !% are created before the loop: arguments which are both optional + !% and ``intent(out)`` in Fortran are converted to ``intent(in,out)`` for quippy. :: + !%> + !%> r = farray(0.0) + !%> u = fzeros(3) + !%> for i in frange(at.n): + !%> for n in frange(at.n_neighbours(i)): + !%> j = at.neighbour(i, n, distance=r, diff=u) + function atoms_neighbour(this, i, n, distance, diff, cosines, shift, index, max_dist, jn, alt_connect, error) result(j) + type(Atoms), intent(in) :: this + integer ::i, j, n + real(dp), optional, intent(out) :: distance + real(dp), dimension(3), optional, intent(out) :: diff + real(dp), optional, intent(out) :: cosines(3) + integer, optional, intent(out) :: shift(3) + integer, optional, intent(out) :: index + real(dp), optional, intent(in) :: max_dist + integer, optional, intent(out) :: jn + type(Connection), optional, intent(in), target :: alt_connect + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (present(alt_connect)) then + j = neighbour(alt_connect, this, & + i, n, distance, diff, cosines, shift, index, max_dist, jn, error) + PASS_ERROR(error) + else + j = neighbour(this%connect, this, & + i, n, distance, diff, cosines, shift, index, max_dist, jn, error) + PASS_ERROR(error) + endif + + end function atoms_neighbour + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Adding and Removing atoms: adding/removing single or multiple atoms + ! For the atoms variable in Dynamical System, this should be called + ! shift there to avoid inconsistencies with DS's data + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine add_atom_single(this, pos, Z, mass, travel, error) + + type(Atoms), intent(inout) :: this + real(dp), intent(in), dimension(3) :: pos + integer, intent(in) :: Z + real(dp), optional, intent(in) :: mass + integer, optional, intent(in), dimension(3) :: travel + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(present(travel)) then + if(present(mass)) then + call add_atom_multiple(this, pos=reshape(pos, (/3,1/)), Z=(/Z/), mass=(/mass/), travel=reshape(travel, (/3,1/)), error=error) + else + call add_atom_multiple(this, pos=reshape(pos, (/3,1/)), Z=(/Z/), travel=reshape(travel, (/3,1/)), error=error) + end if + else + if(present(mass)) then + call add_atom_multiple(this, pos=reshape(pos, (/3,1/)), Z=(/Z/), mass=(/mass/), error=error) + else + call add_atom_multiple(this, pos=reshape(pos, (/3,1/)), Z=(/Z/), error=error) + end if + end if + PASS_ERROR(error) + + end subroutine add_atom_single + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine add_atom_multiple(this, pos, Z, mass, velo, acc, travel, error) + + type(Atoms), intent(inout) :: this + real(dp), intent(in), dimension(:,:) :: pos + integer, intent(in), dimension(:) :: Z + real(dp), optional, intent(in), dimension(:) :: mass + integer, optional, intent(in), dimension(:,:) :: travel + real(dp),optional, intent(in), dimension(:,:) :: velo, acc + integer, intent(out), optional :: error + + integer :: oldN,i + integer, allocatable, dimension(:) :: tmp_int + integer, allocatable, dimension(:,:) :: tmp_int2 + real(dp), allocatable, dimension(:) :: tmp_real + real(dp), allocatable, dimension(:,:) :: tmp_real2 + logical, allocatable, dimension(:) :: tmp_logical + character, allocatable, dimension(:,:) :: tmp_char + + logical :: has_mass, has_velo, has_acc, has_travel + + INIT_ERROR(error) + + if (this%fixed_size) then + RAISE_ERROR("add_atom_multiple: Atoms object cannot be resized (this%fixed_size = .true.)", error) + end if + + oldN = this%N + this%N = this%N + size(Z) + this%Ndomain = this%N + + !Check the sizes of the input arrays for consistency + call check_size('Pos',pos,(/3,size(Z)/),'Add_Atom',error) + PASS_ERROR(error) + + ! If we pass a NULL() pointer as an optional argument, the argument + ! shows up as present but has size == 0. + + has_mass = .false. + has_travel = .false. + has_velo = .false. + has_acc = .false. + + if (present(mass)) then + if (size(mass) > 0) then + has_mass = .true. + call check_size('Mass',mass,size(Z), 'Add_Atom', error) + PASS_ERROR(error) + endif + end if + + if (present(travel)) then + if (size(travel, 1) > 0 .and. size(travel, 2) > 0) then + has_travel = .true. + call check_size('Travel',travel,(/3,size(Z)/),'Add_Atom', error) + PASS_ERROR(error) + endif + end if + + if (present(velo)) then + if (size(velo, 1) > 0 .and. size(velo, 2) > 0) then + has_velo = .true. + call check_size('Velo', velo, (/3,size(Z)/), 'Add_Atom', error) + PASS_ERROR(error) + endif + end if + + if (present(acc)) then + if (size(acc, 1) > 0 .and. size(acc, 2) > 0) then + has_acc = .true. + call check_size('Acc', acc, (/3,size(Z)/), 'Add_Atom', error) + PASS_ERROR(error) + endif + end if + + ! Only resize if the actual number of particles is now larger than the + ! buffer size. + if (this%N > this%Nbuffer) then + + ! Resize property data arrays, copying old data. + ! this will break any existing pointers so we call atoms_repoint() immediately after + ! (note that user-held pointers will stay broken, there is no way to fix this + ! since Fortran does not allow pointer-to-pointer types) + do i=1,this%properties%N + select case (this%properties%entries(i)%type) + + case(T_INTEGER_A) + allocate(tmp_int(this%n)) + tmp_int(1:oldN) = this%properties%entries(i)%i_a + tmp_int(oldn+1:this%n) = 0 + call set_value(this%properties, string(this%properties%keys(i)), tmp_int) + deallocate(tmp_int) + + case(T_REAL_A) + allocate(tmp_real(this%n)) + tmp_real(1:oldN) = this%properties%entries(i)%r_a + tmp_real(oldn+1:this%n) = 0.0_dp + call set_value(this%properties, string(this%properties%keys(i)), tmp_real) + deallocate(tmp_real) + + case(T_LOGICAL_A) + allocate(tmp_logical(this%n)) + tmp_logical(1:oldN) = this%properties%entries(i)%l_a + tmp_logical(oldn+1:this%n) = .false. + call set_value(this%properties, string(this%properties%keys(i)), tmp_logical) + deallocate(tmp_logical) + + case(T_INTEGER_A2) + allocate(tmp_int2(this%properties%entries(i)%len2(1),this%n)) + tmp_int2(:,1:oldN) = this%properties%entries(i)%i_a2 + tmp_int2(:,oldn+1:this%n) = 0 + call set_value(this%properties, string(this%properties%keys(i)), tmp_int2) + deallocate(tmp_int2) + + case(T_REAL_A2) + allocate(tmp_real2(this%properties%entries(i)%len2(1),this%n)) + tmp_real2(:,1:oldN) = this%properties%entries(i)%r_a2 + tmp_real2(:,oldn+1:this%n) = 0.0_dp + call set_value(this%properties, string(this%properties%keys(i)), tmp_real2) + deallocate(tmp_real2) + + case(T_CHAR_A) + allocate(tmp_char(this%properties%entries(i)%len2(1),this%n)) + tmp_char(:,1:oldN) = this%properties%entries(i)%s_a + tmp_char(:,oldn+1:this%n) = ' ' + call set_value(this%properties, string(this%properties%keys(i)), tmp_char) + deallocate(tmp_char) + + case default + RAISE_ERROR('atoms_add: bad property type '//this%properties%entries(i)%type//' key='//this%properties%keys(i), error) + + end select + end do + endif + + ! We need to repoint even if the buffers are not reallocated. Otherwise + ! ifort will complain the array sizes are too small if compiled with + ! -check bounds + call atoms_repoint(this) + + this%Nbuffer = max(this%N, this%Nbuffer) + + ! First check the integer properties... + if (.not. has_key(this%properties, 'Z')) then + RAISE_ERROR('Atoms_Add: this atoms has no Z property', error) + end if + this%z(oldN+1:this%N) = Z + + ! set species from Z + if (.not. has_key(this%properties, 'species')) then + RAISE_ERROR('Atoms_Add: this atoms has no species property', error) + end if + do i=1,size(Z) + this%species(:,oldN+i) = ' ' + this%species(1:len(ElementName(Z(i))),oldN+i) = s2a(ElementName(Z(i))) + end do + + if (has_travel) then + if (.not. has_key(this%properties, 'travel')) then + RAISE_ERROR('Atoms_Add: this atoms has no travel property', error) + end if + this%travel(:,oldN+1:this%N) = travel + else + if (has_key(this%properties, 'travel')) then + this%travel(:,oldN+1:this%N) = 0 + end if + end if + + ! Set masks to 1 if properties for them exist + if (has_key(this%properties, 'move_mask')) & + this%move_mask(oldN+1:this%N) = 1 + if (has_key(this%properties, 'damp_mask')) & + this%damp_mask(oldN+1:this%N) = 1 + if (has_key(this%properties, 'thermostat_region')) & + this%thermostat_region(oldN+1:this%N) = 1 + + ! ... and now the real properties + if (has_key(this%properties, 'mass')) then + if (has_mass) then + this%mass(oldN+1:this%N) = mass + else + this%mass(oldN+1:this%N) = ElementMass(Z) + end if + else if (has_mass) then + ! mass specified but property doesn't yet exist, so create it... + call add_property(this, 'mass', ElementMass(this%Z), ptr=this%mass, error=error) + PASS_ERROR(error) + call set_comm_property(this, 'mass', & + comm_atoms=.true.) + ! ... and then override for new atoms + this%mass(oldN+1:this%N) = mass + end if + + if (.not. has_key(this%properties, 'pos')) then + RAISE_ERROR('Atoms_Add: this atoms has no pos property', error) + end if + this%pos(:,oldN+1:this%N) = pos + + if (has_velo .and. has_key(this%properties, 'velo')) & + this%velo(:,oldN+1:this%N) = velo + + if (has_acc .and. has_key(this%properties, 'acc')) & + this%acc(:,oldN+1:this%N) = acc + + call finalise(this%connect) + + end subroutine add_atom_multiple + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_join(this, from, error) + type(Atoms), intent(inout) :: this + type(Atoms), intent(inout) :: from + integer, optional, intent(out) :: error + + ! --- + + INIT_ERROR(error) + + call atoms_repoint(from) + + call add_atom_multiple(this, pos=from%pos, Z=from%Z, mass=from%mass, & + velo=from%velo, acc=from%acc, travel=from%travel, error=error) + PASS_ERROR(error) + + endsubroutine atoms_join + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine remove_atom_single(this, i, error) + + type(Atoms), intent(inout) :: this + integer, intent(in) :: i + integer, intent(out), optional :: error + + INIT_ERROR(error) + call remove_atom_multiple(this,(/i/),error) + PASS_ERROR(error) + + end subroutine remove_atom_single + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + !% Reshuffle the order of the atomic indices to new_indices. + subroutine atoms_shuffle(this, new_indices, error) + type(Atoms), intent(inout) :: this + integer, dimension(this%N), intent(in) :: new_indices + integer, optional, intent(out) :: error + + ! --- + + integer, allocatable, dimension(:) :: tmp_int + integer, allocatable, dimension(:,:) :: tmp_int2 + real(dp), allocatable, dimension(:) :: tmp_real + real(dp), allocatable, dimension(:,:) :: tmp_real2 + logical, allocatable, dimension(:) :: tmp_logical + character, allocatable, dimension(:,:) :: tmp_char + + integer :: i + + ! --- + + INIT_ERROR(error) + + ! Resize property data arrays, copying old data. + ! this will break any existing pointers so we call atoms_repoint() + ! immediately after (note that user-held pointers will stay broken, there + ! is no way to fix this since Fortran does not allow pointer-to-pointer + ! types) + do i=1,this%properties%N + select case (this%properties%entries(i)%type) + + case(T_INTEGER_A) + allocate(tmp_int(this%n)) + tmp_int(:) = this%properties%entries(i)%i_a(new_indices) + call set_value(this%properties, string(this%properties%keys(i)), tmp_int) + deallocate(tmp_int) + + case(T_REAL_A) + allocate(tmp_real(this%n)) + tmp_real(:) = this%properties%entries(i)%r_a(new_indices) + call set_value(this%properties, string(this%properties%keys(i)), tmp_real) + deallocate(tmp_real) + + case(T_LOGICAL_A) + allocate(tmp_logical(this%n)) + tmp_logical(:) = this%properties%entries(i)%l_a(new_indices) + call set_value(this%properties, string(this%properties%keys(i)), tmp_logical) + deallocate(tmp_logical) + + case(T_INTEGER_A2) + allocate(tmp_int2(this%properties%entries(i)%len2(1),this%n)) + tmp_int2(:,:) = this%properties%entries(i)%i_a2(:,new_indices) + call set_value(this%properties, string(this%properties%keys(i)), tmp_int2) + deallocate(tmp_int2) + + case(T_REAL_A2) + allocate(tmp_real2(this%properties%entries(i)%len2(1),this%n)) + tmp_real2(:,:) = this%properties%entries(i)%r_a2(:,new_indices) + call set_value(this%properties, string(this%properties%keys(i)), tmp_real2) + deallocate(tmp_real2) + + case(T_CHAR_A) + allocate(tmp_char(this%properties%entries(i)%len2(1),this%n)) + tmp_char(:,:) = this%properties%entries(i)%s_a(:,new_indices) + call set_value(this%properties, string(this%properties%keys(i)), tmp_char) + deallocate(tmp_char) + + case default + RAISE_ERROR('remove_atom_multiple: bad property type '//this%properties%entries(i)%type//' key='//this%properties%keys(i), error) + end select + end do + call atoms_repoint(this) + + endsubroutine atoms_shuffle + + + subroutine remove_atom_multiple(this, atom_indices, error) + type(Atoms), intent(inout) :: this + integer, intent(in), dimension(:) :: atom_indices + integer, intent(out), optional :: error + + integer i, copysrc + integer, allocatable, dimension(:) :: new_indices + integer, dimension(size(atom_indices)) :: sorted + integer, dimension(:), allocatable :: uniqed + + INIT_ERROR(error) + + if (this%fixed_size) then + RAISE_ERROR("remove_atom_multiple: Atoms object cannot be resized (this%fixed_size = .true.)", error) + end if + + !Delete the connection data because the atomic indices become mangled + call finalise(this%connect) + + ! Permute new_indices, following algorithm in table_record_delete_multiple, + ! so that atom ordering is same as it was under old scheme when properties were + ! stored as columns in Table this%data. + ! (we find first atomc to be removed and last atom to not be removed + ! and swap them. Repeat until all atoms to be removed are at the end.) + + sorted = atom_indices ! Get our own copy of the indices so we can sort them + call heap_sort(sorted) + call uniq(sorted, uniqed) ! remove duplicates from sorted indices + + allocate(new_indices(this%N)) + do i=1,this%N + new_indices(i) = i + end do + + copysrc = this%N + do i = size(uniqed), 1, -1 + if (uniqed(i) < copysrc) then + new_indices(uniqed(i)) = new_indices(copysrc) + else if (uniqed(i) > copysrc) then + RAISE_ERROR("remove_atom_multiple: Fatal internal error: uniqed(i) > copysrc, should not happen", error) + endif + + copysrc = copysrc - 1 + end do + + ! update N + this%N = this%N - size(uniqed) + this%Ndomain = this%N + this%Nbuffer = this%N + + if (this%N /= copysrc) then + RAISE_ERROR("remove_atom_multiple: Fatal internal error: this%N /= copysrc, should not happen", error) + endif + + ! This will reallocate all buffers to the new size (i.e. this%N) + call shuffle(this, new_indices(1:this%N), error=error) + PASS_ERROR(error) + + deallocate(uniqed, new_indices) + + end subroutine remove_atom_multiple + + + subroutine remove_atom_multiple_mask(this, mask, error) + + type(Atoms), intent(inout) :: this + logical, dimension(this%N), intent(in) :: mask + integer, optional, intent(out) :: error + + ! --- + + integer :: i, j + + integer, allocatable :: new_indices(:) + + ! --- + + INIT_ERROR(error) + + if (this%fixed_size) then + RAISE_ERROR("remove_atom_multiple_mask: Atoms object cannot be resized (this%fixed_size = .true.)", error) + end if + + !Delete the connection data because the atomic indices become mangled + call finalise(this%connect) + + allocate(new_indices(this%N)) + + j = 1 + do i = 1, this%N + if (.not. mask(i)) then + ! Keep this atom + new_indices(j) = i + j = j + 1 + endif + enddo + + ! update N + this%N = j-1 + this%Ndomain = this%N + this%Nbuffer = this%N + + ! This will reallocate all buffers to the new size (i.e. this%N) + call shuffle(this, new_indices(1:this%N), error=error) + PASS_ERROR(error) + + deallocate(new_indices) + + endsubroutine remove_atom_multiple_mask + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Map atomic fractional positions back into the unit cell + !% $-0.5 \le t_x,t_y,t_z < 0.5$ + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_map_into_cell(this) + type(Atoms), intent(inout) :: this + + integer :: i,j, n, m + integer :: shift(3) + logical :: mapped + integer, pointer :: map_shift(:,:) + + + ! Loop over all atoms + ! Convert cartesians to lattice co-ords + ! If outside unit cell: + ! add lattice vectors to get back into cell + ! update travel + ! update shifts + + if (.not. has_property(this, 'travel')) then + call add_property(this, 'travel', 0, n_cols=3, ptr2=this%travel) + call set_comm_property(this, 'travel', & + comm_atoms=.true.) + end if + + do i=1,this%N + call map_into_cell(this%pos(:,i), this%lattice, this%g, shift, mapped) + if (mapped) then + this%travel(:,i) = this%travel(:,i) - shift + if (this%connect%initialised) then + do n=1,atoms_n_neighbours(this, i) ! Loop over all atom i's neighbours + + j = atoms_neighbour(this, i, n, index=m) ! get neighbour + + ! now update the data for atom i and the current neighbour + if (i < j) then + this%connect%neighbour1(i)%t%int(2:4,m) = this%connect%neighbour1(i)%t%int(2:4,m) + shift + else if (i > j) then + this%connect%neighbour1(j)%t%int(2:4,m) = this%connect%neighbour1(j)%t%int(2:4,m) - shift + else + ! do nothing when i == j + end if + end do + end if ! this%connect%initialised + end if ! mapped + end do ! i=1..N + + if (assign_pointer(this, 'map_shift', map_shift)) map_shift = 0 + + end subroutine atoms_map_into_cell + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Unskew lattice so the cosines of the lattice angles fall between + !% $-0.5$ and $0.5$ + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_unskew_cell(this, error) + type(Atoms), intent(inout) :: this + integer, intent(out), optional :: error + + real(dp), dimension(3,3) :: lattice + real(dp), dimension(3) :: lengths, angles + integer :: i, j, k, tmp_i, max_angle(1) + + INIT_ERROR(error) + + lattice = this%lattice + + do + do i = 1, 3 + lengths(i) = sqrt(sum(lattice(:,i)**2)) + enddo + + k = 0 + + do i = 1, 3 + do j = i+1, 3 + k = k+1 + angles(k) = dot_product(lattice(:,i),lattice(:,j)) / lengths(i) / lengths(j) + enddo + enddo + + if( all( abs(angles) <= 0.5_dp ) ) exit + + max_angle = maxloc(abs(angles)) + + selectcase(max_angle(1)) + case(1) + i = 1 + j = 2 + case(2) + i = 1 + j = 3 + case(3) + i = 2 + j = 3 + case default + RAISE_ERROR("atoms_unskew_cell: max_angle not between 1 and 3", error) + endselect + + if(lengths(i) > lengths(j)) then + tmp_i = j + j = i + i = tmp_i + endif + + lattice(:,j) = lattice(:,j) - nint(angles(max_angle(1))) * lattice(:,i) + + enddo + + call set_lattice(this,lattice,scale_positions=.false.,remap=.true.,reconnect=.true.) + + + end subroutine atoms_unskew_cell + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Cosine of the angle j--i--k + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function cosine(this,i,j,k,error) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i,j,k + real(dp) :: cosine + real(dp), dimension(3) :: ij, ik + integer, intent(out), optional :: error + + INIT_ERROR(error) + if ((i == j) .or. (i == k)) then + RAISE_ERROR('Cosine: i == j or i == k', error) + end if + + ij = diff_min_image(this,i,j) + ik = diff_min_image(this,i,k) + cosine = (ij .dot. ik) / (norm(ij)*norm(ik)) + + end function cosine + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Cosine of the angle n--i--m where {$n,m$} are the {$n$th, $m$th} neighbours of i + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function cosine_neighbour(this,i,n,m) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i,n,m + real(dp) :: cosine_neighbour + real(dp), dimension(3) :: in, im + integer::j + + if(n == m) then + cosine_neighbour = 1.0_dp + return + end if + j = atoms_neighbour(this, i, n, diff=in) + j = atoms_neighbour(this, i, m, diff=im) + cosine_neighbour = (in .dot. im) / (norm(in)*norm(im)) + + end function cosine_neighbour + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Direction cosines + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Given two atoms $i$ and $j$ and a shift returns the direction + !% cosines of the differnece vector from $i$ to $j$. + function direction_cosines(this,i,j,shift) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i,j, shift(3) + real(dp), dimension(3) :: direction_cosines, diffv + + diffv = diff(this,i,j,shift) + direction_cosines = diffv / norm(diffv) + + end function direction_cosines + + !% Direction cosines of the difference vector from $i$ to $j$ + function direction_cosines_min_image(this,i,j,error) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i,j + real(dp), dimension(3) :: direction_cosines_min_image, diffv + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (i == j) then + RAISE_ERROR('Cosines: i == j', error) + end if + + diffv = diff_min_image(this,i,j) + direction_cosines_min_image = diffv / norm(diffv) + + end function direction_cosines_min_image + + subroutine set_map_shift(this, error) + type(Atoms), intent(inout) :: this + integer, intent(out), optional :: error + + integer, pointer :: map_shift(:,:) + integer n + real(dp) :: lat_pos(3) + + INIT_ERROR(error) + if (.not. assign_pointer(this, 'map_shift', map_shift)) then + call add_property(this, 'map_shift', 0, 3) + if (.not. assign_pointer(this, 'map_shift', map_shift)) then + RAISE_ERROR("partition_atoms impossibly failed to assign map_shift pointer", error) + end if + endif + + do n = 1, this%N + lat_pos = this%g .mult. this%pos(:,n) + map_shift(:,n) = - floor(lat_pos+0.5_dp) + end do + end subroutine set_map_shift + + ! + !% Returns the (unsigned) volume of the simulation cell of this Atoms + ! + function atoms_cell_volume(this) + type(Atoms), intent(in) :: this + real(dp) :: atoms_Cell_Volume + + atoms_cell_volume = cell_volume(this%lattice) + end function atoms_cell_volume + + + ! + ! Make_Lattice + ! + !% Make a matrix of lattice vectors from the lengths 'a','b','c' + !% and the angles 'alpha', 'beta' and 'gamma'. + !% One length must be supplied. Any missing angle is assumed to be 90 degrees + !% and any missing length is assumed to be 'a'. + !% The vectors are created in a right-handed order. + ! + function make_lattice(a,b,c,alpha,beta,gamma,error) result(lattice) + + real(dp), intent(in) :: a + real(dp), optional, intent(in) :: b,c + real(dp), optional, intent(in) :: alpha,beta,gamma + integer, intent(out), optional :: error + real(dp), dimension(3,3) :: lattice + real(dp) :: my_b, my_c, & + cos_alpha, cos2_alpha, & + cos_beta, cos2_beta, & + cos_gamma, cos2_gamma, & + sin_gamma, sin2_gamma, & + my_alpha, my_beta,my_gamma + INIT_ERROR(error) + my_b = a + my_c = a + + if (present(b)) my_b = b + if (present(c)) my_c = c + + my_alpha = PI/2.0_dp + my_beta = PI/2.0_dp + my_gamma = PI/2.0_dp + + if (present(alpha)) my_alpha = alpha + if (present(beta)) my_beta = beta + if (present(gamma)) my_gamma = gamma + + if ( (my_alpha <= 0.0_dp) .or. (my_alpha <= 0.0_dp) .or. (my_gamma <= 0.0_dp) ) then + RAISE_ERROR('Make_Lattice: Negative angles are not permitted', error) + end if + + if ( (my_alpha + my_beta) < my_gamma ) then + RAISE_ERROR('Make_Lattice: alpha + beta < gamma', error) + end if + if ( (my_beta + my_gamma) < my_alpha ) then + RAISE_ERROR('Make_Lattice: beta + gamma < alpha', error) + end if + if ( (my_gamma + my_alpha) < my_beta ) then + RAISE_ERROR('Make_Lattice: gamma + alpha < beta', error) + end if + + cos_alpha = cos(my_alpha); cos2_alpha = cos_alpha*cos_alpha + cos_beta = cos(my_beta); cos2_beta = cos_beta *cos_beta + cos_gamma = cos(my_gamma); cos2_gamma = cos_gamma*cos_gamma + sin_gamma = sin(my_gamma); sin2_gamma = sin_gamma*sin_gamma + + ! a + lattice(1,1) = a + lattice(2,1) = 0.0_dp + lattice(3,1) = 0.0_dp + ! b + lattice(1,2) = my_b * cos_gamma + lattice(2,2) = my_b * sin_gamma + lattice(3,2) = 0.0_dp + ! c + lattice(1,3) = my_c * cos_beta + lattice(2,3) = my_c * (cos_alpha - cos_beta*cos_gamma) / sin_gamma + lattice(3,3) = my_c * sqrt(1.0_dp - (cos2_alpha + cos2_beta - 2.0_dp*cos_alpha*cos_beta*cos_gamma)/ sin2_gamma) + + end function make_lattice + + ! + !% Opposite of Make_Lattice. + !% Given a lattice, return a,b,c,alpha,beta and gamma (if needed) + ! + subroutine get_lattice_params(lattice,a,b,c,alpha,beta,gamma) + + real(dp), dimension(3,3), intent(in) :: lattice + real(dp), optional, intent(out) :: a,b,c,alpha,beta,gamma + !local variables + real(dp), dimension(3) :: a_1,a_2,a_3 + + a_1 = lattice(:,1) + a_2 = lattice(:,2) + a_3 = lattice(:,3) + + if (present(a)) a = norm(a_1) + if (present(b)) b = norm(a_2) + if (present(c)) c = norm(a_3) + + if (present(alpha)) alpha = acos( (a_2 .dot. a_3) / (norm(a_2)*norm(a_3)) ) + if (present(beta)) beta = acos( (a_3 .dot. a_1) / (norm(a_3)*norm(a_1)) ) + if (present(gamma)) gamma = acos( (a_1 .dot. a_2) / (norm(a_1)*norm(a_2)) ) + + end subroutine get_lattice_params + + ! + ! Centre_Of_Mass + ! + !% Calculate the centre of mass of an atoms object, using the closest images to the origin atom, + !% or first atom if this is not specified. If origin is zero, use actual position, not minimum image. + !% If an 'index_list' is present, just calculate it for that subset of atoms (then the origin atom is + !% the first in this list unless it is specified separately). + !% + !% Note: Because the origin can be specified separately it need not be one of the atoms in the + !% calculation. + function centre_of_mass(at,index_list,mask,origin,error) result(CoM) + + type(atoms), intent(in) :: at + integer, optional, intent(in) :: origin + integer, dimension(:), optional, intent(in) :: index_list + logical, dimension(:), optional, intent(in) :: mask + integer, optional, intent(out) :: error + real(dp), dimension(3) :: CoM + + !local variables + integer :: i, my_origin + real(dp) :: M_Tot + + INIT_ERROR(error) + if (.not. has_property(at, 'mass')) then + RAISE_ERROR('centre_of_mass: Atoms has no mass property', error) + end if + + if (present(index_list) .and. present(mask)) then + RAISE_ERROR('centre_of_mass: Cannot take both index_list and mask arguments', error) + endif + + if (present(origin)) then + if (origin > at%N .or. origin < 0) then + RAISE_ERROR('centre_of_mass: Invalid origin atom', error) + end if + my_origin = origin + else + if (present(index_list)) then + my_origin = index_list(1) + else if (present(mask)) then + i = 1 + do while (.not. mask(i) .and. i <= at%N) + i = i+1 + enddo + if (i > at%N) then + RAISE_ERROR('centre_of_mass: No atoms specified in mask.', error) + endif + my_origin = i + else + my_origin = 1 + endif + end if + + CoM = 0.0_dp + M_Tot = 0.0_dp + + if (present(index_list)) then + + do i = 1, size(index_list) + if (index_list(i) > at%N .or. index_list(i) < 1) then + RAISE_ERROR('centre_of_mass: Invalid atom in index_list', error) + end if + if (my_origin > 0) then + CoM = CoM + at%mass(index_list(i)) * diff_min_image(at,my_origin,index_list(i)) + else + CoM = CoM + at%mass(index_list(i)) * at%pos(:,index_list(i)) + endif + M_Tot = M_Tot + at%mass(index_list(i)) + end do + + else + + do i = 1, at%N + if (present(mask)) then + if (.not. mask(i)) cycle + endif + if (my_origin > 0) then + CoM = CoM + at%mass(i) * diff_min_image(at,my_origin,i) + else + CoM = CoM + at%mass(i) * at%pos(:,i) + endif + M_Tot = M_Tot + at%mass(i) + end do + + end if + + CoM = CoM / M_Tot + if (my_origin > 0) then + CoM = CoM + at%pos(:,my_origin) + endif + + end function centre_of_mass + + ! + ! Directionality ellipsoid: + ! + !% Given an origin atom and a list of other atoms, give information as to whether the other atoms + !% are distributed roughly linearly, planar or spherically around the origin atom. + !% + !% The most notable use is to check that the splines in adjustable potential will be able to reproduce + !% a randomly oriented force difference well. + !% + !% The information returned is the set of eigenvectors and associated eigenvalues of the directionality + !% ellipsoid. One large e-value suggests roughly linear clustering, two similar and one small e-values suggest + !% a planar distribution, while three similar e-values suggests almost spherical distribution (when copies of + !% the atoms reflected through the origin atom are also considered). + !% + !% To acheive a more spherical distribution, atoms along the e-vector(s) with the smallest e-value(s) should be + !% added to the index list (See 'CosAngle_To_Line' below). + !% + !% The matrix which is diagonalised is an average of the outer products of the unit vectors from the origin + !% atom to the other atoms. + !% + !% An outer product has 1 eigenvector which is the vector it was constructed from with + !% eigenvalue 1 and the other eigenvectors have eigenvalue 0. + !% + !% The eigenvalues of the averaged matrix sum to 1. + !% + subroutine directionality(this,origin,list,evalues,evectors,method,error) + + type(Atoms), intent(in) :: this !% The input atoms structure + integer, intent(in) :: origin !% The origin atom + type(table), intent(in) :: list !% Indices and shifts of the other atoms relative to origin + real(dp), dimension(3), intent(out) :: evalues !% Eigenvalues of the directionality matrix + real(dp), dimension(3,3), intent(out) :: evectors !% Eigenvectors of the directionality matrix + integer, optional, intent(in) :: method !% 'METHOD = 1' Directionality ellipsoid method. + !% 'METHOD = 2' Singular Value Decomposition method (default) + integer, intent(out), optional :: error + + !local variables + integer :: i, j, k, l, n, my_method, lwork, info, jshift(3) + real(dp), dimension(3) :: r_ij,rhat_ij + real(dp), dimension(3,3) :: A, B + real(dp), allocatable, dimension(:,:) :: vectors, u + real(dp), allocatable, dimension(:) :: work + + INIT_ERROR(error) + my_method = 2 + + if (present(method)) then + if (method < 1 .or. method > 2) then + write(line,'(a,i0,a)')'Directionality: Method = ',method,' does not exist' + call system_abort(line) + end if + my_method = method + end if + + if (list%intsize /= 4) then + RAISE_ERROR('Directionality: list must have 4 int columns for indices and shifts', error) + end if + if (list%N == 0) then + RAISE_ERROR('Directionality: list table has no entries', error) + end if + + i = origin + + select case(my_method) + + case(1) ! **** Directionality Ellipsoid method **** + + B = 0.0_dp + + !Construct the directionality matrix + do n = 1, list%N + j = list%int(1,n) + jshift = list%int(2:4,n) + if (j > this%N) then + RAISE_ERROR('Directionality: Atom '//j//' is out of range ('//this%N//')', error) + end if + r_ij = diff(this,i,j,jshift) + rhat_ij = r_ij / norm(r_ij) + forall(k=1:3,l=1:3) A(k,l) = rhat_ij(k)*rhat_ij(l) + B = B + A + end do + + B = B / real(list%N,dp) + + !Find eigenvalues/eigenvectors of the directionality matrix + call diagonalise(B,evalues,evectors) + + case(2) ! **** Singular Value Decomposition method **** + + lwork = 2 * max(3*min(3,list%N)+max(3,list%N),5*min(3,list%N)) + + allocate(work(lwork), vectors(list%N,3), u(list%N,3)) + + !Fill 'vectors' with unit vectors + do n = 1, list%N + j = list%int(1,n) + jshift = list%int(2:4,n) + if (j > this%N) then + RAISE_ERROR('Directionality: Atom '//j//' is out of range ('//this%N//')', error) + end if + r_ij = diff(this,i,j,jshift) + vectors(n,:) = r_ij / norm(r_ij) + end do + + call dgesvd('N','A',list%N,3,vectors,list%N,evalues,u,list%N,evectors,3,work,lwork,info) + !No left singular vectors, all right singular vectors + + if (info/=0) then + if (info < 0) then + RAISE_ERROR('Directionality: Problem with argument '//-info//' passed to DGESVD', error) + else + RAISE_ERROR('Directionality: DBDSQR (called from DGESVD) did not converge', error) + end if + end if + + deallocate(work, vectors, u) + + evectors = transpose(evectors) + + end select + + end subroutine directionality + + ! + ! CosAngle_To_Line + ! + !% For use with the 'Directionality' routine above. + !% Given an atom ('atom') and a direction ('dir') return the absolute value of the cosine of the angle + !% between the the line running through 'atom' in direction 'dir' and the line + !% between 'atom' and 'test_atom' + !% + !% The idea is that this will be called with the origin atom from 'Directionality' as 'atom', + !% the eigenvector associated with the smallest eigenvalue as 'dir' and a potentially new + !% atom to connect to 'atom' with a spline as 'test_atom'. + !% + !% If the result is close to 1 then accept the 'test_atom', and reject if close to zero + + function cosangle_to_line(this,atom,dir,test_atom,error) + + type(atoms), intent(in) :: this + integer, intent(in) :: atom + real(dp), dimension(3), intent(in) :: dir + integer, intent(in) :: test_atom + real(dp) :: CosAngle_To_Line + integer, intent(out), optional :: error + !local variables + real(dp), dimension(3) :: r_ab + + INIT_ERROR(error) + !Sanity checks + if (atom > this%N) then + RAISE_ERROR('CosAngle_To_Line: Atom '//atom//' out of range ('//this%N//')', error) + end if + + if (test_atom > this%N) then + RAISE_ERROR('CosAngle_To_Line: Test atom '//test_atom//' out of range ('//this%N//')', error) + end if + + if (normsq(dir) .feq. 0.0_dp) then + RAISE_ERROR('CosAngle_To_Line: A non-zero direction is required', error) + end if + + r_ab = diff_min_image(this,atom,test_atom) + + CosAngle_To_Line = abs(dir .dot. r_ab) / (norm(dir)*norm(r_ab)) + + end function cosangle_to_line + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! I/O procedures + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_print(this,file,error) + type(Atoms), intent(in) :: this + type(Inoutput), intent(inout),optional, target :: file + integer, intent(out), optional :: error + + type(Inoutput), pointer :: my_out + + INIT_ERROR(error) + if(.not. is_initialised(this)) then + RAISE_ERROR('Atoms_Print: Atoms structure not initialised', error) + end if + + if(current_verbosity() <= PRINT_SILENT) return ! for efficiency + + if (present(file)) then + my_out => file + else + my_out => mainlog + end if + + call print('Atoms Structure: ', PRINT_NORMAL, my_out) + call print('Number of atoms = '//this%N, PRINT_NORMAL, my_out) + + call print('Cutoff radius = '//this%cutoff//' Angstroms', PRINT_NORMAL, my_out) + + call print('Lattice vectors:', PRINT_NORMAL, my_out) + call print('a = ('//this%lattice(:,1)//')', PRINT_NORMAL, my_out) + call print('b = ('//this%lattice(:,2)//')', PRINT_NORMAL, my_out) + call print('c = ('//this%lattice(:,3)//')', PRINT_NORMAL, my_out) + + call print('Params') + call print(this%params) + + call print('Properties') + call print(this%properties) + + if (this%connect%initialised) then + call verbosity_push_decrement() + call print(this%connect, my_out) + call verbosity_pop() + end if + + call print('',PRINT_NORMAL, my_out) + end subroutine atoms_print + + function prop_names_string(this, with_types, error) + type(Atoms), intent(in) :: this + logical, optional, intent(in) :: with_types + integer, intent(out), optional :: error + character(len=STRING_LENGTH) :: prop_names_string + + INIT_ERROR(error) + prop_names_string=dict_prop_names_string(this%properties, with_types) + PASS_ERROR(error) + + end function prop_names_string + + function dict_prop_names_string(this,with_types,error) + type(Dictionary), intent(in) :: this + logical, intent(in), optional :: with_types + integer, intent(out), optional :: error + character(len=STRING_LENGTH) :: dict_prop_names_string + + character(len=1) :: prop_type + character(len=STRING_LENGTH) :: tmp + integer :: i, n_cols, type + logical :: my_with_types + + INIT_ERROR(error) + my_with_types = optional_default(.false., with_types) + + dict_prop_names_string = "" + do i=1,this%N + if (my_with_types) then + + select case(this%entries(i)%type) + case(T_INTEGER_A) + prop_type = 'I' + n_cols = 1 + case(T_REAL_A) + prop_type = 'R' + n_cols = 1 + case(T_LOGICAL_A) + prop_type = 'L' + n_cols = 1 + case(T_CHAR_A) + prop_type = 'S' + n_cols = 1 + case(T_INTEGER_A2) + prop_type = 'I' + n_cols = this%entries(i)%len2(1) + case(T_REAL_A2) + prop_type = 'R' + n_cols = this%entries(i)%len2(1) + case default + RAISE_ERROR('dict_prop_names_string: bad property type='//type//' in properties argument', error) + end select + + write(tmp,'(i0)') n_cols ! Number of columns for this property + dict_prop_names_string=trim(dict_prop_names_string)//string(this%keys(i))//':'// & + prop_type//':'//trim(tmp)//':' + else + dict_prop_names_string=trim(dict_prop_names_string)//string(this%keys(i))//':' + endif + end do + ! Remove trailing ':' + dict_prop_names_string = dict_prop_names_string(1:len_trim(dict_prop_names_string)-1) + end function dict_prop_names_string + + !Termination_Bond_Rescale + !% Calculates the rescale ratio of a Z1--H bond + !% generate from a Z1--Z2 bond. + function termination_bond_rescale(z1,z2) + integer, intent(in) :: z1, z2 + real(dp) :: termination_bond_rescale + termination_bond_rescale = (ElementCovRad(z1) + ElementCovRad(1)) & + / (ElementCovRad(z1) + ElementCovRad(z2)) + end function termination_bond_rescale + + !% Parses an atom_mask, which is string consisting of the '@' symbol followed by a comma separated + !% list of indices or ranges into a table containing all the indices it represents. + !% E.g. '@1,37-39,54,99-102' is expanded to a table with 1, 37, 38, 39, 54, 99, 100, + !% 101, 102 as its first integer column. There must be no spaces in the mask. + subroutine parse_atom_mask(mask_in,atom_indices,error) + + character(*), intent(in) :: mask_in + type(Table), intent(out) :: atom_indices + integer, intent(out), optional :: error + + character(len(mask_in)) :: mask + character(20), dimension(50) :: fields + integer :: Nfields, i, j, n, a, b, c + + INIT_ERROR(error) + call allocate(atom_indices,1,0,0,0,100) + + mask = adjustl(mask_in) + + if (mask(1:1)=='@') then !Found atom mask + !Remove @ symbol + mask = mask(2:) + !Parse into comma separated numbers or ranges + call parse_string(mask,',',fields,Nfields) + if (Nfields==0) then + RAISE_ERROR('parse_atom_mask: Atom mask contained no indices', error) + end if + do i = 1, Nfields + !Is this field a single atom or a contiguous range? + n = scan(fields(i),'-') + if (n /= 0) then + !it's a range. get start number + a = string_to_int(fields(i)(:n-1)) + !get end number + b = string_to_int(fields(i)(n+1:)) + if (a > b) then + c = b + b = a + a = c + end if + !add all these atoms to the list + do j = a, b + if (.not.is_in_array(int_part(atom_indices,1),j)) call append(atom_indices,j) + end do + else + !it's a single atom. + a = string_to_int(fields(i)) + if (.not.is_in_array(int_part(atom_indices,1),j)) call append(atom_indices,a) + end if + end do + else + RAISE_ERROR('parse_atom_mask: Invalid atom mask: '//mask_in, error) + end if + + end subroutine parse_atom_mask + + !% Find atoms which have integer property 'prop' set to + !% true (i.e. set to 1) and return them in the Table 'list'. + subroutine property_to_list(at, prop, list, error) + type(Atoms), intent(in) :: at + character(*), intent(in) :: prop + type(Table), intent(inout) :: list + integer, intent(out), optional :: error + + integer :: i + integer, dimension(:), pointer :: p + + INIT_ERROR(error) + if (.not. assign_pointer(at, prop, p)) then + RAISE_ERROR('property_to_list: at does not have property "'//trim(prop)//'".', error) + end if + + call allocate(list, 1, 0, 0, 0) + call append(list, pack((/ (i, i=1,size(p)) /), p == 1)) + + end subroutine property_to_list + + !% Convert the Table 'list' to a single column integer property in 'at', + !% with atoms in list marked with a 1 and absent + subroutine list_to_property(at, list, prop, error) + type(Atoms), intent(inout) :: at + type(Table), intent(in) :: list + character(*), intent(in) :: prop + integer, intent(out), optional :: error + + integer, dimension(:), pointer :: p + + INIT_ERROR(error) + ! Add property if necessary + call add_property(at, prop, 0) + + if (.not. assign_pointer(at, prop, p)) then + RAISE_ERROR('list_to_property: at does not have property "'//trim(prop)//'".', error) + end if + + p = 0 ! Set all entries to zero + p(int_part(list,1)) = 1 ! Set entries in 'list' to 1 + + end subroutine list_to_property + + !% Find atoms which have integer property 'prop' with value 'value' + !% and return them in a table 'list'. + subroutine list_matching_prop(at,list,name,value,error) + + type(atoms), intent(in) :: at + type(table), intent(inout) :: list + character(*), intent(in) :: name + integer, intent(in) :: value + integer, intent(out), optional :: error + + integer :: i + integer, pointer, dimension(:) :: ptr + + INIT_ERROR(error) + !find property + if (.not. assign_pointer(at%properties,name,ptr)) then + RAISE_ERROR('Property "'//name//'" not found', error) + end if + + call wipe(list) + + do i = 1, at%N + if (ptr(i)==value) call append(list,(/i/)) + end do + + end subroutine list_matching_prop + + !% Return the complement of a list, i.e. all those atoms not included + !% in list. Result is in outlist on exit. + subroutine complement(at, inlist, outlist) + type(Atoms), intent(in) :: at + type(Table), intent(in) :: inlist + type(Table), intent(out) :: outlist + + integer :: i + integer, allocatable, dimension(:) :: inarray + + call allocate(outlist,1,0,0,0) + + allocate(inarray(inlist%N)) + inarray = int_part(inlist,1) + + do i=1,at%N + if (.not. is_in_array(inarray,i)) & + call append(outlist,i) + end do + + deallocate(inarray) + + end subroutine complement + + + !% Return the difference between list1 and list2 in outlist. + !% That is, those elements in list1 but not in list2 + subroutine difference(list1, list2, outlist, error) + type(Table), intent(in) :: list1, list2 + type(Table), intent(out) :: outlist + integer, intent(out), optional :: error + + integer :: i + integer, dimension(:), allocatable :: array1, array2 + + INIT_ERROR(error) + if (list1%N <= list2%N) then + RAISE_ERROR('difference: list1%N ('//(list1%N)//') <= list2%N ('//(list2%N)//').', error) + end if + + call allocate(outlist, 1, 0, 0, 0) + + allocate(array1(list1%N),array2(list2%N)) + array1 = int_part(list1,1) + array2 = int_part(list2,1) + + do i=1,list1%N + if (.not. is_in_array(array2, array1(i))) & + call append(outlist,list1%int(1,i)) + end do + + deallocate(array1,array2) + + end subroutine difference + + !% move atoms around following neighbor list bonds so that all are in the same periodic image + !% (that of 'seed', if present) + !% poorly tested, especially for situations where not all atoms are in one connected clump + !% probably needs a better subroutine name + subroutine coalesce_in_one_periodic_image(this, seed, is_periodic, error) + type(Atoms), intent(inout) :: this + integer, intent(in), optional :: seed + logical, optional, intent(in) :: is_periodic(3) + integer, intent(out), optional :: error + + integer :: i, ji, jji, j, shift(3), delta_shift(3), jj, k, ki + integer :: n_neighbours, max_n_neighbours + integer, allocatable :: shifts(:,:,:), cluster_list(:) + logical, allocatable :: touched(:), is_in_cluster(:) + integer :: seed_val, last_n_in_cluster + logical :: dir_mask(3) + integer, allocatable, dimension(:) :: dir_indices + + INIT_ERROR(error) + seed_val=optional_default(1, seed) + + if (present(is_periodic)) then + dir_mask = .not. is_periodic + allocate(dir_indices(count(dir_mask))) + dir_indices(:) = pack((/1,2,3/), dir_mask) + else + allocate(dir_indices(3)) + dir_mask = .true. + dir_indices = (/1,2,3/) + end if + + max_n_neighbours = 0 + do i=1, this%N + n_neighbours = atoms_n_neighbours(this, i) + if (n_neighbours > max_n_neighbours) max_n_neighbours = n_neighbours + end do + allocate(shifts(3,max_n_neighbours,this%N)) + shifts = 0 + + ! find which atoms are in cluster that includes seed + allocate(is_in_cluster(this%N)) + is_in_cluster = .false. + last_n_in_cluster = 0 + is_in_cluster(seed_val) = .true. + do while (count(is_in_cluster) /= last_n_in_cluster) + last_n_in_cluster = count(is_in_cluster) + do i=1, this%N + if (is_in_cluster(i)) then + do ji=1, atoms_n_neighbours(this, i) + j = atoms_neighbour(this, i, ji, shift=shift) + is_in_cluster(j) = .true. + end do + end if + end do + end do + allocate(cluster_list(count(is_in_cluster))) + ji = 0 + do i=1, this%N + if (is_in_cluster(i)) then + ji = ji + 1 + cluster_list(ji) = i + endif + end do + + ! initialize shifts + do i=1, this%N + do ji=1, atoms_n_neighbours(this, i) + j = atoms_neighbour(this, i, ji, shift=shift) + shifts(:,ji,i) = shift + end do + end do + + allocate(touched(this%N)) + touched = .false. + touched(seed_val) = .true. + + do while (any(shifts(dir_indices,:,cluster_list(:)) /= 0)) + ! look for atoms i that have been touched + do i=1, this%N + if (.not. is_in_cluster(i)) cycle + if (touched(i)) then + ! look at neighbors of i + do ji=1, atoms_n_neighbours(this,i) + j = atoms_neighbour(this, i, ji) + ! if neighbor has 0 shift, it doesn't need to move + if (any(shifts(dir_indices,ji,i) /= 0)) then + ! atom j does need to move + ! atoms with non-zero shift should not have been touched before + if (touched(j)) then + RAISE_ERROR("coalesce_in_one_periodic_image tried to move atom " // j // " twice", error) + endif + + ! shift atom to zero out shift + do k=1,3 + if (dir_mask(k)) this%pos(:,j) = this%pos(:,j) + shifts(k,ji,i) * this%lattice(:,k) + end do + + ! fix shifts of j's neighbours + delta_shift = merge(shifts(:,ji,i), (/0, 0, 0/), dir_mask) + do jji=1, atoms_n_neighbours(this, j) + ! fix shifts from j to its neighbors + jj = atoms_neighbour(this, j, jji) + shifts(:,jji,j) = shifts(:,jji,j) + delta_shift(:) + ! fix shifts from j's neighbours to it + do ki=1, atoms_n_neighbours(this, jj) + k = atoms_neighbour(this, jj, ki) + if (k == j) then + shifts(:,ki,jj) = shifts(:,ki,jj) - delta_shift(:) + endif + end do ! ki + end do ! jji + ! shifts(:,ji,i) = 0 + touched(j) = .true. + else + ! atom j doesn't need to move + touched(j) = .true. + endif ! any(shift) /= 0 + end do ! ji + endif ! touched i + end do ! i + end do ! some shift isn't zero + + deallocate(touched) + deallocate(shifts) + deallocate(is_in_cluster) + deallocate(cluster_list) + deallocate(dir_indices) + + end subroutine coalesce_in_one_periodic_image + + function closest_atom(this, r, cell_image_Na, cell_image_Nb, cell_image_Nc, mask, dist, diff, error) + type(Atoms), intent(in) :: this + real(dp), intent(in) :: r(3) + integer, intent(in) :: cell_image_Na, cell_image_Nb, cell_image_Nc + logical, intent(in), optional, dimension(:) :: mask + real(dp), intent(out), optional :: dist, diff(3) + integer :: closest_atom + integer, intent(out), optional :: error + + integer :: i, j, k + integer i2, j2, k2, i3, j3, k3, i4, j4, k4, n2, atom_i + integer :: cellsNa, cellsNb, cellsNc + real(dp) :: pos(3), cur_dist, cur_diff(3), min_dist, min_diff(3) + integer :: min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc + + INIT_ERROR(error) + if (.not. this%connect%initialised) then + RAISE_ERROR("closest_atom must have initialised connection object", error) + end if + + call cell_of_pos(this%connect, this%g .mult. r, i, j, k) + + cellsNa = this%connect%cellsNa + cellsNb = this%connect%cellsNb + cellsNc = this%connect%cellsNc + + call get_min_max_images(this%is_periodic, cellsNa, cellsNb, cellsNc,& + cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k, .true., .true., .true., & + min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc) + + k3 = 1; k4 = 1; j3 = 1; j4 = 1; i3 = 1; i4 = 1 + + min_dist = 1.0e38_dp + closest_atom = 0 + ! Loop over neighbouring cells, applying PBC + do k2 = min_cell_image_Nc, max_cell_image_Nc + + ! the stored cell we are in + if(cellsNc > 1) k3 = mod(k+k2-1+cellsNc,cellsNc)+1 + + ! the shift we need to get to the cell image + k4 = (k+k2-k3)/cellsNc + + do j2 = min_cell_image_Nb, max_cell_image_Nb + ! the stored cell we are in + if(cellsNb > 1) j3 = mod(j+j2-1+cellsNb,cellsNb)+1 + + ! the shift we need to get to the cell image + j4 = (j+j2-j3)/cellsNb + + do i2 = min_cell_image_Na, max_cell_image_Na + ! the stored cell we are in + if(cellsNa > 1) i3 = mod(i+i2-1+cellsNa,cellsNa)+1 + + ! the shift we need to get to the cell image + i4 = (i+i2-i3)/cellsNa + + ! The cell we are currently testing atom1 against is cell(i3,j3,k3) + ! with shift (i4,j4,k4) + ! loop over it's atoms and test connectivity if atom1 < atom2 + + atom_i = this%connect%cell_heads(i3, j3, k3) + atom_i_loop: do while (atom_i > 0) + if (present(mask)) then + if (.not. mask(atom_i)) then + atom_i = this%connect%next_atom_in_cell(atom_i) + cycle atom_i_loop + endif + end if + pos = this%pos(:,atom_i) + ( this%lattice .mult. (/ i4, j4, k4 /) ) + cur_diff = pos - r + cur_dist = norm(cur_diff) + if (cur_dist < min_dist) then + min_dist = cur_dist + min_diff = cur_diff + closest_atom = atom_i + endif + + atom_i = this%connect%next_atom_in_cell(atom_i) + end do atom_i_loop + + end do + end do + end do + + if (present(dist)) dist = min_dist + if (present(diff)) diff = min_diff + + end function closest_atom + + function atoms_is_min_image(this, i, alt_connect, error) result(is_min_image) + type(Atoms), target, intent(in) :: this + integer, intent(in) ::i + type(Connection), intent(inout), target, optional :: alt_connect + integer, intent(out), optional :: error + + logical :: is_min_image + integer :: n, m, NN + type(Connection), pointer :: use_connect + + INIT_ERROR(error) + if (present(alt_connect)) then + use_connect => alt_connect + else + use_connect => this%connect + endif + + is_min_image = .true. + ! First we give the neighbour1 (i <= j) then the neighbour2 entries (i > j) + if (use_connect%initialised) then + + if (.not. associated(use_connect%neighbour1(i)%t)) then + RAISE_ERROR('is_min_image: atoms structure has no connectivity data for atom '//i, error) + end if + + nn = use_connect%neighbour1(i)%t%N + do n=1,nn + if (use_connect%neighbour1(i)%t%int(1,n) == i) then + is_min_image = .false. + return + end if + do m=n+1,nn + if (use_connect%neighbour1(i)%t%int(1,n) == use_connect%neighbour1(i)%t%int(1,m)) then + is_min_image = .false. + return + end if + end do + end do + + nn = use_connect%neighbour2(i)%t%N + do n=1,nn + if (use_connect%neighbour2(i)%t%int(1,n) == i) then + is_min_image = .false. + return + end if + do m=n+1,nn + if (use_connect%neighbour2(i)%t%int(1,n) == use_connect%neighbour2(i)%t%int(1,m)) then + is_min_image = .false. + return + end if + end do + end do + + else + RAISE_ERROR('is_min_image: Atoms structure has no connectivity data. Call calc_connect first.', error) + end if + + endfunction atoms_is_min_image + + subroutine atoms_bcast(mpi, at, test_out, error) + type(MPI_context), intent(in) :: mpi + type(Atoms), intent(inout) :: at + type(Atoms), intent(out), optional :: test_out + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + ! Serial test of atoms_bcast by copying into test_out + ! If test fails add new data elements to ALL THREE sections below + if (present(test_out)) then + call finalise(test_out) + test_out%n = at%n + test_out%ndomain = at%ndomain + test_out%nbuffer = at%nbuffer + test_out%cutoff = at%cutoff + test_out%cutoff_skin = at%cutoff_skin + test_out%nneightol = at%nneightol + test_out%lattice = at%lattice + test_out%is_orthorhombic = at%is_orthorhombic + test_out%is_periodic = at%is_periodic + test_out%fixed_size = at%fixed_size + test_out%properties = at%properties + test_out%params = at%params + call matrix3x3_inverse(test_out%lattice,test_out%g) + call atoms_repoint(test_out) + test_out%ref_count = 1 + end if + + if (.not. mpi%active) return + + if (mpi%my_proc == 0) then + call print('atoms_bcast: bcasting from proc '//mpi%my_proc, PRINT_NERD) + call bcast(mpi, at%n) + call bcast(mpi, at%Ndomain) + call bcast(mpi, at%Nbuffer) + call bcast(mpi, at%cutoff) + call bcast(mpi, at%cutoff_skin) + call bcast(mpi, at%nneightol) + call bcast(mpi, at%lattice) + call bcast(mpi, at%is_orthorhombic) + call bcast(mpi, at%is_periodic) + call bcast(mpi, at%fixed_size) + call bcast(mpi, at%properties) + call bcast(mpi, at%params) + else + call print('atoms_bcast: bcasting to proc '//mpi%my_proc, PRINT_NERD) + call finalise(at) + call bcast(mpi, at%n) + call bcast(mpi, at%Ndomain) + call bcast(mpi, at%Nbuffer) + call bcast(mpi, at%cutoff) + call bcast(mpi, at%cutoff_skin) + call bcast(mpi, at%nneightol) + call bcast(mpi, at%lattice) + call bcast(mpi, at%is_orthorhombic) + call bcast(mpi, at%is_periodic) + call bcast(mpi, at%fixed_size) + call bcast(mpi, at%properties) + call bcast(mpi, at%params) + + call matrix3x3_inverse(at%lattice,at%g) + call initialise(at%domain, error=error) + PASS_ERROR(error) + call atoms_repoint(at) + at%ref_count = 1 + end if + + end subroutine atoms_bcast + + + !% Find the indices of the atoms within the cone with its point at the atom 'origin', + !% defined by direction 'dir' and opening angle with cosine 'cos_theta'. The indices + !% are returned in the Table 'output' which has a single integer column. + subroutine atoms_filter_cone(this, origin, dir, cos_theta, output) + type(Atoms), intent(in) :: this + integer, intent(in) :: origin + real(dp), intent(in), dimension(3) :: dir + real(dp), intent(in) :: cos_theta + type(Table), intent(out) :: output + + real(dp) :: d(3), ndir(3), p + integer :: i + + ndir = dir/norm(dir) + p = ndir .dot. this%pos(:,origin) + + call allocate(output, 1,0,0,0) + do i=1,this%n + if (i == origin) cycle + d = this%pos(:,i) - this%pos(:, origin) + if ((d .dot. ndir) < p .and. (d .dot. ndir)/(norm(d)) > cos_theta) call append(output, i) + end do + + end subroutine atoms_filter_cone + + !% Copy some properties from one atoms struct to another + !% The destination will be overriden. + subroutine atoms_copy_properties(this, from, property_list, case_sensitive, error) + type(Atoms), intent(inout) :: this + type(Atoms), intent(in) :: from + character(len=*), intent(in) :: property_list + logical, optional, intent(in) :: case_sensitive + integer, optional, intent(out) :: error + + character(len=len_trim(property_list)) :: property_a(100) + integer :: property_a_n + + INIT_ERROR(error) + + call split_string_simple(trim(property_list), property_a, property_a_n, ':', error) + PASS_ERROR(error) + call subset(from%properties, property_a(1:property_a_n), this%properties, case_sensitive=case_sensitive, out_no_initialise=.true., error=error) + PASS_ERROR(error) + + end subroutine atoms_copy_properties + + + !% sort atoms according to an externally provided field + subroutine atoms_sort_by_rindex(this, sort_index, error) + type(Atoms), intent(inout) :: this + real(DP), dimension(this%N), intent(in) :: sort_index + integer, optional, intent(out) :: error + + ! --- + + real(DP), allocatable :: my_sort_index(:) + integer, allocatable :: atom_index(:) + + integer :: i + + ! --- + + INIT_ERROR(error) + + allocate(my_sort_index(this%N), atom_index(this%N)) + + do i = 1, this%N + my_sort_index(i) = sort_index(i) + atom_index(i) = i + enddo + + call heap_sort(my_sort_index, i_data=atom_index) + + call shuffle(this, atom_index, error=error) + PASS_ERROR(error) + + deallocate(my_sort_index, atom_index) + + endsubroutine atoms_sort_by_rindex + + + !% Basis transformation of rank 0, 1 and 2 tensors real values in Atoms object. + !% This routine transforms rank 1 and rank 2 tensors in this%params and + !% this%properties. Tensors are identified by having the correct type + !% (real arrays) and shape (i.e. 3, (3, 3), (3, this%N) (9, this%N) for + !% vector paramters, tensor parameters, vector properties and tensor + !% properties respectively), and by having a name which is included in + !% the relevant list. Extra names can be added to the lists with the + !% rank1 and rank2 arguments. + subroutine atoms_transform_basis(this, L, rank1, rank2, error) + type(Atoms), intent(inout) :: this + real(dp), dimension(3,3) :: L + character(len=*), optional, intent(in) :: rank1, rank2 + integer, optional, intent(out) :: error + + character(len=*), parameter :: default_rank1 = "pos:velo:acc:avgpos:oldpos:force:efield:dipoles" + character(len=*), parameter :: default_rank2 = "virial:local_virial" + + character(len=STRING_LENGTH) :: all_rank1, all_rank2 + character(len=C_KEY_LEN) :: fields(100) + integer i, j, n_fields + type(Dictionary) :: rank1_d, rank2_d + real(dp), pointer :: v(:), v2(:,:) + + INIT_ERROR(error) + + if (.not. is_orthogonal(L)) then + call print('L=') + call print(L) + RAISE_ERROR("atoms_transform_basis: transformation matrix L is not orthogonal", error) + end if + + all_rank1 = default_rank1 + if (present(rank1)) all_rank1 = trim(all_rank1)//':'//rank1 + call split_string_simple(all_rank1, fields, n_fields, ':', error) + PASS_ERROR(error) + call initialise(rank1_d) + do i=1,n_fields + call set_value(rank1_d, fields(i), .true.) + end do + + all_rank2 = default_rank2 + if (present(rank2)) all_rank2 = trim(all_rank2)//':'//rank2 + call split_string_simple(all_rank2, fields, n_fields, ':', error) + PASS_ERROR(error) + call initialise(rank2_d) + do i=1,n_fields + call set_value(rank2_d, fields(i), .true.) + end do + + ! Special case: transform lattice as 3 separate rank 1 tensors + call set_lattice(this,(L .mult. this%lattice), scale_positions=.false.) + + ! First we consider entries in at%params + do i=1, this%params%n + ! Is it a real 3-vector? + if (assign_pointer(this%params, string(this%params%keys(i)), v)) then + if (has_key(rank1_d, string(this%params%keys(i))) .and. size(v) == 3) then + call print('atoms_transform_basis: transforming '//this%params%keys(i)//' as a rank 1 tensor', PRINT_VERBOSE) + v = L .mult. v + end if + end if + + ! Is it a real 3x3 matrix? + if (assign_pointer(this%params, string(this%params%keys(i)), v2)) then + if (has_key(rank2_d, string(this%params%keys(i))) .and. all(shape(v2) == (/3,3/))) then + call print('atoms_transform_basis: transforming '//this%params%keys(i)//' as a rank 2 tensor', PRINT_VERBOSE) + v2 = L .mult. v2 .mult. transpose(L) + end if + end if + end do + + ! Now for the atomic properties in at%properties + do i=1, this%properties%n + ! Is it a per-atom 3-vector + if (assign_pointer(this%properties, string(this%properties%keys(i)), v2)) then + if (has_key(rank1_d, string(this%properties%keys(i))) .and. size(v2,1) == 3) then + call print('atoms_transform_basis: transforming '//this%properties%keys(i)//' as a rank 1 tensor', PRINT_VERBOSE) + do j=1,this%n + v2(:,j) = L .mult. v2(:,j) + end do + end if + end if + + ! Is it a per-atom 3x3 matrix, arranged as a 9 column property? + if (assign_pointer(this%properties, string(this%properties%keys(i)), v2)) then + if (has_key(rank2_d, string(this%properties%keys(i))) .and. size(v2, 1) == 9) then + call print('atoms_transform_basis: transforming '//this%properties%keys(i)//' as a rank 2 tensor', PRINT_VERBOSE) + do j=1,this%n + v2(:,j) = reshape(L .mult. reshape(v2(:,j),(/3,3/)) .mult. transpose(L), (/9/)) + end do + end if + end if + end do + + call finalise(rank1_d) + call finalise(rank2_d) + + end subroutine atoms_transform_basis + + !% Rotate this Atoms object, transforming all rank 1 and rank 2 tensors parameters and properties + subroutine atoms_rotate(this, axis, angle, rank1, rank2) + type(Atoms), intent(inout) :: this + real(dp), intent(in) :: axis(3), angle + character(len=*), optional, intent(in) :: rank1, rank2 + + type(Quaternion) :: q + real(dp) :: R(3,3) + + q = rotation(axis, angle) + R = rotation_matrix(q) + call transform_basis(this, R, rank1, rank2) + + end subroutine atoms_rotate + + !% Convert from a single index in range 1..this%N to a CASTEP-style (element, index) pair + function atoms_index_to_z_index(this, index) result(z_index) + type(Atoms), intent(in) :: this + integer, intent(in) :: index + integer :: z_index + integer :: j + + z_index = 0 + do j=1,index + if (this%z(index) == this%z(j)) z_index = z_index + 1 + end do + + end function atoms_index_to_z_index + + !% Inverse of atoms_index_to_z_index + function atoms_z_index_to_index(this, z, z_index, error) result(index) + type(Atoms), intent(in) :: this + integer, intent(in) :: z, z_index + integer, intent(out), optional :: error + integer :: index + integer :: nz + + INIT_ERROR(error) + + nz = 0 + do index=1,this%N + if(this%z(index) == z) nz = nz + 1 + if (nz == z_index) return + end do + + RAISE_ERROR('atoms_z_index_to_index: index pair ('//z//','//z_index//') not found', error) + + end function atoms_z_index_to_index + + + !% Test if an atom 'j' is one of 'i's nearest neighbours + function is_nearest_neighbour_abs_index(this,i,j, alt_connect) + type(Atoms), intent(in), target :: this + integer, intent(in) :: i,j + type(Connection), intent(in), optional, target :: alt_connect + logical :: is_nearest_neighbour_abs_index + + integer :: ji + real(dp) :: d + + is_nearest_neighbour_abs_index = .false. + do ji=1, atoms_n_neighbours(this, i) + if (atoms_neighbour(this, i, ji, distance=d, alt_connect=alt_connect) == j) then + if (d < bond_length(this%Z(i),this%Z(j))*this%nneightol) then + is_nearest_neighbour_abs_index = .true. + return + endif + endif + end do + end function is_nearest_neighbour_abs_index + + + !% Test if an atom's $n$th neighbour is one if its nearest neighbours + function is_nearest_neighbour(this,i,n, alt_connect) + + type(Atoms), intent(in), target :: this + integer, intent(in) :: i,n + type(Connection), intent(in), optional, target :: alt_connect + logical :: is_nearest_neighbour + + real(dp) :: d + integer :: j + + is_nearest_neighbour = .false. + + j = atoms_neighbour(this, i, n, distance=d, alt_connect=alt_connect) + if (d < (bond_length(this%Z(i),this%Z(j))*this%nneightol)) & + is_nearest_neighbour = .true. + + end function is_nearest_neighbour + + + !% As for 'calc_connect', but perform the connectivity update + !% hystertically: atoms must come within a relative distance of + !% 'cutoff_factor' to be considered neighbours, and then will remain + !% connected until them move apart further than a relative distance + !% of 'cutoff_break_factor' (all cutoff factors are relative + !% to covalent radii). + !% + !% Typically 'alt_connect' should be set to the + !% 'hysteretic_connect' attribute. 'origin' and 'extent' + !% vectors can be used to restrict the hysteretic region to only + !% part of the entire system -- the 'estimate_origin_extent()' + !% routine in clusters.f95 can be used to guess suitable values. + subroutine atoms_calc_connect_hysteretic(this, cutoff_factor, cutoff_break_factor, alt_connect, & + origin, extent, own_neighbour, store_is_min_image, store_n_neighb, error) + type(Atoms), intent(inout), target :: this + real(dp), intent(in) :: cutoff_factor, cutoff_break_factor + type(Connection), intent(inout), target, optional :: alt_connect + real(dp), optional, intent(in) :: origin(3), extent(3,3) + logical, optional, intent(in) :: own_neighbour, store_is_min_image, store_n_neighb + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if (this%pot_should_do_nn) this%pot_needs_new_connect = .true. + + if (present(alt_connect)) then + call calc_connect_hysteretic(alt_connect, this, cutoff_factor, cutoff_break_factor, & + origin, extent, own_neighbour, store_is_min_image, store_n_neighb, error) + PASS_ERROR(error) + else + call calc_connect_hysteretic(this%connect, this, cutoff_factor, cutoff_break_factor, & + origin, extent, own_neighbour, store_is_min_image, store_n_neighb, error) + PASS_ERROR(error) + endif + + end subroutine atoms_calc_connect_hysteretic + + + !% Fast $O(N)$ connectivity calculation routine. It divides the unit + !% cell into similarly shaped subcells, of sufficient size that + !% sphere of radius 'cutoff' is contained in a subcell, at least in + !% the directions in which the unit cell is big enough. For very + !% small unit cells, there is only one subcell, so the routine is + !% equivalent to the standard $O(N^2)$ method.> + !% If 'own_neighbour' is true, atoms can be neighbours with their + !% own periodic images. + !% If 'cutoff_skin' is present, effective cutoff is increased by this + !% amount, and full recalculation of connectivity is only done when + !% any atom has moved more than 0.5*cutoff_skin - otherwise + !% calc_dists() is called to update the stored distance tables. + subroutine atoms_calc_connect(this, alt_connect, own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb, max_pos_change, did_rebuild, error) + type(Atoms), intent(inout) :: this + type(Connection), optional, intent(inout) :: alt_connect + logical, optional, intent(in) :: own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb + real(dp), optional, intent(out) :: max_pos_change + logical, optional, intent(out) :: did_rebuild + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if (this%pot_should_do_nn) this%pot_needs_new_connect = .true. + + if (present(alt_connect)) then + call calc_connect(alt_connect, this, & + own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb, this%cutoff_skin, & + max_pos_change, did_rebuild, error) + PASS_ERROR(error) + else + call calc_connect(this%connect, this, & + own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb, this%cutoff_skin, & + max_pos_change, did_rebuild, error) + PASS_ERROR(error) + endif + + end subroutine atoms_calc_connect + + + !% Update stored distance tables. To be called after moving atoms, in between calls to calc_connect(). + subroutine atoms_calc_dists(this, alt_connect, parallel, error) + type(Atoms), intent(inout) :: this + type(Connection), optional, intent(inout) :: alt_connect + logical, optional, intent(in) :: parallel + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if (this%pot_should_do_nn) this%pot_needs_new_dists = .true. + + if (present(alt_connect)) then + call calc_dists(alt_connect, this, parallel, error) + PASS_ERROR(error) + else if (this%connect%initialised) then + call calc_dists(this%connect, this, parallel, error) + PASS_ERROR(error) + end if + + end subroutine atoms_calc_dists + + + !% Set which properties to communicate when + !% comm_atoms: Communicate when atom is moved to different domain. + !% Forces, for example, may be excluded since they are updated + !% on every time step. + !% comm_ghosts: Communicate when atom is dublicated as a ghost on a domain. + !% Masses, for example, might be excluded since atoms are + !% propagated on the domain they reside in only. + !% comm_reverse: Communicate back from ghost atoms to the original domain atom + !% and accumulate + !% By default, properties are not communicated. + subroutine atoms_set_comm_property(this, propname, & + comm_atoms, comm_ghosts, comm_reverse) + implicit none + + type(Atoms), intent(inout) :: this + character(*), intent(in) :: propname + logical, optional, intent(in) :: comm_atoms + logical, optional, intent(in) :: comm_ghosts + logical, optional, intent(in) :: comm_reverse + + ! --- + + call set_comm_property(this%domain, propname, & + comm_atoms, comm_ghosts, comm_reverse) + + endsubroutine atoms_set_comm_property + + + !% set Zs from species + subroutine atoms_set_Zs(this, error) + type(Atoms), intent(inout) :: this + integer, intent(out), optional :: ERROR + + integer i, ii + + INIT_ERROR(error) + + do i=1, this%N + ii = find_in_array(ElementName, a2s(this%species(:,i))) + if (ii < 1) then + RAISE_ERROR("failed to match name of atom "//i//" '"//a2s(this%species(:,i))//"'", error) + endif + this%Z(i) = ii-1 + end do + end subroutine atoms_set_Zs + + !% undo pbc jumps, assuming nearest periodic image, with or without persistent atoms object + !% without persistent atoms object, global storage is used, and calling on multiple trajcetories + !% interspersed will not work + subroutine undo_pbc_jumps(at, persistent) + type(Atoms), intent(inout) :: at + logical, optional, intent(in) :: persistent + + logical :: my_persistent + real(dp), pointer :: prev_pos_p(:,:) + + my_persistent = optional_default(.true., persistent) + if (.not. my_persistent) then + if (.not. allocated(save_prev_pos)) then + allocate(save_prev_pos(3, at%N)) + save_prev_pos = at%pos + else + if (size(save_prev_pos,2) /= at%N) then + call system_abort("undo_pbc_jumps got not persistent, but shape(save_prev_pos) "//shape(save_prev_pos)//" does not match shape(at%pos) "//shape(at%pos)) + endif + endif + prev_pos_p => save_prev_pos + else + if (.not. assign_pointer(at, 'prev_pos', prev_pos_p)) then + call add_property(at, 'prev_pos', 0.0_dp, n_cols=3, ptr2=prev_pos_p) + prev_pos_p = at%pos + endif + end if + + at%pos = at%pos - (at%lattice .mult. floor((at%g .mult. (at%pos-prev_pos_p))+0.5_dp)) + prev_pos_p = at%pos + end subroutine undo_pbc_jumps + + !% undo center of mass motion, with or without persistent atoms object + !% without persistent atoms object, global storage is used, and calling on multiple trajcetories + !% interspersed will not work + subroutine undo_CoM_motion(at, persistent) + type(Atoms), intent(inout) :: at + logical, optional, intent(in) :: persistent + + integer :: i + real(dp) :: orig_CoM(3), CoM(3), delta_CoM(3) + logical :: my_persistent + + my_persistent = optional_default(.true., persistent) + + ! calc current CoM + if (.not. has_property(at, 'mass')) then + call add_property(at, 'mass', 0.0_dp) + at%mass = ElementMass(at%Z) + endif + CoM = centre_of_mass(at, origin=0) + + if (my_persistent) then + ! get orig_CoM from at%params + if (.not. get_value(at%params, 'orig_CoM', orig_CoM)) then + orig_CoM = CoM + call set_value(at%params, 'orig_CoM', orig_CoM) + endif + else + ! get orig_CoM from save_orig_CoM + if (.not. allocated(save_orig_CoM)) then + allocate(save_orig_CoM(3)) + save_orig_CoM = CoM + orig_CoM = CoM + else + orig_CoM = save_orig_CoM + endif + endif + + delta_CoM = orig_CoM - CoM + do i=1, at%N + at%pos(:,i) = at%pos(:,i) + delta_CoM + end do + + end subroutine undo_CoM_motion + + !% calculate mean squared displacement, with or without persistent atoms object + !% without persistent atoms object, global storage is used, and calling on multiple trajcetories + !% interspersed will not work. + !% usually desirable to call undo_pbc_jumps and undo_CoM_motion first + subroutine calc_msd(at, mask, reset_msd, persistent) + type(Atoms), intent(inout) :: at + logical, optional, intent(in) :: mask(:), reset_msd, persistent + + logical :: my_reset_msd, my_persistent + real(dp), pointer :: orig_pos_p(:,:), msd_displ_p(:,:), msd_displ_mag_p(:) + + my_reset_msd = optional_default(.false., reset_msd) + my_persistent = optional_default(.true., persistent) + + ! get/save orig_pos + if (.not. my_persistent) then + if (.not. allocated(save_orig_pos)) then + allocate(save_orig_pos(3, at%N)) + save_orig_pos = at%pos + else + if (size(save_orig_pos,2) /= at%N) then + call system_abort("calc_msd got not persistent, but shape(save_orig_pos) "//shape(save_orig_pos)//" does not match shape(at%pos) "//shape(at%pos)) + endif + endif + orig_pos_p => save_orig_pos + else + if (.not. assign_pointer(at, 'orig_pos', orig_pos_p)) then + call add_property(at, 'orig_pos', 0.0_dp, n_cols=3, ptr2=orig_pos_p) + orig_pos_p = at%pos + endif + end if + if (my_reset_msd) orig_pos_p = at%pos + + if (.not. assign_pointer(at, 'msd_displ', msd_displ_p)) then + call add_property(at, 'msd_displ', 0.0_dp, n_cols=3, ptr2 = msd_displ_p) + endif + if (.not. assign_pointer(at, 'msd_displ_mag', msd_displ_mag_p)) then + call add_property(at, 'msd_displ_mag', 0.0_dp, n_cols=1, ptr = msd_displ_mag_p) + endif + + msd_displ_p = at%pos - orig_pos_p + msd_displ_mag_p = sum(msd_displ_p**2, 1) + + if (present(mask)) then + call set_value(at%params, 'msd', sum(msd_displ_mag_p,mask=mask)/real(count(mask),dp)) + else + call set_value(at%params, 'msd', sum(msd_displ_mag_p)/real(at%N,dp)) + endif + + end subroutine calc_msd + + subroutine fake_smooth_pos(at, mix, persistent) + type(Atoms), intent(inout) :: at + real(dp), intent(in) :: mix + logical, optional, intent(in) :: persistent + + logical :: my_persistent + real(dp), pointer :: smooth_pos_p(:,:) + real(dp) :: smooth_lattice(3,3) + + my_persistent = optional_default(.true., persistent) + + if (.not. my_persistent) then + if (.not. allocated(save_smooth_pos)) then ! first config + allocate(save_smooth_pos(3, at%N)) + save_smooth_pos = at%pos + save_smooth_lattice = at%lattice + else ! later config + if (size(save_smooth_pos,2) /= at%N) then + call system_abort("calc_msd got not persistent, but shape(save_smooth_pos) "//shape(save_smooth_pos)//" does not match shape(at%pos) "//shape(at%pos)) + endif + endif + smooth_pos_p => save_smooth_pos + call add_property_from_pointer(at, 'smooth_pos', smooth_pos_p) + else ! persistent + if (.not. assign_pointer(at, 'smooth_pos', smooth_pos_p)) then + call add_property(at, 'smooth_pos', 0.0_dp, n_cols=3, ptr2=smooth_pos_p) + smooth_pos_p = at%pos + endif + call get_param_value(at, 'smooth_lattice', save_smooth_lattice) + end if + + smooth_pos_p = (1.0_dp-mix)*smooth_pos_p + mix*at%pos + smooth_lattice = (1.0_dp-mix)*save_smooth_lattice + mix*at%lattice + call set_param_value(at, 'smooth_lattice', smooth_lattice) + + if (.not. my_persistent) save_smooth_lattice = smooth_lattice + + end subroutine fake_smooth_pos + +end module atoms_module diff --git a/src/libAtoms/Atoms_ll.F90 b/src/libAtoms/Atoms_ll.F90 new file mode 100644 index 0000000000..0852c97dc7 --- /dev/null +++ b/src/libAtoms/Atoms_ll.F90 @@ -0,0 +1,391 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!% Atoms_ll_module +!% linked list of Atoms structures, read in from one or more xyz files, with +!% some automatic time sorting/clean-up capability + +#include "error.inc" + +module Atoms_ll_module +use error_module +use system_module +use extendable_str_module +use dictionary_module +use atoms_module +use cinoutput_module +implicit none +private + +public :: atoms_ll, atoms_ll_entry + +type atoms_ll + type (atoms_ll_entry), pointer :: first => null() + type (atoms_ll_entry), pointer :: last => null() +end type atoms_ll + +type atoms_ll_entry + type(atoms) :: at + type(atoms_ll_entry), pointer :: next => null() + type(atoms_ll_entry), pointer :: prev => null() + real(dp) :: r_index = -1.0_dp +end type atoms_ll_entry + +public :: initialise, finalise, print_xyz, read_xyz, new_entry, remove_last_entry + +interface initialise + module procedure atoms_ll_initialise, atoms_ll_entry_initialise +end interface initialise + +interface finalise + module procedure atoms_ll_finalise, atoms_ll_entry_finalise +end interface finalise + +!% print all configs in atoms_ll object +interface print_xyz + module procedure atoms_ll_print_xyz +end interface + +!% read configs into atoms_ll object +interface read_xyz + module procedure atoms_ll_read_xyz_filename +end interface + +!% add new entry to atoms linked list structure +interface new_entry + module procedure atoms_ll_new_entry +end interface new_entry + +!% remove last entry from atoms linked list structure +interface remove_last_entry + module procedure atoms_ll_remove_last_entry +end interface remove_last_entry + +contains + + subroutine atoms_ll_initialise(this) + type(Atoms_ll), intent(inout) :: this + + call finalise(this) + end subroutine atoms_ll_initialise + + subroutine atoms_ll_finalise(this) + type(Atoms_ll), intent(inout) :: this + + type(atoms_ll_entry), pointer :: entry, next + + entry => this%first + do while (associated(entry)) + next => entry%next + call finalise(entry) + entry => next + end do + this%first => null() + this%last => null() + end subroutine atoms_ll_finalise + + subroutine atoms_ll_entry_initialise(this) + type(Atoms_ll_entry), intent(inout) :: this + + call finalise(this) + end subroutine atoms_ll_entry_initialise + + subroutine atoms_ll_entry_finalise(this) + type(Atoms_ll_entry), intent(inout) :: this + + call finalise(this%at) + this%next => null() + this%prev => null() + end subroutine atoms_ll_entry_finalise + + subroutine atoms_ll_new_entry(this, atoms_p, before, after) + type(atoms_ll), target, intent(inout) :: this !% this: atoms_ll object to add to + type(atoms), intent(inout), pointer :: atoms_p !% atoms_p: pointer to atoms object to insert + type(atoms_ll_entry), intent(in), target, optional :: before, after !% before, after: if present, put in new entry before/after this one + !% before and after are mutually exclusive + + type(atoms_ll_entry), pointer :: my_before, my_after + type(atoms_ll_entry), pointer :: entry + + if (present(before) .and. present(after)) call system_abort("atoms_ll_new_entry got both before and after") + + if (present(before)) then + my_before => before + my_after => before%prev + else if (present(after)) then + my_before => after%next + my_after => after + else + my_after => this%last + my_before => null() + endif + + allocate(entry) + if (associated(my_before)) then + my_before%prev => entry + entry%next => my_before + else + this%last => entry + endif + if (associated(my_after)) then + my_after%next => entry + entry%prev => my_after + else + this%first => entry + endif + + atoms_p => entry%at + end subroutine atoms_ll_new_entry + + subroutine atoms_ll_remove_last_entry(this) + type(atoms_ll), target, intent(inout) :: this + + if (associated(this%last)) then + call finalise(this%last%at) + if (associated(this%last%prev)) nullify(this%last%prev%next) + this%last => this%last%prev + if (.not. associated (this%last)) nullify(this%first) + endif + + end subroutine atoms_ll_remove_last_entry + + + subroutine atoms_ll_print_xyz(this, xyzfile, comment, properties, real_format, mask) + type(Atoms_ll), intent(inout) :: this !% Atoms_ll object to print + type(CInoutput), intent(inout) :: xyzfile !% CInOutput object to write to + character(*), optional, intent(in) :: properties !% List of properties to print + character(*), optional, intent(in) :: comment !% Comment line (line #2 of xyz file) + character(len=*), optional, intent(in) :: real_format !% format of real numbers in output + logical, optional, intent(in) :: mask(:) !% mask of which atoms to print + + + type(extendable_str) :: my_comment + type(atoms_ll_entry), pointer :: entry + integer :: i + + call initialise(my_comment) + if (present(comment)) call concat(my_comment, comment) + + if (present(mask)) call system_abort('atoms_ll_print_xyz: mask argument not currently supported. if you need it, please reimplement!') + + entry => this%first + i = 1 + do while (associated(entry)) + call set_value(entry%at%params, 'comment', my_comment) + call set_value(entry%at%params, 'atoms_ll_i', i) + call write(xyzfile, entry%at, properties, real_format=real_format) + entry => entry%next + i = i + 1 + end do + call finalise(my_comment) + + end subroutine atoms_ll_print_xyz + + !% reads a sequence of configurations with cinoutput, optionally skipping every decimation frames, + !% ignoring things outside of min_time--max_time, sorting by Time value and eliminating configs with + !% duplicate Time values. + subroutine atoms_ll_read_xyz_filename(this, filename, file_is_list, decimation, min_time, max_time, sort_Time, no_Time_dups, quiet, no_compute_index, & + properties, all_properties, error) + type(atoms_ll) :: this !% object to read configs into + character(len=*), intent(in) :: filename !% file name to read from + logical, intent(in) :: file_is_list !% is true, file is list of files to read from rather than xyz file + integer, intent(in), optional :: decimation !% only read one out of every decimation frames + real(dp), intent(in), optional :: min_time, max_time !% ignore frames before min_time or after max_time + character(len=*), intent(in), optional :: properties !% properties to include in objects in list + logical, intent(in), optional :: sort_Time, no_Time_dups, quiet, no_compute_index, all_properties + integer, intent(out), optional :: error + !% sort_time: if true, sort configurations by time + !% no_Times_dups: if true, eliminate configs that have same time value + !% quiet: if true, don't output progress bar + !% no_compute_index: if true, don't compute index for xyz file + !% do_all_properties: if true, include all properties in save Atoms structures + + integer :: status + integer :: frame_count, last_file_frame_n + type(CInOutput) :: cfile + type(Inoutput) file_list + character(len=len(filename)) my_filename + type(Atoms) :: structure_in + type(Atoms), pointer :: structure + logical :: skip_frame + real(dp) :: cur_time, entry_time, entry_PREV_time + integer :: do_decimation + real(dp) :: do_min_time, do_max_time + logical :: do_sort_Time, do_no_Time_dups, do_quiet, do_no_compute_index + type(Atoms_ll_entry), pointer :: entry + logical :: is_a_dup, do_all_properties + character(len=STRING_LENGTH) :: my_properties + integer :: initial_frame_count + integer :: l_error + + INIT_ERROR(error) + my_properties = optional_default("species:pos:Z", properties) + do_all_properties = optional_default(.false., all_properties) + do_decimation = optional_default(1, decimation) + do_min_time = optional_default(-1.0_dp, min_time) + do_max_time = optional_default(-1.0_dp, max_time) + do_sort_Time = optional_default(.false., sort_Time) + do_no_Time_dups = optional_default(.false., no_Time_dups) + do_quiet = optional_default(.false., quiet) + do_no_compute_index = optional_default(.false., no_compute_index) + + if (len_trim(my_properties) == 0) then + call print("WARNING: len_trim(my_properties) == 0, doing all_properties") + do_all_properties=.true. + endif + + if (do_no_Time_dups .and. .not. do_sort_Time) then + RAISE_ERROR("ERROR: atoms_ll_read_xyz no_Times_dups requires sort_Time", error) + endif + + if (do_decimation /= 1 .and. do_no_Time_dups) then + RAISE_ERROR("ERROR: atoms_ll_read_xyz decimation="//do_decimation//" /= 1 and no_Time_dups=T conflict", error) + endif + + if (file_is_list) then + call initialise(file_list, trim(filename), INPUT) + my_filename = read_line(file_list) + else + my_filename = trim(filename) + endif + + cur_time = 1.0_dp + last_file_frame_n = 0 + frame_count = 1 + status = 0 + l_error = ERROR_NONE + do while (l_error == ERROR_NONE) ! loop over files + call initialise(cfile,trim(my_filename),action=INPUT, no_compute_index=do_no_compute_index) + initial_frame_count = frame_count + do while (l_error == ERROR_NONE) ! loop over frames in this file + if (.not. do_quiet) write(mainlog%unit,'(4a,i0,a,i0,$)') achar(13), 'Read file ',trim(my_filename), & + ' Frame ',frame_count,' which in this file is frame (zero based) ',(frame_count-1-last_file_frame_n) + ! if (.not. do_quiet) write(mainlog%unit,'(3a,i0,a,i0)') 'Read file ',trim(my_filename), & + ! ' Frame ',frame_count,' which in this file is frame (zero based) ',(frame_count-1-last_file_frame_n) + call read(cfile, structure_in, frame=frame_count-1-last_file_frame_n, error=l_error) + + if (l_error == ERROR_NONE) then ! we succesfully read a structure + skip_frame = .false. + is_a_dup = .false. + if (do_min_time > 0.0_dp .or. do_max_time > 0.0_dp .or. do_sort_Time .or. no_Time_dups) then ! we need Time value + if (get_value(structure_in%params,"Time",cur_time, case_sensitive=.false.)) then + if ((do_min_time >= 0.0_dp .and. cur_time < do_min_time) .or. (do_max_time >= 0.0_dp .and. cur_time > do_max_time)) skip_frame = .true. + else + RAISE_ERROR("ERROR: min_time="//do_min_time//" < 0 or max_time="//do_max_time//" < 0 or sort_Time="//do_sort_Time//", but Time field wasn't found in config " // frame_count, error) + endif + endif + if (.not. skip_frame) then ! frame is in appropriate time range + if (do_sort_Time) then ! sort by Time value + ! look at LAST entry + if (associated(this%LAST)) then + entry => this%LAST + !NB if (.not. get_value(entry%at%params, "Time", entry_time, case_sensitive=.false.)) call system_abort("atoms_ll_read_xyz sort missing Time for LAST entry") + entry_time = entry%r_index + !NB + else ! no structure list yet, fake entry_time + entry_time = -1.0e38_dp + nullify(entry) + endif + if (cur_time <= entry_time) then ! new frame is at or BEFORE LAST entry + do while (associated(entry)) + !NB if (.not. get_value(entry%at%params, "Time", entry_time, case_sensitive=.false.)) call system_abort("atoms_ll_read_xyz sort missing Time for entry") + entry_time = entry%r_index + !NB + if (do_no_Time_dups .and. (cur_time == entry_time)) then ! entries match in time, i.e. duplicates + is_a_dup = .true. + exit + endif + ! check time of PREV entry + if (associated(entry%PREV)) then + !NB if (.not. get_value(entry%PREV%at%params, "Time", entry_PREV_time, case_sensitive=.false.)) call system_abort("atoms_ll_read_xyz sort missing Time for entry%PREV") + entry_PREV_time = entry%PREV%r_index + !NB + ! if cur_time is <= entry, and cur_time > entry%PREV, we want to insert AFTER entry%prev, so decrement entry and exit now + if ((cur_time <= entry_time) .and. (cur_time > entry_PREV_time)) then + entry => entry%PREV + exit + endif + endif + ! otherwise we keep on going + entry => entry%PREV ! entry will be unassociated, and therefore loop will end, if we got to beginning of list + end do ! associated(entry) + end if ! cur frame was BEFORE last entry + ! we skipped previous section if cur_time > entry_time for LAST entry, so we want to insert AFTER entry=this%LAST + else ! no sorting in time, so always insert AFTER last + entry => this%last + endif + if (.not. is_a_dup) then + if (associated(entry)) then ! we want to insert AFTER entry + call new_entry(this, structure, AFTER=entry) + entry%NEXT%r_index = cur_time + else ! entry is unassociated, therefore we insert and the BEGINNING of the list + call new_entry(this, structure, BEFORE=this%FIRST) + this%FIRST%r_index = cur_time + endif + ! actually copy the structure + if (do_all_properties) then + call atoms_copy_without_connect(structure, structure_in) + else + call atoms_copy_without_connect(structure, structure_in, properties=my_properties) + endif + endif + if (.not. do_quiet) write (mainlog%unit,'(a,$)') " " + ! if (.not. do_quiet) write (mainlog%unit,'(a)') " " + else ! skip_frame was true, we're skipping + if (.not. do_quiet) write (mainlog%unit,'(a,$)') " skip " + ! if (.not. do_quiet) write (mainlog%unit,'(a)') " skip" + endif ! skip_frame + frame_count = frame_count + do_decimation + else + CLEAR_ERROR(error) + endif ! l_error == 0 for reading this structure + + end do ! while l_error == 0 for frames in this file + if (cfile%got_index) then + last_file_frame_n = last_file_frame_n + cfile%n_frame + else + last_file_frame_n = last_file_frame_n + cfile%current_frame + endif + !call print("at end of file, frame_count " // frame_count // " last_file_frame_n " // last_file_frame_n) + call finalise(cfile) + + if (file_is_list) then + my_filename = read_line(file_list, status) + if (status /= 0) call finalise(file_list) + else + status = 1 + endif + + end do ! while status == 0 for each file + + if (.not. quiet) call print("") + end subroutine atoms_ll_read_xyz_filename + +end module Atoms_ll_module diff --git a/src/libAtoms/Atoms_types.F90 b/src/libAtoms/Atoms_types.F90 new file mode 100644 index 0000000000..c6b56db8ff --- /dev/null +++ b/src/libAtoms/Atoms_types.F90 @@ -0,0 +1,1779 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Atoms_types module +!X +!X 'Header' module that contains the data structures for +!X 1. Atoms +!X 2. Connection +!X 3. DomainDecomposition +!X plus methods for manipulating properties. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module Atoms_types_module + + use error_module + use system_module + use units_module + use periodictable_module + use linearalgebra_module + use MPI_context_module + use extendable_str_module + use dictionary_module + use table_module + + implicit none + private + + public :: DEFAULT_NNEIGHTOL + real(dp), parameter :: DEFAULT_NNEIGHTOL = 1.2_dp !% Default value for 'atoms%nneightol' + + public :: DD_WRAP_TO_CELL, DD_WRAP_TO_DOMAIN + + integer, parameter :: DD_WRAP_TO_CELL = 1 !% All particles, including ghosts, are wrapped into the cell + integer, parameter :: DD_WRAP_TO_DOMAIN = 2 !% Particles are wrapped into the domain, ghost particles are + !% located next to the domain. + + public :: Table_pointer + type Table_pointer + type(Table), pointer :: t => null() + end type Table_pointer + + public :: Connection + type Connection + !% The Connection type stores the topology of a set of Atoms + !% + !% We do not use a minimum image convention, rather, collect all the images of a neigbouring atoms + !% that fall within the neighbour cutoff. The different images are made distinct in the connection list + !% by having different 'shift' vectors associated with them. + !% + !% To save storage, the 'neighbour1' table contains all information about the connection + !% but is only filled in for $i <= j$. 'neighbour2' is just a list of those of $i$'s neighbours + !% with $i > j$ together with an index into the 'neighbour1' table of atom $j$. + !% + !% In normal use (i.e. outside this module) you don\'t need direct access to the tables + !% so you should use the interface functions 'atoms_n_neighbours' and 'atoms_neighbour' which + !% hide the distiction between the cases $i <= j$ and $i > j$. + !% + !% :class:`Table` :attr:`neighbour1` (i): $i \le j$ for all $j$ in table, ``intsize=4``, ``realsize=1`` + !% + !% 'connect%neighbour1(i)%int' + !% + !%> +----------+----------+----------+----------+ + !%> | 1 | 2 | 3 | 4 | + !%> +----------+----------+----------+----------+ + !%> | j | shift_a | shift_b | shift_c | + !%> +----------+----------+----------+----------+ + !% + !% 'connect%neighbour1(i)%real' + !% + !%> +----------+ + !%> | 1 | + !%> +----------+ + !%> | r_ij | + !%> +----------+ + !% + !% :class:`Table` :attr:`neighbour2` (i): $i > j$ for all $j$ in table, ``intsize =2``, ``realsize=0`` + !% + !% 'connect%neighbour2(i)%int' + !% + !%> +----------+----------+ + !%> | 1 | 2 | + !%> +----------+----------+ + !%> | j | n | + !%> +----------+----------+ + !% + !% :class:`Table` :attr:`cell` (i,j,k) with ``intsize = 1``, ``realsize = 0`` + !% + !% 'connect%cell(i,j,k)2%int' + !% + !%> +----------+ + !%> | 1 | + !%> +----------+ + !%> | atom | + !%> +----------+ + !% + !% N.B. If $i$ and $j$ are neighbours with shift 'shift', then + !% 'norm(atoms%pos(j) - atoms%pos(i) + shift)' is a minimum. + !% Mnemonic: 'shift' is added to $j$ to get closer to $i$. + + logical :: initialised = .false. + logical :: cells_initialised = .false. + logical :: too_few_cells_warning_issued = .false. + + integer :: cellsNa !% no. of cells in the lattice directions + integer :: cellsNb, cellsNc + + integer :: N = -1 !% no. of atoms at last calc_connect + + type(table_pointer), allocatable, dimension(:) :: neighbour1 !% Neighbour information for pairs $i <= j$. + !% Contains full details of $j$, $r_{ij}$ and shift. + type(table_pointer), allocatable, dimension(:) :: neighbour2 !% Neighbour information for pairs $i > j$. + !% Simply contains $j$ and a reference to $j$'s + !% 'neighbour1' table. + + integer, allocatable, dimension(:,:,:) :: cell_heads !% First entry in cell atoms structure + integer, allocatable, dimension(:) :: next_atom_in_cell !% List of atoms, terminated by zero + + logical, allocatable, dimension(:) :: is_min_image !% True if i is a minimum image + + real(dp) :: last_connect_cutoff !% Value of cutoff used last time connectivity was updated + real(dp), allocatable, dimension(:,:) :: last_connect_pos !% Positions of atoms last time connnectivity was updated + real(dp), dimension(3,3) :: last_connect_lattice !% Lattice last time connectivity was updated + + end type Connection + + + public :: DomainDecomposition + type DomainDecomposition + + integer :: Ntotal = 0 !% Number of total particles in this simulation + integer, pointer :: local_to_global(:) => NULL() !% Local index to global index + integer, allocatable :: global_to_local(:) !% Global index to local index + + integer :: decomposition(3) = (/ 1, 1, 1 /) !% Type of decomposition + + integer :: mode = DD_WRAP_TO_CELL + + logical :: decomposed = .false. !% True if domain decomposition is active + + real(dp) :: requested_border = 0.0_DP + real(dp) :: border(3) = 0.0_DP + real(dp) :: verlet_shell = 0.0_DP + + logical :: communicate_forces = .false. + + real(dp) :: lower(3) = 0.0_DP !% Lower domain boundary, in fraction of the total cell + real(dp) :: upper(3) = 0.0_DP !% Upper domain boundary, in fraction of the total cell + real(dp) :: center(3) = 0.0_DP !% Center of the domain + real(dp) :: lower_with_border(3) = 0.0_DP !% Lower domain boundary, including border + real(dp) :: upper_with_border(3) = 0.0_DP !% Upper domain boundary, including border + + type(MPI_context) :: mpi !% MPI communicator + logical :: periodic(3) = .true. !% Periodicity for domain decomposition + integer :: l(3) = 0 !% Ranks of left domains in x-, y- and z-direction + integer :: r(3) = 0 !% Ranks of right domains in x-, y- and z-direction + real(dp) :: off_l(3) = 0.0_DP !% Distance vector to left domain + real(dp) :: off_r(3) = 0.0_DP !% Distance vector to right domain + + type(Dictionary) :: atoms_properties !% Fields to communicate if for particles + type(Dictionary) :: ghost_properties !% Fields to communicate for ghosts + type(Dictionary) :: reverse_properties !% Back-communication after force computations + + logical, allocatable :: atoms_mask(:) + logical, allocatable :: ghost_mask(:) + logical, allocatable :: reverse_mask(:) + + integer :: atoms_buffer_size = 0 + integer :: ghost_buffer_size = 0 + integer :: reverse_buffer_size = 0 + + character(1), allocatable :: send_l(:) !% buffer for sending to the left + character(1), allocatable :: send_r(:) !% buffer for sending to the right + character(1), allocatable :: recv_l(:) !% buffer for receiving from the left + character(1), allocatable :: recv_r(:) !% buffer for receiving from the right + + integer :: n_ghosts_r(3) = 0 !% length of the ghost particle lists (right) + integer :: n_ghosts_l(3) = 0 !% length of the ghost particle lists (left) + + integer, allocatable :: ghosts_r(:) !% particles send to the right (where they become ghosts) + integer, allocatable :: ghosts_l(:) !% particles send to the left (where they become ghosts) + + integer :: n_send_p_tot !% Statistics: Number of total particles send + integer :: n_recv_p_tot !% Statistics: Number of total particles received + integer :: n_send_g_tot !% Statistics: Number of total ghosts send + integer :: n_recv_g_tot !% Statistics: Number of total ghosts received + integer :: nit_p !% Statistics: Number of particle send events + integer :: nit_g !% Statistics: Number of ghost send events + + endtype DomainDecomposition + + + public :: Atoms + type Atoms + !% Representation of an atomic configuration and its associated properties + !% + !% An atoms object contains atomic numbers, all dynamical variables + !% and connectivity information for all the atoms in the simulation cell. + !% It is initialised like this: + !%> call initialise(MyAtoms,N,lattice) + !% where 'N' is the number of atoms to allocate space for and 'lattice' is a $3\times3$ + !% matrix of lattice vectors given as column vectors, so that 'lattice(:,i)' is the i-th lattice vector. + !% + !% Atoms also contains a Connection object, which stores distance information about + !% the atom neghbours after 'calc_connect' has been called. Rather than using a minimum + !% image convention, all neighbours are stored up to a radius of 'cutoff', including images + + ! Self-deallocating object + logical :: own_this = .false. !% Do I own myself? + integer :: ref_count = 0 !% Reference counter + + logical :: fixed_size = .false. !% Can the number of atoms be changed after initialisation? + integer :: N = 0 !% The number of atoms held (including ghost particles) + integer :: Ndomain = 0 !% The number of atoms held by the local process (excluding ghost particles) + integer :: Nbuffer = 0 !% The number of atoms that can be stored in the buffers of this Atoms object + + real(dp) :: cutoff = -1.0_dp !% Cutoff distance for neighbour calculations. Default -1.0 (unset). + real(dp) :: cutoff_skin = 0.0_dp !% If set, increase cutoff by this amount to reduce calc_connect() frequency + logical :: pot_should_do_nn = .false., pot_needs_new_connect = .false., pot_needs_new_dists = .false. + real(dp) :: nneightol = DEFAULT_NNEIGHTOL + !% Count as nearest neighbour if sum of covalent radii + !% times 'this%nneightol' greater than distance between atoms. + !% Used in cluster carving. + + real(dp), dimension(3,3) :: lattice !% Lattice vectors, as columns: + !%\begin{displaymath} + !%\left( + !%\begin{array}{ccc} + !% | & | & | \\ \mathbf{a} & \mathbf{b} & \mathbf{c} \\ | & | & | \\ \end{array} + !%\right) + !% = \left( + !%\begin{array}{ccc} + !% R_{11} & R_{12} & R_{13} \\ R_{21} & R_{22} & R_{23} \\ R_{31} & R_{32} & R_{33} \\ \end{array} + !%\right) + !%\end{displaymath} + !% i.e. $\mathbf{a}$ = 'lattice(:,1)', $\mathbf{b}$ = 'lattice(:,2)' and + !% $\mathbf{c}$ 'lattice(:,3)'. + + ! ( | | | | | | ) ( (1,1) (1,2) (1,3) ) + ! ( | | | | | | ) ( ) + ! ( |a| |b| |c| ) = ( (2,1) (2,2) (2,3) ) + ! ( | | | | | | ) ( ) + ! ( | | | | | | ) ( (3,1) (3,2) (3,3) ) + logical :: is_orthorhombic, is_periodic(3) + + + real(dp), dimension(3,3) :: g !% Inverse lattice (stored for speed) + + type(Dictionary) :: properties !% :class:`~.Dictionary` of atomic properties. A property is an array + !% of shape (`m`,`n`) where `n` is the number of atoms and `m` is + !% either one (for scalar properties) or three (vector + !% properties). Properties can be integer, real, string or logical. + !% String properties have a fixed length of ``TABLE_STRING_LENGTH=10`` + !% characters. + !% + !% From Fortran, the following default properties are aliased with + !% arrays within the Atoms type: + !% + !% * ``Z`` - Atomic numbers, dimension is actually $(N)$ + !% * ``species`` Names of elements + !% * ``move_mask`` Atoms with 'move_mask' set to zero are fixed + !% * ``damp_mask`` Damping is only applied to those atoms with 'damp_mask' set to 1. By default this is set to 1 for all atoms. + !% * ``thermostat_region`` Which thermostat is applied to each atoms. By default this is set to 1 for all atoms. + !% * ``travel`` Travel across periodic conditions. $(3,N)$ integer array. See meth:`map_into_cell` below. + !% * ``pos`` $(3,N)$ array of atomic positions, in $\mathrm{\AA}$. Position of atom $i$ is 'pos(:,i)' + !% * ``mass`` Atomic masses, dimension is $(N)$ + !% * ``velo`` $(3,N)$ array of atomic velocities, in $\mathrm{AA}$/fs. + !% * ``acc`` $(3,N)$ array of accelerations in $\mathrm{AA}$/fs$^2$ + !% * ``avgpos`` $(3,N)$ array of time-averaged atomic positions. + !% * ``oldpos`` $(3,N)$ array of positions of atoms at previous time step. + !% * ``avg_ke`` Time-averaged atomic kinetic energy + !% + !% Custom properties are most conveniently accessed by assign a pointer to + !% them with the :meth:`assign_pointer` routines. + !% + !% From Python, each property is automatically visible as a + !% array attribute of the :class:`Atoms` object, + !% for example the atomic positions are stored in a real vector + !% property called `pos`, and can be accessed as ``at.pos``. + !% + !% Properties can be added with the :meth:`add_property` method and + !% removed with :meth:`remove_property`. + + type(Dictionary) :: params !% :class:`~.Dictionary` of parameters. Useful for storing data about this + !% Atoms object, for example the temperature, total energy or + !% applied strain. The data stored here is automatically saved to + !% and loaded from XYZ and NetCDF files. + + integer, pointer, dimension(:) :: Z => null() !% Atomic numbers, dimension is actually $(N)$ + character(1), pointer, dimension(:,:) :: species => null() !% Names of elements + + integer, pointer, dimension(:) :: move_mask => null() !% Atoms with 'move_mask' set to false are fixed + integer, pointer, dimension(:) :: damp_mask => null() !% Damping is only applied to those atoms with + !% 'damp_mask' set to 1. + !% By default this is set to 1 for all atoms. + + integer, pointer, dimension(:) :: thermostat_region => null() !% Which thermostat is applied to each atoms. + !% By default this is set to 1 for all atoms. + + integer, pointer, dimension(:,:) :: travel => null() !% Travel across periodic conditions. Actually $(3,N)$ array. + !% See 'map_into_cell' below. + real(dp), pointer, dimension(:,:) :: pos => null() !% $(3,N)$ array of atomic positions, in $\mathrm{AA}$. + !% Position of atom $i$ is 'pos(:,i)' + real(dp), pointer, dimension(:) :: mass => null() !% Atomic masses, dimension is actually $(N)$ + + real(dp), pointer, dimension(:,:) :: velo => null() !% $(3,N)$ array of atomic velocities, in $\mathrm{AA}$/fs. + real(dp), pointer, dimension(:,:) :: acc => null() !% $(3,N)$ array of accelerations in $\mathrm{AA}$/fs$^2$ + real(dp), pointer, dimension(:,:) :: avgpos => null() !% $(3,N)$ array of time-averaged atomic positions. + real(dp), pointer, dimension(:,:) :: oldpos => null() !% $(3,N)$ array of positions of atoms at previous time step. + real(dp), pointer, dimension(:) :: avg_ke => null() !% Time-averaged atomic kinetic energy + + type(Connection) :: connect !% :class:`~.Connection` object + type(Connection) :: hysteretic_connect !% Hysteretic :class:`~.Connection` object + + type(DomainDecomposition) :: domain !% Domain decomposition object + + end type Atoms + + + !% Add a per-atom property to this atoms object, as extra entry with columns of + !% integers, reals, logical, or strings in the 'properties' dictionary. For example, + !% this interface is used by the DynamicalSystems module to create the 'velo', 'acc', + !% etc. properties. + !% Optionally, a pointer to the new property is returned. + public :: add_property + interface add_property + module procedure atoms_add_property_int, atoms_add_property_int_a + module procedure atoms_add_property_real, atoms_add_property_real_a + module procedure atoms_add_property_str, atoms_add_property_str_2da + module procedure atoms_add_property_str_a + module procedure atoms_add_property_logical, atoms_add_property_logical_a + module procedure atoms_add_property_int_2Da + module procedure atoms_add_property_real_2Da + end interface + + !% Add a per-atom property to this atoms object, but point to existing space + !% rather than allocating new space for it (as add_property does). + public :: add_property_from_pointer + interface add_property_from_pointer + module procedure atoms_add_property_p_int, atoms_add_property_p_int_a + module procedure atoms_add_property_p_real, atoms_add_property_p_real_a + module procedure atoms_add_property_p_str + module procedure atoms_add_property_p_logical + end interface + + + !% This is a convenience interface to assign pointers to custom properties of this + !% Atoms object. The pointer is simply directed to the relevant array in the + !% 'this%properties' Dictionary. Adding or removing atoms will invalidate these pointers. + !% Returns true if successful, false if property doesn't exist or + !% if property type and type of pointer don't match. + !% OUTDATED - replace by subroutine assign_property_pointer with error handling + public :: assign_pointer + interface assign_pointer + module procedure atoms_assign_pointer_int1D, atoms_assign_pointer_int2D + module procedure atoms_assign_pointer_real1D, atoms_assign_pointer_real2D + module procedure atoms_assign_pointer_str + module procedure atoms_assign_pointer_logical + end interface + + + !% This is a convenience interface to assign pointers to custom properties of this + !% Atoms object. The pointer is simply directed to the relevant array in the + !% 'this%properties' Dictionary. Adding or removing atoms will invalidate these pointers. + !% Raises error for failure + public :: assign_property_pointer + interface assign_property_pointer + module procedure atoms_assign_prop_ptr_int1D, atoms_assign_prop_ptr_int2D + module procedure atoms_assign_prop_ptr_real1D, atoms_assign_prop_ptr_real2D + module procedure atoms_assign_prop_ptr_str + module procedure atoms_assign_prop_ptr_logical + end interface + + + !% Copy an atom to a different index + public :: copy_entry + interface copy_entry + module procedure atoms_copy_entry + endinterface copy_entry + + + ! Note: These are Atoms unrelated, and could be easily move somewhere else + ! (linearalgebra?) + public :: map_into_cell + interface map_into_cell + module procedure vec_map_into_cell, array_map_into_cell + end interface + + public :: cell_volume + interface cell_volume + module procedure lattice_cell_volume + end interface + + !% This interface calculates the distance between the nearest periodic images of two points (or atoms). + + !% Return minimum image distance between two atoms or positions. + !% End points can be specified by any combination of atoms indices + !% 'i' and 'j' and absolute coordinates 'u' and 'w'. If 'shift' is + !% present the periodic shift between the two atoms or points will + !% be returned in it. + interface distance_min_image + module procedure distance8_atom_atom, distance8_atom_vec, distance8_vec_atom, distance8_vec_vec + end interface + + !% Return the minimum image difference vector between two atoms or + !% positions. End points can be specified by any combination of + !% atoms indices 'i' and 'j' and absolute coordinates 'u' and + !% 'w'. + interface diff_min_image + module procedure diff_atom_atom, diff_atom_vec, diff_vec_atom, diff_vec_vec + end interface + + public :: atoms_repoint, atoms_sort, bond_length, distance, diff, realpos, distance_min_image, diff_min_image + +contains + + !% OMIT + ! Initialise pointers for convenient access to special columns of this%properties + subroutine atoms_repoint(this) + type(Atoms), target, intent(inout) :: this + integer :: i + + if(this%N == 0) return + + nullify(this%Z, this%travel, this%pos, this%move_mask, this%damp_mask, & + this%thermostat_region, this%pos, this%velo, this%acc, this%avgpos, & + this%oldpos) + + ! Loop over all properties looking for those with special names + ! which we have pointers for + do i = 1,this%properties%N + + ! If this%N is zero then point at zero length arrays + if (this%N == 0) then + + select case(trim(lower_case(string(this%properties%keys(i))))) + + ! Integer properties + case('z') + if (this%properties%entries(i)%type /= T_INTEGER_A) & + call system_abort('Confused by Atoms property "Z" not of type T_INTEGER_A') + this%Z => this%properties%entries(i)%i_a(:) + case('travel') + if (this%properties%entries(i)%type /= T_INTEGER_A2) & + call system_abort('Confused by Atoms property "travel" not of type T_INTEGER_A2') + this%travel => this%properties%entries(i)%i_a2(:,:) + case('move_mask') + if (this%properties%entries(i)%type /= T_INTEGER_A) & + call system_abort('Confused by Atoms property "move_mask" not of type T_INTEGER_A') + this%move_mask => this%properties%entries(i)%i_a(:) + case('damp_mask') + if (this%properties%entries(i)%type /= T_INTEGER_A) & + call system_abort('Confused by Atoms property "damp_mask" not of type T_INTEGER_A') + this%damp_mask => this%properties%entries(i)%i_a(:) + case('thermostat_region') + if (this%properties%entries(i)%type /= T_INTEGER_A) & + call system_abort('Confused by Atoms property "thermostat_mask" not of type T_INTEGER_A') + this%thermostat_region => this%properties%entries(i)%i_a(:) + + ! Real properties + case('mass') + if (this%properties%entries(i)%type /= T_REAL_A) & + call system_abort('Confused by Atoms property "mass" not of type T_REAL_A') + this%mass => this%properties%entries(i)%r_a(:) + case('pos') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "mass" not of type T_REAL_A2') + this%pos => this%properties%entries(i)%r_a2(:,:) + case('velo') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "velo" not of type T_REAL_A2') + this%velo => this%properties%entries(i)%r_a2(:,:) + case('acc') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "acc" not of type T_REAL_A2') + this%acc => this%properties%entries(i)%r_a2(:,:) + case('avgpos') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "avgpos" not of type T_REAL_A2') + this%avgpos => this%properties%entries(i)%r_a2(:,:) + case('oldpos') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "oldpos" not of type T_REAL_A2') + this%oldpos => this%properties%entries(i)%r_a2(:,:) + case('avg_ke') + if (this%properties%entries(i)%type /= T_REAL_A) & + call system_abort('Confused by Atoms property "avg_ke" not of type T_REAL_A') + this%avg_ke => this%properties%entries(i)%r_a(:) + + ! String properties + case('species') + if (this%properties%entries(i)%type /= T_CHAR_A) & + call system_abort('Confused by Atoms property "species" not of type T_CHAR_A') + this%species => this%properties%entries(i)%s_a(:,:) + + end select + + + else + + select case(trim(lower_case(string(this%properties%keys(i))))) + + ! Integer properties + case('z') + if (this%properties%entries(i)%type /= T_INTEGER_A) & + call system_abort('Confused by Atoms property "Z" not of type T_INTEGER_A') + this%Z => this%properties%entries(i)%i_a(1:this%n) + case('travel') + if (this%properties%entries(i)%type /= T_INTEGER_A2) & + call system_abort('Confused by Atoms property "travel" not of type T_INTEGER_A2') + this%travel => this%properties%entries(i)%i_a2(:,1:this%n) + case('move_mask') + if (this%properties%entries(i)%type /= T_INTEGER_A) & + call system_abort('Confused by Atoms property "move_mask" not of type T_INTEGER_A') + this%move_mask => this%properties%entries(i)%i_a(1:this%n) + case('damp_mask') + if (this%properties%entries(i)%type /= T_INTEGER_A) & + call system_abort('Confused by Atoms property "damp_mask" not of type T_INTEGER_A') + this%damp_mask => this%properties%entries(i)%i_a(1:this%n) + case('thermostat_region') + if (this%properties%entries(i)%type /= T_INTEGER_A) & + call system_abort('Confused by Atoms property "thermostat_mask" not of type T_INTEGER_A') + this%thermostat_region => this%properties%entries(i)%i_a(1:this%n) + + ! Real properties + case('mass') + if (this%properties%entries(i)%type /= T_REAL_A) & + call system_abort('Confused by Atoms property "mass" not of type T_REAL_A') + this%mass => this%properties%entries(i)%r_a(1:this%n) + case('pos') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "mass" not of type T_REAL_A2') + this%pos => this%properties%entries(i)%r_a2(:,1:this%N) + case('velo') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "velo" not of type T_REAL_A2') + this%velo => this%properties%entries(i)%r_a2(:,1:this%N) + case('acc') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "acc" not of type T_REAL_A2') + this%acc => this%properties%entries(i)%r_a2(:,1:this%N) + case('avgpos') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "avgpos" not of type T_REAL_A2') + this%avgpos => this%properties%entries(i)%r_a2(:,1:this%N) + case('oldpos') + if (this%properties%entries(i)%type /= T_REAL_A2) & + call system_abort('Confused by Atoms property "oldpos" not of type T_REAL_A2') + this%oldpos => this%properties%entries(i)%r_a2(:,1:this%N) + case('avg_ke') + if (this%properties%entries(i)%type /= T_REAL_A) & + call system_abort('Confused by Atoms property "avg_ke" not of type T_REAL_A') + this%avg_ke => this%properties%entries(i)%r_a(1:this%n) + + ! String properties + case('species') + if (this%properties%entries(i)%type /= T_CHAR_A) & + call system_abort('Confused by Atoms property "species" not of type T_CHAR_A') + this%species => this%properties%entries(i)%s_a(:,1:this%N) + + end select + + end if + + end do + + end subroutine atoms_repoint + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Add new properties + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine atoms_add_property_p_int(this, name, ptr, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + integer, intent(in), target :: ptr(:) + integer, intent(out), optional :: error + + integer :: use_n_cols, i + + INIT_ERROR(error) + if (size(ptr,1) /= this%Nbuffer) then + RAISE_ERROR("atoms_add_property_p_int_a: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) + endif + use_n_cols = 1 + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then + RAISE_ERROR("atoms_add_property_p_int: incompatible property "//trim(name)//" already present", error) + end if + end if + call set_value_pointer(this%properties, name, ptr) + call atoms_repoint(this) + end subroutine atoms_add_property_p_int + + subroutine atoms_add_property_p_int_a(this, name, ptr, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + integer, intent(in), target :: ptr(:,:) + integer, intent(out), optional :: error + + integer :: use_n_cols, i + + INIT_ERROR(error) + if (size(ptr,2) /= this%Nbuffer) then + RAISE_ERROR("atoms_add_property_p_int_a: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) + endif + use_n_cols = size(ptr,1) + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then + RAISE_ERROR("atoms_add_property_p_int_a: incompatible property "//trim(name)//" already present", error) + end if + if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_INTEGER_A2) then + RAISE_ERROR("atoms_add_property_p_int_a: incompatible property "//trim(name)//" already present", error) + end if + end if + call set_value_pointer(this%properties, name, ptr) + call atoms_repoint(this) + end subroutine atoms_add_property_p_int_a + + subroutine atoms_add_property_p_real(this, name, ptr, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + real(dp), intent(in), target :: ptr(:) + integer, intent(out), optional :: error + + integer :: use_n_cols, i + + INIT_ERROR(error) + if (size(ptr,1) /= this%Nbuffer) then + RAISE_ERROR("atoms_add_property_p_real_a: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) + endif + use_n_cols = 1 + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then + RAISE_ERROR("atoms_add_property_p_real: incompatible property "//trim(name)//" already present", error) + end if + end if + call set_value_pointer(this%properties, name, ptr) + call atoms_repoint(this) + end subroutine atoms_add_property_p_real + + subroutine atoms_add_property_p_real_a(this, name, ptr, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + real(dp), intent(in), target :: ptr(:,:) + integer, intent(out), optional :: error + + integer :: use_n_cols, i + + INIT_ERROR(error) + if (size(ptr,2) /= this%Nbuffer) then + RAISE_ERROR("atoms_add_property_p_real_a: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) + endif + use_n_cols = size(ptr,1) + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then + RAISE_ERROR("atoms_add_property_p_real_a: incompatible property "//trim(name)//" already present", error) + end if + if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_REAL_A2) then + RAISE_ERROR("atoms_add_property_p_real_a: incompatible property "//trim(name)//" already present", error) + end if + end if + call set_value_pointer(this%properties, name, ptr) + call atoms_repoint(this) + end subroutine atoms_add_property_p_real_a + + + subroutine atoms_add_property_p_logical(this, name, ptr, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + logical, intent(in), target :: ptr(:) + integer, intent(out), optional :: error + + integer :: use_n_cols, i + + INIT_ERROR(error) + if (size(ptr,1) /= this%Nbuffer) then + RAISE_ERROR("atoms_add_property_p_logical: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) + endif + use_n_cols = 1 + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_LOGICAL_A) then + RAISE_ERROR("atoms_add_property_p_logical: incompatible property "//trim(name)//" already present", error) + end if + end if + call set_value_pointer(this%properties, name, ptr) + call atoms_repoint(this) + end subroutine atoms_add_property_p_logical + + subroutine atoms_add_property_p_str(this, name, ptr, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + character(1), intent(in), target :: ptr(:,:) + integer, intent(out), optional :: error + + integer :: use_n_cols, i + + INIT_ERROR(error) + if (size(ptr,2) /= this%N) then + RAISE_ERROR("atoms_add_property_p_str: incompatible pointer this%Nbuffer="//this%Nbuffer//" pointer shape "//shape(ptr), error) + endif + use_n_cols = 1 + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_CHAR_A) then + RAISE_ERROR("atoms_add_property_p_str: incompatible property "//trim(name)//" already present", error) + end if + end if + call set_value_pointer(this%properties, name, ptr) + call atoms_repoint(this) + end subroutine atoms_add_property_p_str + + subroutine atoms_add_property_int(this, name, value, n_cols, ptr, ptr2, overwrite, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + integer, intent(in) :: value + integer, intent(in), optional :: n_cols + integer, intent(out), optional, dimension(:), pointer :: ptr + integer, intent(out), optional, dimension(:,:), pointer :: ptr2 + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer :: use_n_cols, i + + INIT_ERROR(error) + use_n_cols = optional_default(1, n_cols) + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then + RAISE_ERROR("atoms_add_property_int: incompatible property "//trim(name)//" already present", error) + end if + + if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_INTEGER_A2) then + RAISE_ERROR("atoms_add_property_int: incompatible property "//trim(name)//" already present", error) + end if + end if + + if (use_n_cols == 1) then + call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) + else + call add_array(this%properties, name, value, (/n_cols, this%Nbuffer/), ptr2, overwrite) + end if + + call atoms_repoint(this) + end subroutine atoms_add_property_int + + subroutine atoms_add_property_int_a(this, name, value, n_cols, ptr, ptr2, overwrite, error) + type(Atoms), intent(inout),target :: this + character(len=*), intent(in) :: name + integer, intent(in), dimension(:) :: value + integer, intent(in), optional :: n_cols + integer, optional, intent(out), dimension(:), pointer :: ptr + integer, optional, intent(out), dimension(:,:), pointer :: ptr2 + logical, optional, intent(in) :: overwrite + integer, optional, intent(out) :: error + + integer :: use_n_cols, i + integer, allocatable, dimension(:,:) :: tmp_value + + INIT_ERROR(error) + use_n_cols = optional_default(1, n_cols) + + if (size(value) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_int_a: size(value) ('//size(value)//') /= this%Nbuffer ('//this%Nbuffer//')', error) + end if + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then + RAISE_ERROR("atoms_add_property_int_a: incompatible property "//trim(name)//" already present", error) + end if + + if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_INTEGER_A2) then + RAISE_ERROR("atoms_add_property_int_a: incompatible property "//trim(name)//" already present", error) + end if + end if + + if (use_n_cols == 1) then + call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) + else + allocate(tmp_value(n_cols, size(value))) + do i=1,n_cols + tmp_value(i,:) = value + end do + call add_array(this%properties, name, tmp_value, (/n_cols, this%Nbuffer/), ptr2, overwrite) + deallocate(tmp_value) + end if + + call atoms_repoint(this) + end subroutine atoms_add_property_int_a + + + subroutine atoms_add_property_real(this, name, value, n_cols, ptr, ptr2, overwrite, error) + type(Atoms), intent(inout),target :: this + character(len=*), intent(in) :: name + real(dp), intent(in) :: value + integer, intent(in), optional :: n_cols + real(dp), optional, dimension(:), pointer, intent(out) :: ptr + real(dp), optional, dimension(:,:), pointer, intent(out) :: ptr2 + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer use_n_cols, i + + INIT_ERROR(error) + use_n_cols = optional_default(1, n_cols) + + if (present(ptr) .and. present(ptr2)) then + RAISE_ERROR('atoms_add_property_real_a got both ptr and ptr2', error) + endif + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then + RAISE_ERROR("atoms_add_property_real: incompatible property "//trim(name)//" already present", error) + end if + + if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_REAL_A2) then + RAISE_ERROR("atoms_add_property_real: incompatible property "//trim(name)//" already present", error) + end if + end if + + if (use_n_cols == 1 .and. .not. present(ptr2)) then + call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) + else + call add_array(this%properties, name, value, (/n_cols, this%Nbuffer/), ptr2, overwrite) + end if + + call atoms_repoint(this) + end subroutine atoms_add_property_real + + + subroutine atoms_add_property_real_a(this, name, value, n_cols, ptr, ptr2, overwrite, error) + type(Atoms), intent(inout),target :: this + character(len=*), intent(in) :: name + real(dp), intent(in), dimension(:) :: value + integer, intent(in), optional :: n_cols + real(dp), optional, dimension(:), pointer, intent(out) :: ptr + real(dp), optional, dimension(:,:), pointer, intent(out) :: ptr2 + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer :: use_n_cols, i + real(dp), allocatable, dimension(:,:) :: tmp_value + + INIT_ERROR(error) + use_n_cols = optional_default(1, n_cols) + + if (present(ptr) .and. present(ptr2)) then + RAISE_ERROR('atoms_add_property_real_a got both ptr and ptr2', error) + endif + + if (size(value) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_real_a: size(value) ('//size(value)//') /= this%Nbuffer ('//this%Nbuffer//')', error) + end if + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (use_n_cols == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then + RAISE_ERROR("atoms_add_property_real_a: incompatible property "//trim(name)//" already present", error) + end if + + if (use_n_cols /= 1 .and. this%properties%entries(i)%type /= T_REAL_A2) then + RAISE_ERROR("atoms_add_property_real_a: incompatible property "//trim(name)//" already present", error) + end if + end if + + if (use_n_cols == 1 .and. .not. present(ptr2)) then + call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) + else + allocate(tmp_value(n_cols, size(value))) + do i=1,n_cols + tmp_value(i,:) = value + end do + call add_array(this%properties, name, tmp_value, (/n_cols, this%Nbuffer/), ptr2, overwrite) + deallocate(tmp_value) + end if + + call atoms_repoint(this) + end subroutine atoms_add_property_real_a + + subroutine atoms_add_property_int_2Da(this, name, value, ptr, overwrite, error) + type(Atoms), intent(inout),target :: this + character(len=*), intent(in) :: name + integer, intent(in) :: value(:,:) + integer, optional, dimension(:,:), pointer, intent(out) :: ptr + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer i + + INIT_ERROR(error) + + if (size(value,2) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_int_2Da: size(value,2) ('//size(value,2)//') /= this%Nbuffer ('//this%Nbuffer//')', error) + end if + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (size(value,1) == 1 .and. this%properties%entries(i)%type /= T_INTEGER_A) then + RAISE_ERROR("atoms_add_property_int_2Da: incompatible property "//trim(name)//" already present", error) + end if + + if (size(value,1) /= 1 .and. this%properties%entries(i)%type /= T_INTEGER_A2) then + RAISE_ERROR("atoms_add_property_int_2Da: incompatible property "//trim(name)//" already present", error) + end if + end if + + if (size(value,2) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_int_2Da: size(value,2)='//size(value,2)//' != this%Nbuffer ='//this%Nbuffer, error) + end if + + call add_array(this%properties, name, value, (/size(value,1), this%Nbuffer/), ptr, overwrite) + + call atoms_repoint(this) + end subroutine atoms_add_property_int_2Da + + + subroutine atoms_add_property_real_2Da(this, name, value, ptr, overwrite, error) + type(Atoms), intent(inout),target :: this + character(len=*), intent(in) :: name + real(dp), intent(in) :: value(:,:) + real(dp), optional, dimension(:,:), pointer, intent(out) :: ptr + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer i + + INIT_ERROR(error) + + if (size(value,2) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_real_2Da: size(value,2) ('//size(value,2)//') /= this%Nbuffer ('//this%Nbuffer//')', error) + end if + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (size(value,1) == 1 .and. this%properties%entries(i)%type /= T_REAL_A) then + RAISE_ERROR("atoms_add_property_real_2Da: incompatible property "//trim(name)//" already present", error) + end if + + if (size(value,1) /= 1 .and. this%properties%entries(i)%type /= T_REAL_A2) then + RAISE_ERROR("atoms_add_property_real_2Da: incompatible property "//trim(name)//" already present", error) + end if + end if + + if (size(value,2) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_real_2Da: size(value,2)='//size(value,2)//' != this%Nbuffer ='//this%Nbuffer, error) + end if + + call add_array(this%properties, name, value, (/size(value,1), this%Nbuffer/), ptr, overwrite) + + call atoms_repoint(this) + end subroutine atoms_add_property_real_2Da + + + subroutine atoms_add_property_str(this, name, value, ptr, overwrite, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + character(1), intent(out), optional, dimension(:,:), pointer :: ptr + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer i + + INIT_ERROR(error) + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (this%properties%entries(i)%type /= T_CHAR_A) then + RAISE_ERROR("atoms_add_property_str: incompatible property "//trim(name)//" already present", error) + end if + end if + + ! temporary hack - string length fixed to TABLE_STRING_LENGTH + if (len(value) /= TABLE_STRING_LENGTH) then + RAISE_ERROR("atoms_add_property_str: string properties much have string length TABLE_STRING_LENGTH but got "//len(value), error) + end if + call add_array(this%properties, name, value, (/TABLE_STRING_LENGTH, this%Nbuffer/), ptr, overwrite) + + call atoms_repoint(this) + end subroutine atoms_add_property_str + + + subroutine atoms_add_property_str_2da(this, name, value, ptr, overwrite, error) + type(Atoms), intent(inout),target :: this + character(len=*), intent(in) :: name + character(1), dimension(:,:) :: value + character(1), intent(out), optional, dimension(:,:), pointer :: ptr + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer :: i + + INIT_ERROR(error) + + if (size(value,2) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_str_2da: size(value,2) ('//size(value,2)//') /= this%Nbuffer ('//this%Nbuffer//')', error) + end if + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (this%properties%entries(i)%type /= T_CHAR_A) then + RAISE_ERROR("atoms_add_property_str: incompatible property "//trim(name)//" already present", error) + end if + end if + + ! temporary hack - string length fixed to TABLE_STRING_LENGTH + if (size(value,1) /= TABLE_STRING_LENGTH) then + RAISE_ERROR("atoms_add_property_str: string properties much have string length TABLE_STRING_LENGTH", error) + end if + + call add_array(this%properties, name, value, (/TABLE_STRING_LENGTH, this%Nbuffer/), ptr, overwrite) + + call atoms_repoint(this) + end subroutine atoms_add_property_str_2da + + subroutine atoms_add_property_str_a(this, name, value, ptr, overwrite, error) + type(Atoms), intent(inout),target :: this + character(len=*), intent(in) :: name + character(len=*), dimension(:) :: value + character(1), intent(out), optional, dimension(:,:), pointer :: ptr + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + character(1), allocatable, dimension(:,:) :: tmp_value + integer :: i, j + + INIT_ERROR(error) + + if (size(value) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_str_a: size(value) ('//size(value)//') /= this%Nbuffer ('//this%Nbuffer//')', error) + end if + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (this%properties%entries(i)%type /= T_CHAR_A) then + RAISE_ERROR("atoms_add_property_str: incompatible property "//trim(name)//" already present", error) + end if + end if + + ! temporary hack - string length fixed to TABLE_STRING_LENGTH + if (len(value(1)) /= TABLE_STRING_LENGTH) then + RAISE_ERROR("atoms_add_property_str: string properties much have string length TABLE_STRING_LENGTH", error) + end if + + allocate(tmp_value(len(value),this%n)) + do i=1,this%Nbuffer + do j=1,len(value) + tmp_value(j,i) = value(i)(j:j) + end do + end do + call add_array(this%properties, name, tmp_value, (/TABLE_STRING_LENGTH, this%Nbuffer/), ptr, overwrite) + deallocate(tmp_value) + + call atoms_repoint(this) + end subroutine atoms_add_property_str_a + + subroutine atoms_add_property_logical(this, name, value, ptr, overwrite, error) + type(Atoms), intent(inout), target :: this + character(len=*), intent(in) :: name + logical, intent(in) :: value + logical, intent(out), optional, dimension(:), pointer :: ptr + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer i + + INIT_ERROR(error) + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (this%properties%entries(i)%type /= T_LOGICAL_A) then + RAISE_ERROR("atoms_add_property_logical: incompatible property "//trim(name)//" already present", error) + end if + end if + + call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) + + call atoms_repoint(this) + end subroutine atoms_add_property_logical + + + subroutine atoms_add_property_logical_a(this, name, value, ptr, overwrite, error) + type(Atoms), intent(inout),target :: this + character(len=*), intent(in) :: name + logical, dimension(:) :: value + logical, intent(out), optional, dimension(:), pointer :: ptr + logical, optional, intent(in) :: overwrite + integer, intent(out), optional :: error + + integer i + + INIT_ERROR(error) + + if (size(value) /= this%Nbuffer) then + RAISE_ERROR('atoms_add_property_logical_a: size(value) ('//size(value)//') /= this%Nbuffer ('//this%Nbuffer//')', error) + end if + + ! Check for incompatible property + i = lookup_entry_i(this%properties, name) + if (i /= -1) then + if (this%properties%entries(i)%type /= T_LOGICAL_A) then + RAISE_ERROR("atoms_add_property_logical_a: incompatible property "//trim(name)//" already present", error) + end if + end if + + call add_array(this%properties, name, value, this%Nbuffer, ptr, overwrite) + + call atoms_repoint(this) + end subroutine atoms_add_property_logical_a + + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Assigning pointers to properties + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function atoms_assign_pointer_int1D(this, name, ptr) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + integer, pointer :: ptr(:) + logical :: atoms_assign_pointer_int1D + + atoms_assign_pointer_int1D = assign_pointer(this%properties, name, ptr) + end function atoms_assign_pointer_int1D + + function atoms_assign_pointer_int2D(this, name, ptr) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + integer, pointer :: ptr(:,:) + logical :: atoms_assign_pointer_int2D + + atoms_assign_pointer_int2D = assign_pointer(this%properties, name, ptr) + end function atoms_assign_pointer_int2D + + function atoms_assign_pointer_real1D(this, name, ptr) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + real(dp), pointer :: ptr(:) + logical :: atoms_assign_pointer_real1D + + atoms_assign_pointer_real1D = assign_pointer(this%properties, name, ptr) + end function atoms_assign_pointer_real1D + + function atoms_assign_pointer_real2D(this, name, ptr) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + real(dp), pointer :: ptr(:,:) + logical :: atoms_assign_pointer_real2D + + atoms_assign_pointer_real2D = assign_pointer(this%properties, name, ptr) + end function atoms_assign_pointer_real2D + + function atoms_assign_pointer_str(this, name, ptr) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + character(1), pointer :: ptr(:,:) + logical :: atoms_assign_pointer_str + + atoms_assign_pointer_str = assign_pointer(this%properties, name, ptr) + end function atoms_assign_pointer_str + + function atoms_assign_pointer_logical(this, name, ptr) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + logical, pointer :: ptr(:) + logical :: atoms_assign_pointer_logical + + atoms_assign_pointer_logical = assign_pointer(this%properties, name, ptr) + end function atoms_assign_pointer_logical + + subroutine atoms_assign_prop_ptr_int1D(this, name, ptr, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + integer, pointer :: ptr(:) + integer, intent(out), optional :: error + + logical :: res + + INIT_ERROR(error) + + res = assign_pointer(this%properties, name, ptr) + if (.not. res) then + RAISE_ERROR("atoms_assign_prop_ptr_int1d failed to assign pointer to "//trim(name)//" in this%properties", error) + endif + end subroutine atoms_assign_prop_ptr_int1D + + subroutine atoms_assign_prop_ptr_int2D(this, name, ptr, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + integer, pointer :: ptr(:,:) + integer, intent(out), optional :: error + + logical :: res + + INIT_ERROR(error) + + res = assign_pointer(this%properties, name, ptr) + if (.not. res) then + RAISE_ERROR("atoms_assign_prop_ptr_int2d failed to assign pointer to "//trim(name)//" in this%properties", error) + endif + end subroutine atoms_assign_prop_ptr_int2D + + subroutine atoms_assign_prop_ptr_real1D(this, name, ptr, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + real(dp), pointer :: ptr(:) + integer, intent(out), optional :: error + + logical :: res + + INIT_ERROR(error) + + res = assign_pointer(this%properties, name, ptr) + if (.not. res) then + RAISE_ERROR("atoms_assign_prop_ptr_real1d failed to assign pointer to "//trim(name)//" in this%properties", error) + endif + end subroutine atoms_assign_prop_ptr_real1D + + subroutine atoms_assign_prop_ptr_real2D(this, name, ptr, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + real(dp), pointer :: ptr(:,:) + integer, intent(out), optional :: error + + logical :: res + + INIT_ERROR(error) + + res = assign_pointer(this%properties, name, ptr) + if (.not. res) then + RAISE_ERROR("atoms_assign_prop_ptr_real2d failed to assign pointer to "//trim(name)//" in this%properties", error) + endif + end subroutine atoms_assign_prop_ptr_real2D + + subroutine atoms_assign_prop_ptr_str(this, name, ptr, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + character(1), pointer :: ptr(:,:) + integer, intent(out), optional :: error + + logical :: res + + INIT_ERROR(error) + + res = assign_pointer(this%properties, name, ptr) + if (.not. res) then + RAISE_ERROR("atoms_assign_prop_ptr_str failed to assign pointer to "//trim(name)//" in this%properties", error) + endif + end subroutine atoms_assign_prop_ptr_str + + subroutine atoms_assign_prop_ptr_logical(this, name, ptr, error) + type(Atoms), intent(in) :: this + character(len=*), intent(in) :: name + logical, pointer :: ptr(:) + integer, intent(out), optional :: error + + logical :: res + + INIT_ERROR(error) + + res = assign_pointer(this%properties, name, ptr) + if (.not. res) then + RAISE_ERROR("atoms_assign_prop_ptr_logical failed to assign pointer to "//trim(name)//" in this%properties", error) + endif + end subroutine atoms_assign_prop_ptr_logical + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Copying individual atoms and sorting + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Move a single atom from one location to another one. + !% The destination will be overriden. + subroutine atoms_copy_entry(this, src, dst, swap, error) + + type(Atoms), intent(inout) :: this + integer, intent(in) :: src + integer, intent(in) :: dst + logical, intent(in), optional :: swap + integer, optional, intent(out) :: error + + integer i + + logical :: my_swap + integer :: t_i + integer, allocatable :: t_i_a(:) + real(dp) :: t_r + real(dp), allocatable :: t_r_a(:) + logical :: t_l + character(len=1), allocatable :: t_c(:) + + ! --- + + INIT_ERROR(error) + my_swap = optional_default(.false., swap) + + if (src < 1 .or. src > this%N) then + RAISE_ERROR('atoms_copy_entry: src='//src//' out of range 1 <= src <= '//this%n, error) + end if + if (dst < 1 .or. dst > this%N) then + RAISE_ERROR('atoms_copy_entry: dst='//dst//' out of range 1 <= dst <= '//this%n, error) + end if + + do i=1,this%properties%N + select case (this%properties%entries(i)%type) + + case(T_INTEGER_A) + if (my_swap) then + t_i = this%properties%entries(i)%i_a(dst) + this%properties%entries(i)%i_a(dst) = this%properties%entries(i)%i_a(src) + this%properties%entries(i)%i_a(src) = t_i + else + this%properties%entries(i)%i_a(dst) = this%properties%entries(i)%i_a(src) + endif + + case(T_REAL_A) + if (my_swap) then + t_r = this%properties%entries(i)%r_a(dst) + this%properties%entries(i)%r_a(dst) = this%properties%entries(i)%r_a(src) + this%properties%entries(i)%r_a(src) = t_r + else + this%properties%entries(i)%r_a(dst) = this%properties%entries(i)%r_a(src) + endif + + case(T_LOGICAL_A) + if (my_swap) then + t_l = this%properties%entries(i)%l_a(dst) + this%properties%entries(i)%l_a(dst) = this%properties%entries(i)%l_a(src) + this%properties%entries(i)%l_a(src) = t_l + else + this%properties%entries(i)%l_a(dst) = this%properties%entries(i)%l_a(src) + endif + + case(T_INTEGER_A2) + if (my_swap) then + allocate(t_i_a(size(this%properties%entries(i)%i_a2,1))) + t_i_a = this%properties%entries(i)%i_a2(:,dst) + this%properties%entries(i)%i_a2(:,dst) = this%properties%entries(i)%i_a2(:,src) + this%properties%entries(i)%i_a2(:,src) = t_i_a + deallocate(t_i_a) + else + this%properties%entries(i)%i_a2(:,dst) = this%properties%entries(i)%i_a2(:,src) + endif + + case(T_REAL_A2) + if (my_swap) then + allocate(t_r_a(size(this%properties%entries(i)%r_a2,1))) + t_r_a = this%properties%entries(i)%r_a2(:,dst) + this%properties%entries(i)%r_a2(:,dst) = this%properties%entries(i)%r_a2(:,src) + this%properties%entries(i)%r_a2(:,src) = t_r_a + deallocate(t_r_a) + else + this%properties%entries(i)%r_a2(:,dst) = this%properties%entries(i)%r_a2(:,src) + endif + + case(T_CHAR_A) + if (my_swap) then + allocate(t_c(size(this%properties%entries(i)%s_a,1))) + t_c = this%properties%entries(i)%s_a(:,dst) + this%properties%entries(i)%s_a(:,dst) = this%properties%entries(i)%s_a(:,src) + this%properties%entries(i)%s_a(:,src) = t_c + deallocate(t_c) + else + this%properties%entries(i)%s_a(:,dst) = this%properties%entries(i)%s_a(:,src) + endif + + case default + RAISE_ERROR('atoms_copy_entry: bad property type '//this%properties%entries(i)%type//' key='//this%properties%keys(i), error) + + end select + end do + + endsubroutine atoms_copy_entry + + + !% sort atoms by one or more (max 2 now) integer or real properties + subroutine atoms_sort(this, prop1, prop2, prop3, error) + type(Atoms), intent(inout) :: this + character(len=*), intent(in) :: prop1 + character(len=*), intent(in), optional :: prop2, prop3 + integer, intent(out), optional :: error + + integer, pointer :: i_p1(:) => null(), i_p2(:) => null(), i_p3(:) => null() + real(dp), pointer :: r_p1(:) => null(), r_p2(:) => null(), r_p3(:) => null() + integer :: cur_place, i_a, smallest_i_a + logical :: is_lt + + INIT_ERROR(error) + + if (.not. assign_pointer(this, prop1, i_p1)) then + if (.not. assign_pointer(this, prop1, r_p1)) then + RAISE_ERROR("atoms_sort can't find 1st integer or real property '" // prop1 //"'", error) + endif + endif + if (present(prop2)) then + if (.not. assign_pointer(this, prop2, i_p2)) then + if (.not. assign_pointer(this, prop2, r_p2)) then + RAISE_ERROR("atoms_sort can't find 2nd integer or real property '" // prop2 //"'", error) + endif + endif + endif + if (present(prop3)) then + if (.not. assign_pointer(this, prop3, i_p3)) then + if (.not. assign_pointer(this, prop3, r_p3)) then + RAISE_ERROR("atoms_sort can't find 3rd integer or real property '" // prop3 //"'", error) + endif + endif + endif + + do cur_place=1, this%N-1 + smallest_i_a = cur_place + do i_a = cur_place+1, this%N + is_lt = arrays_lt(i_a, smallest_i_a, i_p1=i_p1, r_p1=r_p1, i_p2=i_p2, r_p2=r_p2, i_p3=i_p3, r_p3=r_p3, error=error) + PASS_ERROR(error) + if (is_lt) then + smallest_i_a = i_a + endif + end do + if (smallest_i_a /= cur_place) then + call copy_entry(this, cur_place, smallest_i_a, swap=.true., error=error) + PASS_ERROR(error) + endif + end do + end subroutine atoms_sort + + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Atoms indepedent convenince stuff + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !Bond_Length + !% Returns the sum of the covalent radii of two atoms + function bond_length(z1,z2) + integer, intent(in) :: z1,z2 + real(dp) :: bond_length + bond_length = ElementCovRad(z1) + ElementCovRad(z2) + end function bond_length + + subroutine array_map_into_cell(pos, lattice, g) + real(dp), intent(inout) :: pos(:,:) + real(dp), intent(in) :: lattice(3,3), g(3,3) + + integer :: i + + do i=1, size(pos, 2) + call map_into_cell(pos(:,i), lattice, g) + end do + end subroutine array_map_into_cell + + subroutine vec_map_into_cell(pos, lattice, g, shift, mapped) + real(dp), intent(inout) :: pos(3) + real(dp), intent(in) :: lattice(3,3), g(3,3) + integer, intent(out), optional :: shift(3) + logical, intent(out), optional :: mapped + + integer n, k + real(dp) :: lattice_coord(3) + logical :: my_mapped + + lattice_coord = g .mult. pos(:) + my_mapped = .false. + if (present(shift)) shift = 0 + + do n=1,3 + if ((lattice_coord(n) < -0.5_dp) .or. (lattice_coord(n) >= 0.5_dp)) then + k = floor(lattice_coord(n)+0.5_dp) + lattice_coord(n) = lattice_coord(n) - k + if (present(shift)) shift(n) = -k + my_mapped = .true. + end if + end do + + ! if this atom has been mapped then recalculate its position and shifts for its neighbours + if (my_mapped) then + pos(:) = lattice .mult. lattice_coord + end if + if (present(mapped)) mapped = my_mapped + end subroutine vec_map_into_cell + + + !% Returns the (unsigned) volume of the simulation cell of lattice + function lattice_cell_volume(lattice) + real(dp), intent(in) :: lattice(3,3) + real(dp) :: lattice_Cell_Volume + + real(dp), dimension(3) :: a, b, c + + a = lattice(:,1) + b = lattice(:,2) + c = lattice(:,3) + + lattice_Cell_Volume = abs(Scalar_Triple_Product(a,b,c)) + + end function lattice_cell_volume + + + !% Difference vector between atoms $i$ and $j$ if they are separated by a shift of 'shift' + !% \begin{displaymath} + !% \mathbf{u}_{ij} = \mathbf{r}_j - \mathbf{r}_i + \mathbf{R} \cdot \mathbf{s} + !% \end{displaymath} + !% where $\mathbf{R}$ is the 'lattice' matrix and $\mathbf{s}$ the shift + function diff(this, i, j, shift) + type(Atoms), intent(in) :: this + integer, intent(in) :: i,j + integer, dimension(3) :: shift + real(dp), dimension(3) :: diff + + diff = this%pos(:,j) - this%pos(:,i) + (this%lattice .mult. shift) + + end function diff + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! diff_min_image interface + ! + ! return relative vector from one position to another, adhering to PBC + ! and minimum image conventions + ! + ! Flavours are: atom-atom, vector-atom, atom-vector, vector-vector + ! + ! All are accessible using the 'diff_min_image' interface + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + function diff_atom_atom(this, i, j, shift) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i,j + integer, dimension(3), optional :: shift + real(dp), dimension(3) :: diff_atom_atom + real(dp) :: dummy + + integer, dimension(3) :: myshift + + dummy = distance_min_image(this,i,j, shift=myshift) + + diff_atom_atom = this%pos(:,j) - this%pos(:,i) + (this%lattice .mult. myshift) + + if (present(shift)) shift = myshift + + end function diff_atom_atom + + + function diff_vec_atom(this, v, j) + + type(Atoms), intent(in) :: this + real(dp), dimension(3) :: v + integer, intent(in) :: j + real(dp), dimension(3) :: diff_vec_atom + integer, dimension(3) :: shift + real(dp) :: dummy + + dummy = distance_min_image(this,v,j, shift=shift) + + diff_vec_atom = this%pos(:,j) - v + (this%lattice .mult. shift) + + end function diff_vec_atom + + function diff_atom_vec(this, i, w) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i + real(dp), dimension(3) :: w + real(dp), dimension(3) :: diff_atom_vec + integer, dimension(3) :: shift + real(dp) :: dummy + + dummy = distance_min_image(this,i,w, shift=shift) + + diff_atom_vec = w - this%pos(:,i) + (this%lattice .mult. shift) + + end function diff_atom_vec + + function diff_vec_vec(this, v, w) + + type(Atoms), intent(in) :: this + real(dp), dimension(3) :: v, w + real(dp), dimension(3) :: diff_vec_vec + integer, dimension(3) :: shift + real(dp) :: dummy + + dummy = distance_min_image(this,v,w, shift=shift) + + diff_vec_vec = w - v + (this%lattice .mult. shift) + + end function diff_vec_vec + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Return the real position of atom 'i', taking into account the + !% stored travel across the periodic boundary conditions. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function realpos(this,i) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i + real(dp), dimension(3) :: realpos + + if (associated(this%travel)) then + realpos = (this%lattice .mult. this%travel(:,i)) + this%pos(:,i) + else + realpos = this%pos(:,i) + endif + + end function realpos + + + !% Return distance between atoms 'i' and 'j' if they are separated by a shift + !% of 'shift'. + !% + !% \begin{displaymath} + !% r_{ij} = \left| \mathbf{r}_j - \mathbf{r}_i + \mathbf{R} \cdot \mathbf{s} \right| + !% \end{displaymath} + !% where $\mathbf{R}$ is the 'lattice' matrix and $\mathbf{s}$ the shift. + + function distance(this, i, j, shift) + type(Atoms), intent(in)::this + integer, intent(in)::i, j, shift(3) + real(dp)::distance + + distance = norm(this%pos(:,j)+(this%lattice .mult. shift)-this%pos(:,i)) + end function distance + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! distance_min_image interface + ! + ! Actual distance computing routines. + ! + ! The real work is done in the function that computes the distance + ! of two general vector positions. when atomic indices are + ! specified, they are first converted to vector positions. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function distance8_atom_atom(this,i,j,shift) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i,j + integer, optional, dimension(3), intent(out) :: shift + real(dp) :: distance8_atom_atom + + distance8_atom_atom = distance8_vec_vec(this,this%pos(:,i),this%pos(:,j),shift) + + end function distance8_atom_atom + + function distance8_atom_vec(this,i,v,shift) + + type(Atoms), intent(in) :: this + integer, intent(in) :: i + real(dp), dimension(3), intent(in) :: v + integer, optional, dimension(3), intent(out) :: shift + real(dp) :: distance8_atom_vec + + distance8_atom_vec = distance8_vec_vec(this,this%pos(:,i),v,shift) + + end function distance8_atom_vec + + function distance8_vec_atom(this,v,j,shift) + + type(Atoms), intent(in) :: this + real(dp), dimension(3), intent(in) :: v + integer, intent(in) :: j + integer, optional, dimension(3), intent(out) :: shift + real(dp) :: distance8_vec_atom + + distance8_vec_atom = distance8_vec_vec(this,v,this%pos(:,j),shift) + + end function distance8_vec_atom + + ! This is the general function + + function distance8_vec_vec(this,v,w,shift) + + type(Atoms), intent(in) :: this + real(dp), dimension(3), intent(in) :: v,w + integer, optional, dimension(3), intent(out) :: shift + real(dp) :: distance8_vec_vec, dist2, tmp + real(dp), dimension(3) :: dvw, lattice_coord + integer, dimension(3) :: init_val + integer :: i,j,k, i_shift(3) + + !get the difference vector and convert to lattice co-ordinates + !use the precomputed matrix inverse if possible + dvw = w - v + call map_into_cell(dvw, this%lattice, this%g, i_shift) + lattice_coord = this%g .mult. dvw + + init_val = (/0,0,0/) + + !work out which block of 8 cells we are testing + where (lattice_coord > 0.0_dp) init_val = -1 + + dist2 = huge(1.0_dp) ! effectively +ve infinity + + !now loop over the cells and test + do k=init_val(3), init_val(3)+1 + do j=init_val(2), init_val(2)+1 + do i=init_val(1), init_val(1)+1 + + !construct the shifted vector + tmp = normsq(dvw + this%lattice(:,1)*i +this%lattice(:,2)*j + this%lattice(:,3)*k) + !test if it is the smallest so far and store the shift if necessary + if (tmp < dist2) then + dist2 = tmp + if (present(shift)) shift = (/i,j,k/) + i_shift + end if + + end do + end do + end do + + distance8_vec_vec = sqrt(dist2) + + end function distance8_vec_vec + + +endmodule Atoms_types_module diff --git a/src/libAtoms/Barostat.F90 b/src/libAtoms/Barostat.F90 new file mode 100644 index 0000000000..da776b8003 --- /dev/null +++ b/src/libAtoms/Barostat.F90 @@ -0,0 +1,682 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Barostat module +!X +!% This module contains the implementations for all the barostats available +!% in libAtoms: Langevin thermalized Hoover +!% +!% With $Q > 0$, use adaptive (aka open) Langevin, from Jones \& Leimkuhler +!% preprint ``Adaptive Stochastic Methods for Nonequilibrium Sampling" +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module barostat_module + + use system_module + use units_module + use linearalgebra_module + use atoms_module + + implicit none + private + public :: barostat, initialise, finalise, print, update_barostat, set_degrees_of_freedom, barostat_mass + public :: BAROSTAT_NONE, BAROSTAT_HOOVER_LANGEVIN + public :: barostat_pre_vel1, barostat_post_vel1_pre_pos, barostat_post_pos_pre_calc, barostat_post_calc_pre_vel2, barostat_post_vel2 + + real(dp), parameter :: BAROSTAT_MIN_TEMP = 1.0_dp + + integer, parameter :: BAROSTAT_NONE = 0, & + BAROSTAT_HOOVER_LANGEVIN = 1 + + !% Langevin barostat - fluctuation/dissipation --- + !% originally implemented for hydrostatic strain using + !% EOM from Quigley, D. and Probert, M.I.J., \emph{J. Chem. Phys.}, + !% {\bfseries 120} 11432 + !% rediscretized by Noam Bernstein based on ideas from and discussion + !% with B. Leimkuhler. + !% modified for arbitrary strain based on (but not exactly using) + !% formulation in E. Tadmor and R. Miller Modeling Materials: Continuum, Atomistic and Multiscale + !% Techniques (Cambridge University Press, 2011). Chap 9.5. Their + !% definition of stress (factors of $F$, $F^T$, $J$, and $F^{-T}$) for finite strain is + !% optionally used, but certain terms in EOM are excluded, and their discretization + !% is entirely ignored. + + type barostat + + integer :: type = BAROSTAT_NONE !% One of the types listed above + real(dp) :: gamma_epsilon = 0.0_dp !% Friction coefficient for Langevin part + real(dp) :: T = -1.0_dp !% Temperature for Langevin part + real(dp) :: Ndof = 0.0_dp !% The number of degrees of freedom of atoms attached to this barostat + real(dp) :: stress_ext(3,3) = 0.0_dp !% External applied stress + real(dp) :: W_epsilon = 0.0_dp !% Fictious cell mass in Langevin NPT + real(dp) :: epsilon_v(3,3) = 0.0_dp !% Velocity of deformation gradient for barostat + real(dp) :: epsilon_f(3,3) = 0.0_dp !% Force on deformation gradient + real(dp) :: epsilon_r(3,3) = reshape( (/ 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp /), (/ 3, 3 /) ) !% Value of deformation gradient + logical :: hydrostatic_strain = .true., diagonal_strain = .true., finite_strain_formulation=.false. + + real(dp) :: lattice0(3,3), lattice0_inv(3,3), F_tmp_norm + logical :: lattice0_initialised = .false. + + end type barostat + + interface initialise + module procedure barostat_initialise + end interface initialise + + interface finalise + module procedure barostat_finalise + end interface finalise + + interface assignment(=) + module procedure barostat_assignment + end interface assignment(=) + + interface print + module procedure barostat_print + end interface + + interface update_barostat + module procedure barostat_update_barostat + end interface update_barostat + + interface set_degrees_of_freedom + module procedure set_degrees_of_freedom_int, set_degrees_of_freedom_real + end interface set_degrees_of_freedom + + interface barostat_mass + module procedure barostat_mass_int, barostat_mass_real + end interface barostat_mass + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X INITIALISE / FINALISE + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine barostat_initialise(this,type,p_ext,stress_ext,hydrostatic_strain,diagonal_strain,finite_strain_formulation,deformation_grad,cell_volume,W_epsilon,Ndof,gamma_epsilon,T,W_epsilon_factor, thermalise) + + type(barostat), intent(inout) :: this + integer, intent(in) :: type + real(dp), optional, intent(in) :: p_ext + real(dp), optional, intent(in) :: stress_ext(3,3) + logical, optional, intent(in) :: hydrostatic_strain, diagonal_strain + logical, optional, intent(in) :: finite_strain_formulation + real(dp), optional, intent(in) :: deformation_grad(3,3) + real(dp), optional, intent(in) :: cell_volume + real(dp), optional, intent(in) :: W_epsilon + real(dp), optional, intent(in) :: Ndof + real(dp), optional, intent(in) :: gamma_epsilon + real(dp), optional, intent(in) :: T + real(dp), optional, intent(in) :: W_epsilon_factor + logical, optional, intent(in) :: thermalise + + real(dp) :: use_T + logical :: use_thermalise + + if (type /= BAROSTAT_NONE .and. .not.present(p_ext) .and. .not. present(stress_ext)) & + call system_abort('barostat_initialise: p_ext or stress_ext must be specified when turning on a barostat') + + if (present(p_ext) .and. present(stress_ext)) & + call system_abort('barostat_initialise: got both p_ext and stress_ext') + + this%type = type + this%epsilon_v = 0.0_dp + this%epsilon_f = 0.0_dp + if (present(deformation_grad)) then + this%epsilon_r = deformation_grad + else + this%epsilon_r = 0.0_dp; call add_identity(this%epsilon_r) + endif + this%lattice0_initialised = .false. + + select case(this%type) + + case(BAROSTAT_NONE) + + this%stress_ext = 0.0_dp + this%gamma_epsilon = 0.0_dp + this%W_epsilon = 0.0_dp + this%Ndof = 0.0_dp + this%T = -1.0_dp + + case(BAROSTAT_HOOVER_LANGEVIN) + + if (.not.present(p_ext) .and. .not. present(stress_ext)) call system_abort('barostat initialise: p_ext or stress_ext is required for Hoover-Langevin barostat') + if (present(p_ext) .and. present(stress_ext)) call system_abort('barostat initialise: p_ext and stress_ext conflict for Hoover-Langevin barostat') + if (.not.present(gamma_epsilon)) call system_abort('barostat initialise: gamma_epsilon is required for Hoover-Langevin barostat') + if (gamma_epsilon <= 0.0_dp) call system_abort('barostat initialise: gamma_epsilon must be > 0.0 for Hoover-Langevin') + if (.not.present(Ndof)) call system_abort('barostat initialise: Ndof is required for Hoover-Langevin barostat') + if (Ndof <= 0.0_dp) call system_abort('barostat initialise: Ndof must be > 0.0 for Hoover-Langevin') + + if (.not.present(W_epsilon) .and. .not. present(cell_volume)) call system_abort('barostat initialise: W_epsilon or cell_volume is required for Hoover-Langevin barostat') + if (present(W_epsilon)) then + if (W_epsilon <= 0.0_dp) call system_abort('barostat initialise: W must be > 0.0 for Hoover-Langevin') + endif + if (present(cell_volume)) then + if (cell_volume <= 0.0_dp) call system_abort('barostat initialise: cell_volume must be > 0.0 for Hoover-Langevin') + endif + + if (present(p_ext)) then ! S = - p_ext I + this%stress_ext = 0.0_dp + call add_identity(this%stress_ext) + this%stress_ext = -p_ext * this%stress_ext + else + this%stress_ext = stress_ext + endif + + if (present(hydrostatic_strain)) this%hydrostatic_strain = hydrostatic_strain + if (present(diagonal_strain)) this%diagonal_strain = diagonal_strain + if (present(finite_strain_formulation)) this%finite_strain_formulation = finite_strain_formulation + + this%Ndof = Ndof + if (present(W_epsilon)) then + this%W_epsilon = W_epsilon + else + this%W_epsilon = barostat_mass(maxval(abs(this%stress_ext)), cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor) + endif + use_T = optional_default(-1.0_dp, T) + use_thermalise = optional_default(.true., thermalise) + if (use_thermalise .and. use_T > 0.0_dp) then + this%gamma_epsilon = gamma_epsilon + else + this%gamma_epsilon = 0.0_dp + endif + this%T = use_T + + case default + call system_abort("Invalid barostat type " // type) + + end select + + end subroutine barostat_initialise + + subroutine barostat_finalise(this) + + type(barostat), intent(inout) :: this + + this%type = BAROSTAT_NONE + this%gamma_epsilon = 0.0_dp + this%stress_ext = 0.0_dp + this%hydrostatic_strain = .true. + this%diagonal_strain = .true. + this%finite_strain_formulation = .false. + this%Ndof = 0.0_dp + this%W_epsilon = 0.0_dp + this%epsilon_v = 0.0_dp + this%epsilon_f = 0.0_dp + this%epsilon_r = 0.0_dp; call add_identity(this%epsilon_r) + this%T = -1.0_dp + this%lattice0_initialised = .false. + + end subroutine barostat_finalise + + subroutine barostat_assignment(to,from) + + type(barostat), intent(out) :: to + type(barostat), intent(in) :: from + + to%type = from%type + to%gamma_epsilon = from%gamma_epsilon + to%stress_ext = from%stress_ext + to%hydrostatic_strain = from%hydrostatic_strain + to%diagonal_strain = from%diagonal_strain + to%finite_strain_formulation = from%finite_strain_formulation + to%W_epsilon = from%W_epsilon + to%epsilon_v = from%epsilon_v + to%epsilon_f = from%epsilon_f + to%epsilon_r = from%epsilon_r + to%T = from%T + + end subroutine barostat_assignment + + subroutine barostat_update_barostat(this,p_ext,stress_ext,hydrostatic_strain,diagonal_strain,finite_strain_formulation,W_epsilon,T) + + type(barostat), intent(inout) :: this + real(dp), optional, intent(in) :: p_ext + real(dp), optional, intent(in) :: stress_ext(3,3) + logical, optional, intent(in) :: hydrostatic_strain, diagonal_strain + logical, optional, intent(in) :: finite_strain_formulation + real(dp), optional, intent(in) :: W_epsilon + real(dp), optional, intent(in) :: T + + if( present(p_ext) .and. present(stress_ext)) call system_abort("barostat_update_barostat: got both p_ext and stress_ext, conflict") + if( present(p_ext) ) then + this%stress_ext = 0.0_dp + call add_identity(this%stress_ext) + this%stress_ext = -p_ext * this%stress_ext + endif + if( present(stress_ext) ) this%stress_ext = stress_ext + if( present(hydrostatic_strain) ) this%hydrostatic_strain = hydrostatic_strain + if( present(diagonal_strain) ) this%diagonal_strain = diagonal_strain + if( present(finite_strain_formulation) ) this%finite_strain_formulation = finite_strain_formulation + if( present(W_epsilon) ) this%W_epsilon = W_epsilon + if( present(T) ) this%T = T + + endsubroutine barostat_update_barostat + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X PRINTING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine barostat_print(this,file) + + type(barostat), intent(in) :: this + type(inoutput), optional, intent(in) :: file + + select case(this%type) + + case(BAROSTAT_NONE) + call print('Barostat off',file=file) + + case(BAROSTAT_HOOVER_LANGEVIN) + call print('Hoover-Langevin, stress_ext = '// & + round(this%stress_ext(1,1)/EV_A3_IN_GPA,5)//' '// & + round(this%stress_ext(1,2)/EV_A3_IN_GPA,5)//' '// & + round(this%stress_ext(1,3)/EV_A3_IN_GPA,5)//' '// & + round(this%stress_ext(2,1)/EV_A3_IN_GPA,5)//' '// & + round(this%stress_ext(2,2)/EV_A3_IN_GPA,5)//' '// & + round(this%stress_ext(2,3)/EV_A3_IN_GPA,5)//' '// & + round(this%stress_ext(3,1)/EV_A3_IN_GPA,5)//' '// & + round(this%stress_ext(3,2)/EV_A3_IN_GPA,5)//' '// & + round(this%stress_ext(3,3)/EV_A3_IN_GPA,5)//' GPa , hydrostatic_strain = '//this%hydrostatic_strain//& + ' diagonal_strain = '//this%diagonal_strain//' finite_strain_formulation = '//this%finite_strain_formulation//& + ' gamma_epsilon = '//round(this%gamma_epsilon,5)//' fs^-1, '// & + ' W_epsilon = '//round(this%W_epsilon,5)//' eV/fs, T = '//round(this%T,2)//' K, Ndof = '// round(this%Ndof,1),file=file) + + end select + + end subroutine barostat_print + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X SETTING Ndof + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine set_degrees_of_freedom_int(this,Ndof) + + type(barostat), intent(inout) :: this + integer, intent(in) :: Ndof + + this%Ndof = real(Ndof,dp) + + end subroutine set_degrees_of_freedom_int + + subroutine set_degrees_of_freedom_real(this,Ndof) + + type(barostat), intent(inout) :: this + real(dp), intent(in) :: Ndof + + this%Ndof = Ndof + + end subroutine set_degrees_of_freedom_real + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X CHOOSING NOSE-HOOVER(-LANGEVIN) MASS + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + pure function barostat_mass_int(p_ext, cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor) result(W_epsilon) + + real(dp), intent(in) :: p_ext, cell_volume + integer, intent(in) :: Ndof + real(dp), intent(in) :: gamma_epsilon + real(dp), intent(in), optional :: T + real(dp), intent(in), optional :: W_epsilon_factor + real(dp) :: W_epsilon ! result + + W_epsilon = barostat_mass_real(p_ext, cell_volume, real(Ndof,dp), gamma_epsilon, T, W_epsilon_factor) + + end function barostat_mass_int + + pure function barostat_mass_real(p_ext, cell_volume, Ndof, gamma_epsilon, T, W_epsilon_factor) result(W_epsilon) + + real(dp), intent(in) :: p_ext, cell_volume + real(dp), intent(in) :: Ndof + real(dp), intent(in) :: gamma_epsilon + real(dp), intent(in), optional :: T + real(dp), intent(in), optional :: W_epsilon_factor + real(dp) :: W_epsilon ! result + + real(dp) :: use_T, use_W_epsilon_factor + + use_T = optional_default(BAROSTAT_MIN_TEMP, T) + if (use_T <= 0.0_dp) use_T = BAROSTAT_MIN_TEMP + + use_W_epsilon_factor=optional_default(1.0_dp, W_epsilon_factor) + + W_epsilon = use_W_epsilon_factor*max( 9.0_dp*abs(p_ext)*cell_volume/((gamma_epsilon*2.0_dp*PI)**2), & + (Ndof+3.0_dp)*BOLTZMANN_K*use_T/((gamma_epsilon*2.0_dp*PI)**2) ) + + end function barostat_mass_real + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X BAROSTAT ROUTINES + !X + !X These routines interleave the usual velocity Verlet steps and thermostat steps + !X should modify the velocities accelerations, and positions as required: + !X + !X advance_verlet1 + !X 00 (barostat_pre_vel1) * + !X 10 (thermostat_pre_vel1) * + !X 20 v(t+dt/2) = v(t) + a(t)dt/2 + !X 30 (thermostat_post_vel1_pre_pos) + !X 40 r(t+dt) = r(t) + v(t+dt/2)dt + !X 50 (thermostat_post_pos_pre_calc) + !X 60 (barostat_post_pos_pre_calc) * + !X calc F, virial + !X advance_verlet2 + !X 70 (thermostat_post_calc_pre_vel2) * + !X 80 v(t+dt) = v(t+dt/2) + a(t+dt)dt/2 + !X 90 (thermostat_post_vel2) * + !X 100 (barostat_post_vel2) * + !X + !X * marks routines that are needed in the refactored barostat/thermostat plan + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine barostat_pre_vel1(this,at,dt,virial) + + type(barostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + real(dp), dimension(3,3), optional, intent(in) :: virial + + real(dp) :: vel_decay(3,3), pos_scale(3,3), lattice_p(3,3), F_inv(3,3), F_tmp(3,3) + + select case(this%type) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X HOOVER-LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(BAROSTAT_HOOVER_LANGEVIN) + !TIME_PROPAG_TEX 00 + !TIME_PROPAG_TEX 00 {\color {blue} + !TIME_PROPAG_TEX 00 before all Verlet and thermostat steps (barostat\_pre\_vel1) + !TIME_PROPAG_TEX 00 + !TIME_PROPAG_TEX 00 $$ \epsilon_v = \epsilon_v \exp\left( -(\tau/2) \gamma_\epsilon \epsilon_r^{-1}\right)^T$$ + !TIME_PROPAG_TEX 00 $$ \epsilon_v = \epsilon_v + (\tau/2) \epsilon_f/W_\epsilon $$ + !TIME_PROPAG_TEX 00 $$ v = \exp \left( -(\tau/2) (1 + 3/N_d) \epsilon_v \right) v $$ + !TIME_PROPAG_TEX 00 $$ (r,h) = \exp\left( (\tau/2) \epsilon_v \right) (r,h) $$ + !TIME_PROPAG_TEX 00 } + !TIME_PROPAG_TEX 00 + + if (.not. present(virial)) call system_abort("barostat_pre_vel1 needs virial") + + if (.not. this%lattice0_initialised) then + this%lattice0_initialised = .true. + this%lattice0 = at%lattice + call matrix3x3_inverse(this%lattice0, this%lattice0_inv) + this%F_tmp_norm = 0.0_dp + endif + + ! half step epsilon_v drag + if (this%finite_strain_formulation) then + call matrix3x3_inverse(this%epsilon_r, F_inv) + vel_decay = transpose(matrix_exp(-0.5_dp*dt*this%gamma_epsilon*F_inv)) + vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay)) + this%epsilon_v = this%epsilon_v .mult. vel_decay + else + this%epsilon_v = this%epsilon_v * exp(-0.5_dp*dt*this%gamma_epsilon) + endif + ! half step epsilon_v force (from last step) parts + this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_epsilon + + ! half step barostat drag part of v + vel_decay = matrix_exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) + vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay)) + at%velo = vel_decay .mult. at%velo + + ! half step position affine defomration + pos_scale = matrix_exp(0.5_dp*dt*this%epsilon_v) + pos_scale = 0.5_dp*(pos_scale + transpose(pos_scale)) + lattice_p = pos_scale .mult. at%lattice + ! remove any rotation from new lattice + F_tmp = lattice_p .mult. this%lattice0_inv + F_tmp = 0.5_dp*(F_tmp + transpose(F_tmp)) + if (abs(deviation_from_identity(F_tmp) - this%F_tmp_norm) > 5.0e-2) then + call print_message('WARNING', "barostat transformation projecting away rotations is very different from previous one. Did the lattice change?") + endif + this%F_tmp_norm = deviation_from_identity(F_tmp) + lattice_p = F_tmp .mult. this%lattice0 + call set_lattice(at, lattice_p, scale_positions=.true.) + + end select + + end subroutine barostat_pre_vel1 + + subroutine barostat_post_vel1_pre_pos(this,at,dt,virial) + + type(barostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + real(dp), dimension(3,3), optional, intent(in) :: virial + + end subroutine barostat_post_vel1_pre_pos + + subroutine barostat_post_pos_pre_calc(this,at,dt,virial) + + type(barostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + real(dp), dimension(3,3), optional, intent(in) :: virial + + real(dp) :: pos_scale(3,3), lattice_p(3,3), F_tmp(3,3) + + select case(this%type) + + case(BAROSTAT_HOOVER_LANGEVIN) + !TIME_PROPAG_TEX 60 + !TIME_PROPAG_TEX 60 {\color {blue} + !TIME_PROPAG_TEX 60 after Verlet pos step, before force calc (barostat\_post\_pos\_pre\_calc) + !TIME_PROPAG_TEX 60 + !TIME_PROPAG_TEX 60 $$ (r,h) = \exp\left( (\tau/2) \epsilon_v \right) (r,h) $$ + !TIME_PROPAG_TEX 60 } + !TIME_PROPAG_TEX 60 + if (.not. present(virial)) call system_abort("barostat_post_pos_pre_calc needs virial") + + ! half step position affine defomration + pos_scale = matrix_exp(0.5_dp*dt*this%epsilon_v) + pos_scale = 0.5_dp*(pos_scale + transpose(pos_scale)) + lattice_p = pos_scale .mult. at%lattice + ! remove any rotation from new lattice + F_tmp = lattice_p .mult. this%lattice0_inv + F_tmp = 0.5_dp*(F_tmp + transpose(F_tmp)) + if (abs(deviation_from_identity(F_tmp) - this%F_tmp_norm) > 5.0e-2) then + call print_message('WARNING', "barostat transformation projecting away rotations is very different from previous one. Did the lattice change?") + endif + this%F_tmp_norm = deviation_from_identity(F_tmp) + lattice_p = F_tmp .mult. this%lattice0 + call set_lattice(at, lattice_p, scale_positions=.true.) + + end select + + end subroutine barostat_post_pos_pre_calc + + function deviation_from_identity(a) + real(dp), intent(in) :: a(:, :) + real(dp) :: deviation_from_identity + + integer :: i, j + + deviation_from_identity = 0.0_dp + do i=1, size(a, 1) + do j=1, size(a, 2) + if (i == j) then + deviation_from_identity = deviation_from_identity + (a(i,j)-1.0_dp)**2 + else + deviation_from_identity = deviation_from_identity + (a(i,j))**2 + endif + end do + end do + + deviation_from_identity = sqrt(deviation_from_identity) + + end function deviation_from_identity + + subroutine barostat_post_calc_pre_vel2(this,at,dt,virial) + + type(barostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + real(dp), dimension(3,3), optional, intent(in) :: virial + + end subroutine barostat_post_calc_pre_vel2 + + subroutine barostat_post_vel2(this,at,dt,virial) + + type(barostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + real(dp), dimension(3,3), optional, intent(in) :: virial + + integer :: i, j + real(dp) :: vel_decay(3,3), volume_p, rand_f_cell(3,3), kinetic_virial(3,3), F_det, F_T_inv(3,3), F_inv(3,3), epsilon_f_hydrostatic + real(dp) :: rand_f_scale + + select case(this%type) + + case(BAROSTAT_HOOVER_LANGEVIN) + !TIME_PROPAG_TEX 100 + !TIME_PROPAG_TEX 100 {\color {blue} + !TIME_PROPAG_TEX 100 after all Verlet and thermostat steps (barostat\_post\_vel2) + !TIME_PROPAG_TEX 100 + !TIME_PROPAG_TEX 100 $$ v = \exp \left( -(\tau/2) (1 + 3/N_d) \epsilon_v \right) v $$ + !TIME_PROPAG_TEX 100 $$ \epsilon_r = \epsilon_r + \tau \epsilon_v $$ + !TIME_PROPAG_TEX 100 $r.v.$ is symmetric matrix, normal distribution entries, variance 3 on diagonal and 6 off diagonal + !TIME_PROPAG_TEX 100 \begin{eqnarray*} + !TIME_PROPAG_TEX 100 \epsilon_f & = & \left[ 3 \left( \mathrm{vir} + \sum_i m_i v_i \otimes v_i + + !TIME_PROPAG_TEX 100 3 V \epsilon_r \sigma \epsilon_r^T / \left|\epsilon_r\right| + + !TIME_PROPAG_TEX 100 3/N_d \sum_i m_i v_i \otimes v_i \right) + \right. + !TIME_PROPAG_TEX 100 \\ & & \sqrt{2 k_B T \gamma_\epsilon W_\epsilon/\tau} r.v. \bigg] F^{-T} + !TIME_PROPAG_TEX 100 \end{eqnarray*} + !TIME_PROPAG_TEX 100 $$ \epsilon_v = \epsilon_v + (\tau/2) \epsilon_f/W_\epsilon $$ + !TIME_PROPAG_TEX 100 $$ \epsilon_v = \epsilon_v \exp\left( -(\tau/2) \gamma_\epsilon \epsilon_r^{-1}\right)^T$$ + !TIME_PROPAG_TEX 100 } + !TIME_PROPAG_TEX 100 + if (.not. present(virial)) call system_abort("barostat_pre_vel1 needs virial") + + call system_resync_rng() + + !Decay the velocities for dt/2 again barostat part + vel_decay = matrix_exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) + vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay)) + at%velo(:,:) = vel_decay .mult. at%velo(:,:) + + this%epsilon_r = this%epsilon_r + dt*this%epsilon_v + + ! calc epsilon force + volume_p = cell_volume(at) + rand_f_cell = 0.0_dp + do i=1, 3 + do j=i, 3 + if (i == j) then + rand_f_scale = 3.0_dp + else + ! empirical - maybe have something to do with fact that matrix is symmetric so there are + ! fewer degrees of freedom than first appears? + rand_f_scale = 6.0_dp + endif + rand_f_cell(i,j) = sqrt(rand_f_scale)*sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_epsilon*this%W_epsilon/dt)*ran_normal() + end do + end do + + ! symmetrize rand_f_cell + rand_f_cell(2,1) = rand_f_cell(1,2) + rand_f_cell(3,1) = rand_f_cell(1,3) + rand_f_cell(3,2) = rand_f_cell(2,3) + + kinetic_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) + kinetic_virial = 0.5_dp*(kinetic_virial + transpose(kinetic_virial)) + if (this%finite_strain_formulation) then + F_det = matrix3x3_det(this%epsilon_r) + call matrix3x3_inverse(transpose(this%epsilon_r), F_T_inv) + + this%epsilon_f = (3.0_dp*(virial+kinetic_virial+volume_p*(this%epsilon_r .mult. this%stress_ext .mult. transpose(this%epsilon_r))/F_det + & + 3.0_dp/this%Ndof*kinetic_virial) + rand_f_cell) .mult. F_T_inv + else + this%epsilon_f = 3.0_dp*(virial+kinetic_virial+volume_p*this%stress_ext + & + 3.0_dp/this%Ndof*kinetic_virial) + rand_f_cell + endif + + if (this%diagonal_strain .or. this%hydrostatic_strain) then + this%epsilon_f(1,2) = 0.0_dp + this%epsilon_f(1,3) = 0.0_dp + this%epsilon_f(2,3) = 0.0_dp + this%epsilon_f(2,1) = 0.0_dp + this%epsilon_f(3,1) = 0.0_dp + this%epsilon_f(3,2) = 0.0_dp + if (this%hydrostatic_strain) then + epsilon_f_hydrostatic = (this%epsilon_f(1,1)+ this%epsilon_f(2,2)+ this%epsilon_f(3,3)) / 3.0_dp + this%epsilon_f(1,1) = epsilon_f_hydrostatic + this%epsilon_f(2,2) = epsilon_f_hydrostatic + this%epsilon_f(3,3) = epsilon_f_hydrostatic + endif + endif + + ! half step with epsilon force + this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_epsilon + ! half step with epsilon drag + if (this%finite_strain_formulation) then + call matrix3x3_inverse(this%epsilon_r, F_inv) + vel_decay = transpose(matrix_exp(-0.5_dp*dt*this%gamma_epsilon*F_inv)) + vel_decay = 0.5_dp*(vel_decay + transpose(vel_decay)) + this%epsilon_v = this%epsilon_v .mult. vel_decay + else + this%epsilon_v = this%epsilon_v * exp(-0.5_dp*dt*this%gamma_epsilon) + endif + + call print("BAROSTAT_KE "//barostat_KE(this)) + + end select + + end subroutine barostat_post_vel2 + + function barostat_KE(this) + type(barostat), intent(in) :: this + real(dp) :: barostat_KE + + select case(this%type) + case(BAROSTAT_HOOVER_LANGEVIN) + barostat_KE = 0.5_dp*this%W_epsilon*sum(this%epsilon_v*transpose(this%epsilon_v)) + end select + end function barostat_KE + +end module barostat_module diff --git a/src/libAtoms/CInOutput.F90 b/src/libAtoms/CInOutput.F90 new file mode 100644 index 0000000000..ce942e07fd --- /dev/null +++ b/src/libAtoms/CInOutput.F90 @@ -0,0 +1,1090 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module CInOutput_module + + !% Interface to C routines for reading and writing Atoms objects to and from XYZ and NetCDF files. + + use iso_c_binding + use error_module + use linearalgebra_module, only: print, operator(.mult.), operator(.fne.) + use Extendable_str_module, only: Extendable_str, operator(//), string, concat, assignment(=) + use System_module, only: dp, current_verbosity, optional_default, s2a, a2s, parse_string, print, & + PRINT_NORMAL, PRINT_VERBOSE, PRINT_ALWAYS, PRINT_NERD, INPUT, OUTPUT, INOUT, lower_case, print_message + use PeriodicTable_module, only: atomic_number_from_symbol, ElementName + use Table_module, only: Table, allocate, append, TABLE_STRING_LENGTH + use Dictionary_module, only: Dictionary, has_key, get_value, set_value, print, subset, swap, lookup_entry_i, & + T_INTEGER, T_CHAR, T_REAL, T_LOGICAL, T_INTEGER_A, T_REAL_A, T_INTEGER_A2, T_REAL_A2, T_LOGICAL_A, T_CHAR_A, & + print_keys, c_dictionary_ptr_type, assignment(=) + use Atoms_module, only: Atoms, initialise, is_initialised, is_domain_decomposed, finalise, set_lattice, & + atoms_repoint, transform_basis, bcast, has_property, set_cutoff + use Atoms_types_module, only : add_property + use MPI_Context_module, only: MPI_context + use DomainDecomposition_module, only: allocate, comm_atoms_to_all + + implicit none + + private + + interface + + subroutine read_netcdf(filename, params, properties, selected_properties, lattice, cell_lengths, cell_angles, cell_rotated, & + n_atom, frame, zero, range, irep, rrep, error) bind(c) + use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename + integer(kind=C_INT), dimension(SIZEOF_FORTRAN_T), intent(in) :: params, properties, selected_properties + real(kind=C_DOUBLE), dimension(3,3), intent(out) :: lattice + real(kind=C_DOUBLE), dimension(3), intent(out) :: cell_lengths, cell_angles + integer(kind=C_INT), intent(out) :: cell_rotated, n_atom + integer(kind=C_INT), intent(in), value :: frame, zero, irep + integer(kind=C_INT), intent(in) :: range(2) + real(kind=C_DOUBLE), intent(in), value :: rrep + integer(kind=C_INT), intent(out) :: error + end subroutine read_netcdf + + subroutine write_netcdf(filename, params, properties, selected_properties, lattice, cell_lengths, cell_angles, cell_rotated, & + n_atom, n_label, n_string, frame, netcdf4, append, & + shuffle, deflate, deflate_level, error) bind(c) + use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename + integer(kind=C_INT), dimension(SIZEOF_FORTRAN_T), intent(in) :: params, properties, selected_properties + real(kind=C_DOUBLE), dimension(3,3), intent(in) :: lattice + real(kind=C_DOUBLE), dimension(3), intent(in) :: cell_lengths(3), cell_angles(3) + integer(kind=C_INT), intent(in), value :: cell_rotated, n_atom, n_label, n_string, frame, netcdf4, append, shuffle, deflate, deflate_level + integer(kind=C_INT), intent(out) :: error + end subroutine write_netcdf + + subroutine query_netcdf(filename, n_frame, n_atom, n_label, n_string, error) bind(c) + use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename + integer(kind=C_INT), intent(out) :: n_frame, n_atom, n_label, n_string + integer(kind=C_INT), intent(out) :: error + end subroutine query_netcdf + + subroutine read_xyz(filename, params, properties, selected_properties, lattice, n_atom, compute_index, frame, range, & + string, string_length, n_index, indices, error) bind(c) + use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename + integer(kind=C_INT), dimension(SIZEOF_FORTRAN_T), intent(in) :: params, properties, selected_properties + real(kind=C_DOUBLE), dimension(3,3), intent(out) :: lattice + integer(kind=C_INT), intent(inout) :: n_atom + integer(kind=C_INT), intent(in), value :: compute_index, frame, string, string_length + + integer(kind=C_INT), intent(in) :: range(2) + integer(kind=C_INT), intent(in), value :: n_index + integer(kind=C_INT), intent(in), dimension(n_index) :: indices + integer(kind=C_INT), intent(out) :: error + end subroutine read_xyz + + subroutine write_xyz(filename, params, properties, selected_properties, lattice, n_atom, append, prefix, & + int_format, real_format, str_format, logical_format, string, estr, update_index, error) bind(c) + use iso_c_binding, only: C_CHAR, C_INT, C_PTR, C_DOUBLE + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename + integer(kind=C_INT), dimension(SIZEOF_FORTRAN_T), intent(in) :: params, properties, selected_properties, estr + real(kind=C_DOUBLE), dimension(3,3), intent(in) :: lattice + integer(kind=C_INT), intent(in), value :: n_atom, append, update_index + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: prefix, int_format, real_format, str_format, logical_format + integer(kind=C_INT), intent(in), value :: string + integer(kind=C_INT), intent(out) :: error + end subroutine write_xyz + + subroutine query_xyz(filename, compute_index, frame, n_frame, n_atom, error) bind(c) + use iso_c_binding, only: C_CHAR, C_INT + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: filename + integer(kind=C_INT), intent(in), value :: compute_index, frame + integer(kind=C_INT), intent(out) :: n_frame, n_atom + integer(kind=C_INT), intent(out) :: error + end subroutine query_xyz + + subroutine quip_getcwd_wrapper(getcwd_return,getcwd_size) bind(c,name="fgetcwd_") + use, intrinsic :: iso_c_binding, only : c_char, c_int, c_null_char + implicit none + integer(kind=c_int), intent(in) :: getcwd_size + character(kind=c_char), dimension(getcwd_size) :: getcwd_return + endsubroutine quip_getcwd_wrapper + + function quip_getcwd_size_wrapper() bind(c,name="fgetcwd_size_") + use, intrinsic :: iso_c_binding, only : c_int + implicit none + integer(kind=c_int) :: quip_getcwd_size_wrapper + endfunction quip_getcwd_size_wrapper + + subroutine quip_chdir_wrapper(path) bind(c,name="fchdir_") + use, intrinsic :: iso_c_binding + implicit none + character(kind=c_char), dimension(*) :: path + endsubroutine quip_chdir_wrapper + + function quip_dirname_size_wrapper(path) bind(c,name="fdirname_size_") + use, intrinsic :: iso_c_binding, only : c_int, c_char + implicit none + integer(kind=c_int) :: quip_dirname_size_wrapper + character(kind=c_char), dimension(*) :: path + endfunction quip_dirname_size_wrapper + + subroutine quip_dirname_wrapper(path,dirname,dirname_size) bind(c,name="fdirname_") + use, intrinsic :: iso_c_binding + implicit none + integer(kind=c_int) :: dirname_size + character(kind=c_char), dimension(*) :: path + character(kind=c_char), dimension(*) :: dirname + endsubroutine quip_dirname_wrapper + + function quip_basename_size_wrapper(path) bind(c,name="fbasename_size_") + use, intrinsic :: iso_c_binding, only : c_int, c_char + implicit none + integer(kind=c_int) :: quip_basename_size_wrapper + character(kind=c_char), dimension(*) :: path + endfunction quip_basename_size_wrapper + + subroutine quip_basename_wrapper(path,basename,basename_size) bind(c,name="fbasename_") + use, intrinsic :: iso_c_binding + implicit none + integer(kind=c_int) :: basename_size + character(kind=c_char), dimension(*) :: path + character(kind=c_char), dimension(*) :: basename + endsubroutine quip_basename_wrapper + + function fmd5sum(filename,md5sum) bind(c,name="fmd5sum_") + use, intrinsic :: iso_c_binding, only : c_int, c_char + implicit none + integer(kind=c_int) :: fmd5sum + character(kind=c_char), dimension(*) :: filename + character(kind=c_char), dimension(33) :: md5sum + endfunction fmd5sum + + end interface + + integer, parameter :: XYZ_FORMAT = 1 + integer, parameter :: NETCDF_FORMAT = 2 + real(dp), parameter :: LATTICE_TOL = 1.0e-8_dp + + type CInOutput + logical :: initialised = .false. + character(len=1024) :: filename, basename, extension + integer :: action + integer :: format + logical :: got_index + logical :: netcdf4 + logical :: append + logical :: one_frame_per_file + integer :: current_frame + integer :: n_frame + integer :: n_atom + integer :: n_label + integer :: n_string + integer :: n_digit + type(MPI_Context) :: mpi + end type CInOutput + + interface initialise + !% Open a file for reading or writing. File type (Extended XYZ or NetCDF) is guessed from + !% filename extension. Filename 'stdout' with action 'OUTPUT' to write XYZ to stdout. + module procedure CInOutput_initialise + end interface + + interface finalise + !% Close file and free memory. Calls close() interface. + module procedure CInOutput_finalise + end interface + + interface close + !% Close file. After a call to close(), you can can call initialise() again + !% to reopen a new file. + module procedure CInOutput_close + end interface + + interface read + !% Read an Atoms object from this CInOutput stream. + !% + !% Important :attr:`~.Atoms.properties` which may be present (non-exhaustive list): + !% + !% * **species**, str, 1 col -- atomic species, e.g. Si or H + !% * **pos**, real, 3 cols -- cartesian positions, in A + !% * **Z**, int, 1 col -- atomic numbers + !% * **mass**, real, 1 col -- atomic masses, in A,eV,fs units system + !% * **velo**, real, 3 cols -- velocities, in A/fs + !% * **acc**, real, 3 cols -- accelerations, in A/fs$^2$ + !% * **hybrid**, int, 1 col -- one for QM atoms and zero for hybrid atoms + !% * **frac_pos**, real, 3 cols -- fractional positions of atoms + !% + !% Along with all :attr:`~Atoms.params` entries, the + !% :attr:`~.Atoms.lattice`, :attr:`~.Atoms.cutoff`, and + !% attr:`~Atoms.nneightol` attributes are read from the comment + !% line of XYZ file, or from special variables in NetCDF files + module procedure CInOutput_read + module procedure atoms_read + module procedure atoms_read_cinoutput + end interface + + interface write + !% Write an Atoms object to this CInOutput stream. + ! + !% Along with all atomic :attr:`~.Atoms.properties` and + !% :attr:`~Atoms.params` entries, the :attr:`~.Atoms.lattice`, + !% :attr:`~.Atoms.cutoff` and attr:`~Atoms.nneightol` attributes + !% are written to the comment line of XYZ file, or from special + !% variables in NetCDF files + module procedure CInOutput_write + module procedure atoms_write + module procedure atoms_write_cinoutput + end interface + + interface quip_chdir + module procedure quip_chdir_char + module procedure quip_chdir_extendable_str + end interface quip_chdir + + interface quip_dirname + module procedure quip_dirname_char + module procedure quip_dirname_extendable_str + end interface quip_dirname + + interface quip_basename + module procedure quip_basename_char + module procedure quip_basename_extendable_str + end interface quip_basename + + public :: CInOutput, initialise, finalise, close, read, write + public :: quip_getcwd, quip_chdir, quip_dirname, quip_basename, quip_md5sum + +contains + + subroutine cinoutput_initialise(this, filename, action, append, netcdf4, no_compute_index, frame, one_frame_per_file, mpi, error) + use iso_c_binding, only: C_INT + type(CInOutput), intent(inout) :: this + character(*), intent(in), optional :: filename + integer, intent(in), optional :: action + logical, intent(in), optional :: append + logical, optional, intent(in) :: netcdf4 + logical, optional, intent(in) :: no_compute_index + logical, optional, intent(in) :: one_frame_per_file + integer, optional, intent(in) :: frame + type(MPI_context), optional, intent(in) :: mpi + integer, intent(out), optional :: error + + character(len=1024) :: my_filename + character(len=100) :: fmt + integer :: compute_index, n_file, dot_index + logical :: file_exists + + INIT_ERROR(error) + + this%action = optional_default(INPUT, action) + this%append = optional_default(.false., append) + this%netcdf4 = optional_default(.false., netcdf4) + this%filename = optional_default('', filename) + this%one_frame_per_file = optional_default(.false., one_frame_per_file) + compute_index = 1 + if (present(no_compute_index)) then + if (no_compute_index) compute_index = 0 + end if + if (present(mpi)) this%mpi = mpi + + dot_index = index(filename,'.',.true.) + if (dot_index == 0) then + this%basename = this%filename + this%extension = '' + else + this%basename = filename(:dot_index-1) + this%extension = filename(dot_index:) + end if + this%n_digit = 0 + if (this%one_frame_per_file) then + compute_index = 0 + do + if (this%filename(dot_index-1-this%n_digit:dot_index-1-this%n_digit) /= '0') exit + this%n_digit = this%n_digit + 1 + this%basename = this%filename(:dot_index-1-this%n_digit) + end do + if (this%n_digit == 0) then + RAISE_ERROR("one_frame_per_file=T but no zeros found in filename - use e.g. file_00000.xyz", error) + end if + fmt = '(a,i'//this%n_digit//'.'//this%n_digit//',a)' + end if + + ! Guess format from file extension + if (trim(filename) == '') then + this%format = XYZ_FORMAT + else + if (trim(this%extension) == '.nc') then + this%format = NETCDF_FORMAT + else + this%format = XYZ_FORMAT + end if + end if + + this%n_frame = 0 + this%n_atom = 0 + this%n_label = 0 + this%n_string = 0 + this%current_frame = optional_default(0, frame) + this%got_index = .false. + + ! Should we do an initial query to count number of frames/atoms? + if (.not. this%mpi%active .or. (this%mpi%active .and. this%mpi%my_proc == 0)) then + if (this%one_frame_per_file) then + n_file = 0 + do + write (my_filename, fmt) trim(this%basename), n_file, trim(this%extension) + inquire(file=my_filename, exist=file_exists) + if (.not. file_exists) exit + n_file = n_file + 1 + end do + write (my_filename, fmt) trim(this%basename), 0, trim(this%extension) ! do query on frame 0 + file_exists = n_file > 0 + else + my_filename = this%filename + inquire(file=my_filename, exist=file_exists) + end if + my_filename = trim(my_filename)//C_NULL_CHAR + if (file_exists) then + if (this%format == NETCDF_FORMAT) then + call query_netcdf(my_filename, this%n_frame, this%n_atom, this%n_label, this%n_string, error) + BCAST_PASS_ERROR(error, this%mpi) + this%got_index = .true. + else + if (this%action /= OUTPUT .and. trim(this%filename) /= '' .and. trim(this%filename) /= 'stdin' .and. trim(this%filename) /= 'stdout') then + call query_xyz(my_filename, compute_index, this%current_frame, this%n_frame, this%n_atom, error) + BCAST_PASS_ERROR(error, this%mpi) + this%got_index = .false. + if (compute_index == 1) this%got_index = .true. + else + this%got_index = .false. + end if + end if + end if + if (this%one_frame_per_file) this%n_frame = n_file + end if + + if (this%mpi%active) then + BCAST_CHECK_ERROR(error, this%mpi) + call bcast(this%mpi, this%n_frame) + call bcast(this%mpi, this%n_atom) + call bcast(this%mpi, this%n_label) + call bcast(this%mpi, this%n_string) + end if + + if (this%action /= INPUT .and. this%append) this%current_frame = this%n_frame + + this%initialised = .true. + + end subroutine cinoutput_initialise + + subroutine cinoutput_close(this) + type(CInOutput), intent(inout) :: this + + this%initialised = .false. + + end subroutine cinoutput_close + + subroutine cinoutput_finalise(this) + type(CInOutput), intent(inout) :: this + + call cinoutput_close(this) + + end subroutine cinoutput_finalise + + + subroutine cinoutput_read(this, at, properties, properties_array, frame, zero, range, str, estr, indices, error) + use iso_c_binding, only: C_INT + type(CInOutput), intent(inout) :: this + type(Atoms), target, intent(inout) :: at + character(*), intent(in), optional :: properties + character(*), intent(in), optional :: properties_array(:) + integer, optional, intent(in) :: frame + logical, optional, intent(in) :: zero + integer, optional, intent(in) :: range(2) + character(*), intent(in), optional :: str + type(extendable_str), intent(in), optional :: estr + integer, dimension(:), intent(in), optional :: indices + integer, intent(out), optional :: error + + type(Dictionary) :: empty_dictionary + type(Dictionary), target :: selected_properties, tmp_params + integer :: i, j, k, n_properties + integer(C_INT) :: do_zero, do_compute_index, do_frame, i_rep, do_range(2), cell_rotated, n_index + integer(C_INT), dimension(:), allocatable :: c_indices + real(C_DOUBLE) :: r_rep + real(dp) :: lattice(3,3), maxlen(3), sep(3), cell_lengths(3), cell_angles(3), orig_lattice(3,3), cutoff, nneightol + type(c_dictionary_ptr_type) :: params_ptr, properties_ptr, selected_properties_ptr + integer, dimension(SIZEOF_FORTRAN_T) :: params_ptr_i, properties_ptr_i, selected_properties_ptr_i + integer n_atom + character(len=100) :: tmp_properties_array(100), fmt + character(len=1024) :: filename + type(Extendable_Str), dimension(:), allocatable :: filtered_keys + logical, dimension(3) :: pbc + + real, parameter :: vacuum = 10.0_dp ! amount of vacuum to add if no lattice found in file + + INIT_ERROR(error) + + if (.not. this%initialised) then + RAISE_ERROR_WITH_KIND(ERROR_IO,"This CInOutput object is not initialised", error) + endif + if (this%action /= INPUT .and. this%action /= INOUT) then + RAISE_ERROR_WITH_KIND(ERROR_IO,"Cannot read from action=OUTPUT CInOutput object", error) + endif + + if (present(str) .and. present(estr)) then + RAISE_ERROR('CInOutput_read: only one of "str" and "estr" may be present, not both', error) + end if + + if (present(range) .and. is_domain_decomposed(at)) then + RAISE_ERROR("atoms_read_cinoutput: Please provide either *range* only if the system is not domain decomposed.", error) + endif + + call finalise(at) + + n_atom = 0 + + if (.not. this%mpi%active .or. (this%mpi%active .and. this%mpi%my_proc == 0)) then + + call print('cinoutput_read: doing read on proc '//this%mpi%my_proc, PRINT_NERD) + + do_frame = optional_default(this%current_frame, frame) + + if (this%n_frame /= 0) then + if (do_frame < 0) do_frame = this%n_frame + do_frame ! negative frames count backwards from end + if (do_frame < 0 .or. do_frame >= this%n_frame) then + BCAST_RAISE_ERROR_WITH_KIND(ERROR_IO_EOF,"cinoutput_read: frame "//int(do_frame)//" out of range 0 <= frame < "//int(this%n_frame), error, this%mpi) + end if + end if + + do_zero = 0 + if (present(zero)) then + if (zero) do_zero = 1 + end if + + do_range(:) = 0 + if (present(range)) do_range = range + if (is_domain_decomposed(at)) then + ! Only read part of the files... + do_range = (/ & + at%domain%mpi%my_proc*this%n_atom/at%domain%mpi%n_procs+1, & + (at%domain%mpi%my_proc+1)*this%n_atom/at%domain%mpi%n_procs & + /) + n_atom = this%n_atom + endif + + n_index = -1 + if (present(indices)) then + if (this%format == NETCDF_FORMAT) then + RAISE_ERROR('cinoutput_read: indices argument not yet supported for NetCDF files', error) + end if + n_index = size(indices) + allocate(c_indices(n_index)) + c_indices(:) = indices + else + allocate(c_indices(0)) + end if + + call initialise(selected_properties) + if (present(properties) .or. present(properties_array)) then + if (present(properties_array)) then + do i=1,size(properties_array) + call set_value(selected_properties, properties_array(i), 1) + end do + PASS_ERROR(error) + else ! we've got a colon-separated string + call parse_string(properties, ':', tmp_properties_array, n_properties, error=error) + PASS_ERROR(error) + if (n_properties > size(tmp_properties_array)) then + RAISE_ERROR('cinoutput_read: too many properties given in "properties" argument', error) + end if + do i=1,n_properties + call set_value(selected_properties, tmp_properties_array(i), 1) + end do + end if + end if + + lattice = 0.0_dp + lattice(1,1) = 1.0_dp + lattice(2,2) = 1.0_dp + lattice(3,3) = 1.0_dp + call initialise(empty_dictionary) ! pass an empty dictionary to prevent pos, species, z properties being created + call initialise(at, 0, lattice, & + Nbuffer=this%n_atom, properties=empty_dictionary) + call finalise(empty_dictionary) + + call initialise(tmp_params) + params_ptr%p => tmp_params + properties_ptr%p => at%properties + selected_properties_ptr%p => selected_properties + params_ptr_i = transfer(params_ptr, params_ptr_i) + properties_ptr_i = transfer(properties_ptr, properties_ptr_i) + selected_properties_ptr_i = transfer(selected_properties_ptr, selected_properties_ptr_i) + + if (this%one_frame_per_file) then + fmt = '(a,i'//this%n_digit//'.'//this%n_digit//',a)' + write (filename, fmt) trim(this%basename), do_frame, trim(this%extension) + do_frame = 0 + else + filename = this%filename + end if + filename = trim(filename)//C_NULL_CHAR + + if (this%format == NETCDF_FORMAT) then + i_rep = 0 + r_rep = 0.0_dp + + call read_netcdf(filename, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & + orig_lattice, cell_lengths, cell_angles, cell_rotated, n_atom, do_frame, do_zero, do_range, i_rep, r_rep, error) + else + do_compute_index = 1 + if (.not. this%got_index) do_compute_index = 0 + if (present(str)) then + call read_xyz(str, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & + orig_lattice, n_atom, do_compute_index, do_frame, do_range, 1, len_trim(str), & + n_index, c_indices, error) + else if(present(estr)) then + call read_xyz(estr%s, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & + orig_lattice, n_atom, do_compute_index, do_frame, do_range, 1, estr%len, & + n_index, c_indices, error) + else + call read_xyz(filename, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & + orig_lattice, n_atom, do_compute_index, do_frame, do_range, 0, 0, & + n_index, c_indices, error) + end if + end if + BCAST_PASS_ERROR(error, this%mpi) + call finalise(selected_properties) + deallocate(c_indices) + + if (get_value(tmp_params, 'cutoff', cutoff)) then + call set_cutoff(at, cutoff) + end if + + if (get_value(tmp_params, 'pbc', pbc)) then + at%is_periodic = pbc + end if + + if (get_value(tmp_params, 'nneightol', nneightol)) at%nneightol = nneightol + + ! Copy tmp_params into at%params, removing "Lattice", "Properties", "cutoff", + ! "pbc" and "nneightol"entries + allocate(filtered_keys(tmp_params%N)) + j = 1 + do i=1,tmp_params%N + if (string(tmp_params%keys(i)) == 'Lattice' .or. & + string(tmp_params%keys(i)) == 'Properties' .or. & + string(tmp_params%keys(i)) == 'cutoff' .or. & + string(tmp_params%keys(i)) == 'nneightol' .or. & + string(tmp_params%keys(i)) == 'pbc') cycle + + call initialise(filtered_keys(j), tmp_params%keys(i)) + j = j + 1 + end do + + call subset(tmp_params, filtered_keys(1:j-1), at%params) + call finalise(tmp_params) + do i=1,size(filtered_keys) + call finalise(filtered_keys(i)) + end do + deallocate(filtered_keys) + + at%N = n_atom + at%Ndomain = at%N + if (is_domain_decomposed(at)) then + ! XXX FIXME For now: Buffer size it total number of atoms + at%Nbuffer = this%n_atom + else + at%Nbuffer = at%N + endif + at%ref_count = 1 + call atoms_repoint(at) + + if (this%format == XYZ_FORMAT) then + at%lattice = orig_lattice + ! read_xyz() sets all lattice components to 0.0 if no lattice was present + + if (all(abs(at%lattice) < 1e-5_dp)) then + at%lattice(:,:) = 0.0_dp + + maxlen = 0.0_dp + do i=1,at%N + do j=1,at%N + sep = at%pos(:,i)-at%pos(:,j) + do k=1,3 + if (abs(sep(k)) > maxlen(k)) maxlen(k) = abs(sep(k)) + end do + end do + end do + + do k=1,3 + at%lattice(k,k) = maxlen(k) + vacuum + end do + end if + call set_lattice(at, at%lattice, scale_positions=.false.) + else + ! NetCDF format. We may have to undo rotation of positions and lattice + + ! First construct lattice from cell_lengths and cell_angles + ! By construction, this lattice will have cell vector a parallel to x axis + ! and cell vector b in x-y plane + call lattice_abc_to_xyz(cell_lengths, cell_angles, lattice) + call set_lattice(at, lattice, scale_positions=.false.) + + ! If a rotation was applied, now revert to original stored lattice, rotating positions + if (cell_rotated == 1) then + call transform_basis(at, orig_lattice .mult. at%g) + end if + end if + + if (.not. has_property(at,"Z") .and. .not. has_property(at, "species")) then + call print ("at%properties keys", PRINT_ALWAYS) + call print_keys(at%properties, PRINT_ALWAYS) + BCAST_RAISE_ERROR('cinoutput_read: atoms object read from file has neither Z nor species', error, this%mpi) + else if (.not. has_property(at,"species") .and. has_property(at,"Z")) then + call add_property(at, "species", repeat(" ",TABLE_STRING_LENGTH)) + call atoms_repoint(at) + do i=1,at%N + at%species(1:len(ElementName(at%Z(i))),i) = s2a(ElementName(at%Z(i))) + end do + else if (.not. has_property(at,"Z") .and. has_property(at, "species")) then + call add_property(at, "Z", 0) + call atoms_repoint(at) + do i=1,at%n + at%Z(i) = atomic_number_from_symbol(a2s(at%species(:,i))) + end do + end if + + this%current_frame = this%current_frame + 1 + + end if + + if (this%mpi%active) then + BCAST_CHECK_ERROR(error,this%mpi) + call bcast(this%mpi, at) + end if + + if (is_domain_decomposed(at)) then + call allocate(at%domain, at, range=do_range, error=error) + PASS_ERROR(error) + ! Set global indices + call comm_atoms_to_all(at%domain, at, error=error) + PASS_ERROR(error) + endif + + end subroutine cinoutput_read + + + subroutine cinoutput_write(this, at, properties, properties_array, prefix, int_format, real_format, frame, & + shuffle, deflate, deflate_level, estr, update_index, error) + type c_extendable_str_ptr_type + type(Extendable_str), pointer :: p + end type c_extendable_str_ptr_type + type(CInOutput), intent(inout) :: this + type(Atoms), target, intent(inout) :: at + character(*), intent(in), optional :: properties + character(*), intent(in), optional :: properties_array(:) + character(*), intent(in), optional :: prefix + character(*), intent(in), optional :: int_format, real_format + integer, intent(in), optional :: frame + logical, intent(in), optional :: shuffle, deflate, update_index + integer, intent(in), optional :: deflate_level + type(Extendable_Str), intent(inout), optional, target :: estr + integer, intent(out), optional :: error + + logical :: file_exists + integer :: i + integer(C_INT) :: do_frame, n_label, n_string, do_netcdf4, do_update_index + type(Dictionary), target :: selected_properties, tmp_params + character(len=100) :: do_prefix, do_int_format, do_real_format, do_str_format, do_logical_format, fmt + character(len=1024) :: filename + integer(C_INT) :: do_shuffle, do_deflate, do_deflate_level, append + character(len=100) :: tmp_properties_array(at%properties%n) + integer n_properties + type(c_dictionary_ptr_type) :: params_ptr, properties_ptr, selected_properties_ptr + integer, dimension(SIZEOF_FORTRAN_T) :: params_ptr_i, properties_ptr_i, selected_properties_ptr_i, estr_ptr_i + type(c_extendable_str_ptr_type) :: estr_ptr + real(dp) :: cell_lengths(3), cell_angles(3), orig_lattice(3,3), new_lattice(3,3) + integer :: cell_rotated + + INIT_ERROR(error) + + if (.not. this%initialised) then + RAISE_ERROR("cinoutput_write: this CInOutput object is not initialised", error) + endif + if (this%action /= OUTPUT .and. this%action /= INOUT) then + RAISE_ERROR("cinoutput_write: cannot write to action=INPUT CInOutput object", error) + endif + if (.not. is_initialised(at)) then + RAISE_ERROR("cinoutput_write: atoms object not initialised", error) + end if + + if (this%mpi%active .and. this%mpi%my_proc /= 0) return + + ! These are C-strings and thus must be terminated with '\0' + do_prefix = trim(optional_default('', prefix))//C_NULL_CHAR + do_int_format = trim(optional_default('%8d', int_format))//C_NULL_CHAR + do_real_format = trim(optional_default('%16.8f', real_format))//C_NULL_CHAR + do_str_format = '%.10s'//C_NULL_CHAR + do_logical_format = '%5c'//C_NULL_CHAR + + do_frame = optional_default(this%current_frame, frame) + + do_shuffle = transfer(optional_default(.true., shuffle),do_shuffle) + do_deflate = transfer(optional_default(.true., deflate),do_shuffle) + do_deflate_level = optional_default(6, deflate_level) + do_update_index = transfer(optional_default(.true., update_index), do_update_index) + + append = 0 + inquire(file=this%filename, exist=file_exists) + if (file_exists .and. this%append .or. (.not. this%one_frame_per_file .and. this%current_frame /= 0)) append = 1 + + do_netcdf4 = 0 + if (this%netcdf4) do_netcdf4 = 1 + + + if (present(properties) .and. present(properties_array)) then + RAISE_ERROR('cinoutput_write: "properties" and "properties_array" cannot both be present.', error) + end if + + if (this%format == NETCDF_FORMAT) then + ! Since lattice is stored in NetCDF file as cell lengths and angles, + ! we may need to rotate atomic positions to align cell vector a + ! with x axis and cell vector b lies in x-y plane. + ! This transformation preserves the fractional coordinates. + + orig_lattice = at%lattice + call lattice_xyz_to_abc(at%lattice, cell_lengths, cell_angles) + call lattice_abc_to_xyz(cell_lengths, cell_angles, new_lattice) + + cell_rotated = 0 + if (maxval(abs(orig_lattice - new_lattice)) > LATTICE_TOL) then + cell_rotated = 1 + call transform_basis(at, new_lattice .mult. at%g) + end if + end if + + call initialise(selected_properties) + if (.not. present(properties) .and. .not. present(properties_array)) then + do i=1,at%properties%N + call set_value(selected_properties, string(at%properties%keys(i)), 1) + end do + else + if (present(properties_array)) then + do i=1,size(properties_array) + call set_value(selected_properties, properties_array(i), 1) + end do + else ! we've got a colon-separated string + call parse_string(properties, ':', tmp_properties_array, n_properties, error=error) + PASS_ERROR(error) + do i=1,n_properties + call set_value(selected_properties, tmp_properties_array(i), 1) + end do + end if + end if + + tmp_params = at%params ! Make a copy since write_xyz() adds "Lattice" and "Properties" keys + + call set_value(tmp_params, 'cutoff', at%cutoff) + call set_value(tmp_params, 'nneightol', at%nneightol) + call set_value(tmp_params, 'pbc', at%is_periodic) + + params_ptr%p => tmp_params + properties_ptr%p => at%properties + selected_properties_ptr%p => selected_properties + params_ptr_i = transfer(params_ptr, params_ptr_i) + properties_ptr_i = transfer(properties_ptr, properties_ptr_i) + selected_properties_ptr_i = transfer(selected_properties_ptr, selected_properties_ptr_i) + if (present(estr)) then + estr_ptr%p => estr + estr_ptr_i = transfer(estr_ptr, estr_ptr_i) + end if + + n_label = 10 + n_string = 1024 + + if (this%one_frame_per_file) then + fmt = '(a,i'//this%n_digit//'.'//this%n_digit//',a)' + write (filename, fmt) trim(this%basename), do_frame, trim(this%extension) + do_frame = 0 + do_update_index = 0 + else + filename = this%filename + end if + filename = trim(filename)//C_NULL_CHAR + + if (this%format == NETCDF_FORMAT) then + + call write_netcdf(filename, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & + orig_lattice, cell_lengths, cell_angles, cell_rotated, at%n, n_label, n_string, do_frame, & + do_netcdf4, append, do_shuffle, do_deflate, do_deflate_level, error) + PASS_ERROR(error) + + if (cell_rotated == 1) then + ! Revert to original basis + call transform_basis(at, orig_lattice .mult. at%g) + end if + + else + ! Put "species" in first column and "pos" in second + if (selected_properties%n > 1) then + if (has_key(selected_properties, 'species')) & + call swap(selected_properties, 'species', string(selected_properties%keys(1))) + if (has_key(selected_properties, 'pos')) & + call swap(selected_properties, 'pos', string(selected_properties%keys(2))) + end if + + if (present(estr)) then + call write_xyz(''//C_NULL_CHAR, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & + at%lattice, at%n, append, do_prefix, do_int_format, do_real_format, do_str_format, do_logical_format, 1, estr_ptr_i, 0, error) + else + call write_xyz(filename, params_ptr_i, properties_ptr_i, selected_properties_ptr_i, & + at%lattice, at%n, append, do_prefix, do_int_format, do_real_format, do_str_format, do_logical_format, 0, estr_ptr_i, & + do_update_index, error) + end if + PASS_ERROR(error) + end if + + call finalise(selected_properties) + call finalise(tmp_params) + this%current_frame = this%current_frame + 1 + + end subroutine cinoutput_write + + subroutine atoms_read(this, filename, properties, properties_array, frame, zero, range, str, estr, no_compute_index, mpi, error) + !% Read Atoms object from XYZ or NetCDF file. + type(Atoms), intent(inout) :: this + character(len=*), intent(in), optional :: filename + character(*), intent(in), optional :: properties + character(*), intent(in), optional :: properties_array(:) + integer, optional, intent(in) :: frame + logical, optional, intent(in) :: zero + integer, optional, intent(in) :: range(2) + character(len=*), intent(in), optional :: str + type(extendable_str), intent(in), optional :: estr + logical, optional, intent(in) :: no_compute_index + type(MPI_context), optional, intent(inout) :: mpi + integer, intent(out), optional :: error + + type(CInOutput) :: cio + + INIT_ERROR(error) + + if (present(mpi) .and. is_domain_decomposed(this)) then + RAISE_ERROR("atoms_read: Please provide *mpi* only if the Atoms object is not domain decomposed.", error) + endif + + call initialise(cio, filename, INPUT, no_compute_index=no_compute_index, mpi=mpi, error=error) + PASS_ERROR_WITH_INFO('While reading "' // filename // '".', error) + call read(cio, this, properties, properties_array, frame, zero, range, str, estr, error=error) + PASS_ERROR_WITH_INFO('While reading "' // filename // '".', error) + call finalise(cio) + + end subroutine atoms_read + + subroutine atoms_read_cinoutput(this, cio, properties, properties_array, frame, zero, range, str, estr, error) + type(Atoms), target, intent(inout) :: this + type(CInOutput), intent(inout) :: cio + character(*), intent(in), optional :: properties + character(*), intent(in), optional :: properties_array(:) + integer, optional, intent(in) :: frame + logical, optional, intent(in) :: zero + integer, optional, intent(in) :: range(2) + character(len=*), intent(in), optional :: str + type(extendable_str), intent(in), optional :: estr + integer, intent(out), optional :: error + + INIT_ERROR(error) + call cinoutput_read(cio, this, properties, properties_array, frame, zero, range, str, estr, error=error) + PASS_ERROR(error) + + end subroutine atoms_read_cinoutput + + subroutine atoms_write(this, filename, append, properties, properties_array, prefix, int_format, real_format, estr, error) + !% Write Atoms object to XYZ or NetCDF file. Use filename "stdout" to write to terminal. + use iso_fortran_env + type(Atoms), intent(inout) :: this + character(len=*), intent(in), optional :: filename + logical, optional, intent(in) :: append + character(*), intent(in), optional :: properties + character(*), intent(in), optional :: properties_array(:) + character(*), intent(in), optional :: prefix + character(*), intent(in), optional :: int_format, real_format + type(extendable_str), intent(inout), optional :: estr + integer, intent(out), optional :: error + + type(CInOutput) :: cio + type(MPI_context) :: mpi + + if (trim(filename) == 'stdout') then + if (PRINT_NORMAL > current_verbosity()) return + call initialise(mpi) + if (mpi%active .and. mpi%my_proc /= 0) return + flush(output_unit) + end if + + INIT_ERROR(error) + call initialise(cio, filename, OUTPUT, append, error=error) + PASS_ERROR_WITH_INFO('While writing "' // filename // '".', error) + call write(cio, this, properties, properties_array, prefix, int_format, real_format, estr=estr, error=error) + PASS_ERROR_WITH_INFO('While writing "' // filename // '".', error) + call finalise(cio) + + end subroutine atoms_write + + subroutine atoms_write_cinoutput(this, cio, properties, properties_array, prefix, int_format, real_format, frame, shuffle, deflate, deflate_level, estr, error) + type(Atoms), target, intent(inout) :: this + type(CInOutput), intent(inout) :: cio + character(*), intent(in), optional :: properties + character(*), intent(in), optional :: properties_array(:) + character(*), intent(in), optional :: prefix, int_format, real_format + integer, intent(in), optional :: frame + logical, intent(in), optional :: shuffle, deflate + integer, intent(in), optional :: deflate_level + type(extendable_str), intent(inout), optional :: estr + integer, intent(out), optional :: error + + INIT_ERROR(error) + call cinoutput_write(cio, this, properties, properties_array, prefix, int_format, real_format, frame, shuffle, deflate, deflate_level, estr, error=error) + PASS_ERROR(error) + + end subroutine atoms_write_cinoutput + + function quip_getcwd() + type(extendable_str) :: quip_getcwd + + integer :: i, n + character(len=1), dimension(:), allocatable :: c + + n = quip_getcwd_size_wrapper() + allocate(c(n)) + call quip_getcwd_wrapper(c,n) + + call initialise(quip_getcwd) + quip_getcwd = "" + do i = 1, n + if( c(i) == C_NULL_CHAR ) exit + call concat(quip_getcwd,c(i),no_trim=.true.) + enddo + + deallocate(c) + + endfunction quip_getcwd + + subroutine quip_chdir_char(path) + character(len=*), intent(in) :: path + + call quip_chdir_wrapper(trim(path)//C_NULL_CHAR) + + endsubroutine quip_chdir_char + + subroutine quip_chdir_extendable_str(path) + type(extendable_str), intent(in) :: path + + call quip_chdir_char(string(path)) + endsubroutine quip_chdir_extendable_str + + function quip_basename_char(path) + type(extendable_str) :: quip_basename_char + character(len=*), intent(in) :: path + + integer :: i, n + character(len=1), dimension(:), allocatable :: c + + n = quip_basename_size_wrapper(trim(path)//C_NULL_CHAR) + allocate(c(n)) + call quip_basename_wrapper(trim(path)//C_NULL_CHAR,c,n) + + call initialise(quip_basename_char) + quip_basename_char = "" + do i = 1, n + if( c(i) == C_NULL_CHAR ) exit + call concat(quip_basename_char,c(i),no_trim=.true.) + enddo + + deallocate(c) + + endfunction quip_basename_char + + function quip_basename_extendable_str(path) + type(extendable_str) :: quip_basename_extendable_str + type(extendable_str), intent(in) :: path + + quip_basename_extendable_str = quip_basename_char(string(path)) + endfunction quip_basename_extendable_str + + function quip_dirname_char(path) + type(extendable_str) :: quip_dirname_char + character(len=*), intent(in) :: path + + integer :: i, n + character(len=1), dimension(:), allocatable :: c + + n = quip_dirname_size_wrapper(trim(path)//C_NULL_CHAR) + allocate(c(n)) + call quip_dirname_wrapper(trim(path)//C_NULL_CHAR,c,n) + + call initialise(quip_dirname_char) + quip_dirname_char = "" + do i = 1, n + if( c(i) == C_NULL_CHAR ) exit + call concat(quip_dirname_char,c(i),no_trim=.true.) + enddo + + deallocate(c) + + endfunction quip_dirname_char + + function quip_dirname_extendable_str(path) + type(extendable_str) :: quip_dirname_extendable_str + type(extendable_str), intent(in) :: path + + quip_dirname_extendable_str = quip_dirname(string(path)) + endfunction quip_dirname_extendable_str + + subroutine quip_md5sum(filename,md5sum,stat) + character(len=*), intent(in) :: filename + character(len=32), intent(out) :: md5sum + integer, intent(out), optional :: stat + + integer :: my_stat + character(len=33) :: tmp_md5sum + logical :: l + + my_stat = fmd5sum(trim(filename)//C_NULL_CHAR,tmp_md5sum) + if( my_stat /= 0 ) then + call print_message('WARNING', "quip_md5sum: could not obtain md5 sum of "//trim(filename)) + call print_message('WARNING', "quip_md5sum: fmd5sum returned with code "//my_stat) + md5sum = "" + else + md5sum = tmp_md5sum(1:32) + endif + + if(present(stat)) stat = my_stat + + endsubroutine quip_md5sum + +end module CInOutput_module diff --git a/src/libAtoms/Connection.F90 b/src/libAtoms/Connection.F90 new file mode 100644 index 0000000000..2ec1592851 --- /dev/null +++ b/src/libAtoms/Connection.F90 @@ -0,0 +1,2239 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Connection module +!X +!% A Connection object stores the connectivity information (i.e. +!% list) for a specific Atoms object. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module Connection_module + + use error_module + use system_module + use units_module + use periodictable_module + use linearalgebra_module + use dictionary_module + use table_module + use Atoms_types_module + +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif + implicit none +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif + private + + real(dp), parameter :: CONNECT_LATTICE_TOL = 1e-8_dp + + public :: Connection + + public :: initialise + interface initialise + module procedure connection_initialise + end interface initialise + + public :: finalise + interface finalise + module procedure connection_finalise + end interface finalise + + public :: wipe + interface wipe + module procedure connection_wipe + end interface wipe + + !% Print a verbose textual description of a Connection object to the default + !% logger or to a specificied Inoutput object. + public :: print + interface print + module procedure connection_print + end interface print + + !% Overloaded assigment operators for Connection objects. + public :: assignment(=) + interface assignment(=) + module procedure connection_assignment + end interface assignment(=) + + public :: deepcopy + interface deepcopy + module procedure connection_assignment + endinterface deepcopy + + public :: calc_connect + interface calc_connect + module procedure connection_calc_connect + endinterface + + public :: calc_dists + interface calc_dists + module procedure connection_calc_dists + end interface calc_dists + + public :: calc_connect_hysteretic + interface calc_connect_hysteretic + module procedure connection_calc_connect_hysteretic + endinterface + + public :: n_neighbours + interface n_neighbours + module procedure connection_n_neighbours, connection_n_neighbours_with_dist + end interface + + public :: n_neighbours_total + interface n_neighbours_total + module procedure connection_n_neighbours_total + endinterface + + public :: is_min_image + interface is_min_image + module procedure connection_is_min_image + end interface + + public :: neighbour + interface neighbour + module procedure connection_neighbour, connection_neighbour_minimal + endinterface + + public :: neighbour_index + interface neighbour_index + module procedure connection_neighbour_index + endinterface + + public :: neighbour_minimal + interface neighbour_minimal + module procedure connection_neighbour_minimal + endinterface + + public :: add_bond, remove_bond, remove_bonds, cell_of_pos, connection_cells_initialise + public :: connection_fill, divide_cell, fit_box_in_cell, get_min_max_images + public :: max_cutoff, partition_atoms, cell_n + public :: is_in_subregion + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Connectivity procedures: Initialise and Finalise + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + !% Initialise a Connection object for a given number of atoms 'N'. + !% If the optional Atoms argument is present then we calculate + !% the atomic density to initialise the default lengths of the neighbour + !% list for efficient memory usage. + subroutine connection_initialise(this, N, Nbuffer, pos, lattice, g, origin, extent, nn_guess, store_rij, fill) + type(Connection), intent(inout) :: this + integer, intent(in) :: N ! No. of atoms + integer, intent(in) :: Nbuffer ! Buffer size + real(dp), optional, intent(in) :: pos(:,:), lattice(3,3), g(3,3) + real(dp), optional, intent(in) :: origin(3), extent(3,3) + integer, optional, intent(in) :: nn_guess + logical, optional, intent(in) :: store_rij + logical, optional, intent(in) :: fill + + logical :: do_fill + + do_fill = optional_default(.true., fill) + + ! If already initialised, destroy the existing data and start again + if (this%initialised) call connection_finalise(this) + + if (do_fill) call connection_fill(this, N, Nbuffer, pos, lattice, g, origin, extent, nn_guess, store_rij) + + this%last_connect_cutoff = 0.0_dp + this%last_connect_lattice(:,:) = 0.0_dp + + end subroutine connection_initialise + + subroutine connection_fill(this, N, Nbuffer, pos, lattice, g, origin, extent, nn_guess, store_rij, error) + type(Connection), intent(inout) :: this + integer, intent(in) :: N ! No. of atoms + integer, intent(in) :: Nbuffer ! Buffer size + real(dp), optional, intent(in) :: pos(:,:), lattice(3,3), g(3,3) + real(dp), optional, intent(in) :: origin(3), extent(3,3) + integer, optional, intent(in) :: nn_guess + logical, optional, intent(in) :: store_rij + integer, intent(out), optional :: error + + integer :: i, do_nn_guess + real(dp) :: extent_inv(3,3), subregion_center(3) + logical :: do_subregion, do_store_rij + + INIT_ERROR(error) + do_nn_guess = optional_default(5, nn_guess) + + if (present(origin) .and. present(extent)) then + if (.not.present(lattice) .or. .not.present(g)) then + RAISE_ERROR("connection_fill got origin and extent, so trying to do subregion, but lattice or g are missing", error) + end if + do_subregion = .true. + call matrix3x3_inverse(extent,extent_inv) + subregion_center = origin + 0.5_dp*sum(extent,2) + else + do_subregion = .false. + endif + + if (allocated(this%neighbour1)) then + if (size(this%neighbour1, 1) < Nbuffer) deallocate(this%neighbour1) + endif + if (allocated(this%neighbour2)) then + if (size(this%neighbour2, 1) < Nbuffer) deallocate(this%neighbour2) + endif + + if (.not. allocated(this%neighbour1)) allocate(this%neighbour1(Nbuffer)) + if (.not. allocated(this%neighbour2)) allocate(this%neighbour2(Nbuffer)) + do i=1,Nbuffer + if (do_subregion .and. i <= N) then + if (.not. is_in_subregion(pos(:,i), subregion_center, lattice, g, extent_inv)) then + if (associated(this%neighbour1(i)%t)) then + call connection_remove_atom(this, i, error) + PASS_ERROR(error) + call finalise(this%neighbour1(i)%t) + call finalise(this%neighbour2(i)%t) + deallocate(this%neighbour1(i)%t) + deallocate(this%neighbour2(i)%t) + endif + cycle + endif + endif + if (.not. associated(this%neighbour1(i)%t)) then + allocate(this%neighbour1(i)%t) + do_store_rij = optional_default(.false., store_rij) + if (do_store_rij) then + call allocate(this%neighbour1(i)%t,4,4, 0, 0, max(do_nn_guess, 1)) + else + call allocate(this%neighbour1(i)%t,4,1, 0, 0, max(do_nn_guess, 1)) + endif + this%neighbour1(i)%t%increment = max(do_nn_guess/2, 1) + + allocate(this%neighbour2(i)%t) + call allocate(this%neighbour2(i)%t,2,0, 0, 0, max(do_nn_guess, 1)) + this%neighbour2(i)%t%increment = max(do_nn_guess/2, 1) + endif + end do + + this%initialised = .true. + + end subroutine connection_fill + + function is_in_subregion(p, center, lattice, lattice_inv, extent_inv) + real(dp), intent(in) :: p(3), center(3) + real(dp), intent(in) :: lattice(3,3), lattice_inv(3,3), extent_inv(3,3) + logical :: is_in_subregion + + real(dp) :: relative_p(3), extent_lattice_relative_p(3) + + relative_p = p - center + call map_into_cell(relative_p, lattice, lattice_inv) + + extent_lattice_relative_p = extent_inv .mult. relative_p + + if (any(extent_lattice_relative_p < -0.5_dp) .or. any(extent_lattice_relative_p > 0.5_dp)) then + is_in_subregion = .false. + else + is_in_subregion = .true. + endif + + end function is_in_subregion + + + !% OMIT + subroutine connection_cells_initialise(this,cellsNa,cellsNb,cellsNc,Natoms) + + type(Connection), intent(inout) :: this + integer, intent(in) :: cellsNa,cellsNb,cellsNc ! No. cells in a,b,c directions + integer, optional, intent(in) :: Natoms ! Number of atoms + integer :: i,j,k,av_atoms,stdev_atoms,Ncells + + if (this%cells_initialised) call connection_cells_finalise(this) + + !Set length and increment based on binomial statistics (if possible) + Ncells = cellsNa * cellsNb * cellsNc + if (present(Natoms)) then + av_atoms = Natoms / Ncells + stdev_atoms = int(sqrt(real(Natoms,dp) * (real(Ncells,dp) - 1.0_dp) / (real(Ncells,dp) * real(Ncells,dp)))) + else + av_atoms = 100 !defaults if number of atoms is not given + stdev_atoms = 10 + end if + + allocate(this%cell_heads(cellsNa, cellsNb, cellsNc)) + this%cell_heads = 0 + + this%cellsNa = cellsNa + this%cellsNb = cellsNb + this%cellsNc = cellsNc + + this%cells_initialised = .true. + + end subroutine connection_cells_initialise + + + !% Finalise this connection object + subroutine connection_finalise(this) + + type(Connection), intent(inout) :: this + integer :: i + + !do nothing if not initialised / already finalised + if (.not.this%initialised) return + + if (allocated(this%neighbour1)) then + do i=1,size(this%neighbour1) + if (associated(this%neighbour1(i)%t)) then + call finalise(this%neighbour1(i)%t) + deallocate(this%neighbour1(i)%t) + endif + end do + endif + + if (allocated(this%neighbour2)) then + do i=1,size(this%neighbour2) + if (associated(this%neighbour2(i)%t)) then + call finalise(this%neighbour2(i)%t) + deallocate(this%neighbour2(i)%t) + endif + end do + endif + + + if(allocated(this%neighbour1)) deallocate(this%neighbour1) + if(allocated(this%neighbour2)) deallocate(this%neighbour2) + + if (allocated(this%is_min_image)) deallocate(this%is_min_image) + + if (allocated(this%last_connect_pos)) deallocate(this%last_connect_pos) + + call connection_cells_finalise(this) + + this%initialised = .false. + + end subroutine connection_finalise + + !% Wipe the contents of the connection tables, but keep the allocation + subroutine connection_wipe(this) + + type(Connection), intent(inout) :: this + integer :: i + + !do nothing if not initialised / already finalised + if (.not.this%initialised) return + + do i=1,size(this%neighbour1) + call wipe(this%neighbour1(i)%t) + end do + + do i=1,size(this%neighbour2) + call wipe(this%neighbour2(i)%t) + end do + + call wipe_cells(this) + + end subroutine connection_wipe + + !% OMIT + subroutine connection_cells_finalise(this) + + type(Connection), intent(inout) :: this + integer :: i,j,k + + if (.not.this%cells_initialised) return + + deallocate(this%cell_heads) + if (allocated(this%next_atom_in_cell)) then + deallocate(this%next_atom_in_cell) + endif + + this%cells_initialised = .false. + + end subroutine connection_cells_finalise + + subroutine connection_assignment(to,from) + + type(Connection), intent(inout) :: to + type(Connection), intent(in) :: from + integer :: i,j,k + + call connection_finalise(to) + + if (.not.from%initialised) return + + + call connection_initialise(to,size(from%neighbour1),size(from%neighbour1)) + + + ! Use Append to append the source tables to our (empty) destination tables + do i=1,size(from%neighbour1) + call append(to%neighbour1(i)%t,from%neighbour1(i)%t) + end do + + do i=1,size(from%neighbour2) + call append(to%neighbour2(i)%t,from%neighbour2(i)%t) + end do + + + !If cell data is present then copy that too + if (from%cells_initialised) then + call connection_cells_initialise(to,from%cellsNa,from%cellsNb,from%cellsNc) + to%cell_heads = from%cell_heads + if (allocated(to%next_atom_in_cell) .and. allocated(from%next_atom_in_cell)) then + to%next_atom_in_cell = from%next_atom_in_cell + endif + end if + + end subroutine connection_assignment + + !% OMIT + subroutine wipe_cells(this) + + type(Connection) :: this + integer :: i,j,k + + if (this%cells_initialised) then + this%cell_heads = 0 + end if + + end subroutine wipe_cells + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Connectivity procedures + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Test if atom $i$ is a neighbour of atom $j$ and update 'this%connect' as necessary. + !% Called by 'calc_connect'. The 'shift' vector is added to the position of the $j$ atom + !% to get the correct image position. + subroutine test_form_bond(this, cutoff, use_uniform_cutoff, Z, pos, lattice, i,j, shift, check_for_dup, error) + + type(Connection), intent(inout) :: this + real(dp), intent(in) :: cutoff + logical, intent(in) :: use_uniform_cutoff + integer, intent(in) :: Z(:) + real(dp), intent(in) :: pos(:,:), lattice(3,3) + integer, intent(in) :: i,j + integer, intent(in) :: shift(3) + logical, intent(in) :: check_for_dup + integer, intent(out), optional :: error + + integer :: index, m, k + real(dp) :: d, dd(3) + real(dp) :: use_cutoff + + INIT_ERROR(error) + if (i > j) return + + if (.not. associated(this%neighbour1(i)%t) .or. .not. associated(this%neighbour1(j)%t)) return + +#ifdef DEBUG + if(current_verbosity() >= PRINT_ANALYSIS) then + call print('Entering test_form_bond, i = '//i//' j = '//j, PRINT_ANALYSIS) + call print('use_uniform_cutoff = '//use_uniform_cutoff, PRINT_ANALYSIS) + call print('cutoff = '//cutoff, PRINT_ANALYSIS) + end if +#endif + + !Determine what cutoff distance to use + if (use_uniform_cutoff) then + use_cutoff = cutoff + else + use_cutoff = bond_length(Z(i),Z(j)) * cutoff + end if + + !d = norm(pos(:,j)+(lattice .mult. shift) - pos(:,i)) + !OPTIM + dd = pos(:,j) - pos(:,i) + do m=1,3 + forall(k=1:3) dd(k) = dd(k) + lattice(k,m) * shift(m) + end do + + if (.not. check_for_dup) then + do m=1,3 + if (dd(m) > use_cutoff) return + end do + end if + + d = sqrt(dd(1)*dd(1) + dd(2)*dd(2) + dd(3)*dd(3)) + + if (check_for_dup) then + index = find(this%neighbour1(i)%t, (/ j, shift /)) + if (index /= 0) then ! bond is already in table +#ifdef DEBUG + if (current_verbosity() >= PRINT_ANALYSIS) call print('test_form_bond had check_for_dup=T, found bond already in table', PRINT_ANALYSIS) +#endif + this%neighbour1(i)%t%real(1,index) = d + if (size(this%neighbour1(i)%t%real,1) == 4) then ! store_rij was set + this%neighbour1(i)%t%real(2:4,index) = pos(1:3,j) + (lattice .mult. shift) - pos(1:3,i) + endif + return + endif + endif + +#ifdef DEBUG + if(current_verbosity() >= PRINT_ANALYSIS) call print('d = '//d, PRINT_ANALYSIS) +#endif + + if (d < use_cutoff) then + call add_bond(this, pos, lattice, i, j, shift, d, error=error) + PASS_ERROR(error) + end if + +#ifdef DEBUG + if(current_verbosity() >= PRINT_ANALYSIS) call print('Leaving test_form_bond', PRINT_ANALYSIS) +#endif + + end subroutine test_form_bond + + !% Test if atom $i$ is no longer neighbour of atom $j$ with shift $s$, and update 'this%connect' as necessary. + !% Called by 'calc_connect'. The 'shift' vector is added to the position of the $j$ atom + !% to get the correct image position. + function test_break_bond(this, cutoff_break, use_uniform_cutoff, Z, pos, lattice, i,j, shift, error) + type(Connection), intent(inout) :: this + real(dp), intent(in) :: cutoff_break + logical, intent(in) :: use_uniform_cutoff + integer, intent(in) :: Z(:) + real(dp), intent(in) :: pos(:,:), lattice(3,3) + integer, intent(in) :: i,j + integer, intent(in) :: shift(3) + logical test_break_bond + integer, intent(out), optional :: error + + real(dp) :: d + real(dp) :: cutoff + + INIT_ERROR(error) + test_break_bond = .false. + if (i > j) return + + if (.not. associated(this%neighbour1(i)%t) .or. .not. associated(this%neighbour1(j)%t)) return + +#ifdef DEBUG + if(current_verbosity() >= PRINT_ANALYSIS) then + call print('Entering test_break_bond, i = '//i//' j = '//j, PRINT_ANALYSIS) + call print(" cutoff_break = "// cutoff_break, PRINT_ANALYSIS) + call print(" use_uniform_cutoff ="//use_uniform_cutoff, PRINT_ANALYSIS) + end if +#endif + + !Determine what cutoff distance to use + if (use_uniform_cutoff) then + cutoff = cutoff_break + else + cutoff = bond_length(Z(i),Z(j)) * cutoff_break + end if + + d = norm(pos(:,j)+(lattice .mult. shift) - pos(:,i)) +#ifdef DEBUG + if(current_verbosity() >= PRINT_ANALYSIS) call print('d = '//d//' cutof = '//cutoff//' i = '//i//' j = '//j, PRINT_ANALYSIS) +#endif + if (d > cutoff) then +#ifdef DEBUG + if(current_verbosity() >= PRINT_ANALYSIS) call print('removing bond from tables', PRINT_ANALYSIS) +#endif + call remove_bond(this, i, j, shift, error) + PASS_ERROR(error) + test_break_bond = .true. + end if + +#ifdef DEBUG + if(current_verbosity() >= PRINT_ANALYSIS) call print('Leaving test_break_bond', PRINT_ANALYSIS) +#endif + + end function test_break_bond + + subroutine add_bond(this, pos, lattice, i, j, shift, d, dv, error) + type(Connection), intent(inout) :: this + real(dp), intent(in) :: pos(:,:), lattice(3,3) + integer, intent(in) :: i,j + integer, intent(in) :: shift(3) + real(dp), intent(in) :: d + real(dp), intent(in), optional :: dv(3) + integer, intent(out), optional :: error + + real(dp) :: ddv(3) + integer :: ii, jj, index + + INIT_ERROR(error) + if (.not.this%initialised) then + RAISE_ERROR("add_bond called on uninitialized connection", error) + endif + + if (.not. associated(this%neighbour1(i)%t) .or. .not. associated(this%neighbour1(j)%t)) then + RAISE_ERROR("tried to add_bond for atoms i " // i // " j " // j // " which have associated(neighbour1()%t "//associated(this%neighbour1(i)%t) // " " // associated(this%neighbour1(j)%t) // " one of which is false", error) + endif + + if (i > j) then + ii = j + jj = i + else + ii = i + jj = j + endif + + if (present(dv)) then + ddv = dv*sign(1,j-i) + else ! dv not present + if (size(this%neighbour1(i)%t%real,1) == 4) then + ddv = pos(:,jj) + (lattice .mult. shift) - pos(:,ii) + endif + endif + + ! Add full details to neighbour1 for smaller of i and j + if (size(this%neighbour1(i)%t%real,1) == 4) then ! store_rij was set + call append(this%neighbour1(ii)%t, (/jj, shift /), (/ d, ddv /)) + else + call append(this%neighbour1(ii)%t, (/jj, shift /), (/ d /)) + endif + if(ii .ne. jj) then + index = this%neighbour1(min(ii,jj))%t%N + ! Put a reference to this in neighbour2 for larger of i and j + call append(this%neighbour2(jj)%t, (/ ii, index/)) + end if + + end subroutine add_bond + + + subroutine remove_bond(this, i, j, shift, error) + type(Connection), intent(inout) :: this + integer, intent(in) :: i,j + integer, intent(in), optional :: shift(3) + integer, intent(out), optional :: error + + + integer :: ii, jj, iii, jjj, jjjj, r_index, n_removed, my_shift(3) + + INIT_ERROR(error) + if (.not. associated(this%neighbour1(i)%t) .or. .not. associated(this%neighbour1(j)%t)) then + RAISE_ERROR("tried to remove_bond for atoms i " // i // " j " // j // " which have associated(neighbour1()%t " //associated(this%neighbour1(i)%t) // " " // associated(this%neighbour1(j)%t) // " one of which is false", error) + endif + + if (i > j) then + ii = j + jj = i + if (present(shift)) my_shift = -shift + else + ii = i + jj = j + if (present(shift)) my_shift = shift + endif + ! now ii <= jj + + r_index = 1 + n_removed = 0 + do while (r_index /= 0) + ! remove entry from neighbour1(ii) + if (present(shift)) then + r_index = find(this%neighbour1(ii)%t, (/ jj, my_shift /) ) + else + r_index = find(this%neighbour1(ii)%t, (/ jj, 0, 0, 0 /), (/ .true., .false., .false., .false./) ) + endif + if (r_index == 0) then + if (n_removed == 0) then + if (present(shift)) then + call print("WARNING: remove bond called for i " // i // " j " // j // " shift " // shift // & + " couldn't find a bond to remove", PRINT_ALWAYS) + else + call print("WARNING: remove bond called for i " // i // " j " // j // & + " couldn't find a bond to remove", PRINT_ALWAYS) + endif + endif + else ! r_index /= 0 + n_removed = n_removed + 1 + + call delete(this%neighbour1(ii)%t, r_index, keep_order = .true.) + ! remove entry from neighbour2(jj) + if (ii /= jj) then + call delete(this%neighbour2(jj)%t, (/ ii, r_index /), keep_order = .true.) + endif + ! renumber other neighbour2 entries + do iii=r_index, this%neighbour1(ii)%t%N + ! jjj is another neighbour of ii + jjj = this%neighbour1(ii)%t%int(1,iii) + if (jjj > ii) then + ! jjjj is r_index in jjj's neighbour2 of pointer back to ii's neighbour1 + jjjj = find(this%neighbour2(jjj)%t, (/ ii, iii+1 /) ) + if (jjjj /= 0) then + ! decrement reference in jjj's neighbour2 table + this%neighbour2(jjj)%t%int(:,jjjj) = (/ ii, iii /) + else + RAISE_ERROR("remove_bond: Couldn't find neighbor to fix neighbour2 of", error) + endif + endif + end do + end if ! r_index == 0 + end do ! while r_index /= 0 + + end subroutine remove_bond + + + !% Remove all bonds listed in the Table `bonds` from connectivity + subroutine remove_bonds(this, at, bonds, error) + type(Connection), intent(inout) :: this + type(Atoms), intent(in) :: at + type(Table), intent(in) :: bonds + integer, intent(out), optional :: error + + logical :: bond_exists + integer :: i, j, ji + integer :: shift(3) + + INIT_ERROR(error) + + do i=1,bonds%N + bond_exists = .false. + do ji=1, n_neighbours(this,bonds%int(1,i)) + j = neighbour(this, at, bonds%int(1,i), ji, shift=shift) + if (j == bonds%int(2,i)) then + bond_exists = .true. + exit + endif + end do + if (bond_exists) then + call remove_bond(this, bonds%int(1,i), bonds%int(2,i), shift, error=error) + PASS_ERROR(error) + endif + end do + end subroutine remove_bonds + + + subroutine calc_lat_eff(at, lat_eff, lat_eff_inv, lat_offset) + type(Atoms), intent(in) :: at + real(dp), intent(out) :: lat_eff(3,3), lat_eff_inv(3,3), lat_offset(3) + + integer :: i + real(dp) :: lat_extent + real(dp), allocatable :: lat_pos(:,:) + + lat_eff = at%lattice + lat_offset = 0.0 + if (any(.not. at%is_periodic)) then + allocate(lat_pos(3,at%N)) + lat_pos = at%g .mult. at%pos + do i=1,3 + if (.not. at%is_periodic(i) .and. (minval(lat_pos(i,:)) <= 0.5 .or. maxval(lat_pos(i,:)) >= 0.5)) then + lat_extent = (maxval(lat_pos(i,:)) - minval(lat_pos(i,:))) * 1.1 + lat_eff(:,i) = lat_eff(:,i)/norm(lat_eff(:,i)) * lat_extent + lat_offset(i) = minval(lat_pos(i,:)) - 0.05 + endif + end do + deallocate(lat_pos) + endif + call matrix3x3_inverse(lat_eff,lat_eff_inv) + end subroutine + + + !% As for 'calc_connect', but perform the connectivity update + !% hystertically: atoms must come within 'cutoff' to be considered + !% neighbours, and then will remain connect until them move apart + !% further than 'cutoff_break'. + subroutine connection_calc_connect_hysteretic(this, at, cutoff_factor, cutoff_break_factor, & + origin, extent, own_neighbour, store_is_min_image, store_n_neighb, error) + type(Connection), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(in) :: cutoff_factor, cutoff_break_factor + real(dp), optional :: origin(3), extent(3,3) + logical, optional, intent(in) :: own_neighbour, store_is_min_image, store_n_neighb + integer, intent(out), optional :: error + + integer :: cellsNa,cellsNb,cellsNc + integer :: i,j,k,i2,j2,k2,i3,j3,k3,i4,j4,k4,atom1,atom2 +! integer :: n1, n2 + integer :: cell_image_Na, cell_image_Nb, cell_image_Nc + integer :: min_cell_image_Na + integer :: max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb + integer :: min_cell_image_Nc, max_cell_image_Nc + real(dp) :: cutoff ! absolute cutoffs + integer :: ji, s_ij(3), nn_guess + logical my_own_neighbour, my_store_is_min_image, my_store_n_neighb + logical :: change_i, change_j, change_k, broken + integer, pointer :: map_shift(:,:), n_neighb(:) + real(dp) :: lat_eff(3,3), lat_eff_inv(3,3), lat_offset(3) + + INIT_ERROR(error) + + this%N = at%N + + my_own_neighbour = optional_default(.false., own_neighbour) + my_store_is_min_image = optional_default(.true., store_is_min_image) + my_store_n_neighb = optional_default(.true., store_n_neighb) + + !Find the maximum covalent radius of all the atoms in the structure, double it + !and multiple by cutoff. At makes sure we can deal with the worst case scenario of big atom + !bonded to big atom + cutoff = 0.0_dp + do i = 1, at%N + if (ElementCovRad(at%Z(i)) > cutoff) cutoff = ElementCovRad(at%Z(i)) + end do + cutoff = (2.0_dp * cutoff) * cutoff_factor + + call print("calc_connect_hysteretic: cutoff_factor " // cutoff_factor, PRINT_NERD) + call print("calc_connect_hysteretic: cutoff_break_factor " // cutoff_break_factor, PRINT_NERD) + call print("calc_connect_hysteretic: cutoff " // cutoff, PRINT_NERD) + + if (present(origin) .and. present(extent)) then + cellsNa = 1 + cellsNb = 1 + cellsNc = 1 + else + call calc_lat_eff(at, lat_eff, lat_eff_inv, lat_offset) + call divide_cell(lat_eff, cutoff, cellsNa, cellsNb, cellsNc) + endif + + call print("calc_connect: cells_N[abc] " // cellsNa // " " // cellsNb // " " // cellsNc, PRINT_NERD) + + ! If the lattice has changed, then the cells need de/reallocating + if (this%cells_initialised) then + if ((cellsNa /= this%cellsNa) .or. & + (cellsNb /= this%cellsNb) .or. & + (cellsNc /= this%cellsNc)) call connection_cells_finalise(this) + end if + + ! figure out how many unit cell images we will need to loop over in each direction + call fit_box_in_cell(cutoff, cutoff, cutoff, at%lattice, cell_image_Na, cell_image_Nb, cell_image_Nc) + ! cell_image_N{a,b,c} apply to a box of side 2*cutoff. Since we loop from -cell_image_N to + ! +cell_image_N we can reduce them as follows + + cell_image_Na = max(1,(cell_image_Na+1)/2) + cell_image_Nb = max(1,(cell_image_Nb+1)/2) + cell_image_Nc = max(1,(cell_image_Nc+1)/2) + + ! Estimate number of neighbours of each atom. Factor of 1/2 assumes + ! half will go in neighbour1, half in neighbour2. + nn_guess = int(0.5_dp*4.0_dp/3.0_dp*PI*cutoff**3*at%N/cell_volume(at%lattice)*cell_image_Na*cell_image_Nb*cell_image_Nc) + + call print('calc_connect: image cells '//cell_image_Na//'x'//cell_image_Nb//'x'//cell_image_Nc, PRINT_NERD) + + ! Allocate space for the connection object if needed + if (present(origin) .and. present(extent)) then + if (.not.this%initialised) then + call connection_initialise(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, origin, extent, nn_guess) + else + call connection_fill(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, origin, extent, nn_guess) + end if + else + if (.not.this%initialised) then + call connection_initialise(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, nn_guess=nn_guess) + else + call connection_fill(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, nn_guess=nn_guess) + end if + endif + + if (.not.this%cells_initialised) then + call connection_cells_initialise(this, cellsNa, cellsNb, cellsNc,at%N) + endif + + ! Partition the atoms into cells + call partition_atoms(this, at, lat_eff_inv, lat_offset, error=error) + PASS_ERROR(error) + if (.not. assign_pointer(at, 'map_shift', map_shift)) then + RAISE_ERROR("calc_connect impossibly failed to assign map_shift pointer", error) + end if + + ! look for bonds that have been broken, and remove them + do i=1, at%N + ji = 1 + do + if (ji > n_neighbours(this, i)) exit + j = connection_neighbour(this, at, i, ji, shift = s_ij) + broken = test_break_bond(this, cutoff_break_factor, .false., & + at%Z, at%pos, at%lattice, i, j, s_ij, error) + PASS_ERROR(error) + if (.not. broken) then + ji = ji + 1 ! we didn't break at bond, so go to next one + ! if we did break a bond, ji now points to a different bond, so don't increment it + endif + end do + end do + + ! Here is the main loop: + ! Go through each cell and update the connectivity between atoms in at cell and neighbouring cells + ! N.B. test_form_bond updates both atoms i and j, so only update if i <= j to avoid doubling processing + + ! defaults for cellsNx = 1 + k3 = 1; k4 = 1; j3 = 1; j4 = 1; i3 = 1; i4 = 1 + ! Loop over all cells + do k = 1, cellsNc + change_k = .true. + do j = 1, cellsNb + change_j = .true. + do i = 1, cellsNa + change_i = .true. + call get_min_max_images(at%is_periodic, cellsNa, cellsNb, cellsNc, & + cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k, change_i, change_j, change_k, & + min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc) + change_i = .false. + change_j = .false. + change_k = .false. + + !Loop over atoms in cell(i,j,k) + atom1 = this%cell_heads(i, j, k) + atom1_loop: do while (atom1 > 0) + + ! Loop over neighbouring cells, applying PBC + do k2 = -cell_image_Nc, +cell_image_Nc + + ! the stored cell we are in + if(cellsNc > 1) k3 = mod(k+k2-1+cellsNc,cellsNc)+1 + + ! the shift we need to get to the cell image + k4 = (k+k2-k3)/cellsNc + + do j2 = -cell_image_Nb, +cell_image_Nb + ! the stored cell we are in + if(cellsNb > 1) j3 = mod(j+j2-1+cellsNb,cellsNb)+1 + + ! the shift we need to get to the cell image + j4 = (j+j2-j3)/cellsNb + + do i2 = -cell_image_Na, +cell_image_Na + ! the stored cell we are in + if(cellsNa > 1) i3 = mod(i+i2-1+cellsNa,cellsNa)+1 + + ! the shift we need to get to the cell image + i4 = (i+i2-i3)/cellsNa + + ! The cell we are currently testing atom1 against is cell(i3,j3,k3) + ! with shift (i4,j4,k4) + ! loop over it's atoms and test connectivity if atom1 < atom2 + + atom2 = this%cell_heads(i3,j3,k3) + atom2_loop: do while (atom2 > 0) + + ! omit atom2 < atom1 + if (atom1 > atom2) then + atom2 = this%next_atom_in_cell(atom2) + cycle atom2_loop + endif + ! omit self in the same cell without shift + if (.not. my_own_neighbour .and. (atom1 == atom2 .and. & + (i4==0 .and. j4==0 .and. k4==0) .and. & + (i==i3 .and. j==j3 .and. k==k3))) then + atom2 = this%next_atom_in_cell(atom2) + cycle atom2_loop + endif + + call test_form_bond(this, cutoff_factor, .false., & + at%Z, at%pos, at%lattice, atom1,atom2, & + (/i4-map_shift(1,atom1)+map_shift(1,atom2),j4-map_shift(2,atom1)+map_shift(2,atom2),k4-map_shift(3,atom1)+map_shift(3,atom2)/), & + .true., error) + PASS_ERROR(error) + + atom2 = this%next_atom_in_cell(atom2) + end do atom2_loop ! atom2 + + end do ! i2 + end do ! j2 + end do ! k2 + + atom1 = this%next_atom_in_cell(atom1) + end do atom1_loop ! atom1 + + end do ! i + end do ! j + end do ! k + + if (my_store_is_min_image) then + if (allocated(this%is_min_image)) deallocate(this%is_min_image) + allocate(this%is_min_image(at%n)) + do i=1,at%n + if (associated(this%neighbour1(i)%t)) then + this%is_min_image(i) = is_min_image(this, i) + else + this%is_min_image(i) = .false. + end if + end do + end if + + if (my_store_n_neighb) then + call add_property(at, 'n_neighb', 0, ptr=n_neighb, overwrite=.true.) + do i=1,at%n + n_neighb(i) = n_neighbours(this, i) + end do + end if + + + end subroutine connection_calc_connect_hysteretic + + subroutine connection_remove_atom(this, i, error) + type(Connection), intent(inout) :: this + integer, intent(in) :: i + integer, intent(out), optional :: error + + integer :: ji, j, jj, s_ij(3), n_entries + + INIT_ERROR(error) + n_entries=this%neighbour1(i)%t%N + do ji=n_entries, 1, -1 + j = this%neighbour1(i)%t%int(1,ji) + s_ij = this%neighbour1(i)%t%int(2:4,ji) + call remove_bond(this, i, j, s_ij, error) + PASS_ERROR(error) + end do + + n_entries=this%neighbour2(i)%t%N + do ji=n_entries, 1, -1 + j = this%neighbour2(i)%t%int(1,ji) + jj = this%neighbour2(i)%t%int(2,ji) + s_ij = this%neighbour1(j)%t%int(2:4,jj) + call remove_bond(this, j, i, s_ij, error) + PASS_ERROR(error) + end do + + end subroutine connection_remove_atom + + + !% Fast $O(N)$ connectivity calculation routine. It divides the unit + !% cell into similarly shaped subcells, of sufficient size that + !% sphere of radius 'cutoff' is contained in a subcell, at least in + !% the directions in which the unit cell is big enough. For very + !% small unit cells, there is only one subcell, so the routine is + !% equivalent to the standard $O(N^2)$ method. If 'cutoff_skin' is + !% present, effective cutoff is increased by this amount, and full + !% recalculation of connectivity is only done when any atom has + !% moved more than 0.5*cutoff_skin. + subroutine connection_calc_connect(this, at, own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb, cutoff_skin, max_pos_change, did_rebuild, error) + type(Connection), intent(inout) :: this + type(Atoms), intent(inout) :: at + logical, optional, intent(in) :: own_neighbour, store_is_min_image, skip_zero_zero_bonds, store_n_neighb + real(dp), intent(in), optional :: cutoff_skin + real(dp), intent(out), optional :: max_pos_change + logical, intent(out), optional :: did_rebuild + integer, intent(out), optional :: error + + integer :: cellsNa,cellsNb,cellsNc + integer :: i,j,k,i2,j2,k2,i3,j3,k3,i4,j4,k4,atom1,atom2 +! integer :: n1,n2 + integer :: cell_image_Na, cell_image_Nb, cell_image_Nc, nn_guess, n_occ + integer :: min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb + integer :: max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc + real(dp) :: cutoff, density, volume_per_cell, pos_change, my_max_pos_change + logical my_own_neighbour, my_store_is_min_image, my_skip_zero_zero_bonds, my_store_n_neighb, do_fill + logical :: change_i, change_j, change_k + integer, pointer :: map_shift(:,:), n_neighb(:) + real(dp) :: lat_eff(3,3), lat_eff_inv(3,3), lat_offset(3) + real(dp), allocatable :: lat_pos(:,:) + + + INIT_ERROR(error) + + call system_timer('calc_connect') + + this%N = at%N + + my_own_neighbour = optional_default(.false., own_neighbour) + my_store_is_min_image = optional_default(.true., store_is_min_image) + my_skip_zero_zero_bonds = optional_default(.false., skip_zero_zero_bonds) + my_store_n_neighb = optional_default(.true., store_n_neighb) + + if (at%cutoff < 0.0_dp) then + RAISE_ERROR('calc_connect: Negative cutoff radius ' // at%cutoff, error) + end if + + ! The default is -1.0, so catch the unset-cutoff case explicitly + if ((at%cutoff .feq. -1.0_dp)) then + RAISE_ERROR('calc_connect: at%cutoff==-1.0. Call set_cutoff() first!', error) + endif + + ! The value 0.0 means "don't compute neighbours" - should this still output a message? + if ((at%cutoff .feq. 0.0_dp)) then + return + endif + + !Calculate the cutoff value we should use in dividing up the simulation cell + cutoff = at%cutoff + if (present(cutoff_skin)) then + if (cutoff_skin .fne. 0.0_dp) then + call print('calc_connect: increasing cutoff from '//cutoff//' by cutoff_skin='//cutoff_skin ,PRINT_NERD) + cutoff = cutoff + cutoff_skin + + if (.not. allocated(this%last_connect_pos) .or. & + (cutoff > this%last_connect_cutoff) .or. & + (size(this%last_connect_pos, 2) /= at%n) .or. & + (at%lattice .fne. this%last_connect_lattice)) then + call print('calc_connect: forcing a rebuild: either first time, atom number mismatch or lattice mismatch', PRINT_NERD) + call print('calc_connect: maxval(abs(at%lattice - this%last_connect_lattice)) = '//(maxval(abs(at%lattice - this%last_connect_lattice))), PRINT_NERD) + if (allocated(this%last_connect_pos)) deallocate(this%last_connect_pos) + allocate(this%last_connect_pos(3, at%n)) + my_max_pos_change = huge(1.0_dp) + else + ! FIXME 1. we should also take into account changes in lattice here - for + ! now we force a reconnect whenever lattice changes. + ! 2. it may be possible to further speed up calculation of delta_pos by + ! not calling distance_min_image() every time + my_max_pos_change = 0.0_dp + do i=1, at%N + pos_change = distance_min_image(at, i, this%last_connect_pos(:, i)) + if (pos_change > my_max_pos_change) my_max_pos_change = pos_change + end do + end if + + if (present(max_pos_change)) max_pos_change = my_max_pos_change + + if (my_max_pos_change < 0.5_dp*cutoff_skin) then + call print('calc_connect: max pos change '//my_max_pos_change//' < 0.5*cutoff_skin, doing a calc_dists() only', PRINT_NERD) + call calc_dists(this, at) + call system_timer('calc_connect') + if (present(did_rebuild)) did_rebuild = .false. + return + end if + + ! We need to do a full recalculation of connectivity. Store the current pos and lattice. + call print('calc_connect: max pos change '//my_max_pos_change//' >= 0.5*cutoff_skin, doing a full rebuild', PRINT_NERD) + if (present(did_rebuild)) did_rebuild = .true. + this%last_connect_pos(:,:) = at%pos + this%last_connect_lattice(:,:) = at%lattice + this%last_connect_cutoff = cutoff + end if + end if + + call print("calc_connect: cutoff calc_connect " // cutoff, PRINT_NERD) + + call calc_lat_eff(at, lat_eff, lat_eff_inv, lat_offset) + call divide_cell(lat_eff, cutoff, cellsNa, cellsNb, cellsNc) + + call print("calc_connect: cells_N[abc] " // cellsNa // " " // cellsNb // " " // cellsNc, PRINT_NERD) + + ! If the lattice has changed, then the cells need de/reallocating + if (this%cells_initialised) then + if ((cellsNa /= this%cellsNa) .or. & + (cellsNb /= this%cellsNb) .or. & + (cellsNc /= this%cellsNc)) call connection_finalise(this) + end if + + ! figure out how many unit cell images we will need to loop over in each direction + call fit_box_in_cell(cutoff, cutoff, cutoff, at%lattice, cell_image_Na, cell_image_Nb, cell_image_Nc) + ! cell_image_N{a,b,c} apply to a box of side 2*cutoff. Since we loop from -cell_image_N to + ! +cell_image_N we can reduce them as follows + + cell_image_Na = max(1,(cell_image_Na+1)/2) + cell_image_Nb = max(1,(cell_image_Nb+1)/2) + cell_image_Nc = max(1,(cell_image_Nc+1)/2) + + call print('calc_connect: image cells '//cell_image_Na//'x'//cell_image_Nb//'x'//cell_image_Nc, PRINT_NERD) + + ! Allocate space for the connection object if needed + if (.not.this%initialised) then + call connection_initialise(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, fill=.false.) + do_fill = .true. + else + ! otherwise just wipe the connection table + call wipe(this) + do_fill = .false. + end if + + if (.not.this%cells_initialised) & + call connection_cells_initialise(this, cellsNa, cellsNb, cellsNc,at%N) + + ! Partition the atoms into cells + call partition_atoms(this, at, lat_eff_inv, lat_offset, error=error) + PASS_ERROR(error) + if (.not. assign_pointer(at, 'map_shift', map_shift)) then + RAISE_ERROR("calc_connect impossibly failed to assign map_shift pointer", error) + end if + + if (do_fill) then + volume_per_cell = cell_volume(at%lattice)/real(cellsNa*cellsNb*cellsNc,dp) + + ! Count the occupied cells so vacuum does not contribute to average number density + n_occ = 0 + do k=1,cellsNc + do j=1,cellsNb + do i=1,cellsNa + if (this%cell_heads(i, j, k) > 0) & + n_occ = n_occ + 1 + end do + end do + end do + density = at%n/(n_occ*volume_per_cell) + + ! Sphere of radius "cutoff", assume roughly half neighbours in neighbour1 and half in neighbour2 + nn_guess = int(4.0_dp/3.0_dp*PI*cutoff**3*density)/2 + + call print('calc_connect: occupied cells '//n_occ//'/'//(cellsNa*cellsNb*cellsNc)//' = '//(n_occ/real(cellsNa*cellsNb*cellsNc,dp)), PRINT_NERD) + call print('calc_connect: estimated number of neighbours per atom = '//nn_guess, PRINT_NERD) + + call connection_fill(this, at%N, at%Nbuffer, at%pos, at%lattice, at%g, nn_guess=nn_guess) + end if + + ! Here is the main loop: + ! Go through each cell and update the connectivity between atoms in at cell and neighbouring cells + ! N.B. test_form_bond updates both atoms i and j, so only update if i <= j to avoid doubling processing + + ! defaults for cellsNx = 1 + k3 = 1; k4 = 1; j3 = 1; j4 = 1; i3 = 1; i4 = 1 + + ! loop over all cells i,j,k, and all atoms in each cell n1 + do k = 1, cellsNc + change_k = .true. + do j = 1, cellsNb + change_j = .true. + do i = 1, cellsNa + change_i = .true. + call get_min_max_images(at%is_periodic, cellsNa, cellsNb, cellsNc, & + cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k, change_i, change_j, change_k, & + min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc) + change_i = .false. + change_j = .false. + change_k = .false. + atom1 = this%cell_heads(i, j, k) + atom1_loop: do while (atom1 > 0) + + ! Loop over neighbouring cells, applying PBC + + do k2 = min_cell_image_Nc, max_cell_image_Nc + + ! the stored cell we are in + if(cellsNc > 1) k3 = mod(k+k2-1+cellsNc,cellsNc)+1 + + ! the shift we need to get to the cell image + k4 = (k+k2-k3)/cellsNc + + do j2 = min_cell_image_Nb, max_cell_image_Nb + ! the stored cell we are in + if(cellsNb > 1) j3 = mod(j+j2-1+cellsNb,cellsNb)+1 + + ! the shift we need to get to the cell image + j4 = (j+j2-j3)/cellsNb + + do i2 = min_cell_image_Na, max_cell_image_Na + ! the stored cell we are in + if(cellsNa > 1) i3 = mod(i+i2-1+cellsNa,cellsNa)+1 + + ! the shift we need to get to the cell image + i4 = (i+i2-i3)/cellsNa + + ! The cell we are currently testing atom1 against is cell(i3,j3,k3) + ! with shift (i4,j4,k4) + ! loop over it's atoms and test connectivity if atom1 < atom2 + + atom2 = this%cell_heads(i3, j3, k3) + atom2_loop: do while (atom2 > 0) + + ! omit atom2 < atom1 + if (atom1 > atom2) then + atom2 = this%next_atom_in_cell(atom2) + cycle atom2_loop + endif + + if (my_skip_zero_zero_bonds .and. & + at%z(atom1) == 0 .and. at%z(atom2) == 0) then + atom2 = this%next_atom_in_cell(atom2) + cycle atom2_loop + endif + + ! omit self in the same cell without shift + if (.not. my_own_neighbour .and. & + (atom1 == atom2 .and. & + (i4==0 .and. j4==0 .and. k4==0) .and. & + (i==i3 .and. j==j3 .and. k==k3))) then + atom2 = this%next_atom_in_cell(atom2) + cycle atom2_loop + endif + call test_form_bond(this, cutoff, .true., & + at%Z, at%pos, at%lattice, atom1,atom2, & + (/i4-map_shift(1,atom1)+map_shift(1,atom2),j4-map_shift(2,atom1)+map_shift(2,atom2),k4-map_shift(3,atom1)+map_shift(3,atom2)/), & + .false., error) + PASS_ERROR(error) + + atom2 = this%next_atom_in_cell(atom2) + end do atom2_loop ! atom2 + + end do ! i2 + end do ! j2 + end do ! k2 + + atom1 = this%next_atom_in_cell(atom1) + end do atom1_loop ! atom1 + end do ! i + end do ! j + end do ! k + + if (my_store_is_min_image) then + if (allocated(this%is_min_image)) deallocate(this%is_min_image) + allocate(this%is_min_image(at%n)) + do i=1,at%n + this%is_min_image(i) = is_min_image(this, i, error=error) + PASS_ERROR(error) + end do + end if + + if (my_store_n_neighb) then + call add_property(at, 'n_neighb', 0, ptr=n_neighb, overwrite=.true.) + do i=1,at%n + n_neighb(i) = n_neighbours(this, i) + end do + end if + + call system_timer('calc_connect') + + end subroutine connection_calc_connect + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% The subroutine 'calc_dists' updates the stored distance tables using + !% the stored connectivity and shifts. This should be called every time + !% any atoms are moved (e.g. it is called by 'DynamicalSystem%advance_verlet'). + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine connection_calc_dists(this, at, parallel, error) + type(Connection), intent(inout) :: this + type(Atoms), intent(inout) :: at + logical, optional, intent(in) :: parallel + integer, optional, intent(out) :: error + integer :: i, j, n, index + real(dp) :: r_ij + integer, dimension(3) :: shift + real(dp), dimension(3) :: j_pos + logical :: do_parallel + + real(dp), parameter :: small_number = 1.0e-10_dp +#ifdef _MPI + integer:: Nelements, mpi_pos, mpi_old_pos + real(dp), allocatable :: mpi_send(:), mpi_recv(:) + integer err +#endif + INIT_ERROR(error) + + call system_timer('calc_dists') + + ! Flag to specify whether or not to parallelise calculation. + ! Only actually run in parallel if parallel==.true. AND + ! _MPI is #defined. Default to serial mode. + do_parallel = .false. + if (present(parallel)) do_parallel = parallel + +#ifdef _MPI + if (do_parallel) then + ! Nelements = sum(this%connect%neighbour1(i)%t%N) + Nelements = 0 + do i=1,at%N + Nelements = Nelements + this%neighbour1(i)%t%N + end do + + allocate(mpi_send(Nelements)) + allocate(mpi_recv(Nelements)) + if (Nelements > 0) then + mpi_send = 0.0_dp + mpi_recv = 0.0_dp + end if + mpi_pos = 1 + end if +#endif + + if (.not.this%initialised) then + RAISE_ERROR('CalcDists: Connect is not yet initialised', error) + endif + + if (at%N > 0) then + if (size(this%neighbour1(1)%t%real,1) == 4) then ! store_rij was set + RAISE_ERROR("CalcDists: can't have store_rij set", error) + endif + endif + + do i = 1, at%N + +#ifdef _MPI + if (do_parallel) then + mpi_old_pos = mpi_pos + mpi_pos = mpi_pos + this%neighbour1(i)%t%N + + ! cycle loop if processor rank does not match + if(mod(i, mpi_n_procs()) .ne. mpi_id()) cycle + end if +#endif + + do n = 1, connection_n_neighbours(this, i) + + j = connection_neighbour_minimal(this, i, n, shift=shift, index=index) + + ! j_pos = at%pos(:,j) + ( at%lattice .mult. shift ) + j_pos(:) = at%pos(:,j) + ( at%lattice(:,1) * shift(1) + at%lattice(:,2) * shift(2) + at%lattice(:,3) * shift(3) ) + + r_ij = norm(j_pos - at%pos(:,i)) + if( r_ij < small_number ) then + RAISE_ERROR("connection_calc_dists: atoms "//i//" and "//j//" overlap exactly.",error) + endif + + if (i <= j) then + this%neighbour1(i)%t%real(1,index) = r_ij + else + this%neighbour1(j)%t%real(1,index) = r_ij + end if + + end do + +#ifdef _MPI + if (do_parallel) then + if (mpi_old_pos <= mpi_pos-1) then + mpi_send(mpi_old_pos:mpi_pos-1) = & + this%neighbour1(i)%t%real(1,1:this%neighbour1(i)%t%N) + end if + end if +#endif + + end do + +#ifdef _MPI + if (do_parallel) then + ! collect mpi results + if (Nelements > 0) then + call mpi_allreduce(mpi_send, mpi_recv, & + size(mpi_send), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, err) + call abort_on_mpi_error(err, "Calc_Dists: MPI_ALL_REDUCE()") + end if + + mpi_pos = 1 + do i=1, at%N + if (this%neighbour1(i)%t%N > 0) then + this%neighbour1(i)%t%real(1,1:this%neighbour1(i)%t%N) = & + mpi_recv(mpi_pos:mpi_pos+this%neighbour1(i)%t%N-1) + mpi_pos = mpi_pos + this%neighbour1(i)%t%N + endif + end do + + if (Nelements > 0) then + deallocate(mpi_send, mpi_recv) + end if + end if +#endif + + call system_timer('calc_dists') + + end subroutine connection_calc_dists + + + subroutine get_min_max_images(is_periodic, cellsNa, cellsNb, cellsNc, cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k, do_i, do_j, do_k, & + min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc) + logical, intent(in) :: is_periodic(3) + integer, intent(in) :: cellsNa, cellsNb, cellsNc, cell_image_Na, cell_image_Nb, cell_image_Nc, i, j, k + logical, intent(in) :: do_i, do_j, do_k + integer, intent(out) :: min_cell_image_Na, max_cell_image_Na, min_cell_image_Nb, max_cell_image_Nb, min_cell_image_Nc, max_cell_image_Nc + + if (do_i) then + if (is_periodic(1)) then + min_cell_image_Na = -cell_image_Na + max_cell_image_Na = cell_image_Na + else + if (cell_image_Na < i) then + min_cell_image_Na = -cell_image_Na + else + min_cell_image_Na = -i+1 + endif + if (cell_image_Na < cellsNa-i) then + max_cell_image_Na = cell_image_Na + else + max_cell_image_Na = cellsNa - i + endif + endif + endif + if (do_j) then + if (is_periodic(2)) then + min_cell_image_Nb = -cell_image_Nb + max_cell_image_Nb = cell_image_Nb + else + if (cell_image_Nb < j) then + min_cell_image_Nb = -cell_image_Nb + else + min_cell_image_Nb = -j+1 + endif + if (cell_image_Nb < cellsNb-j) then + max_cell_image_Nb = cell_image_Nb + else + max_cell_image_Nb = cellsNb - j + endif + endif + endif + if (do_k) then + if (is_periodic(3)) then + min_cell_image_Nc = -cell_image_Nc + max_cell_image_Nc = cell_image_Nc + else + if (cell_image_Nc < k) then + min_cell_image_Nc = -cell_image_Nc + else + min_cell_image_Nc = -k+1 + endif + if (cell_image_Nc < cellsNc-k) then + max_cell_image_Nc = cell_image_Nc + else + max_cell_image_Nc = cellsNc - k + endif + endif + endif + + if (current_verbosity() >= PRINT_ANALYSIS) then + call print('get_min_max_images cell_image_Na min='//min_cell_image_Na//' max='//max_cell_image_Na, PRINT_ANALYSIS) + call print('get_min_max_images cell_image_Nb min='//min_cell_image_Nb//' max='//max_cell_image_Nb, PRINT_ANALYSIS) + call print('get_min_max_images cell_image_Nc min='//min_cell_image_Nc//' max='//max_cell_image_Nc, PRINT_ANALYSIS) + end if + + end subroutine get_min_max_images + + ! + !% Spatially partition the atoms into cells. The number of cells in each dimension must already be + !% set (cellsNa,b,c). Pre-wiping of the cells can be skipped (e.g. if they are already empty). + ! + subroutine partition_atoms(this, at, lat_eff_inv, lat_offset, dont_wipe, error) + + type(Connection), intent(inout) :: this + type(Atoms), intent(inout) :: at + real(dp), intent(in) :: lat_eff_inv(3,3), lat_offset(3) + logical, optional, intent(in) :: dont_wipe + integer, intent(out), optional :: error + + logical :: my_dont_wipe, neighbour1_allocated + integer :: i,j,k,n + real(dp) :: lat_pos(3) + integer, pointer :: map_shift(:,:) + + INIT_ERROR(error) + ! Check inputs + if (.not.this%cells_initialised) then + RAISE_ERROR('Partition_Atoms: Cells have not been initialised', error) + end if + my_dont_wipe = .false. + if (present(dont_wipe)) my_dont_wipe = dont_wipe + + ! Wipe the cells + if (.not.my_dont_wipe) then + call wipe_cells(this) + else + RAISE_ERROR("Partition_Atoms: dont_wipe=.true. not supported", error) + endif + +!! ! Make sure all atomic positions are within the cell +!! call map_into_cell(at) + if (.not. assign_pointer(at, 'map_shift', map_shift)) then + call add_property(at, 'map_shift', 0, 3) + if (.not. assign_pointer(at, 'map_shift', map_shift)) then + RAISE_ERROR("partition_atoms impossibly failed to assign map_shift pointer", error) + end if + endif + + neighbour1_allocated = allocated(this%neighbour1) + + if (allocated(this%next_atom_in_cell)) then + if (size(this%next_atom_in_cell) < this%N) then + deallocate(this%next_atom_in_cell) + endif + endif + if (.not. allocated(this%next_atom_in_cell) .and. this%N > 0) then + allocate(this%next_atom_in_cell(this%N)) + endif + + do n = 1, at%N + if (neighbour1_allocated) then + if (.not. associated(this%neighbour1(n)%t)) cycle ! not in active subregion + end if + + ! figure out shift to map atom into cell + lat_pos = (lat_eff_inv .mult. at%pos(:,n)) - lat_offset + map_shift(:,n) = - floor(lat_pos+0.5_dp) + where (.not. at%is_periodic) + map_shift(:,n) = 0.0 + end where + ! do the mapping + lat_pos = lat_pos + map_shift(:,n) + + call cell_of_pos(this, lat_pos, i, j, k) + !Add the atom to this cell + this%next_atom_in_cell(n) = this%cell_heads(i, j, k) + this%cell_heads(i, j, k) = n + end do + + end subroutine partition_atoms + + subroutine cell_of_pos(this, lat_pos, i, j, k) + type(Connection), intent(in) :: this + real(dp), intent(in) :: lat_pos(3) + integer, intent(out) :: i, j, k + + real(dp) :: t(3) + + t = lat_pos + i = floor(real(this%cellsNa,dp) * (t(1)+0.5_dp)) + 1 + j = floor(real(this%cellsNb,dp) * (t(2)+0.5_dp)) + 1 + k = floor(real(this%cellsNc,dp) * (t(3)+0.5_dp)) + 1 + + ! Very small numerical errors in the lattice inverse can lead to bad i,j,k values. + ! Test for this: + if (i < 1) then + i = 1 + else if (i > this%cellsNa) then + i = this%cellsNa + end if + + if (j < 1) then + j = 1 + else if (j > this%cellsNb) then + j = this%cellsNb + end if + + if (k < 1) then + k = 1 + else if (k > this%cellsNc) then + k = this%cellsNc + end if + + end subroutine cell_of_pos + + + function cell_n(this, i, j, k, error) + type(Connection), intent(in) :: this + integer, intent(in) :: i, j, k + integer :: cell_n + integer :: a + integer, intent(out), optional :: error + + INIT_ERROR(error) + if (.not. this%cells_initialised) then + RAISE_ERROR('cell_n: cells are not initialised', error) + end if + + cell_n = 0 + a = this%cell_heads(i, j, k) + do while (a > 0) + cell_n = cell_n + 1 + a = this%next_atom_in_cell(a) + enddo + + end function cell_n + +! Don't understand what this is doing, and doesn't seem to be used +! anywhere - Lars +! function cell_contents(this, i, j, k, n, error) +! type(Connection), intent(in) :: this +! integer, intent(in) :: i, j, k, n +! integer :: cell_contents +! integer, intent(out), optional :: error +! +! INIT_ERROR(error) +! if (.not. this%cells_initialised) then +! RAISE_ERROR('cell_n: cells are not initialised', error) +! end if +! +! cell_contents = this%cell(i,j,k)%int(1,n) +! +! end function cell_contents + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Geometry procedures + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + !% Given a simulation cell defined by lattice vectors, how many + !% times can the cell be divided along the lattice vectors into + !% subcells such that a sphere of radius 'cutoff' with centre in + !% one subcell does not spill out of the surrounding $3 \times 3$ subcell block? + ! + subroutine divide_cell(lattice,cutoff,Na,Nb,Nc) + + real(dp), dimension(3,3), intent(in) :: lattice !% Box defined by lattice vectors + real(dp), intent(in) :: cutoff !% Radius of sphere + integer, intent(out) :: Na,Nb,Nc !% Number of supercells required along $x$, $y$ and $z$ + real(dp) :: cellVol + real(dp), dimension(3) :: a, b, c + + a = lattice(:,1); b = lattice(:,2); c = lattice(:,3) + cellVol = abs( scalar_triple_product(a,b,c) ) + + Na = max(1,int( cellVol / (cutoff * norm(b .cross. c) ) )) ! round down to nearest int >= 1 + Nb = max(1,int( cellVol / (cutoff * norm(c .cross. a) ) )) + Nc = max(1,int( cellVol / (cutoff * norm(a .cross. b) ) )) + + call print('divide_cell: '//Na//'x'//Nb//'x'//Nc//' cells.', PRINT_NERD) + + end subroutine divide_cell + + ! + !% Returns the maximum cutoff radius for 'calc_connect', given the lattice if we want to avoid image neghbours + ! + function max_cutoff(lattice, error) + + real(dp), dimension(3,3), intent(in) :: lattice + real(dp) :: Max_Cutoff + real(dp), dimension(3) :: a,b,c + real(dp) :: cellVol, ra, rb, rc + integer, intent(out), optional :: error + + INIT_ERROR(error) + a = lattice(:,1); b = lattice(:,2); c = lattice(:,3) + cellVol = abs( scalar_triple_product(a,b,c) ) + + if(cellVol == 0.0_dp) then + RAISE_ERROR("Max_cutoff(): cell volume is exactly 0.0!", error) + end if + + ra = cellVol / norm(b .cross. c) + rb = cellVol / norm(c .cross. a) + rc = cellVol / norm(a .cross. b) + + Max_Cutoff = 0.5_dp * min(ra,rb,rc) + + end function max_cutoff + + subroutine connection_print(this,file,error) + + type(Connection), intent(in) :: this + type(Inoutput), optional, intent(inout) :: file + integer, intent(out), optional :: error + integer :: i,j,k,n,a + integer :: ndata(10) + + INIT_ERROR(error) + if (.not.this%initialised) then + RAISE_ERROR('Connection_Print: Connection object not initialised', error) + end if + + call print('Connectivity data:',file=file) + call print('-------------------------------------------------',file=file) + call print('| I | J | Shift | Distance |',file=file) + call print('-------------------------------------------------',file=file) + + do i = 1, size(this%neighbour1) + + if (.not. associated(this%neighbour1(i)%t)) cycle + + if ((this%neighbour1(i)%t%N + this%neighbour2(i)%t%N) > 0) then + write(line,'(a47)')'| Neighbour1 (i <= j) |' + call print(line, file=file) + endif + + do j = 1, this%neighbour1(i)%t%N + if(j == 1) then + write(line,'(a2,i7,a3,i7,a3,3i4,a3,f10.5,a2)')'| ', & + & i, ' | ', this%neighbour1(i)%t%int(1,j),' | ',this%neighbour1(i)%t%int(2:4,j),& + &' | ',this%neighbour1(i)%t%real(1,j),' |' + else + write(line,'(a12,i7,a3,3i4,a3,f10.5,a2)')'| | ', & + this%neighbour1(i)%t%int(1,j),' | ',this%neighbour1(i)%t%int(2:4,j),' | ',this%neighbour1(i)%t%real(1,j),' |' + end if + call print(line,file=file) + end do + + if (this%neighbour2(i)%t%N > 0) then + + write(line,'(a47)')'-----------------------------------------------' + call print(line, file=file) + write(line,'(a47)')'| Neighbour2 (i > j) |' + call print(line, file=file) + + + do j = 1, this%neighbour2(i)%t%N + + if(j == 1) then + write(line,'(a2,i7,a3,i7,a3,i7,a)') '| ', i, ' | ', this%neighbour2(i)%t%int(1,j),' | ',& + &this%neighbour2(i)%t%int(2,j),' |' + else + write(line,'(a12,i7,a3,i7,a)') '| | ', this%neighbour2(i)%t%int(1,j),' | ',& + &this%neighbour2(i)%t%int(2,j),' |' + end if + call print(line,file=file) + end do + + end if + + if ((this%neighbour1(i)%t%N + this%neighbour2(i)%t%N) > 0) then + write(line,'(a47)')'-----------------------------------------------' + call print(line,file=file) + endif + + end do + + write(line,'(a47)')'' + call print(line,file=file) + + + !Print the cell lists if they exist + if (this%cells_initialised .and. current_verbosity() > PRINT_NORMAL) then + call verbosity_push_decrement() + + write(line,'(a11)')'Cell Lists:' + call print(line,file=file) + write(line,'(a70)')'----------------------------------------------------------------------' + call print(line,file=file) + + ! Write atomic indices 10 per line + do k = 1, this%cellsNc + do j = 1, this%cellsNb + do i = 1, this%cellsNa + write(line,'(a7,i0,a1,i0,a1,i0,a3)')'Cell ( ',i,' ',j,' ',k,' ):' + call print(line,file=file) + + a = this%cell_heads(i, j, k) + n = 0 + do while (a > 0) + n = n + 1 + ndata(n) = a + if (n == 10) then + write (line, '(10i7)') ndata + call print(line,file=file) + n = 0 + endif + a = this%next_atom_in_cell(a) + enddo + if (n > 0) then + write (line, '(10i7)') ndata(1:n) + call print(line,file=file) + endif + + write(line,'(a70)')'----------------------------------------------------------------------' + call print(line,file=file) + end do + end do + end do + + call verbosity_pop() + + end if + + end subroutine connection_print + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Simple query functions + ! + !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + + !% Return the total number of neighbour that atom $i$ has. + function connection_n_neighbours(this, i, error) result(n) + type(Connection), intent(in) :: this + integer, intent(in) :: i + integer, optional, intent(out) :: error + + integer :: n + + INIT_ERROR(error) + + if (.not. this%initialised) then + RAISE_ERROR('connection_n_neighbours: Connection structure has no connectivity data. Call calc_connect first.', error) + end if + + if (.not. associated(this%neighbour1(i)%t)) then + n = 0 + return + endif + + ! All neighbours + n = this%neighbour1(i)%t%N + this%neighbour2(i)%t%N + + end function connection_n_neighbours + + + !% Return the total number of neighbour, i.e. the number of bonds in the system + function connection_n_neighbours_total(this, error) result(n) + type(Connection), intent(in) :: this + integer, optional, intent(out) :: error + + integer :: i, n + + INIT_ERROR(error) + + if (.not. this%initialised) then + RAISE_ERROR('connection_n_neighbours: Connection structure has no connectivity data. Call calc_connect first.', error) + end if + + ! All neighbours + n = 0 + do i = 1, this%N + if (.not. associated(this%neighbour1(i)%t)) cycle + n = n + this%neighbour1(i)%t%N + this%neighbour2(i)%t%N + enddo + + end function connection_n_neighbours_total + + + !% Return the number of neighbour that atom $i$ has. + !% If the optional arguments max_dist or max_factor are present + !% then only neighbours closer than this cutoff are included. + function connection_n_neighbours_with_dist(this, at, i, max_dist, max_factor, error) result(n) + type(Connection), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i + real(dp), optional, intent(in) :: max_dist, max_factor + integer, optional, intent(out) :: error + + integer :: n + + integer :: j, m + real(dp) :: r_ij + + INIT_ERROR(error) + + if (.not. this%initialised) then + RAISE_ERROR('connection_n_neighbours: Connection structure has no connectivity data. Call calc_connect first.', error) + end if + + if (.not. associated(this%neighbour1(i)%t)) then + n = 0 + return + endif + + if (.not. present(max_dist) .and. .not. present(max_factor)) then + ! All neighbours + n = this%neighbour1(i)%t%N + this%neighbour2(i)%t%N + else if (present(max_dist)) then + ! Only count neighbours within max_dist distance of i + n = 0 + do m=1,this%neighbour1(i)%t%N+this%neighbour2(i)%t%N + j = connection_neighbour(this, at, i, m, distance=r_ij) + if (r_ij < max_dist) n = n + 1 + end do + else if (present(max_factor)) then + ! Only count neighbours within max_factor of i + n = 0 + do m=1,this%neighbour1(i)%t%N+this%neighbour2(i)%t%N + j = connection_neighbour(this, at, i, m, distance=r_ij) + if (r_ij < bond_length(at%Z(i),at%Z(j))*max_factor) n = n + 1 + end do + else + RAISE_ERROR('connection_n_neighbours: optional arguments max_dist and max_factor must not both be present', error) + end if + + end function connection_n_neighbours_with_dist + + function connection_neighbour_index(this, i, n, index, t, is_j, error) result(j) + type(Connection), intent(in) :: this + integer :: i, n + integer, intent(out) :: index + !NB gfortran 4.3.4 seg faults if this is intent(out) + !NB type(Table), pointer, intent(out) :: t + type(Table), pointer :: t + !NB + logical, intent(out) :: is_j + integer, intent(out), optional :: error + integer :: j + + integer :: i_n1n, j_n1n + + INIT_ERROR(error) + + if (this%initialised) then + i_n1n = n-this%neighbour2(i)%t%N + if (n <= this%neighbour2(i)%t%N) then + j = this%neighbour2(i)%t%int(1,n) + j_n1n = this%neighbour2(i)%t%int(2,n) + index = j_n1n + t => this%neighbour1(j)%t + is_j = .true. + else if (i_n1n <= this%neighbour1(i)%t%N) then + j = this%neighbour1(i)%t%int(1,i_n1n) + index = i_n1n + t => this%neighbour1(i)%t + is_j = .false. + else + RAISE_ERROR('connection_neighbour_index: '//n//' out of range for atom '//i//' Should be in range 1 < n <= '//n_neighbours(this, i), error) + end if + else + RAISE_ERROR('connection_neighbour_index: Connect structure not initialized. Call calc_connect first.', error) + end if + + end function connection_neighbour_index + + function connection_neighbour_minimal(this, i, n, shift, index) result(j) + type(Connection), intent(in) :: this + integer :: i, j, n + integer, intent(out) :: shift(3) + integer, intent(out) :: index + + type(Table), pointer :: t + logical :: is_j + + j = connection_neighbour_index(this, i, n, index, t, is_j) + + if (is_j) then + shift = - t%int(2:4,index) + else + shift = t%int(2:4,index) + endif + + end function connection_neighbour_minimal + + !% Return the index of the $n^{\mbox{\small{th}}}$ neighbour of atom $i$. Together with the + !% previous function, this facilites a loop over the neighbours of atom $i$. Optionally, we + !% return other geometric information, such as distance, direction cosines and difference vector, + !% and also an direct index into the neighbour tables. If $i <= j$, this is an index into 'neighbour1(i)', + !% if $i > j$, it is an index into 'neighbour1(j)' + !% + !%> do n = 1,atoms_n_neighbours(at, i) + !%> j = atoms_neighbour(at, i, n, distance, diff, cosines, shift, index) + !%> + !%> ... + !%> end do + !% + !% if distance $>$ max_dist, return 0, and do not waste time calculating other quantities + function connection_neighbour(this, at, i, n, distance, diff, cosines, shift, index, max_dist, jn, error) result(j) + type(Connection), intent(in) :: this + type(Atoms), intent(in) :: at + integer, intent(in) :: i, n + real(dp), optional, intent(out) :: distance + real(dp), dimension(3), optional, intent(out) :: diff + real(dp), optional, intent(out) :: cosines(3) + integer, optional, intent(out) :: shift(3) + integer, optional, intent(out) :: index + real(dp), optional, intent(in) :: max_dist + integer, optional, intent(out) :: jn + integer, optional, intent(out) :: error + + real(dp)::mydiff(3), norm_mydiff + integer ::myshift(3) + integer ::j, i_n1n, j_n1n, i_njn, m + + INIT_ERROR(error) + + if (.not. this%initialised) then + RAISE_ERROR('connection_n_neighbours: Connection structure has no connectivity data. Call calc_connect first.', error) + end if + + if (.not. associated(this%neighbour1(i)%t)) then + RAISE_ERROR("called atoms_neighbour on atom " // i // " which has no allocated neighbour1 table", error) + endif + + ! First we give the neighbour2 entries (i > j) then the neighbour1 (i <= j) + ! This order chosen to give neighbours in approx numerical order but doesn't matter + if (this%initialised) then + i_n1n = n-this%neighbour2(i)%t%N + if (n <= this%neighbour2(i)%t%N) then + j = this%neighbour2(i)%t%int(1,n) + j_n1n = this%neighbour2(i)%t%int(2,n) + if(present(index)) index = j_n1n + else if (i_n1n <= this%neighbour1(i)%t%N) then + j = this%neighbour1(i)%t%int(1,i_n1n) + if(present(index)) index = i_n1n + else + RAISE_ERROR('atoms_neighbour: '//n//' out of range for atom '//i//' Should be in range 1 < n <= '//n_neighbours(this, i), error) + end if + else + RAISE_ERROR('atoms_neighbour: Atoms structure has no connectivity data. Call calc_connect first.', error) + end if + + if(present(jn)) then + if(i < j) then + do i_njn = 1, this%neighbour2(j)%t%N + if( (this%neighbour2(j)%t%int(1,i_njn)==i) .and. & + (this%neighbour2(j)%t%int(2,i_njn)==i_n1n) ) jn = i_njn + enddo + elseif(i > j) then + jn = j_n1n + this%neighbour2(j)%t%N + else + do i_njn = 1, this%neighbour1(j)%t%N + if( (this%neighbour1(j)%t%int(1,i_njn) == i) .and. & + all(this%neighbour1(j)%t%int(2:4,i_njn) == -this%neighbour1(i)%t%int(2:4,i_n1n))) & + jn = i_njn + this%neighbour2(j)%t%N + enddo + endif + endif + + ! found neighbour, now check for optional requests + if(present(distance)) then + if(i <= j) then + distance = this%neighbour1(i)%t%real(1,i_n1n) + else + distance = this%neighbour1(j)%t%real(1,j_n1n) + end if + if (present(max_dist)) then + if (distance > max_dist) then + j = 0 + return + endif + endif + else + if (present(max_dist)) then + if (i <= j) then + if (this%neighbour1(i)%t%real(1,i_n1n) > max_dist) then + j = 0 + return + endif + else + if (this%neighbour1(j)%t%real(1,j_n1n) > max_dist) then + j = 0 + return + endif + endif + endif + end if + + if(present(diff) .or. present(cosines) .or. present(shift)) then + if (i <= j) then + myshift = this%neighbour1(i)%t%int(2:4,i_n1n) + else + myshift = -this%neighbour1(j)%t%int(2:4,j_n1n) + end if + + if(present(shift)) shift = myshift + + if(present(diff) .or. present(cosines)) then + !mydiff = this%pos(:,j) - this%pos(:,i) + (this%lattice .mult. myshift) + if (size(this%neighbour1(i)%t%real,1) == 4) then + if (i <= j) then + mydiff = this%neighbour1(i)%t%real(2:4,i_n1n) + else + mydiff = -this%neighbour1(j)%t%real(2:4,j_n1n) + endif + else + mydiff = at%pos(:,j) - at%pos(:,i) + endif + do m=1,3 + ! forall(k=1:3) mydiff(k) = mydiff(k) + this%lattice(k,m) * myshift(m) + mydiff(1:3) = mydiff(1:3) + at%lattice(1:3,m) * myshift(m) + end do + if(present(diff)) diff = mydiff + if(present(cosines)) then + norm_mydiff = sqrt(mydiff(1)*mydiff(1) + mydiff(2)*mydiff(2) + mydiff(3)*mydiff(3)) + if (norm_mydiff > 0.0_dp) then + cosines = mydiff / norm_mydiff + else + cosines = 0.0_dp + endif + endif + end if + end if + + end function connection_neighbour + + function connection_is_min_image(this, i, error) result(is_min_image) + type(Connection), intent(in) :: this + integer, intent(in) :: i + integer, optional, intent(out) :: error + + logical :: is_min_image + integer :: n, m, NN + + INIT_ERROR(error) + + is_min_image = .true. + ! First we give the neighbour1 (i <= j) then the neighbour2 entries (i > j) + if (this%initialised) then + + if (.not. associated(this%neighbour1(i)%t)) then + RAISE_ERROR('is_min_image: atoms structure has no connectivity data for atom '//i, error) + end if + + nn = this%neighbour1(i)%t%N + do n=1,nn + if (this%neighbour1(i)%t%int(1,n) == i) then + is_min_image = .false. + return + end if + do m=n+1,nn + if (this%neighbour1(i)%t%int(1,n) == this%neighbour1(i)%t%int(1,m)) then + is_min_image = .false. + return + end if + end do + end do + + nn = this%neighbour2(i)%t%N + do n=1,nn + if (this%neighbour2(i)%t%int(1,n) == i) then + is_min_image = .false. + return + end if + do m=n+1,nn + if (this%neighbour2(i)%t%int(1,n) == this%neighbour2(i)%t%int(1,m)) then + is_min_image = .false. + return + end if + end do + end do + + else + RAISE_ERROR('is_min_image: Atoms structure has no connectivity data. Call calc_connect first.', error) + end if + + endfunction connection_is_min_image + + + ! + ! Fit_Box_In_Cell + ! + !% Given an orthogonal box, oriented along the cartesian axes with lengths '2*rx', '2*ry' and '2*rz' + !% and centred on the origin, what parameters must we pass to supercell to make a system big + !% enough from our original cell defined by lattice for the box to fit inside? + !% + !% The required supercell parameters are returned in 'Na', 'Nb', 'Nc' respectively. If, e.g. 'Na = 1' + !% then we don\'t need to supercell in the a direction. 'Na > 1' means we must supercell by 'Na' times + !% in the $x$ direction. + ! + subroutine fit_box_in_cell(rx,ry,rz,lattice,Na,Nb,Nc) + + real(dp), intent(in) :: rx, ry, rz + real(dp), dimension(3,3), intent(in) :: lattice + integer, intent(out) :: Na, Nb, Nc + !local variables + real(dp), dimension(3,3) :: g !inverse of lattice + real(dp) :: maxa, maxb, maxc !the current maximum in the a,b,c directions + real(dp), dimension(3) :: lattice_coords !the coordinates of a corner in terms of a,b,c + integer :: i,j,k + !This subroutine works by calculating the coordinates of the corners of the box + !in terms of the lattice vectors, taking the maximum in the lattice directions and + !rounding up to the nearest integer. + + call matrix3x3_inverse(lattice,g) + maxa = 0.0_dp; maxb=0.0_dp; maxc=0.0_dp + + !For the time being, do all eight corners. This is most likely overkill, but it's still quick. + do k = -1, 1, 2 + do j = -1, 1, 2 + do i = -1, 1, 2 + lattice_coords = g .mult. (/i*rx,j*ry,k*rz/) + if (abs(lattice_coords(1)) > maxa) maxa = abs(lattice_coords(1)) + if (abs(lattice_coords(2)) > maxb) maxb = abs(lattice_coords(2)) + if (abs(lattice_coords(3)) > maxc) maxc = abs(lattice_coords(3)) + end do + end do + end do + + Na = ceiling(2.0_dp*maxa) + Nb = ceiling(2.0_dp*maxb) + Nc = ceiling(2.0_dp*maxc) + + end subroutine fit_box_in_cell + +endmodule Connection_module diff --git a/src/libAtoms/Constraints.F90 b/src/libAtoms/Constraints.F90 new file mode 100644 index 0000000000..567cd17b75 --- /dev/null +++ b/src/libAtoms/Constraints.F90 @@ -0,0 +1,1828 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Constraints module +!X +!% Contains the Constraint type and constraint subroutines +!% +!% Constraints are applied using the RATTLE algorithm: +!% H. C. Andersen, JCompPhys 52 24-34 (1983) +!% This itself is based on the SHAKE algorithm: +!% J. P. Ryckaert et al., JCompPhys 23 327-341 (1977) +!% +!% To integrate the system with constraints Newtons equations of motion have to be modified to +!% \begin{displaymath} +!% m\mathbf{a} = \mathbf{F} - \lambda\nabla\sigma +!% \end{displaymath} +!% where $\sigma$ is a constraint function (see below) and +!% $\lambda$ is a Lagrange multiplier which is dependent upon atomic positions +!% and velocities. +!% +!% When the equations of motion are discretised two separate approximation to $\lambda$ must be +!% made so that the positions and velocities both obey the constraint exactly (or to within a +!% specified precision) at each time step. +!% +!% During the position updates, a Lagrange multiplier $\lambda_j$ attached to a constraint +!% $\sigma_j$, which involves particles $i=1 \ldots N$ is solved for iteratively by the following: +!% \begin{displaymath} +!% \lambda_j^S = \frac{2\sigma_j}{(\Delta t)^2 \sum_i \frac{1}{m_i} \nabla_i \sigma_j(t+\Delta t) \cdot +!% \nabla_i \sigma_j(t)} +!% \end{displaymath} +!% +!% The velocity updates also include the $\lambda_j^S\nabla\sigma_j$ term, plus an additional +!% $\lambda_j^R\nabla\sigma_j$ term where $\lambda_j^R$ is solved for via: +!% \begin{displaymath} +!% \lambda_j^R = \frac{2\dot{\sigma}_j}{\Delta t \sum_i \frac{1}{m_i} |\nabla_i \sigma_j(t+\Delta t)|^2} +!% \end{displaymath} +!% +!% The full, non-specialised form of the iterative solver is present in the code for added flexibility and +!% to allow users to write and use their own constraint functions, which can be time dependent. +!% +!% +!% \textbf{Writing extra constraint subroutines} +!% +!% A constraint subroutine evaluates a constraint function ('C'), its derivatives with respect to all +!% coordinates ('dC_dr') and its full time derivative ('dC_dt'). A constraint function is a function which +!% evaluates to zero when the constraint is satisfied. +!% +!% Probably the easiest way of constructing a new subroutine is to copy the following and fill in the gaps: +!% +!%> subroutine CONSTRAINT(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt) +!%> +!%> real(dp), dimension(:), intent(in) :: pos, velo, mass, data +!%> real(dp), intent(in) :: lattice(3,3) +!%> real(dp), intent(in) :: t +!%> real(dp), intent(out) :: C +!%> real(dp), dimension(size(pos)), intent(out) :: dC_dr +!%> real(dp), intent(out) :: dC_dt +!%> if(size(pos) /= ?) & +!%> call System_Abort('CONSTRAINT: Exactly ? atoms must be specified') +!%> if(size(data) /= ?) & +!%> call System_Abort('CONSTRAINT: "data" must contain exactly ? value(s)') +!%> C = ? +!%> dC_dr = ? +!%> dC_dt = ? +!%> +!%> end subroutine CONSTRAINT +!% +!% A few notes: +!% \begin{itemize} +!% \item The subroutine must make its own checks on the sizes of the input arguments (as shown) +!% +!% \item dC_dr should not be zero when the constraint is satisfied, since then no force can be applied to +!% enforce the constraint. For example, the plane constraint could have been defined as the squared +!% distance from the plane, but that would cause it to suffer from this problem, so the signed +!% distance was used instead. +!% +!% \item Currently, a constraint function can only depend explicitly on positions and time, so the kinetic +!% energy of a group of particles cannot be constrained for example. +!% +!% \item dC_dt will usually be dC_dr .dot. velo, except in the case where the constraint depends explicitly +!% on time; then there will be an extra partial d/dt term. +!% +!% \item If a constraint contains one particle only, then the absolute position of that particle is passed +!% in 'pos'. If more than one particle is in the constraint then the relative positions are passed +!% (with the first particle at the origin), so periodic boundary conditions should not be a worry. +!% +!% \item When a constraint is added to a DynamicalSystem its number of degrees of freedom is decreased by 1. +!% A constraint should only attempt to remove one degree of freedom MAXIMUM. Constraints which try to, +!% for examples, keep a particle on a line (removing 2 degrees of freedom) are doomed to failure since +!% the particle will not always be able to return to the line by the application of forces in the direction +!% from the particle to the nearest point on the line. Instead, implement the line as the intersection of +!% two planes, which makes the removal of two degrees of freedom more explicit, and allows the algorithm +!% to use two directions to construct the constraint force. +!% +!% \item Some constraints will be extraneous (e.g. constraining a bond length which, by the action of many +!% other constraints, is already fixed implicitly), and the decrease of ds%Ndof will be wrong, in which +!% case it should be correctly set by hand. Also, the algorithm will fail if the 'explicit' constraint +!% is not the same as the 'implicit' one. +!% \end{itemize} +!% +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module constraints_module + + use system_module + use units_module + use linearalgebra_module + use atoms_types_module + use atoms_module + use group_module + use dictionary_module + + implicit none + private + + public :: constraint, initialise, finalise, print, register_constraint, add_restraint_forces + public :: BONDANGLECOS, BONDLENGTH, BONDLENGTH_SQ, BONDLENGTH_DEV_POW, BONDLENGTH_DIFF, GAP_ENERGY, PLANE + public :: CRACK_TIP_CURVATURE, CRACK_TIP_GRADIENT, CRACK_TIP_POSITION + public :: STRUCT_FACTOR_LIKE_MAG, STRUCT_FACTOR_LIKE_R, STRUCT_FACTOR_LIKE_I + public :: CUBIC_BONDLENGTH_SQ + public :: CONSTRAINT_WARNING_TOLERANCE, LOWER_BOUND, UPPER_BOUND, BOTH_UPPER_AND_LOWER_BOUNDS, BOUND_STRING + public :: constraint_store_gradient, constraint_calculate_values_at, constraint_amend, shake, rattle + + integer, parameter :: MAX_CONSTRAINT_SUBS = 20 !% This must be consistent with Constraint_Pointers.c + integer :: REGISTERED_CONSTRAINTS = 0 !% Stores the number of registered constraint functions + + integer, parameter :: RATTLE_MAX_ITERATIONS = 3000 !% Max iterations before failure (same as AMBER) + real(dp), parameter :: DEFAULT_CONSTRAINT_TOLERANCE = 1.0E-10_dp !% Default tolerance of constraints + real(dp), parameter :: CONSTRAINT_WARNING_TOLERANCE = 1.0E-3_dp !% Warn if a constraint is added which is not obeyed + !% to within this tolerance + + integer, parameter :: LOWER_BOUND = -1 !% Restraint should only act if the instantaneous value is larger than the equilibrium restraint value + integer, parameter :: BOTH_UPPER_AND_LOWER_BOUNDS = 0 !% Restraint acts independently from the instantaneous value of the restraint + integer, parameter :: UPPER_BOUND = 1 !% Restraint should only act if the instantaneous value is larger than the equilibrium restraint value + character(len=32), parameter :: BOUND_STRING(-1:1) = (/"LOWER_BOUND ","UPPER_AND_LOWER_BOUNDS","UPPER_BOUND "/) + + type Constraint + + integer :: N = 0 !% Number of atoms in the constraint + integer, allocatable, dimension(:) :: atom !% Indices of the atoms in the constraint + real(dp), allocatable, dimension(:) :: data !% Data to be passed to the constraint function + integer :: func !% Pointer to the constraint function + real(dp) :: lambdaR !% Lagrange multipler for position constraint forces + real(dp) :: dlambdaR !% Last computed correction to lambdaR + real(dp) :: lambdaV !% Lagrange multipler for velocity constraint forces + real(dp) :: dlambdaV !% Last computed correction to lambdaV + real(dp) :: C !% Value of the constraint + real(dp) :: target_v !% Target value of the collective coordinate + real(dp), allocatable, dimension(:) :: dC_dr !% Gradient of the constraint at the start of the timestep + real(dp) :: dC_dt !% Time derivative of the constraint + real(dp), allocatable, dimension(:) :: old_dC_dr !% Value of 'dC_dr' at the beginning of the algorithm + real(dp) :: tol !% Convergence tolerance of the constraint + logical :: initialised = .false. + real(dp), allocatable, dimension(:) :: dcoll_dr !% The derivative of the collective coordinate ($\xi$) wrt. the positions (x), + !% needed to calculate the Fixman determinant. + !% For constraints $\xi - \xi_0$ it is the same as dC_dr + real(dp) :: Z_coll !% Fixman determinant of the constraint + !% $ Z_\xi = \sum_i frac{1}{m_i} \left( \frac{\partial \xi}{\partial x_i} \right)^2 $ + !% $ A (\xi) = \int \langle \lambda_R \rangle_\xi \mathrm{d} \xi - k_B T \ln \langle Z_{\xi}^{-1/2} \rangle_\xi$ + + real(dp) :: k !% spring constant for restraint + integer :: bound !% for onesided restraint (upper/lower) + real(dp) :: E !% restraint energy + real(dp), allocatable, dimension(:) :: dE_dr !% restraint force (on atoms) + real(dp) :: dE_dcoll !% derivative of restraint energy w.r.t. collective coordinate, for Umbrella Integration w.r.t. pos + real(dp) :: dE_dk !% derivative of restraint energy w.r.t. stifness, for Umbrella Integration w.r.t. stiffness + logical :: print_summary=.true. !% if true, print in summary + + end type Constraint + + interface initialise + module procedure constraint_initialise + end interface initialise + + interface finalise + module procedure constraint_finalise, constraints_finalise + end interface finalise + + interface assignment(=) + module procedure constraint_assignment, constraints_assignment + end interface assignment(=) + + interface print + module procedure constraint_print, constraints_print + end interface print + + ! + ! interface blocks for the C functions + ! + !% OMIT + interface + subroutine register_constraint_sub(sub) + interface + subroutine sub(pos,velo,mass, lattice,t,data,C,dC_dr,dC_dt,dcoll_dr,Z_coll,target_v) + use system_module !for dp definition + real(dp), dimension(:), intent(in) :: pos,velo,mass,data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr,dcoll_dr + real(dp), intent(out) :: dC_dt,Z_coll + real(dp), intent(out) :: target_v + end subroutine sub + end interface + end subroutine register_constraint_sub + end interface + + !% OMIT + interface + subroutine call_constraint_sub(i,pos,velo,mass, lattice,t,data,C,dC_dr,dC_dt,dcoll_dr,Z_coll,target_v) + use system_module + integer :: i + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr,dcoll_dr + real(dp), intent(out) :: dC_dt,Z_coll + real(dp), intent(out) :: target_v + end subroutine call_constraint_sub + end interface + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X INITIALISE + !% + !% Initialise this Constraint. + !% + !% NOTE: the atomic indices are not sorted into ascending order, because + !% a three body constraint (for example) may depend on the order + !% (and the wrong angle could be constrained). + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine constraint_initialise(this,indices,func,data,k,bound,tol) + + type(Constraint), intent(inout) :: this + integer, dimension(:), intent(in) :: indices + integer, intent(in) :: func + real(dp), dimension(:), intent(in) :: data + real(dp), optional, intent(in) :: k, tol + integer, optional, intent(in) :: bound + + + if (this%initialised) call constraint_finalise(this) + + if (size(indices) == 0) & + call system_abort('Constraint_Initialise: There must be at least one particle in the constraint') + + this%N = size(indices) + allocate(this%atom(this%N)) + this%atom = indices + + allocate(this%data(size(data))) + this%data = data + + if (func < 0 .or. func >= REGISTERED_CONSTRAINTS) then + write(line,'(a,i0,a)')'Constraint_Initialised: Invalid constraint subroutine (',func,')' + call System_Abort(line) + end if + + this%func = func + this%lambdaR = 0.0_dp + this%lambdaV = 0.0_dp + this%C = 0.0_dp + this%dC_dt = 0.0_dp + this%tol = DEFAULT_CONSTRAINT_TOLERANCE + if (present(tol)) then + if (tol>0._dp) this%tol = tol + endif + + allocate(this%dC_dr(3*size(indices))) + this%dC_dr = 0.0_dp + allocate(this%old_dC_dr(3*size(indices))) + this%old_dC_dr = 0.0_dp + + allocate(this%dcoll_dr(3*size(indices))) + this%dcoll_dr = 0.0_dp + this%Z_coll = 0.0_dp + + if (present(k)) then + this%k = k + this%bound = optional_default(BOTH_UPPER_AND_LOWER_BOUNDS,bound) + this%E = 0.0_dp + this%dE_dcoll = 0.0_dp + this%dE_dk = 0.0_dp + allocate(this%dE_dr(3*size(indices))) + this%dE_dr = 0.0_dp + else + this%k = -1.0_dp + endif + + !initialised + this%initialised = .true. + + end subroutine constraint_initialise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X FINALISE + !X + !% Finalise this Constraint object. + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine constraint_finalise(this) + + type(Constraint), intent(inout) :: this + + this%N = 0 + this%func = 0 + this%lambdaR = 0.0_dp + this%lambdaV = 0.0_dp + this%C = 0.0_dp + this%dC_dt = 0.0_dp + this%tol = 0.0_dp + if (allocated(this%atom)) deallocate(this%atom) + if (allocated(this%data)) deallocate(this%data) + if (allocated(this%dC_dr)) deallocate(this%dC_dr) + if (allocated(this%old_dC_dr)) deallocate(this%old_dC_dr) + if (allocated(this%dcoll_dr)) deallocate(this%dcoll_dr) + this%Z_coll = 0.0_dp + this%k = -1.0_dp + this%k = 0 + this%E = 0.0_dp + this%dE_dcoll = 0.0_dp + this%dE_dk = 0.0_dp + if (allocated(this%dE_dr)) deallocate(this%dE_dr) + this%initialised = .false. + + end subroutine constraint_finalise + + subroutine constraints_finalise(this) + + type(Constraint), dimension(:), allocatable, intent(inout) :: this + integer :: i + + if (allocated(this)) then + do i = 1, size(this) + call finalise(this(i)) + end do + deallocate(this) + end if + + end subroutine constraints_finalise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X AMEND A CONSTRAINT: + !% Change constraint data and/or constraint function + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine constraint_amend(this,func,data,k,bound) + + type(Constraint), intent(inout) :: this + integer, optional, intent(in) :: func + real(dp), dimension(:), optional, intent(in) :: data + real(dp), optional, intent(in) :: k + integer, optional, intent(in) :: bound + + if (present(data)) then + call reallocate(this%data,size(data)) + this%data = data + end if + + if (present(func)) then + if (func < 0 .or. func >= REGISTERED_CONSTRAINTS) then + write(line,'(a,i0,a)')'Constraint_Amend: Invalid constraint subroutine (',func,')' + call System_Abort(line) + end if + + this%func = func + end if + + if (present(k)) this%k = k + if (present(bound)) this%bound = bound + + end subroutine constraint_amend + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X ASSIGNMENT + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine constraint_assignment(to,from) + + type(Constraint), intent(inout) :: to + type(Constraint), intent(in) :: from + + !First wipe the target of the assignment + call Finalise(to) + + if (from%initialised) then + + !Allocate target arrays + allocate(to%atom(size(from%atom)), & + to%data(size(from%data)), & + to%dC_dr(size(from%dC_dr)), & + to%old_dC_dr(size(from%old_dC_dr)), & + to%dcoll_dr(size(from%dcoll_dr))) + + !Then copy over the members one by one + to%N = from%N + to%atom = from%atom + to%data = from%data + to%func = from%func + to%lambdaR = from%lambdaR + to%lambdaV = from%lambdaV + to%C = from%C + to%dC_dr = from%dC_dr + to%dC_dt = from%dC_dt + to%old_dC_dr = from%old_dC_dr + to%dcoll_dr = from%dcoll_dr + to%Z_coll = from%Z_coll + to%tol = from%tol + to%k = from%k + to%bound = from%bound + to%E = from%E + to%dE_dcoll = from%dE_dcoll + to%dE_dk = from%dE_dk + if (allocated(from%dE_dr)) allocate(to%dE_dr(size(from%dE_dr))) + to%initialised = from%initialised + end if + + end subroutine constraint_assignment + + subroutine constraints_assignment(to,from) + + type(Constraint), dimension(:), intent(inout) :: to + type(Constraint), dimension(:), intent(in) :: from + integer :: i + + do i = 1, size(from) + to(i) = from(i) + end do + + end subroutine constraints_assignment + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X CALCULATE CONSTRAINT VALUES + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine constraint_calculate_values(this,pos,velo,mass, lattice,t) + + type(Constraint), intent(inout) :: this + real(dp), dimension(:), intent(in) :: pos, velo, mass + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + + call call_constraint_sub(this%func,pos,velo,mass,lattice,t,this%data,this%C,this%dC_dr,this%dC_dt,this%dcoll_dr,this%Z_coll,this%target_v) + if (this%k >= 0.0_dp) then ! restraint +!call print("RESTRAINT C "//this%C) + if ( (this%bound==BOTH_UPPER_AND_LOWER_BOUNDS) .or. & !apply anyway + (this%bound==UPPER_BOUND .and. this%C>this%target_v) .or. & !apply when exceeding the target value + (this%bound==LOWER_BOUND .and. this%C 1) then + pos(1:3) = 0.0_dp + do n = 2, this%N + i = this%atom(n) + pos(3*n-2:3*n) = diff_min_image(at,o,i) + velo(3*n-2:3*n) = at%velo(:,i) + mass(n) = mass_ptr(i) + end do + else + pos = at%pos(:,o) + end if + + call constraint_calculate_values(this,pos,velo,mass,at%lattice,t) + + end subroutine constraint_calculate_values_at + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X STORE THE GRADIENT AT THE START OF THE ALGORITHM + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine constraint_store_gradient(this) + + type(Constraint), intent(inout) :: this + + this%old_dC_dr = this%dC_dr + + end subroutine constraint_store_gradient + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X REGISTERING A CONSTRAINT + !X + !% Wrapper for constraint registering. Allows error catching + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function register_constraint(sub) result(p) + + integer :: p + interface + subroutine sub(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + use system_module + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + end subroutine sub + end interface + + if ((REGISTERED_CONSTRAINTS+1) == MAX_CONSTRAINT_SUBS) & + call system_abort('Register_Constraint: Pointer table is full') + call register_constraint_sub(sub) + p = REGISTERED_CONSTRAINTS + REGISTERED_CONSTRAINTS = REGISTERED_CONSTRAINTS + 1 + + end function register_constraint + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X I/O + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine constraint_print(this,verbosity,file,index) + + type(Constraint), intent(in) :: this + integer, optional, intent(in) :: verbosity + type(Inoutput), optional, intent(inout) :: file + integer, optional, intent(in) :: index + integer :: i + character(len=20) :: type + + if (this%k < 0.0_dp) then + type="Constraint" + else + type="Restraint" + endif + + call print('================', verbosity, file) + if (present(index)) then + call print(' '//trim(type)//' '// index, verbosity, file) + else + call print(' '//trim(type), verbosity, file) + endif + call print('================', verbosity, file) + call print('', verbosity, file) + if (this%initialised) then + call print('Number of atoms = '//this%N, verbosity, file) + call print('Atoms: '//this%atom, verbosity, file) + call print('Data: '//this%data, verbosity, file) + if (this%k >= 0.0_dp) call print(trim(type)//' k = '//this%k, verbosity, file) + call print(trim(type)//' function = '//this%func, verbosity, file) + call print(trim(type)//' target_value = '//this%target_v, verbosity, file) + call print(trim(type)//' value = '//this%C, verbosity, file) + call print(trim(type)//' gradients :') + do i = 1, this%N + call print(this%dC_dr(3*i-2:3*i), verbosity, file) + end do + call print('Time Derivative = '// this%dC_dt, verbosity, file) + if (this%k >= 0.0) then ! restraint + call print('restraint spring constant(k) = '// this%k, verbosity, file) + call print('spring acts as (bound) = '// trim(BOUND_STRING(this%bound)), verbosity, file) + else ! constraint + call print('Constraint - k value not used') + call print('Lagrange multiplier(R) = '// this%lambdaR, verbosity, file) + call print('Lagrange multiplier(V) = '// this%lambdaV, verbosity, file) + endif + call print('Fixman determinant(Z_xi) = '// this%Z_coll, verbosity, file) + call print(' gradients of collective coordinate:') + do i = 1, this%N + call print(this%dcoll_dr(3*i-2:3*i), verbosity, file) + end do + else + call print('(uninitialised)', verbosity, file) + end if + call print('', verbosity, file) + call print('================', verbosity, file) + + end subroutine constraint_print + + ! + !% Print an array of constraints, with optional first index + ! + subroutine constraints_print(this,verbosity,file,first) + + type(Constraint), dimension(:), intent(in) :: this + integer, optional, intent(in) :: verbosity + type(Inoutput), optional, intent(inout) :: file + integer, optional, intent(in) :: first + integer :: my_first, i + + my_first = 1 + if (present(first)) my_first = first + + do i = 1, size(this) + call print(this(i),verbosity,file,i-1+my_first) + call print('',verbosity,file) + end do + + end subroutine constraints_print + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X SHAKE/RATTLE ROUTINES + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% This is the SHAKE part of the SHAKE/RATTLE algorithm. It + !% adds forces to each atom which are in the directions of the + !% gradients of the constraint functions such that the constraints + !% are obeyed to within the preset tolerance at the new positions. + subroutine shake(at,g,constraints,t,dt,store_constraint_force) + + type(atoms), intent(inout) :: at !% the atoms object + type(group), intent(in) :: g !% the constrained group + type(constraint), intent(inout) :: constraints(:) !% an array of all the dynamicalsystem's constraints + real(dp), intent(in) :: t, dt !% the current time, and the time step + logical, optional, intent(in) :: store_constraint_force + + integer :: i,j,n, nn, Nobj, Nat, iterations + real(dp) :: da(3), m, df(3) + real(dp), dimension(:,:), pointer :: constraint_force + logical :: converged, do_store + + do i=1, size(constraints) + if (constraints(i)%k >= 0.0_dp) & + call system_abort("Called shake on constraint " // i // " which is actually a restraint") + end do + + Nobj = group_n_objects(g) + Nat = group_n_atoms(g) + do_store = optional_default(.false.,store_constraint_force) + + !Check for "constraint_force" property + if (do_store) then + if (assign_pointer(at,'constraint_force',constraint_force)) then + !zero the constraint forces + do n = 1, Nat + i = group_nth_atom(g,n) + constraint_force(:,i) = 0.0_dp + end do + else + call system_abort('shake: cannot find "constraint_force" property') + end if + end if + + !Calculate the constraint functions and store their values - the derivatives at this point will be + !used as the directions of the forces + + do n = 1, Nobj + i = group_nth_object(g,n) + call constraint_calculate_values_at(constraints(i),at,t) + constraints(i)%old_dC_dr = constraints(i)%dC_dr + constraints(i)%dlambdaR = 0.0_dp + constraints(i)%lambdaR = 0.0_dp + end do + + !Make the usual velocity Verlet step + do n = 1, Nat + i = group_nth_atom(g,n) + at%pos(:,i) = at%pos(:,i) + at%velo(:,i)*dt + end do + + iterations = 0 + do + ! update the accelerations, velocities, and positions using dlambdaR + do n = 1, Nobj + i = group_nth_object(g,n) + do nn = 1, constraints(i)%N + j = constraints(i)%atom(nn) + da = -constraints(i)%dlambdaR*constraints(i)%old_dC_dr(3*nn-2:3*nn)/at%mass(j) + at%acc(:,j) = at%acc(:,j) + da + at%velo(:,j) = at%velo(:,j) + 0.5_dp*dt*da + at%pos(:,j) = at%pos(:,j) + 0.5_dp*dt*dt*da + end do + end do + + ! recalculate constraints at the new positions (and new time) and test for convergence + converged = .true. + do n = 1, Nobj + i = group_nth_object(g,n) + call constraint_calculate_values_at(constraints(i),at,t+dt) +!call print("CONSTRAINTS%C "//constraints(i)%C) + if (abs(constraints(i)%C) > constraints(i)%tol) converged = .false. + end do + + if (converged .or. iterations > RATTLE_MAX_ITERATIONS) exit + + !Not converged, so calculate an update to the Lagrange multiplers (dlambdaR) + do n = 1, Nobj + i = group_nth_object(g,n) + m = 0.0_dp + do nn = 1, constraints(i)%N !Loop over each particle in the constraint + j = constraints(i)%atom(nn) + m = m + (constraints(i)%dC_dr(3*nn-2:3*nn) .dot. constraints(i)%old_dC_dr(3*nn-2:3*nn)) / at%mass(j) + end do + constraints(i)%dlambdaR = 2.0_dp * constraints(i)%C / (m * dt * dt) +!call print("CONSTRAINTS%dlambdaR"//constraints(i)%dlambdaR) + constraints(i)%lambdaR = constraints(i)%lambdaR + constraints(i)%dlambdaR +!call print("CONSTRAINTS%lambdaR"//constraints(i)%lambdaR) + end do + + iterations = iterations + 1 + + end do + + ! Store first part of the constraint force + if (do_store) then + do n = 1, Nobj + i = group_nth_object(g,n) + do nn = 1, constraints(i)%N + j = constraints(i)%atom(nn) + df = -constraints(i)%lambdaR*constraints(i)%old_dC_dr(3*nn-2:3*nn) + constraint_force(:,j) = constraint_force(:,j) + df + end do + end do + end if + + if (.not.converged) then + call print('shake: could not converge in '//RATTLE_MAX_ITERATIONS//& + ' iterations for this group:') + call print(g) + call system_abort('shake convergence problem') + end if + + end subroutine shake + + !% This is the RATTLE part of the SHAKE/RATTLE algorithm. It + !% adds forces to each atom which are in the directions of the + !% gradients of the constraint functions (evaluated at the NEW positions) + !% such that the constraints are obeyed to within the preset tolerance + !% by the new velocities. + subroutine rattle(at,g,constraints,t,dt,store_constraint_force) + + type(atoms), intent(inout) :: at + type(group), intent(in) :: g + type(constraint), intent(inout) :: constraints(:) + real(dp), intent(in) :: t + real(dp), intent(in) :: dt + logical, optional, intent(in) :: store_constraint_force + + real(dp), dimension(:,:), pointer :: constraint_force + integer :: i,j,n, nn, Nobj, Nat, iterations + real(dp) :: da(3), m, df(3) + logical :: converged, do_store + + do i=1, size(constraints) + if (constraints(i)%k >= 0.0_dp) & + call system_abort("Called rattle on constraint " // i // " which is actually a restraint") + end do + + Nobj = group_n_objects(g) + Nat = group_n_atoms(g) + do_store = optional_default(.false.,store_constraint_force) + + !Check for "constraint_force" property + if (do_store) then + if (.not. assign_pointer(at%properties,'constraint_force',constraint_force)) then + call system_abort('rattle: cannot find "constraint_force" property') + end if + end if + + !Make the usual velocity Verlet step + do n = 1, Nat + i = group_nth_atom(g,n) + at%velo(:,i) = at%velo(:,i) + 0.5_dp*at%acc(:,i)*dt + end do + + !Calculate the constraint functions and store their values - the derivatives at this point will be + !used as the directions of the forces + + do n = 1, Nobj + i = group_nth_object(g,n) + call constraint_calculate_values_at(constraints(i),at,t+dt) + constraints(i)%old_dC_dr = constraints(i)%dC_dr + constraints(i)%dlambdaV = 0.0_dp + constraints(i)%lambdaV = 0.0_dp + end do + + iterations = 0 + do + ! update the accelerations, and velocities using dlambdaV + do n = 1, Nobj + i = group_nth_object(g,n) + do nn = 1, constraints(i)%N + j = constraints(i)%atom(nn) + da = -constraints(i)%dlambdaV*constraints(i)%old_dC_dr(3*nn-2:3*nn)/at%mass(j) + at%acc(:,j) = at%acc(:,j) + da + at%velo(:,j) = at%velo(:,j) + 0.5_dp*dt*da + end do + end do + + ! recalculate constraints using new velocities and test for convergence + converged = .true. + do n = 1, Nobj + i = group_nth_object(g,n) + call constraint_calculate_values_at(constraints(i),at,t+dt) + if (abs(constraints(i)%dC_dt) > constraints(i)%tol) converged = .false. + end do + + if (converged .or. iterations > RATTLE_MAX_ITERATIONS) exit + + !Not converged, so calculate an update to the Lagrange multiplers (dlambdaV) + do n = 1, Nobj + i = group_nth_object(g,n) + m = 0.0_dp + do nn = 1, constraints(i)%N !Loop over each particle in the constraint + j = constraints(i)%atom(nn) + m = m + normsq(constraints(i)%dC_dr(3*nn-2:3*nn)) / at%mass(j) + end do + constraints(i)%dlambdaV = 2.0_dp * constraints(i)%dC_dt / (m * dt) + constraints(i)%lambdaV = constraints(i)%lambdaV + constraints(i)%dlambdaV + end do + + iterations = iterations + 1 + + end do + + ! Store second poart of the constraint force + if (do_store) then + do n = 1, Nobj + i = group_nth_object(g,n) + do nn = 1, constraints(i)%N + j = constraints(i)%atom(nn) + df = -constraints(i)%lambdaV*constraints(i)%old_dC_dr(3*nn-2:3*nn) + constraint_force(:,j) = constraint_force(:,j) + df + end do + end do + end if + + if (.not.converged) then + call print('rattle: could not converge in '//RATTLE_MAX_ITERATIONS//& + ' iterations for this group:') + call print(g) + call system_abort('rattle convergence problem') + end if + + end subroutine rattle + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X START OF CONSTRAINT SUBROUTINES + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X BONDANGLECOS: + !X + !% Constrain a cosine of a bond angle + !% 'data' should contain the required cosine value + !% The minimum image convention is used. + !% + !% The function used is $C = |\hat{\mathbf{r}}_{21} \cdot \hat{\mathbf{r}}_{23}| - c$ + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine BONDANGLECOS(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp), dimension(3) :: d21_hat, d23_hat + real(dp) :: d21_norm, d23_norm, dot_123 + integer :: i + + if(size(pos) /= 9) call system_abort('BONDANGLECOS: Exactly 3 atom positions must be specified') + if(size(velo) /= 9) call system_abort('BONDANGLECOS: Exactly 3 atom velocities must be specified') + if(size(mass) /= 3) call system_abort('BONDANGLECOS: Exactly 3 atom velocities must be specified') + if(size(data) /= 1) call system_abort('BONDANGLECOS: "data" must contain exactly one value') + + d21_hat = pos(1:3)-pos(4:6) + d21_norm = norm(d21_hat) + d21_hat = d21_hat/d21_norm + + d23_hat = pos(7:9)-pos(4:6) + d23_norm = norm(d23_hat) + d23_hat = d23_hat/d23_norm + + dot_123 = (d21_hat .dot. d23_hat) + + C = dot_123 - data(1) + target_v = data(1) + + dC_dr(1:3) = +(d23_hat - d21_hat*dot_123)/d21_norm + dC_dr(4:6) = - (d23_hat - d21_hat*dot_123)/d21_norm - (d21_hat - d23_hat*dot_123)/d23_norm + dC_dr(7:9) = +(d21_hat - d23_hat*dot_123)/d23_norm + + dC_dt = dC_dr .dot. velo + + dcoll_dr(1:9) = dC_dr(1:9) + Z_coll = 0._dp + do i=1,3 + Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) + enddo + + end subroutine BONDANGLECOS + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X BONDLENGTH: + !X + !% Exponentially decay a bond length towards a final value. + !% + !% \begin{itemize} + !% \item data(1) = initial bond length + !% \item data(2) = final bond length + !% \item data(3) = initial time + !% \item data(4) = relaxation time + !% \end{itemize} + !% + !% Constraint function is $C = |\mathbf{r}_1 - \mathbf{r}_2| - d$, where + !% \begin{displaymath} + !% d = d_{final} + (d_{init} - d_{final})\exp\left(-\frac{t-t_{init}}{t_{relax}}\right) + !% \end{displaymath} + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine BONDLENGTH(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: r(3), d, diff, efact + integer :: i + + if(size(pos) /= 6) call system_abort('BONDLENGTH: Exactly 2 atoms must be specified') + if(size(velo) /= 6) call system_abort('BONDLENGTH: Exactly 2 atoms must be specified') + if(size(mass) /= 2) call system_abort('BONDLENGTH: Exactly 2 atoms must be specified') + if(size(data) /= 4) call system_abort('BONDLENGTH: "data" must contain exactly four values') + + r = pos(1:3)-pos(4:6) + diff = data(1) - data(2) + efact = exp(-(t-data(3))/data(4)) + d = data(2) + diff * efact + + C = norm(r) - d + target_v = d + + dC_dr(1:3) = r/norm(r) + dC_dr(4:6) = -r/norm(r) + + dC_dt = (dC_dr .dot. velo) + diff * efact / data(4) + + dcoll_dr(1:6) = dC_dr(1:6) + Z_coll = 0._dp + do i=1,2 + Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) + enddo + + end subroutine BONDLENGTH + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X BONDLENGTH_SQ: + !X + !% Exponentially decay a bond length towards a final value. + !% + !% \begin{itemize} + !% \item data(1) = initial bond length + !% \item data(2) = final bond length + !% \item data(3) = initial time + !% \item data(4) = relaxation time + !% \end{itemize} + !% + !% Constraint function is $C = |\mathbf{r}_1 - \mathbf{r}_2|^2 - d^2$, where + !% \begin{displaymath} + !% d = d_{final} + (d_{init} - d_{final})\exp\left(-\frac{t-t_{init}}{t_{relax}}\right) + !% \end{displaymath} + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine BONDLENGTH_SQ(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: r(3), d, diff, efact + integer :: i + + if(size(pos) /= 6) call system_abort('BONDLENGTH_SQ: Exactly 2 atoms must be specified') + if(size(velo) /= 6) call system_abort('BONDLENGTH_SQ: Exactly 2 atoms must be specified') + if(size(mass) /= 2) call system_abort('BONDLENGTH_SQ: Exactly 2 atoms must be specified') + if(size(data) /= 4) call system_abort('BONDLENGTH_SQ: "data" must contain exactly four values') + + r = pos(1:3)-pos(4:6) + diff = data(1) - data(2) + efact = exp(-(t-data(3))/data(4)) + d = data(2) + diff * efact + + C = normsq(r) - d*d + target_v = d*d + dC_dr(1:3) = 2.0_dp * r + dC_dr(4:6) = -2.0_dp * r + dC_dt = (dC_dr .dot. velo) + 2.0_dp * d * diff * efact / data(4) + + dcoll_dr(1:6) = dC_dr(1:6) + Z_coll = 0._dp + do i=1,2 + Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) + enddo + + end subroutine BONDLENGTH_SQ + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X BONDLENGTH_DEV_POW: + !X + !% Exponentially decay an arbitrary power of the deviation of a bond length towards a final value. + !% + !% \begin{itemize} + !% \item data(1) = initial bond length + !% \item data(2) = final bond length + !% \item data(3) = exponent + !% \item data(4) = initial time + !% \item data(5) = relaxation time + !% \end{itemize} + !% + !% Constraint function is $C = (|\mathbf{r}_1 - \mathbf{r}_2| - d)^p$, where + !% \begin{displaymath} + !% d = d_{final} + (d_{init} - d_{final})\exp\left(-\frac{t-t_{init}}{t_{relax}}\right) + !% \end{displaymath} + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine BONDLENGTH_DEV_POW(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: ri, rf, p, t0, tau + real(dp) :: dr(3), cur_d, diff, efact, norm_dr + integer :: i + + if(size(pos) /= 6) call system_abort('BONDLENGTH_DEV_POW: Exactly 2 atoms must be specified') + if(size(velo) /= 6) call system_abort('BONDLENGTH_DEV_POW: Exactly 2 atoms must be specified') + if(size(mass) /= 2) call system_abort('BONDLENGTH_DEV_POW: Exactly 2 atoms must be specified') + if(size(data) /= 5) call system_abort('BONDLENGTH_DEV_POW: "data" must contain exactly five values') + + ri = data(1) + rf = data(2) + p = data(3) + t0 = data(4) + tau = data(5) + + dr = pos(1:3)-pos(4:6) + diff = ri - rf + efact = exp(-(t-t0)/tau) + cur_d = rf + diff * efact + + norm_dr = norm(dr) + C = (norm_dr-cur_d)**p + target_v = cur_d + dC_dr(1:3) = p*(norm_dr-cur_d)**(p-1.0_dp)*dr/norm_dr + dC_dr(4:6) = -p*(norm_dr-cur_d)**(p-1.0_dp)*dr/norm_dr + dC_dt = (dC_dr .dot. velo) + p * (norm_dr-cur_d)**(p-1.0_dp) * diff * efact / tau + + dcoll_dr(1:6) = dC_dr(1:6) + Z_coll = 0._dp + do i=1,2 + Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) + enddo + + end subroutine BONDLENGTH_DEV_POW + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X CUBIC_BONDLENGTH_SQ: + !X + !% Constrain a bond length to the time dependent quantity + !% \begin{displaymath} + !% at^3 + bt^2 + ct + d + !% \end{displaymath} + !% where $t$ is clamped to the range $[t_{init},t_{final}]$ + !% + !% \begin{itemize} + !% \item 'data(1:4) = (/ a,b,c,d /)' + !% \item 'data(5) =' initial time $t_{init}$ + !% \item 'data(6) =' final time $t_{final}$ + !% \end{itemize} + !% + !% The constraint function is: + !% \begin{displaymath} + !% \begin{array}{l} + !% C = |\mathbf{r}_1 - \mathbf{r}_2|^2 - l^2 \\ l = at^3 + bt^2 + ct + d + !% \end{array} + !% \end{displaymath} + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine CUBIC_BONDLENGTH_SQ(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: r(3), t_clamped, l, dl_dt, x, x2, x3 + integer :: i + + if(size(pos) /= 6) call system_abort('CUBIC_BONDLENGTH_SQ: Exactly 2 atoms must be specified') + if(size(velo) /= 6) call system_abort('CUBIC_BONDLENGTH_SQ: Exactly 2 atoms must be specified') + if(size(mass) /= 2) call system_abort('CUBIC_BONDLENGTH_SQ: Exactly 2 atoms must be specified') + if(size(data) /= 6) call system_abort('CUBIC_BONDLENGTH_SQ: "data" must contain exactly six values') + + r = pos(1:3)-pos(4:6) + t_clamped = t + if (t_clamped > data(6)) then + t_clamped = data(6) + else if (t_clamped < data(5)) then + t_clamped = data(5) + end if + + x = t_clamped; x2 = x*x; x3 = x2 * x + l = data(1)*x3 + data(2)*x2 + data(3)*x + data(4) + dl_dt = 3.0_dp*data(1)*x2 + 2.0_dp*data(2)*x + data(3) + + C = normsq(r) - l*l + target_v = l*l + dC_dr(1:3) = 2.0_dp * r + dC_dr(4:6) = -2.0_dp * r + if (t >= data(5) .and. t <= data(6)) then + dC_dt = (dC_dr .dot. velo) - 2.0_dp * l * dl_dt + else + dC_dt = dC_dr .dot. velo + endif + + dcoll_dr(1:6) = dC_dr(1:6) + Z_coll = 0._dp + do i=1,2 + Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) + enddo + + end subroutine CUBIC_BONDLENGTH_SQ + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X PLANE + !X + !% Constrain a particle to the plane $ax+by+cz=d$. + !% 'data' should contain '(/a, b, c, d/)'. Periodic boundary conditions + !% are not applied (the plane only cuts the + !% cell once, if at all). + !% + !% The function used is $C = \mathbf{r} \cdot \hat{\mathbf{n}} - d$ + !% where $\mathbf{n} = (a,b,c)$ + !% + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine PLANE(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: d, n(3), n_hat(3) + integer :: i + + if(size(data) /= 4 ) call system_abort('PLANE: "data" must be of length 4') + if(size(pos) /= 3) call system_abort('PLANE: Exactly 1 atom must be specified') + if(size(velo) /= 3) call system_abort('PLANE: Exactly 1 atom must be specified') + if(size(mass) /= 1) call system_abort('PLANE: Exactly 1 atom must be specified') + + n = data(1:3) !Normal to the plane + n_hat = n / norm(n) !Unit normal + d = data(4) / norm(n) !Distance from plane to origin + C = (pos .dot. n_hat) - d !Distance of atom from plane + target_v = d + dC_dr = n_hat + dC_dt = dC_dr .dot. velo + + dcoll_dr(1:3) = dC_dr(1:3) + Z_coll = 0._dp + Z_coll = 1/mass(1) * normsq(dcoll_dr(1:3)) + + end subroutine PLANE + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X BONDLENGTH_DIFF: + !X + !% Constrain the difference of 2 bond length of 3 atoms. + !% The second atom is common in the 2 bonds. + !% 'data' should contain the required bond length + !% The minimum image convention is used. + !% + !% The function used is $C = |\mathbf{r}_1 - \mathbf{r}_2| - |\mathbf{r}_3 - \mathbf{r}_2| - d $ + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine BONDLENGTH_DIFF(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp), dimension(3) :: d1, d2 + real(dp) :: norm_d1,norm_d2 + integer :: i + real(dp) :: target_dd, target_dd_i, target_dd_f, t0, tau, efact + + if(size(pos) /= 9) call system_abort('BONDLENGTH_DIFF: Exactly 3 atoms must be specified') + if(size(velo) /= 9) call system_abort('BONDLENGTH_DIFF: Exactly 3 atoms must be specified') + if(size(mass) /= 3) call system_abort('BONDLENGTH_DIFF: Exactly 3 atoms must be specified') + if(size(data) /= 4) call system_abort('BONDLENGTH_DIFF: "data" must contain exactly four values') + + d1 = pos(1:3)-pos(4:6) + d2 = pos(7:9)-pos(4:6) + + norm_d1 = norm(d1) + norm_d2 = norm(d2) + + target_dd_i = data(1) + target_dd_f = data(2) + t0 = data(3) + tau = data(4) + efact = exp(-(t-t0)/tau) + target_dd = target_dd_f + (target_dd_i-target_dd_f)*efact + + C = norm_d1 - norm_d2 - target_dd + target_v = target_dd + + dC_dr(1:3) = d1(1:3) / norm_d1 + dC_dr(7:9) = - d2(1:3) / norm_d2 + dC_dr(4:6) = - dC_dr(1:3) - dC_dr(7:9) + + dC_dt = dC_dr .dot. velo + (target_dd_i-target_dd_f)*efact/tau + + dcoll_dr(1:9) = dC_dr(1:9) + Z_coll = 0._dp + do i=1,3 + Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) + enddo + + end subroutine BONDLENGTH_DIFF + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X GAP ENERGY: + !X + !% Constrain the GAP energy defined by two resonance structures, + !% where 1 bond breaks and/or another bond forms. + !% 'data' should contain the required value of the gap energy. + !% + !% The function used is $C = E_\mathbf{GAP} - data $ + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine GAP_ENERGY(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: E_GAP, EVB1_energy, EVB2_energy + real(dp), pointer :: EVB1_forces(:,:), EVB2_forces(:,:) + real(dp), dimension(size(pos)) :: F_GAP + type(atoms) :: dummy,dummy2 + type(InOutput) :: inoutfile + integer :: stat + integer :: i + real(dp) :: posmax, posmin + integer :: gap_energy_index, gap_energy_index1, gap_energy_index2 + integer :: num_fields + character(len=STRING_LENGTH) :: comment + character(len=STRING_LENGTH) :: fields(3) + logical :: exists + integer :: jobid + character(len=30) :: jobid_str + + !check if required properties are present + if (mod(size(pos),3)/=0) call system_abort("GAP_ENERGY: pos must have 3N coordinates") + if(size(data) /= 1) call system_abort('GAP_ENERGY: "data" must contain exactly one value') + + !print pos info into an xyz file (no lattice and species info) + posmax=maxval(pos) + posmin=minval(pos) + !CInoutPut is on a higher level, cannot call print_xyz and read_xyz + + !get $JOBID if running i/o on /tmp + jobid=0 + call get_env_var("JOBID", jobid_str, stat) + if (stat==0) read (jobid_str,*) jobid + + if (jobid>0) then + call system_command("mv /tmp/cp2k_run_"//jobid//"/only_pos.xyz /tmp/cp2k_run_"//jobid//"/only_pos.xyz.bak",stat) + call initialise(inoutfile,filename="/tmp/cp2k_run_"//jobid//"/only_pos.xyz",action=OUTPUT) + else + call system_command("mv only_pos.xyz only_pos.xyz.bak",stat) + call initialise(inoutfile,filename="only_pos.xyz",action=OUTPUT) + endif + call print((size(pos)/3),file=inoutfile) + call print('Lattice="'//(posmax-posmin)//' 0. 0. 0. '//(posmax-posmin)//' 0. 0. 0. '//(posmax-posmin)//'" Properties=species:S:1:pos:R:3',file=inoutfile) + do i=1,size(pos),3 + call print("H "//pos(i)//" "//pos(i+1)//" "//pos(i+2),file=inoutfile) + enddo + call finalise(inoutfile) + + !calc evb from an external filepot + if (jobid>0) then + call system_command("~/bin/egap_from_pos_tmp pos=/tmp/cp2k_run_"//jobid//"/only_pos.xyz only_GAP=T out=/tmp/cp2k_run_"//jobid//"/only_pos.out", status=stat) + else + call system_command("~/bin/egap_from_pos pos=only_pos.xyz only_GAP=T out=only_pos.out", status=stat) + endif + + !read evb forces and energies + !CInoutPut is on a higher level, cannot call print_xyz or read_xyz + if (jobid>0) then + inquire(file="/tmp/cp2k_run_"//jobid//"/only_pos.out", exist=exists) + if (.not.exists) call system_abort("No /tmp/cp2k_run_"//jobid//"/only_pos.out file found. EVB filepot probably aborted.") + call initialise(inoutfile,filename="/tmp/cp2k_run_"//jobid//"/only_pos.out",action=INPUT) + else + inquire(file="only_pos.out", exist=exists) + if (.not.exists) call system_abort("No only_pos.out file found. EVB filepot probably aborted.") + call initialise(inoutfile,filename="only_pos.out",action=INPUT) + endif + !Natoms + call parse_line(inoutfile," ",fields,num_fields,stat) + if (stat/=0) call system_abort("GAP_ENERGY: Something wrong while reaing only_pos.out number of atoms.") + if (num_fields>1) call system_abort("GAP_ENERGY: More information than GAP forces was found in only_pos.out.") + if (size(pos)/=3*string_to_int(fields(1))) call system_abort("GAP_ENERGY: Number of atoms mismatch.") + !comment + comment=read_line(inoutfile,stat) + if (stat/=0) call system_abort("GAP_ENERGY: Something wrong while reaing only_pos.out.") + !find gap energy + gap_energy_index=index(comment,"gap=") !find where "gap=..." starts + if (gap_energy_index/=0) then !not the first one + gap_energy_index=index(comment," gap=")+1 !find where "gap=..." starts + endif + if (gap_energy_index==0) call system_abort("GAP_ENERGY: Could not find gap energy in only_pos.out comment line.") + gap_energy_index1=index(comment(gap_energy_index:),"=") !find the position of "=" in "gap=..." + if (gap_energy_index1/=4) call system_abort("GAP_ENERGY: Something wrong with energy value in only_pos.out.") + gap_energy_index2=index(comment(gap_energy_index:)," ") !find the position of " " in "gap=..." + if (gap_energy_index2==0) then !it is at the end of line + E_GAP=string_to_real(comment((gap_energy_index+gap_energy_index1):)) !read from the character after "=" + else !there is something else behind + E_GAP=string_to_real(comment((gap_energy_index+gap_energy_index1):(gap_energy_index+gap_energy_index2-1))) !read from the character after "=" to the one before " " + endif + !GAP forces + do i=1,size(pos),3 + call parse_line(inoutfile," ",fields,num_fields,stat) + if (stat/=0) call system_abort("GAP_ENERGY: Something wrong while reaing only_pos.out.") + if (num_fields>3) call system_abort("GAP_ENERGY: More information than GAP forces was found in only_pos.out.") + F_GAP(i:i+2) = (/string_to_real(fields(1)),string_to_real(fields(2)),string_to_real(fields(3))/) + enddo + call finalise(inoutfile) + +!call print("GAP_ENERGY "//E_GAP) + C = E_GAP - data(1) + target_v = data(1) + + dC_dr(1:size(pos)) = -F_GAP(1:size(pos)) + + dC_dt = dC_dr .dot. velo + + dcoll_dr(1:size(pos)) = dC_dr(1:size(pos)) + Z_coll = 0._dp + do i=1,(size(pos)/3) + Z_coll = 1/mass(i) * normsq(dcoll_dr(i*3-2:i*3)) + enddo + + call finalise(dummy) + call finalise(dummy2) + + end subroutine GAP_ENERGY + + subroutine PARABOLIC_FIT(x,afunc) + real(dp) :: x, afunc(:) + + afunc(1) = x*x + afunc(2) = x + afunc(3) = 1 + + end subroutine PARABOLIC_FIT + + subroutine LINEAR_FIT(x,afunc) + real(dp) :: x, afunc(:) + + afunc(1) = x*x + afunc(2) = x + afunc(3) = 1 + + end subroutine LINEAR_FIT + + + subroutine CRACK_TIP_CURVATURE(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: a(3), am(3), ap(3), chisq, a_target + real(dp), allocatable :: xp(:,:), xm(:,:), x(:,:), sig(:), da1_dR(:,:), da2_dR(:,:), da3_dR(:,:) + integer :: i, n, k, constraint_type + real(dp), parameter :: eps = 1e-4_dp + + n = size(pos)/3 + allocate(x(3,n), xp(3,n), xm(3,n), sig(n), da1_dR(3,n)) + sig(:) = 0.0_dp + x = reshape(pos, (/3,n/)) + a_target = data(1) ! target curvature + + call least_squares(x(2,:), x(1,:), sig, a, chisq, PARABOLIC_FIT) + call print('CRACK_TIP_CURVATURE coefficients '//a) + call print('CRACK_TIP_CURVATURE target '//a_target) + + do k=1,3 + do i=1,n + xp = x + xm = x + + xp(k,i) = xp(k,i) + eps + call least_squares(xp(2,:), xp(1,:), sig, ap, chisq, PARABOLIC_FIT) + + xm(k,i) = xm(k,i) - eps + call least_squares(xm(2,:), xm(1,:), sig, am, chisq, PARABOLIC_FIT) + + da1_dR(k,i) = (ap(1) - am(1))/(2.0_dp*eps) + end do + end do + + ! C = a - a_target + ! dC_dR = da_dR + C = a(1) - a_target + target_v = a_target + dC_dR = reshape(da1_dR, (/3*N/)) + call print('CRACK_TIP_CURVATURE C '//C) + call print('CRACK_TIP_CURVATURE dC_dR '//dC_dR) + + dC_dt = dC_dr .dot. velo + + end subroutine CRACK_TIP_CURVATURE + + subroutine CRACK_TIP_GRADIENT(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: a(2), am(2), ap(2), chisq, a_target + real(dp), allocatable :: xp(:,:), xm(:,:), x(:,:), sig(:), da1_dR(:,:), da2_dR(:,:), da3_dR(:,:) + integer :: i, n, k, constraint_type + real(dp), parameter :: eps = 1e-4_dp + + n = size(pos)/3 + allocate(x(3,n), xp(3,n), xm(3,n), sig(n), da1_dR(3,n)) + sig(:) = 0.0_dp + x = reshape(pos, (/3,n/)) + a_target = data(1) ! target gradient + + call least_squares(x(1,:), x(2,:), sig, a, chisq, LINEAR_FIT) + call print('CRACK_TIP_GRADIENT coefficients '//a) + call print('CRACK_TIP_GRADIENT target '//a_target) + + do k=1,3 + do i=1,n + xp = x + xm = x + + xp(k,i) = xp(k,i) + eps + call least_squares(xp(1,:), xp(2,:), sig, ap, chisq, LINEAR_FIT) + + xm(k,i) = xm(k,i) - eps + call least_squares(xm(1,:), xm(2,:), sig, am, chisq, LINEAR_FIT) + + da1_dR(k,i) = (ap(1) - am(1))/(2.0_dp*eps) + end do + end do + + ! C = a - a_target + ! dC_dR = da_dR + C = a(1) - a_target + target_v = a_target + dC_dR = reshape(da1_dR, (/3*N/)) + call print('CRACK_TIP_GRADIENT C '//C) + call print('CRACK_TIP_GRADIENT dC_dR '//dC_dR) + + dC_dt = dC_dr .dot. velo + + end subroutine CRACK_TIP_GRADIENT + + subroutine CRACK_TIP_POSITION(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + real(dp) :: a(3), am(3), ap(3), chisq, dC_da1, dC_da2, dC_da3, pos_target + real(dp), allocatable :: xp(:,:), xm(:,:), x(:,:), sig(:), da1_dR(:,:), da2_dR(:,:), da3_dR(:,:) + real(dp), parameter :: eps = 1e-4_dp + integer i, k, n + + n = size(pos)/3 + allocate(x(3,n), xp(3,n), xm(3,n), sig(n), da1_dR(3,n), da2_dR(3,n), da3_dR(3,n)) + sig(:) = 0.0_dp + x = reshape(pos, (/3,n/)) + pos_target = data(1) ! target position + + call least_squares(x(2,:), x(1,:), sig, a, chisq, PARABOLIC_FIT) + call print('CRACK_TIP_POSITION coefficients '//a) + call print('CRACK_TIP_POSITION target '//pos_target) + + do k=1,3 + do i=1,n + xp = x + xm = x + + xp(k,i) = xp(k,i) + eps + call least_squares(xp(2,:), xp(1,:), sig, ap, chisq, PARABOLIC_FIT) + + xm(k,i) = xm(k,i) - eps + call least_squares(xm(2,:), xm(1,:), sig, am, chisq, PARABOLIC_FIT) + + da1_dR(k,i) = (ap(1) - am(1))/(2.0_dp*eps) + da2_dR(k,i) = (ap(2) - am(2))/(2.0_dp*eps) + da3_dR(k,i) = (ap(3) - am(3))/(2.0_dp*eps) + + end do + end do + + ! C = y0 - pos_target + ! dC_dR = dC_da*da_dR + dC_db*db_dR + dC_dc*dc_dR + ! x0 = -b/2*a + ! y0 = a*x0**2 + b*x0 + c = c - b**2/(4*a) + C = (a(3) - a(2)**2/(4.0_dp*a(1))) - pos_target + target_v = pos_target + + dC_da1 = a(2)**2/(4.0_dp*a(1)**2) + dC_da2 = -a(2)/(2*a(1)) + dC_da3 = 1.0_dp + + dC_dR = dC_da1*reshape(da1_dR, (/3*N/)) + & + dC_da2*reshape(da2_dR, (/3*N/)) + & + dC_da3*reshape(da3_dR, (/3*N/)) + + dC_dt = dC_dr .dot. velo + + call print('CRACK_TIP_POSITION C '//C) + call print('CRACK_TIP_POSITION dC_dR '//dC_dR) + + end subroutine CRACK_TIP_POSITION + + subroutine STRUCT_FACTOR_LIKE_MAG(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + integer :: i, n + real(dp) :: target_SF_r, target_SF_i + real(dp) :: SF_Q(3), frac_pos(3), lattice_inv(3,3) + real(dp) :: SF_real, SF_imag, SF_mag + + if (size(data) /= 4) call system_abort("STRUCT_FACTOR_LIKE_MAG needs data of 3 q components and target value") + SF_Q(1:3) = data(1:3)*2.0_dp*PI + target_v = data(4) + + n = size(pos)/3 + + call matrix3x3_inverse(lattice, lattice_inv) + SF_real = 0.0_dp + SF_imag = 0.0_dp + do i=0, n-1 + frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) + SF_real = SF_real + cos(frac_pos .dot. SF_Q) + SF_imag = SF_imag + sin(frac_pos .dot. SF_Q) + end do + SF_real = SF_real/real(n,dp) + SF_imag = SF_imag/real(n,dp) + SF_mag = sqrt(SF_real**2 + SF_imag**2) + C = SF_mag - target_v + do i=0, n-1 + frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) + dC_dR(i*3+1:i*3+3) = (0.5_dp/SF_mag)*( & + -2.0_dp/real(n,dp)*SF_real*sin(frac_pos .dot. SF_Q)*matmul(SF_Q, lattice_inv) + & + 2.0_dp/real(n,dp)*SF_imag*cos(frac_pos .dot. SF_Q)*matmul(SF_Q, lattice_inv) ) + end do + + dC_dt = dC_dR .dot. velo + + call print ("STRUCT_FACTOR_LIKE_MAG SF "//SF_real//" "//SF_imag//" |SF| "//SF_mag) + + end subroutine STRUCT_FACTOR_LIKE_MAG + + subroutine STRUCT_FACTOR_LIKE_R(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + integer :: i, n + real(dp) :: target_SF_r, target_SF_i + real(dp) :: SF_Q(3), frac_pos(3), lattice_inv(3,3) + real(dp) :: SF_real + + if (size(data) /= 4) call system_abort("STRUCT_FACTOR_LIKE_R needs data of 3 q components and target value") + SF_Q(1:3) = data(1:3)*2.0_dp*PI + target_v = data(4) + + n = size(pos)/3 + + call matrix3x3_inverse(lattice, lattice_inv) + SF_real = 0.0_dp + do i=0, n-1 + frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) + SF_real = SF_real + cos(frac_pos .dot. SF_Q) + end do + SF_real = SF_real/real(n,dp) + C = SF_real - target_v + do i=0, n-1 + frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) + dC_dR(i*3+1:i*3+3) = -1.0_dp/real(n,dp)*sin(frac_pos .dot. SF_Q)*matmul(SF_Q, lattice_inv) + end do + + dC_dt = dC_dR .dot. velo + + call print ("STRUCT_FACTOR_LIKE_R SF "//SF_real) + + end subroutine STRUCT_FACTOR_LIKE_R + + subroutine STRUCT_FACTOR_LIKE_I(pos, velo, mass, lattice, t, data, C, dC_dr, dC_dt, dcoll_dr, Z_coll, target_v) + + real(dp), dimension(:), intent(in) :: pos, velo, mass, data + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(in) :: t + real(dp), intent(out) :: C + real(dp), dimension(size(pos)), intent(out) :: dC_dr, dcoll_dr + real(dp), intent(out) :: dC_dt, Z_coll + real(dp), intent(out) :: target_v + !local variables + integer :: i, n + real(dp) :: target_SF_r, target_SF_i + real(dp) :: SF_Q(3), frac_pos(3), lattice_inv(3,3) + real(dp) :: SF_imag + + if (size(data) /= 4) call system_abort("STRUCT_FACTOR_LIKE_I needs data of 3 q components and target value") + SF_Q(1:3) = data(1:3)*2.0_dp*PI + target_v = data(4) + + n = size(pos)/3 + + call matrix3x3_inverse(lattice, lattice_inv) + SF_imag = 0.0_dp + do i=0, n-1 + frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) + SF_imag = SF_imag + sin(frac_pos .dot. SF_Q) + end do + SF_imag = SF_imag/real(n,dp) + C = SF_imag - target_v + do i=0, n-1 + frac_pos(1:3) = matmul(lattice_inv, pos(i*3+1:i*3+3)) + dC_dR(i*3+1:i*3+3) = 1.0_dp/real(n,dp)*cos(frac_pos .dot. SF_Q)*matmul(SF_Q, lattice_inv) + end do + + dC_dt = dC_dR .dot. velo + + call print ("STRUCT_FACTOR_LIKE_I "//SF_imag) + + end subroutine STRUCT_FACTOR_LIKE_I + + + subroutine add_restraint_forces(at, Nrestraints, restraints, t, f, E, store_restraint_force) + type(Atoms), intent(inout) :: at + integer, intent(in) :: Nrestraints + type(Constraint), intent(inout) :: restraints(:) + real(dp), intent(in) :: t + real(dp), intent(inout) :: f(:,:) + real(dp), optional, intent(inout) :: E + logical, optional :: store_restraint_force + + integer :: i_r, ii_a, i_a + logical :: do_store + real(dp), pointer :: constraint_force(:,:) + real(dp) :: restraint_E + real(dp) :: df(3) + + do_store = optional_default(.false., store_restraint_force) + + !Check for "constraint_force" property + if (do_store) then + if (assign_pointer(at,'constraint_force',constraint_force)) then + constraint_force = 0.0_dp + else + call system_abort('add_restraint_force: cannot find "constraint_force" property') + end if + end if + + restraint_E = 0.0_dp + do i_r=1, Nrestraints + if (restraints(i_r)%k < 0.0_dp) then + call system_abort("add_restraint_force for restraint " // i_r // " got invalid spring_constant " // restraints(i_r)%k) + endif + if (restraints(i_r)%k >= 0.0_dp) then + call constraint_calculate_values_at(restraints(i_r),at,t) + restraint_E = restraint_E + restraints(i_r)%E + do ii_a=1, restraints(i_r)%N + i_a = restraints(i_r)%atom(ii_a) + df = -restraints(i_r)%dE_dr((ii_a-1)*3+1:(ii_a-1)*3+3) + if (do_store) constraint_force(:,i_a) = constraint_force(:,i_a) + df + f(:,i_a) = f(:,i_a) + df + end do + endif + end do + + if (present(E)) E = E + restraint_E + if (do_store) call set_value(at%params, "restraint_energy", restraint_E) + end subroutine add_restraint_forces + +end module constraints_module diff --git a/src/libAtoms/Dictionary.F90 b/src/libAtoms/Dictionary.F90 new file mode 100644 index 0000000000..adcc11fe87 --- /dev/null +++ b/src/libAtoms/Dictionary.F90 @@ -0,0 +1,3198 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!% A Dictionary object contains a list of keys (strings) and corresponding entries. +!% Entries are a variable type, containing one of: +!% 'integer', 'real(dp)', 'complex(dp)', 'logical', extendable_str +!% or a 1-D array of any of those. 2-D arrays of integers and reals are also supported. + +#include "error.inc" + +module dictionary_module + + use error_module + use system_module + use linearalgebra_module + use mpi_context_module + use extendable_str_module + + implicit none + + private + + public :: T_NONE, T_INTEGER, T_REAL, T_COMPLEX, T_LOGICAL, & + T_INTEGER_A, T_REAL_A, T_COMPLEX_A, T_LOGICAL_A, & + T_CHAR, T_CHAR_A, T_DATA, T_INTEGER_A2, T_REAL_A2, T_DICT + integer, parameter :: & + T_NONE = 0, & + T_INTEGER = 1, T_REAL =2, T_COMPLEX = 3, T_LOGICAL=4, & + T_INTEGER_A = 5, T_REAL_A = 6, T_COMPLEX_A = 7, T_LOGICAL_A = 8, & + T_CHAR = 9, T_CHAR_A = 10, T_DATA = 11, T_INTEGER_A2 = 12, T_REAL_A2 = 13, T_DICT = 14 !% OMIT + + ! Maintained for backwards compatibility with old NetCDF files using type attribute + public :: PROPERTY_INT, PROPERTY_REAL, PROPERTY_STR, PROPERTY_LOGICAL + integer, parameter :: & + PROPERTY_INT = 1, PROPERTY_REAL = 2, PROPERTY_STR = 3, PROPERTY_LOGICAL = 4 + + public :: C_KEY_LEN, STRING_LENGTH, STRING_LENGTH_SHORT, DICT_N_FIELDS + integer, parameter :: C_KEY_LEN = 256 +#ifdef STRING_LENGTH_OVERRIDE + integer, parameter :: STRING_LENGTH = STRING_LENGTH_OVERRIDE !% Maximum string length +#else + integer, parameter :: STRING_LENGTH = 30000 !% Maximum string length +#endif + integer, parameter :: STRING_LENGTH_SHORT = 32 !% a shorter string length, for when there are LOTS of strings + integer, parameter :: DICT_N_FIELDS = 1000 !% Maximum number of fields during parsing + + public :: dictdata + type DictData + integer, dimension(:), allocatable :: d + end type DictData + + public :: dictentry + type DictEntry + !% OMIT + integer :: type = T_NONE + integer :: len = 1 + integer :: len2(2) = (/0, 0/) + + logical :: own_data = .true. !% True if we own the data and should free it in finalise() + + integer i + real(dp) r + complex(dp) c + logical l + type(extendable_str) s + + integer, pointer :: i_a(:) => null() + real(dp), pointer :: r_a(:) => null() + complex(dp), pointer :: c_a(:) => null() + logical, pointer :: l_a(:) => null() + character(len=1), pointer :: s_a(:,:) => null() + + integer, pointer :: i_a2(:,:) => null() + real(dp), pointer :: r_a2(:,:) => null() + + type(DictData) :: d + + end type DictEntry + + integer, parameter :: n_entry_block = 10 !% OMIT + + public Dictionary + type Dictionary + !% Fortran implementation of a dictionary to store key/value pairs of the following types: + !% + !% - Integer + !% - Real + !% - String + !% - Complex + !% - Logical + !% - 1D integer array + !% - 1D real array + !% - 1D complex array + !% - 1D logical array + !% - 2D integer array + !% - 2D real array + !% - Arbitrary data, via Fortran ``transform()`` intrinsic + + integer :: N = 0 !% number of entries in use + type(extendable_str), allocatable :: keys(:) !% array of keys + type(DictEntry), allocatable :: entries(:) !% array of entries + integer :: cache_invalid !% non-zero on exit from set_value(), set_value_pointer(), add_array(), remove_entry() if any array memory locations changed + integer :: key_cache_invalid !% non-zero on exit from set_value(), set_value_pointer(), add_array(), remove_entry() if any keys changed + end type Dictionary + + public c_dictionary_ptr_type + type c_dictionary_ptr_type + type(Dictionary), pointer :: p + end type c_dictionary_ptr_type + + !% Initialise a new empty dictionary + public initialise + interface initialise + module procedure dictionary_initialise + end interface initialise + + !% Finalise dictionary + public finalise + interface finalise + module procedure dictionary_finalise, dictentry_finalise + end interface finalise + + !% Print a DictEntry or a Dictionary + public print + interface print + module procedure dictentry_print, dictionary_print + end interface print + + public print_keys + interface print_keys + module procedure dictionary_print_keys + end interface print_keys + + !% Set a value in a Dictionary + public set_value + interface set_value + module procedure dictionary_set_value_none + module procedure dictionary_set_value_i, dictionary_set_value_r, dictionary_set_value_c, dictionary_set_value_l + module procedure dictionary_set_value_i_a, dictionary_set_value_r_a, dictionary_set_value_c_a, dictionary_set_value_l_a + module procedure dictionary_set_value_s, dictionary_set_value_s_es, dictionary_set_value_s_a2 + module procedure dictionary_set_value_s_a + module procedure dictionary_set_value_d + module procedure dictionary_set_value_i_a2 + module procedure dictionary_set_value_r_a2 + module procedure dictionary_set_value_dict + end interface set_value + + public set_value_pointer + interface set_value_pointer + module procedure dictionary_set_value_pointer_i + module procedure dictionary_set_value_pointer_r + module procedure dictionary_set_value_pointer_c + module procedure dictionary_set_value_pointer_l + module procedure dictionary_set_value_pointer_s + module procedure dictionary_set_value_pointer_i2 + module procedure dictionary_set_value_pointer_r2 + end interface set_value_pointer + + !% Get a value from a Dictionary + public get_value + interface get_value + module procedure dictionary_get_value_i, dictionary_get_value_r, dictionary_get_value_c, dictionary_get_value_l + module procedure dictionary_get_value_i_a, dictionary_get_value_r_a, dictionary_get_value_c_a, dictionary_get_value_l_a + module procedure dictionary_get_value_s, dictionary_get_value_s_es, dictionary_get_value_s_a, dictionary_get_value_s_a2 + module procedure dictionary_get_value_d + module procedure dictionary_get_value_i_a2 + module procedure dictionary_get_value_r_a2 + module procedure dictionary_get_value_dict + end interface get_value + + public assign_pointer + interface assign_pointer + module procedure dictionary_assign_pointer_r0 + module procedure dictionary_assign_pointer_i + module procedure dictionary_assign_pointer_r + module procedure dictionary_assign_pointer_c + module procedure dictionary_assign_pointer_l + module procedure dictionary_assign_pointer_s + module procedure dictionary_assign_pointer_i2 + module procedure dictionary_assign_pointer_r2 + end interface assign_pointer + + public add_array + interface add_array + module procedure dictionary_add_array_i + module procedure dictionary_add_array_r + module procedure dictionary_add_array_c + module procedure dictionary_add_array_l + module procedure dictionary_add_array_s + module procedure dictionary_add_array_i2 + module procedure dictionary_add_array_r2 + module procedure dictionary_add_array_i_a + module procedure dictionary_add_array_r_a + module procedure dictionary_add_array_c_a + module procedure dictionary_add_array_l_a + module procedure dictionary_add_array_s_a + module procedure dictionary_add_array_i2_a + module procedure dictionary_add_array_r2_a + end interface add_array + + !% Remove an entry from a Dictionary + public remove_value + interface remove_value + module procedure dictionary_remove_value + end interface remove_value + + !% Write a string representation of this dictionary + public write_string + interface write_string + module procedure dictionary_write_string + end interface write_string + + !% Read into this dictionary from a string + public read_string + interface read_string + module procedure dictionary_read_string + end interface read_string + + public subset + interface subset + module procedure dictionary_subset + module procedure dictionary_subset_es + end interface subset + + public swap + interface swap + module procedure dictionary_swap + end interface swap + + public has_key + interface has_key + module procedure dictionary_has_key + end interface has_key + + public bcast + interface bcast + module procedure dictionary_bcast + end interface bcast + + public expand_string + interface expand_string + module procedure dictionary_expand_string + end interface expand_string + + public deepcopy + interface deepcopy + module procedure dictionary_deepcopy + endinterface deepcopy + + public assignment(=) + interface assignment(=) + module procedure dictionary_deepcopy_no_error +#ifdef POINTER_COMPONENT_MANUAL_COPY + module procedure dictentry_assign + module procedure dictdata_assign +#endif + end interface assignment(=) + + public :: dictionary_get_key, dictionary_get_type_and_size, dictionary__array__, lookup_entry_i + +contains + + ! **************************************************************************** + ! * + ! * DictEntry methods + ! * + ! **************************************************************************** + + subroutine dictentry_print(this, key, verbosity, file) + type(DictEntry), intent(in) :: this + character(len=*), intent(in) :: key + integer, intent(in), optional :: verbosity + type(Inoutput), intent(inout), optional :: file + integer :: i, j + + if (this%type == T_NONE) then + call print("Dict entry NONE", verbosity, file) + else if (this%type == T_INTEGER) then + write (line,'("Dict entry integer ", A,1x,I0)') trim(key), this%i + call print(line, verbosity,file) + else if (this%type == T_REAL) then + write (line, '("Dict entry real ", A,1x,F30.20)') trim(key), this%r + call print(line, verbosity,file) + else if (this%type == T_COMPLEX) then + write (line,'("Dict entry complex ", A,1x,2F30.20)') trim(key), this%c + call print(line, verbosity,file) + else if (this%type == T_LOGICAL) then + write (line, '("Dict entry logical ", A,1x,L2)') trim(key), this%l + call print(line, verbosity,file) + else if (this%type == T_CHAR) then + write (line,'("Dict entry string ", A,1x,A)') trim(key), string(this%s) + call print(line, verbosity,file) + else if (this%type == T_INTEGER_A) then + write (line, '("Dict entry integer array ",A,1x,I0)') trim(key), size(this%i_a) + call print(line, verbosity,file) + call print(this%i_a, verbosity,file) + else if (this%type == T_REAL_A) then + write (line, '("Dict entry real array ",A,1x,I0)') trim(key), size(this%r_a) + call print(line, verbosity,file) + call print(this%r_a, verbosity,file) + else if (this%type == T_COMPLEX_A) then + write (line,'("Dict entry complex array ",A,1x,I0)') trim(key), size(this%c_a) + call print(line, verbosity,file) + call print(this%c_a,verbosity,file) + else if (this%type == T_LOGICAL_A) then + write (line,'("Dict entry logical array ",A,1x,I0)') trim(key), size(this%l_a) + call print(line, verbosity,file) + do i=1,size(this%l_a) + call print(this%l_a(i),verbosity,file) + end do + else if (this%type == T_CHAR_A) then + write (line,'("Dict entry string array ",A,1x,I0)') trim(key), size(this%s_a) + call print(line, verbosity,file) + do i=1,size(this%s_a,1) + do j=1,size(this%s_a,2) + call print(this%s_a(i,j),verbosity,file) + end do + end do + else if (this%type == T_INTEGER_A2) then + call print("Dict entry integer array "//shape(this%i_a2), verbosity,file) + call print(this%i_a2, verbosity,file) + else if (this%type == T_REAL_A2) then + call print("Dict entry real array "//shape(this%r_a2), verbosity,file) + call print(this%r_a2, verbosity,file) + else if (this%type == T_DATA .or. this%type == T_DICT) then + print '("Dict entry arbitary data ",A,1x,I0)', trim(key), size(this%d%d) + call print(line, verbosity,file) + endif + end subroutine dictentry_print + + subroutine dictionary_print_keys(this, verbosity, file) + type(Dictionary), intent(in) :: this + integer, intent(in), optional :: verbosity + type(Inoutput), intent(inout), optional :: file + + integer :: i + type(extendable_str) :: es + + call initialise(es) + do i=1,this%N + if (i < this%N) then + call concat(es, string(this%keys(i))//":") + else + call concat(es, string(this%keys(i))) + endif + end do + call print(es, verbosity=verbosity, file=file) + call finalise(es) + end subroutine dictionary_print_keys + + subroutine dictionary_print(this, verbosity, file) + type(Dictionary), intent(in) :: this + integer, intent(in), optional :: verbosity + type(Inoutput), intent(inout), optional :: file + type(extendable_str) :: str + + call print("Dictionary, allocated "// size(this%entries) //" n_entries " // this%N, verbosity=verbosity,file=file) + call print('', verbosity=verbosity,file=file) + call print(write_string(this,entry_sep=quip_new_line),verbosity=verbosity,file=file) + call finalise(str) + + end subroutine dictionary_print + + + ! **************************************************************************** + ! * + ! * Dictionary methods + ! * + ! **************************************************************************** + + subroutine dictionary_initialise(this) + type(Dictionary), intent(inout) :: this + + call finalise(this) + + call extend_entries(this, n_entry_block) + this%cache_invalid = 1 + this%key_cache_invalid = 1 + end subroutine dictionary_initialise + + subroutine dictionary_finalise(this) + type(Dictionary), intent(inout) :: this + + integer :: i + + ! Don't trust ifort to dellocate properly + if (allocated(this%entries)) then + ! only finalise entries up to this%n, not size(entries): + ! entries beyond this have been used in the past if some have now been removed, + ! but they won't point to any different data since remove_entry() does a shallow copy + do i=1,this%n +! call print('finalising entry i='//i//' key='//this%keys(i)//' type='//this%entries(i)%type) + call finalise(this%entries(i)) + end do + deallocate(this%entries) + end if + if (allocated(this%keys)) then + do i=1,size(this%keys) + call finalise(this%keys(i)) + end do + deallocate(this%keys) + end if + this%N = 0 + this%cache_invalid = 1 + this%key_cache_invalid = 1 + + end subroutine dictionary_finalise + + subroutine dictentry_finalise(this) + type(DictEntry), intent(inout) :: this + + if (allocated(this%d%d)) deallocate(this%d%d) + + if (.not. this%own_data) return + + if (associated(this%i_a)) deallocate(this%i_a) + this%i_a => null() + + if (associated(this%r_a)) deallocate(this%r_a) + this%r_a => null() + + if (associated(this%c_a)) deallocate(this%c_a) + this%c_a => null() + + if (associated(this%l_a)) deallocate(this%l_a) + this%l_a => null() + + if (associated(this%s_a)) deallocate(this%s_a) + this%s_a => null() + + if (associated(this%i_a2)) deallocate(this%i_a2) + this%i_a2 => null() + + if (associated(this%r_a2)) deallocate(this%r_a2) + this%r_a2 => null() + + call finalise(this%s) + + end subroutine dictentry_finalise + + subroutine dictionary_get_key(this, i, key, error) + type(Dictionary), intent(in) :: this + integer, intent(in) :: i + character(len=C_KEY_LEN), intent(out) :: key + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if (i < 1 .or. 1 > this%n) then + RAISE_ERROR('dictionary_get_key: index '//i//' out of range/', error) + end if + key = string(this%keys(i)) + + end subroutine dictionary_get_key + + subroutine dictionary_get_type_and_size(this, key, type, thesize, thesize2, error) + type(Dictionary), intent(in) :: this + character(len=*), intent(in) :: key + integer, intent(out) :: type, thesize, thesize2(2) + integer :: entry_i + integer, intent(out), optional :: error + + INIT_ERROR(error) + + entry_i = lookup_entry_i(this, key) + + if (entry_i <= 0) then + RAISE_ERROR('dictionary_get_type_and_size: key "'//key//'" not found', error) + end if + + type = this%entries(entry_i)%type + thesize = this%entries(entry_i)%len + thesize2 = this%entries(entry_i)%len2 + + end subroutine dictionary_get_type_and_size + + ! **************************************************************************** + ! * + ! * set_value() interface + ! * + ! **************************************************************************** + + subroutine dictionary_set_value_none(this, key) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_NONE + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + + end subroutine dictionary_set_value_none + + subroutine dictionary_set_value_i(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_INTEGER + entry%i = value + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + + end subroutine dictionary_set_value_i + + subroutine dictionary_set_value_r(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_REAL + entry%r = value + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + + end subroutine dictionary_set_value_r + + subroutine dictionary_set_value_c(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + complex(dp), intent(in) :: value + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_COMPLEX + entry%c = value + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + + end subroutine dictionary_set_value_c + + subroutine dictionary_set_value_l(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + logical, intent(in) :: value + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_LOGICAL + entry%l = value + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + + end subroutine dictionary_set_value_l + + subroutine dictionary_set_value_s(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_CHAR + call initialise(entry%s) + call concat(entry%s, value) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + + end subroutine dictionary_set_value_s + + subroutine dictionary_set_value_s_es(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + type(extendable_str), intent(in) :: value + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_CHAR + call initialise(entry%s, value) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + + end subroutine dictionary_set_value_s_es + + subroutine dictionary_set_value_i_a(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value(:) + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc + + entry%type = T_INTEGER_A + entry%len = size(value) + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%i_a(size(value))) + this%cache_invalid = 1 + end if + this%entries(entry_i)%i_a = value + call finalise(entry) + + + end subroutine dictionary_set_value_i_a + + subroutine dictionary_set_value_r_a(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value(:) + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc + + entry%type = T_REAL_A + entry%len = size(value) + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%r_a(size(value))) + this%cache_invalid = 1 + end if + this%entries(entry_i)%r_a = value + call finalise(entry) + + end subroutine dictionary_set_value_r_a + + subroutine dictionary_set_value_i_a2(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value(:,:) + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc + + entry%type = T_INTEGER_A2 + entry%len = 0 + entry%len2 = shape(value) + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%i_a2(size(value,1),size(value,2))) + this%cache_invalid = 1 + end if + this%entries(entry_i)%i_a2 = value + call finalise(entry) + + end subroutine dictionary_set_value_i_a2 + + subroutine dictionary_set_value_r_a2(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value(:,:) + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc + + entry%type = T_REAL_A2 + entry%len = 0 + entry%len2 = shape(value) + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%r_a2(size(value,1),size(value,2))) + this%cache_invalid = 1 + end if + this%entries(entry_i)%r_a2 = value + call finalise(entry) + + end subroutine dictionary_set_value_r_a2 + + subroutine dictionary_set_value_c_a(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + complex(dp), intent(in) :: value(:) + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc + + entry%type = T_COMPLEX_A + entry%len = size(value) + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%c_a(size(value))) + this%cache_invalid = 1 + end if + this%entries(entry_i)%c_a = value + call finalise(entry) + + end subroutine dictionary_set_value_c_a + + subroutine dictionary_set_value_l_a(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + logical, intent(in) :: value(:) + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc + + entry%type = T_LOGICAL_A + entry%len = size(value) + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%l_a(size(value))) + this%cache_invalid = 1 + end if + this%entries(entry_i)%l_a = value + call finalise(entry) + + end subroutine dictionary_set_value_l_a + + subroutine dictionary_set_value_s_a(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value(:) + + type(DictEntry) entry + integer entry_i, i, j + logical new_key + logical do_alloc + + entry%type = T_CHAR_A + entry%len = 0 + entry%len2 = (/len(value(1)), size(value) /) + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%s_a(entry%len2(1), entry%len2(2))) + this%cache_invalid = 1 + end if + do i=1,entry%len2(1) + do j=1,entry%len2(2) + this%entries(entry_i)%s_a(i,j) = value(j)(i:i) + end do + end do + call finalise(entry) + + end subroutine dictionary_set_value_s_a + + subroutine dictionary_set_value_s_a2(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + character, intent(in) :: value(:,:) + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc + + entry%type = T_CHAR_A + entry%len = 0 + entry%len2 = shape(value) + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%s_a(entry%len2(1), entry%len2(2))) + this%cache_invalid = 1 + end if + this%entries(entry_i)%s_a = value + call finalise(entry) + + end subroutine dictionary_set_value_s_a2 + + subroutine dictionary_set_value_d(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + type(DictData), intent(in) :: value + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_DATA + entry%d = value + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_d + + + subroutine dictionary_set_value_dict(this, key, value) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + type(Dictionary), intent(in) :: value + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_DICT + allocate(entry%d%d(size(transfer(value,entry%d%d)))) + entry%d%d = transfer(value, entry%d%d) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_dict + + + ! **************************************************************************** + ! * + ! * get_value() interface + ! * + ! **************************************************************************** + + function dictionary_get_value_i(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + integer, intent(out) :: v + logical :: dictionary_get_value_i + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_i = .false. + return + endif + + if (this%entries(entry_i)%type == T_INTEGER) then + v = this%entries(entry_i)%i + dictionary_get_value_i = .true. + else + dictionary_get_value_i = .false. + endif + end function dictionary_get_value_i + + function dictionary_get_value_r(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + real(dp), intent(out) :: v + logical :: dictionary_get_value_r + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_r = .false. + return + endif + + if (this%entries(entry_i)%type == T_REAL) then + v = this%entries(entry_i)%r + dictionary_get_value_r = .true. + else + dictionary_get_value_r = .false. + endif + end function dictionary_get_value_r + + + function dictionary_get_value_c(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + complex(dp), intent(out) :: v + logical :: dictionary_get_value_c + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_c = .false. + return + endif + + if (this%entries(entry_i)%type == T_COMPLEX) then + v = this%entries(entry_i)%c + dictionary_get_value_c = .true. + else + dictionary_get_value_c = .false. + endif + end function dictionary_get_value_c + + function dictionary_get_value_l(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + logical, intent(out) :: v + logical :: dictionary_get_value_l + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_l = .false. + return + endif + + if (this%entries(entry_i)%type == T_LOGICAL) then + v = this%entries(entry_i)%l + dictionary_get_value_l = .true. + else + dictionary_get_value_l = .false. + endif + end function dictionary_get_value_l + + + function dictionary_get_value_s(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + character(len=*), intent(out) :: v + logical :: dictionary_get_value_s + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_s = .false. + return + endif + + v="" ! fill with blanks first + if (this%entries(entry_i)%type == T_CHAR) then + v(1:this%entries(entry_i)%s%len) = string(this%entries(entry_i)%s) + dictionary_get_value_s = .true. + else + dictionary_get_value_s = .false. + endif + end function dictionary_get_value_s + + function dictionary_get_value_s_es(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + type(extendable_str), intent(out) :: v + logical :: dictionary_get_value_s_es + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_s_es = .false. + return + endif + + if (this%entries(entry_i)%type == T_CHAR) then + call initialise(v, this%entries(entry_i)%s) + dictionary_get_value_s_es = .true. + else + dictionary_get_value_s_es = .false. + endif + + end function dictionary_get_value_s_es + + + function dictionary_get_value_i_a(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + integer, intent(out) :: v(:) + logical :: dictionary_get_value_i_a + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_i_a = .false. + return + endif + + if (this%entries(entry_i)%type == T_INTEGER_A) then + if (size(v) >= size(this%entries(entry_i)%i_a)) then + v(1:size(this%entries(entry_i)%i_a)) = this%entries(entry_i)%i_a + dictionary_get_value_i_a = .true. + else + dictionary_get_value_i_a = .false. + endif + else + dictionary_get_value_i_a = .false. + endif + end function dictionary_get_value_i_a + + function dictionary_get_value_r_a(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + real(dp), intent(out) :: v(:) + logical :: dictionary_get_value_r_a + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_r_a = .false. + return + endif + + if (this%entries(entry_i)%type == T_REAL_A) then + if (size(v) >= size(this%entries(entry_i)%r_a)) then + v(1:size(this%entries(entry_i)%r_a)) = this%entries(entry_i)%r_a + dictionary_get_value_r_a = .true. + else + dictionary_get_value_r_a = .false. + endif + else + dictionary_get_value_r_a = .false. + endif + end function dictionary_get_value_r_a + + function dictionary_get_value_i_a2(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + integer, intent(out) :: v(:,:) + logical :: dictionary_get_value_i_a2 + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_i_a2 = .false. + return + endif + + if (this%entries(entry_i)%type == T_INTEGER_A2) then + if (size(v,1) >= size(this%entries(entry_i)%i_a2,1) .and. & + size(v,2) >= size(this%entries(entry_i)%i_a2,2)) then + v(1:size(this%entries(entry_i)%i_a2,1),1:size(this%entries(entry_i)%i_a2,2)) = this%entries(entry_i)%i_a2 + dictionary_get_value_i_a2 = .true. + else + dictionary_get_value_i_a2 = .false. + endif + else + dictionary_get_value_i_a2 = .false. + endif + end function dictionary_get_value_i_a2 + + function dictionary_get_value_r_a2(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + real(dp), intent(out) :: v(:,:) + logical :: dictionary_get_value_r_a2 + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_r_a2 = .false. + return + endif + + if (this%entries(entry_i)%type == T_REAL_A2) then + if (size(v,1) >= size(this%entries(entry_i)%r_a2,1) .and. & + size(v,2) >= size(this%entries(entry_i)%r_a2,2) ) then + v(1:size(this%entries(entry_i)%r_a2,1),1:size(this%entries(entry_i)%r_a2,2)) = this%entries(entry_i)%r_a2 + dictionary_get_value_r_a2 = .true. + else + dictionary_get_value_r_a2 = .false. + endif + else + dictionary_get_value_r_a2 = .false. + endif + end function dictionary_get_value_r_a2 + + + function dictionary_get_value_c_a(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + complex(dp), intent(out) :: v(:) + logical :: dictionary_get_value_c_a + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_c_a = .false. + return + endif + + if (this%entries(entry_i)%type == T_COMPLEX_A) then + if (size(v) >= size(this%entries(entry_i)%c_a)) then + v(1:size(this%entries(entry_i)%c_a)) = this%entries(entry_i)%c_a + dictionary_get_value_c_a = .true. + else + dictionary_get_value_c_a = .false. + endif + else + dictionary_get_value_c_a = .false. + endif + end function dictionary_get_value_c_a + + function dictionary_get_value_l_a(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + logical, intent(out) :: v(:) + logical :: dictionary_get_value_l_a + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_l_a = .false. + return + endif + + if (this%entries(entry_i)%type == T_LOGICAL_A) then + if (size(v) >= size(this%entries(entry_i)%l_a)) then + v(1:size(this%entries(entry_i)%l_a)) = this%entries(entry_i)%l_a + dictionary_get_value_l_a = .true. + else + dictionary_get_value_l_a = .false. + endif + else + dictionary_get_value_l_a = .false. + endif + end function dictionary_get_value_l_a + + + function dictionary_get_value_s_a(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + character(len=*), intent(out) :: v(:) + logical :: dictionary_get_value_s_a + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i, j, k + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_s_a = .false. + return + endif + + if (this%entries(entry_i)%type == T_CHAR_A) then + if (len(v(1)) >= size(this%entries(entry_i)%s_a,1) .and. size(v) >= size(this%entries(entry_i)%s_a,2)) then + do k=1,this%entries(entry_i)%len2(1) + do j=1,this%entries(entry_i)%len2(2) + v(j)(k:k) = this%entries(entry_i)%s_a(k,j) + end do + end do + dictionary_get_value_s_a = .true. + else + dictionary_get_value_s_a = .false. + endif + else + dictionary_get_value_s_a = .false. + endif + end function dictionary_get_value_s_a + + function dictionary_get_value_s_a2(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + character, intent(out) :: v(:,:) + logical :: dictionary_get_value_s_a2 + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_s_a2 = .false. + return + endif + + if (this%entries(entry_i)%type == T_CHAR_A) then + if (size(v,1) >= size(this%entries(entry_i)%s_a,1) .and. size(v,2) >= size(this%entries(entry_i)%s_a,2)) then + v(1:size(this%entries(entry_i)%s_a,1),1:size(this%entries(entry_i)%s_a,2)) = this%entries(entry_i)%s_a + dictionary_get_value_s_a2 = .true. + else + dictionary_get_value_s_a2 = .false. + endif + else + dictionary_get_value_s_a2 = .false. + endif + + end function dictionary_get_value_s_a2 + + + function dictionary_get_value_d(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + type(DictData), intent(out) :: v + logical :: dictionary_get_value_d + logical, optional :: case_sensitive + integer, optional :: i + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_d = .false. + return + endif + + if (this%entries(entry_i)%type == T_DATA) then + v = this%entries(entry_i)%d + dictionary_get_value_d = .true. + else + dictionary_get_value_d = .false. + endif + end function dictionary_get_value_d + + function dictionary_get_value_dict(this, key, v, case_sensitive, i) + type(Dictionary), intent(in) :: this + character(len=*) key + type(Dictionary), intent(out) :: v + logical :: dictionary_get_value_dict + logical, optional :: case_sensitive + integer, optional :: i + + type(dictionary) :: tmp_dict + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + if (present(i)) i = entry_i + + if (entry_i <= 0) then + dictionary_get_value_dict = .false. + return + endif + + if (this%entries(entry_i)%type == T_DICT) then + ! bug: overloaded assignment operator is invoked + call initialise(tmp_dict) + tmp_dict = transfer(this%entries(entry_i)%d%d, v) + v = tmp_dict + call finalise(tmp_dict) + dictionary_get_value_dict = .true. + else + dictionary_get_value_dict = .false. + endif + end function dictionary_get_value_dict + + + + ! **************************************************************************** + ! * + ! * assign_pointer() interface + ! * + ! **************************************************************************** + + function dictionary_assign_pointer_r0(this, key, v, case_sensitive) + type(Dictionary), intent(in), target :: this + character(len=*) key + real(dp), intent(out), pointer :: v + logical :: dictionary_assign_pointer_r0 + logical, optional :: case_sensitive + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + + if (entry_i <= 0) then + dictionary_assign_pointer_r0 = .false. + return + endif + + if (this%entries(entry_i)%type == T_REAL) then + v => this%entries(entry_i)%r + dictionary_assign_pointer_r0 = .true. + else + dictionary_assign_pointer_r0 = .false. + endif + end function dictionary_assign_pointer_r0 + + function dictionary_assign_pointer_i(this, key, v, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) key + integer, intent(out), pointer, dimension(:) :: v + logical :: dictionary_assign_pointer_i + logical, optional :: case_sensitive + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + + if (entry_i <= 0) then + dictionary_assign_pointer_i = .false. + return + endif + + if (this%entries(entry_i)%type == T_INTEGER_A) then + v => this%entries(entry_i)%i_a + dictionary_assign_pointer_i = .true. + else + dictionary_assign_pointer_i = .false. + endif + end function dictionary_assign_pointer_i + + function dictionary_assign_pointer_r(this, key, v, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) key + real(dp), intent(out), pointer, dimension(:) :: v + logical :: dictionary_assign_pointer_r + logical, optional :: case_sensitive + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + + if (entry_i <= 0) then + dictionary_assign_pointer_r = .false. + return + endif + + if (this%entries(entry_i)%type == T_REAL_A) then + v => this%entries(entry_i)%r_a + dictionary_assign_pointer_r = .true. + else + dictionary_assign_pointer_r = .false. + endif + end function dictionary_assign_pointer_r + + function dictionary_assign_pointer_c(this, key, v, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) key + complex(dp), intent(out), pointer, dimension(:) :: v + logical :: dictionary_assign_pointer_c + logical, optional :: case_sensitive + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + + if (entry_i <= 0) then + dictionary_assign_pointer_c = .false. + return + endif + + if (this%entries(entry_i)%type == T_COMPLEX_A) then + v => this%entries(entry_i)%c_a + dictionary_assign_pointer_c = .true. + else + dictionary_assign_pointer_c = .false. + endif + end function dictionary_assign_pointer_c + + function dictionary_assign_pointer_l(this, key, v, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) key + logical, intent(out), pointer, dimension(:) :: v + logical :: dictionary_assign_pointer_l + logical, optional :: case_sensitive + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + + if (entry_i <= 0) then + dictionary_assign_pointer_l = .false. + return + endif + + if (this%entries(entry_i)%type == T_LOGICAL_A) then + v => this%entries(entry_i)%l_a + dictionary_assign_pointer_l = .true. + else + dictionary_assign_pointer_l = .false. + endif + end function dictionary_assign_pointer_l + + function dictionary_assign_pointer_s(this, key, v, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) key + character(1), intent(out), pointer, dimension(:,:) :: v + logical :: dictionary_assign_pointer_s + logical, optional :: case_sensitive + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + + if (entry_i <= 0) then + dictionary_assign_pointer_s = .false. + return + endif + + if (this%entries(entry_i)%type == T_CHAR_A) then + v => this%entries(entry_i)%s_a + dictionary_assign_pointer_s = .true. + else + dictionary_assign_pointer_s = .false. + endif + end function dictionary_assign_pointer_s + + function dictionary_assign_pointer_i2(this, key, v, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) key + integer, intent(out), pointer, dimension(:,:) :: v + logical :: dictionary_assign_pointer_i2 + logical, optional :: case_sensitive + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + + if (entry_i <= 0) then + dictionary_assign_pointer_i2 = .false. + return + endif + + if (this%entries(entry_i)%type == T_INTEGER_A2) then + v => this%entries(entry_i)%i_a2 + dictionary_assign_pointer_i2 = .true. + else + dictionary_assign_pointer_i2 = .false. + endif + end function dictionary_assign_pointer_i2 + + function dictionary_assign_pointer_r2(this, key, v, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) key + real(dp), intent(out), pointer, dimension(:,:) :: v + logical :: dictionary_assign_pointer_r2 + logical, optional :: case_sensitive + + integer entry_i + + entry_i = lookup_entry_i(this, key, case_sensitive) + + if (entry_i <= 0) then + dictionary_assign_pointer_r2 = .false. + return + endif + + if (this%entries(entry_i)%type == T_REAL_A2) then + v => this%entries(entry_i)%r_a2 + dictionary_assign_pointer_r2 = .true. + else + dictionary_assign_pointer_r2 = .false. + endif + end function dictionary_assign_pointer_r2 + + + ! **************************************************************************** + ! * + ! * set_value_pointer() interface + ! * + ! **************************************************************************** + + subroutine dictionary_set_value_pointer_i(this, key, ptr) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in), target :: ptr(:) + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_INTEGER_A + entry%own_data = .false. ! force any possible previous entry with same key to be finalised + entry%len = size(ptr) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + this%entries(entry_i)%i_a => ptr + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_pointer_i + + subroutine dictionary_set_value_pointer_r(this, key, ptr) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in), target :: ptr(:) + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_REAL_A + entry%own_data = .false. ! force any possible previous entry with same key to be finalised + entry%len = size(ptr) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + this%entries(entry_i)%r_a => ptr + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_pointer_r + + subroutine dictionary_set_value_pointer_c(this, key, ptr) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + complex(dp), intent(in), target :: ptr(:) + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_COMPLEX_A + entry%own_data = .false. ! force any possible previous entry with same key to be finalised + entry%len = size(ptr) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + this%entries(entry_i)%c_a => ptr + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_pointer_c + + subroutine dictionary_set_value_pointer_l(this, key, ptr) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + logical, intent(in), target :: ptr(:) + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_LOGICAL_A + entry%own_data = .false. ! force any possible previous entry with same key to be finalised + entry%len = size(ptr) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + this%entries(entry_i)%l_a => ptr + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_pointer_l + + subroutine dictionary_set_value_pointer_s(this, key, ptr) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + character(1), intent(in), target :: ptr(:,:) + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_CHAR_A + entry%own_data = .false. ! force any possible previous entry with same key to be finalised + entry%len = 0 + entry%len2 = size(ptr) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + this%entries(entry_i)%s_a => ptr + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_pointer_s + + subroutine dictionary_set_value_pointer_i2(this, key, ptr) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in), target :: ptr(:,:) + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_INTEGER_A2 + entry%own_data = .false. ! force any possible previous entry with same key to be finalised + entry%len = 0 + entry%len2 = shape(ptr) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + this%entries(entry_i)%i_a2 => ptr + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_pointer_i2 + + subroutine dictionary_set_value_pointer_r2(this, key, ptr) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in), target :: ptr(:,:) + + type(DictEntry) entry + integer entry_i + logical new_key + + entry%type = T_REAL_A2 + entry%own_data = .false. ! force any possible previous entry with same key to be finalised + entry%len = 0 + entry%len2 = shape(ptr) + entry_i = add_entry(this, key, entry, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + this%entries(entry_i)%r_a2 => ptr + call finalise(entry) + this%cache_invalid = 1 + + end subroutine dictionary_set_value_pointer_r2 + + + ! **************************************************************************** + ! * + ! * add_array() interface + ! * + ! **************************************************************************** + + subroutine dictionary_add_array_i(this, key, value, len, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value + integer, intent(in) :: len + integer, pointer, optional, intent(out) :: ptr(:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_INTEGER_A + entry%len = len + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%i_a(len)) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%i_a(:) = value + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%i_a + + end subroutine dictionary_add_array_i + + subroutine dictionary_add_array_r(this, key, value, len, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value + integer, intent(in) :: len + real(dp), intent(out), pointer, optional :: ptr(:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_REAL_A + entry%len = len + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%r_a(len)) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%r_a(:) = value + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%r_a + + end subroutine dictionary_add_array_r + + subroutine dictionary_add_array_c(this, key, value, len, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + complex(dp), intent(in) :: value + integer, intent(in) :: len + complex(dp), pointer, optional, intent(out) :: ptr(:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_COMPLEX_A + entry%len = len + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%c_a(len)) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%c_a(:) = value + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%c_a + + end subroutine dictionary_add_array_c + + subroutine dictionary_add_array_l(this, key, value, len, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + logical, intent(in) :: value + integer, intent(in) :: len + logical, pointer, optional, intent(out) :: ptr(:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_LOGICAL_A + entry%len = len + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%l_a(len)) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%l_a(:) = value + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%l_a + + end subroutine dictionary_add_array_l + + subroutine dictionary_add_array_s(this, key, value, len2, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + character(1), intent(in) :: value + integer, intent(in) :: len2(2) + character(1), pointer, optional, intent(out) :: ptr(:,:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_CHAR_A + entry%len = 0 + entry%len2 = len2 + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%s_a(len2(1),len2(2))) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%s_a(:,:) = value + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%s_a + + end subroutine dictionary_add_array_s + + subroutine dictionary_add_array_i2(this, key, value, len2, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value + integer, intent(in) :: len2(2) + integer, pointer, optional, intent(out) :: ptr(:,:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_INTEGER_A2 + entry%len = 0 + entry%len2 = len2 + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%i_a2(len2(1),len2(2))) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%i_a2(:,:) = value + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%i_a2 + + end subroutine dictionary_add_array_i2 + + subroutine dictionary_add_array_r2(this, key, value, len2, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value + integer, intent(in) :: len2(2) + real(dp), intent(out), pointer, optional :: ptr(:,:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_REAL_A2 + entry%len = 0 + entry%len2 = len2 + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%r_a2(len2(1),len2(2))) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%r_a2(:,:) = value + call finalise(entry) + + if (present(ptr)) ptr => this%entries(entry_i)%r_a2 + + end subroutine dictionary_add_array_r2 + + + subroutine dictionary_add_array_i_a(this, key, value, len, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value(:) + integer, intent(in) :: len + integer, pointer, optional, intent(out) :: ptr(:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_INTEGER_A + entry%len = len + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%i_a(len)) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%i_a(:) = value + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%i_a + + end subroutine dictionary_add_array_i_a + + subroutine dictionary_add_array_r_a(this, key, value, len, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value(:) + integer, intent(in) :: len + real(dp), intent(out), pointer, optional :: ptr(:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_REAL_A + entry%len = len + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%r_a(len)) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%r_a(:) = value(:) + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%r_a + + end subroutine dictionary_add_array_r_a + + subroutine dictionary_add_array_c_a(this, key, value, len, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + complex(dp), intent(in) :: value(:) + integer, intent(in) :: len + complex(dp), pointer, optional, intent(out) :: ptr(:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_COMPLEX_A + entry%len = len + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%c_a(len)) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%c_a(:) = value(:) + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%c_a + + end subroutine dictionary_add_array_c_a + + subroutine dictionary_add_array_l_a(this, key, value, len, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + logical, intent(in) :: value(:) + integer, intent(in) :: len + logical, pointer, optional, intent(out) :: ptr(:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_LOGICAL_A + entry%len = len + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%l_a(len)) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%l_a(:) = value(:) + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%l_a + + end subroutine dictionary_add_array_l_a + + subroutine dictionary_add_array_s_a(this, key, value, len2, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + character(1), intent(in) :: value(:,:) + integer, intent(in) :: len2(2) + character(1), pointer, optional, intent(out) :: ptr(:,:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_CHAR_A + entry%len = 0 + entry%len2 = len2 + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%s_a(len2(1),len2(2))) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%s_a(:,:) = value(:,:) + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%s_a + + end subroutine dictionary_add_array_s_a + + subroutine dictionary_add_array_i2_a(this, key, value, len2, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer, intent(in) :: value(:,:) + integer, intent(in) :: len2(2) + integer, pointer, optional, intent(out) :: ptr(:,:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_INTEGER_A2 + entry%len = 0 + entry%len2 = len2 + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%i_a2(len2(1),len2(2))) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%i_a2(:,:) = value(:,:) + call finalise(entry) + if (present(ptr)) ptr => this%entries(entry_i)%i_a2 + + end subroutine dictionary_add_array_i2_a + + subroutine dictionary_add_array_r2_a(this, key, value, len2, ptr, overwrite) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + real(dp), intent(in) :: value(:,:) + integer, intent(in) :: len2(2) + real(dp), intent(out), pointer, optional :: ptr(:,:) + logical, optional, intent(in) :: overwrite + + type(DictEntry) entry + integer entry_i + logical new_key + logical do_alloc, do_overwrite + + do_overwrite = optional_default(.false., overwrite) + entry%type = T_REAL_A2 + entry%len = 0 + entry%len2 = len2 + entry_i = add_entry(this, key, entry, do_alloc, new_key=new_key) + if (new_key) this%key_cache_invalid = 1 + if (do_alloc) then + allocate(this%entries(entry_i)%r_a2(len2(1),len2(2))) + this%cache_invalid = 1 + end if + if (do_alloc .or. do_overwrite) this%entries(entry_i)%r_a2(:,:) = value(:,:) + call finalise(entry) + + if (present(ptr)) ptr => this%entries(entry_i)%r_a2 + + end subroutine dictionary_add_array_r2_a + + ! **************************************************************************** + ! * + ! * Miscellaneous routines + ! * + ! **************************************************************************** + + subroutine dictionary_remove_value(this, key) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + integer entry_i + + entry_i = lookup_entry_i(this, key) + if (entry_i > 0) then + call remove_entry(this, entry_i) + else + call print("WARNING: dictionary_remove_value() could not find entry `"//key//"' in dictionary", PRINT_ANALYSIS) + end if + + end subroutine dictionary_remove_value + + subroutine dictionary_read_string(this, str, append, error) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: str + logical, optional, intent(in) :: append !% If true, append to dictionary (default false) + integer, intent(out), optional :: error + + logical :: do_append + character(len=STRING_LENGTH) :: field + integer equal_pos + character(len=STRING_LENGTH), dimension(dict_n_fields) :: final_fields + character(len=C_KEY_LEN) :: key + character(len=STRING_LENGTH) :: value + integer :: i, num_pairs + + INIT_ERROR(error); + do_append = optional_default(.false., append) + + if (.not. do_append) then + call initialise(this) + end if + + call split_string(str, ' ,', '""'//"''"//'{}', final_fields, num_pairs, matching=.true.) + + ! Set the new entries + do i=1,num_pairs + field = final_fields(i) + equal_pos = index(trim(field),'=') + if (equal_pos == 0) then + key=field + value='' + else if (equal_pos == 1) then + RAISE_ERROR("dictionary_read_string: Malformed field '"//trim(field)//"'", error) + else + key = field(1:equal_pos-1) + value = field(equal_pos+1:len(trim(field))) + endif + call print("dictionary_read_string: key='"//trim(key)//"' value='"//trim(value)//"'", PRINT_NERD) + + if (.not. dictionary_parse_value(this,key,value)) then + RAISE_ERROR('dictionary_read_string: error parsing '//trim(key)//'='//trim(value), error) + end if + + end do + + end subroutine dictionary_read_string + + + !% Parse a string corresponding to a dictionary value and + !% attempt to work out what type it should be, then set it + function dictionary_parse_value(this, key, strvalue, char_a_sep) result(status) + type(Dictionary), intent(inout) :: this + character(*), intent(in) :: key + character(*), intent(in) :: strvalue + character(1), optional, intent(in) :: char_a_sep + logical :: status + + character(len=STRING_LENGTH), dimension(dict_n_fields) :: fields + character(len=len(strvalue)) :: datastr, shapestr, myvalue + integer :: num_fields, i, j + real(dp) :: r + logical :: l, all_int, all_real, all_logical + type(DictData) :: data + integer, allocatable, dimension(:) :: i_a + real(dp), allocatable, dimension(:) :: r_a + logical, allocatable, dimension(:) :: l_a + integer, allocatable, dimension(:,:) :: i_a2 + real(dp), allocatable, dimension(:,:) :: r_a2 + character(1) :: my_char_a_sep + logical got_2d + integer shape_2d(2) + integer :: parse_status + integer :: error + + my_char_a_sep = optional_default(',',char_a_sep) + + ! First, let's check if value is arbitrary data, represented + ! as 'DATA"i1 i2 i3 i4"' with i1,i2, etc. integers + if (strvalue(1:4) == 'DATA') then + datastr = strvalue(5:len(trim(strvalue))) + call parse_string(datastr, ' ',fields, num_fields) + + allocate(data%d(num_fields)) + do j=1,num_fields + data%d(j) = string_to_int(fields(j),error) + if (error /= ERROR_NONE) then + CLEAR_ERROR(error) + status = .false. + return + end if + end do + + call set_value(this,key,data) + deallocate(data%d) + status = .true. + return + end if + + ! 2D arrays are represented with shape in ()s at beginning of value string + got_2d = .false. + if (strvalue(1:1) == '(') then + got_2d = .true. + shapestr = strvalue(2:index(strvalue,')')-1) + read (shapestr, *) shape_2d + myvalue = strvalue(index(strvalue,')')+1:len_trim(strvalue)) + else + myvalue = strvalue + end if + + ! Otherwise, start by splitting value into fields + call parse_string(myvalue, ' ', fields, num_fields, error=parse_status) + + if (parse_status /= 0) then + ! parsing failed, treat as string + call set_value(this,key,myvalue) + status = .true. + return + else if (num_fields == 0) then + ! Nothing there, so type is T_NONE + call set_value(this, key) + status = .true. + return + + else if (num_fields == 1) then + + ! Scalar data, try to guess type + + do i=1, len_trim(fields(1)) + if (fields(1)(i:i) == '/') then + ! slash is technically a delimiter, but we don't like that, so we'll call it a string manually (otherswise string_to_real will be confused) + call set_value(this,key,fields(1)) + status = .true. + return + endif + end do + + ! Is it an integer? + i = string_to_int(fields(1),error) + if (error == ERROR_NONE) then + call set_value(this, key, i) + status = .true. + return + end if + CLEAR_ERROR(error) + + ! Is it a logical? + l = string_to_logical(fields(1),error) + if (error == ERROR_NONE) then + call set_value(this, key, l) + status = .true. + return + endif + CLEAR_ERROR(error) + + ! How about a real? + r = string_to_real(fields(1),error) + if (error == ERROR_NONE) then + call set_value(this, key, r) + status = .true. + return + end if + CLEAR_ERROR(error) + + ! Add complex scalar here... + + ! Does it contain one or more array separator characters? + if (scan(fields(1),my_char_a_sep) /= 0) then + call parse_string(myvalue, my_char_a_sep, fields, num_fields) + call set_value(this,key,fields(1:num_fields)) + status = .true. + return + else + ! All else has failed, treat it as a single string + call set_value(this,key,fields(1)) + status = .true. + return + end if + + else + ! Array data, again have to guess type + + allocate(i_a(num_fields),r_a(num_fields),l_a(num_fields)) + + ! Are all fields integers? + all_int = .true. + do j=1,num_fields + i_a(j) = string_to_int(fields(j),error) + + if (error /= ERROR_NONE) then + CLEAR_ERROR(error) + all_int = .false. + exit ! Found something that's not an integer + end if + end do + + if (all_int) then + if (got_2d) then + allocate(i_a2(shape_2d(1), shape_2d(2))) + i_a2 = reshape(i_a, shape_2d) + call set_value(this,key,i_a2) + else + call set_value(this,key,i_a) + end if + status = .true. + deallocate(i_a,r_a,l_a) + if (allocated(i_a2)) deallocate(i_a2) + return + end if + + ! Are all fields logicals? + all_logical = .true. + do j=1,num_fields + l_a(j) = string_to_logical(fields(j),error) + if (error /= ERROR_NONE) then + CLEAR_ERROR(error) + all_logical = .false. + exit ! Found something that's not a logical + end if + end do + + if (all_logical) then + call set_value(this,key,l_a) + status = .true. + deallocate(i_a,r_a,l_a) + return + end if + + ! Are all fields real numbers? + all_real = .true. + do j=1,num_fields + r_a(j) = string_to_real(fields(j),error) + + if (error /= ERROR_NONE) then + CLEAR_ERROR(error) + all_real = .false. + exit + end if + end do + + if (all_real) then + if (got_2d) then + allocate(r_a2(shape_2d(1), shape_2d(2))) + r_a2 = reshape(r_a, shape_2d) + call set_value(this,key,r_a2) + else + call set_value(this,key,r_a) + end if + status = .true. + deallocate(i_a,r_a,l_a) + if (allocated(r_a2)) deallocate(r_a2) + return + end if + + ! Add complex array here... + + ! We're left with strings. Does it contain array seperator? + if (scan(myvalue,my_char_a_sep) /= 0) then + call parse_string(myvalue, my_char_a_sep, fields, num_fields) + call set_value(this,key,fields(1:num_fields)) + status = .true. + return + else + ! Fall back option: treat entire myvalue as single string + call set_value(this,key,myvalue) + status =.true. + return + end if + end if + + end function dictionary_parse_value + + function dictionary_write_string(this, real_format, entry_sep, char_a_sep, quote_char, error) + type(Dictionary), intent(in) :: this + character(len=*), optional, intent(in) :: real_format !% Output format for reals, default is 'f9.3' + character(1), optional, intent(in) :: entry_sep !% Entry seperator, default is single space + character(1), optional, intent(in) :: char_a_sep !% Output separator for character arrays, default is ',' + character(1), optional, intent(in) :: quote_char !% Character to use to quote output fields containing whitespace, default is '"' + type(extendable_str) :: str + character(len=STRING_LENGTH) :: dictionary_write_string + integer, intent(out), optional :: error + + integer :: i, j, k + character(1) :: my_char_a_sep, my_entry_sep, my_quote_char + character(255) :: my_real_format, tmp_string + + INIT_ERROR(error) + call initialise(str) + + my_real_format = optional_default('f9.3',real_format) + my_char_a_sep = optional_default(',',char_a_sep) + my_entry_sep = optional_default(' ',entry_sep) + my_quote_char = optional_default('"', quote_char) + + do i=1,this%N + + if (i == 1) then + call concat(str, string(this%keys(i))) + else + call concat(str, my_entry_sep//string(this%keys(i))) + end if + + if (this%entries(i)%type /= T_NONE) call concat(str, '=') + + select case(this%entries(i)%type) + + case(T_NONE) + ! no value to write + + case(T_INTEGER) + call concat(str, ''//this%entries(i)%i) + + case(T_REAL) + write (line,'('//my_real_format//')') this%entries(i)%r + call concat(str, trim(adjustl(line))) + + case(T_COMPLEX) + call concat(str, ''//this%entries(i)%c) + + case(T_LOGICAL) + call concat(str, ''//this%entries(i)%l) + + case(T_CHAR) + if (index(string(this%entries(i)%s), ' ') == 0) then + call concat(str, string(this%entries(i)%s)) + else + call concat(str, my_quote_char//string(this%entries(i)%s)//my_quote_char) + end if + + case(T_INTEGER_A) + call concat(str, my_quote_char//this%entries(i)%i_a//my_quote_char) + + case(T_REAL_A) + write (line, '('//size(this%entries(i)%r_a)//trim(my_real_format)//')') this%entries(i)%r_a + call concat(str, my_quote_char//trim(adjustl(line))//my_quote_char) + + case(T_COMPLEX_A) + call concat(str, my_quote_char//this%entries(i)%c_a//my_quote_char) + + case(T_LOGICAL_A) + call concat(str, my_quote_char//this%entries(i)%l_a//my_quote_char) + + case(T_CHAR_A) + call concat(str,my_quote_char) + do j=1,size(this%entries(i)%s_a,2) + tmp_string = '' + do k=1,size(this%entries(i)%s_a,1) + tmp_string(k:k) = this%entries(i)%s_a(k,j) + end do + call concat(str, trim(tmp_string)//my_char_a_sep) + end do + call concat(str,my_quote_char) + + case(T_INTEGER_A2) + call concat(str, my_quote_char//'('//shape(this%entries(i)%i_a2)//') ') + call concat(str, ' '//reshape(this%entries(i)%i_a2,(/size(this%entries(i)%i_a2)/))//my_quote_char) + + case(T_REAL_A2) + call concat(str, my_quote_char//'('//shape(this%entries(i)%r_a2)//') ') + call concat(str, reshape(this%entries(i)%r_a2,(/size(this%entries(i)%r_a2)/))//my_quote_char) + + case(T_DATA) + call concat(str, 'DATA'//my_quote_char//this%entries(i)%d%d//my_quote_char) + + case(T_DICT) + call concat(str, 'DATA'//my_quote_char//this%entries(i)%d%d//my_quote_char) + end select + end do + + if (str%len > len(dictionary_write_string)) then + RAISE_ERROR('dictionary_write_string: string too long (' // str%len // ' > ' // len(dictionary_write_string) // ')', error) + end if + + dictionary_write_string = ''//str + call finalise(str) + + end function dictionary_write_string + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !% OMIT + subroutine remove_entry(this, entry_i, error) + type(Dictionary), intent(inout) :: this + integer, intent(in) :: entry_i + integer, intent(out), optional :: error + integer i + + INIT_ERROR(error) + + if (entry_i <= 0 .or. entry_i > this%N) then + RAISE_ERROR("remove_entry: Called remove_entry with invalid entry number", error) + end if + + if (entry_i < this%N) then + do i=entry_i,this%n-1 + call dictionary_swap(this, string(this%keys(i)), string(this%keys(i+1))) + end do + endif + + call finalise(this%keys(this%n)) + call finalise(this%entries(this%n)) + + this%N = this%N - 1 + this%cache_invalid = 1 + this%key_cache_invalid = 1 + + end subroutine remove_entry + + !% OMIT + function add_entry(this, key, entry, array_alloc, new_key) result(entry_i) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key + type(DictEntry), intent(in) :: entry + logical, intent(out), optional :: array_alloc + logical, intent(out), optional :: new_key + + integer entry_i + + ! must test separately because size(this%entries) is undefined if allocated(this%entries) is false + if (.not. allocated(this%entries)) call extend_entries(this, n_entry_block) + if (this%N >= size(this%entries)) call extend_entries(this, n_entry_block) + + entry_i = lookup_entry_i(this, key) + if (present(new_key)) new_key = entry_i == -1 + if (present(array_alloc)) array_alloc = .true. + + if (entry_i > 0) then + ! we only free entry if new type/size/shape is incompatible with existing entry + ! or if new entry will not be allocated by us (i.e. entry%own_data == .false.) + if (.not. entry%own_data .or. & + this%entries(entry_i)%type == T_DATA .or. & + this%entries(entry_i)%type == T_DICT .or. & + this%entries(entry_i)%type /= entry%type .or. & + this%entries(entry_i)%len /= entry%len .or. & + any(this%entries(entry_i)%len2 /= entry%len2)) then + call finalise(this%entries(entry_i)) + this%entries(entry_i) = entry + else + if (present(array_alloc)) array_alloc = .false. + ! we're keeping allocation, so we overwrite only scalar components of entry + this%entries(entry_i)%type = entry%type + this%entries(entry_i)%len = entry%len + this%entries(entry_i)%len2 = entry%len2 + this%entries(entry_i)%i = entry%i + this%entries(entry_i)%r = entry%r + this%entries(entry_i)%c = entry%c + this%entries(entry_i)%l = entry%l + this%entries(entry_i)%s = entry%s + end if + else + this%N = this%N + 1 + entry_i = this%N + call initialise(this%keys(entry_i)) + call concat(this%keys(entry_i), key) + this%entries(entry_i) = entry + endif + end function add_entry + + + !% OMIT + subroutine extend_entries(this, n) + type(Dictionary), intent(inout) :: this + integer, intent(in) :: n + + type(DictEntry), allocatable :: t_entries(:) + type(Extendable_str), allocatable :: t_keys(:) + integer old_size +#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY + integer :: i +#endif + + + if (allocated(this%entries)) then + allocate(t_entries(size(this%entries))) + allocate(t_keys(size(this%entries))) +#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY + allocate(t_keys(size(this%keys))) + do i=1,size(this%entries) + t_entries(i) = this%entries(i) + t_keys(i) = this%keys(i) + end do +#else + t_entries = this%entries + t_keys = this%keys +#endif + + old_size = size(this%entries) + + deallocate(this%entries) + deallocate(this%keys) + + allocate(this%entries(old_size + n)) + allocate(this%keys(old_size + n)) + +#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY + do i=1, size(t_entries) + this%entries(i) = t_entries(i) + this%keys(i) = t_keys(i) + end do +#else + this%entries(1:this%N) = t_entries(1:this%N) + this%keys(1:this%N) = t_keys(1:this%N) +#endif + + if (allocated(t_entries)) deallocate(t_entries) + deallocate (t_keys) + else + allocate(this%entries(n)) + allocate(this%keys(n)) + this%N = 0 + endif + + end subroutine extend_entries + + !% OMIT + function lookup_entry_i(this, key, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) :: key + logical, optional :: case_sensitive + integer :: lookup_entry_i + + logical :: do_case_sensitive + integer i + + do_case_sensitive = optional_default(.false., case_sensitive) + + lookup_entry_i = -1 + do i=1, this%N + if(do_case_sensitive) then + if (string(this%keys(i)) == trim(key)) then + lookup_entry_i = i + return + endif + else + if (lower_case(string(this%keys(i))) == trim(lower_case(key))) then + lookup_entry_i = i + return + endif + end if + end do + end function lookup_entry_i + + !% Return true if 'key' is in Dictionary or false if not + function dictionary_has_key(this, key, case_sensitive) + type(Dictionary), intent(in) :: this + character(len=*) :: key + logical :: dictionary_has_key + logical, optional :: case_sensitive + + dictionary_has_key = lookup_entry_i(this, key, case_sensitive) /= -1 + + end function dictionary_has_key + + subroutine dictionary_subset(this, keys, out, case_sensitive, out_no_initialise, error) + type(Dictionary), intent(in) :: this + character(len=*), dimension(:) :: keys + type(Dictionary), intent(inout) :: out + logical, intent(in), optional :: case_sensitive, out_no_initialise + integer, intent(out), optional :: error + + type(extendable_str), dimension(:), allocatable :: tmp_keys + integer i + + INIT_ERROR(error) + + allocate(tmp_keys(size(keys))) + do i=1,size(keys) + call initialise(tmp_keys(i)) + call concat(tmp_keys(i), keys(i)) + end do + + call dictionary_subset_es(this, tmp_keys, out, case_sensitive, out_no_initialise, error) + PASS_ERROR(error) + + do i=1,size(tmp_keys) + call finalise(tmp_keys(i)) + end do + deallocate(tmp_keys) + + end subroutine dictionary_subset + + + !% Return a dictionary that is a subset of this in 'out' + !% with only the keys in the arrays 'keys' present. + subroutine dictionary_subset_es(this, keys, out, case_sensitive, out_no_initialise, error) + type(Dictionary), intent(in) :: this + type(extendable_str), dimension(:), intent(in) :: keys + type(Dictionary), intent(inout) :: out + logical, intent(in), optional :: case_sensitive, out_no_initialise + integer, intent(out), optional :: error + + type(Dictionary) :: tmp_dict + logical :: my_out_no_initialise + integer :: i, j, io + + INIT_ERROR(error) + + + my_out_no_initialise = optional_default(.false., out_no_initialise) + if (.not. my_out_no_initialise) call initialise(out) + + do j=1,size(keys) + + i = lookup_entry_i(this, string(keys(j)), case_sensitive) + if (i == -1) then + RAISE_ERROR('dictionary_subset_es: key '//string(keys(j))//' not in dictionary', error) + end if + if (my_out_no_initialise) then + io = lookup_entry_i(out, string(keys(j)), case_sensitive) + if (io >= 1) then + if (this%entries(i)%type /= out%entries(io)%type) then + RAISE_ERROR('entry type for key '//string(keys(i))//' does not match in this, out', error) + endif + select case(this%entries(i)%type) + case(T_INTEGER_A) + if (any(shape(this%entries(i)%i_a) /= shape(out%entries(io)%i_a))) then + RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) + endif + case(T_REAL_A) + if (any(shape(this%entries(i)%r_a) /= shape(out%entries(io)%r_a))) then + RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) + endif + case(T_COMPLEX_A) + if (any(shape(this%entries(i)%c_a) /= shape(out%entries(io)%c_a))) then + RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) + endif + case(T_LOGICAL_A) + if (any(shape(this%entries(i)%l_a) /= shape(out%entries(io)%l_a))) then + RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) + endif + case(T_CHAR_A) + if (any(shape(this%entries(i)%s_a) /= shape(out%entries(io)%s_a))) then + RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) + endif + case(T_INTEGER_A2) + if (any(shape(this%entries(i)%i_a2) /= shape(out%entries(io)%i_a2))) then + RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) + endif + case(T_REAL_A2) + if (any(shape(this%entries(i)%r_a2) /= shape(out%entries(io)%r_a2))) then + RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) + endif + case(T_DATA) + if (any(shape(this%entries(i)%d) /= shape(out%entries(io)%d))) then + RAISE_ERROR('entry size for key '//string(keys(i))//' does not match in this, out', error) + endif + end select + call remove_entry(out, io) + endif ! io >= 1 + endif ! my_out_no_initialise + + select case(this%entries(i)%type) + case(T_NONE) + call set_value(out, string(this%keys(i))) + + case(T_INTEGER) + call set_value(out, string(this%keys(i)), this%entries(i)%i) + + case(T_REAL) + call set_value(out, string(this%keys(i)), this%entries(i)%r) + + case(T_COMPLEX) + call set_value(out, string(this%keys(i)), this%entries(i)%c) + + case(T_LOGICAL) + call set_value(out, string(this%keys(i)), this%entries(i)%l) + + case(T_CHAR) + call set_value(out, string(this%keys(i)), this%entries(i)%s) + + case(T_INTEGER_A) + call set_value(out, string(this%keys(i)), this%entries(i)%i_a) + + case(T_REAL_A) + call set_value(out, string(this%keys(i)), this%entries(i)%r_a) + + case(T_COMPLEX_A) + call set_value(out, string(this%keys(i)), this%entries(i)%c_a) + + case(T_LOGICAL_A) + call set_value(out, string(this%keys(i)), this%entries(i)%l_a) + + case(T_CHAR_A) + call set_value(out, string(this%keys(i)), this%entries(i)%s_a) + + case(T_INTEGER_A2) + call set_value(out, string(this%keys(i)), this%entries(i)%i_a2) + + case(T_REAL_A2) + call set_value(out, string(this%keys(i)), this%entries(i)%r_a2) + + case(T_DATA) + call set_value(out, string(this%keys(i)), this%entries(i)%d) + + case(T_DICT) + if (.not. get_value(this, string(this%keys(i)), tmp_dict)) then + RAISE_ERROR('dictionary_subset_es: cannot get_value() as Dictionary type.', error) + end if + call set_value(out, string(this%keys(i)), tmp_dict) + call finalise(tmp_dict) + + end select + end do + + end subroutine dictionary_subset_es + + + !% Swap the positions of two entries in the dictionary. Arrays are not moved in memory. + subroutine dictionary_swap(this, key1, key2, case_sensitive, error) + type(Dictionary), intent(inout) :: this + character(len=*), intent(in) :: key1, key2 + logical, optional :: case_sensitive + integer, intent(out), optional :: error + + integer :: i1,i2 + type(DictEntry) :: tmp_entry + type(Extendable_str) :: tmp_key + + INIT_ERROR(error); + + i1 = lookup_entry_i(this,key1,case_sensitive) + i2 = lookup_entry_i(this,key2,case_sensitive) + + if (i1 <= 0) then + RAISE_ERROR('dictionary_swap: key '//key1//' not in dictionary', error) + end if + if (i2 <= 0) then + RAISE_ERROR('dictionary_swap: key '//key2//' not in dictionary', error) + end if + + tmp_entry = this%entries(i2) + tmp_key = this%keys(i2) + this%entries(i2) = this%entries(i1) + this%keys(i2) = this%keys(i1) + this%entries(i1) = tmp_entry + this%keys(i1) = tmp_key + + ! Avoid memory leaks by freeing Extanable_str memory + ! (other entry types are shallow copied). + call finalise(tmp_key) + if (tmp_entry%type == T_CHAR) call finalise(tmp_entry%s) + + this%key_cache_invalid = 1 + + end subroutine dictionary_swap + + subroutine dictionary_bcast(mpi, dict, error) + type(MPI_context), intent(in) :: mpi + type(Dictionary), intent(inout) :: dict + integer, intent(out), optional :: error + + integer :: i, size_tmp, shape_tmp(2) + + INIT_ERROR(error) + + if (.not. mpi%active) return + + if (mpi%my_proc == 0) then + call bcast(mpi, dict%n) + do i=1,dict%n + call bcast(mpi, dict%entries(i)%type) + call bcast(dict%keys(i), mpi%communicator, mpi%my_proc) + + if (dict%entries(i)%type == T_NONE) then + ! nothing to do + else if (dict%entries(i)%type == T_INTEGER) then + call bcast(mpi, dict%entries(i)%i) + else if (dict%entries(i)%type == T_REAL) then + call bcast(mpi, dict%entries(i)%r) + else if (dict%entries(i)%type == T_COMPLEX) then + call bcast(mpi, dict%entries(i)%c) + else if (dict%entries(i)%type == T_LOGICAL) then + call bcast(mpi, dict%entries(i)%l) + else if (dict%entries(i)%type == T_CHAR) then + call bcast(dict%entries(i)%s, mpi%communicator, mpi%my_proc) + else if (dict%entries(i)%type == T_INTEGER_A) then + !size_tmp = size(dict%entries(i)%i_a) + call bcast(mpi, dict%entries(i)%len) + call bcast(mpi, dict%entries(i)%i_a) + else if (dict%entries(i)%type == T_REAL_A) then + !size_tmp = size(dict%entries(i)%r_a) + call bcast(mpi, dict%entries(i)%len) + call bcast(mpi, dict%entries(i)%r_a) + else if (dict%entries(i)%type == T_COMPLEX_A) then + !size_tmp = size(dict%entries(i)%c_a) + call bcast(mpi, dict%entries(i)%len) + call bcast(mpi, dict%entries(i)%c_a) + else if (dict%entries(i)%type == T_LOGICAL_A) then + !size_tmp = size(dict%entries(i)%l_a) + call bcast(mpi, dict%entries(i)%len) + call bcast(mpi, dict%entries(i)%l_a) + else if (dict%entries(i)%type == T_CHAR_A) then + !shape_tmp = shape(dict%entries(i)%s_a) + call bcast(mpi, dict%entries(i)%len2) + call bcast(mpi, dict%entries(i)%s_a) + else if (dict%entries(i)%type == T_INTEGER_A2) then + !shape_tmp = shape(dict%entries(i)%i_a2) + call bcast(mpi, dict%entries(i)%len2) + call bcast(mpi, dict%entries(i)%i_a2) + else if (dict%entries(i)%type == T_REAL_A2) then + !shape_tmp = shape(dict%entries(i)%r_a2) + call bcast(mpi, dict%entries(i)%len2) + call bcast(mpi, dict%entries(i)%r_a2) + else if (dict%entries(i)%type == T_DATA) then + size_tmp = size(dict%entries(i)%d%d) + call bcast(mpi, size_tmp) + call bcast(mpi, dict%entries(i)%d%d) + end if + end do + else + call finalise(dict) + call bcast(mpi, dict%n) + allocate(dict%keys(dict%n)) + allocate(dict%entries(dict%n)) + do i=1,dict%n + call bcast(mpi, dict%entries(i)%type) + call bcast(dict%keys(i), mpi%communicator, mpi%my_proc) + + if (dict%entries(i)%type == T_NONE) then + ! nothing to do + else if (dict%entries(i)%type == T_INTEGER) then + call bcast(mpi, dict%entries(i)%i) + else if (dict%entries(i)%type == T_REAL) then + call bcast(mpi, dict%entries(i)%r) + else if (dict%entries(i)%type == T_COMPLEX) then + call bcast(mpi, dict%entries(i)%c) + else if (dict%entries(i)%type == T_LOGICAL) then + call bcast(mpi, dict%entries(i)%l) + else if (dict%entries(i)%type == T_CHAR) then + call bcast(dict%entries(i)%s, mpi%communicator, mpi%my_proc) + else if (dict%entries(i)%type == T_INTEGER_A) then + !size_tmp = size(dict%entries(i)%i_a) + call bcast(mpi, size_tmp) + dict%entries(i)%len = size_tmp + dict%entries(i)%len2 = (/0, 0/) + allocate(dict%entries(i)%i_a(size_tmp)) + call bcast(mpi, dict%entries(i)%i_a) + else if (dict%entries(i)%type == T_REAL_A) then + !size_tmp = size(dict%entries(i)%r_a) + call bcast(mpi, size_tmp) + dict%entries(i)%len = size_tmp + dict%entries(i)%len2 = (/0, 0/) + allocate(dict%entries(i)%r_a(size_tmp)) + call bcast(mpi, dict%entries(i)%r_a) + else if (dict%entries(i)%type == T_COMPLEX_A) then + !size_tmp = size(dict%entries(i)%c_a) + call bcast(mpi, size_tmp) + dict%entries(i)%len = size_tmp + dict%entries(i)%len2 = (/0, 0/) + allocate(dict%entries(i)%c_a(size_tmp)) + call bcast(mpi, dict%entries(i)%c_a) + else if (dict%entries(i)%type == T_LOGICAL_A) then + !size_tmp = size(dict%entries(i)%l_a) + call bcast(mpi, size_tmp) + dict%entries(i)%len = size_tmp + dict%entries(i)%len2 = (/0, 0/) + allocate(dict%entries(i)%l_a(size_tmp)) + call bcast(mpi, dict%entries(i)%l_a) + else if (dict%entries(i)%type == T_CHAR_A) then + !shape_tmp = shape(dict%entries(i)%s_a) + call bcast(mpi, shape_tmp) + dict%entries(i)%len = 0 + dict%entries(i)%len2 = shape_tmp + allocate(dict%entries(i)%s_a(shape_tmp(1),shape_tmp(2))) + call bcast(mpi, dict%entries(i)%s_a) + else if (dict%entries(i)%type == T_INTEGER_A2) then + !shape_tmp = shape(dict%entries(i)%i_a2) + call bcast(mpi, shape_tmp) + dict%entries(i)%len = 0 + dict%entries(i)%len2 = shape_tmp + allocate(dict%entries(i)%i_a2(shape_tmp(1),shape_tmp(2))) + call bcast(mpi, dict%entries(i)%i_a2) + else if (dict%entries(i)%type == T_REAL_A2) then + !shape_tmp = shape(dict%entries(i)%r_a2) + call bcast(mpi, shape_tmp) + dict%entries(i)%len = 0 + dict%entries(i)%len2 = shape_tmp + allocate(dict%entries(i)%r_a2(shape_tmp(1),shape_tmp(2))) + call bcast(mpi, dict%entries(i)%r_a2) + else if (dict%entries(i)%type == T_DATA) then + size_tmp = size(dict%entries(i)%d%d) + call bcast(mpi, size_tmp) + allocate(dict%entries(i)%d%d(size_tmp)) + call bcast(mpi, dict%entries(i)%d%d) + end if + end do + end if + + end subroutine dictionary_bcast + + !% Copy extendable string from 'in' to 'out', expanding variables formatted + !% as '\$KEY' or '\$\{KEY\}' using values in this Dictionary. An error + !% is raised if a key is not found, or if the string ends with a dollar sign or braces aren't matched + !XXX backslashes are for f90doc.py; of course it actually means '$KEY' and '${KEY}' + subroutine dictionary_expand_string(this, in, out, error) + type(Dictionary), intent(in) :: this + type(Extendable_str), intent(inout) :: in + type(Extendable_str), intent(out) :: out + integer, intent(out), optional :: error + + integer s, e, save_cur + character(len=C_KEY_LEN) :: key + character(len=STRING_LENGTH) :: val + character(len=63), parameter :: valid_chars = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_' + logical got_brace + + INIT_ERROR(error) + + save_cur = in%cur + in%cur = 1 + call initialise(out) + do + s = index(in, '$') + if (s == 0) then + call concat(out, substr(in, in%cur, in%len)) + exit + end if + if (s > in%len-1) then + RAISE_ERROR('dictionary_expand_string: $ found at end of input string "'//in//'"', error) + end if + + if (in%s(s+1) == '{') then + got_brace = .true. + e = index(in, '}') + if (e == 0) then + RAISE_ERROR('dictionary_expand_string: unmatched { in input string "'//in//'"', error) + end if + key = substr(in, s+2, e-1, error) + PASS_ERROR(error); + else + got_brace = .false. + e = s+1 + do while (all(verify(in%s(e:e), valid_chars) == 0)) + e = e + 1 + if (e > in%len) exit + end do + e = e - 1 + key = substr(in, s+1, e, error) + PASS_ERROR(error); + end if + + if (.not. get_value(this, key, val)) then + RAISE_ERROR('dictionary_expand_string: unknown key "'//trim(key)//'" or value is not of type T_CHAR', error) + end if + + call concat(out, substr(in, in%cur, s-1, error)) + PASS_ERROR(error); + call concat(out, val) + in%cur = e+1 + end do + + in%cur = save_cur + + end subroutine dictionary_expand_string + + + !% Make a deep copy of 'from' in 'this', allocating new memory for array components + subroutine dictionary_deepcopy(this, from, error) + type(Dictionary), intent(inout) :: this + type(Dictionary), intent(in) :: from + integer, optional, intent(out) :: error + + INIT_ERROR(error) + call subset(from, from%keys(1:from%n), this, error=error) + PASS_ERROR(error) + + end subroutine dictionary_deepcopy + + + !% Make a deep copy of 'from' in 'this', allocating new memory for array components; no error passing, for the assignment operator + subroutine dictionary_deepcopy_no_error(this, from) + type(Dictionary), intent(inout) :: this + type(Dictionary), intent(in) :: from + + call deepcopy(this, from) + + end subroutine dictionary_deepcopy_no_error + + subroutine dictionary__array__(this, key, nd, dtype, dshape, dloc) + use iso_c_binding, only: c_intptr_t + type(Dictionary), intent(in) :: this + character(len=*), intent(in) :: key + integer, intent(out) :: nd + integer, intent(out) :: dtype + integer, dimension(10), intent(out) :: dshape + integer(c_intptr_t), intent(out) :: dloc + + integer entry_i + + nd = 0 + dtype = 0 + dshape(:) = 0 + dloc = 0 + + entry_i = lookup_entry_i(this, key) + if (entry_i == -1) return + + select case(this%entries(entry_i)%type) + case(T_INTEGER_A) + nd = 1 + dshape(1) = size(this%entries(entry_i)%i_a) + dloc = loc(this%entries(entry_i)%i_a) + dtype = 5 + + case(T_REAL_A) + nd = 1 + dshape(1) = size(this%entries(entry_i)%r_a) + dloc = loc(this%entries(entry_i)%r_a) + dtype = 12 + + case(T_COMPLEX_A) + nd = 1 + dshape(1) = size(this%entries(entry_i)%c_a) + dloc = loc(this%entries(entry_i)%c_a) + dtype = 14 + + case(T_LOGICAL_A) + nd = 1 + dshape(1) = size(this%entries(entry_i)%l_a) + dloc = loc(this%entries(entry_i)%l_a) + dtype = 5 + + case(T_CHAR_A) + nd = 2 + dshape(1) = size(this%entries(entry_i)%s_a,1) + dshape(2) = size(this%entries(entry_i)%s_a,2) + dloc = loc(this%entries(entry_i)%s_a) + dtype = 18 + + case(T_INTEGER_A2) + nd = 2 + dshape(1) = size(this%entries(entry_i)%i_a2, 1) + dshape(2) = size(this%entries(entry_i)%i_a2, 2) + dloc = loc(this%entries(entry_i)%i_a2) + dtype = 5 + + case(T_REAL_A2) + nd = 2 + dshape(1) = size(this%entries(entry_i)%r_a2, 1) + dshape(2) = size(this%entries(entry_i)%r_a2, 2) + dloc = loc(this%entries(entry_i)%r_a2) + dtype = 12 + end select + + end subroutine dictionary__array__ + + +#ifdef POINTER_COMPONENT_MANUAL_COPY +subroutine dictentry_assign(to, from) + type(DictEntry), intent(inout) :: to + type(DictEntry), intent(in) :: from + + to%type = from%type + to%len = from%len + to%len2 = from%len2 + + to%own_data = from%own_data + to%i = from%i + to%r = from%r + to%c = from%c + + to%s = from%s + + to%i_a => from%i_a + to%r_a => from%r_a + to%c_a => from%c_a + to%l_a => from%l_a + to%s_a => from%s_a + + to%i_a2 => from%i_a2 + to%r_a2 => from%r_a2 + + to%d = from%d +end subroutine dictentry_assign + +subroutine dictdata_assign(to, from) + type(DictData), intent(inout) :: to + type(DictData), intent(in) :: from + + if (allocated(to%d)) deallocate(to%d) + if (allocated(from%d)) then + allocate(to%d(size(from%d))) + to%d = from%d + endif +end subroutine dictdata_assign +#endif + +end module dictionary_module diff --git a/src/libAtoms/DomainDecomposition.F90 b/src/libAtoms/DomainDecomposition.F90 new file mode 100644 index 0000000000..c780ed58ea --- /dev/null +++ b/src/libAtoms/DomainDecomposition.F90 @@ -0,0 +1,1605 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module DomainDecomposition_module + use error_module + use system_module + use extendable_str_module + use MPI_context_module + use linearalgebra_module + use table_module + use atoms_types_module + use dictionary_module + + implicit none + + private + + public :: DomainDecomposition + + public :: initialise + interface initialise + module procedure domaindecomposition_initialise + endinterface + + public :: finalise + interface finalise + module procedure domaindecomposition_finalise + endinterface + + interface update_sendrecv_masks + module procedure domaindecomposition_update_sendrecv_masks + endinterface + + public :: enable + interface enable + module procedure domaindecomposition_enable + endinterface enable + + public :: disable + interface disable + module procedure domaindecomposition_disable + endinterface disable + + public :: allocate + interface allocate + module procedure domaindecomposition_allocate + endinterface allocate + + interface is_in_domain + module procedure domaindecomposition_is_in_domain + endinterface is_in_domain + + interface sdompos + module procedure sdompos1, sdompos3 + endinterface + + public :: set_comm_property + interface set_comm_property + module procedure domaindecomposition_set_comm_property + endinterface set_comm_property + + public :: set_border + interface set_border + module procedure domaindecomposition_set_border + endinterface + + public :: comm_atoms + interface comm_atoms + module procedure domaindecomposition_comm_atoms + endinterface + + public :: comm_ghosts + interface comm_ghosts + module procedure domaindecomposition_comm_ghosts + endinterface + + public :: comm_reverse + interface comm_reverse + module procedure domaindecomposition_comm_reverse + endinterface + + public :: comm_atoms_to_all + interface comm_atoms_to_all + module procedure domaindecomposition_comm_atoms_to_all + endinterface + + public :: deepcopy + interface deepcopy + module procedure domaindecomposition_deepcopy + endinterface deepcopy + + + ! + ! Supplement to the Dictionary class required by the domain + ! decomposition module. + ! Move it do Dictionary.f95? + ! + + interface keys_to_mask + module procedure dictionary_keys_to_mask + endinterface keys_to_mask + + interface pack_buffer + module procedure dictionary_pack_buffer + endinterface + + interface unpack_buffer + module procedure dictionary_unpack_buffer + endinterface + +contains + + !% Initialize the domain decomposition module + subroutine domaindecomposition_initialise(this, & + decomposition, verlet_shell, mode, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + integer, optional, intent(in) :: decomposition(3) + real(dp), optional, intent(in) :: verlet_shell + integer, optional, intent(in) :: mode + integer, optional, intent(out) :: error + + ! --- + + INIT_ERROR(error) + + call print("DomainDecomposition : initialise", PRINT_NERD) + + this%decomposition = (/ 1, 1, 1 /) + if (present(decomposition)) then + this%decomposition = decomposition + endif + + this%verlet_shell = 0.0_DP + if (present(verlet_shell)) then + this%verlet_shell = verlet_shell + endif + + this%mode = DD_WRAP_TO_CELL + if (present(mode)) then + if (mode /= DD_WRAP_TO_CELL .and. mode /= DD_WRAP_TO_DOMAIN) then + RAISE_ERROR("Unknown domain decomposition mode '" // mode // "'.", error) + endif + + this%mode = mode + else + this%mode = DD_WRAP_TO_CELL + endif + + this%decomposed = .false. + this%requested_border = 0.0_DP + + this%n_send_p_tot = 0 + this%n_recv_p_tot = 0 + this%n_send_g_tot = 0 + this%n_recv_g_tot = 0 + this%nit_p = 0 + this%nit_g = 0 + + ! Initialise property lists + call initialise(this%atoms_properties) + call initialise(this%ghost_properties) + call initialise(this%reverse_properties) + + endsubroutine domaindecomposition_initialise + + + !% Update send and receive masks, only necessary after properties have + !% been added to or removed from the Atoms object + subroutine domaindecomposition_update_sendrecv_masks(this, at, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(in) :: at + integer, intent(out), optional :: error + + ! --- + + integer :: s + + ! --- + + INIT_ERROR(error) + + ! XXX FIXME This should become unecessary if DynamicalSystem only + ! pointer to an atoms object + if (.not. assign_pointer(at%properties, "local_to_global", & + this%local_to_global)) then + RAISE_ERROR("Could not find 'local_to_global'", error) + endif + + if (allocated(this%atoms_mask)) then + if (size(this%atoms_mask) < at%properties%N) then + deallocate(this%atoms_mask) + this%atoms_buffer_size = 0 + endif + endif + + if (allocated(this%ghost_mask)) then + if (size(this%ghost_mask) < at%properties%N) then + deallocate(this%ghost_mask) + this%ghost_buffer_size = 0 + endif + endif + + if (allocated(this%reverse_mask)) then + if (size(this%reverse_mask) < at%properties%N) then + deallocate(this%reverse_mask) + this%reverse_buffer_size = 0 + endif + endif + + if (.not. allocated(this%atoms_mask) .and. this%atoms_properties%N > 0) then + allocate(this%atoms_mask(at%properties%N)) + call keys_to_mask( & + at%properties, this%atoms_properties, this%atoms_mask, & + s = this%atoms_buffer_size, error = error) + PASS_ERROR(error) + + call print("DomainDecomposition : atoms_buffer_size = " // & + this%atoms_buffer_size, PRINT_VERBOSE) + endif + if (.not. allocated(this%ghost_mask) .and. this%ghost_properties%N > 0) then + allocate(this%ghost_mask(at%properties%N)) + call keys_to_mask( & + at%properties, this%ghost_properties, this%ghost_mask, & + s = this%ghost_buffer_size, error = error) + PASS_ERROR(error) + + call print("DomainDecomposition : ghost_buffer_size = " // & + this%ghost_buffer_size, PRINT_VERBOSE) + endif + if (.not. allocated(this%reverse_mask) .and. this%reverse_properties%N > 0) then + allocate(this%reverse_mask(at%properties%N)) + call keys_to_mask( & + at%properties, this%reverse_properties, this%reverse_mask, & + s = this%reverse_buffer_size, error = error) + PASS_ERROR(error) + + call print("DomainDecomposition : reverse_buffer_size = " // & + this%reverse_buffer_size, PRINT_VERBOSE) + endif + + s = max(this%atoms_buffer_size, this%ghost_buffer_size) * at%Nbuffer + + if (allocated(this%send_l)) then + if (s > size(this%send_l, 1)) then + deallocate(this%send_l) + deallocate(this%send_r) + deallocate(this%recv_l) + deallocate(this%recv_r) + endif + endif + + if (.not. allocated(this%send_l)) then + allocate(this%send_l(s)) + allocate(this%send_r(s)) + allocate(this%recv_l(s)) + allocate(this%recv_r(s)) + endif + + endsubroutine domaindecomposition_update_sendrecv_masks + + + !% Enable domain decomposition, after this call every process + !% remains only with the atoms in its local domain. + subroutine domaindecomposition_enable(this, at, & + mpi, decomposition, verlet_shell, mode, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + type(MPI_context), optional, intent(in) :: mpi + integer, optional, intent(in) :: decomposition(3) + real(dp), optional, intent(in) :: verlet_shell + integer, optional, intent(in) :: mode + integer, optional, intent(out) :: error + + ! --- + + integer :: i, j + + ! --- + + INIT_ERROR(error) + + call print("DomainDecomposition : enable", PRINT_VERBOSE) + + if (present(decomposition)) then + this%decomposition = decomposition + endif + + if (present(verlet_shell)) then + this%verlet_shell = verlet_shell + endif + + if (present(mode)) then + if (mode /= DD_WRAP_TO_CELL .and. mode /= DD_WRAP_TO_DOMAIN) then + RAISE_ERROR("Unknown domain decomposition mode '" // mode // "'.", error) + endif + + this%mode = mode + else + this%mode = DD_WRAP_TO_CELL + endif + + call print("DomainDecomposition : Parallelisation using domain decomposition over " // & + this%decomposition // "domains.", PRINT_NORMAL) + + call initialise(this%mpi, & + context = mpi, & + dims = this%decomposition, & + error = error) + PASS_ERROR(error) + + call print("DomainDecomposition : " // this%mpi%n_procs // " MPI processes available.", PRINT_NORMAL) + + if (this%decomposition(1)*this%decomposition(2)*this%decomposition(3) /= & + this%mpi%n_procs) then + RAISE_ERROR("Decomposition geometry requires " // this%decomposition(1)*this%decomposition(2)*this%decomposition(3) // " processes, however, MPI returns " // this%mpi%n_procs // " processes.", error) + endif + +! For now this needs to be true +! this%periodic = at%periodic + this%periodic = .true. + this%requested_border = 0.0_DP + + call print("DomainDecomposition : coords = ( " // this%mpi%my_coords // ")", PRINT_VERBOSE) + + do i = 1, 3 + call cart_shift( & + this%mpi, i-1, 1, this%l(i), this%r(i), error) + PASS_ERROR(error) + enddo + + this%lower = (1.0_DP*this%mpi%my_coords) / this%decomposition + this%upper = (1.0_DP*(this%mpi%my_coords+1)) / this%decomposition + this%center = (this%lower + this%upper)/2 + + call print("DomainDecomposition : lower = ( " // this%lower // " )", PRINT_VERBOSE) + call print("DomainDecomposition : upper = ( " // this%upper // " )", PRINT_VERBOSE) + call print("DomainDecomposition : center = ( " // this%center // " )", PRINT_VERBOSE) + + this%n_send_p_tot = 0 + this%n_recv_p_tot = 0 + this%n_send_g_tot = 0 + this%n_recv_g_tot = 0 + this%nit_p = 0 + this%nit_g = 0 + + ! allocate internal buffers + call allocate(this, at, error=error) + PASS_ERROR(error) + + ! at is initialised, this means we need to retain only the atoms that + ! are in the current domain. + j = 0 + do i = 1, at%N + ! If this is in the domain, keep it + if (is_in_domain(this, at, at%pos(:, i))) then + j = j+1 + if (i /= j) then + call copy_entry(at, i, j) + endif + endif + enddo + at%N = j + at%Ndomain = j + + this%decomposed = .true. + + endsubroutine domaindecomposition_enable + + + !% Disable domain decomposition, after this call every process + !% retains an identical copy of the system. + subroutine domaindecomposition_disable(this, at, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, intent(out), optional :: error + + ! --- + + INIT_ERROR(error) + + if (.not. this%decomposed) then + RAISE_ERROR("DomainDecomposition-object is not in a domain-decomposed state. Cannot disable domain decomposition.", error) + endif + + call comm_atoms_to_all(this, at, error=error) + PASS_ERROR(error) + + this%decomposed = .false. + + this%local_to_global = 0 + + if (allocated(this%global_to_local)) deallocate(this%global_to_local) + if (allocated(this%ghosts_r)) deallocate(this%ghosts_r) + if (allocated(this%ghosts_l)) deallocate(this%ghosts_l) + + endsubroutine domaindecomposition_disable + + + !% Allocate internal buffer + subroutine domaindecomposition_allocate(this, at, range, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, optional, intent(in) :: range(2) + integer, optional, intent(inout) :: error + + ! --- + + integer :: i, d, my_range(2) + real(dp) :: l(3) + + ! --- + + if ((at%lattice(:, 1) .dot. at%lattice(:, 2)) > 1e-6 .or. & + (at%lattice(:, 2) .dot. at%lattice(:, 3)) > 1e-6 .or. & + (at%lattice(:, 3) .dot. at%lattice(:, 1)) > 1e-6) then + RAISE_ERROR("Only orthorhombic lattices are support for now.", error) + endif + + l = (/ at%lattice(1, 1), at%lattice(2, 2), at%lattice(3, 3) /) + + this%off_r = 0.0_DP + this%off_l = 0.0_DP + + do d = 1, 3 +! if (at%periodic(d) .and. this%decomposition(d) > 1) then + if (this%decomposition(d) > 1) then + ! No periodicity in binning because we explicitly copy the atoms + ! from the other processors +! this%locally_periodic(d) = .false. + else + this%periodic(d) = .false. + endif + + if (this%mpi%my_coords(d) == 0) then + this%off_l(d) = -l(d) + else if (this%mpi%my_coords(d) == this%decomposition(d)-1) then + this%off_r(d) = l(d) + endif + enddo + +! call print("periodic (global) = ( " // at%periodic // " )", PRINT_VERBOSE) + call print("DomainDecomposition : periodic (par.) = ( " // this%periodic // " )", PRINT_VERBOSE) +! call print("periodic (local) = ( " // this%locally_periodic // " )", PRINT_VERBOSE) + + if (this%mode == DD_WRAP_TO_CELL) then + this%off_l = 0.0_DP + this%off_r = 0.0_DP + endif + + call print("DomainDecomposition : off_l = ( " // this%off_l // " )", PRINT_VERBOSE) + call print("DomainDecomposition : off_r = ( " // this%off_r // " )", PRINT_VERBOSE) + + if (present(range)) then + my_range = range + if (my_range(2) - my_range(1) + 1 /= at%N) then + RAISE_ERROR("*range* and number of atoms do not match.", error) + endif + else + my_range = (/ 1, at%N /) + endif + + ! Additional properties (integers) + call add_property(at, "local_to_global", 0, & + ptr=this%local_to_global, error=error) + PASS_ERROR(error) + + ! Allocate local buffers + allocate(this%global_to_local(at%Nbuffer)) + allocate(this%ghosts_r(at%Nbuffer)) + allocate(this%ghosts_l(at%Nbuffer)) + + do i = 1, at%N + !% Assign global indices + this%local_to_global(i) = i+my_range(1)-1 + this%global_to_local(i+my_range(1)-1) = i + enddo + + this%Ntotal = sum(this%mpi, at%N, error) + PASS_ERROR(error) + + call print("DomainDecomposition : Ntotal = " // this%Ntotal, PRINT_VERBOSE) + + call set_border(this, at, this%requested_border, error=error) + PASS_ERROR(error) + + endsubroutine domaindecomposition_allocate + + + !% Is the position in the current domain? + function domaindecomposition_is_in_domain(this, at, r) result(id) + implicit none + + type(DomainDecomposition), intent(in) :: this + type(Atoms), intent(in) :: at + real(dp), intent(in) :: r(3) + + logical :: id + + ! --- + + real(dp) :: s(3) + + ! --- + + s = at%g .mult. r + id = all(s >= this%lower) .and. all(s < this%upper) + + endfunction domaindecomposition_is_in_domain + + + !% Set which properties to communicate on which events + !% comm_atoms: Communicate when atom is moved to different domain. + !% Forces, for example, may be excluded since they are updated + !% on every time step. + !% comm_ghosts: Communicate when atoms becomes a ghost on some domain + !% Masses, for example, might be excluded since atoms are + !% propagated on the domain they reside in only. + !% comm_reverse: Communicate back from ghost atoms to the original domain atom + !% and accumulate + subroutine domaindecomposition_set_comm_property(this, propname, & + comm_atoms, comm_ghosts, comm_reverse) + implicit none + + type(DomainDecomposition), intent(inout) :: this + character(*), intent(in) :: propname + logical, optional, intent(in) :: comm_atoms + logical, optional, intent(in) :: comm_ghosts + logical, optional, intent(in) :: comm_reverse + + ! --- + + if (present(comm_atoms)) then + if (comm_atoms) then + call set_value(this%atoms_properties, propname, .true.) + else + call remove_value(this%atoms_properties, propname) + endif + endif + if (present(comm_ghosts)) then + if (comm_ghosts) then + call set_value(this%ghost_properties, propname, .true.) + else + call remove_value(this%ghost_properties, propname) + endif + endif + if (present(comm_reverse)) then + if (comm_reverse) then + call set_value(this%reverse_properties, propname, .true.) + else + call remove_value(this%reverse_properties, propname) + endif + endif + + endsubroutine domaindecomposition_set_comm_property + + + !% Set the communication border + subroutine domaindecomposition_set_border(this, at, & + border, verlet_shell, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(in) :: at + real(dp), intent(in) :: border + real(dp), intent(in), optional :: verlet_shell + integer, intent(out), optional :: error + + ! --- + + integer :: d + + ! --- + + INIT_ERROR(error) + + call print("DomainDecomposition : set_border", PRINT_VERBOSE) + + if (present(verlet_shell)) then + this%verlet_shell = verlet_shell + endif + + this%requested_border = max(this%requested_border, border) + this%border = this%requested_border + this%verlet_shell + + call print("DomainDecomposition : requested_border = " // this%requested_border, PRINT_VERBOSE) + call print("DomainDecomposition : verlet_shell = " // this%verlet_shell, PRINT_VERBOSE) + call print("DomainDecomposition : border = " // this%border, PRINT_VERBOSE) + + if (any(((at%lattice .mult. (this%upper - this%lower)) < 2*this%border) .and. this%periodic)) then + RAISE_ERROR("Domain smaller than twice the border. This does not work (yet). border = " // this%border // ", lattice = " // at%lattice(:, 1) // ", " // at%lattice(:, 2) // ", " // at%lattice(:, 3) // ", lower = " // this%lower // ", upper = " // this%upper, error) + endif + + do d = 1, 3 + if (this%periodic(d) .or. this%mpi%my_coords(d) /= 0) then + this%lower_with_border(d) = this%lower(d) - (at%g(d, :) .dot. this%border) + else + this%lower_with_border(d) = this%lower(d) + endif + if (this%periodic(d) .or. this%mpi%my_coords(d) /= this%decomposition(d)-1) then + this%upper_with_border(d) = this%upper(d) + (at%g(d, :) .dot. this%border) + else + this%upper_with_border(d) = this%upper(d) + endif + enddo + + call print("DomainDecomposition : lower_with_border = ( " // this%lower_with_border // " )", PRINT_VERBOSE) + call print("DomainDecomposition : upper_with_border = ( " // this%upper_with_border // " )", PRINT_VERBOSE) + + endsubroutine domaindecomposition_set_border + + + !% Free memory, clean up + subroutine domaindecomposition_finalise(this) + implicit none + + type(DomainDecomposition), intent(inout) :: this + + ! --- + + call print("DomainDecomposition : finalise", PRINT_NERD) + + if (allocated(this%send_l)) deallocate(this%send_l) + if (allocated(this%send_r)) deallocate(this%send_r) + if (allocated(this%recv_l)) deallocate(this%recv_l) + if (allocated(this%recv_r)) deallocate(this%recv_r) + + if (allocated(this%global_to_local)) deallocate(this%global_to_local) + if (allocated(this%ghosts_r)) deallocate(this%ghosts_r) + if (allocated(this%ghosts_l)) deallocate(this%ghosts_l) + + if (allocated(this%atoms_mask)) deallocate(this%atoms_mask) + if (allocated(this%ghost_mask)) deallocate(this%ghost_mask) + if (allocated(this%reverse_mask)) deallocate(this%reverse_mask) + + if (this%n_send_p_tot > 0 .and. this%n_recv_p_tot > 0 .and. & + this%n_send_g_tot > 0 .and. this%n_recv_g_tot > 0) then + call print("DomainDecomposition : Average number of particles sent/received per iteration:", PRINT_NERD) + call print("DomainDecomposition : Particles send = " // (1.0_DP*this%n_send_p_tot)/this%nit_p, PRINT_NERD) + call print("DomainDecomposition : Particles recv = " // (1.0_DP*this%n_recv_p_tot)/this%nit_p, PRINT_NERD) + call print("DomainDecomposition : Ghosts send = " // (1.0_DP*this%n_send_g_tot)/this%nit_g, PRINT_NERD) + call print("DomainDecomposition : Ghosts recv = " // (1.0_DP*this%n_recv_g_tot)/this%nit_g, PRINT_NERD) + endif + + call finalise(this%atoms_properties) + call finalise(this%ghost_properties) + call finalise(this%reverse_properties) + + call finalise(this%mpi) + + endsubroutine domaindecomposition_finalise + + + !% Compute the scaled position as the minimum image from the domain center + !% for a single coordinate only + function sdompos1(this, at, r, d) + implicit none + + type(DomainDecomposition), intent(in) :: this + type(Atoms), intent(in) :: at + real(dp), intent(in) :: r(3) + integer, intent(in) :: d + + real(dp) :: sdompos1 + + ! --- + + real(dp) :: s + + ! --- + + ! center is in scaled coordinates + s = (at%g(d, :) .dot. r) - this%center(d) + sdompos1 = s - nint(s) + this%center(d) + + endfunction sdompos1 + + + !% Compute the scaled position as the minimum image from the domain center + function sdompos3(this, at, r) + implicit none + + type(DomainDecomposition), intent(in) :: this + type(Atoms), intent(in) :: at + real(dp), intent(in) :: r(3) + + real(dp) :: sdompos3(3) + + ! --- + + real(dp) :: s(3) + + ! --- + + ! center is in scaled coordinates + s = (at%g .mult. r) - this%center + sdompos3 = s - nint(s) + this%center + + endfunction sdompos3 + + + !% Add particle data to the send buffer + subroutine pack_atoms_buffer(this, at, i, n, buffer) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, intent(in) :: i + integer, intent(inout) :: n + character(1), intent(inout) :: buffer(:) + + ! --- + +! write (*, *) "Packing: i = " // i // ", n = " // n // ", index = " // this%local_to_global(i) // ", pos = " // at%pos(:, i) + + call pack_buffer(at%properties, this%atoms_mask, i, n, buffer) + this%global_to_local(this%local_to_global(i)) = 0 ! This one is gone + + endsubroutine pack_atoms_buffer + + + !% Copy particle data from the receive buffer + subroutine unpack_atoms_buffer(this, at, n, buffer) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, intent(in) :: n + character(1), intent(in) :: buffer(:) + + ! --- + + integer :: i +! real(dp), pointer :: pos(:, :) + + ! --- + +! if (.not. assign_pointer(at%properties, "pos", pos)) then +! call system_abort("...") +! endif + +! do i = 1, n + i = 0 + do while (i < n) + at%Ndomain = at%Ndomain+1 + + call unpack_buffer(at%properties, this%atoms_mask, i, buffer, at%Ndomain) +! write (*, *) "Unpacked: n = " // at%Ndomain // ", index = " // this%local_to_global(at%Ndomain) // ", pos = " // pos(:, at%Ndomain) + this%global_to_local(this%local_to_global(at%Ndomain)) = at%Ndomain + +! call print("n = " // at%Ndomain // ", pos = " // at%pos(:, at%Ndomain)) + enddo + + endsubroutine unpack_atoms_buffer + + + !% Copy particle data from the receive buffer + subroutine unpack_atoms_buffer_if_in_domain(this, at, n, buffer, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, intent(in) :: n + character(1), intent(in) :: buffer(:) + integer, optional, intent(out) :: error + + ! --- + + integer :: i + real(dp) :: s(3) + real(dp), pointer :: pos(:, :) + + ! --- + + INIT_ERROR(error) + + if (.not. assign_pointer(at%properties, "pos", pos)) then + RAISE_ERROR("Property 'pos' not found.", error) + endif + + i = 0 + do while (i < n) + at%Ndomain = at%Ndomain+1 + + call unpack_buffer(at%properties, this%atoms_mask, i, buffer, at%Ndomain) + + s = sdompos(this, at, pos(1:3, at%Ndomain)) + if (all(s >= this%lower) .and. all(s < this%upper)) then + this%global_to_local(this%local_to_global(at%Ndomain)) = at%Ndomain + else + at%Ndomain = at%Ndomain-1 + endif + enddo + + endsubroutine unpack_atoms_buffer_if_in_domain + + + !% Communicate particles which left the domains + !% to the neighboring domains (former order routine) + subroutine domaindecomposition_comm_atoms(this, at, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, optional, intent(out) :: error + + ! --- + + ! + ! General and auxiliary variables + ! + + integer :: i, d + integer :: last_N + + ! + ! Structure variables, mpi and system structure + ! + + integer :: n_send_l, n_send_r, n_recv_l, n_recv_r + + real(dp) :: off_l(3), off_r(3), s + + ! --- + + INIT_ERROR(error) + + call print("DomainDecomposition : comm_atoms", PRINT_VERBOSE) + + call system_timer("domaindecomposition_comm_atoms") + + ! Update internal buffers + call update_sendrecv_masks(this, at) + + this%nit_p = this%nit_p + 1 + + do i = at%Ndomain+1, at%N + this%global_to_local(this%local_to_global(i)) = 0 + enddo + + ! + ! Loop over dimensions and distribute particle in the + ! respective direction + ! + + do d = 1, 3 + + if (this%decomposition(d) > 1) then + + last_N = at%Ndomain + at%Ndomain = 0 + + n_send_r = 0 + n_send_l = 0 + + do i = 1, last_N + + s = sdompos(this, at, at%pos(:, i), d) +! call print("d = " // d // ", i = " // i // ", s = " // s // ", lower = " // this%lower(d) // ", upper = " // this%upper(d)) + if (s >= this%upper(d)) then + ! Send to the right + + call pack_atoms_buffer(this, at, i, n_send_r, this%send_r) + + else if (s < this%lower(d)) then + ! Send to the left + + call pack_atoms_buffer(this, at, i, n_send_l, this%send_l) + + else + ! Keep on this processor and reorder + + at%Ndomain = at%Ndomain+1 + + if (at%Ndomain /= i) then + call copy_entry(at, i, at%Ndomain) + endif + + endif + + enddo + + this%n_send_p_tot = this%n_send_p_tot + n_send_r + n_send_l + + call sendrecv(this%mpi, & + this%send_r(1:n_send_r), this%r(d), 0, & + this%recv_l, this%l(d), 0, & + n_recv_l, error) + PASS_ERROR(error) + + call sendrecv(this%mpi, & + this%send_l(1:n_send_l), this%l(d), 1, & + this%recv_r, this%r(d), 1, & + n_recv_r, error) + PASS_ERROR(error) + + call print("DomainDecomposition : Send state buffers. Sizes: l = " // n_send_l/this%atoms_buffer_size // ", r = " // n_send_r/this%atoms_buffer_size, PRINT_NERD) + + call print("DomainDecomposition : Received state buffers. Sizes: l = " // n_recv_l/this%atoms_buffer_size // ", r = " // n_recv_r/this%atoms_buffer_size, PRINT_NERD) + + this%n_recv_p_tot = this%n_recv_p_tot + n_recv_r/this%atoms_buffer_size + n_recv_l/this%atoms_buffer_size + + off_l = 0.0_DP + ! This will be done by inbox + off_l(d) = this%off_l(d) + + off_r = 0.0_DP + ! This will be done by inbox + off_r(d) = this%off_r(d) + + call unpack_atoms_buffer(this, at, n_recv_l, this%recv_l) + call unpack_atoms_buffer(this, at, n_recv_r, this%recv_r) + + endif + + enddo + + at%N = at%Ndomain + if (at%Ndomain /= last_N) then + call print("DomainDecomposition : Repointing atoms object", PRINT_ANALYSIS) + call atoms_repoint(at) + endif + + this%Ntotal = sum(this%mpi, at%N, error) + +! call print("DomainDecomposition : Total number of atoms = " // this%Ntotal, PRINT_VERBOSE) + + call system_timer("domaindecomposition_comm_atoms") + + endsubroutine domaindecomposition_comm_atoms + + + !% Communicate all particles from this domain to all other domains + subroutine domaindecomposition_comm_atoms_to_all(this, at, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, optional, intent(out) :: error + + ! --- + + ! + ! General and auxiliary variables + ! + + integer :: i, j + integer :: last_N + + ! + ! Structure variables, mpi and system structure + ! + + integer :: n_send, n_recv + + real(dp) :: s(3) + + ! --- + + INIT_ERROR(error) + + call print("DomainDecomposition : comm_atoms_to_all", PRINT_VERBOSE) + call print("DomainDecomposition : decomposed = " // this%decomposed, & + PRINT_VERBOSE) + + ! Update internal buffers + call update_sendrecv_masks(this, at) + + ! + ! Loop over dimensions and distribute particle in the + ! respective direction + ! + + last_N = at%Ndomain + at%Ndomain = 0 + + n_send = 0 + + do i = 1, last_N + + ! Send always + call pack_atoms_buffer(this, at, i, n_send, this%send_r) + + s = sdompos(this, at, at%pos(:, i)) + if (.not. this%decomposed .or. & + all(s >= this%lower) .and. all(s < this%upper)) then + ! Keep on this processor and reorder + + at%Ndomain = at%Ndomain+1 + + if (at%Ndomain /= i) then + call copy_entry(at, i, at%Ndomain) + endif + + endif + + enddo + + do j = 0, this%mpi%n_procs-1 + + if (j == this%mpi%my_proc) then + call bcast(this%mpi, n_send, root=j, error=error) + PASS_ERROR(error) + +! call print("n_send = " // n_send // ", size(send_r) = " // size(this%send_r), PRINT_ALWAYS) + + call bcast(this%mpi, this%send_r(1:n_send), root=j, error=error) + PASS_ERROR(error) + else + call bcast(this%mpi, n_recv, root=j, error=error) + PASS_ERROR(error) + +! call print("n_recv = " // n_recv // ", size(recv_r) = " // size(this%recv_r), PRINT_ALWAYS) +! call print("n = " // (n_recv/this%atoms_buffer_size), PRINT_ALWAYS) + + call bcast(this%mpi, this%recv_r(1:n_recv), root=j, error=error) + PASS_ERROR(error) + + if (this%decomposed) then + call unpack_atoms_buffer_if_in_domain(this, at, & + n_recv, this%recv_r, & + error = error) + PASS_ERROR(error) + else + call unpack_atoms_buffer(this, at, n_recv, this%recv_r) + endif + endif + + enddo + + call print("DomainDecomposition : " // & + "Ndomain = " // at%Ndomain // ", Nbuffer = " // at%Nbuffer, & + PRINT_VERBOSE) + + if (this%decomposed) then + call print("DomainDecomposition : total number of atoms = " // & + sum(this%mpi, at%Ndomain), PRINT_VERBOSE) + endif + + at%N = at%Ndomain + if (at%Ndomain /= last_N) then + call print("DomainDecomposition : Repointing atoms object", PRINT_ANALYSIS) + call atoms_repoint(at) + endif + + call print("DomainDecomposition : Sorting atoms object", PRINT_ANALYSIS) + + ! Sort atoms by global index + call atoms_sort(at, "local_to_global", error=error) + PASS_ERROR(error) + + endsubroutine domaindecomposition_comm_atoms_to_all + + + !% Copy particle data from the (ghost) receive buffer + subroutine unpack_ghost_buffer(this, at, n, buffer, off) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, intent(in) :: n + character(1), intent(in) :: buffer(:) + real(dp), intent(in) :: off(3) + + ! --- + + integer :: i + + ! --- + + i = 0 + do while (i < n) + at%N = at%N+1 + call unpack_buffer(at%properties, this%ghost_mask, i, buffer, at%N) + at%pos(:, at%N) = at%pos(:, at%N) + off + this%global_to_local(this%local_to_global(at%N)) = at%N + enddo + + endsubroutine unpack_ghost_buffer + + + !% Communicate ghost particles to neighboring domains + !% (former prebinning routine). *bwidth* is the width of + !% the border. + subroutine domaindecomposition_comm_ghosts(this, at, new_list, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + logical, intent(in) :: new_list + integer, intent(out), optional :: error + + ! --- + + real(dp) :: upper(3), lower(3) + integer :: i, d, list_off_r, list_off_l, last_N + integer :: n_send_r, n_send_l, n_recv_r, n_recv_l + + real(dp) :: off_l(3), off_r(3), s + + ! --- + + INIT_ERROR(error) + + call print("DomainDecomposition : comm_ghosts", PRINT_NERD) + + call update_sendrecv_masks(this, at) + + call system_timer("domaindecomposition_comm_ghosts") + + this%nit_g = this%nit_g + 1 + + do d = 1, 3 + + if (this%periodic(d) .or. this%mpi%my_coords(d) /= 0) then + lower(d) = this%lower(d) + (at%g(d, :) .dot. this%border) + else + lower(d) = this%lower(d) + endif + + if (this%periodic(d) .or. this%mpi%my_coords(d) /= this%decomposition(d)-1) then + upper(d) = this%upper(d) - (at%g(d, :) .dot. this%border) + else + upper(d) = this%upper(d) + endif + + enddo + + call print("DomainDecomposition : upper = " // upper, PRINT_NERD) + call print("DomainDecomposition : lower = " // lower, PRINT_NERD) + + last_N = at%n + do i = at%Ndomain+1, at%N + this%global_to_local(this%local_to_global(i)) = 0 + enddo + at%N = at%Ndomain + + ! + ! Loop over dimensions and distribute particle in the + ! respective direction + ! + + list_off_r = 0 + list_off_l = 0 + do d = 1, 3 + + if (this%decomposition(d) > 1) then + + n_send_r = 0 + n_send_l = 0 + + if (new_list) then + + this%n_ghosts_r(d) = 0 + this%n_ghosts_l(d) = 0 + + do i = 1, at%N + s = sdompos(this, at, at%pos(:, i), d) + if (s >= upper(d)) then + call pack_buffer(at%properties, this%ghost_mask, & + i, & + n_send_r, this%send_r) + this%n_ghosts_r(d) = this%n_ghosts_r(d)+1 + this%ghosts_r(list_off_r+this%n_ghosts_r(d)) = this%local_to_global(i) + + else if (s < lower(d)) then + call pack_buffer(at%properties, this%ghost_mask, & + i, & + n_send_l, this%send_l) + + this%n_ghosts_l(d) = this%n_ghosts_l(d)+1 + this%ghosts_l(list_off_l+this%n_ghosts_l(d)) = this%local_to_global(i) + + endif + enddo + + else + + do i = 1, this%n_ghosts_r(d) + call pack_buffer(at%properties, this%ghost_mask, & + this%global_to_local(this%ghosts_r(list_off_r+i)), & + n_send_r, this%send_r) + enddo + + do i = 1, this%n_ghosts_l(d) + call pack_buffer(at%properties, this%ghost_mask, & + this%global_to_local(this%ghosts_l(list_off_l+i)), & + n_send_l, this%send_l) + enddo + + endif + + this%n_send_g_tot = this%n_send_g_tot + this%n_ghosts_r(d) + this%n_ghosts_l(d) + + call sendrecv(this%mpi, & + this%send_r(1:n_send_r), this%r(d), 0, & + this%recv_l, this%l(d), 0, & + n_recv_l, error) + PASS_ERROR(error) + + call sendrecv(this%mpi, & + this%send_l(1:n_send_l), this%l(d), 1, & + this%recv_r, this%r(d), 1, & + n_recv_r, error) + PASS_ERROR(error) + + call print("DomainDecomposition : Send ghost buffers. Sizes: l = " // n_send_l/this%ghost_buffer_size // ", r = " // n_send_r/this%ghost_buffer_size, PRINT_NERD) + call print("DomainDecomposition : Received ghost buffers. Sizes: l = " // n_recv_l/this%ghost_buffer_size // ", r = " // n_recv_r/this%ghost_buffer_size, PRINT_NERD) + + this%n_recv_g_tot = this%n_recv_g_tot + & + n_recv_r/this%ghost_buffer_size + & + n_recv_l/this%ghost_buffer_size + + off_l = 0.0_DP + off_l(d) = this%off_l(d) + + off_r = 0.0_DP + off_r(d) = this%off_r(d) + + call unpack_ghost_buffer(this, at, n_recv_r, this%recv_r, off_r) + call unpack_ghost_buffer(this, at, n_recv_l, this%recv_l, off_l) + + list_off_r = list_off_r + this%n_ghosts_r(d) + list_off_l = list_off_l + this%n_ghosts_l(d) + + endif + + enddo + + if (at%N /= last_N) then + call print("DomainDecomposition : Repointing atoms object", PRINT_ANALYSIS) + call atoms_repoint(at) + endif + + call system_timer("domaindecomposition_comm_ghosts") + + endsubroutine domaindecomposition_comm_ghosts + + + !% Copy forces to the (ghost) send buffer + subroutine copy_forces_to_send_ghosts(this, at, i, n, buffer) + implicit none + + type(DomainDecomposition), intent(in) :: this + type(Atoms), intent(inout) :: at + integer, intent(in) :: i + integer, intent(in) :: n + character(1), intent(inout) :: buffer(:) + + ! --- + + integer :: m + + ! --- + + m = n + call pack_buffer(at%properties, this%reverse_mask, i, m, buffer) + + endsubroutine copy_forces_to_send_ghosts + + + !% Copy particle data from the (ghost) receive buffer + subroutine copy_forces_from_recv_ghosts(this, at, cur, n, buffer) + implicit none + + type(DomainDecomposition), intent(in) :: this + type(Atoms), intent(inout) :: at + integer, intent(inout) :: cur + integer, intent(in) :: n + character(1), intent(in) :: buffer(:) + + ! --- + + integer :: i + + ! --- + + i = 0 + do while (i < n) + cur = cur+1 + + call unpack_buffer(at%properties, this%reverse_mask, i, buffer, cur) + enddo + + endsubroutine copy_forces_from_recv_ghosts + + + !% Communicate forces of ghost particles back. + !% This is needed for rigid object (i.e., water) or to reduce the + !% border size in BOPs. + subroutine domaindecomposition_comm_reverse(this, at, error) + implicit none + + type(DomainDecomposition), intent(inout) :: this + type(Atoms), intent(inout) :: at + integer, intent(out), optional :: error + + ! --- + + integer :: i, d, list_off_r, list_off_l, n_recv_r, n_recv_l, cur + + ! --- + + INIT_ERROR(error) + + call print("DomainDecomposition : comm_ghosts", PRINT_NERD) + + call update_sendrecv_masks(this, at) + + call system_timer("domaindecomposition_comm_reverse") + + ! + ! Loop over dimensions and distribute particle in the + ! respective direction + ! + + list_off_r = 0 + list_off_l = 0 + cur = at%Ndomain + do d = 1, 3 + + if (this%decomposition(d) > 1) then + + do i = 1, this%n_ghosts_r(d) + call copy_forces_to_send_ghosts(this, at, this%global_to_local(this%ghosts_r(list_off_r+i)), (i-1)*this%reverse_buffer_size, this%send_r) + enddo + + do i = 1, this%n_ghosts_l(d) + call copy_forces_to_send_ghosts(this, at, this%global_to_local(this%ghosts_l(list_off_l+i)), (i-1)*this%reverse_buffer_size, this%send_l) + enddo + + call sendrecv(this%mpi, & + this%send_r(1:this%reverse_buffer_size*this%n_ghosts_r(d)), & + this%r(d), 0, & + this%recv_l, this%l(d), 0, & + n_recv_l, error) + PASS_ERROR(error) + + call sendrecv(this%mpi, & + this%send_l(1:this%reverse_buffer_size*this%n_ghosts_l(d)), & + this%l(d), 1, & + this%recv_r, this%r(d), 1, & + n_recv_r, error) + PASS_ERROR(error) + + call copy_forces_from_recv_ghosts(this, at, cur, n_recv_l, this%recv_l) + call copy_forces_from_recv_ghosts(this, at, cur, n_recv_r, this%recv_r) + + list_off_r = list_off_r + this%n_ghosts_r(d) + list_off_l = list_off_l + this%n_ghosts_l(d) + + endif + + enddo + + call system_timer("domaindecomposition_comm_reverse") + + endsubroutine domaindecomposition_comm_reverse + + + !% Create a deep copy + subroutine domaindecomposition_deepcopy(to, from) + implicit none + + type(DomainDecomposition), intent(out) :: to + type(DomainDecomposition), intent(in) :: from + + ! --- + + to = from + + endsubroutine domaindecomposition_deepcopy + + ! + ! Supplement to the Dictionary object + ! + + !% Convert a list of keys to a mask + subroutine dictionary_keys_to_mask(this, keys, mask, s, error) + implicit none + + type(Dictionary), intent(in) :: this !% Dictionary object + type(Dictionary), intent(in) :: keys !% List of keys + logical, intent(out) :: mask(this%N) !% True if in keys + integer, intent(out), optional :: s !% Size of the buffer + integer, intent(out), optional :: error + + ! --- + + integer :: i, entry_i + + ! --- + + INIT_ERROR(error) + + mask = .false. + s = 0 + do i = 1, keys%N + entry_i = lookup_entry_i(this, string(keys%keys(i))) + if (entry_i == -1) then +! RAISE_ERROR("Could not find key '" // keys%keys(i) // "'.", error) + call print("DomainDecomposition : WARNING - Could not find key '" // keys%keys(i) // "', this property will not be communicated.", PRINT_ANALYSIS) + else + + select case(this%entries(entry_i)%type) + + case (T_REAL_A) + s = s + sizeof(this%entries(entry_i)%r_a(1)) + + case (T_INTEGER_A) + s = s + sizeof(this%entries(entry_i)%i_a(1)) + + case (T_LOGICAL_A) + s = s + sizeof(this%entries(entry_i)%l_a(1)) + + case (T_REAL_A2) + s = s + sizeof(this%entries(entry_i)%r_a2(:, 1)) + + case (T_INTEGER_A2) + s = s + sizeof(this%entries(entry_i)%i_a2(:, 1)) + + case default + RAISE_ERROR("Don't know how to handle entry type " // this%entries(entry_i)%type // " (key '" // this%keys(entry_i) // "').", error) + + endselect + + mask(entry_i) = .true. + + endif + enddo + + endsubroutine dictionary_keys_to_mask + + + !% Pack buffer, copy all entries with for which tag is true to the buffer + subroutine dictionary_pack_buffer(this, mask, & + data_i, buffer_i, buffer, error) + implicit none + + type(Dictionary), intent(in) :: this + logical, intent(in) :: mask(:) + integer, intent(in) :: data_i + integer, intent(inout) :: buffer_i + character(1), intent(inout) :: buffer(:) + integer, intent(out), optional :: error + + ! --- + + integer :: i, s + + ! --- + + INIT_ERROR(error) + + do i = 1, this%N + if (mask(i)) then + + select case(this%entries(i)%type) + + case (T_REAL_A) + s = sizeof(this%entries(i)%r_a(1)) + buffer(buffer_i+1:buffer_i+s) = & + transfer(this%entries(i)%r_a(data_i), buffer) + buffer_i = buffer_i + s + + case (T_INTEGER_A) + s = sizeof(this%entries(i)%i_a(1)) + buffer(buffer_i+1:buffer_i+s) = & + transfer(this%entries(i)%i_a(data_i), buffer) + buffer_i = buffer_i + s + + case (T_LOGICAL_A) + s = sizeof(this%entries(i)%l_a(1)) + buffer(buffer_i+1:buffer_i+s) = & + transfer(this%entries(i)%l_a(data_i), buffer) + buffer_i = buffer_i + s + + case (T_REAL_A2) + s = sizeof(this%entries(i)%r_a2(:, 1)) + buffer(buffer_i+1:buffer_i+s) = & + transfer(this%entries(i)%r_a2(:, data_i), buffer) + buffer_i = buffer_i + s + + case (T_INTEGER_A2) + s = sizeof(this%entries(i)%i_a2(:, 1)) + buffer(buffer_i+1:buffer_i+s) = & + transfer(this%entries(i)%i_a2(:, data_i), buffer) + buffer_i = buffer_i + s + + case default + RAISE_ERROR("Don't know how to handle entry type " // this%entries(i)%type // " (key '" // this%keys(i) // "').", error) + + endselect + + endif + enddo + + endsubroutine dictionary_pack_buffer + + + !% Unpack buffer, copy all entries with for which mask is true from the buffer + subroutine dictionary_unpack_buffer(this, mask, & + buffer_i, buffer, data_i, error) + implicit none + + type(Dictionary), intent(inout) :: this + logical, intent(in) :: mask(:) + integer, intent(inout) :: buffer_i + character(1), intent(in) :: buffer(:) + integer, intent(in) :: data_i + integer, intent(out), optional :: error + + ! --- + + integer :: i, ndims, s + + ! --- + + INIT_ERROR(error) + + do i = 1, this%N + if (mask(i)) then + + select case(this%entries(i)%type) + + case (T_REAL_A) + s = sizeof(this%entries(i)%r_a(1)) + this%entries(i)%r_a(data_i) = & + transfer(buffer(buffer_i+1:buffer_i+s), 1.0_DP) + buffer_i = buffer_i + s + + case (T_INTEGER_A) + s = sizeof(this%entries(i)%i_a(1)) + this%entries(i)%i_a(data_i) = & + transfer(buffer(buffer_i+1:buffer_i+s), 1) + buffer_i = buffer_i + s + + case (T_LOGICAL_A) + this%entries(i)%l_a(data_i) = & + transfer(buffer(buffer_i+1:), .true.) + buffer_i = buffer_i + sizeof(this%entries(i)%l_a(1)) + + case (T_REAL_A2) + s = sizeof(this%entries(i)%r_a2(:, 1)) + ndims = size(this%entries(i)%r_a2, 1) + this%entries(i)%r_a2(:, data_i) = & + transfer(buffer(buffer_i+1:buffer_i+s), 1.0_DP, ndims) + buffer_i = buffer_i + s + + case (T_INTEGER_A2) + s = sizeof(this%entries(i)%i_a2(:, 1)) + ndims = size(this%entries(i)%i_a2, 1) + this%entries(i)%i_a2(:, data_i) = & + transfer(buffer(buffer_i+1:buffer_i+s), 1.0_DP, ndims) + buffer_i = buffer_i + s + + case default + RAISE_ERROR("Don't know how to handle entry type " // this%entries(i)%type // " (key '" // this%keys(i) // "').", error) + + endselect + + endif + enddo + + endsubroutine dictionary_unpack_buffer + +endmodule DomainDecomposition_module diff --git a/src/libAtoms/DynamicalSystem.F90 b/src/libAtoms/DynamicalSystem.F90 new file mode 100644 index 0000000000..3e218a752f --- /dev/null +++ b/src/libAtoms/DynamicalSystem.F90 @@ -0,0 +1,3287 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Dynamical System module +!X +!% A DynamicalSystem object contains an Atoms object, which holds infomation about +!% velocities and accelerations of each atom, scalar quantities such as +!% thermostat settings, and logical masks so that thermostatting can be applied +!% to selected atoms etc. +!% +!% In Fortran code, initialise a DynamicalSystem object like this: +!%> call initialise(MyDS, MyAtoms) +!% which (shallowly) copies MyAtoms into the internal atoms structure (and so +!% MyAtoms is not required by MyDS after this call and can be finalised). In Python, +!% a DynamicalSystem can be initialised from an Atoms instance: +!%> MyDS = DynamicalSystem(MyAtoms) +!% +!% +!% A DynamicalSystem is constructed from an Atoms object +!% 'atoms'. The initial velocities and accelerations can optionally be +!% specificed as '(3,atoms.n)' arrays. The 'constraints' and +!% 'rigidbodies' arguments can be used to specify the number of +!% constraints and rigid bodies respectively (the default is zero in +!% both cases). +!% +!% DynamicalSystem has an integrator, +!%> call advance_verlet(MyDS,dt,forces) +!% which takes a set of forces and integrates the equations of motion forward +!% for a time 'dt'. +!% +!% All dynamical variables are stored inside the Atoms' :attr:`~quippy.atoms.Atoms.properties` Dictionary. +!% +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module dynamicalsystem_module + + use error_module + use system_module + use mpi_context_module + use units_module + use linearalgebra_module + use table_module + use periodictable_module + use dictionary_module, only: STRING_LENGTH + use atoms_types_module + use atoms_module + use rigidbody_module + use group_module + use constraints_module + use thermostat_module + use barostat_module + +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif + implicit none +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif + private + + public :: dynamicalsystem, add_atoms, remove_atoms, print, initialise, finalise + public :: kinetic_energy, kinetic_virial, angular_momentum, momentum, n_thermostat, add_thermostat, remove_thermostat, print_thermostats + public :: set_barostat, add_thermostats, update_thermostat, gaussian_velocity_component + public :: TYPE_CONSTRAINED, TYPE_ATOM, ds_print_status, rescale_velo, zero_momentum + public :: advance_verlet1, advance_verlet2, advance_verlet, distance_relative_velocity, ds_amend_constraint + public :: torque, temperature, zero_angular_momentum, is_damping_enabled, get_damping_time, enable_damping, disable_damping, moment_of_inertia_tensor, thermostat_temperatures + public :: ds_add_constraint, ds_save_state, ds_restore_state + + public :: constrain_bondanglecos, & + constrain_bondlength, & + constrain_bondlength_sq, & + constrain_bondlength_dev_pow, & + constrain_bondlength_diff, & + constrain_gap_energy, & + constrain_atom_plane, & + constrain_struct_factor_like_mag, & + constrain_struct_factor_like_r, & + constrain_struct_factor_like_i + + !Different integration types. Stored in group%type. Used by advance_verlet to integrate + !the equations of motion in different ways. + integer, parameter :: TYPE_IGNORE = 0 + integer, parameter :: TYPE_ATOM = 1 + integer, parameter :: TYPE_CONSTRAINED = 2 + integer, parameter :: TYPE_RIGID = 3 + + type DynamicalSystem + + ! Scalar members + integer :: N = 0 !% Number of atoms + integer :: nSteps = 0 !% Number of integration steps + integer :: Nrigid = 0 !% Number of rigid bodies + integer :: Nconstraints = 0 !% Number of constraints + integer :: Nrestraints = 0 !% Number of restraints + integer :: Ndof = 0 !% Number of degrees of freedom + real(dp) :: t = 0.0_dp !% Time + real(dp) :: dt = 1.0_dp !% Last time step + real(dp) :: avg_temp = 0.0_dp !% Time-averaged temperature + real(dp) :: cur_temp = 0.0_dp !% Current temperature + real(dp) :: avg_time = 100.0_dp !% Averaging time, in fs + real(dp) :: dW = 0.0_dp !% Increment of work done this time step + real(dp) :: work = 0.0_dp !% Total work done + real(dp) :: Epot = 0.0_dp !% Total potential energy + real(dp) :: Ekin = 0.0_dp !% Current kinetic energy + real(dp) :: Wkin(3, 3) = 0.0_dp !% Current kinetic contribution to the virial + real(dp) :: ext_energy = 0.0_dp !% Extended energy + real(dp) :: thermostat_dW = 0.0_dp !% Increment of work done by thermostat + real(dp) :: thermostat_work = 0.0_dp !% Total work done by thermostat + logical :: initialised = .false. + + integer :: random_seed !% RNG seed, used by 'ds_save_state' and 'ds_restore_state' only. + + ! Array members + integer, pointer, dimension(:) :: group_lookup !% Stores which group atom $i$ is in + + ! Derived type members + type(Atoms), pointer :: atoms => NULL() + + ! Derived Type array members + type(Constraint), allocatable, dimension(:) :: constraint, restraint + type(RigidBody), allocatable, dimension(:) :: rigidbody + type(Group), allocatable, dimension(:) :: group + type(thermostat), allocatable, dimension(:) :: thermostat + type(barostat) :: barostat + logical :: print_thermostat_temps = .true. + + end type DynamicalSystem + + interface assignment(=) + module procedure DS_Assignment + end interface + + !% Add one or more atoms to this DynamicalSystem. Equivalent to 'Atoms%add_atoms', + !% but also appends the number of degrees of freedom correctly. + interface add_atoms + module procedure ds_add_atom_single, ds_add_atom_multiple + end interface add_atoms + + !% Remove one or more atoms from this DynamicalSystem. Equivalent of 'Atoms%remove_atoms', + !%but also amends the number of degrees of freedom correctly. + interface remove_atoms + module procedure ds_remove_atom_single, ds_remove_atom_multiple + end interface remove_atoms + + interface print + module procedure ds_print + end interface + + !% Initialise this DynamicalSystem from an Atoms object + interface initialise + module procedure ds_initialise + end interface initialise + + !% Free up the memory used by this DynamicalSystem + interface finalise + module procedure ds_finalise + end interface finalise + + interface kinetic_energy + module procedure single_kinetic_energy, arrays_kinetic_energy, atoms_kinetic_energy, ds_kinetic_energy + end interface kinetic_energy + + interface kinetic_virial + module procedure single_kinetic_virial, arrays_kinetic_virial + module procedure atoms_kinetic_virial, ds_kinetic_virial + endinterface kinetic_virial + + interface angular_momentum + module procedure arrays_angular_momentum, atoms_angular_momentum, ds_angular_momentum + end interface angular_momentum + + interface momentum + module procedure arrays_momentum, atoms_momentum, ds_momentum + end interface momentum + + !% Add a new thermostat to this DynamicalSystem. 'type' should + !% be one of the following thermostat types: + !% + !% * 'THERMOSTAT_NONE' + !% * 'THERMOSTAT_LANGEVIN' + !% * 'THERMOSTAT_NOSE_HOOVER' + !% * 'THERMOSTAT_NOSE_HOOVER_LANGEVIN' + !% * 'THERMOSTAT_LANGEVIN_NPT' + !% * 'THERMOSTAT_LANGEVIN_PR' + !% * 'THERMOSTAT_NPH_ANDERSEN' + !% * 'THERMOSTAT_NPH_PR' + !% * 'THERMOSTAT_LANGEVIN_OU' + !% * 'THERMOSTAT_LANGEVIN_NPT_NB' + !% + !% 'T' is the target temperature. 'Q' is the Nose-Hoover coupling constant. Only one + !% of 'tau' or 'gamma' should be given. 'p' is the external + !% pressure for the case of Langevin NPT. + interface add_thermostat + module procedure ds_add_thermostat + end interface add_thermostat + + interface remove_thermostat + module procedure ds_remove_thermostat + end interface remove_thermostat + + interface print_thermostats + module procedure ds_print_thermostats + end interface print_thermostats + + interface set_barostat + module procedure ds_set_barostat + end interface set_barostat + + interface add_thermostats + module procedure ds_add_thermostats + end interface add_thermostats + + interface update_thermostat + module procedure ds_update_thermostat + end interface update_thermostat + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X INITIALISE AND FINALISE + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine ds_initialise(this,atoms_in,velocity,acceleration,constraints,restraints,rigidbodies,error) + + type(DynamicalSystem), intent(inout) :: this + type(Atoms), target :: atoms_in + real(dp), dimension(:,:), optional, intent(in) :: velocity + real(dp), dimension(:,:), optional, intent(in) :: acceleration + integer, optional, intent(in) :: constraints, restraints + integer, optional, intent(in) :: rigidbodies + integer :: i,N + integer, optional, intent(out) :: error + + logical :: added_avgpos, added_avgke + + ! --- + + INIT_ERROR(error) + + ! Check to see if the object has already been initialised + if (this%initialised) call ds_finalise(this) + + N = atoms_in%Nbuffer + this%N = N + + ! Check the atomic numbers + do i = 1, atoms_in%N + if (atoms_in%Z(i) < 1) then + RAISE_ERROR('DS_Initialise: Atom '//i//' has not had its atomic number set', error) + end if + end do + + ! 'group_lookup' needs to be in the Atoms object in order to be + ! distributed properly with domain decomposition enabled. + ! XXX FIXME this crashes in quippy + !call add_property(this%atoms, 'group_lookup', 0, & + ! ptr=this%group_lookup, error=error) + !PASS_ERROR(error) + ! XXX FIXME this is the temporary fix + allocate(this%group_lookup(N)) + ! allocate local arrays + allocate(this%group(N)) + + ! Now point to the atoms + call shallowcopy(this%atoms, atoms_in) + + ! Add single valued properties to this%atoms + ! XXX FIXME also not quippy compatible, check + !call set_value(this%atoms%properties, 'time', 0.0_DP) + !if (.not. assign_pointer(this%atoms%properties, 'time', this%t)) then + ! RAISE_ERROR("Could not assign property 'time'.", error) + !endif + + ! Add properties for the dynamical variables to this%atoms if they don't + ! already exist + call add_property(this%atoms, 'mass', 0.0_DP, error=error) + PASS_ERROR(error) + call set_comm_property(this%atoms, 'mass', & + comm_atoms=.true.) + call add_property(this%atoms, 'travel', 0, n_cols=3, error=error) + PASS_ERROR(error) + call set_comm_property(this%atoms, 'travel', & + comm_atoms=.true.) + + call add_property(this%atoms, 'move_mask', 1, error=error) + PASS_ERROR(error) + call set_comm_property(this%atoms, 'move_mask', & + comm_atoms=.true.) + call add_property(this%atoms, 'damp_mask', 1, error=error) + PASS_ERROR(error) + call set_comm_property(this%atoms, 'damp_mask', & + comm_atoms=.true.) + call add_property(this%atoms, 'thermostat_region', 1, error=error) + PASS_ERROR(error) + call set_comm_property(this%atoms, 'thermostat_region', & + comm_atoms=.true.) + + added_avgke = .not. has_property(this%atoms, 'avg_ke') + call add_property(this%atoms, 'avg_ke', 0.0_dp, error=error) + PASS_ERROR(error) + call set_comm_property(this%atoms, 'avg_ke', & + comm_atoms=.true.) + call add_property(this%atoms, 'velo', 0.0_dp, n_cols=3, error=error) + PASS_ERROR(error) + call set_comm_property(this%atoms, 'velo', & + comm_atoms=.true.) + call add_property(this%atoms, 'acc', 0.0_dp, n_cols=3, error=error) + PASS_ERROR(error) + added_avgpos = .not. has_property(this%atoms, 'avgpos') + call add_property(this%atoms, 'avgpos', 0.0_dp, n_cols=3, error=error) + PASS_ERROR(error) + call set_comm_property(this%atoms, 'avgpos', & + comm_atoms=.true.) + call add_property(this%atoms, 'oldpos', 0.0_dp, n_cols=3, error=error) + PASS_ERROR(error) + + ! Update pointers in this%atoms so we can use this%atoms%velo etc. + call atoms_repoint(this%atoms) + + ! Set mass - unless already specified + if (maxval(abs(this%atoms%mass)) < 1e-5_dp) then + this%atoms%mass = ElementMass(this%atoms%Z) + end if + + ! The input arrays must have 3N components if they are present + ! if not, local arrays are set to zero + + if(present(velocity)) then + call check_size('Velocity',velocity,(/3,N/),'DS_Initialise',error) + PASS_ERROR(error) + this%atoms%velo = velocity + end if + + if(present(acceleration)) then + call check_size('Acceleration',acceleration,(/3,N/),'DS_Initialise',error) + PASS_ERROR(error) + this%atoms%acc = acceleration + end if + + ! Initialize oldpos and avgpos + if (added_avgpos) then + do i = 1, this%N + this%atoms%avgpos(:,i) = realpos(this%atoms,i) + end do + endif + this%atoms%oldpos = this%atoms%avgpos + if (added_avgke) then + do i=1, this%atoms%N + this%atoms%avg_ke(i) = 0.5_dp*this%atoms%mass(i)*normsq(this%atoms%velo(:,i)) + end do + endif + + ! Check for constraints + if (present(constraints)) then + if (constraints > 0) then + allocate(this%constraint(constraints)) + this%Nconstraints = 0 + end if + end if + + ! Check for restraints + if (present(restraints)) then + if (restraints > 0) then + allocate(this%restraint(restraints)) + this%Nrestraints = 0 + end if + end if + + ! Check for rigid bodies + if (present(rigidbodies)) then + if (rigidbodies > 0) then + allocate(this%rigidbody(rigidbodies)) + this%Nrigid = 0 + end if + end if + + ! Initialise all the groups, default to TYPE_ATOM + do i = 1, this%N + call initialise(this%group(i),TYPE_ATOM, atoms = (/i/)) + this%group_lookup(i) = i + end do + + this%Ndof = 3 * this%N + + allocate(this%thermostat(0:0)) + call initialise(this%thermostat(0),THERMOSTAT_NONE,0.0_dp) !a dummy thermostat, which is turned into + !a langevin thermostat if damping is needed + call initialise(this%barostat,BAROSTAT_NONE) + this%cur_temp = temperature(this, include_all=.true., instantaneous=.true.) + this%avg_temp = this%cur_temp + + this%initialised = .true. + + call verbosity_push_decrement(PRINT_ANALYSIS) + call print(this) + call verbosity_pop() + + end subroutine ds_initialise + + + subroutine ds_finalise(this, error) + + type(DynamicalSystem), intent(inout) :: this + integer, optional, intent(out) :: error + + ! --- + + INIT_ERROR(error) + + if (this%initialised) then + call finalise_ptr(this%atoms) + call finalise(this%group) + deallocate(this%group_lookup) + + !Finalise constraints + if (allocated(this%constraint)) call finalise(this%constraint) + + !Finalise restraints + if (allocated(this%restraint)) call finalise(this%restraint) + + !Finalise rigid bodies + if (allocated(this%rigidbody)) call finalise(this%rigidbody) + + call finalise(this%thermostat) + call finalise(this%barostat) + + this%N = 0 + this%nSteps = 0 + this%Nrigid = 0 + this%Nconstraints = 0 + this%Nrestraints = 0 + this%Ndof = 0 + this%t = 0.0_dp + this%avg_temp = 0.0_dp + this%dW = 0.0_dp + this%work = 0.0_dp + this%thermostat_dW = 0.0_dp + this%thermostat_work = 0.0_dp + this%ext_energy = 0.0_dp + this%Epot = 0.0_dp + + this%initialised = .false. + + end if + + end subroutine ds_finalise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X FREE EXCESS MEMORY USED BY GROUPS + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Free up excess memory used by Groups + subroutine ds_free_groups(this) + + type(DynamicalSystem), intent(inout) :: this + + call tidy_groups(this%group) + call groups_create_lookup(this%group,this%group_lookup) + + end subroutine ds_free_groups + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X ASSIGNMENT + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Overloaded assignment operator for DynamicalSystems + subroutine ds_assignment(to,from) + + type(DynamicalSystem), intent(inout) :: to + type(DynamicalSystem), intent(in) :: from + + integer :: from_constraint_size, from_restraint_size, from_rigidbody_size + + ! Re-initialise the destination object to be the correct size. + ! Note: size(from%constraint) in general is not equal to from%Nconstraints etc. + ! Also, the constraints aren't added using add_constraint etc. since this + ! will automatically evaluate the constraints at the current positions, which may not + ! correspond to the values currently stored. Same for rigid bodies. + + from_constraint_size = 0 + if (allocated(from%constraint)) from_constraint_size = size(from%constraint) + from_restraint_size = 0 + if (allocated(from%restraint)) from_restraint_size = size(from%restraint) + from_rigidbody_size = 0 + if (allocated(from%rigidbody)) from_rigidbody_size = size(from%rigidbody) + + call initialise(to, from%atoms, constraints=from_constraint_size, restraints=from_restraint_size, rigidbodies=from_rigidbody_size) + + ! Copy over scalar members + ! to%N is set in the initialisation 1 + to%nSteps = from%nSteps !2 + to%Nrigid = from%Nrigid !4 + to%Nconstraints = from%Nconstraints !5 + to%Nrestraints = from%Nrestraints !5 + to%Ndof = from%Ndof !6 + + to%t = from%t !8 + to%avg_temp = from%avg_temp !11 + to%avg_time = from%avg_time !12 + to%dW = from%dW !18 + to%work = from%work !19 + to%Epot = from%Epot !20 + to%ext_energy = from%ext_energy !21 + to%thermostat_dW = from%thermostat_dW !22 + to%thermostat_work = from%thermostat_work !23 + ! to%initialised is set in initialisation + + ! Copy over array members + to%group_lookup = from%group_lookup + + ! Derived type members + ! to%atoms already set + if (from%Nconstraints /= 0) to%constraint = from%constraint + if (from%Nrestraints /= 0) to%restraint = from%restraint + if (from%Nrigid /= 0) to%rigidbody = from%rigidbody + if (size(to%group)/=size(from%group)) then + deallocate(to%group) + allocate(to%group(size(from%group))) + end if + to%group = from%group + + ! Copy thermostats - will have been wiped by ds_initialise + ! (uses overloaded routine to copy array of thermostats) + ! to%thermostat = from%thermostat + call thermostat_array_assignment(to%thermostat, from%thermostat) + to%barostat = from%barostat + + end subroutine ds_assignment + + !% Save the state of a DynamicalSystem. The output object + !% cannot be used as an initialised DynamicalSystem since + !% connectivity and group information is not copied to save + !% memory. Only scalar members and the 'ds%atoms' object + !% (minus 'ds%atoms%connect') are copied. The current + !% state of the random number generator is also saved. + subroutine ds_save_state(to, from, error) + + type(DynamicalSystem), intent(inout) :: to + type(DynamicalSystem), intent(in) :: from + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if (.not. to%initialised) then + RAISE_ERROR('ds_save_state: target DynamicalSystem "to" not initialised', error) + end if + + if (associated(to%atoms, from%atoms)) then + ! Both DynamicalSystem object point to the same Atoms object, so we + ! need to allocate our own buffer. + allocate(to%atoms) + to%atoms%own_this = .true. + endif + + ! Copy over scalar members + to%N = from%N !1 + to%nSteps = from%nSteps !2 + to%Nrigid = from%Nrigid !4 + to%Nconstraints = from%Nconstraints !5 + to%Nrestraints = from%Nrestraints !6 + to%Ndof = from%Ndof !7 + + to%t = from%t !8 + to%avg_temp = from%avg_temp !11 + to%avg_time = from%avg_time !12 + to%dW = from%dW !18 + to%work = from%work !19 + to%Epot = from%Epot !20 + to%ext_energy = from%ext_energy !21 + to%thermostat_dW = from%thermostat_dW !22 + to%thermostat_work = from%thermostat_work !23 + + to%random_seed = system_get_random_seed() + + call atoms_copy_without_connect(to%atoms, from%atoms, error=error) + PASS_ERROR(error) + + end subroutine ds_save_state + + !% Restore a DynamicalSystem to a previously saved state. + !% Only scalar members and 'ds%atoms' (minus 'ds%atoms%connect') + !% are copied back; 'to' should be a properly initialised + !% DynamicalSystem object. The saved state of the random + !% number generator is also restored. 'calc_dists()' is + !% called on the restored atoms object. + subroutine ds_restore_state(to, from) + + type(DynamicalSystem), intent(inout) :: to + type(DynamicalSystem), intent(in) :: from + + ! Copy over scalar members + to%N = from%N !1 + to%nSteps = from%nSteps !2 + to%Nrigid = from%Nrigid !4 + to%Nconstraints = from%Nconstraints !5 + to%Nrestraints = from%Nrestraints !6 + to%Ndof = from%Ndof !7 + + to%t = from%t !8 + to%avg_temp = from%avg_temp !11 + to%avg_time = from%avg_time !12 + to%dW = from%dW !18 + to%work = from%work !19 + to%Epot = from%Epot !20 + to%ext_energy = from%ext_energy !21 + to%thermostat_dW = from%thermostat_dW !22 + to%thermostat_work = from%thermostat_work !23 + + call system_reseed_rng(from%random_seed) + + call atoms_copy_without_connect(to%atoms, from%atoms) + call calc_dists(to%atoms) + + end subroutine ds_restore_state + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X ADDING / REMOVING ATOMS + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine ds_add_atom_single(this,z,mass,p,v,a,t, error) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: z + real(dp), optional, intent(in) :: mass + real(dp), optional, dimension(3), intent(in) :: p,v,a + integer, optional, dimension(3), intent(in) :: t + integer, optional, intent(out) :: error + + real(dp) :: my_mass, my_p(3), my_v(3), my_a(3) + integer :: my_t(3) + + INIT_ERROR(error) + + my_mass = optional_default(ElementMass(Z),mass) + my_p = optional_default((/0.0_dp,0.0_dp,0.0_dp/),p) + my_v = optional_default((/0.0_dp,0.0_dp,0.0_dp/),v) + my_a = optional_default((/0.0_dp,0.0_dp,0.0_dp/),a) + my_t = optional_default((/0,0,0/),t) + + call ds_add_atom_multiple(this, (/z/), (/my_mass/), & + reshape(my_p, (/3,1/)), & + reshape(my_v, (/3,1/)), & + reshape(my_a, (/3,1/)), & + reshape(my_t, (/3,1/)), error) + PASS_ERROR(error) + + end subroutine ds_add_atom_single + + ! + ! Updated to work with groups. NEEDS TESTING + ! + subroutine ds_add_atom_multiple(this,z,mass,p,v,a,t,error) + + type(DynamicalSystem), intent(inout) :: this + integer, dimension(:), intent(in) :: z + real(dp), dimension(:), optional, intent(in) :: mass + real(dp), dimension(:,:), optional, intent(in) :: p,v,a + integer, dimension(:,:), optional, intent(in) :: t + integer, optional, intent(out) :: error + + integer :: oldN, newN, n, f, i + integer, dimension(this%N) :: tmp_group_lookup + type(Group), dimension(:), allocatable :: tmp_group + + INIT_ERROR(error) + + oldN = this%N + + ! Check the sizes are ok + n = size(z) + call check_size('Position',p,(/3,n/),'DS_Add_Atoms',error) + PASS_ERROR(error) + + call check_size('Velocity',v,(/3,n/),'DS_Add_Atoms', error) + PASS_ERROR(error) + + call check_size('Acceleration',a,(/3,n/),'DS_Add_Atoms', error) + PASS_ERROR(error) + + newN = oldN + n + + !Copy all non-scalar data into the temps + tmp_group_lookup = this%group_lookup + + !Adjust the size of the dynamical system's arrays + deallocate(this%group_lookup) + allocate(this%group_lookup(newN)) + + ! Implement the changes in Atoms + call add_atoms(this%atoms,pos=p,Z=z,mass=mass,velo=v,acc=a,travel=t) + + !update the scalars (if needed) + this%N = newN + this%Ndof = this%Ndof + 3*n + + !See if there are enough free groups to accommodate the new atoms + f = Num_Free_Groups(this%group) + if (f < n) then + !We need more groups: + !Make a copy of the current groups + allocate(tmp_group(size(this%group))) + tmp_group = this%group + !Resize the group array + call finalise(this%group) + allocate(this%group(size(tmp_group) + n - f)) + !Copy the groups back + this%group(1:size(tmp_group)) = tmp_group + call finalise(tmp_group) + end if + + !Add the new groups + do i = oldN+1, newN + f = Free_Group(this%group) + call group_add_atom(this%group(f),i) + call set_type(this%group(f),TYPE_ATOM) !default to TYPE_ATOM + end do + + !Rebuild the lookup table + call groups_create_lookup(this%group,this%group_lookup) + + end subroutine ds_add_atom_multiple + + + subroutine ds_remove_atom_single(this,i,error) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i + integer, intent(out), optional :: error + + INIT_ERROR(error) + call ds_remove_atom_multiple(this,(/i/),error) + PASS_ERROR(error) + + end subroutine ds_remove_atom_single + + + + subroutine ds_remove_atom_multiple(this,atomlist_in,error) + + type(DynamicalSystem), intent(inout) :: this + integer, dimension(:), intent(in) :: atomlist_in + integer, intent(out), optional :: error + + integer, dimension(size(atomlist_in)) :: atomlist + integer :: oldN, newN, g, i, copysrc + + INIT_ERROR(error) + + !Make our own copy of the indices so that we can sort them + atomlist = atomlist_in + call insertion_sort(atomlist) + + !Check for repeated indices, and non-TYPE_ATOM atoms + do i = 1, size(atomlist) + if (Atom_Type(this,atomlist(i)) /= TYPE_ATOM) then + RAISE_ERROR('Remove_Atoms: Atom '//atomlist(i)//' is not a normal atom', error) + end if + if (i > 1) then + if (atomlist(i) == atomlist(i-1)) then + RAISE_ERROR('Remove_Atoms: Tried to remove the same atom twice ('//atomlist(i)//')', error) + end if + end if + end do + + oldN = this%N + newN = this%N - size(atomlist) + + ! Implement the data changes in the atoms structure + ! Since we're mangling the atom indices and some atoms are being removed, the + ! connection data will no longer be valid after this + call remove_atoms(this%atoms,atomlist) + + !Make sure the group lookup table is up-to-date + call groups_create_lookup(this%group,this%group_lookup) + + !Delete all atoms in atomlist from their respective groups + do i = 1, size(atomlist) + g = this%group_lookup(atomlist(i)) + call group_delete_atom(this%group(g),atomlist(i)) + end do + + ! Algorithm: Find first atom to be removed and last atom to not be removed + ! and swap them. Repeat until all atoms to be removed are at the end. + ! note: this loop must be logically identical to the corresponding one in + ! Atoms + copysrc = oldN + do i=1,size(atomlist) + + do while(Is_in_array(atomlist,copysrc)) + copysrc = copysrc - 1 + end do + + if (atomlist(i) > copysrc) exit + + !Relabel copysrc to atomlist(i) in copysrc's group + + g = this%group_lookup(copysrc) + call group_delete_atom(this%group(g),copysrc) + call group_add_atom(this%group(g),atomlist(i)) + + copysrc = copysrc - 1 + + end do + + !Resize dynamical system's arrays + deallocate(this%group_lookup) + allocate(this%group_lookup(newN)) + + !Update scalars + this%N = newN + this%Ndof = this%Ndof - 3*size(atomlist) + + !Rebuild the group lookup table + call groups_create_lookup(this%group,this%group_lookup) + + end subroutine ds_remove_atom_multiple + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Atom - Group lookup + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + !% Look up the type of the group that atom i belongs to + ! + pure function atom_type(this,i) + + type(DynamicalSystem), intent(in) :: this + integer, intent(in) :: i + integer :: atom_type + + atom_type = this%group(this%group_lookup(i))%type + + end function atom_type + + ! + !% If an atom is in the list, add the rest of its group + ! + subroutine add_group_members(this,list) + + type(dynamicalsystem), intent(in) :: this + type(table), intent(inout) :: list + + integer :: i, j, n, g, nn, jn + + do n = 1, list%N + + i = list%int(1,n) + g = this%group_lookup(i) + do nn = 1, Group_N_Atoms(this%group(g)) + j = Group_Nth_Atom(this%group(g),nn) + jn = find_in_array(int_part(list,1),j) + if (jn == 0) call append(list,(/j,list%int(2:,n)/)) + end do + + end do + + end subroutine add_group_members + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Adding a thermostat + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine ds_set_barostat(this,type,p_ext,hydrostatic_strain,diagonal_strain,finite_strain_formulation,tau_epsilon,W_epsilon,T,W_epsilon_factor,thermalise) + type(dynamicalsystem), intent(inout) :: this + integer, intent(in) :: type + real(dp), intent(in) :: p_ext + logical, intent(in) :: hydrostatic_strain, diagonal_strain, finite_strain_formulation + real(dp), intent(in) :: tau_epsilon + real(dp), optional, intent(in) :: W_epsilon, T, W_epsilon_factor + logical, optional, intent(in) :: thermalise + + real(dp) :: gamma_epsilon + + if (tau_epsilon > 0.0_dp) then + gamma_epsilon = 1.0_dp/tau_epsilon + else + gamma_epsilon = 0.0_dp + endif + + call initialise(this%barostat, type=type, p_ext=p_ext, hydrostatic_strain=hydrostatic_strain, diagonal_strain=diagonal_strain, & + finite_strain_formulation=finite_strain_formulation, cell_volume=cell_volume(this%atoms), W_epsilon=W_epsilon, & + Ndof=real(this%Ndof,dp), gamma_epsilon=gamma_epsilon, T=T, W_epsilon_factor=W_epsilon_factor, thermalise=thermalise) + + end subroutine ds_set_barostat + + function n_thermostat(this) + type(dynamicalsystem), intent(in) :: this + integer n_thermostat + + n_thermostat = size(this%thermostat) + + end function n_thermostat + + subroutine ds_remove_thermostat(this, index) + type(dynamicalsystem), intent(inout) :: this + integer, intent(in) :: index + + call remove_thermostat(this%thermostat, index) + + end subroutine ds_remove_thermostat + + subroutine ds_add_thermostat(this,type,T,gamma,Q,tau,tau_cell, p, bulk_modulus_estimate, cell_oscillation_time, NHL_tau, NHL_mu, massive, region_i) + + type(dynamicalsystem), intent(inout) :: this + integer, intent(in) :: type + real(dp), intent(in) :: T + real(dp), optional, intent(in) :: gamma + real(dp), optional, intent(in) :: Q + real(dp), optional, intent(in) :: tau + real(dp), optional, intent(in) :: tau_cell + real(dp), optional, intent(in) :: bulk_modulus_estimate + real(dp), optional, intent(in) :: cell_oscillation_time + real(dp), optional, intent(in) :: p + real(dp), optional, intent(in) :: NHL_tau, NHL_mu + logical, optional, intent(in) :: massive + integer, optional, intent(out) :: region_i + + real(dp) :: w_p, gamma_cell, volume_0, my_bulk_modulus_estimate, my_cell_oscillation_time !, mass1, mass2 + real(dp) :: gamma_eff, NHL_gamma_eff + + if (.not. present(Q)) then + if (count( (/present(gamma), present(tau) /) ) /= 1 ) & + call system_abort('ds_add_thermostat: exactly one of gamma, tau must be present if Q is not') + endif + + if (present(gamma)) then + gamma_eff = gamma + if (present(tau)) call print("WARNING: ds_add_thermostat got gamma and tau, gamma overriding tau", PRINT_ALWAYS) + else + gamma_eff = 0.0_dp + if (present(tau)) then + if (tau /= 0.0_dp) then + gamma_eff = 1.0_dp/tau + endif + endif + endif + + NHL_gamma_eff = 0.0_dp + if (present(NHL_tau)) then + if (NHL_tau > 0.0_dp) NHL_gamma_eff = 1.0_dp/NHL_tau + endif + + volume_0 = cell_volume(this%atoms) + + if(present(p)) then + if(present(tau_cell)) then + gamma_cell = 1.0_dp / tau_cell + else + gamma_cell = gamma_eff * 0.1_dp + endif + + my_cell_oscillation_time = optional_default(10.0_dp/gamma_cell,cell_oscillation_time) + my_bulk_modulus_estimate = optional_default(100.0_dp/EV_A3_IN_GPA,bulk_modulus_estimate) + + w_p = 3.0_dp * my_bulk_modulus_estimate * volume_0 * my_cell_oscillation_time**2 / ((2.0_dp*PI)**2) + + endif + call add_thermostat(this%thermostat,type,T,gamma_eff,Q,p,gamma_cell,w_p,volume_0, & + NHL_gamma=NHL_gamma_eff, NHL_mu=NHL_mu, massive=massive, region_i=region_i) + + end subroutine ds_add_thermostat + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Adding many thermostats + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine ds_add_thermostats(this,type,n,T,T_a,gamma,gamma_a,Q,Q_a,tau,tau_a,region_i) + + type(dynamicalsystem), intent(inout) :: this + integer, intent(in) :: type + integer, intent(in) :: n + real(dp), optional, target, intent(in) :: T, T_a(:) + real(dp), optional, target, intent(in) :: gamma, gamma_a(:) + real(dp), optional, target, intent(in) :: Q, Q_a(:) + real(dp), optional, intent(in) :: tau, tau_a(:) + integer, optional, intent(out) :: region_i + + real(dp), allocatable :: gamma_eff_a(:) + real(dp), pointer :: use_T_a(:), use_Q_a(:) + + if (count( (/present(T), present(T_a) /) ) /= 1 ) & + call system_abort('ds_add_thermostat: exactly one of T, T_a must be present') + + if (count( (/present(Q), present(Q_a) /) ) > 1 ) & + call system_abort('ds_add_thermostat: at most one of Q, Q_a must be present') + + if (count( (/present(gamma), present(gamma_a), present(tau), present(tau_a) /) ) /= 1 ) & + call system_abort('ds_add_thermostat: exactly one of gamma, gamma_a, tau, tau_a must be present') + + if (present(T)) then + allocate(use_T_a(n)) + use_T_a = T + else + use_T_a => T_a + endif + + if (present(Q)) then + allocate(use_Q_a(n)) + use_Q_a = Q + else if (present(Q_a)) then + use_Q_a => Q_a + end if + + allocate(gamma_eff_a(n)) + if (present(gamma)) then + gamma_eff_a = gamma + else ! tau or tau_a + if (present(tau)) then + gamma_eff_a = 1.0_dp/tau + else + gamma_eff_a = 1.0_dp/tau_a + endif + endif + + if (associated(use_Q_a)) then + call add_thermostats(this%thermostat,type,n,use_T_a,gamma_eff_a,use_Q_a,region_i=region_i) + else + call add_thermostats(this%thermostat,type,n,use_T_a,gamma_eff_a,region_i=region_i) + endif + + deallocate(gamma_eff_a) + if (present(Q)) deallocate(use_Q_a) + if (present(T)) deallocate(use_T_a) + + end subroutine ds_add_thermostats + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Updating a thermostat + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine ds_update_thermostat(this,T,p,i) + + type(dynamicalsystem), intent(inout) :: this + real(dp), optional, intent(in) :: T + real(dp), optional, intent(in) :: p + integer, optional, intent(in) :: i + + !real(dp) :: w_p, mass1, mass2, my_T + integer :: my_i + + my_i = optional_default(1,i) + + call update_thermostat(this%thermostat(my_i),T=T,p=p) + + end subroutine ds_update_thermostat + + subroutine ds_update_barostat(this,p,T) + type(dynamicalsystem), intent(inout) :: this + real(dp), optional, intent(in) :: p, T + + if (.not. present(p)) call system_abort("ds_upadte_barostat needs p") + call update_barostat(this%barostat, p_ext=p, W_epsilon=barostat_mass(p, cell_volume(this%atoms), this%Ndof, this%barostat%gamma_epsilon, T)) + end subroutine ds_update_barostat + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X enable/disable damping + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function is_damping_enabled(this) + type(DynamicalSystem), intent(in) :: this + logical is_damping_enabled + + if (this%thermostat(0)%type == THERMOSTAT_NONE) then + is_damping_enabled = .false. + else + is_damping_enabled = .true. + end if + + end function is_damping_enabled + + function get_damping_time(this) + type(DynamicalSystem), intent(in) :: this + real(dp) :: get_damping_time + + if (.not. is_damping_enabled(this)) & + call system_abort('get_damping_time: damping is not enabled') + get_damping_time = 1.0_dp/this%thermostat(0)%gamma + + end function get_damping_time + + !% Enable damping, with damping time set to `damp_time`. Only atoms + !% flagged in the `damp_mask` property will be affected. + subroutine enable_damping(this,damp_time) + + type(dynamicalsystem), intent(inout) :: this + real(dp), intent(in) :: damp_time + + if (damp_time <= 0.0_dp) call system_abort('enable_damping: damp_time must be > 0') + call initialise(this%thermostat(0),THERMOSTAT_LANGEVIN,0.0_dp,gamma=1.0_dp/damp_time) + + end subroutine enable_damping + + subroutine disable_damping(this) + + type(dynamicalsystem), intent(inout) :: this + call initialise(this%thermostat(0),THERMOSTAT_NONE) + + end subroutine disable_damping + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Procedures for returning/changing the state of the system + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Return the total momentum $\mathbf{p} = \sum_i \mathbf{m_i} \mathbf{v_i}$. + !% Optionally only include the contribution of a subset of atoms. + pure function ds_momentum(this,indices) result(p) ! sum(mv) + type(DynamicalSystem), intent(in) :: this + integer, optional, dimension(:), intent(in) :: indices + real(dp) :: p(3) + + p = momentum(this%atoms, indices) + end function ds_momentum + + !% Return the total momentum $\mathbf{p} = \sum_i \mathbf{m_i} \mathbf{v_i}$. + !% Optionally only include the contribution of a subset of atoms. + pure function atoms_momentum(this,indices) result(p) ! sum(mv) + type(Atoms), intent(in) :: this + integer, optional, dimension(:), intent(in) :: indices + real(dp) :: p(3) + + p = momentum(this%mass, this%velo, indices) + end function atoms_momentum + + !% Return the total momentum $\mathbf{p} = \sum_i \mathbf{m_i} \mathbf{v_i}$. + !% Optionally only include the contribution of a subset of atoms. + pure function arrays_momentum(mass, velo, indices) result(p) ! sum(mv) + real(dp), intent(in) :: mass(:) + real(dp), intent(in) :: velo(:,:) + integer, optional, dimension(:), intent(in) :: indices + + real(dp) :: p(3) + integer :: i, N + + N = size(mass) + p = 0.0_dp + if (present(indices)) then + do i = 1,size(indices) + p = p + velo(:,indices(i)) * mass(indices(i)) + end do + else + do i = 1,N + p = p + velo(:,i) * mass(i) + end do + end if + end function arrays_momentum + + !% Return the angular momentum of all the atoms in this DynamicalSystem, defined by + !% $\mathbf{L} = \sum_{i} \mathbf{r_i} \times \mathbf{v_i}$. + pure function ds_angular_momentum(this, origin, indices) result(L) + type(DynamicalSystem), intent(in) :: this + real(dp), intent(in), optional :: origin(3) + integer, intent(in), optional :: indices(:) + real(dp) :: L(3) + + L = angular_momentum(this%atoms, origin, indices) + end function ds_angular_momentum + + !% Return the angular momentum of all the atoms in this DynamicalSystem, defined by + !% $\mathbf{L} = \sum_{i} \mathbf{r_i} \times \mathbf{v_i}$. + pure function atoms_angular_momentum(this, origin, indices) result(L) + type(Atoms), intent(in) :: this + real(dp), intent(in), optional :: origin(3) + integer, intent(in), optional :: indices(:) + real(dp) :: L(3) + + L = angular_momentum(this%mass, this%pos, this%velo, origin, indices) + end function atoms_angular_momentum + + !% Return the angular momentum of all the atoms in this DynamicalSystem, defined by + !% $\mathbf{L} = \sum_{i} \mathbf{r_i} \times \mathbf{v_i}$. + pure function arrays_angular_momentum(mass, pos, velo, origin, indices) result(L) + real(dp), intent(in) :: mass(:) + real(dp), intent(in) :: pos(:,:), velo(:,:) + real(dp), intent(in), optional :: origin(3) + integer, intent(in), optional :: indices(:) + real(dp) :: L(3) + + integer :: ii, i, N + + if (present(indices)) then + N = size(indices) + else + N = size(mass) + endif + + L = 0.0_dp + do ii = 1, N + if (present(indices)) then + i = indices(ii) + else + i = ii + end if + if (present(origin)) then + L = L + mass(i) * ((pos(:,i)-origin) .cross. velo(:,i)) + else + L = L + mass(i) * (pos(:,i) .cross. velo(:,i)) + endif + end do + + end function arrays_angular_momentum + + !% Return the moment of inertia of all the atoms in this DynamicalSystem about a particular axis + !% placed at (optional) origin + !% $I = \sum_{i} m_i |\mathbf{r_i}-\mathbf{o}|^2 $. + pure function moment_of_inertia(this,axis,origin) result (MoI) + type(Atoms), intent(in) :: this + real(dp), intent(in) :: axis(3) + real(dp), intent(in), optional :: origin(3) + real(dp) :: MoI + + real(dp) :: my_origin(3) + integer i + real(dp) :: dr_proj(3), dr(3), dr_normal(3) + real(dp) :: axis_hat(3) + + if (present(origin)) then + my_origin = origin + else + my_origin = (/ 0.0_dp, 0.0_dp, 0.0_dp /) + end if + + axis_hat = axis/norm(axis) + + MoI = 0.0_dp + do i=1, this%N + dr = (this%pos(:,i)-my_origin) + dr_proj = (dr.dot.axis_hat)*axis_hat + dr_normal = dr - dr_proj + MoI = MoI + this%mass(i)*normsq(dr_normal) + end do + end function moment_of_inertia + + pure function moment_of_inertia_tensor(this,origin) result (MoI) + type(Atoms), intent(in) :: this + real(dp), intent(in), optional :: origin(3) + real(dp) :: MoI(3,3) + + real(dp) :: dr(3) + real(dp) :: m + integer i, ii, jj + + MoI = 0.0_dp + do i=1, this%N + m = this%mass(i) + if (present(origin)) then + dr = this%pos(:,i)-origin + else + dr = this%pos(:,i) + endif + do ii=1,3 + do jj=1,3 + if (ii == jj) MoI(ii,jj) = MoI(ii,jj) + m*normsq(dr) + MoI(ii,jj) = MoI(ii,jj) - m*dr(ii)*dr(jj) + end do + end do + end do + end function moment_of_inertia_tensor + + !% Return the total kinetic energy $E_k = \sum_{i} \frac{1}{2} m v^2$ + function DS_kinetic_energy(this, mpi_obj, local_ke, error) result(ke) ! sum(0.5mv^2) + type(DynamicalSystem), intent(in) :: this + type(MPI_context), optional, intent(in) :: mpi_obj + logical, optional, intent(in) :: local_ke + integer, optional, intent(out) :: error + real(dp) :: ke + + INIT_ERROR(error) + ke = kinetic_energy(this%atoms, mpi_obj, local_ke, error=error) + PASS_ERROR(error) + end function DS_kinetic_energy + + !% Return the total kinetic energy $E_k = \sum_{i} \frac{1}{2} m v^2$ + function atoms_kinetic_energy(this, mpi_obj, local_ke, error) result(ke) ! sum(0.5mv^2) + type(atoms), intent(in) :: this + type(MPI_context), optional, intent(in) :: mpi_obj + logical, optional, intent(in) :: local_ke + integer, optional, intent(out) :: error + real(dp) :: ke + + real(dp), pointer :: local_ke_p(:) + + logical :: do_local_ke + + INIT_ERROR(error) + if (.not. associated(this%mass)) call system_abort("atoms_kinetic_energy called on atoms without mass property") + if (.not. associated(this%velo)) call system_abort("atoms_kinetic_energy called on atoms without velo property") + + do_local_ke = optional_default(.false., local_ke) + if (do_local_ke) then + if (.not. assign_pointer(this, 'local_ke', local_ke_p)) then + RAISE_ERROR("atoms_kinetic_energy got local_ke but no local_ke property", error) + endif + local_ke_p = 0.0_dp + ke = kinetic_energy(this%mass(1:this%Ndomain), this%velo(1:3, 1:this%Ndomain), local_ke_p(1:this%Ndomain)) + else + ke = kinetic_energy(this%mass(1:this%Ndomain), this%velo(1:3, 1:this%Ndomain)) + endif + + if (present(mpi_obj)) then + call sum_in_place(mpi_obj, ke, error=error) + PASS_ERROR(error) + if (do_local_ke) then + call sum_in_place(mpi_obj, local_ke_p, error=error) + PASS_ERROR(error) + endif + endif + end function atoms_kinetic_energy + + !% Return the kinetic energy given a mass and a velocity + pure function single_kinetic_energy(mass, velo) result(ke) + real(dp), intent(in) :: mass, velo(3) + real(dp) :: ke + + ke = 0.5_dp*mass * normsq(velo) + end function single_kinetic_energy + + !% Return the total kinetic energy given atomic masses and velocities + function arrays_kinetic_energy(mass, velo, local_ke) result(ke) + real(dp), intent(in) :: mass(:) + real(dp), intent(in) :: velo(:,:) + real(dp), intent(inout), optional :: local_ke(:) + real(dp) :: ke + + if (present(local_ke)) then + local_ke = 0.5_dp * sum(velo**2,dim=1)*mass + endif + ke = 0.5_dp * sum(sum(velo**2,dim=1)*mass) + end function arrays_kinetic_energy + + !% Return the total kinetic virial $w_ij = \sum_{k} \frac{1}{2} m v_i v_j$ + function DS_kinetic_virial(this, mpi_obj, error) result(kv) ! sum(0.5mv^2) + type(DynamicalSystem), intent(in) :: this + type(MPI_context), optional, intent(in) :: mpi_obj + integer, optional, intent(out) :: error + real(dp), dimension(3,3) :: kv + + INIT_ERROR(error) + kv = kinetic_virial(this%atoms, mpi_obj, error=error) + PASS_ERROR(error) + end function DS_kinetic_virial + + !% Return the total kinetic virial $w_ij = \sum_{k} \frac{1}{2} m v_i v_j$ + function atoms_kinetic_virial(this, mpi_obj, error) result(kv) ! sum(0.5mv^2) + type(atoms), intent(in) :: this + type(MPI_context), optional, intent(in) :: mpi_obj + integer, optional, intent(out) :: error + real(dp), dimension(3,3) :: kv + + INIT_ERROR(error) + if (.not. associated(this%mass)) call system_abort("atoms_kinetic_virial called on atoms without mass property") + if (.not. associated(this%velo)) call system_abort("atoms_kinetic_virial called on atoms without velo property") + kv = kinetic_virial(this%mass(1:this%Ndomain), this%velo(1:3, 1:this%Ndomain)) + + if (present(mpi_obj)) then + call sum_in_place(mpi_obj, kv, error=error) + PASS_ERROR(error) + endif + end function atoms_kinetic_virial + + !% Return the kinetic virial given a mass and a velocity + pure function single_kinetic_virial(mass, velo) result(kv) + real(dp), intent(in) :: mass, velo(3) + real(dp), dimension(3,3) :: kv + + kv = mass * (velo .outer. velo) + end function single_kinetic_virial + + !% Return the total kinetic virial given atomic masses and velocities + pure function arrays_kinetic_virial(mass, velo) result(kv) + real(dp), intent(in) :: mass(:) + real(dp), intent(in) :: velo(:,:) + real(dp), dimension(3,3) :: kv + + kv = matmul(velo*spread(mass,dim=1,ncopies=3),transpose(velo)) + end function arrays_kinetic_virial + + pure function torque(pos, force, origin) result(tau) + real(dp), intent(in) :: pos(:,:), force(:,:) + real(dp), intent(in), optional :: origin(3) + real(dp) :: tau(3) + + integer i, N + + N = size(pos,2) + tau = 0.0_dp + do i=1, N + if (present(origin)) then + tau = tau + ((pos(:,i)-origin).cross.force(:,i)) + else + tau = tau + (pos(:,i).cross.force(:,i)) + endif + end do + end function torque + + subroutine thermostat_temperatures(this, temps) + type(DynamicalSystem), intent(in) :: this + real(dp), intent(out) :: temps(:) + + integer :: i + + if (size(temps) /= size(this%thermostat)) & + call system_abort("thermostat_temperatures needs a temps array to match size of this%thermostat() " //size(this%thermostat)) + + temps = -1.0_dp + if (this%thermostat(0)%type == THERMOSTAT_LANGEVIN) then + temps(1) = temperature(this, property='damp_mask', value=1, instantaneous=.true.) + endif + do i=1, size(this%thermostat)-1 + if (this%thermostat(i)%type /= THERMOSTAT_NONE) temps(i+1) = temperature(this, property='thermostat_region', value=i, instantaneous=.true.) + end do + end subroutine thermostat_temperatures + + !% Return the temperature, assuming each degree of freedom contributes + !% $\frac{1}{2}kT$. By default only moving and thermostatted atoms are + !% included --- this can be overriden by setting 'include_all' to true. + !% 'region' can be used to restrict + !% the calculation to a particular thermostat + !% region. 'instantaneous' controls whether the calculation should + !% be carried out using the current values of the velocities and + !% masses, or whether to return the value at the last Verlet step + !% (the latter is the default). + function temperature(this, property, value, include_all, instantaneous, & + mpi_obj, error) + type(DynamicalSystem), intent(in) :: this + character(len=*), intent(in), optional :: property + integer, intent(in), optional :: value + logical, intent(in), optional :: include_all + logical, intent(in), optional :: instantaneous + type(MPI_context), intent(in), optional :: mpi_obj + integer, intent(out), optional :: error + real(dp) :: temperature + + logical :: my_include_all, my_instantaneous + integer :: i, N + real(dp) :: Ndof + integer, pointer :: property_p(:) + + my_instantaneous = optional_default(.false., instantaneous) + my_include_all = optional_default(.false., include_all) + + if (my_instantaneous) then + nullify(property_p) + if (present(property)) then + if (.not. present(value)) then + RAISE_ERROR("temperature called with property but no value to match", error) + endif + if (.not. assign_pointer(this%atoms, trim(property), property_p)) then + RAISE_ERROR("temperature failed to assign integer pointer for property '"//trim(property)//"'", error) + endif + endif + + temperature = 0.0_dp + N = 0 + Ndof = 0.0_dp + do i = 1,this%atoms%Ndomain + if (associated(property_p)) then + if (property_p(i) == value .and. this%atoms%move_mask(i) == 1) then + temperature = temperature + this%atoms%mass(i) * normsq(this%atoms%velo(:,i)) + N = N + 1 + Ndof = Ndof + degrees_of_freedom(this,i) + end if + else + if (my_include_all .or. (this%atoms%move_mask(i) == 1)) then + temperature = temperature + this%atoms%mass(i) * normsq(this%atoms%velo(:,i)) + N = N + 1 + Ndof = Ndof + degrees_of_freedom(this,i) + end if + end if + end do + + if (present(mpi_obj)) then + call sum_in_place(mpi_obj, temperature, error=error) + PASS_ERROR(error) + call sum_in_place(mpi_obj, N, error=error) + PASS_ERROR(error) + call sum_in_place(mpi_obj, Ndof, error=error) + PASS_ERROR(error) + endif + + if (N /= 0) temperature = temperature / ( Ndof * BOLTZMANN_K ) + else + temperature = this%cur_temp + endif + + end function temperature + + !% Add or remove heat from the system by scaling the atomic velocities + subroutine add_heat(this, heat, Ekin) + + type(DynamicalSystem), intent(inout) :: this + real(dp), intent(in) :: heat, Ekin + real(dp) :: r + + if ( Ekin + heat < 0.0_dp ) call System_Abort('AddHeat: Tried to remove too much heat') + + r = sqrt((Ekin+heat)/Ekin) + + this%atoms%velo = this%atoms%velo * r + this%Wkin = kinetic_virial(this) + this%Ekin = trace(this%Wkin)/2 + + end subroutine add_heat + + !% Rescale the atomic velocities to temperature 'temp'. If the + !% current temperature is zero, we first randomise the velocites. + !% If 'mass_weighted' is true, then the velocites are weighted by + !% $1/sqrt{m}$. Linear momentum is zeroed automatically. If + !% 'zero_l' is true then the angular momentum is also zeroed. + subroutine rescale_velo(this, temp, mass_weighted, zero_L) + type(DynamicalSystem), intent(inout) :: this + real(dp), intent(in) :: temp + logical, intent(in), optional :: mass_weighted, zero_L + + logical :: my_mass_weighted, my_zero_L + real(dp) :: r, currTemp + + my_mass_weighted = optional_default(.true., mass_weighted) + my_zero_L = optional_default(.false., zero_L) + currTemp = temperature(this, instantaneous=.true.) + call print("Rescaling velocities from "//currTemp//" K to "//temp//" K") + + if ( currTemp .feq. 0.0_dp ) then + call print('Randomizing velocities') + if (my_mass_weighted) then + call randomise(this%atoms%velo, 1.0_dp/sqrt(this%atoms%mass)) + else + call randomise(this%atoms%velo, 1.0_dp) + endif + call print('Zeroing total momentum') + call zero_momentum(this) + if (my_zero_L) then + call print('Zeroing angular momentum') + call zero_angular_momentum(this%atoms) + endif + currTemp = temperature(this, instantaneous=.true.) + end if + + r = sqrt(temp/currTemp) + this%atoms%velo = this%atoms%velo * r + + this%Wkin = kinetic_virial(this) + this%Ekin = trace(this%Wkin)/2 + end subroutine rescale_velo + + !% Reinitialise the atomic velocities to temperature 'temp'. + !% We first randomise the velocites. + subroutine reinitialise_velo_normal(this, temp, mass_weighted, zero_L) + type(DynamicalSystem), intent(inout) :: this + real(dp), intent(in) :: temp + logical, intent(in), optional :: mass_weighted, zero_L + + logical :: my_mass_weighted, my_zero_L + real(dp) :: r, currTemp + integer :: i + + my_mass_weighted = optional_default(.true., mass_weighted) + my_zero_L = optional_default(.false., zero_L) + currTemp = temperature(this, instantaneous=.true.) + + !call print('Randomizing velocities') + if (my_mass_weighted) then + do i=1,this%atoms%N + this%atoms%velo(1:3,i) = ran_normal3()/sqrt(this%atoms%mass(i)) + enddo + else + do i=1,this%atoms%N + this%atoms%velo(1:3,i) = ran_normal3() + enddo + endif + !call print('Zeroing total momentum') + call zero_momentum(this) + if (my_zero_L) then + call print('Zeroing angular momentum') + call zero_angular_momentum(this%atoms) + endif + currTemp = temperature(this, instantaneous=.true.) + + r = sqrt(temp/currTemp) + this%atoms%velo = this%atoms%velo * r + end subroutine reinitialise_velo_normal + + !% Draw a velocity component from the correct Gaussian distribution for + !% a degree of freedom with (effective) mass 'm' at temperature 'T' + function gaussian_velocity_component(m,T) result(v) + + real(dp), intent(in) :: m, T + real(dp) :: v + + v = sqrt(BOLTZMANN_K * T / m) * ran_normal() + + end function gaussian_velocity_component + + !% Construct a velocity vector for a particle of mass 'm' + !% at temperature 'T' from Gaussian distributed components + function gaussian_velocity(m,T) result(v) + + real(dp), intent(in) :: m,T + real(dp), dimension(3) :: v + + v(1) = gaussian_velocity_component(m,T) + v(2) = gaussian_velocity_component(m,T) + v(3) = gaussian_velocity_component(m,T) + + end function gaussian_velocity + + !% Change velocities to those that the system would have in the zero momentum frame. + !% Optionalally zero the total momentum of a subset of atoms, specified by 'indices'. + subroutine zero_momentum(this,indices) + + type(DynamicalSystem), intent(inout) :: this + integer, optional, dimension(:), intent(in) :: indices + real(dp) :: p(3) + integer :: i + + if (present(indices)) then + p = momentum(this,indices)/size(indices) + forall(i=1:size(indices)) this%atoms%velo(:,indices(i)) = & + this%atoms%velo(:,indices(i)) - p/this%atoms%mass(indices(i)) + else + p = momentum(this)/real(this%N,dp) + forall(i=1:this%N) this%atoms%velo(:,i) = this%atoms%velo(:,i)-p/this%atoms%mass(i) + end if + + end subroutine zero_momentum + + !% give the system a rigid body rotation so as to zero the angular momentum about the centre of mass + subroutine zero_angular_momentum(this) + type(Atoms) :: this + + real(dp) :: CoM(3), L(3), MoI(3,3), MoI_inv(3,3), angular_vel(3) + real(dp) :: axis(3), angular_vel_mag + real(dp) :: dr(3), dr_parallel(3), dr_normal(3), v(3) + + integer i + + CoM = centre_of_mass(this) + L = angular_momentum(this,CoM) + MoI = moment_of_inertia_tensor(this,CoM) + call inverse(MoI, MoI_inv) + angular_vel = matmul(MoI_inv,L) + + angular_vel_mag = norm(angular_vel) + axis = angular_vel/angular_vel_mag + + if (angular_vel_mag .fne. 0.0_dp) then + do i=1, this%N + dr = this%pos(:,i)-CoM + dr_parallel = axis*(dr.dot.axis) + dr_normal = dr - dr_parallel + v = angular_vel_mag*(axis .cross. dr_normal) + this%velo(:,i) = this%velo(:,i) - v + end do + end if + end subroutine zero_angular_momentum + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Centre of Mass calculations + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Calculates the velocity of the centre of mass c.f. 'centre_of_mass' in Atoms module. No origin atom required. + pure function centre_of_mass_velo(this,index_list) result(V_CoM) + + type(DynamicalSystem), intent(in) :: this + integer, dimension(:), optional, intent(in) :: index_list + real(dp), dimension(3) :: V_CoM + !local variables + integer :: i + real(dp) :: M_tot + + V_CoM = 0.0_dp + M_tot = 0.0_dp + if (present(index_list)) then + do i = 1, size(index_list) + V_CoM = V_CoM + this%atoms%velo(:,index_list(i)) * this%atoms%mass(index_list(i)) + M_tot = M_tot + this%atoms%mass(index_list(i)) + end do + else + do i = 1, this%N + V_CoM = V_CoM + this%atoms%velo(:,i) * this%atoms%mass(i) + M_tot = M_tot + this%atoms%mass(i) + end do + end if + + V_CoM = V_CoM / M_tot + + end function centre_of_mass_velo + + !% Calculates the acceleration of the centre of mass c.f. 'centre_of_mass' in Atoms module. No origin atom required + pure function centre_of_mass_acc(this,index_list) result(A_CoM) + + type(DynamicalSystem), intent(in) :: this + integer, dimension(:), optional, intent(in) :: index_list + real(dp), dimension(3) :: A_CoM + !local variables + integer :: i + real(dp) :: M_tot + + A_CoM = 0.0_dp + M_tot = 0.0_dp + + if (present(index_list)) then + do i = 1, size(index_list) + A_CoM = A_CoM + this%atoms%acc(:,index_list(i)) * this%atoms%mass(index_list(i)) + M_tot = M_tot + this%atoms%mass(index_list(i)) + end do + else + do i = 1, this%N + A_CoM = A_CoM + this%atoms%acc(:,i) * this%atoms%mass(i) + M_tot = M_tot + this%atoms%mass(i) + end do + end if + + A_CoM = A_CoM / M_tot + + end function centre_of_mass_acc + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXX + !XXX ADVANCE VERLET 1 + !XXX + !XXX This is the first step of the integration algorithm. + !XXX + !XXX On entry we have r(t), v(t) and a(t). + !XXX + !XXX For normal atoms this routine performs the following steps of velocity + !XXX Verlet: + !XXX + !XXX p(t+dt/2) = p(t) + F(t)dt/2 -> v(t+dt/2) = v(t) + a(t)dt/2 + !XXX + !XXX r(t+dt) = r(t) + (1/m)p(t+dt/2)dt -> r(t+dt) = r(t) + v(t+dt/2)dt + !XXX + !XXX Integration algorithms for other types of atoms fit around this. After this + !XXX routine, the user code must calculate F(t+dt) and call advance_verlet2 to + !XXX complete the integration step. + !XXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + !% Advance the velocities by half the time-step 'dt' and the + !% positions by a full time-step. A typical MD loop should + !% resemble the following code (Python example, Fortran is similar): + !% + !%> ds.atoms.calc_connect() + !%> for n in range(n_steps): + !%> ds.advance_verlet1(dt) + !%> pot.calc(ds.atoms, force=True, energy=True) + !%> ds.advance_verlet2(dt, ds.atoms.force) + !%> ds.print_status(epot=ds.atoms.energy) + !%> if n % connect_interval == 0: + !%> ds.atoms.calc_connect() + subroutine advance_verlet1(this,dt,virial,parallel,store_constraint_force,do_calc_dists,mpi_obj,error) + + type(dynamicalsystem), intent(inout) :: this + real(dp), intent(in) :: dt +!NB real(dp), intent(in) :: f(:,:) + real(dp),dimension(3,3), intent(in), optional :: virial + logical, optional, intent(in) :: parallel + logical, optional, intent(in) :: store_constraint_force, do_calc_dists + type(MPI_context), optional, intent(in) :: mpi_obj + integer, optional, intent(out) :: error + + logical :: do_parallel, do_store, my_do_calc_dists + integer :: i, j, g, n, ntherm + real(dp), allocatable :: therm_ndof(:) + +#ifdef _MPI + real(dp), dimension(:,:), allocatable :: mpi_pos, mpi_velo, mpi_acc, mpi_constraint_force + real(dp), dimension(:,:), pointer :: constraint_force + integer :: error_code +#endif + + + INIT_ERROR(error) + + this%dt = dt + + do_parallel = optional_default(.false.,parallel) + do_store = optional_default(.false.,store_constraint_force) + my_do_calc_dists = optional_default(.true., do_calc_dists) +!NB call check_size('Force',f,(/3,this%N/),'advance_verlet1') + + this%dW = 0.0_dp + ntherm = size(this%thermostat)-1 + allocate(therm_ndof(ntherm)) + +#ifdef _MPI + if (do_parallel) then + allocate(mpi_pos(3,this%N), mpi_velo(3,this%N), mpi_acc(3,this%N)) + mpi_pos = 0.0_dp + mpi_velo = 0.0_dp + mpi_acc = 0.0_dp + if (do_store) then + allocate(mpi_constraint_force(3,this%N)) + mpi_constraint_force = 0.0_dp + if (.not. assign_pointer(this%atoms,'constraint_force', constraint_force)) then + RAISE_ERROR('advance_verlet1: no constraint_force property found', error) + end if + end if + end if +#endif + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X CALCULATE AND SET DEGREES OF FREEDOM FOR EACH THERMOSTAT + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + call barostat_pre_vel1(this%barostat,this%atoms,dt,virial) + + therm_ndof = 0.0_dp + do i = 1, this%atoms%Ndomain + j = this%atoms%thermostat_region(i) + if (j>0 .and. j<=ntherm) therm_ndof(j) = therm_ndof(j) + degrees_of_freedom(this,i) + end do + if (present(mpi_obj)) then + call sum_in_place(mpi_obj, therm_ndof, error=error) + PASS_ERROR(error) + endif + do i = 1, ntherm + call set_degrees_of_freedom(this%thermostat(i),therm_ndof(i)) + end do + deallocate(therm_ndof) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X DAMPING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then + call thermostat_pre_vel1(this%thermostat(0),this%atoms,dt,'damp_mask',1) + end if + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTATTING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + do i = 1, ntherm + call thermostat_pre_vel1(this%thermostat(i),this%atoms,dt,'thermostat_region',i,virial) + end do + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X VELOCITY UPDATE + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !TIME_PROPAG_TEX 20 + !TIME_PROPAG_TEX 20 Verlet vel step 1 (advance\_verlet1) + !TIME_PROPAG_TEX 20 $$ v = v + (\tau/2) f/m $$ + !TIME_PROPAG_TEX 20 + + do g = 1, size(this%group) + +#ifdef _MPI + if (do_parallel .and. mod(g,mpi_n_procs()) /= mpi_id()) cycle +#endif + + select case(this%group(g)%type) + + case(TYPE_ATOM, TYPE_CONSTRAINED) ! Constrained atoms undergo the usual verlet step here + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X v(t+dt/2) = v(t) + a(t)dt/2 + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXX + do n = 1, group_n_atoms(this%group(g)) + i = group_nth_atom(this%group(g),n) + + if (i <= this%atoms%Ndomain) then +#ifdef _MPI + if (do_parallel) then + if (this%atoms%move_mask(i)==0) then + mpi_velo(:,i) = 0.0_dp + else + mpi_velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt + end if + else + if (this%atoms%move_mask(i)==0) then + this%atoms%velo(:,i) = 0.0_dp + else + this%atoms%velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt + end if + end if +#else + if (this%atoms%move_mask(i)==0) then + this%atoms%velo(:,i) = 0.0_dp + else + this%atoms%velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt + end if +#endif + endif + end do + + end select + + end do +! call print("advance_verlet1 "//(0.5_dp*dt*sum(norm(this%atoms%acc,1))/real(this%atoms%N,dp))) + +#ifdef _MPI + ! Broadcast the new velocities + if (do_parallel) then + call MPI_ALLREDUCE(mpi_velo,this%atoms%velo,size(mpi_velo),MPI_DOUBLE_PRECISION,& + MPI_SUM,MPI_COMM_WORLD,error_code) + call abort_on_mpi_error(error_code,'advance_verlet1 - velocity update') + end if +#endif + + call barostat_post_vel1_pre_pos(this%barostat,this%atoms,dt,virial) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X DAMPING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then + call thermostat_post_vel1_pre_pos(this%thermostat(0),this%atoms,dt,'damp_mask',1) + end if + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTATTING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + do i=1, ntherm + call thermostat_post_vel1_pre_pos(this%thermostat(i),this%atoms,dt,'thermostat_region',i) + end do + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X POSITION UPDATE + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !TIME_PROPAG_TEX 40 + !TIME_PROPAG_TEX 40 Verlet pos step (advance\_verlet1) + !TIME_PROPAG_TEX 40 $$ r = r + \tau v $$ + !TIME_PROPAG_TEX 40 + + do g = 1, size(this%group) + +#ifdef _MPI + if (do_parallel .and. mod(g,mpi_n_procs()) /= mpi_id()) cycle +#endif + + select case(this%group(g)%type) + + case(TYPE_ATOM) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X r(t+dt) = r(t) + v(t+dt/2)dt + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + do n = 1, group_n_atoms(this%group(g)) + i = group_nth_atom(this%group(g),n) + + if (i <= this%atoms%Ndomain) then +#ifdef _MPI + if (do_parallel) then + if (this%atoms%move_mask(i)==0) then + mpi_pos(:,i) = this%atoms%pos(:,i) + mpi_velo(:,i) = 0.0_dp + mpi_acc(:,i) = 0.0_dp + else + mpi_pos(:,i) = this%atoms%pos(:,i) + this%atoms%velo(:,i)*dt + mpi_velo(:,i) = this%atoms%velo(:,i) + mpi_acc(:,i) = this%atoms%acc(:,i) + end if + else + if (this%atoms%move_mask(i)==0) then + this%atoms%velo(:,i) = 0.0_dp + this%atoms%acc(:,i) = 0.0_dp + else + this%atoms%pos(:,i) = this%atoms%pos(:,i) + this%atoms%velo(:,i)*dt + end if + end if +#else + if (this%atoms%move_mask(i)==0) then + this%atoms%velo(:,i) = 0.0_dp + this%atoms%acc(:,i) = 0.0_dp + else + this%atoms%pos(:,i) = this%atoms%pos(:,i) + this%atoms%velo(:,i)*dt + end if +#endif + endif + end do + + case(TYPE_CONSTRAINED) + + !We don't test move_mask here: constrained atoms are fixed by extra constraints. + call shake(this%atoms,this%group(g),this%constraint,this%t,dt,store_constraint_force) +#ifdef _MPI + if (do_parallel) then + do n = 1, group_n_atoms(this%group(g)) + i = group_nth_atom(this%group(g),n) + mpi_pos(:,i) = this%atoms%pos(:,i) + mpi_velo(:,i) = this%atoms%velo(:,i) + mpi_acc(:,i) = this%atoms%acc(:,i) + if (do_store) mpi_constraint_force(:,i) = constraint_force(:,i) + end do + end if +#endif + + end select + + end do + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X DAMPING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then + call thermostat_post_pos_pre_calc(this%thermostat(0),this%atoms,dt,'damp_mask',1) + end if + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTATTING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + do i=1, ntherm + call thermostat_post_pos_pre_calc(this%thermostat(i),this%atoms,dt,'thermostat_region',i) + end do + + call barostat_post_pos_pre_calc(this%barostat,this%atoms,dt,virial) + +#ifdef _MPI + ! Broadcast the new positions, velocities, accelerations and possibly constraint forces + if (do_parallel) then + call MPI_ALLREDUCE(mpi_pos,this%atoms%pos,size(mpi_pos),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) + call abort_on_mpi_error(error_code,'advance_verlet1 - position update') + call MPI_ALLREDUCE(mpi_velo,this%atoms%velo,size(mpi_velo),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) + call abort_on_mpi_error(error_code,'advance_verlet1 - velocity update 2') + call MPI_ALLREDUCE(mpi_acc,this%atoms%acc,size(mpi_acc),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) + call abort_on_mpi_error(error_code,'advance_verlet1 - acceleration update') + if (do_store) then + call MPI_ALLREDUCE(mpi_constraint_force, constraint_force, size(mpi_constraint_force),& + MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) + call abort_on_mpi_error(error_code,'advance_verlet1 - constraint force update') + end if + end if +#endif + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X BOOKKEEPING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#ifdef _MPI + if (do_parallel) then + deallocate(mpi_pos, mpi_velo, mpi_acc) + if (do_store) deallocate(mpi_constraint_force) + end if +#endif + + if (my_do_calc_dists) then + call calc_dists(this%atoms,parallel=do_parallel,error=error) + PASS_ERROR(error) + endif + + end subroutine advance_verlet1 + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXX + !XXX ADVANCE VERLET 2 + !XXX + !XXX This is the second step of the integration algorithm. + !XXX + !XXX On entry we have r(t+dt), v(t+dt/2) and a(t). F(t+dt) is calculated by the + !XXX user code between calls to advance_verlet1 and advance_verlet2, and passed + !XXX in as the argument 'f' + !XXX + !XXX For normal atoms this routine performs the last step of velocity Verlet: + !XXX + !XXX p(t+dt) = p(t+dt/2) + F(t+dt)dt/2 -> v(t+dt) = v(t+dt/2) + a(t+dt)dt/2 + !XXX + !XXX where a(t+dt) = (1/m) F(t+dt) + !XXX + !XXX Integration algorithms for other types of atoms fit around this. + !XXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Advances the velocities by the second half time-step + subroutine advance_verlet2(this,dt,f,virial,E,parallel,store_constraint_force,error) + + type(dynamicalsystem), intent(inout) :: this + real(dp), intent(in) :: dt + real(dp), intent(inout) :: f(:,:) + real(dp),dimension(3,3), intent(in), optional :: virial + real(dp), optional, intent(inout) :: E + logical, optional, intent(in) :: parallel + logical, optional, intent(in) :: store_constraint_force + integer, optional, intent(out) :: error + + logical :: do_parallel, do_store + integer :: i, g, n, ntherm + real(dp) :: decay + +#ifdef _MPI + real(dp), dimension(:,:), allocatable :: mpi_velo, mpi_acc, mpi_constraint_force + real(dp), dimension(:,:), pointer :: constraint_force + integer :: error_code +#endif + + INIT_ERROR(error) + + this%dt = dt + + do_parallel = optional_default(.false.,parallel) + do_store = optional_default(.false.,store_constraint_force) + ntherm = size(this%thermostat)-1 + call check_size('Force',f,(/3,this%N/),'advance_verlet2', error=error) + PASS_ERROR(error) + +#ifdef _MPI + if (do_parallel) then + allocate(mpi_velo(3,this%N), mpi_acc(3,this%N)) + mpi_velo = 0.0_dp + mpi_acc = 0.0_dp + if (do_store) then + allocate(mpi_constraint_force(3,this%N)) + mpi_constraint_force = 0.0_dp + if (.not. assign_pointer(this%atoms,'constraint_force', constraint_force)) then + RAISE_ERROR('advance_verlet2: no constraint_force property found', error) + end if + end if + end if +#endif + + call add_restraint_forces(this%atoms, this%Nrestraints, this%restraint, this%t, f, E, store_restraint_force=store_constraint_force) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X CONVERT FORCES TO ACCELERATIONS + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + forall (i=1:this%atoms%Ndomain) this%atoms%acc(:,i) = f(:,i) / this%atoms%mass(i) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X DAMPING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then + call thermostat_post_calc_pre_vel2(this%thermostat(0),this%atoms,dt,'damp_mask',1) + end if + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTATTING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + do i = 1, ntherm + call thermostat_post_calc_pre_vel2(this%thermostat(i),this%atoms,dt,'thermostat_region',i) + end do + + call barostat_post_calc_pre_vel2(this%barostat,this%atoms,dt,virial) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X VELOCITY UPDATE + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !TIME_PROPAG_TEX 80 + !TIME_PROPAG_TEX 80 Verlet vel step 2 (advance\_verlet2) + !TIME_PROPAG_TEX 80 $$ v = v + (\tau/2) f/m $$ + !TIME_PROPAG_TEX 80 + + do g = 1, size(this%group) + +#ifdef _MPI + if (do_parallel .and. mod(g,mpi_n_procs()) /= mpi_id()) cycle +#endif + + select case(this%group(g)%type) + + case(TYPE_ATOM) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X v(t+dt) = v(t+dt/2) + a(t+dt)dt/2 + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + do n = 1, group_n_atoms(this%group(g)) + i = group_nth_atom(this%group(g),n) + + if (i <= this%atoms%Ndomain) then +#ifdef _MPI + if (do_parallel) then + if (this%atoms%move_mask(i)==0) then + mpi_velo(:,i) = 0.0_dp + mpi_acc(:,i) = 0.0_dp + else + mpi_velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt + mpi_acc(:,i) = this%atoms%acc(:,i) + end if + else + if (this%atoms%move_mask(i)==0) then + this%atoms%velo(:,i) = 0.0_dp + this%atoms%acc(:,i) = 0.0_dp + else + this%atoms%velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt + end if + end if +#else + if (this%atoms%move_mask(i)==0) then + this%atoms%velo(:,i) = 0.0_dp + this%atoms%acc(:,i) = 0.0_dp + else + this%atoms%velo(:,i) = this%atoms%velo(:,i) + 0.5_dp*this%atoms%acc(:,i)*dt + end if +#endif + endif + end do + + case(TYPE_CONSTRAINED) + + !As with shake, we don't test move_mask here + call rattle(this%atoms,this%group(g),this%constraint,this%t,dt,store_constraint_force) +#ifdef _MPI + if (do_parallel) then + do n = 1, group_n_atoms(this%group(g)) + i = group_nth_atom(this%group(g),n) + mpi_velo(:,i) = this%atoms%velo(:,i) + mpi_acc(:,i) = this%atoms%acc(:,i) + if (do_store) mpi_constraint_force(:,i) = constraint_force(:,i) + end do + end if +#endif + + end select + + end do +! call print("advance_verlet2 "//(0.5_dp*dt*sum(norm(this%atoms%acc,1))/real(this%atoms%N,dp))) + +#ifdef _MPI + ! Broadcast the new velocities, accelerations and possibly constraint forces + if (do_parallel) then + call MPI_ALLREDUCE(mpi_velo,this%atoms%velo,size(mpi_velo),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) + call abort_on_mpi_error(error_code,'advance_verlet1 - velocity update 2') + call MPI_ALLREDUCE(mpi_acc,this%atoms%acc,size(mpi_acc),MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) + call abort_on_mpi_error(error_code,'advance_verlet1 - acceleration update') + if (do_store) then + call MPI_ALLREDUCE(mpi_constraint_force,constraint_force,size(mpi_constraint_force),& + MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,error_code) + call abort_on_mpi_error(error_code,'advance_verlet1 - constraint force update') + end if + end if +#endif + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X DAMPING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + if (this%thermostat(0)%type==THERMOSTAT_LANGEVIN) then + call thermostat_post_vel2(this%thermostat(0),this%atoms,dt,'damp_mask',1) + end if + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTATTING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + do i = 1, ntherm + call thermostat_post_vel2(this%thermostat(i),this%atoms,dt,'thermostat_region',i,virial) + end do + + call barostat_post_vel2(this%barostat,this%atoms,dt,virial) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X BOOKKEEPING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + this%t = this%t + dt + this%nSteps = this%nSteps + 1 + this%work = this%work + this%dW ! Not currently calculated + + this%cur_temp = temperature(this, instantaneous=.true.) + + if (this%avg_time > 0.0_dp) then + decay = dt/this%avg_time + call update_exponential_average(this%avg_temp,decay,this%cur_temp) + do i = 1, this%atoms%Ndomain + call update_exponential_average(this%atoms%avgpos(:,i),decay,realpos(this%atoms,i)) + call update_exponential_average(this%atoms%avg_ke(i),decay,0.5_dp*this%atoms%mass(i)*normsq(this%atoms%velo(:,i))) + end do + end if + +#ifdef _MPI + if (do_parallel) then + deallocate(mpi_velo, mpi_acc) + if (do_store) deallocate(mpi_constraint_force) + end if +#endif + + this%Wkin = kinetic_virial(this, error=error) + PASS_ERROR(error) + this%Ekin = trace(this%Wkin)/2 + + end subroutine advance_verlet2 + + !% Calls' advance_verlet2' followed by 'advance_verlet1'. Outside this routine the + !% velocities will be half-stepped. This allows a simpler MD loop: + !%> for n in range(n_steps): + !%> pot.calc(ds.atoms, force=True, energy=True) + !%> ds.advance_verlet(dt, ds.atoms.force) + !%> ds.print_status(epot=ds.atoms.energy) + !%> if n % connect_interval == 0: + !%> ds.atoms.calc_connect() + subroutine advance_verlet(ds,dt,f,virial,E,parallel,store_constraint_force,do_calc_dists,error) + + type(dynamicalsystem), intent(inout) :: ds + real(dp), intent(in) :: dt + real(dp), intent(inout) :: f(:,:) + real(dp),dimension(3,3), intent(in), optional :: virial + real(dp), intent(inout), optional :: E + logical, optional, intent(in) :: parallel + logical, optional, intent(in) :: store_constraint_force, do_calc_dists + logical, save :: first_call = .true. + integer, optional, intent(out) :: error + + INIT_ERROR(error) + if (first_call) then + call print_title('SINGLE STEP VERLET IN USE') + call print('Consider changing to the two-step integrator') + call print_title('=') + first_call = .false. + end if + call advance_verlet2(ds,dt,f,virial,E,parallel,store_constraint_force,error=error) + PASS_ERROR(error) + call advance_verlet1(ds,dt,virial,parallel,store_constraint_force,do_calc_dists,error=error) + PASS_ERROR(error) + + end subroutine advance_verlet + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X I/O + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Print a status line showing the current time, temperature, the mean temperature + !% the total energy and the total momentum for this DynamicalSystem. If present, the optional + !% 'label' parameter should be a one character label for the log lines and is printed + !% in the first column of the output. 'epot' should be the potential energy + !% if this is available. 'instantaneous' has the same meaning as in 'temperature' routine. + subroutine ds_print_status(this, label, epot, instantaneous, mpi_obj, file, error) + type(DynamicalSystem), intent(in) :: this + character(*), optional, intent(in) :: label + real(dp), optional, intent(in) :: epot + logical, optional, intent(in) :: instantaneous + type(MPI_context), optional, intent(in) :: mpi_obj + type(InOutput), optional, intent(inout) :: file + integer, optional, intent(out) :: error + + character(len=STRING_LENGTH) :: string + logical, save :: firstcall = .true. + real(dp) :: temp, my_epot, my_ekin + real(dp) :: region_temps(size(this%thermostat)) + integer :: i + + INIT_ERROR(error) + + string = "" + if(present(label)) string = label + + if(firstcall) then + if(present(epot)) then + write(line, '(a14,a12,a12,a12,5a20)') "Time", "Temp", "Mean temp", & + "Norm(p)","Total work","Thermo work", & + "Ekin", "Etot", "Eext"; call print(line, file=file) + else + write(line, '(a14,a12,a12,a12,a12,2a20)') "Time", "Temp", "Mean temp", & + "Norm(p)", "Total work","Thermo work"; call print(line, file=file) + end if + firstcall = .false. + end if + + if (present(epot)) then + if (present(mpi_obj)) then + my_epot = sum(mpi_obj, epot, error=error) + PASS_ERROR(error) + else + my_epot = epot + endif + endif + + temp = temperature(this, instantaneous=instantaneous, & + mpi_obj=mpi_obj, error=error) + PASS_ERROR(error) + call thermostat_temperatures(this, region_temps) + + my_ekin = kinetic_energy(this, mpi_obj, error=error) + PASS_ERROR(error) + + if(present(epot)) then + write(line, '(a,f12.2,2f12.4,e12.2,5e20.8)') trim(string), this%t, & + temp, this%avg_temp, norm(momentum(this)),& + this%work, this%thermostat_work, my_ekin, & + my_epot+my_ekin,my_epot+my_ekin+this%ext_energy + else + write(line, '(a,f12.2,2f12.4,e12.2,2e20.8)') trim(string), this%t, & + temp, this%avg_temp, norm(momentum(this)), & + this%work, this%thermostat_work + + end if + call print(line, file=file) + + if (this%print_thermostat_temps) then + if (any(region_temps >= 0.0_dp)) then + call print("T "//this%t, nocr=.true., file=file) + do i=0, size(region_temps)-1 + if (this%thermostat(i)%type /= THERMOSTAT_NONE) then + call print(" "// i // " " // round(this%thermostat(i)%T,2) // " " // round(region_temps(i+1),2), nocr=.true., file=file) + else + call print(" "// i // " type=NONE", nocr=.true., file=file) + endif + end do + call print("", file=file) + endif + endif + + end subroutine ds_print_status + + + subroutine ds_print_thermostats(this) + type(DynamicalSystem), intent(inout) :: this + + call print(this%thermostat) + + end subroutine ds_print_thermostats + + + !% Print lots of information about this DynamicalSystem in text format. + subroutine ds_print(this,file) + + type(DynamicalSystem), intent(inout) :: this + type(Inoutput),optional,intent(inout) :: file + integer :: i + + call Print('DynamicalSystem:',file=file) + + if (.not.this%initialised) then + + call Print(' (not initialised)',file=file) + return + end if + + call print('Number of atoms = '//this%N) + call print('Simulation Time = '//this%t) + call print('Averaging Time = '//this%avg_time) + call print("") + + call print('Thermostat') + call print(this%thermostat) + + call print('-------------------------------------------------------------------------------', PRINT_VERBOSE, file) + call print('| Index | Average Position | Velocity | Acceleration |', PRINT_VERBOSE, file) + call print('-------------------------------------------------------------------------------', PRINT_VERBOSE, file) + do i = 1, this%N + call print('| '//i//' |'//this%atoms%avgpos(:,i)//' |'//this%atoms%velo(:,i)//' |'//this%atoms%acc(:,i)//' |', PRINT_VERBOSE, file) + end do + call print('-------------------------------------------------------------------------------', PRINT_VERBOSE,file) + + call verbosity_push_decrement() + call print(this%atoms,file) + call verbosity_pop() + + end subroutine ds_print + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X CONSTRAINED DYNAMICS ROUTINES + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + ! Routines to make adding constraints easier + ! + !% Constrain the bond angle cosine between atoms i, j, and k + subroutine constrain_bondanglecos(this,i,j,k,c,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i,j,k + real(dp), optional, intent(in) :: c, restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: BONDANGLECOS_FUNC + real(dp) :: use_c + real(dp) :: r_ji(3), r_jk(3) + + !Do nothing for i==j + if (i==j .or. i == k .or. j == k) then + call print_message('WARNING', 'Constrain_bondanglecos: Tried to constrain bond angle cosine '//i//'--'//j//'--'//k) + return + end if + + !Report bad atom indices + if ( i>this%N .or. i<1 .or. j>this%N .or. j<1 .or. k > this%N .or. k<1) then + call system_abort('Constrain_bondanglecos: Cannot constrain bond angle cosine '//i//'--'//j//'--'//k// & + ' : Atom out of range (N='//this%N//')') + end if + + !Register the constraint function if this is the first call + if (first_call) then + BONDANGLECOS_FUNC = register_constraint(BONDANGLECOS) + first_call = .false. + end if + + !Add the constraint + if (present(c)) then + use_c = c + else + r_ji = diff_min_image(this%atoms,j,i) + r_jk = diff_min_image(this%atoms,j,k) + use_c = (r_ji .dot. r_jk)/(norm(r_ji)*norm(r_jk)) + endif + call ds_add_constraint(this,(/i,j,k/),BONDANGLECOS_FUNC,(/use_c/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + + end subroutine constrain_bondanglecos + + !% Constrain the bond between atoms i and j + subroutine constrain_bondlength(this,i,j,d,di,t0,tau,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i,j + real(dp), intent(in) :: d + real(dp), optional, intent(in) :: di, t0, tau + real(dp), optional, intent(in) :: restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: BOND_FUNC + real(dp) :: use_di + + !Do nothing for i==j + if (i==j) then + call print_message('WARNING', 'Constrain_bondlength: Tried to constrain bond '//i//'--'//j) + return + end if + + !Report bad atom indices + if ( (i>this%N) .or. (i<1) .or. (j>this%N) .or. (j<1) ) then + call system_abort('Constrain_bondlength: Cannot constrain bond '//i//'--'//j//& + ': Atom out of range (N='//this%N//')') + end if + + if (count( (/ present(di), present(t0), present(tau) /) ) /= 3 .and. & + count( (/ present(di), present(t0), present(tau) /) ) /= 0) then + call system_abort("constrain_bondlength needs all or none of di, t0, and tau for relaxing bond length to final value") + endif + + !Register the constraint function if this is the first call + if (first_call) then + BOND_FUNC = register_constraint(BONDLENGTH) + first_call = .false. + end if + + !Add the constraint + if (present(di)) then + ! relaxing bond length to final value + if (di < 0.0_dp) then + use_di = distance_min_image(this%atoms,i,j) + else + use_di = di + endif + call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/use_di,d,t0,tau/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + else ! constant restraint + call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/d,d,0.0_dp,1.0_dp/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + endif + + end subroutine constrain_bondlength + + !% Constrain the bond between atoms i and j + subroutine constrain_bondlength_sq(this,i,j,d,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i,j + real(dp), optional, intent(in) :: d, restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: BOND_FUNC + real(dp) :: use_d + + !Do nothing for i==j + if (i==j) then + call print_message('WARNING', 'Constrain_bondlength_sq: Tried to constrain bond '//i//'--'//j) + return + end if + + !Report bad atom indices + if ( (i>this%N) .or. (i<1) .or. (j>this%N) .or. (j<1) ) then + call system_abort('Constrain_bondlength_sq: Cannot constrain bond '//i//'--'//j//& + ': Atom out of range (N='//this%N//')') + end if + + !Register the constraint function if this is the first call + if (first_call) then + BOND_FUNC = register_constraint(BONDLENGTH_SQ) + first_call = .false. + end if + + !Add the constraint + use_d = optional_default(distance_min_image(this%atoms,i,j), d) + call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/use_d/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + + end subroutine constrain_bondlength_sq + + !% Constrain the bond between atoms i and j + subroutine constrain_bondlength_dev_pow(this,i,j,p,d,di,t0,tau,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i,j + real(dp), intent(in) :: p, d + real(dp), optional, intent(in) :: di, t0, tau + real(dp), optional, intent(in) :: restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: BOND_FUNC + real(dp) :: use_di + + !Do nothing for i==j + if (i==j) then + call print_message('WARNING', 'Constrain_bondlength_dev_pow: Tried to constrain bond '//i//'--'//j) + return + end if + + !Report bad atom indices + if ( (i>this%N) .or. (i<1) .or. (j>this%N) .or. (j<1) ) then + call system_abort('Constrain_bondlength_dev_pow: Cannot constrain bond '//i//'--'//j//& + ': Atom out of range (N='//this%N//')') + end if + + if (count( (/ present(di), present(t0), present(tau) /) ) /= 3 .and. & + count( (/ present(di), present(t0), present(tau) /) ) /= 0) then + call system_abort("constrain_bondlength_dev_pow needs all or none of di, t0, and tau for relaxing bond length to final value") + endif + + !Register the constraint function if this is the first call + if (first_call) then + BOND_FUNC = register_constraint(BONDLENGTH_DEV_POW) + first_call = .false. + end if + + !Add the constraint + if (present(di)) then + ! relaxing bond length to final value + if (di < 0.0_dp) then + use_di = distance_min_image(this%atoms,i,j) + else + use_di = di + endif + call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/use_di,d,p,t0,tau/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + else + call ds_add_constraint(this,(/i,j/),BOND_FUNC,(/d,d,p,0.0_dp,1.0_dp/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + endif + + end subroutine constrain_bondlength_dev_pow + + ! + ! Routines to make adding constraints easier + ! + !% Constrain the difference of bond length between atoms i--j and j--k + subroutine constrain_bondlength_diff(this,i,j,k,d,di,t0,tau,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i,j,k + real(dp), intent(in) :: d + real(dp), optional, intent(in) :: di, t0, tau + real(dp), optional, intent(in) :: restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: BOND_DIFF_FUNC + + !Do nothing for i==j or i==k or j==k + if (i==j.or.i==k.or.j==k) then + call print_message('WARNING', 'Constrain_bondlength_Diff: Tried to constrain bond '//i//'--'//j//'--'//k) + return + end if + + !Report bad atom indices + if ( (i>this%N) .or. (i<1) .or. (j>this%N) .or. (j<1) .or. (k>this%N) .or. (k<0) ) then + call system_abort('Constrain_bondlength_Diff: Cannot constrain bond '//i//'--'//j//'--'//k//& + ': Atom out of range (N='//this%N//')') + end if + + if (count( (/ present(di), present(t0), present(tau) /) ) /= 3 .and. & + count( (/ present(di), present(t0), present(tau) /) ) /= 0) then + call system_abort("constrain_bondlength_diff needs all or none of di, t0, and tau for relaxing bond length to final value") + endif + + !Register the constraint function if this is the first call + if (first_call) then + BOND_DIFF_FUNC = register_constraint(BONDLENGTH_DIFF) + first_call = .false. + end if + + !Add the constraint + if (present(di)) then + call ds_add_constraint(this,(/i,j,k/),BOND_DIFF_FUNC,(/di,d,t0,tau/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + else + call ds_add_constraint(this,(/i,j,k/),BOND_DIFF_FUNC,(/d,d,0.0_dp,1.0_dp/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + endif + + end subroutine constrain_bondlength_diff + + ! + ! Routines to make adding constraints easier + ! + !% Constrain the energy gap of two resonance structures + subroutine constrain_gap_energy(this,d,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + real(dp), intent(in) :: d + real(dp), optional, intent(in) :: restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: GAP_ENERGY_FUNC + integer, allocatable :: all_atoms(:) + integer :: i + + !Register the constraint function if this is the first call + if (first_call) then + GAP_ENERGY_FUNC = register_constraint(GAP_ENERGY) + first_call = .false. + end if + + !Add the constraint + allocate(all_atoms(this%atoms%N)) + do i=1,this%atoms%N + all_atoms(i) = i + enddo + call ds_add_constraint(this,all_atoms,GAP_ENERGY_FUNC,(/d/), restraint_k=restraint_k,bound=bound, tol=tol, print_summary=print_summary) + deallocate(all_atoms) + + end subroutine constrain_gap_energy + + !% Constrain an atom to lie in a particluar plane + subroutine constrain_atom_plane(this,i,plane_n,d,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i + real(dp), intent(in) :: plane_n(3) + real(dp), optional, intent(in) :: d, restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: PLANE_FUNC + real(dp) :: use_d, plane_n_hat(3) + + !Report bad atom indices + if ( (i>this%N) .or. (i<1)) then + call system_abort('Constrain_atom_plane: Cannot constrain atom '//i// & + ': Atom out of range (N='//this%N//')') + end if + + !Register the constraint function if this is the first call + if (first_call) then + PLANE_FUNC = register_constraint(PLANE) + first_call = .false. + end if + + plane_n_hat = plane_n/norm(plane_n) + use_d = optional_default((this%atoms%pos(:,i) .dot. plane_n_hat),d) + + !Add the constraint + call ds_add_constraint(this,(/i/),PLANE_FUNC,(/plane_n,use_d/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + + end subroutine constrain_atom_plane + + !% Constrain an atom to lie in a particluar plane + subroutine constrain_struct_factor_like_mag(this,Z,q,SF,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: Z + real(dp), intent(in) :: q(3) + real(dp), intent(in) :: SF + real(dp), optional, intent(in) :: restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: STRUCT_FACTOR_LIKE_MAG_FUNC + + integer :: i, ii + integer, allocatable :: atom_indices(:) + + !Report bad atom indices + if ( Z /= 0) then + if (count(this%atoms%Z == Z) == 0) then + call system_abort('Constrain_struct_factor_like_mag: No atoms (out of '//this%atoms%N//') with Z='//Z) + end if + end if + + !Register the constraint function if this is the first call + if (first_call) then + STRUCT_FACTOR_LIKE_MAG_FUNC = register_constraint(STRUCT_FACTOR_LIKE_MAG) + first_call = .false. + end if + + if (Z == 0) then + allocate(atom_indices(this%atoms%n)) + do i=1, this%atoms%N + atom_indices(i) = i + end do + else + allocate(atom_indices(count(this%atoms%Z == Z))) + ii = 0 + do i=1, this%atoms%N + if (Z == 0) then + ii = ii + 1 + atom_indices(ii) = i + else + if (this%atoms%Z(i) == Z) then + ii = ii + 1 + atom_indices(ii) = i + endif + endif + end do + endif + + !Add the constraint + call ds_add_constraint(this,atom_indices,STRUCT_FACTOR_LIKE_MAG_FUNC,(/q(1),q(2),q(3),SF/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + + deallocate(atom_indices) + + end subroutine constrain_struct_factor_like_mag + + !% Constrain an atom to lie in a particluar plane + subroutine constrain_struct_factor_like_r(this,Z,q,SF,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: Z + real(dp), intent(in) :: q(3) + real(dp), intent(in) :: SF + real(dp), optional, intent(in) :: restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: STRUCT_FACTOR_LIKE_R_FUNC + + integer :: i, ii + integer, allocatable :: atom_indices(:) + + !Report bad atom indices + if ( Z /= 0) then + if (count(this%atoms%Z == Z) == 0) then + call system_abort('Constrain_struct_factor_like_r: No atoms (out of '//this%atoms%N//') with Z='//Z) + end if + end if + + !Register the constraint function if this is the first call + if (first_call) then + STRUCT_FACTOR_LIKE_R_FUNC = register_constraint(STRUCT_FACTOR_LIKE_R) + first_call = .false. + end if + + if (Z == 0) then + allocate(atom_indices(this%atoms%n)) + do i=1, this%atoms%N + atom_indices(i) = i + end do + else + allocate(atom_indices(count(this%atoms%Z == Z))) + ii = 0 + do i=1, this%atoms%N + if (Z == 0) then + ii = ii + 1 + atom_indices(ii) = i + else + if (this%atoms%Z(i) == Z) then + ii = ii + 1 + atom_indices(ii) = i + endif + endif + end do + endif + + !Add the constraint + call ds_add_constraint(this,atom_indices,STRUCT_FACTOR_LIKE_R_FUNC,(/q(1),q(2),q(3),SF/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + + deallocate(atom_indices) + + end subroutine constrain_struct_factor_like_r + + !% Constrain an atom to lie in a particluar plane + subroutine constrain_struct_factor_like_i(this,Z,q,SF,restraint_k,bound,tol,print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: Z + real(dp), intent(in) :: q(3) + real(dp), intent(in) :: SF + real(dp), optional, intent(in) :: restraint_k, tol + integer, optional, intent(in) :: bound + logical, optional, intent(in) :: print_summary + + logical, save :: first_call = .true. + integer, save :: STRUCT_FACTOR_LIKE_I_FUNC + + integer :: i, ii + integer, allocatable :: atom_indices(:) + + !Report bad atom indices + if ( Z /= 0) then + if (count(this%atoms%Z == Z) == 0) then + call system_abort('Constrain_struct_factor_like_i: No atoms (out of '//this%atoms%N//') with Z='//Z) + end if + end if + + !Register the constraint function if this is the first call + if (first_call) then + STRUCT_FACTOR_LIKE_I_FUNC = register_constraint(STRUCT_FACTOR_LIKE_I) + first_call = .false. + end if + + if (Z == 0) then + allocate(atom_indices(this%atoms%n)) + do i=1, this%atoms%N + atom_indices(i) = i + end do + else + allocate(atom_indices(count(this%atoms%Z == Z))) + ii = 0 + do i=1, this%atoms%N + if (Z == 0) then + ii = ii + 1 + atom_indices(ii) = i + else + if (this%atoms%Z(i) == Z) then + ii = ii + 1 + atom_indices(ii) = i + endif + endif + end do + endif + + !Add the constraint + call ds_add_constraint(this,atom_indices,STRUCT_FACTOR_LIKE_I_FUNC,(/q(1),q(2),q(3),SF/), restraint_k=restraint_k, bound=bound, tol=tol, print_summary=print_summary) + + deallocate(atom_indices) + + end subroutine constrain_struct_factor_like_i + + !% Add a constraint to the DynamicalSystem and reduce the number of degrees of freedom, + !% unless 'update_Ndof' is present and false. + subroutine ds_add_constraint(this,atoms,func,data,update_Ndof, restraint_k, bound, tol, print_summary) + + type(DynamicalSystem), intent(inout) :: this + integer, dimension(:), intent(in) :: atoms + integer, intent(in) :: func + integer, optional, intent(in) :: bound + real(dp), dimension(:), intent(in) :: data + logical, optional, intent(in) :: update_Ndof + real(dp), optional, intent(in) :: restraint_k, tol + logical, optional, intent(in) :: print_summary + + integer :: i, type, g1, g2, n, new_constraint + logical :: do_update_Ndof, do_print_summary + + do_update_Ndof = optional_default(.true., update_Ndof) + do_print_summary = optional_default(.true., print_summary) + + !Have constraints been declared when the dynamicalsystem was initialised? + + if (present(restraint_k)) then ! restraint + + if (.not.allocated(this%restraint)) & + call system_abort('ds_add_constraint: Restraints array has not been allocated') + + this%Nrestraints = this%Nrestraints + 1 + new_constraint = this%Nrestraints + if (this%Nrestraints > size(this%restraint)) call system_abort('ds_add_constraint: Restraint array size '//size(this%restraint)//' not enough space for '//this%Nrestraints//' restraints') + if (present(tol)) call print("ds_add_constraint: Restraints will ignore the explicitly given constraint tolerance.",PRINT_ALWAYS) + call initialise(this%restraint(new_constraint),atoms,func,data,restraint_k,bound=bound) + call constraint_calculate_values_at(this%restraint(new_constraint),this%atoms,this%t) + this%restraint(new_constraint)%print_summary = do_print_summary + + else ! constraint + + if (.not.allocated(this%constraint)) & + call system_abort('ds_add_constraint: Constraints array has not been allocated') + + !First make sure the atoms are of TYPE_ATOM or TYPE_CONSTRAINED. If they are of + !TYPE_ATOM they must be in a group on their own, otherwise all the other atoms will + !be added to the CONSTRAINED group, but never be integrated. + do i = 1, size(atoms) + type = Atom_Type(this,atoms(i)) + if ((type /= TYPE_ATOM) .and. (type /= TYPE_CONSTRAINED)) then + call system_abort('ds_add_constraint: Atom '//i// & + ' is not a normal or constrained atom (type = '//type//')') + end if + if (type == TYPE_ATOM) then + g1 = this%group_lookup(atoms(i)) + if (Group_N_Atoms(this%group(g1)) > 1) call system_abort(& + 'ds_add_constraint: A normal atom must be in its own group when added to a constraint') + end if + end do + + !Merge all the groups containing the atoms in this constraint + g1 = this%group_lookup(atoms(1)) + call set_type(this%group(g1),TYPE_CONSTRAINED) + do i = 2, size(atoms) + g2 = this%group_lookup(atoms(i)) + + call set_type(this%group(g2),TYPE_CONSTRAINED) + call merge_groups(this%group(g1),this%group(g2)) + end do + + !Increase the constraint counter and initialise the new constraint + this%Nconstraints = this%Nconstraints + 1 + new_constraint = this%Nconstraints + if (this%Nconstraints > size(this%constraint)) call system_abort('ds_add_constraint: Constraint array full') + call initialise(this%constraint(new_constraint),atoms,func,data,tol=tol) + this%constraint(new_constraint)%print_summary = do_print_summary + + !Update the group_lookups + do n = 1, Group_N_atoms(this%group(g1)) + i = Group_Nth_Atom(this%group(g1),n) + this%group_lookup(i) = g1 + end do + + !Add the constraint as an object for this group + call group_add_object(this%group(g1),new_constraint) + + !Reduce the number of degrees of freedom + if (do_update_Ndof) this%Ndof = this%Ndof - 1 + + !Call the constraint subroutine to fill in variables: + call constraint_calculate_values_at(this%constraint(new_constraint),this%atoms,this%t) + + !Give warning if they constraint is not being satisfied + if (abs(this%constraint(new_constraint)%C) > CONSTRAINT_WARNING_TOLERANCE) & + call print_message('WARNING', 'ds_add_constraint: This constraint ('//new_constraint//') is not currently obeyed: C = '// & + round(this%constraint(new_constraint)%C,5)) + + call constraint_store_gradient(this%constraint(new_constraint)) + endif + + end subroutine ds_add_constraint + + ! + !% Replace a constraint involving some atoms with a different constraint involving + !% the same atoms + ! + subroutine ds_amend_constraint(this,constraint,func,data,k) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: constraint, func + real(dp), dimension(:), intent(in) :: data + real(dp), optional, intent(in) :: k + + call constraint_amend(this%constraint(constraint),func,data,k) + + end subroutine ds_amend_constraint + + ! + !% Return the distance between two atoms and the relative velocity + !% between them projected along the bond direction. + !% This is useful for time dependent constraints. + ! + subroutine distance_relative_velocity(at,i,j,dist,rel_velo) + + type(Atoms), intent(in) :: at + integer, intent(in) :: i,j + real(dp), intent(out) :: dist,rel_velo + real(dp), dimension(3) :: r,v + + r = diff_min_image(at,i,j) !rj - ri + dist = norm(r) + + v = at%velo(:,j) - at%velo(:,i) + + rel_velo = (v .dot. r) / dist + + end subroutine distance_relative_velocity + +! subroutine accumulate_kinetic_energy(this,i,ek,Ndof) +! +! type(dynamicalsystem), intent(in) :: this +! integer, intent(in) :: i +! real(dp), intent(inout) :: ek, Ndof +! +! integer :: g +! +! g = this%group_lookup(i) +! +! select case(this%group(g)%type) +! +! case(TYPE_ATOM) +! ek = eK + 0.5_dp*this%atoms%mass(i)*normsq(this%atoms%velo(:,i)) +! Ndof = Ndof + 3.0_dp +! +! case(TYPE_CONSTRAINED) +! ek = ek + 0.5_dp*this%atoms%mass(i)*normsq(this%atoms%velo(:,i)) +! Ndof = Ndof + 3.0_dp - (real(group_n_objects(this%group(g)),dp) / real(group_n_atoms(this%group(g)),dp)) +! +! case default +! call system_abort('accumulate_kinetic_energy: cannot handle atoms with type = '//this%group(g)%type) +! +! end select +! +! end subroutine accumulate_kinetic_energy + + function degrees_of_freedom(ds,i) result(Ndof) + + type(dynamicalsystem), intent(in) :: ds + integer, intent(in) :: i + real(dp) :: Ndof + + integer :: g + + if (ds%atoms%move_mask(i) == 0) then + Ndof = 0.0_dp + return + end if + + g = ds%group_lookup(i) + + select case(ds%group(g)%type) + + case(TYPE_ATOM) + Ndof = 3.0_dp + + case(TYPE_CONSTRAINED) + Ndof = 3.0_dp - (real(group_n_objects(ds%group(g)),dp) / real(group_n_atoms(ds%group(g)),dp)) + + case default + call system_abort('degrees_of_freedom: cannot handle atoms with type = '//ds%group(g)%type) + + end select + + end function degrees_of_freedom + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X FIXING ATOMS + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% This subroutine fixes a list of atoms. If the atoms are unconstrained then it + !% simply sets move_mask to 0 and advance_verlet does nothing with them. + !% If the atom is constrained then the situation is more complicated: if only one + !% atom in a constrained group is fixed then this must be implemented as 3 + !% constraints (the atom is constrained to the intersection of 3 planes). This is + !% required so that the shake and rattle algorithms work correctly with any further + !% constraints of which the atom is a part. Move_mask is also zeroed in this case. + + subroutine fix_atoms(this,index,restraint_k) + + type(dynamicalsystem), intent(inout) :: this + integer, dimension(:), intent(in) :: index + real(dp), optional, intent(in) :: restraint_k + + integer :: i, g, n + logical, save :: plane_registered = .false. + integer, save :: PLANE_FUNC + + do n = 1, size(index) + + !Zero the move_mask + i = index(n) + + if (this%atoms%move_mask(i) == 0) cycle + + this%atoms%move_mask(i) = 0 + + !Update the number of DoF + this%Ndof = this%Ndof - 3 + + !See if constraints need adding + g = this%group_lookup(i) + if (this%group(g)%type == TYPE_CONSTRAINED) then + + ! Make sure the PLANE constraint function is registered + if (.not.plane_registered) then + PLANE_FUNC = register_constraint(PLANE) + plane_registered = .true. + end if + + !Add the constraints for three intersecting planes + call ds_add_constraint(this,(/i/),PLANE_FUNC,(/1.0_dp,0.0_dp,0.0_dp,this%atoms%pos(1,i)/),restraint_k=restraint_k) + call ds_add_constraint(this,(/i/),PLANE_FUNC,(/0.0_dp,1.0_dp,0.0_dp,this%atoms%pos(2,i)/),restraint_k=restraint_k) + call ds_add_constraint(this,(/i/),PLANE_FUNC,(/0.0_dp,0.0_dp,1.0_dp,this%atoms%pos(3,i)/),restraint_k=restraint_k) + + end if + + end do + + end subroutine fix_atoms + +end module DynamicalSystem_module diff --git a/src/libAtoms/ExtendableStr.F90 b/src/libAtoms/ExtendableStr.F90 new file mode 100644 index 0000000000..2ae0bc7719 --- /dev/null +++ b/src/libAtoms/ExtendableStr.F90 @@ -0,0 +1,716 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Extendable string module +!X +!% Defines strings that can extend as required, using a character array +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module extendable_str_module + +use error_module +use system_module +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif +implicit none + +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif + +private + +integer, parameter :: EXTENDABLE_STRING_LENGTH_INCREMENT = 10240 !% Increment of extendable string +integer, parameter :: extendable_string_reading_buffer = 1024 !% Read ext_string by chunks of this size + +public :: extendable_str +type extendable_str + character(len=1), allocatable :: s(:) + integer :: len = 0 + integer :: increment = EXTENDABLE_STRING_LENGTH_INCREMENT + integer :: cur = 0 +end type extendable_str + + +public :: concat +interface concat + module procedure extendable_str_concat +end interface concat + +public :: string +interface string + module procedure extendable_str_string +end interface string + +public :: substr +interface substr + module procedure extendable_str_substr +end interface substr + +public :: substr_replace +interface substr_replace + module procedure extendable_str_substr_replace +end interface substr_replace + +public :: read +interface read + module procedure extendable_str_read_unit, extendable_str_read_file +end interface read + +public :: initialise +interface initialise + module procedure extendable_str_initialise +end interface initialise + +public :: zero +interface zero + module procedure extendable_str_zero +end interface zero + +public :: finalise +interface finalise + module procedure extendable_str_finalise +end interface finalise + +public :: print +interface print + module procedure extendable_str_print +end interface print + +!public :: len +!interface len +! module procedure extendable_str_len +!endinterface + +public :: read_line +interface read_line + module procedure extendable_str_read_line +end interface read_line + +public :: parse_line +interface parse_line + module procedure extendable_str_parse_line +end interface parse_line + +public :: index +interface index + module procedure extendable_str_index +end interface index + +public :: bcast +interface bcast + module procedure extendable_str_bcast +end interface bcast + +public :: operator(//) +interface operator(//) + module procedure extendable_str_cat_string, string_cat_extendable_str + module procedure extendable_str_cat_extendable_str + module procedure string_cat_extendable_str_array +end interface operator(//) + +public :: assignment(=) +interface assignment(=) + module procedure extendable_str_assign_string + module procedure string_assign_extendable_str +#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY + module procedure extendable_str_assign_extendable_str +#endif +endinterface + +contains + +subroutine extendable_str_initialise(this, copy_from) + type(extendable_str), intent(inout) :: this + type(extendable_str), intent(in), optional :: copy_from + + call finalise(this) + + if (present(copy_from)) then + this%len = copy_from%len + this%increment = copy_from%increment + this%cur = copy_from%cur + allocate(this%s(this%len)) + this%s = copy_from%s + endif +end subroutine extendable_str_initialise + +subroutine extendable_str_finalise(this) + type(extendable_str), intent(inout) :: this + + if (allocated(this%s)) deallocate(this%s) + this%cur = 0 + this%len = 0 + this%increment = EXTENDABLE_STRING_LENGTH_INCREMENT +end subroutine extendable_str_finalise + +subroutine extendable_str_zero(this) + type(extendable_str), intent(inout) :: this + + this%len = 0 +end subroutine extendable_str_zero + +subroutine extendable_str_print(this,verbosity,file) + use iso_c_binding + implicit none + type(extendable_str), intent(in) :: this + integer, intent(in), optional :: verbosity + type(Inoutput), intent(inout),optional:: file + + if (allocated(this%s)) then + call print ("extendable_str, len " // this%len // " size(s) " // size(this%s), verbosity, file) + call print(this%s(1:this%len)) +! OLD IMPLEMENTATION +! do i=1, this%len +! call print (this%s(i), verbosity, out) +! end do + else + call print("extendable_str, len " // this%len // " not allocated", verbosity, file) + endif +end subroutine extendable_str_print + +pure function extendable_str_len(this) + type(extendable_str), intent(in) :: this + integer :: extendable_str_len + extendable_str_len = this%len +end function extendable_str_len + +subroutine extendable_str_concat(this, str, keep_lf, add_lf_if_missing, no_trim, lf_to_whitespace) + type(extendable_str), intent(inout) :: this + character(len=*), intent(in) :: str + logical, intent(in), optional :: keep_lf, add_lf_if_missing, no_trim, lf_to_whitespace + + character, allocatable :: t(:) + integer str_len + integer add_len, new_len + integer i + logical my_keep_lf, my_add_lf_if_missing, my_no_trim, my_lf_to_whitespace + logical :: add_lf + + my_keep_lf = optional_default(.true., keep_lf) + my_add_lf_if_missing = optional_default(.false., add_lf_if_missing) + my_no_trim = optional_default(.false., no_trim) + my_lf_to_whitespace = optional_default(.false., lf_to_whitespace) + + if (my_no_trim) then + str_len = len(str) + else + str_len = len_trim(str) + endif + add_lf = .false. + if (str_len > 0) then + if (my_add_lf_if_missing .and. str(str_len:str_len) /= quip_new_line) add_lf = .true. + else + add_lf = my_add_lf_if_missing + endif + add_len = str_len + if (add_lf) add_len = add_len + 1 + if (add_len > 0) then + if (allocated(this%s)) then ! already allocated contents + new_len = this%len + add_len + if (new_len > size(this%s)) then ! new length too big for current allocated array + if (this%increment > 0) then + new_len = size(this%s) + do while(new_len < this%len + add_len) + new_len = new_len + this%increment + this%increment = this%increment*2 + enddo + endif + if (this%len > 0) then ! need to save old data + allocate(t(size(this%s))) + t = this%s + deallocate(this%s) + allocate(this%s(new_len)) + this%s(1:this%len) = t(1:this%len) + deallocate(t) + else ! don't need to save old data + if (this%increment > 0) then + new_len = this%increment + this%increment = this%increment*2 + do while (new_len < this%len + add_len) + new_len = new_len + this%increment + this%increment = this%increment*2 + enddo + endif + deallocate(this%s) + allocate(this%s(new_len)) + endif + endif + else ! array not already allocated + allocate(this%s(add_len)) + this%len = 0 + endif + + do i=1, str_len + if ( ( .not. my_keep_lf .or. my_lf_to_whitespace ) .and. str(i:i) == quip_new_line) then + if(my_lf_to_whitespace) then + this%s(this%len+1) = " " + else + cycle + endif + else + this%s(this%len+1) = str(i:i) + endif + this%len = this%len + 1 + end do + + if (add_lf) then + this%s(this%len+1) = quip_new_line + this%len = this%len + 1 + endif + + endif + + if (this%len > 0 .and. this%cur <= 0) this%cur = 1 + +end subroutine extendable_str_concat + +function extendable_str_string(this) + type(extendable_str), intent(in) :: this + character(len=this%len) :: extendable_str_string + integer i + + do i=1, this%len + extendable_str_string(i:i) = this%s(i) + end do + +end function extendable_str_string + +function extendable_str_substr(this, start, end, error) + type(extendable_str), intent(in) :: this + integer, intent(in) :: start, end + integer, optional, intent(out) :: error + character(len=(end-start+1)) :: extendable_str_substr + integer i, j + + INIT_ERROR(error) + + if (start < 1 .or. start > this%len) then + RAISE_ERROR('extendable_str_substr: start('//start//') < 1 or > this%len='//this%len, error) + end if + if (end < 1 .or. end > this%len) then + RAISE_ERROR('extendable_str_substr: end('//end//') < 1 or > this%len='//this%len, error) + end if + if (end < start) then + RAISE_ERROR('extendable_str_substr: end('//end//') < start('//start//')', error) + endif + + j = 1 + do i=start, end + extendable_str_substr(j:j) = this%s(i) + j = j + 1 + end do + +end function extendable_str_substr + +subroutine extendable_str_substr_replace(this, start, end, replace, error) + type(extendable_str), intent(inout) :: this + integer, intent(in) :: start, end + character(len=*), intent(in) :: replace + integer, optional, intent(out) :: error + + integer :: j, old_len, substr_len + + INIT_ERROR(error) + + if (start < 0 .or. start > this%len+1) then + RAISE_ERROR('extendable_str_substr_replace: start('//start//') < 1 or > thi%len="//this%len', error) + end if + if (end < 0 .or. end > this%len+1) then + RAISE_ERROR('extendable_str_substr_replace: end('//end//') < 1 or > thi%len="//this%len', error) + end if + if (end < start) then + RAISE_ERROR('extendable_str_substr_replace: end('//end//') < start('//start//')', error) + endif + + if ((start == 0 .and. end /= 0) .or. (end == 0 .and. start /= 0)) then + RAISE_ERROR('extendable_str_substr_replace: start('//start//') == 0 and end('//end//') /= 0, or vice versa', error) + endif + if ((start == this%len+1 .and. end /= this%len+1) .or. (end == this%len+1 .and. start /= this%len+1)) then + RAISE_ERROR('extendable_str_substr_replace: start('//start//') < n+1 and end('//end//') /= n+1, or vice versa', error) + endif + + if (start == 0 .or. start == this%len+1) then + substr_len = 0 + else + substr_len = end-start+1 + endif + + if (len(replace) <= substr_len) then ! no need to extend length + ! do replacement + do j=start, start+len(replace)-1 + this%s(j) = replace(j-start+1:j-start+1) + end do + ! move rest of string back if needed + if (len(replace) < substr_len) then ! + do j=1, this%len-(end+1)+1 + this%s(start+len(replace)-1+j) = this%s(end+j) + end do + this%len = this%len - (substr_len - len(replace)) + endif + else ! need to extend length + old_len = this%len + ! extend length + call concat(this, replace(1:len(replace)-substr_len)) + ! move trailing part of string + do j=1, old_len - end + this%s(this%len-j+1) = this%s(old_len-j+1) + end do + ! replace + if (start == 0) then + do j=1, len(replace) + this%s(j) = replace(j:j) + end do + else + do j=start, start+len(replace)-1 + this%s(j) = replace(j-start+1:j-start+1) + end do + endif + endif + +end subroutine extendable_str_substr_replace + +subroutine extendable_str_read_file(this, file, convert_to_string, mpi_comm, mpi_id, keep_lf) + type(extendable_str), intent(inout) :: this + character(len=*), intent(in) :: file + logical, intent(in), optional :: convert_to_string + integer, intent(in), optional :: mpi_comm, mpi_id + logical, intent(in), optional :: keep_lf + + type(inoutput) :: in + logical do_read + + do_read = .true. + if (present(mpi_comm)) then + if (.not. present(mpi_id)) then + call system_abort("extendable_str_read_file got mpi_comm but not mpi_id") + endif + if (mpi_id /= 0) do_read = .false. + end if + + if (do_read) call initialise(in, trim(file), INPUT) + call read(this, in%unit, convert_to_string, mpi_comm, mpi_id, keep_lf) + if (do_read) call finalise(in) + +end subroutine extendable_str_read_file + +#ifdef PGI_IOSTAT_FUNCS +function is_iostat_end(stat) + integer, intent(in) :: stat + logical :: is_iostat_end + + if (stat == -1) then + is_iostat_end = .true. + else + is_iostat_end = .false. + endif +end function is_iostat_end + +function is_iostat_eor(stat) + integer, intent(in) :: stat + logical :: is_iostat_eor + + if (stat == -2) then + is_iostat_eor = .true. + else + is_iostat_eor = .false. + endif +end function is_iostat_eor + +#endif + +subroutine extendable_str_read_unit(this, unit, convert_to_string, mpi_comm, mpi_id, keep_lf) + type(extendable_str), intent(inout) :: this + integer, intent(in) :: unit + logical, intent(in), optional :: convert_to_string + integer, intent(in), optional :: mpi_comm, mpi_id + logical, intent(in), optional :: keep_lf + + character(len=EXTENDABLE_STRING_READING_BUFFER) :: line + integer n_read + integer stat + logical last_was_incomplete + logical done + logical my_convert_to_string + integer stack_size, stack_size_err + logical do_read + logical my_keep_lf + + this%len = 0 + my_convert_to_string = optional_default(.false., convert_to_string) + my_keep_lf = optional_default(.false., keep_lf) + + do_read = .true. + if (present(mpi_comm)) then + if (.not. present(mpi_id)) then + call system_abort("extendable_str_read_unit got mpi_comm but not mpi_id") + endif + if (mpi_id /= 0) do_read = .false. + end if + + if (do_read) then + if (.not. is_open(unit)) call system_abort("Trying to read into extendable_str from unopened unit "//unit//".") + + done = .false. + last_was_incomplete = .true. + do while (.not. done) + read (unit=unit, fmt='(A)', iostat=stat, advance='no', size=n_read) line + if (.not. is_iostat_end(stat)) then + if (n_read == 0 .and. .not. is_iostat_eor(stat) ) cycle + if (.not.last_was_incomplete .and. .not. my_keep_lf) then + call concat(this, " " // trim(line)) + else + call concat(this, trim(line)) + endif + if(is_iostat_eor(stat)) then + if(my_keep_lf) then + call concat(this, quip_new_line) + elseif(n_read == 0) then + call concat(this, " ") + endif + endif + last_was_incomplete = (stat == 0) + else + done = .true. ! EOF + endif + end do + endif + + call extendable_str_bcast(this, mpi_comm, mpi_id) + + if (my_convert_to_string) then + stack_size = floor(this%len/1024.0_dp) + 10 + stack_size_err = increase_stack(stack_size) + if (stack_size_err /= 0) then + call print("extendable_str_read_unit: error calling c_increase_stack size = " // stack_size // & + " err = "// stack_size_err) + endif + endif + + if (this%len > 0) this%cur = 1 + +end subroutine extendable_str_read_unit + +subroutine extendable_str_bcast(this, mpi_comm, mpi_id) + type(extendable_str), intent(inout) :: this + integer, intent(in), optional :: mpi_comm, mpi_id + +#ifdef _MPI + integer err, size_this_s + + if (present(mpi_comm)) then + if (.not. present(mpi_id)) then + call system_abort("extendable_str_bcast got mpi_comm but not mpi_id") + endif + if (mpi_id == 0) then + call mpi_bcast(size(this%s), 1, MPI_INTEGER, 0, mpi_comm, err) + call mpi_bcast(this%len, 1, MPI_INTEGER, 0, mpi_comm, err) + call mpi_bcast(this%increment, 1, MPI_INTEGER, 0, mpi_comm, err) + call mpi_bcast(this%s, this%len, MPI_CHARACTER, 0, mpi_comm, err) + else + call finalise(this) + call mpi_bcast(size_this_s, 1, MPI_INTEGER, 0, mpi_comm, err) + call mpi_bcast(this%len, 1, MPI_INTEGER, 0, mpi_comm, err) + call mpi_bcast(this%increment, 1, MPI_INTEGER, 0, mpi_comm, err) + allocate(this%s(size_this_s)) + call mpi_bcast(this%s, this%len, MPI_CHARACTER, 0, mpi_comm, err) + endif + endif +#endif + + return +end subroutine extendable_str_bcast + +pure function extendable_str_index(this, substr) + type(extendable_str), intent(in) :: this + character(len=*), intent(in) :: substr + integer extendable_str_index + + logical found_it + integer i, j + + if (this%cur <= 0 .or. size(this%s) <= 0) return + + extendable_str_index = 0 + + do i=this%cur, this%len-len(substr)+1 + found_it = .true. + do j=0, len(substr)-1 + if (this%s(i+j) /= substr(j+1:j+1)) found_it = .false. + if (.not. found_it) exit + end do + if (found_it) then + extendable_str_index = i + return + endif + end do + +end function extendable_str_index + +function extendable_str_read_line(this, status) + type(extendable_str), intent(inout) :: this + integer, intent(out), optional :: status + character(len=max(1,index(this,quip_new_line)-this%cur)) :: extendable_str_read_line + + integer line_len + integer i + + line_len = index(this,quip_new_line)-this%cur + + if (this%cur <= this%len) then + do i=1, line_len + extendable_str_read_line(i:i) = this%s(this%cur+i-1) + end do + this%cur = this%cur + max(line_len+1,0) + endif + + if (present(status)) then + if (line_len < 1) then + status = -1 + else + status = 0 + endif + endif + +end function extendable_str_read_line + +subroutine extendable_str_parse_line(this, delimiters, fields, num_fields, status) + type(extendable_str), intent(inout) :: this + character(*), intent(in) :: delimiters + character(*), dimension(:), intent(inout) :: fields + integer, intent(out) :: num_fields + integer, optional, intent(out) :: status + + integer my_status + character(len=EXTENDABLE_STRING_LENGTH_INCREMENT) :: local_line + + local_line = read_line(this, my_status) + if (present(status)) status = my_status + if (my_status == 0) then + call parse_string(local_line, delimiters, fields, num_fields) + endif +end subroutine extendable_str_parse_line + +function extendable_str_cat_string(this, str) + type(extendable_str), intent(in) :: this + character(*), intent(in) :: str + + type(extendable_str) :: extendable_str_cat_string + + ! --- + + call initialise(extendable_str_cat_string, this) + call concat(extendable_str_cat_string, str) +end function extendable_str_cat_string + +function string_cat_extendable_str(str, this) + character(*), intent(in) :: str + type(extendable_str), intent(in) :: this + + character(len(str)+this%len) :: string_cat_extendable_str + + ! --- + + string_cat_extendable_str = str + string_cat_extendable_str(max(1,len(str)+1):) = string(this) +end function string_cat_extendable_str + +pure function sumlen(this) + type(extendable_str), intent(in) :: this(:) + integer :: sumlen, i + sumlen = 0 + do i = lbound(this, 1), ubound(this, 1) + sumlen = sumlen + this(i)%len + enddo +endfunction sumlen + +function string_cat_extendable_str_array(str, this) + character(*), intent(in) :: str + type(extendable_str), intent(in) :: this(:) + character(len(str)+sumlen(this)+3*size(this)) :: string_cat_extendable_str_array + integer :: i, c + + string_cat_extendable_str_array = str + c = max(1,len(str)+1) + do i = lbound(this, 1), ubound(this, 1) + call print("i = " // i // ", c = " // c // ", len(str) = " // this(i)%len // ", str = " // this(i)) + string_cat_extendable_str_array(c:c+this(i)%len+2) = "'" // string(this(i)) // "'" + c = c+this(i)%len+3 + enddo +end function string_cat_extendable_str_array + +function extendable_str_cat_extendable_str(this, str) + type(extendable_str), intent(in) :: this + type(extendable_str), intent(in) :: str + + type(extendable_str) :: extendable_str_cat_extendable_str + + ! --- + + call initialise(extendable_str_cat_extendable_str, this) + call concat(extendable_str_cat_extendable_str, string(str)) +end function extendable_str_cat_extendable_str + +subroutine extendable_str_assign_string(to, from) + type(extendable_str), intent(out) :: to + character(*), intent(in) :: from + + call initialise(to) + call concat(to, from) +end subroutine extendable_str_assign_string + +#ifdef ALLOCATABLE_COMPONENT_MANUAL_COPY +subroutine extendable_str_assign_extendable_str(to, from) + type(extendable_str), intent(out) :: to + type(extendable_str), intent(in) :: from + + call initialise(to) + call concat(to, string(from)) +end subroutine extendable_str_assign_extendable_str +#endif + +subroutine string_assign_extendable_str(to, from) + type(extendable_str), intent(in) :: from + character(from%len), intent(out) :: to + + to = string(from) +end subroutine string_assign_extendable_str + + +end module extendable_str_module diff --git a/src/libAtoms/Group.F90 b/src/libAtoms/Group.F90 new file mode 100644 index 0000000000..099612f285 --- /dev/null +++ b/src/libAtoms/Group.F90 @@ -0,0 +1,812 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Group module +!X +!% A Group is a collection of atoms, with an optional list of objects. These +!% objects can be anything, e.g. rigid bodies, constraints, residues... etc. +!% The idea is that different groups of atoms will require their equations of +!% motion integrating in different ways, so currently AdvanceVerlet loops over all +!% groups, checks the type of the group and integrates the equations of motion +!% for the atoms in that group in the appropriate way. +!% +!% Two examples: +!% +!% \begin{itemize} +!% \item A methane molecule with all C-H bonds fixed would have all 5 of its atoms in one +!% group, which would also contain (the indices of) four constraints. During +!% AdvanceVerlet the RATTLE algorithm can find the correct constraint objects to +!% enforce the fixed bond lengths +!% +!% \item A rigid ammonia molecule could be treated as a rigid body, in which case the +!% group would contain the indices of all 4 of the atoms, and the index of 1 rigid body +!% in the 'objects' array. Then, during AdvanceVerlet, the NO_SQUISH algorithm would +!% propagate these atoms rigidly all at the same time. +!% \end{itemize} +!% +!% Initially, when a DynamicalSystem is initialised each atom is put into its own +!% group. As constraints and rigid bodies are added the number of groups remains +!% the same but some of them become empty. These empty groups can be used if extra +!% atoms are added to the system, or they can be left without a problem. If more +!% memory is needed then DS_Free_Groups can be called, which deletes all the empty groups +!% and recreates the group_lookup array inside DynamicalSystem. This is most useful +!% if all the constraints/rigid bodies are set up before a simulation and are known +!% to never change. +!% +!% A few notes: +!% +!% \begin{itemize} +!% \item Groups aren't necessarily limited to the usage described here +!% +!% \item The 'atom' and 'object' arrays are self extensible, but are always exactly +!% the right size (unlike a Table). This is based on the assumption that they will +!% not change much (if at all) after they have been initially set up. +!% +!% \item Each group has a 'type', which defines how its atoms are integrated. Currently +!% the types are 'TYPE_IGNORE' (numerically zero, and atoms in it are not integrated, +!% which could replace the move_mask variable(?)), 'TYPE_ATOM' (a normal atom), +!% 'TYPE_CONSTRAINED' and 'TYPE_RIGID'. The idea is that if other ways of integrating +!% atoms is required (e.g. linear molecules, positional restraints, belly atoms, etc.) +!% then an new type will be defined and the new will be added to the 'select case' +!% constructs in AdvanceVerlet. +!% \end{itemize} +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module group_module + + use system_module + use linearalgebra_module + + implicit none + private + + public :: group, print, initialise, finalise, set_type + public :: group_n_objects, group_nth_object, group_n_atoms, group_nth_atom + public :: num_free_groups, free_group, tidy_groups, groups_create_lookup + public :: group_add_atom, group_delete_atom, group_add_object, merge_groups + + type Group + + integer :: type !% a 'TYPE_' label for all the atoms in the group + integer, allocatable, dimension(:) :: atom !% a list of atoms in the group in ascending order + integer, allocatable, dimension(:) :: object !% a list of objects these atoms are contained in, e.g. + !% a single rigid body for the whole group, or + !% the subset of the constraints involving these atoms + end type Group + + interface print + module procedure group_print, groups_print + end interface print + + interface initialise + module procedure group_initialise + end interface initialise + + interface finalise + module procedure group_finalise, groups_finalise + end interface finalise + + interface assignment(=) + module procedure group_assign_group, groups_assign_groups + end interface assignment(=) + + interface set_type + module procedure set_type_group + end interface set_type + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Initialise + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine group_initialise(this,type,atoms,objects) + + type(Group), intent(inout) :: this + integer, intent(in) :: type + integer, optional, dimension(:), intent(in) :: atoms + integer, optional, dimension(:), intent(in) :: objects + + this%type = type + + if (allocated(this%atom)) deallocate(this%atom) + if (present(atoms)) then + if (size(atoms)>0) then + allocate(this%atom(size(atoms))) + this%atom = atoms + call insertion_sort(this%atom) + end if + end if + + if (allocated(this%object)) deallocate(this%object) + if (present(objects)) then + if (size(objects)>0) then + allocate(this%object(size(objects))) + this%object = objects + call insertion_sort(this%object) + end if + end if + + end subroutine group_initialise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Finalise + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine group_finalise(this) + + type(Group), intent(inout) :: this + + this%type = 0 + + if (allocated(this%atom)) deallocate(this%atom) + if (allocated(this%object)) deallocate(this%object) + + end subroutine group_finalise + + ! + !% Finalise and deallocate an array of groups + ! + subroutine groups_finalise(this) + + type(Group), dimension(:), allocatable, intent(inout) :: this + integer :: i + + if (allocated(this)) then + do i = 1, size(this) + call group_finalise(this(i)) + end do + deallocate(this) + end if + + end subroutine groups_finalise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Assignment + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine group_assign_group(to,from) + + type(Group), intent(inout) :: to + type(Group), intent(in) :: from + + call group_finalise(to) + + to%type = from%type + if (allocated(from%atom)) then + allocate(to%atom(size(from%atom))) + to%atom = from%atom + end if + if (allocated(from%object)) then + allocate(to%object(size(from%object))) + to%object = from%object + end if + + end subroutine group_assign_group + + subroutine groups_assign_groups(to,from) + + type(Group), dimension(:), intent(inout) :: to + type(Group), dimension(:), intent(in) :: from + integer :: i + + if (size(to) /= size(from)) call system_abort('Groups_Assign_Groups: Target and source sizes differ') + + do i = 1, size(from) + to(i) = from(i) + end do + + end subroutine groups_assign_groups + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Setting the type + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine set_type_group(this,type) + + type(Group), intent(inout) :: this + integer, intent(in) :: type + + this%type = type + + end subroutine set_type_group + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !% Merge: $g1 + g2 \to g1$. If $g2 = g1$ then the result is $g1$ + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine merge_groups(g1,g2) + + type(Group), intent(inout) :: g1,g2 + integer :: type ! + integer, allocatable, dimension(:) :: atom ! Temporary storage + integer, allocatable, dimension(:) :: object ! + integer :: atom_size, object_size, i + + if (g1%type /= g2%type) call system_abort('Merge_Groups: Groups are of different types') + + type = g1%type + + !Allocate the temporary 'atom' array to the max required + atom_size = 0 + if (allocated(g1%atom)) atom_size = atom_size + size(g1%atom) + if (allocated(g2%atom)) atom_size = atom_size + size(g2%atom) + allocate(atom(atom_size)) + !Put each atom into the array only once, + atom_size = 0 + if (allocated(g1%atom)) then + do i = 1, size(g1%atom) + if (.not. is_in_array(atom(1:atom_size),g1%atom(i))) then + atom_size = atom_size + 1 + atom(atom_size) = g1%atom(i) + end if + end do + end if + if (allocated(g2%atom)) then + do i = 1, size(g2%atom) + if (.not. is_in_array(atom(1:atom_size),g2%atom(i))) then + atom_size = atom_size + 1 + atom(atom_size) = g2%atom(i) + end if + end do + end if + + !Now do the same for 'object' + object_size = 0 + if (allocated(g1%object)) object_size = object_size + size(g1%object) + if (allocated(g2%object)) object_size = object_size + size(g2%object) + allocate(object(object_size)) + object_size = 0 + if (allocated(g1%object)) then + do i = 1, size(g1%object) + if (.not. is_in_array(object(1:object_size),g1%object(i))) then + object_size = object_size + 1 + object(object_size) = g1%object(i) + end if + end do + end if + if (allocated(g2%object)) then + do i = 1, size(g2%object) + if (.not. is_in_array(object(1:object_size),g2%object(i))) then + object_size = object_size + 1 + object(object_size) = g2%object(i) + end if + end do + end if + + !Finalise the groups + call finalise(g1) + call finalise(g2) + + !Re-initialise g1 with the new data + call initialise(g1,type,atom(:atom_size),object(:object_size)) + + end subroutine merge_groups + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !% Deleting from a group + !% + !% NOTE: It is, for example, the atom with index 'i' (not 'this%atom(i)') which is deleted + !% Also, if atom/object is empty after deletion it is deallocated + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine group_delete_atom(this,i) + + type(Group), intent(inout) :: this + integer, intent(in) :: i + integer :: pos + integer, allocatable, dimension(:) :: temp_atom + + if (allocated(this%atom)) then + if (size(this%atom) == 0) call system_abort('Group_Delete_Atom: Group has no atoms') + !Find the atoms positions in the array + pos = find_in_array(this%atom,i) + if (pos == 0) then + write(line,'(a,i0,a)')'Group_Delete_Atom: Atom ',i,' is not in this group' + call system_abort(line) + end if + !Copy the others into the temporary + this%atom(pos) = this%atom(size(this%atom)) + if (size(this%atom) > 1) then + allocate(temp_atom(size(this%atom)-1)) + temp_atom = this%atom(1:size(this%atom)-1) + call insertion_sort(temp_atom) + !Copy back the remaining sorted data into the correctly sized atom array + deallocate(this%atom) + allocate(this%atom(size(temp_atom))) + this%atom = temp_atom + deallocate(temp_atom) + else + deallocate(this%atom) + end if + else + call system_abort('Group_Delete_Atom: Group has no atoms') + end if + + end subroutine group_delete_atom + + subroutine group_delete_object(this,i) + + type(Group), intent(inout) :: this + integer, intent(in) :: i + integer :: pos + integer, allocatable, dimension(:) :: temp_object + + if (allocated(this%object)) then + if (size(this%object) == 0) call system_abort('Group_Delete_Object: Group has no objects') + !Find the objects positions in the array + pos = find_in_array(this%object,i) + if (pos == 0) then + write(line,'(a,i0,a)')'Group_Delete_Object: Object ',i,' is not in this group' + call system_abort(line) + end if + !Copy the others into the temporary + this%object(pos) = this%object(size(this%object)) + if (size(this%object) > 1) then + allocate(temp_object(size(this%object)-1)) + temp_object = this%object(1:size(this%object)-1) + call insertion_sort(temp_object) + !Copy back the remaining sorted data into the correctly sized object array + deallocate(this%object) + allocate(this%object(size(temp_object))) + this%object = temp_object + deallocate(temp_object) + else + deallocate(this%object) + end if + else + call system_abort('Group_Delete_Object: Group has no objects') + end if + + end subroutine group_delete_object + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !% Adding objects to a group + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine group_add_atom(this,atom) + + type(Group), intent(inout) :: this + integer, intent(in) :: atom + integer, allocatable, dimension(:) :: temp_atom + + if (allocated(this%atom)) then + if (.not. is_in_array(this%atom,atom)) then + allocate(temp_atom(size(this%atom)+1)) + temp_atom = (/this%atom,atom/) + call insertion_sort(temp_atom) + deallocate(this%atom) + allocate(this%atom(size(temp_atom))) + this%atom = temp_atom + deallocate(temp_atom) + end if + else + allocate(this%atom(1)) + this%atom(1) = atom + end if + + end subroutine group_add_atom + + subroutine group_add_object(this,object) + + type(Group), intent(inout) :: this + integer, intent(in) :: object + integer, allocatable, dimension(:) :: temp_object + + if (allocated(this%object)) then + if (.not. is_in_array(this%object,object)) then + allocate(temp_object(size(this%object)+1)) + temp_object = (/this%object,object/) + call insertion_sort(temp_object) + deallocate(this%object) + allocate(this%object(size(temp_object))) + this%object = temp_object + deallocate(temp_object) + end if + else + allocate(this%object(1)) + this%object(1) = object + end if + + end subroutine group_add_object + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !% Inquiring about the size of a group + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + pure function group_n_atoms(this) + + type(Group), intent(in) :: this + integer :: group_n_atoms + + if (allocated(this%atom)) then + group_n_atoms = size(this%atom) + else + group_n_atoms = 0 + end if + + end function group_n_atoms + + function group_nth_atom(this,n) + + type(Group), intent(in) :: this + integer, intent(in) :: n + integer :: group_nth_atom + + if (allocated(this%atom)) then + if (n > size(this%atom)) then + write(line,'(2(a,i0),a)')'Group_Nth_Atom: Requested atom (',n, & + ') is greater than size of group (',size(this%atom),')' + call system_abort(line) + else + group_nth_atom = this%atom(n) + end if + else + call system_abort('Group_Nth_Atom: Group contains no atoms') + end if + + end function group_nth_atom + + pure function group_n_objects(this) + + type(Group), intent(in) :: this + integer :: group_n_objects + + if (allocated(this%object)) then + group_n_objects = size(this%object) + else + group_n_objects = 0 + end if + + end function group_n_objects + + function group_nth_object(this,n) + + type(Group), intent(in) :: this + integer, intent(in) :: n + integer :: group_nth_object + + if (allocated(this%object)) then + if (n > size(this%object)) then + write(line,'(2(a,i0),a)')'Group_Nth_Object: Requested object (',n, & + ') is greater than number of objects (',size(this%object),')' + call system_abort(line) + else + Group_Nth_Object = this%object(n) + end if + else + call system_abort('Group_Nth_Object: Group contains no objects') + end if + + end function group_nth_object + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X I/O + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine group_print(this,verbosity,out,index) + + type(Group), intent(in) :: this + integer, intent(in), optional :: verbosity + type(Inoutput), intent(inout), optional :: out + integer, optional, intent(in) :: index + integer :: i, nbloc, nrest + logical :: have_atoms, have_objects + character(10) :: form + + if (allocated(this%atom)) then + if (size(this%atom) > 0) then + have_atoms = .true. + else + have_atoms = .false. + end if + else + have_atoms = .false. + end if + + if (allocated(this%object)) then + if (size(this%object) > 0) then + have_objects = .true. + else + have_objects = .false. + end if + else + have_objects = .false. + end if + + call print('=========',verbosity,out) + if (present(index)) then + write(line,'(a,i0)')'Group ',index + call print(line,verbosity,out) + else + call print(' Group ',verbosity,out) + end if + call print('=========',verbosity,out) + + call print('',verbosity,out) + + write(line,'(a,i0)')' Type = ',this%type + call print(line,verbosity,out) + + call print('Atoms:',verbosity,out) + + if (have_atoms) then + nbloc=size(this%atom)/5 + nrest=mod(size(this%atom),5) + do i = 1,nbloc + write(line,'(5(1x,i0))') this%atom((i-1)*5+1:(i*5)) + call print(line,verbosity,out) + end do + if (nrest /= 0) then + write(form,'(a,i0,a)') '(',nrest,'(1x,i0))' + write(line,form) this%atom((i-1)*5+1:(i-1)*5+nrest) + call print(line,verbosity,out) + end if + else + call print('(none)',verbosity,out) + end if + + call print('Objects:',verbosity,out) + + if (have_objects) then + nbloc=size(this%object)/5 + nrest=mod(size(this%object),5) + do i = 1,nbloc + write(line,'(5(1x,i0))') this%object((i-1)*5+1:(i*5)) + call print(line,verbosity,out) + end do + if (nrest /= 0) then + write(form,'(a,i0,a)') '(',nrest,'(1x,i0))' + write(line,form) this%object((i-1)*5+1:(i-1)*5+nrest) + call print(line,verbosity,out) + end if + else + call print('(none)',verbosity,out) + end if + + call print('',verbosity,out) + + call print('=========',verbosity,out) + + end subroutine group_print + + ! + !% Printing arrays of groups, with optional first group index + ! + subroutine groups_print(this,verbosity,file,first) + + type(Group), dimension(:), intent(in) :: this + integer, intent(in), optional :: verbosity + type(Inoutput), intent(inout), optional :: file + integer, optional, intent(in) :: first + integer :: my_first, i + + my_first = 1 !default + if (present(first)) my_first = first + + do i = 1, size(this) + call print(this(i),verbosity,file,i-1+my_first) + call print('', verbosity, file) + end do + + end subroutine groups_print + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Working with arrays of Group objects + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + !% Create an atom lookup table: The supplied lookup table will be filled with the + !% group number that atom i belongs to, with an error if it belongs to multiple groups + !% or if an atom is ungrouped (unless ungrouped errors are turned off). + !% + !% The first group is 1 by default, but can be overridden with the 'first' argument + ! + subroutine groups_create_lookup(this,lookup,first,ungrouped_error) + + type(Group), dimension(:), intent(in) :: this + integer, dimension(:), intent(inout) :: lookup + integer, optional, intent(in) :: first + logical, optional, intent(in) :: ungrouped_error + !local variables + integer :: i, g, n, my_first, ungrouped + logical :: ok, my_ungrouped_error + + my_ungrouped_error = .true. + if (present(ungrouped_error)) my_ungrouped_error = ungrouped_error + + !Set the index of the first group correctly + my_first = 1 !default + if (present(first)) my_first = first + + !Initialise all lookups to a non-existent group number + ungrouped = my_first - 1 + lookup = ungrouped + + do g = 1, size(this) + do n = 1, Group_N_Atoms(this(g)) + i = Group_Nth_Atom(this(g),n) + if (i > size(lookup)) then + write(line,'(2(a,i0))')'Groups_Create_Lookup: Tried to store lookup for atom ',i, & + ' but lookup table only has length ',size(lookup) + call system_abort(line) + end if + if (lookup(i) == ungrouped) then + lookup(i) = g - 1 + my_first + else + write(line,'(3(a,i0))')'Groups_Create_Lookup: Atom ',i,' is in groups ',lookup(i),' and ',(g - 1 + my_first) + call system_abort(line) + end if + end do + end do + + !Now check for ungrouped atoms + if (my_ungrouped_error) then + ok = .true. + do i = 1, size(lookup) + if (lookup(i) == ungrouped) then + write(line,'(a,i0,a)')'Groups_Create_Lookup: Atom ',i,' is ungrouped' + call print_message('WARNING', line) + ok = .false. + end if + end do + if (.not.ok) call system_abort('Refresh_Group_Lookups: Ungrouped atoms found') + end if + + end subroutine groups_create_lookup + + ! + !% Tidy up / free memory used by allocatable group array, optionally leaving 'spare' groups empty. + !% Lookups will need to be refreshed after this. + ! + subroutine tidy_groups(this,spare) + + type(Group), dimension(:), allocatable, intent(inout) :: this + integer, optional, intent(in) :: spare + type(Group), dimension(:), allocatable :: temp_group + integer :: Ngroups, i, g + + !Count the number of groups in use (have atoms in them) + Ngroups = 0 + do i = 1, size(this) + if (allocated(this(i)%atom)) then + if (size(this(i)%atom) > 0) Ngroups = Ngroups + 1 + end if + end do + + !Allocate temporary space + allocate(temp_group(Ngroups)) + + !Copy non-empty groups into temp space + g = 0 + do i = 1, size(this) + if (allocated(this(i)%atom)) then + if (size(this(i)%atom) > 0) then + !Copy the group + g = g + 1 + if (allocated(this(i)%object)) then + call initialise(temp_group(g),this(i)%type,this(i)%atom,this(i)%object) + else + call initialise(temp_group(g),this(i)%type,this(i)%atom) + end if + end if + end if + end do + + !Finalise and deallocate the input groups + call finalise(this) + + !Reallocate to the correct size + if (present(spare)) then + allocate(this(Ngroups + spare)) + else + allocate(this(Ngroups)) + end if + + !Copy over the data + this(1:Ngroups) = temp_group !should work with or without 'spare' + + !Deallocate temporary space + call finalise(temp_group) + + end subroutine tidy_groups + + ! + !% Given an array of groups, return the index of an empty one or the lowest index minus 1 (i.e. zero by default) + !% if none are free. If the first index of the array is not 1, then supply it in 'first' + ! + function free_group(this,first) result(n) + + type(Group), dimension(:), intent(in) :: this + integer, optional, intent(in) :: first + integer :: i, n, my_first + logical :: atom_free, object_free, free_found + + my_first = 1 + if (present(first)) my_first = first + free_found = .false. + + do i = 1, size(this) + + atom_free = .not.allocated(this(i)%atom) + object_free = .not.allocated(this(i)%object) + if (atom_free .and. object_free) then + n = i - 1 + my_first + free_found = .true. + exit + end if + + end do + + if (.not.free_found) n = my_first - 1 + + end function free_group + + ! + !% Count the number of free groups in an array + ! + function num_free_groups(this) result(n) + + type(Group), dimension(:), intent(in) :: this + integer :: i,n + logical :: atom_free, object_free + + n = 0 + do i = 1, size(this) + atom_free = .not.allocated(this(i)%atom) + object_free = .not.allocated(this(i)%object) + if (atom_free .and. object_free) n = n + 1 + end do + + end function num_free_groups + +end module group_module diff --git a/src/libAtoms/LinkedList.F90 b/src/libAtoms/LinkedList.F90 new file mode 100644 index 0000000000..6b296e6efd --- /dev/null +++ b/src/libAtoms/LinkedList.F90 @@ -0,0 +1,957 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Linked list module +!X +!X +!% The linked list module contains linked list implementations and retrieval routines. +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module linkedlist_module + use error_module + use system_module + implicit none + + type LinkedList_i + integer :: data + type(LinkedList_i), pointer :: next => null() + endtype LinkedList_i + + type LinkedList_i1d + integer, dimension(:), allocatable :: data + type(LinkedList_i1d), pointer :: next => null() + endtype LinkedList_i1d + + type LinkedList_i2d + integer, dimension(:,:), allocatable :: data + type(LinkedList_i2d), pointer :: next => null() + endtype LinkedList_i2d + + interface initialise + module procedure initialise_LinkedList_i, initialise_LinkedList_i1d, initialise_LinkedList_i2d + endinterface initialise + + interface finalise + module procedure finalise_LinkedList_i, finalise_LinkedList_i1d, finalise_LinkedList_i2d + endinterface finalise + + interface insert + module procedure insert_LinkedList_i, insert_LinkedList_i1d, insert_LinkedList_i2d + endinterface insert + + interface delete_node + module procedure delete_node_LinkedList_i, delete_node_LinkedList_i1d, delete_node_LinkedList_i2d + endinterface delete_node + + interface update + module procedure update_LinkedList_i, update_LinkedList_i1d, update_LinkedList_i2d + endinterface update + + interface retrieve_node + module procedure retrieve_node_LinkedList_i, retrieve_node_LinkedList_i1d, retrieve_node_LinkedList_i2d + endinterface retrieve_node + + interface retrieve + module procedure retrieve_LinkedList_i, retrieve_LinkedList_i1d, retrieve_LinkedList_i2d + endinterface retrieve + + !interface next + ! module procedure next_LinkedList_i1d, next_LinkedList_i2d + !endinterface next + + interface last + module procedure last_LinkedList_i, last_LinkedList_i1d, last_LinkedList_i2d + endinterface last + + interface append + module procedure append_LinkedList_i, append_LinkedList_i1d, append_LinkedList_i2d + endinterface append + + interface size_LinkedList + module procedure size_LinkedList_i, size_LinkedList_i1d, size_LinkedList_i2d + endinterface size_LinkedList + + interface is_in_LinkedList + module procedure is_in_LinkedList_i, is_in_LinkedList_i1d, is_in_LinkedList_i2d + endinterface is_in_LinkedList + + contains + + ! integers + + subroutine initialise_LinkedList_i(this,data,error) + + type(LinkedList_i), pointer, intent(inout) :: this + integer, intent(in), optional :: data + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if(associated(this)) call finalise(this) + + allocate(this) + if( present(data) ) then + this%data = data + endif + this%next => null() + + endsubroutine initialise_LinkedList_i + + subroutine finalise_LinkedList_i(this,error) + type(LinkedList_i), pointer, intent(inout) :: this + integer, intent(out), optional :: error + + type(LinkedList_i), pointer :: current, next + + INIT_ERROR(error) + + if( .not. associated(this) ) return + + current => this + do while( associated(current) ) + next => current%next + deallocate(current) + current => next + enddo + this => null() + + endsubroutine finalise_LinkedList_i + + subroutine insert_LinkedList_i(this,data,error) + type(LinkedList_i), pointer, intent(inout) :: this + integer, intent(in), optional :: data + integer, intent(out), optional :: error + + type(LinkedList_i), pointer :: current + + INIT_ERROR(error) + + if( .not. associated(this)) then + call initialise(this,data,error) + else + allocate(current) + if(present(data)) then + current%data = data + endif + + current%next => this%next + this%next => current + endif + + endsubroutine insert_LinkedList_i + + subroutine delete_node_LinkedList_i(this,node,error) + type(LinkedList_i), pointer, intent(inout) :: this + type(LinkedList_i), pointer, intent(inout) :: node + integer, intent(out), optional :: error + + type(LinkedList_i), pointer :: delete_node => null(), previous => null() + + INIT_ERROR(error) + + if( .not. associated(this) ) return + + if( associated(this,node) ) then + ! remove first node + delete_node => this + this => this%next + deallocate(delete_node) + else + delete_node => this + do + if(associated(delete_node,node)) then + previous%next => delete_node%next + deallocate(delete_node) + exit + endif + previous => delete_node + delete_node => delete_node%next + if( .not. associated(delete_node) ) exit + enddo + endif + + endsubroutine delete_node_LinkedList_i + + function is_in_LinkedList_i(this,data,error) result(found) + type(LinkedList_i), pointer, intent(in) :: this + integer, intent(in), optional :: data + integer, intent(out), optional :: error + + logical :: found + + type(LinkedList_i), pointer :: current + + INIT_ERROR(error) + + found = .false. + if( associated(this)) then + current => this + do + if( associated(current) ) then + if( current%data == data ) then + found = .true. + exit + endif + current => current%next + else + exit + endif + enddo + endif + + endfunction is_in_LinkedList_i + + subroutine update_LinkedList_i(this,data,error) + type(LinkedList_i), pointer, intent(inout) :: this + integer, intent(in) :: data + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if( .not. associated(this)) then + RAISE_ERROR("update_LinkedList_i: linked list not initialised yet.",error) + endif + + this%data = data + + endsubroutine update_LinkedList_i + + function retrieve_node_LinkedList_i(this,error) result(data) + type(LinkedList_i), pointer, intent(in) :: this + integer, intent(out), optional :: error + + integer, pointer :: data + + INIT_ERROR(error) + + if( .not. associated(this)) then + RAISE_ERROR("retrieve_node_LinkedList_i1d: linked list not initialised yet.",error) + endif + + data => this%data + + endfunction retrieve_node_LinkedList_i + + function next_LinkedList_i(this,error) result(next) + type(LinkedList_i), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i), pointer :: next + + if( .not. associated(this)) then + RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) + endif + + next => this%next + + endfunction next_LinkedList_i + + function last_LinkedList_i(this,error) result(last) + type(LinkedList_i), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i), pointer :: last + + if( .not. associated(this)) then + RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) + endif + + last => this + do while( associated(last%next) ) + last => last%next + enddo + + endfunction last_LinkedList_i + + subroutine append_LinkedList_i(this,data,error) + type(LinkedList_i), pointer, intent(inout) :: this + integer, intent(in), optional :: data + integer, intent(out), optional :: error + + type(LinkedList_i), pointer :: current, new + + INIT_ERROR(error) + + if( .not. associated(this)) then + call initialise(this,data,error) + else + allocate(new) + if(present(data)) then + new%data = data + endif + new%next => null() + + current => this + do while( associated(current%next) ) + current => current%next + enddo + current%next => new + endif + + endsubroutine append_LinkedList_i + + subroutine retrieve_LinkedList_i(this,data,error) + type(LinkedList_i), pointer, intent(inout) :: this + integer, dimension(:), allocatable, intent(out) :: data + integer, intent(out), optional :: error + + type(LinkedList_i), pointer :: current + integer :: i, d1 + + INIT_ERROR(error) + + if( .not. associated(this)) then + call reallocate(data,0) + return + endif + + d1 = size_LinkedList(this,error) + + call reallocate(data,d1) + current => this + i = 0 + do + if( associated(current) ) then + i = i + 1 + data(i) = current%data + current => current%next + else + exit + endif + enddo + + endsubroutine retrieve_LinkedList_i + + function size_LinkedList_i(this,error) result(n) + type(LinkedList_i), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i), pointer :: current + + integer :: n + + n = 0 + if( associated(this) ) then + current => this + do + if( associated(current) ) then + n = n + 1 + current => current%next + else + exit + endif + enddo + endif + + endfunction size_LinkedList_i + + ! 1D integer arrays + + subroutine initialise_LinkedList_i1d(this,data,error) + + type(LinkedList_i1d), pointer, intent(inout) :: this + integer, dimension(:), intent(in), optional :: data + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if(associated(this)) call finalise(this) + + allocate(this) + if( present(data) ) then + allocate( this%data(size(data,1)) ) + this%data = data + endif + this%next => null() + + endsubroutine initialise_LinkedList_i1d + + subroutine finalise_LinkedList_i1d(this,error) + type(LinkedList_i1d), pointer, intent(inout) :: this + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: current, next + + INIT_ERROR(error) + + if( .not. associated(this) ) return + + current => this + do while( associated(current) ) + next => current%next + if( allocated(current%data) ) deallocate(current%data) + deallocate(current) + current => next + enddo + this => null() + + endsubroutine finalise_LinkedList_i1d + + subroutine insert_LinkedList_i1d(this,data,error) + type(LinkedList_i1d), pointer, intent(inout) :: this + integer, dimension(:), intent(in), optional :: data + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: current + + INIT_ERROR(error) + + if( .not. associated(this)) then + call initialise(this,data,error) + else + allocate(current) + if(present(data)) then + allocate( current%data(size(data,1)) ) + current%data = data + endif + + current%next => this%next + this%next => current + endif + + endsubroutine insert_LinkedList_i1d + + subroutine delete_node_LinkedList_i1d(this,node,error) + type(LinkedList_i1d), pointer, intent(inout) :: this + type(LinkedList_i1d), pointer, intent(inout) :: node + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: delete_node => null(), previous => null() + + INIT_ERROR(error) + + if( .not. associated(this) ) return + + if( associated(this,node) ) then + ! remove first node + delete_node => this + this => this%next + if( allocated(delete_node%data) ) deallocate(delete_node%data) + deallocate(delete_node) + else + delete_node => this + do + if(associated(delete_node,node)) then + previous%next => delete_node%next + if( allocated(delete_node%data) ) deallocate(delete_node%data) + deallocate(delete_node) + exit + endif + previous => delete_node + delete_node => delete_node%next + if( .not. associated(delete_node) ) exit + enddo + endif + + endsubroutine delete_node_LinkedList_i1d + + function is_in_LinkedList_i1d(this,data,error) result(found) + type(LinkedList_i1d), pointer, intent(in) :: this + integer, dimension(:), intent(in), optional :: data + integer, intent(out), optional :: error + + logical :: found + + type(LinkedList_i1d), pointer :: current + + INIT_ERROR(error) + + found = .false. + if( associated(this)) then + current => this + do + if( associated(current) ) then + if( all( shape(current%data) == shape(data) ) ) then + if( all( current%data == data ) ) then + found = .true. + exit + endif + endif + current => current%next + else + exit + endif + enddo + endif + + endfunction is_in_LinkedList_i1d + + subroutine update_LinkedList_i1d(this,data,error) + type(LinkedList_i1d), pointer, intent(inout) :: this + integer, dimension(:), intent(in) :: data + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if( .not. associated(this)) then + RAISE_ERROR("update_LinkedList_i1d: linked list not initialised yet.",error) + endif + + call reallocate( this%data, size(data,1) ) + this%data = data + + endsubroutine update_LinkedList_i1d + + function retrieve_node_LinkedList_i1d(this,error) result(data) + type(LinkedList_i1d), pointer, intent(in) :: this + integer, intent(out), optional :: error + + integer, dimension(:), pointer :: data + + INIT_ERROR(error) + + if( .not. associated(this)) then + RAISE_ERROR("retrieve_node_LinkedList_i1d: linked list not initialised yet.",error) + endif + + data => this%data + + endfunction retrieve_node_LinkedList_i1d + + function next_LinkedList_i1d(this,error) result(next) + type(LinkedList_i1d), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: next + + if( .not. associated(this)) then + RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) + endif + + next => this%next + + endfunction next_LinkedList_i1d + + function last_LinkedList_i1d(this,error) result(last) + type(LinkedList_i1d), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: last + + if( .not. associated(this)) then + RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) + endif + + last => this + do while( associated(last%next) ) + last => last%next + enddo + + endfunction last_LinkedList_i1d + + subroutine append_LinkedList_i1d(this,data,error) + type(LinkedList_i1d), pointer, intent(inout) :: this + integer, dimension(:), intent(in), optional :: data + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: current, new + + INIT_ERROR(error) + + if( .not. associated(this)) then + call initialise(this,data,error) + else + allocate(new) + if(present(data)) then + allocate( new%data(size(data,1)) ) + new%data = data + endif + new%next => null() + + current => this + do while( associated(current%next) ) + current => current%next + enddo + current%next => new + endif + + endsubroutine append_LinkedList_i1d + + subroutine retrieve_LinkedList_i1d(this,data,error) + type(LinkedList_i1d), pointer, intent(inout) :: this + integer, dimension(:,:), allocatable, intent(out) :: data + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: current + integer :: i, d1, d2 + + INIT_ERROR(error) + + if( .not. associated(this)) then + call reallocate(data,0,0) + return + endif + + d2 = size_LinkedList(this,error) + if( allocated(this%data) ) then + d1 = size(this%data,1) + else + RAISE_ERROR("retrieve_LinkedList_i1d: no data content in head node.", error) + endif + + call reallocate(data,d1,d2) + current => this + i = 0 + do + if( associated(current) ) then + i = i + 1 + if( .not. allocated(current%data) ) then + RAISE_ERROR("retrieve_LinkedList_i1d: data missing from node "//i, error) + endif + if( any( (/d1/) /= shape(current%data) ) ) then + RAISE_ERROR("retrieve_LinkedList_i1d: data array inconsistency in node "//i, error) + endif + data(:,i) = current%data + current => current%next + else + exit + endif + enddo + + endsubroutine retrieve_LinkedList_i1d + + function size_LinkedList_i1d(this,error) result(n) + type(LinkedList_i1d), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i1d), pointer :: current + + integer :: n + + n = 0 + if( associated(this) ) then + current => this + do + if( associated(current) ) then + n = n + 1 + current => current%next + else + exit + endif + enddo + endif + + endfunction size_LinkedList_i1d + + ! 2D integer arrays + + subroutine initialise_LinkedList_i2d(this,data,error) + + type(LinkedList_i2d), pointer, intent(inout) :: this + integer, dimension(:,:), intent(in), optional :: data + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if(associated(this)) call finalise(this) + + allocate(this) + if( present(data) ) then + allocate( this%data(size(data,1),size(data,2)) ) + this%data = data + endif + this%next => null() + + endsubroutine initialise_LinkedList_i2d + + subroutine finalise_LinkedList_i2d(this,error) + type(LinkedList_i2d), pointer, intent(inout) :: this + integer, intent(out), optional :: error + + type(LinkedList_i2d), pointer :: current, next + + INIT_ERROR(error) + + if( .not. associated(this) ) return + + current => this + do while( associated(current) ) + next => current%next + if( allocated(current%data) ) deallocate(current%data) + deallocate(current) + current => next + enddo + + this => null() + + endsubroutine finalise_LinkedList_i2d + + subroutine insert_LinkedList_i2d(this,data,error) + type(LinkedList_i2d), pointer, intent(inout) :: this + integer, dimension(:,:), intent(in), optional :: data + integer, intent(out), optional :: error + + type(LinkedList_i2d), pointer :: current + + INIT_ERROR(error) + + if( .not. associated(this)) then + call initialise(this,data,error) + else + allocate(current) + if(present(data)) then + allocate( current%data(size(data,1), size(data,2)) ) + current%data = data + endif + + current%next => this%next + this%next => current + endif + + endsubroutine insert_LinkedList_i2d + + subroutine delete_node_LinkedList_i2d(this,node,error) + type(LinkedList_i2d), pointer, intent(inout) :: this + type(LinkedList_i2d), pointer, intent(inout) :: node + integer, intent(out), optional :: error + + type(LinkedList_i2d), pointer :: delete_node => null(), previous => null() + + INIT_ERROR(error) + + if( .not. associated(this) ) return + + if( associated(this,node) ) then + ! remove first node + delete_node => this + this => this%next + if( allocated(delete_node%data) ) deallocate(delete_node%data) + deallocate(delete_node) + else + delete_node => this + do + if(associated(delete_node,node)) then + previous%next => delete_node%next + if( allocated(delete_node%data) ) deallocate(delete_node%data) + deallocate(delete_node) + exit + endif + previous => delete_node + delete_node => delete_node%next + if( .not. associated(delete_node) ) exit + enddo + endif + + endsubroutine delete_node_LinkedList_i2d + + function is_in_LinkedList_i2d(this,data,error) result(found) + type(LinkedList_i2d), pointer, intent(in) :: this + integer, dimension(:,:), intent(in), optional :: data + integer, intent(out), optional :: error + + logical :: found + + type(LinkedList_i2d), pointer :: current + + INIT_ERROR(error) + + found = .false. + if( associated(this)) then + current => this + do + if( associated(current) ) then + if( all( shape(current%data) == shape(data) ) ) then + if( all( current%data == data ) ) then + found = .true. + exit + endif + endif + current => current%next + else + exit + endif + enddo + endif + + endfunction is_in_LinkedList_i2d + + subroutine update_LinkedList_i2d(this,data,error) + type(LinkedList_i2d), pointer, intent(inout) :: this + integer, dimension(:,:), intent(in) :: data + integer, intent(out), optional :: error + + INIT_ERROR(error) + + if( .not. associated(this)) then + RAISE_ERROR("update_LinkedList_i2d: linked list not initialised yet.",error) + endif + + call reallocate( this%data, size(data,1), size(data,2) ) + this%data = data + + endsubroutine update_LinkedList_i2d + + function retrieve_node_LinkedList_i2d(this,error) result(data) + type(LinkedList_i2d), pointer, intent(in) :: this + integer, intent(out), optional :: error + + integer, dimension(:,:), pointer :: data + + INIT_ERROR(error) + + if( .not. associated(this)) then + RAISE_ERROR("retrieve_node_LinkedList_i2d: linked list not initialised yet.",error) + endif + + data => this%data + + endfunction retrieve_node_LinkedList_i2d + + function next_LinkedList_i2d(this,error) result(next) + type(LinkedList_i2d), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i2d), pointer :: next + + if( .not. associated(this)) then + RAISE_ERROR("next_LinkedList_i2d: linked list not initialised yet.",error) + endif + + next => this%next + + endfunction next_LinkedList_i2d + + function last_LinkedList_i2d(this,error) result(last) + type(LinkedList_i2d), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i2d), pointer :: last + + if( .not. associated(this)) then + RAISE_ERROR("next_LinkedList_i1d: linked list not initialised yet.",error) + endif + + last => this + do while( associated(last%next) ) + last => last%next + enddo + endfunction last_LinkedList_i2d + + subroutine append_LinkedList_i2d(this,data,error) + type(LinkedList_i2d), pointer, intent(inout) :: this + integer, dimension(:,:), intent(in), optional :: data + integer, intent(out), optional :: error + + type(LinkedList_i2d), pointer :: current, new + + INIT_ERROR(error) + + if( .not. associated(this)) then + call initialise(this,data,error) + else + allocate(new) + if(present(data)) then + allocate( new%data(size(data,1), size(data,2)) ) + new%data = data + endif + new%next => null() + + current => this + do while( associated(current%next) ) + current => current%next + enddo + current%next => new + endif + + endsubroutine append_LinkedList_i2d + + subroutine retrieve_LinkedList_i2d(this,data,error) + type(LinkedList_i2d), pointer, intent(inout) :: this + integer, dimension(:,:,:), allocatable, intent(out) :: data + integer, intent(out), optional :: error + + type(LinkedList_i2d), pointer :: current + integer :: i, d1, d2, d3 + + INIT_ERROR(error) + + if( .not. associated(this)) then + call reallocate(data,0,0,0) + return + endif + + d3 = size_LinkedList(this,error) + if( allocated(this%data) ) then + d1 = size(this%data,1) + d2 = size(this%data,2) + else + RAISE_ERROR("retrieve_LinkedList_i2d: no data content in head node.", error) + endif + + call reallocate(data,d1,d2,d3) + current => this + i = 0 + do + if( associated(current) ) then + i = i + 1 + if( .not. allocated(current%data) ) then + RAISE_ERROR("retrieve_LinkedList_i2d: data missing from node "//i, error) + endif + if( any( (/d1,d2/) /= shape(current%data) ) ) then + RAISE_ERROR("retrieve_LinkedList_i2d: data array inconsistency in node "//i, error) + endif + data(:,:,i) = current%data + current => current%next + else + exit + endif + enddo + + endsubroutine retrieve_LinkedList_i2d + + function size_LinkedList_i2d(this,error) result(n) + type(LinkedList_i2d), pointer, intent(in) :: this + integer, intent(out), optional :: error + + type(LinkedList_i2d), pointer :: current + + integer :: n + + n = 0 + if( associated(this) ) then + current => this + do + if( associated(current) ) then + n = n + 1 + current => current%next + else + exit + endif + enddo + endif + + endfunction size_LinkedList_i2d + +endmodule linkedlist_module diff --git a/src/libAtoms/MPI_context.F90 b/src/libAtoms/MPI_context.F90 new file mode 100644 index 0000000000..3c77fd9779 --- /dev/null +++ b/src/libAtoms/MPI_context.F90 @@ -0,0 +1,1834 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module MPI_context_module +use error_module +use system_module + +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif +implicit none +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif + +private + +public :: ROOT, ROOT_ +integer, parameter :: ROOT = 0 +integer, parameter :: ROOT_ = ROOT ! use if ROOT is shadowed locally + +public :: MPI_context +type MPI_context + logical :: active = .false. + integer :: communicator = 0 + integer :: n_procs = 1 + integer :: my_proc = 0 + integer :: n_hosts = 1 + integer :: my_host = 0 + character(len=:), allocatable :: hostname + logical :: is_cart = .false. + integer :: my_coords(3) = 0 +end type MPI_context + +public :: Initialise +interface Initialise + module procedure MPI_context_Initialise +end interface + +public :: Finalise +interface Finalise + module procedure MPI_context_Finalise +end interface + +public :: is_root +interface is_root + module procedure MPI_context_is_root +end interface + +public :: Print +interface Print + module procedure MPI_context_Print +end interface + +public :: Split_context +interface Split_context + module procedure MPI_context_Split_context +end interface + +public :: free_context +interface free_context + module procedure MPI_context_free_context +end interface + +public :: bcast +interface bcast + module procedure MPI_context_bcast_real, MPI_context_bcast_real1, MPI_context_bcast_real2 + module procedure MPI_context_bcast_c, MPI_context_bcast_c1, MPI_context_bcast_c2 + module procedure MPI_context_bcast_int, MPI_context_bcast_int1, MPI_context_bcast_int2 + module procedure MPI_context_bcast_logical, MPI_context_bcast_logical1, MPI_context_bcast_logical2 + module procedure MPI_context_bcast_char, MPI_context_bcast_char1, MPI_context_bcast_char2 +end interface +public :: min +interface min + module procedure MPI_context_min_real, MPI_context_min_int +end interface +public :: max +interface max + module procedure MPI_context_max_real, MPI_context_max_int +end interface +public :: all +interface all + module procedure MPI_context_all +endinterface +public :: any +interface any + module procedure MPI_context_any +endinterface +public :: sum +interface sum + module procedure MPI_context_sum_int + module procedure MPI_context_sum_real + module procedure MPI_context_sum_complex +end interface +public :: sum_in_place +interface sum_in_place + module procedure MPI_context_sum_in_place_int0 + module procedure MPI_context_sum_in_place_int1 + module procedure MPI_context_sum_in_place_real0 + module procedure MPI_context_sum_in_place_real1 + module procedure MPI_context_sum_in_place_real2 + module procedure MPI_context_sum_in_place_real3 + module procedure MPI_context_sum_in_place_complex1 + module procedure MPI_context_sum_in_place_complex2 +end interface + +public :: gather +interface gather + module procedure MPI_context_gather_char0 +end interface gather + +public :: gatherv +interface gatherv + module procedure MPI_context_gatherv_int1 + module procedure MPI_context_gatherv_real1 + module procedure MPI_context_gatherv_real2 +end interface gatherv + +public :: allgatherv +interface allgatherv + module procedure MPI_context_allgatherv_real2 +end interface allgatherv + +public :: scatter +interface scatter + module procedure MPI_context_scatter_int0 +end interface scatter + +public :: scatterv +interface scatterv + module procedure MPI_context_scatterv_int1 + module procedure MPI_context_scatterv_real1 + module procedure MPI_context_scatterv_real2 +end interface scatterv + +public :: mpi_print + +public :: barrier +interface barrier + module procedure MPI_context_barrier +end interface barrier + +public :: cart_shift +interface cart_shift + module procedure MPI_context_cart_shift +end interface cart_shift + +public :: sendrecv +interface sendrecv + module procedure MPI_context_sendrecv_c1a + module procedure MPI_context_sendrecv_r, MPI_context_sendrecv_ra +end interface sendrecv + +public :: push_MPI_error + +contains + +subroutine MPI_context_Initialise(this, communicator, context, dims, periods, error) + type(MPI_context), intent(inout) :: this + integer, intent(in), optional :: communicator + type(MPI_context), intent(in), optional :: context + integer, intent(in), optional :: dims(3) + logical, intent(in), optional :: periods(3) + integer, intent(out), optional :: error + +#ifdef _MPI + integer :: err + logical :: is_initialized + integer :: comm + logical :: my_periods(3) +#endif + + INIT_ERROR(error) + + if (present(communicator) .and. present(context)) then + RAISE_ERROR("Please specify either *communicator* or *context* upon call to MPI_context_Initialise.", error) + endif + + call Finalise(this) + + this%active = .false. + this%is_cart = .false. + +#ifndef _MPI + allocate(character(1) :: this%hostname) + this%hostname = ' ' +#endif + +#ifdef _MPI + if (present(communicator) .or. present(context)) then + + if (present(communicator)) then + comm = communicator + else if (present(context)) then + comm = context%communicator + endif + + else + + comm = MPI_COMM_WORLD + call mpi_initialized(is_initialized, err) + PASS_MPI_ERROR(err, error) + if (.not. is_initialized) then + call mpi_init(err) + PASS_MPI_ERROR(err, error) + endif + + endif + this%communicator = comm + + if (present(dims)) then + my_periods = .true. + if (present(periods)) then + my_periods = periods + endif + + this%is_cart = .true. + call mpi_cart_create(comm, 3, dims, my_periods, .true., & + this%communicator, err) + PASS_MPI_ERROR(err, error) + endif + + call mpi_comm_set_errhandler(this%communicator, MPI_ERRORS_RETURN, err) + PASS_MPI_ERROR(err, error) + + call mpi_comm_size(this%communicator, this%n_procs, err) + PASS_MPI_ERROR(err, error) + call mpi_comm_rank(this%communicator, this%my_proc, err) + PASS_MPI_ERROR(err, error) + this%active = .true. + + if (this%is_cart) then + call mpi_cart_coords(this%communicator, this%my_proc, 3, & + this%my_coords, err) + PASS_MPI_ERROR(err, error) + + call print("MPI_context_Initialise : Cart created, coords = " // this%my_coords, PRINT_VERBOSE) + endif + + call MPI_context_init_hostname(this, err) + PASS_MPI_ERROR(err, error) + call MPI_context_scatter_hosts(this, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_Initialise + +subroutine MPI_context_Finalise(this, end_of_program, error) + type(MPI_context), intent(inout) :: this + logical, optional, intent(in) :: end_of_program + integer, intent(out), optional :: error + +#ifdef _MPI + integer :: err + logical :: is_initialized +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + if (present(end_of_program)) then + if (end_of_program) then + call mpi_initialized(is_initialized, err) + PASS_MPI_ERROR(err, error) + if (.not. is_initialized) then + call mpi_finalize(err) + PASS_MPI_ERROR(err, error) + endif + endif + endif +#endif +end subroutine MPI_context_Finalise + +!% Set hostname with max length among all MPI processes +subroutine MPI_context_init_hostname(this, error) + type(MPI_context), intent(inout) :: this + integer, intent(out), optional :: error + +#ifdef _MPI + integer :: err, my_len, max_len + character(MPI_MAX_PROCESSOR_NAME) :: hostname +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + call mpi_get_processor_name(hostname, my_len, err) + PASS_MPI_ERROR(err, error) + + max_len = max(this, my_len, err) + PASS_MPI_ERROR(err, error) + + if (allocated(this%hostname)) deallocate(this%hostname) + allocate(character(my_len) :: this%hostname) + this%hostname = hostname(1:max_len) +#endif +end subroutine MPI_context_init_hostname + +!% Set host index and total for each MPI process +subroutine MPI_context_scatter_hosts(this, error) + type(MPI_context), intent(inout) :: this + integer, intent(out), optional :: error + + integer :: err, i + character(:), allocatable :: hostnames(:) + integer, allocatable :: refs(:), hosts(:) + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + if (.not. allocated(this%hostname)) then + call mpi_context_init_hostname(this) + end if + + if (is_root(this)) then + allocate(character(len(this%hostname)) :: hostnames(0:this%n_procs-1)) + else + allocate(character(1) :: hostnames(0:0)) + end if + + call gather(this, this%hostname, hostnames, error=err) + PASS_MPI_ERROR(err, error) + + if (is_root(this)) then + call get_uniqs_refs(hostnames, hosts, refs, lbound(hostnames, 1)) + this%n_hosts = size(hosts) + else + allocate(hosts(1), source=0) + allocate(refs(1), source=0) + end if + + call scatter(this, refs, this%my_host, error=err) + PASS_MPI_ERROR(err, error) + call bcast(this, this%n_hosts, error=err) + PASS_MPI_ERROR(err, error) + + if (is_root(this)) then + call print("MPI hostnames :: "//join(hostnames(hosts), " ")) + call print("MPI host refs :: "//refs) + end if + call print("MPI my_host : "//this%my_host) + call print("MPI hostname : "//this%hostname) +#endif +end subroutine MPI_context_scatter_hosts + +function MPI_context_is_root(this, root) result(res) + type(MPI_context), intent(in) :: this + integer, intent(in), optional :: root + logical :: res + if (this%active) then + res = (this%my_proc == optional_default(ROOT_, root)) + else + res = .true. + end if +end function MPI_context_is_root + +subroutine MPI_context_free_context(this, error) + type(MPI_context), intent(inout) :: this + integer, intent(out), optional :: error + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + call mpi_comm_free(this%communicator, err) + PASS_MPI_ERROR(err, error) + this%active = .false. +#endif +end subroutine MPI_context_free_context + +subroutine MPI_context_Split_context(this, split_index, new_context, error) + type(MPI_context), intent(in) :: this + integer, intent(in) :: split_index + type(MPI_context), intent(out) :: new_context + integer, intent(out), optional :: error + +#ifdef _MPI + integer err +#endif + integer new_comm + + INIT_ERROR(error) + + if (.not. this%active) then + new_context = this + return + endif + + new_comm = this%communicator + +#ifdef _MPI + call mpi_comm_split(this%communicator, split_index, this%my_proc, new_comm, err) + PASS_MPI_ERROR(err, error) +#endif + + call Initialise(new_context, new_comm) + +end subroutine MPI_context_Split_context + +function MPI_context_min_real(this, v, error) + type(MPI_context), intent(in) :: this + real(dp), intent(in) :: v + integer, intent(out), optional :: error + real(dp) :: MPI_context_min_real + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_min_real = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_min_real, 1, MPI_DOUBLE_PRECISION, MPI_MIN, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_min_real = v +#endif +end function MPI_context_min_real + +function MPI_context_min_int(this, v, error) + type(MPI_context), intent(in) :: this + integer, intent(in) :: v + integer, intent(out), optional :: error + integer :: MPI_context_min_int + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_min_int = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_min_int, 1, MPI_INTEGER, MPI_MIN, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_min_int = v +#endif +end function MPI_context_min_int + +function MPI_context_max_real(this, v, error) + type(MPI_context), intent(in) :: this + real(dp), intent(in) :: v + integer, intent(out), optional :: error + real(dp) :: MPI_context_max_real + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_max_real = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_max_real, 1, MPI_DOUBLE_PRECISION, MPI_MAX, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_max_real = v +#endif +end function MPI_context_max_real + +function MPI_context_max_int(this, v, error) + type(MPI_context), intent(in) :: this + integer, intent(in) :: v + integer, intent(out), optional :: error + integer :: MPI_context_max_int + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_max_int = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_max_int, 1, MPI_INTEGER, MPI_MAX, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_max_int = v +#endif +end function MPI_context_max_int + +function MPI_context_all(this, v, error) + type(MPI_context), intent(in) :: this + logical, intent(in) :: v + integer, intent(out), optional :: error + logical :: MPI_context_all + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_all = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_all, 1, MPI_LOGICAL, MPI_LAND, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_all = v +#endif +end function MPI_context_all + +function MPI_context_any(this, v, error) + type(MPI_context), intent(in) :: this + logical, intent(in) :: v + integer, intent(out), optional :: error + logical :: MPI_context_any + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_any = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_any, 1, MPI_LOGICAL, MPI_LOR, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_any = v +#endif +end function MPI_context_any + +function MPI_context_sum_int(this, v, error) + type(MPI_context), intent(in) :: this + integer, intent(in) :: v + integer, intent(out), optional :: error + integer :: MPI_context_sum_int + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_sum_int = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_sum_int, 1, MPI_INTEGER, MPI_SUM, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_sum_int = v +#endif +end function MPI_context_sum_int + +function MPI_context_sum_real(this, v, error) + type(MPI_context), intent(in) :: this + real(dp), intent(in) :: v + integer, intent(out), optional :: error + real(dp) :: MPI_context_sum_real + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_sum_real = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_sum_real, 1, MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_sum_real = v +#endif +end function MPI_context_sum_real + +function MPI_context_sum_complex(this, v, error) + type(MPI_context), intent(in) :: this + complex(dp), intent(in) :: v + integer, intent(out), optional :: error + complex(dp) :: MPI_context_sum_complex + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) then + MPI_context_sum_complex = v + return + endif + +#ifdef _MPI + call MPI_allreduce(v, MPI_context_sum_complex, 1, MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) + PASS_MPI_ERROR(err, error) +#else + MPI_context_sum_complex = v +#endif +end function MPI_context_sum_complex + +subroutine MPI_context_sum_in_place_real2(this, v, error) + type(MPI_context), intent(in) :: this + real(dp), intent(inout) :: v(:,:) + integer, intent(out), optional :: error + +#ifdef MPI_1 + real(dp), allocatable :: v_sum(:,:) +#endif +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI +#ifdef MPI_1 + allocate(v_sum(size(v,1),size(v,2))) + call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) + v = v_sum +#else + call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) +#endif + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_sum_in_place_real2 + +subroutine MPI_context_sum_in_place_real3(this, v, error) + type(MPI_context), intent(in) :: this + real(dp), intent(inout) :: v(:,:,:) + integer, intent(out), optional :: error + +#ifdef MPI_1 + real(dp), allocatable :: v_sum(:,:,:) +#endif +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI +#ifdef MPI_1 + allocate(v_sum(size(v,1),size(v,2),size(v,3))) + call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) + v = v_sum +#else + call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) +#endif + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_sum_in_place_real3 + +subroutine MPI_context_sum_in_place_complex2(this, v, error) + type(MPI_context), intent(in) :: this + complex(dp), intent(inout) :: v(:,:) + integer, intent(out), optional :: error + +#ifdef MPI_1 + complex(dp), allocatable :: v_sum(:,:) +#endif +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI +#ifdef MPI_1 + allocate(v_sum(size(v,1),size(v,2))) + call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) + v = v_sum +#else + call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) +#endif + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_sum_in_place_complex2 + +subroutine MPI_context_sum_in_place_int0(this, v, error) + type(MPI_context), intent(in) :: this + integer, intent(inout) :: v + integer, intent(out), optional :: error + +#ifdef MPI_1 + integer :: v_sum +#endif +#ifdef _MPI + integer :: err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI +#ifdef MPI_1 + call MPI_allreduce(v, v_sum, 1, MPI_INTEGER, MPI_SUM, this%communicator, err) + v = v_sum +#else + call MPI_allreduce(MPI_IN_PLACE, v, 1, MPI_INTEGER, MPI_SUM, this%communicator, err) +#endif + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_sum_in_place_int0 + +subroutine MPI_context_sum_in_place_int1(this, v, error) + type(MPI_context), intent(in) :: this + integer, intent(inout) :: v(:) + integer, intent(out), optional :: error + +#ifdef MPI_1 + integer, allocatable :: v_sum(:) +#endif +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI +#ifdef MPI_1 + allocate(v_sum(size(v,1))) + call MPI_allreduce(v, v_sum, size(v), MPI_INTEGER, MPI_SUM, this%communicator, err) + v = v_sum +#else + call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_INTEGER, MPI_SUM, this%communicator, err) +#endif + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_sum_in_place_int1 + +subroutine MPI_context_sum_in_place_real0(this, v, error) + type(MPI_context), intent(in) :: this + real(dp), intent(inout) :: v + integer, intent(out), optional :: error + +#ifdef MPI_1 + real(dp) :: v_sum +#endif +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI +#ifdef MPI_1 + call MPI_allreduce(v, v_sum, 1, MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) + v = v_sum +#else + call MPI_allreduce(MPI_IN_PLACE, v, 1, MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) +#endif + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_sum_in_place_real0 + +subroutine MPI_context_sum_in_place_real1(this, v, error) + type(MPI_context), intent(in) :: this + real(dp), intent(inout) :: v(:) + integer, intent(out), optional :: error + +#ifdef MPI_1 + real(dp), allocatable :: v_sum(:) +#endif +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI +#ifdef MPI_1 + allocate(v_sum(size(v,1))) + call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) + v = v_sum +#else + call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_PRECISION, MPI_SUM, this%communicator, err) +#endif + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_sum_in_place_real1 + +subroutine MPI_context_sum_in_place_complex1(this, v, error) + type(MPI_context), intent(in) :: this + complex(dp), intent(inout) :: v(:) + integer, intent(out), optional :: error + +#ifdef MPI_1 + complex(dp), allocatable :: v_sum(:) +#endif +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI +#ifdef MPI_1 + allocate(v_sum(size(v,1))) + call MPI_allreduce(v, v_sum, size(v), MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) + v = v_sum +#else + call MPI_allreduce(MPI_IN_PLACE, v, size(v), MPI_DOUBLE_COMPLEX, MPI_SUM, this%communicator, err) +#endif + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_sum_in_place_complex1 + +subroutine MPI_context_bcast_int(this, v, root, error) + type(MPI_context), intent(in) :: this + integer, intent(inout) :: v + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, 1, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_int + +subroutine MPI_context_bcast_int1(this, v, root, error) + type(MPI_context), intent(in) :: this + integer, intent(inout) :: v(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, size(v), MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_int1 + +subroutine MPI_context_bcast_int2(this, v, root, error) + type(MPI_context), intent(in) :: this + integer, intent(inout) :: v(:,:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, size(v), MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_int2 + + +subroutine MPI_context_bcast_logical(this, v, root, error) + type(MPI_context), intent(in) :: this + logical, intent(inout) :: v + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, 1, MPI_LOGICAL, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_logical + +subroutine MPI_context_bcast_logical1(this, v, root, error) + type(MPI_context), intent(in) :: this + logical, intent(inout) :: v(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, size(v), MPI_LOGICAL, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_logical1 + +subroutine MPI_context_bcast_logical2(this, v, root, error) + type(MPI_context), intent(in) :: this + logical, intent(inout) :: v(:,:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, size(v), MPI_LOGICAL, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_logical2 + + +subroutine MPI_context_bcast_c(this, v, root, error) + type(MPI_context), intent(in) :: this + complex(dp), intent(inout) :: v + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, 1, MPI_DOUBLE_COMPLEX, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_c + +subroutine MPI_context_bcast_c1(this, v, root, error) + type(MPI_context), intent(in) :: this + complex(dp), intent(inout) :: v(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, size(v), MPI_DOUBLE_COMPLEX, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_c1 + +subroutine MPI_context_bcast_c2(this, v, root, error) + type(MPI_context), intent(in) :: this + complex(dp), intent(inout) :: v(:,:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, size(v), MPI_DOUBLE_COMPLEX, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_c2 + +subroutine MPI_context_bcast_real(this, v, root, error) + type(MPI_context), intent(in) :: this + real(dp), intent(inout) :: v + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, 1, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_real + +subroutine MPI_context_bcast_real1(this, v, root, error) + type(MPI_context), intent(in) :: this + real(dp), intent(inout) :: v(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, size(v), MPI_DOUBLE_PRECISION, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_real1 + +subroutine MPI_context_bcast_real2(this, v, root, error) + type(MPI_context), intent(in) :: this + real(dp), intent(inout) :: v(:,:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, size(v), MPI_DOUBLE_PRECISION, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_real2 + +subroutine MPI_context_bcast_char(this, v, root, error) + type(MPI_context), intent(in) :: this + character(*), intent(inout) :: v + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, len(v), MPI_CHARACTER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_char + +subroutine MPI_context_bcast_char1(this, v, root, error) + type(MPI_context), intent(in) :: this + character(*), intent(inout) :: v(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, len(v(1))*size(v), MPI_CHARACTER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_char1 + +subroutine MPI_context_bcast_char2(this, v, root, error) + type(MPI_context), intent(in) :: this + character(*), intent(inout) :: v(:,:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + +#ifdef _MPI + integer err + integer my_root +#endif + + INIT_ERROR(error) + + if (.not. this%active) return + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + call MPI_Bcast(v, len(v(1,1))*size(v), MPI_CHARACTER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_bcast_char2 + +subroutine MPI_Context_Print(this, file) + type(MPI_context), intent(in) :: this + type(Inoutput), intent(inout), optional :: file + + call print("MPI_Context : active " // this%active, file=file) + if (this%active) then + call print("communicator " // this%communicator, file=file) + call print("n_procs " // this%n_procs // " my_proc " // this%my_proc, file=file) + endif +end subroutine MPI_Context_Print + +subroutine MPI_Print(this, lines, file) + type(MPI_context), intent(in) :: this + character(len=*), intent(in) :: lines(:) + type(Inoutput), intent(inout), optional :: file + + integer i + + if (.not. this%active) then + do i=1, size(lines) + call Print(trim(lines(i)), file=file) + end do +#ifdef _MPI + else + call parallel_print(lines, this%communicator, file=file) +#endif + endif + +end subroutine MPI_Print + +subroutine MPI_context_gather_char0(this, v_in, v_out, root, error) + type(MPI_context), intent(in) :: this + character(*), intent(in) :: v_in + character(*), intent(out) :: v_out(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: my_root, err, my_len + + INIT_ERROR(error) + + if (.not. this%active) then + if (size(v_out) < 1) then + RAISE_ERROR("MPI_context_gather_char0 size(v_out) < 1: " // size(v_out), error) + end if + + if (len(v_in) /= len(v_out(1))) then + RAISE_ERROR("MPI_context_gather_char0 lengths differ: len(v_in) " // len(v_in) // " len(v_out(1)) " // len(v_out), error) + end if + + v_out(1) = v_in + return + end if + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + + if (is_root(this)) then + if (size(v_out) /= this%n_procs) then + RAISE_ERROR("MPI_context_gather_char0 size(v_out) < %n_procs: " // size(v_out) // " " // this%n_procs, error) + end if + if (len(v_in) /= len(v_out(1))) then + RAISE_ERROR("MPI_context_gather_char0 lengths differ: len(v_in) " // len(v_in) // " len(v_out(1)) " // len(v_out), error) + end if + end if + + call mpi_gather(v_in, len(v_in), MPI_CHARACTER, v_out, len(v_in), MPI_CHARACTER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_gather_char0 + +subroutine MPI_context_gatherv_int1(this, v_in, v_out, counts, root, error) + type(MPI_context), intent(in) :: this + integer, intent(in) :: v_in(:) + integer, intent(out) :: v_out(:) + integer, intent(out), allocatable, optional :: counts(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: my_root, err, my_count + integer, allocatable :: displs(:), my_counts(:) + + INIT_ERROR(error) + + if (.not. this%active) then + if (any(shape(v_in) /= shape(v_out))) then + RAISE_ERROR("MPI_context_gatherv_int1 (no MPI) shape mismatch v_in " // shape(v_in) // " v_out " // shape(v_out), error) + endif + v_out = v_in + return + endif + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + if (is_root(this)) then + allocate(my_counts(this%n_procs)) + else + allocate(my_counts(1), source=0) + end if + + my_count = size(v_in) + call mpi_gather(my_count, 1, MPI_INTEGER, my_counts, 1, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (sum(my_counts) > size(v_out)) then + RAISE_ERROR("MPI_context_gatherv_int1 not enough space sum(my_counts) " // sum(my_counts) // " size(v_out) " // size(v_out), error) + endif + + if (is_root(this)) then + call get_displs(my_counts, displs) + else + allocate(displs(1), source=0) + end if + + call MPI_gatherv(v_in, my_count, MPI_INTEGER, v_out, my_counts, displs, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (present(counts)) then + allocate(counts, source=my_counts) + end if +#endif + +end subroutine MPI_context_gatherv_int1 + +subroutine MPI_context_gatherv_real1(this, v_in, v_out, counts, root, error) + type(MPI_context), intent(in) :: this + real(dp), intent(in) :: v_in(:) + real(dp), intent(out) :: v_out(:) + integer, intent(out), allocatable, optional :: counts(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: my_root, err, my_count + integer, allocatable :: displs(:), my_counts(:) + + INIT_ERROR(error) + + if (.not. this%active) then + if (any(shape(v_in) /= shape(v_out))) then + RAISE_ERROR("MPI_context_gatherv_real1 (no MPI) shape mismatch v_in " // shape(v_in) // " v_out " // shape(v_out), error) + endif + v_out = v_in + return + endif + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + if (is_root(this)) then + allocate(my_counts(this%n_procs)) + else + allocate(my_counts(1), source=0) + end if + + my_count = size(v_in) + call mpi_gather(my_count, 1, MPI_INTEGER, my_counts, 1, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (sum(my_counts) > size(v_out)) then + RAISE_ERROR("MPI_context_gatherv_real1 not enough space sum(my_counts) " // sum(my_counts) // " size(v_out) " // size(v_out), error) + endif + + if (is_root(this)) then + call get_displs(my_counts, displs) + else + allocate(displs(1), source=0) + end if + + call MPI_gatherv(v_in, my_count, MPI_DOUBLE_PRECISION, v_out, my_counts, displs, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (present(counts)) then + allocate(counts, source=my_counts) + end if +#endif + +end subroutine MPI_context_gatherv_real1 + +subroutine MPI_context_gatherv_real2(this, v_in, v_out, counts, root, error) + type(MPI_context), intent(in) :: this + real(dp), intent(in) :: v_in(:,:) + real(dp), intent(out) :: v_out(:,:) + integer, intent(out), allocatable, optional :: counts(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: my_root, err, my_count + integer, allocatable :: displs(:), my_counts(:) + + INIT_ERROR(error) + + if (.not. this%active) then + if (any(shape(v_in) /= shape(v_out))) then + RAISE_ERROR("MPI_context_gatherv_real2 (no MPI) shape mismatch v_in " // shape(v_in) // " v_out " // shape(v_out), error) + endif + v_out = v_in + return + endif + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + if (is_root(this)) then + allocate(my_counts(this%n_procs)) + else + allocate(my_counts(1), source=0) + end if + + my_count = size(v_in) + call mpi_gather(my_count, 1, MPI_INTEGER, my_counts, 1, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (sum(my_counts) > size(v_out)) then + RAISE_ERROR("MPI_context_gatherv_real2 not enough space sum(my_counts) " // sum(my_counts) // " size(v_out) " // size(v_out), error) + endif + + if (is_root(this)) then + call get_displs(my_counts, displs) + else + allocate(displs(1), source=0) + end if + + call MPI_gatherv(v_in, my_count, MPI_DOUBLE_PRECISION, v_out, my_counts, displs, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (present(counts)) then + allocate(counts, source=my_counts) + end if +#endif + +end subroutine MPI_context_gatherv_real2 + +subroutine MPI_context_allgatherv_real2(this, v_in, v_out, error) + type(MPI_context), intent(in) :: this + real(dp), intent(in) :: v_in(:,:) + real(dp), intent(out) :: v_out(:,:) + integer, intent(out), optional :: error + + integer err + integer my_count + integer, allocatable :: displs(:), counts(:) + + INIT_ERROR(error) + + if (.not. this%active) then + if (size(v_in,1) /= size(v_out,1) .or. & + size(v_in,2) /= size(v_out,2)) then + RAISE_ERROR("MPI_context_allgatherv_real (no MPI) size mismatch v_in " // shape(v_in) // " v_out " // shape(v_out), error) + endif + v_out = v_in + return + endif + +#ifdef _MPI + + my_count = size(v_in) + allocate(counts(this%n_procs)) + call mpi_allgather(my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (sum(counts) > size(v_out)) then + RAISE_ERROR("MPI_context_allgatherv_real2 not enough space sum(counts) " // sum(counts) // " size(v_out) " // size(v_out), error) + endif + + call get_displs(counts, displs) + call MPI_allgatherv(v_in, my_count, MPI_DOUBLE_PRECISION, & + v_out, counts, displs, MPI_DOUBLE_PRECISION, & + this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif + +end subroutine MPI_context_allgatherv_real2 + +subroutine MPI_context_scatter_int0(this, v_in, v_out, root, error) + type(MPI_context), intent(in) :: this + integer, intent(in) :: v_in(:) + integer, intent(out) :: v_out + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: my_root, err + + INIT_ERROR(error) + + if (.not. this%active) then + if (size(v_in) < 1) then + RAISE_ERROR("MPI_context_scatter_int0 size(v_in) < 1: " // size(v_in), error) + end if + + v_out = v_in(1) + return + end if + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + + if (is_root(this)) then + if (size(v_in) /= this%n_procs) then + RAISE_ERROR("MPI_context_scatter_int0 size(v_in) /= %n_procs: " // size(v_in) // " " // this%n_procs, error) + end if + end if + + call mpi_scatter(v_in, 1, MPI_INTEGER, v_out, 1, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_scatter_int0 + +subroutine MPI_context_scatterv_int1(this, v_in, v_out, counts, root, error) + type(MPI_context), intent(in) :: this + integer, intent(in) :: v_in(:) + integer, intent(out) :: v_out(:) + integer, intent(in) :: counts(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: my_root, err, count + integer, allocatable :: displs(:) + + INIT_ERROR(error) + + if (.not. this%active) then + if (any(shape(v_in) /= shape(v_out))) then + RAISE_ERROR("MPI_context_scatterv_int1 (no MPI) shape mismatch: v_in " // shape(v_in) // " v_out " // shape(v_out), error) + endif + v_out = v_in + return + endif + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + + call mpi_scatter(counts, 1, MPI_INTEGER, count, 1, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (count > size(v_out)) then + RAISE_ERROR("MPI_context_scatterv_int1 not enough space: count " // count // " size(v_out) " // size(v_out), error) + endif + + if (is_root(this, my_root)) then + call get_displs(counts, displs) + else + allocate(displs(1), source=0) + end if + + call MPI_scatterv(v_in, counts, displs, MPI_INTEGER, v_out, count, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif + +end subroutine MPI_context_scatterv_int1 + +subroutine MPI_context_scatterv_real1(this, v_in, v_out, counts, root, error) + type(MPI_context), intent(in) :: this + real(dp), intent(in) :: v_in(:) + real(dp), intent(out) :: v_out(:) + integer, intent(in) :: counts(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: my_root, err, count + integer, allocatable :: displs(:) + + INIT_ERROR(error) + + if (.not. this%active) then + if (any(shape(v_in) /= shape(v_out))) then + RAISE_ERROR("MPI_context_scatterv_real1 (no MPI) shape mismatch: v_in " // shape(v_in) // " v_out " // shape(v_out), error) + endif + v_out = v_in + return + endif + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + + call mpi_scatter(counts, 1, MPI_INTEGER, count, 1, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (count > size(v_out)) then + RAISE_ERROR("MPI_context_scatterv_real1 not enough space: count " // count // " size(v_out) " // size(v_out), error) + endif + + if (is_root(this, my_root)) then + call get_displs(counts, displs) + else + allocate(displs(1), source=0) + end if + + call MPI_scatterv(v_in, counts, displs, MPI_DOUBLE_PRECISION, v_out, count, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif + +end subroutine MPI_context_scatterv_real1 + +subroutine MPI_context_scatterv_real2(this, v_in, v_out, counts, root, error) + type(MPI_context), intent(in) :: this + real(dp), intent(in) :: v_in(:,:) + real(dp), intent(out) :: v_out(:,:) + integer, intent(in) :: counts(:) + integer, intent(in), optional :: root + integer, intent(out), optional :: error + + integer :: my_root, err, count + integer, allocatable :: displs(:) + + INIT_ERROR(error) + + if (.not. this%active) then + if (any(shape(v_in) /= shape(v_out))) then + RAISE_ERROR("MPI_context_scatterv_real2 (no MPI) shape mismatch: v_in " // shape(v_in) // " v_out " // shape(v_out), error) + endif + v_out = v_in + return + endif + +#ifdef _MPI + my_root = optional_default(ROOT_, root) + + call mpi_scatter(counts, 1, MPI_INTEGER, count, 1, MPI_INTEGER, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) + + if (count > size(v_out)) then + RAISE_ERROR("MPI_context_scatterv_real2 not enough space: count " // count // " size(v_out) " // size(v_out), error) + endif + + if (is_root(this, my_root)) then + call get_displs(counts, displs) + else + allocate(displs(1), source=0) + end if + + call MPI_scatterv(v_in, counts, displs, MPI_DOUBLE_PRECISION, v_out, count, MPI_DOUBLE_PRECISION, my_root, this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif + +end subroutine MPI_context_scatterv_real2 + +subroutine MPI_context_barrier(this, error) + type(MPI_context), intent(in) :: this + integer, intent(out), optional :: error + +#ifdef _MPI + integer err +#endif + + INIT_ERROR(error) + +#ifdef _MPI + call mpi_barrier(this%communicator, err) + PASS_MPI_ERROR(err, error) +#endif +end subroutine MPI_context_barrier + +subroutine MPI_context_cart_shift(this, direction, displ, source, dest, error) + type(MPI_context), intent(in) :: this + integer, intent(in) :: direction, displ + integer, intent(out) :: source, dest + integer, intent(out), optional :: error + + ! --- + +#ifdef _MPI + integer :: err +#endif + + INIT_ERROR(error) + +#ifdef _MPI + call mpi_cart_shift(this%communicator, direction, displ, source, dest, err) + PASS_MPI_ERROR(err, error) +#else + source = 0 + dest = 0 +#endif +end subroutine MPI_context_cart_shift + + +subroutine MPI_context_sendrecv_c1a(this, & + sendbuf, dest, sendtag, & + recvbuf, source, recvtag, & + nrecv, & + error) + type(MPI_context), intent(in) :: this + character(1), intent(in) :: sendbuf(:) + integer, intent(in) :: dest, sendtag + character(1), intent(out) :: recvbuf(:) + integer, intent(in) :: source, recvtag + integer, optional, intent(out) :: nrecv + integer, intent(out), optional :: error + + ! --- + +#ifdef _MPI + integer :: err + integer :: status(MPI_STATUS_SIZE) +#endif + + INIT_ERROR(error) + +#ifdef _MPI + call mpi_sendrecv( & + sendbuf, size(sendbuf), MPI_CHARACTER, dest, sendtag, & + recvbuf, size(recvbuf), MPI_CHARACTER, source, recvtag, & + this%communicator, status, err) + PASS_MPI_ERROR(err, error) + if (present(nrecv)) then + call mpi_get_count(status, MPI_CHARACTER, nrecv, err) + PASS_MPI_ERROR(err, error) + endif +#endif +endsubroutine MPI_context_sendrecv_c1a + + +subroutine MPI_context_sendrecv_r(this, & + sendbuf, dest, sendtag, & + recvbuf, source, recvtag, & + error) + type(MPI_context), intent(in) :: this + real(DP), intent(in) :: sendbuf + integer, intent(in) :: dest, sendtag + real(DP), intent(out) :: recvbuf + integer, intent(in) :: source, recvtag + integer, intent(out), optional :: error + + ! --- + +#ifdef _MPI + integer :: err + integer :: status(MPI_STATUS_SIZE) +#endif + + INIT_ERROR(error) + +#ifdef _MPI + call mpi_sendrecv( & + sendbuf, 1, MPI_DOUBLE_PRECISION, dest, sendtag, & + recvbuf, 1, MPI_DOUBLE_PRECISION, source, recvtag, & + this%communicator, status, err) + PASS_MPI_ERROR(err, error) +#endif +endsubroutine MPI_context_sendrecv_r + + +subroutine MPI_context_sendrecv_ra(this, & + sendbuf, dest, sendtag, & + recvbuf, source, recvtag, & + nrecv, & + error) + type(MPI_context), intent(in) :: this + real(DP), intent(in) :: sendbuf(:) + integer, intent(in) :: dest, sendtag + real(DP), intent(out) :: recvbuf(:) + integer, intent(in) :: source, recvtag + integer, optional, intent(out) :: nrecv + integer, intent(out), optional :: error + + ! --- + +#ifdef _MPI + integer :: err + integer :: status(MPI_STATUS_SIZE) +#endif + + INIT_ERROR(error) + +#ifdef _MPI + call mpi_sendrecv( & + sendbuf, size(sendbuf), MPI_DOUBLE_PRECISION, dest, sendtag, & + recvbuf, size(recvbuf), MPI_DOUBLE_PRECISION, source, recvtag, & + this%communicator, status, err) + PASS_MPI_ERROR(err, error) + if (present(nrecv)) then + call mpi_get_count(status, MPI_DOUBLE_PRECISION, nrecv, err) + PASS_MPI_ERROR(err, error) + endif +#endif +endsubroutine MPI_context_sendrecv_ra + + +subroutine push_MPI_error(info, fn, line) + integer, intent(inout) :: info !% MPI error code + character(*), intent(in) :: fn + integer, intent(in) :: line + + ! --- + +#ifdef _MPI + character(MPI_MAX_ERROR_STRING) :: err_str + integer :: err_len, err_status + + ! --- + + call mpi_error_string(info, err_str, err_len, err_status) + call push_error_with_info( & + "Call to MPI library failed. Error: " // trim(err_str), & + fn, line, ERROR_MPI) + +#endif + +endsubroutine push_MPI_error + +! Get displacements (start 0) from counts for gatherv/scatterv +subroutine get_displs(counts, displs) + integer, intent(in) :: counts(:) + integer, intent(out), allocatable :: displs(:) + + integer :: i + + allocate(displs(size(counts))) + displs(1) = 0 + do i = 2, size(displs) + displs(i) = displs(i-1) + counts(i-1) + end do +end subroutine get_displs + +end module MPI_context_module diff --git a/src/libAtoms/Matrix.F90 b/src/libAtoms/Matrix.F90 new file mode 100644 index 0000000000..4475d26d7b --- /dev/null +++ b/src/libAtoms/Matrix.F90 @@ -0,0 +1,1722 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Matrix module +!X +!% This module handles the math of real and complex matrices. +!% The objects 'MatrixD' and 'MatrixZ' correspond to real and complex matrices, +!% respectively. They can be used for parellel computing with ScaLAPACK. +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module matrix_module + +use error_module +use System_module +use linearalgebra_module + +use MPI_context_module +use ScaLAPACK_module + +implicit none +private + +public :: MatrixD +type MatrixD + logical :: use_allocate = .true. !> + integer :: N = 0 !> global rows + integer :: M = 0 !> global columns + integer :: l_N = 0 !> local rows + integer :: l_M = 0 !> local columns + real(dp), pointer :: data(:,:) => null() !> matrix values + type(Matrix_ScaLAPACK_Info) :: ScaLAPACK_Info_obj !> meta info for scalapack + contains + final :: MatrixD_Finalise +end type MatrixD + +public :: MatrixZ +type MatrixZ + integer :: N = 0, M = 0, l_N = 0, l_M = 0 + complex(dp), allocatable:: data(:,:) + type(Matrix_ScaLAPACK_Info) ScaLAPACK_Info_obj +end type MatrixZ + +public :: Initialise +interface Initialise + module procedure MatrixD_Initialise, MatrixZ_Initialise + module procedure MatrixD_Initialise_mat, MatrixZ_Initialise_mat +end interface Initialise + +public :: Finalise +interface Finalise + module procedure MatrixD_Finalise, MatrixZ_Finalise +end interface Finalise + +!% Nullify all the matrix elements. +public :: Wipe +interface Wipe + module procedure MatrixD_Wipe, MatrixZ_Wipe +end interface Wipe + +!% Set at zero some elements of real and complex matrices. +!% Adding the optional logical values (\texttt{d_mask} and \texttt{od_mask}), the diagonal and +!% off-diagonal elements are selected. +public :: Zero +interface Zero + module procedure MatrixD_Zero, MatrixZ_Zero +end interface Zero + +public :: Print +interface Print + module procedure MatrixD_Print, MatrixZ_Print +end interface Print + +!% Add a block to a given matrix. The block dimensions have to be specified. +public :: add_block +interface add_block + module procedure MatrixD_add_block, MatrixZ_add_block +end interface add_block + +!% Diagonalise a real or complex matrix. +public :: diagonalise +interface diagonalise + module procedure MatrixD_diagonalise, MatrixD_diagonalise_gen, MatrixZ_diagonalise, MatrixZ_diagonalise_gen +end interface diagonalise + +! public :: accum_col_outer_product +! interface accum_col_outer_product +! module procedure MatrixDD_accum_col_outer_product, MatrixZZ_accum_col_outer_product +! end interface accum_col_outer_product + +!% Compute the trace of the matrix obtained multiplying two input matrices \texttt{a} and \texttt{b}. +public :: TraceMult +interface TraceMult + module procedure Matrix_TraceMult_DD, Matrix_TraceMult_DZ, Matrix_TraceMult_ZZ, Matrix_TraceMult_ZD +end interface TraceMult + +public :: partial_TraceMult +interface partial_TraceMult + module procedure Matrix_partial_TraceMult_DD, Matrix_partial_TraceMult_DZ, Matrix_partial_TraceMult_ZZ, Matrix_partial_TraceMult_ZD +end interface partial_TraceMult + +public :: partial_TraceMult_spinor +interface partial_TraceMult_spinor + module procedure Matrix_partial_TraceMult_spinor_ZZ +end interface partial_TraceMult_spinor + +!% Make real the diagonal elements of a given matrix \texttt{a} . +public :: Re_diag +interface Re_diag + module procedure Matrix_Re_diagD, Matrix_Re_diagZ +end interface Re_diag + +!% Get diagonal 2x2 blocks a given matrix \texttt{a} . +public :: diag_spinor +interface diag_spinor + module procedure Matrix_diag_spinorD, Matrix_diag_spinorZ +end interface diag_spinor + +!% Compute the sum of two matrices (complex or real) \texttt{m$_1$} and \texttt{m$_2$} weighted by +!% complex factors \texttt{f1} and \texttt{f2}. The result is a complex matrix. +public :: scaled_sum +interface scaled_sum + module procedure Matrix_scaled_sum_ZZZ, Matrix_scaled_sum_ZDD +end interface scaled_sum + +!% Add to a given matrix the elements of an other matrix \texttt{m$_1$} weighted by a +!% complex factor \texttt{f1}. +public :: scaled_accum +interface scaled_accum + module procedure Matrix_scaled_accum_DZ, Matrix_scaled_accum_ZZ +end interface scaled_accum + +!% Compute the inverse of a given matrix. +public :: inverse +interface inverse + module procedure MatrixD_inverse, MatrixZ_inverse +end interface inverse + +public :: multDiag +interface multDiag + module procedure MatrixD_multDiag_d, MatrixZ_multDiag_d, MatrixZ_multDiag_z +end interface multDiag + +public :: multDiagRL +interface multDiagRL + module procedure MatrixD_multDiagRL_d, MatrixZ_multDiagRL_d +end interface multDiagRL + +public :: matrix_product_sub +interface matrix_product_sub + module procedure MatrixZ_matrix_product_sub_zz, MatrixZ_matrix_product_sub_dz, MatrixZ_matrix_product_sub_zd + module procedure MatrixD_matrix_product_sub_dr2, MatrixD_matrix_product_sub_dd +end interface matrix_product_sub + +!% Add the identity matrix. +public :: add_identity +interface add_identity + module procedure MatrixD_add_identity +end interface add_identity + +!% Scale the matrix elements for a real factor \texttt{scale}. +public :: scale +interface scale + module procedure MatrixD_scale +end interface scale + +public :: transpose_sub +interface transpose_sub + module procedure MatrixD_transpose_sub, MatrixZ_transpose_sub +end interface transpose_sub + +public :: make_hermitian +interface make_hermitian + module procedure MatrixD_make_hermitian, MatrixZ_make_hermitian +end interface make_hermitian + +public :: SP_Matrix_QR_Solve + +contains + +subroutine MatrixD_Initialise(this, N, M, NB, MB, scalapack_obj, use_allocate) + type(MatrixD), intent(out) :: this + integer, intent(in), optional :: N, M, NB, MB + type(ScaLAPACK), intent(in), optional :: scalapack_obj + logical, intent(in), optional :: use_allocate + + call Finalise(this) + + this%use_allocate = optional_default(.true., use_allocate) + + call matrixany_initialise(N, M, NB, MB, scalapack_obj, this%N, this%M, this%l_N, this%l_M, & + this%ScaLAPACK_Info_obj) + + if (.not. this%use_allocate) return + + if (this%l_N > 0 .and. this%l_M > 0) then + allocate(this%data(this%l_N, this%l_M)) + call ALLOC_TRACE("MatrixD_Initialise "//this%l_N//" "//this%l_M, size(this%data)*REAL_SIZE) + else + allocate(this%data(1,1)) + call ALLOC_TRACE("MatrixD_Initialise "//1//" "//1, size(this%data)*REAL_SIZE) + endif + +end subroutine MatrixD_Initialise + +subroutine MatrixD_Initialise_mat(this, from) + type(MatrixD), intent(out) :: this + type(MatrixD), intent(in) :: from + + call Finalise(this) + + this%N = from%N + this%M = from%M + this%l_N = from%l_N + this%l_M = from%l_M + this%ScaLAPACK_Info_obj = from%ScaLAPACK_Info_obj + + if (this%l_N > 0 .and. this%l_M > 0) then + allocate(this%data(this%l_N, this%l_M)) + call ALLOC_TRACE("MatrixD_Initialise_mat "//this%l_N//" "//this%l_M,size(this%data)*REAL_SIZE) + else + allocate(this%data(1,1)) + call ALLOC_TRACE("MatrixD_Initialise_mat "//1//" "//1, size(this%data)*REAL_SIZE) + endif + +end subroutine MatrixD_Initialise_mat + +subroutine MatrixD_to_array1d(this, array) + type(MatrixD), intent(inout) :: this + real(dp), intent(out), dimension(:) :: array + + integer :: nrows + + if (this%ScaLAPACK_Info_obj%active) then + call ScaLAPACK_to_array1d(this%ScaLAPACK_Info_obj, this%data, array) + else + nrows = min(this%N, size(array, 1)) + array(:nrows) = this%data(:nrows,1) + array(nrows+1:) = 0.0_dp + end if +end subroutine MatrixD_to_array1d + +subroutine MatrixD_to_MatrixD(A, B, M, N, ia, ja, ib, jb, UPLO) + ! Copy general submatrix A%data(ia:ia+M-1, ja:ja+N-1) to B%data(ib:ib+M-1, jb:jb+N-1) + ! For ScaLAPACK use, assumes the BLACS context of B is the same as (or a child of) the context of A + ! If UPLO is present, only copy upper (UPLO="U") or lower (UPLO="L") triangle + type(MatrixD), intent(in) :: A + type(MatrixD), intent(inout) :: B + integer, intent(in) :: M, N + integer, intent(in), optional:: ia, ja, ib, jb + character(1), intent(in), optional :: UPLO + + integer :: my_ia, my_ja, my_ib, my_jb + + character(1) :: my_uplo + + my_uplo = optional_default("F", UPLO) + + if (A%ScaLAPACK_Info_obj%active .and. B%ScaLAPACK_Info_obj%active) then ! ScaLAPACK + + if ((my_uplo /= "U") .and. (my_uplo /= "L")) then ! Assume full matrix copy + call ScaLAPACK_pdgemr2d_wrapper(A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, B%data, & + A%ScaLAPACK_Info_obj%ScaLAPACK_obj%blacs_context, M, N, ia, ja, ib, jb) + + else + ! Triangular matrix ScaLAPACK copy + call ScaLAPACK_pdtrmr2d_wrapper(my_uplo, "N", A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, B%data, & + A%ScaLAPACK_Info_obj%ScaLAPACK_obj%blacs_context, M, N, ia, ja, ib, jb) + endif + + else ! non-MPI + my_ia = optional_default(1, ia) + my_ja = optional_default(1, ja) + my_ib = optional_default(1, ib) + my_jb = optional_default(1, jb) + + ! my_uplo = "F" will be interpreted as default full copy + call dlacpy(my_uplo, M, N, A%data(my_ia:my_ia+M-1, my_ja:my_ja+N-1), M, B%data(my_ib:my_ib+M-1, my_jb:my_jb+N-1), M) + end if +end subroutine MatrixD_to_MatrixD + +subroutine MatrixD_QR_Solve(A_SP, B_SP, cheat_nb_A) + type(MatrixD), intent(inout) :: A_SP, B_SP + logical, intent(in) :: cheat_nb_A + + if (A_SP%ScaLAPACK_Info_obj%active .and. & + B_SP%ScaLAPACK_Info_obj%active) then + call ScaLAPACK_Matrix_QR_Solve(A_SP%ScaLAPACK_Info_obj, A_SP%data, & + B_SP%ScaLAPACK_Info_obj, B_SP%data, cheat_nb_A) + else + call system_abort("MatrixD_QR_Solve() without ScaLAPACK is not implemented.") + endif +end subroutine MatrixD_QR_Solve + +subroutine SP_Matrix_QR_Solve(A, B, X, ScaLAPACK_obj, mb_A, nb_A, R, do_export_R) + real(dp), intent(inout), dimension(:,:), target :: A + real(dp), intent(inout), dimension(:), target :: B + real(dp), intent(out), dimension(:) :: X + type(ScaLAPACK), intent(in) :: ScaLAPACK_obj + integer, intent(in) :: mb_A, nb_A + real(dp), intent(out), dimension(:, :), allocatable, optional :: R + logical, intent(in), optional :: do_export_R + + logical :: cheat_nb_A + integer :: mb, nb, ml, nl, mg, ng + type(MatrixD) :: A_SP, B_SP + + ml = size(A, 1) + nl = size(A, 2) + mg = ml * ScaLAPACK_obj%n_proc_rows + ng = nl * ScaLAPACK_obj%n_proc_cols + + mb = mb_A + nb = nb_A + + cheat_nb_A = .false. + if (mb /= nb) then + if (ScaLAPACK_obj%n_proc_cols > 1) & + call system_abort("SP_Matrix_QR_Solve: blocksizes differ: "//mb//" "//nb//char(16) & + // "Cannot cheat for more than one process column: "//ScaLAPACK_obj%n_proc_cols) + cheat_nb_A = .true. + end if + + if (ScaLAPACK_obj%my_proc_row+1 < ScaLAPACK_obj%n_proc_rows .and. mod(ml, mb) /= 0) & + call system_abort("SP_Matrix_QR_Solve: nrows is not a multiple of blocksize: "//ml//" "//mb) + if (ScaLAPACK_obj%my_proc_col+1 < ScaLAPACK_obj%n_proc_cols .and. mod(nl, nb) /= 0) & + call system_abort("SP_Matrix_QR_Solve: ncols is not a multiple of blocksize: "//nl//" "//nb) + + call initialise(A_SP, mg, ng, mb, nb, scalapack_obj=ScaLAPACK_obj, use_allocate=.false.) + call initialise(B_SP, mg, 1, mb, 1, scalapack_obj=ScaLAPACK_obj, use_allocate=.false.) + + A_SP%data => A + B_SP%data(lbound(B,1):ubound(B,1),1:1) => B(:) + + ! Scalapack needs mb == nb for p?trtrs, cheating if only single process column + call MatrixD_QR_Solve(A_SP, B_SP, cheat_nb_A) + call MatrixD_QR_Get_Weights(A_SP, B_SP, ng, X, R, do_export_R) + + call finalise(A_SP) + call finalise(B_SP) +end subroutine SP_Matrix_QR_Solve + +subroutine MatrixD_QR_Get_Weights(A, b, M, weights, R, do_export_R) + ! Extract weights from b after MatrixD_QR_Solve + ! Optionally extract R + type(MatrixD), intent(in) :: A, b + integer, intent(in) :: M + real(dp), dimension(M), intent(out), target :: weights + real(dp), dimension(:, :), intent(out), allocatable, target, optional :: R + logical, intent(in), optional :: do_export_R + + type(ScaLAPACK) :: wt_scalapack + type(MatrixD) :: wt_matrixD, R_matrixD + + ! Initialise 1x1 scalapack process grid + call initialise(wt_scalapack, b%ScaLAPACK_Info_obj%ScaLAPACK_obj%MPI_obj, 1, 1) + + call initialise(wt_matrixD, M, 1, M, 1, wt_scalapack, use_allocate=.false.) + + ! weights + weights(:) = 0.0_dp + wt_matrixd%data(1:M,1:1) => weights(:) + + call MatrixD_to_MatrixD(b, wt_matrixD, M, 1) + call Finalise(wt_matrixD) + + ! R + if (present(R) .and. present(do_export_R)) then + if (do_export_R) then + call print("Extracting Posterior Covariance", PRINT_VERBOSE) + if (wt_scalapack%blacs_context > -1) then + allocate(R(M, M)) + else + allocate(R(1, 1)) + end if + + R(:, :) = 0.0_dp + ! Reuse wt_scalapack, assuming context of A equal to context of B + call initialise(R_matrixD, M, M, M, M, wt_scalapack, use_allocate=.false.) + R_matrixd%data(1:ubound(R,1),1:ubound(R,2)) => R(:, :) + call MatrixD_to_MatrixD(A, R_matrixD, M, M, UPLO="U") + call Finalise(R_matrixD) + end if + end if + call Finalise(wt_scalapack) + +end subroutine MatrixD_QR_Get_Weights + + +subroutine MatrixZ_Initialise(this, N, M, NB, MB, scalapack_obj) + type(MatrixZ), intent(out) :: this + integer, intent(in), optional :: N, M, NB, MB + type(ScaLAPACK), intent(in), optional :: scalapack_obj + + call Finalise(this) + + call matrixany_initialise(N, M, NB, MB, scalapack_obj, this%N, this%M, this%l_N, this%l_M, & + this%ScaLAPACK_Info_obj) + + if (this%l_N > 0 .and. this%l_M > 0) then + allocate(this%data(this%l_N, this%l_M)) + call ALLOC_TRACE("MatrixZ_Initialise "//this%l_N//" "//this%l_M, size(this%data)*COMPLEX_SIZE) + else + allocate(this%data(1,1)) + call ALLOC_TRACE("MatrixZ_Initialise "//1//" "//1, size(this%data)*REAL_SIZE) + endif + +end subroutine MatrixZ_Initialise + +subroutine MatrixZ_Initialise_mat(this, from) + type(MatrixZ), intent(out) :: this + type(MatrixZ), intent(in) :: from + + call Finalise(this) + + this%N = from%N + this%M = from%M + this%l_N = from%l_N + this%l_M = from%l_M + this%ScaLAPACK_Info_obj = from%ScaLAPACK_Info_obj + + if (this%l_N > 0 .and. this%l_M > 0) then + allocate(this%data(this%l_N, this%l_M)) + call ALLOC_TRACE("MatrixZ_Initialise_mat "//this%l_N//" "//this%l_M, size(this%data)*COMPLEX_SIZE) + else + allocate(this%data(1,1)) + call ALLOC_TRACE("MatrixZ_Initialise_mat "//1//" "//1, size(this%data)*REAL_SIZE) + endif + +end subroutine MatrixZ_Initialise_mat + +subroutine matrixany_initialise(N, M, NB, MB, scalapack_obj, this_N, this_M, this_l_N, this_l_M, & + this_ScaLAPACK_Info_obj) + integer, intent(in), optional :: N, M, NB, MB + type(ScaLAPACK), intent(in), target, optional :: scalapack_obj + integer, intent(out) :: this_N, this_M, this_l_N, this_l_M + type(Matrix_ScaLAPACK_Info), intent(out) :: this_ScaLAPACK_Info_obj + + integer use_NB, use_MB + + this_N = 0 + this_M = 0 + this_l_N = 0 + this_l_M = 0 + + if (present(N)) then + this_N = N + if (present(M)) then + this_M = M + else + this_M = N + endif + + if (present(NB)) then + use_NB = NB + else + use_NB = 36 + endif + if (present(MB)) then + use_MB = MB + else + use_MB = 36 + endif + + if (present(scalapack_obj)) then + call Initialise(this_ScaLAPACK_Info_obj, this_N, this_M, use_NB, use_MB, scalapack_obj) + else + call Initialise(this_ScaLAPACK_Info_obj, N, M, use_NB, use_MB) + endif + if (this_ScaLAPACK_Info_obj%active) then + this_l_N = this_ScaLAPACK_Info_obj%l_N_R + this_l_M = this_ScaLAPACK_Info_obj%l_N_C + else + this_l_N = this_N + this_l_M = this_M + endif + endif +end subroutine matrixany_initialise + +subroutine MatrixD_Finalise(this) + type(MatrixD), intent(inout) :: this + + call Wipe(this) + call Finalise(this%ScaLAPACK_Info_obj) + +end subroutine MatrixD_Finalise + +subroutine MatrixD_Wipe(this) + type(MatrixD), intent(inout) :: this + + call Wipe(this%ScaLAPACK_Info_obj) + + if (this%use_allocate .and. associated(this%data)) then + call DEALLOC_TRACE("MatrixD_Wipe ", size(this%data)*REAL_SIZE) + deallocate(this%data) + endif + this%data => null() + + this%N = 0 + this%M = 0 + this%l_N = 0 + this%l_M = 0 + +end subroutine MatrixD_Wipe + +subroutine MatrixD_Zero(this, d_mask, od_mask) + type(MatrixD), intent(inout) :: this + logical, intent(in), optional :: d_mask(:), od_mask(:) + + integer i + + if (.not. associated(this%data)) return + + if (.not. present(d_mask) .and. .not. present(od_mask)) then + this%data = 0.0_dp + return + end if + + if (present(d_mask)) then + do i=1, min(size(d_mask), this%N, this%M) + if (d_mask(i)) this%data(i,i) = 0.0_dp + end do + end if + + if (present(od_mask)) then + do i=1, size(od_mask) + if (od_mask(i)) then + if (i <= this%M) this%data(:,i) = 0.0_dp + if (i <= this%N) this%data(i,:) = 0.0_dp + end if + end do + end if + +end subroutine + +subroutine MatrixZ_Finalise(this) + type(MatrixZ), intent(inout) :: this + + call MatrixZ_Wipe(this) + call Finalise(this%ScaLAPACK_Info_obj) + +end subroutine MatrixZ_Finalise + +subroutine MatrixZ_Wipe(this) + type(MatrixZ), intent(inout) :: this + + call Wipe(this%ScaLAPACK_Info_obj) + + if (allocated(this%data)) then + call DEALLOC_TRACE("MatrixZ_Wipe ", size(this%data)*COMPLEX_SIZE) + deallocate(this%data) + endif + + this%N = 0 + this%M = 0 + this%l_N = 0 + this%l_M = 0 + +end subroutine MatrixZ_Wipe + +subroutine MatrixZ_Zero(this, d_mask, od_mask) + type(MatrixZ), intent(inout) :: this + logical, intent(in), optional :: d_mask(:), od_mask(:) + + integer i + + if (allocated(this%data)) then + if (present(d_mask) .or. present(od_mask)) then + if (present(d_mask)) then + do i=1, min(size(d_mask), this%N, this%M) + if (d_mask(i)) this%data(i,i) = 0.0_dp + end do + end if + if (present(od_mask)) then + do i=1, size(od_mask) + if (od_mask(i)) then + if (i <= this%M) this%data(:,i) = 0.0_dp + if (i <= this%N) this%data(i,:) = 0.0_dp + end if + end do + end if + else + this%data = 0.0_dp + endif + endif + +end subroutine + +subroutine MatrixD_Print(this,file) + type(MatrixD), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + if (current_verbosity() < PRINT_NORMAL) return + + call Print ("MatrixD : ", file=file) + + call Print ("N M " // this%N // " " // this%M // " l_N l_M " // this%l_N // " " // this%l_M, file=file) + call Print (this%ScaLAPACK_Info_obj, file=file) + call Print ("MatrixD data:", file=file) + if (this%ScaLAPACK_Info_obj%active) then + call Print(this%ScaLAPACK_Info_obj, this%data, file=file) + else + if (associated(this%data)) then + call Print(this%data, file=file) + endif + endif + +end subroutine MatrixD_Print + +subroutine MatrixZ_Print(this,file) + type(MatrixZ), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + + if (current_verbosity() < PRINT_NORMAL) return + + call Print ("MatrixZ : ", file=file) + + call Print ("N M " // this%N // " " // this%M // " l_N l_M " // this%l_N // " " // this%l_M, file=file) + call Print (this%ScaLAPACK_Info_obj, file=file) + call Print ("MatrixZ data:", file=file) + if (allocated(this%data)) then + if (this%ScaLAPACK_Info_obj%active) then + call Print(this%ScaLAPACK_Info_obj, this%data, file=file) + else + call Print(this%data, file=file) + endif + endif + +end subroutine MatrixZ_Print + +subroutine MatrixD_add_block(this, block, block_nr, block_nc, first_row, first_col) + type(MatrixD), intent(inout) :: this + real(dp), intent(in) :: block(:,:) + integer, intent(in) :: block_nr, block_nc !% Number of rows and columns of the block + integer, intent(in) :: first_row, first_col + + integer i, j, io, jo, li, lj + + if (this%ScaLAPACK_Info_obj%active) then + do jo=1, block_nc + j = first_col + jo - 1 + do io=1, block_nr + i = first_row + io - 1 + call coords_global_to_local(this%ScaLAPACK_Info_obj, i, j, li, lj) + if (li > 0 .and. lj > 0) then + this%data(li,lj) = this%data(li,lj) + block(io,jo) + endif + end do + end do + else + this%data(first_row:first_row+block_nr-1,first_col:first_col+block_nc-1) = & + this%data(first_row:first_row+block_nr-1,first_col:first_col+block_nc-1) + & + block(1:block_nr,1:block_nc) + endif + +end subroutine + +subroutine MatrixZ_add_block(this, block, block_nr, block_nc, first_row, first_col) + type(MatrixZ), intent(inout) :: this + complex(dp), intent(in) :: block(:,:) + integer, intent(in) :: block_nr, block_nc + integer, intent(in) :: first_row, first_col + + integer i, j, io, jo, li, lj + + if (this%ScaLAPACK_Info_obj%active) then + do jo=1, block_nc + j = first_col + jo - 1 + do io=1, block_nr + i = first_row + io - 1 + call coords_global_to_local(this%ScaLAPACK_Info_obj, i, j, li, lj) + if (li > 0 .and. lj > 0) then + this%data(li,lj) = this%data(li,lj) + block(io,jo) + endif + end do + end do + else + this%data(first_row:first_row+block_nr-1,first_col:first_col+block_nc-1) = & + this%data(first_row:first_row+block_nr-1,first_col:first_col+block_nc-1) + & + block(1:block_nr,1:block_nc) + endif +end subroutine + +subroutine MatrixD_diagonalise(this, evals, evecs, ignore_symmetry, error) + type(MatrixD), intent(in), target :: this + real(dp), intent(inout) :: evals(:) !% Eigenvalues + type(MatrixD), intent(inout), target, optional :: evecs !% Eigenvectors + logical, intent(in), optional :: ignore_symmetry + integer, intent(out), optional :: error + + real(dp), pointer :: u_evecs(:,:) + type(Matrix_ScaLAPACK_Info), pointer :: evecs_ScaLAPACK_Info + + INIT_ERROR(error) + + if (present(evecs)) then + u_evecs => evecs%data + evecs_ScaLAPACK_Info => evecs%ScaLAPACK_Info_obj + else + allocate(u_evecs(this%l_N,this%l_M)) + call ALLOC_TRACE("MatrixD_diagonalise evecs ", size(u_evecs)*REAL_SIZE) + evecs_ScaLAPACK_Info => this%ScaLAPACK_Info_obj + endif + + if (this%ScaLAPACK_Info_obj%active) then + call diagonalise(this%ScaLAPACK_Info_obj, this%data, evals, evecs_ScaLAPACK_Info, u_evecs, error = error) + else + call diagonalise(this%data, evals, u_evecs, ignore_symmetry = ignore_symmetry, error = error) + endif + + if (.not.present(evecs)) then + call DEALLOC_TRACE("MatrixD_diagonalise evecs ",-size(u_evecs)*REAL_SIZE) + deallocate(u_evecs) + endif + + PASS_ERROR(error) + +end subroutine MatrixD_diagonalise + +subroutine MatrixD_diagonalise_gen(this, overlap, evals, evecs, ignore_symmetry, error) + type(MatrixD), intent(in), target :: this + type(MatrixD), intent(in) :: overlap + real(dp), intent(inout) :: evals(:) + type(MatrixD), intent(inout), target, optional :: evecs + logical, intent(in), optional :: ignore_symmetry + integer, intent(out), optional :: error + + real(dp), pointer :: u_evecs(:,:) + type(Matrix_ScaLAPACK_Info), pointer :: evecs_ScaLAPACK_Info + + INIT_ERROR(error) + + if (present(evecs)) then + u_evecs => evecs%data + evecs_ScaLAPACK_Info => evecs%ScaLAPACK_Info_obj + else + allocate(u_evecs(this%l_N,this%l_M)) + call ALLOC_TRACE("MatrixD_diagonalise_gen evecs", size(u_evecs)*REAL_SIZE) + evecs_ScaLAPACK_Info => this%ScaLAPACK_Info_obj + endif + + if (this%ScaLAPACK_Info_obj%active) then + call diagonalise(this%ScaLAPACK_Info_obj, this%data, overlap%ScaLAPACK_Info_obj, & + overlap%data, evals, evecs_ScaLAPACK_Info, u_evecs, error) + else + call diagonalise(this%data, overlap%data, evals, u_evecs, error = error) + endif + + if (.not.present(evecs)) then + call DEALLOC_TRACE("MatrixD_diagonalise_gen u_evecs", size(u_evecs)*REAL_SIZE) + deallocate(u_evecs) + endif + + PASS_ERROR(error) + +end subroutine MatrixD_diagonalise_gen + +subroutine MatrixZ_diagonalise(this, evals, evecs, ignore_symmetry, error) + type(MatrixZ), intent(in), target :: this + real(dp), intent(inout) :: evals(:) + type(MatrixZ), intent(inout), target, optional :: evecs + logical, intent(in), optional :: ignore_symmetry + integer, intent(out), optional :: error + + complex(dp), pointer :: u_evecs(:,:) + type(Matrix_ScaLAPACK_Info), pointer :: evecs_ScaLAPACK_Info + + INIT_ERROR(error) + + if (present(evecs)) then + u_evecs => evecs%data + evecs_ScaLAPACK_Info => evecs%ScaLAPACK_Info_obj + else + allocate(u_evecs(this%l_N,this%l_M)) + call ALLOC_TRACE("MatrixZ_diagonalise u_evecs", size(u_evecs)*COMPLEX_SIZE) + evecs_ScaLAPACK_Info => this%ScaLAPACK_Info_obj + endif + + if (this%ScaLAPACK_Info_obj%active) then + call diagonalise(this%ScaLAPACK_Info_obj, this%data, evals, evecs_ScaLAPACK_Info, u_evecs, error) + else + call diagonalise(this%data, evals, u_evecs, ignore_symmetry = ignore_symmetry, error = error) + endif + + if (.not.present(evecs)) then + call DEALLOC_TRACE("MatrixZ_diagonalise u_evecs", size(u_evecs)*COMPLEX_SIZE) + deallocate(u_evecs) + endif + + PASS_ERROR(error) + +end subroutine MatrixZ_diagonalise + +subroutine MatrixZ_diagonalise_gen(this, overlap, evals, evecs, ignore_symmetry, error) + type(MatrixZ), intent(in), target :: this + type(MatrixZ), intent(in) :: overlap + real(dp), intent(inout) :: evals(:) + type(MatrixZ), intent(inout), target, optional :: evecs + logical, intent(in), optional :: ignore_symmetry + integer, intent(out), optional :: error + + complex(dp), pointer :: u_evecs(:,:) + type(Matrix_ScaLAPACK_Info), pointer :: evecs_ScaLAPACK_Info + + INIT_ERROR(error) + + if (present(evecs)) then + u_evecs => evecs%data + evecs_ScaLAPACK_Info => evecs%ScaLAPACK_Info_obj + else + allocate(u_evecs(this%l_N,this%l_M)) + call ALLOC_TRACE("MatrixZ_diagonalise_gen u_evecs", size(u_evecs)*COMPLEX_SIZE) + evecs_ScaLAPACK_Info => this%ScaLAPACK_Info_obj + endif + + if (this%ScaLAPACK_Info_obj%active) then + call diagonalise(this%ScaLAPACK_Info_obj, this%data, overlap%ScaLAPACK_Info_obj, & + overlap%data, evals, evecs_ScaLAPACK_Info, u_evecs, error) + else + call diagonalise(this%data, overlap%data, evals, u_evecs, error = error) + endif + + if (.not.present(evecs)) then + call DEALLOC_TRACE("MatrixZ_diagonalise_gen u_evecs", size(u_evecs)*COMPLEX_SIZE) + deallocate(u_evecs) + endif + + PASS_ERROR(error) + +end subroutine MatrixZ_diagonalise_gen + +!subroutine MatrixDD_accum_col_outer_product(this, mati, i, f) +! type(MatrixD), intent(inout) :: this +! type(MatrixD), intent(in) :: mati +! integer, intent(in) :: i +! real(dp), intent(in) :: f +! +! if (this%ScaLAPACK_Info_obj%active) then +! call system_abort ("No support for ScaLAPACK yet in MatrixD_accum_col_outer_product") +! else +! this%data = this%data + f*(mati%data(:,i) .outer. mati%data(:,i)) +! endif +!end subroutine MatrixDD_accum_col_outer_product +! +!subroutine MatrixZZ_accum_col_outer_product(this, mati, i, f) +! type(MatrixZ), intent(inout) :: this +! type(MatrixZ), intent(in) :: mati +! integer, intent(in) :: i +! real(dp), intent(in) :: f +! +! if (this%ScaLAPACK_Info_obj%active) then +! call system_abort ("No support for ScaLAPACK yet in MatrixZ_accum_col_outer_product") +! else +! this%data = this%data + f*(mati%data(:,i) .outer. mati%data(:,i)) +! endif +!end subroutine MatrixZZ_accum_col_outer_product + +function Matrix_partial_TraceMult_DD(a, b, a_T, b_T) + type(MatrixD), intent(in) :: a, b + logical, intent(in), optional :: a_T, b_T + real(dp) :: Matrix_partial_TraceMult_DD(a%N) + + logical u_a_T, u_b_T + integer i, j, g_i, g_j + + if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") + endif + + u_a_T = optional_default(.false., a_T) + u_b_T = optional_default(.false., b_T) + + if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then + if (u_a_T .and. .not. u_b_T) then + Matrix_partial_TraceMult_DD = 0.0_dp + do j=1, a%l_M + call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) + Matrix_partial_TraceMult_DD(g_j) = sum(a%data(:,j)*b%data(:,j)) + end do + else if (.not. u_a_T .and. u_b_T) then + Matrix_partial_TraceMult_DD = 0.0_dp + do i=1, a%l_N + call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) + Matrix_partial_TraceMult_DD(g_i) = sum(a%data(i,:)*b%data(i,:)) + end do + else + call system_abort("Can only do partial_TraceMult for ScaLAPACK matrices if one is transposed and the other not") + endif + else + if (.not. u_a_T .and. .not. u_b_T) then + do i=1, a%N + Matrix_partial_TraceMult_DD(i) = sum(a%data(i,:)*b%data(:,i)) + end do + else if (u_a_T .and. u_b_T) then + do i=1, a%N + Matrix_partial_TraceMult_DD(i) = sum(a%data(:,i)*b%data(i,:)) + end do + else if (.not. u_a_T .and. u_b_T) then + Matrix_partial_TraceMult_DD(:) = 0.0_dp + do i=1, a%N + Matrix_partial_TraceMult_DD(:) = Matrix_partial_TraceMult_DD(:) + a%data(:,i)*b%data(:,i) + end do + else + do i=1, a%N + Matrix_partial_TraceMult_DD(i) = sum(a%data(:,i)*b%data(:,i)) + end do + endif + endif + +end function Matrix_partial_TraceMult_DD + +function Matrix_partial_TraceMult_DZ(a, b, a_T, b_H) + type(MatrixD), intent(in) :: a + type(MatrixZ), intent(in) :: b + logical, intent(in), optional :: a_T, b_H + complex(dp) :: Matrix_partial_TraceMult_DZ(a%N) + + logical u_a_T, u_b_H + integer i, j, g_i, g_j + + if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") + endif + + u_a_T = optional_default(.false., a_T) + u_b_H = optional_default(.false., b_H) + + if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then + if (u_a_T .and. .not. u_b_H) then + Matrix_partial_TraceMult_DZ = 0.0_dp + do j=1, a%l_M + call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) + Matrix_partial_TraceMult_DZ(g_j) = sum(a%data(:,j)*b%data(:,j)) + end do + else if (.not. u_a_T .and. u_b_H) then + Matrix_partial_TraceMult_DZ = 0.0_dp + do i=1, a%l_N + call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) + Matrix_partial_TraceMult_DZ(g_i) = sum(a%data(i,:)*conjg(b%data(i,:))) + end do + else + call system_abort("Can only do partial_TraceMult for ScaLAPACK matrices if one is transposed and the other not") + endif + else ! no scalapack + if (.not. u_a_T .and. .not. u_b_H) then + do i=1, a%N + Matrix_partial_TraceMult_DZ(i) = sum(a%data(i,:)*b%data(:,i)) + end do + else if (u_a_T .and. u_b_H) then + do i=1, a%N + Matrix_partial_TraceMult_DZ(i) = sum(a%data(:,i)*conjg(b%data(i,:))) + end do + else if (.not. u_a_T .and. u_b_H) then + Matrix_partial_TraceMult_DZ(:) = 0.0_dp + do i=1, a%N + Matrix_partial_TraceMult_DZ(:) = Matrix_partial_TraceMult_DZ(:) + a%data(:,i)*conjg(b%data(:,i)) + end do + else + do i=1, a%N + Matrix_partial_TraceMult_DZ(i) = sum(a%data(:,i)*b%data(:,i)) + end do + endif + endif + +end function Matrix_partial_TraceMult_DZ + +function Matrix_partial_TraceMult_ZD(a, b, a_H, b_T) + type(MatrixZ), intent(in) :: a + type(MatrixD), intent(in) :: b + logical, intent(in), optional :: a_H, b_T + complex(dp) :: Matrix_partial_TraceMult_ZD(a%N) + + logical u_a_H, u_b_T + integer i, j, g_i, g_j + + if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") + endif + + u_a_H = optional_default(.false., a_H) + u_b_T = optional_default(.false., b_T) + + if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then + if (u_a_H .and. .not. u_b_T) then + Matrix_partial_TraceMult_ZD = 0.0_dp + do j=1, a%l_M + call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) + Matrix_partial_TraceMult_ZD(g_j) = sum(conjg(a%data(:,j))*b%data(:,j)) + end do + else if (.not. u_a_H .and. u_b_T) then + Matrix_partial_TraceMult_ZD = 0.0_dp + do i=1, a%l_N + call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) + Matrix_partial_TraceMult_ZD(g_i) = sum(a%data(i,:)*b%data(i,:)) + end do + else + call system_abort("Can only do partial_TraceMult for ScaLAPACK matrices if one is transposed and the other not") + endif + else + if (.not. u_a_H .and. .not. u_b_T) then + do i=1, a%N + Matrix_partial_TraceMult_ZD(i) = sum(a%data(i,:)*b%data(:,i)) + end do + else if (u_a_H .and. u_b_T) then + do i=1, a%N + Matrix_partial_TraceMult_ZD(i) = sum(conjg(a%data(:,i))*b%data(i,:)) + end do + else if (.not. u_a_H .and. u_b_T) then + Matrix_partial_TraceMult_ZD(:) = 0.0_dp + do i=1, a%N + Matrix_partial_TraceMult_ZD(:) = Matrix_partial_TraceMult_ZD(:) + a%data(:,i)*b%data(:,i) + end do + else + do i=1, a%N + Matrix_partial_TraceMult_ZD(i) = sum(conjg(a%data(:,i))*b%data(:,i)) + end do + endif + endif + +end function Matrix_partial_TraceMult_ZD + +function Matrix_partial_TraceMult_ZZ(a, b, a_H, b_H) + type(MatrixZ), intent(in) :: a + type(MatrixZ), intent(in) :: b + logical, intent(in), optional :: a_H, b_H + complex(dp) :: Matrix_partial_TraceMult_ZZ(a%N) + + logical u_a_H, u_b_H + integer i, j, g_i, g_j + + if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") + endif + + u_a_H = optional_default(.false., a_H) + u_b_H = optional_default(.false., b_H) + + if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then + if (u_a_H .and. .not. u_b_H) then + Matrix_partial_TraceMult_ZZ = 0.0_dp + do j=1, a%l_M + call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) + Matrix_partial_TraceMult_ZZ(g_j) = sum(conjg(a%data(:,j))*b%data(:,j)) + end do + else if (.not. u_a_H .and. u_b_H) then + Matrix_partial_TraceMult_ZZ = 0.0_dp + do i=1, a%l_N + call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) + Matrix_partial_TraceMult_ZZ(g_i) = sum(a%data(i,:)*conjg(b%data(i,:))) + end do + else + call system_abort("Can only do partial_TraceMult for ScaLAPACK matrices if one is transposed and the other not") + endif + else + if (.not. u_a_H .and. .not. u_b_H) then + do i=1, a%N + Matrix_partial_TraceMult_ZZ(i) = sum(a%data(i,:)*b%data(:,i)) + end do + else if (u_a_H .and. u_b_H) then + do i=1, a%N + Matrix_partial_TraceMult_ZZ(i) = sum(conjg(a%data(:,i))*conjg(b%data(i,:))) + end do + else if (.not. u_a_H .and. u_b_H) then + Matrix_partial_TraceMult_ZZ(:) = 0.0_dp + do i=1, a%N + Matrix_partial_TraceMult_ZZ(:) = Matrix_partial_TraceMult_ZZ(:) + a%data(:,i)*conjg(b%data(:,i)) + end do + else + do i=1, a%N + Matrix_partial_TraceMult_ZZ(i) = sum(conjg(a%data(:,i))*b%data(:,i)) + end do + endif + endif + +end function Matrix_partial_TraceMult_ZZ + +function Matrix_partial_TraceMult_spinor_ZZ(a, b, a_H, b_H) + type(MatrixZ), intent(in) :: a + type(MatrixZ), intent(in) :: b + logical, intent(in), optional :: a_H, b_H + complex(dp) :: Matrix_partial_TraceMult_spinor_ZZ(2,2,a%N/2) + + logical u_a_H, u_b_H + integer i, j, g_i, g_j + + if (a%ScaLAPACK_Info_obj%active .neqv. b%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do partial tracemult for mixed dense regular and ScaLAPACK matrices") + endif + + u_a_H = optional_default(.false., a_H) + u_b_H = optional_default(.false., b_H) + + if (a%ScaLAPACK_Info_obj%active .or. b%ScaLAPACK_Info_obj%active) then + if (u_a_H .and. .not. u_b_H) then + Matrix_partial_TraceMult_spinor_ZZ = 0.0_dp + do j=1, a%l_M + call coords_local_to_global(a%ScaLAPACK_Info_obj, 1, j, g_i, g_j) + Matrix_partial_TraceMult_spinor_ZZ(1,1,(g_j-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,j))*b%data(1:a%l_N:2,j)) + Matrix_partial_TraceMult_spinor_ZZ(1,2,(g_j-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,j))*b%data(2:a%l_N:2,j)) + Matrix_partial_TraceMult_spinor_ZZ(2,1,(g_j-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,j+1))*b%data(1:a%l_N:2,j+1)) + Matrix_partial_TraceMult_spinor_ZZ(2,2,(g_j-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,j+1))*b%data(2:a%l_N:2,j+1)) + end do + else if (.not. u_a_H .and. u_b_H) then + Matrix_partial_TraceMult_spinor_ZZ = 0.0_dp + do i=1, a%l_N, 2 + call coords_local_to_global(a%ScaLAPACK_Info_obj, i, 1, g_i, g_j) + Matrix_partial_TraceMult_spinor_ZZ(1,1,(g_i-1)/2+1) = sum(a%data(i,1:a%l_M:2)*conjg(b%data(i,1:b%l_M:2))) + Matrix_partial_TraceMult_spinor_ZZ(1,2,(g_i-1)/2+1) = sum(a%data(i,2:a%l_M:2)*conjg(b%data(i,2:b%l_M:2))) + Matrix_partial_TraceMult_spinor_ZZ(2,1,(g_i-1)/2+1) = sum(a%data(i+1,1:a%l_M:2)*conjg(b%data(i+1,1:b%l_M:2))) + Matrix_partial_TraceMult_spinor_ZZ(2,2,(g_i-1)/2+1) = sum(a%data(i+1,2:a%l_M:2)*conjg(b%data(i+1,2:b%l_M:2))) + end do + else + call system_abort("Can only do partial_TraceMult_spinor for ScaLAPACK matrices if one is transposed and the other not") + endif + else + if (.not. u_a_H .and. .not. u_b_H) then + do i=1, a%N, 2 + Matrix_partial_TraceMult_spinor_ZZ(1,1,(i-1)/2+1) = sum(a%data(i,1:a%l_M:2)*b%data(1:b%l_N:2,i)) + Matrix_partial_TraceMult_spinor_ZZ(1,2,(i-1)/2+1) = sum(a%data(i,2:a%l_M:2)*b%data(2:b%l_N:2,i)) + Matrix_partial_TraceMult_spinor_ZZ(2,1,(i-1)/2+1) = sum(a%data(i+1,1:a%l_M:2)*b%data(1:b%l_N:2,i+1)) + Matrix_partial_TraceMult_spinor_ZZ(2,2,(i-1)/2+1) = sum(a%data(i+1,2:a%l_M:2)*b%data(2:b%l_N:2,i+1)) + end do + else if (u_a_H .and. u_b_H) then + do i=1, a%N, 2 + Matrix_partial_TraceMult_spinor_ZZ(1,1,(i-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,i))*conjg(b%data(i,1:b%l_M:2))) + Matrix_partial_TraceMult_spinor_ZZ(1,2,(i-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,i))*conjg(b%data(i,2:b%l_M:2))) + Matrix_partial_TraceMult_spinor_ZZ(2,1,(i-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,i+1))*conjg(b%data(i+1,1:b%l_M:2))) + Matrix_partial_TraceMult_spinor_ZZ(2,2,(i-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,i+1))*conjg(b%data(i+1,2:b%l_M:2))) + end do + else if (.not. u_a_H .and. u_b_H) then + Matrix_partial_TraceMult_spinor_ZZ(:,:,:) = 0.0_dp + do i=1, a%N, 2 + Matrix_partial_TraceMult_spinor_ZZ(1,1,:) = Matrix_partial_TraceMult_spinor_ZZ(1,1,:) + a%data(1:a%l_N:2,i)*conjg(b%data(1:b%l_N:2,i)) + Matrix_partial_TraceMult_spinor_ZZ(1,2,:) = Matrix_partial_TraceMult_spinor_ZZ(1,2,:) + a%data(1:a%l_N:2,i+1)*conjg(b%data(1:b%l_N:2,i+1)) + Matrix_partial_TraceMult_spinor_ZZ(2,1,:) = Matrix_partial_TraceMult_spinor_ZZ(2,1,:) + a%data(2:a%l_N:2,i)*conjg(b%data(2:b%l_N:2,i)) + Matrix_partial_TraceMult_spinor_ZZ(2,2,:) = Matrix_partial_TraceMult_spinor_ZZ(2,2,:) + a%data(2:a%l_N:2,i+1)*conjg(b%data(2:b%l_N:2,i+1)) + end do + else + do i=1, a%N, 2 + Matrix_partial_TraceMult_spinor_ZZ(1,1,(i-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,i))*b%data(1:b%l_N:2,i)) + Matrix_partial_TraceMult_spinor_ZZ(1,2,(i-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,i))*b%data(2:b%l_N:2,i)) + Matrix_partial_TraceMult_spinor_ZZ(2,1,(i-1)/2+1) = sum(conjg(a%data(1:a%l_N:2,i+1))*b%data(1:b%l_N:2,i+1)) + Matrix_partial_TraceMult_spinor_ZZ(2,2,(i-1)/2+1) = sum(conjg(a%data(2:a%l_N:2,i+1))*b%data(2:b%l_N:2,i+1)) + end do + endif + endif + +end function Matrix_partial_TraceMult_spinor_ZZ + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +function Matrix_TraceMult_DD(a, b, w, a_T, b_T) + type(MatrixD), intent(in) :: a, b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_T, b_T + real(dp) :: Matrix_TraceMult_DD + + if (present(w)) then + Matrix_TraceMult_DD = sum(partial_TraceMult(a, b, a_T, b_T)*w) + else + Matrix_TraceMult_DD = sum(partial_TraceMult(a, b, a_T, b_T)) + endif + +end function Matrix_TraceMult_DD + +function Matrix_TraceMult_DZ(a, b, w, a_T, b_H) + type(MatrixD), intent(in) :: a + type(MatrixZ), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_T, b_H + complex(dp) :: Matrix_TraceMult_DZ + + if (present(w)) then + Matrix_TraceMult_DZ = sum(partial_TraceMult(a, b, a_T, b_H)*w) + else + Matrix_TraceMult_DZ = sum(partial_TraceMult(a, b, a_T, b_H)) + endif + +end function Matrix_TraceMult_DZ + +function Matrix_TraceMult_ZD(a, b, w, a_H, b_T) + type(MatrixZ), intent(in) :: a + type(MatrixD), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_H, b_T + complex(dp) :: Matrix_TraceMult_ZD + + if (present(w)) then + Matrix_TraceMult_ZD = sum(partial_TraceMult(a, b, a_H, b_T)*w) + else + Matrix_TraceMult_ZD = sum(partial_TraceMult(a, b, a_H, b_T)) + endif + +end function Matrix_TraceMult_ZD + +function Matrix_TraceMult_ZZ(a, b, w, a_H, b_H) + type(MatrixZ), intent(in) :: a + type(MatrixZ), intent(in) :: b + real(dp), intent(in), optional :: w(:) + logical, intent(in), optional :: a_H, b_H + complex(dp) :: Matrix_TraceMult_ZZ + + if (present(w)) then + Matrix_TraceMult_ZZ = sum(partial_TraceMult(a, b, a_H, b_H)*w) + else + Matrix_TraceMult_ZZ = sum(partial_TraceMult(a, b, a_H, b_H)) + endif + +end function Matrix_TraceMult_ZZ + +function Matrix_Re_diagZ(a) + type(MatrixZ), intent(in) :: a + real(dp) :: Matrix_Re_diagZ(a%N) + + integer i + + if (a%ScaLAPACK_Info_obj%active) then + Matrix_Re_diagZ = Re_diag(a%ScaLAPACK_Info_obj, a%data) + else + do i=1, a%N + Matrix_Re_diagZ(i) = real(a%data(i,i)) + end do + endif +end function Matrix_Re_diagZ + +function Matrix_Re_diagD(a) + type(MatrixD), intent(in) :: a + real(dp) :: Matrix_Re_diagD(a%N) + + integer i + + if (a%ScaLAPACK_Info_obj%active) then + Matrix_Re_diagD = Re_diag(a%ScaLAPACK_Info_obj, a%data) + else + do i=1, a%N + Matrix_Re_diagD(i) = a%data(i,i) + end do + endif +end function Matrix_Re_diagD + +function Matrix_diag_spinorZ(a) + type(MatrixZ), intent(in) :: a + complex(dp) :: Matrix_diag_spinorZ(2,2,a%N/2) + + integer i + + if (a%ScaLAPACK_Info_obj%active) then + Matrix_diag_spinorZ = diag_spinor(a%ScaLAPACK_Info_obj, a%data) + else + Matrix_diag_spinorZ = 0.0_dp + do i=1, a%N,2 + Matrix_diag_spinorZ(:,:,(i-1)/2+1) = a%data(i:i+1,i:i+1) + end do + endif +end function Matrix_diag_spinorZ + +function Matrix_diag_spinorD(a) + type(MatrixD), intent(in) :: a + complex(dp) :: Matrix_diag_spinorD(2,2,a%N/2) + + integer i + + if (a%ScaLAPACK_Info_obj%active) then + Matrix_diag_spinorD = diag_spinor(a%ScaLAPACK_Info_obj, a%data) + else + Matrix_diag_spinorD = 0.0_dp + do i=1, a%N, 2 + Matrix_diag_spinorD(:,:,(i-1)/2+1) = a%data(i:i+1,i:i+1) + end do + endif +end function Matrix_diag_spinorD + +subroutine Matrix_scaled_sum_ZDD(this, f1, m1, f2, m2) + type(MatrixZ), intent(inout) :: this + complex(dp), intent(in) :: f1 + type(MatrixD), intent(in) :: m1 + complex(dp), intent(in) :: f2 + type(MatrixD), intent(in) :: m2 + + integer i + + if (m1%ScaLAPACK_Info_obj%active .neqv. m2%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do scaled_sum for mixed ScaLAPCAK non-ScaLAPACK matrices") + endif + + do i=1, size(this%data,2) + this%data(:,i) = f1*m1%data(:,i) + f2*m2%data(:,i) + end do + +end subroutine Matrix_scaled_sum_ZDD + +subroutine Matrix_scaled_sum_ZZZ(this, f1, m1, f2, m2) + type(MatrixZ), intent(inout) :: this + complex(dp), intent(in) :: f1 + type(MatrixZ), intent(in) :: m1 + complex(dp), intent(in) :: f2 + type(MatrixZ), intent(in) :: m2 + + integer i + + if (m1%ScaLAPACK_Info_obj%active .neqv. m2%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do scaled_sum for mixed ScaLAPCAK non-ScaLAPACK matrices") + endif + + do i=1, size(this%data,2) + this%data(:,i) = f1*m1%data(:,i) + f2*m2%data(:,i) + end do + +end subroutine Matrix_scaled_sum_ZZZ + +subroutine Matrix_scaled_accum_DZ(this, f1, m1) + type(MatrixD), intent(inout) :: this + complex(dp), intent(in) :: f1 + type(MatrixZ), intent(in) :: m1 + + integer i + + if (this%ScaLAPACK_Info_obj%active .neqv. m1%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do scaled_accum for mixed ScaLAPCAK non-ScaLAPACK matrices") + endif + + do i=1, size(this%data,2) + this%data(:,i) = this%data(:,i) + f1*m1%data(:,i) + end do + +end subroutine Matrix_scaled_accum_DZ + +subroutine Matrix_scaled_accum_ZZ(this, f1, m1) + type(MatrixZ), intent(inout) :: this + complex(dp), intent(in) :: f1 + type(MatrixZ), intent(in) :: m1 + + integer i + + if (this%ScaLAPACK_Info_obj%active .neqv. m1%ScaLAPACK_Info_obj%active) then + call system_abort("Can't do scaled_accum for mixed ScaLAPCAK non-ScaLAPACK matrices") + endif + + do i=1, size(this%data,2) + this%data(:,i) = this%data(:,i) + f1*m1%data(:,i) + end do + +end subroutine Matrix_scaled_accum_ZZ + + +subroutine MatrixD_inverse(this, inv, positive) + type(MatrixD), intent(inout) :: this + type(MatrixD), intent(out), optional :: inv + logical, intent(in), optional :: positive + + if (this%ScaLAPACK_Info_obj%active) then + if (present(inv)) then + call inverse(this%ScaLAPACK_Info_obj, this%data, inv%ScaLAPACK_Info_obj, inv%data, positive) + else + call inverse(this%ScaLAPACK_Info_obj, this%data, positive_in = positive) + endif + else + if (present(inv)) then + call inverse(this%data, inv%data, positive) + else + call inverse(this%data, positive_in = positive) + endif + endif +end subroutine MatrixD_inverse + +subroutine MatrixZ_inverse(this, inv, positive) + type(MatrixZ), intent(inout) :: this + type(MatrixZ), intent(out), optional :: inv + logical, intent(in), optional :: positive + + if (this%ScaLAPACK_Info_obj%active) then + if (present(inv)) then + call inverse(this%ScaLAPACK_Info_obj, this%data, inv%ScaLAPACK_Info_obj, inv%data, positive) + else + call inverse(this%ScaLAPACK_Info_obj, this%data, positive_in = positive) + endif + else + if (present(inv)) then + call inverse(this%data, inv%data, positive) + else + call inverse(this%data, positive_in = positive) + endif + endif + +end subroutine MatrixZ_inverse + +subroutine MatrixD_multDiag_d(this, A, diag) + type(MatrixD), intent(inout) :: this + type(MatrixD), intent(in) :: A + real(dp), intent(in) :: diag(:) + + if (this%M /= size(diag) .or. A%M /= size(diag)) & + call system_abort("Called MatrixD_multDiag_d with mismatched sizes") + + if (this%ScaLAPACK_Info_obj%active .and. A%ScaLAPACK_Info_obj%active) then + call matrix_product_vect_asdiagonal_sub(this%ScaLAPACK_Info_obj, this%data, A%ScaLAPACK_Info_obj, A%data, diag) + else if (.not.this%ScaLAPACK_Info_obj%active .and. .not.A%ScaLAPACK_Info_obj%active) then + call matrix_product_vect_asdiagonal_sub(this%data, A%data, diag) + else + call system_abort("Called MatrixD_multDiag_d with mix of ScaLAPACK and non-ScaLAPACK objects") + endif +end subroutine MatrixD_multDiag_d + +subroutine MatrixZ_multDiag_d(this, A, diag) + type(MatrixZ), intent(inout) :: this + type(MatrixZ), intent(in) :: A + real(dp), intent(in) :: diag(:) + + if (this%M /= size(diag) .or. A%M /= size(diag)) & + call system_abort("Called MatrixZ_multDiag_d with mismatched sizes") + + if (this%ScaLAPACK_Info_obj%active .and. A%ScaLAPACK_Info_obj%active) then + call matrix_product_vect_asdiagonal_sub(this%ScaLAPACK_Info_obj, this%data, A%ScaLAPACK_Info_obj, A%data, diag) + else if (.not.this%ScaLAPACK_Info_obj%active .and. .not.A%ScaLAPACK_Info_obj%active) then + call matrix_product_vect_asdiagonal_sub(this%data, A%data, diag) + else + call system_abort("Called MatrixZ_multDiag_d with mix of ScaLAPACK and non-ScaLAPACK objects") + endif +end subroutine MatrixZ_multDiag_d + +subroutine MatrixZ_multDiag_z(this, A, diag) + type(MatrixZ), intent(inout) :: this + type(MatrixZ), intent(in) :: A + complex(dp), intent(in) :: diag(:) + + if (this%M /= size(diag) .or. A%M /= size(diag)) & + call system_abort("Called MatrixZ_multDiag_z with mismatched sizes") + + if (this%ScaLAPACK_Info_obj%active .and. A%ScaLAPACK_Info_obj%active) then + call matrix_product_vect_asdiagonal_sub(this%ScaLAPACK_Info_obj, this%data, A%ScaLAPACK_Info_obj, A%data, diag) + else if (.not.this%ScaLAPACK_Info_obj%active .and. .not.A%ScaLAPACK_Info_obj%active) then + call matrix_product_vect_asdiagonal_sub(this%data, A%data, diag) + else + call system_abort("Called MatrixZ_multDiag_z with mix of ScaLAPACK and non-ScaLAPACK objects") + endif +end subroutine MatrixZ_multDiag_z + +subroutine MatrixD_multDiagRL_d(this, A, diag) + type(MatrixD), intent(inout) :: this + type(MatrixD), intent(in) :: A + real(dp), intent(in) :: diag(:) + + if (this%M /= size(diag) .or. A%M /= size(diag)) & + call system_abort("Called MatrixD_multDiagRL_d with mismatched sizes") + + call matrix_product_vect_asdiagonal_RL_sub(this%data, A%data, diag) +end subroutine MatrixD_multDiagRL_d + +subroutine MatrixZ_multDiagRL_d(this, A, diag) + type(MatrixZ), intent(inout) :: this + type(MatrixZ), intent(in) :: A + real(dp), intent(in) :: diag(:) + + if (this%M /= size(diag) .or. A%M /= size(diag)) & + call system_abort("Called MatrixZ_multDiagRL_d with mismatched sizes") + + call matrix_product_vect_asdiagonal_RL_sub(this%data, A%data, diag) +end subroutine MatrixZ_multDiagRL_d + +subroutine MatrixZ_matrix_product_sub_zz(C, A, B, a_transpose, a_conjugate, b_transpose, b_conjugate) + type(MatrixZ), intent(inout) :: C + type(MatrixZ), intent(in) :: A, B + logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose, b_conjugate + + if (a%ScaLAPACK_Info_obj%active .and. & + b%ScaLAPACK_Info_obj%active .and. & + c%ScaLAPACK_Info_obj%active) then + call matrix_product_sub(C%ScaLAPACK_Info_obj, C%data, A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, B%data, & + a_transpose, a_conjugate, b_transpose, b_conjugate) + else if (.not.a%ScaLAPACK_Info_obj%active .and. & + .not.b%ScaLAPACK_Info_obj%active .and. & + .not.c%ScaLAPACK_Info_obj%active) then + call matrix_product_sub(C%data, A%data, B%data, a_transpose, a_conjugate, b_transpose, b_conjugate) + else + call system_abort("Called MatrixZ_matric_product_sub_zz with a mix of ScaLAPACK and non-ScaLAPACK matrices") + endif +end subroutine MatrixZ_matrix_product_sub_zz + +subroutine MatrixZ_matrix_product_sub_dz(C, A, B, a_transpose, b_transpose, b_conjugate) + type(MatrixZ), intent(inout) :: C + type(MatrixD), intent(in) :: A + type(MatrixZ), intent(in) :: B + logical, intent(in), optional :: a_transpose, b_transpose, b_conjugate + + logical a_transp, b_transp, b_conjg + real(dp), allocatable :: tC(:,:), tB(:,:) + + allocate(tC(C%l_N, C%l_M)) + call ALLOC_TRACE("MatrixZ_product_sub_dz tC", size(tC)*REAL_SIZE) + allocate(tB(B%l_N, B%l_M)) + call ALLOC_TRACE("MatrixZ_product_sub_dz tB", size(tB)*REAL_SIZE) + + a_transp = optional_default(.false., a_transpose) + b_transp = optional_default(.false., b_transpose) + b_conjg = optional_default(.false., b_conjugate) + + if (a%ScaLAPACK_Info_obj%active .and. & + b%ScaLAPACK_Info_obj%active .and. & + c%ScaLAPACK_Info_obj%active) then + tB = dble(B%data) + call matrix_product_sub(C%ScaLAPACK_Info_obj, tC, A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, tB, & + a_transp, b_transp .or. b_conjg) + C%data = tC + if (b_conjg) then + tB = -aimag(B%data) + else + tB = aimag(B%data) + endif + call matrix_product_sub(C%ScaLAPACK_Info_obj, tC, A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, tB, & + a_transp, b_transp .or. b_conjg) + c%data = c%data + cmplx(0.0_dp, tC, dp) + else if (.not.a%ScaLAPACK_Info_obj%active .and. & + .not.b%ScaLAPACK_Info_obj%active .and. & + .not.c%ScaLAPACK_Info_obj%active) then + tB = dble(B%data) + call matrix_product_sub(tC, A%data, tB, a_transp, b_transp .or. b_conjg) + C%data = tC + if (b_conjg) then + tB = -aimag(B%data) + else + tB = aimag(B%data) + endif + call matrix_product_sub(tC, A%data, tB, a_transp, b_transp .or. b_conjg) + c%data = c%data + cmplx(0.0_dp, tC, dp) + else + call system_abort("Called MatrixZ_matric_product_sub_dz with a mix of ScaLAPACK and non-ScaLAPACK matrices") + endif + + call DEALLOC_TRACE("MatrixZ_product_sub_dz tC", size(tC)*REAL_SIZE) + deallocate(tC) + call DEALLOC_TRACE("MatrixZ_product_sub_dz tB", size(tB)*REAL_SIZE) + deallocate(tB) +end subroutine MatrixZ_matrix_product_sub_dz + +subroutine MatrixZ_matrix_product_sub_zd(C, A, B, a_transpose, a_conjugate, b_transpose) + type(MatrixZ), intent(inout) :: C + type(MatrixZ), intent(in) :: A + type(MatrixD), intent(in) :: B + logical, intent(in), optional :: a_transpose, a_conjugate, b_transpose + + logical a_transp, a_conjg, b_transp + real(dp), allocatable :: tC(:,:), tA(:,:) + + allocate(tC(C%l_N, C%l_M)) + call ALLOC_TRACE("MatrixZ_product_sub_zd tC", size(tC)*REAL_SIZE) + allocate(tA(A%l_N, A%l_M)) + call ALLOC_TRACE("MatrixZ_product_sub_zd tA", size(tA)*REAL_SIZE) + + a_transp = optional_default(.false., a_transpose) + a_conjg = optional_default(.false., a_conjugate) + b_transp = optional_default(.false., b_transpose) + + if (a%ScaLAPACK_Info_obj%active .and. & + b%ScaLAPACK_Info_obj%active .and. & + c%ScaLAPACK_Info_obj%active) then + tA = dble(A%data) + call matrix_product_sub(C%ScaLAPACK_Info_obj, tC, A%ScaLAPACK_Info_obj, tA, B%ScaLAPACK_Info_obj, B%data, & + a_transp .or. a_conjg, b_transp) + C%data = tC + if (a_conjg) then + tA = -aimag(A%data) + else + tA = aimag(A%data) + endif + call matrix_product_sub(C%ScaLAPACK_Info_obj, tC, A%ScaLAPACK_Info_obj, tA, B%ScaLAPACK_Info_obj, B%data, & + a_transp .or. a_conjg, b_transp) + c%data = c%data + cmplx(0.0_dp, tC, dp) + else if (.not.a%ScaLAPACK_Info_obj%active .and. & + .not.b%ScaLAPACK_Info_obj%active .and. & + .not.c%ScaLAPACK_Info_obj%active) then + tA = dble(A%data) + call matrix_product_sub(tC, tA, B%data, a_transp .or. a_conjg, b_transp) + C%data = tC + if (a_conjg) then + tA = -aimag(A%data) + else + tA = aimag(A%data) + endif + call matrix_product_sub(tC, tA, B%data, a_transp .or. a_conjg, b_transp) + c%data = c%data + cmplx(0.0_dp, tC, dp) + else + call system_abort("Called MatrixZ_matric_product_sub_zd with a mix of ScaLAPACK and non-ScaLAPACK matrices") + endif + + call DEALLOC_TRACE("MatrixZ_product_sub_zd tC", size(tC)*REAL_SIZE) + deallocate(tC) + call DEALLOC_TRACE("MatrixZ_product_sub_zd tA", size(tA)*REAL_SIZE) + deallocate(tA) +end subroutine MatrixZ_matrix_product_sub_zd + +subroutine MatrixD_matrix_product_sub_dd(C, A, B, a_transpose, b_transpose) + type(MatrixD), intent(inout) :: C + type(MatrixD), intent(in) :: A, B + logical, intent(in), optional :: a_transpose, b_transpose + + if (a%ScaLAPACK_Info_obj%active .and. & + b%ScaLAPACK_Info_obj%active .and. & + c%ScaLAPACK_Info_obj%active) then + call matrix_product_sub(C%ScaLAPACK_Info_obj, C%data, A%ScaLAPACK_Info_obj, A%data, B%ScaLAPACK_Info_obj, B%data, & + a_transpose, b_transpose) + else if (.not.a%ScaLAPACK_Info_obj%active .and. & + .not.b%ScaLAPACK_Info_obj%active .and. & + .not.c%ScaLAPACK_Info_obj%active) then + call matrix_product_sub(C%data, A%data, B%data, a_transpose, b_transpose) + else + call system_abort("Called MatrixD_matric_product_sub_dd with a mix of ScaLAPACK and non-ScaLAPACK matrices") + endif +end subroutine MatrixD_matrix_product_sub_dd + +subroutine MatrixD_matrix_product_sub_dr2(C, A, B, a_transpose, b_transpose) + type(MatrixD), intent(inout) :: C + type(MatrixD), intent(in) :: A + real(dp), intent(in) :: B(:,:) + logical, intent(in), optional :: a_transpose, b_transpose + + if (.not.a%ScaLAPACK_Info_obj%active .and. .not.c%ScaLAPACK_Info_obj%active) then + call matrix_product_sub(C%data, A%data, B, a_transpose, b_transpose) + else + call system_abort("Called MatrixZ_matric_product_sub_dr2 with a mix of ScaLAPACK and non-ScaLAPACK matrices") + endif + +end subroutine MatrixD_matrix_product_sub_dr2 + +subroutine MatrixD_add_identity(A) + type(MatrixD), intent(inout) :: A + + if (A%ScaLAPACK_Info_obj%active) then + call add_identity(A%ScaLAPACK_Info_obj, A%data) + else + call add_identity(A%data) + endif +end subroutine + +subroutine MatrixD_scale(A, scale) + type(MatrixD), intent(inout) :: A + real(dp), intent(in) :: scale + + A%data = A%data * scale +end subroutine + +subroutine MatrixD_transpose_sub(this, m) + type(MatrixD), intent(inout) :: this + type(MatrixD), intent(in) :: m + + if (this%N /= m%M .or. this%M /= m%N) call system_abort("Called MatrixD_transpose_sub with mismatched sizes "// & + "this " // this%N // " " // this%M // " m " // m%N // " " //m%M) + + + if (this%ScaLAPACK_Info_obj%active .and. m%ScaLAPACK_Info_obj%active) then + call system_abort("MatrixD_transpose_sub not yet implemented for ScaLAPACK matrices") + else + this%data = transpose(m%data) + endif +end subroutine MatrixD_transpose_sub + +subroutine MatrixZ_transpose_sub(this, m) + type(MatrixZ), intent(inout) :: this + type(MatrixZ), intent(in) :: m + + if (this%N /= m%M .or. this%M /= m%N) call system_abort("Called MatrixZ_transpose_sub with mismatched sizes "// & + "this " // this%N // " " // this%M // " m " // m%N // " " //m%M) + + + if (this%ScaLAPACK_Info_obj%active .and. m%ScaLAPACK_Info_obj%active) then + call system_abort("MatrixZ_transpose_sub not yet implemented for ScaLAPACK matrices") + else + this%data = transpose(m%data) + endif +end subroutine MatrixZ_transpose_sub + +subroutine MatrixD_make_hermitian(this) + type(MatrixD), intent(inout) :: this + + if (this%ScaLAPACK_Info_obj%active) then + call system_abort("MatrixD_make_hermitian not yet implemented for ScaLAPACK matrices") + else + call make_hermitian(this%data) + endif +end subroutine MatrixD_make_hermitian + +subroutine MatrixZ_make_hermitian(this) + type(MatrixZ), intent(inout) :: this + + if (this%ScaLAPACK_Info_obj%active) then + call system_abort("MatrixZ_make_hermitian not yet implemented for ScaLAPACK matrices") + else + call make_hermitian(this%data) + endif +end subroutine MatrixZ_make_hermitian + +end module matrix_module diff --git a/src/libAtoms/ParamReader.F90 b/src/libAtoms/ParamReader.F90 new file mode 100644 index 0000000000..5cfa37f497 --- /dev/null +++ b/src/libAtoms/ParamReader.F90 @@ -0,0 +1,1061 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X ParamReader module +!X +!X James Kermode +!% The ParamReader module provides the facility to read parameters in the +!% form 'key = value' from files or from the command line. In typical +!% usage you would 'Param_Register' a series of parameters with default values, +!% then read some values from a parameter file overriding the defaults, +!% possibly then reading from the command line arguments to override the +!% options set by the parameter file. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module paramreader_module + + use system_module + use extendable_str_module + use dictionary_module + use table_module + + implicit none + private + + public :: param_register, PARAM_MANDATORY, param_read_line, param_read_args, param_print_help, param_print, param_check, param_write_string + + integer, parameter, private :: MAX_N_FIELDS = 1024 !% Maximum number of fields during parsing + + integer, parameter :: PARAM_NO_VALUE = 0 !% Special parameter type that doesn't get parsed + integer, parameter :: PARAM_REAL = 1 !% Real (double precision) parameter + integer, parameter :: PARAM_INTEGER = 2 !% Integer parameter + integer, parameter :: PARAM_STRING = 3 !% String parameter + integer, parameter :: PARAM_LOGICAL = 4 !% Logical parameter + + character(len=*), parameter :: PARAM_MANDATORY = '//MANDATORY//' !% If this is passed to 'Param_Register' + !% instead of a default value then + !% this parameter is not optional. + + type ParamEntry + !% OMIT + + character(len=STRING_LENGTH):: value + integer :: N, param_type + + real(dp), pointer :: real => null() + integer, pointer :: integer => null() + logical, pointer :: logical => null() + character(len=STRING_LENGTH), pointer :: string => null() + + real(dp), dimension(:), pointer :: reals => null() + integer, dimension(:), pointer :: integers => null() + + logical, pointer :: has_value + + character(len=STRING_LENGTH) :: help_string + character(len=STRING_LENGTH) :: altkey + end type ParamEntry + + !% Overloaded interface to register a parameter in a Dictionary object. + !% 'key' is the key name and 'value' the default value. For a mandatory + !% parameter use a value of 'PARAM_MANDATORY'. The last argument to Register + !% should be a pointer to the variable that the value of the parameter should + !% be copied to after parsing by 'param_read_line', 'param_read_file' + !% or 'param_read_args'. For a parameter which shouldn't be parsed, do not specify a target. + interface param_register + module procedure param_register_single_integer + module procedure param_register_multiple_integer + module procedure param_register_single_real + module procedure param_register_multiple_real + module procedure param_register_single_string + module procedure param_register_dontread + module procedure param_register_single_logical + end interface + +#ifdef POINTER_COMPONENT_MANUAL_COPY + interface assignment(=) + module procedure ParamEntry_assign + end interface +#endif + + contains + + ! Overloaded interface for registering parameter of type single logical + subroutine param_register_single_logical(dict, key, value, logical_target, help_string, has_value_target, altkey) + type(Dictionary), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + logical, intent(inout), target :: logical_target + character(len=*), intent(in) :: help_string + logical, intent(inout), optional, target :: has_value_target + character(len=*), intent(in), optional :: altkey + call param_register_main(dict, key, value, 1, PARAM_LOGICAL, & + help_string=help_string, logical_target=logical_target, & + has_value_target=has_value_target, altkey=altkey) + if (present(altkey)) then + call param_register_main(dict, altkey, value, 1, PARAM_LOGICAL, & + help_string=help_string, logical_target=logical_target, & + has_value_target=has_value_target, altkey=key) + end if + + + end subroutine param_register_single_logical + + ! Overloaded interface for registering parameter of type single integer + subroutine param_register_single_integer(dict, key, value, int_target, help_string, has_value_target, altkey) + type(Dictionary), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + integer, intent(inout), target :: int_target + character(len=*), intent(in) :: help_string + logical, intent(inout), optional, target :: has_value_target + character(len=*), intent(in), optional :: altkey + + call param_register_main(dict, key, value, 1, PARAM_INTEGER, & + help_string=help_string, int_target=int_target, & + has_value_target=has_value_target, altkey=altkey) + if (present(altkey)) then + call param_register_main(dict, altkey, value, 1, PARAM_INTEGER, & + help_string=help_string, int_target=int_target, & + has_value_target=has_value_target, altkey=key) + end if + end subroutine param_register_single_integer + + + ! Overloaded interface for registering parameter of type multiple integer + subroutine param_register_multiple_integer(dict, key, value, int_target_array, help_string, has_value_target, altkey) + type(Dictionary), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + integer, dimension(:), intent(inout), target :: int_target_array + character(len=*), intent(in) :: help_string + logical, intent(inout), optional, target :: has_value_target + character(len=*), intent(in), optional :: altkey + + call param_register_main(dict, key, value, size(int_target_array), PARAM_INTEGER,& + help_string=help_string, int_target_array=int_target_array, & + has_value_target=has_value_target, altkey=altkey) + if (present(altkey)) then + call param_register_main(dict, altkey, value, size(int_target_array), PARAM_INTEGER,& + help_string=help_string, int_target_array=int_target_array, & + has_value_target=has_value_target, altkey=key) + end if + + end subroutine param_register_multiple_integer + + + ! Overloaded interface for registering parameter of type single real + subroutine param_register_single_real(dict, key, value, real_target, help_string, has_value_target, altkey) + type(Dictionary), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + real(dp), intent(inout), target :: real_target + character(len=*), intent(in) :: help_string + logical, intent(inout), optional, target :: has_value_target + character(len=*), intent(in), optional :: altkey + + call param_register_main(dict, key, value, 1, PARAM_REAL, & + help_string=help_string, real_target=real_target, & + has_value_target=has_value_target, altkey=altkey) + if (present(altkey)) then + call param_register_main(dict, altkey, value, 1, PARAM_REAL, & + help_string=help_string, real_target=real_target, & + has_value_target=has_value_target, altkey=key) + end if + + end subroutine param_register_single_real + + + ! Overloaded interface for registering parameter of type multiple real + subroutine param_register_multiple_real(dict, key, value, real_target_array, help_string, has_value_target, altkey) + type(Dictionary), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + real(dp), dimension(:), intent(inout), target :: real_target_array + character(len=*), intent(in) :: help_string + logical, intent(inout), optional, target :: has_value_target + character(len=*), intent(in), optional :: altkey + + call param_register_main(dict, key, value, size(real_target_array), PARAM_REAL, & + help_string=help_string, real_target_array=real_target_array, & + has_value_target=has_value_target, altkey=altkey) + if (present(altkey)) then + call param_register_main(dict, altkey, value, size(real_target_array), PARAM_REAL,& + help_string=help_string, real_target_array=real_target_array, & + has_value_target=has_value_target, altkey=key) + end if + + end subroutine param_register_multiple_real + + + ! Overloaded interface for registering parameter of type single string + subroutine param_register_single_string(dict, key, value, char_target, help_string, has_value_target, altkey) + type(Dictionary), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + character(len=*), intent(inout), target :: char_target + character(len=*), intent(in) :: help_string + logical, intent(inout), optional, target :: has_value_target + character(len=*), intent(in), optional :: altkey + + if (len(char_target) /= STRING_LENGTH) & + call system_abort('param_register_single_string called for "'//trim(key)// & + '" has char_target(len='//len(char_target)//'), must be called with char_target(len=STRING_LENGTH)') + + + call param_register_main(dict, key, value, 1, PARAM_STRING, & + help_string=help_string, char_target=char_target, & + has_value_target=has_value_target, altkey=altkey) + if (present(altkey)) then + call param_register_main(dict, altkey, value, 1, PARAM_STRING, & + help_string=help_string, char_target=char_target, & + has_value_target=has_value_target, altkey=key) + end if + end subroutine param_register_single_string + + ! Overloaded interface for registering parameters which do not need parsing + subroutine param_register_dontread(dict, key, altkey) + type(Dictionary), intent(inout) :: dict + character(len=*), intent(in) :: key + character(len=*), intent(in), optional :: altkey + + call param_register_main(dict, key, '', 0, PARAM_NO_VALUE, help_string="NOT PARSED", altkey=altkey) + if (present(altkey)) then + call param_register_main(dict, altkey, '', 0, PARAM_NO_VALUE, help_string="NOT PARSED", altkey=key) + end if + end subroutine param_register_dontread + + + ! Helper routine called by all the registration interfaces + !%OMIT + subroutine param_register_main(dict, key, value, N, param_type, & + help_string, int_target, real_target, char_target, & + logical_target, int_target_array, real_target_array, has_value_target, altkey) + type(Dictionary), intent(inout) :: dict + + character(len=*), intent(in) :: key + character(len=*), intent(in) :: value + integer, intent(in) :: N, param_type + + character(len=*), intent(in) :: help_string + integer, intent(inout), optional, target :: int_target + integer, dimension(:), intent(inout), optional, target :: int_target_array + real(dp), intent(inout), optional, target :: real_target + real(dp), dimension(:), intent(inout), optional, target :: real_target_array + character(len=*), intent(inout), optional, target :: char_target + logical, intent(inout), optional, target :: logical_target + logical, intent(inout), optional, target :: has_value_target + character(len=*), intent(in), optional :: altkey + + type(ParamEntry) :: entry + type(DictData) :: data + + if (len_trim(value) > STRING_LENGTH) & + call system_abort("Param_Register: Value "//trim(value)//" too long") + + entry%value = value + entry%N = N + entry%param_type = param_type + + entry%help_string=trim(help_string) + + if(present(altkey)) then + entry%altkey = trim(altkey) + else + entry%altkey = '' + endif + +! call print("parser register entry " // trim(key) // " value " // trim(value), PRINT_ALWAYS) + + if (present(has_value_target)) then + entry%has_value => has_value_target + else + nullify(entry%has_value) + endif + + ! Check target type and size and set pointer to point to it + select case (param_type) + case(PARAM_NO_VALUE) + ! Do nothing + + case (PARAM_LOGICAL) + if (N == 1) then + if (present(logical_target)) then + entry%logical => logical_target + else + call system_abort('Param_Register: no target for single logical parameter') + endif + else + call system_abort('Param_Register: no support for logical array parameters') + endif + case (PARAM_INTEGER) + if (N == 1) then + if (present(int_target)) then + entry%integer => int_target + else + call system_abort('Param_Register: no target for single integer parameter') + end if + else + if (present(int_target_array)) then + if (size(int_target_array) == N) then + entry%integers => int_target_array + else + call system_abort('Param_Register: integer target array wrong size') + end if + else + call system_abort('Param_Register: no target for integer array parameter') + end if + end if + + case (PARAM_REAL) + if (N == 1) then + if (present(real_target)) then + entry%real => real_target + else + call system_abort('Param_Register: no target for single real parameter') + end if + else + if (present(real_target_array)) then + if (size(real_target_array) == N) then + entry%reals => real_target_array + else + call system_abort('Param_Register: real target array wrong size') + end if + else + call system_abort('Param_Register: no target for real array parameter') + end if + end if + + + case (PARAM_STRING) + if (N == 1) then + if (present(char_target)) then + entry%string => char_target + else + call system_abort('Param_Register: no target for single char parameter') + end if + else + call system_abort('Param_Register: multiple string param type not supported') + end if + + case default + write (line, '(a,i0)') 'Param_Register: unknown parameter type ', & + entry%param_type + call system_abort(line) + + end select + + ! Parse the default value string + if (.not. param_parse_value(entry)) then + call system_abort('Error parsing value '//trim(entry%value)) + end if + + ! Store the entry object in dictionary + allocate(data%d(size(transfer(entry,data%d)))) + data%d = transfer(entry,data%d) + call Set_Value(dict, key, data) + + end subroutine param_register_main + + + !% Read and parse line and update the key/value pairs stored by + !% in a Dictionary object. Returns false if an error is encountered parsing + !% the line. + function param_read_line(dict, myline, ignore_unknown, check_mandatory, task, did_help) result(status) + + type(Dictionary), intent(inout) :: dict !% Dictionary of registered key/value pairs + character(len=*), intent(in) :: myline !% Line to parse + logical, intent(in), optional :: ignore_unknown !% If true, ignore unknown keys in line + logical, intent(in), optional :: check_mandatory !% If true, check for missing mandatory parameters + character(len=*), intent(in), optional :: task + logical, intent(out), optional :: did_help + logical :: status + + character(len=STRING_LENGTH) :: field + integer equal_pos + character(len=STRING_LENGTH), dimension(:), allocatable :: final_fields + character(len=STRING_LENGTH) :: key, value + integer :: i, num_pairs + type(ParamEntry) :: entry + type(DictData) :: data + logical :: my_ignore_unknown + integer :: entry_i + logical, allocatable :: my_has_value(:) + logical :: my_check_mandatory + + my_ignore_unknown=optional_default(.false., ignore_unknown) + my_check_mandatory=optional_default(.true., check_mandatory) + + allocate(final_fields(MAX_N_FIELDS)) + + if(present(did_help)) did_help = .false. + + call split_string(myline," ,","''"//'""'//'{}', final_fields, num_pairs, matching=.true.) + + allocate(data%d(size(transfer(entry,data%d)))) + + allocate(my_has_value(dict%N)) + my_has_value = .false. + + ! zero out has_value pointers for entire dictionary + do i=1, dict%N + entry = transfer(dict%entries(i)%d%d,entry) + if (associated(entry%has_value)) then + entry%has_value = .false. + endif + end do + + if (present(task)) then + call print("parser doing "//trim(task), PRINT_VERBOSE) + else + call print("parser doing UNKNOWN", PRINT_VERBOSE) + endif + call print("parser input line: <"//trim(myline)//">", PRINT_VERBOSE) + ! Set the new entries + do i=1,num_pairs + field = final_fields(i) + equal_pos = index(trim(field),'=') + if (equal_pos == 0) then + key=field + value='' + else if (equal_pos == 1) then + call system_abort("Malformed field '"//trim(field)//"'") + else if (equal_pos == len(trim(field))) then + key = field(1:equal_pos-1) + value = '' + else + key = field(1:equal_pos-1) + value = field(equal_pos+1:len(trim(field))) + endif + call print("param_read_line key='"//trim(key)//"' value='"//trim(value)//"'", PRINT_NERD) + if (len_trim(value) > STRING_LENGTH) then + call print("param_read_line: value "//trim(value)//" too long") + status = .false. + return + end if + + if (trim(key) == "--help") then + if(present(did_help)) did_help = .true. + call param_print_help(dict) + cycle + endif + + ! Extract this value + if (.not. get_value(dict, key, data, i=entry_i)) then + if (.not. my_ignore_unknown) then + call print("param_read_line: unknown key "//trim(key)) + status = .false. + return + endif + else + entry = transfer(data%d,entry) + entry%value = value + my_has_value(entry_i) = .true. + if (associated(entry%has_value)) then + entry%has_value = .true. + endif + call print ("parser got: " // trim(paramentry_write_string(key, entry)), PRINT_VERBOSE) + if (equal_pos == 0) then + status = param_parse_value(entry, key) + else + status = param_parse_value(entry) + endif + if (.not. status) then + call Print('Error parsing value '//trim(entry%value)) + return + end if + + ! Put it back in dict + data%d = transfer(entry,data%d) + call set_value(dict,key,data) + end if + end do + + if (current_verbosity() >= PRINT_VERBOSE) then + do i=1, dict%N + entry = transfer(dict%entries(i)%d%d,entry) + if (.not. my_has_value(i)) then + call print ("parser defaulted: "//trim(paramentry_write_string(string(dict%keys(i)),entry)), PRINT_VERBOSE) + endif + end do + endif + + if (allocated(data%d)) deallocate(data%d) + status = .true. ! signal success to caller + + if (my_check_mandatory) status = param_check(dict) + if(allocated(final_fields)) deallocate(final_fields) + + end function param_read_line + + + !% Read lines from Inoutput object 'file', in format 'key = value' and set + !% entries in the Dictionary 'dict'. Skips lines starting with a '#'. If + !% 'check_mandatory' is true then finish by checking if all mandatory values have + !% been specified. Returns false if there was a problem reading the file, or + !% if the check for mandatory parameters fails. + function param_read_file(dict, file, check_mandatory,task) result(status) + type(Dictionary), intent(inout) :: dict !% Dictionary of registered key/value pairs + type(Inoutput), intent(in) :: file !% File to read from + logical, intent(in), optional :: check_mandatory !% Should we check if all mandatory parameters have been given + character(len=*), intent(in), optional :: task + logical :: status + + integer :: file_status + character(STRING_LENGTH) :: myline + logical :: my_check_mandatory + + my_check_mandatory=optional_default(.true., check_mandatory) + + do + myline = read_line(file, file_status) + if (file_status /= 0) exit ! Check for end of file + ! Discard empty and comment lines, otherwise parse the line + if (len_trim(myline) > 0 .and. myline(1:1) /= '#') then + status = param_read_line(dict, myline, task=task) + if (.not. status) then + call print('Error reading line: '//myline) + return + end if + end if + end do + + status = .true. + ! Should we check if all mandatory params have been specified? + if (my_check_mandatory) status = param_check(dict) + + end function param_read_file + + + !% Read 'key = value' pairs from command line and set entries in this + !% 'dict'. Array 'args' is a list of the indices of command line + !% arguments that we should look at, in order, if it's not given we look + !% at all arguments. Returns false if fails, or if optional check that + !% all mandatory values have been specified fails. + function param_read_args(dict, args, check_mandatory,ignore_unknown,task,command_line, did_help) result(status) + type(Dictionary), intent(inout) :: dict !% Dictionary of registered key/value pairs + integer, dimension(:), intent(in), optional :: args !% Argument indices to use + logical, intent(in), optional :: check_mandatory !% Should we check if all mandatory parameters have been given + logical, intent(in), optional :: ignore_unknown !% If true, ignore unknown keys in line + character(len=*), intent(in), optional :: task + character(len=*), intent(out), optional :: command_line + logical, intent(out), optional :: did_help + logical :: status + + integer :: i, nargs + character(len=STRING_LENGTH) :: this_arg + character(len=STRING_LENGTH) :: my_command_line + integer, dimension(:), allocatable :: xargs + logical :: my_ignore_unknown + integer :: eq_loc, this_len + logical :: my_check_mandatory + + my_ignore_unknown=optional_default(.false., ignore_unknown) + my_check_mandatory=optional_default(.true., check_mandatory) + + nargs = cmd_arg_count() + + ! If args was specified, make a local copy of it + ! Otherwise make a list of all command line arguments + if (present(args)) then + allocate(xargs(size(args))) + xargs = args + else + + allocate(xargs(nargs)) + xargs = (/ (i, i=1,size(xargs)) /) + end if + + ! Concatentate command line options into one string + my_command_line = '' + do i=1, size(xargs) + call get_cmd_arg(xargs(i), this_arg) + if (index(trim(this_arg),' ') /= 0) then + if (index(trim(this_arg),'=') /= 0) then + eq_loc = index(trim(this_arg),'=') + this_len = len_trim(this_arg) + if (scan(this_arg(eq_loc+1:eq_loc+1),"'{"//'"') <= 0) then + my_command_line = trim(my_command_line)//' '//this_arg(1:eq_loc)//'"'//this_arg(eq_loc+1:this_len)//'"' + else + my_command_line = trim(my_command_line)//' '//trim(this_arg) + endif + else + if (scan(this_arg(1:1),"{'"//'"') <= 0) then + my_command_line = trim(my_command_line)//' "'//trim(this_arg)//'"' + else + my_command_line = trim(my_command_line)//' '//trim(this_arg) + endif + endif + else + my_command_line = trim(my_command_line)//' '//trim(this_arg) + endif + end do + + call print("param_read_args got command_line '"//trim(my_command_line)//"'", PRINT_VERBOSE) + ! Free local copy before there's a chance we return + deallocate(xargs) + + ! Then parse this string, and return success or failure + status = param_read_line(dict, my_command_line,ignore_unknown=my_ignore_unknown, task=task, did_help=did_help) + if (.not. status) return + + status = .true. + ! Should we check if all mandatory params have been specified? + if (my_check_mandatory) status = param_check(dict) + + if(present(command_line)) command_line = trim(my_command_line) + + end function param_read_args + + + !% Process command line by looking for arguments in 'key=value' form and + !% parsing their values into 'dict'. Non option arguments + !% are returned in the array non_opt_args. Optionally check that + !% all mandatory parameters have been specified. + function process_arguments(dict, non_opt_args, n_non_opt_args, check_mandatory, task) result(status) + type(Dictionary) :: dict !% Dictionary of registered key/value pairs + character(len=*), dimension(:), intent(out) :: non_opt_args !% On exit, contains non option arguments + integer, intent(out) :: n_non_opt_args !% On exit, number of non option arguments + logical, intent(in), optional :: check_mandatory !% Should we check if all mandatory parameters have been given + character(len=*), intent(in), optional :: task + logical :: status + + character(len=255) :: args(100) + character(len=1000) :: options + type(Table) :: opt_inds + integer :: start, end, i, j, eqpos, n_args + logical :: my_check_mandatory + + n_args = cmd_arg_count() + if (n_args > size(args)) call system_abort('Too many command line arguments') + + my_check_mandatory=optional_default(.true., check_mandatory) + + ! Read command line args into array args + do i=1,n_args + call get_cmd_arg(i, args(i)) + end do + + ! Find the key=value pairs, skipping over non-option arguments + call allocate(opt_inds, 1, 0, 0, 0) + i = 1 + do + eqpos = scan(args(i), '=') + + if (eqpos == 0) then + i = i + 1 + if (i > n_args) exit + cycle ! Skip non option arguments + else if (eqpos == 1) then + ! Starts with '=', so previous argument is key name + if (i == 1) call system_abort('Missing option name in command line arguments') + start = i-1 + else if (eqpos > 1) then + ! Contains '=' but not at start so key name is in this arg + start = i + end if + end = i + + ! If last character of arg is '=' then value must be in next argument + eqpos = len_trim(args(i)) + if (args(i)(eqpos:eqpos) == '=') then + end = end + 1 + end if + + ! Get whole of quoted string + if (scan(args(end), '"''') /= 0) then + do + end = end + 1 + if (end > n_args) & + call system_abort('Mismatched quotes in command line arguments') + if (scan(args(end), '"''') /= 0) exit + end do + end if + + ! Add the indices of the arguments that make up this key/value pair + call append(opt_inds, (/ (j, j=start,end )/)) + + i = end + 1 + if (i > n_args) exit + end do + + ! Concatenate args and parse line + options = '' + do i=1,opt_inds%N + options = trim(options)//' '//trim(args(opt_inds%int(1,i))) + end do + status = param_read_line(dict, options, task=task) + if (.not. status) return + + status = .true. + ! Should we check if all mandatory params have been specified? + if (my_check_mandatory) status = param_check(dict) + + ! Find and return the non-option arguments + n_non_opt_args = 0 + do i=1,n_args + if (Find(opt_inds, i) == 0) then + n_non_opt_args = n_non_opt_args + 1 + if (n_non_opt_args > size(non_opt_args)) call system_abort('Too many non option arguments') + + non_opt_args(n_non_opt_args) = args(i) + end if + end do + + call finalise(opt_inds) + + end function process_arguments + + + !% Print key/value pairs. + subroutine param_print(dict, verbosity, out) + type(Dictionary), intent(in) :: dict !% Dictionary of registered key/value pairs + integer, intent(in), optional :: verbosity + type(Inoutput), intent(inout), optional :: out + + type(ParamEntry) :: entry + integer :: i + + type(DictData) :: data + allocate(data%d(size(transfer(entry,data%d)))) + + do i=1,dict%N + if (.not. get_value(dict, string(dict%keys(i)), data)) & + call system_abort('param_print: Key '//string(dict%keys(i))//' missing') + entry = transfer(data%d,entry) + ! Print value in quotes if it contains any spaces + if (index(trim(entry%value), ' ') /= 0) then + write (line, '(a,a,a,a)') & + string(dict%keys(i)), ' = "', trim(entry%value),'" ' + else + write (line, '(a,a,a,a)') & + string(dict%keys(i)), ' = ', trim(entry%value), ' ' + end if + call print(line,verbosity,out) + end do + + deallocate(data%d) + + end subroutine param_print + + subroutine param_print_help(dict, verbosity, out) + type(Dictionary), intent(in) :: dict !% Dictionary of registered key/value pairs + integer, intent(in), optional :: verbosity + type(Inoutput), intent(inout), optional :: out + + type(ParamEntry) :: entry + integer :: i + + type(DictData) :: data + character(len=10) type_str, param_dim_str + character(len=STRING_LENGTH) out_line + + allocate(data%d(size(transfer(entry,data%d)))) + + do i=1,dict%N + if (.not. get_value(dict, string(dict%keys(i)), data)) & + call system_abort('param_print: Key '//string(dict%keys(i))//' missing') + entry = transfer(data%d,entry) + + out_line=string(dict%keys(i)//" type=") + + param_dim_str = "unknown" + select case(entry%param_type) + case(PARAM_NO_VALUE) + out_line=trim(out_line)//"NO_VALUE" + case(PARAM_REAL) + out_line=trim(out_line)//"REAL" + if (associated(entry%real)) then + out_line=trim(out_line)//" scalar" + elseif (associated(entry%reals)) then + out_line=trim(out_line)//" dim="//size(entry%reals) + else + out_line=trim(out_line)//" ERROR-no-value-pointer-associated" + endif + case(PARAM_INTEGER) + out_line=trim(out_line)//"INTEGER" + if (associated(entry%integer)) then + out_line=trim(out_line)//" scalar" + elseif (associated(entry%integers)) then + out_line=trim(out_line)//" dim="//size(entry%integers) + else + out_line=trim(out_line)//" ERROR-no-value-pointer-associated" + endif + case(PARAM_STRING) + out_line=trim(out_line)//"STRING" + if (associated(entry%string)) then + out_line=trim(out_line)//" scalar" + else + out_line=trim(out_line)//" ERROR-no-value-pointer-associated" + endif + case(PARAM_LOGICAL) + out_line=trim(out_line)//"LOGICAL" + if (associated(entry%logical)) then + out_line=trim(out_line)//" scalar" + else + out_line=trim(out_line)//" ERROR-no-value-pointer-associated" + endif + case default + call system_abort("Unknown param_type "//entry%param_type//" for key " //string(dict%keys(i))) + end select + + ! Print value in quotes if it contains any spaces + if (index(trim(entry%value), ' ') /= 0) then + out_line=trim(out_line)//" current_value='"//trim(entry%value)//"'" + else + out_line=trim(out_line)//" current_value="//trim(entry%value) + end if + call print(trim(out_line), verbosity=PRINT_ALWAYS, file=out) + + call print(linebreak_string(trim(entry%help_string), 80), verbosity=PRINT_ALWAYS, file=out) + + call print("", verbosity=PRINT_ALWAYS, file=out) + end do + + deallocate(data%d) + + end subroutine param_print_help + + function paramentry_write_string(key,entry) result(s) + character(len=*) :: key + type(ParamEntry), intent(in) :: entry + character(len=STRING_LENGTH) :: s + + ! Print value in brackets if it contains any spaces + if (index(trim(entry%value), ' ') /= 0) then + write (s, '(a,a,a,a)') & + trim(key), '={', trim(entry%value),'} ' + else + if (len(trim(entry%value)) == 0 .and. entry%param_type == PARAM_LOGICAL) then + write (s, '(a,a,a,a)') & + trim(key), '=', 'T', ' ' + else + write (s, '(a,a,a,a)') & + trim(key), '=', trim(entry%value), ' ' + endif + end if + end function paramentry_write_string + + !% Return string representation of param dictionary, i.e. + !% 'key1=value1 key2=value2 quotedkey="quoted value"' + function param_write_string(dict) result(s) + type(Dictionary), intent(in) :: dict !% Dictionary of registered key/value pairs + character(STRING_LENGTH) :: s + + type(ParamEntry) :: entry + integer :: i + + type(DictData) :: data + allocate(data%d(size(transfer(entry,data%d)))) + + s="" + do i=1,dict%N + if (.not. get_value(dict, string(dict%keys(i)), data)) & + call system_abort('param_print: Key '//string(dict%keys(i))//' missing') + entry = transfer(data%d,entry) + s = trim(s)//trim(paramentry_write_string(string(dict%keys(i)),entry)) + end do + + deallocate(data%d) + + end function param_write_string + + + ! Parse the value according to its param_type and number of values + ! and set the targets to the values read. Called by Register and ReadLine + !%OMIT + function param_parse_value(entry, key) result(status) + type(ParamEntry) :: entry + character(len=*), optional :: key + logical :: status + + character(len=STRING_LENGTH), dimension(:), allocatable :: fields + integer :: num_fields, j + + allocate(fields(MAX_N_FIELDS)) + + if (entry%param_type == PARAM_NO_VALUE .or. & + trim(entry%value) == PARAM_MANDATORY) then + status = .true. + return + end if + + call parse_string(entry%value, ' ', fields, num_fields) + + ! jrk33 - commented out these lines as they stop zero length string + ! values from setting the associated target to an empty string, and + ! I can't think what good they do! +!!$ if (num_fields == 0 .and. entry%param_type /= PARAM_LOGICAL) then +!!$ status = .true. +!!$ return +!!$ end if + + if ((entry%param_type == PARAM_LOGICAL .and. num_fields /= 0 .and. num_fields /= entry%N) .or. & + (entry%param_type /= PARAM_STRING .and. entry%param_type /= PARAM_LOGICAL .and. num_fields /= entry%N) ) then + write (line, '(a,a,a)') 'Param_ParseValue: Number of value fields wrong: ', & + trim(entry%value) + call print(line) + status = .false. + return + end if + + select case(entry%param_type) + case (PARAM_LOGICAL) + if (entry%N == 1) then + if (num_fields == 0) then + entry%logical = .true. + else + entry%logical = String_to_Logical(fields(1)) + endif + else + call system_abort("param_parse_value no support for logical array yet") + end if + + case (PARAM_INTEGER) + if (entry%N == 1) then + entry%integer = String_to_Int(fields(1)) + else + do j=1,num_fields + entry%integers(j) = String_to_Int(fields(j)) + end do + end if + + case (PARAM_REAL) + if (entry%N == 1) then + entry%real = String_to_Real(fields(1)) + else + do j=1,num_fields + entry%reals(j) = String_to_Real(fields(j)) + end do + end if + + case (PARAM_STRING) + if (num_fields == 0 .and. present(key)) then + entry%string = trim(key) + else + entry%string = trim(entry%value) + endif + + case default + write (line, '(a,i0)') 'Param_ParseValue: unknown parameter type ', & + entry%param_type + call print(line) + status = .false. + return + end select + + if(allocated(fields)) deallocate(fields) + status = .true. + + end function param_parse_value + + + !% Explicity check if all mandatory values have now been specified + !% Returns true or false accordingly. Optionally return the list + !% of missing keys as a string. + function param_check(dict, missing_keys) result(status) + type(Dictionary), intent(in) :: dict !% Dictionary of registered key/value pairs + character(len=*), intent(out), optional :: missing_keys !% On exit, string list of missing mandatory keys, + !% separated by spaces. + logical :: status + integer :: i + type(ParamEntry) :: entry, altentry + type(DictData) :: data, altdata + logical :: valuemissing, altpresent, altvaluemissing + allocate(data%d(size(transfer(entry,data%d)))) + + if (present(missing_keys)) missing_keys = '' + + status = .true. + do i=1,dict%N + if (.not. get_value(dict, string(dict%keys(i)), data)) & + call system_abort('Param_Check: Key '//string(dict%keys(i))//' missing') + entry = transfer(data%d,entry) + + if (trim(entry%value) == PARAM_MANDATORY) then + valuemissing = .true. + else + valuemissing = .false. + endif + + ! see if we have an altkey for this key + if (entry%altkey /= '') then + altpresent = .true. + if (.not. get_value(dict, entry%altkey, altdata)) & + call system_abort('Param_Check: Key '//entry%altkey//' missing') + + altentry = transfer(altdata%d, altentry) + + if (trim(altentry%value) == PARAM_MANDATORY) then + altvaluemissing = .true. + else + altvaluemissing = .false. + endif + else + altpresent = .false. + altvaluemissing = .false. + endif + + ! now check for missing values, taking into account check of altentry + if (valuemissing .and. (.not. altpresent .or. (altpresent .and. altvaluemissing ))) then + status = .false. + if (present(missing_keys)) then + missing_keys = trim(missing_keys)//' '//string(dict%keys(i)) + else + call print('missing mandatory parameter '//string(dict%keys(i))) + endif + end if + end do + + deallocate(data%d) + + end function param_check + +#ifdef POINTER_COMPONENT_MANUAL_COPY + subroutine ParamEntry_assign(to, from) + type(ParamEntry) :: to, from + + to%value = from%value + to%N = from%N + to%param_type = from%param_type + to%real => from%real + to%integer => from%integer + to%logical => from%logical + to%string => from%string + to%reals => from%reals + to%integers => from%integers + + to%has_value => from%has_value + end subroutine ParamEntry_assign +#endif + +end module paramreader_module diff --git a/src/libAtoms/PeriodicTable.F90 b/src/libAtoms/PeriodicTable.F90 new file mode 100644 index 0000000000..cc8dec6333 --- /dev/null +++ b/src/libAtoms/PeriodicTable.F90 @@ -0,0 +1,204 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Periodic Table module +!X +!% This module contains a list of elements, their masses and covalent radii. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module periodictable_module + +use system_module ! for definition of real(dp) +use units_module +! +! The Periodic Table +! + +implicit none +private + +public :: ElementName, ElementMass, ElementValence, ElementCovRad, atomic_number, atomic_number_from_symbol, atomic_number_from_mass, & + total_elements + +integer, parameter :: total_elements = 118 + +! IUPAC 2017 element symbols +character(3),parameter,dimension(0:total_elements) :: ElementName = (/"xx ", & + "H ","He ", & + "Li ","Be ","B ","C ","N ","O ","F ","Ne ", & + "Na ","Mg ","Al ","Si ","P ","S ","Cl ","Ar ", & + "K ","Ca ","Sc ","Ti ","V ","Cr ","Mn ","Fe ","Co ","Ni ","Cu ","Zn ","Ga ","Ge ","As ","Se ","Br ","Kr ", & + "Rb ","Sr ","Y ","Zr ","Nb ","Mo ","Tc ","Ru ","Rh ","Pd ","Ag ","Cd ","In ","Sn ","Sb ","Te ","I ","Xe ", & + "Cs ","Ba ","La ","Ce ","Pr ","Nd ","Pm ","Sm ","Eu ","Gd ","Tb ","Dy ","Ho ","Er ","Tm ","Yb ","Lu ","Hf ", & + "Ta ","W ","Re ","Os ","Ir ","Pt ","Au ","Hg ","Tl ","Pb ","Bi ","Po ","At ","Rn ", & + "Fr ","Ra ","Ac ","Th ","Pa ","U ","Np ","Pu ","Am ","Cm ","Bk ","Cf ","Es ","Fm ","Md ","No ","Lr ","Rf ", & + "Db ","Sg ","Bh ","Hs ","Mt ","Ds ","Rg ","Cn ","Nh ","Fl ","Mc ","Lv ","Ts ","Og " & + /) !% Mapping of atomic number to element name + + +! Units: grams per Mole * MASSCONVERT (conforming to eV,A,fs system) +#ifdef LEGACY_MASSES +! Masses for pre-2017 code. Many of these have been updated, but some code may depend on these +! values. If used, tests will fail. +real(dp),parameter,dimension(total_elements) :: ElementMass = & +(/1.00794, 4.00260, 6.941, 9.012187, 10.811, 12.0107, 14.00674, 15.9994, 18.99840, 20.1797, 22.98977, & +24.3050, 26.98154, 28.0855, 30.97376, 32.066, 35.4527, 39.948, 39.0983, 40.078, 44.95591, 47.867, & +50.9415, 51.9961, 54.93805, 55.845, 58.93320, 58.6934, 63.546, 65.39, 69.723, 72.61, 74.92160, 78.96, & +79.904, 83.80, 85.4678, 87.62, 88.90585, 91.224, 92.90638, 95.94, 98.0, 101.07, 102.90550, 106.42, & +107.8682, 112.411, 114.818, 118.710, 121.760, 127.60, 126.90447, 131.29, 132.90545, 137.327, 138.9055, & +140.116, 140.90765, 144.24, 145.0, 150.36, 151.964, 157.25, 158.92534, 162.50, 164.93032, 167.26, & +168.93421, 173.04, 174.967, 178.49, 180.9479, 183.84, 186.207, 190.23, 192.217, 195.078, 196.96655, & +200.59, 204.3833, 207.2, 208.98038, 209.0, 210.0, 222.0, 223.0, 226.0, 227.0, 232.0381, 231.03588, & +238.0289, 237.0, 244.0, 243.0, 247.0, 247.0, 251.0, 252.0, 257.0, 258.0, 259.0, 262.0, 261.0, 262.0, & +263.0, 264.0, 265.0, 268.0, 271.0, 272.0, 285.0, 284.0, 289.0, 288.0, 292.0, 293.0, 294.0/)*MASSCONVERT +#else +! IUPAC2016 masses from: +! Meija, J., Coplen, T., Berglund, M., et al. (2016). Atomic weights of +! the elements 2013 (IUPAC Technical Report). Pure and Applied Chemistry, +! 88(3), pp. 265-291. Retrieved 30 Nov. 2016, +! from doi:10.1515/pac-2015-0305 +! Consistent with ase 3.14 onwards +real(dp),parameter,dimension(total_elements) :: ElementMass = (/ & +1.008_dp,4.002602_dp,6.94_dp,9.0121831_dp,10.81_dp,12.011_dp,14.007_dp,15.999_dp,18.998403163_dp, & +20.1797_dp,22.98976928_dp,24.305_dp,26.9815385_dp,28.085_dp,30.973761998_dp,32.06_dp,35.45_dp, & +39.948_dp,39.0983_dp,40.078_dp,44.955908_dp,47.867_dp,50.9415_dp,51.9961_dp,54.938044_dp,55.845_dp, & +58.933194_dp,58.6934_dp,63.546_dp,65.38_dp,69.723_dp,72.63_dp,74.921595_dp,78.971_dp,79.904_dp, & +83.798_dp,85.4678_dp,87.62_dp,88.90584_dp,91.224_dp,92.90637_dp,95.95_dp,97.90721_dp,101.07_dp, & +102.9055_dp,106.42_dp,107.8682_dp,112.414_dp,114.818_dp,118.71_dp,121.76_dp,127.6_dp,126.90447_dp, & +131.293_dp,132.90545196_dp,137.327_dp,138.90547_dp,140.116_dp,140.90766_dp,144.242_dp,144.91276_dp, & +150.36_dp,151.964_dp,157.25_dp,158.92535_dp,162.5_dp,164.93033_dp,167.259_dp,168.93422_dp,173.054_dp, & +174.9668_dp,178.49_dp,180.94788_dp,183.84_dp,186.207_dp,190.23_dp,192.217_dp,195.084_dp,196.966569_dp,& +200.592_dp,204.38_dp,207.2_dp,208.9804_dp,208.98243_dp,209.98715_dp,222.01758_dp,223.01974_dp, & +226.02541_dp,227.02775_dp,232.0377_dp,231.03588_dp,238.02891_dp,237.04817_dp,244.06421_dp, & +243.06138_dp,247.07035_dp,247.07031_dp,251.07959_dp,252.083_dp,257.09511_dp,258.09843_dp,259.101_dp, & +262.11_dp,267.122_dp,268.126_dp,271.134_dp,270.133_dp,269.1338_dp,278.156_dp,281.165_dp,281.166_dp, & +285.177_dp,286.182_dp,289.19_dp,289.194_dp,293.204_dp,293.208_dp,294.214_dp /)*MASSCONVERT +!% Element mass in grams per Mole $\times$ 'MASSCONVERT' (conforming to eV,\AA,fs unit system). +#endif + +! Units: Angstroms + +real(dp),parameter,dimension(total_elements) :: ElementCovRad = & +(/0.320,0.310,1.630,0.900,0.820,0.770,0.750,0.730,0.720,0.710,1.540,1.360,1.180,1.110,1.060,1.020, & +0.990,0.980,2.030,1.740,1.440,1.320,1.220,1.180,1.170,1.170,1.160,1.150,1.170,1.250,1.260,1.220,1.200, & +1.160,1.140,1.120,2.160,1.910,1.620,1.450,1.340,1.300,1.270,1.250,1.250,1.280,1.340,1.480,1.440,1.410, & +1.400,1.360,1.330,1.310,2.350,1.980,1.690,1.650,1.650,1.840,1.630,1.620,1.850,1.610,1.590,1.590,1.580, & +1.570,1.560,2.000,1.560,1.440,1.340,1.300,1.280,1.260,1.270,1.300,1.340,1.490,1.480,1.470,1.460,1.460, & +2.000,2.000,2.000,2.000,2.000,1.650,2.000,1.420,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000, & +2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000,2.000/) +!% Covalent radii in \AA. + +integer,parameter,dimension(total_elements) :: ElementValence = & +(/1,-1, 1, 2, 3, 4, 3, 2, 1,-1, 1, 2, 3, 4, 3, 2, & + 1,-1, 1, 2,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & + -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, & + -1,-1,-1,-1,-1,-1/) + + +interface atomic_number + !% Do a reverse lookup of atomic number from either symbol or mass + module procedure atomic_number_from_symbol, atomic_number_from_mass +end interface atomic_number + +contains + + !Look up the atomic number for a given atomic symbol + elemental function atomic_number_from_symbol(atomic_symbol) + character(*), intent(in) :: atomic_symbol + integer :: atomic_number_from_symbol + integer :: i + + if (verify(trim(adjustl(atomic_symbol)),"0123456789") == 0) then ! an integer + read (atomic_symbol, *) atomic_number_from_symbol + if (atomic_number_from_symbol < 1 .or. atomic_number_from_symbol > size(ElementName)) then + atomic_number_from_symbol = 0 + endif + return + else ! not an integer, hopefully an element abbreviation + do i = 1, total_elements + if (trim(lower_case(adjustl(atomic_symbol)))==trim(lower_case(ElementName(i)))) then + atomic_number_from_symbol = i + return + end if + end do + end if + + !If unsuccessful, return 0 + atomic_number_from_symbol = 0 + + end function atomic_number_from_symbol + + !Look up the atomic number for a given atomic mass (IN GRAMS PER MOLE) + !Note: this may fail for some of the transuranic elements... + !so put those ununpentium simulations on hold for a while ;-) + function atomic_number_from_mass(atomic_mass) + real(dp), intent(in) :: atomic_mass + integer :: atomic_number_from_mass + integer :: i + real(dp), parameter :: TOL = 0.01_dp + + do i = 1, total_elements + if (abs(atomic_mass - ElementMass(i)/MASSCONVERT) < TOL) then + atomic_number_from_mass = i + return + end if + end do + + !If unsuccessful, return 0 + atomic_number_from_mass = 0 + + end function atomic_number_from_mass + + !ElementName formatting, used by atoms_read_xyz + !First leter uppercase, others lowercase + function ElementFormat(lower_UPPER) result(UPPER_lower) + character(*), intent(in) :: lower_UPPER + character(len=len_trim(lower_UPPER)) :: UPPER_lower + character(len=*), parameter :: lc = 'abcdefghijklmnopqrstuvwxyz', & + UC = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + integer :: i,j + + UPPER_lower = lower_UPPER + j = index(lc,lower_UPPER(1:1)) + if (j>0) UPPER_lower(1:1) = UC(j:j) + do i = 2, len_trim(lower_UPPER) + j = index(UC,lower_UPPER(i:i)) + if (j>0) UPPER_lower(i:i) = lc(j:j) + enddo + + end function ElementFormat + +end module periodictable_module diff --git a/src/libAtoms/Quaternions.F90 b/src/libAtoms/Quaternions.F90 new file mode 100644 index 0000000000..9d5bf808ab --- /dev/null +++ b/src/libAtoms/Quaternions.F90 @@ -0,0 +1,782 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!% Implementation of quaternion algebra. Primarily for use with +!% rigid body dynamics, although the 'Orientation', 'Rotation' +!% and 'Rotate' routines can be useful in many other situations. +!% +!% \begin{displaymath} +!% \begin{array}{c} +!% i^2 = j^2 = k^2 = ijk = -1 \\ ij = k \quad jk = i \quad ki = j +!% \end{array} +!% \end{displaymath} + +module quaternions_module + + use system_module ! for dp + use units_module ! for PI + use linearalgebra_module ! for .feq./.fne + + implicit none + private + + public :: quaternion, initialise, finalise, print + public :: rotate, rotation, rotation_matrix, orientation, assignment(=) + public :: rotation_parameters + public :: operator(.dot.), operator(*), operator(+), operator(.conj.) + + type Quaternion + + real(dp) :: a = 0.0_dp ! + real(dp) :: b = 0.0_dp ! + real(dp) :: c = 0.0_dp ! = a*1 + b*i + c*j + d*k + real(dp) :: d = 0.0_dp ! + + end type Quaternion + + private :: quaternion_initialise + interface initialise + module procedure quaternion_initialise + end interface initialise + + private :: quaternion_finalise + interface finalise + module procedure quaternion_finalise + end interface finalise + + private :: quaternion_norm + interface norm + module procedure quaternion_norm + end interface norm + + private :: quaternion_normsq + interface normsq + module procedure quaternion_normsq + end interface normsq + + private :: quat_plus_quat, quat_plus_vect + interface operator(+) + module procedure quat_plus_quat, quat_plus_vect + end interface + + private :: quat_minus_quat, quat_minus_vect + interface operator(-) + module procedure quat_minus_quat, quat_minus_vect + end interface + + private :: quat_mult_real, quat_mult_quat, real_mult_quat + interface operator(*) + module procedure quat_mult_real, quat_mult_quat, real_mult_quat + end interface + + private :: quat_divide_real, quat_divide_quat + interface operator(/) + module procedure quat_divide_real, quat_divide_quat + end interface + + private :: quat_assign_vect, vect_assign_quat, quat_assign_real + interface assignment(=) + module procedure quat_assign_vect, vect_assign_quat, quat_assign_real + end interface + + private :: quaternion_conjugate + interface operator(.conj.) + module procedure quaternion_conjugate + end interface + + private :: quat_eq_quat, quat_eq_vect + interface operator(.feq.) + module procedure quat_eq_quat, quat_eq_vect + end interface + + private :: quat_ne_quat, quat_ne_vect + interface operator(.fne.) + module procedure quat_ne_quat, quat_ne_vect + end interface + + private :: quat_dot_quat + interface operator(.dot.) + module procedure quat_dot_quat + end interface + + private :: rotate_vect, rotate_quat + interface rotate + module procedure rotate_vect, rotate_quat + end interface rotate + + private :: quaternion_print + interface print + module procedure quaternion_print + end interface print + +contains + + subroutine quaternion_initialise(this, a, b, c, d) + type(Quaternion), intent(out) :: this + real(dp), intent(in), optional :: a, b, c, d + + this%a = optional_default(0.0_dp, a) + this%b = optional_default(0.0_dp, b) + this%c = optional_default(0.0_dp, c) + this%d = optional_default(0.0_dp, d) + + end subroutine quaternion_initialise + + subroutine quaternion_finalise(this) + type(Quaternion), intent(inout) :: this + + this%a = 0.0_dp + this%b = 0.0_dp + this%c = 0.0_dp + this%d = 0.0_dp + + end subroutine quaternion_finalise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X Assignment + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine quat_assign_vect(this,vect) + + type(Quaternion), intent(out) :: this + real(dp), dimension(:), intent(in) :: vect + + select case(size(vect)) + + case(3) + this%a = 0.0_dp + this%b = vect(1) + this%c = vect(2) + this%d = vect(3) + + case(4) + this%a = vect(1) + this%b = vect(2) + this%c = vect(3) + this%d = vect(4) + + case default + call system_abort('Quat_Assign_Vect: Vector must have 3 or 4 components') + + end select + + end subroutine quat_assign_vect + + subroutine vect_assign_quat(vect,q) + + real(dp), dimension(:), intent(out) :: vect + type(Quaternion), intent(in) :: q + + select case(size(vect)) + + case(3) + vect = (/q%b,q%c,q%d/) + + case(4) + vect = (/q%a,q%b,q%c,q%d/) + + case default + call system_abort('Vect_Assign_Quat: Vector must have 3 or 4 components') + + end select + + end subroutine vect_assign_quat + + subroutine quat_assign_real(q,r) + + type(Quaternion), intent(out) :: q + real(dp), intent(in) :: r + + q%a = r + q%b = 0.0_dp + q%c = 0.0_dp + q%d = 0.0_dp + + end subroutine quat_assign_real + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X Simple arithmetic + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function quat_plus_quat(q1,q2) result(res) + + type(Quaternion), intent(in) :: q1,q2 + type(Quaternion) :: res + + res%a = q1%a + q2%a + res%b = q1%b + q2%b + res%c = q1%c + q2%c + res%d = q1%d + q2%d + + end function quat_plus_quat + + function quat_plus_vect(q,v) result(res) + + type(Quaternion), intent(in) :: q + real(dp), dimension(4), intent(in) :: v + type(Quaternion) :: res + + res%a = q%a + v(1) + res%b = q%b + v(2) + res%c = q%c + v(3) + res%d = q%d + v(4) + + end function quat_plus_vect + + function quat_minus_quat(q1,q2) result(res) + + type(Quaternion), intent(in) :: q1,q2 + type(Quaternion) :: res + + res%a = q1%a - q2%a + res%b = q1%b - q2%b + res%c = q1%c - q2%c + res%d = q1%d - q2%d + + end function quat_minus_quat + + function quat_minus_vect(q,v) result(res) + + type(Quaternion), intent(in) :: q + real(dp), dimension(4), intent(in) :: v + type(Quaternion) :: res + + res%a = q%a - v(1) + res%b = q%b - v(2) + res%c = q%c - v(3) + res%d = q%d - v(4) + + end function quat_minus_vect + + function quat_mult_quat(q1,q2) result(res) + + type(Quaternion), intent(in) :: q1,q2 + type(Quaternion) :: res + + res%a = q1%a * q2%a - q1%b * q2%b - q1%c * q2%c - q1%d * q2%d + res%b = q1%a * q2%b + q1%b * q2%a + q1%c * q2%d - q1%d * q2%c + res%c = q1%a * q2%c - q1%b * q2%d + q1%c * q2%a + q1%d * q2%b + res%d = q1%a * q2%d + q1%b * q2%c - q1%c * q2%b + q1%d * q2%a + + end function quat_mult_quat + + function quat_mult_real(q,r) result(res) + + type(Quaternion), intent(in) :: q + real(dp), intent(in) :: r + type(Quaternion) :: res + + res%a = q%a * r + res%b = q%b * r + res%c = q%c * r + res%d = q%d * r + + end function quat_mult_real + + function real_mult_quat(r,q) result(res) + + type(Quaternion), intent(in) :: q + real(dp), intent(in) :: r + type(Quaternion) :: res + + res%a = q%a * r + res%b = q%b * r + res%c = q%c * r + res%d = q%d * r + + end function real_mult_quat + + function quat_divide_real(q,r) result(res) + + type(Quaternion), intent(in) :: q + real(dp), intent(in) :: r + type(Quaternion) :: res + + res%a = q%a / r + res%b = q%b / r + res%c = q%c / r + res%d = q%d / r + + end function quat_divide_real + + function quat_divide_quat(q1,q2) result(res) + + type(Quaternion), intent(in) :: q1,q2 + type(Quaternion) :: res, q2c + real(dp) :: q2n + + q2c = .conj. q2 + q2n = normsq(q2) + + res = (q1 * q2c) / q2n + + end function quat_divide_quat + + !Dot product as if they were 4 component vectors + function quat_dot_quat(q1,q2) result(res) + + type(Quaternion), intent(in) :: q1,q2 + real(dp) :: res + + res = q1%a * q2%a + q1%b * q2%b + q1%c * q2%c + q1%d * q2%d + + end function quat_dot_quat + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X Comparison + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function quat_eq_quat(q1,q2) result(res) + + type(Quaternion), intent(in) :: q1,q2 + logical :: res + + res = .false. + + if (q1%a .fne. q2%a) return + if (q1%b .fne. q2%b) return + if (q1%c .fne. q2%c) return + if (q1%d .fne. q2%d) return + + res = .true. + + end function quat_eq_quat + + function quat_ne_quat(q1,q2) result(res) + + type(Quaternion), intent(in) :: q1,q2 + logical :: res + + res = .not. (q1 .feq. q2) + + end function quat_ne_quat + + function quat_eq_vect(q,v) result(res) + + type(Quaternion), intent(in) :: q + real(dp), dimension(:), intent(in) :: v + logical :: res + type(Quaternion) :: qv + + qv = v + + res = .false. + + if (q%a .fne. qv%a) return + if (q%b .fne. qv%b) return + if (q%c .fne. qv%c) return + if (q%d .fne. qv%d) return + + res = .true. + + end function quat_eq_vect + + function quat_ne_vect(q,v) result(res) + + type(Quaternion), intent(in) :: q + real(dp), dimension(:), intent(in) :: v + logical :: res + + res = .not. (q .feq. v) + + end function quat_ne_vect + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X Norms + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function quaternion_normsq(this) result(normsq) + + type(Quaternion), intent(in) :: this + real(dp) :: normsq + + normsq = this%a*this%a & + + this%b*this%b & + + this%c*this%c & + + this%d*this%d + + end function quaternion_normsq + + function quaternion_norm(this) result(norm) + + type(Quaternion), intent(in) :: this + real(dp) :: norm + + norm = sqrt(quaternion_normsq(this)) + + end function quaternion_norm + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X Quaternion conjugate + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function quaternion_conjugate(this) result(res) + + type(Quaternion), intent(in) :: this + type(Quaternion) :: res + + res%a = this%a + res%b = -this%b + res%c = -this%c + res%d = -this%d + + end function quaternion_conjugate + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X Printing + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine quaternion_print(this,file) + + type(Quaternion), intent(in) :: this + type(Inoutput), optional, intent(in) :: file + !local variables + character :: s2,s3,s4 + + s2 = '+'; s3 = '+'; s4 = '+' + if (this%b < 0.0_dp) s2 = '-' + if (this%c < 0.0_dp) s3 = '-' + if (this%d < 0.0_dp) s4 = '-' + + write(line,'(4(f0.5,a))') this%a,' '//s2//' ', & + abs(this%b),'i '//s3//' ', & + abs(this%c),'j '//s4//' ', & + abs(this%d),'k' + call Print(line,file=file) + + end subroutine quaternion_print + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X Rotation routines + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Many rotations can be collapsed into one, e.g. + !% to rotate using $q_1$ then $q_2$ : + !% rotate using $q_3 = q_2 \times q_1$ + !% + !% + !% Construct a rotation quaternion from axis and angle (in a righthanded sense) + ! + function rotation(axis,angle) result(res) + + real(dp), dimension(3), intent(in) :: axis + real(dp), intent(in) :: angle ! in radians + type(Quaternion) :: res + !local variables + real(dp) :: n + + n = norm(axis) + + res = (/ cos(angle/2.0_dp), sin(angle/2.0_dp)*axis/n /) + + end function rotation + + ! + !% Rotate a vector using the given quaternion + ! + subroutine rotate_vect(v,qr) + + real(dp), dimension(3), intent(inout) :: v + type(Quaternion), intent(in) :: qr + !local variables + type(Quaternion) :: qv + + qv = v + call rotate_quat(qv,qr) + v = qv + + end subroutine rotate_vect + + ! + !% Rotate a vector represented as a quaternion ('qv'), using a given rotation quaternion ('qr') + !% This assumes that the rotation quaternion is properly normalised + !% + !% 'qv = qr * qv * (.conj.qr)' + subroutine rotate_quat(qv,qr) + + type(Quaternion), intent(inout) :: qv + type(Quaternion), intent(in) :: qr + + qv = qr * qv * (.conj. qr) + + end subroutine rotate_quat + + ! + !% Given two vectors ('a1' and 'b1'), calculate the rotation quaternion + !% that must be used to rotate them into two other vectors ('a2' and 'b2'). + !% The angle between 'a1' and 'b1' must be the same as 'a2' and 'b2', + !% unless 'correct_angle' is present and true + ! + function orientation(a1, b1, a2, b2, correct_angle) + + real(dp), dimension(3), intent(in) :: a1,b1,a2,b2 + logical, optional, intent(in) :: correct_angle + type(Quaternion) :: Orientation + !local variables + type(Quaternion) :: r1, r2 !The two parts of the orientation + real(dp), dimension(3) :: n, p, q, a1_hat, b1_hat, a2_hat, b2_hat, b3_hat, zero3 + real(dp) :: theta + logical :: do_correct_angle + + do_correct_angle = .false. + if (present(correct_angle)) do_correct_angle = correct_angle + zero3 = (/0.0_dp,0.0_dp,0.0_dp/) + + !Normalise the vectors + a1_hat = a1 / norm(a1) + b1_hat = b1 / norm(b1) + a2_hat = a2 / norm(a2) + b2_hat = b2 / norm(b2) + + !Check the angles a1-b1 and a2-b2 match + if (.not. do_correct_angle .and. ((a1_hat .dot. b1_hat) .fne. (a2_hat .dot. b2_hat))) then + call system_abort('Orientation: Angle a1--b1 is not equal to angle a2--b2') + end if + + !Correct the a1--b1 angle to be the same as the a2--b2 angle by moving b1 + if (do_correct_angle) then + n = b1_hat - (a1_hat .dot. b1_hat)*a1_hat !Perpendicular to a1 in a1--b1 plane + n = n / norm(n) + theta = angle(a2_hat, b2_hat) + b1_hat = a1_hat * cos(theta) + n * sin(theta) + end if + + !Now construct the rotation quaternion needed to take a1 to a2 around an axis perpendicular to both + n = a1_hat .cross. a2_hat + + !Special case: The vectors could be almost (anti)parallel, in which case it we can choose any vector + !perpendicular to them as the first rotation axis + if (n .feq. zero3) then + do while(n .feq. zero3) !This is for the TINY possiblility that the random vector we choose + !is STILL (anti)parallel to a1 + !Create a random unit vector + p = random_unit_vector() + n = a1_hat .cross. p + end do + end if + + n = n / norm(n) + + theta = angle(a1_hat,a2_hat) + r1 = Rotation(n,theta) + + !Acting on b1 with r1 will take it to a new position, b3 + b3_hat = b1_hat + call Rotate(b3_hat,r1) + + !Now figure out the angle which we need to rotate around a2 (or -a2) to take b3 to b2 + ! -> Construct vectors perpendicular to a2, in the a2-b3 and a2-b2 planes, then find angle between them + p = b3_hat - (a2_hat .dot. b3_hat)*a2_hat + p = p / norm(p) + q = b2_hat - (a2_hat .dot. b2_hat)*a2_hat + q = q / norm(q) + n = p .cross. q ! This will be either in the a2 or the -a2 direction + + !Another Special case: Miraculously, p and q could be (anti) parallel, in which case we can just + !use a2_hat, then is doesn't matter if we rotate by 0 (or PI) clockwise or anticlockwise + if (n .feq. zero3) n = a2_hat + + n = n / norm(n) + theta = angle(p,q) + r2 = rotation(n,theta) + + !Combine the two rotations into one using quaternion multiplication + orientation = r2 * r1 + + end function orientation + + ! + !% Returns the angle and rotation axis of a (normalised) quaternion + ! + subroutine rotation_parameters(q,theta,axis) + + type(Quaternion), intent(in) :: q + real(dp), intent(out) :: theta + real(dp), dimension(3), intent(out) :: axis + + theta = 2.0_dp * acos(q%a) + + axis = (/q%b,q%c,q%d/) / (sqrt(1 - q%a*q%a)) + + end subroutine rotation_parameters + + ! + !% Return the equivalent rotation matrix of a (unit) quaternion + ! + function rotation_matrix(q_in) result(A) + + type(Quaternion), intent(in) :: q_in + real(dp), dimension(3,3) :: A + type(Quaternion) :: q + + !Normalise q_in + q = q_in / norm(q_in) + + !Now build A + A(1,1) = q%a*q%a+q%b*q%b-q%c*q%c-q%d*q%d; A(1,2) = 2.0_dp*(q%b*q%c-q%a*q%d); A(1,3) = 2.0_dp*(q%b*q%d+q%a*q%c) + A(2,1) = 2.0_dp*(q%b*q%c+q%a*q%d); A(2,2) = q%a*q%a-q%b*q%b+q%c*q%c-q%d*q%d; A(2,3) = 2.0_dp*(q%c*q%d-q%a*q%b) + A(3,1) = 2.0_dp*(q%b*q%d-q%a*q%c); A(3,2) = 2.0_dp*(q%c*q%d+q%a*q%b); A(3,3) = q%a*q%a-q%b*q%b-q%c*q%c+q%d*q%d + + end function rotation_matrix + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X Testing + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !%OMIT + subroutine quaternion_test + + type(Quaternion) :: q1, q2, q3 + real(dp) :: v3(3), v4(4), a(3), b(3), c(3), d(3), M(3,3) + + !Assignment + call Print('Testing assignment...') + call Print('q1 <- 4vector:') + q1 = (/1.0_dp,1.0_dp,1.0_dp,1.0_dp/) + call Print(q1) + call Print('q2 <- 3vector:') + q2 = (/2.0_dp,2.0_dp,2.0_dp/) + call Print(q2) + call Print('q1 -> 3vector:') + v3 = q1 + call Print(v3) + call Print('q2 -> 4vector:') + v4 = q2 + call Print(v4) + call Print('') + + !Algebra + call Print('Testing alegbra...') + call Print('q1 + q2:') + q3 = q1 + q2 + call Print(q3) + call Print('q1 - q2:') + q3 = q1 - q2 + call Print(q3) + call Print('q1 * q2:') + q3 = q1 * q2 + call Print(q3) + call Print('q1 / q2:') + q3 = q1 / q2 + call Print(q3) + call Print('') + + !Norms + call Print('Testing norms...') + call Print('normsq(q1):') + call Print(normsq(q1)) + call Print('normsq(q2):') + call Print(normsq(q2)) + call Print('norm(q1):') + call Print(norm(q1)) + call Print('norm(q2):') + call Print(norm(q2)) + call Print('') + + !Conjugate + call Print('Testing conjugates...') + call Print('q1*:') + call Print(.conj.q1) + call Print('q2*:') + call Print(.conj.q2) + call Print('') + + !Rotation + call Print('Testing Rotations...') + call Print('Setting q1 to x axis...') + q1 = (/1.0_dp,0.0_dp,0.0_dp/) + call Print('q1:') + call Print(q1) + call Print('Setting up q2 for rotation about z axis by 90deg...') + q2 = Rotation(unit_vector(0.0_dp,0.0_dp),PI/2.0_dp) + call Print('q2:') + call Print(q2) + call Print('Rotating...') + call Rotate(q1,q2) + q3 = q1 + call Print(q3) + v3 = q3 + call Print('Rotated vector:') + call Print(v3) + call Print('') + call Print('Rotating this by a further 90deg around z axis') + call Rotate(v3,q2) + call Print('Rotated vector:') + call Print(v3) + call Print('') + call Print('Creating random rotation quaternion...') + q1 = Rotation(random_unit_vector(),ran_uniform()*PI) + call Print(q1) + call Print('Calculating equivalent rotation matrix...') + M = Rotation_matrix(q1) + call Print(M) + call Print('Creating random vector...') + v3 = random_unit_vector() + call Print(v3) + call Print('Rotating with quaternion...') + a = v3 + call Rotate(a,q1) + call Print(a) + call Print('Rotating with matrix...') + b = M .mult. v3 + call Print(b) + call Print('') + + !Orientation + !NOTE: remember that q and -q represent the same rotation! + call Print('Testing orientation...') + call Print('Creating two random unit vectors...') + a = random_unit_vector() + b = random_unit_vector() + call Print('a:') + call Print(a) + call Print('b:') + call Print(b) + call Print('Creating random rotation quaternion...') + q1 = Rotation(random_unit_vector(),ran_uniform()*PI) + call Print(q1) + call Print('Rotating random vectors with random quaternion...') + c = a + call Rotate(c,q1) + d = b + call Rotate(d,q1) + call Print('a -> c:') + call Print(c) + call Print('b -> d:') + call Print(b) + call Print('Calculating rotation quaternion based on a,b,c,d:') + q2 = Orientation(a,b,c,d,.true.) + call Print(q2) + call Print('') + + end subroutine quaternion_test + +end module quaternions_module diff --git a/src/libAtoms/RigidBody.F90 b/src/libAtoms/RigidBody.F90 new file mode 100644 index 0000000000..b3eada677d --- /dev/null +++ b/src/libAtoms/RigidBody.F90 @@ -0,0 +1,885 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!% Types and routines for rigid body dynamics. +!% +!% \textbf{The implementation of the NO_SQUISH algorithm in AdvanceVerlet still requires +!% some work, so rigid bodies should be constructed from constraints for the time +!% being.} +! +module rigidbody_module + + use system_module + use periodictable_module + use linearalgebra_module + use atoms_module + use quaternions_module + + implicit none + private + + public :: rigidbodymodel, rigidbody, initialise, finalise, print + + type RigidBodyModel + !% Object used as a reference by the RigidBody type. + !% Many RigidBodys can point to the same model + + type(Atoms) :: at !% The actual atoms + integer :: d1a, d1b, d2a, d2b !% Atoms used as reference directions, 'd1a$>$d1b' and 'd2a$>$d2b' + real(dp), dimension(3) :: I !% Moments of inertia along x,y,z axes (after reorientation) + real(dp) :: Mtot !% The total mass of the body + logical :: initialised = .false. + + end type RigidBodyModel + + + type RigidBody + !% Holds one rigid body (e.g. one water molecule) + + integer :: N = 0 !% Number of atoms in the rigid body + integer, allocatable, dimension(:) :: indices !% Atoms that make up the rigid body + type(RigidBodyModel), pointer :: model !% A model of the rigid body in its correct conformation + type(Quaternion) :: q !% The orientation of the body + type(Quaternion) :: p !% The momentum of the orientation + real(dp), dimension(3) :: RCoM !% The centre of mass position + real(dp), dimension(3) :: VCoM !% The centre of mass velocity + logical :: initialised = .false. + + end type RigidBody + + integer, parameter :: M_ROT = 10 !Increasing this number integrates the rigid rotations more accurately + + interface initialise + module procedure rigidbody_initialise + end interface initialise + + interface finalise + module procedure rigidbody_finalise, rigidbodies_finalise + end interface finalise + + interface assignment(=) + module procedure rigidbody_assignment, rigidbodies_assignment + end interface + + interface print + module procedure rigidbodymodel_print, rigidbody_print, rigidbodies_print + end interface print + + private P0, P1, P2, P3 + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X INITIALISATION / FINALISATION + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + !% Initialise a RigidBodyModel: + !% \begin{itemize} + !% \item Calculates total mass. + !% \item Shifts the centre of mass to the origin. + !% \item Calculates moments of inertia and rotates + !% the atoms so that the principal axes. + !% lie along cartesian directions. + !% \item Finds two reference directions which are + !% not (anti)parallel. + !% \end{itemize} + ! + subroutine rigidbodymodel_initialise(this,at) + + type(RigidBodyModel), intent(inout) :: this + type(Atoms), intent(in) :: at + !local variables + real(dp), dimension(3,3) :: I_matrix, I_vects + real(dp), dimension(3) :: XCoM, d1, d2 + real(dp) :: m + integer :: i + type(Quaternion) :: q + + !A rigid body must have at least 2 atoms + if (at%N < 3) call system_abort('RigidBodyModel_Initialise: A rigid body must have at least 3 atoms') + + if (this%initialised) call rigidbodymodel_finalise(this) + + !Copy the atomic info + call initialise(this%at,at%N,at%lattice) + this%at%Z = at%Z + this%at%pos = at%pos + + !Shift the model so that the centre of mass is at the origin (note: no periodic wrapping is assumed) + XCoM = 0.0_dp + this%Mtot = 0.0_dp + + do i = 1, this%at%N + m = this%at%mass(i) + XCoM = XCoM + m * this%at%pos(:,i) + this%Mtot = this%Mtot + m + end do + + XCoM = XCoM / this%Mtot + + do i = 1, this%at%N + this%at%pos(:,i) = this%at%pos(:,i) - XCoM + end do + + !Calculate the model's inertia tensor + I_matrix = Inertia_Tensor(this%at) + call diagonalise(I_matrix,this%I,I_vects) !Stores the moments of inertia in this%I + + !Rotate the model so that the principle axes point along the x,y,z directions. + !The positions are then stored in body-fixed coordinates + !Eigenvalues are already normalised and orthogonal. + q = Orientation(I_vects(:,1), I_vects(:,2), & !Go from where the eigenvalues point... + (/1.0_dp,0.0_dp,0.0_dp/),(/0.0_dp,1.0_dp,0.0_dp/),.true.)!... to the x and y axes + + do i = 1, this%at%N + call rotate(this%at%pos(:,i),q) + end do + + !Find two non-parallel reference directions within the structure + this%d1a = 1; this%d1b = 2 + this%d2a = 1; this%d2b = 3 + do + d1 = this%at%pos(:,this%d1b) - this%at%pos(:,this%d1a) + d2 = this%at%pos(:,this%d2b) - this%at%pos(:,this%d2a) + d1 = d1 / norm(d1) + d2 = d2 / norm(d2) + if (abs(d1 .dot. d2) .fne. 1.0_dp) exit + !Directions are parallel... try a different set. + this%d2b = this%d2b + 1 + if (this%d2b > this%at%N) then + this%d1b = this%d1b + 1 + this%d2b = this%d1b + 1 + if (this%d2b == this%at%N) call System_Abort('RigidBodyModel_Initialise: Structure is Linear!') + end if + end do + + !Now the object is initialised + this%initialised = .true. + + end subroutine rigidbodymodel_initialise + + subroutine rigidbodymodel_finalise(this) + + type(RigidBodyModel), intent(inout) :: this + + call finalise(this%at) + this%d1a = 0; this%d1b = 0 + this%d2a = 0; this%d2b = 0 + this%I = 0.0_dp + this%Mtot = 0.0_dp + + this%initialised = .false. + + end subroutine rigidbodymodel_finalise + + ! + !% Initialise: The atoms in 'indices' must be in the same order as in the RigidModel + ! + subroutine rigidbody_initialise(this,at,indices,RigidModel) + + type(RigidBody), intent(inout) :: this !% The rigid body object we are initialising + type(Atoms), intent(inout) :: at !% The atoms object to which the indices refer + integer, dimension(:), intent(in) :: indices !% The indices of the atoms which make up the rigid body + type(RigidBodyModel), target, intent(in) :: RigidModel !% A model of the rigid body in its proper conformation + !local variables + integer :: i + + !Check the model has been initialised + if (.not.RigidModel%initialised) call system_abort('RigidBody_Initialise: Model is not initialised') + + !Check for the correct number of atoms + if (size(indices) /= RigidModel%at%N) then + write(line,'(a,i0,a,i0,a)')'RigidBody_Initialise: The model contains ',RigidModel%at%N,' atoms but ', & + size(indices),' indices have been provided' + call system_abort(line) + end if + + !Check the atomic indices and atomic numbers + do i = 1, size(indices) + if (indices(i) > at%N) then + write(line,'(a,i0,a,i0,a)')'RigidBody_Initialise: Atom ',indices(i),' is out of range (',at%N,')' + call system_abort(line) + end if + if (RigidModel%at%Z(i) /= at%Z(indices(i))) then + write(line,'(4(a,i0),a)')'RigidBody_Initialise: Atom ',i, & + ' of model ('//trim(ElementName(RigidModel%at%Z(i)))//', Z=', & + RigidModel%at%Z(i),') does not match atom ',indices(i), & + ' of atoms object ('//trim(ElementName(at%Z(indices(i))))//', Z=', & + at%Z(indices(i)),')' + call system_abort(line) + end if + end do + + call reallocate(this%indices,size(indices)) + this%indices = indices + this%N = size(indices) + + this%model => RigidModel + + this%q = 0.0_dp + this%p = 0.0_dp + this%RCoM = 0.0_dp + this%VCoM = 0.0_dp + + !Now we are initialised! + this%initialised = .true. + + end subroutine rigidbody_initialise + + subroutine rigidbody_finalise(this) + + type(RigidBody), intent(inout) :: this + + this%N = 0 + if (allocated(this%indices)) deallocate(this%indices) + this%model => null() + + this%q = 0.0_dp + this%p = 0.0_dp + this%RCoM = 0.0_dp + this%VCoM = 0.0_dp + + this%initialised = .false. + + end subroutine rigidbody_finalise + + ! + !% Finalise an allocatable array of RigidBodys + ! + subroutine rigidbodies_finalise(this) + + type(RigidBody), dimension(:), allocatable, intent(inout) :: this + integer :: i + + if (allocated(this)) then + do i = 1, size(this) + call finalise(this(i)) + end do + deallocate(this) + end if + + end subroutine rigidbodies_finalise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X ASSIGNMENT + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine rigidbody_assignment(to,from) + + type(RigidBody), intent(inout) :: to + type(RigidBody), intent(in) :: from + + call finalise(to) + + if (from%initialised) then + + allocate(to%indices(size(from%indices))) + + to%N = from%N + to%indices = from%indices + to%model => from%model + to%q = from%q + to%p = from%p + to%RCoM = from%RCoM + to%VCoM = from%VCoM + to%initialised = from%initialised + + end if + + end subroutine rigidbody_assignment + + subroutine rigidbodies_assignment(to,from) + + type(RigidBody), dimension(:), intent(inout) :: to + type(RigidBody), dimension(:), intent(in) :: from + integer :: i + + if (size(to) /= size(from)) call system_abort('RigidBodies_Assignment: Target array has different length to source array') + + do i = 1, size(from) + to(i) = from(i) + end do + + end subroutine rigidbodies_assignment + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X I/O + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine rigidbodymodel_print(this, file) + + type(RigidBodyModel), intent(inout) :: this + type(Inoutput), intent(inout), optional :: file + + call print('================', file=file) + call print(' RigidBodyModel', file=file) + call print('================', file=file) + call print('', file=file) + if (this%initialised) then + call print('Atoms:', file=file) + call print('------------', file=file) + call print(this%at, file=file) + call print('------------', file=file) + call print('', file=file) + write(line,'(2(a,i0))') 'Reference direction 1: atom ',this%d1a,' --> atom ',this%d1b + call print(line, file=file) + write(line,'(2(a,i0))') 'Reference direction 2: atom ',this%d2a,' --> atom ',this%d2b + call print(line, file=file) + call print('', file=file) + call print('Inertia Tensor:', file=file) + call print(inertia_tensor(this%at), file=file) + call print('Stored moments of inertia:') + call print(this%I, file=file) + call print('', file=file) + call print('Total Mass:', file=file) + call print(this%Mtot, file=file) + else + call print('(uninitialised)', file=file) + end if + call print('', file=file) + call print('================', file=file) + + end subroutine rigidbodymodel_print + + subroutine rigidbody_print(this, file) + + type(RigidBody), intent(inout) :: this + type(Inoutput), intent(inout), optional :: file + + call print('XXXXXXXXXXXXXXXX', file=file) + call print(' Rigid Body', file=file) + call print('XXXXXXXXXXXXXXXX', file=file) + call print('', file=file) + if (this%initialised) then + write(line,'(a,i0)')'Number of atoms = ',this%N + call print(line, file=file) + call print('', file=file) + call print('Atomic indices:', file=file) + call print(this%indices, file=file) + call print('', file=file) + call print('Reference Model =>', file=file) + call print(this%model, file=file) + call print('', file=file) + call print('Orientation quaternion:', file=file) + call print(this%q, file=file) + call print('Conjugate momentum quaternion:', file=file) + call print(this%p, file=file) + call print('', file=file) + call print('Centre of mass position:', file=file) + call print(this%RCoM, file=file) + call print('Centre of mass velocity:', file=file) + call print(this%VCoM, file=file) + else + call print('(uninitialised)', file=file) + end if + call print('', file=file) + call print('XXXXXXXXXXXXXXXX', file=file) + + end subroutine rigidbody_print + + subroutine rigidbodies_print(this,file) + + type(Rigidbody), dimension(:), intent(inout) :: this + type(inoutput), optional, intent(inout) :: file + integer :: i + + do i = 1, size(this) + call print(this(i),file) + end do + + end subroutine rigidbodies_print + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X FUNCTIONS FOR WORKING WITH RIGID BODIES + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function inertia_tensor(this) result(I) + + type(Atoms), intent(in) :: this + real(dp), dimension(3,3) :: I + !local variables + integer :: j + real(dp) :: r(3), m, x2, xy, xz, y2, yz, z2 + + I = 0.0_dp + do j = 1, this%N + r = this%pos(:,j) + m = this%mass(j) + x2 = r(1)*r(1); y2 = r(2)*r(2); z2 = r(3)*r(3) + xy = r(1)*r(2); xz = r(1)*r(3); yz = r(2)*r(3) + I(1,1) = I(1,1) + m * (y2 + z2) + I(2,2) = I(2,2) + m * (x2 + z2) + I(3,3) = I(3,3) + m * (x2 + y2) + I(1,2) = I(1,2) - m * xy + I(1,3) = I(1,3) - m * xz + I(2,3) = I(2,3) - m * yz + end do + !Fill in symmetric bits + I(2,1) = I(1,2) + I(3,1) = I(1,3) + I(3,2) = I(2,3) + + end function inertia_tensor + + ! + ! Functions and routines required by NO_SQUISH + ! + ! From Miller et al.: + ! P_0 q = {q0,q1,q2,q3} P_1 q = {-q1,q0,q3,-q2} P_2 q = {-q2,-q3,q0,q1} P_3 q = {-q3,q2,-q1,q0} + ! + ! ( ( | ) ( | ) ( | ) ( | ) ) + ! Matrix S(q) = ( (P_0 q) (P_1 q) (P_2 q) (P_3 q) ) + ! ( ( | ) ( | ) ( | ) ( | ) ) + ! + + function P0(q) !does nothing, but here for completeness + type(Quaternion), intent(in) :: q + type(Quaternion) :: P0 + P0 = q + end function P0 + + function P1(q) + type(Quaternion), intent(in) :: q + type(Quaternion) :: P1 + P1 = (/-q%b,q%a,q%d,-q%c/) + end function P1 + + function P2(q) + type(Quaternion), intent(in) :: q + type(Quaternion) :: P2 + P2 = (/-q%c,-q%d,q%a,q%b/) + end function P2 + + function P3(q) + type(Quaternion), intent(in) :: q + type(Quaternion) :: P3 + P3 = (/-q%d,q%c,-q%b,q%a/) + end function P3 + + function no_squish_S(q) result(S) + type(Quaternion), intent(in) :: q + real(dp), dimension(4,4) :: S + S(1,1) = +q%a; S(1,2) = -q%b; S(1,3) = -q%c; S(1,4) = -q%d + S(2,1) = +q%b; S(2,2) = +q%a; S(2,3) = -q%d; S(2,4) = +q%c + S(3,1) = +q%c; S(3,2) = +q%d; S(3,3) = +q%a; S(3,4) = -q%b + S(4,1) = +q%d; S(4,2) = -q%c; S(4,3) = +q%b; S(4,4) = +q%a + end function no_squish_S + + function no_squish_A_dot_transpose(q,q_dot) result(A_t) + + type(Quaternion), intent(in) :: q,q_dot + real(dp), dimension(3,3) :: A_t + + A_t(1,1) = q%a*q_dot%a + q%b*q_dot%b - q%c*q_dot%c - q%d*q_dot%d + A_t(2,1) = q%b*q_dot%c + q%c*q_dot%b + q%a*q_dot%d + q%d*q_dot%a + A_t(3,1) = q%b*q_dot%d + q%d*q_dot%b - q%a*q_dot%c - q%c*q_dot%a + A_t(1,2) = q%b*q_dot%c + q%c*q_dot%b - q%a*q_dot%d - q%d*q_dot%a + A_t(2,2) = q%a*q_dot%a - q%b*q_dot%b + q%c*q_dot%c - q%d*q_dot%d + A_t(3,2) = q%c*q_dot%d + q%d*q_dot%c + q%a*q_dot%b + q%b*q_dot%a + A_t(1,3) = q%b*q_dot%d + q%d*q_dot%b + q%a*q_dot%c + q%c*q_dot%a + A_t(2,3) = q%c*q_dot%d + q%d*q_dot%c - q%a*q_dot%b - q%b*q_dot%a + A_t(3,3) = q%a*q_dot%a - q%b*q_dot%b - q%c*q_dot%c + q%d*q_dot%d + + A_t = 2.0_dp * A_t + + end function no_squish_A_dot_transpose + + ! + ! Free_Rotor: part of the NO_SQUISH algorithm + ! + subroutine no_squish_free_rotor(q,p,I,dt) + + type(Quaternion), intent(inout) :: q,p + real(dp), dimension(3), intent(in) :: I + real(dp) :: dt + !local variables + real(dp) :: zetadt_2, zetadt, delta_t + integer :: j + + !Free rotation in M_ROT steps + delta_t = dt / real(M_ROT,dp) + do j = 1, M_ROT + + zetadt_2 = delta_t * (p .dot. P3(q)) / (8.0_dp * I(3)) + q = cos(zetadt_2)*q + sin(zetadt_2)*P3(q) + p = cos(zetadt_2)*p + sin(zetadt_2)*P3(p) + + zetadt_2 = delta_t * (p .dot. P2(q)) / (8.0_dp * I(2)) + q = cos(zetadt_2)*q + sin(zetadt_2)*P2(q) + p = cos(zetadt_2)*p + sin(zetadt_2)*P2(p) + + zetadt = delta_t * (p .dot. P1(q)) / (4.0_dp * I(1)) + q = cos(zetadt_2)*q + sin(zetadt_2)*P1(q) + p = cos(zetadt_2)*p + sin(zetadt_2)*P1(p) + + zetadt_2 = delta_t * (p .dot. P2(q)) / (8.0_dp * I(2)) + q = cos(zetadt_2)*q + sin(zetadt_2)*P2(q) + p = cos(zetadt_2)*p + sin(zetadt_2)*P2(p) + + zetadt_2 = delta_t * (p .dot. P3(q)) / (8.0_dp * I(3)) + q = cos(zetadt_2)*q + sin(zetadt_2)*P3(q) + p = cos(zetadt_2)*p + sin(zetadt_2)*P3(p) + + end do + + end subroutine no_squish_free_rotor + +end module RigidBody_module + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X RIGID BODY ROUTINES + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !This is based on the NO_SQUISH algorithm + !Miller et al., JChemPhys 116(20) 8649 (2002) + + ! + !% From Positions and Velocities of individual atoms, calculate the + !% centre of mass, centre of mass velocity, the orientation, and the + !% orientation conjugate momentum. + ! +! subroutine rigidbody_calculate_variables(this,i) +! +! type(DynamicalSystem), intent(inout) :: this +! integer, intent(in) :: i +! integer :: j,k, d1s_a, d1s_b, d2s_a, d2s_b +! real(dp), dimension(3) :: VCoM,L,r,v, d1s,d2s,d1b,d2b +! real(dp), dimension(4,4) :: S +! real(dp), dimension(4) :: L4 +! real(dp) :: m +! type(Quaternion) :: q +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_CalculateVariables: Rigid Body ',i,' is out of range' +! call system_abort(line) +! end if +! +! !Work out which atoms the reference directions go bewteen in the full atomic system +! d1s_a = this%rigidbody(i)%indices(this%rigidbody(i)%model%d1a) +! d1s_b = this%rigidbody(i)%indices(this%rigidbody(i)%model%d1b) +! d2s_a = this%rigidbody(i)%indices(this%rigidbody(i)%model%d2a) +! d2s_b = this%rigidbody(i)%indices(this%rigidbody(i)%model%d2b) +! !Find the directions in body and space coordinates +! d1s = diff_min_image(this%atoms,d1s_a,d1s_b) +! d2s = diff_min_image(this%atoms,d2s_a,d2s_b) +! d1b = this%rigidbody(i)%model%at%pos(:,this%rigidbody(i)%model%d1b) - & +! this%rigidbody(i)%model%at%pos(:,this%rigidbody(i)%model%d1a) +! d2b = this%rigidbody(i)%model%at%pos(:,this%rigidbody(i)%model%d2b) - & +! this%rigidbody(i)%model%at%pos(:,this%rigidbody(i)%model%d2a) +! !Calculate the rotation quaternion to go from body to space coords +! q = Orientation(d1b,d2b,d1s,d2s,correct_angle = .true.) +! this%rigidbody(i)%q = q +! !Calculate its angular momentum in the body frame of reference +! VCoM = centre_of_mass_velo(this,this%rigidbody(i)%indices) +! L = 0.0_dp +! q = this%rigidbody(i)%q +! do j = 1, this%rigidbody(i)%N +! +! k = this%rigidbody(i)%indices(j) !index of the jth atom in rigid body i +! m = this%atoms%Z(k) !the mass of the jth atom +! r = this%rigidbody(i)%model%at%pos(:,j) !the body fixed coordinates of jth atom +! v = Rotate((this%atoms%velo(:,k) - VCoM),.conj.q) !body fixed velocity of jth atom +! L = L + m * (r .cross. v) +! +! end do +! +! !Calculate the momentum conjugate to the orientation quaternion +! L4 = (/0.0_dp,L/) !this is D^-1 omega(4) in equation 2.15 of Miller et al. +! S = no_squish_S(q) +! this%rigidbody(i)%p = 2.0_dp * (S .mult. L4) +! +! !Store the centre of mass position and velocity +! this%rigidbody(i)%RCoM = centre_of_mass(this%atoms,this%rigidbody(i)%indices) +! this%rigidbody(i)%VCoM = VCoM +! +! end subroutine rigidbody_calculate_variables +! +! subroutine rigidbody_write_positions(this,i) +! +! type(DynamicalSystem), intent(inout) :: this +! integer, intent(in) :: i +! !local variables +! integer :: j, k +! real(dp), dimension(3) :: r +! type(Quaternion) :: q +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_WritePositions: Rigid Body ',i,' is out of range' +! call system_abort(line) +! end if +! +! q = this%rigidbody(i)%q +! +! do j = 1, this%rigidbody(i)%model%at%N +! k = this%rigidbody(i)%indices(j) !jth atom of rigid body +! r = this%rigidbody(i)%model%at%pos(:,j) !body coords of jth atom +! this%atoms%pos(:,k) = this%rigidbody(i)%RCoM + Rotate(r,this%rigidbody(i)%q) +! end do +! +! end subroutine rigidbody_write_positions +! +! subroutine rigidbody_write_velocities(this,i) +! +! type(DynamicalSystem), intent(inout) :: this +! integer, intent(in) :: i +! !local variables +! integer :: j, k +! real(dp), dimension(3) :: r, omega +! type(Quaternion) :: q +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_WriteVelocities: Rigid Body ',i,' is out of range' +! call system_abort(line) +! end if +! +! q = this%rigidbody(i)%q +! omega = RigidBody_angular_velocity(this,i) +! +! do j = 1, this%rigidbody(i)%model%at%N +! k = this%rigidbody(i)%indices(j) !jth atom of rigid body +! r = this%rigidbody(i)%model%at%pos(:,j) !body coords of jth atom +! this%atoms%velo(:,k) = this%rigidbody(i)%VCoM + Rotate((omega .cross. r),q) +! end do +! +! end subroutine rigidbody_write_velocities +! +! ! +! !% Reconstitute a rigid body that has been split over periodic boundaries +! ! +! subroutine rigidbody_reconstitute(this,i) +! +! type(DynamicalSystem), intent(inout) :: this +! integer, intent(in) :: i +! integer :: j, k, n, t(3) +! real(dp), dimension(3) :: r +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_Reconstitute: Rigid Body ',i,' is out of range' +! call system_abort(line) +! end if +! +! !Map everything back into the cell of the first atom in the body +! j = this%rigidbody(i)%indices(1) +! r = this%atoms%pos(:,j) +! t = this%atoms%travel(:,j) +! do n = 2, this%rigidbody(i)%N +! k = this%rigidbody(i)%indices(n) +! !Alter the position +! this%atoms%pos(:,k) = r + diff_min_image(this%atoms,j,k) +! !Make the travel values agree... RIGID BODIES CANNOT SPAN MORE THAN ONE CELL (why would they?) +! this%atoms%travel(:,k) = t +! end do +! +! end subroutine rigidbody_reconstitute +! +! ! +! !% Calculate the current angular velocity of rigid body 'i', in body frame +! ! +! function rigidbody_angular_velocity(this,i) result(omega) +! +! type(DynamicalSystem), intent(in) :: this +! integer, intent(in) :: i +! real(dp), dimension(3) :: omega +! real(dp), dimension(4) :: p4, sTp +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_AngularVelocity: Rigid Body ',i,' is out of range' +! call System_Abort(line) +! end if +! +! p4 = this%rigidbody(i)%p +! !sTp(1) should always be zero +! sTp = transpose(no_squish_S(this%rigidbody(i)%q)) .mult. p4 +! omega = 0.5_dp * sTp(2:4) / this%rigidbody(i)%model%I +! +! end function rigidbody_angular_velocity +! +! ! +! !% Calculate the current angular velocity of rigid body 'i', in body frame +! ! +! function rigidbody_angular_momentum(this,i) result(L) +! +! type(DynamicalSystem), intent(in) :: this +! integer, intent(in) :: i +! real(dp), dimension(3) :: L +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_AngularMomentum: Rigid Body ',i,' is out of range' +! call system_abort(line) +! end if +! +! L = this%rigidbody(i)%model%I * RigidBody_Angular_Velocity(this,i) !elementwise multiplication since +! !I is a vector, not a matrix +! +! end function rigidbody_angular_momentum +! +! ! +! !% Calculate the current torque on the rigid body 'i', in body frame +! ! +! function rigidbody_torque(this,i) result(tau) +! +! type(DynamicalSystem), intent(in) :: this +! integer, intent(in) :: i +! real(dp), dimension(3) :: tau, ACoM, r, a +! real :: m +! integer :: j, k +! type(Quaternion) :: q +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_Torque: Rigid Body ',i,' is out of range' +! call system_abort(line) +! end if +! +! ACoM = centre_of_mass_acc(this,this%rigidbody(i)%indices) +! q = this%rigidbody(i)%q +! tau = 0.0_dp +! +! do j = 1, this%rigidbody(i)%model%at%N +! k = this%rigidbody(i)%indices(j) !jth atom of rigid body i +! m = this%rigidbody(i)%model%at%mass(j) +! r = this%rigidbody(i)%model%at%pos(:,j) !body coords of jth atom +! a = Rotate((this%atoms%acc(:,k) - ACoM), .conj.q) !Rotate the non-CoM acceleration into the body frame +! tau = tau + m * (r .cross. a) +! end do +! +! end function rigidbody_torque +! +! function rigidbody_rotational_energy(this,i) result(Erot) +! +! type(DynamicalSystem), intent(in) :: this +! integer, intent(in) :: i +! real(dp) :: Erot +! real(dp), dimension(3) :: Im, omega +! +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_RotationalEnergy: Rigid Body ',i,' is out of range' +! call system_abort(line) +! end if +! +! omega = RigidBody_Angular_Velocity(this,i) +! Im = this%rigidbody(i)%model%I +! Erot = 0.5_dp * (Im(1)*omega(1)*omega(1) + Im(2)*omega(2)*omega(2) + Im(3)*omega(3)*omega(3)) +! +! end function rigidbody_rotational_energy +! +! function rigidbody_translational_energy(this,i) result(Etrans) +! +! type(DynamicalSystem), intent(in) :: this +! integer, intent(in) :: i +! real(dp) :: Etrans +! +! if (i < 1 .or. i > this%Nrigid) then +! write(line,'(a,i0,a)')'RigidBody_TranslationalEnergy: Rigid Body ',i,' is out of range' +! call system_abort(line) +! end if +! +! Etrans = 0.5_dp*this%rigidbody(i)%model%Mtot * normsq(centre_of_mass_velo(this,this%rigidbody(i)%indices)) +! +! end function rigidbody_translational_energy +! +! ! +! !% Add rigid bodies to the DynamicalSystem +! ! +! subroutine ds_add_rigidbody(this,indices,model) +! +! type(DynamicalSystem), intent(inout) :: this +! integer, dimension(:), intent(in) :: indices +! type(RigidBodyModel), target, intent(in) :: model +! !local variables +! integer :: i, g1, g2 +! +! !Check if rigid bodies have been set up +! if (.not.allocated(this%rigidbody)) call system_abort('DS_AddRigidBody: Rigid Bodies have not been allocated') +! +! !Have we got space for another rigid body? +! if (this%Nrigid == size(this%rigidbody)) then +! write(line,'(a,i0,a)')'DS_AddRigidBody: Maximum number of rigid bodies reached (',this%Nrigid,')' +! call system_abort(line) +! end if +! +! !Initialise the rigid body and update the group variables +! this%Nrigid = this%Nrigid + 1 +! g1 = this%group_lookup(indices(1)) +! do i = 1, size(indices) +! if (Atom_Type(this,indices(i)) /= TYPE_ATOM) then +! write(line,'(a,i0,a)')'DS_AddRigidBody: Atom ',indices(i),& +! ' is already being treated by another integration method' +! call system_abort(line) +! end if +! g2 = this%group_lookup(indices(i)) +! call merge_groups(this%group(g1),this%group(g2)) +! end do +! +! !Make atoms belong to this rigid body +! call group_add_object(this%group(g1),this%Nrigid) +! call initialise(this%rigidbody(this%Nrigid),this%atoms,indices,model) +! +! !Calculate the dynamical variables +! call rigidbody_calculate_variables(this,this%Nrigid) +! +! !Reduce the number of degrees of freedom: +! !Subtract 3 translational DoF for each atom, then add on the 3 trans + 3 rot DoF for the body +! this%Ndof = this%Ndof - 3*size(indices) + 6 +! +! end subroutine ds_add_rigidbody +! +! ! +! !% Correct the positions of all the atoms in rigid bodies +! ! +! subroutine ds_correct_rigid_positions(this) +! +! type(DynamicalSystem), intent(inout) :: this +! integer :: i,j,n +! +! do i = 1, this%Nrigid +! +! call rigidbody_calculate_variables(this,i) +! +! do j = 1, this%rigidbody(i)%N +! n = this%rigidbody(i)%indices(j) +! this%atoms%pos(:,n) = Rotate(this%rigidbody(i)%model%at%pos(:,j), this%rigidbody(i)%q) & +! + this%rigidbody(i)%RCoM +! end do +! +! end do +! +! end subroutine ds_correct_rigid_positions diff --git a/src/libAtoms/ScaLAPACK.F90 b/src/libAtoms/ScaLAPACK.F90 new file mode 100644 index 0000000000..a8d33f4c51 --- /dev/null +++ b/src/libAtoms/ScaLAPACK.F90 @@ -0,0 +1,1662 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X ScaLAPACK module +!X +!% Module wrapping ScaLAPACK routines +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module ScaLAPACK_module + +use error_module +use System_module +use MPI_context_module + +implicit none +private + +#ifdef SCALAPACK +integer, external :: ilcm, indxg2p, indxl2g, numroc +#endif + +integer, parameter :: dlen_ = 50 + +public :: ScaLAPACK +type ScaLAPACK + logical :: active = .false. + type(MPI_context) :: MPI_obj + integer :: blacs_context ! BLACS context (process grid ID) + integer :: n_proc_rows = 1 ! number rows in process grid + integer :: n_proc_cols = 1 ! number columns in process grid + integer :: my_proc_row = 0 ! grid row index of this process + integer :: my_proc_col = 0 ! grid column index of this process +end type ScaLAPACK + +public :: Matrix_ScaLAPACK_Info +type Matrix_ScaLAPACK_Info + logical :: active = .false. + type(ScaLAPACK) :: ScaLAPACK_obj + integer :: N_R = 0 ! number of rows in global matrix + integer :: N_C = 0 ! number of columns in global matrix + integer :: NB_R = 0 ! number of rows per block + integer :: NB_C = 0 ! number of columns per block + integer :: desc(dlen_) ! descriptor for ScaLAPACK + integer :: l_N_R = 0 ! local number of rows for this process + integer :: l_N_C = 0 ! local number of columns for this process +end type Matrix_ScaLAPACK_Info + +public :: Initialise +interface Initialise + module procedure ScaLAPACK_Initialise + module procedure Matrix_ScaLAPACK_Info_Initialise +end interface Initialise + +public :: Finalise +interface Finalise + module procedure ScaLAPACK_Finalise + module procedure Matrix_ScaLAPACK_Info_Finalise +end interface Finalise + +public :: Wipe +interface Wipe + module procedure Matrix_ScaLAPACK_Info_Wipe +end interface Wipe + +public :: Print +interface Print + module procedure ScaLAPACK_Print, Matrix_ScaLAPACK_Info_Print + module procedure ScaLAPACK_Matrix_d_print + module procedure ScaLAPACK_Matrix_z_print +end interface Print + +public :: init_matrix_desc +interface init_matrix_desc + module procedure ScaLAPACK_init_matrix_desc +end interface init_matrix_desc + +public :: coords_local_to_global +interface coords_local_to_global + module procedure Matrix_ScaLAPACK_Info_coords_local_to_global +end interface coords_local_to_global + +public :: coords_global_to_local +interface coords_global_to_local + module procedure Matrix_ScaLAPACK_Info_coords_global_to_local +end interface coords_global_to_local + +public :: diagonalise +interface diagonalise + module procedure ScaLAPACK_diagonalise_r, ScaLAPACK_diagonalise_c + module procedure ScaLAPACK_diagonalise_gen_r, ScaLAPACK_diagonalise_gen_c +end interface + +public :: inverse +interface inverse + module procedure ScaLAPACK_inverse_r, ScaLAPACK_inverse_c +end interface + +public :: add_identity +interface add_identity + module procedure ScaLAPACK_add_identity_r +end interface + +public :: matrix_product_sub +interface matrix_product_sub + module procedure ScaLAPACK_matrix_product_sub_ddd, ScaLAPACK_matrix_product_sub_zzz +end interface + +public :: matrix_product_vect_asdiagonal_sub +interface matrix_product_vect_asdiagonal_sub + module procedure ScaLAPACK_matrix_product_vect_asdiagonal_sub_ddd + module procedure ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzd + module procedure ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzz +end interface matrix_product_vect_asdiagonal_sub + +public :: Re_diag +interface Re_diag + module procedure ScaLAPACK_Re_diagZ, ScaLAPACK_Re_diagD +end interface Re_diag + +public :: diag_spinor +interface diag_spinor + module procedure ScaLAPACK_diag_spinorZ, ScaLAPACK_diag_spinorD +end interface diag_spinor + +public :: get_lwork_pdgeqrf +interface get_lwork_pdgeqrf + module procedure get_lwork_pdgeqrf_i32o64 + module procedure ScaLAPACK_get_lwork_pdgeqrf + module procedure ScaLAPACK_matrix_get_lwork_pdgeqrf +end interface + +public :: get_lwork_pdormqr +interface get_lwork_pdormqr + module procedure get_lwork_pdormqr_i32o64 + module procedure ScaLAPACK_get_lwork_pdormqr + module procedure ScaLAPACK_matrix_get_lwork_pdormqr +end interface + +public :: ScaLAPACK_pdgeqrf_wrapper, ScaLAPACK_pdtrtrs_wrapper, ScaLAPACK_pdormqr_wrapper +public :: ScaLAPACK_pdgemr2d_wrapper, ScaLAPACK_pdtrmr2d_wrapper +public :: ScaLAPACK_matrix_QR_solve, ScaLAPACK_to_array1d, ScaLAPACK_to_array2d + +contains + +subroutine Matrix_ScaLAPACK_Info_Initialise(this, N_R, N_C, NB_R, NB_C, scalapack_obj) + type(Matrix_ScaLAPACK_Info), intent(inout) :: this + integer, intent(in) :: N_R, NB_R + integer, intent(in), optional :: N_C, NB_C + type(ScaLAPACK), intent(in), optional :: scalapack_obj + +#ifdef SCALAPACK + + call Finalise(this) + + this%N_R = N_R + this%NB_R = NB_R + + if (present(N_C)) then + this%N_C = N_C + else + this%N_C = N_R + endif + if (present(NB_C)) then + this%NB_C = NB_C + else + this%NB_C = NB_R + endif + + if (present(scalapack_obj)) then + if (scalapack_obj%active) then + this%ScaLAPACK_obj = scalapack_obj + call init_matrix_desc(this%ScaLAPACK_obj, this%N_R, this%N_C, this%NB_R, this%NB_C, & + this%desc, this%l_N_R, this%l_N_C) + endif + else + this%l_N_R = this%N_R + this%l_N_C = this%N_C + endif + + this%active = this%ScaLAPACK_obj%active +#endif +end subroutine Matrix_ScaLAPACK_Info_Initialise + +subroutine ScaLAPACK_Initialise(this, MPI_obj, np_r, np_c) + type(ScaLAPACK), intent(inout) :: this + type(MPI_context), intent(in), optional :: MPI_obj + integer, intent(in), optional :: np_r, np_c !> rows, cols in process grid + +#ifdef SCALAPACK + call Finalise(this) + + this%active = .false. + if (present(MPI_obj)) then + if (MPI_obj%active .and. MPI_obj%n_procs > 1) then + this%active = .true. + + this%MPI_obj = MPI_obj + this%blacs_context = MPI_obj%communicator + + if (present(np_r) .and. present(np_c)) then + this%n_proc_rows = np_r + this%n_proc_cols = np_c + else + call calc_n_proc_rows_cols(this%MPI_obj%n_procs, this%n_proc_rows, this%n_proc_cols) + end if + call print("ScaLAPACK_Initialise using proc grid " // this%n_proc_rows // " x " // this%n_proc_cols, PRINT_VERBOSE) + + call blacs_gridinit (this%blacs_context, 'R', this%n_proc_rows, this%n_proc_cols) + call blacs_gridinfo (this%blacs_context, this%n_proc_rows, this%n_proc_cols, this%my_proc_row, this%my_proc_col) + endif + endif + +#endif +end subroutine ScaLAPACK_Initialise + +subroutine Matrix_ScaLAPACK_Info_Finalise(this) + type(Matrix_ScaLAPACK_Info), intent(inout) :: this + +#ifdef SCALAPACK + this%active = .false. +#endif +end subroutine + +subroutine ScaLAPACK_Finalise(this) + type(ScaLAPACK), intent(inout) :: this + +#ifdef SCALAPACK + if (this%active .and. this%blacs_context > -1) then + call blacs_gridexit(this%blacs_context) + endif + this%active = .false. +#endif +end subroutine + +subroutine Matrix_ScaLAPACK_Info_Wipe(this) + type(Matrix_ScaLAPACK_Info), intent(inout) :: this + +#ifdef SCALAPACK + this%active = .false. +#endif +end subroutine Matrix_ScaLAPACK_Info_Wipe + + +subroutine Matrix_ScaLAPACK_Info_coords_global_to_local(this, i, j, l_i, l_j, l_row_p, l_col_p) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + integer, intent(in) :: i, j + integer, intent(out) :: l_i, l_j + integer, intent(out), optional :: l_row_p, l_col_p + +#ifdef SCALAPACK + integer :: l_row_p_use, l_col_p_use + + if (this%active) then + call infog2l(i, j, this%desc, this%ScaLAPACK_obj%n_proc_rows, this%ScaLAPACK_obj%n_proc_cols, & + this%ScaLAPACK_obj%my_proc_row, this%ScaLAPACK_obj%my_proc_col, & + l_i, l_j, l_row_p_use, l_col_p_use) + + if (l_row_p_use /= this%ScaLAPACK_obj%my_proc_row .or. l_col_p_use /= this%ScaLAPACK_obj%my_proc_col) then + l_i = -1 + l_j = -1 + endif + + if (present(l_row_p)) l_row_p = l_row_p_use + if (present(l_col_p)) l_col_p = l_col_p_use + else +#endif + l_i = i + l_j = j + if (present(l_row_p)) l_row_p = 0 + if (present(l_col_p)) l_col_p = 0 +#ifdef SCALAPACK + endif +#endif +end subroutine Matrix_ScaLAPACK_Info_coords_global_to_local + +subroutine Matrix_ScaLAPACK_Info_coords_local_to_global(this, l_i, l_j, i, j) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + integer, intent(in) :: l_i, l_j + integer, intent(out) :: i, j + +#ifdef SCALAPACK + + if (this%active) then + i = indxl2g(l_i, this%NB_R, this%ScaLAPACK_obj%my_proc_row, 0, this%ScaLAPACK_obj%n_proc_rows) + j = indxl2g(l_j, this%NB_C, this%ScaLAPACK_obj%my_proc_col, 0, this%ScaLAPACK_obj%n_proc_cols) + else +#endif + i = l_i + j = l_j +#ifdef SCALAPACK + endif +#endif + +end subroutine Matrix_ScaLAPACK_Info_coords_local_to_global + + +subroutine ScaLAPACK_init_matrix_desc(this, N_R, N_C, NB_R, NB_C, desc, l_N_R, l_N_C) + type(ScaLAPACK), intent(in) :: this + integer, intent(in) :: N_R, NB_R + integer, intent(in), optional :: N_C, NB_C + integer, intent(out) :: desc(dlen_) + integer, intent(out) :: l_N_R, l_N_C + +#ifdef SCALAPACK + integer err + integer use_N_C, use_NB_C + integer lld +#endif + + desc = 0 + l_N_R = 0 + l_N_C = 0 + +#ifdef SCALAPACK + if (this%active) then + if (present(N_C)) then + use_N_C = N_C + else + use_N_C = N_R + endif + + if (present(NB_C)) then + use_NB_C = NB_C + else + use_NB_C = NB_R + endif + + l_N_R = numroc(N_R, NB_R, this%my_proc_row, 0, this%n_proc_rows) + l_N_C = numroc(use_N_C, use_NB_C, this%my_proc_col, 0, this%n_proc_cols) + + lld = l_N_R + if (l_N_r < 1) lld = 1 + + if (this%blacs_context >-1) then + call descinit (desc, N_R, use_N_C, NB_R, use_NB_C, 0, 0, this%blacs_context, lld, err) + else + desc(:) = -1 + end if + endif +#endif +end subroutine ScaLAPACK_init_matrix_desc + + + +subroutine calc_n_proc_rows_cols(n_procs, n_proc_rows, n_proc_cols) + integer, intent(in) :: n_procs + integer, intent(out) :: n_proc_rows, n_proc_cols + +#ifdef SCALAPACK + integer n_proc_rows_t, n_proc_cols_t + + +! long and narrow, or short and wide +! do n_proc_cols_t=int(sqrt(dble(n_procs))), 1, -1 +! n_proc_rows_t = n_procs/n_proc_cols_t + do n_proc_rows_t=int(sqrt(dble(n_procs))), 1, -1 + n_proc_cols_t = n_procs/n_proc_rows_t + + if (n_proc_rows_t*n_proc_cols_t .eq. n_procs) then + n_proc_rows = n_proc_rows_t + n_proc_cols = n_proc_cols_t + exit + endif + end do +#else + n_proc_rows = 0 + n_proc_cols = 0 +#endif +end subroutine calc_n_proc_rows_cols + +subroutine ScaLAPACK_Print(this,file) + type(ScaLAPACK), intent(in) :: this + type(Inoutput), intent(inout),optional:: file + +#ifdef SCALAPACK + + call Print("ScaLAPACK : ", file=file) + + call Print ('ScaLAPACK : active ' // this%active, file=file) + if (this%active) then + call Print ('ScaLAPACK : n_proc rows cols ' // this%n_proc_rows // " " // this%n_proc_cols, file=file) + call Print ('ScaLAPACK : my row col ' // this%my_proc_row // " " // this%my_proc_col, file=file) + endif +#endif +end subroutine ScaLAPACK_Print + +subroutine Matrix_ScaLAPACK_Info_Print(this,file) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + type(Inoutput), intent(inout),optional:: file +#ifdef SCALAPACK + + call Print('Matrix_ScaLAPACK_Info : ', file=file) + + call Print ('Matrix_ScaLAPACK_Info : active ' // this%active, file=file) + if (this%active) then + call Print(this%ScaLAPACK_obj, file=file) + call Print ('Matrix_ScaLAPACK_Info : N_R N_C ' // this%N_R // " " // this%N_C, file=file) + call Print ('Matrix_ScaLAPACK_Info : NB_R NB_C ' // this%NB_R // " " // this%NB_C, file=file) + call Print ('Matrix_ScaLAPACK_Info : l_N_R l_N_C ' // this%l_N_R // " " // this%l_N_C, file=file) + call Print ('Matrix_ScaLAPACK_Info : desc ' // this%desc, file=file) + endif +#endif +end subroutine Matrix_ScaLAPACK_Info_Print + +subroutine ScaLAPACK_inverse_r(this, data, inv_scalapack_info, inv_data, positive_in) + type(Matrix_ScaLAPACK_Info), intent(in), target :: this + real(dp), intent(inout), target :: data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in), target, optional :: inv_scalapack_info + real(dp), intent(out), target, optional :: inv_data(:,:) + logical, intent(in), optional :: positive_in + +#ifdef SCALAPACK + real(dp), pointer :: u_inv_data(:,:) + integer, pointer :: u_inv_desc(:) + integer, allocatable :: ipiv(:) + integer :: info + integer :: lwork, liwork + real(dp), allocatable :: work(:) + integer, allocatable :: iwork(:) + + if (present(inv_data)) then + u_inv_data => inv_data + u_inv_data = data + else + u_inv_data => data + endif + if (present(inv_scalapack_info)) then + if (.not. present(inv_data)) call system_abort("ScaLAPACK_inverse_r called with inv_scalapack_info but w/o inv_data") + u_inv_desc => inv_scalapack_info%desc + else + u_inv_desc => this%desc + endif + + allocate(ipiv(numroc(this%N_C, this%NB_C, this%scalapack_obj%my_proc_row, 0, this%scalapack_obj%n_proc_rows)+this%NB_C)) + call pdgetrf(this%N_R, this%N_C, u_inv_data, 1, 1, u_inv_desc, ipiv, info) + if (info /= 0) then + call system_abort("ScaLAPACK_inverse_r got pdgetrf info " // info) + endif + + allocate(work(1)) + allocate(iwork(1)) + lwork = -1 + liwork = -1 + call pdgetri(this%N_R, u_inv_data, 1, 1, u_inv_desc, & + ipiv, work, lwork, iwork, liwork, info) + lwork = work(1) + liwork = iwork(1) + deallocate(work) + deallocate(iwork) + + allocate(work(lwork)) + allocate(iwork(liwork)) + call pdgetri(this%N_R, u_inv_data, 1, 1, u_inv_desc, & + ipiv, work, lwork, iwork, liwork, info) + if (info /= 0) then + call system_abort("ScaLAPACK_inverse_r got pdgetrf info " // info) + endif + + deallocate(work) + deallocate(iwork) + deallocate(ipiv) +#endif + +end subroutine ScaLAPACK_inverse_r + +subroutine ScaLAPACK_inverse_c(this, data, inv_scalapack_info, inv_data, positive_in) + type(Matrix_ScaLAPACK_Info), intent(in), target :: this + complex(dp), intent(inout), target :: data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in), target, optional :: inv_scalapack_info + complex(dp), intent(out), target, optional :: inv_data(:,:) + logical, intent(in), optional :: positive_in + +#ifdef SCALAPACK + complex(dp), pointer :: u_inv_data(:,:) + integer, pointer :: u_inv_desc(:) + integer, allocatable :: ipiv(:) + integer :: info + + integer :: lwork, liwork + complex(dp), allocatable :: work(:) + integer, allocatable :: iwork(:) + +! call system_timer("ScaLAPACK_inverse_c") +! call system_timer("ScaLAPACK_inverse_c/prep") + if (present(inv_data)) then + u_inv_data => inv_data + u_inv_data = data + else + u_inv_data => data + endif + if (present(inv_scalapack_info)) then + if (.not. present(inv_data)) call system_abort("ScaLAPACK_inverse_r called with inv_scalapack_info but w/o inv_data") + u_inv_desc => inv_scalapack_info%desc + else + u_inv_desc => this%desc + endif + + allocate(ipiv(numroc(this%N_C, this%NB_C, this%scalapack_obj%my_proc_row, 0, this%scalapack_obj%n_proc_rows)+this%NB_C)) +! call system_timer("ScaLAPACK_inverse_c/prep") +! call system_timer("ScaLAPACK_inverse_c/pzgetrf") + call pzgetrf(this%N_R, this%N_C, u_inv_data, 1, 1, u_inv_desc, ipiv, info) +! call system_timer("ScaLAPACK_inverse_c/pzgetrf") +! call system_timer("ScaLAPACK_inverse_c/pzgetri_prep") + if (info /= 0) then + call system_abort("ScaLAPACK_inverse_r got pzgetrf info " // info) + endif + + allocate(work(1)) + allocate(iwork(1)) + lwork = -1 + liwork = -1 + call pzgetri(this%N_R, u_inv_data, 1, 1, u_inv_desc, & + ipiv, work, lwork, iwork, liwork, info) + lwork = work(1) + liwork = iwork(1) + deallocate(work) + deallocate(iwork) + + allocate(work(lwork)) + allocate(iwork(liwork)) +! call system_timer("ScaLAPACK_inverse_c/pzgetri_prep") +! call system_timer("ScaLAPACK_inverse_c/pzgetri") + call pzgetri(this%N_R, u_inv_data, 1, 1, u_inv_desc, & + ipiv, work, lwork, iwork, liwork, info) +! call system_timer("ScaLAPACK_inverse_c/pzgetri") +! call system_timer("ScaLAPACK_inverse_c/post") + if (info /= 0) then + call system_abort("ScaLAPACK_inverse_r got pzgetrf info " // info) + endif + + deallocate(work) + deallocate(iwork) + deallocate(ipiv) +! call system_timer("ScaLAPACK_inverse_c/post") +! call system_timer("ScaLAPACK_inverse_c") +#endif +end subroutine ScaLAPACK_inverse_c + +subroutine ScaLAPACK_diagonalise_r(this, data, evals, evecs_ScaLAPACK_obj, evecs_data, error) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + real(dp), intent(in) :: data(:,:) + real(dp), intent(out) :: evals(:) + type(Matrix_ScaLAPACK_Info), intent(in) :: evecs_ScaLAPACK_obj + real(dp), intent(out) :: evecs_data(:,:) + integer, intent(out), optional :: error + + integer liwork, lwork + real(dp), allocatable :: data_copy(:,:) + integer, allocatable :: iwork(:) + real(dp), allocatable :: work(:) + integer, allocatable :: icluster(:), ifail(:) + real(dp), allocatable :: gap(:) + + integer info + integer M, NZ, i + real(dp) :: orfac = 1.0e-4_dp + + INIT_ERROR(error) + + evals = 0.0_dp + evecs_data = 0.0_dp + +#ifdef SCALAPACK + allocate(icluster(2*this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) + allocate(gap(this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) + allocate(ifail(this%N_R)) + + allocate(data_copy(this%l_N_R, this%l_N_C)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_r data_copy", size(data_copy)*REAL_SIZE) + data_copy = data + + lwork = -1 + liwork = -1 + allocate(work(1)) + allocate(iwork(1)) + call pdsyevx('V', 'A', 'U', this%N_R, & + data_copy, 1, 1, this%desc, & + 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & + orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, work, lwork, & + iwork, liwork, ifail, icluster, gap, info) + lwork=work(1)*4 + liwork=iwork(1) + deallocate(work) + deallocate(iwork) + allocate(work(lwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_r work", size(work)*REAL_SIZE) + allocate(iwork(liwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_r iwork", size(iwork)*INTEGER_SIZE) + + call pdsyevx('V', 'A', 'U', this%N_R, & + data_copy, 1, 1, this%desc, & + 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & + orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, work, lwork, & + iwork, liwork, ifail, icluster, gap, info) + + if (info .ne. 0) then + call print("ScaLAPACK_diagonalise_r got info " // info, PRINT_ALWAYS) + if (mod(info,2) .ne. 0) then + call print(" eigenvectors failed to converge", PRINT_ALWAYS) + else if (mod(info/2,2) .ne. 0) then + call print(" eigenvectors failed to orthogonalize", PRINT_ALWAYS) + do i=1, size(icluster), 2 + if (icluster(i) /= 0) then + call print (" eval cluster " // icluster(i) // " " // icluster(i+1) // & + "("// (icluster(i+1)-icluster(i)+1) // ")", PRINT_ALWAYS) + else + exit + endif + end do + do i=1, this%N_R + call print(" eigenvalue " // i // " " // evals(i), PRINT_ANALYSIS) + end do + else if (mod(info/4,2) .ne. 0) then + call print(" not enough space for all eigenvectors in range", PRINT_ALWAYS) + else if (mod(info/8,2) .ne. 0) then + call print(" failed to compute eigenvalues", PRINT_ALWAYS) + else if (mod(info/16,2) .ne. 0) then + call print(" S was not positive definite "//ifail(1), PRINT_ALWAYS) + endif + endif + + deallocate (icluster, ifail, gap) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_r work", size(work)*REAL_SIZE) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_r iwork", size(iwork)*INTEGER_SIZE) + deallocate (iwork, work) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_r data_copy", size(data_copy)*REAL_SIZE) + deallocate (data_copy) + + if (M /= this%N_R .or. NZ /= this%N_R) then ! bad enough error to report + RAISE_ERROR("ScaLAPACK_diagonalise_r: Failed to diagonalise info="//info, error) + endif +#endif + +end subroutine ScaLAPACK_diagonalise_r + +subroutine ScaLAPACK_diagonalise_c(this, data, evals, evecs_ScaLAPACK_obj, evecs_data, error) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + complex(dp), intent(in) :: data(:,:) + real(dp), intent(out) :: evals(:) + type(Matrix_ScaLAPACK_Info), intent(in) :: evecs_ScaLAPACK_obj + complex(dp), intent(out) :: evecs_data(:,:) + integer, intent(out), optional :: error + + integer liwork, lrwork, lcwork + integer, allocatable :: iwork(:) + real(dp), allocatable :: rwork(:) + complex(dp), allocatable :: cwork(:) + integer, allocatable :: icluster(:), ifail(:) + real(dp), allocatable :: gap(:) + + complex(dp), allocatable :: data_copy(:,:) + + integer info + integer M, NZ, i + real(dp) :: orfac = 1.0e-4_dp + + INIT_ERROR(error) + + evals = 0.0_dp + evecs_data = 0.0_dp + +#ifdef SCALAPACK + allocate(icluster(2*this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) + allocate(gap(this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) + allocate(ifail(this%N_R)) + + allocate(data_copy(this%l_N_R, this%l_N_C)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_c data_copy", size(data_copy)*COMPLEX_SIZE) + data_copy = data + + lrwork = -1 + lcwork = -1 + liwork = -1 + allocate(rwork(1)) + allocate(cwork(1)) + allocate(iwork(1)) + call pzheevx('V', 'A', 'U', this%N_R, & + data_copy, 1, 1, this%desc, & + 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & + orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, cwork, lcwork, & + rwork, lrwork, iwork, liwork, ifail, icluster, gap, info) + lrwork=rwork(1)*4 + lcwork=cwork(1) + liwork=iwork(1) + deallocate(rwork) + deallocate(cwork) + deallocate(iwork) + allocate(rwork(lrwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_c rwork", size(rwork)*REAL_SIZE) + allocate(cwork(lcwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_c cwork", size(cwork)*COMPLEX_SIZE) + allocate(iwork(liwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_c iwork", size(iwork)*INTEGER_SIZE) + + call pzheevx('V', 'A', 'U', this%N_R, & + data_copy, 1, 1, this%desc, & + 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & + orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, cwork, lcwork, & + rwork, lrwork, iwork, liwork, ifail, icluster, gap, info) + + if (info .ne. 0) then + call print("ScaLAPACK_diagonlise_c got info " // info, PRINT_ALWAYS) + if (mod(info,2) .ne. 0) then + call print(" eigenvectors failed to converge", PRINT_ALWAYS) + else if (mod(info/2,2) .ne. 0) then + call print(" eigenvectors failed to orthogonalize", PRINT_ALWAYS) + do i=1, size(icluster), 2 + if (icluster(i) /= 0) then + call print (" eval cluster " // icluster(i) // " " // icluster(i+1) // & + "("// (icluster(i+1)-icluster(i)+1) // ")", PRINT_ALWAYS) + else + exit + endif + end do + do i=1, this%N_R + call print(" eigenvalue " // i // " " // evals(i), PRINT_ANALYSIS) + end do + else if (mod(info/4,2) .ne. 0) then + call print(" not enough space for all eigenvectors in range", PRINT_ALWAYS) + else if (mod(info/8,2) .ne. 0) then + call print(" failed to compute eigenvalues", PRINT_ALWAYS) + else if (mod(info/16,2) .ne. 0) then + call print(" S was not positive definite "//ifail(1), PRINT_ALWAYS) + endif + endif + + deallocate (icluster, ifail, gap) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_c iwork", size(iwork)*INTEGER_SIZE) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_c rwork", size(rwork)*REAL_SIZE) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_c cwork", size(cwork)*COMPLEX_SIZE) + deallocate (iwork, rwork, cwork) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_c data_copy", size(data_copy)*COMPLEX_SIZE) + deallocate (data_copy) + + if (M /= this%N_R .or. NZ /= this%N_R) then ! bad enough error to report + RAISE_ERROR("ScaLAPACK_diagonalise_r: Failed to diagonalise info="//info, error) + endif +#endif + +end subroutine ScaLAPACK_diagonalise_c + +subroutine ScaLAPACK_diagonalise_gen_r(this, data, overlap_ScaLAPACK_obj, overlap_data, & + evals, evecs_ScaLAPACK_obj, evecs_data, error) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + real(dp), intent(in) :: data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: overlap_ScaLAPACK_obj + real(dp), intent(in) :: overlap_data(:,:) + real(dp), intent(out) :: evals(:) + type(Matrix_ScaLAPACK_Info), intent(in) :: evecs_ScaLAPACK_obj + real(dp), intent(out) :: evecs_data(:,:) + integer, intent(out), optional :: error + + integer :: liwork, lwork + integer, allocatable :: iwork(:) + real(dp), allocatable :: work(:) + integer, allocatable :: icluster(:), ifail(:) + real(dp), allocatable :: gap(:) + + real(dp), allocatable :: data_copy(:,:), overlap_data_copy(:,:) + + integer info + integer M, NZ, i + real(dp) :: orfac = 1.0e-4_dp + + INIT_ERROR(error) + + evals = 0.0_dp + evecs_data = 0.0_dp + +#ifdef SCALAPACK + allocate(icluster(2*this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) + allocate(gap(this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) + allocate(ifail(this%N_R)) + + allocate(data_copy(this%l_N_R, this%l_N_C)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r data_copy", size(data_copy)*REAL_SIZE) + allocate(overlap_data_copy(overlap_ScaLAPACK_obj%l_N_R, overlap_ScaLAPACK_obj%l_N_C)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r overlap_data_copy", size(overlap_data_copy)*REAL_SIZE) + data_copy = data + overlap_data_copy = overlap_data + + lwork = -1 + liwork = -1 + allocate(work(1)) + allocate(iwork(1)) + call pdsygvx(1, 'V', 'A', 'U', this%N_R, & + data_copy, 1, 1, this%desc, & + overlap_data_copy, 1, 1, overlap_ScaLAPACK_obj%desc, & + 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & + orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, work, lwork, & + iwork, liwork, ifail, icluster, gap, info) + lwork = work(1)*4 + liwork = iwork(1) + deallocate(work) + deallocate(iwork) + + allocate(work(lwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r work", size(work)*REAL_SIZE) + allocate(iwork(liwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r iwork", size(iwork)*INTEGER_SIZE) + +! call print("calling pdsygv : NR " // this%N_R // " shape(data_copy) " // shape(data_copy) // & +! " shape(overlap_data_copy) " // shape(overlap_data_copy) // " shape(evals) " // shape(evals) // & +! " shape(evecs_data) " // shape(evecs_data) // " shape(work) " // shape(work) // " lwork " // lwork // & +! " shape(iwork) " // shape(iwork) // " liwork " // liwork // " shape(ifail) " // shape(ifail) // & +! " shape(icluster) " // shape(icluster), PRINT_ALWAYS) + call pdsygvx(1, 'V', 'A', 'U', this%N_R, & + data_copy, 1, 1, this%desc, & + overlap_data_copy, 1, 1, overlap_ScaLAPACK_obj%desc, & + 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & + orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, work, lwork, & + iwork, liwork, ifail, icluster, gap, info) +! call print("done pdsygvx", PRINT_ALWAYS) + + if (info .ne. 0) then + call print("ScaLAPACK_diagonlise_gen_r got info " // info, PRINT_ALWAYS) + if (mod(info,2) .ne. 0) then + call print(" eigenvectors failed to converge", PRINT_ALWAYS) + else if (mod(info/2,2) .ne. 0) then + call print(" eigenvectors failed to orthogonalize", PRINT_ALWAYS) + do i=1, size(icluster), 2 + if (icluster(i) /= 0) then + call print (" eval cluster " // icluster(i) // " " // icluster(i+1) // & + "("// (icluster(i+1)-icluster(i)+1) // ")", PRINT_ALWAYS) + else + exit + endif + end do + do i=1, this%N_R + call print(" eigenvalue " // i // " " // evals(i), PRINT_ANALYSIS) + end do + else if (mod(info/4,2) .ne. 0) then + call print(" not enough space for all eigenvectors in range", PRINT_ALWAYS) + else if (mod(info/8,2) .ne. 0) then + call print(" failed to compute eigenvalues", PRINT_ALWAYS) + else if (mod(info/16,2) .ne. 0) then + call print(" S was not positive definite "//ifail(1), PRINT_ALWAYS) + endif + endif + + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r iwork", size(iwork)*INTEGER_SIZE) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r work", size(work)*REAL_SIZE) + deallocate (iwork, work) + + deallocate (icluster, ifail, gap) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r data_copy", size(data_copy)*REAL_SIZE) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r overlap_data_copy", size(overlap_data_copy)*REAL_SIZE) + deallocate (data_copy, overlap_data_copy) + + if (M /= this%N_R .or. NZ /= this%N_R) then ! bad enough error to report + RAISE_ERROR("ScaLAPACK_diagonalise_r: Failed to diagonalise info="//info, error) + endif +#endif + +end subroutine ScaLAPACK_diagonalise_gen_r + +subroutine ScaLAPACK_diagonalise_gen_c(this, data, overlap_ScaLAPACK_obj, overlap_data, & + evals, evecs_ScaLAPACK_obj, evecs_data, error) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + complex(dp), intent(in) :: data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: overlap_ScaLAPACK_obj + complex(dp), intent(in) :: overlap_data(:,:) + real(dp), intent(out) :: evals(:) + type(Matrix_ScaLAPACK_Info), intent(in) :: evecs_ScaLAPACK_obj + complex(dp), intent(out) :: evecs_data(:,:) + integer, intent(out), optional :: error + + integer liwork, lrwork, lcwork + integer, allocatable :: iwork(:) + real(dp), allocatable :: rwork(:) + complex(dp), allocatable :: cwork(:) + integer, allocatable :: icluster(:), ifail(:) + real(dp), allocatable :: gap(:) + + complex(dp), allocatable :: data_copy(:,:), overlap_data_copy(:,:) + + integer info + integer M, NZ, i + real(dp) :: orfac = 1.0e-4_dp + + INIT_ERROR(error) + + evals = 0.0_dp + evecs_data = 0.0_dp + +#ifdef SCALAPACK + allocate(icluster(2*this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) + allocate(gap(this%ScaLAPACK_obj%n_proc_rows*this%ScaLAPACK_obj%n_proc_cols)) + allocate(ifail(this%N_R)) + + allocate(data_copy(this%l_N_R, this%l_N_C)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r data_copy", size(data_copy)*COMPLEX_SIZE) + allocate(overlap_data_copy(this%l_N_R, this%l_N_C)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r overlap_data_copy", size(overlap_data_copy)*COMPLEX_SIZE) + data_copy = data + overlap_data_copy = overlap_data + + lrwork = -1 + lcwork = -1 + liwork = -1 + allocate(rwork(1)) + allocate(cwork(1)) + allocate(iwork(1)) + call pzhegvx(1, 'V', 'A', 'U', this%N_R, & + data_copy, 1, 1, this%desc, & + overlap_data_copy, 1, 1, overlap_ScaLAPACK_obj%desc, & + 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & + orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, cwork, lcwork, & + rwork, lrwork, iwork, liwork, ifail, icluster, gap, info) + lrwork=rwork(1)*4 + lcwork=cwork(1) + liwork=iwork(1) + deallocate(rwork) + deallocate(cwork) + deallocate(iwork) + allocate(rwork(lrwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r rwork", size(rwork)*REAL_SIZE) + allocate(cwork(lcwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r cwork", size(cwork)*COMPLEX_SIZE) + allocate(iwork(liwork)) + call ALLOC_TRACE("ScaLAPACK_diagonalise_gen_r iwork", size(iwork)*INTEGER_SIZE) + + call pzhegvx(1, 'V', 'A', 'U', this%N_R, & + data_copy, 1, 1, this%desc, & + overlap_data_copy, 1, 1, overlap_ScaLAPACK_obj%desc, & + 0.0_dp, 0.0_dp, 1, 1, -1.0_dp, M, NZ, evals, & + orfac, evecs_data, 1, 1, evecs_ScaLAPACK_obj%desc, cwork, lcwork, & + rwork, lrwork, iwork, liwork, ifail, icluster, gap, info) + + if (info .ne. 0) then + call print("ScaLAPACK_diagonlise_gen_c got info " // info, PRINT_ALWAYS) + if (mod(info,2) .ne. 0) then + call print(" eigenvectors failed to converge", PRINT_ALWAYS) + else if (mod(info/2,2) .ne. 0) then + call print(" eigenvectors failed to orthogonalize", PRINT_ALWAYS) + do i=1, size(icluster), 2 + if (icluster(i) /= 0) then + call print (" eval cluster " // icluster(i) // " " // icluster(i+1) // & + "("// (icluster(i+1)-icluster(i)+1) // ")", PRINT_ALWAYS) + else + exit + endif + end do + do i=1, this%N_R + call print(" eigenvalue " // i // " " // evals(i), PRINT_ANALYSIS) + end do + else if (mod(info/4,2) .ne. 0) then + call print(" not enough space for all eigenvectors in range", PRINT_ALWAYS) + else if (mod(info/8,2) .ne. 0) then + call print(" failed to compute eigenvalues", PRINT_ALWAYS) + else if (mod(info/16,2) .ne. 0) then + call print(" S was not positive definite "//ifail(1), PRINT_ALWAYS) + endif + endif + + deallocate (icluster, ifail, gap) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r iwork", size(iwork)*INTEGER_SIZE) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r rwork", size(rwork)*REAL_SIZE) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r cwork", size(cwork)*COMPLEX_SIZE) + deallocate (iwork, rwork, cwork) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r data_copy", size(data_copy)*COMPLEX_SIZE) + call DEALLOC_TRACE("ScaLAPACK_diagonalise_gen_r overlap_data_copy", size(overlap_data_copy)*COMPLEX_SIZE) + deallocate (data_copy, overlap_data_copy) + + if (M /= this%N_R .or. NZ /= this%N_R) then ! bad enough error to report + RAISE_ERROR("ScaLAPACK_diagonalise_r: Failed to diagonalise info="//info, error) + endif +#endif + +end subroutine ScaLAPACK_diagonalise_gen_c + +subroutine ScaLAPACK_add_identity_r(this, data) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + real(dp), intent(inout) :: data(:,:) + +#ifdef SCALAPACK + integer g_i + integer l_i, l_j, p_i, p_j + + + do g_i=1, this%N_R + call coords_global_to_local(this, g_i, g_i, l_i, l_j, p_i, p_j) + if (p_i == this%ScaLAPACK_obj%my_proc_row .and. & + p_j == this%ScaLAPACK_obj%my_proc_col) & + data(l_i, l_j) = data(l_i, l_j) + 1.0_dp + end do +#endif +end subroutine ScaLAPACK_add_identity_r + +subroutine ScaLAPACK_Matrix_d_print(this, data, file, short_output) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + real(dp), intent(in) :: data(:,:) + type(Inoutput), intent(inout), optional :: file + logical, intent(in), optional :: short_output + +#ifdef SCALAPACK + logical :: short_output_opt + integer :: l_i, l_j, g_i, g_j, my_proc + character(len=200), allocatable :: lines(:) + + short_output_opt = optional_default(.false., short_output) + + if (this%l_N_R*this%l_N_c > 0) then + allocate(lines(this%l_N_R*this%l_N_C)) + + my_proc = this%ScaLAPACK_obj%MPI_obj%my_proc + + do l_i=1, this%l_N_R + do l_j=1, this%l_N_C + call coords_local_to_global(this, l_i, l_j, g_i, g_j) + if (short_output_opt) then + lines((l_i-1)*this%l_N_C + l_j) = g_i // " " // g_j // " " // data(l_i,l_j) + else + lines((l_i-1)*this%l_N_C + l_j) = my_proc // & + ": ScaLAPACK local_matrix li,j " // l_i // " " // l_j // " gi,j " // g_i // " " // g_j & + // " " // data(l_i,l_j) + end if + end do + end do + else + allocate(lines(1)) + lines(1) = "" + endif + + call mpi_print(this%ScaLAPACK_obj%mpi_obj, lines, file) + + deallocate(lines) +#endif +end subroutine ScaLAPACK_Matrix_d_print + +subroutine ScaLAPACK_Matrix_z_print(this, data, file, short_output) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + complex(dp), intent(in) :: data(:,:) + type(Inoutput), intent(inout), optional :: file + logical, intent(in), optional :: short_output + +#ifdef SCALAPACK + logical :: short_output_opt + integer :: l_i, l_j, g_i, g_j, my_proc + character(len=200), allocatable :: lines(:) + + short_output_opt = optional_default(.false., short_output) + + if (this%l_N_R*this%l_N_C > 0) then + allocate(lines(this%l_N_R*this%l_N_C)) + + my_proc = this%ScaLAPACK_obj%MPI_obj%my_proc + + do l_i=1, this%l_N_R + do l_j=1, this%l_N_C + call coords_local_to_global(this, l_i, l_j, g_i, g_j) + if (short_output_opt) then + lines((l_i-1)*this%l_N_C + l_j) = g_i // " " // g_j // " " // data(l_i,l_j) + else + lines((l_i-1)*this%l_N_C + l_j) = my_proc // & + ": ScaLAPACK local_matrix li,j " // l_i // " " // l_j // " gi,j " // g_i // " " // g_j & + // " " // data(l_i,l_j) + end if + end do + end do + else + allocate(lines(1)) + lines(1) = "" + endif + + call mpi_print(this%ScaLAPACK_obj%mpi_obj, lines) + + deallocate(lines) +#endif +end subroutine ScaLAPACK_Matrix_z_print + +subroutine ScaLAPACK_matrix_product_sub_ddd(c_scalapack, c_data, a_scalapack, a_data, b_scalapack, b_data, & + a_transpose, b_transpose, a_conjugate, b_conjugate) + type(Matrix_ScaLAPACK_Info), intent(in) :: c_scalapack + real(dp), intent(inout) :: c_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack + real(dp), intent(in) :: a_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: b_scalapack + real(dp), intent(in) :: b_data(:,:) + logical, intent(in), optional :: a_transpose, b_transpose, a_conjugate, b_conjugate + +#ifdef SCALAPACK + + logical a_transp, b_transp, a_conjg, b_conjg + character a_op, b_op + + a_transp = .false. + b_transp = .false. + a_conjg = .false. + b_conjg = .false. + if (present(a_transpose)) a_transp = a_transpose + if (present(b_transpose)) b_transp = b_transpose + if (present(a_conjugate)) a_conjg = a_conjugate + if (present(b_conjugate)) b_conjg = b_conjugate + + if (a_transp .or. a_conjg) then + a_op = 'T' + else + a_op = 'N' + endif + if (b_transp .or. b_conjg) then + b_op = 'T' + else + b_op = 'N' + endif + + call pdgemm(a_op, b_op, c_scalapack%N_R, c_scalapack%N_C, a_scalapack%N_C, & + 1.0_dp, a_data, 1, 1, a_scalapack%desc, b_data, 1, 1, b_scalapack%desc, & + 0.0_dp, c_data, 1, 1, c_scalapack%desc) + +#endif + +end subroutine ScaLAPACK_matrix_product_sub_ddd + +subroutine ScaLAPACK_matrix_product_sub_zzz(c_scalapack, c_data, a_scalapack, a_data, b_scalapack, b_data, & + a_transpose, b_transpose, a_conjugate, b_conjugate) + type(Matrix_ScaLAPACK_Info), intent(in) :: c_scalapack + complex(dp), intent(inout) :: c_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack + complex(dp), intent(in) :: a_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: b_scalapack + complex(dp), intent(in) :: b_data(:,:) + logical, intent(in), optional :: a_transpose, b_transpose, a_conjugate, b_conjugate + +#ifdef SCALAPACK + logical a_transp, b_transp, a_conjg, b_conjg + character a_op, b_op + + a_transp = .false. + b_transp = .false. + a_conjg = .false. + b_conjg = .false. + if (present(a_transpose)) a_transp = a_transpose + if (present(b_transpose)) b_transp = b_transpose + if (present(a_conjugate)) a_conjg = a_conjugate + if (present(b_conjugate)) b_conjg = b_conjugate + + if (a_transp .and. a_conjg) call system_abort("ScaLAPACK_matrix_product_sub_zzz called with a_transp and a_conjg") + if (b_transp .and. b_conjg) call system_abort("ScaLAPACK_matrix_product_sub_zzz called with b_transp and b_conjg") + + if (a_transp) then + a_op = 'T' + else if (a_conjg) then + a_op = 'C' + else + a_op = 'N' + endif + if (b_transp) then + b_op = 'T' + else if (b_conjg) then + b_op = 'C' + else + b_op = 'N' + endif + + call pzgemm(a_op, b_op, c_scalapack%N_R, c_scalapack%N_C, a_scalapack%N_C, & + cmplx(1.0_dp,0.0_dp,dp), a_data, 1, 1, a_scalapack%desc, b_data, 1, 1, b_scalapack%desc, & + cmplx(0.0_dp,0.0_dp,dp), c_data, 1, 1, c_scalapack%desc) +#endif + +end subroutine ScaLAPACK_matrix_product_sub_zzz + +subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_ddd(this_scalapack, this_data, a_scalapack, a_data, diag) + type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack + real(dp), intent(out) :: this_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack + real(dp), intent(in) :: a_data(:,:) + real(dp), intent(in) :: diag(:) + +#ifdef SCALAPACK + integer l_i, l_j, g_i, g_j + + do l_i=1, this_scalapack%l_N_R + do l_j=1, this_scalapack%l_N_C + call coords_local_to_global(this_scalapack, l_i, l_j, g_i, g_j) + this_data(l_i,l_j) = a_data(l_i,l_j) * diag(g_j) + end do + end do +#else + this_data = 0.0_dp +#endif +end subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_ddd + +subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzd(this_scalapack, this_data, a_scalapack, a_data, diag) + type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack + complex(dp), intent(out) :: this_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack + complex(dp), intent(in) :: a_data(:,:) + real(dp), intent(in) :: diag(:) + +#ifdef SCALAPACK + integer l_i, l_j, g_i, g_j + + do l_i=1, this_scalapack%l_N_R + do l_j=1, this_scalapack%l_N_C + call coords_local_to_global(this_scalapack, l_i, l_j, g_i, g_j) + this_data(l_i,l_j) = a_data(l_i,l_j) * diag(g_j) + end do + end do +#else + this_data = 0.0_dp +#endif +end subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzd + +subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzz(this_scalapack, this_data, a_scalapack, a_data, diag) + type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack + complex(dp), intent(out) :: this_data(:,:) + type(Matrix_ScaLAPACK_Info), intent(in) :: a_scalapack + complex(dp), intent(in) :: a_data(:,:) + complex(dp), intent(in) :: diag(:) + +#ifdef SCALAPACK + integer l_i, l_j, g_i, g_j + + do l_i=1, this_scalapack%l_N_R + do l_j=1, this_scalapack%l_N_C + call coords_local_to_global(this_scalapack, l_i, l_j, g_i, g_j) + this_data(l_i,l_j) = a_data(l_i,l_j) * diag(g_j) + end do + end do +#else + this_data = 0.0_dp +#endif +end subroutine ScaLAPACK_matrix_product_vect_asdiagonal_sub_zzz + +function ScaLAPACK_Re_diagZ(this_scalapack, this_data) + type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack + complex(dp), intent(in) :: this_data(:,:) + real(dp) :: ScaLAPACK_Re_diagZ(this_scalapack%N_R) + + integer :: g_i, l_i, l_j, p_i, p_j + ScaLAPACK_Re_diagZ = 0.0_dp + +#ifdef SCALAPACK + do g_i=1, this_scalapack%N_R + call coords_global_to_local(this_scalapack, g_i, g_i, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_Re_diagZ(g_i) = real(this_data(l_i, l_j)) + end do +#endif + +end function ScaLAPACK_Re_diagZ + +function ScaLAPACK_Re_diagD(this_scalapack, this_data) + type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack + real(dp), intent(in) :: this_data(:,:) + real(dp) :: ScaLAPACK_Re_diagD(this_scalapack%N_R) + + integer :: g_i, l_i, l_j, p_i, p_j + + ScaLAPACK_Re_diagD = 0.0_dp + +#ifdef SCALAPACK + do g_i=1, this_scalapack%N_R + call coords_global_to_local(this_scalapack, g_i, g_i, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_Re_diagD(g_i) = this_data(l_i, l_j) + end do +#endif + +end function ScaLAPACK_Re_diagD + +function ScaLAPACK_diag_spinorZ(this_scalapack, this_data) + type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack + complex(dp), intent(in) :: this_data(:,:) + complex(dp) :: ScaLAPACK_diag_spinorZ(2,2,this_scalapack%N_R/2) + + integer :: g_i, l_i, l_j, p_i, p_j + ScaLAPACK_diag_spinorZ = 0.0_dp + +#ifdef SCALAPACK + do g_i=1, this_scalapack%N_R,2 + call coords_global_to_local(this_scalapack, g_i, g_i, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_diag_spinorZ(1,1,(g_i-1)/2+1) = this_data(l_i, l_j) + call coords_global_to_local(this_scalapack, g_i+1, g_i, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_diag_spinorZ(2,1,(g_i-1)/2+1) = this_data(l_i, l_j) + call coords_global_to_local(this_scalapack, g_i, g_i+1, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_diag_spinorZ(1,2,(g_i-1)/2+1) = this_data(l_i, l_j) + call coords_global_to_local(this_scalapack, g_i+1, g_i+1, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_diag_spinorZ(2,2,(g_i-1)/2+1) = this_data(l_i, l_j) + end do +#endif + +end function ScaLAPACK_diag_spinorZ + +function ScaLAPACK_diag_spinorD(this_scalapack, this_data) + type(Matrix_ScaLAPACK_Info), intent(in) :: this_scalapack + real(dp), intent(in) :: this_data(:,:) + complex(dp) :: ScaLAPACK_diag_spinorD(2,2,this_scalapack%N_R/2) + + integer :: g_i, l_i, l_j, p_i, p_j + + ScaLAPACK_diag_spinorD = 0.0_dp + +#ifdef SCALAPACK + do g_i=1, this_scalapack%N_R, 2 + call coords_global_to_local(this_scalapack, g_i, g_i, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_diag_spinorD(1,1,(g_i-1)/2+1) = this_data(l_i, l_j) + call coords_global_to_local(this_scalapack, g_i+1, g_i, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_diag_spinorD(2,1,(g_i-1)/2+1) = this_data(l_i, l_j) + call coords_global_to_local(this_scalapack, g_i, g_i+1, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_diag_spinorD(1,2,(g_i-1)/2+1) = this_data(l_i, l_j) + call coords_global_to_local(this_scalapack, g_i+1, g_i+1, l_i, l_j, p_i, p_j) + if (p_i == this_scalapack%ScaLAPACK_obj%my_proc_row .and. & + p_j == this_scalapack%ScaLAPACK_obj%my_proc_col) & + ScaLAPACK_diag_spinorD(2,2,(g_i-1)/2+1) = this_data(l_i, l_j) + end do +#endif + +end function ScaLAPACK_diag_spinorD + +subroutine ScaLAPACK_pdgeqrf_wrapper(this, data, tau, work) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + real(dp), intent(inout), dimension(:,:) :: data + real(dp), intent(out), dimension(:), allocatable :: tau + real(dp), intent(out), dimension(:), allocatable :: work + + integer :: m, n, k, lwork, info + +#ifdef SCALAPACK + m = this%N_R + n = this%N_C + k = min(m, n) + + call reallocate(tau, k) + call reallocate(work, 1) + call pdgeqrf(m, n, data, 1, 1, this%desc, tau, work, -1, info) + lwork = work(1) + call reallocate(work, lwork) + call pdgeqrf(m, n, data, 1, 1, this%desc, tau, work, lwork, info) +#endif +end subroutine ScaLAPACK_pdgeqrf_wrapper + +subroutine ScaLAPACK_pdormqr_wrapper(A_info, A_data, C_info, C_data, tau, work) + type(Matrix_ScaLAPACK_Info), intent(in) :: A_info, C_info + real(dp), intent(inout), dimension(:,:) :: A_data, C_data + real(dp), intent(inout), dimension(:), allocatable :: tau + real(dp), intent(inout), dimension(:), allocatable :: work + + integer :: m, n, k, lwork, info + +#ifdef SCALAPACK + m = C_info%N_R + n = C_info%N_C + k = size(tau) + + call reallocate(work, 1) + call pdormqr('L', 'T', m, n, k, A_data, 1, 1, A_info%desc, & + tau, C_data, 1, 1, C_info%desc, work, -1, info) + lwork = work(1) + call reallocate(work, lwork) + call pdormqr('L', 'T', m, n, k, A_data, 1, 1, A_info%desc, & + tau, C_data, 1, 1, C_info%desc, work, lwork, info) +#endif +end subroutine ScaLAPACK_pdormqr_wrapper + +subroutine ScaLAPACK_pdtrtrs_wrapper(A_info, A_data, B_info, B_data, cheat_nb_A) + type(Matrix_ScaLAPACK_Info), intent(inout) :: A_info, B_info + real(dp), intent(inout), dimension(:,:) :: A_data ! distributed triangular matrix + real(dp), intent(inout), dimension(:,:) :: B_data ! + logical, intent(in) :: cheat_nb_A + + integer, parameter :: mb_ = 5, nb_ = 6 + integer :: n, nrhs, info, nb + +#ifdef SCALAPACK + n = min(A_info%N_R, A_info%N_C) + nrhs = B_info%N_C + + if (cheat_nb_A) then + nb = A_info%desc(nb_) + A_info%desc(nb_) = A_info%desc(mb_) + end if + + ! A(lda,n+), B(ldb,nrhs+) + call pdtrtrs('U', 'N', 'N', n, nrhs, A_data, 1, 1, A_info%desc, & + B_data, 1, 1, B_info%desc, info) + + if (cheat_nb_A) then + A_info%desc(nb_) = nb + end if + +#endif +end subroutine ScaLAPACK_pdtrtrs_wrapper + +subroutine ScaLAPACK_pdgemr2d_wrapper(A_info, A_data, B_info, B_data, glob_cntxt, m, n, ia, ja, ib, jb) + ! Copy general distributed submatrix A_data(ia:ia+m, ja:ja+n) to B_data(ib:ib+m, jb:jb+n) + type(Matrix_ScaLAPACK_Info), intent(in) :: A_info, B_info + real(dp), intent(in), dimension(:,:) :: A_data ! input distributed matrix + real(dp), intent(inout), dimension(:,:) :: B_data ! target distributed matrix + integer :: glob_cntxt ! Context spanning both A and B + integer :: m, n ! size of submatrix + integer, optional :: ia, ja ! start coords in A; defaults to (1, 1) + integer, optional :: ib, jb ! start coords in B; defaults to (1, 1) + + integer :: my_ia, my_ja, my_ib, my_jb + +#ifdef SCALAPACK + my_ia = optional_default(1, ia) + my_ja = optional_default(1, ja) + my_ib = optional_default(1, ib) + my_jb = optional_default(1, jb) + + call pdgemr2d(m, n, A_data, my_ia, my_ja, A_info%desc, & + B_data, my_ib, my_jb, B_info%desc, glob_cntxt) + +#endif +end subroutine ScaLAPACK_pdgemr2d_wrapper + +subroutine ScaLAPACK_pdtrmr2d_wrapper(uplo, diag, A_info, A_data, B_info, B_data, glob_cntxt, m, n, ia, ja, ib, jb) + ! Copy trapezoidal distributed submatrix A_data(ia:ia+m, ja:ja+n) to B_data(ib:ib+m, jb:jb+n) + character(len=1), intent(in) :: uplo, diag ! copy upper/lower triangle; copy diag + type(Matrix_ScaLAPACK_Info), intent(in) :: A_info, B_info + real(dp), intent(in), dimension(:,:) :: A_data ! input distributed matrix + real(dp), intent(inout), dimension(:,:) :: B_data ! target distributed matrix + + integer :: glob_cntxt ! Context spanning both A and B + integer :: m, n ! size of submatrix + integer, optional :: ia, ja ! start coords in A; defaults to (1, 1) + integer, optional :: ib, jb ! start coords in B; defaults to (1, 1) + + integer :: my_ia, my_ja, my_ib, my_jb + +#ifdef SCALAPACK + my_ia = optional_default(1, ia) + my_ja = optional_default(1, ja) + my_ib = optional_default(1, ib) + my_jb = optional_default(1, jb) + + call pdtrmr2d(uplo, diag, m, n, A_data, my_ia, my_ja, A_info%desc, & + B_data, my_ib, my_jb, B_info%desc, glob_cntxt) + +#endif +end subroutine ScaLAPACK_pdtrmr2d_wrapper + +subroutine ScaLAPACK_matrix_QR_solve(A_info, A_data, B_info, B_data, cheat_nb_A) + type(Matrix_ScaLAPACK_Info), intent(inout) :: A_info, B_info + real(dp), intent(inout), dimension(:,:) :: A_data, B_data + logical, intent(in) :: cheat_nb_A + + real(dp), dimension(:), allocatable :: tau, work + + call ScaLAPACK_pdgeqrf_wrapper(A_info, A_data, tau, work) + call ScaLAPACK_pdormqr_wrapper(A_info, A_data, B_info, B_data, tau, work) + call ScaLAPACK_pdtrtrs_wrapper(A_info, A_data, B_info, B_data, cheat_nb_A) +end subroutine ScaLAPACK_matrix_QR_solve + +subroutine ScaLAPACK_to_array1d(A_info, A_data, array) + type(Matrix_ScaLAPACK_Info), intent(in) :: A_info + real(dp), intent(in), dimension(:,:) :: A_data + real(dp), intent(out), dimension(:) :: array + + integer :: info + integer :: nrows, ncols + integer, dimension(9) :: desc + +#ifdef SCALAPACK + nrows = min(A_info%N_R, size(array, 1)) + ncols = 1 + array(nrows+1:) = 0.0_dp + call descinit(desc, nrows, ncols, nrows, ncols, 0, 0, & + A_info%ScaLAPACK_obj%blacs_context, size(array, 1), info) + call pdgeadd("N", nrows, ncols, 1.0_dp, A_data, 1, 1, A_info%desc, & + 0.0_dp, array, 1, 1, desc) +#endif +end subroutine ScaLAPACK_to_array1d + +subroutine ScaLAPACK_to_array2d(A_info, A_data, array) + type(Matrix_ScaLAPACK_Info), intent(in) :: A_info + real(dp), intent(in), dimension(:,:) :: A_data + real(dp), intent(out), dimension(:,:) :: array + + integer :: info + integer, dimension(9) :: desc + +#ifdef SCALAPACK + call descinit(desc, A_info%N_R, A_info%N_C, A_info%N_R, A_info%N_C, 0, 0, & + A_info%ScaLAPACK_obj%blacs_context, A_info%N_R, info) + call pdgeadd("N", A_info%N_R, A_info%N_C, 1.0_dp, A_data, 1, 1, A_info%desc, & + 0.0_dp, array, 1, 1, desc) +#endif +end subroutine ScaLAPACK_to_array2d + +! returns 64bit minimal work array length for pdgeqrf from 32bit sources +! adapted from documentation of pdgeqrf +function get_lwork_pdgeqrf_i32o64(m, n, ia, ja, mb_a, nb_a, & + myrow, mycol, rsrc_a, csrc_a, nprow, npcol) result(lwork) + integer, intent(in) :: m, n, ia, ja, mb_a, nb_a + integer, intent(in) :: myrow, mycol, rsrc_a, csrc_a, nprow, npcol + integer(idp) :: lwork + + integer :: iarow, iacol, iroff, icoff + integer(idp) :: mp0, nq0, nb64 + + lwork = 0 + +#ifdef SCALAPACK + iroff = mod(ia-1, mb_a) + icoff = mod(ja-1, nb_a) + iarow = indxg2p(ia, mb_a, myrow, rsrc_a, nprow) + iacol = indxg2p(ja, nb_a, mycol, csrc_a, npcol) + mp0 = numroc(m+iroff, mb_a, myrow, iarow, nprow) + nq0 = numroc(n+icoff, nb_a, mycol, iacol, npcol) + + nb64 = int(nb_a, idp) + lwork = nb64 * (mp0 + nq0 + nb64) +#endif +end function get_lwork_pdgeqrf_i32o64 + +function ScaLAPACK_get_lwork_pdgeqrf(this, m, n, mb_a, nb_a) result(lwork) + type(ScaLAPACK), intent(in) :: this + integer, intent(in) :: m, n, mb_a, nb_a + integer(idp) :: lwork + + integer, parameter :: ia = 1, ja = 1, rsrc_a = 0, csrc_a = 0 + + lwork = 0 + +#ifdef SCALAPACK + lwork = get_lwork_pdgeqrf(m, n, ia, ja, mb_a, nb_a, & + this%my_proc_row, this%my_proc_col, rsrc_a, csrc_a, & + this%n_proc_rows, this%n_proc_cols) +#endif +end function ScaLAPACK_get_lwork_pdgeqrf + +function ScaLAPACK_matrix_get_lwork_pdgeqrf(this) result(lwork) + type(Matrix_ScaLAPACK_Info), intent(in) :: this + integer(idp) :: lwork + + lwork = 0 + +#ifdef SCALAPACK + lwork = get_lwork_pdgeqrf(this%ScaLAPACK_obj, this%N_R, this%N_C, this%NB_R, this%NB_C) +#endif +end function ScaLAPACK_matrix_get_lwork_pdgeqrf + +! returns 64bit minimal work array length for pdormqr from 32bit sources +! adapted from documentation of pdormqr +function get_lwork_pdormqr_i32o64(side, m, n, ia, ja, mb_a, nb_a, ic, jc, & + mb_c, nb_c, myrow, mycol, rsrc_a, csrc_a, rsrc_c, csrc_c, nprow, npcol) result(lwork) + character :: side + integer, intent(in) :: m, n, ia, ja, mb_a, nb_a + integer, intent(in) :: ic, jc, mb_c, nb_c + integer, intent(in) :: rsrc_a, csrc_a, rsrc_c, csrc_c + integer, intent(in) :: myrow, mycol, nprow, npcol + integer(idp) :: lwork + + integer :: lcm, lcmq + integer :: iarow, iroffa, icoffa, iroffc, icoffc, icrow, iccol + integer(idp) :: npa0, mpc0, nqc0, nr, nb64, lwork1, lwork2 + + lwork = 0 + +#ifdef SCALAPACK + iroffc = mod(ic-1, mb_c) + icoffc = mod(jc-1, nb_c) + icrow = indxg2p(ic, mb_c, myrow, rsrc_c, nprow) + iccol = indxg2p(jc, nb_c, mycol, csrc_c, npcol) + mpc0 = numroc(m+iroffc, mb_c, myrow, icrow, nprow) + nqc0 = numroc(n+icoffc, nb_c, mycol, iccol, npcol) + + nb64 = int(nb_a, idp) + lwork1 = (nb64 * (nb64 - 1)) / 2 + if (side == 'L') then + lwork2 = (nqc0 + mpc0) * nb64 + else if (side == 'R') then + iroffa = mod(ia-1, mb_a) + icoffa = mod(ja-1, nb_a) + iarow = indxg2p(ia, mb_a, myrow, rsrc_a, nprow) + npa0 = numroc(n+iroffa, mb_a, myrow, iarow, nprow) + + lcm = ilcm(nprow, npcol) + lcmq = lcm / npcol + nr = numroc(n+icoffc, nb_a, 0, 0, npcol) + nr = numroc(int(nr, isp), nb_a, 0, 0, lcmq) + nr = max(npa0 + nr, mpc0) + lwork2 = (nqc0 + nr) * nb64 + end if + lwork = max(lwork1, lwork2) + nb64 * nb64 +#endif +end function get_lwork_pdormqr_i32o64 + +function ScaLAPACK_get_lwork_pdormqr(this, side, m, n, mb_a, nb_a, mb_c, nb_c) result(lwork) + type(ScaLAPACK), intent(in) :: this + character :: side + integer, intent(in) :: m, n, mb_a, nb_a, mb_c, nb_c + integer(idp) :: lwork + + integer, parameter :: ia = 1, ja = 1, rsrc_a = 0, csrc_a = 0 + integer, parameter :: ic = 1, jc = 1, rsrc_c = 0, csrc_c = 0 + + lwork = 0 + +#ifdef SCALAPACK + lwork = get_lwork_pdormqr(side, m, n, ia, ja, mb_a, nb_a, ic, jc, mb_c, nb_c, & + this%my_proc_row, this%my_proc_col, rsrc_a, csrc_a, rsrc_c, csrc_c, & + this%n_proc_rows, this%n_proc_cols) +#endif +end function ScaLAPACK_get_lwork_pdormqr + +function ScaLAPACK_matrix_get_lwork_pdormqr(A_info, C_info, side) result(lwork) + type(Matrix_ScaLAPACK_Info), intent(in) :: A_info, C_info + character :: side + integer(idp) :: lwork + + lwork = 0 + +#ifdef SCALAPACK + lwork = get_lwork_pdormqr(A_info%ScaLAPACK_obj, side, C_info%N_R, & + C_info%N_C, A_info%NB_R, A_info%NB_C, A_info%NB_R, A_info%NB_C) +#endif +end function ScaLAPACK_matrix_get_lwork_pdormqr + +end module ScaLAPACK_module diff --git a/src/libAtoms/SocketTools.F90 b/src/libAtoms/SocketTools.F90 new file mode 100644 index 0000000000..b39b472e53 --- /dev/null +++ b/src/libAtoms/SocketTools.F90 @@ -0,0 +1,326 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +!% Routines to send and receive data via TCP/IP sockets + +module SocketTools_module + + use iso_c_binding + + use error_module + use system_module, only: dp, print, operator(//) + use extendable_str_module, only: Extendable_Str + use atoms_types_module, only: Atoms + use cinoutput_module, only: read, write + + implicit none + + private + + integer, parameter :: MSG_LEN_SIZE = 8 + integer, parameter :: MSG_END_MARKER_SIZE = 5 + character(MSG_END_MARKER_SIZE), parameter :: MSG_END_MARKER = 'done.' + character(6), parameter :: MSG_INT_FORMAT = 'i6' + character(6), parameter :: MSG_FLOAT_FORMAT = 'f25.16' + integer, parameter :: MSG_INT_SIZE = 6, MSG_FLOAT_SIZE = 25 + integer, parameter :: MAX_ATTEMPTS = 5 + + interface + function quip_recv_data(ip, port, client_id, request_code, data, data_len) bind(c) + use iso_c_binding + integer(kind=C_INT) :: quip_recv_data + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: ip + integer(kind=C_INT), intent(in), value :: port, client_id + character(kind=C_CHAR,len=1), intent(in) :: request_code + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: data + integer(kind=C_INT), intent(inout) :: data_len + end function quip_recv_data + + function quip_send_data(ip, port, client_id, request_code, data, data_len) bind(c) + use iso_c_binding + integer(kind=C_INT) :: quip_send_data + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: ip + integer(kind=C_INT), intent(in), value :: port, client_id + character(kind=C_CHAR,len=1), intent(in) :: request_code + character(kind=C_CHAR,len=1), dimension(*), intent(in) :: data + integer(kind=C_INT), intent(in), value :: data_len + end function quip_send_data + end interface + + public :: socket_send_reftraj, socket_recv_reftraj, socket_send_xyz, socket_recv_xyz + +contains + + subroutine socket_send_reftraj(ip, port, client_id, label, n_atoms, energy, force, virial, error) + character(*), intent(in) :: ip + integer, intent(in) :: port, client_id, label, n_atoms + real(dp), intent(in) :: energy, force(:,:), virial(3,3) + integer, optional, intent(out) :: error + + character(len_trim(ip)+1) :: c_ip + integer(kind=C_INT) :: c_port, c_client_id, data_len, status + character(kind=C_CHAR, len=1), dimension(:), pointer :: data + character(1024) :: line + integer i, j, n, attempt + + INIT_ERROR(error) + + c_ip = trim(ip)//C_NULL_CHAR + c_port = port + c_client_id = client_id + + ! space for label, n_atoms, 1 energy, 3*N force components and 6 virial components, separated by N+3 newlines + data_len = 2*MSG_INT_SIZE + MSG_FLOAT_SIZE*(1 + size(force) + 6) + size(force,2)+3 + allocate(data(data_len)) + i = 1 + + ! first line is label + write(line, '('//MSG_INT_FORMAT//')') label + do j=1,len_trim(line) + data(i) = line(j:j) + i = i + 1 + end do + data(i) = C_NEW_LINE + i = i + 1 + + ! second line is n_atoms + write(line, '('//MSG_INT_FORMAT//')') n_atoms + do j=1,len_trim(line) + data(i) = line(j:j) + i = i + 1 + end do + data(i) = C_NEW_LINE + i = i + 1 + + ! third line is energy + write(line, '('//MSG_FLOAT_FORMAT//')') energy + do j=1,len_trim(line) + data(i) = line(j:j) + i = i + 1 + end do + data(i) = C_NEW_LINE + i = i + 1 + + ! next are the 3*N forces, three components per line + do n = 1, size(force, 2) + write(line,'(3'//MSG_FLOAT_FORMAT//')') force(:, n) + do j=1,len_trim(line) + data(i) = line(j:j) + i = i + 1 + end do + data(i) = C_NEW_LINE + i = i + 1 + end do + + ! finally the virial, as six components in order xx yy zz xy yz xz (NB: not Voigt order) + write(line, '(6'//MSG_FLOAT_FORMAT//')') & + virial(1,1), virial(2,2), virial(3,3), virial(1,2), virial(2,3), virial(1,3) + do j=1,len_trim(line) + data(i) = line(j:j) + i = i + 1 + end do + ! no newline at end of data + + !write(*,*) 'after packing, i=', i, 'data_len=', data_len + !write (*,*) 'data=' + !write (*,*) data + + do attempt = 1, MAX_ATTEMPTS + ! Send data with request code 'R' (results) + status = quip_send_data(c_ip, c_port, c_client_id, 'R', data, data_len) + if (status == 0) exit + call fusleep(100000) ! wait 0.1 seconds + end do + if (status /= 0) then + RAISE_ERROR('fatal error sending data over socket', error) + end if + + deallocate(data) + + end subroutine socket_send_reftraj + + + subroutine socket_recv_reftraj(ip, port, client_id, buff_size, label, n_atoms, lattice, frac_pos, error) + character(*), intent(in) :: ip + integer, intent(in) :: port, client_id + integer, intent(in) :: buff_size + integer, intent(out) :: label, n_atoms + real(dp), intent(out), dimension(:,:) :: lattice, frac_pos + integer, optional, intent(out) :: error + + character(len_trim(ip)+1) :: c_ip + integer(kind=C_INT) :: c_port, c_client_id, data_len, status + character(kind=C_CHAR, len=1), dimension(:), pointer :: data + character(1024) :: line + integer i, j, lineno, attempt + + INIT_ERROR(error) + + c_ip = trim(ip)//C_NULL_CHAR + c_port = port + c_client_id = client_id + + data_len = buff_size + allocate(data(data_len)) + + do attempt = 1, MAX_ATTEMPTS + ! Receive data with request code 'A' (atoms in REFTRAJ format) + status = quip_recv_data(c_ip, c_port, c_client_id, 'A', data, data_len) + if (status == 0) exit + call fusleep(100000) ! wait 0.1 seconds + end do + if (status /= 0) then + RAISE_ERROR('fatal error receiving data over socket', error) + end if + + i = 1 + lineno = 0 + do while (i < data_len) + line = '' + j = 1 + do while (data(i) /= C_NEW_LINE) + line(j:j) = data(i) + i = i + 1 + j = j + 1 + end do + lineno = lineno + 1 + i = i + 1 ! skip the newline character + + if (lineno == 1) then + read (line,*) label + else if (lineno == 2) then + read (line,*) n_atoms + if (size(frac_pos, 2) < n_atoms) then + RAISE_ERROR('insufficient space to store received data', error) + end if + else if (lineno > 2 .and. lineno <= 5) then + read (line, *) lattice(lineno-2, :) + else if (lineno > 5 .and. lineno <= 5+n_atoms) then + read (line, *) frac_pos(1, lineno-5), frac_pos(2, lineno-5), frac_pos(3, lineno-5) + else + RAISE_ERROR('unexpected line '//trim(line), error) + end if + end do + deallocate(data) + + end subroutine socket_recv_reftraj + + + subroutine socket_send_xyz(ip, port, client_id, at, error, properties) + character(*), intent(in) :: ip + integer, intent(in) :: port, client_id + type(Atoms), intent(inout) :: at + integer, optional, intent(out) :: error + character(len=*), intent(in), optional :: properties + + character(len_trim(ip)+1) :: c_ip + integer(kind=C_INT) :: c_port, c_client_id, data_len, status + character(kind=C_CHAR, len=1), dimension(:), pointer :: data + integer i, j, n, attempt + type(Extendable_Str) :: estr + + INIT_ERROR(error) + + c_ip = trim(ip)//C_NULL_CHAR + c_port = port + c_client_id = client_id + + call write(at, estr=estr, properties=properties) ! write Atoms to extendable str + ! convert estr to C string + data_len = estr%len + allocate(data(data_len)) + do i=1, data_len + data(i) = estr%s(i) + end do + + do attempt = 1, MAX_ATTEMPTS + call print('socket_send_xyz() calling quip_send_data attempt='//attempt) + ! Send data with request code 'Y' (XYZ results) + status = quip_send_data(c_ip, c_port, c_client_id, 'Y', data, data_len) + if (status == 0) exit + call fusleep(100000) ! wait 0.1 seconds + end do + if (status /= 0) then + RAISE_ERROR('fatal error sending data over socket', error) + end if + + deallocate(data) + + end subroutine socket_send_xyz + + + subroutine socket_recv_xyz(ip, port, client_id, buff_size, at, error) + character(*), intent(in) :: ip + integer, intent(in) :: port, client_id + integer, intent(in) :: buff_size + type(Atoms), intent(out) :: at + integer, optional, intent(out) :: error + + character(len_trim(ip)+1) :: c_ip + integer(kind=C_INT) :: c_port, c_client_id, data_len, status + character(kind=C_CHAR, len=1), dimension(:), pointer :: data + character(len=buff_size) :: fdata + integer i, attempt + + INIT_ERROR(error) + + c_ip = trim(ip)//C_NULL_CHAR + c_port = port + c_client_id = client_id + + data_len = buff_size + allocate(data(data_len)) + + do attempt = 1, MAX_ATTEMPTS + call print('socket_recv_xyz() calling quip_recv_data attempt='//attempt) + ! Receive data with request code 'X' (receive atoms in XYZ format) + status = quip_recv_data(c_ip, c_port, c_client_id, 'X', data, data_len) + if (status == 0) exit + call fusleep(100000) ! wait 0.1 seconds + end do + if (status /= 0) then + RAISE_ERROR('fatal error receiving data over socket', error) + end if + ! convert from C to Fortran string + do i=1, data_len + fdata(i:i) = data(i) + end do + !call print('recieved data <'//fdata//'>') + ! read from fdata string into Atoms in XYZ format + call read(at, str=fdata, error=error) + PASS_ERROR(error) + deallocate(data) + + end subroutine socket_recv_xyz + + +end module SocketTools_Module diff --git a/src/libAtoms/Sparse.F90 b/src/libAtoms/Sparse.F90 new file mode 100644 index 0000000000..445c7f5186 --- /dev/null +++ b/src/libAtoms/Sparse.F90 @@ -0,0 +1,724 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Sparse module +!X +!X Sparse matrix representation and algebra +!X +!X +!X Table: +!X int : [................] column indices +!X real: [................] nonzero elements +!X +!X rows: integer array that holds the starting indices of each row in +!X the table +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module sparse_module + use system_module + use linearalgebra_module + use table_module +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif + + implicit none +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif + private + SAVE + + public :: sparse, print, print_full, operator(.mult.), assignment(=), sparse_init, sparse_finalise + + type Sparse + type(table)::table ! values + integer,allocatable::rows(:) ! indexes + integer::Nrows ! number of rows + integer::Ncols ! number of colummns + end type Sparse + + real(dp), parameter :: SPARSITY_GUESS = 0.01_dp ! A guess at the sparsity of the input matrices + ! to sparse_assign_matrix + + interface assignment(=) + module procedure sparse_assign_matrix,matrix_assign_sparse,& + sparse_assign_sparse + end interface assignment(=) + + interface operator(.mult.) + module procedure sparse_mult_vector, vector_mult_sparse, sparse_mult_sparse + end interface + + interface print + module procedure sparse_print + end interface print + + interface print_full + module procedure sparse_print_full + end interface print_full + +contains + + ! just init + subroutine sparse_init(this,Nrows,Ncols,Nmax) + type(sparse):: this + integer, optional::Nmax ! maximum number of nonzero elements + integer::Nrows,Ncols ! size of the matrix + + call allocate(this%table,1,1,0,0,Nmax) + call reallocate(this%rows,Nrows+1) + this%Nrows = Nrows + this%Ncols = Ncols + this%rows = 1 + + end subroutine sparse_init + + subroutine sparse_finalise(this) + type(sparse)::this + call finalise(this%table) + if(allocated(this%rows))deallocate(this%rows) + end subroutine sparse_finalise + + + !overloading assignment + subroutine sparse_assign_sparse(this,other) + type(sparse),intent(OUT):: this + type(sparse),intent(IN):: other + this%Nrows = other%Nrows + this%Ncols = other%Ncols + this%table = other%table + call reallocate(this%rows,this%Nrows+1) + this%rows = other%rows + end subroutine sparse_assign_sparse + + ! assignment + subroutine sparse_assign_matrix(this,matrix) + type(sparse), intent(out) :: this + real(dp), intent(in) :: matrix(:,:) + integer :: Nmax, i, j + + Nmax = int( SPARSITY_GUESS * real(size(matrix),dp) ) + + call sparse_init(this, size(matrix,1), size(matrix,2), Nmax) + + do i=1,this%Nrows + this%rows(i) = this%table%N+1 + + do j=1,this%Ncols + + if (abs(matrix(i,j)) > NUMERICAL_ZERO ) then + call append(this%table,realpart=(matrix(i,j)),intpart=j) + end if + + end do + + end do + + ! last value in rows() + this%rows(this%Nrows+1) = this%table%N+1 + + if(this%table%N == 0) then ! give warning + call print('sparse_assign_matrix: no nonzero elements!') + end if + + ! now truncate the length + call allocate(this%table) + + end subroutine sparse_assign_matrix + + + subroutine matrix_assign_sparse(matrix,sp) + type(sparse),intent(IN):: sp + real(dp),intent(OUT)::matrix(sp%Nrows,sp%Ncols) + integer::i,j + + call sparse_check(sp,"matrix_assign_sparse") + + matrix=0.0_dp + do i = 1,sp%Nrows + do j = sp%rows(i),sp%rows(i+1)-1 + matrix(i,sp%table%int(1,j)) = sp%table%real(1,j) + end do + end do + end subroutine matrix_assign_sparse + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X X + !X Routines for constructing/reading sparse matrices X + !X X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + ! Return the (i,j)th element of the sparse matrix + ! + function sparse_element(this,i,j) + + type(sparse), intent(in) :: this + integer, intent(in) :: i, j + real(dp) :: sparse_element + integer :: n + + call sparse_check_bounds(this,i,j,'Sparse_Element') + + sparse_element = 0.0_dp + + do n = this%rows(i), this%rows(i+1) - 1 + if (this%table%int(1,n) > j) exit ! The requested element is 0.0 + if (this%table%int(1,n) == j) then ! The requested element is stored + sparse_element = this%table%real(1,n) + exit + end if + end do + + end function sparse_element + + ! + ! Return the number of stored elements + ! + function sparse_stored_elements(this) + + type(sparse), intent(in) :: this + integer :: sparse_stored_elements + + sparse_stored_elements = this%table%N + + end function sparse_stored_elements + + ! + ! Zero all elements of a sparse matrix (keeping storage) + ! + subroutine sparse_zero(this) + + type(sparse), intent(inout) :: this + + this%table%real = 0.0_dp + + + end subroutine sparse_zero + + ! + ! Copy 'val' into the (i,j)th element of the sparse matrix + ! + ! The optional logical 'nocheck', when present and true, supresses the deletion of an element + ! if we set it to zero. This can be used to insert placeholders for future non-zero values, but note + ! that these will be classed as 'non-zero' in sparse_non_zero + ! + subroutine sparse_set_element(this,i,j,val,nocheck) + + type(sparse), intent(inout) :: this + integer, intent(in) :: i,j + real(dp), intent(in) :: val + logical, optional, intent(in) :: nocheck + !local variables + integer :: n, table_pos, intpart, tmp_intpart + logical :: element_written, my_nocheck + real(dp) :: realpart, tmp_realpart + + if (present(nocheck)) then + my_nocheck = nocheck + else + my_nocheck = .false. + end if + + ! If we are setting a value to zero and nocheck is false then call delete_element instead + if (.not.my_nocheck) then + if (abs(val) < NUMERICAL_ZERO) then + call sparse_delete_element(this,i,j) + return + end if + end if + + ! Check the element we are setting is a valid one + call sparse_check_bounds(this,i,j,'Sparse_Set_Element') + + !**** SHOULD WE USE A BINARY SEARCH TO FIND THE CORRECT INSERTION POINT? **** + + ! First find the place in table where the element will be inserted, or where it already exists + table_pos = this%rows(i) + element_written = .false. + do n = this%rows(i), this%rows(i+1) - 1 + + if (this%table%int(1,table_pos) > j) exit ! We've found the insertion point + + if (this%table%int(1,n) == j) then + ! The element already exists, so just write the value + this%table%real(1,n) = val + element_written = .true. + exit + end if + + table_pos = table_pos + 1 + + end do + + ! Now, either the element has been written (so we can return) or the insertion point is in table_pos + if (element_written) return + + ! Append a blank element to 'table', insert the new value and shift the other entries down + call append(this%table,(/0/),(/0.0_dp/)) + intpart = j + realpart = val + do n = table_pos, this%table%N + !Make a temporary copy of the data that is already there + tmp_intpart = this%table%int(1,n) + tmp_realpart = this%table%real(1,n) + !Copy in the new elements + this%table%int(1,n) = intpart + this%table%real(1,n) = realpart + !Make the tmp_ variables the next to be written back to the table + intpart = tmp_intpart + realpart = tmp_realpart + end do + + ! Lastly, all the row pointers for rows i+1 upwards need incrementing + forall(n=i+1:this%Nrows+1) this%rows(n) = this%rows(n) + 1 + + end subroutine sparse_set_element + + ! + ! Search for the (i,j)th element and if it exists delete it (i.e. set it to zero) + ! + subroutine sparse_delete_element(this,i,j) + + type(sparse), intent(inout) :: this + integer, intent(in) :: i,j + integer :: n, table_pos + + call sparse_check_bounds(this,i,j,'Sparse_Delete_Element') + + table_pos = 0 + do n = this%rows(i), this%rows(i+1) - 1 + if (this%table%int(1,n) > j) return ! The element is already 0.0 + if (this%table%int(1,n) == j) then + ! We've found the element to be deleted + table_pos = n + exit + end if + end do + + if (table_pos==0) return !The element didn't exist + + ! Shift all the succeeding table entries back by one + do n = table_pos, this%table%N - 1 + this%table%int(1,n) = this%table%int(1,n+1) + this%table%real(1,n) = this%table%real(1,n+1) + end do + + ! Then delete the last entry + call delete(this%table,this%table%N) + + ! Decrement the row pointers for rows i+1 upwards by one + forall(n=i+1:this%Nrows+1) this%rows(n) = this%rows(n) - 1 + + end subroutine sparse_delete_element + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X X + !X BLAS X + !X X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function sparse_mult_vector(this,vectin) result (vectout) + real(dp),intent(IN)::vectin(:) + type(sparse),intent(IN)::this + real(dp)::vectout(this%Nrows) + integer::i,j +#ifdef _MPI + integer::mpi_size, mpi_rank, PRINT_ALWAYS + real(dp)::vectout_all(this%Nrows) + + vectout_all = 0.0_dp + call get_mpi_size_rank(MPI_COMM_WORLD, mpi_size, mpi_rank) +#endif + + call sparse_check(this, "sparse_mult_vector") + if (this%Ncols .ne. size(vectin)) then + write(line, *) 'sparse_mult_vector: mismatched matrix(',this%Nrows,',',this%Ncols,') and vector(',size(vectin),')!' + call System_Abort(line) + end if + + vectout=0.0_dp + do i=1,this%Nrows +#ifdef _MPI + ! cycle loop if processor rank does not match + if(mod(i, mpi_size) .ne. mpi_rank) cycle +#endif + do j= this%rows(i),this%rows(i+1)-1 + vectout(i)=vectout(i)+this%table%real(1,j)*vectin(this%table%int(1,j)) + end do + end do + +#ifdef _MPI + ! collect mpi results + call MPI_ALLREDUCE(vectout, vectout_all, & + size(vectout), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, PRINT_ALWAYS) + call abort_on_mpi_error(PRINT_ALWAYS, "Sparse .mult. vector: MPI_ALL_REDUCE()") + vectout = vectout_all +#endif + end function sparse_mult_vector + + + function vector_mult_sparse(vectin,this) result(vectout) + real(dp),intent(IN)::vectin(:) + type(sparse),intent(IN)::this + real(dp)::vectout(this%Ncols) + integer::N,i,k,M +#ifdef _MPI + integer::mpi_size, mpi_rank, PRINT_ALWAYS + real(dp)::vectout_all(this%Ncols) + + vectout_all = 0.0_dp + call get_mpi_size_rank(MPI_COMM_WORLD, mpi_size, mpi_rank) +#endif + + N=this%Nrows + M=this%Ncols + + call sparse_check(this, "vector_mult_sparse") + + if (N .NE. size(vectin)) then + call system_abort("sparse_product_vect:'mismatched vector and matrix!") + end if + + + vectout=0.0_dp + do i=1,N +#ifdef _MPI + ! cycle loop if processor rank does not match + if(mod(i, mpi_size) .ne. mpi_rank) cycle +#endif + do k= this%rows(i),this%rows(i+1)-1 + vectout(this%table%int(1,k))=vectout(this%table%int(1,k))+this%table%real(1,k)*vectin(i) + end do + end do +#ifdef _MPI + ! collect mpi results + call MPI_ALLREDUCE(vectout, vectout_all, & + size(vectout), MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, PRINT_ALWAYS) + call abort_on_mpi_error(PRINT_ALWAYS, "Sparse .mult. vector: MPI_ALL_REDUCE()") + vectout = vectout_all +#endif + end function vector_mult_sparse + + + ! + ! Tr(sparse*matrix) + ! + function trace_sparse_mult_matrix(this,matrix) result(tr) + type(sparse),intent(IN)::this + real(dp),intent(IN)::matrix(:,:) + real(dp)::tr + integer::i,j + + call sparse_check(this,"sparce_tracemult_matrix") + if(this%Nrows .ne. size(matrix,1)) then + call system_abort("trace_sparse_mult_matrix: size of sparse and matrix mismatch ") + end if + + tr = 0.0_dp + + do i = 1,size(matrix,1) + do j = this%rows(i),this%rows(i+1)-1 + tr = tr +this%table%real(1,j) * matrix(i,this%table%int(1,j)) + end do + end do + + end function trace_sparse_mult_matrix + + ! + ! Sparse_CFCT : (Sparse matrix C) * (diagonal matrix F) * (Transpose of C) + ! + function sparse_cfct(c,f) result(res) + + type(Sparse), intent(in) :: c + real(dp), dimension(:), intent(in) :: f + type(Sparse) :: res + integer :: i,j,k,n + real(dp) :: val + + if (size(f) /= c%Ncols) call System_Abort('Sparse_CFCT: Number of elements in F is not equal to number of rows in C') + + ! Initialise the output matrix + call Sparse_Init(res,c%Nrows,c%Nrows) + + ! Sparse matrix storage stores elements in the same row together, so make the loop over + ! the columns go faster. Also, the matrix is symmetric so only half the working is needed + do i = 1, c%Nrows + + do j = 1, i - 1 ! Just copy the pre-worked out values into the lower triangle + val = sparse_element(res,j,i) + if (abs(val) > NUMERICAL_ZERO) call sparse_set_element(res,i,j,val) + end do + + do j = i, c%Nrows ! Actually work out the upper triangle of values + val = 0.0_dp + do n = c%rows(i), c%rows(i+1)-1 + k = c%table%int(1,n) + val = val + sparse_element(c,i,k) * f(k) * sparse_element(c,j,k) + end do + if (abs(val) > NUMERICAL_ZERO) call sparse_set_element(res,i,j,val) + end do + + end do + + end function sparse_cfct + + function sparse_mult_sparse(a,b) result(res) + + type(sparse), intent(in) :: a,b + type(sparse) :: res + !local variables + integer :: i,j,n + real(dp) :: val + + !Check sizes + if (a%Ncols /= b%Nrows) call System_Abort('Sparse_Mult_Sparse: Argument 1 rows /= argument 2 columns') + + call Sparse_Init(res,a%Nrows,b%Ncols) + + do i = 1, a%Nrows + do j = 1, b%Ncols + val = 0.0_dp + do n = a%rows(i), a%rows(i+1)-1 + val = val + a%table%real(1,n) * sparse_element(b, a%table%int(1,n), j) + end do + if (abs(val) > NUMERICAL_ZERO) call sparse_set_element(res,i,j,val) + end do + end do + + end function sparse_mult_sparse + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X X + !X Printing X + !X X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine sparse_print(this,verbosity,out) + type(sparse),intent(in)::this + integer, optional::verbosity + type(inoutput),intent(inout),optional::out + + call sparse_check(this,"sparse_print") + write(line,'(a,i0,a,i0)')'Sparse matrix: Nrows = ',this%Nrows,' Ncols = ',this%Ncols + call print(line,verbosity, out) + call print('row indices:', verbosity, out) + call print(this%rows, verbosity, out) + call print(' Column Value', verbosity, out) + call print(this%table, verbosity, out) + end subroutine sparse_print + + subroutine sparse_print_full(this,verbosity,out) + + type(sparse), intent(in) :: this + integer, optional :: verbosity + type(inoutput),intent(in), optional :: out + real(dp) :: row(this%Ncols) + integer :: i, j + character(13) :: format + + call sparse_check(this,"sparse_print_full") + if (this%Ncols >= 1e6) & + call system_abort('Sparse_Print_Full: Tried to print a matrix with > 1M columns. Are you crazy?!?') + write(format,'(a,i0,a)')'(',this%Ncols,'f14.5)' + + do j = 1, this%Nrows + row = 0.0_dp + do i = this%rows(j), this%rows(j+1) - 1 + row( this%table%int(1,i) ) = this%table%real(1,i) + end do + write(line,format) row + call Print(line,verbosity,out) + end do + + end subroutine sparse_print_full + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X X + !X Miscellaneous checking routines X + !X X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + ! Check if the element (i,j) is within the bounds of 'this'. caller is the calling routine + ! + subroutine sparse_check_bounds(this,i,j,caller) + + type(Sparse), intent(in) :: this + integer, intent(in) :: i,j + character(*), intent(in) :: caller + + if (i > this%Nrows .or. j > this%Ncols) then + write(line,'(4(a,i0),a)') caller//': Element (',i,',',j,') is out of range (',& + this%Nrows,',',this%Ncols,')' + call System_Abort(line) + end if + + end subroutine sparse_check_bounds + + ! + ! Check the input is a valid sparse matrix. caller is the calling routine. + ! + subroutine sparse_check(this,caller) + + type(sparse), intent(in) :: this + character(*) :: caller + integer :: m + + if (.not. allocated(this%rows)) then + write(line,'(a)')"In "//caller//":" + call Print(line) + call System_Abort("Sparse_check: sparse%rows is unallocated") + end if + + m = size(this%rows) + if( (this%rows(m) /= this%table%N+1) .or. (m /= this%Nrows+1) ) then + write(line,'(a)')"In "//caller//":" + call Print(line) + call System_Abort("Sparse_check: sparse rows and table size mismatch") + end if + + end subroutine sparse_check + + ! + ! Subroutine to test the sparse module is functioning properly + ! NOTE: does not include tests for all features + ! + subroutine sparse_test + type(sparse)::sparse1,sparse3 + real(dp),allocatable::a(:,:),b(:,:),c(:,:),vect(:),vectout(:) + allocate(a(5,5),b(5,5),c(5,5),vect(5)) + write(line,*) 'SPARSE TEST';call print(line) + + + a=0.0_dp + a(1,1)=3 + a(1,3)=1 + a(2,2)=4 + a(3,2)=7 + a(3,3)=5 + a(3,4)=9 + a(4,5)=2 + a(5,4)=6 + a(5,5)=5 + write(line,*) 'MATRIX A IS:';call print(line) + call print(a) + c=a + + write(line,*) 'Now we assign it to a sparse';call print(line) + ! call sparse_assign_matrix(sparse1,a) + sparse3=a + + write(line,*) 'Now we assign a sparse to a sparse';call print(line) + ! call sparse_assign_matrix(sparse1,a) + sparse1=sparse3 + + call sparse_check(sparse1,"This message should not be seen") + write(line,*) 'Structure of the sparse';call print(line) + write(line,*) 'And its content';call print(line) + call print(sparse1) + write(line,*) 'Now we assign it back to a matrix';call print(line) + call matrix_assign_sparse(b,sparse1) + b=sparse1 + call print(b) + if ( a .FNE. b) then + write(line,*) 'Something is wrong: a .NE. b';call print(line) + else + write(line,*) 'Everything seems alright!';call print(line) + end if + + write(line,*) 'Now we multiply our sparse with a unity vector';call print(line) + vect=1 + call print(vect) + allocate(vectout(size(vect))) + vectout = sparse_mult_vector(sparse1,vect) + write(line,*) 'Result should be 4 4 21 2 11';call print(line) + call print(vectout) + + write(line,*) 'Now we multiply the following vector for the sparse';call print(line) + vect(1)=5 + vect(2)=2 + vect(3)=3 + vect(4)=2 + vect(5)=1 + + call print(vect) + vectout = vector_mult_sparse(vect,sparse1) + write(line,*) 'Result should be 15 29 20 33 9';call print(line) + call print(vectout) + + + write(line,*) 'Lets check if it is working with empty rows ';call print(line) + a(2,2)=0.0 ! now row 2 has no elements + call print(a) + sparse1=a + call print(sparse1) + call matrix_assign_sparse(b,sparse1) + call print(b) + if ( a .FNE. b) then + write(line,*) 'Something is wrong: a .NE. b';call print(line) + else + write(line,*) 'Everything seems alright!';call print(line) + end if + + write(line,*) 'Now we check an empty matrix';call print(line) + a=0.0 + call print(a) + call sparse_assign_matrix(sparse1,a) + call print(sparse1) + call matrix_assign_sparse(b,sparse1) + call print(b) + if ( a .FNE. b) then + write(line,*) 'Something is wrong: a .NE. b';call print(line) + else + write(line,*) 'Everything seems alright!';call print(line) + end if + + write(line,*) 'Now we check tracemult';call print(line) + write(line,*) 'The matrix is a=1';call print(line) + a=1 + call sparse_assign_matrix(sparse1,c) + write(line,*) 'The following should be 42:',trace_sparse_mult_matrix(sparse1,a) + call print(line) + write(line,*) 'Now we check print_full'; call print(line) + call sparse_print_full(sparse1) + + end subroutine sparse_test + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +end module sparse_module diff --git a/src/libAtoms/Spline.F90 b/src/libAtoms/Spline.F90 new file mode 100644 index 0000000000..93a132859a --- /dev/null +++ b/src/libAtoms/Spline.F90 @@ -0,0 +1,463 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Spline module +!X +!% Defines derived type for a spline, and associated functions. +!% Code partially based on Numerical Recipes. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module spline_module + use system_module, only : dp, inoutput, print, optional_default, system_abort, verbosity_push_decrement, verbosity_pop + use linearalgebra_module + use table_module + implicit none + private + SAVE + + public :: spline, initialise, finalise, print, min_knot, max_knot, spline_value, spline_deriv + + + type Spline + integer ::n !% Number of knot points + real(dp), allocatable, dimension(:) ::x !% Knot positions + real(dp), allocatable, dimension(:) ::y !% Function values + real(dp), allocatable, dimension(:) ::y2 !% Second derivative + real(dp) ::yp1,ypn !% Endpoint derivatives + ! whether y2 has been initialised or not + logical ::y2_initialised = .false. + logical :: initialised = .false. + end type Spline + + interface initialise + module procedure spline_init + end interface + + interface finalise + module procedure spline_finalise + end interface + + interface print + module procedure spline_print + end interface + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X spline_init(this, x, y, yp1, ypn) + !X + !% Initialises a spline with given x and y values (and endpoint derivatives) + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + subroutine spline_init(this, x, y, yp1, ypn) + type(spline), intent(inout)::this + real(dp), dimension(:) :: x !% Knot points + real(dp), dimension(:) :: y !%Values of spline at the knot points + real(dp)::yp1 !% Derivative of the spline at 'x(1)' + real(dp)::ypn !% Derivative of the spline at 'x(n)' + + + call check_size('Y',y,size(x),'Spline_Init') + + ! first deallocate arrays if they have been allocated before + if(allocated(this%x)) deallocate(this%x) + if(allocated(this%y)) deallocate(this%y) + if(allocated(this%y2)) deallocate(this%y2) + + ! allocate new sizes + this%n = size(x); + allocate(this%x(this%n)) + allocate(this%y(this%n)) + allocate(this%y2(this%n)) + + ! copy data + this%x = x + this%y = y + call sort_array(this%x, r_data=this%y) + this%yp1 = yp1 + this%ypn = ypn + + ! compute y2 + call spline_y2calc(this) + this%initialised = .true. + end subroutine spline_init + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X spline_finalise(this) + !X + !% Deallocates a spline + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine spline_finalise(this) + type(spline), intent(inout)::this + if(allocated(this%x)) deallocate(this%x) + if(allocated(this%y)) deallocate(this%y) + if(allocated(this%y2)) deallocate(this%y2) + this%y2_initialised = .false. + this%initialised = .false. + end subroutine spline_finalise + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X spline_y2calc(this) + !X + !% Takes a spline with $x$ and $y$ values, and computes the second derivates + !% this must be done before interpolation. + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + subroutine spline_y2calc(this) + type(spline),intent(inout)::this + real(dp), allocatable, dimension(:) ::u ! local temporary + real(dp)::sig,p,un,qn + integer::i,k, n + + if(.not.allocated(this%x)) call system_abort("spline_y2calc: x not allocated!") + if(.not.allocated(this%y)) call system_abort("spline_y2calc: y not allocated!") + + n = this%n + + if(.not.allocated(this%y2)) allocate(this%y2(n)) + + allocate(u(n)) + + if(this%yp1> 0.99e30_dp) then + ! natural spline with zero second derivative at first point + this%y2(1) = 0.0_dp + u(1) = 0.0_dp + else + this%y2(1) = -0.5_dp + + u(1) = (3.0_dp/(this%x(2)-this%x(1)))* & + ((this%y(2)-this%y(1))/(this%x(2)-this%x(1))-this%yp1) + end if + + do i=2,n-1 + sig = (this%x(i)-this%x(i-1))/(this%x(i+1)-this%x(i-1)) + p = sig*this%y2(i-1)+2.0_dp + this%y2(i) = (sig-1.0)/p + u(i) = (this%y(i+1)-this%y(i))/(this%x(i+1)-this%x(i)) - & + (this%y(i)-this%y(i-1))/(this%x(i)-this%x(i-1)) + u(i) = (6.0*u(i)/(this%x(i+1)-this%x(i-1))-sig*u(i-1))/p + end do + + if(this%ypn > 0.99e30_dp)then + ! natural spline with zero second derivative at last point + qn = 0.0_dp + un = 0.0_dp + else + qn = 0.5_dp + un = (3.0_dp/(this%x(n)-this%x(n-1)))* & + (this%ypn-(this%y(n)-this%y(n-1))/(this%x(n)-this%x(n-1))) + end if + + this%y2(n) = (un-qn*u(n-1))/(qn*this%y2(n-1)+1.0_dp) + + do k=n-1,1,-1 + this%y2(k) = this%y2(k)*this%y2(k+1)+u(k) + end do + + ! set the logical flag + this%y2_initialised = .true. + + deallocate(u) ! free temporary + + if( this%yp1 > 0.99e30_dp ) then + this%yp1 = spline_deriv(this,this%x(1)) + endif + + if( this%ypn > 0.99e30_dp ) then + this%ypn = spline_deriv(this,this%x(n)) + endif + + end subroutine spline_y2calc + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X y = spline_value(this, x) + !X + !% Interpolate the spline for a given $x$ point + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + function spline_value(this,x) result(y) + type(spline)::this + real(dp)::x,h,a,b,y + integer::klo,khi,k, n + + if(.NOT.this%y2_initialised) then + if(allocated(this%x).and.allocated(this%y)) then + call spline_y2calc(this) + else + call system_abort("spline_value: spline has not been initialised") + end if + end if + + n = this%n + if( x < this%x(1) ) then + y = this%y(1) + (x - this%x(1))*this%yp1 + elseif( x > this%x(n) ) then + y = this%y(n) + (x - this%x(n))*this%ypn + else + klo = 1 + khi = this%n + + do while(khi-klo > 1) + k = (khi+klo)/2 + if(this%x(k) > x) then + khi = k + else + klo = k + end if + end do + + h = this%x(khi)-this%x(klo) + if(h .EQ. 0.0_dp) then + call system_abort("spline_interpolate: h=0!!!") + end if + + a = (this%x(khi)-x)/h + b = (x-this%x(klo))/h + y = a*this%y(klo)+b*this%y(khi)+((a*a*a-a)*this%y2(klo)+(b*b*b-b)*this%y2(khi))*(h*h)/6.0 + endif + + end function spline_value + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X dy = spline_deriv(this, x) + !X + !% Interpolate the derivative of the spline at the given $x$ point + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + function spline_deriv(this,x) result(dy) + type(spline)::this + real(dp)::x,h,a,b,dy + integer::klo,khi,k,n + + if(.NOT.this%y2_initialised) then + if(allocated(this%x).and.allocated(this%y)) then + call spline_y2calc(this) + else + call system_abort("spline_deriv: spline has not been initialised") + end if + end if + + n = this%n + + if( x < this%x(1) ) then + dy = this%yp1 + elseif( x > this%x(n) ) then + dy = this%ypn + else + klo = 1 + khi = n + + do while(khi-klo > 1) + k = (khi+klo)/2 + if(this%x(k) > x) then + khi = k + else + klo = k + end if + end do + + h = this%x(khi)-this%x(klo) + if(h .EQ. 0.0) then + call system_abort("spline_deriv: h=0!!!") + end if + + a = (this%x(khi)-x)/h + b = (x-this%x(klo))/h + dy = (this%y(khi)-this%y(klo))/h+((3.0_dp*b*b-1.0_dp)*this%y2(khi)-(3.0_dp*a*a-1.0_dp)*this%y2(klo))*h/6.0_dp + endif + + end function spline_deriv + + function spline_nintegrate(this, x0, x, n_per_knot) result (y_int) + type(spline), intent(in) :: this + real(dp), intent(in) :: x0, x + integer, intent(in), optional :: n_per_knot + real(dp) :: y_int + + integer :: use_n, total_n, i + real(dp), allocatable :: int_x(:), int_y(:) + + use_n = optional_default(10, n_per_knot) + total_n = use_n*abs(x-x0)/minval(abs(this%x(2:this%n)-this%x(1:this%n-1))) + + allocate(int_x(total_n)) + allocate(int_y(total_n)) + + do i=1, total_n + int_x(i) = x0+real(i-1,dp)*(x-x0)/real(total_n-1,dp) + int_y(i) = spline_value(this, int_x(i)) + end do + + y_int = TrapezoidIntegral(int_x, int_y) + deallocate(int_x) + deallocate(int_y) + + end function spline_nintegrate + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X spline_compute_matrices(this) + !X + !% The y2 of the spline can also be computed using + !% linear algebra. Following Numerical Recipes, + !% + !% \begin{displaymath} + !% A Y'' = BY + C + !% \end{displaymath} + !% where $A$, $B$ are matrices, $C$ is a vector + !% so + !% \begin{displaymath} + !% Y'' = A^{-1} B Y + A^{-1} C + !% \end{displaymath} + !% + !% This subroutine computes these matrices, and stores them in + !% 'spline%y2_matrix1 = inv(A)*B' and 'spline%y2_matrix0 = inv(A)*C' + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine spline_compute_matrices(this, y2_matrix1, y2_matrix0) + type(spline), intent(in)::this + real(dp), dimension(:,:), intent(out)::y2_matrix1 + real(dp), dimension(:), intent(out)::y2_matrix0 + real(dp)::A(this%n,this%n) + real(dp)::B(this%n,this%n),C(this%n) + real(dp)::Ainv(this%n,this%n) + integer::i,n + + n = this%n + + ! Set matrix elements that correspond to + ! conditions on first derivative at x1 and xn + ! equation 3.3.5 of Numerical Recipes in c++ second edition pag. 117 + ! evaluated at x=x1 and x=xn + A=0.0_dp + B=0.0_dp + C=0.0_dp + A(1,1) = -(1.0_dp/3.0_dp)*(this%x(2)-this%x(1)) + A(1,2) = -(1.0_dp/6.0_dp)*(this%x(2)-this%x(1)) + A(2,n-1)= (1.0_dp/6.0_dp)*(this%x(n)-this%x(n-1)) + A(2,n) = (1.0_dp/3.0_dp)*(this%x(n)-this%x(n-1)) + + B(1,1) = 1.0_dp/(this%x(2)-this%x(1)) + B(1,2) = -1.0_dp/(this%x(2)-this%x(1)) + B(2,n-1)= 1.0_dp/(this%x(n)-this%x(n-1)) + B(2,n) = -1.0_dp/(this%x(n)-this%x(n-1)) + + C(1) = this%yp1 + C(n) = this%ypn + + ! Set the matrix elements corresponds to the + ! equations 3.3.7 of page 118 in Numerical Recipes + + do I=2,n-1 + A(I+1,I-1) =(this%x(i) -this%x(i-1))/6.0_dp + A(I+1,I) =(this%x(i+1)-this%x(i-1))/3.0_dp + A(I+1,I+1) =(this%x(i+1)-this%x(i) )/6.0_dp + + B(I+1,I-1) = 1.0_dp/(this%x(i) -this%x(i-1)) + B(I+1,I) = -1.0_dp/(this%x(i+1)-this%x(i))- & + 1.0_dp/(this%x(i) -this%x(i-1)) + B(I+1,I+1) = 1.0_dp/(this%x(i+1)-this%x(i)) + end do + + call inverse(A,Ainv) + + y2_matrix1 = Ainv .mult. B + + y2_matrix0 = Ainv .mult. C + + end subroutine spline_compute_matrices + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X spline_print(this) + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine spline_print(this, file) + type(Spline), intent(in)::this + type(Inoutput), optional, target, intent(inout) :: file + + real(dp), allocatable :: y2m1(:,:), y2m0(:), y2(:) + + call print("Spline ", file=file) + + call print(this%n, file=file) + call print(reshape( (/this%x,this%y/), (/this%n,2/)), file=file) + + call verbosity_push_decrement() + if(this%y2_initialised) then + call print(this%y2, file=file) + else + + allocate(y2m1(this%n, this%n)) + allocate(y2m0(this%n)) + allocate(y2(this%n)) + + call spline_compute_matrices(this, y2m1, y2m0) + y2 = (y2m1 .mult. this%y)+y2m0 + call print(y2, file=file) + + deallocate(y2m1) + deallocate(y2m0) + deallocate(y2) + endif + + call verbosity_pop() + end subroutine spline_print + + function min_knot(this) + type(Spline), intent(in) :: this + real(dp) :: min_knot + + min_knot = this%x(1) + end function min_knot + + function max_knot(this) + type(Spline), intent(in) :: this + real(dp) :: max_knot + + max_knot = this%x(size(this%x)) + end function max_knot + +end module spline_module + + + diff --git a/src/libAtoms/Structures.F90 b/src/libAtoms/Structures.F90 new file mode 100644 index 0000000000..34c5d309b4 --- /dev/null +++ b/src/libAtoms/Structures.F90 @@ -0,0 +1,3499 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Structures module +!X +!% A collection of utility functions that generate useful Atoms structures +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module structures_module + use error_module + use system_module + use units_module + use periodictable_module + use linearalgebra_module + use table_module + use extendable_str_module + use dictionary_module + use connection_module + use atoms_types_module + use atoms_module + use cinoutput_module + use paramreader_module + use clusters_module + implicit none + private + + public :: slab, find_motif + public :: graphene_cubic, graphene_slab, graphene_sheet, graphene_tube, tube_radius, anatase_cubic, alpha_quartz, alpha_quartz_cubic, rutile, diamond, water, supercell, structure_from_file, fcc, fcc1, & + diamond2, graphite, graphite_rhombohedral, beta_tin, beta_tin4, bcc1, hcp, wurtzite, sh, sh2, imma, imma4, & + fcc_11b2_edge_disloc, fcc_disloc_malc, disloc_noam, fcc_z111_ortho, fcc_z111, fcc_z100, bulk, unit_slab, slab_width_height_nz, & + slab_nx_ny_nz, bcc, transform, arbitrary_supercell, find_compatible_supercells, bond_angle_mean_dev, map_nearest_atoms, & + delaunay_reduce, min_neighbour_dist, remove_too_close_atoms, surface_unit_cell, find_closest, void_analysis + + + interface slab + module procedure slab_width_height_nz, slab_nx_ny_nz + end interface + +contains + + !X + !X Edge dislocation generator + !X + subroutine fcc_11b2_edge_disloc(at, a0, n1, n2, n3) + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a0 ! cubic lattice constant + integer, intent(in) :: n1, n2, n3 ! supercell dimensions + + type(atoms) :: at1 + type(table) :: removelist + integer :: i + + call fcc_z111_ortho(at1, a0) + call supercell(at, at1, n1, n2, n3) + + call map_into_cell(at) + + do i= 1,at%N + if( at%pos(3,i) > 0.0_dp) then + if(abs(at%pos(1,i)) < 0.1_dp) then + call append(removelist, i) + else + at%pos(1,i) = at%pos(1,i)-sign(at%pos(1,i))*min(a0/sqrt(2.0_dp)/4.0_dp, at%pos(3,i)/10.0_dp) + at%pos(2,i) = at%pos(2,i)-sign(at%pos(1,i))*min(a0*sqrt(3.0_dp/2.0_dp)/4.0_dp, at%pos(3,i)/10.0_dp) + end if + end if + end do + + if(removelist%N > 0) then + call allocate(removelist) ! make the table size exact + call print('Removing '//removelist%N//' atoms') + call remove_atoms(at, int_part(removelist,1)) + end if + + + call set_lattice(at, at%lattice+reshape((/ & + 20.0_dp,0.0_dp,0.0_dp, & + 0.0_dp, 0.0_dp,0.0_dp, & + 0.0_dp, 0.0_dp,20.0_dp/), (/3, 3/)), scale_positions=.false.) + + call finalise(at1) + call finalise(removelist) + + end subroutine fcc_11b2_edge_disloc + + + !X + !X Dislocation generator, formulas from Malcolm Heggie + !X + subroutine fcc_disloc_malc(at, a0, nu, n1, n2, n3, d, type) + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a0, nu ! cubic lattice constant, poisson ratio + integer, intent(in) :: n1, n2, n3, d ! supercell dimensions, distance between partials + character(*) :: type + + type(atoms) :: at1 + type(table) :: removelist + real(dp) :: x, y, z, ux, uy, uz, r2, b_screw, b_edge, b_edge_p, theta, ox(2), r_ij + integer :: p, i, n, j + + call fcc_z111_ortho(at1, a0) + call supercell(at, at1, n1, n2, n3) + + ox(1) = -real(d)*sqrt(3.0_dp/2.0_dp)*a0 + ox(2) = real(d)*sqrt(3.0_dp/2.0_dp)*a0 + + if(type == 'edge') then + b_screw = a0*sqrt(3.0_dp/2.0_dp)/2.0_dp + b_edge = a0/sqrt(2.0_dp)/2.0_dp + else if (type == 'screw') then + b_screw = a0/2.0_dp/sqrt(2.0_dp) + b_edge = 0.0_dp + else + call system_abort("screw_disloc(): unknown type `"//type//"'") + end if + + do p=1,2 + b_edge_p = b_edge*0.5_dp + a0/2.0_dp/sqrt(6.0_dp)*sign(p-1.5_dp) + do i=1,at%N + x = at%pos(1,i)-ox(p)-0.1 + y = at%pos(2,i) + z = at%pos(3,i)-0.1 + theta = atan2(z,x) + r2 = x*x+z*z + ux = b_edge_p/(2.0_dp*PI)*(theta+0.5_dp*x*z/r2/(1.0_dp-nu)) + uy = b_screw/(2.0_dp*PI)*theta + uz = -0.25_dp*b_edge_p/(2.0_dp*PI)*((1.0_dp-2.0_dp*nu)*log(r2)+(x*x-z*z)/r2)/(1.0_dp-nu) + + at%pos(:,i) = at%pos(:,i)+(/ux, uy, uz/) + end do + end do + + call set_cutoff(at, 2.1_dp) + call calc_connect(at) + + do i= 1,at%N + do n = 1,n_neighbours(at, i) + j = neighbour(at, i, n, distance=r_ij) + if(r_ij < 2.0_dp .and. i > j) then + call print('i= '//i//' j= '//j//' r_ij = '//r_ij) + call append(removelist, j) + end if + end do + end do + + !call print(at) + + if(removelist%N > 0) then + call allocate(removelist) ! make the table size exact + call print('Removing '//removelist%N//' atoms') + call remove_atoms(at, int_part(removelist,1)) + call calc_connect(at) + end if + + call set_lattice(at, at%lattice+reshape((/ & + 20.0_dp,0.0_dp,0.0_dp, & + 0.0_dp, 0.0_dp,0.0_dp, & + 0.0_dp, 0.0_dp,20.0_dp/), (/3, 3/)), scale_positions=.false.) + + call finalise(at1) + call finalise(removelist) + end subroutine fcc_disloc_malc + + subroutine disloc_noam(at, p, l, b, close_threshold) + type(Atoms), intent(inout) :: at + real(dp) :: p(3), l(3), b(3) + real(dp), optional :: close_threshold + + real(dp) :: l_hat(3), b_hat(3), r1_hat(3), r2_hat(3) + real(dp) :: theta + real(dp) :: delta_p(3), delta_p_rot(3) + real(dp) :: r + + integer :: i_at, j_at, j + logical, allocatable :: atoms_remove(:) + integer, allocatable :: remove_list(:) + + l_hat = l/norm(l) + b_hat = b/norm(b) + + if (abs(l_hat .dot. b_hat) .feq. 1.0_dp) then ! screw + r1_hat = (/ 1.0_dp, 0.0_dp, 0.0_dp /) + r1_hat = r1_hat - l_hat * (r1_hat .dot. l_hat) + if (norm(r1_hat) .feq. 0.0_dp) then + r1_hat = (/ 0.0_dp, 1.0_dp, 0.0_dp /) + r1_hat = r1_hat - l_hat * (r1_hat .dot. l_hat) + endif + r1_hat = r1_hat / norm(r1_hat) + r2_hat = l_hat .cross. r1_hat + else + r2_hat = l_hat .cross. b_hat + r2_hat = r2_hat/norm(r2_hat) + r1_hat = r2_hat .cross. l_hat + endif + + call print("disloc_noam: r1_hat " // r1_hat, PRINT_VERBOSE) + call print("disloc_noam: r2_hat " // r2_hat, PRINT_VERBOSE) + call print("disloc_noam: l_hat " // l_hat, PRINT_VERBOSE) + + do i_at = 1, at%N + delta_p = diff_min_image(at, p, i_at) + if (norm(delta_p) .feq. 0.0_dp) then + theta = 0.0_dp + else + delta_p_rot(1) = delta_p .dot. r1_hat + delta_p_rot(2) = delta_p .dot. r2_hat + delta_p_rot(3) = delta_p .dot. l_hat + theta = atan2(delta_p_rot(2), delta_p_rot(1)) + endif + call print("atom " // i_at // " pos " // at%pos(:,i_at) // " delta_p " // delta_p // " theta " // theta, PRINT_ANALYSIS) + delta_p = b*theta/(2.0_dp*PI) + at%pos(:,i_at) = at%pos(:,i_at) + delta_p + end do + + allocate(atoms_remove(at%N)) + atoms_remove = .false. + + call calc_connect(at) + do i_at = 1, at%N + if (atoms_remove(i_at)) cycle + do j=1, n_neighbours(at, i_at) + j_at = neighbour(at, i_at, j, distance=r) + if (atoms_remove(j_at)) cycle + if (present(close_threshold)) then + if (r < close_threshold) then + if (j_at == i_at) then + call print("WARNING: disloc_noam found atom too close to itself", PRINT_ALWAYS) + else + atoms_remove(j_at) = .true. + endif + endif + else + if (r < 0.5_dp*bond_length(at%Z(i_at), at%Z(j_at))) then + if (i_at == j_at) then + call print("WARNING: disloc_noam found atom too close to itself", PRINT_ALWAYS) + else + atoms_remove(j_at) = .true. + endif + endif + endif ! present(close_threshold) + end do ! j + end do ! i_at + + if (count(atoms_remove) > 0) then + allocate(remove_list(count(atoms_remove))) + j_at = 0 + do i_at=1, at%N + if (atoms_remove(i_at)) then + j_at = j_at + 1 + remove_list(j_at) = i_at + endif + end do + call remove_atoms(at, remove_list) + + deallocate(remove_list) + end if + + deallocate(atoms_remove) + + end subroutine disloc_noam + + subroutine fcc_z111_ortho(at, a0) + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a0 ! cubic lattice constant + real(dp) :: lat(3,3), b + + b = a0*sqrt(2.0_dp)/2.0_dp + lat(:,1) = (/b, 0.0_dp, 0.0_dp/) + lat(:,2) = (/0.0_dp, b*sqrt(3.0_dp), 0.0_dp/) + lat(:,3) = (/0.0_dp, 0.0_dp, a0*sqrt(3.0_dp)/) + + call initialise(at, 6, lat) + at%pos(:,1) = lat .mult. (/0.0_dp,0.0_dp,0.0_dp/) + at%pos(:,2) = lat .mult. (/0.5_dp,0.5_dp,0.0_dp/) + at%pos(:,3) = lat .mult. (/0.0_dp, 2.0_dp/3.0_dp, 1.0_dp/3.0_dp/) + at%pos(:,4) = lat .mult. (/0.5_dp, 1.0_dp/6.0_dp, 1.0_dp/3.0_dp/) + at%pos(:,5) = lat .mult. (/0.0_dp, 1.0_dp/3.0_dp, 2.0_dp/3.0_dp/) + at%pos(:,6) = lat .mult. (/0.5_dp, 5.0_dp/6.0_dp, 2.0_dp/3.0_dp/) + end subroutine fcc_z111_ortho + + subroutine fcc_z111(at, a0) + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a0 ! cubic lattice constant + real(dp) :: lat(3,3), b + + b = a0*sqrt(2.0_dp)/2.0_dp + lat(:,1) = (/b, 0.0_dp, 0.0_dp/) + lat(:,2) = (/b*0.5_dp, b*sqrt(3.0_dp)/2.0_dp, 0.0_dp/) + lat(:,3) = (/0.0_dp, 0.0_dp, a0*sqrt(3.0_dp)/) + + call initialise(at, 3, lat) + at%pos(:,1) = lat .mult. (/0.0_dp,0.0_dp,0.0_dp/) + at%pos(:,2) = lat .mult. (/1.0_dp/3.0_dp, 1.0_dp/3.0_dp, 1.0_dp/3.0_dp/) + at%pos(:,3) = lat .mult. (/2.0_dp/3.0_dp, 2.0_dp/3.0_dp, 2.0_dp/3.0_dp/) + end subroutine fcc_z111 + + + !% Make an FCC 100 surface, such that the repeating squares of the + !% surface are aligned with the cell boundaries + subroutine fcc_z100(at, a0) + type(Atoms), intent(out) :: at + real(DP), intent(in) :: a0 ! cubic lattice constant + + real(DP) :: lat(3, 3) + + lat(:, 1) = (/ a0/sqrt(2.0), 0.0_DP, 0.0_DP /) + lat(:, 2) = (/ 0.0_DP, a0/sqrt(2.0_DP), 0.0_DP /) + lat(:, 3) = (/ 0.0_DP, 0.0_DP, a0 /) + + call initialise(at, 2, lat) + at%pos(:, 1) = lat .mult. (/ 0.0_DP, 0.0_DP, 0.0_DP /) + at%pos(:, 2) = lat .mult. (/ 0.5_DP, 0.5_DP, 0.5_DP /) + endsubroutine fcc_z100 + + !% Construct a bulk primitive cell with a given lattice type and lattice parameters + subroutine bulk(at, lat_type, a, c, u, x, y, z, atnum) + type(Atoms), intent(out) :: at + character(len=*), intent(in) :: lat_type !% One of 'diamond', 'bcc', 'fcc', 'alpha_quartz', 'anatase_cubic', 'anatase', or 'rutile' + real(dp), intent(in) :: a !% Principal lattice constant + real(dp), intent(in), optional :: c, u, x, y, z + integer, intent(in), optional :: atnum(:) !% Optionally specify atomic numbers + + if(trim(lat_type).eq.'diamond') then + call diamond(at, a, atnum) + elseif(trim(lat_type).eq.'bcc') then + call bcc(at, a, atnum(1)) + elseif(trim(lat_type).eq.'fcc') then + call fcc(at, a, atnum(1)) + elseif(trim(lat_type) .eq. 'alpha_quartz') then + if (.not. present(c) .or. .not. present(u) .or. .not. present(x) & + .or. .not. present(y) .or. .not. present(z)) call system_abort('bulk: alpha_quartz missing c, u, x, y or z') + call alpha_quartz_cubic(at, a, c, u, x, y, z) + elseif(trim(lat_type) .eq. 'anatase_cubic') then + if (.not. present(c) .or. .not. present(u) ) call system_abort('bulk: anatase_cubic missing c, u') + call anatase_cubic(at, a, c, u) + elseif(trim(lat_type) .eq. 'anatase') then + if (.not. present(c) .or. .not. present(u) ) call system_abort('bulk: anatase missing c, u') + call anatase(at, a, c, u) + elseif(trim(lat_type) .eq. 'rutile') then + if (.not. present(c) .or. .not. present(u) ) call system_abort('bulk: rutile missing c, u') + call rutile(at, a, c, u) + else + call system_abort('bulk: unknown lattice type '//lat_type) + endif + + end subroutine bulk + + + !% Return a slab of material with the x, y, and z axes desribed by the + !% Miller indices in the array axes (with ``x = axes[:,1])``, ``y = + !% axes[:,2]`` and ``z = axes[:,3]``). The extent of the slab should + !% be given either as ``(nx, ny, nz)`` unit cells or as ``(width, + !% height, nz)`` where `width` and `height` are measured in Angstrom + !% and `nz` is the number of cells in the `z` direction. + !% + !% `atnum` can be used to initialise the `z` and `species` properties. + !% `lat_type` should be of ``"diamond"```, ``"fcc"``, or ``"bcc"`` + !% (default is ``"diamond"``) + subroutine unit_slab(myatoms, axes, a, atnum, lat_type, c, u, x, y, z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in), dimension(3,3) :: axes + real(dp), intent(in) :: a ! Lattice vector + real(dp), intent(in), optional :: c, u, x, y, z ! Lattice vector + integer, intent(in), optional :: atnum(:) ! atomic numbers + character(len=*), intent(in), optional :: lat_type ! lattice type (diamond, bcc, fcc) + + integer :: i, Nrep(3) ! Number of repeats in x,y and z + real(dp), dimension(3) :: a1, a2, a3, t, d + real(dp), dimension(3,3) :: rot + type(Atoms) :: at + character(20) :: my_lat_type + + i = 0 + Nrep = (/ 1,1,1 /) + + my_lat_type = optional_default('diamond', lat_type) + call print("unit_slab : Lattice type " // trim(my_lat_type)) + call bulk(at, lat_type, a, c, u, x, y, z, atnum) + + ! Need special cases for some surfaces to ensure we only get one unit cell + if (all(axes(:,2) == (/ 1,1,1 /)) .and. all(axes(:,3) == (/ 1,-1,0 /))) & + Nrep = (/ 2,1,2 /) + if (all(axes(:,2) == (/ 1,1,0 /)) .and. all(axes(:,3) == (/ 0,0,-1 /))) & + Nrep = (/ 2,2,1 /) + if (all(axes(:,2) == (/ 1,1,0 /)) .and. all(axes(:,3) == (/ 1,-1,0 /))) & + Nrep = (/ 1,1,2 /) + + a1 = axes(:,1); a2 = axes(:,2); a3 = axes(:,3) + rot(1,:) = a1/norm(a1); rot(2,:) = a2/norm(a2); rot(3,:) = a3/norm(a3) + + ! Rotate atom positions and lattice + at%pos = rot .mult. at%pos + at%lattice = rot .mult. at%lattice + + call supercell(myatoms, at, 5, 5, 5) + call zero_sum(myatoms%pos) + + ! Project rotated lattice onto axes + do i=1,3 + myatoms%lattice(:,i) = (axes(1,i)*at%lattice(:,1) + & + axes(2,i)*at%lattice(:,2) + & + axes(3,i)*at%lattice(:,3))/Nrep(i) + end do + call set_lattice(myatoms, myatoms%lattice, scale_positions=.false.) + + ! Form primitive cell by discarding atoms with + ! lattice coordinates outside range [-0.5,0.5] + d = (/ 0.01_dp,0.02_dp,0.03_dp /) ! Small shift to avoid conincidental alignments + i = 1 + do + t = myatoms%g .mult. (myatoms%pos(:,i) + d) + if (any(t <= -0.5_dp) .or. any(t >= 0.5_dp)) then + call remove_atoms(myatoms, i) + i = i - 1 ! Retest since we've removed an atom + end if + if (i == myatoms%N) exit + i = i + 1 + end do + + call map_into_cell(myatoms) + + call finalise(at) + + end subroutine unit_slab + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Slab with dimensions width x height in xy plane and nz layers deep. + ! Origin is at centre of slab. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine slab_width_height_nz(myslab, axes, a, width, height, nz, atnum, lat_type, c, u, x, y, z, even_nx, even_ny) + type(Atoms), intent(out) :: myslab + real(dp), intent(in), dimension(3,3) :: axes + real(dp), intent(in) :: a, width, height + real(dp), intent(IN), optional :: c, u, x, y, z ! Lattice vector + integer, intent(in) :: nz ! Number of layers + integer, intent(in), optional :: atnum(:) ! atomic numbers to use + character(len=*), optional :: lat_type + logical, optional, intent(in) :: even_nx, even_ny ! round nx or ny to even numbers + + type(Atoms) :: unit, layer + integer nx, ny + logical :: do_even_nx, do_even_ny + + ! even_nx and even_ny default to true for lat_type="alpha_quartz", otherwise they default to false + if (present(lat_type)) then + if (trim(lat_type) == 'alpha_quartz') then + do_even_nx = optional_default(.true., even_nx) + do_even_ny = optional_default(.true., even_ny) + else + do_even_nx = optional_default(.false., even_nx) + do_even_ny = optional_default(.false., even_ny) + end if + else + do_even_nx = optional_default(.false., even_nx) + do_even_ny = optional_default(.false., even_ny) + end if + + call unit_slab(unit, axes, a, atnum, lat_type, c, u, x, y, z) + + nx = int(floor(width/unit%lattice(1,1))) + ny = int(floor(height/unit%lattice(2,2))) + + if (do_even_nx .and. mod(nx, 2) == 1) nx = nx - 1 + if (do_even_ny .and. mod(ny, 2) == 1) ny = ny - 1 + + if (.not. (nx > 0 .and. ny > 0 .and. nz > 0)) then + write(line,'(a, i0, i0, i0)') 'Error in slab: nx,ny,nz = ', nx, ny, nz + call system_abort(line) + end if + + call print('slab_width_height_nz: nx='//nx//' ny='//ny//' nz='//nz, PRINT_VERBOSE) + + call supercell(layer, unit, nx, ny, 1) + ! z layers last for symmetrise + call supercell(myslab, layer, 1, 1, nz) + call zero_sum(myslab%pos) + call finalise(unit, layer) + + end subroutine slab_width_height_nz + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! Slab of size nx x ny x nx primitive cells. + ! Origin is at centre of slab. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine slab_nx_ny_nz(myslab, axes, a, nx, ny, nz, atnum, lat_type, c, u, x, y, z) + type(Atoms), intent(out) :: myslab + real(dp), intent(in), dimension(3,3) :: axes + real(dp), intent(in) :: a + real(dp), intent(IN), optional :: c, u, x, y, z + integer, intent(in) :: nx, ny, nz + integer, intent(in), optional :: atnum(:) + character(len=*), intent(inout), optional :: lat_type + + type(Atoms) :: unit, layer + + call unit_slab(unit, axes, a, atnum, lat_type, c, u, x, y, z) + call supercell(layer, unit, nx, ny, 1) + ! z layers last for symmetrise + call supercell(myslab, layer, 1, 1, nz) + call zero_sum(myslab%pos) + call finalise(unit, layer) + + end subroutine slab_nx_ny_nz + + !% Cubic grapphene unit cell with lattice parameter 'a', this is the subroutine version + subroutine Graphene(cube, a) + type(Atoms), intent(out) :: cube + real(dp), intent(in) :: a + + ! call the function below + cube = Graphene_Cubic(a) + end subroutine Graphene + + !% Cubic graphene unit cell with lattice parameter 'a'. + function Graphene_Cubic(a) result(cube) + real(dp), intent(in) :: a + type(Atoms) :: cube + + call Initialise(cube, 4, & + reshape((/ 3.0_dp*a, 0.0_dp, 0.0_dp, & + 0.0_dp, sqrt(3.0_dp)*a, 0.0_dp, & + 0.0_dp, 0.0_dp, 10.0_dp/), (/3, 3/))) + + call set_atoms(cube, 6) + cube%pos(:,1) = a*(/0.0_dp, sqrt(3.0_dp)/2.0, 0.0_dp/) + cube%pos(:,2) = a*(/0.5_dp, 0.0_dp, 0.0_dp/) + cube%pos(:,3) = a*(/1.5_dp, 0.0_dp, 0.0_dp/) + cube%pos(:,4) = a*(/2.0_dp, sqrt(3.0_dp)/2.0, 0.0_dp/) + + end function Graphene_Cubic + + !% Construct a slab of graphene of a given with and height, at a given angle. + !% 'a' is lattice parameter. + subroutine Graphene_Slab(slab, a, theta, width, height) + real(dp), intent(in) :: a, theta, width, height + type(Atoms), intent(out) :: slab + + type(Atoms) :: unit, tmp_slab + type(Table) :: keep_list + integer :: i, nx, ny, nz + real(dp) :: rot(3,3), lattice(3,3), d(3), t(3) + + unit = Graphene_Cubic(a) + + rot = reshape((/ cos(theta), -sin(theta), 0.0_dp, & + sin(theta), cos(theta), 0.0_dp, & + 0.0_dp, 0.0_dp, 1.0_dp /), (/3,3/)) + + unit%pos = rot .mult. unit%pos + lattice = rot .mult. unit%lattice + call Set_Lattice(unit, lattice, scale_positions=.false.) + + ! Choose nx and ny so we can cut a width by height square out of the + ! rotated slab + call Fit_Box_in_Cell(width, height, norm(unit%lattice(:,3)), unit%lattice, nx, ny, nz) + call Supercell(tmp_slab, unit, nx, ny, 1) + call Zero_Sum(tmp_slab%pos) + + ! Final lattice for unitslab is width by height + lattice = 0.0_dp + lattice(1,1) = width + lattice(2,2) = height + lattice(3,3) = tmp_slab%lattice(3,3) + call Set_Lattice(tmp_slab, lattice, scale_positions=.false.) + + ! Form primitive cell by discarding atoms with + ! lattice coordinates outside range [-0.5,0.5] + d = (/ 0.01, 0.02, 0.03 /) + call Allocate(keep_list, 1, 0, 0, 0, tmp_slab%N) + + do i=1,tmp_slab%N + t = tmp_slab%g .mult. (tmp_slab%pos(:,i) + d) + if (.not. (any(t < -0.5_dp) .or. any(t >= 0.5_dp))) & + call Append(keep_list, i) + end do + + call Initialise(slab, keep_list%N, tmp_slab%lattice) + slab%Z = tmp_slab%Z(keep_list%int(1,1:keep_list%N)) + slab%species = tmp_slab%species(:,keep_list%int(1,1:keep_list%N)) + + if (has_property(slab, 'mass')) & + forall (i=1:slab%N) slab%mass(i) = ElementMass(slab%Z(i)) + + slab%pos = tmp_slab%pos(:,keep_list%int(1,1:keep_list%N)) + + call Finalise(unit) + call Finalise(tmp_slab) + call finalise(keep_list) + end subroutine Graphene_Slab + + !% Construct a graphene sheet of index $(n,m)$ with lattice constant 'a' with 'rep_x' + !% repeat units in the $x$ direction and 'rep_y' in the $y$ direction. + subroutine Graphene_Sheet(sheet, a, n, m, rep_x, rep_y) + type(Atoms), intent(out) :: sheet + real(dp), intent(in) :: a + integer, intent(in) :: n, m, rep_x, rep_y + + type(Atoms) :: unit, unitsheet + real(dp) :: a1(2), a2(2), x(2), y(2), lattice(3,3), theta, rot(3,3), d(3), t(3), normx, normy + integer :: nx, ny, nz, i + + unit = Graphene_Cubic(a) + + a1 = a*(/3.0_dp/2.0_dp, sqrt(3.0_dp)/2.0/) + a2 = a*(/3.0_dp/2.0_dp, -sqrt(3.0_dp)/2.0/) + + ! x gets mapped to circumference of tube + x = n*a1 + m*a2 + normx = norm(x) + + ! y is smallest vector perpendicular to x that can be written + ! in form a*a1 + b*a2 where a and b are integers, i.e. it is + ! the periodicity of nanotube along tube length + y = (2.0_dp*n + m)*a1 - (n + 2.0_dp*m)*a2 + y = y / real(gcd(2*n + m, n + 2*m), dp) + normy = norm(y) + + ! Rotate unit cell to align x axis with vector x + theta = -atan(x(2)/x(1)) + rot = reshape((/ cos(theta), -sin(theta), 0.0_dp, & + sin(theta), cos(theta), 0.0_dp, & + 0.0_dp, 0.0_dp, 1.0_dp /), (/3,3/)) + + unit%pos = rot .mult. unit%pos + lattice = rot .mult. unit%lattice + call Set_Lattice(unit, lattice, scale_positions=.false.) + + ! Choose nx and ny so we can cut an x by y square out of the + ! rotated unitsheet + call Fit_Box_in_Cell(normx, normy, norm(unit%lattice(:,3)), unit%lattice, nx, ny, nz) + call Supercell(unitsheet, unit, nx, ny, 1) + call Zero_Sum(unitsheet%pos) + + ! Final lattice for unitsheet is norm(x) by norm(y) + lattice = 0.0_dp + lattice(1,1) = normx + lattice(2,2) = normy + lattice(3,3) = unitsheet%lattice(3,3) + + call Set_Lattice(unitsheet, lattice, scale_positions=.false.) + + ! Form primitive cell by discarding atoms with + ! lattice coordinates outside range [-0.5,0.5] + d = (/ 0.01, 0.02, 0.03 /) + i = 1 + do + t = unitsheet%g .mult. (unitsheet%pos(:,i) + d) + if (any(t < -0.5_dp) .or. any(t >= 0.5_dp)) then + call Remove_Atoms(unitsheet, i) + i = i - 1 ! Retest since we've removed an atom + end if + if (i == unitsheet%N) exit + i = i + 1 + end do + + call Supercell(sheet, unitsheet, rep_x, rep_y, 1) + + call Finalise(unit) + call Finalise(unitsheet) + end subroutine Graphene_Sheet + + + !% Calcualte average radius of a nanotube + function Tube_Radius(tube) result(r) + type(Atoms), intent(in) :: tube + real(dp) :: r + + real(dp), dimension(2,tube%N) :: pos + real(dp) :: r_sum + integer :: i + + ! Collapse in z direction + pos(:,:) = tube%pos(1:2,:) + + ! Centre on (0,0) + call Zero_Sum(pos) + + r_sum = 0.0_dp + do i=1,tube%N + r_sum = r_sum + sqrt(pos(1,i)**2 + pos(2,i)**2) + end do + r = r_sum/tube%N ! Average radius + + end function Tube_Radius + + + + !% Euclidean algorithm for greatest common divisor of 'a' and 'b' + !% needed by 'graphene_tube' + function gcd(ai, bi) + integer, intent(in) :: ai, bi + integer :: gcd + + integer :: a, b, c + + a = ai + b = bi + do while (b /= 0) + c = b + b = mod(a,b) + a = c + end do + gcd = a + + end function gcd + + !% Construct a $(n,m)$ nanotube with lattice parameter 'a' and 'nz' + !% unit cells along the tube length. Also returns the radius of the tube. + function Graphene_Tube(tube, a, n, m, nz) result(r) + type(Atoms), intent(out) :: tube + real(dp), intent(in) :: a + integer, intent(in) :: n, m, nz + real(dp) :: r + + type(Atoms) :: unit, sheet, unittube + real(dp) :: a1(2), a2(2), x(2), lattice(3,3), normx + integer :: i + + real, parameter :: NANOTUBE_VACCUUM = 10.0_dp + + a1 = a*(/3.0_dp/2.0_dp, sqrt(3.0_dp)/2.0/) + a2 = a*(/3.0_dp/2.0_dp, -sqrt(3.0_dp)/2.0/) + + call Graphene_Sheet(sheet, a, n, m, 1, 1) + + ! x gets mapped to circumference of tube + x = n*a1 + m*a2 + normx = norm(x) + + ! Circumference of tube is norm(x) + r = normx/(2.0_dp*pi) + + ! Tube lattice + lattice = 0.0_dp + lattice(1,1) = 2*r + NANOTUBE_VACCUUM + lattice(2,2) = lattice(1,1) + lattice(3,3) = sheet%lattice(2,2) + + call Initialise(unittube, sheet%N, lattice) + unittube%Z = sheet%Z + unittube%species = sheet%species + + if (has_property(unittube,'mass')) & + forall(i=1:unittube%N) unittube%mass(i) = ElementMass(unittube%Z(i)) + + ! Roll up sheet to form tube + do i = 1,unittube%N + unittube%pos(1,i) = r*cos(2.0_dp*pi*sheet%pos(1,i)/normx) + unittube%pos(2,i) = r*sin(2.0_dp*pi*sheet%pos(1,i)/normx) + unittube%pos(3,i) = sheet%pos(2,i) + end do + + call Supercell(tube, unittube, 1, 1, nz) + call Finalise(unit) + call Finalise(sheet) + call Finalise(unittube) + + end function Graphene_Tube + + ! + !% Return an atoms object containing one TIP3P water molecule in a box + !% giving the correct density at 300K + ! + function water() + + type(Atoms) :: water + + call initialise(water,3,make_lattice(3.129058333_dp)) + + water%pos(:,1) = (/0.0_dp,0.0_dp,0.0_dp/) + water%pos(:,2) = (/0.9572_dp,0.0_dp,0.0_dp/) + water%pos(:,3) = (/-0.2399872084_dp,0.9266272065_dp,0.0_dp/) + + call set_atoms(water, (/8, 1, 1/)) + + end function water + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! supercell(lotsofatoms, atoms, n1, n2, n3) + ! + !% Replicates the unit cell 'n1*n2*n3' times along the lattice vectors. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine supercell(aa, a, n1, n2, n3, supercell_index_name, error) + type(Atoms), intent(out)::aa !% Output (big) cell + type(Atoms), intent(in)::a !% Input cell + integer, intent(in)::n1, n2, n3 + character(len=*), intent(in), optional :: supercell_index_name + integer, intent(out), optional :: error + + real(dp)::lattice(3,3), p(3) + integer::i,j,k,n,nn + + integer, pointer :: a_int_ptr(:), a_int2_ptr(:,:), aa_int_ptr(:), aa_int2_ptr(:,:), supercell_index(:,:) + real(dp), pointer :: a_real_ptr(:), a_real2_ptr(:,:), aa_real_ptr(:), aa_real2_ptr(:,:) + logical, pointer :: a_logical_ptr(:), aa_logical_ptr(:) + character, pointer :: a_char_ptr(:,:), aa_char_ptr(:,:) + + INIT_ERROR(error) + + lattice(:,1) = a%lattice(:,1)*n1 + lattice(:,2) = a%lattice(:,2)*n2 + lattice(:,3) = a%lattice(:,3)*n3 + call initialise(aa, a%N*n1*n2*n3, lattice) + call set_cutoff(aa, a%cutoff) + + do n=1,a%properties%n + select case(a%properties%entries(n)%type) + + case(T_INTEGER_A) + if (.not. assign_pointer(a, string(a%properties%keys(n)), a_int_ptr)) then + RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) + end if + call add_property(aa, string(a%properties%keys(n)), 0, ptr=aa_int_ptr, error=error, overwrite=.true.) + PASS_ERROR(error) + do i=0,n1-1 + do j=0,n2-1 + do k=0,n3-1 + aa_int_ptr(((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_int_ptr(:) + end do + end do + end do + + case(T_REAL_A) + if (.not. assign_pointer(a, string(a%properties%keys(n)), a_real_ptr)) then + RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) + end if + call add_property(aa, string(a%properties%keys(n)), 0.0_dp, ptr=aa_real_ptr, error=error, overwrite=.true.) + PASS_ERROR(error) + do i=0,n1-1 + do j=0,n2-1 + do k=0,n3-1 + aa_real_ptr(((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_real_ptr(:) + end do + end do + end do + + case(T_LOGICAL_A) + if (.not. assign_pointer(a, string(a%properties%keys(n)), a_logical_ptr)) then + RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) + end if + call add_property(aa, string(a%properties%keys(n)), .false., ptr=aa_logical_ptr, error=error, overwrite=.true.) + PASS_ERROR(error) + do i=0,n1-1 + do j=0,n2-1 + do k=0,n3-1 + aa_logical_ptr(((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_logical_ptr(:) + end do + end do + end do + + case(T_INTEGER_A2) + if (.not. assign_pointer(a, string(a%properties%keys(n)), a_int2_ptr)) then + RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) + end if + call add_property(aa, string(a%properties%keys(n)), 0, n_cols=size(a_int2_ptr,1), & + ptr2=aa_int2_ptr, error=error, overwrite=.true.) + PASS_ERROR(error) + do i=0,n1-1 + do j=0,n2-1 + do k=0,n3-1 + aa_int2_ptr(:,((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_int2_ptr(:,:) + end do + end do + end do + + case(T_REAL_A2) + if (.not. assign_pointer(a, string(a%properties%keys(n)), a_real2_ptr)) then + RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) + end if + call add_property(aa, string(a%properties%keys(n)), 0.0_dp, n_cols=size(a_real2_ptr,1), & + ptr2=aa_real2_ptr, error=error, overwrite=.true.) + PASS_ERROR(error) + do i=0,n1-1 + do j=0,n2-1 + do k=0,n3-1 + aa_real2_ptr(:,((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_real2_ptr(:,:) + end do + end do + end do + + case(T_CHAR_A) + if (.not. assign_pointer(a, string(a%properties%keys(n)), a_char_ptr)) then + RAISE_ERROR('supercell: cannot assign pointer to property '//a%properties%keys(n), error) + end if + call add_property(aa, string(a%properties%keys(n)), repeat(' ', TABLE_STRING_LENGTH), ptr=aa_char_ptr, error=error, overwrite=.true.) + PASS_ERROR(error) + do i=0,n1-1 + do j=0,n2-1 + do k=0,n3-1 + aa_char_ptr(:,((i*n2+j)*n3+k)*a%n+1:((i*n2+j)*n3+k)*a%n+a%n) = a_char_ptr(:,:) + end do + end do + end do + + case default + RAISE_ERROR('supercell: bad property type '//a%properties%entries(i)%type, error) + end select + end do + + if(present(supercell_index_name)) then + if( has_property(aa, trim(supercell_index_name)) ) then + call print_message('WARNING', "supercell_index_name = "//trim(supercell_index_name)//" but it is already present in atoms object, it will be overwritten.") + endif + call add_property(aa, trim(supercell_index_name), 0, n_cols=3, ptr2=supercell_index, error=error, overwrite=.true.) + PASS_ERROR(error) + endif + + do i = 0,n1-1 + do j = 0,n2-1 + do k = 0,n3-1 + p = a%lattice .mult. (/i,j,k/) + do n = 1,a%N + nn = ((i*n2+j)*n3+k)*a%n+n + ! overwrite position with shifted pos + aa%pos(:,nn) = a%pos(:,n)+p + if(present(supercell_index_name)) supercell_index(:,nn) = (/i,j,k/) + end do + end do + end do + end do + + end subroutine supercell + + + !% Create a supercell of size sx and sy out of unit cell that are rotated + !% by phi in the x-y plane. + !% + !% The final cell might be distorted, but distortions become smaller then + !% sx and sy grow. The strain tensor that describes these distortions is + !% returned in the optional parameter eps. + !% + !% If phi_min is given, the angle that minimizes the norm of the strain + !% tensor will be determined using a downhill search starting from phi. + !% The minimum angle is then output in phi_min. + subroutine rotated_supercell(at, unitcell, sx, sy, phi, phi_min, eps, error) + implicit none + + type(Atoms), intent(inout) :: at + type(Atoms), intent(in) :: unitcell + real(DP), intent(in) :: sx, sy + real(DP), intent(in) :: phi + real(DP), optional, intent(out) :: phi_min + real(DP), optional, intent(out) :: eps(2, 2) + integer, optional, intent(out) :: error + + ! --- + + real(DP), parameter :: initial_step_size = 0.001_DP + + integer :: i, j, jn, n1, n2, m1, m2 + + real(DP) :: p1, p3, p5, en1, en3, en5, step_size, d, d0 + real(DP) :: x(3), T(2, 2), Tr(2, 2), lattice(3, 3) + + logical, allocatable :: mask(:) + + ! --- + + INIT_ERROR(error) + + ! + ! Determine nearest neighbor distance + ! + + d0 = sum(unitcell%lattice) + do i = 1, at%N-1 + do j = i+1, at%N + d0 = min(d0, distance_min_image(at, i, j)) + enddo + enddo + + ! + ! Determine parameters of the rotated supercell + ! + + if (present(phi_min)) then + step_size = initial_step_size + p3 = phi + call find_rotated_supercell(unitcell, sx, sy, p3, n1, n2, m1, m2, eps) + en3 = sqrt(sum(eps*eps)) + + do while (step_size > 1e-6) + p1 = p3-step_size + p5 = p3+step_size + + call find_rotated_supercell( & + unitcell, sx, sy, p1, n1, n2, m1, m2, eps) + en1 = sqrt(sum(eps*eps)) + call find_rotated_supercell( & + unitcell, sx, sy, p5, n1, n2, m1, m2, eps) + en5 = sqrt(sum(eps*eps)) + + if (en1 < en3 .and. en5 < en3) then + if (en1 < en5) then + p3 = p1 + en3 = en1 + else + p3 = p5 + en3 = en5 + endif + else if (en1 < en3) then + p3 = p1 + en3 = en1 + else if (en5 < en3) then + p3 = p5 + en3 = en5 + else + step_size = step_size * 0.1_DP + endif + enddo + + phi_min = p3 + call find_rotated_supercell( & + unitcell, sx, sy, phi_min, n1, n2, m1, m2, eps) + else + call find_rotated_supercell( & + unitcell, sx, sy, phi, n1, n2, m1, m2, eps) + endif + + ! + ! Create template supercell + ! + + call supercell( & + at, unitcell, & + abs(n1)+abs(m1)+2, & + abs(n2)+abs(m2)+2, & + 1, error=error) + PASS_ERROR(error) + + ! + ! Transform from unrotated to rotated cell + ! + + allocate(mask(at%N)) + mask = .true. + + ! n2 is negative for 0 < phi < pi/2 + at%pos(2, :) = at%pos(2, :) + n2*unitcell%lattice(2, 2) + + T(:, 1) = n1*unitcell%lattice(1:2, 1) + n2*unitcell%lattice(1:2, 2) + T(:, 2) = m1*unitcell%lattice(1:2, 1) + m2*unitcell%lattice(1:2, 2) + call inverse(T, Tr) + + do i = 1, at%N + x(1:2) = matmul(Tr, at%pos(1:2, i)) + + ! Allow for reasonable epsilon. Dublicates will be removed later. + if (x(1) > -0.01_DP .and. x(1)-1.0_DP < 0.01_DP .and. & + x(2) > -0.01_DP .and. x(2)-1.0_DP < 0.01_DP) then + at%pos(1, i) = modulo(x(1), 1.0_DP)*sx + at%pos(2, i) = modulo(x(2), 1.0_DP)*sy + mask(i) = .false. + endif + enddo + + call remove_atoms(at, mask, error=error) + PASS_ERROR(error) + + lattice = 0.0_DP + lattice(1, 1) = sx + lattice(2, 2) = sy + lattice(3, 3) = at%lattice(3, 3) + call set_lattice(at, lattice, .false.) + + ! + ! Remove dublicates. + ! Any better idea to do this is greatly appreciated. It seems that any + ! threshold above always leads to either dublicates or missing atoms + ! in some situations. + ! + + call set_cutoff(at, d0*1.1_DP) + call calc_connect(at) + mask(1:at%N) = .false. + d0 = 0.5_DP*d0 + do i = 1, at%N + do jn = 1, n_neighbours(at, i) + j = neighbour(at, i, jn, distance=d) + if (i < j) then + if (d < d0) then + mask(i) = .true. + endif + endif + enddo + enddo + call remove_atoms(at, mask(1:at%N), error=error) + PASS_ERROR(error) + + deallocate(mask) + + endsubroutine rotated_supercell + + + !% Find the lattice parameters for the rotated supercell + subroutine find_rotated_supercell( & + unitcell, sx, sy, phi, n1, n2, m1, m2, eps) + implicit none + + type(Atoms), intent(in) :: unitcell + real(DP), intent(in) :: sx, sy + real(DP), intent(in) :: phi + integer, intent(out) :: n1, n2 + integer, intent(out) :: m1, m2 + real(DP), optional, intent(out) :: eps(2, 2) !% strain + + ! --- + + ! / sx \ + ! n1 a1 + n2 a2 = | | + ! \ 0 / + ! + ! / 0 \ + ! m1 a1 + m2 a2 = | | + ! \ sy / + + real(DP) :: l1, l2, sphi, cphi, tphi, n2r, m2r + real(DP) :: a1(2), a2(2), b1(2), b2(2) + + ! --- + + l1 = unitcell%lattice(1, 1) + l2 = unitcell%lattice(2, 2) + + sphi = sin(phi) + cphi = cos(phi) + tphi = sphi/cphi + + n2r = - sx/(sphi + cphi/tphi) + m2r = sy/(cphi + sphi*tphi) + + n1 = - nint( n2r/(l1*tphi) ) + m1 = nint( m2r/l1 *tphi ) + + n2 = nint( n2r/l2 ) + m2 = nint( m2r/l2 ) + + if (present(eps)) then + ! Compute strain + + a1 = (/ cphi*l1, sphi*l1 /) + a2 = (/ -sphi*l2, cphi*l2 /) + + b1 = n1*a1 + n2*a2 + b2 = m1*a1 + m2*a2 + + eps(1, 1) = b1(1)/sx - 1.0_DP + eps(2, 1) = b1(2)/sx + eps(1, 2) = b2(1)/sy + eps(2, 2) = b2(2)/sy - 1.0_DP + endif + + endsubroutine find_rotated_supercell + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! diamond(myatoms, a) + ! + !% Creates an 8-atom diamond-structure with cubic lattice constant of 'a' + !% and atomic number 'Z', e.g. in Python:: + !% + !% a = diamond(5.44, 14) # Silicon unit cell + !% + !% Or, in Fortran:: + !% + !% type(Atoms) :: at + !% ... + !% call diamond(at, 5.44_dp, 14) + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine diamond(myatoms, a, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a + integer, intent(in), optional :: Z(:) + + call initialise(myatoms, 8, & + reshape((/a,0.0_dp,0.0_dp,0.0_dp,a,0.0_dp,0.0_dp,0.0_dp,a/), (/3,3/))) + + myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) ! sublattice 1 + myatoms%pos(:,2) = a*(/0.25_dp, 0.25_dp, 0.25_dp/) ! sublattice 2 + myatoms%pos(:,3) = a*(/0.50_dp, 0.50_dp, 0.00_dp/) ! sublattice 1 + myatoms%pos(:,4) = a*(/0.75_dp, 0.75_dp, 0.25_dp/) ! sublattice 2 + myatoms%pos(:,5) = a*(/0.50_dp, 0.00_dp, 0.50_dp/) ! sublattice 1 + myatoms%pos(:,6) = a*(/0.75_dp, 0.25_dp, 0.75_dp/) ! sublattice 2 + myatoms%pos(:,7) = a*(/0.00_dp, 0.50_dp, 0.50_dp/) ! sublattice 1 + myatoms%pos(:,8) = a*(/0.25_dp, 0.75_dp, 0.75_dp/) ! sublattice 2 + + if (present(Z)) then + if (size(Z) == 1) then + myatoms%Z = Z(1) + if (has_property(myatoms, 'mass')) & + myatoms%mass = ElementMass(Z(1)) + else if (size(Z) == 2) then + myatoms%Z(1:7:2) = Z(1) + if (has_property(myatoms, 'mass')) & + myatoms%mass(1:7:2) = ElementMass(Z(1)) + + myatoms%Z(2:8:2) = Z(2) + if (has_property(myatoms, 'mass')) & + myatoms%mass(2:8:2) = ElementMass(Z(2)) + else + call system_abort("diamond got passed Z with size="//size(Z)//" which isn't 1 or 2") + endif + + call set_atoms(myatoms,myatoms%Z) + endif + end subroutine diamond + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! diamond2(myatoms, a, Z) + ! + !% Creates a 2-atom diamond-structure with cubic lattice constant of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine diamond2(myatoms, a, Z1, Z2) + type(Atoms), intent(out) :: myatoms + real(dp) :: a + integer, intent(in), optional :: Z1, Z2 + integer :: my_Z1, my_Z2 + + my_Z1 = optional_default(6, Z1) + my_Z2 = optional_default(6, Z2) + + call initialise(myatoms, 2, & + reshape((/a/2,a/2,0.0_dp,0.0_dp,a/2,a/2,a/2,0.0_dp,a/2/), (/3,3/))) + + myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) + myatoms%pos(:,2) = a*(/0.25_dp, 0.25_dp, 0.25_dp/) + + call set_atoms(myatoms,(/my_Z1,my_Z2/)) + + end subroutine diamond2 + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! beta_tin(myatoms, a, c, Z) + ! + !% Creates a 2-atom beta-tin structure with lattice constants of a and c + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine beta_tin(myatoms, a, c, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a, c + integer, intent(in), optional :: Z + + call initialise(myatoms, 2, & + reshape((/ 0.5_dp*a,-0.5_dp*a,-0.5_dp*c, & + &-0.5_dp*a, 0.5_dp*a,-0.5_dp*c, & + & 0.5_dp*a, 0.5_dp*a, 0.5_dp*c /), (/3,3/) )) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ -0.125_dp, -0.375_dp, 0.25_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.125_dp, 0.375_dp, -0.25_dp /)) + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine beta_tin + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! beta_tin4(myatoms, a, c, Z) + ! + !% Creates a 4-atom beta-tin structure with lattice constants of a and c + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine beta_tin4(myatoms, a, c, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a, c + integer, intent(in), optional :: Z + + call initialise(myatoms, 4, & + reshape((/a, 0.0_dp, 0.0_dp, 0.0_dp, a, 0.0_dp, 0.0_dp, 0.0_dp, c/), (/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.00_dp, 0.00_dp, 0.00_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.50_dp, 0.50_dp, 0.50_dp /)) + myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 0.00_dp, 0.50_dp, 0.25_dp /)) + myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 0.50_dp, 0.00_dp, 0.75_dp /)) + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine beta_tin4 + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! fcc(myatoms, a, Z) + ! + !% Creates a 4-atom fcc-structure with cubic lattice constant of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine fcc(myatoms, a, Z) + type(Atoms), intent(out) :: myatoms + real(dp) :: a + integer, intent(in), optional :: Z + + call initialise(myatoms, 4, & + reshape((/a,0.0_dp,0.0_dp,0.0_dp,a,0.0_dp,0.0_dp,0.0_dp,a/), (/3,3/))) + + myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) + myatoms%pos(:,2) = a*(/0.50_dp, 0.50_dp, 0.00_dp/) + myatoms%pos(:,3) = a*(/0.50_dp, 0.00_dp, 0.50_dp/) + myatoms%pos(:,4) = a*(/0.00_dp, 0.50_dp, 0.50_dp/) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine fcc + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! fcc1(myatoms, a, Z) + ! + !% Creates a 1-atom fcc-structure with cubic lattice constant of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine fcc1(myatoms, a, Z) + type(Atoms), intent(out) :: myatoms + real(dp) :: a + integer, intent(in), optional :: Z + integer :: my_Z + + my_Z = optional_default(6, Z) + + call initialise(myatoms, 1, & + reshape((/a/2,a/2,0.0_dp,0.0_dp,a/2,a/2,a/2,0.0_dp,a/2/), (/3,3/))) + + myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) + + call set_atoms(myatoms,(/my_Z/)) + + end subroutine fcc1 + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! hcp(myatoms, a, Z) + ! + !% Creates a 2-atom hcp lattice with lattice constants of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine hcp(myatoms, a, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a + integer, intent(in), optional :: Z + + call initialise(myatoms, 2, & + reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.0_dp, 0.0_dp, a*sqrt(8.0_dp/3.0_dp) /),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 0.5_dp /)) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine hcp + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! sh(myatoms, a, Z) + ! + !% Creates a 1-atom simple hexagonal lattice with lattice constants of 'a' and 'c' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine sh(myatoms, a, c, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a, c + integer, intent(in), optional :: Z + + call initialise(myatoms, 1, & + reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.0_dp, 0.0_dp, c /),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine sh + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! sh2(myatoms, a, Z) + ! + !% Creates a 2-atom simple hexagonal lattice with lattice constants of 'a' and 'c' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine sh2(myatoms, a, c, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a, c + integer, intent(in), optional :: Z + + call initialise(myatoms, 2, & + reshape( (/ a, 0.0_dp, 0.0_dp, & + & 0.0_dp, sqrt(3.0_dp)*a, 0.0_dp, & + & 0.0_dp, 0.0_dp, c /),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.5_dp, 0.5_dp, 0.0_dp /)) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine sh2 + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! imma(myatoms, a, b, c, u, Z) + ! + !% Creates a 2-atom Imma cell + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine imma(myatoms, a, b, c, u, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a, b, c, u + integer, intent(in), optional :: Z + + call initialise(myatoms, 2, & + 0.5_dp * reshape( (/ a, b, -c, & + -a, b, c, & + a, -b, c /),(/3,3/))) + + !myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.25_dp, 0.25_dp+u, u /)) + !myatoms%pos(:,2) = -matmul(myatoms%lattice, (/ 0.25_dp, 0.25_dp+u, u /)) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.00_dp, 0.00_dp, 0.00_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.50_dp, 0.50_dp+u, u /)) + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine imma + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! imma4(myatoms, a, b, c, u, Z) + ! + !% Creates a 4-atom Imma cell + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine imma4(myatoms, a, b, c, u, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a, b, c, u + integer, intent(in), optional :: Z + + call initialise(myatoms, 4, & + reshape( (/ a, 0.0_dp, 0.0_dp, & + 0.0_dp, b, 0.0_dp, & + 0.0_dp, 0.0_dp, c /),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.00_dp, 0.00_dp, 0.00_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.50_dp, 0.50_dp, 0.50_dp /)) + myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 0.00_dp, 0.50_dp, u /)) + myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 0.50_dp, 0.00_dp, 0.50_dp + u /)) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine imma4 + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! sc(myatoms, a, Z) + ! + !% Creates a 1-atom simple cubic lattice with lattice constants of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine sc(myatoms, a, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a + integer, intent(in), optional :: Z + + call initialise(myatoms, 1, & + reshape( (/ a, 0.0_dp, 0.0_dp, & + & 0.0_dp, a, 0.0_dp, & + & 0.0_dp, 0.0_dp, a /),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine sc + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! bcc(myatoms, a, Z) + ! + !% Creates a 2-atom bcc-structure with cubic lattice constant of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine bcc(myatoms, a, Z) + type(Atoms), intent(out) :: myatoms + real(dp) :: a + integer, intent(in), optional :: Z + + call initialise(myatoms, 2, & + reshape((/a,0.0_dp,0.0_dp,0.0_dp,a,0.0_dp,0.0_dp,0.0_dp,a/), (/3,3/))) + + myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) + myatoms%pos(:,2) = a*(/0.50_dp, 0.50_dp, 0.50_dp/) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine bcc + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! bcc1(myatoms, a, Z) + ! + !% Creates a 1-atom primitive bcc-structure with cubic lattice constant of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine bcc1(myatoms, a, Z) + type(Atoms), intent(out) :: myatoms + real(dp) :: a + integer, intent(in), optional :: Z + + call initialise(myatoms, 1, & + & 0.5_dp*a*reshape( (/1.0_dp,-1.0_dp, 1.0_dp, & + & 1.0_dp, 1.0_dp,-1.0_dp, & + &-1.0_dp, 1.0_dp, 1.0_dp/),(/3,3/))) + + myatoms%pos(:,1) = (/0.00_dp, 0.00_dp, 0.00_dp/) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine bcc1 + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! zincblende2(myatoms, a, Z1, Z2) + ! + !% Creates a 2-atom zincblende lattice with lattice constants of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine zincblende(myatoms, a, Z1, Z2) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a + integer, intent(in), optional :: Z1, Z2 + + call initialise(myatoms, 2, & + reshape( (/0.0_dp, 0.5_dp*a, 0.5_dp*a, & + & 0.5_dp*a, 0.0_dp, 0.5_dp*a, & + & 0.5_dp*a, 0.5_dp*a, 0.0_dp /),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.00_dp, 0.00_dp, 0.00_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.25_dp, 0.25_dp, 0.25_dp /)) + + if (present(Z1).and.present(Z2)) call set_atoms(myatoms,(/Z1,Z2/)) + if (present(Z1).and. .not.present(Z2)) call set_atoms(myatoms,Z1) + if (.not. present(Z1).and. present(Z2)) call set_atoms(myatoms,Z2) + + end subroutine zincblende + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! wurtzite(myatoms, a, Z1, Z2) + ! + !% Creates a 4-atom wurtzite lattice with lattice constants of 'a' and 'c' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine wurtzite(myatoms, a, c, Z1, Z2, u) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a + real(dp), intent(in), optional :: c, u + integer, intent(in), optional :: Z1, Z2 + + real(dp) :: my_c, my_u + + my_c = optional_default(sqrt(8.0_dp/3.0_dp)*a,c) + my_u = optional_default(3.0_dp/8.0_dp,u) + + call initialise(myatoms, 4, & + reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.0_dp, 0.0_dp, my_c/),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 0.00_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 0.50_dp /)) + myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, my_u /)) + myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 0.50_dp+my_u /)) + + if (present(Z1).and.present(Z2)) call set_atoms(myatoms,(/Z1,Z1,Z2,Z2/)) + if (present(Z1).and. .not.present(Z2)) call set_atoms(myatoms,Z1) + if (.not. present(Z1).and. present(Z2)) call set_atoms(myatoms,Z2) + + end subroutine wurtzite + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! a15(myatoms, a, Z) + ! + !% Creates an 8-atom a15-structure with cubic lattice constant of 'a' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine a15(myatoms, a, Z) + type(Atoms), intent(out) :: myatoms + real(dp) :: a + integer, intent(in), optional :: Z + + call initialise(myatoms, 8, & + reshape((/a,0.0_dp,0.0_dp,0.0_dp,a,0.0_dp,0.0_dp,0.0_dp,a/), (/3,3/))) + + myatoms%pos(:,1) = a*(/0.00_dp, 0.00_dp, 0.00_dp/) + myatoms%pos(:,2) = a*(/0.50_dp, 0.50_dp, 0.50_dp/) + myatoms%pos(:,3) = a*(/0.25_dp, 0.50_dp, 0.00_dp/) + myatoms%pos(:,4) = a*(/0.75_dp, 0.50_dp, 0.00_dp/) + myatoms%pos(:,5) = a*(/0.00_dp, 0.25_dp, 0.50_dp/) + myatoms%pos(:,6) = a*(/0.00_dp, 0.75_dp, 0.50_dp/) + myatoms%pos(:,7) = a*(/0.50_dp, 0.00_dp, 0.25_dp/) + myatoms%pos(:,8) = a*(/0.50_dp, 0.00_dp, 0.75_dp/) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine a15 + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! graphite(myatoms, a, c, Z) + ! + !% Creates a 4-atom graphite lattice with lattice constants of 'a' and 'c' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine graphite(myatoms, a, c, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a, c + integer, intent(in), optional :: Z + + call initialise(myatoms, 4, & + reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.0_dp, 0.0_dp, c/),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.25_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.75_dp /)) + myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 0.25_dp /)) + myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 0.75_dp /)) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine graphite + + subroutine graphite_rhombohedral(myatoms, a, c, Z) + type(Atoms), intent(out) :: myatoms + real(dp), intent(in) :: a, c + integer, intent(in), optional :: Z + + call initialise(myatoms, 6, & + reshape( (/0.5_dp*a,-0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp, & + & 0.0_dp, 0.0_dp, c/),(/3,3/))) + + myatoms%pos(:,1) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 0.0_dp /)) + myatoms%pos(:,2) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 0.0_dp /)) + myatoms%pos(:,3) = matmul(myatoms%lattice, (/ 0.0_dp, 0.0_dp, 1.0_dp/3.0_dp /)) + myatoms%pos(:,4) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 1.0_dp/3.0_dp /)) + myatoms%pos(:,5) = matmul(myatoms%lattice, (/ 1.0_dp/3.0_dp, 2.0_dp/3.0_dp, 2.0_dp/3.0_dp /)) + myatoms%pos(:,6) = matmul(myatoms%lattice, (/ 2.0_dp/3.0_dp, 1.0_dp/3.0_dp, 2.0_dp/3.0_dp /)) + + if (present(Z)) call set_atoms(myatoms,Z) + + end subroutine graphite_rhombohedral + + !% Primitive 9-atom trigonal alpha quartz cell, with lattice constants + !% `a` and `c` and internal coordinates `u` (Si), `x`, `y` and `z` (O). + subroutine alpha_quartz(at, a, c, u, x, y, z) + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a, c, u, x, y, z + + real(dp) :: lattice(3,3), a1(3), a2(3), a3(3) + + lattice = 0.0_dp + a1 = (/ 0.5_dp*a, -0.5_dp*sqrt(3.0_dp)*a, 0.0_dp /) + a2 = (/ 0.5_dp*a, 0.5_dp*sqrt(3.0_dp)*a, 0.0_dp /) + a3 = (/ 0.0_dp, 0.0_dp, c /) + lattice(:,1) = a1 + lattice(:,2) = a2 + lattice(:,3) = a3 + + call initialise(at, n=9, lattice=lattice) + call set_atoms(at, (/14,14,14,8,8,8,8,8,8 /)) + + at%pos(:,1) = u*a1 + 2.0_dp/3.0_dp*a3 + at%pos(:,2) = u*a2 + 1.0_dp/3.0_dp*a3 + at%pos(:,3) = -u*a1 - u*a2 + at%pos(:,4) = x*a1 + y*a2 + (z + 2.0_dp/3.0_dp)*a3 + at%pos(:,5) = -y*a1 + (x-y)*a2 + (4.0_dp/3.0_dp + z)*a3 + at%pos(:,6) = (y-x)*a1 - x*a2 + (1.0_dp+ z)*a3 + at%pos(:,7) = y*a1 + x*a2 - (2.0_dp/3.0_dp + z)*a3 + at%pos(:,8) = -x*a1 + (y-x)*a2 - z*a3 + at%pos(:,9) = (x - y)*a1 - y*a2 - (1.0_dp/3.0_dp + z)*a3 + + call add_property(at, 'primitive_index', (/ 1,2,3,4,5,6,7,8,9 /)) + + end subroutine alpha_quartz + + !% Non-primitive 18-atom cubic quartz cell + subroutine alpha_quartz_cubic(at, a, c, u, x, y, z) + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a, c, u, x, y, z + + type(Atoms) :: a0, a1 + real(dp) :: lattice(3,3), g(3,3), t(3) + logical, allocatable, dimension(:) :: unit_cell + integer :: i + + call alpha_quartz(a0, a, c, u, x, y, z) + call supercell(a1, a0, 4, 4, 1) + call map_into_cell(a1) + + lattice = 0.0_dp + lattice(1,1) = a0%lattice(1,1)*2.0_dp + lattice(2,2) = a0%lattice(2,2)*2.0_dp + lattice(3,3) = a0%lattice(3,3) + call matrix3x3_inverse(lattice,g) + + allocate(unit_cell(a1%n)) + unit_cell = .false. + do i=1,a1%n + ! add small shift to avoid coincidental alignment + t = g .mult. a1%pos(:,i) + (/0.01_dp, 0.02_dp, 0.03_dp/) + if (all(t >= -0.5) .and. all(t < 0.5)) unit_cell(i) = .true. + end do + + call select(at, a1, mask=unit_cell) + call set_lattice(at, lattice, scale_positions=.false.) + + deallocate(unit_cell) + + end subroutine alpha_quartz_cubic + + subroutine rutile(at, a, c, u) +!For atomic coordinates see Ref. PRB 65, 224112 (2002). +!Experimental values: a=4.587, c=2.954, u=0.305 (Ref. JACS 109, 3639 (1987)). + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a, c, u + + real(dp) :: lattice(3,3), a1(3), a2(3), a3(3) + + lattice = 0.0_dp + a1 = (/ a, 0.0_dp, 0.0_dp /) + a2 = (/ 0.0_dp, a, 0.0_dp /) + a3 = (/ 0.0_dp, 0.0_dp, c /) + lattice(:,1) = a1 + lattice(:,2) = a2 + lattice(:,3) = a3 + + call initialise(at, n=6, lattice=lattice) + call set_atoms(at, (/22,22,8,8,8,8 /)) + + at%pos(:,1) = 0.0_dp + at%pos(:,2) = 0.5_dp * a1 + 0.5_dp*a2 + 0.5_dp*a3 + at%pos(:,3) = u*a1 + u*a2 + at%pos(:,4) = -u*a1 - u*a2 + at%pos(:,5) = (0.5_dp + u)*a1 + (0.5_dp - u)*a2 + 0.5_dp*a3 + at%pos(:,6) = (0.5_dp - u)*a1 + (0.5_dp + u)*a2 + 0.5_dp*a3 + + call add_property(at, 'primitive_index', (/ 1,2,3,4,5,6/)) + + end subroutine rutile + + subroutine anatase_cubic(at, a, c, u) +!Conventional 12 atoms unit cell defined as a function of a,c,u. +!Experimental values: a=3.782, c=9.502, u=0.208 (Ref. JACS 109, 3639 (1987)). + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a, c, u + + real(dp) :: lattice(3,3), a1(3), a2(3), a3(3) + + lattice = 0.0_dp + a1 = (/ a, 0.0_dp, 0.0_dp /) + a2 = (/ 0.0_dp, a, 0.0_dp /) + a3 = (/ 0.0_dp, 0.0_dp, c /) + lattice(:,1) = a1 + lattice(:,2) = a2 + lattice(:,3) = a3 + + call initialise(at, n=12, lattice=lattice) + call set_atoms(at, (/22,22,22,22,8,8,8,8,8,8,8,8 /)) + + at%pos(:,1) = (/0.0_dp*a, 0.5_dp*a, 0.0_dp /) + at%pos(:,2) = (/0.0_dp, 0.0_dp , 0.25_dp*c/) + at%pos(:,3) = (/0.5_dp*a, 0.5_dp*a, -0.25_dp*c/) + at%pos(:,4) = (/0.5_dp*a, 0.0_dp , 0.50_dp*c/) + at%pos(:,5) = (/0.0_dp , 0.5_dp*a, u * c /) + at%pos(:,6) = (/0.0_dp , 0.5_dp*a, -u * c /) + at%pos(:,7) = (/0.0_dp , 0.0_dp , (0.25_dp+u)*c /) + at%pos(:,8) = (/0.0_dp , 0.0_dp , (0.25_dp-u)*c /) + at%pos(:,9) = (/0.5_dp*a, 0.5_dp*a, (0.75_dp-u)*c /) + at%pos(:,10)= (/0.5_dp*a, 0.0_dp , (0.50_dp-u)*c /) + at%pos(:,11)= (/0.5_dp*a, 0.0_dp , -(0.50_dp-u)*c /) + at%pos(:,12)= (/0.5_dp*a, 0.5_dp*a, -(0.25_dp-u)*c /) + + call add_property(at, 'primitive_index', (/ 1,2,3,4,5,6,7,8,9,10,11,12/)) + + end subroutine anatase_cubic + +subroutine anatase(at, a, c, u) +!Conventional 6 atoms unit cell defined as a function of a,c,u. +!Experimental values: a=3.782, c=9.502, u=0.208 (Ref. JACS 109, 3639 (1987)). + type(Atoms), intent(out) :: at + real(dp), intent(in) :: a, c, u + real(dp) :: uu + + real(dp) :: lattice(3,3), a1(3), a2(3), a3(3) + + lattice = 0.0_dp + a1 = (/ a, 0.0_dp, 0.0_dp /) + a2 = (/ 0.0_dp, a, 0.0_dp /) + a3 = (/ 0.5_dp*a, 0.5_dp*a, 0.5_dp*c /) + lattice(:,1) = a1 + lattice(:,2) = a2 + lattice(:,3) = a3 + + call initialise(at, n=6, lattice=lattice) + call set_atoms(at, (/22, 22,8,8,8,8/)) + + uu = u - 1.0_dp/8.0_dp + at%pos(:,1) = (/0.0_dp , 0.75_dp*a, 0.125_dp*c/) + at%pos(:,2) = (/0.5_dp*a , 0.75_dp*a, 0.375_dp*c/) + at%pos(:,3) = (/0.0_dp , 0.25_dp*a, uu*c /) + at%pos(:,4) = (/0.0_dp , 0.75_dp*a, (0.25_dp+uu)*c/) + at%pos(:,5) = (/0.5_dp*a , 0.25_dp*a, (0.5_dp -uu)*c/) + at%pos(:,6) = (/0.5_dp*a , 0.75_dp*a, (0.25_dp-uu)*c/) + + call add_property(at, 'primitive_index', (/1,2,3,4,5,6/)) + + end subroutine anatase + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Given a lattice type ('P','I','F','A','B','C') and a motif, + !% creates an atoms object which consists of the motif + !% applied to each lattice point in one unit cell. + !% This object can then be supercelled. + !% + !% e.g. The following code creates the YBCO superconductor + !% structure, and allows the oxygen positions to be changed + !% by altering delta_O: + !% + !%> type(atoms) :: ybco + !%> type(atoms) :: big_ybco + !%> type(table) :: motif + !%> real(dp), dimension(3,3) :: lattice + !%> real(dp) :: delta_O = 0.03_dp + !%> + !%> lattice = make_lattice(3.8227_dp,3.8827_dp,11.6802_dp) + !%> + !%> call allocate(motif,1,3,0,0,13) + !%> + !%> call append(motif,Atomic_Number('Y'), & + !%> (/real(0.5,dp),real(0.5,dp),real(0.5,dp)/)) + !%> call append(motif,Atomic_Number('Ba'), + !%> (/real(0.5,dp),real(0.5,dp),real((1.0/6.0),dp)/)) + !%> call append(motif,Atomic_Number('Ba'), + !%> (/real(0.5,dp),real(0.5,dp),real((5.0/6.0),dp)/)) + !%> call append(motif,Atomic_Number('Cu'), + !%> (/real(0.0,dp),real(0.0,dp),real(0.0,dp)/)) + !%> call append(motif,Atomic_Number('Cu'), + !%> (/real(0.0,dp),real(0.0,dp),real((1.0/3.0),dp)/)) + !%> call append(motif,Atomic_Number('Cu'), + !%> (/real(0.0,dp),real(0.0,dp),real((2.0/3.0),dp)/)) + !%> call append(motif,Atomic_Number('O'), + !%> (/real(0.0,dp),real(0.0,dp),real((1.0/6.0),dp)/)) + !%> call append(motif,Atomic_Number('O'), + !%> (/real(0.0,dp),real(0.5,dp),real(0.0,dp)/)) + !%> call append(motif,Atomic_Number('O'), & + !%> (/real(0.5,dp),real(0.0,dp),real((1.0/3.0),dp)+delta_O/)) + !%> call append(motif,Atomic_Number('O'), & + !%> (/real(0.0,dp),real(0.5,dp),real((1.0/3.0),dp)+delta_O/)) + !%> call append(motif,Atomic_Number('O'), & + !%> (/real(0.5,dp),real(0.0,dp),real((2.0/3.0),dp)-delta_O/)) + !%> call append(motif,Atomic_Number('O'), & + !%> (/real(0.0,dp),real(0.5,dp),real((2.0/3.0),dp)-delta_O/)) + !%> call append(motif,Atomic_Number('O'), & + !%> (/real(0.0,dp),real(0.0,dp),real((5.0/6.0),dp)/)) + !%> + !%> ybco = make_structure(lattice,'P',motif) + !%> + !%> call supercell(big_ybco,ybco,2,2,2) + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function make_structure(lattice, type, motif) result(structure) + + real(dp), dimension(3,3), intent(in) :: lattice + type(table), intent(in) :: motif + character(1), intent(in) :: type ! P,I,F,A,B or C + type(Atoms) :: structure + !local variables + integer :: i, j, n + type(table) :: points + + !Check the motif + if (motif%N < 1) call system_abort('Make_Structure: Must have at least one atom in motif') + if (motif%intsize /= 1 .or. motif%realsize /= 3) & + call system_abort('Make_Structure: Motif must have 1 int and 3 reals') + + !Set up the lattice points + call allocate(points,0,3,0,0,4) + call append(points, realpart=(/0.0_dp,0.0_dp,0.0_dp/)) + + select case(type) + case('P') + !Primitive. No extra points + case('I') + !Body centred + call append(points, realpart=(/0.5_dp,0.5_dp,0.5_dp/)) + case('F') + !Face centred + call append(points, realpart=(/0.5_dp,0.5_dp,0.0_dp/)) + call append(points, realpart=(/0.5_dp,0.0_dp,0.5_dp/)) + call append(points, realpart=(/0.0_dp,0.5_dp,0.5_dp/)) + case('A') + call append(points, realpart=(/0.0_dp,0.5_dp,0.5_dp/)) + case('B') + call append(points, realpart=(/0.5_dp,0.0_dp,0.5_dp/)) + case('C') + call append(points, realpart=(/0.5_dp,0.5_dp,0.0_dp/)) + case default + call system_abort('Make_Structure: Unknown lattice type: '//type) + end select + + call initialise(structure,(motif%N * points%N),lattice) + + do j = 1, points%N + do i = 1, motif%N + + if (motif%int(1,i) < 1) call system_abort('Make_Structure: Atom '//i//' not recognised') + + n = (j-1)*motif%N + i + + structure%Z(n) = motif%int(1,i) + if (has_property(structure, 'mass')) & + structure%mass(n) = ElementMass(structure%Z(n)) + structure%pos(:,n) = lattice .mult. (motif%real(:,i) + points%real(:,j)) + + end do + end do + + call finalise(points) + + end function make_structure + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% create a supercell of a structure, read from a file, with chosen + !% volume per atom or volume per unit cell, with desired supercell + !% repeats, and specified Z values. + !% file may contain default Z values as a property Z_values='Z1 Z2 ...' + !% structures that begin with . or / are searched for as paths, + !% and everything else is searched for in 'QUIP_ARCH/structures/struct.xyz' + !% or in 'HOME/share/quip_structures/struct.xyz' + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function structure_from_file(struct, vol_per_atom, vol_per_unit_cell, repeat, Z_values_str, error) result(dup_cell) + character(len=*), intent(in) :: struct + real(dp), intent(in), optional :: vol_per_atom, vol_per_unit_cell + integer, intent(in), optional :: repeat(3) + character(len=*), intent(in), optional :: Z_values_str + integer, intent(out), optional :: error + type(Atoms) :: dup_cell + + character(len=STRING_LENGTH) :: struct_file + character(len=STRING_LENGTH) :: quip_structs_dir + type(Atoms) :: cell + real(dp) :: vol, scale + integer :: stat + character(len=STRING_LENGTH) :: Z_values_str_use + character(len=STRING_LENGTH), allocatable :: Z_values_a(:) + integer, allocatable :: Z_values(:), new_Z(:) + integer :: i, n_types, n_fields + real(dp) :: u_vol_per_atom, u_vol_per_unit_cell + integer :: l_error + + INIT_ERROR(error) + + if (minval(repeat) <= 0) & + call system_abort("all elements of repeat='"//repeat//"' must be >= 1") + + u_vol_per_atom = optional_default(-1.0_dp, vol_per_atom) + u_vol_per_unit_cell = optional_default(-1.0_dp, vol_per_unit_cell) + + if (u_vol_per_atom > 0.0_dp .and. u_vol_per_unit_cell > 0.0_dp) & + call system_abort("Only one of u_vol_per_atom="//u_vol_per_atom//" and u_vol_per_unit="//u_vol_per_unit_cell//" cell can be specified") + if (u_vol_per_atom <= 0.0_dp .and. u_vol_per_unit_cell <= 0.0_dp) & + call system_abort("One of u_vol_per_atom ="//u_vol_per_atom//"and u_vol_per_unit ="//u_vol_per_unit_cell//"cell must be specified") + + if (struct(1:1) == '.' .or. struct(1:1) == '/') then + struct_file = trim(struct) + else + call get_env_var("QUIP_STRUCTS_DIR", quip_structs_dir, stat) + if (stat /= 0) then + call get_env_var("QUIP_ROOT", quip_structs_dir, stat) + if (stat /= 0) then + call get_env_var("HOME", quip_structs_dir, stat) + if (stat /= 0) & + call system_abort("Could not get QUIP_STRUCTS_DIR or QUIP_ROOT or HOME env variables") + quip_structs_dir = trim(quip_structs_dir) // "/share/quip_structures" + else + quip_structs_dir = trim(quip_structs_dir) // "/structures" + endif + endif + struct_file = trim(quip_structs_dir)//"/"//trim(struct)//".xyz" + endif + call read(cell, struct_file, error=l_error) + if (l_error /= 0) then + call print("structure_from_file looks for structure files in this order:", PRINT_ALWAYS) + call print(" $QUIP_STRUCTS_DIR", PRINT_ALWAYS) + call print(" $QUIP_ROOT/structures", PRINT_ALWAYS) + call print(" $HOME/share/quip_structures", PRINT_ALWAYS) + RAISE_ERROR("file '"//trim(struct_file)//"' not found", error) + endif + + n_types=maxval(cell%Z)-minval(cell%Z) + 1 + allocate(Z_values(n_types)) + allocate(new_Z(cell%N)) + + if (present(Z_values_str)) then + Z_values_str_use = trim(Z_values_str) + endif + if (len_trim(Z_values_str_use) <= 0) then + if (.not. get_value(cell%params, "z_values", Z_values_str_use)) then + RAISE_ERROR("structure_from_file: no appropriate Z values in cell file or Z_values_str argument", error) + endif + endif + + allocate(Z_values_a(n_types+1)) + call split_string_simple(trim(Z_values_str_use), Z_values_a, n_fields, " ", error) + PASS_ERROR(error) + + if (n_fields /= n_types+1) then + RAISE_ERROR("structure_from_file: got n_types="//n_types//" but n_types+1 /= n_fields="//n_fields, error) + endif + + do i=1, n_types + read (unit=Z_values_a(i+1),fmt=*) Z_values(i) + end do + deallocate(Z_values_a) + + do i=1, n_types + where (cell%Z == i) + new_Z = Z_values(i) + end where + end do + call set_atoms(cell, new_Z) + + vol = cell_volume(cell) + if (u_vol_per_atom > 0.0_dp) then + scale = 1.0_dp/vol**(1.0_dp/3.0_dp) * (cell%N*u_vol_per_atom)**(1.0_dp/3.0_dp) + else + scale = 1.0_dp/vol**(1.0_dp/3.0_dp) * u_vol_per_unit_cell**(1.0_dp/3.0_dp) + endif + call set_lattice(cell, cell%lattice*scale, scale_positions=.true.) + call supercell(dup_cell, cell, repeat(1), repeat(2), repeat(3)) + + deallocate(Z_values) + deallocate(new_Z) + + end function structure_from_file + + !% Transform cell and lattice coordinates by the 3 x 3 matrix `t` + subroutine transform(at_out, at_in, t) + type(Atoms), intent(out)::at_out !% Output + type(Atoms), intent(in) ::at_in !% Input + real(dp), intent(in)::t(3,3) + + at_out = at_in + call set_lattice(at_out,(t .mult. at_in%lattice), scale_positions=.true.) + end subroutine transform + + + !% + !% Subgraph isomorphism identifier based on J.R. Ullmann, JACM 23(1) 31-42 (1976) + !% + !% Slight modifications are that if we include two unconnected vertices in the subgraph + !% then the corresponding vertices in the isomorphism MUST also be disconnected. + !% i.e. if we don\'t include a bond between two atoms it is because it really isn\'t there. + !% + !% Pattern matching problems are combinatorial in time required, so the routine itself + !% has seven different escape routes; the first six try to quickly fail and prevent the + !% main part of the algorithm from executing at all. + !% + !% 'at' is the atoms structure with connectivity data precalculated to at least first nearest neighbours + !% + !% 'motif' is an integer matrix describing the connectivity of the region you wish to match. + !% it has dimension (number of atoms, max number of neighbours + 1) + !% motif(i,1) is the atomic number of an atom + !% motif(i,2), motif(i,3) etc. are the indices of atoms to which this atom connects in this motif + !% or zero if there are no more neighbours. + !% + !% E.g. to match a water molecule we could use: + !% + !%> water_motif = reshape( (/ 8, 1, 1, & + !%> 2, 1, 1, & + !%> 3, 0, 0 /), (/3,3/) ) + !% + !% or, alternatively: + !%> water_motif2 = reshape( (/ 1, 8, 1, & + !%> 2, 1, 2, & + !%> 0, 3, 0/), (/3,3/) ) + !% + !% and for an alpha carbon + !%> O + !%> | + !%> N - C - C + !%> | + !%> H + !%> + !%> c_alpha = reshape( (/ 6,6,7,8,1, & + !%> 2,1,1,2,1, & + !%> 3,4,0,0,0, & + !%> 5,0,0,0,0/), (/5,4/) ) + !% + !% The routine will identify an optimum atom in the motif which it will try to find in the + !% atoms structure before doing any further matching. The optimum atom is the one which + !% minimises the total number of bond hops required to include all atoms in the motif + !% + !% 'matches' is a table containing one line for each match found in the atoms structure + !% or for optimum atoms with indices between 'start' and 'end'. The integers in each line + !% give the indices of the atoms, in the same order as in the motif, which consitute a single + !% match. + !% + !% 'mask' allows individual atoms to be selected for searching, e.g. for preventing a water + !% molecule from being re-identified as an OH, and then later as two hydrogens. + !% + !% if find_all_possible_matches is true, all possible matches, not just non-overlapping ones, + !% are returned. Useful for situations where things are ambiguous and need to be resolved + !% with more information outside this routine + !% + !% The routine could optionally find hysteretically defined connections between neighbours, + !% if the alt_connect's cutoff were the same as at%cutoff(_break) + !% + subroutine find_motif(at,motif,matches,start,end,mask,find_all_possible_matches,nneighb_only,alt_connect) !,hysteretic_neighbours) + + type(atoms), intent(in), target :: at !% The atoms structure to search + integer, intent(in) :: motif(:,:) !% The motif to search for + type(table), intent(out) :: matches !% All matches + integer, optional, intent(in) :: start, end !% Start and End atomic indices for search + logical, optional, intent(in) :: mask(:) !% If present only masked atoms are searched + logical, optional, intent(in) :: find_all_possible_matches !% if true, don't exclude matches that overlap + logical, intent(in), optional :: nneighb_only + type(Connection), intent(in), optional, target :: alt_connect +! logical, optional, intent(in) :: hysteretic_neighbours + + character(*), parameter :: me = 'find_motif: ' + + integer, allocatable :: A(:,:),B(:,:),C(:,:),depth(:), neighbour_Z(:), Z(:), M0(:,:), M(:,:), & + match_indices(:), depth_real(:) + integer :: i,j,k,p,q,N,max_depth,max_depth_real, my_start,my_end, opt_atom, ji + logical :: match + type(table) :: neighbours, core_raw, core, num_species_at, num_species_motif + logical, allocatable :: assigned_to_motif(:) + logical :: do_append + logical :: do_find_all_possible_matches + logical :: my_nneighb_only + + integer :: discards(7) +! logical :: use_hysteretic_neighbours +! real(dp) :: cutoff + + + call print("find_motif", verbosity=PRINT_ANALYSIS) + call print(motif, verbosity=PRINT_ANALYSIS) + if (present(mask)) then + call print("mask", verbosity=PRINT_ANALYSIS) + call print(mask, verbosity=PRINT_ANALYSIS) + endif + + my_nneighb_only = optional_default(.true., nneighb_only) + + discards = 0 + do_find_all_possible_matches = optional_default(.false., find_all_possible_matches) + + !XXXXXXXXXXXXXXXX + !X INITIALISATION + !XXXXXXXXXXXXXXXX + + ! Check atomic numbers + if (any(motif(:,1)<1)) call system_abort(me//'Bad atomic numbers ('//motif(:,1)//')') + + ! Check for atomic connectivity + if (present(alt_connect)) then + if (.not.alt_connect%initialised) call system_abort(me//'got alt_connect uninitialised') + else + if (.not.at%connect%initialised) call system_abort(me//'got at%connect uninitialised') + endif +! use_hysteretic_neighbours = optional_default(.false.,hysteretic_neighbours) +! + if (size(motif,1).eq.0) call system_abort(me//'zero motif size') + + ! Build adjacency matrix from motif + N = size(motif,1) + allocate(A(N,N),C(N,N),depth(N)) + A = 0 + do i = 1, N + do p = 2, size(motif,2) + j = motif(i,p) + if (j>N) call system_abort(me//'Undefined atom referenced in motif ('//j//')') + if (j>0) A(i,j) = 1 + end do + end do + + ! Make array of atomic numbers in motif + allocate(Z(N)) + Z = motif(:,1) + + ! Check symmetry + if (.not.is_symmetric(A)) then + call print_title('Non-symmetic adjacency matrix') + call print(A) + call print('bad rows/columns:') + do i = 1, size(A,1) + if (.not.all(A(:,i)==A(i,:))) call print(i) + end do + call system_abort(me//'Adjacency matrix for given motif is not symmetric!') + end if + + ! Allocate matches table: the ints are atomic indices which match, in order, the connectivity info + call allocate(matches,N,0,0,0,1) + + ! Find the best atom (opt_atom) to identify and grow clusters around in the real structure + call find_optimum_central_atom(A,opt_atom,depth) + max_depth = maxval(depth) + + !XXXXXXXXXXXXXXX + !X THE ALGORITHM + !XXXXXXXXXXXXXXX + + allocate(assigned_to_motif(at%N)) + assigned_to_motif = .false. + + !Loop over all atoms looking for candidates for the optimum atom 'opt_atom' + call allocate(core_raw,4,0,0,0,1) + allocate(neighbour_Z(count(A(opt_atom,:)==1))) + neighbour_Z = pack(Z,(A(opt_atom,:)==1)) + + call print("opt_atom " // opt_atom // " Z " // Z(opt_atom), verbosity=PRINT_ANALYSIS) + + my_start = 1 + if (present(start)) then + if (start < 1 .or. start > at%N) call system_abort(me//'Starting atom is out of range ('//start//')') + my_start = start + end if + my_end = at%N + if (present(end)) then + if (end < 1 .or. end > at%N) call system_abort(me//'Ending atom is out of range ('//start//')') + my_end = end + end if + + ! if end < start then no matches will be returned, a la do loops + + do i = my_start, my_end + + call print("check atom " // i // " Z " // at%Z(i), verbosity=PRINT_ANALYSIS) + + if (present(mask)) then + if (.not.mask(i)) then + call print(" i not in mask, skipping", verbosity=PRINT_ANALYSIS) + cycle + endif + end if + + !XXXXXXXXXXXXXXXXXXXX + !X ESCAPE ROUTE 1 + !XXXXXXXXXXXXXXXXXXXX + + ! Discard atoms which don't match the atomic number of the optimum atom + + if (at%Z(i) /= Z(opt_atom)) then + call print(" i has wrong Z to match opt_atom, skipping", verbosity=PRINT_ANALYSIS) + discards(1) = discards(1) + 1 + cycle + end if + + !--------------------- + + !XXXXXXXXXXXXXXXXXXXX + !X ESCAPE ROUTE 2 + !XXXXXXXXXXXXXXXXXXXX + + ! Check if the real atom's neighbours can be matched with those in the motif + + if (.not.atoms_compatible(at,i,A,Z,opt_atom,nneighb_only=nneighb_only,alt_connect=alt_connect)) then + discards(2) = discards(2) + 1 + call print(" i has incompatible neighbour list, skipping", verbosity=PRINT_ANALYSIS) + cycle + end if + + !--------------------- + + ! Grow a cluster around the real atom i which is max_depth hops deep + call wipe(core_raw) + call append(core_raw,(/i,0,0,0/)) + call bfs_grow(at,core_raw,max_depth,nneighb_only = nneighb_only, min_images_only = .true.,alt_connect=alt_connect) + call finalise(core) + if (present(mask)) then + call select(core, core_raw, mask(int_part(core_raw,1))) + else + core = core_raw + end if + + + !XXXXXXXXXXXXXXXXXXXX + !X ESCAPE ROUTE 3 + !XXXXXXXXXXXXXXXXXXXX + + ! If the number of atoms in the cluster is less than those in the motif we can't have a match + if (core%N < N) then + call print(" i's cluster is too small, skipping", verbosity=PRINT_ANALYSIS) + discards(3) = discards(3) + 1 + cycle + end if + + !--------------------- + + ! Count the number of each atomic species in the motif and in the cluster + call allocate(num_species_motif,2,0,0,0,6) + call allocate(num_species_at,2,0,0,0,6) + do k = 1, N + p = find_in_array(int_part(num_species_motif,1),Z(k)) + if (p == 0) then + call append(num_species_motif,(/Z(k),1/)) + else + num_species_motif%int(2,p) = num_species_motif%int(2,p) + 1 + end if + end do + do k = 1, core%N + p = find_in_array(int_part(num_species_at,1),at%Z(core%int(1,k))) + if (p == 0) then + call append(num_species_at,(/at%Z(core%int(1,k)),1/)) + else + num_species_at%int(2,p) = num_species_at%int(2,p) + 1 + end if + end do + + !XXXXXXXXXXXXXXXXXXXX + !X ESCAPE ROUTE 4 + !XXXXXXXXXXXXXXXXXXXX + + !Compare the tables: if there are more atoms of one type in motif than core then a fit is impossible + match = .true. + do k = 1, num_species_motif%N + p = find_in_array(int_part(num_species_at,1),num_species_motif%int(1,k)) + if (p == 0) then + match = .false. + exit + else if (num_species_at%int(2,p) < num_species_motif%int(2,k)) then + match = .false. + exit + end if + end do + call finalise(num_species_motif) + call finalise(num_species_at) + if (.not.match) then + call print(" i's cluster has mismatching atom numbers, skipping", verbosity=PRINT_ANALYSIS) + discards(4) = discards(4) + 1 + cycle + end if + + !--------------------- + + ! Create adjacency matrix + allocate(B(core%N,core%N)) + B = 0 + do p = 1, core%N + k = core%int(1,p) + do ji=1, n_neighbours(at, k, alt_connect=alt_connect) + j = neighbour(at, k, ji, alt_connect=alt_connect) + if (my_nneighb_only) then + if (.not. is_nearest_neighbour(at, k, ji, alt_connect=alt_connect)) cycle + endif + q = find_in_array(core%int(1,1:core%N),j) + if (q > 0) then + B(p,q) = 1 + B(q,p) = 1 + endif + end do ! ji + end do !p + + call print("core", verbosity=PRINT_ANALYSIS) + call print(core, verbosity=PRINT_ANALYSIS) + call print("adjacency mat", verbosity=PRINT_ANALYSIS) + call print(B, verbosity=PRINT_ANALYSIS) + + ! Find depth of connectivity for real atoms + allocate(depth_real(core%N)) + call find_connectivity_depth(B,1,depth_real) + max_depth_real = maxval(depth_real) + + !XXXXXXXXXXXXXXXXXX + !X ESCAPE ROUTE 5 + !XXXXXXXXXXXXXXXXXX + + ! If there are atoms which aren't deep enough in the real structure then a match is impossible + if (max_depth > max_depth_real) then + call print(" i's cluster isn't actually keep enough, skipping", verbosity=PRINT_ANALYSIS) + deallocate(B,depth_real) + discards(5) = discards(5) + 1 + cycle + end if + + !--------------------- + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X THE MAIN PART OF THE ALGORITHM + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! Create possibility matrix M0, with the optimum atom already matched + + ! ***** THINGS CAN BE SPED UP CONSIDERABLY BY LIMITING THE NUMBER OF 1'S IN M0 ***** + + allocate(M0(N,core%N)) + M0 = 0 + M0(opt_atom,1) = 1 + do q = 2, core%N + do p = 1, N + if (p==opt_atom) cycle + if (depth_real(q) == depth(p)) then + if (atoms_compatible(at,core%int(1,q),A,Z,p,nneighb_only=nneighb_only,alt_connect=alt_connect)) M0(p,q) = 1 + end if + end do + end do + + deallocate(depth_real) + + !XXXXXXXXXXXXXXXXXX + !X ESCAPE ROUTE 6 + !XXXXXXXXXXXXXXXXXX + + ! Check to see if any atoms have no possibilities + if (any(sum(M0,dim=2)==0)) then + call print(" i has some neighbor that doesn't match, skipping", verbosity=PRINT_ANALYSIS) + deallocate(M0,B) + discards(6) = discards(6) + 1 + cycle + end if + + !--------------------- + + ! Loop over all permuations + allocate(M(N,core%N)) + call first_trial_matrix(M0,M) + match = .false. + do + + call print(" check permutation loop start", verbosity=PRINT_ANALYSIS) + ! For each trial matrix create the permuted adjacency matrix + C = matmul(M,transpose(matmul(M,B))) ! ***** THIS LINE IS ANOTHER CANDIDATE FOR OPTIMISATION ***** + ! Use sparse matrices maybe? + + if (all(C==A)) then ! match + !decode trial matrix into atomic indices + allocate(match_indices(N)) + do j = 1, N + do k = 1, core%N + if (M(j,k)==1) then + match_indices(j) = core%int(1,k) + exit + end if + end do + end do + + do_append = .true. + ! if mask is present, make sure all atoms are in mask, otherwise skip + if (present(mask)) then + if (.not. all(mask(match_indices))) do_append = .false. + end if + if (do_find_all_possible_matches) then + ! if we're finding all possible matches, skip only if _all_ atoms are already in a motif + if(all(assigned_to_motif(match_indices))) do_append = .false. + else + ! if we're not, skip if _any_ atom is already in a motif + if (any(assigned_to_motif(match_indices))) do_append = .false. + endif + + if (do_append) then + call append(matches,match_indices) + assigned_to_motif(match_indices) = .true. + call print(" found match, indices " // match_indices, verbosity=PRINT_ANALYSIS) + endif + deallocate(match_indices) + + if (.not. do_find_all_possible_matches) then + call print(" not looking for _all_ matches, finished", verbosity=PRINT_ANALYSIS) + exit + endif + end if ! match + + call next_trial_matrix(M0,M) + + !XXXXXXXXXXXXXXXXXX + !X ESCAPE ROUTE 7 + !XXXXXXXXXXXXXXXXXX + + ! If next_trial_matrix deletes the only atom we know to be fitted then all + ! permutations have been exhausted + if (M(opt_atom,1)==0) then + call print(" i has no more premutations, leaving loop", verbosity=PRINT_ANALYSIS) + discards(7) = discards(7) + 1 + exit + end if + !--------------------- + + end do + + + deallocate(B,M0,M) + + end do + + deallocate(A,C,depth,Z,neighbour_Z) + call finalise(core) + call finalise(neighbours) + + !When debugging/improving this algorithm uncomment this line + !as it gives an indication of how successful the predetection + !of bad matches is + + !call print('find_motif: Discards by level: '//discards) + + end subroutine find_motif + + !% OMIT + ! Used by find_motif to generate the first permutation matrix + subroutine first_trial_matrix(M0,M) + + integer, dimension(:,:), intent(in) :: M0 + integer, dimension(:,:), intent(inout) :: M + integer, dimension(size(M0,2)) :: taken + integer :: A,B,i,j + + A = size(M0,1) + B = size(M0,2) + M = 0 + taken = 0 + + do i = 1, A + + do j = 1, B + + if (M0(i,j) == 1 .and. taken(j) == 0) then + M(i,j) = 1 + taken(j) = 1 + exit + end if + + end do + + end do + + end subroutine first_trial_matrix + + !% OMIT + ! Used by find_motif to generate the next permutation matrix given the current one + subroutine next_trial_matrix(M0,M) + + integer, dimension(:,:), intent(in) :: M0 + integer, dimension(:,:), intent(inout) :: M + integer, dimension(size(M0,2)) :: taken + + integer :: A,B,i,j + logical :: found, placed, l1, l2 + + A = size(M,1) + B = size(M,2) + + i = A + + taken = sum(M,dim=1) + do while (i<=A .and. i>0) + + !try to move the 1 in the ith row along, or place it if it isn't there + + !find the 1 + found = .false. + j = 1 + do while(j<=B) + if (M(i,j)==1) then + found = .true. + exit + else + j = j + 1 + end if + end do + if (found) then + M(i,j) = 0 + j = j + 1 + else + j = 1 + end if + + !place it + placed = .false. + taken = sum(M,dim=1) + do while (j<=B) + l1 = M0(i,j) == 1 + l2 = taken(j) == 0 + if (l1 .and. l2) then + M(i,j) = 1 + taken(j) = 1 + placed = .true. + exit + end if + j = j + 1 + end do + if (.not.placed) then + i = i - 1 + else + i = i + 1 + end if + + end do + + end subroutine next_trial_matrix + + !% OMIT + ! Used by find_motif + subroutine find_optimum_central_atom(A,i,depth) + + integer, dimension(:,:), intent(in) :: A ! The adjacency matrix + integer, intent(out) :: i ! The optimum central atom + integer, dimension(size(A,1)), intent(out) :: depth ! The connectivity depth using this atom + + integer :: n, max_depth, new_max_depth + integer, dimension(size(A,1)) :: new_depth + + ! Starting with each atom in turn, calculate the depth of the connectivity + ! The best is the one with the smallest maximum depth + + max_depth = huge(1) + + do n = 1, size(A,1) + + call find_connectivity_depth(A,n,new_depth) + new_max_depth = maxval(new_depth) + + if (new_max_depth < max_depth) then + max_depth = new_max_depth + depth = new_depth + i = n + end if + + end do + + end subroutine find_optimum_central_atom + + !% OMIT + ! Used by find_motif + subroutine find_connectivity_depth(A,i,depth) + + integer, dimension(:,:), intent(in) :: A ! The adjacency matrix + integer, intent(in) :: i ! The central atom + integer, dimension(size(A,1)), intent(out) :: depth ! The connectivity depth using this atom + + integer :: p, q, j + logical :: atom_marked + + depth = -1 + depth(i) = 0 + atom_marked = .true. + p = -1 + + do while(atom_marked) + + atom_marked = .false. + p = p + 1 + + do q = 1, size(A,1) + + if (depth(q) == p) then !...mark its neighbours with p+1 if unmarked + + do j = 1, size(A,1) + + if (A(q,j) == 1 .and. depth(j) == -1) then + depth(j) = p + 1 + atom_marked = .true. + end if + + end do + + end if + + end do + + end do + + if (any(depth == -1)) call system_abort('find_conectivity_depth: Adjacency matrix contains dijoint regions') + + end subroutine find_connectivity_depth + + !% OMIT + ! Used by find_motif + ! Added alt_connect. + function atoms_compatible(at,i,A,Z,j,nneighb_only,alt_connect) + + type(atoms), intent(in), target :: at !the atoms structure + integer, intent(in) :: i !the atom in the atoms structure we are testing + integer, dimension(:,:), intent(in) :: A !the adjacency matrix of the motif + integer, dimension(:), intent(in) :: Z !the atomic number of the motif + integer, intent(in) :: j !the atom in the motif we are testing + logical, intent(in), optional :: nneighb_only + type(Connection), intent(in), optional, target :: alt_connect + logical :: atoms_compatible + + type(table) :: core, neighbours + logical, allocatable, dimension(:) :: neighbour_used + integer, allocatable, dimension(:) :: neighbour_Z + integer :: p,q + logical :: match, found + + ! First check the atomic numbers of the two atoms to test + if (at%Z(i) /= Z(j)) then + atoms_compatible = .false. + return + end if + + ! find nearest neighbours of real atom + call allocate(core,4,0,0,0,1) + call append(core,(/i,0,0,0/)) + call bfs_step(at,core,neighbours,nneighb_only=nneighb_only,min_images_only=.true.,alt_connect=alt_connect) + + allocate(neighbour_used(neighbours%N)) + neighbour_used = .false. + + ! find the atomic numbers of the neighbours of atom j in the motif + allocate(neighbour_Z(count(A(j,:)==1))) + neighbour_Z = pack(Z,(A(j,:)==1)) + + ! see if a tentative match between the neighbours of atom i in at and atom j in + ! the adjacency matrix is possible, just using atomic numbers + + match = .true. + + do p = 1, size(neighbour_Z) + + found = .false. + + do q = 1, neighbours%N + + if (neighbour_used(q)) cycle + + if (at%Z(neighbours%int(1,q)) == neighbour_Z(p)) then + neighbour_used(q) = .true. + found = .true. + exit + end if + end do + + if (.not.found) then + match = .false. + exit + end if + + end do + + atoms_compatible = match + + deallocate(neighbour_used,neighbour_Z) + call finalise(core) + call finalise(neighbours) + + end function atoms_compatible + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% find supercells of two lattices that are compatible (i.e. + !% equal or parallel vectors to some tolerance) + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine find_compatible_supercells(l1, l2, match_tol, n1, n2, fix_l2, max_m1, max_m2, error) + real(dp), intent(in) :: l1(3,3), l2(3,3) !% lattices of 1st and 2nd structures + real(dp), intent(in) :: match_tol !% tolerange for good enough match. + integer, intent(out) :: n1(3,3), n2(3,3) !% output supercells of 1st and 2nd structures that match well enough (new lattices = lattice . n[12] ) + logical, intent(in), optional :: fix_l2 !% if true, don't allow supercells of l2 + integer, intent(in), optional :: max_m1, max_m2 !% max range of supercells to check (bigger is slower) + integer, intent(out), optional :: error !% if present, error status return + + logical :: my_fix_l2 + integer :: my_max_m1, my_max_m2 + + real(dp) :: l1_inv(3,3), l2_inv(3,3) + type(Atoms) :: a1, a1_sc, a2, a2_sc, matches + real(dp) :: new_lattice(3,3), new_lattice_1(3,3), new_lattice_2(3,3), r + logical :: better, match + real(dp) :: best_normsq, best_vol, t_normsq, t_vol + integer i, i1, i2, i3, ji, j + + INIT_ERROR(error) + + my_fix_l2 = optional_default(.false., fix_l2) + my_max_m1 = optional_default(10, max_m1) + my_max_m2 = optional_default(10, max_m2) + + call initialise(a1, N=1, lattice=l1, error=error) + PASS_ERROR(error) + a1%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) + a1%Z(1) = 1 + call supercell(a1_sc, a1, 2*my_max_m1+1, 2*my_max_m1+1, 2*my_max_m1+1, error=error) + PASS_ERROR(error) + call remove_atoms(a1_sc, 1, error=error) + PASS_ERROR(error) + a1_sc%pos(1,:) = a1_sc%pos(1,:) - a1%lattice(1,1)*my_max_m1 - a1%lattice(1,2)*my_max_m1 - a1%lattice(1,3)*my_max_m1 + a1_sc%pos(2,:) = a1_sc%pos(2,:) - a1%lattice(2,1)*my_max_m1 - a1%lattice(2,2)*my_max_m1 - a1%lattice(2,3)*my_max_m1 + a1_sc%pos(3,:) = a1_sc%pos(3,:) - a1%lattice(3,1)*my_max_m1 - a1%lattice(3,2)*my_max_m1 - a1%lattice(3,3)*my_max_m1 + call finalise(a1) + + if (my_fix_l2) then + call initialise(a2_sc, N=3, lattice=l2, error=error) + PASS_ERROR(error) + a2_sc%pos(:,1) = l2(:,1) + a2_sc%pos(:,2) = l2(:,2) + a2_sc%pos(:,3) = l2(:,3) + a2_sc%Z(1:3) = 2 + a2_sc%species(1,1:3) = "H" + a2_sc%species(2,1:3) = "e" + else + call initialise(a2, N=1, lattice=l2) + a2%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) + a2%Z(1) = 2 + a2_sc%species(1,1) = "H" + a2_sc%species(2,1) = "e" + call supercell(a2_sc, a2, 2*my_max_m2+1, 2*my_max_m2+1, 2*my_max_m2+1, error=error) + PASS_ERROR(error) + call remove_atoms(a2_sc, 1, error=error) + PASS_ERROR(error) + a2_sc%pos(1,:) = a2_sc%pos(1,:) - a2%lattice(1,1)*my_max_m2 - a2%lattice(1,2)*my_max_m2 - a2%lattice(1,3)*my_max_m2 + a2_sc%pos(2,:) = a2_sc%pos(2,:) - a2%lattice(2,1)*my_max_m2 - a2%lattice(2,2)*my_max_m2 - a2%lattice(2,3)*my_max_m2 + a2_sc%pos(3,:) = a2_sc%pos(3,:) - a2%lattice(3,1)*my_max_m2 - a2%lattice(3,2)*my_max_m2 - a2%lattice(3,3)*my_max_m2 + call finalise(a2) + endif + + call add_atoms(a2_sc, a1_sc%pos(1:3,1:a1_sc%N), a1_sc%Z(1:a1_sc%N), error=error) + PASS_ERROR(error) + call set_cutoff(a2_sc, max(norm(a2_sc%lattice(:,1))/5.0_dp, norm(a2_sc%lattice(:,2))/5.0_dp, norm(a2_sc%lattice(:,3))/5.0_dp ) ) + new_lattice = 0.0_dp + new_lattice(1,1) = max(norm(a2_sc%lattice(:,1)), norm(a1_sc%lattice(:,1)))*2.0_dp + new_lattice(2,2) = max(norm(a2_sc%lattice(:,2)), norm(a1_sc%lattice(:,2)))*2.0_dp + new_lattice(3,3) = max(norm(a2_sc%lattice(:,3)), norm(a1_sc%lattice(:,3)))*2.0_dp + call set_lattice(a2_sc, new_lattice, .false.) + + call initialise(matches, N=1, lattice=new_lattice) + call remove_atoms(matches, 1) + call calc_connect(a2_sc) + do i=1, a2_sc%N + if (a2_sc%Z(i) == 2) then + do ji=1, n_neighbours(a2_sc, i) + j = neighbour(a2_sc, i, ji, distance=r) + if (a2_sc%Z(j) /= 1) cycle + if (r/max(norm(a2_sc%pos(:,i)),norm(a2_sc%pos(:,j))) <= match_tol) then + call add_atoms(matches, a2_sc%pos(:,j), 1) + call add_atoms(matches, a2_sc%pos(:,i), 2) + endif + end do + endif + end do + + if (matches%N < 6) then + RAISE_ERROR("not enough points matched to be possible to get 3-D cell", error) + endif + + call matrix3x3_inverse(l1, l1_inv) + call matrix3x3_inverse(l2, l2_inv) + + match = .false. + best_normsq = 1.0e38_dp + best_vol = 1.0e38_dp + do i1=1, matches%N, 2 + do i2=i1+2, matches%N, 2 + do i3=i2+2, matches%N, 2 + if (i2 == i1) cycle + if (i3 == i1) cycle + if (i2 == i3) cycle + new_lattice_1(:,1) = matches%pos(:, i1) + new_lattice_1(:,2) = matches%pos(:, i2) + new_lattice_1(:,3) = matches%pos(:, i3) + if (cell_volume(new_lattice_1) .feq. 0.0_dp) cycle + new_lattice_2(:,1) = matches%pos(:, i1+1) + new_lattice_2(:,2) = matches%pos(:, i2+1) + new_lattice_2(:,3) = matches%pos(:, i3+1) + if (cell_volume(new_lattice_2) .feq. 0.0_dp) cycle + t_normsq = normsq(new_lattice_1(:,1)-new_lattice_2(:,1)) + & + normsq(new_lattice_1(:,2)-new_lattice_2(:,2)) + normsq(new_lattice_1(:,3)-new_lattice_2(:,3)) + t_vol = cell_volume(new_lattice_1) + cell_volume(new_lattice_2) + better = .false. + if (t_normsq < best_normsq) then + better = .true. + else if ((t_normsq .feq. best_normsq) .and. (t_vol < best_vol)) then + better = .true. + endif + if (better) then + best_normsq = t_normsq + best_vol = t_vol + n1(:,:) = floor(matmul(l1_inv,new_lattice_1)+0.5_dp) + n2(:,:) = floor(matmul(l2_inv,new_lattice_2)+0.5_dp) + match = .true. + endif + end do + end do + end do + + if (.not. match) then + RAISE_ERROR("no good enough match", error) + endif + + end subroutine find_compatible_supercells + + ! + !% construct an arbitrary supercell from a primitive structure and a combination of primitive vectors that form supercell + ! + subroutine arbitrary_supercell(a_out, a_in, i1, error) + type(Atoms), intent(out)::a_out !% Output (big) cell + type(Atoms), intent(in)::a_in !% Input (small) cell + integer, intent(in):: i1(3,3) !% combination of primitive lattice vectors to create supercell (a_out%lattice = a_in%lattice . i1). column i specifies output pbc vector i. + integer, intent(out), optional :: error !% if present, returned error status + + integer :: dup_n1, dup_n2, dup_n3 + integer :: max_n1, max_n2, max_n3 + integer :: min_n1, min_n2, min_n3 + type(Atoms) :: a_dup + real(dp) :: new_lat(3,3), t_p(3) + integer :: f1, f2, f3 + logical, allocatable :: is_good(:) + + integer :: i, ji, j + + INIT_ERROR(error) + + ! calculate how big a simple supercell we need to encompass new arbitrary supercell + new_lat = matmul(a_in%lattice, real(i1,dp)) + dup_n1 = 0; dup_n2 = 0; dup_n3 = 0 + max_n1 = -1000000 + max_n2 = -1000000 + max_n3 = -1000000 + min_n1 = 1000000 + min_n2 = 1000000 + min_n3 = 1000000 + do f1=0,1 + do f2=0,1 + do f3=0,1 + t_p = matmul(a_in%g,f1*new_lat(:,1)+f2*new_lat(:,2)+f3*new_lat(:,3)) + max_n1 = max(max_n1, int(t_p(1)+1.0)) + max_n2 = max(max_n2, int(t_p(2)+1.0)) + max_n3 = max(max_n3, int(t_p(3)+1.0)) + min_n1 = min(min_n1, int(t_p(1)+1.0)) + min_n2 = min(min_n2, int(t_p(2)+1.0)) + min_n3 = min(min_n3, int(t_p(3)+1.0)) + end do + end do + end do + dup_n1 = max_n1 - min_n1 + 2 + dup_n2 = max_n2 - min_n2 + 2 + dup_n3 = max_n3 - min_n3 + 2 + call supercell(a_dup, a_in, dup_n1, dup_n2, dup_n3, error=error) + PASS_ERROR(error) + + ! set the new lattice and map to [-0.5, 0.5) + call set_lattice(a_dup, matmul(a_in%lattice, real(i1,dp)), .false.) + call map_into_cell(a_dup) + + ! look for close atoms + call set_cutoff(a_dup, 2.0_dp) + call calc_connect(a_dup) + allocate(is_good(a_dup%N)) + is_good = .true. + do i=1, a_dup%N + if (is_good(i)) then + do ji=1, n_neighbours(a_dup, i) + j = neighbour(a_dup, i, ji, max_dist=0.01_dp) + if (j > i) is_good(j) = .false. + end do + endif + end do + + ! select good atoms + call select(a_out, a_dup, is_good) + + end subroutine arbitrary_supercell + + subroutine remove_too_close_atoms(at, distance, error) + type(Atoms), intent(inout) :: at + real(dp), intent(in) :: distance + integer, intent(out), optional :: error + + logical, pointer :: removable_p(:) + integer, allocatable :: remove_list(:) + integer :: n_remove + integer :: i, ji, j + real(dp) :: r + + INIT_ERROR(error) + + call assign_property_pointer(at, "removable", removable_p, error) + PASS_ERROR(error) + + allocate(remove_list(at%N)) + + n_remove = 1 + do while (n_remove > 0) + call calc_connect(at) + n_remove = 0 + remove_list = 0 + do i=1, at%N + if (any(remove_list == i)) cycle + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, distance=r) + if (.not. removable_p(j)) cycle + if (r < distance) then + if (n_remove > 0) then + if (any(remove_list == j)) cycle + endif + n_remove = n_remove + 1 + remove_list(n_remove) = j + endif + end do + end do + + if (n_remove > 0) then + call remove_atoms(at, remove_list(1:n_remove), error) + endif + PASS_ERROR(error) + end do + + deallocate(remove_list) + + end subroutine remove_too_close_atoms + + function min_neighbour_dist(at) + type(Atoms), intent(in) :: at + real(dp) :: min_neighbour_dist + + real(dp) :: r + integer :: i, ji, j + + min_neighbour_dist = 1.0e38_dp + do i=1, at%N + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, distance=r) + if (r < min_neighbour_dist) min_neighbour_dist = r + end do + end do + + end function min_neighbour_dist + + function torsion_angle(at, i1, i2, i3, i4, error) + type(Atoms), intent(in) :: at + integer, intent(in) :: i1, i2, i3, i4 + integer, optional, intent(out) :: error + real(dp) :: torsion_angle + + real(dp) :: v21(3), v23(3), v34(3) + + INIT_ERROR(error) + + if (any( (/ i1, i2, i3, i3 /) < 1) .or. & + any( (/ i1, i2, i3, i3 /) > at%N)) then + RAISE_ERROR("torsion angle atom index out of bounds", error) + endif + v21 = diff_min_image(at, i2, i1) + v23 = diff_min_image(at, i2, i3) + v34 = diff_min_image(at, i3, i4) + + v21 = v21 - v23*(v21.dot.v23)/(norm(v23)*norm(v23)) + v34 = v34 - v23*(v34.dot.v23)/(norm(v23)*norm(v23)) + + torsion_angle = acos((v21.dot.v34)/(norm(v21)*norm(v34))) + end function torsion_angle + + ! find a smaller unit cell, Int. Tables for Crystallography A, Sec 9.1.8 + function delaunay_reduce(lat) result(reduced_lat) + real(dp), intent(in) :: lat(3,3) + real(dp) :: reduced_lat(3,3) + + real(dp) :: m(3,4), inner_products(4,4), m_new(3,4), inner_products_new(4,4), m_aug(3,7), norms_aug(7) + real(dp) :: norm_sum, norm_sum_new + integer :: i, j, k, min_norm(1) + logical :: any_accepted + + ! create initial basis vectors from lattice and -(a1+a2+a3) + m(1:3,1:3) = lat(1:3,1:3) + m(1:3,4) = - (lat(:,1) + lat(:,2) + lat(:,3)) + inner_products = matmul(transpose(m),m) + norm_sum = inner_products(1,1) + inner_products(2,2) + inner_products(3,3) + inner_products(4,4) + inner_products(1,1) = -1.0_dp + inner_products(2,2) = -1.0_dp + inner_products(3,3) = -1.0_dp + inner_products(4,4) = -1.0_dp + + ! while any i /= j inner products are positive + any_accepted = .true. + do while (any(inner_products > NUMERICAL_ZERO) .and. any_accepted) + any_accepted = .false. + do i=1, 4 + do j=1, 4 + if (inner_products(i,j) > NUMERICAL_ZERO) then + ! i.j is negative, try to flip i + do k=1, 4 + if (k == i) then + m_new(:,k) = -1.0_dp * m(:,k) + else if (k == j) then + m_new(:,k) = m(:,k) + else + m_new(:,k) = m(:,k) + m(:,i) + endif + end do + inner_products_new = matmul(transpose(m_new),m_new) + norm_sum_new = inner_products_new(1,1) + inner_products_new(2,2) + inner_products_new(3,3) + inner_products_new(4,4) + inner_products_new(1,1) = -1.0_dp; inner_products_new(2,2) = -1.0_dp; inner_products_new(3,3) = -1.0_dp; inner_products_new(4,4) = -1.0_dp + if (norm_sum_new < norm_sum) then ! improvement, accept + m = m_new + inner_products = inner_products_new + norm_sum = norm_sum_new + any_accepted = .true. + endif + endif ! inner_products(i,j) > NUMERICAL_ZERO + end do + end do + end do + + if (.not. any_accepted) then + call system_abort("Did a whole scan and failed to accept a trial lattice change") + endif + + ! basis is contained by 4 vectors and a1+a2, a2+a3, a3+1 + m_aug(1:3,1:4) = m(1:3,1:4) + m_aug(1:3,5) = m(1:3,1) + m(1:3,2) + m_aug(1:3,6) = m(1:3,2) + m(1:3,3) + m_aug(1:3,7) = m(1:3,3) + m(1:3,1) + + do i=1, 7 + norms_aug(i) = sum(m_aug(1:3,i)**2) + end do + ! find first 2 PBC vectors + do i=1,2 + min_norm = minloc(norms_aug) + reduced_lat(1:3,i) = m_aug(1:3,min_norm(1)) + norms_aug(min_norm(1)) = HUGE(1.0_dp) + end do + ! find third that's independent (cell_volume > 0) + reduced_lat(1:3,3) = 0.0_dp + do while (cell_volume(reduced_lat) .feq. 0.0_dp) + min_norm = minloc(norms_aug) + reduced_lat(1:3,3) = m_aug(1:3,min_norm(1)) + norms_aug(min_norm(1)) = HUGE(1.0_dp) + end do + + end function delaunay_reduce + + function map_nearest_atoms(at1, at2, types) + type(Atoms), intent(inout) :: at1, at2 + integer, intent(in) :: types(:) + real(dp) :: map_nearest_atoms + + integer, pointer :: mapping1(:), mapping2(:) + real(dp), pointer :: mapping_diff1(:,:), mapping_diff2(:,:) + integer :: i, j, min_j + real(dp) :: dist, diff(3), min_dist, min_diff(3) + + call add_property(at1, "mapping", 0, ptr=mapping1, overwrite=.true.) + call add_property(at1, "mapping_diff", 0.0_dp, n_cols=3, ptr2=mapping_diff1, overwrite=.true.) + call add_property(at2, "mapping", 0, ptr=mapping2, overwrite=.true.) + call add_property(at2, "mapping_diff", 0.0_dp, n_cols=3, ptr2=mapping_diff2, overwrite=.true.) + + map_nearest_atoms = 0.0_dp + + do i=1, at1%N + if (mapping1(i) > 0) cycle + if (find_in_array(types, at1%Z(i)) <= 0) cycle + + min_dist = huge(1.0_dp) + do j=1, at2%N + if (mapping2(j) > 0) cycle + if (at1%Z(i) /= at2%Z(j)) cycle + if (find_in_array(types, at2%Z(j)) <= 0) cycle + + diff = diff_min_image(at1, i, at2%pos(:,j)) + dist = norm(diff) + if (dist < min_dist) then + min_dist = dist + min_diff = diff + min_j = j + end if + end do + mapping1(i) = min_j + mapping_diff1(:,i) = min_diff + mapping2(min_j) = i + mapping_diff2(:,min_j) = -min_diff + map_nearest_atoms = map_nearest_atoms + min_dist**2 + end do + end function map_nearest_atoms + + ! characterization from Demkowicz and Argon PRB _72_ 245205 (2005) + ! definition of "liquid-like" approximation of line in Fig. 6 + subroutine bond_angle_mean_dev(at) + type(Atoms), intent(inout) :: at + + real(dp), pointer :: ba_mean(:), ba_dev(:) + logical, pointer :: liquid_like(:) + real(dp) :: ba, ba_sum, ba_sum_sq + real(dp) :: i_rv(3), j_rv(3) + real(dp) :: n_angles + integer :: i, n_nn, i_nn, j_nn, ii + + if (.not. assign_pointer(at, "bond_angle_mean", ba_mean)) & + call add_property(at, "bond_angle_mean", 0.0_dp, ptr=ba_mean, overwrite=.true.) + if (.not. assign_pointer(at, "bond_angle_dev", ba_dev)) & + call add_property(at, "bond_angle_dev", 0.0_dp, ptr=ba_dev, overwrite=.true.) + if (.not. assign_pointer(at, "liquid_like", ba_dev)) & + call add_property(at, "liquid_like", .false., ptr=liquid_like, overwrite=.true.) + + do i=1, at%N + ba_sum = 0.0_dp + ba_sum_sq = 0.0_dp + n_nn = n_neighbours(at,i) + do i_nn=1, n_nn + ii = neighbour(at, i, i_nn, cosines=i_rv) + do j_nn=i_nn+1, n_nn + ii = neighbour(at, i, j_nn, cosines=j_rv) + ba = DEGREES_PER_RADIAN*acos(sum(i_rv*j_rv)) + ba_sum = ba_sum + ba + ba_sum_sq = ba_sum_sq + ba**2 + end do + end do + n_angles = n_nn*(n_nn-1)/2 + ba_mean(i) = ba_sum/n_angles + ba_dev(i) = sqrt(ba_sum_sq/n_angles-ba_mean(i)**2) + liquid_like(i) = (ba_mean(i) < 97.6_dp+(111.5_dp-97.6_dp)/35.0_dp*ba_dev(i)) + end do + + end subroutine bond_angle_mean_dev + + subroutine surface_unit_cell(i_out, surf_v, lat, third_vec_normal, tol, max_n) + integer, intent(out) :: i_out(3,3) !% combination of primitive lattice vectors to create supercell (surf_lattice = latt . i_out). column i specifies output pbc vector i. + real(dp), intent(in) :: surf_v(3) !% surface vector + real(dp), intent(in) :: lat(3,3) !% lattice + logical, intent(in), optional :: third_vec_normal + real(dp), intent(in), optional :: tol + integer, intent(in), optional :: max_n + + logical :: my_third_vec_normal + real(dp) :: my_tol + integer :: my_max_n + + integer :: i1, i2, i3, j1, j2, j3 + real(dp) :: v1(3), v2(3), v3(3), v1_cross_v2(3), v1_cross_v2_norm, surf_v_hat(3) + real(dp) :: smallest_so_far, most_normal_so_far + real(dp) :: cell(3,3), cell_vol + + my_max_n = optional_default(5, max_n) + my_tol = optional_default(1.0e-6_dp, tol) + my_third_vec_normal = optional_default(.false., third_vec_normal) + + surf_v_hat = surf_v/norm(surf_v) + + smallest_so_far = 1.0e38_dp + do i1 = -my_max_n, my_max_n + do i2 = -my_max_n, my_max_n + do i3 = -my_max_n, my_max_n + v1 = lat(:,1)*i1 + lat(:,2)*i2 + lat(:,3)*i3 + do j1 = -my_max_n, my_max_n + do j2 = -my_max_n, my_max_n + do j3 = -my_max_n, my_max_n + v2 = lat(:,1)*j1 + lat(:,2)*j2 + lat(:,3)*j3 + v1_cross_v2 = (v1 .cross. v2) + v1_cross_v2_norm = norm(v1_cross_v2) + + if (v1_cross_v2_norm <= my_tol) cycle ! v1 and v2 are parallel + if ((v1_cross_v2 .dot. surf_v_hat)/v1_cross_v2_norm < 1.0_dp-my_tol) cycle ! v1 cross v2 is not parallel to surf_v + + if (v1_cross_v2_norm < smallest_so_far-my_tol) then ! v1 cross v2 is smallest than best so far, pick it + i_out(:,1) = (/ i1, i2, i3 /) + i_out(:,2) = (/ j1, j2, j3 /) + smallest_so_far = v1_cross_v2_norm + most_normal_so_far = abs((v1 .dot. v2) / (norm(v1)*norm(v2))) + else if (v1_cross_v2_norm <= smallest_so_far + my_tol) then ! v1 cross v2 is as good as best so far, check for normalness + if (abs((v1 .dot. v2) / (norm(v1)*norm(v2))) < most_normal_so_far) then ! v1 more normal to v2, pick them + i_out(:,1) = (/ i1, i2, i3 /) + i_out(:,2) = (/ j1, j2, j3 /) + smallest_so_far = v1_cross_v2_norm + most_normal_so_far = abs((v1 .dot. v2) / (norm(v1)*norm(v2))) + endif + endif + end do + end do + end do + end do + end do + end do + + if (smallest_so_far >= 1.0e38_dp) then + call system_abort("failed to find a proper unit cell v1,v2") + endif + + v1 = matmul(lat, i_out(:,1)) + v2 = matmul(lat, i_out(:,2)) + cell(:,1) = v1 + cell(:,2) = v2 + v1_cross_v2 = (v1 .cross. v2) + v1_cross_v2_norm = norm(v1_cross_v2) + + smallest_so_far = 1.0e38_dp + do i1 = -my_max_n, my_max_n + do i2 = -my_max_n, my_max_n + do i3 = -my_max_n, my_max_n + v3 = lat(:,1)*i1 + lat(:,2)*i2 + lat(:,3)*i3 + + cell(:,3) = v3 + cell_vol = cell_volume(cell) + if (cell_vol < my_tol) cycle ! v3 is in v1-v2 plane + if (my_third_vec_normal .and. abs(v1_cross_v2 .dot. v3)/(v1_cross_v2_norm*norm(v3)) < 1.0_dp-my_tol) cycle ! need v3 normal to surface, and it's not sufficiently parallel to v1 x v2 + if (cell_vol < smallest_so_far-my_tol) then ! volume is smaller, pick it + i_out(:,3) = (/ i1, i2, i3 /) + smallest_so_far = cell_vol + most_normal_so_far = abs((v3 .dot. v1_cross_v2)/(norm(v3)*v1_cross_v2_norm)) + else if (cell_vol <= smallest_so_far+my_tol) then ! equal, check for normalness + if (abs((v3 .dot. v1_cross_v2)/(norm(v3)*v1_cross_v2_norm)) > most_normal_so_far) then ! this v3 more normal to surface (i.e. more parallel to v1_cross_v2), pick it + i_out(:,3) = (/ i1, i2, i3 /) + smallest_so_far = cell_vol + most_normal_so_far = abs((v3 .dot. v1_cross_v2)/(norm(v3)*v1_cross_v2_norm)) + endif + endif + end do + end do + end do + if (smallest_so_far >= 1.0e38_dp) then + call system_abort("failed to find a proper unit cell v3") + endif + + end subroutine surface_unit_cell + + +subroutine find_closest(at, r, closest_list) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: r(3) + integer, intent(out) :: closest_list(:) + + integer :: n_p, i_p, j + real(dp) :: prev_dist + real(dp), allocatable :: r_a(:) + real(dp), allocatable :: closest_r(:) + + n_p = size(closest_list) + + allocate(r_a(at%N)) + allocate(closest_r(n_p)) + + if (at%N < n_p) call system_abort("not enought points ("//at%N//") in atoms object (need "//n_p//")") + + do i_p=1, at%N + r_a(i_p) = distance_min_image(at, i_p, r) + end do + + prev_dist = -1e38_dp + do i_p=1, n_p + closest_r(i_p) = 1.0e38_dp + closest_list(i_p) = -1 + do j=1, at%N + if (r_a(j) < closest_r(i_p) .and. r_a(j) >= prev_dist .and. .not. any(j == closest_list(1:i_p-1))) then + closest_list(i_p) = j + closest_r(i_p) = r_a(j) + endif + end do + prev_dist = closest_r(i_p) + end do + + deallocate(r_a, closest_r) + +end subroutine find_closest + +subroutine void_analysis(at, grid_size, cutoff, grid, radii) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: grid_size, cutoff + + real(dp), intent(inout) :: grid(:,:), radii(:) + + real(dp) :: min_x, min_y, min_z, max_x, max_y, max_z, dx, dy, dz + integer :: nx, ny, nz, i, j, k, n, a(1) + logical changed + + min_x = minval(at%pos(1,:)) + min_y = minval(at%pos(2,:)) + min_z = minval(at%pos(3,:)) + + max_x = maxval(at%pos(1,:)) + max_y = maxval(at%pos(2,:)) + max_z = maxval(at%pos(3,:)) + + nx = int((max_x-min_x)/grid_size) + ny = int((max_y-min_y)/grid_size) + nz = int((max_z-min_z)/grid_size) + + dx = (max_x - min_x)/(real(nx-1, dp)) + dy = (max_y - min_y)/(real(ny-1, dp)) + dz = (max_z - min_z)/(real(nz-1, dp)) + + call print('nx='//nx//' dx='//dx) + call print('ny='//ny//' dy='//dy) + call print('nz='//nz//' dz='//dz) + + if (size(grid, 1) /= 3) then + call system_abort('void_analysis: size(grid, 2) /= 3') + end if + + if (.not. (size(grid, 2) >= nx*ny*nz)) then + call system_abort('void_analysis: size(grid, 1)='//(size(grid, 1))//' must be >= nx*ny*nz='//(nx*ny*nz)) + end if + + if (.not. (size(radii) >= nx*ny*nz)) then + call system_abort('void_analysis: size(radii)='//(size(radii, 1))//' must be >= nx*ny*nz='//(nx*ny*nz)) + end if + + !allocate(grid(nx*ny*nz,3), radii(nx*ny*nz)) + + ! populate grid + n = 1 + do i=1,nx + do j=1,ny + do k=1,nz + grid(:, n) = (/ min_x + (i-1)*dx, & + min_y + (j-1)*dy, & + min_z + (k-1)*dz /) + n = n + 1 + end do + end do + end do + + ! find distance from each grid point to nearest atom. That is void radius at that point. + do i=1, size(grid, 2) + call find_closest(at, grid(:, i), a) + radii(i) = distance_min_image(at, a(1), grid(:, i)) + end do + + ! Remove grid points with radii < cutoff + where (radii < cutoff) + radii = 0.0_dp + end where + + ! TODO agglomerative merging of overlapping grid points + + !deallocate(grid, radii) + +end subroutine void_analysis + +end module structures_module diff --git a/src/libAtoms/System.F90 b/src/libAtoms/System.F90 new file mode 100644 index 0000000000..249218f3ba --- /dev/null +++ b/src/libAtoms/System.F90 @@ -0,0 +1,3779 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X System module +!X +!X Basic system dependent functionality: +!X +!X mpi constants, default output objects, printing +!X random number generators +!X +!% The system module contains low-level routines for I/O, timing, random +!% number generation etc. The Inoutput type is used to abstract both +!% formatted and unformatted (i.e. binary) I/O. +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module system_module + use error_module + use kind_module +!$ use omp_lib +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif + implicit none +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif + +private + + logical, public :: system_always_flush = .false. + + logical, public :: system_use_fortran_random = .false. + + public :: isp, idp, iwp, dp, qp + + character, public :: quip_new_line + + integer, parameter, public :: INTEGER_SIZE = 4 + integer, parameter, public :: REAL_SIZE = dp + integer, parameter, public :: COMPLEX_SIZE = 2*dp + logical, public :: trace_memory = .false. + integer, public :: traced_memory = 0 + + logical, private :: system_do_timing = .false. + logical, private :: system_quippy_running = .false. + + type, public :: Stack + integer:: pos + integer, allocatable :: val(:) + end type Stack + + type, public :: InOutput + integer:: unit + character(256)::filename + character(256)::prefix, postfix + integer::default_real_precision + logical::formatted + logical::append + logical::active !% Does it print? + integer::action + logical::mpi_all_inoutput_flag = .false. + logical::mpi_print_id = .false. + type(Stack) :: verbosity_stack, verbosity_cascade_stack + logical::initialised = .false. + end type InOutput + + type, public :: allocatable_array_pointers + integer, allocatable :: i_a(:) + real(dp), allocatable :: r_a(:) + complex(dp), allocatable :: c_a(:) + logical, allocatable :: l_a(:) + end type allocatable_array_pointers + + integer,private :: mpi_n, mpi_myid ! Number of processes and local process ID + real(dp),private :: start_time ! Initial time + integer, parameter, private :: SYSTEM_STRING_LENGTH_SHORT = 32 !when a shorter strong is enough and we have lots of them + integer, parameter, private :: SYSTEM_STRING_LENGTH = 1024 !max line length read + integer, parameter, private :: SYSTEM_STRING_LENGTH_LONG = 102400 !max line length read + character(SYSTEM_STRING_LENGTH_LONG),public :: line ! 'line' is global and is used by other modules + character(SYSTEM_STRING_LENGTH_LONG),private :: local_line ! 'local_line' is private and System should use this instead + type(inoutput),target,save,public :: mainlog !% main output, connected to 'stdout' by default + type(inoutput),target,save,public :: errorlog !% error output, connected to 'stderr' by default + type(inoutput),target,save,public :: mpilog !% MPI output, written to by each mpi process + integer,private :: idum ! used in the random generator + !$omp threadprivate(idum) + real(dp),parameter, public :: NUMERICAL_ZERO = 1.0e-14_dp + + ! system dependent variables + integer, public::RAN_MAX + + + ! output labels + integer,parameter, public::PRINT_ALWAYS = -100000 + integer,parameter, public::PRINT_SILENT = -1 + integer,parameter, public::PRINT_NORMAL = 0 + integer,parameter, public::PRINT_VERBOSE = 1 + integer,parameter, public::PRINT_NERD = 1000 ! aleph0 + integer,parameter, public::PRINT_ANALYSIS = 10000 ! aleph1 + + integer,parameter, public::INPUT=0 + integer,parameter, public::OUTPUT=1 + integer,parameter, public::INOUT=2 + + + ! random number generator parameters + integer,parameter, public::ran_A=16807 + integer,parameter, public::ran_M=2147483647 + integer,parameter, public::ran_Q=127773 + integer,parameter, public::ran_R=2836 + + ! System_Timer stack size + integer, parameter, public :: TIMER_STACK = 500 + + ! Command argument variables + integer, public, save :: NUM_COMMAND_ARGS = 0 !% The number of arguments on the command line + integer, parameter, public :: MAX_READABLE_ARGS = 100 !% The maximum number of arguments that will be read + character(255), public, save :: EXEC_NAME !% The name of the executable + character(2550), public, dimension(MAX_READABLE_ARGS), save :: COMMAND_ARG !% The first 'MAX_READABLE_ARGS' command arguments + + +#ifdef NO_FORTRAN_ISNAN + public :: isnan +#endif + + private :: inoutput_initialise + public :: initialise + interface initialise + module procedure inoutput_initialise + end interface initialise + + private :: inoutput_finalise + public :: finalise + interface finalise + module procedure inoutput_finalise + end interface finalise + + private :: inoutput_activate + public :: activate + interface activate + module procedure inoutput_activate + end interface activate + + private :: inoutput_deactivate + public :: deactivate + interface deactivate + module procedure inoutput_deactivate + end interface deactivate + + public :: mpi_all_inoutput + interface mpi_all_inoutput + module procedure inoutput_mpi_all_inoutput + end interface mpi_all_inoutput + + public :: print_mpi_id + interface print_mpi_id + module procedure inoutput_print_mpi_id + end interface print_mpi_id + + private :: inoutput_print_string + private :: inoutput_print_integer, inoutput_print_real, inoutput_print_logical + + !% Overloaded interface for printing. With the + !% 'this' parameter omitted output goes to the default mainlog ('stdout'). The + !% 'verbosity' parameter controls whether the object is actually printed; + !% if the verbosity is greater than that currently at the top of the + !% verbosity stack then output is suppressed. Possible verbosity levels + !% range from 'ERROR' through 'NORMAL', 'VERBOSE', 'NERD' and 'ANALYSIS'. + !% Other user-defined types define the Print interface in the same way. + + public :: print + interface print + module procedure inoutput_print_string + module procedure inoutput_print_integer, inoutput_print_real, inoutput_print_logical + module procedure inoutput_print_char_array + module procedure print_inoutput + end interface print + + private :: reada_real_dim1, reada_int_dim1 + public :: read_ascii + interface read_ascii + module procedure reada_real_dim1, reada_int_dim1 + end interface read_ascii + + private :: inoutput_read_line + public :: read_line + interface read_line + module procedure inoutput_read_line + end interface read_line + + private :: inoutput_read_file + public :: read_file + interface read_file + module procedure inoutput_read_file + end interface read_file + + private :: inoutput_parse_line + public :: parse_line + interface parse_line + module procedure inoutput_parse_line + end interface parse_line + + private :: reallocate_int1d, reallocate_int2d, reallocate_int3d, reallocate_real1d, reallocate_real2d, reallocate_char1d, reallocate_log1d + public :: reallocate + interface reallocate + module procedure reallocate_int1d, reallocate_int2d, reallocate_int3d, reallocate_real1d, reallocate_real2d, reallocate_char1d, reallocate_log1d + end interface reallocate + + public :: operator(//) + + interface operator(//) + module procedure string_cat_logical, string_cat_isp, string_cat_idp, string_cat_real, string_cat_real_array + module procedure string_cat_complex, string_cat_int_array, string_cat_logical_array + module procedure string_cat_complex_array, string_cat_string_array +! module procedure logical_cat_string, logical_cat_logical, logical_cat_int, logical_cat_real + module procedure int_cat_string!, int_cat_logical, int_cat_int, int_cat_real + module procedure real_cat_string!, real_cat_logical, real_cat_int, real_cat_real + module procedure real_array_cat_string + end interface + + public :: system_command + interface system_command + !%> call system_command(command) + !% Interface to a C wrapper to the 'system(3)' system call for + !% executing external programs. Command can only be up to 1024 characters long. + !% \begin{description} + !% \item['character' --- character(*)] + !% \end{description} + subroutine system_command(command,status,error) + character(*), intent(in) :: command + integer, optional, intent(out) :: status + integer, optional, intent(out) :: error + end subroutine system_command + end interface + +#ifdef NO_FORTRAN_ISNAN + INTERFACE + elemental function fisnan(r) + real(8), intent(in)::r + integer::fisnan + end function fisnan + end INTERFACE +#endif + + public :: c_mem_info + interface c_mem_info + subroutine c_mem_info(total_mem,free_mem) + real(8), intent(out) :: total_mem, free_mem + endsubroutine c_mem_info + endinterface c_mem_info + + public :: mem_info + interface mem_info + module procedure mem_info_i, mem_info_r + end interface mem_info + + private :: Stack_Initialise + interface Initialise + module procedure Stack_Initialise + end interface Initialise + + private :: Stack_Finalise + interface Finalise + module procedure Stack_Finalise + end interface Finalise + + private :: Stack_push + public :: push + interface push + module procedure Stack_push + end interface push + + private :: Stack_pop + public :: pop + interface pop + module procedure Stack_pop + end interface pop + + private :: Stack_value + public :: value + interface value + module procedure Stack_value + end interface value + + private :: Stack_Print + interface Print + module procedure Stack_Print + end interface Print + + !% takes as arguments a default value and an optional argument, and + !% returns the optional argument value if it's present, otherwise + !% the default value + private :: optional_default_l, optional_default_i, optional_default_r + private :: optional_default_c, optional_default_ca, optional_default_z + private :: optional_default_ia, optional_default_ra + public :: optional_default + interface optional_default + module procedure optional_default_l, optional_default_i, optional_default_r + module procedure optional_default_c, optional_default_ca, optional_default_z + module procedure optional_default_ia, optional_default_ra + end interface optional_default + + private :: string_to_real_sub, string_to_integer_sub, string_to_logical_sub + private :: string_to_real1d, string_to_integer1d, string_to_logical1d + public :: string_to_numerical + interface string_to_numerical + module procedure string_to_real_sub, string_to_integer_sub, string_to_logical_sub + module procedure string_to_real1d, string_to_integer1d, string_to_logical1d + end interface string_to_numerical + + public :: int_format_length + interface int_format_length + module procedure int_format_length_isp, int_format_length_idp + end interface int_format_length + + public :: get_uniqs_refs + interface get_uniqs_refs + module procedure get_uniqs_refs_char1 + end interface + + public :: join + interface join + module procedure join_char1 + end interface + + integer, external :: pointer_to + public :: increase_stack + public :: ran_normal + public :: ran_uniform + public :: ran + public :: round + public :: current_verbosity + public :: string_to_real + public :: string_to_int + public :: string_to_logical + public :: upper_case + public :: lower_case + public :: replace + public :: split_string + public :: parse_string + public :: linebreak_string + public :: cmd_arg_count + public :: mpi_id + public :: mpi_n_procs + public :: a2s, s2a + public :: system_get_random_seed + public :: system_abort + public :: verbosity_push_decrement + public :: verbosity_pop + public :: print_message + public :: print_warning + public :: pad + public :: get_quippy_running + public :: system_timer + public :: split_string_simple + public :: num_fields_in_string_simple + public :: current_times + public :: progress + public :: progress_timer + public :: system_initialise + public :: verbosity_push + public :: abort_on_mpi_error + public :: verbosity_push_increment + public :: verbosity_of_str + public :: verbosity_to_str + public :: get_env_var + public :: system_resync_rng + public :: get_mpi_size_rank + public :: print_title + public :: parallel_print + public :: system_reseed_rng + public :: get_cmd_arg + public :: system_set_random_seeds + public :: system_finalise + public :: enable_timing + public :: verbosity_unset_minimum + public :: verbosity_set_minimum + public :: rewind + public :: th + public :: string_cat_string_array + public :: reference_true + public :: reference_false + public :: is_file_readable + public :: ALLOC_TRACE + public :: DEALLOC_TRACE + public :: make_run_directory + public :: link_run_directory + public :: wait_for_file_to_exist + public :: is_open + public :: increase_to_multiple + public :: i2si +contains + +#ifdef NO_FORTRAN_ISNAN + elemental function isnan(r) + real(dp), intent(in)::r + logical::isnan + select case(fisnan(r)) + case(0) + isnan = .false. + case(1) + isnan = .true. + case default + isnan = .true. + end select + end function isnan +#endif + + !% Open a file for reading or writing. The action optional parameter can + !% be one of 'INPUT' (default), 'OUTPUT' or 'INOUT'. + !% For unformatted output, the + !% 'isformatted' optional parameter must + !% be set to false. + subroutine inoutput_initialise(this,filename,action,isformatted,append,verbosity,verbosity_cascade,master_only,unit,error) + type(Inoutput), intent(inout)::this + character(*),intent(in),optional::filename + logical,intent(in),optional::isformatted + integer,intent(in),optional::action + logical,intent(in),optional::append + integer,intent(in),optional :: verbosity, verbosity_cascade + logical,intent(in),optional :: master_only + integer, intent(in), optional :: unit + integer,intent(out),optional :: error + + character(32)::formattedstr + character(32)::position_value + integer::stat + logical :: my_master_only + + INIT_ERROR(error) + + ! Default of optional parameters------------------------------- + + my_master_only = optional_default(.true., master_only) + call mpi_all_inoutput(this, .not. my_master_only) + + if(present(isformatted)) then + this%formatted=isformatted + else + this%formatted=.true. + endif + + if(.NOT.(this%formatted)) then + formattedstr = 'unformatted' + else + formattedstr = 'formatted' + end if + + if (present(action)) then + this%action=action + else + this%action=INPUT + end if + + if (present(append)) then + this%append=append + if(append) then + position_value="APPEND" + else + position_value="REWIND" + end if + + else + this%append=.false. + position_value="REWIND" + end if + + if(this%append .AND. .NOT.this%formatted) then + RAISE_ERROR(" Append not implemented for unformatted output",error) + end if + + if (present(filename)) then + if (present(unit)) then + RAISE_ERROR("got filename and unit simultaneously",error) + endif + if (trim(filename).eq.'stderr') then + this%filename=trim(filename) + this%unit=0 !standard error + this%action=OUTPUT + + else if (trim(filename).eq.'stdout' .or. trim(filename) .eq. '-') then + this%filename='stdout' + this%unit = 6 !standard output + this%action=OUTPUT + + else if (trim(filename).eq.'stdin') then + this%filename=trim(filename) + this%unit = 5 !standard input + this%action=INPUT + + else + this%filename=trim(filename) + this%unit=pick_up_unit() ! pick up available unit + + ! actually open the unit + if ((.not. my_master_only) .or. mpi_myid == 0) then + if (this%action == INPUT) then + open(unit=this%unit,file=trim(filename),form=formattedstr,position=position_value,status='OLD',iostat=stat) + else + open(unit=this%unit,file=trim(filename),form=formattedstr,position=position_value,iostat=stat) + endif + else + stat = 0 + endif + if(stat.NE.0)then + RAISE_ERROR('IO error opening "'//trim(filename)//'" on unit '//this%unit//', error number: '//stat,error) + end if + + end if + else ! no file name passed, so we go to passed-in unit if present, otherwise standard output + if (present(unit)) then + this%filename='from_unit_arg' + this%unit=unit + this%action=OUTPUT + else + this%filename='stdout' + this%unit = 6 !standard output + this%action = OUTPUT + endif + end if ! end default-------------------------------------------------- + + this%prefix = '' + this%postfix = '' + this%default_real_precision = 17 + + call initialise(this%verbosity_stack) + if (present(verbosity)) then + call push(this%verbosity_stack, verbosity) + else + call push(this%verbosity_stack, PRINT_NORMAL) + endif + + call initialise(this%verbosity_cascade_stack) + if (present(verbosity_cascade)) then + call push(this%verbosity_cascade_stack, verbosity_cascade) + else + call push(this%verbosity_cascade_stack, 0) + endif + + if ((.not. my_master_only) .or. mpi_myid == 0) then + call activate(this) ! now it is active + endif + + this%initialised = .true. + + end subroutine inoutput_initialise + + !% OMIT + function is_open(unit) + integer, intent(in) :: unit + logical :: is_open + inquire(unit, opened=is_open) + end function is_open + + !% OMIT + function pick_up_unit() result(unit) + integer::unit,i + do i=7,99 + if (.not. is_open(i)) then + unit=i + exit + end if + end do + end function pick_up_unit + + !% Deactivate an Inoutput object temporarily. + subroutine inoutput_deactivate(this) + type(Inoutput),intent(inout)::this + this%active=.false. + end subroutine inoutput_deactivate + + !% Activate an Inoutput object temporarily. + subroutine inoutput_activate(this) + type(Inoutput),intent(inout)::this + this%active=.true. + end subroutine inoutput_activate + + + !% Cleans everything and set members to default + subroutine inoutput_finalise(this) + type(Inoutput), intent(inout)::this + if (this%unit .ge. 7) close(this%unit) + call finalise(this%verbosity_stack) + call finalise(this%verbosity_cascade_stack) + call deactivate(this) + this%initialised = .false. + end subroutine inoutput_finalise + + !% Close file but don't finalise this Inoutput + subroutine inoutput_close(this) + type(Inoutput), intent(inout) :: this + + if (this%unit .ge. 7) close(this%unit) + call deactivate(this) + end subroutine inoutput_close + + subroutine inoutput_mpi_all_inoutput(this,value) + + type(inoutput), intent(inout) :: this + logical, optional, intent(in) :: value + + if (present(value)) then + this%mpi_all_inoutput_flag = value + else + this%mpi_all_inoutput_flag = .true. + end if + + end subroutine inoutput_mpi_all_inoutput + + subroutine inoutput_print_mpi_id(this,value) + + type(inoutput), intent(inout) :: this + logical, optional, intent(in) :: value + + if (present(value)) then + this%mpi_print_id = value + else + this%mpi_print_id = .true. + end if + + end subroutine inoutput_print_mpi_id + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Printing routines for intrinsic types + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine inoutput_print_string(string, verbosity, file, nocr, do_flush) + character(*), intent(in) :: string + integer, optional, intent(in) :: verbosity + type(Inoutput), optional, target, intent(in) :: file + logical, optional, intent(in) :: nocr, do_flush + + type(Inoutput), pointer :: myoutput + integer :: myverbosity + character(len=2) :: nocr_fmt + logical :: my_do_flush + + my_do_flush = optional_default(system_always_flush, do_flush) + + nocr_fmt = '' + if (present(nocr)) then + if (nocr) nocr_fmt = ',$' + endif + + ! check inoutput object + myoutput => mainlog + if(present(file)) myoutput => file + + ! check verbosity request + myverbosity = PRINT_NORMAL + if(present(verbosity)) myverbosity = verbosity + + ! if we are not active, do nothing + if(.not.myoutput%active) return + ! if request is above threshold, do nothing + if(myverbosity > value(myoutput%verbosity_stack) ) return + + if(myoutput%action .EQ. INPUT) then + call system_abort("inoutput_print: you cannot print to an INPUT object") + end if + + if(.NOT.myoutput%formatted) then + call system_abort("inoutput_print: this subroutine is not good for unformatted printing") + end if + + ! actually write the line, removing trailing blanks + if (inoutput_do_output(myoutput)) then + if (len_trim(myoutput%prefix) == 0) then + if (myoutput%mpi_all_inoutput_flag .and. myoutput%mpi_print_id) then + write(myoutput%unit,'(i0,": ",a'//trim(nocr_fmt)//')') mpi_id(), trim(string)//trim(myoutput%postfix) + else + write(myoutput%unit,'(a'//trim(nocr_fmt)//')') trim(string)//trim(myoutput%postfix) + endif + else + if (myoutput%mpi_all_inoutput_flag .and. myoutput%mpi_print_id) then + write(myoutput%unit,'(i0,": ",a'//trim(nocr_fmt)//')') mpi_id(), trim(myoutput%prefix)//" "//trim(string) & + // " " // trim(myoutput%postfix) + else + write(myoutput%unit,'(a'//trim(nocr_fmt)//')') trim(myoutput%prefix)//" "//trim(string)// " " // trim(myoutput%postfix) + endif + endif + endif + + if (my_do_flush) call flush(myoutput%unit) + end subroutine inoutput_print_string + + function inoutput_do_output(this) + type(inoutput), intent(in) :: this + logical :: inoutput_do_output + + if ((this%mpi_all_inoutput_flag .or. mpi_id() == 0) .and. this%unit >= 0) then + inoutput_do_output = .true. + else + inoutput_do_output = .false. + end if + end function inoutput_do_output + + subroutine inoutput_print_char_array(char_a, verbosity, file) + character(len=*) :: char_a(:) + integer, optional, intent(in) :: verbosity + type(Inoutput), optional, target, intent(in) :: file + + integer i + character(len=size(char_a)) :: str + + do i=1, size(char_a) + str(i:i) = char_a(i) + end do + + call print(str, verbosity, file) + end subroutine inoutput_print_char_array + + subroutine inoutput_print_logical(log, verbosity, file) + logical, intent(in) :: log + integer, optional, intent(in) :: verbosity + type(Inoutput), optional, intent(in) :: file + + write(local_line,'(l1)') log + call print(local_line, verbosity, file) + end subroutine inoutput_print_logical + + subroutine inoutput_print_integer(int, verbosity, file) + integer, intent(in) :: int + integer, optional, intent(in) :: verbosity + type(Inoutput), optional, intent(in) :: file + + write(local_line,'(i0)') int + call print(local_line, verbosity, file) + end subroutine inoutput_print_integer + + subroutine inoutput_print_real(real, verbosity, file, precision, format, nocr) + real(dp), intent(in) :: real + integer, optional, intent(in) :: verbosity + integer, optional, intent(in) :: precision ! number of decimal places + character(*), optional, intent(in) :: format + type(inoutput), optional, intent(in) :: file + logical, optional, intent(in) :: nocr + + character(7) :: myformat + + if(present(format)) then + write(local_line, format) real + else + if (present(precision)) then + if (precision > 99) then + call print_message('WARNING', 'Inoutput_Print_Real: Precision too high. Capping to 99.') + write(myformat,'(a)')'(f0.99)' + else + write(myformat,'(a,i0,a)')'(f0.',precision,')' + end if + else + if(present(file)) then + write(myformat,'(a,i0,a)')'(f0.',file%default_real_precision,')' + else + write(myformat,'(a,i0,a)')'(f0.',mainlog%default_real_precision,')' + end if + end if + + write(local_line,myformat) real + end if + + call print(local_line, verbosity, file, nocr=nocr) + end subroutine inoutput_print_real + + subroutine print_inoutput(this) + type(inoutput), intent(in) :: this + + call print_title("type(inoutput)") + call print("unit "//this% unit) + call print("filename "//this%filename) + call print("prefix "//this%prefix) + call print("postfix "//this%postfix) + call print("default_real_precision "//this%default_real_precision) + call print("formatted "//this%formatted) + call print("append "//this%append) + call print("active "//this%active) + call print("action "//this%action) + call print("mpi_all_inoutput_flag "//this%mpi_all_inoutput_flag) + call print("mpi_print_id "//this%mpi_print_id) + call print("verbosity_stack: ") + call print(this%verbosity_stack) + call print("verbosity_cascade_stack: ") + call print(this%verbosity_cascade_stack) + call print("initialised "//this%initialised) + call print_title("") + end subroutine print_inoutput + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Pretty print a title +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + !% Print a centred title, like this: + !% + !% '==================================== Title =====================================' + ! + subroutine print_title(title, verbosity) + + character(*), intent(in) :: title + integer, intent(in), optional :: verbosity + + character(len(title)) :: my_title + integer :: length, a,b + + my_title = adjustl(title) + length = len_trim(my_title) + + call print('', verbosity) + if (length < 76) then + a = (80 - length) / 2 + b = 80 - length - a - 2 + call print(repeat('=',a)//' '//trim(my_title)//' '//repeat('=',b), verbosity) + else + call print(title, verbosity) + end if + call print('',verbosity) + + end subroutine print_title + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Formatted reading +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !%Read a line of text from a file (up to a line break, or 1024 characters). + !%This can then be parsed by the calling routine (using 'parse_line' for example) + !% + !%Optionally, a status is returned which is: + !% + !%\begin{itemize} + !% \item $<0$ if the end of the file is reached + !% \item $=0$ if no problems were encountered + !% \item $>0$ if there was a read error + !%\end{itemize} + !% + !%The actual number returned is implementation specific + function inoutput_read_line(this,status) + + type(Inoutput), intent(in) :: this + integer, optional, intent(out) :: status + character(SYSTEM_STRING_LENGTH_LONG) :: inoutput_read_line + integer :: my_status + + if (this%action == OUTPUT) call system_abort('read_line: Cannot read from an output file ('//trim(adjustl(this%filename))//')') + + if (present(status)) then + read (this%unit,fmt='(a)',iostat=status) inoutput_read_line + else + read (this%unit,fmt='(a)',iostat=my_status) inoutput_read_line + if (my_status < 0) call system_abort('read_line: End of file when reading '//trim(adjustl(this%filename))) + if (my_status > 0) call system_abort('read_line: Error reading file '//trim(adjustl(this%filename))) + end if + + end function inoutput_read_line + + subroutine inoutput_read_file(this,line_array, n_lines, status) + type(Inoutput), intent(in) :: this + character(len=*), allocatable, intent(inout) :: line_array(:) + integer, intent(out) :: n_lines + integer, optional, intent(out) :: status + + integer :: my_status, line_no, line_array_size + + line_no = 0 + my_status = 0 + + do while (my_status == 0) + line_no = line_no + 1 + if (allocated(line_array)) then + line_array_size = size(line_array) + else + line_array_size = 0 + endif + if (line_no > line_array_size) call extend_char_array(line_array, 1.5_dp, 10) + line_array(line_no) = read_line(this, my_status) + end do + + n_lines = line_no - 1 + + if (my_status > 0) then + if (present(status)) then + status = my_status + return + else + call system_abort("ERROR inoutput_read_file reading file '"//trim(adjustl(this%filename))//"' status " // my_status) + endif + endif + + end subroutine inoutput_read_file + + subroutine extend_char_array(line_array, factor, minlen) + character(len=*), allocatable, intent(inout) :: line_array(:) + real(dp), intent(in), optional :: factor + integer, intent(in), optional :: minlen + + real(dp) :: my_factor + integer :: my_minlen + character, allocatable :: t_line_array(:,:) + integer old_n, i, j + + my_minlen = optional_default(10, minlen) + my_factor = optional_default(1.5_dp, factor) + + if (.not. allocated(line_array)) then + allocate(line_array(my_minlen)) + return + endif + + if (allocated(line_array)) then + old_n = size(line_array) + else + old_n = 0 + end if + allocate(t_line_array(len(line_array(1)), old_n)) + do i=1, old_n + do j=1, len(line_array(1)) + t_line_array(j,i) = line_array(i)(j:j) + end do + end do + deallocate(line_array) + allocate(line_array(int(old_n*my_factor))) + do i=1, old_n + do j=1, len(line_array(1)) + line_array(i)(j:j) = t_line_array(j,i) + end do + end do + deallocate(t_line_array) + end subroutine extend_char_array + + !% Call parse_string on the next line from a file + subroutine inoutput_parse_line(this,delimiters,fields,num_fields,status) + type(inoutput), intent(in) :: this + character(*), intent(in) :: delimiters + character(*), dimension(:), intent(inout) :: fields + integer, intent(out) :: num_fields + integer, optional, intent(out) :: status + integer :: my_status + + num_fields = 0 ! in case read gives non-zero status + local_line = read_line(this,my_status) + if (present(status)) status = my_status + if (my_status == 0) call split_string_simple(local_line, fields, num_fields, delimiters) + + end subroutine inoutput_parse_line + + !% split a string into fields separated by possible separators + !% no quoting, matching separators, just a simple split + subroutine split_string_simple(str, fields, n_fields, separators, error) + character(len=*), intent(in) :: str !% string to be split + character(len=*), intent(out) :: fields(:) !% on return, array of fields + integer, intent(out) :: n_fields !% on return, number of fields + character(len=*), intent(in) :: separators !% string of possible separators + integer, intent(out), optional :: error + + integer :: str_len, cur_pos, next_pos, cur_field + + INIT_ERROR(error) + + str_len = len_trim(str) + cur_pos = 0 + cur_field = 1 + do while (cur_pos <= str_len) + if (cur_field > size(fields)) then + RAISE_ERROR("split_string_simple str='"//trim(str)//"' no room for fields size(fields)="//size(fields)//" cur_field "//cur_field, error) + endif + next_pos = scan(str(cur_pos+1:str_len),separators) + if (next_pos > 0) then + if (next_pos == 1) then ! found another separator, skip it + cur_pos = cur_pos + 1 + else ! some stuff between us and separator, must be another field + fields(cur_field) = str(cur_pos+1:cur_pos+1+next_pos-2) + cur_pos = cur_pos + next_pos + cur_field = cur_field + 1 + endif + else ! end of string, last field + fields(cur_field) = str(cur_pos+1:str_len) + cur_field = cur_field + 1 + cur_pos = str_len+1 ! exit loop + endif + end do + n_fields = cur_field - 1 + + end subroutine split_string_simple + + function num_fields_in_string_simple(this,separators) + character(len=*), intent(in) :: this + character(len=*), intent(in) :: separators + integer :: num_fields_in_string_simple + + integer :: i, res + + res = 1 + + do i = 1, len_trim(this) + if( index(trim(separators),this(i:i)) > 0 ) res = res + 1 + enddo + + + num_fields_in_string_simple = res + + endfunction num_fields_in_string_simple + + !% split a string at separators, making sure not to break up bits that + !% are in quotes (possibly matching opening and closing quotes), and + !% also strip one level of quotes off, sort of like a shell would when + !% tokenizing + subroutine split_string(this, separators, quotes, fields, num_fields, matching) + character(len=*), intent(in) :: this + character(len=*), intent(in) :: separators, quotes + character(len=*), intent(inout) :: fields(:) + integer, intent(out) :: num_fields + logical, intent(in), optional :: matching + + integer :: i, length + integer :: n_quotes + character(len=len(quotes)) :: opening_quotes, closing_quotes + integer :: opening_quote_index, closing_quote_pos + logical :: do_matching + character(len=len(fields(1))) :: tmp_field + character(1) :: c + integer :: tmp_field_last, t_start, dist + logical :: in_token + + do_matching = optional_default(.false., matching) + + if (do_matching) then + if (mod(len(quotes),2) == 0) then + do i=1, len(quotes)/2 + opening_quotes(i:i) = quotes(2*(i-1)+1:2*(i-1)+1) + closing_quotes(i:i) = quotes(2*(i-1)+2:2*(i-1)+2) + end do + n_quotes = len(quotes)/2 + else + call system_abort("split_string called with matching=.true. but odd number of quotes " // (len(quotes))) + endif + else + n_quotes = len(quotes) + opening_quotes(1:n_quotes) = quotes(1:n_quotes) + closing_quotes(1:n_quotes) = quotes(1:n_quotes) + endif + + length = len_trim(this) + num_fields = 0 + tmp_field = "" + tmp_field_last = 0 + in_token = .false. + i = 1 + do + if (i > length) then ! last character + if (in_token) then + num_fields = num_fields + 1 + if (num_fields > size(fields)) call system_abort("split_string on '"//trim(this)//"' ran out of space for fields max " // size(fields)) + if (tmp_field_last > 0) then + if (t_start <= length) then + fields(num_fields) = tmp_field(1:tmp_field_last) // this(t_start:length) + else + fields(num_fields) = tmp_field(1:tmp_field_last) + endif + else + if (t_start <= length) then + fields(num_fields) = this(t_start:length) + else + endif + endif + endif + exit + else if (scan(this(i:i),opening_quotes(1:n_quotes)) > 0) then ! found an opening quote + opening_quote_index = index(opening_quotes,this(i:i)) + closing_quote_pos = find_closing_delimiter(this(i+1:length), closing_quotes(opening_quote_index:opening_quote_index), & + opening_quotes(1:n_quotes), closing_quotes(1:n_quotes), do_matching) + if (closing_quote_pos <= 0) then + call print("splitting string '"//trim(this)//"'", PRINT_ALWAYS) + call system_abort("split_string on '"//trim(this)//"' couldn't find closing quote matching opening at char " // i) + endif + if (in_token) then ! add string from t_start to tmp_field + if (tmp_field_last > 0) then + tmp_field = tmp_field(1:tmp_field_last) // this(t_start:i-1) + else + tmp_field = this(t_start:i-1) + endif + tmp_field_last = tmp_field_last + (i-1 - t_start + 1) + endif + if (tmp_field_last > 0) then ! add contents of quote to tmp_field + if (i+closing_quote_pos-1 >= i+1) tmp_field = tmp_field(1:tmp_field_last) // this(i+1:i+closing_quote_pos-1) + else + if (i+closing_quote_pos-1 >= i+1) tmp_field = this(i+1:i+closing_quote_pos-1) + endif + ! update tmp_field_last + tmp_field_last = tmp_field_last + closing_quote_pos - 1 + in_token = .true. + i = i + closing_quote_pos + 1 + ! reset t_start + t_start = i + else if (scan(this(i:i),separators) > 0) then ! found a separator + if (next_non_separator(this, i+1, length, separators, dist) == '=') then + if (in_token) then + ! add string from t_start to tmp_field + if (tmp_field_last > 0) then + tmp_field = tmp_field(1:tmp_field_last) // this(t_start:i-1)//'=' + else + tmp_field = this(t_start:i-1)//'=' + endif + tmp_field_last = tmp_field_last + (i-1)-t_start+1+1 + else + tmp_field = '=' + tmp_field_last = 1 + endif + in_token = .true. + ! update i and t_start to be after '=' + i = i + dist + 1 + t_start = i + if (i <= length) then + ! look for next non separator + c = next_non_separator(this, i, length, separators, dist) + if (dist > 0) then + i = i + dist-1 + t_start = i + endif + endif + else + if (in_token) then ! we were in a token before finding this separator + num_fields = num_fields + 1 + if (num_fields > size(fields)) call system_abort("split_string on '"//trim(this)//"' ran out of space for fields max " // size(fields)) + ! add string from t_start and tmp_field to fields(num_fields) + if (tmp_field_last > 0) then + fields(num_fields) = tmp_field(1:tmp_field_last) // this(t_start:i-1) + else + fields(num_fields) = this(t_start:i-1) + endif + tmp_field = "" + tmp_field_last = 0 + endif + in_token = .false. + i = i + 1 + endif + else ! plain character + if (.not. in_token) then + t_start = i + endif + in_token = .true. + i = i + 1 + endif + end do + end subroutine split_string + + function next_non_separator(this, start, end, separators, dist) result(c) + character(len=*), intent(in) :: this + integer, intent(in) :: start, end + character(len=*) :: separators + integer, intent(out) :: dist + character(1) :: c + + integer i + +! call print("finding next_non_sep in '"//this(start:end)//"'") + c='' + dist = 0 + do i=start, end + if (scan(this(i:i), separators) == 0) then ! found a non-separator + c = this(i:i) + dist = i-start+1 + exit + endif + end do +! call print("returning c='"//c//"' and dist "//dist) + end function next_non_separator + + !% outdated - please use split_string + !% Parse a string into fields delimited by certain characters. On exit + !% the 'fields' array will contain one field per entry and 'num_fields' + !% gives the total number of fields. 'status' will be given the error status + !% (if present) and so can be used to tell if an end-of-file occurred. + subroutine parse_string(this, delimiters, fields, num_fields, matching, error) + + character(*), intent(in) :: this + character(*), intent(in) :: delimiters + character(*), dimension(:), intent(inout) :: fields + integer, intent(out) :: num_fields + logical, optional, intent(in) :: matching + integer, optional, intent(out) :: error + + integer :: field_start, length + integer :: delim_pos + integer :: n_delims, i + character(len=len(delimiters)) :: opening_delims, closing_delims + character(len=1) :: opening_delim + integer :: opening_delim_index + logical :: do_matching + + + do_matching = optional_default(.false., matching) + + INIT_ERROR(error) + + field_start = 1 + num_fields = 0 + length = len_trim(this) + + if (do_matching) then + if (mod(len(delimiters),2) == 0) then + do i=1, len(delimiters)/2 + opening_delims(i:i) = delimiters(2*(i-1)+1:2*(i-1)+1) + closing_delims(i:i) = delimiters(2*(i-1)+2:2*(i-1)+2) + end do + n_delims = len(delimiters)/2 + else + RAISE_ERROR("parse_string called with matching=.true. but odd number of delimiters " // (len(delimiters)), error) + endif + else + n_delims = len(delimiters) + opening_delims(1:n_delims) = delimiters(1:n_delims) + closing_delims(1:n_delims) = delimiters(1:n_delims) + endif + + do + delim_pos = scan(this(field_start:length), opening_delims(1:n_delims)) + if (delim_pos == 0) then ! didn't find opening delimiter + if (len_trim(this(field_start:length)) == 0) then !...and the rest of the string is blank... + !... then we've finished + exit + else !otherwise, there's one field left to get + if (length >= field_start) then + num_fields = num_fields + 1 + if (num_fields > size(fields)) then + RAISE_ERROR("parse_string ran out of space for fields", error) + endif + fields(num_fields) = this(field_start:length) + endif + return + end if + endif + ! get here if we found an opening delimiter + delim_pos = delim_pos + field_start - 1 + if (delim_pos /= field_start) then ! found an opening delimiter after some text + ! save text in a field, and jump over it + if (delim_pos-1 >= field_start) then + num_fields = num_fields + 1 + if (num_fields > size(fields)) then + RAISE_ERROR("parse_string ran out of space for fields", error) + endif + fields(num_fields) = this(field_start:delim_pos-1) + end if + field_start = delim_pos + endif + field_start = field_start + 1 + if (do_matching) then + opening_delim = this(delim_pos:delim_pos) + opening_delim_index = index(opening_delims(1:n_delims), opening_delim) + delim_pos = find_closing_delimiter(this(field_start:length), closing_delims(opening_delim_index:opening_delim_index), opening_delims(1:n_delims), closing_delims(1:n_delims), do_matching) + else + delim_pos = find_closing_delimiter(this(field_start:length), closing_delims, opening_delims(1:n_delims), closing_delims(1:n_delims), do_matching) + endif + if (delim_pos == 0) then ! didn't find closing delimiter + if (do_matching) then + call print("parse_string failed to find closing delimiter to match opening delimiter at position " // (field_start-1), PRINT_ALWAYS) + call print("parse_string string='"//this//"'", PRINT_ALWAYS) + RAISE_ERROR("parse_string failed to find closing delimiter", error) + else + delim_pos = length-field_start+2 + endif + endif + delim_pos = delim_pos + field_start - 1 + if (delim_pos-1 >= field_start) then + num_fields = num_fields + 1 + if (num_fields > size(fields)) then + RAISE_ERROR("parse_string ran out of space for fields", error) + endif + fields(num_fields) = this(field_start:delim_pos-1) + endif + field_start = delim_pos+1 + if (field_start > length) return + end do + + end subroutine parse_string + + recursive function find_closing_delimiter(this, closing_delim, opening_delims, closing_delims, matching) result(pos) + character(len=*), intent(in) :: this + character(len=*), intent(in) :: closing_delim + character(len=*), intent(in) :: opening_delims, closing_delims + logical :: matching + integer :: pos + + integer :: length, first_matching_closing_delim, first_opening_delim + integer :: opening_delim_index + character(len=1) :: opening_delim + integer :: substring_end_pos + + pos = 0 + + do + if (matching) then + first_matching_closing_delim = scan(this, closing_delim) + else + first_matching_closing_delim = scan(this, closing_delims) + endif + first_opening_delim = scan(this, opening_delims) + if ((first_opening_delim > 0) .and. (first_opening_delim < first_matching_closing_delim)) then + length = len(this) + if (matching) then + opening_delim = this(first_opening_delim:first_opening_delim) + opening_delim_index = index(opening_delims, opening_delim) + substring_end_pos = find_closing_delimiter(this(first_opening_delim+1:length), & + closing_delims(opening_delim_index:opening_delim_index), opening_delims, closing_delims, matching) + else + substring_end_pos = find_closing_delimiter(this(first_opening_delim+1:length), & + closing_delims, opening_delims, closing_delims, matching) + endif + if (substring_end_pos == 0) & + call system_abort("find_closing_delimiter failed to find substring closing delimiter '"// & + closing_delims(opening_delim_index:opening_delim_index)//"' in string '"//this// & + "' for substring starting at "//(first_opening_delim+1)) + substring_end_pos = substring_end_pos + first_opening_delim+1 - 1 + pos = find_closing_delimiter(this(substring_end_pos+1:length), closing_delim, opening_delims, & + closing_delims, matching) + substring_end_pos+1 - 1 + return + else + pos=first_matching_closing_delim + return + endif + end do + + return + + end function find_closing_delimiter + + !% Parse a string into fields delimited by certain characters. On exit + !% the 'fields' array will contain one field per entry and 'num_fields' + !% gives the total number of fields. 'status' will be given the error status + !% (if present) and so can be used to tell if an end-of-file occurred. + subroutine parse_string_orig(this, delimiters, fields, num_fields) + + character(*), intent(in) :: this + character(*), intent(in) :: delimiters + character(*), dimension(:), intent(inout) :: fields + integer, intent(out) :: num_fields + + integer :: field_start,field_end,width,length + integer :: array_length + + field_start = 1 + num_fields = 0 + length = len_trim(this) + array_length = size(fields) + + do + !Try to find a delimiter + width = scan(this(field_start:length),delimiters) + !If delimiter not found... + if (width == 0) then + !...and the rest of the string is blank... + if (len_trim(this(field_start:length)) == 0) then + !... then we've finished + exit + else + !otherwise, there's one field left to get + field_end = length + end if + !On the other hand, if the delimiter is the first character... + else if (width == 1) then + !...then move past it and start the do loop again + field_start = field_start + 1 + cycle + !Otherwise calculate the end of the field, without the delimiter + else + field_end = field_start + width - 2 + end if + + num_fields = num_fields + 1 + + if (num_fields > array_length) then + call print(this) + call system_abort('inoutput_parse_line: Number of fields is greater than storage array size') + end if + + fields(num_fields) = adjustl(this(field_start:field_end)) + field_start = field_end + 1 + + end do + + end subroutine parse_string_orig + + !% Convert an input string into an integer. + function string_to_int(string,error) + character(*), intent(in) :: string + integer, optional, intent(out) :: error + integer :: string_to_int + integer stat + + INIT_ERROR(error) + + string_to_int = 0 + read(string,*,iostat=stat) string_to_int + if(stat /= 0) then + RAISE_ERROR("string_to_int: could not convert, iostat="//stat, error) + endif + + end function string_to_int + + !% Convert an input string into a logical. + function string_to_logical(string, error) + character(*), intent(in) :: string + integer, optional, intent(out) :: error + logical :: string_to_logical + + INIT_ERROR(error) + + select case(trim(lower_case(string))) + case("true","t") + string_to_logical = .true. + case("false","f") + string_to_logical = .false. + case default + RAISE_ERROR("string_to_logical: could not convert. Only true/false/t/f (or any uppercase variants) may be converted. String passed: "//trim(string), error) + endselect + + end function string_to_logical + + + !% Convert an input string into a real. + function string_to_real(string, error) + character(*), intent(in) :: string + integer, optional, intent(out) :: error + real(dp) :: string_to_real + integer stat + + INIT_ERROR(error) + + string_to_real = 0.0_dp + read(string,*,iostat=stat) string_to_real + + if(stat /= 0) then + RAISE_ERROR("string_to_real: could not convert, iostat="//stat, error) + endif + + end function string_to_real + + subroutine string_to_real_sub(string,real_number,error) + character(len=*), intent(in) :: string + real(dp), intent(out) :: real_number + integer, intent(out), optional :: error + + integer :: stat + + INIT_ERROR(error) + + real_number = 0.0_dp + read(string,*,iostat=stat) real_number + + if(stat /= 0) then + RAISE_ERROR("string_to_real_sub: could not convert, iostat="//stat, error) + endif + endsubroutine string_to_real_sub + + subroutine string_to_integer_sub(string,integer_number,error) + character(len=*), intent(in) :: string + integer, intent(out) :: integer_number + integer, intent(out), optional :: error + + integer :: stat + + INIT_ERROR(error) + + integer_number = 0 + read(string,*,iostat=stat) integer_number + + if(stat /= 0) then + RAISE_ERROR("string_to_integer_sub: could not convert, iostat="//stat, error) + endif + endsubroutine string_to_integer_sub + + subroutine string_to_logical_sub(string,logical_number,error) + character(len=*), intent(in) :: string + logical, intent(out) :: logical_number + integer, intent(out), optional :: error + + integer :: stat + + INIT_ERROR(error) + + logical_number = .false. + read(string,*,iostat=stat) logical_number + + if(stat /= 0) then + RAISE_ERROR("string_to_logical_sub: could not convert, iostat="//stat, error) + endif + endsubroutine string_to_logical_sub + + subroutine string_to_real1d(string,real1d,error) + character(len=*), intent(in) :: string + real(dp), dimension(:), intent(out) :: real1d + integer, intent(out), optional :: error + + integer :: stat + + INIT_ERROR(error) + + real1d = 0.0_dp + read(string,*,iostat=stat) real1d + + if(stat /= 0) then + RAISE_ERROR("string_to_real1d: could not convert, iostat="//stat, error) + endif + endsubroutine string_to_real1d + + subroutine string_to_integer1d(string,integer1d,error) + character(len=*), intent(in) :: string + integer, dimension(:), intent(out) :: integer1d + integer, intent(out), optional :: error + + integer :: stat + + INIT_ERROR(error) + + integer1d = 0 + read(string,*,iostat=stat) integer1d + + if(stat /= 0) then + RAISE_ERROR("string_to_integer1d: could not convert, iostat="//stat, error) + endif + endsubroutine string_to_integer1d + + subroutine string_to_logical1d(string,logical1d,error) + character(len=*), intent(in) :: string + logical, dimension(:), intent(out) :: logical1d + integer, intent(out), optional :: error + + integer :: stat + + INIT_ERROR(error) + + logical1d = .false. + read(string,*,iostat=stat) logical1d + + if(stat /= 0) then + RAISE_ERROR("string_to_logical1d: could not convert, iostat="//stat, error) + endif + endsubroutine string_to_logical1d + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Reallocation: used to reduce the need to deallocate and reallocate +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine reallocate_int1d(array, d1, zero, copy) + integer, allocatable, dimension(:), intent(inout) :: array + integer, intent(in) :: d1 + logical, optional, intent(in) :: zero, copy + + logical :: do_copy + integer, allocatable :: tmp(:) + + if (allocated(array)) then + if (size(array) /= d1) then + do_copy = optional_default(.false., copy) + if (do_copy) then + allocate(tmp(size(array))) + tmp = array + endif + deallocate(array) + allocate(array(d1)) + if (do_copy) then + array = 0 + array(1:min(size(tmp),size(array))) = tmp(1:min(size(tmp),size(array))) + deallocate(tmp) + endif + end if + else + allocate(array(d1)) + end if + + if (present(zero)) then + if (zero) array = 0 + end if + + end subroutine reallocate_int1d + + subroutine reallocate_real1d(array, d1, zero, copy) + real(dp), allocatable, dimension(:), intent(inout) :: array + integer, intent(in) :: d1 + logical, optional, intent(in) :: zero, copy + + logical :: do_copy + real(dp), allocatable :: tmp(:) + + if (allocated(array)) then + if (size(array) /= d1) then + do_copy = optional_default(.false., copy) + if (do_copy) then + allocate(tmp(size(array))) + tmp = array + endif + deallocate(array) + allocate(array(d1)) + if (do_copy) then + array = 0 + array(1:min(size(tmp),size(array))) = tmp(1:min(size(tmp),size(array))) + deallocate(tmp) + endif + end if + else + allocate(array(d1)) + end if + + if (present(zero)) then + if (zero) array = 0.0_dp + end if + + end subroutine reallocate_real1d + + + subroutine reallocate_int2d(array, d1, d2, zero, copy) + integer, allocatable, dimension(:,:), intent(inout) :: array + integer, intent(in) :: d1,d2 + logical, optional, intent(in) :: zero, copy + + logical :: do_copy + integer, allocatable :: tmp(:,:) + + if (allocated(array)) then + if (.not. all(shape(array) == (/d1,d2/))) then + do_copy = optional_default(.false., copy) + if (do_copy) then + allocate(tmp(size(array,1),size(array,2))) + tmp = array + endif + deallocate(array) + allocate(array(d1,d2)) + if (do_copy) then + array = 0 + array(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2))) = tmp(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2))) + deallocate(tmp) + endif + end if + else + allocate(array(d1,d2)) + end if + + if (present(zero)) then + if (zero) array = 0 + end if + + end subroutine reallocate_int2d + + subroutine reallocate_int3d(array, d1, d2, d3, zero, copy) + integer, allocatable, dimension(:,:,:), intent(inout) :: array + integer, intent(in) :: d1,d2,d3 + logical, optional, intent(in) :: zero, copy + + logical :: do_copy + integer, allocatable :: tmp(:,:,:) + + if (allocated(array)) then + if (.not. all(shape(array) == (/d1,d2,d3/))) then + do_copy = optional_default(.false., copy) + if (do_copy) then + allocate(tmp(size(array,1),size(array,2),size(array,3))) + tmp = array + endif + deallocate(array) + allocate(array(d1,d2,d3)) + if (do_copy) then + array = 0 + array(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2)),1:min(size(tmp,3),size(array,3))) = tmp(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2)),1:min(size(tmp,3),size(array,3))) + deallocate(tmp) + endif + end if + else + allocate(array(d1,d2,d3)) + end if + + if (present(zero)) then + if (zero) array = 0 + end if + + end subroutine reallocate_int3d + + subroutine reallocate_real2d(array, d1, d2, zero, copy) + real(dp), allocatable, dimension(:,:), intent(inout) :: array + integer, intent(in) :: d1,d2 + logical, optional, intent(in) :: zero, copy + + logical :: do_copy + real(dp), allocatable :: tmp(:,:) + + if (allocated(array)) then + if (.not. all(shape(array) == (/d1,d2/))) then + do_copy = optional_default(.false., copy) + if (do_copy) then + allocate(tmp(size(array,1),size(array,2))) + tmp = array + endif + deallocate(array) + allocate(array(d1,d2)) + if (do_copy) then + array = 0.0_dp + array(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2))) = tmp(1:min(size(tmp,1),size(array,1)),1:min(size(tmp,2),size(array,2))) + deallocate(tmp) + endif + end if + else + allocate(array(d1,d2)) + end if + + if (present(zero)) then + if (zero) array = 0.0_dp + end if + + end subroutine reallocate_real2d + + subroutine reallocate_char1d(array, d1, zero, copy) + character(len=*), allocatable, dimension(:), intent(inout) :: array + integer, intent(in) :: d1 + logical, optional, intent(in) :: zero, copy + + + if (allocated(array)) then + call reallocate_allocated_char1d(array,d1,copy) + else + allocate(array(d1)) + end if + + if (present(zero)) then + if (zero) array = "" + end if + + + end subroutine reallocate_char1d + + subroutine reallocate_allocated_char1d(array,d1,copy) + character(len=*), allocatable, dimension(:), intent(inout) :: array + integer, intent(in) :: d1 + logical, optional, intent(in) :: copy + + logical :: do_copy + character(len=len(array(lbound(array)))), allocatable, dimension(:) :: tmp + + if (size(array) /= d1) then + do_copy = optional_default(.false., copy) + if (do_copy) then + allocate(tmp(size(array))) + tmp = array + endif + deallocate(array) + allocate(array(d1)) + if (do_copy) then + array = "" + array(1:min(size(tmp),size(array))) = tmp(1:min(size(tmp),size(array))) + deallocate(tmp) + endif + end if + endsubroutine reallocate_allocated_char1d + + subroutine reallocate_log1d(array, d1, zero, copy) + logical, allocatable, dimension(:), intent(inout) :: array + integer, intent(in) :: d1 + logical, optional, intent(in) :: zero, copy + + logical :: do_copy + logical, allocatable :: tmp(:) + + if (allocated(array)) then + if (size(array) /= d1) then + do_copy = optional_default(.false., copy) + if (do_copy) then + allocate(tmp(size(array))) + tmp = array + endif + deallocate(array) + allocate(array(d1)) + if (do_copy) then + array = .false. + array(1:min(size(tmp),size(array))) = tmp(1:min(size(tmp),size(array))) + deallocate(tmp) + endif + end if + else + allocate(array(d1)) + end if + + if (present(zero)) then + if (zero) array = .false. + end if + + end subroutine reallocate_log1d + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Read scalar and array data from ascii files. These +!% interfaces are not yet heavily overloaded to cater for all intrinsic and most +!% derived types. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine reada_real_dim1(this,da,status) + type(Inoutput), intent(in) :: this + real(dp), intent(out) :: da(:) + integer, optional, intent(out) :: status + + integer :: my_status + + if (this%action == OUTPUT) call system_abort('read_line: Cannot read from an output file ('//trim(adjustl(this%filename))//')') + + if (present(status)) then + read (this%unit,fmt=*,iostat=status) da + else + read (this%unit,fmt=*,iostat=my_status) da + if (my_status < 0) call system_abort('read_line: End of file when reading '//trim(adjustl(this%filename))) + if (my_status > 0) call system_abort('read_line: Error reading file '//trim(adjustl(this%filename))) + end if + end subroutine reada_real_dim1 + + subroutine reada_int_dim1(this,ia,status) + type(Inoutput), intent(in) :: this + integer, intent(out) :: ia(:) + integer, optional, intent(out) :: status + + integer :: my_status + + if (this%action == OUTPUT) call system_abort('read_line: Cannot read from an output file ('//trim(adjustl(this%filename))//')') + + if (present(status)) then + read (this%unit,fmt=*,iostat=status) ia + else + read (this%unit,fmt=*,iostat=my_status) ia + if (my_status < 0) call system_abort('read_line: End of file when reading '//trim(adjustl(this%filename))) + if (my_status > 0) call system_abort('read_line: Error reading file '//trim(adjustl(this%filename))) + end if + end subroutine reada_int_dim1 + + !% Rewind to the start of this file. Works for both formatted and unformatted files. + subroutine rewind(this) + type(Inoutput), intent(inout) :: this + rewind this%unit + end subroutine rewind + + !% Move the file pointer back by 'n' (defaults to 1) records. Works for + !% formatted and unformatted files. + subroutine backspace(this,n) + type(Inoutput), intent(inout) :: this + integer, optional :: n + integer :: i + if (present(n)) then + do i=1,n + backspace this%unit + end do + else + backspace this%unit + end if + end subroutine backspace + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!% Concatenation functions. +!% Overloadings for the // operator to make strings from various other types. +!% In each case, we need to work out the exact length of the resultant string +!% in order to avoid printing excess spaces. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Return a string which is the real number 'r' rounded to 'digits' decimal digits + function round(r,digits) + + real(dp), intent(in) :: r + integer, intent(in) :: digits + ! below we work out the exact length of the resultant string + ! space for '-' sign or not + digits in integer part + space for . or not + decimal digits + character( int(0.5_dp-sign(0.5_dp,r)) + int(log10(max(1.0_dp,abs(r)+0.5_dp*10.0_dp**(-digits)))) + 1 + int(sign(0.5_dp,real(digits,dp)-0.5_dp)+0.5_dp) + max(0,digits)) :: round + character(8) :: format + + if (digits > 0) then + write(format,'(a,i0,a)')'(f0.',max(0,digits),')' + write(round,format) r + else + write(round,'(i0)') int(r) + end if + + end function round + + function string_cat_logical(string, log) + character(*), intent(in) :: string + logical, intent(in) :: log + character((len(string)+1)) :: string_cat_logical + write(string_cat_logical,'(a,l1)') string, log + end function string_cat_logical + + function string_cat_logical_array(string, log) + character(*), intent(in) :: string + logical, intent(in) :: log(:) + character((len(string)+2*size(log)-1)) :: string_cat_logical_array + character(len=32) format + + format = '(a,'//size(log)//'(l1,1x),l1)' + write(string_cat_logical_array,format) string, log + end function string_cat_logical_array + + elemental function int_format_length_isp(i) result(len) + integer(isp), intent(in)::i + integer::len + len = max(1,(-sign(1, i)+1)/2 + ceiling(log10(abs(real(i,dp))+0.01_dp))) + end function int_format_length_isp + + elemental function int_format_length_idp(i) result(len) + integer(idp), intent(in) :: i + integer :: len + len = max(1_idp,(-sign(1_idp, i)+1_idp)/2_idp + ceiling(log10(abs(real(i,dp))+0.01_dp), idp)) + end function int_format_length_idp + + function string_cat_isp(string, int) result(res) + character(*), intent(in) :: string + integer(isp), intent(in) :: int + ! below we work out the exact length of the resultant string + character(len(string)+int_format_length(int)) :: res + + write(res,'(a,i0)') string, int + end function string_cat_isp + + function string_cat_idp(string, int) result(res) + character(*), intent(in) :: string + integer(idp), intent(in) :: int + ! below we work out the exact length of the resultant string + character(len(string)+int_format_length(int)) :: res + + write(res,'(a,i0)') string, int + end function string_cat_idp + + function int_cat_string(int,string) + character(*), intent(in) :: string + integer, intent(in) :: int + ! below we work out the exact length of the resultant string + character(len(string)+int_format_length(int)) :: int_cat_string + + write(int_cat_string,'(i0,a)') int,string + end function int_cat_string + + function string_cat_int_array(string, values) + character(*), intent(in) :: string + integer, intent(in) :: values(:) + ! below we work out the exact length of the resultant string + character(len(string)+size(values)+sum(int_format_length(values)))::string_cat_int_array + + character(32) :: format + + if (size(values) == 1) then + format = '(a,i0)' + write(string_cat_int_array,format) string, values + else if (size(values)>1) then + format = '(a,' // (size(values)-1) //'(i0,1x),i0)' + write(string_cat_int_array,format) string, values + else + write(string_cat_int_array,'(a)') string + end if + + end function string_cat_int_array + + pure function real_sci_format_length() result(len) + integer::len + ! space sign 0. fractional part E+000 + len = 1 + 1 + 2 + max(0,mainlog%default_real_precision)+5 + end function real_sci_format_length + + + function string_cat_real_array(string, values) + character(*), intent(in) :: string + real(dp), intent(in) :: values(:) + ! we work out the exact length of the resultant string + character((len(string)+size(values)*real_sci_format_length())) :: string_cat_real_array + character(32) :: format + + if (size(values)>0) then + ! replaced concatenation with write... for PGI bug, NB 22/6/2007 + write(format,'("(a,",I0,"e",I0,".",I0,"e3)")') size(values), real_sci_format_length(), & + mainlog%default_real_precision + write(string_cat_real_array, format) string, values + else + write(string_cat_real_array, '(a)') string + end if + + end function string_cat_real_array + + function string_cat_complex_array(string, values) + character(*), intent(in) :: string + complex(dp), intent(in) :: values(:) + ! we work out the exact length of the resultant string + character((len(string)+2*size(values)*real_sci_format_length())) :: string_cat_complex_array + character(32) :: format + + if (size(values)>0) then + ! replaced concatenation with write... for PGI bug, NB 22/6/2007 + write(format,'("(a,",I0,"e",I0,".",I0,"e3)")') 2*size(values), real_sci_format_length(), & + mainlog%default_real_precision + write(string_cat_complex_array, format) string, values + else + write(string_cat_complex_array, '(a)') string + end if + + end function string_cat_complex_array + + function string_cat_string_array(string, values) + character(*), intent(in) :: string + character(*), intent(in) :: values(:) + ! we work out the exact length of the resultant string +#ifndef __PGI + character(len(string)+size(values)*len(values(1))) :: string_cat_string_array +#else +#warning temporal fix in size of string_cat_string_array + ! nvfortran: temporal fix + character(len(string)) :: string_cat_string_array +#endif + character(32) :: format + + if (size(values)>0) then + ! replaced concatenation with write... for PGI bug, NB 22/6/2007 + write(format,'("(a",I0,",",I0,"a",I0,")")') len(string), size(values)+1, len(values(1)) + write(string_cat_string_array, format) string, values + else + write(string_cat_string_array, '(a)') string + end if + + end function string_cat_string_array + + function real_array_cat_string(values, string) + character(*), intent(in) :: string + real(dp), intent(in) :: values(:) + ! we work out the exact length of the resultant string + character((len(string)+size(values)*real_sci_format_length())) :: real_array_cat_string + character(32) :: format + + if (size(values)>0) then + ! replaced concatenation with write... for PGI bug, NB 22/6/2007 + write(format,'("(",I0,"e",I0,".",I0,"e3,a)")') size(values), real_sci_format_length(), & + mainlog%default_real_precision + write(real_array_cat_string, format) values, string + else + write(real_array_cat_string, '(a)') string + end if + + end function real_array_cat_string + + pure function real_format_length(r) result(len) + real(dp), intent(in) :: r + integer :: len + integer :: space_for_sign, space_for_exponent + character(len=256) :: tmp + + if(isnan(r)) then + len = 3 + elseif( mainlog%default_real_precision > 0 .or. abs(r) > huge(1) / 10 ) then + space_for_sign = int(0.5_dp-sign(0.5_dp,r)) + space_for_exponent = merge(0,5,abs(r) > 0.1_dp .and. abs(r) < 10.0_dp**mainlog%default_real_precision ) + ! NULL/- . 12345 NULL/E-000 + len = space_for_sign + 1 + merge(mainlog%default_real_precision,15,mainlog%default_real_precision > 0) + space_for_exponent + else + write(tmp,'(i0)') int(r) + len = len_trim(tmp) + end if + +#ifdef GFORTRAN_ZERO_HACK + !gfortran hack - 0.0000... is printed as .00000000 + if (r == 0.0_dp) then len = len - 1 +#endif + + end function real_format_length + + pure function complex_format_length(c) result(len) + complex(dp), intent(in)::c + integer::len + + len = real_format_length(real(c))+1+real_format_length(imag(c)) + end function complex_format_length + + function real_cat_string(r, string) + character(*), intent(in) :: string + real(dp), intent(in) :: r + ! we work out the exact length of the resultant string + character( len(string)+real_format_length(r) ) :: real_cat_string + character(12) :: format + + integer :: len_r + + len_r = real_format_length(r) + + if (isnan(r)) then + write(real_cat_string,'(a,a)') "NaN", string + elseif( mainlog%default_real_precision > 0 .or. abs(r) > huge(1) / 10 ) then + if( abs(r) > 0.1_dp .and. abs(r) < 10.0_dp**mainlog%default_real_precision ) then + write(format,'(a,i0,a,i0,a)')'(f',len_r,'.',mainlog%default_real_precision-floor(log10(abs(r)))-1,',a)' + else + write(format,'(a,i0,a,i0,a)')'(e',len_r,'.',merge(mainlog%default_real_precision,15,mainlog%default_real_precision > 0),'E3,a)' + endif + write(real_cat_string,format) r, string + else + write(real_cat_string,'(i0,a)') int(r), string + endif + + end function real_cat_string + + function string_cat_real(string,r) + character(*), intent(in) :: string + real(dp), intent(in) :: r + ! we work out the exact length of the resultant string + character( len(string)+real_format_length(r) ) :: string_cat_real + character(12) :: format + + integer :: len_r + + len_r = real_format_length(r) + + if (isnan(r)) then + write(string_cat_real,'(a,a)') string, "NaN" + elseif( mainlog%default_real_precision > 0 .or. abs(r) > huge(1) / 10 ) then + if( abs(r) > 0.1_dp .and. abs(r) < 10.0_dp**mainlog%default_real_precision ) then + write(format,'(a,i0,a,i0,a)')'(a,f',len_r,'.',mainlog%default_real_precision-floor(log10(abs(r)))-1,')' + else + write(format,'(a,i0,a,i0,a)')'(a,e',len_r,'.',merge(mainlog%default_real_precision,15,mainlog%default_real_precision > 0),'E3)' + endif + write(string_cat_real,format) string, r + else + write(string_cat_real,'(a,i0)') string, int(r) + endif + + end function string_cat_real + + function string_cat_complex(string, c) + character(*), intent(in) :: string + complex(dp), intent(in) :: c + ! we work out the exact length of the resultant string + character( len(string)+complex_format_length(c)) :: string_cat_complex + character(24) :: format + + string_cat_complex = string//real(c)//","//aimag(c) + + end function string_cat_complex + + !% Returns a string with number shortened to 2 to 4 digits and si prefix appended + function i2si(number) result(res) + integer(idp), intent(in) :: number + character(:), allocatable :: res + character, parameter :: prefixes(0:*) = [' ', 'K', 'M', 'G', 'T', 'P', 'E'] + + integer :: i, l + integer(idp) :: num + character(5) :: str + + num = number + do i = lbound(prefixes, 1), ubound(prefixes, 1)-1 + if (num < 10000) exit + num = num / 1000 + end do + str = "" // num + + l = len_trim(str) + allocate(character(len=l+2) :: res) + res = str(1:l) // " " // prefixes(i) + end function i2si + + !% Return the mpi size and rank for the communicator 'comm'. + !% this routine aborts of _MPI is not defined + subroutine get_mpi_size_rank(comm, nproc, rank) + + integer, intent(in) :: comm !% MPI communicator + integer, intent(out) :: nproc !% Total number of processes + integer, intent(out) :: rank !% Rank of this process + +#ifdef _MPI + + integer::error_code + + call MPI_COMM_SIZE(comm, nproc, error_code) + if (error_code .ne. MPI_SUCCESS) then + rank=-1 + nproc=-1 + return + endif + call MPI_COMM_RANK(comm, rank, error_code) + if (error_code .ne. MPI_SUCCESS) then + rank=-1 + nproc=-1 + return + endif +#else + rank = 0 + nproc = 1 +#endif + end subroutine get_mpi_size_rank + + ! System initialiser + + !% Must be called at the start of all programs. Initialises MPI if present, + !% set the random number seed sets up the default Inoutput objects + !% logger and errorlog to point to stdout and stderr respectively. Calls + !% Hello_World to do some of the work and print a friendly welcome. If we're + !% using MPI, by default we set the same random seed for each process. + !% This also attempts to read the executable name, the number of command + !% arguments, and the arguments themselves. + subroutine system_initialise(verbosity,seed, mpi_all_inoutput, common_seed, enable_timing, quippy_running, mainlog_file, mainlog_unit) + integer,intent(in), optional::verbosity !% mainlog output verbosity + integer,intent(in), optional::seed !% Seed for the random number generator. + logical,intent(in), optional::mpi_all_inoutput !% Print on all MPI nodes (false by default) + logical,intent(in), optional::common_seed + logical,intent(in), optional::enable_timing !% Enable system_timer() calls + logical,intent(in), optional::quippy_running !% .true. if running under quippy (Python interface) + character(len=*),intent(in), optional :: mainlog_file + integer,intent(in), optional :: mainlog_unit + !% If 'common_seed' is true (default), random seed will be the same for each + !% MPI process. + character(30) :: arg + integer :: status, i, n + logical :: master_only + +#ifdef _MPI + integer::PRINT_ALWAYS + logical :: is_initialised + + call MPI_initialized(is_initialised, PRINT_ALWAYS) + call abort_on_mpi_error(PRINT_ALWAYS, "system_initialise, mpi_initialised()") + if (.not. is_initialised) then + call MPI_INIT(PRINT_ALWAYS) + call abort_on_mpi_error(PRINT_ALWAYS, "system_initialise, mpi_init()") + endif + call get_mpi_size_rank(MPI_COMM_WORLD, mpi_n, mpi_myid) + if (mpi_n < 1 .or. mpi_myid < 0) & + call system_abort("system_initialise Got bad size="//mpi_n// " or rank="//mpi_myid//" from get_mpi_size_rank") + error_mpi_myid = mpi_myid +#else + mpi_n = 1 ! default + mpi_myid = 0 ! default +#endif + + ! should really be in declaration, but ifort complains +#ifdef NO_F2003_NEW_LINE + quip_new_line = char(13) +#else + quip_new_line = new_line(' ') +#endif + + call cpu_time(start_time) + master_only = .not. optional_default(.false., mpi_all_inoutput) + + ! Initialise the verbosity stack and default logger + call initialise(mainlog, filename=mainlog_file, unit=mainlog_unit, verbosity=verbosity, & + action=OUTPUT, master_only=master_only) + call print_mpi_id(mainlog) + call initialise(errorlog, filename='stderr', master_only=master_only) + call print_mpi_id(errorlog) + error_unit = errorlog%unit + + call hello_world(seed, common_seed) + + RAN_MAX = huge(1) + + ! Query arguments and executable name + num_command_args = cmd_arg_count() + call get_cmd_arg(0, arg, status=status) + if (status == 0) then + EXEC_NAME = arg + else + EXEC_NAME ='' + end if + if (NUM_COMMAND_ARGS < MAX_READABLE_ARGS) then + n = NUM_COMMAND_ARGS + else + n = MAX_READABLE_ARGS + end if + do i = 1, n + call get_cmd_arg(i, COMMAND_ARG(i), status = status) + if (status /= 0) then + write(line,'(a,i0)')'system_initialise: Problem reading command argument ',i + call system_abort(line) + end if + end do + + system_do_timing = optional_default(.false., enable_timing) + if (system_do_timing) then + call print("Calls to system_timer will report times") + else + call print("Calls to system_timer will do nothing by default") + endif + call print('') + + system_quippy_running = optional_default(.false., quippy_running) + + end subroutine system_initialise + + subroutine get_mainlog_errorlog_ptr(mainlog_ptr, errorlog_ptr) + type inoutput_ptr + type(inoutput), pointer :: p + end type inoutput_ptr +#ifndef SIZEOF_FORTRAN_T +#error "SIZEOF_FORTRAN_T not defined. Check your build scripts, e.g. build/${QUIP_ARCH}/Makefile.inc" +#endif + integer, intent(out), dimension(SIZEOF_FORTRAN_T) :: mainlog_ptr, errorlog_ptr + type(inoutput_ptr) :: mainlog_p, errorlog_p + + mainlog_p%p => mainlog + mainlog_ptr = transfer(mainlog_p, mainlog_ptr) + errorlog_p%p => errorlog + errorlog_ptr = transfer(errorlog_p, errorlog_ptr) + + end subroutine get_mainlog_errorlog_ptr + + function cmd_arg_count() + integer :: cmd_arg_count + +#ifndef GETARG_F2003 + integer :: iargc + external iargc +#endif + +#ifndef GETARG_F2003 + cmd_arg_count = iargc() +#else + cmd_arg_count = command_argument_count() +#endif + end function cmd_arg_count + + subroutine get_cmd_arg(i,arg, status) + integer, intent(in) :: i + character(len=*), intent(out) :: arg + integer, intent(out), optional :: status + +#ifndef GETARG_F2003 + external getarg +#endif + +#ifndef GETARG_F2003 + call getarg(i, arg) + if (present(status)) status = 0 +#else + call get_command_argument(i, arg, status=status) +#endif + end subroutine get_cmd_arg + + subroutine get_env_var(name, arg, status) + character(len=*), intent(in) :: name + character(len=*), intent(out) :: arg + integer, intent(out), optional :: status + +#ifndef GETENV_F2003 + external getenv +#endif + +#ifndef GETENV_F2003 + call getenv(trim(name), arg) + if (present(status)) then + if( len_trim(arg) > 0 ) then + status = 0 + else + status = 1 + endif + endif +#else + call get_environment_variable(trim(name), arg, status=status) +#endif + end subroutine get_env_var + + !% Shut down gracefully, finalising system objects. + subroutine system_finalise() + integer :: values(8) +#ifdef _MPI + integer :: PRINT_ALWAYS +#endif + logical :: ltemp + integer, allocatable :: seeds(:), idums(:) + + call print("") + call system_get_random_seeds(seeds, idums) + ltemp = mainlog%mpi_all_inoutput_flag + mainlog%mpi_all_inoutput_flag = .true. + call print('libAtoms::Finalise: random seeds(:) = '//seeds, PRINT_VERBOSE) + call print('libAtoms::Finalise: random idums(:) = '//idums, PRINT_VERBOSE) + mainlog%mpi_all_inoutput_flag = ltemp + + call date_and_time(values=values) + call print('libAtoms::Finalise: '//date_and_time_string(values)) + call print("libAtoms::Finalise: Bye-Bye!") + call finalise(mainlog) + call finalise(errorlog) +#ifdef _MPI + call mpi_finalize(PRINT_ALWAYS) + call abort_on_mpi_error(PRINT_ALWAYS, "system_finalise, mpi_finalise()") +#endif + end subroutine system_finalise + + !% Backward compatible (replaced with print_message) routine to print a warning message to log + subroutine print_warning(message) + character(*), intent(in) :: message + !write (0,*) 'WARNING: '//message + call print_message('WARNING', message) + end subroutine print_warning + + !% Print a message to log + subroutine print_message(message_type, message, verbosity) + character(*), intent(in) :: message_type + character(*), intent(in) :: message + integer, intent(in), optional :: verbosity ! default passed to print() + !write (0,*) 'WARNING: '//message + call print(message_type // ': ' // message, verbosity=verbosity) + end subroutine print_message + + !% Take the values from 'date_and_time' and make a nice string + function date_and_time_string(values) + character(21) :: date_and_time_string + integer, intent(in) :: values(8) + character(2) :: time(7) + character(4) :: year + integer :: i + + write(year,'(i0)') values(1) + do i = 2, 7 + if (i==4) cycle ! We don't use the local adjustment to UTC + write(time(i),'(i0.2)') values(i) + end do + write(date_and_time_string,'(11a)') year,'-',time(2),'-',time(3),' ',time(5),':',time(6),':',time(7) + + end function date_and_time_string + + subroutine system_set_random_seeds(seed) +#ifdef _OPENMP + use omp_lib +#endif + integer, intent(in) :: seed + + integer :: n + integer, allocatable :: seed_a(:) + + integer :: i, ran_dummy + +#ifdef _OPENMP + !$omp parallel + idum=seed*(omp_get_thread_num()+1) + !$omp end parallel +#else + idum=seed !gabor generator +#endif + + call random_seed(size=n) + allocate(seed_a(n)) + seed_a = seed + call random_seed(put=seed_a) !fortran 90 generator + deallocate(seed_a) + + ! The first seed tends to give very small random numbers. The loop below decorrelates the seed from the initial value so it can be trusted to be uniform. +!$OMP parallel + do i = 1, 100 + ran_dummy = ran() + enddo +!$OMP end parallel + end subroutine system_set_random_seeds + + subroutine system_get_random_seeds(seeds, idums) + integer, intent(out), allocatable :: seeds(:), idums(:) + + integer :: n + + call random_seed(size=n) + call reallocate(seeds, n) + call random_seed(get=seeds) + +#ifdef _OPENMP + !$omp parallel shared(idums) + !$omp single + call reallocate(idums, omp_get_num_threads()) + idums = 0 + !$omp end single + idums(omp_get_thread_num()+1) = idum + !$omp end parallel +#else + call reallocate(idums, 1) + idums(1) = idum +#endif + end subroutine system_get_random_seeds + + !% Called by 'system_initialise' to print welcome messages and + !% seed the random number generator. + subroutine hello_world(seed, common_seed) + integer, optional::seed !% Seed for the random number generator. + logical, optional :: common_seed + !% If 'common_seed' is true (default), random seed will be the same for each + !% MPI process. +!$ character(len=SYSTEM_STRING_LENGTH) :: omp_stacksize + integer:: actual_seed + integer:: values(20) ! for time inquiry function + logical :: use_common_seed + integer :: np=1, myp=0 +#ifdef _MPI + integer :: PRINT_ALWAYS +#endif + + call date_and_time(values=values) + + call print('libAtoms::Hello World: '//date_and_time_string(values)) + call print('libAtoms::Hello World: git version '//current_version()) + call print('libAtoms::Hello World: QUIP_ARCH '//QUIP_ARCH) + call print('libAtoms::Hello World: compiled on '//__DATE__//' at '//__TIME__) +#ifdef _MPI + call print('libAtoms::Hello World: MPI parallelisation with '//mpi_n_procs()//' processes') +#endif +! Open MP stuff +!$OMP parallel +!$OMP master +!$ call print('libAtoms::Hello World: OpenMP parallelisation with '//OMP_get_num_threads()//' threads') +!$ call get_env_var('OMP_STACKSIZE',omp_stacksize) +!$ if(len_trim(omp_stacksize) == 0) then +!$ call print_message('WARNING', 'libAtoms::Hello World: environment variable OMP_STACKSIZE not set explicitly. The default value - system and compiler dependent - may be too small for some applications.') +!$ else +!$ call print('libAtoms::Hello World: OMP_STACKSIZE='//trim(omp_stacksize)) +!$ endif +!$OMP end master +!$OMP end parallel + if(present(seed)) then + actual_seed = seed + else +#ifdef _MPI + call get_mpi_size_rank(MPI_COMM_WORLD, np, myp) +#endif + actual_seed= (((values(5)*60+values(6))*60+values(7))*1000+values(8))*np+1+myp ! (number of ms since beginning of the day time) * np + rank + use_common_seed = optional_default(.true., common_seed) +#ifdef _MPI + if (.not. use_common_seed) then + call print('libAtoms::Hello World: MPI run with different seeds on each process') + else + call print('libAtoms::Hello World: MPI run with the same seed on each process') + + ! Broadcast seed from process 0 to all others + call MPI_Bcast(actual_seed, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, PRINT_ALWAYS) + call abort_on_mpi_error(PRINT_ALWAYS, 'Hello_World: MPI_Bcast()') + end if +#endif + end if + + call print('libAtoms::Hello World: Random Seed = '//actual_seed) + call system_set_random_seeds(actual_seed) + + call print('libAtoms::Hello World: global verbosity = '//value(mainlog%verbosity_stack)) + call print('') + end subroutine hello_world + + subroutine system_resync_rng +#ifdef _MPI +#ifdef _OPENMP + use omp_lib +#endif + integer :: PRINT_ALWAYS +#ifdef _OPENMP + integer, allocatable :: idum_buf(:) +#endif + call print('Resynchronising random number generator', PRINT_VERBOSE) + +#ifdef _OPENMP + allocate(idum_buf(omp_get_max_threads())) + ! Collect all seeds into continuous buffer + !$omp parallel default(none) shared(idum_buf) + idum_buf(omp_get_thread_num()+1) = idum + !$omp end parallel + ! Broadcast seed from process 0 to all others + call MPI_Bcast(idum_buf, omp_get_max_threads(), MPI_INTEGER, 0, & + MPI_COMM_WORLD, PRINT_ALWAYS) + call abort_on_mpi_error(PRINT_ALWAYS, 'system_resync_rng') + ! Set seeds on individual threads + !$omp parallel default(none) shared(idum_buf) + idum = idum_buf(omp_get_thread_num()+1) + !$omp end parallel + deallocate(idum_buf) +#else + ! Broadcast seed from process 0 to all others + call MPI_Bcast(idum, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, PRINT_ALWAYS) + call abort_on_mpi_error(PRINT_ALWAYS, 'system_resync_rng') +#endif +#endif + end subroutine system_resync_rng + + ! + !% Return the correct ordinal ending (st,nd,rd,th) for the given integer + ! + elemental function th(n) + + integer, intent(in) :: n + character(2) :: th + integer :: l,m + + l = mod(n,100) + m = mod(n,10) + + if (l > 10 .and. l < 20) then + th = 'th' + else + select case(m) + case(1) + th = 'st' + case(2) + th = 'nd' + case(3) + th = 'rd' + case default + th = 'th' + end select + end if + + end function th + + + !% Reseed the random number generator. Useful when restarting from check files. + subroutine system_reseed_rng(new_seed) + integer, intent(in) :: new_seed + + call print('libAtoms::Reseed_RNG: Reseeding random number generator, new seed = '//new_seed,PRINT_VERBOSE) + call system_set_random_seeds(new_seed) + end subroutine system_reseed_rng + + !% Return the current random number seed. + function system_get_random_seed() + integer :: system_get_random_seed + + system_get_random_seed = idum + end function system_get_random_seed + + !% Return a random integer + function ran() + integer::ran + integer:: k + real(dp):: dran + + if (system_use_fortran_random) then + call random_number(dran) + ran = dran*RAN_MAX + else + if (idum == 0) & + call system_abort("function ran(): linear-congruential random number generators fail with seed idum=0") + k = idum/ran_Q + idum = ran_A*(idum-k*ran_Q)-ran_R*k + if(idum < 0) idum = idum + ran_M + ran =idum + endif + end function ran + + !% Return a random real number uniformly distributed in the range [0,1] + function ran_uniform() + real(dp)::ran_uniform + + if (system_use_fortran_random) then + call random_number(ran_uniform) + else + ran_uniform = 1.1_dp + do while (ran_uniform > 1.0_dp) ! generating [0,1] + ran_uniform = real(ran(),dp)/RAN_MAX + end do + end if + end function ran_uniform + + !% Return random real from Normal distribution with mean zero and standard deviation one. + function ran_normal() + real(dp) :: ran_normal, r, v1, v2 + r = 2.0_dp + do while (r > 1.0_dp) + v1 = 2.0_dp * ran_uniform() - 1.0_dp + v2 = 2.0_dp * ran_uniform() - 1.0_dp + r = v1*v1 + v2*v2 + end do + ran_normal = v1 * sqrt(-2.0_dp * log(r) / r) + end function ran_normal + + !% Return a random real distributed exponentially between zero and positive infinity + !% with mean and variance of unity + function ran_exp() result(r) + real(dp) :: r + r = -log(ran_uniform()) + end function ran_exp + + !% Return a random string of length l containing the characters A-Z, a-z, and 0-9 + function ran_string(l) + + integer, intent(in) :: l + character(len=l) :: ran_string + integer :: i, n + + do i = 1, l + n = mod(ran(),62) + if (n < 10) then + ran_string(i:i) = achar(n+48) ! 0-9 + else if (n < 36) then + ran_string(i:i) = achar(n+55) ! A-Z + else + ran_string(i:i) = achar(n+61) ! a-z + end if + end do + + end function ran_string + + subroutine current_times(cpu_t, wall_t, mpi_t) + real(dp), intent(out), optional :: cpu_t, wall_t, mpi_t + integer(kind=8) wall_t_count, count_rate, max_count + if (present(cpu_t)) call cpu_time(cpu_t) + if (present(wall_t)) then + call system_clock(wall_t_count, count_rate, max_count) + wall_t = real(wall_t_count,dp) * 1.0_dp/real(count_rate,dp) + endif +#ifdef _MPI + if (present(mpi_t)) mpi_t = MPI_Wtime() +#else + if (present(mpi_t)) mpi_t = 0.0_dp +#endif + end subroutine current_times + + !% Measure elapsed CPU and wall clock time between pairs of calls with + !% matching 'name' parameter. Calls to 'system_timer' must be properly + !% nested (i.e. start and stop from different pairs can't overlap), and + !% maximum depth of calls is set by the 'TIMER_STACK' parameter. + !% + !%> call system_timer(name) start the clock + !%> ... do something + !%> call system_timer(name) stop clock and print elapsed time + !%> + !%> If optional do_always argument is true, routine will do its thing even + !%> if system_do_timing is false. + ! + subroutine system_timer(name, do_always, time_elapsed, do_print) +#ifdef _OPENMP + use omp_lib +#endif + character(len=*), intent(in) :: name !% Unique identifier for this timer + logical, intent(in), optional :: do_always + real(dp), intent(out), optional :: time_elapsed + logical, intent(in), optional :: do_print + + integer, save :: stack_pos = 0 + real(dp), save, dimension(TIMER_STACK) :: wall_t0, cpu_t0 + character(len=255), save, dimension(TIMER_STACK) :: names + character(len=50) :: out_name + + logical my_do_always, my_do_print + + logical :: found_name + real(dp) :: cpu_t1, wall_t1 +#ifdef _MPI + real(dp), save :: mpi_t0(TIMER_STACK) + real(dp) :: mpi_t1 +#endif + + my_do_always = optional_default(.false., do_always) + my_do_print = optional_default(.true., do_print) + + if (.not. my_do_always .and. .not. system_do_timing) return + +#ifdef _OPENMP + ! stacks are not thread safe, so if we're in an OpenMP parallel region do nothing + if (omp_get_num_threads() > 1) return +#endif + + found_name = .false. + if (stack_pos >= 1) found_name = trim(names(stack_pos)) == trim(name) + + if (.not. found_name) then + ! Start a new timer + stack_pos = stack_pos + 1 + if (stack_pos > TIMER_STACK) then + call print_message('WARNING', 'System_Timer: stack overflow, name ' // trim(name)) + return + end if + + names(stack_pos) = trim(name) + +#ifdef _MPI + call current_times(cpu_t0(stack_pos), wall_t0(stack_pos), mpi_t0(stack_pos)) +#else + call current_times(cpu_t0(stack_pos), wall_t0(stack_pos)) +#endif + + if (present(time_elapsed)) time_elapsed = 0.0_dp + + else + ! Stop the most recently started timer +#ifdef _MPI + call current_times(cpu_t1, wall_t1, mpi_t1) +#else + call current_times(cpu_t1, wall_t1) +#endif + + out_name = name +#ifndef _MPI + if (present(time_elapsed)) time_elapsed = wall_t1-wall_t0(stack_pos) + if (my_do_print) then + call print("TIMER: " // out_name // " done in " // (cpu_t1-cpu_t0(stack_pos)) // & + " cpu secs, " // (wall_t1-wall_t0(stack_pos))//" wall clock secs.") + endif +#else + if (present(time_elapsed)) time_elapsed = mpi_t1-mpi_t0(stack_pos) + if (my_do_print) then + call print("TIMER: " // out_name // " done in " // (cpu_t1-cpu_t0(stack_pos)) // & + " cpu secs, " // (wall_t1-wall_t0(stack_pos))//" wall clock secs, " // & + (mpi_t1-mpi_t0(stack_pos)) // " mpi wall secs.") + endif +#endif + + stack_pos = stack_pos - 1 + if (stack_pos < 0) & + call system_abort('System_Timer: stack underflow, name ' // trim(name)) + end if + + end subroutine system_timer + + + !% Test if the file 'filename' can be accessed. + function is_file_readable(filename) + character(len=*), intent(in) :: filename + logical :: is_file_readable + + integer myunit + integer stat + + myunit=pick_up_unit() + + open(file=filename,unit=myunit,status="OLD",iostat=stat) + + if(stat == 0)then + is_file_readable = .true. + close(unit=myunit) + else + is_file_readable = .false. + end if + + end function is_file_readable + + + subroutine Stack_Initialise(this, value) + type(stack), intent(inout) :: this + integer, optional::value + + call Finalise(this) + allocate(this%val(4)) + if(present(value)) then + this%val(1) = value + this%pos = 1 + else + this%pos = 0 + end if + + end subroutine Stack_Initialise + + subroutine Stack_Finalise(this) + type(stack), intent(inout) :: this + + if (allocated(this%val)) deallocate(this%val) + + end subroutine Stack_Finalise + + subroutine Stack_push(this, val) + type(Stack), intent(inout) :: this + integer, intent(in) :: val + + integer, allocatable :: val_t(:) + + if (.not. allocated(this%val)) then + allocate(this%val(4)) + endif + + if (this%pos+1 > size(this%val)) then + allocate(val_t(size(this%val))) + val_t = this%val + deallocate(this%val) + allocate(this%val(2*size(val_t))) + this%val(1:size(val_t)) = val_t + deallocate(val_t) + endif + + this%val(this%pos+1) = val + this%pos = this%pos + 1 + + end subroutine Stack_push + + subroutine Stack_pop(this) + type(Stack), intent(inout) :: this + + if (this%pos > 0) then + this%pos = this%pos - 1 + else + call system_abort("Underflow in Stack_pop") + endif + end subroutine Stack_pop + + function stack_value(this) + type(Stack), intent(in) :: this + integer :: stack_value + + if (this%pos > 0) then + stack_value = this%val(this%pos) + else + call system_abort("Called stack_value on empty stack, pos = " // this%pos) + endif + end function stack_value + + subroutine Stack_print(this, verbosity, out) + type(Stack), intent(in) :: this + integer, intent(in), optional :: verbosity + type(inoutput), intent(in), optional :: out + + call Print("Stack:", verbosity, out) + if (allocated(this%val)) then + call Print("Stack: size " // size(this%val), verbosity, out) + call Print("Stack: val " // this%val(1:this%pos), verbosity, out) + endif + end subroutine Stack_Print + + !% Map from verbsoity codes to descriptive strings + function verbosity_to_str(val) result(str) + integer, intent(in) :: val + character(10) :: str + + select case(val) + case(PRINT_ALWAYS) + str = 'ERROR' + case(PRINT_SILENT) + str = 'SILENT' + case(PRINT_NORMAL) + str = 'NORMAL' + case(PRINT_VERBOSE) + str = 'VERBOSE' + case(PRINT_NERD) + str = 'NERD' + case(PRINT_ANALYSIS) + str = 'ANALYSIS' + end select + end function verbosity_to_str + + !% Map from descriptive verbosity names ('NORMAL', 'VERBOSE' etc.) to numbers + function verbosity_of_str(str) result(val) + character(len=*), intent(in) :: str + integer :: val + + if (trim(str) == 'ERROR') then + val = PRINT_ALWAYS + else if (trim(str) == 'SILENT') then + val = PRINT_SILENT + else if (trim(str) == 'NORMAL') then + val = PRINT_NORMAL + else if (trim(str) == 'VERBOSE') then + val = PRINT_VERBOSE + else if (trim(str) == 'NERD') then + val = PRINT_NERD + else if (trim(str) == 'ANALYSIS') then + val = PRINT_ANALYSIS + else + call system_abort("verbosity_of_str failed to understand '"//trim(str)//"'") + end if + end function verbosity_of_str + + + !% Push a value onto the verbosity stack + !% Don't ever lower the verbosity if verbosity minimum is set, + !% but always push _something_ + subroutine verbosity_push(val) + integer, intent(in) :: val + + if ((value(mainlog%verbosity_cascade_stack) == 0) .or. & + val > value(mainlog%verbosity_stack)) then + call push(mainlog%verbosity_stack, val) + else + call push(mainlog%verbosity_stack, value(mainlog%verbosity_stack)) + endif + !call print('verbosity_push now '//current_verbosity(), PRINT_ALWAYS) + end subroutine verbosity_push + + !% pop the current verbosity value off the stack + subroutine verbosity_pop() + call pop(mainlog%verbosity_stack) + !call print('verbosity_pop now '//current_verbosity(), PRINT_ALWAYS) + end subroutine verbosity_pop + + !% return the current value of verbosity + function current_verbosity() + integer :: current_verbosity + current_verbosity = value(mainlog%verbosity_stack) + end function current_verbosity + + !% push the current value + n onto the stack + subroutine verbosity_push_increment(n) + integer, intent(in), optional :: n + integer my_n + + my_n = 1 + if(present(n)) my_n = n + call verbosity_push(value(mainlog%verbosity_stack)+my_n) + end subroutine verbosity_push_increment + + !% push the current value - n onto the stack + subroutine verbosity_push_decrement(n) + integer, intent(in), optional :: n + integer my_n + + my_n = 1 + if(present(n)) my_n = n + call verbosity_push(value(mainlog%verbosity_stack)-my_n) + end subroutine verbosity_push_decrement + + !% set the minimum verbosity value, by pushing value onto + !% stack and pushing 1 on to verbosity_cascade_stack + subroutine verbosity_set_minimum(verbosity) + integer, intent(in) :: verbosity + + call push(mainlog%verbosity_cascade_stack, 1) + call verbosity_push(verbosity) + end subroutine verbosity_set_minimum + + !% unset the minimum verbosity value, by popping value from + !% stack and popping from verbosity_cascade_stack + subroutine verbosity_unset_minimum() + call verbosity_pop() + call pop(mainlog%verbosity_cascade_stack) + end subroutine verbosity_unset_minimum + + pure function optional_default_l(def, opt_val) + logical, intent(in) :: def + logical, intent(in), optional :: opt_val + logical :: optional_default_l + + if (present(opt_val)) then + optional_default_l = opt_val + else + optional_default_l = def + endif + + end function optional_default_l + + pure function optional_default_i(def, opt_val) + integer, intent(in) :: def + integer, intent(in), optional :: opt_val + integer :: optional_default_i + + if (present(opt_val)) then + optional_default_i = opt_val + else + optional_default_i = def + endif + + end function optional_default_i + + pure function optional_default_ia(def, opt_val) + integer, intent(in) :: def(:) + integer, intent(in), optional :: opt_val(size(def)) + integer :: optional_default_ia(size(def)) + + if (present(opt_val)) then + optional_default_ia = opt_val + else + optional_default_ia = def + endif + + end function optional_default_ia + + + pure function optional_default_r(def, opt_val) + real(dp), intent(in) :: def + real(dp), intent(in), optional :: opt_val + real(dp) :: optional_default_r + + if (present(opt_val)) then + optional_default_r = opt_val + else + optional_default_r = def + endif + + end function optional_default_r + + pure function optional_default_ra(def, opt_val) + real(dp), intent(in) :: def(:) + real(dp), intent(in), optional :: opt_val(size(def)) + real(dp) :: optional_default_ra(size(def)) + + if (present(opt_val)) then + optional_default_ra = opt_val + else + optional_default_ra = def + endif + + end function optional_default_ra + + + pure function optional_default_z(def, opt_val) + complex(dp), intent(in) :: def + complex(dp), intent(in), optional :: opt_val + complex(dp) :: optional_default_z + + if (present(opt_val)) then + optional_default_z = opt_val + else + optional_default_z = def + endif + + end function optional_default_z + + pure function optional_default_c(def, opt_val) + character(len=*), intent(in) :: def + character(len=*), intent(in), optional :: opt_val + character(SYSTEM_STRING_LENGTH) :: optional_default_c + + if (present(opt_val)) then + optional_default_c = opt_val + else + optional_default_c = def + endif + + end function optional_default_c + + pure function optional_default_ca(def, opt_val) + character(len=*), dimension(:), intent(in) :: def + character(len=*), dimension(:), intent(in), optional :: opt_val + character(SYSTEM_STRING_LENGTH), dimension(size(def)) :: optional_default_ca + + if (present(opt_val)) then + optional_default_ca = opt_val + else + optional_default_ca = def + endif + + end function optional_default_ca + + subroutine enable_timing() + system_do_timing = .true. + end subroutine enable_timing + + subroutine disable_timing() + system_do_timing = .false. + end subroutine disable_timing + + function get_timing() + logical :: get_timing + get_timing = system_do_timing + end function get_timing + + subroutine set_timing(do_timing) + logical :: do_timing + + system_do_timing = do_timing + end subroutine set_timing + + function get_quippy_running() + logical :: get_quippy_running + + get_quippy_running = system_quippy_running + + end function get_quippy_running + + function increase_stack(stack_size) + integer, intent(in) :: stack_size + integer :: increase_stack + + integer, external :: c_increase_stack + + increase_stack = c_increase_stack(stack_size) + end function increase_stack + + !% Abort with a useful message if an MPI routine returned an error status + subroutine abort_on_mpi_error(error_code, routine_name) + integer, intent(in) :: error_code + character(len=*), intent(in) :: routine_name + +#ifdef _MPI + + character(MPI_MAX_ERROR_STRING)::error_string + integer::error_string_length, my_error_code + + if(error_code .ne. MPI_SUCCESS) then + call MPI_ERROR_STRING(error_code, error_string, error_string_length, my_error_code) + if(my_error_code .ne. MPI_SUCCESS) then + call system_abort(trim(routine_name) // " returned with error code = " // error_code & + // ", which could not be parsed") + else + call system_abort(trim(routine_name) // " had error '" // trim(error_string) // "'") + endif + endif +#else + call system_abort("abort_on_mpi_error called with routine_name='"//trim(routine_name)//"' " // & + " error_code " // error_code // " even though MPI is off") +#endif + end subroutine abort_on_mpi_error + + + subroutine parallel_print(lines, comm, verbosity, file) + character(len=*), intent(in) :: lines(:) + integer, intent(in) :: comm + integer, intent(in), optional :: verbosity + type(inoutput), intent(inout), optional :: file + + integer i +#ifdef _MPI + + integer proc + integer mpi_stat(MPI_STATUS_SIZE) + integer, allocatable :: lengths(:) + integer :: lengths_send(2) + character, allocatable :: in_lines(:) + integer n_c, line_l, n_lines + integer err + + if (mpi_id() == 0) then +#endif + do i=1, size(lines) + call Print(trim(lines(i)), verbosity, file) + end do +#ifdef _MPI + allocate(lengths(2*mpi_n_procs())) + lengths_send(1) = size(lines) + lengths_send(2) = len(adjustr(lines(1))) + call mpi_gather(lengths_send,2,MPI_INTEGER,lengths,2,MPI_INTEGER,0,comm,err) + + do proc=1, mpi_n_procs()-1 + n_lines = lengths((proc)*2+1) + line_l = lengths((proc)*2+2) + allocate(in_lines(n_lines*line_l)) + call mpi_recv(in_lines,n_lines*line_l,MPI_CHARACTER,proc,100+proc,comm,mpi_stat,err) + do i=1, n_lines*line_l, line_l + call Print(in_lines(i:i+line_l-1), verbosity, file) + end do + deallocate(in_lines) + end do + + deallocate(lengths) + + else + line_l = len(adjustr(lines(1))) + lengths_send(1) = size(lines) + lengths_send(2) = line_l + call mpi_gather(lengths_send,2,MPI_INTEGER,lengths,2,MPI_INTEGER,0,comm,err) + n_c = line_l*size(lines) + call mpi_send(lines,n_c,MPI_CHARACTER,0,100+mpi_id(),comm,err) + endif +#endif + + end subroutine parallel_print + + subroutine ALLOC_TRACE(str,amt) + character(len=*), intent(in) :: str + integer, intent(in) :: amt + + if (trace_memory) then + traced_memory = traced_memory + amt + call print("TR_ALLOCATE " // str // " " // amt // " " // traced_memory) + endif + end subroutine ALLOC_TRACE + + subroutine DEALLOC_TRACE(str,amt) + character(len=*), intent(in) :: str + integer, intent(in) :: amt + if (trace_memory) then + traced_memory = traced_memory - amt + call print("TR_ALLOCATE " // str // " " // (-amt) // " " // traced_memory) + endif + end subroutine DEALLOC_TRACE + +#ifdef _OPENMP + function system_omp_get_num_threads() + use omp_lib + integer :: system_omp_get_num_threads + +!$omp parallel +!$omp master + system_omp_get_num_threads = omp_get_num_threads() +!$omp end master +!$omp end parallel + end function system_omp_get_num_threads + + subroutine system_omp_set_num_threads(threads) + use omp_lib + integer, intent(in) :: threads + + call omp_set_num_threads(threads) + end subroutine system_omp_set_num_threads +#endif + + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X These functions provide low-level access to some MPI global variables +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Return this processes' MPI ID + pure function mpi_id() result (id) + integer::id + id = mpi_myid + end function mpi_id + + !% Return the total number of MPI processes. + pure function mpi_n_procs() result (n) + integer::n + n = mpi_n + end function mpi_n_procs + + function reference_true() + logical :: reference_true + + reference_true = .true. + + end function reference_true + + function reference_false() + logical :: reference_false + + reference_false = .false. + + end function reference_false + +!% String to character array +function s2a(s) result(a) + character(len=*), intent(in) :: s + character(len=1), dimension(len(s)) :: a + + integer i + + do i=1,len(s) + a(i) = s(i:i) + end do + +end function s2a + +!% Character array to string +function a2s(a) result(s) + character(len=1), dimension(:), intent(in) :: a + character(len=size(a)) :: s + + integer i + + do i=1,size(a) + s(i:i) = a(i) + end do + +end function a2s + +!% String to padded character array of length l +function pad(s,l) result(a) + character(len=*), intent(in) :: s + integer, intent(in) :: l + character(len=1), dimension(l) :: a + + integer i + + a = ' ' + do i=1,min(len(s),size(a)) + a(i) = s(i:i) + end do +end function pad + + function make_run_directory(basename, force_run_dir_i, run_dir_i, error) result(dir) + character(len=*), optional :: basename + integer, intent(in), optional :: force_run_dir_i + integer, intent(out), optional :: run_dir_i + integer, intent(out), optional :: error + character(len=SYSTEM_STRING_LENGTH) :: dir + + integer i + character(len=SYSTEM_STRING_LENGTH) :: use_basename + integer :: use_force_run_dir_i + + logical :: exists + integer stat + + INIT_ERROR(error) + + use_force_run_dir_i = optional_default(-1, force_run_dir_i) + use_basename = optional_default("run", basename) + + if (use_force_run_dir_i >= 0) then + i = use_force_run_dir_i + dir = trim(use_basename)//"_"//i + call system_command("bash -c '[ -d "//trim(dir)//" ]'", status=stat) + if (stat /= 0) then + RAISE_ERROR("make_run_directory got force_run_dir_i="//use_force_run_dir_i//" but "//trim(dir)//" doesn't exist or isn't a directory", error) + endif + else + exists = .true. + i = 0 + do while (exists) + i = i + 1 + dir = trim(use_basename)//"_"//i + call system_command("bash -c '[ -e "//trim(dir)//" ]'", status=stat) + exists = (stat == 0) + end do + call system_command("mkdir "//trim(dir), status=stat) + if (stat /= 0) then + RAISE_ERROR("Failed to mkdir "//trim(dir)//" status " // stat, error) + endif + endif + + if (present(run_dir_i)) run_dir_i = i + + end function make_run_directory + + function link_run_directory(sourcename, basename, run_dir_i, error) result(dir) + character(len=*), intent(in) :: sourcename + character(len=*), optional :: basename + integer, intent(out), optional :: run_dir_i + integer, intent(out), optional :: error + character(len=SYSTEM_STRING_LENGTH) :: dir + + integer i + character(len=SYSTEM_STRING_LENGTH) :: use_basename + + logical :: exists + integer stat + + INIT_ERROR(error) + + use_basename = optional_default("run", basename) + + exists = .true. + i = 0 + do while (exists) + i = i + 1 + dir = trim(use_basename)//"_"//i + call system_command("bash -c '[ -e "//trim(dir)//" ]'", status=stat) + exists = (stat == 0) + end do + call system_command("ln -s "//trim(sourcename)//" "//trim(dir), status=stat) + if (stat /= 0) then + RAISE_ERROR("Failed to link "//trim(dir)//" status " // stat, error) + endif + + if (present(run_dir_i)) run_dir_i = i + + end function link_run_directory + + function current_version() + character(len=SYSTEM_STRING_LENGTH) :: current_version + +#ifdef GIT_VERSION + current_version = trim(GIT_VERSION) +#else + current_version = "" +#endif + + endfunction current_version + + pure function linebreak_string_length(str, line_len) result(length) + character(len=*), intent(in) :: str + integer, intent(in) :: line_len + integer :: length + + length = len_trim(str)+2*len_trim(str)/line_len+3 + + end function linebreak_string_length + + function linebreak_string(str, line_len) result(lb_str) + character(len=*), intent(in) :: str + integer, intent(in) :: line_len + + character(len=linebreak_string_length(str, line_len)) :: lb_str + + logical :: word_break + integer :: copy_len, last_space + character(len=len(lb_str)) :: tmp_str + + lb_str="" + tmp_str=trim(str) + do while (len_trim(tmp_str) > 0) + copy_len = min(len_trim(tmp_str),line_len) + if (tmp_str(copy_len:copy_len) /= " ") then + last_space=scan(tmp_str(1:copy_len), " ", .true.) + if ( last_space > 0 .and. (len_trim(tmp_str(1:copy_len)) - last_space) < 4) then + copy_len=last_space + endif + endif + + if (len_trim(lb_str) > 0) then ! we already have some text, add newline before concatenating next line + lb_str = trim(lb_str)//quip_new_line//trim(tmp_str(1:copy_len)) + else ! just concatenate next line + lb_str = trim(tmp_str(1:copy_len)) + endif + ! if we broke in mid word, add "-" + word_break = .true. + if (tmp_str(copy_len:copy_len) == " ") then ! we broke right after a space, so no wordbreak + word_break = .false. + else ! we broke after a character + if (copy_len < len_trim(tmp_str)) then ! there's another character after this one, check if it's a space + if (tmp_str(copy_len+1:copy_len+1) == " ") then + word_break = .false. + endif + else ! we broke after the last character + word_break = .false. + endif + endif + if (word_break) lb_str = trim(lb_str)//"-" + tmp_str(1:copy_len) = "" + tmp_str=adjustl(tmp_str) + end do + + end function linebreak_string + + subroutine mem_info_i(total_mem_i, free_mem_i) + integer(idp), intent(out) :: total_mem_i, free_mem_i + real(8) :: total_mem_r, free_mem_r + call mem_info(total_mem_r, free_mem_r) + total_mem_i = int(total_mem_r, idp) + free_mem_i = int(free_mem_r, idp) + end subroutine mem_info_i + + subroutine mem_info_r(total_mem, free_mem) + real(8), intent(out) :: total_mem, free_mem + call c_mem_info(total_mem, free_mem) + end subroutine mem_info_r + + subroutine print_mem_info(file) + type(inoutput), intent(in), optional :: file + + real(8) :: total_mem, free_mem + + call mem_info(total_mem, free_mem) + + call print('TOTAL MEMORY = '//total_mem/1.0e9_dp//' GB', file=file) + call print('FREE MEMORY = '//free_mem/1.0e9_dp//' GB', file=file) + + endsubroutine print_mem_info + + subroutine wait_for_file_to_exist(filename, max_wait_time, cycle_time, error) + character(len=*) filename + real(dp) :: max_wait_time + real(dp), optional :: cycle_time + integer, intent(out), optional :: error + + real(dp) :: total_wait_time, use_cycle_time + integer :: usleep_cycle_time + logical :: file_exists + + INIT_ERROR(error) + + use_cycle_time = optional_default(0.1_dp, cycle_time) + usleep_cycle_time = int(use_cycle_time*1000000) + + inquire(file=filename, exist=file_exists) + total_wait_time = 0.0_dp + do while (.not. file_exists) + call fusleep(usleep_cycle_time) + total_wait_time = total_wait_time + use_cycle_time + inquire(file=filename, exist=file_exists) + if (.not. file_exists .and. total_wait_time > max_wait_time) then + RAISE_ERROR("error waiting too long for '"//trim(filename)//"' to exist", error) + endif + end do + + end subroutine wait_for_file_to_exist + + !% Convert a word to upper case + function upper_case(word) + character(*) , intent(in) :: word + character(len(word)) :: upper_case + + integer :: i,ic,nlen + + nlen = len(word) + do i=1,nlen + ic = ichar(word(i:i)) + if (ic >= 97 .and. ic <= 122) then + upper_case(i:i) = char(ic-32) + else + upper_case(i:i) = char(ic) + end if + end do + end function upper_case + + !% Convert a word to lower case + pure function lower_case(word) + character(*) , intent(in) :: word + character(len(word)) :: lower_case + + integer :: i,ic,nlen + + nlen = len(word) + do i=1,nlen + ic = ichar(word(i:i)) + if (ic >= 65 .and. ic <= 90) then + lower_case(i:i) = char(ic+32) + else + lower_case(i:i) = char(ic) + end if + end do + end function lower_case + + pure function replace(string, search, substitute) result(res) + character(len=*), intent(in) :: string + character(len=1), intent(in) :: search, substitute + character(len=len(string)) :: res + + integer :: i + + i = 1 + do i = 1, len(string) + if (string(i:i) == search) then + res(i:i) = substitute + else + res(i:i) = string(i:i) + end if + end do + end function replace + + !% Print a progress bar + subroutine progress(total,current, name) + integer, intent(in) :: total, current + character(len=*), intent(in) :: name + + integer :: current_percent, k + + character(len=17) :: bar + + bar="???% | |" + + if(total >= current) then + current_percent = ceiling( 100.0_dp * real(current,dp) / real(total,dp) ) + + write(unit=bar(1:3),fmt="(i3)") current_percent + + do k = 1, current_percent / 10 + bar(6+k:6+k)="*" + enddo + ! print the progress bar. + write(unit=mainlog%unit,fmt="(a1,a,$)") char(13), trim(name) // " " // bar + else + write(unit=mainlog%unit,fmt=*) + endif + + end subroutine progress + + !% Print a progress bar with an estimate of time to completion + !% based on the elapsed time so far + subroutine progress_timer(total, current, name, elapsed_seconds) + integer, intent(in) :: total, current + character(len=*), intent(in) :: name + real(dp), intent(in) :: elapsed_seconds + + integer :: current_percent, k + real(dp) :: elapsed_time, estimated_time + character(len=1) :: time_units + + character(len=27) :: bar + + bar="???% | |" + + if(total >= current) then + current_percent = ceiling( 100.0_dp * real(current,dp) / real(total,dp) ) + estimated_time = elapsed_seconds * real(total,dp) / real(current,dp) + + write(unit=bar(1:3),fmt="(i3)") current_percent + + ! fill the progress bar + do k = 1, current_percent / 5 + bar(6+k:6+k)="*" + enddo + ! convert time to readable units + if (estimated_time / 60.0_dp > 2.0_dp) then + if (estimated_time / 3600.0_dp > 2.0_dp) then + if (estimated_time / 86400.0_dp > 3.0_dp) then + elapsed_time = elapsed_seconds / 86400.0_dp + estimated_time = estimated_time / 86400.0_dp + time_units = 'd' + else + elapsed_time = elapsed_seconds / 3600.0_dp + estimated_time = estimated_time / 3600.0_dp + time_units = 'h' + endif + else + elapsed_time = elapsed_seconds / 60.0_dp + estimated_time = estimated_time / 60.0_dp + time_units = 'm' + endif + else + elapsed_time = elapsed_seconds + time_units = 's' + endif + + ! print the progress bar. + write(unit=mainlog%unit,fmt="(a1,a,f5.1,a,f5.1,a)",advance="no") char(13), & + trim(name) // " " // bar // " ", & + elapsed_time, " / ", estimated_time, " " // time_units + else + write(unit=mainlog%unit,fmt=*) + endif + + end subroutine progress_timer + + function increase_to_multiple(a, m) result(res) + integer, intent(in) :: a, m + integer :: res + res = (a / m) * m + if (res < a) res = res + m + end function increase_to_multiple + + !% get indices of unique array elements and references + !% to these indices for each element of the array + subroutine get_uniqs_refs_char1(array, uniqs, refs, lower_bound) + character(*), intent(in) :: array(lower_bound:) + integer, intent(out), allocatable :: uniqs(:) + integer, intent(out), allocatable :: refs(:) + integer, intent(in) :: lower_bound + + integer :: r, u, n_vals + integer :: lb, ub, nb + integer, allocatable :: vals(:) + + lb = lbound(array, 1) + ub = ubound(array, 1) + allocate(vals(lb:ub)) + allocate(refs(lb:ub)) + + n_vals = 0 + do_refs: do r = lb, ub + nb = n_vals + lb - 1 + do u = nb, lb, -1 ! assuming similar neighbours + if (array(r) == array(vals(u))) then + refs(r) = u + cycle do_refs + end if + end do + refs(r) = nb + 1 + vals(refs(r)) = r + n_vals = n_vals + 1 + end do do_refs + + nb = n_vals + lb - 1 + allocate(uniqs(lb:nb)) + uniqs = vals(lb:nb) + end subroutine get_uniqs_refs_char1 + + function join_char1(array, sep) result(res) + character(*), intent(in) :: array(:) + character(*), intent(in) :: sep + character(:), allocatable :: res + + integer :: i, o, l_res, l_as + + l_as = len(array) + len(sep) + l_res = l_as * size(array) - len(sep) + allocate(character(l_res) :: res) + o = 0 + do i = lbound(array, 1), ubound(array, 1) - 1 + res(o+1:o+l_as) = array(i) // sep + o = o + l_as + end do + res(o+1:) = array(ubound(array, 1)) + end function join_char1 + +end module system_module diff --git a/src/libAtoms/Table.F90 b/src/libAtoms/Table.F90 new file mode 100644 index 0000000000..afa4bb337e --- /dev/null +++ b/src/libAtoms/Table.F90 @@ -0,0 +1,2134 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Table module +!X +!% A 'Table' is an extensible 2D array of integers, reals, strings and logicals. +!% The lengths of all rows are the same and the number of rows will grow and shrink +!% as datais appended or deleted. Extra columns can also be appended, although this +!% is envisaged to be required less often. Any of the number of integers, +!% number of reals, number of strings and number of logicals can be zero +!% +!% Integers are referenced by 'table%int' +!% +!% Reals are referenced by 'table%real' +!% +!% Strings are referenced by 'table%str' +!% +!% Logicals are referenced by 'table%logical' +!% +!% Appending to the table is through the 'append' interface. +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module table_module + use error_module + use system_module + use linearalgebra_module + use mpi_context_module + use dictionary_module + implicit none + private + + public :: table, allocate, initialise, finalise, print, set_increment, append, find, table_string_length + public :: wipe, delete, int_part, real_part, logical_part, str_part, sort, search, select, int_subtable, insert, delete_multiple + public :: append_column, subtable, remove_columns + + integer, parameter, private :: DEFAULT_TABLE_LENGTH = 100 + integer, parameter, private :: DEFAULT_TABLE_INCREMENT = 1000 + + integer, parameter :: TABLE_STRING_LENGTH = 10 + +#ifdef DEBUG + integer :: table_realloc_count = 0 +#endif + + type Table + integer,allocatable, dimension(:,:) :: int !% (intsize,N) array of integer data + real(dp),allocatable, dimension(:,:) :: real !% (realsize,N) array of real data + character(TABLE_STRING_LENGTH), allocatable, dimension(:,:) :: str !% (strsize,N) array of string data + logical, allocatable, dimension(:,:) :: logical !% (logicalsize,N) array of logical data + integer::increment = DEFAULT_TABLE_INCREMENT !% How many rows to grow the table by on reallocation (default 1000) + integer::max_length = 0 !% Initial maximum length of the table before the first reallocation (default 100) + integer::intsize = 0 !% Number of integer columns + integer::realsize = 0 !% Number of real columns + integer::strsize = 0 !% Number of string columns + integer::logicalsize = 0 !% Number of logical columns + integer::N=0 !% Number of rows + end type Table + + !% Allocate a 'Table'. When allocating a table, you can + !% optionally specify the number of integer and real columns and the + !% initial amount of space to allocate ('max_length'). If a table is + !% unallocated when append is called for the first time it will be + !% allocated accordingly. + interface allocate + module procedure table_allocate + end interface allocate + + interface initialise + module procedure table_allocate + end interface + + !% Finalise this table. + interface finalise + module procedure table_finalise + end interface finalise + + !% Change the increment for this table. + interface set_increment + module procedure table_set_increment + end interface set_increment + +! This overriden interface causes seg faults on Tru64 unix, and does +! not seem to be necessary with ifort9, sun f95 or HP f95 so it's +! been removed for now. + +!!$ interface assignment(=) +!!$ module procedure table_assign_table +!!$ end interface + + + !% Append rows to a table. Overloaded to be able to append single elements, + !% arrays or other tables. + interface append + module procedure table_append_row_or_arrays, table_append_table + module procedure table_append_int_element, table_append_real_element + module procedure table_append_str_element, table_append_logical_element + module procedure table_append_int_element_and_real_element + module procedure table_append_int_row_real_element + module procedure table_append_int_element_real_row + module procedure table_append_int_array, table_append_real_array + module procedure table_append_str_array, table_append_logical_array + end interface append + + !% Append 1 or more columns to a table. Overloaded to be able to append + !% a scalar, 1-D array (must match N rows), or other tables (must match N rows) + interface append_column + module procedure table_append_col_i, table_append_col_i_a + module procedure table_append_col_r, table_append_col_r_a + module procedure table_append_col_s, table_append_col_s_a + module procedure table_append_col_l, table_append_col_l_a + module procedure table_append_col_table + end interface append_column + + !% remove a range of columns from a table's int or real parts + interface remove_columns + module procedure table_remove_columns + end interface remove_columns + + !% insert a row at a given position + interface insert + module procedure table_insert + end interface insert + + !% Search the integer part of a table for a given element or array. + interface find + module procedure table_find_element, table_find_row + end interface find + + !% Sort a table according to its int part + interface sort + module procedure table_sort + end interface sort + + !% Do a binary search (faster than find) on a pre-sorted table + interface search + module procedure table_search + end interface search + + !% Print this table to the mainlog or to an inoutput object. + interface print + module procedure table_print, table_print_mainlog + end interface print + + !% Utility function to return one or more columns from the integer part of a table. + !% Since this is a function the array may be returned on the stack, so be careful + !% when working with large tables --- the same goes for the 'real_part' + !% interface below. + interface int_part + module procedure table_int_part, table_int_column, table_int_columns + end interface int_part + + !% Utility function to return one or more columns from the real part of a table. + interface real_part + module procedure table_real_part, table_real_column, table_real_columns + end interface real_part + + interface str_part + module procedure table_str_part, table_str_column, table_str_columns + end interface str_part + + interface logical_part + module procedure table_logical_part, table_logical_column, table_logical_columns + end interface logical_part + + !% Delete a row by index or by value. If by value then the match + !% is made by the integer part of the table. The last row is copied + !% over the row to be deleted, so the order of rows is not maintained. + interface delete + module procedure table_record_delete_by_index + module procedure table_record_delete_by_value + end interface delete + + !% Delete multiple rows from a Table. Beware, the order of rows + !% is not maintained. + interface delete_multiple + module procedure table_record_delete_multiple + end interface delete_multiple + + !% Clear this table, but keep the allocation. + interface wipe + module procedure table_wipe + end interface wipe + + !% Zero all parts of this table. + interface zero + module procedure table_zero + end interface zero + + private::rms_diff_list + interface rms_diff + module procedure rms_diff_list + end interface + + !% Select certains rows from a table based on a mask + private::table_select + interface select + module procedure table_select + end interface select + + private :: table_bcast + interface bcast + module procedure table_bcast + end interface + + private :: table_copy_entry + interface copy_entry + module procedure table_copy_entry + endinterface copy_entry + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! general functions used to allocate and deallocate tables + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + ! Table_Allocate: Initialises a Table object ready for use. + subroutine table_allocate(this,Nint,Nreal,Nstr,Nlogical,max_length,error) + + type(table), intent(inout) :: this + integer, optional, intent(in) :: Nint !% Number of integer columns + integer, optional, intent(in) :: Nreal !% Number of real columns + integer, optional, intent(in) :: Nstr !% Number of string columns + integer, optional, intent(in) :: Nlogical !% Number of logical columns + integer, optional, intent(in) :: max_length !% Number of rows to initially allocate + type(table) :: temp + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if (present(Nint) .or. present(Nreal) .or. present(Nstr) .or. present(Nlogical)) then + + ! Initialise the table to the given dimensions + + call finalise(this) + this%max_length = DEFAULT_TABLE_LENGTH + + !If max length is present then we have info about how big the table + !is likely to be... so set the increment accordingly + if (present(max_length)) then + this%max_length = max_length + this%increment = max(1,max_length/10) + end if + + ! Beware, interface change! + if (.not. present(Nint) .or. .not. present(Nreal) .or. & + .not. present(Nstr) .or. .not. present(Nlogical)) then + call print('WARNING: The interface to table_allocate (allocate(table,...) and', PRINT_ALWAYS) + call print(' initialise(table,...)) has changed!', PRINT_ALWAYS) + call print(' from call allocate(table,Nint,Nreal,length)', PRINT_ALWAYS) + call print(' to call allocate(table,Nint,Nreal,Nstr,Nlogical,length)', PRINT_ALWAYS) + call print('Please update your code!', PRINT_ALWAYS) + RAISE_ERROR('table_allocate: if one of Nint, Nreal, Nstr, Nlogical is present then all must be!', error) + end if + + if (present(Nint)) then + this%intsize = max(Nint,0) + if (this%intsize > 0) allocate(this%int(this%intsize,this%max_length)) + else + this%intsize = 0 + end if + + if (present(Nreal)) then + this%realsize = max(Nreal,0) + if (this%realsize > 0) allocate(this%real(this%realsize,this%max_length)) + else + this%realsize = 0 + end if + + if (present(Nstr)) then + this%strsize = max(Nstr,0) + if (this%strsize > 0) allocate(this%str(this%strsize,this%max_length)) + else + this%strsize = 0 + end if + + if (present(Nlogical)) then + this%logicalsize = max(Nlogical,0) + if (this%logicalsize > 0) allocate(this%logical(this%logicalsize,this%max_length)) + else + this%logicalsize = 0 + end if + else + + ! Change the length of the table, keeping the data + temp = this +! DODGINESS: the value of max_length sometimes changes after the call finalise(this) line +! if (present(max_length)) write(*,*) 'max_length=',max_length + call finalise(this) +! if (present(max_length)) write(*,*) 'max_length=',max_length + this%max_length = temp%N + if (present(max_length)) then + this%max_length = max_length + this%increment = max(1,max_length/10) + end if + if (temp%N > this%max_length) then + RAISE_ERROR('Table_Allocate: Max_Length is smaller than number of rows', error) + endif + + if (temp%intsize > 0) then + this%intsize = temp%intsize + allocate(this%int(this%intsize,this%max_length)) + this%int(:,1:temp%N) = temp%int(:,1:temp%N) + end if + + if (temp%realsize > 0) then + this%realsize = temp%realsize + allocate(this%real(this%realsize,this%max_length)) + this%real(:,1:temp%N) = temp%real(:,1:temp%N) + end if + + if (temp%strsize > 0) then + this%strsize = temp%strsize + allocate(this%str(this%strsize,this%max_length)) + this%str(:,1:temp%N) = temp%str(:,1:temp%N) + end if + + if (temp%logicalsize > 0) then + this%logicalsize = temp%logicalsize + allocate(this%logical(this%logicalsize,this%max_length)) + this%logical(:,1:temp%N) = temp%logical(:,1:temp%N) + end if + + this%N = temp%N + + call finalise(temp) + + endif + + end subroutine table_allocate + + subroutine table_set_increment(this,increment) + + type(table), intent(inout) :: this + integer, intent(in) :: increment + + if (increment < 1) call system_abort('Table_Set_Increment: Increment must be at least 1') + + this%increment = increment + + end subroutine table_set_increment + + !% Reduce the allocation if we can, still leaving a bit at the end, not more than 'this%increment'. + subroutine reduce_allocation(this) + type(table), intent(inout) :: this + integer::nblocs + + if(this%N.gt.(this%max_length - this%increment)) return + + nblocs = this%N / this%increment + 2 + call table_allocate(this,max_length=nblocs*this%increment) + end subroutine reduce_allocation + + + ! destructor + subroutine table_finalise(this) + type(table), intent(inout)::this + + if(allocated(this%int)) deallocate(this%int) + if(allocated(this%real)) deallocate(this%real) + if(allocated(this%str)) deallocate(this%str) + if(allocated(this%logical)) deallocate(this%logical) + + this%max_length = 0 + this%N = 0 + this%intsize = 0 + this%realsize = 0 + this%strsize = 0 + this%logicalsize = 0 + + end subroutine table_finalise + + ! Zero all parts of this table. + subroutine table_zero(this) + type(table), intent(inout) :: this + if(allocated(this%int)) this%int = 0 + if(allocated(this%real)) this%real = 0.0_dp + if(allocated(this%str)) this%str = repeat(' ',TABLE_STRING_LENGTH) + if(allocated(this%logical)) this%logical = .false. + end subroutine table_zero + + !% OMIT + subroutine table_assign_table(this,other) + type(table), intent(inout) ::this + type(table), intent(in) ::other + call finalise(this) + call table_allocate(this,other%intsize,other%realsize,& + other%strsize,other%logicalsize,other%N) !optimised for temporary copies + this%N=other%N + this%increment=other%increment + if(allocated(other%int)) this%int(:,1:this%N) = other%int(:,1:this%N) + if(allocated(other%real)) this%real(:,1:this%N) = other%real(:,1:this%N) + if(allocated(other%str)) this%str(:,1:this%N) = other%str(:,1:this%N) + if(allocated(other%logical)) this%logical(:,1:this%N) = other%logical(:,1:this%N) + + end subroutine table_assign_table + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! appending to tables + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine table_append_row_or_arrays(this,intpart,realpart,strpart,logicalpart, & + intpart_2D,realpart_2D,strpart_2D,logicalpart_2D, blank_rows) + + type(Table), intent(inout) :: this + integer, intent(in), optional :: intpart(:) + real(dp), intent(in), optional :: realpart(:) + character(TABLE_STRING_LENGTH), intent(in), optional :: strpart(:) + logical, intent(in), optional :: logicalpart(:) + integer, dimension(:,:), intent(in),optional :: intpart_2D + real(dp), dimension(:,:), intent(in),optional :: realpart_2D + character(TABLE_STRING_LENGTH), dimension(:,:), intent(in),optional :: strpart_2D + logical, dimension(:,:), intent(in), optional :: logicalpart_2D + integer, optional, intent(in) :: blank_rows + + logical :: got1D, got2D + + got1D = present(intpart) .or. present(realpart) .or. & + present(strpart) .or. present(logicalpart) + got2D = present(intpart_2D) .or. present(realpart_2D) .or. & + present(strpart_2D) .or. present(logicalpart_2D) + + if (present(blank_rows)) then + if(allocated(this%int) .or. allocated(this%real) .or. & + allocated(this%str) .or. allocated(this%logical)) then + + if(this%N+blank_rows > this%max_length) then ! we need more memory + call table_allocate(this,max_length=this%N+blank_rows) + end if + this%N = this%N + blank_rows + return + else + call system_abort('table_append_row_or_arrays: blank_rows can only be used with already allocated tables') + end if + else + if (.not. got1D .and. .not. got2D) & + call system_abort('table_append_row_or_arrays: nothing to append') + + if (got1D .and. got2D) & + call system_abort("table_append_row_or_arrays: can't mix 1D and 2D arrays") + + if (got1D) call table_append_row(this,intpart,realpart,strpart,logicalpart) + if (got2D) call table_append_arrays(this,intpart_2d,realpart_2d,strpart_2d,logicalpart_2d) + end if + + end subroutine table_append_row_or_arrays + + ! append single records + ! unless all sizes are 1 we do multiple appends + subroutine table_append_row(this,intpart,realpart,strpart,logicalpart, error) + type(table), intent(inout) :: this + integer, intent(in), optional :: intpart(:) + real(dp), intent(in), optional :: realpart(:) + character(TABLE_STRING_LENGTH), intent(in), optional :: strpart(:) + logical, intent(in), optional :: logicalpart(:) + integer, intent(out), optional::error + + integer :: intsize, realsize, strsize, logicalsize + + integer, allocatable :: use_intpart(:) + real(dp), allocatable :: use_realpart(:) + character(TABLE_STRING_LENGTH), allocatable :: use_strpart(:) + logical, allocatable :: use_logicalpart(:) + + INIT_ERROR(error) + + intsize = 0 + realsize = 0 + strsize = 0 + logicalsize = 0 + if (present(intpart)) intsize = size(intpart) + if (present(realpart)) realsize = size(realpart) + if (present(strpart)) strsize = size(strpart) + if (present(logicalpart)) logicalsize = size(logicalpart) + + !Special cases: if the table has size 1 + !and the vector length is > 1 then call append_arrays + if ((this%intsize == 1 .and. intsize > 1) .or. & + (this%realsize == 1 .and. realsize > 1) .or. & + (this%strsize == 1 .and. strsize > 1) .or. & + (this%logicalsize == 1 .and. logicalsize > 1)) then + + ! Make local copies so we can reshape + allocate(use_intpart(intsize)) + if (present(intpart)) use_intpart = intpart + + allocate(use_realpart(realsize)) + if (present(realpart)) use_realpart = realpart + + allocate(use_strpart(strsize)) + if (present(strpart)) use_strpart = strpart + + allocate(use_logicalpart(logicalsize)) + if (present(logicalpart)) use_logicalpart = logicalpart + + call table_append_arrays(this, reshape(use_intpart, (/1,intsize/)), & + reshape(use_realpart, (/1,realsize/)), & + reshape(use_strpart, (/1,strsize/)), & + reshape(use_logicalpart, (/1,logicalsize/))) + + deallocate(use_intpart, use_realpart, use_strpart, use_logicalpart) + + return + end if + + if(allocated(this%int) .or. allocated(this%real) .or. & + allocated(this%str) .or. allocated(this%logical)) then + if(this%N+1 > this%max_length) then ! we need more memory +#ifdef DEBUG + !$omp atomic + table_realloc_count = table_realloc_count + 1 +#endif + call table_allocate(this,max_length=this%N+this%increment) + end if + else +! call print('allocating '//intsize//' '//realsize//' '//strsize//' '//logicalsize) + call table_allocate(this,intsize,realsize,strsize,logicalsize) + end if + + if (this%intsize > 0) then + if(present(intpart)) then + if(size(this%int,1).ne.size(intpart)) then + RAISE_ERROR(('table_append_row: appendix int part has the wrong size, '//size(intpart)//', should be '//size(this%int,1)//'. intpart: '), error) + end if + this%int(:,this%N+1) = intpart + else + ! use default value of zero + this%int(:,this%N+1) = 0 + end if + end if + + if (this%realsize > 0) then + if(present(realpart)) then + if(size(this%real,1).ne.size(realpart)) & + call system_abort('table_append_row: appendix real part has the wrong size') + this%real(:,this%N+1)=realpart + else + ! default to zero + this%real(:,this%N+1) = 0.0_dp + end if + end if + + if (this%strsize > 0) then + if(present(strpart)) then + if(size(this%str,1).ne.size(strpart)) & + call system_abort('table_append_row: appendix str part has the wrong size') + this%str(:,this%N+1)=strpart + else + ! default to empty string + this%str(:,this%N+1) = repeat(' ',TABLE_STRING_LENGTH) + end if + end if + + if (this%logicalsize > 0) then + if(present(logicalpart)) then + if(size(this%logical,1).ne.size(logicalpart)) & + call system_abort('table_append_row: appendix logical part has the wrong size') + this%logical(:,this%N+1)=logicalpart + else + ! default to false + this%logical(:,this%N+1) = .false. + end if + end if + + ! Now increment the number of valid table rows + this%N = this%N+1 + end subroutine table_append_row + + + !Appending 2D arrays to tables + + subroutine table_append_int_array(this,intpart) + type(Table), intent(inout) :: this + integer, dimension(:,:), intent(in) :: intpart + + call table_append_arrays(this,intpart=intpart) + + end subroutine table_append_int_array + + subroutine table_append_real_array(this,realpart) + type(Table), intent(inout) :: this + real(dp), dimension(:,:), intent(in) :: realpart + + call table_append_arrays(this,realpart=realpart) + + end subroutine table_append_real_array + + + subroutine table_append_str_array(this,strpart) + type(Table), intent(inout) :: this + character(TABLE_STRING_LENGTH), dimension(:,:), intent(in) :: strpart + + call table_append_arrays(this,strpart=strpart) + + end subroutine table_append_str_array + + + subroutine table_append_logical_array(this,logicalpart) + type(Table), intent(inout) :: this + logical, dimension(:,:), intent(in) :: logicalpart + call table_append_arrays(this,logicalpart=logicalpart) + + end subroutine table_append_logical_array + + + subroutine table_append_arrays(this,intpart,realpart,strpart,logicalpart) + type(Table), intent(inout) :: this + integer, dimension(:,:), intent(in),optional :: intpart + real(dp), dimension(:,:), intent(in),optional :: realpart + character(TABLE_STRING_LENGTH), dimension(:,:), intent(in),optional :: strpart + logical, dimension(:,:), intent(in), optional :: logicalpart + + !locals + integer :: datasize(4), datalength(4), thissize(4), length, i + + datasize(1) = 0 + datalength(1) = 0 + if (present(intpart)) then + datasize(1) = size(intpart,1) + datalength(1) = size(intpart,2) + end if + + datasize(2) = 0 + datalength(2) = 0 + if (present(realpart)) then + datasize(2) = size(realpart,1) + datalength(2) = size(realpart,2) + end if + + datasize(3) = 0 + datalength(3) = 0 + if (present(strpart)) then + datasize(3) = size(strpart,1) + datalength(3) = size(strpart,2) + end if + + datasize(4) = 0 + datalength(4) = 0 + if (present(logicalpart)) then + datasize(4) = size(logicalpart,1) + datalength(4) = size(logicalpart,2) + end if + + if (all(datasize == 0)) & + call system_abort('table_append_arrays: all array widths are zero!') + length = maxval(datalength) + if (length == 0) & + call system_abort('table_append_arrays: all array lengths are zero!') + + ! Check non zero lengths match + do i=1,4 + if (datalength(i) == 0) cycle + if (datalength(i) /= length) then + call print(datalength) + call system_abort('table_append_arrays: lengths mismatched between arrays') + end if + end do + + thissize = (/this%intsize,this%realsize,this%strsize,this%logicalsize/) + + !Check if the table has been allocated and allocate if not, or check for correct size + if (all(thissize == 0)) then + call table_allocate(this,datasize(1),datasize(2),datasize(3),datasize(4),length) + else + ! Check non zero length arrays are correct size + do i=1,4 + if (datalength(i) == 0) cycle + if (datasize(i) /= thissize(i)) & + call system_abort('table_append_arrays: Input data sizes do not match table sizes') + end do + + !Table already allocated. See if long enough to hold the extra data + if (this%N+length > this%max_length) call table_allocate(this,max_length = this%N+length) + endif + + !Actually do the append + if (datasize(1) > 0 .and. datalength(1) > 0) this%int(:,this%N+1:this%N+length) = intpart + if (datasize(2) > 0 .and. datalength(2) > 0) this%real(:,this%N+1:this%N+length) = realpart + if (datasize(3) > 0 .and. datalength(3) > 0) this%str(:,this%N+1:this%N+length) = strpart + if (datasize(4) > 0 .and. datalength(4) > 0) this%logical(:,this%N+1:this%N+length) = logicalpart + + this%N = this%N + length + + end subroutine table_append_arrays + + + subroutine table_append_int_element(this,intpart, error) + type(Table), intent(inout) :: this + integer, intent(in) :: intpart + integer, intent(out), optional :: error + + INIT_ERROR(error) + + call table_append_row(this,(/intpart/), error=error) + PASS_ERROR(error) + end subroutine table_append_int_element + + subroutine table_append_real_element(this,realpart) + type(Table), intent(inout) :: this + real(dp), intent(in) :: realpart + + call table_append_row(this,realpart=(/realpart/)) + end subroutine table_append_real_element + + subroutine table_append_str_element(this,strpart,error) + type(Table), intent(inout) :: this + character(*) :: strpart + integer, intent(out), optional :: error + + character(TABLE_STRING_LENGTH) :: loc_strpart + + INIT_ERROR(error) + + if (len(strpart) > TABLE_STRING_LENGTH) then + RAISE_ERROR("table_append_str_element: Length of string '" // strpart // "' (" // len(strpart) // ") exceeds maximum length for strings in a table (" // TABLE_STRING_LENGTH // ").", error) + endif + + loc_strpart = strpart + + call table_append_row(this,strpart=(/loc_strpart/)) + end subroutine table_append_str_element + + subroutine table_append_logical_element(this,logicalpart) + type(Table), intent(inout) :: this + logical, intent(in) :: logicalpart + + call table_append_row(this,logicalpart=(/logicalpart/)) + + end subroutine table_append_logical_element + + subroutine table_append_int_element_and_real_element(this,intpart,realpart) + type(Table), intent(inout) :: this + integer, intent(in) :: intpart + real(dp), intent(in) :: realpart + + call table_append_row(this,(/intpart/),(/realpart/)) + + end subroutine table_append_int_element_and_real_element + + !overloaded append for mixed scalar and row input + subroutine table_append_int_element_real_row(this,intpart,realpart) + type(table), intent(inout) :: this + integer, intent(in) :: intpart + real(dp), intent(in) :: realpart(:) + + call table_append_row(this,(/intpart/),realpart) + + end subroutine table_append_int_element_real_row + + !overloaded append for mixed scalar and row input + subroutine table_append_int_row_real_element(this,intpart,realpart) + type(table), intent(inout) :: this + integer, intent(in) :: intpart(:) + real(dp), intent(in) :: realpart + + call table_append_row(this,intpart,(/realpart/)) + + end subroutine table_append_int_row_real_element + + ! append another table to this table + subroutine table_append_table(this,other) + type(table), intent(inout) :: this + type(table), intent(in) :: other + + if(allocated(this%int) .or. allocated(this%real) .or. allocated(this%str) .or. allocated(this%logical)) then + if(this%N+other%N > this%max_length) & ! we need more memory + call table_allocate(this,max_length=this%N+other%N) + else ! new table + this=other + return + end if + + if (other%n == 0) return + + ! we have ints + if(allocated(this%int)) then + if (.not.allocated(other%int))& + call system_abort('table_append_table: appendix table has no int part!') + + if(size(this%int,1).ne.size(other%int,1))& + call system_abort('table_append_table: appendix table has int part with wrong shape!') + + this%int(:,this%N+1:this%N+other%N) = other%int(:,1:other%N) + end if + + ! we have reals + if(allocated(this%real)) then + if (.not.allocated(other%real)) & + call system_abort('table_append_table: appendix table has no real part!') + + if(size(this%real,1).ne.size(other%real,1))& + call system_abort('table_append_table: appendix table has real part with wrong shape!') + + this%real(:,this%N+1:this%N+other%N) = other%real(:,1:other%N) + end if + + ! we have strs + if(allocated(this%str)) then + if (.not.allocated(other%str)) & + call system_abort('table_append_table: appendix table has no str part!') + + if(size(this%str,1).ne.size(other%str,1))& + call system_abort('table_append_table: appendix table has str part with wrong shape!') + + this%str(:,this%N+1:this%N+other%N) = other%str(:,1:other%N) + end if + + ! we have logicals + if(allocated(this%logical)) then + if (.not.allocated(other%logical)) & + call system_abort('table_append_table: appendix table has no logical part!') + + if(size(this%logical,1).ne.size(other%logical,1))& + call system_abort('table_append_table: appendix table has logical part with wrong shape!') + + this%logical(:,this%N+1:this%N+other%N) = other%logical(:,1:other%N) + end if + + + ! update the number of rows + this%N=this%N+other%N + end subroutine table_append_table + + subroutine table_append_col_i(this, val, n_cols, cols) + type(Table), intent(inout) :: this + integer, intent(in) :: val + integer, optional :: n_cols + integer, intent(out), optional :: cols(2) + + integer :: use_n_cols = 1 + + if (present(n_cols)) use_n_cols = n_cols + + call table_extend_int_cols(this,use_n_cols) + + this%int(this%intsize-use_n_cols+1:this%intsize,:) = val + + if (present(cols)) then + cols(1) = this%intsize-use_n_cols+1 + cols(2) = this%intsize + endif + end subroutine table_append_col_i + + subroutine table_append_col_i_a(this, val_a, n_cols, cols) + type(Table), intent(inout) :: this + integer, intent(in) :: val_a(:) + integer, optional :: n_cols + integer, intent(out), optional :: cols(2) + + integer i + integer :: use_n_cols = 1 + + if (present(n_cols)) use_n_cols = n_cols + if (size(val_a) /= this%N) call system_abort ("Called table_append_col_i_a with mismatched data size") + + call table_extend_int_cols(this,use_n_cols) + do i=1, this%N + this%int(this%intsize-use_n_cols+1:this%intsize,i) = val_a(i) + end do + + if (present(cols)) then + cols(1) = this%intsize-use_n_cols+1 + cols(2) = this%intsize + endif + end subroutine table_append_col_i_a + + subroutine table_append_col_r(this, val, n_cols, cols) + type(Table), intent(inout) :: this + real(dp), intent(in) :: val + integer, optional :: n_cols + integer, intent(out), optional :: cols(2) + + integer :: use_n_cols = 1 + + if (present(n_cols)) use_n_cols = n_cols + + call table_extend_real_cols(this, use_n_cols) + + this%real(this%realsize-use_n_cols+1:this%realsize,:) = val + + if (present(cols)) then + cols(1) = this%realsize-use_n_cols+1 + cols(2) = this%realsize + endif + end subroutine table_append_col_r + + subroutine table_append_col_r_a(this, val_a, n_cols, cols) + type(Table), intent(inout) :: this + real(dp), intent(in) :: val_a(:) + integer, optional :: n_cols + integer, intent(out), optional :: cols(2) + + integer i + integer :: use_n_cols = 1 + + if (present(n_cols)) use_n_cols = n_cols + if (size(val_a) /= this%N) call system_abort ("Called table_append_col_r_a with mismatched data size") + + call table_extend_real_cols(this, use_n_cols) + do i=1, this%N + this%real(this%realsize-use_n_cols+1:this%realsize,i) = val_a(i) + end do + + if (present(cols)) then + cols(1) = this%realsize-use_n_cols+1 + cols(2) = this%realsize + endif + end subroutine table_append_col_r_a + + + subroutine table_append_col_s(this, val, n_cols, cols) + type(Table), intent(inout) :: this + character(TABLE_STRING_LENGTH), intent(in) :: val + integer, optional :: n_cols + integer, intent(out), optional :: cols(2) + + integer :: use_n_cols = 1 + + if (present(n_cols)) use_n_cols = n_cols + + call table_extend_str_cols(this, use_n_cols) + + this%str(this%strsize-use_n_cols+1:this%strsize,:) = val + + if (present(cols)) then + cols(1) = this%strsize-use_n_cols+1 + cols(2) = this%strsize + endif + end subroutine table_append_col_s + + subroutine table_append_col_s_a(this, val_a, n_cols, cols) + type(Table), intent(inout) :: this + character(TABLE_STRING_LENGTH), intent(in) :: val_a(:) + integer, optional :: n_cols + integer, intent(out), optional :: cols(2) + + integer i + integer :: use_n_cols = 1 + + if (present(n_cols)) use_n_cols = n_cols + if (size(val_a) /= this%N) call system_abort ("Called table_append_col_s_a with mismatched data size") + + call table_extend_str_cols(this, use_n_cols) + do i=1, this%N + this%str(this%strsize-use_n_cols+1:this%strsize,i) = val_a(i) + end do + + if (present(cols)) then + cols(1) = this%strsize-use_n_cols+1 + cols(2) = this%strsize + endif + end subroutine table_append_col_s_a + + + subroutine table_append_col_l(this, val, n_cols, cols) + type(Table), intent(inout) :: this + logical, intent(in) :: val + integer, optional :: n_cols + integer, intent(out), optional :: cols(2) + + integer :: use_n_cols = 1 + + if (present(n_cols)) use_n_cols = n_cols + + call table_extend_logical_cols(this, use_n_cols) + + this%logical(this%logicalsize-use_n_cols+1:this%logicalsize,:) = val + + if (present(cols)) then + cols(1) = this%logicalsize-use_n_cols+1 + cols(2) = this%logicalsize + endif + end subroutine table_append_col_l + + subroutine table_append_col_l_a(this, val_a, n_cols, cols) + type(Table), intent(inout) :: this + logical, intent(in) :: val_a(:) + integer, optional :: n_cols + integer, intent(out), optional :: cols(2) + + integer i + integer :: use_n_cols = 1 + + if (present(n_cols)) use_n_cols = n_cols + if (size(val_a) /= this%N) call system_abort ("Called table_append_col_l_a with mismatched data size") + + call table_extend_logical_cols(this, use_n_cols) + do i=1, this%N + this%logical(this%logicalsize-use_n_cols+1:this%logicalsize,i) = val_a(i) + end do + + if (present(cols)) then + cols(1) = this%logicalsize-use_n_cols+1 + cols(2) = this%logicalsize + endif + end subroutine table_append_col_l_a + + + subroutine table_append_col_table(this, other) + type(Table), intent(inout) :: this + type(Table), intent(in) :: other + + if (this%N /= other%N) call system_abort ("Called table_append_col_table with mismatched sizes") + + if (other%intsize > 0) then + call table_extend_int_cols(this, other%intsize) + this%int(this%intsize-other%intsize+1:this%intsize, :) = other%int(1:other%intsize, :) + endif + if (other%realsize > 0) then + call table_extend_real_cols(this, other%realsize) + this%real(this%realsize-other%realsize+1:this%realsize, :) = other%real(1:other%realsize, :) + endif + if (other%strsize > 0) then + call table_extend_str_cols(this, other%strsize) + this%str(this%strsize-other%strsize+1:this%strsize, :) = other%str(1:other%strsize, :) + endif + if (other%logicalsize > 0) then + call table_extend_logical_cols(this, other%logicalsize) + this%logical(this%logicalsize-other%logicalsize+1:this%logicalsize, :) = other%logical(1:other%logicalsize, :) + endif + + end subroutine table_append_col_table + + subroutine table_extend_int_cols(this, n_cols) + type(Table), intent(inout) :: this + integer n_cols + + integer, allocatable :: t(:,:) + + if (n_cols < 0) call system_abort ("Called table_extend_int_cols with n_cols < 0") + if (n_cols == 0) return + + if (allocated(this%int)) then + if (size(this%int,1) < this%intsize+n_cols) then + allocate(t(this%intsize,this%N)) + t = this%int(1:this%intsize, 1:this%N) + deallocate(this%int) + allocate(this%int(this%intsize+n_cols,this%max_length)) + this%int(1:this%intsize, 1:this%N) = t(1:this%intsize, 1:this%N) + this%int(this%intsize+1:this%intsize+n_cols,:) = 0 + endif + this%intsize = this%intsize + n_cols + else + this%intsize = n_cols + allocate(this%int(this%intsize,this%N)) + this%int = 0 + endif + end subroutine table_extend_int_cols + + subroutine table_extend_real_cols(this, n_cols) + type(Table), intent(inout) :: this + integer n_cols + + real(dp), allocatable :: t(:,:) + + if (n_cols < 0) call system_abort ("Called table_extend_int_cols with n_cols < 0") + if (n_cols == 0) return + + if (allocated(this%real)) then + if (size(this%real,1) < this%realsize+n_cols) then + allocate(t(this%realsize,this%N)) + t = this%real(1:this%realsize, 1:this%N) + deallocate(this%real) + allocate(this%real(this%realsize+n_cols,this%max_length)) + this%real(1:this%realsize, 1:this%N) = t(1:this%realsize, 1:this%N) + this%real(this%realsize+1:this%realsize+n_cols,:) = 0 + endif + this%realsize = this%realsize + n_cols + else + this%realsize = n_cols + allocate(this%real(this%realsize,this%N)) + this%real = 0 + endif + end subroutine table_extend_real_cols + + subroutine table_extend_str_cols(this, n_cols) + type(Table), intent(inout) :: this + integer n_cols + + character(TABLE_STRING_LENGTH), allocatable :: t(:,:) + + if (n_cols < 0) call system_abort ("Called table_extend_str_cols with n_cols < 0") + if (n_cols == 0) return + + if (allocated(this%str)) then + if (size(this%str,1) < this%strsize+n_cols) then + allocate(t(this%strsize,this%N)) + t = this%str(1:this%strsize, 1:this%N) + deallocate(this%str) + allocate(this%str(this%strsize+n_cols,this%max_length)) + this%str(1:this%strsize, 1:this%N) = t(1:this%strsize, 1:this%N) + this%str(this%strsize+1:this%strsize+n_cols,:) = repeat(' ',TABLE_STRING_LENGTH) + endif + this%strsize = this%strsize + n_cols + else + this%strsize = n_cols + allocate(this%str(this%strsize,this%N)) + this%str = repeat(' ',TABLE_STRING_LENGTH) + endif + end subroutine table_extend_str_cols + + + subroutine table_extend_logical_cols(this, n_cols) + type(Table), intent(inout) :: this + integer n_cols + + logical, allocatable :: t(:,:) + + if (n_cols < 0) call system_abort ("Called table_extend_logical_cols with n_cols < 0") + if (n_cols == 0) return + + if (allocated(this%logical)) then + if (size(this%logical,1) < this%logicalsize+n_cols) then + allocate(t(this%logicalsize,this%N)) + t = this%logical(1:this%logicalsize, 1:this%N) + deallocate(this%logical) + allocate(this%logical(this%logicalsize+n_cols,this%max_length)) + this%logical(1:this%logicalsize, 1:this%N) = t(1:this%logicalsize, 1:this%N) + this%logical(this%logicalsize+1:this%logicalsize+n_cols,:) = .false. + endif + this%logicalsize = this%logicalsize + n_cols + else + this%logicalsize = n_cols + allocate(this%logical(this%logicalsize,this%N)) + this%logical = .false. + endif + end subroutine table_extend_logical_cols + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! inserting a new row at a given position + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine table_insert(this,pos,intpart,realpart,strpart,logicalpart) + + type(table), intent(inout) :: this + integer, intent(in) :: pos + integer, dimension(:), optional, intent(in) :: intpart + real(dp), dimension(:), optional, intent(in) :: realpart + character(TABLE_STRING_LENGTH), dimension(:), optional, intent(in) :: strpart + logical, dimension(:), optional, intent(in) :: logicalpart + + !Check input arguments + if (pos < 1 .or. pos > this%N+1) call system_abort('table_insert: cannot insert at position '//pos) + + if (present(intpart)) then + if (this%intsize == 0) call system_abort('table insert: table does not have an int part') + if (size(intpart) /= this%intsize) & + call system_abort('table_insert: int size should be '//this%intsize//' and not '//size(intpart)) + end if + if (present(realpart)) then + if (this%realsize == 0) call system_abort('table insert: table does not have a real part') + if (size(realpart) /= this%realsize) & + call system_abort('table_insert: real size should be '//this%realsize//' and not '//size(realpart)) + end if + if (present(strpart)) then + if (this%strsize == 0) call system_abort('table insert: table does not have a str part') + if (size(strpart) /= this%strsize) & + call system_abort('table_insert: str size should be '//this%strsize//' and not '//size(strpart)) + end if + if (present(logicalpart)) then + if (this%logicalsize == 0) call system_abort('table insert: table does not have a logical part') + if (size(logicalpart) /= this%logicalsize) & + call system_abort('table_insert: logical size should be '//this%logicalsize//' and not '//size(logicalpart)) + end if + + if (.not.present(intpart) .and. .not.present(realpart) .and. & + .not. present(strpart) .and. .not. present(logicalpart)) & + call system_abort('table_insert: at least one of intpart/realpart/strpart/logicalpart must be present') + + !First check if we need to insert -- FIXME: these parameters are not optional in append() + if (pos == this%N+1) then + call append(this,intpart,realpart,strpart,logicalpart) + return + end if + + !Make sure memory is available + if (this%N+1 > this%max_length) call allocate(this,max_length=this%N+this%increment) + + !Shift everything from 'pos' to 'N' down a line and insert new data + if (this%intsize > 0) then + if (.not. present(intpart)) call system_abort('table_insert: missing intpart') + this%int(:,pos+1:this%N+1) = this%int(:,pos:this%N) + this%int(:,pos) = intpart + end if + if (this%realsize > 0) then + if (.not. present(realpart)) call system_abort('table_insert: missing realpart') + this%real(:,pos+1:this%N+1) = this%real(:,pos:this%N) + this%real(:,pos) = realpart + end if + if (this%strsize > 0) then + if (.not. present(strpart)) call system_abort('table_insert: missing strpart') + this%str(:,pos+1:this%N+1) = this%str(:,pos:this%N) + this%str(:,pos) = strpart + end if + if (this%logicalsize > 0) then + if (.not. present(logicalpart)) call system_abort('table_insert: missing logicalpart') + this%logical(:,pos+1:this%N+1) = this%logical(:,pos:this%N) + this%logical(:,pos) = logicalpart + end if + + + !Update the row counter + this%N = this%N + 1 + + end subroutine table_insert + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! sort a table by its integer part + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine table_sort(this,idx,int_cols) + type(table), intent(inout) :: this + integer, dimension(this%N), optional, intent(out) :: idx + integer, optional, intent(in) :: int_cols(:) + + integer, dimension(this%intsize) :: tmp_intpart + real(dp),dimension(this%realsize) :: tmp_realpart + character(TABLE_STRING_LENGTH), dimension(this%strsize) :: tmp_strpart + logical, dimension(this%logicalsize) :: tmp_logicalpart + + integer :: i, j, vi + logical :: have_reals, have_strs, have_logicals + integer, allocatable :: sort_cols(:) + + if (this%intsize == 0) return + have_reals = (this%realsize /= 0) + have_strs = (this%strsize /= 0) + have_logicals = (this%logicalsize /= 0) + + if (present(idx)) idx = (/ (i, i=1,this%N) /) + + if (present(int_cols)) then + allocate(sort_cols(size(int_cols))) + sort_cols = int_cols + else + allocate(sort_cols(this%intsize)) + sort_cols = (/ (i, i=1,this%intsize) /) + endif + + do i = 2, this%N + + if (int_array_ge(this%int(sort_cols,i),this%int(sort_cols,i-1))) cycle + + ! i is smaller than i-1, start moving it back + tmp_intpart = this%int(:,i) + if (have_reals) tmp_realpart = this%real(:,i) + if (have_strs) tmp_strpart = this%str(:,i) + if (have_logicals) tmp_logicalpart = this%logical(:,i) + if (present(idx)) vi = idx(i) + + j = i-1 + + do while (j >= 1) + + ! if tmp (orig i, now j+1) is greater than this j, no need to move it further + if (int_array_gt(tmp_intpart(sort_cols), this%int(sort_cols,j))) exit + + this%int(:,j+1) = this%int(:,j) + if (have_reals) this%real(:,j+1) = this%real(:,j) + if (have_strs) this%str(:,j+1) = this%str(:,j) + if (have_logicals) this%logical(:,j+1) = this%logical(:,j) + + this%int(:,j) = tmp_intpart + if (have_reals) this%real(:,j) = tmp_realpart + if (have_strs) this%str(:,j) = tmp_strpart + if (have_logicals) this%logical(:,j) = tmp_logicalpart + + if (present(idx)) then + idx(j+1) = idx(j) + idx(j) = vi + end if + j = j - 1 + + end do + + end do + + deallocate(sort_cols) + + end subroutine table_sort + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! binary search a sorted table: index = 0 if not found + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + pure function table_search(this,intpart) result(index) + + type(table), intent(in) :: this + integer, dimension(:), intent(in) :: intpart + integer :: index + + integer :: ilow, ihigh + logical :: done + + index = 0 + if (this%N < 1) return + ilow = 1; ihigh = this%N + done = .false. + + if ( int_array_gt(this%int(:,ilow),intpart) .or. int_array_lt(this%int(:,ihigh),intpart) ) done = .true. + if (.not.done) then + if (all(this%int(1:size(intpart),ilow) == intpart)) then + index = ilow + done = .true. + else if (all(this%int(1:size(intpart),ihigh) == intpart)) then + index = ihigh + done = .true. + end if + end if + + do while(.not.done) + index = (ihigh + ilow) / 2 + if (index == ilow) then ! value is not present. exit + index = 0 + done = .true. + else if (all(this%int(1:size(intpart),index) == intpart)) then ! value found + done = .true. + else if (int_array_lt(this%int(1:size(intpart),index),intpart)) then ! value at this index is too low. shift lower bound + ilow = index + else ! value at this index is too high. shift upper bound + ihigh = index + end if + end do + + end function table_search + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! deleting rows from tables + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + subroutine table_record_delete_by_index(this, n, keep_order) + type(table), intent(inout) :: this + integer, intent(in) :: n + logical, intent(in), optional :: keep_order + + logical :: do_keep_order + + do_keep_order = optional_default(.true., keep_order) + + if (n > this%N .or. n < 1) then + write(line,'(a,2(i0,a))')'table_record_delete_by_index: Tried to delete record ',n,' (N=',this%N,')' + call system_abort(line) + end if + + if (do_keep_order) then + ! move all later rows back 1 + if(allocated(this%int)) this%int (:,n:this%N-1) = this%int (:,n+1:this%N) + if(allocated(this%real)) this%real(:,n:this%N-1) = this%real(:,n+1:this%N) + if(allocated(this%str)) this%str(:,n:this%N-1) = this%str(:,n+1:this%N) + if(allocated(this%logical)) this%logical(:,n:this%N-1) = this%logical(:,n+1:this%N) + else + ! replace the row with the last row + if(allocated(this%int)) this%int (:,n) = this%int (:,this%N) + if(allocated(this%real)) this%real(:,n) = this%real(:,this%N) + if(allocated(this%str)) this%str(:,n) = this%str(:,this%N) + if(allocated(this%logical)) this%logical(:,n) = this%logical(:,this%N) + endif + + this%N=this%N-1 + + ! maybe we can reduce the memory + call reduce_allocation(this) + + end subroutine table_record_delete_by_index + + subroutine table_record_delete_multiple(this, indices) + type(Table), intent(inout) :: this + integer, intent(in), dimension(:) :: indices + + integer :: oldN, newN, i, N, copysrc + integer, dimension(size(indices)) :: sorted + integer, dimension(:), allocatable :: uniqed + + !Get our own copy of the indices so we can sort them + sorted = indices + call sort_array(sorted) + + !Now remove duplicates from sorted indices + call uniq(sorted, uniqed) + + oldN = this%N + N = size(uniqed) + newN = oldN - N + + ! Algorithm: Find first row to be removed and last row to not be removed + ! and swap them. Repeat until all rows to be removed are at the end. + copysrc = oldN + do i=1,N + do while(is_in_array(uniqed,copysrc)) + copysrc = copysrc - 1 + end do + + if (uniqed(i) > copysrc) exit + + if (allocated(this%int)) this%int(:,uniqed(i)) = this%int(:,copysrc) + if (allocated(this%real)) this%real(:,uniqed(i)) = this%real(:,copysrc) + if (allocated(this%str)) this%str(:,uniqed(i)) = this%str(:,copysrc) + if (allocated(this%logical)) this%logical(:,uniqed(i)) = this%logical(:,copysrc) + + copysrc = copysrc - 1 + end do + + this%N = newN + call reduce_allocation(this) + deallocate(uniqed) + + end subroutine table_record_delete_multiple + + + subroutine table_record_delete_by_value(this,n, keep_order) + type(table), intent(inout) :: this + integer, intent(in) :: n(:) + logical, intent(in), optional :: keep_order + + integer :: i + + if (.not.allocated(this%int)) & + call system_abort('table_record_delete_by_value: you cannot delete by value from a table without an int part') + + if (size(n).ne.size(this%int,1)) & + call system_abort('table_record_delete_by_value: the row you are trying to delete has the wrong size') + + do i=1,this%N + if ( all(this%int(:,i) == n(:)) ) then + call delete(this, i, keep_order) + exit + end if + end do + !maybe we can reduce the memory + call reduce_allocation(this) + end subroutine table_record_delete_by_value + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! Wipe the table but keep the allocation + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine table_wipe(this,zero) + type(Table), intent(inout) :: this + logical, optional, intent(in) :: zero + + if (present(zero)) then + if (zero) call table_zero(this) + end if + + this%N = 0 + + end subroutine table_wipe + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! find a row by the integer entries (return first occurrence) + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function table_find_element(this, n) result(i) + type(table), intent(in):: this + integer, intent(in) :: n + integer :: i + + i = table_find_row(this, (/n/)) + + end function table_find_element + + function table_find_row(this, n, mask) result(i) + type(table), intent(in) :: this + integer, intent(in) :: n(:) ! what we are looking for + logical,optional,intent(in) :: mask(:) ! if this exists, we only compare elements where this is true + integer :: i + + + if (this%intsize == 0) & + call system_abort('Table_Find_Row: Table has no int part') + + if (size(n) /= this%intsize) & + call system_abort('Table_Find_Row: Row being searched for has wrong size') + + ! I've removed call to int_part() here as found to be bottleneck when profiling (jrk33) + i = find_in_array(this%int(:,1:this%n), n, mask) + end function table_find_row + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! + ! printing + ! + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine table_print_mainlog(this,verbosity) + type(table), intent(in) :: this + integer, intent(in), optional :: verbosity + call table_print(this, verbosity, mainlog) + end subroutine table_print_mainlog + + + subroutine table_print(this,verbosity,file,real_format,int_format,str_format,logical_format,mask) + type(table), intent(in) :: this + type(inoutput), intent(inout) :: file + integer, intent(in), optional :: verbosity + character(*), optional, intent(in) :: real_format, int_format, str_format, logical_format + logical, optional, intent(in) :: mask(:) + + !locals + character(10) :: my_real_format, my_int_format, my_str_format, my_logical_format + character(100) :: fmt + integer :: i, j + + my_real_format = optional_default('f16.8',real_format) + my_int_format = optional_default('i8',int_format) + my_str_format = optional_default('a'//(TABLE_STRING_LENGTH+1),str_format) + my_logical_format = optional_default('l3',logical_format) + + ! Print all columns in order, first ints then reals, strs and logicals + do i=1,this%N + if (present(mask)) then + if (.not.mask(i)) cycle + endif + line = '' + do j=1,this%intsize + write (fmt,'('//trim(my_int_format)//')') this%int(j,i) + line=trim(line)//' '//trim(fmt) + end do + do j=1,this%realsize + write (fmt,'('//trim(my_real_format)//')') this%real(j,i) + line=trim(line)//' '//trim(fmt) + end do + do j=1,this%strsize + write (fmt,'('//trim(my_str_format)//')') this%str(j,i) + line=trim(line)//' '//trim(fmt) + end do + do j=1,this%logicalsize + write (fmt,'('//trim(my_logical_format)//')') this%logical(j,i) + line=trim(line)//' '//trim(fmt) + end do + call print(line,verbosity,file) + end do + + end subroutine table_print + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Returning parts of the table + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function table_int_column(this,column) + type(Table), intent(in) :: this + integer, intent(in) :: column + integer, dimension(this%N) :: table_int_column + + if (column > this%intsize) call system_abort('table_int_column: Column out of range') + + table_int_column = this%int(column,1:this%N) + + end function table_int_column + + function table_real_column(this,column) + type(Table), intent(in) :: this + integer, intent(in) :: column + real(dp), dimension(this%N) :: table_real_column + + if (column > this%realsize) call system_abort('table_real_column: Column out of range') + + table_real_column = this%real(column,1:this%N) + + end function table_real_column + + function table_str_column(this,column) + type(Table), intent(in) :: this + integer, intent(in) :: column + character(TABLE_STRING_LENGTH), dimension(this%N) :: table_str_column + + if (column > this%strsize) call system_abort('table_str_column: Column out of range') + + table_str_column = this%str(column,1:this%N) + + end function table_str_column + + + function table_logical_column(this,column) + type(Table), intent(in) :: this + integer, intent(in) :: column + logical, dimension(this%N) :: table_logical_column + + if (column > this%logicalsize) call system_abort('table_logical_column: Column out of range') + + table_logical_column = this%logical(column,1:this%N) + + end function table_logical_column + + + function table_int_columns(this,columns) + type(Table), intent(in) :: this + integer, intent(in) :: columns(:) + integer, dimension(size(columns),this%N) :: table_int_columns + + if (any(columns > this%intsize)) call system_abort('table_int_columns: Column out of range') + + table_int_columns = this%int(columns,1:this%N) + + end function table_int_columns + + function table_real_columns(this,columns) + type(Table), intent(in) :: this + integer, intent(in) :: columns(:) + real(dp), dimension(size(columns),this%N) :: table_real_columns + + if (any(columns > this%realsize)) call system_abort('table_real_columns: Column out of range') + + table_real_columns = this%real(columns,1:this%N) + + end function table_real_columns + + + function table_str_columns(this,columns) + type(Table), intent(in) :: this + integer, intent(in) :: columns(:) + character(TABLE_STRING_LENGTH), dimension(size(columns),this%N) :: table_str_columns + + if (any(columns > this%strsize)) call system_abort('table_str_columns: Column out of range') + + table_str_columns = this%str(columns,1:this%N) + + end function table_str_columns + + function table_logical_columns(this,columns) + type(Table), intent(in) :: this + integer, intent(in) :: columns(:) + logical, dimension(size(columns),this%N) :: table_logical_columns + + if (any(columns > this%logicalsize)) call system_abort('table_logical_columns: Column out of range') + + table_logical_columns = this%logical(columns,1:this%N) + + end function table_logical_columns + + + function table_int_part(this) + type(Table), intent(in) :: this + integer, dimension(this%intsize,this%N) :: table_int_part + + if (this%intsize == 0) call system_abort('table_int_part: Table has no integer part') + + table_int_part = this%int(:,1:this%N) + + end function table_int_part + + function table_real_part(this) + type(Table), intent(in) :: this + real(dp), dimension(this%realsize,this%N ) :: table_real_part + + if (this%realsize == 0) call system_abort('table_real_part: Table has no real part') + + table_real_part = this%real(:,1:this%N) + + end function table_real_part + + function table_str_part(this) + type(Table), intent(in) :: this + character(TABLE_STRING_LENGTH), dimension(this%strsize,this%N ) :: table_str_part + + if (this%strsize == 0) call system_abort('table_str_part: Table has no str part') + + table_str_part = this%str(:,1:this%N) + + end function table_str_part + + function table_logical_part(this) + type(Table), intent(in) :: this + logical, dimension(this%logicalsize,this%N ) :: table_logical_part + + if (this%logicalsize == 0) call system_abort('table_logical_part: Table has no logical part') + + table_logical_part = this%logical(:,1:this%N) + + end function table_logical_part + + + + !Create a table from selected elements of another table + + function subtable(this,rows,intcols,realcols,strcols,logicalcols) + type(Table), intent(in) :: this + integer, dimension(:), intent(in) :: rows + integer, dimension(:), intent(in),optional :: intcols + integer, dimension(:), intent(in),optional :: realcols + integer, dimension(:), intent(in),optional :: strcols + integer, dimension(:), intent(in),optional :: logicalcols + type(Table) :: subtable + + integer, dimension(:), allocatable :: use_intcols, use_realcols, use_strcols, use_logicalcols + integer :: i + + !First check none of the requested rows/columns are out of bounds + + if (any(rows > this%N)) & + call system_abort('subtable: Row out of range size(rows) ' // size(rows) // ' minval ' // minval(rows) // ' maxval ' // maxval(rows) // ' this%N ' // this%N) + + if(present(intcols)) then + if(any(intcols > 0 .and. intcols > this%intsize)) call system_abort('subtable: Integer column out of range') + allocate(use_intcols(count(intcols > 0))) + use_intcols = pack(intcols, intcols > 0) + else + allocate(use_intcols(this%intsize)) + use_intcols = (/ (i, i=1,this%intsize ) /) + end if + + if(present(realcols)) then + if(any(realcols > 0 .and. realcols > this%realsize)) call system_abort('subtable: Real column out of range') + allocate(use_realcols(count(realcols > 0))) + use_realcols = pack(realcols, realcols > 0) + else + allocate(use_realcols(this%realsize)) + use_realcols = (/ (i, i=1,this%realsize )/) + end if + + if(present(strcols)) then + if(any(strcols > 0 .and. strcols > this%strsize)) call system_abort('subtable: Str column out of range') + allocate(use_strcols(count(strcols > 0))) + use_strcols = pack(strcols, strcols > 0) + else + allocate(use_strcols(this%strsize)) + use_strcols = (/ (i, i=1,this%strsize ) /) + end if + + if(present(logicalcols)) then + if(any(logicalcols > 0 .and. logicalcols > this%logicalsize)) call system_abort('subtable: Logical column out of range') + allocate(use_logicalcols(count(logicalcols > 0))) + use_logicalcols = pack(logicalcols, logicalcols > 0) + else + allocate(use_logicalcols(this%logicalsize)) + use_logicalcols = (/ (i, i=1,this%logicalsize ) /) + end if + +! call allocate(subtable, size(use_intcols),size(use_realcols),size(use_strcols),size(use_logicalcols)) + + ! gfortran is fussier than ifort about passing empty arrays, so we have to do this ugly switch over all + ! permuations of null and non-null columns + + if (this%intsize /= 0 .and. this%realsize /= 0 .and. this%strsize /= 0 .and. this%logicalsize /= 0) then + ! case 0 + + call append(subtable,intpart_2d=this%int(use_intcols,rows),& + realpart_2d=this%real(use_realcols,rows), & + strpart_2d=this%str(use_strcols,rows), & + logicalpart_2d=this%logical(use_logicalcols,rows)) + + else if (this%intsize /= 0 .and. this%realsize /= 0 .and. this%strsize /= 0 .and. this%logicalsize == 0) then + ! case 1 + + call append(subtable,intpart_2d=this%int(use_intcols,rows),& + realpart_2d=this%real(use_realcols,rows), & + strpart_2d=this%str(use_strcols,rows)) + + else if (this%intsize /= 0 .and. this%realsize /= 0 .and. this%strsize == 0 .and. this%logicalsize /= 0) then + ! case 2 + + call append(subtable,intpart_2d=this%int(use_intcols,rows),& + realpart_2d=this%real(use_realcols,rows), & + logicalpart_2d=this%logical(use_logicalcols,rows)) + + else if (this%intsize /= 0 .and. this%realsize /= 0 .and. this%strsize == 0 .and. this%logicalsize == 0) then + ! case 3 + + call append(subtable,intpart_2d=this%int(use_intcols,rows),& + realpart_2d=this%real(use_realcols,rows)) + + else if (this%intsize /= 0 .and. this%realsize == 0 .and. this%strsize /= 0 .and. this%logicalsize /= 0) then + ! case 4 + + call append(subtable,intpart_2d=this%int(use_intcols,rows),& + strpart_2d=this%str(use_strcols,rows), & + logicalpart_2d=this%logical(use_logicalcols,rows)) + + else if (this%intsize /= 0 .and. this%realsize == 0 .and. this%strsize /= 0 .and. this%logicalsize == 0) then + ! case 5 + + call append(subtable,intpart_2d=this%int(use_intcols,rows),& + strpart_2d=this%str(use_strcols,rows)) + + else if (this%intsize /= 0 .and. this%realsize == 0 .and. this%strsize == 0 .and. this%logicalsize /= 0) then + ! case 6 + + call append(subtable,intpart_2d=this%int(use_intcols,rows),& + logicalpart_2d=this%logical(use_logicalcols,rows)) + + else if (this%intsize /= 0 .and. this%realsize == 0 .and. this%strsize == 0 .and. this%logicalsize == 0) then + ! case 7 + + call append(subtable,intpart_2d=this%int(use_intcols,rows)) + + else if (this%intsize == 0 .and. this%realsize /= 0 .and. this%strsize /= 0 .and. this%logicalsize /= 0) then + ! case 8 + + call append(subtable, & + realpart_2d=this%real(use_realcols,rows), & + strpart_2d=this%str(use_strcols,rows), & + logicalpart_2d=this%logical(use_logicalcols,rows)) + + else if (this%intsize == 0 .and. this%realsize /= 0 .and. this%strsize /= 0 .and. this%logicalsize == 0) then + ! case 9 + + call append(subtable, & + realpart_2d=this%real(use_realcols,rows), & + strpart_2d=this%str(use_strcols,rows)) + + else if (this%intsize == 0 .and. this%realsize /= 0 .and. this%strsize == 0 .and. this%logicalsize /= 0) then + ! case 10 + + call append(subtable, & + realpart_2d=this%real(use_realcols,rows), & + logicalpart_2d=this%logical(use_logicalcols,rows)) + + else if (this%intsize == 0 .and. this%realsize /= 0 .and. this%strsize == 0 .and. this%logicalsize == 0) then + ! case 11 + + call append(subtable, & + realpart_2d=this%real(use_realcols,rows)) + + else if (this%intsize == 0 .and. this%realsize == 0 .and. this%strsize /= 0 .and. this%logicalsize /= 0) then + ! case 12 + + call append(subtable, & + strpart_2d=this%str(use_strcols,rows), & + logicalpart_2d=this%logical(use_logicalcols,rows)) + + else if (this%intsize == 0 .and. this%realsize == 0 .and. this%strsize /= 0 .and. this%logicalsize == 0) then + ! case 13 + + call append(subtable, & + strpart_2d=this%str(use_strcols,rows)) + + else if (this%intsize == 0 .and. this%realsize == 0 .and. this%strsize == 0 .and. this%logicalsize /= 0) then + ! case 14 + + call append(subtable, & + logicalpart_2d=this%logical(use_logicalcols,rows)) + + else if (this%intsize == 0 .and. this%realsize == 0 .and. this%strsize == 0 .and. this%logicalsize == 0) then + ! case 15 + + call system_abort('subtable: source table is empty') + + end if + + deallocate(use_intcols, use_realcols, use_strcols, use_logicalcols) + + end function subtable + + function real_subtable(this,rows,cols) + type(Table), intent(in) :: this + integer, dimension(:), intent(in) :: rows + integer, dimension(:), intent(in) :: cols + type(Table) :: Real_Subtable + integer, dimension(0) :: intcols + + real_subtable = subtable(this,rows,intcols,cols) + + end function real_subtable + + function int_subtable(this,rows,cols) + type(Table), intent(in) :: this + integer, dimension(:), intent(in) :: rows + integer, dimension(:), intent(in) :: cols + type(Table) :: int_subtable + integer, dimension(0) :: realcols + + int_subtable = subtable(this,rows,cols,realcols) + + end function int_subtable + + function rms_diff_list(array1, array2, list) + real(dp), dimension(:,:), intent(in) :: array1, array2 + type(table) :: list + real(dp) :: rms_diff_list, d + integer :: i,j, n + call check_size('Array 2',array2,shape(array1),'rms_diff') + + rms_diff_list = 0.0_dp + do n = 1,list%N + j = list%int(1,n) + do i = 1, size(array1,1) + d = array1(i,j) - array2(i,j) + rms_diff_list = rms_diff_list + d * d + end do + end do + rms_diff_list = rms_diff_list / real(list%N*size(array1,1),dp) + rms_diff_list = sqrt(rms_diff_list) + end function rms_diff_list + + subroutine table_select(to, from, row_mask, row_list) + type(table), intent(inout) :: to + type(table), intent(in) :: from + integer, intent(in), optional :: row_list(:) + logical, intent(in), optional :: row_mask(:) + + integer, allocatable :: rows(:) + integer i, N_rows + + if ((.not. present(row_list) .and. .not. present(row_mask)) .or. (present(row_list) .and. present(row_mask))) & + call system_abort('table_select: either list or mask must be present (but not both)') + + call finalise(to) + + if(present(row_list)) then ! we have a row_list + to = subtable(from, row_list) + else ! we have a row_mask + if (from%N /= size(row_mask)) & + call system_abort("table_select mismatched sizes from " // from%N // " mask " // size(row_mask)) + + N_rows = count(row_mask) + allocate(rows(N_rows)) + ! build up a row list + N_rows = 1 + do i=1, from%N + if (row_mask(i)) then + rows(N_rows) = i + N_rows = N_rows + 1 + endif + end do + + to = subtable(from, rows) + + deallocate(rows) + end if + + end subroutine table_select + +subroutine table_remove_columns(this, int_col_min, int_col_max, real_col_min, real_col_max, & + str_col_min, str_col_max, logical_col_min, logical_col_max) + type(Table), intent(inout) :: this + integer, intent(in), optional :: int_col_min, int_col_max + integer, intent(in), optional :: real_col_min, real_col_max + integer, intent(in), optional :: str_col_min, str_col_max + integer, intent(in), optional :: logical_col_min, logical_col_max + + integer my_int_col_min, my_int_col_max, my_real_col_min, my_real_col_max + integer my_str_col_min, my_str_col_max, my_logical_col_min, my_logical_col_max + integer i + type(Table) subtab + + if (present(int_col_min)) then + my_int_col_min = int_col_min + my_int_col_max = my_int_col_min + if (present(int_col_max)) my_int_col_max = int_col_max + else + if (present(int_col_max)) call system_abort("table_remove_columns has int_col_max but no int_col_min") + my_int_col_min = 1 + my_int_col_max = 0 + endif + + if (present(real_col_min)) then + my_real_col_min = real_col_min + my_real_col_max = my_real_col_min + if (present(real_col_max)) my_real_col_max = real_col_max + else + if (present(real_col_max)) call system_abort("table_remove_columns has real_col_max but no real_col_min") + my_real_col_min = 1 + my_real_col_max = 0 + endif + + if (present(str_col_min)) then + my_str_col_min = str_col_min + my_str_col_max = my_str_col_min + if (present(str_col_max)) my_str_col_max = str_col_max + else + if (present(str_col_max)) call system_abort("table_remove_columns has str_col_max but no str_col_min") + my_str_col_min = 1 + my_str_col_max = 0 + endif + + if (present(logical_col_min)) then + my_logical_col_min = logical_col_min + my_logical_col_max = my_logical_col_min + if (present(logical_col_max)) my_logical_col_max = logical_col_max + else + if (present(logical_col_max)) call system_abort("table_remove_columns has logical_col_max but no logical_col_min") + my_logical_col_min = 1 + my_logical_col_max = 0 + endif + + subtab = subtable(this, (/ (i,i=1,this%N) /), & + intcols = (/ (i,i=1,my_int_col_min-1),(i,i=my_int_col_max+1,this%intsize) /), & + realcols = (/ (i,i=1,my_real_col_min-1),(i,i=my_real_col_max+1,this%realsize) /), & + strcols = (/ (i,i=1,my_str_col_min-1),(i,i=my_str_col_max+1,this%strsize) /), & + logicalcols = (/ (i,i=1,my_logical_col_min-1),(i,i=my_logical_col_max+1,this%logicalsize) /)) + this = subtab + +end subroutine table_remove_columns + +subroutine table_bcast(mpi, this) + type(MPI_Context), intent(in) :: mpi + type(Table), intent(inout) :: this + integer :: tmp_intsize, tmp_realsize, tmp_logicalsize, tmp_strsize, tmp_max_length + + if (.not. mpi%active) return + + if (mpi%my_proc == 0) then + + tmp_max_length = this%max_length + tmp_intsize = this%intsize + tmp_realsize = this%realsize + tmp_strsize = this%strsize + tmp_logicalsize = this%logicalsize + + call bcast(mpi, tmp_max_length) + call bcast(mpi, tmp_intsize) + call bcast(mpi, tmp_realsize) + call bcast(mpi, tmp_strsize) + call bcast(mpi, tmp_logicalsize) + + call bcast(mpi, this%n) + call bcast(mpi, this%increment) + + if (this%intsize /= 0) call bcast(mpi, this%int) + if (this%realsize /= 0) call bcast(mpi, this%real) + if (this%strsize /= 0) call bcast(mpi, this%str) + if (this%logicalsize /= 0) call bcast(mpi, this%logical) + else + call finalise(this) + call bcast(mpi, tmp_max_length) + call bcast(mpi, tmp_intsize) + call bcast(mpi, tmp_realsize) + call bcast(mpi, tmp_strsize) + call bcast(mpi, tmp_logicalsize) + call allocate(this, tmp_intsize, tmp_realsize, tmp_strsize, tmp_logicalsize, tmp_max_length) + + call bcast(mpi, this%n) + call bcast(mpi, this%increment) + + if (this%intsize /= 0) call bcast(mpi, this%int) + if (this%realsize /= 0) call bcast(mpi, this%real) + if (this%strsize /= 0) call bcast(mpi, this%str) + if (this%logicalsize /= 0) call bcast(mpi, this%logical) + end if + +end subroutine table_bcast + + +!% Move a single entry from one location to another one. +!% The destination will be overriden. +subroutine table_copy_entry(this, src, dst) + implicit none + + type(Table), intent(inout) :: this + integer, intent(in) :: src + integer, intent(in) :: dst + + ! --- + + if (allocated(this%int)) then + this%int(:, dst) = this%int(:, src) + endif + + if (allocated(this%real)) then + this%real(:, dst) = this%real(:, src) + endif + + if (allocated(this%str)) then + this%str(:, dst) = this%str(:, src) + endif + + if (allocated(this%logical)) then + this%logical(:, dst) = this%logical(:, src) + endif + +endsubroutine table_copy_entry + +end module table_module diff --git a/src/libAtoms/Thermostat.F90 b/src/libAtoms/Thermostat.F90 new file mode 100644 index 0000000000..63c4a61d63 --- /dev/null +++ b/src/libAtoms/Thermostat.F90 @@ -0,0 +1,1929 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Thermostat module +!X +!% This module contains the implementations for all the thermostats available +!% in libAtoms: Langevin, Nose-Hoover and Nose-Hoover-Langevin. +!% Each thermostat has its own section in the 'thermostat_pre_vel1-4' subroutines, +!% which interleave the usual velocity verlet steps. +!% +!% All Langevin variants with $Q > 0$ are open Langevin, from Jones \& Leimkuhler +!% preprint ``Adaptive Stochastic Methods for Nonequilibrium Sampling" +!% +!% Langevin steps for THERMOSTAT_ALL_PURPOSE use Ornstein-Uhlenbeck steps as +!% recommended by B. Leimkuhler, private comm. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module thermostat_module + + use system_module + use units_module + use linearalgebra_module + use atoms_types_module + use atoms_module + + implicit none + private + + public :: thermostat, initialise, finalise, print, add_thermostat, remove_thermostat, add_thermostats, update_thermostat, & + set_degrees_of_freedom, nose_hoover_mass, thermostat_array_assignment + public :: THERMOSTAT_NONE, & + THERMOSTAT_LANGEVIN, & + THERMOSTAT_NOSE_HOOVER, & + THERMOSTAT_NOSE_HOOVER_LANGEVIN, & + THERMOSTAT_LANGEVIN_NPT, & + THERMOSTAT_LANGEVIN_PR, & + THERMOSTAT_NPH_ANDERSEN, & + THERMOSTAT_NPH_PR, & + THERMOSTAT_LANGEVIN_OU, & + THERMOSTAT_LANGEVIN_NPT_NB, & + THERMOSTAT_ALL_PURPOSE + public :: MIN_TEMP + + public :: thermostat_pre_vel1, thermostat_post_vel1_pre_pos, thermostat_post_pos_pre_calc, thermostat_post_calc_pre_vel2, thermostat_post_vel2 + + real(dp), dimension(3,3), parameter :: matrix_one = reshape( (/ 1.0_dp, 0.0_dp, 0.0_dp, & + & 0.0_dp, 1.0_dp, 0.0_dp, & + & 0.0_dp, 0.0_dp, 1.0_dp/), (/3,3/) ) + + real(dp), parameter :: MIN_TEMP = 1.0_dp ! K + + integer, parameter :: THERMOSTAT_NONE = 0, & + THERMOSTAT_LANGEVIN = 1, & + THERMOSTAT_NOSE_HOOVER = 2, & + THERMOSTAT_NOSE_HOOVER_LANGEVIN = 3, & + THERMOSTAT_LANGEVIN_NPT = 4, & + THERMOSTAT_LANGEVIN_PR = 5, & + THERMOSTAT_NPH_ANDERSEN = 6, & + THERMOSTAT_NPH_PR = 7, & + THERMOSTAT_LANGEVIN_OU = 8, & + THERMOSTAT_LANGEVIN_NPT_NB = 9, & + THERMOSTAT_ALL_PURPOSE = 10 + + !% Nose-Hoover thermostat --- + !% Hoover, W.G., \emph{Phys. Rev.}, {\bfseries A31}, 1695 (1985) + + !% Langevin thermostat - fluctuation/dissipation --- + !% Quigley, D. and Probert, M.I.J., \emph{J. Chem. Phys.}, + !% {\bfseries 120} 11432 + + !% Nose-Hoover-Langevin thermostat --- me! + + !% all-purpose adaptive Langevin + !% Jones and Leimkuhler, \emph{J. Chem. Phys.} {\bfseries 135}, 084125 (2011). + + !% all-purpose Nose-Hoover-Langevin + !% Leimkuhler private communication (?) + + type thermostat + + integer :: type = THERMOSTAT_NONE !% One of the types listed above + real(dp) :: gamma = 0.0_dp !% Friction coefficient in Langevin and Nose-Hoover-Langevin + real(dp) :: NHL_gamma = 0.0_dp !% Friction coefficient in all-purpose thermostat NHL + real(dp) :: eta = 0.0_dp !% $\eta$ variable in Nose-Hoover + real(dp), allocatable :: chi_a(:) !% $\chi$ variable in Leimkuhler's notation for Nose-Hoover + real(dp), allocatable :: xi_a(:) !% $\xi$ variable in Leimkuhler's notation for Nose-Hoover-Langevin + real(dp) :: p_eta = 0.0_dp !% $p_\eta$ variable in Nose-Hoover and Nose-Hoover-Langevin + real(dp) :: f_eta = 0.0_dp !% The force on the Nose-Hoover(-Langevin) conjugate momentum + real(dp) :: Q = 0.0_dp !% Thermostat mass in Nose-Hoover and Nose-Hoover-Langevin + real(dp) :: NHL_mu = 0.0_dp !% Thermostat mass in all-purpose NHL + real(dp) :: T = 0.0_dp !% Target temperature + real(dp) :: Ndof = 0.0_dp !% The number of degrees of freedom of atoms attached to this thermostat + real(dp) :: work = 0.0_dp !% Work done by this thermostat + real(dp) :: p = 0.0_dp !% External pressure + real(dp) :: gamma_p = 0.0_dp !% Friction coefficient for cell in Langevin NPT + real(dp) :: W_p = 0.0_dp !% Fictious cell mass in Langevin NPT + real(dp) :: epsilon_r = 0.0_dp !% Position of barostat variable + real(dp) :: epsilon_v = 0.0_dp !% Velocity of barostat variable + real(dp) :: epsilon_f = 0.0_dp !% Force on barostat variable + real(dp) :: epsilon_f1 = 0.0_dp !% Force on barostat variable + real(dp) :: epsilon_f2 = 0.0_dp !% Force on barostat variable + real(dp) :: volume_0 = 0.0_dp !% Reference volume + real(dp), dimension(3,3) :: lattice_v = 0.0_dp + real(dp), dimension(3,3) :: lattice_f, lattice_f2 = 0.0_dp + logical :: massive = .false. + + end type thermostat + + interface initialise + module procedure thermostat_initialise + end interface initialise + + interface finalise + module procedure thermostat_finalise, thermostats_finalise + end interface finalise + + interface assignment(=) + module procedure thermostat_assignment, thermostat_array_assignment + end interface assignment(=) + + interface print + module procedure thermostat_print, thermostats_print + end interface + + interface add_thermostat + module procedure thermostats_add_thermostat + end interface add_thermostat + + interface remove_thermostat + module procedure thermostats_remove_thermostat + end interface remove_thermostat + + interface add_thermostats + module procedure thermostats_add_thermostats + end interface add_thermostats + + interface update_thermostat + module procedure thermostats_update_thermostat + end interface update_thermostat + + interface set_degrees_of_freedom + module procedure set_degrees_of_freedom_int, set_degrees_of_freedom_real + end interface set_degrees_of_freedom + + interface nose_hoover_mass + module procedure nose_hoover_mass_int, nose_hoover_mass_real + end interface nose_hoover_mass + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X INITIALISE / FINALISE + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine thermostat_initialise(this,type,T,gamma,Q,p,gamma_p,W_p,volume_0,NHL_gamma,NHL_mu,massive) + + type(thermostat), intent(inout) :: this + integer, intent(in) :: type + real(dp), optional, intent(in) :: T + real(dp), optional, intent(in) :: gamma + real(dp), optional, intent(in) :: Q + real(dp), optional, intent(in) :: p + real(dp), optional, intent(in) :: gamma_p + real(dp), optional, intent(in) :: W_p + real(dp), optional, intent(in) :: volume_0 + real(dp), optional, intent(in) :: NHL_gamma,NHL_mu + logical, optional, intent(in) :: massive + + real(dp) :: use_Q + + if (present(T)) then + if (T < 0.0_dp) call system_abort('initialise: Temperature must be >= 0') + end if + + if (type /= THERMOSTAT_NONE .and. .not.present(T)) & + call system_abort('initialise: T must be specified when turning on a thermostat') + + this%type = type + this%work = 0.0_dp + this%eta = 0.0_dp + if (allocated(this%chi_a)) deallocate(this%chi_a) + if (allocated(this%xi_a)) deallocate(this%xi_a) + this%p_eta = 0.0_dp + this%f_eta = 0.0_dp + this%epsilon_r = 0.0_dp + this%epsilon_v = 0.0_dp + this%epsilon_f = 0.0_dp + this%epsilon_f1 = 0.0_dp + this%epsilon_f2 = 0.0_dp + this%volume_0 = 0.0_dp + this%p = 0.0_dp + this%lattice_v = 0.0_dp + this%lattice_f = 0.0_dp + this%lattice_f2 = 0.0_dp + + use_Q = optional_default(-1.0_dp, Q) + + select case(this%type) + + case(THERMOSTAT_NONE) + + this%T = 0.0_dp + this%gamma = 0.0_dp + this%Q = 0.0_dp + + case(THERMOSTAT_LANGEVIN) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_LANGEVIN does not implement massive flag") + endif + + if (.not.present(gamma)) call system_abort('thermostat initialise: gamma is required for Langevin thermostat') + if (gamma < 0.0_dp) call system_abort('thermostat initialise: gamma must be >= 0 for Langevin') + this%T = T + this%gamma = gamma + this%Q = use_Q + + case(THERMOSTAT_NOSE_HOOVER) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_NOSE_HOOVER does not implement massive flag") + endif + + if (.not.present(Q)) call system_abort('thermostat initialise: Q is required for Nose-Hoover thermostat') + if (Q <= 0.0_dp) call system_abort('thermostat initialise: Q must be > 0') + this%T = T + this%gamma = 0.0_dp + this%Q = Q + + case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_NOSE_HOOVER_LANGEVIN does not implement massive flag") + endif + + if (.not.present(gamma)) & + call system_abort('thermostat initialise: gamma is required for Nose-Hoover-Langevin thermostat') + if (gamma < 0.0_dp) call system_abort('thermostat initialise: gamma must be >= 0') + if (.not.present(Q)) call system_abort('thermostat initialise: Q is required for Nose-Hoover-Langevin thermostat') + if (Q <= 0.0_dp) call system_abort('thermostat initialise: Q must be > 0') + this%T = T + this%gamma = gamma + this%Q = Q + + case(THERMOSTAT_LANGEVIN_NPT) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_LANGEVIN_NPT does not implement massive flag") + endif + + if (.not.present(gamma) .or. .not.present(p) .or. .not.present(gamma_p) .or. .not.present(W_p) .or. .not.present(volume_0) ) & + & call system_abort('thermostat initialise: p, gamma, gamma_p, W_p and volume_0 are required for Langevin NPT baro-thermostat') + this%T = T + this%gamma = gamma + this%Q = 0.0_dp + this%p = p + this%gamma_p = gamma_p + this%W_p = W_p + this%volume_0 = volume_0 + this%Q = use_Q + + case(THERMOSTAT_LANGEVIN_PR) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_LANGEVIN_PR does not implement massive flag") + endif + + if (.not.present(gamma) .or. .not.present(p) .or. .not.present(W_p) .or. .not.present(gamma_p) ) & + & call system_abort('initialise: p, gamma, W_p are required for Langevin Parrinello-Rahman baro-thermostat') + this%T = T + this%gamma = gamma + this%Q = 0.0_dp + this%p = p + this%gamma_p = gamma_p + this%W_p = W_p + this%Q = use_Q + + case(THERMOSTAT_NPH_ANDERSEN) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_NPH_ANDERSEN does not implement massive flag") + endif + + if (.not.present(W_p) .or. .not.present(p) .or. .not.present(volume_0) .or. .not.present(gamma_p) ) & + & call system_abort('thermostat initialise: p, W_p and volume_0 are required for Andersen THERMOSTAT_NPH barostat') + this%T = 0.0_dp + this%gamma = 0.0_dp + this%Q = 0.0_dp + this%p = p + this%gamma_p = gamma_p + this%W_p = W_p + this%volume_0 = volume_0 + + case(THERMOSTAT_NPH_PR) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_NPH_PR does not implement massive flag") + endif + + if (.not.present(p) .or. .not.present(W_p) .or. .not.present(gamma_p) ) & + & call system_abort('initialise: p and W_p are required for THERMOSTAT_NPH Parrinello-Rahman barostat') + this%T = 0.0_dp + this%gamma = 0.0_dp + this%Q = 0.0_dp + this%p = p + this%gamma_p = gamma_p + this%W_p = W_p + + case(THERMOSTAT_LANGEVIN_OU) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_LANGEVIN_OU does not implement massive flag") + endif + + if (.not.present(gamma)) call system_abort('thermostat initialise: gamma is required for Langevin OU thermostat') + if (gamma < 0.0_dp) call system_abort('thermostat initialise: gamma must be >= 0 for Langevin OU') + this%T = T + this%gamma = gamma + this%Q = use_Q + + case(THERMOSTAT_LANGEVIN_NPT_NB) + if (present(massive)) then + if (massive) call system_abort("THERMOSTAT_LANGEVIN_NPT_NB does not implement massive flag") + endif + + if (.not.present(gamma) .or. .not.present(p) .or. .not.present(gamma_p) .or. .not. present(W_p) ) & + & call system_abort('thermostat initialise: p, gamma, gamma_p, W_p and volume_0 are required for Langevin NPT baro-thermostat') + this%T = T + this%gamma = gamma + this%Q = use_Q + this%p = p + this%gamma_p = gamma_p + this%W_p = W_p + + case(THERMOSTAT_ALL_PURPOSE) + this%T = T + this%gamma = optional_default(0.0_dp, gamma) + this%NHL_gamma = optional_default(0.0_dp, NHL_gamma) + this%Q = optional_default(-1.0_dp, Q) + this%NHL_mu = optional_default(-1.0_dp, NHL_mu) + this%massive = optional_default(.false., massive) + + + if (count( (/ this%NHL_gamma > 0.0_dp, this%NHL_mu > 0.0_dp /) ) == 1) call system_abort("THERMOSTAT_ALL_PURPOSE needs NHL_gamma="//this%NHL_gamma//" and NHL_mu="//this%NHL_mu//" either both or neither > 0") + + end select + + end subroutine thermostat_initialise + + subroutine thermostat_finalise(this) + + type(thermostat), intent(inout) :: this + + this%type = THERMOSTAT_NONE + this%gamma = 0.0_dp + this%NHL_gamma = 0.0_dp + this%eta = 0.0_dp + this%p_eta = 0.0_dp + this%f_eta = 0.0_dp + this%Q = 0.0_dp + this%NHL_mu = 0.0_dp + this%T = 0.0_dp + this%Ndof = 0.0_dp + this%work = 0.0_dp + this%p = 0.0_dp + this%gamma_p = 0.0_dp + this%W_p = 0.0_dp + this%epsilon_r = 0.0_dp + this%epsilon_v = 0.0_dp + this%epsilon_f = 0.0_dp + this%epsilon_f1 = 0.0_dp + this%epsilon_f2 = 0.0_dp + this%lattice_v = 0.0_dp + this%lattice_f = 0.0_dp + this%lattice_f2 = 0.0_dp + this%massive = .false. + + end subroutine thermostat_finalise + + subroutine thermostat_assignment(to,from) + + type(thermostat), intent(out) :: to + type(thermostat), intent(in) :: from + + to%type = from%type + to%gamma = from%gamma + to%NHL_gamma = from%NHL_gamma + to%eta = from%eta + if (allocated(from%chi_a)) then + if (allocated(to%chi_a)) deallocate(to%chi_a) + allocate(to%chi_a(size(from%chi_a))) + to%chi_a = from%chi_a + else + if (allocated(to%chi_a)) deallocate(to%chi_a) + endif + if (allocated(from%xi_a)) then + if (allocated(to%xi_a)) deallocate(to%xi_a) + allocate(to%xi_a(size(from%xi_a))) + to%xi_a = from%xi_a + else + if (allocated(to%xi_a)) deallocate(to%xi_a) + endif + to%p_eta = from%p_eta + to%Q = from%Q + to%NHL_mu = from%NHL_mu + to%T = from%T + to%Ndof = from%Ndof + to%work = from%work + to%p = from%p + to%gamma_p = from%gamma_p + to%W_p = from%W_p + to%epsilon_r = from%epsilon_r + to%epsilon_v = from%epsilon_v + to%epsilon_f = from%epsilon_f + to%epsilon_f1 = from%epsilon_f1 + to%epsilon_f2 = from%epsilon_f2 + to%volume_0 = from%volume_0 + to%lattice_v = from%lattice_v + to%lattice_f = from%lattice_f + to%lattice_f2 = from%lattice_f2 + to%massive = from%massive + + end subroutine thermostat_assignment + + !% Copy an array of thermostats + subroutine thermostat_array_assignment(to, from) + type(thermostat), allocatable, intent(inout) :: to(:) + type(thermostat), allocatable, intent(in) :: from(:) + + integer :: u(1), l(1), i + + if (allocated(to)) deallocate(to) + u = ubound(from) + l = lbound(from) + allocate(to(l(1):u(1))) + do i=l(1),u(1) + to(i) = from(i) + end do + + end subroutine thermostat_array_assignment + + !% Finalise an array of thermostats + subroutine thermostats_finalise(this) + + type(thermostat), allocatable, intent(inout) :: this(:) + + integer :: i, ua(1), la(1), u, l + + if (allocated(this)) then + ua = ubound(this); u = ua(1) + la = lbound(this); l = la(1) + do i = l, u + call finalise(this(i)) + end do + deallocate(this) + end if + + end subroutine thermostats_finalise + + subroutine thermostats_remove_thermostat(this,index) + type(thermostat), allocatable, intent(inout) :: this(:) + integer, intent(in) :: index + + type(thermostat), allocatable :: temp(:) + integer :: i, l, u, la(1), ua(1) + + if (.not. allocated(this)) & + call system_abort('thermostats array not allocataed') + + la = lbound(this); l=la(1) + ua = ubound(this); u=ua(1) + + if (index < l .or. index > u) & + call system_abort('index '//index//' outside of range '//l//' <= index <= '//u) + + allocate(temp(l:u)) + do i = l,u + temp(i) = this(i) + end do + call finalise(this) + + allocate(this(l:u-1)) + do i = l,u + if (i == index) cycle + this(i) = temp(i) + end do + call finalise(temp) + + end subroutine thermostats_remove_thermostat + + subroutine thermostats_add_thermostat(this,type,T,gamma,Q,p,gamma_p,W_p,volume_0,NHL_gamma,NHL_mu,massive,region_i) + + type(thermostat), allocatable, intent(inout) :: this(:) + integer, intent(in) :: type + real(dp), optional, intent(in) :: T + real(dp), optional, intent(in) :: gamma + real(dp), optional, intent(in) :: Q + real(dp), optional, intent(in) :: p + real(dp), optional, intent(in) :: gamma_p + real(dp), optional, intent(in) :: W_p + real(dp), optional, intent(in) :: volume_0 + real(dp), optional, intent(in) :: NHL_gamma, NHL_mu + logical, optional, intent(in) :: massive + integer, optional, intent(out) :: region_i + + type(thermostat), allocatable :: temp(:) + integer :: i, l, u, la(1), ua(1) + + if (allocated(this)) then + la = lbound(this); l=la(1) + ua = ubound(this); u=ua(1) + allocate(temp(l:u)) + do i = l,u + temp(i) = this(i) + end do + call finalise(this) + else + l=1 + u=0 + end if + + allocate(this(l:u+1)) + + if (allocated(temp)) then + do i = l,u + this(i) = temp(i) + end do + call finalise(temp) + end if + + call initialise(this(u+1),type,T=T,gamma=gamma,Q=Q,p=p,gamma_p=gamma_p,W_p=W_p,volume_0=volume_0,NHL_gamma=NHL_gamma,NHL_mu=NHL_mu,massive=massive) + + if (present(region_i)) region_i=u+1 + + end subroutine thermostats_add_thermostat + + subroutine thermostats_add_thermostats(this,type,n,T_a,gamma_a,Q_a,region_i) + + type(thermostat), allocatable, intent(inout) :: this(:) + integer, intent(in) :: type + integer, intent(in) :: n + real(dp), optional, intent(in) :: T_a(:) + real(dp), optional, intent(in) :: gamma_a(:) + real(dp), optional, intent(in) :: Q_a(:) + integer, optional, intent(out) :: region_i + + type(thermostat), allocatable :: temp(:) + integer :: i, l, u, la(1), ua(1) + + if (allocated(this)) then + la = lbound(this); l=la(1) + ua = ubound(this); u=ua(1) + allocate(temp(l:u)) + do i = l,u + temp(i) = this(i) + end do + call finalise(this) + else + l=1 + u=0 + end if + + allocate(this(l:u+n)) + + if (allocated(temp)) then + do i = l,u + this(i) = temp(i) + end do + call finalise(temp) + end if + + do i=1, n + if (present(T_a)) then + if (present(Q_a)) then + if (present(gamma_a)) then + call initialise(this(u+i),type,T=T_a(i),gamma=gamma_a(i),Q=Q_a(i)) + else + call initialise(this(u+i),type,T=T_a(i),Q=Q_a(i)) + endif + else ! no Q_a + if (present(gamma_a)) then + call initialise(this(u+i),type,T=T_a(i),gamma=gamma_a(i)) + else + call initialise(this(u+i),type,T=T_a(i)) + endif + endif + else ! no T_A + if (present(Q_a)) then + if (present(gamma_a)) then + call initialise(this(u+i),type,gamma=gamma_a(i),Q=Q_a(i)) + else + call initialise(this(u+i),type,Q=Q_a(i)) + endif + else ! no Q_aa + if (present(gamma_a)) then + call initialise(this(u+i),type,gamma=gamma_a(i)) + else + call initialise(this(u+i),type) + endif + endif + endif + end do + + if (present(region_i)) region_i=u+1 + + end subroutine thermostats_add_thermostats + + subroutine thermostats_update_thermostat(this,T,p,w_p) + + type(thermostat), intent(inout) :: this + real(dp), optional, intent(in) :: T + real(dp), optional, intent(in) :: p + real(dp), optional, intent(in) :: w_p + + if( present(T) ) this%T = T + if( present(p) ) this%p = p + if( present(w_p) ) this%w_p = w_p + + endsubroutine thermostats_update_thermostat + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X PRINTING + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine thermostat_print(this,file) + + type(thermostat), intent(in) :: this + type(inoutput), optional, intent(in) :: file + select case(this%type) + + case(THERMOSTAT_NONE) + call print('Thermostat off',file=file) + + case(THERMOSTAT_LANGEVIN) + call print('Langevin, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& + round(this%eta,5)//' (#), work = '//round(this%work,5)//' eV, Ndof = '// round(this%Ndof,1),file=file) + + case(THERMOSTAT_NOSE_HOOVER) + call print('Nose-Hoover, T = '//round(this%T,2)//' K, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& + round(this%eta,5)//' (#), p_eta = '//round(this%p_eta,5)//' eV fs, work = '//round(this%work,5)//' eV, Ndof = ' // round(this%Ndof,1),file=file) + + case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) + call print('Nose-Hoover-Langevin, T = '//round(this%T,2)//' K, Q = '//round(this%Q,5)//& + ' eV fs^2, gamma = '//round(this%gamma,5)//' fs^-1, eta = '//round(this%eta,5)//& + ' , p_eta = '//round(this%p_eta,5)//' eV fs, work = '//round(this%work,5)//' eV, Ndof = ' // round(this%Ndof,1),file=file) + + case(THERMOSTAT_LANGEVIN_NPT) + call print('Langevin NPT, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& + round(this%eta,5)//' (#), work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, gamma_p = '// & + round(this%gamma_p,5)//' fs^-1, W_p = '//round(this%W_p,5)//' au, Ndof = ' // round(this%Ndof,1),file=file) + + case(THERMOSTAT_LANGEVIN_PR) + call print('Langevin PR, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& + round(this%eta,5)//' (#), work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, gamma_p = '// & + round(this%gamma_p,5)//' fs^-1, W_p = '//round(this%W_p,5)//' au',file=file) + + case(THERMOSTAT_NPH_ANDERSEN) + call print('Andersen THERMOSTAT_NPH, work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, W_p = '//round(this%W_p,5)//' au, Ndof = ' // round(this%Ndof,1),file=file) + + case(THERMOSTAT_NPH_PR) + call print('Parrinello-Rahman THERMOSTAT_NPH, work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, W_p = '//round(this%W_p,5)//' au, Ndof = ' // round(this%Ndof,1),file=file) + + case(THERMOSTAT_LANGEVIN_OU) + call print('Langevin OU, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& + round(this%eta,5)//' (#), work = '//round(this%work,5)//' eV, Ndof = '// round(this%Ndof,1),file=file) + + case(THERMOSTAT_LANGEVIN_NPT_NB) + call print('Langevin NPT, T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, eta = '//& + round(this%eta,5)//' (#), work = '// round(this%work,5)//' eV, p = '//round(this%p,5)//' eV/A^3, gamma_p = '// & + round(this%gamma_p,5)//' fs^-1, W_p = '//round(this%W_p,5)//' au, Ndof = ' // round(this%Ndof,1),file=file) + + case(THERMOSTAT_ALL_PURPOSE) + if (this%massive) then + call print('All-purpose adaptive-Langevin , T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, chi = '//& + 'too many to list (#), xi = too many to list (#), Ndof = ' // round(this%Ndof,1),file=file) + else + if (.not. allocated(this%chi_a)) then + call print('All-purpose adaptive-Langevin , T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, NHL_mu = '//round(this%NHL_mu,5)//' eV fs^2, '//& + 'NHL_gamma = '//round(this%NHL_gamma,5)//' fs^-1, chi = '//round(0.0_dp,5)//' (#), xi = '//round(0.0_dp,5)//' Ndof = ' // round(this%Ndof,1),file=file) + else + call print('All-purpose adaptive-Langevin , T = '//round(this%T,2)//' K, gamma = '//round(this%gamma,5)//' fs^-1, Q = '//round(this%Q,5)//' eV fs^2, NHL_mu = '//round(this%NHL_mu,5)//' eV fs^2, '//& + 'NHL_gamma = '//round(this%NHL_gamma,5)//' fs^-1, chi = '//round(this%chi_a(1),5)//' (#), xi = '//round(this%xi_a(1),5)//' Ndof = ' // round(this%Ndof,1),file=file) + endif + endif + + end select + + end subroutine thermostat_print + + subroutine thermostats_print(this,file) + + type(thermostat), allocatable, intent(in) :: this(:) + type(inoutput), optional, intent(in) :: file + + integer :: u, l, i, ua(1), la(1) + + la=lbound(this); l=la(1) + ua=ubound(this); u=ua(1) + + do i = l,u + call print('Thermostat '//i//':',file=file) + call print(this(i),file) + end do + + end subroutine thermostats_print + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X SETTING Ndof + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine set_degrees_of_freedom_int(this,Ndof) + + type(thermostat), intent(inout) :: this + integer, intent(in) :: Ndof + + this%Ndof = real(Ndof,dp) + + end subroutine set_degrees_of_freedom_int + + subroutine set_degrees_of_freedom_real(this,Ndof) + + type(thermostat), intent(inout) :: this + real(dp), intent(in) :: Ndof + + this%Ndof = Ndof + + end subroutine set_degrees_of_freedom_real + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X CHOOSING NOSE-HOOVER(-THERMOSTAT_LANGEVIN) MASS + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + pure function nose_hoover_mass_int(Ndof,T,tau) result(Q) + + integer, intent(in) :: Ndof + real(dp), intent(in) :: T, tau + real(dp) :: Q + + Q = nose_hoover_mass_real(real(Ndof,dp),T,tau) + + end function nose_hoover_mass_int + + pure function nose_hoover_mass_real(Ndof,T,tau) result(Q) + + real(dp), intent(in) :: Ndof, T, tau + real(dp) :: Q + + if (tau < 0.0) then + Q = -1.0_dp + else + Q = Ndof*BOLTZMANN_K*T*tau*tau/(4.0_dp*PI*PI) + endif + + end function nose_hoover_mass_real + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT ROUTINES + !X + !X These routines interleave the usual velocity Verlet steps and should modify + !X the velocities and accelerations as required: + !X + !X advance_verlet1 + !X 00 (barostat_pre_vel1) * + !X 10 (thermostat_pre_vel1) * + !X 20 v(t+dt/2) = v(t) + a(t)dt/2 + !X 30 (thermostat_post_vel1_pre_pos) + !X 40 r(t+dt) = r(t) + v(t+dt/2)dt + !X 50 (thermostat_post_pos_pre_calc) + !X 60 (barostat_post_pos_pre_calc) * + !X calc F, virial + !X advance_verlet2 + !X 70 (thermostat_post_calc_pre_vel2) * + !X 80 v(t+dt) = v(t+dt/2) + a(t+dt)dt/2 + !X 90 (thermostat_post_vel2) * + !X 100 (barostat_post_vel2) * + !X + !X * marks routines that are needed in the refactored barostat/thermostat plan + !X + !X A thermostat can be applied to part of the atomic system by passing an integer + !X atomic property and the value it must have. + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine thermostat_pre_vel1(this,at,dt,property,value,virial) + + type(thermostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + character(*), intent(in) :: property + integer, intent(in) :: value + real(dp), dimension(3,3), intent(in), optional :: virial + + real(dp) :: decay, K, volume_p, rv_mag, OU_dv(3) + real(dp), dimension(3,3) :: lattice_p, ke_virial, decay_matrix, decay_matrix_eigenvectors, exp_decay_matrix + real(dp), dimension(3) :: decay_matrix_eigenvalues + integer :: i + integer, dimension(:), pointer :: prop_ptr + real(dp) :: delta_K + + if (.not. assign_pointer(at,property,prop_ptr)) then + call system_abort('thermostat_pre_vel1: cannot find property '//property) + end if + + select case(this%type) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_LANGEVIN) + + !Decay the velocity for dt/2. The random force will have been added to acc during the + !previous timestep. + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + else + this%eta = 0.0_dp + endif + + decay = exp(-0.5_dp*(this%gamma+this%eta)*dt) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + endif + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X NOSE-HOOVER + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_NOSE_HOOVER) + + !Propagate eta for dt (this saves doing it twice, for dt/2) + if (this%Q > 0.0_dp) then + this%eta = this%eta + this%p_eta*dt/this%Q + else + this%eta = 0.0_dp + endif + + !Decay the velocities using p_eta for dt/2. Also, accumulate the (pre-decay) + !kinetic energy (x2) and use to integrate the 'work' value + K = 0.0_dp + if (this%Q > 0.0_dp) then + decay = exp(-0.5_dp*this%p_eta*dt/this%Q) + else + decay = 1.0_dp + endif + + ! dvelo = 0.0_dp + ! ntherm = 0 + do i=1, at%N + if (prop_ptr(i) /= value) cycle + K = K + at%mass(i)*normsq(at%velo(:,i)) + ! dvelo = dvelo + norm(at%velo(:,i))*abs(1.0_dp-decay) + ! ntherm = ntherm + 1 + at%velo(:,i) = at%velo(:,i)*decay + end do + ! call print("Thermostat " // value //" thermostat_pre_vel1 N-H "//(dvelo/real(ntherm,dp))) + + !Propagate the work for dt/2 + if (this%Q > 0.0_dp) then + this%work = this%work + 0.5_dp*this%p_eta*K*dt/this%Q + endif + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X NOSE-HOOVER-THERMOSTAT_LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) + + !Decay p_eta for dt/2 and propagate it for dt/2 + this%p_eta = this%p_eta*exp(-0.5_dp*this%gamma*dt) + 0.5_dp*this%f_eta*dt + !Propagate eta for dt (this saves doing it twice, for dt/2) + if (this%Q > 0.0_dp) then + this%eta = this%eta + this%p_eta*dt/this%Q + else + this%eta = 0.0_dp + endif + + !Decay the velocities using p_eta for dt/2 and accumulate Ek (as in NH) for + !work integration + if (this%Q > 0.0_dp) then + decay = exp(-0.5_dp*this%p_eta*dt/this%Q) + else + decay = 1.0_dp + endif + K = 0.0_dp + + do i = 1, at%N + if(prop_ptr(i) /= value) cycle + K = K + at%mass(i)*normsq(at%velo(:,i)) + at%velo(:,i) = at%velo(:,i)*decay + end do + + !Propagate work + if (this%Q > 0.0_dp) then + this%work = this%work + 0.5_dp*this%p_eta*K*dt/this%Q + endif + + ! advance_verlet1 will do conservative + random force parts of v half step + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN NPT, Andersen barostat + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_LANGEVIN_NPT) + + if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: NPT & + & simulation, but virial has not been passed') + + this%epsilon_r = this%epsilon_r + 0.5_dp*this%epsilon_v*dt + volume_p = exp(3.0_dp*this%epsilon_r)*this%volume_0 + lattice_p = at%lattice * (volume_p/cell_volume(at))**(1.0_dp/3.0_dp) + call set_lattice(at,lattice_p, scale_positions=.false.) + + this%epsilon_f1 = (1.0_dp + 3.0_dp/this%Ndof)*sum(at%mass*sum(at%velo**2,dim=1)) + trace(virial) & + & - 3.0_dp * volume_p * this%p + + this%epsilon_f = this%epsilon_f1 + this%epsilon_f2 + this%epsilon_v = this%epsilon_v + 0.5_dp * dt * this%epsilon_f / this%W_p + + !Decay the velocity for dt/2. The random force will have been added to acc during the + !previous timestep. + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + else + this%eta = 0.0_dp + endif + + decay = exp(-0.5_dp*dt*((this%gamma+this%eta)+(1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + at%pos(:,i) = at%pos(:,i)*( 1.0_dp + this%epsilon_v * dt ) + end do + !at%pos = at%pos*exp(this%epsilon_vp * dt) ???? + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + endif + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN NPT, Parrinello-Rahman barostat + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_LANGEVIN_PR) + + if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: NPT & + & simulation, but virial has not been passed') + + lattice_p = at%lattice + 0.5_dp * dt * matmul(this%lattice_v,at%lattice) + + call set_lattice(at,lattice_p, scale_positions=.false.) + volume_p = cell_volume(at) + + ke_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) + + this%lattice_f = ke_virial + virial - this%p*volume_p*matrix_one + trace(ke_virial)*matrix_one/this%Ndof + this%lattice_f2 + this%lattice_v = this%lattice_v + 0.5_dp*dt*this%lattice_f / this%W_p + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + else + this%eta = 0.0_dp + endif + + !Decay the velocity for dt/2. The random force will have been added to acc during the + !previous timestep. + + decay_matrix = -0.5_dp*dt*( (this%gamma+this%eta)*matrix_one + this%lattice_v + trace(this%lattice_v)*matrix_one/this%Ndof ) + decay_matrix = ( decay_matrix + transpose(decay_matrix) ) / 2.0_dp ! Making sure the matrix is exactly symmetric + call diagonalise(decay_matrix,decay_matrix_eigenvalues,decay_matrix_eigenvectors) + exp_decay_matrix = matmul( decay_matrix_eigenvectors, matmul( diag(exp(decay_matrix_eigenvalues)), transpose(decay_matrix_eigenvectors) ) ) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = matmul(exp_decay_matrix,at%velo(:,i)) + !at%velo(:,i) = at%velo(:,i) + matmul(decay_matrix,at%velo(:,i)) + at%pos(:,i) = at%pos(:,i) + matmul(this%lattice_v,at%pos(:,i))*dt + end do + !at%pos = at%pos*exp(this%epsilon_vp * dt) ???? + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + endif + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_NPH, Andersen barostat + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_NPH_ANDERSEN) + + if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: THERMOSTAT_NPH & + & simulation, but virial has not been passed') + + this%epsilon_r = this%epsilon_r + 0.5_dp*this%epsilon_v*dt + volume_p = exp(3.0_dp*this%epsilon_r)*this%volume_0 + lattice_p = at%lattice * (volume_p/cell_volume(at))**(1.0_dp/3.0_dp) + call set_lattice(at,lattice_p, scale_positions=.false.) + + this%epsilon_f = (1.0_dp + 3.0_dp/this%Ndof)*sum(at%mass*sum(at%velo**2,dim=1)) + trace(virial) & + & - 3.0_dp * volume_p * this%p + + this%epsilon_v = this%epsilon_v + 0.5_dp * dt * this%epsilon_f / this%W_p + + !Decay the velocity for dt/2. The random force will have been added to acc during the + !previous timestep. + + decay = exp(-0.5_dp*dt*(1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + at%pos(:,i) = at%pos(:,i)*( 1.0_dp + this%epsilon_v * dt ) + end do + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_NPH, Parrinello-Rahman barostat + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_NPH_PR) + + if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: THERMOSTAT_NPH & + & simulation, but virial has not been passed') + + lattice_p = at%lattice + 0.5_dp * dt * matmul(this%lattice_v,at%lattice) + + call set_lattice(at,lattice_p, scale_positions=.false.) + volume_p = cell_volume(at) + + ke_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) + + this%lattice_f = ke_virial + virial - this%p*volume_p*matrix_one + trace(ke_virial)*matrix_one/this%Ndof + this%lattice_v = this%lattice_v + 0.5_dp*dt*this%lattice_f / this%W_p + + !Decay the velocity for dt/2. + + decay_matrix = -0.5_dp*dt*( this%lattice_v + trace(this%lattice_v)*matrix_one/this%Ndof ) + decay_matrix = ( decay_matrix + transpose(decay_matrix) ) / 2.0_dp ! Making sure the matrix is exactly symmetric + call diagonalise(decay_matrix,decay_matrix_eigenvalues,decay_matrix_eigenvectors) + exp_decay_matrix = matmul( decay_matrix_eigenvectors, matmul( diag(exp(decay_matrix_eigenvalues)), transpose(decay_matrix_eigenvectors) ) ) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = matmul(exp_decay_matrix,at%velo(:,i)) + !at%velo(:,i) = at%velo(:,i) + matmul(decay_matrix,at%velo(:,i)) + at%pos(:,i) = at%pos(:,i) + matmul(this%lattice_v,at%pos(:,i))*dt + end do + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN with Ornstein-Uhlenbeck dynamics (Leimkuhler e-mail) + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_LANGEVIN_OU) + + !Decay the velocity for dt/2 by eta (aka chi) + + if (this%eta /= 0.0_dp) then + decay = exp(-0.5_dp*this%eta*dt) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + endif + + case(THERMOSTAT_LANGEVIN_NPT_NB) + if( .not. present(virial) ) call system_abort('thermostat_pre_vel1: NPT & + simulation, but virial has not been passed') + + ! half step epsilon_v, drag and force (from last step) parts + this%epsilon_v = this%epsilon_v*exp(-0.5_dp*dt*this%gamma_p) + this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_p + + ! half step barostat drag part of v + decay = exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) + at%velo = at%velo*decay + + ! Leimkuhler+Jones adaptive Langevin + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + else + this%eta = 0.0_dp + endif + + ! half step Langevin drag part of v + decay = exp(-0.5_dp*dt*(this%gamma+this%eta)) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + + ! Leimkuhler+Jones adaptive Langevin + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + endif + + + ! half step position affine defomration + lattice_p = at%lattice + call set_lattice(at, lattice_p*exp(0.5_dp*dt*this%epsilon_v), scale_positions=.false.) + at%pos = at%pos*exp(0.5_dp*dt*this%epsilon_v) + + case(THERMOSTAT_ALL_PURPOSE) + !TIME_PROPAG_TEX 10 before first Verlet velocity step (thermostat\_pre\_vel1) + !TIME_PROPAG_TEX 10 + !TIME_PROPAG_TEX 10 $\chi$ Nose Hoover extended DOF (also part of open Langevin) + !TIME_PROPAG_TEX 10 + !TIME_PROPAG_TEX 10 $\gamma$ Langevin decay rate = 1/time constant (also part of open Langevin) + !TIME_PROPAG_TEX 10 + !TIME_PROPAG_TEX 10 $\xi$ Nose Hoover Langevin extended DOF + !TIME_PROPAG_TEX 10 + !TIME_PROPAG_TEX 10 $r.v.$ is normal random variable, variance 1 + !TIME_PROPAG_TEX 10 + !TIME_PROPAG_TEX 10 $$ v = v \exp(-(\tau/2) \gamma) + \sqrt{k_B T \frac{1-\exp(-\tau\gamma)}{m}}~r.v.$$ + !TIME_PROPAG_TEX 10 $$ \Delta K = 1/2 \left( \sum_i m_i \left| v_i \right|^2 - N_d k_B T \right) $$ + !TIME_PROPAG_TEX 10 $$ \chi = \chi + (\tau/2) \Delta K/Q $$ + !TIME_PROPAG_TEX 10 $$ \xi = \xi + (\tau/2) \Delta K/\mu $$ + !TIME_PROPAG_TEX 10 $$ v = v \exp(-0.25 \tau (\chi + \xi)) $$ + !TIME_PROPAG_TEX 10 $$ \xi = \xi \exp\left( -(\tau/2) \gamma_\mathrm{NHL} \right) + \sqrt{k_B T \frac{1-\exp(-\tau \gamma_\mathrm{NHL})}{\mu}}~r.v. $$ + !TIME_PROPAG_TEX 10 $$ v = v \exp(-0.25 \tau (\chi + \xi)) $$ + !TIME_PROPAG_TEX 10 $$ \Delta K = 1/2 \left( \sum_i m_i \left| v_i \right|^2 - N_d k_B T \right) $$ + !TIME_PROPAG_TEX 10 $$ \xi = \xi + (\tau/2) \Delta K/\mu $$ + !TIME_PROPAG_TEX 10 $$ \chi = \chi + (\tau/2) \Delta K/Q $$ + !TIME_PROPAG_TEX 10 + + if (this%gamma > 0.0_dp .or. (this%NHL_gamma > 0.0_dp .and. this%NHL_mu > 0.0_dp)) call system_resync_rng() + + if (.not. allocated(this%chi_a)) then + if (this%massive) then + allocate(this%chi_a(count(prop_ptr == value))) + allocate(this%xi_a(count(prop_ptr == value))) + else + allocate(this%chi_a(1)) + allocate(this%xi_a(1)) + endif + this%chi_a = 0.0_dp + this%xi_a = 0.0_dp + endif + + ! Random numbers may have been used at different rates on different MPI processes: + ! we must resync the random number if we want the same numbers on each process. + call system_resync_rng() + + if (this%gamma > 0.0_dp) then + ! Do the Ornstein-Uhlenbeck half step + decay=exp(-0.5_dp*this%gamma*dt) + rv_mag = sqrt(BOLTZMANN_K*this%T*(1.0_dp-decay**2)) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + OU_dv = rv_mag/sqrt(at%mass(i))*ran_normal3() + at%velo(:,i) = decay*at%velo(:,i) + OU_dv + end do + end if + + ! Leimkuhler+Jones adaptive Langevin + ! propagate chi and xi dt/4 + if (this%Q > 0.0_dp .or. this%NHL_mu > 0.0_dp) then + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + delta_K = open_Langevin_delta_K(1, at%mass(i:i), at%velo(1:3,i:i), 3.0_dp, this%T, prop_ptr(i:i), value) + if (this%Q > 0.0_dp) this%chi_a(i) = this%chi_a(i) + 0.5_dp*dt*delta_K/this%Q + if (this%NHL_mu > 0.0_dp) this%xi_a(i) = this%xi_a(i) + 0.5_dp*dt*delta_K/this%NHL_mu + end do + else + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + if (this%Q > 0.0_dp) this%chi_a = this%chi_a + 0.5_dp*dt*delta_K/this%Q + if (this%NHL_mu > 0.0_dp) this%xi_a = this%xi_a + 0.5_dp*dt*delta_K/this%NHL_mu + endif + else + this%chi_a = 0.0_dp + this%xi_a = 0.0_dp + endif + + ! quarter step drag part of v + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + decay = exp(-0.25_dp*dt*(this%chi_a(i)+this%xi_a(i))) + at%velo(:,i) = at%velo(:,i)*decay + end do + else + decay = exp(-0.25_dp*dt*(this%chi_a(1)+this%xi_a(1))) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + endif + + ! Langevin half step for xi (if doing NHL) + if (this%NHL_mu > 0.0_dp .and. this%NHL_gamma > 0.0_dp) then + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + this%xi_a(i) = this%xi_a(i)*exp(-0.5_dp*dt*this%NHL_gamma) + sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-dt*this%NHL_gamma))/this%NHL_mu)*ran_normal() + end do + else + this%xi_a = this%xi_a*exp(-0.5_dp*dt*this%NHL_gamma) + sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-dt*this%NHL_gamma))/this%NHL_mu)*ran_normal() + endif + endif + + ! quarter step drag part of v + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + decay = exp(-0.25_dp*dt*(this%chi_a(i)+this%xi_a(i))) + at%velo(:,i) = at%velo(:,i)*decay + end do + else + decay = exp(-0.25_dp*dt*(this%chi_a(1)+this%xi_a(1))) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + endif + + ! Leimkuhler+Jones adaptive Langevin + ! propagate chi and xi dt/4 + if (this%Q > 0.0_dp .or. this%NHL_mu > 0.0_dp) then + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + delta_K = open_Langevin_delta_K(1, at%mass(i:i), at%velo(1:3,i:i), 3.0_dp, this%T, prop_ptr(i:i), value) + if (this%Q > 0.0_dp) this%chi_a(i) = this%chi_a(i) + 0.5_dp*dt*delta_K/this%Q + if (this%NHL_mu > 0.0_dp) this%xi_a(i) = this%xi_a(i) + 0.5_dp*dt*delta_K/this%NHL_mu + end do + else + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + if (this%Q > 0.0_dp) this%chi_a = this%chi_a + 0.5_dp*dt*delta_K/this%Q + if (this%NHL_mu > 0.0_dp) this%xi_a = this%xi_a + 0.5_dp*dt*delta_K/this%NHL_mu + endif + endif + + end select + + end subroutine thermostat_pre_vel1 + + subroutine thermostat_post_vel1_pre_pos(this,at,dt,property,value) + + type(thermostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + character(*), intent(in) :: property + integer, intent(in) :: value + + integer, pointer, dimension(:) :: prop_ptr + + if (.not. assign_pointer(at,property,prop_ptr)) then + call system_abort('thermostat_post_vel1_pre_pos: cannot find property '//property) + end if + + select case(this%type) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !case(THERMOSTAT_LANGEVIN) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X NOSE-HOOVER + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !case(THERMOSTAT_NOSE_HOOVER) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X NOSE-HOOVER-THERMOSTAT_LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + end select + + end subroutine thermostat_post_vel1_pre_pos + + subroutine thermostat_post_pos_pre_calc(this,at,dt,property,value) + + type(thermostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + character(*), intent(in) :: property + integer, intent(in) :: value + + real(dp) :: lattice_p(3,3) + + select case(this%type) + + case(THERMOSTAT_LANGEVIN_NPT_NB) + + ! half step position affine defomration + lattice_p = at%lattice + call set_lattice(at, lattice_p*exp(0.5_dp*dt*this%epsilon_v), scale_positions=.false.) + at%pos = at%pos*exp(0.5_dp*dt*this%epsilon_v) + + end select + + end subroutine thermostat_post_pos_pre_calc + + subroutine thermostat_post_calc_pre_vel2(this,at,dt,property,value) + + type(thermostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + character(*), intent(in) :: property + integer, intent(in) :: value + + real(dp) :: R, a(3) + integer :: i + integer, pointer, dimension(:) :: prop_ptr + real(dp) :: delta_K + + if (.not. assign_pointer(at,property,prop_ptr)) then + call system_abort('thermostat_post_calc_pre_vel2: cannot find property '//property) + end if + + select case(this%type) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + case(THERMOSTAT_LANGEVIN,THERMOSTAT_LANGEVIN_NPT,THERMOSTAT_LANGEVIN_PR,THERMOSTAT_LANGEVIN_NPT_NB) + + ! Add the random acceleration + R = 2.0_dp*this%gamma*BOLTZMANN_K*this%T/dt + + ! Random numbers may have been used at different rates on different MPI processes: + ! we must resync the random number if we want the same numbers on each process. + call system_resync_rng() + + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + a = sqrt(R/at%mass(i))*ran_normal3() + at%acc(:,i) = at%acc(:,i) + a + end do + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X NOSE-HOOVER + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !case(THERMOSTAT_NOSE_HOOVER) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X NOSE-HOOVER-THERMOSTAT_LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) nothing to be done + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN with Ornstein-Uhlenbeck dynamics (Leimkuhler e-mail) + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_LANGEVIN_OU) + + ! propagate eta (a.k.a. chi) for a full step + + if (this%Q > 0.0_dp) then + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + dt*2.0_dp*delta_K/this%Q + endif + + end select + + end subroutine thermostat_post_calc_pre_vel2 + + subroutine thermostat_post_vel2(this,at,dt,property,value,virial) + + type(thermostat), intent(inout) :: this + type(atoms), intent(inout) :: at + real(dp), intent(in) :: dt + character(*), intent(in) :: property + integer, intent(in) :: value + real(dp), dimension(3,3), intent(in), optional :: virial + + real(dp) :: decay, K, volume_p, f_cell, rv_mag, OU_dv(3) + real(dp), dimension(3,3) :: lattice_p, ke_virial, decay_matrix, decay_matrix_eigenvectors, exp_decay_matrix, random_lattice + real(dp), dimension(3) :: decay_matrix_eigenvalues + integer :: i, j + integer, pointer, dimension(:) :: prop_ptr + real(dp) :: delta_K + real(dp) :: OU_random_dv_mag + + if (.not. assign_pointer(at,property,prop_ptr)) then + call system_abort('thermostat_post_vel2: cannot find property '//property) + end if + + select case(this%type) + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_LANGEVIN) + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + else + this%eta = 0.0_dp + endif + + !Decay the velocities for dt/2 again + decay = exp(-0.5_dp*(this%gamma+this%eta)*dt) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + endif + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X NOSE-HOOVER + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_NOSE_HOOVER) + + !Decay the velocities again using p_eta for dt/2, and accumulate the (post-decay) + !kinetic energy (x2) to integrate the 'work' value. + if (this%Q > 0.0_dp) then + decay = exp(-0.5_dp*this%p_eta*dt/this%Q) + else + decay = 1.0_dp + endif + K = 0.0_dp + ! dvelo = 0.0_dp + ! ntherm = 0 + do i=1, at%N + if (prop_ptr(i) /= value) cycle + ! dvelo = dvelo + norm(at%velo(:,i))*abs(1.0_dp-decay) + ! ntherm = ntherm + 1 + at%velo(:,i) = at%velo(:,i)*decay + K = K + at%mass(i)*normsq(at%velo(:,i)) + end do + ! call print("Thermostat " // value //" thermostat_post_vel2 N-H "//(dvelo/real(ntherm,dp))) + + !Calculate new f_eta... + this%f_eta = 0.0_dp + do i = 1, at%N + if (prop_ptr(i) == value) this%f_eta = this%f_eta + at%mass(i)*normsq(at%velo(:,i)) + end do + this%f_eta = this%f_eta - this%Ndof*BOLTZMANN_K*this%T + + !Propagate p_eta for dt/2 + this%p_eta = this%p_eta + 0.5_dp*this%f_eta*dt + + !Propagate the work for dt/2 + if (this%Q > 0.0_dp) then + this%work = this%work + 0.5_dp*this%p_eta*K*dt/this%Q + endif + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X NOSE-HOOVER-THERMOSTAT_LANGEVIN + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_NOSE_HOOVER_LANGEVIN) + ! Random numbers may have been used at different rates on different MPI processes: + ! we must resync the random number if we want the same numbers on each process. + call system_resync_rng() + + !Decay the velocities again using p_eta for dt/2, and accumulate Ek for work integration + if (this%Q > 0.0_dp) then + decay = exp(-0.5_dp*this%p_eta*dt/this%Q) + else + decay = 1.0_dp + endif + K = 0.0_dp + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + K = K + at%mass(i)*normsq(at%velo(:,i)) + end do + + !Propagate work + if (this%Q > 0.0_dp) then + this%work = this%work + 0.5_dp*this%p_eta*K*dt/this%Q + endif + + !Calculate new f_eta... + this%f_eta = 0.0_dp + !Deterministic part: + do i = 1, at%N + if (prop_ptr(i) == value) this%f_eta = this%f_eta + at%mass(i)*normsq(at%velo(:,i)) + end do + this%f_eta = this%f_eta - this%Ndof*BOLTZMANN_K*this%T + !Stochastic part: + this%f_eta = this%f_eta + sqrt(2.0_dp*this%gamma*this%Q*BOLTZMANN_K*this%T/dt)*ran_normal() + + !Propagate p_eta for dt/2 then decay it for dt/2 + this%p_eta = this%p_eta + 0.5_dp*this%f_eta*dt + this%p_eta = this%p_eta*exp(-0.5_dp*this%gamma*dt) + + case(THERMOSTAT_LANGEVIN_NPT_NB) + + call system_resync_rng() + + ! Leimkuhler+Jones adaptive Langevin + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + else + this%eta = 0.0_dp + endif + + !Decay the velocities for dt/2 again Langevin part + decay = exp(-0.5_dp*dt*(this%gamma+this%eta)) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + + ! Leimkuhler+Jones adaptive Langevin + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + endif + + + !Decay the velocities for dt/2 again barostat part + decay = exp(-0.5_dp*dt*((1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) + do i = 1, at%N + at%velo(:,i) = at%velo(:,i)*decay + end do + + ! half step with epsilon force + volume_p = cell_volume(at) + f_cell = sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_p*this%W_p/dt)*ran_normal() + this%epsilon_f = (trace(virial)+sum(at%mass*sum(at%velo**2,dim=1))-3.0_dp*volume_p*this%p) + & + 3.0_dp/this%Ndof*sum(at%mass*sum(at%velo**2,dim=1)) + f_cell + this%epsilon_f = this%epsilon_f + f_cell + this%epsilon_v = this%epsilon_v + 0.5_dp*dt*this%epsilon_f/this%W_p + + ! half step with epsilon drag + this%epsilon_v = this%epsilon_v*exp(-0.5_dp*dt*this%gamma_p) + + case(THERMOSTAT_LANGEVIN_NPT) + ! Random numbers may have been used at different rates on different MPI processes: + ! we must resync the random number if we want the same numbers on each process. + call system_resync_rng() + + if( .not. present(virial) ) call system_abort('thermostat_post_vel2: NPT & + & simulation, but virial has not been passed') + + f_cell = sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_p*this%W_p/dt)*ran_normal() + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + else + this%eta = 0.0_dp + endif + + !Decay the velocities for dt/2 again + decay = exp(-0.5_dp*dt*((this%gamma+this%eta)+(1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v)) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + endif + + volume_p = cell_volume(at) + this%epsilon_f = (1.0_dp + 3.0_dp/this%Ndof)*sum(at%mass*sum(at%velo**2,dim=1)) + trace(virial) & + & - 3.0_dp * volume_p * this%p + f_cell + + this%epsilon_v = ( this%epsilon_v + 0.5_dp * dt * this%epsilon_f / this%W_p ) / & + & ( 1.0_dp + 0.5_dp * dt * this%gamma_p ) + + this%epsilon_r = this%epsilon_r + 0.5_dp*this%epsilon_v*dt + volume_p = exp(3.0_dp*this%epsilon_r)*this%volume_0 + lattice_p = at%lattice * (volume_p/cell_volume(at))**(1.0_dp/3.0_dp) + call set_lattice(at,lattice_p, scale_positions=.false.) + + this%epsilon_f2 = f_cell - this%epsilon_v*this%W_p*this%gamma_p + + case(THERMOSTAT_LANGEVIN_PR) + + if( .not. present(virial) ) call system_abort('thermostat_post_vel2: NPT Parrinello-Rahman& + & simulation, but virial has not been passed') + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + else + this%eta = 0.0_dp + endif + + !Decay the velocities for dt/2 again + decay_matrix = -0.5_dp*dt*( (this%gamma+this%eta)*matrix_one + this%lattice_v + trace(this%lattice_v)*matrix_one/this%Ndof ) + decay_matrix = ( decay_matrix + transpose(decay_matrix) ) / 2.0_dp ! Making sure the matrix is exactly symmetric + call diagonalise(decay_matrix,decay_matrix_eigenvalues,decay_matrix_eigenvectors) + exp_decay_matrix = matmul( decay_matrix_eigenvectors, matmul( diag(exp(decay_matrix_eigenvalues)), transpose(decay_matrix_eigenvectors) ) ) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = matmul(exp_decay_matrix,at%velo(:,i)) + !at%velo(:,i) = at%velo(:,i) + matmul(decay_matrix,at%velo(:,i)) + end do + + if (this%Q > 0.0_dp) then + ! propagate eta (Jones and Leimkuhler chi) dt/4 + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + this%eta = this%eta + 0.5_dp*dt*delta_K/this%Q + endif + + do i = 1, 3 + do j = 1, 3 + random_lattice(j,i) = sqrt(2.0_dp*BOLTZMANN_K*this%T*this%gamma_p*this%W_p/dt)*ran_normal() + enddo + enddo + random_lattice = ( random_lattice + transpose(random_lattice) ) / 2.0_dp + + volume_p = cell_volume(at) + ke_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) + this%lattice_f = ke_virial + virial - this%p*volume_p*matrix_one + trace(ke_virial)*matrix_one/this%Ndof + random_lattice + + this%lattice_v = ( this%lattice_v + 0.5_dp*dt*this%lattice_f / this%W_p ) / ( 1.0_dp + 0.5_dp * dt * this%gamma_p ) + + lattice_p = at%lattice + 0.5_dp * dt * matmul(this%lattice_v,at%lattice) + call set_lattice(at,lattice_p, scale_positions=.false.) + + this%lattice_f2 = random_lattice - this%gamma_p * this%lattice_v * this%W_p + + case(THERMOSTAT_NPH_ANDERSEN) + + if( .not. present(virial) ) call system_abort('thermostat_post_vel2: THERMOSTAT_NPH & + & simulation, but virial has not been passed') + + !Decay the velocities for dt/2 again + decay = exp(-0.5_dp*dt*(1.0_dp + 3.0_dp/this%Ndof)*this%epsilon_v) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + + volume_p = cell_volume(at) + this%epsilon_f = (1.0_dp + 3.0_dp/this%Ndof)*sum(at%mass*sum(at%velo**2,dim=1)) + trace(virial) & + & - 3.0_dp * volume_p * this%p + + this%epsilon_v = ( this%epsilon_v + 0.5_dp * dt * this%epsilon_f / this%W_p ) + + this%epsilon_r = this%epsilon_r + 0.5_dp*this%epsilon_v*dt + volume_p = exp(3.0_dp*this%epsilon_r)*this%volume_0 + lattice_p = at%lattice * (volume_p/cell_volume(at))**(1.0_dp/3.0_dp) + call set_lattice(at,lattice_p, scale_positions=.false.) + + case(THERMOSTAT_NPH_PR) + + if( .not. present(virial) ) call system_abort('thermostat_post_vel2: THERMOSTAT_NPH Parrinello-Rahman& + & simulation, but virial has not been passed') + + !Decay the velocities for dt/2 again + decay_matrix = -0.5_dp*dt*( this%lattice_v + trace(this%lattice_v)*matrix_one/this%Ndof ) + decay_matrix = ( decay_matrix + transpose(decay_matrix) ) / 2.0_dp ! Making sure the matrix is exactly symmetric + call diagonalise(decay_matrix,decay_matrix_eigenvalues,decay_matrix_eigenvectors) + exp_decay_matrix = matmul( decay_matrix_eigenvectors, matmul( diag(exp(decay_matrix_eigenvalues)), transpose(decay_matrix_eigenvectors) ) ) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = matmul(exp_decay_matrix,at%velo(:,i)) + !at%velo(:,i) = at%velo(:,i) + matmul(decay_matrix,at%velo(:,i)) + end do + + volume_p = cell_volume(at) + ke_virial = matmul(at%velo*spread(at%mass,dim=1,ncopies=3),transpose(at%velo)) + this%lattice_f = ke_virial + virial - this%p*volume_p*matrix_one + trace(ke_virial)*matrix_one/this%Ndof + + this%lattice_v = this%lattice_v + 0.5_dp*dt*this%lattice_f / this%W_p + lattice_p = at%lattice + 0.5_dp * dt * matmul(this%lattice_v,at%lattice) + call set_lattice(at,lattice_p, scale_positions=.false.) + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X THERMOSTAT_LANGEVIN Ornstein-Uhlenbeck + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + case(THERMOSTAT_LANGEVIN_OU) + ! Random numbers may have been used at different rates on different MPI processes: + ! we must resync the random number if we want the same numbers on each process. + call system_resync_rng() + + !Decay the velocities for dt/2 again by eta (aka chi) + if (this%eta /= 0.0_dp) then + decay = exp(-0.5_dp*this%eta*dt) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + endif + + !Decay the velocities for dt with gamma + decay = exp(-this%gamma*dt) + ! add random force + OU_random_dv_mag = sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-2.0_dp*this%gamma*dt))) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + OU_random_dv_mag/sqrt(at%mass(i))*ran_normal3() + end do + + case(THERMOSTAT_ALL_PURPOSE) + !TIME_PROPAG_TEX 90 after second Verlet velocity step (thermostat\_post\_vel2) + !TIME_PROPAG_TEX 90 + !TIME_PROPAG_TEX 90 $$ \Delta K = 1/2 \left( \sum_i m_i \left| v_i \right|^2 - N_d k_B T \right)~r.v.$$ + !TIME_PROPAG_TEX 90 $$ \chi = \chi + (\tau/2) \Delta K/Q $$ + !TIME_PROPAG_TEX 90 $$ \xi = \xi + (\tau/2) \Delta K/\mu $$ + !TIME_PROPAG_TEX 90 $$ v = v \exp(-0.25 \tau (\chi + \xi)) $$ + !TIME_PROPAG_TEX 90 $$ \xi = \xi \exp\left( -(\tau/2) \gamma_\mathrm{NHL} \right) + \sqrt{k_B T \frac{1-\exp(-\tau \gamma_\mathrm{NHL})}{\mu}}~r.v. $$ + !TIME_PROPAG_TEX 90 $$ v = v \exp(-0.25 \tau (\chi + \xi)) $$ + !TIME_PROPAG_TEX 90 $$ \Delta K = 1/2 \left( \sum_i m_i \left| v_i \right|^2 - N_d k_B T \right) $$ + !TIME_PROPAG_TEX 90 $$ \xi = \xi + (\tau/2) \Delta K/\mu $$ + !TIME_PROPAG_TEX 90 $$ \chi = \chi + (\tau/2) \Delta K/Q $$ + !TIME_PROPAG_TEX 90 $$ v = v \exp(-(\tau/2) \gamma) + \sqrt{k_B T \frac{1-\exp(-\tau\gamma)}{m}} $$ + !TIME_PROPAG_TEX 90 + + if (this%gamma > 0.0_dp .or. (this%NHL_gamma > 0.0_dp .and. this%NHL_mu > 0.0_dp)) call system_resync_rng() + + ! Leimkuhler+Jones adaptive Langevin + ! propagate chi and xi dt/4 + if (this%Q > 0.0_dp .or. this%NHL_mu > 0.0_dp) then + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + delta_K = open_Langevin_delta_K(1, at%mass(i:i), at%velo(1:3,i:i), 3.0_dp, this%T, prop_ptr(i:i), value) + if (this%Q > 0.0_dp) this%chi_a(i) = this%chi_a(i) + 0.5_dp*dt*delta_K/this%Q + if (this%NHL_mu > 0.0_dp) this%xi_a(i) = this%xi_a(i) + 0.5_dp*dt*delta_K/this%NHL_mu + end do + else + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + if (this%Q > 0.0_dp) this%chi_a = this%chi_a + 0.5_dp*dt*delta_K/this%Q + if (this%NHL_mu > 0.0_dp) this%xi_a = this%xi_a + 0.5_dp*dt*delta_K/this%NHL_mu + endif + else + this%chi_a = 0.0_dp + this%xi_a = 0.0_dp + endif + + ! quarter step drag part of v + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + decay = exp(-0.25_dp*dt*(this%chi_a(i)+this%xi_a(i))) + at%velo(:,i) = at%velo(:,i)*decay + end do + else + decay = exp(-0.25_dp*dt*(this%chi_a(1)+this%xi_a(1))) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + endif + + ! Langevin half step for xi (if doing NHL) + if (this%NHL_mu > 0.0_dp .and. this%NHL_gamma > 0.0_dp) then + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + this%xi_a(i) = this%xi_a(i)*exp(-0.5_dp*dt*this%NHL_gamma) + sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-dt*this%NHL_gamma))/this%NHL_mu)*ran_normal() + end do + else + this%xi_a = this%xi_a*exp(-0.5_dp*dt*this%NHL_gamma) + sqrt(BOLTZMANN_K*this%T*(1.0_dp-exp(-dt*this%NHL_gamma))/this%NHL_mu)*ran_normal() + endif + endif + + ! quarter step drag part of v + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + decay = exp(-0.25_dp*dt*(this%chi_a(i)+this%xi_a(i))) + at%velo(:,i) = at%velo(:,i)*decay + end do + else + decay = exp(-0.25_dp*dt*(this%chi_a(1)+this%xi_a(1))) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + at%velo(:,i) = at%velo(:,i)*decay + end do + endif + + ! Leimkuhler+Jones adaptive Langevin + ! propagate chi and xi dt/4 + if (this%Q > 0.0_dp .or. this%NHL_mu > 0.0_dp) then + if (this%massive) then + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + delta_K = open_Langevin_delta_K(1, at%mass(i:i), at%velo(1:3,i:i), 3.0_dp, this%T, prop_ptr(i:i), value) + if (this%Q > 0.0_dp) this%chi_a(i) = this%chi_a(i) + 0.5_dp*dt*delta_K/this%Q + if (this%NHL_mu > 0.0_dp) this%xi_a(i) = this%xi_a(i) + 0.5_dp*dt*delta_K/this%NHL_mu + end do + else + delta_K = open_Langevin_delta_K(at%N, at%mass, at%velo, this%Ndof, this%T, prop_ptr, value) + if (this%Q > 0.0_dp) this%chi_a = this%chi_a + 0.5_dp*dt*delta_K/this%Q + if (this%NHL_mu > 0.0_dp) this%xi_a = this%xi_a + 0.5_dp*dt*delta_K/this%NHL_mu + endif + endif + + if (this%gamma > 0.0_dp) then + ! Do the Ornstein-Uhlenbeck half step + decay=exp(-0.5_dp*this%gamma*dt) + rv_mag = sqrt(BOLTZMANN_K*this%T*(1.0_dp-decay**2)) + do i = 1, at%N + if (prop_ptr(i) /= value) cycle + OU_dv = rv_mag/sqrt(at%mass(i))*ran_normal3() + at%velo(:,i) = decay*at%velo(:,i) + OU_dv + end do + end if + + end select + + end subroutine thermostat_post_vel2 + + function open_Langevin_delta_K(N, mass, velo, Ndof, T, prop_ptr, value) result(delta_K) + integer, intent(in) :: N + real(dp), intent(in) :: mass(:), velo(:,:) + real(dp), intent(in) :: Ndof + real(dp), intent(in) :: T + integer, intent(in) :: prop_ptr(:), value + + real(dp) :: delta_K + + integer i + + delta_K = 0.0_dp + do i = 1, N + if (prop_ptr(i) == value) delta_K = delta_K + mass(i)*normsq(velo(:,i)) + end do + delta_K = 0.5_dp*(delta_K - Ndof*BOLTZMANN_K*T) + end function open_Langevin_delta_K + +end module thermostat_module diff --git a/src/libAtoms/Topology.F90 b/src/libAtoms/Topology.F90 new file mode 100644 index 0000000000..b820e1562a --- /dev/null +++ b/src/libAtoms/Topology.F90 @@ -0,0 +1,3462 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module topology_module + + use error_module + use system_module + use units_module + use extendable_str_module + use linearalgebra_module + use dictionary_module + use table_module + use periodictable_module + use connection_module + use atoms_types_module + use atoms_module + use clusters_module + use structures_module + + + implicit none + private + +public :: next_motif, find_motif_backbone + !! private :: next_motif, write_psf_section, create_bond_list, write_pdb_file + !! private :: create_angle_list, create_dihedral_list + !! private :: create_improper_list + !! private :: create_pos_dep_charges, calc_fc + + public :: delete_metal_connects, & + write_brookhaven_pdb_file, & + write_cp2k_pdb_file, & + write_psf_file, & + write_psf_file_arb_pos, & + create_residue_labels_arb_pos, & + NONE_RUN, & + QS_RUN, & + MM_RUN, & + QMMM_RUN_CORE, & + QMMM_RUN_EXTENDED, & + find_water_monomer, find_A2_monomer, find_AB_monomer, & + find_molecule_ids, & + find_general_monomer, & + find_monomer_pairs, & + find_monomer_pairs_MPI, & + find_monomer_triplets, & + find_monomer_triplets_MPI, & + calc_mean_pos + + +!parameters for Run_Type + integer, parameter :: NONE_RUN = -100 + integer, parameter :: QS_RUN = -1 + integer, parameter :: MM_RUN = 0 + integer, parameter :: QMMM_RUN_CORE = 1 + integer, parameter :: QMMM_RUN_EXTENDED = 2 + +!parameters for the Residue Library + integer, parameter, private :: MAX_KNOWN_RESIDUES = 200 !Maximum number of residues in the library + !(really about 116 at the mo) + integer, parameter, private :: MAX_ATOMS_PER_RES = 50 !Maximum number of atoms in one residue + integer, parameter, private :: MAX_IMPROPERS_PER_RES = 12 !Maximum number of impropers in one residue + + real(dp), parameter, public :: SILICON_2BODY_CUTOFF = 3.8_dp !Si-Si 2body interaction + real(dp), parameter, public :: SILICA_2BODY_CUTOFF = 7.5_dp !Si-O, O-O 2body interaction + real(dp), parameter, public :: TITANIA_2BODY_CUTOFF = 7.5_dp !Si-O, O-O 2body interaction + real(dp), parameter, public :: SILICON_3BODY_CUTOFF = 3.8_dp !Si-Si-Si, Si-Si-O 3body cutoff + real(dp), parameter, public :: SILICA_3BODY_CUTOFF = 3.6_dp !Si-O-Si, O-Si-O, Si-O-H 3body cutoff + real(dp), parameter, public :: TITANIA_3BODY_CUTOFF = 7.5_dp !Si-O, O-O 2body interaction +! real(dp), parameter, public :: SILICON_2BODY_CUTOFF = 2.8_dp !Si-Si 2body interaction +! real(dp), parameter, public :: SILICA_2BODY_CUTOFF = 5.5_dp !Si-O, O-O 2body interaction +! real(dp), parameter, public :: SILICON_3BODY_CUTOFF = 2.8_dp !Si-Si-Si, Si-Si-O 3body cutoff +! real(dp), parameter, public :: SILICA_3BODY_CUTOFF = 2.6_dp !Si-O-Si, O-Si-O, Si-O-H 3body cutoff + + real(dp), parameter, private :: Danny_R_q = 2.0_dp + real(dp), parameter, private :: Danny_Delta_q = 0.1_dp + + real(dp), parameter, private :: Danny_Si_Si_cutoff = 2.8_dp + real(dp), parameter, private :: Danny_Si_Si_O_cutoff = 2.8_dp + real(dp), parameter, private :: Danny_Si_O_cutoff = 2.6_dp + real(dp), parameter, private :: Danny_Si_H_cutoff = 0._dp +! real(dp), parameter, private :: Danny_O_O_cutoff = 2.6_dp + real(dp), parameter, private :: Danny_O_O_cutoff = 0._dp + real(dp), parameter, private :: Danny_O_H_cutoff = 1.0_dp + real(dp), parameter, private :: Danny_H_H_cutoff = 0._dp + +contains + + + !% Topology calculation using arbitrary (usually avgpos) coordinates, as a wrapper to find_residue_labels + !% if EVB is being used, must pass exact connectivity object and set evb_nneighb_only to false + !% + subroutine create_residue_labels_arb_pos(at,do_CHARMM,intrares_impropers,find_silica_residue,pos_field_for_connectivity, & + form_bond,break_bond, silica_pos_dep_charges, silica_charge_transfer, have_titania_potential, & + find_molecules, evb_nneighb_only, remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds, error) + + type(Atoms), intent(inout),target :: at + logical, optional, intent(in) :: do_CHARMM + type(Table), optional, intent(out) :: intrares_impropers + logical, optional, intent(in) :: find_silica_residue + character(len=*), optional, intent(in) :: pos_field_for_connectivity + integer, optional, intent(in) :: form_bond(2), break_bond(2) + logical, optional, intent(in) :: silica_pos_dep_charges + real(dp), intent(in), optional :: silica_charge_transfer + logical, intent(in), optional :: have_titania_potential + logical, intent(in), optional :: find_molecules + logical, intent(in), optional :: evb_nneighb_only + logical, optional, intent(in) :: remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds + integer, optional, intent(out) :: error + + real(dp), pointer :: use_pos(:,:) + type(Connection) :: t_connect + type(Atoms) :: at_copy + logical :: do_find_silica_residue, do_have_titania_potential + logical :: use_pos_is_pos + + logical :: bond_exists, do_nneighb_only + integer :: shift(3) + real(dp) :: form_bond_dist + + integer :: ji, j + + INIT_ERROR(error) + + do_nneighb_only = optional_default(.true., evb_nneighb_only) + + ! save a copy + at_copy = at + + use_pos_is_pos = .false. + ! find desired position field (pos, avgpos, whatever) + if (present(pos_field_for_connectivity)) then + if (.not. assign_pointer(at, trim(pos_field_for_connectivity), use_pos)) then + RAISE_ERROR("calc_topology can't find pos field '"//trim(pos_field_for_connectivity)//"'", error) + endif + if (trim(pos_field_for_connectivity) == 'pos') use_pos_is_pos = .true. + else if (.not. assign_pointer(at, 'avgpos', use_pos)) then + call print("WARNING: calc_topology can't find default pos field 'avgpos', trying to use pos instead") + if (.not. assign_pointer(at, 'pos', use_pos)) then + RAISE_ERROR("calc_topology can't find avgpos or pos fields",error) + endif + use_pos_is_pos = .true. + endif + + do_find_silica_residue = optional_default(.false.,find_silica_residue) + do_have_titania_potential = optional_default(.false.,have_titania_potential) + + ! copy desired pos to pos, and new connectivity + !NB don't do if use_pos => pos + if (.not. use_pos_is_pos) at_copy%pos = use_pos + if (do_find_silica_residue) then + call set_cutoff(at_copy,SILICA_2BODY_CUTOFF) + call calc_connect(at_copy, alt_connect=t_connect) + elseif (do_have_titania_potential) then + call set_cutoff(at_copy,1.3*bond_length(22, 8)) + call calc_connect(at_copy, alt_connect=t_connect) + else + ! use hysteretic connect to get nearest neighbour cutoff + ! will use default cutoff, which is the same as heuristics_nneighb_only=.true. + call calc_connect_hysteretic(at, DEFAULT_NNEIGHTOL, DEFAULT_NNEIGHTOL, alt_connect=t_connect) + endif + + + call break_form_bonds(at, t_connect, form_bond, break_bond, error=error) + PASS_ERROR(error) + + ! now create labels using this connectivity object + call create_residue_labels_internal(at,do_CHARMM,intrares_impropers,heuristics_nneighb_only=do_nneighb_only,alt_connect=t_connect,& + find_silica_residue=do_find_silica_residue, silica_pos_dep_charges=silica_pos_dep_charges, & + silica_charge_transfer=silica_charge_transfer, have_titania_potential=have_titania_potential, & + find_molecules=find_molecules, remove_Si_H_silica_bonds=remove_Si_H_silica_bonds, & + remove_Ti_H_titania_bonds=remove_Ti_H_titania_bonds, error=error) + PASS_ERROR(error) + call finalise(t_connect) + + end subroutine create_residue_labels_arb_pos + + !% Topology calculation. Recognize residues and save atomic names, residue names etc. in the atoms object. + !% Generally useable for AMBER and CHARMM force fields, in case of CHARMM, the MM charges are assigned here, too. + !% do_CHARMM=.true. is the default + !% Optionally outputs the intraresidual impropers. + !% The algorithm will fail if the Residue_Library is not present in atoms%params or in the directory. + !% Optionally use hysteretic_connect if passed as alt_connect. + !% Optionally could use hysteretic neighbours instead of nearest neighbours, if the cutoff of the + !% alt_connect were the same as at%cutoff(_break). + !% + subroutine create_residue_labels_internal(at,do_CHARMM,intrares_impropers, heuristics_nneighb_only,alt_connect, & + find_silica_residue, silica_pos_dep_charges, silica_charge_transfer, have_titania_potential, & + find_molecules, remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds, error) !, hysteretic_neighbours) + + type(Atoms), intent(inout),target :: at + logical, optional, intent(in) :: do_CHARMM + type(Table), optional, intent(out) :: intrares_impropers + logical, intent(in), optional :: heuristics_nneighb_only + type(Connection), intent(in), optional, target :: alt_connect + logical, optional, intent(in) :: find_silica_residue, silica_pos_dep_charges + real(dp), optional, intent(in) :: silica_charge_transfer + logical, optional, intent(in) :: have_titania_potential + logical, optional, intent(in) :: find_molecules + integer, optional, intent(out) :: error + logical, optional, intent(in) :: remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds +! logical, optional, intent(in) :: hysteretic_neighbours + + + character(*), parameter :: me = 'create_residue_labels_pos_internal: ' + + type(Inoutput) :: lib + character(4) :: cha_res_name(MAX_KNOWN_RESIDUES), Cres_name + character(3) :: pdb_res_name(MAX_KNOWN_RESIDUES), pres_name + integer :: residue_number(at%N) + character(4) :: atom_name(at%N), atom_name_PDB(at%N) + real(dp) :: atom_charge(at%N) + integer :: atom_subgroup(at%N) + type(Table) :: residue_type, list + logical :: unidentified(at%N) + integer, allocatable, dimension(:,:) :: motif + integer :: i, m, n, nres + character(4), allocatable :: at_names(:), at_names_PDB(:) + real(dp), allocatable :: at_charges(:) + integer, allocatable :: at_subgroups(:) + logical :: my_do_charmm + character, dimension(:,:), pointer :: atom_type, atom_type_PDB, atom_res_name, atom_mol_name + integer, dimension(:), pointer :: atom_res_number, atom_res_type, motif_atom_num, atom_subgroup_number + real(dp), dimension(:), pointer :: atom_charge_ptr + logical :: ex + type(extendable_str) :: residue_library + integer :: i_impr, n_impr + integer, allocatable :: imp_atoms(:,:) + real(dp) :: mol_charge_sum + logical :: found_residues + type(Table) :: atom_Si, atom_SiO, SiOH_list, atom_Ti, atom_TiO, TiOH_list + real(dp), dimension(:), allocatable :: charge +integer :: j,atom_i, ji +!logical :: silanol + type(Table) :: bondH,bondSi, bondTi + integer :: bond_H,bond_Si, bond_Ti +! integer :: qm_flag_index, pos_indices(3) +! logical :: do_qmmm + type(Connection), pointer :: use_connect +! logical :: use_hysteretic_neighbours + type(Table) :: O_atom, O_neighb + integer :: hydrogen + logical :: find_silica, titania_potential, do_silica_pos_dep_charges, do_find_molecules + logical :: do_remove_Si_H_silica_bonds, do_remove_Ti_H_titania_bonds + real(dp) :: do_silica_charge_transfer + + integer, pointer :: mol_id(:) + type(allocatable_array_pointers), allocatable :: molecules(:) + integer :: i_motif_at + + INIT_ERROR(error) + + call system_timer('create_residue_labels_pos_internal') + + find_silica = optional_default(.false.,find_silica_residue) + do_silica_pos_dep_charges = optional_default(.true., silica_pos_dep_charges) + do_silica_charge_transfer = optional_default(2.4_dp, silica_charge_transfer) + titania_potential = optional_default(.false.,have_titania_potential) + do_find_molecules = optional_default(.true., find_molecules) + do_remove_Si_H_silica_bonds = optional_default(.true., remove_Si_H_silica_bonds) + do_remove_Ti_H_titania_bonds = optional_default(.true., remove_Ti_H_titania_bonds) + + if (present(alt_connect)) then + use_connect => alt_connect + else + use_connect => at%connect + endif + if (.not.use_connect%initialised) then + RAISE_ERROR(me//'No connectivity data present in atoms structure', error) + endif +! use_hysteretic_neighbours = optional_default(.false.,hysteretic_neighbours) + + my_do_charmm = optional_default(.true.,do_CHARMM) + + call initialise(residue_library) + call print_title('Creating CHARMM format') + call get_param_value(at, 'Library', residue_library, error=error) + PASS_ERROR_WITH_INFO('create_residue_labels_pos_internal: no residue library specified, but topology generation requested', error) + call print('Library: '//string(residue_library)) + + !Open the residue library + !call print('Opening library...') + call initialise(lib,string(residue_library),action=INPUT) + + !Set all atoms as initially unidentified + unidentified = .true. + + ! add property for find_motif() to save the index of each atom in the motif + call add_property(at,'motif_atom_num',0, ptr=motif_atom_num) + + !Read each of the residue motifs from the library + n = 0 + nres = 0 + mol_charge_sum = 0._dp + found_residues = .false. + if (present(intrares_impropers)) call initialise(intrares_impropers,4,0,0,0,0) + call allocate(residue_type,1,0,0,0,1000) + call print('Identifying atoms...') + +!!!!!!!!!!! TITANIA POTENTIAL !!!!!!!!!! + if (titania_potential) then + ! TIO residue if Ti atom is present in the atoms structure + if (any(at%Z(1:at%N).eq.22)) then + call print('|-Looking for TIO residue, not from the library...') + call print('| |-Found... will be treated as 1 molecule, 1 residue...') + !all this bulk will be 1 residue + n = n + 1 + cha_res_name(n) = 'TIO2' + pdb_res_name(n) = '' !not used + call append(residue_type,(/n/)) + nres = nres + 1 + + !Add Ti atoms + call initialise(atom_Ti,4,0,0,0,0) + do i = 1,at%N + if (at%Z(i).eq.22) then + call append(atom_Ti,(/i,0,0,0/)) + endif + enddo + call print(atom_Ti%N//' Ti atoms found in total') + !Add O atoms + call bfs_step(at,atom_Ti,atom_TiO,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) + call print(atom_TiO%N//' O atoms found in total') +! if (any(at%Z(atom_TiO%int(1,1:atom_TiO%N)).eq.1)) call system_abort('Ti-H bond') + if (do_remove_Ti_H_titania_bonds) then + do i=1,atom_TiO%N !check Hs bonded to Ti. There shouldn't be any,removing the bond. + if (at%Z(atom_TiO%int(1,i)).eq.1) then + call print('WARNING! Ti and H are very close',verbosity=PRINT_ALWAYS) + bond_H = atom_TiO%int(1,i) + call initialise(bondH,4,0,0,0,0) + call append(bondH,(/bond_H,0,0,0/)) + call bfs_step(at,bondH,bondTi,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) + do j = 1,bondTi%N + if (at%Z(bondTi%int(1,i)).eq.22) then + bond_Ti = bondTi%int(1,i) + call print('WARNING! Remove Ti '//bond_Ti//' and H '//bond_H//' bond ('//distance_min_image(at,bond_H,bond_Ti)//')',verbosity=PRINT_ALWAYS) + call remove_bond(use_connect,bond_H,bond_Ti) + endif + enddo + endif + enddo + endif + + !Add H atoms -- if .not.remove_Ti_H_bonds, we might include whole water molecules at this stage, adding the remaining -OH. + call add_cut_hydrogens(at,atom_TiO,heuristics_nneighb_only=.true.,alt_connect=use_connect) + call print(atom_TiO%N//' O/H atoms found in total') + +!check if none of these atoms are identified yet + if (any(.not.unidentified(atom_Ti%int(1,1:atom_Ti%N)))) then + RAISE_ERROR('already identified atoms found again.', error) + endif + if (any(.not.unidentified(atom_TiO%int(1,1:atom_TiO%N)))) then +! call system_abort('already identified atoms found again.') + do i = 1,atom_TiO%N,-1 + if (.not.unidentified(atom_TiO%int(1,i))) then + call print('delete from TiO2 list already identified atom '//atom_TiO%int(1,1:atom_TiO%N)) + call delete(atom_TiO,i) + endif + enddo + endif + unidentified(atom_Ti%int(1,1:atom_Ti%N)) = .false. + unidentified(atom_TiO%int(1,1:atom_TiO%N)) = .false. + + !add atom, residue and molecule names + !TIO + do i = 1, atom_Ti%N !atom_Ti only has Ti atoms + atom_i = atom_Ti%int(1,i) + atom_name(atom_i) = 'TIO' + atom_name_PDB(atom_i) = 'TIO' + enddo + + !OTB, OTI & HTI + do i = 1, atom_TiO%N !atom_TiO only has O,H atoms + atom_i = atom_TiO%int(1,i) + !OTB & OTI + if (at%Z(atom_i).eq.8) then + call initialise(O_neighb,4,0,0,0) + call initialise(O_atom,4,0,0,0) + call append(O_atom,(/atom_i,0,0,0/)) + call bfs_step(at,O_atom,O_neighb,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) + !check nearest neighbour number = 3 + if (O_neighb%N.ne.3) then + call print('WARNING! titania O '//atom_i//'has '//O_neighb%N//'/=3 nearest neighbours',PRINT_ALWAYS) + call print('neighbours: '//O_neighb%int(1,1:O_neighb%N)) + endif + !check if it has a H nearest neighbour + hydrogen = find_in_array(at%Z(O_neighb%int(1,1:O_neighb%N)),1) + if (hydrogen.ne.0) then + atom_name(atom_i) = 'OTI' !silanol O + atom_name_PDB(atom_i) = 'OTI' !silanol O +! call print('Found OH silanol oxygen.'//atom_TiO%int(1,i)//' hydrogen: '//O_neighb%int(1,hydrogen)) + !check if it has only 1 H nearest neighbour + if (hydrogen.lt.O_neighb%N) then + if(find_in_array(at%Z(O_neighb%int(1,hydrogen+1:O_neighb%N)),1).gt.0) then + RAISE_ERROR('More than 1 H neighbours of O '//atom_i, error) + endif + endif + else + atom_name(atom_i) = 'OTB' !bridging O + atom_name_PDB(atom_i) = 'OTB' !bridging O +! call print('Found OB bridging oxygen.'//atom_TiO%int(1,i)) + endif + call finalise(O_atom) + call finalise(O_neighb) + !HSI + elseif (at%Z(atom_TiO%int(1,i)).eq.1) then + atom_name(atom_TiO%int(1,i)) = 'HTI' + atom_name_PDB(atom_TiO%int(1,i)) = 'HTI' + else + RAISE_ERROR('Non O/H atom '//atom_i//'!?', error) + endif + enddo + + !Add all the titanium atoms together + call initialise(TiOH_list,4,0,0,0,0) + call append (TiOH_list,atom_Ti) + call append (TiOH_list,atom_TiO) + + !Residue numbers + residue_number(TiOH_list%int(1,1:TiOH_list%N)) = nres + + !Charges + !call create_pos_dep_charges(at,TiOH_list,charge) !,residue_names=cha_res_name(residue_type%int(1,residue_number(1:at%N)))) + atom_charge = 1.2_dp + do i=1,at%n + if(at%Z(i).eq.8) atom_charge(i) = -0.6_dp + call print(' '//i//' '//atom_charge(i),verbosity=PRINT_ANALYSIS) + enddo + call print("overall titania charge: "//sum(atom_charge(TiOH_list%int(1,1:TiOH_list%N)))) + + call finalise(atom_Ti) + call finalise(atom_TiO) + call finalise(TiOH_list) + + else + call print('WARNING! have_titania_potential is true, but found no Ti atoms in the atoms object!',PRINT_ALWAYS) + endif + + endif +!!!!!!!!!!!!!! END TITANIA POTENTIAL !!!!!!!!!!!!!!!! + + +!!!!!!!!!!!!!!! DANNY POTENTIAL !!!!!!!!!!!!!!!! + if (find_silica) then + + ! SIO residue for Danny potential if Si atom is present in the atoms structure + if (any(at%Z(1:at%N).eq.14)) then + call print('|-Looking for SIO residue, not from the library...') + call print('| |-Found... will be treated as 1 molecule, 1 residue...') + !all this bulk will be 1 residue + n = n + 1 + cha_res_name(n) = 'SIO2' + pdb_res_name(n) = '' !not used + call append(residue_type,(/n/)) + nres = nres + 1 + + !Add Si atoms + call initialise(atom_Si,4,0,0,0,0) + do i = 1,at%N + if (at%Z(i).eq.14) then + call append(atom_Si,(/i,0,0,0/)) + endif + enddo + call print(atom_Si%N//' Si atoms found in total') + !Add O atoms + call bfs_step(at,atom_Si,atom_SiO,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) + call print(atom_SiO%N//' O atoms found in total') +! if (any(at%Z(atom_SiO%int(1,1:atom_SiO%N)).eq.1)) call system_abort('Si-H bond') + if (do_remove_Si_H_silica_bonds) then + call initialise(bondH,4,0,0,0) + call initialise(bondSi,4,0,0,0) + + do i=1,atom_SiO%N !check Hs bonded to Si. There shouldn't be any,removing the bond. + if (at%Z(atom_SiO%int(1,i)).eq.1) then + call print('WARNING! Si and H are very close',verbosity=PRINT_ALWAYS) + bond_H = atom_SiO%int(1,i) + call wipe(bondH) + call wipe(bondSi) + call append(bondH,(/bond_H,0,0,0/)) + call bfs_step(at,bondH,bondSi,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) + do j = 1,bondSi%N + if (at%Z(bondSi%int(1,j)).eq.14) then + bond_Si = bondSi%int(1,j) + call print('WARNING! Remove Si '//bond_Si//' and H '//bond_H//' bond ('//distance_min_image(at,bond_H,bond_Si)//')',verbosity=PRINT_ALWAYS) + call remove_bond(use_connect,bond_H,bond_Si) + endif + enddo + endif +! call print('atom_SiO has '//at%Z(atom_SiO%int(1,i))) + enddo + endif + !Add H atoms -- if .not.remove_Si_H_bonds, we might include whole water molecules at this stage, adding the remaining -OH. + ! call bfs_step(at,atom_SiO,atom_SIOH,nneighb_only=.true.,min_images_only=.true.) + call add_cut_hydrogens(at,atom_SiO,heuristics_nneighb_only=.true.,alt_connect=use_connect) + call print(atom_SiO%N//' O/H atoms found in total') + + !check if none of these atoms are identified yet + if (any(.not.unidentified(atom_Si%int(1,1:atom_Si%N)))) then + RAISE_ERROR('already identified atoms found again.', error) + endif + if (any(.not.unidentified(atom_SiO%int(1,1:atom_SiO%N)))) then +! call system_abort('already identified atoms found again.') + do i = 1,atom_SiO%N,-1 + if (.not.unidentified(atom_SiO%int(1,i))) then + call print('delete from SiO2 list already identified atom '//atom_SiO%int(1,1:atom_SiO%N)) + call delete(atom_SiO,i) + endif + enddo + endif + unidentified(atom_Si%int(1,1:atom_Si%N)) = .false. + unidentified(atom_SiO%int(1,1:atom_SiO%N)) = .false. + + !add atom, residue and molecule names + !SIO + do i = 1, atom_Si%N !atom_Si only has Si atoms + atom_i = atom_Si%int(1,i) + atom_name(atom_i) = 'SIO' + atom_name_PDB(atom_i) = 'SIO' + enddo + !OSB, OSI & HSI + do i = 1, atom_SiO%N !atom_SiO only has O,H atoms + atom_i = atom_SiO%int(1,i) + !OSB & OSI + if (at%Z(atom_i).eq.8) then + call initialise(O_neighb,4,0,0,0) + call initialise(O_atom,4,0,0,0) + call append(O_atom,(/atom_i,0,0,0/)) + call bfs_step(at,O_atom,O_neighb,nneighb_only=.true.,min_images_only=.true.,alt_connect=use_connect) + !check nearest neighbour number = 2 + if (O_neighb%N.ne.2) then + call print('WARNING! silica O '//atom_i//'has '//O_neighb%N//'/=2 nearest neighbours',PRINT_ALWAYS) + call print('neighbours: '//O_neighb%int(1,1:O_neighb%N)) + endif + !check if it has a H nearest neighbour + hydrogen = find_in_array(at%Z(O_neighb%int(1,1:O_neighb%N)),1) + if (hydrogen.ne.0) then + atom_name(atom_i) = 'OSI' !silanol O + atom_name_PDB(atom_i) = 'OSI' !silanol O +! call print('Found OH silanol oxygen.'//atom_SiO%int(1,i)//' hydrogen: '//O_neighb%int(1,hydrogen)) + !check if it has only 1 H nearest neighbour + if (hydrogen.lt.O_neighb%N) then + if(find_in_array(at%Z(O_neighb%int(1,hydrogen+1:O_neighb%N)),1).gt.0) then + RAISE_ERROR('More than 1 H neighbours of O '//atom_i, error) + endif + endif + else + atom_name(atom_i) = 'OSB' !bridging O + atom_name_PDB(atom_i) = 'OSB' !bridging O +! call print('Found OB bridging oxygen.'//atom_SiO%int(1,i)) + endif + call finalise(O_atom) + call finalise(O_neighb) + !HSI + elseif (at%Z(atom_SiO%int(1,i)).eq.1) then + atom_name(atom_SiO%int(1,i)) = 'HSI' + atom_name_PDB(atom_SiO%int(1,i)) = 'HSI' + else + RAISE_ERROR('Non O/H atom '//atom_i//'!?', error) + endif + enddo + + !Add all the silica atoms together + call initialise(SiOH_list,4,0,0,0,0) + call append (SiOH_list,atom_Si) + call append (SiOH_list,atom_SiO) + + !Residue numbers + residue_number(SiOH_list%int(1,1:SiOH_list%N)) = nres + + !Charges + if (do_silica_pos_dep_charges) then + call create_pos_dep_charges(at,SiOH_list,charge) !,residue_names=cha_res_name(residue_type%int(1,residue_number(1:at%N)))) + atom_charge(SiOH_list%int(1,1:SiOH_list%N)) = 0._dp + atom_charge(SiOH_list%int(1,1:SiOH_list%N)) = charge(SiOH_list%int(1,1:SiOH_list%N)) + call print("overall silica charge: "//sum(atom_charge(SiOH_list%int(1,1:SiOH_list%N)))) + call print('Atomic charges: ',PRINT_ANALYSIS) + call print(' ATOM CHARGE',PRINT_ANALYSIS) + do i=1,at%N + call print(' '//i//' '//atom_charge(i),verbosity=PRINT_ANALYSIS) + enddo + else + where (at%z == 1) atom_charge = do_silica_charge_transfer/4.0_dp + where (at%z == 8) atom_charge = -do_silica_charge_transfer/2.0_dp + where (at%z ==14) atom_charge = do_silica_charge_transfer + end if + + call finalise(atom_Si) + call finalise(atom_SiO) + call finalise(SiOH_list) + + else + call print('WARNING! find_silica_residue is true, but found no silicon atoms in the atoms object!',PRINT_ALWAYS) + endif + + endif +!!!!!!!!!!!!!!! END DANNY POTENTIAL !!!!!!!!!!!!!!!! + + do + + ! Pull the next residue template from the library + if (my_do_charmm) then + call next_motif(lib,cres_name,pres_name,motif,atom_names=at_names,atom_charges=at_charges,atom_names_PDB=at_names_PDB, n_impr=n_impr,imp_atoms=imp_atoms,do_CHARMM=.true.,at_subgroups=at_subgroups) + else + call next_motif(lib,cres_name,pres_name,motif,atom_names=at_names,atom_names_PDB=at_names_PDB, do_CHARMM=.false.,at_subgroups=at_subgroups) + endif + + if (cres_name=='NONE') then + found_residues = .true. + exit + endif + +! call print("motif") +! call print("cres_name " // trim(cres_name)// " pres_name "//trim(pres_name) // " n_impr " // n_impr) +! do m=1, size(motif,1) +! call print("motif " // motif(m,1:7) // " name " // trim(at_names(m)) // " charge " // at_charges(m) // " PDB name " // trim(at_names_PDB(m)) // & +! " subgroup " // at_subgroups(m)) +! end do + + ! Store its CHARMM (3 char) and PDB (3 char) names + ! e.g. cha/pdb_res_name(5) corresponds to the 5th residue found in the library + n = n + 1 + cha_res_name(n) = cres_name + pdb_res_name(n) = pres_name + + ! Search the atom structure for this residue + call print('|-Looking for '//cres_name//'...',verbosity=PRINT_ANALYSIS) + call find_motif(at,motif,list,mask=unidentified,nneighb_only=heuristics_nneighb_only,alt_connect=use_connect) !,hysteretic_neighbours=use_hysteretic_neighbours) + + if (list%N > 0) then + + call print('| |-Found '//list%N//' occurrences of '//cres_name//' with charge '//(sum(at_charges(1:size(at_charges))))) + mol_charge_sum = mol_charge_sum + list%N * sum(at_charges(1:size(at_charges))) + + ! Loop over all found instances of the residue + + do m = 1, list%N + + !Mark the newly identified atoms +!1 row is 1 residue + unidentified(list%int(:,m)) = .false. + + do i_motif_at=1, size(list%int,1) + motif_atom_num(list%int(i_motif_at,m)) = i_motif_at + end do + + !Store the residue info + nres = nres + 1 + call append(residue_type,(/n/)) + ! if residue_type%int(1,2) == 3 then residue no. 2 matches the 3rd residue in the library + residue_number(list%int(:,m)) = nres + !e.g. if residue_number(i) = j j-th residue in the atoms object (1 to 8000 in case of 8000 H2O) + ! residue_type(1,j) = k k-th residue in the library file, in order + ! cha_res_name(k) = 'ALA' name of the k-th residue in the library file + !then atom 'i' is in a residue 'ALA' + atom_subgroup(list%int(:,m)) = at_subgroups + atom_name(list%int(:,m)) = at_names + atom_name_PDB(list%int(:,m)) = at_names_PDB + if (my_do_charmm) then + atom_charge(list%int(:,m)) = at_charges + ! intraresidual IMPROPERs + if (present(intrares_impropers)) then + do i_impr = 1, n_impr + call append(intrares_impropers,list%int(imp_atoms(1:4,i_impr),m)) +! call print('Added intraresidual improper '//intrares_impropers%int(1:4,intrares_impropers%N)) + enddo + endif + endif + end do + + end if + + call print('|',verbosity=PRINT_ANALYSIS) + + end do + + ! check if residue library is empty + if (.not.found_residues) then + RAISE_ERROR('Residue library '//trim(lib%filename)//' does not contain any residues!', error) + endif + + call print('Finished.') + call print(nres//' residues found in total') + + if (any(unidentified)) then + call print(count(unidentified)//' unidentified atoms',verbosity=PRINT_ALWAYS) + call print(find(unidentified)) + do i=1,at%N + if (unidentified(i)) then + call print(ElementName(at%Z(i))//' atom '//i//' has avgpos: '//round(at%pos(1,i),5)//& + ' '//round(at%pos(2,i),5)//' '//round(at%pos(3,i),5),verbosity=PRINT_ALWAYS) + call print(ElementName(at%Z(i))//' atom '//i//' has number of neighbours: '//n_neighbours(at,i,alt_connect=alt_connect),verbosity=PRINT_ALWAYS) + do ji=1, n_neighbours(at, i, alt_connect=alt_connect) + j = neighbour(at, i, ji, alt_connect=alt_connect) + call print(" neighbour " // j // " is of type " // ElementName(at%Z(j)), verbosity=PRINT_ALWAYS) + end do + endif + enddo + + call print(at%connect) + ! THIS IS WHERE THE CALCULATION OF NEW PARAMETERS SHOULD GO + RAISE_ERROR('create_residue_labels_pos_internal: Unidentified atoms', error) + + else + call print('All atoms identified') + call print('Total charge of the molecule: '//round(mol_charge_sum,5)) + end if + + ! add data to store CHARMM topology + call add_property(at,'atom_type',repeat(' ',TABLE_STRING_LENGTH), ptr=atom_type) + call add_property(at,'atom_type_PDB',repeat(' ',TABLE_STRING_LENGTH), ptr=atom_type_PDB) + call add_property(at,'atom_res_name',repeat(' ',TABLE_STRING_LENGTH), ptr=atom_res_name) + call add_property(at,'atom_mol_name',repeat(' ',TABLE_STRING_LENGTH), ptr=atom_mol_name) + call add_property(at,'atom_res_number',0, ptr=atom_res_number) + call add_property(at,'atom_subgroup_number',0, ptr=atom_subgroup_number) + call add_property(at,'atom_res_type',0, ptr=atom_res_type) + call add_property(at,'atom_charge',0._dp, ptr=atom_charge_ptr) + + atom_type(1,1:at%N) = 'X' + atom_type_PDB(1,1:at%N) = 'X' + atom_res_name(1,1:at%N) = 'X' + atom_mol_name(1,1:at%N) = 'X' + atom_res_number(1:at%N) = 0 + atom_subgroup_number(1:at%N) = 0 + atom_res_type(1:at%N) = 0 + atom_charge_ptr(1:at%N) = 0._dp + + do i=1, at%N + atom_res_name(:,i) = pad(cha_res_name(residue_type%int(1,residue_number(i))), TABLE_STRING_LENGTH) + atom_res_number(i) = residue_number(i) + atom_subgroup_number(i) = atom_subgroup(i) + atom_res_type(i) = residue_type%int(1,residue_number(i)) + atom_type(:,i) = pad(adjustl(atom_name(i)), TABLE_STRING_LENGTH) + atom_type_PDB(:,i) = pad(adjustl(atom_name_PDB(i)), TABLE_STRING_LENGTH) + end do + + if (my_do_charmm) then + if (do_find_molecules) then + allocate(molecules(at%N)) + call find_molecule_ids(at,molecules,heuristics_nneighb_only=heuristics_nneighb_only,alt_connect=alt_connect) + do i=1, size(molecules) + if (allocated(molecules(i)%i_a)) then + ! special case for silica molecule + if (find_silica .and. count(at%Z(molecules(i)%i_a) == 14) /=0) then + atom_mol_name(:,molecules(i)%i_a) = atom_res_name(:,molecules(i)%i_a) + ! special case for single atoms + elseif (size(molecules(i)%i_a) == 1) then + atom_mol_name(:,molecules(i)%i_a) = atom_res_name(:,molecules(i)%i_a) + ! special case for H2O + else if (size(molecules(i)%i_a) == 3) then + if (count(at%Z(molecules(i)%i_a) == 8) == 1 .and. & + count(at%Z(molecules(i)%i_a) == 1) == 2) then + atom_mol_name(:,molecules(i)%i_a) = atom_res_name(:,molecules(i)%i_a) + else ! default + call print("Found molecule containing "//size(molecules(i)%i_a)//" atoms and not water, single atom or silica") + do j=1,size(molecules(i)%i_a) + atom_mol_name(:,molecules(i)%i_a(j)) = pad("M"//i, TABLE_STRING_LENGTH) + end do + endif + else ! default + call print("Found molecule containing "//size(molecules(i)%i_a)//" atoms and not water, single atom or silica") + do j=1,size(molecules(i)%i_a) + atom_mol_name(:,molecules(i)%i_a(j)) = pad("M"//i, TABLE_STRING_LENGTH) + end do + endif + end if ! allocated(molecules) + end do ! i=1,size(molecules) + deallocate(molecules) + else + ! find_molecules is F, assume we have just one molecule + ! we set molecule name to residue name of first atom + + call add_property(at,'mol_id',0,overwrite=.true.) + if (.not. assign_pointer(at,'mol_id',mol_id)) & + call system_abort("create_residue_labels_internal can't assign mol_id") + mol_id(:) = 1 + do i=1, at%N + atom_mol_name(:,i) = atom_res_name(:,1) + end do + end if + atom_charge_ptr(1:at%N) = atom_charge(1:at%N) + endif + + if (any(atom_res_number(1:at%N).le.0)) then + RAISE_ERROR('create_residue_labels_pos_internal: atom_res_number is not >0 for every atom', error) + endif + if (any(atom_type(1,1:at%N).eq.'X')) then + RAISE_ERROR('create_residue_labels_pos_internal: atom_type is not saved for at least one atom', error) + endif + if (any(atom_res_name(1,1:at%N).eq. 'X')) then + RAISE_ERROR('create_residue_labels_pos_internal: atom_res_name is not saved for at least one atom', error) + endif + + !Free up allocations + call finalise(residue_type) + call finalise(list) + if (allocated(motif)) deallocate(motif) + + !Close the library + call finalise(lib) + + call system_timer('create_residue_labels_pos_internal') + + end subroutine create_residue_labels_internal + + subroutine find_molecule_ids(at,molecules,heuristics_nneighb_only,alt_connect) + type(Atoms), intent(inout) :: at + type(allocatable_array_pointers), optional :: molecules(:) + logical, intent(in), optional :: heuristics_nneighb_only + type(Connection), intent(in), optional, target :: alt_connect + + integer, pointer :: mol_id(:) + integer :: last_seed, last_mol_id, seed_at + logical :: added_something + type(Table) :: cur_molec, next_atoms + + !if property not present + call add_property(at,'mol_id',0) + if (.not. assign_pointer(at,'mol_id',mol_id)) & + call system_abort("find_molecule_ids can't assign mol_id") + !if present + mol_id=0 + + last_seed = 0 + last_mol_id = 0 + do while (any(mol_id == 0)) + do seed_at=last_seed+1, at%N + if (mol_id(seed_at) /= 0) cycle + + ! find molecule from seed + call initialise(cur_molec) + call append(cur_molec, (/ seed_at, 0, 0, 0 /) ) + added_something = .true. + ! look for neighbours + do while (added_something) + call initialise(next_atoms) + call bfs_step(at,cur_molec,next_atoms,nneighb_only = heuristics_nneighb_only, min_images_only = .true., alt_connect=alt_connect) + if (next_atoms%N > 0) then + added_something = .true. + call append(cur_molec, next_atoms) + else + added_something = .false. + endif + end do + + ! set mol_id + mol_id(cur_molec%int(1,1:cur_molec%N)) = last_mol_id+1 + ! store in molecules + if (present(molecules)) then + allocate(molecules(last_mol_id+1)%i_a(cur_molec%N)) + molecules(last_mol_id+1)%i_a = cur_molec%int(1,1:cur_molec%N) + endif + call finalise(cur_molec) + + last_mol_id = last_mol_id + 1 + + last_seed = seed_at + end do ! seed_at + end do ! while any(mol_id == 0) + + call finalise(cur_molec) + call finalise(next_atoms) + end subroutine find_molecule_ids + + + !% This is the subroutine that reads residues from a library. + !% Used by create_CHARMM, can read from CHARMM and AMBER residue libraries. + !% do_CHARMM=.true. is the default + ! + subroutine next_motif(library,res_name,pdb_name,motif,atom_names,atom_charges,atom_names_PDB, n_impr,imp_atoms,do_CHARMM,at_subgroups,header_line) + + type(Inoutput), intent(in) :: library + character(4), intent(out) :: res_name + character(3), intent(out) :: pdb_name + integer, allocatable, intent(out) :: motif(:,:) + character(4), allocatable, intent(out) :: atom_names(:), atom_names_PDB(:) + real(dp), optional, allocatable, intent(out) :: atom_charges(:) + logical, optional, intent(in) :: do_CHARMM + integer, optional, allocatable, intent(out) :: imp_atoms(:,:) + integer, optional, intent(out) :: n_impr + integer, optional, allocatable, intent(out) :: at_subgroups(:) + character(len=*), optional, intent(out) :: header_line + + character(20), dimension(11) :: fields + integer :: status, num_fields, data(7), i, n_at, max_num_fields + type(Table) :: motif_table + integer :: tmp_at_subgroups(MAX_ATOMS_PER_RES) + character(4) :: tmp_at_names(MAX_ATOMS_PER_RES), tmp_at_names_PDB(MAX_ATOMS_PER_RES) + real(dp) :: tmp_at_charges(MAX_ATOMS_PER_RES),check_charge + logical :: my_do_charmm + character(len=STRING_LENGTH) :: line + ! for improper generation + integer :: imp_fields, tmp_imp_atoms(4,MAX_IMPROPERS_PER_RES) + + my_do_charmm = .true. + if (present(do_CHARMM)) my_do_charmm = do_CHARMM + + if (my_do_charmm) then + max_num_fields = 11 + imp_fields = 5 + else !do AMBER + max_num_fields = 9 + endif + + status = 0 + + if (present(header_line)) header_line ='' + do while(status==0) + line = read_line(library,status) + if (present(header_line)) then + if (len_trim(header_line) > 0) header_line=trim(header_line)//quip_new_line + header_line=trim(header_line)//trim(line) + endif + if (line(1:8)=='%residue') exit + end do + + if (status/=0) then + res_name = 'NONE' + pdb_name = 'NON' + return + end if + + call parse_string(line,' ',fields,num_fields) + res_name = trim(adjustl(fields(3))) + pdb_name = trim(adjustl(fields(4))) + + call allocate(motif_table,7,0,0,0,20) + n_at = 0 + check_charge=0._dp + ! residue structure [& charges] + do + call parse_line(library,' ',fields,num_fields) + if (num_fields < max_num_fields-1) exit ! last column of protein library (atom_name_PDB) is optional + do i = 1, 7 + data(i) = string_to_int(fields(i+1)) + end do + call append(motif_table,data) + n_at = n_at + 1 + tmp_at_subgroups(n_at) = string_to_int(fields(1)) + tmp_at_names(n_at) = fields(9) + if (my_do_charmm) then + tmp_at_charges(n_at) = string_to_real(fields(10)) + check_charge=check_charge+tmp_at_charges(n_at) + if(num_fields == 11) then + tmp_at_names_PDB(n_at) = fields(11) + else + tmp_at_names_PDB(n_at) = tmp_at_names(n_at) + end if + endif + end do + if (my_do_charmm) then + ! intra amino acid IMPROPER generation here + n_impr = 0 + do + if (num_fields < imp_fields) exit + if (trim(fields(1)).ne.'IMP') call system_abort('wrong improper format, should be: "IMP 1 4 7 10" with the 1st in the middle') + n_impr = n_impr + 1 + do i = 1,4 + tmp_imp_atoms(i,n_impr) = string_to_int(fields(i+1)) + enddo + call parse_line(library,' ',fields,num_fields) + enddo + endif + +! if (abs(mod(check_charge,1.0_dp)).ge.0.0001_dp .and. & +! abs(mod(check_charge,1.0_dp)+1._dp).ge.0.0001_dp .and. & !for -0.9999... +! abs(mod(check_charge,1.0_dp)-1._dp).ge.0.0001_dp) then !for +0.9999... +! call print('WARNING next_motif: Charge of '//res_name//' residue is :'//round(check_charge,4),verbosity=PRINT_ALWAYS) +! endif + + allocate(motif(motif_table%N,7)) + + motif = transpose(int_part(motif_table)) + + allocate(atom_names(n_at)) + atom_names = tmp_at_names(1:n_at) + allocate(atom_names_PDB(n_at)) + if (my_do_charmm) then + allocate(atom_charges(n_at)) + atom_charges = tmp_at_charges(1:n_at) + allocate(imp_atoms(4,n_impr)) + imp_atoms(1:4,1:n_impr) = tmp_imp_atoms(1:4,1:n_impr) + atom_names_PDB = tmp_at_names_PDB(1:n_at) + else + atom_names_PDB = atom_names + endif + + if (present(at_subgroups)) then + if (allocated(at_subgroups)) then + if (size(at_subgroups) /= n_at) deallocate(at_subgroups) + endif + if (.not. allocated(at_subgroups)) allocate(at_subgroups(n_at)) + at_subgroups = tmp_at_subgroups(1:n_at) + endif + + call finalise(motif_table) + + end subroutine next_motif + + !% Writes PDB format using the pdb_format passed as an input + !% printing charges into the last column of PDB file + !% Sample lines: + !%ATOM 1 CT3 ALA A 1 0.767 0.801 13.311 0.00 0.00 ALA C -0.2700 + !%ATOM 2 HA ALA A 1 0.074 -0.060 13.188 0.00 0.00 ALA H 0.0900 + !%ATOM 3 HA ALA A 1 0.176 1.741 13.298 0.00 0.00 ALA H 0.0900 + ! + subroutine write_pdb_file(at,pdb_file,pdb_format,run_type_string) + + character(len=*), intent(in) :: pdb_file + type(Atoms), intent(in) :: at + character(len=*), intent(in) :: pdb_format + character(len=*), optional, intent(in) :: run_type_string + + type(Inoutput) :: pdb + character(103) :: sor !Brookhaven only uses 88 + integer :: mm + character(4) :: QM_prefix_atom_mol_name + character, dimension(:,:), pointer :: atom_type, atom_res_name, atom_mol_name + integer, dimension(:), pointer :: atom_res_number + real(dp), dimension(:), pointer :: atom_charge + character(len=STRING_LENGTH) :: my_run_type_string + real(dp) :: cell_lengths(3), cell_angles(3) + + external :: lattice_xyz_to_abc + + call system_timer('write_pdb_file') + my_run_type_string = optional_default('',run_type_string) + + call initialise(pdb,trim(pdb_file),action=OUTPUT) + call print(' PDB file: '//trim(pdb%filename)) +! call print('REMARK'//at%N,file=pdb) +!lattice information could be added in a line like this: +!CRYST1 1.000 1.000 1.000 90.00 90.00 90.00 P 1 1 + call get_lattice_params(at%lattice, cell_lengths(1), cell_lengths(2), cell_lengths(3), & + cell_angles(1), cell_angles(2), cell_angles(3)) + sor='' + write(sor, '(a6,3f9.3,3f7.2,a16)') 'CRYST1', cell_lengths(:), DEGREES_PER_RADIAN*cell_angles(:), ' P 1 1' + call print(sor, file=pdb) + +! if ((trim(my_run_type_string).eq.'QMMM_CORE') .or. & +! (trim(my_run_type_string).eq.'QMMM_EXTENDED')) then +! qm_flag_index = get_property(at,'cluster_mark') +! if (trim(my_run_type_string).eq.'QMMM_EXTENDED') run_type=QMMM_RUN_EXTENDED +! if (trim(my_run_type_string).eq.'QMMM_CORE') run_type=QMMM_RUN_CORE +! endif + + if (.not. assign_pointer(at, 'atom_type_PDB', atom_type)) & + call system_abort('Cannot assign pointer to "atom_type_PDB" property.') + if (.not. assign_pointer(at, 'atom_res_name', atom_res_name)) & + call system_abort('Cannot assign pointer to "atom_res_name" property.') + if (.not. assign_pointer(at, 'atom_mol_name', atom_mol_name)) & + call system_abort('Cannot assign pointer to "atom_mol_name" property.') + if (.not. assign_pointer(at, 'atom_res_number', atom_res_number)) & + call system_abort('Cannot assign pointer to "atom_res_numer" property.') + if (.not. assign_pointer(at, 'atom_charge', atom_charge)) & + call system_abort('Cannot assign pointer to "atom_charge" property.') + + do mm=1,at%N + ! e.g. CP2K needs different name for QM molecules, if use isolated atoms + sor = '' + QM_prefix_atom_mol_name = '' + QM_prefix_atom_mol_name = trim(a2s(atom_mol_name(:,mm))) +!does not work for contiguous molecules, e.g. silica +!!! if ((trim(run_type_string).eq.'QMMM_CORE') .or. & +!!! (trim(run_type_string).eq.'QMMM_EXTENDED')) then +!!! if (at%data%int(qm_flag_index,mm).ge.QMMM_RUN_CORE .and. at%data%int(qm_flag_index,mm).le.run_type) then +!!! QM_prefix_atom_mol_name = 'QM'//trim(at%data%str(atom_mol_name_index,mm)) +!!!! call print('QM molecule '//QM_prefix_atom_mol_name) +!!! endif +!!! endif +! call print('molecule '//QM_prefix_atom_mol_name) +! call print('writing PDB file: atom type '//at%data%str(atom_type_index,mm)) + write(sor,trim(pdb_format)) 'ATOM ',mm,trim(a2s(atom_type(:,mm))),trim(a2s(atom_res_name(:,mm))),atom_res_number(mm), & + at%pos(1:3,mm),0._dp,0._dp,QM_prefix_atom_mol_name,ElementName(at%Z(mm)),atom_charge(mm) +! at%pos(1:3,mm),0._dp,0._dp,this%atom_res_name(mm),ElementName(at%Z(mm)),this%atom_charge(mm) + call print(sor,file=pdb) + enddo + call print('END',file=pdb) + + call finalise(pdb) + + call system_timer('write_pdb_file') + + end subroutine write_pdb_file + + !% Writes Brookhaven PDB format + !% charges are printed into the PSF file, too + !% use CHARGE_EXTENDED keyword i.e. reads charges from the last column of PDB file + !% Sample line: + !%ATOM 1 CT3 ALA A 1 0.767 0.801 13.311 0.00 0.00 ALA C -0.2700 + !%ATOM 2 HA ALA A 1 0.074 -0.060 13.188 0.00 0.00 ALA H 0.0900 + !%ATOM 3 HA ALA A 1 0.176 1.741 13.298 0.00 0.00 ALA H 0.0900 + ! + subroutine write_brookhaven_pdb_file(at,pdb_file,run_type_string) + + character(len=*), intent(in) :: pdb_file + type(atoms), intent(in) :: at + character(len=*), optional, intent(in) :: run_type_string + +! character(*), parameter :: pdb_format = '(a6,i5,1x,a4,1x,a4,1x,i4,1x,3x,3f8.3,2f6.2,10x,a2,2x,f7.4)' + character(*), parameter :: pdb_format = '(a6,i5,1x,a4,1x,a4,i5,1x,3x,3f8.3,2f6.2,6x,a4,1x,a2,2x,f7.4)' + + !Brookhaven PDB format + ! sor(1:6) = 'ATOM ' + ! sor(7:11) = mm + ! sor(13:16) = this%atom_type(mm) + ! sor(18:21) = this%res_name(mm) + !! sor(22:22) = ' A' !these two are now + ! sor(23:26) = residue_number(mm) ! merged to handle >9999 residues + ! sor(31:38) = at%pos(1,mm) + ! sor(39:46) = at%pos(2,mm) + ! sor(47:54) = at%pos(3,mm) + ! sor(55:60) = ' 0.00' + ! sor(61:66) = ' 0.00' + !! sor(72:75) = 'MOL1' + ! sor(77:78) = ElementName(at%Z(mm)) + ! sor(79:86) = this%atom_charge(mm) + + call system_timer('write_brookhaven_pdb_file') + + call write_pdb_file(at,pdb_file,pdb_format,run_type_string) + + call system_timer('write_brookhaven_pdb_file') + + end subroutine write_brookhaven_pdb_file + + !% Writes modified PDB format for accurate coordinates and charges, for CP2K + !% Use CHARGE_EXTENDED keyword i.e. reads charges from the last column of PDB file + !% Sample line: + !%ATOM 1 CT3 ALA A 1 0.76700000 0.80100000 13.31100000 0.00 0.00 ALA C -0.27 + !%ATOM 2 HA ALA A 1 0.07400000 -0.06000000 13.18800000 0.00 0.00 ALA H 0.09 + !%ATOM 3 HA ALA A 1 0.17600000 1.74100000 13.29800000 0.00 0.00 ALA H 0.09 + ! + subroutine write_cp2k_pdb_file(at,pdb_file,run_type_string) + + character(len=*), intent(in) :: pdb_file + type(atoms), intent(in) :: at + character(len=*), optional, intent(in) :: run_type_string + +! character(*), parameter :: pdb_format = '(a6,i5,1x,a4,1x,a4,1x,i4,1x,3x,3f13.8,2f6.2,10x,a2,2x,f6.4)' + character(*), parameter :: pdb_format = '(a6,i5,1x,a4,1x,a4,i5,1x,3x,3f13.8,2f6.2,5x,a4,1x,a2,2x,f7.4)' + + !CP2K modified PDB format + ! sor(1:6) = 'ATOM ' + ! sor(7:11) = mm + ! sor(13:16) = this%atom_type(mm) + ! sor(18:21) = this%res_name(mm) + !! sor(22:22) = ' A' !these two are now + ! sor(23:26) = residue_number(mm) ! merged to handle >9999 residues + ! sor(31:43) = at%pos(1,mm) + ! sor(44:56) = at%pos(2,mm) + ! sor(57:69) = at%pos(3,mm) + ! sor(70:75) = ' 0.00' + ! sor(76:81) = ' 0.00' + !! sor(87:90) = 'MOL1' + ! sor(92:93) = ElementName(at%Z(mm)) + ! sor(96:) = this%atom_charge(mm) + + call system_timer('write_cp2k_pdb_file') + + call write_pdb_file(at,pdb_file,pdb_format,run_type_string) + + call system_timer('write_cp2k_pdb_file') + + end subroutine write_cp2k_pdb_file + + subroutine write_psf_file_arb_pos(at,psf_file,run_type_string,intrares_impropers,imp_filename,add_silica_23body,& + pos_field_for_connectivity,form_bond,break_bond, remove_qmmm_link_bonds, & + run_suffix, error) + character(len=*), intent(in) :: psf_file + type(atoms), intent(inout) :: at + character(len=*), optional, intent(in) :: run_type_string + type(Table), optional, intent(in) :: intrares_impropers + character(80), optional, intent(in) :: imp_filename + logical, optional, intent(in) :: add_silica_23body + character(len=*), optional, intent(in) :: pos_field_for_connectivity, run_suffix + integer, optional, intent(in) :: form_bond(2), break_bond(2) + logical, optional, intent(in) :: remove_qmmm_link_bonds + integer, optional, intent(out) :: error + + real(dp), pointer :: use_pos(:,:) + type(Connection) :: t_connect + type(Atoms) :: at_copy + !character(len=TABLE_STRING_LENGTH), pointer :: atom_res_name_p(:) + logical :: use_pos_is_pos, do_add_silica_23body + + INIT_ERROR(error) + + ! save a copy + at_copy = at + + do_add_silica_23body = optional_default(.false., add_silica_23body) + + ! find desired position field (pos, avgpos, whatever) + use_pos_is_pos = .false. + if (present(pos_field_for_connectivity)) then + if (.not. assign_pointer(at, trim(pos_field_for_connectivity), use_pos)) then + RAISE_ERROR("calc_topology can't find pos field '"//trim(pos_field_for_connectivity)//"'", error) + endif + if (trim(pos_field_for_connectivity) == 'pos') use_pos_is_pos = .true. + else + if (.not. assign_pointer(at, 'avgpos', use_pos)) then + RAISE_ERROR("calc_topology can't find default pos field avgpos", error) + endif + endif + + ! copy desired pos to pos, and new connectivity + !NB don't do if use_pos => pos + if (.not. use_pos_is_pos) at_copy%pos = use_pos + + if (do_add_silica_23body) then + call set_cutoff(at_copy,SILICA_2BODY_CUTOFF) + call calc_connect(at_copy, alt_connect=t_connect) + else + ! use hysteretic connect to get nearest neighbour cutoff + ! will use default cutoff, which is the same as heuristics_nneighb_only=.true. + call calc_connect_hysteretic(at, DEFAULT_NNEIGHTOL, DEFAULT_NNEIGHTOL, alt_connect=t_connect) + endif + + + call break_form_bonds(at, t_connect, form_bond, break_bond, error=error) + PASS_ERROR(error) + + ! now create labels using this connectivity object + ! if cutoff is set to 0, heuristics_nneighb_only doesn't matter + ! if cutoff is large, then heuristics_nneighb_only must be true + ! so might as well pass true + if (do_add_silica_23body) then + ! cutoff is large, must do heuristics_nneighb_only=.true., but EVB form bond won't work + call write_psf_file (at,psf_file,run_type_string,intrares_impropers,imp_filename,add_silica_23body,heuristics_nneighb_only=.true.,alt_connect=t_connect,& + remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) + else + ! cutoff is set to 0, all bonds are already heuristics_nneighb_only except extra EVB form_bond bonds + call write_psf_file (at,psf_file,run_type_string,intrares_impropers,imp_filename,add_silica_23body,heuristics_nneighb_only=.false.,alt_connect=t_connect,& + remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) + endif + PASS_ERROR(error) + call finalise(t_connect) + end subroutine write_psf_file_arb_pos + + !% Writes PSF topology file, to be used with the PDB coordinate file. + !% PSF contains the list of atoms, bonds, angles, impropers, dihedrals. + ! + subroutine write_psf_file(at,psf_file,run_type_string,intrares_impropers,imp_filename,add_silica_23body,heuristics_nneighb_only,alt_connect, & + remove_qmmm_link_bonds, run_suffix, error) + + character(len=*), intent(in) :: psf_file + type(atoms), intent(in) :: at + character(len=*), optional, intent(in) :: run_type_string + type(Table), optional, intent(in) :: intrares_impropers + character(80), optional, intent(in) :: imp_filename + logical, optional, intent(in) :: add_silica_23body + logical, intent(in), optional :: heuristics_nneighb_only + type(Connection), intent(in), optional, target :: alt_connect + character(len=*), optional, intent(in) :: run_suffix + logical, optional, intent(in) :: remove_qmmm_link_bonds + integer, intent(out), optional :: error + + type(Inoutput) :: psf + character(103) :: sor + character(*), parameter :: psf_format = '(I8,1X,A4,I5,1X,A4,1X,A4,1X,A4,1X,2G14.6,I8)' + character(*), parameter :: title_format = '(I8,1X,A)' + character(*), parameter :: int_format = 'I8' + integer :: mm, i + character(4) :: QM_prefix_atom_mol_name + character, dimension(:,:), pointer :: atom_type, atom_type_PDB, atom_res_name, atom_mol_name + integer, dimension(:), pointer :: atom_res_number + real(dp), dimension(:), pointer :: atom_charge + type(Table) :: bonds + type(Table) :: angles + type(Table) :: dihedrals, impropers + character(len=STRING_LENGTH) :: my_run_type_string + !integer :: run_type + logical :: do_add_silica_23body + + INIT_ERROR(error) + + call system_timer('write_psf_file_pos') + + !intraresidual impropers: table or read in from file + if (.not.present(intrares_impropers).and..not.present(imp_filename)) call print('WARNING!!! NO INTRARESIDUAL IMPROPERS USED!',verbosity=PRINT_ALWAYS) + if (present(imp_filename)) then + call system_abort('Not yet implemented.') + endif + + do_add_silica_23body = optional_default(.false.,add_silica_23body) + if (do_add_silica_23body) then !!xxx there must be a SIO2 residue? + if (at%cutoff.lt.SILICA_2BODY_CUTOFF) call system_abort('The connect cutoff '//at%cutoff//' is smaller than the required cutoff for silica. Cannot build connectivity to silica.') + endif + + my_run_type_string = optional_default('',run_type_string) +! if ((trim(my_run_type_string).eq.'QMMM_CORE') .or. & +! (trim(my_run_type_string).eq.'QMMM_EXTENDED')) then +! qm_flag_index = get_property(at,'cluster_mark') +! if (trim(my_run_type_string).eq.'QMMM_EXTENDED') run_type=QMMM_RUN_EXTENDED +! if (trim(my_run_type_string).eq.'QMMM_CORE') run_type=QMMM_RUN_CORE +! endif + if (.not. assign_pointer(at, 'atom_type', atom_type)) & + call system_abort('Cannot assign pointer to "atom_type" property.') + if (.not. assign_pointer(at, 'atom_type_PDB', atom_type_PDB)) & + call system_abort('Cannot assign pointer to "atom_type_PDB" property.') + if (.not. assign_pointer(at, 'atom_res_name', atom_res_name)) & + call system_abort('Cannot assign pointer to "atom_res_name" property.') + if (.not. assign_pointer(at, 'atom_mol_name', atom_mol_name)) & + call system_abort('Cannot assign pointer to "atom_mol_name" property.') + if (.not. assign_pointer(at, 'atom_res_number', atom_res_number)) & + call system_abort('Cannot assign pointer to "atom_res_numer" property.') + if (.not. assign_pointer(at, 'atom_charge', atom_charge)) & + call system_abort('Cannot assign pointer to "atom_charge" property.') + + call initialise(psf,trim(psf_file),action=OUTPUT) + call print(' PSF file: '//trim(psf%filename)) + + call print('PSF',file=psf) + call print('',file=psf) + + write(sor,title_format) 1,'!NTITLE' + call print(sor,file=psf) + write(sor,'(A)') ' PSF file generated by libAtoms -- http://www.libatoms.org' + call print(sor,file=psf) + call print('',file=psf) + + ! ATOM section + write(sor,title_format) at%N, '!NATOM' + call print(sor,file=psf) + do mm=1,at%N + QM_prefix_atom_mol_name = '' + QM_prefix_atom_mol_name = trim(a2s(atom_mol_name(:,mm))) +!does not work for contiguous molecules, e.g. silica +!!! if ((trim(my_run_type_string).eq.'QMMM_CORE') .or. & +!!! (trim(my_run_type_string).eq.'QMMM_EXTENDED')) then +!!! if (at%data%int(qm_flag_index,mm).ge.QMMM_RUN_CORE .and. at%data%int(qm_flag_index,mm).le.run_type) then +!!! QM_prefix_atom_mol_name = 'QM'//trim(at%data%str(atom_mol_name_index,mm)) +!!!! call print('QM molecule '//QM_prefix_atom_mol_name) +!!! endif +!!! endif +! call print('molecule '//QM_prefix_atom_mol_name) +! call print('writing PSF file: atom type '//at%data%str(atom_type_index,mm)) + write(sor,psf_format) mm, QM_prefix_atom_mol_name, atom_res_number(mm), & + trim(a2s(atom_res_name(:,mm))),trim(a2s(atom_type_PDB(:,mm))),trim(a2s(atom_type(:,mm))), & + atom_charge(mm),ElementMass(at%Z(mm))/MASSCONVERT,0 + call print(sor,file=psf) + enddo + call print('',file=psf) +call print('PSF| '//at%n//' atoms') + ! BOND section + call create_bond_list(at,bonds,do_add_silica_23body,heuristics_nneighb_only,alt_connect=alt_connect, & + remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) + if (any(bonds%int(1:2,1:bonds%N).le.0) .or. any(bonds%int(1:2,1:bonds%N).gt.at%N)) & + call system_abort('write_psf_file_pos: element(s) of bonds not within (0;at%N]') + call write_psf_section(data_table=bonds,psf=psf,section='BOND',int_format=int_format,title_format=title_format) +call print('PSF| '//bonds%n//' bonds') + + ! ANGLE section + call create_angle_list(at,bonds,angles,do_add_silica_23body,heuristics_nneighb_only,alt_connect=alt_connect, & + remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) + + if (any(angles%int(1:3,1:angles%N).le.0) .or. any(angles%int(1:3,1:angles%N).gt.at%N)) then + do i = 1, angles%N + if (any(angles%int(1:3,i).le.0) .or. any(angles%int(1:3,i).gt.at%N)) & + call print('angle: '//angles%int(1,i)//' -- '//angles%int(2,i)//' -- '//angles%int(3,i),verbosity=PRINT_ALWAYS) + enddo + call system_abort('write_psf_file_pos: element(s) of angles not within (0;at%N]') + endif + call write_psf_section(data_table=angles,psf=psf,section='THETA',int_format=int_format,title_format=title_format) +call print('PSF| '//angles%n//' angles') + + ! DIHEDRAL section + call create_dihedral_list(at,angles,dihedrals,do_add_silica_23body,heuristics_nneighb_only,alt_connect=alt_connect, & + remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) + if (any(dihedrals%int(1:4,1:dihedrals%N).le.0) .or. any(dihedrals%int(1:4,1:dihedrals%N).gt.at%N)) & + call system_abort('write_psf_file_pos: element(s) of dihedrals not within (0;at%N]') + call write_psf_section(data_table=dihedrals,psf=psf,section='PHI',int_format=int_format,title_format=title_format) +call print('PSF| '//dihedrals%n//' dihedrals') + + ! IMPROPER section + call create_improper_list(at,angles,impropers,intrares_impropers=intrares_impropers, & !why not alt_connect? + remove_qmmm_link_bonds=remove_qmmm_link_bonds, run_suffix=run_suffix) + if (any(impropers%int(1:4,1:impropers%N).le.0) .or. any(impropers%int(1:4,1:impropers%N).gt.at%N)) & + call system_abort('write_psf_file_pos: element(s) of impropers not within (0;at%N]') + call write_psf_section(data_table=impropers,psf=psf,section='IMPHI',int_format=int_format,title_format=title_format) +call print('PSF| '//impropers%n//' impropers') + + !empty DON, ACC and NNB sections + write(sor,title_format) 0,'!NDON' + call print(sor,file=psf) + call print('',file=psf) + + write(sor,title_format) 0,'!NACC' + call print(sor,file=psf) + call print('',file=psf) + + write(sor,title_format) 0,'!NNB' + call print(sor,file=psf) + call print('',file=psf) + + call print('END',file=psf) + + call finalise(bonds) + call finalise(angles) + call finalise(dihedrals) + call finalise(impropers) + call finalise(psf) + + call system_timer('write_psf_file_pos') +!call print('psf written. stop.') +!stop + + end subroutine write_psf_file + + !% Writes a section of the PSF topology file. + !% Given a $section$ (name of the section) and a table $data_table$ with the data, + !% it writes them into $psf$ file with $int_format$ format. + !% Used by write_psf_file. + ! + subroutine write_psf_section(data_table,psf,section,int_format,title_format) + + type(Table), intent(in) :: data_table + type(InOutput), intent(in) :: psf + character(len=*), intent(in) :: section + character(*), intent(in) :: int_format + character(*), intent(in) :: title_format + + character(len=103) :: sor + integer :: mm, i, num_per_line + + if (.not.any(size(data_table%int,1).eq.(/2,3,4/))) & + call system_abort('data table to print into psf file has wrong number of integers '//size(data_table%int,1)) + if (size(data_table%int,1).eq.2) num_per_line = 4 + if (size(data_table%int,1).eq.3) num_per_line = 3 + if (size(data_table%int,1).eq.4) num_per_line = 2 + + sor = '' + write(sor,title_format) data_table%N, '!N'//trim(section) + call print(sor,file=psf) + + mm = 1 + do while (mm.le.(data_table%N-num_per_line+1-mod(data_table%N,num_per_line))) + select case(size(data_table%int,1)) + case(2) + write(sor,'(8'//trim(int_format)//')') & + data_table%int(1,mm), data_table%int(2,mm), & + data_table%int(1,mm+1), data_table%int(2,mm+1), & + data_table%int(1,mm+2), data_table%int(2,mm+2), & + data_table%int(1,mm+3), data_table%int(2,mm+3) + mm = mm + 4 + case(3) + write(sor,'(9'//trim(int_format)//')') & + data_table%int(1,mm), data_table%int(2,mm), data_table%int(3,mm), & + data_table%int(1,mm+1), data_table%int(2,mm+1), data_table%int(3,mm+1), & + data_table%int(1,mm+2), data_table%int(2,mm+2), data_table%int(3,mm+2) + mm = mm + 3 + case(4) + write(sor,'(8'//trim(int_format)//')') & + data_table%int(1,mm), data_table%int(2,mm), data_table%int(3,mm), data_table%int(4,mm), & + data_table%int(1,mm+1), data_table%int(2,mm+1), data_table%int(3,mm+1), data_table%int(4,mm+1) + mm = mm + 2 + end select + call print(sor,file=psf) + enddo + + ! mm = data_table%N - mod(data_table%N,num_per_line) + 1 + sor = '' + do i=1, mod(data_table%N,num_per_line) !if 0 then it does nothing + select case(size(data_table%int,1)) + case(2) + write(sor((i-1)*16+1:i*16),'(2'//trim(int_format)//')') data_table%int(1,mm), data_table%int(2,mm) + case(3) + write(sor((i-1)*24+1:i*24),'(3'//trim(int_format)//')') data_table%int(1,mm), data_table%int(2,mm), data_table%int(3,mm) + case(4) + write(sor((i-1)*32+1:i*32),'(4'//trim(int_format)//')') data_table%int(1,mm), data_table%int(2,mm), data_table%int(3,mm), data_table%int(4,mm) + end select + mm = mm + 1 + enddo + + if (mm .ne. data_table%N+1) call system_abort('psf writing: written '//(mm-1)//' of '//data_table%N) + if (mod(data_table%N,num_per_line).ne.0) call print(sor,file=psf) + call print('',file=psf) + + end subroutine write_psf_section + + !% Subroutine to create a $bonds$ table with all the nearest neighbour bonds + !% according to the connectivity. If $add_silica_23body$ is true, include + !% atom pairs that have SIO2 molecule type up to the silica_cutoff distance. + !% Optionally use hysteretic_connect, if it is passed as alt_connect. + ! + subroutine create_bond_list(at,bonds,add_silica_23body,heuristics_nneighb_only,alt_connect, & + remove_qmmm_link_bonds, run_suffix) + + type(Atoms), intent(in) :: at + type(Table), intent(out) :: bonds + logical, intent(in) :: add_silica_23body + logical, intent(in), optional :: heuristics_nneighb_only + type(Connection), intent(in), optional, target :: alt_connect + logical, intent(in), optional :: remove_qmmm_link_bonds + character(len=*), intent(in), optional :: run_suffix + + character(*), parameter :: me = 'create_bond_list: ' + + type(Table) :: atom_a,atom_b + integer :: i,j + integer :: atom_j +! logical :: do_qmmm +! integer,dimension(3) :: pos_indices +! integer :: qm_flag_index + character(STRING_LENGTH) :: my_run_suffix + character, pointer, dimension(:,:) :: atom_mol_name + integer, pointer, dimension(:) :: cluster_mark + logical :: add_bond, do_remove_qmmm_link_bonds + + call system_timer('create_bond_list') + + do_remove_qmmm_link_bonds = optional_default(.false., remove_qmmm_link_bonds) + my_run_suffix = optional_default('', run_suffix) + + if (do_remove_qmmm_link_bonds) then + call assign_property_pointer(at, 'cluster_mark'//trim(my_run_suffix), cluster_mark) + end if + + if (add_silica_23body) then + if (at%cutoff.lt.SILICA_2BODY_CUTOFF) call system_abort('The connect cutoff '//at%cutoff//' is smaller than the required cutoff for silica. Cannot build connectivity to silica.') + if (.not. assign_pointer(at, 'atom_mol_name', atom_mol_name)) & + call system_abort('Cannot assign pointer to "atom_mol_name" property.') + endif + call initialise(bonds,2,0,0,0,0) + +! do_qmmm = .true. +! if (get_value(at%properties,trim('QM_flag'),pos_indices)) then +! qm_flag_index = pos_indices(2) +! else +! do_qmmm = .false. +! end if +! + do i=1,at%N + call initialise(atom_a,4,0,0,0,0) + call append(atom_a,(/i,0,0,0/)) + if (add_silica_23body) then + call bfs_step(at,atom_a,atom_b,nneighb_only=.false.,min_images_only=.true.,alt_connect=alt_connect) ! SILICON_2BODY_CUTOFF is not within nneigh_tol + else + call bfs_step(at,atom_a,atom_b,nneighb_only=heuristics_nneighb_only,min_images_only=.true.,alt_connect=alt_connect) + endif + do j = 1,atom_b%N + atom_j = atom_b%int(1,j) + if (atom_j.gt.i) then +! ! QM core atoms should be isolated atoms +!!call print('atom '//i//' (QM flag '//at%data%int(qm_flag_index,i)//')') +!!call print('atom '//atom_j//' (QM flag '//at%data%int(qm_flag_index,atom_j)//')') +! +! if (do_qmmm) then +! if (any((/at%data%int(qm_flag_index,i),at%data%int(qm_flag_index,atom_j)/).eq.1)) then +!! call print('not added '//i//' (QM flag '//at%data%int(qm_flag_index,i)//') -- '//atom_j//' (QM flag '//at%data%int(qm_flag_index,atom_j)//')') +! cycle +! else +!! call print('added '//i//' (QM flag '//at%data%int(qm_flag_index,i)//') -- '//atom_j//' (QM flag '//at%data%int(qm_flag_index,atom_j)//')') +! endif +! endif + + add_bond = .true. + + if (add_silica_23body) then ! do not include H2O -- SiO2 bonds + if ( ((trim(a2s(atom_mol_name(:,atom_j))) .eq.'SIO2' .and. trim(a2s(atom_mol_name(:,i))).ne.'SIO2')) .or. & + ((trim(a2s(atom_mol_name(:,atom_j))) .ne.'SIO2' .and. trim(a2s(atom_mol_name(:,i))).eq.'SIO2')) ) then !silica -- something +!call system_abort('should have not got here') + !add only nearest neighbours + if (.not.(is_nearest_neighbour_abs_index(at,i,atom_j,alt_connect=alt_connect))) add_bond = .false. + elseif ((trim(a2s(atom_mol_name(:,atom_j))) .eq.'SIO2' .and. trim(a2s(atom_mol_name(:,i))).eq.'SIO2')) then !silica -- silica + !add atom pairs within SILICON_2BODY_CUTOFF +!call system_abort('what not?') + if (.not.are_silica_2body_neighbours(at,i,atom_j,alt_connect=alt_connect)) add_bond = .false. !SILICON_2BODY_CUTOFF for Si-Si and Si-O, nearest neighbours otherwise(Si-H,O-O,O-H,H-H) + else +!call system_abort('should have not got here') + !add only nearest neighbours + if (.not.(is_nearest_neighbour_abs_index(at,i,atom_j,alt_connect=alt_connect))) add_bond = .false. + endif + endif + + if (do_remove_qmmm_link_bonds) then + ! skip bond if it is a QM-MM link + if ((cluster_mark(i) == HYBRID_NO_MARK) .neqv. (cluster_mark(atom_j) == HYBRID_NO_MARK)) then + call print('create_bond_list: removing QM/MM link bond '//i//'--'//atom_j, PRINT_VERBOSE) + add_bond = .false. + end if + end if + + if (add_bond) then + call append(bonds,(/i,atom_j/)) + endif + + else +! call print('not added '//i//' -- '//atom_j) + endif + enddo + call finalise(atom_a) + call finalise(atom_b) + enddo + + if (any(bonds%int(1:2,1:bonds%N).le.0) .or. any(bonds%int(1:2,1:bonds%N).gt.at%N)) & + call system_abort('create_bond_list: element(s) of bonds not within (0;at%N]') + + call system_timer('create_bond_list') + + end subroutine create_bond_list + + + !% Test if atom $j$ is a neighbour of atom $i$ for the silica 2 body terms. + !% Optionally use hysteretic_connect, if it is passed as alt_connect. + !% + function are_silica_2body_neighbours(this,i,j,alt_connect) + + type(Atoms), intent(in), target :: this + integer, intent(in) :: i,j + type(Connection), intent(in), optional, target :: alt_connect + logical :: are_silica_2body_neighbours + + real(dp) :: d + integer :: neigh, Z_i, Z_j, j2 + + are_silica_2body_neighbours = .false. + + do neigh = 1, n_neighbours(this,i) + j2 = neighbour(this,i,neigh,distance=d,alt_connect=alt_connect) + if (j2.eq.j) then + Z_i = this%Z(i) + Z_j = this%Z(j) + if ( ((Z_i.eq.14).and.(Z_j.eq. 8)) .or. & !Si--O + ((Z_i.eq. 8).and.(Z_j.eq.14)) .or. & !O--Si + ((Z_i.eq. 8).and.(Z_j.eq. 8)) ) then !O--O + if (d < SILICA_2BODY_CUTOFF) & + are_silica_2body_neighbours = .true. + elseif ((Z_i.eq.14).and.(Z_j.eq.14)) then !Si--Si + if (d < SILICON_2BODY_CUTOFF) & + are_silica_2body_neighbours = .true. +!call print(i//'--'//j//': '//d//' < 2.8? '//are_silica_2body_neighbours) + else !Si--H, O--H, O--O, H--H + if (d < (bond_length(Z_i,Z_j)*this%nneightol)) & + are_silica_2body_neighbours = .true. +!call print(i//'--'//j//': '//d//' < nneigh_tol? '//are_silica_2body_neighbours) + endif + return + endif + enddo + + call system_abort('are_silica_2body_neighbours: atom '//j//'is not a neighbour of atom '//i) + + end function are_silica_2body_neighbours + + !% Test if atom $j$ is a nearest neighbour of atom $i$ for the silica 3 body terms. + !% Optionally use hysteretic_connect, if it is passed as alt_connect. + !% + function are_silica_nearest_neighbours(this,i,j,alt_connect) + + type(Atoms), intent(in), target :: this + integer, intent(in) :: i,j + type(Connection), intent(in), optional, target :: alt_connect + logical :: are_silica_nearest_neighbours + + real(dp) :: d + integer :: neigh, Z_i, Z_j, j2 + + are_silica_nearest_neighbours = .false. + + do neigh = 1, n_neighbours(this,i) + j2 = neighbour(this,i,neigh,distance=d,alt_connect=alt_connect) + if (j2.eq.j) then + Z_i = this%Z(i) + Z_j = this%Z(j) + if ( ((Z_i.eq.14).and.(Z_j.eq. 8)) .or. & !Si--O + ((Z_i.eq. 8).and.(Z_j.eq.14)) .or. & !O--Si + ((Z_i.eq.14).and.(Z_j.eq.14)) ) then !Si--Si + if (d < SILICON_2BODY_CUTOFF) & + are_silica_nearest_neighbours = .true. +!call print(i//'--'//j//': '//d//' < 2.8? '//are_silica_nearest_neighbours) + else !Si--H, O--H, O--O, H--H + if (d < (bond_length(Z_i,Z_j)*this%nneightol)) & + are_silica_nearest_neighbours = .true. +!call print(i//'--'//j//': '//d//' < nneigh_tol? '//are_silica_nearest_neighbours) + endif + return + endif + enddo + + call system_abort('are_silica_nearest_neighbours: atom '//j//'is not a neighbour of atom '//i) + + end function are_silica_nearest_neighbours + + !% Subroutine to create an $angles$ table with all the angles, + !% according to the connectivity nearest neighbours. If $add_silica_23body$ is true, include + !% atom triplets that have SIO2 molecule type and the distances are smaller than the cutoff + !% for the corresponding 3 body cutoff. + !% Optionally use hysteretic_connect if passed as alt_connect. + ! + subroutine create_angle_list(at,bonds,angles,add_silica_23body,heuristics_nneighb_only,alt_connect, & + remove_qmmm_link_bonds, run_suffix) + + type(Atoms), intent(in) :: at + type(Table), intent(in) :: bonds + type(Table), intent(out) :: angles + logical, intent(in) :: add_silica_23body + logical, intent(in), optional :: heuristics_nneighb_only + type(Connection), intent(in), optional, target :: alt_connect + logical, intent(in), optional :: remove_qmmm_link_bonds + character(len=*), intent(in), optional :: run_suffix + character(*), parameter :: me = 'create_angle_list: ' + integer, pointer, dimension(:) :: cluster_mark + + + integer :: i,j + type(Table) :: atom_a, atom_b + integer :: atom_j, atom_1, atom_2 + logical :: add_angle, do_remove_qmmm_link_bonds + character, pointer, dimension(:,:) :: atom_mol_name, atom_type + character(STRING_LENGTH) :: my_run_suffix + + call system_timer('create_angle_list') + + do_remove_qmmm_link_bonds = optional_default(.false., remove_qmmm_link_bonds) + my_run_suffix = optional_default('', run_suffix) + + if (do_remove_qmmm_link_bonds) then + call assign_property_pointer(at, 'cluster_mark'//trim(my_run_suffix), cluster_mark) + end if + + if (add_silica_23body) then + if (.not. assign_pointer(at, 'atom_type', atom_type)) & + call system_abort('Cannot assign pointer to "atom_type" property.') + if (.not. assign_pointer(at, 'atom_mol_name', atom_mol_name)) & + call system_abort('Cannot assign pointer to "atom_mol_name" property.') + endif + + call initialise(angles,3,0,0,0,0) + + do i=1,bonds%N + + atom_1 = bonds%int(1,i) + atom_2 = bonds%int(2,i) + + ! look for one more to the beginning: ??--1--2 where ??<2 + call initialise(atom_a,4,0,0,0,0) + call append(atom_a,(/atom_1,0,0,0/)) + + if (add_silica_23body) then +!call system_abort('stop!') + call bfs_step(at,atom_a,atom_b,nneighb_only=.false.,min_images_only=.true.,alt_connect=alt_connect) ! SILICON_2BODY_CUTOFF is not within nneigh_tol + else + call bfs_step(at,atom_a,atom_b,nneighb_only=heuristics_nneighb_only,min_images_only=.true.,alt_connect=alt_connect) + endif + + do j = 1,atom_b%N +!call print('atom '//j//' out of '//atom_b%N//' which is atom '//atom_j) + atom_j = atom_b%int(1,j) + if (atom_j.ge.atom_2) cycle + + add_angle = .true. + + if (add_silica_23body) then ! do not include H2O -- SiO2 bonds + if ( ((trim(a2s(atom_mol_name(:,atom_j))) .eq.'SIO2' .and. trim(a2s(atom_mol_name(:,atom_1))).ne.'SIO2')) .or. & + ((trim(a2s(atom_mol_name(:,atom_j))) .ne.'SIO2' .and. trim(a2s(atom_mol_name(:,atom_1))).eq.'SIO2')) ) then !silica -- something + !add only nearest neighbours + if (.not.(is_nearest_neighbour_abs_index(at,atom_1,atom_j,alt_connect=alt_connect))) add_angle = .false. + elseif ((trim(a2s(atom_mol_name(:,atom_j))) .eq.'SIO2' .and. trim(a2s(atom_mol_name(:,atom_1))).eq.'SIO2')) then !silica -- silica + !add atom pairs within SILICON_2BODY_CUTOFF + if (.not.are_silica_nearest_neighbours(at,atom_1,atom_j,alt_connect=alt_connect)) add_angle = .false. + + ! we kept 2.8 A cutoff for Si-Si and 5.5 A for Si-O and O-O: reduce it to 2.6 for Si-O-Si, O-Si-O, Si-O-H + if (add_angle) then + if (any(at%Z(atom_j)*1000000+at%Z(atom_1)*1000+at%Z(atom_2).eq.(/14008014,8014008,14008001,1008014/))) then + add_angle = (distance_min_image(at,atom_j,atom_1).le.SILICA_3BODY_CUTOFF).and. & + (distance_min_image(at,atom_1,atom_2).le.SILICA_3BODY_CUTOFF) + elseif (any(at%Z(atom_j)*1000000+at%Z(atom_1)*1000+at%Z(atom_2).eq.(/14008008,8008014,1008008,8008001,8008008/))) then + add_angle = .false. + endif + endif + else !something -- something, neither are silica + !add only nearest neighbours + if (.not.(is_nearest_neighbour_abs_index(at,atom_1,atom_j,alt_connect=alt_connect))) add_angle = .false. + endif + endif + + if (do_remove_qmmm_link_bonds) then + ! skip angle if it spans the QM-MM boundary + if ( .not. (all(cluster_mark( (/atom_j, atom_1, atom_2/) ) == HYBRID_NO_MARK) .or. & + all(cluster_mark( (/atom_j, atom_1, atom_2/) ) /= HYBRID_NO_MARK))) then + call print('create_angle_list: removing QM/MM spanning angle '//(/atom_j, atom_1, atom_2/), PRINT_VERBOSE) + add_angle = .false. + end if + end if + +! if (add_angle.and.(atom_j.lt.atom_2)) & + if (add_angle) & !.and.(atom_j.lt.atom_2)) & + call append(angles,(/atom_j,atom_1,atom_2/)) + + enddo + + call finalise(atom_a) + call finalise(atom_b) + + ! look for one more to the end: 1--2--?? where 1= 1) .and. all(form_bond <= at%N)) then + bond_exists = .false. + do ji=1, n_neighbours(at, form_bond(1), alt_connect=conn) + j = neighbour(at, form_bond(1), ji, shift=shift, alt_connect=conn) + if (j == form_bond(2)) then + bond_exists = .true. + exit + endif + end do + if (.not. bond_exists) then + form_bond_dist = distance_min_image(at, form_bond(1), form_bond(2), shift=shift) + call add_bond(conn, at%pos, at%lattice, form_bond(1), form_bond(2), shift, form_bond_dist, error=error) + PASS_ERROR(error) + endif + endif ! valid atom #s + endif ! present(form_bond) + if (present(break_bond)) then + if (all(break_bond >= 1) .and. all(break_bond <= at%N)) then + bond_exists = .false. + do ji=1, n_neighbours(at, break_bond(1), alt_connect=conn) + j = neighbour(at, break_bond(1), ji, shift=shift, alt_connect=conn) + if (j == break_bond(2)) then + bond_exists = .true. + exit + endif + end do + if (bond_exists) then + call remove_bond(conn, break_bond(1), break_bond(2), shift, error=error) + PASS_ERROR(error) + endif + endif ! valid atom #s + endif ! present(break_bond) + end subroutine break_form_bonds + + function find_motif_backbone(motif, is_proline) result(backbone) + integer :: motif(:,:) + logical :: is_proline + integer :: backbone(5,3) + + integer :: i, ji, j, ki, k, li, l, mi, m, ii, ni, n, found_N, found_aC, found_cC + + is_proline = .false. + + backbone = 0 + do i=1, size(motif,1) ! look for N +!call print("check atom i " //i // " Z=" // motif(i,1)) + if (motif(i,1) /= 7) cycle + ! i is an N + found_N = i +!call print("atom i is a N, continuing") + do ji=2, size(motif,2) ! look for alpha-C + j=motif(i,ji); if (j == 0) exit +!call print("check atom j "//j//" Z=" // motif(j,1)) + if (motif(j,1) == 6) then ! j is a possible alpha-C +!call print("atom j is a C, continuing") + found_aC = j + do ki=2, size(motif,2) ! look for possible carboxyl-C + k = motif(j,ki); if (k == 0) exit +!call print("check atom k " //k//" Z=" // motif(k,1)) + if (motif(k,1) == 6) then ! k is a possible carboxyl-C +!call print("atom k is a C, continuing") + found_cC = k + do li=2, size(motif,2) ! loook for possible carboxyl-O + l = motif(k, li); if (l == 0) exit +!call print("check atom l "//l//" Z=" // motif(l,1)) + if (motif(l,1) == 8 .and. count(motif(l,2:) /= 0) == 1) then ! found carboxyl O +!call print("atom l is an O with coord 1, continuing") + + ii = 1 + backbone(ii,1) = found_N + do mi=2, size(motif,2) ! find neighbours of N for backbone + m = motif(found_N, mi); if (m == 0) exit +!call print("neighbor m " // m // " Z="//motif(m,1)// " neighbor of N") + if (m == found_aC) cycle + if (motif(m,1) == 1) then +!call print("neighbor m is a H, adding to backbone") + ii = ii + 1 + backbone(ii,1) = m + else if (motif(m,1) == 6) then + is_proline = .true. + else + call print("find_motif_backbone confused by neighbor of N", PRINT_VERBOSE) + backbone = 0 + return + endif + end do ! mi + + ii = 1 + backbone(ii,2) = found_aC + do mi=2, size(motif,2) ! find neighbours of alpha-C for backbone + m = motif(found_aC, mi); if (m == 0) exit +!call print("neighbor m " // m // " Z="//motif(m,1)// " neighbor of alpha-C") + if (m == found_N .or. m == found_cC) cycle + if (motif(m,1) == 1) then +!call print("neighbor m is a H, adding to backbone") + ii = ii + 1 + backbone(ii,2) = m + else if (motif(m,1) /= 6) then + call print("find_motif_backbone confused by neighbor of alpha-C, neither H or C", PRINT_VERBOSE) + backbone = 0 + return + endif + end do ! mi + + ii = 1 + backbone(ii,3) = found_cC + do mi=2, size(motif,2) ! find neighbours of carboxyl-C for backbone + m = motif(found_cC, mi); if (m == 0) exit +!call print("neighbor m " // m // " Z="//motif(m,1)// " neighbor of carboxyl-C") + if (m == found_aC) cycle + if (motif(m,1) == 8) then +!call print("neighbor m is an O, adding to backbone") + ii = ii + 1 + backbone(ii,3) = m + do ni=2, size(motif,2) ! look for OH + n = motif(m, ni); if (n == 0) exit + if (n == found_cC) cycle +!call print("neighbor n " // n // " Z="//motif(n,1)// " neighbor of carboxyl-C-O") + if (motif(n,1) == 1) then +!call print("neighbor n is an H, adding to backbone") + ii = ii + 1 + backbone(ii,3) = n + else + call print("find_motif_backbone confused by non-H neighbor of carboxyl-O", PRINT_VERBOSE) + backbone = 0 + return + endif + end do + else + call print("find_motif_backbone confused by neighbor of carboxyl-C", PRINT_VERBOSE) + backbone = 0 + return + endif + end do ! mi + endif ! found carboxyl O + end do ! li + endif ! carboxyl-C + end do ! ki + endif ! found alpha C + end do ! ji + end do ! i + end function find_motif_backbone + + subroutine find_general_monomer(at,monomer_index,signature,is_associated,cutoff,general_ordercheck,error) + type(atoms), intent(in) :: at + integer, intent(in), dimension(:) :: signature + real(dp), dimension(:), allocatable :: r + real(dp) :: r_ij, cutoff + integer, dimension(1) :: temp + integer, dimension(:), allocatable :: indices + integer, dimension(:,:), allocatable :: monomer_index, monomer_index_working + integer, intent(out), optional :: error + logical, optional :: general_ordercheck + integer :: i, j, k, n, Z_uniq_index, Z_uniq, Z_uniq_pos, monomers_found + logical, dimension(:), intent(inout) :: is_associated + logical :: do_general_ordercheck + + do_general_ordercheck = optional_default(.true.,general_ordercheck) + + allocate(monomer_index(size(signature),0)) + allocate(monomer_index_working(size(signature),0)) + allocate(r(size(signature))) + allocate(indices(size(signature))) + + monomers_found = 0 + if(do_general_ordercheck) then + do i = 1, at%N + if(.not. is_associated(i) .and. any(signature .eq. at%Z(i))) then + if (at%Z(i) == 1) cycle ! for now, don't let H be at the centre of a monomer + + r = cutoff ! initialise distances + indices = 0 ! initialise indices + temp = minloc(signature, signature .eq. at%Z(i)) ! will return location of first element of signature with correct Z + indices(temp(1))=i + r(temp(1))=0.0 + + do n = 1, n_neighbours(at, i) + j = neighbour(at, i, n, distance=r_ij) + if(is_associated(j) .or. .not. any(signature .eq. at%Z(j)) ) cycle + + do k=1,maxval(signature) + if (at%Z(j) .eq. k) then + if(r_ij .lt. maxval(r, mask = signature .eq. at%Z(j)) ) then + temp = maxloc(r, mask = signature .eq. at%Z(j)) + r(temp(1)) = r_ij + indices(temp(1)) = j + exit + end if + end if + end do + end do + + if(any(indices .eq. 0)) cycle ! couldn't make a monomer with i as central atom + + monomers_found = monomers_found + 1 ! number of monomers found so far + do k=1,size(signature) + is_associated(indices(k))=.true. + end do + + deallocate(monomer_index_working) + allocate(monomer_index_working(size(monomer_index,1),size(monomer_index,2))) + monomer_index_working =monomer_index + deallocate(monomer_index) + allocate(monomer_index(size(monomer_index_working,1),size(monomer_index_working,2)+1)) + monomer_index(:,:monomers_found-1) = monomer_index_working + monomer_index(:,monomers_found) = indices + end if + end do + else ! do_general_ordercheck = .false. + n = size(signature) + do i = 1, at%N-n+1 + if(.not. any(is_associated(i:i+n-1)) .and. all(signature(:) .eq. at%Z(i:i+n-1))) then + monomers_found = monomers_found + 1 ! number of monomers found so far + indices = (/(i+k, k=0,n-1)/) + is_associated(i:i+n-1) = .true. + + deallocate(monomer_index_working) + allocate(monomer_index_working(size(monomer_index,1), size(monomer_index,2))) + monomer_index_working = monomer_index + deallocate(monomer_index) + allocate(monomer_index(size(monomer_index_working,1), size(monomer_index_working,2)+1)) + monomer_index(:,:monomers_found-1) = monomer_index_working + monomer_index(:,monomers_found) = indices + end if + enddo + end if ! do_general_ordercheck + + deallocate(monomer_index_working) + deallocate(r) + deallocate(indices) + + end subroutine find_general_monomer + + subroutine find_monomer_pairs(at_in,monomer_pairs,mean_pos_diffs,pairs_diffs_map,monomer_one_index,monomer_two_index,monomers_identical,double_count,cutoff,pairs_shifts,error,use_com) + ! finds pairs of monomers combined into dimer if *any pair* of atoms are within cutoff. Returns 2 by n array of pairs, + ! the elements of which refer to the second index of the monomer_one_index and monomer_two_index matrices respectively. + ! also returns a set of diffs, which are vectors between the mean positions of the shifted versions of these pairs. + type(atoms), intent(in) :: at_in + integer, dimension(:,:), allocatable, intent(out) :: monomer_pairs + real(dp),dimension(:,:), allocatable, intent(out) :: mean_pos_diffs + integer, dimension(:), allocatable, intent(out) :: pairs_diffs_map + integer, intent(in), dimension(:,:) :: monomer_one_index, monomer_two_index + logical, intent(in) :: monomers_identical, double_count + real(dp), intent(in) :: cutoff + integer, dimension(:,:), allocatable, intent(out), optional :: pairs_shifts + integer, intent(out), optional :: error + logical, intent(in), optional :: use_com + + type(atoms) :: at + integer, dimension(:,:), allocatable :: mean_pos_shifts + integer, dimension(:), allocatable :: atomic_index_one, atomic_index_two + integer :: i, j, i_atomic, j_atomic, n, i_neighbour, i_desc, k, m, n_pairs,monomer_one_size ,monomer_two_size,rep,n_repeats + real(dp) :: r_one_two, mass_one, mass_two, temp_dist,min_dist + + real(dp), dimension(3) :: diff_one_two, mean_pos_one, mean_pos_two ! unweighted mean position of atoms in monomer, if monomer straddles cell boundary this will be in the middle of the cell + integer, dimension(3) :: shift_one_two, shift_one, shift_two,min_image_shift + integer, dimension(2) :: temp2d + integer, dimension(1) :: temp1d + logical, dimension(:), allocatable :: shifts_mask + logical :: do_use_com + + do_use_com = optional_default(.false., use_com) + + ! make a copy of the atoms object + at = at_in + call set_cutoff(at,cutoff+0.5_dp) + call calc_connect(at) + + allocate(monomer_pairs(2,0)) + allocate(mean_pos_shifts(3,0)) + allocate(mean_pos_diffs(3,0)) + allocate(pairs_diffs_map(0)) + allocate(shifts_mask(0)) + + monomer_one_size = size(monomer_one_index,1) + monomer_two_size = size(monomer_two_index,1) + + allocate(atomic_index_one(monomer_one_size)) + allocate(atomic_index_two(monomer_two_size)) + + i_desc=0 + n_pairs=0 + + ! loop over all occurences of first monomer + loop_monomer_one: do i=1,size(monomer_one_index,2) + atomic_index_one = monomer_one_index(:,i) + if (do_use_com) then + mean_pos_one = centre_of_mass(at,index_list=atomic_index_one) + else + mean_pos_one = calc_mean_pos(at,atomic_index_one) + endif + + !loop over neighbours of each atom, check at least one pair of heavy atoms within cutoff and belong to an occurrence of monomer_two + loop_monomer_one_atoms: do i_atomic=1,size(monomer_one_index,1) + if (at%Z(atomic_index_one(i_atomic)) == 1) cycle ! skip hydrogens + + loop_monomer_one_atom_neighbours: do n = 1, n_neighbours(at,atomic_index_one(i_atomic)) + + i_neighbour = neighbour(at,atomic_index_one(i_atomic),n,distance=r_one_two,shift=shift_one_two) + if (at%Z(i_neighbour) == 1 ) cycle ! skip hydrogens + if( r_one_two >= cutoff ) cycle + temp2d = maxloc(monomer_two_index, monomer_two_index .eq. i_neighbour) + if (any(temp2d .eq. 0)) cycle ! atom i_neighbour does not belong to the type of monomer we're looking for + j = temp2d(2) ! atom i_neighbour belongs to monomer j + atomic_index_two = monomer_two_index(:,j) + if (do_use_com) then + mean_pos_two = centre_of_mass(at,index_list=atomic_index_two) + else + mean_pos_two = calc_mean_pos(at,atomic_index_two) + endif + + temp_dist = distance_min_image(at,i_neighbour,mean_pos_two,shift=shift_two) + shift_one_two = shift_one_two + shift_two + + ! get the diff vector between the shifted mean positions + min_dist = distance_min_image(at,mean_pos_one,mean_pos_two,shift=min_image_shift) + diff_one_two = diff_min_image(at,mean_pos_one,mean_pos_two) + matmul(at%lattice,shift_one_two-min_image_shift) + + ! this makes sure we don't double count. All monomer pairs in the unit cell are found, + ! as are half of the monomer pairs in which one of the monomers is from a neighbour cell + are_monomers_identical: if (monomers_identical) then + if (all(shift_one_two .eq. 0)) then + if (i .ge. j) cycle + else + if (i .gt. j) cycle + if (i == j) then + temp1d = maxloc(monomer_pairs(1,:), monomer_pairs(1,:) .eq. i .and. monomer_pairs(2,:) .eq. i) + k=temp1d(1) + if (k > 0) then + shifts_mask =(/ mean_pos_shifts(1,:) .eq. -shift_one_two(1)/) .and. & + (/ mean_pos_shifts(2,:) .eq. -shift_one_two(2)/) .and. & + (/ mean_pos_shifts(3,:) .eq. -shift_one_two(3)/) + if (count( (/pairs_diffs_map .eq. k /) .and. shifts_mask) > 0) cycle ! cycle if negative shift already present + end if + end if + end if + end if are_monomers_identical + + ! check if this combination of monomers was already found + temp1d = maxloc(monomer_pairs(1,:), monomer_pairs(2,:) .eq. j .and. monomer_pairs(1,:) .eq. i) + k=temp1d(1) ! if so, pair is at (:,k) in the monomer_pairs array , else equals 0 + + if (k > 0 ) then ! have found this pair before + shifts_mask =(/ mean_pos_shifts(1,:) .eq. shift_one_two(1)/) .and. & + (/ mean_pos_shifts(2,:) .eq. shift_one_two(2)/) .and. & + (/ mean_pos_shifts(3,:) .eq. shift_one_two(3)/) + if (count( (/pairs_diffs_map .eq. k/) .and. shifts_mask) > 0) cycle ! cycle if we've already found this pair with this shift + + else ! new pair + n_pairs = n_pairs + 1 + call reallocate(monomer_pairs,2,n_pairs,copy=.true.) + monomer_pairs(:,n_pairs) = (/ i,j /) + k=n_pairs + end if + + n_repeats = 1 + if (double_count) n_repeats = 2 + do rep=1,n_repeats ! save this shift, possibly twice if we're double-counting + i_desc = i_desc + 1 + call reallocate(mean_pos_shifts,3,i_desc,copy=.true.) + call reallocate(mean_pos_diffs,3,i_desc,copy=.true.) + call reallocate(pairs_diffs_map,i_desc,copy=.true.) + call reallocate(shifts_mask,i_desc) + mean_pos_shifts(:,i_desc) = shift_one_two + mean_pos_diffs(:,i_desc) = diff_one_two + pairs_diffs_map(i_desc) = k + end do + + end do loop_monomer_one_atom_neighbours + end do loop_monomer_one_atoms + end do loop_monomer_one + + if (present(pairs_shifts)) then + allocate(pairs_shifts(3,size(mean_pos_shifts,2))) + pairs_shifts = mean_pos_shifts + end if + call finalise(at) + deallocate(mean_pos_shifts) + deallocate(atomic_index_one) + deallocate(atomic_index_two) + deallocate(shifts_mask) + + end subroutine find_monomer_pairs + + subroutine find_monomer_pairs_MPI(at,monomer_pairs,mean_pos_diffs,pairs_diffs_map,monomer_one_index,monomer_two_index,monomers_identical,double_count,cutoff,pairs_shifts,error,use_com,atom_mask) + ! finds pairs of monomers combined into dimer if the centers of mass (use_com=T)/geometry(F) are within cutoff. + ! (currently loops over all monomers, and doesn't take into account + ! interactions with mirror images) + ! Optionally takes atom_mask for use in MPI parallelisation, only looks for dimers whose first monomer is captured by the atom mask. + ! Returns dimers in ascending order of monomer index (hence no double-counting). + ! Returns 2 by n array of pairs, + ! the elements of which refer to the second index of the monomer_one_index and monomer_two_index matrices respectively. + ! also returns a set of diffs, which are vectors between the mean positions of the shifted versions of these pairs. + type(atoms), intent(in) :: at + integer, dimension(:,:), allocatable, intent(out) :: monomer_pairs ! 2 x n: (index into monomer_one_index, index into monomer_two_index) + real(dp),dimension(:,:), allocatable, intent(out) :: mean_pos_diffs ! + integer, dimension(:), allocatable, intent(out) :: pairs_diffs_map + integer, intent(in), dimension(:,:) :: monomer_one_index, monomer_two_index + logical, intent(in) :: monomers_identical, double_count + real(dp), intent(in) :: cutoff + integer, dimension(:,:), allocatable, intent(out), optional :: pairs_shifts + integer, intent(out), optional :: error + logical, intent(in), optional :: use_com + logical, dimension(:), intent(in), optional :: atom_mask + + integer, dimension(:,:), allocatable :: mean_pos_shifts + integer, dimension(:), allocatable :: atomic_index_one, atomic_index_two + integer :: i, j, i_atomic, j_atomic, n, i_neighbour, i_desc, k, m, n_pairs,monomer_one_size ,monomer_two_size,rep,n_repeats + real(dp) :: r_one_two, mass_one, mass_two, temp_dist,min_dist + + real(dp), dimension(3) :: diff_one_two, mean_pos_one, mean_pos_two ! unweighted mean position of atoms in monomer, if monomer straddles cell boundary this will be in the middle of the cell + integer, dimension(3) :: shift_one_two, shift_one, shift_two,min_image_shift + integer, dimension(2) :: temp2d + integer, dimension(1) :: temp1d + logical :: do_use_com + + real(dp), dimension(3) :: n1, n2, n3 + real(dp) :: w1, w2, w3 + + do_use_com = optional_default(.false., use_com) + + n1 = at%lattice(:,1) .cross. at%lattice(:,2) + w1 = abs(n1 .dot. at%lattice(:,3)) / norm(n1) + n2 = at%lattice(:,2) .cross. at%lattice(:,3) + w2 = abs(n2 .dot. at%lattice(:,1)) / norm(n2) + n3 = at%lattice(:,3) .cross. at%lattice(:,1) + w3 = abs(n3 .dot. at%lattice(:,2)) / norm(n3) + if (2*cutoff .ge. min(w1, w2, w3)) then + RAISE_ERROR("find_monomer_pairs_MPI: only implemented for cutoff less than half the smallest box width",error) + endif + + allocate(monomer_pairs(2,0)) + allocate(mean_pos_shifts(3,0)) + allocate(mean_pos_diffs(3,0)) + allocate(pairs_diffs_map(0)) + + monomer_one_size = size(monomer_one_index,1) + monomer_two_size = size(monomer_two_index,1) + + allocate(atomic_index_one(monomer_one_size)) + allocate(atomic_index_two(monomer_two_size)) + + i_desc=0 + n_pairs=0 + + ! loop over all occurences of first monomer + loop_monomer_one: do i=1,size(monomer_one_index,2) + atomic_index_one = monomer_one_index(:,i) + + if(present(atom_mask)) then + if (.not. any(atom_mask(atomic_index_one))) then + cycle + else + if(.not. all(atom_mask(atomic_index_one))) then + RAISE_ERROR("find_monomer_pairs_MPI: atom mask has to encompass either all or none of the atoms of monomer one",error) + endif + endif + endif + + if (do_use_com) then + mean_pos_one = centre_of_mass(at,index_list=atomic_index_one) + else + mean_pos_one = calc_mean_pos(at,atomic_index_one) + endif + + loop_monomer_two: do j=1,size(monomer_two_index,2) + atomic_index_two = monomer_two_index(:,j) + + if (monomers_identical .and. i == j) cycle + + ! could instead try to find which monomers are within cutoff instead of + ! looping over all of them + ! a) going back to some atom-based measure + ! b) implementing connectivity for molecule COMs? + + if (monomers_identical .and. i > j) cycle + ! only keep monomers for which i cutoff) cycle + + diff_one_two = diff_min_image(at,mean_pos_one,mean_pos_two) + + n_pairs = n_pairs + 1 + call reallocate(monomer_pairs,2,n_pairs,copy=.true.) + monomer_pairs(:,n_pairs) = (/ i,j /) + k=n_pairs + + i_desc = i_desc + 1 + call reallocate(mean_pos_shifts,3,i_desc,copy=.true.) + call reallocate(mean_pos_diffs,3,i_desc,copy=.true.) + call reallocate(pairs_diffs_map,i_desc,copy=.true.) + mean_pos_shifts(:,i_desc) = shift_one_two + mean_pos_diffs(:,i_desc) = diff_one_two + pairs_diffs_map(i_desc) = k + + end do loop_monomer_two + end do loop_monomer_one + + if (present(pairs_shifts)) then + allocate(pairs_shifts(3,size(mean_pos_shifts,2))) + pairs_shifts = mean_pos_shifts + end if + + deallocate(mean_pos_shifts) + deallocate(atomic_index_one) + deallocate(atomic_index_two) + end subroutine find_monomer_pairs_MPI + + subroutine find_monomer_triplets_MPI(at,monomer_triplets,triplets_diffs,triplets_diffs_map,monomer_one_index,monomer_two_index,monomer_three_index,one_two_identical,one_three_identical,two_three_identical,cutoff,error,use_com,atom_mask) + ! loops through pairs of monomers made by find_monomer_pairs above and makes trimers if a third monomer is within cutoff. Returns 3 by n array, + ! returns trimers in ascending order of monomer index (hence no double-counting) + ! the elements of which refer to the second index of the monomer_{one,two,three}_index matrices. + ! the columns of triplets shifts are (k,shift_one_two,shift_one_three), where k refers to a column of monomer_triplets and the shifts correspond to a set of periodic images which are within cutoff. + type(atoms), intent(in) :: at + integer, dimension(:,:), intent(out), allocatable :: monomer_triplets + real(dp), dimension(:,:), intent(out), allocatable :: triplets_diffs + integer, dimension(:), intent(out), allocatable :: triplets_diffs_map + integer, intent(in), dimension(:,:) :: monomer_one_index, monomer_two_index, monomer_three_index + logical, intent(in) :: one_two_identical,one_three_identical, two_three_identical + real(dp), intent(in) :: cutoff + integer, intent(out), optional :: error + logical, intent(in), optional :: use_com + logical, dimension(:), intent(in), optional :: atom_mask + + integer, dimension(:,:), allocatable :: pairs_one_two, pairs_one_three,shifts_one_two,shifts_one_three,triplets_shifts + real(dp), dimension(:,:), allocatable :: diffs_one_two,diffs_one_three + integer, dimension(:), allocatable :: map_one_two, map_one_three + integer :: i, j, k,pos_ij,pos_ik,pos_jk,i_map,i_desc + real(dp) :: dist, pairwise_cutoff,min_dist + + real(dp), dimension(3) :: diff_ij,diff_ik,diff_jk, min_distances + integer, dimension(3) :: shift_ij, shift_ik, shift_jk + integer, dimension(1) :: temp1d + logical :: double_count + + double_count=.false. + pairwise_cutoff = 2.0_dp*cutoff+ 0.1_dp ! plenty big to find all relevant dimers + + call find_monomer_pairs_MPI(at,pairs_one_two, diffs_one_two, map_one_two, monomer_one_index,monomer_two_index ,one_two_identical ,double_count,pairwise_cutoff,shifts_one_two ,error,use_com,atom_mask) + call find_monomer_pairs_MPI(at,pairs_one_three,diffs_one_three,map_one_three,monomer_one_index,monomer_three_index,one_three_identical,double_count,pairwise_cutoff,shifts_one_three,error,use_com,atom_mask) + ! could save by re-using results if one_two_identical .and. one_three_identical + ! for any equivalent monomer types we have to append the negative self-pairs since these are excluded by find_monomer_pairs + + if (.not. allocated(monomer_triplets)) allocate(monomer_triplets(3,0)) + if (.not. allocated(triplets_diffs)) allocate(triplets_diffs(6,0)) + if (.not. allocated(triplets_diffs_map)) allocate(triplets_diffs_map(0)) + if (.not. allocated(triplets_shifts)) allocate(triplets_shifts(6,0)) + + !! make triplets + do pos_ij=1,size(map_one_two) ! loop over pairs (i,j) of 1 and 2 + i=pairs_one_two( 1, map_one_two(pos_ij) ) + j=pairs_one_two( 2, map_one_two(pos_ij) ) + if (one_two_identical .and. i >= j) cycle + diff_ij = diffs_one_two(:,pos_ij) + shift_ij = shifts_one_two(:,pos_ij) + + do pos_ik=1,size(map_one_three) ! loop over monomers k of type 3 also paired with i + if (i /= pairs_one_three( 1, map_one_three(pos_ik) ) ) cycle + + k = pairs_one_three( 2 , map_one_three(pos_ik) ) + + if (one_three_identical .and. i >= k) cycle + if (two_three_identical .and. j >= k) cycle + + diff_ik = diffs_one_three(:,pos_ik) + shift_ik = shifts_one_three(:,pos_ik) + + diff_jk = diff_ik - diff_ij + shift_jk = shift_ik - shift_ij + + ! check that is a valid triplet - i.e. two sides of the triangle are within cutoff length + ! based on COM/COG distance between each monomer pair + min_distances = (/ norm(diff_ij), norm(diff_ik), norm(diff_jk) /) + if ( count(min_distances .gt. cutoff) .gt. 1 ) cycle + + call add_triplet_MPI(monomer_triplets,triplets_diffs,triplets_diffs_map,triplets_shifts,i,j,k,diff_ij,diff_ik,shift_ij,shift_ik,two_three_identical) + end do + end do + deallocate(pairs_one_two) + deallocate(shifts_one_two) + deallocate(diffs_one_two) + deallocate(pairs_one_three) + deallocate(shifts_one_three) + deallocate(diffs_one_three) + if(allocated(triplets_shifts)) deallocate(triplets_shifts) + end subroutine find_monomer_triplets_MPI + subroutine add_triplet_MPI(monomer_triplets,triplets_diffs,triplets_diffs_map,triplets_shifts,i,j,k,diff_ij,diff_ik,shift_ij,shift_ik,two_three_identical) + ! this also excludes the case where the and three identical and this pair was already found in the opposite order + integer, dimension(:,:), intent(inout), allocatable :: monomer_triplets + real(dp), dimension(:,:), intent(inout), allocatable :: triplets_diffs + integer, dimension(:), intent(inout), allocatable :: triplets_diffs_map + integer, dimension(:,:), intent(inout), allocatable :: triplets_shifts + integer, intent(in) :: i,j,k + real(dp), dimension(3),intent(in) :: diff_ij,diff_ik + integer, dimension(3),intent(in) :: shift_ij,shift_ik + logical, intent(in) :: two_three_identical + + integer, dimension(3) :: triplet + logical, dimension(:), allocatable :: shift_mask + integer, dimension(1):: temp1d + integer :: pos_ijk, pos_ikj,n_triplets,n_shifts + logical :: do_append + + if (.not. allocated(monomer_triplets)) allocate(monomer_triplets(3,0)) + if (.not. allocated(triplets_diffs)) allocate(triplets_diffs(6,0)) + if (.not. allocated(triplets_diffs_map)) allocate(triplets_diffs_map(0)) + if (.not. allocated(triplets_shifts)) allocate(triplets_shifts(6,0)) + + n_triplets = size(monomer_triplets,2) + n_shifts = size(triplets_diffs_map) + triplet = (/i,j,k/) + + n_triplets = n_triplets + 1 + call reallocate(monomer_triplets,3,n_triplets,copy=.true.) + monomer_triplets(:,n_triplets) = triplet + pos_ijk = n_triplets + + n_shifts = n_shifts + 1 + call reallocate(triplets_shifts,6,n_shifts,copy=.true.) + call reallocate(triplets_diffs,6,n_shifts,copy=.true.) + call reallocate(triplets_diffs_map,n_shifts,copy=.true.) + triplets_shifts(:,n_shifts) = (/shift_ij,shift_ik/) + triplets_diffs(:,n_shifts) = (/diff_ij,diff_ik/) + triplets_diffs_map(n_shifts) = pos_ijk + end subroutine add_triplet_MPI + + subroutine find_monomer_triplets(at,monomer_triplets,triplets_diffs,triplets_diffs_map,monomer_one_index,monomer_two_index,monomer_three_index,one_two_identical,one_three_identical,two_three_identical,cutoff,error) + ! loops through pairs of monomers made by find_monomer_pairs above and makes trimers if a third monomer is within cutoff. Returns 3 by n array, + ! the elements of which refer to the second index of the monomer_{one,two,three}_index matrices. + ! the columns of triplets shifts are (k,shift_one_two,shift_one_three), where k refers to a column of monomer_triplets and the shifts correspond to a set of periodic images which are within cutoff. + type(atoms), intent(in) :: at + integer, dimension(:,:), intent(out), allocatable :: monomer_triplets + real(dp), dimension(:,:), intent(out), allocatable :: triplets_diffs + integer, dimension(:), intent(out), allocatable :: triplets_diffs_map + integer, intent(in), dimension(:,:) :: monomer_one_index, monomer_two_index, monomer_three_index + logical, intent(in) :: one_two_identical,one_three_identical, two_three_identical + real(dp), intent(in) :: cutoff + integer, intent(out), optional :: error + + integer, dimension(:,:), allocatable :: pairs_one_two, pairs_one_three,shifts_one_two,shifts_one_three,triplets_shifts + real(dp), dimension(:,:), allocatable :: diffs_one_two,diffs_one_three + integer, dimension(:), allocatable :: map_one_two, map_one_three + integer :: i, j, k,pos_ij,pos_ik,pos_jk,i_map,i_desc + real(dp) :: dist, pairwise_cutoff,min_dist + + real(dp), dimension(3) :: diff_ij,diff_ik,diff_jk, min_distances + integer, dimension(3) :: shift_ij, shift_ik, shift_jk + integer, dimension(1) :: temp1d + logical :: double_count + + double_count=.false. + pairwise_cutoff = 2.0_dp*cutoff+ 0.1_dp ! plenty big to find all relevant dimers + + call find_monomer_pairs(at,pairs_one_two, diffs_one_two, map_one_two, monomer_one_index,monomer_two_index ,one_two_identical , double_count,pairwise_cutoff,shifts_one_two ,error) + call find_monomer_pairs(at,pairs_one_three,diffs_one_three,map_one_three,monomer_one_index,monomer_three_index,one_three_identical,double_count,pairwise_cutoff,shifts_one_three,error) + ! for any equivalent monomer types we have to append the negative self-pairs since these are excluded by find_monomer_pairs + + if (.not. allocated(monomer_triplets)) allocate(monomer_triplets(3,0)) + if (.not. allocated(triplets_diffs)) allocate(triplets_diffs(6,0)) + if (.not. allocated(triplets_diffs_map)) allocate(triplets_diffs_map(0)) + if (.not. allocated(triplets_shifts)) allocate(triplets_shifts(6,0)) + + !! make triplets + do pos_ij=1,size(map_one_two) ! loop over pairs (i,j) of 1 and 2 + i=pairs_one_two( 1, map_one_two(pos_ij) ) + j=pairs_one_two( 2, map_one_two(pos_ij) ) + diff_ij = diffs_one_two(:,pos_ij) + shift_ij = shifts_one_two(:,pos_ij) + + do pos_ik=1,size(map_one_three) ! loop over monomers k of type 3 also paired with i + if (i /= pairs_one_three( 1, map_one_three(pos_ik) ) ) cycle + + k =pairs_one_three( 2 , map_one_three(pos_ik) ) + diff_ik = diffs_one_three(:,pos_ik) + shift_ik = shifts_one_three(:,pos_ik) + + diff_jk = diff_ik - diff_ij + shift_jk = shift_ik - shift_ij + + if (two_three_identical .and. all(shift_jk .eq. 0) .and. j==k ) cycle ! skip if j and k are same monomer + +! if (two_three_identical .and. k .lt. j) cycle +! if (two_three_identical .and. all(shift_jk .eq. 0) .and. j .ge. k ) cycle +! if (two_three_identical .and. j .ge. k ) cycle + + ! check that is a valid triplet - i.e. two sides of the triangle are within cutoff length + ! find minimum intermolecular distance (excluding Hydrogen) between each monomer pair + min_distances = (/ min_intermolecular_dist(at,monomer_one_index(:,i),monomer_two_index(:,j) , diff_ij, pairwise_cutoff) , & + min_intermolecular_dist(at,monomer_one_index(:,i),monomer_three_index(:,k) , diff_ik, pairwise_cutoff) , & + min_intermolecular_dist(at,monomer_two_index(:,j),monomer_three_index(:,k) , diff_jk, pairwise_cutoff) /) + if ( count(min_distances .gt. cutoff) .gt. 1 ) cycle + call add_triplet_if_new(monomer_triplets,triplets_diffs,triplets_diffs_map,triplets_shifts,i,j,k,diff_ij,diff_ik,shift_ij,shift_ik,two_three_identical) + end do + end do + deallocate(pairs_one_two) + deallocate(shifts_one_two) + deallocate(diffs_one_two) + deallocate(pairs_one_three) + deallocate(shifts_one_three) + deallocate(diffs_one_three) + if(allocated(triplets_shifts)) deallocate(triplets_shifts) +!call print("triplets diffs") +!call print(triplets_diffs) +end subroutine find_monomer_triplets + + +subroutine add_triplet_if_new(monomer_triplets,triplets_diffs,triplets_diffs_map,triplets_shifts,i,j,k,diff_ij,diff_ik,shift_ij,shift_ik,two_three_identical) + ! this also excludes the case where the and three identical and this pair was already found in the opposite order + integer, dimension(:,:), intent(inout), allocatable :: monomer_triplets + real(dp), dimension(:,:), intent(inout), allocatable :: triplets_diffs + integer, dimension(:), intent(inout), allocatable :: triplets_diffs_map + integer, dimension(:,:), intent(inout), allocatable :: triplets_shifts + integer, intent(in) :: i,j,k + real(dp), dimension(3),intent(in) :: diff_ij,diff_ik + integer, dimension(3),intent(in) :: shift_ij,shift_ik + logical, intent(in) :: two_three_identical + + integer, dimension(3) :: triplet + logical, dimension(:), allocatable :: shift_mask + integer, dimension(1):: temp1d + integer :: pos_ijk, pos_ikj,n_triplets,n_shifts + logical :: do_append + + if (.not. allocated(monomer_triplets)) allocate(monomer_triplets(3,0)) + if (.not. allocated(triplets_diffs)) allocate(triplets_diffs(6,0)) + if (.not. allocated(triplets_diffs_map)) allocate(triplets_diffs_map(0)) + if (.not. allocated(triplets_shifts)) allocate(triplets_shifts(6,0)) + + n_triplets=size(monomer_triplets,2) + n_shifts=size(triplets_diffs_map) + triplet=(/i,j,k/) + allocate(shift_mask(n_shifts)) + !call print("triplet has i, j,k = "//(/i,j,k/)//" and shifts "//(/shift_ij,shift_ik/)) + + ! in case monomers two and three are identical, check this pair hasn't already been found in opposite order + if (two_three_identical) then + shift_mask = (/ triplets_shifts(1,:) .eq. shift_ik(1) /) .and. & + (/ triplets_shifts(2,:) .eq. shift_ik(2) /) .and. & + (/ triplets_shifts(3,:) .eq. shift_ik(3) /) .and. & + + (/ triplets_shifts(4,:) .eq. shift_ij(1) /) .and. & + (/ triplets_shifts(5,:) .eq. shift_ij(2) /) .and. & + (/ triplets_shifts(6,:) .eq. shift_ij(3) /) + + temp1d = maxloc(monomer_triplets(1,:), monomer_triplets(1,:) .eq. i .and. monomer_triplets(2,:) .eq. k .and. monomer_triplets(3,:) .eq. j) + pos_ikj = temp1d(1) + temp1d=maxloc(triplets_diffs_map,triplets_diffs_map .eq. pos_ikj .and. shift_mask) + if (temp1d(1) /= 0) then + deallocate(shift_mask) + return + end if + end if + + ! find where this triplet is if we've found it before + temp1d = maxloc(monomer_triplets(1,:), monomer_triplets(1,:) .eq. i .and. monomer_triplets(2,:) .eq. j .and. monomer_triplets(3,:) .eq. k) + pos_ijk = temp1d(1) + + if (pos_ijk == 0) then ! append triplet if it's new + n_triplets = n_triplets + 1 + call reallocate(monomer_triplets,3,n_triplets,copy=.true.) + monomer_triplets(:,n_triplets) = triplet + pos_ijk=n_triplets + end if + + shift_mask = (/ triplets_shifts(1,:) .eq. shift_ij(1) /) .and. & ! check if this shift already present for this triplet + (/ triplets_shifts(2,:) .eq. shift_ij(2) /) .and. & + (/ triplets_shifts(3,:) .eq. shift_ij(3) /) .and. & + + (/ triplets_shifts(4,:) .eq. shift_ik(1) /) .and. & + (/ triplets_shifts(5,:) .eq. shift_ik(2) /) .and. & + (/ triplets_shifts(6,:) .eq. shift_ik(3) /) + + temp1d=maxloc(triplets_diffs_map,triplets_diffs_map .eq. pos_ijk .and. shift_mask) + deallocate(shift_mask) + do_append = (temp1d(1) == 0) + + if (do_append) then ! append shift if it's new + n_shifts = n_shifts + 1 + call reallocate(triplets_shifts,6,n_shifts,copy=.true.) + call reallocate(triplets_diffs,6,n_shifts,copy=.true.) + call reallocate(triplets_diffs_map,n_shifts,copy=.true.) + triplets_shifts(:,n_shifts) = (/shift_ij,shift_ik/) + triplets_diffs(:,n_shifts) = (/diff_ij,diff_ik/) + triplets_diffs_map(n_shifts) = pos_ijk + end if +end subroutine add_triplet_if_new + +function calc_mean_pos(at,indices) result (pos) +! generates an absolute 'mean' position of a set of atoms - NB not the centre of mass + type(Atoms), intent(in) :: at + integer,dimension(:), intent(in) :: indices + real(dp),dimension(3) :: pos + integer :: i,n + + pos = 0.0_dp + n=size(indices) + + do i =2,n + pos = pos + diff_min_image(at,indices(1),indices(i)) + end do + pos = pos / n + pos = pos + at%pos(:,indices(1)) + +end function calc_mean_pos + +function min_intermolecular_dist(at,mono1,mono2,mean_pos_diff,r_init) result (r_min) + ! returns the minimum intermolecular distance between two monomers, excluding hydrogens + type(Atoms), intent(in) :: at + integer, dimension(:), intent(in) :: mono1,mono2 + real(dp), dimension(3), intent(in) :: mean_pos_diff + real(dp), intent(in) :: r_init + + real(dp) :: r_min, temp_dist + integer :: i_atomic, i_glob,j_atomic, j_glob + real(dp), dimension(3) :: mean_pos_one, mean_pos_two + + mean_pos_one = calc_mean_pos(at,mono1) + mean_pos_two = calc_mean_pos(at,mono2) + + r_min = r_init + + do i_atomic=1,size(mono1) + i_glob=mono1(i_atomic) + if (at%Z(i_glob) == 1) cycle + + do j_atomic=1,size(mono2) + j_glob = mono2(j_atomic) + if (at%Z(j_glob) == 1) cycle + temp_dist = norm( diff_min_image(at,at%pos(:,i_glob),mean_pos_one) + mean_pos_diff + diff_min_image(at,mean_pos_two,at%pos(:,j_glob)) ) + r_min = min(r_min,temp_dist) + end do + end do + +end function min_intermolecular_dist + +end module topology_module diff --git a/src/libAtoms/Units.F90 b/src/libAtoms/Units.F90 new file mode 100644 index 0000000000..778f117368 --- /dev/null +++ b/src/libAtoms/Units.F90 @@ -0,0 +1,150 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Units module +!X +!% This module holds a collection of our units and conversion factors. +!% We use Angstroms ($\mathrm{\AA}$), eV, and femtoseconds (fs). +!% +!% - Length: Angstroms, ``a.u. * BOHR`` +!% - Energy: eV, ``a.u. * HARTREE`` +!% - Time: fs +!% - Mass: $E T^2/L^2$ = ``a.u. * HARTREE * AU_FS**2 / BOHR**2`` +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module units_module + +use system_module, only : dp ! for definition of dp +implicit none +public + +#ifdef LEGACY_UNITS +! Values of units pre-2017. +! Since results will vary, keep these around for a while in case +! someone needs consistency with these. +! Tests will fail if these values are used. +real(dp), parameter :: ELECTRONMASS_GPERMOL = 5.48579903e-4_dp !% grams/mol +real(dp), parameter :: ELEM_CHARGE = 1.60217653e-19_dp !% coulombs +real(dp), parameter :: HARTREE = 27.2113961_dp !% eV +real(dp), parameter :: RYDBERG = 0.5_dp*HARTREE !% eV +real(dp), parameter :: BOHR = 0.529177249_dp !% Angstrom +real(dp), parameter :: CUBIC_BOHR = BOHR*BOHR/HARTREE !% QUIP Units of polarisability +real(dp), parameter :: HBAR_EVSEC = 6.5821220e-16_dp !% hbar in eV seconds +real(dp), parameter :: HBAR_AU = 1.0_dp !% hbar in a.u. +real(dp), parameter :: HBAR = (HBAR_EVSEC*1e+15_dp) !% hbar in eV fs +real(dp), parameter :: ONESECOND = 1e15_dp !% 1 second in fs +real(dp), parameter :: ONESECOND_AU = (1.0_dp/(HBAR_EVSEC/(HBAR_AU*HARTREE))) !% 1 second in a.u. +real(dp), parameter :: AU_FS = (1.0_dp/ONESECOND_AU*ONESECOND) !% a.u. time in fs +real(dp), parameter :: MASSCONVERT = (1.0_dp/ELECTRONMASS_GPERMOL*HARTREE*AU_FS*AU_FS/(BOHR*BOHR)) !% = 1e7 / (N_A * ELEM_CHARGE) +real(dp), parameter :: BOLTZMANN_K = 8.617385e-5_dp !% eV/Kelvin +real(dp), parameter :: PI = 3.14159265358979323846264338327950288_dp +real(dp), parameter :: N_A = 6.0221479e23_dp !% Avogadro's number +real(dp), parameter :: KCAL_MOL = 4.3383e-2_dp !% eV +real(dp), parameter :: DEGREES_PER_RADIAN = 180.0_dp / PI +real(dp), parameter :: RADIANS_PER_DEGREE = PI / 180.0_dp +real(dp), parameter :: GPA = 1.6022e-19_dp*1.0e30_dp/1.0e9_dp !% Convert from \textsc{libAtoms} units to Gigapascals (DEPRECATED) +real(dp), parameter :: EV_A3_IN_GPA = 1.6022e-19_dp*1.0e30_dp/1.0e9_dp !% Same thing but with a less misleading name +real(dp), parameter :: GPA_TO_EV_A3 = 1.0e9_dp/ELEM_CHARGE/1.0e30_dp !% The inverse of the above, convention consistent with all other conversion factors +real(dp), parameter :: EPSILON_0 = 8.854187817e-12_dp / ELEM_CHARGE * 1.0e-10_dp !% epsilon_0 in e / V Angstrom +real(dp), parameter :: DEBYE = 1.0e-21_dp/299792458.0_dp/ELEM_CHARGE*1e10_dp !% 1D $= 10^{-18}$ statcoulomb-centrimetre in e-A +real(dp), parameter :: SQRT_TWO = sqrt(2.0_dp) +! not included originally, make sure they're not undefined +real(dp), parameter :: GRAM = 1e-3_dp !% in kg +real(dp), parameter :: ELECTRONMASS = ELECTRONMASS_GPERMOL*GRAM/N_A +real(dp), parameter :: EPSILON_0_AU = EPSILON_0*ELEM_CHARGE/1.0e-10_dp +real(dp), parameter :: VACUUM_C = 299792458.0_dp !% exact in m/s +real(dp), parameter :: INVERSE_CM = 1.0e2_dp*VACUUM_C*HBAR_EVSEC*2.0_dp*PI !% +#else +! CODATA 2014 taken from +! http://arxiv.org/pdf/1507.07956.pdf +! Fundamentals +real(dp), parameter :: ELECTRONMASS = 9.10938356e-31_dp !% electron mass / kg +real(dp), parameter :: N_A = 6.022140857e23_dp !% Avogadro constant +real(dp), parameter :: ELEM_CHARGE = 1.6021766208e-19_dp !% e / Coulombs +real(dp), parameter :: HARTREE = 27.21138602_dp !% EH / eV +real(dp), parameter :: BOHR = 0.52917721067_dp !% in Angstrom +real(dp), parameter :: HBAR_EVSEC = 6.582119514e-16_dp !% hbar in eV seconds +real(dp), parameter :: BOLTZMANN_K = 8.6173303e-5_dp !% eV/kelvin +real(dp), parameter :: EPSILON_0_AU = 8.854187817e-12_dp !% exact in F/m +real(dp), parameter :: VACUUM_C = 299792458.0_dp !% exact in m/s + +! Others +real(dp), parameter :: GRAM = 1e-3_dp !% in kg +real(dp), parameter :: PI = 3.14159265358979323846264338327950288_dp +real(dp), parameter :: SQRT_TWO = sqrt(2.0_dp) + +! derived units for QUIP +real(dp), parameter :: ELECTRONMASS_GPERMOL = ELECTRONMASS*N_A/GRAM !% grams/mol +real(dp), parameter :: RYDBERG = 0.5_dp*HARTREE !% eV +real(dp), parameter :: CUBIC_BOHR = BOHR*BOHR/HARTREE !% QUIP Units of polarisability +real(dp), parameter :: HBAR_AU = 1.0_dp !% hbar in a.u. +real(dp), parameter :: HBAR = (HBAR_EVSEC*1e+15_dp) !% hbar in eV fs +real(dp), parameter :: ONESECOND = 1e15_dp !% 1 second in fs +real(dp), parameter :: ONESECOND_AU = (1.0_dp/(HBAR_EVSEC/(HBAR_AU*HARTREE))) !% 1 second in a.u. +real(dp), parameter :: AU_FS = (1.0_dp/ONESECOND_AU*ONESECOND) !% a.u. time in fs +real(dp), parameter :: MASSCONVERT = (1.0_dp/ELECTRONMASS_GPERMOL*HARTREE*AU_FS*AU_FS/(BOHR*BOHR)) !% = 1e7 / (N_A * ELEM_CHARGE) +real(dp), parameter :: KCAL_MOL = 4.184*1000/(ELEM_CHARGE*N_A) !% Thermochemical definition in eV +real(dp), parameter :: DEGREES_PER_RADIAN = 180.0_dp / PI +real(dp), parameter :: RADIANS_PER_DEGREE = PI / 180.0_dp +real(dp), parameter :: GPA = ELEM_CHARGE*1.0e30_dp/1.0e9_dp !% Convert from \textsc{libAtoms} units to Gigapascals (DEPRECATED) +real(dp), parameter :: EV_A3_IN_GPA = ELEM_CHARGE*1.0e30_dp/1.0e9_dp !% Same thing but with a less misleading name +real(dp), parameter :: GPA_TO_EV_A3 = 1.0e9_dp/ELEM_CHARGE/1.0e30_dp !% The inverse of the above, convention consistent with all other conversion factors +real(dp), parameter :: EPSILON_0 = EPSILON_0_AU/ELEM_CHARGE*1.0e-10_dp !% epsilon_0 in e / V Angstrom +real(dp), parameter :: DEBYE = 1.0e-21_dp/VACUUM_C/ELEM_CHARGE*1e10_dp !% 1D $= 10^{-18}$ statcoulomb-centrimetre in e-A +real(dp), parameter :: INVERSE_CM = 1.0e2_dp*VACUUM_C*HBAR_EVSEC*2.0_dp*PI !% cm^{-1} * h * c +#endif + +complex(dp), parameter :: CPLX_ZERO = (0.0_dp,0.0_dp) +complex(dp), parameter :: CPLX_IMAG = (0.0_dp,1.0_dp) +complex(dp), parameter :: CPLX_ONE = (1.0_dp,0.0_dp) + +! Make the values of some compiler macros available at runtime +#ifdef HAVE_LOTF +integer, parameter :: have_lotf = 1 +#else +integer, parameter :: have_lotf = 0 +#endif + +#ifdef HAVE_CP2K +integer, parameter :: have_cp2k = 1 +#else +integer, parameter :: have_cp2k = 0 +#endif + +#ifdef HAVE_NETCDF4 +integer, parameter :: have_netcdf = 1 +#else +integer, parameter :: have_netcdf = 0 +#endif + +end module units_module diff --git a/src/libAtoms/angular_functions.F90 b/src/libAtoms/angular_functions.F90 new file mode 100644 index 0000000000..b99bb9ff0c --- /dev/null +++ b/src/libAtoms/angular_functions.F90 @@ -0,0 +1,710 @@ +module angular_functions_module + +use system_module +use units_module +use linearalgebra_module + +implicit none +private + + + real(dp), dimension(:,:,:,:,:,:), allocatable, save :: cg_array + integer, save :: cg_j1_max=0, cg_m1_max=0, cg_j2_max=0, cg_m2_max=0, cg_j_max=0, cg_m_max=0 + logical, save :: cg_initialised = .false. + + public :: SphericalYCartesian, GradSphericalYCartesian + public :: SphericalYCartesian_all, GradSphericalYCartesian_all + public :: SolidRCartesian, SphericalIterative, GradSphericalIterative + + public :: wigner3j + public :: cg_initialise, cg_finalise, cg_array + +contains + + !################################################################################# + !# + !% Solid Harmonic function using Cartesian coordinates + !% + !% $ R_{l m} = \sqrt{\frac{4 \pi}{2 l + 1}} r^l Y_{l m} $ + !# + !################################################################################# + + function SolidRCartesian(l, m, x) + + complex(dp) :: SolidRCartesian + integer, intent(in) :: l, m + real(dp), intent(in) :: x(3) + integer :: p, q, s + + SolidRCartesian = CPLX_ZERO + + do p = 0, l + q = p - m + s = l - p - q + + if ((q >= 0) .and. (s >= 0)) then + SolidRCartesian = SolidRCartesian + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) & + * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) & + * (x(3)**s) & + / (factorial(p) * factorial(q) * factorial(s))) + end if + end do + + SolidRCartesian = SolidRCartesian * sqrt(factorial(l + m) * factorial(l - m)) + + end function SolidRCartesian + + function SolidRCartesian_all(l_max, x) + + integer, intent(in) :: l_max + real(dp), intent(in) :: x(3) + complex(dp) :: SolidRCartesian_all(0:l_max, -l_max:l_max) + + integer :: l, m + integer :: p, q, s + complex(kind=dp) :: cm, cp, cm_term(0:l_max), cp_term(0:2*l_max), x3_term(0:2*l_max) + real(dp) :: factorials(0:2*l_max) + + SolidRCartesian_all = CPLX_ZERO + + cm = cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp) + cp = cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp) + + ! p = 0 .. l + do p=0, l_max + cm_term(p) = cm**p + end do + ! q, s = 0 .. 2l + do q=0, 2*l_max + cp_term(q) = cp**q + x3_term(q) = x(3)**q + factorials(q) = factorial(q) + end do + + do l=0, l_max + do m=-l, l + do p = 0, l + q = p - m + s = l - p - q + + if ((q >= 0) .and. (s >= 0)) then + SolidRCartesian_all(l,m) = SolidRCartesian_all(l,m) + & + ( cm_term(p) * cp_term(q) * x3_term(s) / & + ( factorials(p) * factorials(q) * factorials(s) ) ) + end if + end do + + SolidRCartesian_all(l,m) = SolidRCartesian_all(l,m) * sqrt(factorials(l + m) * factorials(l - m)) + end do + end do + + end function SolidRCartesian_all + + !################################################################################# + !# + !% Spherical Harmonic function using Cartesian coordinates + !# + !################################################################################# + + function SphericalYCartesian(l, m, x) + + complex(dp) :: SphericalYCartesian + integer, intent(in) :: l, m + real(dp), intent(in) :: x(3) + + SphericalYCartesian = SolidRCartesian(l, m, x) * sqrt(((2.0_dp * l) + 1) / (4.0_dp * PI)) & + * (normsq(x)**(-0.5_dp * l)) + + end function SphericalYCartesian + + function SphericalYCartesian_all(l_max, x) + + integer, intent(in) :: l_max + real(dp), intent(in) :: x(3) + complex(dp) :: SphericalYCartesian_all(0:l_max, -l_max:l_max) + + real(dp) :: normsq_x + integer :: l, m + + normsq_x = normsq(x) + SphericalYCartesian_all = SolidRCartesian_all(l_max, x) + do l=0, l_max + SphericalYCartesian_all(l,-l:l) = SphericalYCartesian_all(l,-l:l) * & + sqrt(((2.0_dp * l) + 1) / (4.0_dp * PI)) * (normsq_x**(-0.5_dp * l)) + end do + + end function SphericalYCartesian_all + + !################################################################################# + !# + !% Derivative of Spherical Harmonic function using Cartesian coordinates + !# + !################################################################################# + + function GradSphericalYCartesian(l, m, x) + + complex(dp) :: GradSphericalYCartesian(3) + integer, intent(in) :: l, m + real(dp), intent(in) :: x(3) + integer :: p, q, s + + GradSphericalYCartesian = CPLX_ZERO + + do p = 0, l + q = p - m + s = l - p - q + + if ((p >= 1) .and. (q >= 0) .and. (s >= 0)) then + GradSphericalYCartesian(1) = GradSphericalYCartesian(1) & + - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**(p - 1)) & + * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) & + * (x(3)**s) & + * 0.5_dp & + / (factorial(p - 1) * factorial(q) * factorial(s))) + GradSphericalYCartesian(2) = GradSphericalYCartesian(2) & + - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**(p - 1)) & + * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) & + * (x(3)**s) & + * 0.5_dp * cmplx(0.0_dp, 1.0_dp, dp) & + / (factorial(p - 1) * factorial(q) * factorial(s))) + end if + + if ((p >= 0) .and. (q >= 1) .and. (s >= 0)) then + GradSphericalYCartesian(1) = GradSphericalYCartesian(1) & + + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) & + * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**(q - 1)) & + * (x(3)**s) & + * 0.5_dp & + / (factorial(p) * factorial(q - 1) * factorial(s))) + GradSphericalYCartesian(2) = GradSphericalYCartesian(2) & + - ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) & + * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**(q - 1)) & + * (x(3)**s) & + * 0.5_dp * cmplx(0.0_dp, 1.0_dp, dp) & + / (factorial(p) * factorial(q - 1) * factorial(s))) + end if + + if ((p >= 0) .and. (q >= 0) .and. (s >= 1)) then + GradSphericalYCartesian(3) = GradSphericalYCartesian(3) & + + ((cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp)**p) & + * (cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp)**q) & + * (x(3)**(s - 1)) & + / (factorial(p) * factorial(q) * factorial(s - 1))) + end if + end do + + GradSphericalYCartesian = GradSphericalYCartesian & + * sqrt(factorial(l + m) * factorial(l - m) * ((2.0_dp * l) + 1) / (4.0_dp * PI)) & + * (normsq(x)**(-0.5_dp * l)) + + GradSphericalYCartesian = GradSphericalYCartesian & + - (l * x * SphericalYCartesian(l, m, x) / normsq(x)) + + end function GradSphericalYCartesian + + function GradSphericalYCartesian_all(l_max, x) + + integer, intent(in) :: l_max + real(dp), intent(in) :: x(3) + complex(dp) :: GradSphericalYCartesian_all(0:l_max, -l_max:l_max, 3) + + integer :: l, m + integer :: p, q, s + complex(kind=dp) :: cm, cp, cm_term(0:l_max), cp_term(0:2*l_max), x3_term(0:2*l_max) + real(dp) :: factorials(0:2*l_max) + real(dp) :: normsq_x + complex(dp) :: tt + + GradSphericalYCartesian_all = CPLX_ZERO + + cm = cmplx(-0.5_dp * x(1), -0.5_dp * x(2), dp) + cp = cmplx(0.5_dp * x(1), -0.5_dp * x(2), dp) + + ! p = 0 .. l + do p=0, l_max + cm_term(p) = cm**p + end do + ! q, s = 0 .. 2l + do q=0, 2*l_max + cp_term(q) = cp**q + x3_term(q) = x(3)**q + factorials(q) = factorial(q) + end do + + normsq_x = normsq(x) + + do l=0, l_max + do m=-l, l + do p = 0, l + q = p - m + s = l - p - q + + if ((p >= 1) .and. (q >= 0) .and. (s >= 0)) then + tt = (cm_term(p-1) * cp_term(q) * x3_term(s) & + * 0.5_dp & + / (factorials(p - 1) * factorials(q) * factorials(s))) + GradSphericalYCartesian_all(l,m,1) = GradSphericalYCartesian_all(l,m,1) & + - tt + GradSphericalYCartesian_all(l,m,2) = GradSphericalYCartesian_all(l,m,2) & + - tt * cmplx(0.0_dp, 1.0_dp, dp) + end if + + if ((p >= 0) .and. (q >= 1) .and. (s >= 0)) then + tt = (cm_term(p) * cp_term(q-1) * x3_term(s) & + * 0.5_dp & + / (factorials(p) * factorials(q - 1) * factorials(s))) + GradSphericalYCartesian_all(l,m,1) = GradSphericalYCartesian_all(l,m,1) & + + tt + GradSphericalYCartesian_all(l,m,2) = GradSphericalYCartesian_all(l,m,2) & + - tt * cmplx(0.0_dp, 1.0_dp, dp) + end if + + if ((p >= 0) .and. (q >= 0) .and. (s >= 1)) then + GradSphericalYCartesian_all(l,m,3) = GradSphericalYCartesian_all(l,m,3) & + + (cm_term(p) * cp_term(q) * x3_term(s-1) & + / (factorials(p) * factorials(q) * factorials(s - 1))) + end if + end do + + GradSphericalYCartesian_all(l,m,:) = GradSphericalYCartesian_all(l,m,:) & + * sqrt(factorials(l + m) * factorials(l - m) * ((2.0_dp * l) + 1) / (4.0_dp * PI)) & + * (normsq_x**(-0.5_dp * l)) + + GradSphericalYCartesian_all(l,m,:) = GradSphericalYCartesian_all(l,m,:) & + - (l * x * SphericalYCartesian(l, m, x) / normsq_x) + end do + end do + + end function GradSphericalYCartesian_all + + !################################################################################# + !# + !% Spherical Harmonics and SH derivative functions in Cartesian coordinates using iterative method + !# + !################################################################################# + + function SphericalIterative(l_max, x) + + real(dp), allocatable :: SphericalIterative(:,:,:) + real(dp) :: Q_ml_2, Q_ml_1, Q_ml_0, r_xy_squared, sm_cm_part, s_m, c_m, s_m_new, c_m_new + real(dp) :: x(:,:), F_ml(0:l_max,0:l_max) + integer :: l, m, i, j, l_max + + allocate(SphericalIterative(-l_max:l_max, 0:l_max, SIZE(x, 2))) + F_ml = 0 + + do l=0, l_max + F_ml(l, 0) = sqrt((2*l + 1)/(2*PI)) + + do m=1, l + F_ml(l,m) = F_ml(l,m-1) * (-1/sqrt(REAL((l+m)*(l+1-m)))) + end do + end do + + do i=1, SIZE(x, 2) + do l=0, l_max + do m=-l, l + s_m = 0.0 + c_m = 1.0 + + if (m == 0) then + sm_cm_part = 1/sqrt(2.0) + + else + do j=0, ABS(m)-2 + s_m_new = x(1, i)*s_m + x(2, i)*c_m + c_m_new = -x(2, i)*s_m + x(1, i)*c_m + s_m = s_m_new + c_m = c_m_new + end do + if (m > 0) then + sm_cm_part = -x(2, i)*s_m + x(1, i)*c_m + else if (m < 0) then + sm_cm_part = x(1, i)*s_m + x(2, i)*c_m + end if + end if + + Q_ml_2 = 1.0 + + do j=1, l + Q_ml_2 = Q_ml_2 * -(2*j - 1) + end do + + Q_ml_1 = -x(3,i) * Q_ml_2 + + if (l-ABS(m)>1) then + r_xy_squared = x(1,i)*x(1,i) + x(2,i)*x(2,i) + + do j=l-2, ABS(m), -1 + Q_ml_0 = (-(2 * (j+1) * x(3,i) * Q_ml_1) - (r_xy_squared * Q_ml_2))/((l+j+1) * (l-j)) + + Q_ml_2 = Q_ml_1 + Q_ml_1 = Q_ml_0 + end do + + else if (l-ABS(m)==1) then + Q_ml_0 = Q_ml_1 + else if (l-ABS(m)==0) then + Q_ml_0 = Q_ml_2 + end if + + SphericalIterative(m,l,i) = Q_ml_0 * sm_cm_part * F_ml(l, ABS(m)) + end do + end do + end do + end function SphericalIterative + + function GradSphericalIterative(l_max, x) + + real(dp), allocatable :: GradSphericalIterative(:,:,:,:) + real(dp) :: r_xy_squared, first_term, second_term, Q_ml_0, Q_ml_1, Q_ml_2 + real(dp) :: x(:,:), F_ml(0:l_max,0:l_max), Q_ml(0:l_max,0:l_max), s(0:l_max), c(0:l_max) + integer :: l, m, l_max, i, j + + allocate(GradSphericalIterative(-l_max:l_max, 0:l_max, SIZE(x, 2), 3)) + + F_ml = 0 + do l=0, l_max + F_ml(l, 0) = sqrt((2*l + 1)/(2*PI)) + + do m=1, l + F_ml(l,m) = F_ml(l,m-1) * (-1/sqrt(REAL((l+m)*(l+1-m)))) + end do + end do + + do i=1, SIZE(x, 2) + Q_ml = 0 + r_xy_squared = x(1,i)*x(1,i) + x(2,i)*x(2,i) + do l=0, l_max + do m=0, l + Q_ml_2 = 1.0 + + do j=1, l + Q_ml_2 = Q_ml_2 * -(2*j - 1) + end do + + Q_ml_1 = -x(3,i) * Q_ml_2 + + if (l-ABS(m)>1) then + do j=l-2, ABS(m), -1 + Q_ml_0 = (-(2 * (j+1) * x(3,i) * Q_ml_1) - (r_xy_squared * Q_ml_2))/((l+j+1) * (l-j)) + + Q_ml_2 = Q_ml_1 + Q_ml_1 = Q_ml_0 + end do + else if (l-ABS(m)==1) then + Q_ml_0 = Q_ml_1 + + else if (l-ABS(m)==0) then + Q_ml_0 = Q_ml_2 + end if + Q_ml(m,l) = Q_ml_0 + end do + end do + + s(0) = 0.0 + c(0) = 1.0 + do j=1, l_max + s(j) = x(1,i)*s(j-1) + x(2,i)*c(j-1) + c(j) = -x(2,i)*s(j-1) + x(1,i)*c(j-1) + end do + + do l=0, l_max + do m=-l, l + if (l == 0) then + GradSphericalIterative(m,l,i,1) = 0.0 + GradSphericalIterative(m,l,i,2) = 0.0 + GradSphericalIterative(m,l,i,3) = 0.0 + + else if (m == 0) then + ! m = 0 case + if (l == 1) then + GradSphericalIterative(m,l,i,1) = 0.0 + GradSphericalIterative(m,l,i,2) = 0.0 + GradSphericalIterative(m,l,i,3) = F_ml(l,m)/sqrt(2.0) * l * Q_ml(0,l-1) + else + GradSphericalIterative(m,l,i,1) = F_ml(l,m)/sqrt(2.0) * x(1,i) * Q_ml(1,l-1) + GradSphericalIterative(m,l,i,2) = F_ml(l,m)/sqrt(2.0) * x(2,i) * Q_ml(1,l-1) + GradSphericalIterative(m,l,i,3) = F_ml(l,m)/sqrt(2.0) * l * Q_ml(0,l-1) + end if + else if (m < 0) then + if (abs(m) > l-2) then + first_term = 0.0 + else + first_term = Q_ml(abs(m)+1,l-1) + end if + if (l == abs(m)) then + second_term = 0.0 + else + second_term = Q_ml(abs(m),l-1) + end if + + GradSphericalIterative(m,l,i,1) = F_ml(l,abs(m)) * ((s(abs(m))*x(1,i)*first_term) + (abs(m)*s(abs(m)-1)*Q_ml(abs(m),l))) + GradSphericalIterative(m,l,i,2) = F_ml(l,abs(m)) * ((s(abs(m))*x(2,i)*first_term) + (abs(m)*c(abs(m)-1)*Q_ml(abs(m),l))) + GradSphericalIterative(m,l,i,3) = F_ml(l,abs(m)) * s(abs(m)) * (l+abs(m)) * second_term + + else if (m > 0) then + if (abs(m) > l-2) then + first_term = 0.0 + else + first_term = Q_ml(abs(m)+1,l-1) + end if + if (l == abs(m)) then + second_term = 0.0 + else + second_term = Q_ml(abs(m),l-1) + end if + + GradSphericalIterative(m,l,i,1) = F_ml(l,abs(m)) * (c(abs(m))*x(1,i)*first_term + abs(m)*c(abs(m)-1)*Q_ml(abs(m),l)) + GradSphericalIterative(m,l,i,2) = F_ml(l,abs(m)) * (c(abs(m))*x(2,i)*first_term - abs(m)*s(abs(m)-1)*Q_ml(abs(m),l)) + GradSphericalIterative(m,l,i,3) = F_ml(l,abs(m)) * c(abs(m)) * (l+abs(m)) * second_term + end if + end do + end do + end do + end function GradSphericalIterative + + + subroutine cg_initialise(j,denom) + + integer, intent(in) :: j + integer :: i_j1,i_m1,i_j2,i_m2,i_j,i_m + integer, intent(in), optional :: denom + + integer :: my_denom + + if (cg_initialised .and. j > cg_j_max) then ! need to reinitialise + call cg_finalise() + cg_initialised = .false. + endif + if (cg_initialised) return + + my_denom = optional_default(1,denom) + + cg_j1_max = j + cg_m1_max = j + cg_j2_max = j + cg_m2_max = j + cg_j_max = j !(j1_max+j2_max) + cg_m_max = j !(j1_max+j2_max) + + allocate( cg_array(0:cg_j1_max,-cg_m1_max:cg_m1_max,0:cg_j2_max,-cg_m2_max:cg_m2_max,& + & 0:cg_j_max,-cg_j_max:cg_j_max) ) + + cg_array = 0.0_dp + + do i_j1 = 0, cg_j1_max + do i_m1 = -i_j1, i_j1, my_denom + do i_j2 = 0, cg_j2_max + do i_m2 = -i_j2, i_j2, my_denom + do i_j = abs(i_j1-i_j2), min(cg_j_max,i_j1+i_j2) + do i_m = -i_j, i_j, my_denom + + + cg_array(i_j1,i_m1,i_j2,i_m2,i_j,i_m) = cg_calculate(i_j1,i_m1,i_j2,i_m2,i_j,i_m,denom) + + enddo + enddo + enddo + enddo + enddo + enddo + + cg_initialised = .true. + + endsubroutine cg_initialise + + !################################################################################# + !# + !% Finalise global CG arrays + !# + !################################################################################# + + subroutine cg_finalise + + cg_j1_max = 0 + cg_m1_max = 0 + cg_j2_max = 0 + cg_m2_max = 0 + cg_j_max = 0 + cg_m_max = 0 + + if(allocated(cg_array)) deallocate( cg_array ) + cg_initialised = .false. + + endsubroutine cg_finalise + + !################################################################################# + !# + !% Look up CG coefficient from CG array, previously calculated. + !# + !################################################################################# + + function cg_lookup(j1,m1,j2,m2,j,m,denom) result(cg) + + real(dp) :: cg + integer, intent(in) :: j1,m1,j2,m2,j,m + integer, intent(in), optional :: denom + + cg=0.0_dp + + if ( .not. cg_check(j1,m1,j2,m2,j,m,denom) ) then + return + endif + + if( j1<=cg_j1_max .and. j2<=cg_j2_max .and. j<=cg_j_max .and. & + abs(m1)<=cg_m1_max .and. abs(m2)<=cg_m2_max .and. abs(m) <= cg_m_max .and. cg_initialised ) then + cg = cg_array(j1,m1,j2,m2,j,m) + else + cg = cg_calculate(j1,m1,j2,m2,j,m,denom) + endif + + endfunction cg_lookup + + !################################################################################# + !# + !% Check if input variables for CG make sense. + !% Source: http://mathworld.wolfram.com/Clebsch-GordanCoefficient.html \\ + !% + !% $ j_1 + j_2 \ge j $ \\ + !% $ j_1 - j_2 \ge -j $ \\ + !% $ j_1 - j_2 \le j $ \\ + !% $ j_1 \ge m_1 \ge j_1 $ \\ + !% $ j_2 \ge m_2 \ge j_2 $ \\ + !% $ j \ge m \ge j $ \\ + !% $ m_1 + m_2 = m $ \\ + !# + !################################################################################# + + function cg_check(j1,m1,j2,m2,j,m,denom) + + logical :: cg_check + integer, intent(in) :: j1,m1,j2,m2,j,m + integer, intent(in), optional :: denom + + integer :: my_denom + + my_denom = optional_default(1,denom) + cg_check = (j1>=0) .and. (j2>=0) .and. (j>=0) .and. & + (abs(m1)<=j1) .and. (abs(m2)<=j2) .and. (abs(m)<=j) & + .and. (m1+m2==m) .and. (j1+j2 >= j) .and. (abs(j1-j2) <= j) & + .and. (mod(j1+j2+j,my_denom)==0) + + endfunction cg_check + + !################################################################################# + !# + !% Calculate a Clebsch-Gordan coefficient $\left< j_1 m_1 j_2 m_2 | j m \right>$ + !% Source: http://mathworld.wolfram.com/Clebsch-GordanCoefficient.html \\ + !% $ \left< j_1 m_1 j_2 m_2 | j m \right> = (-1)^{m+j_1-j_2) + !% \sqrt{2j+1} \left( \begin{array}{ccc} + !% j_1 & j_2 & j \\ + !% m_1 & m_2 & -m \\ + !% \end{array} \right) $ + !% where the thing on the right-hand side is the Wigner 3J symbol. + !# + !################################################################################# + + function cg_calculate(j1,m1,j2,m2,j,m,denom) result(cg) + + real(dp) :: cg + integer, intent(in) :: j1,m1,j2,m2,j,m + integer, intent(in), optional :: denom + + integer :: my_denom + + my_denom = optional_default(1,denom) + + cg=0.0_dp + if ( .not. cg_check(j1,m1,j2,m2,j,m,denom) ) return + + cg = oscillate((m+j1-j2)/my_denom) * sqrt(2.0_dp*real(j,dp)/real(my_denom,dp)+1.0_dp) * & + wigner3j(j1,m1,j2,m2,j,-m,denom) + + end function cg_calculate + + !################################################################################# + !# + !% Triangle coefficient + !% Source: http://mathworld.wolfram.com/TriangleCoefficient.html + !% + !% $ \Delta(a,b,c) = \frac{ (a+b-c)! (a-b+c)! (-a+b+c)! }{ (a+b+c+1)! } $ + !# + !################################################################################# + + function tc(a,b,c,denom) + + real(dp) :: tc + integer, intent(in) :: a, b, c + integer, intent(in), optional :: denom + integer :: my_denom + + my_denom = optional_default(1,denom) + + tc = factorial((a+b-c)/my_denom) * factorial((a-b+c)/my_denom) * & + factorial((-a+b+c)/my_denom) / factorial((a+b+c)/my_denom+1) + + endfunction tc + + !################################################################################# + !# + !% Wigner 3J symbol + !% Source: http://mathworld.wolfram.com/Wigner3j-Symbol.html + !% + !% \[ + !% \left( \begin{array}{ccc} + !% j_1 & j_2 & j \\ + !% m_1 & m_2 & m \\ + !% \end{array} \right) = (-1)^{j_1-j_2-m) \sqrt{ \Delta (j_1,j_2,j) } + !% \sqrt{ (j_1+m_1)! (j_1-m_1)! (j_2+m_2)! (j_2-m_2)! (j+m)! (j-m)! } + !% \sum_k \frac{ (-1)^k }{k! (j-j_2+k+m_1)! (j-j_1+k-m_2)! (j_1+j_2-j-k)! + !% (j_1-k-m_1)! (j_2-k+m_2)! } + !% \] + !% the summation index k runs on all integers where none of the argument of + !% factorials are negative + !% $\Delta(a,b,c)$ is the triangle coefficient. + !# + !################################################################################# + + function wigner3j(j1,m1,j2,m2,j,m,denom) + + real(dp) :: wigner3j + integer, intent(in) :: j1,m1,j2,m2,j,m + integer, intent(in), optional :: denom + + real(dp) :: pre_fac, triang_coeff, main_coeff, sum_coeff, sum_term + integer :: k, kmin, kmax, my_denom + + my_denom = optional_default(1,denom) + + pre_fac = oscillate((j1-j2-m)/my_denom) + + triang_coeff = sqrt( tc(j1,j2,j,denom) ) + + main_coeff = sqrt( & + factorial((j1+m1)/my_denom) * factorial((j1-m1)/my_denom) * & + factorial((j2+m2)/my_denom) * factorial((j2-m2)/my_denom) * & + factorial((j+m)/my_denom) * factorial((j-m)/my_denom) ) + + sum_coeff = 0.0_dp + + kmin = max( j2-j-m1, j1+m2-j, 0 ) / my_denom + kmax = min( j1+j2-j, j1-m1, j2+m2) / my_denom + + do k = kmin, kmax + + sum_term = 1.0_dp / ( factorial(k) * factorial((j-j2+m1)/my_denom+k) * & + factorial((j-j1-m2)/my_denom+k) * factorial((j1+j2-j)/my_denom-k) * & + factorial((j1-m1)/my_denom-k) * factorial((j2+m2)/my_denom-k) ) + + sum_term = oscillate(k) * sum_term + + sum_coeff = sum_coeff + sum_term + + enddo + + wigner3j = pre_fac * triang_coeff * main_coeff * sum_coeff + + endfunction wigner3j + +end module angular_functions_module diff --git a/src/libAtoms/clusters.F90 b/src/libAtoms/clusters.F90 new file mode 100644 index 0000000000..ed7a060c54 --- /dev/null +++ b/src/libAtoms/clusters.F90 @@ -0,0 +1,4304 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" +module clusters_module + use error_module + use system_module + use linearalgebra_module + use Table_module + use periodictable_module + use Atoms_types_module + use Atoms_module + use dictionary_module + use ParamReader_module + use group_module + use constraints_module + use dynamicalsystem_module + use cinoutput_module + +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif +implicit none +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif +private + +integer, parameter :: & + HYBRID_ACTIVE_MARK = 1, & + HYBRID_BUFFER_MARK = 2, & + HYBRID_TRANS_MARK = 3, & + HYBRID_TERM_MARK = 4, & + HYBRID_BUFFER_OUTER_LAYER_MARK = 5, & + HYBRID_ELECTROSTATIC_MARK = 6, & + HYBRID_NO_MARK = 0 +! HYBRID_FIT_MARK = 6, & + +public :: HYBRID_ACTIVE_MARK, HYBRID_BUFFER_MARK, HYBRID_TRANS_MARK, HYBRID_TERM_MARK, & + HYBRID_BUFFER_OUTER_LAYER_MARK, HYBRID_ELECTROSTATIC_MARK, HYBRID_NO_MARK +! HYBRID_FIT_MARK + +integer, parameter :: MAX_CUT_BONDS = 6 +public :: MAX_CUT_BONDS + +character(len=TABLE_STRING_LENGTH), parameter :: hybrid_mark_name(0:6) = & + (/ "h_none ", & + "h_active ", & + "h_buffer ", & + "h_trans ", & + "h_term ", & + "h_outer_l ", & + "h_fit " /) + +public :: create_cluster_info_from_mark, carve_cluster, create_cluster_simple, create_hybrid_weights, & + bfs_grow, bfs_step, multiple_images, discard_non_min_images, make_convex, create_embed_and_fit_lists, & + create_embed_and_fit_lists_from_cluster_mark, & + add_cut_hydrogens, construct_hysteretic_region, & + create_pos_or_list_centred_hybrid_region, get_hybrid_list, & + estimate_origin_extent + !, construct_region, select_hysteretic_quantum_region + +!% Grow a selection list by bond hopping. +interface bfs_grow + module procedure bfs_grow_single + module procedure bfs_grow_list +end interface + +contains + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Cluster carving routines + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% On exit, 'list' will contain 'atom' (with shift '000') + !% plus the atoms within 'n' bonds hops of it. + subroutine bfs_grow_single(this, list, atom, n, nneighb_only, min_images_only, alt_connect) + type(Atoms), intent(in) :: this + type(Table), intent(out) :: list + integer, intent(in) :: atom, n + logical, optional, intent(in)::nneighb_only, min_images_only + type(Connection), intent(in), optional :: alt_connect + + call append(list, (/atom, 0,0,0/)) ! Add atom with shift 000 + call bfs_grow_list(this, list, n, nneighb_only, min_images_only, alt_connect) + + end subroutine bfs_grow_single + + + !% On exit, 'list' will have been grown by 'n' bond hops. + subroutine bfs_grow_list(this, list, n, nneighb_only, min_images_only, alt_connect) + type(Atoms), intent(in) ::this + type(Table), intent(inout)::list + integer, intent(in) :: n + logical, optional, intent(in)::nneighb_only, min_images_only + type(Connection), intent(in), optional :: alt_connect + + type(Table)::tmplist + integer::i + + do i=1,n + call bfs_step(this, list, tmplist, nneighb_only, min_images_only, alt_connect=alt_connect) + call append(list, tmplist) + end do + + if (n >= 1) call finalise(tmplist) + end subroutine bfs_grow_list + + + !% Execute one Breadth-First-Search move on the atomic connectivity graph. + subroutine bfs_step(this,input,output,nneighb_only, min_images_only, max_r, alt_connect, property, debugfile, error) + type(Atoms), intent(in), target :: this !% The atoms structure to perform the step on. + type(Table), intent(in) :: input !% Table with intsize 4. First integer column is indices of atoms + !% already in the region, next 3 are shifts. + type(Table), intent(out) :: output !% Table with intsize 4, containing the new atomic + !% indices and shifts. + + + logical, optional, intent(in) :: nneighb_only + !% If present and true, sets whether only neighbours + !% within the sum of the two respective covalent radii (multiplied by the atom's nneightol) are included, + !% irrespective of the cutoff in the atoms structure + !% (default is true). + + logical, optional, intent(in) :: min_images_only + !% If true, there will be no repeated atomic indices in final list - only the + !% minimum shift image of those found will be included. Default is false. + + real(dp), optional, intent(in) :: max_r + !% if present, only neighbors within this range will be included + + type(Connection), intent(in), optional, target :: alt_connect + integer, intent(in), optional:: property(:) + + type(inoutput), optional :: debugfile + + integer, optional, intent(out) :: error + + !local + logical :: do_nneighb_only, do_min_images_only + integer :: i, j, n, m, jshift(3), ishift(3) + + integer :: n_i, keep_row(4), in_i, min_image + integer, allocatable, dimension(:) :: repeats + real(dp), allocatable, dimension(:) :: normsqshift + type(Connection), pointer :: use_connect + + INIT_ERROR(error) + + if (present(debugfile)) call print("bfs_step", file=debugfile) + if (present(alt_connect)) then + use_connect => alt_connect + else + use_connect => this%connect + endif + + if (present(debugfile)) call print("bfs_step cutoff " // this%cutoff, file=debugfile) + + if (.not.use_connect%initialised) then + RAISE_ERROR('BFS_Step: Atomic structure has no connectivity data', error) + endif + + do_nneighb_only = optional_default(.true., nneighb_only) + + do_min_images_only = optional_default(.false., min_images_only) + + if (present(debugfile)) call print('bfs_step: do_nneighb_only = ' // do_nneighb_only // ' do_min_images_only = '//do_min_images_only, file=debugfile) + call print('bfs_step: do_nneighb_only = ' // do_nneighb_only // ' do_min_images_only = '//do_min_images_only, PRINT_NERD) + + if(input%intsize /= 4 .or. input%realsize /= 0) then + RAISE_ERROR("bfs_step: input table must have intsize=4.", error) + endif + + call allocate(output, 4, 0, 0, 0) + + ! Now go though the atomic indices + do m = 1, input%N + i = input%int(1,m) + ishift = input%int(2:4,m) + + if (present(debugfile)) call print("bfs_step check atom " // m // " " // i // " with n_neigh " // n_neighbours(this, i, alt_connect=use_connect), file=debugfile) + ! Loop over i's neighbours + do n = 1, n_neighbours(this,i, alt_connect=use_connect) + j = neighbour(this,i,n,shift=jshift,max_dist=max_r, alt_connect=use_connect) + if (present(debugfile)) call print("bfs_step check neighbour " // n // " " // j, file=debugfile) + if (j == 0) cycle + + ! Look at next neighbour if j with correct shift is already in the cluster + ! Must check input AND output tables + if (find(input,(/j,ishift+jshift/)) > 0) cycle + if (present(debugfile)) call print("bfs_step not in input", file=debugfile) + if (find(output,(/j,ishift+jshift/)) > 0) cycle + if (present(debugfile)) call print("bfs_step not in output", file=debugfile) + + if (do_nneighb_only .and. .not. is_nearest_neighbour(this, i, n, alt_connect=use_connect)) cycle + if (present(debugfile)) call print("bfs_step acceptably near neighbor", file=debugfile) + + if (present(property)) then + if (property(j) == 0) cycle + endif + if (present(debugfile)) call print("bfs_step property matches OK", file=debugfile) + + ! Everything checks out ok, so add j to the output table + ! with correct shift + if (present(debugfile)) call print("bfs_step appending", file=debugfile) + call append(output,(/j,ishift+jshift/)) + end do + end do + + if (present(debugfile)) call print("bfs_step raw output", file=debugfile) + if (present(debugfile)) call print(output, file=debugfile) + + if (do_min_images_only) then + + ! If there are repeats of any atomic index, + ! we want to keep the one with smallest normsq(shift) + + ! must check input and output + + n = 1 + do while (n <= output%N) + + ! How many occurances in the output list? + n_i = count(int_part(output,1) == output%int(1,n)) + + ! Is there one in the input list as well? + in_i = find_in_array(int_part(input,1),output%int(1,n)) + + ! If there's only one, and we've not got one already then move on + if (n_i == 1 .and. in_i == 0) then + n = n + 1 + cycle + end if + + ! otherwise, things are more complicated... + ! we want to keep the one with the smallest shift, bearing + ! in mind that it could well be the one in the input list + + allocate(repeats(n_i), normsqshift(n_i)) + + ! Get indices of repeats of this atomic index + repeats = pack((/ (j, j=1,output%N) /), & + int_part(output,1) == output%int(1,n)) + + if (in_i /= 0) then + ! atom is in input list, remove all new occurances + call delete_multiple(output, repeats) + else + ! Find row with minimum normsq(shift) + normsqshift = normsq(real(output%int(2:4,repeats),dp),1) + min_image = repeats(minloc(normsqshift,dim=1)) + keep_row = output%int(:,min_image) + + ! keep the minimum image + call delete_multiple(output, & + pack(repeats, repeats /= min_image)) + end if + + ! don't increment n, since delete_multiple copies items from + ! end of list over deleted items, so we need to retest + + deallocate(repeats, normsqshift) + + end do + + end if + + if (present(debugfile)) call print("bfs_step final output", file=debugfile) + if (present(debugfile)) call print(output, file=debugfile) + + end subroutine bfs_step + + + !% Check if the list of indices and shifts 'list' contains + !% any repeated atomic indices. + function multiple_images(list) + type(Table), intent(in) :: list + logical :: multiple_images + + + integer :: i + multiple_images = .false. + + if (list%N == 0) return + + do i = 1, list%N + if (count(int_part(list,1) == list%int(1,i)) /= 1) then + multiple_images = .true. + return + end if + end do + + end function multiple_images + + !% Given an input list with 4 integer columns for atomic indices + !% and shifts, keep only the minimum images of each atom + subroutine discard_non_min_images(list) + type(Table), intent(inout) :: list + + integer :: n, n_i, j, min_image, keep_row(4) + integer, allocatable, dimension(:) :: repeats + real(dp), allocatable, dimension(:) :: normsqshift + + n = 1 + do while (n <= list%N) + + ! How many occurances in the list list? + n_i = count(int_part(list,1) == list%int(1,n)) + + ! If there's only one, and we've not got one already then move on + if (n_i == 1) then + n = n + 1 + cycle + end if + + ! otherwise, things are more complicated... + ! we want to keep the one with the smallest shift + + allocate(repeats(n_i), normsqshift(n_i)) + + ! Get indices of repeats of this atomic index + repeats = pack((/ (j, j=1,list%N) /), & + int_part(list,1) == list%int(1,n)) + + ! Find row with minimum normsq(shift) + normsqshift = normsq(real(list%int(2:4,repeats),dp),1) + min_image = repeats(minloc(normsqshift,dim=1)) + keep_row = list%int(:,min_image) + + ! keep the minimum image + call delete_multiple(list, & + pack(repeats, repeats /= min_image)) + + ! don't increment n, since delete_multiple copies items from + ! end of list over deleted items, so we need to retest + + deallocate(repeats, normsqshift) + + end do + + end subroutine discard_non_min_images + + + !% Add atoms to 'list' to make the selection region convex, i.e. if $i$ and + !% $j$ are nearest neighbours, with $i$ in the list and not $j$ then $j$ will be added + !% if more than half its nearest neighbours are in the list. + subroutine make_convex(this, list) + type(Atoms), intent(in) :: this + type(Table), intent(inout) :: list + type(Table)::tmplist + do while(make_convex_step(this, list, tmplist) /= 0) + call append(list, tmplist) + end do + call finalise(tmplist) + end subroutine make_convex + + !% OMIT + ! Given an input list, what needs to be added to make the selection region convex? + function make_convex_step(this, input, output, error) result(newatoms) + type(Atoms), intent(in) :: this + type(Table), intent(in) :: input + type(Table), intent(out) :: output + integer, optional, intent(out) :: error + integer::newatoms + + integer :: n, i, j, k, p, m, n_in, nn, ishift(3), jshift(3), kshift(3) + real(dp) :: r_ij, r_kj + + INIT_ERROR(error) + + ! Check table size + if(input%intsize /= 4 .or. input%realsize /= 0) then + RAISE_ERROR("make_convex_step: input table must have intsize=4", error) + endif + + if(input%intsize /= 4 .or. input%realsize /= 0) then + RAISE_ERROR("bfs_step: input table must have intsize=4.", error) + endif + + call allocate(output, 4, 0, 0, 0) + + do n=1,input%N + i = input%int(1,n) + ishift = input%int(2:4,n) + + !Loop over neighbours + do m = 1, n_neighbours(this,i) + j = neighbour(this,i,m, r_ij,shift=jshift) + + ! Look for nearest neighbours of i not in input list + if (find(input,(/j,ishift+jshift/)) == 0 .and. is_nearest_neighbour(this, i, m)) then + + n_in = 0 + nn = 0 + ! Count number of nearest neighbours of j, and how many + ! of them are in input list + do p = 1, n_neighbours(this,j) + k = neighbour(this,j,p, r_kj, shift=kshift) + if (is_nearest_neighbour(this, j, p)) then + nn = nn + 1 + if (find(input,(/k,ishift+jshift+kshift/)) /= 0) n_in = n_in + 1 + end if + end do + + !If more than half of j's nearest neighbours are in then add it to output + if (find(output, (/j,ishift+jshift/)) == 0 .and. real(n_in,dp)/real(nn,dp) > 0.5_dp) & + call append(output, (/j,ishift+jshift/)) + + end if + + end do + end do + + newatoms = output%N + + end function make_convex_step + + +! Gotcha 1: Hollow sections +! NB equivalent to reduce_n_cut_bonds when new number of bonds is 0 +! JRK: reduce_n_cut_bonds() is not equivalent to cluster_in_out_in() +! for silica, where adding IN-OUT-IN atoms doesn't change number of +! cut bonds OUT and IN refers to the list in cluster_info Look at the +! OUT nearest neighbours of IN atoms. If mode='all', then if ALL the +! nearest neighbours of the OUT atom are IN, then make the OUT atom +! IN. If mode='any', then add the OUT atom if ANY of it's nearest +! neighours (apart from the original IN atom)! are IN. This stronger +! condition is required for cp2k. + +function cluster_in_out_in(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, mode) result(cluster_changed) + type(Atoms), intent(in) :: this + type(Table), intent(inout) :: cluster_info + logical, intent(in) :: connectivity_just_from_connect + type(Connection), intent(in) :: use_connect + logical, intent(in) :: atom_mask(6) + character(len=*), intent(in) :: mode + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3), p, k, kshift(3), n_nearest, n_in + logical :: add_atom + + cluster_changed = .false. + if (trim(mode) /= 'all' .and. trim(mode) /= 'any') & + call system_abort('cluster_in_out_in: bad mode '//mode//' - should be "all" or "any"') + + n = 1 + ! Loop over cluster atoms (including ones that may get added in this loop) + call print('cluster_in_out_in: Checking for hollow sections', PRINT_NERD) + do while (n <= cluster_info%N) + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + call print('cluster_in_out_in: i = '//i//' ['//ishift//'] Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + + !Loop over neighbours + do m = 1, n_neighbours(this,i,alt_connect=use_connect) + j = neighbour(this,i,m, shift=jshift,alt_connect=use_connect) + + if (find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) == 0 .and. & + (connectivity_just_from_connect .or. is_nearest_neighbour(this, i, m, alt_connect=use_connect)) ) then + ! j is out and is nearest neighbour + + call print('cluster_in_out_in: checking j = '//j//" ["//jshift//"]",PRINT_ANALYSIS) + + ! We have an OUT nearest neighbour, loop over its nearest neighbours to see if they are IN + + n_nearest = 0 + n_in = 0 + do p = 1, n_neighbours(this,j,alt_connect=use_connect) + k = neighbour(this,j,p, shift=kshift,alt_connect=use_connect) + if (k == i) cycle + if (connectivity_just_from_connect .or. is_nearest_neighbour(this, j, p,alt_connect=use_connect)) then + n_nearest = n_nearest + 1 + if (find(cluster_info,(/k,ishift+jshift+kshift,this%Z(k),0/), atom_mask) /= 0) then + n_in = n_in + 1 + end if + end if + end do + + if (trim(mode) == "all") then + !If all of j's nearest neighbours are IN then add it + add_atom = n_nearest == n_in + else + !If any of j's nearest neighbours (apart from i) are in then add it + add_atom = n_in /= 0 + end if + + if (add_atom) then + call append(cluster_info, (/j,ishift+jshift,this%Z(j),0/), (/this%pos(:,j), 1.0_dp/), (/ "inoutin "/) ) + cluster_changed = .true. + call print('cluster_in_out_in: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + end if + + end if + + end do ! m + n = n + 1 + end do ! while (n <= cluster_info%N) + + call print('cluster_in_out_in: Finished checking',PRINT_NERD) + call print("cluster_in_out_in: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) +end function cluster_in_out_in + + !% Find cases where two IN atoms have a common + !% OUT nearest neighbour, and see if termination would cause the hydrogen + !% atoms to be too close together. If so, include the OUT nearest neighbour + !% in the cluster + !% returns true if cluster was changed + function cluster_fix_termination_clash(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, termination_clash_factor) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + real(dp), intent(in) :: termination_clash_factor + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3), p, k, kshift(3) + real(dp) :: dhat_ij(3), dhat_jk(3), r_ij, r_jk, H1(3), H2(3), diff_ik(3) + ! real(dp) :: t_norm + + cluster_changed = .false. + + call print('doing cluster_fix_termination_clash', PRINT_NERD) + + !Loop over atoms in the cluster + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) ! index of atom in the cluster + ishift = cluster_info%int(2:4,n) + call print('cluster_fix_termination_clash: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + !Loop over atom i's neighbours + do m = 1, n_neighbours(this,i,alt_connect=use_connect) + j = neighbour(this,i,m, shift=jshift, diff=dhat_ij, distance=r_ij,alt_connect=use_connect) + dhat_ij = dhat_ij/r_ij + + !If j is IN the cluster, or not a nearest neighbour then try the next neighbour + if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then + call print('cluster_fix_termination_clash: j = '//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) + cycle + end if + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print('cluster_fix_termination_clash: j = '//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + ! So j is an OUT nearest neighbour of i. + call print('cluster_fix_termination_clash: checking j = '//j//" ["//jshift//"]",PRINT_ANALYSIS) + + !Determine the position of the would-be hydrogen along i--j + call print('cluster_fix_termination_clash: Finding i--j hydrogen position',PRINT_ANALYSIS) + + H1 = this%pos(:,i) + (this%lattice .mult. (ishift)) + & + termination_bond_rescale(this%Z(i), this%Z(j)) * r_ij * dhat_ij + + !Do a loop over j's nearest neighbours + call print('cluster_fix_termination_clash: Looping over '//n_neighbours(this,j, alt_connect=use_connect)//' neighbours of j', PRINT_ANALYSIS) + + do p = 1, n_neighbours(this,j, alt_connect=use_connect) + k = neighbour(this,j,p, shift=kshift, diff=dhat_jk, distance=r_jk, alt_connect=use_connect) + dhat_jk = dhat_jk/r_jk + + !If k is OUT of the cluster or k == i or it is not a nearest neighbour of j + !then try the next neighbour + + if(find(cluster_info,(/k,ishift+jshift+kshift,this%Z(k),0/), atom_mask) == 0) then + call print('cluster_fix_termination_clash: k = '//k//" ["//kshift//"] not in cluster",PRINT_ANALYSIS) + cycle + end if + if(k == i .and. all( jshift+kshift == 0 )) cycle + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,j, p, alt_connect=use_connect))) then + call print('cluster_fix_termination_clash: k = '//k//" ["//kshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + call print('cluster_fix_termination_clash: testing k = '//k//" ["//kshift//"]", PRINT_ANALYSIS) + !Determine the position of the would-be hydrogen along k--j + call print('cluster_fix_termination_clash: Finding k--j hydrogen position',PRINT_ANALYSIS) + + diff_ik = r_ij * dhat_ij + r_jk * dhat_jk + + H2 = this%pos(:,i) + (this%lattice .mult. (ishift)) + diff_ik - & + termination_bond_rescale(this%Z(k), this%Z(j)) * r_jk * dhat_jk + call print('cluster_fix_termination_clash: Checking i--k distance and hydrogen distance',PRINT_ANALYSIS) + + call print("cluster_fix_termination_clash: proposed hydrogen positions:", PRINT_ANALYSIS) + call print(H1, PRINT_ANALYSIS) + call print(H2, PRINT_ANALYSIS) + call print('norm(H1-H2) '//norm(H1-H2)//' tol'//(bond_length(1,1)*this%nneightol*termination_clash_factor), PRINT_ANALYSIS) + !NB workaround for pgf90 bug (as of 9.0-1) + ! t_norm = norm(H1-H2); call print("cluster_fix_termination_clash: hydrogen distance would be "//t_norm, PRINT_ANALYSIS) + !NB end of workaround for pgf90 bug (as of 9.0-1) + ! If i and k are nearest neighbours, or the terminating hydrogens would be very close, then + ! include j in the cluster. The H--H checking is conservative, hence the extra factor of 1.2 + if ((norm(diff_ik) < bond_length(this%Z(i),this%Z(k))*this%nneightol) .or. & + (norm(H1-H2) < bond_length(1,1)*this%nneightol*termination_clash_factor) ) then + + call append(cluster_info,(/j,ishift+jshift,this%Z(j),0/),(/this%pos(:,j),1.0_dp/), (/ "clash "/) ) + cluster_changed = .true. + call print('cluster_fix_termination_clash: Atom '//j//'with shift '//(ishift+jshift)//' added to cluster. Atoms = '//cluster_info%N, PRINT_NERD) + ! j is now included in the cluster, so we can exit this do loop (over p) + exit + end if + + end do ! p + + end do ! m + + end do ! while (n <= cluster_info%N) + + call print('cluster_fix_termination_clash: Finished checking',PRINT_NERD) + call print("cluster_fix_termination_clash: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + end function cluster_fix_termination_clash + + !% keep each whole residue (using atom_res_number(:) property) if any bit of it is already included + function cluster_keep_whole_residues(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_keep_whole_residues) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical, intent(in) :: present_keep_whole_residues !% if true, keep_whole_residues was specified by user, not just a default value + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + integer, pointer :: atom_res_number(:) + + call print('doing cluster_keep_whole_residues', PRINT_NERD) + + cluster_changed = .false. + if (.not. assign_pointer(this, 'atom_res_number', atom_res_number)) then + if (present_keep_whole_residues) then + call print("WARNING: cluster_keep_whole_residues got keep_whole_residues requested explicitly, but no proper atom_res_number property available", PRINT_ALWAYS) + endif + return + endif + + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + if (atom_res_number(i) < 0) cycle + call print('cluster_keep_whole_residues: i = '//i//' residue # = ' // atom_res_number(i) //'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + + if (atom_res_number(i) /= atom_res_number(j)) then + call print("cluster_keep_whole_residues: j = "//j//" ["//jshift//"] has different res number " // atom_res_number(j), PRINT_ANALYSIS) + cycle + endif + if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then + call print("cluster_keep_whole_residues: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) + cycle + end if + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_keep_whole_residues: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"res_num "/) ) + cluster_changed = .true. + call print('cluster_keep_whole_residues: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + + end do ! m + end do ! while (n <= cluster_info%N) + + call print('cluster_keep_whole_residues: Finished checking',PRINT_NERD) + call print("cluster_keep_whole_residues: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + + end function cluster_keep_whole_residues + + !% keep each whole proline (using atom_subgroup_number(:) and atom_res_number(:) property) if any bit of it is already included + function cluster_keep_whole_prolines(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_keep_whole_prolines) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical, intent(in) :: present_keep_whole_prolines !% if true, keep_whole_prolines was specified by user, not just a default value + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + integer, pointer :: atom_res_number(:), atom_subgroup_number(:) + logical :: is_proline + + call print('doing cluster_keep_whole_prolines', PRINT_NERD) + + cluster_changed = .false. + if (.not. assign_pointer(this, 'atom_res_number', atom_res_number) .or. .not. assign_pointer(this, 'atom_subgroup_number', atom_subgroup_number)) then + if (present_keep_whole_prolines) then + call print("WARNING: cluster_keep_whole_prolines got keep_whole_prolines requested explicitly, but no proper atom_res_number or atom_subgroup_number properties available", PRINT_ALWAYS) + endif + return + endif + + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + if (atom_res_number(i) < 0) cycle + call print('cluster_keep_whole_prolines: i = '//i//' residue # = ' // atom_res_number(i) //' subgroup # = '// atom_subgroup_number(i) // & + '. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + is_proline = .false. + + if (atom_res_number(i) /= atom_res_number(j)) then + call print("cluster_keep_whole_prolines: j = "//j//" ["//jshift//"] has different res number " // atom_res_number(j), PRINT_ANALYSIS) + cycle + endif + if (atom_subgroup_number(i) <= -10 .or. atom_subgroup_number(j) <= -10) then + call print("cluster_keep_whole_prolines: j = "//j//" ["//jshift//"] has proline subgroup number " // atom_subgroup_number(j), PRINT_ANALYSIS) + is_proline = .true. + endif + if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then + call print("cluster_keep_whole_prolines: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) + cycle + end if + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_keep_whole_prolines: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + if (is_proline) then + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"subgp_num "/) ) + cluster_changed = .true. + call print('cluster_keep_whole_prolines: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + endif + + end do ! m + + end do ! while (n <= cluster_info%N) + + call print('cluster_keep_whole_prolines: Finished checking',PRINT_NERD) + call print("cluster_keep_whole_prolines: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + + end function cluster_keep_whole_prolines + + !% keep each proline sidechain and directly connected bit of backbone (using atom_subgroup_number and atom_res_number(:) property) if any bit of it is already included + function cluster_keep_whole_proline_sidechains(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_keep_whole_proline_sidechains) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical, intent(in) :: present_keep_whole_proline_sidechains !% if true, keep_whole_proline_sidechains was specified by user, not just a default value + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + integer, pointer :: atom_res_number(:), atom_subgroup_number(:) + logical :: is_proline + + call print('doing cluster_keep_whole_proline_sidechains', PRINT_NERD) + + cluster_changed = .false. + if (.not. assign_pointer(this, 'atom_res_number', atom_res_number) .or. .not. assign_pointer(this, 'atom_subgroup_number', atom_subgroup_number)) then + if (present_keep_whole_proline_sidechains) then + call print("WARNING: cluster_keep_whole_proline_sidechains got keep_whole_proline_sidechains requested explicitly, but no proper atom_res_number or atom_subgroup_number properties available", PRINT_ALWAYS) + endif + return + endif + + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + if (atom_res_number(i) < 0) cycle + call print('cluster_keep_whole_proline_sidechains: i = '//i//' residue # = ' // atom_res_number(i) //' subgroup # = '// atom_subgroup_number(i) // & + '. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + is_proline = .false. + + if (atom_res_number(i) /= atom_res_number(j)) then + call print("cluster_keep_whole_proline_sidechains: j = "//j//" ["//jshift//"] has different res number " // atom_res_number(j), PRINT_ANALYSIS) + cycle + endif + if (atom_subgroup_number(i) == -1000 .or. atom_subgroup_number(j) == -1000) then + call print("cluster_keep_proline_sidechains: i or j = "//j//" ["//jshift//"] has proline sidechain subgroup number " // atom_subgroup_number(j), PRINT_ANALYSIS) + is_proline = .true. + endif + if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then + call print("cluster_keep_proline_sidechains: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) + cycle + end if + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_keep_whole_proline_sidechains: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + if (is_proline) then + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"subgp_num "/) ) + cluster_changed = .true. + call print('cluster_keep_whole_proline_sidechains: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + endif + + end do ! m + + end do ! while (n <= cluster_info%N) + + call print('cluster_keep_whole_proline_sidechains: Finished checking',PRINT_NERD) + call print("cluster_keep_whole_proline_sidechains: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + + end function cluster_keep_whole_proline_sidechains + + !% keep each whole subgroup (using atom_subgroup_number and atom_res_number(:) property) if any bit of it is already included + function cluster_keep_whole_subgroups(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_keep_whole_subgroups) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical, intent(in) :: present_keep_whole_subgroups !% if true, keep_whole_subgroups was specified by user, not just a default value + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + integer, pointer :: atom_res_number(:), atom_subgroup_number(:) + + call print('doing cluster_keep_whole_subgroups', PRINT_NERD) + + cluster_changed = .false. + if (.not. assign_pointer(this, 'atom_res_number', atom_res_number) .or. .not. assign_pointer(this, 'atom_subgroup_number', atom_subgroup_number)) then + if (present_keep_whole_subgroups) then + call print("WARNING: cluster_keep_whole_subgroups got keep_whole_subgroups requested explicitly, but no proper atom_res_number or atom_subgroup_number properties available", PRINT_ALWAYS) + endif + return + endif + + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + if (atom_res_number(i) < 0) cycle + if (atom_subgroup_number(i) == 0) cycle + call print('cluster_keep_whole_subgroups: i = '//i//' residue # = ' // atom_res_number(i) //' subgroup # = '// atom_subgroup_number(i) // '. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + call print("cluster_keep_whole_subgroups: m = " // m //" j = " // j, PRINT_ANALYSIS) + if (atom_res_number(j) < 0) cycle + if (atom_subgroup_number(j) == 0) cycle + + if (atom_res_number(i) /= atom_res_number(j)) then + call print("cluster_keep_whole_subgroups: j = "//j//" ["//jshift//"] has different res number " // atom_res_number(j), PRINT_ANALYSIS) + cycle + endif + if (atom_subgroup_number(i) /= atom_subgroup_number(j)) then + call print("cluster_keep_whole_subgroups: j = "//j//" ["//jshift//"] has different subgroup number " // atom_subgroup_number(j), PRINT_ANALYSIS) + cycle + endif + if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then + call print("cluster_keep_whole_subgroups: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) + cycle + end if + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_keep_whole_subgroups: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"subgp_num "/) ) + cluster_changed = .true. + call print('cluster_keep_whole_subgroups: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + + end do ! m + + end do ! while (n <= cluster_info%N) + + call print('cluster_keep_whole_subgroups: Finished checking',PRINT_NERD) + call print("cluster_keep_whole_subgroups: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + + end function cluster_keep_whole_subgroups + + !% keep whole silica tetrahedra -- that is, for each silicon atom, keep all it's oxygen nearest neighbours + function cluster_keep_whole_silica_tetrahedra(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + + call print('doing cluster_keep_whole_silica_tetrahedra', PRINT_NERD) + + cluster_changed = .false. + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + if (this%z(i) /= 14) then + ! Consider only silicon atoms, which form centres of tetrahedra + cycle + end if + + call print('cluster_keep_whole_silica_tetrahedra: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + + if (this%z(j) /= 8) then + call print("cluster_keep_whole_silica_tetrahedra: j = "//j//" ["//jshift//"] is not oxygen ", PRINT_ANALYSIS) + cycle + endif + if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then + call print("cluster_keep_whole_silica_tetrahedra: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) + cycle + end if + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_keep_whole_silica_tetrahedra: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"tetra "/) ) + cluster_changed = .true. + call print('cluster_keep_whole_silica_tetrahedra: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + + end do ! m + + end do ! while (n <= cluster_info%N) + + call print('cluster_keep_whole_silica_tetrahedra: Finished checking',PRINT_NERD) + call print("cluster_keep_whole_silica_tetrahedra: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + + end function cluster_keep_whole_silica_tetrahedra + + !% keep whole octahedra for titania that is, for each Ti atom, keep all it's oxygen nearest neighbours but the O atoms with only 1 neighbour. + function cluster_keep_whole_titania_octahedra(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + + call print('doing cluster_keep_whole_titania_octahedra', PRINT_NERD) + + cluster_changed = .false. + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + if (this%z(i) /= 22) then + ! Consider only Ti atoms, which form centres of tetrahedra + cycle + end if + + call print('cluster_keep_whole_titania_octahedra: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + + if (this%z(j) /= 8) then + call print("cluster_keep_whole_titania_octahedra: j = "//j//" ["//jshift//"] is not oxygen ", PRINT_ANALYSIS) + cycle + endif + if(find(cluster_info,(/j,ishift+jshift,this%Z(j),0/), atom_mask) /= 0) then + call print("cluster_keep_whole_titania_octahedra: j = "//j//" ["//jshift//"] is in cluster",PRINT_ANALYSIS) + cycle + end if + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_keep_whole_titania_octahedra: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + !check if the oxygen has more than 1 neighbour in the cluster. +! neigh_O = 0 +! do l=1,n_neighbours(this, j, alt_connect=use_connect) +! k = neighbour(this, j, l, distance=rdist, shift=kshift, alt_connect=use_connect) +! if(find(cluster_info,(/k,ishift+jshift+kshift,this%Z(k),0/), atom_mask) == 0) then +! call print(" j : "// j // " Z(j) :" // this%Z(j) // ' shift ' // jshift) +! call print(" k : "// k // " Z(k) :" // this%Z(k) // ' shift ' // kshift) +! call print(" i : "// i // " Z(i) :" // this%Z(i) // ' shift ' // ishift) +! call print('distance between k and j '// rdist) +! call print("cluster_keep_whole_titania_octahedra: k = "//k//" ["//kshift//"] is not in cluster",PRINT_ANALYSIS) +! cycle +! end if +! if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,j, l, alt_connect=use_connect))) then +! call print(" j : "// j // " Z(j) :" // this%Z(j) // ' shift ' // jshift) +! call print(" k : "// k // " Z(k) :" // this%Z(k) // ' shift ' // kshift) +! call print(" i : "// i // " Z(i) :" // this%Z(i) // ' shift ' // ishift) +! call print('distance between k and j '// rdist) +! call print("cluster_keep_whole_titania_octahedra: k = "//k//" ["//kshift//"] not nearest neighbour",PRINT_ANALYSIS) +! cycle +! end if +! neigh_O = neigh_O + 1 +! end do ! l + + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"octa "/) ) + cluster_changed = .true. + call print('cluster_keep_whole_titania_octahedra Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + + end do ! m + + + end do ! while (n <= cluster_info%N) + + call print('cluster_keep_whole_titania_octahedra: Finished checking',PRINT_NERD) + call print("cluster_keep_whole_titania_octahedra: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + + end function cluster_keep_whole_titania_octahedra + + !% adding each neighbour outside atom if doing so immediately reduces the number of cut bonds + function cluster_reduce_n_cut_bonds(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3), p, k, kshift(3) + integer :: n_bonds_in, n_bonds_out + + call print('doing cluster_reduce_n_cut_bonds', PRINT_NERD) + + cluster_changed = .false. + + ! loop over each atom in the cluster already + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + call print('cluster_reduce_n_cut_bonds: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + + ! loop over every neighbour, looking for outside neighbours + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_reduce_n_cut_bonds: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + ! if we're here, j must be an outside neighbour of i + call print('cluster_reduce_n_cut_bonds: j = '//j//'. Looping over '//n_neighbours(this,j,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + + n_bonds_in = 0 + n_bonds_out = 0 + do p=1, n_neighbours(this, j, alt_connect=use_connect) + k = neighbour(this, j, p, shift=kshift, alt_connect=use_connect) + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,j, p, alt_connect=use_connect))) then + call print("cluster_reduce_n_cut_bonds: k = "//k//" ["//kshift//"] not nearest neighbour of j = " // j,PRINT_ANALYSIS) + cycle + end if + ! count how many bonds point in vs. out + if (find(cluster_info, (/ k, ishift+jshift+kshift, this%Z(k), 0 /), atom_mask ) /= 0) then + n_bonds_in = n_bonds_in + 1 + else + n_bonds_out = n_bonds_out + 1 + endif + end do ! p + + if (n_bonds_out < n_bonds_in) then ! adding this one would reduce number of cut bonds + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"n_cut_bond" /) ) + cluster_changed = .true. + call print('cluster_reduce_n_cut_bonds: Added atom ' //j//' ['//(ishift+jshift)//'] n_bonds_in ' // n_bonds_in // & + ' out ' // n_bonds_out // ' to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + endif + end do ! m + + end do ! while (n <= cluster_info%N) + + call print('cluster_reduce_n_cut_bonds: Finished checking',PRINT_NERD) + call print("cluster_reduce_n_cut_bonds: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + end function cluster_reduce_n_cut_bonds + + !% Go through the cluster atoms and find cut bonds. If the bond is to + !% hydrogen, then include the hydrogen in the cluster list (since AMBER + !% doesn't cap a bond to hydrogen with a link atom) + function cluster_protect_X_H_bonds(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + + call print('doing cluster_protect_X_H_bonds', PRINT_NERD) + cluster_changed = .false. + + ! loop over each atom in the cluster already + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + call print('cluster_protect_X_H_bonds: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + + ! loop over every neighbour, looking for outside neighbours + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + + ! if j is in, or not a nearest neighbour, go on to next + if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_protect_X_H_bonds: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + ! if we're here, j must be an outside neighbour of i + + if (this%Z(i) == 1 .or. this%Z(j) == 1) then + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"X_H_bond " /) ) + cluster_changed = .true. + call print('cluster_protect_X_H_bonds: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + endif + end do ! m + + end do ! while (n <= cluster_info%N) + + call print('cluster_protect_X_H_bonds: Finished checking',PRINT_NERD) + call print("cluster_protect_X_H_bonds: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + end function cluster_protect_X_H_bonds + + !% Go through the cluster atoms and find cut bonds. + !% Include the bonded-to atom in the cluster list. + !% cheap alternative to keep_residues_whole + function cluster_keep_whole_molecules(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + + call print('doing cluster_keep_whole_molecules', PRINT_NERD) + cluster_changed = .false. + + ! loop over each atom in the cluster already + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + call print('cluster_keep_whole_molecules: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) + + ! loop over every neighbour, looking for outside neighbours + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + + ! if j is in, or not a nearest neighbour, go on to next + if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_keep_whole_molecules: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + ! if we're here, j must be an outside neighbour of i + + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"molec " /) ) + cluster_changed = .true. + call print('cluster_keep_whole_molecules: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + end do ! m + + end do ! while (n <= cluster_info%N) + + call print('cluster_keep_whole_molecules: Finished checking',PRINT_NERD) + call print("cluster_keep_whole_molecules: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + end function cluster_keep_whole_molecules + + !if by accident a single atom is included, that is part of a larger entity (not ion) + !then delete it from the list as it will cause error in SCF (e.g. C=O oxygen) + !call allocate(to_delete,4,0,0,0,1) + !do n = 1, cluster%N + ! i = cluster%int(1,n) + ! is_alone = .true. + ! do j = 1, n_neighbours(at,i) + ! k = neighbour(at,i,j) + ! if(find(cluster_info,(/k,shift/)) /= 0) then + ! if(is_nearest_neighbour(at,i,j)) GOTO 120 + ! else + ! if(is_nearest_neighbour(at,i,j)) is_alone = .false. + ! end if + ! end do + ! if(.not. is_alone) call append(to_delete,(/i,shift/)) + ! 120 cycle + !end do + + !do i = 1, to_delete%N + ! call delete(cluster_info,to_delete%int(:,i)) + !end do + +!OUTDATED function cluster_biochem_in_out_in(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) result(cluster_changed) +!OUTDATED type(Atoms), intent(in) :: this +!OUTDATED type(Table), intent(inout) :: cluster_info +!OUTDATED logical, intent(in) :: connectivity_just_from_connect +!OUTDATED type(Connection), intent(in) :: use_connect +!OUTDATED logical, intent(in) :: atom_mask(6) +!OUTDATED logical :: cluster_changed +!OUTDATED +!OUTDATED integer :: n, i, ishift(3), m, j, jshift(3), p, k, kshift(3) +!OUTDATED +!OUTDATED call print('doing cluster_biochem_in_out_in', PRINT_NERD) +!OUTDATED cluster_changed = .false. +!OUTDATED +!OUTDATED ! loop over each atom in the cluster already +!OUTDATED n = 1 +!OUTDATED do while (n <= cluster_info%N) +!OUTDATED i = cluster_info%int(1,n) +!OUTDATED ishift = cluster_info%int(2:4,n) +!OUTDATED call print('cluster_reduce_n_cut_bonds: i = '//i//'. Looping over '//n_neighbours(this,i,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) +!OUTDATED +!OUTDATED ! loop over every neighbour, looking for outside neighbours +!OUTDATED do m=1, n_neighbours(this, i, alt_connect=use_connect) +!OUTDATED j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) +!OUTDATED +!OUTDATED ! if j is in, or not a neareste neighbour, go on to next +!OUTDATED if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle +!OUTDATED if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then +!OUTDATED call print("cluster_reduce_n_cut_bonds: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) +!OUTDATED cycle +!OUTDATED end if +!OUTDATED ! if we're here, j must be an outside neighbour of i +!OUTDATED call print('cluster_reduce_n_cut_bonds: j = '//j//'. Looping over '//n_neighbours(this,j,alt_connect=use_connect)//' neighbours...',PRINT_ANALYSIS) +!OUTDATED +!OUTDATED do p=1, n_neighbours(this, j, alt_connect=use_connect) +!OUTDATED k = neighbour(this, j, p, shift=kshift, alt_connect=use_connect) +!OUTDATED if (k == i .and. all(jshift + kshift == 0)) cycle +!OUTDATED if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,j, p, alt_connect=use_connect))) then +!OUTDATED call print("cluster_reduce_n_cut_bonds: k = "//k//" ["//kshift//"] not nearest neighbour of j = " // j,PRINT_ANALYSIS) +!OUTDATED cycle +!OUTDATED end if +!OUTDATED ! if k is in, then j has 2 in neighbours, and so we add it +!OUTDATED if (find(cluster_info, (/ k, ishift+jshift+kshift, this%Z(k), 0 /), atom_mask ) /= 0) then +!OUTDATED call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"bio_IOI " /) ) +!OUTDATED cluster_changed = .true. +!OUTDATED call print('cluster_biochem_in_out_in: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) +!OUTDATED exit +!OUTDATED end if +!OUTDATED end do ! p +!OUTDATED end do ! m +!OUTDATED +!OUTDATED n = n + 1 +!OUTDATED end do ! while (n <= cluster_info%N) +!OUTDATED +!OUTDATED call print('cluster_biochem_in_out_in: Finished checking',PRINT_NERD) +!OUTDATED call print("cluster_biochem_in_out_in: cluster list:", PRINT_NERD) +!OUTDATED call print(cluster_info, PRINT_NERD) +!OUTDATED end function cluster_biochem_in_out_in + + !% if an in non-H atom is in a residue and not at right coordination, add all of its neighbours + function cluster_protect_double_bonds(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_protect_double_bonds) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical, intent(in) :: present_protect_double_bonds !% if true, protect_double_bonds was specified by user, not just a default value + logical :: cluster_changed + + integer :: n, i, ishift(3), m, j, jshift(3) + integer :: n_nearest_neighbours + integer, pointer :: atom_res_number(:) + + call print('doing cluster_protect_double_bonds', PRINT_NERD) + cluster_changed = .false. + + if (.not. assign_pointer(this, 'atom_res_number', atom_res_number)) then + if (present_protect_double_bonds) then + call print("WARNING: cluster_protect_double_bonds got protect_double_bonds requested explicitly, but no proper atom_res_number property available", PRINT_ALWAYS) + endif + return + endif + + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + + if (this%Z(i) /= 0 .and. atom_res_number(i) >= 0) then + + ! count nearest neighbours of i + n_nearest_neighbours = 0 + do m=1, n_neighbours(this, i, alt_connect=use_connect) + j = neighbour(this, i, m, alt_connect=use_connect) + + ! if j is not nearest neighbour, go on to next one + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_protect_double_bonds: j = "//j//" not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + ! if we're here, j must be an outside neighbour of i + n_nearest_neighbours = n_nearest_neighbours + 1 + end do ! m + + if (ElementValence(this%Z(i)) /= -1 .and. (ElementValence(this%Z(i)) /= n_nearest_neighbours)) then ! i has a valence, and it doesn't match nn# + do m=1, n_neighbours(this, i) + j = neighbour(this, i, m, shift=jshift, alt_connect=use_connect) + + ! if j is in, or isn't nearest neighbour, go on to next + if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask ) /= 0) cycle + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, m, alt_connect=use_connect))) then + call print("cluster_protect_double_bonds: j = "//j//" ["//jshift//"] not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + ! if we're here, j must be an outside neighbour of i + call append(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), (/ this%pos(:,j), 1.0_dp /), (/"dbl_bond " /) ) + cluster_changed = .true. + call print('cluster_protect_double_bonds: Added atom ' //j//' ['//(ishift+jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + end do ! m + endif ! valence defined + end if ! atom_res_number(i) >= 0 + + end do ! while (n <= cluster_info%N) + + call print('cluster_protect_double_bonds: Finished checking',PRINT_NERD) + call print("cluster_protect_double_bonds: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + end function cluster_protect_double_bonds + + !% protect bond between R-C ... -N-R + !% | | + !% O R (usually H or C (proline)) + function cluster_protect_peptide_bonds(this, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, present_protect_peptide_bonds) result(cluster_changed) + type(Atoms), intent(in) :: this !% atoms structure + type(Table), intent(inout) :: cluster_info !% table of cluster info, modified if necessary on output + logical, intent(in) :: connectivity_just_from_connect !% if true, we're doing hysterestic connect and should rely on the connection object completely + type(Connection), intent(in) :: use_connect !% connection object to use for connectivity info + logical, intent(in) :: atom_mask(6) !% which fields in int part of table to compare when checking for identical atoms + logical, intent(in) :: present_protect_peptide_bonds !% if true, protect_peptide_bonds was specified by user, not just a default value + logical :: cluster_changed + + integer :: n, i, ishift(3), ji, j, ki, k, jshift(3) + integer, pointer :: atom_res_number(:) + integer :: found_other_j, found_other_jshift(3) + integer :: this_neighbour_Z, other_neighbour_Z, other_Z + logical :: found_this_neighbour, found_other_neighbour + + call print('doing cluster_protect_peptide_bonds', PRINT_NERD) + cluster_changed = .false. + + if (.not. assign_pointer(this, 'atom_res_number', atom_res_number)) then + if (present_protect_peptide_bonds) then + call print("WARNING: cluster_protect_peptide_bonds got protect_peptide_bonds requested explicitly, but no proper atom_res_number property available", PRINT_ALWAYS) + endif + return + endif + + n = 0 + do while (n < cluster_info%N) + n = n + 1 + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + + if (this%Z(i) /= 0 .and. atom_res_number(i) >= 0) then + + call print("cluster_protect_peptide_bonds: i = "//i//" Z(i) " // this%Z(i), PRINT_ANALYSIS) + + ! peptide bond is C-N + ! | + ! O + if (this%Z(i) == 6) then + other_Z = 7 + this_neighbour_Z = 8 + other_neighbour_Z = 0 + else if (this%Z(i) == 7) then + other_Z = 6 + this_neighbour_Z = 0 + other_neighbour_Z = 8 + else + call print("cluster_protect_peptide_bonds: i = "//i//" not C or N",PRINT_ANALYSIS) + cycle + endif + + found_other_j = 0 + found_this_neighbour = (this_neighbour_Z == 0) + found_other_neighbour = (other_neighbour_Z == 0) + + call print("cluster_protect_peptide_bonds: other_Z " // other_Z // " this_neighbour_Z " // this_neighbour_Z // " other_neighbour_z " // other_neighbour_Z, PRINT_ANALYSIS) + call print("cluster_protect_peptide_bonds: found_this_neighbour " // found_this_neighbour // " found_other_neighbour " // found_other_neighbour, PRINT_ANALYSIS) + + ! must have 3 neighbours + if (n_neighbours(this, i, alt_connect=use_connect) /= 3) then + call print("cluster_protect_peptide_bonds: i = "//i//" doesn't have 3 neighbours",PRINT_ANALYSIS) + cycle + endif + do ji=1, n_neighbours(this, i, alt_connect=use_connect) ! look for correct neighbour + j=neighbour(this, i, ji, shift=jshift, alt_connect=use_connect) + call print("cluster_protect_peptide_bonds: j = " //j//" Z(j) " // this%Z(j), PRINT_ANALYSIS) + ! only nearest neighbours count, usually + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,i, ji, alt_connect=use_connect))) then + call print("cluster_protect_peptide_bonds: neighbour j = "//j//" not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + if (this%Z(j) == this_neighbour_Z .and. n_neighbours(this, j) == 1) then ! neighbour has right Z and coordination + found_this_neighbour = .true. + call print("cluster_protect_peptide_bonds: neighbour j = "//j//" is neighbor (O) we're looking for",PRINT_ANALYSIS) + endif + if (this%Z(j) == other_Z) then ! found other + ! if j is already in, this isn't a peptide bond in need of protection from being cut + if (find(cluster_info, (/ j, ishift+jshift, this%Z(j), 0 /), atom_mask) /= 0) then + call print("cluster_protect_peptide_bonds: other_Z neighbour j = "//j//" already in",PRINT_ANALYSIS) + cycle + endif + ! save info on other + call print("cluster_protect_peptide_bonds: found_other_j " // j // " Z(found_other_j) " // this%Z(j), PRINT_ANALYSIS) + found_other_j = j + found_other_jshift = jshift + + ! if (.not. found_this_neighbour .or. found_other_j == 0) then ! some part of motif missing + ! call print("cluster_protect_peptide_bonds: failed to find this_neighbour_Z or other_j",PRINT_ANALYSIS) + ! cycle + ! endif + + ! other must have 3 neighbours + if (n_neighbours(this, found_other_j, alt_connect=use_connect) /= 3) then + call print("cluster_protect_peptide_bonds: found_other_j = "//found_other_j//" doesn't have 3 neighbours", PRINT_ANALYSIS) + cycle + endif + ! perhaps we should require that other be in a different residue, but not doing that now + ! if (atoms_res_number(i) == atom_res_number(found_other_j)) then + ! call print("cluster_protect_peptide_bonds: i and found_other_j are in the same residue", PRINT_ANALYSIS) + ! cycle + ! endif + + ! check neighbours of other + do ki=1, n_neighbours(this, found_other_j, alt_connect=use_connect) + k=neighbour(this, found_other_j, ki, alt_connect=use_connect) + ! only nearest neighbours count + if(.not. (connectivity_just_from_connect .or. is_nearest_neighbour(this,found_other_j, ki, alt_connect=use_connect))) then + call print("cluster_protect_peptide_bonds: found_other_j's neighbour k = "//k//" not nearest neighbour",PRINT_ANALYSIS) + cycle + end if + + if (this%Z(k) == other_neighbour_Z .and. n_neighbours(this, k) == 1) then ! neighbour has right Z and coordination + found_other_neighbour = .true. + call print("cluster_protect_peptide_bonds: neighbour k = "//k//" is neighbor (O) we're looking for",PRINT_ANALYSIS) + endif + end do ! ki + + ! some part of motif is missing + if (.not. found_other_neighbour) then + call print("cluster_protect_peptide_bonds: couldn't find other_neighbour",PRINT_ANALYSIS) + cycle + endif + + call append(cluster_info, (/ found_other_j, ishift+found_other_jshift, this%Z(found_other_j), 0 /), & + (/ this%pos(:,found_other_j), 1.0_dp /), (/"pep_bond " /) ) + cluster_changed = .true. + call print('cluster_protect_peptide_bonds: Added atom ' //found_other_j//' ['//(ishift+found_other_jshift)//'] to cluster. Atoms = ' // cluster_info%N, PRINT_NERD) + endif ! Z(j) == other_Z + end do ! ji + + end if ! Z(i) /= 0 .and. atom_res_number(i) /= 0 + + end do ! while (n <= cluster_info%N) + + call print('cluster_protect_peptide_bonds: Finished checking',PRINT_NERD) + call print("cluster_protect_peptide_bonds: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + end function cluster_protect_peptide_bonds + + subroutine create_cluster_simple(at, args_str, cluster, mark_name, error) + type(Atoms), intent(inout) :: at + character(len=*), intent(in) :: args_str + type(Atoms), intent(out) :: cluster + character(len=*), intent(in), optional :: mark_name + integer, intent(out), optional :: ERROR + + type(Table) :: cluster_info + + INIT_ERROR(error) + + call calc_connect(at) + cluster_info = create_cluster_info_from_mark(at, args_str, mark_name=mark_name, error=error) + PASS_ERROR(error) + call carve_cluster(at, args_str, cluster_info, cluster=cluster, mark_name=mark_name, error=error) + PASS_ERROR(error) + call finalise(cluster_info) + + end subroutine create_cluster_simple + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Create cluster from atoms and cluster information table (which + !% which should be generated by a call to :func:`create_cluster_info_from_hybrid_mark`. + !% + !% The output cluster contains all properties of the initial atoms object, and + !% some additional columns, which are: + !% + !% ``index`` + !% index of the cluster atoms into the initial atoms object. + !% + !% ``termindex`` + !% nonzero for termination atoms, and is an index into + !% the cluster atoms specifiying which atom is being terminated, + !% it is used in collecting the forces. + !% + !% ``rescale`` + !% a real number which for nontermination atoms is 1.0, + !% for termination atoms records the scaling applied to + !% termination bond lengths + !% + !% ``shift`` + !% the shift of each atom + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + subroutine carve_cluster(at, args_str, cluster_info, cluster, mark_name, error) + type(Atoms), intent(in), target :: at + character(len=*), intent(in) :: args_str + type(Table), intent(in) :: cluster_info + type(Atoms), intent(out) :: cluster + character(len=*), optional, intent(in) :: mark_name + integer, optional, intent(out) :: error + + type(Dictionary) :: params + logical :: do_rescale_r + real(dp) :: r_scale, cluster_vacuum, cluster_fix_lattice(3), cluster_round_lattice + logical :: terminate, randomise_buffer, print_clusters, do_calc_connect, do_same_lattice, do_fix_lattice + logical :: hysteretic_connect + integer :: i, j, k, m + real(dp) :: maxlen(3), sep(3), lat_maxlen(3), lat_sep(3) + logical :: do_periodic(3) + integer, pointer :: hybrid_mark(:), cluster_index(:), cluster_hybrid_mark(:), cluster_shift(:,:) + type(CInoutput) :: clusterfile + character(len=255) :: clusterfilename + character(len=255) :: my_mark_name + character(STRING_LENGTH) :: run_suffix + type(Table) :: outer_layer + logical :: in_outer_layer, do_map_into_cell + +#ifdef _MPI + integer::mpi_size, mpi_rank, PRINT_ALWAYS + integer :: mpi_force_size + real(dp), allocatable, dimension(:) :: mpi_force + + call get_mpi_size_rank(MPI_COMM_WORLD, mpi_size, mpi_rank) +#endif /* _MPI */ + + INIT_ERROR(error) + + call print('carve_cluster got args_str "'//trim(args_str)//'"', PRINT_VERBOSE) + + call initialise(params) + call param_register(params, 'terminate', 'T', terminate,& + help_string="do hydrogen termination") + call param_register(params, 'do_rescale_r', 'F', do_rescale_r,& + help_string="do rescale cluster lattice positions and lattice (for matching lattice constants of different models") + call param_register(params, 'r_scale', '1.0', r_scale,& + help_string="cluster position/lattice rescaling factor") + call param_register(params, 'randomise_buffer', 'T', randomise_buffer,& + help_string="randomly perturb positions of buffer atoms") + call param_register(params, 'print_clusters', 'F', print_clusters,& + help_string="Print out clusters into clusters.xyz file (clusters.MPI_RANK.xyz if in MPI)") + call param_register(params, 'cluster_calc_connect', 'F', do_calc_connect,& + help_string="run calc_connect before doing stuff (passivation, etc)") + call param_register(params, 'cluster_same_lattice', 'F', do_same_lattice,& + help_string="Don't modify cluster cell vectors from incoming cell vectors") + call param_register(params, 'cluster_fix_lattice', '0. 0. 0.', cluster_fix_lattice, & + has_value_target=do_fix_lattice, & + help_string="fix the cluster lattice to be cubic with given 3 lengths. useful with DFT codes where one doesn't pay for vacuum.") + call param_register(params, 'cluster_round_lattice', '3.0', cluster_round_lattice, & + help_string="distance to which to round cluster lattice (default is 3.0 A)") + call param_register(params, 'cluster_periodic_x', 'F', do_periodic(1),& + help_string="do not add vaccum along x, so as to make cluster's cell vectors periodic") + call param_register(params, 'cluster_periodic_y', 'F', do_periodic(2),& + help_string="do not add vaccum along x, so as to make cluster's cell vectors periodic") + call param_register(params, 'cluster_periodic_z', 'F', do_periodic(3),& + help_string="do not add vaccum along x, so as to make cluster's cell vectors periodic") + call param_register(params, 'cluster_vacuum', '10.0', cluster_vacuum,& + help_string="Amount of vacuum to add around cluster (minimum - lattice vectors are rounded up to integers)") + call param_register(params, 'hysteretic_connect', 'F', hysteretic_connect,& + help_string="Use hysteretic connection object for identifying bonds") + call param_register(params, 'map_into_cell', 'T', do_map_into_cell,& + help_string="Call map_into_cell (lattice coordinates=[-0.5,0.5)) on cluster") + call param_register(params, 'run_suffix', '', run_suffix, & + help_string="string to append to names of extra properties added to cluster. NOTE: does not override mark_name argument") + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='carve_cluster arg_str') ) then + RAISE_ERROR("carve_cluster failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + ! first pick up an atoms structure with the right number of atoms and copy the properties + !Now turn the cluster_temp table into an atoms structure + call print('carve_cluster: Copying atomic data to output object',PRINT_NERD) + call print('List of atoms in cluster:', PRINT_NERD) + call print(int_part(cluster_info,1), PRINT_NERD) + + call select(cluster, at, list=int_part(cluster_info,1), error=error) + PASS_ERROR(error) + ! then reset the positions species and Z (latter two needed because termination atoms have Z=1) + ! unfold the positions to real positions using the stored shifts, at is neede because + ! next we might make the unit cell much smaller + do i=1,cluster_info%N + cluster%pos(:,i) = cluster_info%real(1:3, i)+(at%lattice .mult. cluster_info%int(2:4, i)) + cluster%Z(i) = cluster_info%int(5,i) + cluster%species(:,i) = ' ' + cluster%species(1:3,i) = s2a(ElementName(cluster_info%int(5,i))) + end do + ! add properties to cluster + call add_property(cluster, 'index'//trim(run_suffix), int_part(cluster_info,1)) + call add_property(cluster, 'shift'//trim(run_suffix), 0, n_cols=3, ptr2=cluster_shift) + cluster_shift(:,1:cluster%N) = cluster_info%int(2:4,1:cluster_info%N) + call add_property(cluster, 'termindex'//trim(run_suffix), int_part(cluster_info,6)) + call add_property(cluster, 'rescale'//trim(run_suffix), real_part(cluster_info,4)) + call add_property(cluster, 'cluster_ident'//trim(run_suffix), cluster_info%str(1,1:cluster_info%N)) + + ! Find smallest bounding box for cluster + ! Find boxes aligned with xyz (maxlen) and with a1 a2 a3 (lat_maxlen) + maxlen = 0.0_dp + lat_maxlen = 0.0_dp + do i=1,cluster%N + do j=1,cluster%N + sep = cluster%pos(:,i)-cluster%pos(:,j) + lat_sep = cluster%g .mult. sep + do k=1,3 + if (abs(sep(k)) > maxlen(k)) maxlen(k) = abs(sep(k)) + if (abs(lat_sep(k)) > lat_maxlen(k)) lat_maxlen(k) = abs(lat_sep(k)) + end do + end do + end do + + ! renormalize lat_maxlen to real dist units + do k=1,3 + lat_maxlen(k) = lat_maxlen(k) * norm(cluster%lattice(:,k)) + end do + + ! Round up maxlen to be divisible by cluster_round_lattice (default 3 A), so that it does not fluctuate too much + forall (k=1:3) maxlen(k) = cluster_round_lattice*ceiling(maxlen(k)/cluster_round_lattice) + forall (k=1:3) lat_maxlen(k) = cluster_round_lattice*ceiling(lat_maxlen(k)/cluster_round_lattice) + + ! vacuum pad cluster (if didn't set do_same_lattice or cluster_fix_lattice) + ! if not periodic at all, just do vacuum padding + ! if cluster_fix_lattice was given, just set the diagonal lattice elements to those values + ! if periodic along some dir, keep supercell vector directions, and set + ! extent in each direction to lesser of cluster extent + vacuum or original extent + if (do_same_lattice) then + cluster%lattice = at%lattice + else if (do_fix_lattice) then + cluster%lattice = 0.0_dp + do k=1,3 + cluster%lattice(k,k) = cluster_fix_lattice(k) + end do + else + if (any(do_periodic)) then + do k=1,3 + if (do_periodic(k)) then + if (lat_maxlen(k)+cluster_vacuum >= norm(at%lattice(:,k))) then + cluster%lattice(:,k) = at%lattice(:,k) + else + cluster%lattice(:,k) = (lat_maxlen(k)+cluster_vacuum)*at%lattice(:,k)/norm(at%lattice(:,k)) + endif + else + cluster%lattice(:,k) = (lat_maxlen(k)+cluster_vacuum)*at%lattice(:,k)/norm(at%lattice(:,k)) + endif + end do + else + cluster%lattice = 0.0_dp + do k=1,3 + cluster%lattice(k,k) = maxlen(k) + cluster_vacuum + end do + endif + endif + + call set_lattice(cluster, cluster%lattice, scale_positions=.false.) + + ! Remap positions so any image atoms end up inside the cell + if (do_map_into_cell) then + call map_into_cell(cluster) + end if + + call print ('carve_cluster: carved cluster with '//cluster%N//' atoms', PRINT_VERBOSE) + + write (line, '(a,f10.3,f10.3,f10.3)') & + 'carve_cluster: Cluster dimensions are ', cluster%lattice(1,1), & + cluster%lattice(2,2), cluster%lattice(3,3) + call print(line, PRINT_VERBOSE) + + my_mark_name = optional_default('hybrid_mark', mark_name) + ! reassign pointers + if (.not. assign_pointer(at, trim(my_mark_name), hybrid_mark)) then + RAISE_ERROR('cannot reassign "'//trim(my_mark_name)//'" property', error) + endif + + ! rescale cluster positions and lattice + if (do_rescale_r) then + call print('carve_cluster: rescaling cluster positions (and lattice if not fixed) by factor '//r_scale, PRINT_VERBOSE) + cluster%pos = r_scale * cluster%pos + if (.not. do_fix_lattice) then + call set_lattice(cluster, r_scale * cluster%lattice, scale_positions=.false.) + end if + end if + + if (randomise_buffer .and. .not. any(hybrid_mark == HYBRID_BUFFER_OUTER_LAYER_MARK)) & + do_calc_connect = .true. + + if (do_calc_connect) then + call print('carve_cluster: doing calc_connect', PRINT_VERBOSE) + ! Does QM force model need connectivity information? + call set_cutoff(cluster, at%cutoff) + call calc_connect(cluster) + end if + + if (randomise_buffer) then + ! If outer buffer layer is not marked do so now. This will be + ! the case if we're using hysteretic_buffer selection option. + ! In this case we consider any atoms connected to terminating + ! hydrogens to be in the outer layer - obviously this breaks down + ! if we're not terminating so we abort if that's the case. + if (.not. assign_pointer(cluster, 'index', cluster_index)) then + RAISE_ERROR('carve_cluster: cluster is missing index property', error) + endif + + if (.not. any(hybrid_mark == HYBRID_BUFFER_OUTER_LAYER_MARK)) then + if (.not. terminate) then + RAISE_ERROR('cannot determine which buffer atoms to randomise if terminate=F and hysteretic_buffer=T', error) + endif + + if (.not. assign_pointer(cluster, trim(my_mark_name), cluster_hybrid_mark)) then + RAISE_ERROR(trim(my_mark_name)//' property not found in cluster', error) + endif + + do i=1,cluster%N + if (hybrid_mark(cluster_info%int(1,i)) /= HYBRID_BUFFER_MARK) cycle + in_outer_layer = .false. + do m = 1, cluster_info%N + if (cluster_info%int(6,m).eq. i) then + in_outer_layer = .true. + exit + end if + enddo + if (in_outer_layer) then + hybrid_mark(cluster_info%int(1,i)) = HYBRID_BUFFER_OUTER_LAYER_MARK + cluster_hybrid_mark(i) = HYBRID_BUFFER_OUTER_LAYER_MARK + end if + end do + end if + + if (any(hybrid_mark == HYBRID_BUFFER_OUTER_LAYER_MARK)) then + ! Slightly randomise the positions of the outermost layer + ! of the buffer region in order to avoid systematic errors + ! in QM forces. + + call initialise(outer_layer, 1,0,0,0) + call append(outer_layer, find(hybrid_mark == HYBRID_BUFFER_OUTER_LAYER_MARK)) + + do i=1,outer_layer%N + ! Shift atom by randomly distributed vector of magnitude 0.05 A + j = find_in_array(cluster_index, outer_layer%int(1,i)) + cluster%pos(:,j) = cluster%pos(:,j) + 0.05_dp*random_unit_vector() + end do + + call finalise(outer_layer) + end if + + end if + + if (value(mainlog%verbosity_stack) >= PRINT_VERBOSE .or. print_clusters) then +#ifdef _MPI + write (clusterfilename, '(a,i3.3,a)') 'clusters.',mpi_rank,'.xyz' +#else + clusterfilename = 'clusters.xyz' +#endif /* _MPI */ + call initialise(clusterfile, clusterfilename, append=.true., action=OUTPUT) + call write(clusterfile, cluster) + call finalise(clusterfile) + end if + + end subroutine carve_cluster + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Create a cluster using the mark_name (optional arg, default 'hybrid_mark') + !% property and options in 'args_str'. + !% All atoms that are marked with anything other than 'HYBRID_NO_MARK' will + !% be included in the cluster; this includes active, transition and buffer + !% atoms. Atoms added (to satisfy heuristics) will be marked in new property + !% modified_//trim(mark_name) as 'HYBRID_BUFFER_MARK'. + !% Returns a Table object (cluster_info) which contains info on atoms whose + !% indices are given in atomlist, possibly with some extras for consistency, + !% and optionally terminated with Hydrogens, that can be used by carve_cluster(). + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function create_cluster_info_from_mark(at, args_str, cut_bonds, mark_name, error) result(cluster_info) + type(Atoms), intent(inout), target :: at + character(len=*), intent(in) :: args_str + type(Table), optional, intent(out) :: cut_bonds !% Return a list of the bonds cut when making + !% the cluster. See create_cluster() documentation. + character(len=*), intent(in), optional :: mark_name + integer, optional, intent(out) :: error + type(Table) :: cluster_info + + type(Dictionary) :: params + logical :: terminate, periodic_x, periodic_y, periodic_z, & + even_electrons, do_periodic(3), cluster_hopping_nneighb_only, cluster_heuristics_nneighb_only, & + cluster_allow_modification, hysteretic_connect, same_lattice, & + fix_termination_clash, keep_whole_residues, keep_whole_subgroups, keep_whole_prolines, keep_whole_proline_sidechains, & + keep_whole_silica_tetrahedra, keep_whole_titania_octahedra, terminate_octahedra,reduce_n_cut_bonds, in_out_in, & + protect_X_H_bonds, protect_double_bonds, protect_peptide_bonds, keep_whole_molecules, has_termination_rescale, & + combined_protein_heuristics, force_no_fix_termination_clash + character(STRING_LENGTH) :: in_out_in_mode + logical :: keep_whole_residues_has_value, keep_whole_subgroups_has_value, keep_whole_prolines_has_value, keep_whole_proline_sidechains_has_value, & + protect_double_bonds_has_value, protect_peptide_bonds_has_value, keep_whole_molecules_has_value + real(dp) :: r, r_min, centre(3), termination_rescale, termination_clash_factor + type(Table) :: cluster_list, currentlist, nextlist, activelist, bufferlist + integer :: i, j, jj, first_active, old_n, n_cluster + integer, pointer :: hybrid_mark(:), modified_hybrid_mark(:) + integer :: prev_cluster_info_n + integer, allocatable, dimension(:) :: uniqed, tmp_index + + type(Table) :: n_term, in_n_term, sorted_n_term + integer :: m, n, p, p_in, in_n + + real(dp) :: H1(3) + real(dp) :: dhat_ij(3), d(3) + real(dp) :: r_ij, rescale + real(dp) :: orig_length + real(dp), dimension(3) :: bond1, bond2, new_bond + integer :: ishift(3), jshift(3), oldN, most_hydrogens + logical :: atom_mask(6) + integer, allocatable, dimension(:) :: idx + + type(Connection), pointer :: use_connect + logical :: connectivity_just_from_connect + logical :: cluster_changed, cluster_hopping + character(len=STRING_LENGTH) :: my_mark_name + + INIT_ERROR(error) + + my_mark_name = optional_default('hybrid_mark', mark_name) + + call print('create_cluster_info_from_mark got args_str "'//trim(args_str)//'"', PRINT_VERBOSE) + + call initialise(params) + call param_register(params, 'terminate', 'T', terminate, & + help_string="Do hydrogen termination for dangling bonds") + call param_register(params, 'cluster_periodic_x', 'F', periodic_x,& + help_string="do not add vaccum along x, so as to make cluster's cell vectors periodic") + call param_register(params, 'cluster_periodic_y', 'F', periodic_y,& + help_string="do not add vaccum along y, so as to make cluster's cell vectors periodic") + call param_register(params, 'cluster_periodic_z', 'F', periodic_z,& + help_string="do not add vaccum along z, so as to make cluster's cell vectors periodic") + call param_register(params, 'even_electrons', 'F', even_electrons,& + help_string="Remove passivation hydrogen to keep total number of electrons even") + call param_register(params, 'cluster_hopping_nneighb_only', 'T', cluster_hopping_nneighb_only,& + help_string="Apply is_nearest_neighbor test to bonds when doing bond hops to find cluster. If false, uses connectivity object as is") + call param_register(params, 'cluster_heuristics_nneighb_only', 'T', cluster_heuristics_nneighb_only,& + help_string="Apply is_nearest_neighbor test to bonds when deciding what's bonded for heuristics. If false, uses connectivity object as is") + call param_register(params, 'cluster_allow_modification', 'T', cluster_allow_modification,& + help_string="Allow cluster to be modified using various heuristics") + call param_register(params, 'hysteretic_connect', 'F', hysteretic_connect,& + help_string="Use hysteretic connect object to decide what's bonded. Usually goes with cluster_*_nneighb_only=F.") + call param_register(params, 'cluster_same_lattice', 'F', same_lattice,& + help_string="Don't modify cluster cell vectors from incoming cell vectors") + call param_register(params, 'fix_termination_clash','T', fix_termination_clash,& + help_string="Apply termination clash (terimnation H too close together) heureistic") + call param_register(params, 'force_no_fix_termination_clash','F', force_no_fix_termination_clash,& + help_string="Overrides values of (terminate .or. termination_clash) to explicitly disable termination clash heuristic") + call param_register(params, 'combined_protein_heuristics','F', combined_protein_heuristics, & + help_string="Apply heuristics for proteins: overrides keep_whole_molecules=F, keep_whole_residues=F, keep_whole_subgroups=T, keep_whole_prolines=T, keep_whole_proline_sidechains=F, protect_double_bonds=F, protect_peptide_bonds=T") + call param_register(params, 'keep_whole_residues','T', keep_whole_residues, has_value_target=keep_whole_residues_has_value,& + help_string="Apply heuristic keeping identified residues whole") + call param_register(params, 'keep_whole_prolines','F', keep_whole_prolines, has_value_target=keep_whole_prolines_has_value,& + help_string="Apply heuristic keeping identified prolines whole") + call param_register(params, 'keep_whole_proline_sidechains','F', keep_whole_proline_sidechains, has_value_target=keep_whole_proline_sidechains_has_value,& + help_string="Apply heuristic keeping identified prolines sidechain+directly connected backbone part whole") + call param_register(params, 'keep_whole_subgroups','F', keep_whole_subgroups, has_value_target=keep_whole_subgroups_has_value,& + help_string="Apply heuristic keeping identified subgroups within a residue whole") + call param_register(params, 'keep_whole_silica_tetrahedra','F', keep_whole_silica_tetrahedra,& + help_string="Apply heureistic keeping SiO2 tetrahedra whole") + call param_register(params, 'keep_whole_titania_octahedra','F', keep_whole_titania_octahedra,& + help_string="Apply heureistic keeping TiO2 tetragonal structure whole") + call param_register(params, 'terminate_octahedra','F', terminate_octahedra,& + help_string="Apply heureistic terminating TiO2 octahedra") + call param_register(params, 'reduce_n_cut_bonds','T', reduce_n_cut_bonds,& + help_string="Apply heuristic that adds atoms if doing so reduces number of broken bonds") + call param_register(params, 'in_out_in', 'F', in_out_in, & + help_string="Apply heuristic than adds atoms to avoid IN-OUT-IN configurations. Usually equivalent to reduce_n_cut_bonds.") + call param_register(params, 'in_out_in_mode', 'all', in_out_in_mode, & + help_string="Mode to use for in_out_in heuristic - can be either 'all' or 'any'. Default is 'all'.") + call param_register(params, 'protect_X_H_bonds','T', protect_X_H_bonds,& + help_string="Apply heuristic protecting X-H bonds - no point H passivating bonds with an H") + call param_register(params, 'protect_double_bonds','T', protect_double_bonds, has_value_target=protect_double_bonds_has_value,& + help_string="Apply heuristic protecting double bonds from being cut (based one some heuristic idea of what's a double bond") + call param_register(params, 'protect_peptide_bonds','F', protect_peptide_bonds, has_value_target=protect_peptide_bonds_has_value,& + help_string="Apply heuristic protecting peptide bonds from being cut (RO-C...N-RR)") + call param_register(params, 'keep_whole_molecules','F', keep_whole_molecules, has_value_target=keep_whole_molecules_has_value, & + help_string="Apply heuristic keeping identified molecules (i.e. contiguous bonded groups of atoms) whole") + call param_register(params, 'termination_rescale', '0.0', termination_rescale, has_value_target=has_termination_rescale,& + help_string="rescale factor for X-H passivation bonds") + call param_register(params, 'termination_clash_factor', '1.2', termination_clash_factor, & + help_string="Factor to multiply H-H bond-length by when deciding if two Hs are too close. Default 1.2") + call param_register(params, 'cluster_hopping', 'T', cluster_hopping,& + help_string="Identify cluster region by hopping from a seed atom. Needed so that shifts will be correct.") + + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='create_cluster_info_from_mark args_str') ) then + RAISE_ERROR("create_cluster_info_from_mark failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + if (combined_protein_heuristics) then + if (keep_whole_molecules_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_molecules") + if (keep_whole_residues_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_residues") + if (keep_whole_subgroups_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_subgroups") + if (keep_whole_prolines_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_prolines") + if (keep_whole_proline_sidechains_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding keep_whole_proline_sidechains") + if (protect_double_bonds_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding protect_double_bonds_has_value") + if (protect_peptide_bonds_has_value) call print("WARNING: create_cluster_info_from_mark got combined_protein_heuristics, overriding protect_peptide_bonds_has_value") + keep_whole_molecules = .false. + keep_whole_molecules_has_value = .true. + keep_whole_residues = .false. + keep_whole_residues_has_value = .true. + keep_whole_subgroups = .true. + keep_whole_subgroups_has_value = .true. + keep_whole_prolines = .true. + keep_whole_prolines_has_value = .true. + keep_whole_proline_sidechains = .true. + keep_whole_proline_sidechains_has_value = .true. + protect_double_bonds = .false. + protect_peptide_bonds = .true. + protect_peptide_bonds_has_value = .true. + endif + + do_periodic = (/periodic_x,periodic_y,periodic_z/) + + if (.not. has_property(at, trim(my_mark_name))) then + RAISE_ERROR('create_cluster_info_from_mark: atoms structure has no "'//trim(my_mark_name)//'" property', error) + endif + + call assign_property_pointer(at, trim(my_mark_name), hybrid_mark, error=error) + PASS_ERROR_WITH_INFO('create_cluster_info_from_mark passed atoms structure with no hybrid_mark property', error) + + ! Calculate centre of cluster + call allocate(cluster_list, 1,0,0,0) + call append(cluster_list, find(hybrid_mark /= HYBRID_NO_MARK)) + ! unreliable when cluster extends across periodic boundaries + ! centre = 0.0_dp + ! do i=1,cluster_list%N + ! centre = centre + at%pos(:,cluster_list%int(1,i)) + (at%lattice .mult. cluster_list%int(2:4,i)) + ! end do + ! centre = centre / cluster_list%N + centre = at%pos(:,cluster_list%int(1,1)) +!!$ call print('centre = '//centre) + + ! Find ACTIVE atom closest to centre of cluster, using min image convention + r_min = huge(1.0_dp) + do i=1,cluster_list%N + if (hybrid_mark(cluster_list%int(1,i)) /= HYBRID_ACTIVE_MARK) cycle + r = distance_min_image(at, centre, cluster_list%int(1,i)) +!!$ call print(cluster_list%int(1,i)//' '//r) + if (r < r_min) then + first_active = cluster_list%int(1,i) + r_min = r + end if + end do + + if (cluster_hopping) then + call system_timer('cluster_hopping') + + n_cluster = cluster_list%N + call wipe(cluster_list) + call allocate(cluster_list, 4,0,0,0) + + ! Add first marked atom to cluster_list. shifts will be relative to this atom + call print('Growing cluster starting from atom '//first_active//', n_cluster='//n_cluster, PRINT_VERBOSE) + call append(cluster_list, (/first_active,0,0,0/)) + call append(currentlist, cluster_list) + + ! Add other active atoms using bond hopping from the central cluster atom + ! to find the other cluster atoms and hence to determine the correct + ! periodic shifts. + ! + ! This will fail if marked atoms do not form a single connected cluster + old_n = cluster_list%N + do + call wipe(nextlist) + if (hysteretic_connect) then + call BFS_step(at, currentlist, nextlist, nneighb_only=cluster_hopping_nneighb_only, & + min_images_only = any(do_periodic) .or. same_lattice , alt_connect=at%hysteretic_connect) + else + call BFS_step(at, currentlist, nextlist, nneighb_only=cluster_hopping_nneighb_only, & + min_images_only = any(do_periodic) .or. same_lattice) + endif + do j=1,nextlist%N + jj = nextlist%int(1,j) + ! shift = nextlist%int(2:4,j) + if (hybrid_mark(jj) /= HYBRID_NO_MARK .and. find(cluster_list, nextlist%int(:,j)) == 0) & + call append(cluster_list, nextlist%int(:,j)) + end do + call append(currentlist, nextlist) + + ! check exit condition + allocate(tmp_index(cluster_list%N)) + tmp_index = int_part(cluster_list,1) + call sort_array(tmp_index) + call uniq(tmp_index, uniqed) + call print('cluster hopping: got '//cluster_list%N//' atoms, of which '//size(uniqed)//' are unique.', PRINT_VERBOSE) + if (size(uniqed) == n_cluster) exit !got them all + deallocate(uniqed, tmp_index) + + ! check that cluster is still growing + if (cluster_list%N == old_n) then + call write(at, 'create_cluster_abort.xyz') + call print(cluster_list) + RAISE_ERROR('create_cluster_info_from_mark: cluster stopped growing before all marked atoms found - check for split QM region', error) + end if + old_n = cluster_list%N + end do + deallocate(tmp_index, uniqed) + call finalise(nextlist) + call finalise(currentlist) + call system_timer('cluster_hopping') + else + call system_timer('cluster_diff_min_image') + call allocate(cluster_list, 4,0,0,0) + + call append(cluster_list, (/first_active,0,0,0/)) + do i=1, at%n + if (hybrid_mark(i) == HYBRID_NO_MARK .or. i == first_active) cycle + ! shifts relative to first_active + d = distance_min_image(at, first_active, i, shift=ishift) + call append(cluster_list, (/i,ishift/)) + end do + call system_timer('cluster_diff_min_image') + end if + ! partition cluster_list so that active atoms come first + call wipe(activelist) + call wipe(bufferlist) + do i=1,cluster_list%N + if (hybrid_mark(cluster_list%int(1,i)) == HYBRID_ACTIVE_MARK) then + call append(activelist, cluster_list%int(:,i)) + else + call append(bufferlist, cluster_list%int(:,i)) + end if + end do + + call wipe(cluster_list) + call append(cluster_list, activelist) + call append(cluster_list, bufferlist) + call finalise(activelist) + call finalise(bufferlist) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! + ! Validate arguments + ! + + ! check for consistency in optional arguments + + if (.not. (count(do_periodic) == 0 .or. count(do_periodic) == 1 .or. count(do_periodic) == 3)) then + RAISE_ERROR('count(periodic) must be zero, one or three.', error) + endif + + if (same_lattice) do_periodic = .true. + + if (any(do_periodic) .and. multiple_images(cluster_list)) then + RAISE_ERROR("create_cluster: can't make a periodic cluster since cluster_list contains repeats", error) + endif + + ! check for empty list + + if(cluster_list%N == 0) then + call print('create_cluster: empty cluster_list', PRINT_NORMAL) + return + end if + + call print('create_cluster: Entering create_cluster', PRINT_NERD) + + if(.not.(cluster_list%intsize == 1 .or. cluster_list%intsize == 4) .or. cluster_list%realsize /= 0) then + RAISE_ERROR("create_cluster: cluster_list table must have intsize=1 or 4 and realsize=0.", error) + endif + + + ! Cluster_info is extensible storage for the cluster + ! It stores atomic indices and shifts (4 ints) + ! atomic number (1 int) + ! termination index (1 int): for termination atoms, which atom is being terminated? + ! and atomic positions (3 reals) + ! It's length will be at least cluster_list%N + + call print('create_cluster: Creating temporary cluster table', PRINT_NERD) + call allocate(cluster_info,6,4,1,0,cluster_list%N) + + ! First, put all the marked atoms into cluster_info, storing their positions and shifts + call print('create_cluster: Adding specified atoms to the cluster', PRINT_NERD) + do i = 1, cluster_list%N + if(cluster_list%intsize == 4) then + ! we have shifts + ishift = cluster_list%int(2:4,i) + else + ! no incoming shifts + ishift = (/0,0,0/) + end if + call append(cluster_info, (/cluster_list%int(1,i),ishift,at%Z(cluster_list%int(1,i)),0/),& + (/at%pos(:,cluster_list%int(1,i)),1.0_dp/), (/ hybrid_mark_name(hybrid_mark(cluster_list%int(1,i))) /) ) + end do + + call print("create_cluster: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + + call system_timer('cluster_consistency') + ! Next, check for various gotchas + + ! at mask is used to match with atoms already in the cluster_info table + ! if we are periodic in a direction, we don't care about the shifts in that direction when matching + atom_mask = (/.true.,.not.do_periodic, .true., .true./) + + connectivity_just_from_connect = .not. cluster_heuristics_nneighb_only + if (hysteretic_connect) then + use_connect => at%hysteretic_connect + ! will also pass true for connectivity_just_from_connect to cluster_...() routines, so that + ! is_nearest_neighbour() won't be used + connectivity_just_from_connect = .true. + else + use_connect => at%connect + endif + + if (cluster_allow_modification) then + call add_property(at, 'modified_'//trim(my_mark_name), 0, ptr=modified_hybrid_mark) + cluster_changed = .true. + modified_hybrid_mark = hybrid_mark + prev_cluster_info_n = cluster_info%N + + do while (cluster_changed) + cluster_changed = .false. + call print("fixing up cluster according to heuristics keep_whole_residues " // keep_whole_residues // & + ' keep_whole_prolines ' // keep_whole_prolines // & + ' keep_whole_proline_sidechains ' // keep_whole_proline_sidechains // & + ' keep_whole_subgroups ' // keep_whole_subgroups // & + ' keep_whole_silica_tetrahedra ' // keep_whole_silica_tetrahedra // & + ' keep_whole_titania_octahedra ' // keep_whole_titania_octahedra // & + ' terminate_octahedra ' // terminate_octahedra // & + ' reduce_n_cut_bonds ' // reduce_n_cut_bonds // & + ' in_out_in ' // in_out_in // & + ' in_out_in_mode ' // trim(in_out_in_mode) // & + ' protect_X_H_bonds ' // protect_X_H_bonds // & + ' protect_double_bonds ' // protect_double_bonds // & + ' protect_peptide_bonds ' // protect_peptide_bonds // & + ' terminate .or. fix_termination_clash ' // (terminate .or. fix_termination_clash) // & + ' force_no_fix_termination_clash '// force_no_fix_termination_clash, verbosity=PRINT_NERD) + if (keep_whole_proline_sidechains) then + cluster_changed = cluster_changed .or. cluster_keep_whole_proline_sidechains(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, keep_whole_proline_sidechains_has_value) + endif + if (keep_whole_prolines) then + cluster_changed = cluster_changed .or. cluster_keep_whole_prolines(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, keep_whole_prolines_has_value) + endif + if (keep_whole_subgroups) then + cluster_changed = cluster_changed .or. cluster_keep_whole_subgroups(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, keep_whole_subgroups_has_value) + endif + if (keep_whole_residues) then + cluster_changed = cluster_changed .or. cluster_keep_whole_residues(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, keep_whole_residues_has_value) + endif + if (keep_whole_silica_tetrahedra) then + cluster_changed = cluster_changed .or. cluster_keep_whole_silica_tetrahedra(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) + end if + if (reduce_n_cut_bonds) then + cluster_changed = cluster_changed .or. cluster_reduce_n_cut_bonds(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) + endif + if (keep_whole_titania_octahedra) then + cluster_changed = cluster_changed .or. cluster_keep_whole_titania_octahedra(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) + end if + if (in_out_in) then + cluster_changed = cluster_changed .or. cluster_in_out_in(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, in_out_in_mode) + endif + if (protect_X_H_bonds) then + cluster_changed = cluster_changed .or. cluster_protect_X_H_bonds(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) + endif + if (protect_double_bonds) then + cluster_changed = cluster_changed .or. cluster_protect_double_bonds(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, protect_double_bonds_has_value) + endif + if (protect_peptide_bonds) then + cluster_changed = cluster_changed .or. cluster_protect_peptide_bonds(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, protect_peptide_bonds_has_value) + endif + if ((terminate .or. fix_termination_clash) .and. .not. force_no_fix_termination_clash) then + cluster_changed = cluster_changed .or. cluster_fix_termination_clash(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask, termination_clash_factor) + endif + if (keep_whole_molecules) then + cluster_changed = cluster_changed .or. cluster_keep_whole_molecules(at, cluster_info, connectivity_just_from_connect, use_connect, atom_mask) + endif + end do ! while cluster_changed + + if (prev_cluster_info_n < cluster_info%N) modified_hybrid_mark(cluster_info%int(1,prev_cluster_info_n+1:cluster_info%N)) = HYBRID_BUFFER_MARK + + call print('create_cluster: Finished fixing cluster for various heuristic pathologies',PRINT_NERD) + call print("create_cluster: cluster list:", PRINT_NERD) + call print(cluster_info, PRINT_NERD) + end if ! allow_cluster_mod + + call system_timer('cluster_consistency') + + call system_timer('cluster_termination') + + !So now cluster_info contains all the atoms that are going to be in the cluster. + !If terminate is set, we need to add terminating hydrogens along nearest neighbour bonds + if (terminate.or.terminate_octahedra) then + call print('create_cluster: Terminating cluster with hydrogens',PRINT_NERD) + + call allocate(n_term, 5, 0, 0, 0) + call allocate(in_n_term, 5, 0, 0, 0) + oldN = cluster_info%N + + !Loop over atoms in the cluster + do n = 1, oldN + + i = cluster_info%int(1,n) + ishift = cluster_info%int(2:4,n) + if(terminate_octahedra .and. at%z(i).ne.8 ) cycle + !Loop over atom i's neighbours + do m = 1, n_neighbours(at,i, alt_connect=use_connect) + + j = neighbour(at,i,m, r_ij, diff=dhat_ij, shift=jshift, alt_connect=use_connect) + dhat_ij = dhat_ij / r_ij + + if (find(cluster_info,(/j,ishift+jshift,at%Z(j),0/), atom_mask) == 0 .and. & + (hysteretic_connect .or. is_nearest_neighbour(at, i, m, alt_connect=use_connect))) then + + ! If j is an OUT atom, and it is close enough, put a terminating hydrogen + ! at the scaled distance between i and j + + if (.not. has_termination_rescale) then + rescale = termination_bond_rescale(at%Z(i), at%Z(j)) + else + rescale = termination_rescale + end if + H1 = at%pos(:,i) + rescale * r_ij * dhat_ij + + ! Label term atom with indices into original atoms structure. + ! j is atom it's generated from and n is index into cluster table of atom it's attached to + call append(cluster_info,(/j,ishift,1,n/),(/H1, rescale/), (/ "term " /)) + + ! Keep track of how many termination atoms each cluster atom has + p = find_in_array(int_part(n_term,(/1,2,3,4/)),(/n,ishift/)) + if (p == 0) then + call append(n_term, (/n,ishift,1/)) + else + n_term%int(5,p) = n_term%int(5,p) + 1 + end if + + ! optionally keep a record of the bonds that we have cut + if (present(cut_bonds)) & + call append(cut_bonds, (/i,j,ishift,jshift/)) + + if(current_verbosity() .ge. PRINT_NERD) then + write(line,'(a,i0,a,i0,a)')'create_cluster: Replacing bond ',i,'--',j,' with hydrogen' + call print(line, PRINT_NERD) + end if + end if + + ! Keep track of how many other neighbours has + if (terminate_octahedra.and.find(cluster_info,(/j,ishift+jshift,at%Z(j),0/), atom_mask) /= 0 .and. & + (hysteretic_connect .or. is_nearest_neighbour(at, i, m, alt_connect=use_connect))) then + p_in = find_in_array(int_part(in_n_term,(/1,2,3,4/)),(/n,ishift/)) + if (p_in == 0) then + call append(in_n_term, (/n,ishift,1/)) + else + in_n_term%int(5,p_in) = in_n_term%int(5,p_in) + 1 + end if + endif + end do + + end do + + !If terminate octahedra is set we have to adjust how many H atoms are added to the oxygens. + !Since with Ti, the oxygens are threefold coordinated, we have to remove some of the added O + !to restore the correct twofold coordination. + if(terminate_octahedra) then + + j = cluster_info%N + do i=n_term%n,1,-1 + n = n_term%int(1,i) !Reference atom + in_n = find_in_array(int_part(in_n_term,(/1/)),(/n/)) + ishift = n_term%int(2:4,i) + + if (n_term%int(5,i) .eq. 2) then + if (all(cluster_info%int(2:6,j) == (/ishift,1,n/))) then + bond1 = cluster_info%real(1:3,j) - cluster_info%real(1:3,n) + bond2 = cluster_info%real(1:3,j-1) - cluster_info%real(1:3,n) + orig_length = sqrt(sum(bond1 * bond1)) + + new_bond = bond1 + bond2 + new_bond = new_bond / sqrt(sum(new_bond*new_bond)) + new_bond = new_bond * orig_length + call delete(cluster_info, j) !Delete second H atom + call print('create_cluster: removed one of atom '//cluster_info%int(1,n)//" "//maxval(int_part(n_term,5))// & + ' terminating hydrogens ', PRINT_VERBOSE) + cluster_info%real(1:3,j-1) = cluster_info%real(1:3,n) + new_bond + endif + j = j - 2 + elseif (n_term%int(5,i) .eq. 1 .and. in_n_term%int(5,in_n) .le. 1) then !Do not remove the H atom + j = j - 1 + elseif (n_term%int(5,i) .eq. 1 .and. in_n_term%int(5,in_n) .gt. 1) then !Remove the H atom + if (all(cluster_info%int(2:6,j) == (/ishift,1,n/))) then + call delete(cluster_info, j) + call print('create_cluster: removed one of atom '//cluster_info%int(1,n)//" "//maxval(int_part(n_term,5))// & + ' terminating hydrogens ', PRINT_VERBOSE) + endif + j = j - 1 + endif + end do + + endif + + ! Do we need to remove a hydrogen atom to ensure equal n_up and n_down electrons? + if (even_electrons .and. mod(sum(int_part(cluster_info,5)),2) == 1) then + + ! Find first atom with a maximal number of terminating hydrogens + + do i=1,n_term%n + call append(sorted_n_term, (/n_term%int(5,i), n_term%int(1,i)/)) + end do + allocate(idx(n_term%n)) + call sort(sorted_n_term, idx) + + n = sorted_n_term%int(2, sorted_n_term%n) + most_hydrogens = idx(sorted_n_term%n) + ishift = n_term%int(2:4,most_hydrogens) + + ! Loop over termination atoms + do j=oldN,cluster_info%N + ! Remove first H atom attached to atom i + if (all(cluster_info%int(2:6,j) == (/ishift,1,n/))) then + call delete(cluster_info, j) + call print('create_cluster: removed one of atom '//cluster_info%int(1,n)//" "//maxval(int_part(n_term,5))// & + ' terminating hydrogens to zero total spin', PRINT_VERBOSE) + exit + end if + end do + + deallocate(idx) + end if + + call finalise(n_term) + + call print('create_cluster: Finished terminating cluster',PRINT_NERD) + end if + call system_timer('cluster_termination') + + call print ('Exiting create_cluster_info', PRINT_NERD) + + call finalise(cluster_list) + + end function create_cluster_info_from_mark + + + !% Given an atoms structure with a 'hybrid_mark' property, set to + !% 'HYBRID_ACTIVE_MARK' for some atoms, this routine adds transition + !% and buffer regions, and creates a 'weight_region1' property, + !% whose values are between 0 and 1. + !% + !% Atoms marked with 'HYBRID_ACTIVE_MARK' in 'hybrid_mark' get weight + !% 1. Neighbour hopping is done up to transition_hops times, over + !% which the weight linearly decreases to zero with hop count if + !% 'weight_interpolation=hop_ramp'. If + !% 'weight_interpolation=distance_ramp', weight is 1 up to + !% 'distance_ramp_inner_radius', and goes linearly to 0 by + !% 'distance_ramp_outer_radius', where distance is calculated from + !% 'distance_ramp_center(1:3)'. 'distance_ramp' makes the most sense if + !% the 'HYBRID_ACTIVE_MARK' is set on a sphere with radius + !% distance_ramp_inner_radius from distance_ramp_center, no + !% hysteresis, and with 'transition_hops' < 0 so hops continue until + !% no more atoms are added. Transition atoms are marked with + !% 'HYBRID_TRANS_MARK'. If 'hysteretic_buffer=F' (default), buffer + !% atoms are selected by hopping 'buffer_hops' times, otherwise + !% hysteretically with radii 'hysteretic_buffer_inner_radius' and + !% 'hysteretic_buffer_outer_radius'. Buffer atoms are marked with + !% 'HYBRID_BUFFER_MARK' and given weight 0. If 'hysteretic_connect' is + !% set, all hops are done on bonds in the hysteretic_connect + !% structure. + + subroutine create_hybrid_weights(at, args_str, error) + type(Atoms), intent(inout) :: at + character(len=*), intent(in) :: args_str + integer, optional, intent(out) :: error + + type(Dictionary) :: params + logical :: has_distance_ramp_inner_radius, has_distance_ramp_outer_radius, has_distance_ramp_center + real(dp) :: distance_ramp_inner_radius, distance_ramp_outer_radius, distance_ramp_center(3) + logical :: min_images_only, mark_buffer_outer_layer, cluster_hopping_nneighb_only, hysteretic_buffer, hysteretic_connect, hysteretic_buffer_nneighb_only + real(dp) :: hysteretic_buffer_inner_radius, hysteretic_buffer_outer_radius + real(dp) :: hysteretic_connect_cluster_radius, hysteretic_connect_inner_factor, hysteretic_connect_outer_factor + real(dp) :: hysteretic_connect_inner_cutoff, hysteretic_connect_outer_cutoff + integer :: buffer_hops, transition_hops + character(STRING_LENGTH) :: weight_interpolation, run_suffix + logical :: construct_buffer_use_only_heavy_atoms, cluster_hopping_skip_unreachable + + integer, pointer :: hybrid_mark(:) + real(dp), pointer :: weight_region1(:) + integer :: n_region1, n_trans, n_region2 !, n_term + integer :: i, j, jj, first_active, shift(3) + logical :: dummy + type(Table) :: activelist, currentlist, nextlist, distances, oldbuffer, bufferlist + real(dp) :: core_CoM(3), core_mass, mass + integer :: list_1, hybrid_number + type(Table) :: total_embedlist + + real(dp) :: origin(3), extent(3,3) + integer :: old_n + integer, allocatable :: uniq_Z(:) + + logical :: distance_ramp, hop_ramp + logical :: add_this_atom, more_hops + integer :: cur_trans_hop + real(dp) :: bond_len, d + logical :: ignore_silica_residue + integer :: res_num_silica + + INIT_ERROR(error) + +! only one set of defaults now, not one in args_str and one in arg list + call initialise(params) + call param_register(params, 'run_suffix', '', run_suffix, help_string="string to append to hyrbid_mark for proper mark property name") + call param_register(params, 'transition_hops', '0', transition_hops, help_string="Number of hops to do transition region over") + call param_register(params, 'buffer_hops', '3', buffer_hops, help_string="Number of hops for buffer region") + call param_register(params, 'weight_interpolation', 'hop_ramp', weight_interpolation, help_string="How to ramp down weights for transition region: hop_ramp or distance_ramp") + call param_register(params, 'distance_ramp_inner_radius', '0', distance_ramp_inner_radius, has_value_target=has_distance_ramp_inner_radius, help_string="If distance_ramp, inner radius to start reducing weight from 1") + call param_register(params, 'distance_ramp_outer_radius', '0', distance_ramp_outer_radius, has_value_target=has_distance_ramp_outer_radius, help_string="If distance_ramp, outer radius by which to reach weight of 0") + call param_register(params, 'distance_ramp_center', '0 0 0', distance_ramp_center, has_value_target=has_distance_ramp_center, help_string="If present, origin for distances of distance ramp (otherwise cluster center of mass)") + call param_register(params, 'cluster_hopping_nneighb_only', 'T', cluster_hopping_nneighb_only, help_string="If true, only hop to atom pairs that are is_nearest_neighbor().") + call param_register(params, 'cluster_hopping_skip_unreachable', 'F', cluster_hopping_skip_unreachable, help_string='If true, remove buffer atoms no longer reachable by bond hopping') + call param_register(params, 'min_images_only', 'F', min_images_only, help_string="If true, consider only minimum images, not multiple periodic images") + call param_register(params, 'mark_buffer_outer_layer', 'T', mark_buffer_outer_layer, help_string="If true, mark outermost buffer layer") + call param_register(params, 'hysteretic_buffer', 'F', hysteretic_buffer, help_string="If true, do hysteretic buffer") + call param_register(params, 'hysteretic_buffer_inner_radius', '5.0', hysteretic_buffer_inner_radius, help_string="Inner radius for hysteretic buffer") + call param_register(params, 'hysteretic_buffer_outer_radius', '7.0', hysteretic_buffer_outer_radius, help_string="Outer radius for hysteretic buffer") + call param_register(params, 'hysteretic_buffer_nneighb_only', 'F', hysteretic_buffer_nneighb_only, help_string="If true, only hop to nearest neighbour pairs when constructing hysteretic buffer") + call param_register(params, 'hysteretic_connect', 'F', hysteretic_connect, help_string="If true, use hysteretic connect object") + call param_register(params, 'hysteretic_connect_cluster_radius', '1.2', hysteretic_connect_cluster_radius, help_string="If using hysteretic connect, use as cluster radius for origin and extent estimates") + call param_register(params, 'hysteretic_connect_inner_factor', '1.2', hysteretic_connect_inner_factor, help_string="Inner factor (multiplier for covalent bond distance) for hysteretic connect") + call param_register(params, 'hysteretic_connect_outer_factor', '1.5', hysteretic_connect_outer_factor, help_string="Outer factor (multiplier for covalent bond distance) for hysteretic connect") + call param_register(params, 'construct_buffer_use_only_heavy_atoms', 'F', construct_buffer_use_only_heavy_atoms, help_string="If true, use only non-H atoms for constructing buffer") + call param_register(params, 'ignore_silica_residue', 'F', ignore_silica_residue, help_string="If true, do special things for silica") !lam81 + call param_register(params, 'res_num_silica', '1', res_num_silica, help_string="Residue number for silica") !lam81 + if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='create_hybrid_weights args_str') ) then + RAISE_ERROR("create_hybrid_weights failed to parse args_str='"//trim(args_str)//"'", error) + endif + call finalise(params) + + hop_ramp = .false. + distance_ramp = .false. + if (trim(weight_interpolation) == 'hop_ramp') then + hop_ramp = .true. + else if (trim(weight_interpolation) == 'distance_ramp') then + distance_ramp = .true. + else + RAISE_ERROR('create_hybrid_weights: unknown weight_interpolation value: '//trim(weight_interpolation), error) + end if + + call print('create_hybrid_weights: transition_hops='//transition_hops//' buffer_hops='//buffer_hops//' weight_interpolation='//weight_interpolation, PRINT_VERBOSE) + call print(' cluster_hopping_nneighb_only='//cluster_hopping_nneighb_only//' min_images_only='//min_images_only//' mark_buffer_outer_layer='//mark_buffer_outer_layer, PRINT_VERBOSE) + call print(' hysteretic_buffer='//hysteretic_buffer//' hysteretic_buffer_inner_radius='//hysteretic_buffer_inner_radius, PRINT_VERBOSE) + call print(' hysteretic_buffer_outer_radius='//hysteretic_buffer_outer_radius//' hysteretic_buffer_nneighb_only='//hysteretic_buffer_nneighb_only, PRINT_VERBOSE) + call print(' hysteretic_connect='//hysteretic_connect//' hysteretic_connect_cluster_radius='//hysteretic_connect_cluster_radius, PRINT_VERBOSE) + call print(' hysteretic_connect_inner_factor='//hysteretic_connect_inner_factor //' hysteretic_connect_outer_factor='//hysteretic_connect_outer_factor, PRINT_VERBOSE) + + + ! check to see if atoms has a 'weight_region1' property already, if so, check that it is compatible, if not present, add it + if(assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1)) then + weight_region1 = 0.0_dp + else + call add_property(at, 'weight_region1'//trim(run_suffix), 0.0_dp) + dummy = assign_pointer(at, 'weight_region1'//trim(run_suffix), weight_region1) + end if + + ! check for a compatible hybrid_mark property. it must be present + if(.not.assign_pointer(at, 'hybrid_mark'//trim(run_suffix), hybrid_mark)) then + RAISE_ERROR('create_hybrid_weights: atoms structure has no "hybrid_mark'//trim(run_suffix)//'" property', error) + endif + + ! Fast implementation of trivial case where buffer_hops=0 and transition_hops=0 + if (buffer_hops == 0 .and. transition_hops == 0) then + call print('WARNING: buffer_hops=0 and transition_hops=0, aborting create_hybrid_weights() early') + + where (hybrid_mark /= HYBRID_ACTIVE_MARK) + hybrid_mark = HYBRID_NO_MARK + end where + + weight_region1 = 0.0_dp + where (hybrid_mark == HYBRID_ACTIVE_MARK) + weight_region1 = 1.0_dp + end where + + return + end if + + ! Add first marked atom to activelist. shifts will be relative to this atom + first_active = find_in_array(hybrid_mark, HYBRID_ACTIVE_MARK) + + n_region1 = count(hybrid_mark == HYBRID_ACTIVE_MARK) + list_1 = 0 + call allocate(activelist, 4,0,0,0) + call allocate(total_embedlist, 4,0,0,0) + + do while (total_embedlist%N < n_region1) + + call wipe(currentlist) + call wipe(activelist) + call wipe(nextlist) + + call append(activelist, (/first_active,0,0,0/)) + call append(currentlist, activelist) + weight_region1(first_active) = 1.0_dp + + if (distance_ramp) then ! we might need ACTIVE_MARK center of mass + if (has_property(at, 'mass')) then + core_mass = at%mass(first_active) + else + core_mass = ElementMass(at%Z(first_active)) + end if + core_CoM = core_mass*at%pos(:,first_active) ! we're taking this as reference atom so no shift needed here + end if + + if (hysteretic_connect) then + call system_timer('hysteretic_connect') + call estimate_origin_extent(at, hybrid_mark == HYBRID_ACTIVE_MARK, hysteretic_connect_cluster_radius, origin, extent) + call calc_connect_hysteretic(at, hysteretic_connect_inner_cutoff, hysteretic_connect_outer_cutoff, at%hysteretic_connect, origin, extent) + call system_timer('hysteretic_connect') + endif + + ! Add other active atoms using bond hopping from the first atom + ! in the cluster to find the other active atoms and hence to determine the correct + ! periodic shifts + + hybrid_number = 1 + do while (hybrid_number .ne. 0) + if (hysteretic_connect) then + call BFS_step(at, currentlist, nextlist, nneighb_only=cluster_hopping_nneighb_only, min_images_only = min_images_only, alt_connect=at%hysteretic_connect) + else + call BFS_step(at, currentlist, nextlist, nneighb_only=cluster_hopping_nneighb_only, min_images_only = min_images_only, property=hybrid_mark) + endif + hybrid_number = 0 + do j=1,nextlist%N + jj = nextlist%int(1,j) + shift = nextlist%int(2:4,j) + if (hybrid_mark(jj) == HYBRID_ACTIVE_MARK .and. find_in_array(activelist%int(1,1:activelist%N), jj) == 0) then + hybrid_number = hybrid_number+1 + call append(activelist, nextlist%int(:,j)) + weight_region1(jj) = 1.0_dp + + if (distance_ramp) then ! we might need ACTIVE_MARK center of mass + if (has_property(at, 'mass')) then + mass = at%mass(jj) + else + mass = ElementMass(at%Z(jj)) + end if + core_CoM = core_CoM + mass*(at%pos(:,jj) + (at%lattice .mult. (shift))) + core_mass = core_mass + mass + end if + + end if + end do + call append(currentlist, nextlist) + enddo + list_1 = list_1 + activelist%N + call append(total_embedlist, activelist) + + if (distance_ramp) then ! calculate actual distance ramp parameters + ! distance_ramp center is as specified, otherwise ACTIVE_MARK center of mass + core_CoM = core_CoM/core_mass + if (.not. has_distance_ramp_center) distance_ramp_center = core_CoM + + ! distance_ramp_inner_radius is as specified, otherwise distance of atom furthest from distance_ramp_center + if (.not. has_distance_ramp_inner_radius) then + call initialise(distances, 1, 1, 0, 0) + do i=1, activelist%N + jj = activelist%int(1,i) + call append(distances, jj, distance_min_image(at, distance_ramp_center, jj)) + end do + distance_ramp_inner_radius = maxval(distances%real(1,1:distances%N)) + call finalise(distances) + endif + + if (.not. has_distance_ramp_outer_radius) then + distance_ramp_outer_radius = 0.0_dp + call uniq(at%Z, uniq_Z) + do i=1, size(uniq_Z) + do j=1, size(uniq_Z) + bond_len = bond_length(uniq_Z(i), uniq_Z(j)) + if (bond_len > distance_ramp_outer_radius) distance_ramp_outer_radius = bond_len + end do + end do + if (transition_hops <= 0) & + call print("WARNING: using transition_hops for distance_ramp outer radius, but transition_hops="//transition_hops,PRINT_ALWAYS) + distance_ramp_outer_radius = distance_ramp_inner_radius + distance_ramp_outer_radius*transition_hops + endif + endif ! distance_ramp + + call wipe(currentlist) + call append(currentlist, activelist) + + ! create transition region + call print('create_hybrid_mark: creating transition region',PRINT_VERBOSE) + n_trans = 0 + + cur_trans_hop = 1 + if (distance_ramp) transition_hops = -1 ! distance ramp always does as many hops as needed to get every atom within outer radius + more_hops = (transition_hops < 0 .or. transition_hops >= 2) + do while (more_hops) + more_hops = .false. + if (hysteretic_connect) then + call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only .and. (transition_hops > 0), min_images_only = min_images_only, alt_connect=at%hysteretic_connect) + else + call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only .and. (transition_hops > 0), min_images_only = min_images_only) + endif + + call wipe(currentlist) + do j = 1,nextlist%N + jj = nextlist%int(1,j) + if(hybrid_mark(jj) == HYBRID_NO_MARK) then + add_this_atom = .true. + if (distance_ramp) then + d = distance_min_image(at, distance_ramp_center, jj) + if (d >= distance_ramp_outer_radius) add_this_atom = .false. + endif + + if (add_this_atom) then + if (hop_ramp) weight_region1(jj) = 1.0_dp - real(cur_trans_hop,dp)/real(transition_hops,dp) ! linear transition + if (distance_ramp) then ! Save distance, weight will be calculated later + if (d <= distance_ramp_inner_radius) then + weight_region1(jj) = 1.0_dp + else + weight_region1(jj) = 1.0_dp - (d-distance_ramp_inner_radius)/(distance_ramp_outer_radius-distance_ramp_inner_radius) + endif + endif + call append(currentlist, nextlist%int(:,j)) + hybrid_mark(jj) = HYBRID_TRANS_MARK + n_trans = n_trans+1 + more_hops = .true. + end if + end if + end do ! do j=1,nextlist%N + + cur_trans_hop = cur_trans_hop + 1 + if (transition_hops >= 0 .and. cur_trans_hop >= transition_hops) more_hops = .false. + end do ! more_hops + + if (list_1 < n_region1) then + call print('searching for a new quantum zone as found '//list_1//' atoms, need to get to '//n_region1, PRINT_VERBOSE) + do i =1, at%N + if (hybrid_mark(i) == HYBRID_ACTIVE_MARK .and. .not. Is_in_Array(total_embedlist%int(1,1:total_embedlist%N), i)) then + first_active = i + exit + endif + enddo + endif + + enddo ! while (total_embedlist%N < n_region1) + + ! create region2 (buffer region) + if (.not. hysteretic_buffer) then + ! since no hysteresis, safe to reset non ACTIVE/TRANS atoms to HYBRID_NO_MARK + where (hybrid_mark /= HYBRID_ACTIVE_MARK .and. hybrid_mark /= HYBRID_TRANS_MARK) hybrid_mark = HYBRID_NO_MARK + + n_region2 = 0 + do i = 0,buffer_hops-1 + if (hysteretic_connect) then + call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only, min_images_only = min_images_only, alt_connect=at%hysteretic_connect) + else + call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only, min_images_only = min_images_only) + endif + call wipe(currentlist) + do j = 1,nextlist%N + jj = nextlist%int(1,j) + if(hybrid_mark(jj) == HYBRID_NO_MARK) then + call append(currentlist, nextlist%int(:,j)) + weight_region1(jj) = 0.0_dp + if (i==buffer_hops-1 .and. mark_buffer_outer_layer) then + hybrid_mark(jj) = HYBRID_BUFFER_OUTER_LAYER_MARK + else + hybrid_mark(jj) = HYBRID_BUFFER_MARK + end if + n_region2 = n_region2+1 + end if + end do + end do + else + ! hysteretic buffer here + + call initialise(oldbuffer, 1,0,0,0) + !call wipe(oldbuffer) + call append(oldbuffer, find(hybrid_mark /= HYBRID_NO_MARK)) + + call wipe(currentlist) + + ! Add first marked atom to embedlist. shifts will be relative to this atom + first_active = find_in_array(hybrid_mark, HYBRID_ACTIVE_MARK) + call append(bufferlist, (/first_active,0,0,0/)) + call append(currentlist, bufferlist) + + n_region2 = count(hybrid_mark /= HYBRID_NO_MARK) + + ! Find old embed + buffer atoms using bond hopping from the first atom + ! in the cluster to find the other buffer atoms and hence to determine the correct + ! periodic shifts + ! + ! This will fail if marked atoms do not form connected clusters around the active atoms + old_n = bufferlist%N + do while (bufferlist%N < n_region2) + if (hysteretic_connect) then + call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only, min_images_only = min_images_only, alt_connect=at%hysteretic_connect) + else + call BFS_step(at, currentlist, nextlist, nneighb_only = cluster_hopping_nneighb_only, min_images_only = min_images_only, property =hybrid_mark) + endif + do j=1,nextlist%N + jj = nextlist%int(1,j) + shift = nextlist%int(2:4,j) + if (hybrid_mark(jj) /= HYBRID_NO_MARK) call append(bufferlist, nextlist%int(:,j)) + end do + call append(currentlist, nextlist) + + ! check that cluster is still growing + if (bufferlist%N == old_n) then + exit + if (cluster_hopping_skip_unreachable) then + call print('WARNING: skipping buffer atoms no longer connected') + exit + else + RAISE_ERROR('create_hybrid_weights: buffer cluster stopped growing before all marked atoms found - check for split QM or buffer region', error) + end if + end if + old_n = bufferlist%N + end do + n_region2 = bufferlist%N ! possibly excluding some no-longer-reachable atoms + + ! Remove marks on all buffer atoms + do i=1,oldbuffer%N + if (hybrid_mark(oldbuffer%int(1,i)) == HYBRID_BUFFER_MARK .or. & + hybrid_mark(oldbuffer%int(1,i)) == HYBRID_BUFFER_OUTER_LAYER_MARK) & + hybrid_mark(oldbuffer%int(1,i)) = HYBRID_NO_MARK + end do + + !construct the hysteretic buffer region: + if (hysteretic_connect) then + call print("create_hybrid_weights calling construct_hysteretic_region", verbosity=PRINT_NERD) + call construct_hysteretic_region(region=bufferlist,at=at,core=total_embedlist,loop_atoms_no_connectivity=.false., & + inner_radius=hysteretic_buffer_inner_radius,outer_radius=hysteretic_buffer_outer_radius,use_avgpos=.false., & + add_only_heavy_atoms=construct_buffer_use_only_heavy_atoms, cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, & + force_hopping_nneighb_only=hysteretic_buffer_nneighb_only, min_images_only=min_images_only, & + alt_connect=at%hysteretic_connect, & + ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica, error=error) !NB, debugfile=mainlog) lam81 + else + call print("create_hybrid_weights calling construct_hysteretic_region", verbosity=PRINT_NERD) + call construct_hysteretic_region(region=bufferlist,at=at,core=total_embedlist,loop_atoms_no_connectivity=.false., & + inner_radius=hysteretic_buffer_inner_radius,outer_radius=hysteretic_buffer_outer_radius,use_avgpos=.false., & + add_only_heavy_atoms=construct_buffer_use_only_heavy_atoms, cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, & + force_hopping_nneighb_only=hysteretic_buffer_nneighb_only, min_images_only=min_images_only, & + ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica, error=error) !NB, debugfile=mainlog) lam81 + endif + + call print('bufferlist=',PRINT_VERBOSE) + call print(bufferlist,PRINT_VERBOSE) + + ! Mark new buffer region, leaving core QM region alone + ! at the moment only ACTIVE and NO marks are present, because hybrid_mark was set to =hybrid + do i=1,bufferlist%N + if (hybrid_mark(bufferlist%int(1,i)) == HYBRID_NO_MARK) & + hybrid_mark(bufferlist%int(1,i)) = HYBRID_BUFFER_MARK + + ! Marking the outer layer with HYBRID_BUFFER_OUTER_LAYER_MARK is + ! dealt with in create_cluster_from_mark. + + end do + + call finalise(bufferlist) + call finalise(oldbuffer) +! call finalise(embedlist) + + end if + + ! this is commented out for now, terminations are controlled in create_cluster only + ! create terminations + !n_term = 0 + !if(terminate) then + ! call BFS_step(at, currentlist, nextlist, nneighb_only = .true., min_images_only = .true.) + ! do j = 1,nextlist%N + ! jj = nextlist%int(1,j) + ! if(hybrid_mark(jj) == HYBRID_NO_MARK) then + ! weight_region1(jj) = 0.0_dp + ! hybrid_mark(jj) = HYBRID_TERM_MARK + ! n_term = n_term+1 + ! end if + ! end do + !end do + + call print('create_hybrid_weights: '//list_1//' region 1, '//n_trans//' transition, '//n_region2//& + ' region 2, '//count(hybrid_mark /= HYBRID_NO_MARK)//' in total', PRINT_VERBOSE) + !call print('create_hybrid_weights: '//n_region1//' region 1, '//n_trans//' transition, '//n_region2//& + ! ' region 2, '//count(hybrid_mark /= HYBRID_NO_MARK)//' in total', PRINT_VERBOSE) + ! call sort(total_embedlist) + + call finalise(activelist) + call finalise(currentlist) + call finalise(nextlist) + call finalise(distances) + call finalise(total_embedlist) + + end subroutine create_hybrid_weights + + !% Return estimated `(origin, extent)` for hysteretic connectivity + !% calculator to include all atoms within a distance `cluster_radius` + !% of an atom in the `active` array. + subroutine estimate_origin_extent(at, active, cluster_radius, origin, extent) + type(Atoms), intent(in) :: at + logical, intent(in) :: active(:) + real(dp), intent(in) :: cluster_radius + real(dp), intent(out) :: origin(3), extent(3,3) + + real(dp) :: center(3), low_corner(3), high_corner(3), dr(3) + integer :: i, n_active, first_active + logical :: found_first_active + + found_first_active = .false. + n_active = 0 + do i=1, at%N + if (.not. active(i)) cycle + n_active = n_active + 1 + if (found_first_active) then + center = center + diff_min_image(at, first_active, i) + else + center = 0.0_dp + first_active = i + found_first_active = .true. + endif + end do + center = center / real(n_active, dp) + center = center + at%pos(:,first_active) + + call print("estimate_origin_extent: got center" // center, verbosity=PRINT_VERBOSE) + + low_corner = 1.0e38_dp + high_corner = -1.0e38_dp + do i=1, at%N + if (.not. active(i)) cycle + dr = diff_min_image(at, at%pos(:,i), center) + low_corner = min(low_corner, dr) + high_corner = max(high_corner, dr) + end do + call print("estimate_origin_extent: got relative low_corner" // low_corner, verbosity=PRINT_NERD) + call print("estimate_origin_extent: got relative high_corner" // high_corner, verbosity=PRINT_NERD) + low_corner = low_corner + center + high_corner = high_corner + center + + call print("estimate_origin_extent: got low_corner" // low_corner, verbosity=PRINT_NERD) + call print("estimate_origin_extent: got high_corner" // high_corner, verbosity=PRINT_NERD) + + origin = low_corner - cluster_radius + extent = 0.0_dp + extent(1,1) = (high_corner(1)-low_corner(1))+2.0_dp*cluster_radius + extent(2,2) = (high_corner(2)-low_corner(2))+2.0_dp*cluster_radius + extent(3,3) = (high_corner(3)-low_corner(3))+2.0_dp*cluster_radius + + call print("estimate_origin_extent: got origin" // origin, verbosity=PRINT_VERBOSE) + call print("estimate_origin_extent: got extent(1,:) " // extent(1,:), verbosity=PRINT_VERBOSE) + call print("estimate_origin_extent: got extent(2,:) " // extent(2,:), verbosity=PRINT_VERBOSE) + call print("estimate_origin_extent: got extent(3,:) " // extent(3,:), verbosity=PRINT_VERBOSE) + + end subroutine estimate_origin_extent + + !% Given an Atoms structure with an active region marked in the mark_name (default 'hybrid_mark') + !% property using 'HYBRID_ACTIVE_MARK', grow the embed region by 'fit_hops' + !% bond hops to form a fit region. Returns the embedlist and fitlist with correct + !% periodic shifts. + subroutine create_embed_and_fit_lists(at, fit_hops, embedlist, fitlist, cluster_hopping_nneighb_only, min_images_only, mark_name, error) + + type(Atoms), intent(inout) :: at + integer :: fit_hops + type(Table), intent(out) :: embedlist, fitlist + logical, intent(in), optional :: cluster_hopping_nneighb_only, min_images_only + character(len=*), intent(in), optional :: mark_name + integer, optional, intent(out) :: error + + character(len=255) :: my_mark_name + integer, pointer :: hybrid_mark(:) + integer :: n_region1, n_region2 !, n_term + integer :: i, j, jj, first_active, shift(3) + logical :: do_hopping_nneighb_only, do_min_images_only + type(Table) :: currentlist, nextlist, tmpfitlist + integer :: n, hybrid_number + type(Table) :: totallist + integer :: list_1 + + integer :: old_n + + INIT_ERROR(error) + + my_mark_name = optional_default('hybrid_mark', mark_name) + + call print('Entered create_embed_and_fit_lists.',PRINT_VERBOSE) + do_hopping_nneighb_only = optional_default(.false., cluster_hopping_nneighb_only) + do_min_images_only = optional_default(.true., min_images_only) + + ! check for a compatible hybrid_mark property. it must be present + if(.not.assign_pointer(at, trim(my_mark_name), hybrid_mark)) then + RAISE_ERROR('create_fit_region: atoms structure has no "'//trim(my_mark_name)//'"', error) + endif + + call wipe(embedlist) + call wipe(fitlist) + + ! Add first marked atom to embedlist. shifts will be relative to this atom + first_active = find_in_array(hybrid_mark, HYBRID_ACTIVE_MARK) + + n_region1 = count(hybrid_mark == HYBRID_ACTIVE_MARK) + list_1 = 0 + call allocate(totallist,4,0,0,0) + call allocate(currentlist,4,0,0,0) + + ! Add other active atoms using bond hopping from the first atom + ! in the cluster to find the other active atoms and hence to determine the correct + ! periodic shifts + ! + old_n = embedlist%N + do while (embedlist%N < n_region1) + + call wipe(currentlist) + call wipe(nextlist) + call wipe(totallist) + + call append(totallist, (/first_active,0,0,0/)) + call print('create_embed_and_fit_lists: expanding quantum region starting from '//first_active//' atom', PRINT_VERBOSE) + call append(currentlist, totallist) + + hybrid_number = 1 + do while (hybrid_number .ne. 0) +!!!CHECK THIS + call BFS_step(at, currentlist, nextlist, nneighb_only = .false., min_images_only = do_min_images_only, property =hybrid_mark) + + hybrid_number = 0 + do j=1,nextlist%N + jj = nextlist%int(1,j) + shift = nextlist%int(2:4,j) + if (hybrid_mark(jj) == HYBRID_ACTIVE_MARK) then + hybrid_number = hybrid_number + 1 + call append(totallist, nextlist%int(:,j)) + endif + end do + call append(currentlist, nextlist) + enddo + + list_1 = list_1 + totallist%N + call append(embedlist, totallist) + call print('create_embed_and_fit_lists: number of atoms in the embedlist is '//embedlist%N, PRINT_VERBOSE) + + if (list_1 .lt. n_region1) then + n = 0 + do i =1, at%N + if (hybrid_mark(i) == HYBRID_ACTIVE_MARK) then + n = n+1 + if (.not. Is_in_Array(int_part(embedlist,1), i)) then + first_active = i + exit + endif + endif + enddo + endif + + ! check that cluster is still growing + !if (embedlist%N == old_n) then + ! RAISE_ERROR('create_embed_and_fit_lists: (embedlist) cluster stopped growing before all marked atoms found - check for split QM region', error) + !endif + !old_n = embedlist%N + end do + + + call wipe(currentlist) + call append(currentlist, embedlist) + + + ! create region2 (fit region) + call initialise(tmpfitlist,4,0,0,0,0) + n_region2 = 0 + do i = 0,fit_hops-1 + call BFS_step(at, currentlist, nextlist, nneighb_only = do_hopping_nneighb_only, min_images_only = do_min_images_only) + do j = 1,nextlist%N + jj = nextlist%int(1,j) + if(hybrid_mark(jj) /= HYBRID_ACTIVE_MARK) then + call append(tmpfitlist, nextlist%int(:,j)) + n_region2 = n_region2+1 + end if + end do + call append(currentlist, nextlist) + end do + + call print('create_embed_and_fit_lists: '//list_1//' embed, '//n_region2//' fit', PRINT_VERBOSE) + + ! Sort order to we are stable to changes in neighbour ordering introduced + ! by calc_connect. + call sort(embedlist) + call sort(tmpfitlist) + + ! fitlist consists of sorted embedlist followed by sorted list of remainder of fit atoms + call append(fitlist, embedlist) + call append(fitlist, tmpfitlist) + + if (do_min_images_only) then + if (multiple_images(embedlist)) then + call discard_non_min_images(embedlist) + call print('create_embed_and_fits_lists: multiple images discarded from embedlist', PRINT_VERBOSE) + endif + + if (multiple_images(fitlist)) then + call discard_non_min_images(fitlist) + call print('create_embed_and_fits_lists: multiple images discarded from fitlist', PRINT_VERBOSE) + endif + endif + + call finalise(currentlist) + call finalise(nextlist) + call finalise(tmpfitlist) + + end subroutine create_embed_and_fit_lists + + !% Given an Atoms structure with an active region marked in the mark_name (default 'cluster_mark') + !% property using 'HYBRID_ACTIVE_MARK', and buffer region marked using 'HYBRID_BUFFER_MARK', + !% 'HYBRID_TRANS_MARK' or 'HYBRID_BUFFER_OUTER_LAYER_MARK', simply returns the embedlist and fitlist + !% according to 'cluster_mark'. It does not take into account periodic shifts. + subroutine create_embed_and_fit_lists_from_cluster_mark(at,embedlist,fitlist, mark_name, error) + + type(Atoms), intent(in) :: at + type(Table), intent(out) :: embedlist, fitlist + character(len=*), intent(in), optional :: mark_name + integer, optional, intent(out) :: error + + character(len=255) :: my_mark_name + type(Table) :: tmpfitlist + + INIT_ERROR(error) + + my_mark_name = optional_default('cluster_mark', mark_name) + + call print('Entered create_embed_and_fit_lists_from_cluster_mark.',PRINT_VERBOSE) + call wipe(embedlist) + call wipe(fitlist) + call wipe(tmpfitlist) + + !build embed list from ACTIVE atoms + call list_matching_prop(at,embedlist,trim(my_mark_name),HYBRID_ACTIVE_MARK) + + !build fitlist from BUFFER and TRANS atoms + call list_matching_prop(at,tmpfitlist,trim(my_mark_name),HYBRID_BUFFER_MARK) + call append(fitlist,tmpfitlist) + call list_matching_prop(at,tmpfitlist,trim(my_mark_name),HYBRID_TRANS_MARK) + call append(fitlist,tmpfitlist) + call list_matching_prop(at,tmpfitlist,trim(my_mark_name),HYBRID_BUFFER_OUTER_LAYER_MARK) + call append(fitlist,tmpfitlist) + + call wipe(tmpfitlist) + call append(tmpfitlist,fitlist) + + ! Sort in order to we are stable to changes in neighbour ordering introduced + ! by calc_connect. + call sort(embedlist) + call sort(tmpfitlist) + + ! fitlist consists of sorted embedlist followed by sorted list of remainder of fit atoms + call wipe(fitlist) + call append(fitlist, embedlist) + call append(fitlist, tmpfitlist) + + call print('Embedlist:',PRINT_ANALYSIS) + call print(int_part(embedlist,1),PRINT_ANALYSIS) + call print('Fitlist:',PRINT_ANALYSIS) + call print(int_part(fitlist,1),PRINT_ANALYSIS) + + call finalise(tmpfitlist) + call print('Leaving create_embed_and_fit_lists_from_cluster_mark.',PRINT_VERBOSE) + + end subroutine create_embed_and_fit_lists_from_cluster_mark + + !% Return the atoms in a hysteretic region: + !% To become part of the 'list' region, atoms must drift within the + !% 'inner' list. To leave the 'list' region, an atom + !% must drift further than 'outer'. + !% Optionally use time averaged positions + ! + subroutine update_hysteretic_region(at,inner,outer,list,min_images_only,error) + + type(Atoms), intent(in) :: at + type(Table), intent(inout) :: inner, outer + type(Table), intent(inout) :: list + logical, optional, intent(in) :: min_images_only + integer, optional, intent(out) :: error + + integer n, my_verbosity + logical do_min_images_only + integer, allocatable :: cols(:) + + INIT_ERROR(error) + + my_verbosity = current_verbosity() + do_min_images_only = optional_default(.false., min_images_only) + call print('update_hysteretic_region: do_min_images_only='//do_min_images_only, PRINT_VERBOSE) + + if (do_min_images_only) then + ! only compare atom indices - first column in table + allocate(cols(1)) + cols(1) = 1 + else + ! compare atom indices and shifts - all four columns in table + allocate(cols(4)) + cols(:) = (/1, 2, 3, 4/) + end if + + if (my_verbosity == PRINT_ANALYSIS) then + call print('In Select_Hysteretic_Quantum_Region:') + call print('List currently contains '//list%N//' atoms') + end if + + if ((list%intsize /= inner%intsize) .or. (list%intsize /= outer%intsize)) then + RAISE_ERROR('update_hysteretic_region: inner, outer and list must have the same intsize', error) + endif + + ! Speed up searching + call sort(outer) + call sort(list) + + !Check for atoms in 'list' and not in 'outer' + do n = list%N, 1, -1 + if (search(outer,list%int(cols,n))==0) then + call delete(list,n) + if (my_verbosity > PRINT_NORMAL) call print('Removed atom ('//list%int(cols,n)//') from quantum list') + end if + end do + + call sort(list) + + !Check for new atoms in 'inner' cluster and add them to list + do n = 1, inner%N + if (search(list,inner%int(cols,n))==0) then + call append(list,inner%int(:,n)) ! copy shifts columns as well, even if we're not comparing them + call sort(list) + if (my_verbosity > PRINT_NORMAL) call print('Added atom ('//inner%int(cols,n)//') to quantum list') + end if + end do + + if (my_verbosity >= PRINT_NORMAL) call print(list%N//' atoms selected for quantum treatment') + deallocate(cols) + + end subroutine update_hysteretic_region + + + ! + !% Given an atoms object, and a point 'centre' or a list of atoms 'core', + !% fill the 'region' table with all atoms hysteretically within 'inner_radius -- outer_radius' + !% of the 'centre' or any 'core' atom, which can be reached by connectivity hopping. + !% In the case of building the 'region' around 'centre', simply_loop_over_atoms loops instead of + !% bond hopping. + !% Optionally use the time averaged positions. + !% Optionally use only heavy atom selection. + ! + subroutine construct_hysteretic_region(region,at,core,centre,loop_atoms_no_connectivity,inner_radius,outer_radius,use_avgpos,add_only_heavy_atoms,cluster_hopping_nneighb_only, & + force_hopping_nneighb_only, min_images_only,alt_connect,debugfile, ignore_silica_residue, res_num_silica, error) !lam81 + + type(Table), intent(inout) :: region + type(Atoms), intent(in) :: at + type(Table), optional, intent(in) :: core + real(dp), optional, intent(in) :: centre(3) + logical, optional, intent(in) :: loop_atoms_no_connectivity + real(dp), intent(in) :: inner_radius + real(dp), intent(in) :: outer_radius + logical, optional, intent(in) :: use_avgpos + logical, optional, intent(in) :: add_only_heavy_atoms + logical, optional, intent(in) :: cluster_hopping_nneighb_only + logical, optional, intent(in) :: force_hopping_nneighb_only + logical, optional, intent(in) :: min_images_only + type(Connection), optional,intent(in) :: alt_connect + type(inoutput), optional :: debugfile + integer, optional, intent(out) :: error + + type(Table) :: inner_region + type(Table) :: outer_region + logical :: no_hysteresis + + logical, optional, intent(in) :: ignore_silica_residue ! lam81 + integer, optional, intent(in) :: res_num_silica ! lam81 + + INIT_ERROR(error) + + if (present(debugfile)) call print("construct_hysteretic_region radii " // inner_radius // " " // outer_radius, file=debugfile) + !check the input arguments only in construct_region. + if (inner_radius.lt.0._dp) then + RAISE_ERROR('inner_radius must be > 0 and it is '//inner_radius, error) + endif + if (outer_radius.lt.inner_radius) then + RAISE_ERROR('outer radius ('//outer_radius//') must not be smaller than inner radius ('//inner_radius//').', error) + endif + + no_hysteresis = .false. + if ((outer_radius-inner_radius).lt.epsilon(0._dp)) no_hysteresis = .true. + if (inner_radius .feq. 0.0_dp) call print('WARNING: hysteretic region with inner_radius .feq. 0.0', PRINT_ALWAYS) + if (no_hysteresis) call print('WARNING! construct_hysteretic_region: inner_buffer=outer_buffer. no hysteresis applied: outer_region = inner_region used.',PRINT_ALWAYS) + if (present(debugfile)) call print(" no_hysteresis " // no_hysteresis, file=debugfile) + + if (present(debugfile)) call print(" constructing inner region", file=debugfile) + call construct_region(region=inner_region,at=at,core=core,centre=centre,loop_atoms_no_connectivity=loop_atoms_no_connectivity, & + radius=inner_radius,use_avgpos=use_avgpos,add_only_heavy_atoms=add_only_heavy_atoms,cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, & + force_hopping_nneighb_only=force_hopping_nneighb_only, & + min_images_only=min_images_only,alt_connect=alt_connect,debugfile=debugfile, & + ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica) !lam81 + if (no_hysteresis) then + call initialise(outer_region,4,0,0,0,0) + call append(outer_region,inner_region) + else + if (present(debugfile)) call print(" constructing outer region", file=debugfile) + call construct_region(region=outer_region,at=at,core=core,centre=centre,loop_atoms_no_connectivity=loop_atoms_no_connectivity, & + radius=outer_radius, use_avgpos=use_avgpos,add_only_heavy_atoms=add_only_heavy_atoms,cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, & + force_hopping_nneighb_only=force_hopping_nneighb_only, & + min_images_only=min_images_only,alt_connect=alt_connect,debugfile=debugfile, & + ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica) ! lam81 + endif + + if (present(debugfile)) call print(" orig inner_region list", file=debugfile) + if (present(debugfile)) call print(inner_region, file=debugfile) + if (present(debugfile)) call print(" orig outer_region list", file=debugfile) + if (present(debugfile)) call print(outer_region, file=debugfile) + if (present(debugfile)) call print(" old region list", file=debugfile) + if (present(debugfile)) call print(region, file=debugfile) + + call print('construct_hysteretic_region: old region list:',PRINT_VERBOSE) + call print(region,PRINT_VERBOSE) + + call update_hysteretic_region(at,inner_region,outer_region,region, min_images_only=min_images_only) + + call print('construct_hysteretic_region: inner_region list:',PRINT_VERBOSE) + call print(inner_region,PRINT_VERBOSE) + call print('construct_hysteretic_region: outer_region list:',PRINT_VERBOSE) + call print(outer_region,PRINT_VERBOSE) + + if (present(debugfile)) call print(" new inner region list", file=debugfile) + if (present(debugfile)) call print(inner_region, file=debugfile) + if (present(debugfile)) call print(" new outer region list", file=debugfile) + if (present(debugfile)) call print(outer_region, file=debugfile) + + call print('construct_hysteretic_region: new region list:',PRINT_VERBOSE) + call print(region,PRINT_VERBOSE) + + if (present(debugfile)) call print(" new region list", file=debugfile) + if (present(debugfile)) call print(region, file=debugfile) + + call finalise(inner_region) + call finalise(outer_region) + + end subroutine construct_hysteretic_region + + ! + !% Given an atoms object, and a point or a list of atoms in the first integer of + !% the 'core' table, fill the 'buffer' table with all atoms within 'radius' + !% of any core atom (which can be reached by connectivity hopping) or the point + !%(with bond hopping or simply looping once over the atoms). + !% Optionally use the time averaged positions (only for the radius). + !% Optionally use a heavy atom based selection (applying to both the core and the region atoms). + !% Alternatively use the hysteretic connection, only nearest neighbours and/or min_images (only for the n_connectivity_hops). + ! + subroutine construct_region(region,at,core,centre,loop_atoms_no_connectivity,radius,n_connectivity_hops,use_avgpos,add_only_heavy_atoms,cluster_hopping_nneighb_only,& + force_hopping_nneighb_only, min_images_only,alt_connect,debugfile, ignore_silica_residue, res_num_silica, error) !lam81 + + type(Table), intent(out) :: region + type(Atoms), intent(in) :: at + type(Table), optional, intent(in) :: core + real(dp), optional, intent(in) :: centre(3) + logical, optional, intent(in) :: loop_atoms_no_connectivity + real(dp), optional, intent(in) :: radius + integer, optional, intent(in) :: n_connectivity_hops + logical, optional, intent(in) :: use_avgpos + logical, optional, intent(in) :: add_only_heavy_atoms + logical, optional, intent(in) :: cluster_hopping_nneighb_only + logical, optional, intent(in) :: force_hopping_nneighb_only + logical, optional, intent(in) :: min_images_only + type(Connection), optional,intent(in) :: alt_connect +type(inoutput), optional :: debugfile + integer, optional, intent(out) :: error + + logical :: do_use_avgpos + logical :: do_loop_atoms_no_connectivity + logical :: do_add_only_heavy_atoms + logical :: do_hopping_nneighb_only, do_force_hopping_nneighb_only + logical :: do_min_images_only + integer :: i, j, ii, ij + type(Table) :: nextlist + logical :: more_hops, add_i + integer :: cur_hop + real(dp), pointer :: use_pos(:,:) + integer :: shift_i(3) + logical :: do_ignore_silica_residue, got_atom_res_number + + integer, pointer :: atom_res_number(:) !lam81 + logical, optional, intent(in) :: ignore_silica_residue !lam81 + integer, optional, intent(in) :: res_num_silica + + INIT_ERROR(error) + + do_loop_atoms_no_connectivity = optional_default(.false.,loop_atoms_no_connectivity) + do_ignore_silica_residue = optional_default(.false., ignore_silica_residue) + + do_add_only_heavy_atoms = optional_default(.false.,add_only_heavy_atoms) + if (do_add_only_heavy_atoms .and. .not. has_property(at,'Z')) then + RAISE_ERROR("construct_region: atoms has no Z property", error) + endif + + got_atom_res_number = assign_pointer(at, 'atom_res_number', atom_res_number) + + do_use_avgpos = optional_default(.false., use_avgpos) + + if (count((/ present(centre), present(core) /)) /= 1) then + RAISE_ERROR("Need either centre or core, but not both present(centre) " // present(centre) // " present(core) "// present(core), error) + endif + + ! if we have radius, we'll have to decide what positions to use + if (present(radius)) then + if (do_use_avgpos) then + if (.not. assign_pointer(at, "avgpos", use_pos)) then + RAISE_ERROR("do_use_avgpos is true, but no avgpos property", error) + endif + else + if (.not. assign_pointer(at, "pos", use_pos)) then + RAISE_ERROR("do_use_avgpos is false, but no pos property", error) + endif + endif + endif + + call initialise(region,4,0,0,0,0) + + if (do_loop_atoms_no_connectivity) then + if (present(debugfile)) call print(" loop over atoms", file=debugfile) + if (.not. present(radius)) then + RAISE_ERROR("do_loop_atoms_no_connectivity=T requires radius", error) + endif + if (present(n_connectivity_hops) .or. present(min_images_only) .or. present(cluster_hopping_nneighb_only)) & + call print("WARNING: do_loop_atoms_no_connectivity, but specified unused arg n_connectivity_hops " // present(n_connectivity_hops) // & + " min_images_only " // present(min_images_only) // " cluster_hopping_nneighb_only " // present(cluster_hopping_nneighb_only), PRINT_ALWAYS) + ! jrk33: disabled this warning - should be fine with small cells since distance_min_image is used. + ! call print('WARNING: check if your cell is greater than the radius, looping only works in that case.',PRINT_ALWAYS) + !if (any((/at%lattice(1,1),at%lattice(2,2),at%lattice(3,3)/) < radius)) then + !RAISE_ERROR('too small cell', error) + !endifx + do i = 1,at%N + if (present(debugfile)) call print("check atom i " // i // " Z " // at%Z(i) // " pos " // at%pos(:,i), file=debugfile) + if (do_add_only_heavy_atoms .and. at%Z(i) == 1) cycle + if (present(centre)) then ! distance from centre is all that matters + if (present(debugfile)) call print(" distance_min_image use_pos i " // use_pos(:,i) // " centre " // centre // " dist " // distance_min_image(at, use_pos(:,i), centre(1:3), shift_i(1:3)), file=debugfile) + if (distance_min_image(at,use_pos(:,i),centre(1:3),shift_i(1:3)) < radius) then + if (present(debugfile)) call print(" adding i " // i // " at " // use_pos(:,i) // " center " // centre // " dist " // distance_min_image(at, use_pos(:,i), centre(1:3), shift_i(1:3)), file=debugfile) + call append(region,(/i,shift_i(1:3)/)) + endif + else ! no centre, check distance from each core list atom + do ij=1, core%N + j = core%int(1,ij) + if (present(debugfile)) call print(" core atom ij " // ij // " j " // j // " distance_min_image use_pos i " // use_pos(:,i) // " use_pos j " // use_pos(:,j) // " dist " // distance_min_image(at, use_pos(:,i), use_pos(:,j), shift_i(1:3)), file=debugfile) + if (distance_min_image(at,use_pos(:,i),use_pos(:,j),shift_i(1:3)) < radius) then + if (present(debugfile)) call print(" adding i " // i // " at " // use_pos(:,i) // " near j " // j // " at " // use_pos(:,j) // " dist " // distance_min_image(at, use_pos(:,i), use_pos(:,j), shift_i(1:3)), file=debugfile) + call append(region,(/i,shift_i(1:3)/)) + exit + endif + end do ! j + endif ! no centre, use core + enddo ! i + + else ! do_loop_atoms_no_connectivity + + if (.not. present(core)) then + RAISE_ERROR("do_loop_atoms_no_connectivity is false, trying connectivity hops, but no core list is specified", error) + endif + + if (present(debugfile)) call print(" connectivity hopping", file=debugfile) + if (present(debugfile) .and. present(radius)) call print(" have radius " // radius, file=debugfile) + if (present(debugfile)) call print(" present cluster_hopping_nneighb_only " // present(cluster_hopping_nneighb_only), file=debugfile) + if (present(debugfile) .and. present(cluster_hopping_nneighb_only)) call print(" cluster_hopping_nneighb_only " // cluster_hopping_nneighb_only, file=debugfile) + do_hopping_nneighb_only = optional_default(.true., cluster_hopping_nneighb_only) + do_force_hopping_nneighb_only = optional_default(.false., force_hopping_nneighb_only) + do_min_images_only = optional_default(.true., min_images_only) + if (do_use_avgpos) then + RAISE_ERROR("can't use avgpos with connectivity hops - make sure your connectivity is based on pos instead", error) + endif + + if (do_ignore_silica_residue) then + call print_message('WARNING', 'Overriding min_images_only since ignore_silica_residue=T') + do_min_images_only = .true. !lam81 + end if + ! start with core + call append(region,core) + + more_hops = .true. + cur_hop = 1 + do while (more_hops) + if (present(debugfile)) call print(' construct_region do_hopping_nneighb_only = ' // do_hopping_nneighb_only // ' do_min_images_only = '//do_min_images_only, file=debugfile) + if (present(debugfile)) call print(' doing hop ' // cur_hop, file=debugfile) + if (present(debugfile)) call print(' cutoffs ' // at%cutoff, file=debugfile) + more_hops = .false. + call bfs_step(at, region, nextlist, nneighb_only=(do_hopping_nneighb_only .and. .not. present(radius)) .or. do_force_hopping_nneighb_only, & + min_images_only=do_min_images_only, max_r=radius, alt_connect=alt_connect, debugfile=debugfile) + if (present(debugfile)) call print(" bfs_step returned nextlist%N " // nextlist%N, file=debugfile) + if (present(debugfile)) call print(nextlist, file=debugfile) + if (nextlist%N /= 0) then ! go over things in next hop + do ii=1, nextlist%N + i = nextlist%int(1,ii) + add_i = .true. + if (do_add_only_heavy_atoms) then + if (at%Z(i) == 1) cycle + endif + if (do_ignore_silica_residue .and. got_atom_res_number) then ! lam81 + if (atom_res_number(i) == res_num_silica) cycle ! lam81 + endif + if (present(debugfile)) call print(" i " // i // " is heavy or all atoms requested", file=debugfile) + if (present(radius)) then ! check to make sure we're close enough to core list + if (present(debugfile)) call print(" radius is present, check distance from core list", file=debugfile) + add_i = .false. + do ij=1, core%N + j = core%int(1,ij) + if (present(debugfile)) call print(" distance of ii " // ii // " i " // i // " at " // use_pos(:,i) // " from ij " // ij // " j " // j // " at " // use_pos(:,j) // " is " // distance_min_image(at,use_pos(:,i),use_pos(:,j),shift_i(1:3)), file=debugfile) + if (distance_min_image(at,use_pos(:,i),use_pos(:,j),shift_i(1:3)) <= radius) then + if (present(debugfile)) call print(" decide to add i", file=debugfile) + add_i = .true. + exit ! from ij loop + endif + end do ! ij + endif ! present(radius) + if (add_i) then + if (present(debugfile)) call print(" actually adding i", file=debugfile) + more_hops = .true. + call append(region, nextlist%int(1:4,ii)) + endif + end do + else ! nextlist%N == 0 + if (present(n_connectivity_hops)) then + if (n_connectivity_hops > 0) & + call print("WARNING: n_connectivity_hops = " // n_connectivity_hops // " cur_hop " // cur_hop // " but no atoms added") + endif + endif ! nextlist%N + + cur_hop = cur_hop + 1 + if (present(n_connectivity_hops)) then + if (cur_hop > n_connectivity_hops) more_hops = .false. + endif + end do ! while more_hops + + endif ! do_loop_atoms_no_connectivity + if (present(debugfile)) call print("leaving construct_region()", file=debugfile) + + end subroutine construct_region + + + subroutine update_active(this, nneightol, avgpos, reset, error) + type(Atoms) :: this + real(dp), optional :: nneightol + logical, optional :: avgpos, reset + integer, optional, intent(out) :: error + + type(Atoms), save :: nn_atoms + integer, pointer, dimension(:) :: nn, old_nn, active + integer :: i + real(dp) :: use_nn_tol + logical :: use_avgpos, do_reset + + INIT_ERROR(error) + + use_nn_tol = optional_default(this%nneightol, nneightol) + use_avgpos = optional_default(.true., avgpos) + do_reset = optional_default(.false., reset) + + ! First time copy entire atoms structure into nn_atoms and + ! add properties for nn, old_nn and active + if (reset .or. .not. is_initialised(nn_atoms)) then + nn_atoms = this + call add_property(this, 'nn', 0) + call add_property(this, 'old_nn', 0) + call add_property(this, 'active', 0) + + + end if + + if (this%N /= nn_atoms%N) then + RAISE_ERROR('update_actives: Number mismatch between this%N ('//this%N//') and nn_atoms%N ('//nn_atoms%N//')', error) + endif + + if (.not. assign_pointer(this, 'nn', nn)) then + RAISE_ERROR('update_actives: Atoms is missing "nn" property', error) + endif + + if (.not. assign_pointer(this, 'old_nn', old_nn)) then + RAISE_ERROR('update_actives: Atoms is missing "old_nn" property', error) + endif + + if (.not. assign_pointer(this, 'active', active)) then + RAISE_ERROR('update_actives: Atoms is missing "active" property', error) + endif + + call print('update_actives: recalculating nearest neighbour table', PRINT_VERBOSE) + if (use_avgpos .and. associated(this%avgpos)) then + call print('update_actives: using time averaged atomic positions', PRINT_VERBOSE) + nn_atoms%pos = this%avgpos + else + call print('update_actives: using instantaneous atomic positions', PRINT_VERBOSE) + nn_atoms%pos = this%pos + end if + !% Use hysteretic connect so we can work with relative cutoffs + call calc_connect_hysteretic(nn_atoms, cutoff_factor=use_nn_tol, & + cutoff_break_factor=use_nn_tol) + + nn = 0 + do i = 1,nn_atoms%N + nn(i) = n_neighbours(nn_atoms, i) + end do + + if (all(old_nn == 0)) old_nn = nn ! Special case for first time + + ! Decrement the active counts + where (active /= 0) active = active -1 + + ! Find newly active atoms + where (nn /= old_nn) active = 1 + + if (count(active == 1) /= 0) then + call print('update_actives: '//count(active == 1)//' atoms have become active.') + end if + + old_nn = nn + + end subroutine update_active + + + ! + !% Given an atoms structure and a list of quantum atoms, find X-H + !% bonds which have been cut and include the other atom of + !% the pair in the quantum list. + ! + subroutine add_cut_hydrogens(this,qmlist,heuristics_nneighb_only,verbosity,alt_connect) + + type(Atoms), intent(in), target :: this + type(Table), intent(inout) :: qmlist + integer, optional, intent(in) :: verbosity + logical, optional, intent(in) :: heuristics_nneighb_only + type(Connection), intent(in), optional, target :: alt_connect + + type(Table) :: neighbours, bonds, centre + logical :: more_atoms + integer :: i, j, n, nn, added + type(Connection), pointer :: use_connect + logical :: my_heuristics_nneighb_only + + ! Check for atomic connectivity + if (present(alt_connect)) then + use_connect => alt_connect + else + use_connect => this%connect + endif + + my_heuristics_nneighb_only = optional_default(.true., heuristics_nneighb_only) + + more_atoms = .true. + added = 0 + call allocate(centre,4,0,0,0,1) + + !Repeat while the search trigger is true + do while(more_atoms) + + more_atoms = .false. + + !Find nearest neighbours of the cluster + call bfs_step(this,qmlist,neighbours,nneighb_only=my_heuristics_nneighb_only,min_images_only=.true.,alt_connect=use_connect) + + !Loop over neighbours + do n = 1, neighbours%N + + i = neighbours%int(1,n) + + call wipe(centre) + call append(centre,(/i,0,0,0/)) + + ! Find atoms bonded to this neighbour + call bfs_step(this,centre,bonds,nneighb_only=my_heuristics_nneighb_only,min_images_only=.true.,alt_connect=use_connect) + + !Loop over these bonds + do nn = 1, bonds%N + + j = bonds%int(1,nn) + + !Try to find j in the qmlist + if (find_in_array(int_part(qmlist,1),j)/=0) then + !We have a cut bond. If i or j are hydrogen then add i to the + !quantum list and trigger another search after this one + if (this%Z(i)==1 .or. this%Z(j)==1) then + call append(qmlist,(/i,0,0,0/)) + if (present(verbosity)) then + if (verbosity >= PRINT_NORMAL) call print('Add_Cut_Hydrogens: Added atom '//i//', neighbour of atom '//j) + end if + more_atoms = .true. + added = added + 1 + exit !Don't add the same atom more than once + end if + end if + + end do + + end do + + end do + + !Report findings + if (present(verbosity)) then + if (verbosity >= PRINT_NORMAL) then + write(line,'(a,i0,a)')'Add_Cut_Hydrogens: Added ',added,' atoms to quantum region' + call print(line) + end if + end if + + call finalise(centre) + call finalise(bonds) + call finalise(neighbours) + + end subroutine add_cut_hydrogens + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X GROUP CONVERSION +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + !% Convert a constrained atom's group to a normal group prior to quantum treatment + !% The constraints are not deleted, just ignored. The number of degrees of freedom + !% of the system is also updated. + ! + subroutine constrained_to_quantum(this,i) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i + integer :: g!, n, j, a1, a2 + + g = this%group_lookup(i) + + if (this%group(g)%type == TYPE_CONSTRAINED) then + write(line,'(2(a,i0),a)')' INFO: Converting group ',g,' from Constrained to Quantum' + call print(line) + + !Change the group type + call set_type(this%group(g),TYPE_ATOM) + + !Update the number of degrees of freedom (add 1 per removed constraint) + this%Ndof = this%Ndof + Group_N_Objects(this%group(g)) + + !Thermalize the released constraints +! do n = 1, group_n_objects(this%group(g)) +! +! j = group_nth_object(this%group(g),n) +! +! !If not a two body constraint then go to the next one. +! if (this%constraint(j)%N /= 2) cycle +! +! !Get the indices of the atoms in this constraint +! a1 = this%constraint(j)%atom(1) +! a2 = this%constraint(j)%atom(2) +! +! call thermalize_bond(this,a1,a2,this%sim_temp) +! +! end do + +! call thermalize_group(this,g,this%sim_temp) + + end if + + end subroutine constrained_to_quantum + + ! + !% When a constraint is released as a molecule drifts into the quantum region the + !% new, unconstrained degree of freedom has zero temperature. This routine adds + !% velocities in the directions between atoms which make up two body constraints + !% at a specified temperature + ! + subroutine thermalize_bond(this,i,j,T) + + type(DynamicalSystem), intent(inout) :: this !% The dynamical system + integer, intent(in) :: i,j !% The two atoms + real(dp), intent(in) :: T !% Temperature + real(dp) :: meff ! effective mass + real(dp), dimension(3) :: u_hat ! unit vector between the atoms + real(dp) :: w, wi, wj, & ! magnitude of velocity component in bond direction + mi, mj ! masses of the atoms + real(dp) :: E0,E1 ! kinetic energy in bond before and after + real(dp), save :: Etot = 0.0_dp ! cumulative energy added to the system + real(dp), save :: Eres = 0.0_dp ! cumulative energy already in bonds (QtoC error) + real(dp) :: r, v ! relative distance and velocity + + call print('Thermalize_Bond: Thermalizing bond '//i//'--'//j) + + ! Find unit vector along bond and current relative velocity + call distance_relative_velocity(this%atoms,i,j,r,v) + + ! Find unit vector between atoms + u_hat = diff_min_image(this%atoms,i,j) + u_hat = u_hat / norm(u_hat) + + ! Calculate effective mass + mi = ElementMass(this%atoms%Z(i)) + mj = ElementMass(this%atoms%Z(j)) + meff = mi * mj / (mi + mj) + + ! Calculate energy currently stored in this bond (should be zero) + E0 = 0.5_dp * meff * v * v + Eres = Eres + E0 + + call print('Thermalize_Bond: Bond currently contains '//round(E0,8)//' eV') + call print('Thermalize_Bond: Residual energy encountered so far: '//round(Eres,8)//' eV') + + ! Draw a velocity for this bond + w = gaussian_velocity_component(meff,T) + w = w - v ! Adjust for any velocity which the bond already had + + ! Distribute this between the two atoms, conserving momentum + wi = (meff / mi) * w + wj = -(meff / mj) * w + + this%atoms%velo(:,i) = this%atoms%velo(:,i) + wi * u_hat + this%atoms%velo(:,j) = this%atoms%velo(:,j) + wj * u_hat + + call distance_relative_velocity(this%atoms,i,j,r,v) + E1 = 0.5_dp * meff * v * v + + Etot = Etot + E1 - E0 + + call print('Thermalize_Bond: Added '//round(E1-E0,8)//' eV to bond') + call print('Thermalize_Bond: Added '//round(Etot,8)//' eV to the system so far') + + end subroutine thermalize_bond + + ! + !% Convert a quantum atom's group to a constrained group. The group is searched for + !% two body constraints, which are assumed to be bond length or time dependent bond length + !% constraints. The required final length is extracted, and a new time dependent bond length + !% constraint is imposed, taking the current length and relative velocity along the bond + !% to the required values, in the time given by smoothing_time. + !% + !% Any other constraints are left untouched. + ! + subroutine quantum_to_constrained(this,i,smoothing_time) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: i + real(dp), intent(in) :: smoothing_time + integer, save :: CUBIC_BONDLENGTH_SQ_FUNC + logical, save :: first_call = .true. + integer :: g, j, n, a1, a2, datalength + real(dp) :: x0,y0,y0p,x1,y1,y1p, coeffs(4), t, dE, m1, m2, meff + real(dp), save :: Etot = 0.0_dp + + !Register the constraint function if this is the first call + if (first_call) then + CUBIC_BONDLENGTH_SQ_FUNC = Register_Constraint(CUBIC_BONDLENGTH_SQ) + first_call = .false. + end if + + g = this%group_lookup(i) + + if (this%group(g)%type == TYPE_ATOM) then + write(line,'(2(a,i0),a)')' INFO: Converting group ',g,' from Quantum to Constrained' + call print(line) + + !Change the group type + call set_type(this%group(g),TYPE_CONSTRAINED) + + !Update the number of degrees of freedom (subtract 1 per added constraint) + this%Ndof = this%Ndof - Group_N_Objects(this%group(g)) + + !Loop over constraints + do n = 1, Group_N_Objects(this%group(g)) + + j = Group_Nth_Object(this%group(g),n) + + !If not a two body constraint then go to the next one. + if (this%constraint(j)%N /= 2) cycle + + !Get the indices of the atoms in this constraint + a1 = this%constraint(j)%atom(1) + a2 = this%constraint(j)%atom(2) + + !Detect the type of constraint (simple bondlength or time dependent bond length) + !from the size of the data array (1 or 6) + datalength = size(this%constraint(j)%data) + select case(datalength) + case(1) + !Simple bond length: the required final length is the only entry + y1 = this%constraint(j)%data(1) + case(6) + !Time dependent bond length: the final length is the polynomial evaluated at the end point + coeffs = this%constraint(j)%data(1:4) + t = this%constraint(j)%data(6) + y1 = ((coeffs(1)*t + coeffs(2))*t + coeffs(3))*t + coeffs(4) + case default + !This isn't a known bond length constraint. Set y1 to a negative value. + y1 = -1.0_dp + end select + + !If an existing bond length constraint has been found then set up a time dependent constraint + if (y1 > 0.0_dp) then + + call print('Quantum_to_Constrained: Reconstraining bond '//a1//'--'//a2) + + x0 = this%t + call distance_relative_velocity(this%atoms,a1,a2,y0,y0p) + x1 = this%t + smoothing_time + y1p = 0.0_dp + + !Find the coefficients of the cubic which fits these boundary conditions + call fit_cubic(x0,y0,y0p,x1,y1,y1p,coeffs) + + !Change the constraint + call ds_amend_constraint(this,j,CUBIC_BONDLENGTH_SQ_FUNC,(/coeffs,x0,x1/)) + + !Work out the amount of energy which will be removed + m1 = ElementMass(this%atoms%Z(a1)) + m2 = ElementMass(this%atoms%Z(a2)) + meff = m1 * m2 / (m1 + m2) + + dE = 0.5_dp * meff * y0p * y0p + Etot = Etot + dE + + call print('Quantum_to_Constrained: Gradually removing '//round(dE,8)//' eV from bond') + call print('Quantum_to_Constrained: Will have removed approximately '//round(Etot,8)//' eV in total') + + end if + + end do + + end if + + end subroutine quantum_to_constrained + + + subroutine thermalize_group(this,g,T) + + type(DynamicalSystem), intent(inout) :: this + integer, intent(in) :: g + real(dp), intent(in) :: T + + integer :: i, j, k + real(dp) :: mi, mj, mk, mij, mik, mjk, vij, vik, vjk, rij, rik, rjk, gij, gik, gjk + real(dp) :: ri(3), rj(3), rk(3), Rcom(3) + real(dp) :: A(9,9), b(9), A_inv(9,9), x(9) + + real(dp) :: dEij, dEik, dEjk + real(dp), save :: Etot = 0.0_dp + + ! Get atoms + i = this%group(g)%atom(1) + j = this%group(g)%atom(2) + k = this%group(g)%atom(3) + + ! Get shifted positions + ri = 0.0_dp + rj = diff_min_image(this%atoms,i,j) + rk = diff_min_image(this%atoms,i,k) + + ! Get separations and current bond velocities + call distance_relative_velocity(this%atoms,i,j,rij,vij) + call distance_relative_velocity(this%atoms,i,k,rik,vik) + call distance_relative_velocity(this%atoms,j,k,rjk,vjk) + + ! Calculate masses + mi = ElementMass(this%atoms%Z(i)) + mj = ElementMass(this%atoms%Z(j)) + mk = ElementMass(this%atoms%Z(k)) + mij = mi * mj / (mi + mj) + mik = mi * mk / (mi + mk) + mjk = mj * mk / (mj + mk) + + ! Calculate centre of mass + Rcom = (mi*ri + mj*rj + mk*rk) / (mi+mj+mk) + + ! Select a gaussian distributed velocity adjustment for each bond + gij = gaussian_velocity_component(mij,T) + gik = gaussian_velocity_component(mik,T) + gjk = gaussian_velocity_component(mjk,T) + vij = gij - vij + vik = gik - vik + vjk = gjk - vjk + + ! Build matrix... + A = 0.0_dp + b = 0.0_dp + + ! Momentum conservation + A(1,1) = mi; A(2,2) = mi; A(3,3) = mi + A(1,4) = mj; A(2,5) = mj; A(3,6) = mj + A(1,7) = mk; A(2,8) = mk; A(3,9) = mk + + ! Angular momentum conservation + A(4,2) = -mi * (ri(3) - Rcom(3)); A(4,3) = mi * (ri(2) - Rcom(2)) + A(4,5) = -mj * (rj(3) - Rcom(3)); A(4,6) = mj * (rj(2) - Rcom(2)) + A(4,8) = -mk * (rk(3) - Rcom(3)); A(4,9) = mk * (rk(2) - Rcom(2)) + + A(5,1) = mi * (ri(3) - Rcom(3)); A(5,3) = -mi * (ri(1) - Rcom(1)) + A(5,4) = mj * (rj(3) - Rcom(3)); A(5,6) = -mj * (rj(1) - Rcom(1)) + A(5,7) = mk * (rk(3) - Rcom(3)); A(5,9) = -mk * (rk(1) - Rcom(1)) + + A(6,1) = -mi * (ri(2) - Rcom(2)); A(6,2) = mi * (ri(1) - Rcom(1)) + A(6,4) = -mj * (rj(2) - Rcom(2)); A(6,5) = mj * (rj(1) - Rcom(1)) + A(6,7) = -mk * (rk(2) - Rcom(2)); A(6,8) = mk * (rk(1) - Rcom(1)) + + ! Bond length velocities + A(7,1) = ri(1) - rj(1); A(7,2) = ri(2) - rj(2); A(7,3) = ri(3) - rj(3) + A(7,4) = rj(1) - ri(1); A(7,5) = rj(2) - ri(2); A(7,6) = rj(3) - ri(3) + b(7) = rij * vij + + A(8,1) = ri(1) - rk(1); A(8,2) = ri(2) - rk(2); A(8,3) = ri(3) - rk(3) + A(8,7) = rk(1) - ri(1); A(8,8) = rk(2) - ri(2); A(8,9) = rk(3) - ri(3) + b(8) = rik * vik + + A(9,4) = rj(1) - rk(1); A(9,5) = rj(2) - rk(2); A(9,6) = rj(3) - rk(3) + A(9,7) = rk(1) - rj(1); A(9,8) = rk(2) - rj(2); A(9,9) = rk(3) - rj(3) + b(9) = rjk * vjk + + ! Invert + call inverse(A,A_inv) + x = A_inv .mult. b + + call print('Momentum before update = '//momentum(this,(/i,j,k/))) + + call print('Angular momentum before update = '//& + (mi*((ri-Rcom) .cross. this%atoms%velo(:,i)) + & + mj*((rj-Rcom) .cross. this%atoms%velo(:,j)) + & + mk*((rk-Rcom) .cross. this%atoms%velo(:,k)))) + + dEij = -bond_energy(this,i,j) + dEik = -bond_energy(this,i,k) + dEjk = -bond_energy(this,j,k) + + this%atoms%velo(:,i) = this%atoms%velo(:,i) + x(1:3) + this%atoms%velo(:,j) = this%atoms%velo(:,j) + x(4:6) + this%atoms%velo(:,k) = this%atoms%velo(:,k) + x(7:9) + + dEij = dEij + bond_energy(this,i,j) + dEik = dEik + bond_energy(this,i,k) + dEjk = dEjk + bond_energy(this,j,k) + + call print('Momentum after update = '//momentum(this,(/i,j,k/))) + + call print('Angular momentum after update = '//& + (mi*((ri-Rcom) .cross. this%atoms%velo(:,i)) + & + mj*((rj-Rcom) .cross. this%atoms%velo(:,j)) + & + mk*((rk-Rcom) .cross. this%atoms%velo(:,k)))) + + ! Now check the result + + call print('Required velocity for bond '//i//'--'//j//': '//gij) + call print('Required velocity for bond '//i//'--'//k//': '//gik) + call print('Required velocity for bond '//j//'--'//k//': '//gjk) + + call distance_relative_velocity(this%atoms,i,j,rij,vij) + call distance_relative_velocity(this%atoms,i,k,rik,vik) + call distance_relative_velocity(this%atoms,j,k,rjk,vjk) + + call print('') + + call print('Actual velocity for bond '//i//'--'//j//': '//vij) + call print('Actual velocity for bond '//i//'--'//k//': '//vik) + call print('Actual velocity for bond '//j//'--'//k//': '//vjk) + + call print('Energy added to bond '//i//'--'//j//': '//dEij) + call print('Energy added to bond '//i//'--'//k//': '//dEik) + call print('Energy added to bond '//j//'--'//k//': '//dEjk) + + Etot = Etot + dEij + dEik + dEjk + + call print('Total energy added so far = '//Etot) + + end subroutine thermalize_group + + function bond_energy(this,i,j) + + type(DynamicalSystem), intent(in) :: this + integer, intent(in) :: i, j + real(dp) :: bond_energy + + real(dp) :: mi, mj, vij, rij + + mi = ElementMass(this%atoms%Z(i)) + mj = ElementMass(this%atoms%Z(j)) + + call distance_relative_velocity(this%atoms,i,j,rij,vij) + + bond_energy = 0.5_dp * mi * mj * vij * vij / (mi + mj) + + end function bond_energy + + !% Updates the core QM flags saved in 'hybrid' and 'hybrid_mark' + !% properties. Do this hysteretically, from 'R_inner' to 'R_outer' + !% around 'origin' or 'atomlist', that is the centre of the QM + !% region (a position in space or a list of atoms). Also saves the + !% old 'hybrid_mark' property in 'old_hybrid_mark' property. + !% optionally correct selected region with heuristics (as coded in + !% :func:`create_cluster_info_from_mark`()) + ! + subroutine create_pos_or_list_centred_hybrid_region(my_atoms,R_inner,R_outer,origin, atomlist,use_avgpos,add_only_heavy_atoms, & + cluster_hopping_nneighb_only,cluster_heuristics_nneighb_only,min_images_only,use_create_cluster_info, create_cluster_info_args, list_changed, mark_postfix, & + ignore_silica_residue, res_num_silica, error) ! lam81 + + type(Atoms), intent(inout) :: my_atoms + real(dp), intent(in) :: R_inner + real(dp), intent(in) :: R_outer + real(dp), optional, intent(in) :: origin(3) + type(Table), optional, intent(in) :: atomlist !the seed of the QM region + logical, optional, intent(in) :: use_avgpos, add_only_heavy_atoms, cluster_hopping_nneighb_only, cluster_heuristics_nneighb_only, min_images_only, use_create_cluster_info + character(len=*), optional, intent(in) :: create_cluster_info_args + logical, optional, intent(out) :: list_changed + character(len=*), optional, intent(in) :: mark_postfix + integer, optional, intent(out) :: error + + logical :: do_hopping_nneighb_only, do_heuristics_nneighb_only + logical :: my_use_create_cluster_info + type(Atoms) :: atoms_for_add_cut_hydrogens + type(Table) :: core, old_core, old_all_but_term + integer, pointer :: hybrid_p(:), hybrid_mark_p(:), old_hybrid_mark_p(:) + character(len=STRING_LENGTH) :: my_create_cluster_info_args, my_mark_postfix + integer, pointer :: hybrid_region_core_tmp_p(:) + type(Table) :: padded_cluster_info + + logical, optional, intent(in) :: ignore_silica_residue ! lam81 + integer, optional, intent(in) :: res_num_silica ! lam81 + + INIT_ERROR(error) + + my_use_create_cluster_info = optional_default(.false., use_create_cluster_info) + + do_hopping_nneighb_only = optional_default(.false., cluster_hopping_nneighb_only) + do_heuristics_nneighb_only = optional_default(.true., cluster_heuristics_nneighb_only) + + if (count((/present(origin),present(atomlist)/))/=1) then + RAISE_ERROR('create_pos_or_list_centred_hybrid_mark: Exactly 1 of origin and atomlist must be present.', error) + endif + + my_mark_postfix = optional_default("", trim(mark_postfix)) + + call map_into_cell(my_atoms) + + ! save various subsets of atoms based on old hybrid marks + call allocate(core,4,0,0,0,0) + call allocate(old_core,4,0,0,0,0) + call allocate(old_all_but_term,4,0,0,0,0) + call get_hybrid_list(my_atoms,old_core,active_trans_only=.true., int_property='hybrid_mark'//trim(my_mark_postfix), error=error) + PASS_ERROR_WITH_INFO("create_pos_or_list_centred_hybrid_region getting old core", error) + call get_hybrid_list(my_atoms,core,active_trans_only=.true., int_property='hybrid_mark'//trim(my_mark_postfix), error=error) + PASS_ERROR_WITH_INFO("create_pos_or_list_centred_hybrid_region getting core", error) + call get_hybrid_list(my_atoms,old_all_but_term, all_but_term=.true., int_property='hybrid_mark'//trim(my_mark_postfix), error=error) + PASS_ERROR_WITH_INFO("create_pos_or_list_centred_hybrid_region getting all but term", error) + + ! Build the new hysteretic QM core based on distances from point/list + if (present(atomlist)) then + call print("create_pos_or_list_centred_hybrid_region calling construct_hysteretic_region", verbosity=PRINT_NERD) + call construct_hysteretic_region(region=core,at=my_atoms,core=atomlist,loop_atoms_no_connectivity=.false., & + inner_radius=R_inner,outer_radius=R_outer, use_avgpos=use_avgpos, add_only_heavy_atoms=add_only_heavy_atoms, & + cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, min_images_only=min_images_only, & + ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica, error=error) !NB , debugfile=mainlog) lam81 + else !present origin + call print("create_pos_or_list_centred_hybrid_region calling construct_hysteretic_region", verbosity=PRINT_NERD) + call construct_hysteretic_region(region=core,at=my_atoms,centre=origin,loop_atoms_no_connectivity=.true., & + inner_radius=R_inner,outer_radius=R_outer, use_avgpos=use_avgpos, add_only_heavy_atoms=add_only_heavy_atoms, & + cluster_hopping_nneighb_only=cluster_hopping_nneighb_only, min_images_only=min_images_only, & + ignore_silica_residue=ignore_silica_residue, res_num_silica=res_num_silica, error=error) !NB , debugfile=mainlog) lam81 + endif + PASS_ERROR_WITH_INFO("create_pos_or_list_centred_hybrid_region constructing hysteretic region", error) + + ! call create_cluster_info_from_mark, if requested, for various chemical intuition fixes to core + if (my_use_create_cluster_info) then + call add_property(my_atoms, "hybrid_region_core_tmp", HYBRID_NO_MARK, ptr=hybrid_region_core_tmp_p) + hybrid_region_core_tmp_p(int_part(core,1)) = HYBRID_ACTIVE_MARK + if (present(create_cluster_info_args) .and. (present(cluster_hopping_nneighb_only) .or. present(cluster_heuristics_nneighb_only))) then + RAISE_ERROR("Got both create_cluster_info_args and (do_hopping_nneighb_only or do_heuristics_nneighb_only), but these conflict", error) + endif + my_create_cluster_info_args = optional_default("terminate=F cluster_hopping_nneighb_only="//do_hopping_nneighb_only// & + " cluster_heuristics_nneighb_only="//do_heuristics_nneighb_only//" cluster_allow_modification", create_cluster_info_args) + padded_cluster_info = create_cluster_info_from_mark(my_atoms, my_create_cluster_info_args, mark_name="hybrid_region_core_tmp") + call finalise(core) + call initialise(core, Nint=4, Nreal=0, Nstr=0, Nlogical=0, max_length=padded_cluster_info%N) + call append(core, blank_rows=padded_cluster_info%N) + core%int(1:4,1:padded_cluster_info%N) = padded_cluster_info%int(1:4,1:padded_cluster_info%N) + call remove_property(my_atoms,"hybrid_region_core_tmp") + endif + +!TO BE OPTIMIZED : add avgpos to add_cut_hydrogen + ! add cut hydrogens, according to avgpos + atoms_for_add_cut_hydrogens = my_atoms + atoms_for_add_cut_hydrogens%oldpos = my_atoms%avgpos + atoms_for_add_cut_hydrogens%avgpos = my_atoms%avgpos + atoms_for_add_cut_hydrogens%pos = my_atoms%avgpos + + !% Use hysteretic connectivity calculator so we can work with relative cutoffs + call calc_connect_hysteretic(atoms_for_add_cut_hydrogens, cutoff_factor=DEFAULT_NNEIGHTOL, & + cutoff_break_factor=DEFAULT_NNEIGHTOL) + + + call add_cut_hydrogens(atoms_for_add_cut_hydrogens,core) + call finalise(atoms_for_add_cut_hydrogens) + + ! check changes in QM list and set the new QM list + if (present(list_changed)) then + list_changed = check_list_change(old_list=old_core,new_list=core) + if (list_changed) call print('QM list around the origin has changed') + endif + + ! sadd old hybrid_mark property + call add_property(my_atoms,'old_hybrid_mark'//trim(my_mark_postfix),HYBRID_NO_MARK) + if (.not. assign_pointer(my_atoms,'old_hybrid_mark'//trim(my_mark_postfix),old_hybrid_mark_p)) then + RAISE_ERROR("create_pos_or_list_centred_hybrid_region couldn't get old_hybrid_mark"//trim(my_mark_postfix)//" property", error) + endif + ! update QM_flag of my_atoms + if (.not. assign_pointer(my_atoms,'hybrid_mark'//trim(my_mark_postfix),hybrid_mark_p)) then + RAISE_ERROR("create_pos_or_list_centred_hybrid_region couldn't get hybrid_mark"//trim(my_mark_postfix)//" property", error) + endif + ! save old_hybrid_mark + old_hybrid_mark_p(1:my_atoms%N) = hybrid_mark_p(1:my_atoms%N) + ! default to NO_MARK + hybrid_mark_p(1:my_atoms%N) = HYBRID_NO_MARK + ! anything which was marked before (except termination) is now BUFFER (so hysteretic buffer, later, has correct previous values) + hybrid_mark_p(int_part(old_all_but_term,1)) = HYBRID_BUFFER_MARK + ! anything returned in the core list is now ACTIVE + hybrid_mark_p(int_part(core,1)) = HYBRID_ACTIVE_MARK + + ! update hybrid property of my_atoms + if (.not. assign_pointer(my_atoms,'hybrid'//trim(my_mark_postfix),hybrid_p)) then + RAISE_ERROR("create_pos_or_list_centred_hybrid_region couldn't get hybrid"//trim(my_mark_postfix)//" property", error) + endif + hybrid_p(1:my_atoms%N) = 0 + hybrid_p(int_part(core,1)) = 1 + + call finalise(core) + call finalise(old_core) + call finalise(old_all_but_term) + + end subroutine create_pos_or_list_centred_hybrid_region + +! !% Returns a $hybridlist$ table with the atom indices whose $cluster_mark$ +! !% (or optionally any $int_property$) property takes no greater than $hybridflag$ positive value. +! ! +! subroutine get_hybrid_list(my_atoms,hybridflag,hybridlist,int_property,get_up_to_mark_value) +! +! type(Atoms), intent(in) :: my_atoms +! integer, intent(in) :: hybridflag +! type(Table), intent(out) :: hybridlist +! character(len=*), optional, intent(in) :: int_property +! logical, intent(in), optional :: get_up_to_mark_value +! +! integer, pointer :: mark_p(:) +! integer :: i +! logical :: do_get_up_to_mark_value +! +! do_get_up_to_mark_value = optional_default(.false., get_up_to_mark_value) +! +! if (present(int_property)) then +! if (.not. assign_pointer(my_atoms, trim(int_property), mark_p)) then +! RAISE_ERROR("get_hybrid_list_int couldn't get int_property='"//trim(int_property)//"'", error) +! endif +! else +! if (.not. assign_pointer(my_atoms, 'cluster_mark', mark_p)) then +! RAISE_ERROR("get_hybrid_list_int couldn't get default int_property='cluster_mark'", error) +! endif +! endif +! +! call initialise(hybridlist,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_hybrid_atoms entries +! if (do_get_up_to_mark_value) then +! do i=1,my_atoms%N +! ! if (my_atoms%data%int(hybrid_flag_index,i).gt.0.and. & +! ! my_atoms%data%int(hybrid_flag_index,i).le.hybridflag) & +! if (mark_p(i) > 0 .and. mark_p(i) <= hybridflag) & +! call append(hybridlist,(/i,0,0,0/)) +! enddo +! else +! do i=1,my_atoms%N +! ! if (my_atoms%data%int(hybrid_flag_index,i).eq.hybridflag) & +! if (mark_p(i) == hybridflag) call append(hybridlist,(/i,0,0,0/)) +! enddo +! endif +! +! if (hybridlist%N.eq.0) call print('Empty QM list with cluster_mark '//hybridflag,verbosity=PRINT_SILENT) +! +! end subroutine get_hybrid_list + + !% Checks and reports the changes between two tables, $old_qmlist$ and $new_qmlist$. + ! + function check_list_change(old_list,new_list) result(list_changed) + + type(Table), intent(in) :: old_list, new_list + integer :: i + logical :: list_changed + + list_changed = .false. + if (old_list%N.ne.new_list%N) then + call print ('list has changed: new number of atoms is: '//new_list%N//', was: '//old_list%N) + list_changed = .true. + else + if (any(old_list%int(1,1:old_list%N).ne.new_list%int(1,1:new_list%N))) then + do i=1,old_list%N + if (.not.find_in_array(int_part(old_list,1),(new_list%int(1,i))).gt.0) then + call print('list has changed: atom '//new_list%int(1,i)//' has entered the region') + list_changed = .true. + endif + if (.not.find_in_array(int_part(new_list,1),(old_list%int(1,i))).gt.0) then + call print('list has changed: atom '//old_list%int(1,i)//' has left the region') + list_changed = .true. + endif + enddo + endif + endif + + end function check_list_change + + !% return list of atoms that have various subsets of hybrid marks set + subroutine get_hybrid_list(at,hybrid_list,all_but_term,active_trans_only,int_property, error) + type(Atoms), intent(in) :: at !% object to scan for marked atoms + type(Table), intent(out) :: hybrid_list !% on return, list of marked atoms + logical, intent(in), optional :: all_but_term !% if present and true, select all marked atoms that aren't TERM + logical, intent(in), optional :: active_trans_only !% if present and true, select all atoms marked ACTIVE or TRANS + !% exactly one of all_but_term and active_trans_only must be present and true + character(len=*), optional, intent(in) :: int_property !% if present, property to check, default cluster_mark + integer, optional, intent(out) :: error + + integer :: i + integer, pointer :: hybrid_mark(:) + logical :: my_all_but_term, my_active_trans_only + character(STRING_LENGTH) :: my_int_property + + INIT_ERROR(error) + + if (.not. present(all_but_term) .and. .not. present(active_trans_only)) then + RAISE_ERROR("get_hybrid_list called with neither all_but_term nor active_trans_only present", error) + endif + + my_all_but_term = optional_default(.false., all_but_term) + my_active_trans_only = optional_default(.false., active_trans_only) + + if ((my_all_but_term .and. my_active_trans_only) .or. (.not. my_all_but_term .and. .not. my_active_trans_only)) then + RAISE_ERROR("get_hybrid_list needs exactly one of all_but_term=" // all_but_term // " and active_trans_only="//my_active_trans_only, error) + endif + + my_int_property = '' + if (present(int_property)) then + my_int_property = trim(int_property) + else + my_int_property = "cluster_mark" + endif + if (.not.(assign_pointer(at, trim(my_int_property), hybrid_mark))) then + RAISE_ERROR("get_hybrid_list couldn't find "//trim(my_int_property)//" field", error) + endif + + call initialise(hybrid_list,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries + do i=1, at%N + if (my_all_but_term) then + if (hybrid_mark(i) /= HYBRID_NO_MARK .and. hybrid_mark(i) /= HYBRID_TERM_MARK) call append(hybrid_list,(/i,0,0,0/)) + else if (my_active_trans_only) then + if (hybrid_mark(i) == HYBRID_ACTIVE_MARK .or. hybrid_mark(i) == HYBRID_TRANS_MARK) call append(hybrid_list,(/i,0,0,0/)) + else + RAISE_ERROR("impossible! get_hybrid_list has no selection mode set", error) + endif + end do + + if (hybrid_list%N.eq.0) call print('get_hybrid_list returns empty hybrid list with field '//trim(my_int_property)// & + ' all_but_term ' // my_all_but_term // ' active_trans_only ' // my_active_trans_only ,PRINT_ALWAYS) + end subroutine get_hybrid_list + + +end module clusters_module diff --git a/src/libAtoms/error.F90 b/src/libAtoms/error.F90 new file mode 100644 index 0000000000..1ee1a560d8 --- /dev/null +++ b/src/libAtoms/error.F90 @@ -0,0 +1,425 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Exception handling +!X +!% This modules keeps track an error stack. When an error occurs a list +!% of files/lines that allow to trace back the position in the code where +!% the error occured first is constructed. +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module error_module +#ifdef _MPI +#ifndef _OLDMPI + use mpi +#endif +#endif + implicit none +#ifdef _MPI +#ifdef _OLDMPI +include 'mpif.h' +#endif +#endif + + private + + ! --- + + integer, parameter :: ERROR_STACK_SIZE = 100 + + integer, parameter :: ERROR_DOC_LENGTH = 1000 + integer, parameter :: ERROR_FN_LENGTH = 100 + + ! --- + + !% Error kinds + integer, parameter :: ERROR_NONE = 0 + integer, parameter :: ERROR_UNSPECIFIED = -1 + integer, parameter :: ERROR_IO = -2 + integer, parameter :: ERROR_IO_EOF = -3 + integer, parameter :: ERROR_MPI = -4 + integer, parameter :: ERROR_MINIM_NOT_CONVERGED = -5 + + !% Strings + integer, parameter :: ERROR_STR_LENGTH = 20 + character(ERROR_STR_LENGTH), parameter :: ERROR_STR_UNSPECIFIED = & + "unspecified" + character(ERROR_STR_LENGTH), parameter :: ERROR_STR_IO = "IO" + character(ERROR_STR_LENGTH), parameter :: ERROR_STR_IO_EOF = "IO EOF" + character(ERROR_STR_LENGTH), parameter :: ERROR_STR_MPI = "MPI" + character(ERROR_STR_LENGTH), parameter :: ERROR_STR_MINIM_NOT_CONVERGED = & + "MINIM_NOT_CONVERGED" + character(ERROR_STR_LENGTH), parameter :: ERROR_STRINGS(5) = & + (/ ERROR_STR_UNSPECIFIED, ERROR_STR_IO, ERROR_STR_IO_EOF, & + ERROR_STR_MPI, ERROR_STR_MINIM_NOT_CONVERGED /) + + public :: ERROR_NONE, ERROR_UNSPECIFIED, ERROR_IO, ERROR_IO_EOF, ERROR_MPI + public :: ERROR_MINIM_NOT_CONVERGED + + ! --- + + type ErrorDescriptor + integer :: kind !% kind of error + logical :: has_doc !% does the documentation string exist? + character(ERROR_DOC_LENGTH) :: doc !% documentation string + character(ERROR_FN_LENGTH) :: fn !% file name where the error occured + integer :: line !% code line where the error occured + endtype ErrorDescriptor + + ! --- + + save + integer :: error_stack_position = 0 !% If this is zero, no error has occured + integer :: error_mpi_myid = 0 !% MPI rank of process. Initialised by system_initialise() + type(ErrorDescriptor) :: error_stack(ERROR_STACK_SIZE) !% Error stack + + ! --- + + public :: system_abort + interface system_abort + module procedure error_abort_with_message + endinterface + + interface quippy_running + function quippy_running() + logical :: quippy_running + end function quippy_running + end interface quippy_running + + interface f90wrap_abort + subroutine f90wrap_abort(message) + character(*), intent(in) :: message + end subroutine f90wrap_abort + end interface f90wrap_abort + + public :: error_abort + interface error_abort + module procedure error_abort_from_stack + endinterface + + public :: error_clear_stack + + public :: push_error, push_error_with_info + public :: get_error_string_and_clear, clear_error + + ! --- + + public :: error_unit, error_mpi_myid + integer :: error_unit = -1 + +contains + + !% Push a new error callback to the stack + subroutine push_error(fn, line, kind) + implicit none + + character(*), intent(in) :: fn + integer, intent(in) :: line + integer, intent(in), optional :: kind + + ! --- + + !$omp critical + + error_stack_position = error_stack_position + 1 + + if (error_stack_position > ERROR_STACK_SIZE) then + call system_abort("Fatal error: Error stack size too small.") + endif + + if (present(kind)) then + error_stack(error_stack_position)%kind = kind + else + error_stack(error_stack_position)%kind = ERROR_UNSPECIFIED + endif + error_stack(error_stack_position)%fn = fn + error_stack(error_stack_position)%line = line + + !$omp end critical + + endsubroutine push_error + + subroutine error_clear_stack() + error_stack_position = 0 + end subroutine error_clear_stack + + + !% Push a new information string onto the error stack + subroutine push_error_with_info(doc, fn, line, kind) + implicit none + + character(*), intent(in) :: doc + character(*), intent(in) :: fn + integer, intent(in) :: line + integer, intent(in), optional :: kind + + ! --- + + !$omp critical + + error_stack_position = error_stack_position + 1 + + if (error_stack_position > ERROR_STACK_SIZE) then + call system_abort("Fatal error: Error stack size too small.") + endif + + if (present(kind)) then + error_stack(error_stack_position)%kind = kind + else + error_stack(error_stack_position)%kind = ERROR_UNSPECIFIED + endif + error_stack(error_stack_position)%fn = fn + error_stack(error_stack_position)%line = line + error_stack(error_stack_position)%has_doc = .true. + error_stack(error_stack_position)%doc = doc + + !$omp end critical + + endsubroutine push_error_with_info + + + !% This error has been handled, clear it. + subroutine clear_error(error) + implicit none + + integer, intent(inout) :: error + + ! --- + + error = ERROR_NONE + + error_stack_position = 0 + + endsubroutine clear_error + + + !% Construct a string describing the error. + function get_error_string_and_clear(error) result(str) + use iso_c_binding + + implicit none + + integer, intent(inout), optional :: error + + character(ERROR_DOC_LENGTH) :: str + + ! --- + + integer :: i + character(10) :: linestr + + ! --- + + if (present(error)) then + if (-error < lbound(ERROR_STRINGS, 1) .or. & + -error > ubound(ERROR_STRINGS, 1)) then + call system_abort("Fatal: error descriptor out of bounds. Did you initialise the error variable?") + endif + + str = "Traceback (most recent call last - error kind " & + // trim(ERROR_STRINGS(-error)) // "):" + else + str = "Traceback (most recent call last)" + endif + do i = error_stack_position, 1, -1 + + write (linestr, '(I10)') error_stack(i)%line + + if (error_stack(i)%has_doc) then + + str = trim(str) // C_NEW_LINE // & + ' File "' // & + trim(error_stack(i)%fn) // & + '", line ' // & + trim(adjustl(linestr)) // & + ' kind '// & + trim(ERROR_STRINGS(-error_stack(i)%kind)) // & + C_NEW_LINE // & + " " // & + trim(error_stack(i)%doc) + + else + + str = trim(str) // C_NEW_LINE // & + ' File "' // & + trim(error_stack(i)%fn) // & + '", line ' // & + trim(adjustl(linestr))// & + ' kind '// & + trim(ERROR_STRINGS(-error_stack(i)%kind)) + endif + + enddo + + error_stack_position = 0 + + if (present(error)) then + error = ERROR_NONE + endif + + endfunction get_error_string_and_clear + + + !% Quit with an error message. Calls 'MPI_Abort' for MPI programs. + subroutine error_abort_with_message(message) + character(*), intent(in) :: message +#ifdef IFORT_TRACEBACK_ON_ABORT + integer :: j +#endif /* IFORT_TRACEBACK_ON_ABORT */ +#ifdef SIGNAL_ON_ABORT + integer :: status + integer, parameter :: SIGUSR1 = 30 +#endif +#ifdef _MPI + integer::PRINT_ALWAYS +#endif + + if (quippy_running()) call f90wrap_abort(message) + +#ifdef _MPI + write(unit=error_unit, fmt='(a,i0," ",a)') 'SYSTEM ABORT: proc=',error_mpi_myid,error_linebreak_string(trim(message),100) +#else + write(unit=error_unit, fmt='(a," ",a)') 'SYSTEM ABORT:', error_linebreak_string(trim(message),100) +#endif + call flush(error_unit) + +#ifdef _MPI + call MPI_Abort(MPI_COMM_WORLD, 1, PRINT_ALWAYS) +#endif + +#ifdef IFORT_TRACEBACK_ON_ABORT + ! Cause an integer divide by zero error to persuade + ! ifort to issue a traceback + j = 1/0 +#endif + +#ifdef DUMP_CORE_ON_ABORT + call fabort() +#else +#ifdef SIGNAL_ON_ABORT + ! send ourselves a USR1 signal rather than aborting + call kill(getpid(), SIGUSR1, status) +#else + stop 1 +#endif +#endif + end subroutine error_abort_with_message + + + !% Stop program execution since this error is not handled properly + subroutine error_abort_from_stack(error) + implicit none + + integer, intent(inout), optional :: error + + ! --- + + ! This is for compatibility with quippy, change to error_abort + call system_abort(get_error_string_and_clear(error)) + + endsubroutine error_abort_from_stack + + pure function error_linebreak_string_length(str, line_len) result(length) + character(len=*), intent(in) :: str + integer, intent(in) :: line_len + integer :: length + + length = len_trim(str)+2*len_trim(str)/line_len+3 + + end function error_linebreak_string_length + + function error_linebreak_string(str, line_len) result(lb_str) + character(len=*), intent(in) :: str + integer, intent(in) :: line_len + + character(len=error_linebreak_string_length(str, line_len)) :: lb_str + + logical :: word_break + integer :: copy_len, last_space, next_cr + character(len=len(lb_str)) :: tmp_str + character :: quip_new_line + +#ifdef NO_F2003_NEW_LINE + quip_new_line = char(13) +#else + quip_new_line = new_line(' ') +#endif + + lb_str="" + tmp_str=trim(str) + do while (len_trim(tmp_str) > 0) + next_cr = scan(trim(tmp_str),quip_new_line) + if (next_cr > 0) then + copy_len = min(len_trim(tmp_str),line_len,next_cr) + else + copy_len = min(len_trim(tmp_str),line_len) + endif + if (copy_len < len_trim(tmp_str) .and. tmp_str(copy_len+1:copy_len+1) /= " ") then + last_space=scan(tmp_str(1:copy_len), " ", .true.) + if ( last_space > 0 .and. (len_trim(tmp_str(1:copy_len)) - last_space) < 4) then + copy_len=last_space + endif + endif + + if (len_trim(lb_str) > 0) then ! we already have some text, add newline before concatenating next line + if (lb_str(len_trim(lb_str):len_trim(lb_str)) == quip_new_line) then + lb_str = trim(lb_str)//trim(tmp_str(1:copy_len)) + else + lb_str = trim(lb_str)//quip_new_line//trim(tmp_str(1:copy_len)) + endif + else ! just concatenate next line + lb_str = trim(tmp_str(1:copy_len)) + endif + ! if we broke in mid word, add "-" + word_break = .true. + if (tmp_str(copy_len:copy_len) == " ") then ! we broke right after a space, so no wordbreak + word_break = .false. + else ! we broke after a character + if (copy_len < len_trim(tmp_str)) then ! there's another character after this one, check if it's a space + if (tmp_str(copy_len+1:copy_len+1) == " ") then + word_break = .false. + endif + else ! we broke after the last character + word_break = .false. + endif + endif + if (word_break) lb_str = trim(lb_str)//"-" + tmp_str(1:copy_len) = "" + tmp_str=adjustl(tmp_str) + end do + + end function error_linebreak_string + + +endmodule error_module diff --git a/src/libAtoms/f90wrap_stub.F90 b/src/libAtoms/f90wrap_stub.F90 new file mode 100644 index 0000000000..1957511cf8 --- /dev/null +++ b/src/libAtoms/f90wrap_stub.F90 @@ -0,0 +1,8 @@ +! stub file to include dummy defition of Python error abort function when +! building standalone exectuble +subroutine f90wrap_abort(message) + character(*) :: message + + ! do nothing + +end subroutine f90wrap_abort diff --git a/src/libAtoms/find_surface_atoms.F90 b/src/libAtoms/find_surface_atoms.F90 new file mode 100644 index 0000000000..f473aff670 --- /dev/null +++ b/src/libAtoms/find_surface_atoms.F90 @@ -0,0 +1,333 @@ +! based on Varshney et al IEEE Comp. Graphics and Appl. v. 14 p 19 (1994) +! linear programming solver from +! http://www.mpi-inf.mpg.de/departments/d1/teaching/ss10/opt/handouts/lecture25-SeidelLinearProgramming.pdf +! Not sure why they think that intersection of power-cell half spaces and enclosing +! tetrahedron half spaces is null for internal atoms - seems to be just something +! like Voronoi cell of atom (if all (covalent) radii are equal, anyway) +! instead, look for intersection of power cell with half spaces that don't include +! system (iterate over 6 - could be done with 4 with a tetrahedron). If any +! intersections are not null, atom has an unbounded power cell and is a surface atom. +module find_surface_atoms_module +use system_module, only : dp, print, mainlog, PRINT_VERBOSE, PRINT_ALWAYS, ran, operator(//), system_abort +use periodictable_module +use linearalgebra_module +use atoms_types_module +use atoms_module +implicit none + +private +public :: label_surface_atoms + +contains + +subroutine label_surface_atoms(at, probe_r) + type(Atoms), intent(inout) :: at + real(dp), intent(in) :: probe_r + + integer, pointer :: surf(:) + integer :: i, ji, j + real(dp) :: dist_ij, cos_ij(3), p(3), v(3), di, dj + real(dp), allocatable :: plane_constraints(:,:) + real(dp) :: bounds(3,2) + real(dp) :: bounds_constraints(6,6) + real(dp) :: nn_cutoff + integer :: nn + + nn_cutoff = 2.0_dp*probe_r + 2.0_dp*maxval(ElementCovRad(at%Z)) + call set_cutoff(at, nn_cutoff) + call calc_connect(at) + + call add_property(at, "surf", 0, n_cols=1, ptr=surf) + + bounds(1,1) = minval(at%pos(1,:))-(maxval(at%pos(1,:))-minval(at%pos(1,:))) + bounds(1,2) = maxval(at%pos(1,:))+(maxval(at%pos(1,:))-minval(at%pos(1,:))) + bounds(2,1) = minval(at%pos(2,:))-(maxval(at%pos(2,:))-minval(at%pos(2,:))) + bounds(2,2) = maxval(at%pos(2,:))+(maxval(at%pos(2,:))-minval(at%pos(2,:))) + bounds(3,1) = minval(at%pos(3,:))-(maxval(at%pos(3,:))-minval(at%pos(3,:))) + bounds(3,2) = maxval(at%pos(3,:))+(maxval(at%pos(3,:))-minval(at%pos(3,:))) + bounds_constraints(1:6,1) = (/ bounds(1,1), 0.0_dp, 0.0_dp, -1.0_dp, 0.0_dp, 0.0_dp /) + bounds_constraints(1:6,2) = (/ bounds(1,2), 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, 0.0_dp /) + bounds_constraints(1:6,3) = (/ 0.0_dp, bounds(2,1), 0.0_dp, 0.0_dp, -1.0_dp, 0.0_dp /) + bounds_constraints(1:6,4) = (/ 0.0_dp, bounds(2,2), 0.0_dp, 0.0_dp, 1.0_dp, 0.0_dp /) + bounds_constraints(1:6,5) = (/ 0.0_dp, 0.0_dp, bounds(3,1), 0.0_dp, 0.0_dp, -1.0_dp /) + bounds_constraints(1:6,6) = (/ 0.0_dp, 0.0_dp, bounds(3,2), 0.0_dp, 0.0_dp, 1.0_dp /) + + bounds(1,1) = minval(at%pos(1,:))-10.0_dp*(maxval(at%pos(1,:))-minval(at%pos(1,:))) + bounds(1,2) = maxval(at%pos(1,:))+10.0_dp*(maxval(at%pos(1,:))-minval(at%pos(1,:))) + bounds(2,1) = minval(at%pos(2,:))-10.0_dp*(maxval(at%pos(2,:))-minval(at%pos(2,:))) + bounds(2,2) = maxval(at%pos(2,:))+10.0_dp*(maxval(at%pos(2,:))-minval(at%pos(2,:))) + bounds(3,1) = minval(at%pos(3,:))-10.0_dp*(maxval(at%pos(3,:))-minval(at%pos(3,:))) + bounds(3,2) = maxval(at%pos(3,:))+10.0_dp*(maxval(at%pos(3,:))-minval(at%pos(3,:))) + + do i=1, at%N + + ! count close enough neighbours + nn = 0 + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, distance=dist_ij) + if (dist_ij <= ElementCovRad(at%Z(i)) + ElementCovRad(at%Z(j)) + 2.0_dp*probe_R) then + nn = nn + 1 + endif + end do + + if (allocated(plane_constraints)) then + if (size(plane_constraints,2) /= nn+1) deallocate(plane_constraints) + endif + if (.not. allocated(plane_constraints)) allocate(plane_constraints(6,nn+1)) + + ! do constraints for close enough neighbours + nn = 0 + do ji=1, n_neighbours(at, i) + j = neighbour(at, i, ji, distance=dist_ij, cosines=cos_ij) + if (dist_ij <= ElementCovRad(at%Z(i)) + ElementCovRad(at%Z(j)) + 2.0_dp*probe_R) then + nn = nn + 1 + ! pi = di^2 - (ElementCovRad(i)+probe_r)^2 + ! pj = dj^2 - (ElementCovRad(j)+probe_r)^2 + ! along r_ij, di+dj=dij, dj=dij-di + + ! pi == pj + ! di^2 - (Ci+pr)^2 = (dij-di)^2 - (Cj+pr)^2 + ! di^2 - (Ci+pr)^2 = dij^2 - 2 di dij + di^2 - (Cj+pr)^2 + ! -(Ci+pr)^2 = dij^2 - 2 di dij - (Cj+pr)^2 + ! -2 di dij = (Cj+pr)^2-(Ci+pr)^2-dij^2 + ! di = ((Cj+pr)^2-(Ci+pr)^2-dij^2)/(-2 dij) + di = ((ElementCovRad(at%Z(j))+probe_r)**2 - (ElementCovRad(at%Z(i))+probe_r)**2 - dist_ij**2)/(-2.0_dp*dist_ij) + dj = dist_ij - di + if (abs(di) < dist_ij .and. abs(dj) < dist_ij) then ! in between + p(:) = at%pos(:,i) + abs(di)*cos_ij(:) + else if (abs(di) > abs(dj)) then ! not in between, and closer to j than to i + p(:) = at%pos(:,i) + abs(di)*cos_ij(:) + else ! not in between and closer to i than to j + p(:) = at%pos(:,i) - abs(di)*cos_ij(:) + endif + v(:) = -cos_ij(:) + plane_constraints(1:3,nn) = p + plane_constraints(4:6,nn) = v + endif + end do + do j=1,6 + plane_constraints(1:6,nn+1) = bounds_constraints(1:6,j) + if (feasible_cell_has_solution(plane_constraints, bounds)) then + surf(i) = 1 + exit + endif + end do + end do + +end subroutine label_surface_atoms + +function feasible_cell_has_solution(plane_constraints, bounds) + real(dp), intent(in) :: plane_constraints(:,:), bounds(3,2) + real(dp) :: x(3) + logical :: feasible_cell_has_solution + logical :: constraint_ok, t_constraint_ok + + integer i + + call print("has_solution "//shape(plane_constraints), PRINT_VERBOSE) + do i=1, size(plane_constraints,2) + call print("p "//plane_constraints(1:3,i)//" v "//plane_constraints(4:6,i), PRINT_VERBOSE) + end do + + x = seidel_solve(a=-plane_constraints(4:6,:),b=-sum(plane_constraints(1:3,:)*plane_constraints(4:6,:),1),& + bounds=bounds, has_solution=feasible_cell_has_solution) + call print(" has_solution " // feasible_cell_has_solution, PRINT_VERBOSE) + if (feasible_cell_has_solution) then + call print("solution x " //x, PRINT_VERBOSE) + constraint_ok=.true. + do i=1, size(plane_constraints,2) + call print(i//" a.x "//sum(-plane_constraints(4:6,i)*x)//" <=? "//sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i)) // & + " " // (sum(-plane_constraints(4:6,i)*x) <= sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))), PRINT_VERBOSE) + t_constraint_ok = (sum(-plane_constraints(4:6,i)*x) <= sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))) + if (.not. t_constraint_ok .and. abs(sum(-plane_constraints(4:6,i)*x) - sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))) < 1.0e-6_dp) t_constraint_ok = .true. + constraint_ok = constraint_ok .and. t_constraint_ok + end do + if (.not. constraint_ok) then + call print("WARNING: has_solution=T but some constraint violated") + do i=1, size(plane_constraints, 2) + t_constraint_ok = (sum(-plane_constraints(4:6,i)*x) <= sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))) + if (.not. t_constraint_ok .and. abs(sum(-plane_constraints(4:6,i)*x) - sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))) < 1.0e-6_dp) t_constraint_ok = .true. + if (.not. t_constraint_ok) then + call print(i//" a.x "//sum(-plane_constraints(4:6,i)*x)//" <=? "//sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i)) // & + " " // (sum(-plane_constraints(4:6,i)*x) <= sum(-plane_constraints(1:3,i)*plane_constraints(4:6,i))), PRINT_VERBOSE) + endif + end do + endif + endif +end function feasible_cell_has_solution + +! linear programming solver from +! http://www.mpi-inf.mpg.de/departments/d1/teaching/ss10/opt/handouts/lecture25-SeidelLinearProgramming.pdf +! solve a.x <= b for x, subject to bounds. Returns x, sets has_solution to false if no solution. +recursive function seidel_solve(a, b, bounds, has_solution) result(x) + real(dp) :: a(:,:), b(:), bounds(:,:) + logical :: has_solution + real(dp) :: x(size(a,1)) + + real(dp), allocatable :: a_skip_m(:,:), b_skip_m(:), x_skip_m(:) + real(dp), allocatable :: a_skip_dm(:,:), b_skip_dm(:), x_skip_dm(:), bounds_skip_dm(:,:) + integer :: d, m, i, j, ii, jj, i_skip, j_skip + real(dp) :: x_min, x_max + integer, allocatable :: skip_m_index(:), skip_d_index(:) + character(len=1024) :: prefix + + d = size(a,1) + m = size(a,2) +! call print("seidel_solve d "//d//" m "//m) + + if (size(b) /= m) call system_abort("Bad size of b "//size(b)) + if (size(bounds,1) /= d) call system_abort("Bad size of bounds dim 1 "//size(bounds,1)) + if (size(bounds,2) /= 2) call system_abort("Bad size of bounds dim 2 "//size(bounds,2)) + + has_solution = .true. + if (d == 1) then ! 1-D, just find range of minima, maxima + x_min = bounds(1,1) + x_max = bounds(1,2) + do i=1, m + if (a(1,i) .feq. 0.0_dp) then + if (0.0_dp <= b(i)) then + has_solution = .true. + else + has_solution = .false. + endif + else if (a(1,i) > 0) then ! x <= b/a + x_max = min(x_max, b(i)/a(1,i)) + else ! x >= b/a + x_min = max(x_min, b(i)/a(1,i)) + endif + end do ! i=1,m + if (x_max >= x_min) then + has_solution = has_solution .and. .true. + else + has_solution = has_solution .and. .false. + endif + x = 0.5_dp*(x_max+x_min) +! call print("1-D returning has_solution "//has_solution//" "//x_min//" "//x_max) + return + endif ! d == 1 + + if (m == 0) then ! no constraints + call print("WARNING: should never get here", PRINT_ALWAYS) + has_solution = .true. + x = 0.5_dp*(bounds(:,1)+bounds(:,2)) + return + endif + + ! omit a random constraint + i_skip = mod(ran(),m)+1 + allocate(x_skip_m(d)) + allocate(skip_m_index(m-1)) +! call print("skip constraint "//i_skip) + if (m == 1) then ! next would be a call with no constraints +! call print("faking m=0 call") + x_skip_m = 0.5_dp*(bounds(:,1)+bounds(:,2)) + else ! some constraints left to solve + allocate(a_skip_m(d,m-1), b_skip_m(m-1)) + ii=1 + do i=1, m + if (i /= i_skip) then + skip_m_index(ii) = i + ii = ii + 1 + endif + end do + do j=1, d + a_skip_m(j,:) = a(j,skip_m_index(:)) + end do + b_skip_m(:) = b(skip_m_index(:)) +prefix=trim(mainlog%prefix) +mainlog%prefix=trim(mainlog%prefix)//"S" + x_skip_m = seidel_solve(a_skip_m, b_skip_m, bounds, has_solution) +mainlog%prefix=trim(prefix) +! call print("got has_solution "//has_solution//" "//x_skip_m) + deallocate(a_skip_m, b_skip_m) + if (.not. has_solution) then + deallocate(x_skip_m) + deallocate(skip_m_index) + return + endif + endif + if (sum(x_skip_m(:)*a(:,i_skip)) <= b(i_skip)) then +! call print("skipped constraint is satisfied (a.x="//sum(x_skip_m(:)*a(:,i_skip))//" <= b="//b(i_skip)//"), returning") + has_solution=.true. + x = x_skip_m + deallocate(x_skip_m) + deallocate(skip_m_index) + return + endif +! call print("skipped constraint wasn't satisfied, continuing") + deallocate(x_skip_m) + ! still have skip_m_index allocated + + j_skip=0 + do j=1,d + if (a(j,i_skip) .fne. 0.0_dp) then + j_skip=j + exit + endif + end do +! call print("eliminating dim "//j_skip) + if (j_skip == 0) then +! call print("can't eliminate, assuming no solution") + has_solution = .false. + deallocate(skip_m_index) + return + endif + allocate(x_skip_dm(d-1)) + allocate(skip_d_index(d-1)) + jj=1 + do j=1, d + if (j /= j_skip) then + skip_d_index(jj) = j + jj = jj + 1 + endif + end do + if (m == 1) then ! fake m=0 call +! call print("faking m=0 call") + has_solution = .true. + x_skip_dm(1:d-1) = 0.5_dp*(bounds(skip_d_index(:),1)+bounds(skip_d_index(:),2)) + else + allocate(a_skip_dm(d-1,m-1), b_skip_dm(m-1)) + do i=1, m-1 + do j=1, d-1 + a_skip_dm(j,i) = a(skip_d_index(j),skip_m_index(i)) - a(j_skip,skip_m_index(i))*a(skip_d_index(j),i_skip)/a(j_skip,i_skip) + end do + b_skip_dm(i) = b(skip_m_index(i)) - a(j_skip,skip_m_index(i))*b(i_skip)/a(j_skip,i_skip) + end do + allocate(bounds_skip_dm(d-1,2)) + bounds_skip_dm(:,1) = bounds(skip_d_index(:),1) + bounds_skip_dm(:,2) = bounds(skip_d_index(:),2) +prefix=trim(mainlog%prefix) +mainlog%prefix=trim(mainlog%prefix)//"S" + x_skip_dm = seidel_solve(a_skip_dm, b_skip_dm, bounds_skip_dm, has_solution) +mainlog%prefix=trim(prefix) +! call print("got has_solution "//has_solution//" "//x_skip_dm) +! if (has_solution) then +! call print("check raw solution") +! do i=1, m-1 +! call print(" a.x="//sum(a_skip_dm(:,i)*x_skip_dm(:))//" <=? "//b_skip_dm(i)//" "// (sum(a_skip_dm(:,i)*x_skip_dm(:)) <=b_skip_dm(i))) +! end do +! endif + deallocate(bounds_skip_dm) + deallocate(a_skip_dm, b_skip_dm) + endif + deallocate(skip_m_index) + if (.not. has_solution) then +! call print("no solution, returning") + deallocate(x_skip_dm) + deallocate(skip_d_index) + return + endif +! call print("has solution, back substituting") + x(skip_d_index(:)) = x_skip_dm(:) + x(j_skip) = (b(i_skip) - sum(a(skip_d_index(:),i_skip)*x_skip_dm(:)))/a(j_skip,i_skip) +! call print("check backsub solution") +! do i=1, m +! call print(" a.x="//sum(a(:,i)*x(:))//" <=? "//b(i)//" "// (sum(a(:,i)*x(:)) <=b(i))) +! end do + has_solution = .true. + deallocate(x_skip_dm) + deallocate(skip_d_index) + +end function seidel_solve + +end module find_surface_atoms_module diff --git a/src/libAtoms/frametools.F90 b/src/libAtoms/frametools.F90 new file mode 100644 index 0000000000..b4fd7e8d5d --- /dev/null +++ b/src/libAtoms/frametools.F90 @@ -0,0 +1,240 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" +module frametools_module +use error_module +use system_module +use linearalgebra_module +use atoms_types_module +use atoms_module +use quaternions_module +implicit none +private + + +public :: atoms_mark + +public :: mark_cylinder, mark_sphere + +private :: ft_rotate +public :: rotate +interface rotate + module procedure ft_rotate +end interface rotate + +contains + +!% Mark atoms according to the results of a callback function `mark_f` +!% +!% The integer property `mark_name` will be set to `mark_value` for +!% the atoms for which the function `mark_f(at, i, periodic, f_i_data, +!% f_r_data[, error])` returns true, where `i` is the atom index and +!% the other arguments are passed along from those given to `atoms_mark`. +subroutine atoms_mark(this, mark_f, f_i_data, f_r_data, periodic, mark_name, mark_value, intersection, error) + type(atoms), intent(inout) :: this + interface + function mark_f(at, i, periodic, i_data, r_data, error) + use system_module + use atoms_module + type(atoms), intent(inout) :: at + integer, intent(in) :: i + logical, intent(in) :: periodic + integer, intent(in), optional :: i_data(:) + real(dp), intent(in), optional :: r_data(:) + integer, intent(out), optional :: error + logical mark_f + end function mark_f + end interface + integer, intent(in), optional :: f_i_data(:) !% Integer data passed along to `mark_f` function + real(dp), intent(in), optional :: f_r_data(:) !% Real data passed along to `mark_f` function + logical, intent(in), optional :: periodic !% Passed along to `mark_f` function + character(len=*), intent(in), optional :: mark_name !% Name of integer property to set the marks in + integer, intent(in), optional :: mark_value !% Value with which to mark atoms + logical, intent(in), optional :: intersection !% If true, only consider atoms where mark property is already non-zero + integer, intent(out), optional :: error + + integer :: i + character(len=128) :: my_mark_name + integer :: my_mark_value + logical :: my_intersection, my_periodic + integer, pointer :: mark(:) + + INIT_ERROR(error) + + my_mark_name = optional_default("mark", mark_name) + my_mark_value = optional_default(1, mark_value) + my_intersection = optional_default(.false., intersection) + my_periodic = optional_default(.true., periodic) + + if (.not. assign_pointer(this, trim(my_mark_name), mark)) then + call add_property(this, trim(my_mark_name), 0, ptr=mark) + else + call assign_property_pointer(this, trim(my_mark_name), mark, error=error) + endif + + do i=1, this%N + if (my_intersection .and. mark(i) == 0) cycle ! if we're doing intersection and this one isn't already marked, skip it + if (my_intersection) mark(i) = 0 ! if we're doing intersection, set mark to .false., and it'll will be set to true if it's marked in the current shape + if (mark_f(this, i, my_periodic, f_i_data, f_r_data, error=error)) then + mark(i) = my_mark_value + endif + PASS_ERROR(error) + end do +end subroutine atoms_mark + +function is_in_cylinder_f(this, i, periodic, i_data, r_data, error) + type(atoms), intent(inout) :: this + integer, intent(in) :: i + logical, intent(in) :: periodic + integer, intent(in), optional :: i_data(:) + real(dp), intent(in), optional :: r_data(:) + integer, intent(out), optional :: error + logical is_in_cylinder_f + + logical :: my_periodic + real(dp) :: delta_p(3), v(3), r + + INIT_ERROR(error) + + if (present(i_data)) then + RAISE_ERROR("is_in_cylinder_f doesn't take i_data", error) + endif + if (.not.present(r_data)) then + RAISE_ERROR("is_in_cylinder_f requires r_data", error) + endif + if (size(r_data) /= 7) then + RAISE_ERROR("is_in_cylinder_f requires [px py pz vx vy vz r] in cylinder", error) + endif + + if (periodic) then + delta_p = diff_min_image(this, i, r_data(1:3)) + else + delta_p = this%pos(:,i) - r_data(1:3) + endif + v = r_data(4:6) + v = v/norm(v) + r = r_data(7) + + delta_p = delta_p - v*(v .dot. delta_p) + if (r > 0.0_dp) then + is_in_cylinder_f = (norm(delta_p) < r) + else + is_in_cylinder_f = (norm(delta_p) >= -r) + endif +end function is_in_cylinder_f + +function is_in_sphere_f(this, i, periodic, i_data, r_data, error) + type(atoms), intent(inout) :: this + integer, intent(in) :: i + logical, intent(in) :: periodic + integer, intent(in), optional :: i_data(:) + real(dp), intent(in), optional :: r_data(:) + integer, intent(out), optional :: error + logical is_in_sphere_f + + real(dp) :: dr, r + + INIT_ERROR(error) + + if (present(i_data)) then + RAISE_ERROR("is_in_sphere_f doesn't take i_data", error) + endif + if (.not.present(r_data)) then + RAISE_ERROR("is_in_sphere_f requires r_data", error) + endif + if (size(r_data) /= 4) then + RAISE_ERROR("is_in_sphere_f requires [px py pz r] in sphere", error) + endif + + if (periodic) then + dr = distance_min_image(this, i, r_data(1:3)) + else + dr = norm(this%pos(:,i)-r_data(1:3)) + endif + r = r_data(4) + + if (r > 0.0_dp) then + is_in_sphere_f = (dr < r) + else + is_in_sphere_f = (dr >= -r) + endif +end function is_in_sphere_f + + +!% Mark atoms in a cylinder centred on the point `p` with axis `v` and radius `r` +subroutine mark_cylinder(this, p, v, r, periodic, mark_name, mark_value, intersection) + type(atoms), intent(inout) :: this + real(dp), intent(in) :: p(3), v(3), r + character(len=*), intent(in), optional :: mark_name + integer, intent(in), optional :: mark_value + logical, intent(in), optional :: periodic, intersection + + call atoms_mark(this, is_in_cylinder_f, f_r_data=(/ p, v, r /), periodic=periodic, mark_name=mark_name, mark_value=mark_value, intersection=intersection) +end subroutine mark_cylinder + +!% Mark atoms in a cylinder centred on the point `p` with radius `r` +subroutine mark_sphere(this, p, r, periodic, mark_name, mark_value, intersection) + type(atoms), intent(inout) :: this + real(dp), intent(in) :: p(3), r + character(len=*), intent(in), optional :: mark_name + integer, intent(in), optional :: mark_value + logical, intent(in), optional :: periodic, intersection + + call atoms_mark(this, is_in_sphere_f, f_r_data=(/ p, r /), periodic=periodic, mark_name=mark_name, mark_value=mark_value, intersection=intersection) +end subroutine mark_sphere + +!% Rotate `field`, which should be a vector field with shape `(3, N)`, +!% e.g. atomic positions array around `axis` by `angle`, centering the +!% rotation on `origin` +subroutine ft_rotate(field, axis, angle, origin) + real(dp), intent(inout) :: field(:,:) + real(dp), intent(in) :: axis(3) + real(dp), intent(in) :: angle + real(dp), intent(in), optional :: origin(3) + + real(dp) :: dr(3) + type(Quaternion) :: Q + integer i, N + + Q = rotation(axis, angle) + + N = size(field,2) + + do i=1, N + if (present(origin)) then + field(:,i) = field(:,i)-origin + endif + call rotate(field(:,i), Q) + end do +end subroutine ft_rotate + + +end module frametools_module diff --git a/src/libAtoms/gamma_functions.F90 b/src/libAtoms/gamma_functions.F90 new file mode 100644 index 0000000000..f5361b4e13 --- /dev/null +++ b/src/libAtoms/gamma_functions.F90 @@ -0,0 +1,244 @@ +module gamma_module + + use system_module,only : dp + + ! Incomplete GAMMA function. Adapted from Numerical Recipes in Fortran 77. + + implicit none +! integer, parameter :: dp = kind(1.0d0) + integer, parameter :: max_iteration = 100 + real(dp), parameter :: eps = 1.0e-12_dp + real(dp), parameter :: min_float = tiny(1.0_dp) * 10.0_dp + real(dp), parameter :: log_sqrt_2_pi = log(sqrt(2.0_dp*3.14159265358979323846264338327950288_dp) ) + + interface gamma_incomplete_upper + module procedure gamma_incomplete_upper, gamma_incomplete_upper_xarray1d, & + gamma_incomplete_upper_ainteger + endinterface gamma_incomplete_upper + + contains + + function gamma_incomplete_upper_xarray1d(a,x) + real(dp), intent(in) :: a + real(dp), intent(in), dimension(:) :: x + real(dp), dimension(size(x)) :: gamma_incomplete_upper_xarray1d + + integer :: i + + do i = 1, size(x) + gamma_incomplete_upper_xarray1d(i) = gamma_incomplete_upper(a,x(i)) + enddo + + endfunction gamma_incomplete_upper_xarray1d + + function gamma_incomplete_upper_ainteger(a,x) + integer, intent(in) :: a + real(dp), intent(in) :: x + real(dp) :: gamma_incomplete_upper_ainteger + + gamma_incomplete_upper_ainteger = gamma_incomplete_upper(real(a,dp),x) + + endfunction gamma_incomplete_upper_ainteger + + function gamma_incomplete_upper(a,x) + + real(dp), intent(in) :: a, x + real(dp) :: gamma_incomplete_upper + ! USES gcf,gser + ! Returns the incomplete gamma function Q(a, x) ≡ 1 − P(a, x). + real(dp) :: gammcf, gamser, gln + + if(x < 0.0_dp .or. a <= 0.0_dp ) stop 'bad arguments in gamma_incomplete_upper' + + if(x < a+1.0_dp)then !Use the series representation + call gser(gamser,a,x,gln) + gamma_incomplete_upper = 1.0_dp - gamser !and take its complement. + else !Use the continued fraction representation. + call gcf(gammcf,a,x,gln) + gamma_incomplete_upper = gammcf + endif + + gamma_incomplete_upper = gamma_incomplete_upper * exp(gln) + + endfunction gamma_incomplete_upper + + function gammp(a,x) + + real(dp), intent(in) :: a, x + real(dp) :: gammp + ! USES gcf,gser + ! Returns the incomplete gamma function P(a, x). + real(dp) :: gammcf,gamser,gln + + if(x < 0.0_dp .or. a <= 0.0_dp) stop 'bad arguments in gammp' + + if(x < a + 1.0_dp )then !Use the series representation. + call gser(gamser,a,x,gln) + gammp=gamser + else !Use the continued fraction representation + call gcf(gammcf,a,x,gln) + gammp =1.0_dp - gammcf !and take its complement. + endif + + endfunction gammp + + function gammq(a,x) + + real(dp), intent(in) :: a, x + real(dp) :: gammq + ! USES gcf,gser + ! Returns the incomplete gamma function Q(a, x) ≡ 1 − P(a, x). + real(dp) :: gammcf, gamser, gln + + if(x < 0.0_dp .or. a <= 0.0_dp ) stop 'bad arguments in gammq' + + if(x < a+1.0_dp)then !Use the series representation + call gser(gamser,a,x,gln) + gammq=1.0_dp - gamser !and take its complement. + else !Use the continued fraction representation. + call gcf(gammcf,a,x,gln) + gammq=gammcf + endif + + endfunction gammq + + subroutine gser(gamser,a,x,gln) + real(dp), intent(in) :: a, x + real(dp), intent(out) :: gamser, gln + + ! USES ln_gamma + !Returns the incomplete gamma function P(a, x) evaluated by its series + !representation as + !gamser. Also returns ln \Gamma(a) as gln. + + integer :: i + real(dp) :: ap, del, sum + + gln = ln_gamma(a) + + if(x <= 0.0_dp)then + if(x < 0.0_dp) stop 'x < 0 in gser' + gamser=0.0_dp + else + ap = a + sum = 1.0_dp / a + del = sum + i = 0 + do + i = i + 1 + ap = ap + 1.0_dp + del = del * x / ap + sum = sum + del + if(abs(del) < abs(sum)*eps) exit + if(i == max_iteration) stop 'Number of iterations reached maximum & + number of iterations, stopping. Consider increasing max_iteration.' + enddo + gamser = sum * exp(-x + a * log(x) - gln) + endif + + endsubroutine gser + + subroutine gcf(gammcf,a,x,gln) + real(dp), intent(in) :: a, x + real(dp), intent(out) :: gammcf, gln + + ! USES ln_gamma + ! Returns the incomplete gamma function Q(a, x) evaluated by its continued + ! fraction representation as gammcf. Also returns ln \Gamma(a) as gln. + + integer :: i + real(dp) :: an,b,c,d,del,h + + gln = ln_gamma(a) + + b = x + 1.0_dp - a ! Set up for evaluating continued fraction by modiï¬ed + c = 1.0 / min_float ! Lentz’s method (5.2) with b0 = 0. + d = 1.0_dp / b + h = d + i = 0 + do ! Iterate to convergence. + i = i + 1 + an = -i * (i-a) + b = b + 2.0_dp + d = an * d + b + + if(abs(d) < min_float) d = min_float + + c = b + an / c + + if(abs(c) < min_float) c = min_float + + d = 1.0_dp / d + del = d * c + h = h * del + if(abs(del-1.0_dp) < eps) exit + if(i == max_iteration) stop 'Number of iterations reached maximum & + number of iterations, stopping. Consider increasing max_iteration.' + enddo + gammcf = exp(-x + a*log(x) - gln)*h ! Put factors in front. + + endsubroutine gcf + +! function ln_gamma(xx) +! real(dp), intent(in) :: xx +! real(dp) :: ln_gamma +! +! ! Returns the value ln[ \Gamma(xx)] for xx > 0. +! integer :: j +! real(dp) :: ser, tmp, x, y +! +! real(dp), dimension(6), parameter :: cof = (/76.18009172947146_dp,-86.50532032941677_dp, & +! 24.01409824083091_dp,-1.231739572450155_dp,0.1208650973866179e-2_dp,-0.5395239384953e-5_dp/) +! real(dp), parameter :: stp = 2.5066282746310005_dp +! +! x = xx +! y = x +! tmp = x + 5.5_dp +! tmp = (x + 0.5_dp) * log(tmp) - tmp +! ser = 1.000000000190015_dp +! do j = 1, 6 +! y = y + 1.0_dp +! ser = ser + cof(j) / y +! enddo +! ln_gamma = tmp + log(stp*ser/x) +! endfunction ln_gamma + + function ln_gamma(xx) + real(dp), intent(in) :: xx + real(dp) :: ln_gamma + + integer :: i + real(dp) :: z, x, t + + real(dp), parameter :: g = 7.0_dp + integer, parameter :: n = 9 + real(dp), dimension(n), parameter :: p = & + (/0.99999999999980993227684700473478_dp, 676.520368121885098567009190444019_dp, & + -1259.13921672240287047156078755283_dp, 771.3234287776530788486528258894_dp, & + -176.61502916214059906584551354_dp, 12.507343278686904814458936853_dp, & + -0.13857109526572011689554707_dp, 9.984369578019570859563e-6_dp, 1.50563273514931155834e-7_dp /) + + !real(dp), parameter :: g = 4.74218750_dp + !integer, parameter :: n = 15 + !real(dp), dimension(n), parameter :: p = & + !(/0.99999999999999709182_dp, 57.156235665862923517_dp, -59.597960355475491248_dp, & + ! 14.136097974741747174_dp, -0.49191381609762019978_dp, .33994649984811888699e-4_dp, & + ! 0.46523628927048575665e-4_dp, -0.98374475304879564677e-4_dp, 0.15808870322491248884e-3_dp, & + ! -0.21026444172410488319e-3_dp, 0.21743961811521264320e-3_dp, -0.16431810653676389022e-3_dp, & + ! 0.84418223983852743293e-4_dp, -0.26190838401581408670e-4_dp, 0.36899182659531622704e-5_dp/) + + z = xx - 1.0_dp + + x = 0.0_dp + do i = n, 2, -1 + x = x + p(i)/(z+real(i-1,dp)) + enddo + x = x + p(1) + + t = z + g + 0.5_dp + + ln_gamma = log_sqrt_2_pi - t + log(x) + (z+0.5_dp)*log(t) + + endfunction ln_gamma + +endmodule gamma_module diff --git a/src/libAtoms/histogram1d.F90 b/src/libAtoms/histogram1d.F90 new file mode 100644 index 0000000000..65ea56010d --- /dev/null +++ b/src/libAtoms/histogram1d.F90 @@ -0,0 +1,1991 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Histogram helper functions in 1D +!X +!X Computes periodic and non-periodic histograms within certain bounds. +!X Interpolation can be chosen from +!X INTERP_LINEAR: Linear interpolation between neigboring grid +!X points +!X INTERP_LUCY: Lucy function interpolation between neighboring +!X grid points +!X TODO: +!X INTERP_NONE: No interpolation, simply sort into bins +!X +!X Provides routine for MPI communication. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +#define ASSERT(x) + +module histogram1d_module + use Error_module + use System_module + use Units_module + use MPI_context_module + + private + + public :: INTERP_LINEAR, INTERP_LUCY + integer, parameter :: INTERP_LINEAR = 0 + integer, parameter :: INTERP_LUCY = 1 + + public :: Histogram1D + type Histogram1D + + ! + ! General stuff + ! + + integer :: interp ! INTERP_LINEAR, INTERP_LUCY + + integer :: n = -1 ! number of bins + real(DP) :: min_b ! minimum value + real(DP) :: max_b ! maximun value + real(DP) :: db ! difference + real(DP) :: dbin ! bin size + + logical :: periodic + + ! + ! For smoothing function + ! + + real(DP) :: sigma + + real(DP) :: fac1 +! real(DP) :: sigma_sq + + ! + ! Values + ! + + real(DP), allocatable :: x(:) ! x-values + + real(DP), allocatable :: h(:) ! values + real(DP), allocatable :: h_sq(:) ! second moment + + real(DP), allocatable :: h1(:) ! histogram with norm 1 (number of values which have been added to each bin) + + integer :: ng + real(DP), pointer :: smoothing_func(:) => NULL() + + endtype Histogram1D + + ! + ! Interface definition + ! + + public :: initialise + interface initialise + module procedure histogram1d_initialise, histogram1d_initialise_from_histogram + endinterface + + public :: finalise + interface finalise + module procedure histogram1d_finalise + endinterface + + public :: clear + interface clear + module procedure histogram1d_clear + endinterface + + public :: set_bounds + interface set_bounds + module procedure histogram1d_set_bounds + endinterface + + public :: write + interface write + module procedure histogram1d_write, histogram1d_write_mult + module procedure histogram1d_write_character_fn, histogram1d_write_mult_character_fn + endinterface + + public :: add + interface add + module procedure histogram1d_add, histogram1d_add_vals, histogram1d_add_vals_norms + module procedure histogram1d_add_vals_mask, histogram1d_add_vals_norm_mask, histogram1d_add_vals_norms_mask + module procedure histogram1d_add_histogram, histogram1d_add_mult_histograms + endinterface + + public :: add_range + interface add_range + module procedure histogram1d_add_range, histogram1d_add_range_vals, histogram1d_add_range_vals_norms + endinterface + + public :: average + interface average + module procedure histogram1d_average + endinterface + + public :: entropy + interface entropy + module procedure histogram1d_entropy + endinterface + + public :: expectation_value + interface expectation_value + module procedure histogram1d_expectation_value + endinterface + + public :: mul + interface mul + module procedure histogram1d_mul, histograms_mul, histograms2_mul, histogram1d_mul_vals + endinterface + + public :: div + interface div + module procedure histogram1d_div, histograms_div, histograms2_div, histogram1d_div_vals + endinterface + + public :: normalize + interface normalize + module procedure histogram1d_normalize + endinterface + + public :: reduce + interface reduce + module procedure histogram1d_reduce + endinterface + + public :: smooth + interface smooth + module procedure histogram1d_smooth + endinterface + + public :: sum_in_place + interface sum_in_place + module procedure histogram1d_sum_in_place + endinterface + +! Memory estimation not yet implemented in libAtoms +#if 0 + interface log_memory_estimate + module procedure log_memory_estimate_histogram, log_memory_estimate_histogram2, log_memory_estimate_histogram3 + endinterface +#endif + +contains + + !% Initialize the histogram + !% Default is linear interpolation, non-periodic + elemental subroutine histogram1d_initialise(this, n, min_b, max_b, sigma, & + periodic) + implicit none + + type(Histogram1D), intent(inout) :: this + integer, intent(in) :: n + real(DP), intent(in) :: min_b + real(DP), intent(in) :: max_b + real(DP), intent(in), optional :: sigma + logical, intent(in), optional :: periodic + + ! --- + + call finalise(this) + + this%n = n + + if (present(sigma) .and. sigma > 0.0_DP) then + + this%interp = INTERP_LUCY + + this%sigma = sigma + +! this%fac1 = 1.0_DP/(sqrt(2*PI)*this%sigma) +! this%sigma_sq = 2*sigma**2 + this%fac1 = 5/(4*this%sigma) + + else + + this%interp = INTERP_LINEAR + + endif + + if (present(periodic)) then + this%periodic = periodic + else + this%periodic = .false. + endif + + this%smoothing_func => NULL() + + allocate(this%x(n)) + allocate(this%h(n)) + allocate(this%h_sq(n)) + allocate(this%h1(n)) + + this%min_b = min_b - 1.0_DP + this%max_b = max_b - 1.0_DP + + call histogram1d_set_bounds(this, min_b, max_b) + + call histogram1d_clear(this) + + endsubroutine histogram1d_initialise + + + !% Initialize the histogram + subroutine histogram1d_initialise_from_histogram(this, that) + implicit none + + type(Histogram1D), intent(out) :: this + type(Histogram1D), intent(in ) :: that + + ! --- + + call finalise(this) + + this%n = that%n + + this%interp = that%interp + this%sigma = that%sigma + + if (this%interp == INTERP_LUCY) then + this%fac1 = 5/(4*this%sigma) + endif + + this%periodic = that%periodic + + this%smoothing_func => NULL() + + allocate(this%x(this%n)) + allocate(this%h(this%n)) + allocate(this%h_sq(this%n)) + allocate(this%h1(this%n)) + + this%min_b = that%min_b - 1.0_DP + this%max_b = that%max_b - 1.0_DP + + call histogram1d_set_bounds(this, that%min_b, that%max_b) + + call histogram1d_clear(this) + + endsubroutine histogram1d_initialise_from_histogram + + + !% Clear histogram + elemental subroutine histogram1d_clear(this) + implicit none + + type(Histogram1D), intent(inout) :: this + + ! --- + + this%h1 = 0.0_DP + this%h = 0.0_DP + this%h_sq = 0.0_DP + + endsubroutine histogram1d_clear + + + !% Set histogram bounds + elemental subroutine histogram1d_set_bounds(this, min_b, max_b) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: min_b + real(DP), intent(in) :: max_b + + ! --- + + integer :: i + real(DP) :: x + + ! --- + + if (this%min_b /= min_b .or. this%max_b /= max_b) then + + this%min_b = min_b + this%max_b = max_b + this%db = max_b - min_b + + if (this%periodic) then + this%dbin = this%db/this%n + else + this%dbin = this%db/(this%n-1) + endif + + do i = 1, this%n + this%x(i) = this%min_b + this%dbin*(i-0.5_DP) + enddo + + ! + ! Tabulate the smoothing function + ! + + if (this%interp == INTERP_LUCY) then + + this%ng = floor(this%sigma/this%dbin) + + if (.not. associated(this%smoothing_func)) then + allocate(this%smoothing_func(-this%ng:this%ng)) + else if (ubound(this%smoothing_func, 1) /= this%ng) then + deallocate(this%smoothing_func) + allocate(this%smoothing_func(-this%ng:this%ng)) + endif + + do i = -this%ng, this%ng +! this%smoothing_func(i) = this%fac1 * exp(-((this%dbin*i)**2)/this%sigma_sq) + x = abs( ( this%dbin*i )/this%sigma ) + this%smoothing_func(i) = this%fac1 * (1+3*x)*(1-x)**3 + enddo + + endif + + endif + + endsubroutine histogram1d_set_bounds + + + !% Delete a histogram table + elemental subroutine histogram1d_finalise(this) + implicit none + + type(Histogram1D), intent(inout) :: this + + ! --- + +#if 0 + if (allocated(this%x)) then + deallocate(this%x) + endif + if (allocated(this%h)) then + deallocate(this%h) + endif + if (allocated(this%h_sq)) then + deallocate(this%h_sq) + endif + if (allocated(this%h1)) then + deallocate(this%h1) + endif + + if (associated(this%smoothing_func)) then + deallocate(this%smoothing_func) + endif +#endif + + endsubroutine histogram1d_finalise + + + !% Output the histogram table to a file (by file unit) + subroutine histogram1d_write_mult(this, file, xvalues, header, error) + implicit none + + type(Histogram1D), intent(in) :: this(:) + type(InOutput), intent(in) :: file + logical, intent(in), optional :: xvalues + character(*), intent(in), optional :: header(lbound(this, 1):ubound(this, 1)) + integer, intent(out), optional :: error + + ! --- + + integer :: i, j + character(80) :: fmt + character(20) :: ext_header(lbound(this, 1):ubound(this, 1)) + + integer :: n + real(DP) :: min_b, max_b, dbin, y(lbound(this, 1):ubound(this, 1)) + + ! --- + + INIT_ERROR(error) + + n = this(lbound(this, 1))%n + min_b = this(lbound(this, 1))%min_b + max_b = this(lbound(this, 1))%max_b + dbin = this(lbound(this, 1))%dbin + + do i = lbound(this, 1)+1, ubound(this, 1) + if (this(i)%n /= n) then + RAISE_ERROR("Number of histogram bins do not match.", error) + endif + + if (this(i)%min_b /= min_b) then + RAISE_ERROR("*min_b*s do not match.", error) + endif + + if (this(i)%max_b /= max_b) then + RAISE_ERROR("*max_b*s do not match.", error) + endif + enddo + + if (present(header)) then + do i = lbound(this, 1), ubound(this, 1) + write (fmt, '(I2.2)') i+2 + ext_header(i) = trim(fmt) // ":" // trim(header(i)) + ext_header(i) = adjustr(ext_header(i)) + enddo + + write (fmt, '(A,I4.4,A)') "(A5,5X,A20,", ubound(this, 1)-lbound(this, 1)+1, "A20)" + write (file%unit, fmt) "#01:i", "02:x", ext_header + endif + + if (present(xvalues) .and. .not. xvalues) then + write (fmt, '(A,I4.4,A)') "(A,", n, "ES20.10)" + write (file%unit, trim(fmt)) "# ", this(lbound(this, 1))%x + write (fmt, '(A,I4.4,A)') "(I10,", ubound(this, 1)-lbound(this, 1)+1, "ES20.10)" + else + write (fmt, '(A,I4.4,A)') "(I10,", ubound(this, 1)-lbound(this, 1)+2, "ES20.10)" + endif + + do i = 1, n + do j = lbound(this, 1), ubound(this, 1) + y(j) = this(j)%h(i) + enddo + + if (present(xvalues) .and. .not. xvalues) then + write (file%unit, trim(fmt)) i, y + else + write (file%unit, trim(fmt)) i, this(lbound(this, 1))%x(i), y + endif + enddo + + endsubroutine histogram1d_write_mult + + + !% Output the histogram table to a file (by file name) + subroutine histogram1d_write_mult_character_fn(this, fn, xvalues, header, error) + implicit none + + type(Histogram1D), intent(in) :: this(:) + character(*), intent(in) :: fn + logical, intent(in), optional :: xvalues + character(*), intent(in), optional :: header(lbound(this, 1):ubound(this, 1)) + integer, intent(out), optional :: error + + ! --- + + type(InOutput) :: file + + ! --- + + INIT_ERROR(error) + + call initialise(file, fn, action=OUTPUT, error=error) + PASS_ERROR(error) + call histogram1d_write_mult(this, file, xvalues, header, error=error) + call finalise(file) + PASS_ERROR(error) + + endsubroutine histogram1d_write_mult_character_fn + + + !% Output the histogram table to a file (by file unit) + subroutine histogram1d_write(this, file, xvalues, header, error) + implicit none + + type(Histogram1D), intent(in) :: this + type(InOutput), intent(in) :: file + logical, intent(in), optional :: xvalues + character(*), intent(in), optional :: header + integer, intent(out), optional :: error + + ! --- + + INIT_ERROR(error) + + if (present(header)) then + call histogram1d_write_mult((/ this /), file, xvalues, (/ header /), error=error) + PASS_ERROR(error) + else + call histogram1d_write_mult((/ this /), file, xvalues, error=error) + PASS_ERROR(error) + endif + + endsubroutine histogram1d_write + + + !% Output the histogram table to a file (by file name) + subroutine histogram1d_write_character_fn(this, fn, xvalues, header, error) + implicit none + + type(Histogram1D), intent(in) :: this + character(*), intent(in) :: fn + logical, intent(in), optional :: xvalues + character(*), intent(in), optional :: header + integer, intent(out), optional :: error + + ! --- + + INIT_ERROR(error) + + if (present(header)) then + call histogram1d_write_mult_character_fn((/ this /), fn, xvalues, (/ header /), error=error) + PASS_ERROR(error) + else + call histogram1d_write_mult_character_fn((/ this /), fn, xvalues, error=error) + PASS_ERROR(error) + endif + + endsubroutine histogram1d_write_character_fn + + + !% Add a value to the histogram with linear interpolation + subroutine histogram1d_add_linear(this, val, norm) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: val + real(DP), intent(in) :: norm + + ! --- + + integer :: i1, i2 + real(DP) :: d1, d2 + + ! --- + + i1 = int(floor((val-this%min_b)/this%dbin))+1 + i2 = i1+1 + + d1 = ( (i2-1) - (val-this%min_b)/this%dbin )/this%dbin + d2 = ( (val-this%min_b)/this%dbin - (i1-1) )/this%dbin + + if ((i1 >= 0 .and. i1 <= this%n) .or. this%periodic) then + ASSERT(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP) + + if (this%periodic) then + i1 = modulo(i1-1, this%n)+1 + else + if (i1 == 0) then + i1 = 1 + endif + endif + + this%h1(i1) = this%h1(i1) + d1 + this%h(i1) = this%h(i1) + d1*norm + this%h_sq(i1) = this%h_sq(i1) + d1*norm**2 + endif + + if ((i2 >= 1 .and. i2 <= this%n+1) .or. this%periodic) then + ASSERT(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP) + + if (this%periodic) then + i2 = modulo(i2-1, this%n)+1 + else + if (i2 == this%n+1) then + i2 = this%n + endif + endif + + this%h1(i2) = this%h1(i2) + d2 + this%h(i2) = this%h(i2) + d2*norm + this%h_sq(i2) = this%h_sq(i2) + d2*norm**2 + endif + + endsubroutine histogram1d_add_linear + + + !% Add multiple values to the histogram with linear interpolation + subroutine histogram1d_add_linear_vals(this, vals, norm) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + real(DP), intent(in) :: norm + + ! --- + + integer :: i1(lbound(vals, 1):ubound(vals, 1)), i2(lbound(vals, 1):ubound(vals, 1)) + real(DP) :: d1(lbound(vals, 1):ubound(vals, 1)), d2(lbound(vals, 1):ubound(vals, 1)) + + integer :: i + + ! --- + + i1 = int(floor((vals-this%min_b)/this%dbin))+1 + i2 = i1+1 + + d1 = ( (i2-1) - (vals-this%min_b)/this%dbin )/this%dbin + d2 = ( (vals-this%min_b)/this%dbin - (i1-1) )/this%dbin + + ASSERT(all(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP)) + ASSERT(all(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP)) + + if (this%periodic) then + + i1 = modulo(i1-1, this%n)+1 + i2 = modulo(i2-1, this%n)+1 + + do i = lbound(vals, 1), ubound(vals, 1) + this%h1(i1(i)) = this%h1(i1(i)) + d1(i) + this%h1(i2(i)) = this%h1(i2(i)) + d2(i) + + this%h(i1(i)) = this%h(i1(i)) + d1(i)*norm + this%h(i2(i)) = this%h(i2(i)) + d2(i)*norm + + this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1(i)*norm**2 + this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2(i)*norm**2 + enddo + + else + + do i = lbound(vals, 1), ubound(vals, 1) + if (i1(i) >= 1 .and. i1(i) <= this%n) then + this%h1(i1(i)) = this%h1(i1(i)) + d1(i) + this%h(i1(i)) = this%h(i1(i)) + d1(i)*norm + this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1(i)*norm**2 + else if (i1(i) == 0) then + this%h1(1) = this%h1(1) + d1(i) + this%h(1) = this%h(1) + d1(i)*norm + this%h_sq(1) = this%h_sq(1) + d1(i)*norm**2 + endif + + if (i2(i) >= 1 .and. i2(i) <= this%n) then + this%h1(i2(i)) = this%h1(i2(i)) + d2(i) + this%h(i2(i)) = this%h(i2(i)) + d2(i)*norm + this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2(i)*norm**2 + else if (i2(i) == this%n+1) then + this%h1(this%n) = this%h1(this%n) + d2(i) + this%h(this%n) = this%h(this%n) + d2(i)*norm + this%h_sq(this%n) = this%h_sq(this%n) + d2(i)*norm**2 + endif + enddo + + endif + + endsubroutine histogram1d_add_linear_vals + + + !% Add multiple values to the histogram with linear interpolation + subroutine histogram1d_add_linear_vals_norms(this, vals, norms) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + real(DP), intent(in) :: norms(:) + + ! --- + + integer :: i1(lbound(vals, 1):ubound(vals, 1)), i2(lbound(vals, 1):ubound(vals, 1)) + real(DP) :: d1(lbound(vals, 1):ubound(vals, 1)), d2(lbound(vals, 1):ubound(vals, 1)) + + real(DP) :: d1n(lbound(vals, 1):ubound(vals, 1)), d2n(lbound(vals, 1):ubound(vals, 1)) + real(DP) :: d1nn(lbound(vals, 1):ubound(vals, 1)), d2nn(lbound(vals, 1):ubound(vals, 1)) + + integer :: i + + ! --- + + i1 = int(floor((vals-this%min_b)/this%dbin))+1 + i2 = i1+1 + + d1 = ( (i2-1) - (vals-this%min_b)/this%dbin )/this%dbin + d2 = ( (vals-this%min_b)/this%dbin - (i1-1) )/this%dbin + + ASSERT(all(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP)) + ASSERT(all(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP)) + + d1n = d1*norms + d2n = d2*norms + + d1nn = d1n*norms + d2nn = d2n*norms + + if (this%periodic) then + + i1 = modulo(i1-1, this%n)+1 + i2 = modulo(i2-1, this%n)+1 + + do i = lbound(vals, 1), ubound(vals, 1) + this%h1(i1(i)) = this%h1(i1(i)) + d1(i) + this%h1(i2(i)) = this%h1(i2(i)) + d2(i) + + this%h(i1(i)) = this%h(i1(i)) + d1n(i) + this%h(i2(i)) = this%h(i2(i)) + d2n(i) + + this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) + this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) + enddo + + else + + do i = lbound(vals, 1), ubound(vals, 1) + if (i1(i) >= 1 .and. i1(i) <= this%n) then + this%h1(i1(i)) = this%h1(i1(i)) + d1(i) + this%h(i1(i)) = this%h(i1(i)) + d1n(i) + this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) + else if (i1(i) == 0) then + this%h1(1) = this%h1(1) + d1(i) + this%h(1) = this%h(1) + d1n(i) + this%h_sq(1) = this%h_sq(1) + d1nn(i) + endif + + if (i2(i) >= 1 .and. i2(i) <= this%n) then + this%h1(i2(i)) = this%h1(i2(i)) + d2(i) + this%h(i2(i)) = this%h(i2(i)) + d2n(i) + this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) + else if (i2(i) == this%n+1) then + this%h1(this%n) = this%h1(this%n) + d2(i) + this%h(this%n) = this%h(this%n) + d2n(i) + this%h_sq(this%n) = this%h_sq(this%n) + d2nn(i) + endif + enddo + + endif + + endsubroutine histogram1d_add_linear_vals_norms + + + !% Add multiple values to the histogram with linear interpolation + !% and an additional mask + subroutine histogram1d_add_linear_vals_norm_mask(this, vals, norm, mask) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + real(DP), intent(in) :: norm + logical, intent(in) :: mask(:) + + ! --- + + integer :: i1(lbound(vals, 1):ubound(vals, 1)), i2(lbound(vals, 1):ubound(vals, 1)) + real(DP) :: d1(lbound(vals, 1):ubound(vals, 1)), d2(lbound(vals, 1):ubound(vals, 1)) + + real(DP) :: d1n(lbound(vals, 1):ubound(vals, 1)), d2n(lbound(vals, 1):ubound(vals, 1)) + real(DP) :: d1nn(lbound(vals, 1):ubound(vals, 1)), d2nn(lbound(vals, 1):ubound(vals, 1)) + + integer :: i + + ! --- + + i1 = int(floor((vals-this%min_b)/this%dbin))+1 + i2 = i1+1 + + d1 = ( (i2-1) - (vals-this%min_b)/this%dbin )/this%dbin + d2 = ( (vals-this%min_b)/this%dbin - (i1-1) )/this%dbin + + ASSERT(all(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP)) + ASSERT(all(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP)) + + d1n = d1*norm + d2n = d2*norm + + d1nn = d1n*norm + d2nn = d2n*norm + + if (this%periodic) then + + i1 = modulo(i1-1, this%n)+1 + i2 = modulo(i2-1, this%n)+1 + + do i = lbound(vals, 1), ubound(vals, 1) + if (mask(i)) then + this%h1(i1(i)) = this%h1(i1(i)) + d1(i) + this%h1(i2(i)) = this%h1(i2(i)) + d2(i) + + this%h(i1(i)) = this%h(i1(i)) + d1n(i) + this%h(i2(i)) = this%h(i2(i)) + d2n(i) + + this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) + this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) + endif + enddo + + else + + do i = lbound(vals, 1), ubound(vals, 1) + if (mask(i)) then + if (i1(i) >= 1 .and. i1(i) <= this%n) then + this%h1(i1(i)) = this%h1(i1(i)) + d1(i) + this%h(i1(i)) = this%h(i1(i)) + d1n(i) + this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) + else if (i1(i) == 0) then + this%h1(1) = this%h1(1) + d1(i) + this%h(1) = this%h(1) + d1n(i) + this%h_sq(1) = this%h_sq(1) + d1nn(i) + endif + + if (i2(i) >= 1 .and. i2(i) <= this%n) then + this%h1(i2(i)) = this%h1(i2(i)) + d2(i) + this%h(i2(i)) = this%h(i2(i)) + d2n(i) + this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) + else if (i2(i) == this%n+1) then + this%h1(this%n) = this%h1(this%n) + d2(i) + this%h(this%n) = this%h(this%n) + d2n(i) + this%h_sq(this%n) = this%h_sq(this%n) + d2nn(i) + endif + endif + enddo + + endif + + endsubroutine histogram1d_add_linear_vals_norm_mask + + + !% Add multiple values to the histogram with linear interpolation + !% and an additional mask + subroutine histogram1d_add_linear_vals_norms_mask(this, vals, norms, mask) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + real(DP), intent(in) :: norms(:) + logical, intent(in) :: mask(:) + + ! --- + + integer :: i1(lbound(vals, 1):ubound(vals, 1)), i2(lbound(vals, 1):ubound(vals, 1)) + real(DP) :: d1(lbound(vals, 1):ubound(vals, 1)), d2(lbound(vals, 1):ubound(vals, 1)) + + real(DP) :: d1n(lbound(vals, 1):ubound(vals, 1)), d2n(lbound(vals, 1):ubound(vals, 1)) + real(DP) :: d1nn(lbound(vals, 1):ubound(vals, 1)), d2nn(lbound(vals, 1):ubound(vals, 1)) + + integer :: i + + ! --- + + i1 = int(floor((vals-this%min_b)/this%dbin))+1 + i2 = i1+1 + + d1 = ( (i2-1) - (vals-this%min_b)/this%dbin )/this%dbin + d2 = ( (vals-this%min_b)/this%dbin - (i1-1) )/this%dbin + + ASSERT(all(d1 >= 0.0_DP .and. d1*this%dbin <= 1.0_DP)) + ASSERT(all(d2 >= 0.0_DP .and. d2*this%dbin <= 1.0_DP)) + + d1n = d1*norms + d2n = d2*norms + + d1nn = d1n*norms + d2nn = d2n*norms + + if (this%periodic) then + + i1 = modulo(i1-1, this%n)+1 + i2 = modulo(i2-1, this%n)+1 + + do i = lbound(vals, 1), ubound(vals, 1) + if (mask(i)) then + this%h1(i1(i)) = this%h1(i1(i)) + d1(i) + this%h1(i2(i)) = this%h1(i2(i)) + d2(i) + + this%h(i1(i)) = this%h(i1(i)) + d1n(i) + this%h(i2(i)) = this%h(i2(i)) + d2n(i) + + this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) + this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) + endif + enddo + + else + + do i = lbound(vals, 1), ubound(vals, 1) + if (mask(i)) then + if (i1(i) >= 1 .and. i1(i) <= this%n) then + this%h1(i1(i)) = this%h1(i1(i)) + d1(i) + this%h(i1(i)) = this%h(i1(i)) + d1n(i) + this%h_sq(i1(i)) = this%h_sq(i1(i)) + d1nn(i) + else if (i1(i) == 0) then + this%h1(1) = this%h1(1) + d1(i) + this%h(1) = this%h(1) + d1n(i) + this%h_sq(1) = this%h_sq(1) + d1nn(i) + endif + + if (i2(i) >= 1 .and. i2(i) <= this%n) then + this%h1(i2(i)) = this%h1(i2(i)) + d2(i) + this%h(i2(i)) = this%h(i2(i)) + d2n(i) + this%h_sq(i2(i)) = this%h_sq(i2(i)) + d2nn(i) + else if (i2(i) == this%n+1) then + this%h1(this%n) = this%h1(this%n) + d2(i) + this%h(this%n) = this%h(this%n) + d2n(i) + this%h_sq(this%n) = this%h_sq(this%n) + d2nn(i) + endif + endif + enddo + + endif + + endsubroutine histogram1d_add_linear_vals_norms_mask + + + !% Add a value which is broadened by a smoothing function to the histogram + subroutine histogram1d_add_smoothed(this, val, norm) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: val + real(DP), intent(in) :: norm + + ! --- + + real(DP) :: expvals(this%n) + + integer :: i1, i2, g1, g2 + real(DP) :: x2 + + ! --- + + x2 = (val-this%min_b)/this%dbin + 0.5_DP + i1 = floor(x2) + x2 = x2 - i1 + + g1 = -this%ng + g2 = this%ng-1 + + expvals(1:2*this%ng) = x2*this%smoothing_func(g1:g2) + (1.0_DP-x2)*this%smoothing_func(g1+1:g2+1) + + i1 = i1 - this%ng+1 + i2 = i1 + 2*this%ng - 1 + + ! + ! Cut smoothing function if we're at the border + ! + + g1 = 1 + g2 = 2*this%ng + + if (i1 < 1) then + g1 = g1 + (1 - i1) + i1 = 1 + endif + + if (i2 > this%n) then + g2 = g2 - (i2 - this%n) + i2 = this%n + endif + + this%h1(i1:i2) = this%h1(i1:i2) + expvals(g1:g2) + this%h(i1:i2) = this%h(i1:i2) + expvals(g1:g2)*norm + this%h_sq(i1:i2) = this%h_sq(i1:i2) + expvals(g1:g2)*norm**2 + + endsubroutine histogram1d_add_smoothed + + + !********************************************************************** + ! Add a value + !********************************************************************** + subroutine histogram1d_add(this, val, norm) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: val + real(DP), intent(in), optional :: norm + + ! --- + + real(DP) :: n + + ! --- + + if (present(norm)) then + n = norm + else + n = 1.0_DP + endif + + if (this%interp == INTERP_LINEAR) then + call histogram1d_add_linear(this, val, n) + else + call histogram1d_add_smoothed(this, val, n) + endif + + endsubroutine histogram1d_add + + + !% Add a list of values to the histogram + subroutine histogram1d_add_vals(this, vals, norm) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + real(DP), intent(in), optional :: norm + + ! --- + + integer :: i + real(DP) :: n + + ! --- + + if (present(norm)) then + n = norm + else + n = 1.0_DP + endif + + if (this%interp == INTERP_LINEAR) then + + call histogram1d_add_linear_vals(this, vals, n) + + else + + do i = lbound(vals, 1), ubound(vals, 1) + call histogram1d_add_smoothed(this, vals(i), n) + enddo + + endif + + endsubroutine histogram1d_add_vals + + + !% Add a list of values to the histogram + subroutine histogram1d_add_vals_mask(this, vals, mask) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + logical, intent(in) :: mask(:) + + ! --- + + integer :: i + + ! --- + + if (this%interp == INTERP_LINEAR) then + + do i = lbound(vals, 1), ubound(vals, 1) + if (mask(i)) then + call histogram1d_add_linear(this, vals(i), 1.0_DP) + endif + enddo + + else + + do i = lbound(vals, 1), ubound(vals, 1) + if (mask(i)) then + call histogram1d_add_smoothed(this, vals(i), 1.0_DP) + endif + enddo + + endif + + endsubroutine histogram1d_add_vals_mask + + + !% Add a list of values to the histogram + subroutine histogram1d_add_vals_norms(this, vals, norms) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + real(DP), intent(in) :: norms(:) + + ! --- + + integer :: i + + ! --- + + if (this%interp == INTERP_LINEAR) then + + call histogram1d_add_linear_vals_norms(this, vals, norms) + + else + + do i = lbound(vals, 1), ubound(vals, 1) + call histogram1d_add_smoothed(this, vals(i), norms(i)) + enddo + + endif + + endsubroutine histogram1d_add_vals_norms + + + !% Add a list of values to the histogram + subroutine histogram1d_add_vals_norm_mask(this, vals, norm, mask) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + real(DP), intent(in) :: norm + logical, intent(in) :: mask(:) + + ! --- + + integer :: i + + ! --- + + if (this%interp == INTERP_LINEAR) then + + call histogram1d_add_linear_vals_norm_mask(this, vals, norm, mask) + + else + + do i = lbound(vals, 1), ubound(vals, 1) + if (mask(i)) then + call histogram1d_add_smoothed(this, vals(i), norm) + endif + enddo + + endif + + endsubroutine histogram1d_add_vals_norm_mask + + + !% Add a list of values to the histogram + subroutine histogram1d_add_vals_norms_mask(this, vals, norms, mask) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(:) + real(DP), intent(in) :: norms(:) + logical, intent(in) :: mask(:) + + ! --- + + integer :: i + + ! --- + + if (this%interp == INTERP_LINEAR) then + + call histogram1d_add_linear_vals_norms_mask(this, vals, norms, mask) + + else + + do i = lbound(vals, 1), ubound(vals, 1) + if (mask(i)) then + call histogram1d_add_smoothed(this, vals(i), norms(i)) + endif + enddo + + endif + + endsubroutine histogram1d_add_vals_norms_mask + + + !% Add a range of values to the histogram (linear interpolation only) + subroutine histogram1d_add_range(this, vala, valb, norm, error) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vala + real(DP), intent(in) :: valb + real(DP), intent(in), optional :: norm + integer, intent(out), optional :: error + + ! --- + + integer :: i1a, i2a, i1b, i2b, i + real(DP) :: d1a, d1b, d2a, d2b + real(DP) :: va, vb, fac, n, n_sq + + ! --- + + INIT_ERROR(error) + + if (this%interp /= INTERP_LINEAR) then + RAISE_ERROR("*histogram1d_add_range* can only be used with linear interpolation.", error) + endif + + n = 1.0_DP + if (present(norm)) then + n = norm + endif + n_sq = n**2 + + if (vala > valb) then + va = valb + vb = vala + else + va = vala + vb = valb + endif + + i1a = int(floor((va-this%min_b)/this%dbin))+1 + i2a = i1a+1 + + d1a = ( (i2a-1) - (va-this%min_b)/this%dbin ) + d2a = ( (va-this%min_b)/this%dbin - (i1a-1) ) + + i1b = int(floor((vb-this%min_b)/this%dbin))+1 + i2b = i1b+1 + + d1b = ( (i2b-1) - (vb-this%min_b)/this%dbin ) + d2b = ( (vb-this%min_b)/this%dbin - (i1b-1) ) + + if (va == vb) then + + this%h1(i1a) = this%h1(i1a) + d1a + this%h(i1a) = this%h(i1a) + d1a*n + this%h_sq(i1a) = this%h_sq(i1a) + d1a*n_sq + + this%h1(i2a) = this%h1(i2a) + d2a + this%h(i2a) = this%h(i2a) + d2a*n + this%h_sq(i2a) = this%h_sq(i2a) + d2a*n_sq + + else + + fac = 1.0_DP/(vb-va) + + if (i1a == i1b) then + + d1a = fac * ( d2b * ( 1.0_DP - 0.5_DP*d2b ) - d2a * ( 1.0_DP - 0.5_DP*d2a ) ) + d2a = fac * 0.5_DP * ( d2b**2 - d2a**2 ) + + this%h1(i1a) = this%h1(i1a) + d1a + this%h(i1a) = this%h(i1a) + d1a*n + this%h_sq(i1a) = this%h_sq(i1a) + d1a*n_sq + + this%h1(i2a) = this%h1(i2a) + d2a + this%h(i2a) = this%h(i2a) + d2a*n + this%h_sq(i2a) = this%h_sq(i2a) + d2a*n_sq + + else + + forall(i = i2a:i1b-1) + this%h1(i) = this%h1(i) + 0.5_DP*fac + this%h(i) = this%h(i) + 0.5_DP*fac*n + this%h_sq(i) = this%h_sq(i) + 0.5_DP*fac*n_sq + + this%h1(i+1) = this%h1(i+1) + 0.5_DP*fac + this%h(i+1) = this%h(i+1) + 0.5_DP*fac*n + this%h_sq(i+1) = this%h_sq(i+1) + 0.5_DP*fac*n_sq + endforall + + d2a = fac * d1a * ( 1 - 0.5_DP*d1a ) + d1a = fac * 0.5_DP * d1a**2 + + d1b = fac * d2b * ( 1 - 0.5_DP*d2b ) + d2b = fac * 0.5_DP * d2b**2 + + this%h1(i1a) = this%h1(i1a) + d1a + this%h(i1a) = this%h(i1a) + d1a*n + this%h_sq(i1a) = this%h_sq(i1a) + d1a*n_sq + + this%h1(i1b) = this%h1(i1b) + d1b + this%h(i1b) = this%h(i1b) + d1b*n + this%h_sq(i1b) = this%h_sq(i1b) + d1b*n_sq + + this%h1(i2a) = this%h1(i2a) + d2a + this%h(i2a) = this%h(i2a) + d2a*n + this%h_sq(i2a) = this%h_sq(i2a) + d2a*n_sq + + this%h1(i2b) = this%h1(i2b) + d2b + this%h(i2b) = this%h(i2b) + d2b*n + this%h_sq(i2b) = this%h_sq(i2b) + d2b*n_sq + + endif + + endif + + endsubroutine histogram1d_add_range + + + !% Add a range of values to the histogram (linear interpolation only) + subroutine histogram1d_add_range_vals(this, valsa, valsb, norm, mask, error) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: valsa(:) + real(DP), intent(in) :: valsb(:) + real(DP), intent(in), optional :: norm + logical, intent(in), optional :: mask(:) + integer, intent(out), optional :: error + + ! --- + + integer :: i, j + integer :: i1a(lbound(valsa, 1):ubound(valsa, 1)), i2a(lbound(valsa, 1):ubound(valsa, 1)) + integer :: i1b(lbound(valsb, 1):ubound(valsb, 1)), i2b(lbound(valsb, 1):ubound(valsb, 1)) + real(DP) :: d1a(lbound(valsa, 1):ubound(valsa, 1)), d2a(lbound(valsa, 1):ubound(valsa, 1)) + real(DP) :: d1b(lbound(valsb, 1):ubound(valsb, 1)), d2b(lbound(valsb, 1):ubound(valsb, 1)) + real(DP) :: va(lbound(valsa, 1):ubound(valsa, 1)), vb(lbound(valsb, 1):ubound(valsb, 1)) + real(DP) :: fac(lbound(valsa, 1):ubound(valsa, 1)) + real(DP) :: n, n_sq + logical :: m(lbound(valsa, 1):ubound(valsa, 1)) + + ! --- + + INIT_ERROR(error) + + if (this%interp /= INTERP_LINEAR) then + RAISE_ERROR("*histogram1d_add_range* can only be used with linear interpolation.", error) + endif + + n = 1.0_DP + if (present(norm)) then + n = norm + endif + n_sq = n**2 + + where (valsa > valsb) + va = valsb + vb = valsa + elsewhere + va = valsa + vb = valsb + endwhere + + fac = 1.0_DP + where (va /= vb) + fac = 1.0_DP/(vb-va) + endwhere + + m = .true. + if (present(mask)) then + m = mask + endif + + i1a = int(floor((va-this%min_b)/this%dbin))+1 + i2a = i1a+1 + + d1a = ( (i2a-1) - (va-this%min_b)/this%dbin ) + d2a = ( (va-this%min_b)/this%dbin - (i1a-1) ) + + i1b = int(floor((vb-this%min_b)/this%dbin))+1 + i2b = i1b+1 + + d1b = ( (i2b-1) - (vb-this%min_b)/this%dbin ) + d2b = ( (vb-this%min_b)/this%dbin - (i1b-1) ) + + + do j = lbound(valsa, 1), ubound(valsa, 1) + + if (m(j)) then + + if (va(j) == vb(j)) then + + this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) + this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*n + this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*n_sq + + this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) + this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*n + this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*n_sq + + else + + if (i1a(j) == i1b(j)) then + + d1a(j) = fac(j) * ( d2b(j) * ( 1.0_DP - 0.5_DP*d2b(j) ) - d2a(j) * ( 1.0_DP - 0.5_DP*d2a(j) ) ) + d2a(j) = fac(j) * 0.5_DP * ( d2b(j)**2 - d2a(j)**2 ) + + this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) + this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*n + this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*n_sq + + this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) + this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*n + this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*n_sq + + else + + forall(i = i2a(j):i1b(j)-1) + this%h1(i) = this%h1(i) + 0.5_DP*fac(j) + this%h(i) = this%h(i) + 0.5_DP*fac(j)*n + this%h_sq(i) = this%h_sq(i) + 0.5_DP*fac(j)*n_sq + + this%h1(i+1) = this%h1(i+1) + 0.5_DP*fac(j) + this%h(i+1) = this%h(i+1) + 0.5_DP*fac(j)*n + this%h_sq(i+1) = this%h_sq(i+1) + 0.5_DP*fac(j)*n_sq + endforall + + d2a(j) = fac(j) * d1a(j) * ( 1 - 0.5_DP*d1a(j) ) + d1a(j) = fac(j) * 0.5_DP * d1a(j)**2 + + d1b(j) = fac(j) * d2b(j) * ( 1 - 0.5_DP*d2b(j) ) + d2b(j) = fac(j) * 0.5_DP * d2b(j)**2 + + this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) + this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*n + this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*n_sq + + this%h1(i1b(j)) = this%h1(i1b(j)) + d1b(j) + this%h(i1b(j)) = this%h(i1b(j)) + d1b(j)*n + this%h_sq(i1b(j)) = this%h_sq(i1b(j)) + d1b(j)*n_sq + + this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) + this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*n + this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*n_sq + + this%h1(i2b(j)) = this%h1(i2b(j)) + d2b(j) + this%h(i2b(j)) = this%h(i2b(j)) + d2b(j)*n + this%h_sq(i2b(j)) = this%h_sq(i2b(j)) + d2b(j)*n_sq + + endif + + endif + + endif + + enddo + + endsubroutine histogram1d_add_range_vals + + + !% Add a range of values to the histogram (linear interpolation only) + subroutine histogram1d_add_range_vals_norms(this, valsa, valsb, norms, mask, error) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: valsa(:) + real(DP), intent(in) :: valsb(:) + real(DP), intent(in) :: norms(:) + logical, intent(in), optional :: mask(:) + integer, intent(out), optional :: error + + ! --- + + integer :: i, j + integer :: i1a(lbound(valsa, 1):ubound(valsa, 1)), i2a(lbound(valsa, 1):ubound(valsa, 1)) + integer :: i1b(lbound(valsb, 1):ubound(valsb, 1)), i2b(lbound(valsb, 1):ubound(valsb, 1)) + real(DP) :: d1a(lbound(valsa, 1):ubound(valsa, 1)), d2a(lbound(valsa, 1):ubound(valsa, 1)) + real(DP) :: d1b(lbound(valsb, 1):ubound(valsb, 1)), d2b(lbound(valsb, 1):ubound(valsb, 1)) + real(DP) :: va(lbound(valsa, 1):ubound(valsa, 1)), vb(lbound(valsb, 1):ubound(valsb, 1)) + real(DP) :: fac(lbound(valsa, 1):ubound(valsa, 1)) + logical :: m(lbound(valsa, 1):ubound(valsa, 1)) + + ! --- + + INIT_ERROR(error) + + if (this%interp /= INTERP_LINEAR) then + RAISE_ERROR("*histogram1d_add_range* can only be used with linear interpolation.", error) + endif + + where (valsa > valsb) + va = valsb + vb = valsa + elsewhere + va = valsa + vb = valsb + endwhere + + fac = 1.0_DP + where (va /= vb) + fac = 1.0_DP/(vb-va) + endwhere + + m = .true. + if (present(mask)) then + m = mask + endif + + i1a = int(floor((va-this%min_b)/this%dbin))+1 + i2a = i1a+1 + + d1a = ( (i2a-1) - (va-this%min_b)/this%dbin ) + d2a = ( (va-this%min_b)/this%dbin - (i1a-1) ) + + i1b = int(floor((vb-this%min_b)/this%dbin))+1 + i2b = i1b+1 + + d1b = ( (i2b-1) - (vb-this%min_b)/this%dbin ) + d2b = ( (vb-this%min_b)/this%dbin - (i1b-1) ) + + + do j = lbound(valsa, 1), ubound(valsa, 1) + + if (m(j)) then + + if (va(j) == vb(j)) then + + this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) + this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*norms(j) + this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*norms(j)*norms(j) + + this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) + this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*norms(j) + this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*norms(j)*norms(j) + + else + + if (i1a(j) == i1b(j)) then + + d1a(j) = fac(j) * ( d2b(j) * ( 1.0_DP - 0.5_DP*d2b(j) ) - d2a(j) * ( 1.0_DP - 0.5_DP*d2a(j) ) ) + d2a(j) = fac(j) * 0.5_DP * ( d2b(j)**2 - d2a(j)**2 ) + + this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) + this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*norms(j) + this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*norms(j)*norms(j) + + this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) + this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*norms(j) + this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*norms(j)*norms(j) + + else + + forall(i = i2a(j):i1b(j)-1) + this%h1(i) = this%h1(i) + 0.5_DP*fac(j) + this%h(i) = this%h(i) + 0.5_DP*fac(j)*norms(j) + this%h_sq(i) = this%h_sq(i) + 0.5_DP*fac(j)*norms(j)*norms(j) + + this%h1(i+1) = this%h1(i+1) + 0.5_DP*fac(j) + this%h(i+1) = this%h(i+1) + 0.5_DP*fac(j)*norms(j) + this%h_sq(i+1) = this%h_sq(i+1) + 0.5_DP*fac(j)*norms(j)*norms(j) + endforall + + d2a(j) = fac(j) * d1a(j) * ( 1 - 0.5_DP*d1a(j) ) + d1a(j) = fac(j) * 0.5_DP * d1a(j)**2 + + d1b(j) = fac(j) * d2b(j) * ( 1 - 0.5_DP*d2b(j) ) + d2b(j) = fac(j) * 0.5_DP * d2b(j)**2 + + this%h1(i1a(j)) = this%h1(i1a(j)) + d1a(j) + this%h(i1a(j)) = this%h(i1a(j)) + d1a(j)*norms(j) + this%h_sq(i1a(j)) = this%h_sq(i1a(j)) + d1a(j)*norms(j)*norms(j) + + this%h1(i1b(j)) = this%h1(i1b(j)) + d1b(j) + this%h(i1b(j)) = this%h(i1b(j)) + d1b(j)*norms(j) + this%h_sq(i1b(j)) = this%h_sq(i1b(j)) + d1b(j)*norms(j)*norms(j) + + this%h1(i2a(j)) = this%h1(i2a(j)) + d2a(j) + this%h(i2a(j)) = this%h(i2a(j)) + d2a(j)*norms(j) + this%h_sq(i2a(j)) = this%h_sq(i2a(j)) + d2a(j)*norms(j)*norms(j) + + this%h1(i2b(j)) = this%h1(i2b(j)) + d2b(j) + this%h(i2b(j)) = this%h(i2b(j)) + d2b(j)*norms(j) + this%h_sq(i2b(j)) = this%h_sq(i2b(j)) + d2b(j)*norms(j)*norms(j) + + endif + + endif + + endif + + enddo + + endsubroutine histogram1d_add_range_vals_norms + + + !% Add two histograms + subroutine histogram1d_add_histogram(this, that, fac) + implicit none + + type(Histogram1D), intent(inout) :: this + type(Histogram1D), intent(in) :: that + real(DP), intent(in), optional :: fac + + ! --- + + this%h1 = this%h1 + that%h1 + if (present(fac)) then + this%h = this%h + fac*that%h + else + this%h = this%h + that%h + endif + + endsubroutine histogram1d_add_histogram + + + !% Add a two vectors of multiple histograms histograms + subroutine histogram1d_add_mult_histograms(this, that, fac) + implicit none + + type(Histogram1D), intent(inout) :: this(:) + type(Histogram1D), intent(in) :: that(lbound(this,1):ubound(this,1)) + real(DP), intent(in), optional :: fac + + ! --- + + integer :: i + + ! --- + + do i = lbound(this,1), ubound(this,1) + this(i)%h1 = this(i)%h1 + that(i)%h1 + if (present(fac)) then + this(i)%h = this(i)%h + fac*that(i)%h + else + this(i)%h = this(i)%h + that(i)%h + endif + enddo + + endsubroutine histogram1d_add_mult_histograms + + + !% Compute average value in each bin (does only makes sense if + !% norm != 1 was used in the add functions) + subroutine histogram1d_average(this, mpi) + implicit none + + type(Histogram1D), intent(inout) :: this + type(MPI_context), optional, intent(in) :: mpi + + ! --- + + if (present(mpi)) then + call sum_in_place(mpi, this%h1) + call sum_in_place(mpi, this%h) + call sum_in_place(mpi, this%h_sq) + endif + + where (this%h1 == 0.0_DP) + this%h1 = 1.0_DP + endwhere + + this%h = this%h / this%h1 + this%h_sq = this%h_sq / this%h1 + + endsubroutine histogram1d_average + + + !% Compute Shannon entropy of this histogram. Needs to be called + !% after normalize. + elemental function histogram1d_entropy(this) result(val) + implicit none + + type(Histogram1D), intent(in) :: this + real(DP) :: val + + ! --- + + integer :: i + real(DP) :: S + + ! --- + + S = 0.0_DP + do i = 1, this%n + if (this%h(i) > 0.0_DP) then + S = S - this%h(i)*log(this%h(i)*this%dbin) + endif + enddo + + val = S*this%dbin + + endfunction histogram1d_entropy + + + !% Compute expectation value + elemental function histogram1d_expectation_value(this) result(val) + implicit none + + type(Histogram1D), intent(in) :: this + real(DP) :: val + + ! --- + + real(DP) :: n + + ! --- + + n = sum(this%h) + + if (n == 0.0_DP) then + val = 0.0_DP + else + val = sum(this%x * this%h / n) + endif + + endfunction histogram1d_expectation_value + + + !% Multiply the histogram by a value - for normalization + subroutine histogram1d_mul(this, val) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: val + + ! --- + + this%h = this%h * val + + endsubroutine histogram1d_mul + + + !% Multiply multiple histograms by a value - for normalization + subroutine histograms_mul(this, val) + implicit none + + type(Histogram1D), intent(inout) :: this(:) + real(DP), intent(in) :: val + + ! --- + + integer :: i + + ! --- + + do i = lbound(this, 1), ubound(this, 1) + this(i)%h = this(i)%h * val + enddo + + endsubroutine histograms_mul + + + !% Multiply multiple histograms by a value - for normalization + subroutine histograms2_mul(this, val) + implicit none + + type(Histogram1D), intent(inout) :: this(:, :) + real(DP), intent(in) :: val + + ! --- + + integer :: i, j + + ! --- + + do i = lbound(this, 1), ubound(this, 1) + do j = lbound(this, 2), ubound(this, 2) + this(i, j)%h = this(i, j)%h * val + enddo + enddo + + endsubroutine histograms2_mul + + + !% Multiply the histogram by multiple value - for normalization + subroutine histogram1d_mul_vals(this, vals) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(this%n) + + ! --- + + this%h = this%h * vals + + endsubroutine histogram1d_mul_vals + + + !% Divide histogram by a value + subroutine histogram1d_div(this, val) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: val + + ! --- + + this%h = this%h / val + + endsubroutine histogram1d_div + + + !% Divide multiple histograms by a value + subroutine histograms_div(this, val) + implicit none + + type(Histogram1D), intent(inout) :: this(:) + real(DP), intent(in) :: val + + ! --- + + integer :: i + + ! --- + + do i = lbound(this, 1), ubound(this, 1) + this(i)%h = this(i)%h / val + enddo + + endsubroutine histograms_div + + + !% Divide multiple histograms by a value + subroutine histograms2_div(this, val) + implicit none + + type(Histogram1D), intent(inout) :: this(:, :) + real(DP), intent(in) :: val + + ! --- + + integer :: i, j + + ! --- + + do i = lbound(this, 1), ubound(this, 1) + do j = lbound(this, 2), ubound(this, 2) + this(i, j)%h = this(i, j)%h / val + enddo + enddo + + endsubroutine histograms2_div + + + !% Divide histogram by multiple values + subroutine histogram1d_div_vals(this, vals) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: vals(this%n) + + ! --- + + this%h = this%h / vals + + endsubroutine histogram1d_div_vals + + + !% Normalize histogram + elemental subroutine histogram1d_normalize(this) + implicit none + + type(Histogram1D), intent(inout) :: this + + ! --- + + real(DP) :: n + + ! --- + + n = sum(this%h*this%dbin) + + if (n /= 0.0_DP) then + this%h = this%h / n + endif + + endsubroutine histogram1d_normalize + + + !% OpenMP reduction - *thpriv* is a threadprivate histogram, + !% this needs to be called within an *omp parallel* construct. + subroutine histogram1d_reduce(this, thpriv) + implicit none + + type(Histogram1D), intent(inout) :: this + type(Histogram1D), intent(in) :: thpriv + + ! --- + + !$omp single + call initialise(this, thpriv) + !$omp end single + + !$omp critical + this%h = this%h + thpriv%h + this%h_sq = this%h_sq + thpriv%h_sq + this%h1 = this%h1 + thpriv%h1 + !$omp end critical + + endsubroutine histogram1d_reduce + + + !% Smooth histogram by convolution with a Gaussian + subroutine histogram1d_smooth(this, sigma) + implicit none + + type(Histogram1D), intent(inout) :: this + real(DP), intent(in) :: sigma + + ! --- + + integer :: i + real(DP) :: fac, sigma_sq, h(this%n) + + ! --- + + h = 0.0_DP + + fac = this%dbin/(sqrt(2*PI)*sigma) + sigma_sq = sigma**2 + + do i = 1, this%n + h = h + fac*this%h(i)*exp(-((this%x - this%x(i))**2/(2*sigma_sq))) + enddo + + this%h = h + + endsubroutine histogram1d_smooth + + + !% Sum histogram from different processors onto root + subroutine histogram1d_sum_in_place(mpi, this) + implicit none + + type(MPI_context), intent(in) :: mpi + type(Histogram1D), intent(inout) :: this + + ! --- + + call sum_in_place(mpi, this%h) + call sum_in_place(mpi, this%h_sq) + call sum_in_place(mpi, this%h1) + + endsubroutine histogram1d_sum_in_place + + +#if 0 + !********************************************************************** + ! Memory estimate logging + !********************************************************************** + subroutine log_memory_estimate_histogram(this) + implicit none + + type(Histogram1D), intent(in) :: this + + ! --- + + call log_memory_estimate(this%x) + call log_memory_estimate(this%h) + call log_memory_estimate(this%h_sq) + call log_memory_estimate(this%h1) + + endsubroutine log_memory_estimate_histogram + + + !********************************************************************** + ! Memory estimate logging + !********************************************************************** + subroutine log_memory_estimate_histogram2(this) + implicit none + + type(Histogram1D), intent(in) :: this(:) + + ! --- + + integer :: i + + ! --- + + do i = lbound(this, 1), ubound(this, 1) + call log_memory_estimate_histogram(this(i)) + enddo + + endsubroutine log_memory_estimate_histogram2 + + + !********************************************************************** + ! Memory estimate logging + !********************************************************************** + subroutine log_memory_estimate_histogram3(this) + implicit none + + type(Histogram1D), intent(in) :: this(:, :) + + ! --- + + integer :: i, j + + ! --- + + do j = lbound(this, 2), ubound(this, 2) + do i = lbound(this, 1), ubound(this, 1) + call log_memory_estimate_histogram(this(i, j)) + enddo + enddo + + endsubroutine log_memory_estimate_histogram3 +#endif + +endmodule histogram1d_module diff --git a/src/libAtoms/histogram2d.F90 b/src/libAtoms/histogram2d.F90 new file mode 100644 index 0000000000..0fe9346720 --- /dev/null +++ b/src/libAtoms/histogram2d.F90 @@ -0,0 +1,826 @@ +!********************************************************************** +! Histogram helper functions +!********************************************************************** + +#include "macros.inc" + +module histogram2d_module + use libAtoms_module + + use io + use logging + + private + public : histogram2d, init, del, clear, set_bounds, write, add, average, mul, normalize, reduce, log_memory_estimate + + integer, parameter :: INTERP_LINEAR = 0 + integer, parameter :: INTERP_LUCY = 1 + + type histogram2d_t + + ! + ! General stuff + ! + + integer :: n(2) = -1 ! number of bins + real(DP) :: min_b(2) ! minimum value + real(DP) :: max_b(2) ! minimum value + real(DP) :: db(2) ! difference + real(DP) :: dbin(2) ! bin size + + logical :: periodic(2) + + ! + ! Values + ! + + real(DP), allocatable :: x1(:) ! x-values + real(DP), allocatable :: x2(:) ! x-values + + real(DP), allocatable :: h(:, :) ! values + integer, allocatable :: h1(:, :) ! histogram2d with norm 1 (number of values which have been added to each bin) + + endtype histogram2d_t + + ! + ! Interface definition + ! + + interface init + module procedure histogram2d_init, histogram2d_init_from_histogram2d + endinterface + + interface del + module procedure histogram2d_del + endinterface + + interface clear + module procedure histogram2d_clear + endinterface + + interface set_bounds + module procedure histogram2d_set_bounds + endinterface + + interface write + module procedure histogram2d_write, histogram2d_write_mult + module procedure histogram2d_write_character_fn, histogram2d_write_mult_character_fn + endinterface +, + interface add + module procedure histogram2d_add, histogram2d_add_vals, histogram2d_add_vals_norms + module procedure histogram2d_add_vals_mask, histogram2d_add_vals_norm_mask, histogram2d_add_vals_norms_mask + module procedure histogram2d_add_histogram2d + endinterface + + interface average + module procedure histogram2d_average + endinterface + + interface mul + module procedure histogram2d_mul, histogram2ds_mul, histogram2ds2_mul + endinterface + + interface normalize + module procedure histogram2d_normalize + endinterface + + interface reduce + module procedure histogram2d_reduce + endinterface + + interface log_memory_estimate + module procedure log_memory_estimate_histogram2d, log_memory_estimate_histogram2d2, log_memory_estimate_histogram2d3 + endinterface + +contains + + !********************************************************************** + ! Initialize the histogram2d + !********************************************************************** + elemental subroutine histogram2d_init(this, n1, n2, min_b1, max_b1, min_b2, max_b2, periodic1, periodic2) + implicit none + + type(histogram2d_t), intent(out) :: this + integer, intent(in) :: n1 + integer, intent(in) :: n2 + real(DP), intent(in) :: min_b1 + real(DP), intent(in) :: max_b1 + real(DP), intent(in) :: min_b2 + real(DP), intent(in) :: max_b2 + logical, intent(in), optional :: periodic1 + logical, intent(in), optional :: periodic2 + + ! --- + + call del(this) + + this%n = (/ n1, n2 /) + + this%periodic = .false. + + if (present(periodic1)) then + this%periodic(1) = periodic1 + endif + + if (present(periodic2)) then + this%periodic(2) = periodic2 + endif + + allocate(this%x1(this%n(1))) + allocate(this%x2(this%n(2))) + allocate(this%h(this%n(1), this%n(2))) + allocate(this%h1(this%n(1), this%n(2))) + + this%min_b = (/ min_b1, min_b2 /) - 1.0_DP + this%max_b = (/ max_b1, min_b2 /) - 1.0_DP + + call histogram2d_set_bounds(this, min_b1, max_b1, min_b2, max_b2) + + call histogram2d_clear(this) + + endsubroutine histogram2d_init + + + !********************************************************************** + ! Initialize the histogram2d + !********************************************************************** + elemental subroutine histogram2d_init_from_histogram2d(this, that) + implicit none + + type(histogram2d_t), intent(out) :: this + type(histogram2d_t), intent(in) :: that + + ! --- + + call del(this) + + this%n = that%n + this%periodic = that%periodic + + allocate(this%x1(this%n(1))) + allocate(this%x2(this%n(2))) + allocate(this%h(this%n(1), this%n(2))) + allocate(this%h1(this%n(1), this%n(2))) + + this%min_b = that%min_b - 1.0_DP + this%max_b = that%max_b - 1.0_DP + + call histogram2d_set_bounds(this, that%min_b(1), that%max_b(1), that%min_b(2), that%max_b(2)) + + call histogram2d_clear(this) + + endsubroutine histogram2d_init_from_histogram2d + + + !********************************************************************** + ! Clear histogram2d + !********************************************************************** + elemental subroutine histogram2d_clear(this) + implicit none + + type(histogram2d_t), intent(inout) :: this + + ! --- + + this%h1 = 0 + this%h = 0.0_DP + + endsubroutine histogram2d_clear + + + !********************************************************************** + ! Initialize the histogram2d + !********************************************************************** + elemental subroutine histogram2d_set_bounds(this, min_b1, max_b1, min_b2, max_b2) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: min_b1 + real(DP), intent(in) :: max_b1 + real(DP), intent(in) :: min_b2 + real(DP), intent(in) :: max_b2 + + ! --- + + integer :: i + + ! --- + + if (any(this%min_b /= (/ min_b1, min_b2 /)) .or. any(this%max_b /= (/ max_b1, max_b2 /))) then + + this%min_b = (/ min_b1, min_b2 /) + this%max_b = (/ max_b1, max_b2 /) + this%db = this%max_b - this%min_b + + this%dbin = this%db/this%n + + do i = 1, this%n(1) + this%x1(i) = this%min_b(1) + this%dbin(1)*(i-0.5_DP) + this%x2(i) = this%min_b(2) + this%dbin(2)*(i-0.5_DP) + enddo + + endif + + endsubroutine histogram2d_set_bounds + + + !********************************************************************** + ! Delete a histogram2d table + !********************************************************************** + elemental subroutine histogram2d_del(this) + implicit none + + type(histogram2d_t), intent(inout) :: this + + ! --- + + if (allocated(this%x1)) then + deallocate(this%x1) + endif + if (allocated(this%x2)) then + deallocate(this%x2) + endif + if (allocated(this%h)) then + deallocate(this%h) + endif + if (allocated(this%h1)) then + deallocate(this%h1) + endif + + endsubroutine histogram2d_del + + + !********************************************************************** + ! Output the histogram2d table to a file (by file unit) + !********************************************************************** + subroutine histogram2d_write_mult(this, un, ierror) + implicit none + + type(histogram2d_t), intent(in) :: this(:) + integer, intent(in) :: un + integer, intent(inout), optional :: ierror + + ! --- + + integer :: i, j, k + character(80) :: fmt + + integer :: n(2) + real(DP) :: min_b(2), max_b(2), dbin(2), y(lbound(this, 1):ubound(this, 1)) + + ! --- + + n = this(lbound(this, 1))%n + min_b = this(lbound(this, 1))%min_b + max_b = this(lbound(this, 1))%max_b + dbin = this(lbound(this, 1))%dbin + + do i = lbound(this, 1)+1, ubound(this, 1) + if (any(this(i)%n /= n)) then + RAISE_ERROR("Number of histogram2d bins do not match.", ierror) + endif + + if (any(this(i)%min_b /= min_b)) then + RAISE_ERROR("*min_b*s do not match.", ierror) + endif + + if (any(this(i)%max_b /= max_b)) then + RAISE_ERROR("*max_b*s do not match.", ierror) + endif + enddo + + write (fmt, '(A,I4.4,A)') "(", ubound(this, 1)-lbound(this, 1)+3, "ES20.10)" + + do i = 1, n(1) + do j = 1, n(2) + do k = lbound(this, 1), ubound(this, 1) + y(k) = this(k)%h(i, j) + enddo + + write (un, trim(fmt)) this(lbound(this, 1))%x1(i), this(lbound(this, 1))%x2(j), y + enddo + + write (un, *) + enddo + + endsubroutine histogram2d_write_mult + + + !********************************************************************** + ! Output the histogram2d table to a file (by file name) + !********************************************************************** + subroutine histogram2d_write_mult_character_fn(this, fn, ierror) + implicit none + + type(histogram2d_t), intent(in) :: this(:) + character(*), intent(in) :: fn + integer, intent(inout), optional :: ierror + + ! --- + + integer :: un + + ! --- + + un = fopen(fn, F_WRITE) + call histogram2d_write_mult(this, un, ierror=ierror) + call fclose(un) + + PASS_ERROR(ierror) + + endsubroutine histogram2d_write_mult_character_fn + + + !********************************************************************** + ! Output the histogram2d table to a file (by file unit) + !********************************************************************** + subroutine histogram2d_write(this, un, ierror) + implicit none + + type(histogram2d_t), intent(in) :: this + integer, intent(in) :: un + integer, intent(inout), optional :: ierror + + ! --- + + call histogram2d_write_mult((/ this /), un, ierror=ierror) + PASS_ERROR(ierror) + + endsubroutine histogram2d_write + + + !********************************************************************** + ! Output the histogram2d table to a file (by file name) + !********************************************************************** + subroutine histogram2d_write_character_fn(this, fn, ierror) + implicit none + + type(histogram2d_t), intent(in) :: this + character(*), intent(in) :: fn + integer, intent(inout), optional :: ierror + + ! --- + + call histogram2d_write_mult_character_fn((/ this /), fn, ierror) + PASS_ERROR(ierror) + + endsubroutine histogram2d_write_character_fn + + + !********************************************************************** + ! Add a value to the histogram2d with linear interpolation + !********************************************************************** + subroutine histogram2d_add_linear(this, val1, val2, norm) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: val1 + real(DP), intent(in) :: val2 + real(DP), intent(in) :: norm + + ! --- + + integer :: i1, i2 + + ! --- + + i1 = int(floor((val1-this%min_b(1))/this%dbin(1)))+1 + i2 = int(floor((val2-this%min_b(2))/this%dbin(2)))+1 + + if (this%periodic(1)) then + i1 = modulo(i1-1, this%n(1))+1 + endif + if (this%periodic(2)) then + i2 = modulo(i2-1, this%n(2))+1 + endif + + if (i1 >= 1 .and. i1 <= this%n(1) .and. i2 >= 1 .and. i2 <= this%n(2)) then + this%h1(i1, i2) = this%h1(i1, i2) + 1 + this%h(i1, i2) = this%h(i1, i2) + norm + endif + + endsubroutine histogram2d_add_linear + + + !********************************************************************** + ! Add a value to the histogram2d with linear interpolation + !********************************************************************** + subroutine histogram2d_add_linear_vals(this, vals1, vals2, norm) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: vals1(:) + real(DP), intent(in) :: vals2(:) + real(DP), intent(in) :: norm + + ! --- + + integer :: i1(lbound(vals1, 1):ubound(vals1, 1)) + integer :: i2(lbound(vals2, 1):ubound(vals2, 1)) + + integer :: i + + ! --- + + i1 = int(floor((vals1-this%min_b(1))/this%dbin(1)))+1 + i2 = int(floor((vals2-this%min_b(2))/this%dbin(2)))+1 + + if (this%periodic(1)) then + i1 = modulo(i1-1, this%n(1))+1 + endif + if (this%periodic(2)) then + i2 = modulo(i2-1, this%n(2))+1 + endif + + do i = lbound(vals1, 1), ubound(vals1, 1) + if (i1(i) >= 1 .and. i1(i) <= this%n(1) .and. i2(i) >= 1 .and. i2(i) <= this%n(2)) then + this%h1(i1(i), i2(i)) = this%h1(i1(i), i2(i)) + 1 + this%h(i1(i), i2(i)) = this%h(i1(i), i2(i)) + norm + endif + enddo + + endsubroutine histogram2d_add_linear_vals + + + !********************************************************************** + ! Add a value + !********************************************************************** + subroutine histogram2d_add(this, val1, val2, norm) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: val1 + real(DP), intent(in) :: val2 + real(DP), intent(in), optional :: norm + + ! --- + + real(DP) :: n + + ! --- + + if (present(norm)) then + n = norm + else + n = 1.0_DP + endif + + call histogram2d_add_linear(this, val1, val2, n) + + endsubroutine histogram2d_add + + + !********************************************************************** + ! Add a list of values to the histogram2d + !********************************************************************** + subroutine histogram2d_add_vals(this, vals1, vals2, norm) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: vals1(:) + real(DP), intent(in) :: vals2(:) + real(DP), intent(in), optional :: norm + + ! --- + + real(DP) :: n + + ! --- + + if (present(norm)) then + n = norm + else + n = 1.0_DP + endif + + call histogram2d_add_linear_vals(this, vals1, vals2, n) + +! call histogram2d_add_linear_vals(this, vals, n) + + endsubroutine histogram2d_add_vals + + + !********************************************************************** + ! Add a list of values to the histogram2d + !********************************************************************** + subroutine histogram2d_add_vals_mask(this, vals1, vals2, mask) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: vals1(:) + real(DP), intent(in) :: vals2(:) + logical, intent(in) :: mask(:) + + ! --- + + integer :: i + + ! --- + + do i = lbound(vals1, 1), ubound(vals1, 1) + if (mask(i)) then + call histogram2d_add_linear(this, vals1(i), vals2(i), 1.0_DP) + endif + enddo + + endsubroutine histogram2d_add_vals_mask + + + !********************************************************************** + ! Add a list of values to the histogram2d + !********************************************************************** + subroutine histogram2d_add_vals_norms(this, vals1, vals2, norms) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: vals1(:) + real(DP), intent(in) :: vals2(:) + real(DP), intent(in) :: norms(:) + + ! --- + + integer :: i + + ! --- + + do i = lbound(vals1, 1), ubound(vals1, 1) + call histogram2d_add_linear(this, vals1(i), vals2(i), norms(i)) + enddo + +! call histogram2d_add_linear_vals_norms(this, vals, norms) + + endsubroutine histogram2d_add_vals_norms + + + !********************************************************************** + ! Add a list of values to the histogram2d + !********************************************************************** + subroutine histogram2d_add_vals_norm_mask(this, vals1, vals2, norm, mask) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: vals1(:) + real(DP), intent(in) :: vals2(:) + real(DP), intent(in) :: norm + logical, intent(in) :: mask(:) + + ! --- + + integer :: i + + ! --- + + do i = lbound(vals1, 1), ubound(vals1, 1) + if (mask(i)) then + call histogram2d_add_linear(this, vals1(i), vals2(i), norm) + endif + enddo + +! call histogram2d_add_linear_vals_norm_mask(this, vals, norm, mask) + + endsubroutine histogram2d_add_vals_norm_mask + + + !********************************************************************** + ! Add a list of values to the histogram2d + !********************************************************************** + subroutine histogram2d_add_vals_norms_mask(this, vals1, vals2, norms, mask) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: vals1(:) + real(DP), intent(in) :: vals2(:) + real(DP), intent(in) :: norms(:) + logical, intent(in) :: mask(:) + + ! --- + + integer :: i + + ! --- + + do i = lbound(vals1, 1), ubound(vals1, 1) + if (mask(i)) then + call histogram2d_add_linear(this, vals1(i), vals2(i), norms(i)) + endif + enddo + +! call histogram2d_add_linear_vals_norms_mask(this, vals, norms, mask) + + endsubroutine histogram2d_add_vals_norms_mask + + + !********************************************************************** + ! Add a list of values to the histogram2d + !********************************************************************** + subroutine histogram2d_add_histogram2d(this, that, fac) + implicit none + + type(histogram2d_t), intent(inout) :: this + type(histogram2d_t), intent(in) :: that + real(DP), intent(in), optional :: fac + + ! --- + + this%h1 = this%h1 + that%h1 + if (present(fac)) then + this%h = this%h + fac*that%h + else + this%h = this%h + that%h + endif + + endsubroutine histogram2d_add_histogram2d + + + !********************************************************************** + ! Compute average value in each bin (does only makes sense if + ! norm != 1 was used in the add functions) + !********************************************************************** + elemental subroutine histogram2d_average(this) + implicit none + + type(histogram2d_t), intent(inout) :: this + + ! --- + + where (this%h1 == 0) + this%h1 = 1 + endwhere + + this%h = this%h / this%h1 + + endsubroutine histogram2d_average + + + !********************************************************************** + ! Multiply the histogram2d by a value - for normalization + !********************************************************************** + subroutine histogram2d_mul(this, val) + implicit none + + type(histogram2d_t), intent(inout) :: this + real(DP), intent(in) :: val + + ! --- + + this%h = this%h * val + + endsubroutine histogram2d_mul + + + !********************************************************************** + ! Multiply the histogram2d by a value - for normalization + !********************************************************************** + subroutine histogram2ds_mul(this, val) + implicit none + + type(histogram2d_t), intent(inout) :: this(:) + real(DP), intent(in) :: val + + ! --- + + integer :: i + + ! --- + + do i = lbound(this, 1), ubound(this, 1) + this(i)%h = this(i)%h * val + enddo + + endsubroutine histogram2ds_mul + + + !********************************************************************** + ! Multiply the histogram2d by a value - for normalization + !********************************************************************** + subroutine histogram2ds2_mul(this, val) + implicit none + + type(histogram2d_t), intent(inout) :: this(:, :) + real(DP), intent(in) :: val + + ! --- + + integer :: i, j + + ! --- + + do i = lbound(this, 1), ubound(this, 1) + do j = lbound(this, 2), ubound(this, 2) + this(i, j)%h = this(i, j)%h * val + enddo + enddo + + endsubroutine histogram2ds2_mul + + + !********************************************************************** + ! Normalize histogram2d + !********************************************************************** + elemental subroutine histogram2d_normalize(this) + implicit none + + type(histogram2d_t), intent(inout) :: this + + ! --- + + real(DP) :: n + + ! --- + + n = sum(this%h*this%dbin(1)*this%dbin(2)) + + if (n /= 0.0_DP) then + this%h = this%h / n + endif + + endsubroutine histogram2d_normalize + + + !********************************************************************** + ! OpenMP reduction - *thpriv* is a threadprivate histogram, + ! this needs to be called within an *omp parallel* construct. + !********************************************************************** + elemental subroutine histogram2d_reduce(this, thpriv) + implicit none + + type(histogram2d_t), intent(inout) :: this + type(histogram2d_t), intent(in) :: thpriv + + ! --- + + !$omp single + call init(this, thpriv) + !$omp end single + + !$omp critical + this%h = this%h + thpriv%h + this%h1 = this%h1 + thpriv%h1 + !$omp end critical + + endsubroutine histogram2d_reduce + + + !********************************************************************** + ! Memory estimate logging + !********************************************************************** + subroutine log_memory_estimate_histogram2d(this) + implicit none + + type(histogram2d_t), intent(in) :: this + + ! --- + + call log_memory_estimate(this%x1) + call log_memory_estimate(this%x2) + call log_memory_estimate(this%h) + call log_memory_estimate(this%h1) + + endsubroutine log_memory_estimate_histogram2d + + + !********************************************************************** + ! Memory estimate logging + !********************************************************************** + subroutine log_memory_estimate_histogram2d2(this) + implicit none + + type(histogram2d_t), intent(in) :: this(:) + + ! --- + + integer :: i + + ! --- + + do i = lbound(this, 1), ubound(this, 1) + call log_memory_estimate_histogram2d(this(i)) + enddo + + endsubroutine log_memory_estimate_histogram2d2 + + + !********************************************************************** + ! Memory estimate logging + !********************************************************************** + subroutine log_memory_estimate_histogram2d3(this) + implicit none + + type(histogram2d_t), intent(in) :: this(:, :) + + ! --- + + integer :: i, j + + ! --- + + do j = lbound(this, 2), ubound(this, 2) + do i = lbound(this, 1), ubound(this, 1) + call log_memory_estimate_histogram2d(this(i, j)) + enddo + enddo + + endsubroutine log_memory_estimate_histogram2d3 + +endmodule histogram2d_module diff --git a/src/libAtoms/k_means_clustering.F90 b/src/libAtoms/k_means_clustering.F90 new file mode 100644 index 0000000000..1884e0b676 --- /dev/null +++ b/src/libAtoms/k_means_clustering.F90 @@ -0,0 +1,245 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module k_means_clustering_module +implicit none +private + + integer, parameter :: dp = 8 + + public :: k_means_clustering_pick + interface k_means_clustering_pick + module procedure k_means_clustering_pick_1d, k_means_clustering_pick_nd + end interface + +contains + + subroutine k_means_clustering_pick_1d(x, periodicity, cluster_indices) + real(dp), intent(in) :: x(:) + real(dp), intent(in) :: periodicity + integer, intent(out) :: cluster_indices(:) + + integer :: k + real(dp), allocatable :: k_means(:) + integer :: n, rv, i, j, closest_i, closest_j + real(dp) :: rrv + real(dp) :: closest_r, r, t_sum + integer, allocatable :: a(:), prev_a(:) + + k = size(cluster_indices) + n = size(x) + allocate(k_means(k)) + + ! random initial guess + cluster_indices = 0 + do i=1, k + call random_number(rrv); rv = 1+floor(rrv*n) + do while (any(cluster_indices == rv)) + call random_number(rrv); rv = 1+floor(rrv*n) + end do + cluster_indices(i) = rv + end do + k_means = x(cluster_indices) + + allocate(a(n), prev_a(n)) + + ! evaluate initial assignments + do j=1, n + closest_i = 0 + closest_r = HUGE(1.0_dp) + do i=1, k + r = dist((/x(j)/), (/k_means(i)/), (/periodicity/)) + if (r < closest_r) then + closest_r = r + closest_i = i + endif + end do + a(j) = closest_i + end do + + prev_a = 0 + do while (any(a /= prev_a)) + prev_a = a + + ! update positions + do i=1, k + t_sum = 0.0_dp + do j=1, n + if (a(j) == i) t_sum = t_sum + x(j) + end do + k_means(i) = t_sum / real(count(a == i),dp) + end do + + ! update assignments + do j=1, n + closest_i = 0 + closest_r = HUGE(1.0_dp) + do i=1, k + r = dist((/x(j)/), (/k_means(i)/), (/periodicity/)) + if (r < closest_r) then + closest_r = r + closest_i = i + endif + end do + a(j) = closest_i + end do + end do + + do i=1, k + closest_i = 0 + closest_r = HUGE(1.0_dp) + do j=1, n + r = dist((/x(j)/), (/k_means(i)/), (/periodicity/)) + if (r < closest_r) then + closest_r = r + closest_j = j + endif + end do + cluster_indices(i) = closest_j + end do + + deallocate(a, prev_a, k_means) + + end subroutine k_means_clustering_pick_1d + + subroutine k_means_clustering_pick_nd(x, periodicity, cluster_indices) + real(dp), intent(in) :: x(:,:) + real(dp), intent(in) :: periodicity(:) + integer, intent(out) :: cluster_indices(:) + + integer :: k + real(dp), allocatable :: k_means(:,:) + integer :: n, rv, i, j, closest_i, closest_j, nd + real(dp) :: rrv + real(dp) :: closest_r, r, t_sum(size(x,1)) + integer, allocatable :: a(:), prev_a(:) + + k = size(cluster_indices) + n = size(x,2) + nd = size(x,1) + allocate(k_means(nd,k)) + + ! random initial guess + cluster_indices = 0 + do i=1, k + call random_number(rrv); rv = 1+floor(rrv*n) + do while (any(cluster_indices == rv)) + call random_number(rrv); rv = 1+floor(rrv*n) + end do + cluster_indices(i) = rv + end do + k_means(:,:) = x(:,cluster_indices(:)) + + allocate(a(n), prev_a(n)) + + ! evaluate initial assignments + do j=1, n + closest_i = 0 + closest_r = HUGE(1.0_dp) + do i=1, k + r = dist(x(:,j), k_means(:,i), periodicity(:)) + if (r < closest_r) then + closest_r = r + closest_i = i + endif + end do + a(j) = closest_i + end do + + prev_a = 0 + do while (any(a /= prev_a)) + prev_a = a + + ! update positions + do i=1, k + t_sum = 0.0_dp + do j=1, n + if (a(j) == i) t_sum(:) = t_sum(:) + x(:,j) + end do + k_means(:,i) = t_sum(:) / real(count(a == i),dp) + end do + + ! update assignments + do j=1, n + closest_i = 0 + closest_r = HUGE(1.0_dp) + do i=1, k + r = dist(x(:,j), k_means(:,i), periodicity(:)) + if (r < closest_r) then + closest_r = r + closest_i = i + endif + end do + a(j) = closest_i + end do + end do + + do i=1, k + closest_i = 0 + closest_r = HUGE(1.0_dp) + do j=1, n + r = dist(x(:,j), k_means(:,i), periodicity(:)) + if (r < closest_r) then + closest_r = r + closest_j = j + endif + end do + cluster_indices(i) = closest_j + end do + + deallocate(a, prev_a, k_means) + + end subroutine k_means_clustering_pick_nd + + ! from BRUSH paper, citing MacKay + function dist(x0, x1, periodicity) + real(dp), intent(in) :: x0(:), x1(:) + real(dp), intent(in) :: periodicity(:) + real(dp) :: dist ! result + + integer :: i + + if (any(periodicity /= 0.0_dp)) then + dist = 0.0_dp + do i=1, size(x0) + if (periodicity(i) /= 0.0_dp) then + dist = dist + 4.0_dp*sin((2.0_dp*3.14159265358979_dp/periodicity(i))*(x0(i)-x1(i))/2.0_dp)**2 + else + dist = dist + (x0(i)-x1(i))**2 + endif + end do + dist = sqrt(dist) + else + dist = sqrt(sum((x0(:)-x1(:))**2)) + endif + + end function dist + +end module k_means_clustering_module diff --git a/src/libAtoms/kind_module.F90 b/src/libAtoms/kind_module.F90 new file mode 100644 index 0000000000..095d6439a3 --- /dev/null +++ b/src/libAtoms/kind_module.F90 @@ -0,0 +1,25 @@ +module kind_module + + implicit none + + integer, parameter, public :: isp = selected_int_kind(9) + integer, parameter, public :: idp = selected_int_kind(18) + integer, parameter, public :: iwp = kind(isp) + +#ifdef QUAD_PRECISION + integer, parameter, public :: dp = 16 +#elsif TEN_DIGIT_PRECISION + integer, parameter, public :: dp = selected_real_kind(10) +#else + integer, parameter, public :: dp = 8 +#endif + +#ifdef HAVE_QP + integer, parameter, public :: qp = 16 +#elsif TEN_DIGIT_PRECISION + integer, parameter, public :: qp = selected_real_kind(10) +#else + integer, parameter, public :: qp = 8 +#endif + +end module kind_module diff --git a/src/libAtoms/libAtoms.F90 b/src/libAtoms/libAtoms.F90 new file mode 100644 index 0000000000..6dd9b0b2c9 --- /dev/null +++ b/src/libAtoms/libAtoms.F90 @@ -0,0 +1,78 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X libAtoms module +!X +!% This is a container module, "use" it if you want to use libatoms stuff: +!%> use libAtoms_module +!% +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module libAtoms_module + use error_module + use system_module + use linkedlist_module + use MPI_context_module + use units_module + use linearalgebra_module + use minimization_module + use extendable_str_module + use dictionary_module + use table_module + use spline_module + use sparse_module + use periodictable_module + use cinoutput_module + use paramreader_module + use atoms_types_module + use connection_module + use atoms_module + use quaternions_module + use rigidbody_module + use steinhardt_nelson_qw_module + use constraints_module + use thermostat_module + use barostat_module + use dynamicalsystem_module + use clusters_module + use structures_module + use frametools_module + use nye_tensor_module + use Topology_module + use atoms_ll_module + use ringstat_module + use histogram1d_module + use domaindecomposition_module + use k_means_clustering_module + use SocketTools_module + use partition_module +end module libAtoms_module diff --git a/src/libAtoms/libAtoms_misc_utils.F90 b/src/libAtoms/libAtoms_misc_utils.F90 new file mode 100644 index 0000000000..8c14b8dcfe --- /dev/null +++ b/src/libAtoms/libAtoms_misc_utils.F90 @@ -0,0 +1,56 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +module libatoms_misc_utils_module +use libatoms_module +implicit none +private + +public :: dipole_moment + +contains + +function dipole_moment(pos, net_charge) + real(dp), intent(in) :: pos(:,:), net_charge(:) + real(dp) :: dipole_moment(size(pos,1)) + + integer :: i + + if (size(pos,2) /= size(net_charge)) & + call system_abort("dipole_moment called with incompatible size(pos) " // size(pos) //& + ", size(net_charge) " // size(net_charge)) + + dipole_moment = 0.0_dp + do i=1, size(pos,1) + dipole_moment(:) = dipole_moment(:) - pos(:,i)*net_charge(i) + end do +end function dipole_moment + +end module libatoms_misc_utils_module diff --git a/src/libAtoms/libAtoms_utils_no_module.F90 b/src/libAtoms/libAtoms_utils_no_module.F90 new file mode 100644 index 0000000000..46f319e53f --- /dev/null +++ b/src/libAtoms/libAtoms_utils_no_module.F90 @@ -0,0 +1,409 @@ +#include "error.inc" + +subroutine lattice_abc_to_xyz(cell_lengths, cell_angles, lattice) + use system_module + use atoms_module + implicit none + real(dp), intent(in) :: cell_lengths(3), cell_angles(3) + real(dp), intent(out) :: lattice(3,3) + + lattice = make_lattice(cell_lengths(1), cell_lengths(2), cell_lengths(3), & + cell_angles(1), cell_angles(2), cell_angles(3)) + +end subroutine lattice_abc_to_xyz + +subroutine lattice_xyz_to_abc(lattice, cell_lengths, cell_angles) + use system_module + use atoms_module + implicit none + real(dp), intent(in) :: lattice(3,3) + real(dp), intent(out) :: cell_lengths(3), cell_angles(3) + + call get_lattice_params(lattice, cell_lengths(1), cell_lengths(2), cell_lengths(3), & + cell_angles(1), cell_angles(2), cell_angles(3)) + +end subroutine lattice_xyz_to_abc + +subroutine c_system_initialise(verbosity) + use system_module + implicit none + integer verbosity + + call system_initialise(verbosity) + +end subroutine c_system_initialise + +function quippy_running() + use system_module, only: get_quippy_running + implicit none + logical quippy_running + quippy_running = get_quippy_running() +end function quippy_running + +! Error handling routines callable from C + +subroutine c_push_error_with_info(doc, fn, line, kind) + use error_module + implicit none + character(*), intent(in) :: doc + character(*), intent(in) :: fn + integer, intent(in) :: line + integer, intent(in), optional :: kind + + call push_error_with_info(doc, fn, line, kind) + +end subroutine c_push_error_with_info + +subroutine c_push_error(fn, line, kind) + use error_module + implicit none + + character(*), intent(in) :: fn + integer, intent(in) :: line + integer, intent(in), optional :: kind + + call push_error(fn, line, kind) + +end subroutine c_push_error + +subroutine c_error_abort(error) + use error_module + implicit none + integer, intent(inout), optional :: error + + call error_abort(error) +end subroutine c_error_abort + +subroutine c_error_clear_stack() + use error_module + implicit none + call error_clear_stack +end subroutine c_error_clear_stack + + +! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! +! Dictionary routines callable from C +! +! Routines used by CInOutput to manipulate Fortran Dictionary objects from C. +! +! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +subroutine c_dictionary_initialise(this) + use dictionary_module + implicit none + integer, intent(inout) :: this(12) + type(c_dictionary_ptr_type) :: this_ptr + + allocate(this_ptr%p) + call initialise(this=this_ptr%p) + this = transfer(this_ptr, this) + +end subroutine c_dictionary_initialise + +subroutine c_dictionary_finalise(this) + use dictionary_module + implicit none + integer, intent(in) :: this(12) + type(c_dictionary_ptr_type) :: this_ptr + + this_ptr = transfer(this, this_ptr) + call finalise(this=this_ptr%p) + deallocate(this_ptr%p) + +end subroutine c_dictionary_finalise + +subroutine c_dictionary_get_n(this, n) + use dictionary_module + implicit none + integer, intent(in) :: this(12) + integer, intent(out) :: n + type(c_dictionary_ptr_type) :: this_ptr + + this_ptr = transfer(this, this_ptr) + n = this_ptr%p%n + +end subroutine c_dictionary_get_n + +subroutine c_dictionary_get_key(this, i, key, length, error) + use error_module + use dictionary_module + implicit none + integer, intent(in) :: this(12), i + character(len=*), intent(out) :: key + integer, intent(out), optional :: length, error + type(c_dictionary_ptr_type) :: this_ptr + + INIT_ERROR(error) + length = 0 + this_ptr = transfer(this, this_ptr) + call dictionary_get_key(this_ptr%p, i, key, error) + PASS_ERROR(error) + length = len_trim(key) + +end subroutine c_dictionary_get_key + +subroutine c_dictionary_query_key(this, key, type, dshape, dloc, error) + + use error_module + use dictionary_module + use iso_c_binding, only: c_intptr_t + + use extendable_str_module + use system_module + implicit none + +#ifdef __GFORTRAN__ + INTERFACE + subroutine c_dictionary_query_index(this, entry_i, key, type, dshape, dloc, error) + use iso_c_binding, only: c_intptr_t + integer, intent(in) :: this(12) + integer, intent(in) :: entry_i + character(len=*), intent(out) :: key + integer, intent(out) :: type + integer, dimension(2), intent(out) :: dshape + integer(c_intptr_t), intent(out) :: dloc + integer, intent(out), optional :: error + end subroutine c_dictionary_query_index + END INTERFACE +#endif + + integer, intent(in) :: this(12) + character(len=*), intent(inout) :: key + integer, intent(out) :: type + integer, dimension(2), intent(out) :: dshape + integer(c_intptr_t), intent(out) :: dloc + integer, intent(out), optional :: error + + integer entry_i + type(c_dictionary_ptr_type) :: this_ptr + + INIT_ERROR(error) + this_ptr = transfer(this, this_ptr) + + entry_i = lookup_entry_i(this_ptr%p, key) + if (entry_i <= 0) then + RAISE_ERROR('c_dictionary_query_key: key '//trim(key)//' not found', error) + end if + call c_dictionary_query_index(this, entry_i, key, type, dshape, dloc, error) + PASS_ERROR(error) + +end subroutine c_dictionary_query_key + +subroutine c_dictionary_query_index(this, entry_i, key, type, dshape, dloc, error) + use error_module + use extendable_str_module + use system_module + use dictionary_module + use iso_c_binding, only: c_intptr_t + integer, intent(in) :: this(12) + integer, intent(in) :: entry_i + character(len=*), intent(out) :: key + integer, intent(out) :: type + integer, dimension(2), intent(out) :: dshape + integer(c_intptr_t), intent(out) :: dloc + integer, intent(out), optional :: error + + type(c_dictionary_ptr_type) :: this_ptr + + INIT_ERROR(error) + this_ptr = transfer(this, this_ptr) + + type = 0 + dshape(:) = 0 + dloc = 0 + + if (entry_i <= 0 .or. entry_i > this_ptr%p%N) then + RAISE_ERROR('c_dictionary_query_index: entry_i = '//entry_i//' outside range 1 < entry_i <= '//this_ptr%p%N, error) + end if + + type = this_ptr%p%entries(entry_i)%type + key = string(this_ptr%p%keys(entry_i)) + + select case(this_ptr%p%entries(entry_i)%type) + case(T_NONE) + dloc = 0 + return + + case(T_INTEGER) + dloc = loc(this_ptr%p%entries(entry_i)%i) + + case(T_REAL) + dloc = loc(this_ptr%p%entries(entry_i)%r) + + case(T_COMPLEX) + dloc = loc(this_ptr%p%entries(entry_i)%c) + + case(T_CHAR) + dshape(1) = this_ptr%p%entries(entry_i)%s%len + dloc = loc(this_ptr%p%entries(entry_i)%s%s) + + case(T_LOGICAL) + dloc = loc(this_ptr%p%entries(entry_i)%l) + + case(T_INTEGER_A) + dshape(1) = size(this_ptr%p%entries(entry_i)%i_a) + dloc = loc(this_ptr%p%entries(entry_i)%i_a) + + case(T_REAL_A) + dshape(1) = size(this_ptr%p%entries(entry_i)%r_a) + dloc = loc(this_ptr%p%entries(entry_i)%r_a) + + case(T_COMPLEX_A) + dshape(1) = size(this_ptr%p%entries(entry_i)%c_a) + dloc = loc(this_ptr%p%entries(entry_i)%c_a) + + case(T_LOGICAL_A) + dshape(1) = size(this_ptr%p%entries(entry_i)%l_a) + dloc = loc(this_ptr%p%entries(entry_i)%l_a) + + case(T_CHAR_A) + dshape(1) = size(this_ptr%p%entries(entry_i)%s_a,1) + dshape(2) = size(this_ptr%p%entries(entry_i)%s_a,2) + dloc = loc(this_ptr%p%entries(entry_i)%s_a) + + case(T_INTEGER_A2) + dshape(1) = size(this_ptr%p%entries(entry_i)%i_a2, 1) + dshape(2) = size(this_ptr%p%entries(entry_i)%i_a2, 2) + dloc = loc(this_ptr%p%entries(entry_i)%i_a2) + + case(T_REAL_A2) + dshape(1) = size(this_ptr%p%entries(entry_i)%r_a2, 1) + dshape(2) = size(this_ptr%p%entries(entry_i)%r_a2, 2) + dloc = loc(this_ptr%p%entries(entry_i)%r_a2) + + case(T_DATA) + ! not supported + dloc = 0 + RAISE_ERROR('c_dictionary_query_index: data type T_DATA not supported.', error) + + end select + +end subroutine c_dictionary_query_index + +subroutine c_dictionary_add_key(this, key, type, dshape, loc, error) + use system_module + use error_module + use dictionary_module + use iso_c_binding, only: c_intptr_t + implicit none + +#ifdef __GFORTRAN__ + INTERFACE + subroutine c_dictionary_query_key(this, key, type, dshape, dloc, error) + + use error_module + use dictionary_module + use iso_c_binding, only: c_intptr_t + + use extendable_str_module + use system_module + + integer, intent(in) :: this(12) + character(len=*), intent(inout) :: key + integer, intent(out) :: type + integer, dimension(2), intent(out) :: dshape + integer(c_intptr_t), intent(out) :: dloc + integer, intent(out), optional :: error + + end subroutine c_dictionary_query_key + END INTERFACE +#endif + + integer, intent(in) :: this(12) + character(len=*), intent(inout) :: key + integer, intent(in) :: type + integer, intent(in) :: dshape(2) + integer(c_intptr_t), intent(out) :: loc + integer, intent(out), optional :: error + + type(c_dictionary_ptr_type) this_ptr + integer mytype, mydshape(2), tmp_error + + INIT_ERROR(error) + mytype = -1 + mydshape(:) = -1 + + ! check if a compatiable entry already exists + tmp_error = 0 + call c_dictionary_query_key(this, key, mytype, mydshape, loc, tmp_error) + CLEAR_ERROR(tmp_error) + if (tmp_error == 0 .and. type == mytype .and. all(dshape == mydshape)) then + return + end if + + ! otherwise we need to add a new entry + this_ptr = transfer(this, this_ptr) + select case(type) + case(T_NONE) + call set_value(this_ptr%p, key) + + case(T_INTEGER) + call set_value(this_ptr%p, key, 0) + + case(T_REAL) + call set_value(this_ptr%p, key, 0.0_dp) + + case(T_COMPLEX) + call set_value(this_ptr%p, key, (0.0_dp, 0.0_dp)) + + case(T_CHAR) + call set_value(this_ptr%p, key, repeat('X', dshape(1))) + + case(T_LOGICAL) + call set_value(this_ptr%p, key, .false.) + + case(T_INTEGER_A) + call add_array(this_ptr%p, key, 0, dshape(1)) + + case(T_REAL_A) + call add_array(this_ptr%p, key, 0.0_dp, dshape(1)) + + case(T_COMPLEX_A) + call add_array(this_ptr%p, key, 0.0_dp, dshape(1)) + + case(T_LOGICAL_A) + call add_array(this_ptr%p, key, .false., dshape(1)) + + case(T_CHAR_A) + call add_array(this_ptr%p, key, ' ', dshape) + + case(T_INTEGER_A2) + call add_array(this_ptr%p, key, 0, dshape) + + case(T_REAL_A2) + call add_array(this_ptr%p, key, 0.0_dp, dshape) + + case default + RAISE_ERROR('c_dictionary_add_key: unknown data type '//type, error) + + end select + + ! Finally, update 'loc' pointer + call c_dictionary_query_key(this, key, mytype, mydshape, loc, error) + PASS_ERROR(error) + +end subroutine c_dictionary_add_key + +subroutine c_extendable_str_concat(this, str, keep_lf, add_lf_if_missing) + use extendable_str_module + type c_extendable_str_ptr_type + type(Extendable_str), pointer :: p + end type c_extendable_str_ptr_type + integer, intent(in) :: this(12) + character(*), intent(in) :: str + integer, intent(in) :: keep_lf, add_lf_if_missing + + type(c_extendable_str_ptr_type) :: this_ptr + logical do_keep_lf, do_add_lf_if_missing + + do_keep_lf = .false. + if (keep_lf == 1) do_keep_lf = .true. + do_add_lf_if_missing = .false. + if (add_lf_if_missing == 1) do_add_lf_if_missing = .true. + + this_ptr = transfer(this, this_ptr) + call concat(this_ptr%p, str, do_keep_lf, do_add_lf_if_missing) + +end subroutine c_extendable_str_concat + diff --git a/src/libAtoms/linearalgebra.F90 b/src/libAtoms/linearalgebra.F90 new file mode 100644 index 0000000000..bde758a04a --- /dev/null +++ b/src/libAtoms/linearalgebra.F90 @@ -0,0 +1,7677 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Linear algebra module +!X +!% This is a general purpose linear algebra module, extending +!% the Fortran intrinsics +!% This module defines dot products between matrices and vectors, +!% wrappers to \textsc{lapack} for matrix diagonalisation and inversion, +!% as well as array searching, sorting and averaging. +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module linearalgebra_module + use error_module + use system_module + use units_module + implicit none + private + SAVE + + real(dp), parameter :: factorial_table(0:20) = (/& + 1.0_dp, & + 1.0_dp, & + 2.0_dp, & + 6.0_dp, & + 24.0_dp, & + 120.0_dp, & + 720.0_dp, & + 5040.0_dp, & + 40320.0_dp, & + 362880.0_dp, & + 3628800.0_dp, & + 39916800.0_dp, & + 479001600.0_dp, & + 6227020800.0_dp, & + 87178291200.0_dp, & + 1307674368000.0_dp, & + 20922789888000.0_dp, & + 355687428096000.0_dp, & + 6402373705728000.0_dp, & + 121645100408832000.0_dp, & + 2432902008176640000.0_dp/) + public :: factorial, factorial_int, factorial2, binom, oscillate + + real(dp), public, parameter :: TOL_SVD = 1e-13_dp + + public :: cos_cutoff_function, dcos_cutoff_function + + interface coordination_function + module procedure coordination_function_upper, coordination_function_lower_upper + endinterface coordination_function + public :: coordination_function + + interface dcoordination_function + module procedure dcoordination_function_upper, dcoordination_function_lower_upper + endinterface dcoordination_function + public :: dcoordination_function + + interface d2coordination_function + module procedure d2coordination_function_upper + endinterface d2coordination_function + public :: d2coordination_function + + interface d3coordination_function + module procedure d3coordination_function_upper + endinterface d3coordination_function + public :: d3coordination_function + + public :: la_matrix, la_matrix_factorise, la_matrix_qr_factorise, LA_Matrix_QR_Solve_Vector, la_matrix_logdet, la_matrix_qr_inverse, la_matrix_inverse, LA_Matrix_Expand_Symmetrically, la_matrix_svd, la_matrix_svd_allocate, la_matrix_pseudoinverse + + public :: initialise, assignment(=), finalise, matrix_solve, matrix_qr_solve, find, sign + public :: operator(.feq.), operator(.fne.), operator(.fgt.), operator(.fle.), operator(.flt.), operator(.fge.) + public :: norm, normsq, operator(.mult.), operator(.dot.) + public :: frobenius_norm + public :: heap_sort, is_orthogonal, find_in_array, is_in_array, trace, trace_mult, diag + public :: ran_normal3, matrix_exp, matrix3x3_det, matrix3x3_inverse, operator(.outer.), operator(.cross.) + public :: check_size, sort_array, trapezoidintegral, print, print_mathematica, int_array_ge, int_array_gt, int_array_lt + public :: angle, unit_vector, random_unit_vector, arrays_lt, is_symmetric, permutation_symbol + public :: diagonalise, nonsymmetric_diagonalise, uniq, find_indices, inverse, pseudo_inverse, matrix_product_sub, matrix_product_vect_asdiagonal_sub, matrix_mvmt + public :: add_identity, linear_interpolate, cubic_interpolate, pbc_aware_centre, randomise, zero_sum + public :: insertion_sort, update_exponential_average, least_squares, scalar_triple_product, inverse_svd_threshold, svdfact + public :: fit_cubic, symmetrise, symmetric_linear_solve, matrix_product_vect_asdiagonal_RL_sub, matrix_condition_number + public :: rms_diff, histogram, kmeans, round_prime_factors, binary_search, apply_function_matrix, invsqrt_real_array1d, fill_random_integer + public :: poly_switch, dpoly_switch, d2poly_switch, d3poly_switch + public :: is_diagonal, integerDigits + public :: make_hermitian + + logical :: use_intrinsic_blas = .false. + !% If set to true, use internal routines instead of \textsc{blas} calls for matrix + !% multiplication. Can be changed at runtime. The default is true. + integer, parameter :: NOT_FACTORISED = 0 + integer, parameter :: CHOLESKY = 1 + integer, parameter :: QR = 2 + + type LA_Matrix + real(qp), dimension(:,:), pointer :: matrix + real(qp), dimension(:,:), allocatable :: factor + real(qp), dimension(:), allocatable :: s, tau + integer :: n, m + logical :: use_allocate = .true. + logical :: initialised = .false. + logical :: equilibrated = .false. + integer :: factorised = NOT_FACTORISED + contains + final :: LA_Matrix_Finalise + endtype LA_Matrix + + interface Initialise + module procedure LA_Matrix_Initialise + endinterface Initialise + + interface assignment(=) + module procedure LA_Matrix_Initialise_Matrix + module procedure LA_Matrix_Initialise_Copy + end interface assignment(=) + + interface Finalise + module procedure LA_Matrix_Finalise + endinterface Finalise + + interface Matrix_Solve + module procedure LA_Matrix_Solve_Vector, LA_Matrix_Solve_Matrix + endinterface Matrix_Solve + + interface Matrix_QR_Solve + module procedure LA_Matrix_QR_Solve_Vector, LA_Matrix_QR_Solve_Matrix, Fixed_LA_Matrix_QR_Solve_Vector + endinterface Matrix_QR_Solve + + interface find + module procedure find_indices + end interface + + interface sign + module procedure int_sign, real_sign + end interface + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Interfaces to mathematical operations +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Construct a diagonal matrix from a vector, or extract the diagonal elements + !% of a matrix and return them as a vector. + ! matrix = diag(vector) , vector = diag(matrix) + private :: matrix_diagonal_r, matrix_diagonal_c, vector_as_diag_matrix_r, vector_as_diag_matrix_c + interface diag + module procedure matrix_diagonal_r, matrix_diagonal_c, vector_as_diag_matrix_r, vector_as_diag_matrix_c + end interface + + !% Heavily overloaded interface to print matrices and vectors of reals, complex numbers or integers. + private :: matrix_print_mainlog, matrix_print, vector_print_mainlog, vector_print + private :: matrix_z_print_mainlog, matrix_z_print, vector_z_print_mainlog, vector_z_print + private :: int_matrix_print_mainlog, int_matrix_print + private :: logical_matrix_print_mainlog, logical_matrix_print + private :: integer_array_print, integer_array_print_mainlog, logical_array_print, logical_array_print_mainlog + interface print + module procedure matrix_print_mainlog, matrix_print, vector_print_mainlog, vector_print + module procedure matrix_z_print_mainlog, matrix_z_print, vector_z_print_mainlog, vector_z_print + module procedure integer_array_print, integer_array_print_mainlog, logical_array_print_mainlog + module procedure int_matrix_print_mainlog, int_matrix_print, logical_array_print + module procedure logical_matrix_print_mainlog, logical_matrix_print + end interface + + private :: matrix_z_print_mathematica, matrix_print_mathematica + interface print_mathematica + module procedure matrix_z_print_mathematica, matrix_print_mathematica + end interface print_mathematica + + ! matrix*matrix , matrix*vector + !% Overloaded multiplication for matrix $\times$ matrix and matrix $\times$ vector. + !% Use as 'C = A .mult. B' for matrices and 'C = A .mult. v' for a matrix times a vector. + private :: matrix_product_vect, matrix_product_ddd, matrix_product_int_vect, matrix_product_zzz + private :: matrix_product_int_mat + interface operator(.mult.) + module procedure matrix_product_vect, matrix_product_ddd, matrix_product_int_vect, matrix_product_zzz + module procedure matrix_product_int_mat + end interface + !% Interface for routines that want function to be called 'matrix_product()' + interface matrix_product + module procedure matrix_product_ddd + end interface + + !% Overloaded multiplication for matrix $\times$ matrix in subroutine form, + !% with no return value allocated on the stack + interface matrix_product_sub + module procedure matrix_product_sub_ddd, matrix_product_sub_zzz, matrix_vector_product_sub_ddd + end interface + + ! matrix*diag(vector) + !% Matrix product with the diagonal matrix constructed from a vector. For example, + !% 'B = A .multd. d' is equivalent to 'B = A .mult. diag(d)' + private :: matrix_product_vect_asdiagonal_dd, matrix_product_vect_asdiagonal_zz + interface operator(.multd.) + module procedure matrix_product_vect_asdiagonal_dd, matrix_product_vect_asdiagonal_zz + end interface + + !% Matrix product with the diagonal matrix constructed from a vector in subroutine form, + !% with no return value allocated on the stack +#ifdef HAVE_QP + private :: matrix_product_vect_asdiagonal_sub_qqq +#endif + private :: matrix_product_vect_asdiagonal_sub_ddd + private :: matrix_product_vect_asdiagonal_sub_zzd + private :: matrix_product_vect_asdiagonal_sub_zdz + private :: matrix_product_vect_asdiagonal_sub_zzz + private :: vect_asdiagonal_product_matrix_sub_ddd + private :: vect_asdiagonal_product_matrix_sub_zzd + private :: vect_asdiagonal_product_matrix_sub_zdz + private :: vect_asdiagonal_product_matrix_sub_zzz + interface matrix_product_vect_asdiagonal_sub +#ifdef HAVE_QP + module procedure matrix_product_vect_asdiagonal_sub_qqq +#endif + module procedure matrix_product_vect_asdiagonal_sub_ddd + module procedure matrix_product_vect_asdiagonal_sub_zzd + module procedure matrix_product_vect_asdiagonal_sub_zdz + module procedure matrix_product_vect_asdiagonal_sub_zzz + module procedure vect_asdiagonal_product_matrix_sub_ddd + module procedure vect_asdiagonal_product_matrix_sub_zzd + module procedure vect_asdiagonal_product_matrix_sub_zdz + module procedure vect_asdiagonal_product_matrix_sub_zzz + end interface matrix_product_vect_asdiagonal_sub + + private :: matrix_product_vect_asdiagonal_RL_sub_ddd + private :: matrix_product_vect_asdiagonal_RL_sub_zzd + interface matrix_product_vect_asdiagonal_RL_sub + module procedure matrix_product_vect_asdiagonal_RL_sub_ddd + module procedure matrix_product_vect_asdiagonal_RL_sub_zzd + end interface matrix_product_vect_asdiagonal_RL_sub + + ! matrix*diag(vector)*matrix.t + !% Matrix product of matrix and a vector in the form: + !%> matrix * diag(vector) * transpose(matrix) + private :: matrix_cfct + interface matrix_mvmt + module procedure matrix_cfct + end interface + + ! vector.vector , matrix.matrix + !% Inner product of two vectors or two matrices. For two vectors $\mathbf{v}$ and + !% $\mathbf{w}$ this is simply: + !%\begin{displaymath} + !% d = \sum_{i=1}^N v_i w_i + !%\end{displaymath} + !% For $N \times M$ matrices $A$ and $B$ it is defined similarily: + !%\begin{displaymath} + !% d = \sum_{i=1}^N \sum_{j=1}^M A_{ij} B_{ij} + !%\end{displaymath} + private :: matrix_dotproduct_matrix,vector_dotpr + interface operator(.dot.) + module procedure matrix_dotproduct_matrix,vector_dotpr + end interface + + !% Floating point equality testing. Returns false if + !% '(abs(x-y) > NUMERICAL_ZERO * abs(x))', and true otherwise. + private :: real_feq,complex_feq,matrix_feq,vector_feq + interface operator(.feq.) + module procedure real_feq,real_integer_feq,integer_real_feq,complex_feq,matrix_feq,vector_feq + end interface + + !% Floating point inequality testing. + private :: real_fne,complex_fne,matrix_fne,vector_fne + interface operator(.fne.) + module procedure real_fne,complex_fne,matrix_fne,vector_fne + end interface + + private :: real_fge + interface operator(.fge.) + module procedure real_fge + end interface + + private :: real_fgt + interface operator(.fgt.) + module procedure real_fgt + end interface + + private :: real_fle + interface operator(.fle.) + module procedure real_fle + end interface + + private :: real_flt + interface operator(.flt.) + module procedure real_flt + end interface + + !% Overloaded interfaces to \textsc{lapack} matrix diagonlisation + !% functions for real and complex matrices. Always calls + !% \textsc{lapack}, regardless of the 'use_intrinsic_blas' setting. + !% Both diagonalisation and solution of the generalised eigenproblem + !% are supported, but only for real positive definite symmetric or + !% complex hermitian postive definite matrices. + private :: matrix_diagonalise, matrix_diagonalise_generalised + private :: matrix_z_diagonalise, matrix_z_diagonalise_generalised + interface diagonalise + module procedure matrix_diagonalise, matrix_diagonalise_generalised + module procedure matrix_z_diagonalise, matrix_z_diagonalise_generalised + end interface + + interface nonsymmetric_diagonalise + module procedure matrix_nonsymmetric_diagonalise + end interface + + !% Calculate the inverse of a matrix in-place. Uses \textsc{lapack} to compute the inverse. + interface inverse + module procedure matrix_inverse, matrix_z_inverse + end interface inverse + + !% Return the outer product of two vectors. Usage is 'x .outer. y'. + private :: outer, z_outer_zz + interface operator(.outer.) + module procedure outer, z_outer_zz +#ifdef HAVE_QP + module procedure outer_qq +#endif + end interface + + !% Interface to return the real outer product. Usage is 'x .realouter. y'. + private :: d_outer_zz + interface operator(.realouter.) + module procedure outer, d_outer_zz + end interface + + !% Cross product between two 3-vectors. Usage is 'x .cross. y'. + private :: cross_product + interface operator(.cross.) + module procedure cross_product + end interface + + !% Test for matrix symmetry (with floating point equality test '.feq.' as described above). + private :: matrix_is_symmetric, matrix_z_is_symmetric, int_matrix_is_symmetric + interface is_symmetric + module procedure matrix_is_symmetric, matrix_z_is_symmetric, int_matrix_is_symmetric + end interface is_symmetric + + !% Test for matrix hermiticity (with floating point equals test). + private :: matrix_z_is_hermitian + interface is_hermitian + module procedure matrix_z_is_hermitian + end interface + + !% Test for matrix hermiticity (with floating point equals test). + private :: matrix_z_make_hermitian, matrix_d_make_hermitian + interface make_hermitian + module procedure matrix_z_make_hermitian, matrix_d_make_hermitian + end interface + + !% Test if matrix is square + private :: matrix_square, matrix_z_square, int_matrix_square, logical_matrix_square + interface is_square + module procedure matrix_square, matrix_z_square, int_matrix_square, logical_matrix_square + end interface + public :: is_square + + !% Test is matrix is unitary i.e. if $M M^{-1} = I$ + private :: matrix_is_orthogonal + interface is_orthogonal + module procedure matrix_is_orthogonal + end interface is_orthogonal + + !% Symmetrise a matrix: $$A \to \frac{A + A^T}{2}$$ + private :: matrix_symmetrise + interface symmetrise + module procedure matrix_symmetrise + end interface + + !% Return the trace of a matrix. + private :: matrix_trace + interface trace + module procedure matrix_trace +#ifdef HAVE_QP + module procedure matrix_trace_q +#endif + end interface + + private :: matrix_trace_mult + interface trace_mult + module procedure matrix_trace_mult + end interface + + !% Adds the identity to a matrix + private :: matrix_add_identity_r, matrix_add_identity_c + interface add_identity + module procedure matrix_add_identity_r, matrix_add_identity_c + end interface add_identity + + !% Adds $x\mathbf{I}$ to a matrix + private :: matrix_add_xidentity_r, matrix_add_xidentity_c + interface add_xidentity + module procedure matrix_add_xidentity_r, matrix_add_xidentity_c + end interface add_xidentity + + !% Return the euclidean norm of a vector or of an array. + !% For a single vector 'x', 'norm(x)' is equal to 'sqrt(x .dot. x)' + !% A two-dimensional array is treated as a list of vectors in either + !% Fortran ('dir=1') or C ('dir=2') style-ordering. + !% The result is then a one-dimensional array of the norms of each vector. + private :: vector_norm, array_norm + interface norm + module procedure vector_norm, array_norm + end interface + + !% Euclidean norm$^2$ of a vector or a of a list of vectors. Result is equal + !% to 'x .dot. x' for a single vector 'x'. + private :: vector_normsq, array_normsq + interface normsq + module procedure vector_normsq, array_normsq +#ifdef HAVE_QP + module procedure vector_normsq_q +#endif + end interface + + !% Randomise the elements of an array. Uniformly distributed random quantities in the range + !% $(-\frac{a}{2},\frac{a}{2})$ are added to each element of the vector or matrix. + private :: vector_randomise, matrix_randomise, matrix_randomise_vweight, matrix_z_randomise, vector_z_randomise + interface randomise + module procedure vector_randomise, matrix_randomise, matrix_randomise_vweight, matrix_z_randomise, vector_z_randomise + end interface + + !% Search an array by element or by row. + private :: find_in_array_element_i, find_in_array_element_s, find_in_array_row + interface find_in_array + module procedure find_in_array_element_i, find_in_array_element_s, find_in_array_row + end interface + + !% Root-mean-square difference calculation for components of two vectors or arrays. + private :: rms_diff1, rms_diff2 + interface rms_diff + module procedure rms_diff1, rms_diff2 + end interface rms_diff + + + !% Returns a vector, contining a histogram of frequencies. + private :: vector_histogram + interface histogram + module procedure vector_histogram + end interface histogram + + private :: sort_array_i, sort_array_r + interface sort_array + module procedure sort_array_i, sort_array_r + end interface sort_array + + private :: heap_sort_i, heap_sort_r, heap_sort_r_2dim, heap_sort_i_2dim + interface heap_sort + module procedure heap_sort_i, heap_sort_r, heap_sort_r_2dim, heap_sort_i_2dim + end interface heap_sort + + private :: insertion_sort_i, insertion_sort_r + interface insertion_sort + module procedure insertion_sort_i, insertion_sort_r + end interface insertion_sort + + private :: binary_search_i, binary_search_r + interface binary_search + module procedure binary_search_i, binary_search_r + endinterface + + ! in addition, these are the intrinsics defined on matrices and vectors: + ! + ! = : intrinsic assignment, the left part needs to be allocated + ! * : intrinsic product : elementwise product + ! + : intrinsic sum : elementwise sum + ! - : intrinsic difference : elementwise difference + ! / : intrinsic division : elementwise division + ! + ! cos,sin,exp,log,sqrt,**,abs ....... : elementwise + ! matmul : intrinsic row*column product + ! transpose : intrinsic transposition + ! + ! in the following you can specify the direction of matrix, as optional argument, + ! which the operation will be performed along. + ! + ! maxval: return maximum in the matrix + ! minval: return minimum in the matrix + ! sum : return sum of matrix or vector elements + ! product : return product of matrix or vector elements + ! reshape(matrix,newshape) : to change shape + ! (the order of elements in memory will not change) + ! + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Interface to array size checking routines +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! Usage: call check_size(name,array,sizes,calling routine) + ! e.g. check_size('Velocity',velo,(/3,ds%N/),'DS_Add_Atom') + + !% Overloaded interface to assert that the size of an array is correct. + !% If the test fails 'system_abort' is called with an appropriate error message + !% constructed from the 'arrayname' and 'caller' arguments. + private :: check_size_int_dim1, check_size_int_dim1_s, check_size_int_dim2 + private :: check_size_real_dim1,check_size_real_dim1_s, check_size_real_dim2 +#ifdef HAVE_QP + private :: check_size_quad_dim1,check_size_quad_dim1_s, check_size_quad_dim2 +#endif + private :: check_size_complex_dim1,check_size_complex_dim1_s, check_size_complex_dim2 + private :: check_size_log_dim1, check_size_log_dim1_s, check_size_log_dim2 + interface check_size + module procedure check_size_int_dim1, check_size_int_dim1_s, check_size_int_dim2 + module procedure check_size_real_dim1, check_size_real_dim1_s, check_size_real_dim2, check_size_real_dim3 +#ifdef HAVE_QP + module procedure check_size_quad_dim1, check_size_quad_dim1_s, check_size_quad_dim2 +#endif + module procedure check_size_complex_dim1, check_size_complex_dim1_s, check_size_complex_dim2 + module procedure check_size_log_dim1, check_size_log_dim1_s, check_size_log_dim2 + end interface check_size + + !% Update a measure of a recent average by decaying its current value and adding on a new sample + private :: update_exponential_average_s, update_exponential_average_v, update_exponential_average_d2 + interface update_exponential_average + module procedure update_exponential_average_s, update_exponential_average_v, update_exponential_average_d2 + end interface update_exponential_average + + private :: matrix_exp_d + interface matrix_exp + module procedure matrix_exp_d + end interface matrix_exp + + private :: uniq_int, uniq_real, uniq_real_dim2 + interface uniq + module procedure uniq_int, uniq_real, uniq_real_dim2 + endinterface uniq + + private :: find_nonzero_chunk_real1d + interface find_nonzero_chunk + module procedure find_nonzero_chunk_real1d + endinterface find_nonzero_chunk +CONTAINS + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X +!X random crap +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function int_sign(n) + integer::n, int_sign + int_sign = sign(1, n) + end function int_sign + + function real_sign(n) + real(dp)::n, real_sign + real_sign = sign(1.0_dp, n) + end function real_sign + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X +!X MATRIX stuff +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Kronecker delta function $\delta_{ij}$. + function delta(i,j) + integer, intent(in) :: i,j + integer :: delta + if (i == j) then + delta = 1 + else + delta = 0 + end if + end function delta + + ! diag(v) + ! + ! return a matrix with the vector as its diagonal + function vector_as_diag_matrix_r(vect) result(matrix) + real(dp),intent(in), dimension(:) :: vect + real(dp), dimension(size(vect),size(vect)) :: matrix + integer::i + + matrix = 0.0_dp + + do i=1,size(vect) + matrix(i,i)=vect(i) + end do + + end function vector_as_diag_matrix_r + + ! diag(v) + ! + ! return a matrix with the vector as its diagonal + function vector_as_diag_matrix_c(vect) result(matrix) + complex(dp),intent(in), dimension(:) :: vect + complex(dp), dimension(size(vect),size(vect)) :: matrix + integer::i + + matrix = 0.0_dp + + do i=1,size(vect) + matrix(i,i)=vect(i) + end do + + end function vector_as_diag_matrix_c + + ! diag(matrix) + ! + ! returns the diagonal of a matrix as a vector + function matrix_diagonal_r(matrix) result (vect) + real(dp),intent(in), dimension(:,:) ::matrix + real(dp), dimension(size(matrix,1)) ::vect + integer::I + + if (.NOT.is_square(matrix)) call system_abort('Matrix_diagonal: matrix not squared') + + do i=1,size(matrix,1) + vect(i)=matrix(i,i) + end do + + end function matrix_diagonal_r + + ! diag(matrix) + ! + ! returns the diagonal of a matrix as a vector + function matrix_diagonal_c(matrix) result (vect) + complex(dp),intent(in), dimension(:,:) ::matrix + complex(dp), dimension(size(matrix,1)) ::vect + integer::I + + if (.NOT.is_square(matrix)) call system_abort('Matrix_diagonal: matrix not squared') + + do i=1,size(matrix,1) + vect(i)=matrix(i,i) + end do + + end function matrix_diagonal_c + + + ! m(:,:) .mult. v(:) + ! + ! matrix times a vector + function matrix_product_vect(matrix,vect) result (prodvect) + real(dp),intent(in), dimension(:) :: vect + real(dp),intent(in), dimension(:,:) :: matrix + real(dp), dimension(size(matrix,1)) ::prodvect + integer::N,M,i,j + + N=size(matrix,1) + M=size(matrix,2) + + if (M /= size(vect)) call check_size('Vector',vect,M,'Matrix_Product_Vect') + prodvect = 0.0_dp + do j=1,M + forall (i=1:N) prodvect(i) = prodvect(i) + matrix(i,j)*vect(j) + end do + + end function matrix_product_vect + + ! m(:,:) .mult. a(:) + ! + ! product of real matrix and integer vector + function matrix_product_int_vect(matrix,intvect) result(prodvect) + + real(dp), intent(in), dimension(:,:) :: matrix + integer, intent(in), dimension(:) :: intvect + real(dp) :: prodvect(size(matrix,1)) + integer :: M,N,i,j + + N=size(matrix,1) + M=size(matrix,2) + if(M /= size(intvect)) & + call check_size('Integer Vector',intvect,M,'Matrix_product_int_vect') + prodvect = 0.0_dp + do j=1,M + forall(i=1:N) prodvect(i) = prodvect(i)+matrix(i,j)*intvect(j) + end do + + end function matrix_product_int_vect + + function matrix_product_int_mat(matrix,intmat) result(prodmat) + + real(dp), intent(in), dimension(:,:) :: matrix + integer, intent(in), dimension(:,:) :: intmat + real(dp) :: prodmat(size(matrix,1),size(intmat,2)) + integer :: M,N,L,i + + N=size(matrix,1) + M=size(matrix,2) + L=size(intmat,2) + if (M /= size(intmat,1)) & + call check_size('Integer Matrix',intmat,(/M,L/),'Matrix_product_int_mat') + prodmat = 0.0_dp + do i=1,L + prodmat(:,i) = matrix_product_int_vect(matrix,intmat(:,i)) + end do + + end function matrix_product_int_mat + + ! subroutine form of m(:,:) .multd. v(:) for real = real * real + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) +#ifdef HAVE_QP + subroutine matrix_product_vect_asdiagonal_sub_qqq(lhs, matrix, vect) + real(qp), dimension(:,:), intent(out) :: lhs + real(qp), dimension(:,:), intent(in) :: matrix + real(qp), dimension(:), intent(in) :: vect + + integer :: i + +!$omp parallel do private(i) shared(lhs,vect,matrix) + do i = 1, size(vect) + lhs(:,i) = vect(i) * matrix(:,i) + enddo + + endsubroutine matrix_product_vect_asdiagonal_sub_qqq +#endif + + subroutine matrix_product_vect_asdiagonal_sub_ddd(lhs, matrix, vect) + real(dp), dimension(:,:), intent(out) :: lhs + real(dp), dimension(:,:), intent(in) :: matrix + real(dp), dimension(:), intent(in) :: vect + + integer :: i + +!$omp parallel do private(i) shared(lhs,vect,matrix) + do i = 1, size(vect) + lhs(:,i) = vect(i) * matrix(:,i) + enddo + + endsubroutine matrix_product_vect_asdiagonal_sub_ddd + + ! subroutine form of m(:,:) .multd. v(:) for complex = real * complex + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine matrix_product_vect_asdiagonal_sub_zdz(lhs, matrix, vect) + complex(dp), dimension(:,:), intent(out) :: lhs + real(dp), dimension(:,:), intent(in) :: matrix + complex(dp), dimension(:), intent(in) :: vect + + integer :: i + +!$omp parallel do private(i) shared(lhs,vect,matrix) + do i = 1, size(vect) + lhs(:,i) = vect(i) * matrix(:,i) + enddo + + endsubroutine matrix_product_vect_asdiagonal_sub_zdz + + ! subroutine form of m(:,:) .multd. v(:) for complex = complex * real + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine matrix_product_vect_asdiagonal_sub_zzd(lhs, matrix, vect) + complex(dp), dimension(:,:), intent(out) :: lhs + complex(dp), dimension(:,:), intent(in) :: matrix + real(dp), dimension(:), intent(in) :: vect + + integer :: i + +!$omp parallel do private(i) shared(lhs,vect,matrix) + do i = 1, size(vect) + lhs(:,i) = vect(i) * matrix(:,i) + enddo + + endsubroutine matrix_product_vect_asdiagonal_sub_zzd + + ! subroutine form of m(:,:) .multd. v(:) for complex = complex * complex + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine matrix_product_vect_asdiagonal_sub_zzz(lhs, matrix, vect) + complex(dp), dimension(:,:), intent(out) :: lhs + complex(dp), dimension(:,:), intent(in) :: matrix + complex(dp), dimension(:), intent(in) :: vect + + integer :: i + +!$omp parallel do private(i) shared(lhs,vect,matrix) + do i = 1, size(vect) + lhs(:,i)=vect(i)*matrix(:,i) + end do + + endsubroutine matrix_product_vect_asdiagonal_sub_zzz + + ! subroutine form of v(:) .multd. m(:,:) for real = real * real + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine vect_asdiagonal_product_matrix_sub_ddd(lhs, vectL, matrix) + real(dp), dimension(:,:), intent(out) :: lhs + real(dp), dimension(:), intent(in) :: vectL + real(dp), dimension(:,:), intent(in) :: matrix + + integer :: i + + do i = 1, size(matrix,2) + lhs(:,i)=vectL(:)*matrix(:,i) + end do + + end subroutine vect_asdiagonal_product_matrix_sub_ddd + + ! subroutine form of v(:) .multd. m(:,:) for complex = complex * real + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine vect_asdiagonal_product_matrix_sub_zzd(lhs, vectL, matrix) + complex(dp), dimension(:,:), intent(out) :: lhs + complex(dp), dimension(:), intent(in) :: vectL + real(dp), dimension(:,:), intent(in) :: matrix + + integer :: i + + do i = 1, size(matrix,2) + lhs(:,i)=vectL(:)*matrix(:,i) + end do + + end subroutine vect_asdiagonal_product_matrix_sub_zzd + + ! subroutine form of v(:) .multd. m(:,:) for complex = real * complex + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine vect_asdiagonal_product_matrix_sub_zdz(lhs, vectL, matrix) + complex(dp), dimension(:,:), intent(out) :: lhs + real(dp), dimension(:), intent(in) :: vectL + complex(dp), dimension(:,:), intent(in) :: matrix + + integer :: i + + do i = 1, size(matrix,2) + lhs(:,i)=vectL(:)*matrix(:,i) + end do + + end subroutine vect_asdiagonal_product_matrix_sub_zdz + + ! subroutine form of v(:) .multd. m(:,:) for complex = complex * complex + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine vect_asdiagonal_product_matrix_sub_zzz(lhs, vectL, matrix) + complex(dp), dimension(:,:), intent(out) :: lhs + complex(dp), dimension(:), intent(in) :: vectL + complex(dp), dimension(:,:), intent(in) :: matrix + + integer :: i + + do i = 1, size(matrix,2) + lhs(:,i)=vectL(:)*matrix(:,i) + end do + + end subroutine vect_asdiagonal_product_matrix_sub_zzz + + ! m(:,:) .multd. v(:) + ! + ! returns product of matrix and vector as diagonal of another matrix + function matrix_product_vect_asdiagonal_dd(matrix,vect) result (prodmatrix) + real(dp),intent(in),dimension(:,:)::matrix + real(dp),intent(in), dimension(:) :: vect + real(dp),dimension(size(matrix,1),size(matrix,2))::prodmatrix + + call matrix_product_vect_asdiagonal_sub(prodmatrix, matrix, vect) + + end function matrix_product_vect_asdiagonal_dd + + ! m(:,:) .multd. v(:) + ! + ! returns product of matrix and vector as diagonal of another matrix + function matrix_product_vect_asdiagonal_zz(matrix,vect) result (prodmatrix) + complex(dp),intent(in), dimension(:) :: vect + complex(dp),dimension(size(vect),size(vect))::prodmatrix + complex(dp),intent(in),dimension(:,:)::matrix + + call matrix_product_vect_asdiagonal_sub(prodmatrix, matrix, vect) + + end function matrix_product_vect_asdiagonal_zz + + ! multiply a matrix by a vector, interepreted as a diagonal matrix, on + ! the left and right hand sides, weighted by 0.5 + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine matrix_product_vect_asdiagonal_RL_sub_ddd(lhs, matrix, vect) + real(dp), intent(out) :: lhs(:,:) + real(dp), intent(in) :: matrix(:,:) + real(dp), intent(in) :: vect(:) + + real(dp)::tmp + integer::i,j,N + + N=size(vect) + + do j=1,N + tmp=vect(j) + do i=1,N + lhs(i,j)=0.5_dp*(tmp+vect(i))*matrix(i,j) + end do + end do + + end subroutine matrix_product_vect_asdiagonal_RL_sub_ddd + + ! multiply a matrix by a vector, interepreted as a diagonal matrix, on + ! the left and right hand sides, weighted by 0.5 + ! + ! first argument set to product of matrix and a vector as a diagonal of another matrix (no temp on stack) + subroutine matrix_product_vect_asdiagonal_RL_sub_zzd(lhs, matrix, vect) + complex(dp), intent(out) :: lhs(:,:) + complex(dp), intent(in) :: matrix(:,:) + real(dp), intent(in) :: vect(:) + + real(dp)::tmp + integer::i,j,N + + N=size(vect) + + do j=1,N + tmp=vect(j) + do i=1,N + lhs(i,j)=0.5_dp*(tmp+vect(i))*matrix(i,j) + end do + end do + + end subroutine matrix_product_vect_asdiagonal_RL_sub_zzd + + + ! multiply matrix C with a diagonal matrix that has vect as diagonal, + ! and then multiply the result and the tranpose of C. + ! NEEDS TO BE OPTIMIZED + function matrix_cfct(matrix,vect) result (prodmatrix) + real(dp),intent(in),dimension(:) :: vect + real(dp),intent(in),dimension(:,:) :: matrix + real(dp), dimension(size(matrix,1),size(matrix,1)) ::prodmatrix + integer::i,j,k,N,M + real(dp)::tmp + + N=size(matrix,1) + M=size(matrix,2) + + if(M /= size(vect)) & + call check_size('Vector',vect,M,'Matrix_CFCT') + + do I=1,N + do j=1,N + tmp=0.0_dp + do k=1,size(vect)/2 + tmp=tmp+matrix(I,K)*vect(k)*matrix(j,K) + end do + do k=size(vect)/2+1,size(vect) + if (abs(vect(k)).LT.(real(1.e-10))) cycle + + tmp=tmp+matrix(I,K)*vect(k)*matrix(j,K) + end do + prodmatrix(I,J)=tmp + end do + end do + + end function matrix_cfct + + + ! m1(:,:) .dot. m2(:,:) + ! + ! scalar product between matrixes + function matrix_dotproduct_matrix(matrix1,matrix2) result(prod) + real(dp),intent(in), dimension(:,:) :: matrix1 + real(dp),intent(in), dimension(:,:) :: matrix2 + real(dp)::prod + integer::i,j + + if(size(matrix1,1) /= size(matrix2,1) .or. size(matrix1,2) /= size(matrix2,2)) & + call check_size('Matrix2',matrix2,shape(matrix1),'Matrix_Dotproduct_Matrix') + + prod = 0.0_dp + do j = 1, size(matrix1,2) + do i = 1, size(matrix1,1) + prod = prod + matrix1(i,j)*matrix2(i,j) + end do + end do + + end function matrix_dotproduct_matrix + + ! subroutine form of m1(:,:) .mult. m2(:,:) + ! + ! set first argument to matrix product (no temporary on the stack) + subroutine matrix_product_sub_ddd(lhs, matrix1, matrix2, m1_transpose, m2_transpose, & + lhs_factor, rhs_factor) + real(dp), intent(out) :: lhs(:,:) + real(dp), intent(in) :: matrix1(:,:), matrix2(:,:) + logical, intent(in), optional :: m1_transpose, m2_transpose + real(dp), intent(in), optional :: lhs_factor, rhs_factor + + integer::M,N,maxd,K + character(len=1) :: m1_transp, m2_transp + integer :: m1_r, m1_c, m2_r, m2_c + real(dp) :: my_lhs_factor, my_rhs_factor + + m1_transp = 'N' + m2_transp = 'N' + if (present(m1_transpose)) then + if (m1_transpose) m1_transp = 'T' + endif + if (present(m2_transpose)) then + if (m2_transpose) m2_transp = 'T' + endif + + if (m1_transp == 'N') then + m1_r = 1; m1_c = 2 + else + m1_r = 2; m1_c = 1 + endif + if (m2_transp == 'N') then + m2_r = 1; m2_c = 2 + else + m2_r = 2; m2_c = 1 + endif + + my_lhs_factor = optional_default(0.0_dp, lhs_factor) + my_rhs_factor = optional_default(1.0_dp, rhs_factor) + + call check_size('lhs',lhs,(/size(matrix1,m1_r),size(matrix2,m2_c)/),'Matrix_Product') + if (m2_transp == 'N') then + call check_size('Matrix2',matrix2,(/size(matrix1,m1_c),size(matrix2,m2_c)/),'Matrix_Product') + else + call check_size('Matrix2',matrix2,(/size(matrix2,m2_c),size(matrix1,m1_c)/),'Matrix_Product') + endif + + N = size(lhs,1) !# of rows of lhs + M = size(lhs,2) !# of columns of rhs + K = size(matrix1,m1_c) !!shared dimension + maxd=max(N,M,K) + + if (use_intrinsic_blas) then + if (m1_transp == 'T') then + if (m2_transp == 'T') then + lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),transpose(matrix2)) + else + lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),matrix2) + endif + else + if (m2_transp == 'T') then + lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,transpose(matrix2)) + else + lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,matrix2) + endif + endif + else + call DGEMM(m1_transp,m2_transp, N,M,K,my_rhs_factor,matrix1,size(matrix1,1),matrix2,size(matrix2,1),& + my_lhs_factor,lhs,size(lhs,1)) + endif + + end subroutine matrix_product_sub_ddd + + ! subroutine form of m1(:,:) .mult. m2(:,:) + ! + ! set first argument to matrix product (no temporary on the stack) + subroutine matrix_product_sub_zzz(lhs, matrix1, matrix2, m1_transpose, m1_conjugate, & + m2_transpose, m2_conjugate, lhs_factor, rhs_factor) + complex(dp), intent(out) :: lhs(:,:) + complex(dp), intent(in) :: matrix1(:,:), matrix2(:,:) + logical, intent(in), optional :: m1_transpose, m1_conjugate, m2_transpose, m2_conjugate + complex(dp), intent(in), optional :: lhs_factor, rhs_factor + + integer::M,N,maxd,K + logical :: m1_transp, m2_transp, m1_conjg, m2_conjg + character(len=1) :: m1_op, m2_op + integer :: m1_r, m1_c, m2_r, m2_c + complex(dp) :: my_lhs_factor, my_rhs_factor + + m1_transp = .false. + m2_transp = .false. + m1_conjg = .false. + m2_conjg = .false. + if (present(m1_transpose)) m1_transp = m1_transpose + if (present(m2_transpose)) m2_transp = m2_transpose + if (present(m1_conjugate)) m1_conjg = m1_conjugate + if (present(m2_conjugate)) m2_conjg = m2_conjugate + + if (m1_conjg .and. m1_transp) call system_abort("Called matrix_product_sub_zzz with m1_transp and m1_conjg true") + if (m2_conjg .and. m2_transp) call system_abort("Called matrix_product_sub_zzz with m2_transp and m2_conjg true") + + if (m1_transp) then + m1_op = 'T' + else if (m1_conjg) then + m1_op = 'C' + else + m1_op = 'N' + end if + + if (m2_transp) then + m2_op = 'T' + else if (m2_conjg) then + m2_op = 'C' + else + m2_op = 'N' + end if + + if (m1_op == 'N') then + m1_r = 1; m1_c = 2 + else + m1_r = 2; m1_c = 1 + endif + if (m2_op == 'N') then + m2_r = 1; m2_c = 2 + else + m2_r = 2; m2_c = 1 + endif + + my_lhs_factor = optional_default(cmplx(0.0_dp, 0.0_dp, dp), lhs_factor) + my_rhs_factor = optional_default(cmplx(1.0_dp, 0.0_dp, dp), rhs_factor) + + call check_size('lhs',lhs,(/size(matrix1,m1_r),size(matrix2,m2_c)/),'Matrix_Product') + if (m2_op == 'N') then + call check_size('Matrix2',matrix2,(/size(matrix1,m1_c),size(matrix2,m2_c)/),'Matrix_Product') + else + call check_size('Matrix2',matrix2,(/size(matrix2,m2_c),size(matrix1,m1_c)/),'Matrix_Product') + endif + + N = size(lhs,1) !# of rows of lhs + M = size(lhs,2) !# of columns of rhs + K = size(matrix1,m1_c) !!shared dimension + maxd=max(N,M,K) + + if (use_intrinsic_blas) then + if (m1_transp) then + if (m2_transp) then + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),transpose(matrix2)) + else if (m2_conjg) then + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),conjg(transpose(matrix2))) + else + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix1),matrix2) + endif + else if (m1_conjg) then + if (m2_transp) then + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(conjg(transpose(matrix1)),transpose(matrix2)) + else if (m2_conjg) then + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(conjg(transpose(matrix1)),conjg(transpose(matrix2))) + else + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(conjg(transpose(matrix1)),matrix2) + endif + else + if (m2_transp) then + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,transpose(matrix2)) + else if (m2_conjg) then + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,conjg(transpose(matrix2))) + else + lhs = lhs*my_lhs_factor + my_rhs_factor*matmul(matrix1,matrix2) + endif + endif + else + call ZGEMM(m1_op,m2_op, N,M,K,my_rhs_factor,matrix1,size(matrix1,1),matrix2,size(matrix2,1),my_lhs_factor,lhs,size(lhs,1)) + endif + + end subroutine matrix_product_sub_zzz + + subroutine matrix_vector_product_sub_ddd(lhs, matrix, vector, m_transpose, & + lhs_factor, rhs_factor) + real(dp), intent(out) :: lhs(:) + real(dp), intent(in) :: matrix(:,:), vector(:) + logical, intent(in), optional :: m_transpose + real(dp), intent(in), optional :: lhs_factor, rhs_factor + + integer::M,N,maxd + character(len=1) :: m_transp + integer :: m_r, m_c + real(dp) :: my_lhs_factor, my_rhs_factor + + m_transp = 'N' + if (present(m_transpose)) then + if (m_transpose) m_transp = 'T' + endif + + if (m_transp == 'N') then + m_r = 1; m_c = 2 + else + m_r = 2; m_c = 1 + endif + + my_lhs_factor = optional_default(0.0_dp, lhs_factor) + my_rhs_factor = optional_default(1.0_dp, rhs_factor) + + call check_size('lhs',lhs,(/size(matrix,m_r)/),'Matrix_Product') + + N = size(lhs) !# of rows of lhs + M = size(matrix,m_c) !!shared dimension + maxd=max(N,M) + + if (use_intrinsic_blas) then + if (m_transp == 'T') then + lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(transpose(matrix),vector) + else + lhs=lhs*my_lhs_factor + my_rhs_factor*matmul(matrix,vector) + endif + else + call DGEMV(m_transp,N,M,my_rhs_factor,matrix,size(matrix,1),vector,1,& + my_lhs_factor,lhs,1) + endif + + end subroutine matrix_vector_product_sub_ddd + ! m1(:,:) .mult. m2(:,:) + ! + ! matrix multiplication (either lapack or intrinsic) + function matrix_product_ddd(matrix1,matrix2) result (prodmatrix) + real(dp),intent(in), dimension(:,:) :: matrix1 + real(dp),intent(in), dimension(:,:) :: matrix2 + real(dp), dimension(size(matrix1,1),size(matrix2,2)) ::prodmatrix + + call matrix_product_sub(prodmatrix, matrix1, matrix2) + end function matrix_product_ddd + + ! m1(:,:) .mult. m2(:,:) + ! + ! matrix multiplication (either lapack or intrinsic) + function matrix_product_zzz(matrix1,matrix2) result (prodmatrix) + complex(dp),intent(in), dimension(:,:) :: matrix1 + complex(dp),intent(in), dimension(:,:) :: matrix2 + complex(dp), dimension(size(matrix1,1),size(matrix2,2)) ::prodmatrix + + call matrix_product_sub(prodmatrix, matrix1, matrix2) + end function matrix_product_zzz + + ! m1(:,:) .mult. m2'(:,:) + ! + !% Calculate matrix product of 'matrix1' and 'matrix2' after transposing matrix2 + !% (either using \textsc{lapack} or intrinsic multiplication, depending on the + !& 'use_intrinsic_blas' setting). + function matrix_multT(matrix1,matrix2) result (prodmatrix) + real(dp),intent(in), dimension(:,:) :: matrix1 + real(dp),intent(in), dimension(:,:) :: matrix2 + real(dp), dimension(size(matrix1,1),size(matrix2,2)) ::prodmatrix + + call matrix_product_sub(prodmatrix, matrix1, matrix2, m1_transpose = .false., m2_transpose = .true.) + + end function matrix_multT + + + ! a .feq. b + ! + ! floating point logical comparison + pure function real_feq(x,y) result(feq) + + real(dp), intent(in) :: x, y + logical :: feq + + feq = (abs(x-y) <= NUMERICAL_ZERO * (abs(x)+abs(y))/2.0_dp) .or. (abs(x-y) <= NUMERICAL_ZERO) + + end function real_feq + + pure function real_integer_feq(x,y) result(feq) + + integer, intent(in) :: x + real(dp), intent(in) :: y + logical :: feq + + feq = real_feq(real(x,dp),y) + + end function real_integer_feq + + pure function integer_real_feq(x,y) result(feq) + + real(dp), intent(in) :: x + integer, intent(in) :: y + logical :: feq + + feq = real_feq(x,real(y,dp)) + + end function integer_real_feq + + ! a .fne. b + ! + ! floating point logical comparison + pure function real_fne(x,y) result(fne) + + real(dp), intent(in) :: x, y + logical :: fne + + fne = .not. real_feq(x, y) + + end function real_fne + + pure function real_fgt(x,y) result(fgt) + real(dp), intent(in) :: x, y + logical :: fgt + + fgt = ( (x-y) > max(abs(x),abs(y)) * NUMERICAL_ZERO ) !.or. ( (x-y) > NUMERICAL_ZERO ) + + endfunction real_fgt + + pure function real_fle(x,y) result(fle) + real(dp), intent(in) :: x, y + logical :: fle + + fle = .not. real_fgt(x,y) + + endfunction real_fle + + pure function real_flt(x,y) result(flt) + real(dp), intent(in) :: x, y + logical :: flt + + flt = ( (y-x) > max(abs(x),abs(y)) * NUMERICAL_ZERO ) !.or. ( (y-x) > NUMERICAL_ZERO ) + + endfunction real_flt + + pure function real_fge(x,y) result(fge) + real(dp), intent(in) :: x, y + logical :: fge + + fge = .not. real_flt(x,y) + + endfunction real_fge + + ! za .feq. zb + ! + ! complex logical comparison + pure function complex_feq(x,y) result(feq) + + complex(dp), intent(in) :: x, y + logical :: feq + + if ( (abs(real(x-y)) > NUMERICAL_ZERO * abs(real(x))) .or. & + (abs(aimag(x-y)) > NUMERICAL_ZERO * abs(aimag(x))) ) then + feq = .false. + else + feq = .true. + end if + + end function complex_feq + + ! za .fne. zb + ! + ! complex logical comparison + pure function complex_fne(x,y) result(fne) + + complex(dp), intent(in) :: x, y + logical :: fne + + if ( (abs(real(x-y)) > NUMERICAL_ZERO * abs(real(x))) .or. & + (abs(aimag(x-y)) > NUMERICAL_ZERO * abs(aimag(x))) ) then + fne = .true. + else + fne = .false. + end if + + end function complex_fne + + ! m1 .feq. m2 + ! + ! matrix floating point comparison + function matrix_feq(matrix1,matrix2) result (feq) + real(dp),intent(in), dimension(:,:) :: matrix1 + real(dp),intent(in), dimension(:,:) :: matrix2 + + integer::i,j + logical::feq + + call check_size('Matrix2',matrix2,shape(matrix1),'Matrix_FEQ') + + feq =.true. + do j=1,size(matrix1,2) + do i=1,size(matrix1,1) + if (matrix1(i,j).fne.matrix2(i,j)) then + feq=.false. + return + end if + end do + end do + + end function matrix_feq + + ! m1 .fne. m2 + ! + ! matrix floating point comparison + function matrix_fne(matrix1,matrix2) result (fne) + real(dp),intent(in), dimension(:,:) :: matrix1 + real(dp),intent(in), dimension(:,:) :: matrix2 + + integer::i,j + logical::fne + + if(size(matrix1,1) /= size(matrix2,1) .or. size(matrix1,2) /= size(matrix2,2)) & + call check_size('Matrix2',matrix2,shape(matrix1),'Matrix_FNE') + + fne =.false. + do j=1,size(matrix1,2) + do i=1,size(matrix1,1) + if (matrix1(i,j).FNE.matrix2(i,j)) then + fne=.true. + return + end if + end do + end do + + end function matrix_fne + + ! is_square(matrix) + ! + ! tells if the matrix is square + function matrix_square(matrix) result(sq) + real(dp),intent(in), dimension(:,:) :: matrix + logical::sq + + if (size(matrix,1).EQ.size(matrix,2)) then + sq=.true. + else + sq=.false. + end if + + end function matrix_square + + function int_matrix_square(matrix) result(sq) + + integer, intent(in), dimension(:,:) :: matrix + logical::sq + + sq = size(matrix,1) == size(matrix,2) + + end function int_matrix_square + + function logical_matrix_square(matrix) result(sq) + + logical, dimension(:,:), intent(in) :: matrix + + logical :: sq + + sq = size(matrix,1) == size(matrix,2) + + end function logical_matrix_square + + ! is_square(matrix_z) + ! + ! tells if the complex matrix is square + function matrix_z_square(matrix_z) result(sq) + complex(dp),intent(in), dimension(:,:) ::matrix_z + logical::sq + + if (size(matrix_z,1).EQ.size(matrix_z,2)) then + sq=.true. + else + sq=.false. + end if + + end function matrix_z_square + + + ! symmetrise matrix A -> (A + transpose(A))/2 + subroutine matrix_symmetrise(matrix) + real(dp), intent(inout), dimension(:,:) :: matrix + integer::i,j,n + real(dp)::tmp + + if (.not.is_square(matrix)) call system_abort('Matrix_Symmetrise: Matrix is not square') + + n=size(matrix,1) + do i=1,n + do j=i+1,n + tmp=0.5_dp*(matrix(i,j)+matrix(j,i)) + matrix(i,j)=tmp + matrix(j,i)=tmp + end do + end do + + end subroutine matrix_symmetrise + + !returns trace of a matrix + function matrix_trace(matrix) result(tr) + real(dp),intent(in), dimension(:,:) ::matrix + real(dp)::tr + integer::i,N + + N = min(size(matrix,1),size(matrix,2)) + + tr=0.0_dp + do i=1,N + tr=tr+matrix(i,i) + end do + + end function matrix_trace + +#ifdef HAVE_QP + function matrix_trace_q(matrix) result(tr) + real(qp),intent(in), dimension(:,:) ::matrix + real(qp)::tr + integer::i,N + + N = min(size(matrix,1),size(matrix,2)) + + tr=0.0_qp + do i=1,N + tr=tr+matrix(i,i) + end do + + end function matrix_trace_q +#endif + + !returns trace of the result matrix + function matrix_trace_mult(matrixA, matrixB) result(trm) + real(dp),intent(in), dimension(:,:) ::matrixA, matrixB + real(dp)::trm + integer::i, N + + N = size(matrixA, 1) + if(size(matrixB, 2) /= N) call system_abort("matrix_trace_mult: size(matrixB, 2) /= N") + if(size(matrixA, 2) /= size(matrixB, 1)) call system_abort("size(matrixA, 2) /= size(matrixB, 1)") + + trm=0.0_dp + do i=1,N + trm=trm + (matrixA(i,:) .dot. matrixB(:,i)) + end do + + end function matrix_trace_mult + + subroutine matrix_add_identity_r(matrix) + real(dp), intent(inout) :: matrix(:,:) + + integer i + + if (.not.is_square(matrix)) call system_abort('Matrix_add_identity: Matrix is not square') + + do i=1, size(matrix,1) + matrix(i,i) = matrix(i,i) + 1.0_dp + end do + end subroutine matrix_add_identity_r + + subroutine matrix_add_identity_c(matrix) + complex(dp), intent(inout) :: matrix(:,:) + + integer i + + if (.not.is_square(matrix)) call system_abort('Matrix_add_identity: Matrix is not square') + + do i=1, size(matrix,1) + matrix(i,i) = matrix(i,i) + 1.0_dp + end do + end subroutine matrix_add_identity_c + + subroutine matrix_add_xidentity_r(matrix,r) + real(dp), intent(inout) :: matrix(:,:) + real(dp), intent(in) :: r + + integer :: i + + if (.not.is_square(matrix)) call system_abort('Matrix_add_xidentity: Matrix is not square') + + do i=1, size(matrix,1) + matrix(i,i) = matrix(i,i) + r + end do + end subroutine matrix_add_xidentity_r + + subroutine matrix_add_xidentity_c(matrix,c) + complex(dp), intent(inout) :: matrix(:,:) + complex(dp), intent(in) :: c + + integer :: i + + if (.not.is_square(matrix)) call system_abort('Matrix_add_xidentity: Matrix is not square') + + do i=1, size(matrix,1) + matrix(i,i) = matrix(i,i) + c + end do + end subroutine matrix_add_xidentity_c + + + ! the following stuff only with lapack + ! diagonalise matrix, only symmetric case + subroutine matrix_diagonalise(this,evals,evects, ignore_symmetry, error) + real(dp),intent(in), dimension(:,:) :: this + real(dp),intent(inout), dimension(:) ::evals + real(dp),intent(inout), target, optional, dimension(:,:) :: evects + logical, intent(in), optional :: ignore_symmetry + integer, intent(out), optional :: error + + logical :: use_ignore_symmetry + real(8),allocatable::WORK(:), r8_evals(:) + real(8), pointer :: r8_evects(:,:) + integer::N,INFO,LWORK + + INIT_ERROR(error) + + use_ignore_symmetry = optional_default(.false., ignore_symmetry) + + N=size(this,2) + call check_size('Eigenvalue Vector',evals,N,'Matrix_Diagonalise') + + if (present(evects)) & + call check_size('Eigenvector Array',evects,shape(this),'Matrix_Diagonalise') + + if (use_ignore_symmetry .or. is_symmetric(this)) then + + LWORK=3*N + allocate(WORK(LWORK)) + allocate(r8_evals(N)) + + if (present(evects) .and. dp == 8) then + r8_evects => evects + else + allocate(r8_evects(N,N)) + endif + r8_evects = this + + if (present(evects)) then + call DSYEV('V','U',N,r8_evects,N,r8_evals,WORK,LWORK,INFO) + else + call DSYEV('N','U',N,r8_evects,N,r8_evals,WORK,LWORK,INFO) + endif + + if (present(evects) .and. dp /= 8) evects = r8_evects + evals = r8_evals + + deallocate(WORK) + deallocate(r8_evals) + if (.not. (present(evects) .and. dp == 8)) deallocate(r8_evects) + + if (INFO /= 0) then + mainlog%mpi_all_inoutput_flag=.true. + call print ('Matrix_diagonalise: Error in calling DSYEV! (info = '//INFO//')', PRINT_ALWAYS) + if (INFO < 0) then + call print (' '//(-INFO)//' argument had illegal value', PRINT_ALWAYS) + else if (INFO <= N) then + call print (' '//INFO//' off-diagonal elements of an intermediate tridiagonal form did not converge to zero', PRINT_ALWAYS) + endif + mainlog%mpi_all_inoutput_flag=.false. + RAISE_ERROR ('Matrix_diagonalise: Error in calling DSYEV! (info = '//INFO//')', error) + endif + else + ! Why not print a warning then call more general diagonalise? + RAISE_ERROR('Matrix_diagonalise: Non symmetric diagonalisation is not permitted',error) + end if + + end subroutine matrix_diagonalise + + ! the following stuff only with lapack + ! diagonalise complex matrix, only hermitian positive definite case + subroutine matrix_z_diagonalise(this,evals,evects,ignore_symmetry, error) + complex(dp),intent(in), dimension(:,:) :: this + real(dp),intent(inout), dimension(:) ::evals + complex(dp),intent(inout), optional, target, dimension(:,:) :: evects + logical, intent(in), optional :: ignore_symmetry + integer, intent(out), optional :: error + + integer::N,INFO,LWORK + integer NB + integer, external :: ILAENV + + logical :: use_ignore_symmetry + complex(8), pointer :: z8_evects(:,:) + real(8), allocatable :: r8_evals(:), RWORK(:) + complex(8), pointer :: WORK(:) + + INIT_ERROR(error) + + use_ignore_symmetry = optional_default(.false., ignore_symmetry) + + N=size(this,2) + call check_size('Eigenvalue Vector',evals,N,'Matrix_z_Diagonalise') + + if (present(evects)) & + call check_size('Eigenvector Array',evects,shape(this),'Matrix_z_Diagonalise') + + if (use_ignore_symmetry .or. is_hermitian(this)) then + + NB = ILAENV(1, "ZHETRD", "U", N, N, N, N) + LWORK=(NB+1)*N + allocate(WORK(LWORK)) + allocate(RWORK(3*N-2)) + allocate(r8_evals(N)) + + if (present(evects) .and. dp == 8) then + z8_evects => evects + else + allocate(z8_evects(N,N)) + endif + z8_evects = this + + if (present(evects)) then + call ZHEEV('V','U',N,z8_evects,N,r8_evals,WORK,LWORK,RWORK,INFO) + else + call ZHEEV('N','U',N,z8_evects,N,r8_evals,WORK,LWORK,RWORK,INFO) + endif + + if (present(evects) .and. dp /= 8) evects = z8_evects + evals = r8_evals + + deallocate(WORK) + deallocate(RWORK) + deallocate(r8_evals) + if (.not.(present(evects) .and. dp == 8)) deallocate(z8_evects) + + if (INFO /= 0) then + mainlog%mpi_all_inoutput_flag=.true. + call print ('Matrix_z_diagonalise: Error in calling ZHEEV! (info = '//INFO//')', PRINT_ALWAYS) + if (INFO < 0) then + call print (' '//(-INFO)//' argument had illegal value', PRINT_ALWAYS) + else if (INFO <= N) then + call print (' '//INFO//' off-diagonal elements of an intermediate tridiagonal form did not converge to zero', PRINT_ALWAYS) + endif + mainlog%mpi_all_inoutput_flag=.false. + RAISE_ERROR ('Matrix_z_diagonalise: Error in calling ZHEEV! (info = '//INFO//')', error) + endif + else + ! why not print a warning and call more general diagonalise instead? + RAISE_ERROR ('Matrix_z_diagonalise: Non hermitian diagonalisation is not permitted', error) + end if + + end subroutine matrix_z_diagonalise + + ! generalised eigenproblem + ! just works for symmetric systems + subroutine matrix_diagonalise_generalised(this,other,evals,evects,error) + real(dp),intent(in), dimension(:,:) :: this + real(dp),intent(in), dimension(:,:) :: other + real(dp),intent(inout), dimension(:) :: evals + real(dp),intent(inout), dimension(:,:) :: evects + integer, intent(out), optional :: error + + real(dp), allocatable :: other_copy(:,:) + real(dp), allocatable :: WORK(:) + integer::N,INFO,LWORK + integer, external :: ILAENV + integer NB + + INIT_ERROR(error) + + if (dp /= 8) call system_abort("matrix_diagonalise_generalised: no workaround for LAPACK assuming 8 byte double, but dp(="//dp//") /= 8") + + NB = ILAENV(1, "DSYTRD", "U", N, N, N, N) + N=size(this,1) + LWORK=(NB+2)*N + allocate(WORK(LWORK)) + allocate(other_copy(N,N)) + + call check_size('Eigenvalue vector',evals,N,'Matrix_Diagonalise_Generalised') + call check_size('Eigenvector Array',evects,shape(this),'Matrix_Diagonalise_Generalised') + + evects = this + other_copy = other + + call DSYGV(1,'V','U',N,evects,N,other_copy,N,evals,WORK,LWORK,INFO) + + deallocate(WORK) + deallocate(other_copy) + + if (INFO /= 0) then + mainlog%mpi_all_inoutput_flag=.true. + call print ('Matrix_diagonalise_generalised: Error in calling DSYGV! (info = '//INFO//')', PRINT_ALWAYS) + if (INFO < 0) then + call print (' '//(-INFO)//' argument had illegal value', PRINT_ALWAYS) + else if (INFO <= N) then + call print (' '//INFO//' off-diagonal elements of an intermediate tridiagonal form did not converge to zero', PRINT_ALWAYS) + else + call print (' '//(INFO-N)//' leading minor of B is not positive definite, factorization failed') + endif + mainlog%mpi_all_inoutput_flag=.false. + RAISE_ERROR ('Matrix_diagonalise_generalised: Error in calling DSYGV! (info = '//INFO//')', error) + endif + + end subroutine matrix_diagonalise_generalised + + ! general eigenproblem + ! just works for hermitian systems + subroutine matrix_z_diagonalise_generalised(this,other,evals,evects, error ) + complex(dp),intent(in), dimension(:,:) :: this + complex(dp),intent(in), dimension(:,:) :: other + real(dp),intent(inout), dimension(:) :: evals + complex(dp),intent(inout), dimension(:,:) :: evects + integer, intent(out), optional :: error + + complex(dp), allocatable::WORK(:) + real(dp), allocatable::RWORK(:) + integer::N,INFO,LWORK + integer, external :: ILAENV + complex(dp), allocatable :: other_copy(:,:) + + integer NB + + INIT_ERROR(error) + + if (dp /= 8) call system_abort("matrix_z_diagonalise_generalised: no workaround for LAPACK assuming 8 byte double, but dp(="//dp//") /= 8") + + N=size(this,2) + NB = ILAENV(1, "ZHETRD", "U", N, N, N, N) + LWORK=(NB+1)*N + allocate(WORK(LWORK)) + allocate(RWORK(3*N-2)) + allocate(other_copy(N,N)) + + call check_size('Eigenvalue vector',evals,N,'Matrix_z_Diagonalise_Generalised') + call check_size('Eigenvector Array',evects,shape(this),'Matrix_z_Diagonalise_Generalised') + + evects = this + other_copy = other + + call ZHEGV(1,'V','U',N,evects,N,other_copy,N,evals,WORK,LWORK,RWORK,INFO) + + deallocate(WORK) + deallocate(RWORK) + deallocate(other_copy) + + if (INFO /= 0) then + mainlog%mpi_all_inoutput_flag=.true. + call print ('Matrix_z_diagonalise_generalised: Error in calling ZHEGV! (info = '//INFO//')', PRINT_ALWAYS) + if (INFO < 0) then + call print (' '//(-INFO)//' argument had illegal value', PRINT_ALWAYS) + else if (INFO <= N) then + call print (' '//INFO//' off-diagonal elements of an intermediate tridiagonal form did not converge to zero', PRINT_ALWAYS) + else + call print (' '//(INFO-N)//' leading minor of B is not positive definite, factorization failed') + endif + mainlog%mpi_all_inoutput_flag=.false. + RAISE_ERROR ('Matrix_z_diagonalise_generalised: Error in calling ZHEGV! (info = '//INFO//')', error) + endif + + end subroutine matrix_z_diagonalise_generalised + + subroutine matrix_nonsymmetric_diagonalise(this, eval, l_evects, r_evects, error) + real(dp), dimension(:,:), intent(in) :: this + complex(dp), dimension(:), intent(out) :: eval + complex(dp), dimension(:,:), intent(out), optional, target :: l_evects, r_evects + integer, optional, intent(out) :: error + + real(dp), dimension(:), allocatable :: wr, wi, work + real(dp), dimension(:,:), allocatable :: a + real(dp), dimension(:,:), allocatable :: vl, vr + integer :: n, lwork, info, i + character(len=1) :: cl, cr + integer :: ldvl, ldvr + + INIT_ERROR(error) + + n = size(this,1) + allocate(a(n,n), wr(n), wi(n)) + if (present(r_evects)) then + allocate(vr(n,n)) + cr = 'V' + ldvr = n + else + allocate(vr(1,1)) + cr ='N' + ldvr = 1 + endif + if (present(l_evects)) then + allocate(vl(n,n)) + cl='V' + ldvl = n + else + allocate(vl(1,1)) + cl='N' + ldvl = 1 + endif + a = this + + allocate(work(1)) + lwork = -1 + call dgeev(cl, cr, n, a, n, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info) + if (info /= 0) then + RAISE_ERROR("matrix_nonsymmetric_diagonalise first dgeev call (determine lwork) failed with INFO="//info, error) + endif + lwork = ceiling(work(1)) + deallocate(work) + allocate(work(lwork)) + call dgeev(cl, cr, n, a, n, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info) + if (info /= 0) then + RAISE_ERROR("matrix_nonsymmetric_diagonalise second dgeev call (actual calculation) failed with INFO="//info, error) + endif + + eval = cmplx(wr,wi) + if (present(l_evects) .or. present(r_evects)) then + i = 1 + do while (i <= n) + if (wi(i) == 0) then + if (present(l_evects)) l_evects(:,i) = vl(:,i) + if (present(r_evects)) r_evects(:,i) = vr(:,i) + else + if (present(l_evects)) l_evects(:,i) = cmplx(vl(:,i), vl(:,i+1)) + if (present(l_evects)) l_evects(:,i+1) = cmplx(vl(:,i), -vl(:,i+1)) + if (present(r_evects)) r_evects(:,i) = cmplx(vr(:,i), vr(:,i+1)) + if (present(r_evects)) r_evects(:,i+1) = cmplx(vr(:,i), -vr(:,i+1)) + i = i + 1 + endif + i = i + 1 + end do + endif + + deallocate( a, wr, wi, work ) + if (.not. present(l_evects)) deallocate(vl) + if (.not. present(r_evects)) deallocate(vr) + + + endsubroutine matrix_nonsymmetric_diagonalise + + subroutine test_eigensys(A, B, evals, evecs) + real(dp), intent(in) :: A(:,:), B(:,:) + real(dp), intent(in) :: evals(:) + real(dp), intent(in) :: evecs(:,:) + + real(dp), allocatable :: t1(:,:), t2(:,:) + integer n, i, j + + n = size(evals) + + allocate(t1(n,n)) + allocate(t2(n,n)) + + t1 = matmul(A, evecs) + t2 = matmul(B, evecs) + + print '("test eigensys")' + + do i=1, N + do j=1, N + if (abs(t2(j,i)) > 1e-10_dp) then + print '(I0," ",4F30.20)', i, evals(i), t1(j,i), t2(j,i), t1(j,i)/t2(j,i) + else + print '(I0," ",3F30.20, "-")', i, evals(i), t1(j,i), t2(j,i) + endif + end do + end do + + end subroutine test_eigensys + + + ! calculate inverse, if the matrix is symmetric uses a quicker way, otherways a more general + ! if inverse is missing, do in-place + subroutine matrix_inverse(matrix,inverse,positive_in) + real(dp),intent(in), dimension(:,:), target::matrix + real(dp),intent(out), dimension(:,:), optional, target::inverse + logical,optional::positive_in + + integer::N,INFO,i,j,LWORK + integer,allocatable::IPIV(:) + real(dp),allocatable::WORK(:) + logical::positive + !IMPROVE real(dp), allocatable :: u_lu(:,:), b(:,:), ferr(:), berr(:) + !IMPROVE integer, allocatable :: iwork(:) + + real(dp), pointer :: u_inverse(:,:) + + if (present(inverse)) then + u_inverse => inverse + else + u_inverse => matrix + endif + + if (present(positive_in)) then + positive = positive_in + else + positive = .true. + end if + + call check_size('Inverse',u_inverse,shape(matrix),'Matrix_Inverse') + + N = size(matrix,2) + + if (present(inverse)) u_inverse = matrix + + ! try the symmetric, positive definite case + + if( matrix_is_symmetric(matrix) .and. positive) then + + ! cholesky + + ! this only works for positive definite + call DPOTRF('U', N, u_inverse, N, INFO) + + if(INFO > 0) then + write (line,'(a)') 'Matrix_Inverse: Matrix is not positive definite, switching to general case inversion!' + call print(line) + + ! we branch to the general case below + else + if (INFO < 0) then + write(line,'(a,i0,a)')'Matrix_Inverse: Error in calling DPOTRF (',info,')' + call system_abort(line) + end if + ! now do the inverse + ! again, this call is only for positive definite, but now we should be + call DPOTRI('U', N, u_inverse, N, INFO) + if (INFO /= 0) then + write(line,'(a,i0,a)')'Matrix_Inverse: Error in calling DPOTRI (',info,')' + call system_abort(line) + end if + ! filling the lower part of symmetric matrix + do i=1,N + do j=i+1,N + u_inverse(j,i) = u_inverse(i,j) + enddo + enddo + return + end if + end if + + ! do the general case + + LWORK = 3*N + allocate(WORK(LWORK)) + allocate(IPIV(N)) + + ! LU factorization + + call DGETRF(N, N, u_inverse, N, IPIV, info) + if (INFO /= 0) call system_abort('Error in calling DGETRF (info = '//info//')') + + !IMPROVE allocate(u_lu(N,N)) + !IMPROVE u_lu = u_inverse + + !inverse + + call DGETRI(N, u_inverse, N, IPIV, WORK, LWORK, info) + if (INFO /= 0) call system_abort('Error in calling DGETRI (info = '//info//')') + + !IMPROVE deallocate(WORK) + !IMPROVE allocate(b(N,N),ferr(N),berr(N),WORK(3*N),iwork(N)) + !IMPROVE b = 0.0_dp + !IMPROVE call add_identity(b) + !IMPROVE call dgerfs('N',N,N,matrix,N,u_lu,N,ipiv,b,N,u_inverse,N,ferr,berr,WORK,iwork,info) + + deallocate(WORK,IPIV) + + end subroutine matrix_inverse + + ! calculate inverse, if the matrix is symmetric uses a quicker way, otherways a more general + ! if inverse is missing, do in-place + subroutine matrix_z_inverse(matrix,inverse,positive_in) + complex(dp),intent(in), dimension(:,:), target::matrix + complex(dp),intent(out), dimension(:,:), optional, target::inverse + logical,optional::positive_in + + integer::N,INFO,i,j,LWORK + integer,allocatable::IPIV(:) + complex(dp),allocatable::WORK(:) + logical::positive + + complex(dp), pointer :: u_inverse(:,:) + + if (present(inverse)) then + u_inverse => inverse + u_inverse = matrix + else + u_inverse => matrix + endif + + if (present(positive_in)) then + positive = positive_in + else + positive = .true. + end if + + call check_size('Inverse',u_inverse,shape(matrix),'Matrix_Inverse') + + N = size(matrix,2) + + if (matrix_z_is_hermitian(matrix)) then + + + if (positive) then + + ! cholesky + + ! this only works for hermitian positive definite + call ZPOTRF('U', N, u_inverse, N, INFO) + + if(INFO > 0) then + write (line,'(a)') 'Matrix_Inverse: Matrix is not positive definite, switching to general case inversion!' + call print(line) + ! we branch to the general case below + else + if (INFO < 0) then + write(line,'(a,i0,a)')'Matrix_Inverse: Error in calling ZPOTRF (',info,')' + call system_abort(line) + end if + ! now do the inverse + ! again, this call is only for positive definite, but now we should be + call ZPOTRI('U', N, u_inverse, N, INFO) + if (INFO /= 0) then + write(line,'(a,i0,a)')'Matrix_Inverse: Error in calling ZPOTRI (',info,')' + call system_abort(line) + end if + ! filling the lower part of hermitian matrix + do i=1,N + do j=i+1,N + u_inverse(j,i) = conjg(u_inverse(i,j)) + enddo + enddo + return + end if ! zpotrf INFO > 0 + + endif ! positive + + lwork = 16*N + allocate(work(lwork)) + allocate(ipiv(N)) + + ! Bunch-Kaufman factorization + call ZHETRF('U', N, u_inverse, N, ipiv, work, lwork, info) + if (INFO /= 0) call system_abort('Error in calling ZHETRF (info = '//info//')') + + ! inverse + call ZHETRI('U', N, u_inverse, N, ipiv, work, info) + if (INFO /= 0) call system_abort('Error in calling ZHETRI (info = '//info//')') + + ! filling the lower part of hermitian matrix + do i=1,N + do j=i+1,N + u_inverse(j,i) = conjg(u_inverse(i,j)) + enddo + enddo + + deallocate(work,ipiv) + return + else if (matrix_z_is_symmetric(matrix)) then + lwork = 16*N + allocate(work(lwork)) + allocate(ipiv(N)) + + ! LU factorization + call ZSYTRF('U', N, u_inverse, N, ipiv, work, lwork, info) + if (INFO /= 0) call system_abort('Error in calling ZSYTRF (info = '//info//')') + + ! inverse + call ZSYTRI('U', N, u_inverse, N, ipiv, work, info) + if (INFO /= 0) call system_abort('Error in calling ZSYTRI (info = '//info//')') + + ! filling the lower part of symmetric matrix + do i=1,N + do j=i+1,N + u_inverse(j,i) = u_inverse(i,j) + enddo + enddo + + deallocate(work, ipiv) + return + end if ! matrix is hermitian + + ! do the general case + + LWORK = 16*N + allocate(WORK(LWORK)) + allocate(IPIV(N)) + + ! LU factorization + call ZGETRF(N, N, u_inverse, N, IPIV, info) + if (INFO /= 0) call system_abort('Error in calling ZGETRF (info = '//info//')') + + !inverse + call ZGETRI(N, u_inverse, N, IPIV, WORK, LWORK, info) + if (INFO /= 0) call system_abort('Error in calling ZGETRI (info = '//info//')') + + deallocate(WORK,IPIV) + return + + end subroutine matrix_z_inverse + + subroutine pseudo_inverse(this,inverse,error) + real(dp),intent(in), dimension(:,:) :: this + real(dp),intent(out), dimension(:,:) :: inverse + integer, optional, intent(out) :: error + + type(LA_Matrix) :: LA_this + + INIT_ERROR(error) + + call initialise(LA_this,this) + call LA_Matrix_PseudoInverse(LA_this,inverse,error=error) + call finalise(LA_this) + + endsubroutine pseudo_inverse + + ! Cholesky factorisation of a symmetric matrix. + ! Various checks (size, symmetricity etc.) might be useful later. + subroutine LA_Matrix_Initialise(this,matrix,use_allocate) + + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(in), target :: matrix + logical, intent(in), optional :: use_allocate + + if(this%initialised) call finalise(this) + + this%use_allocate = optional_default(.true., use_allocate) + + this%n = size(matrix,1) + this%m = size(matrix,2) + + if (this%use_allocate) then + allocate(this%matrix(this%n,this%m)) + this%matrix = matrix + else + this%matrix => matrix + end if + + allocate(this%factor(this%n,this%m), this%s(this%n), this%tau(this%m)) + this%initialised = .true. + + endsubroutine LA_Matrix_Initialise + + subroutine LA_Matrix_Initialise_Matrix(this,matrix) + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(in) :: matrix + call Initialise(this,matrix) + endsubroutine LA_Matrix_Initialise_Matrix + + subroutine LA_Matrix_Initialise_Copy(this, from) + + type(LA_Matrix), intent(inout) :: this + type(LA_Matrix), intent(in) :: from + + if(this%initialised) call finalise(this) + + this%use_allocate = .true. + if (associated(from%matrix)) then + allocate(this%matrix(size(from%matrix,1), size(from%matrix,2))) + this%matrix = from%matrix + end if + if (allocated(from%factor)) then + allocate(this%factor(size(from%factor,1), size(from%factor,2))) + this%factor = from%factor + end if + if (allocated(from%s)) then + allocate(this%s(size(from%s))) + this%s = from%s + end if + if (allocated(from%tau)) then + allocate(this%tau(size(from%tau))) + this%tau = from%tau + end if + this%n = from%n + this%m = from%m + this%initialised = from%initialised + this%equilibrated = from%equilibrated + this%factorised = from%factorised + + endsubroutine LA_Matrix_Initialise_Copy + + subroutine LA_Matrix_Update(this,matrix) + + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(in) :: matrix + + integer :: factorised + + factorised = this%factorised + + if(this%initialised) then + if( all(shape(matrix) == (/this%n,this%m/)) ) then + this%matrix = matrix + else + call initialise(this,matrix) + endif + else + call initialise(this,matrix) + endif + + select case(factorised) + case(CHOLESKY) + call LA_Matrix_Factorise(this) + case(QR) + call LA_Matrix_QR_Factorise(this) + endselect + + endsubroutine LA_Matrix_Update + + subroutine LA_Matrix_Finalise(this) + + type(LA_Matrix), intent(inout) :: this + + if(.not. this%initialised) return + + this%n = 0 + this%m = 0 + if(this%use_allocate .and. associated(this%matrix)) deallocate(this%matrix) + this%matrix => null() + if(allocated(this%factor) ) deallocate(this%factor) + if(allocated(this%s) ) deallocate(this%s) + if(allocated(this%tau) ) deallocate(this%tau) + this%initialised = .false. + this%equilibrated = .false. + this%factorised = NOT_FACTORISED + + endsubroutine LA_Matrix_Finalise + + subroutine LA_Matrix_Factorise(this,factor,error) + + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(out), optional :: factor + integer, optional, intent(out) :: error + + integer :: i, j, info + real(dp) :: scond, amax + + INIT_ERROR(error) + + if(.not. this%initialised) then + RAISE_ERROR('LA_Matrix_Factorise: object not initialised',error) + endif + + if( this%n /= this%m ) then + RAISE_ERROR('LA_Matrix_Factorise: matrix not square',error) + endif + + this%s = 1.0_qp + + do i = 1, this%n + this%s(i) = 1.0_qp / sqrt(this%matrix(i,i)) + enddo + scond = maxval(this%s) / minval(this%s) + amax = maxval(this%matrix) + + this%equilibrated = ( scond < 0.1_qp ) + + if( this%equilibrated ) then + do i = 1, this%n + this%factor(:,i) = this%matrix(:,i)*this%s(:)*this%s(i) + enddo + else + this%factor = this%matrix + endif + +#if defined(HAVE_QP) || defined(ALBERT_LAPACK) + call qpotrf(this%factor,info) +#else + call dpotrf('L', this%n, this%factor, this%n, info) + do i = 2, this%n + do j = 1, i + this%factor(j,i) = this%factor(i,j) + enddo + enddo +#endif + + if( info /= 0 ) then + RAISE_ERROR('LA_Matrix_Factorise: cannot factorise, error: '//info, error) + endif + + if( present(factor) ) then + if( this%equilibrated ) then + factor = 0.0_qp + do i = 1, this%n + do j = 1, this%n + factor(j,i) = this%factor(j,i) / this%s(i) + enddo + enddo + else + factor = this%factor + endif + endif + + this%factorised = CHOLESKY + + endsubroutine LA_Matrix_Factorise + + subroutine qpotrf(this,info) + real(qp), dimension(:,:), intent(inout) :: this + integer, intent(out), optional :: info + real(qp), dimension(:), allocatable :: v, w + + integer :: i, j, k, p, mu, n +#ifdef _OPENMP + integer, external :: omp_get_num_threads, omp_get_thread_num +#endif + + n = size(this,1) + + if(present(info)) info = 0 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! another implementation +! this(:,1) = this(:,1) / sqrt(this(1,1)) +! do j = 2, n +! this(j:n,j) = this(j:n,j) - matmul( this(j:n,1:j-1), this(j,1:j-1) ) +! if(this(j,j)<0.0_qp) then +! if(present(info)) then +! info = j +! return +! else +! call system_abort('my_potrf: trouble') +! endif +! endif +! this(j:n,j) = this(j:n,j)/sqrt(this(j,j)) +! enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + p = 1 + mu = 1 + +!$omp parallel private(mu,v,w) shared(info) +!$ p=omp_get_num_threads() +!$ mu=omp_get_thread_num()+1 + allocate(v(n),w(n)) + do k = 1, n + if( mu == 1 ) then + v(k:n) = this(k:n,k) + if(v(k)<0.0_qp) then + if(present(info)) then + info = k +! return + else + call system_abort('my_potrf: trouble') + endif + endif + v(k:n) = v(k:n) / sqrt(v(k)) + this(k:n,k) = v(k:n) + endif +!$omp barrier + v(k+1:n) = this(k+1:n,k) + do j = k+mu,n,p + w(j:n) = this(j:n,j) + w(j:n) = w(j:n) - v(j)*v(j:n) + this(j:n,j) = w(j:n) + enddo +!$omp barrier + enddo + deallocate(v,w) +!$omp end parallel + + do i = 2, n + do j = 1, i + this(j,i) = this(i,j) + enddo + enddo + + endsubroutine qpotrf + + subroutine LA_Matrix_Inverse(this,inverse,error) + + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(out) :: inverse + integer, optional, intent(out) :: error + + integer :: i, j, info + + INIT_ERROR(error) + + if( this%factorised == NOT_FACTORISED ) then + call LA_Matrix_Factorise(this, error=error) + elseif( this%factorised /= CHOLESKY ) then + RAISE_ERROR('LA_Matrix_Inverse: matrix not Cholesky-factorised',error) + endif + + call check_size('inverse',inverse,shape(this%factor),'LA_Matrix_Inverse',error=error) + PASS_ERROR(error) + + inverse = this%factor + +#if defined(HAVE_QP) || defined(ALBERT_LAPACK) + call qpotri(inverse,info) +#else + call dpotri('U', this%n, inverse, this%n, info) +#endif + + if( info /= 0 ) then + RAISE_ERROR('LA_Matrix_Inverse: cannot invert, error: '//info, error) + endif + + do i = 1, this%n + do j = i+1, this%n + inverse(j,i) = inverse(i,j) + enddo + enddo + + if(this%equilibrated) then + do i = 1, this%n + inverse(:,i) = inverse(:,i)*this%s(:)*this%s(i) + enddo + endif + + endsubroutine LA_Matrix_Inverse + + subroutine qpotri(this,info) + + real(qp), dimension(:,:), intent(inout) :: this + integer, optional, intent(out) :: info + + real(qp), dimension(:,:), allocatable :: one + integer :: i, n + + n = size(this,1) + allocate(one(n,n)) + one = 0.0_qp + do i = 1, n + one(i,i) = 1.0_qp + enddo + call qpotrs(this,one) + this = one + deallocate(one) + + if(present(info)) info = 0 + + endsubroutine qpotri + + subroutine LA_Matrix_Solve_Vector(this,b,x,refine,error) + + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:), intent(in) :: b + real(qp), dimension(:), intent(out) :: x + logical, intent(in), optional :: refine + integer, intent(out), optional :: error + + real(qp), dimension(:,:), allocatable :: my_x + + INIT_ERROR(error) + + if( (size(b) /= this%n) .or. (size(x) /= this%n) ) then + RAISE_ERROR('LA_Matrix_Solve_Vector: length of b or x is not n',error) + endif + + allocate(my_x(this%n,1)) + call LA_Matrix_Solve_Matrix(this,reshape(b,(/this%n,1/)),my_x,refine,error) + x = my_x(:,1) + deallocate(my_x) + + endsubroutine LA_Matrix_Solve_Vector + + subroutine LA_Matrix_Solve_Matrix(this,b,x,refine,error) + + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(in) :: b + real(qp), dimension(:,:), intent(out) :: x + logical, intent(in), optional :: refine + integer, intent(out), optional :: error + + real(qp), dimension(:,:), allocatable :: my_b, my_x + integer :: i, m, info + + logical :: my_refine + + INIT_ERROR(error) + + if( size(b,1) /= this%n ) then + RAISE_ERROR('LA_Matrix_Solve_Matrix: first dimension of b is not n',error) + endif + + my_refine = optional_default(.false.,refine) + + if( this%factorised == NOT_FACTORISED ) then + call LA_Matrix_Factorise(this,error=error) + elseif( this%factorised /= CHOLESKY ) then + call system_abort('LA_Matrix_Solve_Matrix: matrix not Cholesky-factorised') + endif + + m = size(b,2) + allocate(my_b(this%n,m),my_x(this%n,m)) !, work(3*this%n),iwork(this%n),ferr(m), berr(m)) + + if( this%equilibrated ) then + do i = 1, m + my_x(:,i) = b(:,i)*this%s + enddo + my_b = my_x + else + my_x = b + my_b = my_x + endif + +#if defined(HAVE_QP) || defined(ALBERT_LAPACK) + call qpotrs( this%factor, my_x, info ) +#else + call dpotrs( 'U', this%n, m, this%factor, this%n, my_x, this%n, info ) +#endif + + if( this%equilibrated ) then + do i = 1, m + x(:,i) = my_x(:,i)*this%s + enddo + else + x = my_x + endif + + if( info /= 0 ) then + RAISE_ERROR('LA_Matrix_Solve_Matrix: cannot solve, error: '//info, error) + endif + deallocate(my_x,my_b) + + endsubroutine LA_Matrix_Solve_Matrix + + subroutine LA_Matrix_Expand_Symmetrically(this,vector,error) + + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:), intent(in) :: vector + integer, intent(out), optional :: error + + integer :: n, tmp_factorised, info + real(qp) :: scond, u2 + real(qp), dimension(:,:) , allocatable :: tmp_matrix, tmp_factor + real(qp), dimension(:) , allocatable :: tmp_s + + logical :: tmp_equilibrated + + INIT_ERROR(error) + + if( this%n /= this%m ) then + RAISE_ERROR('LA_Matrix_Expand_Symmetrically: matrix not square',error) + endif + + n = size(vector) + if( n /= this%n + 1 ) then + RAISE_ERROR('LA_Matrix_Expand_Symmetrically: expanding vector should be longer by 1 than matrix dimensionality',error) + endif + + allocate(tmp_matrix(this%n+1,this%n+1)) + tmp_matrix(1:this%n,1:this%n) = this%matrix + tmp_matrix(this%n+1,:) = vector + tmp_matrix(:,this%n+1) = vector + + if(this%factorised == CHOLESKY) then + allocate(tmp_factor(this%n,this%n), tmp_s(this%n)) + tmp_factor = this%factor + tmp_s = this%s + endif + + tmp_equilibrated = this%equilibrated + tmp_factorised = this%factorised + + call finalise(this) + + call initialise(this,tmp_matrix) + this%equilibrated = tmp_equilibrated + this%factorised = tmp_factorised + + select case(this%factorised) + case(CHOLESKY) + this%s(1:this%n-1) = tmp_s + this%s(this%n) = 1.0_qp / sqrt(this%matrix(this%n,this%n)) + scond = maxval(this%s) / minval(this%s) + if( this%equilibrated .or. ( scond < 0.1_qp ) ) then + call LA_Matrix_Factorise(this) + else + this%factor(1:this%n-1,1:this%n-1) = tmp_factor + this%factor(1:this%n-1,this%n) = vector(1:this%n-1) + call dtrtrs('L','N','N',this%n-1,1,tmp_factor,this%n-1,this%factor(1:this%n-1,this%n:this%n),this%n-1,info) + if( info /=0 ) then + RAISE_ERROR('LA_Matrix_Expand_Symmetrically: dtrtrs returned an error:'//info,error) + endif + u2 = this%matrix(this%n,this%n) - dot_product(this%factor(1:this%n-1,this%n),this%factor(1:this%n-1,this%n)) + if( u2 < 0.0_qp ) then + RAISE_ERROR('LA_Matrix_Expand_Symmetrically: expanded matrix no longer positive definite',error) + endif + this%factor(this%n,1:this%n-1) = this%factor(1:this%n-1,this%n) + this%factor(this%n,this%n) = sqrt(u2) + endif + case(QR) + call LA_Matrix_QR_Factorise(this) + endselect + + if(allocated(tmp_matrix)) deallocate(tmp_matrix) + if(allocated(tmp_factor)) deallocate(tmp_factor) + if(allocated(tmp_s)) deallocate(tmp_s) + + endsubroutine LA_Matrix_Expand_Symmetrically + + subroutine qpotrs(factor,x, info) + real(qp), dimension(:,:), intent(in) ::factor + real(qp), dimension(:,:), intent(inout) :: x + integer, intent(out), optional :: info + + integer :: n, m, i, j + + n = size(factor,1) + m = size(x,2) +!$omp parallel do + do i = 1, m + do j = 1, n-1 + x(j,i) = x(j,i)/factor(j,j) + x(j+1:n,i) = x(j+1:n,i) - x(j,i)*factor(j+1:n,j) + enddo + x(n,i) = x(n,i)/factor(n,n) + + do j = n, 2, -1 + x(j,i) = x(j,i)/factor(j,j) + x(1:j-1,i) = x(1:j-1,i) - x(j,i)*factor(1:j-1,j) + enddo + x(1,i) = x(1,i)/factor(1,1) + enddo + + if( present(info) ) info = 0 + + endsubroutine qpotrs + + function LA_Matrix_LogDet(this,error) + + type(LA_Matrix), intent(inout) :: this + integer, intent(out), optional :: error + real(qp) :: LA_Matrix_LogDet + integer :: i + + INIT_ERROR(error) + + if( this%factorised == NOT_FACTORISED ) then + call LA_Matrix_Factorise(this,error=error) + endif + + LA_Matrix_LogDet = 0.0_qp + do i = 1, this%m + LA_Matrix_LogDet = LA_Matrix_LogDet + log(abs(this%factor(i,i))) + enddo + + if(this%equilibrated) LA_Matrix_LogDet = LA_Matrix_LogDet - sum( log(this%s) ) + + if( this%factorised == CHOLESKY ) then + LA_Matrix_LogDet = LA_Matrix_LogDet*2 + elseif( this%factorised == QR ) then + LA_Matrix_LogDet = LA_Matrix_LogDet*1 + else + RAISE_ERROR('LA_Matrix_LogDet: matrix not Cholesky-factorised or QR-factorised',error) + endif + + endfunction LA_Matrix_LogDet + + function LA_Matrix_Det(this,error) + + type(LA_Matrix), intent(inout) :: this + integer, intent(out), optional :: error + real(qp) :: LA_Matrix_Det + integer :: i + + INIT_ERROR(error) + + if( this%factorised == NOT_FACTORISED ) then + call LA_Matrix_Factorise(this,error=error) + endif + + LA_Matrix_Det = 1.0_qp + do i = 1, this%n + LA_Matrix_Det = LA_Matrix_Det * this%factor(i,i) + enddo + + if(this%equilibrated) LA_Matrix_Det = LA_Matrix_Det / product( this%s ) + + if( this%factorised == CHOLESKY ) then + LA_Matrix_Det = LA_Matrix_Det**2 + elseif( this%factorised == QR ) then + LA_Matrix_Det = LA_Matrix_Det*1 + else + RAISE_ERROR('LA_Matrix_LogDet: matrix not Cholesky-factorised or QR-factorised',error) + endif + + endfunction LA_Matrix_Det + + subroutine LA_Matrix_QR_Factorise(this,q,r,error) + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(out), optional :: q, r + integer, intent(out), optional :: error + + integer :: info +#ifndef HAVE_QP + real(dp), dimension(:), allocatable :: work + integer :: lwork +#endif + + INIT_ERROR(error) + + this%factor = this%matrix + +#if defined(HAVE_QP) || defined(ALBERT_LAPACK) + call qgeqrf(this%factor,this%tau,info) +#else + + allocate(work(1)) + lwork = -1 + call dgeqrf(this%n, this%m, this%factor, this%n, this%tau, work, lwork, info) + lwork = nint(work(1)) + deallocate(work) + + allocate(work(lwork)) + call dgeqrf(this%n, this%m, this%factor, this%n, this%tau, work, lwork, info) + deallocate(work) +#endif + + if( info /= 0 ) then + RAISE_ERROR('LA_Matrix_QR_Factorise: '//(-info)//'-th parameter had an illegal value.',error) + endif + + this%factorised = QR + + if( present(q) .or. present(r) ) call LA_Matrix_GetQR(this,q,r,error) + + endsubroutine LA_Matrix_QR_Factorise + + subroutine LA_Matrix_GetQR(this,q,r,error) + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(out), optional :: q, r + integer, intent(out), optional :: error + + integer :: j, info +#ifndef HAVE_QP + real(dp), dimension(:), allocatable :: work + integer :: lwork +#endif + + INIT_ERROR(error) + + if( this%factorised /= QR ) then + RAISE_ERROR('LA_Matrix_GetQR: not QR-factorised, call LA_Matrix_QR_Factorise first.',error) + endif + + if(present(q)) then + call check_size('q', q, (/this%n,this%m/),'LA_Matrix_GetQR',error) + q = this%factor + +#if defined(HAVE_QP) || defined(ALBERT_LAPACK) + call qorgqr(this%factor,this%tau,q,info) +#else + allocate(work(1)) + lwork = -1 + call dorgqr(this%n, this%m, this%m, q, this%n, this%tau, work, lwork, info) + lwork = nint(work(1)) + deallocate(work) + + allocate(work(lwork)) + call dorgqr(this%n, this%m, this%m, q, this%n, this%tau, work, lwork, info) + deallocate(work) +#endif + endif + + if(present(r)) then + call check_size('r', r, (/this%m,this%m/),'LA_Matrix_GetQR',error) + r = this%factor(1:this%m,1:this%m) + do j = 1, this%m - 1 + r(j+1:this%m,j) = 0.0_dp + enddo + endif + + if( info /= 0 ) then + RAISE_ERROR('LA_Matrix_QR_Factorise: '//(info)//'-th parameter had an illegal value.',error) + endif + + endsubroutine LA_Matrix_GetQR + + subroutine Fixed_LA_Matrix_QR_Solve_Vector(factor, tau, vector, vec_result) + !supply factor and tau from QR factorisation only + real(dp), dimension(:), intent(in) :: vector + real(dp), dimension(:), intent(out) :: vec_result + real(dp), dimension(:, :), intent(in) :: factor + real(dp), dimension(:), intent(in) :: tau + + integer :: n, m, o, lwork, info, i, j + real(dp), dimension(:), allocatable :: work + real(dp), dimension(:, :), allocatable :: matrix, my_result + !real(dp) :: start, mid, end + + !reshape vector into matrix + n = size(vector) + allocate(matrix(n, 1)) + matrix = reshape(vector,(/n,1/)) + + ! sizes, n is already set + o = 1 + m = size(factor, 2) + + allocate(my_result(n, o)) + my_result = matrix + + ! start = factor(1,1) + + ! copied this directly from LA_Matrix_QR_Solve_Matrix in linearalgebra + lwork = -1 + allocate(work(1)) + call dormqr('L', 'T', n, o, m, factor, n, tau, my_result, n, work, lwork, info) + lwork = nint(work(1)) + deallocate(work) + + !mid = factor(1,1) + + allocate(work(lwork)) + call dormqr('L', 'T', n, o, m, factor, n, tau, my_result, n, work, lwork, info) + deallocate(work) + + !end = factor(1,1) + !print*, "jpd47 in fixed", start, mid, end + ! NOTE WARNING TODO with OMP_NUM_THREADS > 1 factor gets modified between start and end + ! dormqr documentation says that "A is modified by the routine but restored on exit." (A=factor) + + if( info /= 0 ) then + print*, "paramater", info, "had an illegal value" + endif + + do i = 1, o + do j = m, 2, -1 + my_result(j,i) = my_result(j,i)/factor(j,j) + my_result(1:j-1,i) = my_result(1:j-1,i) - my_result(j,i)*factor(1:j-1,j) + enddo + my_result(1,i) = my_result(1,i) / factor(1,1) + enddo + + !result = my_result(1:m,:) + vec_result = my_result(1:m, 1) + deallocate(my_result) + deallocate(matrix) +endsubroutine + + subroutine LA_Matrix_QR_Solve_Matrix(this,matrix,result,error) + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:,:), intent(in) :: matrix + real(qp), dimension(:,:), intent(out) :: result + integer, intent(out), optional :: error + + real(qp), dimension(:,:), allocatable :: my_result + integer :: info, i, j, n, o +#ifndef HAVE_QP + real(dp), dimension(:), allocatable :: work + integer :: lwork +#endif + + INIT_ERROR(error) + + if(this%factorised == NOT_FACTORISED) then + call LA_Matrix_QR_Factorise(this,error=error) + elseif(this%factorised /= QR) then + RAISE_ERROR('LA_Matrix_QR_Solve_Matrix: matrix not QR-factorised',error) + endif + + n = size(matrix,1) + o = size(matrix,2) + call check_size('result', result, (/this%m,o/),'LA_Matrix_QR_Solve_Matrix',error) + + if( n /= this%n ) then + RAISE_ERROR('LA_Matrix_QR_Solve_Matrix: dimensions of Q and matrix do not match.',error) + endif + + allocate(my_result(n,o)) + my_result = matrix +#if defined(HAVE_QP) || defined(ALBERT_LAPACK) + call qormqr(this%factor, this%tau, my_result, info) +#else + lwork = -1 + allocate(work(1)) + call dormqr('L', 'T', this%n, o, this%m, this%factor, this%n, this%tau, my_result, this%n, work, lwork, info) + lwork = nint(work(1)) + deallocate(work) + + allocate(work(lwork)) + call dormqr('L', 'T', this%n, o, this%m, this%factor, this%n, this%tau, my_result, this%n, work, lwork, info) + deallocate(work) +#endif + + if( info /= 0 ) then + RAISE_ERROR('LA_Matrix_QR_QR_Solve_Matrix: '//(-info)//'-th parameter had an illegal value.',error) + endif + + do i = 1, o + do j = this%m, 2, -1 + my_result(j,i) = my_result(j,i)/this%factor(j,j) + my_result(1:j-1,i) = my_result(1:j-1,i) - my_result(j,i)*this%factor(1:j-1,j) + enddo + my_result(1,i) = my_result(1,i) / this%factor(1,1) + enddo + + result = my_result(1:this%m,:) + deallocate(my_result) + + endsubroutine LA_Matrix_QR_Solve_Matrix + + subroutine LA_Matrix_QR_Solve_Vector(this,vector,result,error) + type(LA_Matrix), intent(inout) :: this + real(qp), dimension(:), intent(in) :: vector + real(qp), dimension(:), intent(out) :: result + integer, intent(out), optional :: error + + real(qp), dimension(:,:), allocatable :: my_result + integer :: n, m + + INIT_ERROR(error) + + n = size(vector) + m = size(result) + + allocate(my_result(m,1)) + + call LA_Matrix_QR_Solve_Matrix(this,reshape(vector,(/n,1/)),my_result,error=error) + result = my_result(:,1) + + deallocate(my_result) + + endsubroutine LA_Matrix_QR_Solve_Vector + + subroutine LA_Matrix_QR_Inverse(this,inverse,error) + type(LA_Matrix), intent(inout) :: this + real(dp), dimension(:,:), intent(out) :: inverse + integer, optional, intent(out) :: error + + real(dp), allocatable, dimension(:,:) :: Q, R, R_inv, Q_T + integer i,j,k + + INIT_ERROR(error) + + if (this%n /= this%m) then + RAISE_ERROR('LA_Matrix_QR_inverse: cannot invert non-square matrix',error) + endif + + call check_size('inverse',inverse,shape(this%factor),'LA_Matrix_QR_Inverse',error=error) + PASS_ERROR(error) + + allocate(Q(this%n, this%n), R(this%n, this%n), R_inv(this%n, this%n), Q_T(this%n, this%n)) + + if( this%factorised == NOT_FACTORISED ) then + call LA_Matrix_QR_Factorise(this, error=error) + elseif( this%factorised /= QR ) then + RAISE_ERROR('LA_Matrix_QR_Inverse: matrix not QR-factorised',error) + endif + + call LA_Matrix_GetQR(this, Q, R) + + ! inversion of upper triangular matrix R via back-substitution + R_inv(:,:) = 0.0_dp + do j=1,this%n + do i=1,j-1 + do k=1,j-1 + R_inv(i,j) = R_inv(i,j) + R_inv(i,k)*R(k,j) + end do + end do + do k=1,j-1 + R_inv(k,j) = -R_inv(k,j)/R(j,j) + end do + R_inv(j,j) = 1.0_dp/R(j,j) + end do + + ! A^-1 = (QR)^-1 = R^-1 Q^-1 = R^-1 Q^T + Q_T = transpose(Q) + inverse = matmul(R_inv, Q_T) + + deallocate(Q, R, R_inv, Q_T) + + end subroutine LA_Matrix_QR_inverse + + subroutine LA_Matrix_SVD_Allocate(this,s,u,v,error) + + type(LA_Matrix), intent(in) :: this + real(dp), dimension(:), allocatable, intent(inout), optional :: s + real(dp), dimension(:,:), allocatable, intent(inout), optional :: u, v + integer, optional, intent(out) :: error + + INIT_ERROR(error) + + if(.not.this%initialised) then + RAISE_ERROR('LA_Matrix_SVD: not initialised',error) + endif + + if(present(s)) then + if(allocated(s)) deallocate(s) + allocate(s(min(this%n,this%m))) + endif + + if(present(u)) then + if(allocated(u)) deallocate(u) + if(this%n <= this%m) then + allocate(u(this%n,this%n)) + else + allocate(u(this%n,this%m)) + endif + endif + + if(present(v)) then + if(allocated(v)) deallocate(v) + if(this%n <= this%m) then + allocate(v(this%m,this%n)) + else + allocate(v(this%m,this%m)) + endif + endif + + endsubroutine LA_Matrix_SVD_Allocate + + subroutine LA_Matrix_SVD(this,s,u,v,error) + + type(LA_Matrix), intent(in) :: this + real(dp), dimension(:), intent(out), target, optional :: s + real(dp), dimension(:,:), intent(out), target, optional :: u, v + integer, optional, intent(out) :: error + + real(dp), dimension(:,:), allocatable :: a + real(dp), dimension(:), allocatable :: work + real(dp), dimension(:), pointer :: my_s + real(dp), dimension(:,:), pointer :: my_u, my_vt + real(dp), dimension(1,1), target :: dummy_u, dummy_vt + real(dp) :: tmp + character(len=1) :: jobu, jobvt + integer :: lwork, info, i, j + integer(kind=8) :: lwork_min + + INIT_ERROR(error) + + if(.not.this%initialised) then + RAISE_ERROR('LA_Matrix_SVD: not initialised',error) + endif + + allocate(a(this%n,this%m)) + a = this%matrix + + if(present(s)) then + call check_size('s',s,min(this%n,this%m),'LA_Matrix_SVD',error=error) + my_s => s + else + allocate(my_s(min(this%n,this%m))) + endif + + if(present(u)) then + if(this%n <= this%m) then + call check_size('u',u,(/this%n,this%n/),'LA_Matrix_SVD',error=error) + jobu = "A" + my_u => u + else + call check_size('u',u,(/this%n,this%m/),'LA_Matrix_SVD',error=error) + jobu = "S" + my_u => u + endif + else + jobu = "N" + my_u => dummy_u + endif + + if(present(v)) then + if(this%n <= this%m) then + call check_size('v',v,(/this%m,this%n/),'LA_Matrix_SVD',error=error) + jobvt = "O" + my_vt => dummy_vt + else + call check_size('v',v,(/this%m,this%m/),'LA_Matrix_SVD',error=error) + jobvt = "A" + my_vt => v + endif + else + jobvt = "N" + my_vt => dummy_vt + endif + + allocate(work(1)) + lwork = -1 + call dgesvd(jobu, jobvt, this%n, this%m, a, this%n, my_s, my_u, this%n, my_vt, this%m, work, lwork, info) + if( work(1) > huge(lwork) ) then ! optimal size of work is a bit too large. + ! that's the minimum size of the work array + lwork_min = max( 3*min(this%m, this%n) + max(this%n,this%m), 5*min(this%m,this%n) ) + if( lwork_min > huge(lwork) ) then + RAISE_ERROR("LA_Matrix_SVD: temporary array for SVD would be too large.", error) + else + ! max out the work array + lwork = huge(lwork) + endif + else + ! otherwise just go with the optimum + lwork = ceiling(work(1)) + endif + + deallocate(work) + + allocate(work(lwork)) + call dgesvd(jobu, jobvt, this%n, this%m, a, this%n, my_s, my_u, this%n, my_vt, this%m, work, lwork, info) + deallocate(work) + + if( this%n <= this%m ) then + if(present(v)) then + do i = 1, this%n + do j = 1, this%m + v(j,i) = a(i,j) + enddo + enddo + endif + else + if(present(v)) then + do i = 1, this%m + do j = i+1, this%m + tmp = v(i,j) + v(i,j) = v(j,i) + v(j,i) = tmp + enddo + enddo + endif + endif + + if(allocated(a)) deallocate(a) + my_u => null() + my_vt => null() + + if(present(s)) then + my_s => null() + else + deallocate(my_s) + endif + + if(info < 0) then + RAISE_ERROR('LA_Matrix_SVD: '//(-info)//'-th parameter had an illegal value.',error) + elseif( info > 0) then + RAISE_ERROR('LA_Matrix_SVD: singular value decomposition of the bidiagonal matrix did not converge, '//info//' superdiagonals did not converge to zero.',error) + endif + + endsubroutine LA_Matrix_SVD + + subroutine LA_Matrix_PseudoInverse(this, inverse, error) + type(LA_Matrix), intent(in) :: this + real(dp), dimension(:,:), intent(out) :: inverse + integer, optional, intent(out) :: error + + real(dp), dimension(:), allocatable :: s + real(dp), dimension(:,:), allocatable :: u, v, inverse_tmp + + INIT_ERROR(error) + + if(.not.this%initialised) then + RAISE_ERROR('LA_Matrix_SVD: not initialised',error) + endif + + call check_size('inverse',inverse,(/this%m,this%n/),'LA_Matrix_PseudoInverse',error=error) + + call LA_Matrix_SVD_Allocate(this,s=s,u=u,v=v,error=error) + call LA_Matrix_SVD(this,s=s,u=u,v=v,error=error) + + where(abs(s) > TOL_SVD) + s = 1.0_dp / s + elsewhere + s = 0.0_dp + endwhere + + allocate(inverse_tmp(size(v,1),size(v,2))) + inverse_tmp = v .multd. s + inverse = inverse_tmp .mult. transpose(u) + deallocate(inverse_tmp) + + if(allocated(s)) deallocate(s) + if(allocated(u)) deallocate(u) + if(allocated(v)) deallocate(v) + + endsubroutine LA_Matrix_PseudoInverse + + subroutine house_qp(x,v,beta) + real(qp), dimension(:), intent(in) :: x + real(qp), dimension(size(x)), intent(out) :: v + real(qp), intent(out) :: beta + + integer :: n + real(qp) :: sigma, mu + + n = size(x) + sigma = dot_product(x(2:n),x(2:n)) + v = (/ 1.0_qp, x(2:n) /) + + if( sigma == 0.0_qp ) then + beta = 0.0_qp + else + mu = sqrt(x(1)**2+sigma) + if( x(1) <= 0.0_qp ) then + v(1) = x(1) - mu + else + v(1) = -sigma / (x(1)+mu) + endif + beta = 2.0_qp * v(1)**2 / (sigma + v(1)**2) + v = v / v(1) + endif + + endsubroutine house_qp + + subroutine qgeqrf(a,beta,info) + real(qp), dimension(:,:), intent(inout) :: a + real(qp), dimension(size(a,2)), intent(out) :: beta + integer, intent(out), optional :: info + + integer :: m, n, i, j + real(qp), dimension(:), allocatable :: v, vTa, beta_v + + m = size(a,1) + n = size(a,2) + + allocate(v(m), vTa(n), beta_v(m)) + + do j = 1, n + call house_qp(a(j:m,j),v(j:m),beta(j)) + vTa(j:n) = matmul(v(j:m),a(j:m,j:n)) + beta_v(j:m) = beta(j)*v(j:m) + + do i = j, n + a(j:m,i) = a(j:m,i) - beta_v(j:m)*vTa(i) + enddo + if (j < m) a(j+1:m,j) = v(j+1:m) + enddo + + if( present(info) ) info = 0 + deallocate(v, vTa, beta_v) + + endsubroutine qgeqrf + + subroutine qormqr(a, beta, c, info) + + real(qp), dimension(:,:), intent(in) :: a + real(qp), dimension(size(a,2)), intent(in) :: beta + real(qp), dimension(:,:), intent(inout) :: c + integer, intent(out), optional :: info + + integer :: m, n, q, i, j + real(qp), dimension(:), allocatable :: v, vTc, beta_v + + m = size(a,1) + n = size(a,2) + q = size(c,2) + + allocate(v(m), vTc(q), beta_v(m)) + + do j = 1, n + v(j:m) = (/ 1.0_qp, a(j+1:m,j) /) + vTc = matmul(v(j:m),c(j:m,:)) + beta_v(j:m) = beta(j)*v(j:m) + + do i = 1, q + c(j:m,i) = c(j:m,i) - beta_v(j:m)*vTc(i) + enddo + enddo + + if( present(info) ) info = 0 + deallocate(v, vTc, beta_v) + + endsubroutine qormqr + + subroutine qorgqr(a,beta,q,info) + + real(qp), dimension(:,:), intent(in) :: a + real(qp), dimension(size(a,2)), intent(in) :: beta + real(qp), dimension(:,:), intent(out) :: q + integer, intent(out), optional :: info + + integer :: m, n, i, j + real(qp), dimension(:), allocatable :: v, vTq, beta_v + + m = size(a,1) + n = size(a,2) + + allocate(v(m), vTq(n), beta_v(m)) + + q = 0.0_qp + do j = 1, n + q(j,j) = 1.0_qp + enddo + + do j = n, 1, -1 + v(j:m) = (/1.0_qp, a(j+1:m,j) /) + vTq(j:n) = matmul(v(j:m), q(j:m,j:n)) + beta_v(j:m) = beta(j)*v(j:m) + + do i = j, n + q(j:m,i) = q(j:m,i) - beta_v(j:m)*vTq(i) + enddo + enddo + + if( present(info) ) info = 0 + deallocate(v, vTq, beta_v) + + endsubroutine qorgqr + + subroutine Matrix_CholFactorise(A,A_factor) + + real(dp), dimension(:,:), intent(inout), target :: A + real(dp), dimension(:,:), intent(out), target, optional :: A_factor + + real(dp), dimension(:,:), pointer :: my_A_factor + integer :: i, j, n, info + + if( .not. is_square(A) ) call system_abort('Matrix_CholFactorise: A is not square') + if( present(A_factor) ) call check_size('A_factor',A_factor,shape(A), 'Matrix_CholFactorise') + + n = size(A,1) + + if( present(A_factor) ) then + my_A_factor => A_factor + my_A_factor = A + else + my_A_factor => A + endif + + call dpotrf('U', n, my_A_factor, n, info) + + if( info /= 0 ) call system_abort('Matrix_CholFactorise: cannot factorise, PRINT_ALWAYS: '//info) + + do i = 1, n + do j = i+1, n + my_A_factor(j,i) = 0.0_dp + enddo + enddo + + my_A_factor => null() + + endsubroutine Matrix_CholFactorise + + ! Solve system of linear equations with an already Cholesky-factorised matrix. + subroutine Matrix_BackSubstitute(U,x,b) + + real(dp), dimension(:,:), intent(in) :: U + real(dp), dimension(:), intent(out) :: x + real(dp), dimension(:), intent(in) :: b + + integer :: n, info + + n = size(U,1) + + x = b + + call dpotrs('U', n, 1, U, n, x, n, info) + + if( info /= 0 ) call system_abort('Matrix_BackSubstitute: cannot solve system') + + endsubroutine Matrix_BackSubstitute + + ! Solve system of linear equations with an upper triagonal matrix. + subroutine Matrix_Solve_Upper_Triangular(U,x,b) + + real(dp), dimension(:,:), intent(in) :: U + real(dp), dimension(:), intent(out) :: x + real(dp), dimension(:), intent(in) :: b + + integer :: n, info + + n = size(U,1) + + x = b + + call dtrtrs('U','T','N', n, 1, U, n, x, n, info) + + if( info /= 0 ) call system_abort('Matrix_Solve_Upper_Triangular: cannot solve system') + + endsubroutine Matrix_Solve_Upper_Triangular + + ! Invert an already Cholesky-factorised matrix. + subroutine Matrix_Factorised_Inverse(U,inverse_A) + + real(dp), dimension(:,:), target, intent(inout) :: U + real(dp), dimension(:,:), target, intent(out), optional :: inverse_A + + real(dp), dimension(:,:), pointer :: inverse + integer :: i, j, n, info + + n = size(U,1) + + if( present(inverse_A) ) then + inverse => inverse_A + inverse = U + else + inverse => U + endif + + call dpotri('U', n, inverse, n, info) + + if( info /= 0 ) call system_abort('Matrix_Factorised_Inverse: cannot invert') + + do i = 1, n + do j = i+1, n + inverse(j,i) = inverse(i,j) + enddo + enddo + inverse => null() + + endsubroutine Matrix_Factorised_Inverse + + !% Test if this matrix is diagonal + function is_diagonal(matrix) + real(dp),intent(in), dimension(:,:) :: matrix + logical :: is_diagonal + + integer :: i,j + + if (.not. is_square(matrix)) call system_abort('Matrix_diagonal: matrix not squared') + + do i=1,size(matrix,1) + do j=1,size(matrix,2) + if (i == j) cycle + if (matrix(i,j) .fne. 0.0_dp) then + is_diagonal = .false. + return + end if + end do + end do + + is_diagonal = .true. + + end function is_diagonal + + ! matrix_is_symmetric(matrix) + ! + ! tells if tha matrix is symmetric + function matrix_is_symmetric(matrix) result(symm) + real(dp),intent(in), dimension(:,:):: matrix + logical::symm + integer::i,j,N + + real(dp) :: maxv + + if (.not.Is_Square(matrix)) & + call system_abort('Matrix_Is_Symmetric: Matrix is not square') + + maxv = maxval(abs(matrix)) + N=size(matrix,1) + symm=.true. + do i=1,N + do j=i+1,N + if (abs(matrix(i,j)-matrix(j,i)) > NUMERICAL_ZERO*maxv) then + symm=.false. + return + end if + enddo + enddo + + end function matrix_is_symmetric + + ! matrix_is_symmetric(matrix) + ! + ! tells if the matrix is symmetric + function int_matrix_is_symmetric(matrix) result(symm) + + integer, intent(in), dimension(:,:):: matrix + logical::symm + integer::i,j,N + + if (.not.is_square(matrix)) & + call system_abort('is_symmetric: Matrix is not square') + + N=size(matrix,1) + symm=.true. + do i=1,N + do j=i+1,N + if (matrix(j,i) /= matrix(i,j)) then + symm=.false. + return + end if + enddo + enddo + + end function int_matrix_is_symmetric + + ! matrix_z_is_symmetric(matrix) + ! + ! tells if the matrix is symmetric + function matrix_z_is_symmetric(matrix) result(symm) + complex(dp),intent(in), dimension(:,:):: matrix + logical::symm + integer::i,j,N + + real(dp) :: maxv + + if (.not.Is_Square(matrix)) & + call system_abort('Matrix_Is_Symmetric: Matrix is not square') + + maxv = maxval(abs(matrix)) + + N=size(matrix,1) + symm=.true. + do i=1,N + do j=i+1,N + if (abs(matrix(j,i)-matrix(i,j)) > maxv*NUMERICAL_ZERO ) then + symm=.false. + return + end if + enddo + enddo + + end function matrix_z_is_symmetric + + ! matrix_z_is_hermitian(matrix) + ! + ! tells if tha matrix is hermitian + function matrix_z_is_hermitian(matrix) result(herm) + complex(dp),intent(in), dimension(:,:):: matrix + + logical::herm + integer::i,j,N + + real(dp) :: maxv + + if (.not.Is_Square(matrix)) & + call system_abort('Matrix_Is_Symmetric: Matrix is not square') + + maxv = maxval(abs(matrix)) + N=size(matrix,1) + herm=.true. + do i=1,N + do j=i,N + if (abs(matrix(j,i)-conjg(matrix(i,j))) > maxv*NUMERICAL_ZERO) then + herm=.false. + return + end if + enddo + enddo + + end function matrix_z_is_hermitian + + function matrix_is_orthogonal(matrix) + real(dp),intent(in), dimension(:,:):: matrix + logical :: matrix_is_orthogonal + real(dp) :: t(size(matrix,1), size(matrix,2)), identity(size(matrix,1),size(matrix,2)) + + if (.not.Is_Square(matrix)) & + call system_abort('Matrix_Is_Symmetric: Matrix is not square') + + t = matrix .mult. transpose(matrix) + identity = 0.0_dp + call add_identity(identity) + matrix_is_orthogonal = maxval(abs(t - identity)) < maxval(matrix)*NUMERICAL_ZERO + + end function matrix_is_orthogonal + + ! print(matrix) + ! printing + + subroutine matrix_print_mainlog(this, verbosity) + real(dp),intent(in),dimension(:,:) :: this + integer, optional::verbosity + call matrix_print(this,verbosity,mainlog) + end subroutine matrix_print_mainlog + + subroutine matrix_z_print_mainlog(this, verbosity) + complex(dp),intent(in),dimension(:,:) :: this + integer, optional::verbosity + call matrix_z_print(this,verbosity,mainlog) + end subroutine matrix_z_print_mainlog + + subroutine int_matrix_print_mainlog(this, verbosity) + integer,intent(in),dimension(:,:) :: this + integer, optional::verbosity + call int_matrix_print(this,verbosity,mainlog) + end subroutine int_matrix_print_mainlog + + subroutine int_matrix_print(this,verbosity,file) + + integer, dimension(:,:), intent(in) :: this + integer, optional, intent(in) :: verbosity + type(inoutput), intent(in) :: file + + integer :: i,N,M,w + character(20) :: format + + w = int(log10(real(maxval(abs(this))+1,dp)))+3 ! leave at least one space between entries, including room for neg. sign + N = size(this,1) + M = size(this,2) + write(format,'(2(a,i0),a)')'(',M,'i',w,')' + + do i = 1, N + write(line,format) this(i,:) + call print(line,verbosity,file) + end do + + end subroutine int_matrix_print + + ! print real matrix to file, either one entry per line (always == .true.) or as a block with restrictions + subroutine matrix_print(this,verbosity,file, always) + real(dp), intent(in), dimension(:,:) :: this + type(inoutput), intent(in) :: file + integer, optional, intent(in) :: verbosity + logical, optional, intent(in) :: always + + integer :: i, n, w, j + logical :: t + character(20) :: format + integer :: max_size = 5 + integer :: absolute_max_width = 50 + logical :: do_always + + do_always = optional_default(.false., always) + + if (do_always) then + do i=1, size(this,2) + do j=1, size(this,1) + call print(j // " " // i // " " // this(j,i), verbosity, file) + end do + end do + else + + if (size(this,2) > max_size .and. size(this,1) <= max_size) then + w = size(this,1) + n = size(this,2) + t = .true. + else + w = size(this,2) + n = size(this,1) + t = .false. + end if + + if (w > absolute_max_width) then + call print('Matrix_print: matrix is too large to print', verbosity, file) + return + end if + + if (t) then + write (line, '(a)') 'Matrix_Print: printing matrix transpose' + call print(line,verbosity,file) + endif + + write(format,'(a,i0,a)')'(',w,'(1x,f18.10))' + + do i=1,n + if (t) then + write(line,format) this(:,i) + else + write(line,format) this(i,:) + end if + call print(line,verbosity,file) + end do + + end if + + end subroutine matrix_print + + subroutine matrix_z_print(this,verbosity,file) + type(inoutput), intent(in) :: file + complex(dp), intent(in), dimension(:,:) :: this + integer, optional :: verbosity + integer :: i, n, w + logical :: t + character(200) :: format + integer :: max_size = 6 + + if (size(this,2) > max_size .and. size(this,1) <= max_size) then + w = size(this,1) + n = size(this,2) + t = .true. + else + w = size(this,2) + n = size(this,1) + t = .false. + end if + + +! if (w > 60) then +! write(line,'(a,i0,a,i0,a)')'Matrix_z_Print: Both dimensions (',w,',',n,') are too large to print' +! call system_abort(line) +! end if + + if (t) then + write(line, '(a)') 'Matrix_z_Print: printing transpose' + call print(line,verbosity,file) + endif + + write(format,'(a,i0,a)')'(',w,'(x,f12.6,"+I*",f12.6))' + + do i=1,n + if (t) then + write(line,format) this(:,i) + else + write(line,format) this(i,:) + end if + call print(line,verbosity,file) + end do + + end subroutine matrix_z_print + + subroutine matrix_print_mathematica(label, this, verbosity, file) + character(len=*), intent(in) :: label + real(dp), intent(in), dimension(:,:) :: this + integer, optional :: verbosity + type(inoutput), intent(in), optional :: file + + integer i, j + + call print(trim(label)//" = { ", verbosity, file) + do i=1, size(this,1) + call print ("{", verbosity, file) + do j=1, size(this,1) + if (j == size(this,1)) then + call print(this(i,j), verbosity, file) + else + call print(this(i,j)//", ", verbosity, file) + endif + end do + if (i == size(this,1)) then + call print ("}", verbosity, file) + else + call print ("},", verbosity, file) + endif + end do + call print ("};", verbosity, file) + end subroutine matrix_print_mathematica + + subroutine matrix_z_print_mathematica(label, this, verbosity, file) + character(len=*), intent(in) :: label + complex(dp), intent(in), dimension(:,:) :: this + integer, optional :: verbosity + type(inoutput), intent(in), optional :: file + + integer i, j + + call print(trim(label)//" = { ", verbosity, file) + do i=1, size(this,1) + call print ("{", verbosity, file) + do j=1, size(this,1) + if (j == size(this,1)) then + call print(real(this(i,j), dp) // " + I*"//aimag(this(i,j)), verbosity, file) + else + call print(real(this(i,j), dp) // " + I*"//aimag(this(i,j))//", ", verbosity, file) + endif + end do + if (i == size(this,1)) then + call print ("}", verbosity, file) + else + call print ("},", verbosity, file) + endif + end do + call print ("};", verbosity, file) + end subroutine matrix_z_print_mathematica + + !% Returns reciprocal condtion number of matrix A using norm + function matrix_condition_number(A, norm) result(rcond) + real(dp), intent(in) :: A(:,:) + character, intent(in) :: norm !% 1 or O: 1-norm, I: inf-norm + real(dp) :: rcond + + integer :: m, n, minmn, lda, info + real(dp) :: anorm + integer, allocatable :: ipiv(:), iwork(:) + real(dp), allocatable :: work(:) + real(dp), allocatable :: Acopy(:,:) + + real(dp), external :: dlange + + rcond = -1.0_dp + + m = size(A, 1) + n = size(A, 2) + lda = m + + allocate(Acopy(m,n)) + Acopy = A + + allocate(work(m)) + anorm = dlange(norm, m, n, Acopy, lda, work) + deallocate(work) + + minmn = min(m, n) + allocate(ipiv(minmn)) + call dgetrf(m, n, Acopy, lda, ipiv, info) + deallocate(ipiv) + + allocate(work(4 * n)) + allocate(iwork(n)) + call dgecon(norm, n, Acopy, lda, anorm, rcond, work, iwork, info) + end function matrix_condition_number + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X +!X Polynomial fitting to boundary conditions +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! + !% Fit a cubic polynomial to a function given its values ($y_0$ and $y_1$) and + !% its derivative ($y^\prime_0$ and $y^\prime_1$) at two points ($x_0$ and $x_1$) + ! + !% \begin{displaymath} + !% y = ax^3 + bx^2 + cx + d + !% \end{displaymath} + ! + subroutine fit_cubic(x0,y0,y0p,x1,y1,y1p,coeffs) + + real(dp), intent(in) :: x0,y0,y0p !% $x_0$, $y_0$, $y^\prime_0$ + real(dp), intent(in) :: x1,y1,y1p !% $x_1$, $y_1$, $y^\prime_1$ + real(dp), intent(out) :: coeffs(4) !% '(/a,b,c,d/)' + real(dp), dimension(4,4) :: A, invA + real(dp) :: x02, x03, x12, x13 !x0^2, x0^3 ... + + x02 = x0*x0; x03 = x02*x0 + x12 = x1*x1; x13 = x12*x1 + + A = reshape( (/ x03, x13, 3.0_dp*x02, 3.0_dp*x12, & + x02, x12, 2.0_dp*x0, 2.0_dp*x1, & + x0, x1, 1.0_dp, 1.0_dp, & + 1.0_dp, 1.0_dp, 0.0_dp, 0.0_dp /),(/4,4/) ) + + call matrix_inverse(A,invA) + + coeffs = invA .mult. (/y0,y1,y0p,y1p/) + + end subroutine fit_cubic + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X +!X VECTOR stuff +!X +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + ! normsq() + ! returns (X.dot.X) + pure function vector_normsq(vector) result(normsq) + + real(dp), intent(in), dimension(:) :: vector + real(dp) :: normsq + + normsq = dot_product(vector,vector) + + end function vector_normsq + + pure function vector_normsq_q(vector) result(normsq) + + real(qp), intent(in), dimension(:) :: vector + real(qp) :: normsq + + normsq = dot_product(vector,vector) + + end function vector_normsq_q + + ! norm() + ! returns SQRT((X.dot.X)) + pure function vector_norm(vector) result(norm) + + real(dp), intent(in),dimension(:) :: vector + real(dp) :: norm + + norm = sqrt(dot_product(vector,vector)) + + end function vector_norm + + + ! x .dot. y + pure function vector_dotpr(this,other) result(dotpr) + + real(dp), intent(in), dimension(:) :: this,other + real(dp) :: dotpr + + dotpr = dot_product(this,other) + + end function vector_dotpr + + + !% Return the (smallest) angle between two vectors, in radians. + !% This is calculated as + !%\begin{displaymath} + !%\arccos\left(\frac{\mathbf{a}\cdot\mathbf{b}}{|\mathbf{a}| |\mathbf{b}|}\right) + !%\end{displaymath} + pure function angle(a,b) + + real(dp), dimension(:), intent(in) :: a,b + real(dp) :: angle + real(dp) :: arg + + arg = (a .dot. b)/(norm(a)*norm(b)) + if (arg > 1.0_dp) then + arg = 1.0_dp + else if (arg < -1.0_dp) then + arg = -1.0_dp + end if + + angle = acos(arg) + + end function angle + + ! x .outer. y + pure function outer(vector1,vector2) result(outr) + real(dp),intent(in), dimension(:) ::vector1,vector2 + real(dp), dimension(size(vector1),size(vector2)) ::outr + integer::i,j + + do j=1,size(vector2) + do i=1,size(vector1) + outr(i,j)=vector1(i)*vector2(j) + end do + end do + + end function outer + + pure function outer_qq(vector1,vector2) result(outr) + real(qp),intent(in), dimension(:) ::vector1,vector2 + real(qp), dimension(size(vector1),size(vector2)) ::outr + integer::i,j + + do j=1,size(vector2) + do i=1,size(vector1) + outr(i,j)=vector1(i)*vector2(j) + end do + end do + + end function outer_qq + + ! x .outer. y + pure function d_outer_zz(vector1,vector2) result(outr) + complex(dp),intent(in), dimension(:) ::vector1,vector2 + real(dp), dimension(size(vector1),size(vector2)) ::outr + integer::i,j + + do j=1,size(vector2) + do i=1,size(vector1) + outr(i,j)=vector1(i)*conjg(vector2(j)) + end do + end do + + end function d_outer_zz + + ! x .outer. y + pure function z_outer_zz(vector1,vector2) result(outr) + complex(dp),intent(in), dimension(:) ::vector1,vector2 + complex(dp), dimension(size(vector1),size(vector2)) :: outr + integer::i,j + + do j=1,size(vector2) + do i=1,size(vector1) + outr(i,j)=vector1(i)*conjg(vector2(j)) + end do + end do + + end function z_outer_zz + + + !% Return the square root of 'r' if it is positive, or zero otherwise. + elemental function sqrt_cut(r) + real(dp),intent(in)::r + real(dp)::sqrt_cut + sqrt_cut = sqrt(max(0.0_dp,r)) + end function sqrt_cut + + + ! v1 .feq. v2 + ! + !floating point logical comparison + function vector_feq(vector1,vector2) + real(dp),intent(in), dimension(:) ::vector1,vector2 + logical::vector_feq + integer::i + + if(size(vector1) /= size(vector2)) & + call check_size('Vector2',vector2,size(vector1),'Vector_FEQ') + + vector_feq=.true. + do i=1,size(vector1) + if (vector1(i).fne.vector2(i)) then + vector_feq=.false. + return + end if + end do + + end function vector_feq + + ! v1 .fne. v2 + ! + function vector_fne(vector1,vector2) + real(dp),intent(in), dimension(:) :: vector1,vector2 + logical::vector_fne + integer::i + + if(size(vector1) /= size(vector2)) & + call check_size('Vector2',vector2,size(vector1),'Vector_FNE') + + vector_fne=.false. + do i=1,size(vector1) + if (vector1(i).fne.vector2(i)) then + vector_fne=.true. + return + end if + end do + + end function vector_fne + + + !printing + subroutine vector_print_mainlog(this, verbosity) + real(dp),intent(in), dimension(:) :: this + integer, optional::verbosity + call vector_print(this,verbosity,mainlog) + end subroutine vector_print_mainlog + + subroutine vector_print(this,verbosity,file) + real(dp),intent(in), dimension(:) :: this + type(inoutput) :: file + integer, optional :: verbosity + integer :: nbloc,i,nrest + + nbloc=size(this)/5 + nrest=mod(size(this),5) + + do i=1,nbloc + call print(""//this((i-1)*5+1:(i-1)*5+5), verbosity, file) + end do + if (nrest /= 0) then + call print(""//this((i-1)*5+1:(i-1)*5+nrest),verbosity,file) + end if + + end subroutine vector_print + + subroutine vector_z_print_mainlog(this,verbosity) + complex(dp),intent(in), dimension(:) ::this + integer, optional::verbosity + call vector_z_print(this,verbosity,mainlog) + end subroutine vector_z_print_mainlog + + subroutine vector_z_print(this,verbosity,file) + complex(dp),intent(in), dimension(:) :: this + type(inoutput) :: file + integer, optional::verbosity + integer:: nbloc,i,nrest + + nbloc=size(this)/5 + nrest=mod(size(this),5) + + do i=1,nbloc + call print(""//this((i-1)*5+1:(i-1)*5+5), verbosity, file) + end do + if (nrest /= 0) then + call print(""//this((i-1)*5+1:(i-1)*5+nrest), verbosity, file) + end if + + end subroutine vector_z_print + + subroutine integer_array_print_mainlog(this, verbosity) + integer,intent(in), dimension(:) ::this + integer, optional::verbosity + call integer_array_print(this,verbosity,mainlog) + end subroutine integer_array_print_mainlog + + subroutine integer_array_print(this,verbosity,file) + integer,intent(in), dimension(:) ::this + type(inoutput)::file + integer, optional::verbosity + integer:: nbloc,i,nrest + character(20)::form + + nbloc=size(this)/5 + nrest=mod(size(this),5) + + do i=1,nbloc + write(line,'(5i12)')this((i-1)*5+1:(i-1)*5+5) + call print(line,verbosity,file) + end do + if (nrest /= 0) then + write(form,'(a,i0,a)') '(',nrest,'i12)' + write(line,form)this((i-1)*5+1:(i-1)*5+nrest) + call print(line,verbosity,file) + end if + + end subroutine integer_array_print + + subroutine logical_array_print_mainlog(this, verbosity) + logical,intent(in), dimension(:) ::this + integer, optional::verbosity + call logical_array_print(this,verbosity,mainlog) + end subroutine logical_array_print_mainlog + + subroutine logical_array_print(this,verbosity,file) + logical,intent(in), dimension(:) ::this + type(inoutput)::file + integer, optional::verbosity + integer:: nbloc,i,nrest + character(20)::form + + nbloc=size(this)/5 + nrest=mod(size(this),5) + + do i=1,nbloc + write(line,'(5l2)')this((i-1)*5+1:(i-1)*5+5) + call print(line,verbosity,file) + end do + if (nrest /= 0) then + write(form,'(a,i0,a)') '(',nrest,'l2)' + write(line,form)this((i-1)*5+1:(i-1)*5+nrest) + call print(line,verbosity,file) + end if + + end subroutine logical_array_print + + subroutine logical_matrix_print_mainlog(this, verbosity) + logical, intent(in),dimension(:,:) :: this + integer, optional :: verbosity + call logical_matrix_print(this,verbosity,mainlog) + end subroutine logical_matrix_print_mainlog + + subroutine logical_matrix_print(this,verbosity,file) + + logical, dimension(:,:), intent(in) :: this + integer, optional, intent(in) :: verbosity + type(inoutput), intent(in) :: file + + integer :: i,N,M + character(20) :: format + + N = size(this,1) + M = size(this,2) + write(format,'(a,i0,a)')'(',M,'L3)' + + do i = 1, N + write(line,format) this(i,:) + call print(line,verbosity,file) + end do + + end subroutine logical_matrix_print + + ! add to vector elements, random quantities in the range(-a/2,a/2) + subroutine vector_randomise(v,a) + real(dp), intent(inout), dimension(:) :: v + real(dp), intent(in) :: a + + integer :: i + do i=1,size(v) + v(i)=v(i)+(ran_uniform()-0.5_dp)*a + end do + end subroutine vector_randomise + + ! add to complex vector elements, random quantities in the range(-a/2,a/2) + subroutine vector_z_randomise(v,a) + complex(dp), intent(inout), dimension(:) :: v + real(dp), intent(in) :: a + + integer :: i + do i=1,size(v) + v(i)=v(i)+cmplx((ran_uniform()-0.5_dp)*a/sqrt(2.0_dp), (ran_uniform()-0.5_dp)*a/sqrt(2.0_dp)) + end do + end subroutine vector_z_randomise + + ! + !% Return a three vector with normally distributed components + ! + function ran_normal3() + real(dp), dimension(3) :: ran_normal3 + ran_normal3(1) = ran_normal() + ran_normal3(2) = ran_normal() + ran_normal3(3) = ran_normal() + end function ran_normal3 + + + ! returns a vector, contining a histogram of frequencies + function vector_histogram(vector,min_x,max_x,Nbin,weight_vector, drop_outside) + + real(dp), dimension(:), intent(in) :: vector + real(dp), intent(in) :: min_x, max_x + integer, intent(in) :: Nbin + real(dp), dimension(:), intent(in), optional :: weight_vector + logical, optional, intent(in) :: drop_outside + real(dp), dimension(Nbin) :: vector_histogram + !local variables + real(dp) :: binsize + integer :: i, bin + logical :: do_drop_outside + + if(max_x <= min_x) then + call system_abort('Vector_Histogram: max_x < min_x') + end if + + do_drop_outside = optional_default(.false., drop_outside) + + binsize=(max_x-min_x)/(real(Nbin,dp)) + vector_histogram = 0.0_dp + + do i=1,size(vector) + + bin = ceiling((vector(i)-min_x)/binsize) + if (do_drop_outside) then + if (bin < 1 .or. bin > Nbin) cycle + else + if (bin < 1) bin = 1 + if (bin > Nbin) bin = Nbin + endif + if (present(weight_vector)) then + vector_histogram(bin) = vector_histogram(bin) + weight_vector(i) + else + vector_histogram(bin) = vector_histogram(bin) + 1.0_dp + endif + + end do + + end function vector_histogram + + ! Root-Mean-Square difference between elements of two vectors + + !% For two vectors of $N$ dimensions, this is calculated as + !%\begin{displaymath} + !%\sum_{i=1}^{N} \left(\mathbf{v_1}_i - \mathbf{v_2}_i\right)^2 + !%\end{displaymath} + function rms_diff1(vector1, vector2) + real(dp), dimension(:), intent(in) :: vector1, vector2 + real(dp) :: rms_diff1, d + integer :: i + if(size(vector1) /= size(vector2)) & + call check_size('Vector 2',vector2,shape(vector1),'RMS_diff') + rms_diff1 = 0.0_dp + do i = 1, size(vector1) + d = vector1(i) - vector2(i) + rms_diff1 = rms_diff1 + d * d + end do + rms_diff1 = rms_diff1 / real(size(vector1),dp) + rms_diff1 = sqrt(rms_diff1) + end function rms_diff1 + + + !% OMIT + function array_dotprod(this,other, dir) result(c) + real(dp),intent(in), dimension(:,:) :: this,other + integer, intent(in)::dir + real(dp)::c(size(this,3-dir)) + integer::i + + + call check_size('this, other',this,shape(other),'Array_Dotprod') + + if(dir==1) then + do i=1,size(this,2) + c(i)=sqrt(dot_product(this(:,i),other(:,i))) + end do + else if(dir==2) then + do i=1,size(this,1) + c(i)=sqrt(dot_product(this(i,:),other(i,:))) + end do + else + call system_abort('array_dotprod: dir must be 1 or 2') + end if + + end function array_dotprod + + + ! normsq of each vector + function array_normsq(this, dir) + real(dp), dimension(:,:) ::this + integer, intent(in)::dir + real(dp)::array_normsq(size(this,3-dir)) + integer::i + + if(dir==1) then + do i=1,size(this,2) + array_normsq(i)=dot_product(this(:,i),this(:,i)) + end do + else if(dir==2) then + do i=1,size(this,1) + array_normsq(i)=dot_product(this(i,:),this(i,:)) + end do + else + call system_abort('array_normsq: dir must be 1 or 2') + end if + end function array_normsq + + ! norm for each vector + function array_norm(this, dir) result(sqvalue) + real(dp),intent(in), dimension(:,:) :: this + integer, intent(in)::dir + real(dp)::sqvalue(size(this,3-dir)) + integer::i + + if(dir==1) then + do i=1,size(this,2) + sqvalue(i)=sqrt(dot_product(this(:,i),this(:,i))) + end do + else if(dir==2) then + do i=1,size(this,1) + sqvalue(i)=sqrt(dot_product(this(i,:),this(i,:))) + end do + else + call system_abort('array_norm: dir must be 1 or 2') + end if + end function array_norm + + + !% Return a list of scalar triple products for each triplet of vectors from 'a', 'b' and 'c', i.e. + !%> array3_triple(i) = a(:,i) .dot. (b(:,i) .cross. c(:,i))'. + function array3_triple(a,b,c) + real(dp),intent(in), dimension(:,:) ::a, b, c + real(dp)::array3_triple(size(a,2)) + integer::n,m,i + n=size(a,1) + m=size(a,2) + + call check_size('B',b,shape(a),'Array3_Triple') + call check_size('C',c,shape(a),'Array3_Triple') + + do i = 1,m + array3_triple(i) = scalar_triple_product(a(:,i),b(:,i),c(:,i)) + end do + + end function array3_triple + + + ! add random values to the elements of an array in the range(-a/2,a/2) + subroutine matrix_randomise(m,a) + real(dp), dimension(:,:), intent(inout) ::m + real(dp)::a + !local + integer::i,j + + do i=1,size(m,1) + do j=1,size(m,2) + m(i,j)=m(i,j)+(ran_uniform()-0.5_dp)*a + end do + end do + + end subroutine matrix_randomise + + subroutine matrix_z_randomise(m,a) + complex(dp), dimension(:,:), intent(inout) ::m + real(dp)::a + !local + integer::i,j + + do i=1,size(m,1) + do j=1,size(m,2) + m(i,j)=m(i,j)+cmplx((ran_uniform()-0.5_dp)*a/sqrt(2.0_dp), (ran_uniform()-0.5_dp)*a/sqrt(2.0_dp)) + end do + end do + + end subroutine matrix_z_randomise + + ! add to matrix elements, random quantities in the range(-a/2,a/2) + subroutine matrix_randomise_vweight(m,a) + real(dp), intent(inout), dimension(:,:) :: m + real(dp), intent(in) :: a(:) + + integer :: i,j + + if (size(m,2) /= size(a)) & + call system_abort("matrix_randomise_vweight incompatible sizes : m " // shape(m) // " a " // shape(a)) + do i=1,size(m,1) + do j=1,size(m,2) + m(i,j)=m(i,j)+(ran_uniform()-0.5_dp)*a(j) + end do + end do + end subroutine matrix_randomise_vweight + + !% For two arrays of dimension $N \times M$, this is calculated as + !%\begin{displaymath} + !%\sum_{j=1}^{M} \sum_{i=1}^{N} \left(\mathbf{a_1}_{ij} - \mathbf{a_2}_{ij}\right)^2 + !%\end{displaymath} + function rms_diff2(array1, array2) + real(dp), dimension(:,:), intent(in) :: array1, array2 + real(dp) :: rms_diff2, d + integer :: i,j + call check_size('Array 2',array2,shape(array1),'rms_diff') + rms_diff2 = 0.0_dp + do j = 1, size(array1,2) + do i = 1, size(array1,1) + d = array1(i,j) - array2(i,j) + rms_diff2 = rms_diff2 + d * d + end do + end do + rms_diff2 = rms_diff2 / real(size(array1),dp) + rms_diff2 = sqrt(rms_diff2) + end function rms_diff2 + + + ! --------------------------------- + ! + ! 3-vector procedures + ! + + pure function cross_product(x,y) ! x ^ y + + real(dp), dimension(3), intent(in):: x,y + real(dp), dimension(3) :: cross_product + + cross_product(1) = + ( x(2)*y(3) - x(3)*y(2) ) + cross_product(2) = - ( x(1)*y(3) - x(3)*y(1) ) + cross_product(3) = + ( x(1)*y(2) - x(2)*y(1) ) + + end function cross_product + + !% Return the scalar triple product $\mathbf{x} \cdot \mathbf{y} \times \mathbf{z}$ + !% of the 3-vectors 'x', 'y' and 'z'. + pure function scalar_triple_product(x,y,z) ! [x,y,z] + + real(dp), dimension(3), intent(in) :: x,y,z + real(dp) :: scalar_triple_product + + scalar_triple_product = + x(1) * ( y(2)*z(3) - y(3)*z(2) ) & + - x(2) * ( y(1)*z(3) - y(3)*z(1) ) & + + x(3) * ( y(1)*z(2) - y(2)*z(1) ) + + end function scalar_triple_product + + !% Return the vector triple product $\mathbf{x} \times (\mathbf{y} \times \mathbf{z})$ + !% of the 3-vectors 'x', 'y' and 'z'. + pure function vector_triple_product(x,y,z) ! x ^ (y ^ z) = y(x.z) - z(x.y) + + real(dp), dimension(3), intent(in) :: x,y,z + real(dp), dimension(3) :: vector_triple_product + + vector_triple_product = y * (x.dot.z) - z * (x.dot.y) + + end function vector_triple_product + + ! + !% Return a unit vector in the direction given by the angles 'theta' and 'phi', i.e. + !% convert the spherical polar coordinates point $(1,\theta,\phi)$ to cartesians. + ! + pure function unit_vector(theta,phi) + + real(dp), intent(in) :: theta, phi + real(dp), dimension(3) :: unit_vector + + unit_vector(1) = sin(theta)*cos(phi) + unit_vector(2) = sin(theta)*sin(phi) + unit_vector(3) = cos(theta) + + end function unit_vector + + ! + !% Returns a random unit vector which is + !% uniformly distributed over the unit sphere + !% [See Knop, CACM 13 326 (1970)]. + ! + function random_unit_vector() result(v) + real(dp), dimension(3) :: v + real(dp) :: x,y,z,s + + !Find a point in the unit circle + s = 1.1_dp + do while(s > 1.0_dp) + x = 2.0_dp * ran_uniform() - 1.0_dp + y = 2.0_dp * ran_uniform() - 1.0_dp + s = x*x + y*y + end do + + !z must be uniform in [-1,1]. s is uniform in [0,1] + z = 2.0_dp * s - 1.0_dp + + !x and y are constrained by normalisation + s = sqrt((1-z*z)/s) + x = x*s + y = y*s + + v = (/x,y,z/) + + end function random_unit_vector + + + ! INTERPOLATION + + !% Linearly interpolate between the points $(x_0,y_0)$ and $(x_1,y_1)$. + !% Returns the interpolated $y$ at position $x$, where $x_0 \le x \le x_1$. + pure function linear_interpolate(x0,y0,x1,y1,x) result(y) + real(dp), intent(in) :: x0,y0,x1,y1,x + real(dp) :: y + y = y0 + (y1-y0)*(x-x0)/(x1-x0) + end function linear_interpolate + + !% Perform a cubic interpolation between the points $(x_0,y_0)$ and $(x_1,y_1)$, + !% using the cubic function with zero first derivative at $x_0$ and $x_1$. + !% Returns the interpolated $y$ at position $x$, where $x_0 \le x \le x_1$. + pure function cubic_interpolate(x0,y0,x1,y1,x) result(y) + real(dp), intent(in) :: x0,y0,x1,y1,x + real(dp) :: u,v,w,y + u = (x-x0)/(x1-x0) ! relative co-ordinate + v = u * u + w = 3*v - 2*v*u ! w = 3u^2-2u^3 + y = y0 + (y1-y0)*w + end function cubic_interpolate + + + + !%OMIT + subroutine matrix_test() + real(dp),allocatable ::a(:,:),b(:,:),c(:,:),vect1(:),vect2(:),d(:,:) + real(dp)::tmp + write(line,*) 'A is a 2x2 matrix:'; call print(line) + allocate(a(2,2)) + !b=a assigment dosnt work !make subroutine + a=3 + call print(a) + write(line,*) 'Vect1 is a vector of 3 elements:'; call print(line) + allocate(vect1(3),vect2(3)) + vect1=3 + call print(vect1) + + allocate(b(3,3)) + write(line,*) 'If we assign it to the matrix b:'; call print(line) + b=diag(vect1) + call print(b) + write(line,*) 'Now the product of b * vect1:'; call print(line) + !works, but you have to initialise the result + vect2=b.mult.vect1 + call print(vect2) + + !works + + write(line,*) 'The result can be directly assigned to b that becomes:'; call print(line) + b=b.multd.vect1 + call print(b) + + write(line,*) 'The scalar product b.dot. b is :'; call print(line) + !works + tmp=b.dot.b + write(line,*) tmp; call print(line) + call print(line) + + ! works + write(line,*) 'Now b=:'; call print(line) + b=1 + b(1,2)=5 + b(3,1)=0 + b(2,2)=2 + call print(b) + + write(line,*) 'The rowcol product b*b is'; call print(line) + call print(b.mult.b) + write(line,*) 'For comparison: The matmul says that'; call print(line) + allocate(d(size(b,1),size(b,2))) + d=matmul(b,b) + call print(d) + write(line,*) 'Now b=:'; call print(line) + ! transposition works + b(1,2)=-1 + call print(b) + write(line,*) 'Transposing:'; call print(line) + b=transpose(b) + call print(b) + + !works + write(line,*) 'And Symmetrise:'; call print(line) + call matrix_symmetrise(b) + call print(b) + + allocate(c(3,3)) + + c=b +#ifndef useintrinsicblas + write(line,*) 'Eigenproblem of b?:'; call print(line) + ! works + call matrix_diagonalise(b,vect1,c) + write(line,*) 'Eigenvectors:'; call print(line) + call print(c) + write(line,*) 'Eigenvalues:'; call print(line) + call print(vect1) + + + ! general diagonalization + write(line,*) 'Generalise eigenvaue problem:'; call print(line) + call diagonalise(b,b,vect1,c) + write(line,*) 'Eigenvectors:'; call print(line) + call print(c) + write(line,*) 'Eigenvalues:'; call print(line) + call print(vect1) + + + ! check result of diagonalizations with matlab + + write(line,*) 'Now b=: (simmetric?)'; call print(line) + b(1,:)=1 + b(2,:)=2 + b(3,1)=1 + b(3,2)=3 + b(3,3)=4 + call matrix_symmetrise(b) + b(3,:)=0 + b(:,3)=0 + b(2,2)=4 + b(3,3)=6 + + call print(b) + + write(line,*) 'Its inverse is(symmetric positive definite case)'; call print(line) + call matrix_inverse(b,c)!works + call print(c) + write(line,*) 'Their rowcol product is:'; call print(line) + call print(matrix_product(c,b)) + write(line,*) 'Is it the unity matrix? thats good'; call print(line) + + b(2,1)=-2.0 + b(2,1)=3.5 + b(3,2)=7 + write(line,*) 'Now b=: (general case)'; call print(line) + call print(b) + + write(line,*) 'Its inverse is(general case)'; call print(line) + call matrix_inverse(b,c)! works + call print(c) + write(line,*) 'Their rowcol product is:'; call print(line) + call print(matrix_product(c,b)) + write(line,*) 'Is it the unity matrix? thats good'; call print(line) +#endif + + + write(line,*)'The following should be F and T ', b.FEQ.c, b.FEQ.b + call print(line) + + write(line,*) 'Putting diag(b) into a vector'; call print(line) + vect1=diag(b) + call print(vect1) + + write(line,*)'Checking CFCT, b is (34,48,48,110)? :' + call print(line) + + deallocate(b) + allocate(b(2,5)) + b(1,1:3)=3.0 + b(2,1:2)=1.0 + b(2,3:5)=6.0 + b(1,4:5)=2.0 + + call print(b) + + deallocate(vect1) + allocate(vect1(5)) + vect1=1.0_dp + + call print(matrix_cfct(b,vect1)) + + write(line,*)'Checking write_file_direct, b:' + call print(line) + call print(b) +! call matrix_file_write_direct(b,'pippo.dat') + b=0.0_dp + ! call matrix_file_read_direct(b,'pippo.dat') + write(line,*)'We write it to a file and read back. b:' + call print(line) + call print(b) + end subroutine matrix_test + + !% OMIT + subroutine vector_test() + real(dp),allocatable::vector(:),vector1(:),vector2(:) + + write(line,*)'CHECKING VECTORS';call print(line) + write(line,*)'';call print(line) + write(line,*)'a ten elements vector of 0s';call print(line) + allocate(vector(10)) + allocate(vector2(10)) + vector=0.0_dp + call print(vector) + vector=1 + write(line,*)'a ten elements vector of 1s';call print(line) + call print(vector) + write(line,*)'norm And normsq:',normsq(vector),vector_norm(vector) + call print(line) + write(line,*)'Assign it to another vector';call print(line) + allocate(vector1(10)) + vector1=vector + call print(vector1) + write(line,*)'Assign a constant:7';call print(line) + vector1=7.0_dp + call print(vector1) + + ! think about overloading + write(line,*)'Dotproduct vector .DOT. vector',dot_product(vector1,vector1) + call print(line) + write(line,*)'The outer product is'; call print(line) + call print(outer(vector,vector1)) + ! call print(line) + vector2=sqrt_cut(vector1) + write(line,*)'sqrt_cut:';call print(line) + call print(vector2) + write(line,*)'Vector_reandomise:'; call print(line) + call vector_randomise(vector1,6.0_dp) + call print(vector1) + if(vector1.FEQ.vector1) then + write(line,*)'FEQ OK' + call print(line) + end if + if(vector1.FNE.vector) then + write(line,*)'FNE OK' + call print(line) + end if + write(line,*)'Checking print:OK if last 2 are different' + call print(line) + + deallocate (vector) + allocate(vector(17)) + vector=3.57 + vector(16)=5.0 + vector(17)=-4.1 + call print(vector) + + write(line,*)'Checking vector histogram' + call print(line) + + write(line,*) vector_histogram(vector,0.0_dp,5.0_dp,5) + call print(line) + end subroutine vector_test + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Array size and shape checking routines +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + ! The one dimensional checks seem unnecessarily complicated, but they can be + ! easily generalised to higher dimensions (an extra : in intarray declaration + ! for example) + + subroutine check_size_int_dim1(arrayname,intarray,n,caller,error) + + character(*), intent(in) :: arrayname ! The name of the array to be checked + integer, dimension(:), intent(in) :: intarray ! The array to be tested + integer, dimension(:), intent(in) :: n ! The size that intarray should be + character(*), intent(in) :: caller ! The name of the calling routine + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size ! container for the actual size of intarray + logical :: failed ! Keeps track of any failures + integer :: i ! dimension iterator + + INIT_ERROR(error) + + failed = .false. + allocate( actual_size( size(shape(intarray)) ) ) + actual_size = shape(intarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed', error) + end if + + end subroutine check_size_int_dim1 + + !overloaded subroutine which allows a scalar 'n' in the one dimensional case + subroutine check_size_int_dim1_s(arrayname,intarray,n,caller,error) + character(*), intent(in) :: arrayname + integer, dimension(:), intent(in) :: intarray + integer, intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + INIT_ERROR(error) + call check_size(arrayname,intarray,(/n/),caller,error) + PASS_ERROR(error) + + end subroutine check_size_int_dim1_s + + subroutine check_size_int_dim2(arrayname,intarray,n,caller,error) + + character(*), intent(in) :: arrayname + integer, dimension(:,:), intent(in) :: intarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(intarray)) ) ) + actual_size = shape(intarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed', error) + end if + + end subroutine check_size_int_dim2 + + subroutine check_size_real_dim1(arrayname,realarray,n,caller,error) + + character(*), intent(in) :: arrayname + real(dp), dimension(:), intent(in) :: realarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(realarray)) ) ) + actual_size = shape(realarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed', error) + end if + + end subroutine check_size_real_dim1 + + !overloaded subroutine which allows a scalar 'n' in the one dimensional case + subroutine check_size_real_dim1_s(arrayname,realarray,n,caller,error) + character(*), intent(in) :: arrayname + real(dp), dimension(:), intent(in) :: realarray + integer, intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + INIT_ERROR(error) + call check_size(arrayname,realarray,(/n/),caller,error) + PASS_ERROR(error) + + end subroutine check_size_real_dim1_s + + subroutine check_size_real_dim2(arrayname,realarray,n,caller, error) + + character(*), intent(in) :: arrayname + real(dp), dimension(:,:), intent(in) :: realarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(realarray)) ) ) + actual_size = shape(realarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller) //': Size checking failed. Expected: ' // n // ', got: ' // actual_size, error) + end if + + end subroutine check_size_real_dim2 + + subroutine check_size_real_dim3(arrayname,realarray,n,caller, error) + + character(*), intent(in) :: arrayname + real(dp), dimension(:,:,:),intent(in) :: realarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(realarray)) ) ) + actual_size = shape(realarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller) //': Size checking failed. Expected: ' // n // ', got: ' // actual_size, error) + end if + + end subroutine check_size_real_dim3 + +#ifdef HAVE_QP + subroutine check_size_quad_dim1(arrayname,quadarray,n,caller,error) + + character(*), intent(in) :: arrayname + real(qp), dimension(:), intent(in) :: quadarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(quadarray)) ) ) + actual_size = shape(quadarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed',error) + end if + + end subroutine check_size_quad_dim1 + + !overloaded subroutine which allows a scalar 'n' in the one dimensional case + subroutine check_size_quad_dim1_s(arrayname,quadarray,n,caller,error) + character(*), intent(in) :: arrayname + real(qp), dimension(:), intent(in) :: quadarray + integer, intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + INIT_ERROR(error) + call check_size(arrayname,quadarray,(/n/),caller,error) + PASS_ERROR(error) + + end subroutine check_size_quad_dim1_s + + subroutine check_size_quad_dim2(arrayname,quadarray,n,caller,error) + + character(*), intent(in) :: arrayname + real(qp), dimension(:,:), intent(in) :: quadarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(quadarray)) ) ) + actual_size = shape(quadarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed', error) + end if + + end subroutine check_size_quad_dim2 +#endif + + subroutine check_size_complex_dim1(arrayname,realarray,n,caller,error) + + character(*), intent(in) :: arrayname + complex(dp), dimension(:), intent(in) :: realarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(realarray)) ) ) + actual_size = shape(realarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed', error) + end if + + end subroutine check_size_complex_dim1 + + !overloaded subroutine which allows a scalar 'n' in the one dimensional case + subroutine check_size_complex_dim1_s(arrayname,realarray,n,caller,error) + character(*), intent(in) :: arrayname + complex(dp), dimension(:), intent(in) :: realarray + integer, intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + INIT_ERROR(error) + call check_size(arrayname,realarray,(/n/),caller) + PASS_ERROR(error) + + end subroutine check_size_complex_dim1_s + + subroutine check_size_complex_dim2(arrayname,realarray,n,caller, error) + + character(*), intent(in) :: arrayname + complex(dp), dimension(:,:), intent(in) :: realarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(realarray)) ) ) + actual_size = shape(realarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed', error) + end if + + end subroutine check_size_complex_dim2 + + subroutine check_size_log_dim1(arrayname,logarray,n,caller,error) + + character(*), intent(in) :: arrayname + logical, dimension(:), intent(in) :: logarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(logarray)) ) ) + actual_size = shape(logarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed', error) + end if + + end subroutine check_size_log_dim1 + + !overloaded subroutine which allows a scalar 'n' in the one dimensional case + subroutine check_size_log_dim1_s(arrayname,logarray,n,caller,error) + character(*), intent(in) :: arrayname + logical, dimension(:), intent(in) :: logarray + integer, intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + INIT_ERROR(error) + call check_size(arrayname,logarray,(/n/),caller) + PASS_ERROR(error) + + end subroutine check_size_log_dim1_s + + subroutine check_size_log_dim2(arrayname,logarray,n,caller,error) + + character(*), intent(in) :: arrayname + logical, dimension(:,:), intent(in) :: logarray + integer, dimension(:), intent(in) :: n + character(*), intent(in) :: caller + integer, intent(out), optional :: error + + integer, dimension(:), allocatable :: actual_size + logical :: failed + integer :: i + + INIT_ERROR(error) + failed = .false. + allocate( actual_size( size(shape(logarray)) ) ) + actual_size = shape(logarray) + + if (size(actual_size) /= size(n)) then + write(line,'(a,i0,a,i0,a)') caller//': '//arrayname//' is ',size(actual_size), & + ' dimensional and not ',size(n),' dimensional as expected' + call print(line) + failed = .true. + else + do i = 1, size(actual_size) + if (actual_size(i) /= n(i)) then + write(line,'(3(a,i0),a)') caller//': The size of dimension ',i,' of '//arrayname//' is ', & + actual_size(i),' and not ',n(i),' as expected' + call print(line) + failed = .true. + end if + end do + end if + + if (failed) then + RAISE_ERROR(trim(caller)//': Size checking failed', error) + end if + + end subroutine check_size_log_dim2 + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !X + !X Array Searching/Sorting/Averaging + !X + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + !% Collect the indices corresponding to .true. elements of a mask + !% can be used to index other arrays, e.g. array(find(mask)) + function find_indices(mask) + logical::mask(:) + integer::find_indices(count(mask)) + integer::i,n + n = 1 + do i=1,size(mask) + if(mask(i)) then + find_indices(n) = i + n = n+1 + end if + end do + end function find_indices + + + !% Test if a given integer 'val' is in an integer array 'array'. + pure function is_in_array(this, val) + + + integer, intent(in) :: val + integer, intent(in), dimension(:) :: this + logical :: Is_In_Array + + if(find_in_array(this, val) > 0) then + is_in_array = .true. + else + is_in_array = .false. + end if + + end function is_in_array + + pure function find_in_array_element_i(this, val) result(n) + integer, intent(in) :: val + integer, intent(in), dimension(:) :: this + integer ::i, n + + ! Optimised to avoid overhead of function call to find_in_array_row (jrk33) + + do i = 1,size(this) + if (this(i) == val) then + n = i + return + end if + end do + + ! not found + n = 0 + + end function find_in_array_element_i + + pure function find_in_array_element_s(this, val) result(n) + character(len=*), intent(in) :: val + character(len=*), intent(in), dimension(:) :: this + integer ::i, n + + ! Optimised to avoid overhead of function call to find_in_array_row (jrk33) + + do i = 1,size(this) + if (this(i) == val) then + n = i + return + end if + end do + + ! not found + n = 0 + + end function find_in_array_element_s + + function find_in_array_row(this, val, mask) result(n) + integer, intent(in), dimension(:,:) :: this + integer, intent(in), dimension(:) :: val + logical, optional, intent(in), dimension(:) :: mask ! if this exists, we only compare elements where this is 1 + integer :: i, j, n + logical :: match + + if(present(mask)) then + if (size(val) /= size(mask)) & + call system_abort('Table_Find_Row: mask and row size mismatch') + end if + + if (present(mask)) then + do i = 1,size(this,2) + match = .true. + do j=1,size(this,1) + if (.not. mask(j)) cycle + if (this(j,i) /= val(j)) then + match = .false. + exit + end if + end do + if (.not. match) cycle + n = i + return + end do + else + do i = 1,size(this,2) + match = .true. + do j=1,size(this,1) + if (this(j,i) /= val(j)) then + match = .false. + exit + end if + end do + if (.not. match) cycle + n = i + return + end do + end if + + ! not found + n = 0 + end function find_in_array_row + + + !% Return a copy of the integer array 'array' with duplicate + !% elements removed. 'uniq' assumes the input array is sorted + !% so that duplicate entries appear consecutively. + subroutine uniq_int(array, uniqed) + integer, intent(in), dimension(:) :: array + integer, dimension(:), allocatable, intent(out) :: uniqed + + integer, dimension(size(array)) :: seen + integer :: i, n_seen + + n_seen = 1 + seen(1) = array(1) + + do i=2,size(array) + if (array(i) == array(i-1)) cycle + n_seen = n_seen + 1 + seen(n_seen) = array(i) + end do + + allocate(uniqed(n_seen)) + uniqed = seen(1:n_seen) + + end subroutine uniq_int + + subroutine uniq_real(array, uniqed) + real(dp), intent(in), dimension(:) :: array + real(dp), dimension(:), allocatable, intent(out) :: uniqed + + real(dp), dimension(size(array)) :: seen + integer :: i, n_seen + + n_seen = 1 + seen(1) = array(1) + + do i=2,size(array) + if (array(i) .feq. array(i-1)) cycle + n_seen = n_seen + 1 + seen(n_seen) = array(i) + end do + + allocate(uniqed(n_seen)) + uniqed = seen(1:n_seen) + + end subroutine uniq_real + + subroutine uniq_real_dim2(array, uniqed, unique) + real(dp), intent(in), dimension(:,:), target :: array + real(dp), dimension(:,:), allocatable, intent(out), optional :: uniqed + logical, dimension(:), intent(out), optional, target :: unique + + logical, dimension(:), pointer :: my_unique + real(dp), dimension(:), pointer :: last_unique + integer :: i, n_seen, d, n + + d = size(array,1) + n = size(array,2) + + if(present(unique)) then + my_unique => unique + else + allocate(my_unique(n)) + endif + + my_unique = .false. + my_unique(1) = .true. + last_unique => array(:,1) + + do i = 2, n + if( last_unique .feq. array(:,i) ) cycle + my_unique(i) = .true. + last_unique => array(:,i) + enddo + + last_unique => null() + + if(present(uniqed)) then + n_seen = count(my_unique) + call reallocate(uniqed,d,n_seen) + uniqed(:,:) = array(:,find_indices(my_unique)) + endif + + if(present(unique)) then + my_unique => null() + else + deallocate(my_unique) + endif + + end subroutine uniq_real_dim2 + + !% Sort an array of integers into ascending order (slow: scales as N$^2$). + !% r_data is an accompanying array of reals on which the same reordering is performed + subroutine sort_array_i(array, i_data, r_data) + + integer, dimension(:), intent(inout) :: array + integer, dimension(:), intent(inout), optional :: i_data + real(dp), dimension(:), intent(inout), optional :: r_data + integer :: i,j,minpos + integer :: min, tmp + real(dp) :: r_tmp + + + do i = 1, (size(array) - 1) + + min = huge(0) + + do j = i,size(array) + + if (array(j) < min) then + min = array(j) + minpos = j + end if + + end do + + tmp = array(i) + array(i) = array(minpos) + array(minpos) = tmp + if (present(i_data)) then + tmp = i_data(i) + i_data(i) = i_data(minpos) + i_data(minpos) = tmp + endif + if (present(r_data)) then + r_tmp = r_data(i) + r_data(i) = r_data(minpos) + r_data(minpos) = r_tmp + endif + + end do + + end subroutine sort_array_i + + + !% Sort an array of integers into ascending order (slow: scales as N$^2$). + !% i_data is an accompanying array of integers on which the same reordering is performed + subroutine sort_array_r(array, i_data,r_data) + + real(dp), dimension(:), intent(inout) :: array + integer, dimension(:), intent(inout), optional :: i_data + real(dp), dimension(:), intent(inout), optional :: r_data + integer :: i,j, minpos + real(dp) :: tmp, min + integer :: i_tmp + real(dp) :: r_tmp + + + do i = 1, (size(array) - 1) + + min = huge(0.0_dp) + + do j = i,size(array) + + if (array(j) < min) then + min = array(j) + minpos = j + end if + + end do + + tmp = array(i) + array(i) = array(minpos) + array(minpos) = tmp + if (present(i_data)) then + i_tmp = i_data(i) + i_data(i) = i_data(minpos) + i_data(minpos) = i_tmp + endif + if (present(r_data)) then + r_tmp = r_data(i) + r_data(i) = r_data(minpos) + r_data(minpos) = r_tmp + endif + + end do + + end subroutine sort_array_r + + + !% Sort an array of integers into ascending order. + !% The function uses heapsort, which always scales as N log N. + !% i_data and r_data are a accompanying arrays of integers and reals + !% on which the same reordering is performed + !% (Initial implementation by Andreas Wonisch) + subroutine heap_sort_i(array, i_data, r_data) + integer, dimension(:), intent(inout) :: array + integer, optional, dimension(:), intent(inout) :: i_data + real(dp), optional, dimension(:), intent(inout) :: r_data + + ! --- + + integer :: N, i, j, root, tmpi + real(DP) :: tmpr + + ! --- + + N = size(array) + + do i = N/2, 1, -1 + + j = i + call siftdown(j, N) + + enddo + + do i = N, 2, -1 + + ! Swap + tmpi = array(1) + array(1) = array(i) + array(i) = tmpi + if (present(i_data)) then + tmpi = i_data(1) + i_data(1) = i_data(i) + i_data(i) = tmpi + endif + if (present(r_data)) then + tmpr = r_data(1) + r_data(1) = r_data(i) + r_data(i) = tmpr + endif + + root = 1 + j = i -1 + call siftdown(root, j) + + enddo + + contains + + subroutine siftdown(root, bottom) + integer, intent(inout) :: root + integer, intent(in) :: bottom + + ! --- + + logical :: done + integer :: maxchild + + ! --- + + done = .false. + + do while ((root*2 <= bottom) .and. .not. done) + + if (root*2 == bottom) then + maxchild = root * 2 + else if (array(root*2) > array(root*2+1)) then + maxchild = root * 2 + else + maxchild = root*2 + 1 + endif + + if (array(root) < array(maxchild)) then + + ! Swap + tmpi = array(root) + array(root) = array(maxchild) + array(maxchild) = tmpi + if (present(i_data)) then + tmpi = i_data(root) + i_data(root) = i_data(maxchild) + i_data(maxchild) = tmpi + endif + if (present(r_data)) then + tmpr = r_data(root) + r_data(root) = r_data(maxchild) + r_data(maxchild) = tmpr + endif + + root = maxchild + else + done = .true. + endif + + enddo + + endsubroutine siftdown + + endsubroutine heap_sort_i + + + !% Sort an array of integers into ascending order. + !% The function uses heapsort, which always scales as N log N. + !% i_data and r_data are a accompanying arrays of integers and reals + !% on which the same reordering is performed + !% (Initial implementation by Andreas Wonisch) + subroutine heap_sort_r(array, i_data, r_data) + real(dp), dimension(:), intent(inout) :: array + integer, optional, dimension(:), intent(inout) :: i_data + real(dp), optional, dimension(:), intent(inout) :: r_data + + ! --- + + integer :: N, i, j, root, tmpi + real(DP) :: tmpr + + ! --- + + N = size(array) + + do i = N/2, 1, -1 + + j = i + call siftdown(j, N) + + enddo + + do i = N, 2, -1 + + ! Swap + tmpr = array(1) + array(1) = array(i) + array(i) = tmpr + if (present(i_data)) then + tmpi = i_data(1) + i_data(1) = i_data(i) + i_data(i) = tmpi + endif + if (present(r_data)) then + tmpr = r_data(1) + r_data(1) = r_data(i) + r_data(i) = tmpr + endif + + root = 1 + j = i -1 + call siftdown(root, j) + + enddo + + contains + + subroutine siftdown(root, bottom) + integer, intent(inout) :: root + integer, intent(in) :: bottom + + ! --- + + logical :: done + integer :: maxchild + + ! --- + + done = .false. + + do while ((root*2 <= bottom) .and. .not. done) + + if (root*2 == bottom) then + maxchild = root * 2 + else if (array(root*2) > array(root*2+1)) then + maxchild = root * 2 + else + maxchild = root*2 + 1 + endif + + if (array(root) < array(maxchild)) then + + ! Swap + tmpr = array(root) + array(root) = array(maxchild) + array(maxchild) = tmpr + if (present(i_data)) then + tmpi = i_data(root) + i_data(root) = i_data(maxchild) + i_data(maxchild) = tmpi + endif + if (present(r_data)) then + tmpr = r_data(root) + r_data(root) = r_data(maxchild) + r_data(maxchild) = tmpr + endif + + root = maxchild + else + done = .true. + endif + + enddo + + endsubroutine siftdown + + endsubroutine heap_sort_r + + subroutine heap_sort_r_2dim(array, i_data, r_data) + real(dp), dimension(:,:), intent(inout) :: array + integer, optional, dimension(:), intent(inout) :: i_data + real(dp), optional, dimension(:), intent(inout) :: r_data + + ! --- + + integer :: N, i, j, root, tmpi, d + real(dp), dimension(:), allocatable :: tmp_array + real(dp) :: tmpr + + ! --- + + N = size(array,2) + d = size(array,1) + allocate(tmp_array(d)) + + do i = N/2, 1, -1 + + j = i + call siftdown(j, N) + + enddo + + do i = N, 2, -1 + + ! Swap + tmp_array(:) = array(:,1) + array(:,1) = array(:,i) + array(:,i) = tmp_array(:) + if (present(i_data)) then + tmpi = i_data(1) + i_data(1) = i_data(i) + i_data(i) = tmpi + endif + if (present(r_data)) then + tmpr = r_data(1) + r_data(1) = r_data(i) + r_data(i) = tmpr + endif + + root = 1 + j = i -1 + call siftdown(root, j) + + enddo + + deallocate(tmp_array) + + contains + + subroutine siftdown(root, bottom) + integer, intent(inout) :: root + integer, intent(in) :: bottom + + ! --- + + logical :: done + integer :: maxchild + + ! --- + + done = .false. + + do while ((root*2 <= bottom) .and. .not. done) + + if (root*2 == bottom) then + maxchild = root * 2 + else if ( real_array_gt(array(:,root*2),array(:,root*2+1)) ) then !array(:,root*2) > array(:,root*2+1) + maxchild = root * 2 + else + maxchild = root*2 + 1 + endif + + if ( real_array_lt(array(:,root),array(:,maxchild)) ) then ! array(:,root) < array(:,maxchild) + + ! Swap + tmp_array(:) = array(:,root) + array(:,root) = array(:,maxchild) + array(:,maxchild) = tmp_array(:) + if (present(i_data)) then + tmpi = i_data(root) + i_data(root) = i_data(maxchild) + i_data(maxchild) = tmpi + endif + if (present(r_data)) then + tmpr = r_data(root) + r_data(root) = r_data(maxchild) + r_data(maxchild) = tmpr + endif + + root = maxchild + else + done = .true. + endif + + enddo + + endsubroutine siftdown + + endsubroutine heap_sort_r_2dim + + subroutine heap_sort_i_2dim(array, i_data, r_data) + integer, dimension(:,:), intent(inout) :: array + integer, optional, dimension(:), intent(inout) :: i_data + real(dp), optional, dimension(:), intent(inout) :: r_data + + ! --- + + integer :: N, i, j, root, tmpi, d + integer, dimension(:), allocatable :: tmp_array + real(dp) :: tmpr + + ! --- + + N = size(array,2) + d = size(array,1) + allocate(tmp_array(d)) + + do i = N/2, 1, -1 + + j = i + call siftdown(j, N) + + enddo + + do i = N, 2, -1 + + ! Swap + tmp_array(:) = array(:,1) + array(:,1) = array(:,i) + array(:,i) = tmp_array(:) + if (present(i_data)) then + tmpi = i_data(1) + i_data(1) = i_data(i) + i_data(i) = tmpi + endif + if (present(r_data)) then + tmpr = r_data(1) + r_data(1) = r_data(i) + r_data(i) = tmpr + endif + + root = 1 + j = i -1 + call siftdown(root, j) + + enddo + + deallocate(tmp_array) + + contains + + subroutine siftdown(root, bottom) + integer, intent(inout) :: root + integer, intent(in) :: bottom + + ! --- + + logical :: done + integer :: maxchild + + ! --- + + done = .false. + + do while ((root*2 <= bottom) .and. .not. done) + + if (root*2 == bottom) then + maxchild = root * 2 + else if ( int_array_gt(array(:,root*2),array(:,root*2+1)) ) then !array(:,root*2) > array(:,root*2+1) + maxchild = root * 2 + else + maxchild = root*2 + 1 + endif + + if ( int_array_lt(array(:,root),array(:,maxchild)) ) then ! array(:,root) < array(:,maxchild) + + ! Swap + tmp_array(:) = array(:,root) + array(:,root) = array(:,maxchild) + array(:,maxchild) = tmp_array(:) + if (present(i_data)) then + tmpi = i_data(root) + i_data(root) = i_data(maxchild) + i_data(maxchild) = tmpi + endif + if (present(r_data)) then + tmpr = r_data(root) + r_data(root) = r_data(maxchild) + r_data(maxchild) = tmpr + endif + + root = maxchild + else + done = .true. + endif + + enddo + + endsubroutine siftdown + + endsubroutine heap_sort_i_2dim + + !% Sort an array of integers into ascending order (stable, slow: scales as N$^2$). + !% i_data is an accompanying array of integers on which the same reordering is performed + subroutine insertion_sort_i(array, i_data) + integer, intent(inout), dimension(:) :: array + integer, intent(inout), dimension(size(array)), optional :: i_data + + integer :: i, vi, j, v + vi = 1 + + do i = 2, size(array) + if (array(i) >= array(i-1)) cycle + v = array(i) + if (present(i_data)) vi = i_data(i) + + do j = (i - 1), 1, -1 + if (v > array(j)) exit + array(j+1) = array(j) + if (present(i_data)) i_data(j+1) = i_data(j) + end do + array(j+1) = v + if (present(i_data)) i_data(j+1) = vi + end do + + end subroutine insertion_sort_i + + !% Sort an array of reals into ascending order (stable, slow: scales as N$^2$). + !% i_data is an accompanying array of integers on which the same reordering is performed + subroutine insertion_sort_r(array, i_data) + real(dp), intent(inout), dimension(:) :: array + integer, intent(inout), dimension(size(array)), optional :: i_data + + integer :: i, vi, j + real(dp) :: v + vi = 1 + + do i = 2, size(array) + if (array(i) >= array(i-1)) cycle + v = array(i) + if (present(i_data)) vi = i_data(i) + + do j = (i - 1), 1, -1 + if (v > array(j)) exit + array(j+1) = array(j) + if (present(i_data)) i_data(j+1) = i_data(j) + end do + array(j+1) = v + if (present(i_data)) i_data(j+1) = vi + end do + + end subroutine insertion_sort_r + + !% Do binary search and return 'index' of element containing 'value', or zero if not found. + !% 'array' must be sorted into ascending order beforehand. + !% If the array subscripts don't start at 1, then pass the actual index of the first element as 'first', + !% then, if the element isn't found, the value returned is 'first' minus 1. + !% To restrict the search to a subsection of the array supply 'low' and/or 'high'. + + function binary_search_i(array,value,first,low,high,error) result(index) + + integer, dimension(:), intent(in) :: array + integer, intent(in) :: value + integer, optional, intent(in) :: first,low,high + integer, optional, intent(out) :: error + integer :: index + !local variables + integer :: ilow, ihigh, count, max + logical :: done + + INIT_ERROR(error) + max = size(array) + ilow = 1; ihigh = max + if (present(low)) then + ilow = low + if (present(first)) ilow = ilow - first + 1 + ASSERT(ilow >= 1, 'binary_search: Bad lower index supplied', error) + end if + if (present(high)) then + ihigh = high + if (present(first)) ihigh = ihigh - first + 1 + ASSERT(ihigh <= max, 'binary_search: Bad higher index supplied', error) + end if + ASSERT(ilow <= ihigh, 'binary_search: Lower index > Higher index!', error) + + index = 0; count = 0 + done = .false. + + ASSERT(max >= 1, 'binary_search: Array must have at lease one element!', error) + + if ( (array(ilow) > value) .or. (array(ihigh) < value) ) done = .true. + if (array(ilow) == value) then + index = ilow + done = .true. + end if + if (array(ihigh) == value) then + index = ihigh + done = .true. + end if + + do while(.not.done) + count = count + 1 + index = (ihigh + ilow) / 2 + if (index == ilow) then ! value is not present. exit + index = 0 + done = .true. + else if (array(index) == value) then ! value found + done = .true. + else if (array(index) < value) then ! value at this index is too low. shift lower bound + ilow = index + else ! value at this index is too high. shift upper bound + ihigh = index + end if + ASSERT(count < max, 'binary_search: Counter hit maximum. Is the array sorted properly?', error) + end do + + if (present(first)) index = index - 1 + first + + end function binary_search_i + + + !% Do binary search and return 'index' of element being smaller or equal + !% to 'value'. 'array' must be sorted into ascending order beforehand. + !% If the array subscripts don't start at 1, then pass the actual index of + !% the first element as 'first' + function binary_search_r(array,value,first,low,high,error) result(index) + + real(DP), dimension(:), intent(in) :: array + real(DP), intent(in) :: value + integer, optional, intent(in) :: first,low,high + integer, optional, intent(out) :: error + integer :: index + !local variables + integer :: ilow, ihigh, count, max + logical :: done + + INIT_ERROR(error) + max = size(array) + ilow = 1; ihigh = max + if (present(low)) then + ilow = low + if (present(first)) ilow = ilow - first + 1 + ASSERT(ilow >= 1, 'binary_search: Bad lower index supplied', error) + end if + if (present(high)) then + ihigh = high + if (present(first)) ihigh = ihigh - first + 1 + ASSERT(ihigh <= max, 'binary_search: Bad higher index supplied', error) + end if + ASSERT(ilow <= ihigh, 'binary_search: Lower index > Higher index!', error) + + index = 0; count = 0 + done = .false. + + ASSERT(max >= 1, 'binary_search: Array must have at lease one element!', error) + + if (array(ilow) > value) then + index = ilow-1 + done = .true. + end if + if (array(ihigh) <= value) then + index = ihigh + done = .true. + end if + + do while(.not.done) + count = count + 1 + index = (ihigh + ilow) / 2 + if (array(index) <= value .and. array(index+1) > value) then + ! value found + done = .true. + else if (array(index) < value) then + ! value at this index is too low. shift lower bound + ilow = index + else + ! value at this index is too high. shift upper bound + ihigh = index + endif + ASSERT(count < max, 'binary_search: Counter hit maximum. Is the array sorted properly?', error) + end do + + if (present(first)) index = index - 1 + first + + end function binary_search_r + + + !% Subtract the average value from each element of a real array. + subroutine zero_sum(array) + + real(dp), dimension(:,:), intent(inout) :: array + real(dp), dimension(size(array,1)) :: array_avg + integer :: i + + array_avg = average_array(array) + + ! Update each component + do i = 1, size(array,2) + array(:,i) = array(:,i) - array_avg + end do + + end subroutine zero_sum + + !% Calculate the average of a two dimenstional real array across its second dimension. + function average_array(array) + + real(dp), dimension(:,:), intent(in) :: array + real(dp), dimension(size(array,1)) :: average_array + integer :: i + + average_array = 0.0_dp + do i = 1, size(array,2) + average_array = average_array + array(:,i) + end do + + average_array = average_array / real(size(array,2),dp) + + end function average_array + + + + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Linear Least Squares fit using \textsc{lapack} to do singular value decomposition. + !% + !% Fit data 'y' with errors 'sig' to model using parameters 'a', + !% and calculate $\chi^2$ of the fit. The user defined subroutine 'funcs' + !% should return the model parameters 'a' for the point 'x' in the array 'afunc'. + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine least_squares(x, y, sig, a, chisq, funcs) + + real(dp), intent(in), dimension(:) :: x, y, sig + real(dp), intent(out), dimension(:) :: a + real(dp), intent(out) :: chisq + + real(dp) :: ain(size(x),size(a)), u(size(x),size(x)), v(size(a),size(a)),& + w(size(a)), sigmainv(size(a), size(x)) + integer i,j,info + real(dp), parameter :: TOL = 1e-13_dp + real(dp) :: wmax, thresh, sum, b(size(x)), afunc(size(a)) + real(dp), allocatable, dimension(:) :: work + integer :: ndata, ma, lwork + interface + subroutine funcs(x,afunc) + use system_module + real(dp) :: x, afunc(:) + end subroutine funcs + end interface + + ndata = size(x) + ma = size(a) + + ! Call user fit function and scale by sig + do i=1,ndata + call funcs(x(i), afunc) + do j=1,ma + ain(i,j) = afunc(j)/sig(i) + end do + b(i) = y(i)/sig(i) + end do + + lwork = 2 * max(3*min(ma,ndata)+max(ma,ndata),5*min(ma,ndata)) + allocate(work(lwork)) + call DGESVD('A','A',ndata,ma,ain,ndata,w,u,ndata,v,ma,work,lwork,info) + + if (info/=0) then + if (info < 0) then + write(line,'(a,i0)')'least_squares: Problem with argument ',-info + call system_abort(line) + else + call system_abort('least_squares: DBDSQR (called from DGESVD) did not converge') + end if + end if + deallocate(work) + + ! Zero singular elements + wmax = maxval(w) + thresh = TOL*wmax + + ! Invert singular value matrix + sigmainv = 0.0_dp + do i=1,ma + if (w(i) < thresh) then + sigmainv(i,i) = 0.0_dp + else + sigmainv(i,i) = 1.0_dp/w(i) + end if + end do + + a = transpose(v) .mult. sigmainv .mult. transpose(u) .mult. b + + ! Calculate chi^2 for the fitted parameters + chisq = 0.0_dp + do i=1,ndata + call funcs(x(i), afunc) + sum = 0.0_dp + do j=1,ma + sum = sum + a(j)*afunc(j) + end do + chisq = chisq + ((y(i)-sum)/sig(i))**2 + end do + + end subroutine least_squares + + !% This routine updates the average and variance of a quantity that is sampled periodically + subroutine update_running_average_and_variance(average,variance,x,N) + + real(dp), intent(inout) :: average, variance + real(dp), intent(in) :: x !% The new sample value + integer, intent(in) :: N !% The sample number + + real(dp) :: f1, f2, old_av, old_var + + f1 = real(N-1,dp) / real(N,dp) + f2 = 1.0_dp / real(N,dp) + old_av = average + old_var = variance + + !Update average + average = f1 * old_av + f2 * x + + !Update variance + variance = f1 * (old_var + old_av*old_av) + f2 * x*x - average*average + + end subroutine update_running_average_and_variance + + subroutine update_exponential_average_s(average,decay,x) + + real(dp), intent(inout) :: average + real(dp), intent(in) :: decay, x + + real(dp) :: aa(1), xa(1) + + !Pack the scalar data into a 1-component vector and call + !the vector version of this routine + + aa(1) = average + xa(1) = x + call update_exponential_average(aa,decay,xa) + + average = aa(1) + + end subroutine update_exponential_average_s + + subroutine update_exponential_average_v(average,decay,x) + + real(dp), intent(inout) :: average(:) + real(dp), intent(in) :: decay, x(size(average)) + + real(dp) :: f1, f2 + + f1 = exp(-decay) + f2 = 1.0_dp - f1 + + average = f1*average + f2*x + + end subroutine update_exponential_average_v + + subroutine update_exponential_average_d2(average,decay,x) + + real(dp), intent(inout) :: average(:,:) + real(dp), intent(in) :: decay, x(size(average,1),size(average,2)) + + real(dp) :: f1, f2 + + f1 = exp(-decay) + f2 = 1.0_dp - f1 + + average = f1*average + f2*x + + end subroutine update_exponential_average_d2 + + ! + ! If we need to bin some data in the range [a,b) with bin-width d, which bin (starting at 1) should + ! the value x go into? Also check that x lies in the correct range. + ! + function bin(a,b,d,x) + + real(dp), intent(in) :: a,b,d,x + integer :: bin + + if (x < a .or. x >= b) call system_abort('bin: data value '//round(x,3)//' does not lie in range [' & + //round(a,3)//','//round(b,3)//')') + + bin = int((x-a)/d) + 1 + + end function bin + + ! + ! Return the coordinate of the centre of the ith bin if we have n bins spanning the range [a,b) + ! + function bin_centre(a,b,n,i) result(c) + + real(dp), intent(in) :: a, b + integer, intent(in) :: n, i + real(dp) :: c + + c = a + (b-a)*(real(i,dp)-0.5_dp)/real(n,dp) + + end function bin_centre + + pure function int_array_ge(array1,array2) result(ge) + + integer, intent(in) :: array1(:) + integer, intent(in) :: array2(size(array1)) + logical :: ge + integer :: i + + ge = .true. + i = 1 + do while(i <= size(array1)) + if (array1(i) < array2(i)) then + ge =.false. + return + else if (array1(i) > array2(i)) then + return + end if + i = i + 1 + end do + + end function int_array_ge + + pure function int_array_gt(array1,array2) result(gt) + + integer, intent(in) :: array1(:) + integer, intent(in) :: array2(size(array1)) + logical :: gt + integer :: i + + gt = .true. + i = 1 + do while(i <= size(array1)) + if (array1(i) < array2(i)) then + gt =.false. + return + else if (array1(i) > array2(i)) then + return + end if + i = i + 1 + end do + gt = .false. + + end function int_array_gt + + pure function int_array_lt(array1,array2) result(lt) + + integer, intent(in) :: array1(:) + integer, intent(in) :: array2(size(array1)) + logical :: lt + + lt = .not.int_array_ge(array1,array2) + + end function int_array_lt + + pure function int_array_le(array1,array2) result(le) + + integer, intent(in) :: array1(:) + integer, intent(in) :: array2(size(array1)) + logical :: le + + le = .not.int_array_gt(array1,array2) + + end function int_array_le + + pure function real_array_gt(array1,array2) + real(dp), dimension(:), intent(in) :: array1 + real(dp), dimension(size(array1)), intent(in) :: array2 + logical :: real_array_gt + + integer :: i + + do i = 1, size(array1) + if(array1(i) .feq. array2(i)) then + cycle + elseif(array1(i) > array2(i)) then + real_array_gt = .true. + return + else !array1(i) < array2(i) + real_array_gt = .false. + return + endif + enddo + + real_array_gt = .false. + + endfunction real_array_gt + + pure function real_array_ge(array1,array2) + real(dp), dimension(:), intent(in) :: array1 + real(dp), dimension(size(array1)), intent(in) :: array2 + logical :: real_array_ge + + integer :: i + + do i = 1, size(array1) + if(array1(i) .feq. array2(i)) then + cycle + elseif(array1(i) > array2(i)) then + real_array_ge = .true. + return + else !array1(i) < array2(i) + real_array_ge = .false. + return + endif + enddo + + real_array_ge = .true. + + endfunction real_array_ge + + pure function real_array_lt(array1,array2) + real(dp), dimension(:), intent(in) :: array1 + real(dp), dimension(size(array1)), intent(in) :: array2 + logical :: real_array_lt + + real_array_lt = .not.real_array_ge(array1,array2) + endfunction real_array_lt + + pure function real_array_le(array1,array2) + real(dp), dimension(:), intent(in) :: array1 + real(dp), dimension(size(array1)), intent(in) :: array2 + logical :: real_array_le + + real_array_le = .not.real_array_gt(array1,array2) + endfunction real_array_le + + !% compare contents of 2 cells in up to N=2 arrays (int or real), return true if + !% contents in first cell is less than 2nd, with 1st array taking precendence. + function arrays_lt(i, j, i_p1, r_p1, i_p2, r_p2, i_p3, r_p3, error) + integer, intent(in) :: i, j + integer, intent(in), pointer, optional :: i_p1(:) + real(dp), intent(in), pointer, optional :: r_p1(:) + integer, intent(in), pointer, optional :: i_p2(:) + real(dp), intent(in), pointer, optional :: r_p2(:) + integer, intent(in), pointer, optional :: i_p3(:) + real(dp), intent(in), pointer, optional :: r_p3(:) + integer, intent(out), optional :: error + logical :: arrays_lt + + integer :: n_p1, n_p2, n_p3 + logical :: p1_is_i = .false., p1_is_r = .false. + logical :: p2_is_i = .false., p2_is_r = .false., have_p2 = .false. + logical :: p3_is_i = .false., p3_is_r = .false., have_p3 = .false. + + INIT_ERROR(error) + + n_p1 = 0 + if (present(i_p1)) then + if (associated(i_p1)) then + n_p1 = n_p1 + 1 + p1_is_i = .true. + endif + end if + if (present(r_p1)) then + if (associated(r_p1)) then + n_p1 = n_p1 + 1 + p1_is_r = .true. + endif + end if + if (n_p1 /= 1) then + RAISE_ERROR("arrays_lt got too many or too few present and associated p1 pointers",error) + endif + + n_p2 = 0 + if (present(i_p2)) then + if (associated(i_p2)) then + n_p2 = n_p2 + 1 + p2_is_i = .true. + endif + end if + if (present(r_p2)) then + if (associated(r_p2)) then + n_p2 = n_p2 + 1 + p2_is_r = .true. + endif + endif + if (n_p2 > 1) then + RAISE_ERROR("arrays_lt got too many present and associated p2 pointers",error) + endif + have_p2 = (n_p2 == 1) + + n_p3 = 0 + if (present(i_p3)) then + if (associated(i_p3)) then + n_p3 = n_p3 + 1 + p3_is_i = .true. + endif + end if + if (present(r_p3)) then + if (associated(r_p3)) then + n_p3 = n_p3 + 1 + p3_is_r = .true. + endif + endif + if (n_p3 > 1) then + RAISE_ERROR("arrays_lt got too many present and associated p3 pointers",error) + endif + have_p3 = (n_p3 == 1) + + ! always have some *_p1, test *_p1 + if (p1_is_i) then + if (i_p1(i) < i_p1(j)) then + arrays_lt = .true. + return + else if (i_p1(i) > i_p1(j)) then + arrays_lt = .false. + return + endif + else ! p1_is_r + if (r_p1(i) < r_p1(j)) then + arrays_lt = .true. + return + else if (r_p1(i) > r_p1(j)) then + arrays_lt = .false. + return + endif + endif + + ! *_p1 must be equal, test *_p2 + if (have_p2) then ! must have some present and associated *_p2 pointer, test it + if (p2_is_i) then + if (i_p2(i) < i_p2(j)) then + arrays_lt = .true. + return + else if (i_p2(i) > i_p2(j)) then + arrays_lt = .false. + return + endif + else ! p2_is_r + if (r_p2(i) < r_p2(j)) then + arrays_lt = .true. + return + else if (r_p2(i) > r_p2(j)) then + arrays_lt = .false. + return + endif + endif + endif + + ! *_p2 must be equal, test *_p3 + if (have_p3) then ! must have some present and associated *_p3 pointer, test it + if (p3_is_i) then + if (i_p3(i) < i_p3(j)) then + arrays_lt = .true. + return + else if (i_p3(i) > i_p3(j)) then + arrays_lt = .false. + return + endif + else ! p3_is_r + if (r_p3(i) < r_p3(j)) then + arrays_lt = .true. + return + else if (r_p3(i) > r_p3(j)) then + arrays_lt = .false. + return + endif + endif + endif + + ! *_p3 must be equal + arrays_lt = .false. + end function arrays_lt + + subroutine polar_decomposition(m, S, R) + real(dp), intent(in) :: m(3,3) + real(dp), intent(out) :: S(3,3), R(3,3) + + real(dp) :: EEt(3,3), D(3), V(3,3) + + ! Find polar decomposition: m = S*R where S is symmetric, R is a rotation + ! EEt = E*E', EEt = VDV' D diagonal, S = V D^1/2 V', R = S^-1*E + + EEt = m .mult. transpose(m) ! Normal + call diagonalise(EEt, D, V) + + ! Check positive definite + if (any(D < 0)) then + call print(m, PRINT_VERBOSE) + call system_abort("polar decomposition 'm' is not positive definite") + end if + + S = V .mult. diag(sqrt(D)) .mult. transpose(V) + R = V .mult. diag(D ** (-0.5_dp)) .mult. transpose(V) .mult. m + + call print('S:', PRINT_ANALYSIS); call print(S, PRINT_ANALYSIS) + call print('R:', PRINT_ANALYSIS); call print(R, PRINT_ANALYSIS) + + end subroutine polar_decomposition + + !% Returns the volume of intersection of two spheres, radius $r_1$ and $r_2$, whose + !% centres are a distance $d$ apart + function sphere_intersection_vol(r1,r2,d) result(V) + + real(dp), intent(in) :: r1, r2, d + real(dp) :: V + real(dp) :: t1, t2, t3 + + if (r1<0.0_dp .or. r2<0.0-dp .or. d<0.0_dp .or. (r1 + r2)>d) then + V = 0.0_dp + return + else if (abs(r1-r2)>d) then + t1 = min(r1,r2) + V = 4.0_dp*PI*t1*t1*t1/3.0_dp + return + end if + + t1 = r1 + r2 - d + t2 = r1 + r2 + d + t3 = r1 - r2 + + V = PI * t1 * t1 * (d * t2 - 3.0_dp * t3 * t3) / (12.0_dp * d) + + end function sphere_intersection_vol + + function permutation_symbol() result(eps) + real(dp) :: eps(3,3,3) + + eps = 0.0_dp + + eps(1,2,3) = 1.0_dp + eps(1,3,2) = -1.0_dp + eps(2,3,1) = 1.0_dp + eps(2,1,3) = -1.0_dp + eps(3,1,2) = 1.0_dp + eps(3,2,1) = -1.0_dp + end function permutation_symbol + + ! Matrix3x3_Inverse + ! + !% Calculate $3\times3$ matrix inverse of 'lattice' and store result in 'g'. + !% Avoids overhead of calling \textsc{lapack} for simple case of $3\times3$ matrix. + subroutine matrix3x3_inverse(matrix, g) + real(dp), intent(in) :: matrix(3,3) + real(dp), intent(out) :: g(3,3) + + real(dp) :: stp + + stp = scalar_triple_product(matrix(:,1), matrix(:,2), matrix(:,3)) + + g(1,:) = (matrix(:,2) .cross. matrix(:,3))/stp + g(2,:) = (matrix(:,3) .cross. matrix(:,1))/stp + g(3,:) = (matrix(:,1) .cross. matrix(:,2))/stp + + end subroutine matrix3x3_inverse + + !% Calulates determinant of $3\times3$ matrix + function matrix3x3_det(m) result(det) + real(dp), intent(in) :: m(3,3) + real(dp) :: det + + det = m(1,1)*(m(2,2)*m(3,3) - m(3,2)*m(2,3)) & + - m(2,1)*(m(1,2)*m(3,3) - m(3,2)*m(1,3)) & + + m(3,1)*(m(1,2)*m(2,3) - m(2,2)*m(1,3)) + + end function matrix3x3_det + + function pbc_aware_centre(p, lattice, g) result(c) + real(dp), intent(in) :: p(:,:), lattice(3,3), g(3,3) + real(dp) :: c(3) + + integer i + complex(dp) :: c_z(3) + + c_z = 0.0_dp + do i=1, size(p,2) + c_z = c_z + exp(cmplx(0.0_dp,1.0_dp)*2.0_dp*PI*(g .mult. p(:,i))) + end do + c_z = c_z / real(size(p,2),dp) + c_z = c_z/abs(c_z) + c = lattice .mult. real(log(c_z)/(cmplx(0.0_dp,1.0_dp)*2.0_dp*PI),dp) + + end function pbc_aware_centre + + + !% K-means clustering. Algorithm is as described in Numerical Recipes + !% (Third Edition, Section 16.1.2, pp. 848-849). + subroutine kmeans(data, K, means, assign, err, initialisation) + real(dp), dimension(:, :), intent(in) :: data + integer, intent(in) :: K + real(dp), intent(inout), dimension(:,:) :: means + integer, dimension(:), intent(inout) :: assign + real(dp), intent(out), optional :: err + character(*), intent(in), optional :: initialisation + + character(30) :: do_initialisation + integer :: N, M, nn, mm, kk, kmin + logical :: change + real(dp) :: dmin, d + + N = size(data, 1) + M = size(data, 2) + + do_initialisation = optional_default('none', initialisation) + if (trim(do_initialisation) /= 'none' .and. & + trim(do_initialisation) /= 'random_means' .and. & + trim(do_initialisation) /= 'random_partition') & + call system_abort('kmeans: initialisation argument should be one of "none" (default), "random_means", "random_partition"') + + if (trim(do_initialisation) == 'random_means') then + ! Initialise centroids randomly within range of input data + do kk=1,K + do mm=1,M + means(kk,mm) = ran_uniform()*(maxval(data(:,mm))-minval(data(:,mm))) + minval(data(:,mm)) + end do + end do + end if + + assign(:) = 0 + + if (trim(do_initialisation) == 'random_partition') then + ! Assign each centroid randomly to one of the K centroids + do nn=1,N + assign(nn) = mod(ran(), K)+1 + end do + + ! Compute the initial means from the random partition + means(:,:) = 0.0_dp + do nn=1,N + do mm=1,M + means(assign(nn),mm) = means(assign(nn),mm) + data(nn,mm) + end do + end do + do kk=1,K + if (any(assign == kk)) then + means(kk,:) = means(kk,:) / count(assign == kk) + end if + end do + end if + + change = .true. + + do while (change) + change = .false. + + ! E-step -- assign each point to the component whose mean it is closest to + do nn=1,N + dmin = huge(1.0_dp) + do kk=1,K + d = (data(nn,:) - means(kk,:)) .dot. (data(nn,:) - means(kk,:)) + if (d < dmin) then + dmin = d + kmin = kk + end if + end do + + if (assign(nn) /= kmin) then + assign(nn) = kmin + change = .true. + end if + end do + + ! M-step -- update each mean to the average of the data points assigned to it + means(:,:) = 0.0_dp + do nn=1,N + do mm=1,M + means(assign(nn),mm) = means(assign(nn),mm) + data(nn,mm) + end do + end do + do kk=1,K + if (any(assign == kk)) then + means(kk,:) = means(kk,:) / count(assign == kk) + end if + end do + end do + + if (present(err)) then + ! Compute residual error + err = 0.0_dp + do nn=1,N + err = err + (data(nn,:) - means(assign(nn),:)) .dot. (data(nn,:) - means(assign(nn),:)) + end do + end if + + end subroutine kmeans + + subroutine symmetric_linear_solve(M, a, M_inv_a) + real(dp), intent(in) :: M(:,:), a(:) + real(dp), intent(out):: M_inv_a(:) + + integer :: N + integer :: lwork, info + real(dp), allocatable :: work(:) + integer, allocatable :: ipiv(:) + + N = size(a) + + allocate(ipiv(N)) + M_inv_a = a + + allocate(work(1)) + lwork = -1 + call dsysv('U', N, 1, M, N, ipiv, M_inv_a, N, work, lwork, info) + if (info /= 0) & + call system_abort("symmetric_linear_solve failed in lwork computation dsysv " // info) + lwork = work(1) + deallocate(work) + + allocate(work(lwork)) + call dsysv('U', N, 1, M, N, ipiv, M_inv_a, N, work, lwork, info) + if (info /= 0) & + call system_abort("symmetric_linear_solve failed in dsysv " // info) + + deallocate(work) + deallocate(ipiv) + end subroutine symmetric_linear_solve + + !% round n to the nearest number greater or equal to n + !% with prime factors of only 2, 3, 5, ... max_prime_factor + subroutine round_prime_factors(n, max_prime_factor, error) + integer, intent(inout) :: n !% The number to be rounded + integer, optional, intent(in) :: max_prime_factor + integer, optional, intent(out) :: error + + integer :: factor, test, i, my_max_prime_factor, num_prime_factors + + INIT_ERROR(error) + + ! Check that n is not zero, otherwise we get stuck in an infinite loop + ASSERT(n /= 0, 'n=0 has no prime factors', error) + + my_max_prime_factor = optional_default(5, max_prime_factor) + select case (my_max_prime_factor) + case ( 2) ; num_prime_factors = 1 + case ( 3) ; num_prime_factors = 2 + case ( 5) ; num_prime_factors = 3 + case ( 7) ; num_prime_factors = 4 + case (11) ; num_prime_factors = 5 + case (13) ; num_prime_factors = 6 + case (17) ; num_prime_factors = 7 + case (19) ; num_prime_factors = 8 + case default + RAISE_ERROR('unsupported max_prime_factor '//my_max_prime_factor//' in prime_factors()', error) + end select + + do + test = n + do i=1,num_prime_factors + factor = 1 + select case (i) + case (1) ; factor = 2 + case (2) ; factor = 3 + case (3) ; factor = 5 + case (4) ; factor = 7 + case (5) ; factor = 11 + case (6) ; factor = 13 + case (7) ; factor = 17 + case (8) ; factor = 19 + case default + RAISE_ERROR('unsupported prime factor '//i//' in prime_factors()', error) + end select + + do while(mod(test,factor).eq.0) + test = test / factor + enddo + end do + + if (test == 1) return + n = n + 1 + end do + + end subroutine round_prime_factors + + !% Calculates integral numerically using the trapezoid formula from (x,y) data + !% pairs. + function TrapezoidIntegral(x,y) + + real(dp) :: TrapezoidIntegral + real(dp), dimension(:), intent(in) :: x, y + + integer :: n + + if( size(x) /= size(y) ) call system_abort('TrapezoidIntegral: dimensions of x and y not the same') + n = size(x) + + TrapezoidIntegral = sum((x(2:n)-x(1:n-1))*(y(2:n)+y(1:n-1)))/2.0_dp + + endfunction TrapezoidIntegral + + subroutine fill_random_integer(r,n,b) + integer, dimension(:), intent(out) :: r + integer, intent(in) :: n + integer, dimension(:), intent(in), optional :: b + + integer :: i, i0, irnd, sr + real(qp) :: rnd + + sr = size(r) + if( sr > n ) call system_abort('fill_random_integer: cannot fill array, too short') + r = 0 + i0 = 1 + if( present(b) ) then + if(size(b) > sr) call system_abort('fill_random_integer: cannot fill array, optional b too long') + r(1:size(b)) = b + i0 = size(b) + 1 + endif + + do i = i0, sr + do + call random_number(rnd) + irnd = ceiling(rnd*n) + if( all(r /= irnd) ) exit + enddo + r(i) = irnd + enddo + + end subroutine fill_random_integer + + function apply_function_matrix(fun,this) + real(dp), dimension(:,:), intent(in) :: this + real(dp), dimension(size(this,1),size(this,2)) :: apply_function_matrix + interface + function fun(x) + use system_module + real(dp), dimension(:), intent(in) :: x + real(dp), dimension(size(x)) :: fun + endfunction fun + endinterface + + real(dp), dimension(:), allocatable :: evals + real(dp), dimension(:,:), allocatable :: evects + + allocate(evals(size(this,1)), evects(size(this,1),size(this,2))) + + call diagonalise(this, evals, evects) + + apply_function_matrix = matrix_mvmt(evects,fun(evals)) + + deallocate(evals,evects) + + endfunction apply_function_matrix + + function sqrt_real_array1d(x) + real(dp), dimension(:), intent(in) :: x + real(dp), dimension(size(x)) :: sqrt_real_array1d + + sqrt_real_array1d = sqrt(x) + + endfunction sqrt_real_array1d + + function invsqrt_real_array1d(x) + real(dp), dimension(:), intent(in) :: x + real(dp), dimension(size(x)) :: invsqrt_real_array1d + + invsqrt_real_array1d = 1.0_dp/sqrt(x) + + endfunction invsqrt_real_array1d + + function matrix_exp_d(a) + real(dp), intent(in) :: a(:,:) + real(dp) :: matrix_exp_d(size(a,1),size(a,2)) + + integer :: n + complex(dp), allocatable :: rv(:,:) + complex(dp), allocatable :: ev(:), rv_inv(:,:) + + if (size(a,1) /= size(a,2)) call system_abort("matrix_exp_d needs a square matrix, not "//size(a,1)//"x"//size(a,2)) + + n = size(a,1) + allocate(rv(n,n), rv_inv(n,n), ev(n)) + + call nonsymmetric_diagonalise(a, ev, r_evects=rv) + call inverse(rv, rv_inv) + + matrix_exp_d = ((rv .multd. exp(ev)) .mult. rv_inv) + + deallocate(rv, rv_inv, ev) + end function matrix_exp_d + + subroutine find_nonzero_chunk_real1d(this,first,last) + real(dp), dimension(:), intent(in) :: this + integer, intent(out), optional :: first, last + + integer :: i + + if(present(first)) then + first = 1 + do i = 1, size(this) + if(this(i) /= 0.0_dp) then + first = i + exit + endif + enddo + endif + + if(present(last)) then + last = 1 + do i = size(this), 1, -1 + if(this(i) /= 0.0_dp) then + last = i + exit + endif + enddo + endif + + endsubroutine find_nonzero_chunk_real1d + + + subroutine svdfact(in_matrix, u_out, s_out, vt_out) + + real(dp), intent(in) :: in_matrix(:,:) + real(dp), dimension(:), intent(out) :: s_out + real(dp), dimension(:,:), intent(out) :: u_out, vt_out + real(dp), allocatable :: s(:), u(:,:), vt(:,:) + real(dp), allocatable :: work(:) + integer, allocatable :: iwork(:) + integer :: n_dimension, info, i, lwork, j + + call print('entering svdfact', verbosity=PRINT_VERBOSE) + + n_dimension = size(in_matrix(:,1)) + if (size(in_matrix(:,2)) /= n_dimension) call system_abort("svdfact only implemented for square matrices") + !call print('Dimension of the Matrix : '//n_dimension, verbosity=PRINT_VERBOSE) + + allocate(s(n_dimension), u(n_dimension,n_dimension), vt(n_dimension,n_dimension)) + allocate(iwork(8*n_dimension)) + lwork = -1 + allocate(work(1)) + call DGESDD('A', n_dimension,n_dimension,in_matrix,n_dimension, s, u,n_dimension, vt,n_dimension, work, lwork, iwork, info) + + lwork = work(1) + deallocate(work) + + allocate(work(lwork)) + call DGESDD('A', n_dimension,n_dimension,in_matrix,n_dimension, s, u,n_dimension, vt,n_dimension, work, lwork, iwork, info) + deallocate(work) + deallocate(iwork) + + call print("DGESDD finished with exit code "//info, verbosity=PRINT_VERBOSE) + + if (info /= 0) then + if (info < 0) then + write(line,'(a,i0)')'SVD: Problem with argument ',-info + call system_abort(line) + else + call system_abort('SVD: DBDSDC (called from DGESDD) did not converge') + end if + end if + + do j=1, size(s) + call print("svd values "// j//" "//s(j), verbosity=PRINT_VERBOSE) + end do + call print("smallest, largest value : "//minval(abs(s))//" "//maxval(abs(s)), verbosity=PRINT_VERBOSE) + + s_out = s + u_out = u + vt_out = vt + + deallocate(s) + deallocate(u) + deallocate(vt) + + call print('finished svdfact', PRINT_VERBOSE) + + end subroutine svdfact + + subroutine inverse_svd_threshold(in_matrix, thresh, result_inv, u_out, vt_out) + + real(dp), intent(in) :: in_matrix(:,:) + real(dp), intent(in), optional :: thresh + real(dp), intent(out), dimension(:,:), optional :: u_out, vt_out + real(dp), intent(out), dimension(:,:), optional :: result_inv + + real(dp), allocatable :: w(:), sigmainv(:,:), u(:,:), vt(:,:) + real(dp), allocatable :: work(:) + integer :: n, m, k, info, i, lwork, j + + real(dp) :: thresh_use + + call print('entering inverse_svd_threshold', verbosity=PRINT_VERBOSE) + + m = size(in_matrix,1) + n = size(in_matrix,2) + k = min(m, n) + !call print('Dimension of the Matrix : '//m//' x '//n, verbosity=PRINT_VERBOSE) + + allocate(w(k), sigmainv(n,m), u(m,m), vt(n,n)) + + lwork = -1 + allocate(work(1)) + call DGESVD('A','A', m,n,in_matrix,m, w, u,m, vt,n, work, lwork, info) + + lwork = work(1) + deallocate(work) + allocate(work(lwork)) + + call DGESVD('A','A', m,n,in_matrix,m, w, u,m, vt,n, work, lwork, info) + call print("DGESVD finished with exit code "//info, verbosity=PRINT_VERBOSE) + deallocate(work) + + if (present(result_inv)) then + + if (info /= 0) then + if (info < 0) then + write(line,'(a,i0)')'SVD: Problem with argument ',-info + call system_abort(line) + else + call system_abort('SVD: DBDSQR (called from DGESVD) did not converge') + end if + end if + + do j=1, size(w) + call print("svd values "// j//" "//w(j), verbosity=PRINT_VERBOSE) + end do + call print("smallest, largest value : "//minval(abs(w))//" "//maxval(abs(w)), verbosity=PRINT_VERBOSE) + + if (present(thresh)) then + if (thresh >= 0.0) then + thresh_use = thresh*TOL_SVD + else + thresh_use = abs(thresh)*TOL_SVD*w(1) + endif + else + thresh_use = real(max(m, n), kind=dp) * epsilon(1.0_dp) * w(1) + endif + + sigmainv = 0.0_dp + j = 0 + do i=1, k + if (w(i) < thresh_use) then + sigmainv(i,i) = 0.0_dp + j = j + 1 + else + sigmainv(i,i) = 1.0_dp/w(i) + end if + end do + + call print("the number of zero singular values : "//j, verbosity=PRINT_VERBOSE) + + result_inv = transpose(vt) .mult. sigmainv .mult. transpose(u) + + end if ! on condition of matrix inverting + + if (present(u_out)) u_out = u + if (present(vt_out)) vt_out = vt + + deallocate(w) + deallocate(sigmainv) + deallocate(u) + deallocate(vt) + + call print('finished inverse_svd_threshold', verbosity=PRINT_VERBOSE) + + end subroutine inverse_svd_threshold + + pure function frobenius_norm(this) result(norm) + real(dp), dimension(:,:), intent(in) :: this + real(dp) :: norm + integer :: i, j + + norm = 0.0_dp + do j=1, size(this,2) + do i=1, size(this,1) + norm = norm + this(i,j)**2 + end do + end do + norm = sqrt(norm) + end function frobenius_norm + + ! polynomial switching function for implementing a cutoff - + ! a sigmoid going from 1 to zero smoothly. + ! the first three derivatives are exactly zero at the end points + function poly_switch(r,cutoff_in,transition_width) + + real(dp) :: poly_switch + real(dp), intent(in) :: r, cutoff_in, transition_width + real(dp) :: x, x4 + + if( r > cutoff_in ) then + poly_switch = 0.0_dp + elseif( r > (cutoff_in-transition_width) ) then + x = (r - (cutoff_in - transition_width))/transition_width + x4 = x**4 + poly_switch = 1 - 35.0_dp*(x4) +84.0_dp*(x4*x) - 70.0_dp * (x4*x*x) + 20.0_dp* (x4)*(x**3) + else + poly_switch = 1.0_dp + endif + + end function poly_switch + + function dpoly_switch(r,cutoff_in,transition_width) + + real(dp) :: dpoly_switch + real(dp), intent(in) :: r, cutoff_in, transition_width + real(dp) :: x + + if( r > cutoff_in ) then + dpoly_switch = 0.0_dp + elseif( r > (cutoff_in-transition_width) ) then + x = (r - (cutoff_in - transition_width))/transition_width + dpoly_switch = 140.0_dp *( (x-1.0_dp)**3 )* (x**3) + dpoly_switch = dpoly_switch / transition_width + else + dpoly_switch = 0.0_dp + endif + + end function dpoly_switch + + function d2poly_switch(r,cutoff_in,transition_width) + + real(dp) :: d2poly_switch + real(dp), intent(in) :: r, cutoff_in, transition_width + real(dp) :: x + + if( r > cutoff_in ) then + d2poly_switch = 0.0_dp + elseif( r > (cutoff_in-transition_width) ) then + x = (r - (cutoff_in - transition_width))/transition_width + d2poly_switch = 420.0_dp * (x-1.0_dp)**2 * (x**2) * (2.0_dp*x-1.0_dp) + d2poly_switch = d2poly_switch / (transition_width)**2 + else + d2poly_switch = 0.0_dp + endif + + end function d2poly_switch + + function d3poly_switch(r,cutoff_in,transition_width) + + real(dp) :: d3poly_switch + real(dp), intent(in) :: r, cutoff_in, transition_width + real(dp) :: x + + if( r > cutoff_in ) then + d3poly_switch = 0.0_dp + elseif( r > (cutoff_in-transition_width) ) then + x = (r - (cutoff_in - transition_width))/transition_width + d3poly_switch = 840.0_dp * x * (5.0_dp*(x**3) - 10.0_dp*(x**2) + 6.0_dp*x -1.0_dp ) + d3poly_switch = d3poly_switch / (transition_width)**3 + else + d3poly_switch = 0.0_dp + endif + + end function d3poly_switch + + !################################################################################# + !# + !% Factorial, real result + !# + !################################################################################# + + elemental function factorial(n) result(res) + + ! factorial_real + + integer, intent(in) :: n + real(dp) :: res + integer :: i + + if (n<0) then + res = huge(1.0_dp) + res = res + 1.0_dp + elseif(n <= 20) then + res = factorial_table(n) + else + res=1.0_dp + do i=2,n + res = res*i + end do + end if + + endfunction factorial + + !################################################################################# + !# + !% Factorial, integer result + !# + !################################################################################# + + elemental function factorial_int(n) result(res) + + ! factorial_int + + integer, intent(in) :: n + integer :: res + integer :: i + + if (n<0) then + res = huge(n) + res = res + 1 + else + res=1 + do i=2,n + res = res*i + end do + end if + + endfunction factorial_int + + !################################################################################# + !# + !% Double factorial, real result + !# + !################################################################################# + + recursive function factorial2(n) result(res) + + ! double factorial + + integer, intent(in) :: n + real(dp) :: res + integer :: i + + if( n < -1 ) then + call system_abort('factorial2: negative argument') + else + res = 1.0_dp + do i = 2-mod(n,2), n, 2 + res = res*i + enddo + endif + + endfunction factorial2 + + !################################################################################# + !# + !% Binomial coefficient, real result + !# + !################################################################################# + + recursive function binom(n,r) result(res) + + ! binomial coefficients + + integer, intent(in) :: n,r + real(dp) :: res + integer :: i + + if((n<0) .or. (r<0) .or. (n cutoff_in ) then + cos_cutoff_function = 0.0_dp + else + cos_cutoff_function = 0.5_dp * ( cos(PI*r/cutoff_in) + 1.0_dp ) + endif + !if( r > cutoff_in ) then + ! cutoff = 0.0_dp + !elseif( r > (cutoff_in-S) ) then + ! cutoff = 0.5_dp * ( cos(PI*(r-cutoff_in+S)/S) + 1.0_dp ) + !else + ! cutoff = 1.0_dp + !endif + + endfunction cos_cutoff_function + + function dcos_cutoff_function(r,cutoff_in) + + real(dp) :: dcos_cutoff_function + real(dp), intent(in) :: r, cutoff_in + real(dp), parameter :: S = 0.25_dp + + if( r > cutoff_in ) then + dcos_cutoff_function = 0.0_dp + else + dcos_cutoff_function = - 0.5_dp * PI * sin(PI*r/cutoff_in) / cutoff_in + endif + !if( r > r_cut ) then + ! dcutoff = 0.0_dp + !elseif( r > (cutoff_in-S) ) then + ! dcutoff = - 0.5_dp * PI * sin(PI*(r-cutoff_in+S)/S) / S + !else + ! dcutoff = 0.0_dp + !endif + + endfunction dcos_cutoff_function + + elemental function coordination_function_upper(r,cutoff_in,transition_width) + + real(dp) :: coordination_function_upper + real(dp), intent(in) :: r, cutoff_in, transition_width + + if( r > cutoff_in ) then + coordination_function_upper = 0.0_dp + elseif( r > (cutoff_in-transition_width) ) then + coordination_function_upper = 0.5_dp * ( cos(PI*(r-cutoff_in+transition_width)/transition_width) + 1.0_dp ) + else + coordination_function_upper = 1.0_dp + endif + + endfunction coordination_function_upper + + elemental function dcoordination_function_upper(r,cutoff_in,transition_width) + + real(dp) :: dcoordination_function_upper + real(dp), intent(in) :: r, cutoff_in,transition_width + + if( r > cutoff_in ) then + dcoordination_function_upper = 0.0_dp + elseif( r > (cutoff_in-transition_width) ) then + dcoordination_function_upper = - 0.5_dp * PI * sin(PI*(r-cutoff_in+transition_width)/transition_width) / transition_width + else + dcoordination_function_upper = 0.0_dp + endif + + endfunction dcoordination_function_upper + + elemental function d2coordination_function_upper(r,cutoff_in,transition_width) + + real(dp) :: d2coordination_function_upper + real(dp), intent(in) :: r, cutoff_in,transition_width + + if( r > cutoff_in ) then + d2coordination_function_upper = 0.0_dp + elseif( r > (cutoff_in-transition_width) ) then + d2coordination_function_upper = - 0.5_dp * ((PI/ transition_width)**2) * cos(PI*(r-cutoff_in+transition_width)/transition_width) + else + d2coordination_function_upper = 0.0_dp + endif + + endfunction d2coordination_function_upper + + !NB this third derivative is not continuous! + elemental function d3coordination_function_upper(r,cutoff_in,transition_width) + + real(dp) :: d3coordination_function_upper + real(dp), intent(in) :: r, cutoff_in,transition_width + + if( r > cutoff_in ) then + d3coordination_function_upper = 0.0_dp + elseif( r > (cutoff_in-transition_width) ) then + d3coordination_function_upper = 0.5_dp * ((PI/ transition_width)**3) * sin(PI*(r-cutoff_in+transition_width)/transition_width) + else + d3coordination_function_upper = 0.0_dp + endif + + endfunction d3coordination_function_upper + + + function coordination_function_lower_upper(r,lower_cutoff_in,lower_transition_width, upper_cutoff_in, upper_transition_width) + + real(dp) :: coordination_function_lower_upper + real(dp), intent(in) :: r, lower_cutoff_in, lower_transition_width, upper_cutoff_in, upper_transition_width + + coordination_function_lower_upper = coordination_function(r, upper_cutoff_in, upper_transition_width) * coordination_function(-r, -lower_cutoff_in, lower_transition_width) + + endfunction coordination_function_lower_upper + + function dcoordination_function_lower_upper(r,lower_cutoff_in,lower_transition_width, upper_cutoff_in, upper_transition_width) + + real(dp) :: dcoordination_function_lower_upper + real(dp), intent(in) :: r, lower_cutoff_in, lower_transition_width, upper_cutoff_in, upper_transition_width + + dcoordination_function_lower_upper = dcoordination_function(r, upper_cutoff_in, upper_transition_width) * coordination_function(-r, -lower_cutoff_in, lower_transition_width) - & + coordination_function(r, upper_cutoff_in, upper_transition_width) * dcoordination_function(-r, -lower_cutoff_in, lower_transition_width) + + endfunction dcoordination_function_lower_upper + + subroutine integerDigits(this,base,iDigits,error) + integer, intent(in) :: this, base + integer, dimension(:), intent(out) :: iDigits + integer, intent(out), optional :: error + + integer :: i, my_this + integer, dimension(size(iDigits)) :: baseDigits + + INIT_ERROR(error) + + baseDigits = (/ (i, i = 0, size(iDigits)-1) /) + baseDigits = base ** baseDigits + if( this > sum(baseDigits) ) then + RAISE_ERROR("integerDigits: number too large, wouldn't fit",error) + endif + + my_this = this + do i = size(iDigits), 1, -1 + iDigits(i) = my_this / baseDigits(i) + my_this = mod(my_this,baseDigits(i)) + enddo + + endsubroutine integerDigits + +!!$ +!!$ function fermi_dirac_function(r,cutoff_in,transition_width) +!!$ +!!$ real(dp) :: fermi_dirac_function +!!$ real(dp), intent(in) :: r, cutoff_in, transition_width +!!$ real(dp) :: ex, numerical_zero +!!$ numerical_zero = 1e-16_dp +!!$ +!!$ ex = exp((r-cutoff_in)/transition_width) +!!$ +!!$ if( ex < numerical_zero ) then +!!$ fermi_dirac_function= 1.0_dp +!!$ elseif( 1/ex < numerical_zero) then +!!$ fermi_dirac_function = 0.0_dp +!!$ else +!!$ fermi_dirac_function = 1.0_dp / (ex + 1.0_dp) +!!$ endif +!!$ +!!$ endfunction fermi_dirac_function +!!$ +!!$ +!!$ function d_ln_fermi_dirac_function(r,cutoff_in,transition_width) +!!$ +!!$ real(dp) :: d_ln_fermi_dirac_function +!!$ real(dp), intent(in) :: r, cutoff_in, transition_width +!!$ real(dp) :: ex, numerical_zero +!!$ numerical_zero = 1e-16_dp +!!$ +!!$ ex = exp((r-cutoff_in)/transition_width) +!!$ +!!$ if( ex < numerical_zero ) then +!!$ d_ln_fermi_dirac_function = 0.0_dp +!!$ else +!!$ d_ln_fermi_dirac_function = (-1.0_dp/transition_width)* (r) / (1.0_dp + 1/ex) +!!$ endif +!!$ +!!$ endfunction d_ln_fermi_dirac_function + + subroutine matrix_z_make_hermitian(m, error) + complex(dp), intent(inout) :: m(:,:) + integer, intent(out), optional :: error + integer i, j + + complex(dp) :: v + + INIT_ERROR(error) + + if (.not. is_square(m)) then + RAISE_ERROR("matrix_z_make_hermitian got non-square matrix", error) + endif + + do i=1, size(m,1) + do j=i, size(m,2) + v = 0.5_dp*(m(i,j) + conjg(m(j,i))) + m(i,j) = v + m(j,i) = conjg(v) + end do + end do + end subroutine matrix_z_make_hermitian + + + subroutine matrix_d_make_hermitian(m, error) + real(dp), intent(inout) :: m(:,:) + integer, intent(out), optional :: error + integer i, j + + real(dp) :: v + + INIT_ERROR(error) + + if (.not. is_square(m)) then + RAISE_ERROR("matrix_d_make_hermitian got non-square matrix", error) + endif + + do i=1, size(m,1) + do j=i+1, size(m,2) + v = 0.5_dp*(m(i,j) + m(j,i)) + m(i,j) = v + m(j,i) = v + end do + end do + end subroutine matrix_d_make_hermitian + + +end module linearalgebra_module diff --git a/src/libAtoms/lobpcg.F90 b/src/libAtoms/lobpcg.F90 new file mode 100644 index 0000000000..2d68484a31 --- /dev/null +++ b/src/libAtoms/lobpcg.F90 @@ -0,0 +1,686 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine matrix_general_diagonlise_lobpcg_sandia(A, M, evals, evecs, block_size, & + precond, no_guess, err) + real(dp),intent(in), dimension(:,:) :: A + real(dp),intent(in), dimension(:,:) :: M + real(dp),intent(inout), dimension(:) :: evals + real(dp),intent(inout), dimension(:,:) :: evecs + integer, intent(in), optional :: block_size + real(dp),intent(in), dimension(:,:), optional :: precond(:,:) + logical, intent(in), optional :: no_guess + integer, intent(out), optional :: err + + real(dp), allocatable :: X_twid(:,:), X(:,:), RI(:,:), R(:), PI(:,:), & + HI(:,:), S(:,:), Y(:,:), YI(:,:), A_X(:,:), M_X(:,:), rr_M(:,:), M_HI(:,:), M_YI(:,:) + real(dp), allocatable :: evals_block(:), Y_evals(:) + + logical :: done, failed + logical :: my_no_guess + integer :: n_evecs, n_full_blocks, extra_block_size + integer :: N, i, iter, max_n_iter, bs, cbs, i_block, ii_block, nrr, prev_cbs + integer :: first_eval, last_eval, max_bs, max_n_new_block, got_n_evals + real(dp) :: max_r, max_r_hist(10) + integer :: n_needed + + call print("matrix_general_diagonlise_lobpcg_sandia", PRINT_VERBOSE) + + N = size(A, 1) + + my_no_guess = optional_default(.true., no_guess) + max_bs = optional_default(1, block_size) + + n_evecs = size(evals) + if (n_evecs /= size(evecs,2)) & + call system_abort("called matrix_general_digonalise_lobpcg_sandia with mismatched evals and evecs size") + + call print("matrix_general_diagonalise_lpbpcg_sandia n_evecs " // & + n_evecs // " block_size " // max_bs, PRINT_VERBOSE) + + call print("n_full_blocks " // n_full_blocks // " extra_block_size " // extra_block_size, PRINT_VERBOSE) + + ! randomise evecs + if (my_no_guess) then + evecs = 0.0_dp + do i=1, n_evecs + call randomise(evecs(:,i), 1.0_dp) + end do + endif + + max_n_iter = 200 + max_n_new_block = 30 + + allocate(X_twid(N,max_bs)) + allocate(X(N,max_bs)) + allocate(A_X(N,max_bs)) + allocate(M_X(N,max_bs)) + allocate(evals_block(max_bs)) + allocate(R(N)) + allocate(RI(N,max_bs)) + allocate(PI(N,max_bs)) + allocate(HI(N,max_bs)) + allocate(M_HI(N,max_bs)) + allocate(Y(3*max_bs,max_bs)) + allocate(YI(3*max_bs,max_bs)) + allocate(M_YI(3*max_bs,max_bs)) + allocate(Y_evals(max_bs)) + allocate(S(N,3*max_bs)) + allocate(rr_M(3*max_bs,3*max_bs)) + + got_n_evals = 0 + i_block = 1 + failed = .false. + do while (got_n_evals < n_evecs .and. .not. failed) + + first_eval = got_n_evals + 1 + last_eval = min(first_eval+max_bs-1, N) + bs = last_eval-first_eval+1 + + call print("doing block " // first_eval // " - " // last_eval, PRINT_VERBOSE) + + n_needed = n_evecs-first_eval + ! copy block of eigenvectors + X_twid(1:N,1:min(bs,n_needed)) = evecs(1:N,first_eval:min(last_eval,n_evecs)) + if (n_needed < bs) then + do i=n_needed+1, bs + call randomise(X_twid(1:N,i), 1.0_dp) + end do + endif + + if (first_eval > 1) then + call matrix_product_sub(X(1:N,1:bs), M(1:N,1:N), X_twid(1:N,1:bs)) + call orthogonalise_col_vectors(X_twid(1:N,1:bs), evecs(1:N,1:first_eval-1), X(1:N,1:bs)) + endif + + call rr_solve(X_twid(1:N,1:bs), A(1:N,1:N), M(1:N,1:N), Y(1:bs,1:bs), Y_evals(1:bs)) + call matrix_product_sub(X(1:N,1:bs),X_twid(1:N,1:bs),Y(1:bs,1:bs)) + call matrix_product_sub(A_X(1:N,1:bs), A(1:N,1:N), X(1:N,1:bs)) + call matrix_product_sub(M_X(1:N,1:bs), M(1:N,1:N), X(1:N,1:bs)) + do i=1, bs + RI(1:N,i) = A_X(1:N,i) - Y_evals(i)*M_X(1:N,i) + end do + PI(1:N,1:bs) = 0.0_dp + cbs = bs + iter = 1 + done = .false. + max_r_hist = 1e38_dp + do while (iter < max_n_iter .and. .not. done .and. .not. failed) + call print("doing iter "//iter, PRINT_NERD) + if (present(precond)) then + call matrix_product_sub(HI(1:N,1:cbs), precond(1:N,1:N), RI(1:N,1:cbs)) + else + HI(1:N,1:cbs) = RI(1:N,1:cbs) + endif + + S(1:N,1:bs) = X(1:N,1:bs) + S(1:N,bs+1:bs+cbs) = PI(1:N,1:cbs) + + call matrix_product_sub(M_HI(1:N,1:cbs), M(1:N,1:N), HI(1:N,1:cbs)) + call orthogonalise_col_vectors(HI(1:N,1:cbs), S(1:N,1:bs+cbs), M_HI(1:N,1:cbs)) + + if (first_eval > 1) then + call orthogonalise_col_vectors(HI(1:N,1:cbs), evecs(1:N,1:first_eval-1), M_HI(1:N,1:cbs)) + end if + + S(1:N,1:bs) = X(1:N,1:bs) + S(1:N,bs+1:bs+cbs) = HI(1:N,1:cbs) + S(1:N,bs+cbs+1:bs+2*cbs) = PI(1:N,1:cbs) + if (iter == 1) then + nrr = bs+cbs + else + nrr = bs+2*cbs + endif + call rr_solve(S(1:N,1:nrr), A(1:N,1:N), M(1:N,1:N), Y(1:nrr,1:bs), Y_evals(1:bs), & + rr_M=rr_M(1:nrr,1:nrr)) + + call matrix_product_sub(X(1:N,1:bs), S(1:N,1:nrr), Y(1:nrr,1:bs)) + + call matrix_product_sub(A_X(1:N,1:bs), A(1:N,1:N), X(1:N,1:bs)) + call matrix_product_sub(M_X(1:N,1:bs), M(1:N,1:N), X(1:N,1:bs)) + if (iter == 1) then + YI = 0.0_dp + endif + prev_cbs = cbs + cbs = 0 + max_r = 0.0_dp + do i=1, bs + R(1:N) = A_X(1:N,i) - Y_evals(i)*M_X(1:N,i) + max_r = max(max_R, maxval(abs(R))) + if (maxval(abs(R(1:N))) > 1.0e-7_dp) then ! column not converged + cbs = cbs + 1 + RI(1:N,cbs) = R(1:N) + YI(1:nrr,cbs) = Y(1:nrr,i) + endif + end do + call print("residual max " // max_r // " cbs " // cbs, PRINT_VERBOSE) + max_r_hist(1:9) = max_r_hist(2:10) + max_r_hist(10) = max_r + + if (prev_cbs < cbs) then + call print("diverging, but block partially converged " // (bs-cbs), PRINT_VERBOSE) + done = .true. + n_needed = n_evecs-first_eval+1 + got_n_evals = got_n_evals + (bs-cbs) + ! copy all evecs and converged evals + evecs(1:N,first_eval:min(first_eval+(bs)-1,n_evecs)) = X(1:N,1:min(bs,n_needed)) + evals(first_eval:min(first_eval+(bs-cbs)-1,n_evecs)) = Y_evals(1:min(bs-cbs,n_needed)) + else if (cbs == 0) then ! all converged + done = .true. + n_needed = n_evecs-first_eval+1 + got_n_evals = got_n_evals + bs + ! copy converged evecs/evals + evecs(1:N,first_eval:min(last_eval,n_evecs)) = X(1:N,1:min(bs,n_needed)) + evals(first_eval:min(last_eval,n_evecs)) = Y_evals(1:min(bs,n_needed)) + else if (got_n_evals+(bs-cbs) >= n_evecs) then + call print("enough evecs done, but block partially converged " // (bs-cbs), PRINT_VERBOSE) + done = .true. + n_needed = n_evecs-first_eval+1 + got_n_evals = got_n_evals + (bs-cbs) + ! copy all evecs and converged evals + evecs(1:N,first_eval:min(first_eval+(bs)-1,n_evecs)) = X(1:N,1:min(bs,n_needed)) + evals(first_eval:min(first_eval+(bs-cbs)-1,n_evecs)) = Y_evals(1:min(bs-cbs,n_needed)) + else if (cbs /= bs .and. (iter > max_n_new_block .or. max_r_hist(10) > max_r_hist(5)*0.75_dp)) then + call print("block partially converged " // (bs-cbs), PRINT_VERBOSE) + done = .true. + n_needed = n_evecs-first_eval+1 + got_n_evals = got_n_evals + (bs-cbs) + ! copy all evecs and converged evals + evecs(1:N,first_eval:min(first_eval+(bs)-1,n_evecs)) = X(1:N,1:min(bs,n_needed)) + evals(first_eval:min(first_eval+(bs-cbs)-1,n_evecs)) = Y_evals(1:min(bs-cbs,n_needed)) + else + done = .false. + YI(1:bs,1:cbs) = 0.0_dp + call matrix_product_sub(M_YI(1:nrr,1:bs), rr_M(1:nrr,1:nrr), YI(1:nrr, 1:bs)) + call orthogonalise_col_vectors(YI(1:nrr,1:cbs), Y(1:nrr,1:bs), M_YI(1:nrr,1:cbs)) + + call matrix_product_sub(PI(1:N,1:cbs), S(1:N,1:nrr), YI(1:nrr,1:cbs)) + endif + + iter = iter + 1 + + end do ! iter + call print("block " // i_block // " took " // iter // " iterations") + if (iter >= max_n_iter) then + failed = .true. + endif + end do ! i_block + + deallocate(X_twid) + deallocate(X) + deallocate(A_X) + deallocate(M_X) + deallocate(evals_block) + deallocate(R) + deallocate(RI) + deallocate(PI) + deallocate(HI) + deallocate(M_HI) + deallocate(Y) + deallocate(YI) + deallocate(M_YI) + deallocate(Y_evals) + deallocate(S) + deallocate(rr_M) + + if (present(err)) err = 0 + + if (failed) then + if (present(err)) then + err = 1 + call print("matrix_general_diagonalise_lobpcg_sandia failed") + return + else + call system_abort("matrix_general_diagonalise_lobpcg_sandia failed") + endif + endif + + end subroutine matrix_general_diagonlise_lobpcg_sandia + + subroutine rr_solve(X, A, M, Y, evals, rr_A, rr_M) + real(dp), intent(in) :: X(:,:), A(:,:), M(:,:) + real(dp), intent(out) :: Y(:,:) + real(dp), intent(out) :: evals(:) + real(dp), intent(out), target, optional :: rr_A(:,:), rr_M(:,:) + + integer :: N, rr_size + real(dp), allocatable :: YY(:,:), ev(:) + real(dp), allocatable :: A_X(:,:), M_X(:,:) + real(dp), pointer :: l_rr_A(:,:), l_rr_M(:,:) + + if (size(A,1) /= size(A,2)) call system_abort("called rr_solve with non-square A") + if (size(M,1) /= size(M,2)) call system_abort("called rr_solve with non-square M") + if (size(X,1) /= size(A,1)) call system_abort("called rr_solve with X size not matching A/M size") + if (size(X,2) /= size(Y,1)) call system_abort("called rr_solve with X size not matching Y size") + if (size(X,2) < size(Y,2)) call system_abort("called rr_solve with X size too small for Y size") + if (size(X,2) < size(evals)) call system_abort("called rr_solve with Y size too small for evals size") + + N = size(X,1) + rr_size = size(X,2) + + if (present(rr_A)) then + if (size(rr_A,1) /= size(rr_A,2)) call system_abort("called rr_solve with non-square rr_A") + if (size(rr_A,1) /= rr_size) call system_abort("called rr_solve with rr_A size not matching X size") + l_rr_A => rr_A + else + allocate(l_rr_A(rr_size,rr_size)) + endif + if (present(rr_M)) then + if (size(rr_M,1) /= size(rr_M,2)) call system_abort("called rr_solve with non-square rr_M") + if (size(rr_M,1) /= rr_size) call system_abort("called rr_solve with rr_M size not matching X size") + l_rr_M => rr_M + else + allocate(l_rr_M(rr_size,rr_size)) + endif + + allocate(YY(rr_size,rr_size)) + allocate(ev(rr_size)) + allocate(A_X(N,rr_size)) + allocate(M_X(N,rr_size)) + + call matrix_product_sub(A_X(1:N,1:rr_size), A(1:N,1:N), X(1:N,1:rr_size)) + call matrix_product_sub(M_X(1:N,1:rr_size), M(1:N,1:N), X(1:N,1:rr_size)) + call matrix_product_sub(l_rr_A(1:rr_size,1:rr_size), X(1:N,1:rr_size), A_X(1:N,1:rr_size), & + m1_transpose=.true., m2_transpose=.false.) + call matrix_product_sub(l_rr_M(1:rr_size,1:rr_size), X(1:N,1:rr_size), M_X(1:N,1:rr_size), & + m1_transpose=.true., m2_transpose=.false.) + + call diagonalise(l_rr_A, l_rr_M, ev, YY) + + evals(:) = ev(1:size(evals)) + Y(1:rr_size,:) = YY(1:rr_size,1:size(Y,2)) + + deallocate(YY) + deallocate(ev) + deallocate(A_X) + deallocate(M_X) + if (.not. present(rr_A)) deallocate(l_rr_A) + if (.not. present(rr_M)) deallocate(l_rr_M) + end subroutine rr_solve + +! subroutine matrix_general_diagonlise_lobpcg(B, A, evals, evecs, n_evecs, block_size, & +! precond, no_guess, largest, err) +! real(dp),intent(in), dimension(:,:) :: A +! real(dp),intent(in), dimension(:,:) :: B +! real(dp),intent(inout), dimension(:) :: evals +! real(dp),intent(inout), dimension(:,:) :: evecs +! integer, intent(in), optional :: n_evecs +! integer, intent(in), optional :: block_size +! real(dp),intent(in), dimension(:,:), optional :: precond(:,:) +! logical, intent(in), optional :: no_guess +! logical, intent(in), optional :: largest +! integer, intent(out), optional :: err +! +! logical :: my_no_guess, my_largest +! integer :: my_n_evecs, my_block_size +! integer :: i_block, ii_block, n_full_blocks, extra_block_size +! integer :: i, j +! integer :: N +! integer :: iter, max_n_iter +! real(dp), allocatable :: evals_block(:) +! real(dp), allocatable :: RR_evals(:) +! real(dp), allocatable :: tt(:,:), R(:,:), W(:,:), P(:,:), RR_basis(:,:), RR_basis_AorB(:,:), & +! RR_mat_A(:,:), RR_mat_B(:,:), evecs_block(:,:), A_evecs_block(:,:), B_evecs_block(:,:) +! real(dp), allocatable :: RR_evecs(:,:) +! logical :: done +! +! integer :: i_max, rr_min, rr_max, rr_step +! real(dp) :: mag +! +! call print("matrix_general_diagonlise_lobpcg", PRINT_VERBOSE) +! +! N = size(A, 1) +! call print("N " // N, PRINT_VERBOSE) +! +! my_no_guess = optional_default(.true., no_guess) +! my_largest = optional_default(.false., largest) +! my_n_evecs = optional_default(N, n_evecs) +! my_block_size = optional_default(1, block_size) +! n_full_blocks = my_n_evecs/my_block_size +! extra_block_size = my_n_evecs - n_full_blocks*my_block_size +! if (extra_block_size /= 0) & +! call system_abort("lobpcg can't handle non integer number of blocks yet") +! +! call print("matrix_general_diagonalise_lobpcg n_evecs " // & +! my_n_evecs // " block_size " // my_block_size, PRINT_VERBOSE) +! +! call print("n_full_blocks " // n_full_blocks // " extra_block_size " // extra_block_size, PRINT_VERBOSE) +! +! allocate(evecs_block(N, my_block_size)) +! allocate(A_evecs_block(N, my_block_size)) +! allocate(B_evecs_block(N, my_block_size)) +! allocate(evals_block(my_block_size)) +! allocate(tt(N, my_block_size)) +! allocate(R(N, my_block_size)) +! allocate(W(N, my_block_size)) +! allocate(P(N, my_block_size)) +! allocate(RR_basis(N, 3*my_block_size)) +! allocate(RR_basis_AorB(N, 3*my_block_size)) +! allocate(RR_mat_A(3*my_block_size, 3*my_block_size)) +! allocate(RR_mat_B(3*my_block_size, 3*my_block_size)) +! allocate(RR_evecs(3*my_block_size, 3*my_block_size)) +! allocate(RR_evals(3*my_block_size)) +! +! ! randomise evecs +! if (my_no_guess) then +! evecs = 0.0_dp +! do i=1, n_evecs +! call randomise(evecs(:,i), 1.0_dp) +! end do +! endif +! +! max_n_iter = 100 +! +! do i_block=1, n_full_blocks +! call print("doing block " // i_block, PRINT_VERBOSE) +! +! ! copy block of eigenvectors +! evecs_block = evecs(:,(i_block-1)*my_block_size+1:i_block*my_block_size) +! call print("raw evecs_block", PRINT_ANALYSIS) +! call print(evecs_block, PRINT_ANALYSIS) +! +! ! A orthogonalize evecs_block w.r.t. previous blocks +! do ii_block=1, i_block-1 +! call orthogonalise_col_vectors(evecs_block, & +! evecs(:,(ii_block-1)*my_block_size+1:ii_block*my_block_size), A) +! end do +! +! call print("orthogonalized evecs_block", PRINT_ANALYSIS) +! call print(evecs_block, PRINT_ANALYSIS) +! +! P = 0.0_dp +! iter = 1 +! done = .false. +! do while (iter <= max_n_iter .and. .not. done) +! call print("doing iter " // iter, PRINT_NERD) +! +! ! evaluate eigenvalues +! call matrix_product_sub(A_evecs_block, A, evecs_block) +! call matrix_product_sub(B_evecs_block, B, evecs_block) +! if (iter == 1) & +! evals_block(:) = sum(evecs_block*B_evecs_block,1)/ & +! sum(evecs_block*A_evecs_block,1) +! +! call print("evals_block", PRINT_NERD) +! call print(evals_block, PRINT_NERD) +! call print("evecs_block", PRINT_ANALYSIS) +! call print(evecs_block, PRINT_ANALYSIS) +! +! ! evaluate residual +! do i=1, block_size +! R(:,i) = B_evecs_block(:,i) - evals_block(i)*A_evecs_block(:,i) +! end do +! +! call print("R", PRINT_ANALYSIS) +! call print(R, PRINT_ANALYSIS) +! +! mainlog%default_real_precision=16 +! call print("residual max " // maxval(abs(R)), PRINT_VERBOSE) +! mainlog%default_real_precision=8 +! done = (maxval(abs(R)) < 1.0e-8_dp) +! +! if (.not. done) then +! +! ! precondition +! if (present(precond)) then +! call matrix_product_sub(W, precond, R) +! else +! W = R +! endif +! +! call print("W", PRINT_ANALYSIS) +! call print(W, PRINT_ANALYSIS) +! +! ! A orthogonalize W w.r.t. previous blocks +! do ii_block=1, i_block-1 +! call orthogonalise_col_vectors(W, & +! evecs(:,(ii_block-1)*my_block_size+1:ii_block*my_block_size), A) +! end do +! +! call print("orthogonalized W", PRINT_ANALYSIS) +! call print(W, PRINT_ANALYSIS) +! +! call print("P", PRINT_ANALYSIS) +! call print(P, PRINT_ANALYSIS) +! +! ! evaluate Rayleigh-Ritz basis +! RR_basis(:,1:my_block_size) = evecs_block +! RR_basis(:,my_block_size+1:2*my_block_size) = W +! RR_basis(:,2*my_block_size+1:3*my_block_size) = P +! +! +! call print("RR_basis", PRINT_ANALYSIS) +! call print(RR_basis, PRINT_ANALYSIS) +! +! ! evaluate Rayleigh-Ritz matrices +! call matrix_product_sub(RR_basis_AorB, A, RR_basis) +! +! call matrix_product_sub(RR_mat_A, RR_basis_AorB, RR_basis, & +! m1_transpose=.true., m2_transpose=.false.) +! call print("RR_mat_A", PRINT_ANALYSIS) +! call print(RR_mat_A, PRINT_ANALYSIS) +! call matrix_product_sub(RR_basis_AorB, B, RR_basis) +! call matrix_product_sub(RR_mat_B, RR_basis_AorB, RR_basis, & +! m1_transpose=.true., m2_transpose=.false.) +! call print("RR_mat_B", PRINT_ANALYSIS) +! call print(RR_mat_B, PRINT_ANALYSIS) +! +! ! diagonalise Rayleigh-Ritz matrix +! if (iter == 1) then +! call diagonalise(RR_mat_B(1:2*block_size,1:2*block_size), & +! RR_mat_A(1:2*block_size,1:2*block_size), & +! RR_evals(1:2*block_size), RR_evecs(1:2*block_size,1:2*block_size)) +! call print("RR_evals", PRINT_NERD) +! call print(RR_evals(1:2*block_size), PRINT_NERD) +! call print("RR_evecs", PRINT_ANALYSIS) +! call print(RR_evecs(1:2*block_size,1:2*block_size), PRINT_ANALYSIS) +! else +! call diagonalise(RR_mat_B, RR_mat_A, RR_evals, RR_evecs) +! call print("RR_evals", PRINT_NERD) +! call print(RR_evals, PRINT_NERD) +! call print("RR_evecs", PRINT_ANALYSIS) +! call print(RR_evecs, PRINT_ANALYSIS) +! endif +! +! if (iter == 1) then +! i_max = 2*my_block_size +! if (my_largest) then +! rr_min = 2*my_block_size +! rr_max = my_block_size+1 +! rr_step = -1 +! else +! rr_min = my_block_size+1 +! rr_max = 2*my_block_size +! rr_step = 1 +! endif +! else +! i_max = 3*my_block_size +! if (my_largest) then +! rr_min = 3*my_block_size +! rr_max = 2*my_block_size+1 +! rr_step = -1 +! else +! rr_min = 2*my_block_size+1 +! rr_max = 3*my_block_size +! rr_step = 1 +! endif +! endif +! +! ! Create new evecs from Rayleigh-Ritz vectors +! call matrix_product_sub(evecs_block, RR_basis(:,1:i_max), & +! RR_evecs(1:i_max,rr_min:rr_max:rr_step)) +! +! ! copy Rayleigh-Ritz evals (ignored, because of orthogonalization) +! evals_block = RR_evals(rr_min:rr_max:rr_step) +! +! ! Create new Ps from Rayleigh-Ritz vectors +! RR_evecs(1:my_block_size,:) = 0.0_dp +! call matrix_product_sub(P, RR_basis(:,1:i_max), RR_evecs(1:i_max,rr_min:rr_max:rr_step)) +! +! iter = iter + 1 +! end if +! end do ! while not converged +! +! if (.not. done) then +! if (present(err)) then +! err = 1 +! deallocate(evecs_block) +! deallocate(A_evecs_block) +! deallocate(B_evecs_block) +! deallocate(evals_block) +! deallocate(tt) +! deallocate(R) +! deallocate(W) +! deallocate(P) +! deallocate(RR_basis) +! deallocate(RR_basis_AorB) +! deallocate(RR_mat_A) +! deallocate(RR_mat_B) +! deallocate(RR_evecs) +! deallocate(RR_evals) +! return +! else +! call system_abort("matrix_general_diagonalise_lobpcg failed to converge in " // & +! iter // " iterations") +! endif +! endif +! +! ! copy blocks back into main arrays +! evecs(:,(i_block-1)*my_block_size+1:i_block*my_block_size) = evecs_block +! evals((i_block-1)*my_block_size+1:i_block*my_block_size) = evals_block +! call print("block " // i_block // " took " // iter // " iterations") +! +! end do ! i_block +! +! if (present(err)) err = 0 +! +! deallocate(evecs_block) +! deallocate(A_evecs_block) +! deallocate(B_evecs_block) +! deallocate(evals_block) +! deallocate(tt) +! deallocate(R) +! deallocate(W) +! deallocate(P) +! deallocate(RR_basis) +! deallocate(RR_basis_AorB) +! deallocate(RR_mat_A) +! deallocate(RR_mat_B) +! deallocate(RR_evecs) +! deallocate(RR_evals) +! +! end subroutine matrix_general_diagonlise_lobpcg +! +! +! ! assume A is symmetric +! subroutine orthogonalise_col_vectors(V1, V2, A) +! real(dp), intent(inout) :: V1(:,:) +! real(dp), intent(in) :: V2(:,:) +! real(dp), intent(in), optional :: A(:,:) +! +! real(dp), allocatable :: A_V1(:,:), V2_V2T(:,:) +! integer :: N, n_v1, n_v2 +!integer i +! +! if (present(A)) then +! if (size(A,2) /= size(V1,1)) & +! call system_abort("called orthogonalise_col_vectors with V1 size not matching A size") +! if (size(A,1) /= size(V2,1)) & +! call system_abort("called orthogonalise_col_vectors with V2 size not matching A size") +! else +! if (size(V1,1) /= size(V2,1)) & +! call system_abort("called orthogonalise_col_vectors with V1 size not matching V2 size") +! endif +! +! if (present(A)) then +! allocate(A_V1(size(A,1),size(V1,2))) +! call matrix_product_sub(A_V1, A, V1) +! endif +! +! allocate(V2_V2T(size(V2,1), size(V2,1))) +! call matrix_product_sub(V2_V2T, V2, V2, m1_transpose=.false., m2_transpose=.true.) +! +! if (present(A)) then +! call matrix_product_sub(V1, V2_V2T, A_V1, lhs_factor=1.0_dp, rhs_factor=-1.0_dp) +!call matrix_product_sub(A_V1, A, V1) +!do i=1, size(V1,2) +! V1(:,i) = V1(:,i)/sqrt(sum(V1(:,i)*A_V1(:,i))) +!end do +! deallocate(A_V1) +! else +! call matrix_product_sub(V1, V2_V2T, V1, lhs_factor=1.0_dp, rhs_factor=-1.0_dp) +!do i=1, size(V1,2) +! V1(:,i) = V1(:,i)/sqrt(sum(V1(:,i)*V1(:,i))) +!end do +! endif +! deallocate(V2_V2T) +! +! end subroutine orthogonalise_col_vectors + + ! assume A is symmetric + subroutine orthogonalise_col_vectors(V1, V2, A_V1) + real(dp), intent(inout) :: V1(:,:) + real(dp), intent(in) :: V2(:,:) + real(dp), intent(inout), optional :: A_V1(:,:) + + real(dp), allocatable :: V2_V2T(:,:) + real(dp) :: mag + integer :: i + + if (present(A_V1)) then + if (size(A_V1,1) /= size(V1,1)) & + call system_abort("called orthogonalise_col_vectors with V1 size not matching A_V1 size") + if (size(A_V1,2) /= size(V1,2)) & + call system_abort("called orthogonalise_col_vectors with V1 size not matching A_V1 size") + else + if (size(V1,1) /= size(V2,1)) & + call system_abort("called orthogonalise_col_vectors with V1 size not matching V2 size") + endif + + allocate(V2_V2T(size(V2,1), size(V2,1))) + call matrix_product_sub(V2_V2T, V2, V2, m1_transpose=.false., m2_transpose=.true.) + + if (present(A_V1)) then + call matrix_product_sub(V1, V2_V2T, A_V1, lhs_factor=1.0_dp, rhs_factor=-1.0_dp) + do i=1, size(V1,2) + mag = sqrt(sum(V1(:,i)*A_V1(:,i))) + V1(:,i) = V1(:,i)/mag + A_V1(:,i) = A_V1(:,i)/mag + end do + else + call matrix_product_sub(V1, V2_V2T, V1, lhs_factor=1.0_dp, rhs_factor=-1.0_dp) + do i=1, size(V1,2) + V1(:,i) = V1(:,i)/sqrt(sum(V1(:,i)*V1(:,i))) + end do + endif + + deallocate(V2_V2T) + + end subroutine orthogonalise_col_vectors diff --git a/src/libAtoms/minimal_md.F90 b/src/libAtoms/minimal_md.F90 new file mode 100644 index 0000000000..b64fa04eed --- /dev/null +++ b/src/libAtoms/minimal_md.F90 @@ -0,0 +1,102 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +program md + use libAtoms_module + + implicit none + + real(dp), parameter :: dt = 1.0_dp ! Time step + real(dp), parameter :: init_temp = 300.0_dp + + type(DynamicalSystem) :: ds + type(Atoms) :: at, tmpat + type(cinoutput) :: movie + real(dp), allocatable :: f(:,:) + real(dp) :: Q + integer :: n + + call system_initialise + call initialise(movie, "movie.xyz", action=OUTPUT) + call diamond(tmpat, 3.5_dp) + call supercell(at, tmpat, 2, 2, 2) + call set_atoms(at, 6) + allocate(f(3,at%N)) ! Allocate force array + + call set_cutoff(at,3.0_dp) + call calc_connect(at) + call calc_dists(at) + call initialise(ds, at) + call rescale_velo(ds, init_temp) + call zero_momentum(ds) + + + Q = nose_hoover_mass(Ndof = 3*ds%N, T = init_temp, tau = 1000.0_dp) ! This 'tau' is the characteristic time of your system, + ! e.g. from phonon spectrum, and controls the coupling + ! of the thermostat to the system: + ! higher tau = higher mass = lower coupling + + call add_thermostat(ds, THERMOSTAT_NOSE_HOOVER_LANGEVIN, init_temp, Q = Q, tau = 5000.0_dp) ! This tau controls how fast the nose-hoover variable + ! explores phase space. + ! higher tau = slower, and more Nose-Hoover like. + +! call add_thermostat(ds, THERMOSTAT_NOSE_HOOVER, init_temp, Q = Q) +! call add_thermostat(ds, THERMOSTAT_LANGEVIN, init_temp, tau = 1000.0_dp) + + ! Use random forces + f = 0.0_dp + call randomise(f, 0.1_dp) + call zero_sum(f) + + do n = 1, 1000 + call ds_print_status(ds, 'M') + if(mod(n, 20) == 0) then + call write(ds%atoms,movie) + call calc_connect(ds%atoms) + end if + + call advance_verlet1(ds, dt) + + !Calculate new forces + f = 0.0_dp + call randomise(f, 0.1_dp) + call zero_sum(f) + + call advance_verlet2(ds, dt, f) + + end do + + call finalise(at) + call finalise(ds) + call finalise(movie) + deallocate(f) + + call system_finalise() +end program md diff --git a/src/libAtoms/minimization.F90 b/src/libAtoms/minimization.F90 new file mode 100644 index 0000000000..9cf575fbe8 --- /dev/null +++ b/src/libAtoms/minimization.F90 @@ -0,0 +1,6246 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!X +!X Minimization module +!X +!% This module contains subroutines to perform conjugate gradient and +!% damped MD minimisation of an objective function. +!% The conjugate gradient minimiser can use various different line minimisation routines. +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" +module minimization_module + + use error_module + use system_module + use linearalgebra_module + implicit none + private + SAVE + + public :: minim, n_minim, fire_minim, test_gradient, n_test_gradient, precon_data, preconminim, precondimer + + public :: KahanSum, DoubleKahanSum + + real(dp),parameter:: DXLIM=huge(1.0_dp) !% Maximum amount we are willing to move any component in a linmin step + + ! parameters from Numerical Recipes */ + real(dp),parameter:: GOLD=1.618034_dp + integer, parameter:: MAXFIT=5 + real(dp),parameter:: TOL=1e-2_dp + real(dp),parameter:: CGOLD=0.3819660_dp + real(dp),parameter:: ZEPS=1e-10_dp + integer, parameter:: ITER=50 + + type precon_data + logical :: multI = .FALSE. + logical :: diag = .FALSE. + logical :: dense = .FALSE. + integer, allocatable :: preconrowlengths(:) + integer, allocatable :: preconindices(:,:) + real(dp), allocatable :: preconcoeffs(:,:,:) + character(10) :: precon_id + integer :: nneigh,mat_mult_max_iter,max_sub + real(dp) :: energy_scale,length_scale,cutoff,res2 + logical :: has_fixed = .FALSE. + real(dp) :: cell_coeff = 1.0_dp + real(dp) :: bulk_modulus, number_density, mu + end type precon_data + integer, parameter :: E_FUNC_BASIC=1, E_FUNC_KAHAN=2, E_FUNC_DOUBLEKAHAN=3 + + interface minim + module procedure minim + end interface + + interface preconminim + module procedure preconminim + end interface + + interface precondimer + module procedure precondimer + end interface + + interface test_gradient + module procedure test_gradient + end interface + + interface n_test_gradient + module procedure n_test_gradient + end interface + + interface smartmatmul + module procedure smartmatmulmat, smartmatmulvec + end interface + + ! LBFGS stuff + external QUIPLB2 + integer::MP,LP + real(dp)::GTOL,STPMIN,STPMAX + common /lb3/MP,LP,GTOL,STPMIN,STPMAX + +CONTAINS + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Smart line minimiser, adapted from Numerical Recipes. + !% The objective function is 'func'. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function linmin(x0,xdir,y,epsilon,func,data) + real(dp) :: x0(:) !% Starting position + real(dp) :: xdir(:)!% Direction of gradient at 'x0' + real(dp) :: y(:) !% Finishing position returned in 'y' after 'linmin' + real(dp)::epsilon !% Initial step size + INTERFACE + function func(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + end function func + END INTERFACE + character(len=1),optional::data(:) + integer:: linmin + + integer::i,it,sizeflag,N, bracket_it + real(dp)::Ea,Eb,Ec,a,b,c,r,q,u,ulim,Eu,fallback + real(dp)::v,w,x,Ex,Ev,Ew,e,d,xm,tol1,tol2,p,etmp + + ! Dynamically allocate to avoid stack overflow madness with ifort + real(dp), dimension(:), allocatable :: tmpa, tmpb, tmpc, tmpu + + !%RV Number of linmin steps taken, or zero if an error occured + + N=size(x0) + + allocate(tmpa(N), tmpb(N), tmpc(N), tmpu(N)) + tmpa=x0 + y=x0 + +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Ea=func(tmpa,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print(" Linmin: Ea = " // Ea // " a = " // 0.0_dp, PRINT_NORMAL) + Eb= Ea + 1.0_dp !just to start us off + + a=0.0_dp + b=2.0_dp*epsilon + + + ! lets figure out if we can go downhill at all + + it = 2 + do while( (Eb.GT.Ea) .AND. (.NOT.(Eb.FEQ.Ea))) + + b=b*0.5_dp + tmpb(:)= x0(:)+b*xdir(:) + +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Eb=func(tmpb,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print(" Linmin: Eb = " // Eb // " b = " // b, PRINT_VERBOSE) + it = it+1 + + if(b.LT.1.0e-20) then + + write(line,*) " Linmin: Direction points the wrong way\n" ; call print(line, PRINT_NORMAL) + + epsilon=0.0_dp + linmin=0 + return + end if + end do + + ! does it work in fortran? + ! two: if(isnan(Eb)) then + + ! write(global_err%unit,*) "linmin: got a NaN!" + ! epsilon=0 + ! linmin=0 + ! return + ! end if two + + if(Eb.FEQ.Ea) then + + epsilon=b + linmin=1 + call print(" Linmin: Eb.feq.Ea, returning after one step", PRINT_VERBOSE) + return + end if + + ! we now have Ea > Eb */ + + fallback = b ! b is the best point so far, make that the fallback + + write(line,*) " Linmin: xdir is ok.."; call print(line,PRINT_VERBOSE) + + c = b + GOLD*b !first guess for c */ + tmpc = x0 + c*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Ec = func(tmpc,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print(" Linmin: Ec = " // Ec // " c = " // c, PRINT_VERBOSE) + it = it + 1 + ! ! does it work in fortran? + ! four: if(isnan(Ec)) then + + ! write(global_err%unit,*) "linmin: Ec is a NaN!" + ! epsilon=0 + ! linmin=0 + ! return + ! end if four + + + + + + !let's bracket the minimum + + do while(Eb.GT.Ec) + + write(line,*) a,Ea; call print(line,PRINT_VERBOSE) + write(line,*) b,Eb; call print(line,PRINT_VERBOSE) + write(line,*) c,Ec; call print(line,PRINT_VERBOSE) + + + + + ! compute u by quadratic fit to a, b, c + + + !inverted ????????????????????? + r = (b-a)*(Eb-Ec) + q = (b-c)*(Eb-Ea) + u = b-((b-c)*q-(b-a)*r)/(2.0_dp*max(abs(q-r), 1.0e-20_dp)*sign(q-r)) + + ulim = b+MAXFIT*(c-b) + + write(line,*) "u= ",u ; call print(line,PRINT_VERBOSE) + + + if((u-b)*(c-u).GT. 0) then ! b < u < c + + write(line,*)"b < u < c" ; call print(line,PRINT_VERBOSE) + + tmpu = x0 + u*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Eu = func(tmpu,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print("linmin got one Eu " // Eu // " " // u, PRINT_NERD) + it = it + 1 + + if(Eu .LT. Ec) then ! Eb > Eu < Ec + a = b + b = u + Ea = Eb + Eb = Eu + exit !break? + else if(Eu .GT. Eb) then ! Ea > Eb < Eu + c = u + Ec = Eu + exit + end if + + !no minimum found yet + + u = c + GOLD*(c-b) + tmpu = x0 + u*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Eu = func(tmpu,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print("linmin got second Eu " // Eu // " " // u, PRINT_NERD) + it = it + 1 + + else if((u-c)*(ulim-u) .GT. 0) then ! c < u < ulim + + write(line,*) " c < u < ulim= ", ulim; call print(line,PRINT_VERBOSE) + tmpu = x0 + u*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Eu = func(tmpu,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print("linmin got one(2) Eu " // Eu // " " // u, PRINT_NERD) + it = it + 1 + + if(Eu .LT. Ec) then + b = c + c = u + u = c + GOLD*(c-b) + Eb = Ec + Ec = Eu + tmpu = x0 + u*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Eu = func(tmpu,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print("linmin got second(2) Eu " // Eu // " " // u, PRINT_NERD) + it = it + 1 + end if + + else ! c < ulim < u or u is garbage (we are in a linear regime) + write(line,*) " ulim=",ulim," < u or u garbage"; call print(line,PRINT_VERBOSE) + u = ulim + tmpu = x0 + u*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Eu = func(tmpu,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + it = it + 1 + call print("linmin got one(3) Eu " // Eu // " " // u, PRINT_NERD) + end if + + write(line,*) " "; call print(line,PRINT_VERBOSE) + write(line,*) " "; call print(line,PRINT_VERBOSE) + + ! test to see if we change any component too much + + + + do i = 1,N + + if(abs(c*xdir(i)) .GT. DXLIM)then + tmpb = x0+b*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Eb = func(tmpb,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print("linmin got new Eb " // Eb // " " // b, PRINT_NERD) + it = it + 1 + y = tmpb + write(line,*) " bracket: step too big", b, Eb + call print(line, PRINT_VERBOSE) + write(line,'("I= ",I4," C= ",F16.12," xdir(i)= ",F16.12," DXLIM =",F16.12)')& + i, c, xdir(i), DXLIM + call print(line, PRINT_VERBOSE) + + epsilon = b + + linmin= it + return + end if + end do + + + a = b + b = c + c = u + Ea = Eb + Eb = Ec + Ec = Eu + + end do + + epsilon = b + fallback = b + + bracket_it = it + call print(" Linmin: bracket OK in "//bracket_it//" steps", PRINT_VERBOSE) + + + + ! ahhh.... now we have a minimum between a and c, Ea > Eb < Ec + + write(line,*) " "; call print(line,PRINT_VERBOSE) + write(line,*) a,Ea; call print(line,PRINT_VERBOSE) + write(line,*) b,Eb; call print(line,PRINT_VERBOSE) + write(line,*) c,Ec; call print(line,PRINT_VERBOSE) + write(line,*) " "; call print(line,PRINT_VERBOSE) + + + + !******************************************************************** + ! * primitive linmin + ! * do a quadratic fit to a, b, c + ! * + ! + ! r = (b-a)*(Eb-Ec); + ! q = (b-c)*(Eb-Ea); + ! u = b-((b-c)*q-(b-a)*r)/(2*Mmax(fabs(q-r), 1e-20)*sign(q-r)); + ! y = x0 + u*xdir; + ! Eu = (*func)(y); + ! + ! if(Eb < Eu){ // quadratic fit was bad + ! if(current_verbosity() > MUMBLE) logger(" Quadratic fit was bad, returning 'b'\n"); + ! u = b; + ! y = x0 + u*xdir; + ! Eu = (*func)(y); + ! } + ! + ! if(current_verbosity() > PRINT_SILENT) + ! logger(" simple quadratic fit: %25.16e%25.16e\n\n", u, Eu); + ! + ! //return(u); + ! * + ! * end primitive linmin + !**********************************************************************/ + + ! now we need a tol1) then + u = x+d + else + u = x + tol1*sign(d) + end if + + ! evaluate function + tmpa = u*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + Eu = func(x0+tmpa,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print(' Linmin: new point u= '//u//' Eu= '//Eu, PRINT_VERBOSE) + if(any(abs(tmpa) > DXLIM)) then + if(sizeflag .EQ. 0) then + call print(' Linmin: an element of x moved more than '//DXLIM) + end if + sizeflag = 1 + endif + + ! analyse new point result + if(Eu .LE. Ex) then + call print(' Linmin: new point best so far', PRINT_VERBOSE+1) + if(u .GE. x) then + a = x + else + b = x + end if + + v=w;w=x;x=u + Ev=Ew;Ew=Ex;Ex=Eu + else + call print(' Linmin: new point is no better', PRINT_VERBOSE+1) + if(u < x) then + a = u + else + b = u + endif + + if(Eu .LE. Ew .OR. w .EQ. x) then + v=w;w=u + Ev = Ew; Ew = Eu + else if(Eu .LE. Ev .OR. v .EQ. x .OR. v .EQ. w) then + v = u + Ev = Eu + end if + end if + call print(' Linmin: a='//a//' b='//b//' x='//x, PRINT_VERBOSE+1) + + end do + + write(line,*) " Linmin: too many iterations"; call print(line, PRINT_NORMAL) + + + + y = x0 + x*xdir + epsilon = x + linmin = it + + deallocate(tmpa, tmpb, tmpc, tmpu) + return + end function linmin + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Simple (fast, dumb) line minimiser. The 'func' interface is + !% the same as for 'linmin' above. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + function linmin_fast(x0,fx0,xdir,y,epsilon,func,data) result(linmin) + real(dp)::x0(:) !% Starting vector + real(dp)::fx0 !% Value of 'func' at 'x0' + real(dp)::xdir(:) !% Direction + real(dp)::y(:) !% Result + real(dp)::epsilon !% Initial step + INTERFACE + function func(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + end function func + END INTERFACE + character(len=1),optional::data(:) + integer::linmin + + ! Dynamically allocate to avoid stack overflow madness with ifort + real(dp),allocatable::xb(:),xc(:) + real(dp)::r,q,new_eps,a,b,c,fxb,fxc,ftol + integer::n + logical::reject_quadratic_extrap + + !%RV Number of linmin steps taken, or zero if an error occured + + N=size(x0) + new_eps=-1.0_dp + a=0.0_dp + ftol=1.e-13 + allocate(xb(N)) + allocate(xc(N)) + + call print("Welcome to linmin_fast", PRINT_NORMAL) + + reject_quadratic_extrap = .true. + do while(reject_quadratic_extrap) + + b = a+epsilon + c = b+GOLD*epsilon + xb = x0+b*xdir + xc = x0+c*xdir + +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + fxb = func(xb,data) + fxc = func(xc,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + + write(line,*) " abc = ", a, b, c; call print(line, PRINT_NORMAL) + write(line,*) " f = ",fx0, fxb, fxc; call print(line, PRINT_NORMAL) + + if(abs(fx0-fxb) < abs(ftol*fx0))then + write(line,*) "*** fast_linmin is stuck, returning 0" + call print(line,PRINT_SILENT) + + linmin=0 + return + end if + + !WARNING: find a way to do the following + + ! probably we will need to wrap isnan + + !if(isnan(fxb) .OR. isnan(fxc))then + ! write(global_err%unit,*)" Got a NaN!!!" + ! linmin=0 + ! return + !end if + ! if(.NOT.finite(fxb) .OR. .NOT.finite(fxc))then + ! write(global_err%unit,*)" Got a INF!!!" + ! linmin=0 + ! return + ! end if + + r = (b-a)*(fxb-fxc) + q = (b-c)*(fxb-fx0) + new_eps = b-((b-c)*q-(b-a)*r)/(2.0*max(abs(q-r), 1.0_dp-20)*sign(1.0_dp,q-r)) + + write(line,*) " neweps = ", new_eps; call print(line, PRINT_NORMAL) + + if (abs(fxb) .GT. 100.0_dp*abs(fx0) .OR. abs(fxc) .GT. 100.0_dp*abs(fx0)) then ! extrapolation gave stupid results + epsilon = epsilon/10.0_dp + reject_quadratic_extrap = .true. + else if(new_eps > 10.0_dp*(b-a))then + write(line,*) "*** new epsilon > 10.0 * old epsilon, capping at factor of 10.0 increase" + call print(line, PRINT_NORMAL) + epsilon = 10.0_dp*(b-a) + a = c + fx0 = fxc + reject_quadratic_extrap = .true. + else if(new_eps < 0.0_dp) then + ! new proposed minimum is behind us! + if(fxb < fx0 .and. fxc < fx0 .and. fxc < fxb) then + ! increase epsilon + epsilon = epsilon*2.0_dp + call print("*** quadratic extrapolation resulted in backward step, increasing epsilon: "//epsilon, PRINT_NORMAL) + else + epsilon = epsilon/10.0_dp + write(line,*)"*** xdir wrong way, reducing epsilon ",epsilon + call print(line, PRINT_NORMAL) + endif + reject_quadratic_extrap = .true. + else if(new_eps < epsilon/10.0_dp) then + write(line,*) "*** new epsilon < old epsilon / 10, reducing epsilon by a factor of 2" + epsilon = epsilon/2.0_dp + reject_quadratic_extrap = .true. + else + reject_quadratic_extrap = .false. + end if + end do + y = x0+new_eps*xdir + + epsilon = new_eps + linmin=1 + + deallocate(xb, xc) + + return + end function linmin_fast + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Line minimizer that uses the derivative and extrapolates + !% its projection onto the search direction to zero. Again, + !% the 'func' interface is the same as for 'linmin'. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + function linmin_deriv(x0, xdir, dx0, y, epsilon, dfunc, data) result(linmin) + real(dp)::x0(:) !% Starting vector + real(dp)::xdir(:)!% Search direction + real(dp)::dx0(:) !% Initial gradient + real(dp)::y(:) !% Result + real(dp)::epsilon!% Initial step + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + character(len=1),optional::data(:) + integer::linmin + + ! local vars + integer::N + real(dp), allocatable::x1(:), dx1(:) + real(dp)::dirdx0, dirdx1, gamma, new_eps + + !%RV Number of linmin steps taken, or zero if an error occured + + N=size(x0) + dirdx1 = 9.9e30_dp + new_eps = epsilon + allocate(x1(N), dx1(N)) + + linmin = 0 + dirdx0 = xdir .DOT. dx0 + if( dirdx0 > 0.0_dp) then ! should be negative + call print("WARNING: linmin_deriv: xdir*dx0 > 0 !!!!!", PRINT_ALWAYS) + return + endif + + do while(abs(dirdx1) > abs(dirdx0)) + x1 = x0+new_eps*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dx1 = dfunc(x1,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx1 = xdir .DOT. dx1 + + if(abs(dirdx1) > abs(dirdx0)) then ! this eps leads to a point with larger abs gradient + call print("WARNING: linmin_deriv: |dirdx1| > |dirdx0|, reducing epsilon by factor of 5", PRINT_NORMAL) + new_eps = new_eps/5.0_dp + if(new_eps < 1.0e-12_dp) then + call print("WARNING: linmin_deriv: new_eps < 1e-12 !!!!!", PRINT_NORMAL) + linmin = 0 + return + endif + else + gamma = dirdx0/(dirdx0-dirdx1) + if(gamma > 2.0_dp) then + call print("*** gamma > 2.0, capping at 2.0", PRINT_NORMAL) + gamma = 2.0_dp + endif + new_eps = gamma*epsilon + endif + linmin = linmin+1 + end do + + write (line,'(a,e10.2,a,e10.2)') ' gamma = ', gamma, ' new_eps = ', new_eps + call Print(line, PRINT_NORMAL) + + y = x0+new_eps*xdir + epsilon = new_eps + + deallocate(x1, dx1) + return + end function linmin_deriv + + + !% Iterative version of 'linmin_deriv' that avoid taking large steps + !% by iterating the extrapolation to zero gradient. + function linmin_deriv_iter(x0, xdir, dx0, y, epsilon, dfunc,data,do_line_scan) result(linmin) + real(dp)::x0(:) !% Starting vector + real(dp)::xdir(:)!% Search direction + real(dp)::dx0(:) !% Initial gradient + real(dp)::y(:) !% Result + real(dp)::epsilon!% Initial step + logical, optional :: do_line_scan + + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + character(len=1),optional :: data(:) + integer::linmin + + ! local vars + integer::N, extrap_steps,i + real(dp), allocatable::xn(:), dxn(:) + real(dp)::dirdx1, dirdx2, dirdx_new, eps1, eps2, new_eps, eps11, step, old_eps + integer, parameter :: max_extrap_steps = 50 + logical :: extrap + + !%RV Number of linmin steps taken, or zero if an error occured + + N=size(x0) + allocate(xn(N), dxn(N)) + + if (present(do_line_scan)) then + if (do_line_scan) then + call print('line scan:', PRINT_NORMAL) + new_eps = 1.0e-5_dp + do i=1,50 + xn = x0 + new_eps*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dxn = dfunc(xn,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx_new = xdir .DOT. dxn + + call print(new_eps//' '//dirdx_new//' <-- LS', PRINT_NORMAL) + + new_eps = new_eps*1.15 + enddo + end if + end if + + eps1 = 0.0_dp + eps2 = epsilon + new_eps = epsilon + + linmin = 0 + dirdx1 = xdir .DOT. dx0 + dirdx2 = dirdx1 + if( dirdx1 > 0.0_dp) then ! should be negative + call print("WARNING: linmin_deriv_iter: xdir*dx0 > 0 !!!!!", PRINT_ALWAYS) + return + endif + + extrap_steps = 0 + + do while ( (abs(eps1-eps2) > TOL*abs(eps1)) .and. extrap_steps < max_extrap_steps) + do + xn = x0 + new_eps*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dxn = dfunc(xn,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx_new = xdir .DOT. dxn + + linmin = linmin + 1 + + call print('eps1 = '//eps1//' eps2 = '//eps2//' new_eps = '//new_eps, PRINT_NORMAL) + call print('dirdx1 = '//dirdx1//' dirdx2 = '//dirdx2//' dirdx_new = '//dirdx_new, PRINT_NORMAL) + + extrap = .false. + if (dirdx_new > 0.0_dp) then + if(abs(dirdx_new) < 2.0_dp*abs(dirdx1)) then + ! projected gradient at new point +ve, but not too large. + call print("dirdx_new > 0, but not too large", PRINT_NORMAL) + eps2 = new_eps + dirdx2 = dirdx_new + extrap_steps = 0 + ! we're straddling the minimum well, so gamma < 2 and we can interpolate to the next step + + ! let's try to bring in eps1 + step = 0.5_dp*(new_eps-eps1) + dirdx1 = 1.0_dp + do while (dirdx1 > 0.0_dp) + eps11 = eps1+step + call print("Trying to bring in eps1: "//eps11, PRINT_NORMAL) + xn = x0 + eps11*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dxn = dfunc(xn,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx1 = xdir .DOT. dxn + step = step/2.0_dp + end do + eps1 = eps11 + + exit + else + ! projected gradient at new point +ve and large + ! let's decrease the step we take + call print("*** reducing trial epsilon by factor of 2, making eps2=current new_eps", PRINT_NORMAL) + eps2 = new_eps + dirdx2 = dirdx_new + new_eps = (eps1+new_eps)/2.0_dp + ! check if we are just fiddling around + if(new_eps < 1.0e-12_dp) then + call print("WARNING: linmin_deriv_iter: total_eps < 1e-12 !!!!!", PRINT_NORMAL) + linmin = 0 + return + endif + end if + else ! projected gradient is -ve + if(abs(dirdx_new) <= abs(dirdx1)) then + ! projected gradient smaller than at x1 + if(dirdx2 > 0.0_dp) then + ! we have good bracketing, so interpolate + call print("dirdx_new <= 0, and we have good bracketing", PRINT_NORMAL) + eps1 = new_eps + dirdx1 = dirdx_new + extrap_steps = 0 + + ! let's try to bring in eps2 + step = 0.5_dp*(eps2-new_eps) + dirdx2 = -1.0_dp + do while(dirdx2 < 0.0_dp) + eps11 = eps2-step + call print("Trying to bring in eps2: "//eps11, PRINT_NORMAL) + xn = x0 + eps11*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dxn = dfunc(xn,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx2 = xdir .DOT. dxn + step = step/2.0_dp + end do + eps2 = eps11 + + exit + else + ! we have not bracketed yet, but can take this point and extrapolate to a bigger stepsize + old_eps = new_eps + if(abs(dirdx_new-dirdx1) .fne. 0.0_dp) new_eps = eps1-dirdx1/(dirdx_new-dirdx1)*(new_eps-eps1) + call print("we have not bracketed yet, extrapolating: "//new_eps, PRINT_NORMAL) + extrap_steps = extrap_steps + 1 + if(new_eps > 5.0_dp*old_eps) then + ! extrapolation is too large, let's just move closer + call print("capping extrapolation at "//2.0_dp*old_eps, PRINT_NORMAL) + eps1 = old_eps + new_eps = 2.0_dp*old_eps + else + ! accept the extrapolation + eps1 = old_eps + dirdx1 = dirdx_new + end if + endif + else + if (dirdx2 < 0.0_dp) then + ! have not bracketed yet, and projected gradient too big - minimum is behind us! lets move forward + call print("dirdx2 < 0.0_dp and projected gradient too big, closest stationary point is behind us!", PRINT_NORMAL) + eps1 = new_eps + dirdx1 = dirdx_new + new_eps = eps1*2.0_dp + eps2 = new_eps + extrap_steps = extrap_steps+1 + else + call print("abs(dirdx_new) > abs(dirdx1) but dirdx2 > 0, should only happen when new_eps is converged. try to bring in eps2", PRINT_NORMAL) + eps2 = 0.5_dp*(new_eps+eps2) + xn = x0 + eps2*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dxn = dfunc(xn,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx2 = xdir .DOT. dxn + exit + endif + endif + end if + end do + new_eps = eps1 - dirdx1/(dirdx2-dirdx1)*(eps2-eps1) + + + end do + + if (extrap_steps == max_extrap_steps) then + call Print('*** linmin_deriv: max consequtive extrapolation steps exceeded', PRINT_ALWAYS) + linmin = 0 + return + end if + + call print('linmin_deriv_iter done in '//linmin//' steps') + + epsilon = new_eps + y = x0 + epsilon*xdir + + deallocate(xn, dxn) + return + end function linmin_deriv_iter + + + !% Simplified Iterative version of 'linmin_deriv' that avoid taking large steps + !% by iterating the extrapolation to zero gradient. It does not try to reduce + !% the bracketing interval on both sides at every step + function linmin_deriv_iter_simple(x0, xdir, dx0, y, epsilon, dfunc,data,do_line_scan) result(linmin) + real(dp)::x0(:) !% Starting vector + real(dp)::xdir(:)!% Search direction + real(dp)::dx0(:) !% Initial gradient + real(dp)::y(:) !% Result + real(dp)::epsilon!% Initial step + logical, optional :: do_line_scan + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + character(len=1),optional :: data(:) + integer::linmin + + ! local vars + integer::N, extrap_steps, i + real(dp), allocatable::xn(:), dxn(:) + real(dp)::dirdx1, dirdx2, dirdx_new, eps1, eps2, new_eps, old_eps + integer, parameter :: max_extrap_steps = 50 + logical :: extrap + + !%RV Number of linmin steps taken, or zero if an error occured + + + + N=size(x0) + allocate(xn(N), dxn(N)) + + if (present(do_line_scan)) then + if (do_line_scan) then + call print('line scan:', PRINT_NORMAL) + new_eps = 1.0e-5_dp + do i=1,50 + xn = x0 + new_eps*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dxn = dfunc(xn,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx_new = xdir .DOT. dxn + + call print(new_eps//' '//dirdx_new, PRINT_NORMAL) + + new_eps = new_eps*1.15 + enddo + end if + end if + + + eps1 = 0.0_dp + eps2 = epsilon + old_eps = 0.0_dp + new_eps = epsilon + + linmin = 0 + dirdx1 = xdir .DOT. dx0 + dirdx2 = 0.0_dp + if( dirdx1 > 0.0_dp) then ! should be negative + call print("WARNING: linmin_deriv_iter_simple: xdir*dx0 > 0 !!!!!", PRINT_ALWAYS) + return + endif + + + + extrap_steps = 0 + + do while ( (abs(old_eps-new_eps) > TOL*abs(new_eps)) .and. extrap_steps < max_extrap_steps) + xn = x0 + new_eps*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dxn = dfunc(xn,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx_new = xdir .DOT. dxn + + + linmin = linmin + 1 + + call print('eps1 = '//eps1//' eps2 = '//eps2//' new_eps = '//new_eps, PRINT_NORMAL) + call print('dirdx1 = '//dirdx1//' dirdx2 = '//dirdx2//' dirdx_new = '//dirdx_new, PRINT_NORMAL) + extrap = .false. + if (dirdx_new > 0.0_dp) then + if(abs(dirdx_new) < 10.0_dp*abs(dirdx1)) then + ! projected gradient at new point +ve, but not too large. + call print("dirdx_new > 0, but not too large", PRINT_NORMAL) + eps2 = new_eps + dirdx2 = dirdx_new + extrap_steps = 0 + ! we're straddling the minimum well, so gamma < 2 and we can interpolate to the next step + else + ! projected gradient at new point +ve and large + ! let's decrease the step we take + call print("*** reducing trial epsilon by factor of 2, making eps2=current new_eps", PRINT_NORMAL) + eps2 = new_eps + dirdx2 = dirdx_new + old_eps = new_eps + new_eps = (eps1+new_eps)/2.0_dp + ! check if we are just fiddling around + if(new_eps < 1.0e-12_dp) then + call print("WARNING: linmin_deriv_iter_simple: new_eps < 1e-12 !!!!!", PRINT_NORMAL) + linmin = 0 + return + endif + cycle + end if + else ! projected gradient is -ve + if(abs(dirdx_new) <= abs(dirdx1)) then + ! projected gradient smaller than at x1 + if(dirdx2 > 0.0_dp) then + ! we have good bracketing, so interpolate + call print("dirdx_new <= 0, and we have good bracketing", PRINT_NORMAL) + eps1 = new_eps + dirdx1 = dirdx_new + extrap_steps = 0 + else + ! we have not bracketed yet, but can take this point and extrapolate to a bigger stepsize + old_eps = new_eps + if(abs(dirdx_new-dirdx1) .fne. 0.0_dp) new_eps = eps1-dirdx1/(dirdx_new-dirdx1)*(new_eps-eps1) + call print("we have not bracketed yet, extrapolating: "//new_eps, PRINT_NORMAL) + if(new_eps > 5.0_dp*old_eps) then + ! extrapolation is too large, let's just move closer + call print("capping extrapolation at "//2.0_dp*old_eps, PRINT_NORMAL) + eps1 = old_eps + new_eps = 2.0_dp*old_eps + else + ! accept the extrapolation + eps1 = old_eps + dirdx1 = dirdx_new + end if + extrap_steps = extrap_steps + 1 + cycle + endif + else + if (dirdx2 .eq. 0.0_dp) then + ! have not bracketed yet, and projected gradient too big - minimum is behind us! lets move forward + call print("dirdx2 < 0.0_dp and projected gradient too big, closest stationary point is behind us!", PRINT_NORMAL) + eps1 = new_eps + dirdx1 = dirdx_new + old_eps = new_eps + new_eps = eps1*2.0_dp + eps2 = new_eps + extrap_steps = extrap_steps+1 + cycle + else + call print("dirdx_new < 0, abs(dirdx_new) > abs(dirdx1) but dirdx2 > 0, function not monotonic?", PRINT_NORMAL) + eps1 = new_eps + dirdx1 = dirdx_new + endif + endif + end if + old_eps = new_eps + new_eps = eps1 - dirdx1/(dirdx2-dirdx1)*(eps2-eps1) + + end do + + if (extrap_steps == max_extrap_steps) then + call Print('*** linmin_deriv_iter_simple: max consequtive extrapolation steps exceeded', PRINT_ALWAYS) + linmin = 0 + return + end if + + epsilon = new_eps + y = x0 + epsilon*xdir + + deallocate(xn, dxn) + return + end function linmin_deriv_iter_simple + + + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Damped molecular dynamics minimiser. The objective + !% function is 'func(x)' and its gradient is 'dfunc(x)'. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + + function damped_md_minim(x,mass,func,dfunc,damp,tol,max_change,max_steps,data) + + real(dp)::x(:) !% Starting vector + real(dp)::mass(:) !% Effective masses of each degree of freedom + INTERFACE + function func(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + end function func + end INTERFACE + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + real(dp)::damp !% Velocity damping factor + real(dp)::tol !% Minimisation is taken to be converged when 'normsq(force) < tol' + real(dp)::max_change !% Maximum position change per time step + integer:: max_steps !% Maximum number of MD steps + character(len=1),optional::data(:) + + integer :: N,i + integer :: damped_md_minim + real(dp),allocatable::velo(:),acc(:),force(:) + real(dp)::dt,df2, f + + !%RV Returns number of MD steps taken. + + + N=size(x) + allocate(velo(N),acc(N),force(N)) + + call print("Welcome to damped md minim()") + write(line,*)"damping = ", damp ; call print(line) + + velo=0.0_dp +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + acc = -dfunc(x,data)/mass +#ifndef _OPENMP + call verbosity_pop() +#endif + + + dt = sqrt(max_change/maxval(abs(acc))) + write(line,*)"dt = ", dt ; call print(line) + + do I=0,max_steps + velo(:)=velo(:) + (0.5*dt)*acc(:) +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + force(:)= -dfunc(X,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + df2=normsq(force) + if(df2 .LT. tol) then + write(line,*) I," force^2 =",df2 ; call print(line) + write(line,*)"Converged in ",i," steps!!" ; call print(line) + exit + else if (mod(i,100) .EQ. 0) then + write(line,*)i," f = ", func(x,data), "df^2 = ", df2, "max(abs(df)) = ",maxval(abs(force)); call print(line) + end if + acc(:)=force(:)/mass(:) + velo(:)=velo(:) + (0.5*dt)*acc(:) + + velo(:)=velo(:) * (1.0-damp)/(1.0+damp) + x(:)=x(:)+dt*velo(:) + x(:)=x(:)+0.5*dt*dt*acc(:) + +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + f = func(x,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call print("f=" // f, PRINT_VERBOSE) + call print(x, PRINT_NERD) + + end do + ! + if(i .EQ. max_steps) then + write(line,*) "Failed to converge in ",i," steps" ; call print(line) + end if + damped_md_minim = i + return + end function damped_md_minim + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + !% Gradient descent minimizer, using either the conjugate gradients or + !% steepest descent methods. The objective function is + !% 'func(x)' and its gradient is 'dfunc(x)'. + !% There is an additional 'hook' interface which is called at the + !% beginning of each gradient descent step. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + + function minim(x_in,func,dfunc,method,convergence_tol,max_steps, linminroutine, hook, hook_print_interval, & + eps_guess, always_do_test_gradient, data, status) + real(dp), intent(inout) :: x_in(:) !% Starting position + INTERFACE + function func(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + end function func + end INTERFACE + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + character(*), intent(in) :: method !% 'cg' for conjugate gradients or 'sd' for steepest descent + real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ + !% 'convergence_tol'. + integer, intent(in) :: max_steps !% Maximum number of 'cg' or 'sd' steps + integer::minim + character(*), intent(in), optional :: linminroutine !% Name of the line minisation routine to use. + !% This should be one of 'NR_LINMIN', 'FAST_LINMIN' and + !% 'LINMIN_DERIV'. + !% If 'FAST_LINMIN' is used and problems with the line + !% minisation are detected, 'minim' automatically switches + !% to the more reliable 'NR_LINMIN', and then switches back + !% once no more problems have occurred for some time. + !% the default is NR_LINMIN + optional :: hook + INTERFACE + subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + end subroutine hook + end INTERFACE + integer, intent(in), optional :: hook_print_interval + real(dp), intent(in), optional :: eps_guess + logical, intent(in), optional :: always_do_test_gradient + character(len=1), optional, intent(inout) :: data(:) + integer, optional, intent(out) :: status + + !%RV Returns number of gradient descent steps taken during minimisation + + integer, parameter:: max_bad_cg = 5 + integer, parameter:: max_bad_iter = 5 + integer, parameter:: convergence_window = 3 + integer:: convergence_counter + integer:: main_counter + integer:: bad_cg_counter + integer:: bad_iter_counter + integer:: resetflag + integer:: exit_flag + integer:: lsteps + integer:: i, extra_report + real(dp), parameter:: stuck_tol = NUMERICAL_ZERO + real(dp):: linmin_quality + real(dp):: eps, alpha + real(dp):: oldeps + real(dp), parameter :: default_eps_guess = 0.1_dp ! HACK + real(dp) :: my_eps_guess + real(dp):: f, f_new + real(dp):: gg, dgg, hdirgrad_before, hdirgrad_after + real(dp):: dcosine, gdirlen, gdirlen_old, normsqgrad_f, normsqgrad_f_old + real(dp):: obj, obj_new + logical:: do_sd, do_sd2, do_cg, do_pcg, do_lbfgs + integer:: fast_linmin_switchback + logical:: do_fast_linmin + logical:: do_linmin_deriv + logical:: dumbool, done + logical:: do_test_gradient + integer :: my_hook_print_interval + + ! working arrays + ! Dynamically allocate to avoid stack overflow madness with ifort + real(dp),dimension(:), allocatable :: x, y, hdir, gdir, gdir_old, grad_f, grad_f_old, x_old + ! for lbfgs + real(dp), allocatable :: lbfgs_work(:), lbfgs_diag(:) + integer :: lbfgs_flag + integer, parameter :: lbfgs_M = 40 + + if (current_verbosity() >= PRINT_VERBOSE) then + my_hook_print_interval = optional_default(1, hook_print_interval) + else if (current_verbosity() >= PRINT_NORMAL) then + my_hook_print_interval = optional_default(10, hook_print_interval) + else + my_hook_print_interval = optional_default(100000, hook_print_interval) + endif + + call system_timer("minim") + + call system_timer("minim/init") + allocate(x(size(x_in))) + x = x_in + + allocate(y(size(x)), hdir(size(x)), gdir(size(x)), gdir_old(size(x)), & + grad_f(size(x)), grad_f_old(size(x))) + + extra_report = 0 + if (present(status)) status = 0 + + call print("Welcome to minim()", PRINT_NORMAL) + call print("space is "//size(x)//" dimensional", PRINT_NORMAL) + do_sd = .false. + do_sd2 = .false. + do_cg = .false. + do_pcg = .false. + do_lbfgs = .false. + + if(trim(method).EQ."sd") then + do_sd = .TRUE. + call print("Method: Steepest Descent", PRINT_NORMAL) + else if(trim(method).EQ."sd2")then + do_sd2 = .TRUE. + call print("Method: Two-Point Step Size Gradient Methods, J Barzilai and JM Borwein, IMA J Num Anal (1988) 8, 141-148", PRINT_NORMAL) + allocate(x_old(size(x))) + y=x + x_old = x + else if(trim(method).EQ."cg")then + do_cg = .TRUE. + call print("Method: Conjugate Gradients", PRINT_NORMAL) + else if(trim(method).EQ."pcg")then + do_cg = .TRUE. + do_pcg = .TRUE. + call print("Method: Preconditioned Conjugate Gradients", PRINT_NORMAL) + else if(trim(method).EQ."lbfgs") then + do_lbfgs = .TRUE. + call print("Method: LBFGS by Jorge Nocedal, please cite D. Liu and J. Nocedal, Mathematical Programming B 45 (1989) 503-528", PRINT_NORMAL) + allocate(lbfgs_diag(size(x))) + allocate(lbfgs_work(size(x)*(lbfgs_M*2+1)+2*lbfgs_M)) + call print("Allocating LBFGS work array: "//(size(x)*(lbfgs_M*2+1)+2*lbfgs_M)//" bytes") + lbfgs_flag = 0 + ! set units + MP = mainlog%unit + LP = errorlog%unit + ! + y=x ! this is reqired for lbfgs on first entry into the main loop, as no linmin is done + else + call System_abort("Invalid method in optimize: '"//trim(method)//"'") + end if + + + do_fast_linmin = .FALSE. + do_linmin_deriv = .FALSE. + if(present(linminroutine)) then + if(do_lbfgs) & + call print("Minim warning: a linminroutine was specified for use with LBFGS") + if(do_sd2) & + call print("Minim warning: a linminroutine was specified for use with two-point steepest descent SD2") + if(trim(linminroutine) .EQ. "FAST_LINMIN") then + do_fast_linmin =.TRUE. + call print("Using FAST_LINMIN linmin", PRINT_NORMAL) + else if(trim(linminroutine).EQ."NR_LINMIN") then + call print("Using NR_LINMIN linmin", PRINT_NORMAL) + else if(trim(linminroutine).EQ."LINMIN_DERIV") then + do_linmin_deriv = .TRUE. + call print("Using LINMIN_DERIV linmin", PRINT_NORMAL) + else + call System_abort("Invalid linminroutine: "//linminroutine) + end if + end if + + if (current_verbosity() .GE. PRINT_NERD .and. .not. do_linmin_deriv) then + dumbool=test_gradient(x, func, dfunc,data=data) + end if + + ! initial function calls + if (.not. do_linmin_deriv) then +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + f = func(x,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + else + f = 0.0_dp + end if + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + grad_f = dfunc(x,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + + if (my_hook_print_interval > 0) then + if (present(hook)) then + call hook(x, grad_f, f, done, .true., data) + if (done) then + call print('hook reports that minim finished, exiting.', PRINT_NORMAL) + exit_flag = 1 + end if + else + call print("hook is not present", PRINT_VERBOSE) + end if + endif + + + grad_f_old = grad_f + gdir = (-1.0_dp)*grad_f + hdir = gdir + gdir_old = gdir + normsqgrad_f = normsq(grad_f) + normsqgrad_f_old = normsqgrad_f + gdirlen = sqrt(normsqgrad_f) + gdirlen_old = gdirlen + ! quality monitors + dcosine = 0.0_dp + linmin_quality = 0.0_dp + bad_cg_counter = 0 + bad_iter_counter = 0 + convergence_counter = 0 + resetflag = 0 + exit_flag = 0 + fast_linmin_switchback = -1 + lsteps = 0 + + + + do_test_gradient = optional_default(.false., always_do_test_gradient) + my_eps_guess = optional_default(default_eps_guess, eps_guess) + eps = my_eps_guess + + !******************************************************************** + !* + !* MAIN CG LOOP + !* + !********************************************************************** + + + if(normsqgrad_f .LT. convergence_tol)then + call print("Minimization is already converged!") + call print(trim(method)//" iter = "// 0 //" df^2 = " // normsqgrad_f // " f = " // f & + &// " "//lsteps//" linmin steps eps = "//eps,PRINT_VERBOSE) + exit_flag = 1 + end if + + call system_timer("minim/init") + call system_timer("minim/main_loop") + + main_counter=1 ! incremented at the end of the loop + do while((main_counter .LT. max_steps) .AND. (.NOT.(exit_flag.gt.0))) + call system_timer("minim/main_loop/"//main_counter) + + if ((current_verbosity() >= PRINT_ANALYSIS .or. do_test_gradient) & + .and. .not. do_linmin_deriv) then + dumbool=test_gradient(x, func, dfunc,data=data) + if (.not. dumbool) call print("Gradient test failed") + end if + + !********************************************************************** + !* + !* Print stuff + !* + !**********************************************************************/ + + +#ifndef _OPENMP + if (my_hook_print_interval == 1 .or. mod(main_counter,my_hook_print_interval) == 1) call verbosity_push_increment() +#endif + call print(trim(method)//" iter = "//main_counter//" df^2 = "//normsqgrad_f//" f = "//f// & + ' max(abs(df)) = '//maxval(abs(grad_f)),PRINT_VERBOSE) + if(.not. do_lbfgs) & + call print(" dcos = "//dcosine//" q = " //linmin_quality,PRINT_VERBOSE) +#ifndef _OPENMP + if (my_hook_print_interval == 1 .or. mod(main_counter,my_hook_print_interval) == 1) call verbosity_pop() +#endif + + ! call the hook function + if (present(hook)) then + call hook(x, grad_f, f, done, (mod(main_counter-1,my_hook_print_interval) == 0), data) + if (done) then + call print('hook reports that minim finished, exiting.', PRINT_NORMAL) + exit_flag = 1 + call system_timer("minim/main_loop/"//main_counter) + cycle + end if + else + call print("hook is not present", PRINT_VERBOSE) + end if + + !********************************************************************** + !* + !* test to see if we've converged, let's quit + !* + !**********************************************************************/ + ! + if(normsqgrad_f < convergence_tol) then + convergence_counter = convergence_counter + 1 + !call print("Convergence counter = "//convergence_counter) + else + convergence_counter = 0 + end if + if(convergence_counter == convergence_window) then + call print("Converged after step " // main_counter) + call print(trim(method)//" iter = " // main_counter // " df^2= " // normsqgrad_f // " f= " // f) + exit_flag = 1 ! while loop will quit + call system_timer("minim/main_loop/"//main_counter) + cycle !continue + end if + + if( (.not. do_lbfgs) .and. (.not. do_sd2) ) then + !********************************************************************** + !* + !* do line minimization + !* + !**********************************************************************/ + + oldeps = eps + ! no output from linmin unless level >= PRINT_VERBOSE + call system_timer("minim/main_loop/"//main_counter//"/linmin") +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + if(do_fast_linmin) then + lsteps = linmin_fast(x, f, hdir, y, eps, func,data) + if (lsteps .EQ.0) then + call print("Fast linmin failed, calling normal linmin at step " // main_counter) + lsteps = linmin(x, hdir, y, eps, func,data) + end if + else if(do_linmin_deriv) then + lsteps = linmin_deriv_iter_simple(x, hdir, grad_f, y, eps, dfunc,data) + else + lsteps = linmin(x, hdir, y, eps, func,data) + end if + if ((oldeps .fne. my_eps_guess) .and. (eps > oldeps*2.0_dp)) then + eps = oldeps*2.0_dp + endif +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("minim/main_loop/"//main_counter//"/linmin") + + !********************************************************************** + !* + !* check the result of linmin + !* + !********************************************************************** + + if(lsteps .EQ. 0) then ! something very bad happenned, gradient is bad? + call print("*** LINMIN returned 0, RESETTING CG CYCLE and eps at step " // main_counter) +#ifndef _OPENMP + call verbosity_push_increment() +#endif + extra_report = extra_report + 1 + hdir = -1.0 * grad_f + eps = my_eps_guess + + if (current_verbosity() >= PRINT_NERD) call line_scan(x, hdir, func, .not. do_linmin_deriv, dfunc, data) + + bad_iter_counter = bad_iter_counter + 1 + if(bad_iter_counter .EQ. max_bad_iter) then + + call print("*** BAD linmin counter reached maximum, exiting " // max_bad_iter) + + exit_flag = 1 + if (present(status)) status = 1 + end if + + call system_timer("minim/main_loop/"//main_counter) + cycle !continue + end if + + end if ! .not. lbfgs .and. .not. sd2 + + !********************************************************************** + !* + !* Evaluate function at new position + !* + !********************************************************************** + + + if (.not. do_linmin_deriv) then +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + f_new = func(y,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + else + f_new = 0.0_dp + end if + ! if(!finite(f_new)){ + ! logger(ERROR, "OUCH!!! f_new is not finite!\n"); + ! return -1; // go back screaming + ! end if + + !******************************************************************** + ! Is everything going normal? + !*********************************************************************/ + + ! let's make sure we are progressing + ! obj is the thing we are trying to minimize + ! are we going down,and enough? + + if(.not. do_lbfgs .and. .not. do_sd2) then + if (.not. do_linmin_deriv) then + obj = f + obj_new = f_new + else + ! let's pretend that linmin_deriv never goes uphill! + obj = 0.0_dp + obj_new = -1.0_dp + end if + + if(obj-obj_new > abs(stuck_tol*obj_new)) then + ! everything is fine, clear some monitoring flags + bad_iter_counter = 0 + do i=1, extra_report +#ifndef _OPENMP + call verbosity_pop() +#endif + end do + extra_report = 0 + + if(present(linminroutine)) then + if(trim(linminroutine) .EQ. "FAST_LINMIN" .and. .not. do_fast_linmin .and. & + main_counter > fast_linmin_switchback) then + call print("Switching back to FAST_LINMIN linmin") + do_fast_linmin = .TRUE. + end if + end if + !********************************************************************** + !* Otherwise, diagnose problems + !********************************************************************** + else if(obj_new > obj)then ! are we not going down ? then things are very bad + + if( abs(obj-obj_new) < abs(stuck_tol*obj_new))then ! are we stuck ? + call print("*** Minim is stuck, exiting") + exit_flag = 1 + if (present(status)) status = 0 + call system_timer("minim/main_loop/"//main_counter) + cycle !continue + end if + + + call print("*** Minim is not going down at step " // main_counter //" ==> eps /= 10") + eps = oldeps / 10.0_dp + + if (current_verbosity() >= PRINT_NERD) call line_scan(x, hdir, func, .not. do_linmin_deriv, dfunc, data) + if(current_verbosity() >= PRINT_NERD .and. .not. do_linmin_deriv) then + if(.NOT.test_gradient(x, func, dfunc,data=data)) then + call print("*** Gradient test failed!!") + end if + end if + + + if(do_fast_linmin) then + do_fast_linmin = .FALSE. + fast_linmin_switchback = main_counter+5 + call print("Switching off FAST_LINMIN (back after " //& + (fast_linmin_switchback - main_counter) // " steps if all OK") + end if + + call print("Resetting conjugacy") + resetflag = 1 + + main_counter=main_counter-1 + bad_iter_counter=bad_iter_counter+1 ! increment BAD counter + + else ! minim went downhill, but not a lot + + call print("*** Minim is stuck at step " // main_counter // ", trying to unstick", PRINT_VERBOSE) + +#ifndef _OPENMP + if (current_verbosity() >= PRINT_NORMAL) then + call verbosity_push_increment() + extra_report = extra_report + 1 + end if +#endif + + if (current_verbosity() >= PRINT_NERD) call line_scan(x, hdir, func, .not. do_linmin_deriv, dfunc, data) + !********************************************************************** + !* + !* do gradient test if we need to + !* + !**********************************************************************/ + ! + if(current_verbosity() >= PRINT_NERD .and. .not. do_linmin_deriv) then + if(.NOT.test_gradient(x, func, dfunc,data=data)) then + call print("*** Gradient test failed!! Exiting linmin!") + exit_flag = 1 + if (present(status)) status = 1 + call system_timer("minim/main_loop/"//main_counter) + cycle !continue + end if + end if + + bad_iter_counter=bad_iter_counter+1 ! increment BAD counter + eps = my_eps_guess ! try to unstick + call print("resetting eps to " // eps,PRINT_VERBOSE) + resetflag = 1 ! reset CG + end if + + if(bad_iter_counter == max_bad_iter)then + call print("*** BAD iteration counter reached maximum " // max_bad_iter // " exiting") + exit_flag = 1 + if (present(status)) status = 1 + call system_timer("minim/main_loop/"//main_counter) + cycle !continue + end if + end if ! .not. do_bfgs and .not. do_sd2 + + !********************************************************************** + !* + !* accept iteration, get new gradient + !* + !**********************************************************************/ + + f = f_new + x = y + +! Removed resetting +! if(mod(main_counter,50) .EQ. 0) then ! reset CG every now and then regardless +! resetflag = 1 +! end if + + ! measure linmin_quality + if(.not. do_lbfgs) hdirgrad_before = hdir.DOT.grad_f + + grad_f_old = grad_f +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + grad_f = dfunc(x,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + + if( (.not. do_lbfgs) .and. (.not. do_sd2) ) then + hdirgrad_after = hdir.DOT.grad_f + if (hdirgrad_after /= 0.0_dp) then + linmin_quality = hdirgrad_before/hdirgrad_after + else + linmin_quality = HUGE(1.0_dp) + endif + end if + + normsqgrad_f_old = normsqgrad_f + normsqgrad_f = normsq(grad_f) + + + !********************************************************************** + !* Choose minimization method + !**********************************************************************/ + + if(do_sd) then !steepest descent + hdir = -1.0_dp * grad_f + elseif(do_sd2) then + if(main_counter == 1) then + alpha = 1.0e-6_dp + else + alpha = dot_product(x-x_old,grad_f-grad_f_old) / dot_product(grad_f-grad_f_old,grad_f-grad_f_old) + endif + + x_old = x + x = x - alpha * grad_f + y = x + else if(do_cg)then ! conjugate gradients + + if( bad_cg_counter == max_bad_cg .OR.(resetflag > 0)) then ! reset the conj grad cycle + + if( bad_cg_counter .EQ. max_bad_cg) then + call print("*** bad_cg_counter == "// max_bad_cg, PRINT_VERBOSE) + end if + call print("*** Resetting conjugacy", PRINT_VERBOSE) + + + hdir = -1.0_dp * grad_f + bad_cg_counter = 0 + resetflag = 0 + else ! do CG + gdirlen = 0.0 + dcosine = 0.0 + + gg = normsq(gdir) + + if(.NOT.do_pcg) then ! no preconditioning + dgg = max(0.0_dp, (gdir + grad_f).DOT.grad_f) ! Polak-Ribiere formula + gdir = (-1.0_dp) * grad_f + ! the original version was this, I had to change because intrinsic does'nt return allocatables. + ! dgg = (grad_f + gdir).DOT.grad_f + ! gdir = (-1.0_dp) * grad_f + else ! precondition + call System_abort("linmin: preconditioning not implemented") + dgg = 0.0 ! STUPID COMPILER + ! //dgg = (precond^grad_f+gdir)*grad_f; + ! //gdir = -1.0_dp*(precond^grad_f); + end if + if(gg .ne. 0.0_dp) then + hdir = gdir+hdir*(dgg/gg) + else + hdir = gdir + endif + ! calculate direction cosine + dcosine = gdir.DOT.gdir_old + gdir_old = gdir + gdirlen = norm(gdir) + + if(gdirlen .eq. 0.0_dp .or. gdirlen_old .eq. 0.0_dp) then + dcosine = 0.0_dp + else + dcosine = dcosine/(gdirlen*gdirlen_old) + endif + gdirlen_old = gdirlen + + if(abs(dcosine) > 0.2) then + bad_cg_counter= bad_cg_counter +1 + else + bad_cg_counter = 0 + end if + + end if + else if(do_lbfgs)then ! LBFGS method + y = x + call LBFGS(size(x),lbfgs_M,y, f, grad_f, .false., lbfgs_diag, (/-1,0/), 1e-12_dp, 1e-12_dp, lbfgs_work, lbfgs_flag) +! do while(lbfgs_flag == 2) +! call LBFGS(size(x),lbfgs_M,y, f, grad_f, .false., lbfgs_diag, (/-1,0/), 1e-12_dp, 1e-12_dp, lbfgs_work, lbfgs_flag) +! end do + if(lbfgs_flag < 0) then ! internal LBFGS error + call print('LBFGS returned error code '//lbfgs_flag//', exiting') + exit_flag = 1 + if (present(status)) status = 1 + call system_timer("minim/main_loop/"//main_counter) + cycle + end if + else + call System_abort("minim(): c'est ci ne pas une erreur!") + end if + + call system_timer("minim/main_loop/"//main_counter) + main_counter=main_counter + 1 + end do + call system_timer("minim/main_loop") + + if(main_counter >= max_steps) then + call print("Iterations exceeded " // max_steps) + end if + + call print("Goodbye from minim()") + call print("") + minim = main_counter-1 + + x_in = x + + deallocate(x) + deallocate(y, hdir, gdir, gdir_old, grad_f, grad_f_old) + if(allocated(x_old)) deallocate(x_old) + + if(do_lbfgs) then + deallocate(lbfgs_diag) + deallocate(lbfgs_work) + end if + + ! just in case extra pushes weren't popped +#ifndef _OPENMP + do i=1, extra_report + call verbosity_pop() + end do +#endif + + call system_timer("minim") + + end function minim + + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! test_gradient + ! + !% Test a function against its gradient by evaluating the gradient from the + !% function by finite differnces. We can only test the gradient if energy and force + !% functions are pure in that they do not change the input vector + !% (e.g. no capping of parameters). The interface for 'func(x)' and 'dfunc(x)' + !% are the same as for 'minim' above. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + + function test_gradient(xx,func,dfunc, dir,data) + real(dp),intent(in)::xx(:) !% Position + INTERFACE + function func(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + end function func + end INTERFACE + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + real(dp), intent(in), optional, target :: dir(:) !% direction along which to test + character(len=1),optional::data(:) + !%RV Returns true if the gradient test passes, or false if it fails + logical :: test_gradient + + + integer:: N,I,loopend + logical::ok,printit,monitor_ratio + real(dp)::f0, f, tmp, eps, ratio, previous_ratio + ! Dynamically allocate to avoid stack overflow madness with ifort + real(dp),dimension(:), allocatable ::x,dx,x_0 + real(dp), allocatable :: my_dir(:) + + N=size(xx) + allocate(x(N), dx(N), x_0(N)) + x=xx + + if(current_verbosity() > PRINT_VERBOSE) then + printit = .TRUE. + loopend=0 + else + printit = .FALSE. + loopend=1 + end if + + if(printit) then + write(line,*)" "; call print(line) + write(line,*)" " ; call print(line) + write(line,*) "Gradient test"; call print(line) + write(line,*)" " ; call print(line) + end if + + if(printit) then + write(line, *) "Calling func(x)"; call print(line) + end if + !f0 = param_penalty(x_0); +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + f0 = func(x,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + !!//logger("f0: %24.16f\n", f0); + + if(printit) then + write(line, *) "Calling dfunc(x)"; call print(line) + end if +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + dx = dfunc(x,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + !!//dx = param_penalty_deriv(x); + + allocate(my_dir(N)) + if (present(dir)) then + if (norm(dir) .feq. 0.0_dp) & + call system_abort("test_gradient got dir = 0.0, can't use as normalized direction for test") + my_dir = dir/norm(dir) + else + if (norm(dx) == 0.0_dp) & + call system_abort("test_gradient got dfunc = 0.0, can't use as normalized direction for test") + my_dir = (-1.0_dp)*dx/norm(dx) + endif + !//my_dir.zero(); + !//my_dir.randomize(0.1); + !//my_dir.x[4] = 0.1; + !//logger("dx: ");dx.print(logger_stream); + + tmp = my_dir.DOT.dx + x_0(:) = x(:) + !//logger("x0: "); x_0.print(logger_stream); + + if(printit) then + call print("GT eps (f-f0)/(eps*df) f") + end if + + ok = .FALSE. + ratio = 0.0 + + do i=0,loopend ! do it twice, print second time if not OK + previous_ratio = 0.0 + monitor_ratio = .FALSE. + + eps=1.0e-1_dp + do while(eps>1.e-20) + + + x = x_0 + eps*my_dir + !//logger("x: "); x.print(logger_stream); + !//f = param_penalty(x); +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + f = func(x,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + !//logger("f: %24.16f\n", f); + previous_ratio = ratio + ratio = (f-f0)/(eps*tmp) + + if(printit) then + write(line,'("GT ",e8.2,f22.16,e24.16)') eps, ratio, f; + call print(line) + end if + + if(abs(ratio-1.0_dp) .LT. 1e-2_dp) monitor_ratio = .TRUE. + + if(.NOT.monitor_ratio) then + if(abs((f-f0)/f0) .LT. NUMERICAL_ZERO) then ! we ran out of precision, gradient is really bad + call print("(f-f0)/f0 " // ((f-f0)/f0) // " ZERO " // NUMERICAL_ZERO, PRINT_ANALYSIS) + call print("ran out of precision, quitting loop", PRINT_ANALYSIS) + exit + end if + end if + + if(monitor_ratio) then + if( abs(ratio-1.0_dp) > abs(previous_ratio-1.0_dp) )then ! sequence broke + if(abs((f-f0)/f0*(ratio-1.0_dp)) < 1e-10_dp) then ! lets require 10 digits of precision + ok = .TRUE. + !//break; + end if + end if + end if + + eps=eps/10.0 + end do + + if(.NOT.ok) then + printit = .TRUE. ! go back and print it + else + exit + end if + + end do + if(printit) then + write(line,*)" "; call print(line, PRINT_NORMAL) + end if + + if(ok) then + write(line,*)"Gradient test OK"; call print(line, PRINT_VERBOSE) + end if + test_gradient= ok + + deallocate(x, dx, x_0) + deallocate(my_dir) + + + end function test_gradient + + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! + ! n_test_gradient + ! + !% Test a function against its gradient by evaluating the gradient from the + !% function by symmetric finite differnces. We can only test the gradient if + !% energy and force functions are pure in that they do not change the input + !% vector (e.g. no capping of parameters). The interface for 'func(x)' and + !% 'dfunc(x)'are the same as for 'minim' above. + ! + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + subroutine n_test_gradient(xx,func,dfunc, dir,data) + real(dp),intent(in)::xx(:) !% Position + INTERFACE + function func(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + end function func + end INTERFACE + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + real(dp), intent(in), optional, target :: dir(:) !% direction along which to test + character(len=1),optional::data(:) + + integer N, i + real(dp) :: eps, tmp, fp, fm + real(dp), allocatable :: x(:), dx(:) + real(dp), pointer :: my_dir(:) + + N=size(xx) + allocate(x(N), dx(N)) + x=xx + + dx = dfunc(x,data) + + if (present(dir)) then + if (norm(dir) == 0.0_dp) & + call system_abort("n_test_gradient got dir = 0.0, can't use as normalized direction for test") + allocate(my_dir(N)) + my_dir = dir/norm(dir) + else + if (norm(dx) == 0.0_dp) & + call system_abort("n_test_gradient got dfunc = 0.0, can't use as normalized direction for test") + allocate(my_dir(N)) + my_dir = (-1.0_dp)*dx/norm(dx) + endif + + tmp = my_dir.DOT.dx + + do i=2, 10 + eps = 10.0_dp**(-i) + x = xx + eps*my_dir + fp = func(x,data) + x = xx - eps*my_dir + fm = func(x,data) + call print ("fp " // fp // " fm " // fm) + call print("GT_N eps " // eps // " D " // tmp // " FD " // ((fp-fm)/(2.0_dp*eps)) // " diff " // (tmp-(fp-fm)/(2.0_dp*eps))) + end do + + deallocate(x, dx) + deallocate(my_dir) + + end subroutine n_test_gradient + + + !% FIRE MD minimizer from Bitzek et al., \emph{Phys. Rev. Lett.} {\bfseries 97} 170201. + !% Beware, this algorithm is patent pending in the US. + function fire_minim(x, mass, func, dfunc, dt0, tol, max_steps, hook, hook_print_interval, data, dt_max, status) + real(dp), intent(inout), dimension(:) :: x + real(dp), intent(in) :: mass + interface + function func(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + end function func + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + end interface + real(dp), intent(in) :: dt0 + real(dp), intent(in) :: tol + integer, intent(in) :: max_steps + optional :: hook + interface + subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + end subroutine hook + end interface + integer, optional :: hook_print_interval + character(len=1),optional::data(:) + real(dp), intent(in), optional :: dt_max + integer, optional, intent(out) :: status + integer :: fire_minim + + integer :: my_hook_print_interval + + real(dp), allocatable, dimension(:) :: velo, acc, force + real(dp) :: f, df2, alpha_start, alpha, P, dt, my_dt_max + integer :: i, Pcount + logical :: done + + if (present(status)) status = 0 + + if (current_verbosity() >= PRINT_VERBOSE) then + my_hook_print_interval = optional_default(1, hook_print_interval) + else if (current_verbosity() >= PRINT_NORMAL) then + my_hook_print_interval = optional_default(10, hook_print_interval) + else if (current_verbosity() >= PRINT_SILENT) then + my_hook_print_interval = optional_default(100000, hook_print_interval) + endif + + allocate (velo(size(x)), acc(size(x)), force(size(x))) + + alpha_start = 0.1_dp + alpha = alpha_start + dt = dt0 + my_dt_max = optional_default(20.0_dp*dt, dt_max) + Pcount = 0 + + call Print('Welcome to fire_minim', PRINT_NORMAL) + call Print('Attempting to find minimum with tolerance '// tol, PRINT_NORMAL) + + velo = 0 + acc = -dfunc(x,data)/mass + + do i = 1, max_steps + + velo = velo + (0.5_dp*dt)*acc + force = dfunc(x,data) ! keep original sign of gradient for now as hook() expects gradient, not force + + df2 = normsq(force) + + if (df2 < tol) then + write (line, '(i4,a,e10.2)') i, ' force^2 = ', df2 + call Print(line, PRINT_NORMAL) + + write (line, '(a,i0,a)') 'Converged in ', i, ' steps.' + call Print(line, PRINT_NORMAL) + exit + else if(mod(i, my_hook_print_interval) == 0) then + f = func(x,data) + write (line, '(i4,a,e24.16,a,e24.16,a,f0.3,a,e24.16)') i,' f=',f,' df^2=',df2,' dt=', dt, 'max(abs(df))=', maxval(abs(force)) + call Print(line, PRINT_NORMAL) + + if(present(hook)) then + call hook(x, force, f, done, (mod(i-1,my_hook_print_interval) == 0), data) + if (done) then + call print('hook reports that fire_minim is finished, exiting.', PRINT_NORMAL) + exit + end if + end if + end if + + force = -force ! convert from gradient of energy to force + acc = force/mass + velo = velo + (0.5_dp*dt)*acc + + P = velo .dot. force + velo = (1.0_dp-alpha)*velo + (alpha*norm(velo)/norm(force))*force + if (P > 0) then + if(Pcount > 5) then + dt = min(dt*1.1_dp, my_dt_max) + alpha = alpha*0.99_dp + else + Pcount = Pcount + 1 + end if + else + dt = dt*0.5_dp + velo = 0.0_dp + alpha = alpha_start + Pcount = 0 + end if + + x = x + dt*velo + x = x + (0.5_dp*dt*dt)*acc + + if(current_verbosity() >= PRINT_NERD) then + write (line, '(a,e24.16)') 'E=', func(x,data) + call print(line,PRINT_NERD) + call print(x,PRINT_NERD) + end if + end do + + if(i == max_steps) then + write (line, '(a,i0,a)') 'fire_minim: Failed to converge in ', i, ' steps.' + call Print(line, PRINT_ALWAYS) + if (present(status)) status = 1 + end if + + fire_minim = i + + deallocate(velo, acc, force) + + end function fire_minim + + + +!%%%% +!% Noam's line minimizer +!% +!% args +!% x: input vector, flattened into 1-D double array +!% bothfunc: input pointer to function computing value and gradient +!% neg_gradient: input negative of gradient (i.e. force) for input x +!% E: input value at x +!% search_dir: input vector search direction, not necessarily normalized +!% new_x: output x at minimimum +!% new_new_gradient: output negative of gradient at new_x +!% new_E: output value at new_x +!% max_step_size: input max step size (on _normalized_ search dir), output actual step size for this linmin +!% accuracy: input desired accuracy on square of L2 norm of projected gradient +!% N_evals: input initial number of function evals so far, output final number of function evalutions +!% max_N_evals: input max number of function evaluations before giving up +!% hook: input pointer to function to call after each evaluation +!% data: input pointer to other data needed for calc, flattened to 1-D character array with transfer() +!% error: output error state +!%%%% + +subroutine n_linmin(x, bothfunc, neg_gradient, E, search_dir, & + new_x, new_neg_gradient, new_E, & + max_step_size, accuracy, N_evals, max_N_evals, hook, hook_print_interval, & + data, error) + real(dp), intent(inout) :: x(:) + real(dp), intent(in) :: neg_gradient(:) + interface + subroutine bothfunc(x,E,f,data,error) + use system_module + real(dp)::x(:) + real(dp)::E + real(dp)::f(:) + character(len=1),optional::data(:) + integer,optional :: error + end subroutine bothfunc + end interface + real(dp), intent(inout) :: E + real(dp), intent(inout) :: search_dir(:) + real(dp), intent(out) :: new_x(:), new_neg_gradient(:) + real(dp), intent(out) :: new_E + real(dp), intent(inout) :: max_step_size + real(dp), intent(in) :: accuracy + integer, intent(inout) :: N_evals + integer, intent(in) :: max_N_evals + optional :: hook + interface + subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + end subroutine hook + end interface + integer, intent(in), optional :: hook_print_interval + character(len=1),optional::data(:) + integer, intent(out), optional :: error + + logical :: do_print + real(dp) search_dir_mag + real(dp) p0_dot, p1_dot, new_p_dot + real(dp), allocatable :: p0(:), p1(:), p0_ng(:), p1_ng(:), new_p(:), new_p_ng(:), t_projected(:) + real(dp) p0_E, p1_E, new_p_E + real(dp) p0_pos, p1_pos, new_p_pos + + real(dp) tt + real(dp) t_a, t_b, t_c, Ebar, pbar, soln_1, soln_2 + + integer :: n_pure_linesearch + integer :: max_pure_linesearch = 10 + logical done, use_cubic, got_valid_cubic + + integer l_error + real(dp) est_step_size + + INIT_ERROR(error) + + do_print = .false. + + allocate(p0(size(x))) + allocate(p1(size(x))) + allocate(p0_ng(size(x))) + allocate(p1_ng(size(x))) + allocate(new_p(size(x))) + allocate(new_p_ng(size(x))) + allocate(t_projected(size(x))) + + call print ("n_linmin starting line minimization", PRINT_NERD) + call print ("n_linmin initial |x| " // norm(x) // " |neg_gradient| " // & + norm(neg_gradient) // " |search_dir| " // norm(search_dir), PRINT_NERD) + + search_dir_mag = norm(search_dir) + ! search_dir = search_dir / search_dir_mag + search_dir = search_dir / search_dir_mag + + p0_dot = neg_gradient .dot. search_dir + + t_projected = search_dir*p0_dot + if (normsq(t_projected) .lt. accuracy) then + call print ("n_linmin initial config is apparently converged " // norm(t_projected) // " " // accuracy, PRINT_NERD) + endif + + p0_pos = 0.0_dp + p0 = x + p0_ng = neg_gradient + p0_E = E + + p0_dot = p0_ng .dot. search_dir + call print("initial p0_dot " // p0_dot, PRINT_NERD) + + if (p0_dot .lt. 0.0_dp) then + p0_ng = -p0_ng + p0_dot = -p0_dot + endif + + call print("cg_n " // p0_pos // " " // p0_e // " " // p0_dot // " " // & + normsq(p0_ng) // " " // N_evals // " bracket starting", PRINT_VERBOSE) + + est_step_size = 4.0_dp*maxval(abs(p0_ng))**2/p0_dot + if (max_step_size .gt. 0.0_dp .and. est_step_size .gt. max_step_size) then + est_step_size = max_step_size + endif + + p1_pos = est_step_size + p1 = x + p1_pos*search_dir + p1_ng = p0_ng + l_error = 1 + do while (l_error .ne. 0) + N_evals = N_evals + 1 + l_error=0 + call bothfunc(p1, p1_e, p1_ng, data, error=l_error); p1_ng = -p1_ng + if (present(hook_print_interval)) do_print = (mod(N_evals, hook_print_interval) == 0) + if (present(hook)) call hook(p1,p1_ng,p1_E,done,do_print,data) + if (l_error .ne. 0) then + call print("cg_n " // p1_pos // " " // p1_e // " " // 0.0_dp // " " // & + 0.0_dp // " " // N_evals // " bracket first step ERROR", PRINT_ALWAYS) + est_step_size = est_step_size*0.5_dp + p1_pos = est_step_size + p1 = x + p1_pos*search_dir + endif + if (N_evals .gt. max_N_evals) then + RAISE_ERROR_WITH_KIND(ERROR_MINIM_NOT_CONVERGED, "n_linmin ran out of iterations", error) + endif + end do + + p1_dot = p1_ng .dot. search_dir + + call print("cg_n " // p1_pos // " " // p1_e // " " // p1_dot // " " // & + normsq(p1_ng) // " " // N_evals // " bracket first step", PRINT_VERBOSE) + + t_projected = search_dir*p1_dot + ! if (object_norm(t_projected,norm_type) .lt. accuracy) then + ! ! search_dir = search_dir * search_dir_mag + ! call scalar_selfmult (search_dir, search_dir_mag) + ! minimize_along = 0 + ! call print ("returning from minimize_along, t_projected is_converged") + ! return + ! endif + + call print ("starting bracketing loop", PRINT_NERD) + + ! bracket solution + do while (p1_dot .ge. 0.0_dp) + p0 = p1 + p0_ng = p1_ng + p0_E = p1_E + p0_pos = p1_pos + p0_dot = p1_dot + + p1_pos = p1_pos + est_step_size + + call print ("checking bracketing for " // p1_pos, PRINT_NERD) + + p1 = x + p1_pos*search_dir + l_error = 1 + do while (l_error .ne. 0) + N_evals = N_evals + 1 + l_error = 0 + call bothfunc (p1, p1_E, p1_ng, data, error=l_error); p1_ng = -p1_ng + if (present(hook_print_interval)) do_print = (mod(N_evals, hook_print_interval) == 0) + if (present(hook)) call hook(p1,p1_ng,p1_E,done,do_print,data) + if (done) then + call print("hook reported done", PRINT_NERD) + search_dir = search_dir * search_dir_mag + new_x = p1 + new_neg_gradient = p1_ng + new_E = p1_E + return + endif + if (l_error .ne. 0) then + call print("cg_n " // p0_pos // " " // p0_e // " " // 0.0_dp // " " // & + 0.0_dp // " " // N_evals // " bracket loop ERROR", PRINT_ALWAYS) + call print ("Error in bracket loop " // l_error // " stepping back", PRINT_ALWAYS) + p1_pos = p1_pos - est_step_size + est_step_size = est_step_size*0.5_dp + p1_pos = p1_pos + est_step_size + p1 = x + p1_pos*search_dir + endif + if (N_evals .gt. max_N_evals) then + search_dir = search_dir * search_dir_mag + RAISE_ERROR_WITH_KIND(ERROR_MINIM_NOT_CONVERGED, "n_linmin ran out of iterations", error) + endif + end do + + p1_dot = p1_ng .dot. search_dir + + ! tt = -p0_dot/(p1_dot-p0_dot) + ! if (1.5D0*tt*(p1_pos-p0_pos) .lt. 10.0*est_step_size) then + ! est_step_size = 1.5_dp*tt*(p1_pos-p0_pos) + ! else + est_step_size = est_step_size*2.0_dp + ! end if + + call print("cg_n " // p1_pos // " " // p1_e // " " // p1_dot // " " // & + normsq(p1_ng) // " " // N_evals // " bracket loop", PRINT_VERBOSE) + end do + + call print ("bracketed by" // p0_pos // " " // p1_pos, PRINT_NERD) + + done = .false. + t_projected = 2.0_dp*sqrt(accuracy) + !new_p_dot = accuracy*2.0_dp + n_pure_linesearch = 0 + do while (n_pure_linesearch < max_pure_linesearch .and. normsq(t_projected) .ge. accuracy .and. (.not. done)) + n_pure_linesearch = n_pure_linesearch + 1 + call print ("n_linmin starting true minimization loop", PRINT_NERD) + + use_cubic = .false. + if (use_cubic) then + !!!! fit to cubic polynomial + Ebar = p1_E-p0_E + pbar = p1_pos-p0_pos + t_a = (-p0_dot) + t_c = (pbar*((-p1_dot)-(-p0_dot)) - 2.0_dp*Ebar + 2*(-p0_dot)*pbar)/pbar**3 + t_b = (Ebar - (-p0_dot)*pbar - t_c*pbar**3)/pbar**2 + + soln_1 = (-2.0_dp*t_b + sqrt(4.0_dp*t_b**2 - 12.0_dp*t_a*t_c))/(6.0_dp*t_c) + soln_2 = (-2.0_dp*t_b - sqrt(4.0_dp*t_b**2 - 12.0_dp*t_a*t_c))/(6.0_dp*t_c) + + if (soln_1 .ge. 0.0_dp .and. soln_1 .le. pbar) then + new_p_pos = p0_pos + soln_1 + got_valid_cubic = .true. + else if (soln_2 .ge. 0.0_dp .and. soln_2 .le. pbar) then + new_p_pos = p0_pos + soln_2 + got_valid_cubic = .true. + else + call print ("n_linmin warning: no valid solution for cubic", PRINT_ALWAYS) + !!!! use only derivative information to find pt. where derivative = 0 + tt = -p0_dot/(p1_dot-p0_dot) + new_p_pos = p0_pos + tt*(p1_pos-p0_pos) + done = .false. + endif + else + !!!! use only derivative information to find pt. where derivative = 0 + tt = -p0_dot/(p1_dot-p0_dot) + new_p_pos = p0_pos + tt*(p1_pos-p0_pos) + ! done = .true. + done = .false. + endif + + new_p = x + new_p_pos*search_dir + N_evals = N_evals + 1 + call bothfunc (new_p, new_p_E, new_p_ng, data, error); new_p_ng = -new_p_ng + if (error .ne. 0) then + call system_abort("n_linmin: Error in line search " // error) + endif + + if (N_evals .gt. max_N_evals) done = .true. + + ! if (inner_prod(new_p_ng,new_p_ng) .lt. 0.1 .and. got_valid_cubic) done = .true. + ! if (got_valid_cubic) done = .true. + + new_p_dot = new_p_ng .dot. search_dir + + call print("cg_n " // new_p_pos // " " // new_p_E // " " // new_p_dot // " " // & + normsq(new_p_ng) // " " // N_evals // " during line search", PRINT_VERBOSE) + + if (new_p_dot .gt. 0) then + p0 = new_p + p0_pos = new_p_pos + p0_dot = new_p_dot + p0_ng = new_p_ng + p0_E = new_p_E + else + p1 = new_p + p1_pos = new_p_pos + p1_dot = new_p_dot + p1_ng = new_p_ng + p1_E = new_p_E + endif + + t_projected = search_dir*new_p_dot + end do + + new_x = new_p + new_neg_gradient = new_p_ng + new_E = new_p_E + + max_step_size = new_p_pos + search_dir = search_dir * search_dir_mag + + call print ("done with line search", PRINT_NERD) +end subroutine n_linmin + +!%%%% +!% Noam's minimizer with preconditioning from Cristoph Ortner +!% return value: number of function evaluations +!% args +!% x_i: input vector, flattened into a 1-D double array +!% bothfunc: input pointer to function that returns value and gradient +!% can apply simple constraints and external (body) forces +!% use_precond: input logical controling preconditioning +!% apply_precond_func: input pointer to function that applies preconditioner to a vector +!% initial_E: output initial value +!% final_E: output final value +!% expected reduction: input expected reduction in value used to estimate initial step +!% max_N_evals: max number of function evaluations before giving up +!% accuracy: desired accuracy on square of L2 norm of gradient +!% hook: pointer to function passed to linmin and called once per CG step +!% does stuff like print configuration, and can also apply other ending conditions, +!% although latter capability isn't used +!% hook_print_interval: how often to call hook, depending on verbosity level +!% data: other data both_func will need to actually do calculation, flattened into +!% character array by transfer() function. Maybe be replaced with F2003 pointer soon +!% error: output error state +!%%%% +function n_minim(x_i, bothfunc, use_precond, apply_precond_func, initial_E, final_E, & + expected_reduction, max_N_evals, accuracy, hook, hook_print_interval, data, error) result(N_evals) + real(dp), intent(inout) :: x_i(:) + interface + subroutine bothfunc(x,E,f,data,error) + use system_module + real(dp)::x(:) + real(dp)::E + real(dp)::f(:) + character(len=1),optional::data(:) + integer, optional :: error + end subroutine bothfunc + end interface + logical :: use_precond + interface + subroutine apply_precond_func(x,g,P_g,data,error) + use system_module + real(dp)::x(:),g(:),P_g(:) + character(len=1),optional::data(:) + integer, optional :: error + end subroutine apply_precond_func + end interface + real(dp), intent(out) :: initial_E, final_E + real(dp), intent(inout) :: expected_reduction + integer, intent(in) :: max_N_evals + real(dp), intent(in) :: accuracy + optional :: hook + integer :: N_evals + interface + subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + end subroutine hook + end interface + integer, optional :: hook_print_interval + character(len=1),optional::data(:) + integer, optional, intent(out) :: error + + real(dp) :: E_i, E_ip1 + + logical :: done, hook_done + integer :: iter + real(dp) :: max_step_size, initial_step_size + + real(dp), allocatable :: g_i(:) + real(dp), allocatable :: x_ip1(:), g_ip1(:) + real(dp), allocatable :: h_i(:) + real(dp), allocatable :: P_g(:) + + real(dp) :: g_i_dot_g_i, g_ip1_dot_g_i, g_ip1_dot_g_ip1 + real(dp) :: gamma_i + + integer :: l_error + + integer :: my_hook_print_interval + + INIT_ERROR(error) + + if (current_verbosity() >= PRINT_VERBOSE) then + my_hook_print_interval = optional_default(1, hook_print_interval) + else if (current_verbosity() >= PRINT_NORMAL) then + my_hook_print_interval = optional_default(10, hook_print_interval) + else if (current_verbosity() >= PRINT_SILENT) then + my_hook_print_interval = optional_default(100000, hook_print_interval) + endif + + allocate(g_i(size(x_i))) + allocate(x_ip1(size(x_i))) + allocate(g_ip1(size(x_i))) + allocate(h_i(size(x_i))) + N_evals = 1 + call bothfunc(x_i, E_i, g_i, data, error=error); g_i = -g_i + if (present(hook)) call hook(x_i, g_i, E_i, done, .true., data) + PASS_ERROR_WITH_INFO("n_minim first evaluation", error) + initial_E = E_i + + allocate(P_g(size(x_i))) + ! need to get P into the routine somehow + if (use_precond) then + call apply_precond_func(x_i, g_i, P_g, data, error=error) + PASS_ERROR_WITH_INFO("n_miniCGinitial preconditioning call", error) + else + P_g = g_i + endif + + call print("#cg_n use_precond="//use_precond) + + call print("#cg_n " // " x" // & + " val" // & + " -grad.dir" // & + " |grad|^2" // " n_evals") + call print("cg_n " // 0.0_dp // " " // E_i // " " // (g_i.dot.g_i) // " " // & + normsq(g_i) // " " // N_evals // " INITIAL_VAL") + + if (normsq(g_i) .lt. accuracy) then + call print("cg_n " // 0.0_dp // " " // E_i // " " // (g_i.dot.g_i) // " " // & + normsq(g_i) // " " // N_evals // " FINAL_VAL") + call print ("n_minim initial config is converged " // norm(g_i) // " " // accuracy, PRINT_VERBOSE) + final_E = initial_E + return + endif + + h_i = P_g + + iter = 1 + done = .false. + do while (N_evals .le. max_N_evals .and. (.not.(done))) + + !! max_step_size = 4.0_dp*expected_reduction / norm(g_i) + max_step_size = 1.0_dp * expected_reduction / (g_i .dot. (h_i/norm(h_i))) ! dividing by norm(h_i) because n_linmin will normalize h_i + ! if (max_step_size .gt. 1.0_dp) then + ! max_step_size = 1.0_dp + ! endif + call print("max_step_size "//max_step_size, verbosity=PRINT_VERBOSE) + + call print("cg_n " // 0.0_dp // " " // E_i // " " // (g_i.dot.h_i) // " " // & + normsq(g_i) // " " // N_evals // " n_minim pre linmin") + l_error = ERROR_NONE + call n_linmin(x_i, bothfunc, g_i, E_i, h_i, & + x_ip1, g_ip1, E_ip1, & + max_step_size, accuracy, N_evals, max_N_evals, hook, hook_print_interval, data, l_error) + if (l_error == ERROR_MINIM_NOT_CONVERGED) then + if (N_evals > max_N_evals) then + final_E = E_i + RAISE_ERROR_WITH_KIND(l_error, "linmin: n_minim didn't converge", error) + endif + ! we're just going to continue after an unconverged linmin, + CLEAR_ERROR() + else + PASS_ERROR_WITH_INFO("linmin: n_minim error", error) + endif + + call print("cg_n " // 0.0_dp // " " // E_ip1 // " " // (g_ip1.dot.h_i) // " " // & + normsq(g_ip1) // " " // N_evals // " n_minim post linmin") + + if (E_ip1 > E_i) then + final_E = E_i + call print("WARNING:n_minim: n_limin stepped uphill - forces may not be consistent with energy", verbosity=PRINT_ALWAYS) + ! RAISE_ERROR("n_minim: n_limin stepped uphill - forces may not be consistent with energy", error) + endif + + if (normsq(g_ip1) .lt. accuracy) then + call print("n_minim is converged", PRINT_VERBOSE) + E_i = E_ip1 + x_i = x_ip1 + g_i = g_ip1 + done = .true. + endif + + ! gamma_i = sum(g_ip1*g_ip1)/sum(g_i*g_i) ! Fletcher-Reeves + ! gamma_i = sum((g_ip1-g_i)*g_ip1)/sum(g_i*g_i) ! Polak-Ribiere + g_i_dot_g_i = g_i .dot. P_g + g_ip1_dot_g_i = g_ip1 .dot. P_g + !! perhaps have some way of telling apply_precond_func to update/not update preconitioner? + if (use_precond) then + call apply_precond_func(x_ip1, g_ip1, P_g, data, error=error) + PASS_ERROR_WITH_INFO("n_minim in-loop preconditioning call", error) + else + P_g = g_ip1 + endif + g_ip1_dot_g_ip1 = g_ip1 .dot. P_g + gamma_i = (g_ip1_dot_g_ip1 - g_ip1_dot_g_i)/g_i_dot_g_i + ! steepest descent + ! gamma_i = 0.0_dp + h_i = gamma_i*h_i + P_g + + if (iter .eq. 1) then + expected_reduction = abs(E_i - E_ip1)/10.0_dp + else + expected_reduction = abs(E_i - E_ip1)/2.0_dp + endif + + E_i = E_ip1 + x_i = x_ip1 + g_i = g_ip1 + ! P_g is already P_g_ip1 from gamma_i evaluation code + + if (present(hook)) then + call hook(x_i,g_i,E_i,hook_done,(mod(iter-1,my_hook_print_interval) == 0), data) + if (hook_done) done = .true. + endif + + call print("cg_n " // 0.0_dp // " " // E_i // " " // (g_i.dot.h_i) // " " // & + normsq(g_i) // " " // N_evals // " n_minim with new dir") + + call print("n_minim loop end, N_evals " // N_evals // " max_N_evals " // max_N_evals // & + " done " // done, PRINT_VERBOSE) + + iter = iter + 1 + + end do + + if (present(hook)) then + call hook(x_i,g_i,E_i,hook_done,.true.,data) + if (hook_done) done = .true. + endif + + final_E = E_i + + call print("cg_n " // 0.0_dp // " " // final_E // " " // (g_i.dot.h_i) // " " // & + normsq(g_i) // " " // N_evals // " FINAL_VAL") + +end function n_minim + +subroutine line_scan(x0, xdir, func, use_func, dfunc, data) + real(dp)::x0(:) !% Starting vector + real(dp)::xdir(:)!% Search direction + INTERFACE + function func(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + end function func + END INTERFACE + logical :: use_func + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + character(len=1), optional::data(:) + + integer :: i + real(dp) :: new_eps + real(dp) :: fn, dirdx_new + real(dp), allocatable :: xn(:), dxn(:) + + allocate(xn(size(x0))) + allocate(dxn(size(x0))) + + fn = 0.0_dp + call print('line scan:', PRINT_NORMAL) + new_eps = 1.0e-5_dp + do i=1,50 + xn = x0 + new_eps*xdir +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + if (use_func) fn = func(xn,data) + dxn = dfunc(xn,data) +#ifndef _OPENMP + call verbosity_pop() +#endif + dirdx_new = xdir .DOT. dxn + + call print('LINE_SCAN ' // new_eps//' '//fn// ' '//dirdx_new, PRINT_NORMAL) + + new_eps = new_eps*1.15 + enddo + + deallocate(xn) + +end subroutine line_scan + +function func_wrapper(func, x, data, local_energy, gradient, doefunc) + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + integer, intent(in) :: doefunc + real(dp)::func_wrapper + + if (doefunc == E_FUNC_BASIC) then + func_wrapper = func(x, data, gradient=gradient) + if (present(local_energy)) then + local_energy = 0.0_dp + local_energy(1) = func_wrapper + endif + else + func_wrapper = func(x, data, local_energy=local_energy, gradient=gradient) + endif +end function func_wrapper + +! Interface is made to imitate the existing interface. + function preconminim(x_in,func,dfunc,build_precon,pr,method,convergence_tol,max_steps,efuncroutine,LM, linminroutine, hook, & + hook_print_interval, am_data, status,writehessian,gethessian,getfdhconnectivity,infoverride,infconvext) + + implicit none + + real(dp), intent(inout) :: x_in(:) !% Starting position + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + INTERFACE + subroutine build_precon(pr,am_data) + use system_module + import precon_data + type(precon_data),intent(inout) ::pr + character(len=1)::am_data(:) + end subroutine + END INTERFACE + type(precon_data):: pr + character(*), intent(in) :: method !% 'cg' for conjugate gradients or 'sd' for steepest descent + real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ + !% 'convergence_tol'. + integer, intent(in) :: max_steps !% Maximum number of 'cg' or 'sd' steps + character(*), intent(in), optional :: efuncroutine !% Control of the objective function evaluation + character(*), intent(in), optional :: linminroutine !% Name of the line minisation routine to use. + integer, optional :: LM + optional :: hook + INTERFACE + subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + end subroutine hook + end INTERFACE + integer, intent(in), optional :: hook_print_interval + character(len=1), optional, intent(inout) :: am_data(:) + integer, optional, intent(out) :: status + optional :: writehessian + INTERFACE + subroutine writehessian(x,data,filename) + use system_module + real(dp) :: x(:) + character(len=1)::data(:) + character(*) :: filename + end subroutine writehessian + end INTERFACE + optional :: gethessian + INTERFACE + subroutine gethessian(x,data,FDHess) + use system_module + real(dp),intent(in):: x(:) + character(len=1),intent(in)::data(:) + real(dp),intent(inout) :: FDHess(:,:) + end subroutine gethessian + end INTERFACE + optional :: getfdhconnectivity + INTERFACE + subroutine getfdhconnectivity(rows,columns,rn,data) + use system_module + integer, intent(inout) :: rows(:), columns(:) + integer, intent(out) :: rn + character(len=1), intent(in)::data(:) + end subroutine + end INTERFACE + ! result + real(dp), optional :: infoverride + logical, optional :: infconvext + integer::preconminim + + logical :: doFD,doSD, doCG,doLBFGS,doDLLBFGS,doSHLBFGS,doSHLSR1,doGHLBFGS,doGHLSR1,doGHFD,doSHFD, doGHFDH, doprecon,done + logical :: doLSbasic,doLSbasicpp,doLSstandard, doLSnone,doLSMoreThuente,doLSunit + integer :: doefunc + real(dp),allocatable :: x(:),xold(:),s(:),sold(:),g(:),gold(:),pg(:),pgold(:),xcand(:),gcand(:) + real(dp) :: alpha,alphamax, beta,betanumer,betadenom,f + integer :: n_iter,N, abortcount + real(dp),allocatable :: alpvec(:),dirderivvec(:) + integer :: my_hook_print_interval + real(dp) :: normsqgrad, normsqs + integer :: this_ls_count, total_ls_count + real(dp) :: amax + real(dp),allocatable :: local_energy(:),local_energyold(:),local_energycand(:) + real(dp) :: dotpgout + type (precon_data) :: hess + real(dp),allocatable :: LBFGSs(:,:), LBFGSy(:,:), LBFGSa(:,:), LBFGSb(:,:), LBFGSalp(:), LBFGSbet(:), LBFGSrho(:), LBFGSq(:), LBFGSz(:), LBFGSbuf1(:), LBFGSbuf2(:) + real(dp),allocatable :: LBFGSdlr(:,:) + integer :: LBFGSm, LBFGScount + integer :: I, n_back,thisind + integer :: k_out + + real(dp), allocatable :: TRcandg(:),TRBs(:),TRyk(:) + real(dp) :: TRared,TRpred,TRdelta,fcand,TRrho,ftest + type(precon_data) :: TRB + real(dp) :: TReta = 0.25 + real(dp) :: TRr = 10.0**(-8) + + real(dp), allocatable :: FDhess(:,:) + integer, allocatable :: IPIV(:) + real(dp), allocatable :: LBFGSd(:,:), LBFGSl(:,:), SR1testvec(:) + integer :: SR1I,SR1J + integer :: INFO + real(dp) :: SR1testLHS,SR1testRHS + logical :: SR1doupdate + logical :: term2norm + + + N = size(x_in) + + !allocate NLCG vectors + allocate(x(N)) + allocate(xold(N)) + allocate(s(N)) + allocate(sold(N)) + allocate(g(N)) + allocate(gold(N)) + allocate(pg(N)) + allocate(pgold(N)) + + !allocate linesearch history vectors + allocate(alpvec(max_steps)) + allocate(dirderivvec(max_steps)) + + allocate(local_energy( (size(x) - 9)/3 )) + allocate(local_energyold( (size(x) - 9)/3 )) + + if (current_verbosity() >= PRINT_VERBOSE) then + my_hook_print_interval = optional_default(1, hook_print_interval) + else if (current_verbosity() >= PRINT_NORMAL) then + my_hook_print_interval = optional_default(10, hook_print_interval) + else + my_hook_print_interval = optional_default(100000, hook_print_interval) + endif + + doFD = .false. + doCG = .FALSE. + doSD = .FALSE. + doLBFGS = .false. + doDLLBFGS = .false. + doSHLBFGS = .false. + doSHLSR1 = .false. + doGHLBFGS = .false. + doGHLSR1 = .false. + doGHFD = .false. + doGHFDH = .false. + doSHFD = .false. + if (trim(method) == 'preconCG') then + doCG = .TRUE. + call print("Using preconditioned Polak-Ribiere Conjugate Gradients") + else if (trim(method) == 'preconSD') then + doSD = .TRUE. + call print("Using preconditioned Steepest Descent") + else if (trim(method) == 'preconLBFGS') then + doLBFGS = .TRUE. + call print ("Using linesearching limited memory BFGS") + else if (trim(method) == 'preconDLLBFGS') then + doDLLBFGS = .true. + call print ("Using dogleg trust region limited memory BFGS") + else if (trim(method) == 'preconSHLBFGS') then + doSHLBFGS = .true. + call print ("Using Steihaug trust region limited memory BFGS") + else if (trim(method) == 'preconSHLSR1') then + doSHLSR1 = .true. + call print ("Using Steihaug trust region limited memory SR1") + else if (trim(method) == 'preconSHFD') then + doSHFD = .true. + call print ("Using Steihaug trust region with FD based Hessian") + else if (trim(method) == 'FD') then + doFD = .true. + else + call print('Unrecognized minim method, exiting') + call exit() + end if + + if (doLBFGS .or. doDLLBFGS .or. doSHLBFGS .or. doSHLSR1 .or. doSHFD) then + + LBFGSm = 20 + if ( present(LM) ) LBFGSm = LM + + allocate(LBFGSs(N,LBFGSm)) + allocate(LBFGSy(N,LBFGSm)) + allocate(LBFGSalp(LBFGSm)) + allocate(LBFGSbet(LBFGSm)) + allocate(LBFGSrho(LBFGSm)) + allocate(LBFGSz(N)) + allocate(LBFGSq(N)) + allocate(LBFGSbuf1(N)) + allocate(LBFGSdlr(LBFGSm,LBFGSm)) + LBFGSbuf1 = 0.0 + LBFGScount = 0 + LBFGSy = 0.0_dp + LBFGSs = 0.0_dp + LBFGSdlr = 0.0_dp + LBFGSrho = 0.0 + end if + if(doDLLBFGS .or. doSHLBFGS .or. doSHLSR1 .or. doSHFD ) then + allocate(xcand(N)) + allocate(gcand(N)) + allocate(LBFGSb(N,LBFGSm)) + allocate(TRBs(N)) + end if + if(doSHLSR1) then + allocate(SR1testvec(N)) + end if + if(doFD .or. doSHFD) then + allocate(FDHess(N,N)) + allocate(IPIV(N)) + end if + + + doLSbasic = .FALSE. + doLSbasicpp = .FALSE. + doLSstandard = .FALSE. + doLSnone = .FALSE. + doLSMoreThuente = .false. + doLSunit = .false. + + doefunc = 0 + if ( present(efuncroutine) ) then + if (trim(efuncroutine) == 'basic') then + doefunc = E_FUNC_BASIC + call print('Using naive summation of local energies') + elseif (trim(efuncroutine) == 'kahan') then + doefunc = E_FUNC_KAHAN + allocate(local_energycand((size(x)-9)/3)) + call print('Using Kahan summation of local energies') + elseif (trim(efuncroutine) == 'doublekahan') then + doefunc = E_FUNC_DOUBLEKAHAN + allocate(local_energycand((size(x)-9)/3)) + call print('Using double Kahan summation of local energies with quicksort') + else + call print('Unrecognized efuncroutine, normally use "basic" or "kahan", aborting for safety') + call exit() + end if + else + doefunc = E_FUNC_BASIC + call print('Using naive summation of local energies by default') + end if + + if (doSD .or. doCG .or. doLBFGS) then + if ( present(linminroutine) ) then + if (trim(linminroutine) == 'basic') then + call print('Using basic backtracking linesearch') + doLSbasic = .TRUE. + elseif (trim(linminroutine) == 'basicpp') then + call print('Using backtracking linesearch with cubic interpolation') + doLSbasicpp = .TRUE. + elseif (trim(linminroutine) == 'standard') then + call print('Using standard two-stage linesearch with cubic interpolation in the zoom phase, with bisection as backup') + doLSstandard = .TRUE. + elseif (trim(linminroutine) == 'none') then + call print('Using no linesearch method (relying on init_alpha to make good guesses)') + doLSnone = .TRUE. + elseif (trim(linminroutine) == 'morethuente') then + call print('Using More & Thuente minpack linesearch') + doLSMoreThuente = .TRUE. + elseif (trim(linminroutine) == 'unit') then + call print('Using fixed stepsize of 1') + doLSunit = .true. + else + call print('Unrecognized linmin routine') + call exit() + end if + else + call print('Defaulting to basic linesearch') + doLSbasic = .TRUE. + end if + end if + + term2norm = .true. + if (present(infconvext)) then + if (infconvext .eqv. .true.) then + term2norm = .false. + end if + end if + + x = x_in + + !Main Loop + this_ls_count = 0 + total_ls_count = 0 + n_iter = 1 + call system_timer("preconminim/func") +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + f = func_wrapper(func,x,am_data,local_energy,g,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("preconminim/func") + + abortcount = 0 + alpha = 0 + this_ls_count = 0 + dotpgout = 0 + do + + if(doSD .or. doCG .or. doLBFGS .or. doFD) then + normsqgrad = smartdotproduct(g,g,doefunc) + + if ( normsqgrad < convergence_tol .and. term2norm) then + call print('Extended minim completed with |df|^2 = '// normsqgrad // ' < tolerance = ' // convergence_tol // ' total linesearch iterations = '// total_ls_count) + ! call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |df|^2 = '// normsqgrad// ' max(abs(df)) = '//maxval(abs(g))//' last alpha = '//alpha) + call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad// ' sg/(|s||g|) = '//dotpgout//' last alpha = '//alpha//' max(abs(g)) = '//maxval(abs(g)) & + // ' last ls_iter = ' // this_ls_count) + exit + elseif ( maxval(abs(g)) < convergence_tol .and. .not. term2norm) then + call print('Extended minim completed with |df|_infty = '// maxval(abs(g)) // ' < tolerance = ' // convergence_tol // ' total linesearch iterations = '// total_ls_count) + ! call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |df|^2 = '// normsqgrad// ' max(abs(df)) = '//maxval(abs(g))//' last alpha = '//alpha) + call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad// ' sg/(|s||g|) = '//dotpgout//' last alpha = '//alpha//' max(abs(g)) = '//maxval(abs(g)) & + // ' last ls_iter = ' // this_ls_count) + exit + + end if + + call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad// ' sg/(|s||g|) = '//dotpgout //' last alpha = '//alpha//' max(abs(g)) = '//maxval(abs(g)) & + // ' last ls_iter = ' // this_ls_count,PRINT_NORMAL) + ! call the hook function + if (present(hook)) then + call hook(x, g, f, done, (mod(n_iter-1,my_hook_print_interval) == 0), am_data) + else + call print("hook is not present", PRINT_VERBOSE) + end if + !if(n_iter == 1) call build_precon(pr,am_data) + call build_precon(pr,am_data) + !call writeprecon(pr,'pr') + !call exit() + + if (doCG .or. doSD) then + pgold = pg + if (n_iter > 1) then + pg = apply_precon(g,pr,doefunc,init=pgold) + elseif (n_iter == 1) then + pg = apply_precon(g,pr,doefunc) + end if + end if + + sold = s + if (n_iter > 1 .AND. doCG) then + + betanumer = smartdotproduct(pg, (g - gold),doefunc) + betadenom = smartdotproduct(pgold,gold,doefunc) + beta = betanumer/betadenom + + if (beta > 0) then + beta = 0 + end if + + s = -pg + beta*sold + + elseif (doLBFGS) then + + !call print(LBFGSrho) + if (n_iter > 1) then + LBFGSs(1:N,1:(LBFGSm-1)) = LBFGSs(1:N,2:LBFGSm) + LBFGSy(1:N,1:(LBFGSm-1)) = LBFGSy(1:N,2:LBFGSm) + + LBFGSrho(1:(LBFGSm-1)) = LBFGSrho(2:LBFGSm) + LBFGSs(1:N,LBFGSm) = x - xold + LBFGSy(1:N,LBFGSm) = g - gold + LBFGSrho(LBFGSm) = 1.0/smartdotproduct(LBFGSs(1:N,LBFGSm),LBFGSy(1:N,LBFGSm),doefunc) + end if + n_back = min(LBFGSm,LBFGScount,n_iter-1) + !n_back = 0 + LBFGSq = g + do I = 1,n_back + thisind = LBFGSm - I + 1 + LBFGSalp(thisind) = LBFGSrho(thisind)*smartdotproduct(LBFGSs(1:N,thisind),LBFGSq,doefunc) + !call print(LBFGSy(1:N,thisind)) + LBFGSq = LBFGSq - LBFGSalp(thisind)*LBFGSy(1:N,thisind) + end do + if (n_iter == 1) then + LBFGSz = apply_precon(LBFGSq,pr,doefunc,k_out=k_out) + else + LBFGSz = apply_precon(LBFGSq,pr,doefunc,init=LBFGSbuf1,k_out=k_out) + end if + LBFGSbuf1 = LBFGSz + do I = 1,n_back + thisind = LBFGSm - n_back + I + LBFGSbet(thisind) = LBFGSrho(thisind)*smartdotproduct(LBFGSy(1:N,thisind),LBFGSz,doefunc) + LBFGSz = LBFGSz + LBFGSs(1:N,thisind)*(LBFGSalp(thisind) - LBFGSbet(thisind)) + end do + s = -LBFGSz + elseif (doFD) then + + call gethessian(x,am_data,FDHess) + !call writemat(FDHess,'densehess' // n_iter) + s = -g + call dgesv(size(x),1,FDHess,size(x),IPIV,s,size(x),INFO) + else + + s = -pg + + end if + + dirderivvec(n_iter) = smartdotproduct(g,s,doefunc) + dotpgout = -dirderivvec(n_iter)/(norm(g)*norm(s)) + + if (dirderivvec(n_iter) > 0) then + call print('Problem, directional derivative of search direction = '// dirderivvec(n_iter)) + if(doLBFGS) then + call print('Restarting LBFGS') + LBFGScount = 0 + end if + abortcount = abortcount + 1 + if (abortcount >= 5) then + call print(' Extended Minim aborted due to multiple bad search directions, possibly reached machine precision') + call print(' |df|^2 = '// normsqgrad // ', tolerance = ' // convergence_tol // ' total linesearch iterations = '// total_ls_count) + + !call writehessian(x,am_data,'outfinal') + exit + end if + cycle + else + if(doLBFGS) then + LBFGScount = LBFGScount + 1 + end if + abortcount = 0 + end if + !initial guess of alpha + alpha = init_alpha(alpvec,dirderivvec,n_iter) + + if(n_iter == 1 .and. (doCG .or. doSD)) then + alpha = calc_amax(s,pr,doefunc) + elseif (doLBFGS .and. (pr%precon_id == 'C1' .or. pr%precon_id == 'LJ')) then + alpha = 1.0 + else + alpha = init_alpha(alpvec,dirderivvec,n_iter) + if (pr%precon_id == 'ID') then + alpha = alpha*2.0 + end if + end if + + gold = g + amax = calc_amax(s,pr,doefunc,infoverride) + call print('Beginning linesearch, initial alpha = ' //alpha// ', alpha_max = ' //amax ,PRINT_VERBOSE) + if (doLSbasic) then + alpha = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,am_data,dirderivvec(n_iter),this_ls_count,amaxin=amax) + !call print('moo1') + elseif (doLSbasicpp) then + alpha = linesearch_basic_pp(x,s,f,alpha,func,doefunc,am_data,dirderivvec(n_iter),this_ls_count) + !call print('moo2') + elseif (doLSstandard) then + alpha = linesearch_standard(x,s,f,g,local_energy,alpha,func,doefunc,am_data,dirderivvec(n_iter),this_ls_count,amaxin=amax) + !call print('moo2') + elseif (doLSMoreThuente) then + alpha = linesearch_morethuente(x,s,f,local_energy,alpha,func,doefunc,am_data,dirderivvec(n_iter),this_ls_count,amaxin=amax) + elseif (doLSunit) then + alpha = 1.0 + call system_timer("preconminim/func") + f = func_wrapper(func,x+s,am_data,doefunc=doefunc) + call system_timer("preconminim/func") + elseif (doLSnone) then + !do nothing + this_ls_count = 0 + end if + total_ls_count = total_ls_count + this_ls_count + alpvec(n_iter) = alpha + + xold = x + if (alpha < 10.0_dp**(-14) ) then + call print(' Extended Minim aborted due to being unable to find a step along the given descent direction, probably your dE is not accurate else extremely badly conditioned') + call print(' |df|^2 = '// normsqgrad // ', tolerance = ' // convergence_tol // ' total linesearch iterations = '// total_ls_count) + exit + end if + x = x + alpha*s + + elseif (doDLLBFGS .or. doSHLBFGS .or. doSHLSR1 .or. doSHFD ) then + if (n_iter == 1) then + call system_timer("preconminim/func") +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + f = func_wrapper(func,x,am_data,local_energy,g,doefunc=doefunc) + normsqgrad = smartdotproduct(g,g,doefunc) + TRDelta = 1.0 + call build_precon(pr,am_data) +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("preconminim/func") + call print(trim(method)//" iter = 0 f = "//f// ' |g|^2 = '// normsqgrad,PRINT_NORMAL) + end if + n_back = min(LBFGSm,LBFGScount) + + if (doSHLBFGS) then + s = steihaug(x,g,pr,TRDelta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr,doBFGS=.true.) + elseif (doSHLSR1) then + s = steihaug(x,g,pr,TRDelta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr,doSR1=.true.) + elseif (doSHFD) then + call gethessian(x,am_data,FDHess) + s = steihaug(x,g,pr,TRDelta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr,doFD=.true.,FDhess=FDHess) + elseif (doDLLBFGS) then + s = LBFGSdogleg(x,g,pr,TRDelta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr) + end if + xcand = x + s + normsqs = Pdotproduct(s,s,pr,doefunc) + + call system_timer("preconminim/func") +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + fcand = func_wrapper(func,xcand,am_data,local_energycand,gcand,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("preconminim/func") + !call print(f // ' '//fcand) + if (doDLLBFGS .or. doSHLBFGS) then + TRBs = calc_LBFGS_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,s,pr,doefunc) + elseif (doSHLSR1) then + TRBs = calc_LSR1_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,s,pr,doefunc) + elseif ( doSHFD) then + TRBs = smartmatmul(FDHess,s,doefunc) + end if + + TRared = calcdeltaE(doefunc,f,fcand,local_energy,local_energycand) + TRpred = -( smartdotproduct(g,s,doefunc) + 0.5*(smartdotproduct(s,TRBs,doefunc)) ) + TRrho = TRared/TRpred + + if (TRrho < 0) then + abortcount = abortcount+1 + else + abortcount = 0 + end if + + if (abortcount >= 15) then + call print(' Extended Minim aborted due to multiple bad trust region models, possibly reached machine precision') + exit + end if + + if (TRrho < 0.25) then + TRDelta = 0.25*TRdelta + else if (TRrho > 0.75 .and. abs(sqrt(normsqs) - TRDelta) < 10.0**(-2.0)) then + TRDelta = 2.0*TRDelta + end if + + if (TRrho > TReta) then + xold = x + gold = g + + x = xcand + f = fcand + local_energy = local_energycand + g = gcand + normsqgrad = smartdotproduct(g,g,doefunc) + call build_precon(pr,am_data) + + end if + + SR1doupdate = .false. + if (doSHLSR1) then + SR1testvec = g - gold - calc_LSR1_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,x-xold,pr,doefunc) + SR1testLHS = abs(smartdotproduct(x-xold,SR1testvec,doefunc)) + SR1testRHS = 10.0**(-8.0)*sqrt(Pdotproduct(x-xold,x-xold,pr,doefunc))*sqrt(Pdotproduct(SR1testvec,SR1testvec,pr,doefunc)) + if(SR1testLHS >= SR1testRHS) SR1doupdate = .true. + end if + + if (doLBFGS .or. doDLLBFGS .or. doSHLBFGS .or. SR1doupdate) then + + LBFGSs(1:N,1:(LBFGSm-1)) = LBFGSs(1:N,2:LBFGSm) + LBFGSy(1:N,1:(LBFGSm-1)) = LBFGSy(1:N,2:LBFGSm) + LBFGSdlr(1:(LBFGSm-1),1:(LBFGSm-1)) = LBFGSdlr(2:LBFGSm,2:LBFGSm) + + LBFGSs(1:N,LBFGSm) = x - xold + LBFGSy(1:N,LBFGSm) = g - gold + LBFGScount = LBFGScount + 1 + n_back = min(LBFGSm,LBFGScount) + do I = 1,n_back + thisind = LBFGSm - I + 1 + + LBFGSdlr(LBFGSm,thisind) = smartdotproduct(LBFGSs(1:N,LBFGSm),LBFGSy(1:N,thisind),doefunc) + LBFGSdlr(thisind,LBFGSm) = smartdotproduct(LBFGSs(1:N,thisind),LBFGSy(1:N,LBFGSm),doefunc) + if(allocated(LBFGSd)) deallocate(LBFGSd) + if(allocated(LBFGSl)) deallocate(LBFGSl) + allocate(LBFGSd(n_back,n_back)) + allocate(LBFGSl(n_back,n_back)) + LBFGSd = 0.0 + LBFGSl = 0.0 + do SR1I = 1,n_back + do SR1J = 1,n_back + if (SR1I == SR1J) LBFGSd(SR1I,SR1J) = LBFGSdlr(LBFGSm-n_back+SR1I,LBFGSm-n_back+SR1J) + if (SR1I > SR1J) LBFGSl(SR1I,SR1J) = LBFGSdlr(LBFGSm-n_back+SR1I,LBFGSm-n_back+SR1J) + end do + end do + end do + end if + + if ( normsqgrad < convergence_tol ) then + call print('Extended minim completed with |df|^2 = '// normsqgrad // ' < tolerance = ' // convergence_tol) + ! call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |df|^2 = '// normsqgrad// ' max(abs(df)) = '//maxval(abs(g))//' last alpha = '//alpha) + call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad // ' |s|^2 = ' //normsqs //' rho = ' // TRrho// ' Delta^2 = '// TRDelta**2) + exit + end if + + call print(trim(method)//" iter = "//n_iter//" f = "//f// ' |g|^2 = '// normsqgrad // ' |s|^2 = ' //normsqs //' rho = ' // TRrho// ' Delta^2 = '// TRDelta**2,PRINT_NORMAL) + end if + + + if (n_iter >= max_steps) then + exit + end if + n_iter = n_iter+1 + + end do + + x_in = x + + end function preconminim + + function fdhmultiply(x,FDH_rows,FDH_H,FDH_diag) + + real(dp) :: x(:), FDH_H(:) + integer :: FDH_rows(:), FDH_diag(:) + real(dp) :: fdhmultiply(size(x)) + + integer :: N, I, NH, rowind, colind + + N = size(x) + NH = size(FDH_H) + fdhmultiply = 0.0 + + colind = 1 + do I = 1,NH + rowind = FDH_rows(I) + if (colind < N) then + if (I == FDH_diag(colind+1)) then + colind = colind+1 + end if + end if + fdhmultiply(rowind) = fdhmultiply(rowind) + FDH_H(I)*x(colind) + fdhmultiply(colind) = fdhmultiply(colind) + FDH_H(I)*x(rowind) + end do + + end function + + function LBFGSdogleg(x,g,pr,Delta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr) result(s) + + implicit none + + real(dp) :: x(:),g(:) + type(precon_data) :: pr + real(dp) :: Delta + integer :: doefunc + integer :: n_back + real(dp):: LBFGSs(:,:), LBFGSy(:,:), LBFGSdlr(:,:) + real(dp) :: s(size(x)) + + real(dp) :: deltak,gammak + real(dp) :: sqn(size(x)), ssd(size(x)), LBFGSl(n_back,n_back), LBFGSr(n_back,n_back), LBFGSrinv(n_back,n_back),LBFGSd(n_back,n_back), su(size(x)),Bg(size(x)) + integer :: N, INFO, IPIV(n_back), I, J, LBFGSm + real(dp) :: WORK(n_back), sunorm, sqnnorm,a,b,c,tau, Pg(size(x)) + + N = size(x) + deltak = pr%energy_scale + gammak = 1.0/deltak + LBFGSm = size(LBFGSs,dim=2) + + LBFGSr = 0.0 + LBFGSd = 0.0 + LBFGSl = 0.0 + LBFGSrinv = 0.0 + do I = 1,n_back + do J = 1,n_back + if (I <= J) LBFGSr(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) + if (I == J) LBFGSd(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) + if (I > J) LBFGSl(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) + end do + end do + + Bg = calc_LBFGS_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,g,pr,doefunc) + su = -(smartdotproduct(g,g,doefunc)/smartdotproduct(g,Bg,doefunc))*g + sunorm = sqrt(Pdotproduct(su,su,pr,doefunc)) + if (sunorm >= Delta) then + s = su*Delta/sunorm + else + LBFGSrinv = LBFGSr + if (n_back >= 1) then + call dgetrf(n_back,n_back,LBFGSrinv,n_back,IPIV,INFO) + call dgetri(n_back,LBFGSrinv,n_back,IPIV,WORK,n_back,INFO) + end if + sqn = -calc_LBFGS_Hk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSd,LBFGSrinv,gammak,g,pr,doefunc) + sqnnorm = sqrt(Pdotproduct(sqn,sqn,pr,doefunc)) + if (sqnnorm <= Delta) then + s = sqn + else + a = Pdotproduct(sqn-su,sqn-su,pr,doefunc) + b = 2.0*Pdotproduct(su,sqn-su,pr,doefunc) + c = Pdotproduct(su,su,pr,doefunc) - Delta**2.0 + tau = (-b + sqrt(b**2.0 -4.0*a*c))/(2.0*a) + s = su + tau*(sqn-su) + end if + end if + !call exit() + end function + + function steihaug(x,g,pr,Delta,doefunc,n_back,LBFGSs,LBFGSy,LBFGSdlr,doSR1,doBFGS,doFD,FDHess) result(s) + + implicit none + + real(dp) :: x(:),g(:) + type(precon_data) :: pr + real(dp) :: Delta + integer :: doefunc + integer :: n_back + real(dp):: LBFGSs(:,:), LBFGSy(:,:), LBFGSdlr(:,:) + logical, optional :: doSR1,doBFGS,doFD + real(dp), optional :: FDHess(:,:) + real(dp) :: s(size(x)) + real(dp) :: a,b,c,tau + + real(dp) :: alpn,alpd,betn,alp,bet,normzcand,normr + integer :: thisind,I,J,K,N,thisind2 + integer :: LBFGSm + real(dp) :: LBFGSd(n_back,n_back), LBFGSl(n_back,n_back) + real(dp) :: eps = 10.0**(-3) + real(dp) :: d(size(x)), Bd(size(x)), r(size(x)), z(size(x)) + real(dp) :: rtilde(size(x)) + real(dp) :: zcand(size(x)) + real(dp) :: LBFGSbufinterior(size(x)) + real(dp) :: deltak + logical :: first_cg + integer :: cg_iter_count + + LBFGSm = size(LBFGSs,dim=2) + N = size(x) + first_cg = .true. + + deltak=pr%energy_scale + !Extract submatrices of S^T*Y + LBFGSd = 0.0_dp + LBFGSl = 0.0_dp + do I = 1,n_back + do J = 1,n_back + if (I == J) LBFGSd(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) + if (I > J) LBFGSl(I,J) = LBFGSdlr(LBFGSm-n_back+I,LBFGSm-n_back+J) + end do + end do + + !Main Steihaug loop + z = 0.0_dp + r = -g + rtilde = apply_precon_gs(r,pr,doefunc,force_k=10) + d = rtilde + do + if(present(doSR1)) then + Bd = calc_LSR1_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,d,pr,doefunc) + elseif(present(doBFGS)) then + Bd = calc_LBFGS_Bk_mult_v(LBFGSs(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSy(1:N,(LBFGSm-n_back+1):LBFGSm),LBFGSl,LBFGSd,d,pr,doefunc) + elseif(present(doFD)) then + BD = smartmatmul(FDhess,d,doefunc) + end if + alpd = smartdotproduct(d,Bd,doefunc) + if (alpd <= 0.0) then + a = Pdotproduct(d,d,pr,doefunc) + b = 2.0*Pdotproduct(z,d,pr,doefunc) + c = Pdotproduct(z,z,pr,doefunc) - Delta**2.0 + tau = (-b + sqrt(b**2.0 -4.0*a*c))/(2.0*a) + s = z + tau*d + exit + end if + alpn = smartdotproduct(r,rtilde,doefunc) + alp = alpn/alpd + zcand = z + alp*d + normzcand = sqrt(Pdotproduct(zcand,zcand,pr,doefunc)) + if (normzcand >= Delta) then + a = Pdotproduct(d,d,pr,doefunc) + b = 2.0*Pdotproduct(z,d,pr,doefunc) + c = Pdotproduct(z,z,pr,doefunc) - Delta**2.0 + tau = (-b + sqrt(b**2.0 -4.0*a*c))/(2.0*a) + s = z + tau*d + exit + end if + z = zcand + r = r - alp*Bd + normr = sqrt(Pdotproduct(r,r,pr,doefunc)) + if (normr < eps) then + s = z + exit + endif + rtilde = apply_precon_gs(r,pr,doefunc,force_k=20) + betn = smartdotproduct(r,rtilde,doefunc) + bet = betn/alpn + d = rtilde + bet*d + end do + end function + + function Pdotproduct(v1,v2,pr,doefunc) + + implicit none + + real(dp) :: v1(:),v2(:) + type(precon_data) :: pr + integer :: doefunc + real(dp) :: Pdotproduct + + real(dp) :: Pv(size(v2)) + + Pv = do_mat_mult_vec(pr,v2,doefunc) + + Pdotproduct = smartdotproduct(v1,Pv,doefunc) + end function + + function calc_LBFGS_Bk_mult_v(LBFGSs,LBFGSy,LBFGSl,LBFGSd,v,pr,doefunc) result(Bkv) + + implicit none + + real(dp) :: LBFGSs(:,:), LBFGSy(:,:), LBFGSl(:,:), LBFGSd(:,:), v(:) + type(precon_data) :: pr + integer :: doefunc + real(dp) :: Bkv(size(v)) +! + integer :: n_back + integer :: INFO + integer, allocatable :: IPIV(:) + real(dp), allocatable :: midmat(:,:), midvec(:) + n_back = size(LBFGSs,dim=2) + + Bkv = do_mat_mult_vec(pr,v,doefunc) + if (n_back>=1) then + allocate(IPIV(n_back*2)) + allocate(midmat(2*n_back,2*n_back),midvec(2*n_back)) + + midvec(1:n_back) = smartmatmul(transpose(LBFGSs),do_mat_mult_vec(pr,v,doefunc),doefunc) + midvec((n_back+1):) = smartmatmul(transpose(LBFGSy),v,doefunc) + + midmat(1:n_back,1:n_back) = smartmatmul(transpose(LBFGSs),do_mat_mult_vecs(pr,LBFGSs,doefunc),doefunc) + midmat((n_back+1):,1:n_back) = LBFGSl + midmat(1:n_back,(n_back+1):) = transpose(LBFGSl) + midmat((n_back+1):,(n_back+1):) = -LBFGSd + + call dgesv(n_back*2,1,midmat,n_back*2,IPIV,midvec,n_back*2,INFO) + + Bkv = Bkv - do_mat_mult_vec(pr,smartmatmul(LBFGSs,midvec(1:n_back),doefunc),doefunc) - smartmatmul(LBFGSy,midvec((n_back+1):),doefunc) + end if + + end function + + function calc_LBFGS_Hk_mult_v(LBFGSs,LBFGSy,LBFGSd,LBFGSrinv,gammak,v,pr,doefunc) result(Hkv) + + implicit none + +! real(dp) :: LBFGSs(:,:), LBFGSy(:,:), LBFGSd(:,:), LBFGSrinv(:,:), gammak, v(:) +! real(dp) :: Hkv(size(v)) +! type(precon_data) :: pr +! logical :: doefunc(:) +! +! integer :: n_back +! integer :: INFO +! real(dp), allocatable :: midmat(:,:), midvec(:) +! +! n_back = size(LBFGSs,dim=2) +! Hkv = apply_precon_gs(v,pr,doefunc,force_k=20) +! if (n_back>=1) then +! allocate(midmat(2*n_back,2*n_back),midvec(2*n_back)) +! midvec(1:n_back) = smartmatmul(transpose(LBFGSs),v,doefunc) +! midvec((n_back+1):2*n_back) = smartmatmul(transpose(LBFGSy),apply_precon_gs(v,pr,doefunc,force_k=20),doefunc) +! +! midmat = 0.0 +! midmat(1:n_back,1:n_back) = smartmatmul(transpose(LBFGSrinv),smartmatmul(LBFGSd + smartmatmul(transpose(LBFGSy),apply_precon_vecs(LBFGSy,pr,doefunc),doefunc),LBFGSrinv,doefunc),doefunc) +! midmat((n_back+1):,1:n_back) = -LBFGSrinv +! midmat(1:n_back,(n_back+1):) = -transpose(LBFGSrinv) +! +! midvec = smartmatmul(midmat,midvec,doefunc) +! +! Hkv = Hkv + smartmatmul(LBFGSs,midvec(1:n_back),doefunc) + apply_precon_gs(smartmatmul(LBFGSy,midvec((n_back+1):),doefunc),pr,doefunc,force_k=20) +! end if + real(dp) :: LBFGSs(:,:), LBFGSy(:,:), LBFGSd(:,:), LBFGSrinv(:,:), gammak, v(:) + real(dp) :: Hkv(size(v)) + type(precon_data) :: pr + integer :: doefunc + + integer :: I,J,n_back,thisind,N + real(dp), allocatable :: LBFGSq(:),LBFGSz(:),LBFGSalp(:),LBFGSbet(:),LBFGSrho(:) + + N = size(LBFGSs,dim=1) + n_back = size(LBFGSs,dim=2) + allocate(LBFGSq(N),LBFGSz(N),LBFGSbet(n_back),LBFGSalp(n_back),LBFGSrho(n_back)) + + do I =1,n_back + LBFGSrho(I) = 1.0/smartdotproduct(LBFGSs(1:N,I),LBFGSy(1:N,I),doefunc) + end do + LBFGSq = v + do I = 1,n_back + thisind = n_back - I + 1 + + LBFGSalp(thisind) = LBFGSrho(thisind)*smartdotproduct(LBFGSs(1:N,thisind),LBFGSq,doefunc) + LBFGSq = LBFGSq - LBFGSalp(thisind)*LBFGSy(1:N,thisind) + end do + + LBFGSz = apply_precon(LBFGSq,pr,doefunc) + + do I = 1,n_back + thisind = I + + LBFGSbet(thisind) = LBFGSrho(thisind)*smartdotproduct(LBFGSy(1:N,thisind),LBFGSz,doefunc) + LBFGSz = LBFGSz + LBFGSs(1:N,thisind)*(LBFGSalp(thisind) - LBFGSbet(thisind)) + end do + Hkv = LBFGSz + + end function + + function calc_LSR1_Bk_mult_v(LBFGSs,LBFGSy,LBFGSd,LBFGSl,v,pr,doefunc) result(Bkv) + + implicit none + + real(dp) :: LBFGSs(:,:), LBFGSy(:,:), LBFGSd(:,:), LBFGSl(:,:), v(:) + type(precon_data) :: pr + integer :: doefunc + real(dp) :: Bkv(size(v)) + + integer :: n_back, INFO + real(dp), allocatable :: midmat(:,:), midvec(:) + integer, allocatable :: IPIV(:) + + n_back = size(LBFGSs,dim=2) + Bkv = do_mat_mult_vec(pr,v,doefunc) + if (n_back >= 1) then + allocate(IPIV(n_back)) + allocate(midmat(n_back,n_back),midvec(n_back)) + midvec = smartmatmul(transpose(LBFGSy - do_mat_mult_vecs(pr,LBFGSs,doefunc)),v,doefunc) + midmat = LBFGSd + LBFGSl + transpose(LBFGSl) - smartmatmul(transpose(LBFGSs),do_mat_mult_vecs(pr,LBFGSs,doefunc),doefunc) + call dgesv(n_back,1,midmat,n_back,IPIV,midvec,n_back,INFO) + Bkv = Bkv + smartmatmul(LBFGSy-do_mat_mult_vecs(pr,LBFGSs,doefunc),midvec,doefunc) + end if + + end function + + function calc_amax(g,pr,doefunc,infoverride) + + + implicit none + + real(dp) :: g(:) + type(precon_data) :: pr + real(dp) :: calc_amax + real(dp), optional :: infoverride + integer :: doefunc + real(dp) :: P_amax, inf_amax + real(dp) :: infcoeff = 0.5 + + if (present(infoverride)) then + infcoeff = infoverride + end if + + P_amax = pr%length_scale/sqrt(pdotproduct(g,g,pr,doefunc)) + inf_amax = infcoeff/maxval(abs(g)) + + calc_amax = min(P_amax,inf_amax) + + end function + + !basic linear backtracking linesearch, relies on changing initial alpha to increase step size + function linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d0,n_iter_final,amaxin) + + implicit none + + real(dp) :: x(:) + real(dp) :: s(:) + real(dp), intent(inout) :: f + real(dp), intent(inout) :: g(:) + real(dp), intent(inout) :: local_energy(:) + real(dp) :: alpha + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + integer :: doefunc + character(len=1)::data(:) + real(dp) :: linesearch_basic + integer, optional, intent(out) :: n_iter_final + real(dp) , optional :: amaxin + + + integer,parameter :: ls_it_max = 1000 + real(dp),parameter :: C = 10.0_dp**(-4.0) + integer :: ls_it + real(dp) :: f1, f0, d0, g1(size(g)) + real(dp) :: amax + real(dp) :: local_energy0(size(local_energy)),local_energy1(size(local_energy)) + real(dp) :: deltaE,deltaE2 + + alpha = alpha*4.0 + if (present(amaxin)) then + amax = amaxin + else + amax = 4.1*alpha + end if + + if(alpha>amax) alpha = amax + + f0 = f + local_energy0 = local_energy + ls_it = 0 + do + + !f1 = func_wrapper(func,x+alpha*s,data,doefunc=doefunc) + + call system_timer("preconminim/linesearch_basic/func") +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + f1 = func_wrapper(func,x+alpha*s,data,local_energy1,g1,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("preconminim/linesearch_basic/func") + call print("linesearch_basic loop "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//alpha) + + deltaE = calcdeltaE(doefunc,f1,f0,local_energy1,local_energy0) + !call print(deltaE) + + + ls_it = ls_it + 1 + if ( deltaE < C*alpha*d0) then + + + exit + end if + + if(ls_it>ls_it_max) then + exit + end if + + alpha = alpha/4.0_dp + + if (alpha <1.0e-15) then + exit + end if + + end do + + call print("linesearch_basic returning "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//alpha) + + linesearch_basic = alpha + f = f1 + g = g1 + local_energy = local_energy1 + !linesearch_basic = 15.0 + if(present(n_iter_final)) n_iter_final = ls_it + + end function + + ! Backtracking linesearch with cubic min + function linesearch_basic_pp(x,s,f,alpha,func,doefunc,data,d0,n_iter_final,amaxin) + + implicit none + + real(dp) :: x(:) + real(dp) :: s(:) + real(dp) :: f + real(dp) :: alpha + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::func + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + end function func + end INTERFACE + integer, intent(in) :: doefunc + character(len=1)::data(:) + real(dp) :: linesearch_basic_pp + integer, optional, intent(out) :: n_iter_final + real(dp), optional :: amaxin + + integer,parameter :: ls_it_max = 1000 + real(dp),parameter :: C = 10.0_dp**(-4.0) + integer :: ls_it + real(dp) :: f1, f0, d0, d1, a1, acand + real(dp) :: g1(size(x)) + real(dp) :: amax + real(dp) :: deltaE + !real(dp) :: local_energy0(size(local_energy)),local_energy1(size(local_energy)) + + alpha = alpha*4.0 + if (present(amaxin)) then + amax = amaxin + if(alpha>amax) alpha = amax + else + amax = 100.0_dp*alpha + end if + + a1 = alpha + f0 = f + ls_it = 1 + do + + !f1 = func_wrapper(func,x+alpha*s,data,doefunc=doefunc) + + call system_timer("preconminim/linesearch_basic_pp/func") +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + f1 = func_wrapper(func,x+a1*s,data,gradient=g1,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("preconminim/linesearch_basic_pp/func") + call print("linesearch_basic_pp loop "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//a1) + + d1 = dot_product(g1,s) + !call print(alpha) + + if ( f1-f0 < C*a1*d0) then + exit + end if + + if(ls_it>ls_it_max) then + exit + end if + + ls_it = ls_it + 1 + acand = cubic_min(0.0_dp,f0,d0,a1,f1,d1) + !acand = quad_min(0.0_dp,a1,f0,f1,d0) + + !call print(a1 //' '// f0//' ' //f1// ' ' //d0) + !call print('a1=' // a1 // ' acand=' // acand) + + !if ( acand == 0.0_dp) acand = a1/4.0_dp + acand = max(0.1*a1, min(acand,0.8*a1) ) + a1 = acand + + !call print(a1) + + end do + + call print("linesearch_basic_pp returning "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = N/A '//' last alpha = '//a1) + + linesearch_basic_pp = a1 + f = f1 + if(present(n_iter_final)) n_iter_final = ls_it + end function + + + ! standard two stage lineseach from N&W + function linesearch_standard(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amaxin) + implicit none + real(dp) :: x(:) + real(dp) :: s(:) + real(dp), intent(inout) :: f + real(dp), intent(inout) :: g(:) + real(dp), intent(inout) :: local_energy(:) + real(dp) :: alpha + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + integer :: doefunc + character(len=1)::data(:) + real(dp) :: d + real(dp) :: linesearch_standard + integer, optional, intent(out) :: n_iter_final + real(dp), optional :: amaxin + + + integer, parameter :: ls_it_max = 20 + real(dp), parameter :: C1 = 10.0_dp**(-4.0) + real(dp), parameter :: C2 = 0.9 + real(dp) :: amax + real(dp), parameter :: amin = 10.0_dp**(-5.0) + + real(dp) :: f0, f1, ft, a0, a1, a2, at, d0, d1, dt + real(dp) :: flo, fhi, alo, ahi, dlo, dhi + integer :: ls_it + real(dp) :: g1(size(x)), gt(size(x)) + logical :: dozoom = .FALSE. + real (dp) :: deltaE,deltaE0, deltaET, deltaETlo + real(dp) :: local_energy0(size(local_energy)),local_energy1(size(local_energy)),local_energyT(size(local_energy)),local_energylo(size(local_energy)),local_energyhi(size(local_energy)) + + a0 = 0.0_dp + f0 = f + local_energy0 = local_energy + d0 = d + a1 = alpha + + + if (present(amaxin)) then + amax = amaxin + if(a1>amax) a1 = amax + else + amax = 100.0_dp*alpha + end if + + !begin bracketing + ls_it = 0 + do + + call system_timer("preconminim/linesearch_standard/func") +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + f1 = func_wrapper(func,x+a1*s,data,local_energy1,g1,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("preconminim/linesearch_standard/func") + + + ls_it = ls_it + 1 + call print("linesearch_standard bracket "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//a1) + + + d1 = smartdotproduct(s,g1,doefunc) + + deltaE = calcdeltaE(doefunc,f1,f,local_energy1,local_energy) + deltaE0 = calcdeltaE(doefunc,f1,f0,local_energy1,local_energy0) + + if ( deltaE > C1*a1*d .OR. (deltaE0 >= 0.0 .AND. ls_it > 1 )) then + dozoom = .TRUE. + alo = a0 + ahi = a1 + flo = f0 + local_energylo = local_energy0 + fhi = f1 + local_energyhi = local_energy1 + dlo = d0 + dhi = d1 + exit + end if + + if ( abs(d1) <= C2*abs(d) ) then + dozoom = .FALSE. + exit + end if + + if ( d1 >= 0.0_dp) then + alo = a1 + ahi = a0 + flo = f1 + local_energylo = local_energy1 + fhi = f0 + local_energyhi = local_energy0 + dlo = d1 + dhi = d0 + exit + end if + + if(ls_it>ls_it_max) then + call print('linesearch_standard Ran out of line search iterations in phase 1') + a1 = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amax) + ! *1 quantities will be copied into function arguments for return at end + f1 = f + g1 = g + local_energy1 = local_energy + n_iter_final = n_iter_final + ls_it + dozoom = .FALSE. + exit + end if + + if(a1 >= amax) then + call print('linesearch_standard Bracketing failed to find an interval, reverting to basic linesearch') + a1 = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amax) + ! *1 quantities will be copied into function arguments for return at end + f1 = f + g1 = g + local_energy1 = local_energy + n_iter_final = n_iter_final + ls_it + dozoom = .FALSE. + exit + end if + + a2 = min(a1 + 4.0*(a1-a0),amax) + a0 = a1 + a1 = a2 + + f0 = f1 + local_energy0 = local_energy1 + d0 = d1 + + + !call print(a1) + + end do + + + if ( dozoom ) then + + !ls_it = ls_it+1 + do + at = cubic_min(alo,flo,dlo,ahi,fhi,dhi) + + call system_timer("preconminim/linesearch_standard/func") +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + ft = func_wrapper(func,x+at*s,data,local_energyT,gt,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("preconminim/linesearch_standard/func") + + ls_it = ls_it + 1 + call print("linesearch_standard zoom "//" iter = "//ls_it//" f = "//ft// ' |g|^2 = '// normsq(gt)//' last alpha = '//at) + + deltaET = calcdeltaE(doefunc,ft,f0,local_energyT,local_energy0) + deltaETlo = calcdeltaE(doefunc,ft,flo,local_energyT,local_energylo) + + if ( deltaET > C1*at*d .OR. deltaETlo >= 0.0) then + + ahi = at + fhi = ft + local_energyhi = local_energyT + + else + dt = dot_product(gt,s) + + + if ( abs(dt) <= C2*abs(d) ) then + + a1 = at + f1 = ft + g1 = gt + local_energy1 = local_energyT + exit + + end if + + if ( dt*(ahi-alo) >= 0.0 ) then + + ahi = alo + fhi = flo + local_energyhi = local_energylo + + end if + + alo = at + flo = ft + local_energylo = local_energyT + + end if + + if (abs(ahi - alo) < amin) then + call print('Bracket got small without satisfying curvature condition') + + deltaET = calcdeltaE(doefunc,ft,f,local_energyT,local_energy) + if ( deltaET < C1*at*d) then + call print('Bracket lowpoint satisfies sufficient decrease, using that') + a1 = at + f1 = ft + g1 = gt + exit + else + call print('Bracket lowpoint no good, doing a step of basic linesearch with original initial inputs') + a1 = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amax) + f1 = ft + g1 = gt + n_iter_final = n_iter_final + ls_it + exit + end if + end if + + if(ls_it>ls_it_max) then + call print('Ran out of line search iterations in phase 2') + a1 = linesearch_basic(x,s,f,g,local_energy,alpha,func,doefunc,data,d,n_iter_final,amax) + f1 = f + g1 = g + local_energy1 = local_energy + n_iter_final = n_iter_final + ls_it + exit + end if + + + end do ! zoom loop + end if + + call print("linesearch_standard returning "//" iter = "//ls_it//" f = "//f1// ' |g|^2 = '// normsq(g1)//' last alpha = '//a1) + + !call print('boo ' // ls_it) + n_iter_final = ls_it + linesearch_standard = a1 + f = f1 + local_energy = local_energy1 + g = g1 + end function linesearch_standard + + function linesearch_morethuente(x,s,finit,local_energy,alpha,func,doefunc,data,d,n_iter_final,amaxin) + implicit none + real(dp) :: x(:) + real(dp) :: s(:) + real(dp), intent(inout) :: finit + real(dp), intent(inout) :: local_energy(:) + real(dp) :: alpha + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + integer :: doefunc + character(len=1)::data(:) + real(dp) :: d + real(dp) :: linesearch_morethuente + integer, optional, intent(out) :: n_iter_final + real(dp), optional :: amaxin + + + integer, parameter :: ls_it_max = 20 + real(dp), parameter :: ftol = 10.0_dp**(-4.0) ! sufficient decrease + real(dp), parameter :: gtol = 0.9 ! curvature + real(dp), parameter :: xtol = 10.0_dp**(-5.0) ! bracket size + real(dp) :: amax + real(dp), parameter :: amin = 10.0_dp**(-10.0) + + + logical :: brackt + integer :: nfev,stage + real(dp) :: f, g, ftest, fm, fx, fxm, fy, fym, ginit, gtest, gm, gx, gxm, gy, gym, stx, sty, stmin, stmax, width, width1,stp + real(dp) :: f1,g1(size(x)),local_energy1(size(x)) + integer :: ls_it + real(dp), parameter :: xtrapl = 1.1_dp, xtrapu=4.0_dp, p5 = 0.5_dp, p66 = 0.66_dp + + + stp = alpha + stpmin = amin + if (present(amaxin)) then + stpmax = amaxin + if(stp>stpmax) stp = stpmax + else + stpmax = 100.0_dp*stp + end if + + + brackt = .false. + stage = 1 + nfev = 0 + ginit = d + gtest = ftol*d + width = stpmax-stpmin + width1 = width/p5 + + stx = 0.0_dp + fx = finit + gx = ginit + sty = 0.0_dp + fy = finit + gy = ginit + stmin = 0.0_dp + stmax = stp + xtrapu*stp + + ls_it = 0 + do + + ftest = finit + stp*gtest + + ls_it = ls_it + 1 + call system_timer("preconminim/linesearch_morethuente/func") +#ifndef _OPENMP + call verbosity_push_decrement() +#endif + f1 = func_wrapper(func,x+stp*s,data,local_energy1,gradient=g1,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + call system_timer("preconminim/linesearch_morethuente/func") + + f = calcE(doefunc,f1,local_energy1) + g = smartdotproduct(g1,s,doefunc) + + ftest = finit + stp*gtest + if (stage .eq. 1 .and. f .le. ftest .and. g .ge. 0.0_dp) stage = 2 + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax)) then + call print("Rounding errors in linesearch") + exit + end if + if (brackt .and. stmax-stmin .le. xtol*stmax) then + call print("Bracket too small") + exit + end if + if (stp .eq. stpmax .and. f .le. ftest .and. g .le. gtest) then + call print("Maximum stepsize reached") + exit + end if + if (stp .eq. stpmin .and. (f .gt. ftest .or. g .ge. gtest)) then + call print("Minimum stepsize reached") + exit + end if + + if (f .le. ftest .and. abs(g) .le. gtol*(-ginit)) exit + + if (stage .eq. 1 .and. f .le. fx .and. f .gt. ftest) then + + fm = f - stp*gtest + fxm = fx - stx*gtest + fym = fy - sty*gtest + gm = g - gtest + gxm = gx - gtest + gym = gy - gtest + + call cstep(stx,fxm,gxm,sty,fym,gym,stp,fm,gm,brackt,stmin,stmax) + + fx = fxm + stx*gtest + fy = fym + sty*gtest + gx = gxm + gtest + gy = gym + gtest + + else + + call cstep(stx,fx,gx,sty,fy,gy,stp,f,g,brackt,stmin,stmax) + + end if + + if (brackt) then + if (abs(sty-stx) .ge. p66*width1) stp = stx + p5*(sty-stx) + width1 = width + width = abs(sty-stx) + else + stmin = stp + xtrapl*(stp-stx) + stmax = stp + xtrapu*(stp-stx) + end if + + stp = max(stp,stpmin) + stp = min(stp,stpmax) + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax) .or. (brackt .and. stmax-stmin .le. xtol*stmax)) stp = stx + + call print(stx// ' '//sty// ' '//stp) + end do + finit = f + linesearch_morethuente = stp + end function + + subroutine cstep(stx,fx,dx,sty,fy,dy,stp,fp,dpp,brackt,stpmin,stpmax) + implicit none + + real(dp),intent(inout) :: stx,fx,dx,sty,fy,dy,stp,fp,dpp + logical, intent(inout) :: brackt + real(dp), intent(in) :: stpmin,stpmax + + integer :: info + real(dp), parameter :: p66 = 0.66 + logical :: bound + real(dp) :: sgnd,theta,s,gamm,p,q,r,stpc,stpq,stpf + + info = 0 + + if(brackt .and. (stp<=min(stx,sty) .or. stp>=max(stx,sty))) then + call print("cstep received mixed information about the bracketing") + return + end if + if (stpmax=0.0) then + call print("cstep didn't receive a descent direction") + !return + end if + + if (fp > fx) then + info = 1 + bound = .true. + theta = 3.0*(fx - fp)/(stp - stx) + dx + dpp + s = max(abs(theta),abs(dx),abs(dpp)) + gamm = s*sqrt((theta/s)**2.0 - (dx/s)*(dpp/s)) + if (stp .lt. stx) then + gamm = -gamm + end if + p = (gamm - dx) + theta + q = ((gamm - dx) + gamm) + dp + r = p/q + stpc = stx + r*(stp-stx) + stpq = stx + ((dx/((fx-fp)/(stp-stx)+dx))/2.0)*(stp-stx) + if( abs(stpc-stx) .lt. abs(stpq-stx)) then + stpf = stpc + else + stpf = stpc + (stpq-stpc)/2.0 + end if + brackt = .true. + elseif (sgnd<0.0) then + info = 2 + bound = .false. + theta = 3.0*(fx - fp)/(stp - stx) + dx + dpp + s = max( abs(theta),abs(dx),abs(dpp)) + gamm = s*sqrt((theta/s)**2.0 - (dx/s)*(dpp/s)) + if (stp .gt. stx) then + gamm = -gamm + end if + p = (gamm - dpp) + theta + q = ((gamm - dpp) + gamm) + dx + r = p/q + stpc = stp + r*(stx-stp) + stpq = stp + (dpp/(dpp-dx))*(stx-stp) + if( abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + end if + brackt = .true. + elseif (abs(dpp) .lt. abs(dx))then + info = 3 + bound = .true. + theta = 3.0*(fx - fp)/(stp - stx) + dx + dpp + s = max(abs(theta),abs(dx),abs(dpp)) + gamm = s*sqrt(max(0.0,(theta/s)**2.0 - (dx/s)*(dpp/s))) + if (stp .gt. stx) then + gamm = -gamm + end if + p = (gamm - dpp) + theta + q = (gamm + (dx-dpp)) + gamm + r = p/q + if(r .lt. 0.0 .and. gamm .ne. 0.0_dp) then + stpc = stp + r*(stx-stp) + elseif (stp > stx)then + stpc = stpmax + else + stpc = stpmin + end if + stpq = stp + (dpp/(dpp-dx))*(stx-stp) + if (brackt) then + if(abs(stpc-stp) .lt. abs(stpq-stp))then + stpf = stpc + else + stpf = stpq + end if + if(stp .gt. stx) then + stpf = min(stp+p66*(sty-stp),stpf) + else + stpf = max(stp+p66*(sty-stp),stpf) + end if + else + if(abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + end if + stpf = min(stpmax,stpf) + stpf = max(stpmin,stpf) + end if + else + info = 4 + bound = .false. + if (brackt) then + theta = 3.0*(fp-fy)/(sty - stp) + dy + dpp + s = max(abs(theta),abs(dy),abs(dpp)) + gamm = s*sqrt((theta/s)**2.0 - (dy/s)*(dpp/s)) + if (stp .gt. sty ) then + gamm = -gamm + end if + p = (gamm - dpp) + theta + q = ((gamm - dpp) + gamm) + dy + r = p/q + stpc = stp + r*(sty-stp) + stpf = stpc + elseif(stp.gt.stx)then + stpf = stpmax + else + stpf = stpmin + end if + end if + + if (fp .gt. fx) then + sty = stp + fy = fp + dy = dpp + else + if (sgnd .lt. 0.0) then + sty = stx + fy = fx + dy = dx + end if + stx = stp + fx = fp + dx = dpp + end if + + stpf = min(stpmax,stpf) + stpf = max(stpmin,stpf) + stp = stpf + + end subroutine + + function cubic_min(a0,f0,d0,a1,f1,d1) + implicit none + + real(dp) :: a0,f0,d0,a1,f1,d1 + real(dp) :: cubic_min + + real(dp) :: h1,h2 + + h1 = d0 + d1 - 3.0_dp*(f0-f1)/(a0-a1) + + if ( h1**2.0 - d0*d1 <= 10.0**(-10.0)*abs(a1-a0) ) then + + !call print ('Line search routine cubic_min failed, crit1, will do a linear backtracking (linminroutine=basic) step') + cubic_min = (a0 + a1)/2.0_dp + else + + h2 = sign(1.0_dp,a1-a0)*sqrt(h1**2.0 - d0*d1) + if ( abs(d1-d0+2.0*h2) <= 10.0**(-8.0)*abs(d1+h2-h1) ) then + !call print ('cubic min failed, crit2, will do a linear backtracking (linminroutine=basic) step') + cubic_min = (a0 + a1)/2.0_dp + else + cubic_min = a1 - (a1-a0)*((d1+h2-h1)/(d1-d0+2.0*h2)) + end if + end if + + end function cubic_min + + function quad_min(a1,a2,f1,f2,g1) + implicit none + + real(dp) :: a1, a2, f1, f2, g1 + real(dp) :: quad_min + + real(dp) :: ama2, x, y + + ama2 = (a1-a2)**2.0 + + x = (f2 - f1 + a1*g1 - a2*g1)/ama2 + y = (2.0_dp*a1*(f1 - f2) - g1*ama2)/ama2 + + quad_min = y/(2.0_dp*x) + + end function quad_min + + !function to choose initial guess of steplength + function init_alpha(alpvec,dirderivvec,n_iter) + + implicit none + + real(dp) :: alpvec(:) + real(dp) :: dirderivvec(:) + integer :: n_iter + integer :: touse,I + + real(dp) :: init_alpha + + if (n_iter > 1) then + touse = min(n_iter-1,5) + init_alpha = 0.0 + do I =1,touse + init_alpha = init_alpha+alpvec(n_iter-I)*dirderivvec(n_iter-I)/dirderivvec(n_iter-I+1) + end do + init_alpha = init_alpha/touse + else + init_alpha = 0.01_dp + end if + + + end function + + + recursive function apply_precon(g,pr,doefunc,init,res2,max_iter,init_k,max_sub_iter,k_out,force_k) result (ap_result) + + implicit none + + real(dp) :: g(:) !to apply to + type (precon_data) :: pr + integer :: doefunc + real(dp),optional :: init(size(g)) + real(dp),optional :: res2 + integer,optional :: max_iter + integer,optional :: init_k + integer,optional :: max_sub_iter + integer,optional,intent(out) :: k_out + integer,optional :: force_k + real(dp) :: ap_result(size(g)) + integer :: k_out_internal + + logical :: do_force_k + + real(dp) :: x(size(g)) + real(dp) :: r(size(g)) + real(dp) :: p(size(g)) + real(dp) :: Ap(size(g)) + real(dp) :: passx(size(g)) + real(dp) :: alpn,alpd,alp,betn,bet,betnold + + real(dp) :: my_res2 + integer :: my_max_iter, gs, my_max_sub + + integer :: k,subk + real(dp),parameter :: betnstop = 10.0_dp**(-10) + real(dp),parameter :: alpdstop = 10.0_dp**(-14) + real(dp),parameter :: alpdsubbstop = 10.0_dp**(-1) + + call system_timer("apply_precon") + + do_force_k = .false. + if(present(force_k)) then + do_force_k = .true. + end if + + subk = 0 + k = 0 + if ( present(init_k) ) k = init_k + + !call print(pr%mat_mult_max_iter) + gs = size(g) + my_res2 = optional_default(pr%res2,res2) + my_max_iter = optional_default(pr%mat_mult_max_iter,max_iter) + my_max_sub = optional_default(pr%max_sub,max_sub_iter) + if ( present(init) ) then + x = init + r = g - do_mat_mult_vec(pr,x,doefunc) + p = r + else + x = 0.0_dp + r = g + p = r + end if + + betn = smartdotproduct(r,r,doefunc) + !call print(p) + !call print(pr%preconrowlengths) + !call exit() + do + + Ap = do_mat_mult_vec(pr,p,doefunc) + + !call print(' ') + !call print(Ap) + alpn = smartdotproduct(r,r,doefunc) + alpd = smartdotproduct(p,Ap,doefunc) + + if (alpd <= alpdstop) then + if ( betn < alpdsubbstop) then + call print("Gave up inverting matrix due to lack of precision, result may be of some use though") + ap_result = x + else + call print("Gave up inverting matrix due to lack of precision, result was garbage returning input") + ap_result = g + end if + if(present(k_out)) k_out = k + exit + end if + alp = alpn/alpd + !call print(alp) + x = x + alp*p + r = r - alp*Ap + betnold = betn + betn = smartdotproduct(r,r,doefunc) + !Usual exit condition + if ( ((betn < my_res2 .and. k >= 10) .or. betn < my_res2 .and. betn > betnold) .and. .not. do_force_k ) then + ap_result = x + if(present(k_out)) k_out = k + exit + end if + + !Force iteration count search direction + if (do_force_k) then + if(k == force_k) then + ap_result = x + exit + endif + endif + + ! Safeguard on search direction + if (betn < betnstop ) then + ap_result = x + if(present(k_out)) k_out = k + exit + end if + + !CG is not converging +! if (betn>betnold) then +! ap_result= x +! if(present(k_out)) k_out = k +! call print("CG failed to invert the preconditioner and aborted with |r|^2 = " // betn) +! exit +! end if + + bet = betn/alpn + p = r + bet*p + k = k+1 + subk = subk + 1 + + if (subk >= my_max_sub) then + !call print("Restarting preconditioner inverter") + passx = x + ap_result = apply_precon(g,pr,doefunc,init=passx,res2=res2,max_iter=max_iter,init_k=k,max_sub_iter=my_max_sub,k_out=k_out_internal) + if (present(k_out)) then + k_out = k_out_internal + end if + exit + end if + + if (k >= my_max_iter) then + if ( betn < 10.0**(-1)) then + call print("Gave up inverting preconditioner afer "// k // " iterations of CG, result may be of some use though") + ap_result = x + else + call print("Gave up inverting preconditioner afer "// k // " iterations of CG, result was garbage returning input") + ap_result = g + end if + if(present(k_out)) then + k_out = k + end if + exit + end if + + + end do + + !call print(k) + call system_timer("apply_precon") + + end function apply_precon + + function apply_precon_gs(b,pr,doefunc,init,res2,max_iter,k_out,force_k) result (ap_result) + + real(dp) :: b(:) + type(precon_data) :: pr + integer :: doefunc + real(dp), optional :: init(:), res2 + integer, optional :: max_iter, k_out, force_k + real(dp) :: ap_result(size(b)) + + integer :: my_max_iter, N, I, J, thisind, k + real(dp) :: my_res2, scoeff, r2 + real(dp) :: x(size(b)), r(size(b)) + integer :: target_elements(3), row_elements(3) + real(dp) :: Y(3),T(3),C(3) + logical :: do_force_k + + N = size(b) + my_res2 = optional_default(pr%res2,res2) + my_max_iter = optional_default(pr%mat_mult_max_iter,max_iter) + + if ( present(init) ) then + if (size(init) == size(b)) then + x = init + else + call print("init vector of incorrect dimension") + endif + else + x = 0.0_dp + end if + + do_force_k = .false. + if(present(force_k)) then + do_force_k = .true. + end if + + k=0 + x(1:9) = b(1:9) + do + + do I = 1,size(pr%preconindices,DIM=2) + C = 0.0 + target_elements = (/ I*3-2+9, I*3-1+9, I*3+9 /) + + if (pr%multI) then + x(target_elements) = b(target_elements)/pr%preconcoeffs(1,I,1) + end if + !call print(pr%preconcoeffs(1,I,1)) + do J = 2,(pr%preconrowlengths(I)) + + thisind = pr%preconindices(J,I) + row_elements = (/ thisind*3-2+9, thisind*3-1+9, thisind*3+9/) + + if (pr%multI) then + + scoeff = pr%preconcoeffs(J,I,1) + + if(doefunc == E_FUNC_BASIC) then + x(target_elements) = x(target_elements) - scoeff*x(row_elements)/pr%preconcoeffs(1,I,1) + else + Y = -scoeff*x(row_elements)/pr%preconcoeffs(1,I,1) - C + T = x(target_elements) + Y + C = (T - x(target_elements)) - Y + x(target_elements) = T + endif + + endif + end do + end do + !call print(x) + !call exit() + k=k+1 + r = b - do_mat_mult_vec(pr,x,doefunc) + r2 = smartdotproduct(r,r,doefunc) + !call print(k // ' '// r2) + if(r2**2.0= my_max_iter) then + if ( r2 < 10.0**(-1)) then + call print("Gave up inverting preconditioner afer "// k // " iterations of GS, result may be of some use though") + ap_result = x + else + call print("Gave up inverting preconditioner afer "// k // " iterations of GS, result was garbage returning input") + ap_result = b + end if + if(present(k_out)) then + k_out = k + end if + exit + end if + end do + + end function + + function apply_precon_csi(b,pr,doefunc,init,res2,max_iter,iter_out,force_iter) result (ap_result) + + implicit none + + real(dp) :: b(:) + type(precon_data) :: pr + integer :: doefunc + real(dp), optional :: init(:), res2 + integer, optional :: max_iter, iter_out, force_iter + real(dp) :: ap_result(size(b)) + + integer :: iter = 1 + real(dp) :: ykp1(size(b)), yk(size(b)), ykm1(size(b)), zk(size(b)) + real(dp) :: omega, gamm, alpha, beta + + alpha = 0.0 + + do + zk = b - do_mat_mult_vec(pr,yk,doefunc) + gamm = 1.0 + ykp1 = omega*(yk - ykm1 + gamm*zk) + ykm1 + + end do + + ap_result = ykp1 + + end function + + function apply_precon_vecs(x,pr,doefunc) + + real(dp) :: x(:,:) + type(precon_data) :: pr + integer :: doefunc + real(dp) :: apply_precon_vecs(size(x,dim=1),size(x,dim=2)) + + integer :: I,M + M = size(x,dim=2) + apply_precon_vecs = 0.0_dp + do I = 1,M + apply_precon_vecs(1:,I) = apply_precon(x(1:,I),pr,doefunc) + end do + + end function + + function apply_precon_vecs_gs(x,pr,doefunc,force_k) + + real(dp) :: x(:,:) + type(precon_data) :: pr + integer :: doefunc + integer :: force_k + real(dp) :: apply_precon_vecs_gs(size(x,dim=1),size(x,dim=2)) + + integer :: I,M + M = size(x,dim=2) + apply_precon_vecs_gs = 0.0_dp + do I = 1,M + apply_precon_vecs_gs(1:,I) = apply_precon_gs(x(1:,I),pr,doefunc,force_k=force_k) + end do + + end function + + + + function do_mat_mult_vecs(pr,x,doefunc) + + real(dp) :: x(:,:) + type(precon_data) :: pr + integer :: doefunc + real(dp) :: do_mat_mult_vecs(size(x,dim=1),size(x,dim=2)) + + integer :: I,M + M = size(x,dim=2) + do_mat_mult_vecs = 0.0_dp + do I = 1,M + do_mat_mult_vecs(1:,I) = do_mat_mult_vec(pr,x(1:,I),doefunc) + end do + + end function + + function do_mat_mult_vec(pr,x,doefunc) + + implicit none + + real(dp) :: x(:) + type(precon_data) :: pr + integer :: doefunc + real(dp) :: do_mat_mult_vec(size(x)) + + integer :: I,J,thisind,K,L + real(dp) :: scoeff + real(dp) :: dcoeffs(6) + integer,dimension(3) :: target_elements, row_elements + real(dp) :: C(3), T(3), Y(3) + + do_mat_mult_vec = 0.0_dp + do_mat_mult_vec(1:9) = pr%cell_coeff*x(1:9) + + do I = 1,size(pr%preconindices,DIM=2) + + !call print(pr%preconindices(1:pr%preconrowlengths(I),I)) + target_elements = (/ I*3-2+9, I*3-1+9, I*3+9 /) + C = 0.0_dp + if (pr%preconrowlengths(I) >= 1) then + + do J = 1,(pr%preconrowlengths(I)) + + thisind = pr%preconindices(J,I) + row_elements = (/ thisind*3-2+9, thisind*3-1+9, thisind*3+9/) + !call print(target_elements) + + + if (pr%multI) then + !call print(target_elements) + !call print(row_elements) + !call print(I // ' ' // thisind) + !call exit() + scoeff = pr%preconcoeffs(J,I,1) + if(doefunc == E_FUNC_BASIC) then + do_mat_mult_vec(target_elements) = do_mat_mult_vec(target_elements) + scoeff*x(row_elements) + else + Y = scoeff*x(row_elements) - C + T = do_mat_mult_vec(target_elements) + Y + C = (T - do_mat_mult_vec(target_elements)) - Y + do_mat_mult_vec(target_elements) = T + endif + + elseif(pr%dense) then + + !call print(size(pr%preconcoeffs(J,I,1:))) + !call exit() + + dcoeffs(1) = pr%preconcoeffs(J,I,1) + dcoeffs(2) = pr%preconcoeffs(J,I,2) + dcoeffs(3) = pr%preconcoeffs(J,I,3) + dcoeffs(4) = pr%preconcoeffs(J,I,4) + dcoeffs(5) = pr%preconcoeffs(J,I,5) + dcoeffs(6) = pr%preconcoeffs(J,I,6) + + !dcoeffs(6) =0.0! pr%preconcoeffs(J,I,6) + + !call print(dcoeffs) + !call exit() + !call writevec(dcoeffs,'dcoeffs.dat') + !call writevec(do_mat_mult(target_elements),'t1.dat') + !call writevec(x(row_elements),'r1.dat') + do_mat_mult_vec(target_elements(1)) = do_mat_mult_vec(target_elements(1)) + dcoeffs(1)*x(row_elements(1)) + do_mat_mult_vec(target_elements(1)) = do_mat_mult_vec(target_elements(1)) + dcoeffs(2)*x(row_elements(2)) + do_mat_mult_vec(target_elements(1)) = do_mat_mult_vec(target_elements(1)) + dcoeffs(3)*x(row_elements(3)) + + do_mat_mult_vec(target_elements(2)) = do_mat_mult_vec(target_elements(2)) + dcoeffs(2)*x(row_elements(1)) + do_mat_mult_vec(target_elements(2)) = do_mat_mult_vec(target_elements(2)) + dcoeffs(4)*x(row_elements(2)) + do_mat_mult_vec(target_elements(2)) = do_mat_mult_vec(target_elements(2)) + dcoeffs(5)*x(row_elements(3)) + + do_mat_mult_vec(target_elements(3)) = do_mat_mult_vec(target_elements(3)) + dcoeffs(3)*x(row_elements(1)) + do_mat_mult_vec(target_elements(3)) = do_mat_mult_vec(target_elements(3)) + dcoeffs(5)*x(row_elements(2)) + do_mat_mult_vec(target_elements(3)) = do_mat_mult_vec(target_elements(3)) + dcoeffs(6)*x(row_elements(3)) + + !call writevec(do_mat_mult(target_elements),'t2.dat') + + !call exit() + + end if + end do + + else + do_mat_mult_vec(target_elements) = x(target_elements) + end if + end do + + end function + + function convert_mat_to_dense(pr) result(prout) + + type(precon_data) :: pr + type(precon_data) :: prout + + logical :: multI = .FALSE. + logical :: diag = .FALSE. + logical :: dense = .FALSE. + integer, allocatable :: preconrowlengths(:) + integer, allocatable :: preconindices(:,:) + real(dp), allocatable :: preconcoeffs(:,:,:) + character(10) :: precon_id + integer :: nneigh,mat_mult_max_iter,max_sub + real(dp) :: energy_scale,length_scale,cutoff,res2 + logical :: has_fixed = .FALSE. + + integer :: M,N + + prout%dense = .true. + prout%precon_id = "genericdense" + prout%nneigh = pr%nneigh + prout%mat_mult_max_iter = pr%mat_mult_max_iter + prout%max_sub = pr%max_sub + prout%energy_scale = pr%energy_scale + prout%length_scale = pr%length_scale + prout%cutoff = pr%cutoff + prout%res2 = pr%res2 + prout%has_fixed = pr%has_fixed + + M = size(pr%preconrowlengths) + allocate(prout%preconrowlengths(M)) + prout%preconrowlengths(1:M) = pr%preconrowlengths(1:M) + + M = size(pr%preconindices,dim=1) + N = size(pr%preconindices,dim=2) + allocate(prout%preconindices(M,N)) + prout%preconindices(1:M,1:N) = pr%preconindices(1:M,1:N) + + M = size(pr%preconcoeffs,dim=1) + N = size(pr%preconcoeffs,dim=2) + allocate(prout%preconcoeffs(M,N,6)) + prout%preconcoeffs = 0.0 + prout%preconcoeffs(1:M,1:N,1) = pr%preconcoeffs(1:M,1:N,1) + prout%preconcoeffs(1:M,1:N,4) = pr%preconcoeffs(1:M,1:N,1) + prout%preconcoeffs(1:M,1:N,6) = pr%preconcoeffs(1:M,1:N,1) + + end function + + function calcdeltaE(doefunc,f1,f0,le1,le0) + integer :: doefunc + real(dp) :: f1, f0 + real(dp) :: le1(:), le0(:) + + real(dp) :: sorted1(size(le1)),sorted0(size(le0)) + real(dp) :: calcdeltaE + + if (doefunc == E_FUNC_BASIC) then + calcdeltaE = f1 - f0 + elseif (doefunc == E_FUNC_KAHAN) then + calcdeltaE = KahanSum(le1 - le0) + elseif (doefunc == E_FUNC_DOUBLEKAHAN) then + sorted1 = qsort(le1-le0) + calcdeltaE = DoubleKahanSum(sorted1) + endif + end function + + function calcE(doefunc,f0,le0) + integer :: doefunc + real(dp) :: f0 + real(dp) :: le0(:) + + real(dp) :: sorted0(size(le0)) + real(dp) :: calcE + + if (doefunc == E_FUNC_BASIC) then + calcE = f0 + elseif (doefunc == E_FUNC_KAHAN) then + calcE = KahanSum(le0) + elseif (doefunc == E_FUNC_DOUBLEKAHAN) then + sorted0 = qsort(le0) + calcE = DoubleKahanSum(sorted0) + endif + end function + + + + function smartdotproduct(v1,v2,doefunc) + integer :: doefunc + real(dp) :: v1(:),v2(:) + + real(dp) :: vec(size(v1)),sorted(size(v1)) + real(dp) :: smartdotproduct + + if(size(v1) .ne. size(v2)) then + call print("Dot Product called with mismatching vector sizes, exiting") + call exit() + end if + + vec = v1*v2 + + if (doefunc == E_FUNC_BASIC) then + smartdotproduct = sum(vec) + elseif (doefunc == E_FUNC_KAHAN) then + smartdotproduct = KahanSum(vec) + elseif (doefunc == E_FUNC_DOUBLEKAHAN) then + sorted = qsort(vec) + smartdotproduct = DoubleKahanSum(sorted) + endif + + end function + + function smartmatmulmat(m1,m2,doefunc) result(prod) + + real(dp) :: m1(:,:), m2(:,:) + integer :: doefunc + real(dp) :: prod(size(m1,dim=1),size(m2,dim=2)) + + integer :: I,J,M,N + M = size(m1,dim=1) + N = size(m2,dim=2) + + do I = 1,M + do J = 1,N + prod(I,J) = smartdotproduct(m1(I,1:),m2(1:,J),doefunc) + end do + end do + end function + + function smartmatmulvec(m1,m2,doefunc) result(prod) + + real(dp) :: m1(:,:), m2(:) + integer :: doefunc + real(dp) :: prod(size(m1,dim=1)) + + integer :: I,M + !call print(size(m1,dim=1) // ' ' // size(m1,dim=2) // ' '// size(m2)) + + M = size(m1,dim=1) + do I = 1,M + prod(I) = smartdotproduct(m1(I,1:),m2,doefunc) + end do + end function + + function KahanSum(vec) + + real(dp) :: vec(:) + real(dp) :: KahanSum + + integer :: I,N + real(dp) :: C,T,Y + + N = size(vec) + + KahanSum = 0.0 + C = 0.0 + do I = 1,N + Y = vec(I) - C + T = KahanSum + Y + C = (T - KahanSum) - Y + KahanSum = T + end do + + end function + + function DoubleKahanSum(vec) + + real(dp) :: vec(:) + real(dp) :: DoubleKahanSum + + integer :: I,N + real(dp) :: C,T,Y,U,V,Z + + N = size(vec) + + DoubleKahanSum = 0.0 + C = 0.0 + do I = 1,N + Y = C + vec(I) + U = vec(I) - (Y - C) + T = Y + DoubleKahanSum + V = Y - (T - DoubleKahanSum) + Z = U + V + DoubleKahanSum = T + Z + C = Z - (DoubleKahanSum - T) + end do + + end function + + recursive function qsort( data ) result( sorted ) + real(dp), dimension(:), intent(in) :: data + real(dp), dimension(1:size(data)) :: sorted + if ( size(data) > 1 ) then + sorted = (/ qsort( pack( data(2:), abs(data(2:)) > abs(data(1)) ) ), & + data(1), & + qsort( pack( data(2:), abs(data(2:)) <= abs(data(1)) ) ) /) + else + sorted = data + endif + end function + + subroutine precongradcheck(x,func,dfunc,data) + real(dp) :: x(:) + INTERFACE + function func(x,data,local_energy) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp)::func + end function func + end INTERFACE + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + character(len=1) :: data(:) + + integer :: N, I, J, levels + real(dp) :: eps,initeps + real(dp) :: f1,f2,deltaE + real(dp), allocatable :: grads(:,:), le1(:),le2(:),xp(:),xm(:) + + initeps = 1.0 + levels = 10 + + + N = size(x) + allocate(grads(levels+1,N)) + allocate(le1( (size(x) - 9)/3)) + allocate(le2( (size(x) - 9)/3)) + allocate(xp(N)) + allocate(xm(N)) + grads(1,1:N) = dfunc(x,data) + do I = 1,N + + eps = initeps + do J = 1,levels + + call print(I // " of "//N// '; '//J // ' of ' //levels) + xp = x + xm = x + xp(I) = xp(I) + eps + xm(I) = xm(I) - eps + + f1 = func(xp,data,le1) + f2 = func(xm,data,le2) + + deltaE = calcdeltaE(E_FUNC_KAHAN ,f1,f2,le1,le2) + + grads(J+1,I) = deltaE/(2.0*eps) + + eps = eps/10.0 + end do + + end do + + call writemat(grads,'gradsGab.dat') + + end subroutine + + subroutine sanity(x,func,dfunc,data) + real(dp) :: x(:) + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + character(len=1) :: data(:) + + real(dp), allocatable :: output(:),le(:) + integer :: I + real(dp),parameter :: stepsize = 10**(-3.0) + integer :: N = 1000 + real(dp) :: g(size(x)) + real(dp) :: f + + g = dfunc(x,data) + + allocate(le( (size(x)-9)/3 )) + allocate(output(N)) + do I = 1,N + call print(I // ' of ' // N) + f = func(x-I*stepsize*g,data,le) + output(I) = KahanSum(le) + end do + + call writevec(output,'sanity.dat') + + + end subroutine + + function infnorm(v) + + real(dp) :: v(:) + + real(dp) :: infnorm, temp + integer :: l, I + + l = size(v) + + temp = abs(v(1)) + do I = 2,l + if ( abs(v(I)) > temp ) temp = v(I) + end do + + infnorm = temp + + end function + + ! utility function to dump a vector into a file (for checking,debugging) + subroutine writevec(vec,filename) + real(dp) :: vec(:) + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) vec + close(outid) + + end subroutine + + subroutine writeveci(vec,filename) + integer :: vec(:) + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) vec + close(outid) + + end subroutine + + subroutine writemat(mat,filename) + real(dp) :: mat(:,:) + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) mat + close(outid) + + end subroutine + + subroutine writeprecon(precon,filename) + type(precon_data) :: precon + character(*) :: filename + + call writepreconcoeffs(precon,filename // 'coeffs') + call writepreconindices(precon,filename // 'indices') + call writepreconrowlengths(precon,filename // 'lengths') + end subroutine + + subroutine writepreconcoeffs(precon,filename) + type(precon_data) :: precon + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) precon%preconcoeffs + close(outid) + + end subroutine + + subroutine writepreconindices(precon,filename) + type(precon_data) :: precon + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) precon%preconindices + close(outid) + + end subroutine + + subroutine writepreconrowlengths(precon,filename) + type(precon_data) :: precon + character(*) :: filename + + integer :: outid = 10 + open(unit=outid,file=filename,action="write",status="replace") + write(outid,*) precon%preconrowlengths + close(outid) + + end subroutine + + subroutine writeLBFGS(LBFGSs,LBFGSy,n_back,filename) + real(dp):: LBFGSs(:,:), LBFGSy(:,:) + integer :: n_back + character(*) :: filename + integer :: outid1 = 10 + integer :: outid2 = 11 + integer :: M + M = size(LBFGSs,dim=2) + + open(unit=outid1,file=(filename//'s'),action="write",status="replace") + write(outid1,*) LBFGSs(1:,(M-n_back+1):) + close(outid1) + + open(unit=outid2,file=(filename//'y'),action="write",status="replace") + write(outid2,*) LBFGSy(1:,(M-n_back+1):) + close(outid2) + + + + end subroutine + + function precondimer(x_in,v_in,func,dfunc,build_precon,pr,method,convergence_tol,max_steps,efuncroutine,LM, linminroutine, hook, hook_print_interval, am_data, status,writehessian,gethessian,infoverride) + + implicit none + + real(dp), intent(inout) :: x_in(:) !% Starting position + real(dp), intent(inout) :: v_in(:) !% Starting dimer orientation + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + INTERFACE + function dfunc(x,data) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp)::dfunc(size(x)) + end function dfunc + END INTERFACE + INTERFACE + subroutine build_precon(pr,am_data) + use system_module + import precon_data + type(precon_data),intent(inout) ::pr + character(len=1)::am_data(:) + end subroutine + END INTERFACE + type(precon_data):: pr + character(*), intent(in) :: method !% 'cg' for conjugate gradients or 'sd' for steepest descent + real(dp), intent(in) :: convergence_tol !% Minimisation is treated as converged once $|\mathbf{\nabla}f|^2 <$ + !% 'convergence_tol'. + integer, intent(in) :: max_steps !% Maximum number of 'cg' or 'sd' steps + integer::precondimer + character(*), intent(in), optional :: efuncroutine !% Control of the objective function evaluation + character(*), intent(in), optional :: linminroutine !% Name of the line minisation routine to use. + integer, optional :: LM + optional :: hook + INTERFACE + subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + end subroutine hook + end INTERFACE + integer, intent(in), optional :: hook_print_interval + character(len=1), optional, intent(inout) :: am_data(:) + integer, optional, intent(out) :: status + optional :: writehessian + INTERFACE + subroutine writehessian(x,data,filename) + use system_module + real(dp) :: x(:) + character(len=1)::data(:) + character(*) :: filename + end subroutine writehessian + end INTERFACE + optional :: gethessian + INTERFACE + subroutine gethessian(x,data,FDHess) + use system_module + real(dp),intent(in):: x(:) + character(len=1),intent(in)::data(:) + real(dp),intent(inout) :: FDHess(:,:) + end subroutine gethessian + end INTERFACE + real(dp), optional :: infoverride + + integer :: N,k,k2,k3,kmax,k2max + real(dp) :: h = 1e-3_dp + real(dp), parameter :: pi = 4.0_dp*datan(1.0_dp) + real(dp), parameter :: TOLvdefault = 10.0_dp**(-1) + + real(dp), allocatable :: x(:), F1(:), F2(:), F10(:), F20(:), v(:), vstar(:), Gd(:), s(:), sl2(:), Gv(:), Gvp(:), Gx(:), Gxp(:), Gdl2(:), Gvpold(:), Gxpold(:), Gs(:), Qx(:) + real(dp), allocatable :: local_energy1(:),local_energy2(:),local_energy10(:),local_energy20(:),alpvec(:),dirderivvec(:) + real(dp) :: alpha_x,crit,avn,dC,delE,e1,e10,e2,e20,lam,res_v,res_v_rot,res_x,rotC,traC,TOLv,dt + logical :: rotationfailed, totalfailure + + logical :: doLSbasic, doLSstandard + integer :: doefunc + + logical :: noimprove + real(dp) :: res_x_hist(5) = 1000.0_dp + + integer :: neval + + alpha_x = 0.01 + rotC = 10.0_dp**(-3) + traC = 10.0_dp**(-3) + TOLv = TOLvdefault + + kmax = max_steps + k2max = 5 + + if ( present(linminroutine) ) then + call print('linmin options not currently supported by dimer') +! if (trim(linminroutine) == 'basic') then +! call print('Using basic backtracking linesearch') +! doLSbasic = .TRUE. +! elseif (trim(linminroutine) == 'standard') then +! call print('Using standard two-stage linesearch with cubic interpolation in the zoom phase, with bisection as backup') +! call print('Not recommended for dimer method!!!') +! doLSstandard = .TRUE. +! end if +! else +! doLSbasic = .true. + end if + + N = size(x_in) + + allocate(local_energy1((N-9)/3),local_energy2((N-9)/3),local_energy10((N-9)/3),local_energy20((N-9)/3)) + allocate(x(N),F1(N),F2(N),F10(N),F20(N),v(N),vstar(N),Gd(N),s(N),sl2(N),Gv(N),Gvp(N),Gx(N),Gxp(N),Gdl2(N),Gvpold(N),Gxpold(N),Qx(N),gs(N)) + + allocate(alpvec(max_steps)) + allocate(dirderivvec(max_steps)) + + + !open(1,file='dimerplot.dat',status='replace',access='stream',action='write') + + doefunc = E_FUNC_BASIC + if ( present(efuncroutine) ) then + if (trim(efuncroutine) == 'basic') then + doefunc = E_FUNC_BASIC + call print('Using naive summation of local energies') + elseif (trim(efuncroutine) == 'kahan') then + doefunc = E_FUNC_KAHAN +! allocate(local_energycand((size(x)-9)/3)) + call print('Using Kahan summation of local energies') + elseif (trim(efuncroutine) == 'doublekahan') then + doefunc = E_FUNC_DOUBLEKAHAN +! allocate(local_energycand((size(x)-9)/3)) + call print('Using double Kahan summation of local energies with quicksort') + end if + else + doefunc = E_FUNC_BASIC + call print('Using naive summation of local energies by default') + end if + x = x_in + v = v_in + !call random_number(d) + + avn = pi/4.0 + k = 0 + do + + call build_precon(pr,am_data) + v = v/sqrt(Pdotproduct(v,v,pr,doefunc)) + + call writeprecon(pr,'dimerpr') + + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + e1 = func_wrapper(func,x+h*v,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) + e2 = func_wrapper(func,x-h*v,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) + neval = neval + 2 +#ifndef _OPENMP + call verbosity_pop() +#endif + + Gxpold = Gxp + Gx = 0.5_dp*(F1 + F2) + + + if (k > 0) then + Gxp = apply_precon(Gx,pr,doefunc,init=Gxpold) + else + Gxp = apply_precon(Gx,pr,doefunc) + !call exit() + end if + res_x = sqrt(smartdotproduct(Gxp,Gx,doefunc)) + + res_x_hist(1:4) = res_x_hist(2:5) + res_x_hist(5) = res_x + + !call print(abs(sum(res_x_hist)/5.0_dp) ) + +! noimprove = .false. +! if ( abs(sum(res_x_hist)/5.0_dp - res_x) < 10.0_dp**(-2)) then +! noimprove = .true. +! end if +! +! if (noimprove) then +! call print("Residual does not seem to be improving, switching to simple dimer method") +! k = simpleprecondimer(x,v,h,func,am_data,build_precon,pr,doefunc,0.005_dp,0.005_dp) +! exit +! end if + + + + Gvpold = Gvp + Gv = (F1 - F2)/(2.0_dp*h) + if (k > 0) then + Gvp = apply_precon(Gv,pr,doefunc,init=Gvpold) + else + Gvp = apply_precon(Gv,pr,doefunc) + end if + + lam = smartdotproduct(Gv,v,doefunc) + Gd = Gvp - lam*v + Gdl2 = Gv - lam*v + res_v = sqrt(Pdotproduct(Gd,Gd,pr,doefunc)) + call print('precon_dimer n_iter = ' // k // ', res_x = ' // res_x // ', res_v = ' // res_v // ', lam = ' // lam //', alpha = '// alpha_x // ', nf = '//neval) + if (res_x < convergence_tol) then + call print('Precon Dimer exiting with translation residual = ' //res_x) + exit + end if + + + + rotationfailed = .false. + totalfailure = .false. + k2 = 0 + ! Do a rotation if necessary + do while (res_v > max(TOLv,res_x)) + + s = -Gd + sl2 = -Gdl2 + dC = smartdotproduct(s,sl2,doefunc) + + e10 = e1 + e20 = e2 + F10 = F1 + F20 = F2 + local_energy10 = local_energy1 + local_energy20 = local_energy2 + + + if (rotationfailed .eqv. .false.) then + + k3 = 0 + do + crit = -h*h*rotC*dC*avn + vstar = cos(avn)*v + sin(avn)*s + vstar = vstar/sqrt(Pdotproduct(vstar,vstar,pr,doefunc)) + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + e1 = func_wrapper(func,x+h*vstar,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + e2 = func_wrapper(func,x-h*vstar,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + + neval = neval + 2 + delE = calcdeltaE(doefunc,e1,e10,local_energy1,local_energy10) + calcdeltaE(doefunc,e2,e20,local_energy2,local_energy20) + call print("precon_dimer rotation inner, theta = " // avn // ", delE = "// delE//" crit = "//crit) + + ! call print(avn // ' '// delE // ' ' //crit//' '//norm(v-vstar)) + !call print(e2// ' '//e20) + + if (delE < crit) then + v = vstar + exit + end if + + if (abs(delE) < 10.0**(-12) .and. delE < 10.0**(-15)) then + rotationfailed = .true. + call print('Ran out of precision in objective based rotation') + exit + else + avn = avn/2.0_dp + end if + + end do + else + exit + end if + + if (rotationfailed .eqv. .false.) then + + Gvpold = Gvp; + Gv = (F1 - F2)/(2.0_dp*h) + Gvp = apply_precon(Gv,pr,doefunc,init=Gvpold) + + lam = smartdotproduct(Gv,v,doefunc) + Gd = Gvp - lam*v + Gdl2 = Gv - lam*v + res_v = sqrt(Pdotproduct(Gd,Gd,pr,doefunc)) + + end if + + call print('precon_dimer rotating, iter = '// k2 //',theta = '//avn// ',delE = ' //delE //',res_v = '//res_v) + k2 = k2 + 1 + if (res_v < TOLv .or. totalfailure .eqv. .true. .or. k2 > k2max) then + !call print(res_v // ' ' //k2) + exit + end if + + + end do + + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + e1 = func_wrapper(func,x+h*v,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + e2 = func_wrapper(func,x-h*v,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + + neval = neval + 2 + Gx = 0.5*(F1+F2) + Gxpold = Gxp + Gxp = apply_precon(Gx,pr,doefunc,init=Gxpold) + + gs = -Gx + 2.0*smartdotproduct(v,Gx,doefunc)*v + s = -Gxp + 2.0*smartdotproduct(v,Gx,doefunc)*v + dt = -smartdotproduct(gs,s,doefunc) + if (dt > 0) then + gs = -gs + dt = -dt + end if + + !alpha_x = 2.0*init_alpha(alpvec,dirderivvec,k) + alpha_x = 2.0*alpha_x + e10 = e1 + e20 = e2 + F10 = F1 + F20 = F2 + local_energy10 = local_energy1 + local_energy20 = local_energy2 + res_v_rot = res_v + k2 = 0 + do + + delE = dimerdelE(x+alpha_x*s,v,h,lam,x,Gx,pr,func,am_data,doefunc,e10,e20,local_energy10,local_energy20) + crit = dt*traC*alpha_x + + neval = neval + 2 + call print('precon_dimer translating, iter = '// k2 //', alpha = '//alpha_x// ', delE = ' //delE) + if (delE < crit + 10.0**(-14) .and. res_v < 10.0*res_v_rot) then + x = x + alpha_x*s + + exit + end if + alpha_x = alpha_x/2.0 + k2 = k2 + 1 + end do + + + + k = k + 1 + dirderivvec(k) = dt + alpvec(k) = alpha_x + + if ( k >= max_steps) then + exit + end if + end do + x_in = x + + end function + + function dimerdelE(x,v,h,lam,x0,gx0,pr,func,am_data,doefunc,e10,e20,local_energy10,local_energy20) result(delE) + + real(dp) :: x(:),v(:),x0(:),gx0(:) + type(precon_data) :: pr + real(dp) :: h,lam + character(len=1), intent(inout) :: am_data(:) + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + real(dp) :: delE + integer :: doefunc + + + real(dp) :: e10,e20,local_energy10(:),local_energy20(:) + real(dp) :: e1,e2,local_energy1(size(local_energy10)),local_energy2(size(local_energy20)) + + real(dp) :: Qx(size(x)) + real(dp) :: F1(size(x)), F2(size(x)) + + Qx = smartdotproduct(v,x-x0,doefunc)*v + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + e1 = func_wrapper(func,x+h*v,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) + e2 = func_wrapper(func,x-h*v,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + + delE = (calcdeltaE(doefunc,e1,e10,local_energy1,local_energy10) + calcdeltaE(doefunc,e2,e20,local_energy2,local_energy20))/2.0_dp & + -2.0*Pdotproduct(v,x-x0,pr,doefunc)*smartdotproduct(v,gx0,doefunc) - lam*Pdotproduct(Qx,Qx,pr,doefunc) + + ! Gv = (F1 - F2)/(2.0_dp*h) + ! if (k > 0) then + ! Gvp = apply_precon(Gv,pr,doefunc,init=Gvpold) + ! else + ! Gvp = apply_precon(Gv,pr,doefunc) + ! end if + + ! lam = smartdotproduct(Gv,v,doefunc) + ! Gd = Gvp - lam*v + ! res_v = sqrt(Pdotproduct(Gd,Gd,pr,doefunc)) + ! + end function + + function simpleprecondimer(x,v,h,func,am_data,build_precon,pr,doefunc,alpha_x,alpha_v) result(k) + + real(dp), intent(inout) :: x(:),v(:) + real(dp) :: h + INTERFACE + function func(x,data,local_energy,gradient) + use system_module + real(dp)::x(:) + character(len=1),optional::data(:) + real(dp), intent(inout),optional :: local_energy(:) + real(dp), intent(inout),optional :: gradient(:) + real(dp)::func + end function func + end INTERFACE + character(len=1), intent(inout) :: am_data(:) + INTERFACE + subroutine build_precon(pr,am_data) + use system_module + import precon_data + type(precon_data),intent(inout) ::pr + character(len=1)::am_data(:) + end subroutine + END INTERFACE + type(precon_data):: pr + integer :: doefunc + real(dp) :: alpha_x,alpha_v + + integer :: k,N + integer :: kmax = 1000 + real(dp) :: e1,e2,lam,res_x,res_v + + real(dp), allocatable :: F1(:), F2(:), F10(:), F20(:), vstar(:), Gd(:), s(:), sl2(:), Gv(:), Gvp(:), Gx(:), Gxp(:), Gdl2(:), Gvpold(:), Gxpold(:), Gs(:), Qx(:) + real(dp), allocatable :: local_energy1(:),local_energy2(:),local_energy10(:),local_energy20(:),alpvec(:),dirderivvec(:) + + N = size(x,1) + allocate(local_energy1((N-9)/3),local_energy2((N-9)/3)) + allocate(F1(N),F2(N),F10(N),F20(N),vstar(N),Gd(N),s(N),sl2(N),Gv(N),Gvp(N),Gx(N),Gxp(N),Gdl2(N),Gvpold(N),Gxpold(N),Qx(N),gs(N)) + + + k = 0 + do + call build_precon(pr,am_data) + v = v/sqrt(Pdotproduct(v,v,pr,doefunc)) + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + e1 = func_wrapper(func,x+v*h,am_data,local_energy=local_energy1,gradient=F1,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + +#ifndef _OPENMP + call verbosity_push_decrement(2) +#endif + e2 = func_wrapper(func,x-v*h,am_data,local_energy=local_energy2,gradient=F2,doefunc=doefunc) +#ifndef _OPENMP + call verbosity_pop() +#endif + + Gxpold = Gxp + Gx = 0.5_dp*(F1 + F2); + if (k > 1) then + Gxp = apply_precon(Gx,pr,doefunc,init=Gxpold) + else + Gxp = apply_precon(Gx,pr,doefunc) + end if + res_x = sqrt(smartdotproduct(Gxp,Gx,doefunc)) + + Gvpold = Gvp + Gv = (F1 - F2)/(2.0_dp*h) + if (k > 1) then + Gvp = apply_precon(Gv,pr,doefunc,init=Gvpold) + else + Gvp = apply_precon(Gv,pr,doefunc) + end if + + lam = smartdotproduct(Gv,v,doefunc) + Gd = Gvp - lam*v + Gdl2 = Gv - lam*v + res_v = sqrt(Pdotproduct(Gd,Gd,pr,doefunc)) + call print('n_iter = ' // k // ', res_x = ' // res_x // ', res_v = ' // res_v // ', lam = ' // lam //', alpha = '// alpha_x) + + v = v - alpha_v*Gvp + x = x - alpha_x*(Gxp - 2.0*smartdotproduct(v,Gx,doefunc)*v) + + + k = k + 1 + if (k>=kmax) then + exit + end if + end do + + end function + + subroutine printlikematlab(x) + real(dp) :: x(:) + integer :: vl + vl = size(x) + call print(reshape(x(10:vl),(/ 3 , (vl-9)/3 /))) + + end subroutine +end module minimization_module + diff --git a/src/libAtoms/nye_tensor.F90 b/src/libAtoms/nye_tensor.F90 new file mode 100644 index 0000000000..96b0705bb6 --- /dev/null +++ b/src/libAtoms/nye_tensor.F90 @@ -0,0 +1,310 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! Nye Tensor calculations from C. S. Hartley and Y. Mishin, Acta Mat. v. 53, p. 1313 (2005) + +module nye_tensor_module + use system_module, only : dp, print, PRINT_NERD, PRINT_VERBOSE, operator(//) + use units_module + use linearalgebra_module + use atoms_module + implicit none + private + + public :: calc_nye_tensor + +contains + subroutine calc_nye_tensor(at, ref_lat, alpha, G) + type(Atoms), intent(inout) :: at + type(Atoms), intent(inout) :: ref_lat + real(dp), intent(out) :: alpha(:,:,:) + real(dp), intent(out), target, optional :: G(:,:,:) + + real(dp), pointer :: G_p(:,:,:) + real(dp), allocatable :: Qplus(:,:,:) + integer, allocatable :: match_list(:,:) + integer, allocatable :: n_matches(:) + + integer, allocatable :: ref_nn_list(:) + real(dp), allocatable :: ref_nn_vec(:,:), ref_nn_vec_normalised(:,:) + integer, allocatable :: nn_list(:) + real(dp), allocatable :: nn_vec(:,:), nn_vec_normalised(:,:) + + integer :: ref_n_neighbours, l_n_neighbours, max_n_neighbours + integer :: i_at + + integer i_gamma, II, MM, i, j, k, m + real(dp), allocatable :: Delta_G(:,:,:) + real(dp), allocatable :: Delta_G_vec(:) + real(dp) :: A(3,3,3) + real(dp) :: eps(3,3,3) + + call calc_connect(ref_lat) + call calc_connect(at) + + max_n_neighbours = 0 + do i_at = 1, at%N + l_n_neighbours = n_neighbours(at, i_at) + if (l_n_neighbours > max_n_neighbours) max_n_neighbours = l_n_neighbours + end do + call print('max_n_neighbours='//max_n_neighbours, PRINT_VERBOSE) + + if (.not.present(G)) then + allocate(G_p(3,3,at%N)) + else + G_p => G + endif + allocate(Qplus(3,max_n_neighbours,at%N)) + allocate(match_list(max_n_neighbours,at%N)) + allocate(n_matches(at%N)) + allocate(Delta_G(3,3,max_n_neighbours)) + allocate(Delta_G_vec(max_n_neighbours)) + + call get_nn_list(ref_lat, 1, ref_n_neighbours, ref_nn_list, ref_nn_vec, ref_nn_vec_normalised) + call print('get_nn_list found ref_n_neighbours='//ref_n_neighbours, PRINT_VERBOSE) + + do i_at=1, at%N + call get_nn_list(at, i_at, l_n_neighbours, nn_list, nn_vec, nn_vec_normalised) + call print('get_nn_list found l_n_neighbours='//ref_n_neighbours//' i_at='//i_at, PRINT_VERBOSE) + + call find_lattice_correspondence(l_n_neighbours, nn_list, nn_vec, nn_vec_normalised, & + ref_n_neighbours, ref_nn_list, ref_nn_vec, ref_nn_vec_normalised, & + n_matches(i_at), match_list(:,i_at), Qplus(:,:,i_at), G_p(:,:,i_at)) + call print("atom i_at " // i_at, PRINT_NERD) + call print("n_matches " // n_matches(i_at) // " match_list " // match_list(1:n_matches(i_at),i_at), PRINT_NERD) + call print("Qplus", PRINT_NERD) + call print(Qplus(1:3,1:n_matches(i_at),i_at), PRINT_NERD) + call print("G", PRINT_NERD) + call print(G_p(1:3,1:3,i_at), PRINT_NERD) + end do + + eps = permutation_symbol() + + do i_at = 1, at%N + do i_gamma = 1, n_matches(i_at) + Delta_G(:,:,i_gamma) = G_p(:,:,match_list(i_gamma,i_at)) - G_p(:,:,i_at) + call print("Delta_G(:,:,"//i_gamma//")", PRINT_NERD) + call print(Delta_G(:,:,i_gamma), PRINT_NERD) + end do + do II = 1, 3 + do MM = 1, 3 + Delta_G_vec(1:n_matches(i_at)) = Delta_G(II,MM,1:n_matches(i_at)) + call print("II " // II // " MM " // MM, PRINT_NERD) + call print("Delta_G_vec " // Delta_G_vec, PRINT_NERD) + A(II,MM,1:3) = matmul(Qplus(1:3,1:n_matches(i_at),i_at), Delta_G_vec(1:n_matches(i_at))) + call print("A " // A(II, MM, 1:3), PRINT_NERD) + end do + end do + + alpha(:,:,i_at) = 0.0_dp + do j=1, 3 + do k=1, 3 + do m=1, 3 + do i=1, 3 + alpha(j,k,i_at) = alpha(j,k,i_at) - eps(j,i,m)*A(m,k,i) + end do + end do + end do + end do + + call print("alpha(:,:,"//i_at//")", PRINT_VERBOSE) + call print(alpha(1,:,i_at), PRINT_VERBOSE) + call print(alpha(2,:,i_at), PRINT_VERBOSE) + call print(alpha(3,:,i_at), PRINT_VERBOSE) + + end do + + if (.not. present(G)) then + deallocate(G_p) + endif + deallocate(match_list, Qplus) + deallocate(n_matches) + deallocate(Delta_G, Delta_G_vec) + end subroutine calc_nye_tensor + + subroutine find_lattice_correspondence(l_n_neighbours, nn_list, nn_vec, nn_vec_normalised, & + ref_n_neighbours, ref_nn_list, ref_nn_vec, ref_nn_vec_normalised, & + n_matches, match_list, Qplus, G) + integer, intent(in) :: l_n_neighbours + integer, intent(in) :: nn_list(:) + real(dp), intent(in) :: nn_vec(:,:), nn_vec_normalised(:,:) + integer, intent(in) :: ref_n_neighbours + integer, intent(in) :: ref_nn_list(:) + real(dp), intent(in) :: ref_nn_vec(:,:), ref_nn_vec_normalised(:,:) + integer, intent(out) :: n_matches + integer, intent(out) :: match_list(:) + real(dp), intent(out) :: Qplus(:,:), G(:,:) + + real(dp), allocatable :: P(:,:), Q(:,:) + real(dp) :: QTQ_inv(3,3) + + integer :: i_beta, i_gamma, i_gammap + integer :: match_i, t_n_matches + integer, allocatable :: t_match_list(:) + real(dp), allocatable :: t_match_length(:) + real(dp) :: smallest_angle + real(dp), allocatable :: angles(:,:) + integer :: save_match, i_gamma_best_match(1), i_match + + !real(dp) :: max_angle_dev = 27.0_dp*PI/180.0_dp + + allocate(angles(l_n_neighbours, ref_n_neighbours)) + allocate(t_match_list(ref_n_neighbours)) + allocate(t_match_length(ref_n_neighbours)) + + + ! calculate all angles between lat and ref neighbor vectors + do i_gamma = 1, l_n_neighbours + do i_beta = 1, ref_n_neighbours + angles(i_gamma, i_beta) = acos(sum(nn_vec_normalised(1:3,i_gamma)*ref_nn_vec_normalised(1:3,i_beta))) + end do + end do + + + ! for each lat vector i_gamma, find matching ref vector and save in match_list(i_gamma), save 0 if more than 1 ref. vector matches + do i_gamma = 1, l_n_neighbours + smallest_angle = 1.0e38_dp + n_matches = 0 ! ref. vector matches to this real neighbor vector + do i_beta=1, ref_n_neighbours + if (angles(i_gamma, i_beta) .feq. smallest_angle) then + n_matches = n_matches + 1 + else if (angles(i_gamma, i_beta) < smallest_angle) then + n_matches = 1 + match_i = i_beta + smallest_angle = angles(i_gamma, i_beta) + endif + end do + if (n_matches /= 1 .or. smallest_angle > 27.0_dp*PI/180.0_dp) then + match_list(i_gamma) = 0 + else + match_list(i_gamma) = match_i + endif + end do + + ! look for multiple lat vectors that match same ref vector, and pick best length match - zero other entries of match_list + do i_gamma = 1, l_n_neighbours + if (match_list(i_gamma) == 0) cycle + t_n_matches = 0 + do i_gammap = 1, l_n_neighbours + if (match_list(i_gammap) == match_list(i_gamma)) then + t_n_matches = t_n_matches + 1 + t_match_list(t_n_matches) = i_gammap + t_match_length(t_n_matches) = norm(nn_vec(:,i_gammap)) + endif + end do + if (t_n_matches > 1) then + i_gamma_best_match = minloc(abs(t_match_length-norm(ref_nn_vec(:,match_list(i_gamma))))) + save_match = match_list(i_gamma) + match_list(t_match_list(1:t_n_matches)) = 0 + match_list(i_gamma_best_match(1)) = save_match + endif + end do + + ! fill in P and Q vectors for matched pairs + n_matches = count(match_list(1:l_n_neighbours) /= 0) + call print('find_lattice_correspondence found l_n_neighbours='//l_n_neighbours//' n_matches='//n_matches, PRINT_VERBOSE) + allocate(P(n_matches,3)) + allocate(Q(n_matches,3)) + i_match = 0 + do i_gamma=1, l_n_neighbours + if (match_list(i_gamma) /= 0) then + i_match = i_match + 1 + Q(i_match,1:3) = nn_vec(1:3,i_gamma) + P(i_match,1:3) = ref_nn_vec(1:3,match_list(i_gamma)) + endif + end do + + ! compute Qplus and G + QTQ_inv(1:3,1:3) = matmul(transpose(Q(1:n_matches,1:3)),Q(1:n_matches,1:3)) + call inverse(QTQ_inv) + Qplus(1:3,1:n_matches) = matmul(QTQ_inv(1:3,1:3),transpose(Q(1:n_matches,1:3))) + G(1:3,1:3) = matmul(Qplus(1:3,1:n_matches), P(1:n_matches,1:3)) + + call print("P", PRINT_NERD) + call print(P, PRINT_NERD) + call print("Q", PRINT_NERD) + call print(Q, PRINT_NERD) + call print("Q - P", PRINT_NERD) + call print((Q - P), PRINT_NERD) + call print("Q.G - P", PRINT_NERD) + call print(((Q.mult.G) - P), PRINT_NERD) + call print("rms Q-P " // sum((Q-P)**2), PRINT_NERD) + call print("rms Q.G-P " // sum(((Q.mult.G)-P)**2), PRINT_NERD) + + deallocate(P,Q) + + deallocate(angles) + deallocate(t_match_list) + deallocate(t_match_length) + + ! make output match_list(), which contains indices of atoms for each matched bond + allocate(t_match_list(l_n_neighbours)) + i_gammap = 0 + do i_gamma = 1, l_n_neighbours + if (match_list(i_gamma) /= 0) then + i_gammap = i_gammap + 1 + t_match_list(i_gammap) = nn_list(i_gamma) + end if + end do + match_list = 0 + match_list(1:n_matches) = t_match_list(1:n_matches) + deallocate(t_match_list) + end subroutine find_lattice_correspondence + + subroutine get_nn_list(at, i_at, l_n_neighbours, nn_list, nn_vec, nn_vec_normalised) + type(Atoms), intent(inout) :: at + integer, intent(in) :: i_at + integer, intent(out) :: l_n_neighbours + integer, allocatable, intent(inout) :: nn_list(:) + real(dp), allocatable, intent(inout) :: nn_vec(:,:), nn_vec_normalised(:,:) + + real(dp) :: nn_v(3), nn_v_normalised(3) + integer i_neigh + + l_n_neighbours = n_neighbours(at, i_at) + + if (.not. allocated(nn_list) .or. l_n_neighbours > size(nn_list)) then + if (allocated(nn_list)) deallocate(nn_list) + allocate(nn_list(l_n_neighbours)) + if (allocated(nn_vec)) deallocate(nn_vec) + allocate(nn_vec(3,l_n_neighbours)) + if (allocated(nn_vec_normalised)) deallocate(nn_vec_normalised) + allocate(nn_vec_normalised(3,l_n_neighbours)) + endif + + do i_neigh = 1, l_n_neighbours + nn_list(i_neigh) = neighbour(at, i_at, i_neigh, diff = nn_v, cosines = nn_v_normalised) + nn_vec(:, i_neigh) = nn_v + nn_vec_normalised(:, i_neigh) = nn_v_normalised + end do + + end subroutine get_nn_list + +end module nye_tensor_module diff --git a/src/libAtoms/partition.F90 b/src/libAtoms/partition.F90 new file mode 100644 index 0000000000..70558631ec --- /dev/null +++ b/src/libAtoms/partition.F90 @@ -0,0 +1,414 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X This module written by Marco Caccin +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module partition_module + + use iso_c_binding + use error_module + use system_module, only: dp, operator(//) + use atoms_types_module + use atoms_module + use connection_module + use clusters_module, only: HYBRID_ACTIVE_MARK + use ringstat_module, only: distance_map + + implicit none + private + + public :: kway_partition_atoms, partition_qm_list + + interface + function METIS_SetDefaultOptions(options) bind(c) + use iso_c_binding + integer(C_INT) :: METIS_SetDefaultOptions + integer(C_INT), dimension(0:40) :: options + end function METIS_SetDefaultOptions + + function METIS_PartGraphKway(nvtxs, ncon, xadj, adjncy, vwgt, vsize, & + adjwgt, nparts, tpwgts, ubvec, options, objval, part) bind(c) + use iso_c_binding + integer(C_INT) :: nvtxs, ncon, nparts, objval + integer(C_INT), dimension(*) :: xadj, adjncy, part + type(C_PTR) :: vwgt, vsize, adjwgt, tpwgts, ubvec + integer(C_INT), dimension(0:40) :: options + integer(C_INT) :: METIS_PartGraphKway + end function METIS_PartGraphKway + end interface + + ! There is no METIS Fortran API, so we have to declare constants. The following are valid for versions >= 5. + ! Tested with 5.1.0_3, Nov 2014 + integer(C_INT), parameter :: METIS_OPTION_PTYPE=0, METIS_OPTION_OBJTYPE=1, METIS_OPTION_CTYPE=2, METIS_OPTION_IPTYPE=3, & + METIS_OPTION_RTYPE=4, METIS_OPTION_DBGLVL=5, METIS_OPTION_NITER=6, METIS_OPTION_NCUTS=7, METIS_OPTION_SEED=8, & + METIS_OPTION_NO2HOP=9, METIS_OPTION_MINCONN=10, METIS_OPTION_CONTIG=11, METIS_OPTION_COMPRESS=12, & + METIS_OPTION_CCORDER=13, METIS_OPTION_PFACTOR=14, METIS_OPTION_NSEPS=15, METIS_OPTION_UFACTOR=16, & + METIS_OPTION_NUMBERING=17, METIS_OPTION_HELP=18, METIS_OPTION_TPWGTS=19, METIS_OPTION_NCOMMON=20, & + METIS_OPTION_NOOUTPUT=21, METIS_OPTION_BALANCE=22, METIS_OPTION_GTYPE=23, METIS_OPTION_UBVEC=24 + +contains + +! subroutine atoms_to_metis_graph(at, mask, error, filename) +! implicit none +! type(Atoms), intent(in) :: at +! integer :: distance_matrix(at%N, at%N) +! integer :: i, j +! integer :: nnodes, nedges +! logical, intent(in), optional :: mask(at%N) +! integer, intent(out), optional :: error +! character(len=*), intent(in) :: filename +! character(len=STRING_LENGTH), dimension(nnodes) :: lines +! character(len=STRING_LENGTH) :: tempstr + +! call distance_map(at, distance_matrix, mask, error) +! ! convert a bondhop distance matrix into lines of METIS graph file (line 1+1 := list of edges for node i) +! do i = 1, nnodes +! lines(i) = " " +! do j = 1, nnodes +! if (dist(i,j) == 1) then +! if (j>i) then +! nedges = nedges + 1 +! end if +! write( tempstr, '(i10)' ) j ! convert j to string +! lines(i) = trim(lines(i))//" "//trim(tempstr) ! append it to list of neighbours of i on the same line +! end if +! end do +! end do +! ! write the METIS graph file corresponding to at +! open(12, file=filename, status="replace", action="write") +! write(12,*) nnodes, nedges +! do i = 1, nnodes +! write(12,*) trim(lines(i)) +! end do +! close(12) +! end subroutine atoms_to_metis_graph + + + subroutine preprocess_atoms_to_csr_adjacency_matrix(at, nneightol, nedges) + implicit none + type(Atoms), intent(in) :: at + integer :: i + real(dp), intent(in) :: nneightol + integer, intent(out) :: nedges + type(Atoms) :: at_copy + + call atoms_copy_without_connect(at_copy, at) + at_copy%nneightol = nneightol + !% Use hysteretic connect so we can work with relative cutoffs + call calc_connect_hysteretic(at_copy, at_copy%nneightol, at_copy%nneightol) + + nedges = 0 + do i = 1, at%N + nedges = nedges + n_neighbours(at_copy, i) + end do + + call finalise(at_copy) + + end subroutine preprocess_atoms_to_csr_adjacency_matrix + + + subroutine atoms_to_csr_adjacency_matrix(at, nedges, xadj, adjncy) + implicit none + type(Atoms), intent(in) :: at + integer, intent(in) :: nedges + integer :: i, j, edge + integer :: nneighs, neigh_idx + integer(C_INT), intent(out) :: xadj(at%N+1), adjncy(2*nedges) + + edge = 0 + do i = 1, at%N + xadj(i) = edge + nneighs = n_neighbours(at, i) + do j = 1, nneighs + edge = edge + 1 + adjncy(edge) = neighbour(at, i, j) + end do + end do + xadj(at%N+1) = nedges + + end subroutine atoms_to_csr_adjacency_matrix + + + subroutine kway_partition_atoms(at, k, nneightol, part, objval, status) + + ! Generate a balanced and connected partition of an atomic configuration using METIS' PartGraphKway method. + ! INPUT Atoms object at : configuration to be partitioned + ! INPUT integer k : number of partitions + ! OUTPUT integer array part, size at%N : partition array, assigning each atom of at to part i \in [1,k] + + implicit none + type(Atoms), intent(in) :: at + integer, intent(in) :: k + real(dp), intent(in) :: nneightol + integer, intent(out), dimension(:) :: part + integer, intent(out) :: objval, status + + integer :: nedges + integer(C_INT) :: nvert, ncon, nparts, c_status, c_objval + type(C_PTR) :: vwgt, vsize, adjwgt, tpwgts, ubvec + integer(C_INT), allocatable :: options(:), adjncy(:), xadj(:) + +#ifdef HAVE_METIS + integer(C_INT), allocatable :: cpart(:) + + allocate(options(0:40)) + c_status = METIS_SetDefaultOptions(options) + options(:) = -1 + options(METIS_OPTION_NUMBERING) = 1 ! METIS_OPTION_NUMBERING: fortran indexing + options(METIS_OPTION_NCUTS) = 5 ! number of different partitionings to compute (then choose the best edgecut) + options(METIS_OPTION_CONTIG) = 1 ! forces contiguous partitions + + nvert = at%n + ncon = 1 + ! from at create csr adjacency matrix + call preprocess_atoms_to_csr_adjacency_matrix(at, nneightol, nedges) + allocate(adjncy(2*nedges), xadj(at%n + 1), cpart(at%n)) + call atoms_to_csr_adjacency_matrix(at, nedges, xadj, adjncy) + + ! perform partitioning using METIS + vwgt = C_NULL_PTR + vsize = C_NULL_PTR + adjwgt = C_NULL_PTR + tpwgts = C_NULL_PTR + ubvec = C_NULL_PTR + + c_status = METIS_PartGraphKway(nvert, ncon, xadj, adjncy, vwgt, vsize, adjwgt, nparts, & + tpwgts, ubvec, options, c_objval, part) + + ! Copy output + objval = c_objval + status = c_status + if (size(cpart) > size(part)) then + part(:) = cpart + else + call system_abort('size of part array ('//(size(part))//') insufficient to store results') + end if + + deallocate(options, adjncy, cpart) +#else + call system_abort('kway_partition_atoms requires HAVE_METIS=1 at compile time') +#endif + + end subroutine kway_partition_atoms + + function submatrix(matrix, mask) + ! select submatrix choosing only rows and columns in mask. only works for square matrices + implicit none + integer, intent(in) :: matrix(:,:) + logical, intent(in) :: mask(:) + integer, allocatable :: submatrix(:,:), my_mask(:) + integer :: i + + if (size(matrix(1,:)) /= size(matrix(:,1)) .or. size(matrix(1,:)) /= size(mask)) then + write(*,*) "Inconsistent input, submatrix function now exiting..." + end if + do i = 1, size(mask) + if (mask(i)) then + my_mask(i) = i + else + my_mask(i) = 0 + end if + end do + submatrix = matrix(pack(my_mask, my_mask > 0), pack(my_mask, my_mask > 0)) + end function submatrix + + + function costG(dm, part, idx, kappa) + ! Calculate 'free energy' of region idx using distance matrix dm and assignment assign + ! kappa measures the relative importance of surface and 1/diameter components of G (arbitrarily) + integer, intent(in), dimension(:,:) :: dm + integer, intent(in), dimension(:) :: part + integer, intent(in) :: idx + real(dp), intent(in), optional :: kappa + logical :: mask(size(part)) + integer, allocatable :: sub_dm(:,:) + real(dp) :: costG, surface_energy, r, k + integer :: i, j + + k = 1.0 + if(present(kappa)) k = kappa + + mask = (part == idx) + sub_dm = submatrix(dm, mask) + surface_energy = sum(sub_dm**2) + + if (size(shape(sub_dm)) == 1) then + r = 1.0E-6_dp + else + r = maxval(sub_dm) / real(count(mask), dp)**2 + end if + costG = surface_energy + k/r + + end function costG + + + subroutine connect2subconnects(connect, nodelist, part, sub1, sub2, nodelist1, nodelist2, cut_edges) + implicit none + integer, intent(in) :: connect(:,:), nodelist(:) + logical, intent(in) :: part(:) + integer, intent(out), allocatable :: sub1(:,:), sub2(:,:), nodelist1(:), nodelist2(:), cut_edges(:,:) + integer, allocatable :: cut_edges_temp(:,:) + integer, dimension(size(nodelist)) :: part_mask1, part_mask2 + integer :: i, j, k, ncuts + + ! FIXME compiler doesn't like logical comparison +! if ((size(connect(1,:) /= size(nodelist)) .or. size(nodelist) /= size(part) & +! .or. size(connect(1,:)) /= size(part)) then +! call system_abort('inconsistent sizes for connectivity matrix, nodelist and part') +! end if + + do i = 1, size(part) + if (part(i)) then + part_mask1(i) = i + part_mask2(i) = 0 + else + part_mask1(i) = 0 + part_mask2(i) = i + end if + end do + + ! slice the connectivity matrix + sub1 = connect(pack(part_mask1, part_mask1 > 0), pack(part_mask1, part_mask1 > 0)) + sub2 = connect(pack(part_mask2, part_mask2 > 0), pack(part_mask2, part_mask2 > 0)) + ! also return list of nodes for each new subgraph + nodelist1 = nodelist(pack(part_mask1, part_mask1 > 0)) + nodelist2 = nodelist(pack(part_mask2, part_mask2 > 0)) + + ! number of edges is the sum of upper triangle "1"s + ncuts = (sum(connect) - sum(sub1) - sum(sub2)) / 2 + write(*,*) "number of cut edges:", ncuts + allocate(cut_edges_temp(ncuts, 2)) + ! find edges that are missing from the two new subgraphs + k = 1 + do i = 1, size(connect(1,:)) + do j = i+1, size(connect(1,:)) + if (connect(i,j) == 1) then + if (any(nodelist1 .eq. nodelist(i)) .and. any(nodelist2 .eq. nodelist(j))) then + cut_edges(k,:) = (/ nodelist(i), nodelist(j) /) + k = k +1 + end if + end if + end do + end do + cut_edges = cut_edges_temp + + deallocate(cut_edges_temp) + end subroutine connect2subconnects + + function region_neighbouring_atoms(connect, nodelist, part, which) + implicit none + integer, intent(in) :: connect(:,:), part(:), nodelist(:), which + integer, allocatable :: sub1(:,:), sub2(:,:), dummy1(:), dummy2(:), cut_edges(:,:) + integer, dimension(2) :: edge, regions + integer, allocatable :: neigh_temp(:,:), region_neighbouring_atoms(:,:) + integer i + ! generate a partition of the whole graph using part == which as the carving mask. + ! returns a list of cut edges + call connect2subconnects(connect, nodelist, part==which, & + sub1, sub2, dummy1, dummy2, cut_edges) + + allocate(neigh_temp(size(cut_edges(:,1)),3)) + do i = 1, size(cut_edges(:,1)) + edge = cut_edges(i,:) + regions = (/part(minloc(abs(nodelist - edge(1)), 1)), & + part(minloc(abs(nodelist - edge(2)), 1))/) + ! which region other node belongs to + if (regions(1) == which) then + neigh_temp(i,1) = regions(2) + else + neigh_temp(i,1) = regions(1) + end if + ! which edge + neigh_temp(i,2:3) = edge + end do + region_neighbouring_atoms = neigh_temp + + deallocate(neigh_temp) + end function region_neighbouring_atoms + + + subroutine partition_qm_list(at, k, nneightol, ripening, error) + + implicit none + type(Atoms), intent(inout) :: at + integer, intent(in) :: k + real(dp), intent(in) :: nneightol + logical, intent(in) :: ripening + integer, optional, intent(out) :: error + + type(Atoms) :: qm_at + integer, pointer :: hybrid_mark(:), orig_index(:), qm_cluster_ptr(:) + logical, allocatable :: my_hybrid_mask(:) + integer :: i, objval, status + integer, dimension(:), allocatable :: part + + INIT_ERROR(error) + + call assign_property_pointer(at, 'hybrid_mark', hybrid_mark, error) + PASS_ERROR(error) + + allocate(my_hybrid_mask(at%n)) + my_hybrid_mask = (hybrid_mark == HYBRID_ACTIVE_MARK) + + ! select qm region here. NB: qm_list is now qm_at%orig_index + call select(qm_at, at, mask=my_hybrid_mask, orig_index=.true.) + allocate(part(qm_at%N)) + + ! then generate the part vector (was called assign, unfortunate choice for a fortran code) + call kway_partition_atoms(qm_at, k, nneightol, part, objval, status) + + ! now try writing down the ripening stuff in fortran + + ! add property qm_cluster + call add_property(at, 'qm_cluster', 0, ptr=qm_cluster_ptr, overwrite=.true., error=error) + PASS_ERROR(error) + + ! zero padding qm_cluster property + do i = 1, at%N + qm_cluster_ptr(i) = 0 + end do + ! update values in qm region + + call assign_property_pointer(at, 'orig_index', orig_index, error) + PASS_ERROR(error) + + do i = 1, qm_at%N + qm_cluster_ptr(orig_index(i)) = part(i) + end do + + deallocate(part) + deallocate(my_hybrid_mask) + ! WARNING: this routine does not return medoids, which are anyway useless at the current stage of partitioning method + + end subroutine partition_qm_list + +end module partition_module diff --git a/src/libAtoms/ringstat.F90 b/src/libAtoms/ringstat.F90 new file mode 100644 index 0000000000..fd390b06c5 --- /dev/null +++ b/src/libAtoms/ringstat.F90 @@ -0,0 +1,469 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X Ring statistics module +!X +!% Functions to compute ring statistics according to +!% D.S. Franzblau, Phys. Rev. B 44, 4925 (1991) +!% +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +#include "error.inc" + +module ringstat_module + use error_module + use system_module, only : dp, operator(//) + use linearalgebra_module + use atoms_module + + implicit none + private + + public :: count_sp_rings, distance_map + +contains + + !% Look for the shortest distance starting at atom *root*, + !% look only for atoms where *mask* is true + subroutine find_shortest_distances(at, root, dist, mask, error) + implicit none + + type(Atoms), intent(in) :: at + integer, intent(in) :: root + integer, intent(out) :: dist(at%N) + logical, intent(in), optional :: mask(at%N) + integer, intent(out), optional :: error + + ! --- + + integer, parameter :: MAX_WALKER = 8192 + + ! --- + + integer :: i, ni, j, k + + integer :: n_walker + integer :: walker(MAX_WALKER) + + integer :: n_new_walker + integer :: new_walker(MAX_WALKER) + logical :: this_atom + + ! --- + + INIT_ERROR(error) + + n_walker = 1 + walker(1) = root + + do while (n_walker > 0) + + n_new_walker = 0 + + do k = 1, n_walker + i = walker(k) + +! do ni = nl%seed(i), nl%last(i) + do ni = 1, n_neighbours(at, i) +! j = nl%neighbors(ni) + j = neighbour(at, i, ni) + + this_atom = .true. + if (present(mask)) this_atom = mask(j) + + if (this_atom .and. dist(j) == 0 ) then + + n_new_walker = n_new_walker+1 + if (n_new_walker > MAX_WALKER) then + RAISE_ERROR("MAX_WALKER ("//MAX_WALKER//") exceeded.", error) + endif + + new_walker(n_new_walker) = j + + dist(j) = dist(i)+1 + + endif + + enddo + + enddo + + n_walker = n_new_walker + walker(1:n_walker) = new_walker(1:n_walker) + + enddo + + dist(root) = 0 + + endsubroutine find_shortest_distances + + + !% Look for the shortest distance starting at atom *root*, + !% look only for atoms where *mask* is true + subroutine distance_map(at, dist, mask, diameter, error) + implicit none + + type(Atoms), intent(in) :: at + integer, intent(out) :: dist(at%N, at%N) + logical, intent(in), optional :: mask(at%N) + integer, intent(out), optional :: diameter + integer, intent(out), optional :: error + + ! --- + + integer :: i + logical :: this_atom + + ! --- + + INIT_ERROR(error) + + if (present(diameter)) then + diameter = 0 + endif + + dist = 0 + + do i = 1, at%N + + this_atom = .true. + if (present(mask)) this_atom = mask(i) + + if (this_atom) then + + call find_shortest_distances(at, i, dist(:, i), mask, error) + PASS_ERROR(error) + + if (present(diameter)) then + diameter = max(diameter, maxval(dist(:, i))) + endif + + endif + enddo + + ! Check that matrix is symmetric + if (any(dist /= transpose(dist))) then + RAISE_ERROR("*dist* matrix not symmetric.", error) + endif + + endsubroutine distance_map + + + !% Look for the "shortest path" ring starting at atom *at*, + !% look only for atoms where *mask* is true + subroutine count_sp_rings(at, cutoff, dist, max_ring_len, stat, mask, rings_out, dr_out, error) + implicit none + + type(Atoms), intent(in) :: at + real(DP), intent(in) :: cutoff + integer, intent(in) :: dist(at%N, at%N) + integer, intent(in) :: max_ring_len + integer, intent(inout) :: stat(max_ring_len) + logical, intent(in), optional :: mask(at%N) + integer, intent(out), optional :: rings_out(:, :) + real(dp), intent(out), optional :: dr_out(:, :, :) + integer, intent(out), optional :: error + + ! --- + + integer, parameter :: MAX_WALKER = 16384 + + real(DP), parameter :: EPS = 0.0001_DP + + ! --- + + integer :: i, ni, j, k, m, n, a, na, b, dn + + real(DP) :: d(3), abs_dr_sq, cutoff_sq + + logical, allocatable :: done(:) + logical :: is_sp + + integer :: n_walker + integer :: walker(MAX_WALKER) + integer :: last(MAX_WALKER) + + integer :: ring_len(MAX_WALKER) + integer :: rings(max_ring_len, MAX_WALKER) + real(DP) :: dr(3, max_ring_len, MAX_WALKER) + + integer :: n_new_walker + integer :: new_walker(MAX_WALKER) + integer :: new_last(MAX_WALKER) + + integer :: new_ring_len(MAX_WALKER) + integer :: new_rings(max_ring_len, MAX_WALKER) + real(DP) :: new_dr(3, max_ring_len, MAX_WALKER) + + integer :: no(at%N), n_rings_out + + ! --- + +! allocate(done(at%connect%neighbour1%t%N+at%connect%neighbour2%t%N)) + + INIT_ERROR(error) + + if (present(rings_out)) then + if (size(rings_out,1) < max_ring_len+1) then + RAISE_ERROR('size(rings_out,1) < max_ring_len+1', error) + end if + if (.not. present(dr_out)) then + RAISE_ERROR('rings_out is present but dr_out is not', error) + end if + rings_out(:,:) = 0 + dr_out(:,:,:) = 0.0_dp + n_rings_out = 0 + end if + + cutoff_sq = cutoff**2 + + no(1) = 0 + do i = 2, at%N + no(i) = no(i-1) + n_neighbours(at, i-1) + enddo + + allocate(done(no(at%N) + n_neighbours(at, at%N))) + + done = .false. + + bonds_loop1: do a = 1, at%N + if ( .not. present(mask) .or. mask(a) ) then +! bonds_loop2: do na = nl%seed(a), nl%last(a) + bonds_loop2: do na = 1, n_neighbours(at, a) +! b = nl%neighbors(na) + b = neighbour(at, a, na) + + if ( a < b .and. ( .not. present(mask) .or. mask(b) ) ) then + + done(no(a)+na) = .true. +! do ni = nl%seed(b), nl%last(b) +! if (nl%neighbors(ni) == a) then +! done(ni) = .true. +! endif +! enddo + do ni = 1, n_neighbours(at, b) + if (neighbour(at, b, ni) == a) then + done(no(b)+ni) = .true. + endif + enddo + + n_walker = 1 + walker(1) = b + last(1) = a + + ring_len = 1 + rings(1, 1) = b +! dr(:, 1, 1) = GET_DRJ(p, nl, a, b, na) + b = neighbour(at, a, na, diff=dr(:, 1, 1)) + + while_walkers_exist: do while (n_walker > 0) + + n_new_walker = 0 + + do k = 1, n_walker + i = walker(k) + + if ( i > 0 ) then + +! ni_away_from_root_loop: do ni = nl%seed(i), nl%last(i) + ni_away_from_root_loop: do ni = 1, n_neighbours(at, i) + ni_away_from_root_if: if ( .not. done(no(i)+ni) ) then + +! DISTJ_SQ(p, nl, i, ni, j, d, abs_dr_sq) + j = neighbour(at, i, ni, diff=d) + abs_dr_sq = d .dot. d + + if ( abs_dr_sq < cutoff_sq .and. ( .not. present(mask) .or. mask(j) ) .and. j /= last(k) ) then + + if ( dist(j, a) == dist(i, a)+1 ) then + + if ( ring_len(k) < (max_ring_len-1)/2 ) then + + n_new_walker = n_new_walker+1 + if (n_new_walker > MAX_WALKER) then + RAISE_ERROR("MAX_WALKER ("//MAX_WALKER//") exceeded.", error) + endif + + new_walker(n_new_walker) = j + new_last(n_new_walker) = i + + new_rings(1:ring_len(k), n_new_walker) = rings(1:ring_len(k), k) + new_ring_len(n_new_walker) = ring_len(k)+1 + new_rings(new_ring_len(n_new_walker), n_new_walker) = j + + new_dr(:, 1:ring_len(k), n_new_walker) = dr(:, 1:ring_len(k), n_new_walker) + new_dr(:, new_ring_len(n_new_walker), n_new_walker) = dr(:, ring_len(k), k) + d + + endif + + else + + if ( dist(j, a) == dist(i, a) .or. dist(j, a) == dist(i, a)-1) then + + ! Reverse search direction + n_new_walker = n_new_walker+1 + if (n_new_walker > MAX_WALKER) then + RAISE_ERROR("MAX_WALKER ("//MAX_WALKER//") exceeded.", error) + endif + + new_walker(n_new_walker) = -j + new_last(n_new_walker) = i + + new_rings(1:ring_len(k), n_new_walker) = rings(1:ring_len(k), k) + new_ring_len(n_new_walker) = ring_len(k)+1 + new_rings(new_ring_len(n_new_walker), n_new_walker) = j + + new_dr(:, 1:ring_len(k), n_new_walker) = dr(:, 1:ring_len(k), k) + new_dr(:, new_ring_len(n_new_walker), n_new_walker) = dr(:, ring_len(k), k) + d + + else + + RAISE_ERROR("Something is wrong with the distance map.", error) + + endif + + endif + + endif + + endif ni_away_from_root_if + enddo ni_away_from_root_loop + + else + + i = -i + +! ni_towards_root_loop: do ni = nl%seed(i), nl%last(i) + ni_towards_root_loop: do ni = 1, n_neighbours(at, i) + ni_towards_root_if: if ( .not. done(no(i)+ni) ) then + +! DISTJ_SQ(p, nl, i, ni, j, d, abs_dr_sq) + j = neighbour(at, i, ni, diff=d) + abs_dr_sq = d .dot. d + + if ( abs_dr_sq < cutoff_sq .and. ( .not. present(mask) .or. mask(j) ) .and. j /= last(k) ) then + + if ( j == a ) then + + d = d + dr(:, ring_len(k), k) + + if ( dot_product(d, d) < EPS ) then + + ! Now we need to check whether this ring is SP + + is_sp = .true. + + ring_len(k) = ring_len(k)+1 + rings(ring_len(k), k) = a + + do m = 1, ring_len(k) + do n = m+2, ring_len(k) + + dn = n-m + if (dn > ring_len(k)/2) dn = ring_len(k)-dn + + if (dist(rings(n, k), rings(m, k)) /= dn) then + is_sp = .false. + endif + enddo + enddo + + if (is_sp) then + if (present(rings_out)) then + n_rings_out = n_rings_out + 1 + if (n_rings_out > size(rings_out,2)) then + RAISE_ERROR('Too many rings to store in rings_out', error) + end if + ! save atoms around the ring + rings_out(:, n_rings_out) = (/ring_len(k), rings(1:ring_len(k), k) /) + ! save displacement vectors around the ring + dr_out(:, 1:ring_len(k), n_rings_out) = dr(:, 1:ring_len(k), k) + end if + stat(ring_len(k)) = stat(ring_len(k))+1 + endif + + endif + + else if (dist(j, a) == dist(i, a)-1) then + + if (all(rings(1:ring_len(k), k) /= j)) then + + n_new_walker = n_new_walker+1 + if (n_new_walker > MAX_WALKER) then + RAISE_ERROR("MAX_WALKER ("//MAX_WALKER//") exceeded.", error) + endif + + new_walker(n_new_walker) = -j + new_last(n_new_walker) = i + + new_rings(1:ring_len(k), n_new_walker) = rings(1:ring_len(k), k) + new_ring_len(n_new_walker) = ring_len(k)+1 + new_rings(new_ring_len(n_new_walker), n_new_walker) = j + + new_dr(:, 1:ring_len(k), n_new_walker) = dr(:, 1:ring_len(k), k) + new_dr(:, new_ring_len(n_new_walker), n_new_walker) = dr(:, ring_len(k), k) + d + + endif + + endif + + endif + + endif ni_towards_root_if + enddo ni_towards_root_loop + + endif + enddo + + n_walker = n_new_walker + walker(1:n_walker) = new_walker(1:n_walker) + last(1:n_walker) = new_last(1:n_walker) + + ring_len(1:n_walker) = new_ring_len(1:n_walker) + rings(:, 1:n_walker) = new_rings(:, 1:n_walker) + + dr(:, :, 1:n_walker) = new_dr(:, :, 1:n_walker) + + enddo while_walkers_exist + + endif + + enddo bonds_loop2 + endif + enddo bonds_loop1 + + deallocate(done) + + endsubroutine count_sp_rings + +endmodule ringstat_module diff --git a/src/libAtoms/statistics.F90 b/src/libAtoms/statistics.F90 new file mode 100644 index 0000000000..77f87c1bea --- /dev/null +++ b/src/libAtoms/statistics.F90 @@ -0,0 +1,83 @@ +module statistics_module +use system_module, only : dp, PRINT_VERBOSE, PRINT_NORMAL, print, current_verbosity, operator(//) +implicit none +private + +public :: mean, variance + +public :: mean_var_decorrelated_err +interface mean_var_decorrelated_err + module procedure mean_var_decorrelated_err_r1 +end interface mean_var_decorrelated_err + +contains + +subroutine mean_var_decorrelated_err_r1(A, m, v, decorrelated_err, decorrelation_t) + real(dp) :: A(:) + real(dp), optional :: m, v, decorrelated_err, decorrelation_t + + integer :: bin_i, bin_size, n_bins, N + real(dp) :: A_mean, A_var, Nr, A_decorrelation_t + real(dp), allocatable :: binned_means(:) + real(dp) :: binned_means_var + real(dp) :: p_d_t, pp_d_t + logical :: found_max + + N = size(A) + Nr = N + + A_mean = mean(A) + if (present(m)) m = A_mean + if (present(v) .or. present(decorrelation_t) .or. present(decorrelated_err)) A_var = variance(A, A_mean) + if (present(v)) v = A_var + + found_max = .false. + p_d_t = -HUGE(1.0_dp) + pp_d_t = HUGE(1.0_dp) + if (present(decorrelation_t) .or. present(decorrelated_err)) then + bin_size = 1 + do while (bin_size <= N) + n_bins = N/bin_size + allocate(binned_means(n_bins)) + do bin_i=1, n_bins + binned_means(bin_i) = mean(A((bin_i-1)*bin_size+1:(bin_i-1)*bin_size+bin_size)) + end do + binned_means_var = variance(binned_means, mean(binned_means)) + deallocate(binned_means) + A_decorrelation_t = binned_means_var*real(bin_size,dp)/A_var + call print("bin_size " // bin_size // " decorrelation_t " // A_decorrelation_t, PRINT_VERBOSE) + if (A_decorrelation_t < p_d_t .and. p_d_t > pp_d_t) then + if (.not. found_max) then + if (present(decorrelation_t)) decorrelation_t = A_decorrelation_t + if (present(decorrelated_err)) decorrelated_err = sqrt(binned_means_var/real(n_bins,dp)) + found_max = .true. + endif + if (current_verbosity() <= PRINT_NORMAL) exit + endif + pp_d_t = p_d_t + p_d_t = A_decorrelation_t + if (bin_size == 1) then + bin_size = bin_size * 2 + else + bin_size = bin_size * 1.5 + endif + end do + end if + +end subroutine mean_var_decorrelated_err_r1 + +function mean(A) + real(dp), intent(in) :: A(:) + real(dp) :: mean + + mean = sum(A)/real(size(A),dp) +end function mean + +function variance(A, A_mean) + real(dp), intent(in) :: A(:), A_mean + real(dp) :: variance + + variance = sum((A-A_mean)**2)/real(size(A),dp) +end function variance + +end module statistics_module diff --git a/src/libAtoms/steinhardt_nelson_qw.F90 b/src/libAtoms/steinhardt_nelson_qw.F90 new file mode 100644 index 0000000000..d0d4d28764 --- /dev/null +++ b/src/libAtoms/steinhardt_nelson_qw.F90 @@ -0,0 +1,243 @@ +#include "error.inc" + +module steinhardt_nelson_qw_module + +use error_module +use system_module +use units_module +use dictionary_module +use atoms_types_module +use atoms_module +use linearalgebra_module +use angular_functions_module + +implicit none +private + +public :: calc_qw, calc_qw_grad + +contains + +subroutine calc_qw(this,l,do_q,do_w,cutoff,min_cutoff,cutoff_transition_width,mask,mask_neighbour,error) + type(atoms), intent(inout) :: this + integer, intent(in) :: l + logical, intent(in), optional :: do_q, do_w + real(dp), intent(in), optional :: cutoff, cutoff_transition_width, min_cutoff + logical, dimension(:), intent(in), optional :: mask, mask_neighbour + integer, intent(out), optional :: error + + real(dp), dimension(:), pointer :: ql, wl + real(dp), dimension(3) :: diff_ij + real(dp) :: ql_crystal, wl_crystal, my_cutoff, my_min_cutoff, my_cutoff_transition_width, r_ij, f_cut + logical :: my_do_q, my_do_w, do_smooth_cutoff + + complex(dp), dimension(:), allocatable :: spherical_c + complex(dp), dimension(:), allocatable :: spherical_c_crystal + integer :: i, j, m, n, m1, m2, m3 + real(dp) :: n_bonds, n_bonds_crystal + + INIT_ERROR(error) + + my_do_q = optional_default(.false.,do_q) + my_do_w = optional_default(.false.,do_w) + my_cutoff = optional_default(this%cutoff,cutoff) + my_min_cutoff = optional_default(0.0_dp,min_cutoff) + my_cutoff_transition_width = optional_default(0.0_dp,cutoff_transition_width) + + do_smooth_cutoff = present(cutoff_transition_width) + + if(my_cutoff > this%cutoff) then + call set_cutoff(this,my_cutoff) + call calc_connect(this) + endif + + if(my_do_q) call add_property(this, 'q'//l, 0.0_dp, ptr=ql) + if(my_do_w) call add_property(this, 'w'//l, 0.0_dp, ptr=wl) + + if(present(mask)) then + call check_size("mask",mask,this%N,"calc_qw",error) + endif + if(present(mask_neighbour)) then + call check_size("mask_neighbour",mask_neighbour,this%N,"calc_qw",error) + endif + + allocate(spherical_c(-l:l), spherical_c_crystal(-l:l)) + spherical_c_crystal = CPLX_ZERO + + f_cut = 1.0_dp + n_bonds_crystal = 0.0_dp + + do i = 1, this%N + + if(present(mask)) then + if( .not. mask(i) ) cycle + endif + + n_bonds = 0.0_dp + spherical_c = CPLX_ZERO + + do n = 1, n_neighbours(this,i) + j = neighbour(this,i,n,diff=diff_ij,distance=r_ij) + + if(r_ij > my_cutoff) cycle + if(r_ij < my_min_cutoff) cycle + + if(present(mask_neighbour)) then + if( .not. mask_neighbour(j) ) cycle + endif + + if(do_smooth_cutoff) then + f_cut = coordination_function(r_ij,my_cutoff,my_cutoff_transition_width) + endif + n_bonds = n_bonds + f_cut + + do m = -l, l + spherical_c(m) = spherical_c(m) + SphericalYCartesian(l,m,diff_ij) * f_cut + enddo + + enddo + + ! spherical_c_crystal is defined as in Steinhardt and Nelson, from ( \sum_i spherical_c(i) ) / ( \sum_i n_bonds(i)) + ! An altenative would be \sum_i ( spherical_c(i) / n_bonds(i) ) + spherical_c_crystal = spherical_c_crystal + spherical_c + n_bonds_crystal = n_bonds_crystal + n_bonds + + if(n_bonds > 0.0_dp) spherical_c = spherical_c / n_bonds + + if(my_do_q) ql(i) = sqrt( dot_product(spherical_c,spherical_c) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) + + if(my_do_w) then + wl(i) = 0.0_dp + do m1 = -l, l + do m2 = -l, l + m3 = -m1-m2 + if( m3 >= -l .and. m3 <= l ) wl(i) = wl(i) + spherical_c(m1) * spherical_c(m2) * spherical_c(m3) * wigner3j(l,m1,l,m2,l,m3) + enddo + enddo + + wl(i) = wl(i) / sqrt( dot_product(spherical_c,spherical_c)**3 ) + endif + + enddo + + if (n_bonds_crystal > 0.0_dp ) spherical_c_crystal = spherical_c_crystal / n_bonds_crystal + if (my_do_q) then + ql_crystal = sqrt( dot_product(spherical_c_crystal,spherical_c_crystal) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) + call set_value(this%params, "q"//l//"_global",ql_crystal) + endif + + if(my_do_w) then + wl_crystal = 0.0_dp + do m1 = -l, l + do m2 = -l, l + m3 = -m1-m2 + if( m3 >= -l .and. m3 <= l ) wl_crystal = wl_crystal + spherical_c_crystal(m1) * spherical_c_crystal(m2) * spherical_c_crystal(m3) * wigner3j(l,m1,l,m2,l,m3) + enddo + enddo + + wl_crystal = wl_crystal / sqrt( dot_product(spherical_c_crystal(:),spherical_c_crystal(:))**3 ) + call set_value(this%params, "w"//l//"_global",wl_crystal) + endif + + if(allocated(spherical_c)) deallocate(spherical_c) + if(allocated(spherical_c_crystal)) deallocate(spherical_c_crystal) + +endsubroutine calc_qw + +subroutine calc_qw_grad(this,grad_ind,l,do_q,do_w,cutoff,cutoff_transition_width) + type(atoms), intent(inout) :: this + integer, intent(in) :: grad_ind + integer, intent(in) :: l + logical, intent(in), optional :: do_q, do_w + real(dp), optional :: cutoff, cutoff_transition_width + + integer :: i, j, n, m + logical :: my_do_q, my_do_w, do_smooth_cutoff + real(dp) :: my_cutoff, my_cutoff_transition_width, ql + real(dp) :: f_cut, df_cut(3), r_ij, diff_ij(3), n_bonds + complex(dp), allocatable :: spherical_c(:), dspherical_c(:,:,:) + real(dp), allocatable :: dn_bonds(:,:) + real(dp), pointer :: ql_grad(:,:), wl_grad(:,:) + + my_do_q = optional_default(.false.,do_q) + my_do_w = optional_default(.false.,do_w) + my_cutoff = optional_default(this%cutoff,cutoff) + my_cutoff_transition_width = optional_default(0.0_dp,cutoff_transition_width) + + do_smooth_cutoff = present(cutoff_transition_width) + + if(my_cutoff > this%cutoff) then + call set_cutoff(this,my_cutoff) + call calc_connect(this) + endif + + if(my_do_q) call add_property(this, 'q'//l//'_grad', 0.0_dp, n_cols=3, ptr2=ql_grad) + if(my_do_w) call add_property(this, 'w'//l//'_grad', 0.0_dp, n_cols=3, ptr2=wl_grad) + + if (my_do_q) ql_grad = 0.0_dp + if (my_do_w) wl_grad = 0.0_dp + + allocate(spherical_c(-l:l), dspherical_c(3,-l:l,this%N), dn_bonds(3,this%N)) + spherical_c = CPLX_ZERO + dspherical_c = CPLX_ZERO + + f_cut = 1.0_dp + df_cut = 0.0_dp + + n_bonds = 0.0_dp + dn_bonds = 0.0_dp + + i = grad_ind + do n = 1, n_neighbours(this,i) + j = neighbour(this,i,n,diff=diff_ij,distance=r_ij) + + if(r_ij > my_cutoff) cycle + + if(do_smooth_cutoff) then + f_cut = coordination_function(r_ij,my_cutoff,my_cutoff_transition_width) + df_cut(:) = -dcoordination_function(r_ij,my_cutoff,my_cutoff_transition_width)*diff_ij/r_ij + endif + n_bonds = n_bonds + f_cut + dn_bonds(:,i) = dn_bonds(:,i) + df_cut(:) + dn_bonds(:,j) = dn_bonds(:,j) - df_cut(:) + + do m = -l, l + spherical_c(m) = spherical_c(m) + SphericalYCartesian(l,m,diff_ij) * f_cut + dspherical_c(:,m,i) = dspherical_c(:,m,i) - GradSphericalYCartesian(l,m,diff_ij) * f_cut + & + SphericalYCartesian(l,m,diff_ij)*df_cut + dspherical_c(:,m,j) = dspherical_c(:,m,j) + GradSphericalYCartesian(l,m,diff_ij) * f_cut - & + SphericalYCartesian(l,m,diff_ij)*df_cut + enddo + enddo + + if(n_bonds > 0.0_dp) then + do m=-l,l + dspherical_c(:,m,i) = ((n_bonds*dspherical_c(:,m,i))-(spherical_c(m)*dn_bonds(:,i))) / (n_bonds**2) + do n = 1, n_neighbours(this,i) + j = neighbour(this,i,n) + dspherical_c(:,m,j) = ((n_bonds*dspherical_c(:,m,j))-(spherical_c(m)*dn_bonds(:,j))) / (n_bonds**2) + end do + end do + spherical_c(:) = spherical_c(:) / n_bonds + end if + + if(my_do_q) then + ql = sqrt( dot_product(spherical_c(:),spherical_c(:)) * 4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) + do m=-l,l + ql_grad(:,i) = ql_grad(:,i) + (1.0_dp/ql)*spherical_c(m)*conjg(dspherical_c(:,m,i)) * (4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) + do n = 1, n_neighbours(this,i) + j = neighbour(this,i,n) + ql_grad(:,j) = ql_grad(:,j) + (1.0_dp/ql)*spherical_c(m)*conjg(dspherical_c(:,m,j)) * (4.0_dp * PI / (2.0_dp * l + 1.0_dp) ) + end do + end do + endif + + if(my_do_w) then + call system_abort("calc_qw_grad does not support grad of w yet") + endif + +end subroutine calc_qw_grad + +end module steinhardt_nelson_qw_module + + diff --git a/src/libAtoms/task_manager.F90 b/src/libAtoms/task_manager.F90 new file mode 100644 index 0000000000..e395bdc6fb --- /dev/null +++ b/src/libAtoms/task_manager.F90 @@ -0,0 +1,358 @@ +module task_manager_module + !> A task manager determines the distribution of tasks to workers with + !> respect to the tasks' demands. + !> + !> Each task stores integer data in %idata. + !> %idata(1) is used for distribution. + !> + !> The special %worker_id=SHARED is used for shared tasks. Each worker + !> has a local entry with local %idata. %idata(1) contains the local + !> size, %idata(2) contains the global offset. + + use libatoms_module, only : initialise, finalise, print_title, print, & + operator(//), system_abort, inoutput, optional_default, OUTPUT, PRINT_VERBOSE + use linearalgebra_module, only : insertion_sort + use MPI_context_module, only : MPI_Context, print + use ScaLAPACK_module, only : Scalapack, print + + implicit none + private + + public :: task_manager_type, task_type, worker_type, SHARED + public :: task_manager_init_tasks, task_manager_init_workers, task_manager_deallocate + public :: task_manager_init_idata + public :: task_manager_add_task, task_manager_add_worker + public :: task_manager_distribute_tasks, task_manager_check_distribution + public :: task_manager_print, task_manager_export_distribution + + integer, parameter :: UNDEFINED = -1 + integer, parameter :: SHARED = 0 + + type task_type + integer :: index = UNDEFINED !> initial task index + integer, dimension(:), allocatable :: idata !> integer data for this task + integer :: worker_id = UNDEFINED !> ID of worker assigned to this task + end type task_type + + type worker_type + integer :: index = UNDEFINED !> initial worker index + integer :: n_tasks = 0 !> number of tasks assigned to this worker + integer :: n_padding = 0 !> number of padding rows to reach unified workload + type(task_type), dimension(:), allocatable :: tasks !> tasks assigned to this worker + end type worker_type + + type task_manager_type + logical :: active = .false. !> whether task manager is used + logical :: distributed = .false. !> whether tasks have been distributed + integer :: my_worker_id = 0 !> compute only tasks for this worker + integer :: unified_workload = 0 !> highest workload among workers, target for padding + + integer :: n_tasks = 0 !> number of tasks + integer :: n_workers = 0 !> number of workers + integer :: n_shared = 0 !> number of shared tasks + + integer, dimension(:), allocatable :: idata !< custom shared integer data + + type(MPI_Context) :: MPI_obj + type(ScaLAPACK) :: ScaLAPACK_obj + + type(task_type), dimension(:), allocatable :: tasks !> tasks to compute + type(worker_type), dimension(:), allocatable :: workers !> workers to compute tasks + end type task_manager_type + + contains + + !> Add task to list + subroutine task_manager_add_task(this, idata1, n_idata, worker_id) + type(task_manager_type), intent(inout) :: this + integer, intent(in), optional :: idata1 !> first idata entry for new task + integer, intent(in), optional :: n_idata !> number of idata entries for new task + integer, intent(in), optional :: worker_id !> preset worker for this task + + integer :: my_n_idata + + if (.not. this%active) return + my_n_idata = optional_default(1, n_idata) + + this%n_tasks = this%n_tasks + 1 + if (this%n_tasks > size(this%tasks)) call system_abort("More tasks added than allocated.") + associate(task => this%tasks(this%n_tasks)) + allocate(task%idata(my_n_idata)) + task%idata = UNDEFINED + task%index = this%n_tasks + if (present(idata1)) task%idata(1) = idata1 + if (present(worker_id)) task%worker_id = worker_id + end associate + end subroutine task_manager_add_task + + !> Add worker to list + subroutine task_manager_add_worker(this) + type(task_manager_type), intent(inout) :: this + + if (.not. this%active) return + + this%n_workers = this%n_workers + 1 + if (this%n_workers > size(this%workers)) call system_abort("More workers added than allocated.") + associate(worker => this%workers(this%n_workers)) + worker%index = this%n_workers + worker%n_tasks = 0 + end associate + end subroutine task_manager_add_worker + + !> @brief Distribute tasks among workers for minimal idata(1) usage + subroutine task_manager_distribute_tasks(this) + type(task_manager_type), intent(inout) :: this + + integer :: i, t, w ! indices + integer :: n + integer, dimension(:), allocatable :: workloads + integer, dimension(:), allocatable :: idata1_list + integer, dimension(:), allocatable :: index_list + + if (.not. this%active) return + if (this%n_tasks < 1) return + if (this%n_workers < 1) call system_abort("task_manager_distribute_tasks: No workers initialised.") + + allocate(workloads(this%n_workers)) + allocate(idata1_list(this%n_tasks)) + allocate(index_list(this%n_tasks)) + + ! copy to temp arrays, sort both by idata1 + do i = 1, this%n_tasks + if (.not. allocated(this%tasks(i)%idata)) call system_abort("task_manager_distribute_tasks: idata of task "//i//" is unallocated.") + idata1_list(i) = this%tasks(i)%idata(1) + index_list(i) = this%tasks(i)%index + end do + call insertion_sort(idata1_list, i_data=index_list) ! stable sort for easier testing + + ! count workload of preset tasks + workloads = 0 + do t = 1, this%n_tasks + i = index_list(t) + w = this%tasks(i)%worker_id + if (w >= 1) then + this%workers(w)%n_tasks = this%workers(w)%n_tasks + 1 + workloads(w) = workloads(w) + idata1_list(t) + end if + end do + + ! distribute tasks to workers to minimize maximum idata1 sum + do t = this%n_tasks, 1, -1 + i = index_list(t) + if (this%tasks(i)%worker_id /= UNDEFINED) cycle ! skip preset tasks + w = minloc(workloads, 1) + this%tasks(i)%worker_id = w + this%workers(w)%n_tasks = this%workers(w)%n_tasks + 1 + workloads(w) = workloads(w) + idata1_list(t) + end do + + this%unified_workload = maxval(workloads) + + ! fill workers with task id lists (replication for simpler retrieval) + this%n_shared = count(this%tasks(:)%worker_id == SHARED) + do w = 1, this%n_workers + n = this%workers(w)%n_tasks + this%n_shared + allocate(this%workers(w)%tasks(n)) + this%workers(w)%n_tasks = 0 + end do + do t = 1, this%n_tasks + w = this%tasks(t)%worker_id + if (w < 1) cycle + n = this%workers(w)%n_tasks + 1 + this%workers(w)%tasks(n) = this%tasks(t) + this%workers(w)%n_tasks = n + end do + + do w = 1, this%n_workers + this%workers(w)%n_padding = this%unified_workload - workloads(w) + end do + + call task_manager_distribute_shared_tasks(this) + + this%distributed = .true. + end subroutine task_manager_distribute_tasks + + subroutine task_manager_distribute_shared_tasks(this) + ! fill padding first, then distribute rows evenly + type(task_manager_type), intent(inout) :: this + + integer :: n, t, w + integer :: rest, n_split, n_extra, n_plus, offset + + if (.not. this%active) return + + do t = 1, this%n_tasks + if (this%tasks(t)%worker_id /= SHARED) cycle + + rest = max(this%tasks(t)%idata(1) - sum(this%workers(:)%n_padding), 0) + n_split = rest / this%n_workers + n_extra = mod(rest, this%n_workers) + n_plus = n_split + if (n_extra > 0) n_plus = n_split + 1 + + rest = this%tasks(t)%idata(1) + offset = 0 + do w = 1, this%n_workers + n = this%workers(w)%n_tasks + 1 + associate(worker => this%workers(w), w_task => this%workers(w)%tasks(n)) + call task_deepcopy(w_task, this%tasks(t)) + + w_task%idata(1) = worker%n_padding + n_split + if (w <= n_extra) w_task%idata(1) = w_task%idata(1) + 1 + w_task%idata(1) = min(w_task%idata(1), rest) + w_task%idata(2) = offset + worker%n_padding = worker%n_padding + n_plus - w_task%idata(1) + + rest = rest - w_task%idata(1) + offset = offset + w_task%idata(1) + worker%n_tasks = n + end associate + end do + this%unified_workload = this%unified_workload + n_plus + end do + end subroutine task_manager_distribute_shared_tasks + + subroutine task_manager_check_distribution(this) + type(task_manager_type), intent(in) :: this + + integer :: tmp + + if (.not. this%active) return + if (.not. this%distributed) return + + tmp = task_manager_get_max_idata1_sum(this) + if (tmp /= this%unified_workload) call system_abort("task_manager_check_distribution: unified_workload is inconsistent: "//tmp//" "//this%unified_workload) + if (any(this%workers(:)%n_padding < 0)) call system_abort("task_manager_check_distribution: negative padding: "//this%workers(:)%n_padding) + end subroutine task_manager_check_distribution + + subroutine task_manager_show_distribution(this) + type(task_manager_type), intent(in) :: this + + integer :: i, t, w, idata1_sum, n_tasks + + if (.not. this%active) return + + do w = 1, this%n_workers + call print("Tasks of worker "//w) + idata1_sum = 0 + n_tasks = 0 + do i = 1, this%workers(w)%n_tasks + t = this%workers(w)%tasks(i)%index + call print(i // ": " // t // ": " // this%workers(w)%tasks(i)%idata) + idata1_sum = idata1_sum + this%tasks(t)%idata(1) + end do + call print("Summary: "//this%workers(w)%n_tasks//" tasks, "//idata1_sum//" idata1_sum, "//this%workers(w)%n_padding//" padding") + end do + end subroutine task_manager_show_distribution + + subroutine task_manager_export_distribution(this, only_id) + type(task_manager_type), intent(in) :: this + integer, optional :: only_id !> only this worker writes distribution + + integer :: i, t, w + integer :: only_id_opt + type(Inoutput) :: file + + if (.not. this%active) return + only_id_opt = optional_default(UNDEFINED, only_id) + if (only_id_opt >= 0 .and. only_id_opt /= this%my_worker_id) return + + call initialise(file, "tm.dist", OUTPUT) + call print("worker_id task_id_local task_id_global idata", file=file) + do w = 1, this%n_workers + do i = 1, this%workers(w)%n_tasks + t = this%workers(w)%tasks(i)%index + call print(w // " " // i // " " // t // " " // this%workers(w)%tasks(i)%idata, file=file) + end do + end do + call finalise(file) + end subroutine task_manager_export_distribution + + subroutine task_manager_init_tasks(this, n_tasks) + type(task_manager_type), intent(inout) :: this + integer, intent(in) :: n_tasks !> number of tasks to allocate + + if (.not. this%active) return + + call print("Allocate task_manager%tasks for "//n_tasks//" tasks.", PRINT_VERBOSE) + allocate(this%tasks(n_tasks)) + end subroutine task_manager_init_tasks + + subroutine task_manager_init_workers(this, n_workers) + type(task_manager_type), intent(inout) :: this + integer, intent(in) :: n_workers !> number of workers to allocate and set + + integer :: w + + if (.not. this%active) return + + allocate(this%workers(n_workers)) + do w = 1, n_workers + call task_manager_add_worker(this) + end do + end subroutine task_manager_init_workers + + subroutine task_manager_init_idata(this, n_idata) + type(task_manager_type), intent(inout) :: this + integer, intent(in) :: n_idata + + if (.not. this%active) return + + allocate(this%idata(n_idata)) + end subroutine task_manager_init_idata + + subroutine task_manager_deallocate(this) + type(task_manager_type), intent(inout) :: this + + this%distributed = .false. + this%n_tasks = 0 + this%n_workers = 0 + if (allocated(this%idata)) deallocate(this%idata) + if (allocated(this%tasks)) deallocate(this%tasks) + if (allocated(this%workers)) deallocate(this%workers) + end subroutine task_manager_deallocate + + subroutine task_manager_print(this) + type(task_manager_type), intent(inout) :: this + + call print_title('task_manager_type') + call print("%active: "//this%active) + call print("%my_worker_id: "//this%my_worker_id) + call print("%distributed: "//this%distributed) + call print("%unified_workload: "//this%unified_workload) + call print("%n_tasks: "//this%n_tasks) + call print("%n_workers: "//this%n_workers) + call print_title('MPI_obj') + call print(this%MPI_obj) + call print_title('ScaLAPACK_obj') + call print(this%ScaLAPACK_obj) + call print_title('task distrubtion') + call task_manager_show_distribution(this) + call print_title('') + end subroutine task_manager_print + + function task_manager_get_max_idata1_sum(this) result(res) + type(task_manager_type), intent(in) :: this + + integer :: res + integer :: n, t, w + + if (.not. this%active) return + + res = 0 + do w = 1, this%n_workers + n = sum([(this%workers(w)%tasks(t)%idata(1), t = 1, this%workers(w)%n_tasks)]) + res = max(n, res) + end do + end function task_manager_get_max_idata1_sum + + subroutine task_deepcopy(this, from) + type(task_type), intent(inout) :: this + type(task_type), intent(in) :: from + + this%index = from%index + allocate(this%idata, source=from%idata) + this%worker_id = from%worker_id + end subroutine task_deepcopy + +end module task_manager_module diff --git a/src/libAtoms/test_gamma.F90 b/src/libAtoms/test_gamma.F90 new file mode 100644 index 0000000000..7d8869a893 --- /dev/null +++ b/src/libAtoms/test_gamma.F90 @@ -0,0 +1,76 @@ +program test_gamma + + use gamma_module + + implicit none + integer, parameter :: n_a = 5 + integer, parameter :: n_x = 9 + integer :: i, j, k + real(dp) :: a(n_a), x(n_x), gamma_mathematica(n_a*n_x) + + a = (/ 1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp /) + x = (/ 0.0_dp, 1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp, 6.0_dp, 7.0_dp, 8.0_dp /) + gamma_mathematica = (/ & + 1.00000000000000e0_dp, & + 3.67879441171442e-1_dp, & + 1.35335283236613e-1_dp, & + 4.9787068367864e-2_dp, & + 1.83156388887342e-2_dp, & + 6.73794699908547e-3_dp, & + 2.47875217666636e-3_dp, & + 9.11881965554516e-4_dp, & + 3.35462627902512e-4_dp, & + 1.00000000000000e0_dp, & + 7.35758882342885e-1_dp, & + 4.06005849709838e-1_dp, & + 1.99148273471456e-1_dp, & + 9.15781944436709e-2_dp, & + 4.04276819945128e-2_dp, & + 1.73512652366645e-2_dp, & + 7.29505572443613e-3_dp, & + 3.01916365112261e-3_dp, & + 2.00000000000000e0_dp, & + 1.83939720585721e0_dp, & + 1.35335283236613e0_dp, & + 8.46380162253687e-1_dp, & + 4.76206611107089e-1_dp, & + 2.49304038966162e-1_dp, & + 1.23937608833318e-1_dp, & + 5.92723277610436e-2_dp, & + 2.7507935488006e-2_dp, & + 6.0000000000000e0_dp, & + 5.88607105874308e0_dp, & + 5.14274076299128e0_dp, & + 3.88339133269339e0_dp, & + 2.60082072220025e0_dp, & + 1.59015549178417e0_dp, & + 9.07223296659887e-1_dp, & + 4.9059249746833e-1_dp, & + 2.54280671950104e-1_dp, & + 2.40000000000000e1_dp, & + 2.39121636761438e1_dp, & + 2.27363275837509e1_dp, & + 1.95663178685705e1_dp, & + 1.5092086444317e1_dp, & + 1.05718388415651e1_dp, & + 6.84135600759915e0_dp, & + 4.15179858916971e0_dp, & + 2.39117761168911e0_dp/) + + !print*,'TESTING GAMMA FUNCTION - GFORTRAN ONLY' + !do i = 1, n_a + ! print*, a(i), exp(ln_gamma(a(i))), gamma(a(i)), abs(exp(ln_gamma(a(i)))-gamma(a(i))) + !enddo + + print*,'TESTING INCOMPLETE GAMMA FUNCTION - Mathematica results' + print'(2a10,2a25,a14)','a','x','Gamma(a,x) Mathematica','Gamma(a,x) Current','Delta' + k = 0 + do i = 1, n_a + do j = 1, n_x + k = k + 1 + print'(2f10.6,2e25.15,e14.5)',a(i),x(j),gamma_mathematica(k),gamma_incomplete_upper(a(i),x(j)), & + abs(gamma_mathematica(k)-gamma_incomplete_upper(a(i),x(j))) + enddo + enddo + +endprogram test_gamma From 31d1e2d43dbccdac0af5d8260aff3384fa59474c Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 18:16:08 +0100 Subject: [PATCH 11/47] renamed source files to have F90 extension --- src/Structure_processors/UI_integrate.F90 | 77 + src/Structure_processors/angle_distr.F90 | 907 +++++++++++ src/Structure_processors/clean_traj.F90 | 117 ++ src/Structure_processors/convert.F90 | 72 + .../coordination_number.F90 | 300 ++++ src/Structure_processors/decimate.F90 | 76 + src/Structure_processors/density.F90 | 326 ++++ src/Structure_processors/density_1d.F90 | 633 ++++++++ src/Structure_processors/density_KDE.F90 | 701 +++++++++ src/Structure_processors/density_new.F90 | 792 ++++++++++ src/Structure_processors/diffusion.F90 | 168 ++ src/Structure_processors/elastic_fields.F90 | 106 ++ src/Structure_processors/extract_EVB.F90 | 227 +++ src/Structure_processors/extract_cv.F90 | 288 ++++ src/Structure_processors/file_rewrite.F90 | 97 ++ src/Structure_processors/find_space_minim.F90 | 291 ++++ .../histogram_process.F90 | 326 ++++ .../make_bulk_supercell.F90 | 38 + src/Structure_processors/make_k_mesh.F90 | 39 + .../make_surface_slab_vasp.F90 | 319 ++++ src/Structure_processors/mean_var_correl.F90 | 797 ++++++++++ .../mean_var_decorrelated_err.F90 | 42 + src/Structure_processors/merge_traj.F90 | 102 ++ .../move_displacement_field.F90 | 122 ++ src/Structure_processors/msd_vibrations.F90 | 131 ++ src/Structure_processors/rdfd.F90 | 323 ++++ src/Structure_processors/rings.F90 | 109 ++ src/Structure_processors/solvate.F90 | 177 +++ src/Structure_processors/solvate_silica.F90 | 257 +++ .../structure_analysis_traj.F90 | 1400 +++++++++++++++++ src/Structure_processors/test_ran.F90 | 93 ++ src/Structure_processors/xyz2pdb.F90 | 329 ++++ .../xyz2residue_library.F90 | 56 + 33 files changed, 9838 insertions(+) create mode 100644 src/Structure_processors/UI_integrate.F90 create mode 100644 src/Structure_processors/angle_distr.F90 create mode 100644 src/Structure_processors/clean_traj.F90 create mode 100644 src/Structure_processors/convert.F90 create mode 100644 src/Structure_processors/coordination_number.F90 create mode 100644 src/Structure_processors/decimate.F90 create mode 100644 src/Structure_processors/density.F90 create mode 100644 src/Structure_processors/density_1d.F90 create mode 100644 src/Structure_processors/density_KDE.F90 create mode 100644 src/Structure_processors/density_new.F90 create mode 100644 src/Structure_processors/diffusion.F90 create mode 100644 src/Structure_processors/elastic_fields.F90 create mode 100644 src/Structure_processors/extract_EVB.F90 create mode 100644 src/Structure_processors/extract_cv.F90 create mode 100644 src/Structure_processors/file_rewrite.F90 create mode 100644 src/Structure_processors/find_space_minim.F90 create mode 100644 src/Structure_processors/histogram_process.F90 create mode 100644 src/Structure_processors/make_bulk_supercell.F90 create mode 100644 src/Structure_processors/make_k_mesh.F90 create mode 100644 src/Structure_processors/make_surface_slab_vasp.F90 create mode 100644 src/Structure_processors/mean_var_correl.F90 create mode 100644 src/Structure_processors/mean_var_decorrelated_err.F90 create mode 100644 src/Structure_processors/merge_traj.F90 create mode 100644 src/Structure_processors/move_displacement_field.F90 create mode 100755 src/Structure_processors/msd_vibrations.F90 create mode 100644 src/Structure_processors/rdfd.F90 create mode 100644 src/Structure_processors/rings.F90 create mode 100644 src/Structure_processors/solvate.F90 create mode 100644 src/Structure_processors/solvate_silica.F90 create mode 100644 src/Structure_processors/structure_analysis_traj.F90 create mode 100755 src/Structure_processors/test_ran.F90 create mode 100644 src/Structure_processors/xyz2pdb.F90 create mode 100644 src/Structure_processors/xyz2residue_library.F90 diff --git a/src/Structure_processors/UI_integrate.F90 b/src/Structure_processors/UI_integrate.F90 new file mode 100644 index 0000000000..25d8718131 --- /dev/null +++ b/src/Structure_processors/UI_integrate.F90 @@ -0,0 +1,77 @@ +program UI_integrate +use libatoms_module +implicit none + type(InOutput) :: io + integer :: N, n_lines + real(dp), allocatable :: v(:), v_err(:), f(:), f_err(:), f_int(:), f_int_err_sq(:) + real(dp) :: t_err_sq + character(len=256), allocatable :: line_array(:) + integer :: i, i_zero + + call system_initialise(verbosity=PRINT_SILENT) + call verbosity_push(PRINT_NORMAL) + + call initialise(io, "stdin") + call read_file(io, line_array, n_lines) + call finalise(io) + allocate(v(n_lines+1)) + allocate(v_err(n_lines+1)) + allocate(f(n_lines+1)) + allocate(f_err(n_lines+1)) + allocate(f_int(n_lines+1)) + allocate(f_int_err_sq(n_lines+1)) + N=n_lines + do i=1, N + read (unit=line_array(i), fmt=*) v(i), v_err(i), f(i), f_err(i) + end do + i_zero = 1 + do i=2, N + if (f(i-1)*f(i) < 0) then ! force changed sign, must have crossed 0 here + v(i+1:n+1) = v(i:n) + v_err(i+1:n+1) = v_err(i:n) + f(i+1:n+1) = f(i:n) + f_err(i+1:N+1) = f_err(i:N) + + v(i) = v(i-1)*f(i+1)/(f(i+1)-f(i-1)) - v(i+1)*f(i-1)/(f(i+1)-f(i-1)) + v_err(i) = Sqrt((f(i+1)**2*v_err(i-1)**2)/(-f(i-1) + f(i+1))**2 + & + f_err(i+1)**2*(-((f(i+1)*v(i-1))/(-f(i-1) + f(i+1))**2) + v(i-1)/(-f(i-1) + f(i+1)) + & + (f(i-1)*v(i+1))/(-f(i-1) + f(i+1))**2)**2 + f_err(i-1)**2*((f(i+1)*v(i-1))/(-f(i-1) + f(i+1))**2 & + - (f(i-1)*v(i+1))/(-f(i-1) + f(i+1))**2 - v(i+1)/(-f(i-1) + f(i+1)))**2 + & + (f(i-1)**2*v_err(i+1)**2)/(-f(i-1) + f(i+1))**2) + + f(i) = 0.0_dp + f_err(i) = Sqrt((f(i+1)**2*f_err(i-1)**2)/(-f(i-1) + f(i+1))**2 + & + f_err(i+1)**2*(-((f(i+1)*f(i-1))/(-f(i-1) + f(i+1))**2) + f(i-1)/(-f(i-1) + f(i+1)) + & + (f(i-1)*f(i+1))/(-f(i-1) + f(i+1))**2)**2 + f_err(i-1)**2*((f(i+1)*f(i-1))/(-f(i-1) + f(i+1))**2 & + - (f(i-1)*f(i+1))/(-f(i-1) + f(i+1))**2 - f(i+1)/(-f(i-1) + f(i+1)))**2 + & + (f(i-1)**2*f_err(i+1)**2)/(-f(i-1) + f(i+1))**2) + + i_zero = i + N = N+1 + exit + endif + end do + + f_int(i_zero) = 0.0_dp + f_int_err_sq(i_zero) = 0.0_dp + do i=i_zero-1, 1, -1 + f_int(i) = f_int(i+1) - (v(i+1)-v(i))*(f(i+1)+f(i))/2.0_dp + t_err_sq = ((f(i+1)+f(i))/2.0_dp)**2*v_err(i+1)**2 + ((f(i+1)+f(i))/2.0_dp)**2*v_err(i)**2 + & + ((v(i+1)-v(i))/2.0_dp)**2*f_err(i+1)**2 + ((v(i+1)-v(i))/2.0_dp)**2*f_err(i)**2 + f_int_err_sq(i) = f_int_err_sq(i+1) + t_err_sq + end do + do i=i_zero, N-1 + f_int(i+1) = f_int(i) + (v(i+1)-v(i))*(f(i+1)+f(i))/2.0_dp + t_err_sq = ((f(i+1)+f(i))/2.0_dp)**2*v_err(i+1)**2 + ((f(i+1)+f(i))/2.0_dp)**2*v_err(i)**2 + & + ((v(i+1)-v(i))/2.0_dp)**2*f_err(i+1)**2 + ((v(i+1)-v(i))/2.0_dp)**2*f_err(i)**2 + f_int_err_sq(i+1) = f_int_err_sq(i) + t_err_sq + end do + + call print("# col_val err grad_val err int_val err") + do i=1, N + call print(v(i)//" "//v_err(i)//" "//f(i)//" "//f_err(i)//" "//f_int(i)//" "//sqrt(f_int_err_sq(i))) + end do + + call verbosity_pop() + call system_finalise() +end program UI_integrate diff --git a/src/Structure_processors/angle_distr.F90 b/src/Structure_processors/angle_distr.F90 new file mode 100644 index 0000000000..32f7723088 --- /dev/null +++ b/src/Structure_processors/angle_distr.F90 @@ -0,0 +1,907 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! Calculates angle distribution in a radial mesh +! with error bars +! outputs: angle (1) O-O distance (A) distance from origin (A) angle distribution (arb.units) + +program angle_distr +use libatoms_module +implicit none + + type(Dictionary) :: cli_params + character(len=STRING_LENGTH) :: infilename + logical :: infile_is_list + character(len=STRING_LENGTH) :: outfilename + type(Inoutput) :: outfile + character(len=STRING_LENGTH) :: commandfilename + type(Inoutput) :: commandfile + character(len=1024) :: args_str + + character(len=STRING_LENGTH) :: mask_str + character(len=STRING_LENGTH) :: mask_center + integer :: decimation + real(dp) :: min_time, max_time + logical :: gaussian_smoothing + real(dp) :: gaussian_sigma + real(dp) :: sampling_sigma + real(dp) :: gaussian_angle_sigma + logical :: radial_histo, random_samples + logical :: do_distance_dependence + integer :: n_samples(2) + integer :: nth_snapshots + logical :: sort_Time, no_Time_dups + real(dp) :: min_p(3), bin_width(3) + integer :: n_bins(3) + logical :: quiet + logical :: autocorrelation, mean + integer :: autocorrelation_max_lag + real(dp) :: mean_decorrelation_time + logical :: have_params + integer :: status, arg_line_no + + logical :: no_compute_index + integer :: n_histos + type(Atoms_ll) :: structure_ll + real(dp), allocatable :: histo_raw(:,:,:,:), histo_mean(:,:,:), histo_var(:,:,:) + integer :: i_lag, i1, i2, i3 + real(dp), allocatable :: autocorr(:,:,:,:) + real(dp) :: m_bin_width + + real(dp) :: part_dens, cell_vol + + call system_initialise(PRINT_VERBOSE) + + call initialise(cli_params) + call register_cli_params(cli_params,.true., infilename, infile_is_list, outfilename, commandfilename, & + mask_str, mask_center, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & + radial_histo, random_samples, n_samples, do_distance_dependence, nth_snapshots, & + sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) + if (.not. param_read_args(cli_params)) then + call print_usage() + call system_abort('could not parse argument line') + end if + + call print("Reading configurations") + no_compute_index=.false. + if ((.not. sort_Time) .and. (.not. no_Time_dups)) no_compute_index=.true. + call read_xyz(structure_ll, infilename, infile_is_list, decimation, min_time, max_time, sort_Time, no_Time_dups, quiet, no_compute_index) + + if (len_trim(commandfilename) == 0) then + args_str = param_write_string(cli_params) + call finalise(cli_params) + else + call finalise(cli_params) + call print("reading commands from file '"//trim(commandfilename)//"'") + call initialise(commandfile, trim(commandfilename), INPUT) + arg_line_no = 1 + args_str = read_line(commandfile) + call initialise(cli_params) + call print("got arguments line '"//trim(args_str)//"'") + call register_cli_params(cli_params,.false., infilename, infile_is_list, outfilename, commandfilename, & + mask_str, mask_center, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & + radial_histo, random_samples, n_samples, do_distance_dependence, nth_snapshots, & + sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) + if (.not. param_read_line(cli_params, trim(args_str), ignore_unknown = .true.)) then + call print_usage() + call system_abort("could not parse argument line "//arg_line_no//" from file '"//trim(commandfilename//"'")) + end if + call finalise(cli_params) + endif + + have_params = .true. + do while (have_params) + call print("infile " // trim(infilename) // " infile_is_list " // infile_is_list) + call print("outfilename " // trim(outfilename)) + call print("decimation " // decimation // " min_time " // min_time // " max_time " // max_time) + call print("AtomMask " // trim(mask_str)) + call print("CentMask " // trim(mask_center)) + call print("radial_histo " // radial_histo) + if (radial_histo) then + do i1 = 1, 3 + if (n_bins(i1) < 1) n_bins(i1) = 1 + end do + call print("bin_width(1,2,3) "//bin_width(1)//" "//bin_width(2)//" "//bin_width(3)& + //" n_bins(1,2,3) " // n_bins(1)//" "//n_bins(2)//" "//n_bins(3)) + call print("random_samples " // random_samples) + if (random_samples) then + call print("n_samples " // n_samples(1)) + else + call print("n_theta " // n_samples(1) // " n_phi " // n_samples(2)) + endif + else + call print("min_p " // min_p) + call print("bin_width " // bin_width // " n_bins " // n_bins) + endif + call print("gaussian " // gaussian_smoothing // " sigma " // gaussian_sigma // " angle_sigma " // gaussian_angle_sigma // " sampling_sigma " // sampling_sigma) + call print("do_distance_dependence " // do_distance_dependence) + call print("nth_snapshots " // nth_snapshots) + call print("sort_Time " // sort_Time // " no_Time_dups " // no_Time_dups) + call print("mean " // mean // " mean_decorrelation_time " // mean_decorrelation_time) + call print("autocorrelation " // autocorrelation // " autocorrelation_max_lag " // autocorrelation_max_lag) + + call print("Calculating angle distributions") + call calc_histos(histo_raw, n_histos, min_p, bin_width, n_bins, structure_ll, mean_decorrelation_time, & + gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & + radial_histo, random_samples, n_samples, mask_str, mask_center, do_distance_dependence, nth_snapshots) + + call initialise(outfile, outfilename, OUTPUT) + + if (autocorrelation) then + call print("Calculating autocorrelations") + allocate(autocorr(n_bins(1),n_bins(2),n_bins(3),autocorrelation_max_lag+1)) + autocorr = autocorrelation_3array(histo_raw(:,:,:,1:n_histos), max_lag=autocorrelation_max_lag) + + call print("Printing autocorrelations") + call print("# Autocorrelation", file=outfile) + do i_lag=0, autocorrelation_max_lag + call print(i_lag // " " // reshape(autocorr(1:n_bins(1),1:n_bins(2),1:n_bins(3),i_lag+1), & + (/ n_bins(1)*n_bins(2)*n_bins(3) /)), file=outfile) + end do + endif + + if (mean) then + if (autocorrelation) then + call print("", file=outfile) + call print("", file=outfile) + endif + allocate(histo_mean(n_bins(1), n_bins(2), n_bins(3))) + allocate(histo_var(n_bins(1), n_bins(2), n_bins(3))) + call calc_mean_var_3array(histo_raw(:,:,:,1:n_histos), histo_mean, histo_var) + + if (radial_histo) then + call print("# O--H-O angles (#/rad) ", file=outfile) + call print("# r mean var n_samples", file=outfile) + if(bin_width(1) == 0.0_dp) then + if(n_bins(1) .ne. 1) then + m_bin_width = PI/real(n_bins(1),dp) + else + m_bin_width = 0.0_dp + end if + else + m_bin_width = bin_width(1) + end if + do i3=1, n_bins(3) + do i1=1, n_bins(1) + do i2=1, n_bins(2) + !call print(PI-(bin_width(1)*(real(i1,dp)-0.5)) // " " // (1.8_dp+(bin_width(2)*(real(i2,dp)-0.5))) // " " & + ! //(bin_width(3)*(real(i3,dp)-0.5))// " " & + ! // histo_raw(i1, i2, i3, 1) // " " //n_histos, file=outfile) + call print(PI-(m_bin_width*(real(i1,dp)-0.5)) // " " // (1.8_dp+(bin_width(2)*(real(i2,dp)-0.5))) // " " & + //(bin_width(3)*(real(i3,dp)-0.5))// " " & + // histo_mean(i1, i2, i3) // " " // histo_var(i1, i2, i3)// " " //n_histos, file=outfile) + end do + call print('',file=outfile) + end do + end do + else + call print("# Density (#/vol)", file=outfile) + call print("# x y z mean var n_samples", file=outfile) + do i1=1,n_bins(1) + do i2=1,n_bins(2) + do i3=1,n_bins(3) + call print( (min_p+bin_width*(/ i1-0.5_dp, i2-0.5_dp, i3-0.5_dp /)) // & + " " // histo_mean(i1, i2, i3) // & + " " // histo_var(i1, i2, i3) // " " // n_histos, file=outfile) + end do + call print('', file=outfile) + end do + call print('', file=outfile) + end do + endif + end if + + call finalise(outfile) + + if (allocated(histo_raw)) deallocate(histo_raw) + if (allocated(autocorr)) deallocate(autocorr) + if (allocated(histo_mean)) deallocate(histo_mean) + if (allocated(histo_var)) deallocate(histo_var) + + if (len_trim(commandfilename) == 0) then + have_params = .false. + else + arg_line_no = arg_line_no + 1 + args_str = read_line(commandfile, status=status) + if (status == 0) then + call print("got arguments line '"//trim(args_str)//"'") + call initialise(cli_params) + call register_cli_params(cli_params,.false., infilename, infile_is_list, outfilename, commandfilename, & + mask_str, mask_center, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & + radial_histo, random_samples, n_samples, do_distance_dependence, nth_snapshots, & + sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) + if (.not. param_read_line(cli_params, trim(args_str), ignore_unknown = .true.)) then + call print_usage() + call system_abort("could not parse argument line "//arg_line_no//" from file '"//trim(commandfilename//"'")) + end if + call finalise(cli_params) + else + have_params = .false. + endif + endif + + end do + + call system_finalise() + +contains + + subroutine print_usage() + + character(len=1024) my_exec_name + + if (EXEC_NAME == "") then + my_exec_name="" + else + my_exec_name=EXEC_NAME + endif + + call print("Usage: " // trim(my_exec_name)//" infile=filename [infile_is_list=logical(F)]", PRINT_ALWAYS) + call print(" outfile=filename [commandfile=filename()] [AtomMask=species()] [min_p={x y z}]", PRINT_ALWAYS) + call print(" bin_width={x y z}(y,z ignored for radial_histo) n_bins={nx ny nz}(y,z ignored for radial_histo)", PRINT_ALWAYS) + call print(" [mean=logical(T)] [mean_decorrelation_time=t(0.0)]", PRINT_ALWAYS) + call print(" [autocorrelation=logical(F)] [autocorrelation_max_lag=N(10000)]", PRINT_ALWAYS) + call print(" [decimation=n(1)] [min_time=t(-1.0)] [max_time=t(-1.0)]", PRINT_ALWAYS) + call print(" [gaussian=logical(F)(always true for radial_histo)] [sigma=s(1.0)] [radial_histo=logical(F)]", PRINT_ALWAYS) + call print(" [random_samples=logical(F)(radial_histo only)] [n_samples={2 4})(component 2 ignored for random)]", PRINT_ALWAYS) + call print(" [sort_Time(F)] [no_Time_dups(F)]", PRINT_ALWAYS) + call print(" [quiet=logical(F)]", PRINT_ALWAYS) + end subroutine print_usage + + subroutine register_cli_params(cli_params, initial, infilename, infile_is_list, outfilename, commandfilename, & + mask_str, mask_center, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & + radial_histo, random_samples, n_samples, do_distance_dependence, nth_snapshots, & + sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) + type(Dictionary), intent(inout) :: cli_params + logical, intent(in) :: initial + character(len=*), intent(inout) :: infilename + logical, intent(inout) :: infile_is_list + character(len=*), intent(inout) :: outfilename + character(len=*), intent(inout) :: commandfilename + character(len=*), intent(inout) :: mask_str + character(len=*), intent(inout) :: mask_center + real(dp), intent(inout) :: min_p(3), bin_width(3) + integer, intent(inout) :: n_bins(3), decimation + real(dp), intent(inout) :: min_time, max_time + logical, intent(inout) :: gaussian_smoothing + real(dp), intent(inout) :: gaussian_sigma + real(dp), intent(inout) :: gaussian_angle_sigma + real(dp), intent(inout) :: sampling_sigma + logical, intent(inout) :: radial_histo + logical, intent(inout) :: random_samples + logical, intent(inout) :: do_distance_dependence + integer, intent(inout) :: nth_snapshots + integer, intent(inout) :: n_samples(2) + logical, intent(inout) :: sort_Time, no_Time_dups + logical, intent(inout) :: mean + real(dp), intent(inout) :: mean_decorrelation_time + logical, intent(inout) :: autocorrelation + integer, intent(inout) :: autocorrelation_max_lag + logical, intent(inout) :: quiet + character(len=STRING_LENGTH) :: t_field + + + if (initial) then + call param_register(cli_params, 'infile', param_mandatory, infilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'infile_is_list', 'F', infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'outfile', 'stdout', outfilename, help_string="No help yet. This source file was $LastChangedBy$") + mask_str = "" + mask_center = "" + commandfilename = "" + call param_register(cli_params, 'commandfile', "", commandfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'AtomMask', "O", mask_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'CentMask', "O", mask_center, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_p', "0.0 0.0 0.0", min_p, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'bin_width', PARAM_MANDATORY, bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'n_bins', PARAM_MANDATORY, n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'gaussian', 'F', gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sigma', '0.0', gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'do_distance_dependence', 'F', do_distance_dependence, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'nth_snapshots', '1', nth_snapshots, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'angle_sigma', '0.0', gaussian_angle_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sampling_sigma', '0.0', sampling_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'radial_histo', 'F', radial_histo, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'random_samples', 'F', random_samples, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'n_samples', '2 4', n_samples, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sort_Time', 'F', sort_Time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'no_Time_dups', 'F', no_Time_dups, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'mean', 'T', mean, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'mean_decorrelation_time', '0.0', mean_decorrelation_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'autocorrelation', 'F', autocorrelation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'autocorrelation_max_lag', '10000', autocorrelation_max_lag, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'quiet', 'F', quiet, help_string="No help yet. This source file was $LastChangedBy$") + else + t_field=infilename + call param_register(cli_params, 'infile', trim(t_field), infilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'infile_is_list', ""//infile_is_list, infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") + t_field=outfilename + call param_register(cli_params, 'outfile', trim(t_field), outfilename, help_string="No help yet. This source file was $LastChangedBy$") + t_field=commandfilename + call param_register(cli_params, 'commandfile', trim(t_field), commandfilename, help_string="No help yet. This source file was $LastChangedBy$") + t_field=mask_str + t_field=mask_center + call param_register(cli_params, 'AtomMask', trim(t_field), mask_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'CentMask', trim(t_field), mask_center, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_p', ""//min_p, min_p, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'bin_width', ""//bin_width, bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'n_bins', ""//n_bins, n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_time', ""//min_time, min_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'max_time', ""//max_time, max_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'gaussian', ""//gaussian_smoothing, gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sigma', ""//gaussian_sigma, gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'do_distance_dependence', ""//do_distance_dependence, do_distance_dependence, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'nth_snapshots', ""//nth_snapshots, nth_snapshots, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'angle_sigma', ""//gaussian_angle_sigma, gaussian_angle_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sampling_sigma', ""//sampling_sigma, sampling_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'radial_histo', ""//radial_histo, radial_histo, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'random_samples', ""//random_samples, random_samples, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'n_samples', '2 4', n_samples, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'mean', ""//mean, mean, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'mean_decorrelation_time', ""//mean_decorrelation_time, mean_decorrelation_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'autocorrelation', ""//autocorrelation, autocorrelation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'autocorrelation_max_lag', ""//autocorrelation_max_lag, autocorrelation_max_lag, help_string="No help yet. This source file was $LastChangedBy$") + endif + end subroutine register_cli_params + + function autocorrelation_scalar(v, max_lag) result(autocorrelation) + real(dp), intent(in) :: v(:) + integer, intent(in) :: max_lag + real(dp) :: autocorrelation(max_lag) + + integer :: lag, i + real(dp) :: t_sum, mean + integer :: nt + + nt = size(v,1) + + mean = sum(v)/real(nt,dp) + do lag=1, max_lag + t_sum = 0.0_dp + do i=1, nt-lag + t_sum = t_sum + (v(i)-mean)*(v(i+lag)-mean) + end do + autocorrelation(lag) = t_sum/real(nt-lag,dp) + end do + + end function autocorrelation_scalar + + function autocorrelation_3array(v, max_lag) result(autocorrelation) + real(dp), intent(in) :: v(:,:,:,:) + integer, intent(in) :: max_lag + real(dp) :: autocorrelation(size(v,1),size(v,2),size(v,3),max_lag+1) + + integer :: lag, i + real(dp), allocatable :: t_sum(:,:,:), mean(:,:,:) + integer :: n1, n2, n3, nt + + n1 = size(v,1) + n2 = size(v,2) + n3 = size(v,3) + nt = size(v,4) + allocate(t_sum(n1,n2,n3), mean(n1,n2,n3)) + + mean = sum(v,4)/real(nt,dp) + do lag=0, max_lag + t_sum = 0.0_dp + do i=1, nt-lag + t_sum(1:n1,1:n2,1:n3) = t_sum(1:n1,1:n2,1:n3) + (v(1:n1,1:n2,1:n3,i)-mean)*(v(1:n1,1:n2,1:n3,i+lag)-mean) + end do + autocorrelation(1:n1,1:n2,1:n3,lag+1) = t_sum(1:n1,1:n2,1:n3)/real(nt-lag,dp) + end do + + deallocate(t_sum, mean) + + end function autocorrelation_3array + + subroutine calc_histos(histo_count, n_histos, min_p, bin_width, n_bins, structure_ll, interval, gaussian, & + gaussian_sigma, gaussian_angle_sigma, sampling_sigma, radial_histo, & + random_samples, n_samples, mask_str, mask_center, do_distance_dependence, nth_snapshots) + real(dp), intent(inout), allocatable :: histo_count(:,:,:,:) + integer, intent(out) :: n_histos + real(dp), intent(in) :: min_p(3), bin_width(3) + integer, intent(in) :: n_bins(3) + type(atoms_ll), intent(in) :: structure_ll + real(dp), intent(in) :: interval + logical, intent(in) :: gaussian + real(dp), intent(in) :: gaussian_sigma + real(dp), intent(in) :: gaussian_angle_sigma + real(dp), intent(in) :: sampling_sigma + logical, intent(in) :: radial_histo + logical :: random_samples + integer :: n_samples(2) + character(len=*), optional, intent(in) :: mask_str + character(len=*), optional, intent(in) :: mask_center + logical, intent(in) :: do_distance_dependence + integer, intent(in) :: nth_snapshots + + real(dp) :: last_time, cur_time + type(atoms_ll_entry), pointer :: entry + logical :: do_this_histo + real(dp), allocatable :: theta(:), phi(:), w(:) + + n_histos = 0 + allocate(histo_count(n_bins(1),n_bins(2),n_bins(3),10)) + histo_count = 0.0_dp + + if (random_samples) then + call calc_samples_random(n_samples(1), theta, phi, w) + else + call calc_samples_grid(n_samples(1), n_samples(2), theta, phi, w) + endif + entry => structure_ll%first + cur_time = -1.0_dp + last_time = -1.0e38_dp + do while (associated(entry)) + do_this_histo = .false. + if (interval > 0.0_dp) then + if (cur_time < last_time) & + call system_abort("calc_histos called with interval="//interval//" > 0, but unsorted sequence: cur_time="// & + cur_time//" < last_time="//last_time) + if (.not. get_value(entry%at%params, "Time", cur_time)) & + call system_abort("calc_histos called with interval="//interval//" > 0, but no Time value in entry") + if ((cur_time .feq. last_time) .or. (cur_time >= last_time+interval)) then + do_this_histo = .true. + if (cur_time >= last_time+interval) last_time = cur_time + endif + else + do_this_histo = .true. + endif + if (do_this_histo) then + ! if (get_value(entry%at%params, "Time", cur_time)) call print("doing histo for config with time " // cur_time) + n_histos = n_histos + 1 + if (mod(n_histos,10) == 0) then + if(mod(n_histos,50) == 0) then + write (mainlog%unit,'(i0)') n_histos + else + write (mainlog%unit,'(a,$)') '|' + end if + else + write(mainlog%unit,'(a,$)') '.' + end if + if (mod(n_histos,1000) == 0) write (mainlog%unit,'(a)') " " + call reallocate_histos(histo_count, n_histos, n_bins) + if (radial_histo) then + call calc_connect(entry%at) + cell_vol = cell_volume(entry%at%lattice) + call accumulate_radial_histo_count(histo_count(:,:,:,n_histos), entry%at, bin_width(1), bin_width(2), bin_width(3), & + n_bins(1), n_bins(2), n_bins(3), & + gaussian, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & + theta, phi, w, mask_str, mask_center, do_distance_dependence) + endif + endif + entry => entry%next + end do + end subroutine calc_histos + + subroutine calc_samples_grid(n_t, n_p, theta, phi, w) + integer, intent(in) :: n_t, n_p + real(dp), allocatable, intent(inout) :: theta(:), phi(:), w(:) + + integer :: t_i, p_i, ii + + if (allocated(theta)) deallocate(theta) + if (allocated(phi)) deallocate(phi) + if (allocated(w)) deallocate(w) + allocate(theta(n_t*n_p)) + allocate(phi(n_t*n_p)) + allocate(w(n_t*n_p)) + + ii = 1 + do t_i=1, n_t + do p_i=1, n_p + phi(ii) = (p_i-1)*2.0_dp*PI/real(n_p,dp) + if (mod(n_t,2) == 0) then + theta(ii) = (t_i-1.5_dp-floor((n_t-1)/2.0_dp))*PI/real(n_t,dp) + else + theta(ii) = (t_i-1-floor((n_t-1)/2.0_dp))*PI/real(n_t,dp) + endif + ! not oversample top and bottom of spehre + w(ii) = cos(theta(ii)) + ii = ii + 1 + end do + end do + w = w / ( (sampling_sigma*sqrt(2.0_dp*PI))**3 * sum(w) ) + end subroutine calc_samples_grid + + subroutine calc_samples_random(n, theta, phi, w) + integer, intent(in) :: n + real(dp), allocatable, intent(inout) :: theta(:), phi(:), w(:) + + integer :: ii + real(dp) :: p(3), p_norm + + if (allocated(theta)) deallocate(theta) + if (allocated(phi)) deallocate(phi) + if (allocated(w)) deallocate(w) + allocate(theta(n)) + allocate(phi(n)) + allocate(w(n)) + + do ii = 1, n + p_norm = 2.0_dp + do while (p_norm > 1.0_dp) + p = 0.0_dp + call randomise(p, 2.0_dp) + p_norm = norm(p) + end do + phi(ii) = atan2(p(2),p(1)) + theta(ii) = acos(p(3)/p_norm) + w(ii) = 1.0_dp + end do + w = w / ( (sampling_sigma*sqrt(2.0_dp*PI))**3 * sum(w) ) + + end subroutine calc_samples_random + + subroutine accumulate_radial_histo_count(histo_count, at, bin_width, dbin_width, sbin_width, n_bins, dn_bins, sn_bins, & + gaussian, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & + theta, phi, w, mask_str, mask_center, do_distance_dependence) + real(dp), intent(inout) :: histo_count(:,:,:) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: bin_width, dbin_width, sbin_width + integer, intent(in) :: n_bins, dn_bins, sn_bins + logical,intent(in) :: gaussian + real(dp), intent(in) :: gaussian_sigma, gaussian_angle_sigma, sampling_sigma, theta(:), phi(:), w(:) + character(len=*), optional, intent(in) :: mask_str + character(len=*), optional, intent(in) :: mask_center + logical,intent(in) :: do_distance_dependence + + real(dp) :: bin_r, bin_a, bin_s, p(3), dist, r, d, sdist, distw, ang, v1(3), v2(3), m_bin_width + logical, allocatable :: mask_a(:), mask_c(:) + integer at_i, at_j, sample_i, bin_i, bin_j, bin_k, i, k, m + real(dp) :: myNorm, fotPI, oostPI, sina, shell, sample_shell + integer :: myCount, sample_size + real(dp) :: mycent(3) + + if(sbin_width == 0.0_dp) then + sample_size = 1 + else + sample_size = size(theta) + end if + + allocate(mask_a(at%N)) + call is_in_mask(mask_a, at, mask_str) + allocate(mask_c(at%N)) + call is_in_mask(mask_c, at, mask_center) + + m = 0 + do i = 1, at%N + if (mask_a(i)) m=m+1 + end do + part_dens=real(m,dp)/cell_vol + + m=0 + do i = 1, at%N + if(mask_c(i)) then + m=m+1 + k=i + end if + end do + + if(m==1) then + mycent=at%pos(:,k) + else + mycent=(/0.0_dp,0.0_dp,0.0_dp/) + end if + + myNorm = 1/(gaussian_angle_sigma*sqrt(2*PI)) + if(bin_width == 0.0_dp) then + if(n_bins .ne. 1) then + m_bin_width = PI/real(n_bins,dp) + else + m_bin_width = 0.0_dp + end if + else + m_bin_width = bin_width + end if + fotPI = (4.0_dp * PI)/3.0_dp + oostPI = 1.0_dp/(sqrt(2.0_dp*PI)) +! ratio of 20/4=5 is bad +! ratio of 20/3=6.66 is bad +! ratio of 20/2.5=8 is borderline (2e-4) +! ratio of 20/2.22=9 is fine (error 2e-5) +! ratio of 20/2=10 is fine + if ( (norm(at%lattice(:,1)) < 9.0_dp*sampling_sigma) .or. & + (norm(at%lattice(:,2)) < 9.0_dp*sampling_sigma) .or. & + (norm(at%lattice(:,3)) < 9.0_dp*sampling_sigma) ) & + call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) + if(.not. do_distance_dependence) then + if(gaussian) then + myCount=0 + do at_i=1, at%N + if(.not. mask_c(at_i)) cycle + myCount = myCount+1 + do bin_i = 1, n_bins !angles + bin_a = PI - (real(bin_i,dp)-0.5)*m_bin_width + do bin_j = 1, dn_bins !distances + bin_r = 1.8_dp +(real(bin_j,dp)-0.5)*dbin_width + shell = fotPI*( (bin_r+1.5_dp*gaussian_sigma)**3 - (max(0.0_dp,(bin_r-1.5_dp*gaussian_sigma)**3)) )*part_dens + do at_j = 1, at%N + if((at_j == at_i) .or. .not. mask_a(at_j)) cycle !(at%Z(at_j) .ne. 8)) cycle + dist = distance_min_image(at,at%pos(:,at_i),at%pos(:,at_j)) + do i = 1, n_neighbours(at,at_j) + k = neighbour(at,at_j,i) + r = 0.0_dp + if(is_nearest_neighbour(at,at_j,i) .and. at%Z(k) == 1) then + d = distance_min_image(at,at%pos(:,at_i),at%pos(:,k)) + if(r == 0.0_dp .or. d < r) then + m = k !select the mth atom (hydrogen) + r = d + end if + end if !nearest neighbour + end do !neighbours of at_j + v1 = at%pos(:,at_i) - at%pos(:,k) + v2 = at%pos(:,at_j) - at%pos(:,k) + ang = angle(v1,v2) + sina = sin(PI-ang) + if(sina .lt. 1.0E-10) sina=1.0E-10 + ang = myNorm*exp(-0.5_dp*((ang-bin_a)/gaussian_angle_sigma)**2) + ang = ang/(2.0*PI*sina) + histo_count(bin_i,bin_j,1) = histo_count(bin_i,bin_j,1) + & + (ang*exp(-0.5_dp*((dist-bin_r)/gaussian_sigma)**2)*( (oostPI/gaussian_sigma) / shell )) + end do !at_j + end do !distances + end do !angles + end do ! at_i + do bin_i=1, n_bins + do bin_j=1, dn_bins + histo_count(bin_i,bin_j,1) = histo_count(bin_i,bin_j,1) / real(myCount,dp) + end do + end do + else if(.not. gaussian) then !use radial bins, weighted down by volume (assuming homogenous density) + myCount = 0 + do at_i=1, at%N + myCount = myCount+1 + if(.not. mask_c(at_i)) cycle + do bin_i = 1, n_bins !angles + bin_a = PI - (real(bin_i,dp)-0.5_dp)*m_bin_width + do bin_j = 1, dn_bins !distances + bin_r = 1.8_dp + ((real(bin_j,dp)-0.5_dp)*dbin_width) + shell = fotPI*((bin_r+0.5_dp*dbin_width)**3 - (bin_r-0.5_dp*dbin_width)**3)*part_dens + do at_j = 1, at%N + if((at_j == at_i) .or. .not.mask_a(at_j)) cycle !(at%Z(at_j) .ne. 8)) cycle + dist = distance_min_image(at,at%pos(:,at_i),at%pos(:,at_j)) + if( (dist > (bin_r-(dbin_width*0.5_dp))) .and. (dist < (bin_r+(dbin_width*0.5_dp))) ) then + do i = 1, n_neighbours(at,at_j) + k = neighbour(at,at_j,i) + r = 0.0_dp + if(is_nearest_neighbour(at,at_j,i) .and. at%Z(k) == 1) then + d = distance_min_image(at,at%pos(:,at_i),at%pos(:,k)) + if(r == 0.0_dp .or. d < r) then + m = k !select the mth atom (hydrogen) + r = d + end if + end if !nearest neighbour + end do !neighbours of at_j + v1 = at%pos(:,at_i) - at%pos(:,k) + v2 = at%pos(:,at_j) - at%pos(:,k) + ang = angle(v1,v2) + sina=sin(PI-ang) + if( (ang > (bin_a-(m_bin_width*0.5_dp))) .and. (ang < (bin_a+(m_bin_width*0.5_dp))) ) then + histo_count(bin_i,bin_j,1) = histo_count(bin_i,bin_j,1) + (1.0_dp/(2.0*PI*sina))/shell + end if !angle bin + end if !distance bin + end do !at_j + end do !distances + end do !angles + end do ! at_i + do bin_i=1, n_bins + do bin_j = 1, dn_bins + histo_count(bin_i,bin_j,1) = histo_count(bin_i,bin_j,1) / real(myCount,dp) + end do + end do + end if !no gaussian smoothing + else !distance dependence + if(gaussian) then + do bin_k = 1, sn_bins + bin_s = (real(bin_k,dp)-0.5_dp)*sbin_width + do at_i=1, at%N + if(.not. mask_c(at_i)) cycle + do sample_i = 1, sample_size + p(1) = mycent(1)+bin_s*cos(theta(sample_i))*cos(phi(sample_i)) + p(2) = mycent(2)+bin_s*cos(theta(sample_i))*sin(phi(sample_i)) + p(3) = mycent(3)+bin_s*sin(theta(sample_i)) + sdist = distance_min_image(at,p,at%pos(:,at_i)) + if( sdist < 3.0_dp*sampling_sigma) then + distw = w(sample_i)*exp(-0.5_dp*(sdist/sampling_sigma)**2) + do bin_i = 1, n_bins !angles + bin_a = PI - (real(bin_i,dp)-0.5)*m_bin_width + do bin_j = 1, dn_bins !distances + bin_r = 1.8_dp +(real(bin_j,dp)-0.5_dp)*dbin_width + shell = fotPI*( (bin_r+1.5_dp*gaussian_sigma)**3 - (max(0.0_dp,(bin_r-1.5_dp*gaussian_sigma)**3)) )*part_dens + do at_j = 1, at%N + if((at_j == at_i) .or. .not.mask_a(at_j)) cycle !.or. (at%Z(at_j) .ne. 8)) cycle + dist = distance_min_image(at,at%pos(:,at_i),at%pos(:,at_j)) + do i = 1, n_neighbours(at,at_j) + k = neighbour(at,at_j,i) + r = 0.0_dp + if(is_nearest_neighbour(at,at_j,i) .and. at%Z(k) == 1) then + d = distance_min_image(at,at%pos(:,at_i),at%pos(:,k)) + if(r == 0.0_dp .or. d < r) then + m = k !select the mth atom (hydrogen) + r = d + end if + end if !nearest neighbour + end do !neighbours of at_j + v1 = at%pos(:,at_i) - at%pos(:,k) + v2 = at%pos(:,at_j) - at%pos(:,k) + ang = angle(v1,v2) + sina=sin(PI-ang) + if(sina .lt. 1.0E-10) sina=1.0E-10 + ang = myNorm*exp(-0.5_dp*((ang-bin_a)/gaussian_angle_sigma)**2) + ang = ang/(2.0_dp*PI*sina) + histo_count(bin_i,bin_j,bin_k) = histo_count(bin_i,bin_j,bin_k) + & + (ang*exp(-0.5_dp*((dist-bin_r)/gaussian_sigma)**2)*( (oostPI/gaussian_sigma) / shell )*distw) + end do !at_j + end do !distances + end do !angles + end if + end do !samples + end do ! at_i + end do !sampling distances + else !distance dependence, but not gaussian + myCount = 0 + do bin_k = 1, sn_bins + bin_s = (real(bin_k,dp)-0.5_dp)*sbin_width + sample_shell = fotPI*((bin_s+0.5_dp*sbin_width)**3 - (bin_s-0.5_dp*sbin_width)**3)*part_dens + do at_i=1, at%N + !do at_i=991, 991 + if(.not. mask_c(at_i)) cycle + !if(at%Z(at_i) .ne. 8) cycle !for oxygens only + sdist = distance_min_image(at,(/0.0_dp,0.0_dp,0.0_dp/),at%pos(:,at_i)) + if( sdist > (bin_s-0.5_dp*sbin_width) .and. sdist < (bin_s+0.5_dp*sbin_width)) then + do bin_i = 1, n_bins !angles + bin_a = PI - (real(bin_i,dp)-0.5_dp)*m_bin_width + do bin_j = 1, dn_bins !distances + bin_r = 1.8_dp + ((real(bin_j,dp)-0.5_dp)*dbin_width) + shell = fotPI*((bin_r+0.5_dp*dbin_width)**3 - (bin_r-0.5_dp*dbin_width)**3)*part_dens + do at_j = 1, at%N + if((at_j == at_i) .or. .not.mask_a(at_j)) cycle !(at%Z(at_j) .ne. 8)) cycle + dist = distance_min_image(at,at%pos(:,at_i),at%pos(:,at_j)) + if( (dist > (bin_r-(dbin_width*0.5_dp))) .and. (dist < (bin_r+(dbin_width*0.5_dp))) ) then + do i = 1, n_neighbours(at,at_j) + k = neighbour(at,at_j,i) + r = 0.0_dp + if(is_nearest_neighbour(at,at_j,i) .and. at%Z(k) == 1) then + d = distance_min_image(at,at%pos(:,at_i),at%pos(:,k)) + if(r == 0.0_dp .or. d < r) then + m = k !select the mth atom (hydrogen) + r = d + end if + end if !nearest neighbour + end do !neighbours of at_j + v1 = at%pos(:,at_i) - at%pos(:,k) + v2 = at%pos(:,at_j) - at%pos(:,k) + ang = angle(v1,v2) + sina=sin(PI-ang) + !cosa=cos(PI-ang) + if( (ang > (bin_a-(m_bin_width*0.5_dp))) .and. (ang < (bin_a+(m_bin_width*0.5_dp))) ) then + histo_count(bin_i,bin_j,bin_k) = histo_count(bin_i,bin_j,bin_k) + (1.0_dp/(2.0*PI*sina))/(shell*sample_shell) + end if !angle bin + end if !distance bin + end do !at_j + end do !distances + end do !angles + end if !if at_i is in sample_shell + end do ! at_i + end do !bin_k + end if !gaussian in distance dependence + end if + + deallocate(mask_a) + end subroutine accumulate_radial_histo_count + + subroutine is_in_mask(mask_a, at, mask_str) + type(Atoms), intent(in) :: at + logical, intent(out) :: mask_a(at%N) + character(len=*), optional, intent(in) :: mask_str + + integer :: i + integer :: Zmask + type(Table) :: atom_indices + + if (.not. present(mask_str)) then + mask_a = .true. + return + endif + + if (len_trim(mask_str) == 0) then + mask_a = .true. + return + endif + + mask_a = .false. + if (mask_str(1:1)=='@') then + call parse_atom_mask(mask_str,atom_indices) + do i=1, atom_indices%N + mask_a(atom_indices%int(1,i)) = .true. + end do + else if (scan(mask_str,'=')/=0) then + call system_abort("property type mask not supported yet") + else + Zmask = Atomic_Number(mask_str) + do i=1, at%N + if (at%Z(i) == Zmask) mask_a(i) = .true. + end do + end if + end subroutine is_in_mask + + subroutine reallocate_histos(histos, n, n_bins) + real(dp), allocatable, intent(inout) :: histos(:,:,:,:) + integer, intent(in) :: n, n_bins(3) + + integer :: new_size + real(dp), allocatable :: t_histos(:,:,:,:) + + if (allocated(histos)) then + if (n <= size(histos,4)) return + allocate(t_histos(size(histos,1),size(histos,2),size(histos,3),size(histos,4))) + t_histos = histos + deallocate(histos) + if (size(t_histos,4) <= 0) then + new_size = 10 + else if (size(t_histos,4) < 1000) then + new_size = 2*size(t_histos,4) + else + new_size = floor(1.25*size(t_histos,4)) + endif + allocate(histos(size(t_histos,1), size(t_histos,2), size(t_histos,3), new_size)) + histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),1:size(t_histos,4)) = & + t_histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),1:size(t_histos,4)) + histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),size(t_histos,4)+1:size(histos,4)) = 0.0_dp + deallocate(t_histos) + else + allocate(histos(n_bins(1), n_bins(2), n_bins(3), n)) + endif + end subroutine reallocate_histos + + subroutine calc_mean_var_3array(a, mean, var) + real(dp), intent(in) :: a(:,:,:,:) + real(dp), intent(out) :: mean(:,:,:) + real(dp), optional, intent(out) :: var(:,:,:) + + integer :: i1, i2, i3, n + + n = size(a,4) + mean = sum(a, 4)/real(n,dp) + if (present(var)) then + do i1=1, size(a,1) + do i2=1, size(a,2) + do i3=1, size(a,3) + var(i1,i2,i3) = sum((a(i1,i2,i3,:)-mean(i1,i2,i3))**2)/real(n,dp) + end do + end do + end do + end if + end subroutine calc_mean_var_3array + +end program angle_distr diff --git a/src/Structure_processors/clean_traj.F90 b/src/Structure_processors/clean_traj.F90 new file mode 100644 index 0000000000..d599deb2e6 --- /dev/null +++ b/src/Structure_processors/clean_traj.F90 @@ -0,0 +1,117 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! Reads a sequence of configs, optionally with decimation, min_time, max_time, and sorting +! by Time as well as eliminating duplicates (basically a driver for atoms_ll_read_xyz_filename()) + +program clean_traj +use libatoms_module +implicit none + + type(Dictionary) :: cli_params + character(len=STRING_LENGTH) :: infilename + logical :: infile_is_list + character(len=STRING_LENGTH) :: outfilename + type(CInOutput) :: outfile + integer :: decimation + real(dp) :: min_time, max_time + logical :: sort_Time, no_Time_dups, quiet, no_compute_index + real(dp) :: scale_lattice, scale_pos + character(len=STRING_LENGTH) :: properties + + type(Atoms_ll) :: structure_ll + type(Atoms_ll_entry), pointer :: entry + + call system_initialise(PRINT_NORMAL) + + call initialise(cli_params) + call param_register(cli_params, 'infile', param_mandatory, infilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'infile_is_list', 'F', infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'outfile', 'stdout', outfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sort_Time', 'F', sort_Time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'no_Time_dups', 'F', no_Time_dups, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'quiet', 'F', quiet, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'scale_lattice', '1.0', scale_lattice, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'scale_pos', '1.0', scale_pos, help_string="No help yet. This source file was $LastChangedBy$") + properties = "" + call param_register(cli_params, 'properties', 'species:pos:Z', properties, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(cli_params)) then + call print_usage() + call system_abort('could not parse argument line') + end if + call finalise(cli_params) + + call print("infile " // trim(infilename) // " infile_is_list " // infile_is_list) + call print("outfilename " // trim(outfilename)) + call print("decimation " // decimation // " min_time " // min_time // " max_time " // max_time) + call print("sort_Time " // sort_Time // " no_Time_dups " // no_Time_dups // " quiet " // quiet) + call print("scale_lattice " // scale_lattice // " scale_pos " // scale_pos) + + no_compute_index=.false. + if ((.not. sort_Time) .and. (.not. no_Time_dups)) no_compute_index=.true. + + call read_xyz(structure_ll, infilename, infile_is_list, decimation, min_time, max_time, sort_Time, no_Time_dups, quiet, no_compute_index, properties=properties) + + call initialise(outfile, outfilename, action=OUTPUT) + entry => structure_ll%first + do while (associated(entry)) + if (scale_lattice /= 1.0_dp) entry%at%lattice = scale_lattice * entry%at%lattice + if (scale_pos /= 1.0_dp) entry%at%pos = scale_pos * entry%at%pos + call write(outfile, entry%at) + entry => entry%next + end do + call finalise(outfile) + + call system_finalise() + +contains + + subroutine print_usage() + + character(len=1024) my_exec_name + + if (EXEC_NAME == "") then + my_exec_name="" + else + my_exec_name=EXEC_NAME + endif + + call print("Usage: " // trim(my_exec_name)//" infile=filename [infile_is_list=logical(F)]", PRINT_ALWAYS) + call print(" outfile=filename [decimation=n(1)]", PRINT_ALWAYS) + call print(" [min_time=t(-1.0)] [max_time=t(-1.0)]", PRINT_ALWAYS) + call print(" [sort_Time(F)] [no_Time_dups(F)] [quiet(F)]", PRINT_ALWAYS) + call print(" [scale_lattice=scale(1.0)] [scale_pos=scale(1.0)]", PRINT_ALWAYS) + call print(" [properties=prop1:prop2...(species:pos:Z,use blank for all props.)]", PRINT_ALWAYS) + end subroutine print_usage + +end program clean_traj diff --git a/src/Structure_processors/convert.F90 b/src/Structure_processors/convert.F90 new file mode 100644 index 0000000000..16ac5d914e --- /dev/null +++ b/src/Structure_processors/convert.F90 @@ -0,0 +1,72 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +#include "error.inc" + +program convert + +use libAtoms_module +use libatoms_misc_utils_module + +implicit none + + type(Atoms) at + type(CInOutput) :: infile, outfile + character(len=STRING_LENGTH) :: infilename, outfilename + integer error + + call system_initialise(verbosity=PRINT_SILENT) + + if (NUM_COMMAND_ARGS == 2) then + infilename = COMMAND_ARG(1) + outfilename = COMMAND_ARG(2) + else if(NUM_COMMAND_ARGS == 0) then + infilename = 'stdin' + outfilename = 'stdout' + else + call system_abort("Usage: convert [ infile.{xyz|nc} outfile.{xyz|nc} ]") + end if + + call initialise(infile, trim(infilename)) + call initialise(outfile, trim(outfilename), action=OUTPUT) + + do + call read(at, infile, error=error) + if (error /= 0) then + if (error == ERROR_IO_EOF) then + exit + else + HANDLE_ERROR(error) + endif + endif + call print(at) + call write(at, outfile) + end do + call system_finalise() +end program convert diff --git a/src/Structure_processors/coordination_number.F90 b/src/Structure_processors/coordination_number.F90 new file mode 100644 index 0000000000..eb2639b689 --- /dev/null +++ b/src/Structure_processors/coordination_number.F90 @@ -0,0 +1,300 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!Program to calculate coordination number as a fn of time, if given is +! -- an XYZ file with the coordinates, +! -- the atomic number of the atoms in the coordination sphere +! -- the atom number of the central atom +! and the output name specified. +!Optionally restarts can be taken into account by printing synchronised +! with the restart frequency (e.g. restart_frequency=20). +!Optionally appends the output (of restart files) to the same outfile (e.g. append_output=T). +! +!A Fermi distribution is used to smooth the coordination number +!M. Sprik, Far.Disc. 110, 437-445 (1998) +! +program coordination_number + + use libatoms_module + + implicit none + + type(Atoms) :: at + type(CInoutput) :: coord_file + type(InOutput) :: out_file + character(len=STRING_LENGTH), allocatable :: output_lines(:) + integer :: lines_used + integer :: iframe, step_nr + real(dp) :: time_passed + integer :: i + + !Input parameters + type(Dictionary) :: params_in + character(len=STRING_LENGTH) :: coord_filename + character(len=STRING_LENGTH) :: out_filename + integer :: last_frame + real(dp) :: time_step + integer :: restart_every + logical :: append_output + logical :: skip_extra_firsts +real(dp) :: dist, coord_num +logical, allocatable :: mask_a(:) +character(STRING_LENGTH) :: mask_str +real(dp) :: kappa, l_cutoff +integer :: iatom, center_atom +logical :: no_smoothing + + +! call system_initialise(verbosity=ANALYSIS,enable_timing=.true.) +! call system_initialise(verbosity=VERBOSE,enable_timing=.true.) + call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) + call system_timer('program') + + !INPUT + call initialise(params_in) + call param_register(params_in, 'infile' , PARAM_MANDATORY, coord_filename , help_string="input XYZ" ) + call param_register(params_in, 'outfile' , PARAM_MANDATORY, out_filename , help_string="output file" ) + mask_str='' + call param_register(params_in, 'neighbour_mask' , '' , mask_str , help_string="neighbour atom in the coordination sphere" ) + call param_register(params_in, 'center_mask' , '0' , center_atom , help_string="center atom, around which the coordination number is calculated" ) + call param_register(params_in, 'kappa' , '-1.0' , kappa , help_string="smoothing by default: 1/(exp(kappa*(d-cutoff))+1)" ) + call param_register(params_in, 'cutoff' , PARAM_MANDATORY, l_cutoff , help_string="cutoff of the coordination sphere" ) + call param_register(params_in, 'last_frame' , '0' , last_frame , help_string="last frame to process (0=all)" ) + call param_register(params_in, 'time_step' , '0.0' , time_step , help_string="time step" ) + call param_register(params_in, 'restart_every' , '1' , restart_every , help_string="to be consistent with the restart frequency" ) + call param_register(params_in, 'append_output' , 'F' , append_output , help_string="do not overwrite output file" ) + call param_register(params_in, 'skip_extra_firsts' ,'F' , skip_extra_firsts, help_string="QMMM_md_buf prints the first time step twice" ) + call param_register(params_in, 'no_smoothing' ,'F' , no_smoothing , help_string="whether to use smoothing, or an abrupt cutoff" ) + + if (.not. param_read_args(params_in)) then + call print("coordination_number infile outfile cutoff [center_atom] [neighbour_atom] [kappa=-1.0] [last_frame=0] [time_step=0.0] [restart_every=1] [append_output=F] [skip_extra_firsts=F] [no_smoothing=F]", PRINT_ALWAYS) + call system_abort('could not parse argument line') + end if + + call finalise(params_in) + + if (kappa<0) call system_abort("kappa<0") + if (l_cutoff<0) call system_abort("cutoff<0") + + !PRINT INPUT PARAMETERS + call print('Run parameters:') + call print(' coord_file '// trim(coord_filename) ) + call print(' outfile '// trim(out_filename) ) + call print(' neighbour_mask '// trim(mask_str) ) + call print(' center_mask '// center_atom ) + call print(' last_frame '// last_frame ) + call print(' kappa '// kappa ) + call print(' cutoff '// l_cutoff ) + call print(' time_step '// time_step ) + call print(' restart_every '// restart_every//' steps' ) + if (restart_every/=1) call print(' Prints after every '//restart_every//' steps, synchronised with the restart frequency.') + call print(' append_output '//append_output) + if (append_output) then + call print(" Will not overwrite out_file (appending probably restart).") + else + call print(" Will overwrite out_file!!") + endif + call print(' skip_extra_firsts '//skip_extra_firsts//" ONLY FOR cp2k_units=F !") + call print('---------------------------------------') + call print('') + + + !Read coordinates + call print('Reading in the coordinates from file '//trim(coord_filename)//'...') + call initialise(coord_file, coord_filename, action=INPUT) + call print('Number of frames '//coord_file%n_frame) + + if (last_frame/=0) then + last_frame = min(last_frame, coord_file%n_frame) + else + last_frame = coord_file%n_frame + endif + call print('Last frame to be processed '//last_frame) + + !open output file, append if required + if (append_output) then + call initialise(out_file, out_filename, action=OUTPUT,append=.true.) + else + call initialise(out_file, out_filename, action=OUTPUT,append=.false.) + call print("# Step Nr. Time[fs] n_coord("//trim(mask_str)//") ((r_cut="//l_cutoff//"))", file=out_file) + endif + + step_nr = 0 + + !allocate printing buffer + allocate(output_lines(restart_every)) + lines_used = 0 + + do iframe = 0, last_frame-1 + + call read(coord_file, at, frame=iframe) + + write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',(iframe+1) + + if (iframe==0) then + if (skip_extra_firsts) cycle !skip very first without force information + endif + if (iframe==1) then + if (skip_extra_firsts .and. append_output) cycle !skip the overlapping second for the restarts + endif + + !get Step_nr and Time + if (.not.get_value(at%params,"i",step_nr)) then + step_nr = step_nr + 1 + endif + if (.not.get_value(at%params,"time",time_passed)) then + time_passed = step_nr * time_step + endif + + if (center_atom<1.or.center_atom>at%N) call system_abort("center_atom="//center_atom//" is <0 or >"//at%N) + allocate(mask_a(at%N)) + call is_in_mask(mask_a, at, mask_str) + + coord_num=0._dp + !calc coordination number + do iatom=1,at%N + if (iatom==center_atom) cycle + if (.not.mask_a(iatom)) cycle + dist = distance_min_image(at,center_atom,iatom) + if (no_smoothing) then + if (dist [] [] [] +program density + + use libatoms_module + + implicit none + + type(Atoms) :: at + type(InOutput) :: xyzfile, datafile, datafile2 + integer :: frame_count, frames_processed + integer :: status + integer :: i + + !Input + type(Dictionary) :: params_in + character(STRING_LENGTH) :: xyzfilename, datafilename + integer :: numbins + integer :: IO_Rate + integer :: decimation + integer :: from, to + logical :: Gaussian_smoothing + real(dp) :: Gaussian_sigma + + !Cell and subcell parameters + real(dp) :: a, b, c + real(dp) :: alpha, beta, gamma + real(dp) :: cellvol + + !Density binning + real(dp) :: t(3), r(3) + integer :: box_a, box_b, box_c + real(dp), allocatable :: mass_cuml(:,:,:) + !Gaussian density binning + real(dp), dimension(3) :: increment + real(dp) :: x_min_bin, y_min_bin, z_min_bin + real(dp) :: x_min, y_min, z_min + real(dp) :: x_max, y_max, z_max + real(dp), dimension(3) :: Gaussian_centre + integer :: j,k,l + integer :: bin_j,bin_k,bin_l + + call system_initialise(PRINT_SILENT) + call verbosity_push(PRINT_NORMAL) + + call initialise(params_in) + call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'NumBins', param_mandatory, numbins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'from', '0', from, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(params_in)) then + if (EXEC_NAME == '') then + call print_usage + else + call print_usage(EXEC_NAME) + end if + call system_abort('could not parse argument line') + end if + call finalise(params_in) + + call print('Run_parameters: ') + call print('==================================') + call print(' Input file: '//trim(xyzfilename)) + call print(' Output file: '//trim(datafilename)) + call print(' NumBins: '//numbins) + call print(' decimation: '//decimation) + if (decimation == 1) then + call print(' Processing every frame') + else + write(line,'(a,i0,a,a)')' Processing every ',decimation,th(decimation),' frame' + call print(line) + end if + call print(' from Frame: '//from) + call print(' to Frame: '//to) + call print(' IO_Rate: '//IO_Rate) + call print(' Gaussians: '//Gaussian_smoothing) + if (Gaussian_smoothing) call print(' sigma: '//round(Gaussian_sigma,3)) + call print('==================================') + call print('') + + call initialise(xyzfile,trim(xyzfilename),action=INPUT) + if (Gaussian_smoothing.and.(Gaussian_sigma.le.0._dp)) call system_abort('sigma must be > 0._dp') + + call read_xyz(at,xyzfile,status=status) + call get_lattice_params(at%lattice,a,b,c,alpha,beta,gamma) + + allocate( mass_cuml(numbins,numbins,numbins) ) + + mass_cuml = 0.0_dp + + call print('grid size '//numbins//'x'//numbins//'x'//numbins) + + cellvol = abs(matrix3x3_det(at%lattice)) / real(numbins*numbins*numbins,dp) + + call print('Subcell volume = '//round(cellvol,6)//'A^3') + + call print('Reading data...') + + frame_count = 0 + frames_processed = 0 + + do + + if (status/=0) exit + + !Skip ahead (decimation-1) frames in the xyz file + frame_count = frame_count + 1 + do i = 1, (decimation-1) + call read_xyz(xyzfile,status) + if (status/=0) exit + frame_count = frame_count + 1 + end do + + write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',frame_count + + if (frame_count.gt.from) then + if ((frame_count.gt.to).and.(to.ne.0)) exit + call calc_connect(at) + call map_into_cell(at) + + !spatial binning of the cell + if (Gaussian_smoothing) then + increment = at%lattice .mult. (/1.0_dp/real(numbins,dp),1.0_dp/real(numbins,dp),1.0_dp/real(numbins,dp)/) + x_min_bin = -0.5*at%lattice(1,1) + y_min_bin = -0.5*at%lattice(2,2) + z_min_bin = -0.5*at%lattice(3,3) + endif + + do i = 1, at%N + + !calculate bin / central bin of the Gaussian + t = at%g .mult. at%pos(:,i) + box_a = floor(real(numbins,dp) * (t(1)+0.5_dp)) + 1 + box_b = floor(real(numbins,dp) * (t(2)+0.5_dp)) + 1 + box_c = floor(real(numbins,dp) * (t(3)+0.5_dp)) + 1 + + if (.not.Gaussian_smoothing) then + + mass_cuml(box_a,box_b,box_c) = mass_cuml(box_a,box_b,box_c) + ElementMass(at%Z(i)) + + else + + !binning is centred around the Gaussian + Gaussian_centre = at%pos(1:3,i) + + do j=int(real(box_a,dp)+real(numbins,dp)/2._dp)-numbins+1,int(real(box_a,dp)+real(numbins,dp)/2._dp) + + !calculate bin in the range of [1:numbins] + bin_j = mod(j+numbins,numbins) + if (bin_j.eq.0) bin_j = numbins + + do k=int(real(box_b,dp)+real(numbins,dp)/2._dp)-numbins+1,int(real(box_b,dp)+real(numbins,dp)/2._dp) + + !calculate bin in the range of [1:numbins] + bin_k = mod(k+numbins,numbins) + if (bin_k.eq.0) bin_k = numbins + + do l=int(real(box_c,dp)+real(numbins,dp)/2._dp)-numbins+1,int(real(box_c,dp)+real(numbins,dp)/2._dp) + + !calculate bin in the range of [1:numbins] + bin_l = mod(l+numbins,numbins) + if (bin_l.eq.0) bin_l = numbins + + !spatial coordinates of this bin + x_min = x_min_bin + real(j-1,dp)*increment(1) + y_min = y_min_bin + real(k-1,dp)*increment(2) + z_min = z_min_bin + real(l-1,dp)*increment(3) + x_max = x_min + increment(1) + y_max = y_min + increment(2) + z_max = z_min + increment(3) + + !add the integral of the Gaussian on the range [x_min,y_min,z_min:x_max,y_max,z_max] + mass_cuml(bin_j,bin_k,bin_l) = mass_cuml(bin_j,bin_k,bin_l) + ElementMass(at%Z(i)) * & + 0.5_dp * ( - erf((x_min-Gaussian_centre(1))/(Gaussian_sigma*sqrt(2.0_dp))) + erf((x_max-Gaussian_centre(1))/(Gaussian_sigma*sqrt(2.0_dp))) ) * & + 0.5_dp * ( - erf((y_min-Gaussian_centre(2))/(Gaussian_sigma*sqrt(2.0_dp))) + erf((y_max-Gaussian_centre(2))/(Gaussian_sigma*sqrt(2.0_dp))) ) * & + 0.5_dp * ( - erf((z_min-Gaussian_centre(3))/(Gaussian_sigma*sqrt(2.0_dp))) + erf((z_max-Gaussian_centre(3))/(Gaussian_sigma*sqrt(2.0_dp))) ) + + enddo + enddo + enddo + + endif + end do + + if (mod(frame_count-from,IO_RATE)==0) call write_data + endif + + !Try to read another frame + call read_xyz(at,xyzfile,status=status) + + if (status.ne.0) then + exit + endif + + end do + + call print('') + call write_data + call print('Read '//frame_count//' frames') + + !Free up memory + call finalise(at) + call finalise(xyzfile) + + deallocate(mass_cuml) + + call print('Finished.') + +! call verbosity_pop + call system_finalise + +contains + + subroutine print_usage(name) + + character(*), optional, intent(in) :: name + + if (present(name)) then + write(line,'(3a)')'Usage: ',trim(name),' xyzfile datafile NumBins [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' + else + write(line,'(a)')'Usage: density xyzfile datafile NumBins [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' + end if + call print(line) + call print(' The input xyz file.') + call print(' The output data file.') + call print(' The number of bins in the cell.') + call print(' Optional. Only process 1 out of every n frames.') + call print(' Optional. Only process frames from this frame.') + call print(' Optional. Only process frames until this frame.') + call print(' Optional. Write data after every n processed frames.') + call print(' Optional. Use Gaussians instead of delta functions.') + call print(' Optional. The sigma is the sqrt(variance) of the Gaussian function.') + call print('') + call print('Pressing Ctrl-C during execution will leave the output file with the rdf averaged over the frames read so far') + call print('') + + !call verbosity_pop + call system_finalise + stop + + end subroutine print_usage + + subroutine write_data + + integer :: i, j, k + real(dp) :: density + + call initialise(datafile,trim(datafilename),action=OUTPUT) + + do k = 1, numbins + t(3) = (real(k,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp + do j = 1, numbins + t(2) = (real(j,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp + do i = 1, numbins + t(1) = (real(i,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp + r = at%lattice .mult. t + density = mass_cuml(i,j,k) / (cellvol * real(frame_count-from,dp)) + density = density * abs(matrix3x3_det(at%lattice)) / sum(ElementMass(at%Z(1:at%N))) + call print(r//' '//density,file=datafile) + end do + call print('',file=datafile) + end do + call print('',file=datafile) + end do + + call finalise(datafile) + + call initialise(datafile2,trim(datafilename)//'_smooth',action=OUTPUT) + do k = 1, numbins + t(3) = (real(k,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp + do j = 1, numbins + t(2) = (real(j,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp + do i = 1, numbins + t(1) = (real(i,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp + r = at%lattice .mult. t + density = 0.125_dp * ( mass_cuml(i,j,k) + mass_cuml(numbins+1-i,j,k) + & + mass_cuml(i,numbins+1-j,k) + mass_cuml(numbins+1-i,numbins+1-j,k) + & + mass_cuml(i,j,numbins+1-k) + mass_cuml(numbins+1-i,j,numbins+1-k) + & + mass_cuml(i,numbins+1-j,numbins+1-k) + mass_cuml(numbins+1-i,numbins+1-j,numbins+1-k) ) & + / (cellvol * real(frame_count-from,dp)) + density = density * abs(matrix3x3_det(at%lattice)) / sum(ElementMass(at%Z(1:at%N))) + call print(r//' '//density,file=datafile2) + end do + call print('',file=datafile2) + end do + call print('',file=datafile2) + end do + call finalise(datafile2) + + end subroutine write_data + +end program density diff --git a/src/Structure_processors/density_1d.F90 b/src/Structure_processors/density_1d.F90 new file mode 100644 index 0000000000..6c2ae43b6c --- /dev/null +++ b/src/Structure_processors/density_1d.F90 @@ -0,0 +1,633 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! Calculates density of a certain element in 1D around the origin +! + +#include "error.inc" + +program density_1d + + use system_module, only : th + use libatoms_module +#ifdef NEED_ERF + use functions_module, only : erf +#endif + + implicit none + + integer, parameter :: DISTANCES_INIT = 1000000 + integer, parameter :: DISTANCES_INCR = 1000000 + + type(atoms_ll) :: structure_ll + type(atoms_ll_entry), pointer :: structure_ll_entry + type(Atoms), pointer :: structure + type(Atoms) :: structure_in + type(Table) :: distances, atom_table + real(dp) :: d + type(Inoutput) :: xyzfile, datafile, xyzfile_list + type(CInoutput) :: cxyzfile + integer :: frame_count, frames_processed, frames_processed_intermed + integer :: status + integer :: error = ERROR_NONE + integer :: i, j + + !Input + type(Dictionary) :: params_in + character(STRING_LENGTH) :: xyzfilename, datafilename + logical :: xyzfile_is_list + real(dp) :: l_cutoff, bin_width + character(STRING_LENGTH) :: mask + integer :: IO_Rate, Density_Time_Evolution_Rate + integer :: decimation + integer :: from, to + real(dp) :: min_time, max_time + logical :: Gaussian_smoothing + real(dp) :: Gaussian_sigma + + !AtomMask processing + character(30) :: prop_name + logical :: list, prop + integer :: prop_val + integer :: Zb + + !Histogram & its integration/normalisation + real(dp), allocatable, dimension(:,:) :: data, data_intermed + real(dp), allocatable, dimension(:) :: hist, hist_sum, hist_sum_intermed + integer :: num_bins, num_atoms + real(dp) :: hist_int, hist_int_intermed + real(dp) :: density, r, dV + logical :: first_time, skip_frame + integer :: last_file_frame_n + real(dp) :: cur_time + + type(Table) :: density_bins !densities of each bin for all the unskipped structure + type(Table) :: density_bins_intermed !densities of each bin for all the unskipped structure + real(dp), allocatable, dimension(:) :: means, sds + logical :: do_statistics + + !Start up LOTF, suppressing messages + call system_initialise(PRINT_NORMAL) + +#ifdef DEBUG + call print('********** DEBUG BUILD **********') + call print('') +#endif + + call initialise(params_in) + call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'xyzfile_is_list', 'F', xyzfile_is_list, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'AtomMask', param_mandatory, mask, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'Cutoff', param_mandatory, l_cutoff, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'BinWidth', param_mandatory, bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'from', '0', from, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'Density_Time_Evolution_Rate', '0', Density_Time_Evolution_Rate, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'do_statistics', 'F', do_statistics, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(params_in)) then + if (EXEC_NAME == '') then + call print_usage + else + call print_usage(EXEC_NAME) + end if + call system_abort('could not parse argument line') + end if + call finalise(params_in) + + call print('Run_parameters: ') + call print('==================================') + call print(' Input file: '//trim(xyzfilename)) + call print(' Input file is list: '//xyzfile_is_list) + call print(' Output file: '//trim(datafilename)) + call print(' AtomMask: '//trim(mask)) + call print(' Cutoff: '//round(l_Cutoff,3)) + call print(' BinWidth: '//round(bin_width,3)) + call print(' decimation: '//decimation) + if (decimation == 1) then + call print(' Processing every frame') + else + write(line,'(a,i0,a,a)')' Processing every ',decimation,th(decimation),' frame' + call print(line) + end if + call print(' from Frame: '//from) + call print(' to Frame: '//to) + call print(' min_time: '//min_time) + call print(' max_time: '//max_time) + call print(' IO_Rate: '//IO_Rate) + call print(' Density_Time_Evolution_Rate: '//Density_Time_Evolution_Rate) + if (IO_Rate > 0 .and. Density_Time_Evolution_Rate > 0) then + call print('WARNING: IO_Rate = ' // IO_Rate // ' will effectively override Density_Time_Evolution_Rate='//Density_Time_Evolution_Rate, PRINT_ALWAYS) + endif + call print(' Gaussians: '//Gaussian_smoothing) + if (Gaussian_smoothing) call print(' sigma: '//round(Gaussian_sigma,3)) + call print(' do_statistics: '//do_statistics) + call print('==================================') + call print('') + + ! + ! Read the element symbol / atom mask + ! + call print('Mask 2:') + call print('=======') + if (mask(1:1)=='@') then + list = .true. + prop = .false. + call parse_atom_mask(mask,atom_table) + else if (scan(mask,'=')/=0) then + list = .true. + prop = .true. + call get_prop_info(mask, prop_name, prop_val) + call print('') + call print('Selecting all atoms that have '//trim(prop_name)//' set to '//prop_val) + call print('') + else + list = .false. + prop = .false. + Zb = Atomic_Number(mask) + call print('') + write(line,'(a,i0,a)')'Selecting all '//trim(ElementName(Zb))//' atoms (Z = ',Zb,')' + call print(line) + call print('') + end if + + if (l_cutoff < 0.0_dp) call system_abort('Cutoff < 0.0 Angstroms') + if (bin_width < 0.0_dp) call system_abort('Bin width < 0.0 Angstroms') + if (Gaussian_smoothing.and.(Gaussian_sigma.le.0._dp)) call system_abort('sigma must be > 0._dp') + + !Make num_bins and bin_width consistent + num_bins = ceiling(l_cutoff / bin_width) + bin_width = l_cutoff / real(num_bins,dp) + if (do_statistics) call initialise(density_bins,0,num_bins,0,0,0) + if (do_statistics) call initialise(density_bins_intermed,0,num_bins,0,0,0) + + allocate( hist(num_bins), hist_sum(num_bins), hist_sum_intermed(num_bins)) + if (do_statistics) then + allocate(data(num_bins,4), data_intermed(num_bins,4) ) + allocate(means(num_bins), sds(num_bins)) + else + allocate(data(num_bins,3), data_intermed(num_bins,3) ) + endif + + hist = 0.0_dp + hist_sum = 0.0_dp + hist_int = 0.0_dp + + !Set up the x coordinates of the plot + do i = 1, num_bins + data_intermed(i,1) = (real(i,dp) - 0.5_dp) * bin_width + end do + data(:,1) = data_intermed(:,1) + + call print('') + write(line,'(i0,a,f0.4,a,f0.4,a)') num_bins,' bins x ',bin_width,' Angstroms per bin = ',l_cutoff,' Angstroms cutoff' + call print(line) + call print('') + + call print('Reading data...') + + ! initialize frame counters + frames_processed = 0 + frames_processed_intermed = 0 + + + + status = 0 + if (from > 0) then + frame_count = from + else + frame_count = 1 + endif + last_file_frame_n = 0 + + if (xyzfile_is_list) then + call initialise(xyzfile_list, trim(xyzfilename), INPUT) + xyzfilename = read_line(xyzfile_list, status) + if (status /= 0) call finalise(xyzfile_list) + endif + + do while (status == 0) ! loop over files + call initialise(cxyzfile,trim(xyzfilename),action=INPUT) + status = 0 + do while ((to <= 0 .or. frame_count <= to) .and. status == 0) + write(mainlog%unit,'(4a,i0,a,i0,$)') achar(13), 'Read file ',trim(xyzfilename), ' Frame ',frame_count,' which in this file is frame (zero based) ',(frame_count-1-last_file_frame_n) + call read(cxyzfile, structure_in, frame=frame_count-1-last_file_frame_n, error=error) + if (error == ERROR_NONE) then + skip_frame = .false. + if (min_time > 0.0_dp .or. max_time > 0.0_dp) then + if (get_value(structure_in%params,"Time",cur_time)) then + if ((min_time >= 0.0_dp .and. cur_time < min_time) .or. & + (max_time >= 0.0_dp .and. cur_time > max_time)) skip_frame = .true. + else + call system_abort("ERROR: min_time="//min_time//" > 0 but Time field wasn't found in config " // frame_count) + endif + endif + if (.not. skip_frame) then + call new_entry(structure_ll, structure) + call atoms_copy_without_connect(structure, structure_in, properties="pos:Z") + else + write (mainlog%unit,'(a,$)') " skip" + endif + frame_count = frame_count + decimation + else + call clear_error(error) + status = 1 + endif + end do + last_file_frame_n = frame_count - 1 + call finalise(cxyzfile) + + if (xyzfile_is_list) then + xyzfilename = read_line(xyzfile_list, status) + if (status /= 0) call finalise(xyzfile_list) + else + status = 1 + endif + + end do + + call allocate(distances,0,1,0,0,DISTANCES_INIT) + call set_increment(distances,DISTANCES_INCR) + + first_time=.true. + + structure_ll_entry => structure_ll%first + + frame_count = from + if (min_time > 0.0_dp) call print("WARNING: min_time > 0, frame_count will be wrong if frames were skipped", PRINT_ALWAYS) + + do while (associated(structure_ll_entry)) + + structure => structure_ll_entry%at + + write(mainlog%unit,'(a,a,i0,$)') achar(13),'Processing Frame ',frame_count + + if (prop) call list_matching_prop(structure,atom_table,trim(prop_name),prop_val) + + call wipe(distances) + + num_atoms = 0 + + hist = 0.0_dp + do j = 1, structure%N + + !Count the atoms + if (list) then + if (find(atom_table,j)/=0) num_atoms = num_atoms + 1 + else + if (structure%Z(j) == Zb) num_atoms = num_atoms + 1 + end if + + !Do we have a "Mask" atom? Cycle if not + if (list) then + if (find(atom_table,j)==0) cycle + else + if (structure%Z(j) /= Zb) cycle + end if + + d = distance_min_image(structure,j,(/0._dp,0._dp,0._dp/)) + if (d < l_cutoff+3.0*Gaussian_sigma) then +#ifdef DEBUG + call print('Storing distance (/0,0,0/)--'//j//' = '//round(d,5)//'A') +#endif + !Add this distance to the list + call accum_histogram(hist, d, 0.0_dp, l_cutoff, num_bins, Gaussian_smoothing, Gaussian_sigma) + end if + end do + + + frames_processed = frames_processed + 1 + frames_processed_intermed = frames_processed_intermed + 1 + +#ifdef DEBUG + call print('Number of atoms = '//num_atoms) +#endif + + !Calculate B atom density + density = real(num_atoms,dp) / cell_volume(structure) + + !Normalise histogram + do i = 1, num_bins + r = (real(i,dp) - 1._dp) * bin_width + dV = 4.0_dp * PI * (r*r + r*bin_width + bin_width*bin_width/3.0_dp ) * bin_width + hist(i) = hist(i) / (dV * density * 1._dp) + end do + + !Accumulate the data + hist_sum = hist_sum + hist + hist_sum_intermed = hist_sum_intermed + hist + if (do_statistics) then +!call print('Append '//hist(1:num_bins)) + call append(density_bins,realpart=hist(1:num_bins)) + call append(density_bins_intermed,realpart=hist(1:num_bins)) + endif + + !copy the current averages into the y coordinates of the plot + data(:,2) = hist_sum / real(frames_processed,dp) + data_intermed(:,2) = hist_sum_intermed / real(frames_processed_intermed,dp) + + !integrate the average data + hist_int = 0.0_dp + hist_int_intermed = 0.0_dp + do i = 1, num_bins + r = data(i,1) + dV = PI * (4.0_dp * r*r + bin_width*bin_width/3.0_dp) * bin_width + hist_int = hist_int + data(i,2)*dV*density + data(i,3) = hist_int + hist_int_intermed = hist_int_intermed + data_intermed(i,2)*dV*density + data_intermed(i,3) = hist_int_intermed + end do + + !calculate the standard deviation to print in the 4th column + if (do_statistics) then + !intermed + means = 0._dp !should be equal to data_intermed(:,2) + sds = 0._dp + do i=1,num_bins !calc +!call print('Raw data:'//density_bins_intermed%real(i,1:density_bins_intermed%N)) + call calc_stat(density_bins_intermed%real(i,1:density_bins_intermed%N),means(i),sds(i)) +!call print(i//' mean: '//means(i)//' SD: '//sds(i)) + enddo + data_intermed(1:num_bins,4) = sds(1:num_bins) + !accumulated + means = 0._dp !should be equal to data(:,2) + sds = 0._dp + do i=1,num_bins !calc +!call print('Raw data:'//density_bins%real(i,1:density_bins%N)) + call calc_stat(density_bins%real(i,1:density_bins%N),means(i),sds(i)) +!call print(i//' mean: '//means(i)//' SD: '//sds(i)) + enddo + data(1:num_bins,4) = sds(1:num_bins) + endif + + if (Density_Time_Evolution_Rate > 0) then + if (mod(frames_processed,Density_Time_Evolution_Rate)==0) then + if (first_time) then + call initialise(datafile,datafilename,action=OUTPUT) + first_time = .false. + else + call initialise(datafile,datafilename,action=OUTPUT,append=.true.) + call print('',file=datafile) + call print('',file=datafile) + endif + call print('# Density 1D',file=datafile) + call print('# Input file: '//trim(xyzfilename),file=datafile) + call print('# Frames read = '//frame_count,file=datafile) + call print('# Frames processed = '//frames_processed,file=datafile) + call print(data_intermed,file=datafile) + call finalise(datafile) + hist_sum_intermed = 0.0_dp + frames_processed_intermed = 0.0_dp + endif + endif + + !Write the current data. This allows the user to Ctrl-C after a certain number + !of frames if things are going slowly + if (IO_Rate > 0) then + if (mod(frames_processed,IO_Rate)==0) then + call initialise(datafile,datafilename,action=OUTPUT) + call print('# Density 1D',file=datafile) + call print('# Input file: '//trim(xyzfilename),file=datafile) + call print('# Frames read = '//frame_count,file=datafile) + call print('# Frames processed = '//frames_processed,file=datafile) + call print(data,file=datafile) + call finalise(datafile) + endif + endif + + !Try to read another frame + structure_ll_entry => structure_ll_entry%next + frame_count = frame_count + decimation + + end do + + frame_count = frame_count - decimation + + if (Density_Time_Evolution_Rate > 0) then + call initialise(datafile,datafilename,action=OUTPUT,append=.true.) + call print('',file=datafile) + call print('',file=datafile) + else + call initialise(datafile,datafilename,action=OUTPUT) + endif + call print('# Final Density 1D',file=datafile) + call print('# Input file: '//trim(xyzfilename),file=datafile) + call print('# Frames read = '//frame_count,file=datafile) + call print('# Frames processed = '//frames_processed,file=datafile) + call print(data,file=datafile) + call finalise(datafile) + + call print('') + call print('Read '//frame_count//' frames, processed '//frames_processed//' frames.') + + !Free up memory + call finalise(distances) + call finalise(structure_in) + call finalise(xyzfile) + + deallocate(hist, hist_sum, data) + + call print('Finished.') + + !call verbosity_pop + call system_finalise + +contains + + subroutine accum_histogram(hist, d, minx, maxx, num_bins, gaussian_smoothing, sigma) + real(dp), intent(inout) :: hist(:) + real(dp) :: d, minx, maxx + integer :: num_bins + logical :: gaussian_smoothing + real(dp) :: sigma + + real(dp), allocatable :: hist_t(:) + real(dp), allocatable :: d_a(:), w_a(:) + real(dp) :: px, py, pz + integer :: ix, iy, iz, io + integer :: n_samples = 20 + real(dp) :: n_samples_d, normalization + real(dp) :: range + + range = 3.0_dp*sigma + normalization=((2.0*range/real(n_samples,dp))**3)/(sigma*sqrt(PI))**3 + + n_samples_d = real(n_samples/2,dp) + allocate(hist_t(size(hist))) + + if (gaussian_smoothing) then + allocate(d_a((n_samples+1)**3)) + allocate(w_a((n_samples+1)**3)) + do ix=1, n_samples+1 + px = real(ix-1-(n_samples/2), dp)/n_samples_d*range + do iy=1, n_samples+1 + py = real(iy-1-(n_samples/2), dp)/n_samples_d*range + do iz=1, n_samples+1 + pz = real(iz-1-(n_samples/2), dp)/n_samples_d*range + io = (ix-1)*(n_samples+1)**2 + (iy-1)*(n_samples+1) + (iz-1) + 1 + d_a(io) = sqrt((px+d)**2+py**2+pz**2) + w_a(io) = normalization*exp(-(px**2+py**2+pz**2)/sigma**2) + end do + end do + end do + hist_t = histogram(d_a, minx, maxx, num_bins, weight_vector=w_a, drop_outside=.true.) + deallocate(d_a) + deallocate(w_a) + else + hist_t = histogram((/d/), minx, maxx, num_bins, drop_outside=.true.) + endif + hist = hist + hist_t + deallocate(hist_t) + + end subroutine accum_histogram + + subroutine print_usage(name) + + character(*), optional, intent(in) :: name + + if (present(name)) then + write(line,'(3a)')'Usage: ',trim(name),' xyzfile datafile AtomMask Cutoff BinWidth [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' + else + write(line,'(a)')'Usage: density_1d xyzfile datafile AtomMask Cutoff BinWidth [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' + end if + call print(line) + call print(' The input xyz file.') + call print(' An element symbol, e.g. H or Ca, or @ followed by a list of indices/ranges, e.g. @1-35,45,47,50-99 or property=value') + call print(' The cutoff radius in Angstroms.') + call print(' The width of each bin in Angstroms.') + call print(' The output data file.') + call print(' Optional. Only process 1 out of every n frames.') + call print(' Optional. Only process frames from this frame.') + call print(' Optional. Only process frames until this frame.') + call print(' Optional. Write data after every n processed frames.') + call print(' Optional. Compute separate densities for each n processed frames (overriden if IO_Rate > 0)') + call print(' Optional. Use Gaussians instead of delta functions.') + call print(' Optional. The sigma is the sqrt(variance) of the Gaussian function.') + call print(' Optional. If true, use FORTRAN I/O. Slower, but might not work for stdin otherwise') + call print('') + call print('Pressing Ctrl-C during execution will leave the output file with the rdf averaged over the frames read so far') + call print('') + + !call verbosity_pop + call system_finalise + stop + + end subroutine print_usage + + subroutine get_prop_info(mask,name,value) + + character(*), intent(in) :: mask + character(*), intent(out) :: name + integer, intent(out) :: value + integer :: delimiter + + delimiter = scan(mask,'=') + if (delimiter > 1) then + name = adjustl(mask(1:delimiter-1)) + value = string_to_int(mask(delimiter+1:len_trim(mask))) + else + call system_abort('Zero length property name in mask: "'//trim(mask)//'"') + end if + + end subroutine get_prop_info + + function Gaussian_histogram(vector,min_x,max_x,Nbin,Gaussian,sigma) + + real(dp), dimension(:), intent(in) :: vector + real(dp), intent(in) :: min_x, max_x + integer, intent(in) :: Nbin + logical, intent(in) :: Gaussian + real(dp), intent(in) :: sigma + real(dp), dimension(Nbin) :: Gaussian_histogram + !local variables + real(dp) :: binsize,min_bin,max_bin + integer :: i, bin, j + + if(max_x <= min_x) then + call system_abort('Vector_Histogram: max_x < min_x') + end if + + binsize=(max_x-min_x)/(real(Nbin,dp)) + Gaussian_histogram = 0.0_dp + + do i=1,size(vector) +! call print('') +! call print('Distribution of vector '//i//' over the whole histogram:') + + if (Gaussian) then +! if(.not.present(sigma)) call system_abort('Gaussian_histogram: Missing Gaussian sigma parameter.') + do j=1,Nbin + min_bin = min_x + real(j-1,dp) * binsize + max_bin = min_bin + binsize +! call print('min_bin: '//min_bin//', max_bin: '//max_bin) +! call print('ERF(min_bin) = '//erf((vector(i)-min_bin)/(sigma*sqrt(2._dp)))) +! call print('ERF(max_bin) = '//erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp)))) +! call print('Adding to bin '//j//' '//(erf((vector(i)-min_bin)/(sigma*sqrt(2._dp))) + erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp))))) + Gaussian_histogram(j) = Gaussian_histogram(j) - 0.5_dp*erf((min_bin-vector(i))/(sigma*sqrt(2._dp))) + 0.5_dp*erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp))) + enddo + else + bin = ceiling((vector(i)-min_x)/binsize) + if (bin < 1) bin = 1 + if (bin > Nbin) bin = Nbin + Gaussian_histogram(bin) = Gaussian_histogram(bin) + 1.0_dp + endif + end do + + end function Gaussian_histogram + + subroutine calc_stat(data,mean,sd) + + real(dp), dimension(:), intent(in) :: data + real(dp), intent(out) :: mean,sd + + integer :: i + + mean = 0._dp + sd = 0._dp + + do i=1,size(data) + mean = mean + data(i) + enddo + mean = mean / size(data) + + do i=1,size(data) + sd = sd + (data(i)-mean)**2.0_dp + enddo + sd = sqrt(sd/size(data)) + + end subroutine calc_stat + +end program density_1d diff --git a/src/Structure_processors/density_KDE.F90 b/src/Structure_processors/density_KDE.F90 new file mode 100644 index 0000000000..76337eb5a0 --- /dev/null +++ b/src/Structure_processors/density_KDE.F90 @@ -0,0 +1,701 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! Calculates density of a certain element in 1D around the origin +! + +program density_KDE + + use libatoms_module +#ifdef NEED_ERF + use functions_module, only : erf +#endif + + implicit none + + integer, parameter :: DISTANCES_INIT = 1000000 + integer, parameter :: DISTANCES_INCR = 1000000 + + type(atoms_ll) :: structure_ll + type(atoms_ll_entry), pointer :: structure_ll_entry + type(Atoms), pointer :: structure + type(Atoms) :: structure_in + type(Table) :: distances, distances_intermed, atom_table + real(dp) :: d + type(Inoutput) :: xyzfile, datafile, xyzfile_list + type(CInoutput) :: cxyzfile + integer :: frame_count, frames_processed, frames_processed_intermed + integer :: status + integer :: i, j + + !Input + type(Dictionary) :: params_in + character(STRING_LENGTH) :: xyzfilename, datafilename + logical :: xyzfile_is_list + real(dp) :: cutoff, bin_width + character(STRING_LENGTH) :: mask + integer :: IO_Rate, Density_Time_Evolution_Rate + integer :: decimation + integer :: from, to + real(dp) :: min_time, max_time + logical :: Gaussian_smoothing + real(dp) :: Gaussian_sigma + logical :: fortran_io + + !AtomMask processing + character(30) :: prop_name + logical :: list, prop + integer :: prop_val + integer :: Zb + + !Histogram & its integration/normalisation + real(dp), allocatable, dimension(:,:) :: data, data_intermed + real(dp), allocatable, dimension(:) :: hist, hist_sum, hist_sum_intermed + integer :: num_bins, num_atoms + real(dp) :: hist_int, hist_int_intermed + real(dp) :: density, r, dV + logical :: first_time, skip_frame + integer :: last_file_frame_n + real(dp) :: cur_time + + + !Start up LOTF, suppressing messages + call system_initialise(PRINT_NORMAL) + +#ifdef DEBUG + call print('********** DEBUG BUILD **********') + call print('') +#endif + + call initialise(params_in) + call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'xyzfile_is_list', 'F', xyzfile_is_list, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'AtomMask', param_mandatory, mask, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'Cutoff', param_mandatory, cutoff, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'NumBins', param_mandatory, num_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'from', '0', from, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'Density_Time_Evolution_Rate', '0', Density_Time_Evolution_Rate, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'fortran_io', 'F', fortran_io, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(params_in)) then + if (EXEC_NAME == '') then + call print_usage + else + call print_usage(EXEC_NAME) + end if + call system_abort('could not parse argument line') + end if + call finalise(params_in) + + call print('Run_parameters: ') + call print('==================================') + call print(' Input file: '//trim(xyzfilename)) + call print(' Input file is list: '//xyzfile_is_list) + call print(' Output file: '//trim(datafilename)) + call print(' AtomMask: '//trim(mask)) + call print(' Cutoff: '//round(Cutoff,3)) + call print(' NumBins: '//num_bins) + call print(' decimation: '//decimation) + if (decimation == 1) then + call print(' Processing every frame') + else + write(line,'(a,i0,a,a)')' Processing every ',decimation,th(decimation),' frame' + call print(line) + end if + call print(' from Frame: '//from) + call print(' to Frame: '//to) + call print(' IO_Rate: '//IO_Rate) + call print(' Density_Time_Evolution_Rate: '//Density_Time_Evolution_Rate) + if (IO_Rate > 0 .and. Density_Time_Evolution_Rate > 0) then + call print('WARNING: IO_Rate = ' // IO_Rate // ' will effectively override Density_Time_Evolution_Rate='//Density_Time_Evolution_Rate, PRINT_ALWAYS) + endif + call print(' Gaussians: '//Gaussian_smoothing) + if (Gaussian_smoothing) call print(' sigma: '//round(Gaussian_sigma,3)) + call print('==================================') + call print('') + + ! + ! Read the element symbol / atom mask + ! + call print('Mask 2:') + call print('=======') + if (mask(1:1)=='@') then + list = .true. + prop = .false. + call parse_atom_mask(mask,atom_table) + else if (scan(mask,'=')/=0) then + list = .true. + prop = .true. + call get_prop_info(mask, prop_name, prop_val) + call print('') + call print('Selecting all atoms that have '//trim(prop_name)//' set to '//prop_val) + call print('') + else + list = .false. + prop = .false. + Zb = Atomic_Number(mask) + call print('') + write(line,'(a,i0,a)')'Selecting all '//trim(ElementName(Zb))//' atoms (Z = ',Zb,')' + call print(line) + call print('') + end if + + if (cutoff < 0.0_dp) call system_abort('Cutoff < 0.0 Angstroms') + if (num_bins < 0) call system_abort('NumBins < 0 ') + bin_width = cutoff / real(num_bins,dp) + + + allocate( hist(num_bins), hist_sum(num_bins), hist_sum_intermed(num_bins) ) + allocate(data(num_bins,3), data_intermed(num_bins,3) ) + + data = 0._dp + data_intermed = 0._dp + + hist = 0.0_dp + hist_sum = 0.0_dp + hist_int = 0.0_dp + + !Set up the x coordinates of the plot -- in distance bins (can easily be plotted as a fn of volume) + do i = 1, num_bins + data_intermed(i,1) = bin_width * (real(i,dp)) + end do + data(:,1) = data_intermed(:,1) + + call print('') + write(line,'(i0,a,f0.4,a,f0.4,a)') num_bins,' bins x ',bin_width,' Angstroms per bin = ',cutoff,' Angstroms cutoff' + call print(line) + call print('') + + call print('Reading data...') + + ! initialize frame counters + frames_processed = 0 + frames_processed_intermed = 0 + + if (fortran_io) then + if (xyzfile_is_list) call system_abort("ERROR: xyzfile_is_list is not supported with fortran I/O") + call initialise(xyzfile,xyzfilename,action=INPUT) + status = 0 + frame_count = 0 + do while (frame_count < from-1) + frame_count = frame_count + 1 + call read_xyz(xyzfile,status) + if (status/=0) exit + end do + + ! read rest of configs, skipping decimation related ones, put in structure_ll + do while (status == 0 .and. (to <= 0 .or. frame_count < to)) + frame_count = frame_count + 1 + write(mainlog%unit,'(a,a,i0,$)') achar(13),'Read Frame ',frame_count + call read_xyz(structure_in, xyzfile, status=status) + skip_frame = .false. + if (min_time > 0.0_dp .or. max_time > 0.0_dp) then + if (get_value(structure_in%params,"Time",cur_time)) then + if (cur_time < min_time .or. cur_time > max_time) skip_frame = .true. + else + call system_abort("ERROR: min_time="//min_time//" > 0.0 or max_time="//max_time//" > 0.0, but Time field wasn't found in config " // frame_count) + endif + endif + if (.not. skip_frame) then +! call new_entry(structure_ll, structure) + call atoms_ll_new_entry2(structure_ll, structure) + call atoms_copy_without_connect(structure, structure_in, properties="pos:Z") + endif + if (to > 0 .and. frame_count >= to) then + exit + endif + + do i=1, (decimation-1) + frame_count = frame_count + 1 + call read_xyz(xyzfile, status) + if (status /= 0) exit + end do + end do + + if (status /= 0) then + call remove_last_entry(structure_ll) + endif + + call finalise(xyzfile) + + else ! not fortran I/O, i.e. C + + status = 0 + if (from > 0) then + frame_count = from + else + frame_count = 1 + endif + last_file_frame_n = 0 + + if (xyzfile_is_list) then + call initialise(xyzfile_list, trim(xyzfilename), INPUT) + xyzfilename = read_line(xyzfile_list, status) + if (status /= 0) call finalise(xyzfile_list) + endif + + do while (status == 0) ! loop over files + call initialise(cxyzfile,trim(xyzfilename),action=INPUT) + status = 0 + do while ((to <= 0 .or. frame_count <= to) .and. status == 0) + write(mainlog%unit,'(4a,i0,a,i0,$)') achar(13), 'Read file ',trim(xyzfilename), ' Frame ',frame_count,' which in this file is frame (zero based) ',(frame_count-1-last_file_frame_n) + call read(cxyzfile, structure_in, frame=frame_count-1-last_file_frame_n, status=status) + if (status == 0) then + skip_frame = .false. + if (min_time > 0.0_dp .or. max_time > 0.0_dp) then + if (get_value(structure_in%params,"Time",cur_time)) then + if (cur_time < min_time .or. cur_time > max_time) skip_frame = .true. + else + call system_abort("ERROR: min_time="//min_time//" > 0 but Time field wasn't found in config " // frame_count) + endif + endif + if (.not. skip_frame) then +! call new_entry(structure_ll, structure) + call atoms_ll_new_entry2(structure_ll, structure) + call atoms_copy_without_connect(structure, structure_in, properties="pos:Z") + else + write (mainlog%unit,'(a,$)') " skip" + endif + frame_count = frame_count + decimation + endif + end do + last_file_frame_n = frame_count - 1 + call finalise(cxyzfile) + + if (xyzfile_is_list) then + xyzfilename = read_line(xyzfile_list, status) + if (status /= 0) call finalise(xyzfile_list) + else + status = 1 + endif + + end do + + endif ! fortran I/O + + call allocate(distances,0,1,0,0,DISTANCES_INIT) + call set_increment(distances,DISTANCES_INCR) + call allocate(distances_intermed,0,1,0,0,DISTANCES_INIT) + call set_increment(distances_intermed,DISTANCES_INCR) + + first_time=.true. + + structure_ll_entry => structure_ll%first + + frame_count = from + if (min_time > 0.0_dp) call print("WARNING: min_time > 0, frame_count will be wrong if frames were skipped", PRINT_ALWAYS) + + do while (associated(structure_ll_entry)) + + structure => structure_ll_entry%at + + write(mainlog%unit,'(a,a,i0,$)') achar(13),'Processing Frame ',frame_count + + if (prop) call list_matching_prop(structure,atom_table,trim(prop_name),prop_val) + + num_atoms = 0 + call wipe(distances) + call wipe(distances_intermed) + + hist = 0.0_dp + do j = 1, structure%N + + !Count the atoms + if (list) then + if (find(atom_table,j)/=0) num_atoms = num_atoms + 1 + else + if (structure%Z(j) == Zb) num_atoms = num_atoms + 1 + end if + + !Do we have a "Mask" atom? Cycle if not + if (list) then + if (find(atom_table,j)==0) cycle + else + if (structure%Z(j) /= Zb) cycle + end if + + d = distance_min_image(structure,j,(/0._dp,0._dp,0._dp/)) + if (d < cutoff+3.0*Gaussian_sigma) then +#ifdef DEBUG + call print('Storing distance (/0,0,0/)--'//j//' = '//round(d,5)//'A') +#endif +! !Add this distance to the list + call append(distances,realpart=(/d/)) + call append(distances_intermed,realpart=(/d/)) + end if + end do + + + frames_processed = frames_processed + 1 + frames_processed_intermed = frames_processed_intermed + 1 + +#ifdef DEBUG + call print('Number of atoms = '//num_atoms) +#endif + + !Calculate B atom density + density = real(num_atoms,dp) / cell_volume(structure) + call print('Number of atoms = '//num_atoms) + call print('density: '//density) + call print('cell_volume: '//cell_volume(structure)) + !Normalise histogram +! do i = 1, num_bins +! hist(i) = hist(i) / (bin_width * density * 1._dp) +! end do + + !copy the current averages into the y coordinates of the plot + do i=1,num_bins + data(i,2) = data(i,2) + KDE_eval(distances%real(1,1:distances%N),data(i,1),Gaussian_sigma) / density !/ (4.0_dp * data(i,1)**2.0_dp * PI) + data_intermed(i,2) = data_intermed(i,2) + KDE_eval(distances_intermed%real(1,1:distances_intermed%N),data_intermed(i,1),Gaussian_sigma) / density !/ (4.0_dp * data_intermed(i,1)**2.0_dp * PI) + enddo +! data(:,2) = data(:,2) / real(frames_processed,dp) +! data_intermed(:,2) = data_intermed(:,2) / real(frames_processed_intermed,dp) + + !integrate the average data + hist_int = 0.0_dp + hist_int_intermed = 0.0_dp + do i = 1, num_bins + hist_int = hist_int + data(i,2) * bin_width * (4.0_dp * data(i,1)**2.0_dp * PI) *density + data(i,3) = hist_int + hist_int_intermed = hist_int_intermed + data_intermed(i,2) * bin_width * (4.0_dp * data_intermed(i,1)**2.0_dp * PI) *density + data_intermed(i,3) = hist_int_intermed + end do + + if (Density_Time_Evolution_Rate > 0) then + if (mod(frames_processed,Density_Time_Evolution_Rate)==0) then + if (first_time) then + call initialise(datafile,datafilename,action=OUTPUT) + first_time = .false. + else + call initialise(datafile,datafilename,action=OUTPUT,append=.true.) + call print('',file=datafile) + call print('',file=datafile) + endif + data_intermed(1:num_bins,2:3) = data_intermed(1:num_bins,2:3) / real(frames_processed_intermed,dp) + call print('# Kernel Density Estimation 1D',file=datafile) + call print('# Input file: '//trim(xyzfilename),file=datafile) + call print('# Frames read = '//frame_count,file=datafile) + call print('# Frames processed = '//frames_processed,file=datafile) + call print(data_intermed,file=datafile) + call finalise(datafile) +! hist_sum_intermed = 0.0_dp + data_intermed(1:num_bins,2:3) = 0._dp + frames_processed_intermed = 0 + endif + endif + + !Write the current data. This allows the user to Ctrl-C after a certain number + !of frames if things are going slowly + if (IO_Rate > 0) then + if (mod(frames_processed,IO_Rate)==0) then + call initialise(datafile,datafilename,action=OUTPUT) + data(1:num_bins,2:3) = data(1:num_bins,2:3) / real(frames_processed,dp) + call print('# Kernel Density Estimation 1D',file=datafile) + call print('# Input file: '//trim(xyzfilename),file=datafile) + call print('# Frames read = '//frame_count,file=datafile) + call print('# Frames processed = '//frames_processed,file=datafile) + call print(data,file=datafile) + call finalise(datafile) + data(1:num_bins,2:3) = data(1:num_bins,2:3) * real(frames_processed,dp) + endif + endif + + !Try to read another frame + structure_ll_entry => structure_ll_entry%next + frame_count = frame_count + decimation + + end do + + frame_count = frame_count - decimation + + if (Density_Time_Evolution_Rate > 0) then + call initialise(datafile,datafilename,action=OUTPUT,append=.true.) + call print('',file=datafile) + call print('',file=datafile) + else + call initialise(datafile,datafilename,action=OUTPUT) + endif + data(1:num_bins,2:3) = data(1:num_bins,2:3) / real(frames_processed,dp) + call print('# Final Kernel Density Estimation 1D',file=datafile) + call print('# Input file: '//trim(xyzfilename),file=datafile) + call print('# Frames read = '//frame_count,file=datafile) + call print('# Frames processed = '//frames_processed,file=datafile) + call print(data,file=datafile) + call finalise(datafile) + + call print('') + call print('Read '//frame_count//' frames, processed '//frames_processed//' frames.') + + !Free up memory + call finalise(distances) + call finalise(structure_in) + call finalise(xyzfile) + + deallocate(hist, hist_sum, data) + + call print('Finished.') + + !call verbosity_pop + call system_finalise + +contains + + subroutine accum_histogram(hist, d, minx, maxx, num_bins, gaussian_smoothing, sigma) + real(dp), intent(inout) :: hist(:) + real(dp) :: d, minx, maxx + integer :: num_bins + logical :: gaussian_smoothing + real(dp) :: sigma + + real(dp), allocatable :: hist_t(:) + real(dp), allocatable :: d_a(:), w_a(:) + real(dp) :: px, py, pz + integer :: ix, iy, iz, io + integer :: n_samples = 20 + real(dp) :: n_samples_d, normalization + real(dp) :: range + + range = 3.0_dp*sigma + normalization=((2.0*range/real(n_samples,dp))**3)/(sigma*sqrt(PI))**3 + + n_samples_d = real(n_samples/2,dp) + allocate(hist_t(size(hist))) + + if (gaussian_smoothing) then + allocate(d_a((n_samples+1)**3)) + allocate(w_a((n_samples+1)**3)) + do ix=1, n_samples+1 + px = real(ix-1-(n_samples/2), dp)/n_samples_d*range + do iy=1, n_samples+1 + py = real(iy-1-(n_samples/2), dp)/n_samples_d*range + do iz=1, n_samples+1 + pz = real(iz-1-(n_samples/2), dp)/n_samples_d*range + io = (ix-1)*(n_samples+1)**2 + (iy-1)*(n_samples+1) + (iz-1) + 1 + d_a(io) = sqrt((px+d)**2+py**2+pz**2) + w_a(io) = normalization*exp(-(px**2+py**2+pz**2)/sigma**2) + end do + end do + end do + hist_t = histogram(d_a, minx, maxx, num_bins, weight_vector=w_a, drop_outside=.true.) + deallocate(d_a) + deallocate(w_a) + else + hist_t = histogram((/d/), minx, maxx, num_bins, drop_outside=.true.) + endif + hist = hist + hist_t + deallocate(hist_t) + + end subroutine accum_histogram + + subroutine print_usage(name) + + character(*), optional, intent(in) :: name + + if (present(name)) then + write(line,'(3a)')'Usage: ',trim(name),' xyzfile datafile AtomMask Cutoff BinWidth [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' + else + write(line,'(a)')'Usage: density_KDE xyzfile datafile AtomMask Cutoff BinWidth [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' + end if + call print(line) + call print(' The input xyz file.') + call print(' An element symbol, e.g. H or Ca, or @ followed by a list of indices/ranges, e.g. @1-35,45,47,50-99 or property=value') + call print(' The cutoff radius in Angstroms.') + call print(' The number of volume bins.') + call print(' The output data file.') + call print(' Optional. Only process 1 out of every n frames.') + call print(' Optional. Only process frames from this frame.') + call print(' Optional. Only process frames until this frame.') + call print(' Optional. Write data after every n processed frames.') + call print(' Optional. Compute separate densities for each n processed frames (overriden if IO_Rate > 0)') + call print(' Optional. Use Gaussians instead of delta functions.') + call print(' Optional. The sigma is the sqrt(variance) of the Gaussian function.') + call print(' Optional. If true, use FORTRAN I/O. Slower, but might not work for stdin otherwise') + call print('') + call print('Pressing Ctrl-C during execution will leave the output file with the rdf averaged over the frames read so far') + call print('') + + !call verbosity_pop + call system_finalise + stop + + end subroutine print_usage + + subroutine get_prop_info(mask,name,value) + + character(*), intent(in) :: mask + character(*), intent(out) :: name + integer, intent(out) :: value + integer :: delimiter + + delimiter = scan(mask,'=') + if (delimiter > 1) then + name = adjustl(mask(1:delimiter-1)) + value = string_to_int(mask(delimiter+1:len_trim(mask))) + else + call system_abort('Zero length property name in mask: "'//trim(mask)//'"') + end if + + end subroutine get_prop_info + + function Gaussian_histogram(vector,min_x,max_x,Nbin,Gaussian,sigma) + + real(dp), dimension(:), intent(in) :: vector + real(dp), intent(in) :: min_x, max_x + integer, intent(in) :: Nbin + logical, intent(in) :: Gaussian + real(dp), intent(in) :: sigma + real(dp), dimension(Nbin) :: Gaussian_histogram + !local variables + real(dp) :: binsize,min_bin,max_bin + integer :: i, bin, j + + if(max_x <= min_x) then + call system_abort('Vector_Histogram: max_x < min_x') + end if + + binsize=(max_x-min_x)/(real(Nbin,dp)) + Gaussian_histogram = 0.0_dp + + do i=1,size(vector) +! call print('') +! call print('Distribution of vector '//i//' over the whole histogram:') + + if (Gaussian) then +! if(.not.present(sigma)) call system_abort('Gaussian_histogram: Missing Gaussian sigma parameter.') + do j=1,Nbin + min_bin = min_x + real(j-1,dp) * binsize + max_bin = min_bin + binsize +! call print('min_bin: '//min_bin//', max_bin: '//max_bin) +! call print('ERF(min_bin) = '//erf((vector(i)-min_bin)/(sigma*sqrt(2._dp)))) +! call print('ERF(max_bin) = '//erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp)))) +! call print('Adding to bin '//j//' '//(erf((vector(i)-min_bin)/(sigma*sqrt(2._dp))) + erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp))))) + Gaussian_histogram(j) = Gaussian_histogram(j) - 0.5_dp*erf((min_bin-vector(i))/(sigma*sqrt(2._dp))) + 0.5_dp*erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp))) + enddo + else + bin = ceiling((vector(i)-min_x)/binsize) + if (bin < 1) bin = 1 + if (bin > Nbin) bin = Nbin + Gaussian_histogram(bin) = Gaussian_histogram(bin) + 1.0_dp + endif + end do + + end function Gaussian_histogram + + subroutine atoms_ll_new_entry2(this, atoms_p, before, after) + type(atoms_ll), target, intent(inout) :: this + type(atoms), intent(inout), pointer :: atoms_p + !type(atoms_ll) :: this !structure_ll +! type(Atoms), pointer :: atoms_p !structure + type(atoms_ll_entry), intent(in), target, optional :: before, after + + type(atoms_ll_entry), pointer :: my_before, my_after + type(atoms_ll_entry), pointer :: entry + + if (present(before) .and. present(after)) call system_abort("atoms_ll_new_entry got both before and after") + + if (present(before)) then + my_before => before + my_after => before%prev + else if (present(after)) then + my_before => after%next + my_after => after + else + my_after => this%last + my_before => null() + endif + + allocate(entry) + if (associated(my_before)) then + my_before%prev => entry + entry%next => my_before + else + this%last => entry + endif + if (associated(my_after)) then + my_after%next => entry + entry%prev => my_after + else + this%first => entry + endif + + atoms_p => entry%at + end subroutine atoms_ll_new_entry2 + + subroutine calc_stat(data,mean,sd) + + real(dp), dimension(:), intent(in) :: data + real(dp), intent(out) :: mean,sd + + integer :: i + + mean = 0._dp + sd = 0._dp + + do i=1,size(data) + mean = mean + data(i) + enddo + mean = mean / size(data) + + do i=1,size(data) + sd = sd + (data(i)-mean)**2.0_dp + enddo + sd = sqrt(sd/size(data)) + + end subroutine calc_stat + + function KDE_eval(points,here,sigma) + + real(dp), dimension(:), intent(in) :: points + real(dp), intent(in) :: here + real(dp), intent(in) :: sigma + + real(dp) :: a,c, bias + integer :: i + real(dp) :: KDE_eval + + KDE_eval = 0._dp + a = 1.0_dp / (sigma * sqrt(2.0_dp*PI)) + c = -1.0_dp / (2.0_dp * sigma**2.0_dp) + do i = 1,size(points) + bias = 4.0_dp * points(i)**2.0_dp * PI + KDE_eval = KDE_eval + a * exp( c * (here-points(i))**2.0_dp ) / bias + KDE_eval = KDE_eval + a * exp( c * (here+points(i))**2.0_dp ) / bias !if close to the origin + enddo + + end function KDE_eval + +end program density_KDE diff --git a/src/Structure_processors/density_new.F90 b/src/Structure_processors/density_new.F90 new file mode 100644 index 0000000000..d75693dc8c --- /dev/null +++ b/src/Structure_processors/density_new.F90 @@ -0,0 +1,792 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! Calculates density in a grid of boxes (possibly smoothed) or a radial mesh +! with error bars +! outputs number density (#/vol) + +program density_new +use libatoms_module +implicit none + + type(Dictionary) :: cli_params + character(len=STRING_LENGTH) :: infilename + logical :: infile_is_list + character(len=STRING_LENGTH) :: outfilename + type(Inoutput) :: outfile + character(len=STRING_LENGTH) :: commandfilename + type(Inoutput) :: commandfile + character(len=1024) :: args_str + + character(len=STRING_LENGTH) :: mask_str + integer :: decimation + real(dp) :: min_time, max_time + logical :: gaussian_smoothing + real(dp) :: gaussian_sigma + logical :: radial_histo, random_samples + real(dp) :: radial_center(3) + integer :: n_samples(2) + logical :: sort_Time, no_Time_dups + real(dp) :: min_p(3), bin_width(3) + integer :: n_bins(3) + logical :: quiet + logical :: autocorrelation, mean + integer :: autocorrelation_max_lag + real(dp) :: mean_decorrelation_time + logical :: have_params + integer :: status, arg_line_no + + logical :: no_compute_index + integer :: n_histos + type(Atoms_ll) :: structure_ll + real(dp), allocatable :: histograms(:,:,:,:), histo_grid(:,:,:,:), histo_mean(:,:,:), histo_var(:,:,:) + integer :: i_lag, i1, i2, i3 + real(dp), allocatable :: autocorr(:,:,:,:) + + call system_initialise(PRINT_NORMAL) + + call initialise(cli_params) + call register_cli_params(cli_params,.true., infilename, infile_is_list, outfilename, commandfilename, & + mask_str, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, & + radial_histo, radial_center, random_samples, n_samples, & + sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) + if (.not. param_read_args(cli_params)) then + call print_usage() + call system_abort('could not parse argument line') + end if + + call print("Reading configurations") + call read_xyz(structure_ll, infilename, infile_is_list, decimation, min_time, max_time, sort_Time, no_Time_dups, quiet, no_compute_index) + + if (len_trim(commandfilename) == 0) then + args_str = write_string(cli_params) + call finalise(cli_params) + else + call finalise(cli_params) + call print("reading commands from file '"//trim(commandfilename)//"'") + call initialise(commandfile, trim(commandfilename), INPUT) + arg_line_no = 1 + args_str = read_line(commandfile) + call initialise(cli_params) + call print("got arguments line '"//trim(args_str)//"'") + call register_cli_params(cli_params,.false., infilename, infile_is_list, outfilename, commandfilename, & + mask_str, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, & + radial_histo, radial_center, random_samples, n_samples, & + sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) + if (.not. param_read_line(cli_params, trim(args_str), ignore_unknown = .true.)) then + call print_usage() + call system_abort("could not parse argument line "//arg_line_no//" from file '"//trim(commandfilename//"'")) + end if + call finalise(cli_params) + endif + + have_params = .true. + do while (have_params) + no_compute_index=.false. + if ((.not. sort_Time) .and. (.not. no_Time_dups)) no_compute_index=.true. + + call print("infile " // trim(infilename) // " infile_is_list " // infile_is_list) + call print("outfilename " // trim(outfilename)) + call print("decimation " // decimation // " min_time " // min_time // " max_time " // max_time) + call print("AtomMask " // trim(mask_str)) + call print("radial_histo " // radial_histo) + if (radial_histo) then + call print("radial_center " // radial_center) + call print("bin_width " // bin_width(1) // " n_bins " // n_bins(1)) + n_bins(2:3) = 1 + call print("random_samples " // random_samples) + if (random_samples) then + call print("n_samples " // n_samples(1)) + else + call print("n_theta " // n_samples(1) // " n_phi " // n_samples(2)) + endif + else + call print("min_p " // min_p) + call print("bin_width " // bin_width // " n_bins " // n_bins) + endif + call print("gaussian " // gaussian_smoothing // " sigma " // gaussian_sigma) + call print("sort_Time " // sort_Time // " no_Time_dups " // no_Time_dups) + call print("mean " // mean // " mean_decorrelation_time " // mean_decorrelation_time) + call print("autocorrelation " // autocorrelation // " autocorrelation_max_lag " // autocorrelation_max_lag) + + call print("Calculating densities") + call calc_histos(histograms, n_histos, histo_grid, min_p, bin_width, n_bins, structure_ll, & + mean_decorrelation_time, gaussian_smoothing, gaussian_sigma, & + radial_histo, radial_center, random_samples, n_samples, mask_str, quiet) + + call initialise(outfile, outfilename, OUTPUT) + + if (autocorrelation) then + call print("Calculating autocorrelations") + allocate(autocorr(n_bins(1),n_bins(2),n_bins(3),autocorrelation_max_lag+1)) + autocorr = autocorrelation_3array(histograms(:,:,:,1:n_histos), max_lag=autocorrelation_max_lag) + + call print("Printing autocorrelations") + call print("# Autocorrelation", file=outfile) + do i_lag=0, autocorrelation_max_lag + call print(i_lag // " " // reshape(autocorr(1:n_bins(1),1:n_bins(2),1:n_bins(3),i_lag+1), & + (/ n_bins(1)*n_bins(2)*n_bins(3) /)), file=outfile) + end do + endif + + if (mean) then + if (autocorrelation) then + call print("", file=outfile) + call print("", file=outfile) + endif + allocate(histo_mean(n_bins(1), n_bins(2), n_bins(3))) + allocate(histo_var(n_bins(1), n_bins(2), n_bins(3))) + call calc_mean_var_3array(histograms(:,:,:,1:n_histos), histo_mean, histo_var) + + if (radial_histo) then + call print("# Density (#/vol) ", file=outfile) + call print("# r mean var n_samples", file=outfile) + do i1=1, n_bins(1) + call print(histo_grid(1,i1,1,1) // " " // histo_mean(i1, 1, 1) // " " // & + histo_var(i1, 1, 1) // " " // n_histos, file=outfile) + end do + else + call print("# Density (#/vol)", file=outfile) + call print("# x y z mean var n_samples", file=outfile) + do i1=1,n_bins(1) + do i2=1,n_bins(2) + do i3=1,n_bins(3) + call print( histo_grid(:,i1,i2,i3) // & + " " // histo_mean(i1, i2, i3) // & + " " // histo_var(i1, i2, i3) // " " // n_histos, file=outfile) + end do + call print('', file=outfile) + end do + call print('', file=outfile) + end do + endif + end if + + call finalise(outfile) + + if (allocated(histograms)) deallocate(histograms) + if (allocated(histo_grid)) deallocate(histo_grid) + if (allocated(autocorr)) deallocate(autocorr) + if (allocated(histo_mean)) deallocate(histo_mean) + if (allocated(histo_var)) deallocate(histo_var) + + if (len_trim(commandfilename) == 0) then + have_params = .false. + else + arg_line_no = arg_line_no + 1 + args_str = read_line(commandfile, status=status) + if (status == 0) then + call print("got arguments line '"//trim(args_str)//"'") + call initialise(cli_params) + call register_cli_params(cli_params,.false., infilename, infile_is_list, outfilename, commandfilename, & + mask_str, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, & + radial_histo, radial_center, random_samples, n_samples, & + sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) + if (.not. param_read_line(cli_params, trim(args_str), ignore_unknown = .true.)) then + call print_usage() + call system_abort("could not parse argument line "//arg_line_no//" from file '"//trim(commandfilename//"'")) + end if + call finalise(cli_params) + else + have_params = .false. + endif + endif + + end do + + call system_finalise() + +contains + + subroutine print_usage() + + character(len=1024) my_exec_name + + if (EXEC_NAME == "") then + my_exec_name="" + else + my_exec_name=EXEC_NAME + endif + + call print("Usage: " // trim(my_exec_name)//" infile=filename [infile_is_list=logical(F)]", PRINT_ALWAYS) + call print(" outfile=filename [commandfile=filename()] [AtomMask=species()] [min_p={x y z}]", PRINT_ALWAYS) + call print(" bin_width={x y z}(y,z ignored for radial_histo) n_bins={nx ny nz}(y,z ignored for radial_histo)", PRINT_ALWAYS) + call print(" [mean=logical(T)] [mean_decorrelation_time=t(0.0)]", PRINT_ALWAYS) + call print(" [autocorrelation=logical(F)] [autocorrelation_max_lag=N(10000)]", PRINT_ALWAYS) + call print(" [decimation=n(1)] [min_time=t(-1.0)] [max_time=t(-1.0)]", PRINT_ALWAYS) + call print(" [gaussian=logical(F)(always true for radial_histo)] [sigma=s(1.0)] [radial_histo=logical(F)]", PRINT_ALWAYS) + call print(" [radial_center={x y z}] [random_samples=logical(F)(radial_histo only)] [n_samples={2 4})(component 2 ignored for random)]", PRINT_ALWAYS) + call print(" [sort_Time(F)] [no_Time_dups(F)]", PRINT_ALWAYS) + call print(" [quiet=logical(F)]", PRINT_ALWAYS) + end subroutine print_usage + + subroutine register_cli_params(cli_params, initial, infilename, infile_is_list, outfilename, commandfilename, & + mask_str, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, & + radial_histo, radial_center, random_samples, n_samples, & + sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) + type(Dictionary), intent(inout) :: cli_params + logical, intent(in) :: initial + character(len=*), intent(inout) :: infilename + logical, intent(inout) :: infile_is_list + character(len=*), intent(inout) :: outfilename + character(len=*), intent(inout) :: commandfilename + character(len=*), intent(inout) :: mask_str + real(dp), intent(inout) :: min_p(3), bin_width(3) + integer, intent(inout) :: n_bins(3), decimation + real(dp), intent(inout) :: min_time, max_time + logical, intent(inout) :: gaussian_smoothing + real(dp), intent(inout) :: gaussian_sigma + logical, intent(inout) :: radial_histo + real(dp), intent(inout) :: radial_center(3) + logical, intent(inout) :: random_samples + integer, intent(inout) :: n_samples(2) + logical, intent(inout) :: sort_Time, no_Time_dups + logical, intent(inout) :: mean + real(dp), intent(inout) :: mean_decorrelation_time + logical, intent(inout) :: autocorrelation + integer, intent(inout) :: autocorrelation_max_lag + logical, intent(inout) :: quiet + character(len=STRING_LENGTH) :: t_field + + + if (initial) then + call param_register(cli_params, 'infile', param_mandatory, infilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'infile_is_list', 'F', infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'outfile', 'stdout', outfilename, help_string="No help yet. This source file was $LastChangedBy$") + mask_str = "" + commandfilename = "" + call param_register(cli_params, 'commandfile', "", commandfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'AtomMask', "", mask_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_p', "0.0 0.0 0.0", min_p, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'bin_width', PARAM_MANDATORY, bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'n_bins', PARAM_MANDATORY, n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'gaussian', 'F', gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sigma', '1.0', gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'radial_histo', 'F', radial_histo, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'radial_center', '0.0 0.0 0.0', radial_center, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'random_samples', 'F', random_samples, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'n_samples', '2 4', n_samples, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sort_Time', 'F', sort_Time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'no_Time_dups', 'F', no_Time_dups, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'mean', 'T', mean, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'mean_decorrelation_time', '0.0', mean_decorrelation_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'autocorrelation', 'F', autocorrelation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'autocorrelation_max_lag', '10000', autocorrelation_max_lag, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'quiet', 'F', quiet, help_string="No help yet. This source file was $LastChangedBy$") + else + t_field=infilename + call param_register(cli_params, 'infile', trim(t_field), infilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'infile_is_list', ""//infile_is_list, infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") + t_field=outfilename + call param_register(cli_params, 'outfile', trim(t_field), outfilename, help_string="No help yet. This source file was $LastChangedBy$") + t_field=commandfilename + call param_register(cli_params, 'commandfile', trim(t_field), commandfilename, help_string="No help yet. This source file was $LastChangedBy$") + t_field=mask_str + call param_register(cli_params, 'AtomMask', trim(t_field), mask_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_p', ""//min_p, min_p, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'bin_width', ""//bin_width, bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'n_bins', ""//n_bins, n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'min_time', ""//min_time, min_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'max_time', ""//max_time, max_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'gaussian', ""//gaussian_smoothing, gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'sigma', ""//gaussian_sigma, gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'radial_histo', ""//radial_histo, radial_histo, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'radial_center', ""//radial_center, radial_center, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'random_samples', ""//random_samples, random_samples, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'n_samples', '2 4', n_samples, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'mean', ""//mean, mean, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'mean_decorrelation_time', ""//mean_decorrelation_time, mean_decorrelation_time, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'autocorrelation', ""//autocorrelation, autocorrelation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'autocorrelation_max_lag', ""//autocorrelation_max_lag, autocorrelation_max_lag, help_string="No help yet. This source file was $LastChangedBy$") + endif + end subroutine register_cli_params + + function autocorrelation_scalar(v, max_lag) result(autocorrelation) + real(dp), intent(in) :: v(:) + integer, intent(in) :: max_lag + real(dp) :: autocorrelation(max_lag) + + integer :: lag, i + real(dp) :: t_sum, mean + integer :: nt + + nt = size(v,1) + + mean = sum(v)/real(nt,dp) + do lag=1, max_lag + t_sum = 0.0_dp + do i=1, nt-lag + t_sum = t_sum + (v(i)-mean)*(v(i+lag)-mean) + end do + autocorrelation(lag) = t_sum/real(nt-lag,dp) + end do + + end function autocorrelation_scalar + + function autocorrelation_3array(v, max_lag) result(autocorrelation) + real(dp), intent(in) :: v(:,:,:,:) + integer, intent(in) :: max_lag + real(dp) :: autocorrelation(size(v,1),size(v,2),size(v,3),max_lag+1) + + integer :: lag, i + real(dp), allocatable :: t_sum(:,:,:), mean(:,:,:) + integer :: n1, n2, n3, nt + + n1 = size(v,1) + n2 = size(v,2) + n3 = size(v,3) + nt = size(v,4) + allocate(t_sum(n1,n2,n3), mean(n1,n2,n3)) + + mean = sum(v,4)/real(nt,dp) + do lag=0, max_lag + t_sum = 0.0_dp + do i=1, nt-lag + t_sum(1:n1,1:n2,1:n3) = t_sum(1:n1,1:n2,1:n3) + (v(1:n1,1:n2,1:n3,i)-mean)*(v(1:n1,1:n2,1:n3,i+lag)-mean) + end do + autocorrelation(1:n1,1:n2,1:n3,lag+1) = t_sum(1:n1,1:n2,1:n3)/real(nt-lag,dp) + end do + + deallocate(t_sum, mean) + + end function autocorrelation_3array + + subroutine calc_histos(histograms, n_histos, histo_grid, min_p, bin_width, n_bins, & + structure_ll, interval, gaussian, gaussian_sigma, & + radial_histo, radial_center, random_samples, n_samples, mask_str, quiet) + real(dp), intent(inout), allocatable :: histograms(:,:,:,:) + integer, intent(out) :: n_histos + real(dp), intent(inout), allocatable :: histo_grid(:,:,:,:) + real(dp), intent(in) :: min_p(3), bin_width(3) + integer, intent(in) :: n_bins(3) + type(atoms_ll), intent(in) :: structure_ll + real(dp), intent(in) :: interval + logical, intent(in) :: gaussian + real(dp), intent(in) :: gaussian_sigma + logical, intent(in) :: radial_histo + real(dp), intent(in) :: radial_center(3) + logical :: random_samples + integer :: n_samples(2) + character(len=*), optional, intent(in) :: mask_str + logical, optional :: quiet + + real(dp) :: last_time, cur_time + type(atoms_ll_entry), pointer :: entry + logical :: do_this_histo, first_histo + real(dp), allocatable :: theta(:), phi(:), w(:) + logical :: my_quiet + + my_quiet = optional_default(.false., quiet) + n_histos = 0 + allocate(histograms(n_bins(1),n_bins(2),n_bins(3),10)) + if (radial_histo) then + allocate(histo_grid(1,n_bins(1),n_bins(2),n_bins(3))) + else + allocate(histo_grid(3,n_bins(1),n_bins(2),n_bins(3))) + endif + histograms = 0.0_dp + + if (radial_histo) then + if (random_samples) then + call calc_angular_samples_random(n_samples(1), theta, phi, w) + else + call calc_angular_samples_grid(n_samples(1), n_samples(2), theta, phi, w) + endif + endif + + first_histo = .true. + entry => structure_ll%first + cur_time = -1.0_dp + last_time = -1.0e38_dp + do while (associated(entry)) + do_this_histo = .false. + if (interval > 0.0_dp) then + if (cur_time < last_time) & + call system_abort("calc_histos called with interval="//interval//" > 0, but unsorted sequence: cur_time="// & + cur_time//" < last_time="//last_time) + if (.not. get_value(entry%at%params, "Time", cur_time)) & + call system_abort("calc_histos called with interval="//interval//" > 0, but no Time value in entry") + if ((cur_time .feq. last_time) .or. (cur_time >= last_time+interval)) then + do_this_histo = .true. + if (cur_time >= last_time+interval) last_time = cur_time + endif + else + do_this_histo = .true. + endif + if (do_this_histo) then + ! if (get_value(entry%at%params, "Time", cur_time)) call print("doing histo for config with time " // cur_time) + n_histos = n_histos + 1 + if (.not. my_quiet) then + if (mod(n_histos,1000) == 1) write (mainlog%unit,'(I4,a)') int(n_histos/1000)," " + if (mod(n_histos,10) == 0) write (mainlog%unit,'(I1,$)') mod(n_histos/10,10) + if (mod(n_histos,1000) == 0) write (mainlog%unit,'(a)') " " + endif + call reallocate_histos(histograms, n_histos, n_bins) + if (radial_histo) then + if (first_histo) then + call sample_radial_mesh_Gaussians(histograms(:,1,1,n_histos), entry%at, radial_center, bin_width(1), n_bins(1), gaussian_sigma, & + theta, phi, w, mask_str, histo_grid(1,:,1,1)) + else + call sample_radial_mesh_Gaussians(histograms(:,1,1,n_histos), entry%at, radial_center, bin_width(1), n_bins(1), gaussian_sigma, & + theta, phi, w, mask_str) + endif + else ! rectilinear + if (gaussian) then + if (first_histo) then + call sample_rectilinear_mesh_Gaussians(histograms(:,:,:,n_histos), entry%at, min_p, bin_width, n_bins, gaussian_sigma, mask_str, histo_grid(:,:,:,:)) + else + call sample_rectilinear_mesh_Gaussians(histograms(:,:,:,n_histos), entry%at, min_p, bin_width, n_bins, gaussian_sigma, mask_str) + endif + else + if (first_histo) then + call calc_histogram(histograms(:,:,:,n_histos), entry%at, min_p, bin_width, n_bins, mask_str, histo_grid(:,:,:,:)) + else + call calc_histogram(histograms(:,:,:,n_histos), entry%at, min_p, bin_width, n_bins, mask_str) + endif + endif + endif + endif + entry => entry%next + end do + end subroutine calc_histos + + subroutine calc_angular_samples_grid(n_t, n_p, theta, phi, w) + integer, intent(in) :: n_t, n_p + real(dp), allocatable, intent(inout) :: theta(:), phi(:), w(:) + + integer :: t_i, p_i, ii + + if (allocated(theta)) deallocate(theta) + if (allocated(phi)) deallocate(phi) + if (allocated(w)) deallocate(w) + allocate(theta(n_t*n_p)) + allocate(phi(n_t*n_p)) + allocate(w(n_t*n_p)) + + ii = 1 + do t_i=1, n_t + do p_i=1, n_p + phi(ii) = (p_i-1)*2.0_dp*PI/real(n_p,dp) + if (mod(n_t,2) == 0) then + theta(ii) = (t_i-1.5_dp-floor((n_t-1)/2.0_dp))*PI/real(n_t,dp) + else + theta(ii) = (t_i-1-floor((n_t-1)/2.0_dp))*PI/real(n_t,dp) + endif + ! not oversample top and bottom of spehre + w(ii) = cos(theta(ii)) + ii = ii + 1 + end do + end do + w = w / ( (gaussian_sigma*sqrt(2.0_dp*PI))**3 * sum(w) ) + end subroutine calc_angular_samples_grid + + subroutine calc_angular_samples_random(n, theta, phi, w) + integer, intent(in) :: n + real(dp), allocatable, intent(inout) :: theta(:), phi(:), w(:) + + integer :: ii + real(dp) :: p(3), p_norm + + if (allocated(theta)) deallocate(theta) + if (allocated(phi)) deallocate(phi) + if (allocated(w)) deallocate(w) + allocate(theta(n)) + allocate(phi(n)) + allocate(w(n)) + + do ii = 1, n + p_norm = 2.0_dp + do while (p_norm > 1.0_dp) + p = 0.0_dp + call randomise(p, 2.0_dp) + p_norm = norm(p) + end do + phi(ii) = atan2(p(2),p(1)) + theta(ii) = acos(p(3)/p_norm) + w(ii) = 1.0_dp + end do + w = w / ( (gaussian_sigma*sqrt(2.0_dp*PI))**3 * sum(w) ) + + end subroutine calc_angular_samples_random + + subroutine sample_radial_mesh_Gaussians(histogram, at, radial_center, bin_width, n_bins, gaussian_sigma, theta, phi, w, mask_str, histo_grid, accumulate) + real(dp), intent(inout) :: histogram(:) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: radial_center(3) + real(dp), intent(in) :: bin_width + integer, intent(in) :: n_bins + real(dp), intent(in) :: gaussian_sigma, theta(:), phi(:), w(:) + character(len=*), optional, intent(in) :: mask_str + real(dp), intent(out), optional :: histo_grid(:) + logical, optional, intent(in) :: accumulate + + logical :: my_accumulate + real(dp) :: bin_r, p(3), dist, r + logical, allocatable :: mask_a(:) + integer at_i, sample_i, bin_i + + my_accumulate = optional_default(.false., accumulate) + if (.not. my_accumulate) histogram = 0.0_dp + + allocate(mask_a(at%N)) + call is_in_mask(mask_a, at, mask_str) + +! ratio of 20/4=5 is bad +! ratio of 20/3=6.66 is bad +! ratio of 20/2.5=8 is borderline (2e-4) +! ratio of 20/2.22=9 is fine (error 2e-5) +! ratio of 20/2=10 is fine + if ( (norm(at%lattice(:,1)) < 9.0_dp*gaussian_sigma) .or. & + (norm(at%lattice(:,2)) < 9.0_dp*gaussian_sigma) .or. & + (norm(at%lattice(:,3)) < 9.0_dp*gaussian_sigma) ) & + call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) + + if (present(histo_grid)) then + do bin_i=1, n_bins + bin_r = (bin_i-1)*bin_width + histo_grid(bin_i) = bin_r + end do + endif + + do at_i=1, at%N + if (.not. mask_a(at_i)) cycle + r = norm(at%pos(:,at_i)) + do bin_i=1, n_bins + bin_r = (bin_i-1)*bin_width + do sample_i=1,size(theta) + p(1) = radial_center(1)+bin_r*cos(phi(sample_i))*cos(theta(sample_i)) + p(2) = radial_center(2)+bin_r*sin(phi(sample_i))*cos(theta(sample_i)) + p(3) = radial_center(3)+bin_r*sin(theta(sample_i)) + dist = distance_min_image(at,p,at%pos(:,at_i)) +!Include all the atoms, slow but minimises error +! if (dist > 4.0_dp*gaussian_sigma) cycle + histogram(bin_i) = histogram(bin_i) + exp(-0.5_dp*(dist/(gaussian_sigma))**2)*w(sample_i) + end do ! sample_i + end do ! bin_i + end do ! at_i + + deallocate(mask_a) + end subroutine sample_radial_mesh_Gaussians + + subroutine sample_rectilinear_mesh_Gaussians(histogram, at, min_p, sample_dist, n_bins, gaussian_sigma, mask_str, histo_grid, accumulate) + real(dp), intent(inout) :: histogram(:,:,:) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: min_p(3), sample_dist(3) + integer, intent(in) :: n_bins(3) + real(dp), intent(in) :: gaussian_sigma + character(len=*), optional, intent(in) :: mask_str + real(dp), intent(out), optional :: histo_grid(:,:,:,:) + logical, optional, intent(in) :: accumulate + + logical :: my_accumulate + integer :: at_i, i1, i2, i3 + real(dp) :: p(3), w, dist + logical, allocatable :: mask_a(:) + + my_accumulate = optional_default(.false., accumulate) + if (.not. my_accumulate) histogram = 0.0_dp + + allocate(mask_a(at%N)) + call is_in_mask(mask_a, at, mask_str) + +! ratio of 20/4=5 is bad +! ratio of 20/3=6.66 is bad +! ratio of 20/2.5=8 is borderline (2e-4) +! ratio of 20/2.22=9 is fine (error 2e-5) +! ratio of 20/2=10 is fine + if ( (norm(at%lattice(:,1)) < 9.0_dp*gaussian_sigma) .or. & + (norm(at%lattice(:,2)) < 9.0_dp*gaussian_sigma) .or. & + (norm(at%lattice(:,3)) < 9.0_dp*gaussian_sigma) ) & + call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) + + w = 1.0_dp / (gaussian_sigma*sqrt(2.0_dp*PI))**3 + + if (present(histo_grid)) then + do i1=1, n_bins(1) + p(1) = min_p(1) + (i1-1)*sample_dist(1) + do i2=1, n_bins(2) + p(2) = min_p(2) + (i2-1)*sample_dist(2) + do i3=1, n_bins(3) + p(3) = min_p(3) + (i3-1)*sample_dist(3) + histo_grid(:,i1,i2,i3) = p + end do + end do + end do + endif + + do at_i=1, at%N + if (.not. mask_a(at_i)) cycle + do i1=1, n_bins(1) + p(1) = min_p(1) + (i1-1)*sample_dist(1) + do i2=1, n_bins(2) + p(2) = min_p(2) + (i2-1)*sample_dist(2) + do i3=1, n_bins(3) + p(3) = min_p(3) + (i3-1)*sample_dist(3) + dist = distance_min_image(at,p,at%pos(:,at_i)) + histogram(i1,i2,i3) = histogram(i1,i2,i3) + exp(-0.5_dp*(dist/(gaussian_sigma))**2)*w + end do ! i3 + end do ! i2 + end do ! i1 + end do ! at_i + + deallocate(mask_a) + end subroutine sample_rectilinear_mesh_Gaussians + + subroutine calc_histogram(histogram, at, min_p, bin_width, n_bins, mask_str, histo_grid, accumulate) + real(dp), intent(inout) :: histogram(:,:,:) + type(Atoms), intent(in) :: at + real(dp), intent(in) :: min_p(3), bin_width(3) + integer, intent(in) :: n_bins(3) + character(len=*), optional, intent(in) :: mask_str + real(dp), intent(out), optional :: histo_grid(:,:,:,:) + logical, optional, intent(in) :: accumulate + + logical :: my_accumulate + integer :: i, bin(3) + logical, allocatable :: mask_a(:) + real(dp) :: p(3) + + my_accumulate = optional_default(.false., accumulate) + if (.not. my_accumulate) histogram = 0.0_dp + + if (present(histo_grid)) then + do i1=1, n_bins(1) + p(1) = min_p(1) + (real(i1,dp)-0.5_dp)*bin_width(1) + do i2=1, n_bins(2) + p(2) = min_p(2) + (real(i2,dp)-0.5_dp)*bin_width(2) + do i3=1, n_bins(3) + p(3) = min_p(3) + (real(i3,dp)-0.5_dp)*bin_width(3) + histo_grid(:,i1,i2,i3) = p + end do + end do + end do + endif + + allocate(mask_a(at%N)) + call is_in_mask(mask_a, at, mask_str) + + do i=1, at%N + if (.not. mask_a(i)) cycle + bin = floor((at%pos(:,i)-min_p)/bin_width)+1 + if (all(bin >= 1) .and. all (bin <= n_bins)) histogram(bin(1),bin(2),bin(3)) = histogram(bin(1),bin(2),bin(3)) + 1.0_dp + end do + + deallocate(mask_a) + + end subroutine calc_histogram + + subroutine is_in_mask(mask_a, at, mask_str) + type(Atoms), intent(in) :: at + logical, intent(out) :: mask_a(at%N) + character(len=*), optional, intent(in) :: mask_str + + integer :: i + integer :: Zmask + type(Table) :: atom_indices + + if (.not. present(mask_str)) then + mask_a = .true. + return + endif + + if (len_trim(mask_str) == 0) then + mask_a = .true. + return + endif + + mask_a = .false. + if (mask_str(1:1)=='@') then + call parse_atom_mask(mask_str,atom_indices) + do i=1, atom_indices%N + mask_a(atom_indices%int(1,i)) = .true. + end do + else if (scan(mask_str,'=')/=0) then + call system_abort("property type mask not supported yet") + else + Zmask = Atomic_Number(mask_str) + do i=1, at%N + if (at%Z(i) == Zmask) mask_a(i) = .true. + end do + end if + end subroutine is_in_mask + + subroutine reallocate_histos(histos, n, n_bins) + real(dp), allocatable, intent(inout) :: histos(:,:,:,:) + integer, intent(in) :: n, n_bins(3) + + integer :: new_size + real(dp), allocatable :: t_histos(:,:,:,:) + + if (allocated(histos)) then + if (n <= size(histos,4)) return + allocate(t_histos(size(histos,1),size(histos,2),size(histos,3),size(histos,4))) + t_histos = histos + deallocate(histos) + if (size(t_histos,4) <= 0) then + new_size = 10 + else if (size(t_histos,4) < 1000) then + new_size = 2*size(t_histos,4) + else + new_size = floor(1.25*size(t_histos,4)) + endif + allocate(histos(size(t_histos,1), size(t_histos,2), size(t_histos,3), new_size)) + histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),1:size(t_histos,4)) = & + t_histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),1:size(t_histos,4)) + histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),size(t_histos,4)+1:size(histos,4)) = 0.0_dp + deallocate(t_histos) + else + allocate(histos(n_bins(1), n_bins(2), n_bins(3), n)) + endif + end subroutine reallocate_histos + + subroutine calc_mean_var_3array(a, mean, var) + real(dp), intent(in) :: a(:,:,:,:) + real(dp), intent(out) :: mean(:,:,:) + real(dp), optional, intent(out) :: var(:,:,:) + + integer :: i1, i2, i3, n + + n = size(a,4) + mean = sum(a, 4)/real(n,dp) + if (present(var)) then + do i1=1, size(a,1) + do i2=1, size(a,2) + do i3=1, size(a,3) + var(i1,i2,i3) = sum((a(i1,i2,i3,:)-mean(i1,i2,i3))**2)/real(n,dp) + end do + end do + end do + end if + end subroutine calc_mean_var_3array + +end program density_new diff --git a/src/Structure_processors/diffusion.F90 b/src/Structure_processors/diffusion.F90 new file mode 100644 index 0000000000..8401252095 --- /dev/null +++ b/src/Structure_processors/diffusion.F90 @@ -0,0 +1,168 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!diffusion constant calculating helper program. +!prints the average square displacement as the function of the frames. +!The diffusivity can be calculated by fitting 4*D*t to (t). +program diffusion + +use libatoms_module + + implicit none + + + type(Atoms) :: structure, reference, prev_structure + type(CInoutput) :: xyzfile + type(Inoutput) :: datafile + real(dp) :: ave_r2, one_r2, d + integer :: frame_count, frames_processed + integer :: i, shift(3) + integer :: error + integer, allocatable, dimension(:,:) :: travel + + !Input + type(Dictionary) :: params_in + character(STRING_LENGTH) :: xyzfilename, datafilename + integer :: from, to + integer :: IO_Rate + integer :: one_atom + + call system_initialise(PRINT_SILENT) + call verbosity_push(PRINT_NORMAL) + + call initialise(params_in) + call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'datafile', param_mandatory, datafilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'from', '1', from, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'one_atom', '0', one_atom, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(params_in)) then + call print('diffusion xyzfile datafile [from=1] [to=0] [one_atom] [IO_Rate]') + call system_abort('could not parse argument line') + end if + call finalise(params_in) + + if (from<1) call system_abort('from must be a positive intger.') + ! Read the input and output filename and open them + call initialise(xyzfile,xyzfilename,action=INPUT) + call initialise(datafile,datafilename,action=OUTPUT) + call print('#average displacement square of all the atoms',file=datafile) + + call print(' Input file: '//trim(xyzfilename)) + call print('Output file: '//trim(datafilename)) + call print('From step '//from//' to step '//to) + call print('Also check atom '//one_atom) + call print('') + + call print('Reading data...') + + call read(structure, xyzfile, error=error) + call map_into_cell(structure) + + allocate(travel(3,structure%N)) + travel = 0 + + frame_count = 0 + frames_processed = 0 + + do + + if (error/=0) exit + + frame_count = frame_count + 1 + + if ((frame_count.gt.to) .and. (to.gt.0)) exit + + write(mainlog%unit,'(a,a,i0,a,$)') achar(13),'Frame ',frame_count, ' ' + + if (frame_count.eq.from) then + call print('Reference structure is at step '//frame_count) + reference = structure + prev_structure = structure + travel=0 + endif + + if (frame_count.ge.from) then + frames_processed = frames_processed + 1 + + + ! now detect wrappings + do i=1,structure%N + if(normsq(structure%pos(:,i)-prev_structure%pos(:,i)) > 1) then + ! atom wrapped + d = distance_min_image(structure, i, prev_structure%pos(:,i), shift) + travel(:,i) = travel(:,i) - shift + endif + end do + + one_r2 = 0._dp + ave_r2 = 0._dp + do i = 1, structure%N + ave_r2 = ave_r2 + normsq(reference%pos(:,i) - structure%pos(:,i) - (structure%lattice .mult. travel(:,i))) + enddo + ave_r2 = ave_r2 / structure%N + if (one_atom.ne.0) then + one_r2 = normsq(reference%pos(:,one_atom) - structure%pos(:,one_atom) - (structure%lattice .mult. travel(:,one_atom))) + endif + + if (mod(frame_count-1,IO_Rate).eq.0) then + if (one_atom.eq.0) then + call print(frame_count//' '//ave_r2,file=datafile) + else + call print(frame_count//' '//ave_r2//' '//one_r2,file=datafile) + endif + endif + + prev_structure=structure + + endif + + + call read(structure,xyzfile,error=error) + call map_into_cell(structure) + + end do + + call print('') + call print('Read '//frame_count//' frames, processed '//frames_processed//' frames.') + + !Free up memory + call finalise(structure) + call finalise(reference) + call finalise(xyzfile) + call finalise(datafile) + + call print('Finished.') + + call verbosity_pop + call system_finalise + +end program diffusion diff --git a/src/Structure_processors/elastic_fields.F90 b/src/Structure_processors/elastic_fields.F90 new file mode 100644 index 0000000000..9d78c3980b --- /dev/null +++ b/src/Structure_processors/elastic_fields.F90 @@ -0,0 +1,106 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +program elastic + + use libAtoms_module + use elasticity_module, only: elastic_fields + + implicit none + + type(Atoms) :: at + type(CInoutput) :: infile, outfile + type(Dictionary) :: params + integer :: i, n, iostat, nargs + character(len=2048) :: comment, arg1, arg2, missing_params + real(dp) :: a, C11, C12, C44, l_cutoff, nneightol + + call system_initialise(PRINT_SILENT) + call verbosity_push(PRINT_NORMAL) + + call initialise(params) + + call param_register(params, 'a', PARAM_MANDATORY, a, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'C11', PARAM_MANDATORY, C11, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'C12', PARAM_MANDATORY, C12, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'C44', PARAM_MANDATORY, C44, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'cutoff', '5.0', l_cutoff, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'nneightol', '1.2', nneightol, help_string="No help yet. This source file was $LastChangedBy$") + + nargs = cmd_arg_count() + + if (nargs < 2) then + call print('Usage: elastic_fields [params]') + call print('') + call print('Parameters and default values are:') + call param_print(params) + call verbosity_push(PRINT_SILENT) + call system_finalise() + stop + end if + + call get_cmd_arg(1, arg1) + call get_cmd_arg(2, arg2) + + call initialise(infile, arg1) + call initialise(outfile, arg2, action=OUTPUT) + + + if (nargs > 2) then + if (.not. param_read_args(params, (/ (i, i=3,nargs ) /))) & + call system_abort('Error parsing command line') + end if + + if (.not. param_check(params, missing_params)) & + call system_abort('Missing mandatory parameters: '//missing_params) + + call print('Parameters:') + call param_print(params) + call print('') + + + ! Loop over all frames in input file + do n=0,infile%n_frame-1 + call read(infile, at, frame=n) + + call print('Frame '//n) + + call set_cutoff(at, l_cutoff) + at%nneightol = nneightol + + call elastic_fields(at, a, C11, C12, C44) + call write(outfile, at) + end do + call print('Done '//n//' frames!') + + call verbosity_push(PRINT_SILENT) + call system_finalise + +end program elastic diff --git a/src/Structure_processors/extract_EVB.F90 b/src/Structure_processors/extract_EVB.F90 new file mode 100644 index 0000000000..62e1f97909 --- /dev/null +++ b/src/Structure_processors/extract_EVB.F90 @@ -0,0 +1,227 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!Program to calculate the EVB E_GAP given +! -- an XYZ file with the coordinates, +! -- 2 PSF files with the 2 resonance states +! -- a form_bond_file containing the pair of atoms that form a bond in PSF1, but not in PSF2 +! -- a break_bond_file containing the pair of atoms that form a bond in PSF2, but not in PSF1 +! +program extract_EVB + + use libatoms_module + use potential_module + + implicit none + + type(Atoms) :: at + type(CInoutput) :: coord_file + type(InOutput) :: out_file + integer :: iframe, step_nr + real(dp) :: time_passed + real(dp) :: energy1, energy2 + !real(dp), allocatable :: f1(:,:) + character(len=STRING_LENGTH), allocatable :: output_lines(:) + integer :: lines_used, i + + type(Potential) :: pot + type(Potential) :: evbpot + character(len=STRING_LENGTH) :: args_str + character(STRING_LENGTH) :: mm_args_str + + !Input parameters + type(Dictionary) :: params_in + character(len=STRING_LENGTH) :: coord_filename, out_filename + character(len=STRING_LENGTH) :: PSF_file1, PSF_file2, & + filepot_program, cp2k_program !, Residue_Library + integer :: last_frame + real(dp) :: time_step + logical :: append_output + integer :: restart_every + + + call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) + call system_timer('program') + + !INPUT + call initialise(params_in) + call param_register(params_in, 'coord_file', PARAM_MANDATORY, coord_filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'outfile', PARAM_MANDATORY, out_filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'PSF_file1', PARAM_MANDATORY, PSF_file1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'PSF_file2', PARAM_MANDATORY, PSF_file2, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'filepot_program', PARAM_MANDATORY, filepot_program, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'cp2k_program', PARAM_MANDATORY, cp2k_program, help_string="No help yet. This source file was $LastChangedBy$") + !call param_register(params_in, 'Residue_Library', PARAM_MANDATORY, Residue_Library, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'last_frame', '0', last_frame, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'time_step', '0.0', time_step, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'append_output', 'F', append_output, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'restart_every', '1', restart_every, help_string="No help yet. This source file was $LastChangedBy$") + + if (.not. param_read_args(params_in)) then + !call print_usage + call print("extract_EVB coord_file outfile PSF_file1 PSF_file2 filepot_program cp2k_program [last_frame] [time_step] [append_output] [restart_every]",PRINT_ALWAYS) + call system_abort('could not parse argument line') + end if + + call finalise(params_in) + + !PRINT INPUT PARAMETERS + call print('Run parameters:') + call print(' coord_file '// trim(coord_filename) ) + call print(' outfile '// trim(out_filename) ) + call print(' PSF_file1 '// trim(PSF_file1) ) + call print(' PSF_file2 '// trim(PSF_file2) ) + !call print(' Residue_Library '// trim(Residue_Library) ) + call print(' cp2k_program '// trim(cp2k_program) ) + call print(' filepot_program '// trim(filepot_program) ) + call print(' last_frame '// last_frame ) + call print(' time_step '// time_step ) + call print(' restart_every '// restart_every//' steps' ) + if (restart_every/=1) call print(' Prints after every '//restart_every//' steps, synchronised with the restart frequency.') + if (append_output) then + call print(" Will not overwrite out_file (appending probably restart).") + else + call print(" Will overwrite out_file!!") + endif + call print('---------------------------------------') + call print('') + + + !Read coordinates and colvars + call print('Reading in the coordinates from file '//trim(coord_filename)//'...') + call initialise(coord_file, coord_filename, action=INPUT) + call print('Number of frames '//coord_file%n_frame) + + if (last_frame/=0) then + last_frame = min(last_frame, coord_file%n_frame) + else + last_frame = coord_file%n_frame + endif + call print('Last frame to be processed '//last_frame) + + !open output file, append if required + if (append_output) then + call initialise(out_file, out_filename, action=OUTPUT,append=.true.) + else + call initialise(out_file, out_filename, action=OUTPUT,append=.false.) + call print("# Step Nr. Time[fs] Energy_PSF1[eV] Energy_PSF2[eV] EVB(E1-E2)", file=out_file) + endif + + !initialise EVB potential + call initialise(pot,'FilePot command='//trim(filepot_program)//' property_list=pos min_cutoff=0.0') + call initialise(evbpot,args_str='EVB=T form_bond={1 2} break_bond={2 6} offdiagonal_A12=0.0 offdiagonal_mu12=0.0 save_energies=T save_forces=F', & + pot1=pot) + + !setup topology files + call system_command('cp '//trim(PSF_file1)//' quip_cp2k_evb1.psf') + call system_command('cp '//trim(PSF_file2)//' quip_cp2k_evb2.psf') + + + step_nr = 0 + + !allocate printing buffer + allocate(output_lines(restart_every)) + lines_used = 0 + + do iframe = 0, last_frame-1 + + call read(coord_file, at, frame=iframe) + + write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',(iframe+1) + + !get Step_nr and Time + if (.not.get_value(at%params,"i",step_nr)) then + step_nr = step_nr + 1 + endif + if (.not.get_value(at%params,"time",time_passed)) then + time_passed = step_nr * time_step + endif + + !Calculate EVB energy + + mm_args_str="Run_Type=MM cp2k_program="//trim(cp2k_program)//" clean_up_files=T save_output_files=F have_silica_potential=F centre_cp2k=F PSF_Print=USE_EXISTING_PSF" + + args_str = "evb_step="//step_nr//" mm_args_str={"//trim(mm_args_str)//"} topology_suffix1=_evb1 topology_suffix2=_evb2" + ! call set_value(at%params,'Library',trim(Residue_Library)) + + call calc(evbpot,at,energy=energy1,args_str=trim(args_str)) + !allocate(f1(1:3,1:at%N)) + !call calc(evbpot,at,energy=energy1,f=f1,args_str=trim(args_str)) + !deallocate(f1) + !call print_xyz(at,'evb_all.xyz',all_properties=.true.) + + if (.not. get_value(at%params,'EVB1_energy',energy1)) then + call system_abort('Could not find EVB1_energy') + endif + if (.not. get_value(at%params,'EVB2_energy',energy2)) then + call system_abort('Could not find EVB2_energy') + endif + + !Printing + + !if not append_output, we want to print time=0, too + if (.not.append_output .and. iframe==0) then + write (UNIT=output_lines(1),FMT="(I8,F13.3,3F18.8)") & + step_nr, time_passed, energy1, energy2, (energy1-energy2) + call print(output_lines(1),file=out_file) + output_lines(1) = "" + call finalise(at) + cycle + endif + + !printing into buffer + write (UNIT=output_lines(lines_used+1),FMT="(I8,F13.3,3F18.8)") & + step_nr, time_passed, energy1, energy2, (energy1-energy2) + lines_used = lines_used + 1 + + !printing buffer into file + if (lines_used == restart_every) then + do i=1,lines_used + call print(output_lines(i),file=out_file) + output_lines(i) = "" + enddo + deallocate(output_lines) + allocate(output_lines(restart_every)) + lines_used = 0 + endif + + call finalise(at) + + enddo + + call finalise(coord_file) + call finalise(at) + + call print('Finished.') + + call system_timer('program') + call system_finalise + +end program extract_EVB diff --git a/src/Structure_processors/extract_cv.F90 b/src/Structure_processors/extract_cv.F90 new file mode 100644 index 0000000000..d48070a363 --- /dev/null +++ b/src/Structure_processors/extract_cv.F90 @@ -0,0 +1,288 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!Program to extract position, velocity and force on certain atoms given +! -- an XYZ file with the coordinates, +! -- an XYZ file with the velocities (can be the same file) in a.u., +! -- an XYZ file with the forces (can be the same file) in a.u., +! -- a file containing the atoms (typically to which the constraint is applied) +! and the output name specified. +!Optionally restarts can be taken into account by printing synchronised +! with the restart frequency (e.g. restart_frequency=20). +!Optionally appends the output (of restart files) to the same outfile (e.g. append_output=T). +! +program extract_cv + + use libatoms_module + + implicit none + + type(Atoms) :: at, at_force, at_velo + type(CInoutput) :: coord_file, velo_file, force_file + type(InOutput) :: out_file + type(Table) :: colvar_atoms + real(dp), pointer :: f(:,:), v(:,:) + character(len=STRING_LENGTH), allocatable :: output_lines(:) + integer :: lines_used + integer :: iframe, step_nr + real(dp) :: time_passed + integer :: i + + !Input parameters + type(Dictionary) :: params_in + character(len=STRING_LENGTH) :: coord_filename + character(len=STRING_LENGTH) :: velo_filename + character(len=STRING_LENGTH) :: force_filename + character(len=STRING_LENGTH) :: out_filename + character(len=STRING_LENGTH) :: colvar_filename + integer :: last_frame + real(dp) :: time_step + integer :: restart_every + logical :: append_output + logical :: input_in_cp2k_units + logical :: skip_extra_firsts + + +! call system_initialise(verbosity=PRINT_ANALYSIS,enable_timing=.true.) +! call system_initialise(verbosity=PRINT_VERBOSE,enable_timing=.true.) + call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) + call system_timer('program') + + !INPUT + call initialise(params_in) + call param_register(params_in, 'coord_file' , PARAM_MANDATORY, coord_filename , help_string="input file containing positions") + call param_register(params_in, 'velo_file' , PARAM_MANDATORY, velo_filename , help_string="input file containing velocities") + call param_register(params_in, 'force_file' , PARAM_MANDATORY, force_filename , help_string="input file containing forces") + call param_register(params_in, 'atomlist_file' , PARAM_MANDATORY, colvar_filename , help_string="file with atomlist whose pos/velo/frc should be extracted") + call param_register(params_in, 'outfile' , PARAM_MANDATORY, out_filename , help_string="output filename") + call param_register(params_in, 'last_frame' , '0' , last_frame , help_string="last frame to be processed") + call param_register(params_in, 'time_step' , '0.0' , time_step , help_string="time step in case there is no Time param in the input posfile") + call param_register(params_in, 'restart_every' , '1' , restart_every , help_string="restart frequency") + call param_register(params_in, 'append_output' , 'F' , append_output , help_string="whether to append to output file") + call param_register(params_in, 'input_in_cp2k_units', 'F' , input_in_cp2k_units , help_string="whether units are in CP2K units or in A, A/fs, eV/A") + call param_register(params_in, 'skip_extra_firsts' ,'F' , skip_extra_firsts , help_string="whether to skip the extra printed first config (for QUIP outputs)") + + if (.not. param_read_args(params_in)) then + call print_usage + call system_abort('could not parse argument line') + end if + + call finalise(params_in) + + !PRINT INPUT PARAMETERS + call print('Run parameters:') + call print(' coord_file '// trim(coord_filename) ) + call print(' velo_file '// trim(velo_filename) ) + call print(' force_file '// trim(force_filename) ) + call print(' outfile '// trim(out_filename) ) + call print(' atomlist_file '// trim(colvar_filename) ) + call print(' last_frame '// last_frame ) + call print(' time_step '// time_step ) + call print(' restart_every '// restart_every//' steps' ) + if (restart_every/=1) call print(' Prints after every '//restart_every//' steps, synchronised with the restart frequency.') + call print(' append_output '//append_output) + if (append_output) then + call print(" Will not overwrite out_file (appending probably restart).") + else + call print(" Will overwrite out_file!!") + endif + call print(' input_in_cp2k_units '//input_in_cp2k_units) + call print(' skip_extra_firsts '//skip_extra_firsts//" ONLY FOR cp2k_units=F !") + call print('---------------------------------------') + call print('') + + + !Read coordinates and colvars + call print('Reading in the coordinates from file '//trim(coord_filename)//'...') + call initialise(coord_file, coord_filename, action=INPUT) + call print('Number of frames '//coord_file%n_frame) + call print('Reading in the velocities from file '//trim(velo_filename)//'...') + call initialise(velo_file, velo_filename, action=INPUT) + call print('Number of frames '//velo_file%n_frame) + call print('Reading in the forces from file '//trim(force_filename)//'...') + call initialise(force_file, force_filename, action=INPUT) + call print('Number of frames '//force_file%n_frame) + + if (last_frame/=0) then + last_frame = min(last_frame, coord_file%n_frame, force_file%n_frame) + else + last_frame = min(coord_file%n_frame, velo_file%n_frame, force_file%n_frame) + endif + call print('Last frame to be processed '//last_frame) + + call print('Reading in the (colvar) atoms from file '//trim(colvar_filename)//'...') + call read_integer_table(colvar_atoms,trim(colvar_filename)) + + !open output file, append if required + if (append_output) then + call initialise(out_file, out_filename, action=OUTPUT,append=.true.) + else + call initialise(out_file, out_filename, action=OUTPUT,append=.false.) + call print("# Step Nr. Time[fs] Atom Nr. Pos_x[A] Pos_y[A] Pos_z[A] Vel_x[A/fs] Vel_y[A/fs] Vel_z[A/fs] Frc_x[eV/A] Frc_y[eV/A] Frc_z[eV/A]", file=out_file) + !call print("# Step Nr. Time[fs] Atom Nr. Pos.[A] Vel.[A/fs] Force[eV/A]",file=out_file) + endif + + step_nr = 0 + + !allocate printing buffer + allocate(output_lines(restart_every*colvar_atoms%N)) + lines_used = 0 + + do iframe = 0, last_frame-1 + + call read(coord_file, at, frame=iframe) + call read(velo_file, at_velo, frame=iframe) + call read(force_file, at_force, frame=iframe) + + write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',(iframe+1) + + if (iframe==0) then !check colvar atoms + if (any(colvar_atoms%int(1,1:colvar_atoms%N).gt.at%N)) & + call system_abort("Constraint atom(s) is >"//at%N) + + if ((.not.input_in_cp2k_units) .and. skip_extra_firsts) cycle !skip very first without force information + endif + if (iframe==1) then + if ((.not.input_in_cp2k_units) .and. skip_extra_firsts .and. append_output) cycle !skip the overlapping second for the restarts + endif + + !get Step_nr and Time + if (.not.get_value(at%params,"i",step_nr)) then + step_nr = step_nr + 1 + endif + if (.not.get_value(at%params,"time",time_passed)) then + if (.not.get_value(at%params,"Time",time_passed)) then + time_passed = step_nr * time_step + endif + endif + + !get velocity and force in a.u. + nullify(v) + if (.not. assign_pointer(at_velo, 'velo', v)) call system_abort("Could not find velo property.") + nullify(f) + if (.not. assign_pointer(at_force, 'frc', f)) then + if (.not. assign_pointer(at_force, 'force', f)) call system_abort("Could not find frc or force property.") + endif + + !printing into buffer + do i=1,colvar_atoms%N + if (input_in_cp2k_units) then + write (UNIT=output_lines(lines_used+1),FMT="(I8,F13.3,I8,9F13.8)") & + step_nr, time_passed, colvar_atoms%int(1,i), & + at%pos(1:3,colvar_atoms%int(1,i)), & + (v(1:3,colvar_atoms%int(1,i))*BOHR/AU_FS), & + (f(1:3,colvar_atoms%int(1,i))*HARTREE/BOHR) + else + write (UNIT=output_lines(lines_used+1),FMT="(I8,F13.3,I8,9F13.8)") & + step_nr, time_passed, colvar_atoms%int(1,i), & + at%pos(1:3,colvar_atoms%int(1,i)), & + (v(1:3,colvar_atoms%int(1,i))), & + (f(1:3,colvar_atoms%int(1,i))) + endif + lines_used = lines_used + 1 + enddo + + !printing buffer into file + if (lines_used == restart_every*colvar_atoms%N) then + !if (mod((iframe+1),restart_every)/=0) call system_abort("lines_used "//lines_used// & + ! " == restart_every "//restart_every//" * colvar_atoms%N "//colvar_atoms%N// & + ! ", but not frame "//(iframe+1)//" mod restart_every "//restart_every//" =0") + do i=1,lines_used + call print(output_lines(i),file=out_file) + output_lines(i) = "" + enddo + deallocate(output_lines) + allocate(output_lines(restart_every*colvar_atoms%N)) + lines_used = 0 + endif + + call finalise(at_force) + call finalise(at_velo) + call finalise(at) + + enddo + + call finalise(colvar_atoms) + call finalise(coord_file) + call finalise(velo_file) + call finalise(force_file) + call finalise(out_file) + call finalise(at_force) + call finalise(at_velo) + call finalise(at) + if (allocated(output_lines)) deallocate(output_lines) + + call print('Finished.') + + call system_timer('program') + call system_finalise + +contains + + subroutine read_integer_table(output_table,input_filename) + + type(Table), intent(out) :: output_table + character(len=*), intent(in) :: input_filename + type(InOutput) :: input_file + integer :: n, num_entries + integer :: dummy,stat + + call initialise(input_file,trim(input_filename),action=INPUT) + read (input_file%unit,*) num_entries + call allocate(output_table,1,0,0,0,num_entries) + do n=1,num_entries + dummy = 0 + read (input_file%unit,*,iostat=stat) dummy + if (stat /= 0) exit + call append(output_table,dummy) + enddo + if (output_table%N.ne.num_entries) call system_abort('read_integer_table: Something wrong with the atomlist file') + call finalise(input_file) + + end subroutine read_integer_table + + subroutine print_usage + + call print("Usage: extract_cv coord_file force_file colvar_file outfile [restart_every=1] [append_output=F] [last_frame=0] [time_step=0.0]") + call print(" coord_file XYZ coordinate file") + call print(" velo_file XYZ file with velocities stored in 'velo' property") + call print(" force_file XYZ file with forces stored in 'frc' property") + call print(" atomlist_file file containing the (colvar) atoms whose properties should be printed") + call print(" outfile output file with positions, velocities and forces on the (colvar) atoms in time.") + call print(" restart_every optionally stores the output in a buffer and prints synchronised with the restart frequency.") + call print(" Useful for restarted runs.") + call print(" append_output optionally append to an existing output file without reprinting the header") + call print(" Useful for restarted runs.") + call print(" last_frame optionally processes only the first last_frame frames. 0 means process all frames.") + call print(" time_step optionally sets the time step between frames. It is used if 'time' is not stored in the coord_file.") + + end subroutine print_usage + +end program extract_cv diff --git a/src/Structure_processors/file_rewrite.F90 b/src/Structure_processors/file_rewrite.F90 new file mode 100644 index 0000000000..5cbd2b36cd --- /dev/null +++ b/src/Structure_processors/file_rewrite.F90 @@ -0,0 +1,97 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! Reads a sequence of configs and writes them back, mostly to convert from xyz to netcdf and back + +#include "error.inc" + +program file_rewrite +use libatoms_module +implicit none + + type(Dictionary) :: cli_params + character(len=STRING_LENGTH) :: infilename + character(len=STRING_LENGTH) :: outfilename + logical :: netcdf4 + type(CInOutput) :: infile, outfile + type(Atoms) :: at + integer i + integer :: error = ERROR_NONE + + call system_initialise(PRINT_NORMAL) + + call initialise(cli_params) + call param_register(cli_params, 'infile', 'stdin', infilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'outfile', 'stdout', outfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'netcdf4', 'F', netcdf4, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(cli_params)) then + call print_usage() + call system_abort('could not parse argument line') + end if + call finalise(cli_params) + + call print("infile " // trim(infilename) // " outfile " // trim(outfilename) // " netcdf4 " // netcdf4) + + call initialise(infile, infilename, action=INPUT, no_compute_index=.true.) + call initialise(outfile, outfilename, action=OUTPUT, netcdf4=netcdf4) + + i = 1 + call read(infile, at, error=error) + do while (error == ERROR_NONE) + call write(outfile, at, error=error) + HANDLE_ERROR(error) + if (mod(i,100) == 0) write (*,'(I1,$)') mod(i/100,10) + call read(infile, at, error=error) + HANDLE_ERROR(error) + i = i + 1 + end do + ! We do not want to handle this error + call clear_error(error) + + call finalise(outfile) + call finalise(infile) + call system_finalise() + +contains + + subroutine print_usage() + + character(len=1024) my_exec_name + + if (EXEC_NAME == "") then + my_exec_name="" + else + my_exec_name=EXEC_NAME + endif + + call print("Usage: " // trim(my_exec_name)//" infile=filename(stdin) outfile=filename(stdout)[=file.nc for NETCDF] [netcdf4 (for output)]", PRINT_ALWAYS) + end subroutine print_usage + +end program file_rewrite diff --git a/src/Structure_processors/find_space_minim.F90 b/src/Structure_processors/find_space_minim.F90 new file mode 100644 index 0000000000..7d285f0983 --- /dev/null +++ b/src/Structure_processors/find_space_minim.F90 @@ -0,0 +1,291 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! find largest spherical hole in a configuation starting from some initial guess +#include "error.inc" +module find_space_minim_mod +use libatoms_module +use iso_c_binding, only : c_ptr, c_loc, c_f_pointer +implicit none + +real(dp), save :: rad, width + +contains + + ! x > r fo = 1-cos((x-r)/w * pi/2 + 3 pi /2) + ! f'(r) = sin(3 pi /2) pi/(2 w) = -pi/(2 w) + ! x <= r fi = o - x pi/(2 w) + ! fi(r) = fo(r) + ! 1 = o - r pi/(2 w) + ! o = 1 + r pi / (2 w) + +function func(x,data) + real(dp) :: x(:) + character, optional :: data(:) + real(dp) :: func + + integer :: i + type(c_ptr) :: at_ptr + type(Atoms), pointer :: at + real(dp) :: r_mag + + if (.not. present(data)) call system_abort("find_space_minim_mod func needs data") + if (size(x) /= 3) call system_abort("find_space_minim_mod func needs x(1:3)") + + at_ptr = transfer(data, at_ptr) + call c_f_pointer(at_ptr, at) + call atoms_repoint(at) + + func = 0.0_dp + do i=1, at%N + r_mag = distance_min_image(at, i, x(1:3)) + if (r_mag < rad) then + func = func + rep_E(r_mag) + endif + end do + +end function func + +function dfunc(x,data) + real(dp) :: x(:) + character, optional :: data(:) + real(dp) :: dfunc(size(x)) + + integer :: i + type(c_ptr) :: at_ptr + type(Atoms), pointer :: at + real(dp) :: r(3), r_mag + + if (.not. present(data)) call system_abort("find_space_minim_mod func needs data") + if (size(x) /= 3) call system_abort("find_space_minifind_space_minimeds x(1:3)") + + at_ptr = transfer(data, at_ptr) + call c_f_pointer(at_ptr, at) + call atoms_repoint(at) + + dfunc = 0.0_dp + do i=1, at%N + r = diff_min_image(at, i, x(1:3)) + r_mag = norm(r) + if (r_mag < rad) then + dfunc = dfunc + rep_dE(r, r_mag) + endif + end do + + +end function dfunc + +subroutine apply_precond_dummy(x,g,P_g,data,error) + real(dp) :: x(:), g(:), P_g(:) + character, optional :: data(:) + integer, optional :: error + + INIT_ERROR(error) + P_g = g + +end subroutine apply_precond_dummy + +subroutine bothfunc(x,E,f,data,error) + real(dp) :: x(:), E, f(:) + character, optional :: data(:) + integer,optional :: error + + integer :: i + type(c_ptr) :: at_ptr + type(Atoms), pointer :: at + real(dp) :: r(3), r_mag + + INIT_ERROR(error) + + if (.not. present(data)) call system_abort("find_space_minim_mod func needs data") + if (size(x) /= 3) call system_abort("find_space_minim_mod bothfunc needs x(1:3)") + + at_ptr = transfer(data, at_ptr) + call c_f_pointer(at_ptr, at) + call atoms_repoint(at) + + f = 0.0_dp + E = 0.0_dp + do i=1, at%N + r = diff_min_image(at, i, x(1:3)) + r_mag = norm(r) + if (r_mag < rad) then + E = E + rep_E(r_mag) + f = f + rep_dE(r, r_mag) + endif + end do + +end subroutine bothfunc + +function rep_E(r_mag) + real(dp) :: r_mag + real(dp) :: rep_E + + real(dp) :: f_envelope + + if (r_mag > rad) then + f_envelope = 0.0_dp + else if (r_mag < rad-width) then + f_envelope = 1.0_dp + else + f_envelope = 0.5_dp+0.5_dp*cos((r_mag-(rad-width))/width * 3.14159_dp) + endif + + rep_E = (2.0_dp - r_mag/rad) * f_envelope + +end function rep_E + +function rep_dE(r, r_mag) + real(dp) :: r(:), r_mag + real(dp) :: rep_dE(size(r)) + + real(dp) :: f_envelope, df_envelope + + if (r_mag > rad) then + f_envelope = 0.0_dp + df_envelope = 0.0_dp + else if (r_mag < rad-width) then + f_envelope = 1.0_dp + df_envelope = 0.0_dp + else + f_envelope = 0.5_dp+0.5_dp*cos((r_mag-(rad-width))/width * 3.14159_dp) + df_envelope = -0.5_dp*sin((r_mag-(rad-width))/width * 3.14159_dp) * (1.0_dp/width) * 3.14159_dp + endif + + rep_dE = ((2.0_dp - r_mag/rad) * df_envelope - 1.0_dp/rad * f_envelope) * r/r_mag +end function rep_dE + +subroutine hook(x,dx,E,done,do_print,data) + use system_module + real(dp), intent(in) ::x(:) + real(dp), intent(in) ::dx(:) + real(dp), intent(in) ::E + logical, intent(out) :: done + logical, optional, intent(in) :: do_print + character(len=1),optional, intent(in) ::data(:) + + done = norm(dx) .feq. 0.0_dp + +end subroutine hook + +end module find_space_minim_mod + +program find_space_minim +use libatoms_module +use find_space_minim_mod, only : func, bothfunc, apply_precond_dummy, hook, rad, width +use iso_c_binding, only : c_ptr, c_loc, c_f_pointer +implicit none + + real(dp) :: r(3), prev_r(3), orig_r(3) + integer :: closest_list(100) + type(Atoms) :: at + type(Atoms), target :: closest_at + type(c_ptr) :: closest_at_ptr + character(len=128) :: arg + integer :: data_size + character, allocatable :: data(:) + integer :: i_r, n_iter + real(dp) :: prev_val, final_val, prev_rad + integer :: i_at +real(dp) :: vi, vf + real(dp) :: expected_red + real(dp) :: rad_min, rad_increment + + call system_initialise() + call read(at, "stdin") + call get_cmd_arg(1, arg) + read (unit=arg, fmt=*) r(1) + call get_cmd_arg(2, arg) + read (unit=arg, fmt=*) r(2) + call get_cmd_arg(3, arg) + read (unit=arg, fmt=*) r(3) + call get_cmd_arg(4, arg) + read (unit=arg, fmt=*) rad_min + call get_cmd_arg(5, arg) + read (unit=arg, fmt=*) rad_increment + + do i_at=1, at%N + at%pos(1:3,i_at) = at%pos(1:3,i_at) - r(1:3) + end do + call map_into_cell(at) + orig_r = r + r = 0.0_dp + + if (at%N < 100) then + call find_closest(at, r, closest_list(1:at%N)) + call select(closest_at, at, list=closest_list(1:at%N)) + else + call find_closest(at, r, closest_list) + call select(closest_at, at, list=closest_list) + endif + + closest_at_ptr = c_loc(closest_at) + data_size = size(transfer(closest_at_ptr, data)) + allocate(data(data_size)) + data = transfer(closest_at_ptr,data) + width = 0.2_dp + + i_r = 1 + prev_val = 0.0_dp + final_val = 0.0_dp + prev_r = 0.0_dp + do while (final_val <= 1.0e-3 .and. i_r < 1000) + prev_r = r + prev_val = final_val + rad = rad_min+(i_r-1)*rad_increment + call verbosity_push(PRINT_SILENT) + ! n_iter = minim(r, func, dfunc, 'cg', 1.0e-6_dp, 1000, 'NR_LINMIN', eps_guess=1e-3_dp, hook=hook, data=data) + expected_red = 1.0e-2_dp + n_iter = n_minim(r, bothfunc, .false., apply_precond_dummy, vi, vf, expected_red, 1000, 1e-8_dp, hook=hook, data=data) + final_val = func(r, data) + call verbosity_pop() + call find_closest(at, r, closest_list(1:1)) + call print("rad " // rad// " n_iter " // n_iter // " relaxed val " // func(r, data) // " relaxed r" // r & + // " radius " // distance_min_image(at,closest_list(1),r)) + i_r = i_r + 1 + end do + + r = r + orig_r + prev_r = prev_r + orig_r + do i_at=1, at%N + at%pos(1:3,i_at) = at%pos(1:3,i_at) + orig_r(1:3) + end do + + if (i_r == 2) then + call print("WARNING: first try found no space at rad " // rad) + else + call find_closest(at, prev_r, closest_list(1:1)) + prev_rad = distance_min_image(at,closest_list(1),prev_r) + + call print("best r " // prev_r // " best_rad " // prev_rad // " best_val " // prev_val // " next_val " // final_val) + endif + + call system_finalise() +end program diff --git a/src/Structure_processors/histogram_process.F90 b/src/Structure_processors/histogram_process.F90 new file mode 100644 index 0000000000..6ec37a80b6 --- /dev/null +++ b/src/Structure_processors/histogram_process.F90 @@ -0,0 +1,326 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! compute Gaussian fit for a distribution(s) +! compute Kullback--Leibler divergence of two distributions +! compute the derivative of the free energy at UI_xi (using UI_use_xi, which is mostly 0) + +program histogram_process + +use libatoms_module + +implicit none + + !input + character(len=STRING_LENGTH) :: infile1_name, infile2_name, outfile_name, listfilename + logical :: file_is_list + integer :: n_data + logical :: KL_divergence, gaussian_fit, UI_unbias + type(InOutput) :: outfile + + !reading in infiles + type(Dictionary) :: cli_params + type(InOutput) :: list_file + character(STRING_LENGTH) :: inline + character(1024), dimension(2) :: fields + integer :: num_fields,status + logical :: read_more + + real(dp), allocatable :: histogram1(:,:), histogram2(:,:) + real(dp) :: sum_hist1, sum_hist2 + real(dp) :: amplitude, mean, variance, chisq + real(dp) :: KL_1_2, KL_2_1, KL + integer :: i + real(dp) :: UI_xi, UI_use_xi + real(dp) :: dA_dxi_unbiased, temp + + call system_initialise() + + call initialise(cli_params) + call param_register(cli_params, "infile1" , "stdin" , infile1_name , help_string="infile1 - containing histogram with no blank lines or comments") + call param_register(cli_params, "infile2" , "" , infile2_name , help_string="infile2 (needed for KL divergence)") + call param_register(cli_params, "outfile" , "stdout" , outfile_name , help_string="outfile") + call param_register(cli_params, "n_data" , PARAM_MANDATORY, n_data , help_string="number of data points in the histogram") + call param_register(cli_params, "KL_divergence", "F" , KL_divergence, help_string="calculate Kullback-Leibler divergence") + call param_register(cli_params, "file_is_list" , "F" , file_is_list , help_string="if infile1 is just a list of infile names (comments starting with # are allowed") + call param_register(cli_params, "gaussian_fit" , "F" , gaussian_fit , help_string="calculate Gaussian fit for the histogram") + call param_register(cli_params, "UI_unbias" , "F" , UI_unbias , help_string="calculate unbiased derivative of the free energy using Umbrella Integration") + call param_register(cli_params, "UI_xi" , "0.0" , UI_xi , help_string="the set value of the reaction coordinate (used as a label), for Umbrella Integration, default=0.0") + call param_register(cli_params, "UI_use_xi" , "0.0" , UI_use_xi , help_string="value of the reaction coordinate, around which the histogram is meant to be centred, for Umbrella Integration (often the histogram is shifted to 0), default=0.0") + call param_register(cli_params, "temperature" , "300.0" , temp , help_string="simulation temperature, needed for Umbrella Integration, default=300.0") + if (.not.param_read_args(cli_params)) then + call param_print_help(cli_params) + call print("Usage: "//trim(EXEC_NAME)//" infile1=stdin infile2 outfile=stdout n_data KL_divergence=F gaussian_fit=F", PRINT_ALWAYS) + call system_abort("Unable to parse command line") + endif + call finalise(cli_params) + + !check arguments + if (len_trim(infile2_name)==0 .and. KL_divergence) & + call system_abort("KL_divergence needs both infile1 and infile2") + if (n_data<1) & + call system_abort("At least 1 data point should be in the input files, specified in n_data. n_data="//n_data) + if (.not.KL_divergence .and. .not.gaussian_fit .and. .not. UI_unbias) & + call system_abort("At least 1 task of KL_divergence and gaussian_fit and UI_unbias should be chosen.") + if (UI_unbias .and. temp<=0._dp) & + call system_abort("UI_unbias needs temperature > 0, got "//temp) + + + allocate(histogram1(n_data,1:2)) + allocate(histogram2(n_data,1:2)) + + if (file_is_list) then + listfilename=trim(infile1_name) + call initialise(list_file,trim(listfilename),action=input) + status=0 + read_more=.true. + do while(status==0.and.read_more) + inline=read_line(list_file,status) + if (status==0) then + if (inline(1:1)/="#") then + read_more=.false. + else + call print("",file=outfile) + call print("",file=outfile) + endif + endif + enddo + if (num_fields==1 .and. KL_divergence) & + call system_abort("KL_divergence needs 2 infiles in the list file.") + endif + + call initialise(outfile,trim(outfile_name),action=output,append=.false.) + if (gaussian_fit) call print("GAUSS| #amplitude mean variance chisq",file=outfile) + if (KL_divergence) call print("DKL| #D_KL(1|2) D_KL(2|1) D_KL(1,2)",file=outfile) + + do while (status==0) + + if (file_is_list) then + call parse_string(inline,' ',fields,num_fields) + infile1_name=fields(1) + infile2_name=fields(2) + endif + + call print("Hist1: "//trim(infile1_name)) + call print("Hist2: "//trim(infile2_name)) + histogram1 = 0._dp + histogram2 = 0._dp + !read in histogram(s) + histogram1 = read_histogram(trim(infile1_name),n_data) + if (len_trim(infile2_name)/=0) histogram2 = read_histogram(trim(infile2_name),n_data) + + !Gaussian fit if needed + if (gaussian_fit .or. UI_unbias) then + call gaussian(histogram1(1:n_data,1:2),amplitude,mean,variance,chisq) + call print("Gaussian fit of histogram(1):") + call print(" amplitude: "//amplitude) + call print(" mean: "//mean) + call print(" variance: "//variance) + call print("") + if (UI_unbias) then + dA_dxi_unbiased = 1.0_dp * BOLTZMANN_K * temp * ( UI_use_xi - mean ) / variance + call print("UI| "//trim(infile1_name)//" "//UI_xi//" "//dA_dxi_unbiased//" "//mean//" "//variance//" "//chisq,file=outfile) + else + call print("GAUSS| "//trim(infile1_name)//" "//amplitude//" "//mean//" "//variance//" "//chisq,file=outfile) + endif + + if (len_trim(infile2_name)/=0) then + call gaussian(histogram2(1:n_data,1:2),amplitude,mean,variance,chisq) + call print("Gaussian fit of histogram(2):") + call print(" amplitude: "//amplitude) + call print(" mean: "//mean) + call print(" variance: "//variance) + if (UI_unbias) then + dA_dxi_unbiased = 1.0_dp * BOLTZMANN_K * temp * ( UI_use_xi - mean ) / variance + call print("UI| "//trim(infile2_name)//" "//UI_xi//" "//dA_dxi_unbiased//" "//mean//" "//variance//" "//chisq,file=outfile) + else + call print("GAUSS| "//trim(infile2_name)//" "//amplitude//" "//mean//" "//variance//" "//chisq,file=outfile) + endif + call print("") + endif + + endif + + !Kullback--Leibler divergence if needed + if (KL_divergence) then + !distributions must add up to 1 (not the same as being normalised) + sum_hist1 = sum(histogram1(1:n_data,2)) + sum_hist2 = sum(histogram2(1:n_data,2)) + histogram1(1:n_data,2) = histogram1(1:n_data,2) / sum_hist1 + histogram2(1:n_data,2) = histogram2(1:n_data,2) / sum_hist2 + sum_hist1=0._dp ; sum_hist2=0._dp + KL_1_2 = 0._dp + KL_2_1 = 0._dp + do i=1,n_data + sum_hist1 = sum_hist1 + histogram1(i,2) ; sum_hist2 = sum_hist2 + histogram2(i,2) + if (histogram1(i,2)>epsilon(0._dp) .and. histogram2(i,2)>epsilon(0._dp)) then + !call print("Adding "//histogram1(i,2)//"*log("//histogram1(i,2)//"/"//histogram2(i,2)//") to D_KL(1|2)") + KL_1_2 = KL_1_2 + histogram1(i,2) * log ( histogram1(i,2)/histogram2(i,2) ) + !call print("KL_1_2 so far "//KL_1_2) + !call print("Adding "//histogram2(i,2)//"*log("//histogram2(i,2)//"/"//histogram1(i,2)//") to D_KL(2|1)") + KL_2_1 = KL_2_1 + histogram2(i,2) * log ( histogram2(i,2)/histogram1(i,2) ) + !call print("KL_2_1 so far "//KL_2_1) + else + !call print("Skipping "//histogram1(i,2)//" and "//histogram2(i,2)) + endif + enddo + KL = 0.5_dp * (KL_1_2 + KL_2_1) + call print("Kullback--Leibler divergence:") + call print(" asym. D_KL(hist1|hist2): "//KL_1_2) + call print(" asym. D_KL(hist2|hist1): "//KL_2_1) + call print(" symm. D_KL(hist2,hist1): "//KL) + call print(" Sum(Hist1): "//sum_hist1) + call print(" Sum(Hist2): "//sum_hist2) + call print("DKL| "//trim(infile1_name)//" "//trim(infile2_name)//" "//KL_1_2//" "//KL_2_1//" "//KL,file=outfile) + call print("") + endif + + if (file_is_list) then + status=0 + read_more=.true. + do while(status==0.and.read_more) + inline=read_line(list_file,status) + if (status==0) then + if (inline(1:1)/="#") then + read_more=.false. + else + call print("",file=outfile) + call print("",file=outfile) + endif + endif + enddo + else + exit + endif + + enddo + + deallocate(histogram1) + deallocate(histogram2) + if (file_is_list) call finalise(list_file) + call finalise(outfile) + + call system_finalise() + +contains + + function read_histogram(filename,n_data) result(histo) + character(len=*), intent(in) :: filename + integer, intent(in) :: n_data + real(dp) :: histo(1:n_data,2) + type(InOutput) :: infile + integer :: i + + call initialise(infile,trim(filename),action=INPUT) + do i=1,n_data + call read_ascii(infile, histo(i,1:2)) + enddo + call finalise(infile) + + end function read_histogram + + + subroutine gaussian(histo,amplitude,mean,variance,chisq) + real(dp), intent(in) :: histo(:,:) + real(dp), intent(out) :: amplitude, mean, variance + real(dp), intent(out) :: chisq + real(dp) :: params(3) !(/A,B,C/) of fit: Ax^2+Bx+C + real(dp) :: x,x2,x3,x4,y,yx,yx2,one + integer :: n_data, i + real(dp) :: inversematrix(3,3) + + + n_data = size(histo,1) + + !fit a second order polynomial to (ln y)(x) + !least squares fit of log(y) (x) = log(1/2variance) - (x-mean)**2.0/(2*variance) + x = 0._dp + x2 = 0._dp + x3 = 0._dp + x4 = 0._dp + y = 0._dp + yx = 0._dp + yx2 = 0._dp + one = 0._dp + do i=1,n_data +! call print(histo(i,1)//" "//histo(i,2)) + if (histo(i,2)>epsilon(1._dp)) then + x = x + histo(i,1) + x2 = x2 + histo(i,1)*histo(i,1) + x3 = x3 + histo(i,1)*histo(i,1)*histo(i,1) + x4 = x4 + histo(i,1)*histo(i,1)*histo(i,1)*histo(i,1) +!call print(histo(i,1)//" "//log(histo(i,2))) + y = y + log(histo(i,2)) + yx = yx + log(histo(i,2))*histo(i,1) + yx2 = yx2 + log(histo(i,2))*histo(i,1)*histo(i,1) + one = one + 1._dp + !weight=1/histo(i,2) + endif + enddo + + + !call print((/x4,x3,x2,x3,x2,x,x2,x,one/)) + !call print( reshape((/x4,x3,x2,x3,x2,x,x2,x,one/),(/3,3/)) ) + call matrix3x3_inverse( reshape((/x4,x3,x2,x3,x2,x,x2,x,one/),(/3,3/)) , inversematrix ) + !call print(inversematrix) + !call print( inversematrix .mult. reshape((/x4,x3,x2,x3,x2,x,x2,x,one/),(/3,3/)) ) + !call print((/yx2,yx,y/)) + params = inversematrix .mult. (/yx2,yx,y/) + !call print(params) + + chisq = 0._dp + do i=1,n_data + if (histo(i,2)>epsilon(1._dp)) then + chisq = chisq + ( log(histo(i,2)) - (params(1)*histo(i,1)*histo(i,1) + params(2)*histo(i,1) + params(3) ) )**2.0_dp + endif + enddo + + call print("Chi^2 of fitting: "//chisq) + call print("est. variance: "//(chisq/(one-3))) + +! least_squares(histo(x=1:size(histo,1),1), & +! y=1:size(histo,1),2), & +! sig=0.01_dp, & +! a=(/A,B,C/), & +! chisq=chisq, & +! funcs=func) + + variance= -1._dp/2._dp*params(1) + mean=params(2)/variance + amplitude=exp(params(3)+mean**2._dp/(2._dp*variance)) * 2._dp*variance + + end subroutine gaussian + +! function func(x,afunc) +! real(dp) :: x,afunc +! afunc = A*x**2.0_dp + B*x + C +! end function func + +end program histogram_process diff --git a/src/Structure_processors/make_bulk_supercell.F90 b/src/Structure_processors/make_bulk_supercell.F90 new file mode 100644 index 0000000000..2087a97bef --- /dev/null +++ b/src/Structure_processors/make_bulk_supercell.F90 @@ -0,0 +1,38 @@ +program make_bulk_supercell +use libatoms_module +implicit none + + character(len=STRING_LENGTH) :: struct, outfile, Z_values_str + real(dp) :: vol_per_atom, vol_per_unit_cell + integer :: repeat(3) + type(Dictionary) :: cli_params + + type(Atoms) :: dup_cell + + call system_initialise(verbosity=PRINT_SILENT) + + call initialise(cli_params) + call param_register(cli_params,"struct", PARAM_MANDATORY, struct, help_string="name of structure (or full path)") + call param_register(cli_params,"outfile", "stdout", outfile, help_string="name of output file") + call param_register(cli_params,"vol_per_atom", "-1.0", vol_per_atom, help_string="volume per atom") + call param_register(cli_params,"vol_per_unit_cell", "-1.0", vol_per_unit_cell, help_string="volume per unit cell") + call param_register(cli_params,"repeat", "1 1 1", repeat, help_string="number of times to repeate supercell in each direction") + call param_register(cli_params,"Z_values", "", Z_values_str, help_string="values of atomic number to assign to each atom type in structure file") + if (.not. param_read_args(cli_params)) then + call print("Usage: make_bulk_supercell struct=[struct_name] outfile=[filename](stdout)", PRINT_ALWAYS) + call print(" [ vol_per_atom=volume | vol_per_unit_cell=volume ] [ repeat='n1 n2 n3'(1 1 1) ]", PRINT_ALWAYS) + call print(" [ Z_values='S Z1 Z2 ...' ]", PRINT_ALWAYS) + call print("In addition, struct names that do not begin with . or / will be searched for", PRINT_ALWAYS) + call print(" in $QUIP_DIR/structures/ or $HOME/share/quip_structures/, in that order", PRINT_ALWAYS) + call system_abort("Failed to parse command line arguments") + endif + call finalise(cli_params) + + dup_cell = structure_from_file(struct, vol_per_atom, vol_per_unit_cell, repeat, Z_values_str) + call verbosity_push(PRINT_NORMAL) + call write(dup_cell, outfile) + call verbosity_pop() + + call system_finalise() + +end program diff --git a/src/Structure_processors/make_k_mesh.F90 b/src/Structure_processors/make_k_mesh.F90 new file mode 100644 index 0000000000..a49ac7621c --- /dev/null +++ b/src/Structure_processors/make_k_mesh.F90 @@ -0,0 +1,39 @@ +program make_k_mesh +use libatoms_module +use tb_kpoints_module +implicit none + type(KPoints) :: kp + integer :: i + type(Dictionary) :: cli_params + character(len=STRING_LENGTH) :: outfile + type(inoutput) :: out_io + integer :: mesh(3) + logical :: monkhorst_pack + + call system_initialise(verbosity=PRINT_SILENT) + + call initialise(cli_params) + call param_register(cli_params, "outfile", "stdout", outfile, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, "mesh", "1 1 1", mesh, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, "monkhorst_pack", "F", monkhorst_pack, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(cli_params, ignore_unknown=.false.)) then + call print("Usage: make_k_mesh outfile=filename(stdout) mesh='n1 n2 n3'(1 1 1 ) monkhorst_pack=L(F)", PRINT_ALWAYS) + call system_abort("Failed to parse command line arguments") + endif + + if (any(mesh <= 0)) & + call system_abort("Invalid mesh " // mesh) + call initialise(kp, mesh, monkhorst_pack) + + call initialise(out_io, trim(outfile)) + call print('', file=out_io) + do i=1, kp%N + call print(' '//kp%k_pts(:,i)//' ', file=out_io) + end do + call print('', file=out_io) + call finalise(out_io) + call finalise(kp) + + call system_finalise() + +end program make_k_mesh diff --git a/src/Structure_processors/make_surface_slab_vasp.F90 b/src/Structure_processors/make_surface_slab_vasp.F90 new file mode 100644 index 0000000000..7c1f265fc5 --- /dev/null +++ b/src/Structure_processors/make_surface_slab_vasp.F90 @@ -0,0 +1,319 @@ +program test_surf_cell +use libatoms_module +implicit none + +type(Atoms) :: at_prim, at_surf, at_slab, at_slab_cut + +real(dp) :: surf_v(3), tol +logical :: third_vec_normal +integer :: max_n + +integer :: i +integer :: surf_i(3,3) +type(Dictionary) :: cli_params +real(dp) :: F(3,3), old_axes(3,3), old_axes_inv(3,3), new_axes(3,3), z_min, z_max, z_vacuum +integer :: n3_min, n3_max +character(len=STRING_LENGTH) :: comment, Z_order +character(len=STRING_LENGTH) :: verbosity + +call system_initialise(verbosity=PRINT_SILENT) + +call initialise(cli_params) +call param_register(cli_params, "surf_v", PARAM_MANDATORY, surf_v, help_string="vector normal to surface in Cartesian coords") +call param_register(cli_params, "z_min", PARAM_MANDATORY, z_min, help_string="minimum Z position to include in slab") +call param_register(cli_params, "z_max", PARAM_MANDATORY, z_max, help_string="maximum Z position to include in slab") +call param_register(cli_params, "z_vacuum", PARAM_MANDATORY, z_vacuum, help_string="amount of vacuum to create") +call param_register(cli_params, "third_vec_normal", "T", third_vec_normal, help_string="if true force the third vector to be normal to the surface") +call param_register(cli_params, "tol", "1.0e-6", tol, help_string="tolerance for various normal/parallel tests") +call param_register(cli_params, "max_n", "4", max_n, help_string="maximum supercell component to search for matching vectors") +call param_register(cli_params, "verbosity", "NORMAL", verbosity, help_string="verbosity level. VERBOSE for more output about surface cell") +if (.not. param_read_args(cli_params)) then + call param_print_help(cli_params) + call system_abort("Error reading params from command line") +endif +call finalise(cli_params) + +call verbosity_push(verbosity_of_str(trim(verbosity))) + +call read_vasp(at_prim, "stdin") + +call print("at_prim", verbosity=PRINT_VERBOSE) +if (current_verbosity() >= PRINT_VERBOSE) call write(at_prim, "stdout") + +call print("surface unit cell for lattice", verbosity=PRINT_VERBOSE) +call print(at_prim%lattice, verbosity=PRINT_VERBOSE) +call print ("normal to "//surf_v, verbosity=PRINT_VERBOSE) + +! create the surface unit cell lattice +call surface_unit_cell(surf_i, surf_v, at_prim%lattice, third_vec_normal=third_vec_normal, tol=tol, max_n=max_n) + +call print("", verbosity=PRINT_VERBOSE) +call print("in lattice coordinates", verbosity=PRINT_VERBOSE) +call print(surf_i, verbosity=PRINT_VERBOSE) +call print("in cartesian coordinates", verbosity=PRINT_VERBOSE) +call print(matmul(at_prim%lattice,surf_i), verbosity=PRINT_VERBOSE) + +! create the actual surface unit cell with atoms +call arbitrary_supercell(at_surf, at_prim, surf_i) + +! rotate to desired axes (surface normal to z) +old_axes(:,1) = at_surf%lattice(:,1) ! map to x +old_axes(:,2) = at_surf%lattice(:,1) .cross. at_surf%lattice(:,2) ! surf_v, map to z +old_axes(:,3) = at_surf%lattice(:,1) .cross. (at_surf%lattice(:,1) .cross. at_surf%lattice(:,2)) ! map to y +old_axes(:,1) = old_axes(:,1) / norm(old_axes(:,1)) +old_axes(:,2) = old_axes(:,2) / norm(old_axes(:,2)) +old_axes(:,3) = old_axes(:,3) / norm(old_axes(:,3)) +new_axes(:,1) = (/ 1, 0, 0 /) +new_axes(:,2) = (/ 0, 0, 1 /) +new_axes(:,3) = (/ 0, 1, 0 /) + +call print("old_axes", verbosity=PRINT_VERBOSE) +call print(old_axes, verbosity=PRINT_VERBOSE) +call print("new_axes", verbosity=PRINT_VERBOSE) +call print(new_axes, verbosity=PRINT_VERBOSE) + +call matrix3x3_inverse(old_axes, old_axes_inv) +F = matmul(new_axes, old_axes_inv) +new_axes = matmul(F, at_surf%lattice) +if (new_axes(3,3) < 0.0_dp) then + F(3,:) = -F(3,:) +endif + +call print("F", verbosity=PRINT_VERBOSE) +call print(F, verbosity=PRINT_VERBOSE) + +call print("F.old_axes", verbosity=PRINT_VERBOSE) +call print(matmul(F, old_axes), verbosity=PRINT_VERBOSE) + +call set_lattice(at_surf, matmul(F, at_surf%lattice), .true.) + +n3_min = floor((z_min-minval(at_surf%pos(3,:)))/at_surf%lattice(3,3))-1 +n3_max = floor((z_max-maxval(at_surf%pos(3,:)))/at_surf%lattice(3,3))+2 +call print("n3 min max "//n3_min//" "//n3_max, verbosity=PRINT_VERBOSE) +call supercell(at_slab, at_surf, 1, 1, n3_max-n3_min+1) +do i=1, at_slab%N + at_slab%pos(:,i) = at_slab%pos(:,i) + n3_min*at_surf%lattice(:,3) +end do + +call print("at_slab", verbosity=PRINT_VERBOSE) +if (current_verbosity() >= PRINT_VERBOSE) call write(at_slab, "stdout") + +call select(at_slab_cut, at_slab, mask=(at_slab%pos(3,:) >= z_min .and. at_slab%pos(3,:) <= z_max)) + +old_axes = at_slab_cut%lattice +old_axes(:,3) = old_axes(:,3)/norm(old_axes(:,3)) * (z_max-z_min + z_vacuum) +call set_lattice(at_slab_cut, old_axes, .false.) + +! print out final slab + +call get_param_value(at_prim, "VASP_Comment", comment) +comment = trim(comment)//" surf_v "//surf_v +call set_param_value(at_slab_cut, "VASP_Comment", comment) + +call get_param_value(at_prim, "VASP_Z_order", Z_order) +call set_param_value(at_slab_cut, "VASP_Z_order", Z_order) + +call print("at_slab_cut", verbosity=PRINT_VERBOSE) +if (current_verbosity() >= PRINT_VERBOSE) call write(at_slab_cut, "stdout") + +call write_vasp(at_slab_cut, "stdout", fix_order=.true., cartesian=.false.) + +call verbosity_pop() +call system_finalise() + +contains + +subroutine write_vasp(at, filename, fix_order, cartesian) + type(Atoms), intent(in) :: at + character(*), intent(in) :: filename + logical, intent(in) :: fix_order, cartesian + + type(inoutput) :: io + integer :: sorted_Zs(at%N) + integer, allocatable :: uniq_Zs(:) + integer :: i, j + character(len=STRING_LENGTH) :: comment, Z_order + integer :: n_species, i_species, Ns(100) + real(dp) :: new_lattice(3,3), new_lattice_inv(3,3) + + call initialise(io, filename) + call get_param_value(at, "VASP_Comment", comment) + + if (.not. get_value(at%params, 'VASP_Z_order', Z_order)) then + Z_order = '' + endif + + call print(trim(comment), file=io, verbosity=PRINT_ALWAYS) + + call print(1.0_dp, file=io, verbosity=PRINT_ALWAYS) + if (scalar_triple_product(at%lattice(:,1), at%lattice(:,2), at%lattice(:,3)) < 0.0_dp) then + new_lattice(:,1) = at%lattice(:,2) + new_lattice(:,2) = at%lattice(:,1) + new_lattice(:,3) = at%lattice(:,3) + call matrix3x3_inverse (new_lattice, new_lattice_inv) + else + new_lattice = at%lattice + new_lattice_inv = at%g + endif + call print(new_lattice(:,1), file=io, verbosity=PRINT_ALWAYS) + call print(new_lattice(:,2), file=io, verbosity=PRINT_ALWAYS) + call print(new_lattice(:,3), file=io, verbosity=PRINT_ALWAYS) + + if (fix_order) then + sorted_Zs = at%Z + call sort_array(sorted_Zs) + call uniq(sorted_Zs, uniq_Zs) + if (len_trim(Z_order) > 0) then + read(unit=Z_order, fmt=*) line, uniq_Zs + endif + + line = "" + do i=1, size(uniq_Zs) + line=trim(line)//" "//ElementName(uniq_Zs(i)) + end do + call print(trim(line), file=io, verbosity=PRINT_ALWAYS) + + line = "" + do i=1, size(uniq_Zs) + line=trim(line)//" "//count(at%Z == uniq_Zs(i)) + end do + + call print(trim(line), file=io, verbosity=PRINT_ALWAYS) + + if (cartesian) then + call print("Cartesian") + do i=1, size(uniq_Zs) + do j=1, at%N + if (at%Z(j) == uniq_Zs(i)) call print(at%pos(:,j), file=io, verbosity=PRINT_ALWAYS) + end do + end do + else + call print("Direct") + do i=1, size(uniq_Zs) + do j=1, at%N + if (at%Z(j) == uniq_Zs(i)) call print(matmul(new_lattice_inv,at%pos(:,j)), file=io, verbosity=PRINT_ALWAYS) + end do + end do + endif + + deallocate(uniq_Zs) + else + line=ElementName(at%Z(1)) + n_species = 1 + do i=2, at%N + if (at%Z(i) /= at%Z(i-1)) then + line=trim(line)//" "//ElementName(at%Z(i)) + n_species = n_species + 1 + endif + end do + call print(trim(line), file=io, verbosity=PRINT_ALWAYS) + + line=""//at%Z(1) + i_species = 1 + Ns(i_species) = 1 + do i=2, at%N + if (at%Z(i) /= at%Z(i-1)) then + i_species = i_species + 1 + endif + Ns(i_species) = Ns(i_species) + 1 + end do + call print(Ns(1:n_species), file=io, verbosity=PRINT_ALWAYS) + + if (cartesian) then + call print("Cartesian") + do i=1, at%N + call print(at%pos(:,i), file=io, verbosity=PRINT_ALWAYS) + end do + else + call print("Direct") + do i=1, at%N + call print(matmul(new_lattice_inv,at%pos(:,i)), file=io, verbosity=PRINT_ALWAYS) + end do + endif + end if + + call finalise(io) + +end subroutine write_vasp + + +subroutine read_vasp(at, filename) + type(Atoms), intent(inout) :: at + character(*), intent(in) :: filename + + type(Inoutput) :: io + character(len=STRING_LENGTH) :: comment, Z_order + character(len=10) :: species(100) + integer :: n_species, i, j, N_tot + integer :: Ns(100), species_Zs(100) + real(dp) :: lattice(3,3) + real(dp) :: lattice_scale + logical :: cartesian + integer :: status + + call initialise(io, filename) + line=read_line(io); comment=trim(line) + line=read_line(io); read (unit=line, fmt=*) lattice_scale + line=read_line(io); read (unit=line, fmt=*) lattice(:,1) + line=read_line(io); read (unit=line, fmt=*) lattice(:,2) + line=read_line(io); read (unit=line, fmt=*) lattice(:,3) + lattice = lattice * lattice_scale + ! species line is optional + line=read_line(io) + call split_string_simple(line, species, n_species, " ") + read(unit=species(1), fmt=*, iostat=status) Ns(1) + if (status == 0) then ! it's a number + read(unit=line, fmt=*) Ns(1:n_species) + do i=1, n_species + species_Zs(i) = i + end do + else ! actually species + line=read_line(io) + read(unit=line, fmt=*) Ns(1:n_species) + do i=1, n_species + species_Zs(i) = atomic_number(species(i)) + end do + endif + Z_order='S '//species_Zs(1:n_species) + line=read_line(io) + if (line(1:1) == 'S') line=read_line(io) + if (line(1:1) == 'c' .or. line(1:1) == 'C') then + cartesian = .true. + else if (line(1:1) == 'd' .or. line(1:1) == 'D') then + cartesian = .false. + else + call system_abort ("confused by cartesian/direct line of '"//trim(line)//"'") + endif + + call initialise(at, sum(Ns(1:n_species)), lattice) + N_tot = 0 + do i=1, n_species + do j=1, Ns(i) + line=read_line(io) + N_tot = N_tot + 1 + read (unit=line, fmt=*) at%pos(:,N_tot) + at%Z(N_tot) = species_Zs(i) + end do + end do + + call set_atoms(at, at%Z) + + if (cartesian) then + at%pos = at%pos * lattice_scale + else + at%pos = matmul(at%lattice, at%pos) + endif + + if (len_trim(comment) == 0) then + call set_param_value(at, "VASP_Comment", "none") + else + call set_param_value(at, "VASP_Comment", trim(comment)) + endif + + call set_param_value(at, "VASP_Z_order", trim(Z_order)) + + call finalise(io) + +end subroutine read_vasp + +end program diff --git a/src/Structure_processors/mean_var_correl.F90 b/src/Structure_processors/mean_var_correl.F90 new file mode 100644 index 0000000000..ddfffbbc4e --- /dev/null +++ b/src/Structure_processors/mean_var_correl.F90 @@ -0,0 +1,797 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! compute mean and/or variance and/or correlation of a grid of data over one of the two indices +! row index is called "bins", column index is called "time" + +module mean_var_correl_util_mod +use system_module +implicit none + +contains + +subroutine calc_correl(data, n_bins, n_data, over_bins, correlation_max_lag, correlation_subtract_mean, data_correl) + real(dp) :: data(:,:) + integer :: n_bins, n_data + logical :: over_bins + integer :: correlation_max_lag + logical :: correlation_subtract_mean + real(dp), allocatable :: data_correl(:,:) + + real(dp), allocatable :: data_mean(:) + + integer :: i, i_lag + + if (allocated(data_correl)) deallocate(data_correl) + if (over_bins) then + allocate(data_mean(size(data,2))) + data_mean = sum(data,1)/real(size(data,1),dp) + allocate(data_correl(min(n_bins, correlation_max_lag+1), n_data)) + data_correl = 0.0_dp + if (correlation_subtract_mean) then + do i_lag=0, min(n_bins-1, correlation_max_lag) + do i=1, n_bins-i_lag + data_correl(i_lag+1, :) = data_correl(i_lag+1, :) + (data(i,:)-data_mean(:))*(data(i+i_lag,:)-data_mean(:)) + end do + data_correl(i_lag+1, :) = data_correl(i_lag+1, :) / real(n_bins-i_lag, dp) + end do + else + do i_lag=0, min(n_bins-1, correlation_max_lag) + do i=1, n_bins-i_lag + data_correl(i_lag+1, :) = data_correl(i_lag+1, :) + (data(i,:))*(data(i+i_lag,:)) + end do + data_correl(i_lag+1, :) = data_correl(i_lag+1, :) / real(n_bins-i_lag, dp) + end do + endif + else ! over bins false + allocate(data_mean(size(data,1))) + data_mean = sum(data,2)/real(size(data,2),dp) + allocate(data_correl(n_bins, min(correlation_max_lag+1,n_data))) + data_correl = 0.0_dp + if (correlation_subtract_mean) then + do i_lag=0, min(n_data-1, correlation_max_lag) + do i=1, n_data-i_lag + data_correl(:, i_lag+1) = data_correl(:, i_lag+1) + (data(:,i)-data_mean(:))*(data(:,i+i_lag)-data_mean(:)) + end do + data_correl(:, i_lag+1) = data_correl(:, i_lag+1) / real(n_data-i_lag, dp) + end do + else + do i_lag=0, min(n_data-1, correlation_max_lag) + do i=1, n_data-i_lag + data_correl(:, i_lag+1) = data_correl(:, i_lag+1) + (data(:,i))*(data(:,i+i_lag)) + end do + data_correl(:, i_lag+1) = data_correl(:, i_lag+1) / real(n_data-i_lag, dp) + end do + endif + endif + deallocate(data_mean) +end subroutine + +! effective N_ind samples from autocorrelation variance +subroutine calc_correlation_var_effective_N(data_correl, over_bins, correlation_var_effective_N_long_lag, effective_N) + real(dp) :: data_correl(:,:) + logical :: over_bins + integer :: correlation_var_effective_N_long_lag + real(dp) :: effective_N(:) + + real(dp) :: correl_0, correl_mean, correl_std_dev + integer :: i + + if (over_bins) then + if (correlation_var_effective_N_long_lag+1 < size(data_correl,1)) then + do i=1, size(data_correl,2) + correl_0 = data_correl(1, i) + correl_mean = sum(data_correl(correlation_var_effective_N_long_lag+1:,i)) / real(size(data_correl,1)-correlation_var_effective_N_long_lag, dp) + correl_std_dev = sqrt( sum((data_correl(correlation_var_effective_N_long_lag+1:,i)-correl_mean)**2) / real(size(data_correl,1)-correlation_var_effective_N_long_lag, dp) ) + if (correl_std_dev > 1.0e-8_dp) then + effective_N(i) = (correl_0/correl_std_dev)**2 + else + effective_N(i) = -1 + endif + end do + endif ! long_lag short enough + else ! over_bins false + if (correlation_var_effective_N_long_lag+1 < size(data_correl,2)) then + do i=1, size(data_correl,1) + correl_0 = data_correl(i, 1) + correl_mean = sum(data_correl(i,correlation_var_effective_N_long_lag+1:)) / real(size(data_correl,2)-correlation_var_effective_N_long_lag, dp) + correl_std_dev = sqrt( sum((data_correl(i,correlation_var_effective_N_long_lag+1:)-correl_mean)**2) / real(size(data_correl,2)-correlation_var_effective_N_long_lag, dp) ) + if (correl_std_dev > 1.0e-8_dp) then + effective_N(i) = (correl_0/correl_std_dev)**2 + else + effective_N(i) = -1 + endif + call print(" i " // i // " correl_0 " // correl_0 // " mean " // correl_mean // " std_dev " // correl_std_dev // " eff_N " // effective_N(i), verbosity=PRINT_VERBOSE) + end do + endif ! long_lag short enough + endif ! over_bins +end subroutine + +! effective N_ind samples from summed ac, a la Sokal +subroutine calc_summed_ac_effective_N(N, data_correl, over_bins, max_lag, effective_N) + integer :: N + real(dp) :: data_correl(:,:) + logical :: over_bins + integer :: max_lag + real(dp) :: effective_N(:) + + real(dp) :: correl_0, two_tau_int + integer :: i + + if (over_bins) then + do i=1, size(data_correl,2) + correl_0 = data_correl(1, i) + two_tau_int = 1.0_dp + 2.0_dp*sum(data_correl(2:max_lag+1,i))/correl_0 + effective_N(i) = real(N,dp)/two_tau_int + call print("summed_ac i " // i // " correl_0 " // correl_0 // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE) + end do + else ! over_bins false + do i=1, size(data_correl,1) + correl_0 = data_correl(i, 1) + two_tau_int = 1.0_dp + 2.0_dp*sum(data_correl(i,2:max_lag+1))/correl_0 + effective_N(i) = real(N,dp)/two_tau_int + call print("summed_ac i " // i // " correl_0 " // correl_0 // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE) + end do + endif ! over_bins +end subroutine + +function calc_c_hat(data, k) result(c_hat) + real(dp) :: data(:) + integer :: k + real(dp) :: c_hat + + real(dp) :: sum_0, sum_k, sum_sq_0, sum_sq_k, cross_covar + real(dp) :: N_minus_k + integer :: N + + N = size(data) + sum_0 = sum(data(1:N-k)) + sum_k = sum(data(1+k:N)) + sum_sq_0 = sum(data(1:N-k)**2) + sum_sq_k = sum(data(1+k:N)**2) + cross_covar = sum(data(1:N-k)*data(1+k:N)) + N_minus_k = real(N-k,dp) + + c_hat = ( cross_covar/N_minus_k - sum_0*sum_k/N_minus_k**2 ) / & + ( sqrt(sum_sq_0 - (sum_0**2)/N_minus_k)* & + sqrt(sum_sq_k - (sum_k**2)/N_minus_k) / (N_minus_k-1.0_dp) ) +end function + +! effective N_ind samples from summed ac, a la Kerl +subroutine calc_sliding_window_effective_N(data, over_bins, max_k, effective_N) + real(dp) :: data(:,:) + logical :: over_bins + integer :: max_k + real(dp) :: effective_N(:) + + real(dp), allocatable :: c_hat(:) + real(dp) :: two_tau_int + integer :: i, k + + ! John Kerl Ph.D. Thesis + allocate(c_hat(1:max_k)) + + if (over_bins) then + do i=1, size(data,2) + do k=1, max_k + c_hat(k) = calc_c_hat(data(:,i),k) + call print("c_hat " // k // " " // c_hat(k)//" "//(1.0_dp+2.0_dp*sum(c_hat(1:k))), verbosity=PRINT_VERBOSE) + end do + two_tau_int = 1.0_dp + 2.0_dp*sum(c_hat) + effective_N(i) = real(size(data,1),dp)/two_tau_int + call print(" i " // i // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE) + end do + else ! over_bins false + do i=1, size(data,1) + do k=1, max_k + c_hat(k) = calc_c_hat(data(i,:),k) + call print("c_hat " // k // " " // c_hat(k)//" "//(1.0_dp+2.0_dp*sum(c_hat(1:k))), verbosity=PRINT_VERBOSE) + end do + two_tau_int = 1.0_dp + 2.0_dp*sum(c_hat) + effective_N(i) = real(size(data,2),dp)/two_tau_int + call print(" i " // i // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE) + end do + endif ! over_bins + + deallocate(c_hat) +end subroutine + +! effective N_ind samples from binning (blocking), a la Hartman +subroutine calc_binning_effective_N(data, over_bins, effective_N) + real(dp) :: data(:,:) + logical :: over_bins + real(dp) :: effective_N(:) + + real(dp) :: bin_size_d + integer :: i, bin_size, N + real(dp) :: err_est, prev_err_est, best_err_est, mean, means_variance_1 + + if (over_bins) then + do i=1, size(data,2) + N = size(data,1) + err_est=0.0_dp + best_err_est = -1.0_dp + bin_size_d = 1 + do while (bin_size_d > 0 .and. bin_size_d <= N/5) + bin_size = bin_size_d + + prev_err_est = err_est + err_est = binned_err_estimator(data(:,i),bin_size) + + if (err_est < prev_err_est .and. abs(err_est-prev_err_est)/(0.5_dp*(err_est+prev_err_est)) < 0.1_dp) best_err_est = err_est + call print("binning_effective_N " // bin_size//" "//err_est, verbosity=PRINT_VERBOSE) + bin_size_d = bin_size_d * 2 + end do + call print("", verbosity=PRINT_VERBOSE) + + if (best_err_est < 0.0_dp) best_err_est = prev_err_est + + mean = sum(data(:,i))/real(N,dp) + means_variance_1 = sum((data(:,i)-mean)**2)/real(N,dp) + effective_N(i) = means_variance_1/best_err_est**2 + if (effective_N(i) > N) effective_N(i) = N + end do + else + do i=1, size(data,1) + N = size(data,2) + err_est=0.0_dp + best_err_est = -1.0_dp + bin_size_d = 1 + do while (bin_size_d > 0 .and. bin_size_d <= N/5) + bin_size = bin_size_d + + prev_err_est = err_est + err_est = binned_err_estimator(data(i,:),bin_size) + + if (err_est < prev_err_est .and. abs(err_est-prev_err_est)/(0.5_dp*(err_est+prev_err_est)) < 0.1_dp) best_err_est = err_est + call print("binning_effective_N " // bin_size//" "//err_est, verbosity=PRINT_VERBOSE) + bin_size_d = bin_size_d * 2 + end do + call print("", verbosity=PRINT_VERBOSE) + + if (best_err_est < 0.0_dp) best_err_est = prev_err_est + + mean = sum(data(i,:))/real(N,dp) + means_variance_1 = sum((data(i,:)-mean)**2)/real(N,dp) + effective_N(i) = means_variance_1/best_err_est**2 + if (effective_N(i) > N) effective_N(i) = N + end do + end if +end subroutine + +function binned_err_estimator(data, bin_size) result(err_est) + real(dp) :: data(:) + integer :: bin_size + real(dp) :: err_est + + integer :: n_bins, bin_i, N + real(dp), allocatable :: means(:) + real(dp) :: means_mean, means_variance + + N = size(data) + n_bins = N/bin_size + allocate(means(n_bins)) + + do bin_i=1, n_bins + means(bin_i) = sum(data((bin_i-1)*bin_size+1:bin_i*bin_size))/real(bin_size,dp) + end do + means_mean = sum(means)/real(n_bins,dp) + means_variance = sum((means-means_mean)**2)/real(n_bins,dp) + err_est = sqrt(means_variance/real(n_bins,dp)) + + deallocate(means) +end function + +end module mean_var_correl_util_mod + +program mean_var_correl +use libatoms_module +use mean_var_correl_util_mod +implicit none + integer :: n_bins, n_data, n_weights, i, j, bin_i, skip, max_frame + logical :: do_weights + real(dp), allocatable :: data(:,:), weights(:), data_line(:), data_t(:,:), weights_t(:), weighted_data(:,:) + integer :: stat, new_data_array_size + character(len=128), allocatable :: bin_labels(:) + type(Dictionary) :: cli_params, data_params + logical :: do_mean, do_var, do_histogram, do_correl, correlation_subtract_mean, do_correlation_var_effective_N, do_summed_ac_effective_N, do_sliding_window_effective_N, do_binning_effective_N, do_exp_smoothing + logical :: do_bimod + real(dp) :: exp_smoothing_time + integer :: exp_smoothing_bin_i + integer :: histogram_n_bins + real(dp) :: histogram_min_v, histogram_max_v, histogram_cur_min_v, histogram_cur_max_v, histogram_extra_width, histogram_bin_width + logical :: do_histogram_effective_N, do_histogram_correl + character(len=STRING_LENGTH) :: infile_name, outfile_name + character(len=102400) :: myline + type(inoutput) :: infile, outfile + real(dp), allocatable :: data_mean(:), data_var(:), data_correl(:,:), data_histogram(:,:,:), data_histogram_data(:,:,:), data_histogram_correl(:,:) + real(dp), allocatable :: data_bimod(:), data_3_mom(:), data_4_mom(:) + real(dp), allocatable :: smooth_data_v(:) + integer :: reduction_index, other_index, sz, r_sz, correlation_max_lag, n_correl_print, correlation_var_effective_N_long_lag, sliding_window_effective_N_max_k, summed_ac_effective_N_max_lag + logical :: over_bins, over_time + real(dp), allocatable :: correlation_var_effective_N(:), summed_ac_effective_N(:), sliding_window_effective_N(:), binning_effective_N(:), histogram_effective_N(:,:) + character(len=STRING_LENGTH) :: verbosity_str + + call system_initialise() + + call initialise(cli_params) + call param_register(cli_params, "infile", "stdin", infile_name, help_string="input filename") + call param_register(cli_params, "outfile", "stdout", outfile_name, help_string="output filename") + call param_register(cli_params, "skip", "0", skip, help_string="skip this many initial frames") + call param_register(cli_params, "max_frame", "0", max_frame, help_string="stop at this frame. if 0, continue until end") + call param_register(cli_params, "mean", "F", do_mean, help_string="calculate mean") + call param_register(cli_params, "exp_smoothing", "F", do_exp_smoothing, help_string="calculate exponentially smoothed data") + call param_register(cli_params, "exp_smoothing_time", "100", exp_smoothing_time, help_string="time constant for exponential smoothing (in units of frames). 0 => no smoothing") + call param_register(cli_params, "exp_smoothing_bin_i", "0", exp_smoothing_bin_i, help_string="bin to evaluate for exponential smoothing") + call param_register(cli_params, "variance", "F", do_var, help_string="calculate variance") + call param_register(cli_params, "bimodality", "F", do_bimod, help_string="calculate Sarle's bimodality coefficient") + call param_register(cli_params, "correlation_var_effective_N", "F", do_correlation_var_effective_N, help_string="calculate effective N from ratio of initial variance to long time autocorrelation variance") + call param_register(cli_params, "correlation_var_effective_N_long_lag", "1001", & + correlation_var_effective_N_long_lag, help_string="lag after which autocorrelation is assumed to be in long time regime (for effective_N calculation)") + call param_register(cli_params, "summed_ac_effective_N", "F", do_summed_ac_effective_N, help_string="calculate Sokals's summed_ac \tau_{int} based effective N from integrated autocorrelation") + call param_register(cli_params, "summed_ac_effective_N_max_lag", "1001", & + summed_ac_effective_N_max_lag, help_string="max lag to calculate autocorrelation estimator for summed_ac effective N") + call param_register(cli_params, "sliding_window_effective_N", "F", do_sliding_window_effective_N, help_string="calculate Kerl's sliding_window \tau_{int} based effective N from fancy integrated autocorrelation") + call param_register(cli_params, "sliding_window_effective_N_max_k", "1001", & + sliding_window_effective_N_max_k, help_string="max lag to calculate autocorrelation estimator for sliding window effective N") + call param_register(cli_params, "binning_effective_N", "F", do_binning_effective_N, help_string="calculate binning effective N") + call param_register(cli_params, "correlation", "F", do_correl, help_string="calculate autocorrelation") + call param_register(cli_params, "correlation_subtract_mean", "T", correlation_subtract_mean, help_string="subtract mean before calculating autocorrelation") + call param_register(cli_params, "correlation_max_lag", "2000", correlation_max_lag, help_string="maxmimum lag to compute autocorrelation for") + call param_register(cli_params, "histogram", "F", do_histogram, help_string="compute histogram") + call param_register(cli_params, "histogram_n_bins", "10", histogram_n_bins, help_string="number of bins for histogram calculation") + call param_register(cli_params, "histogram_extra_width", "0.1", histogram_extra_width, help_string="extra range to do histogram over, in fractions of max_val-min_val (ignored if histogram_min,max_v are used)") + call param_register(cli_params, "histogram_effective_N", "F", do_histogram_effective_N, help_string="if true calculate effective N for bins based on autocorrelation") + call param_register(cli_params, "histogram_correl", "F", do_histogram_correl, help_string="if true calculate autocorrelation for histogram bins") + call param_register(cli_params, "histogram_min_v", "0.0", histogram_min_v, help_string="minimum value to use for histogram range (if not specified, automatic)") + call param_register(cli_params, "histogram_max_v", "-1.0", histogram_max_v, help_string="maximum value to use for histogram range (if not specified, automatic)") + call param_register(cli_params, "over_bins", "F", over_bins, help_string="do mean/variance/correlation over bins") + call param_register(cli_params, "over_time", "F", over_time, help_string="do mean/variance/correlation over time") + call param_register(cli_params, "verbosity", "NORMAL", verbosity_str, help_string="verbosity level") + if (.not.param_read_args(cli_params)) then + call print("Usage: "//trim(EXEC_NAME)//" infile=stdin outfile=stdout mean=F variance=F correlation=F effective_N=F", PRINT_ALWAYS) + call print(" correlation_max_lag=1000 correlation_var_effective_N_long_lag=1001 over_bins=F over_time=T", PRINT_ALWAYS) + call system_abort("Unable to parse command line") + endif + call finalise(cli_params) + + if (over_bins .and. over_time) & + call system_abort("specified both over_bins="//over_bins//" over_time="//over_time) + + call verbosity_push(verbosity_of_str(trim(verbosity_str))) + + if (.not. over_bins .and. .not. over_time) then + over_bins = .false. + over_time = .true. + endif + + if (over_bins) then + reduction_index = 1 + other_index = 2 + else + reduction_index = 2 + other_index = 1 + endif + + call initialise(data_params) + call param_register(data_params, "n_bins", param_mandatory, n_bins, help_string="number of bins at each data timepoint") + call param_register(data_params, "n_data", '-1', n_data, help_string="number of data timepoints, < 0 to figure out from length of file") + call param_register(data_params, "do_weights", 'F', do_weights, help_string="If true, do weighted mean") + + call initialise(infile, infile_name, INPUT) + myline=read_line(infile) ! comment + myline=read_line(infile) ! data description + if (.not.param_read_line(data_params, trim(myline), ignore_unknown=.false.)) & + call system_abort("Couldn't parse n_bins or n_data in 2nd line of file") + + if (do_weights) then + if (over_bins) call system_abort("Can't do weighted mean over bins") + n_weights = 1 + else + n_weights = 0 + end if + + allocate(bin_labels(n_bins)) + do i=1, n_bins + bin_labels(i) = read_line(infile) + end do + allocate(data_line(n_bins+n_weights)) + if(skip > 0) then + do i=1,skip + call read_ascii(infile, data_line(:)) + end do + n_data = n_data-skip + end if + if (n_data > 0) then + if(max_frame > 0 .and. max_frame <= n_data) then + n_data = max_frame + end if + allocate(data(n_bins, n_data)) + if (n_weights > 0) then + allocate(weights(n_data)) + endif + do i=1, n_data + call read_ascii(infile, data_line(:)) + if (n_weights > 0) then + weights(i) = data_line(1) + data(:,i) = data_line(2:) + else + data(:,i) = data_line(:) + endif + end do + else ! n_data <= 0, figure out by reading + print *, "doing n_data = 0" + ! initial counters and storage + n_data = 0 + allocate(data(n_bins,1)) + if (n_weights > 0) allocate(weights(1)) + ! read a line + do while (.true.) + call read_ascii(infile, data_line(:), stat) + if (stat < 0 .or. (max_frame > 0 .and. n_data == max_frame)) then ! end + ! if we have extra space, reallocate to precise space + if (size(data,2) /= n_data) then + ! allocate temporary space + allocate(data_t(n_bins, n_data)) + ! copy into temporary + data_t = data(:,1:n_data) + ! reallocate intended space to exact size + deallocate(data) + allocate(data(n_bins, n_data)) + data = data_t + ! clear up temporary + deallocate(data_t) + ! do the same for weights + if (n_weights > 0) then + allocate(weights_t(n_data)) + weights_t = weights(1:n_data) + deallocate(weights) + allocate(weights(n_data)) + weights = weights_t + deallocate(weights_t) + endif + endif + exit ! from while loop + elseif (stat == 0) then ! add this line + ! if we don't have space for additional entry, reallocate it + if (n_data >= size(data,2)) then + ! allocate temporary space + allocate(data_t(n_bins,n_data)) + data_t = data + deallocate(data) + new_data_array_size = max(int(1.5*n_data),2) + allocate(data(n_bins, new_data_array_size)) + data(1:n_bins,1:n_data) = data_t(:,:) + deallocate(data_t) + if (n_weights > 0) then + allocate(weights_t(n_data)) + weights_t = weights + deallocate(weights) + allocate(weights(new_data_array_size)) + weights(1:n_data) = weights_t(:) + deallocate(weights_t) + endif + endif + ! add additional entry + n_data = n_data + 1 + if (n_weights > 0) then + weights(n_data) = data_line(1) + data(:,n_data) = data_line(2:) + else + data(:,n_data) = data_line(:) + endif + else ! real error + call system_abort("Read error in data " // stat) + endif + end do ! while + endif + deallocate(data_line) + print *, "final n_data", n_data + + sz = size(data, other_index) + r_sz = size(data, reduction_index) + + call initialise(outfile, outfile_name, OUTPUT) + + + allocate(data_mean(sz)) + if (n_weights > 0) then + allocate(weighted_data(size(data,1),size(data,2))) + do i=1, n_data + weighted_data(:,i) = data(:,i) * weights(i) + end do + data_mean = sum(weighted_data,reduction_index) / sum(weights) + deallocate(weighted_data) + else + data_mean = sum(data,reduction_index)/real(size(data,reduction_index),dp) + endif + + if (do_var .or. do_bimod) then + allocate(data_var(sz)) + if (over_bins) then + do i=1, sz + data_var(i) = sum((data(:,i)-data_mean(i))**2)/size(data,reduction_index) + end do + else + if (n_weights > 0) then + do i=1, sz + data_var(i) = sum(weights(:)*(data(i,:)-data_mean(i))**2)/sum(weights) + end do + else + do i=1, sz + data_var(i) = sum((data(i,:)-data_mean(i))**2)/size(data,reduction_index) + end do + endif + endif + endif + + ! b = \frac{(\mu_3^2/\mu_2^3) + 1.0}{\mu_4/\mu_2^2}, + if (do_bimod) then + allocate(data_bimod(sz)) + allocate(data_3_mom(sz)) + allocate(data_4_mom(sz)) + if (over_bins) then + do i=1, sz + data_3_mom(i) = sum((data(:,i)-data_mean(i))**3)/size(data,reduction_index) + data_4_mom(i) = sum((data(:,i)-data_mean(i))**4)/size(data,reduction_index) + end do + else + if (n_weights > 0) then + do i=1, sz + data_3_mom(i) = sum(weights(:)*(data(i,:)-data_mean(i))**3)/sum(weights) + data_4_mom(i) = sum(weights(:)*(data(i,:)-data_mean(i))**4)/sum(weights) + end do + else + do i=1, sz + data_3_mom(i) = sum((data(i,:)-data_mean(i))**3)/size(data,reduction_index) + data_4_mom(i) = sum((data(i,:)-data_mean(i))**4)/size(data,reduction_index) + end do + endif + endif + data_bimod = ((data_3_mom**2 / data_var**3) + 1.0) / (data_4_mom/data_var**2) + deallocate(data_3_mom, data_4_mom) + endif + + if (do_correl .or. do_correlation_var_effective_N .or. do_summed_ac_effective_N) then + call calc_correl(data, n_bins, n_data, over_bins, correlation_max_lag, correlation_subtract_mean, data_correl) + + if (do_correl) then + call print("# correl", file=outfile) + if (over_bins) then + n_correl_print = n_data + else + n_correl_print = min(n_data, correlation_max_lag+1) + endif + do i=1, n_correl_print + call print(""//data_correl(:,i), file=outfile) + end do + endif + + if (do_correlation_var_effective_N) then + allocate(correlation_var_effective_N(sz)) + call calc_correlation_var_effective_N(data_correl, over_bins, correlation_var_effective_N_long_lag, correlation_var_effective_N) + endif + if (do_summed_ac_effective_N) then + allocate(summed_ac_effective_N(sz)) + call calc_summed_ac_effective_N(size(data,reduction_index), data_correl, over_bins, summed_ac_effective_N_max_lag, summed_ac_effective_N) + endif + endif ! do_correl or do_effective_N + if (do_sliding_window_effective_N) then + allocate(sliding_window_effective_N(sz)) + call calc_sliding_window_effective_N(data, over_bins, sliding_window_effective_N_max_k, sliding_window_effective_N) + endif + if (do_binning_effective_N) then + allocate(binning_effective_N(sz)) + call calc_binning_effective_N(data, over_bins, binning_effective_N) + endif + + ! data(n_bins, n_data) + if (do_exp_smoothing) then + if (over_bins) then + call system_abort("Can't actually do exponentially smoothed time trace over bins") + else + myline="# bin_label value" + if (exp_smoothing_bin_i <= 0 .or. exp_smoothing_bin_i > n_bins) then + call system_abort("exp_smoothing_bin_i out of range "//exp_smoothing_bin_i) + endif + endif + call print(trim(myline), file=outfile) + if (over_bins) then + call system_abort("Can't actually do exponentially smoothed time trace over bins") + else + allocate(smooth_data_v(n_bins)) + smooth_data_v(1:n_bins) = data(1:n_bins, 1) + call print(trim(bin_labels(exp_smoothing_bin_i))//" "//smooth_data_v(exp_smoothing_bin_i), file=outfile) + do i=2, n_data + if (exp_smoothing_time > 0.0_dp) then + smooth_data_v(1:n_bins) = (1.0_dp - 1.0_dp/exp_smoothing_time)*smooth_data_v(1:n_bins) + 1.0_dp/exp_smoothing_time*data(1:n_bins, i) + else + smooth_data_v(1:n_bins) = data(1:n_bins, i) + endif + call print(trim(bin_labels(exp_smoothing_bin_i))//" "//smooth_data_v(exp_smoothing_bin_i), file=outfile) + end do + endif + end if ! do_exp_smoothing + + if (do_mean .or. do_var .or. do_bimod .or. do_correlation_var_effective_N .or. do_summed_ac_effective_N .or. do_sliding_window_effective_N .or. do_binning_effective_N) then + if (over_bins) then + myline = "#" + else + myline = "# bin_label" + endif + if (do_mean) myline = trim(myline) //" mean" + if (do_var) myline = trim(myline) //" var N" + if (do_bimod) myline = trim(myline) //" bimod" + if (do_correlation_var_effective_N) myline = trim(myline) // " correlation_var_effective_N correlation_var_effective_decorrel_time" + if (do_summed_ac_effective_N) myline = trim(myline) // " summed_ac_effective_N summed_ac_effective_decorrel_time" + if (do_sliding_window_effective_N) myline = trim(myline) // " sliding_window_effective_N sliding_window_effective_decorrel_time" + if (do_binning_effective_N) myline = trim(myline) // " binning_effective_N binning_effective_decorrel_time" + + call print(trim(myline), file=outfile) + + do i=1, sz + if (over_bins) then + myline = "" + else + myline = trim(bin_labels(i)) + endif + if (do_mean) myline = trim(myline) //" " // data_mean(i) + if (do_var) myline = trim(myline) //" " // data_var(i)//" "//size(data,reduction_index) + if (do_bimod) myline = trim(myline) //" " // data_bimod(i) + if (do_correlation_var_effective_N) then + if (correlation_var_effective_N(i) > 0) then + myline = trim(myline) // " " // correlation_var_effective_N(i) // " " // (size(data,reduction_index)/correlation_var_effective_N(i)) + else + myline = trim(myline) // " " // correlation_var_effective_N(i) // " " // 0 + endif + endif + if (do_summed_ac_effective_N) then + if (summed_ac_effective_N(i) > 0) then + myline = trim(myline) // " " // summed_ac_effective_N(i) // " " // (size(data,reduction_index)/summed_ac_effective_N(i)) + else + myline = trim(myline) // " " // summed_ac_effective_N(i) // " " // 0 + endif + endif + if (do_sliding_window_effective_N) then + if (sliding_window_effective_N(i) > 0) then + myline = trim(myline) // " " // sliding_window_effective_N(i) // " " // (size(data,reduction_index)/sliding_window_effective_N(i)) + else + myline = trim(myline) // " " // sliding_window_effective_N(i) // " " // 0 + endif + endif + if (do_binning_effective_N) then + if (binning_effective_N(i) > 0) then + myline = trim(myline) // " " // binning_effective_N(i) // " " // (size(data,reduction_index)/binning_effective_N(i)) + else + myline = trim(myline) // " " // binning_effective_N(i) // " " // 0 + endif + endif + call print(trim(myline), file=outfile) + end do + end if + + if (do_histogram) then + ! data(n_bins, n_data) + allocate(data_histogram(3, histogram_n_bins, sz)) + if (do_histogram_effective_N) then + allocate(data_histogram_data(histogram_n_bins, r_sz, sz)) + data_histogram_data = 0.0_dp + endif + data_histogram = 0.0_dp + do i=1, sz + if (histogram_max_v > histogram_min_v) then + histogram_cur_min_v = histogram_min_v + histogram_cur_max_v = histogram_max_v + else + if (over_bins) then + histogram_cur_min_v = minval(data(:,i)) + histogram_cur_max_v = maxval(data(:,i)) + else + histogram_cur_min_v = minval(data(i,:)) + histogram_cur_max_v = maxval(data(i,:)) + endif + histogram_extra_width = (histogram_cur_max_v-histogram_cur_min_v)*histogram_extra_width + histogram_cur_min_v = histogram_cur_min_v - histogram_extra_width + histogram_cur_max_v = histogram_cur_max_v + histogram_extra_width + endif + histogram_bin_width = (histogram_cur_max_v-histogram_cur_min_v)/histogram_n_bins + if (histogram_bin_width == 0.0_dp) histogram_bin_width = 1.0e-8_dp + do bin_i=1, histogram_n_bins + data_histogram(1, bin_i, i) = histogram_cur_min_v+(real(bin_i,dp)-0.5_dp)*histogram_bin_width + end do + do j=1, r_sz + if (over_bins) then + bin_i = (data(j,i) - histogram_cur_min_v)/histogram_bin_width+1 + else + bin_i = (data(i,j) - histogram_cur_min_v)/histogram_bin_width+1 + endif + if (bin_i >= 1 .and. bin_i <= histogram_n_bins) then + data_histogram(2,bin_i,i) = data_histogram(2,bin_i,i) + 1.0_dp + if (do_histogram_effective_N) then + data_histogram_data(bin_i, j, i) = 1 + endif + endif + end do ! r_sz + end do ! i + data_histogram(2,:,:) = data_histogram(2,:,:)/real(r_sz, dp) + ! root variance + data_histogram(3,:,:) = sqrt(data_histogram(2,:,:) - data_histogram(2,:,:)**2) + ! normalize + data_histogram(2:3,:,:) = data_histogram(2:3,:,:)/histogram_bin_width + if (do_histogram_effective_N) then + allocate(histogram_effective_N(histogram_n_bins,sz)) + do i=1, sz + call calc_correl(data_histogram_data(:,:,i), histogram_n_bins, n_data, .false., correlation_max_lag, .true., data_histogram_correl) + if (do_histogram_correl) then + do bin_i=1, histogram_n_bins + call print("# data_histogram_correl i="//i // " bin=" // bin_i) + do j=1, size(data_histogram_correl,2) + call print(data_histogram_correl(bin_i,j)) + end do + call print("") + call print("") + end do + endif + mainlog%prefix="EFF_N value_i="//i + call calc_correlation_var_effective_N(data_histogram_correl, .false., correlation_var_effective_N_long_lag, histogram_effective_N(:,i)) + mainlog%prefix="" + end do + endif + + if (do_histogram_effective_N) then + call print("# v p(v) rms(p(v)) effective_N", file=outfile) + else + call print("# v p(v) rms(p(v))", file=outfile) + endif + + do i=1, sz + if (over_bins) then + myline = "#" + else + myline = "# "//trim(bin_labels(i)) + endif + call print(trim(myline), file=outfile) + do bin_i=1, histogram_n_bins + if (do_histogram_effective_N) then + call print(data_histogram(:,bin_i,i)//" "//histogram_effective_N(bin_i,i), file=outfile) + else + call print(data_histogram(:,bin_i,i), file=outfile) + endif + end do + call print("", file=outfile) + call print("", file=outfile) + end do + end if ! do_histogram + + call finalise(outfile) + call system_finalise() + +end program + diff --git a/src/Structure_processors/mean_var_decorrelated_err.F90 b/src/Structure_processors/mean_var_decorrelated_err.F90 new file mode 100644 index 0000000000..c5ec9afb40 --- /dev/null +++ b/src/Structure_processors/mean_var_decorrelated_err.F90 @@ -0,0 +1,42 @@ +program do_statistics_decorrelated_err +use libatoms_module, only : dp, system_initialise, system_finalise, system_abort, verbosity_push, verbosity_pop, verbosity_of_str, initialise, finalise, read_file, print, operator(//), param_register, param_read_args +use libatoms_module, only : PRINT_SILENT, PRINT_ALWAYS, INPUT, STRING_LENGTH +use libatoms_module, only : inoutput, dictionary +use statistics_module, only : mean_var_decorrelated_err +implicit none + integer :: i, N + real(dp), allocatable :: A(:,:) + real(dp) :: m, v, decorrelation_t, decorrelated_error + character(len=100), allocatable :: lines(:) + type(inoutput) :: io + type(Dictionary) :: cli + character(len=STRING_LENGTH) :: verbosity_str + integer :: n_col + + call system_initialise(verbosity=PRINT_SILENT) + call initialise(cli) + call param_register(cli, "verbosity", "NORMAL", verbosity_str, help_string="verbosity level") + call param_register(cli, "n_col", "1", n_col, help_string="number of columns of data to be analyzed") + if (.not. param_read_args(cli, ignore_unknown=.false., task="mean_var_decorrelated_err CLI arguments")) then + call print("Usage: mean_var_decorrelated_err [ verbosity=LEVEL ] [ n_col=n(1) ]", PRINT_ALWAYS) + call system_abort("Failed to parse command line arguments") + end if + call finalise(cli) + call verbosity_push(verbosity_of_str(trim(verbosity_str))) + + call initialise(io, "stdin", INPUT) + + call read_file(io, lines, N) + allocate(A(N,n_col)) + do i=1, N + read (lines(i), *) A(i,:) + end do + do i=1, n_col + call mean_var_decorrelated_err(A(:,i), m, v, decorrelated_error, decorrelation_t) + call print("col " // i // " mean " // m // " variance " // v // " decorrelation_t " // decorrelation_t // " decorrelated_error " // decorrelated_error) + end do + + call verbosity_pop() + call system_finalise() + +end program diff --git a/src/Structure_processors/merge_traj.F90 b/src/Structure_processors/merge_traj.F90 new file mode 100644 index 0000000000..6c1c25ca94 --- /dev/null +++ b/src/Structure_processors/merge_traj.F90 @@ -0,0 +1,102 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +! Syntax: merge_traj + +program merge_traj + use libAtoms_module + + integer, parameter :: FN_MAX = 100 + + ! --- + + type(Atoms) :: at + type(CInOutput) :: infile, outfile + + ! --- + + character(FN_MAX) :: outfn, infn + character(FN_MAX), allocatable :: infndescr(:) + + integer :: i, j, frame, n + integer :: error + + ! --- + + call system_initialise + + n = cmd_arg_count() + allocate(infndescr(n-1)) + + call get_cmd_arg(1, outfn) + do i = 1, n-1 + call get_cmd_arg(i+1, infndescr(i)) + enddo + + call print("Creating merged trajectory file " // outfn) + call initialise(outfile, outfn, action=OUTPUT, error=error) + HANDLE_ERROR(error) + frame = 0 + do i = 1, n-1 + j = index(infndescr(i), "@") + if (j == 0) then + call print("..." // infndescr(i)) + call initialise(infile, infndescr(i), action=INPUT, error=error) + HANDLE_ERROR(error) + do j = 1, infile%n_frame + call read(infile, at, frame=j-1, error=error) + HANDLE_ERROR(error) + call write(outfile, at, frame=frame, error=error) + HANDLE_ERROR(error) + frame = frame + 1 + enddo + call finalise(infile) + else + infn = infndescr(i)(:j-1) + read (infndescr(i)(j+1:), *) j + call print("..." // trim(infn) // ", frame " // j) + call initialise(infile, infn, action=INPUT, error=error) + call read(infile, at, frame=j, error=error) + HANDLE_ERROR(error) + call write(outfile, at, frame=frame, error=error) + HANDLE_ERROR(error) + frame = frame + 1 + call finalise(infile) + endif + enddo + call finalise(outfile) + + deallocate(infndescr) + + call system_finalise + +endprogram merge_traj diff --git a/src/Structure_processors/move_displacement_field.F90 b/src/Structure_processors/move_displacement_field.F90 new file mode 100644 index 0000000000..48c1e02de4 --- /dev/null +++ b/src/Structure_processors/move_displacement_field.F90 @@ -0,0 +1,122 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! move displacement field along a shift vector (defined in reference config) to +! figure out which shifted atom's displacement corresponds to which original atom +program move_displacement_field +use libatoms_module +implicit none + real(dp) :: shift_vec(3) + real(dp) :: l_cutoff, dist_tol + real(dp), allocatable :: new_pos(:,:) + type(Atoms) :: config, ref_config + character(len=STRING_LENGTH) :: config_filename, ref_config_filename + type(CInoutput) :: config_io, ref_config_io + type(Dictionary) :: cli_params + real(dp) :: cur_displacement(3) + real(dp) :: dist + integer :: i, shifted_i + integer :: cell_image_Na, cell_image_Nb, cell_image_Nc + + call system_initialise() + call initialise(cli_params) + call param_register(cli_params, "config_filename", PARAM_MANDATORY, config_filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, "ref_config_filename", PARAM_MANDATORY, ref_config_filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, "shift_vec", PARAM_MANDATORY, shift_vec, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, "cutoff", "5.0", l_cutoff, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, "dist_tol", "0.3", dist_tol, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(cli_params)) then + call print("Usage: move_displacement_field config_filename=file ref_config_filename=file shift_vec={x y z}", PRINT_ALWAYS) + call print(" cutoff=r(5.0) dist_tol=t(0.3)", PRINT_ALWAYS) + call system_abort("confused by command line arguments") + endif + call finalise(cli_params) + + call print("parameters:") + call print("config_filename " // trim(config_filename)) + call print("ref_config_filename " // trim(ref_config_filename)) + call print("shift_vec " // shift_vec) + call print("cutoff " // l_cutoff) + call print("dist_tol " // dist_tol) + call print("") + + call initialise(config_io, config_filename, action=INPUT) + call read(config, config_io) + call finalise(config_io) + + call initialise(ref_config_io, ref_config_filename, action=INPUT) + call read(ref_config, ref_config_io) + call finalise(ref_config_io) + + if (config%N /= ref_config%N) call system_abort("number of atoms mismatch " // config%N // " " // ref_config%N) + + allocate(new_pos(3,config%N)) + + call set_cutoff(ref_config, l_cutoff) + call calc_connect(ref_config) + + call fit_box_in_cell(l_cutoff, l_cutoff, l_cutoff, ref_config%lattice, cell_image_Na, cell_image_Nb, cell_image_Nc) + cell_image_Na = max(1,(cell_image_Na+1)/2) + cell_image_Nb = max(1,(cell_image_Nb+1)/2) + cell_image_Nc = max(1,(cell_image_Nc+1)/2) + + new_pos(1:3,1:config%N) = config%pos(1:3,1:config%N) + + do i=1, config%N + if (mod(i,1000) == 1) write (*,'(a,$)') "." + ! atom closest to displaced position + shifted_i = closest_atom(ref_config, ref_config%pos(:,i)+shift_vec, cell_image_Na, cell_image_Nb, cell_image_Nc, dist=dist) + + if (current_verbosity() >= PRINT_VERBOSE) then + if (shifted_i > 0) then + call print("mapping displacement cur " // i // " " // config%pos(:,i) // " to " // shifted_i // " " // config%pos(:,shifted_i) // " dist " // dist) + endif + endif + + if (shifted_i > 0 .and. dist < dist_tol) then ! found a close match + ! current displacement of atom i + cur_displacement(1:3) = config%pos(:,i) - ref_config%pos(:,i) + ! new position of atom shifted_i from current displacement of atom i + new_pos(:,shifted_i) = ref_config%pos(:,shifted_i) + cur_displacement + else + if (current_verbosity() >= PRINT_VERBOSE) then + call print("no mapping for " // i // " " // config%pos(:,i)) + endif + endif + + end do + call print("") + + config%pos(1:3,1:config%N) = new_pos(1:3,1:config%N) + + call write(config, "stdout", prefix="SHIFTED_CONFIG") + + call system_finalise() +end program diff --git a/src/Structure_processors/msd_vibrations.F90 b/src/Structure_processors/msd_vibrations.F90 new file mode 100755 index 0000000000..9eb2af229b --- /dev/null +++ b/src/Structure_processors/msd_vibrations.F90 @@ -0,0 +1,131 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +program msd +use libatoms_module + character(len=STRING_LENGTH) :: infile_name + type(inoutput) :: infile + type(Atoms) :: current, mean, prev + type(Dictionary) :: cli_params + integer :: stat + integer :: i, n_config + integer :: shift(3) + real(dp) :: dummy + real(dp), pointer :: dr(:) + + call system_initialise() + + call initialise(cli_params) + call param_register(cli_params, 'infile', PARAM_MANDATORY, infile_name, help_string="No help yet. This source file was $LastChangedBy$") + + call print("n_args " // cmd_arg_count()) + + if (.not. param_read_args(cli_params)) then + call print('Usage: msd infile=filename.xyz') + call system_abort("Bad CLI parameter") + endif + call finalise(cli_params) + + call initialise(infile, infile_name) + + call read_xyz(current, infile, status=stat) + + n_config = 0 + do while (stat == 0) + n_config = n_config + 1 + if (mean%N == 0) then ! first config + mean = current + prev = current +! call print("mean_calc initial current") +! call print_xyz(current, mainlog) + else + do i=1, current%N + dummy = distance_min_image(current, current%pos(:,i), prev%pos(:,i), shift=shift) + if (any(shift /= 0)) then + current%pos(:,i) = current%pos(:,i) - (current%lattice .mult. shift) + endif + end do + mean%pos = mean%pos + current%pos + prev = current +! call print("mean_calc wrapped current") +! call print_xyz(current, mainlog) + endif + call read_xyz(current, infile, status=stat) + end do + + mean%pos = mean%pos/real(n_config,dp) + +! call print("mean") +! call print_xyz(mean, mainlog) + + call finalise(infile) + + call add_property(mean, "dr", 0.0_dp) + if (.not. assign_pointer(mean, "dr", dr)) & + call system_abort("Impossible failure to assign pointer for dr") + dr(:) = 0.0_dp + + call initialise(infile, infile_name) + + call read_xyz(current, infile, status=stat) + prev = current + do while (stat == 0) +! call print("msd_calc pre-wrap prev") +! call print_xyz(prev, mainlog) +! call print("msd_calc pre-wrap current") +! call print_xyz(current, mainlog) + do i=1, current%N + dummy = distance_min_image(current, current%pos(:,i), prev%pos(:,i), shift=shift) +! call print("dummy " // dummy // " shift " // shift) + if (any(shift /= 0)) then + current%pos(:,i) = current%pos(:,i) - (current%lattice .mult. shift) + endif + end do + prev = current + +! call print("msd_calc wrapped current") +! call print_xyz(current, mainlog) + do i=1, current%N + dr(i) = dr(i) + sum((current%pos(:,i)-mean%pos(:,i))**2) + end do + + call read_xyz(current, infile, status=stat) + end do + + dr = dr/real(n_config,dp) + + call finalise(infile) + + mainlog%prefix="MSD" + call print_xyz(mean, mainlog, all_properties=.true.) + mainlog%prefix="" + + call system_finalise() +end program msd diff --git a/src/Structure_processors/rdfd.F90 b/src/Structure_processors/rdfd.F90 new file mode 100644 index 0000000000..b2bdda6e78 --- /dev/null +++ b/src/Structure_processors/rdfd.F90 @@ -0,0 +1,323 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! RDFD +! Tool for calculating Radial Distribution Functions from xyz files +! The extra 'D' shows that the RDF is calculated as a function of distance from some centre and binned +! The centre is a position and not an atom +! +! rdfd +program RDFD + + use libatoms_module + + implicit none + + type(Atoms) :: at + type(InOutput) :: xyzfile, datafile + integer :: Za, Zb + integer :: frames_read, frames_processed + integer :: status + integer :: i, j + + !Binning & histograms + integer :: rdf_bin, dist_bin + integer :: num_rdf_bins, num_dist_bins + integer :: num_A_atoms, num_B_atoms + real(dp) :: r, B_density + integer, allocatable, dimension(:,:) :: rdf_data + integer, allocatable, dimension(:) :: num_atoms + + !Input + type(Dictionary) :: params_in + character(STRING_LENGTH) :: xyzfilename, datafilename + real(dp) :: d_cutoff, d_binwidth + real(dp) :: rdf_cutoff, rdf_binwidth + real(dp), dimension(3) :: centre + character(STRING_LENGTH) :: mask1, mask2 + integer :: IO_Rate + integer :: decimation + integer :: from, to + logical :: Gaussian_smoothing + real(dp) :: Gaussian_sigma + + !Start up LOTF, suppressing messages + call system_initialise(PRINT_NORMAL) + call verbosity_push(PRINT_NORMAL) + +#ifdef DEBUG + call print('********** DEBUG BUILD **********') + call print('') +#endif + + call initialise(params_in) + call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'AtomMask1', param_mandatory, mask1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'AtomMask2', param_mandatory, mask2, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'centre', '0. 0. 0.', centre, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'RDFCutoff', param_mandatory, rdf_cutoff, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'RDFBinWidth', param_mandatory, rdf_binwidth, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'DistCutoff', param_mandatory, d_cutoff, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'DistBinWidth', param_mandatory, d_binwidth, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'from', '0', from, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") +! call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") +! call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(params_in)) then + if (EXEC_NAME == '') then + call print_usage + else + call print_usage(EXEC_NAME) + end if + call system_abort('could not parse argument line') + end if + call finalise(params_in) + + call print('Run_parameters: ') + call print('==================================') + call print(' Input file: '//trim(xyzfilename)) + call print(' Output file: '//trim(datafilename)) + call print(' AtomMask1: '//trim(mask1)) + call print(' AtomMask2: '//trim(mask2)) + call print(' centre: '//round(centre(1),3)//' '//round(centre(2),3)//' '//round(centre(3),3)) + call print(' RDFCutoff: '//round(rdf_cutoff,3)) + call print(' RDFBinWidth: '//round(rdf_binwidth,3)) + call print(' DistCutoff: '//round(d_cutoff,3)) + call print(' DistBinWidth: '//round(d_binwidth,3)) + call print(' decimation: '//decimation) + if (decimation == 1) then + call print(' Processing every frame') + else + write(line,'(a,i0,a,a)')' Processing every ',decimation,th(decimation),' frame' + call print(line) + end if + call print(' from Frame: '//from) + call print(' to Frame: '//to) + call print(' IO_Rate: '//IO_Rate) + call print(' Gaussians: '//Gaussian_smoothing) + if (Gaussian_smoothing) call print(' sigma: '//round(Gaussian_sigma,3)) + call print('==================================') + call print('') + + call initialise(xyzfile,xyzfilename,action=INPUT) + + call print('Mask 1:') + call print('=======') + Za = Atomic_Number(mask1) + call print('') + call print('Selecting all '//trim(ElementName(Za))//' atoms (Z = '//Za//')') + call print('') + + call print('Mask 2:') + call print('=======') + Zb = Atomic_Number(mask2) + call print('') + call print('Selecting all '//trim(ElementName(Zb))//' atoms (Z = '//Zb//')') + call print('') + + if (d_cutoff < 0.0_dp) call system_abort('Distance cutoff < 0.0 Angstroms') + if (d_binwidth < 0.0_dp) call system_abort('Distance bin width < 0.0 Angstroms') + if (rdf_cutoff < 0.0_dp) call system_abort('RDF cutoff < 0.0 Angstroms') + if (rdf_binwidth < 0.0_dp) call system_abort('RDF bin width < 0.0 Angstroms') + + !Make the number of bins and bin widths consistent + num_rdf_bins = ceiling(rdf_cutoff / rdf_binwidth) + rdf_binwidth = rdf_cutoff / real(num_rdf_bins,dp) + num_dist_bins = ceiling(d_cutoff / d_binwidth) + d_binwidth = d_cutoff / real(num_dist_bins,dp) + + !Set up arrays + allocate( rdf_data(num_rdf_bins,num_dist_bins), num_atoms(num_dist_bins) ) + + rdf_data = 0 + num_atoms = 0 + + call print('') + call print('RDFs from ('//centre//') out to '//round(d_cutoff,3)//'A') + call print('Each RDF has '//num_rdf_bins//' bins x '//round(rdf_binwidth,3)//'A per bin = '//round(rdf_cutoff,3)//'A cutoff') + call print('') + + call print('Reading data...') + frames_read = 0 + frames_processed = 0 + + do + + call read_xyz(at,xyzfile,status=status) + if (status/=0) then + if (frames_processed > 1) call write_data + exit + end if + frames_read = frames_read + 1 + + ! Do the calculation between form and to: + if (frames_read.ge.from) then + if ((frames_read.gt.to) .and.(to.gt.0)) exit + ! Loop over all atoms + num_A_atoms = 0 + num_B_atoms = 0 + do i = 1, at%N + + !Count 'B' atoms + if (at%Z(i) == Zb) num_B_atoms = num_B_atoms + 1 + + !Do we have an 'A' atom? + if (at%Z(i) /= Za) cycle + + num_A_atoms = num_A_atoms + 1 + + !Is this 'A' atom within the cutoff of the centre? + r = distance_min_image(at,i,centre) + if (r >= d_cutoff) cycle + + !Increase the atom count at this distance + dist_bin = bin(0.0_dp,d_cutoff,d_binwidth,r) + num_atoms(dist_bin) = num_atoms(dist_bin) + 1 + + !Loop over all other atoms + do j = 1, at%N + + ! Skip self + if (i==j) cycle + + !Do we have a 'B' atom? + if (at%Z(j) /= Zb) cycle + + !Is this 'B' atom within the rdf cutoff of the 'A' atom? + r = distance_min_image(at,i,j) + if (r >= rdf_cutoff) cycle + + !Increase the count at this distance + rdf_bin = bin(0.0_dp,rdf_cutoff,rdf_binwidth,r) + rdf_data(rdf_bin,dist_bin) = rdf_data(rdf_bin,dist_bin) + 1 + + end do + + end do + + B_density = real(num_B_atoms,dp) / cell_volume(at) + + frames_processed = frames_processed + 1 + write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',frames_read + + if (mod(frames_processed,IO_Rate)==0) then + !call print('writing data to datafile '//trim(datafile%filename)) + call write_data + endif + endif + + !Skip ahead (decimation-1) frames + do i = 1, (decimation-1) + call read_xyz(xyzfile,status) + if (status/=0) exit + frames_read = frames_read + 1 + end do + if (status/=0) exit + + end do + + call print('Finished.') + call print('Read '//frames_read//' frames, processed '//frames_processed//' frames.') + + call verbosity_pop + call system_finalise() + +contains + + subroutine write_data + + integer :: i, j + real(dp) :: dist, rdf_dist, rdf, rdf_int, dV + + call initialise(datafile,datafilename,action=OUTPUT) + + do i = 1, num_dist_bins + + dist = (real(i,dp)-0.5_dp)*d_binwidth + + do j = 1, num_rdf_bins + + rdf_dist = (real(j,dp)-0.5_dp)*rdf_binwidth + dV = PI*rdf_binwidth * ( 4.0_dp*rdf_dist*rdf_dist + rdf_binwidth*rdf_binwidth/3.0_dp ) + + if (num_atoms(i) > 0) then + rdf_int = real(rdf_data(j,i),dp) / (real(num_atoms(i),dp)) + else + rdf_int = 0 + end if + rdf = rdf_int / ( dV * B_density ) + + call print(round(dist,5)//' '//round(rdf_dist,5)//' '//round(rdf,5)//' '//round(rdf_int,5),file=datafile) + + end do + + call print('',file=datafile) !Insert blank line to separate data sets + + end do + + call finalise(datafile) + + end subroutine write_data + + + subroutine print_usage(name) + + character(*), optional, intent(in) :: name + + if (present(name)) then + write(line,'(3a)')'Usage: ',trim(name),' [] [] [] []' + else + write(line,'(a)')'Usage: rdfd [] [] [] []' + end if + call print(line) + call print(' The input xyz file.') + call print(' An element symbol, e.g. H or Ca') + call print(' An element symbol, e.g. H or Ca') + call print(' The central atom.') + call print(' The width of bins into which rdfs are placed.') + call print(' The cutoff radius for the distance from the centre.') + call print(' The cutoff radius for the RDF in Angstroms.') + call print(' The width of each bin in Angstroms used for individual rdf calculations.') + call print(' The output data file.') + call print(' Optional. Only process 1 out of every n frames') + call print(' Optional. Only process frames from this frame') + call print(' Optional. Only process frames until this frame') + call print(' Optional. Write data after every n processed frames') + call print('') + + call verbosity_pop + call system_finalise + + end subroutine print_usage + +end program RDFD diff --git a/src/Structure_processors/rings.F90 b/src/Structure_processors/rings.F90 new file mode 100644 index 0000000000..50c5bb9156 --- /dev/null +++ b/src/Structure_processors/rings.F90 @@ -0,0 +1,109 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +program rings + use libatoms_module + + implicit none + + real(DP) :: CC_cutoff + integer, parameter :: MAX_RING_LEN = 20 + integer, parameter :: DIST_CUTOFF = MAX_RING_LEN+1 + integer, parameter :: MAX_GROUPS = 20 + + type(Dictionary) :: cli_params + character(len=STRING_LENGTH) :: infilename + type(CInOutput) :: infile + type(Atoms) :: at + integer i + integer :: error = ERROR_NONE + + integer :: diameter, o + + integer, allocatable :: dist(:, :) + integer :: ring_stat(MAX_RING_LEN) + + logical, allocatable :: mask(:) + + call system_initialise(PRINT_NORMAL) + + call initialise(cli_params) + call param_register(cli_params, 'infile', 'stdin', infilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'CC_cutoff', PARAM_MANDATORY, CC_cutoff, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(cli_params)) then + call system_abort('could not parse argument line') + end if + call finalise(cli_params) + + call print("infile " // trim(infilename)) + + call initialise(infile, infilename, action=INPUT, no_compute_index=.true.) + + i = 1 + call read(infile, at, error=error) + HANDLE_ERROR(error) + + call set_cutoff(at, CC_cutoff) + call calc_connect(at) + + allocate(dist(at%N, at%N)) + + ! + ! Create the graph of connected C-C + ! + + ring_stat = 0 + + allocate(mask(at%N)) + mask=.true. + + !mask = (at%Z == 6) .and. (at%pos(3, :) > 11.0_DP) + !mask = (at%Z == 6) + + call distance_map(at, dist, mask=mask, diameter=diameter) + call print("# Graph diameter: " // diameter) + call count_sp_rings(at, CC_cutoff, dist, MAX_RING_LEN, & + ring_stat, mask=mask) + + o = sum(ring_stat) + do i = 1, MAX_RING_LEN + write (*, '(I5,I10,F10.5)') i, ring_stat(i), 1.0_DP*ring_stat(i)/o + enddo + + deallocate(mask) + + deallocate(dist) + + call finalise(infile) + call system_finalise() + +end program rings diff --git a/src/Structure_processors/solvate.F90 b/src/Structure_processors/solvate.F90 new file mode 100644 index 0000000000..c8b31a81ea --- /dev/null +++ b/src/Structure_processors/solvate.F90 @@ -0,0 +1,177 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! solvate a molecule. Needs a solute and a solvent XYZ input file (only water). +! [x/y/z][min/max] specify the new lattice, which must not be smaller than the solute's lattice and larger than the solvate lattice. +! could be improved: e.g. shift the water file to cover *min -- *max, at the moment it works only if centred around the origin, +! multiply water file to cover any box size, +! check whether water molecules touch any other added water molecules. +! center_around_atom : to center the solvent around atom and shift that atom to the origin before mapping into cell + +program solvate + + use libatoms_module + + implicit none + + type(Atoms) :: at, wat, at2 + integer :: i, j, stat + type(dictionary) :: cli_params + character(len=STRING_LENGTH) :: filename, waterfilename, solvated_filename +! type(inoutput) :: xyzfile, waterfile + real(dp) :: xmin, xmax, ymin, ymax, zmin, zmax, exclusion, security_zone + logical :: add_molec + integer :: center_around_atom + real(dp) :: shift(3) + real(dp), pointer :: pos_p(:,:), avgpos_p(:,:) + + call system_initialise(verbosity=PRINT_SILENT) + call verbosity_push(PRINT_NORMAL) + + call initialise(cli_params) + call param_register(cli_params,"file","stdin", filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"waterfile","stdin", waterfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"outfile","stdout", solvated_filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"xmin",PARAM_MANDATORY, xmin, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"ymin",PARAM_MANDATORY, ymin, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"zmin",PARAM_MANDATORY, zmin, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"xmax",PARAM_MANDATORY, xmax, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"ymax",PARAM_MANDATORY, ymax, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"zmax",PARAM_MANDATORY, zmax, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"exclusion","2.4", exclusion, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"center_around_atom","0", center_around_atom, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"security_zone","1.0", security_zone, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(cli_params)) then + !call system_abort("Usage: decimate [file=(stdin)] [waterfile=(stdin)] xmin xmax ymin ymax zmin zmax [exclusion=(2.4)] [security_zone=(1.0)] [center_around_atom=0]") + call print_usage + call system_abort('could not parse argument line') + endif + call finalise(cli_params) + + !Read in the 2 files + call print("Reading file to solvate: "//trim(filename)) + call read(at, filename, error=stat) + if (stat /= 0) call system_abort('Could not read file to solvate.') + !center around given atom, if required + if (center_around_atom > 0) then + if (center_around_atom > at%N) call system_abort("center_around_atom must be less than the number of solvent atoms "//at%N) + shift = at%pos(1:3,center_around_atom) + do i=1,at%N + at%pos(1:3,i) = at%pos(1:3,i) - shift(1:3) + enddo + endif + call map_into_cell(at) + + call print("Reading waterfile: "//trim(waterfilename)) + call read(wat, waterfilename, error=stat) + if (stat /= 0) call system_abort('Could not read water file.') + call map_into_cell(wat) + + !check for cell size -- if the water file is at least as big as the solute. + do i=1,3 + do j=1,3 + if (at%lattice(i,j).gt.wat%lattice(i,j)) call system_abort('Too small water file') + enddo + enddo + + call print("Starting solvation.") + !Initialise the solvated atoms object + call initialise(at2,0,reshape((/xmax-xmin,0._dp,0._dp,0._dp,ymax-ymin,0._dp,0._dp,0._dp,zmax-zmin/),(/3,3/))) + + !Add solute atoms to at2 + do i=1,at%N + call add_atoms(at2,at%pos(1:3,i),at%Z(i)) + enddo + + !Add water molecules between the given limits to at2 + do i=1,wat%N,3 + add_molec = .false. + if (minval(wat%pos(1,i:i+2)).gt.xmin+security_zone .and. & + maxval(wat%pos(1,i:i+2)).lt.xmax-security_zone .and. & + minval(wat%pos(2,i:i+2)).gt.ymin+security_zone .and. & + maxval(wat%pos(2,i:i+2)).lt.ymax-security_zone .and. & + minval(wat%pos(3,i:i+2)).gt.zmin+security_zone .and. & + maxval(wat%pos(3,i:i+2)).lt.zmax-security_zone ) then + add_molec = .true. + endif + do j = 1,at%N + if (distance_min_image(at2,j,wat%pos(1:3,i )).lt.exclusion .or. & + distance_min_image(at2,j,wat%pos(1:3,i+1)).lt.exclusion .or. & + distance_min_image(at2,j,wat%pos(1:3,i+2)).lt.exclusion ) then + add_molec = .false. + endif + enddo + if (add_molec) then + call add_atoms(at2,wat%pos(1:3,i ),wat%Z(i )) + call add_atoms(at2,wat%pos(1:3,i+1),wat%Z(i+1)) + call add_atoms(at2,wat%pos(1:3,i+2),wat%Z(i+2)) + endif + enddo + + call map_into_cell(at2) + + !add avgpos property that can be used for the topology calc. + call add_property(at2,'avgpos',0._dp, n_cols=3) + if (.not.(assign_pointer(at2, "avgpos", avgpos_p))) call system_abort('??') + if (.not.(assign_pointer(at2, "pos", pos_p))) call system_abort('??') + avgpos_p(1:3,1:at2%N) = pos_p(1:3,1:at2%N) + + if (stat == 0) then + call print("Printing solvated file into "//trim(solvated_filename)) + call write(at2, solvated_filename) + endif + + call verbosity_pop() + call system_finalise() + +contains + + !call system_abort("Usage: decimate [file=(stdin)] [waterfile=(stdin)] xmin xmax ymin ymax zmin zmax [exclusion=(2.4)] [security_zone=(1.0)] [center_around_atom=0]") + subroutine print_usage + + call print("Usage: decimate [file=(stdin)] [waterfile=(stdin)] xmin xmax ymin ymax zmin zmax [exclusion=(2.4)] [security_zone=(1.0)] [center_around_atom=0]") + call print('') + call print(' file=filename, the solute file') + call print(' waterfile=filename, the solvent (only water) file, with cell size at least the size of the solute file') + call print(' xmin, the lower limit of the solvated file in the x direction (should be >= 0.5*solvent file cell edge in x direction)') + call print(' xmax, the lower limit of the solvated file in the y direction (should be <= 0.5*solvent file cell edge in x direction)') + call print(' ymin, the lower limit of the solvated file in the z direction (should be >= 0.5*solvent file cell edge in y direction)') + call print(' ymax, the lower limit of the solvated file in the x direction (should be <= 0.5*solvent file cell edge in y direction)') + call print(' zmin, the lower limit of the solvated file in the y direction (should be >= 0.5*solvent file cell edge in z direction)') + call print(' zmax, the lower limit of the solvated file in the z direction (should be <= 0.5*solvent file cell edge in z direction)') + call print(' [exclusion=0.], optionally keeps a layer around the solvent where there will be no solvent molecule') + call print(' [security_zone=1.], optionally keeps a layer on the edge of the solvated box where there will be no water molecule placed to avoid clashes in PBC') + call print(' [center_around_atom=1], optionally shifts the solute molecule so that the atom with this index will be at the origin') + + call print('') + + end subroutine + +end program solvate diff --git a/src/Structure_processors/solvate_silica.F90 b/src/Structure_processors/solvate_silica.F90 new file mode 100644 index 0000000000..f1c1ea5bec --- /dev/null +++ b/src/Structure_processors/solvate_silica.F90 @@ -0,0 +1,257 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! solvate a molecule. Needs a solute and a solvent XYZ input file. +! shifts and rotates the solvent file so that +! atom1_point has position atom1_pos +! atom1_point -> atom2_vector is` aligned with atom12_vector +! atom3 is in the atom1_pos - atom1_pos+atom12_vector - atom123_plane plane. +! don't include water molecules closer to the solute than exclusion +! rotation_sign to play around with + +program solvate_silica + + use libatoms_module + + implicit none + + type(Atoms) :: at, wat, at2 + type(dictionary) :: cli_params + character(len=STRING_LENGTH) :: filename, waterfilename + integer :: i, j, stat + + !solvation of solvent + real(dp) :: exclusion + integer :: silica_atoms + logical :: add + + !orientation of solvent + integer :: atom1_point, atom2_vector, atom3_plane + real(dp) :: atom1_pos(3), atom12_vector(3), atom123_plane_point(3) + integer :: rotation_sign1 + integer :: rotation_sign2 + real(dp) :: shift(3) + real(dp) :: vector_1(3), vector_2(3) + real(dp) :: theta, axis(3), origin(3) + real(dp) :: unit_vector12(3), projection_of_atom3_on_atom12_vector(3) + real(dp) :: surface_normal(3) + logical :: rotation2_pluspi + + call system_initialise(verbosity=PRINT_SILENT) +! call verbosity_push(PRINT_NORMAL) + + call initialise(cli_params) + call param_register(cli_params,"file","stdin", filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"waterfile","stdin", waterfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"silica_atoms",'0', silica_atoms, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"atom1_point",PARAM_MANDATORY, atom1_point, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"atom2_vector",PARAM_MANDATORY, atom2_vector, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"atom3_plane",PARAM_MANDATORY, atom3_plane, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'atom1_pos', '(/0.0 0.0 0.0/)', atom1_pos, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'atom12_vector', PARAM_MANDATORY, atom12_vector, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, 'atom123_plane_point', PARAM_MANDATORY, atom123_plane_point, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"exclusion","0.0", exclusion, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"rotation1_sign",'1', rotation_sign1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"rotation2_sign",'1', rotation_sign2, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"rotation2_pluspi",'F', rotation2_pluspi, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(cli_params)) then + !call system_abort("Usage: decimate [file=(stdin)] [waterfile=(stdin)] silica_atoms atom1_point atom2_vector atom3_plane atom1_pos atom12_vector atom123_plane_point exclusion rotation1_sign rotation2_sign2 rotation2_pluspi") + call verbosity_push(PRINT_NORMAL) + call print_usage + call system_abort('could not parse argument line') + endif + call finalise(cli_params) + + if (abs(rotation_sign1) /= 1) call system_abort("rotation1_sign must be +/-1") + if (abs(rotation_sign2) /= 1) call system_abort("rotation2_sign must be +/-1") + + !Read in the 2 files + call read(at, filename, error=stat) + if (stat /= 0) call system_abort('Could not read file to solvate.') + call map_into_cell(at) + call read(wat, waterfilename, error=stat) + if (stat /= 0) call system_abort('Could not read water file.') + call map_into_cell(wat) + + !Initialise the solvated atoms object + call initialise(at2,0,reshape(reshape(wat%lattice, (/9/)), (/3,3/))) + +!!!position and orientation of solvent + + !shift atom1_point to the origin (centre of rotation) + + shift = at%pos(1:3,atom1_point) + do i=1,at%N + at%pos(1:3,i) = at%pos(1:3,i) - shift(1:3) + enddo + call calc_connect(at) + call map_into_cell(at) + call calc_dists(at) + + !rotate solvent to align atom1->atom2 vector with atom12_vector + + !vectors we want to lay on top of each other + vector_1(1:3) = diff_min_image(at,atom1_point,atom2_vector) !pointing from atom1 -> atom2 + vector_2(1:3) = atom12_vector(1:3) !pointing from atom1 -> atom2, with arbitrary length + + call print('vector_1('//atom1_point//'->'//atom2_vector//') = '//vector_1(1:3)) + call print('vector_2('//atom1_point//'->'//atom2_vector//') = '//vector_2(1:3)) + + !calc. angle between the two vectors + theta = acos( dot_product(vector_1(1:3),vector_2(1:3)) / & + sqrt(dot_product(vector_1(1:3),vector_1(1:3))) / & + sqrt(dot_product(vector_2(1:3),vector_2(1:3))) ) + + call print('angle = '//theta) + + !calc. axis that is normal to both vectors + axis(1:3) = vector_1(1:3) .cross. vector_2(1:3) + + call print('axis = '//axis) + + origin(1:3) = 0._dp + + !rotate only the 2nd config + call rotate(at%pos, real(rotation_sign1,dp)*axis, theta, origin) + +call print('atom1--atom2 vector should be all right:') +call write(at, 'stdout') + + !rotate solvent around atom12_vector axis to move atom3_plane into the plane that is defined by + ! - origin(1:3) = (/0.,0.,0./), + ! - atom12_vector(1:3) and + ! - atom123_planepoint(1:3)-atom1_point(1:3) + + !projection of atom3 onto atom12_vector + ! (at1->at3 .dot. unit_vector) * unit_vector : the unit vector in atom12_vector direction + unit_vector12 = atom12_vector(1:3) / norm(atom12_vector(1:3)) + projection_of_atom3_on_atom12_vector(1:3) = & + ( (at%pos(1:3,atom3_plane)-at%pos(1:3,atom1_point)) .dot. unit_vector12(1:3) ) * unit_vector12(1:3) + +call print("Projection of atom3 to atom12 vector: "//projection_of_atom3_on_atom12_vector(1:3)) + + !we want to rotate this + vector_1(1:3) = at%pos(1:3,atom3_plane) - projection_of_atom3_on_atom12_vector(1:3) + !onto vector_2, i.e. vector from projection-point, _|_ to vector12, on the plane + surface_normal(1:3) = ( atom123_plane_point(1:3) - at%pos(1:3,atom1_point) ) .cross. atom12_vector(1:3) + vector_2(1:3) = surface_normal(1:3) .cross. atom12_vector(1:3) +!OR (-1)* the same __/\ + vector_2(1:3) = vector_2(1:3) / norm(vector_2(1:3)) * norm(vector_1(1:3)) + + call print('vector_1() = '//vector_1(1:3)) + call print('vector_2() = '//vector_2(1:3)) + + !calc. angle between the two vectors + theta = acos( dot_product(vector_1(1:3),vector_2(1:3)) / & + sqrt(dot_product(vector_1(1:3),vector_1(1:3))) / & + sqrt(dot_product(vector_2(1:3),vector_2(1:3))) ) + + call print('angle = '//theta) + + !calc. axis that is normal to both vectors + axis(1:3) = vector_1(1:3) .cross. vector_2(1:3) + + call print('axis = '//axis) + call print('atom12_vector should be the same = '//atom12_vector) + + origin(1:3) = 0._dp + + !rotate only the 2nd config + if (rotation2_pluspi) theta = theta + PI + call rotate(at%pos, (real(rotation_sign2,dp)) * axis, theta, origin) + +call print('atom3 should be in plane with vector12 and atom3_plane_point:') +call print('v13 x v12 . v1planepoint = '//(diff_min_image(at, atom1_point, atom3_plane) .cross. atom12_vector(1:3) .dot. atom123_plane_point(1:3))) +call write(at, 'stdout') + + !shifting it to the required position + do i=1,at%N + at%pos(1:3,i) = at%pos(1:3,i) + atom1_pos(1:3) + enddo + + !Add atoms to solvate to at2 + do i=1,at%N + call add_atoms(at2,at%pos(1:3,i),at%Z(i)) + enddo + + !add silica + do i=1,silica_atoms + call add_atoms(at2,wat%pos(1:3,i ),wat%Z(i )) + enddo + !Add water molecules between the given limits to at2 + do i=silica_atoms+1,wat%N,3 + add = .true. + do j = 1,at%N + if (distance_min_image(at2,j,wat%pos(1:3,i )).lt.exclusion .or. & + distance_min_image(at2,j,wat%pos(1:3,i+1)).lt.exclusion .or. & + distance_min_image(at2,j,wat%pos(1:3,i+2)).lt.exclusion ) then + add = .false. + endif + enddo + if (add) then + call add_atoms(at2,wat%pos(1:3,i ),wat%Z(i )) + call add_atoms(at2,wat%pos(1:3,i+1),wat%Z(i+1)) + call add_atoms(at2,wat%pos(1:3,i+2),wat%Z(i+2)) + endif + enddo + + call map_into_cell(at2) + call verbosity_push(PRINT_NORMAL) + if (stat == 0) call write(at2, 'stdout') + + call verbosity_pop() + call system_finalise() + +contains + + !call system_abort("Usage: decimate [file=(stdin)] [waterfile=(stdin)] silica_atoms atom1_point atom2_vector atom3_plane atom1_pos atom12_vector atom123_plane_point exclusion rotation1_sign rotation2_sign2 rotation2_pluspi") + subroutine print_usage + + call print("Usage: decimate [file=(stdin)] [waterfile=(stdin)] silica_atoms atom1_point atom2_vector atom3_plane atom1_pos atom12_vector atom123_plane_point exclusion rotation1_sign rotation2_sign2 rotation2_pluspi") + call print('') + call print(' file=filename, the solute file') + call print(' waterfile=filename, the solvent (containing silica and water) file, with cell size at least the size of the solute file the size of the solvated molecule will be the same as the cell of the waterfile') + call print(' silica_atoms, the number of silica atoms in the solvent file') + call print(' atom1_point, the solute atom with this index to set (atom1_point) coordinate in the solvent file') + call print(' atom2_vector, the solute atom with this index to set (atom1_point,atom2_vector) direction in the solvent file') + call print(' atom3_plane, the solute atom with this index to set (atom1_point,atom2_vector,atom3_plane) plane in the solvent file') + call print(' atom1_pos, the position of atom1_point in the solvated file') + call print(' atom12_vector, the direction of atom1_point -> atom2_vector vector in the solvated file') + call print(' atom123_plane point, a point on the plane that contains atom1_point, atom2_vector and atom3_plane in the solvated file') + call print(' [exclusion=0.], optionally keeps a layer around the solvent where there will be no solvent molecule (valid for water, not silica)') + call print(' [rotation1_sign=1], optionally rotate in the negative direction, when rotating the solute molecule to align atom1&2 with atom12_vector') + call print(' [rotation2_sign=1], optionally rotate in the negative direction, when rotating the solute molecule to rotate atom3_plane into the (atom1_pos,atom12_vector,atom123_plane_point) plane') + call print(' [rotation2_pluspi=F], optionally rotate pi more, to have atom3_plane on the other side of (atom1_point,atom2_vector) vector') + + call print('') + + end subroutine + +end program solvate_silica diff --git a/src/Structure_processors/structure_analysis_traj.F90 b/src/Structure_processors/structure_analysis_traj.F90 new file mode 100644 index 0000000000..fabccd18e5 --- /dev/null +++ b/src/Structure_processors/structure_analysis_traj.F90 @@ -0,0 +1,1400 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! do various structural analysis to a trajectory, save an intermediate file +! to be postprocessed (mean, variance, correlation, etc) +! #/vol density on a radial mesh +! #/vol density on a grid +! RDF, possibly as a function of distance of center from a fixed point +! to be added: ADF + +module structure_analysis_module +use libatoms_module +use structure_analysis_routines_module +implicit none +private + +type analysis + character(len=STRING_LENGTH) :: type ! type of analysis, used to fill in list of logicals + logical :: density_radial, density_grid, KE_density_radial, rdfd, integrated_rdfd, xrd, adfd, & !water + KEdf_radial, propdf_radial, geometry, & !general + density_axial_silica, num_hbond_silica, water_orientation_silica !silica-water interface + character(len=STRING_LENGTH) :: outfilename + character(len=STRING_LENGTH) :: mask_str + + integer :: n_configs = 0 + + real(dp) :: min_time, max_time + integer :: min_frame, max_frame + + ! radial density stuff + real(dp) :: density_radial_bin_width + integer :: density_radial_n_bins + integer :: density_radial_center_at + real(dp) :: density_radial_center(3) + real(dp) :: density_radial_gaussian_sigma + real(dp), allocatable :: density_radial_histograms(:,:) + real(dp), allocatable :: density_radial_pos(:) + + ! density grid stuff + real(dp) :: density_grid_min_p(3), density_grid_bin_width(3) + integer :: density_grid_n_bins(3) + logical :: density_grid_gaussian_smoothing + real(dp) :: density_grid_gaussian_sigma + real(dp), allocatable :: density_grid_histograms(:,:,:,:) + real(dp), allocatable :: density_grid_pos(:,:,:,:) + + ! radial KE density stuff + real(dp) :: KE_density_radial_bin_width + integer :: KE_density_radial_n_bins + integer :: KE_density_radial_center_at + real(dp) :: KE_density_radial_center(3) + real(dp) :: KE_density_radial_gaussian_sigma + real(dp), allocatable :: KE_density_radial_histograms(:,:) + real(dp), allocatable :: KE_density_radial_pos(:) + + ! rdfd stuff + real(dp) :: rdfd_zone_center(3) + integer :: rdfd_zone_atom_center + character(STRING_LENGTH) :: rdfd_center_mask_str, rdfd_neighbour_mask_str + real(dp) :: rdfd_zone_width, rdfd_bin_width + integer :: rdfd_n_zones, rdfd_n_bins + logical :: rdfd_gaussian_smoothing + real(dp) :: rdfd_gaussian_sigma + real(dp), allocatable :: rdfds(:,:,:) + real(dp), allocatable :: rdfd_zone_pos(:), rdfd_bin_pos(:) + + ! xrd stuff + real(dp) :: xrd_lambda + real(dp) :: xrd_2theta_range(2) + integer :: xrd_n_2theta + real(dp) :: xrd_k_spacing + real(dp), allocatable :: xrds(:,:) + real(dp), allocatable :: xrd_2theta_pos(:) + logical :: xrd_Lorentz_polarization + + ! adfd stuff + real(dp) :: adfd_zone_center(3) + character(STRING_LENGTH) :: adfd_center_mask_str, adfd_neighbour_1_mask_str, adfd_neighbour_2_mask_str + logical :: adfd_dist_bin_rc2 + real(dp) :: adfd_neighbour_1_max_dist + real(dp) :: adfd_zone_width, adfd_dist_bin_width + integer :: adfd_n_zones, adfd_n_dist_bins, adfd_n_angle_bins + real(dp), allocatable :: adfds(:,:,:,:) + real(dp), allocatable :: adfd_zone_pos(:), adfd_dist_bin_pos(:), adfd_angle_bin_pos(:) + + ! r-dep KE distribution + character(STRING_LENGTH) :: KEdf_radial_mask_str + real(dp) :: KEdf_radial_gaussian_sigma + real(dp) :: KEdf_radial_zone_center(3) + integer :: KEdf_radial_zone_center_at + real(dp) :: KEdf_radial_zone_width, KEdf_radial_bin_width + integer :: KEdf_radial_n_zones, KEdf_radial_n_bins + real(dp), allocatable :: KEdf_radial_bin_pos(:), KEdf_radial_zone_pos(:), KEdf_radial_histograms(:,:,:) + + ! r-dep |F| distribution + character(STRING_LENGTH) :: propdf_radial_mask_str + real(dp) :: propdf_radial_gaussian_sigma + real(dp) :: propdf_radial_zone_center(3) + integer :: propdf_radial_zone_center_at + real(dp) :: propdf_radial_zone_width, propdf_radial_bin_width + integer :: propdf_radial_n_zones, propdf_radial_n_bins + real(dp), allocatable :: propdf_radial_bin_pos(:), propdf_radial_zone_pos(:), propdf_radial_histograms(:,:,:) + character(len=STRING_LENGTH) :: propdf_radial_property + + !geometry + character(STRING_LENGTH) :: geometry_filename + type(Table) :: geometry_params + integer :: geometry_central_atom + real(dp), allocatable :: geometry_histograms(:,:) + real(dp), allocatable :: geometry_pos(:) + character(STRING_LENGTH), allocatable :: geometry_label(:) + + !uniaxial density - for silica-water interface + integer :: density_axial_axis !x:1,y:2,z:3 + real(dp) :: density_axial_bin_width + integer :: density_axial_n_bins + integer :: density_axial_silica_atoms + real(dp) :: density_axial_gaussian_sigma + logical :: density_axial_gaussian_smoothing + real(dp), allocatable :: density_axial_histograms(:,:) + real(dp), allocatable :: density_axial_pos(:) + + !silica_numhb - hydrogen bond distribution for silica-water interface + integer :: num_hbond_axis !x:1,y:2,z:3 + integer :: num_hbond_silica_atoms + integer :: num_hbond_n_type=4 + integer :: num_hbond_n_bins + logical :: num_hbond_gaussian_smoothing + real(dp) :: num_hbond_gaussian_sigma + real(dp), allocatable :: num_hbond_histograms(:,:,:) + real(dp), allocatable :: integrated_num_hbond_histograms(:,:) + integer, allocatable :: num_hbond_type_code(:) + real(dp), allocatable :: num_hbond_bin_pos(:) + character(STRING_LENGTH), allocatable :: num_hbond_type_label(:) + + !silica_water_orientation - water orientation distribution for silica-water interface + integer :: water_orientation_axis !x:1,y:2,z:3 + integer :: water_orientation_silica_atoms + integer :: water_orientation_n_angle_bins + integer :: water_orientation_n_pos_bins + logical :: water_orientation_gaussian_smoothing + real(dp) :: water_orientation_pos_gaussian_sigma + !real(dp) :: water_orientation_angle_gaussian_sigma + logical :: water_orientation_use_dipole + logical :: water_orientation_use_HOHangle_bisector + real(dp), allocatable :: water_orientation_histograms(:,:,:) + real(dp), allocatable :: integrated_water_orientation_histograms(:,:) + real(dp), allocatable :: water_orientation_pos_bin(:) + real(dp), allocatable :: water_orientation_angle_bin(:) + real(dp), allocatable :: water_orientation_angle_bin_w(:) + +end type analysis + +public :: analysis, analysis_read, check_analyses, do_analyses, print_analyses + +interface reallocate_data + module procedure reallocate_data_1d, reallocate_data_2d, reallocate_data_3d +end interface reallocate_data + +contains + +subroutine analysis_read(this, prev, args_str) + type(analysis), intent(inout) :: this + type(analysis), intent(in), optional :: prev + character(len=*), optional, intent(in) :: args_str + + type(Dictionary) :: params + integer :: dummy_i_1 + character(len=STRING_LENGTH) :: dummy_c_1, dummy_c_2 + logical :: dummy_l_1, dummy_l_2 + + call initialise(params) + ! dummy parameters required for some (undocumented) reason... + call param_register(params, 'infile', '', dummy_c_1, help_string="(Dummy parameter)") + call param_register(params, 'commandfile', '', dummy_c_2, help_string="(Dummy parameter)") + call param_register(params, 'decimation', '0', dummy_i_1, help_string="(Dummy parameter)") + call param_register(params, 'infile_is_list', 'F', dummy_l_1, help_string="(Dummy parameter)") + call param_register(params, 'quiet', 'F', dummy_l_2, help_string="(Dummy parameter)") + + if (.not. present(prev)) then + ! general + call param_register(params, 'outfile', 'stdout', this%outfilename, help_string="Output file name (default: stdout)") + call param_register(params, 'AtomMask', '', this%mask_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'min_time', '-1.0', this%min_time, help_string="Only include frames with Time >= min_time") + call param_register(params, 'max_time', '-1.0', this%max_time, help_string="Only include frames with Time <= max_time") + call param_register(params, 'min_frame', '-1', this%min_frame, help_string="Only include frames with number (not counting skipped) >= min_frame") + call param_register(params, 'max_frame', '-1', this%max_frame, help_string="Only include frames with number (not counting skipped) <= max_frame") + call param_register(params, 'type', '', this%type, help_string="[density_radial | density_grid | KE_density_radial | rdfd | xrd | adfd | KEdf_radial | propdf_radial | geometry | density_axial_silica | num_hbond_silica | water_orientation_silica ]") + else + ! general + call param_register(params, 'outfile', trim(prev%outfilename), this%outfilename, help_string="") + call param_register(params, 'AtomMask', trim(prev%mask_str), this%mask_str, help_string="") + call param_register(params, 'min_time', ''//prev%min_time, this%min_time, help_string="") + call param_register(params, 'max_time', ''//prev%max_time, this%max_time, help_string="") + call param_register(params, 'min_frame', ''//prev%min_frame, this%min_frame, help_string="") + call param_register(params, 'max_frame', ''//prev%max_frame, this%max_frame, help_string="") + call param_register(params, 'type', ''//trim(prev%type), this%type, help_string="[density_radial | density_grid | KE_density_radial | rdfd | xrd | adfd | KEdf_radial | propdf_radial | geometry | density_axial_silica | num_hbond_silica | water_orientation_silica ]") + endif + + if (.not. present(prev)) then + ! radial density + call param_register(params, 'density_radial_bin_width', '-1.0', this%density_radial_bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_radial_n_bins', '-1', this%density_radial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_radial_center', '0.0 0.0 0.0', this%density_radial_center, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_radial_center_at', '-1', this%density_radial_center_at, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_radial_sigma', '1.0', this%density_radial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + else + ! radial density + call param_register(params, 'density_radial_bin_width', ''//this%density_radial_bin_width, this%density_radial_bin_width, help_string="") + call param_register(params, 'density_radial_n_bins', ''//this%density_radial_n_bins, this%density_radial_n_bins, help_string="") + call param_register(params, 'density_radial_center', ''//prev%density_radial_center, this%density_radial_center, help_string="") + call param_register(params, 'density_radial_center_at', ''//prev%density_radial_center_at, this%density_radial_center_at, help_string="") + call param_register(params, 'density_radial_sigma', ''//prev%density_radial_gaussian_sigma, this%density_radial_gaussian_sigma, help_string="") + endif + + if (.not. present(prev)) then + ! grid density + call param_register(params, 'density_grid_min_p', '0.0 0.0 0.0', this%density_grid_min_p, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_grid_bin_width', '-1.0 -1.0 -1.0', this%density_grid_bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_grid_n_bins', '-1 -1 -1', this%density_grid_n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_grid_gaussian', 'F', this%density_grid_gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_grid_sigma', '1.0', this%density_grid_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + else + ! grid density + call param_register(params, 'density_grid_min_p', ''//prev%density_grid_min_p, this%density_grid_min_p, help_string="") + call param_register(params, 'density_grid_bin_width', ''//prev%density_grid_bin_width, this%density_grid_bin_width, help_string="") + call param_register(params, 'density_grid_n_bins', ''//prev%density_grid_n_bins, this%density_grid_n_bins, help_string="") + call param_register(params, 'density_grid_gaussian', ''//prev%density_grid_gaussian_smoothing, this%density_grid_gaussian_smoothing, help_string="") + call param_register(params, 'density_grid_sigma', ''//prev%density_grid_gaussian_sigma, this%density_grid_gaussian_sigma, help_string="") + endif + + if (.not. present(prev)) then + ! radial KE density + call param_register(params, 'KE_density_radial_bin_width', '-1.0', this%KE_density_radial_bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KE_density_radial_n_bins', '-1', this%KE_density_radial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KE_density_radial_center', '0.0 0.0 0.0', this%KE_density_radial_center, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KE_density_radial_center_at', '-1', this%KE_density_radial_center_at, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KE_density_radial_sigma', '1.0', this%KE_density_radial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + else + ! radial KE_density + !TODO why do these use 'this' for the default? + call param_register(params, 'KE_density_radial_bin_width', ''//this%KE_density_radial_bin_width, this%KE_density_radial_bin_width, help_string="") + call param_register(params, 'KE_density_radial_n_bins', ''//this%KE_density_radial_n_bins, this%KE_density_radial_n_bins, help_string="") + !TODO why is KE_density_radial_center missing? + call param_register(params, 'KE_density_radial_center_at', ''//prev%KE_density_radial_center_at, this%KE_density_radial_center_at, help_string="") + call param_register(params, 'KE_density_radial_sigma', ''//prev%KE_density_radial_gaussian_sigma, this%KE_density_radial_gaussian_sigma, help_string="") + endif + + if (.not. present(prev)) then + ! rdfd + call param_register(params, 'rdfd_zone_center', '0.0 0.0 0.0', this%rdfd_zone_center, help_string="Cartesian position to center zones for rdfd (ignored if rdfd_zone_atom_center is given)") + call param_register(params, 'rdfd_zone_atom_center', '0', this%rdfd_zone_atom_center, help_string="If > 0, index of atom to center zones for rdfd") + call param_register(params, 'rdfd_zone_width', '-1.0', this%rdfd_zone_width, help_string="Width of zones for rdfd") + call param_register(params, 'rdfd_n_zones', '1', this%rdfd_n_zones, help_string="Number of zones for rdfd") + call param_register(params, 'rdfd_bin_width', '-1', this%rdfd_bin_width, help_string="Width of bin (or distance between sample points) in each rdfd") + call param_register(params, 'rdfd_n_bins', '-1', this%rdfd_n_bins, help_string="Number of bins (or sample points) in each rdfd") + call param_register(params, 'rdfd_center_mask', '', this%rdfd_center_mask_str, help_string="Mask for atoms that are considered for rdfd centers") + call param_register(params, 'rdfd_neighbour_mask', '', this%rdfd_neighbour_mask_str, help_string="Mask for atoms that are considered for rdfd neighbours") + call param_register(params, 'rdfd_gaussian', 'F', this%rdfd_gaussian_smoothing, help_string="If true, use Gaussians to smear mass distributions being integrated for rdfd") + call param_register(params, 'rdfd_sigma', '0.1', this%rdfd_gaussian_sigma, help_string="Width of Gaussians used to smear mass distributions for rdfd") + else + ! rdfd + call param_register(params, 'rdfd_zone_center', ''//prev%rdfd_zone_center, this%rdfd_zone_center, help_string="") + call param_register(params, 'rdfd_zone_atom_center', ''//prev%rdfd_zone_atom_center, this%rdfd_zone_atom_center, help_string="") + call param_register(params, 'rdfd_zone_width', ''//prev%rdfd_zone_width, this%rdfd_zone_width, help_string="") + call param_register(params, 'rdfd_n_zones', ''//prev%rdfd_n_zones, this%rdfd_n_zones, help_string="") + call param_register(params, 'rdfd_bin_width', ''//prev%rdfd_bin_width, this%rdfd_bin_width, help_string="") + call param_register(params, 'rdfd_n_bins', ''//prev%rdfd_n_bins, this%rdfd_n_bins, help_string="") + call param_register(params, 'rdfd_center_mask', trim(prev%rdfd_center_mask_str), this%rdfd_center_mask_str, help_string="") + call param_register(params, 'rdfd_neighbour_mask', trim(prev%rdfd_neighbour_mask_str), this%rdfd_neighbour_mask_str, help_string="") + call param_register(params, 'rdfd_gaussian', ''//prev%rdfd_gaussian_smoothing, this%rdfd_gaussian_smoothing, help_string="") + call param_register(params, 'rdfd_sigma', ''//prev%rdfd_gaussian_sigma, this%rdfd_gaussian_sigma, help_string="") + endif + + if (.not. present(prev)) then + ! xrd + call param_register(params, 'xrd_lambda', '1.5418', this%xrd_lambda, help_string="Wavelength of radiation") + call param_register(params, 'xrd_2theta_range', '1.0 179.0', this%xrd_2theta_range, help_string="range of angles for scan") + call param_register(params, 'xrd_n_2theta', '179', this%xrd_n_2theta, help_string="number of angle values") + call param_register(params, 'xrd_k_spacing', '-1.0', this%xrd_k_spacing, help_string="approx. spacing for k mesh") + call param_register(params, 'xrd_Lorentz_polarization', 'F', this%xrd_Lorentz_polarization, help_string="apply Lorentz polarization factor") + else + ! xrd + call param_register(params, 'xrd_lambda', ''//prev%xrd_lambda, this%xrd_lambda, help_string="Wavelength of radiation") + call param_register(params, 'xrd_2theta_range', ''//prev%xrd_2theta_range, this%xrd_2theta_range, help_string="range of angles for scan") + call param_register(params, 'xrd_n_2theta', ''//prev%xrd_n_2theta, this%xrd_n_2theta, help_string="number of angle values") + call param_register(params, 'xrd_k_spacing', ''//prev%xrd_k_spacing, this%xrd_k_spacing, help_string="approx. spacing for k mesh") + call param_register(params, 'xrd_Lorentz_polarization', ''//prev%xrd_Lorentz_polarization, this%xrd_Lorentz_polarization, help_string="apply Lorentz polarization factor") + endif + + if (.not. present(prev)) then + ! adfd + call param_register(params, 'adfd_zone_center', '0.0 0.0 0.0', this%adfd_zone_center, help_string="Cartesian position to center zones for adfd (ignored if adfd_zone_atom_center is given)") + call param_register(params, 'adfd_zone_width', '-1.0', this%adfd_zone_width, help_string="Width of zones for adfd") + call param_register(params, 'adfd_n_zones', '1', this%adfd_n_zones, help_string="Number of zones for adfd") + call param_register(params, 'adfd_dist_bin_width', '-1', this%adfd_dist_bin_width, help_string="Width of distance bin in adfd") + call param_register(params, 'adfd_n_dist_bins', '-1', this%adfd_n_dist_bins, help_string="Number of distance bins in adfd") + call param_register(params, 'adfd_n_angle_bins', '-1', this%adfd_n_angle_bins, help_string="Number of angular bins in adfd") + call param_register(params, 'adfd_center_mask', '', this%adfd_center_mask_str, help_string="Mask for atoms that are considered for adfd centers") + call param_register(params, 'adfd_neighbour_1_mask', '', this%adfd_neighbour_1_mask_str, help_string="Mask for atoms that are considered for the first neighbour in adfd") + call param_register(params, 'adfd_neighbour_1_max_dist', '-1.0', this%adfd_neighbour_1_max_dist, help_string="Cutoff distance for atoms considered as the first neighbour") + call param_register(params, 'adfd_neighbour_2_mask', '', this%adfd_neighbour_2_mask_str, help_string="Mask for atoms that are considered for the second neighbour in adfd") + call param_register(params, 'adfd_dist_bin_rc2', '', this%adfd_dist_bin_rc2, help_string="If true, apply distance binning to r_center-neighbour2, otherwise to r_neighbour1-neighbour2") + else + ! adfd + call param_register(params, 'adfd_zone_center', ''//prev%adfd_zone_center, this%adfd_zone_center, help_string="") + call param_register(params, 'adfd_zone_width', ''//prev%adfd_zone_width, this%adfd_zone_width, help_string="") + call param_register(params, 'adfd_n_zones', ''//prev%adfd_n_zones, this%adfd_n_zones, help_string="") + call param_register(params, 'adfd_dist_bin_width', ''//prev%adfd_dist_bin_width, this%adfd_dist_bin_width, help_string="") + call param_register(params, 'adfd_n_dist_bins', ''//prev%adfd_n_dist_bins, this%adfd_n_dist_bins, help_string="") + call param_register(params, 'adfd_n_angle_bins', ''//prev%adfd_n_angle_bins, this%adfd_n_angle_bins, help_string="") + call param_register(params, 'adfd_center_mask', trim(prev%adfd_center_mask_str), this%adfd_center_mask_str, help_string="") + call param_register(params, 'adfd_neighbour_1_mask', trim(prev%adfd_neighbour_1_mask_str), this%adfd_neighbour_1_mask_str, help_string="") + call param_register(params, 'adfd_neighbour_1_max_dist', ''//prev%adfd_neighbour_1_max_dist, this%adfd_neighbour_1_max_dist, help_string="") + call param_register(params, 'adfd_neighbour_2_mask', trim(prev%adfd_neighbour_2_mask_str), this%adfd_neighbour_2_mask_str, help_string="") + call param_register(params, 'adfd_dist_bin_rc2', ''//prev%adfd_dist_bin_rc2, this%adfd_dist_bin_rc2, help_string="If true, apply distance binning to r_center-neighbor2, otherwise to r_neighbor1-neighbor2") + endif + + if (.not. present(prev)) then + ! r-dep KE distribution + call param_register(params, 'KEdf_radial_zone_center', '0.0 0.0 0.0', this%KEdf_radial_zone_center, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KEdf_radial_zone_center_at', '-1', this%KEdf_radial_zone_center_at, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KEdf_radial_zone_width', '-1.0', this%KEdf_radial_zone_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KEdf_radial_bin_width', '0.002', this%KEdf_radial_bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KEdf_radial_n_bins', '500', this%KEdf_radial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KEdf_radial_n_zones', '1', this%KEdf_radial_n_zones, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KEdf_radial_gaussian_sigma', '0.005', this%KEdf_radial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'KEdf_radial_mask', '', this%KEdf_radial_mask_str, help_string="No help yet. This source file was $LastChangedBy$") + else + ! r-dep KE distribution + call param_register(params, 'KEdf_radial_zone_center', ''//prev%KEdf_radial_zone_center, this%KEdf_radial_zone_center, help_string="") + call param_register(params, 'KEdf_radial_zone_center_at', ''//prev%KEdf_radial_zone_center_at, this%KEdf_radial_zone_center_at, help_string="") + call param_register(params, 'KEdf_radial_zone_width', ''//prev%KEdf_radial_zone_width, this%KEdf_radial_zone_width, help_string="") + call param_register(params, 'KEdf_radial_bin_width', ''//prev%KEdf_radial_bin_width, this%KEdf_radial_bin_width, help_string="") + call param_register(params, 'KEdf_radial_n_bins', ''//prev%KEdf_radial_n_bins, this%KEdf_radial_n_bins, help_string="") + call param_register(params, 'KEdf_radial_n_zones', ''//prev%KEdf_radial_n_zones, this%KEdf_radial_n_zones, help_string="") + call param_register(params, 'KEdf_radial_gaussian_sigma', ''//prev%KEdf_radial_gaussian_sigma, this%KEdf_radial_gaussian_sigma, help_string="") + call param_register(params, 'KEdf_radial_mask', ''//trim(prev%KEdf_radial_mask_str), this%KEdf_radial_mask_str, help_string="") + endif + + if (.not. present(prev)) then + ! r-dep |F| distribution + call param_register(params, 'propdf_radial_zone_center', '0.0 0.0 0.0', this%propdf_radial_zone_center, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'propdf_radial_zone_center_at', '-1', this%propdf_radial_zone_center_at, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'propdf_radial_zone_width', '-1.0', this%propdf_radial_zone_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'propdf_radial_n_zones', '1', this%propdf_radial_n_zones, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'propdf_radial_bin_width', '0.0', this%propdf_radial_bin_width, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'propdf_radial_n_bins', '0', this%propdf_radial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'propdf_radial_gaussian_sigma', '0.0', this%propdf_radial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'propdf_radial_mask', '', this%propdf_radial_mask_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'propdf_radial_property', '', this%propdf_radial_property, help_string="No help yet. This source file was $LastChangedBy$") + else + ! r-dep |F| distribution + call param_register(params, 'propdf_radial_zone_center', ''//prev%propdf_radial_zone_center, this%propdf_radial_zone_center, help_string="") + call param_register(params, 'propdf_radial_zone_center_at', ''//prev%propdf_radial_zone_center_at, this%propdf_radial_zone_center_at, help_string="") + call param_register(params, 'propdf_radial_zone_width', ''//prev%propdf_radial_zone_width, this%propdf_radial_zone_width, help_string="") + call param_register(params, 'propdf_radial_n_zones', ''//prev%propdf_radial_n_zones, this%propdf_radial_n_zones, help_string="") + call param_register(params, 'propdf_radial_bin_width', ''//prev%propdf_radial_bin_width, this%propdf_radial_bin_width, help_string="") + call param_register(params, 'propdf_radial_n_bins', ''//prev%propdf_radial_n_bins, this%propdf_radial_n_bins, help_string="") + call param_register(params, 'propdf_radial_gaussian_sigma', ''//prev%propdf_radial_gaussian_sigma, this%propdf_radial_gaussian_sigma, help_string="") + call param_register(params, 'propdf_radial_mask', ''//trim(prev%propdf_radial_mask_str), this%propdf_radial_mask_str, help_string="") + call param_register(params, 'propdf_radial_property', ''//trim(prev%propdf_radial_property), this%propdf_radial_property, help_string="") + endif + + if (.not. present(prev)) then + ! geometry + call param_register(params, 'geometry_filename', '', this%geometry_filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'geometry_central_atom', '-1', this%geometry_central_atom, help_string="No help yet. This source file was $LastChangedBy$") + else + ! geometry + call param_register(params, 'geometry_filename', ''//trim(prev%geometry_filename), this%geometry_filename, help_string="") + call param_register(params, 'geometry_central_atom', ''//prev%geometry_central_atom, this%geometry_central_atom, help_string="") + endif + + if (.not. present(prev)) then + ! uniaxial density silica + call param_register(params, 'density_axial_n_bins', '-1', this%density_axial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_axial_axis', '-1', this%density_axial_axis, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_axial_silica_atoms', '-1', this%density_axial_silica_atoms, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_axial_gaussian', 'F', this%density_axial_gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'density_axial_sigma', '1.0', this%density_axial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + else + ! uniaxial density silica + call param_register(params, 'density_axial_n_bins', ''//prev%density_axial_n_bins, this%density_axial_n_bins, help_string="") + call param_register(params, 'density_axial_axis', ''//prev%density_axial_axis, this%density_axial_axis, help_string="") + call param_register(params, 'density_axial_silica_atoms', ''//prev%density_axial_silica_atoms, this%density_axial_silica_atoms, help_string="") + call param_register(params, 'density_axial_gaussian', ''//prev%density_axial_gaussian_smoothing, this%density_axial_gaussian_smoothing, help_string="") + call param_register(params, 'density_axial_sigma', ''//prev%density_axial_gaussian_sigma, this%density_axial_gaussian_sigma, help_string="") + endif + + if (.not. present(prev)) then + ! num_hbond_silica + call param_register(params, 'num_hbond_n_bins', '-1', this%num_hbond_n_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'num_hbond_axis', '0', this%num_hbond_axis, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'num_hbond_silica_atoms', '0', this%num_hbond_silica_atoms, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'num_hbond_gaussian', 'F', this%num_hbond_gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'num_hbond_sigma', '1.0', this%num_hbond_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + else + ! num_hbond_silica + call param_register(params, 'num_hbond_n_bins', ''//prev%num_hbond_n_bins, this%num_hbond_n_bins, help_string="") + call param_register(params, 'num_hbond_axis', ''//prev%num_hbond_axis, this%num_hbond_axis, help_string="") + call param_register(params, 'num_hbond_silica_atoms', ''//prev%num_hbond_silica_atoms, this%num_hbond_silica_atoms, help_string="") + call param_register(params, 'num_hbond_gaussian', ''//prev%num_hbond_gaussian_smoothing, this%num_hbond_gaussian_smoothing, help_string="") + call param_register(params, 'num_hbond_sigma', ''//prev%num_hbond_gaussian_sigma, this%num_hbond_gaussian_sigma, help_string="") + endif + + if (.not. present(prev)) then + ! water_orientation_silica + call param_register(params, 'water_orientation_n_pos_bins', '-1', this%water_orientation_n_pos_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'water_orientation_n_angle_bins', '-1', this%water_orientation_n_angle_bins, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'water_orientation_axis', '0', this%water_orientation_axis, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'water_orientation_silica_atoms', '0', this%water_orientation_silica_atoms, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'water_orientation_gaussian', 'F', this%water_orientation_gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'water_orientation_pos_sigma', '1.0', this%water_orientation_pos_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + !call param_register(params, 'water_orientation_angle_sigma', '1.0', this%water_orientation_angle_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'water_orientation_use_dipole', 'F', this%water_orientation_use_dipole, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'water_orientation_use_HOHangle_bisector', 'F', this%water_orientation_use_HOHangle_bisector, help_string="No help yet. This source file was $LastChangedBy$") + else + ! water_orientation_silica + call param_register(params, 'water_orientation_n_pos_bins', ''//prev%water_orientation_n_pos_bins, this%water_orientation_n_pos_bins, help_string="") + call param_register(params, 'water_orientation_n_angle_bins', ''//prev%water_orientation_n_angle_bins, this%water_orientation_n_angle_bins, help_string="") + call param_register(params, 'water_orientation_axis', ''//prev%water_orientation_axis, this%water_orientation_axis, help_string="") + call param_register(params, 'water_orientation_silica_atoms', ''//prev%water_orientation_silica_atoms, this%water_orientation_silica_atoms, help_string="") + call param_register(params, 'water_orientation_gaussian', ''//prev%water_orientation_gaussian_smoothing, this%water_orientation_gaussian_smoothing, help_string="") + call param_register(params, 'water_orientation_pos_sigma', ''//prev%water_orientation_pos_gaussian_sigma, this%water_orientation_pos_gaussian_sigma, help_string="") + !call param_register(params, 'water_orientation_angle_sigma', ''//prev%water_orientation_angle_gaussian_sigma, this%water_orientation_angle_gaussian_sigma, help_string="") + call param_register(params, 'water_orientation_use_dipole', ''//prev%water_orientation_use_dipole, this%water_orientation_use_dipole, help_string="") + call param_register(params, 'water_orientation_use_HOHangle_bisector', ''//prev%water_orientation_use_HOHangle_bisector, this%water_orientation_use_HOHangle_bisector, help_string="") + endif + + if (present(args_str)) then + if (.not. param_read_line(params, trim(args_str), ignore_unknown=.false.)) & + call system_abort("analysis_read failed to parse string '"//trim(args_str)//"'") + else + if (.not. param_read_args(params)) & + call system_abort("analysis_read failed to parse command line arguments") + endif + + this%density_radial = .false. + this%density_grid = .false. + this%KE_density_radial = .false. + this%rdfd = .false. + this%xrd = .false. + this%adfd = .false. + this%KEdf_radial = .false. + this%propdf_radial = .false. + this%geometry = .false. + this%density_axial_silica = .false. + this%num_hbond_silica = .false. + this%water_orientation_silica = .false. + select case(trim(this%type)) + case("density_radial") + this%density_radial = .true. + case("density_grid") + this%density_grid = .true. + case("KE_density_radial") + this%KE_density_radial = .true. + case("rdfd") + this%rdfd = .true. + case("xrd") + this%xrd = .true. + case("adfd") + this%adfd = .true. + case("KEdf_radial") + this%KEdf_radial = .true. + case("propdf_radial") + this%propdf_radial = .true. + case("geometry") + this%geometry = .true. + case("density_axial_silica") + this%density_axial_silica = .true. + case("num_hbond_silica") + this%num_hbond_silica = .true. + case("water_orientation_silica") + this%water_orientation_silica = .true. + case default + call system_abort("Unknown analysis type '"//trim(this%type)//"'") + end select + + if (count ( (/ this%density_radial, this%density_grid, this%KE_density_radial, this%rdfd, this%xrd, this%adfd, & + this%KEdf_radial, this%propdf_radial, this%geometry, this%density_axial_silica, this%num_hbond_silica, & + this%water_orientation_silica /) ) /= 1) & + call system_abort("Specified "//(/ this%density_radial, this%density_grid, this%KE_density_radial, & + this%rdfd, this%xrd, this%adfd, this%KEdf_radial, this%propdf_radial, this%geometry, this%density_axial_silica, this%num_hbond_silica, & + this%water_orientation_silica /)// & + " types of analysis. Possibilities: density_radial, density_grid, KE_density_radial, rdfd, xrd, adfd, KEdf_radial, propdf_radial, geometry, " // & + " density_axial_silica, num_hbond_silica, water_orientation_silica.") + +end subroutine analysis_read + +subroutine check_analyses(a) + type(analysis), intent(inout) :: a(:) + + integer :: i_a + + do i_a=1, size(a) + if (a(i_a)%density_radial) then !density_radial + if (a(i_a)%density_radial_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has radial_bin_width="//a(i_a)%density_radial_bin_width//" <= 0.0") + if (a(i_a)%density_radial_n_bins <= 0) call system_abort("analysis " // i_a // " has radial_n_bins="//a(i_a)%density_radial_n_bins//" <= 0") + else if (a(i_a)%density_grid) then !density_grid + if (any(a(i_a)%density_grid_bin_width <= 0.0_dp)) call system_abort("analysis " // i_a // " has grid_bin_width="//a(i_a)%density_grid_bin_width//" <= 0.0") + if (any(a(i_a)%density_grid_n_bins <= 0)) call system_abort("analysis " // i_a // " has grid_n_bins="//a(i_a)%density_grid_n_bins//" <= 0") + else if (a(i_a)%KE_density_radial) then !KE_density_radial + if (a(i_a)%KE_density_radial_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has radial_bin_width="//a(i_a)%KE_density_radial_bin_width//" <= 0.0") + if (a(i_a)%KE_density_radial_n_bins <= 0) call system_abort("analysis " // i_a // " has radial_n_bins="//a(i_a)%KE_density_radial_n_bins//" <= 0") + else if (a(i_a)%rdfd) then !rdfd + if (a(i_a)%rdfd_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has rdfd_bin_width="//a(i_a)%rdfd_bin_width//" <= 0.0") + if (a(i_a)%rdfd_n_bins <= 0) call system_abort("analysis " // i_a // " has rdfd_n_bins="//a(i_a)%rdfd_n_bins//" <= 0") + if (a(i_a)%rdfd_n_zones <= 0) call system_abort("analysis " // i_a // " has rdfd_n_zones="//a(i_a)%rdfd_n_zones//" <= 0") + else if (a(i_a)%xrd) then !xrd + if (a(i_a)%xrd_2theta_range(2) < a(i_a)%xrd_2theta_range(1)) call system_abort("analysis " // i_a // " has xrd_2theta_range="//a(i_a)%xrd_2theta_range//" end >= beginning") + if (a(i_a)%xrd_lambda <= 0.0) call system_abort("analysis " // i_a // " has xrd_lambda="//a(i_a)%xrd_lambda//" <= 0") + if (a(i_a)%xrd_n_2theta <= 0) call system_abort("analysis " // i_a // " has xrd_n_2theta="//a(i_a)%xrd_n_2theta//" <= 0") + else if (a(i_a)%adfd) then !adfd + if (a(i_a)%adfd_dist_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has adfd_dist_bin_width="//a(i_a)%adfd_dist_bin_width//" <= 0.0") + if (a(i_a)%adfd_n_dist_bins <= 0) call system_abort("analysis " // i_a // " has adfd_n_dist_bins="//a(i_a)%adfd_n_dist_bins//" <= 0") + if (a(i_a)%adfd_n_angle_bins <= 0) call system_abort("analysis " // i_a // " has adfd_n_angle_bins="//a(i_a)%adfd_n_angle_bins//" <= 0") + if (a(i_a)%adfd_n_zones <= 0) call system_abort("analysis " // i_a // " has adfd_n_zones="//a(i_a)%adfd_n_zones//" <= 0") + else if (a(i_a)%KEdf_radial) then !KEdf_radial + if (a(i_a)%KEdf_radial_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has KEdf_radial_bin_width="//a(i_a)%KEdf_radial_bin_width//" <= 0.0") + if (a(i_a)%KEdf_radial_n_bins <= 0) call system_abort("analysis " // i_a // " has KEdf_radial_n_bins="//a(i_a)%KEdf_radial_n_bins//" <= 0") + if (a(i_a)%KEdf_radial_n_zones <= 0) call system_abort("analysis " // i_a // " has KEdf_radial_n_zones="//a(i_a)%KEdf_radial_n_zones//" <= 0") + else if (a(i_a)%propdf_radial) then !propdf_radial + if (a(i_a)%propdf_radial_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has propdf_radial_bin_width="//a(i_a)%propdf_radial_bin_width//" <= 0.0") + if (a(i_a)%propdf_radial_n_bins <= 0) call system_abort("analysis " // i_a // " has propdf_radial_n_bins="//a(i_a)%propdf_radial_n_bins//" <= 0") + if (a(i_a)%propdf_radial_gaussian_sigma <= 0) call system_abort("analysis " // i_a // " has propdf_radial_gaussian_sigma="//a(i_a)%propdf_radial_gaussian_sigma//" <= 0") + if (a(i_a)%propdf_radial_n_zones <= 0) call system_abort("analysis " // i_a // " has propdf_radial_n_zones="//a(i_a)%propdf_radial_n_zones//" <= 0") + else if (a(i_a)%geometry) then !geometry + if (trim(a(i_a)%geometry_filename)=="") call system_abort("analysis "//i_a//" has empty geometry_filename") + !read geometry parameters to calculate from the file into a table + call read_geometry_params(a(i_a),trim(a(i_a)%geometry_filename)) + if (a(i_a)%geometry_params%N==0) call system_abort("analysis "//i_a//" has no geometry parameters to calculate") + else if (a(i_a)%density_axial_silica) then !density_axial_silica + if (a(i_a)%density_axial_n_bins <= 0) call system_abort("analysis " // i_a // " has density_axial_n_bins="//a(i_a)%density_axial_n_bins//" <= 0") + if (.not. any(a(i_a)%density_axial_axis == (/1,2,3/))) call system_abort("analysis " // i_a // " has density_axial_axis="//a(i_a)%density_axial_axis//" /= 1, 2 or 3") + else if (a(i_a)%num_hbond_silica) then !num_hbond_silica + if (a(i_a)%num_hbond_n_bins <= 0) call system_abort("analysis " // i_a // " has num_hbond_n_bins="//a(i_a)%num_hbond_n_bins//" <= 0") + if (.not. any(a(i_a)%num_hbond_axis == (/1,2,3/))) call system_abort("analysis " // i_a // " has num_hbond_axis="//a(i_a)%num_hbond_axis//" /= 1, 2 or 3") + else if (a(i_a)%water_orientation_silica) then !water_orientation_silica + if (a(i_a)%water_orientation_n_pos_bins <= 0) call system_abort("analysis " // i_a // " has water_orientation_n_pos_bins="//a(i_a)%water_orientation_n_pos_bins//" <= 0") + if (a(i_a)%water_orientation_n_angle_bins <= 0) call system_abort("analysis " // i_a // " has water_orientation_n_angle_bins="//a(i_a)%water_orientation_n_angle_bins//" <= 0") + if (.not. any(a(i_a)%water_orientation_axis == (/1,2,3/))) call system_abort("analysis " // i_a // " has water_orientation_axis="//a(i_a)%water_orientation_axis//" /= 1, 2 or 3") + if (.not. count((/a(i_a)%water_orientation_use_HOHangle_bisector,a(i_a)%water_orientation_use_dipole/)) == 1) call system_abort("Exactly one of water_orientation_use_HOHangle_bisector and water_orientation_use_dipole must be one.") + else + call system_abort("check_analyses: no type of analysis set for " // i_a) + endif + end do +end subroutine check_analyses + +subroutine do_analyses(a, time, frame, at) + type(analysis), intent(inout) :: a(:) + real(dp), intent(in) :: time + integer, intent(in) :: frame + type(Atoms), intent(inout) :: at + real(dp) :: use_radial_center(3) + + integer :: i_a + + call map_into_cell(at) +! at%t ravel = 0 + + do i_a=1, size(a) + if (do_this_analysis(a(i_a), time, frame)) then + + a(i_a)%n_configs = a(i_a)%n_configs + 1 + + if (a(i_a)%density_radial) then !density_radial + call reallocate_data(a(i_a)%density_radial_histograms, a(i_a)%n_configs, a(i_a)%density_radial_n_bins) + if (a(i_a)%density_radial_center_at > 0) then + use_radial_center = at%pos(:,a(i_a)%density_radial_center_at) + else + use_radial_center = a(i_a)%density_radial_center + endif + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%density_radial_pos(a(i_a)%density_radial_n_bins)) + call density_sample_radial_mesh_Gaussians(a(i_a)%density_radial_histograms(:,a(i_a)%n_configs), at, center_pos=use_radial_center, & + rad_bin_width=a(i_a)%density_radial_bin_width, n_rad_bins=a(i_a)%density_radial_n_bins, gaussian_sigma=a(i_a)%density_radial_gaussian_sigma, & + mask_str=a(i_a)%mask_str, radial_pos=a(i_a)%density_radial_pos) + else + call density_sample_radial_mesh_Gaussians(a(i_a)%density_radial_histograms(:,a(i_a)%n_configs), at, center_pos=use_radial_center, & + rad_bin_width=a(i_a)%density_radial_bin_width, n_rad_bins=a(i_a)%density_radial_n_bins, gaussian_sigma= a(i_a)%density_radial_gaussian_sigma, & + mask_str=a(i_a)%mask_str) + endif + else if (a(i_a)%density_grid) then !density_grid + call reallocate_data(a(i_a)%density_grid_histograms, a(i_a)%n_configs, a(i_a)%density_grid_n_bins) + if (a(i_a)%density_grid_gaussian_smoothing) then + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%density_grid_pos(3,a(i_a)%density_grid_n_bins(1),a(i_a)%density_grid_n_bins(2),a(i_a)%density_grid_n_bins(3))) + call density_sample_rectilinear_mesh_Gaussians(a(i_a)%density_grid_histograms(:,:,:,a(i_a)%n_configs), at, a(i_a)%density_grid_min_p, & + a(i_a)%density_grid_bin_width, a(i_a)%density_grid_n_bins, a(i_a)%density_grid_gaussian_sigma, a(i_a)%mask_str, a(i_a)%density_grid_pos) + else + call density_sample_rectilinear_mesh_Gaussians(a(i_a)%density_grid_histograms(:,:,:,a(i_a)%n_configs), at, a(i_a)%density_grid_min_p, & + a(i_a)%density_grid_bin_width, a(i_a)%density_grid_n_bins, a(i_a)%density_grid_gaussian_sigma, a(i_a)%mask_str) + endif + else + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%density_grid_pos(3,a(i_a)%density_grid_n_bins(1),a(i_a)%density_grid_n_bins(2),a(i_a)%density_grid_n_bins(3))) + call density_bin_rectilinear_mesh(a(i_a)%density_grid_histograms(:,:,:,a(i_a)%n_configs), at, a(i_a)%density_grid_min_p, a(i_a)%density_grid_bin_width, & + a(i_a)%density_grid_n_bins, a(i_a)%mask_str, a(i_a)%density_grid_pos) + else + call density_bin_rectilinear_mesh(a(i_a)%density_grid_histograms(:,:,:,a(i_a)%n_configs), at, a(i_a)%density_grid_min_p, a(i_a)%density_grid_bin_width, & + a(i_a)%density_grid_n_bins, a(i_a)%mask_str) + endif + endif + else if (a(i_a)%KE_density_radial) then ! KE_density_radial + call reallocate_data(a(i_a)%KE_density_radial_histograms, a(i_a)%n_configs, a(i_a)%KE_density_radial_n_bins) + if (a(i_a)%KE_density_radial_center_at > 0) then + use_radial_center = at%pos(:,a(i_a)%KE_density_radial_center_at) + else + use_radial_center = a(i_a)%KE_density_radial_center + endif + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%KE_density_radial_pos(a(i_a)%KE_density_radial_n_bins)) + call density_sample_radial_mesh_Gaussians(a(i_a)%KE_density_radial_histograms(:,a(i_a)%n_configs), at, center_pos=use_radial_center, & + rad_bin_width=a(i_a)%KE_density_radial_bin_width, n_rad_bins=a(i_a)%KE_density_radial_n_bins, gaussian_sigma=a(i_a)%KE_density_radial_gaussian_sigma, & + mask_str=a(i_a)%mask_str, radial_pos=a(i_a)%KE_density_radial_pos, quantity="KE") + else + call density_sample_radial_mesh_Gaussians(a(i_a)%KE_density_radial_histograms(:,a(i_a)%n_configs), at, center_pos=use_radial_center, & + rad_bin_width=a(i_a)%KE_density_radial_bin_width, n_rad_bins=a(i_a)%KE_density_radial_n_bins, gaussian_sigma= a(i_a)%density_radial_gaussian_sigma, & + mask_str=a(i_a)%mask_str, quantity="KE") + endif + else if (a(i_a)%rdfd) then !rdfd + call reallocate_data(a(i_a)%rdfds, a(i_a)%n_configs, (/ a(i_a)%rdfd_n_bins, a(i_a)%rdfd_n_zones /) ) + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%rdfd_bin_pos(a(i_a)%rdfd_n_bins)) + allocate(a(i_a)%rdfd_zone_pos(a(i_a)%rdfd_n_zones)) + call rdfd_calc(a(i_a)%rdfds(:,:,a(i_a)%n_configs), at, a(i_a)%rdfd_zone_center, a(i_a)%rdfd_zone_atom_center, a(i_a)%rdfd_bin_width, a(i_a)%rdfd_n_bins, & + a(i_a)%rdfd_zone_width, a(i_a)%rdfd_n_zones, a(i_a)%rdfd_gaussian_smoothing, a(i_a)%rdfd_gaussian_sigma, & + a(i_a)%rdfd_center_mask_str, a(i_a)%rdfd_neighbour_mask_str, & + a(i_a)%rdfd_bin_pos, a(i_a)%rdfd_zone_pos) + else + call rdfd_calc(a(i_a)%rdfds(:,:,a(i_a)%n_configs), at, a(i_a)%rdfd_zone_center, a(i_a)%rdfd_zone_atom_center, a(i_a)%rdfd_bin_width, a(i_a)%rdfd_n_bins, & + a(i_a)%rdfd_zone_width, a(i_a)%rdfd_n_zones, a(i_a)%rdfd_gaussian_smoothing, a(i_a)%rdfd_gaussian_sigma, & + a(i_a)%rdfd_center_mask_str, a(i_a)%rdfd_neighbour_mask_str) + endif + else if (a(i_a)%xrd) then !xrd + call reallocate_data(a(i_a)%xrds, a(i_a)%n_configs, a(i_a)%xrd_n_2theta ) + a(i_a)%xrd_2theta_range = a(i_a)%xrd_2theta_range * PI/180.0 + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%xrd_2theta_pos(a(i_a)%xrd_n_2theta)) + call xrd_calc(a(i_a)%xrds(:,a(i_a)%n_configs), at, a(i_a)%xrd_lambda, a(i_a)%xrd_2theta_range, a(i_a)%xrd_n_2theta, & + a(i_a)%xrd_k_spacing, a(i_a)%xrd_Lorentz_polarization, a(i_a)%xrd_2theta_pos) + a(i_a)%xrd_2theta_pos = a(i_a)%xrd_2theta_pos * 180.0/PI + else + call xrd_calc(a(i_a)%xrds(:,a(i_a)%n_configs), at, a(i_a)%xrd_lambda, a(i_a)%xrd_2theta_range, a(i_a)%xrd_n_2theta, & + a(i_a)%xrd_k_spacing, a(i_a)%xrd_Lorentz_polarization) + endif + a(i_a)%xrd_2theta_range = a(i_a)%xrd_2theta_range * 180.0/PI + else if (a(i_a)%adfd) then !adfd + call reallocate_data(a(i_a)%adfds, a(i_a)%n_configs, (/ a(i_a)%adfd_n_angle_bins, a(i_a)%adfd_n_dist_bins, a(i_a)%adfd_n_zones /) ) + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%adfd_dist_bin_pos(a(i_a)%adfd_n_dist_bins)) + allocate(a(i_a)%adfd_angle_bin_pos(a(i_a)%adfd_n_angle_bins)) + allocate(a(i_a)%adfd_zone_pos(a(i_a)%adfd_n_zones)) + call adfd_calc(a(i_a)%adfds(:,:,:,a(i_a)%n_configs), at, a(i_a)%adfd_zone_center, & + a(i_a)%adfd_n_angle_bins, a(i_a)%adfd_dist_bin_width, a(i_a)%adfd_n_dist_bins, & + a(i_a)%adfd_zone_width, a(i_a)%adfd_n_zones, & + a(i_a)%adfd_center_mask_str, a(i_a)%adfd_neighbour_1_mask_str, a(i_a)%adfd_neighbour_1_max_dist, a(i_a)%adfd_neighbour_2_mask_str, a(i_a)%adfd_dist_bin_rc2, & + a(i_a)%adfd_angle_bin_pos, a(i_a)%adfd_dist_bin_pos, a(i_a)%adfd_zone_pos) + else + call adfd_calc(a(i_a)%adfds(:,:,:,a(i_a)%n_configs), at, a(i_a)%adfd_zone_center, & + a(i_a)%adfd_n_angle_bins, a(i_a)%adfd_dist_bin_width, a(i_a)%adfd_n_dist_bins, & + a(i_a)%adfd_zone_width, a(i_a)%adfd_n_zones, & + a(i_a)%adfd_center_mask_str, a(i_a)%adfd_neighbour_1_mask_str, a(i_a)%adfd_neighbour_1_max_dist, a(i_a)%adfd_neighbour_2_mask_str, a(i_a)%adfd_dist_bin_rc2) + endif + else if (a(i_a)%KEdf_radial) then + call reallocate_data(a(i_a)%KEdf_radial_histograms, a(i_a)%n_configs, (/ a(i_a)%KEdf_radial_n_bins, a(i_a)%KEdf_radial_n_zones /) ) + if (a(i_a)%KEdf_radial_zone_center_at > 0) then + use_radial_center = at%pos(:,a(i_a)%KEdf_radial_zone_center_at) + else + use_radial_center = a(i_a)%KEdf_radial_zone_center + endif + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%KEdf_radial_bin_pos(a(i_a)%KEdf_radial_n_bins)) + allocate(a(i_a)%KEdf_radial_zone_pos(a(i_a)%KEdf_radial_n_zones)) + call propdf_radial_calc(a(i_a)%KEdf_radial_histograms(:,:,a(i_a)%n_configs), at, a(i_a)%KEdf_radial_bin_width, a(i_a)%KEdf_radial_n_bins, & + use_radial_center, a(i_a)%KEdf_radial_zone_width, A(i_a)%KEdf_radial_n_zones, & + a(i_a)%KEdf_radial_gaussian_sigma, a(i_a)%KEdf_radial_mask_str, 'KE', a(i_a)%KEdf_radial_bin_pos, a(i_a)%KEdf_radial_zone_pos) + else + call propdf_radial_calc(a(i_a)%KEdf_radial_histograms(:,:,a(i_a)%n_configs), at, a(i_a)%KEdf_radial_bin_width, a(i_a)%KEdf_radial_n_bins, & + use_radial_center, a(i_a)%KEdf_radial_zone_width, A(i_a)%KEdf_radial_n_zones, & + a(i_a)%KEdf_radial_gaussian_sigma, a(i_a)%KEdf_radial_mask_str, 'KE') + endif + else if (a(i_a)%propdf_radial) then + call reallocate_data(a(i_a)%propdf_radial_histograms, a(i_a)%n_configs, (/ a(i_a)%propdf_radial_n_bins, a(i_a)%propdf_radial_n_zones /) ) + if (a(i_a)%propdf_radial_zone_center_at > 0) then + use_radial_center = at%pos(:,a(i_a)%propdf_radial_zone_center_at) + else + use_radial_center = a(i_a)%propdf_radial_zone_center + endif + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%propdf_radial_bin_pos(a(i_a)%propdf_radial_n_bins)) + allocate(a(i_a)%propdf_radial_zone_pos(a(i_a)%propdf_radial_n_zones)) + call propdf_radial_calc(a(i_a)%propdf_radial_histograms(:,:,a(i_a)%n_configs), at, a(i_a)%propdf_radial_bin_width, a(i_a)%propdf_radial_n_bins, & + use_radial_center, a(i_a)%propdf_radial_zone_width, A(i_a)%propdf_radial_n_zones, & + a(i_a)%propdf_radial_gaussian_sigma, a(i_a)%propdf_radial_mask_str, A(i_a)%propdf_radial_property, & + a(i_a)%propdf_radial_bin_pos, a(i_a)%propdf_radial_zone_pos) + else + call propdf_radial_calc(a(i_a)%propdf_radial_histograms(:,:,a(i_a)%n_configs), at, a(i_a)%propdf_radial_bin_width, a(i_a)%propdf_radial_n_bins, & + use_radial_center, a(i_a)%propdf_radial_zone_width, A(i_a)%propdf_radial_n_zones, & + a(i_a)%propdf_radial_gaussian_sigma, a(i_a)%propdf_radial_mask_str, a(i_a)%propdf_radial_property) + endif + else if (a(i_a)%geometry) then !geometry + call reallocate_data(a(i_a)%geometry_histograms, a(i_a)%n_configs, a(i_a)%geometry_params%N) + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%geometry_pos(a(i_a)%geometry_params%N)) + allocate(a(i_a)%geometry_label(a(i_a)%geometry_params%N)) + call geometry_calc(a(i_a)%geometry_histograms(:,a(i_a)%n_configs), at, a(i_a)%geometry_params, a(i_a)%geometry_central_atom, & + a(i_a)%geometry_pos(1:a(i_a)%geometry_params%N), a(i_a)%geometry_label(1:a(i_a)%geometry_params%N)) + else + call geometry_calc(a(i_a)%geometry_histograms(:,a(i_a)%n_configs), at, a(i_a)%geometry_params, a(i_a)%geometry_central_atom) + endif + else if (a(i_a)%density_axial_silica) then !density_axial_silica + call reallocate_data(a(i_a)%density_axial_histograms, a(i_a)%n_configs, a(i_a)%density_axial_n_bins) + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%density_axial_pos(a(i_a)%density_axial_n_bins)) + call density_axial_calc(a(i_a)%density_axial_histograms(:,a(i_a)%n_configs), at, & + axis=a(i_a)%density_axial_axis, silica_center_i=a(i_a)%density_axial_silica_atoms, & + n_bins=a(i_a)%density_axial_n_bins, & + gaussian_smoothing=a(i_a)%density_axial_gaussian_smoothing, & + gaussian_sigma=a(i_a)%density_axial_gaussian_sigma, & + mask_str=a(i_a)%mask_str, axial_pos=a(i_a)%density_axial_pos) + else + call density_axial_calc(a(i_a)%density_axial_histograms(:,a(i_a)%n_configs), at, & + axis=a(i_a)%density_axial_axis, silica_center_i=a(i_a)%density_axial_silica_atoms, & + n_bins=a(i_a)%density_axial_n_bins, & + gaussian_smoothing=a(i_a)%density_axial_gaussian_smoothing, & + gaussian_sigma=a(i_a)%density_axial_gaussian_sigma, & + mask_str=a(i_a)%mask_str) + endif + else if (a(i_a)%num_hbond_silica) then !num_hbond_silica + a(i_a)%num_hbond_n_type = 4 + call reallocate_data(a(i_a)%num_hbond_histograms, a(i_a)%n_configs, (/a(i_a)%num_hbond_n_bins,a(i_a)%num_hbond_n_type/)) !4: ss, sw, ws, ww + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%num_hbond_bin_pos(a(i_a)%num_hbond_n_bins)) + allocate(a(i_a)%num_hbond_type_code(4)) + allocate(a(i_a)%num_hbond_type_label(4)) + call num_hbond_calc(a(i_a)%num_hbond_histograms(:,:,a(i_a)%n_configs), at, & + axis=a(i_a)%num_hbond_axis, silica_center_i=a(i_a)%num_hbond_silica_atoms, & + n_bins=a(i_a)%num_hbond_n_bins, & + gaussian_smoothing=a(i_a)%num_hbond_gaussian_smoothing, & + gaussian_sigma=a(i_a)%num_hbond_gaussian_sigma, & + mask_str=a(i_a)%mask_str, num_hbond_pos=a(i_a)%num_hbond_bin_pos, & + num_hbond_type_code=a(i_a)%num_hbond_type_code, & + num_hbond_type_label=a(i_a)%num_hbond_type_label) + else + call num_hbond_calc(a(i_a)%num_hbond_histograms(:,:,a(i_a)%n_configs), at, & + axis=a(i_a)%num_hbond_axis, silica_center_i=a(i_a)%num_hbond_silica_atoms, & + n_bins=a(i_a)%num_hbond_n_bins, & + gaussian_smoothing=a(i_a)%num_hbond_gaussian_smoothing, & + gaussian_sigma=a(i_a)%num_hbond_gaussian_sigma, & + mask_str=a(i_a)%mask_str) + endif + else if (a(i_a)%water_orientation_silica) then !water_orientation_silica + call reallocate_data(a(i_a)%water_orientation_histograms, a(i_a)%n_configs, (/ a(i_a)%water_orientation_n_angle_bins, a(i_a)%water_orientation_n_pos_bins /) ) + if (a(i_a)%n_configs == 1) then + allocate(a(i_a)%water_orientation_angle_bin(a(i_a)%water_orientation_n_angle_bins)) + allocate(a(i_a)%water_orientation_angle_bin_w(a(i_a)%water_orientation_n_angle_bins)) + allocate(a(i_a)%water_orientation_pos_bin(a(i_a)%water_orientation_n_pos_bins)) + call water_orientation_calc(a(i_a)%water_orientation_histograms(:,:,a(i_a)%n_configs), at, & + axis=a(i_a)%water_orientation_axis, silica_center_i=a(i_a)%water_orientation_silica_atoms, & + n_pos_bins=a(i_a)%water_orientation_n_pos_bins, n_angle_bins=a(i_a)%water_orientation_n_angle_bins, & + gaussian_smoothing=a(i_a)%water_orientation_gaussian_smoothing, & + pos_gaussian_sigma=a(i_a)%water_orientation_pos_gaussian_sigma, & + !angle_gaussian_sigma=a(i_a)%water_orientation_angle_gaussian_sigma, & + pos_bin=a(i_a)%water_orientation_pos_bin, angle_bin=a(i_a)%water_orientation_angle_bin, & + angle_bin_w=a(i_a)%water_orientation_angle_bin_w, & + use_dipole_rather_than_angle_bisector=a(i_a)%water_orientation_use_dipole) + else + call water_orientation_calc(a(i_a)%water_orientation_histograms(:,:,a(i_a)%n_configs), at, & + axis=a(i_a)%water_orientation_axis, silica_center_i=a(i_a)%water_orientation_silica_atoms, & + n_pos_bins=a(i_a)%water_orientation_n_pos_bins, n_angle_bins=a(i_a)%water_orientation_n_angle_bins, & + gaussian_smoothing=a(i_a)%water_orientation_gaussian_smoothing, & + pos_gaussian_sigma=a(i_a)%water_orientation_pos_gaussian_sigma, & + !angle_gaussian_sigma=a(i_a)%water_orientation_angle_gaussian_sigma, & + angle_bin_w=a(i_a)%water_orientation_angle_bin_w, & + use_dipole_rather_than_angle_bisector=a(i_a)%water_orientation_use_dipole) + endif + else + call system_abort("do_analyses: no type of analysis set for " // i_a) + endif + end if ! do this analysis + end do +end subroutine do_analyses + +function do_this_analysis(this, time, frame) + type(analysis), intent(in) :: this + real(dp), intent(in), optional :: time + integer, intent(in), optional :: frame + logical :: do_this_analysis + + do_this_analysis = .true. + + if (this%min_time > 0.0_dp) then + if (.not. present(time)) call system_abort("analysis has non-zero min_time, but no time specified") + if (time < 0.0_dp) call system_abort("analysis has non-zero min_time, but invalid time < 0") + if (time < this%min_time) then + do_this_analysis = .false. + endif + endif + if (this%max_time > 0.0_dp) then + if (.not. present(time)) call system_abort("analysis has non-zero max_time, but no time specified") + if (time < 0.0_dp) call system_abort("analysis has non-zero max_time, but invalid time < 0") + if (time > this%max_time) then + do_this_analysis = .false. + endif + endif + + if (this%min_frame > 0) then + if (.not. present(frame)) call system_abort("analysis has non-zero min_frame, but no frame specified") + if (frame < 0) call system_abort("analysis has non-zero min_frame, but invalid frame < 0") + if (frame < this%min_frame) then + do_this_analysis = .false. + endif + endif + if (this%max_frame > 0) then + if (.not. present(frame)) call system_abort("analysis has non-zero max_frame, but no frame specified") + if (frame < 0) call system_abort("analysis has non-zero max_frame, but invalid frame < 0") + if (frame > this%max_frame) then + do_this_analysis = .false. + endif + endif + +end function do_this_analysis + +subroutine print_analyses(a) + type(analysis), intent(inout) :: a(:) + + type(inoutput) :: outfile + integer :: i, i1, i2, i3, i_a + real(dp), allocatable :: integrated_rdfds(:,:) + + do i_a=1, size(a) + call initialise(outfile, a(i_a)%outfilename, OUTPUT) + if (a(i_a)%outfilename == "stdout") then + outfile%prefix="ANALYSIS_"//i_a + endif + + if (a(i_a)%n_configs <= 0) then + call print("# NO DATA", file=outfile) + else + if (a(i_a)%density_radial) then !density_radial + call print("# radial density histogram", file=outfile) + call print("n_bins="//a(i_a)%density_radial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i=1, a(i_a)%density_radial_n_bins + call print(a(i_a)%density_radial_pos(i), file=outfile) + end do + do i=1, a(i_a)%n_configs + call print(a(i_a)%density_radial_histograms(:,i), file=outfile) + end do + else if (a(i_a)%density_grid) then !density_grid + call print("# grid density histogram", file=outfile) + call print("n_bins="//a(i_a)%density_grid_n_bins(1)*a(i_a)%density_grid_n_bins(2)*a(i_a)%density_grid_n_bins(3)//" n_data="//a(i_a)%n_configs, file=outfile) + do i1=1, a(i_a)%density_grid_n_bins(1) + do i2=1, a(i_a)%density_grid_n_bins(2) + do i3=1, a(i_a)%density_grid_n_bins(3) + call print(""//a(i_a)%density_grid_pos(:,i1,i2,i3), file=outfile) + end do + end do + end do + do i=1, a(i_a)%n_configs + call print(""//reshape(a(i_a)%density_grid_histograms(:,:,:,i), (/ a(i_a)%density_grid_n_bins(1)*a(i_a)%density_grid_n_bins(2)*a(i_a)%density_grid_n_bins(3) /) ), file=outfile) + end do + else if (a(i_a)%KE_density_radial) then !density_radial + call print("# radial density histogram", file=outfile) + call print("n_bins="//a(i_a)%KE_density_radial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i=1, a(i_a)%KE_density_radial_n_bins + call print(a(i_a)%KE_density_radial_pos(i), file=outfile) + end do + do i=1, a(i_a)%n_configs + call print(a(i_a)%KE_density_radial_histograms(:,i), file=outfile) + end do + else if (a(i_a)%rdfd) then !rdfd + call print("# rdfd", file=outfile) + call print("n_bins="//a(i_a)%rdfd_n_zones*a(i_a)%rdfd_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i1=1, a(i_a)%rdfd_n_zones + do i2=1, a(i_a)%rdfd_n_bins + if (a(i_a)%rdfd_zone_width > 0.0_dp) then + call print(""//a(i_a)%rdfd_zone_pos(i1)//" "//a(i_a)%rdfd_bin_pos(i2), file=outfile) + else + call print(""//a(i_a)%rdfd_bin_pos(i2), file=outfile) + endif + end do + end do + do i=1, a(i_a)%n_configs + call print(""//reshape(a(i_a)%rdfds(:,:,i), (/ a(i_a)%rdfd_n_zones*a(i_a)%rdfd_n_bins /) ), file=outfile) + end do + + call print("", file=outfile) + call print("", file=outfile) + call print("# integrated_rdfd", file=outfile) + call print("n_bins="//a(i_a)%rdfd_n_zones*a(i_a)%rdfd_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i1=1, a(i_a)%rdfd_n_zones + do i2=1, a(i_a)%rdfd_n_bins + if (a(i_a)%rdfd_zone_width > 0.0_dp) then + call print(""//a(i_a)%rdfd_zone_pos(i1)//" "//a(i_a)%rdfd_bin_pos(i2), file=outfile) + else + call print(""//a(i_a)%rdfd_bin_pos(i2), file=outfile) + endif + end do + end do + allocate(integrated_rdfds(a(i_a)%rdfd_n_bins,a(i_a)%rdfd_n_zones)) + integrated_rdfds = 0.0_dp + do i=1, a(i_a)%n_configs + integrated_rdfds = 0.0_dp + do i1=1, a(i_a)%rdfd_n_zones + do i2=2, a(i_a)%rdfd_n_bins + integrated_rdfds(i2,i1) = integrated_rdfds(i2-1,i1) + & + (a(i_a)%rdfd_bin_pos(i2)-a(i_a)%rdfd_bin_pos(i2-1))* & + 4.0_dp*PI*((a(i_a)%rdfd_bin_pos(i2)**2)*a(i_a)%rdfds(i2,i1,i)+(a(i_a)%rdfd_bin_pos(i2-1)**2)*a(i_a)%rdfds(i2-1,i1,i))/2.0_dp + end do + end do + call print(""//reshape(integrated_rdfds(:,:), (/ a(i_a)%rdfd_n_zones*a(i_a)%rdfd_n_bins /) ), file=outfile) + end do + deallocate(integrated_rdfds) + + else if (a(i_a)%xrd) then ! xrd + call print("# xrd",file=outfile) + call print("n_bins="//a(i_a)%xrd_n_2theta//" n_data="//a(i_a)%n_configs, file=outfile) + do i=1, a(i_a)%xrd_n_2theta + call print(""//a(i_a)%xrd_2theta_pos(i), file=outfile) + end do + do i=1, a(i_a)%n_configs + call print(""//a(i_a)%xrds(:,i), file=outfile) + end do + + else if (a(i_a)%adfd) then !adfd + call print("# adfd", file=outfile) + call print("n_bins="//a(i_a)%adfd_n_zones*a(i_a)%adfd_n_dist_bins*a(i_a)%adfd_n_angle_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i1=1, a(i_a)%adfd_n_zones + do i2=1, a(i_a)%adfd_n_dist_bins + do i3=1, a(i_a)%adfd_n_angle_bins + if (a(i_a)%adfd_zone_width > 0.0_dp) then + call print(""//a(i_a)%adfd_zone_pos(i1)//" "//a(i_a)%adfd_dist_bin_pos(i2)//" "//a(i_a)%adfd_angle_bin_pos(i3), file=outfile) + else + call print(""//a(i_a)%adfd_dist_bin_pos(i2)//" "//a(i_a)%adfd_angle_bin_pos(i3), file=outfile) + endif + end do + end do + end do + do i=1, a(i_a)%n_configs + call print(""//reshape(a(i_a)%adfds(:,:,:,i), (/ a(i_a)%adfd_n_zones*a(i_a)%adfd_n_dist_bins*a(i_a)%adfd_n_angle_bins /) ), file=outfile) + end do + + else if (a(i_a)%KEdf_radial) then !r-dep KE density + call print("# r-dependent KE density", file=outfile) + call print("n_bins="//a(i_a)%KEdf_radial_n_zones*a(i_a)%KEdf_radial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + + do i1=1, a(i_a)%KEdf_radial_n_zones + do i2=1, a(i_a)%KEdf_radial_n_bins + if (a(i_a)%KEdf_radial_zone_width > 0.0_dp) then + call print(""//a(i_a)%KEdf_radial_zone_pos(i1)//" "//a(i_a)%KEdf_radial_bin_pos(i2), file=outfile) + else + call print(""//a(i_a)%KEdf_radial_bin_pos(i2), file=outfile) + endif + end do + end do + do i=1, a(i_a)%n_configs + call print(""//reshape(a(i_a)%KEdf_radial_histograms(:,:,i), (/ a(i_a)%KEdf_radial_n_zones*a(i_a)%KEdf_radial_n_bins /) ), file=outfile) + end do + + else if (a(i_a)%propdf_radial) then !r-dep |F| density + call print("# r-dependent prop density", file=outfile) + call print("n_bins="//a(i_a)%propdf_radial_n_zones*a(i_a)%propdf_radial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + + do i1=1, a(i_a)%propdf_radial_n_zones + do i2=1, a(i_a)%propdf_radial_n_bins + if (a(i_a)%propdf_radial_zone_width > 0.0_dp) then + call print(""//a(i_a)%propdf_radial_zone_pos(i1)//" "//a(i_a)%propdf_radial_bin_pos(i2), file=outfile) + else + call print(""//a(i_a)%propdf_radial_bin_pos(i2), file=outfile) + endif + end do + end do + do i=1, a(i_a)%n_configs + call print(""//reshape(a(i_a)%propdf_radial_histograms(:,:,i), (/ a(i_a)%propdf_radial_n_zones*a(i_a)%propdf_radial_n_bins /) ), file=outfile) + end do + + else if (a(i_a)%geometry) then !geometry + call print("# geometry histogram", file=outfile) + call print("n_bins="//a(i_a)%geometry_params%N//" n_data="//a(i_a)%n_configs, file=outfile) + do i=1, a(i_a)%geometry_params%N +! call print(a(i_a)%geometry_pos(i), file=outfile) + call print(trim(a(i_a)%geometry_label(i)), file=outfile) + end do + do i=1, a(i_a)%n_configs + call print(a(i_a)%geometry_histograms(:,i), file=outfile) + end do + + else if (a(i_a)%density_axial_silica) then !density_axial_silica + call print("# uniaxial density histogram in direction "//a(i_a)%density_axial_axis, file=outfile) + call print("n_bins="//a(i_a)%density_axial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i=1, a(i_a)%density_axial_n_bins + call print(a(i_a)%density_axial_pos(i), file=outfile) + end do + do i=1, a(i_a)%n_configs + call print(a(i_a)%density_axial_histograms(:,i), file=outfile) + end do + + else if (a(i_a)%num_hbond_silica) then !num_hbond_silica + !header + call print("# num_hbond_silica in direction "//a(i_a)%num_hbond_axis, file=outfile) + call print("n_bins="//a(i_a)%num_hbond_n_type*a(i_a)%num_hbond_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i1=1, a(i_a)%num_hbond_n_type + do i2=1, a(i_a)%num_hbond_n_bins + !call print(""//a(i_a)%num_hbond_type_code(i1)//" "//a(i_a)%num_hbond_bin_pos(i2), file=outfile) + call print(""//trim(a(i_a)%num_hbond_type_label(i1))//" "//a(i_a)%num_hbond_bin_pos(i2), file=outfile) + end do + end do + !histograms + do i=1, a(i_a)%n_configs + call print(""//reshape(a(i_a)%num_hbond_histograms(:,:,i), (/ a(i_a)%num_hbond_n_type*a(i_a)%num_hbond_n_bins /) ), file=outfile) + end do + + !integrated histograms header + call print("", file=outfile) + call print("", file=outfile) + call print("# integrated_num_hbond_silica", file=outfile) + call print("n_bins="//a(i_a)%num_hbond_n_type*a(i_a)%num_hbond_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i1=1, a(i_a)%num_hbond_n_type + do i2=1, a(i_a)%num_hbond_n_bins + !call print(""//a(i_a)%num_hbond_type_code(i1)//" "//a(i_a)%num_hbond_bin_pos(i2), file=outfile) + call print(""//trim(a(i_a)%num_hbond_type_label(i1))//" "//a(i_a)%num_hbond_bin_pos(i2), file=outfile) + end do + end do + !integrated histograms + allocate(a(i_a)%integrated_num_hbond_histograms(a(i_a)%num_hbond_n_bins,a(i_a)%num_hbond_n_type)) + a(i_a)%integrated_num_hbond_histograms = 0.0_dp + do i=1, a(i_a)%n_configs + a(i_a)%integrated_num_hbond_histograms = 0.0_dp + do i1=1, a(i_a)%num_hbond_n_type + do i2=2, a(i_a)%num_hbond_n_bins + a(i_a)%integrated_num_hbond_histograms(i2,i1) = a(i_a)%integrated_num_hbond_histograms(i2-1,i1) + & + (a(i_a)%num_hbond_bin_pos(i2)-a(i_a)%num_hbond_bin_pos(i2-1))* & + 4.0_dp*PI*((a(i_a)%num_hbond_bin_pos(i2)**2)*a(i_a)%num_hbond_histograms(i2,i1,i)+(a(i_a)%num_hbond_bin_pos(i2-1)**2)*a(i_a)%num_hbond_histograms(i2-1,i1,i))/2.0_dp + end do + end do + call print(""//reshape(a(i_a)%integrated_num_hbond_histograms(:,:), (/ a(i_a)%num_hbond_n_type*a(i_a)%num_hbond_n_bins /) ), file=outfile) + end do + deallocate(a(i_a)%integrated_num_hbond_histograms) + + else if (a(i_a)%water_orientation_silica) then !water_orientation_silica + !header + call print("# water_orientation_silica in direction "//a(i_a)%water_orientation_axis, file=outfile) + call print("n_bins="//a(i_a)%water_orientation_n_pos_bins*a(i_a)%water_orientation_n_angle_bins//" n_data="//a(i_a)%n_configs, file=outfile) + do i1=1, a(i_a)%water_orientation_n_pos_bins + do i2=1, a(i_a)%water_orientation_n_angle_bins + call print(""//a(i_a)%water_orientation_pos_bin(i1)//" "//a(i_a)%water_orientation_angle_bin(i2), file=outfile) + end do + end do + !histograms + do i=1, a(i_a)%n_configs + call print(""//reshape(a(i_a)%water_orientation_histograms(:,:,i), (/ a(i_a)%water_orientation_n_pos_bins*a(i_a)%water_orientation_n_angle_bins /) ), file=outfile) + end do + + else + call system_abort("print_analyses: no type of analysis set for " // i_a) + endif + endif + call finalise(outfile) + end do +end subroutine print_analyses + +!read geometry parameters to calculate +!format: +!4 number of params +!anything comment +!1 3 type #1: y-coord of atom #3 +!2 4 5 type #2: distance of atoms #4--#5 +!3 3 4 5 type #3: angle of atoms #3--#4--#5 +!4 3 1 2 4 type #4: dihedral of atoms #3--#1--#2--#4 +subroutine read_geometry_params(this,filename) + + type(analysis), intent(inout) :: this + character(*), intent(in) :: filename + + type(inoutput) :: geom_lib + character(20), dimension(10) :: fields + integer :: num_fields, status + integer :: num_geom, i, geom_type + character(STRING_LENGTH) :: comment + + call initialise(this%geometry_params,5,0,0,0,0) !type, atom1, atom2, atom3, atom4 + + if (trim(filename)=="") then + call print('WARNING! no file specified') + return !with an empty table + endif + + call initialise(geom_lib,trim(filename),action=INPUT) + call parse_line(geom_lib,' ',fields,num_fields) + if (num_fields < 1) then + call print ('WARNING! empty file '//trim(filename)) + call finalise(geom_lib) + return !with an empty table + endif + + num_geom = string_to_int(fields(1)) + comment="" + comment = read_line(geom_lib,status) + call print(trim(comment),PRINT_VERBOSE) + + do i=1,num_geom + call parse_line(geom_lib,' ',fields,num_fields) + if (num_fields.gt.5 .or. num_fields.lt.2) call system_abort('read_geometry_params: 1 type and maximum 4 atoms must be in the geometry file') + geom_type = string_to_int(fields(1)) + select case (geom_type) + case (1) !y coord atom1 + if (num_fields.lt.2) call system_abort('type 1: coordinate, =1 atoms needed') + call append(this%geometry_params,(/geom_type, & + string_to_int(fields(2)), & + 0, & + 0, & + 0/) ) + case (2) !distance atom1-atom2 + if (num_fields.lt.3) call system_abort('type 2: bond length, =2 atoms needed') + call append(this%geometry_params, (/geom_type, & + string_to_int(fields(2)), & + string_to_int(fields(3)), & + 0, & + 0/) ) + case (3) !angle atom1-atom2-atom3 + if (num_fields.lt.4) call system_abort('type 3: angle, =3 atoms needed') + call append(this%geometry_params, (/geom_type, & + string_to_int(fields(2)), & + string_to_int(fields(3)), & + string_to_int(fields(4)), & + 0/) ) + case (4) !dihedral atom1-atom2-atom3-atom4 + if (num_fields.lt.5) call system_abort('type 4: dihedral, =4 atoms needed') + call append(this%geometry_params, (/geom_type, & + string_to_int(fields(2)), & + string_to_int(fields(3)), & + string_to_int(fields(4)), & + string_to_int(fields(5)) /) ) + case (5) !distance of any atom3(Z) from the atom1-atom2 bond + if (num_fields.lt.4) call system_abort('type 5: Zatom3 distance from the atom1-atom2 bond, =3 atoms needed') + call append(this%geometry_params, (/geom_type, & + string_to_int(fields(2)), & + string_to_int(fields(3)), & + string_to_int(fields(4)), & + 0/) ) + case default + call system_abort('unknown type '//geom_type//', must be one of 1(y coordinate), 2(bond length/distance), 3(angle), 4(dihedral).') + end select + enddo + + call finalise(geom_lib) + +end subroutine read_geometry_params + +subroutine reallocate_data_1d(data, n, n_bins) + real(dp), allocatable, intent(inout) :: data(:,:) + integer, intent(in) :: n, n_bins + + integer :: new_size + real(dp), allocatable :: t_data(:,:) + + if (allocated(data)) then + if (n <= size(data,2)) return + allocate(t_data(size(data,1),size(data,2))) + t_data = data + deallocate(data) + if (size(t_data,2) <= 0) then + new_size = 10 + else if (size(t_data,2) < 1000) then + new_size = 2*size(t_data,2) + else + new_size = floor(1.25*size(t_data,2)) + endif + allocate(data(size(t_data,1), new_size)) + data(1:size(t_data,1),1:size(t_data,2)) = t_data(1:size(t_data,1),1:size(t_data,2)) + data(1:size(t_data,1),size(t_data,2)+1:size(data,2)) = 0.0_dp + deallocate(t_data) + else + allocate(data(n_bins, n)) + endif +end subroutine reallocate_data_1d + +subroutine reallocate_data_2d(data, n, n_bins) + real(dp), allocatable, intent(inout) :: data(:,:,:) + integer, intent(in) :: n, n_bins(2) + + integer :: new_size + real(dp), allocatable :: t_data(:,:,:) + + if (allocated(data)) then + if (n <= size(data,3)) return + allocate(t_data(size(data,1),size(data,2),size(data,3))) + t_data = data + deallocate(data) + if (size(t_data,3) <= 0) then + new_size = 10 + else if (size(t_data,3) < 1000) then + new_size = 2*size(t_data,3) + else + new_size = floor(1.25*size(t_data,3)) + endif + allocate(data(size(t_data,1), size(t_data,2), new_size)) + data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3)) = & + t_data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3)) + data(1:size(t_data,1),1:size(t_data,2),size(t_data,3)+1:size(data,3)) = 0.0_dp + deallocate(t_data) + else + allocate(data(n_bins(1), n_bins(2), n)) + endif +end subroutine reallocate_data_2d + +subroutine reallocate_data_3d(data, n, n_bins) + real(dp), allocatable, intent(inout) :: data(:,:,:,:) + integer, intent(in) :: n, n_bins(3) + + integer :: new_size + real(dp), allocatable :: t_data(:,:,:,:) + + if (allocated(data)) then + if (n <= size(data,4)) return + allocate(t_data(size(data,1),size(data,2),size(data,3),size(data,4))) + t_data = data + deallocate(data) + if (size(t_data,4) <= 0) then + new_size = 10 + else if (size(t_data,4) < 1000) then + new_size = 2*size(t_data,4) + else + new_size = floor(1.25*size(t_data,4)) + endif + allocate(data(size(t_data,1), size(t_data,2), size(t_data,3), new_size)) + data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3),1:size(t_data,4)) = & + t_data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3),1:size(t_data,4)) + data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3),size(t_data,4)+1:size(data,4)) = 0.0_dp + deallocate(t_data) + else + allocate(data(n_bins(1), n_bins(2), n_bins(3), n)) + endif +end subroutine reallocate_data_3d + +end module structure_analysis_module + +program structure_analysis +use libatoms_module +use structure_analysis_module +implicit none + + type(Dictionary) :: cli_params + + character(len=STRING_LENGTH) :: infilename + integer :: decimation + type(Inoutput) :: list_infile + type (CInoutput) :: infile + logical :: infile_is_list + logical :: quiet + + character(len=STRING_LENGTH) :: commandfilename + type(Inoutput) :: commandfile + + character(len=10240) :: args_str, myline + integer :: n_analysis_a + type(analysis), allocatable :: analysis_a(:) + + logical :: more_files + integer :: status, arg_line_no + integer :: error = ERROR_NONE + real(dp) :: time + + integer :: i_a, frame_count, raw_frame_count + type(Atoms) :: structure + logical :: do_verbose + + call system_initialise(PRINT_NORMAL) + + call initialise(cli_params) + call param_register(cli_params, "verbose", "F", do_verbose, help_string="Set verbosity level to VERBOSE.") + if (.not. param_read_args(cli_params, ignore_unknown=.true.)) & + call system_abort("Impossible failure to parse verbosity") + call finalise(cli_params) + if (do_verbose) then + call system_initialise(verbosity=PRINT_VERBOSE) + endif + + call initialise(cli_params) + call param_register(cli_params, "commandfile", '', commandfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params, "infile", "stdin", infilename, help_string="Input file name (default: stdin)") + call param_register(cli_params, "decimation", "1", decimation, help_string="How many frames to advance in each step, i.e. every n-th frame will be analysed.") + call param_register(cli_params, "infile_is_list", "F", infile_is_list, help_string="Treat infile as a list of filenames to process sequentially.") + call param_register(cli_params, "quiet", "F", quiet, help_string="Suppress frame progress count.") + if (.not. param_read_args(cli_params, ignore_unknown = .true., task="CLI")) then + call system_abort("Failed to parse CLI") + endif + if (len_trim(commandfilename) == 0) then + allocate(analysis_a(1)) + call analysis_read(analysis_a(1)) + else + if (.not. param_read_args(cli_params, ignore_unknown = .false., task="CLI_again")) then + call system_abort("Failed to parse CLI again after getting a commandfile, most likely passed in some analysis specific flags on command line") + endif + call initialise(commandfile, trim(commandfilename), INPUT) + arg_line_no = 1 + myline = read_line(commandfile) + read (unit=myline,fmt=*) n_analysis_a + allocate(analysis_a(n_analysis_a)) + do i_a=1, n_analysis_a + args_str = read_line(commandfile) + if (i_a == 1) then + call analysis_read(analysis_a(i_a), args_str=args_str) + else + call analysis_read(analysis_a(i_a), analysis_a(i_a-1), args_str) + endif + end do + endif + call finalise(cli_params) + + call check_analyses(analysis_a) + + more_files = .true. + if (infile_is_list) then + call initialise(list_infile, trim(infilename), INPUT) + infilename = read_line(list_infile, status) + more_files = .false. + if (status == 0) more_files = .true. + endif + + raw_frame_count = decimation-1 + frame_count = 0 + do while (more_files) + + call print(trim(infilename)) + call initialise(infile, infilename, INPUT) + call read(structure, infile, error=error, frame=raw_frame_count) + do while (error == ERROR_NONE) + frame_count = frame_count + 1 + if (.not. quiet) then + if (mod(frame_count,1000) == 1) write (mainlog%unit,'(I7,a,$)') frame_count," " + if (mod(frame_count,10) == 0) write (mainlog%unit,'(I1,$)') mod(frame_count/10,10) + if (mod(frame_count,1000) == 0) write (mainlog%unit,'(a)') " " + endif + + if (.not. get_value(structure%params,"Time",time)) then + time = -1.0_dp + endif + call do_analyses(analysis_a, time, frame_count, structure) + call finalise(structure) + + raw_frame_count = raw_frame_count + decimation + ! get ready for next structure + call read(structure, infile, error=error, frame=raw_frame_count) + end do + ! We do not want to handle this error + call clear_error(error) + raw_frame_count = raw_frame_count - decimation + + ! get ready for next file + more_files = .false. + call finalise(infile) + if (infile_is_list) then + infilename = read_line(list_infile, status) + if (status == 0) then + more_files = .true. + endif + if (infile%n_frame > 0) then + raw_frame_count = (decimation-1)-(infile%n_frame-1-raw_frame_count) + else + raw_frame_count = decimation-1 + endif + endif + write (mainlog%unit,'(a)') " " + frame_count = 0 + end do ! more_files + if (infile_is_list) call finalise(list_infile) + + call print_analyses(analysis_a) + +end program structure_analysis diff --git a/src/Structure_processors/test_ran.F90 b/src/Structure_processors/test_ran.F90 new file mode 100755 index 0000000000..1a240016e0 --- /dev/null +++ b/src/Structure_processors/test_ran.F90 @@ -0,0 +1,93 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +program test_ran + use libatoms_module + +#ifdef _OPENMP + use omp_lib +#endif + + implicit none + + integer, parameter :: nrand = 100000 + + type(Histogram1D), save :: h + !$omp threadprivate(h) + integer :: i, n + real(DP) :: d + + ! --- + + call system_initialise(PRINT_NORMAL) + + call print("Start generating random numbers on proc 0...") + + if (mpi_id() == 0) then + !$omp parallel default(none) private(i, n, d) + do i = 1, nrand + d = ran_normal() + enddo + !$omp end parallel + endif + + call print("...done") + + call print("Synching rngs.") + call system_resync_rng + + call print("Start generating random numbers on all procs...") + + !$omp parallel default(none) private(i, n, d) + call initialise(h, 1000, -10.0_DP, 10.0_DP) + + do i = 1, nrand + call add(h, ran_normal()) + enddo + +#ifdef _OPENMP + n = omp_get_thread_num() +#else + n = 0 +#endif + + call write(h, "normal_"//mpi_id()//"_"//n//".out") + call finalise(h) + !$omp end parallel + + call print("...done") + + call print("Please check that all normal_*_1.out are identical.") + + call system_finalise() + +end program test_ran diff --git a/src/Structure_processors/xyz2pdb.F90 b/src/Structure_processors/xyz2pdb.F90 new file mode 100644 index 0000000000..688b734825 --- /dev/null +++ b/src/Structure_processors/xyz2pdb.F90 @@ -0,0 +1,329 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +! last modified -- 2009-02-19 -- Csilla +! takes an xyz file, identifies the residues and outputs a PSF and a PDB file. +#include "error.inc" + +program xyz2pdb + +! use libatoms_module + + use error_module + use atoms_types_module, only: bond_length, assign_pointer, add_property, atoms_sort, distance_min_image + use atoms_module, only: atoms, finalise, & + set_cutoff, & + calc_connect, print, & + map_into_cell, has_property + use dictionary_module, only: dictionary, initialise, finalise, & + set_value, STRING_LENGTH + use linearalgebra_module, only: find_in_array + use paramreader_module, only: param_register, param_read_args, & + PARAM_MANDATORY + use periodictable_module, only: ElementCovRad + use system_module, only: dp, inoutput, & + system_initialise, system_finalise, & + system_timer, system_abort, & + print, verbosity_push, & + operator(//), & + INPUT, OUTPUT, & + PRINT_SILENT, PRINT_NORMAL, PRINT_ANALYSIS, PRINT_NERD + use table_module, only: table, finalise, int_part, delete, TABLE_STRING_LENGTH + use topology_module, only: create_residue_labels_arb_pos, delete_metal_connects, & + write_brookhaven_pdb_file, & + write_psf_file, & + MM_RUN, silica_2body_cutoff, find_molecule_ids + use cinoutput_module, only : read, write + + implicit none + + type(Atoms) :: my_atoms + type(Table) :: intrares_impropers + + type(Dictionary) :: params_in + character(len=STRING_LENGTH) :: Library, & + xyz_file + real(dp) :: Neighbour_Tolerance + logical :: Delete_Metal_Connections + logical :: print_xsc + character(80) :: Root, & + pdb_name, & + psf_name, & + xsc_name + integer :: len_name + integer :: center_atom, i, j + real(dp) :: shift(3) + logical :: ex + logical :: have_silica_potential + logical :: use_avgpos, Print_PSF + integer :: at_i, iri_i + integer, pointer :: sort_index_p(:) + integer, allocatable :: rev_sort_index(:) + logical :: do_sort, do_sort_3 + integer :: error = ERROR_NONE + character(80) :: sorted_name + + integer, pointer :: mol_id(:), atom_res_number(:) + character(len=1), pointer :: atom_type(:,:), atom_type_PDB(:,:), atom_res_name(:,:), atom_mol_name(:,:) + character(len=STRING_LENGTH) t_atom_name + + call system_initialise(verbosity=PRINT_silent,enable_timing=.true.) + call verbosity_push(PRINT_NORMAL) + call system_timer('program') + + ! reading in run parameters + call initialise(params_in) + call param_register(params_in, 'File', PARAM_MANDATORY, xyz_file, help_string="Input XYZ file containing species:pos or species:avgpos") + call param_register(params_in, 'Residue_Library', PARAM_MANDATORY, Library, help_string="Residue library for pattern matching, e.g. $QUIP_DIR/libAtoms/protein_res.CHARMM.lib") + call param_register(params_in, 'Neighbour_Tolerance', '1.2', Neighbour_Tolerance, help_string="Bond criterion tolerance factor. Two atoms are bonded if d(a1,a2)<[CovRad(a1)+CovRad(a2)]*Neighbour_Tolerance. This should normally not need changing.") + call param_register(params_in, 'Delete_Metal_Connections', 'T', Delete_Metal_Connections, help_string="Whether not to take into account bonds of non(C,H,O,N,P) elements.") + call param_register(params_in, 'Print_XSC', 'F', print_xsc, help_string="Whether to output XSC (NAMD cell file).") + call param_register(params_in, 'Center_atom', '0', center_atom, help_string="Which atom should the system be centered around. 0 means no centering. This is important for programs that can only treat nonperiodic systems not to cut the molecule in half.") + call param_register(params_in, 'have_silica_potential', 'F', have_silica_potential, help_string="Whether there is a silica unit in the system to be treated with the Danny potential in CP2K.") + call param_register(params_in, 'use_avgpos', 'T', use_avgpos, help_string="Whether to use the average positions (avgpos) for the pattern matching rather than the instantaneous positions (pos).") + call param_register(params_in, 'sort', 'F', do_sort, help_string="Whether to sort atoms by molecule and residue.") + call param_register(params_in, 'sort_3', 'F', do_sort_3, help_string="If sorting, whether to sort by atom number within residue as well") + call param_register(params_in, 'Print_PSF', 'T', Print_PSF, help_string="Write PSF file") + if (.not. param_read_args(params_in)) then + call print_usage + call system_abort('could not parse argument line') + end if + + ! filenames + len_name = len_trim(xyz_file) + if (any(xyz_file(len_name-3:len_name).eq.(/'.xyz','.XYZ'/))) then + Root = xyz_file(1:len_name-4) + else + Root = xyz_file(1:len_name) + endif + pdb_name = trim(Root)//'.pdb' + psf_name = trim(Root)//'.psf' + xsc_name = trim(Root)//'.xsc' + sorted_name = trim(Root)//'.sorted.xyz' + + ! print run parameters + call print('Input:') + call print(' XYZ file: '//trim(xyz_file)) + call print(' Residue Library: '//trim(Library)) + call print(' Print_XSC (NAMD cell file): '//print_xsc) + call print(' Delete_Metal_Connections'//Delete_Metal_Connections) + call print(' Neighbour Tolerance: '//Neighbour_Tolerance) + call print(' have_silica_potential: '//have_silica_potential) + call print(' use_avgpos to build connectivity: '//use_avgpos) + call print(' sort atoms by molecule/residue : '//use_avgpos) + if(center_atom > 0) & + call print(' Center atom: '//center_atom) + call print('Output:') + call print(' PDB file: '//trim(pdb_name)) + call print(' PSF file: '//trim(psf_name)) + if (print_xsc) call print(' XSC file: '//trim(xsc_name)) + call print('CHARMM atomic types and Brookhaven PDB format are used') + call print('') + + call finalise(params_in) + + ! check if input files exist + inquire(file=trim(xyz_file),exist=ex) + if (.not.ex) then + call print_usage + call system_abort('Missing xyz File '//xyz_file) + endif + if (trim(Library) /= '-') then + inquire(file=trim(Library),exist=ex) + if (.not.ex) then + call print_usage + call system_abort('Missing Residue_Library '//Library) + endif + endif + + ! read in XYZ + call print('Reading in coordinates...') + call read(my_atoms,trim(xyz_file)) + + + ! calculating connectivities + call print('Calculating connectivities...') + ! use nonuniform connect_cutoff, include only nearest neighbours, otherwise the adjacency matrix will contain disjoint regions + if (have_silica_potential) then + call set_cutoff(my_atoms,silica_2body_cutoff) + else + call set_cutoff(my_atoms,0.0_dp) + endif + my_atoms%nneightol = Neighbour_Tolerance + call calc_connect(my_atoms) + ! remove bonds for metal ions - everything but H, C, N, O, Si, P, S + if (Delete_Metal_Connections) call delete_metal_connects(my_atoms) +! call print(my_atoms%connect) + + ! center atoms if needed + if(center_atom > 0) then + shift = my_atoms%pos(:,center_atom) + do i=1,my_atoms%N + my_atoms%pos(:,i) = my_atoms%pos(:,i)-shift + end do + end if + ! call map_into_cell(my_atoms) + + ! identify residues + call print('Identifying residues...') + if (trim(Library) == "-") then + call find_molecule_ids(my_atoms) + if (.not. assign_pointer(my_atoms, 'mol_id', mol_id)) & + call system_abort("Failed to find mol_id field after find_molecule_ids!") + call add_property(my_atoms, 'atom_charge', 0.0_dp) + call add_property(my_atoms, 'atom_res_number', 0, ptr=atom_res_number) + call add_property(my_atoms, 'atom_type', ' ', ptr=atom_type) + call add_property(my_atoms, 'atom_type_PDB', ' ', ptr=atom_type_PDB) + call add_property(my_atoms, 'atom_res_name', ' ', ptr=atom_res_name) + call add_property(my_atoms, 'atom_mol_name', ' ', ptr=atom_mol_name) + atom_res_number = mol_id + atom_type(:,:) = my_atoms%species(:,:) + atom_type_PDB(:,:) = my_atoms%species(:,:) + do i=1, my_atoms%N + t_atom_name = adjustl("R"//atom_res_number(i)) + do j=1, len_trim(t_atom_name) + atom_res_name(j,i) = t_atom_name(j:j) + end do + t_atom_name = adjustl("M"//mol_id(i)) + do j=1, len_trim(t_atom_name) + atom_mol_name(j,i) = t_atom_name(j:j) + end do + end do + else + call set_value(my_atoms%params,'Library',trim(Library)) + if (use_avgpos) then + call create_residue_labels_arb_pos(my_atoms,do_CHARMM=.true.,intrares_impropers=intrares_impropers, & + find_silica_residue=have_silica_potential,pos_field_for_connectivity="avgpos") + else !use actual positions + call create_residue_labels_arb_pos(my_atoms,do_CHARMM=.true.,intrares_impropers=intrares_impropers, & + find_silica_residue=have_silica_potential,pos_field_for_connectivity="pos") + endif + endif + + if (do_sort) then + ! sort by molecule, residue ID + nullify(sort_index_p) + if (.not. assign_pointer(my_atoms, 'sort_index', sort_index_p)) then + call add_property(my_atoms, 'sort_index', 0) + if (.not. assign_pointer(my_atoms, 'sort_index', sort_index_p)) & + call system_abort("WARNING: do_cp2k_calc failed to assign pointer or create new field for sort_index, can't sort") + endif + do at_i=1, my_atoms%N + sort_index_p(at_i) = at_i + end do + if (.not.(has_property(my_atoms,'mol_id')) .or. .not. has_property(my_atoms,'atom_res_number')) then + call system_abort("WARNING: can't do sort_by_molecule - need mol_id and atom_res_number") + else + if (do_sort_3) then + call atoms_sort(my_atoms, 'mol_id', 'atom_res_number', 'motif_atom_num', error=error) + else + call atoms_sort(my_atoms, 'mol_id', 'atom_res_number', error=error) + endif + HANDLE_ERROR(error) + do at_i=1, my_atoms%N + if (sort_index_p(at_i) /= at_i) then + call print("sort() of my_atoms%data by mol_id, atom_res_number reordered some atoms") + exit + endif + end do + end if + call calc_connect(my_atoms) + + ! fix intrares_impropers to correspond to sorted atom numbers + allocate(rev_sort_index(my_atoms%N)) + do at_i=1, my_atoms%N + rev_sort_index(sort_index_p(at_i)) = at_i + end do + do iri_i=1, intrares_impropers%N + intrares_impropers%int(1:4,iri_i) = rev_sort_index(intrares_impropers%int(1:4,iri_i)) + end do + deallocate(rev_sort_index) + end if ! do_sort + + ! print output PDB and PSF files + call print('Writing files with CHARMM format...') + if (Print_PSF) then + call write_psf_file(my_atoms,psf_file=trim(psf_name),intrares_impropers=intrares_impropers,add_silica_23body=have_silica_potential) + endif + call write_brookhaven_pdb_file(my_atoms,trim(pdb_name)) + if (Print_XSC) call write_xsc_file(my_atoms,xsc_file=trim(xsc_name)) + if (do_sort) then + call write(my_atoms, trim(sorted_name)) + endif + + call finalise(intrares_impropers) + call finalise(my_atoms) + call print ('Finished.') + + call system_timer('program') + call system_finalise + +contains + + subroutine print_usage + + call print('Usage: xyz2pdb File=filename.xyz [Residue_Library=library] [Print_XSC] [Delete_Metal_Connections=T] [Neighbour_tolerance=1.2] [Center_atom=num]') + call print('') + call print(' File=filename, where your input file has extension .xyz') + call print(' Residue_Library=library, where the residue library is, - for no library, just use mol_id based on connectivity') + call print(' [Print_XSC], optional, whether to print NAMD cell file, default is false') + call print(' [Delete_Metal_Connections=T], optional, default is true, only calculates connection for H,C,N,O,Si,P,S,Cl') + call print(' should work fine - only modify if you want bonds with other elements in your structure') + call print(' [Neighbour_Tolerance=1.2], optional, default is 1.2, should work fine - do not poke it ') + call print(' unless you know you have unusally long bonds in your structure') + call print(' [Center_atom=num], optionally shifts atoms so that the atom with index num is at') + call print(' the origin, before dropping periodic boundary condition info') + call print(' [use_avgpos=T], optionally use instantaneous positions instead of average positions, if this is set to F') + call print(' [sort=F], optionally sort atoms by residue/molecule') + call print(' [have_silica_potential=F], optionally switches on the use of silica potential described by Cole et al., JChemPhys, 2007.') + + call print('') + + end subroutine + + subroutine write_xsc_file(at, xsc_file) + + character(len=*), intent(in) :: xsc_file + type(Atoms), intent(in) :: at + + type(InOutput) :: xsc + + call initialise(xsc,trim(xsc_file),action=OUTPUT) + call print(' XSC file: '//trim(xsc%filename)) + + call print('#NAMD cell file',file=xsc) + call print('#$LABELS step a_x a_y a_z b_x b_y b_z c_x c_y c_z o_x o_y o_z',file=xsc) + call print('1 '//reshape(at%lattice,(/9/))//' '//(/0,0,0/),file=xsc) +!write_string(this%params,real_format='f18.6') + call finalise(xsc) + + end subroutine write_xsc_file + +end program xyz2pdb diff --git a/src/Structure_processors/xyz2residue_library.F90 b/src/Structure_processors/xyz2residue_library.F90 new file mode 100644 index 0000000000..55cc4dedaf --- /dev/null +++ b/src/Structure_processors/xyz2residue_library.F90 @@ -0,0 +1,56 @@ +program xyz2residue_library + use system_module, only : string_cat_string_array + use libatoms_module +implicit none + + type(Atoms) :: at, m_at + integer i_at, j_at, nn_ii, nn_i + integer, pointer :: mol_id(:) + character(len=32) :: specie + + call system_initialise(verbosity=PRINT_SILENT) + call verbosity_push(PRINT_NORMAL) + + call read(at, "stdin") + + call calc_connect(at) + call find_molecule_ids(at) + + specie = " " + + if (.not. assign_pointer(at, "mol_id", mol_id)) & + call system_abort("Failed to find mol_id property") + + do i_at=1, at%N + if (mol_id(i_at) /= 0) then + call select(m_at, at, mask=(mol_id(:) == mol_id(i_at))) + call calc_connect(m_at) + + call print("%residue X"//count(mol_id == mol_id(i_at))//" R"//mol_id(i_at)//" R"//mol_id(i_at)) + do j_at=1, m_at%N + line = "0 "//m_at%Z(j_at) + if (n_neighbours(m_at, j_at) > 6) & + call system_abort("Too many neighbours "//n_neighbours(m_at, j_at)//" for atom "//j_at) + do nn_ii=1, n_neighbours(m_at, j_at) + nn_i = neighbour(m_at, j_at, nn_ii) + line = trim(line)//" "//nn_i + end do + do nn_ii=n_neighbours(m_at, j_at)+1, 6 + line = trim(line)//" "//0 + end do + ! nvfortran may complain + specie = string_cat_string_array(specie,m_at%species(:,j_at)) + line = trim(line)//" "//trim(specie)//" 0.0 "//trim(specie) + call print(trim(line)) + end do + call print("") + + endif + where (mol_id == mol_id(i_at)) + mol_id = 0 + end where + end do + + call system_finalise() +end program + From 40630e8d1f706f78f1eebae1dbc0499b749559d7 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 18:16:24 +0100 Subject: [PATCH 12/47] renamed source files to have F90 extension --- src/Structure_processors/UI_integrate.f95 | 77 - src/Structure_processors/angle_distr.f95 | 907 ----------- src/Structure_processors/clean_traj.f95 | 117 -- src/Structure_processors/convert.f95 | 72 - .../coordination_number.f95 | 300 ---- src/Structure_processors/decimate.f95 | 76 - src/Structure_processors/density.f95 | 326 ---- src/Structure_processors/density_1d.f95 | 633 -------- src/Structure_processors/density_KDE.f95 | 701 --------- src/Structure_processors/density_new.f95 | 792 ---------- src/Structure_processors/diffusion.f95 | 168 -- src/Structure_processors/elastic_fields.f95 | 106 -- src/Structure_processors/extract_EVB.f95 | 227 --- src/Structure_processors/extract_cv.f95 | 288 ---- src/Structure_processors/file_rewrite.f95 | 97 -- src/Structure_processors/find_space_minim.f95 | 291 ---- .../histogram_process.f95 | 326 ---- .../make_bulk_supercell.f95 | 38 - src/Structure_processors/make_k_mesh.f95 | 39 - .../make_surface_slab_vasp.f95 | 319 ---- src/Structure_processors/mean_var_correl.f95 | 797 ---------- .../mean_var_decorrelated_err.f95 | 42 - src/Structure_processors/merge_traj.f95 | 102 -- .../move_displacement_field.f95 | 122 -- src/Structure_processors/msd_vibrations.f95 | 131 -- src/Structure_processors/rdfd.f95 | 323 ---- src/Structure_processors/rings.f95 | 109 -- src/Structure_processors/solvate.f95 | 177 --- src/Structure_processors/solvate_silica.f95 | 257 --- .../structure_analysis_traj.f95 | 1400 ----------------- src/Structure_processors/test_ran.f95 | 93 -- src/Structure_processors/xyz2pdb.f95 | 329 ---- .../xyz2residue_library.f95 | 56 - 33 files changed, 9838 deletions(-) delete mode 100644 src/Structure_processors/UI_integrate.f95 delete mode 100644 src/Structure_processors/angle_distr.f95 delete mode 100644 src/Structure_processors/clean_traj.f95 delete mode 100644 src/Structure_processors/convert.f95 delete mode 100644 src/Structure_processors/coordination_number.f95 delete mode 100644 src/Structure_processors/decimate.f95 delete mode 100644 src/Structure_processors/density.f95 delete mode 100644 src/Structure_processors/density_1d.f95 delete mode 100644 src/Structure_processors/density_KDE.f95 delete mode 100644 src/Structure_processors/density_new.f95 delete mode 100644 src/Structure_processors/diffusion.f95 delete mode 100644 src/Structure_processors/elastic_fields.f95 delete mode 100644 src/Structure_processors/extract_EVB.f95 delete mode 100644 src/Structure_processors/extract_cv.f95 delete mode 100644 src/Structure_processors/file_rewrite.f95 delete mode 100644 src/Structure_processors/find_space_minim.f95 delete mode 100644 src/Structure_processors/histogram_process.f95 delete mode 100644 src/Structure_processors/make_bulk_supercell.f95 delete mode 100644 src/Structure_processors/make_k_mesh.f95 delete mode 100644 src/Structure_processors/make_surface_slab_vasp.f95 delete mode 100644 src/Structure_processors/mean_var_correl.f95 delete mode 100644 src/Structure_processors/mean_var_decorrelated_err.f95 delete mode 100644 src/Structure_processors/merge_traj.f95 delete mode 100644 src/Structure_processors/move_displacement_field.f95 delete mode 100755 src/Structure_processors/msd_vibrations.f95 delete mode 100644 src/Structure_processors/rdfd.f95 delete mode 100644 src/Structure_processors/rings.f95 delete mode 100644 src/Structure_processors/solvate.f95 delete mode 100644 src/Structure_processors/solvate_silica.f95 delete mode 100644 src/Structure_processors/structure_analysis_traj.f95 delete mode 100755 src/Structure_processors/test_ran.f95 delete mode 100644 src/Structure_processors/xyz2pdb.f95 delete mode 100644 src/Structure_processors/xyz2residue_library.f95 diff --git a/src/Structure_processors/UI_integrate.f95 b/src/Structure_processors/UI_integrate.f95 deleted file mode 100644 index 25d8718131..0000000000 --- a/src/Structure_processors/UI_integrate.f95 +++ /dev/null @@ -1,77 +0,0 @@ -program UI_integrate -use libatoms_module -implicit none - type(InOutput) :: io - integer :: N, n_lines - real(dp), allocatable :: v(:), v_err(:), f(:), f_err(:), f_int(:), f_int_err_sq(:) - real(dp) :: t_err_sq - character(len=256), allocatable :: line_array(:) - integer :: i, i_zero - - call system_initialise(verbosity=PRINT_SILENT) - call verbosity_push(PRINT_NORMAL) - - call initialise(io, "stdin") - call read_file(io, line_array, n_lines) - call finalise(io) - allocate(v(n_lines+1)) - allocate(v_err(n_lines+1)) - allocate(f(n_lines+1)) - allocate(f_err(n_lines+1)) - allocate(f_int(n_lines+1)) - allocate(f_int_err_sq(n_lines+1)) - N=n_lines - do i=1, N - read (unit=line_array(i), fmt=*) v(i), v_err(i), f(i), f_err(i) - end do - i_zero = 1 - do i=2, N - if (f(i-1)*f(i) < 0) then ! force changed sign, must have crossed 0 here - v(i+1:n+1) = v(i:n) - v_err(i+1:n+1) = v_err(i:n) - f(i+1:n+1) = f(i:n) - f_err(i+1:N+1) = f_err(i:N) - - v(i) = v(i-1)*f(i+1)/(f(i+1)-f(i-1)) - v(i+1)*f(i-1)/(f(i+1)-f(i-1)) - v_err(i) = Sqrt((f(i+1)**2*v_err(i-1)**2)/(-f(i-1) + f(i+1))**2 + & - f_err(i+1)**2*(-((f(i+1)*v(i-1))/(-f(i-1) + f(i+1))**2) + v(i-1)/(-f(i-1) + f(i+1)) + & - (f(i-1)*v(i+1))/(-f(i-1) + f(i+1))**2)**2 + f_err(i-1)**2*((f(i+1)*v(i-1))/(-f(i-1) + f(i+1))**2 & - - (f(i-1)*v(i+1))/(-f(i-1) + f(i+1))**2 - v(i+1)/(-f(i-1) + f(i+1)))**2 + & - (f(i-1)**2*v_err(i+1)**2)/(-f(i-1) + f(i+1))**2) - - f(i) = 0.0_dp - f_err(i) = Sqrt((f(i+1)**2*f_err(i-1)**2)/(-f(i-1) + f(i+1))**2 + & - f_err(i+1)**2*(-((f(i+1)*f(i-1))/(-f(i-1) + f(i+1))**2) + f(i-1)/(-f(i-1) + f(i+1)) + & - (f(i-1)*f(i+1))/(-f(i-1) + f(i+1))**2)**2 + f_err(i-1)**2*((f(i+1)*f(i-1))/(-f(i-1) + f(i+1))**2 & - - (f(i-1)*f(i+1))/(-f(i-1) + f(i+1))**2 - f(i+1)/(-f(i-1) + f(i+1)))**2 + & - (f(i-1)**2*f_err(i+1)**2)/(-f(i-1) + f(i+1))**2) - - i_zero = i - N = N+1 - exit - endif - end do - - f_int(i_zero) = 0.0_dp - f_int_err_sq(i_zero) = 0.0_dp - do i=i_zero-1, 1, -1 - f_int(i) = f_int(i+1) - (v(i+1)-v(i))*(f(i+1)+f(i))/2.0_dp - t_err_sq = ((f(i+1)+f(i))/2.0_dp)**2*v_err(i+1)**2 + ((f(i+1)+f(i))/2.0_dp)**2*v_err(i)**2 + & - ((v(i+1)-v(i))/2.0_dp)**2*f_err(i+1)**2 + ((v(i+1)-v(i))/2.0_dp)**2*f_err(i)**2 - f_int_err_sq(i) = f_int_err_sq(i+1) + t_err_sq - end do - do i=i_zero, N-1 - f_int(i+1) = f_int(i) + (v(i+1)-v(i))*(f(i+1)+f(i))/2.0_dp - t_err_sq = ((f(i+1)+f(i))/2.0_dp)**2*v_err(i+1)**2 + ((f(i+1)+f(i))/2.0_dp)**2*v_err(i)**2 + & - ((v(i+1)-v(i))/2.0_dp)**2*f_err(i+1)**2 + ((v(i+1)-v(i))/2.0_dp)**2*f_err(i)**2 - f_int_err_sq(i+1) = f_int_err_sq(i) + t_err_sq - end do - - call print("# col_val err grad_val err int_val err") - do i=1, N - call print(v(i)//" "//v_err(i)//" "//f(i)//" "//f_err(i)//" "//f_int(i)//" "//sqrt(f_int_err_sq(i))) - end do - - call verbosity_pop() - call system_finalise() -end program UI_integrate diff --git a/src/Structure_processors/angle_distr.f95 b/src/Structure_processors/angle_distr.f95 deleted file mode 100644 index 32f7723088..0000000000 --- a/src/Structure_processors/angle_distr.f95 +++ /dev/null @@ -1,907 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Calculates angle distribution in a radial mesh -! with error bars -! outputs: angle (1) O-O distance (A) distance from origin (A) angle distribution (arb.units) - -program angle_distr -use libatoms_module -implicit none - - type(Dictionary) :: cli_params - character(len=STRING_LENGTH) :: infilename - logical :: infile_is_list - character(len=STRING_LENGTH) :: outfilename - type(Inoutput) :: outfile - character(len=STRING_LENGTH) :: commandfilename - type(Inoutput) :: commandfile - character(len=1024) :: args_str - - character(len=STRING_LENGTH) :: mask_str - character(len=STRING_LENGTH) :: mask_center - integer :: decimation - real(dp) :: min_time, max_time - logical :: gaussian_smoothing - real(dp) :: gaussian_sigma - real(dp) :: sampling_sigma - real(dp) :: gaussian_angle_sigma - logical :: radial_histo, random_samples - logical :: do_distance_dependence - integer :: n_samples(2) - integer :: nth_snapshots - logical :: sort_Time, no_Time_dups - real(dp) :: min_p(3), bin_width(3) - integer :: n_bins(3) - logical :: quiet - logical :: autocorrelation, mean - integer :: autocorrelation_max_lag - real(dp) :: mean_decorrelation_time - logical :: have_params - integer :: status, arg_line_no - - logical :: no_compute_index - integer :: n_histos - type(Atoms_ll) :: structure_ll - real(dp), allocatable :: histo_raw(:,:,:,:), histo_mean(:,:,:), histo_var(:,:,:) - integer :: i_lag, i1, i2, i3 - real(dp), allocatable :: autocorr(:,:,:,:) - real(dp) :: m_bin_width - - real(dp) :: part_dens, cell_vol - - call system_initialise(PRINT_VERBOSE) - - call initialise(cli_params) - call register_cli_params(cli_params,.true., infilename, infile_is_list, outfilename, commandfilename, & - mask_str, mask_center, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & - radial_histo, random_samples, n_samples, do_distance_dependence, nth_snapshots, & - sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) - if (.not. param_read_args(cli_params)) then - call print_usage() - call system_abort('could not parse argument line') - end if - - call print("Reading configurations") - no_compute_index=.false. - if ((.not. sort_Time) .and. (.not. no_Time_dups)) no_compute_index=.true. - call read_xyz(structure_ll, infilename, infile_is_list, decimation, min_time, max_time, sort_Time, no_Time_dups, quiet, no_compute_index) - - if (len_trim(commandfilename) == 0) then - args_str = param_write_string(cli_params) - call finalise(cli_params) - else - call finalise(cli_params) - call print("reading commands from file '"//trim(commandfilename)//"'") - call initialise(commandfile, trim(commandfilename), INPUT) - arg_line_no = 1 - args_str = read_line(commandfile) - call initialise(cli_params) - call print("got arguments line '"//trim(args_str)//"'") - call register_cli_params(cli_params,.false., infilename, infile_is_list, outfilename, commandfilename, & - mask_str, mask_center, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & - radial_histo, random_samples, n_samples, do_distance_dependence, nth_snapshots, & - sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) - if (.not. param_read_line(cli_params, trim(args_str), ignore_unknown = .true.)) then - call print_usage() - call system_abort("could not parse argument line "//arg_line_no//" from file '"//trim(commandfilename//"'")) - end if - call finalise(cli_params) - endif - - have_params = .true. - do while (have_params) - call print("infile " // trim(infilename) // " infile_is_list " // infile_is_list) - call print("outfilename " // trim(outfilename)) - call print("decimation " // decimation // " min_time " // min_time // " max_time " // max_time) - call print("AtomMask " // trim(mask_str)) - call print("CentMask " // trim(mask_center)) - call print("radial_histo " // radial_histo) - if (radial_histo) then - do i1 = 1, 3 - if (n_bins(i1) < 1) n_bins(i1) = 1 - end do - call print("bin_width(1,2,3) "//bin_width(1)//" "//bin_width(2)//" "//bin_width(3)& - //" n_bins(1,2,3) " // n_bins(1)//" "//n_bins(2)//" "//n_bins(3)) - call print("random_samples " // random_samples) - if (random_samples) then - call print("n_samples " // n_samples(1)) - else - call print("n_theta " // n_samples(1) // " n_phi " // n_samples(2)) - endif - else - call print("min_p " // min_p) - call print("bin_width " // bin_width // " n_bins " // n_bins) - endif - call print("gaussian " // gaussian_smoothing // " sigma " // gaussian_sigma // " angle_sigma " // gaussian_angle_sigma // " sampling_sigma " // sampling_sigma) - call print("do_distance_dependence " // do_distance_dependence) - call print("nth_snapshots " // nth_snapshots) - call print("sort_Time " // sort_Time // " no_Time_dups " // no_Time_dups) - call print("mean " // mean // " mean_decorrelation_time " // mean_decorrelation_time) - call print("autocorrelation " // autocorrelation // " autocorrelation_max_lag " // autocorrelation_max_lag) - - call print("Calculating angle distributions") - call calc_histos(histo_raw, n_histos, min_p, bin_width, n_bins, structure_ll, mean_decorrelation_time, & - gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & - radial_histo, random_samples, n_samples, mask_str, mask_center, do_distance_dependence, nth_snapshots) - - call initialise(outfile, outfilename, OUTPUT) - - if (autocorrelation) then - call print("Calculating autocorrelations") - allocate(autocorr(n_bins(1),n_bins(2),n_bins(3),autocorrelation_max_lag+1)) - autocorr = autocorrelation_3array(histo_raw(:,:,:,1:n_histos), max_lag=autocorrelation_max_lag) - - call print("Printing autocorrelations") - call print("# Autocorrelation", file=outfile) - do i_lag=0, autocorrelation_max_lag - call print(i_lag // " " // reshape(autocorr(1:n_bins(1),1:n_bins(2),1:n_bins(3),i_lag+1), & - (/ n_bins(1)*n_bins(2)*n_bins(3) /)), file=outfile) - end do - endif - - if (mean) then - if (autocorrelation) then - call print("", file=outfile) - call print("", file=outfile) - endif - allocate(histo_mean(n_bins(1), n_bins(2), n_bins(3))) - allocate(histo_var(n_bins(1), n_bins(2), n_bins(3))) - call calc_mean_var_3array(histo_raw(:,:,:,1:n_histos), histo_mean, histo_var) - - if (radial_histo) then - call print("# O--H-O angles (#/rad) ", file=outfile) - call print("# r mean var n_samples", file=outfile) - if(bin_width(1) == 0.0_dp) then - if(n_bins(1) .ne. 1) then - m_bin_width = PI/real(n_bins(1),dp) - else - m_bin_width = 0.0_dp - end if - else - m_bin_width = bin_width(1) - end if - do i3=1, n_bins(3) - do i1=1, n_bins(1) - do i2=1, n_bins(2) - !call print(PI-(bin_width(1)*(real(i1,dp)-0.5)) // " " // (1.8_dp+(bin_width(2)*(real(i2,dp)-0.5))) // " " & - ! //(bin_width(3)*(real(i3,dp)-0.5))// " " & - ! // histo_raw(i1, i2, i3, 1) // " " //n_histos, file=outfile) - call print(PI-(m_bin_width*(real(i1,dp)-0.5)) // " " // (1.8_dp+(bin_width(2)*(real(i2,dp)-0.5))) // " " & - //(bin_width(3)*(real(i3,dp)-0.5))// " " & - // histo_mean(i1, i2, i3) // " " // histo_var(i1, i2, i3)// " " //n_histos, file=outfile) - end do - call print('',file=outfile) - end do - end do - else - call print("# Density (#/vol)", file=outfile) - call print("# x y z mean var n_samples", file=outfile) - do i1=1,n_bins(1) - do i2=1,n_bins(2) - do i3=1,n_bins(3) - call print( (min_p+bin_width*(/ i1-0.5_dp, i2-0.5_dp, i3-0.5_dp /)) // & - " " // histo_mean(i1, i2, i3) // & - " " // histo_var(i1, i2, i3) // " " // n_histos, file=outfile) - end do - call print('', file=outfile) - end do - call print('', file=outfile) - end do - endif - end if - - call finalise(outfile) - - if (allocated(histo_raw)) deallocate(histo_raw) - if (allocated(autocorr)) deallocate(autocorr) - if (allocated(histo_mean)) deallocate(histo_mean) - if (allocated(histo_var)) deallocate(histo_var) - - if (len_trim(commandfilename) == 0) then - have_params = .false. - else - arg_line_no = arg_line_no + 1 - args_str = read_line(commandfile, status=status) - if (status == 0) then - call print("got arguments line '"//trim(args_str)//"'") - call initialise(cli_params) - call register_cli_params(cli_params,.false., infilename, infile_is_list, outfilename, commandfilename, & - mask_str, mask_center, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & - radial_histo, random_samples, n_samples, do_distance_dependence, nth_snapshots, & - sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) - if (.not. param_read_line(cli_params, trim(args_str), ignore_unknown = .true.)) then - call print_usage() - call system_abort("could not parse argument line "//arg_line_no//" from file '"//trim(commandfilename//"'")) - end if - call finalise(cli_params) - else - have_params = .false. - endif - endif - - end do - - call system_finalise() - -contains - - subroutine print_usage() - - character(len=1024) my_exec_name - - if (EXEC_NAME == "") then - my_exec_name="" - else - my_exec_name=EXEC_NAME - endif - - call print("Usage: " // trim(my_exec_name)//" infile=filename [infile_is_list=logical(F)]", PRINT_ALWAYS) - call print(" outfile=filename [commandfile=filename()] [AtomMask=species()] [min_p={x y z}]", PRINT_ALWAYS) - call print(" bin_width={x y z}(y,z ignored for radial_histo) n_bins={nx ny nz}(y,z ignored for radial_histo)", PRINT_ALWAYS) - call print(" [mean=logical(T)] [mean_decorrelation_time=t(0.0)]", PRINT_ALWAYS) - call print(" [autocorrelation=logical(F)] [autocorrelation_max_lag=N(10000)]", PRINT_ALWAYS) - call print(" [decimation=n(1)] [min_time=t(-1.0)] [max_time=t(-1.0)]", PRINT_ALWAYS) - call print(" [gaussian=logical(F)(always true for radial_histo)] [sigma=s(1.0)] [radial_histo=logical(F)]", PRINT_ALWAYS) - call print(" [random_samples=logical(F)(radial_histo only)] [n_samples={2 4})(component 2 ignored for random)]", PRINT_ALWAYS) - call print(" [sort_Time(F)] [no_Time_dups(F)]", PRINT_ALWAYS) - call print(" [quiet=logical(F)]", PRINT_ALWAYS) - end subroutine print_usage - - subroutine register_cli_params(cli_params, initial, infilename, infile_is_list, outfilename, commandfilename, & - mask_str, mask_center, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & - radial_histo, random_samples, n_samples, do_distance_dependence, nth_snapshots, & - sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) - type(Dictionary), intent(inout) :: cli_params - logical, intent(in) :: initial - character(len=*), intent(inout) :: infilename - logical, intent(inout) :: infile_is_list - character(len=*), intent(inout) :: outfilename - character(len=*), intent(inout) :: commandfilename - character(len=*), intent(inout) :: mask_str - character(len=*), intent(inout) :: mask_center - real(dp), intent(inout) :: min_p(3), bin_width(3) - integer, intent(inout) :: n_bins(3), decimation - real(dp), intent(inout) :: min_time, max_time - logical, intent(inout) :: gaussian_smoothing - real(dp), intent(inout) :: gaussian_sigma - real(dp), intent(inout) :: gaussian_angle_sigma - real(dp), intent(inout) :: sampling_sigma - logical, intent(inout) :: radial_histo - logical, intent(inout) :: random_samples - logical, intent(inout) :: do_distance_dependence - integer, intent(inout) :: nth_snapshots - integer, intent(inout) :: n_samples(2) - logical, intent(inout) :: sort_Time, no_Time_dups - logical, intent(inout) :: mean - real(dp), intent(inout) :: mean_decorrelation_time - logical, intent(inout) :: autocorrelation - integer, intent(inout) :: autocorrelation_max_lag - logical, intent(inout) :: quiet - character(len=STRING_LENGTH) :: t_field - - - if (initial) then - call param_register(cli_params, 'infile', param_mandatory, infilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'infile_is_list', 'F', infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'outfile', 'stdout', outfilename, help_string="No help yet. This source file was $LastChangedBy$") - mask_str = "" - mask_center = "" - commandfilename = "" - call param_register(cli_params, 'commandfile', "", commandfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'AtomMask', "O", mask_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'CentMask', "O", mask_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_p', "0.0 0.0 0.0", min_p, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'bin_width', PARAM_MANDATORY, bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'n_bins', PARAM_MANDATORY, n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'gaussian', 'F', gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sigma', '0.0', gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'do_distance_dependence', 'F', do_distance_dependence, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'nth_snapshots', '1', nth_snapshots, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'angle_sigma', '0.0', gaussian_angle_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sampling_sigma', '0.0', sampling_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'radial_histo', 'F', radial_histo, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'random_samples', 'F', random_samples, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'n_samples', '2 4', n_samples, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sort_Time', 'F', sort_Time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'no_Time_dups', 'F', no_Time_dups, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'mean', 'T', mean, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'mean_decorrelation_time', '0.0', mean_decorrelation_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'autocorrelation', 'F', autocorrelation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'autocorrelation_max_lag', '10000', autocorrelation_max_lag, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'quiet', 'F', quiet, help_string="No help yet. This source file was $LastChangedBy$") - else - t_field=infilename - call param_register(cli_params, 'infile', trim(t_field), infilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'infile_is_list', ""//infile_is_list, infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") - t_field=outfilename - call param_register(cli_params, 'outfile', trim(t_field), outfilename, help_string="No help yet. This source file was $LastChangedBy$") - t_field=commandfilename - call param_register(cli_params, 'commandfile', trim(t_field), commandfilename, help_string="No help yet. This source file was $LastChangedBy$") - t_field=mask_str - t_field=mask_center - call param_register(cli_params, 'AtomMask', trim(t_field), mask_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'CentMask', trim(t_field), mask_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_p', ""//min_p, min_p, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'bin_width', ""//bin_width, bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'n_bins', ""//n_bins, n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_time', ""//min_time, min_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'max_time', ""//max_time, max_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'gaussian', ""//gaussian_smoothing, gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sigma', ""//gaussian_sigma, gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'do_distance_dependence', ""//do_distance_dependence, do_distance_dependence, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'nth_snapshots', ""//nth_snapshots, nth_snapshots, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'angle_sigma', ""//gaussian_angle_sigma, gaussian_angle_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sampling_sigma', ""//sampling_sigma, sampling_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'radial_histo', ""//radial_histo, radial_histo, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'random_samples', ""//random_samples, random_samples, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'n_samples', '2 4', n_samples, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'mean', ""//mean, mean, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'mean_decorrelation_time', ""//mean_decorrelation_time, mean_decorrelation_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'autocorrelation', ""//autocorrelation, autocorrelation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'autocorrelation_max_lag', ""//autocorrelation_max_lag, autocorrelation_max_lag, help_string="No help yet. This source file was $LastChangedBy$") - endif - end subroutine register_cli_params - - function autocorrelation_scalar(v, max_lag) result(autocorrelation) - real(dp), intent(in) :: v(:) - integer, intent(in) :: max_lag - real(dp) :: autocorrelation(max_lag) - - integer :: lag, i - real(dp) :: t_sum, mean - integer :: nt - - nt = size(v,1) - - mean = sum(v)/real(nt,dp) - do lag=1, max_lag - t_sum = 0.0_dp - do i=1, nt-lag - t_sum = t_sum + (v(i)-mean)*(v(i+lag)-mean) - end do - autocorrelation(lag) = t_sum/real(nt-lag,dp) - end do - - end function autocorrelation_scalar - - function autocorrelation_3array(v, max_lag) result(autocorrelation) - real(dp), intent(in) :: v(:,:,:,:) - integer, intent(in) :: max_lag - real(dp) :: autocorrelation(size(v,1),size(v,2),size(v,3),max_lag+1) - - integer :: lag, i - real(dp), allocatable :: t_sum(:,:,:), mean(:,:,:) - integer :: n1, n2, n3, nt - - n1 = size(v,1) - n2 = size(v,2) - n3 = size(v,3) - nt = size(v,4) - allocate(t_sum(n1,n2,n3), mean(n1,n2,n3)) - - mean = sum(v,4)/real(nt,dp) - do lag=0, max_lag - t_sum = 0.0_dp - do i=1, nt-lag - t_sum(1:n1,1:n2,1:n3) = t_sum(1:n1,1:n2,1:n3) + (v(1:n1,1:n2,1:n3,i)-mean)*(v(1:n1,1:n2,1:n3,i+lag)-mean) - end do - autocorrelation(1:n1,1:n2,1:n3,lag+1) = t_sum(1:n1,1:n2,1:n3)/real(nt-lag,dp) - end do - - deallocate(t_sum, mean) - - end function autocorrelation_3array - - subroutine calc_histos(histo_count, n_histos, min_p, bin_width, n_bins, structure_ll, interval, gaussian, & - gaussian_sigma, gaussian_angle_sigma, sampling_sigma, radial_histo, & - random_samples, n_samples, mask_str, mask_center, do_distance_dependence, nth_snapshots) - real(dp), intent(inout), allocatable :: histo_count(:,:,:,:) - integer, intent(out) :: n_histos - real(dp), intent(in) :: min_p(3), bin_width(3) - integer, intent(in) :: n_bins(3) - type(atoms_ll), intent(in) :: structure_ll - real(dp), intent(in) :: interval - logical, intent(in) :: gaussian - real(dp), intent(in) :: gaussian_sigma - real(dp), intent(in) :: gaussian_angle_sigma - real(dp), intent(in) :: sampling_sigma - logical, intent(in) :: radial_histo - logical :: random_samples - integer :: n_samples(2) - character(len=*), optional, intent(in) :: mask_str - character(len=*), optional, intent(in) :: mask_center - logical, intent(in) :: do_distance_dependence - integer, intent(in) :: nth_snapshots - - real(dp) :: last_time, cur_time - type(atoms_ll_entry), pointer :: entry - logical :: do_this_histo - real(dp), allocatable :: theta(:), phi(:), w(:) - - n_histos = 0 - allocate(histo_count(n_bins(1),n_bins(2),n_bins(3),10)) - histo_count = 0.0_dp - - if (random_samples) then - call calc_samples_random(n_samples(1), theta, phi, w) - else - call calc_samples_grid(n_samples(1), n_samples(2), theta, phi, w) - endif - entry => structure_ll%first - cur_time = -1.0_dp - last_time = -1.0e38_dp - do while (associated(entry)) - do_this_histo = .false. - if (interval > 0.0_dp) then - if (cur_time < last_time) & - call system_abort("calc_histos called with interval="//interval//" > 0, but unsorted sequence: cur_time="// & - cur_time//" < last_time="//last_time) - if (.not. get_value(entry%at%params, "Time", cur_time)) & - call system_abort("calc_histos called with interval="//interval//" > 0, but no Time value in entry") - if ((cur_time .feq. last_time) .or. (cur_time >= last_time+interval)) then - do_this_histo = .true. - if (cur_time >= last_time+interval) last_time = cur_time - endif - else - do_this_histo = .true. - endif - if (do_this_histo) then - ! if (get_value(entry%at%params, "Time", cur_time)) call print("doing histo for config with time " // cur_time) - n_histos = n_histos + 1 - if (mod(n_histos,10) == 0) then - if(mod(n_histos,50) == 0) then - write (mainlog%unit,'(i0)') n_histos - else - write (mainlog%unit,'(a,$)') '|' - end if - else - write(mainlog%unit,'(a,$)') '.' - end if - if (mod(n_histos,1000) == 0) write (mainlog%unit,'(a)') " " - call reallocate_histos(histo_count, n_histos, n_bins) - if (radial_histo) then - call calc_connect(entry%at) - cell_vol = cell_volume(entry%at%lattice) - call accumulate_radial_histo_count(histo_count(:,:,:,n_histos), entry%at, bin_width(1), bin_width(2), bin_width(3), & - n_bins(1), n_bins(2), n_bins(3), & - gaussian, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & - theta, phi, w, mask_str, mask_center, do_distance_dependence) - endif - endif - entry => entry%next - end do - end subroutine calc_histos - - subroutine calc_samples_grid(n_t, n_p, theta, phi, w) - integer, intent(in) :: n_t, n_p - real(dp), allocatable, intent(inout) :: theta(:), phi(:), w(:) - - integer :: t_i, p_i, ii - - if (allocated(theta)) deallocate(theta) - if (allocated(phi)) deallocate(phi) - if (allocated(w)) deallocate(w) - allocate(theta(n_t*n_p)) - allocate(phi(n_t*n_p)) - allocate(w(n_t*n_p)) - - ii = 1 - do t_i=1, n_t - do p_i=1, n_p - phi(ii) = (p_i-1)*2.0_dp*PI/real(n_p,dp) - if (mod(n_t,2) == 0) then - theta(ii) = (t_i-1.5_dp-floor((n_t-1)/2.0_dp))*PI/real(n_t,dp) - else - theta(ii) = (t_i-1-floor((n_t-1)/2.0_dp))*PI/real(n_t,dp) - endif - ! not oversample top and bottom of spehre - w(ii) = cos(theta(ii)) - ii = ii + 1 - end do - end do - w = w / ( (sampling_sigma*sqrt(2.0_dp*PI))**3 * sum(w) ) - end subroutine calc_samples_grid - - subroutine calc_samples_random(n, theta, phi, w) - integer, intent(in) :: n - real(dp), allocatable, intent(inout) :: theta(:), phi(:), w(:) - - integer :: ii - real(dp) :: p(3), p_norm - - if (allocated(theta)) deallocate(theta) - if (allocated(phi)) deallocate(phi) - if (allocated(w)) deallocate(w) - allocate(theta(n)) - allocate(phi(n)) - allocate(w(n)) - - do ii = 1, n - p_norm = 2.0_dp - do while (p_norm > 1.0_dp) - p = 0.0_dp - call randomise(p, 2.0_dp) - p_norm = norm(p) - end do - phi(ii) = atan2(p(2),p(1)) - theta(ii) = acos(p(3)/p_norm) - w(ii) = 1.0_dp - end do - w = w / ( (sampling_sigma*sqrt(2.0_dp*PI))**3 * sum(w) ) - - end subroutine calc_samples_random - - subroutine accumulate_radial_histo_count(histo_count, at, bin_width, dbin_width, sbin_width, n_bins, dn_bins, sn_bins, & - gaussian, gaussian_sigma, gaussian_angle_sigma, sampling_sigma, & - theta, phi, w, mask_str, mask_center, do_distance_dependence) - real(dp), intent(inout) :: histo_count(:,:,:) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: bin_width, dbin_width, sbin_width - integer, intent(in) :: n_bins, dn_bins, sn_bins - logical,intent(in) :: gaussian - real(dp), intent(in) :: gaussian_sigma, gaussian_angle_sigma, sampling_sigma, theta(:), phi(:), w(:) - character(len=*), optional, intent(in) :: mask_str - character(len=*), optional, intent(in) :: mask_center - logical,intent(in) :: do_distance_dependence - - real(dp) :: bin_r, bin_a, bin_s, p(3), dist, r, d, sdist, distw, ang, v1(3), v2(3), m_bin_width - logical, allocatable :: mask_a(:), mask_c(:) - integer at_i, at_j, sample_i, bin_i, bin_j, bin_k, i, k, m - real(dp) :: myNorm, fotPI, oostPI, sina, shell, sample_shell - integer :: myCount, sample_size - real(dp) :: mycent(3) - - if(sbin_width == 0.0_dp) then - sample_size = 1 - else - sample_size = size(theta) - end if - - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - allocate(mask_c(at%N)) - call is_in_mask(mask_c, at, mask_center) - - m = 0 - do i = 1, at%N - if (mask_a(i)) m=m+1 - end do - part_dens=real(m,dp)/cell_vol - - m=0 - do i = 1, at%N - if(mask_c(i)) then - m=m+1 - k=i - end if - end do - - if(m==1) then - mycent=at%pos(:,k) - else - mycent=(/0.0_dp,0.0_dp,0.0_dp/) - end if - - myNorm = 1/(gaussian_angle_sigma*sqrt(2*PI)) - if(bin_width == 0.0_dp) then - if(n_bins .ne. 1) then - m_bin_width = PI/real(n_bins,dp) - else - m_bin_width = 0.0_dp - end if - else - m_bin_width = bin_width - end if - fotPI = (4.0_dp * PI)/3.0_dp - oostPI = 1.0_dp/(sqrt(2.0_dp*PI)) -! ratio of 20/4=5 is bad -! ratio of 20/3=6.66 is bad -! ratio of 20/2.5=8 is borderline (2e-4) -! ratio of 20/2.22=9 is fine (error 2e-5) -! ratio of 20/2=10 is fine - if ( (norm(at%lattice(:,1)) < 9.0_dp*sampling_sigma) .or. & - (norm(at%lattice(:,2)) < 9.0_dp*sampling_sigma) .or. & - (norm(at%lattice(:,3)) < 9.0_dp*sampling_sigma) ) & - call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) - if(.not. do_distance_dependence) then - if(gaussian) then - myCount=0 - do at_i=1, at%N - if(.not. mask_c(at_i)) cycle - myCount = myCount+1 - do bin_i = 1, n_bins !angles - bin_a = PI - (real(bin_i,dp)-0.5)*m_bin_width - do bin_j = 1, dn_bins !distances - bin_r = 1.8_dp +(real(bin_j,dp)-0.5)*dbin_width - shell = fotPI*( (bin_r+1.5_dp*gaussian_sigma)**3 - (max(0.0_dp,(bin_r-1.5_dp*gaussian_sigma)**3)) )*part_dens - do at_j = 1, at%N - if((at_j == at_i) .or. .not. mask_a(at_j)) cycle !(at%Z(at_j) .ne. 8)) cycle - dist = distance_min_image(at,at%pos(:,at_i),at%pos(:,at_j)) - do i = 1, n_neighbours(at,at_j) - k = neighbour(at,at_j,i) - r = 0.0_dp - if(is_nearest_neighbour(at,at_j,i) .and. at%Z(k) == 1) then - d = distance_min_image(at,at%pos(:,at_i),at%pos(:,k)) - if(r == 0.0_dp .or. d < r) then - m = k !select the mth atom (hydrogen) - r = d - end if - end if !nearest neighbour - end do !neighbours of at_j - v1 = at%pos(:,at_i) - at%pos(:,k) - v2 = at%pos(:,at_j) - at%pos(:,k) - ang = angle(v1,v2) - sina = sin(PI-ang) - if(sina .lt. 1.0E-10) sina=1.0E-10 - ang = myNorm*exp(-0.5_dp*((ang-bin_a)/gaussian_angle_sigma)**2) - ang = ang/(2.0*PI*sina) - histo_count(bin_i,bin_j,1) = histo_count(bin_i,bin_j,1) + & - (ang*exp(-0.5_dp*((dist-bin_r)/gaussian_sigma)**2)*( (oostPI/gaussian_sigma) / shell )) - end do !at_j - end do !distances - end do !angles - end do ! at_i - do bin_i=1, n_bins - do bin_j=1, dn_bins - histo_count(bin_i,bin_j,1) = histo_count(bin_i,bin_j,1) / real(myCount,dp) - end do - end do - else if(.not. gaussian) then !use radial bins, weighted down by volume (assuming homogenous density) - myCount = 0 - do at_i=1, at%N - myCount = myCount+1 - if(.not. mask_c(at_i)) cycle - do bin_i = 1, n_bins !angles - bin_a = PI - (real(bin_i,dp)-0.5_dp)*m_bin_width - do bin_j = 1, dn_bins !distances - bin_r = 1.8_dp + ((real(bin_j,dp)-0.5_dp)*dbin_width) - shell = fotPI*((bin_r+0.5_dp*dbin_width)**3 - (bin_r-0.5_dp*dbin_width)**3)*part_dens - do at_j = 1, at%N - if((at_j == at_i) .or. .not.mask_a(at_j)) cycle !(at%Z(at_j) .ne. 8)) cycle - dist = distance_min_image(at,at%pos(:,at_i),at%pos(:,at_j)) - if( (dist > (bin_r-(dbin_width*0.5_dp))) .and. (dist < (bin_r+(dbin_width*0.5_dp))) ) then - do i = 1, n_neighbours(at,at_j) - k = neighbour(at,at_j,i) - r = 0.0_dp - if(is_nearest_neighbour(at,at_j,i) .and. at%Z(k) == 1) then - d = distance_min_image(at,at%pos(:,at_i),at%pos(:,k)) - if(r == 0.0_dp .or. d < r) then - m = k !select the mth atom (hydrogen) - r = d - end if - end if !nearest neighbour - end do !neighbours of at_j - v1 = at%pos(:,at_i) - at%pos(:,k) - v2 = at%pos(:,at_j) - at%pos(:,k) - ang = angle(v1,v2) - sina=sin(PI-ang) - if( (ang > (bin_a-(m_bin_width*0.5_dp))) .and. (ang < (bin_a+(m_bin_width*0.5_dp))) ) then - histo_count(bin_i,bin_j,1) = histo_count(bin_i,bin_j,1) + (1.0_dp/(2.0*PI*sina))/shell - end if !angle bin - end if !distance bin - end do !at_j - end do !distances - end do !angles - end do ! at_i - do bin_i=1, n_bins - do bin_j = 1, dn_bins - histo_count(bin_i,bin_j,1) = histo_count(bin_i,bin_j,1) / real(myCount,dp) - end do - end do - end if !no gaussian smoothing - else !distance dependence - if(gaussian) then - do bin_k = 1, sn_bins - bin_s = (real(bin_k,dp)-0.5_dp)*sbin_width - do at_i=1, at%N - if(.not. mask_c(at_i)) cycle - do sample_i = 1, sample_size - p(1) = mycent(1)+bin_s*cos(theta(sample_i))*cos(phi(sample_i)) - p(2) = mycent(2)+bin_s*cos(theta(sample_i))*sin(phi(sample_i)) - p(3) = mycent(3)+bin_s*sin(theta(sample_i)) - sdist = distance_min_image(at,p,at%pos(:,at_i)) - if( sdist < 3.0_dp*sampling_sigma) then - distw = w(sample_i)*exp(-0.5_dp*(sdist/sampling_sigma)**2) - do bin_i = 1, n_bins !angles - bin_a = PI - (real(bin_i,dp)-0.5)*m_bin_width - do bin_j = 1, dn_bins !distances - bin_r = 1.8_dp +(real(bin_j,dp)-0.5_dp)*dbin_width - shell = fotPI*( (bin_r+1.5_dp*gaussian_sigma)**3 - (max(0.0_dp,(bin_r-1.5_dp*gaussian_sigma)**3)) )*part_dens - do at_j = 1, at%N - if((at_j == at_i) .or. .not.mask_a(at_j)) cycle !.or. (at%Z(at_j) .ne. 8)) cycle - dist = distance_min_image(at,at%pos(:,at_i),at%pos(:,at_j)) - do i = 1, n_neighbours(at,at_j) - k = neighbour(at,at_j,i) - r = 0.0_dp - if(is_nearest_neighbour(at,at_j,i) .and. at%Z(k) == 1) then - d = distance_min_image(at,at%pos(:,at_i),at%pos(:,k)) - if(r == 0.0_dp .or. d < r) then - m = k !select the mth atom (hydrogen) - r = d - end if - end if !nearest neighbour - end do !neighbours of at_j - v1 = at%pos(:,at_i) - at%pos(:,k) - v2 = at%pos(:,at_j) - at%pos(:,k) - ang = angle(v1,v2) - sina=sin(PI-ang) - if(sina .lt. 1.0E-10) sina=1.0E-10 - ang = myNorm*exp(-0.5_dp*((ang-bin_a)/gaussian_angle_sigma)**2) - ang = ang/(2.0_dp*PI*sina) - histo_count(bin_i,bin_j,bin_k) = histo_count(bin_i,bin_j,bin_k) + & - (ang*exp(-0.5_dp*((dist-bin_r)/gaussian_sigma)**2)*( (oostPI/gaussian_sigma) / shell )*distw) - end do !at_j - end do !distances - end do !angles - end if - end do !samples - end do ! at_i - end do !sampling distances - else !distance dependence, but not gaussian - myCount = 0 - do bin_k = 1, sn_bins - bin_s = (real(bin_k,dp)-0.5_dp)*sbin_width - sample_shell = fotPI*((bin_s+0.5_dp*sbin_width)**3 - (bin_s-0.5_dp*sbin_width)**3)*part_dens - do at_i=1, at%N - !do at_i=991, 991 - if(.not. mask_c(at_i)) cycle - !if(at%Z(at_i) .ne. 8) cycle !for oxygens only - sdist = distance_min_image(at,(/0.0_dp,0.0_dp,0.0_dp/),at%pos(:,at_i)) - if( sdist > (bin_s-0.5_dp*sbin_width) .and. sdist < (bin_s+0.5_dp*sbin_width)) then - do bin_i = 1, n_bins !angles - bin_a = PI - (real(bin_i,dp)-0.5_dp)*m_bin_width - do bin_j = 1, dn_bins !distances - bin_r = 1.8_dp + ((real(bin_j,dp)-0.5_dp)*dbin_width) - shell = fotPI*((bin_r+0.5_dp*dbin_width)**3 - (bin_r-0.5_dp*dbin_width)**3)*part_dens - do at_j = 1, at%N - if((at_j == at_i) .or. .not.mask_a(at_j)) cycle !(at%Z(at_j) .ne. 8)) cycle - dist = distance_min_image(at,at%pos(:,at_i),at%pos(:,at_j)) - if( (dist > (bin_r-(dbin_width*0.5_dp))) .and. (dist < (bin_r+(dbin_width*0.5_dp))) ) then - do i = 1, n_neighbours(at,at_j) - k = neighbour(at,at_j,i) - r = 0.0_dp - if(is_nearest_neighbour(at,at_j,i) .and. at%Z(k) == 1) then - d = distance_min_image(at,at%pos(:,at_i),at%pos(:,k)) - if(r == 0.0_dp .or. d < r) then - m = k !select the mth atom (hydrogen) - r = d - end if - end if !nearest neighbour - end do !neighbours of at_j - v1 = at%pos(:,at_i) - at%pos(:,k) - v2 = at%pos(:,at_j) - at%pos(:,k) - ang = angle(v1,v2) - sina=sin(PI-ang) - !cosa=cos(PI-ang) - if( (ang > (bin_a-(m_bin_width*0.5_dp))) .and. (ang < (bin_a+(m_bin_width*0.5_dp))) ) then - histo_count(bin_i,bin_j,bin_k) = histo_count(bin_i,bin_j,bin_k) + (1.0_dp/(2.0*PI*sina))/(shell*sample_shell) - end if !angle bin - end if !distance bin - end do !at_j - end do !distances - end do !angles - end if !if at_i is in sample_shell - end do ! at_i - end do !bin_k - end if !gaussian in distance dependence - end if - - deallocate(mask_a) - end subroutine accumulate_radial_histo_count - - subroutine is_in_mask(mask_a, at, mask_str) - type(Atoms), intent(in) :: at - logical, intent(out) :: mask_a(at%N) - character(len=*), optional, intent(in) :: mask_str - - integer :: i - integer :: Zmask - type(Table) :: atom_indices - - if (.not. present(mask_str)) then - mask_a = .true. - return - endif - - if (len_trim(mask_str) == 0) then - mask_a = .true. - return - endif - - mask_a = .false. - if (mask_str(1:1)=='@') then - call parse_atom_mask(mask_str,atom_indices) - do i=1, atom_indices%N - mask_a(atom_indices%int(1,i)) = .true. - end do - else if (scan(mask_str,'=')/=0) then - call system_abort("property type mask not supported yet") - else - Zmask = Atomic_Number(mask_str) - do i=1, at%N - if (at%Z(i) == Zmask) mask_a(i) = .true. - end do - end if - end subroutine is_in_mask - - subroutine reallocate_histos(histos, n, n_bins) - real(dp), allocatable, intent(inout) :: histos(:,:,:,:) - integer, intent(in) :: n, n_bins(3) - - integer :: new_size - real(dp), allocatable :: t_histos(:,:,:,:) - - if (allocated(histos)) then - if (n <= size(histos,4)) return - allocate(t_histos(size(histos,1),size(histos,2),size(histos,3),size(histos,4))) - t_histos = histos - deallocate(histos) - if (size(t_histos,4) <= 0) then - new_size = 10 - else if (size(t_histos,4) < 1000) then - new_size = 2*size(t_histos,4) - else - new_size = floor(1.25*size(t_histos,4)) - endif - allocate(histos(size(t_histos,1), size(t_histos,2), size(t_histos,3), new_size)) - histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),1:size(t_histos,4)) = & - t_histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),1:size(t_histos,4)) - histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),size(t_histos,4)+1:size(histos,4)) = 0.0_dp - deallocate(t_histos) - else - allocate(histos(n_bins(1), n_bins(2), n_bins(3), n)) - endif - end subroutine reallocate_histos - - subroutine calc_mean_var_3array(a, mean, var) - real(dp), intent(in) :: a(:,:,:,:) - real(dp), intent(out) :: mean(:,:,:) - real(dp), optional, intent(out) :: var(:,:,:) - - integer :: i1, i2, i3, n - - n = size(a,4) - mean = sum(a, 4)/real(n,dp) - if (present(var)) then - do i1=1, size(a,1) - do i2=1, size(a,2) - do i3=1, size(a,3) - var(i1,i2,i3) = sum((a(i1,i2,i3,:)-mean(i1,i2,i3))**2)/real(n,dp) - end do - end do - end do - end if - end subroutine calc_mean_var_3array - -end program angle_distr diff --git a/src/Structure_processors/clean_traj.f95 b/src/Structure_processors/clean_traj.f95 deleted file mode 100644 index d599deb2e6..0000000000 --- a/src/Structure_processors/clean_traj.f95 +++ /dev/null @@ -1,117 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Reads a sequence of configs, optionally with decimation, min_time, max_time, and sorting -! by Time as well as eliminating duplicates (basically a driver for atoms_ll_read_xyz_filename()) - -program clean_traj -use libatoms_module -implicit none - - type(Dictionary) :: cli_params - character(len=STRING_LENGTH) :: infilename - logical :: infile_is_list - character(len=STRING_LENGTH) :: outfilename - type(CInOutput) :: outfile - integer :: decimation - real(dp) :: min_time, max_time - logical :: sort_Time, no_Time_dups, quiet, no_compute_index - real(dp) :: scale_lattice, scale_pos - character(len=STRING_LENGTH) :: properties - - type(Atoms_ll) :: structure_ll - type(Atoms_ll_entry), pointer :: entry - - call system_initialise(PRINT_NORMAL) - - call initialise(cli_params) - call param_register(cli_params, 'infile', param_mandatory, infilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'infile_is_list', 'F', infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'outfile', 'stdout', outfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sort_Time', 'F', sort_Time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'no_Time_dups', 'F', no_Time_dups, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'quiet', 'F', quiet, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'scale_lattice', '1.0', scale_lattice, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'scale_pos', '1.0', scale_pos, help_string="No help yet. This source file was $LastChangedBy$") - properties = "" - call param_register(cli_params, 'properties', 'species:pos:Z', properties, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - call print_usage() - call system_abort('could not parse argument line') - end if - call finalise(cli_params) - - call print("infile " // trim(infilename) // " infile_is_list " // infile_is_list) - call print("outfilename " // trim(outfilename)) - call print("decimation " // decimation // " min_time " // min_time // " max_time " // max_time) - call print("sort_Time " // sort_Time // " no_Time_dups " // no_Time_dups // " quiet " // quiet) - call print("scale_lattice " // scale_lattice // " scale_pos " // scale_pos) - - no_compute_index=.false. - if ((.not. sort_Time) .and. (.not. no_Time_dups)) no_compute_index=.true. - - call read_xyz(structure_ll, infilename, infile_is_list, decimation, min_time, max_time, sort_Time, no_Time_dups, quiet, no_compute_index, properties=properties) - - call initialise(outfile, outfilename, action=OUTPUT) - entry => structure_ll%first - do while (associated(entry)) - if (scale_lattice /= 1.0_dp) entry%at%lattice = scale_lattice * entry%at%lattice - if (scale_pos /= 1.0_dp) entry%at%pos = scale_pos * entry%at%pos - call write(outfile, entry%at) - entry => entry%next - end do - call finalise(outfile) - - call system_finalise() - -contains - - subroutine print_usage() - - character(len=1024) my_exec_name - - if (EXEC_NAME == "") then - my_exec_name="" - else - my_exec_name=EXEC_NAME - endif - - call print("Usage: " // trim(my_exec_name)//" infile=filename [infile_is_list=logical(F)]", PRINT_ALWAYS) - call print(" outfile=filename [decimation=n(1)]", PRINT_ALWAYS) - call print(" [min_time=t(-1.0)] [max_time=t(-1.0)]", PRINT_ALWAYS) - call print(" [sort_Time(F)] [no_Time_dups(F)] [quiet(F)]", PRINT_ALWAYS) - call print(" [scale_lattice=scale(1.0)] [scale_pos=scale(1.0)]", PRINT_ALWAYS) - call print(" [properties=prop1:prop2...(species:pos:Z,use blank for all props.)]", PRINT_ALWAYS) - end subroutine print_usage - -end program clean_traj diff --git a/src/Structure_processors/convert.f95 b/src/Structure_processors/convert.f95 deleted file mode 100644 index 16ac5d914e..0000000000 --- a/src/Structure_processors/convert.f95 +++ /dev/null @@ -1,72 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -#include "error.inc" - -program convert - -use libAtoms_module -use libatoms_misc_utils_module - -implicit none - - type(Atoms) at - type(CInOutput) :: infile, outfile - character(len=STRING_LENGTH) :: infilename, outfilename - integer error - - call system_initialise(verbosity=PRINT_SILENT) - - if (NUM_COMMAND_ARGS == 2) then - infilename = COMMAND_ARG(1) - outfilename = COMMAND_ARG(2) - else if(NUM_COMMAND_ARGS == 0) then - infilename = 'stdin' - outfilename = 'stdout' - else - call system_abort("Usage: convert [ infile.{xyz|nc} outfile.{xyz|nc} ]") - end if - - call initialise(infile, trim(infilename)) - call initialise(outfile, trim(outfilename), action=OUTPUT) - - do - call read(at, infile, error=error) - if (error /= 0) then - if (error == ERROR_IO_EOF) then - exit - else - HANDLE_ERROR(error) - endif - endif - call print(at) - call write(at, outfile) - end do - call system_finalise() -end program convert diff --git a/src/Structure_processors/coordination_number.f95 b/src/Structure_processors/coordination_number.f95 deleted file mode 100644 index eb2639b689..0000000000 --- a/src/Structure_processors/coordination_number.f95 +++ /dev/null @@ -1,300 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!Program to calculate coordination number as a fn of time, if given is -! -- an XYZ file with the coordinates, -! -- the atomic number of the atoms in the coordination sphere -! -- the atom number of the central atom -! and the output name specified. -!Optionally restarts can be taken into account by printing synchronised -! with the restart frequency (e.g. restart_frequency=20). -!Optionally appends the output (of restart files) to the same outfile (e.g. append_output=T). -! -!A Fermi distribution is used to smooth the coordination number -!M. Sprik, Far.Disc. 110, 437-445 (1998) -! -program coordination_number - - use libatoms_module - - implicit none - - type(Atoms) :: at - type(CInoutput) :: coord_file - type(InOutput) :: out_file - character(len=STRING_LENGTH), allocatable :: output_lines(:) - integer :: lines_used - integer :: iframe, step_nr - real(dp) :: time_passed - integer :: i - - !Input parameters - type(Dictionary) :: params_in - character(len=STRING_LENGTH) :: coord_filename - character(len=STRING_LENGTH) :: out_filename - integer :: last_frame - real(dp) :: time_step - integer :: restart_every - logical :: append_output - logical :: skip_extra_firsts -real(dp) :: dist, coord_num -logical, allocatable :: mask_a(:) -character(STRING_LENGTH) :: mask_str -real(dp) :: kappa, l_cutoff -integer :: iatom, center_atom -logical :: no_smoothing - - -! call system_initialise(verbosity=ANALYSIS,enable_timing=.true.) -! call system_initialise(verbosity=VERBOSE,enable_timing=.true.) - call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) - call system_timer('program') - - !INPUT - call initialise(params_in) - call param_register(params_in, 'infile' , PARAM_MANDATORY, coord_filename , help_string="input XYZ" ) - call param_register(params_in, 'outfile' , PARAM_MANDATORY, out_filename , help_string="output file" ) - mask_str='' - call param_register(params_in, 'neighbour_mask' , '' , mask_str , help_string="neighbour atom in the coordination sphere" ) - call param_register(params_in, 'center_mask' , '0' , center_atom , help_string="center atom, around which the coordination number is calculated" ) - call param_register(params_in, 'kappa' , '-1.0' , kappa , help_string="smoothing by default: 1/(exp(kappa*(d-cutoff))+1)" ) - call param_register(params_in, 'cutoff' , PARAM_MANDATORY, l_cutoff , help_string="cutoff of the coordination sphere" ) - call param_register(params_in, 'last_frame' , '0' , last_frame , help_string="last frame to process (0=all)" ) - call param_register(params_in, 'time_step' , '0.0' , time_step , help_string="time step" ) - call param_register(params_in, 'restart_every' , '1' , restart_every , help_string="to be consistent with the restart frequency" ) - call param_register(params_in, 'append_output' , 'F' , append_output , help_string="do not overwrite output file" ) - call param_register(params_in, 'skip_extra_firsts' ,'F' , skip_extra_firsts, help_string="QMMM_md_buf prints the first time step twice" ) - call param_register(params_in, 'no_smoothing' ,'F' , no_smoothing , help_string="whether to use smoothing, or an abrupt cutoff" ) - - if (.not. param_read_args(params_in)) then - call print("coordination_number infile outfile cutoff [center_atom] [neighbour_atom] [kappa=-1.0] [last_frame=0] [time_step=0.0] [restart_every=1] [append_output=F] [skip_extra_firsts=F] [no_smoothing=F]", PRINT_ALWAYS) - call system_abort('could not parse argument line') - end if - - call finalise(params_in) - - if (kappa<0) call system_abort("kappa<0") - if (l_cutoff<0) call system_abort("cutoff<0") - - !PRINT INPUT PARAMETERS - call print('Run parameters:') - call print(' coord_file '// trim(coord_filename) ) - call print(' outfile '// trim(out_filename) ) - call print(' neighbour_mask '// trim(mask_str) ) - call print(' center_mask '// center_atom ) - call print(' last_frame '// last_frame ) - call print(' kappa '// kappa ) - call print(' cutoff '// l_cutoff ) - call print(' time_step '// time_step ) - call print(' restart_every '// restart_every//' steps' ) - if (restart_every/=1) call print(' Prints after every '//restart_every//' steps, synchronised with the restart frequency.') - call print(' append_output '//append_output) - if (append_output) then - call print(" Will not overwrite out_file (appending probably restart).") - else - call print(" Will overwrite out_file!!") - endif - call print(' skip_extra_firsts '//skip_extra_firsts//" ONLY FOR cp2k_units=F !") - call print('---------------------------------------') - call print('') - - - !Read coordinates - call print('Reading in the coordinates from file '//trim(coord_filename)//'...') - call initialise(coord_file, coord_filename, action=INPUT) - call print('Number of frames '//coord_file%n_frame) - - if (last_frame/=0) then - last_frame = min(last_frame, coord_file%n_frame) - else - last_frame = coord_file%n_frame - endif - call print('Last frame to be processed '//last_frame) - - !open output file, append if required - if (append_output) then - call initialise(out_file, out_filename, action=OUTPUT,append=.true.) - else - call initialise(out_file, out_filename, action=OUTPUT,append=.false.) - call print("# Step Nr. Time[fs] n_coord("//trim(mask_str)//") ((r_cut="//l_cutoff//"))", file=out_file) - endif - - step_nr = 0 - - !allocate printing buffer - allocate(output_lines(restart_every)) - lines_used = 0 - - do iframe = 0, last_frame-1 - - call read(coord_file, at, frame=iframe) - - write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',(iframe+1) - - if (iframe==0) then - if (skip_extra_firsts) cycle !skip very first without force information - endif - if (iframe==1) then - if (skip_extra_firsts .and. append_output) cycle !skip the overlapping second for the restarts - endif - - !get Step_nr and Time - if (.not.get_value(at%params,"i",step_nr)) then - step_nr = step_nr + 1 - endif - if (.not.get_value(at%params,"time",time_passed)) then - time_passed = step_nr * time_step - endif - - if (center_atom<1.or.center_atom>at%N) call system_abort("center_atom="//center_atom//" is <0 or >"//at%N) - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - - coord_num=0._dp - !calc coordination number - do iatom=1,at%N - if (iatom==center_atom) cycle - if (.not.mask_a(iatom)) cycle - dist = distance_min_image(at,center_atom,iatom) - if (no_smoothing) then - if (dist [] [] [] -program density - - use libatoms_module - - implicit none - - type(Atoms) :: at - type(InOutput) :: xyzfile, datafile, datafile2 - integer :: frame_count, frames_processed - integer :: status - integer :: i - - !Input - type(Dictionary) :: params_in - character(STRING_LENGTH) :: xyzfilename, datafilename - integer :: numbins - integer :: IO_Rate - integer :: decimation - integer :: from, to - logical :: Gaussian_smoothing - real(dp) :: Gaussian_sigma - - !Cell and subcell parameters - real(dp) :: a, b, c - real(dp) :: alpha, beta, gamma - real(dp) :: cellvol - - !Density binning - real(dp) :: t(3), r(3) - integer :: box_a, box_b, box_c - real(dp), allocatable :: mass_cuml(:,:,:) - !Gaussian density binning - real(dp), dimension(3) :: increment - real(dp) :: x_min_bin, y_min_bin, z_min_bin - real(dp) :: x_min, y_min, z_min - real(dp) :: x_max, y_max, z_max - real(dp), dimension(3) :: Gaussian_centre - integer :: j,k,l - integer :: bin_j,bin_k,bin_l - - call system_initialise(PRINT_SILENT) - call verbosity_push(PRINT_NORMAL) - - call initialise(params_in) - call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'NumBins', param_mandatory, numbins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'from', '0', from, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(params_in)) then - if (EXEC_NAME == '') then - call print_usage - else - call print_usage(EXEC_NAME) - end if - call system_abort('could not parse argument line') - end if - call finalise(params_in) - - call print('Run_parameters: ') - call print('==================================') - call print(' Input file: '//trim(xyzfilename)) - call print(' Output file: '//trim(datafilename)) - call print(' NumBins: '//numbins) - call print(' decimation: '//decimation) - if (decimation == 1) then - call print(' Processing every frame') - else - write(line,'(a,i0,a,a)')' Processing every ',decimation,th(decimation),' frame' - call print(line) - end if - call print(' from Frame: '//from) - call print(' to Frame: '//to) - call print(' IO_Rate: '//IO_Rate) - call print(' Gaussians: '//Gaussian_smoothing) - if (Gaussian_smoothing) call print(' sigma: '//round(Gaussian_sigma,3)) - call print('==================================') - call print('') - - call initialise(xyzfile,trim(xyzfilename),action=INPUT) - if (Gaussian_smoothing.and.(Gaussian_sigma.le.0._dp)) call system_abort('sigma must be > 0._dp') - - call read_xyz(at,xyzfile,status=status) - call get_lattice_params(at%lattice,a,b,c,alpha,beta,gamma) - - allocate( mass_cuml(numbins,numbins,numbins) ) - - mass_cuml = 0.0_dp - - call print('grid size '//numbins//'x'//numbins//'x'//numbins) - - cellvol = abs(matrix3x3_det(at%lattice)) / real(numbins*numbins*numbins,dp) - - call print('Subcell volume = '//round(cellvol,6)//'A^3') - - call print('Reading data...') - - frame_count = 0 - frames_processed = 0 - - do - - if (status/=0) exit - - !Skip ahead (decimation-1) frames in the xyz file - frame_count = frame_count + 1 - do i = 1, (decimation-1) - call read_xyz(xyzfile,status) - if (status/=0) exit - frame_count = frame_count + 1 - end do - - write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',frame_count - - if (frame_count.gt.from) then - if ((frame_count.gt.to).and.(to.ne.0)) exit - call calc_connect(at) - call map_into_cell(at) - - !spatial binning of the cell - if (Gaussian_smoothing) then - increment = at%lattice .mult. (/1.0_dp/real(numbins,dp),1.0_dp/real(numbins,dp),1.0_dp/real(numbins,dp)/) - x_min_bin = -0.5*at%lattice(1,1) - y_min_bin = -0.5*at%lattice(2,2) - z_min_bin = -0.5*at%lattice(3,3) - endif - - do i = 1, at%N - - !calculate bin / central bin of the Gaussian - t = at%g .mult. at%pos(:,i) - box_a = floor(real(numbins,dp) * (t(1)+0.5_dp)) + 1 - box_b = floor(real(numbins,dp) * (t(2)+0.5_dp)) + 1 - box_c = floor(real(numbins,dp) * (t(3)+0.5_dp)) + 1 - - if (.not.Gaussian_smoothing) then - - mass_cuml(box_a,box_b,box_c) = mass_cuml(box_a,box_b,box_c) + ElementMass(at%Z(i)) - - else - - !binning is centred around the Gaussian - Gaussian_centre = at%pos(1:3,i) - - do j=int(real(box_a,dp)+real(numbins,dp)/2._dp)-numbins+1,int(real(box_a,dp)+real(numbins,dp)/2._dp) - - !calculate bin in the range of [1:numbins] - bin_j = mod(j+numbins,numbins) - if (bin_j.eq.0) bin_j = numbins - - do k=int(real(box_b,dp)+real(numbins,dp)/2._dp)-numbins+1,int(real(box_b,dp)+real(numbins,dp)/2._dp) - - !calculate bin in the range of [1:numbins] - bin_k = mod(k+numbins,numbins) - if (bin_k.eq.0) bin_k = numbins - - do l=int(real(box_c,dp)+real(numbins,dp)/2._dp)-numbins+1,int(real(box_c,dp)+real(numbins,dp)/2._dp) - - !calculate bin in the range of [1:numbins] - bin_l = mod(l+numbins,numbins) - if (bin_l.eq.0) bin_l = numbins - - !spatial coordinates of this bin - x_min = x_min_bin + real(j-1,dp)*increment(1) - y_min = y_min_bin + real(k-1,dp)*increment(2) - z_min = z_min_bin + real(l-1,dp)*increment(3) - x_max = x_min + increment(1) - y_max = y_min + increment(2) - z_max = z_min + increment(3) - - !add the integral of the Gaussian on the range [x_min,y_min,z_min:x_max,y_max,z_max] - mass_cuml(bin_j,bin_k,bin_l) = mass_cuml(bin_j,bin_k,bin_l) + ElementMass(at%Z(i)) * & - 0.5_dp * ( - erf((x_min-Gaussian_centre(1))/(Gaussian_sigma*sqrt(2.0_dp))) + erf((x_max-Gaussian_centre(1))/(Gaussian_sigma*sqrt(2.0_dp))) ) * & - 0.5_dp * ( - erf((y_min-Gaussian_centre(2))/(Gaussian_sigma*sqrt(2.0_dp))) + erf((y_max-Gaussian_centre(2))/(Gaussian_sigma*sqrt(2.0_dp))) ) * & - 0.5_dp * ( - erf((z_min-Gaussian_centre(3))/(Gaussian_sigma*sqrt(2.0_dp))) + erf((z_max-Gaussian_centre(3))/(Gaussian_sigma*sqrt(2.0_dp))) ) - - enddo - enddo - enddo - - endif - end do - - if (mod(frame_count-from,IO_RATE)==0) call write_data - endif - - !Try to read another frame - call read_xyz(at,xyzfile,status=status) - - if (status.ne.0) then - exit - endif - - end do - - call print('') - call write_data - call print('Read '//frame_count//' frames') - - !Free up memory - call finalise(at) - call finalise(xyzfile) - - deallocate(mass_cuml) - - call print('Finished.') - -! call verbosity_pop - call system_finalise - -contains - - subroutine print_usage(name) - - character(*), optional, intent(in) :: name - - if (present(name)) then - write(line,'(3a)')'Usage: ',trim(name),' xyzfile datafile NumBins [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' - else - write(line,'(a)')'Usage: density xyzfile datafile NumBins [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' - end if - call print(line) - call print(' The input xyz file.') - call print(' The output data file.') - call print(' The number of bins in the cell.') - call print(' Optional. Only process 1 out of every n frames.') - call print(' Optional. Only process frames from this frame.') - call print(' Optional. Only process frames until this frame.') - call print(' Optional. Write data after every n processed frames.') - call print(' Optional. Use Gaussians instead of delta functions.') - call print(' Optional. The sigma is the sqrt(variance) of the Gaussian function.') - call print('') - call print('Pressing Ctrl-C during execution will leave the output file with the rdf averaged over the frames read so far') - call print('') - - !call verbosity_pop - call system_finalise - stop - - end subroutine print_usage - - subroutine write_data - - integer :: i, j, k - real(dp) :: density - - call initialise(datafile,trim(datafilename),action=OUTPUT) - - do k = 1, numbins - t(3) = (real(k,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp - do j = 1, numbins - t(2) = (real(j,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp - do i = 1, numbins - t(1) = (real(i,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp - r = at%lattice .mult. t - density = mass_cuml(i,j,k) / (cellvol * real(frame_count-from,dp)) - density = density * abs(matrix3x3_det(at%lattice)) / sum(ElementMass(at%Z(1:at%N))) - call print(r//' '//density,file=datafile) - end do - call print('',file=datafile) - end do - call print('',file=datafile) - end do - - call finalise(datafile) - - call initialise(datafile2,trim(datafilename)//'_smooth',action=OUTPUT) - do k = 1, numbins - t(3) = (real(k,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp - do j = 1, numbins - t(2) = (real(j,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp - do i = 1, numbins - t(1) = (real(i,dp) - 0.5_dp) / real(numbins,dp) - 0.5_dp - r = at%lattice .mult. t - density = 0.125_dp * ( mass_cuml(i,j,k) + mass_cuml(numbins+1-i,j,k) + & - mass_cuml(i,numbins+1-j,k) + mass_cuml(numbins+1-i,numbins+1-j,k) + & - mass_cuml(i,j,numbins+1-k) + mass_cuml(numbins+1-i,j,numbins+1-k) + & - mass_cuml(i,numbins+1-j,numbins+1-k) + mass_cuml(numbins+1-i,numbins+1-j,numbins+1-k) ) & - / (cellvol * real(frame_count-from,dp)) - density = density * abs(matrix3x3_det(at%lattice)) / sum(ElementMass(at%Z(1:at%N))) - call print(r//' '//density,file=datafile2) - end do - call print('',file=datafile2) - end do - call print('',file=datafile2) - end do - call finalise(datafile2) - - end subroutine write_data - -end program density diff --git a/src/Structure_processors/density_1d.f95 b/src/Structure_processors/density_1d.f95 deleted file mode 100644 index 6c2ae43b6c..0000000000 --- a/src/Structure_processors/density_1d.f95 +++ /dev/null @@ -1,633 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Calculates density of a certain element in 1D around the origin -! - -#include "error.inc" - -program density_1d - - use system_module, only : th - use libatoms_module -#ifdef NEED_ERF - use functions_module, only : erf -#endif - - implicit none - - integer, parameter :: DISTANCES_INIT = 1000000 - integer, parameter :: DISTANCES_INCR = 1000000 - - type(atoms_ll) :: structure_ll - type(atoms_ll_entry), pointer :: structure_ll_entry - type(Atoms), pointer :: structure - type(Atoms) :: structure_in - type(Table) :: distances, atom_table - real(dp) :: d - type(Inoutput) :: xyzfile, datafile, xyzfile_list - type(CInoutput) :: cxyzfile - integer :: frame_count, frames_processed, frames_processed_intermed - integer :: status - integer :: error = ERROR_NONE - integer :: i, j - - !Input - type(Dictionary) :: params_in - character(STRING_LENGTH) :: xyzfilename, datafilename - logical :: xyzfile_is_list - real(dp) :: l_cutoff, bin_width - character(STRING_LENGTH) :: mask - integer :: IO_Rate, Density_Time_Evolution_Rate - integer :: decimation - integer :: from, to - real(dp) :: min_time, max_time - logical :: Gaussian_smoothing - real(dp) :: Gaussian_sigma - - !AtomMask processing - character(30) :: prop_name - logical :: list, prop - integer :: prop_val - integer :: Zb - - !Histogram & its integration/normalisation - real(dp), allocatable, dimension(:,:) :: data, data_intermed - real(dp), allocatable, dimension(:) :: hist, hist_sum, hist_sum_intermed - integer :: num_bins, num_atoms - real(dp) :: hist_int, hist_int_intermed - real(dp) :: density, r, dV - logical :: first_time, skip_frame - integer :: last_file_frame_n - real(dp) :: cur_time - - type(Table) :: density_bins !densities of each bin for all the unskipped structure - type(Table) :: density_bins_intermed !densities of each bin for all the unskipped structure - real(dp), allocatable, dimension(:) :: means, sds - logical :: do_statistics - - !Start up LOTF, suppressing messages - call system_initialise(PRINT_NORMAL) - -#ifdef DEBUG - call print('********** DEBUG BUILD **********') - call print('') -#endif - - call initialise(params_in) - call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'xyzfile_is_list', 'F', xyzfile_is_list, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'AtomMask', param_mandatory, mask, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Cutoff', param_mandatory, l_cutoff, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'BinWidth', param_mandatory, bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'from', '0', from, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Density_Time_Evolution_Rate', '0', Density_Time_Evolution_Rate, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'do_statistics', 'F', do_statistics, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(params_in)) then - if (EXEC_NAME == '') then - call print_usage - else - call print_usage(EXEC_NAME) - end if - call system_abort('could not parse argument line') - end if - call finalise(params_in) - - call print('Run_parameters: ') - call print('==================================') - call print(' Input file: '//trim(xyzfilename)) - call print(' Input file is list: '//xyzfile_is_list) - call print(' Output file: '//trim(datafilename)) - call print(' AtomMask: '//trim(mask)) - call print(' Cutoff: '//round(l_Cutoff,3)) - call print(' BinWidth: '//round(bin_width,3)) - call print(' decimation: '//decimation) - if (decimation == 1) then - call print(' Processing every frame') - else - write(line,'(a,i0,a,a)')' Processing every ',decimation,th(decimation),' frame' - call print(line) - end if - call print(' from Frame: '//from) - call print(' to Frame: '//to) - call print(' min_time: '//min_time) - call print(' max_time: '//max_time) - call print(' IO_Rate: '//IO_Rate) - call print(' Density_Time_Evolution_Rate: '//Density_Time_Evolution_Rate) - if (IO_Rate > 0 .and. Density_Time_Evolution_Rate > 0) then - call print('WARNING: IO_Rate = ' // IO_Rate // ' will effectively override Density_Time_Evolution_Rate='//Density_Time_Evolution_Rate, PRINT_ALWAYS) - endif - call print(' Gaussians: '//Gaussian_smoothing) - if (Gaussian_smoothing) call print(' sigma: '//round(Gaussian_sigma,3)) - call print(' do_statistics: '//do_statistics) - call print('==================================') - call print('') - - ! - ! Read the element symbol / atom mask - ! - call print('Mask 2:') - call print('=======') - if (mask(1:1)=='@') then - list = .true. - prop = .false. - call parse_atom_mask(mask,atom_table) - else if (scan(mask,'=')/=0) then - list = .true. - prop = .true. - call get_prop_info(mask, prop_name, prop_val) - call print('') - call print('Selecting all atoms that have '//trim(prop_name)//' set to '//prop_val) - call print('') - else - list = .false. - prop = .false. - Zb = Atomic_Number(mask) - call print('') - write(line,'(a,i0,a)')'Selecting all '//trim(ElementName(Zb))//' atoms (Z = ',Zb,')' - call print(line) - call print('') - end if - - if (l_cutoff < 0.0_dp) call system_abort('Cutoff < 0.0 Angstroms') - if (bin_width < 0.0_dp) call system_abort('Bin width < 0.0 Angstroms') - if (Gaussian_smoothing.and.(Gaussian_sigma.le.0._dp)) call system_abort('sigma must be > 0._dp') - - !Make num_bins and bin_width consistent - num_bins = ceiling(l_cutoff / bin_width) - bin_width = l_cutoff / real(num_bins,dp) - if (do_statistics) call initialise(density_bins,0,num_bins,0,0,0) - if (do_statistics) call initialise(density_bins_intermed,0,num_bins,0,0,0) - - allocate( hist(num_bins), hist_sum(num_bins), hist_sum_intermed(num_bins)) - if (do_statistics) then - allocate(data(num_bins,4), data_intermed(num_bins,4) ) - allocate(means(num_bins), sds(num_bins)) - else - allocate(data(num_bins,3), data_intermed(num_bins,3) ) - endif - - hist = 0.0_dp - hist_sum = 0.0_dp - hist_int = 0.0_dp - - !Set up the x coordinates of the plot - do i = 1, num_bins - data_intermed(i,1) = (real(i,dp) - 0.5_dp) * bin_width - end do - data(:,1) = data_intermed(:,1) - - call print('') - write(line,'(i0,a,f0.4,a,f0.4,a)') num_bins,' bins x ',bin_width,' Angstroms per bin = ',l_cutoff,' Angstroms cutoff' - call print(line) - call print('') - - call print('Reading data...') - - ! initialize frame counters - frames_processed = 0 - frames_processed_intermed = 0 - - - - status = 0 - if (from > 0) then - frame_count = from - else - frame_count = 1 - endif - last_file_frame_n = 0 - - if (xyzfile_is_list) then - call initialise(xyzfile_list, trim(xyzfilename), INPUT) - xyzfilename = read_line(xyzfile_list, status) - if (status /= 0) call finalise(xyzfile_list) - endif - - do while (status == 0) ! loop over files - call initialise(cxyzfile,trim(xyzfilename),action=INPUT) - status = 0 - do while ((to <= 0 .or. frame_count <= to) .and. status == 0) - write(mainlog%unit,'(4a,i0,a,i0,$)') achar(13), 'Read file ',trim(xyzfilename), ' Frame ',frame_count,' which in this file is frame (zero based) ',(frame_count-1-last_file_frame_n) - call read(cxyzfile, structure_in, frame=frame_count-1-last_file_frame_n, error=error) - if (error == ERROR_NONE) then - skip_frame = .false. - if (min_time > 0.0_dp .or. max_time > 0.0_dp) then - if (get_value(structure_in%params,"Time",cur_time)) then - if ((min_time >= 0.0_dp .and. cur_time < min_time) .or. & - (max_time >= 0.0_dp .and. cur_time > max_time)) skip_frame = .true. - else - call system_abort("ERROR: min_time="//min_time//" > 0 but Time field wasn't found in config " // frame_count) - endif - endif - if (.not. skip_frame) then - call new_entry(structure_ll, structure) - call atoms_copy_without_connect(structure, structure_in, properties="pos:Z") - else - write (mainlog%unit,'(a,$)') " skip" - endif - frame_count = frame_count + decimation - else - call clear_error(error) - status = 1 - endif - end do - last_file_frame_n = frame_count - 1 - call finalise(cxyzfile) - - if (xyzfile_is_list) then - xyzfilename = read_line(xyzfile_list, status) - if (status /= 0) call finalise(xyzfile_list) - else - status = 1 - endif - - end do - - call allocate(distances,0,1,0,0,DISTANCES_INIT) - call set_increment(distances,DISTANCES_INCR) - - first_time=.true. - - structure_ll_entry => structure_ll%first - - frame_count = from - if (min_time > 0.0_dp) call print("WARNING: min_time > 0, frame_count will be wrong if frames were skipped", PRINT_ALWAYS) - - do while (associated(structure_ll_entry)) - - structure => structure_ll_entry%at - - write(mainlog%unit,'(a,a,i0,$)') achar(13),'Processing Frame ',frame_count - - if (prop) call list_matching_prop(structure,atom_table,trim(prop_name),prop_val) - - call wipe(distances) - - num_atoms = 0 - - hist = 0.0_dp - do j = 1, structure%N - - !Count the atoms - if (list) then - if (find(atom_table,j)/=0) num_atoms = num_atoms + 1 - else - if (structure%Z(j) == Zb) num_atoms = num_atoms + 1 - end if - - !Do we have a "Mask" atom? Cycle if not - if (list) then - if (find(atom_table,j)==0) cycle - else - if (structure%Z(j) /= Zb) cycle - end if - - d = distance_min_image(structure,j,(/0._dp,0._dp,0._dp/)) - if (d < l_cutoff+3.0*Gaussian_sigma) then -#ifdef DEBUG - call print('Storing distance (/0,0,0/)--'//j//' = '//round(d,5)//'A') -#endif - !Add this distance to the list - call accum_histogram(hist, d, 0.0_dp, l_cutoff, num_bins, Gaussian_smoothing, Gaussian_sigma) - end if - end do - - - frames_processed = frames_processed + 1 - frames_processed_intermed = frames_processed_intermed + 1 - -#ifdef DEBUG - call print('Number of atoms = '//num_atoms) -#endif - - !Calculate B atom density - density = real(num_atoms,dp) / cell_volume(structure) - - !Normalise histogram - do i = 1, num_bins - r = (real(i,dp) - 1._dp) * bin_width - dV = 4.0_dp * PI * (r*r + r*bin_width + bin_width*bin_width/3.0_dp ) * bin_width - hist(i) = hist(i) / (dV * density * 1._dp) - end do - - !Accumulate the data - hist_sum = hist_sum + hist - hist_sum_intermed = hist_sum_intermed + hist - if (do_statistics) then -!call print('Append '//hist(1:num_bins)) - call append(density_bins,realpart=hist(1:num_bins)) - call append(density_bins_intermed,realpart=hist(1:num_bins)) - endif - - !copy the current averages into the y coordinates of the plot - data(:,2) = hist_sum / real(frames_processed,dp) - data_intermed(:,2) = hist_sum_intermed / real(frames_processed_intermed,dp) - - !integrate the average data - hist_int = 0.0_dp - hist_int_intermed = 0.0_dp - do i = 1, num_bins - r = data(i,1) - dV = PI * (4.0_dp * r*r + bin_width*bin_width/3.0_dp) * bin_width - hist_int = hist_int + data(i,2)*dV*density - data(i,3) = hist_int - hist_int_intermed = hist_int_intermed + data_intermed(i,2)*dV*density - data_intermed(i,3) = hist_int_intermed - end do - - !calculate the standard deviation to print in the 4th column - if (do_statistics) then - !intermed - means = 0._dp !should be equal to data_intermed(:,2) - sds = 0._dp - do i=1,num_bins !calc -!call print('Raw data:'//density_bins_intermed%real(i,1:density_bins_intermed%N)) - call calc_stat(density_bins_intermed%real(i,1:density_bins_intermed%N),means(i),sds(i)) -!call print(i//' mean: '//means(i)//' SD: '//sds(i)) - enddo - data_intermed(1:num_bins,4) = sds(1:num_bins) - !accumulated - means = 0._dp !should be equal to data(:,2) - sds = 0._dp - do i=1,num_bins !calc -!call print('Raw data:'//density_bins%real(i,1:density_bins%N)) - call calc_stat(density_bins%real(i,1:density_bins%N),means(i),sds(i)) -!call print(i//' mean: '//means(i)//' SD: '//sds(i)) - enddo - data(1:num_bins,4) = sds(1:num_bins) - endif - - if (Density_Time_Evolution_Rate > 0) then - if (mod(frames_processed,Density_Time_Evolution_Rate)==0) then - if (first_time) then - call initialise(datafile,datafilename,action=OUTPUT) - first_time = .false. - else - call initialise(datafile,datafilename,action=OUTPUT,append=.true.) - call print('',file=datafile) - call print('',file=datafile) - endif - call print('# Density 1D',file=datafile) - call print('# Input file: '//trim(xyzfilename),file=datafile) - call print('# Frames read = '//frame_count,file=datafile) - call print('# Frames processed = '//frames_processed,file=datafile) - call print(data_intermed,file=datafile) - call finalise(datafile) - hist_sum_intermed = 0.0_dp - frames_processed_intermed = 0.0_dp - endif - endif - - !Write the current data. This allows the user to Ctrl-C after a certain number - !of frames if things are going slowly - if (IO_Rate > 0) then - if (mod(frames_processed,IO_Rate)==0) then - call initialise(datafile,datafilename,action=OUTPUT) - call print('# Density 1D',file=datafile) - call print('# Input file: '//trim(xyzfilename),file=datafile) - call print('# Frames read = '//frame_count,file=datafile) - call print('# Frames processed = '//frames_processed,file=datafile) - call print(data,file=datafile) - call finalise(datafile) - endif - endif - - !Try to read another frame - structure_ll_entry => structure_ll_entry%next - frame_count = frame_count + decimation - - end do - - frame_count = frame_count - decimation - - if (Density_Time_Evolution_Rate > 0) then - call initialise(datafile,datafilename,action=OUTPUT,append=.true.) - call print('',file=datafile) - call print('',file=datafile) - else - call initialise(datafile,datafilename,action=OUTPUT) - endif - call print('# Final Density 1D',file=datafile) - call print('# Input file: '//trim(xyzfilename),file=datafile) - call print('# Frames read = '//frame_count,file=datafile) - call print('# Frames processed = '//frames_processed,file=datafile) - call print(data,file=datafile) - call finalise(datafile) - - call print('') - call print('Read '//frame_count//' frames, processed '//frames_processed//' frames.') - - !Free up memory - call finalise(distances) - call finalise(structure_in) - call finalise(xyzfile) - - deallocate(hist, hist_sum, data) - - call print('Finished.') - - !call verbosity_pop - call system_finalise - -contains - - subroutine accum_histogram(hist, d, minx, maxx, num_bins, gaussian_smoothing, sigma) - real(dp), intent(inout) :: hist(:) - real(dp) :: d, minx, maxx - integer :: num_bins - logical :: gaussian_smoothing - real(dp) :: sigma - - real(dp), allocatable :: hist_t(:) - real(dp), allocatable :: d_a(:), w_a(:) - real(dp) :: px, py, pz - integer :: ix, iy, iz, io - integer :: n_samples = 20 - real(dp) :: n_samples_d, normalization - real(dp) :: range - - range = 3.0_dp*sigma - normalization=((2.0*range/real(n_samples,dp))**3)/(sigma*sqrt(PI))**3 - - n_samples_d = real(n_samples/2,dp) - allocate(hist_t(size(hist))) - - if (gaussian_smoothing) then - allocate(d_a((n_samples+1)**3)) - allocate(w_a((n_samples+1)**3)) - do ix=1, n_samples+1 - px = real(ix-1-(n_samples/2), dp)/n_samples_d*range - do iy=1, n_samples+1 - py = real(iy-1-(n_samples/2), dp)/n_samples_d*range - do iz=1, n_samples+1 - pz = real(iz-1-(n_samples/2), dp)/n_samples_d*range - io = (ix-1)*(n_samples+1)**2 + (iy-1)*(n_samples+1) + (iz-1) + 1 - d_a(io) = sqrt((px+d)**2+py**2+pz**2) - w_a(io) = normalization*exp(-(px**2+py**2+pz**2)/sigma**2) - end do - end do - end do - hist_t = histogram(d_a, minx, maxx, num_bins, weight_vector=w_a, drop_outside=.true.) - deallocate(d_a) - deallocate(w_a) - else - hist_t = histogram((/d/), minx, maxx, num_bins, drop_outside=.true.) - endif - hist = hist + hist_t - deallocate(hist_t) - - end subroutine accum_histogram - - subroutine print_usage(name) - - character(*), optional, intent(in) :: name - - if (present(name)) then - write(line,'(3a)')'Usage: ',trim(name),' xyzfile datafile AtomMask Cutoff BinWidth [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' - else - write(line,'(a)')'Usage: density_1d xyzfile datafile AtomMask Cutoff BinWidth [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' - end if - call print(line) - call print(' The input xyz file.') - call print(' An element symbol, e.g. H or Ca, or @ followed by a list of indices/ranges, e.g. @1-35,45,47,50-99 or property=value') - call print(' The cutoff radius in Angstroms.') - call print(' The width of each bin in Angstroms.') - call print(' The output data file.') - call print(' Optional. Only process 1 out of every n frames.') - call print(' Optional. Only process frames from this frame.') - call print(' Optional. Only process frames until this frame.') - call print(' Optional. Write data after every n processed frames.') - call print(' Optional. Compute separate densities for each n processed frames (overriden if IO_Rate > 0)') - call print(' Optional. Use Gaussians instead of delta functions.') - call print(' Optional. The sigma is the sqrt(variance) of the Gaussian function.') - call print(' Optional. If true, use FORTRAN I/O. Slower, but might not work for stdin otherwise') - call print('') - call print('Pressing Ctrl-C during execution will leave the output file with the rdf averaged over the frames read so far') - call print('') - - !call verbosity_pop - call system_finalise - stop - - end subroutine print_usage - - subroutine get_prop_info(mask,name,value) - - character(*), intent(in) :: mask - character(*), intent(out) :: name - integer, intent(out) :: value - integer :: delimiter - - delimiter = scan(mask,'=') - if (delimiter > 1) then - name = adjustl(mask(1:delimiter-1)) - value = string_to_int(mask(delimiter+1:len_trim(mask))) - else - call system_abort('Zero length property name in mask: "'//trim(mask)//'"') - end if - - end subroutine get_prop_info - - function Gaussian_histogram(vector,min_x,max_x,Nbin,Gaussian,sigma) - - real(dp), dimension(:), intent(in) :: vector - real(dp), intent(in) :: min_x, max_x - integer, intent(in) :: Nbin - logical, intent(in) :: Gaussian - real(dp), intent(in) :: sigma - real(dp), dimension(Nbin) :: Gaussian_histogram - !local variables - real(dp) :: binsize,min_bin,max_bin - integer :: i, bin, j - - if(max_x <= min_x) then - call system_abort('Vector_Histogram: max_x < min_x') - end if - - binsize=(max_x-min_x)/(real(Nbin,dp)) - Gaussian_histogram = 0.0_dp - - do i=1,size(vector) -! call print('') -! call print('Distribution of vector '//i//' over the whole histogram:') - - if (Gaussian) then -! if(.not.present(sigma)) call system_abort('Gaussian_histogram: Missing Gaussian sigma parameter.') - do j=1,Nbin - min_bin = min_x + real(j-1,dp) * binsize - max_bin = min_bin + binsize -! call print('min_bin: '//min_bin//', max_bin: '//max_bin) -! call print('ERF(min_bin) = '//erf((vector(i)-min_bin)/(sigma*sqrt(2._dp)))) -! call print('ERF(max_bin) = '//erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp)))) -! call print('Adding to bin '//j//' '//(erf((vector(i)-min_bin)/(sigma*sqrt(2._dp))) + erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp))))) - Gaussian_histogram(j) = Gaussian_histogram(j) - 0.5_dp*erf((min_bin-vector(i))/(sigma*sqrt(2._dp))) + 0.5_dp*erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp))) - enddo - else - bin = ceiling((vector(i)-min_x)/binsize) - if (bin < 1) bin = 1 - if (bin > Nbin) bin = Nbin - Gaussian_histogram(bin) = Gaussian_histogram(bin) + 1.0_dp - endif - end do - - end function Gaussian_histogram - - subroutine calc_stat(data,mean,sd) - - real(dp), dimension(:), intent(in) :: data - real(dp), intent(out) :: mean,sd - - integer :: i - - mean = 0._dp - sd = 0._dp - - do i=1,size(data) - mean = mean + data(i) - enddo - mean = mean / size(data) - - do i=1,size(data) - sd = sd + (data(i)-mean)**2.0_dp - enddo - sd = sqrt(sd/size(data)) - - end subroutine calc_stat - -end program density_1d diff --git a/src/Structure_processors/density_KDE.f95 b/src/Structure_processors/density_KDE.f95 deleted file mode 100644 index 76337eb5a0..0000000000 --- a/src/Structure_processors/density_KDE.f95 +++ /dev/null @@ -1,701 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Calculates density of a certain element in 1D around the origin -! - -program density_KDE - - use libatoms_module -#ifdef NEED_ERF - use functions_module, only : erf -#endif - - implicit none - - integer, parameter :: DISTANCES_INIT = 1000000 - integer, parameter :: DISTANCES_INCR = 1000000 - - type(atoms_ll) :: structure_ll - type(atoms_ll_entry), pointer :: structure_ll_entry - type(Atoms), pointer :: structure - type(Atoms) :: structure_in - type(Table) :: distances, distances_intermed, atom_table - real(dp) :: d - type(Inoutput) :: xyzfile, datafile, xyzfile_list - type(CInoutput) :: cxyzfile - integer :: frame_count, frames_processed, frames_processed_intermed - integer :: status - integer :: i, j - - !Input - type(Dictionary) :: params_in - character(STRING_LENGTH) :: xyzfilename, datafilename - logical :: xyzfile_is_list - real(dp) :: cutoff, bin_width - character(STRING_LENGTH) :: mask - integer :: IO_Rate, Density_Time_Evolution_Rate - integer :: decimation - integer :: from, to - real(dp) :: min_time, max_time - logical :: Gaussian_smoothing - real(dp) :: Gaussian_sigma - logical :: fortran_io - - !AtomMask processing - character(30) :: prop_name - logical :: list, prop - integer :: prop_val - integer :: Zb - - !Histogram & its integration/normalisation - real(dp), allocatable, dimension(:,:) :: data, data_intermed - real(dp), allocatable, dimension(:) :: hist, hist_sum, hist_sum_intermed - integer :: num_bins, num_atoms - real(dp) :: hist_int, hist_int_intermed - real(dp) :: density, r, dV - logical :: first_time, skip_frame - integer :: last_file_frame_n - real(dp) :: cur_time - - - !Start up LOTF, suppressing messages - call system_initialise(PRINT_NORMAL) - -#ifdef DEBUG - call print('********** DEBUG BUILD **********') - call print('') -#endif - - call initialise(params_in) - call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'xyzfile_is_list', 'F', xyzfile_is_list, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'AtomMask', param_mandatory, mask, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Cutoff', param_mandatory, cutoff, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'NumBins', param_mandatory, num_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'from', '0', from, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Density_Time_Evolution_Rate', '0', Density_Time_Evolution_Rate, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'fortran_io', 'F', fortran_io, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(params_in)) then - if (EXEC_NAME == '') then - call print_usage - else - call print_usage(EXEC_NAME) - end if - call system_abort('could not parse argument line') - end if - call finalise(params_in) - - call print('Run_parameters: ') - call print('==================================') - call print(' Input file: '//trim(xyzfilename)) - call print(' Input file is list: '//xyzfile_is_list) - call print(' Output file: '//trim(datafilename)) - call print(' AtomMask: '//trim(mask)) - call print(' Cutoff: '//round(Cutoff,3)) - call print(' NumBins: '//num_bins) - call print(' decimation: '//decimation) - if (decimation == 1) then - call print(' Processing every frame') - else - write(line,'(a,i0,a,a)')' Processing every ',decimation,th(decimation),' frame' - call print(line) - end if - call print(' from Frame: '//from) - call print(' to Frame: '//to) - call print(' IO_Rate: '//IO_Rate) - call print(' Density_Time_Evolution_Rate: '//Density_Time_Evolution_Rate) - if (IO_Rate > 0 .and. Density_Time_Evolution_Rate > 0) then - call print('WARNING: IO_Rate = ' // IO_Rate // ' will effectively override Density_Time_Evolution_Rate='//Density_Time_Evolution_Rate, PRINT_ALWAYS) - endif - call print(' Gaussians: '//Gaussian_smoothing) - if (Gaussian_smoothing) call print(' sigma: '//round(Gaussian_sigma,3)) - call print('==================================') - call print('') - - ! - ! Read the element symbol / atom mask - ! - call print('Mask 2:') - call print('=======') - if (mask(1:1)=='@') then - list = .true. - prop = .false. - call parse_atom_mask(mask,atom_table) - else if (scan(mask,'=')/=0) then - list = .true. - prop = .true. - call get_prop_info(mask, prop_name, prop_val) - call print('') - call print('Selecting all atoms that have '//trim(prop_name)//' set to '//prop_val) - call print('') - else - list = .false. - prop = .false. - Zb = Atomic_Number(mask) - call print('') - write(line,'(a,i0,a)')'Selecting all '//trim(ElementName(Zb))//' atoms (Z = ',Zb,')' - call print(line) - call print('') - end if - - if (cutoff < 0.0_dp) call system_abort('Cutoff < 0.0 Angstroms') - if (num_bins < 0) call system_abort('NumBins < 0 ') - bin_width = cutoff / real(num_bins,dp) - - - allocate( hist(num_bins), hist_sum(num_bins), hist_sum_intermed(num_bins) ) - allocate(data(num_bins,3), data_intermed(num_bins,3) ) - - data = 0._dp - data_intermed = 0._dp - - hist = 0.0_dp - hist_sum = 0.0_dp - hist_int = 0.0_dp - - !Set up the x coordinates of the plot -- in distance bins (can easily be plotted as a fn of volume) - do i = 1, num_bins - data_intermed(i,1) = bin_width * (real(i,dp)) - end do - data(:,1) = data_intermed(:,1) - - call print('') - write(line,'(i0,a,f0.4,a,f0.4,a)') num_bins,' bins x ',bin_width,' Angstroms per bin = ',cutoff,' Angstroms cutoff' - call print(line) - call print('') - - call print('Reading data...') - - ! initialize frame counters - frames_processed = 0 - frames_processed_intermed = 0 - - if (fortran_io) then - if (xyzfile_is_list) call system_abort("ERROR: xyzfile_is_list is not supported with fortran I/O") - call initialise(xyzfile,xyzfilename,action=INPUT) - status = 0 - frame_count = 0 - do while (frame_count < from-1) - frame_count = frame_count + 1 - call read_xyz(xyzfile,status) - if (status/=0) exit - end do - - ! read rest of configs, skipping decimation related ones, put in structure_ll - do while (status == 0 .and. (to <= 0 .or. frame_count < to)) - frame_count = frame_count + 1 - write(mainlog%unit,'(a,a,i0,$)') achar(13),'Read Frame ',frame_count - call read_xyz(structure_in, xyzfile, status=status) - skip_frame = .false. - if (min_time > 0.0_dp .or. max_time > 0.0_dp) then - if (get_value(structure_in%params,"Time",cur_time)) then - if (cur_time < min_time .or. cur_time > max_time) skip_frame = .true. - else - call system_abort("ERROR: min_time="//min_time//" > 0.0 or max_time="//max_time//" > 0.0, but Time field wasn't found in config " // frame_count) - endif - endif - if (.not. skip_frame) then -! call new_entry(structure_ll, structure) - call atoms_ll_new_entry2(structure_ll, structure) - call atoms_copy_without_connect(structure, structure_in, properties="pos:Z") - endif - if (to > 0 .and. frame_count >= to) then - exit - endif - - do i=1, (decimation-1) - frame_count = frame_count + 1 - call read_xyz(xyzfile, status) - if (status /= 0) exit - end do - end do - - if (status /= 0) then - call remove_last_entry(structure_ll) - endif - - call finalise(xyzfile) - - else ! not fortran I/O, i.e. C - - status = 0 - if (from > 0) then - frame_count = from - else - frame_count = 1 - endif - last_file_frame_n = 0 - - if (xyzfile_is_list) then - call initialise(xyzfile_list, trim(xyzfilename), INPUT) - xyzfilename = read_line(xyzfile_list, status) - if (status /= 0) call finalise(xyzfile_list) - endif - - do while (status == 0) ! loop over files - call initialise(cxyzfile,trim(xyzfilename),action=INPUT) - status = 0 - do while ((to <= 0 .or. frame_count <= to) .and. status == 0) - write(mainlog%unit,'(4a,i0,a,i0,$)') achar(13), 'Read file ',trim(xyzfilename), ' Frame ',frame_count,' which in this file is frame (zero based) ',(frame_count-1-last_file_frame_n) - call read(cxyzfile, structure_in, frame=frame_count-1-last_file_frame_n, status=status) - if (status == 0) then - skip_frame = .false. - if (min_time > 0.0_dp .or. max_time > 0.0_dp) then - if (get_value(structure_in%params,"Time",cur_time)) then - if (cur_time < min_time .or. cur_time > max_time) skip_frame = .true. - else - call system_abort("ERROR: min_time="//min_time//" > 0 but Time field wasn't found in config " // frame_count) - endif - endif - if (.not. skip_frame) then -! call new_entry(structure_ll, structure) - call atoms_ll_new_entry2(structure_ll, structure) - call atoms_copy_without_connect(structure, structure_in, properties="pos:Z") - else - write (mainlog%unit,'(a,$)') " skip" - endif - frame_count = frame_count + decimation - endif - end do - last_file_frame_n = frame_count - 1 - call finalise(cxyzfile) - - if (xyzfile_is_list) then - xyzfilename = read_line(xyzfile_list, status) - if (status /= 0) call finalise(xyzfile_list) - else - status = 1 - endif - - end do - - endif ! fortran I/O - - call allocate(distances,0,1,0,0,DISTANCES_INIT) - call set_increment(distances,DISTANCES_INCR) - call allocate(distances_intermed,0,1,0,0,DISTANCES_INIT) - call set_increment(distances_intermed,DISTANCES_INCR) - - first_time=.true. - - structure_ll_entry => structure_ll%first - - frame_count = from - if (min_time > 0.0_dp) call print("WARNING: min_time > 0, frame_count will be wrong if frames were skipped", PRINT_ALWAYS) - - do while (associated(structure_ll_entry)) - - structure => structure_ll_entry%at - - write(mainlog%unit,'(a,a,i0,$)') achar(13),'Processing Frame ',frame_count - - if (prop) call list_matching_prop(structure,atom_table,trim(prop_name),prop_val) - - num_atoms = 0 - call wipe(distances) - call wipe(distances_intermed) - - hist = 0.0_dp - do j = 1, structure%N - - !Count the atoms - if (list) then - if (find(atom_table,j)/=0) num_atoms = num_atoms + 1 - else - if (structure%Z(j) == Zb) num_atoms = num_atoms + 1 - end if - - !Do we have a "Mask" atom? Cycle if not - if (list) then - if (find(atom_table,j)==0) cycle - else - if (structure%Z(j) /= Zb) cycle - end if - - d = distance_min_image(structure,j,(/0._dp,0._dp,0._dp/)) - if (d < cutoff+3.0*Gaussian_sigma) then -#ifdef DEBUG - call print('Storing distance (/0,0,0/)--'//j//' = '//round(d,5)//'A') -#endif -! !Add this distance to the list - call append(distances,realpart=(/d/)) - call append(distances_intermed,realpart=(/d/)) - end if - end do - - - frames_processed = frames_processed + 1 - frames_processed_intermed = frames_processed_intermed + 1 - -#ifdef DEBUG - call print('Number of atoms = '//num_atoms) -#endif - - !Calculate B atom density - density = real(num_atoms,dp) / cell_volume(structure) - call print('Number of atoms = '//num_atoms) - call print('density: '//density) - call print('cell_volume: '//cell_volume(structure)) - !Normalise histogram -! do i = 1, num_bins -! hist(i) = hist(i) / (bin_width * density * 1._dp) -! end do - - !copy the current averages into the y coordinates of the plot - do i=1,num_bins - data(i,2) = data(i,2) + KDE_eval(distances%real(1,1:distances%N),data(i,1),Gaussian_sigma) / density !/ (4.0_dp * data(i,1)**2.0_dp * PI) - data_intermed(i,2) = data_intermed(i,2) + KDE_eval(distances_intermed%real(1,1:distances_intermed%N),data_intermed(i,1),Gaussian_sigma) / density !/ (4.0_dp * data_intermed(i,1)**2.0_dp * PI) - enddo -! data(:,2) = data(:,2) / real(frames_processed,dp) -! data_intermed(:,2) = data_intermed(:,2) / real(frames_processed_intermed,dp) - - !integrate the average data - hist_int = 0.0_dp - hist_int_intermed = 0.0_dp - do i = 1, num_bins - hist_int = hist_int + data(i,2) * bin_width * (4.0_dp * data(i,1)**2.0_dp * PI) *density - data(i,3) = hist_int - hist_int_intermed = hist_int_intermed + data_intermed(i,2) * bin_width * (4.0_dp * data_intermed(i,1)**2.0_dp * PI) *density - data_intermed(i,3) = hist_int_intermed - end do - - if (Density_Time_Evolution_Rate > 0) then - if (mod(frames_processed,Density_Time_Evolution_Rate)==0) then - if (first_time) then - call initialise(datafile,datafilename,action=OUTPUT) - first_time = .false. - else - call initialise(datafile,datafilename,action=OUTPUT,append=.true.) - call print('',file=datafile) - call print('',file=datafile) - endif - data_intermed(1:num_bins,2:3) = data_intermed(1:num_bins,2:3) / real(frames_processed_intermed,dp) - call print('# Kernel Density Estimation 1D',file=datafile) - call print('# Input file: '//trim(xyzfilename),file=datafile) - call print('# Frames read = '//frame_count,file=datafile) - call print('# Frames processed = '//frames_processed,file=datafile) - call print(data_intermed,file=datafile) - call finalise(datafile) -! hist_sum_intermed = 0.0_dp - data_intermed(1:num_bins,2:3) = 0._dp - frames_processed_intermed = 0 - endif - endif - - !Write the current data. This allows the user to Ctrl-C after a certain number - !of frames if things are going slowly - if (IO_Rate > 0) then - if (mod(frames_processed,IO_Rate)==0) then - call initialise(datafile,datafilename,action=OUTPUT) - data(1:num_bins,2:3) = data(1:num_bins,2:3) / real(frames_processed,dp) - call print('# Kernel Density Estimation 1D',file=datafile) - call print('# Input file: '//trim(xyzfilename),file=datafile) - call print('# Frames read = '//frame_count,file=datafile) - call print('# Frames processed = '//frames_processed,file=datafile) - call print(data,file=datafile) - call finalise(datafile) - data(1:num_bins,2:3) = data(1:num_bins,2:3) * real(frames_processed,dp) - endif - endif - - !Try to read another frame - structure_ll_entry => structure_ll_entry%next - frame_count = frame_count + decimation - - end do - - frame_count = frame_count - decimation - - if (Density_Time_Evolution_Rate > 0) then - call initialise(datafile,datafilename,action=OUTPUT,append=.true.) - call print('',file=datafile) - call print('',file=datafile) - else - call initialise(datafile,datafilename,action=OUTPUT) - endif - data(1:num_bins,2:3) = data(1:num_bins,2:3) / real(frames_processed,dp) - call print('# Final Kernel Density Estimation 1D',file=datafile) - call print('# Input file: '//trim(xyzfilename),file=datafile) - call print('# Frames read = '//frame_count,file=datafile) - call print('# Frames processed = '//frames_processed,file=datafile) - call print(data,file=datafile) - call finalise(datafile) - - call print('') - call print('Read '//frame_count//' frames, processed '//frames_processed//' frames.') - - !Free up memory - call finalise(distances) - call finalise(structure_in) - call finalise(xyzfile) - - deallocate(hist, hist_sum, data) - - call print('Finished.') - - !call verbosity_pop - call system_finalise - -contains - - subroutine accum_histogram(hist, d, minx, maxx, num_bins, gaussian_smoothing, sigma) - real(dp), intent(inout) :: hist(:) - real(dp) :: d, minx, maxx - integer :: num_bins - logical :: gaussian_smoothing - real(dp) :: sigma - - real(dp), allocatable :: hist_t(:) - real(dp), allocatable :: d_a(:), w_a(:) - real(dp) :: px, py, pz - integer :: ix, iy, iz, io - integer :: n_samples = 20 - real(dp) :: n_samples_d, normalization - real(dp) :: range - - range = 3.0_dp*sigma - normalization=((2.0*range/real(n_samples,dp))**3)/(sigma*sqrt(PI))**3 - - n_samples_d = real(n_samples/2,dp) - allocate(hist_t(size(hist))) - - if (gaussian_smoothing) then - allocate(d_a((n_samples+1)**3)) - allocate(w_a((n_samples+1)**3)) - do ix=1, n_samples+1 - px = real(ix-1-(n_samples/2), dp)/n_samples_d*range - do iy=1, n_samples+1 - py = real(iy-1-(n_samples/2), dp)/n_samples_d*range - do iz=1, n_samples+1 - pz = real(iz-1-(n_samples/2), dp)/n_samples_d*range - io = (ix-1)*(n_samples+1)**2 + (iy-1)*(n_samples+1) + (iz-1) + 1 - d_a(io) = sqrt((px+d)**2+py**2+pz**2) - w_a(io) = normalization*exp(-(px**2+py**2+pz**2)/sigma**2) - end do - end do - end do - hist_t = histogram(d_a, minx, maxx, num_bins, weight_vector=w_a, drop_outside=.true.) - deallocate(d_a) - deallocate(w_a) - else - hist_t = histogram((/d/), minx, maxx, num_bins, drop_outside=.true.) - endif - hist = hist + hist_t - deallocate(hist_t) - - end subroutine accum_histogram - - subroutine print_usage(name) - - character(*), optional, intent(in) :: name - - if (present(name)) then - write(line,'(3a)')'Usage: ',trim(name),' xyzfile datafile AtomMask Cutoff BinWidth [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' - else - write(line,'(a)')'Usage: density_KDE xyzfile datafile AtomMask Cutoff BinWidth [decimation] [from] [to] [IO_Rate] [Gaussian] [sigma]' - end if - call print(line) - call print(' The input xyz file.') - call print(' An element symbol, e.g. H or Ca, or @ followed by a list of indices/ranges, e.g. @1-35,45,47,50-99 or property=value') - call print(' The cutoff radius in Angstroms.') - call print(' The number of volume bins.') - call print(' The output data file.') - call print(' Optional. Only process 1 out of every n frames.') - call print(' Optional. Only process frames from this frame.') - call print(' Optional. Only process frames until this frame.') - call print(' Optional. Write data after every n processed frames.') - call print(' Optional. Compute separate densities for each n processed frames (overriden if IO_Rate > 0)') - call print(' Optional. Use Gaussians instead of delta functions.') - call print(' Optional. The sigma is the sqrt(variance) of the Gaussian function.') - call print(' Optional. If true, use FORTRAN I/O. Slower, but might not work for stdin otherwise') - call print('') - call print('Pressing Ctrl-C during execution will leave the output file with the rdf averaged over the frames read so far') - call print('') - - !call verbosity_pop - call system_finalise - stop - - end subroutine print_usage - - subroutine get_prop_info(mask,name,value) - - character(*), intent(in) :: mask - character(*), intent(out) :: name - integer, intent(out) :: value - integer :: delimiter - - delimiter = scan(mask,'=') - if (delimiter > 1) then - name = adjustl(mask(1:delimiter-1)) - value = string_to_int(mask(delimiter+1:len_trim(mask))) - else - call system_abort('Zero length property name in mask: "'//trim(mask)//'"') - end if - - end subroutine get_prop_info - - function Gaussian_histogram(vector,min_x,max_x,Nbin,Gaussian,sigma) - - real(dp), dimension(:), intent(in) :: vector - real(dp), intent(in) :: min_x, max_x - integer, intent(in) :: Nbin - logical, intent(in) :: Gaussian - real(dp), intent(in) :: sigma - real(dp), dimension(Nbin) :: Gaussian_histogram - !local variables - real(dp) :: binsize,min_bin,max_bin - integer :: i, bin, j - - if(max_x <= min_x) then - call system_abort('Vector_Histogram: max_x < min_x') - end if - - binsize=(max_x-min_x)/(real(Nbin,dp)) - Gaussian_histogram = 0.0_dp - - do i=1,size(vector) -! call print('') -! call print('Distribution of vector '//i//' over the whole histogram:') - - if (Gaussian) then -! if(.not.present(sigma)) call system_abort('Gaussian_histogram: Missing Gaussian sigma parameter.') - do j=1,Nbin - min_bin = min_x + real(j-1,dp) * binsize - max_bin = min_bin + binsize -! call print('min_bin: '//min_bin//', max_bin: '//max_bin) -! call print('ERF(min_bin) = '//erf((vector(i)-min_bin)/(sigma*sqrt(2._dp)))) -! call print('ERF(max_bin) = '//erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp)))) -! call print('Adding to bin '//j//' '//(erf((vector(i)-min_bin)/(sigma*sqrt(2._dp))) + erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp))))) - Gaussian_histogram(j) = Gaussian_histogram(j) - 0.5_dp*erf((min_bin-vector(i))/(sigma*sqrt(2._dp))) + 0.5_dp*erf((max_bin-vector(i))/(sigma*sqrt(2.0_dp))) - enddo - else - bin = ceiling((vector(i)-min_x)/binsize) - if (bin < 1) bin = 1 - if (bin > Nbin) bin = Nbin - Gaussian_histogram(bin) = Gaussian_histogram(bin) + 1.0_dp - endif - end do - - end function Gaussian_histogram - - subroutine atoms_ll_new_entry2(this, atoms_p, before, after) - type(atoms_ll), target, intent(inout) :: this - type(atoms), intent(inout), pointer :: atoms_p - !type(atoms_ll) :: this !structure_ll -! type(Atoms), pointer :: atoms_p !structure - type(atoms_ll_entry), intent(in), target, optional :: before, after - - type(atoms_ll_entry), pointer :: my_before, my_after - type(atoms_ll_entry), pointer :: entry - - if (present(before) .and. present(after)) call system_abort("atoms_ll_new_entry got both before and after") - - if (present(before)) then - my_before => before - my_after => before%prev - else if (present(after)) then - my_before => after%next - my_after => after - else - my_after => this%last - my_before => null() - endif - - allocate(entry) - if (associated(my_before)) then - my_before%prev => entry - entry%next => my_before - else - this%last => entry - endif - if (associated(my_after)) then - my_after%next => entry - entry%prev => my_after - else - this%first => entry - endif - - atoms_p => entry%at - end subroutine atoms_ll_new_entry2 - - subroutine calc_stat(data,mean,sd) - - real(dp), dimension(:), intent(in) :: data - real(dp), intent(out) :: mean,sd - - integer :: i - - mean = 0._dp - sd = 0._dp - - do i=1,size(data) - mean = mean + data(i) - enddo - mean = mean / size(data) - - do i=1,size(data) - sd = sd + (data(i)-mean)**2.0_dp - enddo - sd = sqrt(sd/size(data)) - - end subroutine calc_stat - - function KDE_eval(points,here,sigma) - - real(dp), dimension(:), intent(in) :: points - real(dp), intent(in) :: here - real(dp), intent(in) :: sigma - - real(dp) :: a,c, bias - integer :: i - real(dp) :: KDE_eval - - KDE_eval = 0._dp - a = 1.0_dp / (sigma * sqrt(2.0_dp*PI)) - c = -1.0_dp / (2.0_dp * sigma**2.0_dp) - do i = 1,size(points) - bias = 4.0_dp * points(i)**2.0_dp * PI - KDE_eval = KDE_eval + a * exp( c * (here-points(i))**2.0_dp ) / bias - KDE_eval = KDE_eval + a * exp( c * (here+points(i))**2.0_dp ) / bias !if close to the origin - enddo - - end function KDE_eval - -end program density_KDE diff --git a/src/Structure_processors/density_new.f95 b/src/Structure_processors/density_new.f95 deleted file mode 100644 index d75693dc8c..0000000000 --- a/src/Structure_processors/density_new.f95 +++ /dev/null @@ -1,792 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Calculates density in a grid of boxes (possibly smoothed) or a radial mesh -! with error bars -! outputs number density (#/vol) - -program density_new -use libatoms_module -implicit none - - type(Dictionary) :: cli_params - character(len=STRING_LENGTH) :: infilename - logical :: infile_is_list - character(len=STRING_LENGTH) :: outfilename - type(Inoutput) :: outfile - character(len=STRING_LENGTH) :: commandfilename - type(Inoutput) :: commandfile - character(len=1024) :: args_str - - character(len=STRING_LENGTH) :: mask_str - integer :: decimation - real(dp) :: min_time, max_time - logical :: gaussian_smoothing - real(dp) :: gaussian_sigma - logical :: radial_histo, random_samples - real(dp) :: radial_center(3) - integer :: n_samples(2) - logical :: sort_Time, no_Time_dups - real(dp) :: min_p(3), bin_width(3) - integer :: n_bins(3) - logical :: quiet - logical :: autocorrelation, mean - integer :: autocorrelation_max_lag - real(dp) :: mean_decorrelation_time - logical :: have_params - integer :: status, arg_line_no - - logical :: no_compute_index - integer :: n_histos - type(Atoms_ll) :: structure_ll - real(dp), allocatable :: histograms(:,:,:,:), histo_grid(:,:,:,:), histo_mean(:,:,:), histo_var(:,:,:) - integer :: i_lag, i1, i2, i3 - real(dp), allocatable :: autocorr(:,:,:,:) - - call system_initialise(PRINT_NORMAL) - - call initialise(cli_params) - call register_cli_params(cli_params,.true., infilename, infile_is_list, outfilename, commandfilename, & - mask_str, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, & - radial_histo, radial_center, random_samples, n_samples, & - sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) - if (.not. param_read_args(cli_params)) then - call print_usage() - call system_abort('could not parse argument line') - end if - - call print("Reading configurations") - call read_xyz(structure_ll, infilename, infile_is_list, decimation, min_time, max_time, sort_Time, no_Time_dups, quiet, no_compute_index) - - if (len_trim(commandfilename) == 0) then - args_str = write_string(cli_params) - call finalise(cli_params) - else - call finalise(cli_params) - call print("reading commands from file '"//trim(commandfilename)//"'") - call initialise(commandfile, trim(commandfilename), INPUT) - arg_line_no = 1 - args_str = read_line(commandfile) - call initialise(cli_params) - call print("got arguments line '"//trim(args_str)//"'") - call register_cli_params(cli_params,.false., infilename, infile_is_list, outfilename, commandfilename, & - mask_str, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, & - radial_histo, radial_center, random_samples, n_samples, & - sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) - if (.not. param_read_line(cli_params, trim(args_str), ignore_unknown = .true.)) then - call print_usage() - call system_abort("could not parse argument line "//arg_line_no//" from file '"//trim(commandfilename//"'")) - end if - call finalise(cli_params) - endif - - have_params = .true. - do while (have_params) - no_compute_index=.false. - if ((.not. sort_Time) .and. (.not. no_Time_dups)) no_compute_index=.true. - - call print("infile " // trim(infilename) // " infile_is_list " // infile_is_list) - call print("outfilename " // trim(outfilename)) - call print("decimation " // decimation // " min_time " // min_time // " max_time " // max_time) - call print("AtomMask " // trim(mask_str)) - call print("radial_histo " // radial_histo) - if (radial_histo) then - call print("radial_center " // radial_center) - call print("bin_width " // bin_width(1) // " n_bins " // n_bins(1)) - n_bins(2:3) = 1 - call print("random_samples " // random_samples) - if (random_samples) then - call print("n_samples " // n_samples(1)) - else - call print("n_theta " // n_samples(1) // " n_phi " // n_samples(2)) - endif - else - call print("min_p " // min_p) - call print("bin_width " // bin_width // " n_bins " // n_bins) - endif - call print("gaussian " // gaussian_smoothing // " sigma " // gaussian_sigma) - call print("sort_Time " // sort_Time // " no_Time_dups " // no_Time_dups) - call print("mean " // mean // " mean_decorrelation_time " // mean_decorrelation_time) - call print("autocorrelation " // autocorrelation // " autocorrelation_max_lag " // autocorrelation_max_lag) - - call print("Calculating densities") - call calc_histos(histograms, n_histos, histo_grid, min_p, bin_width, n_bins, structure_ll, & - mean_decorrelation_time, gaussian_smoothing, gaussian_sigma, & - radial_histo, radial_center, random_samples, n_samples, mask_str, quiet) - - call initialise(outfile, outfilename, OUTPUT) - - if (autocorrelation) then - call print("Calculating autocorrelations") - allocate(autocorr(n_bins(1),n_bins(2),n_bins(3),autocorrelation_max_lag+1)) - autocorr = autocorrelation_3array(histograms(:,:,:,1:n_histos), max_lag=autocorrelation_max_lag) - - call print("Printing autocorrelations") - call print("# Autocorrelation", file=outfile) - do i_lag=0, autocorrelation_max_lag - call print(i_lag // " " // reshape(autocorr(1:n_bins(1),1:n_bins(2),1:n_bins(3),i_lag+1), & - (/ n_bins(1)*n_bins(2)*n_bins(3) /)), file=outfile) - end do - endif - - if (mean) then - if (autocorrelation) then - call print("", file=outfile) - call print("", file=outfile) - endif - allocate(histo_mean(n_bins(1), n_bins(2), n_bins(3))) - allocate(histo_var(n_bins(1), n_bins(2), n_bins(3))) - call calc_mean_var_3array(histograms(:,:,:,1:n_histos), histo_mean, histo_var) - - if (radial_histo) then - call print("# Density (#/vol) ", file=outfile) - call print("# r mean var n_samples", file=outfile) - do i1=1, n_bins(1) - call print(histo_grid(1,i1,1,1) // " " // histo_mean(i1, 1, 1) // " " // & - histo_var(i1, 1, 1) // " " // n_histos, file=outfile) - end do - else - call print("# Density (#/vol)", file=outfile) - call print("# x y z mean var n_samples", file=outfile) - do i1=1,n_bins(1) - do i2=1,n_bins(2) - do i3=1,n_bins(3) - call print( histo_grid(:,i1,i2,i3) // & - " " // histo_mean(i1, i2, i3) // & - " " // histo_var(i1, i2, i3) // " " // n_histos, file=outfile) - end do - call print('', file=outfile) - end do - call print('', file=outfile) - end do - endif - end if - - call finalise(outfile) - - if (allocated(histograms)) deallocate(histograms) - if (allocated(histo_grid)) deallocate(histo_grid) - if (allocated(autocorr)) deallocate(autocorr) - if (allocated(histo_mean)) deallocate(histo_mean) - if (allocated(histo_var)) deallocate(histo_var) - - if (len_trim(commandfilename) == 0) then - have_params = .false. - else - arg_line_no = arg_line_no + 1 - args_str = read_line(commandfile, status=status) - if (status == 0) then - call print("got arguments line '"//trim(args_str)//"'") - call initialise(cli_params) - call register_cli_params(cli_params,.false., infilename, infile_is_list, outfilename, commandfilename, & - mask_str, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, & - radial_histo, radial_center, random_samples, n_samples, & - sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) - if (.not. param_read_line(cli_params, trim(args_str), ignore_unknown = .true.)) then - call print_usage() - call system_abort("could not parse argument line "//arg_line_no//" from file '"//trim(commandfilename//"'")) - end if - call finalise(cli_params) - else - have_params = .false. - endif - endif - - end do - - call system_finalise() - -contains - - subroutine print_usage() - - character(len=1024) my_exec_name - - if (EXEC_NAME == "") then - my_exec_name="" - else - my_exec_name=EXEC_NAME - endif - - call print("Usage: " // trim(my_exec_name)//" infile=filename [infile_is_list=logical(F)]", PRINT_ALWAYS) - call print(" outfile=filename [commandfile=filename()] [AtomMask=species()] [min_p={x y z}]", PRINT_ALWAYS) - call print(" bin_width={x y z}(y,z ignored for radial_histo) n_bins={nx ny nz}(y,z ignored for radial_histo)", PRINT_ALWAYS) - call print(" [mean=logical(T)] [mean_decorrelation_time=t(0.0)]", PRINT_ALWAYS) - call print(" [autocorrelation=logical(F)] [autocorrelation_max_lag=N(10000)]", PRINT_ALWAYS) - call print(" [decimation=n(1)] [min_time=t(-1.0)] [max_time=t(-1.0)]", PRINT_ALWAYS) - call print(" [gaussian=logical(F)(always true for radial_histo)] [sigma=s(1.0)] [radial_histo=logical(F)]", PRINT_ALWAYS) - call print(" [radial_center={x y z}] [random_samples=logical(F)(radial_histo only)] [n_samples={2 4})(component 2 ignored for random)]", PRINT_ALWAYS) - call print(" [sort_Time(F)] [no_Time_dups(F)]", PRINT_ALWAYS) - call print(" [quiet=logical(F)]", PRINT_ALWAYS) - end subroutine print_usage - - subroutine register_cli_params(cli_params, initial, infilename, infile_is_list, outfilename, commandfilename, & - mask_str, min_p, bin_width, n_bins, decimation, min_time, max_time, gaussian_smoothing, gaussian_sigma, & - radial_histo, radial_center, random_samples, n_samples, & - sort_Time, no_Time_dups, mean, mean_decorrelation_time, autocorrelation, autocorrelation_max_lag, quiet) - type(Dictionary), intent(inout) :: cli_params - logical, intent(in) :: initial - character(len=*), intent(inout) :: infilename - logical, intent(inout) :: infile_is_list - character(len=*), intent(inout) :: outfilename - character(len=*), intent(inout) :: commandfilename - character(len=*), intent(inout) :: mask_str - real(dp), intent(inout) :: min_p(3), bin_width(3) - integer, intent(inout) :: n_bins(3), decimation - real(dp), intent(inout) :: min_time, max_time - logical, intent(inout) :: gaussian_smoothing - real(dp), intent(inout) :: gaussian_sigma - logical, intent(inout) :: radial_histo - real(dp), intent(inout) :: radial_center(3) - logical, intent(inout) :: random_samples - integer, intent(inout) :: n_samples(2) - logical, intent(inout) :: sort_Time, no_Time_dups - logical, intent(inout) :: mean - real(dp), intent(inout) :: mean_decorrelation_time - logical, intent(inout) :: autocorrelation - integer, intent(inout) :: autocorrelation_max_lag - logical, intent(inout) :: quiet - character(len=STRING_LENGTH) :: t_field - - - if (initial) then - call param_register(cli_params, 'infile', param_mandatory, infilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'infile_is_list', 'F', infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'outfile', 'stdout', outfilename, help_string="No help yet. This source file was $LastChangedBy$") - mask_str = "" - commandfilename = "" - call param_register(cli_params, 'commandfile', "", commandfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'AtomMask', "", mask_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_p', "0.0 0.0 0.0", min_p, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'bin_width', PARAM_MANDATORY, bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'n_bins', PARAM_MANDATORY, n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_time', '-1.0', min_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'max_time', '-1.0', max_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'gaussian', 'F', gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sigma', '1.0', gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'radial_histo', 'F', radial_histo, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'radial_center', '0.0 0.0 0.0', radial_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'random_samples', 'F', random_samples, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'n_samples', '2 4', n_samples, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sort_Time', 'F', sort_Time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'no_Time_dups', 'F', no_Time_dups, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'mean', 'T', mean, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'mean_decorrelation_time', '0.0', mean_decorrelation_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'autocorrelation', 'F', autocorrelation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'autocorrelation_max_lag', '10000', autocorrelation_max_lag, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'quiet', 'F', quiet, help_string="No help yet. This source file was $LastChangedBy$") - else - t_field=infilename - call param_register(cli_params, 'infile', trim(t_field), infilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'infile_is_list', ""//infile_is_list, infile_is_list, help_string="No help yet. This source file was $LastChangedBy$") - t_field=outfilename - call param_register(cli_params, 'outfile', trim(t_field), outfilename, help_string="No help yet. This source file was $LastChangedBy$") - t_field=commandfilename - call param_register(cli_params, 'commandfile', trim(t_field), commandfilename, help_string="No help yet. This source file was $LastChangedBy$") - t_field=mask_str - call param_register(cli_params, 'AtomMask', trim(t_field), mask_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_p', ""//min_p, min_p, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'bin_width', ""//bin_width, bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'n_bins', ""//n_bins, n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'min_time', ""//min_time, min_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'max_time', ""//max_time, max_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'gaussian', ""//gaussian_smoothing, gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'sigma', ""//gaussian_sigma, gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'radial_histo', ""//radial_histo, radial_histo, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'radial_center', ""//radial_center, radial_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'random_samples', ""//random_samples, random_samples, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'n_samples', '2 4', n_samples, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'mean', ""//mean, mean, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'mean_decorrelation_time', ""//mean_decorrelation_time, mean_decorrelation_time, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'autocorrelation', ""//autocorrelation, autocorrelation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'autocorrelation_max_lag', ""//autocorrelation_max_lag, autocorrelation_max_lag, help_string="No help yet. This source file was $LastChangedBy$") - endif - end subroutine register_cli_params - - function autocorrelation_scalar(v, max_lag) result(autocorrelation) - real(dp), intent(in) :: v(:) - integer, intent(in) :: max_lag - real(dp) :: autocorrelation(max_lag) - - integer :: lag, i - real(dp) :: t_sum, mean - integer :: nt - - nt = size(v,1) - - mean = sum(v)/real(nt,dp) - do lag=1, max_lag - t_sum = 0.0_dp - do i=1, nt-lag - t_sum = t_sum + (v(i)-mean)*(v(i+lag)-mean) - end do - autocorrelation(lag) = t_sum/real(nt-lag,dp) - end do - - end function autocorrelation_scalar - - function autocorrelation_3array(v, max_lag) result(autocorrelation) - real(dp), intent(in) :: v(:,:,:,:) - integer, intent(in) :: max_lag - real(dp) :: autocorrelation(size(v,1),size(v,2),size(v,3),max_lag+1) - - integer :: lag, i - real(dp), allocatable :: t_sum(:,:,:), mean(:,:,:) - integer :: n1, n2, n3, nt - - n1 = size(v,1) - n2 = size(v,2) - n3 = size(v,3) - nt = size(v,4) - allocate(t_sum(n1,n2,n3), mean(n1,n2,n3)) - - mean = sum(v,4)/real(nt,dp) - do lag=0, max_lag - t_sum = 0.0_dp - do i=1, nt-lag - t_sum(1:n1,1:n2,1:n3) = t_sum(1:n1,1:n2,1:n3) + (v(1:n1,1:n2,1:n3,i)-mean)*(v(1:n1,1:n2,1:n3,i+lag)-mean) - end do - autocorrelation(1:n1,1:n2,1:n3,lag+1) = t_sum(1:n1,1:n2,1:n3)/real(nt-lag,dp) - end do - - deallocate(t_sum, mean) - - end function autocorrelation_3array - - subroutine calc_histos(histograms, n_histos, histo_grid, min_p, bin_width, n_bins, & - structure_ll, interval, gaussian, gaussian_sigma, & - radial_histo, radial_center, random_samples, n_samples, mask_str, quiet) - real(dp), intent(inout), allocatable :: histograms(:,:,:,:) - integer, intent(out) :: n_histos - real(dp), intent(inout), allocatable :: histo_grid(:,:,:,:) - real(dp), intent(in) :: min_p(3), bin_width(3) - integer, intent(in) :: n_bins(3) - type(atoms_ll), intent(in) :: structure_ll - real(dp), intent(in) :: interval - logical, intent(in) :: gaussian - real(dp), intent(in) :: gaussian_sigma - logical, intent(in) :: radial_histo - real(dp), intent(in) :: radial_center(3) - logical :: random_samples - integer :: n_samples(2) - character(len=*), optional, intent(in) :: mask_str - logical, optional :: quiet - - real(dp) :: last_time, cur_time - type(atoms_ll_entry), pointer :: entry - logical :: do_this_histo, first_histo - real(dp), allocatable :: theta(:), phi(:), w(:) - logical :: my_quiet - - my_quiet = optional_default(.false., quiet) - n_histos = 0 - allocate(histograms(n_bins(1),n_bins(2),n_bins(3),10)) - if (radial_histo) then - allocate(histo_grid(1,n_bins(1),n_bins(2),n_bins(3))) - else - allocate(histo_grid(3,n_bins(1),n_bins(2),n_bins(3))) - endif - histograms = 0.0_dp - - if (radial_histo) then - if (random_samples) then - call calc_angular_samples_random(n_samples(1), theta, phi, w) - else - call calc_angular_samples_grid(n_samples(1), n_samples(2), theta, phi, w) - endif - endif - - first_histo = .true. - entry => structure_ll%first - cur_time = -1.0_dp - last_time = -1.0e38_dp - do while (associated(entry)) - do_this_histo = .false. - if (interval > 0.0_dp) then - if (cur_time < last_time) & - call system_abort("calc_histos called with interval="//interval//" > 0, but unsorted sequence: cur_time="// & - cur_time//" < last_time="//last_time) - if (.not. get_value(entry%at%params, "Time", cur_time)) & - call system_abort("calc_histos called with interval="//interval//" > 0, but no Time value in entry") - if ((cur_time .feq. last_time) .or. (cur_time >= last_time+interval)) then - do_this_histo = .true. - if (cur_time >= last_time+interval) last_time = cur_time - endif - else - do_this_histo = .true. - endif - if (do_this_histo) then - ! if (get_value(entry%at%params, "Time", cur_time)) call print("doing histo for config with time " // cur_time) - n_histos = n_histos + 1 - if (.not. my_quiet) then - if (mod(n_histos,1000) == 1) write (mainlog%unit,'(I4,a)') int(n_histos/1000)," " - if (mod(n_histos,10) == 0) write (mainlog%unit,'(I1,$)') mod(n_histos/10,10) - if (mod(n_histos,1000) == 0) write (mainlog%unit,'(a)') " " - endif - call reallocate_histos(histograms, n_histos, n_bins) - if (radial_histo) then - if (first_histo) then - call sample_radial_mesh_Gaussians(histograms(:,1,1,n_histos), entry%at, radial_center, bin_width(1), n_bins(1), gaussian_sigma, & - theta, phi, w, mask_str, histo_grid(1,:,1,1)) - else - call sample_radial_mesh_Gaussians(histograms(:,1,1,n_histos), entry%at, radial_center, bin_width(1), n_bins(1), gaussian_sigma, & - theta, phi, w, mask_str) - endif - else ! rectilinear - if (gaussian) then - if (first_histo) then - call sample_rectilinear_mesh_Gaussians(histograms(:,:,:,n_histos), entry%at, min_p, bin_width, n_bins, gaussian_sigma, mask_str, histo_grid(:,:,:,:)) - else - call sample_rectilinear_mesh_Gaussians(histograms(:,:,:,n_histos), entry%at, min_p, bin_width, n_bins, gaussian_sigma, mask_str) - endif - else - if (first_histo) then - call calc_histogram(histograms(:,:,:,n_histos), entry%at, min_p, bin_width, n_bins, mask_str, histo_grid(:,:,:,:)) - else - call calc_histogram(histograms(:,:,:,n_histos), entry%at, min_p, bin_width, n_bins, mask_str) - endif - endif - endif - endif - entry => entry%next - end do - end subroutine calc_histos - - subroutine calc_angular_samples_grid(n_t, n_p, theta, phi, w) - integer, intent(in) :: n_t, n_p - real(dp), allocatable, intent(inout) :: theta(:), phi(:), w(:) - - integer :: t_i, p_i, ii - - if (allocated(theta)) deallocate(theta) - if (allocated(phi)) deallocate(phi) - if (allocated(w)) deallocate(w) - allocate(theta(n_t*n_p)) - allocate(phi(n_t*n_p)) - allocate(w(n_t*n_p)) - - ii = 1 - do t_i=1, n_t - do p_i=1, n_p - phi(ii) = (p_i-1)*2.0_dp*PI/real(n_p,dp) - if (mod(n_t,2) == 0) then - theta(ii) = (t_i-1.5_dp-floor((n_t-1)/2.0_dp))*PI/real(n_t,dp) - else - theta(ii) = (t_i-1-floor((n_t-1)/2.0_dp))*PI/real(n_t,dp) - endif - ! not oversample top and bottom of spehre - w(ii) = cos(theta(ii)) - ii = ii + 1 - end do - end do - w = w / ( (gaussian_sigma*sqrt(2.0_dp*PI))**3 * sum(w) ) - end subroutine calc_angular_samples_grid - - subroutine calc_angular_samples_random(n, theta, phi, w) - integer, intent(in) :: n - real(dp), allocatable, intent(inout) :: theta(:), phi(:), w(:) - - integer :: ii - real(dp) :: p(3), p_norm - - if (allocated(theta)) deallocate(theta) - if (allocated(phi)) deallocate(phi) - if (allocated(w)) deallocate(w) - allocate(theta(n)) - allocate(phi(n)) - allocate(w(n)) - - do ii = 1, n - p_norm = 2.0_dp - do while (p_norm > 1.0_dp) - p = 0.0_dp - call randomise(p, 2.0_dp) - p_norm = norm(p) - end do - phi(ii) = atan2(p(2),p(1)) - theta(ii) = acos(p(3)/p_norm) - w(ii) = 1.0_dp - end do - w = w / ( (gaussian_sigma*sqrt(2.0_dp*PI))**3 * sum(w) ) - - end subroutine calc_angular_samples_random - - subroutine sample_radial_mesh_Gaussians(histogram, at, radial_center, bin_width, n_bins, gaussian_sigma, theta, phi, w, mask_str, histo_grid, accumulate) - real(dp), intent(inout) :: histogram(:) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: radial_center(3) - real(dp), intent(in) :: bin_width - integer, intent(in) :: n_bins - real(dp), intent(in) :: gaussian_sigma, theta(:), phi(:), w(:) - character(len=*), optional, intent(in) :: mask_str - real(dp), intent(out), optional :: histo_grid(:) - logical, optional, intent(in) :: accumulate - - logical :: my_accumulate - real(dp) :: bin_r, p(3), dist, r - logical, allocatable :: mask_a(:) - integer at_i, sample_i, bin_i - - my_accumulate = optional_default(.false., accumulate) - if (.not. my_accumulate) histogram = 0.0_dp - - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - -! ratio of 20/4=5 is bad -! ratio of 20/3=6.66 is bad -! ratio of 20/2.5=8 is borderline (2e-4) -! ratio of 20/2.22=9 is fine (error 2e-5) -! ratio of 20/2=10 is fine - if ( (norm(at%lattice(:,1)) < 9.0_dp*gaussian_sigma) .or. & - (norm(at%lattice(:,2)) < 9.0_dp*gaussian_sigma) .or. & - (norm(at%lattice(:,3)) < 9.0_dp*gaussian_sigma) ) & - call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) - - if (present(histo_grid)) then - do bin_i=1, n_bins - bin_r = (bin_i-1)*bin_width - histo_grid(bin_i) = bin_r - end do - endif - - do at_i=1, at%N - if (.not. mask_a(at_i)) cycle - r = norm(at%pos(:,at_i)) - do bin_i=1, n_bins - bin_r = (bin_i-1)*bin_width - do sample_i=1,size(theta) - p(1) = radial_center(1)+bin_r*cos(phi(sample_i))*cos(theta(sample_i)) - p(2) = radial_center(2)+bin_r*sin(phi(sample_i))*cos(theta(sample_i)) - p(3) = radial_center(3)+bin_r*sin(theta(sample_i)) - dist = distance_min_image(at,p,at%pos(:,at_i)) -!Include all the atoms, slow but minimises error -! if (dist > 4.0_dp*gaussian_sigma) cycle - histogram(bin_i) = histogram(bin_i) + exp(-0.5_dp*(dist/(gaussian_sigma))**2)*w(sample_i) - end do ! sample_i - end do ! bin_i - end do ! at_i - - deallocate(mask_a) - end subroutine sample_radial_mesh_Gaussians - - subroutine sample_rectilinear_mesh_Gaussians(histogram, at, min_p, sample_dist, n_bins, gaussian_sigma, mask_str, histo_grid, accumulate) - real(dp), intent(inout) :: histogram(:,:,:) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: min_p(3), sample_dist(3) - integer, intent(in) :: n_bins(3) - real(dp), intent(in) :: gaussian_sigma - character(len=*), optional, intent(in) :: mask_str - real(dp), intent(out), optional :: histo_grid(:,:,:,:) - logical, optional, intent(in) :: accumulate - - logical :: my_accumulate - integer :: at_i, i1, i2, i3 - real(dp) :: p(3), w, dist - logical, allocatable :: mask_a(:) - - my_accumulate = optional_default(.false., accumulate) - if (.not. my_accumulate) histogram = 0.0_dp - - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - -! ratio of 20/4=5 is bad -! ratio of 20/3=6.66 is bad -! ratio of 20/2.5=8 is borderline (2e-4) -! ratio of 20/2.22=9 is fine (error 2e-5) -! ratio of 20/2=10 is fine - if ( (norm(at%lattice(:,1)) < 9.0_dp*gaussian_sigma) .or. & - (norm(at%lattice(:,2)) < 9.0_dp*gaussian_sigma) .or. & - (norm(at%lattice(:,3)) < 9.0_dp*gaussian_sigma) ) & - call print("WARNING: at%lattice may be too small for sigma, errors (noticeably too low a density) may result", PRINT_ALWAYS) - - w = 1.0_dp / (gaussian_sigma*sqrt(2.0_dp*PI))**3 - - if (present(histo_grid)) then - do i1=1, n_bins(1) - p(1) = min_p(1) + (i1-1)*sample_dist(1) - do i2=1, n_bins(2) - p(2) = min_p(2) + (i2-1)*sample_dist(2) - do i3=1, n_bins(3) - p(3) = min_p(3) + (i3-1)*sample_dist(3) - histo_grid(:,i1,i2,i3) = p - end do - end do - end do - endif - - do at_i=1, at%N - if (.not. mask_a(at_i)) cycle - do i1=1, n_bins(1) - p(1) = min_p(1) + (i1-1)*sample_dist(1) - do i2=1, n_bins(2) - p(2) = min_p(2) + (i2-1)*sample_dist(2) - do i3=1, n_bins(3) - p(3) = min_p(3) + (i3-1)*sample_dist(3) - dist = distance_min_image(at,p,at%pos(:,at_i)) - histogram(i1,i2,i3) = histogram(i1,i2,i3) + exp(-0.5_dp*(dist/(gaussian_sigma))**2)*w - end do ! i3 - end do ! i2 - end do ! i1 - end do ! at_i - - deallocate(mask_a) - end subroutine sample_rectilinear_mesh_Gaussians - - subroutine calc_histogram(histogram, at, min_p, bin_width, n_bins, mask_str, histo_grid, accumulate) - real(dp), intent(inout) :: histogram(:,:,:) - type(Atoms), intent(in) :: at - real(dp), intent(in) :: min_p(3), bin_width(3) - integer, intent(in) :: n_bins(3) - character(len=*), optional, intent(in) :: mask_str - real(dp), intent(out), optional :: histo_grid(:,:,:,:) - logical, optional, intent(in) :: accumulate - - logical :: my_accumulate - integer :: i, bin(3) - logical, allocatable :: mask_a(:) - real(dp) :: p(3) - - my_accumulate = optional_default(.false., accumulate) - if (.not. my_accumulate) histogram = 0.0_dp - - if (present(histo_grid)) then - do i1=1, n_bins(1) - p(1) = min_p(1) + (real(i1,dp)-0.5_dp)*bin_width(1) - do i2=1, n_bins(2) - p(2) = min_p(2) + (real(i2,dp)-0.5_dp)*bin_width(2) - do i3=1, n_bins(3) - p(3) = min_p(3) + (real(i3,dp)-0.5_dp)*bin_width(3) - histo_grid(:,i1,i2,i3) = p - end do - end do - end do - endif - - allocate(mask_a(at%N)) - call is_in_mask(mask_a, at, mask_str) - - do i=1, at%N - if (.not. mask_a(i)) cycle - bin = floor((at%pos(:,i)-min_p)/bin_width)+1 - if (all(bin >= 1) .and. all (bin <= n_bins)) histogram(bin(1),bin(2),bin(3)) = histogram(bin(1),bin(2),bin(3)) + 1.0_dp - end do - - deallocate(mask_a) - - end subroutine calc_histogram - - subroutine is_in_mask(mask_a, at, mask_str) - type(Atoms), intent(in) :: at - logical, intent(out) :: mask_a(at%N) - character(len=*), optional, intent(in) :: mask_str - - integer :: i - integer :: Zmask - type(Table) :: atom_indices - - if (.not. present(mask_str)) then - mask_a = .true. - return - endif - - if (len_trim(mask_str) == 0) then - mask_a = .true. - return - endif - - mask_a = .false. - if (mask_str(1:1)=='@') then - call parse_atom_mask(mask_str,atom_indices) - do i=1, atom_indices%N - mask_a(atom_indices%int(1,i)) = .true. - end do - else if (scan(mask_str,'=')/=0) then - call system_abort("property type mask not supported yet") - else - Zmask = Atomic_Number(mask_str) - do i=1, at%N - if (at%Z(i) == Zmask) mask_a(i) = .true. - end do - end if - end subroutine is_in_mask - - subroutine reallocate_histos(histos, n, n_bins) - real(dp), allocatable, intent(inout) :: histos(:,:,:,:) - integer, intent(in) :: n, n_bins(3) - - integer :: new_size - real(dp), allocatable :: t_histos(:,:,:,:) - - if (allocated(histos)) then - if (n <= size(histos,4)) return - allocate(t_histos(size(histos,1),size(histos,2),size(histos,3),size(histos,4))) - t_histos = histos - deallocate(histos) - if (size(t_histos,4) <= 0) then - new_size = 10 - else if (size(t_histos,4) < 1000) then - new_size = 2*size(t_histos,4) - else - new_size = floor(1.25*size(t_histos,4)) - endif - allocate(histos(size(t_histos,1), size(t_histos,2), size(t_histos,3), new_size)) - histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),1:size(t_histos,4)) = & - t_histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),1:size(t_histos,4)) - histos(1:size(t_histos,1),1:size(t_histos,2),1:size(t_histos,3),size(t_histos,4)+1:size(histos,4)) = 0.0_dp - deallocate(t_histos) - else - allocate(histos(n_bins(1), n_bins(2), n_bins(3), n)) - endif - end subroutine reallocate_histos - - subroutine calc_mean_var_3array(a, mean, var) - real(dp), intent(in) :: a(:,:,:,:) - real(dp), intent(out) :: mean(:,:,:) - real(dp), optional, intent(out) :: var(:,:,:) - - integer :: i1, i2, i3, n - - n = size(a,4) - mean = sum(a, 4)/real(n,dp) - if (present(var)) then - do i1=1, size(a,1) - do i2=1, size(a,2) - do i3=1, size(a,3) - var(i1,i2,i3) = sum((a(i1,i2,i3,:)-mean(i1,i2,i3))**2)/real(n,dp) - end do - end do - end do - end if - end subroutine calc_mean_var_3array - -end program density_new diff --git a/src/Structure_processors/diffusion.f95 b/src/Structure_processors/diffusion.f95 deleted file mode 100644 index 8401252095..0000000000 --- a/src/Structure_processors/diffusion.f95 +++ /dev/null @@ -1,168 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!diffusion constant calculating helper program. -!prints the average square displacement as the function of the frames. -!The diffusivity can be calculated by fitting 4*D*t to (t). -program diffusion - -use libatoms_module - - implicit none - - - type(Atoms) :: structure, reference, prev_structure - type(CInoutput) :: xyzfile - type(Inoutput) :: datafile - real(dp) :: ave_r2, one_r2, d - integer :: frame_count, frames_processed - integer :: i, shift(3) - integer :: error - integer, allocatable, dimension(:,:) :: travel - - !Input - type(Dictionary) :: params_in - character(STRING_LENGTH) :: xyzfilename, datafilename - integer :: from, to - integer :: IO_Rate - integer :: one_atom - - call system_initialise(PRINT_SILENT) - call verbosity_push(PRINT_NORMAL) - - call initialise(params_in) - call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'datafile', param_mandatory, datafilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'from', '1', from, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'one_atom', '0', one_atom, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(params_in)) then - call print('diffusion xyzfile datafile [from=1] [to=0] [one_atom] [IO_Rate]') - call system_abort('could not parse argument line') - end if - call finalise(params_in) - - if (from<1) call system_abort('from must be a positive intger.') - ! Read the input and output filename and open them - call initialise(xyzfile,xyzfilename,action=INPUT) - call initialise(datafile,datafilename,action=OUTPUT) - call print('#average displacement square of all the atoms',file=datafile) - - call print(' Input file: '//trim(xyzfilename)) - call print('Output file: '//trim(datafilename)) - call print('From step '//from//' to step '//to) - call print('Also check atom '//one_atom) - call print('') - - call print('Reading data...') - - call read(structure, xyzfile, error=error) - call map_into_cell(structure) - - allocate(travel(3,structure%N)) - travel = 0 - - frame_count = 0 - frames_processed = 0 - - do - - if (error/=0) exit - - frame_count = frame_count + 1 - - if ((frame_count.gt.to) .and. (to.gt.0)) exit - - write(mainlog%unit,'(a,a,i0,a,$)') achar(13),'Frame ',frame_count, ' ' - - if (frame_count.eq.from) then - call print('Reference structure is at step '//frame_count) - reference = structure - prev_structure = structure - travel=0 - endif - - if (frame_count.ge.from) then - frames_processed = frames_processed + 1 - - - ! now detect wrappings - do i=1,structure%N - if(normsq(structure%pos(:,i)-prev_structure%pos(:,i)) > 1) then - ! atom wrapped - d = distance_min_image(structure, i, prev_structure%pos(:,i), shift) - travel(:,i) = travel(:,i) - shift - endif - end do - - one_r2 = 0._dp - ave_r2 = 0._dp - do i = 1, structure%N - ave_r2 = ave_r2 + normsq(reference%pos(:,i) - structure%pos(:,i) - (structure%lattice .mult. travel(:,i))) - enddo - ave_r2 = ave_r2 / structure%N - if (one_atom.ne.0) then - one_r2 = normsq(reference%pos(:,one_atom) - structure%pos(:,one_atom) - (structure%lattice .mult. travel(:,one_atom))) - endif - - if (mod(frame_count-1,IO_Rate).eq.0) then - if (one_atom.eq.0) then - call print(frame_count//' '//ave_r2,file=datafile) - else - call print(frame_count//' '//ave_r2//' '//one_r2,file=datafile) - endif - endif - - prev_structure=structure - - endif - - - call read(structure,xyzfile,error=error) - call map_into_cell(structure) - - end do - - call print('') - call print('Read '//frame_count//' frames, processed '//frames_processed//' frames.') - - !Free up memory - call finalise(structure) - call finalise(reference) - call finalise(xyzfile) - call finalise(datafile) - - call print('Finished.') - - call verbosity_pop - call system_finalise - -end program diffusion diff --git a/src/Structure_processors/elastic_fields.f95 b/src/Structure_processors/elastic_fields.f95 deleted file mode 100644 index 9d78c3980b..0000000000 --- a/src/Structure_processors/elastic_fields.f95 +++ /dev/null @@ -1,106 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program elastic - - use libAtoms_module - use elasticity_module, only: elastic_fields - - implicit none - - type(Atoms) :: at - type(CInoutput) :: infile, outfile - type(Dictionary) :: params - integer :: i, n, iostat, nargs - character(len=2048) :: comment, arg1, arg2, missing_params - real(dp) :: a, C11, C12, C44, l_cutoff, nneightol - - call system_initialise(PRINT_SILENT) - call verbosity_push(PRINT_NORMAL) - - call initialise(params) - - call param_register(params, 'a', PARAM_MANDATORY, a, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'C11', PARAM_MANDATORY, C11, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'C12', PARAM_MANDATORY, C12, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'C44', PARAM_MANDATORY, C44, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'cutoff', '5.0', l_cutoff, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'nneightol', '1.2', nneightol, help_string="No help yet. This source file was $LastChangedBy$") - - nargs = cmd_arg_count() - - if (nargs < 2) then - call print('Usage: elastic_fields [params]') - call print('') - call print('Parameters and default values are:') - call param_print(params) - call verbosity_push(PRINT_SILENT) - call system_finalise() - stop - end if - - call get_cmd_arg(1, arg1) - call get_cmd_arg(2, arg2) - - call initialise(infile, arg1) - call initialise(outfile, arg2, action=OUTPUT) - - - if (nargs > 2) then - if (.not. param_read_args(params, (/ (i, i=3,nargs ) /))) & - call system_abort('Error parsing command line') - end if - - if (.not. param_check(params, missing_params)) & - call system_abort('Missing mandatory parameters: '//missing_params) - - call print('Parameters:') - call param_print(params) - call print('') - - - ! Loop over all frames in input file - do n=0,infile%n_frame-1 - call read(infile, at, frame=n) - - call print('Frame '//n) - - call set_cutoff(at, l_cutoff) - at%nneightol = nneightol - - call elastic_fields(at, a, C11, C12, C44) - call write(outfile, at) - end do - call print('Done '//n//' frames!') - - call verbosity_push(PRINT_SILENT) - call system_finalise - -end program elastic diff --git a/src/Structure_processors/extract_EVB.f95 b/src/Structure_processors/extract_EVB.f95 deleted file mode 100644 index 62e1f97909..0000000000 --- a/src/Structure_processors/extract_EVB.f95 +++ /dev/null @@ -1,227 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!Program to calculate the EVB E_GAP given -! -- an XYZ file with the coordinates, -! -- 2 PSF files with the 2 resonance states -! -- a form_bond_file containing the pair of atoms that form a bond in PSF1, but not in PSF2 -! -- a break_bond_file containing the pair of atoms that form a bond in PSF2, but not in PSF1 -! -program extract_EVB - - use libatoms_module - use potential_module - - implicit none - - type(Atoms) :: at - type(CInoutput) :: coord_file - type(InOutput) :: out_file - integer :: iframe, step_nr - real(dp) :: time_passed - real(dp) :: energy1, energy2 - !real(dp), allocatable :: f1(:,:) - character(len=STRING_LENGTH), allocatable :: output_lines(:) - integer :: lines_used, i - - type(Potential) :: pot - type(Potential) :: evbpot - character(len=STRING_LENGTH) :: args_str - character(STRING_LENGTH) :: mm_args_str - - !Input parameters - type(Dictionary) :: params_in - character(len=STRING_LENGTH) :: coord_filename, out_filename - character(len=STRING_LENGTH) :: PSF_file1, PSF_file2, & - filepot_program, cp2k_program !, Residue_Library - integer :: last_frame - real(dp) :: time_step - logical :: append_output - integer :: restart_every - - - call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) - call system_timer('program') - - !INPUT - call initialise(params_in) - call param_register(params_in, 'coord_file', PARAM_MANDATORY, coord_filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'outfile', PARAM_MANDATORY, out_filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'PSF_file1', PARAM_MANDATORY, PSF_file1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'PSF_file2', PARAM_MANDATORY, PSF_file2, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'filepot_program', PARAM_MANDATORY, filepot_program, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'cp2k_program', PARAM_MANDATORY, cp2k_program, help_string="No help yet. This source file was $LastChangedBy$") - !call param_register(params_in, 'Residue_Library', PARAM_MANDATORY, Residue_Library, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'last_frame', '0', last_frame, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'time_step', '0.0', time_step, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'append_output', 'F', append_output, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'restart_every', '1', restart_every, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not. param_read_args(params_in)) then - !call print_usage - call print("extract_EVB coord_file outfile PSF_file1 PSF_file2 filepot_program cp2k_program [last_frame] [time_step] [append_output] [restart_every]",PRINT_ALWAYS) - call system_abort('could not parse argument line') - end if - - call finalise(params_in) - - !PRINT INPUT PARAMETERS - call print('Run parameters:') - call print(' coord_file '// trim(coord_filename) ) - call print(' outfile '// trim(out_filename) ) - call print(' PSF_file1 '// trim(PSF_file1) ) - call print(' PSF_file2 '// trim(PSF_file2) ) - !call print(' Residue_Library '// trim(Residue_Library) ) - call print(' cp2k_program '// trim(cp2k_program) ) - call print(' filepot_program '// trim(filepot_program) ) - call print(' last_frame '// last_frame ) - call print(' time_step '// time_step ) - call print(' restart_every '// restart_every//' steps' ) - if (restart_every/=1) call print(' Prints after every '//restart_every//' steps, synchronised with the restart frequency.') - if (append_output) then - call print(" Will not overwrite out_file (appending probably restart).") - else - call print(" Will overwrite out_file!!") - endif - call print('---------------------------------------') - call print('') - - - !Read coordinates and colvars - call print('Reading in the coordinates from file '//trim(coord_filename)//'...') - call initialise(coord_file, coord_filename, action=INPUT) - call print('Number of frames '//coord_file%n_frame) - - if (last_frame/=0) then - last_frame = min(last_frame, coord_file%n_frame) - else - last_frame = coord_file%n_frame - endif - call print('Last frame to be processed '//last_frame) - - !open output file, append if required - if (append_output) then - call initialise(out_file, out_filename, action=OUTPUT,append=.true.) - else - call initialise(out_file, out_filename, action=OUTPUT,append=.false.) - call print("# Step Nr. Time[fs] Energy_PSF1[eV] Energy_PSF2[eV] EVB(E1-E2)", file=out_file) - endif - - !initialise EVB potential - call initialise(pot,'FilePot command='//trim(filepot_program)//' property_list=pos min_cutoff=0.0') - call initialise(evbpot,args_str='EVB=T form_bond={1 2} break_bond={2 6} offdiagonal_A12=0.0 offdiagonal_mu12=0.0 save_energies=T save_forces=F', & - pot1=pot) - - !setup topology files - call system_command('cp '//trim(PSF_file1)//' quip_cp2k_evb1.psf') - call system_command('cp '//trim(PSF_file2)//' quip_cp2k_evb2.psf') - - - step_nr = 0 - - !allocate printing buffer - allocate(output_lines(restart_every)) - lines_used = 0 - - do iframe = 0, last_frame-1 - - call read(coord_file, at, frame=iframe) - - write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',(iframe+1) - - !get Step_nr and Time - if (.not.get_value(at%params,"i",step_nr)) then - step_nr = step_nr + 1 - endif - if (.not.get_value(at%params,"time",time_passed)) then - time_passed = step_nr * time_step - endif - - !Calculate EVB energy - - mm_args_str="Run_Type=MM cp2k_program="//trim(cp2k_program)//" clean_up_files=T save_output_files=F have_silica_potential=F centre_cp2k=F PSF_Print=USE_EXISTING_PSF" - - args_str = "evb_step="//step_nr//" mm_args_str={"//trim(mm_args_str)//"} topology_suffix1=_evb1 topology_suffix2=_evb2" - ! call set_value(at%params,'Library',trim(Residue_Library)) - - call calc(evbpot,at,energy=energy1,args_str=trim(args_str)) - !allocate(f1(1:3,1:at%N)) - !call calc(evbpot,at,energy=energy1,f=f1,args_str=trim(args_str)) - !deallocate(f1) - !call print_xyz(at,'evb_all.xyz',all_properties=.true.) - - if (.not. get_value(at%params,'EVB1_energy',energy1)) then - call system_abort('Could not find EVB1_energy') - endif - if (.not. get_value(at%params,'EVB2_energy',energy2)) then - call system_abort('Could not find EVB2_energy') - endif - - !Printing - - !if not append_output, we want to print time=0, too - if (.not.append_output .and. iframe==0) then - write (UNIT=output_lines(1),FMT="(I8,F13.3,3F18.8)") & - step_nr, time_passed, energy1, energy2, (energy1-energy2) - call print(output_lines(1),file=out_file) - output_lines(1) = "" - call finalise(at) - cycle - endif - - !printing into buffer - write (UNIT=output_lines(lines_used+1),FMT="(I8,F13.3,3F18.8)") & - step_nr, time_passed, energy1, energy2, (energy1-energy2) - lines_used = lines_used + 1 - - !printing buffer into file - if (lines_used == restart_every) then - do i=1,lines_used - call print(output_lines(i),file=out_file) - output_lines(i) = "" - enddo - deallocate(output_lines) - allocate(output_lines(restart_every)) - lines_used = 0 - endif - - call finalise(at) - - enddo - - call finalise(coord_file) - call finalise(at) - - call print('Finished.') - - call system_timer('program') - call system_finalise - -end program extract_EVB diff --git a/src/Structure_processors/extract_cv.f95 b/src/Structure_processors/extract_cv.f95 deleted file mode 100644 index d48070a363..0000000000 --- a/src/Structure_processors/extract_cv.f95 +++ /dev/null @@ -1,288 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!Program to extract position, velocity and force on certain atoms given -! -- an XYZ file with the coordinates, -! -- an XYZ file with the velocities (can be the same file) in a.u., -! -- an XYZ file with the forces (can be the same file) in a.u., -! -- a file containing the atoms (typically to which the constraint is applied) -! and the output name specified. -!Optionally restarts can be taken into account by printing synchronised -! with the restart frequency (e.g. restart_frequency=20). -!Optionally appends the output (of restart files) to the same outfile (e.g. append_output=T). -! -program extract_cv - - use libatoms_module - - implicit none - - type(Atoms) :: at, at_force, at_velo - type(CInoutput) :: coord_file, velo_file, force_file - type(InOutput) :: out_file - type(Table) :: colvar_atoms - real(dp), pointer :: f(:,:), v(:,:) - character(len=STRING_LENGTH), allocatable :: output_lines(:) - integer :: lines_used - integer :: iframe, step_nr - real(dp) :: time_passed - integer :: i - - !Input parameters - type(Dictionary) :: params_in - character(len=STRING_LENGTH) :: coord_filename - character(len=STRING_LENGTH) :: velo_filename - character(len=STRING_LENGTH) :: force_filename - character(len=STRING_LENGTH) :: out_filename - character(len=STRING_LENGTH) :: colvar_filename - integer :: last_frame - real(dp) :: time_step - integer :: restart_every - logical :: append_output - logical :: input_in_cp2k_units - logical :: skip_extra_firsts - - -! call system_initialise(verbosity=PRINT_ANALYSIS,enable_timing=.true.) -! call system_initialise(verbosity=PRINT_VERBOSE,enable_timing=.true.) - call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) - call system_timer('program') - - !INPUT - call initialise(params_in) - call param_register(params_in, 'coord_file' , PARAM_MANDATORY, coord_filename , help_string="input file containing positions") - call param_register(params_in, 'velo_file' , PARAM_MANDATORY, velo_filename , help_string="input file containing velocities") - call param_register(params_in, 'force_file' , PARAM_MANDATORY, force_filename , help_string="input file containing forces") - call param_register(params_in, 'atomlist_file' , PARAM_MANDATORY, colvar_filename , help_string="file with atomlist whose pos/velo/frc should be extracted") - call param_register(params_in, 'outfile' , PARAM_MANDATORY, out_filename , help_string="output filename") - call param_register(params_in, 'last_frame' , '0' , last_frame , help_string="last frame to be processed") - call param_register(params_in, 'time_step' , '0.0' , time_step , help_string="time step in case there is no Time param in the input posfile") - call param_register(params_in, 'restart_every' , '1' , restart_every , help_string="restart frequency") - call param_register(params_in, 'append_output' , 'F' , append_output , help_string="whether to append to output file") - call param_register(params_in, 'input_in_cp2k_units', 'F' , input_in_cp2k_units , help_string="whether units are in CP2K units or in A, A/fs, eV/A") - call param_register(params_in, 'skip_extra_firsts' ,'F' , skip_extra_firsts , help_string="whether to skip the extra printed first config (for QUIP outputs)") - - if (.not. param_read_args(params_in)) then - call print_usage - call system_abort('could not parse argument line') - end if - - call finalise(params_in) - - !PRINT INPUT PARAMETERS - call print('Run parameters:') - call print(' coord_file '// trim(coord_filename) ) - call print(' velo_file '// trim(velo_filename) ) - call print(' force_file '// trim(force_filename) ) - call print(' outfile '// trim(out_filename) ) - call print(' atomlist_file '// trim(colvar_filename) ) - call print(' last_frame '// last_frame ) - call print(' time_step '// time_step ) - call print(' restart_every '// restart_every//' steps' ) - if (restart_every/=1) call print(' Prints after every '//restart_every//' steps, synchronised with the restart frequency.') - call print(' append_output '//append_output) - if (append_output) then - call print(" Will not overwrite out_file (appending probably restart).") - else - call print(" Will overwrite out_file!!") - endif - call print(' input_in_cp2k_units '//input_in_cp2k_units) - call print(' skip_extra_firsts '//skip_extra_firsts//" ONLY FOR cp2k_units=F !") - call print('---------------------------------------') - call print('') - - - !Read coordinates and colvars - call print('Reading in the coordinates from file '//trim(coord_filename)//'...') - call initialise(coord_file, coord_filename, action=INPUT) - call print('Number of frames '//coord_file%n_frame) - call print('Reading in the velocities from file '//trim(velo_filename)//'...') - call initialise(velo_file, velo_filename, action=INPUT) - call print('Number of frames '//velo_file%n_frame) - call print('Reading in the forces from file '//trim(force_filename)//'...') - call initialise(force_file, force_filename, action=INPUT) - call print('Number of frames '//force_file%n_frame) - - if (last_frame/=0) then - last_frame = min(last_frame, coord_file%n_frame, force_file%n_frame) - else - last_frame = min(coord_file%n_frame, velo_file%n_frame, force_file%n_frame) - endif - call print('Last frame to be processed '//last_frame) - - call print('Reading in the (colvar) atoms from file '//trim(colvar_filename)//'...') - call read_integer_table(colvar_atoms,trim(colvar_filename)) - - !open output file, append if required - if (append_output) then - call initialise(out_file, out_filename, action=OUTPUT,append=.true.) - else - call initialise(out_file, out_filename, action=OUTPUT,append=.false.) - call print("# Step Nr. Time[fs] Atom Nr. Pos_x[A] Pos_y[A] Pos_z[A] Vel_x[A/fs] Vel_y[A/fs] Vel_z[A/fs] Frc_x[eV/A] Frc_y[eV/A] Frc_z[eV/A]", file=out_file) - !call print("# Step Nr. Time[fs] Atom Nr. Pos.[A] Vel.[A/fs] Force[eV/A]",file=out_file) - endif - - step_nr = 0 - - !allocate printing buffer - allocate(output_lines(restart_every*colvar_atoms%N)) - lines_used = 0 - - do iframe = 0, last_frame-1 - - call read(coord_file, at, frame=iframe) - call read(velo_file, at_velo, frame=iframe) - call read(force_file, at_force, frame=iframe) - - write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',(iframe+1) - - if (iframe==0) then !check colvar atoms - if (any(colvar_atoms%int(1,1:colvar_atoms%N).gt.at%N)) & - call system_abort("Constraint atom(s) is >"//at%N) - - if ((.not.input_in_cp2k_units) .and. skip_extra_firsts) cycle !skip very first without force information - endif - if (iframe==1) then - if ((.not.input_in_cp2k_units) .and. skip_extra_firsts .and. append_output) cycle !skip the overlapping second for the restarts - endif - - !get Step_nr and Time - if (.not.get_value(at%params,"i",step_nr)) then - step_nr = step_nr + 1 - endif - if (.not.get_value(at%params,"time",time_passed)) then - if (.not.get_value(at%params,"Time",time_passed)) then - time_passed = step_nr * time_step - endif - endif - - !get velocity and force in a.u. - nullify(v) - if (.not. assign_pointer(at_velo, 'velo', v)) call system_abort("Could not find velo property.") - nullify(f) - if (.not. assign_pointer(at_force, 'frc', f)) then - if (.not. assign_pointer(at_force, 'force', f)) call system_abort("Could not find frc or force property.") - endif - - !printing into buffer - do i=1,colvar_atoms%N - if (input_in_cp2k_units) then - write (UNIT=output_lines(lines_used+1),FMT="(I8,F13.3,I8,9F13.8)") & - step_nr, time_passed, colvar_atoms%int(1,i), & - at%pos(1:3,colvar_atoms%int(1,i)), & - (v(1:3,colvar_atoms%int(1,i))*BOHR/AU_FS), & - (f(1:3,colvar_atoms%int(1,i))*HARTREE/BOHR) - else - write (UNIT=output_lines(lines_used+1),FMT="(I8,F13.3,I8,9F13.8)") & - step_nr, time_passed, colvar_atoms%int(1,i), & - at%pos(1:3,colvar_atoms%int(1,i)), & - (v(1:3,colvar_atoms%int(1,i))), & - (f(1:3,colvar_atoms%int(1,i))) - endif - lines_used = lines_used + 1 - enddo - - !printing buffer into file - if (lines_used == restart_every*colvar_atoms%N) then - !if (mod((iframe+1),restart_every)/=0) call system_abort("lines_used "//lines_used// & - ! " == restart_every "//restart_every//" * colvar_atoms%N "//colvar_atoms%N// & - ! ", but not frame "//(iframe+1)//" mod restart_every "//restart_every//" =0") - do i=1,lines_used - call print(output_lines(i),file=out_file) - output_lines(i) = "" - enddo - deallocate(output_lines) - allocate(output_lines(restart_every*colvar_atoms%N)) - lines_used = 0 - endif - - call finalise(at_force) - call finalise(at_velo) - call finalise(at) - - enddo - - call finalise(colvar_atoms) - call finalise(coord_file) - call finalise(velo_file) - call finalise(force_file) - call finalise(out_file) - call finalise(at_force) - call finalise(at_velo) - call finalise(at) - if (allocated(output_lines)) deallocate(output_lines) - - call print('Finished.') - - call system_timer('program') - call system_finalise - -contains - - subroutine read_integer_table(output_table,input_filename) - - type(Table), intent(out) :: output_table - character(len=*), intent(in) :: input_filename - type(InOutput) :: input_file - integer :: n, num_entries - integer :: dummy,stat - - call initialise(input_file,trim(input_filename),action=INPUT) - read (input_file%unit,*) num_entries - call allocate(output_table,1,0,0,0,num_entries) - do n=1,num_entries - dummy = 0 - read (input_file%unit,*,iostat=stat) dummy - if (stat /= 0) exit - call append(output_table,dummy) - enddo - if (output_table%N.ne.num_entries) call system_abort('read_integer_table: Something wrong with the atomlist file') - call finalise(input_file) - - end subroutine read_integer_table - - subroutine print_usage - - call print("Usage: extract_cv coord_file force_file colvar_file outfile [restart_every=1] [append_output=F] [last_frame=0] [time_step=0.0]") - call print(" coord_file XYZ coordinate file") - call print(" velo_file XYZ file with velocities stored in 'velo' property") - call print(" force_file XYZ file with forces stored in 'frc' property") - call print(" atomlist_file file containing the (colvar) atoms whose properties should be printed") - call print(" outfile output file with positions, velocities and forces on the (colvar) atoms in time.") - call print(" restart_every optionally stores the output in a buffer and prints synchronised with the restart frequency.") - call print(" Useful for restarted runs.") - call print(" append_output optionally append to an existing output file without reprinting the header") - call print(" Useful for restarted runs.") - call print(" last_frame optionally processes only the first last_frame frames. 0 means process all frames.") - call print(" time_step optionally sets the time step between frames. It is used if 'time' is not stored in the coord_file.") - - end subroutine print_usage - -end program extract_cv diff --git a/src/Structure_processors/file_rewrite.f95 b/src/Structure_processors/file_rewrite.f95 deleted file mode 100644 index 5cbd2b36cd..0000000000 --- a/src/Structure_processors/file_rewrite.f95 +++ /dev/null @@ -1,97 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Reads a sequence of configs and writes them back, mostly to convert from xyz to netcdf and back - -#include "error.inc" - -program file_rewrite -use libatoms_module -implicit none - - type(Dictionary) :: cli_params - character(len=STRING_LENGTH) :: infilename - character(len=STRING_LENGTH) :: outfilename - logical :: netcdf4 - type(CInOutput) :: infile, outfile - type(Atoms) :: at - integer i - integer :: error = ERROR_NONE - - call system_initialise(PRINT_NORMAL) - - call initialise(cli_params) - call param_register(cli_params, 'infile', 'stdin', infilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'outfile', 'stdout', outfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'netcdf4', 'F', netcdf4, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - call print_usage() - call system_abort('could not parse argument line') - end if - call finalise(cli_params) - - call print("infile " // trim(infilename) // " outfile " // trim(outfilename) // " netcdf4 " // netcdf4) - - call initialise(infile, infilename, action=INPUT, no_compute_index=.true.) - call initialise(outfile, outfilename, action=OUTPUT, netcdf4=netcdf4) - - i = 1 - call read(infile, at, error=error) - do while (error == ERROR_NONE) - call write(outfile, at, error=error) - HANDLE_ERROR(error) - if (mod(i,100) == 0) write (*,'(I1,$)') mod(i/100,10) - call read(infile, at, error=error) - HANDLE_ERROR(error) - i = i + 1 - end do - ! We do not want to handle this error - call clear_error(error) - - call finalise(outfile) - call finalise(infile) - call system_finalise() - -contains - - subroutine print_usage() - - character(len=1024) my_exec_name - - if (EXEC_NAME == "") then - my_exec_name="" - else - my_exec_name=EXEC_NAME - endif - - call print("Usage: " // trim(my_exec_name)//" infile=filename(stdin) outfile=filename(stdout)[=file.nc for NETCDF] [netcdf4 (for output)]", PRINT_ALWAYS) - end subroutine print_usage - -end program file_rewrite diff --git a/src/Structure_processors/find_space_minim.f95 b/src/Structure_processors/find_space_minim.f95 deleted file mode 100644 index 7d285f0983..0000000000 --- a/src/Structure_processors/find_space_minim.f95 +++ /dev/null @@ -1,291 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! find largest spherical hole in a configuation starting from some initial guess -#include "error.inc" -module find_space_minim_mod -use libatoms_module -use iso_c_binding, only : c_ptr, c_loc, c_f_pointer -implicit none - -real(dp), save :: rad, width - -contains - - ! x > r fo = 1-cos((x-r)/w * pi/2 + 3 pi /2) - ! f'(r) = sin(3 pi /2) pi/(2 w) = -pi/(2 w) - ! x <= r fi = o - x pi/(2 w) - ! fi(r) = fo(r) - ! 1 = o - r pi/(2 w) - ! o = 1 + r pi / (2 w) - -function func(x,data) - real(dp) :: x(:) - character, optional :: data(:) - real(dp) :: func - - integer :: i - type(c_ptr) :: at_ptr - type(Atoms), pointer :: at - real(dp) :: r_mag - - if (.not. present(data)) call system_abort("find_space_minim_mod func needs data") - if (size(x) /= 3) call system_abort("find_space_minim_mod func needs x(1:3)") - - at_ptr = transfer(data, at_ptr) - call c_f_pointer(at_ptr, at) - call atoms_repoint(at) - - func = 0.0_dp - do i=1, at%N - r_mag = distance_min_image(at, i, x(1:3)) - if (r_mag < rad) then - func = func + rep_E(r_mag) - endif - end do - -end function func - -function dfunc(x,data) - real(dp) :: x(:) - character, optional :: data(:) - real(dp) :: dfunc(size(x)) - - integer :: i - type(c_ptr) :: at_ptr - type(Atoms), pointer :: at - real(dp) :: r(3), r_mag - - if (.not. present(data)) call system_abort("find_space_minim_mod func needs data") - if (size(x) /= 3) call system_abort("find_space_minifind_space_minimeds x(1:3)") - - at_ptr = transfer(data, at_ptr) - call c_f_pointer(at_ptr, at) - call atoms_repoint(at) - - dfunc = 0.0_dp - do i=1, at%N - r = diff_min_image(at, i, x(1:3)) - r_mag = norm(r) - if (r_mag < rad) then - dfunc = dfunc + rep_dE(r, r_mag) - endif - end do - - -end function dfunc - -subroutine apply_precond_dummy(x,g,P_g,data,error) - real(dp) :: x(:), g(:), P_g(:) - character, optional :: data(:) - integer, optional :: error - - INIT_ERROR(error) - P_g = g - -end subroutine apply_precond_dummy - -subroutine bothfunc(x,E,f,data,error) - real(dp) :: x(:), E, f(:) - character, optional :: data(:) - integer,optional :: error - - integer :: i - type(c_ptr) :: at_ptr - type(Atoms), pointer :: at - real(dp) :: r(3), r_mag - - INIT_ERROR(error) - - if (.not. present(data)) call system_abort("find_space_minim_mod func needs data") - if (size(x) /= 3) call system_abort("find_space_minim_mod bothfunc needs x(1:3)") - - at_ptr = transfer(data, at_ptr) - call c_f_pointer(at_ptr, at) - call atoms_repoint(at) - - f = 0.0_dp - E = 0.0_dp - do i=1, at%N - r = diff_min_image(at, i, x(1:3)) - r_mag = norm(r) - if (r_mag < rad) then - E = E + rep_E(r_mag) - f = f + rep_dE(r, r_mag) - endif - end do - -end subroutine bothfunc - -function rep_E(r_mag) - real(dp) :: r_mag - real(dp) :: rep_E - - real(dp) :: f_envelope - - if (r_mag > rad) then - f_envelope = 0.0_dp - else if (r_mag < rad-width) then - f_envelope = 1.0_dp - else - f_envelope = 0.5_dp+0.5_dp*cos((r_mag-(rad-width))/width * 3.14159_dp) - endif - - rep_E = (2.0_dp - r_mag/rad) * f_envelope - -end function rep_E - -function rep_dE(r, r_mag) - real(dp) :: r(:), r_mag - real(dp) :: rep_dE(size(r)) - - real(dp) :: f_envelope, df_envelope - - if (r_mag > rad) then - f_envelope = 0.0_dp - df_envelope = 0.0_dp - else if (r_mag < rad-width) then - f_envelope = 1.0_dp - df_envelope = 0.0_dp - else - f_envelope = 0.5_dp+0.5_dp*cos((r_mag-(rad-width))/width * 3.14159_dp) - df_envelope = -0.5_dp*sin((r_mag-(rad-width))/width * 3.14159_dp) * (1.0_dp/width) * 3.14159_dp - endif - - rep_dE = ((2.0_dp - r_mag/rad) * df_envelope - 1.0_dp/rad * f_envelope) * r/r_mag -end function rep_dE - -subroutine hook(x,dx,E,done,do_print,data) - use system_module - real(dp), intent(in) ::x(:) - real(dp), intent(in) ::dx(:) - real(dp), intent(in) ::E - logical, intent(out) :: done - logical, optional, intent(in) :: do_print - character(len=1),optional, intent(in) ::data(:) - - done = norm(dx) .feq. 0.0_dp - -end subroutine hook - -end module find_space_minim_mod - -program find_space_minim -use libatoms_module -use find_space_minim_mod, only : func, bothfunc, apply_precond_dummy, hook, rad, width -use iso_c_binding, only : c_ptr, c_loc, c_f_pointer -implicit none - - real(dp) :: r(3), prev_r(3), orig_r(3) - integer :: closest_list(100) - type(Atoms) :: at - type(Atoms), target :: closest_at - type(c_ptr) :: closest_at_ptr - character(len=128) :: arg - integer :: data_size - character, allocatable :: data(:) - integer :: i_r, n_iter - real(dp) :: prev_val, final_val, prev_rad - integer :: i_at -real(dp) :: vi, vf - real(dp) :: expected_red - real(dp) :: rad_min, rad_increment - - call system_initialise() - call read(at, "stdin") - call get_cmd_arg(1, arg) - read (unit=arg, fmt=*) r(1) - call get_cmd_arg(2, arg) - read (unit=arg, fmt=*) r(2) - call get_cmd_arg(3, arg) - read (unit=arg, fmt=*) r(3) - call get_cmd_arg(4, arg) - read (unit=arg, fmt=*) rad_min - call get_cmd_arg(5, arg) - read (unit=arg, fmt=*) rad_increment - - do i_at=1, at%N - at%pos(1:3,i_at) = at%pos(1:3,i_at) - r(1:3) - end do - call map_into_cell(at) - orig_r = r - r = 0.0_dp - - if (at%N < 100) then - call find_closest(at, r, closest_list(1:at%N)) - call select(closest_at, at, list=closest_list(1:at%N)) - else - call find_closest(at, r, closest_list) - call select(closest_at, at, list=closest_list) - endif - - closest_at_ptr = c_loc(closest_at) - data_size = size(transfer(closest_at_ptr, data)) - allocate(data(data_size)) - data = transfer(closest_at_ptr,data) - width = 0.2_dp - - i_r = 1 - prev_val = 0.0_dp - final_val = 0.0_dp - prev_r = 0.0_dp - do while (final_val <= 1.0e-3 .and. i_r < 1000) - prev_r = r - prev_val = final_val - rad = rad_min+(i_r-1)*rad_increment - call verbosity_push(PRINT_SILENT) - ! n_iter = minim(r, func, dfunc, 'cg', 1.0e-6_dp, 1000, 'NR_LINMIN', eps_guess=1e-3_dp, hook=hook, data=data) - expected_red = 1.0e-2_dp - n_iter = n_minim(r, bothfunc, .false., apply_precond_dummy, vi, vf, expected_red, 1000, 1e-8_dp, hook=hook, data=data) - final_val = func(r, data) - call verbosity_pop() - call find_closest(at, r, closest_list(1:1)) - call print("rad " // rad// " n_iter " // n_iter // " relaxed val " // func(r, data) // " relaxed r" // r & - // " radius " // distance_min_image(at,closest_list(1),r)) - i_r = i_r + 1 - end do - - r = r + orig_r - prev_r = prev_r + orig_r - do i_at=1, at%N - at%pos(1:3,i_at) = at%pos(1:3,i_at) + orig_r(1:3) - end do - - if (i_r == 2) then - call print("WARNING: first try found no space at rad " // rad) - else - call find_closest(at, prev_r, closest_list(1:1)) - prev_rad = distance_min_image(at,closest_list(1),prev_r) - - call print("best r " // prev_r // " best_rad " // prev_rad // " best_val " // prev_val // " next_val " // final_val) - endif - - call system_finalise() -end program diff --git a/src/Structure_processors/histogram_process.f95 b/src/Structure_processors/histogram_process.f95 deleted file mode 100644 index 6ec37a80b6..0000000000 --- a/src/Structure_processors/histogram_process.f95 +++ /dev/null @@ -1,326 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! compute Gaussian fit for a distribution(s) -! compute Kullback--Leibler divergence of two distributions -! compute the derivative of the free energy at UI_xi (using UI_use_xi, which is mostly 0) - -program histogram_process - -use libatoms_module - -implicit none - - !input - character(len=STRING_LENGTH) :: infile1_name, infile2_name, outfile_name, listfilename - logical :: file_is_list - integer :: n_data - logical :: KL_divergence, gaussian_fit, UI_unbias - type(InOutput) :: outfile - - !reading in infiles - type(Dictionary) :: cli_params - type(InOutput) :: list_file - character(STRING_LENGTH) :: inline - character(1024), dimension(2) :: fields - integer :: num_fields,status - logical :: read_more - - real(dp), allocatable :: histogram1(:,:), histogram2(:,:) - real(dp) :: sum_hist1, sum_hist2 - real(dp) :: amplitude, mean, variance, chisq - real(dp) :: KL_1_2, KL_2_1, KL - integer :: i - real(dp) :: UI_xi, UI_use_xi - real(dp) :: dA_dxi_unbiased, temp - - call system_initialise() - - call initialise(cli_params) - call param_register(cli_params, "infile1" , "stdin" , infile1_name , help_string="infile1 - containing histogram with no blank lines or comments") - call param_register(cli_params, "infile2" , "" , infile2_name , help_string="infile2 (needed for KL divergence)") - call param_register(cli_params, "outfile" , "stdout" , outfile_name , help_string="outfile") - call param_register(cli_params, "n_data" , PARAM_MANDATORY, n_data , help_string="number of data points in the histogram") - call param_register(cli_params, "KL_divergence", "F" , KL_divergence, help_string="calculate Kullback-Leibler divergence") - call param_register(cli_params, "file_is_list" , "F" , file_is_list , help_string="if infile1 is just a list of infile names (comments starting with # are allowed") - call param_register(cli_params, "gaussian_fit" , "F" , gaussian_fit , help_string="calculate Gaussian fit for the histogram") - call param_register(cli_params, "UI_unbias" , "F" , UI_unbias , help_string="calculate unbiased derivative of the free energy using Umbrella Integration") - call param_register(cli_params, "UI_xi" , "0.0" , UI_xi , help_string="the set value of the reaction coordinate (used as a label), for Umbrella Integration, default=0.0") - call param_register(cli_params, "UI_use_xi" , "0.0" , UI_use_xi , help_string="value of the reaction coordinate, around which the histogram is meant to be centred, for Umbrella Integration (often the histogram is shifted to 0), default=0.0") - call param_register(cli_params, "temperature" , "300.0" , temp , help_string="simulation temperature, needed for Umbrella Integration, default=300.0") - if (.not.param_read_args(cli_params)) then - call param_print_help(cli_params) - call print("Usage: "//trim(EXEC_NAME)//" infile1=stdin infile2 outfile=stdout n_data KL_divergence=F gaussian_fit=F", PRINT_ALWAYS) - call system_abort("Unable to parse command line") - endif - call finalise(cli_params) - - !check arguments - if (len_trim(infile2_name)==0 .and. KL_divergence) & - call system_abort("KL_divergence needs both infile1 and infile2") - if (n_data<1) & - call system_abort("At least 1 data point should be in the input files, specified in n_data. n_data="//n_data) - if (.not.KL_divergence .and. .not.gaussian_fit .and. .not. UI_unbias) & - call system_abort("At least 1 task of KL_divergence and gaussian_fit and UI_unbias should be chosen.") - if (UI_unbias .and. temp<=0._dp) & - call system_abort("UI_unbias needs temperature > 0, got "//temp) - - - allocate(histogram1(n_data,1:2)) - allocate(histogram2(n_data,1:2)) - - if (file_is_list) then - listfilename=trim(infile1_name) - call initialise(list_file,trim(listfilename),action=input) - status=0 - read_more=.true. - do while(status==0.and.read_more) - inline=read_line(list_file,status) - if (status==0) then - if (inline(1:1)/="#") then - read_more=.false. - else - call print("",file=outfile) - call print("",file=outfile) - endif - endif - enddo - if (num_fields==1 .and. KL_divergence) & - call system_abort("KL_divergence needs 2 infiles in the list file.") - endif - - call initialise(outfile,trim(outfile_name),action=output,append=.false.) - if (gaussian_fit) call print("GAUSS| #amplitude mean variance chisq",file=outfile) - if (KL_divergence) call print("DKL| #D_KL(1|2) D_KL(2|1) D_KL(1,2)",file=outfile) - - do while (status==0) - - if (file_is_list) then - call parse_string(inline,' ',fields,num_fields) - infile1_name=fields(1) - infile2_name=fields(2) - endif - - call print("Hist1: "//trim(infile1_name)) - call print("Hist2: "//trim(infile2_name)) - histogram1 = 0._dp - histogram2 = 0._dp - !read in histogram(s) - histogram1 = read_histogram(trim(infile1_name),n_data) - if (len_trim(infile2_name)/=0) histogram2 = read_histogram(trim(infile2_name),n_data) - - !Gaussian fit if needed - if (gaussian_fit .or. UI_unbias) then - call gaussian(histogram1(1:n_data,1:2),amplitude,mean,variance,chisq) - call print("Gaussian fit of histogram(1):") - call print(" amplitude: "//amplitude) - call print(" mean: "//mean) - call print(" variance: "//variance) - call print("") - if (UI_unbias) then - dA_dxi_unbiased = 1.0_dp * BOLTZMANN_K * temp * ( UI_use_xi - mean ) / variance - call print("UI| "//trim(infile1_name)//" "//UI_xi//" "//dA_dxi_unbiased//" "//mean//" "//variance//" "//chisq,file=outfile) - else - call print("GAUSS| "//trim(infile1_name)//" "//amplitude//" "//mean//" "//variance//" "//chisq,file=outfile) - endif - - if (len_trim(infile2_name)/=0) then - call gaussian(histogram2(1:n_data,1:2),amplitude,mean,variance,chisq) - call print("Gaussian fit of histogram(2):") - call print(" amplitude: "//amplitude) - call print(" mean: "//mean) - call print(" variance: "//variance) - if (UI_unbias) then - dA_dxi_unbiased = 1.0_dp * BOLTZMANN_K * temp * ( UI_use_xi - mean ) / variance - call print("UI| "//trim(infile2_name)//" "//UI_xi//" "//dA_dxi_unbiased//" "//mean//" "//variance//" "//chisq,file=outfile) - else - call print("GAUSS| "//trim(infile2_name)//" "//amplitude//" "//mean//" "//variance//" "//chisq,file=outfile) - endif - call print("") - endif - - endif - - !Kullback--Leibler divergence if needed - if (KL_divergence) then - !distributions must add up to 1 (not the same as being normalised) - sum_hist1 = sum(histogram1(1:n_data,2)) - sum_hist2 = sum(histogram2(1:n_data,2)) - histogram1(1:n_data,2) = histogram1(1:n_data,2) / sum_hist1 - histogram2(1:n_data,2) = histogram2(1:n_data,2) / sum_hist2 - sum_hist1=0._dp ; sum_hist2=0._dp - KL_1_2 = 0._dp - KL_2_1 = 0._dp - do i=1,n_data - sum_hist1 = sum_hist1 + histogram1(i,2) ; sum_hist2 = sum_hist2 + histogram2(i,2) - if (histogram1(i,2)>epsilon(0._dp) .and. histogram2(i,2)>epsilon(0._dp)) then - !call print("Adding "//histogram1(i,2)//"*log("//histogram1(i,2)//"/"//histogram2(i,2)//") to D_KL(1|2)") - KL_1_2 = KL_1_2 + histogram1(i,2) * log ( histogram1(i,2)/histogram2(i,2) ) - !call print("KL_1_2 so far "//KL_1_2) - !call print("Adding "//histogram2(i,2)//"*log("//histogram2(i,2)//"/"//histogram1(i,2)//") to D_KL(2|1)") - KL_2_1 = KL_2_1 + histogram2(i,2) * log ( histogram2(i,2)/histogram1(i,2) ) - !call print("KL_2_1 so far "//KL_2_1) - else - !call print("Skipping "//histogram1(i,2)//" and "//histogram2(i,2)) - endif - enddo - KL = 0.5_dp * (KL_1_2 + KL_2_1) - call print("Kullback--Leibler divergence:") - call print(" asym. D_KL(hist1|hist2): "//KL_1_2) - call print(" asym. D_KL(hist2|hist1): "//KL_2_1) - call print(" symm. D_KL(hist2,hist1): "//KL) - call print(" Sum(Hist1): "//sum_hist1) - call print(" Sum(Hist2): "//sum_hist2) - call print("DKL| "//trim(infile1_name)//" "//trim(infile2_name)//" "//KL_1_2//" "//KL_2_1//" "//KL,file=outfile) - call print("") - endif - - if (file_is_list) then - status=0 - read_more=.true. - do while(status==0.and.read_more) - inline=read_line(list_file,status) - if (status==0) then - if (inline(1:1)/="#") then - read_more=.false. - else - call print("",file=outfile) - call print("",file=outfile) - endif - endif - enddo - else - exit - endif - - enddo - - deallocate(histogram1) - deallocate(histogram2) - if (file_is_list) call finalise(list_file) - call finalise(outfile) - - call system_finalise() - -contains - - function read_histogram(filename,n_data) result(histo) - character(len=*), intent(in) :: filename - integer, intent(in) :: n_data - real(dp) :: histo(1:n_data,2) - type(InOutput) :: infile - integer :: i - - call initialise(infile,trim(filename),action=INPUT) - do i=1,n_data - call read_ascii(infile, histo(i,1:2)) - enddo - call finalise(infile) - - end function read_histogram - - - subroutine gaussian(histo,amplitude,mean,variance,chisq) - real(dp), intent(in) :: histo(:,:) - real(dp), intent(out) :: amplitude, mean, variance - real(dp), intent(out) :: chisq - real(dp) :: params(3) !(/A,B,C/) of fit: Ax^2+Bx+C - real(dp) :: x,x2,x3,x4,y,yx,yx2,one - integer :: n_data, i - real(dp) :: inversematrix(3,3) - - - n_data = size(histo,1) - - !fit a second order polynomial to (ln y)(x) - !least squares fit of log(y) (x) = log(1/2variance) - (x-mean)**2.0/(2*variance) - x = 0._dp - x2 = 0._dp - x3 = 0._dp - x4 = 0._dp - y = 0._dp - yx = 0._dp - yx2 = 0._dp - one = 0._dp - do i=1,n_data -! call print(histo(i,1)//" "//histo(i,2)) - if (histo(i,2)>epsilon(1._dp)) then - x = x + histo(i,1) - x2 = x2 + histo(i,1)*histo(i,1) - x3 = x3 + histo(i,1)*histo(i,1)*histo(i,1) - x4 = x4 + histo(i,1)*histo(i,1)*histo(i,1)*histo(i,1) -!call print(histo(i,1)//" "//log(histo(i,2))) - y = y + log(histo(i,2)) - yx = yx + log(histo(i,2))*histo(i,1) - yx2 = yx2 + log(histo(i,2))*histo(i,1)*histo(i,1) - one = one + 1._dp - !weight=1/histo(i,2) - endif - enddo - - - !call print((/x4,x3,x2,x3,x2,x,x2,x,one/)) - !call print( reshape((/x4,x3,x2,x3,x2,x,x2,x,one/),(/3,3/)) ) - call matrix3x3_inverse( reshape((/x4,x3,x2,x3,x2,x,x2,x,one/),(/3,3/)) , inversematrix ) - !call print(inversematrix) - !call print( inversematrix .mult. reshape((/x4,x3,x2,x3,x2,x,x2,x,one/),(/3,3/)) ) - !call print((/yx2,yx,y/)) - params = inversematrix .mult. (/yx2,yx,y/) - !call print(params) - - chisq = 0._dp - do i=1,n_data - if (histo(i,2)>epsilon(1._dp)) then - chisq = chisq + ( log(histo(i,2)) - (params(1)*histo(i,1)*histo(i,1) + params(2)*histo(i,1) + params(3) ) )**2.0_dp - endif - enddo - - call print("Chi^2 of fitting: "//chisq) - call print("est. variance: "//(chisq/(one-3))) - -! least_squares(histo(x=1:size(histo,1),1), & -! y=1:size(histo,1),2), & -! sig=0.01_dp, & -! a=(/A,B,C/), & -! chisq=chisq, & -! funcs=func) - - variance= -1._dp/2._dp*params(1) - mean=params(2)/variance - amplitude=exp(params(3)+mean**2._dp/(2._dp*variance)) * 2._dp*variance - - end subroutine gaussian - -! function func(x,afunc) -! real(dp) :: x,afunc -! afunc = A*x**2.0_dp + B*x + C -! end function func - -end program histogram_process diff --git a/src/Structure_processors/make_bulk_supercell.f95 b/src/Structure_processors/make_bulk_supercell.f95 deleted file mode 100644 index 2087a97bef..0000000000 --- a/src/Structure_processors/make_bulk_supercell.f95 +++ /dev/null @@ -1,38 +0,0 @@ -program make_bulk_supercell -use libatoms_module -implicit none - - character(len=STRING_LENGTH) :: struct, outfile, Z_values_str - real(dp) :: vol_per_atom, vol_per_unit_cell - integer :: repeat(3) - type(Dictionary) :: cli_params - - type(Atoms) :: dup_cell - - call system_initialise(verbosity=PRINT_SILENT) - - call initialise(cli_params) - call param_register(cli_params,"struct", PARAM_MANDATORY, struct, help_string="name of structure (or full path)") - call param_register(cli_params,"outfile", "stdout", outfile, help_string="name of output file") - call param_register(cli_params,"vol_per_atom", "-1.0", vol_per_atom, help_string="volume per atom") - call param_register(cli_params,"vol_per_unit_cell", "-1.0", vol_per_unit_cell, help_string="volume per unit cell") - call param_register(cli_params,"repeat", "1 1 1", repeat, help_string="number of times to repeate supercell in each direction") - call param_register(cli_params,"Z_values", "", Z_values_str, help_string="values of atomic number to assign to each atom type in structure file") - if (.not. param_read_args(cli_params)) then - call print("Usage: make_bulk_supercell struct=[struct_name] outfile=[filename](stdout)", PRINT_ALWAYS) - call print(" [ vol_per_atom=volume | vol_per_unit_cell=volume ] [ repeat='n1 n2 n3'(1 1 1) ]", PRINT_ALWAYS) - call print(" [ Z_values='S Z1 Z2 ...' ]", PRINT_ALWAYS) - call print("In addition, struct names that do not begin with . or / will be searched for", PRINT_ALWAYS) - call print(" in $QUIP_DIR/structures/ or $HOME/share/quip_structures/, in that order", PRINT_ALWAYS) - call system_abort("Failed to parse command line arguments") - endif - call finalise(cli_params) - - dup_cell = structure_from_file(struct, vol_per_atom, vol_per_unit_cell, repeat, Z_values_str) - call verbosity_push(PRINT_NORMAL) - call write(dup_cell, outfile) - call verbosity_pop() - - call system_finalise() - -end program diff --git a/src/Structure_processors/make_k_mesh.f95 b/src/Structure_processors/make_k_mesh.f95 deleted file mode 100644 index a49ac7621c..0000000000 --- a/src/Structure_processors/make_k_mesh.f95 +++ /dev/null @@ -1,39 +0,0 @@ -program make_k_mesh -use libatoms_module -use tb_kpoints_module -implicit none - type(KPoints) :: kp - integer :: i - type(Dictionary) :: cli_params - character(len=STRING_LENGTH) :: outfile - type(inoutput) :: out_io - integer :: mesh(3) - logical :: monkhorst_pack - - call system_initialise(verbosity=PRINT_SILENT) - - call initialise(cli_params) - call param_register(cli_params, "outfile", "stdout", outfile, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "mesh", "1 1 1", mesh, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "monkhorst_pack", "F", monkhorst_pack, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params, ignore_unknown=.false.)) then - call print("Usage: make_k_mesh outfile=filename(stdout) mesh='n1 n2 n3'(1 1 1 ) monkhorst_pack=L(F)", PRINT_ALWAYS) - call system_abort("Failed to parse command line arguments") - endif - - if (any(mesh <= 0)) & - call system_abort("Invalid mesh " // mesh) - call initialise(kp, mesh, monkhorst_pack) - - call initialise(out_io, trim(outfile)) - call print('', file=out_io) - do i=1, kp%N - call print(' '//kp%k_pts(:,i)//' ', file=out_io) - end do - call print('', file=out_io) - call finalise(out_io) - call finalise(kp) - - call system_finalise() - -end program make_k_mesh diff --git a/src/Structure_processors/make_surface_slab_vasp.f95 b/src/Structure_processors/make_surface_slab_vasp.f95 deleted file mode 100644 index 7c1f265fc5..0000000000 --- a/src/Structure_processors/make_surface_slab_vasp.f95 +++ /dev/null @@ -1,319 +0,0 @@ -program test_surf_cell -use libatoms_module -implicit none - -type(Atoms) :: at_prim, at_surf, at_slab, at_slab_cut - -real(dp) :: surf_v(3), tol -logical :: third_vec_normal -integer :: max_n - -integer :: i -integer :: surf_i(3,3) -type(Dictionary) :: cli_params -real(dp) :: F(3,3), old_axes(3,3), old_axes_inv(3,3), new_axes(3,3), z_min, z_max, z_vacuum -integer :: n3_min, n3_max -character(len=STRING_LENGTH) :: comment, Z_order -character(len=STRING_LENGTH) :: verbosity - -call system_initialise(verbosity=PRINT_SILENT) - -call initialise(cli_params) -call param_register(cli_params, "surf_v", PARAM_MANDATORY, surf_v, help_string="vector normal to surface in Cartesian coords") -call param_register(cli_params, "z_min", PARAM_MANDATORY, z_min, help_string="minimum Z position to include in slab") -call param_register(cli_params, "z_max", PARAM_MANDATORY, z_max, help_string="maximum Z position to include in slab") -call param_register(cli_params, "z_vacuum", PARAM_MANDATORY, z_vacuum, help_string="amount of vacuum to create") -call param_register(cli_params, "third_vec_normal", "T", third_vec_normal, help_string="if true force the third vector to be normal to the surface") -call param_register(cli_params, "tol", "1.0e-6", tol, help_string="tolerance for various normal/parallel tests") -call param_register(cli_params, "max_n", "4", max_n, help_string="maximum supercell component to search for matching vectors") -call param_register(cli_params, "verbosity", "NORMAL", verbosity, help_string="verbosity level. VERBOSE for more output about surface cell") -if (.not. param_read_args(cli_params)) then - call param_print_help(cli_params) - call system_abort("Error reading params from command line") -endif -call finalise(cli_params) - -call verbosity_push(verbosity_of_str(trim(verbosity))) - -call read_vasp(at_prim, "stdin") - -call print("at_prim", verbosity=PRINT_VERBOSE) -if (current_verbosity() >= PRINT_VERBOSE) call write(at_prim, "stdout") - -call print("surface unit cell for lattice", verbosity=PRINT_VERBOSE) -call print(at_prim%lattice, verbosity=PRINT_VERBOSE) -call print ("normal to "//surf_v, verbosity=PRINT_VERBOSE) - -! create the surface unit cell lattice -call surface_unit_cell(surf_i, surf_v, at_prim%lattice, third_vec_normal=third_vec_normal, tol=tol, max_n=max_n) - -call print("", verbosity=PRINT_VERBOSE) -call print("in lattice coordinates", verbosity=PRINT_VERBOSE) -call print(surf_i, verbosity=PRINT_VERBOSE) -call print("in cartesian coordinates", verbosity=PRINT_VERBOSE) -call print(matmul(at_prim%lattice,surf_i), verbosity=PRINT_VERBOSE) - -! create the actual surface unit cell with atoms -call arbitrary_supercell(at_surf, at_prim, surf_i) - -! rotate to desired axes (surface normal to z) -old_axes(:,1) = at_surf%lattice(:,1) ! map to x -old_axes(:,2) = at_surf%lattice(:,1) .cross. at_surf%lattice(:,2) ! surf_v, map to z -old_axes(:,3) = at_surf%lattice(:,1) .cross. (at_surf%lattice(:,1) .cross. at_surf%lattice(:,2)) ! map to y -old_axes(:,1) = old_axes(:,1) / norm(old_axes(:,1)) -old_axes(:,2) = old_axes(:,2) / norm(old_axes(:,2)) -old_axes(:,3) = old_axes(:,3) / norm(old_axes(:,3)) -new_axes(:,1) = (/ 1, 0, 0 /) -new_axes(:,2) = (/ 0, 0, 1 /) -new_axes(:,3) = (/ 0, 1, 0 /) - -call print("old_axes", verbosity=PRINT_VERBOSE) -call print(old_axes, verbosity=PRINT_VERBOSE) -call print("new_axes", verbosity=PRINT_VERBOSE) -call print(new_axes, verbosity=PRINT_VERBOSE) - -call matrix3x3_inverse(old_axes, old_axes_inv) -F = matmul(new_axes, old_axes_inv) -new_axes = matmul(F, at_surf%lattice) -if (new_axes(3,3) < 0.0_dp) then - F(3,:) = -F(3,:) -endif - -call print("F", verbosity=PRINT_VERBOSE) -call print(F, verbosity=PRINT_VERBOSE) - -call print("F.old_axes", verbosity=PRINT_VERBOSE) -call print(matmul(F, old_axes), verbosity=PRINT_VERBOSE) - -call set_lattice(at_surf, matmul(F, at_surf%lattice), .true.) - -n3_min = floor((z_min-minval(at_surf%pos(3,:)))/at_surf%lattice(3,3))-1 -n3_max = floor((z_max-maxval(at_surf%pos(3,:)))/at_surf%lattice(3,3))+2 -call print("n3 min max "//n3_min//" "//n3_max, verbosity=PRINT_VERBOSE) -call supercell(at_slab, at_surf, 1, 1, n3_max-n3_min+1) -do i=1, at_slab%N - at_slab%pos(:,i) = at_slab%pos(:,i) + n3_min*at_surf%lattice(:,3) -end do - -call print("at_slab", verbosity=PRINT_VERBOSE) -if (current_verbosity() >= PRINT_VERBOSE) call write(at_slab, "stdout") - -call select(at_slab_cut, at_slab, mask=(at_slab%pos(3,:) >= z_min .and. at_slab%pos(3,:) <= z_max)) - -old_axes = at_slab_cut%lattice -old_axes(:,3) = old_axes(:,3)/norm(old_axes(:,3)) * (z_max-z_min + z_vacuum) -call set_lattice(at_slab_cut, old_axes, .false.) - -! print out final slab - -call get_param_value(at_prim, "VASP_Comment", comment) -comment = trim(comment)//" surf_v "//surf_v -call set_param_value(at_slab_cut, "VASP_Comment", comment) - -call get_param_value(at_prim, "VASP_Z_order", Z_order) -call set_param_value(at_slab_cut, "VASP_Z_order", Z_order) - -call print("at_slab_cut", verbosity=PRINT_VERBOSE) -if (current_verbosity() >= PRINT_VERBOSE) call write(at_slab_cut, "stdout") - -call write_vasp(at_slab_cut, "stdout", fix_order=.true., cartesian=.false.) - -call verbosity_pop() -call system_finalise() - -contains - -subroutine write_vasp(at, filename, fix_order, cartesian) - type(Atoms), intent(in) :: at - character(*), intent(in) :: filename - logical, intent(in) :: fix_order, cartesian - - type(inoutput) :: io - integer :: sorted_Zs(at%N) - integer, allocatable :: uniq_Zs(:) - integer :: i, j - character(len=STRING_LENGTH) :: comment, Z_order - integer :: n_species, i_species, Ns(100) - real(dp) :: new_lattice(3,3), new_lattice_inv(3,3) - - call initialise(io, filename) - call get_param_value(at, "VASP_Comment", comment) - - if (.not. get_value(at%params, 'VASP_Z_order', Z_order)) then - Z_order = '' - endif - - call print(trim(comment), file=io, verbosity=PRINT_ALWAYS) - - call print(1.0_dp, file=io, verbosity=PRINT_ALWAYS) - if (scalar_triple_product(at%lattice(:,1), at%lattice(:,2), at%lattice(:,3)) < 0.0_dp) then - new_lattice(:,1) = at%lattice(:,2) - new_lattice(:,2) = at%lattice(:,1) - new_lattice(:,3) = at%lattice(:,3) - call matrix3x3_inverse (new_lattice, new_lattice_inv) - else - new_lattice = at%lattice - new_lattice_inv = at%g - endif - call print(new_lattice(:,1), file=io, verbosity=PRINT_ALWAYS) - call print(new_lattice(:,2), file=io, verbosity=PRINT_ALWAYS) - call print(new_lattice(:,3), file=io, verbosity=PRINT_ALWAYS) - - if (fix_order) then - sorted_Zs = at%Z - call sort_array(sorted_Zs) - call uniq(sorted_Zs, uniq_Zs) - if (len_trim(Z_order) > 0) then - read(unit=Z_order, fmt=*) line, uniq_Zs - endif - - line = "" - do i=1, size(uniq_Zs) - line=trim(line)//" "//ElementName(uniq_Zs(i)) - end do - call print(trim(line), file=io, verbosity=PRINT_ALWAYS) - - line = "" - do i=1, size(uniq_Zs) - line=trim(line)//" "//count(at%Z == uniq_Zs(i)) - end do - - call print(trim(line), file=io, verbosity=PRINT_ALWAYS) - - if (cartesian) then - call print("Cartesian") - do i=1, size(uniq_Zs) - do j=1, at%N - if (at%Z(j) == uniq_Zs(i)) call print(at%pos(:,j), file=io, verbosity=PRINT_ALWAYS) - end do - end do - else - call print("Direct") - do i=1, size(uniq_Zs) - do j=1, at%N - if (at%Z(j) == uniq_Zs(i)) call print(matmul(new_lattice_inv,at%pos(:,j)), file=io, verbosity=PRINT_ALWAYS) - end do - end do - endif - - deallocate(uniq_Zs) - else - line=ElementName(at%Z(1)) - n_species = 1 - do i=2, at%N - if (at%Z(i) /= at%Z(i-1)) then - line=trim(line)//" "//ElementName(at%Z(i)) - n_species = n_species + 1 - endif - end do - call print(trim(line), file=io, verbosity=PRINT_ALWAYS) - - line=""//at%Z(1) - i_species = 1 - Ns(i_species) = 1 - do i=2, at%N - if (at%Z(i) /= at%Z(i-1)) then - i_species = i_species + 1 - endif - Ns(i_species) = Ns(i_species) + 1 - end do - call print(Ns(1:n_species), file=io, verbosity=PRINT_ALWAYS) - - if (cartesian) then - call print("Cartesian") - do i=1, at%N - call print(at%pos(:,i), file=io, verbosity=PRINT_ALWAYS) - end do - else - call print("Direct") - do i=1, at%N - call print(matmul(new_lattice_inv,at%pos(:,i)), file=io, verbosity=PRINT_ALWAYS) - end do - endif - end if - - call finalise(io) - -end subroutine write_vasp - - -subroutine read_vasp(at, filename) - type(Atoms), intent(inout) :: at - character(*), intent(in) :: filename - - type(Inoutput) :: io - character(len=STRING_LENGTH) :: comment, Z_order - character(len=10) :: species(100) - integer :: n_species, i, j, N_tot - integer :: Ns(100), species_Zs(100) - real(dp) :: lattice(3,3) - real(dp) :: lattice_scale - logical :: cartesian - integer :: status - - call initialise(io, filename) - line=read_line(io); comment=trim(line) - line=read_line(io); read (unit=line, fmt=*) lattice_scale - line=read_line(io); read (unit=line, fmt=*) lattice(:,1) - line=read_line(io); read (unit=line, fmt=*) lattice(:,2) - line=read_line(io); read (unit=line, fmt=*) lattice(:,3) - lattice = lattice * lattice_scale - ! species line is optional - line=read_line(io) - call split_string_simple(line, species, n_species, " ") - read(unit=species(1), fmt=*, iostat=status) Ns(1) - if (status == 0) then ! it's a number - read(unit=line, fmt=*) Ns(1:n_species) - do i=1, n_species - species_Zs(i) = i - end do - else ! actually species - line=read_line(io) - read(unit=line, fmt=*) Ns(1:n_species) - do i=1, n_species - species_Zs(i) = atomic_number(species(i)) - end do - endif - Z_order='S '//species_Zs(1:n_species) - line=read_line(io) - if (line(1:1) == 'S') line=read_line(io) - if (line(1:1) == 'c' .or. line(1:1) == 'C') then - cartesian = .true. - else if (line(1:1) == 'd' .or. line(1:1) == 'D') then - cartesian = .false. - else - call system_abort ("confused by cartesian/direct line of '"//trim(line)//"'") - endif - - call initialise(at, sum(Ns(1:n_species)), lattice) - N_tot = 0 - do i=1, n_species - do j=1, Ns(i) - line=read_line(io) - N_tot = N_tot + 1 - read (unit=line, fmt=*) at%pos(:,N_tot) - at%Z(N_tot) = species_Zs(i) - end do - end do - - call set_atoms(at, at%Z) - - if (cartesian) then - at%pos = at%pos * lattice_scale - else - at%pos = matmul(at%lattice, at%pos) - endif - - if (len_trim(comment) == 0) then - call set_param_value(at, "VASP_Comment", "none") - else - call set_param_value(at, "VASP_Comment", trim(comment)) - endif - - call set_param_value(at, "VASP_Z_order", trim(Z_order)) - - call finalise(io) - -end subroutine read_vasp - -end program diff --git a/src/Structure_processors/mean_var_correl.f95 b/src/Structure_processors/mean_var_correl.f95 deleted file mode 100644 index ddfffbbc4e..0000000000 --- a/src/Structure_processors/mean_var_correl.f95 +++ /dev/null @@ -1,797 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! compute mean and/or variance and/or correlation of a grid of data over one of the two indices -! row index is called "bins", column index is called "time" - -module mean_var_correl_util_mod -use system_module -implicit none - -contains - -subroutine calc_correl(data, n_bins, n_data, over_bins, correlation_max_lag, correlation_subtract_mean, data_correl) - real(dp) :: data(:,:) - integer :: n_bins, n_data - logical :: over_bins - integer :: correlation_max_lag - logical :: correlation_subtract_mean - real(dp), allocatable :: data_correl(:,:) - - real(dp), allocatable :: data_mean(:) - - integer :: i, i_lag - - if (allocated(data_correl)) deallocate(data_correl) - if (over_bins) then - allocate(data_mean(size(data,2))) - data_mean = sum(data,1)/real(size(data,1),dp) - allocate(data_correl(min(n_bins, correlation_max_lag+1), n_data)) - data_correl = 0.0_dp - if (correlation_subtract_mean) then - do i_lag=0, min(n_bins-1, correlation_max_lag) - do i=1, n_bins-i_lag - data_correl(i_lag+1, :) = data_correl(i_lag+1, :) + (data(i,:)-data_mean(:))*(data(i+i_lag,:)-data_mean(:)) - end do - data_correl(i_lag+1, :) = data_correl(i_lag+1, :) / real(n_bins-i_lag, dp) - end do - else - do i_lag=0, min(n_bins-1, correlation_max_lag) - do i=1, n_bins-i_lag - data_correl(i_lag+1, :) = data_correl(i_lag+1, :) + (data(i,:))*(data(i+i_lag,:)) - end do - data_correl(i_lag+1, :) = data_correl(i_lag+1, :) / real(n_bins-i_lag, dp) - end do - endif - else ! over bins false - allocate(data_mean(size(data,1))) - data_mean = sum(data,2)/real(size(data,2),dp) - allocate(data_correl(n_bins, min(correlation_max_lag+1,n_data))) - data_correl = 0.0_dp - if (correlation_subtract_mean) then - do i_lag=0, min(n_data-1, correlation_max_lag) - do i=1, n_data-i_lag - data_correl(:, i_lag+1) = data_correl(:, i_lag+1) + (data(:,i)-data_mean(:))*(data(:,i+i_lag)-data_mean(:)) - end do - data_correl(:, i_lag+1) = data_correl(:, i_lag+1) / real(n_data-i_lag, dp) - end do - else - do i_lag=0, min(n_data-1, correlation_max_lag) - do i=1, n_data-i_lag - data_correl(:, i_lag+1) = data_correl(:, i_lag+1) + (data(:,i))*(data(:,i+i_lag)) - end do - data_correl(:, i_lag+1) = data_correl(:, i_lag+1) / real(n_data-i_lag, dp) - end do - endif - endif - deallocate(data_mean) -end subroutine - -! effective N_ind samples from autocorrelation variance -subroutine calc_correlation_var_effective_N(data_correl, over_bins, correlation_var_effective_N_long_lag, effective_N) - real(dp) :: data_correl(:,:) - logical :: over_bins - integer :: correlation_var_effective_N_long_lag - real(dp) :: effective_N(:) - - real(dp) :: correl_0, correl_mean, correl_std_dev - integer :: i - - if (over_bins) then - if (correlation_var_effective_N_long_lag+1 < size(data_correl,1)) then - do i=1, size(data_correl,2) - correl_0 = data_correl(1, i) - correl_mean = sum(data_correl(correlation_var_effective_N_long_lag+1:,i)) / real(size(data_correl,1)-correlation_var_effective_N_long_lag, dp) - correl_std_dev = sqrt( sum((data_correl(correlation_var_effective_N_long_lag+1:,i)-correl_mean)**2) / real(size(data_correl,1)-correlation_var_effective_N_long_lag, dp) ) - if (correl_std_dev > 1.0e-8_dp) then - effective_N(i) = (correl_0/correl_std_dev)**2 - else - effective_N(i) = -1 - endif - end do - endif ! long_lag short enough - else ! over_bins false - if (correlation_var_effective_N_long_lag+1 < size(data_correl,2)) then - do i=1, size(data_correl,1) - correl_0 = data_correl(i, 1) - correl_mean = sum(data_correl(i,correlation_var_effective_N_long_lag+1:)) / real(size(data_correl,2)-correlation_var_effective_N_long_lag, dp) - correl_std_dev = sqrt( sum((data_correl(i,correlation_var_effective_N_long_lag+1:)-correl_mean)**2) / real(size(data_correl,2)-correlation_var_effective_N_long_lag, dp) ) - if (correl_std_dev > 1.0e-8_dp) then - effective_N(i) = (correl_0/correl_std_dev)**2 - else - effective_N(i) = -1 - endif - call print(" i " // i // " correl_0 " // correl_0 // " mean " // correl_mean // " std_dev " // correl_std_dev // " eff_N " // effective_N(i), verbosity=PRINT_VERBOSE) - end do - endif ! long_lag short enough - endif ! over_bins -end subroutine - -! effective N_ind samples from summed ac, a la Sokal -subroutine calc_summed_ac_effective_N(N, data_correl, over_bins, max_lag, effective_N) - integer :: N - real(dp) :: data_correl(:,:) - logical :: over_bins - integer :: max_lag - real(dp) :: effective_N(:) - - real(dp) :: correl_0, two_tau_int - integer :: i - - if (over_bins) then - do i=1, size(data_correl,2) - correl_0 = data_correl(1, i) - two_tau_int = 1.0_dp + 2.0_dp*sum(data_correl(2:max_lag+1,i))/correl_0 - effective_N(i) = real(N,dp)/two_tau_int - call print("summed_ac i " // i // " correl_0 " // correl_0 // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE) - end do - else ! over_bins false - do i=1, size(data_correl,1) - correl_0 = data_correl(i, 1) - two_tau_int = 1.0_dp + 2.0_dp*sum(data_correl(i,2:max_lag+1))/correl_0 - effective_N(i) = real(N,dp)/two_tau_int - call print("summed_ac i " // i // " correl_0 " // correl_0 // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE) - end do - endif ! over_bins -end subroutine - -function calc_c_hat(data, k) result(c_hat) - real(dp) :: data(:) - integer :: k - real(dp) :: c_hat - - real(dp) :: sum_0, sum_k, sum_sq_0, sum_sq_k, cross_covar - real(dp) :: N_minus_k - integer :: N - - N = size(data) - sum_0 = sum(data(1:N-k)) - sum_k = sum(data(1+k:N)) - sum_sq_0 = sum(data(1:N-k)**2) - sum_sq_k = sum(data(1+k:N)**2) - cross_covar = sum(data(1:N-k)*data(1+k:N)) - N_minus_k = real(N-k,dp) - - c_hat = ( cross_covar/N_minus_k - sum_0*sum_k/N_minus_k**2 ) / & - ( sqrt(sum_sq_0 - (sum_0**2)/N_minus_k)* & - sqrt(sum_sq_k - (sum_k**2)/N_minus_k) / (N_minus_k-1.0_dp) ) -end function - -! effective N_ind samples from summed ac, a la Kerl -subroutine calc_sliding_window_effective_N(data, over_bins, max_k, effective_N) - real(dp) :: data(:,:) - logical :: over_bins - integer :: max_k - real(dp) :: effective_N(:) - - real(dp), allocatable :: c_hat(:) - real(dp) :: two_tau_int - integer :: i, k - - ! John Kerl Ph.D. Thesis - allocate(c_hat(1:max_k)) - - if (over_bins) then - do i=1, size(data,2) - do k=1, max_k - c_hat(k) = calc_c_hat(data(:,i),k) - call print("c_hat " // k // " " // c_hat(k)//" "//(1.0_dp+2.0_dp*sum(c_hat(1:k))), verbosity=PRINT_VERBOSE) - end do - two_tau_int = 1.0_dp + 2.0_dp*sum(c_hat) - effective_N(i) = real(size(data,1),dp)/two_tau_int - call print(" i " // i // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE) - end do - else ! over_bins false - do i=1, size(data,1) - do k=1, max_k - c_hat(k) = calc_c_hat(data(i,:),k) - call print("c_hat " // k // " " // c_hat(k)//" "//(1.0_dp+2.0_dp*sum(c_hat(1:k))), verbosity=PRINT_VERBOSE) - end do - two_tau_int = 1.0_dp + 2.0_dp*sum(c_hat) - effective_N(i) = real(size(data,2),dp)/two_tau_int - call print(" i " // i // " two_tau_int " // two_tau_int // " effective_N "// effective_N(i), verbosity=PRINT_VERBOSE) - end do - endif ! over_bins - - deallocate(c_hat) -end subroutine - -! effective N_ind samples from binning (blocking), a la Hartman -subroutine calc_binning_effective_N(data, over_bins, effective_N) - real(dp) :: data(:,:) - logical :: over_bins - real(dp) :: effective_N(:) - - real(dp) :: bin_size_d - integer :: i, bin_size, N - real(dp) :: err_est, prev_err_est, best_err_est, mean, means_variance_1 - - if (over_bins) then - do i=1, size(data,2) - N = size(data,1) - err_est=0.0_dp - best_err_est = -1.0_dp - bin_size_d = 1 - do while (bin_size_d > 0 .and. bin_size_d <= N/5) - bin_size = bin_size_d - - prev_err_est = err_est - err_est = binned_err_estimator(data(:,i),bin_size) - - if (err_est < prev_err_est .and. abs(err_est-prev_err_est)/(0.5_dp*(err_est+prev_err_est)) < 0.1_dp) best_err_est = err_est - call print("binning_effective_N " // bin_size//" "//err_est, verbosity=PRINT_VERBOSE) - bin_size_d = bin_size_d * 2 - end do - call print("", verbosity=PRINT_VERBOSE) - - if (best_err_est < 0.0_dp) best_err_est = prev_err_est - - mean = sum(data(:,i))/real(N,dp) - means_variance_1 = sum((data(:,i)-mean)**2)/real(N,dp) - effective_N(i) = means_variance_1/best_err_est**2 - if (effective_N(i) > N) effective_N(i) = N - end do - else - do i=1, size(data,1) - N = size(data,2) - err_est=0.0_dp - best_err_est = -1.0_dp - bin_size_d = 1 - do while (bin_size_d > 0 .and. bin_size_d <= N/5) - bin_size = bin_size_d - - prev_err_est = err_est - err_est = binned_err_estimator(data(i,:),bin_size) - - if (err_est < prev_err_est .and. abs(err_est-prev_err_est)/(0.5_dp*(err_est+prev_err_est)) < 0.1_dp) best_err_est = err_est - call print("binning_effective_N " // bin_size//" "//err_est, verbosity=PRINT_VERBOSE) - bin_size_d = bin_size_d * 2 - end do - call print("", verbosity=PRINT_VERBOSE) - - if (best_err_est < 0.0_dp) best_err_est = prev_err_est - - mean = sum(data(i,:))/real(N,dp) - means_variance_1 = sum((data(i,:)-mean)**2)/real(N,dp) - effective_N(i) = means_variance_1/best_err_est**2 - if (effective_N(i) > N) effective_N(i) = N - end do - end if -end subroutine - -function binned_err_estimator(data, bin_size) result(err_est) - real(dp) :: data(:) - integer :: bin_size - real(dp) :: err_est - - integer :: n_bins, bin_i, N - real(dp), allocatable :: means(:) - real(dp) :: means_mean, means_variance - - N = size(data) - n_bins = N/bin_size - allocate(means(n_bins)) - - do bin_i=1, n_bins - means(bin_i) = sum(data((bin_i-1)*bin_size+1:bin_i*bin_size))/real(bin_size,dp) - end do - means_mean = sum(means)/real(n_bins,dp) - means_variance = sum((means-means_mean)**2)/real(n_bins,dp) - err_est = sqrt(means_variance/real(n_bins,dp)) - - deallocate(means) -end function - -end module mean_var_correl_util_mod - -program mean_var_correl -use libatoms_module -use mean_var_correl_util_mod -implicit none - integer :: n_bins, n_data, n_weights, i, j, bin_i, skip, max_frame - logical :: do_weights - real(dp), allocatable :: data(:,:), weights(:), data_line(:), data_t(:,:), weights_t(:), weighted_data(:,:) - integer :: stat, new_data_array_size - character(len=128), allocatable :: bin_labels(:) - type(Dictionary) :: cli_params, data_params - logical :: do_mean, do_var, do_histogram, do_correl, correlation_subtract_mean, do_correlation_var_effective_N, do_summed_ac_effective_N, do_sliding_window_effective_N, do_binning_effective_N, do_exp_smoothing - logical :: do_bimod - real(dp) :: exp_smoothing_time - integer :: exp_smoothing_bin_i - integer :: histogram_n_bins - real(dp) :: histogram_min_v, histogram_max_v, histogram_cur_min_v, histogram_cur_max_v, histogram_extra_width, histogram_bin_width - logical :: do_histogram_effective_N, do_histogram_correl - character(len=STRING_LENGTH) :: infile_name, outfile_name - character(len=102400) :: myline - type(inoutput) :: infile, outfile - real(dp), allocatable :: data_mean(:), data_var(:), data_correl(:,:), data_histogram(:,:,:), data_histogram_data(:,:,:), data_histogram_correl(:,:) - real(dp), allocatable :: data_bimod(:), data_3_mom(:), data_4_mom(:) - real(dp), allocatable :: smooth_data_v(:) - integer :: reduction_index, other_index, sz, r_sz, correlation_max_lag, n_correl_print, correlation_var_effective_N_long_lag, sliding_window_effective_N_max_k, summed_ac_effective_N_max_lag - logical :: over_bins, over_time - real(dp), allocatable :: correlation_var_effective_N(:), summed_ac_effective_N(:), sliding_window_effective_N(:), binning_effective_N(:), histogram_effective_N(:,:) - character(len=STRING_LENGTH) :: verbosity_str - - call system_initialise() - - call initialise(cli_params) - call param_register(cli_params, "infile", "stdin", infile_name, help_string="input filename") - call param_register(cli_params, "outfile", "stdout", outfile_name, help_string="output filename") - call param_register(cli_params, "skip", "0", skip, help_string="skip this many initial frames") - call param_register(cli_params, "max_frame", "0", max_frame, help_string="stop at this frame. if 0, continue until end") - call param_register(cli_params, "mean", "F", do_mean, help_string="calculate mean") - call param_register(cli_params, "exp_smoothing", "F", do_exp_smoothing, help_string="calculate exponentially smoothed data") - call param_register(cli_params, "exp_smoothing_time", "100", exp_smoothing_time, help_string="time constant for exponential smoothing (in units of frames). 0 => no smoothing") - call param_register(cli_params, "exp_smoothing_bin_i", "0", exp_smoothing_bin_i, help_string="bin to evaluate for exponential smoothing") - call param_register(cli_params, "variance", "F", do_var, help_string="calculate variance") - call param_register(cli_params, "bimodality", "F", do_bimod, help_string="calculate Sarle's bimodality coefficient") - call param_register(cli_params, "correlation_var_effective_N", "F", do_correlation_var_effective_N, help_string="calculate effective N from ratio of initial variance to long time autocorrelation variance") - call param_register(cli_params, "correlation_var_effective_N_long_lag", "1001", & - correlation_var_effective_N_long_lag, help_string="lag after which autocorrelation is assumed to be in long time regime (for effective_N calculation)") - call param_register(cli_params, "summed_ac_effective_N", "F", do_summed_ac_effective_N, help_string="calculate Sokals's summed_ac \tau_{int} based effective N from integrated autocorrelation") - call param_register(cli_params, "summed_ac_effective_N_max_lag", "1001", & - summed_ac_effective_N_max_lag, help_string="max lag to calculate autocorrelation estimator for summed_ac effective N") - call param_register(cli_params, "sliding_window_effective_N", "F", do_sliding_window_effective_N, help_string="calculate Kerl's sliding_window \tau_{int} based effective N from fancy integrated autocorrelation") - call param_register(cli_params, "sliding_window_effective_N_max_k", "1001", & - sliding_window_effective_N_max_k, help_string="max lag to calculate autocorrelation estimator for sliding window effective N") - call param_register(cli_params, "binning_effective_N", "F", do_binning_effective_N, help_string="calculate binning effective N") - call param_register(cli_params, "correlation", "F", do_correl, help_string="calculate autocorrelation") - call param_register(cli_params, "correlation_subtract_mean", "T", correlation_subtract_mean, help_string="subtract mean before calculating autocorrelation") - call param_register(cli_params, "correlation_max_lag", "2000", correlation_max_lag, help_string="maxmimum lag to compute autocorrelation for") - call param_register(cli_params, "histogram", "F", do_histogram, help_string="compute histogram") - call param_register(cli_params, "histogram_n_bins", "10", histogram_n_bins, help_string="number of bins for histogram calculation") - call param_register(cli_params, "histogram_extra_width", "0.1", histogram_extra_width, help_string="extra range to do histogram over, in fractions of max_val-min_val (ignored if histogram_min,max_v are used)") - call param_register(cli_params, "histogram_effective_N", "F", do_histogram_effective_N, help_string="if true calculate effective N for bins based on autocorrelation") - call param_register(cli_params, "histogram_correl", "F", do_histogram_correl, help_string="if true calculate autocorrelation for histogram bins") - call param_register(cli_params, "histogram_min_v", "0.0", histogram_min_v, help_string="minimum value to use for histogram range (if not specified, automatic)") - call param_register(cli_params, "histogram_max_v", "-1.0", histogram_max_v, help_string="maximum value to use for histogram range (if not specified, automatic)") - call param_register(cli_params, "over_bins", "F", over_bins, help_string="do mean/variance/correlation over bins") - call param_register(cli_params, "over_time", "F", over_time, help_string="do mean/variance/correlation over time") - call param_register(cli_params, "verbosity", "NORMAL", verbosity_str, help_string="verbosity level") - if (.not.param_read_args(cli_params)) then - call print("Usage: "//trim(EXEC_NAME)//" infile=stdin outfile=stdout mean=F variance=F correlation=F effective_N=F", PRINT_ALWAYS) - call print(" correlation_max_lag=1000 correlation_var_effective_N_long_lag=1001 over_bins=F over_time=T", PRINT_ALWAYS) - call system_abort("Unable to parse command line") - endif - call finalise(cli_params) - - if (over_bins .and. over_time) & - call system_abort("specified both over_bins="//over_bins//" over_time="//over_time) - - call verbosity_push(verbosity_of_str(trim(verbosity_str))) - - if (.not. over_bins .and. .not. over_time) then - over_bins = .false. - over_time = .true. - endif - - if (over_bins) then - reduction_index = 1 - other_index = 2 - else - reduction_index = 2 - other_index = 1 - endif - - call initialise(data_params) - call param_register(data_params, "n_bins", param_mandatory, n_bins, help_string="number of bins at each data timepoint") - call param_register(data_params, "n_data", '-1', n_data, help_string="number of data timepoints, < 0 to figure out from length of file") - call param_register(data_params, "do_weights", 'F', do_weights, help_string="If true, do weighted mean") - - call initialise(infile, infile_name, INPUT) - myline=read_line(infile) ! comment - myline=read_line(infile) ! data description - if (.not.param_read_line(data_params, trim(myline), ignore_unknown=.false.)) & - call system_abort("Couldn't parse n_bins or n_data in 2nd line of file") - - if (do_weights) then - if (over_bins) call system_abort("Can't do weighted mean over bins") - n_weights = 1 - else - n_weights = 0 - end if - - allocate(bin_labels(n_bins)) - do i=1, n_bins - bin_labels(i) = read_line(infile) - end do - allocate(data_line(n_bins+n_weights)) - if(skip > 0) then - do i=1,skip - call read_ascii(infile, data_line(:)) - end do - n_data = n_data-skip - end if - if (n_data > 0) then - if(max_frame > 0 .and. max_frame <= n_data) then - n_data = max_frame - end if - allocate(data(n_bins, n_data)) - if (n_weights > 0) then - allocate(weights(n_data)) - endif - do i=1, n_data - call read_ascii(infile, data_line(:)) - if (n_weights > 0) then - weights(i) = data_line(1) - data(:,i) = data_line(2:) - else - data(:,i) = data_line(:) - endif - end do - else ! n_data <= 0, figure out by reading - print *, "doing n_data = 0" - ! initial counters and storage - n_data = 0 - allocate(data(n_bins,1)) - if (n_weights > 0) allocate(weights(1)) - ! read a line - do while (.true.) - call read_ascii(infile, data_line(:), stat) - if (stat < 0 .or. (max_frame > 0 .and. n_data == max_frame)) then ! end - ! if we have extra space, reallocate to precise space - if (size(data,2) /= n_data) then - ! allocate temporary space - allocate(data_t(n_bins, n_data)) - ! copy into temporary - data_t = data(:,1:n_data) - ! reallocate intended space to exact size - deallocate(data) - allocate(data(n_bins, n_data)) - data = data_t - ! clear up temporary - deallocate(data_t) - ! do the same for weights - if (n_weights > 0) then - allocate(weights_t(n_data)) - weights_t = weights(1:n_data) - deallocate(weights) - allocate(weights(n_data)) - weights = weights_t - deallocate(weights_t) - endif - endif - exit ! from while loop - elseif (stat == 0) then ! add this line - ! if we don't have space for additional entry, reallocate it - if (n_data >= size(data,2)) then - ! allocate temporary space - allocate(data_t(n_bins,n_data)) - data_t = data - deallocate(data) - new_data_array_size = max(int(1.5*n_data),2) - allocate(data(n_bins, new_data_array_size)) - data(1:n_bins,1:n_data) = data_t(:,:) - deallocate(data_t) - if (n_weights > 0) then - allocate(weights_t(n_data)) - weights_t = weights - deallocate(weights) - allocate(weights(new_data_array_size)) - weights(1:n_data) = weights_t(:) - deallocate(weights_t) - endif - endif - ! add additional entry - n_data = n_data + 1 - if (n_weights > 0) then - weights(n_data) = data_line(1) - data(:,n_data) = data_line(2:) - else - data(:,n_data) = data_line(:) - endif - else ! real error - call system_abort("Read error in data " // stat) - endif - end do ! while - endif - deallocate(data_line) - print *, "final n_data", n_data - - sz = size(data, other_index) - r_sz = size(data, reduction_index) - - call initialise(outfile, outfile_name, OUTPUT) - - - allocate(data_mean(sz)) - if (n_weights > 0) then - allocate(weighted_data(size(data,1),size(data,2))) - do i=1, n_data - weighted_data(:,i) = data(:,i) * weights(i) - end do - data_mean = sum(weighted_data,reduction_index) / sum(weights) - deallocate(weighted_data) - else - data_mean = sum(data,reduction_index)/real(size(data,reduction_index),dp) - endif - - if (do_var .or. do_bimod) then - allocate(data_var(sz)) - if (over_bins) then - do i=1, sz - data_var(i) = sum((data(:,i)-data_mean(i))**2)/size(data,reduction_index) - end do - else - if (n_weights > 0) then - do i=1, sz - data_var(i) = sum(weights(:)*(data(i,:)-data_mean(i))**2)/sum(weights) - end do - else - do i=1, sz - data_var(i) = sum((data(i,:)-data_mean(i))**2)/size(data,reduction_index) - end do - endif - endif - endif - - ! b = \frac{(\mu_3^2/\mu_2^3) + 1.0}{\mu_4/\mu_2^2}, - if (do_bimod) then - allocate(data_bimod(sz)) - allocate(data_3_mom(sz)) - allocate(data_4_mom(sz)) - if (over_bins) then - do i=1, sz - data_3_mom(i) = sum((data(:,i)-data_mean(i))**3)/size(data,reduction_index) - data_4_mom(i) = sum((data(:,i)-data_mean(i))**4)/size(data,reduction_index) - end do - else - if (n_weights > 0) then - do i=1, sz - data_3_mom(i) = sum(weights(:)*(data(i,:)-data_mean(i))**3)/sum(weights) - data_4_mom(i) = sum(weights(:)*(data(i,:)-data_mean(i))**4)/sum(weights) - end do - else - do i=1, sz - data_3_mom(i) = sum((data(i,:)-data_mean(i))**3)/size(data,reduction_index) - data_4_mom(i) = sum((data(i,:)-data_mean(i))**4)/size(data,reduction_index) - end do - endif - endif - data_bimod = ((data_3_mom**2 / data_var**3) + 1.0) / (data_4_mom/data_var**2) - deallocate(data_3_mom, data_4_mom) - endif - - if (do_correl .or. do_correlation_var_effective_N .or. do_summed_ac_effective_N) then - call calc_correl(data, n_bins, n_data, over_bins, correlation_max_lag, correlation_subtract_mean, data_correl) - - if (do_correl) then - call print("# correl", file=outfile) - if (over_bins) then - n_correl_print = n_data - else - n_correl_print = min(n_data, correlation_max_lag+1) - endif - do i=1, n_correl_print - call print(""//data_correl(:,i), file=outfile) - end do - endif - - if (do_correlation_var_effective_N) then - allocate(correlation_var_effective_N(sz)) - call calc_correlation_var_effective_N(data_correl, over_bins, correlation_var_effective_N_long_lag, correlation_var_effective_N) - endif - if (do_summed_ac_effective_N) then - allocate(summed_ac_effective_N(sz)) - call calc_summed_ac_effective_N(size(data,reduction_index), data_correl, over_bins, summed_ac_effective_N_max_lag, summed_ac_effective_N) - endif - endif ! do_correl or do_effective_N - if (do_sliding_window_effective_N) then - allocate(sliding_window_effective_N(sz)) - call calc_sliding_window_effective_N(data, over_bins, sliding_window_effective_N_max_k, sliding_window_effective_N) - endif - if (do_binning_effective_N) then - allocate(binning_effective_N(sz)) - call calc_binning_effective_N(data, over_bins, binning_effective_N) - endif - - ! data(n_bins, n_data) - if (do_exp_smoothing) then - if (over_bins) then - call system_abort("Can't actually do exponentially smoothed time trace over bins") - else - myline="# bin_label value" - if (exp_smoothing_bin_i <= 0 .or. exp_smoothing_bin_i > n_bins) then - call system_abort("exp_smoothing_bin_i out of range "//exp_smoothing_bin_i) - endif - endif - call print(trim(myline), file=outfile) - if (over_bins) then - call system_abort("Can't actually do exponentially smoothed time trace over bins") - else - allocate(smooth_data_v(n_bins)) - smooth_data_v(1:n_bins) = data(1:n_bins, 1) - call print(trim(bin_labels(exp_smoothing_bin_i))//" "//smooth_data_v(exp_smoothing_bin_i), file=outfile) - do i=2, n_data - if (exp_smoothing_time > 0.0_dp) then - smooth_data_v(1:n_bins) = (1.0_dp - 1.0_dp/exp_smoothing_time)*smooth_data_v(1:n_bins) + 1.0_dp/exp_smoothing_time*data(1:n_bins, i) - else - smooth_data_v(1:n_bins) = data(1:n_bins, i) - endif - call print(trim(bin_labels(exp_smoothing_bin_i))//" "//smooth_data_v(exp_smoothing_bin_i), file=outfile) - end do - endif - end if ! do_exp_smoothing - - if (do_mean .or. do_var .or. do_bimod .or. do_correlation_var_effective_N .or. do_summed_ac_effective_N .or. do_sliding_window_effective_N .or. do_binning_effective_N) then - if (over_bins) then - myline = "#" - else - myline = "# bin_label" - endif - if (do_mean) myline = trim(myline) //" mean" - if (do_var) myline = trim(myline) //" var N" - if (do_bimod) myline = trim(myline) //" bimod" - if (do_correlation_var_effective_N) myline = trim(myline) // " correlation_var_effective_N correlation_var_effective_decorrel_time" - if (do_summed_ac_effective_N) myline = trim(myline) // " summed_ac_effective_N summed_ac_effective_decorrel_time" - if (do_sliding_window_effective_N) myline = trim(myline) // " sliding_window_effective_N sliding_window_effective_decorrel_time" - if (do_binning_effective_N) myline = trim(myline) // " binning_effective_N binning_effective_decorrel_time" - - call print(trim(myline), file=outfile) - - do i=1, sz - if (over_bins) then - myline = "" - else - myline = trim(bin_labels(i)) - endif - if (do_mean) myline = trim(myline) //" " // data_mean(i) - if (do_var) myline = trim(myline) //" " // data_var(i)//" "//size(data,reduction_index) - if (do_bimod) myline = trim(myline) //" " // data_bimod(i) - if (do_correlation_var_effective_N) then - if (correlation_var_effective_N(i) > 0) then - myline = trim(myline) // " " // correlation_var_effective_N(i) // " " // (size(data,reduction_index)/correlation_var_effective_N(i)) - else - myline = trim(myline) // " " // correlation_var_effective_N(i) // " " // 0 - endif - endif - if (do_summed_ac_effective_N) then - if (summed_ac_effective_N(i) > 0) then - myline = trim(myline) // " " // summed_ac_effective_N(i) // " " // (size(data,reduction_index)/summed_ac_effective_N(i)) - else - myline = trim(myline) // " " // summed_ac_effective_N(i) // " " // 0 - endif - endif - if (do_sliding_window_effective_N) then - if (sliding_window_effective_N(i) > 0) then - myline = trim(myline) // " " // sliding_window_effective_N(i) // " " // (size(data,reduction_index)/sliding_window_effective_N(i)) - else - myline = trim(myline) // " " // sliding_window_effective_N(i) // " " // 0 - endif - endif - if (do_binning_effective_N) then - if (binning_effective_N(i) > 0) then - myline = trim(myline) // " " // binning_effective_N(i) // " " // (size(data,reduction_index)/binning_effective_N(i)) - else - myline = trim(myline) // " " // binning_effective_N(i) // " " // 0 - endif - endif - call print(trim(myline), file=outfile) - end do - end if - - if (do_histogram) then - ! data(n_bins, n_data) - allocate(data_histogram(3, histogram_n_bins, sz)) - if (do_histogram_effective_N) then - allocate(data_histogram_data(histogram_n_bins, r_sz, sz)) - data_histogram_data = 0.0_dp - endif - data_histogram = 0.0_dp - do i=1, sz - if (histogram_max_v > histogram_min_v) then - histogram_cur_min_v = histogram_min_v - histogram_cur_max_v = histogram_max_v - else - if (over_bins) then - histogram_cur_min_v = minval(data(:,i)) - histogram_cur_max_v = maxval(data(:,i)) - else - histogram_cur_min_v = minval(data(i,:)) - histogram_cur_max_v = maxval(data(i,:)) - endif - histogram_extra_width = (histogram_cur_max_v-histogram_cur_min_v)*histogram_extra_width - histogram_cur_min_v = histogram_cur_min_v - histogram_extra_width - histogram_cur_max_v = histogram_cur_max_v + histogram_extra_width - endif - histogram_bin_width = (histogram_cur_max_v-histogram_cur_min_v)/histogram_n_bins - if (histogram_bin_width == 0.0_dp) histogram_bin_width = 1.0e-8_dp - do bin_i=1, histogram_n_bins - data_histogram(1, bin_i, i) = histogram_cur_min_v+(real(bin_i,dp)-0.5_dp)*histogram_bin_width - end do - do j=1, r_sz - if (over_bins) then - bin_i = (data(j,i) - histogram_cur_min_v)/histogram_bin_width+1 - else - bin_i = (data(i,j) - histogram_cur_min_v)/histogram_bin_width+1 - endif - if (bin_i >= 1 .and. bin_i <= histogram_n_bins) then - data_histogram(2,bin_i,i) = data_histogram(2,bin_i,i) + 1.0_dp - if (do_histogram_effective_N) then - data_histogram_data(bin_i, j, i) = 1 - endif - endif - end do ! r_sz - end do ! i - data_histogram(2,:,:) = data_histogram(2,:,:)/real(r_sz, dp) - ! root variance - data_histogram(3,:,:) = sqrt(data_histogram(2,:,:) - data_histogram(2,:,:)**2) - ! normalize - data_histogram(2:3,:,:) = data_histogram(2:3,:,:)/histogram_bin_width - if (do_histogram_effective_N) then - allocate(histogram_effective_N(histogram_n_bins,sz)) - do i=1, sz - call calc_correl(data_histogram_data(:,:,i), histogram_n_bins, n_data, .false., correlation_max_lag, .true., data_histogram_correl) - if (do_histogram_correl) then - do bin_i=1, histogram_n_bins - call print("# data_histogram_correl i="//i // " bin=" // bin_i) - do j=1, size(data_histogram_correl,2) - call print(data_histogram_correl(bin_i,j)) - end do - call print("") - call print("") - end do - endif - mainlog%prefix="EFF_N value_i="//i - call calc_correlation_var_effective_N(data_histogram_correl, .false., correlation_var_effective_N_long_lag, histogram_effective_N(:,i)) - mainlog%prefix="" - end do - endif - - if (do_histogram_effective_N) then - call print("# v p(v) rms(p(v)) effective_N", file=outfile) - else - call print("# v p(v) rms(p(v))", file=outfile) - endif - - do i=1, sz - if (over_bins) then - myline = "#" - else - myline = "# "//trim(bin_labels(i)) - endif - call print(trim(myline), file=outfile) - do bin_i=1, histogram_n_bins - if (do_histogram_effective_N) then - call print(data_histogram(:,bin_i,i)//" "//histogram_effective_N(bin_i,i), file=outfile) - else - call print(data_histogram(:,bin_i,i), file=outfile) - endif - end do - call print("", file=outfile) - call print("", file=outfile) - end do - end if ! do_histogram - - call finalise(outfile) - call system_finalise() - -end program - diff --git a/src/Structure_processors/mean_var_decorrelated_err.f95 b/src/Structure_processors/mean_var_decorrelated_err.f95 deleted file mode 100644 index c5ec9afb40..0000000000 --- a/src/Structure_processors/mean_var_decorrelated_err.f95 +++ /dev/null @@ -1,42 +0,0 @@ -program do_statistics_decorrelated_err -use libatoms_module, only : dp, system_initialise, system_finalise, system_abort, verbosity_push, verbosity_pop, verbosity_of_str, initialise, finalise, read_file, print, operator(//), param_register, param_read_args -use libatoms_module, only : PRINT_SILENT, PRINT_ALWAYS, INPUT, STRING_LENGTH -use libatoms_module, only : inoutput, dictionary -use statistics_module, only : mean_var_decorrelated_err -implicit none - integer :: i, N - real(dp), allocatable :: A(:,:) - real(dp) :: m, v, decorrelation_t, decorrelated_error - character(len=100), allocatable :: lines(:) - type(inoutput) :: io - type(Dictionary) :: cli - character(len=STRING_LENGTH) :: verbosity_str - integer :: n_col - - call system_initialise(verbosity=PRINT_SILENT) - call initialise(cli) - call param_register(cli, "verbosity", "NORMAL", verbosity_str, help_string="verbosity level") - call param_register(cli, "n_col", "1", n_col, help_string="number of columns of data to be analyzed") - if (.not. param_read_args(cli, ignore_unknown=.false., task="mean_var_decorrelated_err CLI arguments")) then - call print("Usage: mean_var_decorrelated_err [ verbosity=LEVEL ] [ n_col=n(1) ]", PRINT_ALWAYS) - call system_abort("Failed to parse command line arguments") - end if - call finalise(cli) - call verbosity_push(verbosity_of_str(trim(verbosity_str))) - - call initialise(io, "stdin", INPUT) - - call read_file(io, lines, N) - allocate(A(N,n_col)) - do i=1, N - read (lines(i), *) A(i,:) - end do - do i=1, n_col - call mean_var_decorrelated_err(A(:,i), m, v, decorrelated_error, decorrelation_t) - call print("col " // i // " mean " // m // " variance " // v // " decorrelation_t " // decorrelation_t // " decorrelated_error " // decorrelated_error) - end do - - call verbosity_pop() - call system_finalise() - -end program diff --git a/src/Structure_processors/merge_traj.f95 b/src/Structure_processors/merge_traj.f95 deleted file mode 100644 index 6c1c25ca94..0000000000 --- a/src/Structure_processors/merge_traj.f95 +++ /dev/null @@ -1,102 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -! Syntax: merge_traj - -program merge_traj - use libAtoms_module - - integer, parameter :: FN_MAX = 100 - - ! --- - - type(Atoms) :: at - type(CInOutput) :: infile, outfile - - ! --- - - character(FN_MAX) :: outfn, infn - character(FN_MAX), allocatable :: infndescr(:) - - integer :: i, j, frame, n - integer :: error - - ! --- - - call system_initialise - - n = cmd_arg_count() - allocate(infndescr(n-1)) - - call get_cmd_arg(1, outfn) - do i = 1, n-1 - call get_cmd_arg(i+1, infndescr(i)) - enddo - - call print("Creating merged trajectory file " // outfn) - call initialise(outfile, outfn, action=OUTPUT, error=error) - HANDLE_ERROR(error) - frame = 0 - do i = 1, n-1 - j = index(infndescr(i), "@") - if (j == 0) then - call print("..." // infndescr(i)) - call initialise(infile, infndescr(i), action=INPUT, error=error) - HANDLE_ERROR(error) - do j = 1, infile%n_frame - call read(infile, at, frame=j-1, error=error) - HANDLE_ERROR(error) - call write(outfile, at, frame=frame, error=error) - HANDLE_ERROR(error) - frame = frame + 1 - enddo - call finalise(infile) - else - infn = infndescr(i)(:j-1) - read (infndescr(i)(j+1:), *) j - call print("..." // trim(infn) // ", frame " // j) - call initialise(infile, infn, action=INPUT, error=error) - call read(infile, at, frame=j, error=error) - HANDLE_ERROR(error) - call write(outfile, at, frame=frame, error=error) - HANDLE_ERROR(error) - frame = frame + 1 - call finalise(infile) - endif - enddo - call finalise(outfile) - - deallocate(infndescr) - - call system_finalise - -endprogram merge_traj diff --git a/src/Structure_processors/move_displacement_field.f95 b/src/Structure_processors/move_displacement_field.f95 deleted file mode 100644 index 48c1e02de4..0000000000 --- a/src/Structure_processors/move_displacement_field.f95 +++ /dev/null @@ -1,122 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! move displacement field along a shift vector (defined in reference config) to -! figure out which shifted atom's displacement corresponds to which original atom -program move_displacement_field -use libatoms_module -implicit none - real(dp) :: shift_vec(3) - real(dp) :: l_cutoff, dist_tol - real(dp), allocatable :: new_pos(:,:) - type(Atoms) :: config, ref_config - character(len=STRING_LENGTH) :: config_filename, ref_config_filename - type(CInoutput) :: config_io, ref_config_io - type(Dictionary) :: cli_params - real(dp) :: cur_displacement(3) - real(dp) :: dist - integer :: i, shifted_i - integer :: cell_image_Na, cell_image_Nb, cell_image_Nc - - call system_initialise() - call initialise(cli_params) - call param_register(cli_params, "config_filename", PARAM_MANDATORY, config_filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "ref_config_filename", PARAM_MANDATORY, ref_config_filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "shift_vec", PARAM_MANDATORY, shift_vec, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "cutoff", "5.0", l_cutoff, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "dist_tol", "0.3", dist_tol, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - call print("Usage: move_displacement_field config_filename=file ref_config_filename=file shift_vec={x y z}", PRINT_ALWAYS) - call print(" cutoff=r(5.0) dist_tol=t(0.3)", PRINT_ALWAYS) - call system_abort("confused by command line arguments") - endif - call finalise(cli_params) - - call print("parameters:") - call print("config_filename " // trim(config_filename)) - call print("ref_config_filename " // trim(ref_config_filename)) - call print("shift_vec " // shift_vec) - call print("cutoff " // l_cutoff) - call print("dist_tol " // dist_tol) - call print("") - - call initialise(config_io, config_filename, action=INPUT) - call read(config, config_io) - call finalise(config_io) - - call initialise(ref_config_io, ref_config_filename, action=INPUT) - call read(ref_config, ref_config_io) - call finalise(ref_config_io) - - if (config%N /= ref_config%N) call system_abort("number of atoms mismatch " // config%N // " " // ref_config%N) - - allocate(new_pos(3,config%N)) - - call set_cutoff(ref_config, l_cutoff) - call calc_connect(ref_config) - - call fit_box_in_cell(l_cutoff, l_cutoff, l_cutoff, ref_config%lattice, cell_image_Na, cell_image_Nb, cell_image_Nc) - cell_image_Na = max(1,(cell_image_Na+1)/2) - cell_image_Nb = max(1,(cell_image_Nb+1)/2) - cell_image_Nc = max(1,(cell_image_Nc+1)/2) - - new_pos(1:3,1:config%N) = config%pos(1:3,1:config%N) - - do i=1, config%N - if (mod(i,1000) == 1) write (*,'(a,$)') "." - ! atom closest to displaced position - shifted_i = closest_atom(ref_config, ref_config%pos(:,i)+shift_vec, cell_image_Na, cell_image_Nb, cell_image_Nc, dist=dist) - - if (current_verbosity() >= PRINT_VERBOSE) then - if (shifted_i > 0) then - call print("mapping displacement cur " // i // " " // config%pos(:,i) // " to " // shifted_i // " " // config%pos(:,shifted_i) // " dist " // dist) - endif - endif - - if (shifted_i > 0 .and. dist < dist_tol) then ! found a close match - ! current displacement of atom i - cur_displacement(1:3) = config%pos(:,i) - ref_config%pos(:,i) - ! new position of atom shifted_i from current displacement of atom i - new_pos(:,shifted_i) = ref_config%pos(:,shifted_i) + cur_displacement - else - if (current_verbosity() >= PRINT_VERBOSE) then - call print("no mapping for " // i // " " // config%pos(:,i)) - endif - endif - - end do - call print("") - - config%pos(1:3,1:config%N) = new_pos(1:3,1:config%N) - - call write(config, "stdout", prefix="SHIFTED_CONFIG") - - call system_finalise() -end program diff --git a/src/Structure_processors/msd_vibrations.f95 b/src/Structure_processors/msd_vibrations.f95 deleted file mode 100755 index 9eb2af229b..0000000000 --- a/src/Structure_processors/msd_vibrations.f95 +++ /dev/null @@ -1,131 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program msd -use libatoms_module - character(len=STRING_LENGTH) :: infile_name - type(inoutput) :: infile - type(Atoms) :: current, mean, prev - type(Dictionary) :: cli_params - integer :: stat - integer :: i, n_config - integer :: shift(3) - real(dp) :: dummy - real(dp), pointer :: dr(:) - - call system_initialise() - - call initialise(cli_params) - call param_register(cli_params, 'infile', PARAM_MANDATORY, infile_name, help_string="No help yet. This source file was $LastChangedBy$") - - call print("n_args " // cmd_arg_count()) - - if (.not. param_read_args(cli_params)) then - call print('Usage: msd infile=filename.xyz') - call system_abort("Bad CLI parameter") - endif - call finalise(cli_params) - - call initialise(infile, infile_name) - - call read_xyz(current, infile, status=stat) - - n_config = 0 - do while (stat == 0) - n_config = n_config + 1 - if (mean%N == 0) then ! first config - mean = current - prev = current -! call print("mean_calc initial current") -! call print_xyz(current, mainlog) - else - do i=1, current%N - dummy = distance_min_image(current, current%pos(:,i), prev%pos(:,i), shift=shift) - if (any(shift /= 0)) then - current%pos(:,i) = current%pos(:,i) - (current%lattice .mult. shift) - endif - end do - mean%pos = mean%pos + current%pos - prev = current -! call print("mean_calc wrapped current") -! call print_xyz(current, mainlog) - endif - call read_xyz(current, infile, status=stat) - end do - - mean%pos = mean%pos/real(n_config,dp) - -! call print("mean") -! call print_xyz(mean, mainlog) - - call finalise(infile) - - call add_property(mean, "dr", 0.0_dp) - if (.not. assign_pointer(mean, "dr", dr)) & - call system_abort("Impossible failure to assign pointer for dr") - dr(:) = 0.0_dp - - call initialise(infile, infile_name) - - call read_xyz(current, infile, status=stat) - prev = current - do while (stat == 0) -! call print("msd_calc pre-wrap prev") -! call print_xyz(prev, mainlog) -! call print("msd_calc pre-wrap current") -! call print_xyz(current, mainlog) - do i=1, current%N - dummy = distance_min_image(current, current%pos(:,i), prev%pos(:,i), shift=shift) -! call print("dummy " // dummy // " shift " // shift) - if (any(shift /= 0)) then - current%pos(:,i) = current%pos(:,i) - (current%lattice .mult. shift) - endif - end do - prev = current - -! call print("msd_calc wrapped current") -! call print_xyz(current, mainlog) - do i=1, current%N - dr(i) = dr(i) + sum((current%pos(:,i)-mean%pos(:,i))**2) - end do - - call read_xyz(current, infile, status=stat) - end do - - dr = dr/real(n_config,dp) - - call finalise(infile) - - mainlog%prefix="MSD" - call print_xyz(mean, mainlog, all_properties=.true.) - mainlog%prefix="" - - call system_finalise() -end program msd diff --git a/src/Structure_processors/rdfd.f95 b/src/Structure_processors/rdfd.f95 deleted file mode 100644 index b2bdda6e78..0000000000 --- a/src/Structure_processors/rdfd.f95 +++ /dev/null @@ -1,323 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! RDFD -! Tool for calculating Radial Distribution Functions from xyz files -! The extra 'D' shows that the RDF is calculated as a function of distance from some centre and binned -! The centre is a position and not an atom -! -! rdfd -program RDFD - - use libatoms_module - - implicit none - - type(Atoms) :: at - type(InOutput) :: xyzfile, datafile - integer :: Za, Zb - integer :: frames_read, frames_processed - integer :: status - integer :: i, j - - !Binning & histograms - integer :: rdf_bin, dist_bin - integer :: num_rdf_bins, num_dist_bins - integer :: num_A_atoms, num_B_atoms - real(dp) :: r, B_density - integer, allocatable, dimension(:,:) :: rdf_data - integer, allocatable, dimension(:) :: num_atoms - - !Input - type(Dictionary) :: params_in - character(STRING_LENGTH) :: xyzfilename, datafilename - real(dp) :: d_cutoff, d_binwidth - real(dp) :: rdf_cutoff, rdf_binwidth - real(dp), dimension(3) :: centre - character(STRING_LENGTH) :: mask1, mask2 - integer :: IO_Rate - integer :: decimation - integer :: from, to - logical :: Gaussian_smoothing - real(dp) :: Gaussian_sigma - - !Start up LOTF, suppressing messages - call system_initialise(PRINT_NORMAL) - call verbosity_push(PRINT_NORMAL) - -#ifdef DEBUG - call print('********** DEBUG BUILD **********') - call print('') -#endif - - call initialise(params_in) - call param_register(params_in, 'xyzfile', param_mandatory, xyzfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'datafile', 'data.den1', datafilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'AtomMask1', param_mandatory, mask1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'AtomMask2', param_mandatory, mask2, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'centre', '0. 0. 0.', centre, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'RDFCutoff', param_mandatory, rdf_cutoff, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'RDFBinWidth', param_mandatory, rdf_binwidth, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'DistCutoff', param_mandatory, d_cutoff, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'DistBinWidth', param_mandatory, d_binwidth, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'decimation', '1', decimation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'from', '0', from, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'to', '0', to, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="No help yet. This source file was $LastChangedBy$") -! call param_register(params_in, 'Gaussian', 'F', Gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") -! call param_register(params_in, 'sigma', '0.0', Gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(params_in)) then - if (EXEC_NAME == '') then - call print_usage - else - call print_usage(EXEC_NAME) - end if - call system_abort('could not parse argument line') - end if - call finalise(params_in) - - call print('Run_parameters: ') - call print('==================================') - call print(' Input file: '//trim(xyzfilename)) - call print(' Output file: '//trim(datafilename)) - call print(' AtomMask1: '//trim(mask1)) - call print(' AtomMask2: '//trim(mask2)) - call print(' centre: '//round(centre(1),3)//' '//round(centre(2),3)//' '//round(centre(3),3)) - call print(' RDFCutoff: '//round(rdf_cutoff,3)) - call print(' RDFBinWidth: '//round(rdf_binwidth,3)) - call print(' DistCutoff: '//round(d_cutoff,3)) - call print(' DistBinWidth: '//round(d_binwidth,3)) - call print(' decimation: '//decimation) - if (decimation == 1) then - call print(' Processing every frame') - else - write(line,'(a,i0,a,a)')' Processing every ',decimation,th(decimation),' frame' - call print(line) - end if - call print(' from Frame: '//from) - call print(' to Frame: '//to) - call print(' IO_Rate: '//IO_Rate) - call print(' Gaussians: '//Gaussian_smoothing) - if (Gaussian_smoothing) call print(' sigma: '//round(Gaussian_sigma,3)) - call print('==================================') - call print('') - - call initialise(xyzfile,xyzfilename,action=INPUT) - - call print('Mask 1:') - call print('=======') - Za = Atomic_Number(mask1) - call print('') - call print('Selecting all '//trim(ElementName(Za))//' atoms (Z = '//Za//')') - call print('') - - call print('Mask 2:') - call print('=======') - Zb = Atomic_Number(mask2) - call print('') - call print('Selecting all '//trim(ElementName(Zb))//' atoms (Z = '//Zb//')') - call print('') - - if (d_cutoff < 0.0_dp) call system_abort('Distance cutoff < 0.0 Angstroms') - if (d_binwidth < 0.0_dp) call system_abort('Distance bin width < 0.0 Angstroms') - if (rdf_cutoff < 0.0_dp) call system_abort('RDF cutoff < 0.0 Angstroms') - if (rdf_binwidth < 0.0_dp) call system_abort('RDF bin width < 0.0 Angstroms') - - !Make the number of bins and bin widths consistent - num_rdf_bins = ceiling(rdf_cutoff / rdf_binwidth) - rdf_binwidth = rdf_cutoff / real(num_rdf_bins,dp) - num_dist_bins = ceiling(d_cutoff / d_binwidth) - d_binwidth = d_cutoff / real(num_dist_bins,dp) - - !Set up arrays - allocate( rdf_data(num_rdf_bins,num_dist_bins), num_atoms(num_dist_bins) ) - - rdf_data = 0 - num_atoms = 0 - - call print('') - call print('RDFs from ('//centre//') out to '//round(d_cutoff,3)//'A') - call print('Each RDF has '//num_rdf_bins//' bins x '//round(rdf_binwidth,3)//'A per bin = '//round(rdf_cutoff,3)//'A cutoff') - call print('') - - call print('Reading data...') - frames_read = 0 - frames_processed = 0 - - do - - call read_xyz(at,xyzfile,status=status) - if (status/=0) then - if (frames_processed > 1) call write_data - exit - end if - frames_read = frames_read + 1 - - ! Do the calculation between form and to: - if (frames_read.ge.from) then - if ((frames_read.gt.to) .and.(to.gt.0)) exit - ! Loop over all atoms - num_A_atoms = 0 - num_B_atoms = 0 - do i = 1, at%N - - !Count 'B' atoms - if (at%Z(i) == Zb) num_B_atoms = num_B_atoms + 1 - - !Do we have an 'A' atom? - if (at%Z(i) /= Za) cycle - - num_A_atoms = num_A_atoms + 1 - - !Is this 'A' atom within the cutoff of the centre? - r = distance_min_image(at,i,centre) - if (r >= d_cutoff) cycle - - !Increase the atom count at this distance - dist_bin = bin(0.0_dp,d_cutoff,d_binwidth,r) - num_atoms(dist_bin) = num_atoms(dist_bin) + 1 - - !Loop over all other atoms - do j = 1, at%N - - ! Skip self - if (i==j) cycle - - !Do we have a 'B' atom? - if (at%Z(j) /= Zb) cycle - - !Is this 'B' atom within the rdf cutoff of the 'A' atom? - r = distance_min_image(at,i,j) - if (r >= rdf_cutoff) cycle - - !Increase the count at this distance - rdf_bin = bin(0.0_dp,rdf_cutoff,rdf_binwidth,r) - rdf_data(rdf_bin,dist_bin) = rdf_data(rdf_bin,dist_bin) + 1 - - end do - - end do - - B_density = real(num_B_atoms,dp) / cell_volume(at) - - frames_processed = frames_processed + 1 - write(mainlog%unit,'(a,a,i0,$)') achar(13),'Frame ',frames_read - - if (mod(frames_processed,IO_Rate)==0) then - !call print('writing data to datafile '//trim(datafile%filename)) - call write_data - endif - endif - - !Skip ahead (decimation-1) frames - do i = 1, (decimation-1) - call read_xyz(xyzfile,status) - if (status/=0) exit - frames_read = frames_read + 1 - end do - if (status/=0) exit - - end do - - call print('Finished.') - call print('Read '//frames_read//' frames, processed '//frames_processed//' frames.') - - call verbosity_pop - call system_finalise() - -contains - - subroutine write_data - - integer :: i, j - real(dp) :: dist, rdf_dist, rdf, rdf_int, dV - - call initialise(datafile,datafilename,action=OUTPUT) - - do i = 1, num_dist_bins - - dist = (real(i,dp)-0.5_dp)*d_binwidth - - do j = 1, num_rdf_bins - - rdf_dist = (real(j,dp)-0.5_dp)*rdf_binwidth - dV = PI*rdf_binwidth * ( 4.0_dp*rdf_dist*rdf_dist + rdf_binwidth*rdf_binwidth/3.0_dp ) - - if (num_atoms(i) > 0) then - rdf_int = real(rdf_data(j,i),dp) / (real(num_atoms(i),dp)) - else - rdf_int = 0 - end if - rdf = rdf_int / ( dV * B_density ) - - call print(round(dist,5)//' '//round(rdf_dist,5)//' '//round(rdf,5)//' '//round(rdf_int,5),file=datafile) - - end do - - call print('',file=datafile) !Insert blank line to separate data sets - - end do - - call finalise(datafile) - - end subroutine write_data - - - subroutine print_usage(name) - - character(*), optional, intent(in) :: name - - if (present(name)) then - write(line,'(3a)')'Usage: ',trim(name),' [] [] [] []' - else - write(line,'(a)')'Usage: rdfd [] [] [] []' - end if - call print(line) - call print(' The input xyz file.') - call print(' An element symbol, e.g. H or Ca') - call print(' An element symbol, e.g. H or Ca') - call print(' The central atom.') - call print(' The width of bins into which rdfs are placed.') - call print(' The cutoff radius for the distance from the centre.') - call print(' The cutoff radius for the RDF in Angstroms.') - call print(' The width of each bin in Angstroms used for individual rdf calculations.') - call print(' The output data file.') - call print(' Optional. Only process 1 out of every n frames') - call print(' Optional. Only process frames from this frame') - call print(' Optional. Only process frames until this frame') - call print(' Optional. Write data after every n processed frames') - call print('') - - call verbosity_pop - call system_finalise - - end subroutine print_usage - -end program RDFD diff --git a/src/Structure_processors/rings.f95 b/src/Structure_processors/rings.f95 deleted file mode 100644 index 50c5bb9156..0000000000 --- a/src/Structure_processors/rings.f95 +++ /dev/null @@ -1,109 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -program rings - use libatoms_module - - implicit none - - real(DP) :: CC_cutoff - integer, parameter :: MAX_RING_LEN = 20 - integer, parameter :: DIST_CUTOFF = MAX_RING_LEN+1 - integer, parameter :: MAX_GROUPS = 20 - - type(Dictionary) :: cli_params - character(len=STRING_LENGTH) :: infilename - type(CInOutput) :: infile - type(Atoms) :: at - integer i - integer :: error = ERROR_NONE - - integer :: diameter, o - - integer, allocatable :: dist(:, :) - integer :: ring_stat(MAX_RING_LEN) - - logical, allocatable :: mask(:) - - call system_initialise(PRINT_NORMAL) - - call initialise(cli_params) - call param_register(cli_params, 'infile', 'stdin', infilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'CC_cutoff', PARAM_MANDATORY, CC_cutoff, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - call system_abort('could not parse argument line') - end if - call finalise(cli_params) - - call print("infile " // trim(infilename)) - - call initialise(infile, infilename, action=INPUT, no_compute_index=.true.) - - i = 1 - call read(infile, at, error=error) - HANDLE_ERROR(error) - - call set_cutoff(at, CC_cutoff) - call calc_connect(at) - - allocate(dist(at%N, at%N)) - - ! - ! Create the graph of connected C-C - ! - - ring_stat = 0 - - allocate(mask(at%N)) - mask=.true. - - !mask = (at%Z == 6) .and. (at%pos(3, :) > 11.0_DP) - !mask = (at%Z == 6) - - call distance_map(at, dist, mask=mask, diameter=diameter) - call print("# Graph diameter: " // diameter) - call count_sp_rings(at, CC_cutoff, dist, MAX_RING_LEN, & - ring_stat, mask=mask) - - o = sum(ring_stat) - do i = 1, MAX_RING_LEN - write (*, '(I5,I10,F10.5)') i, ring_stat(i), 1.0_DP*ring_stat(i)/o - enddo - - deallocate(mask) - - deallocate(dist) - - call finalise(infile) - call system_finalise() - -end program rings diff --git a/src/Structure_processors/solvate.f95 b/src/Structure_processors/solvate.f95 deleted file mode 100644 index c8b31a81ea..0000000000 --- a/src/Structure_processors/solvate.f95 +++ /dev/null @@ -1,177 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! solvate a molecule. Needs a solute and a solvent XYZ input file (only water). -! [x/y/z][min/max] specify the new lattice, which must not be smaller than the solute's lattice and larger than the solvate lattice. -! could be improved: e.g. shift the water file to cover *min -- *max, at the moment it works only if centred around the origin, -! multiply water file to cover any box size, -! check whether water molecules touch any other added water molecules. -! center_around_atom : to center the solvent around atom and shift that atom to the origin before mapping into cell - -program solvate - - use libatoms_module - - implicit none - - type(Atoms) :: at, wat, at2 - integer :: i, j, stat - type(dictionary) :: cli_params - character(len=STRING_LENGTH) :: filename, waterfilename, solvated_filename -! type(inoutput) :: xyzfile, waterfile - real(dp) :: xmin, xmax, ymin, ymax, zmin, zmax, exclusion, security_zone - logical :: add_molec - integer :: center_around_atom - real(dp) :: shift(3) - real(dp), pointer :: pos_p(:,:), avgpos_p(:,:) - - call system_initialise(verbosity=PRINT_SILENT) - call verbosity_push(PRINT_NORMAL) - - call initialise(cli_params) - call param_register(cli_params,"file","stdin", filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"waterfile","stdin", waterfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"outfile","stdout", solvated_filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"xmin",PARAM_MANDATORY, xmin, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"ymin",PARAM_MANDATORY, ymin, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"zmin",PARAM_MANDATORY, zmin, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"xmax",PARAM_MANDATORY, xmax, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"ymax",PARAM_MANDATORY, ymax, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"zmax",PARAM_MANDATORY, zmax, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"exclusion","2.4", exclusion, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"center_around_atom","0", center_around_atom, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"security_zone","1.0", security_zone, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - !call system_abort("Usage: decimate [file=(stdin)] [waterfile=(stdin)] xmin xmax ymin ymax zmin zmax [exclusion=(2.4)] [security_zone=(1.0)] [center_around_atom=0]") - call print_usage - call system_abort('could not parse argument line') - endif - call finalise(cli_params) - - !Read in the 2 files - call print("Reading file to solvate: "//trim(filename)) - call read(at, filename, error=stat) - if (stat /= 0) call system_abort('Could not read file to solvate.') - !center around given atom, if required - if (center_around_atom > 0) then - if (center_around_atom > at%N) call system_abort("center_around_atom must be less than the number of solvent atoms "//at%N) - shift = at%pos(1:3,center_around_atom) - do i=1,at%N - at%pos(1:3,i) = at%pos(1:3,i) - shift(1:3) - enddo - endif - call map_into_cell(at) - - call print("Reading waterfile: "//trim(waterfilename)) - call read(wat, waterfilename, error=stat) - if (stat /= 0) call system_abort('Could not read water file.') - call map_into_cell(wat) - - !check for cell size -- if the water file is at least as big as the solute. - do i=1,3 - do j=1,3 - if (at%lattice(i,j).gt.wat%lattice(i,j)) call system_abort('Too small water file') - enddo - enddo - - call print("Starting solvation.") - !Initialise the solvated atoms object - call initialise(at2,0,reshape((/xmax-xmin,0._dp,0._dp,0._dp,ymax-ymin,0._dp,0._dp,0._dp,zmax-zmin/),(/3,3/))) - - !Add solute atoms to at2 - do i=1,at%N - call add_atoms(at2,at%pos(1:3,i),at%Z(i)) - enddo - - !Add water molecules between the given limits to at2 - do i=1,wat%N,3 - add_molec = .false. - if (minval(wat%pos(1,i:i+2)).gt.xmin+security_zone .and. & - maxval(wat%pos(1,i:i+2)).lt.xmax-security_zone .and. & - minval(wat%pos(2,i:i+2)).gt.ymin+security_zone .and. & - maxval(wat%pos(2,i:i+2)).lt.ymax-security_zone .and. & - minval(wat%pos(3,i:i+2)).gt.zmin+security_zone .and. & - maxval(wat%pos(3,i:i+2)).lt.zmax-security_zone ) then - add_molec = .true. - endif - do j = 1,at%N - if (distance_min_image(at2,j,wat%pos(1:3,i )).lt.exclusion .or. & - distance_min_image(at2,j,wat%pos(1:3,i+1)).lt.exclusion .or. & - distance_min_image(at2,j,wat%pos(1:3,i+2)).lt.exclusion ) then - add_molec = .false. - endif - enddo - if (add_molec) then - call add_atoms(at2,wat%pos(1:3,i ),wat%Z(i )) - call add_atoms(at2,wat%pos(1:3,i+1),wat%Z(i+1)) - call add_atoms(at2,wat%pos(1:3,i+2),wat%Z(i+2)) - endif - enddo - - call map_into_cell(at2) - - !add avgpos property that can be used for the topology calc. - call add_property(at2,'avgpos',0._dp, n_cols=3) - if (.not.(assign_pointer(at2, "avgpos", avgpos_p))) call system_abort('??') - if (.not.(assign_pointer(at2, "pos", pos_p))) call system_abort('??') - avgpos_p(1:3,1:at2%N) = pos_p(1:3,1:at2%N) - - if (stat == 0) then - call print("Printing solvated file into "//trim(solvated_filename)) - call write(at2, solvated_filename) - endif - - call verbosity_pop() - call system_finalise() - -contains - - !call system_abort("Usage: decimate [file=(stdin)] [waterfile=(stdin)] xmin xmax ymin ymax zmin zmax [exclusion=(2.4)] [security_zone=(1.0)] [center_around_atom=0]") - subroutine print_usage - - call print("Usage: decimate [file=(stdin)] [waterfile=(stdin)] xmin xmax ymin ymax zmin zmax [exclusion=(2.4)] [security_zone=(1.0)] [center_around_atom=0]") - call print('') - call print(' file=filename, the solute file') - call print(' waterfile=filename, the solvent (only water) file, with cell size at least the size of the solute file') - call print(' xmin, the lower limit of the solvated file in the x direction (should be >= 0.5*solvent file cell edge in x direction)') - call print(' xmax, the lower limit of the solvated file in the y direction (should be <= 0.5*solvent file cell edge in x direction)') - call print(' ymin, the lower limit of the solvated file in the z direction (should be >= 0.5*solvent file cell edge in y direction)') - call print(' ymax, the lower limit of the solvated file in the x direction (should be <= 0.5*solvent file cell edge in y direction)') - call print(' zmin, the lower limit of the solvated file in the y direction (should be >= 0.5*solvent file cell edge in z direction)') - call print(' zmax, the lower limit of the solvated file in the z direction (should be <= 0.5*solvent file cell edge in z direction)') - call print(' [exclusion=0.], optionally keeps a layer around the solvent where there will be no solvent molecule') - call print(' [security_zone=1.], optionally keeps a layer on the edge of the solvated box where there will be no water molecule placed to avoid clashes in PBC') - call print(' [center_around_atom=1], optionally shifts the solute molecule so that the atom with this index will be at the origin') - - call print('') - - end subroutine - -end program solvate diff --git a/src/Structure_processors/solvate_silica.f95 b/src/Structure_processors/solvate_silica.f95 deleted file mode 100644 index f1c1ea5bec..0000000000 --- a/src/Structure_processors/solvate_silica.f95 +++ /dev/null @@ -1,257 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! solvate a molecule. Needs a solute and a solvent XYZ input file. -! shifts and rotates the solvent file so that -! atom1_point has position atom1_pos -! atom1_point -> atom2_vector is` aligned with atom12_vector -! atom3 is in the atom1_pos - atom1_pos+atom12_vector - atom123_plane plane. -! don't include water molecules closer to the solute than exclusion -! rotation_sign to play around with - -program solvate_silica - - use libatoms_module - - implicit none - - type(Atoms) :: at, wat, at2 - type(dictionary) :: cli_params - character(len=STRING_LENGTH) :: filename, waterfilename - integer :: i, j, stat - - !solvation of solvent - real(dp) :: exclusion - integer :: silica_atoms - logical :: add - - !orientation of solvent - integer :: atom1_point, atom2_vector, atom3_plane - real(dp) :: atom1_pos(3), atom12_vector(3), atom123_plane_point(3) - integer :: rotation_sign1 - integer :: rotation_sign2 - real(dp) :: shift(3) - real(dp) :: vector_1(3), vector_2(3) - real(dp) :: theta, axis(3), origin(3) - real(dp) :: unit_vector12(3), projection_of_atom3_on_atom12_vector(3) - real(dp) :: surface_normal(3) - logical :: rotation2_pluspi - - call system_initialise(verbosity=PRINT_SILENT) -! call verbosity_push(PRINT_NORMAL) - - call initialise(cli_params) - call param_register(cli_params,"file","stdin", filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"waterfile","stdin", waterfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"silica_atoms",'0', silica_atoms, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"atom1_point",PARAM_MANDATORY, atom1_point, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"atom2_vector",PARAM_MANDATORY, atom2_vector, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"atom3_plane",PARAM_MANDATORY, atom3_plane, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'atom1_pos', '(/0.0 0.0 0.0/)', atom1_pos, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'atom12_vector', PARAM_MANDATORY, atom12_vector, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'atom123_plane_point', PARAM_MANDATORY, atom123_plane_point, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"exclusion","0.0", exclusion, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"rotation1_sign",'1', rotation_sign1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"rotation2_sign",'1', rotation_sign2, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"rotation2_pluspi",'F', rotation2_pluspi, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - !call system_abort("Usage: decimate [file=(stdin)] [waterfile=(stdin)] silica_atoms atom1_point atom2_vector atom3_plane atom1_pos atom12_vector atom123_plane_point exclusion rotation1_sign rotation2_sign2 rotation2_pluspi") - call verbosity_push(PRINT_NORMAL) - call print_usage - call system_abort('could not parse argument line') - endif - call finalise(cli_params) - - if (abs(rotation_sign1) /= 1) call system_abort("rotation1_sign must be +/-1") - if (abs(rotation_sign2) /= 1) call system_abort("rotation2_sign must be +/-1") - - !Read in the 2 files - call read(at, filename, error=stat) - if (stat /= 0) call system_abort('Could not read file to solvate.') - call map_into_cell(at) - call read(wat, waterfilename, error=stat) - if (stat /= 0) call system_abort('Could not read water file.') - call map_into_cell(wat) - - !Initialise the solvated atoms object - call initialise(at2,0,reshape(reshape(wat%lattice, (/9/)), (/3,3/))) - -!!!position and orientation of solvent - - !shift atom1_point to the origin (centre of rotation) - - shift = at%pos(1:3,atom1_point) - do i=1,at%N - at%pos(1:3,i) = at%pos(1:3,i) - shift(1:3) - enddo - call calc_connect(at) - call map_into_cell(at) - call calc_dists(at) - - !rotate solvent to align atom1->atom2 vector with atom12_vector - - !vectors we want to lay on top of each other - vector_1(1:3) = diff_min_image(at,atom1_point,atom2_vector) !pointing from atom1 -> atom2 - vector_2(1:3) = atom12_vector(1:3) !pointing from atom1 -> atom2, with arbitrary length - - call print('vector_1('//atom1_point//'->'//atom2_vector//') = '//vector_1(1:3)) - call print('vector_2('//atom1_point//'->'//atom2_vector//') = '//vector_2(1:3)) - - !calc. angle between the two vectors - theta = acos( dot_product(vector_1(1:3),vector_2(1:3)) / & - sqrt(dot_product(vector_1(1:3),vector_1(1:3))) / & - sqrt(dot_product(vector_2(1:3),vector_2(1:3))) ) - - call print('angle = '//theta) - - !calc. axis that is normal to both vectors - axis(1:3) = vector_1(1:3) .cross. vector_2(1:3) - - call print('axis = '//axis) - - origin(1:3) = 0._dp - - !rotate only the 2nd config - call rotate(at%pos, real(rotation_sign1,dp)*axis, theta, origin) - -call print('atom1--atom2 vector should be all right:') -call write(at, 'stdout') - - !rotate solvent around atom12_vector axis to move atom3_plane into the plane that is defined by - ! - origin(1:3) = (/0.,0.,0./), - ! - atom12_vector(1:3) and - ! - atom123_planepoint(1:3)-atom1_point(1:3) - - !projection of atom3 onto atom12_vector - ! (at1->at3 .dot. unit_vector) * unit_vector : the unit vector in atom12_vector direction - unit_vector12 = atom12_vector(1:3) / norm(atom12_vector(1:3)) - projection_of_atom3_on_atom12_vector(1:3) = & - ( (at%pos(1:3,atom3_plane)-at%pos(1:3,atom1_point)) .dot. unit_vector12(1:3) ) * unit_vector12(1:3) - -call print("Projection of atom3 to atom12 vector: "//projection_of_atom3_on_atom12_vector(1:3)) - - !we want to rotate this - vector_1(1:3) = at%pos(1:3,atom3_plane) - projection_of_atom3_on_atom12_vector(1:3) - !onto vector_2, i.e. vector from projection-point, _|_ to vector12, on the plane - surface_normal(1:3) = ( atom123_plane_point(1:3) - at%pos(1:3,atom1_point) ) .cross. atom12_vector(1:3) - vector_2(1:3) = surface_normal(1:3) .cross. atom12_vector(1:3) -!OR (-1)* the same __/\ - vector_2(1:3) = vector_2(1:3) / norm(vector_2(1:3)) * norm(vector_1(1:3)) - - call print('vector_1() = '//vector_1(1:3)) - call print('vector_2() = '//vector_2(1:3)) - - !calc. angle between the two vectors - theta = acos( dot_product(vector_1(1:3),vector_2(1:3)) / & - sqrt(dot_product(vector_1(1:3),vector_1(1:3))) / & - sqrt(dot_product(vector_2(1:3),vector_2(1:3))) ) - - call print('angle = '//theta) - - !calc. axis that is normal to both vectors - axis(1:3) = vector_1(1:3) .cross. vector_2(1:3) - - call print('axis = '//axis) - call print('atom12_vector should be the same = '//atom12_vector) - - origin(1:3) = 0._dp - - !rotate only the 2nd config - if (rotation2_pluspi) theta = theta + PI - call rotate(at%pos, (real(rotation_sign2,dp)) * axis, theta, origin) - -call print('atom3 should be in plane with vector12 and atom3_plane_point:') -call print('v13 x v12 . v1planepoint = '//(diff_min_image(at, atom1_point, atom3_plane) .cross. atom12_vector(1:3) .dot. atom123_plane_point(1:3))) -call write(at, 'stdout') - - !shifting it to the required position - do i=1,at%N - at%pos(1:3,i) = at%pos(1:3,i) + atom1_pos(1:3) - enddo - - !Add atoms to solvate to at2 - do i=1,at%N - call add_atoms(at2,at%pos(1:3,i),at%Z(i)) - enddo - - !add silica - do i=1,silica_atoms - call add_atoms(at2,wat%pos(1:3,i ),wat%Z(i )) - enddo - !Add water molecules between the given limits to at2 - do i=silica_atoms+1,wat%N,3 - add = .true. - do j = 1,at%N - if (distance_min_image(at2,j,wat%pos(1:3,i )).lt.exclusion .or. & - distance_min_image(at2,j,wat%pos(1:3,i+1)).lt.exclusion .or. & - distance_min_image(at2,j,wat%pos(1:3,i+2)).lt.exclusion ) then - add = .false. - endif - enddo - if (add) then - call add_atoms(at2,wat%pos(1:3,i ),wat%Z(i )) - call add_atoms(at2,wat%pos(1:3,i+1),wat%Z(i+1)) - call add_atoms(at2,wat%pos(1:3,i+2),wat%Z(i+2)) - endif - enddo - - call map_into_cell(at2) - call verbosity_push(PRINT_NORMAL) - if (stat == 0) call write(at2, 'stdout') - - call verbosity_pop() - call system_finalise() - -contains - - !call system_abort("Usage: decimate [file=(stdin)] [waterfile=(stdin)] silica_atoms atom1_point atom2_vector atom3_plane atom1_pos atom12_vector atom123_plane_point exclusion rotation1_sign rotation2_sign2 rotation2_pluspi") - subroutine print_usage - - call print("Usage: decimate [file=(stdin)] [waterfile=(stdin)] silica_atoms atom1_point atom2_vector atom3_plane atom1_pos atom12_vector atom123_plane_point exclusion rotation1_sign rotation2_sign2 rotation2_pluspi") - call print('') - call print(' file=filename, the solute file') - call print(' waterfile=filename, the solvent (containing silica and water) file, with cell size at least the size of the solute file the size of the solvated molecule will be the same as the cell of the waterfile') - call print(' silica_atoms, the number of silica atoms in the solvent file') - call print(' atom1_point, the solute atom with this index to set (atom1_point) coordinate in the solvent file') - call print(' atom2_vector, the solute atom with this index to set (atom1_point,atom2_vector) direction in the solvent file') - call print(' atom3_plane, the solute atom with this index to set (atom1_point,atom2_vector,atom3_plane) plane in the solvent file') - call print(' atom1_pos, the position of atom1_point in the solvated file') - call print(' atom12_vector, the direction of atom1_point -> atom2_vector vector in the solvated file') - call print(' atom123_plane point, a point on the plane that contains atom1_point, atom2_vector and atom3_plane in the solvated file') - call print(' [exclusion=0.], optionally keeps a layer around the solvent where there will be no solvent molecule (valid for water, not silica)') - call print(' [rotation1_sign=1], optionally rotate in the negative direction, when rotating the solute molecule to align atom1&2 with atom12_vector') - call print(' [rotation2_sign=1], optionally rotate in the negative direction, when rotating the solute molecule to rotate atom3_plane into the (atom1_pos,atom12_vector,atom123_plane_point) plane') - call print(' [rotation2_pluspi=F], optionally rotate pi more, to have atom3_plane on the other side of (atom1_point,atom2_vector) vector') - - call print('') - - end subroutine - -end program solvate_silica diff --git a/src/Structure_processors/structure_analysis_traj.f95 b/src/Structure_processors/structure_analysis_traj.f95 deleted file mode 100644 index fabccd18e5..0000000000 --- a/src/Structure_processors/structure_analysis_traj.f95 +++ /dev/null @@ -1,1400 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! do various structural analysis to a trajectory, save an intermediate file -! to be postprocessed (mean, variance, correlation, etc) -! #/vol density on a radial mesh -! #/vol density on a grid -! RDF, possibly as a function of distance of center from a fixed point -! to be added: ADF - -module structure_analysis_module -use libatoms_module -use structure_analysis_routines_module -implicit none -private - -type analysis - character(len=STRING_LENGTH) :: type ! type of analysis, used to fill in list of logicals - logical :: density_radial, density_grid, KE_density_radial, rdfd, integrated_rdfd, xrd, adfd, & !water - KEdf_radial, propdf_radial, geometry, & !general - density_axial_silica, num_hbond_silica, water_orientation_silica !silica-water interface - character(len=STRING_LENGTH) :: outfilename - character(len=STRING_LENGTH) :: mask_str - - integer :: n_configs = 0 - - real(dp) :: min_time, max_time - integer :: min_frame, max_frame - - ! radial density stuff - real(dp) :: density_radial_bin_width - integer :: density_radial_n_bins - integer :: density_radial_center_at - real(dp) :: density_radial_center(3) - real(dp) :: density_radial_gaussian_sigma - real(dp), allocatable :: density_radial_histograms(:,:) - real(dp), allocatable :: density_radial_pos(:) - - ! density grid stuff - real(dp) :: density_grid_min_p(3), density_grid_bin_width(3) - integer :: density_grid_n_bins(3) - logical :: density_grid_gaussian_smoothing - real(dp) :: density_grid_gaussian_sigma - real(dp), allocatable :: density_grid_histograms(:,:,:,:) - real(dp), allocatable :: density_grid_pos(:,:,:,:) - - ! radial KE density stuff - real(dp) :: KE_density_radial_bin_width - integer :: KE_density_radial_n_bins - integer :: KE_density_radial_center_at - real(dp) :: KE_density_radial_center(3) - real(dp) :: KE_density_radial_gaussian_sigma - real(dp), allocatable :: KE_density_radial_histograms(:,:) - real(dp), allocatable :: KE_density_radial_pos(:) - - ! rdfd stuff - real(dp) :: rdfd_zone_center(3) - integer :: rdfd_zone_atom_center - character(STRING_LENGTH) :: rdfd_center_mask_str, rdfd_neighbour_mask_str - real(dp) :: rdfd_zone_width, rdfd_bin_width - integer :: rdfd_n_zones, rdfd_n_bins - logical :: rdfd_gaussian_smoothing - real(dp) :: rdfd_gaussian_sigma - real(dp), allocatable :: rdfds(:,:,:) - real(dp), allocatable :: rdfd_zone_pos(:), rdfd_bin_pos(:) - - ! xrd stuff - real(dp) :: xrd_lambda - real(dp) :: xrd_2theta_range(2) - integer :: xrd_n_2theta - real(dp) :: xrd_k_spacing - real(dp), allocatable :: xrds(:,:) - real(dp), allocatable :: xrd_2theta_pos(:) - logical :: xrd_Lorentz_polarization - - ! adfd stuff - real(dp) :: adfd_zone_center(3) - character(STRING_LENGTH) :: adfd_center_mask_str, adfd_neighbour_1_mask_str, adfd_neighbour_2_mask_str - logical :: adfd_dist_bin_rc2 - real(dp) :: adfd_neighbour_1_max_dist - real(dp) :: adfd_zone_width, adfd_dist_bin_width - integer :: adfd_n_zones, adfd_n_dist_bins, adfd_n_angle_bins - real(dp), allocatable :: adfds(:,:,:,:) - real(dp), allocatable :: adfd_zone_pos(:), adfd_dist_bin_pos(:), adfd_angle_bin_pos(:) - - ! r-dep KE distribution - character(STRING_LENGTH) :: KEdf_radial_mask_str - real(dp) :: KEdf_radial_gaussian_sigma - real(dp) :: KEdf_radial_zone_center(3) - integer :: KEdf_radial_zone_center_at - real(dp) :: KEdf_radial_zone_width, KEdf_radial_bin_width - integer :: KEdf_radial_n_zones, KEdf_radial_n_bins - real(dp), allocatable :: KEdf_radial_bin_pos(:), KEdf_radial_zone_pos(:), KEdf_radial_histograms(:,:,:) - - ! r-dep |F| distribution - character(STRING_LENGTH) :: propdf_radial_mask_str - real(dp) :: propdf_radial_gaussian_sigma - real(dp) :: propdf_radial_zone_center(3) - integer :: propdf_radial_zone_center_at - real(dp) :: propdf_radial_zone_width, propdf_radial_bin_width - integer :: propdf_radial_n_zones, propdf_radial_n_bins - real(dp), allocatable :: propdf_radial_bin_pos(:), propdf_radial_zone_pos(:), propdf_radial_histograms(:,:,:) - character(len=STRING_LENGTH) :: propdf_radial_property - - !geometry - character(STRING_LENGTH) :: geometry_filename - type(Table) :: geometry_params - integer :: geometry_central_atom - real(dp), allocatable :: geometry_histograms(:,:) - real(dp), allocatable :: geometry_pos(:) - character(STRING_LENGTH), allocatable :: geometry_label(:) - - !uniaxial density - for silica-water interface - integer :: density_axial_axis !x:1,y:2,z:3 - real(dp) :: density_axial_bin_width - integer :: density_axial_n_bins - integer :: density_axial_silica_atoms - real(dp) :: density_axial_gaussian_sigma - logical :: density_axial_gaussian_smoothing - real(dp), allocatable :: density_axial_histograms(:,:) - real(dp), allocatable :: density_axial_pos(:) - - !silica_numhb - hydrogen bond distribution for silica-water interface - integer :: num_hbond_axis !x:1,y:2,z:3 - integer :: num_hbond_silica_atoms - integer :: num_hbond_n_type=4 - integer :: num_hbond_n_bins - logical :: num_hbond_gaussian_smoothing - real(dp) :: num_hbond_gaussian_sigma - real(dp), allocatable :: num_hbond_histograms(:,:,:) - real(dp), allocatable :: integrated_num_hbond_histograms(:,:) - integer, allocatable :: num_hbond_type_code(:) - real(dp), allocatable :: num_hbond_bin_pos(:) - character(STRING_LENGTH), allocatable :: num_hbond_type_label(:) - - !silica_water_orientation - water orientation distribution for silica-water interface - integer :: water_orientation_axis !x:1,y:2,z:3 - integer :: water_orientation_silica_atoms - integer :: water_orientation_n_angle_bins - integer :: water_orientation_n_pos_bins - logical :: water_orientation_gaussian_smoothing - real(dp) :: water_orientation_pos_gaussian_sigma - !real(dp) :: water_orientation_angle_gaussian_sigma - logical :: water_orientation_use_dipole - logical :: water_orientation_use_HOHangle_bisector - real(dp), allocatable :: water_orientation_histograms(:,:,:) - real(dp), allocatable :: integrated_water_orientation_histograms(:,:) - real(dp), allocatable :: water_orientation_pos_bin(:) - real(dp), allocatable :: water_orientation_angle_bin(:) - real(dp), allocatable :: water_orientation_angle_bin_w(:) - -end type analysis - -public :: analysis, analysis_read, check_analyses, do_analyses, print_analyses - -interface reallocate_data - module procedure reallocate_data_1d, reallocate_data_2d, reallocate_data_3d -end interface reallocate_data - -contains - -subroutine analysis_read(this, prev, args_str) - type(analysis), intent(inout) :: this - type(analysis), intent(in), optional :: prev - character(len=*), optional, intent(in) :: args_str - - type(Dictionary) :: params - integer :: dummy_i_1 - character(len=STRING_LENGTH) :: dummy_c_1, dummy_c_2 - logical :: dummy_l_1, dummy_l_2 - - call initialise(params) - ! dummy parameters required for some (undocumented) reason... - call param_register(params, 'infile', '', dummy_c_1, help_string="(Dummy parameter)") - call param_register(params, 'commandfile', '', dummy_c_2, help_string="(Dummy parameter)") - call param_register(params, 'decimation', '0', dummy_i_1, help_string="(Dummy parameter)") - call param_register(params, 'infile_is_list', 'F', dummy_l_1, help_string="(Dummy parameter)") - call param_register(params, 'quiet', 'F', dummy_l_2, help_string="(Dummy parameter)") - - if (.not. present(prev)) then - ! general - call param_register(params, 'outfile', 'stdout', this%outfilename, help_string="Output file name (default: stdout)") - call param_register(params, 'AtomMask', '', this%mask_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'min_time', '-1.0', this%min_time, help_string="Only include frames with Time >= min_time") - call param_register(params, 'max_time', '-1.0', this%max_time, help_string="Only include frames with Time <= max_time") - call param_register(params, 'min_frame', '-1', this%min_frame, help_string="Only include frames with number (not counting skipped) >= min_frame") - call param_register(params, 'max_frame', '-1', this%max_frame, help_string="Only include frames with number (not counting skipped) <= max_frame") - call param_register(params, 'type', '', this%type, help_string="[density_radial | density_grid | KE_density_radial | rdfd | xrd | adfd | KEdf_radial | propdf_radial | geometry | density_axial_silica | num_hbond_silica | water_orientation_silica ]") - else - ! general - call param_register(params, 'outfile', trim(prev%outfilename), this%outfilename, help_string="") - call param_register(params, 'AtomMask', trim(prev%mask_str), this%mask_str, help_string="") - call param_register(params, 'min_time', ''//prev%min_time, this%min_time, help_string="") - call param_register(params, 'max_time', ''//prev%max_time, this%max_time, help_string="") - call param_register(params, 'min_frame', ''//prev%min_frame, this%min_frame, help_string="") - call param_register(params, 'max_frame', ''//prev%max_frame, this%max_frame, help_string="") - call param_register(params, 'type', ''//trim(prev%type), this%type, help_string="[density_radial | density_grid | KE_density_radial | rdfd | xrd | adfd | KEdf_radial | propdf_radial | geometry | density_axial_silica | num_hbond_silica | water_orientation_silica ]") - endif - - if (.not. present(prev)) then - ! radial density - call param_register(params, 'density_radial_bin_width', '-1.0', this%density_radial_bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_radial_n_bins', '-1', this%density_radial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_radial_center', '0.0 0.0 0.0', this%density_radial_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_radial_center_at', '-1', this%density_radial_center_at, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_radial_sigma', '1.0', this%density_radial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - else - ! radial density - call param_register(params, 'density_radial_bin_width', ''//this%density_radial_bin_width, this%density_radial_bin_width, help_string="") - call param_register(params, 'density_radial_n_bins', ''//this%density_radial_n_bins, this%density_radial_n_bins, help_string="") - call param_register(params, 'density_radial_center', ''//prev%density_radial_center, this%density_radial_center, help_string="") - call param_register(params, 'density_radial_center_at', ''//prev%density_radial_center_at, this%density_radial_center_at, help_string="") - call param_register(params, 'density_radial_sigma', ''//prev%density_radial_gaussian_sigma, this%density_radial_gaussian_sigma, help_string="") - endif - - if (.not. present(prev)) then - ! grid density - call param_register(params, 'density_grid_min_p', '0.0 0.0 0.0', this%density_grid_min_p, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_grid_bin_width', '-1.0 -1.0 -1.0', this%density_grid_bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_grid_n_bins', '-1 -1 -1', this%density_grid_n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_grid_gaussian', 'F', this%density_grid_gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_grid_sigma', '1.0', this%density_grid_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - else - ! grid density - call param_register(params, 'density_grid_min_p', ''//prev%density_grid_min_p, this%density_grid_min_p, help_string="") - call param_register(params, 'density_grid_bin_width', ''//prev%density_grid_bin_width, this%density_grid_bin_width, help_string="") - call param_register(params, 'density_grid_n_bins', ''//prev%density_grid_n_bins, this%density_grid_n_bins, help_string="") - call param_register(params, 'density_grid_gaussian', ''//prev%density_grid_gaussian_smoothing, this%density_grid_gaussian_smoothing, help_string="") - call param_register(params, 'density_grid_sigma', ''//prev%density_grid_gaussian_sigma, this%density_grid_gaussian_sigma, help_string="") - endif - - if (.not. present(prev)) then - ! radial KE density - call param_register(params, 'KE_density_radial_bin_width', '-1.0', this%KE_density_radial_bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KE_density_radial_n_bins', '-1', this%KE_density_radial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KE_density_radial_center', '0.0 0.0 0.0', this%KE_density_radial_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KE_density_radial_center_at', '-1', this%KE_density_radial_center_at, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KE_density_radial_sigma', '1.0', this%KE_density_radial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - else - ! radial KE_density - !TODO why do these use 'this' for the default? - call param_register(params, 'KE_density_radial_bin_width', ''//this%KE_density_radial_bin_width, this%KE_density_radial_bin_width, help_string="") - call param_register(params, 'KE_density_radial_n_bins', ''//this%KE_density_radial_n_bins, this%KE_density_radial_n_bins, help_string="") - !TODO why is KE_density_radial_center missing? - call param_register(params, 'KE_density_radial_center_at', ''//prev%KE_density_radial_center_at, this%KE_density_radial_center_at, help_string="") - call param_register(params, 'KE_density_radial_sigma', ''//prev%KE_density_radial_gaussian_sigma, this%KE_density_radial_gaussian_sigma, help_string="") - endif - - if (.not. present(prev)) then - ! rdfd - call param_register(params, 'rdfd_zone_center', '0.0 0.0 0.0', this%rdfd_zone_center, help_string="Cartesian position to center zones for rdfd (ignored if rdfd_zone_atom_center is given)") - call param_register(params, 'rdfd_zone_atom_center', '0', this%rdfd_zone_atom_center, help_string="If > 0, index of atom to center zones for rdfd") - call param_register(params, 'rdfd_zone_width', '-1.0', this%rdfd_zone_width, help_string="Width of zones for rdfd") - call param_register(params, 'rdfd_n_zones', '1', this%rdfd_n_zones, help_string="Number of zones for rdfd") - call param_register(params, 'rdfd_bin_width', '-1', this%rdfd_bin_width, help_string="Width of bin (or distance between sample points) in each rdfd") - call param_register(params, 'rdfd_n_bins', '-1', this%rdfd_n_bins, help_string="Number of bins (or sample points) in each rdfd") - call param_register(params, 'rdfd_center_mask', '', this%rdfd_center_mask_str, help_string="Mask for atoms that are considered for rdfd centers") - call param_register(params, 'rdfd_neighbour_mask', '', this%rdfd_neighbour_mask_str, help_string="Mask for atoms that are considered for rdfd neighbours") - call param_register(params, 'rdfd_gaussian', 'F', this%rdfd_gaussian_smoothing, help_string="If true, use Gaussians to smear mass distributions being integrated for rdfd") - call param_register(params, 'rdfd_sigma', '0.1', this%rdfd_gaussian_sigma, help_string="Width of Gaussians used to smear mass distributions for rdfd") - else - ! rdfd - call param_register(params, 'rdfd_zone_center', ''//prev%rdfd_zone_center, this%rdfd_zone_center, help_string="") - call param_register(params, 'rdfd_zone_atom_center', ''//prev%rdfd_zone_atom_center, this%rdfd_zone_atom_center, help_string="") - call param_register(params, 'rdfd_zone_width', ''//prev%rdfd_zone_width, this%rdfd_zone_width, help_string="") - call param_register(params, 'rdfd_n_zones', ''//prev%rdfd_n_zones, this%rdfd_n_zones, help_string="") - call param_register(params, 'rdfd_bin_width', ''//prev%rdfd_bin_width, this%rdfd_bin_width, help_string="") - call param_register(params, 'rdfd_n_bins', ''//prev%rdfd_n_bins, this%rdfd_n_bins, help_string="") - call param_register(params, 'rdfd_center_mask', trim(prev%rdfd_center_mask_str), this%rdfd_center_mask_str, help_string="") - call param_register(params, 'rdfd_neighbour_mask', trim(prev%rdfd_neighbour_mask_str), this%rdfd_neighbour_mask_str, help_string="") - call param_register(params, 'rdfd_gaussian', ''//prev%rdfd_gaussian_smoothing, this%rdfd_gaussian_smoothing, help_string="") - call param_register(params, 'rdfd_sigma', ''//prev%rdfd_gaussian_sigma, this%rdfd_gaussian_sigma, help_string="") - endif - - if (.not. present(prev)) then - ! xrd - call param_register(params, 'xrd_lambda', '1.5418', this%xrd_lambda, help_string="Wavelength of radiation") - call param_register(params, 'xrd_2theta_range', '1.0 179.0', this%xrd_2theta_range, help_string="range of angles for scan") - call param_register(params, 'xrd_n_2theta', '179', this%xrd_n_2theta, help_string="number of angle values") - call param_register(params, 'xrd_k_spacing', '-1.0', this%xrd_k_spacing, help_string="approx. spacing for k mesh") - call param_register(params, 'xrd_Lorentz_polarization', 'F', this%xrd_Lorentz_polarization, help_string="apply Lorentz polarization factor") - else - ! xrd - call param_register(params, 'xrd_lambda', ''//prev%xrd_lambda, this%xrd_lambda, help_string="Wavelength of radiation") - call param_register(params, 'xrd_2theta_range', ''//prev%xrd_2theta_range, this%xrd_2theta_range, help_string="range of angles for scan") - call param_register(params, 'xrd_n_2theta', ''//prev%xrd_n_2theta, this%xrd_n_2theta, help_string="number of angle values") - call param_register(params, 'xrd_k_spacing', ''//prev%xrd_k_spacing, this%xrd_k_spacing, help_string="approx. spacing for k mesh") - call param_register(params, 'xrd_Lorentz_polarization', ''//prev%xrd_Lorentz_polarization, this%xrd_Lorentz_polarization, help_string="apply Lorentz polarization factor") - endif - - if (.not. present(prev)) then - ! adfd - call param_register(params, 'adfd_zone_center', '0.0 0.0 0.0', this%adfd_zone_center, help_string="Cartesian position to center zones for adfd (ignored if adfd_zone_atom_center is given)") - call param_register(params, 'adfd_zone_width', '-1.0', this%adfd_zone_width, help_string="Width of zones for adfd") - call param_register(params, 'adfd_n_zones', '1', this%adfd_n_zones, help_string="Number of zones for adfd") - call param_register(params, 'adfd_dist_bin_width', '-1', this%adfd_dist_bin_width, help_string="Width of distance bin in adfd") - call param_register(params, 'adfd_n_dist_bins', '-1', this%adfd_n_dist_bins, help_string="Number of distance bins in adfd") - call param_register(params, 'adfd_n_angle_bins', '-1', this%adfd_n_angle_bins, help_string="Number of angular bins in adfd") - call param_register(params, 'adfd_center_mask', '', this%adfd_center_mask_str, help_string="Mask for atoms that are considered for adfd centers") - call param_register(params, 'adfd_neighbour_1_mask', '', this%adfd_neighbour_1_mask_str, help_string="Mask for atoms that are considered for the first neighbour in adfd") - call param_register(params, 'adfd_neighbour_1_max_dist', '-1.0', this%adfd_neighbour_1_max_dist, help_string="Cutoff distance for atoms considered as the first neighbour") - call param_register(params, 'adfd_neighbour_2_mask', '', this%adfd_neighbour_2_mask_str, help_string="Mask for atoms that are considered for the second neighbour in adfd") - call param_register(params, 'adfd_dist_bin_rc2', '', this%adfd_dist_bin_rc2, help_string="If true, apply distance binning to r_center-neighbour2, otherwise to r_neighbour1-neighbour2") - else - ! adfd - call param_register(params, 'adfd_zone_center', ''//prev%adfd_zone_center, this%adfd_zone_center, help_string="") - call param_register(params, 'adfd_zone_width', ''//prev%adfd_zone_width, this%adfd_zone_width, help_string="") - call param_register(params, 'adfd_n_zones', ''//prev%adfd_n_zones, this%adfd_n_zones, help_string="") - call param_register(params, 'adfd_dist_bin_width', ''//prev%adfd_dist_bin_width, this%adfd_dist_bin_width, help_string="") - call param_register(params, 'adfd_n_dist_bins', ''//prev%adfd_n_dist_bins, this%adfd_n_dist_bins, help_string="") - call param_register(params, 'adfd_n_angle_bins', ''//prev%adfd_n_angle_bins, this%adfd_n_angle_bins, help_string="") - call param_register(params, 'adfd_center_mask', trim(prev%adfd_center_mask_str), this%adfd_center_mask_str, help_string="") - call param_register(params, 'adfd_neighbour_1_mask', trim(prev%adfd_neighbour_1_mask_str), this%adfd_neighbour_1_mask_str, help_string="") - call param_register(params, 'adfd_neighbour_1_max_dist', ''//prev%adfd_neighbour_1_max_dist, this%adfd_neighbour_1_max_dist, help_string="") - call param_register(params, 'adfd_neighbour_2_mask', trim(prev%adfd_neighbour_2_mask_str), this%adfd_neighbour_2_mask_str, help_string="") - call param_register(params, 'adfd_dist_bin_rc2', ''//prev%adfd_dist_bin_rc2, this%adfd_dist_bin_rc2, help_string="If true, apply distance binning to r_center-neighbor2, otherwise to r_neighbor1-neighbor2") - endif - - if (.not. present(prev)) then - ! r-dep KE distribution - call param_register(params, 'KEdf_radial_zone_center', '0.0 0.0 0.0', this%KEdf_radial_zone_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KEdf_radial_zone_center_at', '-1', this%KEdf_radial_zone_center_at, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KEdf_radial_zone_width', '-1.0', this%KEdf_radial_zone_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KEdf_radial_bin_width', '0.002', this%KEdf_radial_bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KEdf_radial_n_bins', '500', this%KEdf_radial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KEdf_radial_n_zones', '1', this%KEdf_radial_n_zones, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KEdf_radial_gaussian_sigma', '0.005', this%KEdf_radial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'KEdf_radial_mask', '', this%KEdf_radial_mask_str, help_string="No help yet. This source file was $LastChangedBy$") - else - ! r-dep KE distribution - call param_register(params, 'KEdf_radial_zone_center', ''//prev%KEdf_radial_zone_center, this%KEdf_radial_zone_center, help_string="") - call param_register(params, 'KEdf_radial_zone_center_at', ''//prev%KEdf_radial_zone_center_at, this%KEdf_radial_zone_center_at, help_string="") - call param_register(params, 'KEdf_radial_zone_width', ''//prev%KEdf_radial_zone_width, this%KEdf_radial_zone_width, help_string="") - call param_register(params, 'KEdf_radial_bin_width', ''//prev%KEdf_radial_bin_width, this%KEdf_radial_bin_width, help_string="") - call param_register(params, 'KEdf_radial_n_bins', ''//prev%KEdf_radial_n_bins, this%KEdf_radial_n_bins, help_string="") - call param_register(params, 'KEdf_radial_n_zones', ''//prev%KEdf_radial_n_zones, this%KEdf_radial_n_zones, help_string="") - call param_register(params, 'KEdf_radial_gaussian_sigma', ''//prev%KEdf_radial_gaussian_sigma, this%KEdf_radial_gaussian_sigma, help_string="") - call param_register(params, 'KEdf_radial_mask', ''//trim(prev%KEdf_radial_mask_str), this%KEdf_radial_mask_str, help_string="") - endif - - if (.not. present(prev)) then - ! r-dep |F| distribution - call param_register(params, 'propdf_radial_zone_center', '0.0 0.0 0.0', this%propdf_radial_zone_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'propdf_radial_zone_center_at', '-1', this%propdf_radial_zone_center_at, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'propdf_radial_zone_width', '-1.0', this%propdf_radial_zone_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'propdf_radial_n_zones', '1', this%propdf_radial_n_zones, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'propdf_radial_bin_width', '0.0', this%propdf_radial_bin_width, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'propdf_radial_n_bins', '0', this%propdf_radial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'propdf_radial_gaussian_sigma', '0.0', this%propdf_radial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'propdf_radial_mask', '', this%propdf_radial_mask_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'propdf_radial_property', '', this%propdf_radial_property, help_string="No help yet. This source file was $LastChangedBy$") - else - ! r-dep |F| distribution - call param_register(params, 'propdf_radial_zone_center', ''//prev%propdf_radial_zone_center, this%propdf_radial_zone_center, help_string="") - call param_register(params, 'propdf_radial_zone_center_at', ''//prev%propdf_radial_zone_center_at, this%propdf_radial_zone_center_at, help_string="") - call param_register(params, 'propdf_radial_zone_width', ''//prev%propdf_radial_zone_width, this%propdf_radial_zone_width, help_string="") - call param_register(params, 'propdf_radial_n_zones', ''//prev%propdf_radial_n_zones, this%propdf_radial_n_zones, help_string="") - call param_register(params, 'propdf_radial_bin_width', ''//prev%propdf_radial_bin_width, this%propdf_radial_bin_width, help_string="") - call param_register(params, 'propdf_radial_n_bins', ''//prev%propdf_radial_n_bins, this%propdf_radial_n_bins, help_string="") - call param_register(params, 'propdf_radial_gaussian_sigma', ''//prev%propdf_radial_gaussian_sigma, this%propdf_radial_gaussian_sigma, help_string="") - call param_register(params, 'propdf_radial_mask', ''//trim(prev%propdf_radial_mask_str), this%propdf_radial_mask_str, help_string="") - call param_register(params, 'propdf_radial_property', ''//trim(prev%propdf_radial_property), this%propdf_radial_property, help_string="") - endif - - if (.not. present(prev)) then - ! geometry - call param_register(params, 'geometry_filename', '', this%geometry_filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'geometry_central_atom', '-1', this%geometry_central_atom, help_string="No help yet. This source file was $LastChangedBy$") - else - ! geometry - call param_register(params, 'geometry_filename', ''//trim(prev%geometry_filename), this%geometry_filename, help_string="") - call param_register(params, 'geometry_central_atom', ''//prev%geometry_central_atom, this%geometry_central_atom, help_string="") - endif - - if (.not. present(prev)) then - ! uniaxial density silica - call param_register(params, 'density_axial_n_bins', '-1', this%density_axial_n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_axial_axis', '-1', this%density_axial_axis, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_axial_silica_atoms', '-1', this%density_axial_silica_atoms, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_axial_gaussian', 'F', this%density_axial_gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'density_axial_sigma', '1.0', this%density_axial_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - else - ! uniaxial density silica - call param_register(params, 'density_axial_n_bins', ''//prev%density_axial_n_bins, this%density_axial_n_bins, help_string="") - call param_register(params, 'density_axial_axis', ''//prev%density_axial_axis, this%density_axial_axis, help_string="") - call param_register(params, 'density_axial_silica_atoms', ''//prev%density_axial_silica_atoms, this%density_axial_silica_atoms, help_string="") - call param_register(params, 'density_axial_gaussian', ''//prev%density_axial_gaussian_smoothing, this%density_axial_gaussian_smoothing, help_string="") - call param_register(params, 'density_axial_sigma', ''//prev%density_axial_gaussian_sigma, this%density_axial_gaussian_sigma, help_string="") - endif - - if (.not. present(prev)) then - ! num_hbond_silica - call param_register(params, 'num_hbond_n_bins', '-1', this%num_hbond_n_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'num_hbond_axis', '0', this%num_hbond_axis, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'num_hbond_silica_atoms', '0', this%num_hbond_silica_atoms, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'num_hbond_gaussian', 'F', this%num_hbond_gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'num_hbond_sigma', '1.0', this%num_hbond_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - else - ! num_hbond_silica - call param_register(params, 'num_hbond_n_bins', ''//prev%num_hbond_n_bins, this%num_hbond_n_bins, help_string="") - call param_register(params, 'num_hbond_axis', ''//prev%num_hbond_axis, this%num_hbond_axis, help_string="") - call param_register(params, 'num_hbond_silica_atoms', ''//prev%num_hbond_silica_atoms, this%num_hbond_silica_atoms, help_string="") - call param_register(params, 'num_hbond_gaussian', ''//prev%num_hbond_gaussian_smoothing, this%num_hbond_gaussian_smoothing, help_string="") - call param_register(params, 'num_hbond_sigma', ''//prev%num_hbond_gaussian_sigma, this%num_hbond_gaussian_sigma, help_string="") - endif - - if (.not. present(prev)) then - ! water_orientation_silica - call param_register(params, 'water_orientation_n_pos_bins', '-1', this%water_orientation_n_pos_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'water_orientation_n_angle_bins', '-1', this%water_orientation_n_angle_bins, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'water_orientation_axis', '0', this%water_orientation_axis, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'water_orientation_silica_atoms', '0', this%water_orientation_silica_atoms, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'water_orientation_gaussian', 'F', this%water_orientation_gaussian_smoothing, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'water_orientation_pos_sigma', '1.0', this%water_orientation_pos_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - !call param_register(params, 'water_orientation_angle_sigma', '1.0', this%water_orientation_angle_gaussian_sigma, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'water_orientation_use_dipole', 'F', this%water_orientation_use_dipole, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'water_orientation_use_HOHangle_bisector', 'F', this%water_orientation_use_HOHangle_bisector, help_string="No help yet. This source file was $LastChangedBy$") - else - ! water_orientation_silica - call param_register(params, 'water_orientation_n_pos_bins', ''//prev%water_orientation_n_pos_bins, this%water_orientation_n_pos_bins, help_string="") - call param_register(params, 'water_orientation_n_angle_bins', ''//prev%water_orientation_n_angle_bins, this%water_orientation_n_angle_bins, help_string="") - call param_register(params, 'water_orientation_axis', ''//prev%water_orientation_axis, this%water_orientation_axis, help_string="") - call param_register(params, 'water_orientation_silica_atoms', ''//prev%water_orientation_silica_atoms, this%water_orientation_silica_atoms, help_string="") - call param_register(params, 'water_orientation_gaussian', ''//prev%water_orientation_gaussian_smoothing, this%water_orientation_gaussian_smoothing, help_string="") - call param_register(params, 'water_orientation_pos_sigma', ''//prev%water_orientation_pos_gaussian_sigma, this%water_orientation_pos_gaussian_sigma, help_string="") - !call param_register(params, 'water_orientation_angle_sigma', ''//prev%water_orientation_angle_gaussian_sigma, this%water_orientation_angle_gaussian_sigma, help_string="") - call param_register(params, 'water_orientation_use_dipole', ''//prev%water_orientation_use_dipole, this%water_orientation_use_dipole, help_string="") - call param_register(params, 'water_orientation_use_HOHangle_bisector', ''//prev%water_orientation_use_HOHangle_bisector, this%water_orientation_use_HOHangle_bisector, help_string="") - endif - - if (present(args_str)) then - if (.not. param_read_line(params, trim(args_str), ignore_unknown=.false.)) & - call system_abort("analysis_read failed to parse string '"//trim(args_str)//"'") - else - if (.not. param_read_args(params)) & - call system_abort("analysis_read failed to parse command line arguments") - endif - - this%density_radial = .false. - this%density_grid = .false. - this%KE_density_radial = .false. - this%rdfd = .false. - this%xrd = .false. - this%adfd = .false. - this%KEdf_radial = .false. - this%propdf_radial = .false. - this%geometry = .false. - this%density_axial_silica = .false. - this%num_hbond_silica = .false. - this%water_orientation_silica = .false. - select case(trim(this%type)) - case("density_radial") - this%density_radial = .true. - case("density_grid") - this%density_grid = .true. - case("KE_density_radial") - this%KE_density_radial = .true. - case("rdfd") - this%rdfd = .true. - case("xrd") - this%xrd = .true. - case("adfd") - this%adfd = .true. - case("KEdf_radial") - this%KEdf_radial = .true. - case("propdf_radial") - this%propdf_radial = .true. - case("geometry") - this%geometry = .true. - case("density_axial_silica") - this%density_axial_silica = .true. - case("num_hbond_silica") - this%num_hbond_silica = .true. - case("water_orientation_silica") - this%water_orientation_silica = .true. - case default - call system_abort("Unknown analysis type '"//trim(this%type)//"'") - end select - - if (count ( (/ this%density_radial, this%density_grid, this%KE_density_radial, this%rdfd, this%xrd, this%adfd, & - this%KEdf_radial, this%propdf_radial, this%geometry, this%density_axial_silica, this%num_hbond_silica, & - this%water_orientation_silica /) ) /= 1) & - call system_abort("Specified "//(/ this%density_radial, this%density_grid, this%KE_density_radial, & - this%rdfd, this%xrd, this%adfd, this%KEdf_radial, this%propdf_radial, this%geometry, this%density_axial_silica, this%num_hbond_silica, & - this%water_orientation_silica /)// & - " types of analysis. Possibilities: density_radial, density_grid, KE_density_radial, rdfd, xrd, adfd, KEdf_radial, propdf_radial, geometry, " // & - " density_axial_silica, num_hbond_silica, water_orientation_silica.") - -end subroutine analysis_read - -subroutine check_analyses(a) - type(analysis), intent(inout) :: a(:) - - integer :: i_a - - do i_a=1, size(a) - if (a(i_a)%density_radial) then !density_radial - if (a(i_a)%density_radial_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has radial_bin_width="//a(i_a)%density_radial_bin_width//" <= 0.0") - if (a(i_a)%density_radial_n_bins <= 0) call system_abort("analysis " // i_a // " has radial_n_bins="//a(i_a)%density_radial_n_bins//" <= 0") - else if (a(i_a)%density_grid) then !density_grid - if (any(a(i_a)%density_grid_bin_width <= 0.0_dp)) call system_abort("analysis " // i_a // " has grid_bin_width="//a(i_a)%density_grid_bin_width//" <= 0.0") - if (any(a(i_a)%density_grid_n_bins <= 0)) call system_abort("analysis " // i_a // " has grid_n_bins="//a(i_a)%density_grid_n_bins//" <= 0") - else if (a(i_a)%KE_density_radial) then !KE_density_radial - if (a(i_a)%KE_density_radial_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has radial_bin_width="//a(i_a)%KE_density_radial_bin_width//" <= 0.0") - if (a(i_a)%KE_density_radial_n_bins <= 0) call system_abort("analysis " // i_a // " has radial_n_bins="//a(i_a)%KE_density_radial_n_bins//" <= 0") - else if (a(i_a)%rdfd) then !rdfd - if (a(i_a)%rdfd_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has rdfd_bin_width="//a(i_a)%rdfd_bin_width//" <= 0.0") - if (a(i_a)%rdfd_n_bins <= 0) call system_abort("analysis " // i_a // " has rdfd_n_bins="//a(i_a)%rdfd_n_bins//" <= 0") - if (a(i_a)%rdfd_n_zones <= 0) call system_abort("analysis " // i_a // " has rdfd_n_zones="//a(i_a)%rdfd_n_zones//" <= 0") - else if (a(i_a)%xrd) then !xrd - if (a(i_a)%xrd_2theta_range(2) < a(i_a)%xrd_2theta_range(1)) call system_abort("analysis " // i_a // " has xrd_2theta_range="//a(i_a)%xrd_2theta_range//" end >= beginning") - if (a(i_a)%xrd_lambda <= 0.0) call system_abort("analysis " // i_a // " has xrd_lambda="//a(i_a)%xrd_lambda//" <= 0") - if (a(i_a)%xrd_n_2theta <= 0) call system_abort("analysis " // i_a // " has xrd_n_2theta="//a(i_a)%xrd_n_2theta//" <= 0") - else if (a(i_a)%adfd) then !adfd - if (a(i_a)%adfd_dist_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has adfd_dist_bin_width="//a(i_a)%adfd_dist_bin_width//" <= 0.0") - if (a(i_a)%adfd_n_dist_bins <= 0) call system_abort("analysis " // i_a // " has adfd_n_dist_bins="//a(i_a)%adfd_n_dist_bins//" <= 0") - if (a(i_a)%adfd_n_angle_bins <= 0) call system_abort("analysis " // i_a // " has adfd_n_angle_bins="//a(i_a)%adfd_n_angle_bins//" <= 0") - if (a(i_a)%adfd_n_zones <= 0) call system_abort("analysis " // i_a // " has adfd_n_zones="//a(i_a)%adfd_n_zones//" <= 0") - else if (a(i_a)%KEdf_radial) then !KEdf_radial - if (a(i_a)%KEdf_radial_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has KEdf_radial_bin_width="//a(i_a)%KEdf_radial_bin_width//" <= 0.0") - if (a(i_a)%KEdf_radial_n_bins <= 0) call system_abort("analysis " // i_a // " has KEdf_radial_n_bins="//a(i_a)%KEdf_radial_n_bins//" <= 0") - if (a(i_a)%KEdf_radial_n_zones <= 0) call system_abort("analysis " // i_a // " has KEdf_radial_n_zones="//a(i_a)%KEdf_radial_n_zones//" <= 0") - else if (a(i_a)%propdf_radial) then !propdf_radial - if (a(i_a)%propdf_radial_bin_width <= 0.0_dp) call system_abort("analysis " // i_a // " has propdf_radial_bin_width="//a(i_a)%propdf_radial_bin_width//" <= 0.0") - if (a(i_a)%propdf_radial_n_bins <= 0) call system_abort("analysis " // i_a // " has propdf_radial_n_bins="//a(i_a)%propdf_radial_n_bins//" <= 0") - if (a(i_a)%propdf_radial_gaussian_sigma <= 0) call system_abort("analysis " // i_a // " has propdf_radial_gaussian_sigma="//a(i_a)%propdf_radial_gaussian_sigma//" <= 0") - if (a(i_a)%propdf_radial_n_zones <= 0) call system_abort("analysis " // i_a // " has propdf_radial_n_zones="//a(i_a)%propdf_radial_n_zones//" <= 0") - else if (a(i_a)%geometry) then !geometry - if (trim(a(i_a)%geometry_filename)=="") call system_abort("analysis "//i_a//" has empty geometry_filename") - !read geometry parameters to calculate from the file into a table - call read_geometry_params(a(i_a),trim(a(i_a)%geometry_filename)) - if (a(i_a)%geometry_params%N==0) call system_abort("analysis "//i_a//" has no geometry parameters to calculate") - else if (a(i_a)%density_axial_silica) then !density_axial_silica - if (a(i_a)%density_axial_n_bins <= 0) call system_abort("analysis " // i_a // " has density_axial_n_bins="//a(i_a)%density_axial_n_bins//" <= 0") - if (.not. any(a(i_a)%density_axial_axis == (/1,2,3/))) call system_abort("analysis " // i_a // " has density_axial_axis="//a(i_a)%density_axial_axis//" /= 1, 2 or 3") - else if (a(i_a)%num_hbond_silica) then !num_hbond_silica - if (a(i_a)%num_hbond_n_bins <= 0) call system_abort("analysis " // i_a // " has num_hbond_n_bins="//a(i_a)%num_hbond_n_bins//" <= 0") - if (.not. any(a(i_a)%num_hbond_axis == (/1,2,3/))) call system_abort("analysis " // i_a // " has num_hbond_axis="//a(i_a)%num_hbond_axis//" /= 1, 2 or 3") - else if (a(i_a)%water_orientation_silica) then !water_orientation_silica - if (a(i_a)%water_orientation_n_pos_bins <= 0) call system_abort("analysis " // i_a // " has water_orientation_n_pos_bins="//a(i_a)%water_orientation_n_pos_bins//" <= 0") - if (a(i_a)%water_orientation_n_angle_bins <= 0) call system_abort("analysis " // i_a // " has water_orientation_n_angle_bins="//a(i_a)%water_orientation_n_angle_bins//" <= 0") - if (.not. any(a(i_a)%water_orientation_axis == (/1,2,3/))) call system_abort("analysis " // i_a // " has water_orientation_axis="//a(i_a)%water_orientation_axis//" /= 1, 2 or 3") - if (.not. count((/a(i_a)%water_orientation_use_HOHangle_bisector,a(i_a)%water_orientation_use_dipole/)) == 1) call system_abort("Exactly one of water_orientation_use_HOHangle_bisector and water_orientation_use_dipole must be one.") - else - call system_abort("check_analyses: no type of analysis set for " // i_a) - endif - end do -end subroutine check_analyses - -subroutine do_analyses(a, time, frame, at) - type(analysis), intent(inout) :: a(:) - real(dp), intent(in) :: time - integer, intent(in) :: frame - type(Atoms), intent(inout) :: at - real(dp) :: use_radial_center(3) - - integer :: i_a - - call map_into_cell(at) -! at%t ravel = 0 - - do i_a=1, size(a) - if (do_this_analysis(a(i_a), time, frame)) then - - a(i_a)%n_configs = a(i_a)%n_configs + 1 - - if (a(i_a)%density_radial) then !density_radial - call reallocate_data(a(i_a)%density_radial_histograms, a(i_a)%n_configs, a(i_a)%density_radial_n_bins) - if (a(i_a)%density_radial_center_at > 0) then - use_radial_center = at%pos(:,a(i_a)%density_radial_center_at) - else - use_radial_center = a(i_a)%density_radial_center - endif - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%density_radial_pos(a(i_a)%density_radial_n_bins)) - call density_sample_radial_mesh_Gaussians(a(i_a)%density_radial_histograms(:,a(i_a)%n_configs), at, center_pos=use_radial_center, & - rad_bin_width=a(i_a)%density_radial_bin_width, n_rad_bins=a(i_a)%density_radial_n_bins, gaussian_sigma=a(i_a)%density_radial_gaussian_sigma, & - mask_str=a(i_a)%mask_str, radial_pos=a(i_a)%density_radial_pos) - else - call density_sample_radial_mesh_Gaussians(a(i_a)%density_radial_histograms(:,a(i_a)%n_configs), at, center_pos=use_radial_center, & - rad_bin_width=a(i_a)%density_radial_bin_width, n_rad_bins=a(i_a)%density_radial_n_bins, gaussian_sigma= a(i_a)%density_radial_gaussian_sigma, & - mask_str=a(i_a)%mask_str) - endif - else if (a(i_a)%density_grid) then !density_grid - call reallocate_data(a(i_a)%density_grid_histograms, a(i_a)%n_configs, a(i_a)%density_grid_n_bins) - if (a(i_a)%density_grid_gaussian_smoothing) then - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%density_grid_pos(3,a(i_a)%density_grid_n_bins(1),a(i_a)%density_grid_n_bins(2),a(i_a)%density_grid_n_bins(3))) - call density_sample_rectilinear_mesh_Gaussians(a(i_a)%density_grid_histograms(:,:,:,a(i_a)%n_configs), at, a(i_a)%density_grid_min_p, & - a(i_a)%density_grid_bin_width, a(i_a)%density_grid_n_bins, a(i_a)%density_grid_gaussian_sigma, a(i_a)%mask_str, a(i_a)%density_grid_pos) - else - call density_sample_rectilinear_mesh_Gaussians(a(i_a)%density_grid_histograms(:,:,:,a(i_a)%n_configs), at, a(i_a)%density_grid_min_p, & - a(i_a)%density_grid_bin_width, a(i_a)%density_grid_n_bins, a(i_a)%density_grid_gaussian_sigma, a(i_a)%mask_str) - endif - else - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%density_grid_pos(3,a(i_a)%density_grid_n_bins(1),a(i_a)%density_grid_n_bins(2),a(i_a)%density_grid_n_bins(3))) - call density_bin_rectilinear_mesh(a(i_a)%density_grid_histograms(:,:,:,a(i_a)%n_configs), at, a(i_a)%density_grid_min_p, a(i_a)%density_grid_bin_width, & - a(i_a)%density_grid_n_bins, a(i_a)%mask_str, a(i_a)%density_grid_pos) - else - call density_bin_rectilinear_mesh(a(i_a)%density_grid_histograms(:,:,:,a(i_a)%n_configs), at, a(i_a)%density_grid_min_p, a(i_a)%density_grid_bin_width, & - a(i_a)%density_grid_n_bins, a(i_a)%mask_str) - endif - endif - else if (a(i_a)%KE_density_radial) then ! KE_density_radial - call reallocate_data(a(i_a)%KE_density_radial_histograms, a(i_a)%n_configs, a(i_a)%KE_density_radial_n_bins) - if (a(i_a)%KE_density_radial_center_at > 0) then - use_radial_center = at%pos(:,a(i_a)%KE_density_radial_center_at) - else - use_radial_center = a(i_a)%KE_density_radial_center - endif - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%KE_density_radial_pos(a(i_a)%KE_density_radial_n_bins)) - call density_sample_radial_mesh_Gaussians(a(i_a)%KE_density_radial_histograms(:,a(i_a)%n_configs), at, center_pos=use_radial_center, & - rad_bin_width=a(i_a)%KE_density_radial_bin_width, n_rad_bins=a(i_a)%KE_density_radial_n_bins, gaussian_sigma=a(i_a)%KE_density_radial_gaussian_sigma, & - mask_str=a(i_a)%mask_str, radial_pos=a(i_a)%KE_density_radial_pos, quantity="KE") - else - call density_sample_radial_mesh_Gaussians(a(i_a)%KE_density_radial_histograms(:,a(i_a)%n_configs), at, center_pos=use_radial_center, & - rad_bin_width=a(i_a)%KE_density_radial_bin_width, n_rad_bins=a(i_a)%KE_density_radial_n_bins, gaussian_sigma= a(i_a)%density_radial_gaussian_sigma, & - mask_str=a(i_a)%mask_str, quantity="KE") - endif - else if (a(i_a)%rdfd) then !rdfd - call reallocate_data(a(i_a)%rdfds, a(i_a)%n_configs, (/ a(i_a)%rdfd_n_bins, a(i_a)%rdfd_n_zones /) ) - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%rdfd_bin_pos(a(i_a)%rdfd_n_bins)) - allocate(a(i_a)%rdfd_zone_pos(a(i_a)%rdfd_n_zones)) - call rdfd_calc(a(i_a)%rdfds(:,:,a(i_a)%n_configs), at, a(i_a)%rdfd_zone_center, a(i_a)%rdfd_zone_atom_center, a(i_a)%rdfd_bin_width, a(i_a)%rdfd_n_bins, & - a(i_a)%rdfd_zone_width, a(i_a)%rdfd_n_zones, a(i_a)%rdfd_gaussian_smoothing, a(i_a)%rdfd_gaussian_sigma, & - a(i_a)%rdfd_center_mask_str, a(i_a)%rdfd_neighbour_mask_str, & - a(i_a)%rdfd_bin_pos, a(i_a)%rdfd_zone_pos) - else - call rdfd_calc(a(i_a)%rdfds(:,:,a(i_a)%n_configs), at, a(i_a)%rdfd_zone_center, a(i_a)%rdfd_zone_atom_center, a(i_a)%rdfd_bin_width, a(i_a)%rdfd_n_bins, & - a(i_a)%rdfd_zone_width, a(i_a)%rdfd_n_zones, a(i_a)%rdfd_gaussian_smoothing, a(i_a)%rdfd_gaussian_sigma, & - a(i_a)%rdfd_center_mask_str, a(i_a)%rdfd_neighbour_mask_str) - endif - else if (a(i_a)%xrd) then !xrd - call reallocate_data(a(i_a)%xrds, a(i_a)%n_configs, a(i_a)%xrd_n_2theta ) - a(i_a)%xrd_2theta_range = a(i_a)%xrd_2theta_range * PI/180.0 - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%xrd_2theta_pos(a(i_a)%xrd_n_2theta)) - call xrd_calc(a(i_a)%xrds(:,a(i_a)%n_configs), at, a(i_a)%xrd_lambda, a(i_a)%xrd_2theta_range, a(i_a)%xrd_n_2theta, & - a(i_a)%xrd_k_spacing, a(i_a)%xrd_Lorentz_polarization, a(i_a)%xrd_2theta_pos) - a(i_a)%xrd_2theta_pos = a(i_a)%xrd_2theta_pos * 180.0/PI - else - call xrd_calc(a(i_a)%xrds(:,a(i_a)%n_configs), at, a(i_a)%xrd_lambda, a(i_a)%xrd_2theta_range, a(i_a)%xrd_n_2theta, & - a(i_a)%xrd_k_spacing, a(i_a)%xrd_Lorentz_polarization) - endif - a(i_a)%xrd_2theta_range = a(i_a)%xrd_2theta_range * 180.0/PI - else if (a(i_a)%adfd) then !adfd - call reallocate_data(a(i_a)%adfds, a(i_a)%n_configs, (/ a(i_a)%adfd_n_angle_bins, a(i_a)%adfd_n_dist_bins, a(i_a)%adfd_n_zones /) ) - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%adfd_dist_bin_pos(a(i_a)%adfd_n_dist_bins)) - allocate(a(i_a)%adfd_angle_bin_pos(a(i_a)%adfd_n_angle_bins)) - allocate(a(i_a)%adfd_zone_pos(a(i_a)%adfd_n_zones)) - call adfd_calc(a(i_a)%adfds(:,:,:,a(i_a)%n_configs), at, a(i_a)%adfd_zone_center, & - a(i_a)%adfd_n_angle_bins, a(i_a)%adfd_dist_bin_width, a(i_a)%adfd_n_dist_bins, & - a(i_a)%adfd_zone_width, a(i_a)%adfd_n_zones, & - a(i_a)%adfd_center_mask_str, a(i_a)%adfd_neighbour_1_mask_str, a(i_a)%adfd_neighbour_1_max_dist, a(i_a)%adfd_neighbour_2_mask_str, a(i_a)%adfd_dist_bin_rc2, & - a(i_a)%adfd_angle_bin_pos, a(i_a)%adfd_dist_bin_pos, a(i_a)%adfd_zone_pos) - else - call adfd_calc(a(i_a)%adfds(:,:,:,a(i_a)%n_configs), at, a(i_a)%adfd_zone_center, & - a(i_a)%adfd_n_angle_bins, a(i_a)%adfd_dist_bin_width, a(i_a)%adfd_n_dist_bins, & - a(i_a)%adfd_zone_width, a(i_a)%adfd_n_zones, & - a(i_a)%adfd_center_mask_str, a(i_a)%adfd_neighbour_1_mask_str, a(i_a)%adfd_neighbour_1_max_dist, a(i_a)%adfd_neighbour_2_mask_str, a(i_a)%adfd_dist_bin_rc2) - endif - else if (a(i_a)%KEdf_radial) then - call reallocate_data(a(i_a)%KEdf_radial_histograms, a(i_a)%n_configs, (/ a(i_a)%KEdf_radial_n_bins, a(i_a)%KEdf_radial_n_zones /) ) - if (a(i_a)%KEdf_radial_zone_center_at > 0) then - use_radial_center = at%pos(:,a(i_a)%KEdf_radial_zone_center_at) - else - use_radial_center = a(i_a)%KEdf_radial_zone_center - endif - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%KEdf_radial_bin_pos(a(i_a)%KEdf_radial_n_bins)) - allocate(a(i_a)%KEdf_radial_zone_pos(a(i_a)%KEdf_radial_n_zones)) - call propdf_radial_calc(a(i_a)%KEdf_radial_histograms(:,:,a(i_a)%n_configs), at, a(i_a)%KEdf_radial_bin_width, a(i_a)%KEdf_radial_n_bins, & - use_radial_center, a(i_a)%KEdf_radial_zone_width, A(i_a)%KEdf_radial_n_zones, & - a(i_a)%KEdf_radial_gaussian_sigma, a(i_a)%KEdf_radial_mask_str, 'KE', a(i_a)%KEdf_radial_bin_pos, a(i_a)%KEdf_radial_zone_pos) - else - call propdf_radial_calc(a(i_a)%KEdf_radial_histograms(:,:,a(i_a)%n_configs), at, a(i_a)%KEdf_radial_bin_width, a(i_a)%KEdf_radial_n_bins, & - use_radial_center, a(i_a)%KEdf_radial_zone_width, A(i_a)%KEdf_radial_n_zones, & - a(i_a)%KEdf_radial_gaussian_sigma, a(i_a)%KEdf_radial_mask_str, 'KE') - endif - else if (a(i_a)%propdf_radial) then - call reallocate_data(a(i_a)%propdf_radial_histograms, a(i_a)%n_configs, (/ a(i_a)%propdf_radial_n_bins, a(i_a)%propdf_radial_n_zones /) ) - if (a(i_a)%propdf_radial_zone_center_at > 0) then - use_radial_center = at%pos(:,a(i_a)%propdf_radial_zone_center_at) - else - use_radial_center = a(i_a)%propdf_radial_zone_center - endif - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%propdf_radial_bin_pos(a(i_a)%propdf_radial_n_bins)) - allocate(a(i_a)%propdf_radial_zone_pos(a(i_a)%propdf_radial_n_zones)) - call propdf_radial_calc(a(i_a)%propdf_radial_histograms(:,:,a(i_a)%n_configs), at, a(i_a)%propdf_radial_bin_width, a(i_a)%propdf_radial_n_bins, & - use_radial_center, a(i_a)%propdf_radial_zone_width, A(i_a)%propdf_radial_n_zones, & - a(i_a)%propdf_radial_gaussian_sigma, a(i_a)%propdf_radial_mask_str, A(i_a)%propdf_radial_property, & - a(i_a)%propdf_radial_bin_pos, a(i_a)%propdf_radial_zone_pos) - else - call propdf_radial_calc(a(i_a)%propdf_radial_histograms(:,:,a(i_a)%n_configs), at, a(i_a)%propdf_radial_bin_width, a(i_a)%propdf_radial_n_bins, & - use_radial_center, a(i_a)%propdf_radial_zone_width, A(i_a)%propdf_radial_n_zones, & - a(i_a)%propdf_radial_gaussian_sigma, a(i_a)%propdf_radial_mask_str, a(i_a)%propdf_radial_property) - endif - else if (a(i_a)%geometry) then !geometry - call reallocate_data(a(i_a)%geometry_histograms, a(i_a)%n_configs, a(i_a)%geometry_params%N) - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%geometry_pos(a(i_a)%geometry_params%N)) - allocate(a(i_a)%geometry_label(a(i_a)%geometry_params%N)) - call geometry_calc(a(i_a)%geometry_histograms(:,a(i_a)%n_configs), at, a(i_a)%geometry_params, a(i_a)%geometry_central_atom, & - a(i_a)%geometry_pos(1:a(i_a)%geometry_params%N), a(i_a)%geometry_label(1:a(i_a)%geometry_params%N)) - else - call geometry_calc(a(i_a)%geometry_histograms(:,a(i_a)%n_configs), at, a(i_a)%geometry_params, a(i_a)%geometry_central_atom) - endif - else if (a(i_a)%density_axial_silica) then !density_axial_silica - call reallocate_data(a(i_a)%density_axial_histograms, a(i_a)%n_configs, a(i_a)%density_axial_n_bins) - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%density_axial_pos(a(i_a)%density_axial_n_bins)) - call density_axial_calc(a(i_a)%density_axial_histograms(:,a(i_a)%n_configs), at, & - axis=a(i_a)%density_axial_axis, silica_center_i=a(i_a)%density_axial_silica_atoms, & - n_bins=a(i_a)%density_axial_n_bins, & - gaussian_smoothing=a(i_a)%density_axial_gaussian_smoothing, & - gaussian_sigma=a(i_a)%density_axial_gaussian_sigma, & - mask_str=a(i_a)%mask_str, axial_pos=a(i_a)%density_axial_pos) - else - call density_axial_calc(a(i_a)%density_axial_histograms(:,a(i_a)%n_configs), at, & - axis=a(i_a)%density_axial_axis, silica_center_i=a(i_a)%density_axial_silica_atoms, & - n_bins=a(i_a)%density_axial_n_bins, & - gaussian_smoothing=a(i_a)%density_axial_gaussian_smoothing, & - gaussian_sigma=a(i_a)%density_axial_gaussian_sigma, & - mask_str=a(i_a)%mask_str) - endif - else if (a(i_a)%num_hbond_silica) then !num_hbond_silica - a(i_a)%num_hbond_n_type = 4 - call reallocate_data(a(i_a)%num_hbond_histograms, a(i_a)%n_configs, (/a(i_a)%num_hbond_n_bins,a(i_a)%num_hbond_n_type/)) !4: ss, sw, ws, ww - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%num_hbond_bin_pos(a(i_a)%num_hbond_n_bins)) - allocate(a(i_a)%num_hbond_type_code(4)) - allocate(a(i_a)%num_hbond_type_label(4)) - call num_hbond_calc(a(i_a)%num_hbond_histograms(:,:,a(i_a)%n_configs), at, & - axis=a(i_a)%num_hbond_axis, silica_center_i=a(i_a)%num_hbond_silica_atoms, & - n_bins=a(i_a)%num_hbond_n_bins, & - gaussian_smoothing=a(i_a)%num_hbond_gaussian_smoothing, & - gaussian_sigma=a(i_a)%num_hbond_gaussian_sigma, & - mask_str=a(i_a)%mask_str, num_hbond_pos=a(i_a)%num_hbond_bin_pos, & - num_hbond_type_code=a(i_a)%num_hbond_type_code, & - num_hbond_type_label=a(i_a)%num_hbond_type_label) - else - call num_hbond_calc(a(i_a)%num_hbond_histograms(:,:,a(i_a)%n_configs), at, & - axis=a(i_a)%num_hbond_axis, silica_center_i=a(i_a)%num_hbond_silica_atoms, & - n_bins=a(i_a)%num_hbond_n_bins, & - gaussian_smoothing=a(i_a)%num_hbond_gaussian_smoothing, & - gaussian_sigma=a(i_a)%num_hbond_gaussian_sigma, & - mask_str=a(i_a)%mask_str) - endif - else if (a(i_a)%water_orientation_silica) then !water_orientation_silica - call reallocate_data(a(i_a)%water_orientation_histograms, a(i_a)%n_configs, (/ a(i_a)%water_orientation_n_angle_bins, a(i_a)%water_orientation_n_pos_bins /) ) - if (a(i_a)%n_configs == 1) then - allocate(a(i_a)%water_orientation_angle_bin(a(i_a)%water_orientation_n_angle_bins)) - allocate(a(i_a)%water_orientation_angle_bin_w(a(i_a)%water_orientation_n_angle_bins)) - allocate(a(i_a)%water_orientation_pos_bin(a(i_a)%water_orientation_n_pos_bins)) - call water_orientation_calc(a(i_a)%water_orientation_histograms(:,:,a(i_a)%n_configs), at, & - axis=a(i_a)%water_orientation_axis, silica_center_i=a(i_a)%water_orientation_silica_atoms, & - n_pos_bins=a(i_a)%water_orientation_n_pos_bins, n_angle_bins=a(i_a)%water_orientation_n_angle_bins, & - gaussian_smoothing=a(i_a)%water_orientation_gaussian_smoothing, & - pos_gaussian_sigma=a(i_a)%water_orientation_pos_gaussian_sigma, & - !angle_gaussian_sigma=a(i_a)%water_orientation_angle_gaussian_sigma, & - pos_bin=a(i_a)%water_orientation_pos_bin, angle_bin=a(i_a)%water_orientation_angle_bin, & - angle_bin_w=a(i_a)%water_orientation_angle_bin_w, & - use_dipole_rather_than_angle_bisector=a(i_a)%water_orientation_use_dipole) - else - call water_orientation_calc(a(i_a)%water_orientation_histograms(:,:,a(i_a)%n_configs), at, & - axis=a(i_a)%water_orientation_axis, silica_center_i=a(i_a)%water_orientation_silica_atoms, & - n_pos_bins=a(i_a)%water_orientation_n_pos_bins, n_angle_bins=a(i_a)%water_orientation_n_angle_bins, & - gaussian_smoothing=a(i_a)%water_orientation_gaussian_smoothing, & - pos_gaussian_sigma=a(i_a)%water_orientation_pos_gaussian_sigma, & - !angle_gaussian_sigma=a(i_a)%water_orientation_angle_gaussian_sigma, & - angle_bin_w=a(i_a)%water_orientation_angle_bin_w, & - use_dipole_rather_than_angle_bisector=a(i_a)%water_orientation_use_dipole) - endif - else - call system_abort("do_analyses: no type of analysis set for " // i_a) - endif - end if ! do this analysis - end do -end subroutine do_analyses - -function do_this_analysis(this, time, frame) - type(analysis), intent(in) :: this - real(dp), intent(in), optional :: time - integer, intent(in), optional :: frame - logical :: do_this_analysis - - do_this_analysis = .true. - - if (this%min_time > 0.0_dp) then - if (.not. present(time)) call system_abort("analysis has non-zero min_time, but no time specified") - if (time < 0.0_dp) call system_abort("analysis has non-zero min_time, but invalid time < 0") - if (time < this%min_time) then - do_this_analysis = .false. - endif - endif - if (this%max_time > 0.0_dp) then - if (.not. present(time)) call system_abort("analysis has non-zero max_time, but no time specified") - if (time < 0.0_dp) call system_abort("analysis has non-zero max_time, but invalid time < 0") - if (time > this%max_time) then - do_this_analysis = .false. - endif - endif - - if (this%min_frame > 0) then - if (.not. present(frame)) call system_abort("analysis has non-zero min_frame, but no frame specified") - if (frame < 0) call system_abort("analysis has non-zero min_frame, but invalid frame < 0") - if (frame < this%min_frame) then - do_this_analysis = .false. - endif - endif - if (this%max_frame > 0) then - if (.not. present(frame)) call system_abort("analysis has non-zero max_frame, but no frame specified") - if (frame < 0) call system_abort("analysis has non-zero max_frame, but invalid frame < 0") - if (frame > this%max_frame) then - do_this_analysis = .false. - endif - endif - -end function do_this_analysis - -subroutine print_analyses(a) - type(analysis), intent(inout) :: a(:) - - type(inoutput) :: outfile - integer :: i, i1, i2, i3, i_a - real(dp), allocatable :: integrated_rdfds(:,:) - - do i_a=1, size(a) - call initialise(outfile, a(i_a)%outfilename, OUTPUT) - if (a(i_a)%outfilename == "stdout") then - outfile%prefix="ANALYSIS_"//i_a - endif - - if (a(i_a)%n_configs <= 0) then - call print("# NO DATA", file=outfile) - else - if (a(i_a)%density_radial) then !density_radial - call print("# radial density histogram", file=outfile) - call print("n_bins="//a(i_a)%density_radial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i=1, a(i_a)%density_radial_n_bins - call print(a(i_a)%density_radial_pos(i), file=outfile) - end do - do i=1, a(i_a)%n_configs - call print(a(i_a)%density_radial_histograms(:,i), file=outfile) - end do - else if (a(i_a)%density_grid) then !density_grid - call print("# grid density histogram", file=outfile) - call print("n_bins="//a(i_a)%density_grid_n_bins(1)*a(i_a)%density_grid_n_bins(2)*a(i_a)%density_grid_n_bins(3)//" n_data="//a(i_a)%n_configs, file=outfile) - do i1=1, a(i_a)%density_grid_n_bins(1) - do i2=1, a(i_a)%density_grid_n_bins(2) - do i3=1, a(i_a)%density_grid_n_bins(3) - call print(""//a(i_a)%density_grid_pos(:,i1,i2,i3), file=outfile) - end do - end do - end do - do i=1, a(i_a)%n_configs - call print(""//reshape(a(i_a)%density_grid_histograms(:,:,:,i), (/ a(i_a)%density_grid_n_bins(1)*a(i_a)%density_grid_n_bins(2)*a(i_a)%density_grid_n_bins(3) /) ), file=outfile) - end do - else if (a(i_a)%KE_density_radial) then !density_radial - call print("# radial density histogram", file=outfile) - call print("n_bins="//a(i_a)%KE_density_radial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i=1, a(i_a)%KE_density_radial_n_bins - call print(a(i_a)%KE_density_radial_pos(i), file=outfile) - end do - do i=1, a(i_a)%n_configs - call print(a(i_a)%KE_density_radial_histograms(:,i), file=outfile) - end do - else if (a(i_a)%rdfd) then !rdfd - call print("# rdfd", file=outfile) - call print("n_bins="//a(i_a)%rdfd_n_zones*a(i_a)%rdfd_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i1=1, a(i_a)%rdfd_n_zones - do i2=1, a(i_a)%rdfd_n_bins - if (a(i_a)%rdfd_zone_width > 0.0_dp) then - call print(""//a(i_a)%rdfd_zone_pos(i1)//" "//a(i_a)%rdfd_bin_pos(i2), file=outfile) - else - call print(""//a(i_a)%rdfd_bin_pos(i2), file=outfile) - endif - end do - end do - do i=1, a(i_a)%n_configs - call print(""//reshape(a(i_a)%rdfds(:,:,i), (/ a(i_a)%rdfd_n_zones*a(i_a)%rdfd_n_bins /) ), file=outfile) - end do - - call print("", file=outfile) - call print("", file=outfile) - call print("# integrated_rdfd", file=outfile) - call print("n_bins="//a(i_a)%rdfd_n_zones*a(i_a)%rdfd_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i1=1, a(i_a)%rdfd_n_zones - do i2=1, a(i_a)%rdfd_n_bins - if (a(i_a)%rdfd_zone_width > 0.0_dp) then - call print(""//a(i_a)%rdfd_zone_pos(i1)//" "//a(i_a)%rdfd_bin_pos(i2), file=outfile) - else - call print(""//a(i_a)%rdfd_bin_pos(i2), file=outfile) - endif - end do - end do - allocate(integrated_rdfds(a(i_a)%rdfd_n_bins,a(i_a)%rdfd_n_zones)) - integrated_rdfds = 0.0_dp - do i=1, a(i_a)%n_configs - integrated_rdfds = 0.0_dp - do i1=1, a(i_a)%rdfd_n_zones - do i2=2, a(i_a)%rdfd_n_bins - integrated_rdfds(i2,i1) = integrated_rdfds(i2-1,i1) + & - (a(i_a)%rdfd_bin_pos(i2)-a(i_a)%rdfd_bin_pos(i2-1))* & - 4.0_dp*PI*((a(i_a)%rdfd_bin_pos(i2)**2)*a(i_a)%rdfds(i2,i1,i)+(a(i_a)%rdfd_bin_pos(i2-1)**2)*a(i_a)%rdfds(i2-1,i1,i))/2.0_dp - end do - end do - call print(""//reshape(integrated_rdfds(:,:), (/ a(i_a)%rdfd_n_zones*a(i_a)%rdfd_n_bins /) ), file=outfile) - end do - deallocate(integrated_rdfds) - - else if (a(i_a)%xrd) then ! xrd - call print("# xrd",file=outfile) - call print("n_bins="//a(i_a)%xrd_n_2theta//" n_data="//a(i_a)%n_configs, file=outfile) - do i=1, a(i_a)%xrd_n_2theta - call print(""//a(i_a)%xrd_2theta_pos(i), file=outfile) - end do - do i=1, a(i_a)%n_configs - call print(""//a(i_a)%xrds(:,i), file=outfile) - end do - - else if (a(i_a)%adfd) then !adfd - call print("# adfd", file=outfile) - call print("n_bins="//a(i_a)%adfd_n_zones*a(i_a)%adfd_n_dist_bins*a(i_a)%adfd_n_angle_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i1=1, a(i_a)%adfd_n_zones - do i2=1, a(i_a)%adfd_n_dist_bins - do i3=1, a(i_a)%adfd_n_angle_bins - if (a(i_a)%adfd_zone_width > 0.0_dp) then - call print(""//a(i_a)%adfd_zone_pos(i1)//" "//a(i_a)%adfd_dist_bin_pos(i2)//" "//a(i_a)%adfd_angle_bin_pos(i3), file=outfile) - else - call print(""//a(i_a)%adfd_dist_bin_pos(i2)//" "//a(i_a)%adfd_angle_bin_pos(i3), file=outfile) - endif - end do - end do - end do - do i=1, a(i_a)%n_configs - call print(""//reshape(a(i_a)%adfds(:,:,:,i), (/ a(i_a)%adfd_n_zones*a(i_a)%adfd_n_dist_bins*a(i_a)%adfd_n_angle_bins /) ), file=outfile) - end do - - else if (a(i_a)%KEdf_radial) then !r-dep KE density - call print("# r-dependent KE density", file=outfile) - call print("n_bins="//a(i_a)%KEdf_radial_n_zones*a(i_a)%KEdf_radial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - - do i1=1, a(i_a)%KEdf_radial_n_zones - do i2=1, a(i_a)%KEdf_radial_n_bins - if (a(i_a)%KEdf_radial_zone_width > 0.0_dp) then - call print(""//a(i_a)%KEdf_radial_zone_pos(i1)//" "//a(i_a)%KEdf_radial_bin_pos(i2), file=outfile) - else - call print(""//a(i_a)%KEdf_radial_bin_pos(i2), file=outfile) - endif - end do - end do - do i=1, a(i_a)%n_configs - call print(""//reshape(a(i_a)%KEdf_radial_histograms(:,:,i), (/ a(i_a)%KEdf_radial_n_zones*a(i_a)%KEdf_radial_n_bins /) ), file=outfile) - end do - - else if (a(i_a)%propdf_radial) then !r-dep |F| density - call print("# r-dependent prop density", file=outfile) - call print("n_bins="//a(i_a)%propdf_radial_n_zones*a(i_a)%propdf_radial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - - do i1=1, a(i_a)%propdf_radial_n_zones - do i2=1, a(i_a)%propdf_radial_n_bins - if (a(i_a)%propdf_radial_zone_width > 0.0_dp) then - call print(""//a(i_a)%propdf_radial_zone_pos(i1)//" "//a(i_a)%propdf_radial_bin_pos(i2), file=outfile) - else - call print(""//a(i_a)%propdf_radial_bin_pos(i2), file=outfile) - endif - end do - end do - do i=1, a(i_a)%n_configs - call print(""//reshape(a(i_a)%propdf_radial_histograms(:,:,i), (/ a(i_a)%propdf_radial_n_zones*a(i_a)%propdf_radial_n_bins /) ), file=outfile) - end do - - else if (a(i_a)%geometry) then !geometry - call print("# geometry histogram", file=outfile) - call print("n_bins="//a(i_a)%geometry_params%N//" n_data="//a(i_a)%n_configs, file=outfile) - do i=1, a(i_a)%geometry_params%N -! call print(a(i_a)%geometry_pos(i), file=outfile) - call print(trim(a(i_a)%geometry_label(i)), file=outfile) - end do - do i=1, a(i_a)%n_configs - call print(a(i_a)%geometry_histograms(:,i), file=outfile) - end do - - else if (a(i_a)%density_axial_silica) then !density_axial_silica - call print("# uniaxial density histogram in direction "//a(i_a)%density_axial_axis, file=outfile) - call print("n_bins="//a(i_a)%density_axial_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i=1, a(i_a)%density_axial_n_bins - call print(a(i_a)%density_axial_pos(i), file=outfile) - end do - do i=1, a(i_a)%n_configs - call print(a(i_a)%density_axial_histograms(:,i), file=outfile) - end do - - else if (a(i_a)%num_hbond_silica) then !num_hbond_silica - !header - call print("# num_hbond_silica in direction "//a(i_a)%num_hbond_axis, file=outfile) - call print("n_bins="//a(i_a)%num_hbond_n_type*a(i_a)%num_hbond_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i1=1, a(i_a)%num_hbond_n_type - do i2=1, a(i_a)%num_hbond_n_bins - !call print(""//a(i_a)%num_hbond_type_code(i1)//" "//a(i_a)%num_hbond_bin_pos(i2), file=outfile) - call print(""//trim(a(i_a)%num_hbond_type_label(i1))//" "//a(i_a)%num_hbond_bin_pos(i2), file=outfile) - end do - end do - !histograms - do i=1, a(i_a)%n_configs - call print(""//reshape(a(i_a)%num_hbond_histograms(:,:,i), (/ a(i_a)%num_hbond_n_type*a(i_a)%num_hbond_n_bins /) ), file=outfile) - end do - - !integrated histograms header - call print("", file=outfile) - call print("", file=outfile) - call print("# integrated_num_hbond_silica", file=outfile) - call print("n_bins="//a(i_a)%num_hbond_n_type*a(i_a)%num_hbond_n_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i1=1, a(i_a)%num_hbond_n_type - do i2=1, a(i_a)%num_hbond_n_bins - !call print(""//a(i_a)%num_hbond_type_code(i1)//" "//a(i_a)%num_hbond_bin_pos(i2), file=outfile) - call print(""//trim(a(i_a)%num_hbond_type_label(i1))//" "//a(i_a)%num_hbond_bin_pos(i2), file=outfile) - end do - end do - !integrated histograms - allocate(a(i_a)%integrated_num_hbond_histograms(a(i_a)%num_hbond_n_bins,a(i_a)%num_hbond_n_type)) - a(i_a)%integrated_num_hbond_histograms = 0.0_dp - do i=1, a(i_a)%n_configs - a(i_a)%integrated_num_hbond_histograms = 0.0_dp - do i1=1, a(i_a)%num_hbond_n_type - do i2=2, a(i_a)%num_hbond_n_bins - a(i_a)%integrated_num_hbond_histograms(i2,i1) = a(i_a)%integrated_num_hbond_histograms(i2-1,i1) + & - (a(i_a)%num_hbond_bin_pos(i2)-a(i_a)%num_hbond_bin_pos(i2-1))* & - 4.0_dp*PI*((a(i_a)%num_hbond_bin_pos(i2)**2)*a(i_a)%num_hbond_histograms(i2,i1,i)+(a(i_a)%num_hbond_bin_pos(i2-1)**2)*a(i_a)%num_hbond_histograms(i2-1,i1,i))/2.0_dp - end do - end do - call print(""//reshape(a(i_a)%integrated_num_hbond_histograms(:,:), (/ a(i_a)%num_hbond_n_type*a(i_a)%num_hbond_n_bins /) ), file=outfile) - end do - deallocate(a(i_a)%integrated_num_hbond_histograms) - - else if (a(i_a)%water_orientation_silica) then !water_orientation_silica - !header - call print("# water_orientation_silica in direction "//a(i_a)%water_orientation_axis, file=outfile) - call print("n_bins="//a(i_a)%water_orientation_n_pos_bins*a(i_a)%water_orientation_n_angle_bins//" n_data="//a(i_a)%n_configs, file=outfile) - do i1=1, a(i_a)%water_orientation_n_pos_bins - do i2=1, a(i_a)%water_orientation_n_angle_bins - call print(""//a(i_a)%water_orientation_pos_bin(i1)//" "//a(i_a)%water_orientation_angle_bin(i2), file=outfile) - end do - end do - !histograms - do i=1, a(i_a)%n_configs - call print(""//reshape(a(i_a)%water_orientation_histograms(:,:,i), (/ a(i_a)%water_orientation_n_pos_bins*a(i_a)%water_orientation_n_angle_bins /) ), file=outfile) - end do - - else - call system_abort("print_analyses: no type of analysis set for " // i_a) - endif - endif - call finalise(outfile) - end do -end subroutine print_analyses - -!read geometry parameters to calculate -!format: -!4 number of params -!anything comment -!1 3 type #1: y-coord of atom #3 -!2 4 5 type #2: distance of atoms #4--#5 -!3 3 4 5 type #3: angle of atoms #3--#4--#5 -!4 3 1 2 4 type #4: dihedral of atoms #3--#1--#2--#4 -subroutine read_geometry_params(this,filename) - - type(analysis), intent(inout) :: this - character(*), intent(in) :: filename - - type(inoutput) :: geom_lib - character(20), dimension(10) :: fields - integer :: num_fields, status - integer :: num_geom, i, geom_type - character(STRING_LENGTH) :: comment - - call initialise(this%geometry_params,5,0,0,0,0) !type, atom1, atom2, atom3, atom4 - - if (trim(filename)=="") then - call print('WARNING! no file specified') - return !with an empty table - endif - - call initialise(geom_lib,trim(filename),action=INPUT) - call parse_line(geom_lib,' ',fields,num_fields) - if (num_fields < 1) then - call print ('WARNING! empty file '//trim(filename)) - call finalise(geom_lib) - return !with an empty table - endif - - num_geom = string_to_int(fields(1)) - comment="" - comment = read_line(geom_lib,status) - call print(trim(comment),PRINT_VERBOSE) - - do i=1,num_geom - call parse_line(geom_lib,' ',fields,num_fields) - if (num_fields.gt.5 .or. num_fields.lt.2) call system_abort('read_geometry_params: 1 type and maximum 4 atoms must be in the geometry file') - geom_type = string_to_int(fields(1)) - select case (geom_type) - case (1) !y coord atom1 - if (num_fields.lt.2) call system_abort('type 1: coordinate, =1 atoms needed') - call append(this%geometry_params,(/geom_type, & - string_to_int(fields(2)), & - 0, & - 0, & - 0/) ) - case (2) !distance atom1-atom2 - if (num_fields.lt.3) call system_abort('type 2: bond length, =2 atoms needed') - call append(this%geometry_params, (/geom_type, & - string_to_int(fields(2)), & - string_to_int(fields(3)), & - 0, & - 0/) ) - case (3) !angle atom1-atom2-atom3 - if (num_fields.lt.4) call system_abort('type 3: angle, =3 atoms needed') - call append(this%geometry_params, (/geom_type, & - string_to_int(fields(2)), & - string_to_int(fields(3)), & - string_to_int(fields(4)), & - 0/) ) - case (4) !dihedral atom1-atom2-atom3-atom4 - if (num_fields.lt.5) call system_abort('type 4: dihedral, =4 atoms needed') - call append(this%geometry_params, (/geom_type, & - string_to_int(fields(2)), & - string_to_int(fields(3)), & - string_to_int(fields(4)), & - string_to_int(fields(5)) /) ) - case (5) !distance of any atom3(Z) from the atom1-atom2 bond - if (num_fields.lt.4) call system_abort('type 5: Zatom3 distance from the atom1-atom2 bond, =3 atoms needed') - call append(this%geometry_params, (/geom_type, & - string_to_int(fields(2)), & - string_to_int(fields(3)), & - string_to_int(fields(4)), & - 0/) ) - case default - call system_abort('unknown type '//geom_type//', must be one of 1(y coordinate), 2(bond length/distance), 3(angle), 4(dihedral).') - end select - enddo - - call finalise(geom_lib) - -end subroutine read_geometry_params - -subroutine reallocate_data_1d(data, n, n_bins) - real(dp), allocatable, intent(inout) :: data(:,:) - integer, intent(in) :: n, n_bins - - integer :: new_size - real(dp), allocatable :: t_data(:,:) - - if (allocated(data)) then - if (n <= size(data,2)) return - allocate(t_data(size(data,1),size(data,2))) - t_data = data - deallocate(data) - if (size(t_data,2) <= 0) then - new_size = 10 - else if (size(t_data,2) < 1000) then - new_size = 2*size(t_data,2) - else - new_size = floor(1.25*size(t_data,2)) - endif - allocate(data(size(t_data,1), new_size)) - data(1:size(t_data,1),1:size(t_data,2)) = t_data(1:size(t_data,1),1:size(t_data,2)) - data(1:size(t_data,1),size(t_data,2)+1:size(data,2)) = 0.0_dp - deallocate(t_data) - else - allocate(data(n_bins, n)) - endif -end subroutine reallocate_data_1d - -subroutine reallocate_data_2d(data, n, n_bins) - real(dp), allocatable, intent(inout) :: data(:,:,:) - integer, intent(in) :: n, n_bins(2) - - integer :: new_size - real(dp), allocatable :: t_data(:,:,:) - - if (allocated(data)) then - if (n <= size(data,3)) return - allocate(t_data(size(data,1),size(data,2),size(data,3))) - t_data = data - deallocate(data) - if (size(t_data,3) <= 0) then - new_size = 10 - else if (size(t_data,3) < 1000) then - new_size = 2*size(t_data,3) - else - new_size = floor(1.25*size(t_data,3)) - endif - allocate(data(size(t_data,1), size(t_data,2), new_size)) - data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3)) = & - t_data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3)) - data(1:size(t_data,1),1:size(t_data,2),size(t_data,3)+1:size(data,3)) = 0.0_dp - deallocate(t_data) - else - allocate(data(n_bins(1), n_bins(2), n)) - endif -end subroutine reallocate_data_2d - -subroutine reallocate_data_3d(data, n, n_bins) - real(dp), allocatable, intent(inout) :: data(:,:,:,:) - integer, intent(in) :: n, n_bins(3) - - integer :: new_size - real(dp), allocatable :: t_data(:,:,:,:) - - if (allocated(data)) then - if (n <= size(data,4)) return - allocate(t_data(size(data,1),size(data,2),size(data,3),size(data,4))) - t_data = data - deallocate(data) - if (size(t_data,4) <= 0) then - new_size = 10 - else if (size(t_data,4) < 1000) then - new_size = 2*size(t_data,4) - else - new_size = floor(1.25*size(t_data,4)) - endif - allocate(data(size(t_data,1), size(t_data,2), size(t_data,3), new_size)) - data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3),1:size(t_data,4)) = & - t_data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3),1:size(t_data,4)) - data(1:size(t_data,1),1:size(t_data,2),1:size(t_data,3),size(t_data,4)+1:size(data,4)) = 0.0_dp - deallocate(t_data) - else - allocate(data(n_bins(1), n_bins(2), n_bins(3), n)) - endif -end subroutine reallocate_data_3d - -end module structure_analysis_module - -program structure_analysis -use libatoms_module -use structure_analysis_module -implicit none - - type(Dictionary) :: cli_params - - character(len=STRING_LENGTH) :: infilename - integer :: decimation - type(Inoutput) :: list_infile - type (CInoutput) :: infile - logical :: infile_is_list - logical :: quiet - - character(len=STRING_LENGTH) :: commandfilename - type(Inoutput) :: commandfile - - character(len=10240) :: args_str, myline - integer :: n_analysis_a - type(analysis), allocatable :: analysis_a(:) - - logical :: more_files - integer :: status, arg_line_no - integer :: error = ERROR_NONE - real(dp) :: time - - integer :: i_a, frame_count, raw_frame_count - type(Atoms) :: structure - logical :: do_verbose - - call system_initialise(PRINT_NORMAL) - - call initialise(cli_params) - call param_register(cli_params, "verbose", "F", do_verbose, help_string="Set verbosity level to VERBOSE.") - if (.not. param_read_args(cli_params, ignore_unknown=.true.)) & - call system_abort("Impossible failure to parse verbosity") - call finalise(cli_params) - if (do_verbose) then - call system_initialise(verbosity=PRINT_VERBOSE) - endif - - call initialise(cli_params) - call param_register(cli_params, "commandfile", '', commandfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "infile", "stdin", infilename, help_string="Input file name (default: stdin)") - call param_register(cli_params, "decimation", "1", decimation, help_string="How many frames to advance in each step, i.e. every n-th frame will be analysed.") - call param_register(cli_params, "infile_is_list", "F", infile_is_list, help_string="Treat infile as a list of filenames to process sequentially.") - call param_register(cli_params, "quiet", "F", quiet, help_string="Suppress frame progress count.") - if (.not. param_read_args(cli_params, ignore_unknown = .true., task="CLI")) then - call system_abort("Failed to parse CLI") - endif - if (len_trim(commandfilename) == 0) then - allocate(analysis_a(1)) - call analysis_read(analysis_a(1)) - else - if (.not. param_read_args(cli_params, ignore_unknown = .false., task="CLI_again")) then - call system_abort("Failed to parse CLI again after getting a commandfile, most likely passed in some analysis specific flags on command line") - endif - call initialise(commandfile, trim(commandfilename), INPUT) - arg_line_no = 1 - myline = read_line(commandfile) - read (unit=myline,fmt=*) n_analysis_a - allocate(analysis_a(n_analysis_a)) - do i_a=1, n_analysis_a - args_str = read_line(commandfile) - if (i_a == 1) then - call analysis_read(analysis_a(i_a), args_str=args_str) - else - call analysis_read(analysis_a(i_a), analysis_a(i_a-1), args_str) - endif - end do - endif - call finalise(cli_params) - - call check_analyses(analysis_a) - - more_files = .true. - if (infile_is_list) then - call initialise(list_infile, trim(infilename), INPUT) - infilename = read_line(list_infile, status) - more_files = .false. - if (status == 0) more_files = .true. - endif - - raw_frame_count = decimation-1 - frame_count = 0 - do while (more_files) - - call print(trim(infilename)) - call initialise(infile, infilename, INPUT) - call read(structure, infile, error=error, frame=raw_frame_count) - do while (error == ERROR_NONE) - frame_count = frame_count + 1 - if (.not. quiet) then - if (mod(frame_count,1000) == 1) write (mainlog%unit,'(I7,a,$)') frame_count," " - if (mod(frame_count,10) == 0) write (mainlog%unit,'(I1,$)') mod(frame_count/10,10) - if (mod(frame_count,1000) == 0) write (mainlog%unit,'(a)') " " - endif - - if (.not. get_value(structure%params,"Time",time)) then - time = -1.0_dp - endif - call do_analyses(analysis_a, time, frame_count, structure) - call finalise(structure) - - raw_frame_count = raw_frame_count + decimation - ! get ready for next structure - call read(structure, infile, error=error, frame=raw_frame_count) - end do - ! We do not want to handle this error - call clear_error(error) - raw_frame_count = raw_frame_count - decimation - - ! get ready for next file - more_files = .false. - call finalise(infile) - if (infile_is_list) then - infilename = read_line(list_infile, status) - if (status == 0) then - more_files = .true. - endif - if (infile%n_frame > 0) then - raw_frame_count = (decimation-1)-(infile%n_frame-1-raw_frame_count) - else - raw_frame_count = decimation-1 - endif - endif - write (mainlog%unit,'(a)') " " - frame_count = 0 - end do ! more_files - if (infile_is_list) call finalise(list_infile) - - call print_analyses(analysis_a) - -end program structure_analysis diff --git a/src/Structure_processors/test_ran.f95 b/src/Structure_processors/test_ran.f95 deleted file mode 100755 index 1a240016e0..0000000000 --- a/src/Structure_processors/test_ran.f95 +++ /dev/null @@ -1,93 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -program test_ran - use libatoms_module - -#ifdef _OPENMP - use omp_lib -#endif - - implicit none - - integer, parameter :: nrand = 100000 - - type(Histogram1D), save :: h - !$omp threadprivate(h) - integer :: i, n - real(DP) :: d - - ! --- - - call system_initialise(PRINT_NORMAL) - - call print("Start generating random numbers on proc 0...") - - if (mpi_id() == 0) then - !$omp parallel default(none) private(i, n, d) - do i = 1, nrand - d = ran_normal() - enddo - !$omp end parallel - endif - - call print("...done") - - call print("Synching rngs.") - call system_resync_rng - - call print("Start generating random numbers on all procs...") - - !$omp parallel default(none) private(i, n, d) - call initialise(h, 1000, -10.0_DP, 10.0_DP) - - do i = 1, nrand - call add(h, ran_normal()) - enddo - -#ifdef _OPENMP - n = omp_get_thread_num() -#else - n = 0 -#endif - - call write(h, "normal_"//mpi_id()//"_"//n//".out") - call finalise(h) - !$omp end parallel - - call print("...done") - - call print("Please check that all normal_*_1.out are identical.") - - call system_finalise() - -end program test_ran diff --git a/src/Structure_processors/xyz2pdb.f95 b/src/Structure_processors/xyz2pdb.f95 deleted file mode 100644 index 688b734825..0000000000 --- a/src/Structure_processors/xyz2pdb.f95 +++ /dev/null @@ -1,329 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! last modified -- 2009-02-19 -- Csilla -! takes an xyz file, identifies the residues and outputs a PSF and a PDB file. -#include "error.inc" - -program xyz2pdb - -! use libatoms_module - - use error_module - use atoms_types_module, only: bond_length, assign_pointer, add_property, atoms_sort, distance_min_image - use atoms_module, only: atoms, finalise, & - set_cutoff, & - calc_connect, print, & - map_into_cell, has_property - use dictionary_module, only: dictionary, initialise, finalise, & - set_value, STRING_LENGTH - use linearalgebra_module, only: find_in_array - use paramreader_module, only: param_register, param_read_args, & - PARAM_MANDATORY - use periodictable_module, only: ElementCovRad - use system_module, only: dp, inoutput, & - system_initialise, system_finalise, & - system_timer, system_abort, & - print, verbosity_push, & - operator(//), & - INPUT, OUTPUT, & - PRINT_SILENT, PRINT_NORMAL, PRINT_ANALYSIS, PRINT_NERD - use table_module, only: table, finalise, int_part, delete, TABLE_STRING_LENGTH - use topology_module, only: create_residue_labels_arb_pos, delete_metal_connects, & - write_brookhaven_pdb_file, & - write_psf_file, & - MM_RUN, silica_2body_cutoff, find_molecule_ids - use cinoutput_module, only : read, write - - implicit none - - type(Atoms) :: my_atoms - type(Table) :: intrares_impropers - - type(Dictionary) :: params_in - character(len=STRING_LENGTH) :: Library, & - xyz_file - real(dp) :: Neighbour_Tolerance - logical :: Delete_Metal_Connections - logical :: print_xsc - character(80) :: Root, & - pdb_name, & - psf_name, & - xsc_name - integer :: len_name - integer :: center_atom, i, j - real(dp) :: shift(3) - logical :: ex - logical :: have_silica_potential - logical :: use_avgpos, Print_PSF - integer :: at_i, iri_i - integer, pointer :: sort_index_p(:) - integer, allocatable :: rev_sort_index(:) - logical :: do_sort, do_sort_3 - integer :: error = ERROR_NONE - character(80) :: sorted_name - - integer, pointer :: mol_id(:), atom_res_number(:) - character(len=1), pointer :: atom_type(:,:), atom_type_PDB(:,:), atom_res_name(:,:), atom_mol_name(:,:) - character(len=STRING_LENGTH) t_atom_name - - call system_initialise(verbosity=PRINT_silent,enable_timing=.true.) - call verbosity_push(PRINT_NORMAL) - call system_timer('program') - - ! reading in run parameters - call initialise(params_in) - call param_register(params_in, 'File', PARAM_MANDATORY, xyz_file, help_string="Input XYZ file containing species:pos or species:avgpos") - call param_register(params_in, 'Residue_Library', PARAM_MANDATORY, Library, help_string="Residue library for pattern matching, e.g. $QUIP_DIR/libAtoms/protein_res.CHARMM.lib") - call param_register(params_in, 'Neighbour_Tolerance', '1.2', Neighbour_Tolerance, help_string="Bond criterion tolerance factor. Two atoms are bonded if d(a1,a2)<[CovRad(a1)+CovRad(a2)]*Neighbour_Tolerance. This should normally not need changing.") - call param_register(params_in, 'Delete_Metal_Connections', 'T', Delete_Metal_Connections, help_string="Whether not to take into account bonds of non(C,H,O,N,P) elements.") - call param_register(params_in, 'Print_XSC', 'F', print_xsc, help_string="Whether to output XSC (NAMD cell file).") - call param_register(params_in, 'Center_atom', '0', center_atom, help_string="Which atom should the system be centered around. 0 means no centering. This is important for programs that can only treat nonperiodic systems not to cut the molecule in half.") - call param_register(params_in, 'have_silica_potential', 'F', have_silica_potential, help_string="Whether there is a silica unit in the system to be treated with the Danny potential in CP2K.") - call param_register(params_in, 'use_avgpos', 'T', use_avgpos, help_string="Whether to use the average positions (avgpos) for the pattern matching rather than the instantaneous positions (pos).") - call param_register(params_in, 'sort', 'F', do_sort, help_string="Whether to sort atoms by molecule and residue.") - call param_register(params_in, 'sort_3', 'F', do_sort_3, help_string="If sorting, whether to sort by atom number within residue as well") - call param_register(params_in, 'Print_PSF', 'T', Print_PSF, help_string="Write PSF file") - if (.not. param_read_args(params_in)) then - call print_usage - call system_abort('could not parse argument line') - end if - - ! filenames - len_name = len_trim(xyz_file) - if (any(xyz_file(len_name-3:len_name).eq.(/'.xyz','.XYZ'/))) then - Root = xyz_file(1:len_name-4) - else - Root = xyz_file(1:len_name) - endif - pdb_name = trim(Root)//'.pdb' - psf_name = trim(Root)//'.psf' - xsc_name = trim(Root)//'.xsc' - sorted_name = trim(Root)//'.sorted.xyz' - - ! print run parameters - call print('Input:') - call print(' XYZ file: '//trim(xyz_file)) - call print(' Residue Library: '//trim(Library)) - call print(' Print_XSC (NAMD cell file): '//print_xsc) - call print(' Delete_Metal_Connections'//Delete_Metal_Connections) - call print(' Neighbour Tolerance: '//Neighbour_Tolerance) - call print(' have_silica_potential: '//have_silica_potential) - call print(' use_avgpos to build connectivity: '//use_avgpos) - call print(' sort atoms by molecule/residue : '//use_avgpos) - if(center_atom > 0) & - call print(' Center atom: '//center_atom) - call print('Output:') - call print(' PDB file: '//trim(pdb_name)) - call print(' PSF file: '//trim(psf_name)) - if (print_xsc) call print(' XSC file: '//trim(xsc_name)) - call print('CHARMM atomic types and Brookhaven PDB format are used') - call print('') - - call finalise(params_in) - - ! check if input files exist - inquire(file=trim(xyz_file),exist=ex) - if (.not.ex) then - call print_usage - call system_abort('Missing xyz File '//xyz_file) - endif - if (trim(Library) /= '-') then - inquire(file=trim(Library),exist=ex) - if (.not.ex) then - call print_usage - call system_abort('Missing Residue_Library '//Library) - endif - endif - - ! read in XYZ - call print('Reading in coordinates...') - call read(my_atoms,trim(xyz_file)) - - - ! calculating connectivities - call print('Calculating connectivities...') - ! use nonuniform connect_cutoff, include only nearest neighbours, otherwise the adjacency matrix will contain disjoint regions - if (have_silica_potential) then - call set_cutoff(my_atoms,silica_2body_cutoff) - else - call set_cutoff(my_atoms,0.0_dp) - endif - my_atoms%nneightol = Neighbour_Tolerance - call calc_connect(my_atoms) - ! remove bonds for metal ions - everything but H, C, N, O, Si, P, S - if (Delete_Metal_Connections) call delete_metal_connects(my_atoms) -! call print(my_atoms%connect) - - ! center atoms if needed - if(center_atom > 0) then - shift = my_atoms%pos(:,center_atom) - do i=1,my_atoms%N - my_atoms%pos(:,i) = my_atoms%pos(:,i)-shift - end do - end if - ! call map_into_cell(my_atoms) - - ! identify residues - call print('Identifying residues...') - if (trim(Library) == "-") then - call find_molecule_ids(my_atoms) - if (.not. assign_pointer(my_atoms, 'mol_id', mol_id)) & - call system_abort("Failed to find mol_id field after find_molecule_ids!") - call add_property(my_atoms, 'atom_charge', 0.0_dp) - call add_property(my_atoms, 'atom_res_number', 0, ptr=atom_res_number) - call add_property(my_atoms, 'atom_type', ' ', ptr=atom_type) - call add_property(my_atoms, 'atom_type_PDB', ' ', ptr=atom_type_PDB) - call add_property(my_atoms, 'atom_res_name', ' ', ptr=atom_res_name) - call add_property(my_atoms, 'atom_mol_name', ' ', ptr=atom_mol_name) - atom_res_number = mol_id - atom_type(:,:) = my_atoms%species(:,:) - atom_type_PDB(:,:) = my_atoms%species(:,:) - do i=1, my_atoms%N - t_atom_name = adjustl("R"//atom_res_number(i)) - do j=1, len_trim(t_atom_name) - atom_res_name(j,i) = t_atom_name(j:j) - end do - t_atom_name = adjustl("M"//mol_id(i)) - do j=1, len_trim(t_atom_name) - atom_mol_name(j,i) = t_atom_name(j:j) - end do - end do - else - call set_value(my_atoms%params,'Library',trim(Library)) - if (use_avgpos) then - call create_residue_labels_arb_pos(my_atoms,do_CHARMM=.true.,intrares_impropers=intrares_impropers, & - find_silica_residue=have_silica_potential,pos_field_for_connectivity="avgpos") - else !use actual positions - call create_residue_labels_arb_pos(my_atoms,do_CHARMM=.true.,intrares_impropers=intrares_impropers, & - find_silica_residue=have_silica_potential,pos_field_for_connectivity="pos") - endif - endif - - if (do_sort) then - ! sort by molecule, residue ID - nullify(sort_index_p) - if (.not. assign_pointer(my_atoms, 'sort_index', sort_index_p)) then - call add_property(my_atoms, 'sort_index', 0) - if (.not. assign_pointer(my_atoms, 'sort_index', sort_index_p)) & - call system_abort("WARNING: do_cp2k_calc failed to assign pointer or create new field for sort_index, can't sort") - endif - do at_i=1, my_atoms%N - sort_index_p(at_i) = at_i - end do - if (.not.(has_property(my_atoms,'mol_id')) .or. .not. has_property(my_atoms,'atom_res_number')) then - call system_abort("WARNING: can't do sort_by_molecule - need mol_id and atom_res_number") - else - if (do_sort_3) then - call atoms_sort(my_atoms, 'mol_id', 'atom_res_number', 'motif_atom_num', error=error) - else - call atoms_sort(my_atoms, 'mol_id', 'atom_res_number', error=error) - endif - HANDLE_ERROR(error) - do at_i=1, my_atoms%N - if (sort_index_p(at_i) /= at_i) then - call print("sort() of my_atoms%data by mol_id, atom_res_number reordered some atoms") - exit - endif - end do - end if - call calc_connect(my_atoms) - - ! fix intrares_impropers to correspond to sorted atom numbers - allocate(rev_sort_index(my_atoms%N)) - do at_i=1, my_atoms%N - rev_sort_index(sort_index_p(at_i)) = at_i - end do - do iri_i=1, intrares_impropers%N - intrares_impropers%int(1:4,iri_i) = rev_sort_index(intrares_impropers%int(1:4,iri_i)) - end do - deallocate(rev_sort_index) - end if ! do_sort - - ! print output PDB and PSF files - call print('Writing files with CHARMM format...') - if (Print_PSF) then - call write_psf_file(my_atoms,psf_file=trim(psf_name),intrares_impropers=intrares_impropers,add_silica_23body=have_silica_potential) - endif - call write_brookhaven_pdb_file(my_atoms,trim(pdb_name)) - if (Print_XSC) call write_xsc_file(my_atoms,xsc_file=trim(xsc_name)) - if (do_sort) then - call write(my_atoms, trim(sorted_name)) - endif - - call finalise(intrares_impropers) - call finalise(my_atoms) - call print ('Finished.') - - call system_timer('program') - call system_finalise - -contains - - subroutine print_usage - - call print('Usage: xyz2pdb File=filename.xyz [Residue_Library=library] [Print_XSC] [Delete_Metal_Connections=T] [Neighbour_tolerance=1.2] [Center_atom=num]') - call print('') - call print(' File=filename, where your input file has extension .xyz') - call print(' Residue_Library=library, where the residue library is, - for no library, just use mol_id based on connectivity') - call print(' [Print_XSC], optional, whether to print NAMD cell file, default is false') - call print(' [Delete_Metal_Connections=T], optional, default is true, only calculates connection for H,C,N,O,Si,P,S,Cl') - call print(' should work fine - only modify if you want bonds with other elements in your structure') - call print(' [Neighbour_Tolerance=1.2], optional, default is 1.2, should work fine - do not poke it ') - call print(' unless you know you have unusally long bonds in your structure') - call print(' [Center_atom=num], optionally shifts atoms so that the atom with index num is at') - call print(' the origin, before dropping periodic boundary condition info') - call print(' [use_avgpos=T], optionally use instantaneous positions instead of average positions, if this is set to F') - call print(' [sort=F], optionally sort atoms by residue/molecule') - call print(' [have_silica_potential=F], optionally switches on the use of silica potential described by Cole et al., JChemPhys, 2007.') - - call print('') - - end subroutine - - subroutine write_xsc_file(at, xsc_file) - - character(len=*), intent(in) :: xsc_file - type(Atoms), intent(in) :: at - - type(InOutput) :: xsc - - call initialise(xsc,trim(xsc_file),action=OUTPUT) - call print(' XSC file: '//trim(xsc%filename)) - - call print('#NAMD cell file',file=xsc) - call print('#$LABELS step a_x a_y a_z b_x b_y b_z c_x c_y c_z o_x o_y o_z',file=xsc) - call print('1 '//reshape(at%lattice,(/9/))//' '//(/0,0,0/),file=xsc) -!write_string(this%params,real_format='f18.6') - call finalise(xsc) - - end subroutine write_xsc_file - -end program xyz2pdb diff --git a/src/Structure_processors/xyz2residue_library.f95 b/src/Structure_processors/xyz2residue_library.f95 deleted file mode 100644 index 55cc4dedaf..0000000000 --- a/src/Structure_processors/xyz2residue_library.f95 +++ /dev/null @@ -1,56 +0,0 @@ -program xyz2residue_library - use system_module, only : string_cat_string_array - use libatoms_module -implicit none - - type(Atoms) :: at, m_at - integer i_at, j_at, nn_ii, nn_i - integer, pointer :: mol_id(:) - character(len=32) :: specie - - call system_initialise(verbosity=PRINT_SILENT) - call verbosity_push(PRINT_NORMAL) - - call read(at, "stdin") - - call calc_connect(at) - call find_molecule_ids(at) - - specie = " " - - if (.not. assign_pointer(at, "mol_id", mol_id)) & - call system_abort("Failed to find mol_id property") - - do i_at=1, at%N - if (mol_id(i_at) /= 0) then - call select(m_at, at, mask=(mol_id(:) == mol_id(i_at))) - call calc_connect(m_at) - - call print("%residue X"//count(mol_id == mol_id(i_at))//" R"//mol_id(i_at)//" R"//mol_id(i_at)) - do j_at=1, m_at%N - line = "0 "//m_at%Z(j_at) - if (n_neighbours(m_at, j_at) > 6) & - call system_abort("Too many neighbours "//n_neighbours(m_at, j_at)//" for atom "//j_at) - do nn_ii=1, n_neighbours(m_at, j_at) - nn_i = neighbour(m_at, j_at, nn_ii) - line = trim(line)//" "//nn_i - end do - do nn_ii=n_neighbours(m_at, j_at)+1, 6 - line = trim(line)//" "//0 - end do - ! nvfortran may complain - specie = string_cat_string_array(specie,m_at%species(:,j_at)) - line = trim(line)//" "//trim(specie)//" 0.0 "//trim(specie) - call print(trim(line)) - end do - call print("") - - endif - where (mol_id == mol_id(i_at)) - mol_id = 0 - end where - end do - - call system_finalise() -end program - From 426c79f8db61ada4a4cbe1d810a0af85c5be625d Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 18:16:41 +0100 Subject: [PATCH 13/47] renamed source files to have F90 extension --- src/FilePot_drivers/cp2k_driver.f95 | 119 - src/FilePot_drivers/cp2k_driver_module.f95 | 1871 -------------- src/FilePot_drivers/cp2k_driver_old.f95 | 2708 -------------------- src/FilePot_drivers/cp2k_filepot_old.f95 | 259 -- src/FilePot_drivers/evb_driver.f95 | 254 -- src/FilePot_drivers/vasp_driver.f95 | 744 ------ 6 files changed, 5955 deletions(-) delete mode 100644 src/FilePot_drivers/cp2k_driver.f95 delete mode 100644 src/FilePot_drivers/cp2k_driver_module.f95 delete mode 100644 src/FilePot_drivers/cp2k_driver_old.f95 delete mode 100644 src/FilePot_drivers/cp2k_filepot_old.f95 delete mode 100644 src/FilePot_drivers/evb_driver.f95 delete mode 100644 src/FilePot_drivers/vasp_driver.f95 diff --git a/src/FilePot_drivers/cp2k_driver.f95 b/src/FilePot_drivers/cp2k_driver.f95 deleted file mode 100644 index 993bf68d4e..0000000000 --- a/src/FilePot_drivers/cp2k_driver.f95 +++ /dev/null @@ -1,119 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X cp2k_driver_template program -!X -!% filepot program for CP2K driver using input file template -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" -program cp2k_driver_template -use libatoms_module -use cp2k_driver_module - -implicit none - - integer, parameter :: CP2K_LINE_LENGTH = 1024 !Max line length to be printed into the CP2K input files - - type(Atoms) :: my_atoms - real(dp) :: energy - real(dp), allocatable :: f0(:,:) - real(dp), pointer :: forces_p(:,:) - type(CInoutput) :: xyz_io - - character(len=STRING_LENGTH) :: infile, outfile - character(len=STRING_LENGTH) :: args_str - character(len=STRING_LENGTH) :: arg - integer :: i, index_insert - - integer :: error = ERROR_NONE - - call system_initialise(verbosity=PRINT_SILENT,enable_timing=.true.) - call verbosity_push(PRINT_NORMAL) - call system_timer('cp2k_driver_template') - - if (cmd_arg_count() < 2) & - call system_abort("Usage: cp2k_driver_template infile outfile [ other_cli_arg1=v1 other_cli_arg2=v2 ...]") - - call get_cmd_arg(1, infile) - call get_cmd_arg(2, outfile) - args_str = "" - if (cmd_arg_count() > 2) then - do i=3, cmd_arg_count() - call get_cmd_arg(i, arg) - !add {} if there is space in the arg - if (index(trim(arg)," ").ne.0) then - index_insert = index(trim(arg),"=") - arg(index_insert+1:len_trim(arg)+2) = "{"//arg(index_insert+1:len_trim(arg))//"}" - call print('arg: '//trim(arg),PRINT_SILENT) - endif - args_str = trim(args_str) // " " // trim(arg) - end do - endif - - call read(my_atoms,infile, error=error) - if (error == ERROR_NONE) then - allocate(f0(3,my_atoms%N)) - else - ! continue: do_cp2k_calc() should fail, but print first out help message if requested - CLEAR_ERROR(error) - endif - - !call CP2K - call do_cp2k_calc(at=my_atoms, f=f0, e=energy, args_str=trim(args_str), error=error) - HANDLE_ERROR(error) - - !momentum conservation -! call sum0(f0) - - !write energy and forces - call set_value(my_atoms%params,'energy',energy) - call add_property(my_atoms,'force', 0.0_dp, n_cols=3) - if (.not. assign_pointer(my_atoms, 'force', forces_p)) then - call system_abort("filepot_read_output needed forces, but couldn't find force in my_atoms ") - endif - forces_p = f0 - - call initialise(xyz_io,outfile,action=OUTPUT) - call write(my_atoms,xyz_io,real_format='%20.13f') - call finalise(xyz_io) - - deallocate(f0) - call finalise(my_atoms) - call system_timer('cp2k_driver_template') - mainlog%prefix="" - call verbosity_push(PRINT_SILENT) - call system_finalise - -end program cp2k_driver_template diff --git a/src/FilePot_drivers/cp2k_driver_module.f95 b/src/FilePot_drivers/cp2k_driver_module.f95 deleted file mode 100644 index bca887be27..0000000000 --- a/src/FilePot_drivers/cp2k_driver_module.f95 +++ /dev/null @@ -1,1871 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X cp2k_driver_module -!X -!% guts of cp2k driver from template -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -module cp2k_driver_module - -use libatoms_module - -implicit none - -private - -public :: do_cp2k_calc -public :: read_output, qmmm_qm_abc, calc_charge_lsd, cp2k_state_change - -contains - - subroutine do_cp2k_calc(at, f, e, args_str, error) - type(Atoms), intent(inout) :: at - real(dp), intent(out) :: f(:,:), e - character(len=*), intent(in) :: args_str - integer, intent(out), optional :: error - - type(Dictionary) :: cli - character(len=STRING_LENGTH) :: run_type, cp2k_template_file, psf_print, cp2k_program, link_template_file, & - topology_suffix, qmmm_link_type, qmmm_link_qm_kind - logical :: clean_up_files, save_output_files, save_output_wfn_files, use_buffer, persistent - integer :: clean_up_keep_n, persistent_restart_interval, qmmm_link_qm_kind_z - integer :: max_n_tries - real(dp) :: max_force_warning - real(dp) :: qm_vacuum - real(dp) :: centre_pos(3), cp2k_box_centre_pos(3) - logical :: auto_centre, has_centre_pos - logical :: try_reuse_wfn - character(len=STRING_LENGTH) :: calc_qm_charges, calc_virial - logical :: do_calc_virial - - character(len=128) :: method - - integer :: link_template_n_lines - character(len=STRING_LENGTH), allocatable :: link_template_a(:) - integer :: i_line - - character(len=STRING_LENGTH) :: run_dir - - type(Table) :: qm_list, old_qm_list - type(Table) :: cut_bonds, old_cut_bonds - integer, pointer :: cut_bonds_p(:,:), old_cut_bonds_p(:,:) - integer, allocatable :: qm_list_a(:), old_qm_list_a(:) - integer, allocatable :: link_list_a(:), old_link_list_a(:), inner_link_list_a(:) - integer, allocatable :: qm_and_link_list_a(:) - integer :: i_inner, i_outer, shift(3) - integer :: counter - - integer :: charge, old_charge - logical :: do_lsd, old_do_lsd - - logical :: can_reuse_wfn, qm_list_changed, qmmm_link_list_changed, & - qmmm_same_lattice, qmmm_use_mm_charges, qmmm_link_fix_pbc - character(len=STRING_LENGTH) :: run_suffix - - logical :: use_QM, use_MM, use_QMMM - logical :: cp2k_calc_fake - - integer, pointer :: isolated_atom(:) - integer i, at_Z, insert_pos - real(dp) :: cur_qmmm_qm_abc(3), old_qmmm_qm_abc(3) - - integer, pointer :: old_cluster_mark_p(:), cluster_mark_p(:) - logical :: dummy, have_silica_potential, have_titania_potential, silica_add_23_body - logical :: silica_pos_dep_charges - real(dp) :: silica_charge_transfer, silicon_charge, oxygen_charge, hydrogen_charge - integer :: res_num_silica - logical :: do_mom_cons - type(Table) :: intrares_impropers - - integer, pointer :: sort_index_p(:), mol_id_p(:) - integer, allocatable :: rev_sort_index(:) - type(Inoutput) :: rev_sort_index_io, persistent_run_i_io, persistent_cell_file_io, persistent_traj_io - character(len=1024) :: l - - integer :: run_dir_i, force_run_dir_i, delete_dir_i - - logical :: at_periodic - integer :: form_bond(2), break_bond(2) - real(dp) :: disp(3) - - character(len=STRING_LENGTH) :: verbosity - character(len=STRING_LENGTH) :: tmp_MM_param_filename, tmp_QM_pot_filename, tmp_QM_basis_filename - character(len=STRING_LENGTH) :: MM_param_filename, QM_pot_filename, QM_basis_filename - logical :: truncate_parent_dir - character(len=STRING_LENGTH) :: dir, tmp_run_dir - character(len=1024) :: log_sys_command_str - integer :: tmp_run_dir_i, stat - logical :: exists, persistent_already_started, persistent_start_cp2k, persistent_frc_exists, create_residue_labels, & - remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds - integer :: persistent_run_i, persistent_frc_size, qm_mol_id, n_hydrogen, old_n_hydrogen, n_extra_electrons, old_n_extra_electrons - integer :: qmmm_link_n_electrons - - type(inoutput) :: cp2k_input_io, cp2k_input_tmp_io - real(dp) :: wait_time, persistent_max_wait_time - - character(len=100) proj - - INTERFACE - elemental function ffsize(f) - character(len=*), intent(in)::f - integer::ffsize - end function ffsize - END INTERFACE - - - INIT_ERROR(error) - - call system_timer('do_cp2k_calc') - - call system_timer('do_cp2k_calc/init') - call initialise(cli) - call param_register(cli, 'Run_Type', PARAM_MANDATORY, run_type, help_string="Type of run QS, MM, or QMMM") - call param_register(cli, 'use_buffer', 'T', use_buffer, help_string="If true, use buffer as specified in relevant hybrid_mark") - call param_register(cli, 'run_suffix', '', run_suffix, help_string="String to append to various marks and saved info to indicate distinct sets of calculations or QM/MM QM regions") - call param_register(cli, 'cp2k_template_file', 'cp2k_input.template', cp2k_template_file, help_string="filename for cp2k input template") - call param_register(cli, "qmmm_link_template_file", "", link_template_file, help_string="filename for cp2k link atoms template file") - call param_register(cli, 'PSF_print', 'NO_PSF', psf_print, help_string="when to print PSF file: NO_PSF, DRIVER_PRINT_AND_SAVE, USE_EXISTING_PSF") - call param_register(cli, "topology_suffix", "", topology_suffix, help_string="String to append to file containing topology info (for runs that do multiple topologies not to accidentally reuse PSF file") - call param_register(cli, 'cp2k_program', PARAM_MANDATORY, cp2k_program, help_string="path to cp2k executable") - call param_register(cli, 'persistent', 'F', persistent, help_string="if true, use persistent connection to cp2k with REFTRAJ") - call param_register(cli, 'persistent_restart_interval', '100', persistent_restart_interval, help_string="how often to restart cp2k for persistent connection") - call param_register(cli, 'persistent_max_wait_time', '600.0', persistent_max_wait_time, help_string="Max amount of time in s to wait for forces to be available in persistent mode") - call param_register(cli, 'clean_up_files', 'T', clean_up_files, help_string="if true, clean up run directory files") - call param_register(cli, 'clean_up_keep_n', '1', clean_up_keep_n, help_string="number of old run directories to keep if cleaning up") - call param_register(cli, 'save_output_files', 'T', save_output_files, help_string="if true, save the output files") - call param_register(cli, 'save_output_wfn_files', 'F', save_output_wfn_files, help_string="if true, save output wavefunction files") - call param_register(cli, 'max_n_tries', '2', max_n_tries, help_string="max number of times to run cp2k on failure") - call param_register(cli, 'max_force_warning', '2.0', max_force_warning, help_string="generate warning if any force is larger than this") - call param_register(cli, 'qm_vacuum', '6.0', qm_vacuum, help_string="amount of vacuum to add to size of qm region in hybrid (and nonperiodic?) runs") - call param_register(cli, 'try_reuse_wfn', 'T', try_reuse_wfn, help_string="if true, try to reuse previous wavefunction file") - call param_register(cli, 'have_silica_potential', 'F', have_silica_potential, help_string="if true, use 2.8A SILICA_CUTOFF for the connectivities") - call param_register(cli, 'have_titania_potential', 'F', have_titania_potential, help_string="if true, use 2.8A TITANIA_CUTOFF for the connectivities") - call param_register(cli, 'res_num_silica', '1', res_num_silica, help_string="residue number for silica residue") - call param_register(cli, 'do_mom_cons', 'T', do_mom_cons, help_string="do we need momentum conservation?") - call param_register(cli, 'auto_centre', 'F', auto_centre, help_string="if true, automatically center configuration. May cause energy/force fluctuations. Mutually exclusive with centre_pos") - call param_register(cli, 'centre_pos', '0.0 0.0 0.0', centre_pos, has_value_target=has_centre_pos, help_string="position to center around, mutually exclusive with auto_centre") - call param_register(cli, 'cp2k_calc_fake', 'F', cp2k_calc_fake, help_string="if true, do fake cp2k runs that just read from old output files") - call param_register(cli, 'form_bond', '0 0', form_bond, help_string="extra bond to form (for EVB)") - call param_register(cli, 'break_bond', '0 0', break_bond, help_string="bond to break (for EVB)") - call param_register(cli, 'qm_charges', '', calc_qm_charges, help_string="if not blank, name of property to put QM charges in") - call param_register(cli, 'virial', '', calc_virial, help_string="if not blank, name of property to put virial in") - call param_register(cli, 'force_run_dir_i', '-1', force_run_dir_i, help_string="if > 0, force to run in this # run directory") - call param_register(cli, 'tmp_run_dir_i', '-1', tmp_run_dir_i, help_string="if >0, the cp2k run directory will be /tmp/cp2k_run_$tmp_run_dir_i$, and all input files are also copied here when first called") - call param_register(cli, 'MM_param_file', '', MM_param_filename, help_string="If tmp_run_dir>0, where to find MM parameter file to copy it to the cp2k run dir on /tmp.") !charmm.pot - call param_register(cli, 'QM_potential_file', '', QM_pot_filename, help_string="If tmp_run_dir>0, where to find QM POTENTIAL file to copy it to the cp2k run dir on /tmp.") !POTENTIAL - call param_register(cli, 'QM_basis_file', '', QM_basis_filename, help_string="If tmp_run_dir>0, where to find QM BASIS_SET file to copy it to the cp2k run dir on /tmp.") !BASIS_SET - call param_register(cli, 'silica_add_23_body', 'T', silica_add_23_body, help_string="If true and if have_silica_potential is true, add bonds for silica 2- and 3-body terms to PSF") - call param_register(cli, 'silica_pos_dep_charges', 'T', silica_pos_dep_charges, help_string="If true and if have_silica_potential is true, use variable charges for silicon and oxygen ions in silica residue") - call param_register(cli, 'silica_charge_transfer', '2.4', silica_charge_transfer, help_string="Amount of charge transferred from Si to O in silica bulk, per formula unit") - call param_register(cli, 'remove_Si_H_silica_bonds', 'T', remove_Si_H_silica_bonds, help_string="If true (default) remove any Si-H bonds detected in silica residue") - call param_register(cli, 'remove_Ti_H_titania_bonds', 'T', remove_Ti_H_titania_bonds, help_string="If true (default) remove any Ti-H bonds detected in titania residue") - call param_register(cli, 'create_residue_labels', 'T', create_residue_labels, help_string="If true, recreate residue labels each time PSF file is generated (default T)") - call param_register(cli, 'qmmm_link_type', 'IMOMM', qmmm_link_type, help_string="Type of QMMM links to create: one of IMOMM, PSEUDO or QM_KIND. Default IMOMM") - call param_register(cli, 'qmmm_link_qm_kind', 'OSTAR', qmmm_link_qm_kind, help_string="QM kind to use for inner boundary atoms when qmmm_link_type=QM_KIND") - call param_register(cli, 'qmmm_link_qm_kind_z', '8', qmmm_link_qm_kind_z, help_string="Atomic number of QM_KIND species (default 8)") - call param_register(cli, 'qmmm_link_n_electrons', '1', qmmm_link_n_electrons, help_string="Number of electrons to add per QM-MM link when qmmm_link_type=QM_KIND") - call param_register(cli, 'qmmm_same_lattice', 'F', qmmm_same_lattice, help_string="If true, use full original MM lattice for QM calculation") - call param_register(cli, 'qmmm_use_mm_charges', 'T', qmmm_use_mm_charges, help_string="If true (default) use classical point charges of atoms in QM region to calculate total DFT charge") - call param_register(cli, 'qmmm_link_fix_pbc', 'T', qmmm_link_fix_pbc, help_string="If true (default) move outer atoms in any QM links which straddle a periodic boundary so link is continous") - call param_register(cli, 'verbosity', 'NORMAL', verbosity, help_string="verbosity level") - - ! should really be ignore_unknown=false, but higher level things pass unneeded arguments down here - if (.not.param_read_line(cli, args_str, ignore_unknown=.true.,task='cp2k_driver_template args_str')) then - RAISE_ERROR('cp2k_driver could not parse argument line', error) - endif - call finalise(cli) - do_calc_virial = len_trim(calc_virial) > 0 - - call verbosity_push(verbosity_of_str(trim(verbosity))) - - mainlog%prefix="CP2K_DRIVER" - - call print('do_cp2k_calc args_str '//trim(args_str), PRINT_ALWAYS) - - if (.not. is_initialised(at)) then - RAISE_ERROR("do_cp2k_calc got uninitialized atoms structure", error) - endif - - if (cp2k_calc_fake) then - call print("do_fake cp2k calc calculation") - call do_cp2k_calc_fake(at, f, e, do_calc_virial, args_str) - return - endif - - if (have_silica_potential) then - ! compute silicon_charge and oxygen_charge from silica_charge_transfer such that SiO2 is neutral - silicon_charge = silica_charge_transfer - oxygen_charge = -silicon_charge/2.0_dp - ! compute hydrogen_charge from silicon_charge and oxygen_charge such that Si(OH)_4 is neutral - hydrogen_charge = -(silicon_charge + 4.0_dp*oxygen_charge)/4.0_dp - end if - - if (trim(qmmm_link_type) /= 'IMOMM' .and. & - trim(qmmm_link_type) /= 'PSEUDO' .and. & - trim(qmmm_link_type) /= 'QM_KIND') then - RAISE_ERROR("Unknown value for qmmm_link_type "//trim(qmmm_link_type)//" - should be one of IMOMM, PSEUDO, QM_KIND", error) - end if - ! Link fixing across periodic boundaries only applies to IMOMM - qmmm_link_fix_pbc = qmmm_link_fix_pbc .and. trim(qmmm_link_type) == 'IMOMM' - - call print("do_cp2k_calc command line arguments") - call print(" Run_Type " // Run_Type) - call print(" use_buffer " // use_buffer) - call print(" run_suffix " // run_suffix) - call print(" cp2k_template_file " // cp2k_template_file) - call print(" qmmm_link_template_file " // link_template_file) - call print(" PSF_print " // PSF_print) - call print(" topology_suffix " // trim(topology_suffix)) - call print(" cp2k_program " // trim(cp2k_program)) - call print(" persistent " // persistent) - if (persistent) call print(" persistent_restart_interval " // persistent_restart_interval) - if (persistent) call print(" persistent_max_wait_time " // persistent_max_wait_time) - call print(" clean_up_files " // clean_up_files) - call print(" clean_up_keep_n " // clean_up_keep_n) - call print(" save_output_files " // save_output_files) - call print(" save_output_wfn_files " // save_output_wfn_files) - call print(" max_n_tries " // max_n_tries) - call print(" max_force_warning " // max_force_warning) - call print(" qm_vacuum " // qm_vacuum) - call print(" try_reuse_wfn " // try_reuse_wfn) - call print(' have_titania_potential '//have_titania_potential) - call print(' have_silica_potential '//have_silica_potential) - if(have_silica_potential) then - call print(' res_num_silica '//res_num_silica) - call print(' silica_add_23_body '//silica_add_23_body) - call print(' silica_pos_dep_charges '//silica_pos_dep_charges) - call print(' silica_charge_transfer '//silica_charge_transfer) - call print(' silicon_charge '//silicon_charge) - call print(' oxygen_charge '//oxygen_charge) - call print(' hydrogen_charge '//hydrogen_charge) - call print(' remove_Si_H_silica_bonds '//remove_Si_H_silica_bonds) - call print(' remove_Ti_H_titania_bonds '//remove_Ti_H_titania_bonds) - end if - call print(' auto_centre '//auto_centre) - call print(' centre_pos '//centre_pos) - call print(' cp2k_calc_fake '//cp2k_calc_fake) - call print(' form_bond '//form_bond) - call print(' break_bond '//break_bond) - call print(' qm_charges '//trim(calc_qm_charges)) - call print(' virial '//do_calc_virial) - call print(' force_run_dir_i '//force_run_dir_i) - call print(' tmp_run_dir_i '//tmp_run_dir_i) - call print(' MM_param_file '//trim(MM_param_filename)) - call print(' QM_potential_file '//trim(QM_pot_filename)) - call print(' QM_basis_file '//trim(QM_basis_filename)) - call print(' create_residue_labels '//create_residue_labels) - call print(' qmmm_link_type '//trim(qmmm_link_type)) - call print(' qmmm_link_qm_kind '//trim(qmmm_link_qm_kind)) - call print(' qmmm_link_n_electrons '//qmmm_link_n_electrons) - call print(' qmmm_same_lattice '//qmmm_same_lattice) - call print(' qmmm_use_mm_charges '//qmmm_use_mm_charges) - call print(' qmmm_link_fix_pbc '//qmmm_link_fix_pbc) - call print(' do_mom_cons '//do_mom_cons) - call print(' verbosity '//trim(verbosity)) - - if (auto_centre .and. has_centre_pos) then - RAISE_ERROR("do_cp2k_calc got both auto_centre and centre_pos, don't know which centre (automatic or specified) to shift to origin", error) - endif - - if (tmp_run_dir_i>0 .and. clean_up_keep_n > 0) then - RAISE_ERROR("do_cp2k_calc got both tmp_run_dir_i(only write on /tmp) and clean_up_keep_n (save in home).",error) - endif - call system_timer('do_cp2k_calc/init') - - proj='quip' - - persistent_already_started=.false. - - call system_timer('do_cp2k_calc/run_dir') - !create run directory now, because it is needed if running on /tmp - if (tmp_run_dir_i>0) then - if (persistent) then - RAISE_ERROR("Can't do persistent and temp_run_dir_i > 0", error) - endif - tmp_run_dir = "/tmp/cp2k_run_"//tmp_run_dir_i - run_dir = link_run_directory(trim(tmp_run_dir), basename="cp2k_run", run_dir_i=run_dir_i) - !and copy necessary files for access on /tmp if not yet present - if (len_trim(MM_param_filename)>0) then - tmp_MM_param_filename = trim(MM_param_filename) - truncate_parent_dir=.true. - do while(truncate_parent_dir) - if (tmp_MM_param_filename(1:3)=="../") then - tmp_MM_param_filename=trim(tmp_MM_param_filename(4:)) - else - truncate_parent_dir=.false. - endif - enddo - if (len_trim(tmp_MM_param_filename)==0) then - RAISE_ERROR("Empty tmp_MM_param_filename string",error) - endif - call print("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(tmp_MM_param_filename)//" ] ; then echo 'copy charmm.pot' ; cp "//trim(MM_param_filename)//" "//trim(tmp_run_dir)//"/ ; else echo 'reuse charmm.pot' ; fi") - call system_command("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(tmp_MM_param_filename)//" ] ; then echo 'copy charmm.pot' ; cp "//trim(MM_param_filename)//" "//trim(tmp_run_dir)//"/ ; fi",status=stat) - if ( stat /= 0 ) then - RAISE_ERROR("Something went wrong when tried to copy "//trim(MM_param_filename)//" into the tmp dir "//trim(tmp_run_dir), error) - endif - endif - if (len_trim(QM_pot_filename)>0) then - tmp_QM_pot_filename = trim(QM_pot_filename) - truncate_parent_dir=.true. - do while(truncate_parent_dir) - if (tmp_QM_pot_filename(1:3)=="../") then - tmp_QM_pot_filename=trim(tmp_QM_pot_filename(4:)) - else - truncate_parent_dir=.false. - endif - enddo - call print("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(QM_pot_filename)//" ] ; then cp "//trim(QM_pot_filename)//" "//trim(tmp_run_dir)//"/ ; fi") - call system_command("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(tmp_QM_pot_filename)//" ] ; then echo 'copy QM potential' ; cp "//trim(QM_pot_filename)//" "//trim(tmp_run_dir)//"/ ; fi") - if ( stat /= 0 ) then - RAISE_ERROR("Something went wrong when tried to copy "//trim(QM_pot_filename)//" into the tmp dir "//trim(tmp_run_dir),error) - endif - endif - if (len_trim(QM_basis_filename)>0) then - tmp_QM_basis_filename = trim(QM_basis_filename) - truncate_parent_dir=.true. - do while(truncate_parent_dir) - if (tmp_QM_basis_filename(1:3)=="../") then - tmp_QM_basis_filename=trim(tmp_QM_basis_filename(4:)) - else - truncate_parent_dir=.false. - endif - enddo - call print("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(QM_basis_filename)//" ] ; then cp "//trim(QM_basis_filename)//" "//trim(tmp_run_dir)//"/ ; fi") - call system_command("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(tmp_QM_basis_filename)//" ] ; then echo 'copy QM basis' ; cp "//trim(QM_basis_filename)//" "//trim(tmp_run_dir)//"/ ; fi") - if ( stat /= 0 ) then - RAISE_ERROR("Something went wrong when tried to copy "//trim(QM_basis_filename)//" into the tmp dir "//trim(tmp_run_dir),error) - endif - endif - else ! not tmp - if (persistent) then - if (.not. persistent_already_started) then - call system_command("mkdir -p cp2k_run_0") - endif - force_run_dir_i=0 - endif - run_dir = make_run_directory("cp2k_run", force_run_dir_i, run_dir_i) - endif ! tmp_run_dir - call system_timer('do_cp2k_calc/run_dir') - - if (persistent) then - call system_timer('do_cp2k_calc/get_persistent_i') - inquire(file="persistent_run_i", exist=persistent_already_started) - - if (.not. persistent_already_started) then - persistent_run_i=1 - persistent_start_cp2k=.true. - else - persistent_start_cp2k=.false. - call initialise(persistent_run_i_io, "persistent_run_i", INPUT) - l = read_line(persistent_run_i_io) - call finalise(persistent_run_i_io) - read (unit=l, fmt=*, iostat=stat) persistent_run_i - if (stat /= 0) then - RAISE_ERROR("Failed to read persistent_run_i from 'persistent_run_i' file", error) - endif - persistent_run_i = persistent_run_i + 1 - - if (persistent_run_i > persistent_restart_interval) then - ! reset counters - persistent_run_i=1 - persistent_start_cp2k=.true. - ! tell running process to stop - call initialise(persistent_traj_io, trim(run_dir)//'/quip.persistent.traj.xyz',OUTPUT,append=.false.) - call print ("0", file=persistent_traj_io) - call finalise(persistent_traj_io) - call initialise(persistent_cell_file_io, trim(run_dir)//'/REFTRAJ_READY', OUTPUT, append=.false.) - call print("go",file=persistent_cell_file_io) - call finalise(persistent_cell_file_io) - ! wait - call fusleep(5000000) - ! clean up files - call system_command('cd '//trim(run_dir)//'; rm -f '//& - 'quip.persistent.traj.* '// & - trim(proj)//'-frc-1_[0-9]*.xyz '// & - trim(proj)//'-pos-1_[0-9]*.xyz '// & - trim(proj)//'-qmcharges--1_[0-9]*.mulliken '// & - trim(proj)//'-stress-1_[0-9]*.stress_tensor '// & - 'REFTRAJ_READY') - endif - endif - - call initialise(persistent_run_i_io, "persistent_run_i", OUTPUT) - call print(""//persistent_run_i, file=persistent_run_i_io, verbosity=PRINT_ALWAYS) - call finalise(persistent_run_i_io) - call system_timer('do_cp2k_calc/get_persistent_i') - else - persistent_run_i = 0 - endif - - call system_timer('do_cp2k_calc/copy_templ') - if (.not. persistent_already_started) then - ! read template file - if (tmp_run_dir_i>0) then - call print("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(cp2k_template_file)//" ] ; then cp "//trim(cp2k_template_file)//" "//trim(tmp_run_dir)//"/ ; fi") - call system_command("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(cp2k_template_file)//" ] ; then cp "//trim(cp2k_template_file)//" "//trim(tmp_run_dir)//"/ ; fi") - if ( stat /= 0 ) then - RAISE_ERROR("Something went wrong when tried to copy "//trim(cp2k_template_file)//" into the tmp dir "//trim(tmp_run_dir), error) - endif - call system("cp "//trim(cp2k_template_file)//" "//trim(tmp_run_dir)//"/cp2k_input.inp") - else - call system("cp "//trim(cp2k_template_file)//" "//trim(run_dir)//"/cp2k_input.inp") - endif - - endif - call system_timer('do_cp2k_calc/copy_templ') - - if ( (trim(psf_print) /= 'NO_PSF') .and. & - (trim(psf_print) /= 'DRIVER_PRINT_AND_SAVE') .and. & - (trim(psf_print) /= 'USE_EXISTING_PSF')) then - RAISE_ERROR("Unknown value for psf_print '"//trim(psf_print)//"'", error) - endif - - ! parse run_type - use_QM = .false. - use_MM = .false. - use_QMMM = .false. - select case(trim(run_type)) - case("QS") - use_QM=.true. - method="QS" - case("MM") - use_MM=.true. - method="Fist" - case("QMMM") - use_QM = .true. - use_MM = .true. - use_QMMM = .true. - method="QMMM" - case default - RAISE_ERROR("Unknown run_type "//trim(run_type),error) - end select - - call system_timer('do_cp2k_calc/calc_connect') - ! prepare CHARMM params if necessary - if (use_MM) then - if (have_silica_potential) then - call set_cutoff(at,SILICA_2body_CUTOFF) - call calc_connect(at) - elseif (have_titania_potential) then - call set_cutoff(at,TITANIA_2body_CUTOFF) - call calc_connect(at) - else - ! use hysteretic connect to get nearest neighbour cutoff - call calc_connect_hysteretic(at, DEFAULT_NNEIGHTOL, DEFAULT_NNEIGHTOL) - endif - call map_into_cell(at) - call calc_dists(at) - endif - call system_timer('do_cp2k_calc/calc_connect') - - call system_timer('do_cp2k_calc/make_psf') - ! if writing PSF file, calculate residue labels, before sort - if (run_type /= "QS") then - if (trim(psf_print) == "DRIVER_PRINT_AND_SAVE" .and. create_residue_labels) then - if (persistent_already_started) then - RAISE_ERROR("Trying to rewrite PSF file with persistent_already_started. Can't change connectivity during persistent cp2k run", error) - endif - call create_residue_labels_arb_pos(at,do_CHARMM=.true.,intrares_impropers=intrares_impropers, & - find_silica_residue=have_silica_potential,form_bond=form_bond,break_bond=break_bond, & - silica_pos_dep_charges=silica_pos_dep_charges, silica_charge_transfer=silica_charge_transfer, & - have_titania_potential=have_titania_potential, remove_Si_H_silica_bonds=remove_Si_H_silica_bonds, & - remove_Ti_H_titania_bonds=remove_Ti_H_titania_bonds) - end if - end if - - if (trim(run_type) == 'QMMM' .and. trim(qmmm_link_type) == "QM_KIND") then - if (trim(qmmm_link_qm_kind) == '') then - RAISE_ERROR("qmmm_link_type == QM_KIND, but qmmm_link_qm_kind not specified", error) - end if - - ! If we remove the QM-MM link bonds then QM and MM regions will be disconnected. - ! We need to make QM region a separate molecule so that CP2K doesn't complain - ! about discontigous molecules. - - call assign_property_pointer(at, 'cluster_mark'//trim(run_suffix), cluster_mark_p, error=error) - PASS_ERROR(error) - call assign_property_pointer(at, 'mol_id', mol_id_p, error=error) - PASS_ERROR(error) - qm_mol_id = maxval(mol_id_p) + 1 - do i=1,at%n - if (cluster_mark_p(i) /= HYBRID_NO_MARK) mol_id_p(i) = qm_mol_id - end do - end if - - call do_cp2k_atoms_sort(at, sort_index_p, rev_sort_index, psf_print, topology_suffix, & - tmp_run_dir, tmp_run_dir_i, form_bond, break_bond, intrares_impropers, & - use_MM, have_silica_potential, have_titania_potential, error=error) - PASS_ERROR_WITH_INFO("Failed to sort atoms in do_cp2k_calc", error) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - allocate(qm_list_a(0), old_qm_list_a(0)) - allocate(link_list_a(0)) - allocate(old_link_list_a(0)) - allocate(qm_and_link_list_a(0)) - if (use_QMMM) then - call get_qm_list(at, use_buffer, trim(run_suffix), trim(link_template_file), qm_list, old_qm_list, qm_list_a, old_qm_list_a, & - link_list_a, old_link_list_a, qm_and_link_list_a, rev_sort_index, cut_bonds, cut_bonds_p, old_cut_bonds, old_cut_bonds_p, & - link_template_a, link_template_n_lines, qmmm_link_type, qmmm_link_qm_kind_z, error) - PASS_ERROR(error) - endif - - if (qm_list%N == at%N) then - call print("WARNING: requested '"//trim(run_type)//"' but all atoms are in QM region, doing full QM run instead", PRINT_ALWAYS) - run_type='QS' - use_QM = .true. - use_MM = .false. - use_QMMM = .false. - method = 'QS' - endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! write PSF file, if requested - if (run_type /= "QS") then - if (trim(psf_print) == "DRIVER_PRINT_AND_SAVE") then - ! we should fail for persistent_already_started=T, but this should have been dealt with above - if (has_property(at, 'avgpos')) then - call write_psf_file_arb_pos(at, "quip_cp2k"//trim(topology_suffix)//".psf", run_type_string=trim(run_type),intrares_impropers=intrares_impropers, & - add_silica_23body=have_silica_potential .and. silica_add_23_body, form_bond=form_bond,break_bond=break_bond, & - remove_qmmm_link_bonds=trim(qmmm_link_type) == 'QM_KIND', run_suffix=run_suffix) - else if (has_property(at, 'pos')) then - call print("WARNING: do_cp2k_calc using pos for connectivity. avgpos is preferred but not found.") - call write_psf_file_arb_pos(at, "quip_cp2k"//trim(topology_suffix)//".psf", run_type_string=trim(run_type),intrares_impropers=intrares_impropers, & - add_silica_23body=have_silica_potential .and. silica_add_23_body, pos_field_for_connectivity='pos', & - form_bond=form_bond,break_bond=break_bond, remove_qmmm_link_bonds=trim(qmmm_link_type) == 'QM_KIND', run_suffix=run_suffix) - else - RAISE_ERROR("do_cp2k_calc needs some pos field for connectivity (run_type='"//trim(run_type)//"' /= 'QS'), but found neither avgpos nor pos", error) - endif - ! write sort order - call initialise(rev_sort_index_io, "quip_rev_sort_index"//trim(topology_suffix), action=OUTPUT) - call print(rev_sort_index, file=rev_sort_index_io) - call finalise(rev_sort_index_io) - endif - endif - call system_timer('do_cp2k_calc/make_psf') - - call system_timer('do_cp2k_calc/centre_cell') - if (auto_centre) then - if (qm_list%N > 0) then - centre_pos = pbc_aware_centre(at%pos(:,qm_list_a), at%lattice, at%g) - else - centre_pos = pbc_aware_centre(at%pos, at%lattice, at%g) - endif - call print("centering got automatic center " // centre_pos, PRINT_VERBOSE) - endif - ! move specified centre to origin (centre is already 0 if not specified) - at%pos(1,:) = at%pos(1,:) - centre_pos(1) - at%pos(2,:) = at%pos(2,:) - centre_pos(2) - at%pos(3,:) = at%pos(3,:) - centre_pos(3) - ! move origin into center of CP2K box (0.5 0.5 0.5 lattice coords) - call map_into_cell(at) - - if (.not. get_value(at%params, 'Periodic', at_periodic)) at_periodic = .true. - if (.not. at_periodic) then - cp2k_box_centre_pos(1:3) = 0.5_dp*sum(at%lattice,2) - at%pos(1,:) = at%pos(1,:) + cp2k_box_centre_pos(1) - at%pos(2,:) = at%pos(2,:) + cp2k_box_centre_pos(2) - at%pos(3,:) = at%pos(3,:) + cp2k_box_centre_pos(3) - endif - call system_timer('do_cp2k_calc/centre_cell') - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call system_timer('do_cp2k_calc/write_cp2k_input') - if (.not. persistent_already_started) then - call initialise(cp2k_input_io, trim(run_dir)//'/cp2k_input.inp.header',OUTPUT,append=.true.) - - if (do_calc_virial) then - call print("@SET DO_STRESS 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - else - call print("@SET DO_STRESS 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - - if (use_QM) then - call print("@SET DO_DFT 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - else - call print("@SET DO_DFT 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - if (use_MM) then - call print("@SET DO_MM 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - else - call print("@SET DO_MM 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - if (use_QMMM) then - call print("@SET DO_QMMM 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - else - call print("@SET DO_QMMM 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - - ! set variables having to do with periodic configs - insert_pos = 0 - if (at_periodic) then - call print("@SET PERIODIC XYZ", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - else - call print("@SET PERIODIC NONE", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - call print("@SET CELL_SIZE_INT_1 "//int(norm(at%lattice(:,1))), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET CELL_SIZE_INT_2 "//int(norm(at%lattice(:,2))), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET CELL_SIZE_INT_3 "//int(norm(at%lattice(:,3))), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET CELL_SIZE_INT_ODD_1 "//(int(norm(at%lattice(:,1))/2)*2+1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET CELL_SIZE_INT_ODD_2 "//(int(norm(at%lattice(:,2))/2)*2+1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET CELL_SIZE_INT_ODD_3 "//(int(norm(at%lattice(:,3))/2)*2+1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET MAX_CELL_SIZE_INT "//int(max(norm(at%lattice(:,1)),norm(at%lattice(:,2)), norm(at%lattice(:,3)))), & - file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET MAX_CELL_SIZE_INT_ODD "//(int(max(norm(at%lattice(:,1)),norm(at%lattice(:,2)), norm(at%lattice(:,3)))/2)*2+1), & - file=cp2k_input_io, verbosity=PRINT_ALWAYS) - - ! put in method - call print("@SET FORCE_EVAL_METHOD "//trim(method), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - - can_reuse_wfn = .true. - - call print("@SET DO_QMMM_LINK 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET QMMM_QM_KIND_FILE no_such_file", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - ! put in things needed for QMMM - if (use_QMMM) then - - call print('INFO: The size of the QM cell is either the MM cell itself, or it will have at least '//(qm_vacuum/2.0_dp)// & - ' Angstrom around the QM atoms.') - call print('WARNING! Please check if your cell is centreed around the QM region!',PRINT_ALWAYS) - call print('WARNING! CP2K centreing algorithm fails if QM atoms are not all in the',PRINT_ALWAYS) - call print('WARNING! 0,0,0 cell. If you have checked it, please ignore this message.',PRINT_ALWAYS) - if (qmmm_same_lattice) then - if (.not. at%is_orthorhombic) then - RAISE_ERROR("qmmm_same_lattice=T but original at%lattice is not orthorhombic", error) - end if - cur_qmmm_qm_abc(1) = at%lattice(1,1) - cur_qmmm_qm_abc(2) = at%lattice(2,2) - cur_qmmm_qm_abc(3) = at%lattice(3,3) - else - cur_qmmm_qm_abc = qmmm_qm_abc(at, qm_list_a, qm_vacuum) - end if - call print("@SET QMMM_ABC_X "//cur_qmmm_qm_abc(1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET QMMM_ABC_Y "//cur_qmmm_qm_abc(2), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET QMMM_ABC_Z "//cur_qmmm_qm_abc(3), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET QMMM_PERIODIC XYZ", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - - if (get_value(at%params, "QM_cell"//trim(run_suffix), old_qmmm_qm_abc)) then - if (cur_qmmm_qm_abc .fne. old_qmmm_qm_abc) can_reuse_wfn = .false. - else - can_reuse_wfn = .false. - endif - call set_value(at%params, "QM_cell"//trim(run_suffix), cur_qmmm_qm_abc) - call print('set_value QM_cell'//trim(run_suffix)//' '//cur_qmmm_qm_abc) - - ! check if QM list changed: compare cluster_mark and old_cluster_mark[_suffix] - ! if no old_cluster_mark, assumed it's changed just to be safe - qm_list_changed = .false. - if (.not.has_property(at, 'cluster_mark'//trim(run_suffix))) then - RAISE_ERROR('no cluster_mark'//trim(run_suffix)//' found in atoms object',error) - endif - if (.not.has_property(at, 'old_cluster_mark'//trim(run_suffix))) then - qm_list_changed = .true. - endif - dummy = assign_pointer(at, 'cluster_mark'//trim(run_suffix), cluster_mark_p) - - if (.not. qm_list_changed) then - dummy = assign_pointer(at, 'old_cluster_mark'//trim(run_suffix), old_cluster_mark_p) - do i=1,at%N - if (old_cluster_mark_p(i) /= cluster_mark_p(i)) then ! mark changed. Does it matter? - if (use_buffer) then ! EXTENDED, check for transitions to/from HYBRID_NO_MARK - if (any((/old_cluster_mark_p(i),cluster_mark_p(i)/) == HYBRID_NO_MARK)) qm_list_changed = .true. - else ! CORE, check for transitions between ACTIVE/TRANS and other - if ( ( any(old_cluster_mark_p(i) == (/ HYBRID_ACTIVE_MARK, HYBRID_TRANS_MARK /)) .and. & - all(cluster_mark_p(i) /= (/ HYBRID_ACTIVE_MARK, HYBRID_TRANS_MARK /)) ) .or. & - ( any(cluster_mark_p(i) == (/ HYBRID_ACTIVE_MARK, HYBRID_TRANS_MARK /)) .and. & - all(old_cluster_mark_p(i) /= (/ HYBRID_ACTIVE_MARK, HYBRID_TRANS_MARK /)) ) ) qm_list_changed = .true. - endif - if (qm_list_changed) exit - endif - enddo - endif - call set_value(at%params,'QM_list_changed',qm_list_changed) - call print('set_value QM_list_changed '//qm_list_changed) - - if (qm_list_changed) can_reuse_wfn = .false. - - call initialise(cp2k_input_tmp_io, trim(run_dir)//'/cp2k_input.qmmm_qm_kind',OUTPUT) - call print("@SET QMMM_QM_KIND_FILE cp2k_input.qmmm_qm_kind", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - !Add QM atoms - counter = 0 - if (trim(qmmm_link_type) == "QM_KIND") then - ! get unique list of inner link atoms - these are the atoms at boundary of QM region - call uniq(cut_bonds%int(1,1:cut_bonds%N), inner_link_list_a) - call print("&QM_KIND "//trim(qmmm_link_qm_kind), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - do i=1,size(inner_link_list_a) - if (at%z(inner_link_list_a(i)) /= qmmm_link_qm_kind_z) then - RAISE_ERROR("QM_KIND boundary atom "//inner_link_list_a(i)//" has atomic number Z="//at%z(inner_link_list_a(i))//" != qmmm_link_qm_kind_z="//qmmm_link_qm_kind_z, error) - end if - call print(" MM_INDEX "//inner_link_list_a(i), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - counter = counter + 1 - end do - call print("&END QM_KIND", file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - deallocate(inner_link_list_a) - end if - do at_Z=minval(at%Z), maxval(at%Z) - if (any(at%Z(qm_list_a) == at_Z)) then - call print("&QM_KIND "//trim(ElementName(at_Z)), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - do i=1, size(qm_list_a) - if (at%Z(qm_list_a(i)) == at_Z) then - if (trim(qmmm_link_type) == "QM_KIND") then - ! skip inner link atoms - if (is_in_array(cut_bonds%int(1,1:cut_bonds%N), qm_list_a(i))) cycle - end if - call print(" MM_INDEX "//qm_list_a(i), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - counter = counter + 1 - endif - end do - call print("&END QM_KIND", file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - end if - end do - call finalise(cp2k_input_tmp_io) - if (size(qm_list_a) /= counter) then - RAISE_ERROR("Number of QM list atoms " // size(qm_list_a) // " doesn't match number of QM_KIND atoms " // counter,error) - endif - - !Add link sections from template file for each link - if (size(link_list_a).gt.0 .and. trim(qmmm_link_type) /= "QM_KIND") then - call print("@SET DO_QMMM_LINK 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET QMMM_LINK_FILE cp2k_input.link", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call initialise(cp2k_input_tmp_io, trim(run_dir)//'/cp2k_input.link',OUTPUT) - do i=1,cut_bonds%N - i_inner = cut_bonds%int(1,i) - i_outer = cut_bonds%int(2,i) - do i_line=1,link_template_n_lines - call print(trim(link_template_a(i_line)), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - if (i_line == 1) then - call print("MM_INDEX "//i_outer, file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - call print("QM_INDEX "//i_inner, file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - endif - enddo - enddo - call finalise(cp2k_input_tmp_io) - - ! check if set of cut bonds has changed - qmmm_link_list_changed = .false. - if (cut_bonds%N > 0 .and. old_cut_bonds%N > 0) then - do i=1,at%N - if (any(cut_bonds_p(:,i) /= old_cut_bonds_p(:,i))) then - qmmm_link_list_changed = .true. - exit - end if - end do - if (qmmm_link_list_changed) can_reuse_wfn = .false. - end if - - endif ! size(link_list_a) > 0 - endif ! use_QMMM - - call print("@SET WFN_FILE_NAME no_such_file", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET DO_DFT_LSD 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET DO_DFT_QM_CHARGES 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - ! put in things needed for QM - if (use_QM) then - - if (trim(qmmm_link_type) == "QM_KIND") then - old_n_hydrogen = 0 - n_hydrogen = 0 - old_n_extra_electrons = qmmm_link_n_electrons*old_cut_bonds%N - n_extra_electrons = qmmm_link_n_electrons*cut_bonds%N - else - old_n_hydrogen = old_cut_bonds%N - n_hydrogen = cut_bonds%N - old_n_extra_electrons = 0 - n_extra_electrons = 0 - end if - - call calc_charge_lsd(at, old_qm_list_a, old_charge, old_do_lsd, n_hydrogen=old_n_hydrogen, & - hydrogen_charge=hydrogen_charge, n_extra_electrons=old_n_extra_electrons, & - use_mm_charges=qmmm_use_mm_charges, error=error) - PASS_ERROR(error) - call calc_charge_lsd(at, qm_list_a, charge, do_lsd, n_hydrogen=n_hydrogen, & - hydrogen_charge=hydrogen_charge, n_extra_electrons=n_extra_electrons, & - use_mm_charges=qmmm_use_mm_charges, error=error) - PASS_ERROR(error) - - if (old_charge /= charge) can_reuse_wfn = .false. - if (old_do_lsd .neqv. do_lsd) can_reuse_wfn = .false. - call print('Setting DFT charge to '//charge//' and LSD to '//do_lsd) - call print("@SET DFT_CHARGE "//charge, file=cp2k_input_io, verbosity=PRINT_ALWAYS) - if (do_lsd) then - call print("@SET DO_DFT_LSD 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - if (len_trim(calc_qm_charges) > 0) then - call print("@SET DO_DFT_QM_CHARGES 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - if (try_reuse_wfn .and. can_reuse_wfn) then - call print('Reusing wavefunction from last time') - if (persistent) then - call print("@SET WFN_FILE_NAME quip-RESTART.wfn", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - else - call print("@SET WFN_FILE_NAME ../wfn.restart.wfn"//trim(run_suffix), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - !insert_pos = find_make_cp2k_input_section(cp2k_template_a, template_n_lines, "&FORCE_EVAL&DFT", "&SCF") - !call insert_cp2k_input_line(cp2k_template_a, "&FORCE_EVAL&DFT&SCF SCF_GUESS RESTART", after_line = insert_pos, n_l = template_n_lines); insert_pos = insert_pos + 1 - endif - endif ! use_QM - - if (have_silica_potential .and. .not. silica_pos_dep_charges) then - call print("@SET SIO_CHARGE "//silicon_charge, file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET OSB_CHARGE "//oxygen_charge, file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET HSI_CHARGE "//hydrogen_charge, file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET OSTAR_CORE_CORRECTION "//(1.0_dp - silicon_charge/4.0_dp), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - end if - - ! put in unit cell - call print("@SET SUBSYS_CELL_A_X "//at%lattice(1,1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET SUBSYS_CELL_A_Y "//at%lattice(2,1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET SUBSYS_CELL_A_Z "//at%lattice(3,1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET SUBSYS_CELL_B_X "//at%lattice(1,2), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET SUBSYS_CELL_B_Y "//at%lattice(2,2), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET SUBSYS_CELL_B_Z "//at%lattice(3,2), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET SUBSYS_CELL_C_X "//at%lattice(1,3), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET SUBSYS_CELL_C_Y "//at%lattice(2,3), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET SUBSYS_CELL_C_Z "//at%lattice(3,3), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - - ! put in topology - call print("@SET ISOLATED_ATOMS_FILE cp2k_input.isolated_atoms", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call initialise(cp2k_input_tmp_io, trim(run_dir)//'/cp2k_input.isolated_atoms',OUTPUT) - if (use_QMMM) then - do i=1, size(qm_list_a) - call print("LIST " // qm_list_a(i), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - end do - endif - if (assign_pointer(at, "isolated_atom", isolated_atom)) then - do i=1, at%N - if (isolated_atom(i) /= 0) then - call print("LIST " // qm_list_a(i), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) - endif - end do - endif - call finalise(cp2k_input_tmp_io) - - call print("@SET COORD_FILE quip_cp2k.xyz", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET COORD_FORMAT XYZ", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - if (trim(psf_print) == "DRIVER_PRINT_AND_SAVE" .or. trim(psf_print) == "USE_EXISTING_PSF") then - call print("@SET USE_PSF 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - if (tmp_run_dir_i>0) then - call system_command("if [ ! -s "//trim(tmp_run_dir)//"/quip_cp2k"//trim(topology_suffix)//".psf ] ; then cp quip_cp2k"//trim(topology_suffix)//".psf /tmp/cp2k_run_"//tmp_run_dir_i//"/ ; fi",status=stat) - if ( stat /= 0 ) then - RAISE_ERROR("Something went wrong when tried to copy quip_cp2k"//trim(topology_suffix)//".psf into the tmp dir "//trim(tmp_run_dir),error) - endif - call print("@SET CONN_FILE quip_cp2k"//trim(topology_suffix)//".psf", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - - else - call print("@SET CONN_FILE ../quip_cp2k"//trim(topology_suffix)//".psf", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - call print("@SET CONN_FORMAT PSF", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - else - call print("@SET USE_PSF 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - - ! put in global stuff to run a single force evalution, print out appropriate things - call print("@SET QUIP_PROJECT "//trim(proj), file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET QUIP_RUN_TYPE MD", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - - call print("@SET FORCES_FORMAT XMOL", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET PERSISTENT_TRAJ_FILE no_such_file", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET PERSISTENT_CELL_FILE no_such_file", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - if (persistent) then - call print("@SET QUIP_ENSEMBLE REFTRAJ", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET QUIP_N_STEPS 100000000", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET PERSISTENT_TRAJ_FILE quip.persistent.traj.xyz", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET PERSISTENT_CELL_FILE quip.persistent.traj.cell", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - else - call print("@SET QUIP_ENSEMBLE NVE", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - call print("@SET QUIP_N_STEPS 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) - endif - - call finalise(cp2k_input_io) - endif - call system_timer('do_cp2k_calc/write_cp2k_input') -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call system_timer('do_cp2k_calc/write_xyz') - if (at_periodic .and. size(link_list_a) > 0 .and. qmmm_link_fix_pbc) then - ! correct position of OUTER atoms so no links cross a periodic boundary since - ! if they did, CP2K would place terminating hydrogens incorrectly - - do i=1,cut_bonds%N - i_inner = cut_bonds%int(1,i) - i_outer = cut_bonds%int(2,i) - - disp = diff_min_image(at, i_inner, i_outer, shift=shift) - if (any(shift /= 0)) then - call print('Unwrapping QM/MM link '//i_inner//'-'//i_outer//' by shift '//shift) - at%pos(:,i_outer) = at%pos(:,i_outer) + (at%lattice .mult. shift) - end if - end do - endif - - ! prepare xyz file for input to cp2k - if (persistent) then - ! write cell file - call initialise(persistent_cell_file_io, trim(run_dir)//'/quip.persistent.traj.cell', OUTPUT, append=.false.) - call print("0 0.0 "//at%lattice(:,1)//" "//at%lattice(:,2)//" "//at%lattice(:,3)//" "//cell_volume(at), file=persistent_cell_file_io, verbosity=PRINT_ALWAYS) - call finalise(persistent_cell_file_io) - ! write traj file - call write(at, trim(run_dir)//'/quip.persistent.traj.xyz', append=.false., properties='species:pos') - ! write initial config if needed - if (.not. persistent_already_started) & - call write(at, trim(run_dir)//'/quip_cp2k.xyz', properties='species:pos') - ! touch REFTRAJ_READY FILE - call initialise(persistent_cell_file_io, trim(run_dir)//'/REFTRAJ_READY', OUTPUT, append=.true.) - call print("go",file=persistent_cell_file_io) - call finalise(persistent_cell_file_io) - else - call write(at, trim(run_dir)//'/quip_cp2k.xyz', properties='species:pos') - endif - call system_timer('do_cp2k_calc/write_xyz') - - ! actually run cp2k - if (persistent) then - call system_timer('do_cp2k_calc/run_cp2k') - if (persistent_start_cp2k) then - call start_cp2k_program_background(trim(cp2k_program), trim(run_dir), error=error) - PASS_ERROR(error) - endif - wait_time = 0.0_dp - do while(.true.) - inquire(file=trim(run_dir)//"/"//trim(proj)//"-frc-1_"//persistent_run_i//".xyz", exist=persistent_frc_exists) - if (persistent_frc_exists) then - ! inquire(file=trim(run_dir)//"/"//trim(proj)//"-frc-1_"//persistent_run_i//".xyz", size=persistent_frc_size) - persistent_frc_size = ffsize(trim(run_dir)//"/"//trim(proj)//"-frc-1_"//persistent_run_i//".xyz") - if (persistent_frc_size > 0) then ! got data, leave - call fusleep(1000000) - exit - else if (persistent_frc_size < 0) then ! error - RAISE_ERROR("Failed to get valid value from ffsize of "//trim(run_dir)//"/"//trim(proj)//"-frc-1_"//persistent_run_i//".xyz", error) - endif - endif - call fusleep(100000) - wait_time = wait_time + 100000_dp/1.0e6_dp - if (wait_time > persistent_max_wait_time) then - RAISE_ERROR("Failed to get forces after waiting at least "//persistent_max_wait_time//" s", error) - endif - end do ! waiting for frc file - call system_timer('do_cp2k_calc/run_cp2k') - call system_timer('do_cp2k_calc/read_output') - if (trim(qmmm_link_type) == 'QM_KIND') then - call read_output(at, qm_list_a, cur_qmmm_qm_abc, trim(run_dir), trim(proj), e, f, trim(calc_qm_charges), & - do_calc_virial, save_reordering_index=.false., out_i=persistent_run_i, error=error) - else - call read_output(at, qm_and_link_list_a, cur_qmmm_qm_abc, trim(run_dir), trim(proj), e, f, trim(calc_qm_charges), & - do_calc_virial, save_reordering_index=.false., out_i=persistent_run_i, error=error) - end if - PASS_ERROR(error) - call system_timer('do_cp2k_calc/read_output') - else ! not persistent - call system_timer('do_cp2k_calc/run_cp2k') - call run_cp2k_program(trim(cp2k_program), trim(run_dir), max_n_tries, error=error) - PASS_ERROR(error) - call system_timer('do_cp2k_calc/run_cp2k') - call system_timer('do_cp2k_calc/read_output') - if (trim(qmmm_link_type) == 'QM_KIND') then - call read_output(at, qm_list_a, cur_qmmm_qm_abc, trim(run_dir), trim(proj), e, f, trim(calc_qm_charges), & - do_calc_virial, save_reordering_index=.false., out_i=persistent_run_i, error=error) - else - call read_output(at, qm_and_link_list_a, cur_qmmm_qm_abc, trim(run_dir), trim(proj), e, f, trim(calc_qm_charges), & - do_calc_virial, save_reordering_index=.false., out_i=persistent_run_i, error=error) - end if - PASS_ERROR(error) - call system_timer('do_cp2k_calc/read_output') - endif - - call system_timer('do_cp2k_calc/process_output') - at%pos(1,:) = at%pos(1,:) + centre_pos(1) - cp2k_box_centre_pos(1) - at%pos(2,:) = at%pos(2,:) + centre_pos(2) - cp2k_box_centre_pos(2) - at%pos(3,:) = at%pos(3,:) + centre_pos(3) - cp2k_box_centre_pos(3) - call map_into_cell(at) - - ! unsort - if (associated(sort_index_p)) then - f(:,sort_index_p(:)) = f(:,:) - call atoms_sort(at, 'sort_index', error=error) - PASS_ERROR_WITH_INFO("do_cp2k_calc sorting atoms by sort_index",error) - endif - - if (maxval(abs(f)) > max_force_warning) & - call print('WARNING cp2k forces max component ' // maxval(abs(f)) // ' at ' // maxloc(abs(f)) // & - ' exceeds warning threshold ' // max_force_warning, PRINT_ALWAYS) - - if(do_mom_cons) call sum0(f) - - ! save output - - if (use_QM) then - call system_command('cp '//trim(run_dir)//'/quip-RESTART.wfn wfn.restart.wfn'//trim(run_suffix)) - if (save_output_wfn_files) then - call system_command('cp '//trim(run_dir)//'/quip-RESTART.wfn run_'//run_dir_i//'_end.wfn.restart.wfn'//trim(run_suffix)) - endif - endif - - if (save_output_files) then - if (persistent) then - log_sys_command_str=' if [ ! -f cp2k_input_log ]; then cat '//trim(run_dir)//'/cp2k_input.inp >> cp2k_input_log; echo "##############" >> cp2k_input_log; fi;' // & - ' cat filepot.0.xyz >> cp2k_driver_in_log.xyz;' // & - ' cat '//trim(run_dir)//'/'//trim(proj)//'-frc-1_'//persistent_run_i//'.xyz'// ' >> cp2k_force_file_log;' - if (do_calc_virial) then - log_sys_command_str = trim(log_sys_command_str) //' cat '//trim(run_dir)//'/'//trim(proj)//'-stress-1_'//persistent_run_i//'.stress_tensor'// ' >> cp2k_stress_file_log' - endif - else - log_sys_command_str= ' cat '//trim(run_dir)//'/cp2k_input.inp >> cp2k_input_log; echo "##############" >> cp2k_input_log;' // & - ' cat '//trim(run_dir)//'/cp2k_output.out >> cp2k_output_log; echo "##############" >> cp2k_output_log;' // & - ' cat filepot.xyz >> cp2k_driver_in_log.xyz;' // & - ' cat '//trim(run_dir)//'/'//trim(proj)//'-frc-1_0.xyz'// ' >> cp2k_force_file_log;' - if (do_calc_virial) then - log_sys_command_str = trim(log_sys_command_str) // ' cat '//trim(run_dir)//'/'//trim(proj)//'-stress-1_0.stress_tensor'// ' >> cp2k_stress_file_log' - endif - endif - call system_command(trim(log_sys_command_str)) - endif - call system_timer('do_cp2k_calc/process_output') - - ! clean up - call system_timer('do_cp2k_calc/cleanup') - if (tmp_run_dir_i>0) then - if (clean_up_files) then - !only delete files that need recreating, keep basis, potentials, psf - call system_command('rm -f '//trim(tmp_run_dir)//"/"//trim(proj)//"-* "//trim(tmp_run_dir)//"/cp2k_input.inp "//trim(tmp_run_dir)//"/cp2k_output.out "//trim(run_dir)) - else !save dir - exists = .true. - i = 0 - do while (exists) - i = i + 1 - dir = "cp2k_run_saved_"//i - call system_command("bash -c '[ -e "//trim(dir)//" ]'", status=stat) - exists = (stat == 0) - end do - call system_command("cp -r "//trim(run_dir)//" "//trim(dir), status=stat) - if (stat /= 0) then - RAISE_ERROR("Failed to copy "//trim(run_dir)//" to "//trim(dir)//" status " // stat, error) - endif - call system_command('rm -f '//trim(tmp_run_dir)//"/* "//trim(run_dir)) - endif - else - if (clean_up_files) then - if (clean_up_keep_n <= 0) then ! never keep any old directories around - call system_command('rm -rf '//trim(run_dir)) - else ! keep some (>= 1) old directories around - delete_dir_i = mod(run_dir_i, clean_up_keep_n+1)+1 - call system_command('rm -rf cp2k_run_'//delete_dir_i) - endif - endif - endif - if (allocated(rev_sort_index)) deallocate(rev_sort_index) - call system_timer('do_cp2k_calc/cleanup') - call system_timer('do_cp2k_calc') - - call verbosity_pop() - - end subroutine do_cp2k_calc - - subroutine do_cp2k_atoms_sort(at, sort_index_p, rev_sort_index, psf_print, topology_suffix, & - tmp_run_dir, tmp_run_dir_i, form_bond, break_bond, intrares_impropers, & - use_MM, have_silica_potential, have_titania_potential, error) - type(Atoms), intent(inout) :: at - integer, intent(out), pointer :: sort_index_p(:) - integer, intent(inout), allocatable :: rev_sort_index(:) - character(len=*), intent(in) :: psf_print - character(len=*), intent(in) :: topology_suffix - character(len=*), intent(in) :: tmp_run_dir - integer, intent(in) :: tmp_run_dir_i - integer :: form_bond(2), break_bond(2) - type(Table), intent(inout) :: intrares_impropers - logical, intent(in) :: use_MM, have_silica_potential, have_titania_potential - integer, optional, intent(out) :: error - - logical :: sorted - integer, pointer :: saved_rev_sort_index_p(:) - type(inoutput) :: rev_sort_index_io - integer :: at_i, iri_i - integer :: stat - - ! sort by molecule, residue ID - call add_property(at, 'sort_index', 0, n_cols=1, ptr=sort_index_p, error=error) - PASS_ERROR_WITH_INFO("Failed to add sort_index property", error) - ! initialise sort index - do at_i=1, at%N - sort_index_p(at_i) = at_i - end do - - ! do sort by read in order or labels - sorted = .false. - if (trim(psf_print) == 'USE_EXISTING_PSF') then ! read sort order - ! add property for saved reverse sort indx - call add_property(at, 'saved_rev_sort_index', 0, n_cols=1, ptr=saved_rev_sort_index_p, error=error) - PASS_ERROR_WITH_INFO("Failed to add saved_rev_sort_index property", error) - ! read it from file - if (tmp_run_dir_i>0) then - call system_command("if [ ! -s "//trim(tmp_run_dir)//"/quip_rev_sort_index"//trim(topology_suffix)// & - " ] ; then cp quip_rev_sort_index"//trim(topology_suffix)//" /tmp/cp2k_run_"//tmp_run_dir_i//"/ ; fi",status=stat) - if ( stat /= 0 ) then - RAISE_ERROR("Something went wrong when tried to copy quip_rev_sort_index"//trim(topology_suffix)//" into the tmp dir "//trim(tmp_run_dir),error) - endif - call initialise(rev_sort_index_io, trim(tmp_run_dir)//"/quip_rev_sort_index"//trim(topology_suffix), action=INPUT) - else - call initialise(rev_sort_index_io, "quip_rev_sort_index"//trim(topology_suffix), action=INPUT) - endif - call read_ascii(rev_sort_index_io, saved_rev_sort_index_p) - call finalise(rev_sort_index_io) - ! sort by it - call atoms_sort(at, 'saved_rev_sort_index', error=error) - PASS_ERROR_WITH_INFO ("do_cp2k_calc sorting atoms by read-in sort_index from quip_sort_order"//trim(topology_suffix), error) - sorted = .true. - endif - if (trim(psf_print) == 'DRIVER_PRINT_AND_SAVE') then ! sort by labels - if (has_property(at,'mol_id') .and. has_property(at,'atom_res_number')) then - if (has_property(at,'motif_atom_num')) then - call atoms_sort(at, 'mol_id', 'atom_res_number', 'motif_atom_num', error=error) - else - call atoms_sort(at, 'mol_id', 'atom_res_number', error=error) - endif - PASS_ERROR_WITH_INFO ("do_cp2k_calc sorting atoms by mol_id, atom_res_number, and motif_atom_num", error) - sorted = .true. - endif - endif - - if (allocated(rev_sort_index)) deallocate(rev_sort_index) - allocate(rev_sort_index(at%N)) - do at_i=1, at%N - rev_sort_index(sort_index_p(at_i)) = at_i - end do - - if (sorted) then - do at_i=1, at%N - if (sort_index_p(at_i) /= at_i) then - call print("sort() of at%data reordered some atoms") - exit - endif - end do - ! fix EVB bond forming/breaking indices for new sorted atom numbers - if (use_MM) then - if (have_silica_potential) then - call set_cutoff(at,SILICA_2body_CUTOFF) - call calc_connect(at) - elseif (have_titania_potential) then - call set_cutoff(at,TITANIA_2body_CUTOFF) - call calc_connect(at) - else - ! use hysteretic connect to get nearest neighbour cutoff - call calc_connect_hysteretic(at, DEFAULT_NNEIGHTOL, DEFAULT_NNEIGHTOL) - endif - call map_into_cell(at) - call calc_dists(at) - endif - - if ((all(form_bond > 0) .and. all(form_bond <= at%N)) .or. (all(break_bond > 0) .and. all(break_bond <= at%N))) then - if (all(form_bond > 0) .and. all(form_bond <= at%N)) form_bond(:) = rev_sort_index(form_bond(:)) - if (all(break_bond > 0) .and. all(break_bond <= at%N)) break_bond(:) = rev_sort_index(break_bond(:)) - end if - ! fix intrares impropers atom indices for new sorted atom numbers - do iri_i=1, intrares_impropers%N - intrares_impropers%int(1:4,iri_i) = rev_sort_index(intrares_impropers%int(1:4,iri_i)) - end do - else - call print("WARNING: didn't do sort_by_molecule - need saved sort_index or mol_id, atom_res_number, motif_atom_num. CP2K may complain", PRINT_ALWAYS) - end if - - end subroutine do_cp2k_atoms_sort - - subroutine read_output(at, qm_list_a, cur_qmmm_qm_abc, run_dir, proj, e, f, calc_qm_charges, do_calc_virial, & - save_reordering_index, out_i, error) - type(Atoms), intent(inout) :: at - integer, intent(in) :: qm_list_a(:) - real(dp), intent(in) :: cur_qmmm_qm_abc(3) - character(len=*), intent(in) :: run_dir, proj - real(dp), intent(out) :: e, f(:,:) - real(dp), pointer :: force_p(:,:) - character(len=*) :: calc_qm_charges - logical :: do_calc_virial, save_reordering_index - integer, intent(in), optional :: out_i - integer, intent(out), optional :: error - - integer, pointer :: reordering_index_p(:) - real(dp), pointer :: qm_charges_p(:) - real(dp) :: at_population, at_net_charge - type(Atoms) :: f_xyz, p_xyz - integer :: m - integer :: i, at_i - type(inoutput) :: t_io - character(len=STRING_LENGTH) :: at_species, t_line - integer :: at_kind - integer :: use_out_i - real(dp) :: virial(3,3) - character :: tx, ty, tz - integer :: istat - - INIT_ERROR(error) - - use_out_i = optional_default(0, out_i) - - call read(f_xyz, trim(run_dir)//'/'//trim(proj)//'-frc-1_'//use_out_i//'.xyz') - call read(p_xyz, trim(run_dir)//'/'//trim(proj)//'-pos-1_'//use_out_i//'.xyz') - nullify(qm_charges_p) - if (len_trim(calc_qm_charges) > 0) then - if (.not. assign_pointer(at, trim(calc_qm_charges), qm_charges_p)) then - call add_property(at, trim(calc_qm_charges), 0.0_dp, ptr=qm_charges_p) - endif - call initialise(t_io, trim(run_dir)//'/'//trim(proj)//'-qmcharges--1_'//use_out_i//'.mulliken',action=INPUT, error=error) - PASS_ERROR_WITH_INFO("cp2k_driver read_output() failed to open qmcharges file", error) - t_line='' - do while (index(adjustl(t_line),"#") <= 0) - t_line = read_line(t_io) - end do - do i=1, at%N - t_line = read_line(t_io) - read (unit=t_line,fmt=*) at_i, at_species, at_kind, at_population, at_net_charge - qm_charges_p(i) = at_net_charge - end do - call finalise(t_io) - endif - if (do_calc_virial) then - call initialise(t_io, trim(run_dir)//'/'//trim(proj)//'-stress-1_'//use_out_i//'.stress_tensor',action=INPUT, error=error) - PASS_ERROR_WITH_INFO("cp2k_driver failed to read cp2k stress_tensor file", error) - tx='' - ty='' - tz='' - ! look for line with just 'X Y Z' - t_line=read_line(t_io) - read(unit=t_line, fmt=*, iostat=istat) tx, ty, tz - do while (istat /= 0 .or. tx /= 'X' .or. ty /= 'Y' .or. tz /= 'Z') - t_line=read_line(t_io) - read(unit=t_line, fmt=*, iostat=istat) tx, ty, tz - end do - ! now let's ready stress - t_line=read_line(t_io) - read(unit=t_line, fmt=*, iostat=istat) tx, virial(1,1), virial(1,2), virial(1,3) - if (istat /= 0) then - RAISE_ERROR("cp2k_driver failed to read virial(1,:)", error) - endif - t_line=read_line(t_io) - read(unit=t_line, fmt=*, iostat=istat) tx, virial(2,1), virial(2,2), virial(2,3) - if (istat /= 0) then - RAISE_ERROR("cp2k_driver failed to read virial(2,:)", error) - endif - t_line=read_line(t_io) - read(unit=t_line, fmt=*, iostat=istat) tx, virial(3,1), virial(3,2), virial(3,3) - if (istat /= 0) then - RAISE_ERROR("cp2k_driver failed to read virial(3,:)", error) - endif - call print("got cp2k stress(1,:) "//virial(1,:)) - call print("got cp2k stress(2,:) "//virial(2,:)) - call print("got cp2k stress(3,:) "//virial(3,:)) - ! convert from stress GPa to virial in native units - virial = cell_volume(at)*virial/EV_A3_IN_GPA - call set_value(at%params, 'virial', virial) - call finalise(t_io) - endif - - if (.not. get_value(f_xyz%params, "E", e)) then - RAISE_ERROR('read_output failed to find E value in '//trim(run_dir)//'/'//trim(proj)//'-frc-1_'//use_out_i//'.xyz file', error) - endif - - if (.not.(assign_pointer(f_xyz, 'frc', force_p))) then - RAISE_ERROR("Did not find frc property in "//trim(run_dir)//'/'//trim(proj)//'-frc-1_'//use_out_i//'.xyz file', error) - endif - f = force_p - - nullify(reordering_index_p) - if (save_reordering_index) then - if (.not. assign_pointer(at, "reordering_index", reordering_index_p)) then - call add_property(at, "reordering_index", 0, ptr=reordering_index_p) - endif - end if - - e = e * HARTREE - f = f * HARTREE/BOHR - call reorder_if_necessary(at, qm_list_a, cur_qmmm_qm_abc, p_xyz%pos, f, qm_charges_p, & - reordering_index_p, error=error) - PASS_ERROR_WITH_INFO("cp2k_driver read_output failed to reorder atmos", error) - - call print('') - call print('The energy of the system: '//e) - call verbosity_push_decrement() - call print('The forces acting on each atom (eV/A):') - call print('atom F(x) F(y) F(z)') - do m=1,size(f,2) - call print(' '//m//' '//f(1,m)//' '//f(2,m)//' '//f(3,m)) - enddo - call verbosity_pop() - call print('Sum of the forces: '//sum(f,2)) - - end subroutine read_output - - subroutine reorder_if_necessary(at, qm_list_a, qmmm_qm_abc, new_p, new_f, qm_charges_p, & - reordering_index_p, error) - type(Atoms), intent(in) :: at - integer, intent(in) :: qm_list_a(:) - real(dp), intent(in) :: qmmm_qm_abc(3) - real(dp), intent(in) :: new_p(:,:) - real(dp), intent(inout) :: new_f(:,:) - real(dp), intent(inout), pointer :: qm_charges_p(:) - integer, intent(out), pointer :: reordering_index_p(:) - integer, optional, intent(out) :: error - - real(dp) :: shift(3) - integer, allocatable :: reordering_index(:) - integer :: i - - INIT_ERROR(error) - - ! shifted cell in case of QMMM (cp2k/src/topology_coordinate_util.F) - shift = 0.0_dp - if (size(qm_list_a) > 0) then - do i=1,3 - shift(i) = 0.5_dp * qmmm_qm_abc(i) - (minval(at%pos(i,qm_list_a)) + maxval(at%pos(i,qm_list_a)))*0.5_dp - end do - endif - allocate(reordering_index(at%N)) - call print('trying to reorder with shift='//shift) - call system_timer('reorder_if_necessary/check_reordering_1') - call check_reordering(at%pos, shift, new_p, at%g, reordering_index) - call system_timer('reorder_if_necessary/check_reordering_1') - if (any(reordering_index == 0)) then - ! try again with shift of a/2 b/2 c/2 in case TOPOLOGY%CENTER_COORDINATES is set - shift = sum(at%lattice(:,:),2)/2.0_dp - & - (minval(at%pos(:,:),2)+maxval(at%pos(:,:),2))/2.0_dp - call print('trying to reorder with shift='//shift) - call system_timer('reorder_if_necessary/check_reordering_2') - call check_reordering(at%pos, shift, new_p, at%g, reordering_index) - call system_timer('reorder_if_necessary/check_reordering_2') - if (any(reordering_index == 0)) then - ! try again with uniform shift (module periodic cell) - shift = new_p(:,1) - at%pos(:,1) - call print('trying to reorder with shift='//shift) - call system_timer('reorder_if_necessary/check_reordering_3') - call check_reordering(at%pos, shift, new_p, at%g, reordering_index) - call system_timer('reorder_if_necessary/check_reordering_3') - if (any(reordering_index == 0)) then - RAISE_ERROR("Could not match original and read in atom objects",error) - endif - endif - endif - - do i=1, at%N - if (reordering_index(i) /= i) then - call print("WARNING: reorder_if_necessary indeed found reordered atoms", PRINT_ALWAYS) - exit - endif - end do - - if (associated(reordering_index_p)) then - if (size(reordering_index_p) < size(reordering_index)) then - RAISE_ERROR("save_reordering_index too small", error) - end if - reordering_index_p(1:size(reordering_index)) = reordering_index - end if - - new_f(1,reordering_index(:)) = new_f(1,:) - new_f(2,reordering_index(:)) = new_f(2,:) - new_f(3,reordering_index(:)) = new_f(3,:) - if (associated(qm_charges_p)) then - qm_charges_p(reordering_index(:)) = qm_charges_p(:) - endif - - deallocate(reordering_index) - end subroutine reorder_if_necessary - - subroutine check_reordering(old_p, shift, new_p, recip_lattice, reordering_index) - real(dp), intent(in) :: old_p(:,:), shift(3), new_p(:,:), recip_lattice(3,3) - integer, intent(out) :: reordering_index(:) - - integer :: N, i, j - real(dp) :: dpos(3), dpos_i(3) - - N = size(old_p,2) - - reordering_index = 0 - do i=1, N - ! check for same-order - j = i - dpos = matmul(recip_lattice(1:3,1:3), old_p(1:3,i) + shift(1:3) - new_p(1:3,j)) - dpos_i = nint(dpos) - if (all(abs(dpos-dpos_i) <= 1.0e-4_dp)) then - reordering_index(i) = j - else ! not same order, search - do j=1, N - dpos = matmul(recip_lattice(1:3,1:3), old_p(1:3,i) + shift(1:3) - new_p(1:3,j)) - dpos_i = nint(dpos) - if (all(abs(dpos-dpos_i) <= 1.0e-4_dp)) then - reordering_index(i) = j - exit - endif - end do - end if - end do - end subroutine check_reordering - - subroutine start_cp2k_program_background(cp2k_program, run_dir, error) - character(len=*), intent(in) :: cp2k_program, run_dir - integer, optional, intent(out) :: error - - character(len=STRING_LENGTH) :: cp2k_run_command - integer :: stat - - INIT_ERROR(error) - - cp2k_run_command = 'cd ' // trim(run_dir)//'; '//trim(cp2k_program)//' cp2k_input.inp >> cp2k_output.out &' - call print("Doing '"//trim(cp2k_run_command)//"'") - call system_command(trim(cp2k_run_command), status=stat) - if (stat /= 0) then - RAISE_ERROR("failed to start cp2k program in the background", error) - endif - end subroutine start_cp2k_program_background - - subroutine run_cp2k_program(cp2k_program, run_dir, max_n_tries, error) - character(len=*), intent(in) :: cp2k_program, run_dir - integer, intent(in) :: max_n_tries - integer, optional, intent(out) :: error - - integer :: n_tries - logical :: converged - character(len=STRING_LENGTH) :: cp2k_run_command - integer :: stat, stat2, error_stat - - INIT_ERROR(error) - - n_tries = 0 - converged = .false. - - do while (.not. converged .and. (n_tries < max_n_tries)) - n_tries = n_tries + 1 - - cp2k_run_command = 'cd ' // trim(run_dir)//'; '//trim(cp2k_program)//' cp2k_input.inp >> cp2k_output.out 2>&1' - call print("Doing '"//trim(cp2k_run_command)//"'") - call system_timer('cp2k_run_command') - call system_command(trim(cp2k_run_command), status=stat) - call system_timer('cp2k_run_command') - call print('grep -i warning '//trim(run_dir)//'/cp2k_output.out', PRINT_ALWAYS) - call system_command("fgrep -i 'warning' "//trim(run_dir)//"/cp2k_output.out") - call system_command("fgrep -i 'error' "//trim(run_dir)//"/cp2k_output.out", status=error_stat) - if (stat /= 0) then - ! RAISE_ERROR('cp2k_run_command has non zero return status ' // stat //'. check output file '//trim(run_dir)//'/cp2k_output.out', error) - call print('WARNING: cp2k_run_command has non zero return status ' // stat //'. check output file '//trim(run_dir)//'/cp2k_output.out', error) - endif - if (error_stat == 0) then - ! RAISE_ERROR('cp2k_run_command generated ERROR message in output file '//trim(run_dir)//'/cp2k_output.out', error) - call print('WARNING: cp2k_run_command generated ERROR message in output file '//trim(run_dir)//'/cp2k_output.out', error) - endif - - call system_command('egrep "QS" '//trim(run_dir)//'/cp2k_output.out',status=stat) - if (stat == 0) then ! QS or QMMM run - call system_command('grep "FAILED to converge" '//trim(run_dir)//'/cp2k_output.out',status=stat) - if (stat == 0) then - call print("WARNING: cp2k_driver failed to converge, trying again",PRINT_ALWAYS) - converged = .false. - else - call system_command('grep "outer SCF loop converged" '//trim(run_dir)//'/cp2k_output.out',status=stat) ! OT mode - call system_command('grep "SCF run converged" '//trim(run_dir)//'/cp2k_output.out',status=stat2) ! density mixing mode - if (stat == 0 .or. stat2 == 0) then - converged = .true. - else - call print("WARNING: cp2k_driver couldn't find definitive sign of convergence or failure to converge in output file, trying again",PRINT_ALWAYS) - converged = .false. - endif - end if - else ! MM run - converged = .true. - endif - end do - - if (.not. converged) then - RAISE_ERROR('cp2k failed to converge after n_tries='//n_tries//'. see output file '//trim(run_dir)//'/cp2k_output.out',error) - endif - - end subroutine run_cp2k_program - - function qmmm_qm_abc(at, qm_list_a, qm_vacuum) - type(Atoms), intent(in) :: at - integer, intent(in) :: qm_list_a(:) - real(dp), intent(in) :: qm_vacuum - real(dp) :: qmmm_qm_abc(3) - - real(dp) :: qm_maxdist(3) - integer i, j - - qm_maxdist = 0.0_dp - do i=1, size(qm_list_a) - do j=1, size(qm_list_a) - qm_maxdist(1) = max(qm_maxdist(1), at%pos(1,qm_list_a(i))-at%pos(1,qm_list_a(j))) - qm_maxdist(2) = max(qm_maxdist(2), at%pos(2,qm_list_a(i))-at%pos(2,qm_list_a(j))) - qm_maxdist(3) = max(qm_maxdist(3), at%pos(3,qm_list_a(i))-at%pos(3,qm_list_a(j))) - end do - end do - - qmmm_qm_abc(1) = min(real(ceiling(qm_maxdist(1)))+qm_vacuum,at%lattice(1,1)) - qmmm_qm_abc(2) = min(real(ceiling(qm_maxdist(2)))+qm_vacuum,at%lattice(2,2)) - qmmm_qm_abc(3) = min(real(ceiling(qm_maxdist(3)))+qm_vacuum,at%lattice(3,3)) - - end function qmmm_qm_abc - - subroutine calc_charge_lsd(at, qm_list_a, charge, do_lsd, n_hydrogen, hydrogen_charge, & - n_extra_electrons, use_mm_charges, error) - type(Atoms), intent(in) :: at - integer, intent(in) :: qm_list_a(:) - integer, intent(out) :: charge - logical, intent(out) :: do_lsd - integer, intent(in) :: n_hydrogen - real(dp), intent(in) :: hydrogen_charge - integer, intent(in) :: n_extra_electrons - logical, intent(in) :: use_mm_charges - integer, intent(out), optional :: error - - real(dp), pointer :: atom_charge(:) - integer, pointer :: Z_p(:) - integer :: sum_Z - integer :: l_error - real(dp) :: sum_charge - - INIT_ERROR(error) - - if (.not. assign_pointer(at, "Z", Z_p)) then - RAISE_ERROR("calc_charge_lsd could not find Z property", error) - endif - - if (size(qm_list_a) > 0) then - if (.not. assign_pointer(at, "atom_charge", atom_charge)) then - RAISE_ERROR("calc_charge_lsd could not find atom_charge", error) - endif - sum_charge = 0.0_dp - if (use_mm_charges) then - sum_charge = sum(atom_charge(qm_list_a)) - end if - call print('sum_charge before correction = '//sum_charge) - if (use_mm_charges) then - call print('n_hydrogen = '//n_hydrogen//', n_extra_electrons = '//n_extra_electrons) - sum_charge = sum_charge + n_hydrogen*hydrogen_charge ! terminating hydrogens - end if - sum_charge = sum_charge - n_extra_electrons - call print('sum_charge = '//sum_charge) - charge = nint(sum_charge) - - !check if we have an odd number of electrons - sum_Z = sum(Z_p(qm_list_a(1:size(qm_list_a)))) - sum_Z = sum_Z + n_hydrogen ! include terminating hydrogens - call print('sum_Z = '//sum_Z) - do_lsd = (mod(sum_Z-charge,2) /= 0) - else - sum_Z = sum(Z_p) - do_lsd = .false. - charge = 0 - call get_param_value(at, 'LSD', do_lsd, error=l_error) ! ignore error - CLEAR_ERROR(error) - !if charge is saved, also check if we have an odd number of electrons - call get_param_value(at, 'Charge', charge, error=l_error) - CLEAR_ERROR(error) - if (l_error == 0) then - call print("Using Charge " // charge) - do_lsd = do_lsd .or. (mod(sum_Z-charge,2) /= 0) - else !charge=0 is assumed by CP2K - do_lsd = do_lsd .or. (mod(sum_Z,2) /= 0) - endif - if (do_lsd) call print("Using do_lsd " // do_lsd) - endif - - end subroutine calc_charge_lsd - - subroutine do_cp2k_calc_fake(at, f, e, do_calc_virial, args_str, error) - type(Atoms), intent(inout) :: at - real(dp), intent(out) :: f(:,:), e - logical, intent(in) :: do_calc_virial - character(len=*), intent(in) :: args_str - integer, intent(out), optional :: error - - type(inoutput) :: last_run_io - type(inoutput) :: stress_io - type(cinoutput) :: force_cio - character(len=STRING_LENGTH) :: last_run_s - integer :: this_run_i - integer :: stat - type(Atoms) :: for - real(dp), pointer :: frc(:,:) - - integer :: cur_i - character(len=1024) :: l - character t_s - real(dp) :: virial(3,3) - logical :: got_virial - - INIT_ERROR(error) - - call initialise(last_run_io, "cp2k_driver_fake_run", action=INPUT) - last_run_s = read_line(last_run_io, status=stat) - call finalise(last_run_io) - if (stat /= 0) then - this_run_i = 1 - else - read (fmt=*,unit=last_run_s) this_run_i - this_run_i = this_run_i + 1 - endif - - call print("do_cp2k_calc_fake run_i " // this_run_i, PRINT_ALWAYS) - - call initialise(force_cio, "cp2k_force_file_log") - call read(force_cio, for, frame=this_run_i-1) - !NB why does this crash now? - ! call finalise(force_cio) - if (.not. assign_pointer(for, 'frc', frc)) then - RAISE_ERROR("do_cp2k_calc_fake couldn't find frc field in force log file",error) - endif - f = frc - - if (.not. get_value(for%params, "energy", e)) then - if (.not. get_value(for%params, "Energy", e)) then - if (.not. get_value(for%params, "E", e)) then - RAISE_ERROR("do_cp2k_calc_fake didn't find energy",error) - endif - endif - endif - - if (do_calc_virial) then - call initialise(stress_io, "cp2k_stress_file_log", action=INPUT) - got_virial=.false. - cur_i=0 - do while (.not. got_virial) - l=read_line(stress_io, status=stat) - if (stat /= 0) exit - if (index(trim(l), "STRESS TENSOR [GPa]") > 0) then - cur_i=cur_i + 1 - endif - if (cur_i == this_run_i) then - if (index(trim(l), 'X') > 0 .and. index(trim(l), 'Y') <= 0) read(unit=l, fmt=*) t_s, virial(1,1), virial(1,2), virial(1,3) - if (index(trim(l), 'Y') > 0 .and. index(trim(l), 'X') <= 0) read(unit=l, fmt=*) t_s, virial(2,1), virial(2,2), virial(2,3) - if (index(trim(l), 'Z') > 0 .and. index(trim(l), 'Y') <= 0) then - read(unit=l, fmt=*) t_s, virial(3,1), virial(3,2), virial(3,3) - got_virial=.true. - endif - endif - end do - if (.not. got_virial) then - RAISE_ERROR("do_cp2k_calc_fake got do_calc_virial but couldn't read virial for config "//this_run_i//" from cp2k_stress_file_log",error) - endif - call print("got cp2k stress(1,:) "//virial(1,:)) - call print("got cp2k stress(2,:) "//virial(2,:)) - call print("got cp2k stress(3,:) "//virial(3,:)) - virial = cell_volume(at)*virial/EV_A3_IN_GPA - call set_value(at%params, 'virial', virial) - call finalise(stress_io) - endif - - e = e * HARTREE - f = f * HARTREE/BOHR - - call initialise(last_run_io, "cp2k_driver_fake_run", action=OUTPUT) - call print(""//this_run_i, file=last_run_io) - call finalise(last_run_io) - - end subroutine do_cp2k_calc_fake - - - subroutine get_qm_list(at, use_buffer, run_suffix, link_template_file, qm_list, old_qm_list, qm_list_a, old_qm_list_a, & - link_list_a, old_link_list_a, qm_and_link_list_a, rev_sort_index, cut_bonds, cut_bonds_p, old_cut_bonds, old_cut_bonds_p, & - link_template_a, link_template_n_lines, qmmm_link_type, qmmm_link_qm_kind_z, error) - type(Atoms), intent(inout) :: at - logical, intent(in) :: use_buffer - character(len=*), intent(in) :: run_suffix, link_template_file, qmmm_link_type - type(Table), intent(inout) :: qm_list, old_qm_list - integer, allocatable, intent(inout) :: qm_list_a(:), old_qm_list_a(:), link_list_a(:), old_link_list_a(:), qm_and_link_list_a(:) - integer, intent(in) :: rev_sort_index(:) - type(Table), intent(inout) :: cut_bonds, old_cut_bonds - integer, pointer, intent(inout) :: cut_bonds_p(:,:), old_cut_bonds_p(:,:) - character(len=STRING_LENGTH), allocatable, intent(inout) :: link_template_a(:) - integer, intent(inout) :: link_template_n_lines - integer, intent(in) :: qmmm_link_qm_kind_z - integer, intent(out), optional :: error - - integer :: i_inner, i_outer, j - type(Inoutput) :: link_template_io - - INIT_ERROR(error) - - ! get qm_list and link_list - if (use_buffer) then - call get_hybrid_list(at, qm_list, all_but_term=.true.,int_property="cluster_mark"//trim(run_suffix)) - call get_hybrid_list(at, old_qm_list, all_but_term=.true.,int_property="old_cluster_mark"//trim(run_suffix)) - else - call get_hybrid_list(at, qm_list, active_trans_only=.true.,int_property="cluster_mark"//trim(run_suffix)) - call get_hybrid_list(at, old_qm_list, active_trans_only=.true.,int_property="old_cluster_mark"//trim(run_suffix)) - endif - if (allocated(qm_list_a)) deallocate(qm_list_a) - if (allocated(old_qm_list_a)) deallocate(old_qm_list_a) - if (allocated(link_list_a)) deallocate(link_list_a) - if (allocated(old_link_list_a)) deallocate(old_link_list_a) - if (allocated(qm_and_link_list_a)) deallocate(qm_and_link_list_a) - allocate(qm_list_a(qm_list%N), old_qm_list_a(old_qm_list%N)) - if (qm_list%N > 0) qm_list_a = int_part(qm_list,1) - if (old_qm_list%N > 0) old_qm_list_a = int_part(old_qm_list,1) - !get link list - - if (assign_pointer(at,'cut_bonds'//trim(run_suffix),cut_bonds_p)) then - call initialise(cut_bonds,2,0,0,0,0) - do i_inner=1,at%N - do j=1,size(cut_bonds_p,1) !MAX_CUT_BONDS - if (cut_bonds_p(j,i_inner) == 0) exit - ! correct for new atom indices resulting from sorting of atoms - i_outer = rev_sort_index(cut_bonds_p(j,i_inner)) - - ! If we're doing QM_KIND linking, skip bonds which do not originate from the correct species - if (trim(qmmm_link_type) == "QM_KIND" .and. at%Z(i_inner) /= qmmm_link_qm_kind_z) cycle - call append(cut_bonds,(/i_inner,i_outer/)) - enddo - enddo - if (cut_bonds%N > 0) then - call uniq(cut_bonds%int(2,1:cut_bonds%N),link_list_a) - allocate(qm_and_link_list_a(size(qm_list_a)+size(link_list_a))) - qm_and_link_list_a(1:size(qm_list_a)) = qm_list_a(1:size(qm_list_a)) - qm_and_link_list_a(size(qm_list_a)+1:size(qm_list_a)+size(link_list_a)) = link_list_a(1:size(link_list_a)) - else - allocate(link_list_a(0)) - allocate(qm_and_link_list_a(size(qm_list_a))) - if (size(qm_list_a) > 0) qm_and_link_list_a = qm_list_a - endif - else - allocate(qm_and_link_list_a(size(qm_list_a))) - if (size(qm_list_a) > 0) qm_and_link_list_a = qm_list_a - endif - - call initialise(old_cut_bonds,2,0,0,0,0) - if(assign_pointer(at, 'old_cut_bonds'//trim(run_suffix), old_cut_bonds_p)) then - do i_inner=1,at%N - do j=1,size(old_cut_bonds_p,1) !MAX_CUT_BONDS - if (old_cut_bonds_p(j,i_inner) == 0) exit - ! correct for new atom indices resulting from sorting of atoms - i_outer = rev_sort_index(old_cut_bonds_p(j,i_inner)) - call append(old_cut_bonds,(/i_inner,i_outer/)) - enddo - enddo - end if - - !If needed, read QM/MM link_template_file - if (size(link_list_a) > 0 .and. trim(qmmm_link_type) /= "QM_KIND") then - if (trim(link_template_file).eq."") then - RAISE_ERROR("There are QM/MM links, but qmmm_link_template is not defined.",error) - endif - call initialise(link_template_io, trim(link_template_file), INPUT) - call read_file(link_template_io, link_template_a, link_template_n_lines) - call finalise(link_template_io) - end if - end subroutine get_qm_list - - - subroutine cp2k_state_change(at, to, from_list, ignore_failure, error) - type(Atoms), intent(inout) :: at - character(len=*), intent(in) :: to, from_list(:) - logical, optional, intent(in) :: ignore_failure - integer, optional, intent(out) :: error - - character(STRING_LENGTH) :: from - integer, pointer :: cluster_mark_from(:), cut_bonds_from(:,:), hybrid_mark_from(:) - integer i - real(dp) QM_cell(3) - logical found, do_ignore_failure - - INIT_ERROR(error) - do_ignore_failure = optional_default(.false., ignore_failure) - - found = .false. - do i=1, size(from_list) - if (assign_pointer(at, 'cluster_mark'//trim(from_list(i)), cluster_mark_from)) then - from = from_list(i) - found = .true. - exit - end if - end do - if (.not. do_ignore_failure .and. .not. found) then - RAISE_ERROR('cp2k_state_change cannot find any previous states in from_list', error) - end if - - call print('cp2k_state_change changing CP2K saved state from '//trim(from)//' to '//trim(to)) - call print('cp2k_state_change copying property cluster_mark'//trim(from)//' to cluster_mark'//trim(to)) - call add_property(at, 'cluster_mark'//trim(to), cluster_mark_from, overwrite=.true.) - if (.not. assign_pointer(at, 'cut_bonds'//trim(from), cut_bonds_from)) then - RAISE_ERROR('cp2k_state_change found cluster_mark'//trim(from)//'but not cut_bonds'//trim(from)//' - inconsistent!', error) - end if - call print('cp2k_state_change copying property cut_bonds'//trim(from)//' to cut_bonds'//trim(to)) - call add_property(at, 'cut_bonds'//trim(to), cut_bonds_from, overwrite=.true.) - if (get_value(at%params, 'QM_cell'//trim(from), QM_cell)) then - call print('cp2k_state_change set_value QM_cell'//trim(to)//' '//QM_cell) - call set_value(at%params, 'QM_cell'//trim(to), QM_cell) - end if - if (.not. assign_pointer(at, 'hybrid_mark'//trim(from), hybrid_mark_from)) then - RAISE_ERROR('cp2k_state_change found cluster_mark'//trim(from)//'but not hybrid_mark'//trim(from)//' - inconsistent!', error) - end if - call print('cp2k_state_change copying property hybrid_mark'//trim(from)//' to hybrid_mark'//trim(to)) - call add_property(at, 'hybrid_mark'//trim(to), hybrid_mark_from, overwrite=.true.) - call print('cp2k_state_change executing "if [ -f wfn.restart.wfn'//trim(from)//' ] ; then cp wfn.restart.wfn'//trim(from)//' wfn.restart.wfn'//trim(to)//' ; fi "') - call system_command('if [ -f wfn.restart.wfn'//trim(from)//' ] ; then cp wfn.restart.wfn'//trim(from)//' wfn.restart.wfn'//trim(to)//' ; fi') - - end subroutine cp2k_state_change - - !momentum conservation - ! weighing function: 1 (simply subtract sumF/n) - !?! weighing function: m (keeping same acceleration on the atoms) - subroutine sum0(force) - - real(dp), dimension(:,:), intent(inout) :: force - integer :: i - real(dp) :: sumF(3) - - do i = 1, size(force,2) - sumF(1) = sum(force(1,1:size(force,2))) - sumF(2) = sum(force(2,1:size(force,2))) - sumF(3) = sum(force(3,1:size(force,2))) - enddo - - if ((sumF(1).feq.0.0_dp).and.(sumF(2).feq.0.0_dp).and.(sumF(3).feq.0.0_dp)) then - call print('cp2k_driver: Sum of the forces are zero.') - return - endif - - call print('cp2k_driver: Sum of the forces was '//sumF(1:3)) - sumF = sumF / size(force,2) - - do i = 1, size(force,2) - force(1:3,i) = force(1:3,i) - sumF(1:3) - enddo - - do i = 1, size(force,2) - sumF(1) = sum(force(1,1:size(force,2))) - sumF(2) = sum(force(2,1:size(force,2))) - sumF(3) = sum(force(3,1:size(force,2))) - enddo - call print('cp2k_driver: Sum of the forces after mom.cons.: '//sumF(1:3)) - - end subroutine sum0 - - -end module cp2k_driver_module diff --git a/src/FilePot_drivers/cp2k_driver_old.f95 b/src/FilePot_drivers/cp2k_driver_old.f95 deleted file mode 100644 index 9f735c5149..0000000000 --- a/src/FilePot_drivers/cp2k_driver_old.f95 +++ /dev/null @@ -1,2708 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X cp2k_driver_module -!X -!% Old driver for CP2K code using a hardcoded input file, outdated -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!CP2K driver - -!to use external basis set or potential list add to atoms%params BASIS_SET_list=... or POTENTIAL_list=..., -! or pass to calc in args_str (see below) -!the format is for H and O (for example): -!2 !number of lines -!1 DZVP-GTH-BLYP !atomic number and basis set -!8 DZVP-GTH-BLYP -! -!arguments to be passed to go_cp2k in the args_str: -! Run_Type, default: 'MM', also understands 'QS', 'QMMM_CORE', and 'QMMM_EXTENDED' -! PSF_Print, default: 'NO_PSF', also understands 'CP2K_PRINT_AND_SAVE', 'DRIVER_PRINT_AND_SAVE', 'USE_EXISTING_PSF' -! cp2k_program, default:'cp2k.sopt' -! basis_set_file: default none, name of file (instead of atoms%params value BASIS_SET_list) -! potential_file: default none, name of file (instead of atoms%params value POTENTIAL_list) -! dft_file: default none, name of file -! cell_file: default none, name of file -! clean_up_files: default TRUE -! -!contains the following subroutines and functions: -! -!S param_initialise(this,at,run_type,cp2k_program,basis_set_file,potential_file,dft_file,cell_file,use_cubic_cell) -!S param_finalise(this) -!S create_centred_qmcore(my_atoms,R_inner,R_outer,origin,list_changed) -!S print_qm_region(at, file) -!S construct_buffer_origin(my_atoms,Radius,list,origin) -!S read_list_file(this,filename,basis_set,potential) -!S go_cp2k(my_atoms,forces,energy,args_str) -!F extend_qmlist(my_atoms,R_inner,R_outer) result(list_changed) -!S construct_buffer_RADIUS(my_atoms,core,radius,buffer,use_avgpos,verbosity) -!S get_qm_list_int(my_atoms,qmflag,qmlist) -!S get_qm_list_int_rec(my_atoms,qmflag,qmlist,do_recursive) -!S get_qm_list_array(my_atoms,qmflags,qmlist) -!F get_property(my_atoms,prop) result(prop_index) -!S read_qmlist(my_atoms,qmlistfilename,PRINT_verbose) -!F num_of_bonds(at) result(bonds) -!S check_neighbour_numbers(at) -!F check_list_change(old_list,new_list) result(list_changed) -!S write_cp2k_input_files(my_atoms,qm_list,param,run_type,PSF_print) -!S write_cp2k_input_file(my_atoms,qm_list,param,run_type,PSF_print) -!S read_cp2k_forces(forces,energy,param,my_atoms,run_type,PRINT_verbose) -!S read_convert_back_pos(forces,param,my_atoms,run_type,PRINT_verbose) -!S QUIP_combine_forces(qmmm_forces,mm_forces,combined_forces,my_atoms) -!S abrupt_force_mixing(qmmm_forces,mm_forces,combined_forces,my_atoms) -!F spline_force(at, i, my_spline, pot) result(force) -!S energy_conversion(energy) -!S force_conversion(force) -!S velocity_conversion(at) -!S velocity_conversion_rev(at) -!F real_feq2(x,y) result(feq) -!F matrix_feq2(matrix1,matrix2) result (feq) - -module cp2k_driver_module - -! use libatoms_module - - use atoms_module, only: atoms, initialise, finalise, & - read_xyz, add_property, & - map_into_cell, & - set_cutoff, set_cutoff_minimum, & - calc_connect, DEFAULT_NNEIGHTOL, & - distance_min_image, & - read_line, parse_line, & - assignment(=), atoms_n_neighbours, remove_bond, & - assign_pointer, print_xyz, atoms_neighbour, is_nearest_neighbour - use clusters_module, only: bfs_step,& - construct_hysteretic_region, & - !select_hysteretic_quantum_region, & - add_cut_hydrogens - use dictionary_module, only: dictionary, initialise, finalise, & - get_value, set_value, & - value_len, read_string - use linearalgebra_module, only: find_in_array, find, & - print, operator(.feq.), & - check_size - use paramreader_module, only: param_register, param_read_line, & - STRING_LENGTH - use periodictable_module, only: ElementName, ElementCovRad, ElementMass, total_elements - use structures_module, only: find_motif - use system_module, only: dp, inoutput, initialise, finalise, & - INPUT, OUTPUT, INOUT, & - system_timer, & - system_command, & - system_abort, & - optional_default, & - print, print_title, & - string_to_int, string_to_real, round, & - parse_string, read_line, & - operator(//), & - ERROR, PRINT_SILENT, PRINT_NORMAL, PRINT_VERBOSE, PRINT_NERD, PRINT_ANALYSIS, & - verbosity_push_decrement, verbosity_pop, current_verbosity, & - mainlog - use table_module, only: table, initialise, finalise, & - append, allocate, delete, & - int_part, TABLE_STRING_LENGTH, print - use topology_module, only: write_psf_file, create_CHARMM, & - delete_metal_connects, & - write_cp2k_pdb_file, & - NONE_RUN, QS_RUN, MM_RUN, & - QMMM_RUN_CORE, QMMM_RUN_EXTENDED - use units_module, only: HARTREE, BOHR, HBAR - -! use quantumselection_module - implicit none - - private :: param_initialise - private :: finalise -! private :: construct_buffer_RADIUS - private :: get_qm_list_array - private :: get_qm_list_int - private :: get_qm_list_int_rec - private :: read_cp2k_forces - private :: read_convert_back_pos - private :: real_feq2 - private :: matrix_feq2 - private :: write_cp2k_input_files - private :: write_cp2k_input_file -! private :: combine_forces - - public :: create_centred_qmcore, & - !extend_qmlist, & - check_list_change, & - num_of_bonds, & - get_qm_list, & - get_property, & - go_cp2k, & - read_qmlist, & - check_neighbour_numbers, & - QUIP_combine_forces, & - spline_force, & - energy_conversion, & - force_conversion, & - velocity_conversion, & - velocity_conversion_rev - -!parameters for Run_Type -! see in ../libAtoms/Topology.f95 -!parameters for PSF_Print - integer, parameter :: CP2K_PRINT_AND_SAVE = -1 - integer, parameter :: NO_PSF = 0 - integer, parameter :: DRIVER_PRINT_AND_SAVE = 1 - integer, parameter :: USE_EXISTING_PSF = 2 - - integer, parameter, private :: MAX_CHAR_LENGTH = 200 ! for the system_command - real(dp), parameter :: DEFAULT_QM_BUFFER_WIDTH = 4.5_dp - - real(dp), parameter :: EPSILON_ZERO = 1.e-8_dp !to check if xyz atoms equal - - type spline_pot - real(dp) :: from - real(dp) :: to - real(dp) :: dpot - end type spline_pot - -!!!!! ============================================================================================ !!!!! -!!!!! !!!!! -!!!!! \/ \/ \/ \/ \/ \/ ---------- parameters type to run CP2K ---------- \/ \/ \/ \/ \/ \/ !!!!! -!!!!! !!!!! -!!!!! ============================================================================================ !!!!! - - type param_dft_nml - character(len=value_len) :: file - real(dp) :: mgrid_cutoff != 300.0_dp - character(20) :: scf_guess != 'atomic' - character(20) :: xc_functional !!= 'BLYP' - end type param_dft_nml - - type param_mm_forcefield_nml - character(20) :: parmtype != 'CHM' - character(20) :: parm_file_name != 'charmm.pot' - real(dp) :: charge_OT != -0.834_dp - real(dp) :: charge_HT != 0.417_dp - end type param_mm_forcefield_nml - - type param_mm_ewald_nml - character(20) :: ewald_type != 'ewald' - real(dp) :: ewald_alpha != 0.44_dp - integer :: ewald_gmax != 25 - end type param_mm_ewald_nml - - type param_qmmm_nml - real(dp),dimension(3) :: qmmm_cell != (/8.0_dp,8.0_dp,8.0_dp/) - character(20) :: qmmm_cell_unit != 'ANGSTROM' - logical :: reuse_wfn - character(20) :: ecoupl != 'GAUSS' - real(dp) :: radius_H != 0.44_dp - real(dp) :: radius_O != 0.78_dp - real(dp) :: radius_C != 0.80_dp - real(dp) :: radius_N != 0.80_dp - real(dp) :: radius_S != 0.80_dp - real(dp) :: radius_Cl != 0.80_dp - real(dp) :: radius_Na != 0.80_dp - real(dp) :: radius_Si !=0.80_dp - end type param_qmmm_nml - - type param_global_nml - character(20) :: project != 'cp2k' - character(20) :: runtype != 'MD' - character(len=value_len) :: cell_file, global_file - end type param_global_nml - - type param_md_nml - character(20) :: ensemble != 'NVE' - integer :: steps != 0 - real(dp) :: timestep != 0.5_dp - real(dp) :: temperature != 300.0_dp - end type param_md_nml - - type working_env - character(80) :: working_directory !directory for temporary files used by cp2k - character(80) :: pdb_file - character(80) :: exyz_file - character(80) :: psf_file - character(80) :: wfn_file - character(80) :: cp2k_input_filename !='cp2k_input.inp' - character(80) :: force_file != 'cp2k-frc-1.xyz' - character(80) :: pos_file != 'cp2k-pos-1.xyz' - character(80) :: wrk_filename != 'wrk.dat' - character(800) :: cp2k_program != 'cp2k_serial' or 'cp2k_popt'. long, for possible long path - end type working_env - - type param_cp2k - - type(Dictionary) :: basis_set - type(Dictionary) :: potential - type(param_dft_nml) :: dft - type(param_mm_forcefield_nml) :: mm_forcefield - type(param_mm_ewald_nml) :: mm_ewald - type(param_qmmm_nml) :: qmmm - type(param_global_nml) :: global - type(param_md_nml) :: md - type(working_env) :: wenv - - integer :: N - logical :: initialised - - end type param_cp2k - - interface finalise - module procedure param_finalise - end interface finalise - - interface get_qm_list - module procedure get_qm_list_int, get_qm_list_int_rec, get_qm_list_array - end interface get_qm_list - -contains - - !!!!! ============================================================================================ !!!!! - !!!!! !!!!! - !!!!! \/ \/ \/ \/ \/ \/ ---------- initialise parameters to run CP2K ---------- \/ \/ \/ \/ \/ \/ !!!!! - !!!!! !!!!! - !!!!! ============================================================================================ !!!!! - - !% Initialise parameters to run CP2K: basis set; potential; DFT parameters; cell; global settings. - !% If these are empty, set some default. - ! - subroutine param_initialise(this,at,run_type,cp2k_program,basis_set_file,potential_file,& - dft_file,cell_file,global_file,use_cubic_cell) - - type(param_cp2k), intent(out) :: this - type(atoms), intent(inout) :: at - integer, intent(in) :: run_type - character(len=*), intent(in) :: cp2k_program - character(len=*), intent(in) :: basis_set_file, potential_file, dft_file, cell_file,global_file - logical, optional, intent(in) :: use_cubic_cell - - real(dp), dimension(3) :: QM_maxdist - type(Table) :: fitlist - character(len=20) :: dir - integer :: i,j - logical :: ex - logical :: cubic - character(len=800) :: env_program_name - integer :: name_len, status - real(dp),dimension(3) :: old_QM_cell - logical :: QM_list_changed - character(len=value_len) :: bs_pot_string - character(len=value_len) :: basis_set_file_val, potential_file_val - - call system_timer('param_init') - - if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & - call system_abort('param_initialise Run type is not recognized: '//run_type) - call print('Initializing parameters to run CP2K...') - cubic = optional_default(.false.,use_cubic_cell) - - if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - this%dft%mgrid_cutoff = 280.0_dp - if (run_type.eq.QS_RUN .and. any(at%Z(1:at%N).eq.17)) this%dft%mgrid_cutoff = 300._dp - this%dft%scf_guess = 'atomic' - this%dft%xc_functional = 'BLYP' !can be B3LYP,PBE0,BLYP,BP,PADE,PBE,TPSS,HTCH120,OLYP,NO_SHORTCUT,NONE - endif - if (any(run_type.eq.(/MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - this%mm_forcefield%parmtype = 'CHM' - this%mm_forcefield%parm_file_name = 'charmm.pot' - this%mm_forcefield%charge_OT = -0.834_dp - this%mm_forcefield%charge_HT = 0.417_dp - endif - this%mm_ewald%ewald_type = 'ewald' - this%mm_ewald%ewald_alpha = 0.35_dp - this%mm_ewald%ewald_gmax = int(max(at%lattice(1,1),at%lattice(2,2),at%lattice(3,3))/2._dp)*2+1 - - if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - ! let's have 3 Angstroms on any side of the cell - call print('INFO: The size of the QM cell is either the MM cell itself, or it will have at least 3-3 Angstrom around the QM atoms.') - call print('WARNING! Please check if your cell is centered around the QM region!',verbosity=PRINT_SILENT) - call print('WARNING! CP2K centering algorithm fails if QM atoms are not all in the',verbosity=PRINT_SILENT) - call print('WARNING! 0,0,0 cell. If you have checked it, please ignore this message.',verbosity=PRINT_SILENT) - this%qmmm%qmmm_cell = 0._dp - call get_qm_list_int_rec(at,run_type,fitlist, do_recursive=.true.) ! with QM_flag 1 or 2 - if (any(at%Z(int_part(fitlist,1)).gt.8)) this%dft%mgrid_cutoff = 300._dp - -! whole numbers => to use wavefunction extrapolation later - QM_maxdist = 0._dp - QM_maxdist(1) = maxval(at%pos(1,fitlist%int(1,1:fitlist%N))) - minval(at%pos(1,fitlist%int(1,1:fitlist%N))) - QM_maxdist(2) = maxval(at%pos(2,fitlist%int(1,1:fitlist%N))) - minval(at%pos(2,fitlist%int(1,1:fitlist%N))) - QM_maxdist(3) = maxval(at%pos(3,fitlist%int(1,1:fitlist%N))) - minval(at%pos(3,fitlist%int(1,1:fitlist%N))) -! do i=1,fitlist%N -! do j=i+1,fitlist%N -! QM_maxdist(1) = max(QM_maxdist(1),distance_min_image(at,(/at%pos(1,i),0._dp,0._dp/),(/at%pos(1,j),0._dp,0._dp/))) -! QM_maxdist(2) = max(QM_maxdist(2),distance_min_image(at,(/0._dp,at%pos(2,i),0._dp/),(/0._dp,at%pos(2,j),0._dp/))) -! QM_maxdist(3) = max(QM_maxdist(3),distance_min_image(at,(/0._dp,0._dp,at%pos(3,i)/),(/0._dp,0._dp,at%pos(3,j)/))) -!! call print('QM_maxdist: '//round(QM_maxdist(1),3)//' '//round(QM_maxdist(2),3)//' '//round(QM_maxdist(3),3)) -! enddo -! enddo - - if (cubic) then - QM_maxdist(1) = maxval(QM_maxdist(1:3)) - QM_maxdist(2) = QM_maxdist(1) - QM_maxdist(3) = QM_maxdist(1) - call print('cubic cell') - endif - - this%qmmm%qmmm_cell(1) = min(real(ceiling(QM_maxdist(1)))+6._dp,at%lattice(1,1)) - this%qmmm%qmmm_cell(2) = min(real(ceiling(QM_maxdist(2)))+6._dp,at%lattice(2,2)) - this%qmmm%qmmm_cell(3) = min(real(ceiling(QM_maxdist(3)))+6._dp,at%lattice(3,3)) - - call print('Lattice:') - call print(' A '//round(at%lattice(1,1),6)//' '//round(at%lattice(2,1),6)//' '//round(at%lattice(3,1),6)) - call print(' B '//round(at%lattice(1,2),6)//' '//round(at%lattice(2,2),6)//' '//round(at%lattice(3,2),6)) - call print(' C '//round(at%lattice(1,3),6)//' '//round(at%lattice(2,3),6)//' '//round(at%lattice(3,3),6)) - call print('QM cell:') - call print(' A '//round(this%qmmm%qmmm_cell(1),6)//' '//round(0._dp,6)//' '//round(0._dp,6)) - call print(' B '//round(0._dp,6)//' '//round(this%qmmm%qmmm_cell(2),6)//' '//round(0._dp,6)) - call print(' C '//round(0._dp,6)//' '//round(0._dp,6)//' '//round(this%qmmm%qmmm_cell(3),6)) - - ! save the QM cell size, if the same as last time, might reuse wavefunction - ex = .false. - this%qmmm%reuse_wfn = .false. - ex = get_value(at%params,'QM_cell',old_QM_cell) - if (ex) then - if (old_QM_cell(1:3) .feq. this%qmmm%qmmm_cell(1:3)) then - this%qmmm%reuse_wfn = .true. - if (Run_Type.eq.QMMM_RUN_CORE) call print('QM cell size have not changed. Reuse previous wavefunction.') - call print('QM_cell size has not changed in at%params, will reuse wfn'//old_QM_cell(1:3)//this%qmmm%qmmm_cell(1:3)//' if QM list has not changed', PRINT_VERBOSE) - else - this%qmmm%reuse_wfn = .false. - call print('QM_cell size changed in at%params, will not reuse wfn'//old_QM_cell(1:3)//this%qmmm%qmmm_cell(1:3), PRINT_VERBOSE) - call set_value(at%params,'QM_cell',this%qmmm%qmmm_cell(1:3)) - endif - else !for the first step there is no QM_cell, no wavefunction - this%qmmm%reuse_wfn = .false. - call print('did not find QM_cell property in at%params, will not reuse wfn', PRINT_VERBOSE) - call set_value(at%params,'QM_cell',this%qmmm%qmmm_cell(1:3)) - call print('set_value QM_cell :'//this%qmmm%qmmm_cell(1:3)) - endif - ! only in case of extended run also QM buffer zone change counts - if (Run_Type.eq.QMMM_RUN_EXTENDED) then - ex = .false. - ex = get_value(at%params,'QM_list_changed',QM_list_changed) - if (ex) then - this%qmmm%reuse_wfn = this%qmmm%reuse_wfn .and. (.not.QM_list_changed) - if (QM_list_changed) then - call print('QM list changed, will not use wfn', PRINT_VERBOSE) - else - call print('QM list has not changed, will use wfn if QM cell is the same', PRINT_VERBOSE) - endif - else - this%qmmm%reuse_wfn = .false. - call print('could not find QM_list_changed in the atoms object. reuse_wfn? '//this%qmmm%reuse_wfn) - endif - if (this%qmmm%reuse_wfn) then - this%dft%scf_guess = 'RESTART' - call print('QM list and QM cell size have not changed. Reuse previous wavefunction.') - endif - endif - -! call print('QM coordinates:') -! do i=1,fitlist%N -! call print('QM ATOM '//round(at%pos(1,fitlist%int(1,i)),6)//' '//round(at%pos(2,fitlist%int(1,i)),6)//' '//round(at%pos(3,fitlist%int(1,i)),6)) -! enddo - - this%qmmm%qmmm_cell_unit = 'ANGSTROM' - this%qmmm%ecoupl = 'GAUSS' -! ONLY 0.44, 0.78 & 0.80 values can be used at the moment! - this%qmmm%radius_H = 0.44_dp - this%qmmm%radius_O = 0.78_dp - this%qmmm%radius_C = 0.80_dp !0.77_dp - this%qmmm%radius_N = 0.80_dp !0.75_dp - this%qmmm%radius_S = 0.80_dp !0.75_dp - this%qmmm%radius_Cl = 0.80_dp !0.75_dp - this%qmmm%radius_Na = 0.80_dp !0.75_dp - endif - - if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - - ! read basis_set/potentials from file - call initialise(this%basis_set) - basis_set_file_val = basis_set_file - if (len(trim(basis_set_file_val)) == 0) then ! if no file was passed in calc_str, try to get it from config header - if (get_value(at%params,'BASIS_SET_list',basis_set_file_val)) then ! if file was defined in config header, set filename - call print("Using basis_set_file from BASIS_SET_list property of config") - endif - endif - if (len(trim(basis_set_file_val)) /= 0) then ! if a filename has been defined anywhere - call print("Reading basis set from '"//trim(basis_set_file_val)//"'") - call read_list_file(this,basis_set_file_val,basis_set=.true.) - endif - - this%dft%file = trim(dft_file) - - call initialise(this%potential) - potential_file_val = potential_file - if (len(trim(potential_file_val)) == 0) then ! if no file was passed in calc_str, try to get it from config header - if (get_value(at%params,'POTENTIAL_list',potential_file_val)) then ! if file was defined in config header, set filename - call print("Using potential_file from POTENTIAL_list property of config") - endif - endif - if (len(trim(potential_file_val)) /= 0) then ! if a filename has been defined anywhere - call print("Reading potential from '"//trim(potential_file_val)//"'") - call read_list_file(this,potential_file_val,potential=.true.) - endif - -! add default basis sets and potentials: - if (.not.get_value(this%basis_set,'H',bs_pot_string).and.find_in_array(at%Z(1:at%N),1).gt.0) then - call print('Added default basis set for H: DZVP-GTH-BLYP') - call set_value(this%basis_set,'H','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'H',bs_pot_string).and.find_in_array(at%Z(1:at%N),1).gt.0) then - call print('Added default potential for H: GTH-BLYP-q1') - call set_value(this%potential,'H','GTH-BLYP-q1') - endif - if (.not.get_value(this%basis_set,'O',bs_pot_string).and.find_in_array(at%Z(1:at%N),8).gt.0) then - call print('Added default basis set for O: DZVP-GTH-BLYP') - call set_value(this%basis_set,'O','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'O',bs_pot_string).and.find_in_array(at%Z(1:at%N),8).gt.0) then - call print('Added default potential for O: GTH-BLYP-q6') - call set_value(this%potential,'O','GTH-BLYP-q6') - endif - if (.not.get_value(this%basis_set,'C',bs_pot_string).and.find_in_array(at%Z(1:at%N),6).gt.0) then - call print('Added default basis set for C: DZVP-GTH-BLYP') - call set_value(this%basis_set,'C','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'C',bs_pot_string).and.find_in_array(at%Z(1:at%N),6).gt.0) then - call print('Added default potential for C: GTH-BLYP-q4') - call set_value(this%potential,'C','GTH-BLYP-q4') - endif - if (.not.get_value(this%basis_set,'N',bs_pot_string).and.find_in_array(at%Z(1:at%N),7).gt.0) then - call print('Added default basis set for N: DZVP-GTH-BLYP') - call set_value(this%basis_set,'N','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'N',bs_pot_string).and.find_in_array(at%Z(1:at%N),7).gt.0) then - call print('Added default potential for N: GTH-BLYP-q5') - call set_value(this%potential,'N','GTH-BLYP-q5') - endif - if (.not.get_value(this%basis_set,'S',bs_pot_string).and.find_in_array(at%Z(1:at%N),16).gt.0) then - call print('Added default basis set for S: DZVP-GTH-BLYP') - call set_value(this%basis_set,'S','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'S',bs_pot_string).and.find_in_array(at%Z(1:at%N),16).gt.0) then - call print('Added default potential for S: GTH-BLYP-q6') - call set_value(this%potential,'S','GTH-BLYP-q6') - endif - if (.not.get_value(this%basis_set,'Cl',bs_pot_string).and.find_in_array(at%Z(1:at%N),17).gt.0) then - call print('Added default basis set for Cl: DZVP-GTH-BLYP') - call set_value(this%basis_set,'Cl','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'Cl',bs_pot_string).and.find_in_array(at%Z(1:at%N),17).gt.0) then - call print('Added default potential for Cl: GTH-BLYP-q7') - call set_value(this%potential,'Cl','GTH-BLYP-q7') - endif - if (.not.get_value(this%basis_set,'F',bs_pot_string).and.find_in_array(at%Z(1:at%N),9).gt.0) then - call print('Added default basis set for F: DZVP-GTH-BLYP') - call set_value(this%basis_set,'F','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'F',bs_pot_string).and.find_in_array(at%Z(1:at%N),9).gt.0) then - call print('Added default potential for F: GTH-BLYP-q7') - call set_value(this%potential,'F','GTH-BLYP-q7') - endif - if (.not.get_value(this%basis_set,'Na',bs_pot_string).and.find_in_array(at%Z(1:at%N),11).gt.0) then - call print('Added default basis set for Na: DZVP-GTH-BLYP') - call set_value(this%basis_set,'Na','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'Na',bs_pot_string).and.find_in_array(at%Z(1:at%N),11).gt.0) then - call print('Added default potential for Na: GTH-BLYP-q1') - call set_value(this%potential,'Na','GTH-BLYP-q1') - endif - if (.not.get_value(this%basis_set,'Fe',bs_pot_string).and.find_in_array(at%Z(1:at%N),26).gt.0) then - call print('Added default basis set for Fe: DZVP-GTH-BLYP') - call set_value(this%basis_set,'Fe','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'Fe',bs_pot_string).and.find_in_array(at%Z(1:at%N),26).gt.0) then - call print('Added default potential for Fe: GTH-BLYP-q16') - call set_value(this%potential,'Fe','GTH-BLYP-q16') - endif - if (.not.get_value(this%basis_set,'Si',bs_pot_string).and.find_in_array(at%Z(1:at%N),14).gt.0) then - call print('Added default basis set for Si: DZVP-GTH-BLYP') - call set_value(this%basis_set,'Si','DZVP-GTH-BLYP') - endif - if (.not.get_value(this%potential,'Si',bs_pot_string).and.find_in_array(at%Z(1:at%N),14).gt.0) then - call print('Added default potential for Si: GTH-BLYP-q4') - call set_value(this%potential,'Si','GTH-BLYP-q4') - endif - endif - - this%global%project = 'cp2k' - this%global%runtype = 'MD' - this%global%cell_file = trim(cell_file) - this%global%global_file = trim(global_file) - - this%md%ensemble = 'NVE' - this%md%steps = 0 - this%md%timestep = 0.5_dp - this%md%temperature = 300.0_dp - -! use numbers in ascending order -! this%wenv%working_directory = 'cp2k_run_'//ran_string(8) !directory for temporary files used by cp2k - ex = .true. - i=1 - do while (ex) - dir = "cp2k_run_"//i - inquire(file=(trim(dir)//'/cp2k_input.inp'),exist=ex) - i = i + 1 - enddo - -!added status optionally to system_command! - call system_command('mkdir '//trim(dir),status=status) - call print('system_command status: '//status) - if (status /= 0) then - call system_abort('Failed to mkdir '//trim(dir)) - endif - - call print('the working directory: '//trim(dir)) - this%wenv%working_directory = trim(dir) - this%wenv%pdb_file = 'pdb.CHARMM.pdb' - this%wenv%exyz_file = 'exyz.CHARMM.xyz' - this%wenv%psf_file = 'psf.CHARMM.psf' - this%wenv%wfn_file = 'wfn.restart.wfn' - this%wenv%cp2k_input_filename = 'cp2k_input.inp' - this%wenv%force_file = trim(this%global%project)//'-frc-1.xyz' - this%wenv%pos_file = trim(this%global%project)//'-pos-1.xyz' - this%wenv%wrk_filename = 'wrk.dat' - - this%N=at%N - - ! get program name from environment variable - call print('use cp2k_program passed in args_str: '//trim(cp2k_program)) - this%wenv%cp2k_program = trim(cp2k_program) - - call system_timer('param_init') - - end subroutine param_initialise - - !% Finalise CP2K parameter set - ! - subroutine param_finalise(this) - - type(param_cp2k), intent(out) :: this - - call finalise(this%basis_set) - call finalise(this%potential) - this%dft%file = '' - this%dft%mgrid_cutoff = 0._dp - this%dft%scf_guess = '' - this%dft%xc_functional = '' - this%mm_forcefield%parmtype = '' - this%mm_forcefield%parm_file_name = '' - this%mm_forcefield%charge_OT = 0._dp - this%mm_forcefield%charge_HT = 0._dp - this%mm_ewald%ewald_type = '' - this%mm_ewald%ewald_alpha = 0._dp - this%mm_ewald%ewald_gmax = 0 - this%qmmm%qmmm_cell = 0._dp - this%qmmm%qmmm_cell_unit = '' - this%qmmm%reuse_wfn = .false. - this%qmmm%ecoupl = '' - this%qmmm%radius_H = 0._dp - this%qmmm%radius_O = 0._dp - this%qmmm%radius_C = 0._dp - this%qmmm%radius_N = 0._dp - this%qmmm%radius_S = 0._dp - this%qmmm%radius_Cl = 0._dp - this%qmmm%radius_Na = 0._dp - this%qmmm%radius_Si = 0._dp - this%global%cell_file = '' - this%global%global_file = '' - this%global%project = '' - this%global%runtype = '' - this%md%ensemble = '' - this%md%steps = 0 - this%md%timestep = 0._dp - this%md%temperature = 0._dp - this%wenv%working_directory = '' - this%wenv%pdb_file = '' - this%wenv%exyz_file = '' - this%wenv%psf_file = '' - this%wenv%wfn_file = '' - this%wenv%cp2k_input_filename = '' - this%wenv%force_file = '' - this%wenv%pos_file = '' - this%wenv%wrk_filename = '' - this%wenv%cp2k_program = '' - this%N = 0 - - this%initialised = .false. - - end subroutine param_finalise - - !%Prints the quantum region mark with the cluster_mark property (/=0). - !%If file is given, into file, otherwise to the standard io. - ! - subroutine print_qm_region(at, file) - type(Atoms), intent(inout) :: at - type(Inoutput), optional :: file - - integer, pointer :: qm_flag(:) - - if (.not.(assign_pointer(at, "cluster_mark", qm_flag))) & - call system_abort("print_qm_region couldn't find cluster_mark property") - - if (present(file)) then - file%prefix="QM_REGION" - call print_xyz(at, file, mask=(qm_flag /= 0)) - file%prefix="" - else - mainlog%prefix="QM_REGION" - call print_xyz(at, mainlog, mask=(qm_flag /= 0)) - mainlog%prefix="" - end if - end subroutine print_qm_region - - !% Subroutine to read the BASIS_SET and the POTENTIAL from external files. - !% Used by param_initialise. - ! - !% The format is (e.g. for H and O): - !% 2 !number of lines - !% 1 DZVP-GTH-BLYP !atomic number and basis set - !% 8 DZVP-GTH-BLYP !atomic number and basis set - ! - subroutine read_list_file(this,filename,basis_set,potential) - - type(param_cp2k), intent(inout) :: this - character(len=*), intent(in) :: filename - logical, optional, intent(in) :: basis_set,potential - - type(InOutput) :: listfile - integer :: num_list, n, Z - character(80), dimension(2) :: fields - character(len=80) :: bs_pot - integer :: num_fields - logical :: do_basis_set - integer :: status - - if (present(basis_set).and.present(potential)) then - if (basis_set.eqv.potential) call system_abort('read_list_file: exactly one of basis_set and potential should be true') - endif - if (present(basis_set)) do_basis_set = basis_set - if (present(potential)) do_basis_set = .not.potential - - call initialise(listfile,filename=trim(filename),action=INPUT) - - call parse_line(listfile,' ',fields,num_fields,status) - if (status > 0) then - call system_abort('read_list_file: Error reading from '//listfile%filename) - else if (status < 0) then - call system_abort('read_list_file: End of file when reading from '//listfile%filename) - end if - - num_list = string_to_int(fields(1)) - if (num_list.le.0) call system_abort('read_list_file: number of basis/potential should be >0:'//num_list) -! if (do_basis_set) then -! call initialise(this%basis_set) -! call allocate(this%basis_set,1,0,1,0,num_list) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries -! else -! call initialise(this%potential) -! call allocate(this%basis_set,1,0,1,0,num_list) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries -! endif - - ! Reading and storing list... - do n=1,num_list - call parse_line(listfile,' ',fields,num_fields,status) - if (status.ne.0) call system_abort('wrong file '//listfile%filename) - if (num_fields.lt.2) call system_abort('wrong file format '//listfile%filename) - Z = string_to_int(fields(1)) - bs_pot = fields(2) -! if (len(trim(bs_pot)).gt.TABLE_STRING_LENGTH) call system_abort('too long (>10) name: '//trim(bs_pot)) - if (do_basis_set) then - call print('Use for '//ElementName(Z)//' basis set: '//trim(bs_pot)) - call set_value(this%basis_set,ElementName(Z),bs_pot) -! call append(this%basis_set,(/Z/)) -! call append(this%basis_set,bs_pot) - else - call print('Use for '//ElementName(Z)//' potential: '//trim(bs_pot)) - call set_value(this%potential,ElementName(Z),bs_pot) -! call append(this%potential,(/Z/)) -! call append(this%potential,bs_pot) - endif - enddo - - call finalise(listfile) - - end subroutine read_list_file - - - !!!!! ============================================================================================ !!!!! - !!!!! !!!!! - !!!!! \/ \/ \/ \/ \/ \/ ------------ main subroutine to run CP2K ------------ \/ \/ \/ \/ \/ \/ !!!!! - !!!!! !!!!! - !!!!! ============================================================================================ !!!!! - - !% Main subroutine to run CP2K. The input parameters (program name, basis set, potential, - !% run type, whether to print a PSF file, dft parameters, cell size) are read from args_str. - !% Optionally outputs the forces and/or the energy. - !% Optionally reads the intrares_impropers that will be used to print a PSF file. - ! - subroutine go_cp2k(my_atoms,forces,energy,args_str,intrares_impropers) - - type(Atoms), intent(inout) :: my_atoms - real(dp), dimension(:,:), optional, intent(out) :: forces - real(dp), optional, intent(out) :: energy - character(len=*), optional, intent(in) :: args_str - type(Table), optional, intent(in) :: intrares_impropers - - type(param_cp2k) :: param - type(Table) :: qmlist - real(dp), allocatable, dimension(:,:) :: CP2K_forces - real(dp) :: CP2K_energy - - type(Dictionary) :: params - integer :: run_type - integer :: PSF_print - character(len=STRING_LENGTH) :: cp2k_program - character(len=STRING_LENGTH) :: run_type_str, psf_print_str - character(len=STRING_LENGTH) :: fileroot_str - character(len=STRING_LENGTH) :: basis_set_file, potential_file, dft_file, cell_file,global_file - - character(len=STRING_LENGTH) :: run_command='', & - fin_command='' - logical :: clean_up_files, save_output_files - integer :: status, error_status - logical :: ex - integer :: n_tries, max_n_tries - real(dp) :: max_force_warning - logical :: converged - logical :: have_silica_potential - - call system_timer('go_cp2k_start') - call print_title('Setting up the CP2K run') - - if (.not.present(energy).and..not.present(forces)) call system_abort('go_cp2k: nothing to be calculated. Neither energy, nor forces.') - - ! Read and print run parameters - fileroot_str='' - basis_set_file='' - potential_file='' - dft_file='' - cell_file='' - global_file='' - call initialise(params) - call param_register(params, 'Run_Type', 'MM', run_type_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'PSF_Print', 'NO_PSF', psf_print_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'cp2k_program','cp2k.sopt', cp2k_program, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'root', '', fileroot_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'basis_set_file', '', basis_set_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'potential_file', '', potential_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'dft_file', '', dft_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'cell_file', '', cell_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'global_file', '', global_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'clean_up_files', 'T', clean_up_files, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'save_output_files', 'T', save_output_files, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'max_n_tries', '2', max_n_tries, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'max_force_warning', '2.0', max_force_warning, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'have_silica_potential', 'F', have_silica_potential, help_string="No help yet. This source file was $LastChangedBy$") - - if (present(args_str)) then - if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='go_cp2k args_str')) & - call system_abort("Potential_Initialise_str failed to parse args_str='"//trim(args_str)//"'") - else - call system_abort("Potential_Initialise_str failed to parse args_str, no args_str") - endif - call finalise(params) - - if (len_trim(fileroot_str) > 0) then - if (len_trim(basis_set_file) == 0) basis_set_file=trim(fileroot_str)//'.basis_set' - if (len_trim(potential_file) == 0) potential_file=trim(fileroot_str)//'.potential' - if (len_trim(dft_file) == 0) dft_file=trim(fileroot_str)//'.dft' - if (len_trim(cell_file) == 0) cell_file=trim(fileroot_str)//'.cell' - if (len_trim(global_file) == 0) global_file=trim(fileroot_str)//'.global' - end if - - select case(trim(psf_print_str)) - case('CP2K_PRINT_AND_SAVE') - PSF_print = CP2K_PRINT_AND_SAVE - case('NO_PSF') - PSF_print = NO_PSF - case('DRIVER_PRINT_AND_SAVE') - PSF_print = DRIVER_PRINT_AND_SAVE - case('USE_EXISTING_PSF') - PSF_print = USE_EXISTING_PSF - case default - call system_abort("go_cp2k got psf_print_str='"//trim(psf_print_str)//"'" // & - ", only know about NO_PSF, CP2K_PRINT_AND_SAVE, DRIVER_PRINT_AND_SAVE, USE_EXISTING_PSF") - end select - - select case(trim(run_type_str)) - case('MM') - run_type = MM_RUN - case('QS') - run_type = QS_RUN - case('QMMM_CORE') - run_type = QMMM_RUN_CORE - case('QMMM_EXTENDED') - run_type = QMMM_RUN_EXTENDED - case default - call system_abort("go_cp2k got run_type_str='"//trim(run_type_str)//"'" // & - ", only know about MM, QS, QMMM_CORE, QMMM_EXTENDED") - end select - - if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & - call system_abort('go_cp2k: Run type is not recognized: '//run_type) - if (.not.any(PSF_print.eq.(/NO_PSF,CP2K_PRINT_AND_SAVE,DRIVER_PRINT_AND_SAVE,USE_EXISTING_PSF/))) & - call system_abort('go_cp2k: PSF print is not recognized: '//PSF_print) - - call print ('Run parameters: ') - if (run_type.eq.QS_RUN) call print ('Run type: QS') - if (run_type.eq.MM_RUN) call print ('Run type: MM') - if (run_type.eq.QMMM_RUN_CORE) call print ('Run type: QM/MM run, QM: quantum core') - if (run_type.eq.QMMM_RUN_EXTENDED) call print ('Run type: QM/MM run, QM: extended quantum region') - if (PSF_Print.eq.NO_PSF) call print ('PSF printing: No PSF') - if (PSF_Print.eq.CP2K_PRINT_AND_SAVE) call print ('PSF printing: CP2K prints PSF') - if (PSF_Print.eq.DRIVER_PRINT_AND_SAVE) call print ('PSF printing: driver prints PSF') - if (PSF_Print.eq.USE_EXISTING_PSF) call print ('PSF printing: Use existing PSF') - - ! If QM/MM, get QM list - if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - call get_qm_list_int_rec(my_atoms,run_type,qmlist, do_recursive=.true.) - !check if all the atoms are QM, QS used instead - if (qmlist%N.eq.my_atoms%N) then - call print('WARNING: go_cp2k: QM/MM calculation was requested, but all the atoms are within the quantum zone: fully QS will be run!',verbosity=PRINT_ALWAYS) - run_type = QS_RUN - call print ('Run type: QS') - endif - endif - - ! set params, CHARMM formats and create working directory - call param_initialise(param,my_atoms,run_type,cp2k_program,basis_set_file,potential_file,dft_file,cell_file,global_file) - - ! check CHARMM topology - ! Write the coordinate file and the QM/MM or MM input file - call write_cp2k_input_files(my_atoms,qmlist,param=param,run_type=run_type,PSF_print=PSF_print,intrares_impropers=intrares_impropers,have_silica_potential=have_silica_potential) - - ! Run cp2k MM serial or QM/MM parallel - call print('Running CP2K...') - - n_tries = 0 - converged = .false. - do while (.not. converged .and. (n_tries < max_n_tries)) - n_tries = n_tries + 1 - run_command = 'cd '//trim(param%wenv%working_directory)//';'//trim(param%wenv%cp2k_program)//' '//trim(param%wenv%cp2k_input_filename)//' >> cp2k_output.out' - - call print(run_command) - !added status optionally to system_command. - call system_timer('go_cp2k_start') - call system_timer('system_command(run_command)') - call system_command(run_command,status=status) - call system_timer('system_command(run_command)') - call system_timer('go_cp2k_end') - call print_title('...CP2K...') - call print('grep -i warning '//trim(param%wenv%working_directory)//'/cp2k_output.out') - call system_command('grep -i warning '//trim(param%wenv%working_directory)//'/cp2k_output.out') - call system_command('grep -i error '//trim(param%wenv%working_directory)//'/cp2k_output.out', error_status) - if (status /= 0) call system_abort('CP2K had non-zero return status. See output file '//trim(param%wenv%working_directory)//'/cp2k_output.out') - if (error_status == 0) call system_abort('CP2K had ERROR in output. See output file '//trim(param%wenv%working_directory)//'/cp2k_output.out') - - call system_command('egrep "FORCE_EVAL.* QS " '//trim(param%wenv%working_directory)//'/cp2k_output.out',status=status) - if (status == 0) then ! QS or QMMM run - call system_command('grep "FAILED to converge" '//trim(param%wenv%working_directory)//'/cp2k_output.out',status=status) - if (status == 0) then - call print("WARNING: cp2k_driver failed to converge, trying again",PRINT_ALWAYS) - converged = .false. - else - call system_command('grep "SCF run converged" '//trim(param%wenv%working_directory)//'/cp2k_output.out',status=status) - if (status == 0) then - converged = .true. - else - call print("WARNING: cp2k_driver couldn't find definitive sign of convergence or failure to converge in output file, trying again",PRINT_ALWAYS) - converged = .false. - endif - end if - else ! MM run - converged = .true. - endif - - ! Save Wfn if needed - if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - ! inquire(file=trim(param%wenv%working_directory)//'/'//trim(param%global%project)//'-RESTART.wfn',exist=ex) - ! if (ex) & - call system_command('cp '//trim(param%wenv%working_directory)//'/'//trim(param%global%project)//'-RESTART.wfn '//trim(param%wenv%wfn_file)) - endif - - end do - if (.not. converged) call system_abort('CP2K failed to converge after n_tries='//n_tries//'. See output file '//trim(param%wenv%working_directory)//'/cp2k_output.out') - - ! Read energy and forces - also re-reordering! -! call print('file='//trim(param%wenv%working_directory)//'/'//trim(param%wenv%force_file)//',exist=ex') -! inquire(file=trim(param%wenv%working_directory)//'/'//trim(param%wenv%force_file),exist=ex) -! if (ex) call system_abort('CP2K aborted before printing forces. Check the output file '//trim(param%wenv%working_directory)//'/cp2k_output.out') - call read_cp2k_forces(CP2K_forces,CP2K_energy,param,my_atoms,run_type=run_type) - if (maxval(abs(CP2K_forces)) > max_force_warning) then - call print("WARNING: CP2K_forces maximum component " // maxval(abs(CP2K_forces)) // " at " // maxloc(abs(CP2K_forces)) // & - " exceeds max_force_warning="//max_force_warning, PRINT_ALWAYS) - endif - - if (present(energy)) energy = CP2K_energy - if (present(forces)) forces = CP2K_forces - - ! Save PSF if needed - if (PSF_print.eq.CP2K_PRINT_AND_SAVE) then -! inquire(file=trim(param%wenv%working_directory)//'/'//trim(param%global%project)//'-dump-1.psf',exist=ex) -! if (ex) & - call system_command('cp '//trim(param%wenv%working_directory)//'/'//trim(param%global%project)//'-dump-1.psf '//trim(param%wenv%psf_file)) - endif - - if (save_output_files) then - call system_command('cat '//trim(param%wenv%working_directory)//'/'//trim(param%wenv%cp2k_input_filename)// & - ' >> cp2k_input_log; echo "##############" >> cp2k_input_log;' // & - ' cat '//trim(param%wenv%working_directory)//'/'//trim(param%wenv%force_file)// & - ' >> cp2k_force_file_log; echo "##############" >> cp2k_force_file_log;' // & - ' cat '//trim(param%wenv%working_directory)//'/cp2k_output.out >> cp2k_output_log; echo "##############" >> cp2k_output_log') - endif - - ! remove all unnecessary files - if (clean_up_files) & - call system_command('rm -rf '//trim(param%wenv%working_directory),status=status) - - call finalise(param) - - call print('CP2K finished. Go back to main program.') - call system_timer('go_cp2k_end') - - end subroutine go_cp2k - - !!!!! ============================================================================================ !!!!! - !!!!! !!!!! - !!!!! \/ \/ \/ \/ \/ \/ ----------------- QM list operations ----------------- \/ \/ \/ \/ \/ \/ !!!!! - !!!!! !!!!! - !!!!! ============================================================================================ !!!!! - - !% Returns a $qmlist$ table with the atom indices whose $cluster_mark$ - !% (or optionally any $int_property$) property takes exactly $qmflag$ value. - ! - subroutine get_qm_list_int(my_atoms,qmflag,qmlist,int_property) - - type(Atoms), intent(in) :: my_atoms - integer, intent(in) :: qmflag - type(Table), intent(out) :: qmlist - character(len=*), optional, intent(in) :: int_property - - integer :: i - integer :: qm_flag_index - -! qm_flag_index = get_property(my_atoms,'QM_flag') - if (present(int_property)) then - qm_flag_index = get_property(my_atoms,int_property) - else - qm_flag_index = get_property(my_atoms,'cluster_mark') - endif - - call initialise(qmlist,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries - do i=1,my_atoms%N - if (my_atoms%data%int(qm_flag_index,i).eq.qmflag) & - call append(qmlist,(/i,0,0,0/)) - enddo - - if (qmlist%N.eq.0) call print('Empty QM list with cluster_mark '//qmflag,verbosity=PRINT_SILENT) - - end subroutine get_qm_list_int - - !% Returns a $qmlist$ table with the atom indices whose $cluster_mark$ - !% (or optionally any $int_property$) property takes no greater than $qmflag$ positive value. - ! - subroutine get_qm_list_int_rec(my_atoms,qmflag,qmlist,do_recursive,int_property) - - type(Atoms), intent(in) :: my_atoms - integer, intent(in) :: qmflag - type(Table), intent(out) :: qmlist - logical, intent(in) :: do_recursive - character(len=*), optional, intent(in) :: int_property - - integer :: i - integer :: qm_flag_index - logical :: my_do_recursive - -! my_do_recursive = optional_default(.true.,do_recursive) -! qm_flag_index = get_property(my_atoms,'QM_flag') - if (present(int_property)) then - qm_flag_index = get_property(my_atoms,int_property) - else - qm_flag_index = get_property(my_atoms,'cluster_mark') - endif - - call initialise(qmlist,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries -! if (my_do_recursive) then - if (do_recursive) then - do i=1,my_atoms%N - if (my_atoms%data%int(qm_flag_index,i).gt.0.and. & - my_atoms%data%int(qm_flag_index,i).le.qmflag) & - call append(qmlist,(/i,0,0,0/)) - enddo - else - do i=1,my_atoms%N - if (my_atoms%data%int(qm_flag_index,i).eq.qmflag) & - call append(qmlist,(/i,0,0,0/)) - enddo - endif - - if (qmlist%N.eq.0) call print('Empty QM list with cluster_mark '//qmflag,verbosity=PRINT_SILENT) - - end subroutine get_qm_list_int_rec - - !% Returns a $qmlist$ table with the atom indices whose $cluster_mark$ - !% (or optionally any $int_property$) property takes any value from the $qmflag$ array. - ! - subroutine get_qm_list_array(my_atoms,qmflags,qmlist,int_property) - - type(Atoms), intent(in) :: my_atoms - integer, intent(in) :: qmflags(:) - type(Table), intent(out) :: qmlist - character(len=*), optional, intent(in) :: int_property - - integer :: i - integer :: qm_flag_index - -! qm_flag_index = get_property(my_atoms,'QM_flag') - if (present(int_property)) then - qm_flag_index = get_property(my_atoms,int_property) - else - qm_flag_index = get_property(my_atoms,'cluster_mark') - endif - - call initialise(qmlist,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries - do i=1,my_atoms%N - if (any(my_atoms%data%int(qm_flag_index,i).eq.qmflags(1:size(qmflags)))) & - call append(qmlist,(/i,0,0,0/)) - enddo - - if (qmlist%N.eq.0) call print('Empty QM list with cluster_mark '//qmflags(1:size(qmflags)),verbosity=PRINT_SILENT) - - end subroutine get_qm_list_array - - !% Returns the index of the first column of a property $prop$. - !% Aborts if the property cannot be found in the atoms object. - ! - function get_property(my_atoms,prop) result(prop_index) - - type(Atoms), intent(in) :: my_atoms - character(len=*), intent(in) :: prop - - integer,dimension(3) :: pos_indices - integer :: prop_index - - if (get_value(my_atoms%properties,trim(prop),pos_indices)) then - prop_index = pos_indices(2) - else - call system_abort('get_property: No '//trim(prop)//' property assigned to the Atoms object!') - end if - - end function get_property - - - !!!!! ============================================================================================ !!!!! - !!!!! !!!!! - !!!!! \/ \/ \/ \/ \/ \/ ---------- reading in the QM list from file ---------- \/ \/ \/ \/ \/ \/ !!!!! - !!!!! !!!!! - !!!!! ============================================================================================ !!!!! - - !% Reads the QM list from a file and saves it in $QM_flag$ integer property, - !% marking the QM atoms with 1, otherwise 0. - ! - subroutine read_qmlist(my_atoms,qmlistfilename,PRINT_verbose) - - type(Atoms), intent(inout) :: my_atoms - character(*), intent(in) :: qmlistfilename - logical, optional, intent(in) :: verbose - - type(table) :: qm_list - type(Inoutput) :: qmlistfile - integer :: n,num_qm_atoms,qmatom,status - character(80) :: title,testline - logical :: my_verbose - integer :: qm_flag_index - character(20), dimension(10) :: fields - integer :: num_fields - - - my_verbose = .false. - if (present(verbose)) my_verbose = PRINT_verbose - - if (my_verbose) call print('In Read_QM_list:') - call print('Reading the QM list from file '//trim(qmlistfilename)//'...') - - call initialise(qmlistfile,filename=trim(qmlistfilename),action=INPUT) - title = read_line(qmlistfile,status) - if (status > 0) then - call system_abort('read_qmlist: Error reading from '//qmlistfile%filename) - else if (status < 0) then - call system_abort('read_qmlist: End of file when reading from '//qmlistfile%filename) - end if - - call parse_line(qmlistfile,' ',fields,num_fields,status) - if (status > 0) then - call system_abort('read_qmlist: Error reading from '//qmlistfile%filename) - else if (status < 0) then - call system_abort('read_qmlist: End of file when reading from '//qmlistfile%filename) - end if - - num_qm_atoms = string_to_int(fields(1)) - if (num_qm_atoms.gt.my_atoms%N) call print('WARNING! read_qmlist: more QM atoms then atoms in the atoms object, possible redundant QM list file',verbosity=PRINT_ALWAYS) - call print('Number of QM atoms: '//num_qm_atoms) - call allocate(qm_list,4,0,0,0,num_qm_atoms) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries - - do while (status==0) - testline = read_line(qmlistfile,status) - !print *,testline - if (testline(1:4)=='list') exit - enddo - ! Reading and storing QM list... - do n=1,num_qm_atoms - call parse_line(qmlistfile,' ',fields,num_fields,status) - qmatom = string_to_int(fields(1)) - if (my_verbose) call print(n//'th quantum atom is: '//qmatom) - call append(qm_list,(/qmatom,0,0,0/)) - enddo - - call finalise(qmlistfile) - - if (qm_list%N/=num_qm_atoms) call system_abort('read_qmlist: Something wrong with the QM list file') - if (any(int_part(qm_list,1).gt.my_atoms%N).or.any(int_part(qm_list,1).lt.1)) & - call system_abort('read_qmlist: at least 1 QM atom is out of range') - if ((size(int_part(qm_list,1)).gt.my_atoms%N).or.(size(int_part(qm_list,1)).lt.1)) & - call system_abort("read_qmlist: QM atoms' number is <1 or >"//my_atoms%N) - - call add_property(my_atoms,'hybrid',0) - qm_flag_index = get_property(my_atoms,'hybrid') - my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 - my_atoms%data%int(qm_flag_index,int_part(qm_list,1)) = 1 -call print('Added '//count(my_atoms%data%int(qm_flag_index,1:my_atoms%N).eq.1)//' qm atoms.') - - call add_property(my_atoms,'hybrid_mark',0) - qm_flag_index = get_property(my_atoms,'hybrid_mark') - my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 - my_atoms%data%int(qm_flag_index,int_part(qm_list,1)) = 1 -call print('Added '//count(my_atoms%data%int(qm_flag_index,1:my_atoms%N).eq.1)//' qm atoms.') - - if (my_verbose) call print('Finished. '//qm_list%N//' QM atoms have been read successfully.') - call finalise(qm_list) - - end subroutine read_qmlist - - - !!!!! ============================================================================================ !!!!! - !!!!! !!!!! - !!!!! \/ \/ \/ \/ \/ \/ -------- create the CHARMM params to run CP2K -------- \/ \/ \/ \/ \/ \/ !!!!! - !!!!! !!!!! - !!!!! ============================================================================================ !!!!! - - !% Calculates number of bonds generated during connectivity generation. - !% Double checks if the connection table is symmetric. - ! - function num_of_bonds(at) result(bonds) - - type(atoms),intent(in) :: at - integer :: bonds - integer :: i,bonds2 - - bonds = 0 - bonds2 = 0 - - do i=1,at%N - if (associated(at%connect%neighbour1(i)%t)) bonds = bonds + at%connect%neighbour1(i)%t%N - if (associated(at%connect%neighbour2(i)%t)) bonds2 = bonds2 + at%connect%neighbour2(i)%t%N - enddo - - if (bonds.ne.bonds2) call system_abort('num_of_bonds: connectivities of atoms are not symmetric.') - - end function num_of_bonds - - !% Very simple routine to check the number of neighbours. - !% It prints the number of neighbours, unless it is 1 for H, or 2 for O. - !% May be useful for water, biomolecules only. - ! - subroutine check_neighbour_numbers(at) - - type(atoms),intent(in) :: at - integer :: i, n_neigh - - do i=1,at%N - - n_neigh = atoms_n_neighbours(at, i) - if ( (at%Z(i).eq.1) .AND. (n_neigh.ne.1) ) then -! do n=1,atoms_n_neighbours(at,i) -! j=atoms_neighbour(at,i,n) -! enddo - call print('Warning: '//ElementName(at%Z(i))//' atom '//i//' position '//round(at%pos(1,i),5)//' '//round(at%pos(2,i),5)//' '//round(at%pos(3,i),5)//' has unusual number of neighbours: '//(n_neigh)) - endif - if ( (at%Z(i).eq.8) .AND. (n_neigh.ne.2) ) & - call print('Warning: '//ElementName(at%Z(i))//' atom '//i//' position '//round(at%pos(1,i),5)//' '//round(at%pos(2,i),5)//' '//round(at%pos(3,i),5)//' has unusual number of neighbours: '//(n_neigh)) - - if ( .not.any(at%Z(i).eq.(/1,8/)) ) & - call print('Info: '//ElementName(at%Z(i))//' atom '//i//' position '//round(at%pos(1,i),5)//' '//round(at%pos(2,i),5)//' '//round(at%pos(3,i),5)//' has number of neighbours: '//(n_neigh)) - - enddo - - end subroutine check_neighbour_numbers - - !% Checks and reports the changes between two tables, $old_qmlist$ and $new_qmlist$. - ! - function check_list_change(old_list,new_list) result(list_changed) - - type(Table), intent(in) :: old_list, new_list - integer :: i - logical :: list_changed - - list_changed = .false. - if (old_list%N.ne.new_list%N) then - call print ('list has changed: new number of atoms is: '//new_list%N//', was: '//old_list%N) - list_changed = .true. - else - if (any(old_list%int(1,1:old_list%N).ne.new_list%int(1,1:new_list%N))) then - do i=1,old_list%N - if (.not.find_in_array(int_part(old_list,1),(new_list%int(1,i))).gt.0) then - call print('list has changed: atom '//new_list%int(1,i)//' has entered the region') - list_changed = .true. - endif - if (.not.find_in_array(int_part(new_list,1),(old_list%int(1,i))).gt.0) then - call print('list has changed: atom '//old_list%int(1,i)//' has left the region') - list_changed = .true. - endif - enddo - endif - endif - - end function check_list_change - - !!!!! ============================================================================================ !!!!! - !!!!! !!!!! - !!!!! \/ \/ \/ \/ \/ \/ ------------ input file printing for CP2K ------------ \/ \/ \/ \/ \/ \/ !!!!! - !!!!! !!!!! - !!!!! ============================================================================================ !!!!! - - !% Writes all the input files for CP2K: the actual input file, the coordinate file (PDB) - !% and the topology file (PSF). - !% If the intraresidual improper angles are given in $intrares_impropers$, - !% they will be included in the PSF file. This is needed for a meaningful - !% biochemical calculation. - ! - subroutine write_cp2k_input_files(my_atoms,qm_list,param,run_type,PSF_print,have_silica_potential,intrares_impropers) - - type(Atoms), intent(inout) :: my_atoms - type(Table), intent(in) :: qm_list - type(param_cp2k), intent(in) :: param - integer, intent(in) :: run_type, & - PSF_print - logical, optional, intent(in) :: have_silica_potential - type(Table), optional, intent(in) :: intrares_impropers - character(len=STRING_LENGTH) :: run_type_string -logical :: do_have_silica_potential -type(InOutput) :: exyz - - call system_timer('write_inputs') - - do_have_silica_potential = optional_default(.false.,have_silica_potential) - - if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & - call system_abort('write_cp2k_input_files: Run type is not recognized: '//run_type) - if (.not.any(PSF_print.eq.(/NO_PSF,CP2K_PRINT_AND_SAVE,DRIVER_PRINT_AND_SAVE,USE_EXISTING_PSF/))) & - call system_abort('write_cp2k_input_files: PSF print is not recognized: '//PSF_print) - - call print('Writing the CP2K input file(s)') - if (run_type.ne.QS_RUN) then - run_type_string = '' - if (run_type.eq.QMMM_RUN_EXTENDED) run_type_string = 'QMMM_EXTENDED' - if (run_type.eq.QMMM_RUN_CORE) run_type_string = 'QMMM_CORE' -!Print extended xyz instead of pdb format. -! call write_cp2k_pdb_file(my_atoms,trim(param%wenv%working_directory)//'/'//trim(param%wenv%pdb_file),run_type_string=run_type_string) - call initialise(exyz,trim(param%wenv%working_directory)//'/'//trim(param%wenv%exyz_file),action=OUTPUT) - call print_xyz(my_atoms,exyz,properties='species:pos:atom_type:atom_res_name:atom_mol_name:atom_res_number:atom_charge',real_format='f17.10') - call finalise(exyz) - if (PSF_print.eq.DRIVER_PRINT_AND_SAVE) then - if (present(intrares_impropers)) then - call write_psf_file(my_atoms,param%wenv%psf_file,run_type_string=trim(run_type_string),intrares_impropers=intrares_impropers,add_silica_23body=do_have_silica_potential) - else - call write_psf_file(my_atoms,param%wenv%psf_file,run_type_string=trim(run_type_string),add_silica_23body=do_have_silica_potential) - endif - endif - endif - call write_cp2k_input_file(my_atoms,qm_list,param,run_type,PSF_print,do_have_silica_potential) - call print ('Finished. Input files are ready for the run.') - if (PSF_print.eq.USE_EXISTING_PSF) call print('Use already existing PSF file '//param%wenv%psf_file) - - call system_timer('write_inputs') - - end subroutine write_cp2k_input_files - - !% Writes the CP2K input file. If cell, basis set, potential, global - !% and dft files are present in $param$, the CP2K parameter file, - !% use those to construct the input file, otherwise use some defaults. - ! - subroutine write_cp2k_input_file(my_atoms,qm_list,param,run_type,PSF_print,have_silica_potential) - - type(Atoms), intent(in) :: my_atoms - type(Table), intent(in) :: qm_list - type(param_cp2k), intent(in) :: param - integer, intent(in) :: run_type, & - PSF_print - logical, optional, intent(in) :: have_silica_potential - - type(Inoutput) :: input_file - integer,allocatable,dimension(:) :: list !in order to separate QM atom indices for H and O - integer :: i,j,counter - type(Table) :: qm_list_check - integer :: qm_flag_index, & - atom_type_index, & - atom_res_name_index, & - atom_charge_index - logical :: ex, lsd - integer :: charge - character(len=value_len) :: basis_set, potential - integer :: stat - type(inoutput) :: dft_in_io, cell_in_io, global_in_io - character(len=1024) :: line -type(Table) :: cut_bonds -integer, pointer :: cut_bonds_p(:,:) -integer :: i_inner, i_outer -logical :: do_have_silica_potential -integer :: ineigh,nneigh -type(Table) :: bond_constraints -logical :: constrain_all_HSI - - if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & - call system_abort('write_cp2k_input_file: Run type is not recognized: '//run_type) - - if (any(run_type.eq.(/MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - !qm_flag_index = get_property(my_atoms,'QM_flag') - qm_flag_index = get_property(my_atoms,'cluster_mark') - endif - atom_type_index = get_property(my_atoms,'atom_type') - atom_res_name_index = get_property(my_atoms,'atom_res_name') - atom_charge_index = get_property(my_atoms,'atom_charge') - endif - - if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - call get_qm_list_int_rec(my_atoms,run_type,qm_list_check, do_recursive=.true.) - if (qm_list_check%N.ne.qm_list%N) call system_abort ('qm_list is different from Atoms cluster_mark!!') - do i = 1, qm_list_check%N - if (.not.any(qm_list_check%int(1,i).eq.qm_list%int(1,1:qm_list%N))) call system_abort ('qm_list is different from Atoms cluster_mark!!') - enddo - do i = 1, qm_list%N - if (.not.any(qm_list%int(1,i).eq.qm_list_check%int(1,1:qm_list_check%N))) call system_abort ('qm_list is different from Atoms cluster_mark!!') - enddo - endif - - do_have_silica_potential = optional_default(.false.,have_silica_potential) - constrain_all_HSI = .false. - if (do_have_silica_potential) constrain_all_HSI = .true. - -! call print_title('Writing CP2K input file') - - call initialise(input_file,trim(param%wenv%working_directory)//'/'//trim(param%wenv%cp2k_input_filename),action=OUTPUT) - call print(' inp file: '//trim(input_file%filename)) - - ! input_file%default_real_precision=16 - - call print('&FORCE_EVAL',file=input_file) - if (run_type.eq.MM_RUN) then - call print(' METHOD Fist',file=input_file) - else - if (run_type.eq.QS_RUN) then - call print(' METHOD Quickstep',file=input_file) - else !QMMM_RUN_CORE or QMMM_RUN_EXTENDED - call print(' METHOD QMMM',file=input_file) - endif - endif - - if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - call print(' &DFT',file=input_file) - if (len(trim(param%dft%file)) > 0) then - call initialise(dft_in_io,trim(param%dft%file), INPUT) - stat = 0 - do while (stat == 0) - line = read_line(dft_in_io, stat) - if (stat == 0) call print(trim(line), file=input_file) - end do - call finalise(dft_in_io) - if (run_type.eq.QS_RUN) then - call print(' WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) - else - if (param%qmmm%reuse_wfn) then - call print(' WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) - else - call print('# WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) - endif - endif ! run_type == QS_RUN - if (run_type == QS_RUN) then - ! check if the system is charged, given Charge=... in the comment line - if (get_value(my_atoms%params,'Charge',charge)) then - call print(' CHARGE '//charge,file=input_file) - endif - lsd = .false. - if (get_value(my_atoms%params,'LSD',lsd)) then - if (lsd) call print(' LSD ',file=input_file) - endif - else - if (mod(nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))),2).ne.0) call print(' LSD',file=input_file) - if (nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))).ne.0) & - call print(' CHARGE '//nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))),file=input_file) - endif ! run_type == QS_RUN - else ! len(param%dft_file) > 0 - ! call print(' &PRINT',file=input_file) - ! call print(' &LOCALIZATION',file=input_file) - ! call print(' &LOCALIZE',file=input_file) - ! call print(' &END LOCALIZE',file=input_file) - ! call print(' &END LOCALIZATION',file=input_file) - ! call print(' &END PRINT',file=input_file) - - call print(' BASIS_SET_FILE_NAME ../BASIS_SET',file=input_file) - call print(' POTENTIAL_FILE_NAME ../POTENTIAL',file=input_file) - if (run_type.eq.QS_RUN) then - call print(' WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) - else - if (param%qmmm%reuse_wfn) then - call print(' WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) - else - call print('# WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) - endif - endif - call print(' &MGRID',file=input_file) - call print(' COMMENSURATE',file=input_file) - call print(' CUTOFF '//round(param%dft%mgrid_cutoff,1),file=input_file) !some cutoff !Ry - call print(' NGRIDS 5',file=input_file) - call print(' &END MGRID',file=input_file) - call print(' &QS',file=input_file) - call print(' EXTRAPOLATION PS',file=input_file) - call print(' EXTRAPOLATION_ORDER 1',file=input_file) - call print(' &END QS',file=input_file) - call print(' &SCF',file=input_file) - if (run_type.eq.QS_RUN) then - call print(' SCF_GUESS RESTART',file=input_file) - else - ! if (param%qmmm%wfn_reuse) then - ! call print(' SCF_GUESS RESTART',file=input_file) - ! else - call print(' SCF_GUESS '//trim(param%dft%scf_guess),file=input_file) - ! endif - endif - call print(' EPS_SCF 1.0E-6',file=input_file) - call print(' MAX_SCF 200',file=input_file) - call print(' &OUTER_SCF',file=input_file) - call print(' EPS_SCF 1.0E-6',file=input_file) - call print(' MAX_SCF 200',file=input_file) - call print(' &END',file=input_file) - call print(' &OT',file=input_file) - call print(' MINIMIZER CG',file=input_file) - call print(' PRECONDITIONER FULL_ALL',file=input_file) - ! call print('# PRECONDITIONER SPARSE_DIAG',file=input_file) - ! call print('# ENERGY_GAP 0.001',file=input_file) - call print(' &END OT',file=input_file) - call print(' &END SCF',file=input_file) - call print(' &XC',file=input_file) - call print(' &XC_FUNCTIONAL '//trim(param%dft%xc_functional),file=input_file) - call print(' &END XC_FUNCTIONAL',file=input_file) - call print(' &END XC',file=input_file) - ! in case of charged QM system use unrestricted KS and specify charge - if (run_type.eq.QS_RUN) then - call print(' &POISSON',file=input_file) - call print(' &EWALD',file=input_file) - call print(' EWALD_TYPE '//trim(param%mm_ewald%ewald_type),file=input_file) - call print(' EWALD_ACCURACY 1.E-6',file=input_file) - call print(' ALPHA '//round(param%mm_ewald%ewald_alpha,2),file=input_file) - call print(' GMAX '//param%mm_ewald%ewald_gmax,file=input_file) - call print(' &END EWALD',file=input_file) - call print(' POISSON_SOLVER PERIODIC',file=input_file) - call print(' PERIODIC XYZ',file=input_file) - call print(' &MULTIPOLE',file=input_file) - call print(' RCUT 10',file=input_file) - call print(' EWALD_PRECISION 1.E-6',file=input_file) - call print(' NGRIDS 50 50 50',file=input_file) - call print(' &INTERPOLATOR',file=input_file) - ! call print('# AINT_PRECOND SPL3_NOPBC_AINT1',file=input_file) - ! call print('# PRECOND SPL3_NOPBC_PRECOND3',file=input_file) - ! call print('# EPS_X 1.E-15',file=input_file) - ! call print('# EPS_R 1.E-15',file=input_file) - ! call print('# MAX_ITER 200',file=input_file) - call print(' &END INTERPOLATOR',file=input_file) - call print(' &END MULTIPOLE',file=input_file) - call print(' &END POISSON',file=input_file) - ! check if the system is charged, given Charge=... in the comment line - ex = .false. - ex = get_value(my_atoms%params,'Charge',charge) - if (ex) call print(' CHARGE '//charge,file=input_file) - ex = .false. - lsd = .false. - ex = get_value(my_atoms%params,'LSD',lsd) - if (ex .and. lsd) call print(' LSD ',file=input_file) - else - if (mod(nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))),2).ne.0) call print(' LSD',file=input_file) - if (nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))).ne.0) & - call print(' CHARGE '//nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))),file=input_file) - endif - end if ! dft file - call print(' &END DFT',file=input_file) - endif - - if (any(run_type.eq.(/MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - call print(' &MM',file=input_file) - call print(' &FORCEFIELD',file=input_file) - call print(' PARMTYPE '//trim(param%mm_forcefield%parmtype),file=input_file) - call print(' PARM_FILE_NAME ../'//trim(param%mm_forcefield%parm_file_name),file=input_file) ! charmm.pot - if (do_have_silica_potential) then - call print(' DANNY T',file=input_file) - call print(' DANNY_CUTOFF 5.5',file=input_file) - call print(' &SPLINE',file=input_file) - call print(' EMAX_SPLINE 0.5',file=input_file) - call print(' EMAX_ACCURACY 0.1',file=input_file) - call print(' &END SPLINE',file=input_file) - endif - -!!for old CP2K, QM/MM -! if (any(my_atoms%data%str(atom_type_index,1:my_atoms%N).eq.'CCL') .and. any(my_atoms%data%str(atom_type_index,1:my_atoms%N).eq.'CLA')) then -! call print(' &SPLINE',file=input_file) -! call print(' EMAX_SPLINE 20.',file=input_file) -! call print(' &END SPLINE',file=input_file) -! endif -!!for old CP2K, QM/MM - - if (any(my_atoms%data%str(atom_type_index,1:my_atoms%N).eq.'HFL') .or. any(my_atoms%data%str(atom_type_index,1:my_atoms%N).eq.'OFL')) then - call print(' &BEND',file=input_file) - call print(' ATOMS HFL OFL HFL',file=input_file) - call print(' K 0.074',file=input_file) - call print(' THETA0 1.87',file=input_file) - call print(' &END BEND',file=input_file) - call print(' &BOND',file=input_file) - call print(' ATOMS OFL HFL',file=input_file) - call print(' K 0.27',file=input_file) - call print(' R0 1.84',file=input_file) - call print(' &END BOND',file=input_file) -! call print('# &CHARGE',file=input_file) -! call print('# ATOM OFL',file=input_file) -! call print('# CHARGE -0.8476',file=input_file) -! call print('# &END CHARGE',file=input_file) -! call print('# &CHARGE',file=input_file) -! call print('# ATOM HFL',file=input_file) -! call print('# CHARGE 0.4238',file=input_file) -! call print('# &END CHARGE',file=input_file) - call print(' &NONBONDED',file=input_file) - call print(' &LENNARD-JONES',file=input_file) - call print(' atoms OFL OFL',file=input_file) - call print(' EPSILON 78.198',file=input_file) - call print(' SIGMA 3.166',file=input_file) - call print(' RCUT 11.4',file=input_file) - call print(' &END LENNARD-JONES',file=input_file) - call print(' &LENNARD-JONES',file=input_file) - call print(' atoms OFL HFL',file=input_file) - call print(' EPSILON 0.0',file=input_file) - call print(' SIGMA 3.6705',file=input_file) - call print(' RCUT 11.4',file=input_file) - call print(' &END LENNARD-JONES',file=input_file) - call print(' &LENNARD-JONES',file=input_file) - call print(' atoms HFL HFL',file=input_file) - call print(' EPSILON 0.0',file=input_file) - call print(' SIGMA 3.30523',file=input_file) - call print(' RCUT 11.4',file=input_file) - call print(' &END LENNARD-JONES',file=input_file) - call print(' &END NONBONDED',file=input_file) - endif - call print(' &END FORCEFIELD',file=input_file) - call print(' &POISSON',file=input_file) - call print(' &EWALD',file=input_file) - call print(' EWALD_TYPE '//trim(param%mm_ewald%ewald_type),file=input_file) - call print(' EWALD_ACCURACY 1.E-6',file=input_file) - call print(' ALPHA '//round(param%mm_ewald%ewald_alpha,2),file=input_file) - call print(' GMAX '//param%mm_ewald%ewald_gmax,file=input_file) - call print(' &END EWALD',file=input_file) - call print(' &END POISSON',file=input_file) - call print(' &END MM',file=input_file) - endif - - if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - call print(' &QMMM',file=input_file) - call print(' MM_POTENTIAL_FILE_NAME ../MM_POTENTIAL',file=input_file) - call print(' &CELL',file=input_file) - call print(' ABC '//round(param%qmmm%qmmm_cell(1),6)//' '//round(param%qmmm%qmmm_cell(2),6)//' '//round(param%qmmm%qmmm_cell(3),6),file=input_file) !some cell size for the QM region -! call print(' UNIT '//trim(param%qmmm%qmmm_cell_unit),file=input_file) !in Angstroms - call print(' PERIODIC XYZ',file=input_file) !in Angstroms - call print(' &END CELL',file=input_file) - -!!!!!!*********** -! call print('Writing QM/MM links...') - -! if (.not. assign_pointer(at, 'cut_bonds', cut_bonds_p)) & -! call system_abort("potential_calc failed to assing pointer for cut_bonds pointer") - if (assign_pointer(my_atoms,'cut_bonds',cut_bonds_p)) then - call initialise(cut_bonds,2,0,0,0,0) - do i_inner=1,my_atoms%N - do j=1,4 !MAX_CUT_BONDS - i_outer = cut_bonds_p(j,i_inner) - if (i_outer .eq. 0) exit - call append(cut_bonds,(/i_inner,i_outer/)) - enddo - enddo - - do i=1,cut_bonds%N !for each cut bond - i_inner = cut_bonds%int(1,i) - i_outer = cut_bonds%int(2,i) - call print(' &LINK',file=input_file) - call print('# ALPHA_IMOMM',file=input_file) - call print('# CORR_RADIUS',file=input_file) - call print('# FIST_SCALE_FACTOR 1.0',file=input_file) - call print(' LINK_TYPE IMOMM',file=input_file) - call print(' MM_INDEX '//i_outer,file=input_file) - call print(' QMMM_SCALE_FACTOR 1.0',file=input_file) - call print(' QM_INDEX '//i_inner,file=input_file) - call print(' QM_KIND H',file=input_file) - call print('# RADIUS',file=input_file) - !call print(' &ADD_MM_CHARGE',file=input_file) - !call print(' ALPHA',file=input_file) - !call print(' ATOM_INDEX_1',file=input_file) - !call print(' ATOM_INDEX_2',file=input_file) - !call print(' CHARGE',file=input_file) - !call print(' CORR_RADIUS',file=input_file) - !call print(' RADIUS',file=input_file) - !call print(' &END ADD_MM_CHARGE',file=input_file) - !call print(' &MOVE_MM_CHARGE',file=input_file) - !call print(' ALPHA',file=input_file) - !call print(' ATOM_INDEX_1',file=input_file) - !call print(' ATOM_INDEX_2',file=input_file) - !call print(' CORR_RADIUS',file=input_file) - !call print(' RADIUS',file=input_file) - !call print(' &END MOVE_MM_CHARGE',file=input_file) - call print(' &END LINK',file=input_file) - enddo - call finalise(cut_bonds) - endif -!!!!!!*********** - - call print(' ECOUPL '//trim(param%qmmm%ecoupl),file=input_file) !QMMM electrostatic coupling, can be NONE,COULOMB,GAUSS,S-WAVE - -! call print('Writing decoupling section...') - - call print(' &PERIODIC',file=input_file) -! call print('# GMAX 1.',file=input_file) -! call print('# REPLICA -1',file=input_file) -! call print('# NGRIDS 50 50 50',file=input_file) - call print(' &MULTIPOLE',file=input_file) - call print(' RCUT 10',file=input_file) - call print(' EWALD_PRECISION 1.E-6',file=input_file) - call print(' NGRIDS 50 50 50',file=input_file) - call print(' &INTERPOLATOR',file=input_file) -! call print('# AINT_PRECOND SPL3_NOPBC_AINT1',file=input_file) -! call print('# PRECOND SPL3_NOPBC_PRECOND3',file=input_file) -! call print('# EPS_X 1.E-15',file=input_file) -! call print('# EPS_R 1.E-15',file=input_file) -! call print('# MAX_ITER 200',file=input_file) - call print(' &END INTERPOLATOR',file=input_file) - call print(' &END MULTIPOLE',file=input_file) - call print(' &END PERIODIC',file=input_file) - - !print non default COVALENT RADII: only 0.44, 0.78, 0.80 (=default) available, use 0.44 for H, 0.78 for O - do i=1,my_atoms%N-1 - if (any(my_atoms%data%str(atom_type_index,i).eq.my_atoms%data%str(atom_type_index,i+1:my_atoms%N))) cycle - if (any(my_atoms%Z(i).eq.(/1,8/))) then - call print(' &MM_KIND '//trim(my_atoms%data%str(atom_type_index,i)),file=input_file) - if (my_atoms%Z(i).eq.1) then - call print(' RADIUS '//round(param%qmmm%radius_H,3),file=input_file) !radius of the atomic kind - else - call print(' RADIUS '//round(param%qmmm%radius_O,3),file=input_file) !radius of the atomic kind - endif - call print(' &END MM_KIND',file=input_file) -! else -! call print(trim(my_atoms%data%str(atom_type_index,i))//'is not H or O') - endif - enddo - if (any(my_atoms%Z(my_atoms%N).eq.(/1,8/))) then - call print(' &MM_KIND '//trim(my_atoms%data%str(atom_type_index,my_atoms%N)),file=input_file) - if (my_atoms%Z(my_atoms%N).eq.1) then - call print(' RADIUS '//round(param%qmmm%radius_H,3),file=input_file) !radius of the atomic kind - else - call print(' RADIUS '//round(param%qmmm%radius_O,3),file=input_file) !radius of the atomic kind - endif - call print(' &END MM_KIND',file=input_file) - endif - call print('# otherwise use default: 0.800',file=input_file) - -! call print('Writing QM list...') - allocate(list(qm_list%N)) - list=int_part(qm_list,1) - counter = 0 - - !print QM list - do j=1,total_elements - if (any(my_atoms%Z(list(1:size(list))).eq.j)) then - call print(' &QM_KIND '//ElementName(j),file=input_file) - do i=1,qm_list%N - if (my_atoms%Z(list(i)).eq.j) then - call print(' MM_INDEX '//list(i),file=input_file) - counter = counter + 1 - endif - enddo - call print(' &END QM_KIND',file=input_file) - endif - enddo - - if (size(list).ne.counter) call system_abort('cp2k_write_input: Number of QM list atoms '//size(list)// & - ' differs from the written atom numbers '//counter) - - deallocate(list) - - call print(' &END QMMM',file=input_file) - endif - -! call print(' ...lattice parameters...') - call print(' &SUBSYS',file=input_file) - - call print(' &CELL',file=input_file) - call print(' A '//round(my_atoms%lattice(1,1),6)//' '//round(my_atoms%lattice(2,1),6)//' '//round(my_atoms%lattice(3,1),6),file=input_file) - call print(' B '//round(my_atoms%lattice(1,2),6)//' '//round(my_atoms%lattice(2,2),6)//' '//round(my_atoms%lattice(3,2),6),file=input_file) - call print(' C '//round(my_atoms%lattice(1,3),6)//' '//round(my_atoms%lattice(2,3),6)//' '//round(my_atoms%lattice(3,3),6),file=input_file) -! call print(' UNIT ANGSTROM',file=input_file) !in Angstroms - if (len(trim(param%global%cell_file)) > 0) then - call initialise(cell_in_io,trim(param%global%cell_file), INPUT) - stat = 0 - do while (stat == 0) - line = read_line(cell_in_io, stat) - if (stat == 0) call print(trim(line), file=input_file) - end do - call finalise(cell_in_io) - else - call print(' PERIODIC XYZ',file=input_file) !in Angstroms - endif - call print(' &END CELL',file=input_file) - -! call print('...coordinates...') - if (run_type.eq.QS_RUN) then - call print(' &COORD',file=input_file) - do i = 1, my_atoms%N - call print(' '//ElementName(my_atoms%Z(i))//' '//round(my_atoms%pos(1,i),10)//' '//round(my_atoms%pos(2,i),10)//' '//round(my_atoms%pos(3,i),10),file=input_file) - enddo - call print(' &END COORD',file=input_file) - call print('# &VELOCITY',file=input_file) - call print('# &END VELOCITY',file=input_file) - call print(' &TOPOLOGY',file=input_file) - ! this is for an older version of CP2K. uncomment, and comment out next two lines, if your - ! version is older and complains about this statement in the input file - ! call print(' CENTER_COORDINATES',file=input_file) - call print(' &CENTER_COORDINATES T',file=input_file) - call print(' &END CENTER_COORDINATES',file=input_file) - ! - call print(' &END TOPOLOGY',file=input_file) - else - call print('# &COORD',file=input_file) - call print('# &END COORD',file=input_file) - call print('# &VELOCITY',file=input_file) - call print('# &END VELOCITY',file=input_file) - call print(' &TOPOLOGY',file=input_file) - call print(' &DUMP_PSF',file=input_file) - call print(' &END DUMP_PSF',file=input_file) - call print(' &DUMP_PDB',file=input_file) - call print(' &END DUMP_PDB',file=input_file) -! call print(' CENTER_COORDINATES',file=input_file) - call print(' &GENERATE',file=input_file) - call print(' BONDLENGTH_MAX 5.0',file=input_file) - call print(' REORDER F',file=input_file) - call print(' CREATE_MOLECULES F',file=input_file) - - ! print isolated atom list! - call print(' &ISOLATED_ATOMS',file=input_file) - do i = 1, my_atoms%N -! if ((my_atoms%connect%neighbour1(i)%N + my_atoms%connect%neighbour2(i)%N).lt.1) then -! call print(' LIST '//i,file=input_file) -! call print('Written isolated atom '//my_atoms%Z(i)//' with atom number '//i//': has no neighbour') -! cycle -! endif -! needs different name for the QM molecules, say, only the atom name could be both the res_name and the mol_name! - if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - if (any(i.eq.int_part(qm_list,1))) then - call print(' LIST '//i,file=input_file) -! call print('Written isolated atom '//my_atoms%Z(i)//' with atom number '//i//': QM atom') - cycle - endif - endif - if (any(trim(my_atoms%data%str(atom_res_name_index,i)).eq.(/'SOD','CLA'/))) then !'MCL'? - call print(' LIST '//i,file=input_file) -! call print('Written isolated atom '//my_atoms%Z(i)//' with atom number '//i//': methyl-chloride or 1 atom molecule: '//trim(my_atoms%data%str(atom_res_name_index,i))) - cycle - endif - enddo - call print(' &END ISOLATED_ATOMS',file=input_file) - - call print(' &END GENERATE',file=input_file) - call print(' CHARGE_EXTENDED',file=input_file) -! call print(' COORD_FILE_NAME '//param%wenv%pdb_file,file=input_file) -! call print(' COORDINATE PDB',file=input_file) - call print(' COORDINATE EXYZ',file=input_file) - call print(' COORD_FILE_NAME '//trim(param%wenv%exyz_file),file=input_file) - if (any(PSF_print.eq.(/DRIVER_PRINT_AND_SAVE,USE_EXISTING_PSF/))) then - call print(' CONN_FILE_NAME ../'//trim(param%wenv%psf_file),file=input_file) - call print(' CONN_FILE_FORMAT PSF',file=input_file) - endif - call print(' &END TOPOLOGY',file=input_file) - endif -! call print(' ...basis sets and potentials...') - - if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - do j = 1,100 - if (any(my_atoms%Z(1:my_atoms%N).eq.j)) then - call print(' &KIND '//ElementName(j),file=input_file) - if (get_value(param%basis_set,ElementName(j),basis_set)) then - call print(' BASIS_SET '//trim(basis_set),file=input_file) - else - call system_abort('There is no defined basis set for element '//ElementName(j)) - endif - if (get_value(param%potential,ElementName(j),potential)) then - call print(' POTENTIAL '//trim(potential),file=input_file) - else - call system_abort('There is no defined potential for element '//ElementName(j)) - endif - call print(' &END KIND',file=input_file) - endif - enddo - endif - -if (constrain_all_HSI) then - call initialise(bond_constraints,2,0,0,0,0) - do i=1,my_atoms%N - if (trim(my_atoms%data%str(atom_type_index,i)).eq.'HSI') then - nneigh = atoms_n_neighbours(my_atoms,i) -! if (nneigh.ne.1) call system_abort('HSI has '//nneigh//' neighbours') - do ineigh=1,nneigh - j = atoms_neighbour(my_atoms,i,ineigh) - if (is_nearest_neighbour(my_atoms,i,ineigh)) & - call append(bond_constraints,(/i,j/)) - enddo - endif - enddo -endif - - call print(' &END SUBSYS',file=input_file) - call print('&END FORCE_EVAL',file=input_file) - -! call print(' ...any other internal variables...') - - call print('&GLOBAL',file=input_file) - call print(' PROJECT '//trim(param%global%project),file=input_file) - call print(' RUN_TYPE '//trim(param%global%runtype),file=input_file) - call print(' PRINT_LEVEL LOW',file=input_file) - if (len(trim(param%global%global_file)) > 0) then - call initialise(global_in_io,trim(param%global%global_file), INPUT) - stat = 0 - do while (stat == 0) - line = read_line(global_in_io, stat) - if (stat == 0) call print(trim(line), file=input_file) - end do - call finalise(global_in_io) - endif - call print('&END GLOBAL',file=input_file) - call print('&MOTION',file=input_file) - -if (constrain_all_HSI) then - call print(' &CONSTRAINT',file=input_file) - call print(' &HBONDS',file=input_file) - call print(' ATOM_TYPE OSI',file=input_file) - call print(' TARGETS [angstrom] 0.978',file=input_file) - call print(' &END HBONDS',file=input_file) - call print(' &END CONSTRAINT',file=input_file) -endif - - call print(' &PRINT',file=input_file) - call print(' &FORCES',file=input_file) - call print(' FORMAT XMOL',file=input_file) - call print(' &END FORCES',file=input_file) - call print(' &END PRINT',file=input_file) - call print(' &MD',file=input_file) - call print(' ENSEMBLE '//trim(param%md%ensemble),file=input_file) !not needed,only for input check - call print(' STEPS '//param%md%steps,file=input_file) !only calculates forces and writes them - call print(' TIMESTEP '//round(param%md%timestep,2),file=input_file) !not needed, only for input check - call print(' TEMPERATURE '//round(param%md%temperature,2),file=input_file) !TEMPERATURE - call print(' TEMP_KIND',file=input_file) - call print(' &PRINT',file=input_file) - call print(' &TEMP_KIND',file=input_file) - call print(' &END TEMP_KIND',file=input_file) - call print(' &END PRINT',file=input_file) - call print(' &END MD',file=input_file) - call print('&END MOTION',file=input_file) - - call finalise(input_file) - - end subroutine write_cp2k_input_file - - - !!!!! ============================================================================================ !!!!! - !!!!! !!!!! - !!!!! \/ \/ \/ \/ \/ \/ ----- read forces and energy from CP2K output file ----- \/ \/ \/ \/ \/ \/ !!!!! - !!!!! !!!!! - !!!!! ============================================================================================ !!!!! - - !% Read the forces and the energy from the CP2K output file. - !% Check for reordering, and converts the energy units into eV, the forces to eV/A. - ! - subroutine read_cp2k_forces(forces,energy,param,my_atoms,run_type,PRINT_verbose) - - real(dp),allocatable,dimension(:,:),intent(out) :: forces - real(dp), intent(out) :: energy - type(param_cp2k), intent(in) :: param - type(Atoms), intent(in) :: my_atoms - integer, intent(in) :: run_type - logical, optional, intent(in) :: verbose - - integer :: i,j,num_atoms,m,status - type(Inoutput) :: force_file - logical :: my_verbose - character(len=1024) :: commentline - character(len=2048), dimension(10) :: fields - integer :: num_fields - type(Dictionary) :: params - logical :: energy_found - - my_verbose = .false. - if (present(verbose)) my_verbose = PRINT_verbose - - call initialise(force_file,trim(param%wenv%working_directory)//'/'//trim(param%wenv%force_file),action=INPUT,isformatted=.true.) - call print('Reading forces from file '//trim(force_file%filename)//'...') - - call parse_line(force_file,' ',fields,num_fields,status) - if (status > 0) then - call system_abort('read_cp2k_forces: Error reading from '//force_file%filename) - else if (status < 0) then - call system_abort('read_cp2k_forces: End of file when reading from '//force_file%filename) - end if - - num_atoms = string_to_int(fields(1)) - if (num_atoms.ne.my_atoms%N) call system_abort('read_cp2k_forces: different number of atoms in the force file and in the my_atoms object') - if (my_verbose) & - call print('Reading force coordinates of '//num_atoms//' atoms') - allocate(forces(3,num_atoms)) - - !read the energy from the command line - commentline = read_line(force_file) - call read_string(params, commentline) - energy_found = get_value(params, 'E',energy) - if (.not.energy_found) call system_abort('read_cp2k_forces: no energy found in '//force_file%filename//', update CP2K you are using!!') - - !read forces - do i=1,num_atoms - call parse_line(force_file,' ',fields,num_fields) - if (num_fields < 4) exit - do j = 2, 4 - forces((j-1),i) = string_to_real(fields(j)) - end do -! call print('read force for atom '//i//': '//round(forces(1,i),3)//' '//round(forces(2,i),3)//' '//round(forces(3,i),3)) - enddo - call energy_conversion(energy) - call force_conversion(forces) - call finalise(force_file) - - ! re-reorder atoms/forces in case CP2K reordered them - call read_convert_back_pos(forces,param,my_atoms,run_type=run_type,PRINT_verbose=my_verbose) - - call print('') - call print('The energy of the system: '//energy) - call verbosity_push_decrement() - call print('The forces acting on each atom (eV/A):') - call print('atom F(x) F(y) F(z)') - do m=1,size(forces,2) - call print(' '//m//' '//forces(1,m)//' '//forces(2,m)//' '//forces(3,m)) - enddo - call verbosity_pop() - call print('Sum of the forces: '//sum(forces(1,1:num_atoms))//' '//sum(forces(2,1:num_atoms))//' '//sum(forces(3,1:num_atoms))) - -! if (any(abs(forces(1:3,1:my_atoms%N)).gt.(4.21648784E-02*HARTREE/BOHR))) & -! call print('at least one too large force') - - end subroutine read_cp2k_forces - - !% Re-reordering algorithm. CP2K shifts the atomic coordinates, occasionally - !% reorders the atoms, too. To keep this under control, the positions are read - !% and compared with the atoms object. - !% Calculates the shift the same way CP2K does. - !% As an output the forces are in the same order as the atoms in the original - !% atoms object. - ! - subroutine read_convert_back_pos(forces,param,my_atoms,run_type,PRINT_verbose) - - real(dp), allocatable, dimension(:,:), intent(inout) :: forces - type(param_cp2k), intent(in) :: param - type(Atoms), intent(in) :: my_atoms - integer, intent(in) :: run_type - logical, optional, intent(in) :: verbose - - type(InOutput) :: pos - type(Atoms) :: reordered - type(Table) :: qm_list - real(dp), dimension(3) :: shift - integer, allocatable, dimension(:) :: oldpos - real(dp), allocatable, dimension(:,:) :: tforces - integer :: i, j, status - logical :: my_verbose -integer, pointer :: cut_bonds_p(:,:) -integer :: i_inner, i_outer - - if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & - call system_abort('read_convert_back_matrix: Run type is not recognized: '//run_type) - - my_verbose = optional_default(.false.,PRINT_verbose) - if (my_verbose) & - call print_title('Reading matrix of new atomic coordinates from CP2K output') - - ! Getting the oldpos matrix from *-pos-* file... - call initialise(pos,filename=trim(param%wenv%working_directory)//'/'//trim(param%wenv%pos_file)) - - call print('Reading possibly reordered atoms from file '//pos%filename) - call read_xyz(reordered,pos,status=status) - if (status.ne.0) call system_abort('no atoms could be read from file '//pos%filename) - if (reordered%N.ne.my_atoms%N) call system_abort('different number of atoms in the original and reordered atoms object') - - allocate(oldpos(my_atoms%N)) - oldpos = 0 - - !match the atoms in the 2 atoms object to obtain the oldpos list - - ! shifted cell in case of QMMM (cp2k/src/topology_coordinate_util.F) - if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then - call get_qm_list_int_rec(my_atoms,run_type,qm_list,do_recursive=.true.) - !add links to the qm list, if there is any: - if (assign_pointer(my_atoms,'cut_bonds',cut_bonds_p)) then - do i_inner=1,my_atoms%N - do j=1,4 !MAX_CUT_BONDS - i_outer = cut_bonds_p(j,i_inner) - if (i_outer .eq. 0) exit - call append(qm_list,(/i_outer,0,0,0/)) - enddo - enddo - endif - do i=1,3 - shift(i) = 0.5_dp * param%qmmm%qmmm_cell(i) & - - ( MINVAL(my_atoms%pos(i,int_part(qm_list,1))) + & - MAXVAL(my_atoms%pos(i,int_part(qm_list,1))) ) * 0.5_dp - enddo - else - shift = 0._dp - endif - - ! try to get reordering using default shift - do i=1,my_atoms%N - do j=1,reordered%N -! if ((my_atoms%pos(1:3,i)+shift).feq.reordered%pos(1:3,j)) then - if (matrix_feq2(my_atoms%pos(1:3,i)+shift,reordered%pos(1:3,j))) then -! call print('atom '//i//' became atom '//j) - oldpos(i) = j - exit - endif - enddo - enddo - - ! if failed, try reordering again with shift of a/2 b/2 c/2 (in case user set TOPOLOGY%CENTER_COORDINATES) - if (any(oldpos.eq.0) .and. run_type .eq. QS_RUN) then - shift = sum(my_atoms%lattice(:,:),2)/2.0_dp - & - (minval(my_atoms%pos(:,:),2)+maxval(my_atoms%pos(:,:),2))/2.0_dp - do i=1,my_atoms%N - do j=1,reordered%N - ! if ((my_atoms%pos(1:3,i)+shift).feq.reordered%pos(1:3,j)) then - if (matrix_feq2(my_atoms%pos(1:3,i)+shift,reordered%pos(1:3,j))) then - ! call print('atom '//i//' became atom '//j) - oldpos(i) = j - exit - endif - enddo - enddo - endif - - if (any(oldpos.eq.0)) then - call system_abort('could not match the 2 atoms objects') - endif - - call finalise(pos) - ! End of getting the oldpos matrix from *-pos-* file... - - allocate(tforces(3,my_atoms%N)) - tforces = 0. - do i=1,my_atoms%N - tforces(1:3,oldpos(i)) = forces(1:3,i) - enddo - - forces = tforces - - deallocate(tforces) - deallocate(oldpos) - end subroutine read_convert_back_pos - - !% Force mixing with energy conservation. The fitlist includes the core and buffer atoms. - !% Mass weights are used. - ! - subroutine QUIP_combine_forces(qmmm_forces,mm_forces,combined_forces,my_atoms) - ! use momentum conservation DOES NOT ASSUME that SUM(F(MM)) = 0._dp: - ! for fitlist: F_i = F(MM) - m_i * SUMcore(F_i) / SUMfitlist(m_i) - ! for QM core: F_i = F(QM/MM) - m_i * SUMcore(F_i) / SUMfitlist(m_i) - ! for MM atoms: F_i = F(MM) - ! inner qm_list should be a reordered qm_list !! - ! wrk1 should be written into file !! - - real(dp), allocatable, dimension(:,:), intent(in) :: qmmm_forces - real(dp), allocatable, dimension(:,:), intent(in) :: mm_forces - real(dp), allocatable, dimension(:,:), intent(out) :: combined_forces - type(Atoms), intent(in) :: my_atoms - - integer :: i_atom,m - real(dp),dimension(3) :: force_corr - real(dp) :: mass_corr - type(Table) :: core, fitlist - - if (size(qmmm_forces,2).ne.my_atoms%N.or.size(mm_forces,2).ne.my_atoms%N) call system_abort('combine_forces: the size of QMMM and/or MM forces is different: different number of atoms') - - call get_qm_list_int(my_atoms,1,core) - call get_qm_list_int_rec(my_atoms,2,fitlist, do_recursive=.true.) - - force_corr = 0._dp - mass_corr = 0._dp - allocate(combined_forces(3,my_atoms%N)) - combined_forces = 0._dp - - force_corr = sum(mm_forces,2) !this can be deleted if SUM(F(MM)) = 0._dp - force_corr = force_corr + sum((qmmm_forces(1:3,int_part(core,1))-mm_forces(1:3,int_part(core,1))),2) - mass_corr = sum(ElementMass(my_atoms%Z(int_part(fitlist,1)))) - - force_corr = force_corr / mass_corr - call print('Force mixing: the force correction is '//force_corr(1)//' '//force_corr(2)//' '//force_corr(3)) - - combined_forces(1:3,1:my_atoms%N) = mm_forces(1:3,1:my_atoms%N) - combined_forces(1:3,int_part(core,1)) = qmmm_forces(1:3,int_part(core,1)) - do i_atom=1,my_atoms%N - if (any(int_part(fitlist,1).eq.i_atom)) combined_forces(1:3,i_atom) = combined_forces(1:3,i_atom) - ElementMass(my_atoms%Z(i_atom)) * force_corr - enddo - - call print('') - call print('No energy after force mixing.') - call verbosity_push_decrement() - call print('The forces acting on each atom (eV/A):') - call print('atom F(x) F(y) F(z)') - do m=1,size(combined_forces,2) - call print(' '//m//' '//combined_forces(1,m)//' '//combined_forces(2,m)//' '//combined_forces(3,m)) - enddo - call verbosity_pop() - call print('Sum of the combined forces: '//sum(combined_forces(1,1:my_atoms%N))//' '//sum(combined_forces(2,1:my_atoms%N))//' '//sum(combined_forces(3,1:my_atoms%N))) - - - end subroutine QUIP_combine_forces - - !% Abrupt force mixing. The fitlist includes the core and buffer atoms. - !% Uniform weights are used. - ! - subroutine abrupt_force_mixing(qmmm_forces,mm_forces,combined_forces,my_atoms) - ! do not use momentum conservation - ! for QM core: F_i = F(QM/MM) - ! else: F_i = F(MM) - - real(dp), allocatable, dimension(:,:), intent(in) :: qmmm_forces - real(dp), allocatable, dimension(:,:), intent(in) :: mm_forces - real(dp), allocatable, dimension(:,:), intent(out) :: combined_forces - type(Atoms), intent(in) :: my_atoms - - integer :: m - type(Table) :: core, fitlist - - if (size(qmmm_forces,2).ne.my_atoms%N.or.size(mm_forces,2).ne.my_atoms%N) call system_abort('combine_forces: the size of QMMM and/or MM forces is different: different number of atoms') - - call get_qm_list_int(my_atoms,1,core) - - allocate(combined_forces(3,my_atoms%N)) - combined_forces = 0._dp - - combined_forces(1:3,1:my_atoms%N) = mm_forces(1:3,1:my_atoms%N) - combined_forces(1:3,int_part(core,1)) = qmmm_forces(1:3,int_part(core,1)) - - call print('') - call print('No energy after force mixing.') -! call verbosity_push_decrement() - call print('The forces acting on each atom (eV/A):') - call print('atom F(x) F(y) F(z)') - do m=1,size(combined_forces,2) - call print(' '//m//' '//combined_forces(1,m)//' '//combined_forces(2,m)//' '//combined_forces(3,m)) - enddo -! call verbosity_pop() - call print('Sum of the combined forces: '//sum(combined_forces(1,1:my_atoms%N))//' '//sum(combined_forces(2,1:my_atoms%N))//' '//sum(combined_forces(3,1:my_atoms%N))) - - - end subroutine abrupt_force_mixing - - !% Calculates the force on the $i$th atom due to an external potential that has - !% the form of a spline, $my_spline$. - ! - function spline_force(at, i, my_spline, pot) result(force) - - type(Atoms), intent(in) :: at - integer, intent(in) :: i - type(spline_pot), intent(in) :: my_spline - real(dp), optional, intent(out) :: pot - real(dp), dimension(3) :: force - - real(dp) :: dist, factor - -! dist = distance from the origin -! spline: f(dist) = spline%dpot/(spline%from-spline%to)**3._dp * (dist-spline%to)**2._dp * (3._dp*spline%from - spline%to - 2._dp*dist) -! f(spline%from) = spline%dpot; f(spline%to) = 0. -! f`(spline%from) = 0.; f`(spline%to) = 0. -! force = - grad f(dist) - - dist = distance_min_image(at,i,(/0._dp,0._dp,0._dp/)) - if (dist.ge.my_spline%to .or. dist.le.my_spline%from) then - force = 0._dp - if (present(pot)) then - if (dist.ge.my_spline%to) pot = 0._dp - if (dist.le.my_spline%from) pot = my_spline%dpot - endif - else - factor = 1._dp - ! force on H should be 1/16 times the force on O, to get the same acc. - if (at%Z(i).eq.1) factor = ElementMass(1)/ElementMass(8) - force = - factor * 2._dp *my_spline%dpot / ((my_spline%from - my_spline%to)**3._dp * dist) * & - ( (3._dp * my_spline%from - my_spline%to - 2._dp * dist) * (dist - my_spline%to) & - - (dist - my_spline%to)**2._dp ) * at%pos(1:3,i) - if (present(pot)) pot = my_spline%dpot/(my_spline%from-my_spline%to)**3._dp * (dist-my_spline%to)**2._dp * (3._dp*my_spline%from - my_spline%to - 2._dp*dist) - endif - - end function spline_force - -! subroutine combine_forces(qmmm_forces,mm_forces,combined_forces,qmlist,my_atoms) -! ! use momentum conservation: -! ! for QM atoms: F_corr,i = m_i * SUMall(F_i) / SUMqm(m_i) -! ! for MM atoms: F_corr,i = 0 -! ! inner qm_list should be a reordered qm_list !! -! ! wrk1 should be written into file !! -! -! real(dp), allocatable, dimension(:,:), intent(in) :: qmmm_forces -! real(dp), allocatable, dimension(:,:), intent(in) :: mm_forces -! real(dp), allocatable, dimension(:,:), intent(out) :: combined_forces -! type(Table), intent(in) :: qmlist -! type(Atoms), intent(in) :: my_atoms -! -! integer :: i_atom -! real(dp),dimension(3) :: force_corr -! real(dp) :: mass_corr -! -! if (size(qmmm_forces,2).ne.my_atoms%N.or.size(mm_forces,2).ne.my_atoms%N) call system_abort('combine_forces: the size of QMMM and/or MM forces is different: different number of atoms') -! if (any(int_part(qmlist,1).gt.my_atoms%N).or.any(int_part(qmlist,1).lt.1)) call system_abort('combine_forces: QM atom out of range 1-'//my_atoms%N) -! -! force_corr = 0._dp -! mass_corr = 0._dp -! allocate(combined_forces(3,my_atoms%N)) -! combined_forces = 0._dp -! -! combined_forces(1:3,1:my_atoms%N) = mm_forces(1:3,1:my_atoms%N) -! combined_forces(1:3,int_part(qmlist,1)) = qmmm_forces(1:3,int_part(qmlist,1)) -! force_corr = sum(combined_forces,2) -! mass_corr = sum(ElementMass(my_atoms%Z(int_part(qmlist,1)))) -! -! force_corr = force_corr / mass_corr -! -! do i_atom=1,my_atoms%N -! if (any(int_part(qmlist,1).eq.i_atom)) combined_forces(1:3,i_atom) = qmmm_forces(1:3,i_atom) - ElementMass(my_atoms%Z(i_atom)) * force_corr -! enddo -! -! end subroutine combine_forces - - !% Energy conversion from hartree (used by CP2K) to eV. - ! - subroutine energy_conversion(energy) - - real(dp), intent(inout) :: energy - - energy = energy * HARTREE - - end subroutine energy_conversion - - !% Force conversion from hartree/bohr (used by CP2K) to eV/A. - ! - subroutine force_conversion(force) - - real(dp), dimension(:,:), intent(inout) :: force - integer :: i - - if (size(force,2).le.0) call system_abort('force_conversion: no forces!') - if (size(force,1).ne.3) call system_abort('force_conversion: '//size(force,1)//' components of force instead of 3') - - do i=1,size(force,2) - force(1:3,i) = force(1:3,i) * HARTREE / BOHR - enddo - - end subroutine force_conversion - - !% Velocity conversion from hartree*bohr/hbar (used by CP2K) to A/fs. - ! - subroutine velocity_conversion(at) - - type(Atoms), intent(inout) :: at - integer :: i - - if (.not.associated(at%velo)) call system_abort('velocity_conversion: no velocities!') - - do i=1,at%N - at%velo(1:3,i) = at%velo(1:3,i) * (HARTREE * BOHR / HBAR) - enddo - - end subroutine velocity_conversion - - !% Velocity conversion from A/fs to hartree*bohr/hbar (used by CP2K). - ! - subroutine velocity_conversion_rev(at) - - type(Atoms), intent(inout) :: at - integer :: i - - if (.not.associated(at%velo)) call system_abort('velocity_conversion: no velocities!') - - do i=1,at%N - at%velo(1:3,i) = at%velo(1:3,i) / (HARTREE * BOHR / HBAR) - enddo - - end subroutine velocity_conversion_rev - - !% Floating point logical comparison used by read_convert_back_pos, - !% to compare atoms objects positions. - ! - function real_feq2(x,y) result(feq) - - real(dp), intent(in) :: x, y - logical :: feq - - if (abs(x-y) > EPSILON_ZERO) then - feq = .false. - else - feq = .true. - end if - - end function real_feq2 - - !% Matrix floating point logical comparison used by read_convert_back_pos, - !% to compare atoms objects positions. - ! - function matrix_feq2(matrix1,matrix2) result (feq) - real(dp),intent(in), dimension(:) :: matrix1 - real(dp),intent(in), dimension(:) :: matrix2 - - integer::j - logical::feq - - call check_size('Matrix2',matrix2,shape(matrix1),'Matrix_FEQ') - - feq =.true. - do j=1,size(matrix1) - if (.not.real_feq2(matrix1(j),matrix2(j))) then - feq=.false. - return - end if - end do - - end function matrix_feq2 - - !!!!! ============================================================================================ !!!!! - !!!!! !!!!! - !!!!! \/ \/ \/ \/ \/ \/ ------------------- create region ------------------- \/ \/ \/ \/ \/ \/ !!!!! - !!!!! !!!!! - !!!!! ============================================================================================ !!!!! - - - !% Updates the core QM flags saved in $hybrid$ and $hybrid_mark$ properties. - !% Do this hysteretically, from $R_inner$ to $R_outer$ around $origin$, that is - !% the centre of the QM region. - ! - subroutine create_centred_qmcore(my_atoms,R_inner,R_outer,origin,use_avgpos,add_only_heavy_atoms,nneighb_only,min_images_only,list_changed) - - type(Atoms), intent(inout) :: my_atoms - real(dp), intent(in) :: R_inner - real(dp), intent(in) :: R_outer - real(dp), optional, intent(in) :: origin(3) - logical, optional, intent(in) :: use_avgpos, add_only_heavy_atoms, nneighb_only, min_images_only - logical, optional, intent(out) :: list_changed - - type(Atoms) :: atoms_for_add_cut_hydrogens - type(Table) :: inner_list, outer_list, core, core1, ext_qmlist - integer :: qm_flag_index, i - real(dp) :: my_origin(3) - - my_origin = optional_default((/0._dp,0._dp,0._dp/),origin) - - call map_into_cell(my_atoms) - - call allocate(core,4,0,0,0,0) - call allocate(core1,4,0,0,0,0) - call get_qm_list_int(my_atoms,1,core1,int_property='hybrid_mark') - call get_qm_list_int(my_atoms,1,core,int_property='hybrid_mark') - call get_qm_list_int_rec(my_atoms,2,ext_qmlist, do_recursive=.true.,int_property='hybrid_mark') - -!Build the hysteretic QM core: - call construct_hysteretic_region(region=core,at=my_atoms,centre=my_origin,loop_atoms_no_connectivity=.true., & - inner_radius=R_inner,outer_radius=R_outer, use_avgpos=use_avgpos, add_only_heavy_atoms=add_only_heavy_atoms, & - nneighb_only=nneighb_only, min_images_only=min_images_only, debugfile=mainlog) -! call construct_buffer_origin(my_atoms,R_inner,inner_list,my_origin) -! call construct_buffer_origin(my_atoms,R_outer,outer_list,my_origin) -! call construct_region(my_atoms,R_inner,inner_list,centre=my_origin,use_avgpos=.false.,add_only_heavy_atoms=.false., with_hops=.false.) -! call construct_region(my_atoms,R_outer,outer_list,centre=my_origin,use_avgpos=.false.,add_only_heavy_atoms=.false., with_hops=.false.) - -! call select_hysteretic_quantum_region(my_atoms,inner_list,outer_list,core) -! call finalise(inner_list) -! call finalise(outer_list) - -!TO BE OPTIMIZED : add avgpos to add_cut_hydrogen - ! add cut hydrogens, according to avgpos - atoms_for_add_cut_hydrogens = my_atoms - atoms_for_add_cut_hydrogens%oldpos = my_atoms%avgpos - atoms_for_add_cut_hydrogens%avgpos = my_atoms%avgpos - atoms_for_add_cut_hydrogens%pos = my_atoms%avgpos - call set_cutoff(atoms_for_add_cut_hydrogens,DEFAULT_NNEIGHTOL) - call calc_connect(atoms_for_add_cut_hydrogens) - call add_cut_hydrogens(atoms_for_add_cut_hydrogens,core) - !call print('Atoms in hysteretic quantum region after adding the cut hydrogens:') - !do i=1,core%N - ! call print(core%int(1,i)) - !enddo - call finalise(atoms_for_add_cut_hydrogens) - - ! check changes in QM list and set the new QM list - if (present(list_changed)) then - list_changed = check_list_change(old_list=core1,new_list=core) - if (list_changed) call print('QM list around the origin has changed') - endif - - ! update QM_flag of my_atoms - qm_flag_index = get_property(my_atoms,'hybrid_mark') - my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 - my_atoms%data%int(qm_flag_index,int_part(ext_qmlist,1)) = 2 - my_atoms%data%int(qm_flag_index,int_part(core,1)) = 1 - - ! update hybrid property of my_atoms - qm_flag_index = get_property(my_atoms,'hybrid') - my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 - my_atoms%data%int(qm_flag_index,int_part(core,1)) = 1 - - call finalise(core) - call finalise(core1) - call finalise(ext_qmlist) - - end subroutine create_centred_qmcore - - -! subroutine construct_buffer_origin(my_atoms,Radius,list,origin) -! -! type(Atoms), intent(inout) :: my_atoms -! real(dp), intent(in) :: Radius -! type(Table), intent(out) :: list -! real(dp), optional, intent(in) :: origin(3) -! -! integer :: i -! real(dp) :: my_origin(3) -! logical :: buffer_general, do_general -! -! my_origin = optional_default((/0._dp,0._dp,0._dp/),origin) -! -! call initialise(list,4,0,0,0,0) -! -! if (get_value(my_atoms%params,'Buffer_general',do_general)) then -! call print('Found Buffer_general in atoms%params'//do_general) -! buffer_general=do_general -! else -! call print('not Found Buffer_general in atoms%params set to F') -! buffer_general=.false. -! endif -! -! do i = 1,my_atoms%N -! if (.not.buffer_general) then -! if (my_atoms%Z(i).eq.1) cycle -! endif -! if (distance_min_image(my_atoms,i,my_origin(1:3)).lt.Radius) call append(list,(/i,0,0,0/)) -! enddo -! -! end subroutine construct_buffer_origin -! -! -! function extend_qmlist(my_atoms,R_inner,R_outer) result(list_changed) -! -! type(Atoms), intent(inout) :: my_atoms -! real(dp), optional, intent(in) :: R_inner, R_outer !! to select hysteretic quantum region -! -! real(dp) :: inner, outer -! type(Table) :: inner_buffer, outer_buffer -! type(Table) :: core, ext_qmlist, old_ext_qmlist -! type(Atoms) :: fake, atoms_for_add_cut_hydrogens -! integer :: qm_flag_index, i -! logical :: list_changed,buffer_general,do_general -! -! ! checking the optional inputs -! if (present(R_inner)) then -! inner = R_inner -! if (present(R_outer)) then -! outer = R_outer -! call print('Updating QM_flag properties according to R_inner = '//round(R_inner,3)//', R_outer = '//round(R_outer,3)) -! else -! call print('Warning: extend_qmlist: R_inner present, but not R_outer! Use R_outer=R_inner!') -! outer = R_inner -! endif -! else -! if (present(R_outer)) then -! call print('Warning: extend_qmlist: R_outer present, but not R_inner! Use R_inner=R_outer!') -! inner = R_outer -! outer = R_outer -! else -! call print('Warning: extend_qmlist: R_inner and R_outer not present! qm_list will not be extended!') -! return -! endif -! endif -! -! call get_qm_list_int(my_atoms,1,core) -! call get_qm_list_int_rec(my_atoms,2,ext_qmlist, do_recursive=.true.) -! call get_qm_list_int_rec(my_atoms,2,old_ext_qmlist, do_recursive=.true.) -! -!!TO BE OPTIMIZED: -! ! extend the qm region > ext_qmlist -! !this should go without fake atoms and with use_avgpos! but not the cluster making, only the add_cut_hydrogen! -! fake=my_atoms -!! cutoff_old = my_atoms%cutoff -! call set_cutoff_minimum(fake,outer*(maxval(ElementCovRad(fake%Z(1:fake%N)))/ElementCovRad(8))) ! to find everything like O -! call calc_connect(fake) -! -! if (get_value(my_atoms%params,'Buffer_general',do_general)) then -! call print('Found Buffer_general in atoms%params'//do_general) -! buffer_general=do_general -! else -! call print('not Found Buffer_general in atoms%params set to F') -! buffer_general=.false. -! endif -! -! if (buffer_general) then -! call print('Not element specific buffer selection') -! call construct_buffer(fake,core,inner,inner_buffer,use_avgpos=.false.,verbosity=PRINT_NORMAL) -! !call print('Atoms in inner buffer:') -! !do i=1,inner_buffer%N -! ! call print(inner_buffer%int(1,i)) -! !enddo -! call construct_buffer(fake,core,outer,outer_buffer,use_avgpos=.false.,verbosity=PRINT_NORMAL) -! !call print('Atoms in outer buffer:') -! !do i=1,outer_buffer%N -! ! call print(outer_buffer%int(1,i)) -! !enddo -! !call print('Atoms in the quantum region before updating:') -! !do i=1,ext_qmlist%N -! ! call print(ext_qmlist%int(1,i)) -! !enddo -! else -! call print('Element specific buffer selection, only heavy atoms count') -! call construct_buffer_RADIUS(fake,core,inner,inner_buffer,use_avgpos=.false.,verbosity=PRINT_NORMAL) -! !call print('Atoms in inner buffer:') -! !do i=1,inner_buffer%N -! ! call print(inner_buffer%int(1,i)) -! !enddo -! call construct_buffer_RADIUS(fake,core,outer,outer_buffer,use_avgpos=.false.,verbosity=PRINT_NORMAL) -! !call print('Atoms in outer buffer:') -! !do i=1,outer_buffer%N -! ! call print(outer_buffer%int(1,i)) -! !enddo -! !call print('Atoms in the quantum region before updating:') -! !do i=1,ext_qmlist%N -! ! call print(ext_qmlist%int(1,i)) -! !enddo -! endif -! call select_hysteretic_quantum_region(fake,inner_buffer,outer_buffer,ext_qmlist,verbosity=PRINT_NORMAL) -! !call print('Atoms in hysteretic quantum region:') -! !do i=1,ext_qmlist%N -! ! call print(ext_qmlist%int(1,i)) -! !enddo -! call finalise(fake) -! call finalise(inner_buffer) -! call finalise(outer_buffer) -! -! ! add cut hydrogens, according to avgpos -! atoms_for_add_cut_hydrogens = my_atoms -! atoms_for_add_cut_hydrogens%oldpos = my_atoms%avgpos -! atoms_for_add_cut_hydrogens%avgpos = my_atoms%avgpos -! atoms_for_add_cut_hydrogens%pos = my_atoms%avgpos -! call set_cutoff(atoms_for_add_cut_hydrogens,0._dp) -! call calc_connect(atoms_for_add_cut_hydrogens) -! call add_cut_hydrogens(atoms_for_add_cut_hydrogens,ext_qmlist) -! !call print('Atoms in hysteretic quantum region after adding the cut hydrogens:') -! !do i=1,ext_qmlist%N -! ! call print(ext_qmlist%int(1,i)) -! !enddo -! call finalise(atoms_for_add_cut_hydrogens) -! -! ! check changes in QM list and set the new QM list -! list_changed = check_list_change(old_list=old_ext_qmlist,new_list=ext_qmlist) -! -! ! update QM_flag of my_atoms -! qm_flag_index = get_property(my_atoms,'QM_flag') -! my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 -! my_atoms%data%int(qm_flag_index,int_part(ext_qmlist,1)) = 2 -! my_atoms%data%int(qm_flag_index,int_part(core,1)) = 1 -! -! call finalise(core) -! call finalise(ext_qmlist) -! call finalise(old_ext_qmlist) -! -! end function extend_qmlist -! -! -! subroutine construct_buffer_RADIUS(my_atoms,core,radius,buffer,use_avgpos,verbosity) -! -! type(Atoms), intent(in) :: my_atoms -! real(dp), intent(in) :: radius -! type(Table), intent(in) :: core -! type(Table), intent(out) :: buffer -! logical, optional, intent(in) :: use_avgpos -! integer, optional, intent(in) :: verbosity -! -! integer :: i,j -! logical :: delete_it -! -! call construct_buffer(my_atoms,core,(radius*maxval(ElementCovRad(my_atoms%Z(1:my_atoms%N)))/ElementCovRad(8)),buffer,use_avgpos=use_avgpos,verbosity=verbosity) -! !call print('Atoms in buffer:') -! !do i=1,buffer%N -! ! call print(buffer%int(1,i)) -! !enddo -! -! i = 1 -! do while (i.le.buffer%N) -! delete_it = .true. -! if (any(buffer%int(1,i).eq.core%int(1,1:core%N))) then ! keep core -! delete_it = .false. -! else -! if (my_atoms%Z(buffer%int(1,i)).ne.1) then ! delete Hs from buffer -! do j=1,core%N -! if (my_atoms%Z(core%int(1,j)).eq.1) cycle ! only consider nonH -- nonH distances -! if (distance_min_image(my_atoms,buffer%int(1,i),core%int(1,j)).le. & -! radius / (ElementCovrad(8) + ElementCovRad(8)) * (ElementCovRad(my_atoms%Z(buffer%int(1,i))) + ElementCovRad(my_atoms%Z(core%int(1,j))))) then -! delete_it = .false. -! !call print('Atom '//ElementName(my_atoms%Z(buffer%int(1,i)))//buffer%int(1,i)//' is within element specific buffer distance '//round(distance_min_image(my_atoms,buffer%int(1,i),core%int(1,j)),3)//' < '//round(radius / (ElementCovrad(8) + ElementCovRad(8)) * (ElementCovRad(my_atoms%Z(buffer%int(1,i))) + ElementCovRad(my_atoms%Z(core%int(1,j)))),3)) -! endif -! enddo -! endif -! endif -! if (delete_it) then -! !call print('delete atom '//ElementName(my_atoms%Z(buffer%int(1,i)))//buffer%int(1,i)//'from buffer') -! call delete(buffer,i) -! i = i - 1 -! endif -! i = i + 1 -! enddo -! -! end subroutine construct_buffer_RADIUS - -end module cp2k_driver_module diff --git a/src/FilePot_drivers/cp2k_filepot_old.f95 b/src/FilePot_drivers/cp2k_filepot_old.f95 deleted file mode 100644 index 450634557f..0000000000 --- a/src/FilePot_drivers/cp2k_filepot_old.f95 +++ /dev/null @@ -1,259 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X cp2k_filepot program -!X -!% outdated filepot program for CP2K driver using hard-coded input file -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!FilePotential for the CP2K driver -!FilePot uses go_cp2k from the cp2k_driver_module -!reads filepot.0.xyz >> runs CP2K >> writes filepot.0.out with forces - -!Initialisation: -!For QS or MM calculation: -! call initialise(CP2K_pot,'FilePot command=/Users/csilla/QUIP/build.darwin_x86_64_g95/cp2k_filepot property_list=pos min_cutoff=0.0') -!For QM/MM calculation: -! call initialise(CP2K_pot,'FilePot command=/Users/csilla/QUIP/build.darwin_x86_64_g95/cp2k_filepot property_list=pos:QM_flag min_cutoff=0.0') - -!Calc (args_str is the same as for go_cp2k): -! call calc(CP2K_pot,ds%atoms,energy=energy,forces=f1,args_str=trim(args_str)) - - -program cp2k_filepot - - use libatoms_module - use cp2k_driver_module - use potential_module -! use atoms_module -! use topology_module - - implicit none - - type(Atoms) :: my_atoms - real(dp) :: energy - real(dp), allocatable :: f0(:,:) - real(dp), pointer :: forces_p(:,:) - type(InOutput) :: xyz - - !Input - type(Dictionary) :: params_in - character(len=STRING_LENGTH) :: args_str - character(len=STRING_LENGTH) :: Run_Type - character(len=STRING_LENGTH) :: Print_PSF - character(len=STRING_LENGTH) :: coord_file - character(len=STRING_LENGTH) :: new_coord_file - character(len=STRING_LENGTH) :: cp2k_program - character(len=STRING_LENGTH) :: fileroot_str - character(len=STRING_LENGTH) :: basis_set_file, potential_file, dft_file, global_file, cell_file - logical :: clean_up_files -! logical :: Delete_Metal_Connections - type(Table) :: intrares_impropers -logical :: have_silica_potential -logical :: QM_list_changed -logical :: dummy -integer, pointer :: old_cluster_mark_p(:), cluster_mark_p(:) -integer :: i - real(dp),dimension(3) :: old_QM_cell -! call system_initialise(verbosity=PRINT_SILENT,enable_timing=.true.) - call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) - call system_timer('program') - - !read parameters - call initialise(params_in) - basis_set_file='' - cell_file='' - dft_file='' - global_file='' - call param_register(params_in, 'Run_Type', 'MM', Run_Type, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'PSF_Print', 'NO_PSF', Print_PSF, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'coord_file', 'filepot.0.xyz',coord_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'new_coord_file', 'filepot.0.out',new_coord_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'cp2k_program', 'cp2k_serial',cp2k_program, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'root', '', fileroot_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'basis_set_file', '', basis_set_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'potential_file', '', potential_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'dft_file', '', dft_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'global_file', '', global_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'cell_file', '', cell_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'clean_up_files', 'T', clean_up_files, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'have_silica_potential', 'F', have_silica_potential, help_string="No help yet. This source file was $LastChangedBy$") -! call param_register(params_in, 'Delete_Metal_Connections', 'T', Delete_Metal_Connections, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not.param_read_args(params_in,ignore_unknown=.true.,task='cp2k_filepot args_str')) then - call system_abort('could not parse argument line') - end if - - call finalise(params_in) - - !print parameters - call print('Run parameters:') - call print(' Run_Type '//trim(Run_Type)) - call print(' PSF_Print '//trim(Print_PSF)) - call print(' coord_file '//trim(coord_file)) - call print(' new_coord_file '//trim(new_coord_file)) - call print(' cp2k_program '//trim(cp2k_program)) - call print(' root '//trim(fileroot_str)) - call print(' basis_set_file '//trim(basis_set_file)) - call print(' potential_file '//trim(potential_file)) - call print(' dft_file '//trim(dft_file)) - call print(' global_file '//trim(global_file)) - call print(' cell_file '//trim(cell_file)) - call print(' have_silica_potential '//have_silica_potential) - call print('---------------------------------------') - call print('') - -! starts here - - call read_xyz(my_atoms,coord_file) - - !create connectivity & topology - if (have_silica_potential) then - call set_cutoff(my_atoms,SILICA_2body_CUTOFF) - else - call set_cutoff(my_atoms,0._dp) - endif - call calc_connect(my_atoms) -! if (Delete_Metal_Connections) call delete_metal_connects(my_atoms) - call map_into_cell(my_atoms) - call calc_dists(my_atoms) - if (trim(Run_Type).ne.'QS') then - call create_CHARMM(my_atoms,do_CHARMM=.true.,intrares_impropers=intrares_impropers) - endif - -if (trim(Run_Type).eq.'QMMM_CORE') call system_abort('not yet tested.') -if ((trim(Run_Type).eq.'QMMM_EXTENDED').or.& - (trim(Run_Type).eq.'QMMM_CORE')) then - if (.not.has_property(my_atoms, 'old_cluster_mark')) call system_abort('no old_cluster_mark') - if (.not.has_property(my_atoms, 'cluster_mark')) call system_abort('no cluster_mark') - - dummy = assign_pointer(my_atoms, 'old_cluster_mark', old_cluster_mark_p) - dummy = assign_pointer(my_atoms, 'cluster_mark', cluster_mark_p) - -QM_list_changed = .false. - do i=1,my_atoms%N - if (old_cluster_mark_p(i).ne.cluster_mark_p(i)) then - if (any((/old_cluster_mark_p(i),cluster_mark_p(i)/).eq.HYBRID_NO_MARK) .or. & - any((/old_cluster_mark_p(i),cluster_mark_p(i)/).eq.HYBRID_TERM_MARK) ) then - QM_list_changed = .true. - endif - endif - enddo - call set_value(my_atoms%params,'QM_list_changed',QM_list_changed) -call print('set_value QM_list_changed '//QM_list_changed) - -endif - !generate args_str for go_cp2k - write (args_str,'(a)') 'Run_Type='//trim(Run_Type)//' PSF_Print='//trim(Print_PSF) - if (trim(cp2k_program).ne.'') args_str = trim(args_str)//' cp2k_program='//trim(cp2k_program) - if (trim(fileroot_str).ne.'') args_str = trim(args_str)//' root='//trim(fileroot_str) - if (trim(basis_set_file).ne.'') args_str = trim(args_str)//' basis_set_file='//trim(basis_set_file) - if (trim(potential_file).ne.'') args_str = trim(args_str)//' potential_file='//trim(potential_file) - if (trim(dft_file).ne.'') args_str = trim(args_str)//' dft_file='//trim(dft_file) - if (trim(global_file).ne.'') args_str = trim(args_str)//' global_file='//trim(global_file) - if (trim(cell_file).ne.'') args_str = trim(args_str)//' cell_file='//trim(cell_file) - if (clean_up_files) then - args_str = trim(args_str)//' clean_up_files=T' - else - args_str = trim(args_str)//' clean_up_files=F' - endif - if (have_silica_potential) then - args_str = trim(args_str)//' have_silica_potential=T' - else - args_str = trim(args_str)//' have_silica_potential=F' - endif - - call print('FILEPOT |'//args_str,verbosity=PRINT_SILENT) - - !call CP2K - allocate(f0(3,my_atoms%N)) - call go_cp2k(my_atoms=my_atoms, forces=f0, energy=energy, args_str=args_str,intrares_impropers=intrares_impropers) - !momentum conservation - f0 = sum0(f0, my_atoms) - -if ((trim(Run_Type).eq.'QMMM_EXTENDED')) then - if (.not.get_value(my_atoms%params,'QM_cell',old_QM_cell)) call system_abort('Something has gone wrong. No QM_cell property found.') -endif - - !write energy and forces - call set_value(my_atoms%params,'energy',energy) - call add_property(my_atoms,'force', 0.0_dp, n_cols=3) - if (.not. assign_pointer(my_atoms, 'force', forces_p)) then - call system_abort("filepot_read_output needed forces, but couldn't find force in my_atoms ") - endif - forces_p = f0 - - call initialise(xyz,new_coord_file,action=OUTPUT) - call print_xyz(my_atoms,xyz,all_properties=.true.,real_format='f20.13') - call finalise(xyz) - - deallocate(f0) - call finalise(my_atoms) - call verbosity_push(PRINT_NORMAL) - call system_timer('FILEPOT |') - call verbosity_push(PRINT_SILENT) - call system_finalise - -contains - -! momentum conservation over all atoms, mass weighted - function sum0(force,at) result(force0) - - real(dp), dimension(:,:), intent(in) :: force - type(Atoms), intent(in) :: at - real(dp) :: force0(size(force,1),size(force,2)) - integer :: i - real(dp) :: sumF(3), sum_weight - - sumF = sum(force,2) - call print('Sum of the forces is '//sumF(1:3)) - - if ((sumF(1) .feq. 0.0_dp) .and. (sumF(2) .feq. 0.0_dp) .and. (sumF(3) .feq. 0.0_dp)) then - call print('Sum of the forces is zero.') - force0 = force - else - !F_corr weighted by element mass - sum_weight = sum(ElementMass(at%Z(1:at%N))) - - force0(1,:) = force(1,:) - sumF(1) * ElementMass(at%Z(:)) / sum_weight - force0(2,:) = force(2,:) - sumF(2) * ElementMass(at%Z(:)) / sum_weight - force0(3,:) = force(3,:) - sumF(3) * ElementMass(at%Z(:)) / sum_weight - endif - - sumF = sum(force0,2) - call print('Sum of the forces after mom.cons.: '//sumF(1:3)) - - end function sum0 - -end program cp2k_filepot diff --git a/src/FilePot_drivers/evb_driver.f95 b/src/FilePot_drivers/evb_driver.f95 deleted file mode 100644 index 9f8de4481a..0000000000 --- a/src/FilePot_drivers/evb_driver.f95 +++ /dev/null @@ -1,254 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X EVB_filepot_template program -!X -!% filepot program for EVB energy and force calculation through CP2K -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program EVB_filepot_template - - use libatoms_module - use potential_module - - implicit none - - type(Atoms) :: at1,at2 - real(dp), pointer :: at1_pos(:,:), at2_pos(:,:) - type(Potential) :: cp2k_fast_pot, pot - character(STRING_LENGTH) :: args_str - integer :: stat, error - real(dp) :: energy - real(dp), dimension(:,:), allocatable :: f1 - - !ARGS_STR INPUT PARAMETERS - type(Dictionary) :: cli_params - type(Dictionary) :: params - character(STRING_LENGTH) :: evb_params_line - character(STRING_LENGTH) :: posfilename - character(STRING_LENGTH) :: xyz_template_filename - character(STRING_LENGTH) :: outfilename - logical :: only_GAP - character(STRING_LENGTH) :: psf_file1 - character(STRING_LENGTH) :: psf_file2 - character(STRING_LENGTH) :: filepot_program - character(STRING_LENGTH) :: cp2k_calc_args - character(STRING_LENGTH) :: evb_params_filename - character(STRING_LENGTH) :: mm_args_str - character(STRING_LENGTH) :: topology_suffix1 - character(STRING_LENGTH) :: topology_suffix2 - integer :: form_bond(2), break_bond(2) - real(dp) :: diagonal_dE2, & - offdiagonal_A12, & - offdiagonal_mu12, & - offdiagonal_mu12_square, & - offdiagonal_r0 - logical :: save_forces, & - save_energy - type(Inoutput) :: evb_params_file - logical :: exists - character(len=STRING_LENGTH) :: filename - integer :: tmp_run_dir_i - - - call system_initialise(verbosity=PRINT_SILENT,enable_timing=.true.) - call verbosity_push(PRINT_NORMAL) - mainlog%prefix="EVB_FILEPOT" - call system_timer('evb_filepot_template') - - !INPUT PARAMETERS - call initialise(cli_params) - call param_register(cli_params,"pos","", posfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"xyz_template","", xyz_template_filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"out","", outfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"only_GAP","F", only_gap, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"psf_file1","", psf_file1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"psf_file2","", psf_file2, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"filepot_program","", filepot_program, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"cp2k_calc_args","", cp2k_calc_args, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params,"param_file","evb_params.dat", evb_params_filename, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - !call print("Usage: pos xyz_template out only_GAP param_file",PRINT_ALWAYS) - call system_abort('EVB_filepot: could not parse argument line') - endif - call finalise(cli_params) - - - !EVB params file with EVB parameters and with params that can overwrite the defaults - inquire(file=trim(evb_params_filename), exist=exists) - if (.not.exists) call system_abort("WARNING: no "//trim(evb_params_filename)//" file found.") - - call initialise(evb_params_file,trim(evb_params_filename),ACTION=INPUT) - evb_params_line=read_line(evb_params_file,stat) - if (len_trim(evb_params_line)>0) then - call initialise(params) - call param_register(params,"pos",""//trim(posfilename), posfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"xyz_template",""//trim(xyz_template_filename), xyz_template_filename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"out",""//trim(outfilename), outfilename, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"only_GAP",""//only_gap, only_gap, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"psf_file1",""//trim(psf_file1), psf_file1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"psf_file2",""//trim(psf_file2), psf_file2, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"filepot_program",""//trim(filepot_program), filepot_program, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params,"cp2k_calc_args",""//trim(cp2k_calc_args), cp2k_calc_args, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'mm_args_str', "", mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'topology_suffix1', "_EVB1", topology_suffix1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'topology_suffix2', "_EVB2", topology_suffix2, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'form_bond', '0 0', form_bond, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'break_bond', '0 0', break_bond, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'diagonal_dE2', '0.0', diagonal_dE2, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'offdiagonal_A12', '0.0', offdiagonal_A12, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'offdiagonal_mu12', '0.0', offdiagonal_mu12, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'offdiagonal_mu12_square', '0.0', offdiagonal_mu12_square, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'offdiagonal_r0', '0.0', offdiagonal_r0, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'save_forces', "T", save_forces, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'save_energy', 'T', save_energy, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params, 'tmp_run_dir_i', '-1', tmp_run_dir_i, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_line(params, evb_params_line, ignore_unknown=.true.,task='EVB_filepot_template args_str')) then - call system_abort('EVB_filepot_template failed to parse args_str="'//trim(evb_params_line)//'"') - endif - call finalise(params) - else - call system_abort("WARNING: file with EVB params "//trim(evb_params_filename)//" is empty. It must contain 1 only line with all the params.") - endif - evb_params_line=read_line(evb_params_file,stat) - if (stat==0 .and. len_trim(evb_params_line)>0) then - call system_abort("File with EVB params "//trim(evb_params_filename)//" has more than 1 lines and the second line is not empty. It must contain 1 only line with all the params.") - endif - call finalise(evb_params_file) - - - !remove old output file - call system_command("rm -f "//trim(outfilename),stat) - - - !read positions and template XYZ with lattice - if (len_trim(posfilename)==0) call system_abort("No posfilename given.") - inquire(file=trim(posfilename), exist=exists) - if (.not.exists) call system_abort("No "//trim(posfilename)//" file found.") - if (len_trim(xyz_template_filename)==0) call system_abort("No xyz_template_filename given.") - inquire(file=trim(xyz_template_filename), exist=exists) - if (.not.exists) call system_abort("No "//trim(xyz_template_filename)//" file found.") - !call print("Reading at1") - call read(at1,posfilename) - !call print("Reading at2") - call read(at2,xyz_template_filename) - - if (at1%N/=at2%N) call system_abort("EVB_filepot_template: at1 and at2 has different number of atoms.") - if (.not.assign_pointer(at1,"pos",at1_pos)) call system_abort("EVB_filepot_template: Could not find pos property in at1.") - if (.not.assign_pointer(at2,"pos",at2_pos)) call system_abort("EVB_filepot_template: Could not find pos property in at2.") - - at2_pos(1:3,1:at2%N) = at1_pos(1:3,1:at2%N) - - !possible i/o on /tmp - if (tmp_run_dir_i>0) then - filename="/tmp/cp2k_run_"//tmp_run_dir_i//"/filepot" - else - filename="filepot" - endif - - !call print("Writing filepot.0.xyz") - !!call write(at2,"filepot.0.xyz", properties="species:pos:mol_id:atom_res_number",real_format='f17.10',error=error) - !call write(at2,trim(filename)//".0.xyz", properties="species:pos",real_format='%17.10f',error=error) - !HANDLE_ERROR(error) - call finalise(at1) - - - !call print("Initialise potentials") - !setup EVB potential (pot and args_str) - if (len_trim(filepot_program)==0) call system_abort("EVB_filepot_template: Filepot not given.") - !!call initialise(cp2k_fast_pot,'FilePot command='//trim(filepot_program)//' property_list=species:pos:avgpos:mol_id:atom_res_number min_cutoff=0.0') - call initialise(cp2k_fast_pot,'FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos min_cutoff=0.0') - - args_str="" - !if (len_trim(cp2k_calc_args)==0) call print("WARNING: EVB_filepot_template: cp2k_calc_args not given.",PRINT_ALWAYS) - if (len_trim(cp2k_calc_args)>0) mm_args_str=trim(mm_args_str)//" "//trim(cp2k_calc_args) - if (len_trim(mm_args_str)>0) & - args_str=trim(args_str)//" mm_args_str="//'"'//trim(mm_args_str)//'"' - if (len_trim(topology_suffix1)>0) & - args_str=trim(args_str)//" topology_suffix1="//trim(topology_suffix1) - if (len_trim(topology_suffix2)>0) & - args_str=trim(args_str)//" topology_suffix2="//trim(topology_suffix2) - if (any(form_bond/=0)) & - args_str=trim(args_str)//' form_bond={'//form_bond//'}' - if (any(break_bond/=0)) & - args_str=trim(args_str)//' break_bond={'//break_bond//'}' - if (.not.(diagonal_dE2.feq.0.0_dp)) & - args_str=trim(args_str)//" diagonal_dE2="//diagonal_dE2 - if (.not.(offdiagonal_A12.feq.0.0_dp)) & - args_str=trim(args_str)//" offdiagonal_A12="//offdiagonal_A12 - if (.not.(offdiagonal_mu12.feq.0.0_dp)) & - args_str=trim(args_str)//" offdiagonal_mu12="//offdiagonal_mu12 - if (.not.(offdiagonal_mu12_square.feq.0.0_dp)) & - args_str=trim(args_str)//" offdiagonal_mu12_square="//offdiagonal_mu12_square - if (.not.(offdiagonal_r0.feq.0.0_dp)) & - args_str=trim(args_str)//" offdiagonal_r0="//offdiagonal_r0 - args_str=trim(args_str)//" save_forces="//save_forces - args_str=trim(args_str)//" save_energy="//save_energy - - call initialise(pot,args_str='EVB=T '//trim(args_str), & - pot1=cp2k_fast_pot) - !call print(pot) - - - !copy psf files if needed - if (len_trim(psf_file1)>0) then - !call print("cp "//trim(psf_file1)//" quip_cp2k"//trim(topology_suffix1)//".psf") - call system_command("cp "//trim(psf_file1)//" quip_cp2k"//trim(topology_suffix1)//".psf") - endif - if (len_trim(psf_file2)>0) then - !call print("cp "//trim(psf_file2)//" quip_cp2k"//trim(topology_suffix2)//".psf") - call system_command("cp "//trim(psf_file2)//" quip_cp2k"//trim(topology_suffix2)//".psf") - endif - - - !call print("Calculate energy and forces") - !calc E and F with EVB potential - allocate(f1(3,at2%N)) - call calc(pot,at2,energy=energy,force=f1,args_str=" EVB_gap=gap calc_force=forces calc_energy=energy") - deallocate(f1) - - - !call print("Write output") - if (only_GAP) then - call write(at2,filename=trim(outfilename),properties="gap_force") - else - call write(at2,filename=trim(outfilename)) - endif - call finalise(at2) - - - call system_timer('evb_filepot_template') - call system_finalise - -end program EVB_filepot_template diff --git a/src/FilePot_drivers/vasp_driver.f95 b/src/FilePot_drivers/vasp_driver.f95 deleted file mode 100644 index b07d6da0eb..0000000000 --- a/src/FilePot_drivers/vasp_driver.f95 +++ /dev/null @@ -1,744 +0,0 @@ -#include "error.inc" -program vasp_driver -use libatoms_module -implicit none - - type(Atoms) :: at - - character(len=STRING_LENGTH) :: infile, outfile - character(len=STRING_LENGTH) :: args_str - character(len=STRING_LENGTH) :: arg - integer :: i, index_insert - type(CInOutput) :: outfile_io - - integer :: error, stat_vals(13) - - call system_initialise(verbosity=PRINT_SILENT, enable_timing=.true.) - call verbosity_push(PRINT_NORMAL) - call system_timer('vasp_filepot') - - if (cmd_arg_count() < 2) then - call system_abort("Usage: vasp_filepot infile outfile [ other_cli_arg1=v1 other_cli_arg2=v2 ...]") - endif - - call get_cmd_arg(1, infile) - call get_cmd_arg(2, outfile) - - args_str = "" - if (cmd_arg_count() > 2) then - do i=3, cmd_arg_count() - call get_cmd_arg(i, arg) - !add {} if there is space in the arg - if (index(trim(arg)," ").ne.0) then - index_insert = index(trim(arg),"=") - arg(index_insert+1:len_trim(arg)+2) = "{"//arg(index_insert+1:len_trim(arg))//"}" - call print('arg: '//trim(arg),PRINT_SILENT) - endif - args_str = trim(args_str) // " " // trim(arg) - end do - endif - - call read(at,infile) - - call print('vasp_filepot args_str '//trim(args_str), PRINT_ALWAYS) - - call do_vasp_calc(at, trim(args_str), error) - HANDLE_ERROR(error) - - call initialise(outfile_io,outfile,action=OUTPUT) - call write(at, outfile_io, real_format='%20.13f') - call finalise(outfile_io) - - call finalise(at) - - call system_timer('vasp_filepot') - mainlog%prefix="" - call verbosity_push(PRINT_SILENT) - call system_finalise() - -contains - -subroutine do_vasp_calc(at, args_str, error) - type(Atoms), intent(inout) :: at - character(len=*), intent(in) :: args_str - integer, intent(out), optional :: error - - character(len=STRING_LENGTH) :: incar_template_file, kpoints_file, potcar_files, vasp_path, run_suffix, verbosity_str - character(len=STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy - logical :: do_calc_energy, do_calc_force, do_calc_virial, do_calc_local_energy, persistent, persistent_n_atoms_exist - logical :: clean_up_files, ignore_convergence, no_use_WAVECAR, force_constant_basis - integer :: clean_up_keep_n - integer :: persistent_restart_interval, persistent_n_atoms - real(dp) :: persistent_max_wait_time - type(Dictionary) :: incar_dict, cli - - integer :: persistent_run_i - logical :: persistent_already_started = .false. - type(inoutput) :: persistent_io - - integer :: run_dir_i, force_run_dir_i - - integer :: i_charge - real(dp) :: nelect, nelect_of_elem(size(ElementName)), r_charge - real(dp), pointer :: magmom_p(:) - - character(len=STRING_LENGTH) :: run_dir - type(Inoutput) :: io - - integer :: at_i, stat - integer, pointer :: sort_index_p(:) - logical :: converged, have_wavecar - - INIT_ERROR(error) - - call initialise(cli) - call param_register(cli, "verbosity", "NORMAL", verbosity_str, help_string="verbosity level") - call param_register(cli, "INCAR_template", "INCAR.template", incar_template_file, help_string="name of file with template for main input (INCAR) file") - call param_register(cli, "kpoints_file", "KPOINTS", kpoints_file, help_string="name of k-points file (KPOINTS)") - call param_register(cli, "potcar_files", PARAM_MANDATORY, potcar_files, help_string="mapping from atomic numbers to POTCAR files, Z_1 POTCAR_FILE_1 [ Z_2 POTCAR_FILE_2 ... ]") - call param_register(cli, "vasp", PARAM_MANDATORY, vasp_path, help_string="vasp executable") - call param_register(cli, "energy", "", calc_energy, help_string="if set, calculate energy and put it in parameter named this") - call param_register(cli, "force", "", calc_force, help_string="if set, calculate forces and put them in property named this") - call param_register(cli, "virial", "", calc_virial, help_string="if set, calculate virial and put it in parameter named this") - call param_register(cli, "local_energy", "", calc_local_energy, help_string="not supported") - call param_register(cli, "clean_up_files", "T", clean_up_files, help_string="if true, delete run directory when done") - call param_register(cli, "clean_up_keep_n", "1", clean_up_keep_n, help_string="if cleaning up, keep this many directories around") - call param_register(cli, "ignore_convergence", "F", ignore_convergence, help_string="If true, accept result even if failed to converge SCF") - call param_register(cli, "no_use_WAVECAR", "F", no_use_WAVECAR, help_string="If true, don't reuse previous wavefunction file WAVECAR") - call param_register(cli, "force_constant_basis", "F", force_constant_basis, help_string="If true, do a restart with the same basis") - call param_register(cli, "run_suffix", "run", run_suffix, help_string="suffix to label persistent state from run to run") - call param_register(cli, "persistent", "F", persistent, help_string="If true, use persistent connection to a long-running vasp process") - call param_register(cli, "persistent_restart_interval", "100", persistent_restart_interval, help_string="If persistent, restart vasp this often") - call param_register(cli, "persistent_max_wait_time", "600", persistent_max_wait_time, help_string="If persistent, never wait more than this long (s) for calculation to finish") - if (.not. param_read_line(cli, args_str, ignore_unknown=.true.,task='do_vasp_calc args_str')) then - call print("Args: verbosity INCAR_template kpoints_file potcar_files vasp energy force", PRINT_ALWAYS) - call print(" virial local_energy clean_up_files ignore_convergence no_use_WAVECAR", PRINT_ALWAYS) - call print(" force_constant_basis run_suffix", PRINT_ALWAYS) - RAISE_ERROR('do_vasp_calc failed to parse args_str="'//trim(args_str)//'"', error) - endif - call finalise(cli) - - call verbosity_push(verbosity_of_str(trim(verbosity_str))) - - do_calc_energy = len_trim(calc_energy) > 0 - do_calc_force = len_trim(calc_force) > 0 - do_calc_virial = len_trim(calc_virial) > 0 - do_calc_local_energy = len_trim(calc_local_energy) > 0 - - call print("do_vasp_calc using args:", PRINT_VERBOSE) - call print(" INCAR_template " // trim(INCAR_template_file), PRINT_VERBOSE) - call print(" kpoints_file " // trim(kpoints_file), PRINT_VERBOSE) - call print(" potcar_files " // trim(potcar_files), PRINT_VERBOSE) - call print(" vasp " // trim(vasp_path), PRINT_VERBOSE) - call print(" energy " // do_calc_energy, PRINT_VERBOSE) - call print(" force " // do_calc_force, PRINT_VERBOSE) - call print(" virial " // do_calc_virial, PRINT_VERBOSE) - call print(" local_energy " // do_calc_local_energy, PRINT_VERBOSE) - call print(" clean_up_files " // clean_up_files, PRINT_VERBOSE) - call print(" clean_up_keep_n " // clean_up_keep_n, PRINT_VERBOSE) - call print(" ignore_convergence " // ignore_convergence, PRINT_VERBOSE) - call print(" no_use_WAVECAR " // no_use_WAVECAR, PRINT_VERBOSE) - call print(" force_constant_basis " // force_constant_basis, PRINT_VERBOSE) - call print(" run_suffix " // run_suffix, PRINT_VERBOSE) - call print(" persistent " // persistent, PRINT_VERBOSE) - if (persistent) then - call print(" persistent_restart_interval " // persistent_restart_interval, PRINT_VERBOSE) - call print(" persistent_max_wait_time " // persistent_max_wait_time, PRINT_VERBOSE) - endif - - call system_timer('vasp_filepot/prep') - ! check for local energy - if (do_calc_local_energy) then - RAISE_ERROR("do_vasp_calc can't do local_energy", error) - endif - - call print("reading template", PRINT_VERBOSE) - ! read the template incar - call read_vasp_incar_dict(incar_dict, trim(incar_template_file), error) - PASS_ERROR(error) - - call print("setting INCAR dictionary parameters", PRINT_VERBOSE) - ! check for stress, set ISIF - if (.not. do_calc_energy .and. .not. do_calc_force .and. .not. do_calc_virial) then - return - else if (.not. do_calc_virial) then - call set_value(incar_dict, "ISIF", 0) - else - if (persistent) then - call set_value(incar_dict, "ISIF", 3) - else - call set_value(incar_dict, "ISIF", 2) - endif - endif - - ! remove EDIFFG to avoid VASP quitting when it thinks convergence has been reached - if (has_key(incar_dict,"EDIFFG")) call remove_value(incar_dict,"EDIFFG") - - force_run_dir_i = -1 - if (persistent) then ! make run_dir manually - inquire(file="persistent_run_i", exist=persistent_already_started) - run_dir = "vasp_run_0" - force_run_dir_i = 0 - if (.not. persistent_already_started) then - call system_command("mkdir "//trim(run_dir)) - call initialise(persistent_io, "persistent_run_i", action=OUTPUT) - call print("-1", file=persistent_io) - call finalise(persistent_io) - endif - - inquire(file="persistent_n_atoms", exist=persistent_n_atoms_exist) - if (persistent_n_atoms_exist) then - call initialise(persistent_io, "persistent_n_atoms", action=INPUT) - line = read_line(persistent_io) - read (unit=line, fmt=*, iostat=stat) persistent_n_atoms - call finalise(persistent_io) - else - persistent_n_atoms = 0 - end if - call print('got old persistent_n_atoms = '//persistent_n_atoms, PRINT_VERBOSE) - call print('writing new persistent_n_atoms = '//at%n, PRINT_VERBOSE) - call initialise(persistent_io, "persistent_n_atoms", action=OUTPUT) - call print(at%n, file=persistent_io) - call finalise(persistent_io) - endif - run_dir = make_run_directory("vasp_run", force_run_dir_i, run_dir_i) - - if (persistent) then - ! set dynamics to REFTRAJ, number of ionic steps to 1000000 - call set_value(incar_dict, "NSW", 1000000) - call set_value(incar_dict, "IBRION", 12) - else - ! set dynamics to MD, number of ionic steps to 0 - call set_value(incar_dict, "NSW", 0) - call set_value(incar_dict, "IBRION", 0) - endif - if (no_use_WAVECAR) then - call set_value(incar_dict, "ISTART", 0) - else - inquire(file="WAVECAR."//trim(run_suffix), exist=have_wavecar) - if (have_wavecar) then - call print("copying old WAVECAR.run_suffix to run_dir/WAVECAR", PRINT_VERBOSE) - call system_command("cp WAVECAR."//trim(run_suffix)//" "//trim(run_dir)//"/WAVECAR", status=stat) - if (stat /= 0) then - RAISE_ERROR("do_vasp_calc copying file WAVECAR."//trim(run_suffix)//" into "//trim(run_dir), error) - endif - endif - if (force_constant_basis) then - ! 3 is faster, but not tested - call set_value(incar_dict, "ISTART", 2) - else - call set_value(incar_dict, "ISTART", 1) - endif - endif - - call print("doing sorting", PRINT_VERBOSE) - call add_property(at, "sort_index", 0, n_cols=1, ptr=sort_index_p, error=error) - PASS_ERROR(error) - do at_i=1, at%N - sort_index_p(at_i) = at_i - end do - call atoms_sort(at, 'Z', error=error) - PASS_ERROR(error) - - if (persistent) then - call print("reading persistent_run_i", PRINT_VERBOSE) - call initialise(persistent_io, "persistent_run_i", action=INPUT) - line = read_line(persistent_io) - read (unit=line, fmt=*, iostat=stat) persistent_run_i - call finalise(persistent_io) - call print("got persistent_run_i="//persistent_run_i, PRINT_VERBOSE) - persistent_run_i = persistent_run_i + 1 - call initialise(persistent_io, "persistent_run_i", action=OUTPUT) - call print(persistent_run_i, file=persistent_io) - call finalise(persistent_io) - endif - - if (.not. persistent_already_started) then - call print("writing POTCAR", PRINT_VERBOSE) - call write_vasp_potcar(at, trim(run_dir), trim(potcar_files), nelect_of_elem, error=error) - PASS_ERROR(error) - endif - - ! total number of electrons for each element from POTCAR files - nelect = sum(nelect_of_elem(at%Z)) - ! get Charge from xyz file - r_charge = 0.0_dp - if (get_value(at%params, 'Charge', r_charge)) then - nelect = nelect - r_charge - else if (get_value(at%params, 'Charge', i_charge)) then - r_charge = i_charge - nelect = nelect - i_charge - endif - if (r_charge .fne. 0.0_dp) then ! set total number of electrons - call set_value(incar_dict, "NELECT", nelect) - endif - - if (assign_pointer(at, "magmom", magmom_p)) then - call set_value(incar_dict, "MAGMOM", magmom_p) - endif - - if (.not. persistent_already_started) then - ! write INCAR - call print("writing INCAR", PRINT_VERBOSE) - call initialise(io, trim(run_dir)//"/INCAR", action=OUTPUT, error=error) - PASS_ERROR(error) - call print(write_string(incar_dict, entry_sep=quip_new_line, quote_char=' '), file=io) - call finalise(io) - - ! write KPOINTS if needed - if (trim(kpoints_file) /= "_NONE_") then - call print("writing KPOINTS", PRINT_VERBOSE) - call system_command("cp "//trim(kpoints_file)//" "//trim(run_dir)//"/KPOINTS", status=stat) - if (stat /= 0) then - RAISE_ERROR("do_vasp_calc copying kpoints_file "//trim(kpoints_file)//" into "//trim(run_dir), error) - endif - endif - endif - - if (.not. persistent_already_started .or. mod(persistent_run_i, persistent_restart_interval) == 0 .or. at%n /= persistent_n_atoms) then - call print("writing POSCAR", PRINT_VERBOSE) - call write_vasp_poscar(at, trim(run_dir), error=error) - PASS_ERROR(error) - endif - call system_timer('vasp_filepot/prep') - - if (persistent) then ! restart VASP if needed, write to REFTRAJCAR if needed, initiate calc - call system_timer('vasp_filepot/start_restart') - if (mod(persistent_run_i, persistent_restart_interval) == 0 .or. at%n /= persistent_n_atoms) then ! start or restart VASP - call print("starting or restarting VASP", PRINT_VERBOSE) - if (persistent_already_started) then ! tell currently running vasp to quit - call initialise(persistent_io, trim(run_dir)//"/REFTRAJCAR", action=OUTPUT) - call print("0", file=persistent_io) - call finalise(persistent_io) - call initialise(persistent_io, trim(run_dir)//"/REFTRAJ_READY", action=OUTPUT) - call print("-", file=persistent_io) - call finalise(persistent_io) - ! wait for signal that it's finished - call system_command("echo 'before wait'; ps auxw | egrep 'vasp|mpi'") - call wait_for_file_to_exist(trim(run_dir)//"/vasp.done", max_wait_time=600.0_dp, error=error) - call system_command("echo 'after wait'; ls -l "//trim(run_dir)) - call system_command("echo 'after wait'; ps auxw | egrep 'vasp|mpi'") - PASS_ERROR(error) - ! clean up - call unlink(trim(run_dir)//"/vasp.done") - call system_command("cd "//trim(run_dir)//"; rm -f REFTRAJCAR REFTRAJ_READY OUTCAR CONTCAR OSZICAR") - call system_command("cat vasp.stdout."//run_dir_i//" >> vasp.stdout") - endif - ! start vasp in background - call print("cd "//trim(run_dir)//"; bash -c "//'"'//"("//'\"'//trim(vasp_path)//'\"'//" > ../vasp.stdout."//run_dir_i//"; echo done > vasp.done )"//'"'//" 2>&1 &") - call system_command("cd "//trim(run_dir)//"; bash -c "//'"'//"("//'\"'//trim(vasp_path)//'\"'//" > ../vasp.stdout."//run_dir_i//"; echo done > vasp.done )"//'"'//" 2>&1 &", status=stat) - if (stat /= 0) then - RAISE_ERROR("error running "//trim(vasp_path)//", status="//stat, error) - endif - persistent_already_started = .true. - endif - call system_timer('vasp_filepot/start_restart') - call system_timer('vasp_filepot/write_reftrajcar') - if (mod(persistent_run_i,persistent_restart_interval) /= 0 .and. at%n == persistent_n_atoms) then ! need to write current coords to REFTRAJCAR - call print("writing current coords to REFTRAJCAR", PRINT_VERBOSE) - call initialise(persistent_io, trim(run_dir)//"/REFTRAJCAR", action=OUTPUT) - call print(at%N, file=persistent_io) - call fix_lattice(at) - call print(at%lattice(1,:), file=persistent_io) - call print(at%lattice(2,:), file=persistent_io) - call print(at%lattice(3,:), file=persistent_io) - do i=1, at%N - call print(matmul(at%g, at%pos(:,i)), file=persistent_io) - end do - call finalise(persistent_io) - call print("touching REFTRAJ_READY", PRINT_VERBOSE) - call initialise(persistent_io, trim(run_dir)//"/REFTRAJ_READY", action=OUTPUT) - call print("-", file=persistent_io) - call finalise(persistent_io) - endif - call system_timer('vasp_filepot/write_reftrajcar') - call system_timer('vasp_filepot/wait_reftraj_step_done') - call print("waiting for output REFTRAJ_STEP_DONE", PRINT_VERBOSE) - ! wait for output to be ready - call wait_for_file_to_exist(trim(run_dir)//"/REFTRAJ_STEP_DONE", persistent_max_wait_time, cycle_time=0.1_dp, error=error) - PASS_ERROR(error) - call system_timer('vasp_filepot/wait_reftraj_step_done') - else ! not persistent, just run vasp - call system_timer('vasp_filepot/run_vasp') - call print("running vasp", PRINT_VERBOSE) - call print("cd "//trim(run_dir)//"; bash -c "//'"'//trim(vasp_path)//'"'//" > ../vasp.stdout."//run_dir_i//" 2>&1") - call system_command("cd "//trim(run_dir)//"; bash -c "//'"'//trim(vasp_path)//'"'//" > ../vasp.stdout."//run_dir_i//" 2>&1", status=stat) - if (stat /= 0) then - RAISE_ERROR("error running "//trim(vasp_path)//", status="//stat, error) - endif - call system_command("cat vasp.stdout."//run_dir_i//" >> vasp.stdout") - call system_timer('vasp_filepot/run_vasp') - endif - - ! look for errors in stdout and runtime in OUTCAR - call system_command("fgrep -i 'error' vasp.stdout."//run_dir_i) - call system_command("fgrep -i 'total cpu time used' "//trim(run_dir)//"/OUTCAR | tail -1; fgrep -c 'LOOP:' "//trim(run_dir)//"/OUTCAR | tail -1") - - call system_timer('vasp_filepot/read_output') - if (persistent) then ! read REFTRAJ output - call print("reading output REFTRAJ_OUTPUT", PRINT_VERBOSE) - ! read output - call read_vasp_output_persistent(at, run_dir, do_calc_energy, do_calc_force, do_calc_virial, error) - PASS_ERROR(error) - converged = .true. ! should really find a way of telling if converged for persistent connections - ! clean up - call unlink(trim(run_dir)//"/REFTRAJ_OUTPUT") - call unlink(trim(run_dir)//"/REFTRAJ_STEP_DONE") - else ! read regular VASP output (OUTCAR) - call print("reading vasp output", PRINT_VERBOSE) - call read_vasp_output(trim(run_dir), do_calc_energy, do_calc_force, do_calc_virial, converged, error=error) - PASS_ERROR(error) - endif - call system_timer('vasp_filepot/read_output') - - call system_timer('vasp_filepot/end') - if (.not. converged) then - call print("WARNING: failed to find sign of convergence in OUTCAR", verbosity=PRINT_ALWAYS) - if (.not. ignore_convergence) then - RAISE_ERROR("failed to find sign of convergence in OUTCAR", error) - endif - endif - - inquire(file=trim(run_dir)//"/WAVECAR", exist=have_wavecar) - if (have_wavecar) then - call print("copying run_dir/WAVECAR to WAVECAR.run_suffix", PRINT_VERBOSE) - call system_command("cp "//trim(run_dir)//"/WAVECAR WAVECAR."//trim(run_suffix), status=stat) - if (stat /= 0) then - RAISE_ERROR("do_vasp_calc copying file "//trim(run_dir)//"WAVECAR into ./"//trim(run_dir)//"WAVECAR."//trim(run_suffix), error) - endif - endif - - call print("doing unsorting", PRINT_VERBOSE) - call atoms_sort(at, 'sort_index', error=error) - PASS_ERROR(error) - - if (clean_up_files .and. .not. persistent) then - call print("cleaning up", PRINT_VERBOSE) - call system_command("rm -rf vasp_run_"//(1+mod(run_dir_i,clean_up_keep_n+1))) - endif - - call system_timer('vasp_filepot/end') - - call verbosity_pop() - -end subroutine do_vasp_calc - -subroutine write_vasp_potcar(at, run_dir, potcar_files, nelect_of_elem, error) - type(Atoms), intent(in) :: at - character(len=*), intent(in) :: run_dir, potcar_files - real(dp), intent(out) :: nelect_of_elem(:) - integer, intent(out), optional :: error - - integer :: i, Z_i, potcar_files_n_fields - character(len=STRING_LENGTH) :: potcar_files_fields(128), potcar_files_a(128) - integer, allocatable :: uniq_Z(:) - - integer :: stat, t_Z - real(dp) :: t_nelect - character(len=STRING_LENGTH) :: line - type(inoutput) :: io - - INIT_ERROR(error) - - call split_string_simple(trim(potcar_files), potcar_files_fields, potcar_files_n_fields, " ", error) - PASS_ERROR(error) - - if (potcar_files_n_fields <= 0 .or. mod(potcar_files_n_fields,2) /= 0) then - RAISE_ERROR("write_vasp_potcar didn't find even number of fields (Z1 potcar1 [Z2 potcar2 ...]) in potcar_files='"//trim(potcar_files)//"'", error) - endif - - call uniq(at%Z, uniq_Z) - - potcar_files_a="" - do i=1, potcar_files_n_fields, 2 - read(unit=potcar_files_fields(i),fmt=*) Z_i - potcar_files_a(Z_i) = trim(potcar_files_fields(i+1)) - end do - - call system_command("rm -f nelect_summary; touch nelect_summary") - call system_command("rm -f "//trim(run_dir)//"/POTCAR") - do Z_i=1, size(uniq_Z) - if (uniq_Z(Z_i) == 0) exit - if (len_trim(potcar_files_a(uniq_Z(Z_i))) == 0) then - RAISE_ERROR("write_vasp_potcar could not find a potcar for Z="//uniq_Z(Z_i), error) - endif - call system_command("cat "//trim(potcar_files_a(uniq_Z(Z_i)))//" >> "//trim(run_dir)//"/POTCAR") - call system_command("(echo -n '"//uniq_Z(Z_i)//" '; cat "//trim(potcar_files_a(uniq_Z(Z_i)))//" | fgrep ZVAL | sed -e 's/.*ZVAL[ ]*=[ ]*//' -e 's/ .*//') >> nelect_summary") - end do - - ! read back nelect_summary - call initialise(io, "nelect_summary") - do Z_i=1, size(uniq_Z) - line = read_line(io, stat) - read (unit=line, fmt=*) t_Z, t_nelect - if (t_Z <= 0 .or. t_Z > size(nelect_of_elem)) then - RAISE_ERROR("write_vasp_potcar got value out of range reading nelect_summary value t_Z="//t_Z, error) - endif - if (t_Z /= uniq_Z(Z_i)) then - RAISE_ERROR("write_vasp_potcar got mismatch reading nelect_summary value t_Z="//t_Z//" uniq_Z("//Z_i//")="//uniq_Z(Z_i), error) - endif - nelect_of_elem(t_Z) = t_nelect - end do - call finalise(io) - -end subroutine write_vasp_potcar - -subroutine write_vasp_poscar(at, run_dir, error) - type(Atoms), intent(inout) :: at - character(len=*), intent(in) :: run_dir - integer, intent(out), optional :: error - - integer, allocatable :: uniq_Z(:), n_Z(:) - integer :: i - logical :: swapped_a1_a2 - - type(inoutput) :: io - - INIT_ERROR(error) - - call fix_lattice(at, swapped_a1_a2) - - call initialise(io, trim(run_dir)//"/POSCAR",action=OUTPUT) - if (swapped_a1_a2) then - call print("QUIP VASP run "//trim(run_dir)//" swapped a1 and a2", file=io) - else - call print("QUIP VASP run "//trim(run_dir), file=io) - endif - call print("1.00 ! scale factor", file=io) - - call print(at%lattice(:,1), file=io) - call print(at%lattice(:,2), file=io) - call print(at%lattice(:,3), file=io) - - call uniq(at%Z, uniq_Z) - allocate(n_Z(size(uniq_Z))) - do i=1, size(uniq_Z) - n_Z(i) = count(at%Z == uniq_Z(i)) - call print(" " // trim(ElementName(uniq_Z(i))), file=io, nocr=.true.) - end do - call print("", file=io) - call print(""//n_Z//" ! Zs = "//uniq_Z, file=io) - call print("Selective Dynamics", file=io) - call print("Cartesian", file=io) - do i=1, at%N - call print(at%pos(:,i)//" T T T", file=io) - end do - call finalise(io) - -end subroutine write_vasp_poscar - -subroutine fix_lattice(at, swapped_a1_a2) - type(Atoms), intent(inout) :: at - logical, intent(out), optional :: swapped_a1_a2 - - real(dp) :: vol, lattice(3,3) - - if (present(swapped_a1_a2)) swapped_a1_a2 = .false. - - vol = scalar_triple_product(at%lattice(:,1), at%lattice(:,2), at%lattice(:,3)) - if (vol < 0.0_dp) then - if (present(swapped_a1_a2)) swapped_a1_a2 = .true. - lattice(:,1) = at%lattice(:,2) - lattice(:,2) = at%lattice(:,1) - lattice(:,3) = at%lattice(:,3) - call set_lattice(at, lattice, .false.) - endif - -end subroutine fix_lattice - -subroutine read_vasp_output(run_dir, do_calc_energy, do_calc_force, do_calc_virial, converged, error) - character(len=*), intent(in) :: run_dir - logical, intent(in) :: do_calc_energy, do_calc_force, do_calc_virial - logical, intent(out) :: converged - integer, intent(out), optional :: ERROR - - type(inoutput) :: outcar_io - integer :: stat - character(len=STRING_LENGTH) :: line - character(len=STRING_LENGTH) :: fields(100), t_s - integer :: n_fields, line_i - logical in_virial - - real(dp) :: energy, virial(3,3), t_pos(3) - real(dp), pointer :: force_p(:,:) - integer :: force_start_line_i, virial_start_line_i, read_err - - INIT_ERROR(error) - - if (do_calc_force) then - if (.not. assign_pointer(at, "force", force_p)) then - call add_property(at, "force", 0.0_dp, n_cols=3, ptr2=force_p, error=error) - PASS_ERROR(error) - endif - endif - - converged = .false. - force_start_line_i = -1 - in_virial = .false. - call initialise(outcar_io, trim(run_dir)//"/OUTCAR") - stat = 0 - line_i = 1 - do while (stat == 0) - line = read_line(outcar_io, stat) - if (do_calc_energy) then - if (index(trim(line),"free energy") > 0) then ! found energy - call split_string_simple(trim(line), fields, n_fields, " ", error=error) - PASS_ERROR(error) - if (n_fields /= 6) then - RAISE_ERROR("read_vasp_output confused by energy line# "//line_i//" in OUTCAR line '"//trim(line)//"'", error) - endif - if (fields(6) /= "eV") then - RAISE_ERROR("read_vasp_output confused by units energy line# "//line_i//" in OUTCAR line '"//trim(line)//"'", error) - endif - read(unit=fields(5),fmt=*) energy - call set_param_value(at, 'energy', energy) - endif - endif - if (do_calc_force) then - if (force_start_line_i > 0 .and. line_i >= force_start_line_i .and. line_i <= force_start_line_i+at%N-1) then - read(unit=line,fmt=*) t_pos, force_p(:,line_i-force_start_line_i+1) - else - if (index(trim(line),"TOTAL-FORCE") > 0) then ! found force - call split_string_simple(trim(line), fields, n_fields, " ", error=error) - if (fields(3) /= "(eV/Angst)") then - RAISE_ERROR("read_vasp_output confused by units force header line# "//line_i//" in OUTCAR line '"//trim(line)//"'", error) - endif - force_start_line_i = line_i+2 - endif - endif - endif - if (do_calc_virial) then - if (in_virial .and. index(trim(line),"Total") > 0) then - read(unit=line,fmt=*,iostat=read_err) t_s, virial(1,1), virial(2,2), virial(3,3), virial(1,2), virial(2,3), virial(1,3) - if (read_err /= 0) then - RAISE_ERROR ("read_vasp_output failed to read virial from line '"//trim(line)//"'", error) - endif - virial(2,1) = virial(1,2) - virial(3,2) = virial(2,3) - virial(3,1) = virial(1,3) - call set_param_value(at, 'virial', virial) - in_virial = .false. - else - if (index(trim(line),"FORCE on cell") > 0) then ! found start of virial section - call split_string_simple(trim(line), fields, n_fields, " ", error=error) - if (fields(9) /= "(eV):" .and. fields(9) /= "(eV/reduce") then - RAISE_ERROR("read_vasp_output confused by units virial header line# "//line_i//" in OUTCAR line '"//trim(line)//"'", error) - endif - in_virial = .true. - endif - endif - endif - if (.not. converged) then - if (index(trim(line),"aborting loop because EDIFF is reached") > 0) then ! found convergence of SCF - converged = .true. - endif - endif - ! if (stat == 0) call print("GOT OUTPUT "//trim(line)) - line_i = line_i + 1 - end do - call finalise(outcar_io) - -end subroutine read_vasp_output - -subroutine read_vasp_output_persistent(at, run_dir, do_calc_energy, do_calc_force, do_calc_virial, error) - type(atoms), intent(inout) :: at - character(len=*), intent(in) :: run_dir - logical, intent(in) :: do_calc_energy, do_calc_force, do_calc_virial - integer, optional, intent(out) :: error - - real(dp) :: energy, virial(3,3), force_t(3) - real(dp), pointer :: force_p(:,:) - type(inoutput) :: reftraj_output_io - character(len=STRING_LENGTH) :: line - integer :: ni - - INIT_ERROR(error) - - if (do_calc_force) then - if (.not. assign_pointer(at, "force", force_p)) then - call add_property(at, "force", 0.0_dp, n_cols=3, ptr2=force_p, error=error) - PASS_ERROR(error) - endif - endif - - call initialise(reftraj_output_io, trim(run_dir)//"/REFTRAJ_OUTPUT", action=INPUT) - - line = read_line(reftraj_output_io); read(unit=line, fmt=*) ni - if (ni /= at%N) then - RAISE_ERROR("read_vasp_output_persistent got NI == "//ni//" != at%N == "//at%N, error) - endif - - ! read energy - line = read_line(reftraj_output_io); read(unit=line, fmt=*) energy - if (do_calc_energy) call set_param_value(at, 'energy', energy) - ! read force - do i=1, at%N - line = read_line(reftraj_output_io); read(unit=line, fmt=*) force_t - if (do_calc_force) force_p(:,i) = force_t(:) - end do - ! read virial - if (do_calc_virial) then - line = read_line(reftraj_output_io); read(unit=line, fmt=*) virial(1,1), virial(2,2), virial(3,3), virial(1,2), virial(2,3), virial(3,1) - virial(2,1) = virial(1,2) - virial(3,2) = virial(2,3) - virial(1,3) = virial(3,1) - call set_param_value(at, "virial", virial) - endif - - call finalise(reftraj_output_io) -end subroutine read_vasp_output_persistent - -subroutine read_vasp_incar_dict(incar_dict, incar_template_file, error) - type(Dictionary), intent(inout) :: incar_dict - character(len=*), intent(in) :: incar_template_file - integer, intent(out), optional :: error - - type(Inoutput) :: incar_io - character(len=STRING_LENGTH), allocatable :: incar_a(:), incar_line_fields(:), incar_field_fields(:) - integer :: incar_n_lines, incar_line_n_fields, incar_field_n_fields - integer :: i, j - integer :: comment_pos - - INIT_ERROR(error) - - call initialise(incar_io, trim(incar_template_file), INPUT) - call read_file(incar_io, incar_a, incar_n_lines) - call finalise(incar_io) - - call initialise(incar_dict) - allocate(incar_line_fields(100)) - allocate(incar_field_fields(100)) - ! loop over lines - do i=1, incar_n_lines - comment_pos = index(trim(incar_a(i)), '#') - if (comment_pos > 1) then - incar_a(i) = incar_a(i)(1:comment_pos-1) - elseif (comment_pos == 1) then - incar_a(i) = "" - endif - comment_pos = index(trim(incar_a(i)), '!') - if (comment_pos > 1) then - incar_a(i) = incar_a(i)(1:comment_pos-1) - elseif (comment_pos == 1) then - incar_a(i) = "" - endif - call split_string(trim(incar_a(i)), ";", "''"//'""', incar_line_fields, incar_line_n_fields, .true.) - ! loop over ';' separated fields - do j=1, incar_line_n_fields - call split_string(incar_line_fields(j), "=", "''"//'""', incar_field_fields, incar_field_n_fields, .true.) - if (incar_field_n_fields > 2) then - RAISE_ERROR("read_vasp_incar_dict got more than one '=' in field "//trim(incar_line_fields(j)), error) - endif - if (.not. has_key(incar_dict, trim(adjustl(incar_field_fields(1))))) then - ! VASP always uses first instance of a keyword, do same here - call set_value(incar_dict, trim(adjustl(incar_field_fields(1))), trim(adjustl(incar_field_fields(2)))) - endif - end do - end do - - deallocate(incar_line_fields) - deallocate(incar_field_fields) - -end subroutine read_vasp_incar_dict - -end program vasp_driver From 15c24d43ddbee121bd7c38e97fd7e23e6ec245a1 Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 18:16:58 +0100 Subject: [PATCH 14/47] renamed source files to have F90 extension --- src/FilePot_drivers/cp2k_driver.F90 | 119 + src/FilePot_drivers/cp2k_driver_module.F90 | 1871 ++++++++++++++ src/FilePot_drivers/cp2k_driver_old.F90 | 2708 ++++++++++++++++++++ src/FilePot_drivers/cp2k_filepot_old.F90 | 259 ++ src/FilePot_drivers/evb_driver.F90 | 254 ++ src/FilePot_drivers/vasp_driver.F90 | 744 ++++++ 6 files changed, 5955 insertions(+) create mode 100644 src/FilePot_drivers/cp2k_driver.F90 create mode 100644 src/FilePot_drivers/cp2k_driver_module.F90 create mode 100644 src/FilePot_drivers/cp2k_driver_old.F90 create mode 100644 src/FilePot_drivers/cp2k_filepot_old.F90 create mode 100644 src/FilePot_drivers/evb_driver.F90 create mode 100644 src/FilePot_drivers/vasp_driver.F90 diff --git a/src/FilePot_drivers/cp2k_driver.F90 b/src/FilePot_drivers/cp2k_driver.F90 new file mode 100644 index 0000000000..993bf68d4e --- /dev/null +++ b/src/FilePot_drivers/cp2k_driver.F90 @@ -0,0 +1,119 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X cp2k_driver_template program +!X +!% filepot program for CP2K driver using input file template +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" +program cp2k_driver_template +use libatoms_module +use cp2k_driver_module + +implicit none + + integer, parameter :: CP2K_LINE_LENGTH = 1024 !Max line length to be printed into the CP2K input files + + type(Atoms) :: my_atoms + real(dp) :: energy + real(dp), allocatable :: f0(:,:) + real(dp), pointer :: forces_p(:,:) + type(CInoutput) :: xyz_io + + character(len=STRING_LENGTH) :: infile, outfile + character(len=STRING_LENGTH) :: args_str + character(len=STRING_LENGTH) :: arg + integer :: i, index_insert + + integer :: error = ERROR_NONE + + call system_initialise(verbosity=PRINT_SILENT,enable_timing=.true.) + call verbosity_push(PRINT_NORMAL) + call system_timer('cp2k_driver_template') + + if (cmd_arg_count() < 2) & + call system_abort("Usage: cp2k_driver_template infile outfile [ other_cli_arg1=v1 other_cli_arg2=v2 ...]") + + call get_cmd_arg(1, infile) + call get_cmd_arg(2, outfile) + args_str = "" + if (cmd_arg_count() > 2) then + do i=3, cmd_arg_count() + call get_cmd_arg(i, arg) + !add {} if there is space in the arg + if (index(trim(arg)," ").ne.0) then + index_insert = index(trim(arg),"=") + arg(index_insert+1:len_trim(arg)+2) = "{"//arg(index_insert+1:len_trim(arg))//"}" + call print('arg: '//trim(arg),PRINT_SILENT) + endif + args_str = trim(args_str) // " " // trim(arg) + end do + endif + + call read(my_atoms,infile, error=error) + if (error == ERROR_NONE) then + allocate(f0(3,my_atoms%N)) + else + ! continue: do_cp2k_calc() should fail, but print first out help message if requested + CLEAR_ERROR(error) + endif + + !call CP2K + call do_cp2k_calc(at=my_atoms, f=f0, e=energy, args_str=trim(args_str), error=error) + HANDLE_ERROR(error) + + !momentum conservation +! call sum0(f0) + + !write energy and forces + call set_value(my_atoms%params,'energy',energy) + call add_property(my_atoms,'force', 0.0_dp, n_cols=3) + if (.not. assign_pointer(my_atoms, 'force', forces_p)) then + call system_abort("filepot_read_output needed forces, but couldn't find force in my_atoms ") + endif + forces_p = f0 + + call initialise(xyz_io,outfile,action=OUTPUT) + call write(my_atoms,xyz_io,real_format='%20.13f') + call finalise(xyz_io) + + deallocate(f0) + call finalise(my_atoms) + call system_timer('cp2k_driver_template') + mainlog%prefix="" + call verbosity_push(PRINT_SILENT) + call system_finalise + +end program cp2k_driver_template diff --git a/src/FilePot_drivers/cp2k_driver_module.F90 b/src/FilePot_drivers/cp2k_driver_module.F90 new file mode 100644 index 0000000000..bca887be27 --- /dev/null +++ b/src/FilePot_drivers/cp2k_driver_module.F90 @@ -0,0 +1,1871 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X cp2k_driver_module +!X +!% guts of cp2k driver from template +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +#include "error.inc" + +module cp2k_driver_module + +use libatoms_module + +implicit none + +private + +public :: do_cp2k_calc +public :: read_output, qmmm_qm_abc, calc_charge_lsd, cp2k_state_change + +contains + + subroutine do_cp2k_calc(at, f, e, args_str, error) + type(Atoms), intent(inout) :: at + real(dp), intent(out) :: f(:,:), e + character(len=*), intent(in) :: args_str + integer, intent(out), optional :: error + + type(Dictionary) :: cli + character(len=STRING_LENGTH) :: run_type, cp2k_template_file, psf_print, cp2k_program, link_template_file, & + topology_suffix, qmmm_link_type, qmmm_link_qm_kind + logical :: clean_up_files, save_output_files, save_output_wfn_files, use_buffer, persistent + integer :: clean_up_keep_n, persistent_restart_interval, qmmm_link_qm_kind_z + integer :: max_n_tries + real(dp) :: max_force_warning + real(dp) :: qm_vacuum + real(dp) :: centre_pos(3), cp2k_box_centre_pos(3) + logical :: auto_centre, has_centre_pos + logical :: try_reuse_wfn + character(len=STRING_LENGTH) :: calc_qm_charges, calc_virial + logical :: do_calc_virial + + character(len=128) :: method + + integer :: link_template_n_lines + character(len=STRING_LENGTH), allocatable :: link_template_a(:) + integer :: i_line + + character(len=STRING_LENGTH) :: run_dir + + type(Table) :: qm_list, old_qm_list + type(Table) :: cut_bonds, old_cut_bonds + integer, pointer :: cut_bonds_p(:,:), old_cut_bonds_p(:,:) + integer, allocatable :: qm_list_a(:), old_qm_list_a(:) + integer, allocatable :: link_list_a(:), old_link_list_a(:), inner_link_list_a(:) + integer, allocatable :: qm_and_link_list_a(:) + integer :: i_inner, i_outer, shift(3) + integer :: counter + + integer :: charge, old_charge + logical :: do_lsd, old_do_lsd + + logical :: can_reuse_wfn, qm_list_changed, qmmm_link_list_changed, & + qmmm_same_lattice, qmmm_use_mm_charges, qmmm_link_fix_pbc + character(len=STRING_LENGTH) :: run_suffix + + logical :: use_QM, use_MM, use_QMMM + logical :: cp2k_calc_fake + + integer, pointer :: isolated_atom(:) + integer i, at_Z, insert_pos + real(dp) :: cur_qmmm_qm_abc(3), old_qmmm_qm_abc(3) + + integer, pointer :: old_cluster_mark_p(:), cluster_mark_p(:) + logical :: dummy, have_silica_potential, have_titania_potential, silica_add_23_body + logical :: silica_pos_dep_charges + real(dp) :: silica_charge_transfer, silicon_charge, oxygen_charge, hydrogen_charge + integer :: res_num_silica + logical :: do_mom_cons + type(Table) :: intrares_impropers + + integer, pointer :: sort_index_p(:), mol_id_p(:) + integer, allocatable :: rev_sort_index(:) + type(Inoutput) :: rev_sort_index_io, persistent_run_i_io, persistent_cell_file_io, persistent_traj_io + character(len=1024) :: l + + integer :: run_dir_i, force_run_dir_i, delete_dir_i + + logical :: at_periodic + integer :: form_bond(2), break_bond(2) + real(dp) :: disp(3) + + character(len=STRING_LENGTH) :: verbosity + character(len=STRING_LENGTH) :: tmp_MM_param_filename, tmp_QM_pot_filename, tmp_QM_basis_filename + character(len=STRING_LENGTH) :: MM_param_filename, QM_pot_filename, QM_basis_filename + logical :: truncate_parent_dir + character(len=STRING_LENGTH) :: dir, tmp_run_dir + character(len=1024) :: log_sys_command_str + integer :: tmp_run_dir_i, stat + logical :: exists, persistent_already_started, persistent_start_cp2k, persistent_frc_exists, create_residue_labels, & + remove_Si_H_silica_bonds, remove_Ti_H_titania_bonds + integer :: persistent_run_i, persistent_frc_size, qm_mol_id, n_hydrogen, old_n_hydrogen, n_extra_electrons, old_n_extra_electrons + integer :: qmmm_link_n_electrons + + type(inoutput) :: cp2k_input_io, cp2k_input_tmp_io + real(dp) :: wait_time, persistent_max_wait_time + + character(len=100) proj + + INTERFACE + elemental function ffsize(f) + character(len=*), intent(in)::f + integer::ffsize + end function ffsize + END INTERFACE + + + INIT_ERROR(error) + + call system_timer('do_cp2k_calc') + + call system_timer('do_cp2k_calc/init') + call initialise(cli) + call param_register(cli, 'Run_Type', PARAM_MANDATORY, run_type, help_string="Type of run QS, MM, or QMMM") + call param_register(cli, 'use_buffer', 'T', use_buffer, help_string="If true, use buffer as specified in relevant hybrid_mark") + call param_register(cli, 'run_suffix', '', run_suffix, help_string="String to append to various marks and saved info to indicate distinct sets of calculations or QM/MM QM regions") + call param_register(cli, 'cp2k_template_file', 'cp2k_input.template', cp2k_template_file, help_string="filename for cp2k input template") + call param_register(cli, "qmmm_link_template_file", "", link_template_file, help_string="filename for cp2k link atoms template file") + call param_register(cli, 'PSF_print', 'NO_PSF', psf_print, help_string="when to print PSF file: NO_PSF, DRIVER_PRINT_AND_SAVE, USE_EXISTING_PSF") + call param_register(cli, "topology_suffix", "", topology_suffix, help_string="String to append to file containing topology info (for runs that do multiple topologies not to accidentally reuse PSF file") + call param_register(cli, 'cp2k_program', PARAM_MANDATORY, cp2k_program, help_string="path to cp2k executable") + call param_register(cli, 'persistent', 'F', persistent, help_string="if true, use persistent connection to cp2k with REFTRAJ") + call param_register(cli, 'persistent_restart_interval', '100', persistent_restart_interval, help_string="how often to restart cp2k for persistent connection") + call param_register(cli, 'persistent_max_wait_time', '600.0', persistent_max_wait_time, help_string="Max amount of time in s to wait for forces to be available in persistent mode") + call param_register(cli, 'clean_up_files', 'T', clean_up_files, help_string="if true, clean up run directory files") + call param_register(cli, 'clean_up_keep_n', '1', clean_up_keep_n, help_string="number of old run directories to keep if cleaning up") + call param_register(cli, 'save_output_files', 'T', save_output_files, help_string="if true, save the output files") + call param_register(cli, 'save_output_wfn_files', 'F', save_output_wfn_files, help_string="if true, save output wavefunction files") + call param_register(cli, 'max_n_tries', '2', max_n_tries, help_string="max number of times to run cp2k on failure") + call param_register(cli, 'max_force_warning', '2.0', max_force_warning, help_string="generate warning if any force is larger than this") + call param_register(cli, 'qm_vacuum', '6.0', qm_vacuum, help_string="amount of vacuum to add to size of qm region in hybrid (and nonperiodic?) runs") + call param_register(cli, 'try_reuse_wfn', 'T', try_reuse_wfn, help_string="if true, try to reuse previous wavefunction file") + call param_register(cli, 'have_silica_potential', 'F', have_silica_potential, help_string="if true, use 2.8A SILICA_CUTOFF for the connectivities") + call param_register(cli, 'have_titania_potential', 'F', have_titania_potential, help_string="if true, use 2.8A TITANIA_CUTOFF for the connectivities") + call param_register(cli, 'res_num_silica', '1', res_num_silica, help_string="residue number for silica residue") + call param_register(cli, 'do_mom_cons', 'T', do_mom_cons, help_string="do we need momentum conservation?") + call param_register(cli, 'auto_centre', 'F', auto_centre, help_string="if true, automatically center configuration. May cause energy/force fluctuations. Mutually exclusive with centre_pos") + call param_register(cli, 'centre_pos', '0.0 0.0 0.0', centre_pos, has_value_target=has_centre_pos, help_string="position to center around, mutually exclusive with auto_centre") + call param_register(cli, 'cp2k_calc_fake', 'F', cp2k_calc_fake, help_string="if true, do fake cp2k runs that just read from old output files") + call param_register(cli, 'form_bond', '0 0', form_bond, help_string="extra bond to form (for EVB)") + call param_register(cli, 'break_bond', '0 0', break_bond, help_string="bond to break (for EVB)") + call param_register(cli, 'qm_charges', '', calc_qm_charges, help_string="if not blank, name of property to put QM charges in") + call param_register(cli, 'virial', '', calc_virial, help_string="if not blank, name of property to put virial in") + call param_register(cli, 'force_run_dir_i', '-1', force_run_dir_i, help_string="if > 0, force to run in this # run directory") + call param_register(cli, 'tmp_run_dir_i', '-1', tmp_run_dir_i, help_string="if >0, the cp2k run directory will be /tmp/cp2k_run_$tmp_run_dir_i$, and all input files are also copied here when first called") + call param_register(cli, 'MM_param_file', '', MM_param_filename, help_string="If tmp_run_dir>0, where to find MM parameter file to copy it to the cp2k run dir on /tmp.") !charmm.pot + call param_register(cli, 'QM_potential_file', '', QM_pot_filename, help_string="If tmp_run_dir>0, where to find QM POTENTIAL file to copy it to the cp2k run dir on /tmp.") !POTENTIAL + call param_register(cli, 'QM_basis_file', '', QM_basis_filename, help_string="If tmp_run_dir>0, where to find QM BASIS_SET file to copy it to the cp2k run dir on /tmp.") !BASIS_SET + call param_register(cli, 'silica_add_23_body', 'T', silica_add_23_body, help_string="If true and if have_silica_potential is true, add bonds for silica 2- and 3-body terms to PSF") + call param_register(cli, 'silica_pos_dep_charges', 'T', silica_pos_dep_charges, help_string="If true and if have_silica_potential is true, use variable charges for silicon and oxygen ions in silica residue") + call param_register(cli, 'silica_charge_transfer', '2.4', silica_charge_transfer, help_string="Amount of charge transferred from Si to O in silica bulk, per formula unit") + call param_register(cli, 'remove_Si_H_silica_bonds', 'T', remove_Si_H_silica_bonds, help_string="If true (default) remove any Si-H bonds detected in silica residue") + call param_register(cli, 'remove_Ti_H_titania_bonds', 'T', remove_Ti_H_titania_bonds, help_string="If true (default) remove any Ti-H bonds detected in titania residue") + call param_register(cli, 'create_residue_labels', 'T', create_residue_labels, help_string="If true, recreate residue labels each time PSF file is generated (default T)") + call param_register(cli, 'qmmm_link_type', 'IMOMM', qmmm_link_type, help_string="Type of QMMM links to create: one of IMOMM, PSEUDO or QM_KIND. Default IMOMM") + call param_register(cli, 'qmmm_link_qm_kind', 'OSTAR', qmmm_link_qm_kind, help_string="QM kind to use for inner boundary atoms when qmmm_link_type=QM_KIND") + call param_register(cli, 'qmmm_link_qm_kind_z', '8', qmmm_link_qm_kind_z, help_string="Atomic number of QM_KIND species (default 8)") + call param_register(cli, 'qmmm_link_n_electrons', '1', qmmm_link_n_electrons, help_string="Number of electrons to add per QM-MM link when qmmm_link_type=QM_KIND") + call param_register(cli, 'qmmm_same_lattice', 'F', qmmm_same_lattice, help_string="If true, use full original MM lattice for QM calculation") + call param_register(cli, 'qmmm_use_mm_charges', 'T', qmmm_use_mm_charges, help_string="If true (default) use classical point charges of atoms in QM region to calculate total DFT charge") + call param_register(cli, 'qmmm_link_fix_pbc', 'T', qmmm_link_fix_pbc, help_string="If true (default) move outer atoms in any QM links which straddle a periodic boundary so link is continous") + call param_register(cli, 'verbosity', 'NORMAL', verbosity, help_string="verbosity level") + + ! should really be ignore_unknown=false, but higher level things pass unneeded arguments down here + if (.not.param_read_line(cli, args_str, ignore_unknown=.true.,task='cp2k_driver_template args_str')) then + RAISE_ERROR('cp2k_driver could not parse argument line', error) + endif + call finalise(cli) + do_calc_virial = len_trim(calc_virial) > 0 + + call verbosity_push(verbosity_of_str(trim(verbosity))) + + mainlog%prefix="CP2K_DRIVER" + + call print('do_cp2k_calc args_str '//trim(args_str), PRINT_ALWAYS) + + if (.not. is_initialised(at)) then + RAISE_ERROR("do_cp2k_calc got uninitialized atoms structure", error) + endif + + if (cp2k_calc_fake) then + call print("do_fake cp2k calc calculation") + call do_cp2k_calc_fake(at, f, e, do_calc_virial, args_str) + return + endif + + if (have_silica_potential) then + ! compute silicon_charge and oxygen_charge from silica_charge_transfer such that SiO2 is neutral + silicon_charge = silica_charge_transfer + oxygen_charge = -silicon_charge/2.0_dp + ! compute hydrogen_charge from silicon_charge and oxygen_charge such that Si(OH)_4 is neutral + hydrogen_charge = -(silicon_charge + 4.0_dp*oxygen_charge)/4.0_dp + end if + + if (trim(qmmm_link_type) /= 'IMOMM' .and. & + trim(qmmm_link_type) /= 'PSEUDO' .and. & + trim(qmmm_link_type) /= 'QM_KIND') then + RAISE_ERROR("Unknown value for qmmm_link_type "//trim(qmmm_link_type)//" - should be one of IMOMM, PSEUDO, QM_KIND", error) + end if + ! Link fixing across periodic boundaries only applies to IMOMM + qmmm_link_fix_pbc = qmmm_link_fix_pbc .and. trim(qmmm_link_type) == 'IMOMM' + + call print("do_cp2k_calc command line arguments") + call print(" Run_Type " // Run_Type) + call print(" use_buffer " // use_buffer) + call print(" run_suffix " // run_suffix) + call print(" cp2k_template_file " // cp2k_template_file) + call print(" qmmm_link_template_file " // link_template_file) + call print(" PSF_print " // PSF_print) + call print(" topology_suffix " // trim(topology_suffix)) + call print(" cp2k_program " // trim(cp2k_program)) + call print(" persistent " // persistent) + if (persistent) call print(" persistent_restart_interval " // persistent_restart_interval) + if (persistent) call print(" persistent_max_wait_time " // persistent_max_wait_time) + call print(" clean_up_files " // clean_up_files) + call print(" clean_up_keep_n " // clean_up_keep_n) + call print(" save_output_files " // save_output_files) + call print(" save_output_wfn_files " // save_output_wfn_files) + call print(" max_n_tries " // max_n_tries) + call print(" max_force_warning " // max_force_warning) + call print(" qm_vacuum " // qm_vacuum) + call print(" try_reuse_wfn " // try_reuse_wfn) + call print(' have_titania_potential '//have_titania_potential) + call print(' have_silica_potential '//have_silica_potential) + if(have_silica_potential) then + call print(' res_num_silica '//res_num_silica) + call print(' silica_add_23_body '//silica_add_23_body) + call print(' silica_pos_dep_charges '//silica_pos_dep_charges) + call print(' silica_charge_transfer '//silica_charge_transfer) + call print(' silicon_charge '//silicon_charge) + call print(' oxygen_charge '//oxygen_charge) + call print(' hydrogen_charge '//hydrogen_charge) + call print(' remove_Si_H_silica_bonds '//remove_Si_H_silica_bonds) + call print(' remove_Ti_H_titania_bonds '//remove_Ti_H_titania_bonds) + end if + call print(' auto_centre '//auto_centre) + call print(' centre_pos '//centre_pos) + call print(' cp2k_calc_fake '//cp2k_calc_fake) + call print(' form_bond '//form_bond) + call print(' break_bond '//break_bond) + call print(' qm_charges '//trim(calc_qm_charges)) + call print(' virial '//do_calc_virial) + call print(' force_run_dir_i '//force_run_dir_i) + call print(' tmp_run_dir_i '//tmp_run_dir_i) + call print(' MM_param_file '//trim(MM_param_filename)) + call print(' QM_potential_file '//trim(QM_pot_filename)) + call print(' QM_basis_file '//trim(QM_basis_filename)) + call print(' create_residue_labels '//create_residue_labels) + call print(' qmmm_link_type '//trim(qmmm_link_type)) + call print(' qmmm_link_qm_kind '//trim(qmmm_link_qm_kind)) + call print(' qmmm_link_n_electrons '//qmmm_link_n_electrons) + call print(' qmmm_same_lattice '//qmmm_same_lattice) + call print(' qmmm_use_mm_charges '//qmmm_use_mm_charges) + call print(' qmmm_link_fix_pbc '//qmmm_link_fix_pbc) + call print(' do_mom_cons '//do_mom_cons) + call print(' verbosity '//trim(verbosity)) + + if (auto_centre .and. has_centre_pos) then + RAISE_ERROR("do_cp2k_calc got both auto_centre and centre_pos, don't know which centre (automatic or specified) to shift to origin", error) + endif + + if (tmp_run_dir_i>0 .and. clean_up_keep_n > 0) then + RAISE_ERROR("do_cp2k_calc got both tmp_run_dir_i(only write on /tmp) and clean_up_keep_n (save in home).",error) + endif + call system_timer('do_cp2k_calc/init') + + proj='quip' + + persistent_already_started=.false. + + call system_timer('do_cp2k_calc/run_dir') + !create run directory now, because it is needed if running on /tmp + if (tmp_run_dir_i>0) then + if (persistent) then + RAISE_ERROR("Can't do persistent and temp_run_dir_i > 0", error) + endif + tmp_run_dir = "/tmp/cp2k_run_"//tmp_run_dir_i + run_dir = link_run_directory(trim(tmp_run_dir), basename="cp2k_run", run_dir_i=run_dir_i) + !and copy necessary files for access on /tmp if not yet present + if (len_trim(MM_param_filename)>0) then + tmp_MM_param_filename = trim(MM_param_filename) + truncate_parent_dir=.true. + do while(truncate_parent_dir) + if (tmp_MM_param_filename(1:3)=="../") then + tmp_MM_param_filename=trim(tmp_MM_param_filename(4:)) + else + truncate_parent_dir=.false. + endif + enddo + if (len_trim(tmp_MM_param_filename)==0) then + RAISE_ERROR("Empty tmp_MM_param_filename string",error) + endif + call print("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(tmp_MM_param_filename)//" ] ; then echo 'copy charmm.pot' ; cp "//trim(MM_param_filename)//" "//trim(tmp_run_dir)//"/ ; else echo 'reuse charmm.pot' ; fi") + call system_command("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(tmp_MM_param_filename)//" ] ; then echo 'copy charmm.pot' ; cp "//trim(MM_param_filename)//" "//trim(tmp_run_dir)//"/ ; fi",status=stat) + if ( stat /= 0 ) then + RAISE_ERROR("Something went wrong when tried to copy "//trim(MM_param_filename)//" into the tmp dir "//trim(tmp_run_dir), error) + endif + endif + if (len_trim(QM_pot_filename)>0) then + tmp_QM_pot_filename = trim(QM_pot_filename) + truncate_parent_dir=.true. + do while(truncate_parent_dir) + if (tmp_QM_pot_filename(1:3)=="../") then + tmp_QM_pot_filename=trim(tmp_QM_pot_filename(4:)) + else + truncate_parent_dir=.false. + endif + enddo + call print("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(QM_pot_filename)//" ] ; then cp "//trim(QM_pot_filename)//" "//trim(tmp_run_dir)//"/ ; fi") + call system_command("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(tmp_QM_pot_filename)//" ] ; then echo 'copy QM potential' ; cp "//trim(QM_pot_filename)//" "//trim(tmp_run_dir)//"/ ; fi") + if ( stat /= 0 ) then + RAISE_ERROR("Something went wrong when tried to copy "//trim(QM_pot_filename)//" into the tmp dir "//trim(tmp_run_dir),error) + endif + endif + if (len_trim(QM_basis_filename)>0) then + tmp_QM_basis_filename = trim(QM_basis_filename) + truncate_parent_dir=.true. + do while(truncate_parent_dir) + if (tmp_QM_basis_filename(1:3)=="../") then + tmp_QM_basis_filename=trim(tmp_QM_basis_filename(4:)) + else + truncate_parent_dir=.false. + endif + enddo + call print("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(QM_basis_filename)//" ] ; then cp "//trim(QM_basis_filename)//" "//trim(tmp_run_dir)//"/ ; fi") + call system_command("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(tmp_QM_basis_filename)//" ] ; then echo 'copy QM basis' ; cp "//trim(QM_basis_filename)//" "//trim(tmp_run_dir)//"/ ; fi") + if ( stat /= 0 ) then + RAISE_ERROR("Something went wrong when tried to copy "//trim(QM_basis_filename)//" into the tmp dir "//trim(tmp_run_dir),error) + endif + endif + else ! not tmp + if (persistent) then + if (.not. persistent_already_started) then + call system_command("mkdir -p cp2k_run_0") + endif + force_run_dir_i=0 + endif + run_dir = make_run_directory("cp2k_run", force_run_dir_i, run_dir_i) + endif ! tmp_run_dir + call system_timer('do_cp2k_calc/run_dir') + + if (persistent) then + call system_timer('do_cp2k_calc/get_persistent_i') + inquire(file="persistent_run_i", exist=persistent_already_started) + + if (.not. persistent_already_started) then + persistent_run_i=1 + persistent_start_cp2k=.true. + else + persistent_start_cp2k=.false. + call initialise(persistent_run_i_io, "persistent_run_i", INPUT) + l = read_line(persistent_run_i_io) + call finalise(persistent_run_i_io) + read (unit=l, fmt=*, iostat=stat) persistent_run_i + if (stat /= 0) then + RAISE_ERROR("Failed to read persistent_run_i from 'persistent_run_i' file", error) + endif + persistent_run_i = persistent_run_i + 1 + + if (persistent_run_i > persistent_restart_interval) then + ! reset counters + persistent_run_i=1 + persistent_start_cp2k=.true. + ! tell running process to stop + call initialise(persistent_traj_io, trim(run_dir)//'/quip.persistent.traj.xyz',OUTPUT,append=.false.) + call print ("0", file=persistent_traj_io) + call finalise(persistent_traj_io) + call initialise(persistent_cell_file_io, trim(run_dir)//'/REFTRAJ_READY', OUTPUT, append=.false.) + call print("go",file=persistent_cell_file_io) + call finalise(persistent_cell_file_io) + ! wait + call fusleep(5000000) + ! clean up files + call system_command('cd '//trim(run_dir)//'; rm -f '//& + 'quip.persistent.traj.* '// & + trim(proj)//'-frc-1_[0-9]*.xyz '// & + trim(proj)//'-pos-1_[0-9]*.xyz '// & + trim(proj)//'-qmcharges--1_[0-9]*.mulliken '// & + trim(proj)//'-stress-1_[0-9]*.stress_tensor '// & + 'REFTRAJ_READY') + endif + endif + + call initialise(persistent_run_i_io, "persistent_run_i", OUTPUT) + call print(""//persistent_run_i, file=persistent_run_i_io, verbosity=PRINT_ALWAYS) + call finalise(persistent_run_i_io) + call system_timer('do_cp2k_calc/get_persistent_i') + else + persistent_run_i = 0 + endif + + call system_timer('do_cp2k_calc/copy_templ') + if (.not. persistent_already_started) then + ! read template file + if (tmp_run_dir_i>0) then + call print("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(cp2k_template_file)//" ] ; then cp "//trim(cp2k_template_file)//" "//trim(tmp_run_dir)//"/ ; fi") + call system_command("if [ ! -s "//trim(tmp_run_dir)//"/"//trim(cp2k_template_file)//" ] ; then cp "//trim(cp2k_template_file)//" "//trim(tmp_run_dir)//"/ ; fi") + if ( stat /= 0 ) then + RAISE_ERROR("Something went wrong when tried to copy "//trim(cp2k_template_file)//" into the tmp dir "//trim(tmp_run_dir), error) + endif + call system("cp "//trim(cp2k_template_file)//" "//trim(tmp_run_dir)//"/cp2k_input.inp") + else + call system("cp "//trim(cp2k_template_file)//" "//trim(run_dir)//"/cp2k_input.inp") + endif + + endif + call system_timer('do_cp2k_calc/copy_templ') + + if ( (trim(psf_print) /= 'NO_PSF') .and. & + (trim(psf_print) /= 'DRIVER_PRINT_AND_SAVE') .and. & + (trim(psf_print) /= 'USE_EXISTING_PSF')) then + RAISE_ERROR("Unknown value for psf_print '"//trim(psf_print)//"'", error) + endif + + ! parse run_type + use_QM = .false. + use_MM = .false. + use_QMMM = .false. + select case(trim(run_type)) + case("QS") + use_QM=.true. + method="QS" + case("MM") + use_MM=.true. + method="Fist" + case("QMMM") + use_QM = .true. + use_MM = .true. + use_QMMM = .true. + method="QMMM" + case default + RAISE_ERROR("Unknown run_type "//trim(run_type),error) + end select + + call system_timer('do_cp2k_calc/calc_connect') + ! prepare CHARMM params if necessary + if (use_MM) then + if (have_silica_potential) then + call set_cutoff(at,SILICA_2body_CUTOFF) + call calc_connect(at) + elseif (have_titania_potential) then + call set_cutoff(at,TITANIA_2body_CUTOFF) + call calc_connect(at) + else + ! use hysteretic connect to get nearest neighbour cutoff + call calc_connect_hysteretic(at, DEFAULT_NNEIGHTOL, DEFAULT_NNEIGHTOL) + endif + call map_into_cell(at) + call calc_dists(at) + endif + call system_timer('do_cp2k_calc/calc_connect') + + call system_timer('do_cp2k_calc/make_psf') + ! if writing PSF file, calculate residue labels, before sort + if (run_type /= "QS") then + if (trim(psf_print) == "DRIVER_PRINT_AND_SAVE" .and. create_residue_labels) then + if (persistent_already_started) then + RAISE_ERROR("Trying to rewrite PSF file with persistent_already_started. Can't change connectivity during persistent cp2k run", error) + endif + call create_residue_labels_arb_pos(at,do_CHARMM=.true.,intrares_impropers=intrares_impropers, & + find_silica_residue=have_silica_potential,form_bond=form_bond,break_bond=break_bond, & + silica_pos_dep_charges=silica_pos_dep_charges, silica_charge_transfer=silica_charge_transfer, & + have_titania_potential=have_titania_potential, remove_Si_H_silica_bonds=remove_Si_H_silica_bonds, & + remove_Ti_H_titania_bonds=remove_Ti_H_titania_bonds) + end if + end if + + if (trim(run_type) == 'QMMM' .and. trim(qmmm_link_type) == "QM_KIND") then + if (trim(qmmm_link_qm_kind) == '') then + RAISE_ERROR("qmmm_link_type == QM_KIND, but qmmm_link_qm_kind not specified", error) + end if + + ! If we remove the QM-MM link bonds then QM and MM regions will be disconnected. + ! We need to make QM region a separate molecule so that CP2K doesn't complain + ! about discontigous molecules. + + call assign_property_pointer(at, 'cluster_mark'//trim(run_suffix), cluster_mark_p, error=error) + PASS_ERROR(error) + call assign_property_pointer(at, 'mol_id', mol_id_p, error=error) + PASS_ERROR(error) + qm_mol_id = maxval(mol_id_p) + 1 + do i=1,at%n + if (cluster_mark_p(i) /= HYBRID_NO_MARK) mol_id_p(i) = qm_mol_id + end do + end if + + call do_cp2k_atoms_sort(at, sort_index_p, rev_sort_index, psf_print, topology_suffix, & + tmp_run_dir, tmp_run_dir_i, form_bond, break_bond, intrares_impropers, & + use_MM, have_silica_potential, have_titania_potential, error=error) + PASS_ERROR_WITH_INFO("Failed to sort atoms in do_cp2k_calc", error) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + allocate(qm_list_a(0), old_qm_list_a(0)) + allocate(link_list_a(0)) + allocate(old_link_list_a(0)) + allocate(qm_and_link_list_a(0)) + if (use_QMMM) then + call get_qm_list(at, use_buffer, trim(run_suffix), trim(link_template_file), qm_list, old_qm_list, qm_list_a, old_qm_list_a, & + link_list_a, old_link_list_a, qm_and_link_list_a, rev_sort_index, cut_bonds, cut_bonds_p, old_cut_bonds, old_cut_bonds_p, & + link_template_a, link_template_n_lines, qmmm_link_type, qmmm_link_qm_kind_z, error) + PASS_ERROR(error) + endif + + if (qm_list%N == at%N) then + call print("WARNING: requested '"//trim(run_type)//"' but all atoms are in QM region, doing full QM run instead", PRINT_ALWAYS) + run_type='QS' + use_QM = .true. + use_MM = .false. + use_QMMM = .false. + method = 'QS' + endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! write PSF file, if requested + if (run_type /= "QS") then + if (trim(psf_print) == "DRIVER_PRINT_AND_SAVE") then + ! we should fail for persistent_already_started=T, but this should have been dealt with above + if (has_property(at, 'avgpos')) then + call write_psf_file_arb_pos(at, "quip_cp2k"//trim(topology_suffix)//".psf", run_type_string=trim(run_type),intrares_impropers=intrares_impropers, & + add_silica_23body=have_silica_potential .and. silica_add_23_body, form_bond=form_bond,break_bond=break_bond, & + remove_qmmm_link_bonds=trim(qmmm_link_type) == 'QM_KIND', run_suffix=run_suffix) + else if (has_property(at, 'pos')) then + call print("WARNING: do_cp2k_calc using pos for connectivity. avgpos is preferred but not found.") + call write_psf_file_arb_pos(at, "quip_cp2k"//trim(topology_suffix)//".psf", run_type_string=trim(run_type),intrares_impropers=intrares_impropers, & + add_silica_23body=have_silica_potential .and. silica_add_23_body, pos_field_for_connectivity='pos', & + form_bond=form_bond,break_bond=break_bond, remove_qmmm_link_bonds=trim(qmmm_link_type) == 'QM_KIND', run_suffix=run_suffix) + else + RAISE_ERROR("do_cp2k_calc needs some pos field for connectivity (run_type='"//trim(run_type)//"' /= 'QS'), but found neither avgpos nor pos", error) + endif + ! write sort order + call initialise(rev_sort_index_io, "quip_rev_sort_index"//trim(topology_suffix), action=OUTPUT) + call print(rev_sort_index, file=rev_sort_index_io) + call finalise(rev_sort_index_io) + endif + endif + call system_timer('do_cp2k_calc/make_psf') + + call system_timer('do_cp2k_calc/centre_cell') + if (auto_centre) then + if (qm_list%N > 0) then + centre_pos = pbc_aware_centre(at%pos(:,qm_list_a), at%lattice, at%g) + else + centre_pos = pbc_aware_centre(at%pos, at%lattice, at%g) + endif + call print("centering got automatic center " // centre_pos, PRINT_VERBOSE) + endif + ! move specified centre to origin (centre is already 0 if not specified) + at%pos(1,:) = at%pos(1,:) - centre_pos(1) + at%pos(2,:) = at%pos(2,:) - centre_pos(2) + at%pos(3,:) = at%pos(3,:) - centre_pos(3) + ! move origin into center of CP2K box (0.5 0.5 0.5 lattice coords) + call map_into_cell(at) + + if (.not. get_value(at%params, 'Periodic', at_periodic)) at_periodic = .true. + if (.not. at_periodic) then + cp2k_box_centre_pos(1:3) = 0.5_dp*sum(at%lattice,2) + at%pos(1,:) = at%pos(1,:) + cp2k_box_centre_pos(1) + at%pos(2,:) = at%pos(2,:) + cp2k_box_centre_pos(2) + at%pos(3,:) = at%pos(3,:) + cp2k_box_centre_pos(3) + endif + call system_timer('do_cp2k_calc/centre_cell') + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + call system_timer('do_cp2k_calc/write_cp2k_input') + if (.not. persistent_already_started) then + call initialise(cp2k_input_io, trim(run_dir)//'/cp2k_input.inp.header',OUTPUT,append=.true.) + + if (do_calc_virial) then + call print("@SET DO_STRESS 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + else + call print("@SET DO_STRESS 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + + if (use_QM) then + call print("@SET DO_DFT 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + else + call print("@SET DO_DFT 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + if (use_MM) then + call print("@SET DO_MM 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + else + call print("@SET DO_MM 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + if (use_QMMM) then + call print("@SET DO_QMMM 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + else + call print("@SET DO_QMMM 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + + ! set variables having to do with periodic configs + insert_pos = 0 + if (at_periodic) then + call print("@SET PERIODIC XYZ", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + else + call print("@SET PERIODIC NONE", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + call print("@SET CELL_SIZE_INT_1 "//int(norm(at%lattice(:,1))), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET CELL_SIZE_INT_2 "//int(norm(at%lattice(:,2))), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET CELL_SIZE_INT_3 "//int(norm(at%lattice(:,3))), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET CELL_SIZE_INT_ODD_1 "//(int(norm(at%lattice(:,1))/2)*2+1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET CELL_SIZE_INT_ODD_2 "//(int(norm(at%lattice(:,2))/2)*2+1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET CELL_SIZE_INT_ODD_3 "//(int(norm(at%lattice(:,3))/2)*2+1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET MAX_CELL_SIZE_INT "//int(max(norm(at%lattice(:,1)),norm(at%lattice(:,2)), norm(at%lattice(:,3)))), & + file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET MAX_CELL_SIZE_INT_ODD "//(int(max(norm(at%lattice(:,1)),norm(at%lattice(:,2)), norm(at%lattice(:,3)))/2)*2+1), & + file=cp2k_input_io, verbosity=PRINT_ALWAYS) + + ! put in method + call print("@SET FORCE_EVAL_METHOD "//trim(method), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + + can_reuse_wfn = .true. + + call print("@SET DO_QMMM_LINK 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET QMMM_QM_KIND_FILE no_such_file", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + ! put in things needed for QMMM + if (use_QMMM) then + + call print('INFO: The size of the QM cell is either the MM cell itself, or it will have at least '//(qm_vacuum/2.0_dp)// & + ' Angstrom around the QM atoms.') + call print('WARNING! Please check if your cell is centreed around the QM region!',PRINT_ALWAYS) + call print('WARNING! CP2K centreing algorithm fails if QM atoms are not all in the',PRINT_ALWAYS) + call print('WARNING! 0,0,0 cell. If you have checked it, please ignore this message.',PRINT_ALWAYS) + if (qmmm_same_lattice) then + if (.not. at%is_orthorhombic) then + RAISE_ERROR("qmmm_same_lattice=T but original at%lattice is not orthorhombic", error) + end if + cur_qmmm_qm_abc(1) = at%lattice(1,1) + cur_qmmm_qm_abc(2) = at%lattice(2,2) + cur_qmmm_qm_abc(3) = at%lattice(3,3) + else + cur_qmmm_qm_abc = qmmm_qm_abc(at, qm_list_a, qm_vacuum) + end if + call print("@SET QMMM_ABC_X "//cur_qmmm_qm_abc(1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET QMMM_ABC_Y "//cur_qmmm_qm_abc(2), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET QMMM_ABC_Z "//cur_qmmm_qm_abc(3), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET QMMM_PERIODIC XYZ", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + + if (get_value(at%params, "QM_cell"//trim(run_suffix), old_qmmm_qm_abc)) then + if (cur_qmmm_qm_abc .fne. old_qmmm_qm_abc) can_reuse_wfn = .false. + else + can_reuse_wfn = .false. + endif + call set_value(at%params, "QM_cell"//trim(run_suffix), cur_qmmm_qm_abc) + call print('set_value QM_cell'//trim(run_suffix)//' '//cur_qmmm_qm_abc) + + ! check if QM list changed: compare cluster_mark and old_cluster_mark[_suffix] + ! if no old_cluster_mark, assumed it's changed just to be safe + qm_list_changed = .false. + if (.not.has_property(at, 'cluster_mark'//trim(run_suffix))) then + RAISE_ERROR('no cluster_mark'//trim(run_suffix)//' found in atoms object',error) + endif + if (.not.has_property(at, 'old_cluster_mark'//trim(run_suffix))) then + qm_list_changed = .true. + endif + dummy = assign_pointer(at, 'cluster_mark'//trim(run_suffix), cluster_mark_p) + + if (.not. qm_list_changed) then + dummy = assign_pointer(at, 'old_cluster_mark'//trim(run_suffix), old_cluster_mark_p) + do i=1,at%N + if (old_cluster_mark_p(i) /= cluster_mark_p(i)) then ! mark changed. Does it matter? + if (use_buffer) then ! EXTENDED, check for transitions to/from HYBRID_NO_MARK + if (any((/old_cluster_mark_p(i),cluster_mark_p(i)/) == HYBRID_NO_MARK)) qm_list_changed = .true. + else ! CORE, check for transitions between ACTIVE/TRANS and other + if ( ( any(old_cluster_mark_p(i) == (/ HYBRID_ACTIVE_MARK, HYBRID_TRANS_MARK /)) .and. & + all(cluster_mark_p(i) /= (/ HYBRID_ACTIVE_MARK, HYBRID_TRANS_MARK /)) ) .or. & + ( any(cluster_mark_p(i) == (/ HYBRID_ACTIVE_MARK, HYBRID_TRANS_MARK /)) .and. & + all(old_cluster_mark_p(i) /= (/ HYBRID_ACTIVE_MARK, HYBRID_TRANS_MARK /)) ) ) qm_list_changed = .true. + endif + if (qm_list_changed) exit + endif + enddo + endif + call set_value(at%params,'QM_list_changed',qm_list_changed) + call print('set_value QM_list_changed '//qm_list_changed) + + if (qm_list_changed) can_reuse_wfn = .false. + + call initialise(cp2k_input_tmp_io, trim(run_dir)//'/cp2k_input.qmmm_qm_kind',OUTPUT) + call print("@SET QMMM_QM_KIND_FILE cp2k_input.qmmm_qm_kind", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + !Add QM atoms + counter = 0 + if (trim(qmmm_link_type) == "QM_KIND") then + ! get unique list of inner link atoms - these are the atoms at boundary of QM region + call uniq(cut_bonds%int(1,1:cut_bonds%N), inner_link_list_a) + call print("&QM_KIND "//trim(qmmm_link_qm_kind), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + do i=1,size(inner_link_list_a) + if (at%z(inner_link_list_a(i)) /= qmmm_link_qm_kind_z) then + RAISE_ERROR("QM_KIND boundary atom "//inner_link_list_a(i)//" has atomic number Z="//at%z(inner_link_list_a(i))//" != qmmm_link_qm_kind_z="//qmmm_link_qm_kind_z, error) + end if + call print(" MM_INDEX "//inner_link_list_a(i), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + counter = counter + 1 + end do + call print("&END QM_KIND", file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + deallocate(inner_link_list_a) + end if + do at_Z=minval(at%Z), maxval(at%Z) + if (any(at%Z(qm_list_a) == at_Z)) then + call print("&QM_KIND "//trim(ElementName(at_Z)), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + do i=1, size(qm_list_a) + if (at%Z(qm_list_a(i)) == at_Z) then + if (trim(qmmm_link_type) == "QM_KIND") then + ! skip inner link atoms + if (is_in_array(cut_bonds%int(1,1:cut_bonds%N), qm_list_a(i))) cycle + end if + call print(" MM_INDEX "//qm_list_a(i), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + counter = counter + 1 + endif + end do + call print("&END QM_KIND", file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + end if + end do + call finalise(cp2k_input_tmp_io) + if (size(qm_list_a) /= counter) then + RAISE_ERROR("Number of QM list atoms " // size(qm_list_a) // " doesn't match number of QM_KIND atoms " // counter,error) + endif + + !Add link sections from template file for each link + if (size(link_list_a).gt.0 .and. trim(qmmm_link_type) /= "QM_KIND") then + call print("@SET DO_QMMM_LINK 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET QMMM_LINK_FILE cp2k_input.link", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call initialise(cp2k_input_tmp_io, trim(run_dir)//'/cp2k_input.link',OUTPUT) + do i=1,cut_bonds%N + i_inner = cut_bonds%int(1,i) + i_outer = cut_bonds%int(2,i) + do i_line=1,link_template_n_lines + call print(trim(link_template_a(i_line)), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + if (i_line == 1) then + call print("MM_INDEX "//i_outer, file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + call print("QM_INDEX "//i_inner, file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + endif + enddo + enddo + call finalise(cp2k_input_tmp_io) + + ! check if set of cut bonds has changed + qmmm_link_list_changed = .false. + if (cut_bonds%N > 0 .and. old_cut_bonds%N > 0) then + do i=1,at%N + if (any(cut_bonds_p(:,i) /= old_cut_bonds_p(:,i))) then + qmmm_link_list_changed = .true. + exit + end if + end do + if (qmmm_link_list_changed) can_reuse_wfn = .false. + end if + + endif ! size(link_list_a) > 0 + endif ! use_QMMM + + call print("@SET WFN_FILE_NAME no_such_file", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET DO_DFT_LSD 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET DO_DFT_QM_CHARGES 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + ! put in things needed for QM + if (use_QM) then + + if (trim(qmmm_link_type) == "QM_KIND") then + old_n_hydrogen = 0 + n_hydrogen = 0 + old_n_extra_electrons = qmmm_link_n_electrons*old_cut_bonds%N + n_extra_electrons = qmmm_link_n_electrons*cut_bonds%N + else + old_n_hydrogen = old_cut_bonds%N + n_hydrogen = cut_bonds%N + old_n_extra_electrons = 0 + n_extra_electrons = 0 + end if + + call calc_charge_lsd(at, old_qm_list_a, old_charge, old_do_lsd, n_hydrogen=old_n_hydrogen, & + hydrogen_charge=hydrogen_charge, n_extra_electrons=old_n_extra_electrons, & + use_mm_charges=qmmm_use_mm_charges, error=error) + PASS_ERROR(error) + call calc_charge_lsd(at, qm_list_a, charge, do_lsd, n_hydrogen=n_hydrogen, & + hydrogen_charge=hydrogen_charge, n_extra_electrons=n_extra_electrons, & + use_mm_charges=qmmm_use_mm_charges, error=error) + PASS_ERROR(error) + + if (old_charge /= charge) can_reuse_wfn = .false. + if (old_do_lsd .neqv. do_lsd) can_reuse_wfn = .false. + call print('Setting DFT charge to '//charge//' and LSD to '//do_lsd) + call print("@SET DFT_CHARGE "//charge, file=cp2k_input_io, verbosity=PRINT_ALWAYS) + if (do_lsd) then + call print("@SET DO_DFT_LSD 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + if (len_trim(calc_qm_charges) > 0) then + call print("@SET DO_DFT_QM_CHARGES 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + if (try_reuse_wfn .and. can_reuse_wfn) then + call print('Reusing wavefunction from last time') + if (persistent) then + call print("@SET WFN_FILE_NAME quip-RESTART.wfn", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + else + call print("@SET WFN_FILE_NAME ../wfn.restart.wfn"//trim(run_suffix), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + !insert_pos = find_make_cp2k_input_section(cp2k_template_a, template_n_lines, "&FORCE_EVAL&DFT", "&SCF") + !call insert_cp2k_input_line(cp2k_template_a, "&FORCE_EVAL&DFT&SCF SCF_GUESS RESTART", after_line = insert_pos, n_l = template_n_lines); insert_pos = insert_pos + 1 + endif + endif ! use_QM + + if (have_silica_potential .and. .not. silica_pos_dep_charges) then + call print("@SET SIO_CHARGE "//silicon_charge, file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET OSB_CHARGE "//oxygen_charge, file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET HSI_CHARGE "//hydrogen_charge, file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET OSTAR_CORE_CORRECTION "//(1.0_dp - silicon_charge/4.0_dp), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + end if + + ! put in unit cell + call print("@SET SUBSYS_CELL_A_X "//at%lattice(1,1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET SUBSYS_CELL_A_Y "//at%lattice(2,1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET SUBSYS_CELL_A_Z "//at%lattice(3,1), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET SUBSYS_CELL_B_X "//at%lattice(1,2), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET SUBSYS_CELL_B_Y "//at%lattice(2,2), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET SUBSYS_CELL_B_Z "//at%lattice(3,2), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET SUBSYS_CELL_C_X "//at%lattice(1,3), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET SUBSYS_CELL_C_Y "//at%lattice(2,3), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET SUBSYS_CELL_C_Z "//at%lattice(3,3), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + + ! put in topology + call print("@SET ISOLATED_ATOMS_FILE cp2k_input.isolated_atoms", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call initialise(cp2k_input_tmp_io, trim(run_dir)//'/cp2k_input.isolated_atoms',OUTPUT) + if (use_QMMM) then + do i=1, size(qm_list_a) + call print("LIST " // qm_list_a(i), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + end do + endif + if (assign_pointer(at, "isolated_atom", isolated_atom)) then + do i=1, at%N + if (isolated_atom(i) /= 0) then + call print("LIST " // qm_list_a(i), file=cp2k_input_tmp_io, verbosity=PRINT_ALWAYS) + endif + end do + endif + call finalise(cp2k_input_tmp_io) + + call print("@SET COORD_FILE quip_cp2k.xyz", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET COORD_FORMAT XYZ", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + if (trim(psf_print) == "DRIVER_PRINT_AND_SAVE" .or. trim(psf_print) == "USE_EXISTING_PSF") then + call print("@SET USE_PSF 1", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + if (tmp_run_dir_i>0) then + call system_command("if [ ! -s "//trim(tmp_run_dir)//"/quip_cp2k"//trim(topology_suffix)//".psf ] ; then cp quip_cp2k"//trim(topology_suffix)//".psf /tmp/cp2k_run_"//tmp_run_dir_i//"/ ; fi",status=stat) + if ( stat /= 0 ) then + RAISE_ERROR("Something went wrong when tried to copy quip_cp2k"//trim(topology_suffix)//".psf into the tmp dir "//trim(tmp_run_dir),error) + endif + call print("@SET CONN_FILE quip_cp2k"//trim(topology_suffix)//".psf", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + + else + call print("@SET CONN_FILE ../quip_cp2k"//trim(topology_suffix)//".psf", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + call print("@SET CONN_FORMAT PSF", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + else + call print("@SET USE_PSF 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + + ! put in global stuff to run a single force evalution, print out appropriate things + call print("@SET QUIP_PROJECT "//trim(proj), file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET QUIP_RUN_TYPE MD", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + + call print("@SET FORCES_FORMAT XMOL", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET PERSISTENT_TRAJ_FILE no_such_file", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET PERSISTENT_CELL_FILE no_such_file", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + if (persistent) then + call print("@SET QUIP_ENSEMBLE REFTRAJ", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET QUIP_N_STEPS 100000000", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET PERSISTENT_TRAJ_FILE quip.persistent.traj.xyz", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET PERSISTENT_CELL_FILE quip.persistent.traj.cell", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + else + call print("@SET QUIP_ENSEMBLE NVE", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + call print("@SET QUIP_N_STEPS 0", file=cp2k_input_io, verbosity=PRINT_ALWAYS) + endif + + call finalise(cp2k_input_io) + endif + call system_timer('do_cp2k_calc/write_cp2k_input') +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call system_timer('do_cp2k_calc/write_xyz') + if (at_periodic .and. size(link_list_a) > 0 .and. qmmm_link_fix_pbc) then + ! correct position of OUTER atoms so no links cross a periodic boundary since + ! if they did, CP2K would place terminating hydrogens incorrectly + + do i=1,cut_bonds%N + i_inner = cut_bonds%int(1,i) + i_outer = cut_bonds%int(2,i) + + disp = diff_min_image(at, i_inner, i_outer, shift=shift) + if (any(shift /= 0)) then + call print('Unwrapping QM/MM link '//i_inner//'-'//i_outer//' by shift '//shift) + at%pos(:,i_outer) = at%pos(:,i_outer) + (at%lattice .mult. shift) + end if + end do + endif + + ! prepare xyz file for input to cp2k + if (persistent) then + ! write cell file + call initialise(persistent_cell_file_io, trim(run_dir)//'/quip.persistent.traj.cell', OUTPUT, append=.false.) + call print("0 0.0 "//at%lattice(:,1)//" "//at%lattice(:,2)//" "//at%lattice(:,3)//" "//cell_volume(at), file=persistent_cell_file_io, verbosity=PRINT_ALWAYS) + call finalise(persistent_cell_file_io) + ! write traj file + call write(at, trim(run_dir)//'/quip.persistent.traj.xyz', append=.false., properties='species:pos') + ! write initial config if needed + if (.not. persistent_already_started) & + call write(at, trim(run_dir)//'/quip_cp2k.xyz', properties='species:pos') + ! touch REFTRAJ_READY FILE + call initialise(persistent_cell_file_io, trim(run_dir)//'/REFTRAJ_READY', OUTPUT, append=.true.) + call print("go",file=persistent_cell_file_io) + call finalise(persistent_cell_file_io) + else + call write(at, trim(run_dir)//'/quip_cp2k.xyz', properties='species:pos') + endif + call system_timer('do_cp2k_calc/write_xyz') + + ! actually run cp2k + if (persistent) then + call system_timer('do_cp2k_calc/run_cp2k') + if (persistent_start_cp2k) then + call start_cp2k_program_background(trim(cp2k_program), trim(run_dir), error=error) + PASS_ERROR(error) + endif + wait_time = 0.0_dp + do while(.true.) + inquire(file=trim(run_dir)//"/"//trim(proj)//"-frc-1_"//persistent_run_i//".xyz", exist=persistent_frc_exists) + if (persistent_frc_exists) then + ! inquire(file=trim(run_dir)//"/"//trim(proj)//"-frc-1_"//persistent_run_i//".xyz", size=persistent_frc_size) + persistent_frc_size = ffsize(trim(run_dir)//"/"//trim(proj)//"-frc-1_"//persistent_run_i//".xyz") + if (persistent_frc_size > 0) then ! got data, leave + call fusleep(1000000) + exit + else if (persistent_frc_size < 0) then ! error + RAISE_ERROR("Failed to get valid value from ffsize of "//trim(run_dir)//"/"//trim(proj)//"-frc-1_"//persistent_run_i//".xyz", error) + endif + endif + call fusleep(100000) + wait_time = wait_time + 100000_dp/1.0e6_dp + if (wait_time > persistent_max_wait_time) then + RAISE_ERROR("Failed to get forces after waiting at least "//persistent_max_wait_time//" s", error) + endif + end do ! waiting for frc file + call system_timer('do_cp2k_calc/run_cp2k') + call system_timer('do_cp2k_calc/read_output') + if (trim(qmmm_link_type) == 'QM_KIND') then + call read_output(at, qm_list_a, cur_qmmm_qm_abc, trim(run_dir), trim(proj), e, f, trim(calc_qm_charges), & + do_calc_virial, save_reordering_index=.false., out_i=persistent_run_i, error=error) + else + call read_output(at, qm_and_link_list_a, cur_qmmm_qm_abc, trim(run_dir), trim(proj), e, f, trim(calc_qm_charges), & + do_calc_virial, save_reordering_index=.false., out_i=persistent_run_i, error=error) + end if + PASS_ERROR(error) + call system_timer('do_cp2k_calc/read_output') + else ! not persistent + call system_timer('do_cp2k_calc/run_cp2k') + call run_cp2k_program(trim(cp2k_program), trim(run_dir), max_n_tries, error=error) + PASS_ERROR(error) + call system_timer('do_cp2k_calc/run_cp2k') + call system_timer('do_cp2k_calc/read_output') + if (trim(qmmm_link_type) == 'QM_KIND') then + call read_output(at, qm_list_a, cur_qmmm_qm_abc, trim(run_dir), trim(proj), e, f, trim(calc_qm_charges), & + do_calc_virial, save_reordering_index=.false., out_i=persistent_run_i, error=error) + else + call read_output(at, qm_and_link_list_a, cur_qmmm_qm_abc, trim(run_dir), trim(proj), e, f, trim(calc_qm_charges), & + do_calc_virial, save_reordering_index=.false., out_i=persistent_run_i, error=error) + end if + PASS_ERROR(error) + call system_timer('do_cp2k_calc/read_output') + endif + + call system_timer('do_cp2k_calc/process_output') + at%pos(1,:) = at%pos(1,:) + centre_pos(1) - cp2k_box_centre_pos(1) + at%pos(2,:) = at%pos(2,:) + centre_pos(2) - cp2k_box_centre_pos(2) + at%pos(3,:) = at%pos(3,:) + centre_pos(3) - cp2k_box_centre_pos(3) + call map_into_cell(at) + + ! unsort + if (associated(sort_index_p)) then + f(:,sort_index_p(:)) = f(:,:) + call atoms_sort(at, 'sort_index', error=error) + PASS_ERROR_WITH_INFO("do_cp2k_calc sorting atoms by sort_index",error) + endif + + if (maxval(abs(f)) > max_force_warning) & + call print('WARNING cp2k forces max component ' // maxval(abs(f)) // ' at ' // maxloc(abs(f)) // & + ' exceeds warning threshold ' // max_force_warning, PRINT_ALWAYS) + + if(do_mom_cons) call sum0(f) + + ! save output + + if (use_QM) then + call system_command('cp '//trim(run_dir)//'/quip-RESTART.wfn wfn.restart.wfn'//trim(run_suffix)) + if (save_output_wfn_files) then + call system_command('cp '//trim(run_dir)//'/quip-RESTART.wfn run_'//run_dir_i//'_end.wfn.restart.wfn'//trim(run_suffix)) + endif + endif + + if (save_output_files) then + if (persistent) then + log_sys_command_str=' if [ ! -f cp2k_input_log ]; then cat '//trim(run_dir)//'/cp2k_input.inp >> cp2k_input_log; echo "##############" >> cp2k_input_log; fi;' // & + ' cat filepot.0.xyz >> cp2k_driver_in_log.xyz;' // & + ' cat '//trim(run_dir)//'/'//trim(proj)//'-frc-1_'//persistent_run_i//'.xyz'// ' >> cp2k_force_file_log;' + if (do_calc_virial) then + log_sys_command_str = trim(log_sys_command_str) //' cat '//trim(run_dir)//'/'//trim(proj)//'-stress-1_'//persistent_run_i//'.stress_tensor'// ' >> cp2k_stress_file_log' + endif + else + log_sys_command_str= ' cat '//trim(run_dir)//'/cp2k_input.inp >> cp2k_input_log; echo "##############" >> cp2k_input_log;' // & + ' cat '//trim(run_dir)//'/cp2k_output.out >> cp2k_output_log; echo "##############" >> cp2k_output_log;' // & + ' cat filepot.xyz >> cp2k_driver_in_log.xyz;' // & + ' cat '//trim(run_dir)//'/'//trim(proj)//'-frc-1_0.xyz'// ' >> cp2k_force_file_log;' + if (do_calc_virial) then + log_sys_command_str = trim(log_sys_command_str) // ' cat '//trim(run_dir)//'/'//trim(proj)//'-stress-1_0.stress_tensor'// ' >> cp2k_stress_file_log' + endif + endif + call system_command(trim(log_sys_command_str)) + endif + call system_timer('do_cp2k_calc/process_output') + + ! clean up + call system_timer('do_cp2k_calc/cleanup') + if (tmp_run_dir_i>0) then + if (clean_up_files) then + !only delete files that need recreating, keep basis, potentials, psf + call system_command('rm -f '//trim(tmp_run_dir)//"/"//trim(proj)//"-* "//trim(tmp_run_dir)//"/cp2k_input.inp "//trim(tmp_run_dir)//"/cp2k_output.out "//trim(run_dir)) + else !save dir + exists = .true. + i = 0 + do while (exists) + i = i + 1 + dir = "cp2k_run_saved_"//i + call system_command("bash -c '[ -e "//trim(dir)//" ]'", status=stat) + exists = (stat == 0) + end do + call system_command("cp -r "//trim(run_dir)//" "//trim(dir), status=stat) + if (stat /= 0) then + RAISE_ERROR("Failed to copy "//trim(run_dir)//" to "//trim(dir)//" status " // stat, error) + endif + call system_command('rm -f '//trim(tmp_run_dir)//"/* "//trim(run_dir)) + endif + else + if (clean_up_files) then + if (clean_up_keep_n <= 0) then ! never keep any old directories around + call system_command('rm -rf '//trim(run_dir)) + else ! keep some (>= 1) old directories around + delete_dir_i = mod(run_dir_i, clean_up_keep_n+1)+1 + call system_command('rm -rf cp2k_run_'//delete_dir_i) + endif + endif + endif + if (allocated(rev_sort_index)) deallocate(rev_sort_index) + call system_timer('do_cp2k_calc/cleanup') + call system_timer('do_cp2k_calc') + + call verbosity_pop() + + end subroutine do_cp2k_calc + + subroutine do_cp2k_atoms_sort(at, sort_index_p, rev_sort_index, psf_print, topology_suffix, & + tmp_run_dir, tmp_run_dir_i, form_bond, break_bond, intrares_impropers, & + use_MM, have_silica_potential, have_titania_potential, error) + type(Atoms), intent(inout) :: at + integer, intent(out), pointer :: sort_index_p(:) + integer, intent(inout), allocatable :: rev_sort_index(:) + character(len=*), intent(in) :: psf_print + character(len=*), intent(in) :: topology_suffix + character(len=*), intent(in) :: tmp_run_dir + integer, intent(in) :: tmp_run_dir_i + integer :: form_bond(2), break_bond(2) + type(Table), intent(inout) :: intrares_impropers + logical, intent(in) :: use_MM, have_silica_potential, have_titania_potential + integer, optional, intent(out) :: error + + logical :: sorted + integer, pointer :: saved_rev_sort_index_p(:) + type(inoutput) :: rev_sort_index_io + integer :: at_i, iri_i + integer :: stat + + ! sort by molecule, residue ID + call add_property(at, 'sort_index', 0, n_cols=1, ptr=sort_index_p, error=error) + PASS_ERROR_WITH_INFO("Failed to add sort_index property", error) + ! initialise sort index + do at_i=1, at%N + sort_index_p(at_i) = at_i + end do + + ! do sort by read in order or labels + sorted = .false. + if (trim(psf_print) == 'USE_EXISTING_PSF') then ! read sort order + ! add property for saved reverse sort indx + call add_property(at, 'saved_rev_sort_index', 0, n_cols=1, ptr=saved_rev_sort_index_p, error=error) + PASS_ERROR_WITH_INFO("Failed to add saved_rev_sort_index property", error) + ! read it from file + if (tmp_run_dir_i>0) then + call system_command("if [ ! -s "//trim(tmp_run_dir)//"/quip_rev_sort_index"//trim(topology_suffix)// & + " ] ; then cp quip_rev_sort_index"//trim(topology_suffix)//" /tmp/cp2k_run_"//tmp_run_dir_i//"/ ; fi",status=stat) + if ( stat /= 0 ) then + RAISE_ERROR("Something went wrong when tried to copy quip_rev_sort_index"//trim(topology_suffix)//" into the tmp dir "//trim(tmp_run_dir),error) + endif + call initialise(rev_sort_index_io, trim(tmp_run_dir)//"/quip_rev_sort_index"//trim(topology_suffix), action=INPUT) + else + call initialise(rev_sort_index_io, "quip_rev_sort_index"//trim(topology_suffix), action=INPUT) + endif + call read_ascii(rev_sort_index_io, saved_rev_sort_index_p) + call finalise(rev_sort_index_io) + ! sort by it + call atoms_sort(at, 'saved_rev_sort_index', error=error) + PASS_ERROR_WITH_INFO ("do_cp2k_calc sorting atoms by read-in sort_index from quip_sort_order"//trim(topology_suffix), error) + sorted = .true. + endif + if (trim(psf_print) == 'DRIVER_PRINT_AND_SAVE') then ! sort by labels + if (has_property(at,'mol_id') .and. has_property(at,'atom_res_number')) then + if (has_property(at,'motif_atom_num')) then + call atoms_sort(at, 'mol_id', 'atom_res_number', 'motif_atom_num', error=error) + else + call atoms_sort(at, 'mol_id', 'atom_res_number', error=error) + endif + PASS_ERROR_WITH_INFO ("do_cp2k_calc sorting atoms by mol_id, atom_res_number, and motif_atom_num", error) + sorted = .true. + endif + endif + + if (allocated(rev_sort_index)) deallocate(rev_sort_index) + allocate(rev_sort_index(at%N)) + do at_i=1, at%N + rev_sort_index(sort_index_p(at_i)) = at_i + end do + + if (sorted) then + do at_i=1, at%N + if (sort_index_p(at_i) /= at_i) then + call print("sort() of at%data reordered some atoms") + exit + endif + end do + ! fix EVB bond forming/breaking indices for new sorted atom numbers + if (use_MM) then + if (have_silica_potential) then + call set_cutoff(at,SILICA_2body_CUTOFF) + call calc_connect(at) + elseif (have_titania_potential) then + call set_cutoff(at,TITANIA_2body_CUTOFF) + call calc_connect(at) + else + ! use hysteretic connect to get nearest neighbour cutoff + call calc_connect_hysteretic(at, DEFAULT_NNEIGHTOL, DEFAULT_NNEIGHTOL) + endif + call map_into_cell(at) + call calc_dists(at) + endif + + if ((all(form_bond > 0) .and. all(form_bond <= at%N)) .or. (all(break_bond > 0) .and. all(break_bond <= at%N))) then + if (all(form_bond > 0) .and. all(form_bond <= at%N)) form_bond(:) = rev_sort_index(form_bond(:)) + if (all(break_bond > 0) .and. all(break_bond <= at%N)) break_bond(:) = rev_sort_index(break_bond(:)) + end if + ! fix intrares impropers atom indices for new sorted atom numbers + do iri_i=1, intrares_impropers%N + intrares_impropers%int(1:4,iri_i) = rev_sort_index(intrares_impropers%int(1:4,iri_i)) + end do + else + call print("WARNING: didn't do sort_by_molecule - need saved sort_index or mol_id, atom_res_number, motif_atom_num. CP2K may complain", PRINT_ALWAYS) + end if + + end subroutine do_cp2k_atoms_sort + + subroutine read_output(at, qm_list_a, cur_qmmm_qm_abc, run_dir, proj, e, f, calc_qm_charges, do_calc_virial, & + save_reordering_index, out_i, error) + type(Atoms), intent(inout) :: at + integer, intent(in) :: qm_list_a(:) + real(dp), intent(in) :: cur_qmmm_qm_abc(3) + character(len=*), intent(in) :: run_dir, proj + real(dp), intent(out) :: e, f(:,:) + real(dp), pointer :: force_p(:,:) + character(len=*) :: calc_qm_charges + logical :: do_calc_virial, save_reordering_index + integer, intent(in), optional :: out_i + integer, intent(out), optional :: error + + integer, pointer :: reordering_index_p(:) + real(dp), pointer :: qm_charges_p(:) + real(dp) :: at_population, at_net_charge + type(Atoms) :: f_xyz, p_xyz + integer :: m + integer :: i, at_i + type(inoutput) :: t_io + character(len=STRING_LENGTH) :: at_species, t_line + integer :: at_kind + integer :: use_out_i + real(dp) :: virial(3,3) + character :: tx, ty, tz + integer :: istat + + INIT_ERROR(error) + + use_out_i = optional_default(0, out_i) + + call read(f_xyz, trim(run_dir)//'/'//trim(proj)//'-frc-1_'//use_out_i//'.xyz') + call read(p_xyz, trim(run_dir)//'/'//trim(proj)//'-pos-1_'//use_out_i//'.xyz') + nullify(qm_charges_p) + if (len_trim(calc_qm_charges) > 0) then + if (.not. assign_pointer(at, trim(calc_qm_charges), qm_charges_p)) then + call add_property(at, trim(calc_qm_charges), 0.0_dp, ptr=qm_charges_p) + endif + call initialise(t_io, trim(run_dir)//'/'//trim(proj)//'-qmcharges--1_'//use_out_i//'.mulliken',action=INPUT, error=error) + PASS_ERROR_WITH_INFO("cp2k_driver read_output() failed to open qmcharges file", error) + t_line='' + do while (index(adjustl(t_line),"#") <= 0) + t_line = read_line(t_io) + end do + do i=1, at%N + t_line = read_line(t_io) + read (unit=t_line,fmt=*) at_i, at_species, at_kind, at_population, at_net_charge + qm_charges_p(i) = at_net_charge + end do + call finalise(t_io) + endif + if (do_calc_virial) then + call initialise(t_io, trim(run_dir)//'/'//trim(proj)//'-stress-1_'//use_out_i//'.stress_tensor',action=INPUT, error=error) + PASS_ERROR_WITH_INFO("cp2k_driver failed to read cp2k stress_tensor file", error) + tx='' + ty='' + tz='' + ! look for line with just 'X Y Z' + t_line=read_line(t_io) + read(unit=t_line, fmt=*, iostat=istat) tx, ty, tz + do while (istat /= 0 .or. tx /= 'X' .or. ty /= 'Y' .or. tz /= 'Z') + t_line=read_line(t_io) + read(unit=t_line, fmt=*, iostat=istat) tx, ty, tz + end do + ! now let's ready stress + t_line=read_line(t_io) + read(unit=t_line, fmt=*, iostat=istat) tx, virial(1,1), virial(1,2), virial(1,3) + if (istat /= 0) then + RAISE_ERROR("cp2k_driver failed to read virial(1,:)", error) + endif + t_line=read_line(t_io) + read(unit=t_line, fmt=*, iostat=istat) tx, virial(2,1), virial(2,2), virial(2,3) + if (istat /= 0) then + RAISE_ERROR("cp2k_driver failed to read virial(2,:)", error) + endif + t_line=read_line(t_io) + read(unit=t_line, fmt=*, iostat=istat) tx, virial(3,1), virial(3,2), virial(3,3) + if (istat /= 0) then + RAISE_ERROR("cp2k_driver failed to read virial(3,:)", error) + endif + call print("got cp2k stress(1,:) "//virial(1,:)) + call print("got cp2k stress(2,:) "//virial(2,:)) + call print("got cp2k stress(3,:) "//virial(3,:)) + ! convert from stress GPa to virial in native units + virial = cell_volume(at)*virial/EV_A3_IN_GPA + call set_value(at%params, 'virial', virial) + call finalise(t_io) + endif + + if (.not. get_value(f_xyz%params, "E", e)) then + RAISE_ERROR('read_output failed to find E value in '//trim(run_dir)//'/'//trim(proj)//'-frc-1_'//use_out_i//'.xyz file', error) + endif + + if (.not.(assign_pointer(f_xyz, 'frc', force_p))) then + RAISE_ERROR("Did not find frc property in "//trim(run_dir)//'/'//trim(proj)//'-frc-1_'//use_out_i//'.xyz file', error) + endif + f = force_p + + nullify(reordering_index_p) + if (save_reordering_index) then + if (.not. assign_pointer(at, "reordering_index", reordering_index_p)) then + call add_property(at, "reordering_index", 0, ptr=reordering_index_p) + endif + end if + + e = e * HARTREE + f = f * HARTREE/BOHR + call reorder_if_necessary(at, qm_list_a, cur_qmmm_qm_abc, p_xyz%pos, f, qm_charges_p, & + reordering_index_p, error=error) + PASS_ERROR_WITH_INFO("cp2k_driver read_output failed to reorder atmos", error) + + call print('') + call print('The energy of the system: '//e) + call verbosity_push_decrement() + call print('The forces acting on each atom (eV/A):') + call print('atom F(x) F(y) F(z)') + do m=1,size(f,2) + call print(' '//m//' '//f(1,m)//' '//f(2,m)//' '//f(3,m)) + enddo + call verbosity_pop() + call print('Sum of the forces: '//sum(f,2)) + + end subroutine read_output + + subroutine reorder_if_necessary(at, qm_list_a, qmmm_qm_abc, new_p, new_f, qm_charges_p, & + reordering_index_p, error) + type(Atoms), intent(in) :: at + integer, intent(in) :: qm_list_a(:) + real(dp), intent(in) :: qmmm_qm_abc(3) + real(dp), intent(in) :: new_p(:,:) + real(dp), intent(inout) :: new_f(:,:) + real(dp), intent(inout), pointer :: qm_charges_p(:) + integer, intent(out), pointer :: reordering_index_p(:) + integer, optional, intent(out) :: error + + real(dp) :: shift(3) + integer, allocatable :: reordering_index(:) + integer :: i + + INIT_ERROR(error) + + ! shifted cell in case of QMMM (cp2k/src/topology_coordinate_util.F) + shift = 0.0_dp + if (size(qm_list_a) > 0) then + do i=1,3 + shift(i) = 0.5_dp * qmmm_qm_abc(i) - (minval(at%pos(i,qm_list_a)) + maxval(at%pos(i,qm_list_a)))*0.5_dp + end do + endif + allocate(reordering_index(at%N)) + call print('trying to reorder with shift='//shift) + call system_timer('reorder_if_necessary/check_reordering_1') + call check_reordering(at%pos, shift, new_p, at%g, reordering_index) + call system_timer('reorder_if_necessary/check_reordering_1') + if (any(reordering_index == 0)) then + ! try again with shift of a/2 b/2 c/2 in case TOPOLOGY%CENTER_COORDINATES is set + shift = sum(at%lattice(:,:),2)/2.0_dp - & + (minval(at%pos(:,:),2)+maxval(at%pos(:,:),2))/2.0_dp + call print('trying to reorder with shift='//shift) + call system_timer('reorder_if_necessary/check_reordering_2') + call check_reordering(at%pos, shift, new_p, at%g, reordering_index) + call system_timer('reorder_if_necessary/check_reordering_2') + if (any(reordering_index == 0)) then + ! try again with uniform shift (module periodic cell) + shift = new_p(:,1) - at%pos(:,1) + call print('trying to reorder with shift='//shift) + call system_timer('reorder_if_necessary/check_reordering_3') + call check_reordering(at%pos, shift, new_p, at%g, reordering_index) + call system_timer('reorder_if_necessary/check_reordering_3') + if (any(reordering_index == 0)) then + RAISE_ERROR("Could not match original and read in atom objects",error) + endif + endif + endif + + do i=1, at%N + if (reordering_index(i) /= i) then + call print("WARNING: reorder_if_necessary indeed found reordered atoms", PRINT_ALWAYS) + exit + endif + end do + + if (associated(reordering_index_p)) then + if (size(reordering_index_p) < size(reordering_index)) then + RAISE_ERROR("save_reordering_index too small", error) + end if + reordering_index_p(1:size(reordering_index)) = reordering_index + end if + + new_f(1,reordering_index(:)) = new_f(1,:) + new_f(2,reordering_index(:)) = new_f(2,:) + new_f(3,reordering_index(:)) = new_f(3,:) + if (associated(qm_charges_p)) then + qm_charges_p(reordering_index(:)) = qm_charges_p(:) + endif + + deallocate(reordering_index) + end subroutine reorder_if_necessary + + subroutine check_reordering(old_p, shift, new_p, recip_lattice, reordering_index) + real(dp), intent(in) :: old_p(:,:), shift(3), new_p(:,:), recip_lattice(3,3) + integer, intent(out) :: reordering_index(:) + + integer :: N, i, j + real(dp) :: dpos(3), dpos_i(3) + + N = size(old_p,2) + + reordering_index = 0 + do i=1, N + ! check for same-order + j = i + dpos = matmul(recip_lattice(1:3,1:3), old_p(1:3,i) + shift(1:3) - new_p(1:3,j)) + dpos_i = nint(dpos) + if (all(abs(dpos-dpos_i) <= 1.0e-4_dp)) then + reordering_index(i) = j + else ! not same order, search + do j=1, N + dpos = matmul(recip_lattice(1:3,1:3), old_p(1:3,i) + shift(1:3) - new_p(1:3,j)) + dpos_i = nint(dpos) + if (all(abs(dpos-dpos_i) <= 1.0e-4_dp)) then + reordering_index(i) = j + exit + endif + end do + end if + end do + end subroutine check_reordering + + subroutine start_cp2k_program_background(cp2k_program, run_dir, error) + character(len=*), intent(in) :: cp2k_program, run_dir + integer, optional, intent(out) :: error + + character(len=STRING_LENGTH) :: cp2k_run_command + integer :: stat + + INIT_ERROR(error) + + cp2k_run_command = 'cd ' // trim(run_dir)//'; '//trim(cp2k_program)//' cp2k_input.inp >> cp2k_output.out &' + call print("Doing '"//trim(cp2k_run_command)//"'") + call system_command(trim(cp2k_run_command), status=stat) + if (stat /= 0) then + RAISE_ERROR("failed to start cp2k program in the background", error) + endif + end subroutine start_cp2k_program_background + + subroutine run_cp2k_program(cp2k_program, run_dir, max_n_tries, error) + character(len=*), intent(in) :: cp2k_program, run_dir + integer, intent(in) :: max_n_tries + integer, optional, intent(out) :: error + + integer :: n_tries + logical :: converged + character(len=STRING_LENGTH) :: cp2k_run_command + integer :: stat, stat2, error_stat + + INIT_ERROR(error) + + n_tries = 0 + converged = .false. + + do while (.not. converged .and. (n_tries < max_n_tries)) + n_tries = n_tries + 1 + + cp2k_run_command = 'cd ' // trim(run_dir)//'; '//trim(cp2k_program)//' cp2k_input.inp >> cp2k_output.out 2>&1' + call print("Doing '"//trim(cp2k_run_command)//"'") + call system_timer('cp2k_run_command') + call system_command(trim(cp2k_run_command), status=stat) + call system_timer('cp2k_run_command') + call print('grep -i warning '//trim(run_dir)//'/cp2k_output.out', PRINT_ALWAYS) + call system_command("fgrep -i 'warning' "//trim(run_dir)//"/cp2k_output.out") + call system_command("fgrep -i 'error' "//trim(run_dir)//"/cp2k_output.out", status=error_stat) + if (stat /= 0) then + ! RAISE_ERROR('cp2k_run_command has non zero return status ' // stat //'. check output file '//trim(run_dir)//'/cp2k_output.out', error) + call print('WARNING: cp2k_run_command has non zero return status ' // stat //'. check output file '//trim(run_dir)//'/cp2k_output.out', error) + endif + if (error_stat == 0) then + ! RAISE_ERROR('cp2k_run_command generated ERROR message in output file '//trim(run_dir)//'/cp2k_output.out', error) + call print('WARNING: cp2k_run_command generated ERROR message in output file '//trim(run_dir)//'/cp2k_output.out', error) + endif + + call system_command('egrep "QS" '//trim(run_dir)//'/cp2k_output.out',status=stat) + if (stat == 0) then ! QS or QMMM run + call system_command('grep "FAILED to converge" '//trim(run_dir)//'/cp2k_output.out',status=stat) + if (stat == 0) then + call print("WARNING: cp2k_driver failed to converge, trying again",PRINT_ALWAYS) + converged = .false. + else + call system_command('grep "outer SCF loop converged" '//trim(run_dir)//'/cp2k_output.out',status=stat) ! OT mode + call system_command('grep "SCF run converged" '//trim(run_dir)//'/cp2k_output.out',status=stat2) ! density mixing mode + if (stat == 0 .or. stat2 == 0) then + converged = .true. + else + call print("WARNING: cp2k_driver couldn't find definitive sign of convergence or failure to converge in output file, trying again",PRINT_ALWAYS) + converged = .false. + endif + end if + else ! MM run + converged = .true. + endif + end do + + if (.not. converged) then + RAISE_ERROR('cp2k failed to converge after n_tries='//n_tries//'. see output file '//trim(run_dir)//'/cp2k_output.out',error) + endif + + end subroutine run_cp2k_program + + function qmmm_qm_abc(at, qm_list_a, qm_vacuum) + type(Atoms), intent(in) :: at + integer, intent(in) :: qm_list_a(:) + real(dp), intent(in) :: qm_vacuum + real(dp) :: qmmm_qm_abc(3) + + real(dp) :: qm_maxdist(3) + integer i, j + + qm_maxdist = 0.0_dp + do i=1, size(qm_list_a) + do j=1, size(qm_list_a) + qm_maxdist(1) = max(qm_maxdist(1), at%pos(1,qm_list_a(i))-at%pos(1,qm_list_a(j))) + qm_maxdist(2) = max(qm_maxdist(2), at%pos(2,qm_list_a(i))-at%pos(2,qm_list_a(j))) + qm_maxdist(3) = max(qm_maxdist(3), at%pos(3,qm_list_a(i))-at%pos(3,qm_list_a(j))) + end do + end do + + qmmm_qm_abc(1) = min(real(ceiling(qm_maxdist(1)))+qm_vacuum,at%lattice(1,1)) + qmmm_qm_abc(2) = min(real(ceiling(qm_maxdist(2)))+qm_vacuum,at%lattice(2,2)) + qmmm_qm_abc(3) = min(real(ceiling(qm_maxdist(3)))+qm_vacuum,at%lattice(3,3)) + + end function qmmm_qm_abc + + subroutine calc_charge_lsd(at, qm_list_a, charge, do_lsd, n_hydrogen, hydrogen_charge, & + n_extra_electrons, use_mm_charges, error) + type(Atoms), intent(in) :: at + integer, intent(in) :: qm_list_a(:) + integer, intent(out) :: charge + logical, intent(out) :: do_lsd + integer, intent(in) :: n_hydrogen + real(dp), intent(in) :: hydrogen_charge + integer, intent(in) :: n_extra_electrons + logical, intent(in) :: use_mm_charges + integer, intent(out), optional :: error + + real(dp), pointer :: atom_charge(:) + integer, pointer :: Z_p(:) + integer :: sum_Z + integer :: l_error + real(dp) :: sum_charge + + INIT_ERROR(error) + + if (.not. assign_pointer(at, "Z", Z_p)) then + RAISE_ERROR("calc_charge_lsd could not find Z property", error) + endif + + if (size(qm_list_a) > 0) then + if (.not. assign_pointer(at, "atom_charge", atom_charge)) then + RAISE_ERROR("calc_charge_lsd could not find atom_charge", error) + endif + sum_charge = 0.0_dp + if (use_mm_charges) then + sum_charge = sum(atom_charge(qm_list_a)) + end if + call print('sum_charge before correction = '//sum_charge) + if (use_mm_charges) then + call print('n_hydrogen = '//n_hydrogen//', n_extra_electrons = '//n_extra_electrons) + sum_charge = sum_charge + n_hydrogen*hydrogen_charge ! terminating hydrogens + end if + sum_charge = sum_charge - n_extra_electrons + call print('sum_charge = '//sum_charge) + charge = nint(sum_charge) + + !check if we have an odd number of electrons + sum_Z = sum(Z_p(qm_list_a(1:size(qm_list_a)))) + sum_Z = sum_Z + n_hydrogen ! include terminating hydrogens + call print('sum_Z = '//sum_Z) + do_lsd = (mod(sum_Z-charge,2) /= 0) + else + sum_Z = sum(Z_p) + do_lsd = .false. + charge = 0 + call get_param_value(at, 'LSD', do_lsd, error=l_error) ! ignore error + CLEAR_ERROR(error) + !if charge is saved, also check if we have an odd number of electrons + call get_param_value(at, 'Charge', charge, error=l_error) + CLEAR_ERROR(error) + if (l_error == 0) then + call print("Using Charge " // charge) + do_lsd = do_lsd .or. (mod(sum_Z-charge,2) /= 0) + else !charge=0 is assumed by CP2K + do_lsd = do_lsd .or. (mod(sum_Z,2) /= 0) + endif + if (do_lsd) call print("Using do_lsd " // do_lsd) + endif + + end subroutine calc_charge_lsd + + subroutine do_cp2k_calc_fake(at, f, e, do_calc_virial, args_str, error) + type(Atoms), intent(inout) :: at + real(dp), intent(out) :: f(:,:), e + logical, intent(in) :: do_calc_virial + character(len=*), intent(in) :: args_str + integer, intent(out), optional :: error + + type(inoutput) :: last_run_io + type(inoutput) :: stress_io + type(cinoutput) :: force_cio + character(len=STRING_LENGTH) :: last_run_s + integer :: this_run_i + integer :: stat + type(Atoms) :: for + real(dp), pointer :: frc(:,:) + + integer :: cur_i + character(len=1024) :: l + character t_s + real(dp) :: virial(3,3) + logical :: got_virial + + INIT_ERROR(error) + + call initialise(last_run_io, "cp2k_driver_fake_run", action=INPUT) + last_run_s = read_line(last_run_io, status=stat) + call finalise(last_run_io) + if (stat /= 0) then + this_run_i = 1 + else + read (fmt=*,unit=last_run_s) this_run_i + this_run_i = this_run_i + 1 + endif + + call print("do_cp2k_calc_fake run_i " // this_run_i, PRINT_ALWAYS) + + call initialise(force_cio, "cp2k_force_file_log") + call read(force_cio, for, frame=this_run_i-1) + !NB why does this crash now? + ! call finalise(force_cio) + if (.not. assign_pointer(for, 'frc', frc)) then + RAISE_ERROR("do_cp2k_calc_fake couldn't find frc field in force log file",error) + endif + f = frc + + if (.not. get_value(for%params, "energy", e)) then + if (.not. get_value(for%params, "Energy", e)) then + if (.not. get_value(for%params, "E", e)) then + RAISE_ERROR("do_cp2k_calc_fake didn't find energy",error) + endif + endif + endif + + if (do_calc_virial) then + call initialise(stress_io, "cp2k_stress_file_log", action=INPUT) + got_virial=.false. + cur_i=0 + do while (.not. got_virial) + l=read_line(stress_io, status=stat) + if (stat /= 0) exit + if (index(trim(l), "STRESS TENSOR [GPa]") > 0) then + cur_i=cur_i + 1 + endif + if (cur_i == this_run_i) then + if (index(trim(l), 'X') > 0 .and. index(trim(l), 'Y') <= 0) read(unit=l, fmt=*) t_s, virial(1,1), virial(1,2), virial(1,3) + if (index(trim(l), 'Y') > 0 .and. index(trim(l), 'X') <= 0) read(unit=l, fmt=*) t_s, virial(2,1), virial(2,2), virial(2,3) + if (index(trim(l), 'Z') > 0 .and. index(trim(l), 'Y') <= 0) then + read(unit=l, fmt=*) t_s, virial(3,1), virial(3,2), virial(3,3) + got_virial=.true. + endif + endif + end do + if (.not. got_virial) then + RAISE_ERROR("do_cp2k_calc_fake got do_calc_virial but couldn't read virial for config "//this_run_i//" from cp2k_stress_file_log",error) + endif + call print("got cp2k stress(1,:) "//virial(1,:)) + call print("got cp2k stress(2,:) "//virial(2,:)) + call print("got cp2k stress(3,:) "//virial(3,:)) + virial = cell_volume(at)*virial/EV_A3_IN_GPA + call set_value(at%params, 'virial', virial) + call finalise(stress_io) + endif + + e = e * HARTREE + f = f * HARTREE/BOHR + + call initialise(last_run_io, "cp2k_driver_fake_run", action=OUTPUT) + call print(""//this_run_i, file=last_run_io) + call finalise(last_run_io) + + end subroutine do_cp2k_calc_fake + + + subroutine get_qm_list(at, use_buffer, run_suffix, link_template_file, qm_list, old_qm_list, qm_list_a, old_qm_list_a, & + link_list_a, old_link_list_a, qm_and_link_list_a, rev_sort_index, cut_bonds, cut_bonds_p, old_cut_bonds, old_cut_bonds_p, & + link_template_a, link_template_n_lines, qmmm_link_type, qmmm_link_qm_kind_z, error) + type(Atoms), intent(inout) :: at + logical, intent(in) :: use_buffer + character(len=*), intent(in) :: run_suffix, link_template_file, qmmm_link_type + type(Table), intent(inout) :: qm_list, old_qm_list + integer, allocatable, intent(inout) :: qm_list_a(:), old_qm_list_a(:), link_list_a(:), old_link_list_a(:), qm_and_link_list_a(:) + integer, intent(in) :: rev_sort_index(:) + type(Table), intent(inout) :: cut_bonds, old_cut_bonds + integer, pointer, intent(inout) :: cut_bonds_p(:,:), old_cut_bonds_p(:,:) + character(len=STRING_LENGTH), allocatable, intent(inout) :: link_template_a(:) + integer, intent(inout) :: link_template_n_lines + integer, intent(in) :: qmmm_link_qm_kind_z + integer, intent(out), optional :: error + + integer :: i_inner, i_outer, j + type(Inoutput) :: link_template_io + + INIT_ERROR(error) + + ! get qm_list and link_list + if (use_buffer) then + call get_hybrid_list(at, qm_list, all_but_term=.true.,int_property="cluster_mark"//trim(run_suffix)) + call get_hybrid_list(at, old_qm_list, all_but_term=.true.,int_property="old_cluster_mark"//trim(run_suffix)) + else + call get_hybrid_list(at, qm_list, active_trans_only=.true.,int_property="cluster_mark"//trim(run_suffix)) + call get_hybrid_list(at, old_qm_list, active_trans_only=.true.,int_property="old_cluster_mark"//trim(run_suffix)) + endif + if (allocated(qm_list_a)) deallocate(qm_list_a) + if (allocated(old_qm_list_a)) deallocate(old_qm_list_a) + if (allocated(link_list_a)) deallocate(link_list_a) + if (allocated(old_link_list_a)) deallocate(old_link_list_a) + if (allocated(qm_and_link_list_a)) deallocate(qm_and_link_list_a) + allocate(qm_list_a(qm_list%N), old_qm_list_a(old_qm_list%N)) + if (qm_list%N > 0) qm_list_a = int_part(qm_list,1) + if (old_qm_list%N > 0) old_qm_list_a = int_part(old_qm_list,1) + !get link list + + if (assign_pointer(at,'cut_bonds'//trim(run_suffix),cut_bonds_p)) then + call initialise(cut_bonds,2,0,0,0,0) + do i_inner=1,at%N + do j=1,size(cut_bonds_p,1) !MAX_CUT_BONDS + if (cut_bonds_p(j,i_inner) == 0) exit + ! correct for new atom indices resulting from sorting of atoms + i_outer = rev_sort_index(cut_bonds_p(j,i_inner)) + + ! If we're doing QM_KIND linking, skip bonds which do not originate from the correct species + if (trim(qmmm_link_type) == "QM_KIND" .and. at%Z(i_inner) /= qmmm_link_qm_kind_z) cycle + call append(cut_bonds,(/i_inner,i_outer/)) + enddo + enddo + if (cut_bonds%N > 0) then + call uniq(cut_bonds%int(2,1:cut_bonds%N),link_list_a) + allocate(qm_and_link_list_a(size(qm_list_a)+size(link_list_a))) + qm_and_link_list_a(1:size(qm_list_a)) = qm_list_a(1:size(qm_list_a)) + qm_and_link_list_a(size(qm_list_a)+1:size(qm_list_a)+size(link_list_a)) = link_list_a(1:size(link_list_a)) + else + allocate(link_list_a(0)) + allocate(qm_and_link_list_a(size(qm_list_a))) + if (size(qm_list_a) > 0) qm_and_link_list_a = qm_list_a + endif + else + allocate(qm_and_link_list_a(size(qm_list_a))) + if (size(qm_list_a) > 0) qm_and_link_list_a = qm_list_a + endif + + call initialise(old_cut_bonds,2,0,0,0,0) + if(assign_pointer(at, 'old_cut_bonds'//trim(run_suffix), old_cut_bonds_p)) then + do i_inner=1,at%N + do j=1,size(old_cut_bonds_p,1) !MAX_CUT_BONDS + if (old_cut_bonds_p(j,i_inner) == 0) exit + ! correct for new atom indices resulting from sorting of atoms + i_outer = rev_sort_index(old_cut_bonds_p(j,i_inner)) + call append(old_cut_bonds,(/i_inner,i_outer/)) + enddo + enddo + end if + + !If needed, read QM/MM link_template_file + if (size(link_list_a) > 0 .and. trim(qmmm_link_type) /= "QM_KIND") then + if (trim(link_template_file).eq."") then + RAISE_ERROR("There are QM/MM links, but qmmm_link_template is not defined.",error) + endif + call initialise(link_template_io, trim(link_template_file), INPUT) + call read_file(link_template_io, link_template_a, link_template_n_lines) + call finalise(link_template_io) + end if + end subroutine get_qm_list + + + subroutine cp2k_state_change(at, to, from_list, ignore_failure, error) + type(Atoms), intent(inout) :: at + character(len=*), intent(in) :: to, from_list(:) + logical, optional, intent(in) :: ignore_failure + integer, optional, intent(out) :: error + + character(STRING_LENGTH) :: from + integer, pointer :: cluster_mark_from(:), cut_bonds_from(:,:), hybrid_mark_from(:) + integer i + real(dp) QM_cell(3) + logical found, do_ignore_failure + + INIT_ERROR(error) + do_ignore_failure = optional_default(.false., ignore_failure) + + found = .false. + do i=1, size(from_list) + if (assign_pointer(at, 'cluster_mark'//trim(from_list(i)), cluster_mark_from)) then + from = from_list(i) + found = .true. + exit + end if + end do + if (.not. do_ignore_failure .and. .not. found) then + RAISE_ERROR('cp2k_state_change cannot find any previous states in from_list', error) + end if + + call print('cp2k_state_change changing CP2K saved state from '//trim(from)//' to '//trim(to)) + call print('cp2k_state_change copying property cluster_mark'//trim(from)//' to cluster_mark'//trim(to)) + call add_property(at, 'cluster_mark'//trim(to), cluster_mark_from, overwrite=.true.) + if (.not. assign_pointer(at, 'cut_bonds'//trim(from), cut_bonds_from)) then + RAISE_ERROR('cp2k_state_change found cluster_mark'//trim(from)//'but not cut_bonds'//trim(from)//' - inconsistent!', error) + end if + call print('cp2k_state_change copying property cut_bonds'//trim(from)//' to cut_bonds'//trim(to)) + call add_property(at, 'cut_bonds'//trim(to), cut_bonds_from, overwrite=.true.) + if (get_value(at%params, 'QM_cell'//trim(from), QM_cell)) then + call print('cp2k_state_change set_value QM_cell'//trim(to)//' '//QM_cell) + call set_value(at%params, 'QM_cell'//trim(to), QM_cell) + end if + if (.not. assign_pointer(at, 'hybrid_mark'//trim(from), hybrid_mark_from)) then + RAISE_ERROR('cp2k_state_change found cluster_mark'//trim(from)//'but not hybrid_mark'//trim(from)//' - inconsistent!', error) + end if + call print('cp2k_state_change copying property hybrid_mark'//trim(from)//' to hybrid_mark'//trim(to)) + call add_property(at, 'hybrid_mark'//trim(to), hybrid_mark_from, overwrite=.true.) + call print('cp2k_state_change executing "if [ -f wfn.restart.wfn'//trim(from)//' ] ; then cp wfn.restart.wfn'//trim(from)//' wfn.restart.wfn'//trim(to)//' ; fi "') + call system_command('if [ -f wfn.restart.wfn'//trim(from)//' ] ; then cp wfn.restart.wfn'//trim(from)//' wfn.restart.wfn'//trim(to)//' ; fi') + + end subroutine cp2k_state_change + + !momentum conservation + ! weighing function: 1 (simply subtract sumF/n) + !?! weighing function: m (keeping same acceleration on the atoms) + subroutine sum0(force) + + real(dp), dimension(:,:), intent(inout) :: force + integer :: i + real(dp) :: sumF(3) + + do i = 1, size(force,2) + sumF(1) = sum(force(1,1:size(force,2))) + sumF(2) = sum(force(2,1:size(force,2))) + sumF(3) = sum(force(3,1:size(force,2))) + enddo + + if ((sumF(1).feq.0.0_dp).and.(sumF(2).feq.0.0_dp).and.(sumF(3).feq.0.0_dp)) then + call print('cp2k_driver: Sum of the forces are zero.') + return + endif + + call print('cp2k_driver: Sum of the forces was '//sumF(1:3)) + sumF = sumF / size(force,2) + + do i = 1, size(force,2) + force(1:3,i) = force(1:3,i) - sumF(1:3) + enddo + + do i = 1, size(force,2) + sumF(1) = sum(force(1,1:size(force,2))) + sumF(2) = sum(force(2,1:size(force,2))) + sumF(3) = sum(force(3,1:size(force,2))) + enddo + call print('cp2k_driver: Sum of the forces after mom.cons.: '//sumF(1:3)) + + end subroutine sum0 + + +end module cp2k_driver_module diff --git a/src/FilePot_drivers/cp2k_driver_old.F90 b/src/FilePot_drivers/cp2k_driver_old.F90 new file mode 100644 index 0000000000..9f735c5149 --- /dev/null +++ b/src/FilePot_drivers/cp2k_driver_old.F90 @@ -0,0 +1,2708 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X cp2k_driver_module +!X +!% Old driver for CP2K code using a hardcoded input file, outdated +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!CP2K driver + +!to use external basis set or potential list add to atoms%params BASIS_SET_list=... or POTENTIAL_list=..., +! or pass to calc in args_str (see below) +!the format is for H and O (for example): +!2 !number of lines +!1 DZVP-GTH-BLYP !atomic number and basis set +!8 DZVP-GTH-BLYP +! +!arguments to be passed to go_cp2k in the args_str: +! Run_Type, default: 'MM', also understands 'QS', 'QMMM_CORE', and 'QMMM_EXTENDED' +! PSF_Print, default: 'NO_PSF', also understands 'CP2K_PRINT_AND_SAVE', 'DRIVER_PRINT_AND_SAVE', 'USE_EXISTING_PSF' +! cp2k_program, default:'cp2k.sopt' +! basis_set_file: default none, name of file (instead of atoms%params value BASIS_SET_list) +! potential_file: default none, name of file (instead of atoms%params value POTENTIAL_list) +! dft_file: default none, name of file +! cell_file: default none, name of file +! clean_up_files: default TRUE +! +!contains the following subroutines and functions: +! +!S param_initialise(this,at,run_type,cp2k_program,basis_set_file,potential_file,dft_file,cell_file,use_cubic_cell) +!S param_finalise(this) +!S create_centred_qmcore(my_atoms,R_inner,R_outer,origin,list_changed) +!S print_qm_region(at, file) +!S construct_buffer_origin(my_atoms,Radius,list,origin) +!S read_list_file(this,filename,basis_set,potential) +!S go_cp2k(my_atoms,forces,energy,args_str) +!F extend_qmlist(my_atoms,R_inner,R_outer) result(list_changed) +!S construct_buffer_RADIUS(my_atoms,core,radius,buffer,use_avgpos,verbosity) +!S get_qm_list_int(my_atoms,qmflag,qmlist) +!S get_qm_list_int_rec(my_atoms,qmflag,qmlist,do_recursive) +!S get_qm_list_array(my_atoms,qmflags,qmlist) +!F get_property(my_atoms,prop) result(prop_index) +!S read_qmlist(my_atoms,qmlistfilename,PRINT_verbose) +!F num_of_bonds(at) result(bonds) +!S check_neighbour_numbers(at) +!F check_list_change(old_list,new_list) result(list_changed) +!S write_cp2k_input_files(my_atoms,qm_list,param,run_type,PSF_print) +!S write_cp2k_input_file(my_atoms,qm_list,param,run_type,PSF_print) +!S read_cp2k_forces(forces,energy,param,my_atoms,run_type,PRINT_verbose) +!S read_convert_back_pos(forces,param,my_atoms,run_type,PRINT_verbose) +!S QUIP_combine_forces(qmmm_forces,mm_forces,combined_forces,my_atoms) +!S abrupt_force_mixing(qmmm_forces,mm_forces,combined_forces,my_atoms) +!F spline_force(at, i, my_spline, pot) result(force) +!S energy_conversion(energy) +!S force_conversion(force) +!S velocity_conversion(at) +!S velocity_conversion_rev(at) +!F real_feq2(x,y) result(feq) +!F matrix_feq2(matrix1,matrix2) result (feq) + +module cp2k_driver_module + +! use libatoms_module + + use atoms_module, only: atoms, initialise, finalise, & + read_xyz, add_property, & + map_into_cell, & + set_cutoff, set_cutoff_minimum, & + calc_connect, DEFAULT_NNEIGHTOL, & + distance_min_image, & + read_line, parse_line, & + assignment(=), atoms_n_neighbours, remove_bond, & + assign_pointer, print_xyz, atoms_neighbour, is_nearest_neighbour + use clusters_module, only: bfs_step,& + construct_hysteretic_region, & + !select_hysteretic_quantum_region, & + add_cut_hydrogens + use dictionary_module, only: dictionary, initialise, finalise, & + get_value, set_value, & + value_len, read_string + use linearalgebra_module, only: find_in_array, find, & + print, operator(.feq.), & + check_size + use paramreader_module, only: param_register, param_read_line, & + STRING_LENGTH + use periodictable_module, only: ElementName, ElementCovRad, ElementMass, total_elements + use structures_module, only: find_motif + use system_module, only: dp, inoutput, initialise, finalise, & + INPUT, OUTPUT, INOUT, & + system_timer, & + system_command, & + system_abort, & + optional_default, & + print, print_title, & + string_to_int, string_to_real, round, & + parse_string, read_line, & + operator(//), & + ERROR, PRINT_SILENT, PRINT_NORMAL, PRINT_VERBOSE, PRINT_NERD, PRINT_ANALYSIS, & + verbosity_push_decrement, verbosity_pop, current_verbosity, & + mainlog + use table_module, only: table, initialise, finalise, & + append, allocate, delete, & + int_part, TABLE_STRING_LENGTH, print + use topology_module, only: write_psf_file, create_CHARMM, & + delete_metal_connects, & + write_cp2k_pdb_file, & + NONE_RUN, QS_RUN, MM_RUN, & + QMMM_RUN_CORE, QMMM_RUN_EXTENDED + use units_module, only: HARTREE, BOHR, HBAR + +! use quantumselection_module + implicit none + + private :: param_initialise + private :: finalise +! private :: construct_buffer_RADIUS + private :: get_qm_list_array + private :: get_qm_list_int + private :: get_qm_list_int_rec + private :: read_cp2k_forces + private :: read_convert_back_pos + private :: real_feq2 + private :: matrix_feq2 + private :: write_cp2k_input_files + private :: write_cp2k_input_file +! private :: combine_forces + + public :: create_centred_qmcore, & + !extend_qmlist, & + check_list_change, & + num_of_bonds, & + get_qm_list, & + get_property, & + go_cp2k, & + read_qmlist, & + check_neighbour_numbers, & + QUIP_combine_forces, & + spline_force, & + energy_conversion, & + force_conversion, & + velocity_conversion, & + velocity_conversion_rev + +!parameters for Run_Type +! see in ../libAtoms/Topology.f95 +!parameters for PSF_Print + integer, parameter :: CP2K_PRINT_AND_SAVE = -1 + integer, parameter :: NO_PSF = 0 + integer, parameter :: DRIVER_PRINT_AND_SAVE = 1 + integer, parameter :: USE_EXISTING_PSF = 2 + + integer, parameter, private :: MAX_CHAR_LENGTH = 200 ! for the system_command + real(dp), parameter :: DEFAULT_QM_BUFFER_WIDTH = 4.5_dp + + real(dp), parameter :: EPSILON_ZERO = 1.e-8_dp !to check if xyz atoms equal + + type spline_pot + real(dp) :: from + real(dp) :: to + real(dp) :: dpot + end type spline_pot + +!!!!! ============================================================================================ !!!!! +!!!!! !!!!! +!!!!! \/ \/ \/ \/ \/ \/ ---------- parameters type to run CP2K ---------- \/ \/ \/ \/ \/ \/ !!!!! +!!!!! !!!!! +!!!!! ============================================================================================ !!!!! + + type param_dft_nml + character(len=value_len) :: file + real(dp) :: mgrid_cutoff != 300.0_dp + character(20) :: scf_guess != 'atomic' + character(20) :: xc_functional !!= 'BLYP' + end type param_dft_nml + + type param_mm_forcefield_nml + character(20) :: parmtype != 'CHM' + character(20) :: parm_file_name != 'charmm.pot' + real(dp) :: charge_OT != -0.834_dp + real(dp) :: charge_HT != 0.417_dp + end type param_mm_forcefield_nml + + type param_mm_ewald_nml + character(20) :: ewald_type != 'ewald' + real(dp) :: ewald_alpha != 0.44_dp + integer :: ewald_gmax != 25 + end type param_mm_ewald_nml + + type param_qmmm_nml + real(dp),dimension(3) :: qmmm_cell != (/8.0_dp,8.0_dp,8.0_dp/) + character(20) :: qmmm_cell_unit != 'ANGSTROM' + logical :: reuse_wfn + character(20) :: ecoupl != 'GAUSS' + real(dp) :: radius_H != 0.44_dp + real(dp) :: radius_O != 0.78_dp + real(dp) :: radius_C != 0.80_dp + real(dp) :: radius_N != 0.80_dp + real(dp) :: radius_S != 0.80_dp + real(dp) :: radius_Cl != 0.80_dp + real(dp) :: radius_Na != 0.80_dp + real(dp) :: radius_Si !=0.80_dp + end type param_qmmm_nml + + type param_global_nml + character(20) :: project != 'cp2k' + character(20) :: runtype != 'MD' + character(len=value_len) :: cell_file, global_file + end type param_global_nml + + type param_md_nml + character(20) :: ensemble != 'NVE' + integer :: steps != 0 + real(dp) :: timestep != 0.5_dp + real(dp) :: temperature != 300.0_dp + end type param_md_nml + + type working_env + character(80) :: working_directory !directory for temporary files used by cp2k + character(80) :: pdb_file + character(80) :: exyz_file + character(80) :: psf_file + character(80) :: wfn_file + character(80) :: cp2k_input_filename !='cp2k_input.inp' + character(80) :: force_file != 'cp2k-frc-1.xyz' + character(80) :: pos_file != 'cp2k-pos-1.xyz' + character(80) :: wrk_filename != 'wrk.dat' + character(800) :: cp2k_program != 'cp2k_serial' or 'cp2k_popt'. long, for possible long path + end type working_env + + type param_cp2k + + type(Dictionary) :: basis_set + type(Dictionary) :: potential + type(param_dft_nml) :: dft + type(param_mm_forcefield_nml) :: mm_forcefield + type(param_mm_ewald_nml) :: mm_ewald + type(param_qmmm_nml) :: qmmm + type(param_global_nml) :: global + type(param_md_nml) :: md + type(working_env) :: wenv + + integer :: N + logical :: initialised + + end type param_cp2k + + interface finalise + module procedure param_finalise + end interface finalise + + interface get_qm_list + module procedure get_qm_list_int, get_qm_list_int_rec, get_qm_list_array + end interface get_qm_list + +contains + + !!!!! ============================================================================================ !!!!! + !!!!! !!!!! + !!!!! \/ \/ \/ \/ \/ \/ ---------- initialise parameters to run CP2K ---------- \/ \/ \/ \/ \/ \/ !!!!! + !!!!! !!!!! + !!!!! ============================================================================================ !!!!! + + !% Initialise parameters to run CP2K: basis set; potential; DFT parameters; cell; global settings. + !% If these are empty, set some default. + ! + subroutine param_initialise(this,at,run_type,cp2k_program,basis_set_file,potential_file,& + dft_file,cell_file,global_file,use_cubic_cell) + + type(param_cp2k), intent(out) :: this + type(atoms), intent(inout) :: at + integer, intent(in) :: run_type + character(len=*), intent(in) :: cp2k_program + character(len=*), intent(in) :: basis_set_file, potential_file, dft_file, cell_file,global_file + logical, optional, intent(in) :: use_cubic_cell + + real(dp), dimension(3) :: QM_maxdist + type(Table) :: fitlist + character(len=20) :: dir + integer :: i,j + logical :: ex + logical :: cubic + character(len=800) :: env_program_name + integer :: name_len, status + real(dp),dimension(3) :: old_QM_cell + logical :: QM_list_changed + character(len=value_len) :: bs_pot_string + character(len=value_len) :: basis_set_file_val, potential_file_val + + call system_timer('param_init') + + if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & + call system_abort('param_initialise Run type is not recognized: '//run_type) + call print('Initializing parameters to run CP2K...') + cubic = optional_default(.false.,use_cubic_cell) + + if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + this%dft%mgrid_cutoff = 280.0_dp + if (run_type.eq.QS_RUN .and. any(at%Z(1:at%N).eq.17)) this%dft%mgrid_cutoff = 300._dp + this%dft%scf_guess = 'atomic' + this%dft%xc_functional = 'BLYP' !can be B3LYP,PBE0,BLYP,BP,PADE,PBE,TPSS,HTCH120,OLYP,NO_SHORTCUT,NONE + endif + if (any(run_type.eq.(/MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + this%mm_forcefield%parmtype = 'CHM' + this%mm_forcefield%parm_file_name = 'charmm.pot' + this%mm_forcefield%charge_OT = -0.834_dp + this%mm_forcefield%charge_HT = 0.417_dp + endif + this%mm_ewald%ewald_type = 'ewald' + this%mm_ewald%ewald_alpha = 0.35_dp + this%mm_ewald%ewald_gmax = int(max(at%lattice(1,1),at%lattice(2,2),at%lattice(3,3))/2._dp)*2+1 + + if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + ! let's have 3 Angstroms on any side of the cell + call print('INFO: The size of the QM cell is either the MM cell itself, or it will have at least 3-3 Angstrom around the QM atoms.') + call print('WARNING! Please check if your cell is centered around the QM region!',verbosity=PRINT_SILENT) + call print('WARNING! CP2K centering algorithm fails if QM atoms are not all in the',verbosity=PRINT_SILENT) + call print('WARNING! 0,0,0 cell. If you have checked it, please ignore this message.',verbosity=PRINT_SILENT) + this%qmmm%qmmm_cell = 0._dp + call get_qm_list_int_rec(at,run_type,fitlist, do_recursive=.true.) ! with QM_flag 1 or 2 + if (any(at%Z(int_part(fitlist,1)).gt.8)) this%dft%mgrid_cutoff = 300._dp + +! whole numbers => to use wavefunction extrapolation later + QM_maxdist = 0._dp + QM_maxdist(1) = maxval(at%pos(1,fitlist%int(1,1:fitlist%N))) - minval(at%pos(1,fitlist%int(1,1:fitlist%N))) + QM_maxdist(2) = maxval(at%pos(2,fitlist%int(1,1:fitlist%N))) - minval(at%pos(2,fitlist%int(1,1:fitlist%N))) + QM_maxdist(3) = maxval(at%pos(3,fitlist%int(1,1:fitlist%N))) - minval(at%pos(3,fitlist%int(1,1:fitlist%N))) +! do i=1,fitlist%N +! do j=i+1,fitlist%N +! QM_maxdist(1) = max(QM_maxdist(1),distance_min_image(at,(/at%pos(1,i),0._dp,0._dp/),(/at%pos(1,j),0._dp,0._dp/))) +! QM_maxdist(2) = max(QM_maxdist(2),distance_min_image(at,(/0._dp,at%pos(2,i),0._dp/),(/0._dp,at%pos(2,j),0._dp/))) +! QM_maxdist(3) = max(QM_maxdist(3),distance_min_image(at,(/0._dp,0._dp,at%pos(3,i)/),(/0._dp,0._dp,at%pos(3,j)/))) +!! call print('QM_maxdist: '//round(QM_maxdist(1),3)//' '//round(QM_maxdist(2),3)//' '//round(QM_maxdist(3),3)) +! enddo +! enddo + + if (cubic) then + QM_maxdist(1) = maxval(QM_maxdist(1:3)) + QM_maxdist(2) = QM_maxdist(1) + QM_maxdist(3) = QM_maxdist(1) + call print('cubic cell') + endif + + this%qmmm%qmmm_cell(1) = min(real(ceiling(QM_maxdist(1)))+6._dp,at%lattice(1,1)) + this%qmmm%qmmm_cell(2) = min(real(ceiling(QM_maxdist(2)))+6._dp,at%lattice(2,2)) + this%qmmm%qmmm_cell(3) = min(real(ceiling(QM_maxdist(3)))+6._dp,at%lattice(3,3)) + + call print('Lattice:') + call print(' A '//round(at%lattice(1,1),6)//' '//round(at%lattice(2,1),6)//' '//round(at%lattice(3,1),6)) + call print(' B '//round(at%lattice(1,2),6)//' '//round(at%lattice(2,2),6)//' '//round(at%lattice(3,2),6)) + call print(' C '//round(at%lattice(1,3),6)//' '//round(at%lattice(2,3),6)//' '//round(at%lattice(3,3),6)) + call print('QM cell:') + call print(' A '//round(this%qmmm%qmmm_cell(1),6)//' '//round(0._dp,6)//' '//round(0._dp,6)) + call print(' B '//round(0._dp,6)//' '//round(this%qmmm%qmmm_cell(2),6)//' '//round(0._dp,6)) + call print(' C '//round(0._dp,6)//' '//round(0._dp,6)//' '//round(this%qmmm%qmmm_cell(3),6)) + + ! save the QM cell size, if the same as last time, might reuse wavefunction + ex = .false. + this%qmmm%reuse_wfn = .false. + ex = get_value(at%params,'QM_cell',old_QM_cell) + if (ex) then + if (old_QM_cell(1:3) .feq. this%qmmm%qmmm_cell(1:3)) then + this%qmmm%reuse_wfn = .true. + if (Run_Type.eq.QMMM_RUN_CORE) call print('QM cell size have not changed. Reuse previous wavefunction.') + call print('QM_cell size has not changed in at%params, will reuse wfn'//old_QM_cell(1:3)//this%qmmm%qmmm_cell(1:3)//' if QM list has not changed', PRINT_VERBOSE) + else + this%qmmm%reuse_wfn = .false. + call print('QM_cell size changed in at%params, will not reuse wfn'//old_QM_cell(1:3)//this%qmmm%qmmm_cell(1:3), PRINT_VERBOSE) + call set_value(at%params,'QM_cell',this%qmmm%qmmm_cell(1:3)) + endif + else !for the first step there is no QM_cell, no wavefunction + this%qmmm%reuse_wfn = .false. + call print('did not find QM_cell property in at%params, will not reuse wfn', PRINT_VERBOSE) + call set_value(at%params,'QM_cell',this%qmmm%qmmm_cell(1:3)) + call print('set_value QM_cell :'//this%qmmm%qmmm_cell(1:3)) + endif + ! only in case of extended run also QM buffer zone change counts + if (Run_Type.eq.QMMM_RUN_EXTENDED) then + ex = .false. + ex = get_value(at%params,'QM_list_changed',QM_list_changed) + if (ex) then + this%qmmm%reuse_wfn = this%qmmm%reuse_wfn .and. (.not.QM_list_changed) + if (QM_list_changed) then + call print('QM list changed, will not use wfn', PRINT_VERBOSE) + else + call print('QM list has not changed, will use wfn if QM cell is the same', PRINT_VERBOSE) + endif + else + this%qmmm%reuse_wfn = .false. + call print('could not find QM_list_changed in the atoms object. reuse_wfn? '//this%qmmm%reuse_wfn) + endif + if (this%qmmm%reuse_wfn) then + this%dft%scf_guess = 'RESTART' + call print('QM list and QM cell size have not changed. Reuse previous wavefunction.') + endif + endif + +! call print('QM coordinates:') +! do i=1,fitlist%N +! call print('QM ATOM '//round(at%pos(1,fitlist%int(1,i)),6)//' '//round(at%pos(2,fitlist%int(1,i)),6)//' '//round(at%pos(3,fitlist%int(1,i)),6)) +! enddo + + this%qmmm%qmmm_cell_unit = 'ANGSTROM' + this%qmmm%ecoupl = 'GAUSS' +! ONLY 0.44, 0.78 & 0.80 values can be used at the moment! + this%qmmm%radius_H = 0.44_dp + this%qmmm%radius_O = 0.78_dp + this%qmmm%radius_C = 0.80_dp !0.77_dp + this%qmmm%radius_N = 0.80_dp !0.75_dp + this%qmmm%radius_S = 0.80_dp !0.75_dp + this%qmmm%radius_Cl = 0.80_dp !0.75_dp + this%qmmm%radius_Na = 0.80_dp !0.75_dp + endif + + if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + + ! read basis_set/potentials from file + call initialise(this%basis_set) + basis_set_file_val = basis_set_file + if (len(trim(basis_set_file_val)) == 0) then ! if no file was passed in calc_str, try to get it from config header + if (get_value(at%params,'BASIS_SET_list',basis_set_file_val)) then ! if file was defined in config header, set filename + call print("Using basis_set_file from BASIS_SET_list property of config") + endif + endif + if (len(trim(basis_set_file_val)) /= 0) then ! if a filename has been defined anywhere + call print("Reading basis set from '"//trim(basis_set_file_val)//"'") + call read_list_file(this,basis_set_file_val,basis_set=.true.) + endif + + this%dft%file = trim(dft_file) + + call initialise(this%potential) + potential_file_val = potential_file + if (len(trim(potential_file_val)) == 0) then ! if no file was passed in calc_str, try to get it from config header + if (get_value(at%params,'POTENTIAL_list',potential_file_val)) then ! if file was defined in config header, set filename + call print("Using potential_file from POTENTIAL_list property of config") + endif + endif + if (len(trim(potential_file_val)) /= 0) then ! if a filename has been defined anywhere + call print("Reading potential from '"//trim(potential_file_val)//"'") + call read_list_file(this,potential_file_val,potential=.true.) + endif + +! add default basis sets and potentials: + if (.not.get_value(this%basis_set,'H',bs_pot_string).and.find_in_array(at%Z(1:at%N),1).gt.0) then + call print('Added default basis set for H: DZVP-GTH-BLYP') + call set_value(this%basis_set,'H','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'H',bs_pot_string).and.find_in_array(at%Z(1:at%N),1).gt.0) then + call print('Added default potential for H: GTH-BLYP-q1') + call set_value(this%potential,'H','GTH-BLYP-q1') + endif + if (.not.get_value(this%basis_set,'O',bs_pot_string).and.find_in_array(at%Z(1:at%N),8).gt.0) then + call print('Added default basis set for O: DZVP-GTH-BLYP') + call set_value(this%basis_set,'O','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'O',bs_pot_string).and.find_in_array(at%Z(1:at%N),8).gt.0) then + call print('Added default potential for O: GTH-BLYP-q6') + call set_value(this%potential,'O','GTH-BLYP-q6') + endif + if (.not.get_value(this%basis_set,'C',bs_pot_string).and.find_in_array(at%Z(1:at%N),6).gt.0) then + call print('Added default basis set for C: DZVP-GTH-BLYP') + call set_value(this%basis_set,'C','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'C',bs_pot_string).and.find_in_array(at%Z(1:at%N),6).gt.0) then + call print('Added default potential for C: GTH-BLYP-q4') + call set_value(this%potential,'C','GTH-BLYP-q4') + endif + if (.not.get_value(this%basis_set,'N',bs_pot_string).and.find_in_array(at%Z(1:at%N),7).gt.0) then + call print('Added default basis set for N: DZVP-GTH-BLYP') + call set_value(this%basis_set,'N','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'N',bs_pot_string).and.find_in_array(at%Z(1:at%N),7).gt.0) then + call print('Added default potential for N: GTH-BLYP-q5') + call set_value(this%potential,'N','GTH-BLYP-q5') + endif + if (.not.get_value(this%basis_set,'S',bs_pot_string).and.find_in_array(at%Z(1:at%N),16).gt.0) then + call print('Added default basis set for S: DZVP-GTH-BLYP') + call set_value(this%basis_set,'S','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'S',bs_pot_string).and.find_in_array(at%Z(1:at%N),16).gt.0) then + call print('Added default potential for S: GTH-BLYP-q6') + call set_value(this%potential,'S','GTH-BLYP-q6') + endif + if (.not.get_value(this%basis_set,'Cl',bs_pot_string).and.find_in_array(at%Z(1:at%N),17).gt.0) then + call print('Added default basis set for Cl: DZVP-GTH-BLYP') + call set_value(this%basis_set,'Cl','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'Cl',bs_pot_string).and.find_in_array(at%Z(1:at%N),17).gt.0) then + call print('Added default potential for Cl: GTH-BLYP-q7') + call set_value(this%potential,'Cl','GTH-BLYP-q7') + endif + if (.not.get_value(this%basis_set,'F',bs_pot_string).and.find_in_array(at%Z(1:at%N),9).gt.0) then + call print('Added default basis set for F: DZVP-GTH-BLYP') + call set_value(this%basis_set,'F','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'F',bs_pot_string).and.find_in_array(at%Z(1:at%N),9).gt.0) then + call print('Added default potential for F: GTH-BLYP-q7') + call set_value(this%potential,'F','GTH-BLYP-q7') + endif + if (.not.get_value(this%basis_set,'Na',bs_pot_string).and.find_in_array(at%Z(1:at%N),11).gt.0) then + call print('Added default basis set for Na: DZVP-GTH-BLYP') + call set_value(this%basis_set,'Na','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'Na',bs_pot_string).and.find_in_array(at%Z(1:at%N),11).gt.0) then + call print('Added default potential for Na: GTH-BLYP-q1') + call set_value(this%potential,'Na','GTH-BLYP-q1') + endif + if (.not.get_value(this%basis_set,'Fe',bs_pot_string).and.find_in_array(at%Z(1:at%N),26).gt.0) then + call print('Added default basis set for Fe: DZVP-GTH-BLYP') + call set_value(this%basis_set,'Fe','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'Fe',bs_pot_string).and.find_in_array(at%Z(1:at%N),26).gt.0) then + call print('Added default potential for Fe: GTH-BLYP-q16') + call set_value(this%potential,'Fe','GTH-BLYP-q16') + endif + if (.not.get_value(this%basis_set,'Si',bs_pot_string).and.find_in_array(at%Z(1:at%N),14).gt.0) then + call print('Added default basis set for Si: DZVP-GTH-BLYP') + call set_value(this%basis_set,'Si','DZVP-GTH-BLYP') + endif + if (.not.get_value(this%potential,'Si',bs_pot_string).and.find_in_array(at%Z(1:at%N),14).gt.0) then + call print('Added default potential for Si: GTH-BLYP-q4') + call set_value(this%potential,'Si','GTH-BLYP-q4') + endif + endif + + this%global%project = 'cp2k' + this%global%runtype = 'MD' + this%global%cell_file = trim(cell_file) + this%global%global_file = trim(global_file) + + this%md%ensemble = 'NVE' + this%md%steps = 0 + this%md%timestep = 0.5_dp + this%md%temperature = 300.0_dp + +! use numbers in ascending order +! this%wenv%working_directory = 'cp2k_run_'//ran_string(8) !directory for temporary files used by cp2k + ex = .true. + i=1 + do while (ex) + dir = "cp2k_run_"//i + inquire(file=(trim(dir)//'/cp2k_input.inp'),exist=ex) + i = i + 1 + enddo + +!added status optionally to system_command! + call system_command('mkdir '//trim(dir),status=status) + call print('system_command status: '//status) + if (status /= 0) then + call system_abort('Failed to mkdir '//trim(dir)) + endif + + call print('the working directory: '//trim(dir)) + this%wenv%working_directory = trim(dir) + this%wenv%pdb_file = 'pdb.CHARMM.pdb' + this%wenv%exyz_file = 'exyz.CHARMM.xyz' + this%wenv%psf_file = 'psf.CHARMM.psf' + this%wenv%wfn_file = 'wfn.restart.wfn' + this%wenv%cp2k_input_filename = 'cp2k_input.inp' + this%wenv%force_file = trim(this%global%project)//'-frc-1.xyz' + this%wenv%pos_file = trim(this%global%project)//'-pos-1.xyz' + this%wenv%wrk_filename = 'wrk.dat' + + this%N=at%N + + ! get program name from environment variable + call print('use cp2k_program passed in args_str: '//trim(cp2k_program)) + this%wenv%cp2k_program = trim(cp2k_program) + + call system_timer('param_init') + + end subroutine param_initialise + + !% Finalise CP2K parameter set + ! + subroutine param_finalise(this) + + type(param_cp2k), intent(out) :: this + + call finalise(this%basis_set) + call finalise(this%potential) + this%dft%file = '' + this%dft%mgrid_cutoff = 0._dp + this%dft%scf_guess = '' + this%dft%xc_functional = '' + this%mm_forcefield%parmtype = '' + this%mm_forcefield%parm_file_name = '' + this%mm_forcefield%charge_OT = 0._dp + this%mm_forcefield%charge_HT = 0._dp + this%mm_ewald%ewald_type = '' + this%mm_ewald%ewald_alpha = 0._dp + this%mm_ewald%ewald_gmax = 0 + this%qmmm%qmmm_cell = 0._dp + this%qmmm%qmmm_cell_unit = '' + this%qmmm%reuse_wfn = .false. + this%qmmm%ecoupl = '' + this%qmmm%radius_H = 0._dp + this%qmmm%radius_O = 0._dp + this%qmmm%radius_C = 0._dp + this%qmmm%radius_N = 0._dp + this%qmmm%radius_S = 0._dp + this%qmmm%radius_Cl = 0._dp + this%qmmm%radius_Na = 0._dp + this%qmmm%radius_Si = 0._dp + this%global%cell_file = '' + this%global%global_file = '' + this%global%project = '' + this%global%runtype = '' + this%md%ensemble = '' + this%md%steps = 0 + this%md%timestep = 0._dp + this%md%temperature = 0._dp + this%wenv%working_directory = '' + this%wenv%pdb_file = '' + this%wenv%exyz_file = '' + this%wenv%psf_file = '' + this%wenv%wfn_file = '' + this%wenv%cp2k_input_filename = '' + this%wenv%force_file = '' + this%wenv%pos_file = '' + this%wenv%wrk_filename = '' + this%wenv%cp2k_program = '' + this%N = 0 + + this%initialised = .false. + + end subroutine param_finalise + + !%Prints the quantum region mark with the cluster_mark property (/=0). + !%If file is given, into file, otherwise to the standard io. + ! + subroutine print_qm_region(at, file) + type(Atoms), intent(inout) :: at + type(Inoutput), optional :: file + + integer, pointer :: qm_flag(:) + + if (.not.(assign_pointer(at, "cluster_mark", qm_flag))) & + call system_abort("print_qm_region couldn't find cluster_mark property") + + if (present(file)) then + file%prefix="QM_REGION" + call print_xyz(at, file, mask=(qm_flag /= 0)) + file%prefix="" + else + mainlog%prefix="QM_REGION" + call print_xyz(at, mainlog, mask=(qm_flag /= 0)) + mainlog%prefix="" + end if + end subroutine print_qm_region + + !% Subroutine to read the BASIS_SET and the POTENTIAL from external files. + !% Used by param_initialise. + ! + !% The format is (e.g. for H and O): + !% 2 !number of lines + !% 1 DZVP-GTH-BLYP !atomic number and basis set + !% 8 DZVP-GTH-BLYP !atomic number and basis set + ! + subroutine read_list_file(this,filename,basis_set,potential) + + type(param_cp2k), intent(inout) :: this + character(len=*), intent(in) :: filename + logical, optional, intent(in) :: basis_set,potential + + type(InOutput) :: listfile + integer :: num_list, n, Z + character(80), dimension(2) :: fields + character(len=80) :: bs_pot + integer :: num_fields + logical :: do_basis_set + integer :: status + + if (present(basis_set).and.present(potential)) then + if (basis_set.eqv.potential) call system_abort('read_list_file: exactly one of basis_set and potential should be true') + endif + if (present(basis_set)) do_basis_set = basis_set + if (present(potential)) do_basis_set = .not.potential + + call initialise(listfile,filename=trim(filename),action=INPUT) + + call parse_line(listfile,' ',fields,num_fields,status) + if (status > 0) then + call system_abort('read_list_file: Error reading from '//listfile%filename) + else if (status < 0) then + call system_abort('read_list_file: End of file when reading from '//listfile%filename) + end if + + num_list = string_to_int(fields(1)) + if (num_list.le.0) call system_abort('read_list_file: number of basis/potential should be >0:'//num_list) +! if (do_basis_set) then +! call initialise(this%basis_set) +! call allocate(this%basis_set,1,0,1,0,num_list) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries +! else +! call initialise(this%potential) +! call allocate(this%basis_set,1,0,1,0,num_list) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries +! endif + + ! Reading and storing list... + do n=1,num_list + call parse_line(listfile,' ',fields,num_fields,status) + if (status.ne.0) call system_abort('wrong file '//listfile%filename) + if (num_fields.lt.2) call system_abort('wrong file format '//listfile%filename) + Z = string_to_int(fields(1)) + bs_pot = fields(2) +! if (len(trim(bs_pot)).gt.TABLE_STRING_LENGTH) call system_abort('too long (>10) name: '//trim(bs_pot)) + if (do_basis_set) then + call print('Use for '//ElementName(Z)//' basis set: '//trim(bs_pot)) + call set_value(this%basis_set,ElementName(Z),bs_pot) +! call append(this%basis_set,(/Z/)) +! call append(this%basis_set,bs_pot) + else + call print('Use for '//ElementName(Z)//' potential: '//trim(bs_pot)) + call set_value(this%potential,ElementName(Z),bs_pot) +! call append(this%potential,(/Z/)) +! call append(this%potential,bs_pot) + endif + enddo + + call finalise(listfile) + + end subroutine read_list_file + + + !!!!! ============================================================================================ !!!!! + !!!!! !!!!! + !!!!! \/ \/ \/ \/ \/ \/ ------------ main subroutine to run CP2K ------------ \/ \/ \/ \/ \/ \/ !!!!! + !!!!! !!!!! + !!!!! ============================================================================================ !!!!! + + !% Main subroutine to run CP2K. The input parameters (program name, basis set, potential, + !% run type, whether to print a PSF file, dft parameters, cell size) are read from args_str. + !% Optionally outputs the forces and/or the energy. + !% Optionally reads the intrares_impropers that will be used to print a PSF file. + ! + subroutine go_cp2k(my_atoms,forces,energy,args_str,intrares_impropers) + + type(Atoms), intent(inout) :: my_atoms + real(dp), dimension(:,:), optional, intent(out) :: forces + real(dp), optional, intent(out) :: energy + character(len=*), optional, intent(in) :: args_str + type(Table), optional, intent(in) :: intrares_impropers + + type(param_cp2k) :: param + type(Table) :: qmlist + real(dp), allocatable, dimension(:,:) :: CP2K_forces + real(dp) :: CP2K_energy + + type(Dictionary) :: params + integer :: run_type + integer :: PSF_print + character(len=STRING_LENGTH) :: cp2k_program + character(len=STRING_LENGTH) :: run_type_str, psf_print_str + character(len=STRING_LENGTH) :: fileroot_str + character(len=STRING_LENGTH) :: basis_set_file, potential_file, dft_file, cell_file,global_file + + character(len=STRING_LENGTH) :: run_command='', & + fin_command='' + logical :: clean_up_files, save_output_files + integer :: status, error_status + logical :: ex + integer :: n_tries, max_n_tries + real(dp) :: max_force_warning + logical :: converged + logical :: have_silica_potential + + call system_timer('go_cp2k_start') + call print_title('Setting up the CP2K run') + + if (.not.present(energy).and..not.present(forces)) call system_abort('go_cp2k: nothing to be calculated. Neither energy, nor forces.') + + ! Read and print run parameters + fileroot_str='' + basis_set_file='' + potential_file='' + dft_file='' + cell_file='' + global_file='' + call initialise(params) + call param_register(params, 'Run_Type', 'MM', run_type_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'PSF_Print', 'NO_PSF', psf_print_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'cp2k_program','cp2k.sopt', cp2k_program, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'root', '', fileroot_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'basis_set_file', '', basis_set_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'potential_file', '', potential_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'dft_file', '', dft_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'cell_file', '', cell_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'global_file', '', global_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'clean_up_files', 'T', clean_up_files, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'save_output_files', 'T', save_output_files, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'max_n_tries', '2', max_n_tries, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'max_force_warning', '2.0', max_force_warning, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'have_silica_potential', 'F', have_silica_potential, help_string="No help yet. This source file was $LastChangedBy$") + + if (present(args_str)) then + if (.not. param_read_line(params, args_str, ignore_unknown=.true., task='go_cp2k args_str')) & + call system_abort("Potential_Initialise_str failed to parse args_str='"//trim(args_str)//"'") + else + call system_abort("Potential_Initialise_str failed to parse args_str, no args_str") + endif + call finalise(params) + + if (len_trim(fileroot_str) > 0) then + if (len_trim(basis_set_file) == 0) basis_set_file=trim(fileroot_str)//'.basis_set' + if (len_trim(potential_file) == 0) potential_file=trim(fileroot_str)//'.potential' + if (len_trim(dft_file) == 0) dft_file=trim(fileroot_str)//'.dft' + if (len_trim(cell_file) == 0) cell_file=trim(fileroot_str)//'.cell' + if (len_trim(global_file) == 0) global_file=trim(fileroot_str)//'.global' + end if + + select case(trim(psf_print_str)) + case('CP2K_PRINT_AND_SAVE') + PSF_print = CP2K_PRINT_AND_SAVE + case('NO_PSF') + PSF_print = NO_PSF + case('DRIVER_PRINT_AND_SAVE') + PSF_print = DRIVER_PRINT_AND_SAVE + case('USE_EXISTING_PSF') + PSF_print = USE_EXISTING_PSF + case default + call system_abort("go_cp2k got psf_print_str='"//trim(psf_print_str)//"'" // & + ", only know about NO_PSF, CP2K_PRINT_AND_SAVE, DRIVER_PRINT_AND_SAVE, USE_EXISTING_PSF") + end select + + select case(trim(run_type_str)) + case('MM') + run_type = MM_RUN + case('QS') + run_type = QS_RUN + case('QMMM_CORE') + run_type = QMMM_RUN_CORE + case('QMMM_EXTENDED') + run_type = QMMM_RUN_EXTENDED + case default + call system_abort("go_cp2k got run_type_str='"//trim(run_type_str)//"'" // & + ", only know about MM, QS, QMMM_CORE, QMMM_EXTENDED") + end select + + if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & + call system_abort('go_cp2k: Run type is not recognized: '//run_type) + if (.not.any(PSF_print.eq.(/NO_PSF,CP2K_PRINT_AND_SAVE,DRIVER_PRINT_AND_SAVE,USE_EXISTING_PSF/))) & + call system_abort('go_cp2k: PSF print is not recognized: '//PSF_print) + + call print ('Run parameters: ') + if (run_type.eq.QS_RUN) call print ('Run type: QS') + if (run_type.eq.MM_RUN) call print ('Run type: MM') + if (run_type.eq.QMMM_RUN_CORE) call print ('Run type: QM/MM run, QM: quantum core') + if (run_type.eq.QMMM_RUN_EXTENDED) call print ('Run type: QM/MM run, QM: extended quantum region') + if (PSF_Print.eq.NO_PSF) call print ('PSF printing: No PSF') + if (PSF_Print.eq.CP2K_PRINT_AND_SAVE) call print ('PSF printing: CP2K prints PSF') + if (PSF_Print.eq.DRIVER_PRINT_AND_SAVE) call print ('PSF printing: driver prints PSF') + if (PSF_Print.eq.USE_EXISTING_PSF) call print ('PSF printing: Use existing PSF') + + ! If QM/MM, get QM list + if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + call get_qm_list_int_rec(my_atoms,run_type,qmlist, do_recursive=.true.) + !check if all the atoms are QM, QS used instead + if (qmlist%N.eq.my_atoms%N) then + call print('WARNING: go_cp2k: QM/MM calculation was requested, but all the atoms are within the quantum zone: fully QS will be run!',verbosity=PRINT_ALWAYS) + run_type = QS_RUN + call print ('Run type: QS') + endif + endif + + ! set params, CHARMM formats and create working directory + call param_initialise(param,my_atoms,run_type,cp2k_program,basis_set_file,potential_file,dft_file,cell_file,global_file) + + ! check CHARMM topology + ! Write the coordinate file and the QM/MM or MM input file + call write_cp2k_input_files(my_atoms,qmlist,param=param,run_type=run_type,PSF_print=PSF_print,intrares_impropers=intrares_impropers,have_silica_potential=have_silica_potential) + + ! Run cp2k MM serial or QM/MM parallel + call print('Running CP2K...') + + n_tries = 0 + converged = .false. + do while (.not. converged .and. (n_tries < max_n_tries)) + n_tries = n_tries + 1 + run_command = 'cd '//trim(param%wenv%working_directory)//';'//trim(param%wenv%cp2k_program)//' '//trim(param%wenv%cp2k_input_filename)//' >> cp2k_output.out' + + call print(run_command) + !added status optionally to system_command. + call system_timer('go_cp2k_start') + call system_timer('system_command(run_command)') + call system_command(run_command,status=status) + call system_timer('system_command(run_command)') + call system_timer('go_cp2k_end') + call print_title('...CP2K...') + call print('grep -i warning '//trim(param%wenv%working_directory)//'/cp2k_output.out') + call system_command('grep -i warning '//trim(param%wenv%working_directory)//'/cp2k_output.out') + call system_command('grep -i error '//trim(param%wenv%working_directory)//'/cp2k_output.out', error_status) + if (status /= 0) call system_abort('CP2K had non-zero return status. See output file '//trim(param%wenv%working_directory)//'/cp2k_output.out') + if (error_status == 0) call system_abort('CP2K had ERROR in output. See output file '//trim(param%wenv%working_directory)//'/cp2k_output.out') + + call system_command('egrep "FORCE_EVAL.* QS " '//trim(param%wenv%working_directory)//'/cp2k_output.out',status=status) + if (status == 0) then ! QS or QMMM run + call system_command('grep "FAILED to converge" '//trim(param%wenv%working_directory)//'/cp2k_output.out',status=status) + if (status == 0) then + call print("WARNING: cp2k_driver failed to converge, trying again",PRINT_ALWAYS) + converged = .false. + else + call system_command('grep "SCF run converged" '//trim(param%wenv%working_directory)//'/cp2k_output.out',status=status) + if (status == 0) then + converged = .true. + else + call print("WARNING: cp2k_driver couldn't find definitive sign of convergence or failure to converge in output file, trying again",PRINT_ALWAYS) + converged = .false. + endif + end if + else ! MM run + converged = .true. + endif + + ! Save Wfn if needed + if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + ! inquire(file=trim(param%wenv%working_directory)//'/'//trim(param%global%project)//'-RESTART.wfn',exist=ex) + ! if (ex) & + call system_command('cp '//trim(param%wenv%working_directory)//'/'//trim(param%global%project)//'-RESTART.wfn '//trim(param%wenv%wfn_file)) + endif + + end do + if (.not. converged) call system_abort('CP2K failed to converge after n_tries='//n_tries//'. See output file '//trim(param%wenv%working_directory)//'/cp2k_output.out') + + ! Read energy and forces - also re-reordering! +! call print('file='//trim(param%wenv%working_directory)//'/'//trim(param%wenv%force_file)//',exist=ex') +! inquire(file=trim(param%wenv%working_directory)//'/'//trim(param%wenv%force_file),exist=ex) +! if (ex) call system_abort('CP2K aborted before printing forces. Check the output file '//trim(param%wenv%working_directory)//'/cp2k_output.out') + call read_cp2k_forces(CP2K_forces,CP2K_energy,param,my_atoms,run_type=run_type) + if (maxval(abs(CP2K_forces)) > max_force_warning) then + call print("WARNING: CP2K_forces maximum component " // maxval(abs(CP2K_forces)) // " at " // maxloc(abs(CP2K_forces)) // & + " exceeds max_force_warning="//max_force_warning, PRINT_ALWAYS) + endif + + if (present(energy)) energy = CP2K_energy + if (present(forces)) forces = CP2K_forces + + ! Save PSF if needed + if (PSF_print.eq.CP2K_PRINT_AND_SAVE) then +! inquire(file=trim(param%wenv%working_directory)//'/'//trim(param%global%project)//'-dump-1.psf',exist=ex) +! if (ex) & + call system_command('cp '//trim(param%wenv%working_directory)//'/'//trim(param%global%project)//'-dump-1.psf '//trim(param%wenv%psf_file)) + endif + + if (save_output_files) then + call system_command('cat '//trim(param%wenv%working_directory)//'/'//trim(param%wenv%cp2k_input_filename)// & + ' >> cp2k_input_log; echo "##############" >> cp2k_input_log;' // & + ' cat '//trim(param%wenv%working_directory)//'/'//trim(param%wenv%force_file)// & + ' >> cp2k_force_file_log; echo "##############" >> cp2k_force_file_log;' // & + ' cat '//trim(param%wenv%working_directory)//'/cp2k_output.out >> cp2k_output_log; echo "##############" >> cp2k_output_log') + endif + + ! remove all unnecessary files + if (clean_up_files) & + call system_command('rm -rf '//trim(param%wenv%working_directory),status=status) + + call finalise(param) + + call print('CP2K finished. Go back to main program.') + call system_timer('go_cp2k_end') + + end subroutine go_cp2k + + !!!!! ============================================================================================ !!!!! + !!!!! !!!!! + !!!!! \/ \/ \/ \/ \/ \/ ----------------- QM list operations ----------------- \/ \/ \/ \/ \/ \/ !!!!! + !!!!! !!!!! + !!!!! ============================================================================================ !!!!! + + !% Returns a $qmlist$ table with the atom indices whose $cluster_mark$ + !% (or optionally any $int_property$) property takes exactly $qmflag$ value. + ! + subroutine get_qm_list_int(my_atoms,qmflag,qmlist,int_property) + + type(Atoms), intent(in) :: my_atoms + integer, intent(in) :: qmflag + type(Table), intent(out) :: qmlist + character(len=*), optional, intent(in) :: int_property + + integer :: i + integer :: qm_flag_index + +! qm_flag_index = get_property(my_atoms,'QM_flag') + if (present(int_property)) then + qm_flag_index = get_property(my_atoms,int_property) + else + qm_flag_index = get_property(my_atoms,'cluster_mark') + endif + + call initialise(qmlist,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries + do i=1,my_atoms%N + if (my_atoms%data%int(qm_flag_index,i).eq.qmflag) & + call append(qmlist,(/i,0,0,0/)) + enddo + + if (qmlist%N.eq.0) call print('Empty QM list with cluster_mark '//qmflag,verbosity=PRINT_SILENT) + + end subroutine get_qm_list_int + + !% Returns a $qmlist$ table with the atom indices whose $cluster_mark$ + !% (or optionally any $int_property$) property takes no greater than $qmflag$ positive value. + ! + subroutine get_qm_list_int_rec(my_atoms,qmflag,qmlist,do_recursive,int_property) + + type(Atoms), intent(in) :: my_atoms + integer, intent(in) :: qmflag + type(Table), intent(out) :: qmlist + logical, intent(in) :: do_recursive + character(len=*), optional, intent(in) :: int_property + + integer :: i + integer :: qm_flag_index + logical :: my_do_recursive + +! my_do_recursive = optional_default(.true.,do_recursive) +! qm_flag_index = get_property(my_atoms,'QM_flag') + if (present(int_property)) then + qm_flag_index = get_property(my_atoms,int_property) + else + qm_flag_index = get_property(my_atoms,'cluster_mark') + endif + + call initialise(qmlist,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries +! if (my_do_recursive) then + if (do_recursive) then + do i=1,my_atoms%N + if (my_atoms%data%int(qm_flag_index,i).gt.0.and. & + my_atoms%data%int(qm_flag_index,i).le.qmflag) & + call append(qmlist,(/i,0,0,0/)) + enddo + else + do i=1,my_atoms%N + if (my_atoms%data%int(qm_flag_index,i).eq.qmflag) & + call append(qmlist,(/i,0,0,0/)) + enddo + endif + + if (qmlist%N.eq.0) call print('Empty QM list with cluster_mark '//qmflag,verbosity=PRINT_SILENT) + + end subroutine get_qm_list_int_rec + + !% Returns a $qmlist$ table with the atom indices whose $cluster_mark$ + !% (or optionally any $int_property$) property takes any value from the $qmflag$ array. + ! + subroutine get_qm_list_array(my_atoms,qmflags,qmlist,int_property) + + type(Atoms), intent(in) :: my_atoms + integer, intent(in) :: qmflags(:) + type(Table), intent(out) :: qmlist + character(len=*), optional, intent(in) :: int_property + + integer :: i + integer :: qm_flag_index + +! qm_flag_index = get_property(my_atoms,'QM_flag') + if (present(int_property)) then + qm_flag_index = get_property(my_atoms,int_property) + else + qm_flag_index = get_property(my_atoms,'cluster_mark') + endif + + call initialise(qmlist,4,0,0,0,0) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries + do i=1,my_atoms%N + if (any(my_atoms%data%int(qm_flag_index,i).eq.qmflags(1:size(qmflags)))) & + call append(qmlist,(/i,0,0,0/)) + enddo + + if (qmlist%N.eq.0) call print('Empty QM list with cluster_mark '//qmflags(1:size(qmflags)),verbosity=PRINT_SILENT) + + end subroutine get_qm_list_array + + !% Returns the index of the first column of a property $prop$. + !% Aborts if the property cannot be found in the atoms object. + ! + function get_property(my_atoms,prop) result(prop_index) + + type(Atoms), intent(in) :: my_atoms + character(len=*), intent(in) :: prop + + integer,dimension(3) :: pos_indices + integer :: prop_index + + if (get_value(my_atoms%properties,trim(prop),pos_indices)) then + prop_index = pos_indices(2) + else + call system_abort('get_property: No '//trim(prop)//' property assigned to the Atoms object!') + end if + + end function get_property + + + !!!!! ============================================================================================ !!!!! + !!!!! !!!!! + !!!!! \/ \/ \/ \/ \/ \/ ---------- reading in the QM list from file ---------- \/ \/ \/ \/ \/ \/ !!!!! + !!!!! !!!!! + !!!!! ============================================================================================ !!!!! + + !% Reads the QM list from a file and saves it in $QM_flag$ integer property, + !% marking the QM atoms with 1, otherwise 0. + ! + subroutine read_qmlist(my_atoms,qmlistfilename,PRINT_verbose) + + type(Atoms), intent(inout) :: my_atoms + character(*), intent(in) :: qmlistfilename + logical, optional, intent(in) :: verbose + + type(table) :: qm_list + type(Inoutput) :: qmlistfile + integer :: n,num_qm_atoms,qmatom,status + character(80) :: title,testline + logical :: my_verbose + integer :: qm_flag_index + character(20), dimension(10) :: fields + integer :: num_fields + + + my_verbose = .false. + if (present(verbose)) my_verbose = PRINT_verbose + + if (my_verbose) call print('In Read_QM_list:') + call print('Reading the QM list from file '//trim(qmlistfilename)//'...') + + call initialise(qmlistfile,filename=trim(qmlistfilename),action=INPUT) + title = read_line(qmlistfile,status) + if (status > 0) then + call system_abort('read_qmlist: Error reading from '//qmlistfile%filename) + else if (status < 0) then + call system_abort('read_qmlist: End of file when reading from '//qmlistfile%filename) + end if + + call parse_line(qmlistfile,' ',fields,num_fields,status) + if (status > 0) then + call system_abort('read_qmlist: Error reading from '//qmlistfile%filename) + else if (status < 0) then + call system_abort('read_qmlist: End of file when reading from '//qmlistfile%filename) + end if + + num_qm_atoms = string_to_int(fields(1)) + if (num_qm_atoms.gt.my_atoms%N) call print('WARNING! read_qmlist: more QM atoms then atoms in the atoms object, possible redundant QM list file',verbosity=PRINT_ALWAYS) + call print('Number of QM atoms: '//num_qm_atoms) + call allocate(qm_list,4,0,0,0,num_qm_atoms) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries + + do while (status==0) + testline = read_line(qmlistfile,status) + !print *,testline + if (testline(1:4)=='list') exit + enddo + ! Reading and storing QM list... + do n=1,num_qm_atoms + call parse_line(qmlistfile,' ',fields,num_fields,status) + qmatom = string_to_int(fields(1)) + if (my_verbose) call print(n//'th quantum atom is: '//qmatom) + call append(qm_list,(/qmatom,0,0,0/)) + enddo + + call finalise(qmlistfile) + + if (qm_list%N/=num_qm_atoms) call system_abort('read_qmlist: Something wrong with the QM list file') + if (any(int_part(qm_list,1).gt.my_atoms%N).or.any(int_part(qm_list,1).lt.1)) & + call system_abort('read_qmlist: at least 1 QM atom is out of range') + if ((size(int_part(qm_list,1)).gt.my_atoms%N).or.(size(int_part(qm_list,1)).lt.1)) & + call system_abort("read_qmlist: QM atoms' number is <1 or >"//my_atoms%N) + + call add_property(my_atoms,'hybrid',0) + qm_flag_index = get_property(my_atoms,'hybrid') + my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 + my_atoms%data%int(qm_flag_index,int_part(qm_list,1)) = 1 +call print('Added '//count(my_atoms%data%int(qm_flag_index,1:my_atoms%N).eq.1)//' qm atoms.') + + call add_property(my_atoms,'hybrid_mark',0) + qm_flag_index = get_property(my_atoms,'hybrid_mark') + my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 + my_atoms%data%int(qm_flag_index,int_part(qm_list,1)) = 1 +call print('Added '//count(my_atoms%data%int(qm_flag_index,1:my_atoms%N).eq.1)//' qm atoms.') + + if (my_verbose) call print('Finished. '//qm_list%N//' QM atoms have been read successfully.') + call finalise(qm_list) + + end subroutine read_qmlist + + + !!!!! ============================================================================================ !!!!! + !!!!! !!!!! + !!!!! \/ \/ \/ \/ \/ \/ -------- create the CHARMM params to run CP2K -------- \/ \/ \/ \/ \/ \/ !!!!! + !!!!! !!!!! + !!!!! ============================================================================================ !!!!! + + !% Calculates number of bonds generated during connectivity generation. + !% Double checks if the connection table is symmetric. + ! + function num_of_bonds(at) result(bonds) + + type(atoms),intent(in) :: at + integer :: bonds + integer :: i,bonds2 + + bonds = 0 + bonds2 = 0 + + do i=1,at%N + if (associated(at%connect%neighbour1(i)%t)) bonds = bonds + at%connect%neighbour1(i)%t%N + if (associated(at%connect%neighbour2(i)%t)) bonds2 = bonds2 + at%connect%neighbour2(i)%t%N + enddo + + if (bonds.ne.bonds2) call system_abort('num_of_bonds: connectivities of atoms are not symmetric.') + + end function num_of_bonds + + !% Very simple routine to check the number of neighbours. + !% It prints the number of neighbours, unless it is 1 for H, or 2 for O. + !% May be useful for water, biomolecules only. + ! + subroutine check_neighbour_numbers(at) + + type(atoms),intent(in) :: at + integer :: i, n_neigh + + do i=1,at%N + + n_neigh = atoms_n_neighbours(at, i) + if ( (at%Z(i).eq.1) .AND. (n_neigh.ne.1) ) then +! do n=1,atoms_n_neighbours(at,i) +! j=atoms_neighbour(at,i,n) +! enddo + call print('Warning: '//ElementName(at%Z(i))//' atom '//i//' position '//round(at%pos(1,i),5)//' '//round(at%pos(2,i),5)//' '//round(at%pos(3,i),5)//' has unusual number of neighbours: '//(n_neigh)) + endif + if ( (at%Z(i).eq.8) .AND. (n_neigh.ne.2) ) & + call print('Warning: '//ElementName(at%Z(i))//' atom '//i//' position '//round(at%pos(1,i),5)//' '//round(at%pos(2,i),5)//' '//round(at%pos(3,i),5)//' has unusual number of neighbours: '//(n_neigh)) + + if ( .not.any(at%Z(i).eq.(/1,8/)) ) & + call print('Info: '//ElementName(at%Z(i))//' atom '//i//' position '//round(at%pos(1,i),5)//' '//round(at%pos(2,i),5)//' '//round(at%pos(3,i),5)//' has number of neighbours: '//(n_neigh)) + + enddo + + end subroutine check_neighbour_numbers + + !% Checks and reports the changes between two tables, $old_qmlist$ and $new_qmlist$. + ! + function check_list_change(old_list,new_list) result(list_changed) + + type(Table), intent(in) :: old_list, new_list + integer :: i + logical :: list_changed + + list_changed = .false. + if (old_list%N.ne.new_list%N) then + call print ('list has changed: new number of atoms is: '//new_list%N//', was: '//old_list%N) + list_changed = .true. + else + if (any(old_list%int(1,1:old_list%N).ne.new_list%int(1,1:new_list%N))) then + do i=1,old_list%N + if (.not.find_in_array(int_part(old_list,1),(new_list%int(1,i))).gt.0) then + call print('list has changed: atom '//new_list%int(1,i)//' has entered the region') + list_changed = .true. + endif + if (.not.find_in_array(int_part(new_list,1),(old_list%int(1,i))).gt.0) then + call print('list has changed: atom '//old_list%int(1,i)//' has left the region') + list_changed = .true. + endif + enddo + endif + endif + + end function check_list_change + + !!!!! ============================================================================================ !!!!! + !!!!! !!!!! + !!!!! \/ \/ \/ \/ \/ \/ ------------ input file printing for CP2K ------------ \/ \/ \/ \/ \/ \/ !!!!! + !!!!! !!!!! + !!!!! ============================================================================================ !!!!! + + !% Writes all the input files for CP2K: the actual input file, the coordinate file (PDB) + !% and the topology file (PSF). + !% If the intraresidual improper angles are given in $intrares_impropers$, + !% they will be included in the PSF file. This is needed for a meaningful + !% biochemical calculation. + ! + subroutine write_cp2k_input_files(my_atoms,qm_list,param,run_type,PSF_print,have_silica_potential,intrares_impropers) + + type(Atoms), intent(inout) :: my_atoms + type(Table), intent(in) :: qm_list + type(param_cp2k), intent(in) :: param + integer, intent(in) :: run_type, & + PSF_print + logical, optional, intent(in) :: have_silica_potential + type(Table), optional, intent(in) :: intrares_impropers + character(len=STRING_LENGTH) :: run_type_string +logical :: do_have_silica_potential +type(InOutput) :: exyz + + call system_timer('write_inputs') + + do_have_silica_potential = optional_default(.false.,have_silica_potential) + + if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & + call system_abort('write_cp2k_input_files: Run type is not recognized: '//run_type) + if (.not.any(PSF_print.eq.(/NO_PSF,CP2K_PRINT_AND_SAVE,DRIVER_PRINT_AND_SAVE,USE_EXISTING_PSF/))) & + call system_abort('write_cp2k_input_files: PSF print is not recognized: '//PSF_print) + + call print('Writing the CP2K input file(s)') + if (run_type.ne.QS_RUN) then + run_type_string = '' + if (run_type.eq.QMMM_RUN_EXTENDED) run_type_string = 'QMMM_EXTENDED' + if (run_type.eq.QMMM_RUN_CORE) run_type_string = 'QMMM_CORE' +!Print extended xyz instead of pdb format. +! call write_cp2k_pdb_file(my_atoms,trim(param%wenv%working_directory)//'/'//trim(param%wenv%pdb_file),run_type_string=run_type_string) + call initialise(exyz,trim(param%wenv%working_directory)//'/'//trim(param%wenv%exyz_file),action=OUTPUT) + call print_xyz(my_atoms,exyz,properties='species:pos:atom_type:atom_res_name:atom_mol_name:atom_res_number:atom_charge',real_format='f17.10') + call finalise(exyz) + if (PSF_print.eq.DRIVER_PRINT_AND_SAVE) then + if (present(intrares_impropers)) then + call write_psf_file(my_atoms,param%wenv%psf_file,run_type_string=trim(run_type_string),intrares_impropers=intrares_impropers,add_silica_23body=do_have_silica_potential) + else + call write_psf_file(my_atoms,param%wenv%psf_file,run_type_string=trim(run_type_string),add_silica_23body=do_have_silica_potential) + endif + endif + endif + call write_cp2k_input_file(my_atoms,qm_list,param,run_type,PSF_print,do_have_silica_potential) + call print ('Finished. Input files are ready for the run.') + if (PSF_print.eq.USE_EXISTING_PSF) call print('Use already existing PSF file '//param%wenv%psf_file) + + call system_timer('write_inputs') + + end subroutine write_cp2k_input_files + + !% Writes the CP2K input file. If cell, basis set, potential, global + !% and dft files are present in $param$, the CP2K parameter file, + !% use those to construct the input file, otherwise use some defaults. + ! + subroutine write_cp2k_input_file(my_atoms,qm_list,param,run_type,PSF_print,have_silica_potential) + + type(Atoms), intent(in) :: my_atoms + type(Table), intent(in) :: qm_list + type(param_cp2k), intent(in) :: param + integer, intent(in) :: run_type, & + PSF_print + logical, optional, intent(in) :: have_silica_potential + + type(Inoutput) :: input_file + integer,allocatable,dimension(:) :: list !in order to separate QM atom indices for H and O + integer :: i,j,counter + type(Table) :: qm_list_check + integer :: qm_flag_index, & + atom_type_index, & + atom_res_name_index, & + atom_charge_index + logical :: ex, lsd + integer :: charge + character(len=value_len) :: basis_set, potential + integer :: stat + type(inoutput) :: dft_in_io, cell_in_io, global_in_io + character(len=1024) :: line +type(Table) :: cut_bonds +integer, pointer :: cut_bonds_p(:,:) +integer :: i_inner, i_outer +logical :: do_have_silica_potential +integer :: ineigh,nneigh +type(Table) :: bond_constraints +logical :: constrain_all_HSI + + if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & + call system_abort('write_cp2k_input_file: Run type is not recognized: '//run_type) + + if (any(run_type.eq.(/MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + !qm_flag_index = get_property(my_atoms,'QM_flag') + qm_flag_index = get_property(my_atoms,'cluster_mark') + endif + atom_type_index = get_property(my_atoms,'atom_type') + atom_res_name_index = get_property(my_atoms,'atom_res_name') + atom_charge_index = get_property(my_atoms,'atom_charge') + endif + + if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + call get_qm_list_int_rec(my_atoms,run_type,qm_list_check, do_recursive=.true.) + if (qm_list_check%N.ne.qm_list%N) call system_abort ('qm_list is different from Atoms cluster_mark!!') + do i = 1, qm_list_check%N + if (.not.any(qm_list_check%int(1,i).eq.qm_list%int(1,1:qm_list%N))) call system_abort ('qm_list is different from Atoms cluster_mark!!') + enddo + do i = 1, qm_list%N + if (.not.any(qm_list%int(1,i).eq.qm_list_check%int(1,1:qm_list_check%N))) call system_abort ('qm_list is different from Atoms cluster_mark!!') + enddo + endif + + do_have_silica_potential = optional_default(.false.,have_silica_potential) + constrain_all_HSI = .false. + if (do_have_silica_potential) constrain_all_HSI = .true. + +! call print_title('Writing CP2K input file') + + call initialise(input_file,trim(param%wenv%working_directory)//'/'//trim(param%wenv%cp2k_input_filename),action=OUTPUT) + call print(' inp file: '//trim(input_file%filename)) + + ! input_file%default_real_precision=16 + + call print('&FORCE_EVAL',file=input_file) + if (run_type.eq.MM_RUN) then + call print(' METHOD Fist',file=input_file) + else + if (run_type.eq.QS_RUN) then + call print(' METHOD Quickstep',file=input_file) + else !QMMM_RUN_CORE or QMMM_RUN_EXTENDED + call print(' METHOD QMMM',file=input_file) + endif + endif + + if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + call print(' &DFT',file=input_file) + if (len(trim(param%dft%file)) > 0) then + call initialise(dft_in_io,trim(param%dft%file), INPUT) + stat = 0 + do while (stat == 0) + line = read_line(dft_in_io, stat) + if (stat == 0) call print(trim(line), file=input_file) + end do + call finalise(dft_in_io) + if (run_type.eq.QS_RUN) then + call print(' WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) + else + if (param%qmmm%reuse_wfn) then + call print(' WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) + else + call print('# WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) + endif + endif ! run_type == QS_RUN + if (run_type == QS_RUN) then + ! check if the system is charged, given Charge=... in the comment line + if (get_value(my_atoms%params,'Charge',charge)) then + call print(' CHARGE '//charge,file=input_file) + endif + lsd = .false. + if (get_value(my_atoms%params,'LSD',lsd)) then + if (lsd) call print(' LSD ',file=input_file) + endif + else + if (mod(nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))),2).ne.0) call print(' LSD',file=input_file) + if (nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))).ne.0) & + call print(' CHARGE '//nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))),file=input_file) + endif ! run_type == QS_RUN + else ! len(param%dft_file) > 0 + ! call print(' &PRINT',file=input_file) + ! call print(' &LOCALIZATION',file=input_file) + ! call print(' &LOCALIZE',file=input_file) + ! call print(' &END LOCALIZE',file=input_file) + ! call print(' &END LOCALIZATION',file=input_file) + ! call print(' &END PRINT',file=input_file) + + call print(' BASIS_SET_FILE_NAME ../BASIS_SET',file=input_file) + call print(' POTENTIAL_FILE_NAME ../POTENTIAL',file=input_file) + if (run_type.eq.QS_RUN) then + call print(' WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) + else + if (param%qmmm%reuse_wfn) then + call print(' WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) + else + call print('# WFN_RESTART_FILE_NAME ../'//trim(param%wenv%wfn_file),file=input_file) + endif + endif + call print(' &MGRID',file=input_file) + call print(' COMMENSURATE',file=input_file) + call print(' CUTOFF '//round(param%dft%mgrid_cutoff,1),file=input_file) !some cutoff !Ry + call print(' NGRIDS 5',file=input_file) + call print(' &END MGRID',file=input_file) + call print(' &QS',file=input_file) + call print(' EXTRAPOLATION PS',file=input_file) + call print(' EXTRAPOLATION_ORDER 1',file=input_file) + call print(' &END QS',file=input_file) + call print(' &SCF',file=input_file) + if (run_type.eq.QS_RUN) then + call print(' SCF_GUESS RESTART',file=input_file) + else + ! if (param%qmmm%wfn_reuse) then + ! call print(' SCF_GUESS RESTART',file=input_file) + ! else + call print(' SCF_GUESS '//trim(param%dft%scf_guess),file=input_file) + ! endif + endif + call print(' EPS_SCF 1.0E-6',file=input_file) + call print(' MAX_SCF 200',file=input_file) + call print(' &OUTER_SCF',file=input_file) + call print(' EPS_SCF 1.0E-6',file=input_file) + call print(' MAX_SCF 200',file=input_file) + call print(' &END',file=input_file) + call print(' &OT',file=input_file) + call print(' MINIMIZER CG',file=input_file) + call print(' PRECONDITIONER FULL_ALL',file=input_file) + ! call print('# PRECONDITIONER SPARSE_DIAG',file=input_file) + ! call print('# ENERGY_GAP 0.001',file=input_file) + call print(' &END OT',file=input_file) + call print(' &END SCF',file=input_file) + call print(' &XC',file=input_file) + call print(' &XC_FUNCTIONAL '//trim(param%dft%xc_functional),file=input_file) + call print(' &END XC_FUNCTIONAL',file=input_file) + call print(' &END XC',file=input_file) + ! in case of charged QM system use unrestricted KS and specify charge + if (run_type.eq.QS_RUN) then + call print(' &POISSON',file=input_file) + call print(' &EWALD',file=input_file) + call print(' EWALD_TYPE '//trim(param%mm_ewald%ewald_type),file=input_file) + call print(' EWALD_ACCURACY 1.E-6',file=input_file) + call print(' ALPHA '//round(param%mm_ewald%ewald_alpha,2),file=input_file) + call print(' GMAX '//param%mm_ewald%ewald_gmax,file=input_file) + call print(' &END EWALD',file=input_file) + call print(' POISSON_SOLVER PERIODIC',file=input_file) + call print(' PERIODIC XYZ',file=input_file) + call print(' &MULTIPOLE',file=input_file) + call print(' RCUT 10',file=input_file) + call print(' EWALD_PRECISION 1.E-6',file=input_file) + call print(' NGRIDS 50 50 50',file=input_file) + call print(' &INTERPOLATOR',file=input_file) + ! call print('# AINT_PRECOND SPL3_NOPBC_AINT1',file=input_file) + ! call print('# PRECOND SPL3_NOPBC_PRECOND3',file=input_file) + ! call print('# EPS_X 1.E-15',file=input_file) + ! call print('# EPS_R 1.E-15',file=input_file) + ! call print('# MAX_ITER 200',file=input_file) + call print(' &END INTERPOLATOR',file=input_file) + call print(' &END MULTIPOLE',file=input_file) + call print(' &END POISSON',file=input_file) + ! check if the system is charged, given Charge=... in the comment line + ex = .false. + ex = get_value(my_atoms%params,'Charge',charge) + if (ex) call print(' CHARGE '//charge,file=input_file) + ex = .false. + lsd = .false. + ex = get_value(my_atoms%params,'LSD',lsd) + if (ex .and. lsd) call print(' LSD ',file=input_file) + else + if (mod(nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))),2).ne.0) call print(' LSD',file=input_file) + if (nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))).ne.0) & + call print(' CHARGE '//nint(sum(my_atoms%data%real(atom_charge_index,int_part(qm_list,1)))),file=input_file) + endif + end if ! dft file + call print(' &END DFT',file=input_file) + endif + + if (any(run_type.eq.(/MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + call print(' &MM',file=input_file) + call print(' &FORCEFIELD',file=input_file) + call print(' PARMTYPE '//trim(param%mm_forcefield%parmtype),file=input_file) + call print(' PARM_FILE_NAME ../'//trim(param%mm_forcefield%parm_file_name),file=input_file) ! charmm.pot + if (do_have_silica_potential) then + call print(' DANNY T',file=input_file) + call print(' DANNY_CUTOFF 5.5',file=input_file) + call print(' &SPLINE',file=input_file) + call print(' EMAX_SPLINE 0.5',file=input_file) + call print(' EMAX_ACCURACY 0.1',file=input_file) + call print(' &END SPLINE',file=input_file) + endif + +!!for old CP2K, QM/MM +! if (any(my_atoms%data%str(atom_type_index,1:my_atoms%N).eq.'CCL') .and. any(my_atoms%data%str(atom_type_index,1:my_atoms%N).eq.'CLA')) then +! call print(' &SPLINE',file=input_file) +! call print(' EMAX_SPLINE 20.',file=input_file) +! call print(' &END SPLINE',file=input_file) +! endif +!!for old CP2K, QM/MM + + if (any(my_atoms%data%str(atom_type_index,1:my_atoms%N).eq.'HFL') .or. any(my_atoms%data%str(atom_type_index,1:my_atoms%N).eq.'OFL')) then + call print(' &BEND',file=input_file) + call print(' ATOMS HFL OFL HFL',file=input_file) + call print(' K 0.074',file=input_file) + call print(' THETA0 1.87',file=input_file) + call print(' &END BEND',file=input_file) + call print(' &BOND',file=input_file) + call print(' ATOMS OFL HFL',file=input_file) + call print(' K 0.27',file=input_file) + call print(' R0 1.84',file=input_file) + call print(' &END BOND',file=input_file) +! call print('# &CHARGE',file=input_file) +! call print('# ATOM OFL',file=input_file) +! call print('# CHARGE -0.8476',file=input_file) +! call print('# &END CHARGE',file=input_file) +! call print('# &CHARGE',file=input_file) +! call print('# ATOM HFL',file=input_file) +! call print('# CHARGE 0.4238',file=input_file) +! call print('# &END CHARGE',file=input_file) + call print(' &NONBONDED',file=input_file) + call print(' &LENNARD-JONES',file=input_file) + call print(' atoms OFL OFL',file=input_file) + call print(' EPSILON 78.198',file=input_file) + call print(' SIGMA 3.166',file=input_file) + call print(' RCUT 11.4',file=input_file) + call print(' &END LENNARD-JONES',file=input_file) + call print(' &LENNARD-JONES',file=input_file) + call print(' atoms OFL HFL',file=input_file) + call print(' EPSILON 0.0',file=input_file) + call print(' SIGMA 3.6705',file=input_file) + call print(' RCUT 11.4',file=input_file) + call print(' &END LENNARD-JONES',file=input_file) + call print(' &LENNARD-JONES',file=input_file) + call print(' atoms HFL HFL',file=input_file) + call print(' EPSILON 0.0',file=input_file) + call print(' SIGMA 3.30523',file=input_file) + call print(' RCUT 11.4',file=input_file) + call print(' &END LENNARD-JONES',file=input_file) + call print(' &END NONBONDED',file=input_file) + endif + call print(' &END FORCEFIELD',file=input_file) + call print(' &POISSON',file=input_file) + call print(' &EWALD',file=input_file) + call print(' EWALD_TYPE '//trim(param%mm_ewald%ewald_type),file=input_file) + call print(' EWALD_ACCURACY 1.E-6',file=input_file) + call print(' ALPHA '//round(param%mm_ewald%ewald_alpha,2),file=input_file) + call print(' GMAX '//param%mm_ewald%ewald_gmax,file=input_file) + call print(' &END EWALD',file=input_file) + call print(' &END POISSON',file=input_file) + call print(' &END MM',file=input_file) + endif + + if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + call print(' &QMMM',file=input_file) + call print(' MM_POTENTIAL_FILE_NAME ../MM_POTENTIAL',file=input_file) + call print(' &CELL',file=input_file) + call print(' ABC '//round(param%qmmm%qmmm_cell(1),6)//' '//round(param%qmmm%qmmm_cell(2),6)//' '//round(param%qmmm%qmmm_cell(3),6),file=input_file) !some cell size for the QM region +! call print(' UNIT '//trim(param%qmmm%qmmm_cell_unit),file=input_file) !in Angstroms + call print(' PERIODIC XYZ',file=input_file) !in Angstroms + call print(' &END CELL',file=input_file) + +!!!!!!*********** +! call print('Writing QM/MM links...') + +! if (.not. assign_pointer(at, 'cut_bonds', cut_bonds_p)) & +! call system_abort("potential_calc failed to assing pointer for cut_bonds pointer") + if (assign_pointer(my_atoms,'cut_bonds',cut_bonds_p)) then + call initialise(cut_bonds,2,0,0,0,0) + do i_inner=1,my_atoms%N + do j=1,4 !MAX_CUT_BONDS + i_outer = cut_bonds_p(j,i_inner) + if (i_outer .eq. 0) exit + call append(cut_bonds,(/i_inner,i_outer/)) + enddo + enddo + + do i=1,cut_bonds%N !for each cut bond + i_inner = cut_bonds%int(1,i) + i_outer = cut_bonds%int(2,i) + call print(' &LINK',file=input_file) + call print('# ALPHA_IMOMM',file=input_file) + call print('# CORR_RADIUS',file=input_file) + call print('# FIST_SCALE_FACTOR 1.0',file=input_file) + call print(' LINK_TYPE IMOMM',file=input_file) + call print(' MM_INDEX '//i_outer,file=input_file) + call print(' QMMM_SCALE_FACTOR 1.0',file=input_file) + call print(' QM_INDEX '//i_inner,file=input_file) + call print(' QM_KIND H',file=input_file) + call print('# RADIUS',file=input_file) + !call print(' &ADD_MM_CHARGE',file=input_file) + !call print(' ALPHA',file=input_file) + !call print(' ATOM_INDEX_1',file=input_file) + !call print(' ATOM_INDEX_2',file=input_file) + !call print(' CHARGE',file=input_file) + !call print(' CORR_RADIUS',file=input_file) + !call print(' RADIUS',file=input_file) + !call print(' &END ADD_MM_CHARGE',file=input_file) + !call print(' &MOVE_MM_CHARGE',file=input_file) + !call print(' ALPHA',file=input_file) + !call print(' ATOM_INDEX_1',file=input_file) + !call print(' ATOM_INDEX_2',file=input_file) + !call print(' CORR_RADIUS',file=input_file) + !call print(' RADIUS',file=input_file) + !call print(' &END MOVE_MM_CHARGE',file=input_file) + call print(' &END LINK',file=input_file) + enddo + call finalise(cut_bonds) + endif +!!!!!!*********** + + call print(' ECOUPL '//trim(param%qmmm%ecoupl),file=input_file) !QMMM electrostatic coupling, can be NONE,COULOMB,GAUSS,S-WAVE + +! call print('Writing decoupling section...') + + call print(' &PERIODIC',file=input_file) +! call print('# GMAX 1.',file=input_file) +! call print('# REPLICA -1',file=input_file) +! call print('# NGRIDS 50 50 50',file=input_file) + call print(' &MULTIPOLE',file=input_file) + call print(' RCUT 10',file=input_file) + call print(' EWALD_PRECISION 1.E-6',file=input_file) + call print(' NGRIDS 50 50 50',file=input_file) + call print(' &INTERPOLATOR',file=input_file) +! call print('# AINT_PRECOND SPL3_NOPBC_AINT1',file=input_file) +! call print('# PRECOND SPL3_NOPBC_PRECOND3',file=input_file) +! call print('# EPS_X 1.E-15',file=input_file) +! call print('# EPS_R 1.E-15',file=input_file) +! call print('# MAX_ITER 200',file=input_file) + call print(' &END INTERPOLATOR',file=input_file) + call print(' &END MULTIPOLE',file=input_file) + call print(' &END PERIODIC',file=input_file) + + !print non default COVALENT RADII: only 0.44, 0.78, 0.80 (=default) available, use 0.44 for H, 0.78 for O + do i=1,my_atoms%N-1 + if (any(my_atoms%data%str(atom_type_index,i).eq.my_atoms%data%str(atom_type_index,i+1:my_atoms%N))) cycle + if (any(my_atoms%Z(i).eq.(/1,8/))) then + call print(' &MM_KIND '//trim(my_atoms%data%str(atom_type_index,i)),file=input_file) + if (my_atoms%Z(i).eq.1) then + call print(' RADIUS '//round(param%qmmm%radius_H,3),file=input_file) !radius of the atomic kind + else + call print(' RADIUS '//round(param%qmmm%radius_O,3),file=input_file) !radius of the atomic kind + endif + call print(' &END MM_KIND',file=input_file) +! else +! call print(trim(my_atoms%data%str(atom_type_index,i))//'is not H or O') + endif + enddo + if (any(my_atoms%Z(my_atoms%N).eq.(/1,8/))) then + call print(' &MM_KIND '//trim(my_atoms%data%str(atom_type_index,my_atoms%N)),file=input_file) + if (my_atoms%Z(my_atoms%N).eq.1) then + call print(' RADIUS '//round(param%qmmm%radius_H,3),file=input_file) !radius of the atomic kind + else + call print(' RADIUS '//round(param%qmmm%radius_O,3),file=input_file) !radius of the atomic kind + endif + call print(' &END MM_KIND',file=input_file) + endif + call print('# otherwise use default: 0.800',file=input_file) + +! call print('Writing QM list...') + allocate(list(qm_list%N)) + list=int_part(qm_list,1) + counter = 0 + + !print QM list + do j=1,total_elements + if (any(my_atoms%Z(list(1:size(list))).eq.j)) then + call print(' &QM_KIND '//ElementName(j),file=input_file) + do i=1,qm_list%N + if (my_atoms%Z(list(i)).eq.j) then + call print(' MM_INDEX '//list(i),file=input_file) + counter = counter + 1 + endif + enddo + call print(' &END QM_KIND',file=input_file) + endif + enddo + + if (size(list).ne.counter) call system_abort('cp2k_write_input: Number of QM list atoms '//size(list)// & + ' differs from the written atom numbers '//counter) + + deallocate(list) + + call print(' &END QMMM',file=input_file) + endif + +! call print(' ...lattice parameters...') + call print(' &SUBSYS',file=input_file) + + call print(' &CELL',file=input_file) + call print(' A '//round(my_atoms%lattice(1,1),6)//' '//round(my_atoms%lattice(2,1),6)//' '//round(my_atoms%lattice(3,1),6),file=input_file) + call print(' B '//round(my_atoms%lattice(1,2),6)//' '//round(my_atoms%lattice(2,2),6)//' '//round(my_atoms%lattice(3,2),6),file=input_file) + call print(' C '//round(my_atoms%lattice(1,3),6)//' '//round(my_atoms%lattice(2,3),6)//' '//round(my_atoms%lattice(3,3),6),file=input_file) +! call print(' UNIT ANGSTROM',file=input_file) !in Angstroms + if (len(trim(param%global%cell_file)) > 0) then + call initialise(cell_in_io,trim(param%global%cell_file), INPUT) + stat = 0 + do while (stat == 0) + line = read_line(cell_in_io, stat) + if (stat == 0) call print(trim(line), file=input_file) + end do + call finalise(cell_in_io) + else + call print(' PERIODIC XYZ',file=input_file) !in Angstroms + endif + call print(' &END CELL',file=input_file) + +! call print('...coordinates...') + if (run_type.eq.QS_RUN) then + call print(' &COORD',file=input_file) + do i = 1, my_atoms%N + call print(' '//ElementName(my_atoms%Z(i))//' '//round(my_atoms%pos(1,i),10)//' '//round(my_atoms%pos(2,i),10)//' '//round(my_atoms%pos(3,i),10),file=input_file) + enddo + call print(' &END COORD',file=input_file) + call print('# &VELOCITY',file=input_file) + call print('# &END VELOCITY',file=input_file) + call print(' &TOPOLOGY',file=input_file) + ! this is for an older version of CP2K. uncomment, and comment out next two lines, if your + ! version is older and complains about this statement in the input file + ! call print(' CENTER_COORDINATES',file=input_file) + call print(' &CENTER_COORDINATES T',file=input_file) + call print(' &END CENTER_COORDINATES',file=input_file) + ! + call print(' &END TOPOLOGY',file=input_file) + else + call print('# &COORD',file=input_file) + call print('# &END COORD',file=input_file) + call print('# &VELOCITY',file=input_file) + call print('# &END VELOCITY',file=input_file) + call print(' &TOPOLOGY',file=input_file) + call print(' &DUMP_PSF',file=input_file) + call print(' &END DUMP_PSF',file=input_file) + call print(' &DUMP_PDB',file=input_file) + call print(' &END DUMP_PDB',file=input_file) +! call print(' CENTER_COORDINATES',file=input_file) + call print(' &GENERATE',file=input_file) + call print(' BONDLENGTH_MAX 5.0',file=input_file) + call print(' REORDER F',file=input_file) + call print(' CREATE_MOLECULES F',file=input_file) + + ! print isolated atom list! + call print(' &ISOLATED_ATOMS',file=input_file) + do i = 1, my_atoms%N +! if ((my_atoms%connect%neighbour1(i)%N + my_atoms%connect%neighbour2(i)%N).lt.1) then +! call print(' LIST '//i,file=input_file) +! call print('Written isolated atom '//my_atoms%Z(i)//' with atom number '//i//': has no neighbour') +! cycle +! endif +! needs different name for the QM molecules, say, only the atom name could be both the res_name and the mol_name! + if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + if (any(i.eq.int_part(qm_list,1))) then + call print(' LIST '//i,file=input_file) +! call print('Written isolated atom '//my_atoms%Z(i)//' with atom number '//i//': QM atom') + cycle + endif + endif + if (any(trim(my_atoms%data%str(atom_res_name_index,i)).eq.(/'SOD','CLA'/))) then !'MCL'? + call print(' LIST '//i,file=input_file) +! call print('Written isolated atom '//my_atoms%Z(i)//' with atom number '//i//': methyl-chloride or 1 atom molecule: '//trim(my_atoms%data%str(atom_res_name_index,i))) + cycle + endif + enddo + call print(' &END ISOLATED_ATOMS',file=input_file) + + call print(' &END GENERATE',file=input_file) + call print(' CHARGE_EXTENDED',file=input_file) +! call print(' COORD_FILE_NAME '//param%wenv%pdb_file,file=input_file) +! call print(' COORDINATE PDB',file=input_file) + call print(' COORDINATE EXYZ',file=input_file) + call print(' COORD_FILE_NAME '//trim(param%wenv%exyz_file),file=input_file) + if (any(PSF_print.eq.(/DRIVER_PRINT_AND_SAVE,USE_EXISTING_PSF/))) then + call print(' CONN_FILE_NAME ../'//trim(param%wenv%psf_file),file=input_file) + call print(' CONN_FILE_FORMAT PSF',file=input_file) + endif + call print(' &END TOPOLOGY',file=input_file) + endif +! call print(' ...basis sets and potentials...') + + if (any(run_type.eq.(/QS_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + do j = 1,100 + if (any(my_atoms%Z(1:my_atoms%N).eq.j)) then + call print(' &KIND '//ElementName(j),file=input_file) + if (get_value(param%basis_set,ElementName(j),basis_set)) then + call print(' BASIS_SET '//trim(basis_set),file=input_file) + else + call system_abort('There is no defined basis set for element '//ElementName(j)) + endif + if (get_value(param%potential,ElementName(j),potential)) then + call print(' POTENTIAL '//trim(potential),file=input_file) + else + call system_abort('There is no defined potential for element '//ElementName(j)) + endif + call print(' &END KIND',file=input_file) + endif + enddo + endif + +if (constrain_all_HSI) then + call initialise(bond_constraints,2,0,0,0,0) + do i=1,my_atoms%N + if (trim(my_atoms%data%str(atom_type_index,i)).eq.'HSI') then + nneigh = atoms_n_neighbours(my_atoms,i) +! if (nneigh.ne.1) call system_abort('HSI has '//nneigh//' neighbours') + do ineigh=1,nneigh + j = atoms_neighbour(my_atoms,i,ineigh) + if (is_nearest_neighbour(my_atoms,i,ineigh)) & + call append(bond_constraints,(/i,j/)) + enddo + endif + enddo +endif + + call print(' &END SUBSYS',file=input_file) + call print('&END FORCE_EVAL',file=input_file) + +! call print(' ...any other internal variables...') + + call print('&GLOBAL',file=input_file) + call print(' PROJECT '//trim(param%global%project),file=input_file) + call print(' RUN_TYPE '//trim(param%global%runtype),file=input_file) + call print(' PRINT_LEVEL LOW',file=input_file) + if (len(trim(param%global%global_file)) > 0) then + call initialise(global_in_io,trim(param%global%global_file), INPUT) + stat = 0 + do while (stat == 0) + line = read_line(global_in_io, stat) + if (stat == 0) call print(trim(line), file=input_file) + end do + call finalise(global_in_io) + endif + call print('&END GLOBAL',file=input_file) + call print('&MOTION',file=input_file) + +if (constrain_all_HSI) then + call print(' &CONSTRAINT',file=input_file) + call print(' &HBONDS',file=input_file) + call print(' ATOM_TYPE OSI',file=input_file) + call print(' TARGETS [angstrom] 0.978',file=input_file) + call print(' &END HBONDS',file=input_file) + call print(' &END CONSTRAINT',file=input_file) +endif + + call print(' &PRINT',file=input_file) + call print(' &FORCES',file=input_file) + call print(' FORMAT XMOL',file=input_file) + call print(' &END FORCES',file=input_file) + call print(' &END PRINT',file=input_file) + call print(' &MD',file=input_file) + call print(' ENSEMBLE '//trim(param%md%ensemble),file=input_file) !not needed,only for input check + call print(' STEPS '//param%md%steps,file=input_file) !only calculates forces and writes them + call print(' TIMESTEP '//round(param%md%timestep,2),file=input_file) !not needed, only for input check + call print(' TEMPERATURE '//round(param%md%temperature,2),file=input_file) !TEMPERATURE + call print(' TEMP_KIND',file=input_file) + call print(' &PRINT',file=input_file) + call print(' &TEMP_KIND',file=input_file) + call print(' &END TEMP_KIND',file=input_file) + call print(' &END PRINT',file=input_file) + call print(' &END MD',file=input_file) + call print('&END MOTION',file=input_file) + + call finalise(input_file) + + end subroutine write_cp2k_input_file + + + !!!!! ============================================================================================ !!!!! + !!!!! !!!!! + !!!!! \/ \/ \/ \/ \/ \/ ----- read forces and energy from CP2K output file ----- \/ \/ \/ \/ \/ \/ !!!!! + !!!!! !!!!! + !!!!! ============================================================================================ !!!!! + + !% Read the forces and the energy from the CP2K output file. + !% Check for reordering, and converts the energy units into eV, the forces to eV/A. + ! + subroutine read_cp2k_forces(forces,energy,param,my_atoms,run_type,PRINT_verbose) + + real(dp),allocatable,dimension(:,:),intent(out) :: forces + real(dp), intent(out) :: energy + type(param_cp2k), intent(in) :: param + type(Atoms), intent(in) :: my_atoms + integer, intent(in) :: run_type + logical, optional, intent(in) :: verbose + + integer :: i,j,num_atoms,m,status + type(Inoutput) :: force_file + logical :: my_verbose + character(len=1024) :: commentline + character(len=2048), dimension(10) :: fields + integer :: num_fields + type(Dictionary) :: params + logical :: energy_found + + my_verbose = .false. + if (present(verbose)) my_verbose = PRINT_verbose + + call initialise(force_file,trim(param%wenv%working_directory)//'/'//trim(param%wenv%force_file),action=INPUT,isformatted=.true.) + call print('Reading forces from file '//trim(force_file%filename)//'...') + + call parse_line(force_file,' ',fields,num_fields,status) + if (status > 0) then + call system_abort('read_cp2k_forces: Error reading from '//force_file%filename) + else if (status < 0) then + call system_abort('read_cp2k_forces: End of file when reading from '//force_file%filename) + end if + + num_atoms = string_to_int(fields(1)) + if (num_atoms.ne.my_atoms%N) call system_abort('read_cp2k_forces: different number of atoms in the force file and in the my_atoms object') + if (my_verbose) & + call print('Reading force coordinates of '//num_atoms//' atoms') + allocate(forces(3,num_atoms)) + + !read the energy from the command line + commentline = read_line(force_file) + call read_string(params, commentline) + energy_found = get_value(params, 'E',energy) + if (.not.energy_found) call system_abort('read_cp2k_forces: no energy found in '//force_file%filename//', update CP2K you are using!!') + + !read forces + do i=1,num_atoms + call parse_line(force_file,' ',fields,num_fields) + if (num_fields < 4) exit + do j = 2, 4 + forces((j-1),i) = string_to_real(fields(j)) + end do +! call print('read force for atom '//i//': '//round(forces(1,i),3)//' '//round(forces(2,i),3)//' '//round(forces(3,i),3)) + enddo + call energy_conversion(energy) + call force_conversion(forces) + call finalise(force_file) + + ! re-reorder atoms/forces in case CP2K reordered them + call read_convert_back_pos(forces,param,my_atoms,run_type=run_type,PRINT_verbose=my_verbose) + + call print('') + call print('The energy of the system: '//energy) + call verbosity_push_decrement() + call print('The forces acting on each atom (eV/A):') + call print('atom F(x) F(y) F(z)') + do m=1,size(forces,2) + call print(' '//m//' '//forces(1,m)//' '//forces(2,m)//' '//forces(3,m)) + enddo + call verbosity_pop() + call print('Sum of the forces: '//sum(forces(1,1:num_atoms))//' '//sum(forces(2,1:num_atoms))//' '//sum(forces(3,1:num_atoms))) + +! if (any(abs(forces(1:3,1:my_atoms%N)).gt.(4.21648784E-02*HARTREE/BOHR))) & +! call print('at least one too large force') + + end subroutine read_cp2k_forces + + !% Re-reordering algorithm. CP2K shifts the atomic coordinates, occasionally + !% reorders the atoms, too. To keep this under control, the positions are read + !% and compared with the atoms object. + !% Calculates the shift the same way CP2K does. + !% As an output the forces are in the same order as the atoms in the original + !% atoms object. + ! + subroutine read_convert_back_pos(forces,param,my_atoms,run_type,PRINT_verbose) + + real(dp), allocatable, dimension(:,:), intent(inout) :: forces + type(param_cp2k), intent(in) :: param + type(Atoms), intent(in) :: my_atoms + integer, intent(in) :: run_type + logical, optional, intent(in) :: verbose + + type(InOutput) :: pos + type(Atoms) :: reordered + type(Table) :: qm_list + real(dp), dimension(3) :: shift + integer, allocatable, dimension(:) :: oldpos + real(dp), allocatable, dimension(:,:) :: tforces + integer :: i, j, status + logical :: my_verbose +integer, pointer :: cut_bonds_p(:,:) +integer :: i_inner, i_outer + + if (.not.any(run_type.eq.(/QS_RUN,MM_RUN,QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) & + call system_abort('read_convert_back_matrix: Run type is not recognized: '//run_type) + + my_verbose = optional_default(.false.,PRINT_verbose) + if (my_verbose) & + call print_title('Reading matrix of new atomic coordinates from CP2K output') + + ! Getting the oldpos matrix from *-pos-* file... + call initialise(pos,filename=trim(param%wenv%working_directory)//'/'//trim(param%wenv%pos_file)) + + call print('Reading possibly reordered atoms from file '//pos%filename) + call read_xyz(reordered,pos,status=status) + if (status.ne.0) call system_abort('no atoms could be read from file '//pos%filename) + if (reordered%N.ne.my_atoms%N) call system_abort('different number of atoms in the original and reordered atoms object') + + allocate(oldpos(my_atoms%N)) + oldpos = 0 + + !match the atoms in the 2 atoms object to obtain the oldpos list + + ! shifted cell in case of QMMM (cp2k/src/topology_coordinate_util.F) + if (any(run_type.eq.(/QMMM_RUN_CORE,QMMM_RUN_EXTENDED/))) then + call get_qm_list_int_rec(my_atoms,run_type,qm_list,do_recursive=.true.) + !add links to the qm list, if there is any: + if (assign_pointer(my_atoms,'cut_bonds',cut_bonds_p)) then + do i_inner=1,my_atoms%N + do j=1,4 !MAX_CUT_BONDS + i_outer = cut_bonds_p(j,i_inner) + if (i_outer .eq. 0) exit + call append(qm_list,(/i_outer,0,0,0/)) + enddo + enddo + endif + do i=1,3 + shift(i) = 0.5_dp * param%qmmm%qmmm_cell(i) & + - ( MINVAL(my_atoms%pos(i,int_part(qm_list,1))) + & + MAXVAL(my_atoms%pos(i,int_part(qm_list,1))) ) * 0.5_dp + enddo + else + shift = 0._dp + endif + + ! try to get reordering using default shift + do i=1,my_atoms%N + do j=1,reordered%N +! if ((my_atoms%pos(1:3,i)+shift).feq.reordered%pos(1:3,j)) then + if (matrix_feq2(my_atoms%pos(1:3,i)+shift,reordered%pos(1:3,j))) then +! call print('atom '//i//' became atom '//j) + oldpos(i) = j + exit + endif + enddo + enddo + + ! if failed, try reordering again with shift of a/2 b/2 c/2 (in case user set TOPOLOGY%CENTER_COORDINATES) + if (any(oldpos.eq.0) .and. run_type .eq. QS_RUN) then + shift = sum(my_atoms%lattice(:,:),2)/2.0_dp - & + (minval(my_atoms%pos(:,:),2)+maxval(my_atoms%pos(:,:),2))/2.0_dp + do i=1,my_atoms%N + do j=1,reordered%N + ! if ((my_atoms%pos(1:3,i)+shift).feq.reordered%pos(1:3,j)) then + if (matrix_feq2(my_atoms%pos(1:3,i)+shift,reordered%pos(1:3,j))) then + ! call print('atom '//i//' became atom '//j) + oldpos(i) = j + exit + endif + enddo + enddo + endif + + if (any(oldpos.eq.0)) then + call system_abort('could not match the 2 atoms objects') + endif + + call finalise(pos) + ! End of getting the oldpos matrix from *-pos-* file... + + allocate(tforces(3,my_atoms%N)) + tforces = 0. + do i=1,my_atoms%N + tforces(1:3,oldpos(i)) = forces(1:3,i) + enddo + + forces = tforces + + deallocate(tforces) + deallocate(oldpos) + end subroutine read_convert_back_pos + + !% Force mixing with energy conservation. The fitlist includes the core and buffer atoms. + !% Mass weights are used. + ! + subroutine QUIP_combine_forces(qmmm_forces,mm_forces,combined_forces,my_atoms) + ! use momentum conservation DOES NOT ASSUME that SUM(F(MM)) = 0._dp: + ! for fitlist: F_i = F(MM) - m_i * SUMcore(F_i) / SUMfitlist(m_i) + ! for QM core: F_i = F(QM/MM) - m_i * SUMcore(F_i) / SUMfitlist(m_i) + ! for MM atoms: F_i = F(MM) + ! inner qm_list should be a reordered qm_list !! + ! wrk1 should be written into file !! + + real(dp), allocatable, dimension(:,:), intent(in) :: qmmm_forces + real(dp), allocatable, dimension(:,:), intent(in) :: mm_forces + real(dp), allocatable, dimension(:,:), intent(out) :: combined_forces + type(Atoms), intent(in) :: my_atoms + + integer :: i_atom,m + real(dp),dimension(3) :: force_corr + real(dp) :: mass_corr + type(Table) :: core, fitlist + + if (size(qmmm_forces,2).ne.my_atoms%N.or.size(mm_forces,2).ne.my_atoms%N) call system_abort('combine_forces: the size of QMMM and/or MM forces is different: different number of atoms') + + call get_qm_list_int(my_atoms,1,core) + call get_qm_list_int_rec(my_atoms,2,fitlist, do_recursive=.true.) + + force_corr = 0._dp + mass_corr = 0._dp + allocate(combined_forces(3,my_atoms%N)) + combined_forces = 0._dp + + force_corr = sum(mm_forces,2) !this can be deleted if SUM(F(MM)) = 0._dp + force_corr = force_corr + sum((qmmm_forces(1:3,int_part(core,1))-mm_forces(1:3,int_part(core,1))),2) + mass_corr = sum(ElementMass(my_atoms%Z(int_part(fitlist,1)))) + + force_corr = force_corr / mass_corr + call print('Force mixing: the force correction is '//force_corr(1)//' '//force_corr(2)//' '//force_corr(3)) + + combined_forces(1:3,1:my_atoms%N) = mm_forces(1:3,1:my_atoms%N) + combined_forces(1:3,int_part(core,1)) = qmmm_forces(1:3,int_part(core,1)) + do i_atom=1,my_atoms%N + if (any(int_part(fitlist,1).eq.i_atom)) combined_forces(1:3,i_atom) = combined_forces(1:3,i_atom) - ElementMass(my_atoms%Z(i_atom)) * force_corr + enddo + + call print('') + call print('No energy after force mixing.') + call verbosity_push_decrement() + call print('The forces acting on each atom (eV/A):') + call print('atom F(x) F(y) F(z)') + do m=1,size(combined_forces,2) + call print(' '//m//' '//combined_forces(1,m)//' '//combined_forces(2,m)//' '//combined_forces(3,m)) + enddo + call verbosity_pop() + call print('Sum of the combined forces: '//sum(combined_forces(1,1:my_atoms%N))//' '//sum(combined_forces(2,1:my_atoms%N))//' '//sum(combined_forces(3,1:my_atoms%N))) + + + end subroutine QUIP_combine_forces + + !% Abrupt force mixing. The fitlist includes the core and buffer atoms. + !% Uniform weights are used. + ! + subroutine abrupt_force_mixing(qmmm_forces,mm_forces,combined_forces,my_atoms) + ! do not use momentum conservation + ! for QM core: F_i = F(QM/MM) + ! else: F_i = F(MM) + + real(dp), allocatable, dimension(:,:), intent(in) :: qmmm_forces + real(dp), allocatable, dimension(:,:), intent(in) :: mm_forces + real(dp), allocatable, dimension(:,:), intent(out) :: combined_forces + type(Atoms), intent(in) :: my_atoms + + integer :: m + type(Table) :: core, fitlist + + if (size(qmmm_forces,2).ne.my_atoms%N.or.size(mm_forces,2).ne.my_atoms%N) call system_abort('combine_forces: the size of QMMM and/or MM forces is different: different number of atoms') + + call get_qm_list_int(my_atoms,1,core) + + allocate(combined_forces(3,my_atoms%N)) + combined_forces = 0._dp + + combined_forces(1:3,1:my_atoms%N) = mm_forces(1:3,1:my_atoms%N) + combined_forces(1:3,int_part(core,1)) = qmmm_forces(1:3,int_part(core,1)) + + call print('') + call print('No energy after force mixing.') +! call verbosity_push_decrement() + call print('The forces acting on each atom (eV/A):') + call print('atom F(x) F(y) F(z)') + do m=1,size(combined_forces,2) + call print(' '//m//' '//combined_forces(1,m)//' '//combined_forces(2,m)//' '//combined_forces(3,m)) + enddo +! call verbosity_pop() + call print('Sum of the combined forces: '//sum(combined_forces(1,1:my_atoms%N))//' '//sum(combined_forces(2,1:my_atoms%N))//' '//sum(combined_forces(3,1:my_atoms%N))) + + + end subroutine abrupt_force_mixing + + !% Calculates the force on the $i$th atom due to an external potential that has + !% the form of a spline, $my_spline$. + ! + function spline_force(at, i, my_spline, pot) result(force) + + type(Atoms), intent(in) :: at + integer, intent(in) :: i + type(spline_pot), intent(in) :: my_spline + real(dp), optional, intent(out) :: pot + real(dp), dimension(3) :: force + + real(dp) :: dist, factor + +! dist = distance from the origin +! spline: f(dist) = spline%dpot/(spline%from-spline%to)**3._dp * (dist-spline%to)**2._dp * (3._dp*spline%from - spline%to - 2._dp*dist) +! f(spline%from) = spline%dpot; f(spline%to) = 0. +! f`(spline%from) = 0.; f`(spline%to) = 0. +! force = - grad f(dist) + + dist = distance_min_image(at,i,(/0._dp,0._dp,0._dp/)) + if (dist.ge.my_spline%to .or. dist.le.my_spline%from) then + force = 0._dp + if (present(pot)) then + if (dist.ge.my_spline%to) pot = 0._dp + if (dist.le.my_spline%from) pot = my_spline%dpot + endif + else + factor = 1._dp + ! force on H should be 1/16 times the force on O, to get the same acc. + if (at%Z(i).eq.1) factor = ElementMass(1)/ElementMass(8) + force = - factor * 2._dp *my_spline%dpot / ((my_spline%from - my_spline%to)**3._dp * dist) * & + ( (3._dp * my_spline%from - my_spline%to - 2._dp * dist) * (dist - my_spline%to) & + - (dist - my_spline%to)**2._dp ) * at%pos(1:3,i) + if (present(pot)) pot = my_spline%dpot/(my_spline%from-my_spline%to)**3._dp * (dist-my_spline%to)**2._dp * (3._dp*my_spline%from - my_spline%to - 2._dp*dist) + endif + + end function spline_force + +! subroutine combine_forces(qmmm_forces,mm_forces,combined_forces,qmlist,my_atoms) +! ! use momentum conservation: +! ! for QM atoms: F_corr,i = m_i * SUMall(F_i) / SUMqm(m_i) +! ! for MM atoms: F_corr,i = 0 +! ! inner qm_list should be a reordered qm_list !! +! ! wrk1 should be written into file !! +! +! real(dp), allocatable, dimension(:,:), intent(in) :: qmmm_forces +! real(dp), allocatable, dimension(:,:), intent(in) :: mm_forces +! real(dp), allocatable, dimension(:,:), intent(out) :: combined_forces +! type(Table), intent(in) :: qmlist +! type(Atoms), intent(in) :: my_atoms +! +! integer :: i_atom +! real(dp),dimension(3) :: force_corr +! real(dp) :: mass_corr +! +! if (size(qmmm_forces,2).ne.my_atoms%N.or.size(mm_forces,2).ne.my_atoms%N) call system_abort('combine_forces: the size of QMMM and/or MM forces is different: different number of atoms') +! if (any(int_part(qmlist,1).gt.my_atoms%N).or.any(int_part(qmlist,1).lt.1)) call system_abort('combine_forces: QM atom out of range 1-'//my_atoms%N) +! +! force_corr = 0._dp +! mass_corr = 0._dp +! allocate(combined_forces(3,my_atoms%N)) +! combined_forces = 0._dp +! +! combined_forces(1:3,1:my_atoms%N) = mm_forces(1:3,1:my_atoms%N) +! combined_forces(1:3,int_part(qmlist,1)) = qmmm_forces(1:3,int_part(qmlist,1)) +! force_corr = sum(combined_forces,2) +! mass_corr = sum(ElementMass(my_atoms%Z(int_part(qmlist,1)))) +! +! force_corr = force_corr / mass_corr +! +! do i_atom=1,my_atoms%N +! if (any(int_part(qmlist,1).eq.i_atom)) combined_forces(1:3,i_atom) = qmmm_forces(1:3,i_atom) - ElementMass(my_atoms%Z(i_atom)) * force_corr +! enddo +! +! end subroutine combine_forces + + !% Energy conversion from hartree (used by CP2K) to eV. + ! + subroutine energy_conversion(energy) + + real(dp), intent(inout) :: energy + + energy = energy * HARTREE + + end subroutine energy_conversion + + !% Force conversion from hartree/bohr (used by CP2K) to eV/A. + ! + subroutine force_conversion(force) + + real(dp), dimension(:,:), intent(inout) :: force + integer :: i + + if (size(force,2).le.0) call system_abort('force_conversion: no forces!') + if (size(force,1).ne.3) call system_abort('force_conversion: '//size(force,1)//' components of force instead of 3') + + do i=1,size(force,2) + force(1:3,i) = force(1:3,i) * HARTREE / BOHR + enddo + + end subroutine force_conversion + + !% Velocity conversion from hartree*bohr/hbar (used by CP2K) to A/fs. + ! + subroutine velocity_conversion(at) + + type(Atoms), intent(inout) :: at + integer :: i + + if (.not.associated(at%velo)) call system_abort('velocity_conversion: no velocities!') + + do i=1,at%N + at%velo(1:3,i) = at%velo(1:3,i) * (HARTREE * BOHR / HBAR) + enddo + + end subroutine velocity_conversion + + !% Velocity conversion from A/fs to hartree*bohr/hbar (used by CP2K). + ! + subroutine velocity_conversion_rev(at) + + type(Atoms), intent(inout) :: at + integer :: i + + if (.not.associated(at%velo)) call system_abort('velocity_conversion: no velocities!') + + do i=1,at%N + at%velo(1:3,i) = at%velo(1:3,i) / (HARTREE * BOHR / HBAR) + enddo + + end subroutine velocity_conversion_rev + + !% Floating point logical comparison used by read_convert_back_pos, + !% to compare atoms objects positions. + ! + function real_feq2(x,y) result(feq) + + real(dp), intent(in) :: x, y + logical :: feq + + if (abs(x-y) > EPSILON_ZERO) then + feq = .false. + else + feq = .true. + end if + + end function real_feq2 + + !% Matrix floating point logical comparison used by read_convert_back_pos, + !% to compare atoms objects positions. + ! + function matrix_feq2(matrix1,matrix2) result (feq) + real(dp),intent(in), dimension(:) :: matrix1 + real(dp),intent(in), dimension(:) :: matrix2 + + integer::j + logical::feq + + call check_size('Matrix2',matrix2,shape(matrix1),'Matrix_FEQ') + + feq =.true. + do j=1,size(matrix1) + if (.not.real_feq2(matrix1(j),matrix2(j))) then + feq=.false. + return + end if + end do + + end function matrix_feq2 + + !!!!! ============================================================================================ !!!!! + !!!!! !!!!! + !!!!! \/ \/ \/ \/ \/ \/ ------------------- create region ------------------- \/ \/ \/ \/ \/ \/ !!!!! + !!!!! !!!!! + !!!!! ============================================================================================ !!!!! + + + !% Updates the core QM flags saved in $hybrid$ and $hybrid_mark$ properties. + !% Do this hysteretically, from $R_inner$ to $R_outer$ around $origin$, that is + !% the centre of the QM region. + ! + subroutine create_centred_qmcore(my_atoms,R_inner,R_outer,origin,use_avgpos,add_only_heavy_atoms,nneighb_only,min_images_only,list_changed) + + type(Atoms), intent(inout) :: my_atoms + real(dp), intent(in) :: R_inner + real(dp), intent(in) :: R_outer + real(dp), optional, intent(in) :: origin(3) + logical, optional, intent(in) :: use_avgpos, add_only_heavy_atoms, nneighb_only, min_images_only + logical, optional, intent(out) :: list_changed + + type(Atoms) :: atoms_for_add_cut_hydrogens + type(Table) :: inner_list, outer_list, core, core1, ext_qmlist + integer :: qm_flag_index, i + real(dp) :: my_origin(3) + + my_origin = optional_default((/0._dp,0._dp,0._dp/),origin) + + call map_into_cell(my_atoms) + + call allocate(core,4,0,0,0,0) + call allocate(core1,4,0,0,0,0) + call get_qm_list_int(my_atoms,1,core1,int_property='hybrid_mark') + call get_qm_list_int(my_atoms,1,core,int_property='hybrid_mark') + call get_qm_list_int_rec(my_atoms,2,ext_qmlist, do_recursive=.true.,int_property='hybrid_mark') + +!Build the hysteretic QM core: + call construct_hysteretic_region(region=core,at=my_atoms,centre=my_origin,loop_atoms_no_connectivity=.true., & + inner_radius=R_inner,outer_radius=R_outer, use_avgpos=use_avgpos, add_only_heavy_atoms=add_only_heavy_atoms, & + nneighb_only=nneighb_only, min_images_only=min_images_only, debugfile=mainlog) +! call construct_buffer_origin(my_atoms,R_inner,inner_list,my_origin) +! call construct_buffer_origin(my_atoms,R_outer,outer_list,my_origin) +! call construct_region(my_atoms,R_inner,inner_list,centre=my_origin,use_avgpos=.false.,add_only_heavy_atoms=.false., with_hops=.false.) +! call construct_region(my_atoms,R_outer,outer_list,centre=my_origin,use_avgpos=.false.,add_only_heavy_atoms=.false., with_hops=.false.) + +! call select_hysteretic_quantum_region(my_atoms,inner_list,outer_list,core) +! call finalise(inner_list) +! call finalise(outer_list) + +!TO BE OPTIMIZED : add avgpos to add_cut_hydrogen + ! add cut hydrogens, according to avgpos + atoms_for_add_cut_hydrogens = my_atoms + atoms_for_add_cut_hydrogens%oldpos = my_atoms%avgpos + atoms_for_add_cut_hydrogens%avgpos = my_atoms%avgpos + atoms_for_add_cut_hydrogens%pos = my_atoms%avgpos + call set_cutoff(atoms_for_add_cut_hydrogens,DEFAULT_NNEIGHTOL) + call calc_connect(atoms_for_add_cut_hydrogens) + call add_cut_hydrogens(atoms_for_add_cut_hydrogens,core) + !call print('Atoms in hysteretic quantum region after adding the cut hydrogens:') + !do i=1,core%N + ! call print(core%int(1,i)) + !enddo + call finalise(atoms_for_add_cut_hydrogens) + + ! check changes in QM list and set the new QM list + if (present(list_changed)) then + list_changed = check_list_change(old_list=core1,new_list=core) + if (list_changed) call print('QM list around the origin has changed') + endif + + ! update QM_flag of my_atoms + qm_flag_index = get_property(my_atoms,'hybrid_mark') + my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 + my_atoms%data%int(qm_flag_index,int_part(ext_qmlist,1)) = 2 + my_atoms%data%int(qm_flag_index,int_part(core,1)) = 1 + + ! update hybrid property of my_atoms + qm_flag_index = get_property(my_atoms,'hybrid') + my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 + my_atoms%data%int(qm_flag_index,int_part(core,1)) = 1 + + call finalise(core) + call finalise(core1) + call finalise(ext_qmlist) + + end subroutine create_centred_qmcore + + +! subroutine construct_buffer_origin(my_atoms,Radius,list,origin) +! +! type(Atoms), intent(inout) :: my_atoms +! real(dp), intent(in) :: Radius +! type(Table), intent(out) :: list +! real(dp), optional, intent(in) :: origin(3) +! +! integer :: i +! real(dp) :: my_origin(3) +! logical :: buffer_general, do_general +! +! my_origin = optional_default((/0._dp,0._dp,0._dp/),origin) +! +! call initialise(list,4,0,0,0,0) +! +! if (get_value(my_atoms%params,'Buffer_general',do_general)) then +! call print('Found Buffer_general in atoms%params'//do_general) +! buffer_general=do_general +! else +! call print('not Found Buffer_general in atoms%params set to F') +! buffer_general=.false. +! endif +! +! do i = 1,my_atoms%N +! if (.not.buffer_general) then +! if (my_atoms%Z(i).eq.1) cycle +! endif +! if (distance_min_image(my_atoms,i,my_origin(1:3)).lt.Radius) call append(list,(/i,0,0,0/)) +! enddo +! +! end subroutine construct_buffer_origin +! +! +! function extend_qmlist(my_atoms,R_inner,R_outer) result(list_changed) +! +! type(Atoms), intent(inout) :: my_atoms +! real(dp), optional, intent(in) :: R_inner, R_outer !! to select hysteretic quantum region +! +! real(dp) :: inner, outer +! type(Table) :: inner_buffer, outer_buffer +! type(Table) :: core, ext_qmlist, old_ext_qmlist +! type(Atoms) :: fake, atoms_for_add_cut_hydrogens +! integer :: qm_flag_index, i +! logical :: list_changed,buffer_general,do_general +! +! ! checking the optional inputs +! if (present(R_inner)) then +! inner = R_inner +! if (present(R_outer)) then +! outer = R_outer +! call print('Updating QM_flag properties according to R_inner = '//round(R_inner,3)//', R_outer = '//round(R_outer,3)) +! else +! call print('Warning: extend_qmlist: R_inner present, but not R_outer! Use R_outer=R_inner!') +! outer = R_inner +! endif +! else +! if (present(R_outer)) then +! call print('Warning: extend_qmlist: R_outer present, but not R_inner! Use R_inner=R_outer!') +! inner = R_outer +! outer = R_outer +! else +! call print('Warning: extend_qmlist: R_inner and R_outer not present! qm_list will not be extended!') +! return +! endif +! endif +! +! call get_qm_list_int(my_atoms,1,core) +! call get_qm_list_int_rec(my_atoms,2,ext_qmlist, do_recursive=.true.) +! call get_qm_list_int_rec(my_atoms,2,old_ext_qmlist, do_recursive=.true.) +! +!!TO BE OPTIMIZED: +! ! extend the qm region > ext_qmlist +! !this should go without fake atoms and with use_avgpos! but not the cluster making, only the add_cut_hydrogen! +! fake=my_atoms +!! cutoff_old = my_atoms%cutoff +! call set_cutoff_minimum(fake,outer*(maxval(ElementCovRad(fake%Z(1:fake%N)))/ElementCovRad(8))) ! to find everything like O +! call calc_connect(fake) +! +! if (get_value(my_atoms%params,'Buffer_general',do_general)) then +! call print('Found Buffer_general in atoms%params'//do_general) +! buffer_general=do_general +! else +! call print('not Found Buffer_general in atoms%params set to F') +! buffer_general=.false. +! endif +! +! if (buffer_general) then +! call print('Not element specific buffer selection') +! call construct_buffer(fake,core,inner,inner_buffer,use_avgpos=.false.,verbosity=PRINT_NORMAL) +! !call print('Atoms in inner buffer:') +! !do i=1,inner_buffer%N +! ! call print(inner_buffer%int(1,i)) +! !enddo +! call construct_buffer(fake,core,outer,outer_buffer,use_avgpos=.false.,verbosity=PRINT_NORMAL) +! !call print('Atoms in outer buffer:') +! !do i=1,outer_buffer%N +! ! call print(outer_buffer%int(1,i)) +! !enddo +! !call print('Atoms in the quantum region before updating:') +! !do i=1,ext_qmlist%N +! ! call print(ext_qmlist%int(1,i)) +! !enddo +! else +! call print('Element specific buffer selection, only heavy atoms count') +! call construct_buffer_RADIUS(fake,core,inner,inner_buffer,use_avgpos=.false.,verbosity=PRINT_NORMAL) +! !call print('Atoms in inner buffer:') +! !do i=1,inner_buffer%N +! ! call print(inner_buffer%int(1,i)) +! !enddo +! call construct_buffer_RADIUS(fake,core,outer,outer_buffer,use_avgpos=.false.,verbosity=PRINT_NORMAL) +! !call print('Atoms in outer buffer:') +! !do i=1,outer_buffer%N +! ! call print(outer_buffer%int(1,i)) +! !enddo +! !call print('Atoms in the quantum region before updating:') +! !do i=1,ext_qmlist%N +! ! call print(ext_qmlist%int(1,i)) +! !enddo +! endif +! call select_hysteretic_quantum_region(fake,inner_buffer,outer_buffer,ext_qmlist,verbosity=PRINT_NORMAL) +! !call print('Atoms in hysteretic quantum region:') +! !do i=1,ext_qmlist%N +! ! call print(ext_qmlist%int(1,i)) +! !enddo +! call finalise(fake) +! call finalise(inner_buffer) +! call finalise(outer_buffer) +! +! ! add cut hydrogens, according to avgpos +! atoms_for_add_cut_hydrogens = my_atoms +! atoms_for_add_cut_hydrogens%oldpos = my_atoms%avgpos +! atoms_for_add_cut_hydrogens%avgpos = my_atoms%avgpos +! atoms_for_add_cut_hydrogens%pos = my_atoms%avgpos +! call set_cutoff(atoms_for_add_cut_hydrogens,0._dp) +! call calc_connect(atoms_for_add_cut_hydrogens) +! call add_cut_hydrogens(atoms_for_add_cut_hydrogens,ext_qmlist) +! !call print('Atoms in hysteretic quantum region after adding the cut hydrogens:') +! !do i=1,ext_qmlist%N +! ! call print(ext_qmlist%int(1,i)) +! !enddo +! call finalise(atoms_for_add_cut_hydrogens) +! +! ! check changes in QM list and set the new QM list +! list_changed = check_list_change(old_list=old_ext_qmlist,new_list=ext_qmlist) +! +! ! update QM_flag of my_atoms +! qm_flag_index = get_property(my_atoms,'QM_flag') +! my_atoms%data%int(qm_flag_index,1:my_atoms%N) = 0 +! my_atoms%data%int(qm_flag_index,int_part(ext_qmlist,1)) = 2 +! my_atoms%data%int(qm_flag_index,int_part(core,1)) = 1 +! +! call finalise(core) +! call finalise(ext_qmlist) +! call finalise(old_ext_qmlist) +! +! end function extend_qmlist +! +! +! subroutine construct_buffer_RADIUS(my_atoms,core,radius,buffer,use_avgpos,verbosity) +! +! type(Atoms), intent(in) :: my_atoms +! real(dp), intent(in) :: radius +! type(Table), intent(in) :: core +! type(Table), intent(out) :: buffer +! logical, optional, intent(in) :: use_avgpos +! integer, optional, intent(in) :: verbosity +! +! integer :: i,j +! logical :: delete_it +! +! call construct_buffer(my_atoms,core,(radius*maxval(ElementCovRad(my_atoms%Z(1:my_atoms%N)))/ElementCovRad(8)),buffer,use_avgpos=use_avgpos,verbosity=verbosity) +! !call print('Atoms in buffer:') +! !do i=1,buffer%N +! ! call print(buffer%int(1,i)) +! !enddo +! +! i = 1 +! do while (i.le.buffer%N) +! delete_it = .true. +! if (any(buffer%int(1,i).eq.core%int(1,1:core%N))) then ! keep core +! delete_it = .false. +! else +! if (my_atoms%Z(buffer%int(1,i)).ne.1) then ! delete Hs from buffer +! do j=1,core%N +! if (my_atoms%Z(core%int(1,j)).eq.1) cycle ! only consider nonH -- nonH distances +! if (distance_min_image(my_atoms,buffer%int(1,i),core%int(1,j)).le. & +! radius / (ElementCovrad(8) + ElementCovRad(8)) * (ElementCovRad(my_atoms%Z(buffer%int(1,i))) + ElementCovRad(my_atoms%Z(core%int(1,j))))) then +! delete_it = .false. +! !call print('Atom '//ElementName(my_atoms%Z(buffer%int(1,i)))//buffer%int(1,i)//' is within element specific buffer distance '//round(distance_min_image(my_atoms,buffer%int(1,i),core%int(1,j)),3)//' < '//round(radius / (ElementCovrad(8) + ElementCovRad(8)) * (ElementCovRad(my_atoms%Z(buffer%int(1,i))) + ElementCovRad(my_atoms%Z(core%int(1,j)))),3)) +! endif +! enddo +! endif +! endif +! if (delete_it) then +! !call print('delete atom '//ElementName(my_atoms%Z(buffer%int(1,i)))//buffer%int(1,i)//'from buffer') +! call delete(buffer,i) +! i = i - 1 +! endif +! i = i + 1 +! enddo +! +! end subroutine construct_buffer_RADIUS + +end module cp2k_driver_module diff --git a/src/FilePot_drivers/cp2k_filepot_old.F90 b/src/FilePot_drivers/cp2k_filepot_old.F90 new file mode 100644 index 0000000000..450634557f --- /dev/null +++ b/src/FilePot_drivers/cp2k_filepot_old.F90 @@ -0,0 +1,259 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X cp2k_filepot program +!X +!% outdated filepot program for CP2K driver using hard-coded input file +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!FilePotential for the CP2K driver +!FilePot uses go_cp2k from the cp2k_driver_module +!reads filepot.0.xyz >> runs CP2K >> writes filepot.0.out with forces + +!Initialisation: +!For QS or MM calculation: +! call initialise(CP2K_pot,'FilePot command=/Users/csilla/QUIP/build.darwin_x86_64_g95/cp2k_filepot property_list=pos min_cutoff=0.0') +!For QM/MM calculation: +! call initialise(CP2K_pot,'FilePot command=/Users/csilla/QUIP/build.darwin_x86_64_g95/cp2k_filepot property_list=pos:QM_flag min_cutoff=0.0') + +!Calc (args_str is the same as for go_cp2k): +! call calc(CP2K_pot,ds%atoms,energy=energy,forces=f1,args_str=trim(args_str)) + + +program cp2k_filepot + + use libatoms_module + use cp2k_driver_module + use potential_module +! use atoms_module +! use topology_module + + implicit none + + type(Atoms) :: my_atoms + real(dp) :: energy + real(dp), allocatable :: f0(:,:) + real(dp), pointer :: forces_p(:,:) + type(InOutput) :: xyz + + !Input + type(Dictionary) :: params_in + character(len=STRING_LENGTH) :: args_str + character(len=STRING_LENGTH) :: Run_Type + character(len=STRING_LENGTH) :: Print_PSF + character(len=STRING_LENGTH) :: coord_file + character(len=STRING_LENGTH) :: new_coord_file + character(len=STRING_LENGTH) :: cp2k_program + character(len=STRING_LENGTH) :: fileroot_str + character(len=STRING_LENGTH) :: basis_set_file, potential_file, dft_file, global_file, cell_file + logical :: clean_up_files +! logical :: Delete_Metal_Connections + type(Table) :: intrares_impropers +logical :: have_silica_potential +logical :: QM_list_changed +logical :: dummy +integer, pointer :: old_cluster_mark_p(:), cluster_mark_p(:) +integer :: i + real(dp),dimension(3) :: old_QM_cell +! call system_initialise(verbosity=PRINT_SILENT,enable_timing=.true.) + call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) + call system_timer('program') + + !read parameters + call initialise(params_in) + basis_set_file='' + cell_file='' + dft_file='' + global_file='' + call param_register(params_in, 'Run_Type', 'MM', Run_Type, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'PSF_Print', 'NO_PSF', Print_PSF, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'coord_file', 'filepot.0.xyz',coord_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'new_coord_file', 'filepot.0.out',new_coord_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'cp2k_program', 'cp2k_serial',cp2k_program, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'root', '', fileroot_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'basis_set_file', '', basis_set_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'potential_file', '', potential_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'dft_file', '', dft_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'global_file', '', global_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'cell_file', '', cell_file, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'clean_up_files', 'T', clean_up_files, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params_in, 'have_silica_potential', 'F', have_silica_potential, help_string="No help yet. This source file was $LastChangedBy$") +! call param_register(params_in, 'Delete_Metal_Connections', 'T', Delete_Metal_Connections, help_string="No help yet. This source file was $LastChangedBy$") + + if (.not.param_read_args(params_in,ignore_unknown=.true.,task='cp2k_filepot args_str')) then + call system_abort('could not parse argument line') + end if + + call finalise(params_in) + + !print parameters + call print('Run parameters:') + call print(' Run_Type '//trim(Run_Type)) + call print(' PSF_Print '//trim(Print_PSF)) + call print(' coord_file '//trim(coord_file)) + call print(' new_coord_file '//trim(new_coord_file)) + call print(' cp2k_program '//trim(cp2k_program)) + call print(' root '//trim(fileroot_str)) + call print(' basis_set_file '//trim(basis_set_file)) + call print(' potential_file '//trim(potential_file)) + call print(' dft_file '//trim(dft_file)) + call print(' global_file '//trim(global_file)) + call print(' cell_file '//trim(cell_file)) + call print(' have_silica_potential '//have_silica_potential) + call print('---------------------------------------') + call print('') + +! starts here + + call read_xyz(my_atoms,coord_file) + + !create connectivity & topology + if (have_silica_potential) then + call set_cutoff(my_atoms,SILICA_2body_CUTOFF) + else + call set_cutoff(my_atoms,0._dp) + endif + call calc_connect(my_atoms) +! if (Delete_Metal_Connections) call delete_metal_connects(my_atoms) + call map_into_cell(my_atoms) + call calc_dists(my_atoms) + if (trim(Run_Type).ne.'QS') then + call create_CHARMM(my_atoms,do_CHARMM=.true.,intrares_impropers=intrares_impropers) + endif + +if (trim(Run_Type).eq.'QMMM_CORE') call system_abort('not yet tested.') +if ((trim(Run_Type).eq.'QMMM_EXTENDED').or.& + (trim(Run_Type).eq.'QMMM_CORE')) then + if (.not.has_property(my_atoms, 'old_cluster_mark')) call system_abort('no old_cluster_mark') + if (.not.has_property(my_atoms, 'cluster_mark')) call system_abort('no cluster_mark') + + dummy = assign_pointer(my_atoms, 'old_cluster_mark', old_cluster_mark_p) + dummy = assign_pointer(my_atoms, 'cluster_mark', cluster_mark_p) + +QM_list_changed = .false. + do i=1,my_atoms%N + if (old_cluster_mark_p(i).ne.cluster_mark_p(i)) then + if (any((/old_cluster_mark_p(i),cluster_mark_p(i)/).eq.HYBRID_NO_MARK) .or. & + any((/old_cluster_mark_p(i),cluster_mark_p(i)/).eq.HYBRID_TERM_MARK) ) then + QM_list_changed = .true. + endif + endif + enddo + call set_value(my_atoms%params,'QM_list_changed',QM_list_changed) +call print('set_value QM_list_changed '//QM_list_changed) + +endif + !generate args_str for go_cp2k + write (args_str,'(a)') 'Run_Type='//trim(Run_Type)//' PSF_Print='//trim(Print_PSF) + if (trim(cp2k_program).ne.'') args_str = trim(args_str)//' cp2k_program='//trim(cp2k_program) + if (trim(fileroot_str).ne.'') args_str = trim(args_str)//' root='//trim(fileroot_str) + if (trim(basis_set_file).ne.'') args_str = trim(args_str)//' basis_set_file='//trim(basis_set_file) + if (trim(potential_file).ne.'') args_str = trim(args_str)//' potential_file='//trim(potential_file) + if (trim(dft_file).ne.'') args_str = trim(args_str)//' dft_file='//trim(dft_file) + if (trim(global_file).ne.'') args_str = trim(args_str)//' global_file='//trim(global_file) + if (trim(cell_file).ne.'') args_str = trim(args_str)//' cell_file='//trim(cell_file) + if (clean_up_files) then + args_str = trim(args_str)//' clean_up_files=T' + else + args_str = trim(args_str)//' clean_up_files=F' + endif + if (have_silica_potential) then + args_str = trim(args_str)//' have_silica_potential=T' + else + args_str = trim(args_str)//' have_silica_potential=F' + endif + + call print('FILEPOT |'//args_str,verbosity=PRINT_SILENT) + + !call CP2K + allocate(f0(3,my_atoms%N)) + call go_cp2k(my_atoms=my_atoms, forces=f0, energy=energy, args_str=args_str,intrares_impropers=intrares_impropers) + !momentum conservation + f0 = sum0(f0, my_atoms) + +if ((trim(Run_Type).eq.'QMMM_EXTENDED')) then + if (.not.get_value(my_atoms%params,'QM_cell',old_QM_cell)) call system_abort('Something has gone wrong. No QM_cell property found.') +endif + + !write energy and forces + call set_value(my_atoms%params,'energy',energy) + call add_property(my_atoms,'force', 0.0_dp, n_cols=3) + if (.not. assign_pointer(my_atoms, 'force', forces_p)) then + call system_abort("filepot_read_output needed forces, but couldn't find force in my_atoms ") + endif + forces_p = f0 + + call initialise(xyz,new_coord_file,action=OUTPUT) + call print_xyz(my_atoms,xyz,all_properties=.true.,real_format='f20.13') + call finalise(xyz) + + deallocate(f0) + call finalise(my_atoms) + call verbosity_push(PRINT_NORMAL) + call system_timer('FILEPOT |') + call verbosity_push(PRINT_SILENT) + call system_finalise + +contains + +! momentum conservation over all atoms, mass weighted + function sum0(force,at) result(force0) + + real(dp), dimension(:,:), intent(in) :: force + type(Atoms), intent(in) :: at + real(dp) :: force0(size(force,1),size(force,2)) + integer :: i + real(dp) :: sumF(3), sum_weight + + sumF = sum(force,2) + call print('Sum of the forces is '//sumF(1:3)) + + if ((sumF(1) .feq. 0.0_dp) .and. (sumF(2) .feq. 0.0_dp) .and. (sumF(3) .feq. 0.0_dp)) then + call print('Sum of the forces is zero.') + force0 = force + else + !F_corr weighted by element mass + sum_weight = sum(ElementMass(at%Z(1:at%N))) + + force0(1,:) = force(1,:) - sumF(1) * ElementMass(at%Z(:)) / sum_weight + force0(2,:) = force(2,:) - sumF(2) * ElementMass(at%Z(:)) / sum_weight + force0(3,:) = force(3,:) - sumF(3) * ElementMass(at%Z(:)) / sum_weight + endif + + sumF = sum(force0,2) + call print('Sum of the forces after mom.cons.: '//sumF(1:3)) + + end function sum0 + +end program cp2k_filepot diff --git a/src/FilePot_drivers/evb_driver.F90 b/src/FilePot_drivers/evb_driver.F90 new file mode 100644 index 0000000000..9f8de4481a --- /dev/null +++ b/src/FilePot_drivers/evb_driver.F90 @@ -0,0 +1,254 @@ +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! H0 X +! H0 X libAtoms+QUIP: atomistic simulation library +! H0 X +! H0 X Portions of this code were written by +! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, +! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. +! H0 X +! H0 X Copyright 2006-2010. +! H0 X +! H0 X These portions of the source code are released under the GNU General +! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html +! H0 X +! H0 X If you would like to license the source code under different terms, +! H0 X please contact Gabor Csanyi, gabor@csanyi.net +! H0 X +! H0 X Portions of this code were written by Noam Bernstein as part of +! H0 X his employment for the U.S. Government, and are not subject +! H0 X to copyright in the USA. +! H0 X +! H0 X +! H0 X When using this software, please cite the following reference: +! H0 X +! H0 X http://www.libatoms.org +! H0 X +! H0 X Additional contributions by +! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras +! H0 X +! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!X +!X EVB_filepot_template program +!X +!% filepot program for EVB energy and force calculation through CP2K +!X +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + +program EVB_filepot_template + + use libatoms_module + use potential_module + + implicit none + + type(Atoms) :: at1,at2 + real(dp), pointer :: at1_pos(:,:), at2_pos(:,:) + type(Potential) :: cp2k_fast_pot, pot + character(STRING_LENGTH) :: args_str + integer :: stat, error + real(dp) :: energy + real(dp), dimension(:,:), allocatable :: f1 + + !ARGS_STR INPUT PARAMETERS + type(Dictionary) :: cli_params + type(Dictionary) :: params + character(STRING_LENGTH) :: evb_params_line + character(STRING_LENGTH) :: posfilename + character(STRING_LENGTH) :: xyz_template_filename + character(STRING_LENGTH) :: outfilename + logical :: only_GAP + character(STRING_LENGTH) :: psf_file1 + character(STRING_LENGTH) :: psf_file2 + character(STRING_LENGTH) :: filepot_program + character(STRING_LENGTH) :: cp2k_calc_args + character(STRING_LENGTH) :: evb_params_filename + character(STRING_LENGTH) :: mm_args_str + character(STRING_LENGTH) :: topology_suffix1 + character(STRING_LENGTH) :: topology_suffix2 + integer :: form_bond(2), break_bond(2) + real(dp) :: diagonal_dE2, & + offdiagonal_A12, & + offdiagonal_mu12, & + offdiagonal_mu12_square, & + offdiagonal_r0 + logical :: save_forces, & + save_energy + type(Inoutput) :: evb_params_file + logical :: exists + character(len=STRING_LENGTH) :: filename + integer :: tmp_run_dir_i + + + call system_initialise(verbosity=PRINT_SILENT,enable_timing=.true.) + call verbosity_push(PRINT_NORMAL) + mainlog%prefix="EVB_FILEPOT" + call system_timer('evb_filepot_template') + + !INPUT PARAMETERS + call initialise(cli_params) + call param_register(cli_params,"pos","", posfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"xyz_template","", xyz_template_filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"out","", outfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"only_GAP","F", only_gap, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"psf_file1","", psf_file1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"psf_file2","", psf_file2, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"filepot_program","", filepot_program, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"cp2k_calc_args","", cp2k_calc_args, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(cli_params,"param_file","evb_params.dat", evb_params_filename, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_args(cli_params)) then + !call print("Usage: pos xyz_template out only_GAP param_file",PRINT_ALWAYS) + call system_abort('EVB_filepot: could not parse argument line') + endif + call finalise(cli_params) + + + !EVB params file with EVB parameters and with params that can overwrite the defaults + inquire(file=trim(evb_params_filename), exist=exists) + if (.not.exists) call system_abort("WARNING: no "//trim(evb_params_filename)//" file found.") + + call initialise(evb_params_file,trim(evb_params_filename),ACTION=INPUT) + evb_params_line=read_line(evb_params_file,stat) + if (len_trim(evb_params_line)>0) then + call initialise(params) + call param_register(params,"pos",""//trim(posfilename), posfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"xyz_template",""//trim(xyz_template_filename), xyz_template_filename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"out",""//trim(outfilename), outfilename, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"only_GAP",""//only_gap, only_gap, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"psf_file1",""//trim(psf_file1), psf_file1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"psf_file2",""//trim(psf_file2), psf_file2, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"filepot_program",""//trim(filepot_program), filepot_program, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params,"cp2k_calc_args",""//trim(cp2k_calc_args), cp2k_calc_args, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'mm_args_str', "", mm_args_str, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'topology_suffix1', "_EVB1", topology_suffix1, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'topology_suffix2', "_EVB2", topology_suffix2, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'form_bond', '0 0', form_bond, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'break_bond', '0 0', break_bond, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'diagonal_dE2', '0.0', diagonal_dE2, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'offdiagonal_A12', '0.0', offdiagonal_A12, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'offdiagonal_mu12', '0.0', offdiagonal_mu12, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'offdiagonal_mu12_square', '0.0', offdiagonal_mu12_square, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'offdiagonal_r0', '0.0', offdiagonal_r0, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'save_forces', "T", save_forces, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'save_energy', 'T', save_energy, help_string="No help yet. This source file was $LastChangedBy$") + call param_register(params, 'tmp_run_dir_i', '-1', tmp_run_dir_i, help_string="No help yet. This source file was $LastChangedBy$") + if (.not. param_read_line(params, evb_params_line, ignore_unknown=.true.,task='EVB_filepot_template args_str')) then + call system_abort('EVB_filepot_template failed to parse args_str="'//trim(evb_params_line)//'"') + endif + call finalise(params) + else + call system_abort("WARNING: file with EVB params "//trim(evb_params_filename)//" is empty. It must contain 1 only line with all the params.") + endif + evb_params_line=read_line(evb_params_file,stat) + if (stat==0 .and. len_trim(evb_params_line)>0) then + call system_abort("File with EVB params "//trim(evb_params_filename)//" has more than 1 lines and the second line is not empty. It must contain 1 only line with all the params.") + endif + call finalise(evb_params_file) + + + !remove old output file + call system_command("rm -f "//trim(outfilename),stat) + + + !read positions and template XYZ with lattice + if (len_trim(posfilename)==0) call system_abort("No posfilename given.") + inquire(file=trim(posfilename), exist=exists) + if (.not.exists) call system_abort("No "//trim(posfilename)//" file found.") + if (len_trim(xyz_template_filename)==0) call system_abort("No xyz_template_filename given.") + inquire(file=trim(xyz_template_filename), exist=exists) + if (.not.exists) call system_abort("No "//trim(xyz_template_filename)//" file found.") + !call print("Reading at1") + call read(at1,posfilename) + !call print("Reading at2") + call read(at2,xyz_template_filename) + + if (at1%N/=at2%N) call system_abort("EVB_filepot_template: at1 and at2 has different number of atoms.") + if (.not.assign_pointer(at1,"pos",at1_pos)) call system_abort("EVB_filepot_template: Could not find pos property in at1.") + if (.not.assign_pointer(at2,"pos",at2_pos)) call system_abort("EVB_filepot_template: Could not find pos property in at2.") + + at2_pos(1:3,1:at2%N) = at1_pos(1:3,1:at2%N) + + !possible i/o on /tmp + if (tmp_run_dir_i>0) then + filename="/tmp/cp2k_run_"//tmp_run_dir_i//"/filepot" + else + filename="filepot" + endif + + !call print("Writing filepot.0.xyz") + !!call write(at2,"filepot.0.xyz", properties="species:pos:mol_id:atom_res_number",real_format='f17.10',error=error) + !call write(at2,trim(filename)//".0.xyz", properties="species:pos",real_format='%17.10f',error=error) + !HANDLE_ERROR(error) + call finalise(at1) + + + !call print("Initialise potentials") + !setup EVB potential (pot and args_str) + if (len_trim(filepot_program)==0) call system_abort("EVB_filepot_template: Filepot not given.") + !!call initialise(cp2k_fast_pot,'FilePot command='//trim(filepot_program)//' property_list=species:pos:avgpos:mol_id:atom_res_number min_cutoff=0.0') + call initialise(cp2k_fast_pot,'FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos min_cutoff=0.0') + + args_str="" + !if (len_trim(cp2k_calc_args)==0) call print("WARNING: EVB_filepot_template: cp2k_calc_args not given.",PRINT_ALWAYS) + if (len_trim(cp2k_calc_args)>0) mm_args_str=trim(mm_args_str)//" "//trim(cp2k_calc_args) + if (len_trim(mm_args_str)>0) & + args_str=trim(args_str)//" mm_args_str="//'"'//trim(mm_args_str)//'"' + if (len_trim(topology_suffix1)>0) & + args_str=trim(args_str)//" topology_suffix1="//trim(topology_suffix1) + if (len_trim(topology_suffix2)>0) & + args_str=trim(args_str)//" topology_suffix2="//trim(topology_suffix2) + if (any(form_bond/=0)) & + args_str=trim(args_str)//' form_bond={'//form_bond//'}' + if (any(break_bond/=0)) & + args_str=trim(args_str)//' break_bond={'//break_bond//'}' + if (.not.(diagonal_dE2.feq.0.0_dp)) & + args_str=trim(args_str)//" diagonal_dE2="//diagonal_dE2 + if (.not.(offdiagonal_A12.feq.0.0_dp)) & + args_str=trim(args_str)//" offdiagonal_A12="//offdiagonal_A12 + if (.not.(offdiagonal_mu12.feq.0.0_dp)) & + args_str=trim(args_str)//" offdiagonal_mu12="//offdiagonal_mu12 + if (.not.(offdiagonal_mu12_square.feq.0.0_dp)) & + args_str=trim(args_str)//" offdiagonal_mu12_square="//offdiagonal_mu12_square + if (.not.(offdiagonal_r0.feq.0.0_dp)) & + args_str=trim(args_str)//" offdiagonal_r0="//offdiagonal_r0 + args_str=trim(args_str)//" save_forces="//save_forces + args_str=trim(args_str)//" save_energy="//save_energy + + call initialise(pot,args_str='EVB=T '//trim(args_str), & + pot1=cp2k_fast_pot) + !call print(pot) + + + !copy psf files if needed + if (len_trim(psf_file1)>0) then + !call print("cp "//trim(psf_file1)//" quip_cp2k"//trim(topology_suffix1)//".psf") + call system_command("cp "//trim(psf_file1)//" quip_cp2k"//trim(topology_suffix1)//".psf") + endif + if (len_trim(psf_file2)>0) then + !call print("cp "//trim(psf_file2)//" quip_cp2k"//trim(topology_suffix2)//".psf") + call system_command("cp "//trim(psf_file2)//" quip_cp2k"//trim(topology_suffix2)//".psf") + endif + + + !call print("Calculate energy and forces") + !calc E and F with EVB potential + allocate(f1(3,at2%N)) + call calc(pot,at2,energy=energy,force=f1,args_str=" EVB_gap=gap calc_force=forces calc_energy=energy") + deallocate(f1) + + + !call print("Write output") + if (only_GAP) then + call write(at2,filename=trim(outfilename),properties="gap_force") + else + call write(at2,filename=trim(outfilename)) + endif + call finalise(at2) + + + call system_timer('evb_filepot_template') + call system_finalise + +end program EVB_filepot_template diff --git a/src/FilePot_drivers/vasp_driver.F90 b/src/FilePot_drivers/vasp_driver.F90 new file mode 100644 index 0000000000..b07d6da0eb --- /dev/null +++ b/src/FilePot_drivers/vasp_driver.F90 @@ -0,0 +1,744 @@ +#include "error.inc" +program vasp_driver +use libatoms_module +implicit none + + type(Atoms) :: at + + character(len=STRING_LENGTH) :: infile, outfile + character(len=STRING_LENGTH) :: args_str + character(len=STRING_LENGTH) :: arg + integer :: i, index_insert + type(CInOutput) :: outfile_io + + integer :: error, stat_vals(13) + + call system_initialise(verbosity=PRINT_SILENT, enable_timing=.true.) + call verbosity_push(PRINT_NORMAL) + call system_timer('vasp_filepot') + + if (cmd_arg_count() < 2) then + call system_abort("Usage: vasp_filepot infile outfile [ other_cli_arg1=v1 other_cli_arg2=v2 ...]") + endif + + call get_cmd_arg(1, infile) + call get_cmd_arg(2, outfile) + + args_str = "" + if (cmd_arg_count() > 2) then + do i=3, cmd_arg_count() + call get_cmd_arg(i, arg) + !add {} if there is space in the arg + if (index(trim(arg)," ").ne.0) then + index_insert = index(trim(arg),"=") + arg(index_insert+1:len_trim(arg)+2) = "{"//arg(index_insert+1:len_trim(arg))//"}" + call print('arg: '//trim(arg),PRINT_SILENT) + endif + args_str = trim(args_str) // " " // trim(arg) + end do + endif + + call read(at,infile) + + call print('vasp_filepot args_str '//trim(args_str), PRINT_ALWAYS) + + call do_vasp_calc(at, trim(args_str), error) + HANDLE_ERROR(error) + + call initialise(outfile_io,outfile,action=OUTPUT) + call write(at, outfile_io, real_format='%20.13f') + call finalise(outfile_io) + + call finalise(at) + + call system_timer('vasp_filepot') + mainlog%prefix="" + call verbosity_push(PRINT_SILENT) + call system_finalise() + +contains + +subroutine do_vasp_calc(at, args_str, error) + type(Atoms), intent(inout) :: at + character(len=*), intent(in) :: args_str + integer, intent(out), optional :: error + + character(len=STRING_LENGTH) :: incar_template_file, kpoints_file, potcar_files, vasp_path, run_suffix, verbosity_str + character(len=STRING_LENGTH) :: calc_energy, calc_force, calc_virial, calc_local_energy + logical :: do_calc_energy, do_calc_force, do_calc_virial, do_calc_local_energy, persistent, persistent_n_atoms_exist + logical :: clean_up_files, ignore_convergence, no_use_WAVECAR, force_constant_basis + integer :: clean_up_keep_n + integer :: persistent_restart_interval, persistent_n_atoms + real(dp) :: persistent_max_wait_time + type(Dictionary) :: incar_dict, cli + + integer :: persistent_run_i + logical :: persistent_already_started = .false. + type(inoutput) :: persistent_io + + integer :: run_dir_i, force_run_dir_i + + integer :: i_charge + real(dp) :: nelect, nelect_of_elem(size(ElementName)), r_charge + real(dp), pointer :: magmom_p(:) + + character(len=STRING_LENGTH) :: run_dir + type(Inoutput) :: io + + integer :: at_i, stat + integer, pointer :: sort_index_p(:) + logical :: converged, have_wavecar + + INIT_ERROR(error) + + call initialise(cli) + call param_register(cli, "verbosity", "NORMAL", verbosity_str, help_string="verbosity level") + call param_register(cli, "INCAR_template", "INCAR.template", incar_template_file, help_string="name of file with template for main input (INCAR) file") + call param_register(cli, "kpoints_file", "KPOINTS", kpoints_file, help_string="name of k-points file (KPOINTS)") + call param_register(cli, "potcar_files", PARAM_MANDATORY, potcar_files, help_string="mapping from atomic numbers to POTCAR files, Z_1 POTCAR_FILE_1 [ Z_2 POTCAR_FILE_2 ... ]") + call param_register(cli, "vasp", PARAM_MANDATORY, vasp_path, help_string="vasp executable") + call param_register(cli, "energy", "", calc_energy, help_string="if set, calculate energy and put it in parameter named this") + call param_register(cli, "force", "", calc_force, help_string="if set, calculate forces and put them in property named this") + call param_register(cli, "virial", "", calc_virial, help_string="if set, calculate virial and put it in parameter named this") + call param_register(cli, "local_energy", "", calc_local_energy, help_string="not supported") + call param_register(cli, "clean_up_files", "T", clean_up_files, help_string="if true, delete run directory when done") + call param_register(cli, "clean_up_keep_n", "1", clean_up_keep_n, help_string="if cleaning up, keep this many directories around") + call param_register(cli, "ignore_convergence", "F", ignore_convergence, help_string="If true, accept result even if failed to converge SCF") + call param_register(cli, "no_use_WAVECAR", "F", no_use_WAVECAR, help_string="If true, don't reuse previous wavefunction file WAVECAR") + call param_register(cli, "force_constant_basis", "F", force_constant_basis, help_string="If true, do a restart with the same basis") + call param_register(cli, "run_suffix", "run", run_suffix, help_string="suffix to label persistent state from run to run") + call param_register(cli, "persistent", "F", persistent, help_string="If true, use persistent connection to a long-running vasp process") + call param_register(cli, "persistent_restart_interval", "100", persistent_restart_interval, help_string="If persistent, restart vasp this often") + call param_register(cli, "persistent_max_wait_time", "600", persistent_max_wait_time, help_string="If persistent, never wait more than this long (s) for calculation to finish") + if (.not. param_read_line(cli, args_str, ignore_unknown=.true.,task='do_vasp_calc args_str')) then + call print("Args: verbosity INCAR_template kpoints_file potcar_files vasp energy force", PRINT_ALWAYS) + call print(" virial local_energy clean_up_files ignore_convergence no_use_WAVECAR", PRINT_ALWAYS) + call print(" force_constant_basis run_suffix", PRINT_ALWAYS) + RAISE_ERROR('do_vasp_calc failed to parse args_str="'//trim(args_str)//'"', error) + endif + call finalise(cli) + + call verbosity_push(verbosity_of_str(trim(verbosity_str))) + + do_calc_energy = len_trim(calc_energy) > 0 + do_calc_force = len_trim(calc_force) > 0 + do_calc_virial = len_trim(calc_virial) > 0 + do_calc_local_energy = len_trim(calc_local_energy) > 0 + + call print("do_vasp_calc using args:", PRINT_VERBOSE) + call print(" INCAR_template " // trim(INCAR_template_file), PRINT_VERBOSE) + call print(" kpoints_file " // trim(kpoints_file), PRINT_VERBOSE) + call print(" potcar_files " // trim(potcar_files), PRINT_VERBOSE) + call print(" vasp " // trim(vasp_path), PRINT_VERBOSE) + call print(" energy " // do_calc_energy, PRINT_VERBOSE) + call print(" force " // do_calc_force, PRINT_VERBOSE) + call print(" virial " // do_calc_virial, PRINT_VERBOSE) + call print(" local_energy " // do_calc_local_energy, PRINT_VERBOSE) + call print(" clean_up_files " // clean_up_files, PRINT_VERBOSE) + call print(" clean_up_keep_n " // clean_up_keep_n, PRINT_VERBOSE) + call print(" ignore_convergence " // ignore_convergence, PRINT_VERBOSE) + call print(" no_use_WAVECAR " // no_use_WAVECAR, PRINT_VERBOSE) + call print(" force_constant_basis " // force_constant_basis, PRINT_VERBOSE) + call print(" run_suffix " // run_suffix, PRINT_VERBOSE) + call print(" persistent " // persistent, PRINT_VERBOSE) + if (persistent) then + call print(" persistent_restart_interval " // persistent_restart_interval, PRINT_VERBOSE) + call print(" persistent_max_wait_time " // persistent_max_wait_time, PRINT_VERBOSE) + endif + + call system_timer('vasp_filepot/prep') + ! check for local energy + if (do_calc_local_energy) then + RAISE_ERROR("do_vasp_calc can't do local_energy", error) + endif + + call print("reading template", PRINT_VERBOSE) + ! read the template incar + call read_vasp_incar_dict(incar_dict, trim(incar_template_file), error) + PASS_ERROR(error) + + call print("setting INCAR dictionary parameters", PRINT_VERBOSE) + ! check for stress, set ISIF + if (.not. do_calc_energy .and. .not. do_calc_force .and. .not. do_calc_virial) then + return + else if (.not. do_calc_virial) then + call set_value(incar_dict, "ISIF", 0) + else + if (persistent) then + call set_value(incar_dict, "ISIF", 3) + else + call set_value(incar_dict, "ISIF", 2) + endif + endif + + ! remove EDIFFG to avoid VASP quitting when it thinks convergence has been reached + if (has_key(incar_dict,"EDIFFG")) call remove_value(incar_dict,"EDIFFG") + + force_run_dir_i = -1 + if (persistent) then ! make run_dir manually + inquire(file="persistent_run_i", exist=persistent_already_started) + run_dir = "vasp_run_0" + force_run_dir_i = 0 + if (.not. persistent_already_started) then + call system_command("mkdir "//trim(run_dir)) + call initialise(persistent_io, "persistent_run_i", action=OUTPUT) + call print("-1", file=persistent_io) + call finalise(persistent_io) + endif + + inquire(file="persistent_n_atoms", exist=persistent_n_atoms_exist) + if (persistent_n_atoms_exist) then + call initialise(persistent_io, "persistent_n_atoms", action=INPUT) + line = read_line(persistent_io) + read (unit=line, fmt=*, iostat=stat) persistent_n_atoms + call finalise(persistent_io) + else + persistent_n_atoms = 0 + end if + call print('got old persistent_n_atoms = '//persistent_n_atoms, PRINT_VERBOSE) + call print('writing new persistent_n_atoms = '//at%n, PRINT_VERBOSE) + call initialise(persistent_io, "persistent_n_atoms", action=OUTPUT) + call print(at%n, file=persistent_io) + call finalise(persistent_io) + endif + run_dir = make_run_directory("vasp_run", force_run_dir_i, run_dir_i) + + if (persistent) then + ! set dynamics to REFTRAJ, number of ionic steps to 1000000 + call set_value(incar_dict, "NSW", 1000000) + call set_value(incar_dict, "IBRION", 12) + else + ! set dynamics to MD, number of ionic steps to 0 + call set_value(incar_dict, "NSW", 0) + call set_value(incar_dict, "IBRION", 0) + endif + if (no_use_WAVECAR) then + call set_value(incar_dict, "ISTART", 0) + else + inquire(file="WAVECAR."//trim(run_suffix), exist=have_wavecar) + if (have_wavecar) then + call print("copying old WAVECAR.run_suffix to run_dir/WAVECAR", PRINT_VERBOSE) + call system_command("cp WAVECAR."//trim(run_suffix)//" "//trim(run_dir)//"/WAVECAR", status=stat) + if (stat /= 0) then + RAISE_ERROR("do_vasp_calc copying file WAVECAR."//trim(run_suffix)//" into "//trim(run_dir), error) + endif + endif + if (force_constant_basis) then + ! 3 is faster, but not tested + call set_value(incar_dict, "ISTART", 2) + else + call set_value(incar_dict, "ISTART", 1) + endif + endif + + call print("doing sorting", PRINT_VERBOSE) + call add_property(at, "sort_index", 0, n_cols=1, ptr=sort_index_p, error=error) + PASS_ERROR(error) + do at_i=1, at%N + sort_index_p(at_i) = at_i + end do + call atoms_sort(at, 'Z', error=error) + PASS_ERROR(error) + + if (persistent) then + call print("reading persistent_run_i", PRINT_VERBOSE) + call initialise(persistent_io, "persistent_run_i", action=INPUT) + line = read_line(persistent_io) + read (unit=line, fmt=*, iostat=stat) persistent_run_i + call finalise(persistent_io) + call print("got persistent_run_i="//persistent_run_i, PRINT_VERBOSE) + persistent_run_i = persistent_run_i + 1 + call initialise(persistent_io, "persistent_run_i", action=OUTPUT) + call print(persistent_run_i, file=persistent_io) + call finalise(persistent_io) + endif + + if (.not. persistent_already_started) then + call print("writing POTCAR", PRINT_VERBOSE) + call write_vasp_potcar(at, trim(run_dir), trim(potcar_files), nelect_of_elem, error=error) + PASS_ERROR(error) + endif + + ! total number of electrons for each element from POTCAR files + nelect = sum(nelect_of_elem(at%Z)) + ! get Charge from xyz file + r_charge = 0.0_dp + if (get_value(at%params, 'Charge', r_charge)) then + nelect = nelect - r_charge + else if (get_value(at%params, 'Charge', i_charge)) then + r_charge = i_charge + nelect = nelect - i_charge + endif + if (r_charge .fne. 0.0_dp) then ! set total number of electrons + call set_value(incar_dict, "NELECT", nelect) + endif + + if (assign_pointer(at, "magmom", magmom_p)) then + call set_value(incar_dict, "MAGMOM", magmom_p) + endif + + if (.not. persistent_already_started) then + ! write INCAR + call print("writing INCAR", PRINT_VERBOSE) + call initialise(io, trim(run_dir)//"/INCAR", action=OUTPUT, error=error) + PASS_ERROR(error) + call print(write_string(incar_dict, entry_sep=quip_new_line, quote_char=' '), file=io) + call finalise(io) + + ! write KPOINTS if needed + if (trim(kpoints_file) /= "_NONE_") then + call print("writing KPOINTS", PRINT_VERBOSE) + call system_command("cp "//trim(kpoints_file)//" "//trim(run_dir)//"/KPOINTS", status=stat) + if (stat /= 0) then + RAISE_ERROR("do_vasp_calc copying kpoints_file "//trim(kpoints_file)//" into "//trim(run_dir), error) + endif + endif + endif + + if (.not. persistent_already_started .or. mod(persistent_run_i, persistent_restart_interval) == 0 .or. at%n /= persistent_n_atoms) then + call print("writing POSCAR", PRINT_VERBOSE) + call write_vasp_poscar(at, trim(run_dir), error=error) + PASS_ERROR(error) + endif + call system_timer('vasp_filepot/prep') + + if (persistent) then ! restart VASP if needed, write to REFTRAJCAR if needed, initiate calc + call system_timer('vasp_filepot/start_restart') + if (mod(persistent_run_i, persistent_restart_interval) == 0 .or. at%n /= persistent_n_atoms) then ! start or restart VASP + call print("starting or restarting VASP", PRINT_VERBOSE) + if (persistent_already_started) then ! tell currently running vasp to quit + call initialise(persistent_io, trim(run_dir)//"/REFTRAJCAR", action=OUTPUT) + call print("0", file=persistent_io) + call finalise(persistent_io) + call initialise(persistent_io, trim(run_dir)//"/REFTRAJ_READY", action=OUTPUT) + call print("-", file=persistent_io) + call finalise(persistent_io) + ! wait for signal that it's finished + call system_command("echo 'before wait'; ps auxw | egrep 'vasp|mpi'") + call wait_for_file_to_exist(trim(run_dir)//"/vasp.done", max_wait_time=600.0_dp, error=error) + call system_command("echo 'after wait'; ls -l "//trim(run_dir)) + call system_command("echo 'after wait'; ps auxw | egrep 'vasp|mpi'") + PASS_ERROR(error) + ! clean up + call unlink(trim(run_dir)//"/vasp.done") + call system_command("cd "//trim(run_dir)//"; rm -f REFTRAJCAR REFTRAJ_READY OUTCAR CONTCAR OSZICAR") + call system_command("cat vasp.stdout."//run_dir_i//" >> vasp.stdout") + endif + ! start vasp in background + call print("cd "//trim(run_dir)//"; bash -c "//'"'//"("//'\"'//trim(vasp_path)//'\"'//" > ../vasp.stdout."//run_dir_i//"; echo done > vasp.done )"//'"'//" 2>&1 &") + call system_command("cd "//trim(run_dir)//"; bash -c "//'"'//"("//'\"'//trim(vasp_path)//'\"'//" > ../vasp.stdout."//run_dir_i//"; echo done > vasp.done )"//'"'//" 2>&1 &", status=stat) + if (stat /= 0) then + RAISE_ERROR("error running "//trim(vasp_path)//", status="//stat, error) + endif + persistent_already_started = .true. + endif + call system_timer('vasp_filepot/start_restart') + call system_timer('vasp_filepot/write_reftrajcar') + if (mod(persistent_run_i,persistent_restart_interval) /= 0 .and. at%n == persistent_n_atoms) then ! need to write current coords to REFTRAJCAR + call print("writing current coords to REFTRAJCAR", PRINT_VERBOSE) + call initialise(persistent_io, trim(run_dir)//"/REFTRAJCAR", action=OUTPUT) + call print(at%N, file=persistent_io) + call fix_lattice(at) + call print(at%lattice(1,:), file=persistent_io) + call print(at%lattice(2,:), file=persistent_io) + call print(at%lattice(3,:), file=persistent_io) + do i=1, at%N + call print(matmul(at%g, at%pos(:,i)), file=persistent_io) + end do + call finalise(persistent_io) + call print("touching REFTRAJ_READY", PRINT_VERBOSE) + call initialise(persistent_io, trim(run_dir)//"/REFTRAJ_READY", action=OUTPUT) + call print("-", file=persistent_io) + call finalise(persistent_io) + endif + call system_timer('vasp_filepot/write_reftrajcar') + call system_timer('vasp_filepot/wait_reftraj_step_done') + call print("waiting for output REFTRAJ_STEP_DONE", PRINT_VERBOSE) + ! wait for output to be ready + call wait_for_file_to_exist(trim(run_dir)//"/REFTRAJ_STEP_DONE", persistent_max_wait_time, cycle_time=0.1_dp, error=error) + PASS_ERROR(error) + call system_timer('vasp_filepot/wait_reftraj_step_done') + else ! not persistent, just run vasp + call system_timer('vasp_filepot/run_vasp') + call print("running vasp", PRINT_VERBOSE) + call print("cd "//trim(run_dir)//"; bash -c "//'"'//trim(vasp_path)//'"'//" > ../vasp.stdout."//run_dir_i//" 2>&1") + call system_command("cd "//trim(run_dir)//"; bash -c "//'"'//trim(vasp_path)//'"'//" > ../vasp.stdout."//run_dir_i//" 2>&1", status=stat) + if (stat /= 0) then + RAISE_ERROR("error running "//trim(vasp_path)//", status="//stat, error) + endif + call system_command("cat vasp.stdout."//run_dir_i//" >> vasp.stdout") + call system_timer('vasp_filepot/run_vasp') + endif + + ! look for errors in stdout and runtime in OUTCAR + call system_command("fgrep -i 'error' vasp.stdout."//run_dir_i) + call system_command("fgrep -i 'total cpu time used' "//trim(run_dir)//"/OUTCAR | tail -1; fgrep -c 'LOOP:' "//trim(run_dir)//"/OUTCAR | tail -1") + + call system_timer('vasp_filepot/read_output') + if (persistent) then ! read REFTRAJ output + call print("reading output REFTRAJ_OUTPUT", PRINT_VERBOSE) + ! read output + call read_vasp_output_persistent(at, run_dir, do_calc_energy, do_calc_force, do_calc_virial, error) + PASS_ERROR(error) + converged = .true. ! should really find a way of telling if converged for persistent connections + ! clean up + call unlink(trim(run_dir)//"/REFTRAJ_OUTPUT") + call unlink(trim(run_dir)//"/REFTRAJ_STEP_DONE") + else ! read regular VASP output (OUTCAR) + call print("reading vasp output", PRINT_VERBOSE) + call read_vasp_output(trim(run_dir), do_calc_energy, do_calc_force, do_calc_virial, converged, error=error) + PASS_ERROR(error) + endif + call system_timer('vasp_filepot/read_output') + + call system_timer('vasp_filepot/end') + if (.not. converged) then + call print("WARNING: failed to find sign of convergence in OUTCAR", verbosity=PRINT_ALWAYS) + if (.not. ignore_convergence) then + RAISE_ERROR("failed to find sign of convergence in OUTCAR", error) + endif + endif + + inquire(file=trim(run_dir)//"/WAVECAR", exist=have_wavecar) + if (have_wavecar) then + call print("copying run_dir/WAVECAR to WAVECAR.run_suffix", PRINT_VERBOSE) + call system_command("cp "//trim(run_dir)//"/WAVECAR WAVECAR."//trim(run_suffix), status=stat) + if (stat /= 0) then + RAISE_ERROR("do_vasp_calc copying file "//trim(run_dir)//"WAVECAR into ./"//trim(run_dir)//"WAVECAR."//trim(run_suffix), error) + endif + endif + + call print("doing unsorting", PRINT_VERBOSE) + call atoms_sort(at, 'sort_index', error=error) + PASS_ERROR(error) + + if (clean_up_files .and. .not. persistent) then + call print("cleaning up", PRINT_VERBOSE) + call system_command("rm -rf vasp_run_"//(1+mod(run_dir_i,clean_up_keep_n+1))) + endif + + call system_timer('vasp_filepot/end') + + call verbosity_pop() + +end subroutine do_vasp_calc + +subroutine write_vasp_potcar(at, run_dir, potcar_files, nelect_of_elem, error) + type(Atoms), intent(in) :: at + character(len=*), intent(in) :: run_dir, potcar_files + real(dp), intent(out) :: nelect_of_elem(:) + integer, intent(out), optional :: error + + integer :: i, Z_i, potcar_files_n_fields + character(len=STRING_LENGTH) :: potcar_files_fields(128), potcar_files_a(128) + integer, allocatable :: uniq_Z(:) + + integer :: stat, t_Z + real(dp) :: t_nelect + character(len=STRING_LENGTH) :: line + type(inoutput) :: io + + INIT_ERROR(error) + + call split_string_simple(trim(potcar_files), potcar_files_fields, potcar_files_n_fields, " ", error) + PASS_ERROR(error) + + if (potcar_files_n_fields <= 0 .or. mod(potcar_files_n_fields,2) /= 0) then + RAISE_ERROR("write_vasp_potcar didn't find even number of fields (Z1 potcar1 [Z2 potcar2 ...]) in potcar_files='"//trim(potcar_files)//"'", error) + endif + + call uniq(at%Z, uniq_Z) + + potcar_files_a="" + do i=1, potcar_files_n_fields, 2 + read(unit=potcar_files_fields(i),fmt=*) Z_i + potcar_files_a(Z_i) = trim(potcar_files_fields(i+1)) + end do + + call system_command("rm -f nelect_summary; touch nelect_summary") + call system_command("rm -f "//trim(run_dir)//"/POTCAR") + do Z_i=1, size(uniq_Z) + if (uniq_Z(Z_i) == 0) exit + if (len_trim(potcar_files_a(uniq_Z(Z_i))) == 0) then + RAISE_ERROR("write_vasp_potcar could not find a potcar for Z="//uniq_Z(Z_i), error) + endif + call system_command("cat "//trim(potcar_files_a(uniq_Z(Z_i)))//" >> "//trim(run_dir)//"/POTCAR") + call system_command("(echo -n '"//uniq_Z(Z_i)//" '; cat "//trim(potcar_files_a(uniq_Z(Z_i)))//" | fgrep ZVAL | sed -e 's/.*ZVAL[ ]*=[ ]*//' -e 's/ .*//') >> nelect_summary") + end do + + ! read back nelect_summary + call initialise(io, "nelect_summary") + do Z_i=1, size(uniq_Z) + line = read_line(io, stat) + read (unit=line, fmt=*) t_Z, t_nelect + if (t_Z <= 0 .or. t_Z > size(nelect_of_elem)) then + RAISE_ERROR("write_vasp_potcar got value out of range reading nelect_summary value t_Z="//t_Z, error) + endif + if (t_Z /= uniq_Z(Z_i)) then + RAISE_ERROR("write_vasp_potcar got mismatch reading nelect_summary value t_Z="//t_Z//" uniq_Z("//Z_i//")="//uniq_Z(Z_i), error) + endif + nelect_of_elem(t_Z) = t_nelect + end do + call finalise(io) + +end subroutine write_vasp_potcar + +subroutine write_vasp_poscar(at, run_dir, error) + type(Atoms), intent(inout) :: at + character(len=*), intent(in) :: run_dir + integer, intent(out), optional :: error + + integer, allocatable :: uniq_Z(:), n_Z(:) + integer :: i + logical :: swapped_a1_a2 + + type(inoutput) :: io + + INIT_ERROR(error) + + call fix_lattice(at, swapped_a1_a2) + + call initialise(io, trim(run_dir)//"/POSCAR",action=OUTPUT) + if (swapped_a1_a2) then + call print("QUIP VASP run "//trim(run_dir)//" swapped a1 and a2", file=io) + else + call print("QUIP VASP run "//trim(run_dir), file=io) + endif + call print("1.00 ! scale factor", file=io) + + call print(at%lattice(:,1), file=io) + call print(at%lattice(:,2), file=io) + call print(at%lattice(:,3), file=io) + + call uniq(at%Z, uniq_Z) + allocate(n_Z(size(uniq_Z))) + do i=1, size(uniq_Z) + n_Z(i) = count(at%Z == uniq_Z(i)) + call print(" " // trim(ElementName(uniq_Z(i))), file=io, nocr=.true.) + end do + call print("", file=io) + call print(""//n_Z//" ! Zs = "//uniq_Z, file=io) + call print("Selective Dynamics", file=io) + call print("Cartesian", file=io) + do i=1, at%N + call print(at%pos(:,i)//" T T T", file=io) + end do + call finalise(io) + +end subroutine write_vasp_poscar + +subroutine fix_lattice(at, swapped_a1_a2) + type(Atoms), intent(inout) :: at + logical, intent(out), optional :: swapped_a1_a2 + + real(dp) :: vol, lattice(3,3) + + if (present(swapped_a1_a2)) swapped_a1_a2 = .false. + + vol = scalar_triple_product(at%lattice(:,1), at%lattice(:,2), at%lattice(:,3)) + if (vol < 0.0_dp) then + if (present(swapped_a1_a2)) swapped_a1_a2 = .true. + lattice(:,1) = at%lattice(:,2) + lattice(:,2) = at%lattice(:,1) + lattice(:,3) = at%lattice(:,3) + call set_lattice(at, lattice, .false.) + endif + +end subroutine fix_lattice + +subroutine read_vasp_output(run_dir, do_calc_energy, do_calc_force, do_calc_virial, converged, error) + character(len=*), intent(in) :: run_dir + logical, intent(in) :: do_calc_energy, do_calc_force, do_calc_virial + logical, intent(out) :: converged + integer, intent(out), optional :: ERROR + + type(inoutput) :: outcar_io + integer :: stat + character(len=STRING_LENGTH) :: line + character(len=STRING_LENGTH) :: fields(100), t_s + integer :: n_fields, line_i + logical in_virial + + real(dp) :: energy, virial(3,3), t_pos(3) + real(dp), pointer :: force_p(:,:) + integer :: force_start_line_i, virial_start_line_i, read_err + + INIT_ERROR(error) + + if (do_calc_force) then + if (.not. assign_pointer(at, "force", force_p)) then + call add_property(at, "force", 0.0_dp, n_cols=3, ptr2=force_p, error=error) + PASS_ERROR(error) + endif + endif + + converged = .false. + force_start_line_i = -1 + in_virial = .false. + call initialise(outcar_io, trim(run_dir)//"/OUTCAR") + stat = 0 + line_i = 1 + do while (stat == 0) + line = read_line(outcar_io, stat) + if (do_calc_energy) then + if (index(trim(line),"free energy") > 0) then ! found energy + call split_string_simple(trim(line), fields, n_fields, " ", error=error) + PASS_ERROR(error) + if (n_fields /= 6) then + RAISE_ERROR("read_vasp_output confused by energy line# "//line_i//" in OUTCAR line '"//trim(line)//"'", error) + endif + if (fields(6) /= "eV") then + RAISE_ERROR("read_vasp_output confused by units energy line# "//line_i//" in OUTCAR line '"//trim(line)//"'", error) + endif + read(unit=fields(5),fmt=*) energy + call set_param_value(at, 'energy', energy) + endif + endif + if (do_calc_force) then + if (force_start_line_i > 0 .and. line_i >= force_start_line_i .and. line_i <= force_start_line_i+at%N-1) then + read(unit=line,fmt=*) t_pos, force_p(:,line_i-force_start_line_i+1) + else + if (index(trim(line),"TOTAL-FORCE") > 0) then ! found force + call split_string_simple(trim(line), fields, n_fields, " ", error=error) + if (fields(3) /= "(eV/Angst)") then + RAISE_ERROR("read_vasp_output confused by units force header line# "//line_i//" in OUTCAR line '"//trim(line)//"'", error) + endif + force_start_line_i = line_i+2 + endif + endif + endif + if (do_calc_virial) then + if (in_virial .and. index(trim(line),"Total") > 0) then + read(unit=line,fmt=*,iostat=read_err) t_s, virial(1,1), virial(2,2), virial(3,3), virial(1,2), virial(2,3), virial(1,3) + if (read_err /= 0) then + RAISE_ERROR ("read_vasp_output failed to read virial from line '"//trim(line)//"'", error) + endif + virial(2,1) = virial(1,2) + virial(3,2) = virial(2,3) + virial(3,1) = virial(1,3) + call set_param_value(at, 'virial', virial) + in_virial = .false. + else + if (index(trim(line),"FORCE on cell") > 0) then ! found start of virial section + call split_string_simple(trim(line), fields, n_fields, " ", error=error) + if (fields(9) /= "(eV):" .and. fields(9) /= "(eV/reduce") then + RAISE_ERROR("read_vasp_output confused by units virial header line# "//line_i//" in OUTCAR line '"//trim(line)//"'", error) + endif + in_virial = .true. + endif + endif + endif + if (.not. converged) then + if (index(trim(line),"aborting loop because EDIFF is reached") > 0) then ! found convergence of SCF + converged = .true. + endif + endif + ! if (stat == 0) call print("GOT OUTPUT "//trim(line)) + line_i = line_i + 1 + end do + call finalise(outcar_io) + +end subroutine read_vasp_output + +subroutine read_vasp_output_persistent(at, run_dir, do_calc_energy, do_calc_force, do_calc_virial, error) + type(atoms), intent(inout) :: at + character(len=*), intent(in) :: run_dir + logical, intent(in) :: do_calc_energy, do_calc_force, do_calc_virial + integer, optional, intent(out) :: error + + real(dp) :: energy, virial(3,3), force_t(3) + real(dp), pointer :: force_p(:,:) + type(inoutput) :: reftraj_output_io + character(len=STRING_LENGTH) :: line + integer :: ni + + INIT_ERROR(error) + + if (do_calc_force) then + if (.not. assign_pointer(at, "force", force_p)) then + call add_property(at, "force", 0.0_dp, n_cols=3, ptr2=force_p, error=error) + PASS_ERROR(error) + endif + endif + + call initialise(reftraj_output_io, trim(run_dir)//"/REFTRAJ_OUTPUT", action=INPUT) + + line = read_line(reftraj_output_io); read(unit=line, fmt=*) ni + if (ni /= at%N) then + RAISE_ERROR("read_vasp_output_persistent got NI == "//ni//" != at%N == "//at%N, error) + endif + + ! read energy + line = read_line(reftraj_output_io); read(unit=line, fmt=*) energy + if (do_calc_energy) call set_param_value(at, 'energy', energy) + ! read force + do i=1, at%N + line = read_line(reftraj_output_io); read(unit=line, fmt=*) force_t + if (do_calc_force) force_p(:,i) = force_t(:) + end do + ! read virial + if (do_calc_virial) then + line = read_line(reftraj_output_io); read(unit=line, fmt=*) virial(1,1), virial(2,2), virial(3,3), virial(1,2), virial(2,3), virial(3,1) + virial(2,1) = virial(1,2) + virial(3,2) = virial(2,3) + virial(1,3) = virial(3,1) + call set_param_value(at, "virial", virial) + endif + + call finalise(reftraj_output_io) +end subroutine read_vasp_output_persistent + +subroutine read_vasp_incar_dict(incar_dict, incar_template_file, error) + type(Dictionary), intent(inout) :: incar_dict + character(len=*), intent(in) :: incar_template_file + integer, intent(out), optional :: error + + type(Inoutput) :: incar_io + character(len=STRING_LENGTH), allocatable :: incar_a(:), incar_line_fields(:), incar_field_fields(:) + integer :: incar_n_lines, incar_line_n_fields, incar_field_n_fields + integer :: i, j + integer :: comment_pos + + INIT_ERROR(error) + + call initialise(incar_io, trim(incar_template_file), INPUT) + call read_file(incar_io, incar_a, incar_n_lines) + call finalise(incar_io) + + call initialise(incar_dict) + allocate(incar_line_fields(100)) + allocate(incar_field_fields(100)) + ! loop over lines + do i=1, incar_n_lines + comment_pos = index(trim(incar_a(i)), '#') + if (comment_pos > 1) then + incar_a(i) = incar_a(i)(1:comment_pos-1) + elseif (comment_pos == 1) then + incar_a(i) = "" + endif + comment_pos = index(trim(incar_a(i)), '!') + if (comment_pos > 1) then + incar_a(i) = incar_a(i)(1:comment_pos-1) + elseif (comment_pos == 1) then + incar_a(i) = "" + endif + call split_string(trim(incar_a(i)), ";", "''"//'""', incar_line_fields, incar_line_n_fields, .true.) + ! loop over ';' separated fields + do j=1, incar_line_n_fields + call split_string(incar_line_fields(j), "=", "''"//'""', incar_field_fields, incar_field_n_fields, .true.) + if (incar_field_n_fields > 2) then + RAISE_ERROR("read_vasp_incar_dict got more than one '=' in field "//trim(incar_line_fields(j)), error) + endif + if (.not. has_key(incar_dict, trim(adjustl(incar_field_fields(1))))) then + ! VASP always uses first instance of a keyword, do same here + call set_value(incar_dict, trim(adjustl(incar_field_fields(1))), trim(adjustl(incar_field_fields(2)))) + endif + end do + end do + + deallocate(incar_line_fields) + deallocate(incar_field_fields) + +end subroutine read_vasp_incar_dict + +end program vasp_driver From b168025f68456a3a7d0123b7f8e18078399bd76c Mon Sep 17 00:00:00 2001 From: Albert Bartok-Partay Date: Wed, 9 Apr 2025 18:17:15 +0100 Subject: [PATCH 15/47] renamed source files to have F90 extension --- src/Programs/Constraints_Demo.f95 | 163 -- src/Programs/DFTB_to_xml.f95 | 397 ---- src/Programs/FC_to_xml.f95 | 121 -- src/Programs/NRL_TB_to_xml.f95 | 1076 ---------- src/Programs/QMMM_md_buf.f95 | 1978 ------------------ src/Programs/align.f95 | 110 - src/Programs/analytical_free_E_UI.f95 | 177 -- src/Programs/analyze_md_phonons.f95 | 176 -- src/Programs/basin_exploration.f95 | 356 ---- src/Programs/bulktest.f95 | 322 --- src/Programs/calc_n_poles.f95 | 59 - src/Programs/callback_test.f95 | 125 -- src/Programs/crack.f95 | 1532 -------------- src/Programs/create_hybrid_cluster.f95 | 120 -- src/Programs/descriptors_wrapper_example.f95 | 58 - src/Programs/fgp.f95 | 690 ------ src/Programs/fix_traj_latest.f95 | 98 - src/Programs/get_qw.f95 | 138 -- src/Programs/local_E_fd.f95 | 145 -- src/Programs/local_random_search.f95 | 300 --- src/Programs/mark_hybrid.f95 | 112 - src/Programs/md.f95 | 1001 --------- src/Programs/md_gid.f95 | 254 --- src/Programs/metapot_test.f95 | 137 -- src/Programs/order_atoms_as_molecules.f95 | 94 - src/Programs/parallel_io_test.f95 | 104 - src/Programs/quip.f95 | 834 -------- src/Programs/quip_wrapper_example.f95 | 40 - src/Programs/quip_wrapper_simple_example.f95 | 35 - src/Programs/randomise_calc.f95 | 161 -- src/Programs/rotate.f95 | 62 - src/Programs/slice_sample.f95 | 371 ---- src/Programs/socktest.f95 | 81 - src/Programs/socktest2.f95 | 86 - src/Programs/tabletest.f95 | 273 --- src/Programs/test_CASTEP_MM_buffer_crack.f95 | 108 - src/Programs/test_CASTEP_water_bulk.f95 | 219 -- src/Programs/test_CASTEP_water_chain.f95 | 145 -- src/Programs/test_angular.f95 | 33 - src/Programs/test_cova.f95 | 173 -- src/Programs/test_dimer.f95 | 114 - src/Programs/test_grad_sphericals.f95 | 33 - src/Programs/test_task_manager.f95 | 56 - src/Programs/ts_calculation.f95 | 205 -- src/Programs/vacancy_map.f95 | 159 -- src/Programs/vacancy_map_forcemix_relax.f95 | 160 -- src/Programs/vacancy_map_hybrid_generate.f95 | 202 -- src/Programs/vacancy_map_hybrid_relax.f95 | 134 -- src/Programs/vacancy_map_mod.f95 | 97 - src/Programs/water_dimer_mayer.f95 | 239 --- src/Programs/water_dimer_mc.f95 | 275 --- src/Programs/wrap.f95 | 63 - src/Programs/xyz_to_SPECSYM_forces.f95 | 71 - src/Programs/xyz_to_SPECSYM_start.f95 | 63 - 54 files changed, 14335 deletions(-) delete mode 100644 src/Programs/Constraints_Demo.f95 delete mode 100644 src/Programs/DFTB_to_xml.f95 delete mode 100644 src/Programs/FC_to_xml.f95 delete mode 100644 src/Programs/NRL_TB_to_xml.f95 delete mode 100644 src/Programs/QMMM_md_buf.f95 delete mode 100644 src/Programs/align.f95 delete mode 100644 src/Programs/analytical_free_E_UI.f95 delete mode 100644 src/Programs/analyze_md_phonons.f95 delete mode 100644 src/Programs/basin_exploration.f95 delete mode 100644 src/Programs/bulktest.f95 delete mode 100644 src/Programs/calc_n_poles.f95 delete mode 100644 src/Programs/callback_test.f95 delete mode 100644 src/Programs/crack.f95 delete mode 100644 src/Programs/create_hybrid_cluster.f95 delete mode 100644 src/Programs/descriptors_wrapper_example.f95 delete mode 100644 src/Programs/fgp.f95 delete mode 100644 src/Programs/fix_traj_latest.f95 delete mode 100644 src/Programs/get_qw.f95 delete mode 100644 src/Programs/local_E_fd.f95 delete mode 100644 src/Programs/local_random_search.f95 delete mode 100644 src/Programs/mark_hybrid.f95 delete mode 100644 src/Programs/md.f95 delete mode 100644 src/Programs/md_gid.f95 delete mode 100644 src/Programs/metapot_test.f95 delete mode 100644 src/Programs/order_atoms_as_molecules.f95 delete mode 100644 src/Programs/parallel_io_test.f95 delete mode 100644 src/Programs/quip.f95 delete mode 100644 src/Programs/quip_wrapper_example.f95 delete mode 100644 src/Programs/quip_wrapper_simple_example.f95 delete mode 100644 src/Programs/randomise_calc.f95 delete mode 100644 src/Programs/rotate.f95 delete mode 100644 src/Programs/slice_sample.f95 delete mode 100644 src/Programs/socktest.f95 delete mode 100644 src/Programs/socktest2.f95 delete mode 100644 src/Programs/tabletest.f95 delete mode 100644 src/Programs/test_CASTEP_MM_buffer_crack.f95 delete mode 100644 src/Programs/test_CASTEP_water_bulk.f95 delete mode 100644 src/Programs/test_CASTEP_water_chain.f95 delete mode 100644 src/Programs/test_angular.f95 delete mode 100644 src/Programs/test_cova.f95 delete mode 100644 src/Programs/test_dimer.f95 delete mode 100644 src/Programs/test_grad_sphericals.f95 delete mode 100644 src/Programs/test_task_manager.f95 delete mode 100644 src/Programs/ts_calculation.f95 delete mode 100644 src/Programs/vacancy_map.f95 delete mode 100644 src/Programs/vacancy_map_forcemix_relax.f95 delete mode 100644 src/Programs/vacancy_map_hybrid_generate.f95 delete mode 100644 src/Programs/vacancy_map_hybrid_relax.f95 delete mode 100644 src/Programs/vacancy_map_mod.f95 delete mode 100644 src/Programs/water_dimer_mayer.f95 delete mode 100644 src/Programs/water_dimer_mc.f95 delete mode 100644 src/Programs/wrap.f95 delete mode 100644 src/Programs/xyz_to_SPECSYM_forces.f95 delete mode 100644 src/Programs/xyz_to_SPECSYM_start.f95 diff --git a/src/Programs/Constraints_Demo.f95 b/src/Programs/Constraints_Demo.f95 deleted file mode 100644 index da17e770ed..0000000000 --- a/src/Programs/Constraints_Demo.f95 +++ /dev/null @@ -1,163 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program Constraints_Demo - -! This program demonstrates constrained dynamics using LOTF. It shows how to -! apply constraints using function which are already available and also how -! to create your own. - - use libAtoms_module - use LOTF_module - - implicit none - - type(Atoms) :: at - type(DynamicalSystem) :: ds - type(Inoutput) :: movie - real(dp), dimension(:,:), allocatable :: forces - integer :: i, BOND_FUNC, SPHERE_FUNC - - external SPHERE ! The user defined constraint subroutine - - call System_Initialise(seed = 5671232) - - !Set up some atoms - call Initialise(at,500,Make_Lattice(50.0_dp)) - !The first 250 will be oxygen atoms constrained to the surface of a sphere - !centred on the origin, radius 10.0 - do i = 1, 250 - at%Z(i) = Atomic_Number('O') - at%pos(:,i) = random_unit_vector() * 10.0_dp - end do - !The last 250 will be randomly placed hydrogen molecules (bond length = 0.7413 A) - do i = 251,500,2 - at%Z(i) = Atomic_Number('H') - at%Z(i+1) = Atomic_Number('H') - at%pos(:,i) = 0.0_dp - call randomise(at%pos(:,i),50.0_dp) - at%pos(:,i+1) = at%pos(:,i) + random_unit_vector() * 0.7413_dp - end do - - !Initialise the dynamical system with the constraints: - !We have 250 single particle constraints (atoms on the sphere) - ! + 125 two particle constraints (bonds) - ! = 375 in total - - call Initialise(ds,at,constraints = 375) - - !Now we create the constraints: Start by registering the constraint functions - BOND_FUNC = Register_Constraint(BONDLENGTH) !This is pre-coded in Constraints.f95 - SPHERE_FUNC = Register_Constraint(SPHERE) !This is user defined below, and declared - !as external above. - !Up to 20 different types of constraint can be - !registered without editing the source code. - - !Add the constraints one by one - !The arguments are: The DynamicalSystem, the atoms involved, the subroutine pointer, constraint data. - !See the comments in Constraints.f95 for other function, possible atom orders, and required data. - do i = 1, 250 - call DS_Add_Constraint(ds,(/i/),SPHERE_FUNC,(/0.0_dp,0.0_dp,0.0_dp,10.0_dp/)) !Centre = 0,0,0 radius = 10 - end do - do i = 251, 500, 2 - call DS_Add_Constraint(ds,(/i,i+1/),BOND_FUNC,(/0.7413_dp/)) !Bond length = 0.7413 A - end do - - !Give the atoms some initial velocities - call rescale_velo(ds,300.0_dp) - - !Free up memory used by empty groups - call DS_Free_Groups(ds) - - !Set up a movie file so we can see what happens - call Initialise(movie,'Constraints_Demo.xyz') - - !Now we can do dynamics as usual - allocate(forces(3,ds%N)) - forces = 0.0_dp - - do i = 0, 10000 - - if (mod(i,50)==0) then - call Calc_Connect(ds%atoms) - call Print_xyz(ds%atoms,movie) - call ds_print_status(ds) - end if - - call advance_verlet(ds,1.0_dp,forces) - - end do - - !Finalise all the objects - deallocate(forces) - call Finalise(movie) - call Finalise(ds) - call Finalise(at) - - call System_Finalise - -end program Constraints_Demo - -! -!User defined constraint to keep an atom on a sphere. -!data(1:3) contains the coordinates of the centre of the sphere -!data(4) contains the radius of the sphere -! -! The constraint function is C = |r - r0|^2 - a^2 -! -! where r0 is the centre, a is the radius -! -! To find out more about writing your own constraint, look at the comments near -! the end of Constraints.f95 -! -subroutine SPHERE(pos, velo, t, data, C, dC_dr, dC_dt) - - use System_module !for dp definition - use linearalgebra_module !for .dot. definition - - real(dp), dimension(:), intent(in) :: pos, velo, data - real(dp), intent(in) :: t !not used, since this is not time dependent - real(dp), intent(out) :: C - real(dp), dimension(size(pos)), intent(out) :: dC_dr - real(dp), intent(out) :: dC_dt - !local variables - real(dp) :: d(3), radius2 - - if(size(pos) /= 3) call System_Abort('SPHERE: Exactly 1 atom must be specified') - if(size(data) /= 4) call System_Abort('SPHERE: "data" must contain exactly 4 values') - - d = pos - data(1:3) - radius2 = data(4)*data(4) - - C = normsq(d) - radius2 - dC_dr = 2.0_dp * d - dC_dt = dC_dr .dot. velo - -end subroutine SPHERE diff --git a/src/Programs/DFTB_to_xml.f95 b/src/Programs/DFTB_to_xml.f95 deleted file mode 100644 index bdab0923c8..0000000000 --- a/src/Programs/DFTB_to_xml.f95 +++ /dev/null @@ -1,397 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! convert from DFTB web-site input files to QUIP xml format -module DFTB_to_xml_module - -use System_module -use TB_Common_module -use fox_wxml - -implicit none - -contains - -subroutine do_dftb_params_to_xml(fname) - character(len=*), intent(in) :: fname - - integer n_types - integer, allocatable :: atomic_num(:), n_orbs(:), n_elecs(:), n_orb_sets(:), orb_set_type(:,:) - double precision, allocatable :: SK_cutoff(:,:), Vrep_cutoff(:,:) - double precision, allocatable :: E(:,:), E_spin(:), U(:) - double precision, allocatable :: H_vals(:,:,:,:), S_vals(:,:,:,:), SK_r(:,:,:) - double precision, allocatable :: Vrep_efkt(:,:,:), Vrep_r_in(:,:,:,:), Vrep_coeff(:,:,:,:) - double precision, allocatable :: Vrep_r(:,:,:), Vrep_vals(:,:,:) - - integer max_n_orb_sets - - double precision, allocatable :: SK_dr(:,:), Vrep_maxr(:,:) - integer, allocatable :: SK_npts(:,:), Vrep_npts(:,:) - - character(len=1024), allocatable :: filename(:,:) - - integer, allocatable :: max_l(:) - - real(dp) :: r - - double precision self_fields(10), SK_fields(20) - integer n_elec_s, n_elec_p, n_elec_d - character(len=1024) line - - integer :: n_t_atomic_nums = 200 - integer t_atomic_nums(200) - - integer ti, tj, li, i - - read *, n_types, (t_atomic_nums(i), i=1,min(n_types,n_t_atomic_nums)) - if (n_types > n_t_atomic_nums) then - call system_abort("too many types in dftb.ini file") - endif - - allocate(atomic_num(n_types)) - allocate(n_orbs(n_types)) - allocate(n_elecs(n_types)) - allocate(n_orb_sets(n_types)) - - atomic_num(1:n_types) = t_atomic_nums(1:n_types) - - allocate(max_l(n_types)) - -!!!!!! read non matrix element stuff !!!!!! - read *, (max_l(ti), ti=1,n_types) - max_n_orb_sets = maxval(max_l) - - allocate(orb_set_type(n_types,max_n_orb_sets)) - - do ti=1, n_types - select case(max_l(ti)) - case (1) - n_orbs(ti) = 1 - n_orb_sets(ti) = 1 - orb_set_type(ti,1) = ORB_S - case (2) - n_orbs(ti) = 4 - n_orb_sets(ti) = 2 - orb_set_type(ti,1) = ORB_S - orb_set_type(ti,2) = ORB_P - case (3) - n_orbs(ti) = 9 - n_orb_sets(ti) = 3 - orb_set_type(ti,1) = ORB_S - orb_set_type(ti,2) = ORB_P - orb_set_type(ti,3) = ORB_D - case default - write (line, '("Confused by max_l ",2I4)') max_l(i), ti - call system_abort(line) - end select - end do - - allocate(E(max_n_orb_sets,n_types)) - allocate(E_spin(n_types)) - allocate(U(n_types)) - - allocate(SK_dr(n_types,n_types)) - allocate(SK_npts(n_types,n_types)) - allocate(Vrep_maxr(n_types,n_types)) - allocate(Vrep_npts(n_types,n_types)) - - allocate(filename(n_types,n_types)) - - allocate(SK_cutoff(n_types,n_types)) - allocate(Vrep_cutoff(n_types,n_types)) - - do tj=1, n_types - do ti=1, n_types - read *, filename(ti,tj) - open (unit=20, file=trim(filename(ti,tj)), status="OLD") - read (20,*) SK_dr(ti,tj), SK_npts(ti,tj) - if (ti == tj) then - read (20,*) self_fields - do li=1, max_l(ti) - E(li,ti) = self_fields(4-li) - end do - E_spin(ti) = self_fields(4) - U(ti) = self_fields(5) - n_elec_s = self_fields(10) - n_elec_p = self_fields(9) - n_elec_d = self_fields(8) - n_elecs(ti) = n_elec_s + n_elec_p + n_elec_d - endif ! i == j - - SK_cutoff(ti,tj) = SK_dr(ti,tj)*SK_npts(ti,tj) - - do li=1, SK_npts(ti,tj) - read (20,*) line - end do - - do while (line /= 'Spline') - read (20,*) line - end do - read (20,*) Vrep_npts(ti,tj), Vrep_maxr(ti,tj) - Vrep_cutoff(ti,tj) = Vrep_maxr(ti,tj) - end do - end do - - allocate(SK_r(maxval(SK_npts)+1,n_types,n_types)) - allocate(H_vals(maxval(SK_npts)+1,10,n_types,n_types)) - allocate(S_vals(maxval(SK_npts)+1,10,n_types,n_types)) - - allocate(Vrep_efkt(3,n_types,n_types)) - allocate(Vrep_r_in(maxval(Vrep_npts),2,n_types,n_types)) - allocate(Vrep_coeff(maxval(Vrep_npts),6,n_types,n_types)) - - do tj=1, n_types - do ti=1, n_types - open (unit=20, file=trim(filename(ti,tj)), status="OLD") - read (20,*) line ! dr, npts - if (ti == tj) then - read (20,*) line ! onsite stuff - endif - do li=1, SK_npts(ti,tj) - read (20, *) H_vals(li, SK_DDS, ti, tj), & - H_vals(li, SK_DDP, ti, tj), & - H_vals(li, SK_DDD, ti, tj), & - H_vals(li, SK_PDS, ti, tj), & - H_vals(li, SK_PDP, ti, tj), & - H_vals(li, SK_PPS, ti, tj), & - H_vals(li, SK_PPP, ti, tj), & - H_vals(li, SK_SDS, ti, tj), & - H_vals(li, SK_SPS, ti, tj), & - H_vals(li, SK_SSS, ti, tj), & - S_vals(li, SK_DDS, ti, tj), & - S_vals(li, SK_DDP, ti, tj), & - S_vals(li, SK_DDD, ti, tj), & - S_vals(li, SK_PDS, ti, tj), & - S_vals(li, SK_PDP, ti, tj), & - S_vals(li, SK_PPS, ti, tj), & - S_vals(li, SK_PPP, ti, tj), & - S_vals(li, SK_SDS, ti, tj), & - S_vals(li, SK_SPS, ti, tj), & - S_vals(li, SK_SSS, ti, tj) - SK_r(li,ti,tj) = (li-1)*SK_dr(ti,tj) - end do - H_vals(SK_npts(ti,tj)+1,1:10,ti,tj) = 0.0D0 - S_vals(SK_npts(ti,tj)+1,1:10,ti,tj) = 0.0D0 - SK_r(SK_npts(ti,tj)+1,ti,tj) = SK_npts(ti,tj)*SK_dr(ti,tj) - - do while (line /= 'Spline') - read (20,*) line - end do - read (20,*) line ! npts, maxr - read (20,*) Vrep_Efkt(1:3,ti,tj) - do li=1, Vrep_npts(ti,tj) - if (li == Vrep_npts(ti,tj)) then - read(20,*) Vrep_r_in(li,1:2, ti,tj), Vrep_coeff(li,1:6,ti,tj) - else - read(20,*) Vrep_r_in(li,1:2, ti,tj), Vrep_coeff(li,1:4,ti,tj) - endif - end do - end do - end do - - SK_npts = SK_npts + 1 - - allocate(Vrep_r(maxval(Vrep_npts+11), n_types, n_types)) - allocate(Vrep_vals(maxval(Vrep_npts+11), n_types, n_types)) - - do tj=1, n_types - do ti=1, n_types - do li=1, 10 - r = (li-1)/10.0D0*Vrep_r_in(1,1,ti,tj) - Vrep_r(li,ti,tj) = r - Vrep_vals(li,ti,tj) = exp(-Vrep_efkt(1,ti,tj)*r+Vrep_efkt(2,ti,tj))+Vrep_efkt(3,ti,tj) - end do - do li=1, Vrep_npts(ti,tj) - Vrep_r(li+10,ti,tj) = Vrep_r_in(li,1,ti,tj) - Vrep_vals(li+10,ti,tj) = Vrep_coeff(li,1,ti,tj) - end do - Vrep_r(11+Vrep_npts(ti,tj),ti,tj) = Vrep_r_in(Vrep_npts(ti,tj),2,ti,tj) - Vrep_vals(11+Vrep_npts(ti,tj),ti,tj) = 0.0D0 - end do - end do - Vrep_npts = Vrep_npts + 11 - - deallocate(max_l) - - call print_DFTB_xml(fname, n_types, atomic_num, n_orbs, n_elecs, n_orb_sets, max_n_orb_sets, & - orb_set_type, E, SK_cutoff, SK_npts, SK_r, H_vals, S_vals, Vrep_cutoff, Vrep_npts, Vrep_r, Vrep_vals) -end subroutine - -subroutine print_DFTB_xml(fname, n_types, atomic_num, n_orbs, n_elecs, n_orb_sets, max_n_orb_sets, & - orb_set_type, E, SK_cutoff, SK_npts, SK_r, H_vals, S_vals, Vrep_cutoff, Vrep_npts, Vrep_r, Vrep_vals) -implicit none - character(len=*), intent(in) :: fname - integer, intent(in) :: n_types - integer, intent(in) :: max_n_orb_sets - integer, intent(in) :: atomic_num(:), n_orbs(:), n_elecs(:), n_orb_sets(:), & - orb_set_type(:,:) - double precision, intent(in) :: E(:,:) - double precision, intent(in) :: SK_cutoff(:,:) - integer, intent(in) :: SK_npts(:,:) - double precision, intent(in) :: SK_r(:,:,:), H_vals(:,:,:,:), S_vals(:,:,:,:) - double precision, intent(in) :: Vrep_cutoff(:,:) - integer, intent(in) :: Vrep_npts(:,:) - double precision, intent(in) :: Vrep_r(:,:,:), Vrep_vals(:,:,:) - - type(xmlf_t) :: xf - - integer :: i, j, k, l - integer n_non_zero - - call xml_OpenFile(fname,xf) - call xml_NewElement(xf,"DFTB_params") - - call xml_NewElement(xf,"n_types") - call xml_AddAttribute(xf,"v", "" // n_types) - call xml_EndElement(xf,"n_types") - - call xml_NewElement(xf,"cutoff") - call xml_AddAttribute(xf,"v", "" // max(maxval(SK_cutoff),maxval(Vrep_cutoff))) - call xml_EndElement(xf,"cutoff") - - call xml_NewElement(xf,"max_n_orb_sets") - call xml_AddAttribute(xf,"v", "" // max_n_orb_sets) - call xml_EndElement(xf,"max_n_orb_sets") - - do i=1, n_types - call xml_NewElement(xf,"per_type_data") - call xml_AddAttribute(xf,"type", "" // i) - call xml_AddAttribute(xf,"atomic_num", "" // atomic_num(i)) - call xml_AddAttribute(xf,"n_orbs", "" // n_orbs(i)) - call xml_AddAttribute(xf,"n_elecs", "" // n_elecs(i)) - call xml_AddAttribute(xf,"n_orb_sets", "" // n_orb_sets(i)) - call xml_NewElement(xf,"orb_set_type") - ! call xml_AddArray(xf, orb_set_type(i,1:n_orb_sets(i)), '(i0,1x)') - call xml_AddCharacters(xf, "" // orb_set_type(i,1:n_orb_sets(i))) - call xml_EndElement(xf,"orb_set_type") - call xml_NewElement(xf,"E") - ! call xml_AddArray(xf, E(1:n_orb_sets(i),i), '(f30.20,1x)') - call xml_AddCharacters(xf, "" // E(1:n_orb_sets(i),i)) - call xml_EndElement(xf,"E") - call xml_EndElement(xf,"per_type_data") - end do - - do i=1, n_types - do j=1, n_types -print *, "doing per pair data ", i, j - call xml_NewElement(xf,"per_pair_data") - call xml_AddAttribute(xf,"type1", "" // i) - call xml_AddAttribute(xf,"type2", "" // j) - call xml_AddAttribute(xf,"SK_cutoff", "" // SK_cutoff(i,j)) - call xml_AddAttribute(xf,"Vrep_cutoff", "" // Vrep_cutoff(i,j)) - call xml_AddAttribute(xf,"SK_npts", "" // SK_npts(i,j)) - call xml_AddAttribute(xf,"Vrep_npts", "" // Vrep_npts(i,j)) -print *, "done attributes" - call xml_NewElement(xf,"H_spline") - do k=1, SK_npts(i,j) - call xml_NewElement(xf,"point") - mainlog%default_real_precision=3 - call xml_AddAttribute(xf,"r", "" // SK_r(k,i,j)) - ! call xml_AddArray(xf,H_vals(k,:,i,j), '(f20.10,1x)') - mainlog%default_real_precision=8 - n_non_zero = 1 - do l=size(H_vals,2), 1, -1 - if (H_vals(k,l,i,j) /= 0.0) then - n_non_zero = l - exit - endif - end do - call xml_AddCharacters(xf, "" // H_vals(k,1:n_non_zero,i,j)) - mainlog%default_real_precision=16 - call xml_EndElement(xf,"point") - end do - call xml_EndElement(xf,"H_spline") -print *, "done H_spline" - call xml_NewElement(xf,"S_spline") - do k=1, SK_npts(i,j) - call xml_NewElement(xf,"point") - mainlog%default_real_precision=3 - call xml_AddAttribute(xf,"r","" // SK_r(k,i,j)) - mainlog%default_real_precision=8 - ! call xml_AddArray(xf,S_vals(k,:,i,j), '(f20.10,1x)') - n_non_zero = 1 - do l=size(S_vals,2), 1, -1 - if (S_vals(k,l,i,j) /= 0.0) then - n_non_zero = l - exit - endif - end do - call xml_AddCharacters(xf, "" // S_vals(k,1:n_non_zero,i,j)) - mainlog%default_real_precision=16 - call xml_EndElement(xf,"point") - end do - call xml_EndElement(xf,"S_spline") -print *, "done S_spline" - call xml_NewElement(xf,"Vrep_spline") - do k=1, Vrep_npts(i,j) - call xml_NewElement(xf,"point") - mainlog%default_real_precision=3 - call xml_AddAttribute(xf,"r", "" // Vrep_r(k,i,j)) - mainlog%default_real_precision=8 - ! call xml_AddArray(xf,Vrep_vals(k:k,i,j), '(f20.10,1x)') - call xml_AddCharacters(xf, "" // Vrep_vals(k:k,i,j)) - mainlog%default_real_precision=16 - call xml_EndElement(xf,"point") - end do - call xml_EndElement(xf,"Vrep_spline") -print *, "done Vrep_spline" - call xml_EndElement(xf,"per_pair_data") - end do - end do - - call xml_EndElement(xf,"DFTB_params") - - call xml_Close(xf) -end subroutine - -end module DFTB_to_xml_module - -program DFTB_to_xml -use DFTB_to_xml_module -implicit none - - character(len=1024) fname - - call system_initialise() - - if (command_argument_count() == 0) then - fname = "tightbind.parms.DFTB.xml" - else if (command_argument_count() == 1) then - call get_command_argument(1, fname) - else - call system_abort("Usage: DFTB_to_xml [ output_filename ]") - endif - - call do_dftb_params_to_xml(fname) - - call system_finalise() -end program - - diff --git a/src/Programs/FC_to_xml.f95 b/src/Programs/FC_to_xml.f95 deleted file mode 100644 index 3965647829..0000000000 --- a/src/Programs/FC_to_xml.f95 +++ /dev/null @@ -1,121 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program parse_fc -use libatoms_module -implicit none - character(len=100) :: f_s, f_fc, cmd - integer :: N_at, N_fc, s(3), i, j, fc_i_a(1), fc_i, Zi, Zj - integer, allocatable :: Z(:), bond_list_i(:), bond_list(:) - double precision :: m, p(3), dr(3) - double precision, allocatable :: phi2(:), phi3(:), phi4(:), r0(:) - double precision, allocatable :: phi2_table(:,:,:), phi3_table(:,:,:), phi4_table(:,:,:), r0_table(:,:,:) - integer :: n_types, max_n_fcs - - call system_initialise() - - if (cmd_arg_count() /= 2) then - call get_cmd_arg(0, cmd) - call system_abort("Usage: "// trim(cmd)//" struct_file fc_file") - endif - - call get_cmd_arg(1, f_s) - call get_cmd_arg(2, f_fc) - - open (unit=10, file=f_s, status="OLD") - read (10,*) N_at - ! print *, "reading ",N_at," atoms" - read (10,*) p - read (10,*) p - read (10,*) p - allocate(Z(N_at)) - do i=1, N_at - read (10,*) p, Z(i), m - if (abs(m-55.85) < 0.1) Z(i) = 26 - if (abs(m-121.75) < 0.1) Z(i) = 51 - if (abs(m-138.92) < 0.1) Z(i) = 57 - end do - close(unit=10) - - open (unit=10, file=f_fc, status="OLD") - read (10,*) N_fc - ! print *, "reading ",N_fc," force constants" - allocate(phi2(N_fc), phi3(N_fc), phi4(N_fc), r0(N_fc)) - do i=1, N_fc - read (10,*) phi2(i), phi3(i), phi4(i), s, dr, r0(i) - end do - allocate(bond_list_i(N_at+1)) - allocate(bond_list(N_fc)) - read (10,*) bond_list_i - read (10,*) N_fc - read (10,*) bond_list - - allocate(phi2_table(130,130,30)) - allocate(phi3_table(130,130,30)) - allocate(phi4_table(130,130,30)) - allocate(r0_table(130,130,30)) - r0_table = -1.0 - phi2_table = 0.0 - phi3_table = 0.0 - phi4_table = 0.0 - - do i=1, N_at - ! print '("atom ", I6)', i - do j=bond_list_i(i), bond_list_i(i+1)-1 - ! print '("bond ",I3," Zs ",2I3," phis ",3F25.15," r0 ",F25.15)', j-bond_list_i(i)+1, & - ! Z(i), Z(bond_list(j)), phi2(j), phi3(j), phi4(j), r0(j) - Zi = Z(i) - Zj = Z(bond_list(j)) - if (minval(abs(r0_table(Zi,Zj,:)-r0(j))) > 1.0e-4_dp) then - fc_i_a = minloc(r0_table(Zi,Zj,:)) - fc_i = fc_i_a(1) - phi2_table(Zi,Zj,fc_i) = phi2(j) - phi3_table(Zi,Zj,fc_i) = phi3(j) - phi4_table(Zi,Zj,fc_i) = phi4(j) - r0_table(Zi,Zj,fc_i) = r0(j) - endif - end do - end do - - n_types = count(count(r0_table(:,:,1) > 0.0, 2) > 0) - max_n_fcs = maxval(count(r0_table > 0.0, 3)) - call print('') - do Zi=1, size(phi2_table,1) - do Zj=1, size(phi2_table,2) - if (maxval(r0_table(Zi,Zj,:)) > 0.0) then - do fc_i=1, count(r0_table(Zi,Zj,:) > 0.0) - call print(' ') - end do - endif - end do - end do - call print ("") -end program diff --git a/src/Programs/NRL_TB_to_xml.f95 b/src/Programs/NRL_TB_to_xml.f95 deleted file mode 100644 index 8f0dd241c1..0000000000 --- a/src/Programs/NRL_TB_to_xml.f95 +++ /dev/null @@ -1,1076 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! convert from NRL-TB web-site input files to QUIP XML format -module NRL_TB_to_xml_module - -use System_module -use TB_Common_module -use TBModel_NRL_TB_defs_module -use fox_wxml - -implicit none - -contains - -subroutine do_nrl_tb_params_to_xml(fname) - character(len=*), intent(in) :: fname - - logical is_orthogonal, is_magnetic, has_pair_repulsion, overlap_zero_limit, force_harrison_signs - character(len=1024) header, label - integer param_style - integer n_types - integer, allocatable :: atomic_num(:), n_orbs(:), n_elecs(:), n_orb_sets(:), orb_set_type(:,:) - double precision, allocatable :: atomic_mass(:), r_cut(:,:), screen_l(:,:) - double precision, allocatable :: pair_rep_inner(:,:), pair_rep_outer(:,:) - double precision :: cutoff - double precision, allocatable :: lambda_sq(:,:), abcd(:,:,:,:,:) - double precision, allocatable :: H_coeff(:,:,:,:,:), S_coeff(:,:,:,:,:) - - double precision n_elec_s, n_elec_p, n_elec_d - double precision t_d - integer i, j, stat - integer i_mag, n_mag - character(len=1024) line - - read *, line - - header = trim(line) - - if (header(1:1) == 'N') then - is_orthogonal = .false. - else if (header(1:1) == 'O') then - is_orthogonal = .true. - else - call system_abort ("confused by first character of header") - endif - - if (header(2:2) == 'N') then - is_magnetic = .false. - else if (header(2:2) == 'M') then - is_magnetic = .true. - else - call system_abort ("confused by first character of header") - endif - - if (header(3:3) .ne. "0" .or. header(4:4) .ne. "0" .or. header(5:5) .ne. "0") then - call system_abort( "Unknown parameter format "//trim(header) ) - end if - if (header(6:6) .eq. "0") then - has_pair_repulsion = .false. - else if (header(6:6) .eq. "1") then - has_pair_repulsion = .true. - else - call system_abort ("Unknown parameter format "//trim(header)) - endif - if (header(7:7) .eq. "0") then - param_style = 0 - else if (header(7:7) .eq. "1") then - param_style = 1 - else if (header(7:7) .eq. "2") then - param_style = 2 - else if (header(7:7) .eq. "3") then - param_style = 3 - else - call system_abort ("Unknown parameter format "// trim(header) ) - end if - - select case (param_style) - case (0) - overlap_zero_limit = .false. - force_harrison_signs = .false. - case (1) - overlap_zero_limit = .true. - force_harrison_signs = .false. - case (2) - overlap_zero_limit = .false. - force_harrison_signs = .true. - case (3) - overlap_zero_limit = .true. - force_harrison_signs = .true. - case default - end select - - read *, line - label = trim(line) - -!!!!!! read n_types !!!!!! - read *, n_types - - allocate(atomic_num(n_types)) - allocate(atomic_mass(n_types)) - allocate(n_orbs(n_types)) - allocate(n_elecs(n_types)) - allocate(n_orb_sets(n_types)) - allocate(orb_set_type(n_types,max_n_orb_sets)) - - allocate(r_cut(n_types,n_types)) - allocate(screen_l(n_types,n_types)) - -!!!!!! read non matrix element stuff !!!!!! - do i=1, n_types - do j=i, 1, -1 - read *, r_cut(i,j), screen_l(i,j) - if (i .ne. j) then - r_cut(j,i) = r_cut(i,j) - screen_l(j,i) = screen_l(i,j) - endif - end do - end do - - if (has_pair_repulsion) then - allocate(pair_rep_inner(n_types,n_types)) - allocate(pair_rep_outer(n_types,n_types)) - do i=1, n_types - do j=i, 1, -1 - read *, pair_rep_inner(i,j), pair_rep_outer(i,j) - if (i .ne. j) then - pair_rep_inner(i,j) = pair_rep_inner(j,i) - pair_rep_outer(i,j) = pair_rep_outer(j,i) - endif - end do - end do - endif - - cutoff = maxval(r_cut(:,:)) - do i=1, n_types - read *, n_orbs(i) - - atomic_num(i) = 0 - read (*, *, iostat=stat) atomic_mass(i), atomic_num(i) - - read *, n_elec_s, n_elec_p, n_elec_d - select case (n_orbs(i)) - case (1) - n_orb_sets(i) = 1 - orb_set_type(i,1) = ORB_S - n_elecs(i) = n_elec_s - case (4) - n_orb_sets(i) = 2 - orb_set_type(i,1) = ORB_S - orb_set_type(i,2) = ORB_P - n_elecs(i) = n_elec_s + n_elec_p - case (6) - n_orb_sets(i) = 2 - orb_set_type(i,1) = ORB_S - orb_set_type(i,2) = ORB_D - n_elecs(i) = n_elec_s + n_elec_d - case (9) - n_orb_sets(i) = 3 - orb_set_type(i,1) = ORB_S - orb_set_type(i,2) = ORB_P - orb_set_type(i,3) = ORB_D - n_elecs(i) = n_elec_s + n_elec_p + n_elec_d - case (16) - n_orb_sets(i) = 4 - orb_set_type(i,1) = ORB_S - orb_set_type(i,2) = ORB_P - orb_set_type(i,3) = ORB_D - orb_set_type(i,4) = ORB_F - n_elecs(i) = n_elec_s + n_elec_p + n_elec_d - end select - end do - -!! allocate(type_of_atomic_num(maxval(atomic_num(:)))) -!! type_of_atomic_num(:) = 0 -!! do i=1, n_types -!! type_of_atomic_num(atomic_num(i)) = i -!! end do - -!!!!!!!!! ON-SITE !!!!!!!!!!!! - if (is_magnetic) then - n_mag = 2 - else - n_mag = 1 - endif - - allocate(lambda_sq(n_types,n_mag)) - allocate(abcd(4,max_n_orb_sets,n_types,n_types,n_mag)) - allocate(H_coeff(4,N_SK,n_types,n_types,n_mag)) - allocate(S_coeff(4,N_SK,n_types,n_types,n_mag)) - - do i_mag=1, n_mag - - do i=1, n_types - j = i - read *, lambda_sq(i,i_mag) - - read *, abcd(ABCD_A,SPDF_S,i,i,i_mag) - read *, abcd(ABCD_B,SPDF_S,i,i,i_mag) - read *, abcd(ABCD_C,SPDF_S,i,i,i_mag) - read *, abcd(ABCD_D,SPDF_S,i,i,i_mag) - - read *, abcd(ABCD_A,SPDF_P,i,i,i_mag) - read *, abcd(ABCD_B,SPDF_P,i,i,i_mag) - read *, abcd(ABCD_C,SPDF_P,i,i,i_mag) - read *, abcd(ABCD_D,SPDF_P,i,i,i_mag) - - read *, abcd(ABCD_A,SPDF_D,i,i,i_mag) - read *, abcd(ABCD_B,SPDF_D,i,i,i_mag) - read *, abcd(ABCD_C,SPDF_D,i,i,i_mag) - read *, abcd(ABCD_D,SPDF_D,i,i,i_mag) - - read *, t_d - if (any(orb_set_type(i,1:n_orb_sets(i)) == ORB_D) .and. abcd(ABCD_A,SPDF_D,i,i,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_A,SPDF_D,i,i,i_mag) // " " // t_d) - read *, t_d - if (any(orb_set_type(i,1:n_orb_sets(i)) == ORB_D) .and. abcd(ABCD_B,SPDF_D,i,i,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_B,SPDF_D,i,i,i_mag) // " " // t_d) - read *, t_d - if (any(orb_set_type(i,1:n_orb_sets(i)) == ORB_D) .and. abcd(ABCD_C,SPDF_D,i,i,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_C,SPDF_D,i,i,i_mag) // " " // t_d) - read *, t_d - if (any(orb_set_type(i,1:n_orb_sets(i)) == ORB_D) .and. abcd(ABCD_D,SPDF_D,i,i,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_D,SPDF_D,i,i,i_mag) // " " // t_d) - - if (n_orb_sets(i) == 4) then - read *, abcd(ABCD_A,SPDF_F,i,i,i_mag) - read *, abcd(ABCD_B,SPDF_F,i,i,i_mag) - read *, abcd(ABCD_C,SPDF_F,i,i,i_mag) - read *, abcd(ABCD_D,SPDF_F,i,i,i_mag) - endif - - end do - - do i=2, n_types - do j=1, i-1 - - ! i on j - abcd(ABCD_A,SPDF_S,i,j,i_mag) = 0.0D0 - read *, abcd(ABCD_B,SPDF_S,i,j,i_mag) - read *, abcd(ABCD_C,SPDF_S,i,j,i_mag) - read *, abcd(ABCD_D,SPDF_S,i,j,i_mag) - - abcd(ABCD_A,SPDF_P,i,j,i_mag) = 0.0D0 - read *, abcd(ABCD_B,SPDF_P,i,j,i_mag) - read *, abcd(ABCD_C,SPDF_P,i,j,i_mag) - read *, abcd(ABCD_D,SPDF_P,i,j,i_mag) - - abcd(ABCD_A,SPDF_D,i,j,i_mag) = 0.0D0 - read *, abcd(ABCD_B,SPDF_D,i,j,i_mag) - read *, abcd(ABCD_C,SPDF_D,i,j,i_mag) - read *, abcd(ABCD_D,SPDF_D,i,j,i_mag) - - read *, t_d - if (abcd(ABCD_B,SPDF_D,i,j,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_B,SPDF_D,i,j,i_mag) // " " // t_d) - read *, t_d - if (abcd(ABCD_C,SPDF_D,i,j,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_C,SPDF_D,i,j,i_mag) // " " // t_d) - read *, t_d - if (abcd(ABCD_D,SPDF_D,i,j,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_D,SPDF_D,i,j,i_mag) // " " // t_d) - - if (n_orb_sets(i) == 4) then - abcd(ABCD_A,SPDF_F,i,j,i_mag) = 0.0D0 - read *, abcd(ABCD_B,SPDF_F,i,j,i_mag) - read *, abcd(ABCD_C,SPDF_F,i,j,i_mag) - read *, abcd(ABCD_D,SPDF_F,i,j,i_mag) - endif - - ! j on i - abcd(ABCD_A,SPDF_S,j,i,i_mag) = 0.0D0 - read *, abcd(ABCD_B,SPDF_S,j,i,i_mag) - read *, abcd(ABCD_C,SPDF_S,j,i,i_mag) - read *, abcd(ABCD_D,SPDF_S,j,i,i_mag) - - abcd(ABCD_A,SPDF_P,j,i,i_mag) = 0.0D0 - read *, abcd(ABCD_B,SPDF_P,j,i,i_mag) - read *, abcd(ABCD_C,SPDF_P,j,i,i_mag) - read *, abcd(ABCD_D,SPDF_P,j,i,i_mag) - - abcd(ABCD_A,SPDF_D,j,i,i_mag) = 0.0D0 - read *, abcd(ABCD_B,SPDF_D,j,i,i_mag) - read *, abcd(ABCD_C,SPDF_D,j,i,i_mag) - read *, abcd(ABCD_D,SPDF_D,j,i,i_mag) - - read *, t_d - if (abcd(ABCD_B,SPDF_D,j,i,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_B,SPDF_D,j,i,i_mag) // " " // t_d) - read *, t_d - if (abcd(ABCD_C,SPDF_D,j,i,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_C,SPDF_D,j,i,i_mag) // " " // t_d) - read *, t_d - if (abcd(ABCD_D,SPDF_D,j,i,i_mag) /= t_d) & - call system_abort ("NRL-TB No support for E_g T_2g split" // abcd(ABCD_D,SPDF_D,j,i,i_mag) // " " // t_d) - - if (n_orb_sets(j) == 4) then - abcd(ABCD_A,SPDF_F,j,i,i_mag) = 0.0D0 - read *, abcd(ABCD_B,SPDF_F,j,i,i_mag) - read *, abcd(ABCD_C,SPDF_F,j,i,i_mag) - read *, abcd(ABCD_D,SPDF_F,j,i,i_mag) - endif - - end do - end do - - !!!!!!!!! HAMILTONIAN !!!!!!!!!!!! - - do i=1, n_types - j=i - read *, H_coeff(MC_E,SK_SSS,j,i,i_mag) - read *, H_coeff(MC_F,SK_SSS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_SSS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_SSS,j,i,i_mag) - read *, H_coeff(MC_E,SK_SPS,j,i,i_mag) - read *, H_coeff(MC_F,SK_SPS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_SPS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_SPS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PPS,j,i,i_mag) - read *, H_coeff(MC_F,SK_PPS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PPS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PPS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PPP,j,i,i_mag) - read *, H_coeff(MC_F,SK_PPP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PPP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PPP,j,i,i_mag) - read *, H_coeff(MC_E,SK_SDS,j,i,i_mag) - read *, H_coeff(MC_F,SK_SDS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_SDS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_SDS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PDS,j,i,i_mag) - read *, H_coeff(MC_F,SK_PDS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PDS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PDS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PDP,j,i,i_mag) - read *, H_coeff(MC_F,SK_PDP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PDP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PDP,j,i,i_mag) - read *, H_coeff(MC_E,SK_DDS,j,i,i_mag) - read *, H_coeff(MC_F,SK_DDS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DDS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DDS,j,i,i_mag) - read *, H_coeff(MC_E,SK_DDP,j,i,i_mag) - read *, H_coeff(MC_F,SK_DDP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DDP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DDP,j,i,i_mag) - read *, H_coeff(MC_E,SK_DDD,j,i,i_mag) - read *, H_coeff(MC_F,SK_DDD,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DDD,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DDD,j,i,i_mag) - if (n_orb_sets(i) == 4) then - read *, H_coeff(MC_E,SK_SFS,j,i,i_mag) - read *, H_coeff(MC_F,SK_SFS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_SFS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_SFS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PFS,j,i,i_mag) - read *, H_coeff(MC_F,SK_PFS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PFS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PFS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PFP,j,i,i_mag) - read *, H_coeff(MC_F,SK_PFP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PFP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PFP,j,i,i_mag) - read *, H_coeff(MC_E,SK_DFS,j,i,i_mag) - read *, H_coeff(MC_F,SK_DFS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DFS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFS,j,i,i_mag) - read *, H_coeff(MC_E,SK_DFP,j,i,i_mag) - read *, H_coeff(MC_F,SK_DFP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DFP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFP,j,i,i_mag) - read *, H_coeff(MC_E,SK_DFD,j,i,i_mag) - read *, H_coeff(MC_F,SK_DFD,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DFD,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFD,j,i,i_mag) - read *, H_coeff(MC_E,SK_FFS,j,i,i_mag) - read *, H_coeff(MC_F,SK_FFS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_FFS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_FFS,j,i,i_mag) - read *, H_coeff(MC_E,SK_FFP,j,i,i_mag) - read *, H_coeff(MC_F,SK_FFP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_FFP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_FFP,j,i,i_mag) - read *, H_coeff(MC_E,SK_FFD,j,i,i_mag) - read *, H_coeff(MC_F,SK_FFD,j,i,i_mag) - read *, H_coeff(MC_FB,SK_FFD,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_FFD,j,i,i_mag) - read *, H_coeff(MC_E,SK_FFF,j,i,i_mag) - read *, H_coeff(MC_F,SK_FFF,j,i,i_mag) - read *, H_coeff(MC_FB,SK_FFF,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_FFF,j,i,i_mag) - endif - end do - - do i=2, n_types - do j=1, i-1 - read *, H_coeff(MC_E,SK_SSS,j,i,i_mag) - read *, H_coeff(MC_F,SK_SSS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_SSS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_SSS,j,i,i_mag) - read *, H_coeff(MC_E,SK_SPS,j,i,i_mag) - read *, H_coeff(MC_F,SK_SPS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_SPS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_SPS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PPS,j,i,i_mag) - read *, H_coeff(MC_F,SK_PPS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PPS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PPS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PPP,j,i,i_mag) - read *, H_coeff(MC_F,SK_PPP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PPP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PPP,j,i,i_mag) - read *, H_coeff(MC_E,SK_SDS,j,i,i_mag) - read *, H_coeff(MC_F,SK_SDS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_SDS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_SDS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PDS,j,i,i_mag) - read *, H_coeff(MC_F,SK_PDS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PDS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PDS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PDP,j,i,i_mag) - read *, H_coeff(MC_F,SK_PDP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PDP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PDP,j,i,i_mag) - read *, H_coeff(MC_E,SK_DDS,j,i,i_mag) - read *, H_coeff(MC_F,SK_DDS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DDS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DDS,j,i,i_mag) - read *, H_coeff(MC_E,SK_DDP,j,i,i_mag) - read *, H_coeff(MC_F,SK_DDP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DDP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DDP,j,i,i_mag) - read *, H_coeff(MC_E,SK_DDD,j,i,i_mag) - read *, H_coeff(MC_F,SK_DDD,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DDD,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DDD,j,i,i_mag) - if (n_orb_sets(i) == 4) then - read *, H_coeff(MC_E,SK_SFS,j,i,i_mag) - read *, H_coeff(MC_F,SK_SFS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_SFS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_SFS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PFS,j,i,i_mag) - read *, H_coeff(MC_F,SK_PFS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PFS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PFS,j,i,i_mag) - read *, H_coeff(MC_E,SK_PFP,j,i,i_mag) - read *, H_coeff(MC_F,SK_PFP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_PFP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_PFP,j,i,i_mag) - read *, H_coeff(MC_E,SK_DFS,j,i,i_mag) - read *, H_coeff(MC_F,SK_DFS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DFS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFS,j,i,i_mag) - read *, H_coeff(MC_E,SK_DFP,j,i,i_mag) - read *, H_coeff(MC_F,SK_DFP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DFP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFP,j,i,i_mag) - read *, H_coeff(MC_E,SK_DFD,j,i,i_mag) - read *, H_coeff(MC_F,SK_DFD,j,i,i_mag) - read *, H_coeff(MC_FB,SK_DFD,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFD,j,i,i_mag) - read *, H_coeff(MC_E,SK_FFS,j,i,i_mag) - read *, H_coeff(MC_F,SK_FFS,j,i,i_mag) - read *, H_coeff(MC_FB,SK_FFS,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_FFS,j,i,i_mag) - read *, H_coeff(MC_E,SK_FFP,j,i,i_mag) - read *, H_coeff(MC_F,SK_FFP,j,i,i_mag) - read *, H_coeff(MC_FB,SK_FFP,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_FFP,j,i,i_mag) - read *, H_coeff(MC_E,SK_FFD,j,i,i_mag) - read *, H_coeff(MC_F,SK_FFD,j,i,i_mag) - read *, H_coeff(MC_FB,SK_FFD,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_FFD,j,i,i_mag) - read *, H_coeff(MC_E,SK_FFF,j,i,i_mag) - read *, H_coeff(MC_F,SK_FFF,j,i,i_mag) - read *, H_coeff(MC_FB,SK_FFF,j,i,i_mag) - read *, H_coeff(MC_G_SQ,SK_FFF,j,i,i_mag) - endif - - H_coeff(MC_E,SK_SSS,i,j,i_mag) = H_coeff(MC_E,SK_SSS,j,i,i_mag) - H_coeff(MC_F,SK_SSS,i,j,i_mag) = H_coeff(MC_F,SK_SSS,j,i,i_mag) - H_coeff(MC_FB,SK_SSS,i,j,i_mag) = H_coeff(MC_FB,SK_SSS,j,i,i_mag) - H_coeff(MC_G_SQ,SK_SSS,i,j,i_mag) = H_coeff(MC_G_SQ,SK_SSS,j,i,i_mag) - - read *, H_coeff(MC_E,SK_SPS,i,j,i_mag) - read *, H_coeff(MC_F,SK_SPS,i,j,i_mag) - read *, H_coeff(MC_FB,SK_SPS,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_SPS,i,j,i_mag) - H_coeff(MC_E,SK_SPS,i,j,i_mag) = - H_coeff(MC_E,SK_SPS,i,j,i_mag) - H_coeff(MC_F,SK_SPS,i,j,i_mag) = - H_coeff(MC_F,SK_SPS,i,j,i_mag) - H_coeff(MC_FB,SK_SPS,i,j,i_mag) = - H_coeff(MC_FB,SK_SPS,i,j,i_mag) - - H_coeff(MC_E,SK_PPS,i,j,i_mag) = H_coeff(MC_E,SK_PPS,j,i,i_mag) - H_coeff(MC_F,SK_PPS,i,j,i_mag) = H_coeff(MC_F,SK_PPS,j,i,i_mag) - H_coeff(MC_FB,SK_PPS,i,j,i_mag) = H_coeff(MC_FB,SK_PPS,j,i,i_mag) - H_coeff(MC_G_SQ,SK_PPS,i,j,i_mag) = H_coeff(MC_G_SQ,SK_PPS,j,i,i_mag) - - H_coeff(MC_E,SK_PPP,i,j,i_mag) = H_coeff(MC_E,SK_PPP,j,i,i_mag) - H_coeff(MC_F,SK_PPP,i,j,i_mag) = H_coeff(MC_F,SK_PPP,j,i,i_mag) - H_coeff(MC_FB,SK_PPP,i,j,i_mag) = H_coeff(MC_FB,SK_PPP,j,i,i_mag) - H_coeff(MC_G_SQ,SK_PPP,i,j,i_mag) = H_coeff(MC_G_SQ,SK_PPP,j,i,i_mag) - - read *, H_coeff(MC_E,SK_SDS,i,j,i_mag) - read *, H_coeff(MC_F,SK_SDS,i,j,i_mag) - read *, H_coeff(MC_FB,SK_SDS,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_SDS,i,j,i_mag) - - read *, H_coeff(MC_E,SK_PDS,i,j,i_mag) - read *, H_coeff(MC_F,SK_PDS,i,j,i_mag) - read *, H_coeff(MC_FB,SK_PDS,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_PDS,i,j,i_mag) - H_coeff(MC_E,SK_PDS,i,j,i_mag) = - H_coeff(MC_E,SK_PDS,i,j,i_mag) - H_coeff(MC_F,SK_PDS,i,j,i_mag) = - H_coeff(MC_F,SK_PDS,i,j,i_mag) - H_coeff(MC_FB,SK_PDS,i,j,i_mag) = - H_coeff(MC_FB,SK_PDS,i,j,i_mag) - - read *, H_coeff(MC_E,SK_PDP,i,j,i_mag) - read *, H_coeff(MC_F,SK_PDP,i,j,i_mag) - read *, H_coeff(MC_FB,SK_PDP,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_PDP,i,j,i_mag) - H_coeff(MC_E,SK_PDP,i,j,i_mag) = - H_coeff(MC_E,SK_PDP,i,j,i_mag) - H_coeff(MC_F,SK_PDP,i,j,i_mag) = - H_coeff(MC_F,SK_PDP,i,j,i_mag) - H_coeff(MC_FB,SK_PDP,i,j,i_mag) = - H_coeff(MC_FB,SK_PDP,i,j,i_mag) - - H_coeff(MC_E,SK_DDS,i,j,i_mag) = H_coeff(MC_E,SK_DDS,j,i,i_mag) - H_coeff(MC_F,SK_DDS,i,j,i_mag) = H_coeff(MC_F,SK_DDS,j,i,i_mag) - H_coeff(MC_FB,SK_DDS,i,j,i_mag) = H_coeff(MC_FB,SK_DDS,j,i,i_mag) - H_coeff(MC_G_SQ,SK_DDS,i,j,i_mag) = H_coeff(MC_G_SQ,SK_DDS,j,i,i_mag) - - H_coeff(MC_E,SK_DDP,i,j,i_mag) = H_coeff(MC_E,SK_DDP,j,i,i_mag) - H_coeff(MC_F,SK_DDP,i,j,i_mag) = H_coeff(MC_F,SK_DDP,j,i,i_mag) - H_coeff(MC_FB,SK_DDP,i,j,i_mag) = H_coeff(MC_FB,SK_DDP,j,i,i_mag) - H_coeff(MC_G_SQ,SK_DDP,i,j,i_mag) = H_coeff(MC_G_SQ,SK_DDP,j,i,i_mag) - - H_coeff(MC_E,SK_DDD,i,j,i_mag) = H_coeff(MC_E,SK_DDD,j,i,i_mag) - H_coeff(MC_F,SK_DDD,i,j,i_mag) = H_coeff(MC_F,SK_DDD,j,i,i_mag) - H_coeff(MC_FB,SK_DDD,i,j,i_mag) = H_coeff(MC_FB,SK_DDD,j,i,i_mag) - H_coeff(MC_G_SQ,SK_DDD,i,j,i_mag) = H_coeff(MC_G_SQ,SK_DDD,j,i,i_mag) - - if (n_orb_sets(j) == 4) then - read *, H_coeff(MC_E,SK_SFS,i,j,i_mag) - read *, H_coeff(MC_F,SK_SFS,i,j,i_mag) - read *, H_coeff(MC_FB,SK_SFS,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_SFS,i,j,i_mag) - H_coeff(MC_E,SK_SFS,i,j,i_mag) = -H_coeff(MC_E,SK_SFS,i,j,i_mag) - H_coeff(MC_F,SK_SFS,i,j,i_mag) = -H_coeff(MC_F,SK_SFS,i,j,i_mag) - H_coeff(MC_FB,SK_SFS,i,j,i_mag) = -H_coeff(MC_FB,SK_SFS,i,j,i_mag) - - read *, H_coeff(MC_E,SK_PFS,i,j,i_mag) - read *, H_coeff(MC_F,SK_PFS,i,j,i_mag) - read *, H_coeff(MC_FB,SK_PFS,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_PFS,i,j,i_mag) - read *, H_coeff(MC_E,SK_PFP,i,j,i_mag) - read *, H_coeff(MC_F,SK_PFP,i,j,i_mag) - read *, H_coeff(MC_FB,SK_PFP,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_PFP,i,j,i_mag) - - read *, H_coeff(MC_E,SK_DFS,i,j,i_mag) - read *, H_coeff(MC_F,SK_DFS,i,j,i_mag) - read *, H_coeff(MC_FB,SK_DFS,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFS,i,j,i_mag) - read *, H_coeff(MC_E,SK_DFP,i,j,i_mag) - read *, H_coeff(MC_F,SK_DFP,i,j,i_mag) - read *, H_coeff(MC_FB,SK_DFP,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFP,i,j,i_mag) - read *, H_coeff(MC_E,SK_DFD,i,j,i_mag) - read *, H_coeff(MC_F,SK_DFD,i,j,i_mag) - read *, H_coeff(MC_FB,SK_DFD,i,j,i_mag) - read *, H_coeff(MC_G_SQ,SK_DFD,i,j,i_mag) - H_coeff(MC_E,SK_DFS,i,j,i_mag) = -H_coeff(MC_E,SK_DFS,i,j,i_mag) - H_coeff(MC_F,SK_DFS,i,j,i_mag) = -H_coeff(MC_F,SK_DFS,i,j,i_mag) - H_coeff(MC_FB,SK_DFS,i,j,i_mag) = -H_coeff(MC_FB,SK_DFS,i,j,i_mag) - H_coeff(MC_E,SK_DFP,i,j,i_mag) = -H_coeff(MC_E,SK_DFP,i,j,i_mag) - H_coeff(MC_F,SK_DFP,i,j,i_mag) = -H_coeff(MC_F,SK_DFP,i,j,i_mag) - H_coeff(MC_FB,SK_DFP,i,j,i_mag) = -H_coeff(MC_FB,SK_DFP,i,j,i_mag) - H_coeff(MC_E,SK_DFD,i,j,i_mag) = -H_coeff(MC_E,SK_DFD,i,j,i_mag) - H_coeff(MC_F,SK_DFD,i,j,i_mag) = -H_coeff(MC_F,SK_DFD,i,j,i_mag) - H_coeff(MC_FB,SK_DFD,i,j,i_mag) = -H_coeff(MC_FB,SK_DFD,i,j,i_mag) - - H_coeff(MC_E,SK_FFS,i,j,i_mag) = H_coeff(MC_E,SK_FFS,j,i,i_mag) - H_coeff(MC_F,SK_FFS,i,j,i_mag) = H_coeff(MC_F,SK_FFS,j,i,i_mag) - H_coeff(MC_FB,SK_FFS,i,j,i_mag) = H_coeff(MC_FB,SK_FFS,j,i,i_mag) - H_coeff(MC_G_SQ,SK_FFS,i,j,i_mag) = H_coeff(MC_G_SQ,SK_FFS,j,i,i_mag) - H_coeff(MC_E,SK_FFP,i,j,i_mag) = H_coeff(MC_E,SK_FFP,j,i,i_mag) - H_coeff(MC_F,SK_FFP,i,j,i_mag) = H_coeff(MC_F,SK_FFP,j,i,i_mag) - H_coeff(MC_FB,SK_FFP,i,j,i_mag) = H_coeff(MC_FB,SK_FFP,j,i,i_mag) - H_coeff(MC_G_SQ,SK_FFP,i,j,i_mag) = H_coeff(MC_G_SQ,SK_FFP,j,i,i_mag) - H_coeff(MC_E,SK_FFD,i,j,i_mag) = H_coeff(MC_E,SK_FFD,j,i,i_mag) - H_coeff(MC_F,SK_FFD,i,j,i_mag) = H_coeff(MC_F,SK_FFD,j,i,i_mag) - H_coeff(MC_FB,SK_FFD,i,j,i_mag) = H_coeff(MC_FB,SK_FFD,j,i,i_mag) - H_coeff(MC_G_SQ,SK_FFD,i,j,i_mag) = H_coeff(MC_G_SQ,SK_FFD,j,i,i_mag) - H_coeff(MC_E,SK_FFF,i,j,i_mag) = H_coeff(MC_E,SK_FFF,j,i,i_mag) - H_coeff(MC_F,SK_FFF,i,j,i_mag) = H_coeff(MC_F,SK_FFF,j,i,i_mag) - H_coeff(MC_FB,SK_FFF,i,j,i_mag) = H_coeff(MC_FB,SK_FFF,j,i,i_mag) - H_coeff(MC_G_SQ,SK_FFF,i,j,i_mag) = H_coeff(MC_G_SQ,SK_FFF,j,i,i_mag) - endif - - end do - end do - - !!!!!!!!! OVERLAP !!!!!!!!!!!! - - do i=1, n_types - j=i - read *, S_coeff(MC_E,SK_SSS,j,i,i_mag) - read *, S_coeff(MC_F,SK_SSS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_SSS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_SSS,j,i,i_mag) - read *, S_coeff(MC_E,SK_SPS,j,i,i_mag) - read *, S_coeff(MC_F,SK_SPS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_SPS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_SPS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PPS,j,i,i_mag) - read *, S_coeff(MC_F,SK_PPS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PPS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PPS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PPP,j,i,i_mag) - read *, S_coeff(MC_F,SK_PPP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PPP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PPP,j,i,i_mag) - read *, S_coeff(MC_E,SK_SDS,j,i,i_mag) - read *, S_coeff(MC_F,SK_SDS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_SDS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_SDS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PDS,j,i,i_mag) - read *, S_coeff(MC_F,SK_PDS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PDS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PDS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PDP,j,i,i_mag) - read *, S_coeff(MC_F,SK_PDP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PDP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PDP,j,i,i_mag) - read *, S_coeff(MC_E,SK_DDS,j,i,i_mag) - read *, S_coeff(MC_F,SK_DDS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DDS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DDS,j,i,i_mag) - read *, S_coeff(MC_E,SK_DDP,j,i,i_mag) - read *, S_coeff(MC_F,SK_DDP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DDP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DDP,j,i,i_mag) - read *, S_coeff(MC_E,SK_DDD,j,i,i_mag) - read *, S_coeff(MC_F,SK_DDD,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DDD,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DDD,j,i,i_mag) - if (n_orb_sets(i) == 4) then - read *, S_coeff(MC_E,SK_SFS,j,i,i_mag) - read *, S_coeff(MC_F,SK_SFS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_SFS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_SFS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PFS,j,i,i_mag) - read *, S_coeff(MC_F,SK_PFS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PFS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PFS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PFP,j,i,i_mag) - read *, S_coeff(MC_F,SK_PFP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PFP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PFP,j,i,i_mag) - read *, S_coeff(MC_E,SK_DFS,j,i,i_mag) - read *, S_coeff(MC_F,SK_DFS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DFS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFS,j,i,i_mag) - read *, S_coeff(MC_E,SK_DFP,j,i,i_mag) - read *, S_coeff(MC_F,SK_DFP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DFP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFP,j,i,i_mag) - read *, S_coeff(MC_E,SK_DFD,j,i,i_mag) - read *, S_coeff(MC_F,SK_DFD,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DFD,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFD,j,i,i_mag) - read *, S_coeff(MC_E,SK_FFS,j,i,i_mag) - read *, S_coeff(MC_F,SK_FFS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_FFS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_FFS,j,i,i_mag) - read *, S_coeff(MC_E,SK_FFP,j,i,i_mag) - read *, S_coeff(MC_F,SK_FFP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_FFP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_FFP,j,i,i_mag) - read *, S_coeff(MC_E,SK_FFD,j,i,i_mag) - read *, S_coeff(MC_F,SK_FFD,j,i,i_mag) - read *, S_coeff(MC_FB,SK_FFD,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_FFD,j,i,i_mag) - read *, S_coeff(MC_E,SK_FFF,j,i,i_mag) - read *, S_coeff(MC_F,SK_FFF,j,i,i_mag) - read *, S_coeff(MC_FB,SK_FFF,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_FFF,j,i,i_mag) - endif - end do - - do i=2, n_types - do j=1, i-1 - read *, S_coeff(MC_E,SK_SSS,j,i,i_mag) - read *, S_coeff(MC_F,SK_SSS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_SSS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_SSS,j,i,i_mag) - read *, S_coeff(MC_E,SK_SPS,j,i,i_mag) - read *, S_coeff(MC_F,SK_SPS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_SPS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_SPS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PPS,j,i,i_mag) - read *, S_coeff(MC_F,SK_PPS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PPS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PPS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PPP,j,i,i_mag) - read *, S_coeff(MC_F,SK_PPP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PPP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PPP,j,i,i_mag) - read *, S_coeff(MC_E,SK_SDS,j,i,i_mag) - read *, S_coeff(MC_F,SK_SDS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_SDS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_SDS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PDS,j,i,i_mag) - read *, S_coeff(MC_F,SK_PDS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PDS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PDS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PDP,j,i,i_mag) - read *, S_coeff(MC_F,SK_PDP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PDP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PDP,j,i,i_mag) - read *, S_coeff(MC_E,SK_DDS,j,i,i_mag) - read *, S_coeff(MC_F,SK_DDS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DDS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DDS,j,i,i_mag) - read *, S_coeff(MC_E,SK_DDP,j,i,i_mag) - read *, S_coeff(MC_F,SK_DDP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DDP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DDP,j,i,i_mag) - read *, S_coeff(MC_E,SK_DDD,j,i,i_mag) - read *, S_coeff(MC_F,SK_DDD,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DDD,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DDD,j,i,i_mag) - if (n_orb_sets(i) == 4) then - read *, S_coeff(MC_E,SK_SFS,j,i,i_mag) - read *, S_coeff(MC_F,SK_SFS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_SFS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_SFS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PFS,j,i,i_mag) - read *, S_coeff(MC_F,SK_PFS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PFS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PFS,j,i,i_mag) - read *, S_coeff(MC_E,SK_PFP,j,i,i_mag) - read *, S_coeff(MC_F,SK_PFP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_PFP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_PFP,j,i,i_mag) - read *, S_coeff(MC_E,SK_DFS,j,i,i_mag) - read *, S_coeff(MC_F,SK_DFS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DFS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFS,j,i,i_mag) - read *, S_coeff(MC_E,SK_DFP,j,i,i_mag) - read *, S_coeff(MC_F,SK_DFP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DFP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFP,j,i,i_mag) - read *, S_coeff(MC_E,SK_DFD,j,i,i_mag) - read *, S_coeff(MC_F,SK_DFD,j,i,i_mag) - read *, S_coeff(MC_FB,SK_DFD,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFD,j,i,i_mag) - read *, S_coeff(MC_E,SK_FFS,j,i,i_mag) - read *, S_coeff(MC_F,SK_FFS,j,i,i_mag) - read *, S_coeff(MC_FB,SK_FFS,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_FFS,j,i,i_mag) - read *, S_coeff(MC_E,SK_FFP,j,i,i_mag) - read *, S_coeff(MC_F,SK_FFP,j,i,i_mag) - read *, S_coeff(MC_FB,SK_FFP,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_FFP,j,i,i_mag) - read *, S_coeff(MC_E,SK_FFD,j,i,i_mag) - read *, S_coeff(MC_F,SK_FFD,j,i,i_mag) - read *, S_coeff(MC_FB,SK_FFD,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_FFD,j,i,i_mag) - read *, S_coeff(MC_E,SK_FFF,j,i,i_mag) - read *, S_coeff(MC_F,SK_FFF,j,i,i_mag) - read *, S_coeff(MC_FB,SK_FFF,j,i,i_mag) - read *, S_coeff(MC_G_SQ,SK_FFF,j,i,i_mag) - endif - - S_coeff(MC_E,SK_SSS,i,j,i_mag) = S_coeff(MC_E,SK_SSS,j,i,i_mag) - S_coeff(MC_F,SK_SSS,i,j,i_mag) = S_coeff(MC_F,SK_SSS,j,i,i_mag) - S_coeff(MC_FB,SK_SSS,i,j,i_mag) = S_coeff(MC_FB,SK_SSS,j,i,i_mag) - S_coeff(MC_G_SQ,SK_SSS,i,j,i_mag) = S_coeff(MC_G_SQ,SK_SSS,j,i,i_mag) - - read *, S_coeff(MC_E,SK_SPS,i,j,i_mag) - read *, S_coeff(MC_F,SK_SPS,i,j,i_mag) - read *, S_coeff(MC_FB,SK_SPS,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_SPS,i,j,i_mag) - S_coeff(MC_E,SK_SPS,i,j,i_mag) = - S_coeff(MC_E,SK_SPS,i,j,i_mag) - S_coeff(MC_F,SK_SPS,i,j,i_mag) = - S_coeff(MC_F,SK_SPS,i,j,i_mag) - S_coeff(MC_FB,SK_SPS,i,j,i_mag) = - S_coeff(MC_FB,SK_SPS,i,j,i_mag) - - S_coeff(MC_E,SK_PPS,i,j,i_mag) = S_coeff(MC_E,SK_PPS,j,i,i_mag) - S_coeff(MC_F,SK_PPS,i,j,i_mag) = S_coeff(MC_F,SK_PPS,j,i,i_mag) - S_coeff(MC_FB,SK_PPS,i,j,i_mag) = S_coeff(MC_FB,SK_PPS,j,i,i_mag) - S_coeff(MC_G_SQ,SK_PPS,i,j,i_mag) = S_coeff(MC_G_SQ,SK_PPS,j,i,i_mag) - - S_coeff(MC_E,SK_PPP,i,j,i_mag) = S_coeff(MC_E,SK_PPP,j,i,i_mag) - S_coeff(MC_F,SK_PPP,i,j,i_mag) = S_coeff(MC_F,SK_PPP,j,i,i_mag) - S_coeff(MC_FB,SK_PPP,i,j,i_mag) = S_coeff(MC_FB,SK_PPP,j,i,i_mag) - S_coeff(MC_G_SQ,SK_PPP,i,j,i_mag) = S_coeff(MC_G_SQ,SK_PPP,j,i,i_mag) - - read *, S_coeff(MC_E,SK_SDS,i,j,i_mag) - read *, S_coeff(MC_F,SK_SDS,i,j,i_mag) - read *, S_coeff(MC_FB,SK_SDS,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_SDS,i,j,i_mag) - - read *, S_coeff(MC_E,SK_PDS,i,j,i_mag) - read *, S_coeff(MC_F,SK_PDS,i,j,i_mag) - read *, S_coeff(MC_FB,SK_PDS,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_PDS,i,j,i_mag) - S_coeff(MC_E,SK_PDS,i,j,i_mag) = - S_coeff(MC_E,SK_PDS,i,j,i_mag) - S_coeff(MC_F,SK_PDS,i,j,i_mag) = - S_coeff(MC_F,SK_PDS,i,j,i_mag) - S_coeff(MC_FB,SK_PDS,i,j,i_mag) = - S_coeff(MC_FB,SK_PDS,i,j,i_mag) - - read *, S_coeff(MC_E,SK_PDP,i,j,i_mag) - read *, S_coeff(MC_F,SK_PDP,i,j,i_mag) - read *, S_coeff(MC_FB,SK_PDP,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_PDP,i,j,i_mag) - S_coeff(MC_E,SK_PDP,i,j,i_mag) = - S_coeff(MC_E,SK_PDP,i,j,i_mag) - S_coeff(MC_F,SK_PDP,i,j,i_mag) = - S_coeff(MC_F,SK_PDP,i,j,i_mag) - S_coeff(MC_FB,SK_PDP,i,j,i_mag) = - S_coeff(MC_FB,SK_PDP,i,j,i_mag) - - S_coeff(MC_E,SK_DDS,i,j,i_mag) = S_coeff(MC_E,SK_DDS,j,i,i_mag) - S_coeff(MC_F,SK_DDS,i,j,i_mag) = S_coeff(MC_F,SK_DDS,j,i,i_mag) - S_coeff(MC_FB,SK_DDS,i,j,i_mag) = S_coeff(MC_FB,SK_DDS,j,i,i_mag) - S_coeff(MC_G_SQ,SK_DDS,i,j,i_mag) = S_coeff(MC_G_SQ,SK_DDS,j,i,i_mag) - - S_coeff(MC_E,SK_DDP,i,j,i_mag) = S_coeff(MC_E,SK_DDP,j,i,i_mag) - S_coeff(MC_F,SK_DDP,i,j,i_mag) = S_coeff(MC_F,SK_DDP,j,i,i_mag) - S_coeff(MC_FB,SK_DDP,i,j,i_mag) = S_coeff(MC_FB,SK_DDP,j,i,i_mag) - S_coeff(MC_G_SQ,SK_DDP,i,j,i_mag) = S_coeff(MC_G_SQ,SK_DDP,j,i,i_mag) - - S_coeff(MC_E,SK_DDD,i,j,i_mag) = S_coeff(MC_E,SK_DDD,j,i,i_mag) - S_coeff(MC_F,SK_DDD,i,j,i_mag) = S_coeff(MC_F,SK_DDD,j,i,i_mag) - S_coeff(MC_FB,SK_DDD,i,j,i_mag) = S_coeff(MC_FB,SK_DDD,j,i,i_mag) - S_coeff(MC_G_SQ,SK_DDD,i,j,i_mag) = S_coeff(MC_G_SQ,SK_DDD,j,i,i_mag) - - if (n_orb_sets(j) == 4) then - read *, S_coeff(MC_E,SK_SFS,i,j,i_mag) - read *, S_coeff(MC_F,SK_SFS,i,j,i_mag) - read *, S_coeff(MC_FB,SK_SFS,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_SFS,i,j,i_mag) - S_coeff(MC_E,SK_SFS,i,j,i_mag) = -S_coeff(MC_E,SK_SFS,i,j,i_mag) - S_coeff(MC_F,SK_SFS,i,j,i_mag) = -S_coeff(MC_F,SK_SFS,i,j,i_mag) - S_coeff(MC_FB,SK_SFS,i,j,i_mag) = -S_coeff(MC_FB,SK_SFS,i,j,i_mag) - - read *, S_coeff(MC_E,SK_PFS,i,j,i_mag) - read *, S_coeff(MC_F,SK_PFS,i,j,i_mag) - read *, S_coeff(MC_FB,SK_PFS,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_PFS,i,j,i_mag) - read *, S_coeff(MC_E,SK_PFP,i,j,i_mag) - read *, S_coeff(MC_F,SK_PFP,i,j,i_mag) - read *, S_coeff(MC_FB,SK_PFP,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_PFP,i,j,i_mag) - - read *, S_coeff(MC_E,SK_DFS,i,j,i_mag) - read *, S_coeff(MC_F,SK_DFS,i,j,i_mag) - read *, S_coeff(MC_FB,SK_DFS,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFS,i,j,i_mag) - read *, S_coeff(MC_E,SK_DFP,i,j,i_mag) - read *, S_coeff(MC_F,SK_DFP,i,j,i_mag) - read *, S_coeff(MC_FB,SK_DFP,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFP,i,j,i_mag) - read *, S_coeff(MC_E,SK_DFD,i,j,i_mag) - read *, S_coeff(MC_F,SK_DFD,i,j,i_mag) - read *, S_coeff(MC_FB,SK_DFD,i,j,i_mag) - read *, S_coeff(MC_G_SQ,SK_DFD,i,j,i_mag) - S_coeff(MC_E,SK_DFS,i,j,i_mag) = -S_coeff(MC_E,SK_DFS,i,j,i_mag) - S_coeff(MC_F,SK_DFS,i,j,i_mag) = -S_coeff(MC_F,SK_DFS,i,j,i_mag) - S_coeff(MC_FB,SK_DFS,i,j,i_mag) = -S_coeff(MC_FB,SK_DFS,i,j,i_mag) - S_coeff(MC_E,SK_DFP,i,j,i_mag) = -S_coeff(MC_E,SK_DFP,i,j,i_mag) - S_coeff(MC_F,SK_DFP,i,j,i_mag) = -S_coeff(MC_F,SK_DFP,i,j,i_mag) - S_coeff(MC_FB,SK_DFP,i,j,i_mag) = -S_coeff(MC_FB,SK_DFP,i,j,i_mag) - S_coeff(MC_E,SK_DFD,i,j,i_mag) = -S_coeff(MC_E,SK_DFD,i,j,i_mag) - S_coeff(MC_F,SK_DFD,i,j,i_mag) = -S_coeff(MC_F,SK_DFD,i,j,i_mag) - S_coeff(MC_FB,SK_DFD,i,j,i_mag) = -S_coeff(MC_FB,SK_DFD,i,j,i_mag) - - S_coeff(MC_E,SK_FFS,i,j,i_mag) = S_coeff(MC_E,SK_FFS,j,i,i_mag) - S_coeff(MC_F,SK_FFS,i,j,i_mag) = S_coeff(MC_F,SK_FFS,j,i,i_mag) - S_coeff(MC_FB,SK_FFS,i,j,i_mag) = S_coeff(MC_FB,SK_FFS,j,i,i_mag) - S_coeff(MC_G_SQ,SK_FFS,i,j,i_mag) = S_coeff(MC_G_SQ,SK_FFS,j,i,i_mag) - S_coeff(MC_E,SK_FFP,i,j,i_mag) = S_coeff(MC_E,SK_FFP,j,i,i_mag) - S_coeff(MC_F,SK_FFP,i,j,i_mag) = S_coeff(MC_F,SK_FFP,j,i,i_mag) - S_coeff(MC_FB,SK_FFP,i,j,i_mag) = S_coeff(MC_FB,SK_FFP,j,i,i_mag) - S_coeff(MC_G_SQ,SK_FFP,i,j,i_mag) = S_coeff(MC_G_SQ,SK_FFP,j,i,i_mag) - S_coeff(MC_E,SK_FFD,i,j,i_mag) = S_coeff(MC_E,SK_FFD,j,i,i_mag) - S_coeff(MC_F,SK_FFD,i,j,i_mag) = S_coeff(MC_F,SK_FFD,j,i,i_mag) - S_coeff(MC_FB,SK_FFD,i,j,i_mag) = S_coeff(MC_FB,SK_FFD,j,i,i_mag) - S_coeff(MC_G_SQ,SK_FFD,i,j,i_mag) = S_coeff(MC_G_SQ,SK_FFD,j,i,i_mag) - S_coeff(MC_E,SK_FFF,i,j,i_mag) = S_coeff(MC_E,SK_FFF,j,i,i_mag) - S_coeff(MC_F,SK_FFF,i,j,i_mag) = S_coeff(MC_F,SK_FFF,j,i,i_mag) - S_coeff(MC_FB,SK_FFF,i,j,i_mag) = S_coeff(MC_FB,SK_FFF,j,i,i_mag) - S_coeff(MC_G_SQ,SK_FFF,i,j,i_mag) = S_coeff(MC_G_SQ,SK_FFF,j,i,i_mag) - endif - - end do - end do - - end do ! i_mag - - lambda_sq = lambda_sq**2 - H_coeff(MC_G_SQ,:,:,:,:) = H_coeff(MC_G_SQ,:,:,:,:)**2 - S_coeff(MC_G_SQ,:,:,:,:) = S_coeff(MC_G_SQ,:,:,:,:)**2 - - call print_NRL_TB_xml(trim(fname), header, is_orthogonal, & - is_magnetic, has_pair_repulsion, overlap_zero_limit, force_harrison_signs, label, & - n_types, n_mag, atomic_num, n_orbs, n_elecs, n_orb_sets, max_n_orb_sets, orb_set_type, atomic_mass, r_cut, screen_l, & - pair_rep_inner, pair_rep_outer, cutoff, lambda_sq, abcd, H_coeff, S_coeff) - - -end subroutine - -subroutine print_NRL_TB_xml(fname, header, is_orthogonal, & - is_magnetic, has_pair_repulsion, overlap_zero_limit, force_harrison_signs, label, & - n_types, n_mag, atomic_num, n_orbs, n_elecs, n_orb_sets, max_n_orb_sets, orb_set_type, atomic_mass, r_cut, screen_l, & - pair_rep_inner, pair_rep_outer, cutoff, lambda_sq, abcd, H_coeff, S_coeff) -implicit none - character(len=*), intent(in) :: fname, header - logical, intent(in) :: is_orthogonal, is_magnetic, has_pair_repulsion, overlap_zero_limit, force_harrison_signs - character(len=*), intent(in) :: label - integer, intent(in) :: n_types, n_mag - integer, intent(in) :: max_n_orb_sets - integer, intent(in) :: atomic_num(n_types), n_orbs(n_types), n_elecs(n_types), n_orb_sets(n_types), orb_set_type(n_types,max_n_orb_sets) - double precision, intent(in) :: atomic_mass(n_types), r_cut(n_types,n_types), screen_l(n_types,n_types) - double precision, allocatable :: pair_rep_inner(:,:), pair_rep_outer(:,:) - double precision, intent(in) :: cutoff - double precision, intent(in) :: lambda_sq(n_types,n_mag), abcd(4,3,n_types,n_types,n_mag) - double precision, intent(in) :: H_coeff(4,N_SK,n_types,n_types,n_mag), S_coeff(4,N_SK,n_types,n_types,n_mag) - - type(xmlf_t) :: xf - - integer :: i, j, k, i_mag, n_sk_use, max_spdf - - call xml_OpenFile(fname,xf) - ! call xml_AddXMLDeclaration(xf) - call xml_NewElement(xf,"NRL_TB_params") - call xml_AddAttribute(xf,"header_str",trim(header)) - call xml_AddAttribute(xf,"label",trim(label)) - - call xml_NewElement(xf,"header") - call xml_AddAttribute(xf,"is_orthogonal","" // is_orthogonal) - call xml_AddAttribute(xf,"is_magnetic", "" // is_magnetic) - call xml_AddAttribute(xf,"has_pair_repulsion", "" // has_pair_repulsion) - call xml_AddAttribute(xf,"overlap_zero_limit", "" // overlap_zero_limit) - call xml_AddAttribute(xf,"force_harrison_signs", "" // force_harrison_signs) - call xml_EndElement(xf,"header") - - call xml_NewElement(xf,"n_types") - call xml_AddAttribute(xf,"v", "" // n_types) - call xml_EndElement(xf,"n_types") - - call xml_NewElement(xf,"cutoff") - call xml_AddAttribute(xf,"v", "" // cutoff) - call xml_EndElement(xf,"cutoff") - - do i=1, n_types - call xml_NewElement(xf,"per_type_data") - call xml_AddAttribute(xf,"type", "" // i) - call xml_AddAttribute(xf,"atomic_num", "" // atomic_num(i)) - call xml_AddAttribute(xf,"atomic_mass", "" // atomic_mass(i)) - call xml_AddAttribute(xf,"n_orbs", "" // n_orbs(i)) - call xml_AddAttribute(xf,"n_elecs", "" // n_elecs(i)) - call xml_AddAttribute(xf,"n_orb_sets", "" // n_orb_sets(i)) - if (is_magnetic) then - call xml_AddAttribute(xf,"lambda_sq_up", "" // lambda_sq(i,1)) - call xml_AddAttribute(xf,"lambda_sq_down", "" // lambda_sq(i,2)) - else - call xml_AddAttribute(xf,"lambda_sq", "" // lambda_sq(i,1)) - endif - call xml_NewElement(xf,"orb_set_type") - ! call xml_AddArray(xf, orb_set_type(i,1:n_orb_sets(i)), '(i0,1x)') - call xml_AddCharacters(xf, "" // orb_set_type(i,1:n_orb_sets(i))) - call xml_EndElement(xf,"orb_set_type") - call xml_EndElement(xf,"per_type_data") - end do - - if (any(orb_set_type == ORB_F)) then - n_sk_use=20 - max_spdf = SPDF_F - else - n_sk_use=10 - max_spdf = SPDF_D - endif - - do i=1, n_types - do j=1, n_types - call xml_NewElement(xf,"per_pair_data") - call xml_AddAttribute(xf,"type1", "" // i) - call xml_AddAttribute(xf,"type2", "" // j) - call xml_AddAttribute(xf,"r_cut", "" // r_cut(i,j)) - call xml_AddAttribute(xf,"screen_l", "" // screen_l(i,j)) - if (has_pair_repulsion) then - call xml_AddAttribute(xf,"pair_rep_inner", "" // pair_rep_inner(i,j)) - call xml_AddAttribute(xf,"pair_rep_outer", "" // pair_rep_outer(i,j)) - endif - call xml_NewElement(xf,"abcd") - do k=SPDF_S, max_spdf - ! call xml_AddArray(xf,abcd(1:4,k,i,j), '(f20.10,1x)') - do i_mag=1, n_mag - call xml_AddCharacters(xf, "" // abcd(1:4,k,i,j,i_mag) // " ") - end do - call xml_AddNewLine(xf) - end do - call xml_EndElement(xf,"abcd") - call xml_NewElement(xf,"H_coeff") - do k=1, n_sk_use - ! call xml_AddArray(xf,H_coeff(1:4,k,i,j), '(f20.10,1x)') - do i_mag=1, n_mag - call xml_AddCharacters(xf, "" // H_coeff(1:4,k,i,j,i_mag) // " ") - end do - call xml_AddNewLine(xf) - end do - call xml_EndElement(xf,"H_coeff") - call xml_NewElement(xf,"S_coeff") - do k=1, n_sk_use - ! call xml_AddArray(xf,S_coeff(1:4,k,i,j), '(f20.10,1x)') - do i_mag=1, n_mag - call xml_AddCharacters(xf, "" // S_coeff(1:4,k,i,j,i_mag) // " ") - end do - call xml_AddNewLine(xf) - end do - call xml_EndElement(xf,"S_coeff") - call xml_EndElement(xf,"per_pair_data") - end do - end do - - call xml_EndElement(xf,"NRL_TB_params") - - call xml_Close(xf) -end subroutine - -end module NRL_TB_to_xml_module - -program NRL_TB_to_xml -use NRL_TB_to_xml_module -implicit none - - character(len=1024) fname - - call system_initialise() - - if (command_argument_count() == 0) then - fname = "tightbind.parms.NRL_TB.xml" - else if (command_argument_count() == 1) then - call get_command_argument(1, fname) - else - call system_abort("Usage: NRL_TB_to_xml [ output_filename ]") - endif - - call do_nrl_tb_params_to_xml(fname) - - call system_finalise() -end program - - diff --git a/src/Programs/QMMM_md_buf.f95 b/src/Programs/QMMM_md_buf.f95 deleted file mode 100644 index bf2e710270..0000000000 --- a/src/Programs/QMMM_md_buf.f95 +++ /dev/null @@ -1,1978 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!adaptive hybrid QMMM MD program. -!reads atoms & QM list & runs CP2K & writes movie xyz with QM flags -!uses the potential with momentum conservation, adding the corrective force only to the QM core and buffer atoms -!filepot_program can be e.g. /Users/csilla/QUIP/build.darwin_x86_64_g95/cp2k_filepot -!TODO: -!use the buffer carving of the potential force mixing routines. -#include "error.inc" - -program qmmm_md - - use libatoms_module - use cp2k_driver_module - use potential_module - use restraints_constraints_xml_module - - implicit none - - type(DynamicalSystem) :: ds - type(Atoms) :: my_atoms - integer :: i, n - character(len=STRING_LENGTH) :: Run_Type_array(6) !_MM_, QS, QMMM_EXTENDED or QMMM_CORE - - !Force calc. - type(Potential) :: cp2k_fast_pot, cp2k_slow_pot - type(Potential) :: evbsub_cp2k_fast_pot, evbsub_cp2k_slow_pot - type(Potential) :: pot, empty_qm_pot - type(Potential) :: evbsub_pot, evbsub_empty_qm_pot - real(dp) :: energy,check,TI_force, TI_corr - real(dp), dimension(:,:), allocatable :: f,f0,f1, add_force - - !QM list generation - !logical :: list_changed1 - !integer, pointer :: hybrid_mark_p(:) - !integer, pointer :: cluster_mark_p(:) - - !Spline - - type spline_pot - real(dp) :: from - real(dp) :: to - real(dp) :: dpot - end type spline_pot - - type(spline_pot) :: my_spline - real(dp) :: spline_pot_val - real(dp), pointer :: spline_pot_val_p(:) - - !Output XYZ - type(CInoutput) :: traj_xyz, latest_xyz -! type(CInoutput) :: xyz - character(len=STRING_LENGTH) :: backup_coord_file !output XYZ file - integer :: backup_i - - !Topology - character(len=STRING_LENGTH) :: driver_PSF_Print - integer :: Topology_Print_rate !_-1_ never, 0 print one at the 0th time step and use that - ! n>0 print at 0th and then every n-th step - type(Table) :: intrares_impropers - - !Input parameters - type(Dictionary) :: params_in - character(len=STRING_LENGTH) :: Run_Type1 !_MM_, QS, QMMM_EXTENDED or QMMM_CORE - character(len=STRING_LENGTH) :: Run_Type2 !_NONE_, MM, QMMM_CORE or MM_INTERNAL - integer :: IO_Rate !print coordinates at every n-th step - integer :: Thermostat_Type !_0_ none, 1 Langevin - real(dp) :: Thermostat_7_rs(2) - character(len=STRING_LENGTH) :: PSF_Print !_NO_PSF_, DRIVER_AT_0, DRIVER_EVERY_#, USE_EXISTING_PSF - real(dp) :: Time_Step - real(dp) :: Equilib_Time - real(dp) :: Run_Time - real(dp) :: Inner_Buffer_Radius !for hysteretic quantum - real(dp) :: Outer_Buffer_Radius ! region selection - real(dp) :: Inner_QM_Region_Radius, Inner_QM_Core_Region_Radius - real(dp) :: Outer_QM_Region_Radius, Outer_QM_Core_Region_Radius - real(dp) :: Min_Connect_Cutoff - real(dp) :: Simulation_Temperature - character(len=STRING_LENGTH) :: coord_file - character(len=STRING_LENGTH) :: latest_coord_file !output XYZ file - character(len=STRING_LENGTH) :: traj_file !output XYZ file - character(len=STRING_LENGTH) :: qm_list_filename, qm_core_list_filename !QM list file with a strange format - type(Table) :: qm_seed_extended, qm_seed_core - character(len=STRING_LENGTH) :: Residue_Library - character(len=STRING_LENGTH) :: restraint_constraint_xml_file - type(Extendable_Str) :: restraint_constraint_xml_es - integer :: Charge - real(dp) :: Langevin_Tau, Nose_Hoover_Tau - logical :: adaptive_Langevin - logical :: Buffer_general, do_general - logical :: Continue_it - logical :: reinitialise_qm_region - real(dp) :: avg_time - integer :: Seed - logical :: qm_region_pt_ctr, qm_core_region_pt_ctr - integer :: qm_region_atom_ctr, qm_core_region_atom_ctr - character(len=STRING_LENGTH) :: print_prop - logical :: print_forces - logical :: print_forces_at0 - real(dp) :: nneightol - logical :: Delete_Metal_Connections - real(dp) :: spline_from - real(dp) :: spline_to - real(dp) :: spline_dpot - logical :: use_spline - integer :: max_n_steps - integer :: update_QM_region_interval - character(len=STRING_LENGTH) :: cp2k_calc_args ! other args to calc(cp2k,...) - character(len=STRING_LENGTH) :: evb_args_str ! args to calc(EVB(cp2k)) - character(len=STRING_LENGTH) :: extra_calc_args ! extra args to mm and qm calcs (like FilePot_log) - character(len=STRING_LENGTH) :: filepot_program - character(len=STRING_LENGTH) :: mm_internal_init_args, mm_internal_param_filename, mm_internal_calc_args - - logical :: do_carve_cluster - logical :: use_create_cluster_info_for_core - real(dp) :: qm_region_ctr(3), qm_core_region_ctr(3) - real(dp) :: use_cutoff - real(dp) :: H_extra_heat_ctr(3), H_extra_heat_r(2), H_extra_heat_velo_factor - real(dp) :: nH_extra_heat_ctr(3), nH_extra_heat_r(2), nH_extra_heat_velo_factor - logical :: EVB - - logical :: distance_ramp - real(dp) :: distance_ramp_inner_radius, distance_ramp_outer_radius - character(len=128) :: weight_interpolation - - real(dp) :: max_move_since_calc_connect - real(dp) :: calc_connect_buffer - logical :: have_silica_potential, have_titania_potential, silica_pos_dep_charges, silica_add_23_body - real(dp) :: silica_charge_transfer - integer :: res_num_silica ! lam81 - integer :: stat - - logical have_QMMM_core, have_QMMM_extended - - integer :: error=ERROR_NONE - - real(dp), allocatable :: restraint_stuff(:,:) - real(dp) :: r - integer :: tmp_run_dir_i, copy_latest_every, copy - -! call system_initialise(verbosity=PRINT_ANALYSIS,enable_timing=.true.) -! call system_initialise(verbosity=PRINT_NERD,enable_timing=.true.) - call system_initialise(verbosity=PRINT_VERBOSE,enable_timing=.true.) -! call system_initialise(verbosity=PRINT_NORMAL,enable_timing=.true.) - call system_timer('program') - - !INPUT - call initialise(params_in) - call param_register(params_in, 'Run_Type1', 'MM', Run_Type1, help_string="Type of run1 (or only run if Run_Type2=NONE) QS, MM, QMMM_CORE, QMMM_EXTENDED") - call param_register(params_in, 'Run_Type2', 'NONE', Run_Type2, help_string="Type of run1 (or only run if Run_Type2=NONE) QS, MM, QMMM_CORE, QMMM_EXTENDED") - call param_register(params_in, 'IO_Rate', '1', IO_Rate, help_string="Frequency of output printing (every IO_Rate steps).") - call param_register(params_in, 'Thermostat_Type', '0', Thermostat_Type, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Thermostat_7_rs', '0.0 0.0', Thermostat_7_rs, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'PSF_Print', 'NO_PSF', PSF_Print, help_string="when to print PSF file: NO_PSF, EVERY_#, DRIVER_PRINT_AT_0, USE_EXISTING_PSF") - call param_register(params_in, 'Time_Step', '0.5', Time_Step, help_string="Time step in fs.") - call param_register(params_in, 'Equilib_Time', '0.0', Equilib_Time, help_string="Equilibration time in fs.") - call param_register(params_in, 'Run_Time', '0.5', Run_Time, help_string="Run time in fs.") - call param_register(params_in, 'Inner_Buffer_Radius', '0.0', Inner_Buffer_Radius, help_string="The inner radius of the hysteretic buffer of the QM region.") - call param_register(params_in, 'Outer_Buffer_Radius', '0.0', Outer_Buffer_Radius, help_string="The outer radius of the hysteretic buffer of the QM region.") - call param_register(params_in, 'Inner_QM_Region_Radius', '0.0', Inner_QM_Region_Radius, help_string="The inner radius of the QM region (around an atom list or a point in space).") - call param_register(params_in, 'Outer_QM_Region_Radius', '0.0', Outer_QM_Region_Radius, help_string="The outer radius of the QM region (around an atom list or a point in space).") - call param_register(params_in, 'Inner_QM_Core_Region_Radius', '0.0', Inner_QM_Core_Region_Radius, help_string="The inner radius of the core QM region (around an atom list or a point in space).") - call param_register(params_in, 'Outer_QM_Core_Region_Radius', '0.0', Outer_QM_Core_Region_Radius, help_string="The outer radius of the core QM region (around an atom list or a point in space).") - call param_register(params_in, 'Min_Connect_Cutoff', '0.0', Min_Connect_cutoff, help_string="Minimum value for connection calculation cutoff. Useful for making sure that QM region is reachable by neighbour hops when QM atoms are far apart.") - call param_register(params_in, 'Simulation_Temperature', '300.0', Simulation_Temperature, help_string="Simulation temperature in K.") - call param_register(params_in, 'coord_file', 'coord.xyz',coord_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'latest_coord_file', 'latest.xyz',latest_coord_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'traj_file', 'movie.xyz',traj_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Residue_Library', 'all_res.CHARMM.lib',Residue_Library, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'restraint_constraint_xml_file', '', restraint_constraint_xml_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Charge', '0', Charge, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Langevin_Tau', '500.0', Langevin_Tau, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Nose_Hoover_Tau', '74.0', Nose_Hoover_Tau, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Adaptive_Langevin', 'F', adaptive_Langevin, help_string="If true and Thermostat_Type uses Langevin, use Nose_Hoover_tau to make it adaptive Langevin (Jones & Leimkuhler)") - call param_register(params_in, 'Buffer_general', 'F', Buffer_general, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'Continue', 'F', Continue_it, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'reinitialise_qm_region', 'F', reinitialise_qm_region, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'avg_time', '10.0', avg_time, help_string="Averaging time for the calculation of averaged coordinates to smooth out bond vibrations for the topology calculation") - call param_register(params_in, 'Seed', '-1', Seed, help_string="No help yet. This source file was $LastChangedBy$") - - call param_register(params_in, 'qm_list_filename', '', qm_list_filename, & - help_string="Filename containing list of atoms for (extended) QM region (in funny format). Mutually exclusive with qm_region_pt_ctr and qm_region_atom_ctr") - call param_register(params_in, 'qm_region_pt_ctr', 'F', qm_region_pt_ctr, & - help_string="Use Cartesian point to center (extended) QM region. Mutually exclusive with qm_list_filename and qm_region_atom_ctr") - call param_register(params_in, 'qm_region_ctr', '(/0.0 0.0 0.0/)', qm_region_ctr, help_string="Centre of the (extended) QM region in space.") - call param_register(params_in, 'qm_region_atom_ctr', '0', qm_region_atom_ctr, help_string="Atom to center (extended) QM region about. Mutually exclusive with qm_region_pt_ctr and qm_list_filename") - - call param_register(params_in, 'qm_core_list_filename', '', qm_core_list_filename, & - help_string="Filename containing list of atoms for core QM region (in funny format). Mutually exclusive with qm_core_region_pt_ctr and qm_core_region_atom_ctr") - call param_register(params_in, 'qm_core_region_pt_ctr', 'F', qm_core_region_pt_ctr, & - help_string="Use Cartesian point to center core QM region. Mutually exclusive with qm_core_list_filename and qm_core_region_atom_ctr") - call param_register(params_in, 'qm_core_region_ctr', '(/0.0 0.0 0.0/)', qm_core_region_ctr, help_string="Centre of the QM core region in space.") - call param_register(params_in, 'qm_core_region_atom_ctr', '0', qm_core_region_atom_ctr, & - help_string="Atom to center core QM region about. Mutually exclusive with qm_core_region_pt_ctr and qm_core_list_filename") - - call param_register(params_in, 'print_prop', 'all', print_prop, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'print_forces', 'T', print_forces, help_string="whether to print forces at time>0 on the mainlog") - call param_register(params_in, 'print_forces_at0', 'T', print_forces_at0, help_string="whether to print forces at time=0 on the mainlog") - call param_register(params_in, 'nneightol', '1.2', nneightol, help_string="Nearest neighbour tolerance factor. Two atoms are bonded if d(a1,a2)<[CovRad(a1)+CovRad(a2)]*Neighbour_Tolerance.") - call param_register(params_in, 'Delete_Metal_Connections', 'T', Delete_Metal_Connections, help_string="Whether not to take into account bonds of non(C,H,O,N,P) elements.") - call param_register(params_in, 'spline_from', '0.0', spline_from, help_string="inner radius of the external spline potential") - call param_register(params_in, 'spline_to', '0.0', spline_to, help_string="outer radius of the external spline potential") - call param_register(params_in, 'spline_dpot', '0.0', spline_dpot, help_string="depth of the external spline potential") - call param_register(params_in, 'use_spline', 'F', use_spline, help_string="whether to use an external spline potential within a spherical shell around (/0. 0. 0./).") - call param_register(params_in, 'max_n_steps', '-1', max_n_steps, help_string="Maximum number of time steps to run") - call param_register(params_in, 'update_QM_region_interval', '1', update_QM_region_interval, help_string="interval between updates of QM region") - call param_register(params_in, 'cp2k_calc_args', '', cp2k_calc_args, help_string="calc args for cp2k_filepot") - call param_register(params_in, 'evb_args_str', '', evb_args_str, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'extra_calc_args', '', extra_calc_args, help_string="Extra args for mm and qm calc(), for things like FilePot_log, and arguments for buffer create_cluster_info") - call param_register(params_in, 'filepot_program', param_mandatory, filepot_program, help_string="Filepot program.") - call param_register(params_in, 'carve_cluster', 'F', do_carve_cluster, help_string="If true, carve cluster instead of doing QM/MM. Untested") - call param_register(params_in, 'use_create_cluster_info_for_core', 'F', use_create_cluster_info_for_core, help_string="If true, use cluster_create_inf() to create core, which does things like residue completing heuristics") - call param_register(params_in, 'calc_connect_buffer', '0.2', calc_connect_buffer, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'have_silica_potential', 'F', have_silica_potential, help_string="Whether there is a silica unit in the system to be treated with the Danny potential (implemented in CP2K).") - call param_register(params_in, 'have_titania_potential', 'F', have_titania_potential, help_string="Whether there is a titania unit in the system to be treated with the Danny potential (implemented in CP2K).") - call param_register(params_in, 'silica_add_23_body', 'T', silica_add_23_body, help_string="If true and if have_silica_potential is true, add bonds for silica 2- and 3-body terms to PSF") - call param_register(params_in, 'silica_pos_dep_charges', 'T', silica_pos_dep_charges, help_string="If true and if have_silica_potential is true, use variable charges for silicon and oxygen ions in silica residue") - call param_register(params_in, 'silica_charge_transfer', '2.4', silica_charge_transfer, help_string="Amount of charge transferred from Si to O in silica bulk, per formula unit") - - call param_register(params_in, 'res_num_silica', '1', res_num_silica, help_string="residue number of silica") !lam81 - call param_register(params_in, 'EVB', 'F', EVB, help_string="Whether to use the EVB MM potential instead of a simple MM.") - - call param_register(params_in, 'distance_ramp', 'F', distance_ramp, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'distance_ramp_inner_radius', '3.0', distance_ramp_inner_radius, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(params_in, 'distance_ramp_outer_radius', '4.0', distance_ramp_outer_radius, help_string="No help yet. This source file was $LastChangedBy$") - - call param_register(params_in, 'H_extra_heat_ctr', '0.0 0.0 0.0', H_extra_heat_ctr, help_string="spherical centre of the spherical shell where extra heating is introduced on hydrogen atoms") - call param_register(params_in, 'H_extra_heat_r', '0.0 -1.0', H_extra_heat_r, help_string="inner and outer radii of the spherical shell where extra heating is introduced on hydrogen atoms") - call param_register(params_in, 'H_extra_heat_velo_factor', '1.0', H_extra_heat_velo_factor, help_string="velocities of hydrogen atoms will be multiplied by this every time step") - call param_register(params_in, 'nH_extra_heat_ctr', '0.0 0.0 0.0', nH_extra_heat_ctr, help_string="spherical centre of the spherical shell where extra heating is introduced on nonhydrogen atoms") - call param_register(params_in, 'nH_extra_heat_r', '0.0 -1.0', nH_extra_heat_r, help_string="inner and outer radii of the spherical shell where extra heating is introduced on nonhydrogen atoms") - call param_register(params_in, 'nH_extra_heat_velo_factor', '1.0', nH_extra_heat_velo_factor, help_string="velocities of nonhydrogen atoms will be multiplied by this every time step") - call param_register(params_in, 'tmp_run_dir_i', '-1', tmp_run_dir_i, help_string="if >0, the cp2k run directory will be /tmp/cp2k_run_$tmp_run_dir_i$, and all input files are also copied here when first called") - call param_register(params_in, 'copy_latest_every', '-1', copy_latest_every, help_string="if >0, the copy the latest.xyz and the wfn files from the run directory /tmp/cp2k_run_$tmp_run_dir_i$ back to the home at this frequency -- only active when $tmp_run_dir_i$>0") - call param_register(params_in, 'mm_internal_init_args', '', mm_internal_init_args, help_string="init args for internal MM potential, used when Run_Type2==MM_INTERNAL") - call param_register(params_in, 'mm_internal_calc_args', '', mm_internal_calc_args, help_string="calc args for internal MM potential, used when Run_Type2==MM_INTERNAL") - call param_register(params_in, 'mm_internal_param_filename', '', mm_internal_param_filename, help_string="XML filename for internal MM potential, used when Run_Type2==MM_INTERNAL") - - if (.not. param_read_args(params_in)) then - call system_abort('could not parse argument line') - end if - - call finalise(params_in) - - !CHECK INPUT PARAMETERS - - if (Run_Type1(1:13) == 'QMMM_EXTENDED' .or. Run_Type2(1:13) == 'QMMM_EXTENDED') then - if (count((/qm_region_pt_ctr, qm_region_atom_ctr /= 0, len_trim(qm_list_filename) /= 0 /)) /= 1) then - call system_abort("Doing Run_Type1="//trim(Run_Type1)//" Run_Type2="//trim(Run_Type2)//& - ", need exactly one of qm_region_pt_ctr, qm_region_atom_ctr="//qm_region_atom_ctr// & - "/=0, len_trim(qm_list_filename='"//trim(qm_list_filename)//"') /= 0") - endif - endif - if (Run_Type1(1:9) == 'QMMM_CORE' .or. Run_Type2(1:9) == 'QMMM_CORE') then - if (count((/qm_core_region_pt_ctr, qm_core_region_atom_ctr /= 0, len_trim(qm_core_list_filename) /= 0 /)) /= 1) then - call system_abort("Doing Run_Type1="//trim(Run_Type1)//" Run_Type2="//trim(Run_Type2)//& - ", need exactly one of qm_core_region_pt_ctr, qm_core_region_atom_ctr="//qm_core_region_atom_ctr// & - "/=0, len_trim(qm_core_list_filename='"//trim(qm_core_list_filename)//"') /= 0") - endif - endif - - if (Seed.gt.0) call system_reseed_rng(Seed) -! call hello_world(seed, common_seed) - -!check different run types - Run_Type_array(1) ='QS' - Run_Type_array(2) ='QMMM_EXTENDED' - Run_Type_array(3) ='QMMM_CORE' - Run_Type_array(4) ='MM' - Run_Type_array(5) ='NONE' - Run_Type_array(6) = 'MM_INTERNAL' - - if (.not.any(Run_Type1.eq.Run_Type_array(1:4))) & - call system_abort('Run_Type1 must be one of "QS", "MM", "QMMM_CORE", "QMMM_EXTENDED"') - if (.not.any(Run_Type2.eq.Run_Type_array(3:6))) & - call system_abort('Run_Type1 must be one of "NONE", "MM", "QMMM_CORE", "MM_INTERNAL"') - if ( (trim(Run_Type1).eq.trim(Run_Type2) .or. & - any(trim(Run_Type1).eq.(/'MM','QS'/))) .and. & - trim(Run_Type2).ne.'NONE' ) then - Run_Type2 = 'NONE' - call print('RunType2 set to NONE') - endif - if ((trim(Run_Type1)).eq.'QMMM_EXTENDED' .and..not.any(trim(Run_Type2).eq.Run_Type_array(3:6))) & - call system_abort('Run_Type1 must be higher level of accuracy than Run_Type2') - if ((trim(Run_Type1)).eq.'QMMM_CORE' .and..not.any(trim(Run_Type2).eq.Run_Type_array(4:6))) & - call system_abort('Run_Type1 must be higher level of accuracy than Run_Type2') - -!check PSF printing - if (trim(PSF_Print) == 'NO_PSF' .or. trim(PSF_Print) == 'USE_EXISTING_PSF') then - topology_print_rate=-1 - driver_PSF_Print=PSF_Print - else if (trim(PSF_Print) == 'DRIVER_AT_0') then - topology_print_rate=0 - else if (len(PSF_Print) > 13) then - if (PSF_Print(1:13) == 'DRIVER_EVERY_') then - read(unit=PSF_Print(14:len_trim(PSF_Print)),fmt=*,iostat=stat) topology_print_rate - if (stat /= 0) & - call system_abort("PSF_Print='"//trim(PSF_Print)//"' unable to parse N from DRIVER_EVERY_N '"// & - PSF_Print(14:len_trim(PSF_Print))//"'") - else - call system_abort("Unknown PSF_Print '"//trim(PSF_Print)//"'") - endif - else - call system_abort("Unknown PSF_Print '"//trim(PSF_Print)//"'") - endif - - !PRINT INPUT PARAMETERS - call print('Run parameters:') - call print(' filepot_program '//trim(filepot_program)) - call print(' Run_Type1 '//Run_Type1) - call print(' Run_Type2 '//Run_Type2) - call print(' EVB (MMpot) '//EVB) - call print(' IO_Rate '//IO_Rate) - if (Thermostat_Type.eq.0) then - call print(' Thermostat_Type 0: None, NVE') - elseif (Thermostat_Type.eq.1) then - call print(' Thermostat_Type 1: Langevin everywhere') - call print(' Langevin_Tau '//Langevin_Tau) - call print(' adaptive Langevin '//adaptive_Langevin) - if (adaptive_Langevin) then - call print(' Adaptive Langevin, Nose_Hoover_Tau '//Nose_Hoover_Tau) - endif - elseif (Thermostat_Type.eq.2) then - call print(' Thermostat_Type 1: Nose-Hoover everywhere') - call print(' Nose_Hoover_Tau '//Nose_Hoover_Tau) - elseif (Thermostat_Type.eq.3) then - call print(' Thermostat_Type 3: separate Nose-Hoover for each atom') - call print(' Nose_Hoover_Tau '//Nose_Hoover_Tau) - elseif (Thermostat_Type.eq.4) then - call print(' Thermostat_Type 4: separate Nose-Hoover-Langevin for each atom') - call print(' Langevin_Tau ' // Langevin_Tau // ' Nose_Hoover_Tau '//Nose_Hoover_Tau) - elseif (Thermostat_Type.eq.5) then - call print(' Thermostat_Type 5: QM core & buffer heavy atoms in the 1st thermostat') - call print(' QM core & buffer H in the 2nd thermostat') - call print(' classical O & H in the 3rd thermostat') - call print(' Langevin_Tau '//Langevin_Tau // ', Nose_Hoover_Tau ' // Nose_Hoover_Tau) - elseif (Thermostat_Type.eq.6) then - call print(' Thermostat_Type 6: 3 regions (QM, buffer, MM) x 2 types (H, heavy)') - call print(' each with its own Nose-Hoover thermostat') - call print(' Nose_Hoover_Tau ' // Nose_Hoover_Tau) - elseif (Thermostat_Type.eq.7) then - call print(' Thermostat_Type 7: 3 regions, by radius,') - call print(' each with its own Nose-Hoover thermostat') - call print(' Nose_Hoover_Tau ' // Nose_Hoover_Tau) - elseif (Thermostat_Type.eq.8) then - call print(' Thermostat_Type 8: separate Langevin for each atom, useful only for adaptive Langevin') - call print(' Langevin_Tau ' // Langevin_Tau) - call print(' Nose_Hoover_Tau ' // Nose_Hoover_Tau) - if (.not.adaptive_Langevin) then - call system_abort("Thermostat_Type=8 makes sense only for adaptive langevin and Nose_Hoover_Tau > 0, otherwise just use regular Langevin Thermostat_Type=1") - endif - else - call print(' Thermostat_Type '//thermostat_type//' unknown') - endif - call print(' PSF_Print '//PSF_Print) - call print(' nneightol '//nneightol) - call print(' Time_Step '//round(Time_Step,3)) - call print(' Equilib_Time '//round(Equilib_Time,3)) - call print(' Run_Time '//round(Run_Time,3)) - call print(' max_n_steps '//max_n_steps) - call print(' Inner_Buffer_Radius '//round(Inner_Buffer_Radius,3)) - call print(' Outer_Buffer_Radius '//round(Outer_Buffer_Radius,3)) - call print(' Min_Connect_Cutoff '//round(Min_Connect_cutoff,3)) - call print(' Simulation_Temperature '//round(Simulation_Temperature,3)) - call print(' coord_file '//coord_file) - call print(' latest_coord_file '//latest_coord_file) - call print(' traj_file '//traj_file) - if (len_trim(qm_list_filename) /= 0) then - call print(' qm_list_filename '//trim(qm_list_filename)) - else if (qm_region_pt_ctr .or. qm_region_atom_ctr /= 0) then - if (qm_region_pt_ctr) then - call print(' QM extended region is centred around qm_region_ctr= '//qm_region_ctr) - else - call print(' QM extended region is centred around atom '//qm_region_atom_ctr) - qm_region_pt_ctr = .true. - endif - call print(' Inner_QM_Region_Radius '//round(Inner_QM_Region_Radius,3)) - call print(' Outer_QM_Region_Radius '//round(Outer_QM_Region_Radius,3)) - call print(' use_spline '//use_spline) - if (use_spline) then - call print(' spline_from '//spline_from) - call print(' spline_to '//spline_to) - call print(' spline_dpot '//spline_dpot) - ! initialise spline - my_spline%from = spline_from - my_spline%to = spline_to - my_spline%dpot = spline_dpot - endif - endif - if (len_trim(qm_core_list_filename) /= 0) then - call print(' qm_core_list_filename '//trim(qm_core_list_filename)) - else if (qm_core_region_pt_ctr .or. qm_core_region_atom_ctr /= 0) then - if (qm_core_region_pt_ctr) then - call print(' QM core is centred around qm_core_region_ctr= '//qm_core_region_ctr) - else - call print(' QM core is centred around atom '//qm_core_region_atom_ctr) - qm_core_region_pt_ctr = .true. - endif - call print(' Inner_QM_Core_Region_Radius '//round(Inner_QM_Core_Region_Radius,3)) - call print(' Outer_QM_Core_Region_Radius '//round(Outer_QM_Core_Region_Radius,3)) - endif - call print(' Residue_Library '//Residue_Library) - call print(' restraint_constraint_xml_file '//restraint_constraint_xml_file) - call print(' Charge '//Charge) - call print(' Buffer_general '//Buffer_general) - call print(' Continue '//Continue_it) - call print(' reinitialise_qm_region '//reinitialise_qm_region) - call print(' avg_time '//avg_time) - call print(' Seed '//Seed) - call print(' Properties to print '//trim(print_prop)) - call print(' Print forces? '//print_forces) - call print(' Print forces at t=0? '//print_forces_at0) - call print(' carve_cluster '//do_carve_cluster) - call print(' have_silica_potential '//have_silica_potential) - call print(' have_titania_potential '//have_titania_potential) - if(have_silica_potential) call print(' res_num_silica '//res_num_silica) !lam81 - call print(' evb_args_str '//trim(evb_args_str)) - call print(' cp2k_calc_args '//trim(cp2k_calc_args)) - call print(' filepot_program '//trim(filepot_program)) - call print(' tmp_run_dir_i '//tmp_run_dir_i) - call print(' copy_latest_every '//copy_latest_every) - call print('---------------------------------------') - call print('') - -! STARTS HERE - - if (is_file_readable(trim(traj_file))) then - call print("WARNING: traj_file " // trim(traj_file) // " exists, backing it up") - backup_i=1 - backup_coord_file=trim(traj_file)//".backup_"//backup_i - do while (is_file_readable(trim(backup_coord_file))) - backup_i = backup_i + 1 - backup_coord_file=trim(traj_file)//".backup_"//backup_i - end do - call print("WARNING: to backup_coord_file " // trim(backup_coord_file)) - call system("cp "//trim(traj_file)//" "//trim(backup_coord_file)) - endif - - call initialise(traj_xyz,traj_file,action=OUTPUT) - - !READ COORDINATES - - call print('Reading in the coordinates from file '//trim(coord_file)//'...') - call read(my_atoms,coord_file) - - call initialise(ds,my_atoms) - - if (Continue_it) then - if (get_value(my_atoms%params,'Time',ds%t)) then - call print('Found Time in atoms%params'//ds%t) - endif - endif - - if (len_trim(restraint_constraint_xml_file) > 0) then - call initialise(restraint_constraint_xml_es) - call read(restraint_constraint_xml_es, restraint_constraint_xml_file, convert_to_string=.true.) - call init_restraints_constraints(ds, string(restraint_constraint_xml_es)) - call finalise(restraint_constraint_xml_es) - endif - - ds%avg_time = avg_time - - !THERMOSTAT - call add_QMMM_md_buf_thermostats(ds, thermostat_type, Simulation_Temperature) - call set_thermostat_masses(ds%atoms, Thermostat_Type, Simulation_Temperature, & - Inner_QM_Region_Radius, Outer_QM_Region_Radius, Inner_Buffer_Radius, Outer_Buffer_Radius, Thermostat_7_rs) - - call finalise(my_atoms) - call add_property(ds%atoms,'pot',0.0_dp) ! always do this, it's just 0 if spline isn't active - no need to change print_props - - if (.not. has_property(ds%atoms, 'force')) call add_property(ds%atoms, 'force', 0.0_dp, n_cols=3) - - !PRINT CONSTRAINTS AND RESTRAINTS - - if (ds%Nconstraints > 0) then - call print("Constraints:") - call print(ds%constraint) - end if - if (ds%Nrestraints > 0) then - call print("Restraints:") - call print(ds%restraint) - end if - - !SET VELOCITIES - - if (.not.Continue_it) then - call rescale_velo(ds,Simulation_Temperature) - endif - - !CALC. CONNECTIONS - -! call set_cutoff(ds%atoms,0.0_dp) !use the covalent radii to determine bonds - use_cutoff = max(Min_Connect_Cutoff, Outer_Buffer_Radius) - use_cutoff = max(use_cutoff, Outer_QM_Region_Radius) - if (distance_ramp) use_cutoff = max(use_cutoff, distance_ramp_outer_radius) - if (have_silica_potential) use_cutoff = max(SILICA_2BODY_CUTOFF, Outer_Buffer_Radius) - if (have_titania_potential) use_cutoff = max(TITANIA_2BODY_CUTOFF, Outer_Buffer_Radius) - call set_cutoff(ds%atoms,use_cutoff+calc_connect_buffer) - call calc_connect(ds%atoms) - if (Delete_Metal_Connections) call delete_metal_connects(ds%atoms) - - !READ / CREATE QM LIST + THERMOSTATTING - - !QM BUFFER + THERMOSTATTING - ! set general/heavy atom selection before QM region selection -! call set_value(ds%atoms%params,'Buffer_general',Buffer_general) -! call print('set Buffer_general into ds%atoms%params') -! if (get_value(ds%atoms%params,'Buffer_general',do_general)) then -! call print('Found Buffer_general in atoms%params'//do_general) -! buffer_general=do_general -! else -! call print('Not found Buffer_general in atoms%params') -! buffer_general=.false. -! endif - do_general=Buffer_general - - ds%atoms%nneightol = nneightol - ! topology calculation - if (trim(Run_Type1).ne.'QS') then - if (.not.Continue_it) then - ! residues are needed here for heuristics based on them (e.g. don't break residue, don't break molecule) - ! in update_QM_region() (and also buffer cluster creating in potential_simple_calc()) - call set_value(ds%atoms%params,'Library',trim(Residue_Library)) - call map_into_cell(ds%atoms) - call calc_dists(ds%atoms) - call create_residue_labels_arb_pos(ds%atoms,do_CHARMM=.true.,intrares_impropers=intrares_impropers,& - find_silica_residue=have_silica_potential,silica_pos_dep_charges=silica_pos_dep_charges, & - silica_charge_transfer=silica_charge_transfer, have_titania_potential=have_titania_potential) - endif - endif - - !QM CORE - have_QMMM_core=.false. - if (trim(Run_Type1) == 'QMMM_CORE' .or. trim(Run_Type2) == 'QMMM_CORE') have_QMMM_core =.true. - have_QMMM_extended=.false. - if (trim(Run_Type1) == 'QMMM_EXTENDED' .or. trim(Run_Type2) == 'QMMM_EXTENDED') have_QMMM_extended =.true. - - if (have_QMMM_core .or. have_QMMM_extended) then - - !even if continue, we need the QM seed. -- no marks overwritten! - if (Continue_it .and. len_trim(qm_list_filename)/=0) call read_qmlist(ds%atoms,qm_list_filename,qm_seed_extended) - if (Continue_it .and. len_trim(qm_core_list_filename)/=0) call read_qmlist(ds%atoms,qm_core_list_filename,qm_seed_core) - - !(re)initialise QM region -- marks overwritten! - if (reinitialise_qm_region .or. .not. Continue_it) then - if (have_QMMM_extended) then - call update_QM_region(ds%atoms, '_extended', qm_region_pt_ctr, qm_region_ctr, qm_region_atom_ctr, & - qm_list_filename, Inner_QM_Region_Radius, Outer_QM_Region_Radius, buffer_general, use_create_cluster_info_for_core, & - first_time=.true., qm_seed=qm_seed_extended, error=error) - HANDLE_ERROR(error) - endif - if (have_QMMM_core) then - call update_QM_region(ds%atoms, '_core', qm_core_region_pt_ctr, qm_core_region_ctr, qm_core_region_atom_ctr, & - qm_core_list_filename, Inner_QM_Core_Region_Radius, Outer_QM_Core_Region_Radius, buffer_general, use_create_cluster_info_for_core, & - first_time=.true., qm_seed=qm_seed_core, error=error) - HANDLE_ERROR(error) - endif - - call print('hybrid, hybrid_mark and old_hybrid_mark properties added') - endif ! .not. Continue_it - - endif ! have_QMMM_core || have_QMMM_extended - call map_into_cell(ds%atoms) - call calc_dists(ds%atoms) - - !TOPOLOGY - - if (trim(Run_Type1).ne.'QS') then - if (.not.Continue_it) then - ! topology check cannot be done until after QM region has been marked - call check_topology(ds%atoms) - end if - end if - - - !CHARGE - - if (trim(Run_Type1).eq.'QS') then - call set_value(ds%atoms%params,'Charge',Charge) - endif - - !INIT. POTENTIAL - - !only QMMM_EXTENDED for the moment ************** - !if (trim(Run_Type1).ne.'QMMM_EXTENDED') call system_abort('ONLY QMMM_EXTENDED') - - ! set up pot - if (trim(Run_Type2) == 'NONE') then ! no force mixing - if (EVB.and.trim(Run_Type1)=='MM') then - call print("SETUP_POT EVBSUB_POT") - call setup_pot(evbsub_pot, Run_Type1, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - call initialise(pot,args_str='EVB=T', & - !' topology_suffix1=_EVB1 topology_suffix2=_EVB2'// & - !' form_bond={1 2} break_bond={2 6} ', & - pot1=evbsub_pot) - call print("INITIALISE_POT EVB") - else - call print("SETUP_POT POT") - call setup_pot(pot, Run_Type1, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - endif - ! set up mm only pot, in case we need it for empty QM core - if (EVB) then - call print("SETUP_POT EVBSUB_EMPTY_QM_POT") - call setup_pot(evbsub_empty_qm_pot, 'MM', filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - call initialise(empty_qm_pot,args_str='EVB=T', & - !' topology_suffix1=_EVB1 topology_suffix2=_EVB2'// & - !' form_bond={1 2} break_bond={2 6} ', & - pot1=evbsub_empty_qm_pot) - call print("INITIALISE_POT EVB") - else - call print("SETUP_POT EMPTY_QM_POT") - call setup_pot(empty_qm_pot, 'MM', filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - endif - else ! doing force mixing - if (EVB.and.trim(Run_Type1)=='MM') then - call print("WARNING: Force Mixing with MM as the slow potential!") - call print("SETUP_POT EVBSUB_CP2K_SLOW_POT") - call setup_pot(evbsub_cp2k_slow_pot, Run_Type1, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - call initialise(cp2k_slow_pot,args_str='EVB=T', & - !' topology_suffix1=_EVB1 topology_suffix2=_EVB2'// & - !' form_bond={1 2} break_bond={2 6} ', & - pot1=evbsub_cp2k_slow_pot) - call print("INITIALISE_POT EVB") - else - call print("SETUP_POT CP2K_SLOW_POT") - call setup_pot(cp2k_slow_pot, Run_Type1, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - endif - if (EVB.and.trim(Run_Type2)=='MM') then - call print("SETUP_POT EVBSUB_CP2K_FAST_POT") - call setup_pot(evbsub_cp2k_fast_pot, Run_Type2, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - call initialise(cp2k_fast_pot,args_str='EVB=T', & - !' topology_suffix1=_EVB1 topology_suffix2=_EVB2'// & - !' form_bond={1 2} break_bond={2 6} ', & - pot1=evbsub_cp2k_fast_pot) - call print("INITIALISE_POT EVB") - else - call print("SETUP_POT CP2K_FAST_POT") - call setup_pot(cp2k_fast_pot, Run_Type2, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - ! recalculate connectivity since cutoff of mm_internal - if (cutoff(cp2k_fast_pot) > use_cutoff) then - use_cutoff = cutoff(cp2k_fast_pot) - call set_cutoff(ds%atoms,use_cutoff+calc_connect_buffer) - call calc_connect(ds%atoms) - if (Delete_Metal_Connections) call delete_metal_connects(ds%atoms) - end if - endif - if (distance_ramp) then - if (.not. qm_region_pt_ctr) call system_abort("Distance ramp needs qm_region_pt_ctr (or qm_region_atom_ctr)") - weight_interpolation='distance_ramp' - else - weight_interpolation='hop_ramp' - endif - call initialise(pot,args_str='ForceMixing=T use_buffer_for_fitting=T add_cut_H_in_fitlist=T'// & - ' method=conserve_momentum conserve_momentum_weight_method=mass calc_weights=T'// & - ' min_images_only=F lotf_nneighb_only=F fit_hops=1 hysteretic_buffer=T'// & - ' hysteretic_buffer_inner_radius='//Inner_Buffer_Radius// & - ' hysteretic_buffer_outer_radius='//Outer_Buffer_Radius// & - ' hysteretic_buffer_nneighb_only=T'//& - ' weight_interpolation='//trim(weight_interpolation)// & - ' distance_ramp_inner_radius='//distance_ramp_inner_radius//' distance_ramp_outer_radius='//distance_ramp_outer_radius// & - ' single_cluster=T little_clusters=F carve_cluster='//do_carve_cluster & -!next line is for playing with silica carving -! //' even_electrons=T terminate=T cluster_same_lattice=T termination_clash_check=T' & - //' have_silica_potential='//have_silica_potential// ' res_num_silica'//res_num_silica & !lam81 - //' have_titania_potential='//have_titania_potential & - //' construct_buffer_use_only_heavy_atoms='//(.not.(buffer_general)), & - pot1=cp2k_fast_pot, pot2=cp2k_slow_pot) - call print('INITIALISE_POT ForceMixing=T use_buffer_for_fitting=T add_cut_H_in_fitlist=T'// & - ' method=conserve_momentum conserve_momentum_weight_method=mass calc_weights=T'// & - ' min_images_only=F lotf_nneighb_only=F fit_hops=1 hysteretic_buffer=T'// & - ' hysteretic_buffer_inner_radius='//Inner_Buffer_Radius// & - ' hysteretic_buffer_outer_radius='//Outer_Buffer_Radius// & - ' hysteretic_buffer_nneighb_only=T'//& - ' weight_interpolation='//trim(weight_interpolation)// & - ' distance_ramp_inner_radius='//distance_ramp_inner_radius//' distance_ramp_outer_radius='//distance_ramp_outer_radius// & - ' single_cluster=T little_clusters=F carve_cluster='//do_carve_cluster // & - ' construct_buffer_use_only_heavy_atoms='//(.not.(buffer_general))) - - ! if Run_Type2 = QMMM_CORE, we'll crash if QM core is ever empty - if (trim(Run_Type2) == 'MM') then - if (EVB) then - call print("SETUP_POT EVBSUB_EMPTY_QM_POT") - call setup_pot(evbsub_empty_qm_pot, Run_Type2, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - call initialise(empty_qm_pot,args_str='EVB=T', & - !' topology_suffix1=_EVB1 topology_suffix2=_EVB2'// & - !' form_bond={1 2} break_bond={2 6} ', & - pot1=evbsub_empty_qm_pot) - call print("INITIALISE_POT EVB") - else - call print("SETUP_POT EMPTY_QM_POT") - call setup_pot(empty_qm_pot, Run_Type2, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - endif - endif - endif - - !allocate force lists - allocate(f0(3,ds%N),f1(3,ds%N),f(3,ds%N)) - -!FIRST STEP - first step of velocity verlet - - call system_timer('step') - - n = 0 - - !FORCE - - if (topology_print_rate >= 0) driver_PSF_Print='DRIVER_PRINT_AND_SAVE' -call print("MAIN CALL CALC EVB") -call print(pot) - call do_calc_call(pot, empty_qm_pot, ds%atoms, Run_Type1, Run_Type2, EVB, qm_region_pt_ctr, qm_core_region_pt_ctr, & - distance_ramp, qm_region_ctr, qm_core_region_ctr, cp2k_calc_args, evb_args_str, extra_calc_args, do_carve_cluster, driver_PSF_Print, f1, energy) -call print("MAIN CALLED CALC EVB") - if (topology_print_rate >= 0) driver_PSF_Print='USE_EXISTING_PSF' - - !spline force calculation, if needed - if (qm_region_pt_ctr.and.use_spline) then - allocate(add_force(1:3,1:ds%atoms%N)) - call verbosity_push_decrement() - call print('Force due to added spline potential (eV/A):') - call print('atom F(x) F(y) F(z)') - if (.not.(assign_pointer(ds%atoms, "pot", spline_pot_val_p))) & - call system_abort("couldn't find pot property") - do i = 1, ds%atoms%N - add_force(1:3,i) = spline_force(ds%atoms,i,my_spline, pot=spline_pot_val) - spline_pot_val_p(i) = spline_pot_val - call print(' '//i//' '//round(add_force(1,i),5)//' '//round(add_force(2,i),5)//' '//round(add_force(3,i),5)) - enddo - call verbosity_pop() - call print('Sum of the forces: '//sum(add_force(1,1:ds%atoms%N))//' '//sum(add_force(2,1:ds%atoms%N))//' '//sum(add_force(3,1:ds%atoms%N))) - f = sumBUFFER(f1+add_force,ds%atoms) - deallocate(add_force) - else - f = sum0(f1,ds%atoms) - endif - - ! first call to get_restraint_stuff will allocate restraint_stuff - if (ds%Nrestraints > 0) call get_restraint_stuff(ds, restraint_stuff) - - !THERMOSTATTING now - hybrid_mark was updated only in calc - call set_thermostat_regions(ds%atoms, Thermostat_Type, Thermostat_7_rs, qm_region_ctr) - call set_thermostat_masses(ds%atoms, Thermostat_Type, Simulation_Temperature, & - Inner_QM_Region_Radius, Outer_QM_Region_Radius, Inner_Buffer_Radius, Outer_Buffer_Radius, Thermostat_7_rs) - - !PRINT DS,CONSTRAINT - call ds_print_status(ds, 'E',energy) - if (ds%Nrestraints > 0) call print_restraint_stuff(ds, restraint_stuff, 'E') - call print(ds%thermostat) - - call set_value(ds%atoms%params,'Time',ds%t) - - if (ds%Nconstraints > 0) then - call print(ds%constraint) - do i=1,ds%Nconstraints - call print("TI"//i//" Time[fs] Constraint_value Lambda_R Lambda_V Z_xi") - call print("TI"//i//" "//ds%t//" "//ds%constraint(i)%C//" "// & - ds%constraint(i)%lambdaR//" "// & - ds%constraint(i)%lambdaV//" "// & - ds%constraint(i)%Z_coll) - if (ds%constraint(i)%N /= 3) then - call print("WARNING: constraint " // i // " does not involve 3 atoms, ignoring", PRINT_ALWAYS) - else - TI_force = force_on_collective_variable(ds%atoms, (/ f(1:3,ds%constraint(i)%atom(1)), & - f(1:3,ds%constraint(i)%atom(2)), & - f(1:3,ds%constraint(i)%atom(3)) /), ds%constraint(i)%atom(1:3), TI_corr, check) - call print('constrained bond length diff: '//round(check,10)) - call print('force on colvar '//i//' :'//round(TI_force,10)//' '//round(TI_corr,10)) - endif - enddo - call print_cv(ds,Time_Step,.true.) - endif - - !PRINTING - !---------------------------------------------------- - if (trim(print_prop).eq.'all') then - call write(ds%atoms,traj_xyz,real_format='%17.10f', error=error) - HANDLE_ERROR(error) - else - call write(ds%atoms,traj_xyz,properties=trim(print_prop),real_format='%17.10f',error=error) - HANDLE_ERROR(error) - endif - call initialise(latest_xyz,trim(latest_coord_file)//".new",action=OUTPUT) - call write(ds%atoms,latest_xyz,real_format='%17.10f',error=error) - HANDLE_ERROR(error) - call finalise(latest_xyz) - call system("mv "//trim(latest_coord_file)//".new "//trim(latest_coord_file)) - !---------------------------------------------------- - - if (print_forces_at0) then - do i=1,ds%atoms%N - call print('FFF '//f(1,i)//' '//f(2,i)//' '//f(3,i)) - enddo - endif - - !ADVANCE VERLET 1 - - call advance_verlet1(ds, Time_Step) - - !PRINT XYZ - - call set_value(ds%atoms%params,'Time',ds%t) - if (trim(print_prop).eq.'all') then - call write(ds%atoms,traj_xyz,real_format='%17.10f',error=error) - HANDLE_ERROR(error) -! call write(ds%atoms,xyz,real_format='%17.10f') - else - call write(ds%atoms,traj_xyz,properties=trim(print_prop),real_format='%17.10f', error=error) - HANDLE_ERROR(error) -! call write(ds%atoms,xyz,real_format='%17.10f') - !call write(ds%atoms,xyz,properties=trim(print_prop),real_format='%17.10f') - endif - call initialise(latest_xyz,trim(latest_coord_file)//".new",action=OUTPUT) - call write(ds%atoms,latest_xyz,real_format='%17.10f', error=error) - HANDLE_ERROR(error) - call finalise(latest_xyz) - call system("mv "//trim(latest_coord_file)//".new "//trim(latest_coord_file)) - - !save latest.xyz and wfn files at every $copy_latest_every$ step, starting now - if (tmp_run_dir_i>0 .and. copy_latest_every>0) then - copy=1 - ! call system("cp "//trim(latest_coord_file)//" .") - ! call system("for i in /tmp/cp2k_run_"//tmp_run_dir_i//"/wfn.restart.wfn* ; do cp ${i} . ; done") - endif - - call system_timer('step') - -!LOOP - force calc, then VV-2, VV-1 - - ! keep track of how far atoms could have moved - max_move_since_calc_connect = 0.0_dp - do while (ds%t < (Equilib_Time + Run_Time) .and. ((max_n_steps < 0) .or. (n < (max_n_steps-1)))) - - max_move_since_calc_connect = max_move_since_calc_connect + Time_Step* maxval(abs(ds%atoms%velo)) - ! max distance atom could have moved is about max_move_since_calc_connect - ! 2.0 time that is max that interatomic distance could have changed - ! another factor of 1.5 to account for inaccuracy in max_move_since_calc_connect (because atoms really move a distance dependent on both velo and higher derivatives like acc) - if (max_move_since_calc_connect*2.0_dp*1.5_dp >= calc_connect_buffer) then - call system_timer("calc_connect") - call calc_connect(ds%atoms) - if (Delete_Metal_Connections) call delete_metal_connects(ds%atoms) - max_move_since_calc_connect = 0.0_dp - call system_timer("calc_connect") - else - call calc_dists(ds%atoms) - endif - - call system_timer('step') - n = n + 1 - - !QM CORE + BUFFER UPDATE + THERMOSTAT REASSIGNMENT - - if (mod(n,update_QM_region_interval) == 0) then - !NB should we really recalculate residue labels, so heuristics that keep residues together function here? probably - if (have_QMMM_extended) call update_QM_region(ds%atoms, '_extended', qm_region_pt_ctr, qm_region_ctr, & - qm_region_atom_ctr, qm_list_filename, Inner_QM_Region_Radius, Outer_QM_Region_Radius, buffer_general, & - use_create_cluster_info_for_core, first_time=.false., qm_seed=qm_seed_extended, error=error) - HANDLE_ERROR(error) - if (have_QMMM_core) call update_QM_region(ds%atoms, '_core', qm_core_region_pt_ctr, qm_core_region_ctr, & - qm_core_region_atom_ctr, qm_core_list_filename, Inner_QM_Core_Region_Radius, Outer_QM_Core_Region_Radius, buffer_general, & - use_create_cluster_info_for_core, first_time=.false., qm_seed=qm_seed_core, error=error) - HANDLE_ERROR(error) - endif - - !FORCE - - if (Topology_Print_rate > 0) then !every #th step - if (mod(n,Topology_Print_rate) == 0) then !recalc connectivity & generate PSF (at every n-th step) and then use it - driver_PSF_Print = 'DRIVER_PRINT_AND_SAVE' - else - driver_PSF_Print = 'USE_EXISTING_PSF' - endif - endif - call do_calc_call(pot, empty_qm_pot, ds%atoms, Run_Type1, Run_Type2, EVB, qm_region_pt_ctr, qm_core_region_pt_ctr, & - distance_ramp, qm_region_ctr, qm_core_region_ctr, cp2k_calc_args, evb_args_str, extra_calc_args, do_carve_cluster, driver_PSF_Print, f1, energy) - - !SPLINE force calculation, if needed - if (qm_region_pt_ctr.and.use_spline) then - call verbosity_push_decrement() - call print('Force due to added spline potential (eV/A):') - call print('atom F(x) F(y) F(z)') - allocate(add_force(1:3,1:ds%atoms%N)) - if (.not.(assign_pointer(ds%atoms, "pot", spline_pot_val_p))) & - call system_abort("couldn't find pot property") - do i = 1, ds%atoms%N - add_force(1:3,i) = spline_force(ds%atoms,i,my_spline, pot=spline_pot_val) - spline_pot_val_p(i) = spline_pot_val - call print(' '//i//' '//round(add_force(1,i),5)//' '//round(add_force(2,i),5)//' '//round(add_force(3,i),5)) - enddo - call verbosity_pop() - call print('Sum of the forces: '//sum(add_force(1,1:ds%atoms%N))//' '//sum(add_force(2,1:ds%atoms%N))//' '//sum(add_force(3,1:ds%atoms%N))) - f = sumBUFFER(f1+add_force,ds%atoms) - deallocate(add_force) - else - f = sum0(f1,ds%atoms) - endif - - if (print_forces) then - do i=1,ds%atoms%N - call print('FFF '//f(1,i)//' '//f(2,i)//' '//f(3,i)) - enddo - endif - - !THERMOSTATTING now - hybrid_mark was updated only in calc - call set_thermostat_regions(ds%atoms, Thermostat_Type, Thermostat_7_rs, qm_region_ctr) - call set_thermostat_masses(ds%atoms, Thermostat_Type, Simulation_Temperature, & - Inner_QM_Region_Radius, Outer_QM_Region_Radius, Inner_Buffer_Radius, Outer_Buffer_Radius, Thermostat_7_rs) - - !ADVANCE VERLET 2 - - call advance_verlet2(ds, Time_Step, f) - - !RESTRAINTS - if (ds%Nrestraints > 0) call get_restraint_stuff(ds, restraint_stuff) - - !PRINT DS,THERMOSTAT,CONSTRAINT,XYZ - - if (ds%t < Equilib_Time) then - call ds_print_status(ds, 'E',energy) - if (ds%Nrestraints > 0) call print_restraint_stuff(ds, restraint_stuff, 'E') - else - call ds_print_status(ds, 'I',energy) - if (ds%Nrestraints > 0) call print_restraint_stuff(ds, restraint_stuff, 'I') - end if - - !Thermostat (only if not per-atom) - if (thermostat_type /= 3 .and. thermostat_type /= 4 .and. thermostat_type /= 8) then - call print(ds%thermostat) - endif - - !Constraint - if (ds%Nconstraints > 0) then - call print(ds%constraint) - do i=1,ds%Nconstraints - call print("TI"//i//" "//ds%t//" "//ds%constraint(i)%C//" "// & - ds%constraint(i)%lambdaR//" "// & - ds%constraint(i)%lambdaV//" "// & - ds%constraint(i)%Z_coll) - if (ds%constraint(i)%N /= 3) then - call print("WARNING: constraint " // i // " does not involve 3 atoms, ignoring", PRINT_ALWAYS) - else - TI_force = force_on_collective_variable(ds%atoms, (/ f(1:3,ds%constraint(i)%atom(1)), & - f(1:3,ds%constraint(i)%atom(2)), & - f(1:3,ds%constraint(i)%atom(3)) /), ds%constraint(i)%atom(1:3), TI_corr, check) - call print('constrained bond length diff: '//round(check,10)) - call print('force on colvar '//i//' :'//round(TI_force,10)//' '//round(TI_corr,10)) - endif - enddo - call print_cv(ds,Time_Step,.false.) - endif - - !XYZ - if (mod(n,IO_Rate)==0) then - call set_value(ds%atoms%params,'Time',ds%t) - if (trim(print_prop).eq.'all') then - call write(ds%atoms,traj_xyz,real_format='%17.10f',error=error) - HANDLE_ERROR(error) -! call write(ds%atoms,xyz,real_format='%17.10f') - else - call write(ds%atoms,traj_xyz,properties=trim(print_prop),real_format='%17.10f',error=error) - HANDLE_ERROR(error) -! call write(ds%atoms,xyz,real_format='%17.10f') - !call write(ds%atoms,xyz,properties=trim(print_prop),real_format='%17.10f') - endif - call initialise(latest_xyz,trim(latest_coord_file)//".new",action=OUTPUT) - call write(ds%atoms,latest_xyz,real_format='%17.10f',error=error) - HANDLE_ERROR(error) - call finalise(latest_xyz) - call system("mv "//trim(latest_coord_file)//".new "//trim(latest_coord_file)) - end if - - !save latest.xyz and wfn files from /tmp at every $copy_latest_every$ step - if (tmp_run_dir_i>0 .and. copy_latest_every>0) then - if (copy==copy_latest_every) then - copy=0 - call system("cp "//trim(latest_coord_file)//" .") - call system("for i in /tmp/cp2k_run_"//tmp_run_dir_i//"/wfn.restart.wfn* ; do cp ${i} . ; done") - endif - copy=copy+1 - endif - - if (H_extra_heat_r(2) >= H_extra_heat_r(1)) then - do i=1, ds%atoms%N - if (ds%atoms%Z(i) == 1) then - r = distance_min_image(ds%atoms, i, H_extra_heat_ctr) - if (r >= H_extra_heat_r(1) .and. r <= H_extra_heat_r(2)) ds%atoms%velo(:,i) = H_extra_heat_velo_factor*ds%atoms%velo(:,i) - endif - end do - endif - if (nH_extra_heat_r(2) >= nH_extra_heat_r(1)) then - do i=1, ds%atoms%N - if (ds%atoms%Z(i) /= 1) then - r = distance_min_image(ds%atoms, i, nH_extra_heat_ctr) - if (r >= nH_extra_heat_r(1) .and. r <= nH_extra_heat_r(2)) ds%atoms%velo(:,i) = nH_extra_heat_velo_factor*ds%atoms%velo(:,i) - endif - end do - endif - - !ADVANCE VERLET 1 - - call advance_verlet1(ds, Time_Step) - - call system_timer('step') - - enddo - - deallocate(f,f0,f1) - - call finalise(qm_seed_extended) - call finalise(qm_seed_core) - call finalise(ds) - call finalise(traj_xyz) - - call finalise(pot) - call finalise(empty_qm_pot) - call finalise(CP2K_slow_pot) - call finalise(CP2K_fast_pot) - - call print_title('THE') - call print('Finished. CP2K is now having a rest, since deserved it. Bye-Bye!') - call print_title('END') - - call system_timer('program') - call system_finalise - -contains - - subroutine read_constraints_bond_diff(my_atoms,constraints,constraint_file) - - type(Atoms), intent(in) :: my_atoms - type(Table), intent(out) :: constraints - character(len=*), intent(in) :: constraint_file - type(InOutput) :: cons - integer :: n, num_constraints, cons_a, cons_b,cons_c - - call initialise(cons,trim(constraint_file),action=INPUT) - read (cons%unit,*) num_constraints - call allocate(constraints,3,0,0,0,num_constraints) - do n=1,num_constraints - cons_a = 0 - cons_b = 0 - cons_c = 0 - read (cons%unit,*) cons_a,cons_b, cons_c - call append(constraints,(/cons_a,cons_b,cons_c/)) - enddo - if (constraints%N.ne.num_constraints) call system_abort('read_constraint: Something wrong with the constraints file') - if (any(constraints%int(1:2,1:constraints%N).gt.my_atoms%N).or.any(constraints%int(1:2,1:constraints%N).lt.1)) & - call system_abort("read_constraints: Constraint atom(s) is <1 or >"//my_atoms%N) - call finalise(cons) - - end subroutine read_constraints_bond_diff - - function force_on_collective_variable(my_atoms,frc,at123,F_corr,lambda) result(F_lambda) - - type(Atoms), intent(in) :: my_atoms - real(dp), dimension(9), intent(in) :: frc - integer, dimension(3), intent(in) :: at123 - real(dp), optional, intent(out) :: F_corr ! the metric tensor correction - real(dp), optional, intent(out) :: lambda ! the metric tensor correction - real(dp) :: F_lambda ! the force on the bondlength difference - - real(dp) :: d ! the bondlength difference - real(dp) :: DD ! the bondlength sum - real(dp) :: d_12(3), d12 ! the 1>2 bond vector and its norm - real(dp) :: d_23(3), d23 ! the 2>3 bond vector and its norm - integer :: a1, a2, a3 ! the 3 atoms a1-a2-a3 - real(dp) :: F_1(3), F_2(3), F_3(3) ! the force on the 3 atoms - - a1 = at123(1) - a2 = at123(2) - a3 = at123(3) - - F_1(1:3) = frc(1:3) - F_2(1:3) = frc(4:6) - F_3(1:3) = frc(7:9) - - d_12 = diff_min_image(my_atoms,a1,a2) - d_23 = diff_min_image(my_atoms,a2,a3) - d12 = distance_min_image(my_atoms,a1,a2) - d23 = distance_min_image(my_atoms,a2,a3) - - if (abs(sqrt(dot_product(d_12,d_12))-d12).gt.0.000001_dp .or. & - abs(sqrt(dot_product(d_23,d_23))-d23).gt.0.000001_dp) then - call print(sqrt(dot_product(d_12,d_12))//' '//d12) - call print(sqrt(dot_product(d_23,d_23))//' '//d23) - call system_abort('wrong realpos') - endif - -! ! calc. F_lambda from bondlength forces - not good -! F_d12 = dot_product((F_1(1:3)*m_2-F_2(1:3)*m_1),(-d_12(1:3))) / ((m_1+m_2)*d12) -! F_d23 = dot_product((F_2(1:3)*m_3-F_3(1:3)*m_2),(-d_23(1:3))) / ((m_2+m_3)*d23) -! F_lambda = F_d12 - F_d23 - - F_lambda = dot_product(F_1(1:3),-d_12(1:3)) / (2._dp*d12) - & - dot_product(F_3(1:3),d_23(1:3)) / (2._dp*d23) - - !calc. metric tensor correction - d = d12 - d23 - DD = d12 + d23 - if (present(F_corr)) & - F_corr = - 4 * BOLTZMANN_K * 300 * d / (DD*DD-d*d) - - if (present(lambda)) lambda = d - - end function force_on_collective_variable - -! for QM/MM and MM runs, to check water topology - subroutine check_topology(my_atoms) - - type(Atoms), intent(in) :: my_atoms - - integer :: i, N - logical :: is_bad_H - integer, pointer :: qm_flag_p(:), qm_core_flag_p(:) - character(len=1), pointer :: atom_res_name_p(:,:) - - - if (.not.(assign_pointer(my_atoms, "hybrid_mark_extended", qm_flag_p))) nullify(qm_flag_p) - if (.not.(assign_pointer(my_atoms, "hybrid_mark_core", qm_core_flag_p))) nullify(qm_core_flag_p) - - if (.not.(assign_pointer(my_atoms, "atom_res_name", atom_res_name_p))) & - call system_abort("couldn't find atom_res_name property") - - N = 0 - do i=1,my_atoms%N - is_bad_H = .false. - if (any((/'H3O','HYD','HWP'/).eq.trim(a2s(atom_res_name_p(:,i))))) then - if (associated(qm_flag_p)) then - if (qm_flag_p(i) /= 1) is_bad_H = .true. - endif - if (associated(qm_core_flag_p)) then - if (qm_core_flag_p(i) /= 1) is_bad_H = .true. - endif - if (.not. associated(qm_flag_p) .and. .not. associated(qm_core_flag_p)) is_bad_H = .true. - endif - if (is_bad_H) then - N = N + 1 - call print('ERROR: classical or buffer atom '//i//'has atom_res_name '//trim(a2s(atom_res_name_p(:,i)))) - endif - enddo - if (N > 0) call system_abort('Wrong topology calculated: found H3O, HYD, or HWP in MM or buffer atom.') - - end subroutine check_topology - -! momentum conservation over all atoms, mass weighted - function sum0(force,at) result(force0) - - real(dp), dimension(:,:), intent(in) :: force - type(Atoms), intent(in) :: at - real(dp) :: force0(size(force,1),size(force,2)) - real(dp) :: sumF(3), sum_weight - - sumF = sum(force,2) - call print('Sum of the forces is '//sumF(1:3)) - - if ((sumF(1) .feq. 0.0_dp) .and. (sumF(2) .feq. 0.0_dp) .and. (sumF(3) .feq. 0.0_dp)) then - call print('Sum of the forces is zero.') - force0 = force - else - !F_corr weighted by element mass - sum_weight = sum(ElementMass(at%Z(1:at%N))) - - force0(1,:) = force(1,:) - sumF(1) * ElementMass(at%Z(:)) / sum_weight - force0(2,:) = force(2,:) - sumF(2) * ElementMass(at%Z(:)) / sum_weight - force0(3,:) = force(3,:) - sumF(3) * ElementMass(at%Z(:)) / sum_weight - endif - - sumF = sum(force0,2) - call print('Sum of the forces after mom.cons.: '//sumF(1:3)) - - end function sum0 - -! momentum conservation over atoms with QM flag 1 or 2, mass weighted - function sumBUFFER(force,at) result(force0) - - real(dp), dimension(:,:), intent(in) :: force - type(Atoms), intent(in) :: at - real(dp) :: force0(size(force,1),size(force,2)) - real(dp) :: F_corr(size(force,1),size(force,2)) - integer :: i - real(dp) :: sumF(3), sum_weight - integer, pointer :: qm_flag_p(:) - - if (.not. assign_pointer(at, 'cluster_mark_extended', qm_flag_p)) & - call system_abort('Potential_FM_Calc: cluster_mark property missing') - if ( .not. any(qm_flag_p(:).eq.(/1,2/)) ) then !no buffer or core: maybe empty_qm_core? - force0 = sum0(force,at) - return - endif - - !sum F - sumF = sum(force,2) - call print('Sum of the forces is '//sumF(1:3)) - - if ((sumF(1) .feq. 0.0_dp) .and. (sumF(2) .feq. 0.0_dp) .and. (sumF(3) .feq. 0.0_dp)) then - call print('Sum of the forces is zero.') - force0 = force - else - !F_corr weighted by element mass - sum_weight = 0._dp - F_corr = 0._dp - do i=1, at%N - if ( any(qm_flag_p(i).eq.(/1,2/)) ) then - F_corr(1:3,i) = ElementMass(at%Z(i)) - sum_weight = sum_weight + ElementMass(at%Z(i)) - endif - enddo - if (sum_weight .feq. 0._dp) call system_abort('sum_buffer: 0 element masses? the presence of core or buffer atoms has already been checked.') - - force0(1,:) = force(1,:) - sumF(1) * F_corr(1,:) / sum_weight - force0(2,:) = force(2,:) - sumF(2) * F_corr(2,:) / sum_weight - force0(3,:) = force(3,:) - sumF(3) * F_corr(3,:) / sum_weight - endif - - sumF = sum(force0,2) - call print('Sum of the forces after mom.cons.: '//sumF(1:3)) - - end function sumBUFFER - - !% Calculates the force on the $i$th atom due to an external potential that has - !% the form of a spline, $my_spline$. - ! - function spline_force(at, i, my_spline, pot) result(force) - - type(Atoms), intent(in) :: at - integer, intent(in) :: i - type(spline_pot), intent(in) :: my_spline - real(dp), optional, intent(out) :: pot - real(dp), dimension(3) :: force - - real(dp) :: dist, factor - -! dist = distance from the origin -! spline: f(dist) = spline%dpot/(spline%from-spline%to)**3._dp * (dist-spline%to)**2._dp * (3._dp*spline%from - spline%to - 2._dp*dist) -! f(spline%from) = spline%dpot; f(spline%to) = 0. -! f`(spline%from) = 0.; f`(spline%to) = 0. -! force = - grad f(dist) - - dist = distance_min_image(at,i,(/0._dp,0._dp,0._dp/)) - if (dist.ge.my_spline%to .or. dist.le.my_spline%from) then - force = 0._dp - if (present(pot)) then - if (dist.ge.my_spline%to) pot = 0._dp - if (dist.le.my_spline%from) pot = my_spline%dpot - endif - else - factor = 1._dp - ! force on H should be 1/16 times the force on O, to get the same acc. - if (at%Z(i).eq.1) factor = ElementMass(1)/ElementMass(8) - force = - factor * 2._dp *my_spline%dpot / ((my_spline%from - my_spline%to)**3._dp * dist) * & - ( (3._dp * my_spline%from - my_spline%to - 2._dp * dist) * (dist - my_spline%to) & - - (dist - my_spline%to)**2._dp ) * at%pos(1:3,i) - if (present(pot)) pot = my_spline%dpot/(my_spline%from-my_spline%to)**3._dp * (dist-my_spline%to)**2._dp * (3._dp*my_spline%from - my_spline%to - 2._dp*dist) - endif - - end function spline_force - - !% Reads the QM list from a file - !% Will not overwrite properties! - ! - subroutine read_qmlist(my_atoms,qmlistfilename,qm_list,verbose) - - type(Atoms), intent(inout) :: my_atoms - character(*), intent(in) :: qmlistfilename - type(Table), intent(out) :: qm_list - logical, optional, intent(in) :: verbose - - type(Inoutput) :: qmlistfile - integer :: n,num_qm_atoms,qmatom,status - character(80) :: title,testline - logical :: my_verbose - character(20), dimension(10) :: fields - integer :: num_fields - - - my_verbose = optional_default(.false., verbose) - - if (my_verbose) call print('In Read_QM_list:') - call print('Reading the QM list from file '//trim(qmlistfilename)//'...') - - call initialise(qmlistfile,filename=trim(qmlistfilename),action=INPUT) - title = read_line(qmlistfile,status) - if (status > 0) then - call system_abort('read_qmlist: Error reading from '//qmlistfile%filename) - else if (status < 0) then - call system_abort('read_qmlist: End of file when reading from '//qmlistfile%filename) - end if - - call parse_line(qmlistfile,' ',fields,num_fields,status) - if (status > 0) then - call system_abort('read_qmlist: Error reading from '//qmlistfile%filename) - else if (status < 0) then - call system_abort('read_qmlist: End of file when reading from '//qmlistfile%filename) - end if - - num_qm_atoms = string_to_int(fields(1)) - if (num_qm_atoms < 1 .or. num_qm_atoms > my_atoms%N) call print('WARNING! read_qmlist: bad number of QM atoms ('//num_qm_atoms//') in qm_list , possible bad QM list file',verbosity=PRINT_ALWAYS) - call print('Number of QM atoms: '//num_qm_atoms) - call allocate(qm_list,4,0,0,0,num_qm_atoms) !1 int, 0 reals, 0 str, 0 log, num_qm_atoms entries - - testline = read_line(qmlistfile,status) - if (testline(1:4) /= 'list') then - call system_abort("Got qm_list file '"//trim(qmlistfilename)//"' without 'list' keyword after number of atoms") - endif - ! Reading and storing QM list... - do n=1,num_qm_atoms - call parse_line(qmlistfile,' ',fields,num_fields,status) - if (status /= 0) then - call system_abort("Failed to read qm_list atom #"//n//", I/O error "//status) - endif - qmatom = string_to_int(fields(1)) - if (my_verbose) call print(n//'th quantum atom is: '//qmatom) - call append(qm_list,(/qmatom,0,0,0/)) - enddo - - call finalise(qmlistfile) - - if (qm_list%N/=num_qm_atoms) call system_abort('read_qmlist: Something wrong with the QM list file') - if (any(int_part(qm_list,1).gt.my_atoms%N).or.any(int_part(qm_list,1).lt.1)) & - call system_abort('read_qmlist: at least 1 QM atom is out of range') - if ((size(int_part(qm_list,1)).gt.my_atoms%N).or.(size(int_part(qm_list,1)).lt.1)) & - call system_abort("read_qmlist: QM atoms' number is <1 or >"//my_atoms%N) - - if (my_verbose) call print('Finished. '//qm_list%N//' QM atoms have been read successfully.') - - end subroutine read_qmlist - - !%Prints the quantum region mark with the cluster_mark property (/=0). - !%If file is given, into file, otherwise to the standard io. - ! - subroutine print_qm_region(at, file) - type(Atoms), intent(inout) :: at - type(CInoutput), optional :: file - - integer, pointer :: cluster_mark_p(:) - type(Atoms) :: cluster - - if (.not.(assign_pointer(at, "cluster_mark_extended", cluster_mark_p))) & - call system_abort("print_qm_region couldn't find cluster_mark property") - - call select(cluster, at, mask=(cluster_mark_p /= 0)) - if (present(file)) then - call write(cluster, file, prefix="QM_REGION") - else - call write(cluster, "stdout", prefix="QM_REGION") - end if - end subroutine print_qm_region - - subroutine do_calc_call(pot, empty_qm_pot, at, Run_Type1, Run_Type2, EVB_MM, qm_region_pt_ctr, qm_core_region_pt_ctr, & - distance_ramp, qm_region_ctr, qm_core_region_ctr, cp2k_calc_args, evb_args_str, extra_calc_args, & - do_carve_cluster, driver_PSF_Print, f1, energy) - type(Potential), intent(inout) :: pot, empty_qm_pot - type(Atoms), intent(inout) :: at - logical, intent(in) :: EVB_MM, qm_region_pt_ctr, qm_core_region_pt_ctr, distance_ramp, do_carve_cluster - real(dp), intent(in) :: qm_region_ctr(3), qm_core_region_ctr(3) - character(len=*), intent(in) :: Run_Type1, Run_Type2, cp2k_calc_args, evb_args_str, extra_calc_args, driver_PSF_Print - real(dp), intent(inout) :: f1(:,:) - real(dp), intent(out) :: energy - - integer, pointer :: qm_flag_p(:) - character(len=STRING_LENGTH) :: slow_args_str, fast_args_str, args_str - logical :: empty_QM_core, empty_QM_extended - real(dp), pointer :: force_p(:,:) - - empty_QM_core = .false. - if (qm_core_region_pt_ctr) then - if (.not.(assign_pointer(at, "hybrid_mark_core", qm_flag_p))) & - call system_abort("couldn't find hybrid_mark_core property") - if (.not.any(qm_flag_p(1:at%N).eq.HYBRID_ACTIVE_MARK)) empty_QM_core = .true. - if (empty_QM_core .and. trim(Run_Type2) == 'QMMM_CORE') & - call system_abort("Can't handle Run_Type2=QMMM_CORE but QM core appears empty") - endif - empty_QM_extended = .false. - if (qm_region_pt_ctr) then - if (.not.(assign_pointer(at, "hybrid_mark_extended", qm_flag_p))) & - call system_abort("couldn't find hybrid_mark_extended property") - if (.not.any(qm_flag_p(1:at%N).eq.HYBRID_ACTIVE_MARK)) empty_QM_extended = .true. - endif -! if (.not.((trim(Run_Type1).eq.'QS').or.(trim(Run_Type1).eq.'MM'))) then - if (trim(Run_Type1).eq.'QMMM_EXTENDED') then - call print_qm_region(at) - endif - - if (trim(Run_Type2) == 'NONE' .or. (qm_region_pt_ctr .and. empty_QM_extended)) then ! no force mixing - call print(trim(Run_Type1)//' run will be performed with simple potential.') - if (EVB_MM .and. & - !only instead of MM - ((trim(Run_Type1) == "MM" .and. trim(Run_Type2) == 'NONE') .or. & - (Run_Type1(1:4) == 'QMMM' .and. (qm_region_pt_ctr .and. empty_QM_extended) .and. trim(Run_Type2)=="MM"))) then - !Add args_str into mm_args_str of EVB pot - args_str=trim(evb_args_str)//' mm_args_str="'// & - trim(cp2k_calc_args) // & - ' Run_Type=MM'// & !only MM - ' PSF_Print='//trim(driver_PSF_Print)//'"' - else - args_str=trim(cp2k_calc_args) // & - ' '//trim(cp2k_driver_run_type_args(Run_Type1))// & - ' PSF_Print='//trim(driver_PSF_Print) !// & -! ' clean_up_files=F' - endif - call print('ARGS_STR | '//trim(args_str)) - if (Run_Type1(1:4) == 'QMMM') then - if ( qm_region_pt_ctr .and. empty_QM_extended) then - call print('WARNING: Empty QM extended region. MM run will be performed instead of QM/MM.', PRINT_ALWAYS) - call print("CALC_POT '"//trim(args_str)//"'") - call calc(empty_qm_pot,at,energy=energy,force=f1,args_str=trim(args_str)) - if (assign_pointer(at, 'force', force_p)) force_p = f1 - return - else - args_str = trim(args_str) // & - ' single_cluster=T carve_cluster='//do_carve_cluster//' cluster_hopping_nneighb_only=F cluster_heuristics_nneighb_only=T ' // & - ' termination_clash_check=T terminate=T even_electrons=F auto_centre' - endif - !run_suffix to save hybrid_mark, cluster_mark & old_cluster_mark under different name for QMMM_extended & QMMM_core - if (trim(Run_Type1) == 'QMMM_EXTENDED') then - args_str = trim(args_str) // ' run_suffix=_extended' - elseif (trim(Run_Type1) == 'QMMM_CORE') then - args_str = trim(args_str) // ' run_suffix=_core' - endif - endif - if (Run_Type1(1:4) == 'QMMM' .and. trim(Run_Type2)=="NONE") then - !potential simple will not calculate energy with single_cluster=T - call print("CALC_POT '"//trim(args_str)//"'") - call calc(pot,at,force=f1,args_str=trim(args_str)) - energy=0.0_dp - else - call print("CALC_POT '"//trim(args_str)//"'") - call calc(pot,at,energy=energy,force=f1,args_str=trim(args_str)) - endif - else ! do force mixing - - if (EVB_MM .and. trim(Run_Type1)=="MM") then - call print("WARNING: Force Mixing with MM as the slow potential!") - !Add slow_args_str into mm_args_str of EVB pot - slow_args_str=trim(evb_args_str)//' mm_args_str="'// & - trim(cp2k_calc_args) // ' ' // trim(cp2k_driver_run_type_args(Run_Type1)) // ' PSF_Print='//trim(driver_PSF_print)//'"' - else - slow_args_str=trim(cp2k_calc_args) // ' '//trim(cp2k_driver_run_type_args(Run_Type1)) //' PSF_Print='//trim(driver_PSF_print) !//' clean_up_files=F' - endif - if (Run_Type1(1:4) == 'QMMM' .and. .not. (qm_region_pt_ctr .and. empty_QM_core)) then - slow_args_str = trim(slow_args_str) // & - ' single_cluster=T carve_cluster='//do_carve_cluster//' cluster_hopping_nneighb_only=F cluster_heuristics_nneighb_only=T ' // & - ' termination_clash_check=T terminate=T even_electrons=F auto_centre' - !run_suffix to save hybrid_mark, cluster_mark & old_cluster_mark under different name for QMMM_extended & QMMM_core - if (trim(Run_Type1) == 'QMMM_EXTENDED') then - slow_args_str = trim(slow_args_str) // ' run_suffix=_extended' - elseif (trim(Run_Type1) == 'QMMM_CORE') then - slow_args_str = trim(slow_args_str) // ' run_suffix=_core' - endif - endif - if (trim(Run_Type1) == 'MM_INTERNAL') slow_args_str = trim(slow_args_str)//' '//trim(mm_internal_calc_args) - - if (EVB_MM .and. trim(Run_Type2)=="MM") then - !Add fast_args_str into mm_args_str of EVB pot - fast_args_str=trim(evb_args_str)//' mm_args_str="'// & - trim(cp2k_calc_args) // & - ' Run_Type=MM'// & !only MM - ' PSF_Print='//trim(driver_PSF_Print)//'"' - else - fast_args_str=trim(cp2k_calc_args) // ' '// trim(cp2k_driver_run_type_args(Run_Type2))//' PSF_Print='//trim(driver_PSF_print) !//' clean_up_files=F' - endif - if (Run_Type2(1:4) == 'QMMM' .and. .not. (qm_region_pt_ctr .and. empty_QM_core)) then - fast_args_str = trim(fast_args_str) // & - ' single_cluster=T carve_cluster='//do_carve_cluster//' cluster_hopping_nneighb_only=F cluster_heuristics_nneighb_only=T ' // & - ' termination_clash_check=T terminate=T even_electrons=F auto_centre' - !run_suffix to save hybrid_mark, cluster_mark & old_cluster_mark under different name for QMMM_extended & QMMM_core - if (trim(Run_Type2) == 'QMMM_EXTENDED') then - fast_args_str = trim(fast_args_str) // ' run_suffix=_extended' - elseif (trim(Run_Type2) == 'QMMM_CORE') then - fast_args_str = trim(fast_args_str) // ' run_suffix=_core' - endif - endif - if (trim(Run_Type2) == 'MM_INTERNAL') fast_args_str = trim(fast_args_str)//' '//trim(mm_internal_calc_args) - - ! cluster_hopping_nneighb_only=F so that create_hybrid_weights will be able to find all the atoms - args_str='cluster_hopping_nneighb_only=F qm_args_str={'//trim(slow_args_str)//' '//trim(extra_calc_args)//'} mm_args_str={'//trim(fast_args_str)//' '//trim(extra_calc_args)//'} run_suffix=_extended' - if (distance_ramp) then - args_str = trim(args_str) // ' distance_ramp_centre='//qm_region_ctr - endif - call print('ARGS_STR | '//trim(args_str)) - if (qm_region_pt_ctr .and. empty_QM_extended) then - call system_abort("Got to end of force mixing part of do_calc_call, but (qm_region_ptr_ctr .and. empty_QM_extended) is true. Should never happen!") -! if (trim(Run_Type2) /= 'MM') & -! call system_abort("Doing force mixing, but Run_Type2='"//trim(Run_Type2)//"' /= MM") -! call calc(empty_qm_pot,at,force=f1,args_str=trim(fast_args_str)) - else - call print("CALC_POT '"//trim(args_str)//"'") - call calc(pot,at,force=f1,args_str=trim(args_str)) - endif - energy=0._dp !no energy - endif ! do force mixing - - ! save forces if force property is there - if (assign_pointer(at, 'force', force_p)) force_p = f1 - - end subroutine do_calc_call - - function cp2k_driver_run_type_args(run_type) - character(len=*), intent(in) :: run_type - character(len=300) :: cp2k_driver_run_type_args - - if (run_type(1:2) == 'MM') then - cp2k_driver_run_type_args = "Run_Type=MM" - else if (run_type(1:2) == 'QS') then - cp2k_driver_run_type_args = "Run_Type=QS" - else ! QMMM - cp2k_driver_run_type_args = "Run_Type=QMMM" - if (run_type(1:9) == 'QMMM_CORE') then - cp2k_driver_run_type_args = trim(cp2k_driver_run_type_args)//' use_buffer=F run_suffix=_core' - else - cp2k_driver_run_type_args = trim(cp2k_driver_run_type_args)//' use_buffer=T run_suffix=_extended' - endif - endif - end function cp2k_driver_run_type_args - - subroutine setup_pot(pot, Run_Type, filepot_program, tmp_run_dir_i, mm_internal_init_args, mm_internal_param_filename) - type(Potential), intent(inout) :: pot - character(len=*), intent(in) :: Run_Type, filepot_program, mm_internal_init_args, mm_internal_param_filename - integer, intent(in) :: tmp_run_dir_i - character(len=STRING_LENGTH) :: filename - - if (tmp_run_dir_i > 0) then - filename="/tmp/cp2k_run_"//tmp_run_dir_i//"/filepot" - else - filename="filepot" - endif - if (trim(Run_Type) == 'QS') then - call print('INITIALISE_POT QS FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos min_cutoff=0.0') - call initialise(pot,'FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos min_cutoff=0.0') - else if (trim(Run_Type) == 'MM') then - call print('INITIALISE_POT MM FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos:avgpos:mol_id:atom_res_number min_cutoff=0.0') - call initialise(pot,'FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos:avgpos:mol_id:atom_res_number min_cutoff=0.0') - else if (trim(Run_Type) == 'QMMM_CORE') then - call print('INITIALISE_POT QMMM_CORE FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos:avgpos:atom_charge:mol_id:atom_res_number:cluster_mark_core:old_cluster_mark_core:cut_bonds_core:old_cut_bonds_core min_cutoff=0.0') - call initialise(pot,'FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos:avgpos:atom_charge:mol_id:atom_res_number:cluster_mark_core:old_cluster_mark_core:cut_bonds_core:old_cut_bonds_core min_cutoff=0.0') - else if (trim(Run_Type) == 'QMMM_EXTENDED') then - call print('INITIALISE_POT QMMM_EXTENDED FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos:avgpos:atom_charge:mol_id:atom_res_number:cluster_mark_extended:old_cluster_mark_extended:cut_bonds_extended:old_cut_bonds_extended min_cutoff=0.0') - call initialise(pot,'FilePot filename='//trim(filename)//' command='//trim(filepot_program)//' property_list=species:pos:avgpos:atom_charge:mol_id:atom_res_number:cluster_mark_extended:old_cluster_mark_extended:cut_bonds_extended:old_cut_bonds_extended min_cutoff=0.0') - else if (trim(Run_Type) == 'MM_INTERNAL') then - call print('INITIALISE_POT MM '//mm_internal_init_args) - call potential_filename_initialise(pot, mm_internal_init_args, param_filename=mm_internal_param_filename) - else - call system_abort("Run_Type='"//trim(Run_Type)//"' not supported") - endif - end subroutine setup_pot - - subroutine add_QMMM_md_buf_thermostats(ds, thermostat_type, T) - type(DynamicalSystem), intent(inout) :: ds - integer, intent(in) :: thermostat_type - real(dp), intent(in) :: T - - select case(Thermostat_Type) - case(0) - call print("No thermostat, NVE!!", PRINT_ALWAYS) - case(1) - if (adaptive_Langevin) then - call add_thermostat(ds,type=THERMOSTAT_LANGEVIN,T=T,tau=Langevin_Tau,Q=1.0_dp) - call print('Added single adaptive Langevin Thermostat') - else - Nose_Hoover_Tau = -1.0_dp - call add_thermostat(ds,type=THERMOSTAT_LANGEVIN,T=T,tau=Langevin_Tau) - call print('Added single Langevin Thermostat') - endif - case(2) - call add_thermostat(ds,type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) - call print('Added single Nose-Hoover Thermostat') - case(3) - call add_thermostats(ds,type=THERMOSTAT_NOSE_HOOVER,n=ds%atoms%N,T=T,Q=1.0_dp, gamma=0.0_dp) - ds%print_thermostat_temps = .false. - call print("Added 1 Nose-Hoover thermostat for each atom") - case(4) - call add_thermostats(ds,type=THERMOSTAT_NOSE_HOOVER_LANGEVIN,n=ds%atoms%N, T=T,Q=1.0_dp, tau=Langevin_Tau) - ds%print_thermostat_temps = .false. - call print("Added 1 Nose-Hoover-Langevin thermostat for each atom") - case(5) - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T, Q=1.0_dp, gamma=0.0_dp) ! heavy QM+buffer - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T, Q=1.0_dp, gamma=0.0_dp) ! H QM+buffer - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER_LANGEVIN,T=T,tau=Langevin_Tau,Q=1.0_dp) ! MM - call print("Added 1 Nose-Hoover for QM+buffer heavy, 1 Nose-Hoover for QM+buffer H, and 1 Nose-Hoover-Langevin for MM") - case(6) - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! heavy QM - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! H QM - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! heavy buffer - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! H buffer - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! heavy MM - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! H MM - call print("Added 6 Nose-Hoover thermostats, 3 regions (QM, Buffer, MM) x 2 kinds (H, heavy)") - case(7) - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! heavy QM - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! H QM - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! heavy buffer - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! H buffer - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! heavy MM - call add_thermostat(ds, type=THERMOSTAT_NOSE_HOOVER,T=T,Q=1.0_dp, gamma=0.0_dp) ! H MM - call print("Added 6 Nose-Hoover thermostats, 3 regions (QM, Buffer, MM) x 2 kinds (H, heavy)") - case(8) - call add_thermostats(ds,type=THERMOSTAT_LANGEVIN,n=ds%atoms%N, T=T, tau=Langevin_Tau, Q=1.0_dp) - ds%print_thermostat_temps = .false. - call print("Added 1 Langevin thermostat for each atom") - case default - call system_abort("add_thermostats: Unknown Thermostat_Type="//Thermostat_type) - end select - end subroutine add_QMMM_md_buf_thermostats - - subroutine set_thermostat_masses(at, Thermostat_type, T, Inner_QM_Region_Radius, Outer_QM_Region_Radius, Inner_Buffer_Radius, Outer_Buffer_Radius, Thermostat_7_rs) - type(Atoms), intent(in) :: at - integer, intent(in) :: thermostat_type - real(dp) :: T - real(dp), intent(in) :: Inner_QM_Region_Radius, Outer_QM_Region_Radius, Inner_Buffer_Radius, Outer_Buffer_Radius - real(dp), intent(in) :: Thermostat_7_rs(2) - - integer, pointer :: cluster_mark_p(:) - - real(dp) :: QM_vol, Buffer_vol, cell_vol - integer :: Ndof_QM_H, Ndof_QM_heavy - integer :: Ndof_Buffer_H, Ndof_Buffer_heavy - integer :: Ndof_MM_H, Ndof_MM_heavy - real(dp) :: n_H, n_heavy - - if (Thermostat_type == 7) then - QM_vol = 4.0_dp/3.0_dp*PI*Thermostat_7_rs(1)**3 - Buffer_vol = 4.0_dp/3.0_dp*PI*Thermostat_7_rs(2)**3 - QM_vol - cell_vol = cell_volume(at) - n_H = count(at%Z == 1) - n_heavy = at%N - n_H - Ndof_QM_H = 3*int(QM_vol * n_H/cell_vol) - Ndof_QM_heavy = 3*int(QM_vol * n_heavy/cell_vol) - Ndof_Buffer_H = 3*int(Buffer_vol * n_H/cell_vol) - Ndof_Buffer_heavy = 3*int(Buffer_vol * n_heavy/cell_vol) - Ndof_MM_H = 3*n_H - ndof_QM_H - ndof_Buffer_H - Ndof_MM_heavy = 3*n_heavy - ndof_QM_heavy - ndof_Buffer_heavy - call print("Thermostat_type == 7, estimating NDOFs from volumes QM,Buffer,cell " // QM_vol // " " // & - Buffer_vol//" "//cell_vol // " density H,heavy" // (n_H/cell_vol) // " " // (n_heavy/cell_vol)) - else - if (.not. assign_pointer(at, "cluster_mark_extended", cluster_mark_p)) then - QM_vol = 4.0_dp/3.0_dp*PI*((Inner_QM_Region_Radius + Outer_QM_Region_Radius)/2.0_dp)**3 - Buffer_vol = 4.0_dp/3.0_dp*PI*((Inner_QM_Region_Radius+Inner_Buffer_Radius + Outer_QM_Region_Radius+Outer_Buffer_Radius)/2.0_dp)**3 - QM_vol - cell_vol = cell_volume(at) - n_H = count(at%Z == 1) - n_heavy = at%N - n_H - Ndof_QM_H = 3*int(QM_vol * n_H/cell_vol) - Ndof_QM_heavy = 3*int(QM_vol * n_heavy/cell_vol) - Ndof_Buffer_H = 3*int(Buffer_vol * n_H/cell_vol) - Ndof_Buffer_heavy = 3*int(Buffer_vol * n_heavy/cell_vol) - Ndof_MM_H = 3*n_H - ndof_QM_H - ndof_Buffer_H - Ndof_MM_heavy = 3*n_heavy - ndof_QM_heavy - ndof_Buffer_heavy - call print("no cluster_mark_extended, estimating NDOFs from volumes QM,Buffer,cell " // QM_vol // " " // & - Buffer_vol//" "//cell_vol // " density H,heavy" // (n_H/cell_vol) // " " // (n_heavy/cell_vol)) - else - Ndof_QM_H = 3*count(cluster_mark_p == HYBRID_ACTIVE_MARK .and. at%Z == 1) - Ndof_QM_heavy = 3*count(cluster_mark_p == HYBRID_ACTIVE_MARK) - Ndof_QM_H - Ndof_Buffer_H = 3*count(cluster_mark_p == HYBRID_BUFFER_MARK .and. at%Z == 1) - Ndof_Buffer_heavy = 3*count(cluster_mark_p == HYBRID_BUFFER_MARK) - Ndof_Buffer_H - n_H = count(at%Z == 1) - n_heavy = at%N - n_H - Ndof_MM_H = 3*n_H - (Ndof_QM_H+Ndof_Buffer_H) - Ndof_MM_heavy = 3*n_heavy - (Ndof_QM_heavy+Ndof_Buffer_heavy) - endif - endif - - call print("set_thermostat_masses got NDOFs (H, heavy) QM " // Ndof_QM_H // " " // Ndof_QM_heavy // & - " Buffer " // Ndof_Buffer_H // " " // Ndof_Buffer_heavy // " MM " // Ndof_MM_H // " " // Ndof_MM_heavy) - - select case(Thermostat_Type) - case (0) - continue - case (1,2) - if (Nose_Hoover_tau > 0.0_dp) then - ds%thermostat(1)%Q = nose_hoover_mass(Ndof=3*at%N, T=T, tau=Nose_Hoover_tau) - else - ds%thermostat(1)%Q = -1.0_dp - endif - case(3, 4, 8) - do i=1, ds%atoms%N - ds%thermostat(i)%Q = nose_hoover_mass(Ndof=3, T=T, tau=Nose_Hoover_tau) - end do - case(5) - ds%thermostat(1)%Q = nose_hoover_mass(Ndof=Ndof_QM_heavy+Ndof_Buffer_heavy, T=T, tau=Nose_Hoover_tau) - ds%thermostat(2)%Q = nose_hoover_mass(Ndof=Ndof_QM_H+Ndof_Buffer_H, T=T, tau=Nose_Hoover_tau) - ds%thermostat(3)%Q = nose_hoover_mass(Ndof=Ndof_MM_H+Ndof_MM_heavy, T=T, tau=Nose_Hoover_tau) - case(6) - ds%thermostat(1)%Q = nose_hoover_mass(Ndof=Ndof_QM_heavy, T=T, tau=Nose_Hoover_tau) - ds%thermostat(2)%Q = nose_hoover_mass(Ndof=Ndof_QM_H, T=T, tau=Nose_Hoover_tau) - ds%thermostat(3)%Q = nose_hoover_mass(Ndof=Ndof_Buffer_heavy, T=T, tau=Nose_Hoover_tau) - ds%thermostat(4)%Q = nose_hoover_mass(Ndof=Ndof_Buffer_H, T=T, tau=Nose_Hoover_tau) - ds%thermostat(5)%Q = nose_hoover_mass(Ndof=Ndof_MM_heavy, T=T, tau=Nose_Hoover_tau) - ds%thermostat(6)%Q = nose_hoover_mass(Ndof=Ndof_MM_H, T=T, tau=Nose_Hoover_tau) - case(7) - ds%thermostat(1)%Q = nose_hoover_mass(Ndof=Ndof_QM_heavy, T=T, tau=Nose_Hoover_tau) - ds%thermostat(2)%Q = nose_hoover_mass(Ndof=Ndof_QM_H, T=T, tau=Nose_Hoover_tau) - ds%thermostat(3)%Q = nose_hoover_mass(Ndof=Ndof_Buffer_heavy, T=T, tau=Nose_Hoover_tau) - ds%thermostat(4)%Q = nose_hoover_mass(Ndof=Ndof_Buffer_H, T=T, tau=Nose_Hoover_tau) - ds%thermostat(5)%Q = nose_hoover_mass(Ndof=Ndof_MM_heavy, T=T, tau=Nose_Hoover_tau) - ds%thermostat(6)%Q = nose_hoover_mass(Ndof=Ndof_MM_H, T=T, tau=Nose_Hoover_tau) - case default - call system_abort("set_thermostat_masses: Unknown thermostat_type="//thermostat_type//" in set_thermostat_masses") - end select - end subroutine set_thermostat_masses - - subroutine set_thermostat_regions(at, thermostat_type, Thermostat_7_rs, Thermostat_7_centre) - type(Atoms), intent(inout) :: at - integer, intent(in) :: thermostat_type - real(dp), intent(in) :: thermostat_7_rs(2), Thermostat_7_centre(3) - - integer, pointer :: cluster_mark_p(:) - real(dp) :: r - - select case(Thermostat_Type) - case(0) - continue - case(1, 2) - at%thermostat_region = 1 - case(3, 4, 8) - do i=1, ds%atoms%N - at%thermostat_region(i) = i - end do - case (5) - if (.not. assign_pointer(at, 'cluster_mark_extended', cluster_mark_p)) & - call system_abort("set_thermostat_region failed to find cluster_mark_extended for thermostat_type="//thermostat_type) - at%thermostat_region = 3 ! MM - where ((cluster_mark_p /= HYBRID_NO_MARK .and. cluster_mark_p /= HYBRID_TERM_MARK) .and. at%Z /= 1) ! QM+Buffer heave - at%thermostat_region = 1 - end where - where ((cluster_mark_p /= HYBRID_NO_MARK .and. cluster_mark_p /= HYBRID_TERM_MARK) .and. at%Z == 1) ! QM+Buffer H - at%thermostat_region = 2 - end where - case(6) - if (.not. assign_pointer(at, 'cluster_mark_extended', cluster_mark_p)) & - call system_abort("set_thermostat_region failed to find cluster_mark for thermostat_type="//thermostat_type) - where ((cluster_mark_p == HYBRID_ACTIVE_MARK) .and. at%Z /= 1) ! QM heavy - at%thermostat_region = 1 - end where - where ((cluster_mark_p == HYBRID_ACTIVE_MARK) .and. at%Z == 1) ! QM H - at%thermostat_region = 2 - end where - where ((cluster_mark_p == HYBRID_BUFFER_MARK) .and. at%Z /= 1) ! Buffer heavy - at%thermostat_region = 3 - end where - where ((cluster_mark_p == HYBRID_BUFFER_MARK) .and. at%Z == 1) ! Buffer H - at%thermostat_region = 4 - end where - where ((cluster_mark_p /= HYBRID_ACTIVE_MARK .and. cluster_mark_p /= HYBRID_BUFFER_MARK) .and. at%Z /= 1) ! MM heavy - at%thermostat_region = 5 - end where - where ((cluster_mark_p /= HYBRID_ACTIVE_MARK .and. cluster_mark_p /= HYBRID_BUFFER_MARK) .and. at%Z == 1) ! MM H - at%thermostat_region = 6 - end where - case (7) - call print("Thermostat=7, center at " // thermostat_7_centre, PRINT_ALWAYS) - do i=1, at%N - r = distance_min_image(at, i, thermostat_7_centre) - if (r < Thermostat_7_rs(1)) then - if (at%Z(i) /= 1) then - at%thermostat_region(i) = 1 - else - at%thermostat_region(i) = 2 - endif - else if (r < Thermostat_7_rs(2)) then - if (at%Z(i) /= 1) then - at%thermostat_region(i) = 3 - else - at%thermostat_region(i) = 4 - endif - else - if (at%Z(i) /= 1) then - at%thermostat_region(i) = 5 - else - at%thermostat_region(i) = 6 - endif - endif - end do - case default - call system_abort("set_thermostat_regions: Unknown thermostat_type="//thermostat_type//" in set_thermostat_masses") - end select - end subroutine set_thermostat_regions - - subroutine print_restraint_stuff(ds, restraint_stuff, suffix) - type(DynamicalSystem), intent(in) :: ds - real(dp), intent(in) :: restraint_stuff(:,:) - character(len=*), intent(in) :: suffix - logical, save :: firstcall = .true. - - if (firstcall) then - call print("#R t target_v C E dE/dcoll dE/dk ....") - endif - - call print('R'//trim(suffix) // " " // ds%t // " " // reshape( restraint_stuff, (/ size(restraint_stuff) /) )) - end subroutine print_restraint_stuff - - subroutine get_restraint_stuff(ds, restraint_stuff) - type(DynamicalSystem), intent(in) :: ds - real(dp), allocatable, intent(inout) :: restraint_stuff(:,:) - - integer :: i_r, n_s - - ! count number to print in summary n_s - n_s = 0 - do i_r = 1, ds%Nrestraints - if (ds%restraint(i_r)%print_summary) n_s=n_s + 1 - end do - - ! (re)allocate array - if (allocated(restraint_stuff)) then - if (size(restraint_stuff,1) /= 5 .or. size(restraint_stuff,2) /= n_s) deallocate(restraint_stuff) - endif - if (.not. allocated(restraint_stuff)) then - allocate(restraint_stuff(5,n_s)) - endif - - n_s = 0 - do i_r = 1, ds%Nrestraints - if (ds%restraint(i_r)%print_summary) then - n_s = n_s + 1 - restraint_stuff(1,n_s) = ds%restraint(i_r)%target_v - restraint_stuff(2,n_s) = ds%restraint(i_r)%C - restraint_stuff(3,n_s) = ds%restraint(i_r)%E - restraint_stuff(4,n_s) = -ds%restraint(i_r)%dE_dcoll - restraint_stuff(5,n_s) = -ds%restraint(i_r)%dE_dk - endif - end do - end subroutine get_restraint_stuff - - !% print coord, velo and force of constraint atoms in a cv file - subroutine print_cv(ds,time_step,first) - type(dynamicalsystem), intent(in) :: ds - real(dp), intent(in) :: time_step - logical, intent(in) :: first - real(dp), pointer :: v(:,:),f(:,:) - character(len=STRING_LENGTH) :: output_line - integer :: i,j - nullify(v) - if (.not. assign_pointer(ds%atoms, 'velo', v)) call system_abort("Could not find velo property.") - nullify(f) - if (.not. assign_pointer(ds%atoms, 'frc', f)) then - if (.not. assign_pointer(ds%atoms, 'force', f)) call system_abort("Could not find frc or force property.") - endif - do j=1,ds%Nconstraints - if (first) call print("CV"//j//"| "//"# Step Nr. Time[fs] Atom Nr. Pos_x[A] Pos_y[A] Pos_z[A] Vel_x[A/fs] Vel_y[A/fs] Vel_z[A/fs] Frc_x[eV/A] Frc_y[eV/A] Frc_z[eV/A]") - do i=1,ds%constraint(j)%N - write (output_line,FMT="(I8,F13.3,I8,9F13.8)") & - nint(ds%t/time_step), ds%t, ds%constraint(j)%atom(i), & - ds%atoms%pos(1:3,ds%constraint(j)%atom(i)), & - (v(1:3,ds%constraint(j)%atom(i))), & - (f(1:3,ds%constraint(j)%atom(i))) - call print("CV"//j//"| "//trim(output_line)) - enddo - enddo - end subroutine print_cv - - subroutine update_QM_region(ds_atoms, mark_postfix, qm_region_pt_ctr, qm_region_ctr, qm_region_atom_ctr, qm_list_filename, inner_radius, outer_radius, buffer_general, use_create_cluster_info_for_core, first_time, qm_seed, error) - type(Atoms), intent(inout) :: ds_atoms - character(len=*), intent(in) :: mark_postfix - logical, intent(in) :: qm_region_pt_ctr - real(dp), intent(inout) :: qm_region_ctr(3) - integer, intent(in) :: qm_region_atom_ctr - character(len=*), intent(in) :: qm_list_filename - real(dp), intent(in) :: inner_radius, outer_radius - logical, intent(in) :: buffer_general, use_create_cluster_info_for_core - logical, intent(in) :: first_time - type(table), intent(inout) :: qm_seed - integer, pointer :: hybrid_p(:), hybrid_mark_p(:), cluster_mark_p(:) - integer, optional, intent(out) :: error - - logical :: list_changed1 - - INIT_ERROR(error) - - if (first_time) then - call add_property(ds_atoms,'hybrid'//trim(mark_postfix),HYBRID_NO_MARK) - call add_property(ds_atoms,'hybrid_mark'//trim(mark_postfix),HYBRID_NO_MARK) - call add_property(ds_atoms,'old_hybrid_mark'//trim(mark_postfix),HYBRID_NO_MARK) - call add_property(ds_atoms,'cluster_mark'//trim(mark_postfix),HYBRID_NO_MARK) - call add_property(ds_atoms,'old_cluster_mark'//trim(mark_postfix),HYBRID_NO_MARK) - call add_property(ds_atoms,'cut_bonds'//trim(mark_postfix), 0, n_cols=MAX_CUT_BONDS) - call add_property(ds_atoms,'old_cut_bonds'//trim(mark_postfix), 0, n_cols=MAX_CUT_BONDS) - endif - - if (qm_region_pt_ctr) then - if (first_time) then - call map_into_cell(ds_atoms) - call calc_dists(ds_atoms) - endif - if (qm_region_atom_ctr /= 0) qm_region_ctr = ds_atoms%pos(:,qm_region_atom_ctr) - !update hybrid_*, hybrid_mark_*, old_hybrid_mark_* - call create_pos_or_list_centred_hybrid_region(ds_atoms,inner_radius,outer_radius, & - origin=qm_region_ctr,add_only_heavy_atoms=(.not. buffer_general), & - cluster_hopping_nneighb_only=.false., cluster_heuristics_nneighb_only=.true., & - use_create_cluster_info=use_create_cluster_info_for_core,& - list_changed=list_changed1, res_num_silica=res_num_silica, & - mark_postfix=trim(mark_postfix), error=error) - PASS_ERROR(error) - if (.not.(assign_pointer(ds_atoms, "hybrid_mark"//trim(mark_postfix), hybrid_mark_p))) call system_abort('??') - if (list_changed1) then - call print('Region with postfix "'//trim(mark_postfix)//'" has changed') - endif - else ! not qm_region_pt_ctr - !QM region centred around an atom list - - if (first_time) then !reinitialise QM region - - !read QM seed - call read_qmlist(ds_atoms,qm_list_filename,qm_seed) - - if (.not. (assign_pointer(ds_atoms, 'hybrid'//trim(mark_postfix), hybrid_p))) call system_abort("??") - if (.not.(assign_pointer(ds_atoms, "hybrid_mark"//trim(mark_postfix), hybrid_mark_p))) call system_abort('??') - if (.not.(assign_pointer(ds_atoms, "cluster_mark"//trim(mark_postfix), cluster_mark_p))) call system_abort('??') - - !call print("MARKSX0 "//count(hybrid_p(1:ds_atoms%N)==1)//" + "//count(hybrid_p(1:ds_atoms%N)==2)//" hybrid atoms",PRINT_ANALYSIS) - !call print("MARKSX0 "//count(hybrid_mark_p(1:ds_atoms%N)==1)//" + "//count(hybrid_mark_p(1:ds_atoms%N)==2)//" hybrid_mark atoms",PRINT_ANALYSIS) - !call print("MARKSX0 "//count(cluster_mark_p(1:ds_atoms%N)==1)//" + "//count(cluster_mark_p(1:ds_atoms%N)==2)//" cluster_mark atoms",PRINT_ANALYSIS) - - !(re)initialise the hysteretic qm region with (re)initialising hybrid_*, hybrid_mark_* and cluster_mark_* - hybrid_p(1:ds_atoms%N) = HYBRID_NO_MARK - hybrid_p(int_part(qm_seed,1)) = HYBRID_ACTIVE_MARK - hybrid_mark_p(1:ds_atoms%n) = hybrid_p(1:ds_atoms%n) - call print('hybrid_mark '//count(hybrid_mark_p.eq.1)) - cluster_mark_p(1:ds_atoms%N) = hybrid_mark_p(1:ds_atoms%N) - call print('cluster_mark '//count(cluster_mark_p.eq.1)) - - !call print("MARKSX1 "//count(hybrid_p(1:ds_atoms%N)==1)//" + "//count(hybrid_p(1:ds_atoms%N)==2)//" hybrid atoms",PRINT_ANALYSIS) - !call print("MARKSX1 "//count(hybrid_mark_p(1:ds_atoms%N)==1)//" + "//count(hybrid_mark_p(1:ds_atoms%N)==2)//" hybrid_mark atoms",PRINT_ANALYSIS) - !call print("MARKSX1 "//count(cluster_mark_p(1:ds_atoms%N)==1)//" + "//count(cluster_mark_p(1:ds_atoms%N)==2)//" cluster_mark atoms",PRINT_ANALYSIS) - - endif - - !if (.not. (assign_pointer(ds_atoms, 'hybrid'//trim(mark_postfix), hybrid_p))) call system_abort("??") - !if (.not.(assign_pointer(ds_atoms, "hybrid_mark"//trim(mark_postfix), hybrid_mark_p))) call system_abort('??') - !if (.not.(assign_pointer(ds_atoms, "cluster_mark"//trim(mark_postfix), cluster_mark_p))) call system_abort('??') - !call print("MARKS0 "//count(hybrid_p(1:ds_atoms%N)==1)//" + "//count(hybrid_p(1:ds_atoms%N)==2)//" hybrid atoms",PRINT_ANALYSIS) - !call print("MARKS0 "//count(hybrid_mark_p(1:ds_atoms%N)==1)//" + "//count(hybrid_mark_p(1:ds_atoms%N)==2)//" hybrid_mark atoms",PRINT_ANALYSIS) - !call print("MARKS0 "//count(cluster_mark_p(1:ds_atoms%N)==1)//" + "//count(cluster_mark_p(1:ds_atoms%N)==2)//" cluster_mark atoms",PRINT_ANALYSIS) - - !extend QM region around seed atoms - !update hybrid_*, hybrid_mark_*, old_hybrid_mark_* - call create_pos_or_list_centred_hybrid_region(ds_atoms,inner_radius,outer_radius,atomlist=qm_seed, & - add_only_heavy_atoms=(.not. buffer_general),cluster_hopping_nneighb_only=.false.,cluster_heuristics_nneighb_only=.true.,min_images_only=.true., & - use_create_cluster_info=use_create_cluster_info_for_core,& - list_changed=list_changed1, res_num_silica=res_num_silica, & - mark_postfix=trim(mark_postfix), error=error) - PASS_ERROR(error) - - !if (.not. (assign_pointer(ds_atoms, 'hybrid'//trim(mark_postfix), hybrid_p))) call system_abort("??") - !if (.not.(assign_pointer(ds_atoms, "hybrid_mark"//trim(mark_postfix), hybrid_mark_p))) call system_abort('??') - !if (.not.(assign_pointer(ds_atoms, "cluster_mark"//trim(mark_postfix), cluster_mark_p))) call system_abort('??') - !call print("MARKS1 "//count(hybrid_p(1:ds_atoms%N)==1)//" + "//count(hybrid_p(1:ds_atoms%N)==2)//" hybrid atoms",PRINT_ANALYSIS) - !call print("MARKS1 "//count(hybrid_mark_p(1:ds_atoms%N)==1)//" + "//count(hybrid_mark_p(1:ds_atoms%N)==2)//" hybrid_mark atoms",PRINT_ANALYSIS) - !call print("MARKS1 "//count(cluster_mark_p(1:ds_atoms%N)==1)//" + "//count(cluster_mark_p(1:ds_atoms%N)==2)//" cluster_mark atoms",PRINT_ANALYSIS) - - endif ! qm_region_pt_ctr - end subroutine update_QM_region - -end program qmmm_md diff --git a/src/Programs/align.f95 b/src/Programs/align.f95 deleted file mode 100644 index 38ba09bb81..0000000000 --- a/src/Programs/align.f95 +++ /dev/null @@ -1,110 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Align a configuration (presumably a molecule) so that moment of inertia -! axes are aligned with cartesian axes -program align_prog -use libatoms_module -implicit none - type(Atoms) :: at - type(Dictionary) :: cli_params - real(dp) :: cutoff - - real(dp) :: CoM(3), MoI(3,3), MoI_evecs(3,3), MoI_evals(3) - real(dp) :: rot_mat(3,3) - integer :: i, ii(1) - real(dp), allocatable :: orig_mass(:) - real(dp), pointer :: mass(:) - character(len=2048) :: props - - call system_initialise() - - call initialise(cli_params) - call param_register(cli_params, 'cutoff', '2.0', cutoff, help_string="cutoff in A for nearest-neighbors to figure out what's a single molecule") - if (.not. param_read_args(cli_params)) then - call print("Usage: align [cutoff=5.0]", PRINT_ALWAYS) - call system_abort("Confused by CLI parameters") - endif - call finalise(cli_params) - - call read(at, "stdin") - props = prop_names_string(at) - - if (.not.(assign_pointer(at,'mass', mass))) then - call add_property(at,'mass',0.0_dp) - if (.not.(assign_pointer(at,'mass', mass))) & - call system_abort("ERROR: Impossible failure to add mass property to atoms") - mass = 1.0_dp - else - allocate(orig_mass(at%N)) - orig_mass = mass - mass = 1.0_dp - endif - - call atoms_repoint(at) - - call set_cutoff(at, cutoff) - call calc_connect(at) - - call coalesce_in_one_periodic_image(at) - - CoM = centre_of_mass(at) - do i=1, at%N - at%pos(:,i) = at%pos(:,i) - CoM(:) - end do - - MoI = moment_of_inertia_tensor(at) - call diagonalise(MoI, MoI_evals, MoI_evecs) - - do i=1, 3 - ii = maxloc(MoI_evals) - rot_mat(i,:) = MoI_evecs(:,ii(1)) - MoI_evals(ii(1)) = -1.0e38_dp - end do - - do i=1, at%N - at%pos(:,i) = matmul(rot_mat,at%pos(:,i)) - end do - - if (allocated(orig_mass)) then - mass = orig_mass - deallocate(orig_mass) - endif - - at%lattice = 0.0_dp - at%lattice(1,1) = (maxval(at%pos(1,:)) - minval(at%pos(1,:)))*2.0_dp+5.0_dp - at%lattice(2,2) = (maxval(at%pos(2,:)) - minval(at%pos(2,:)))*2.0_dp+5.0_dp - at%lattice(3,3) = (maxval(at%pos(3,:)) - minval(at%pos(3,:)))*2.0_dp+5.0_dp - - ! call print("props" // trim(props)) - call write(at, "stdout", properties=trim(props), prefix="ALIGNED") - - call system_finalise() -end program diff --git a/src/Programs/analytical_free_E_UI.f95 b/src/Programs/analytical_free_E_UI.f95 deleted file mode 100644 index 3e5bbbb816..0000000000 --- a/src/Programs/analytical_free_E_UI.f95 +++ /dev/null @@ -1,177 +0,0 @@ -program test_UI_k -use libatoms_module -implicit none - integer :: n, i, j - real(dp), allocatable :: Vx(:), Vy(:), dF_dl_x(:), dF_dl_y(:), integrand_x(:), integrand_y(:) - real(dp) :: min_x, max_x, x, l, dx - real(dp) :: k, beta, T - type(spline) :: V0_spline, dF_dl_spline - integer :: n_samples = 500 - real(dp) :: min_V0, min_V0_x, max_V0_x, F, min_F_1, min_F_2, max_F - real(dp) :: normalization, prob_left, prob_right - - call system_initialise() - - read *, n - allocate(Vx(n), Vy(n)) - do i=1, n - read *, Vx(i), Vy(i) - end do - read *, min_x, max_x - read *, k, T - beta = 1.0_dp/T - - ! calculate potential spline V0 - call initialise(V0_spline, Vx, Vy, (Vy(2)-Vy(1))/(Vx(2)-Vx(1)), (Vy(n)-Vy(n-1))/(Vx(n)-Vx(n-1))) - min_V0 = 1e38 - dx = (max_x-min_x)/real(n_samples-1,dp) - do i=1, n_samples - x = min_x + real(i-1,dp)*dx - if (spline_value(V0_spline,x) < min_V0) then - min_V0_x = x - min_V0 = spline_value(V0_spline, x) - endif - if (i > 1 .and. i < n_samples) then - if (spline_value(V0_spline,x) > spline_value(V0_spline,x-dx) .and. spline_value(V0_spline,x) > spline_value(V0_spline,x+dx)) then - max_V0_x = x - endif - endif - call print ("V0 "// x//" " // spline_value(V0_spline, x) //" " // spline_deriv(V0_spline, x)) - end do - - call print("V0 min max x " // min_V0_x // " " // max_V0_x) - - ! dF/dl(l) = \integral_{-\infty}^{\infty} dx dVr/dl(x,l,k) \exp(-beta (V0(x) + Vr(x,l,k))) - allocate(dF_dl_x(n_samples), dF_dl_y(n_samples)) - allocate(integrand_x(3*n_samples), integrand_y(3*n_samples)) - do i=1, n_samples - l = min_x + (max_x-min_x)*real(i-1,dp)/real(n_samples-1,dp) - dF_dl_x(i) = l - - do j=1, 3*n_samples - x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp) - integrand_x(j) = x - integrand_y(j) = dVr_dl(x,l,k) * exp(-beta*(spline_value(V0_spline,x)+Vr(x,l,k))) -! call print("dF_dl integrand_y " // (-beta*(spline_value(V0_spline,x)+Vr(x,l,k))) // " " // integrand_y(j)) - end do - dF_dl_y(i) = TrapezoidIntegral(integrand_x, integrand_y) - - do j=1, 3*n_samples - x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp) - integrand_x(j) = x - integrand_y(j) = exp(-beta*(spline_value(V0_spline,x)+Vr(x,l,k))) - end do - dF_dl_y(i) = dF_dl_y(i) / TrapezoidIntegral(integrand_x, integrand_y) - - end do - call initialise(dF_dl_spline, dF_dl_x, dF_dl_y, (dF_dl_y(2)-dF_dl_y(1))/(dF_dl_x(2)-dF_dl_x(1)), (dF_dl_y(n)-dF_dl_y(n-1))/(dF_dl_x(n)-dF_dl_x(n-1))) - do i=1, n_samples - x = min_x + (max_x-min_x)*real(i-1,dp)/real(n_samples-1,dp) - call print ("dF_dl "// x//" " // spline_value(dF_dl_spline, x) // " " // spline_nintegrate(dF_dl_spline, min_V0_x, x)) - end do - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - dx = 3*(max_x-min_x)/real(3*n_samples-1,dp) - do j=1, 3*n_samples - x = min_x-(max_x-min_x) + real(j-1,dp)*dx - integrand_x(j) = x - F = spline_value(V0_spline, x) - integrand_y(j) = exp(-beta*F) - end do - normalization = TrapezoidIntegral(integrand_x, integrand_y) - - do j=1, 3*n_samples - x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp) - integrand_x(j) = x - if (x <= max_V0_x) then - integrand_y(j) = exp(-beta*spline_value(V0_spline,x)) - else - integrand_y(j) = 0.0_dp - endif - end do - prob_left = TrapezoidIntegral(integrand_x, integrand_y)/normalization - - do j=1, 3*n_samples - x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp) - integrand_x(j) = x - if (x > max_V0_x) then - integrand_y(j) = exp(-beta*spline_value(V0_spline,x)) - else - integrand_y(j) = 0.0_dp - endif - end do - prob_right = TrapezoidIntegral(integrand_x, integrand_y)/normalization - call print("V0 integrals: left basin probability " // prob_left // " right basin probability " // prob_right // & - " ratio " // (prob_right/prob_left)) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - dx = 3*(max_x-min_x)/real(3*n_samples-1,dp) - min_F_1 = 1e38_dp - min_F_2 = 1e38_dp - do j=1, 3*n_samples - x = min_x-(max_x-min_x) + real(j-1,dp)*dx - integrand_x(j) = x - F = spline_nintegrate(dF_dl_spline, min_V0_x, x) - if (j > 1 .and. j < 3*n_samples) then - if (F > spline_nintegrate(dF_dl_spline, min_V0_x, x-dx) .and. F > spline_nintegrate(dF_dl_spline, min_V0_x, x+dx)) then - max_F = F - endif - if (F < spline_nintegrate(dF_dl_spline, min_V0_x, x-dx) .and. F < spline_nintegrate(dF_dl_spline, min_V0_x, x+dx)) then - if (min_F_1 < 1e37_dp) then - min_F_2 = F - else - min_F_1 = F - endif - endif - endif - integrand_y(j) = exp(-beta*F) - end do - normalization = TrapezoidIntegral(integrand_x, integrand_y) - - do j=1, 3*n_samples - x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp) - integrand_x(j) = x - if (x <= max_V0_x) then - integrand_y(j) = exp(-beta*spline_nintegrate(dF_dl_spline, min_V0_x, x)) - else - integrand_y(j) = 0.0_dp - endif - end do - prob_left = TrapezoidIntegral(integrand_x, integrand_y)/normalization - - do j=1, 3*n_samples - x = min_x-(max_x-min_x) + 3*(max_x-min_x)*real(j-1,dp)/real(3*n_samples-1,dp) - integrand_x(j) = x - if (x > max_V0_x) then - integrand_y(j) = exp(-beta*spline_nintegrate(dF_dl_spline, min_V0_x, x)) - else - integrand_y(j) = 0.0_dp - endif - end do - prob_right = TrapezoidIntegral(integrand_x, integrand_y)/normalization - call print("F integrals: left basin probability " // prob_left // " right basin probability " // prob_right // & - " ratio " // (prob_right/prob_left)) - call print("F minima: " // min_F_1 // " " // min_F_2 // " prob ratio " // exp(-beta*(min_F_2-min_F_1)) // " max " // max_F) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call finalise(V0_spline) - call finalise(dF_dl_spline) - call system_finalise() - -contains - function Vr(x,l,k) - real(dp), intent(in) :: x, l, k - real(dp) :: Vr - - Vr = k*(x-l)**2 - end function Vr - - function dVr_dl(x,l,k) - real(dp), intent(in) :: x, l, k - real(dp) :: dVr_dl - - dVr_dl = -2.0_dp*k*(x-l) - end function dVr_dl - -end program diff --git a/src/Programs/analyze_md_phonons.f95 b/src/Programs/analyze_md_phonons.f95 deleted file mode 100644 index 39aed9ffae..0000000000 --- a/src/Programs/analyze_md_phonons.f95 +++ /dev/null @@ -1,176 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" -module analyze_md_phonons_mod -use libatoms_module -implicit none - -contains - -subroutine phonon_evec_to_displacements(phonon, Z) - real(dp) :: phonon(:,:) - integer :: Z(:) - - integer i - - do i=1, size(phonon,2) - phonon(:,i) = phonon(:,i) / sqrt(ElementMass(Z(i))) - end do -end subroutine -end module analyze_md_phonons_mod - -program analyze_md_phonons -use libatoms_module -use analyze_md_phonons_mod -implicit none - type(atoms) :: config - integer n_phonons - real(dp), allocatable :: phonons(:,:,:) - type(CInOutput) :: phonons_io, md_io - real(dp), pointer :: phonon_displ(:,:) - integer i, config_i, j - logical done - integer error - real(dp), allocatable :: ke_proj(:) - real(dp) :: vel_mag, ke_tot, p(3), L(3), mode_vel - real(dp) :: MoI(3,3), MoI_evecs(3,3), MoI_evals(3), MoI_evecs_orig(3,3), R(3,3) - character(len=STRING_LENGTH) phonons_file - logical :: fix_rotation, regular_eigenproblem - type(dictionary) :: cli_params - - - call system_initialise() - - call initialise(cli_params) - call param_register(cli_params, "phonons_file", "phonons.xyz", phonons_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "fix_rotation", "F", fix_rotation, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "regular_eigenproblem", "F", regular_eigenproblem, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - call print("Usage: analyze_md_phonons [phonons_file=file(phonons.xyz)] [fix_rotation=T/F(F)]", PRINT_ALWAYS) - call print(" [regular_eigenproblem=T/F(F)]", PRINT_ALWAYS) - call system_abort("Confused by parameters") - endif - call finalise(cli_params) - - call print("phonons_file '" // trim(phonons_file) // "'") - call print("fix_rotation " // fix_rotation) - call initialise(phonons_io, phonons_file) - - call read(config, phonons_io) - n_phonons = 3*config%N - allocate(phonons(3, config%N, n_phonons)) - if (.not. assign_pointer(config, "phonon", phonon_displ)) & - call system_abort("Couldn't find field phonon in phonon config " // 1) - if (regular_eigenproblem) call phonon_evec_to_displacements(phonon_displ, config%Z) - phonons(:,:,1) = phonon_displ - call print("phonon norm 1 " // sum(ElementMass(config%Z)*sum(phonons(:,:,1)**2,1))) - - do i=2, n_phonons - call read(config, phonons_io) - if (.not. assign_pointer(config, "phonon", phonon_displ)) & - call system_abort("Couldn't find field phonon in phonon config " // i) - if (regular_eigenproblem) call phonon_evec_to_displacements(phonon_displ, config%Z) - phonons(:,:,i) = phonon_displ - call print("phonon norm " // i // " " // sum(ElementMass(config%Z)*sum(phonons(:,:,i)**2,1))) - end do - - call finalise(phonons_io) - - call initialise(md_io, "stdin") - - allocate(ke_proj(n_phonons)) - - call print("Masses " // ElementMass(config%Z)) - -call add_property(config, "mass", 0.0_dp, 1) -call atoms_repoint(config) -config%mass = ElementMass(config%Z) -MoI = moment_of_inertia_tensor(config, centre_of_mass(config)) -call diagonalise(MoI, MoI_evals, MoI_evecs_orig) -call print(MoI_evecs_orig, PRINT_VERBOSE) - - done = .false. - config_i = 0 - do while (.not. done) - config_i = config_i + 1 - call read(config, md_io, error=error) - if (error /= 0) then - if (error == ERROR_IO_EOF) then - done = .true. - else - HANDLE_ERROR(error) - endif - else - call add_property(config, "mass", 0.0_dp, 1) - call atoms_repoint(config) - config%mass = ElementMass(config%Z) - if (.not. associated(config%velo)) & - call system_abort("config " // config_i // " has no velo pointer") - ke_tot = kinetic_energy(config) - p = momentum(config) - L = angular_momentum(config, centre_of_mass(config)) - MoI = moment_of_inertia_tensor(config, centre_of_mass(config)) - - if (fix_rotation) then - call diagonalise(MoI, MoI_evals, MoI_evecs) - do i=1,3 - if ((MoI_evecs(:,i) .dot. MoI_evecs_orig(:,i)) < 0) MoI_evecs(:,i) = - MoI_evecs(:,i) - end do - call print(MoI_evecs, PRINT_VERBOSE) - R = transpose(MoI_evecs_orig) .mult. MoI_evecs - config%velo = R .mult. config%velo - endif - - vel_mag = sqrt(sum(config%velo**2)) - if (vel_mag .feq. 0.0_dp) then - ke_proj = 0.0_dp - else - do i=1, n_phonons - mode_vel = 0.0_dp - do j=1, config%N - mode_vel = mode_vel + ElementMass(config%Z(j))*sum(phonons(:,j,i)*config%velo(:,j)) - end do - ke_proj(i) = mode_vel**2/2.0_dp - end do - endif - call print("check " // config_i // " p " // p // " L ", PRINT_VERBOSE) - call print("check ke_tot " // ke_tot // " sum(ke_proj) " // sum(ke_proj) // & - " sum(ke_proj(1:6)) " // sum(ke_proj(1:6)) // & - " sum(ke_proj(7:)) " // sum(ke_proj(7:)) // " ratio " // & - (sum(ke_proj(7:))/sum(ke_proj)), PRINT_VERBOSE) - call print("config " // config_i // " ke_proj " // ke_proj) - endif - end do - - call system_finalise() - -end program analyze_md_phonons - diff --git a/src/Programs/basin_exploration.f95 b/src/Programs/basin_exploration.f95 deleted file mode 100644 index 3d163e37f9..0000000000 --- a/src/Programs/basin_exploration.f95 +++ /dev/null @@ -1,356 +0,0 @@ -program basin_exploration -use libatoms_module -use k_means_clustering_module -use gp_basic_module -implicit none - -integer :: n_dim - -type (gp_basic), target :: gp -type (gp_basic), pointer :: gp_sparse -integer :: i_sample, n_samples -real(dp), allocatable :: sample_pos(:,:), sample_grad(:,:), sample_noise(:, :) - -integer :: i_cycle, n_cycles, i_candidate, n_candidates -real(dp), allocatable :: rv(:), cur_pos(:) -real(dp) :: simplex_step_length, shooting_step_length, gaussian_width, min_mindist, step_var_target -integer, allocatable :: candidate_i_sample(:) -real(dp), allocatable :: candidate_pos(:,:), candidate_E(:), candidate_prob(:) -real(dp) :: sampling_T -real(dp), allocatable :: len_scale(:), periodicity(:), sparse_len_scale(:) - -integer :: n_sparse_samples -integer, allocatable :: g_sparse_set(:) - -logical :: doubling_interp, doubling_interp_repeat, generate_from_mindist -integer :: gp_guess_sparsify - -call system_initialise(verbosity=PRINT_SILENT, enable_timing=.true.) -call verbosity_push(PRINT_NORMAL) - -read *, n_dim -read *, n_cycles, n_candidates -read *, sampling_T -read *, simplex_step_length, shooting_step_length, step_var_target, min_mindist -read *, gaussian_width -read *, doubling_interp, doubling_interp_repeat, gp_guess_sparsify, generate_from_mindist - -print *, "n_dim ", n_dim -print *, "n_cycles n_candidates ", n_cycles, n_candidates -print *, "sampling_T ", sampling_T -print *, "simplex_step_length shooting_step_length, min_mindist ",simplex_step_length, shooting_step_length, min_mindist -print *, "gaussian_width ", gaussian_width -print *, "doubling_interp, doubling_interp_repeat, gp_guess_sparsify, generate_from_mindist ", & - doubling_interp, doubling_interp_repeat, gp_guess_sparsify, generate_from_mindist - -allocate(rv(n_dim), cur_pos(n_dim)) -allocate(len_scale(n_dim), periodicity(n_dim), sparse_len_scale(n_dim)) - -! n_cycles = 500 -! n_candidates = 1000 -! sampling_T = 0.01_dp -! -! simplex_step_length=0.25_dp -! shooting_step_length=0.10_dp -! gaussian_width=0.5_dp - -len_scale = gaussian_width -periodicity = 0.0_dp - -! sparsify_factor^(1/dim) = len_scale_factor -sparse_len_scale = len_scale * (gp_guess_sparsify**(1.0_dp/real(n_dim, dp))) -! sparse_len_scale = 2.0_dp*len_scale - -print *, "len_scale ", len_scale -print *, "sparse_len_scale ", sparse_len_scale - -allocate(sample_pos(n_dim,n_dim+1+n_cycles), sample_grad(n_dim,n_dim+1+n_cycles), sample_noise(n_dim, n_dim+1+n_cycles)) - -call create_simplex(sample_pos(:,1:n_dim+1)) -sample_pos(:,1:n_dim+1) = simplex_step_length*sample_pos(:,1:n_dim+1) -n_samples = n_dim+1 -do i_sample=1, n_samples - call eval_grad(sample_pos(:,i_sample), sample_grad(:,i_sample), sample_noise(:,i_sample)) -end do - -if (gp_guess_sparsify > 1) then - allocate(gp_sparse) -else - gp_sparse => gp -endif - -call initialise(gp, len_scale, periodicity, 0.25_dp, SE_kernel_r_rr, & - g_r=sample_pos(:,1:n_samples), g_v=sample_grad(:,1:n_samples), g_n=sample_noise(:,1:n_samples), jitter=1.0e-10_dp) -call print_gp(gp, gp_sparse, sample_pos(:, 1:n_samples), 0) -if (gp_guess_sparsify > 1) then - call initialise(gp_sparse, sparse_len_scale, periodicity, 0.25_dp, SE_kernel_r_rr, & - g_r=sample_pos(:,1:n_samples), g_v=sample_grad(:,1:n_samples), g_n=sample_noise(:,1:n_samples), jitter=1.0e-10_dp) -endif - -allocate(candidate_i_sample(n_candidates), candidate_pos(n_dim,n_candidates), candidate_E(n_candidates)) -allocate(candidate_prob(0:n_candidates)) - -do i_cycle=1, n_cycles -call system_timer("generate") - ! generate candidates - do i_candidate=1, n_candidates - candidate_i_sample(i_candidate) = int(ran_uniform()*n_samples)+1 - call generate_sample_pos(candidate_pos(:,i_candidate), sample_pos(:, candidate_i_sample(i_candidate)), gp, gp_sparse, & - shooting_step_length, step_var_target, min_mindist, & - sample_pos(:,1:n_samples), doubling_interp, doubling_interp_repeat, generate_from_mindist) - candidate_E(i_candidate) = f_predict(gp, candidate_pos(:, i_candidate), SE_kernel_r_rr) - end do -call system_timer("generate") - -call system_timer("select") - ! select candidate - candidate_prob(0) = 0.0_dp - candidate_prob(1:n_candidates) = exp(-candidate_E/sampling_T) - candidate_prob = candidate_prob / sum(candidate_prob) - do i_candidate=1, n_candidates - candidate_prob(i_candidate) = candidate_prob(i_candidate) + candidate_prob(i_candidate-1) - end do - rv(1) = ran_uniform() - do i_candidate=1, n_candidates - if (rv(1) >= candidate_prob(i_candidate-1) .and. rv(1) < candidate_prob(i_candidate)) then - cur_pos = candidate_pos(:,i_candidate) - print *, i_cycle, " selected sample pos, E ",cur_pos, candidate_E(i_candidate) - exit - end if - end do -call system_timer("select") - -call system_timer("evaluate_teach") - ! evaluate at cur_pos - n_samples = n_samples + 1 - sample_pos(:, n_samples) = cur_pos - call eval_grad(sample_pos(:,n_samples), sample_grad(:,n_samples), sample_noise(:,n_samples)) - call initialise(gp, len_scale, periodicity, 0.25_dp, SE_kernel_r_rr, & - g_r=sample_pos(:,1:n_samples), g_v=sample_grad(:,1:n_samples), g_n=sample_noise(:,1:n_samples), jitter=1.0e-10_dp) -call system_timer("evaluate_teach") -call system_timer("print") - call print_gp(gp, gp_sparse, sample_pos(:, 1:n_samples), i_cycle) -call system_timer("print") - if (gp_guess_sparsify > 1) then -call system_timer("evaluate_teach_sparse") - if (n_samples > gp_guess_sparsify*10) then - n_sparse_samples = n_samples/gp_guess_sparsify - allocate(g_sparse_set(n_sparse_samples)) - call k_means_clustering_pick(sample_pos(:,1:n_samples), periodicity, g_sparse_set) - call initialise(gp_sparse, sparse_len_scale, periodicity, 0.25_dp, SE_kernel_r_rr, & - g_r=sample_pos(:,1:n_samples), g_v=sample_grad(:,1:n_samples), g_n=sample_noise(:,1:n_samples), & - g_sparse_set=g_sparse_set, jitter=1.0e-10_dp) - deallocate(g_sparse_set) - else - call initialise(gp_sparse, sparse_len_scale, periodicity, 0.25_dp, SE_kernel_r_rr, & - g_r=sample_pos(:,1:n_samples), g_v=sample_grad(:,1:n_samples), g_n=sample_noise(:,1:n_samples), jitter=1.0e-10_dp) - endif -call system_timer("evaluate_teach_sparse") - endif - -end do - -call system_finalise() - -contains - -subroutine generate_sample_pos(new_pos, init_pos, gp, gp_for_var, step_length, step_var_target, min_mindist, sample_pos, & - doubling_interp, doubling_interp_repeat, generate_from_mindist) - real(dp), intent(out) :: new_pos(:) - real(dp), intent(in) :: init_pos(:) - type(gp_basic), intent(inout) :: gp, gp_for_var - real(dp), intent(in) :: step_length, step_var_target, min_mindist - real(dp), intent(in) :: sample_pos(:,:) - logical, intent(in) :: doubling_interp, doubling_interp_repeat, generate_from_mindist - - real(dp) :: rv(size(new_pos)), new_interpolated_pos(size(new_pos)) - real(dp) :: prev_var, new_var - real(dp) :: step_size, step_frac, min_mindist_sq, cur_mindist_sq - - integer :: n_dim, i_dim, n_samples - - n_dim = size(new_pos) - - step_size = step_length - - do i_dim=1, n_dim - rv(i_dim) = ran_normal() - end do - rv = rv / norm(rv) - if (generate_from_mindist) then - min_mindist_sq = min_mindist**2 - new_pos = init_pos + step_size*rv - n_samples = size(sample_pos, 2) - cur_mindist_sq = minval(sum((sample_pos-spread(new_pos, 2, n_samples))**2, dim=1)) - do while (cur_mindist_sq < min_mindist_sq) - new_pos = new_pos + step_size*rv - cur_mindist_sq = minval(sum((sample_pos-spread(new_pos, 2, n_samples))**2, dim=1)) - end do - print *, "final mindist ", sqrt(cur_mindist_sq) - !! - !! print *, "final mindist variance ", f_predict_var(gp_for_var, new_pos, SE_kernel_r_rr) - !! - else - new_pos = init_pos + step_size*rv - prev_var = 0.0_dp - new_var = f_predict_var(gp_for_var, new_pos, SE_kernel_r_rr) - print *, "predict_var initial ", new_var - do while (new_var < step_var_target) - if (doubling_interp) step_size = 2.0_dp * step_size - new_pos = new_pos + step_size*rv - prev_var = new_var - new_var = f_predict_var(gp_for_var, new_pos, SE_kernel_r_rr) - print *, "predict_var shooting ", new_var - end do - - if (doubling_interp) then - print *, "final vars ", prev_var, new_var - ! prev_var + step_frac*(new_var-prev_var) = step_var_target - step_frac = (step_var_target-prev_var)/(new_var-prev_var) - new_interpolated_pos = new_pos - (1.0_dp-step_frac)*step_size*rv - if (doubling_interp_repeat) then - prev_var = f_predict_var(gp_for_var, new_interpolated_pos, SE_kernel_r_rr) - print *, "predict_var initial interpolation ", prev_var - do while (prev_var < step_var_target) - step_size = (1.0_dp-step_frac)*step_size - step_frac = 0.5_dp - new_interpolated_pos = new_pos - (1.0_dp-step_frac)*step_size*rv - prev_var = f_predict_var(gp_for_var, new_interpolated_pos, SE_kernel_r_rr) - print *, "predict_var interpolation ", prev_var - end do - endif ! doubling_interp_repeat - new_pos = new_interpolated_pos - endif ! doubling_interp - !! - !! new_var = f_predict_var(gp_for_var, new_pos, SE_kernel_r_rr) - !! print *, "candidate final pos var ", new_pos, new_var, f_predict_var(gp, new_pos, SE_kernel_r_rr) - !! - endif - -end subroutine generate_sample_pos - -subroutine print_gp(gp, gp_sparse, sample_pos, i_label) - type(gp_basic), intent(inout) :: gp, gp_sparse - real(dp), intent(in) :: sample_pos(:,:) - integer, intent(in) :: i_label - - integer:: i, j - real(dp) :: pos(size(sample_pos,1)), origin(size(sample_pos,1)) - real(dp) :: true_fval, err_offset, plot_offset - - integer :: grid_size = 40 - integer :: err_count - real(dp) :: err - - - ! align origin (minimum) for error offset - origin = 0.0_dp ! ; origin(1) = -5.0_dp - call eval_func(origin, err_offset) - err_offset = err_offset - f_predict(gp, origin, SE_kernel_r_rr) - - ! align far field for plot offset - origin = 0.0_dp; origin(1) = -5.0_dp - call eval_func(origin, plot_offset) - plot_offset = plot_offset - f_predict(gp, origin, SE_kernel_r_rr) - - open (unit=100, file="gp."//i_label, status="unknown") - err = 0.0_dp - err_count = 0 - do i=0, grid_size - do j=0, grid_size - pos = 0.0_dp - pos(1:2) = (/ 5.0*(2.0*(real(i, dp)/real(grid_size, dp)-0.5_dp)), 5.0*(2.0*(real(j, dp)/real(grid_size, dp)-0.5_dp)) /) - call eval_func(pos, true_fval) - write (unit=100, fmt=*) f_predict(gp, pos, SE_kernel_r_rr)+plot_offset, f_predict_var(gp, pos, SE_kernel_r_rr), & - f_predict_var(gp_sparse, pos, SE_kernel_r_rr), true_fval, pos(1:2) - if (f_predict_var(gp, pos, SE_kernel_r_rr) < 0.1_dp) then - err = err + (f_predict(gp, pos, SE_kernel_r_rr)+err_offset-true_fval)**2 - err_count = err_count + 1 - endif - end do - end do - write (unit=100, fmt='(A)') "" - write (unit=100, fmt='(A)') "" - do i=1, size(sample_pos, 2) - write(unit=100, fmt=*) sample_pos(:, i) - end do - write (unit=100, fmt='(A)') "" - write (unit=100, fmt='(A)') "" - err = sqrt(err/real(err_count,dp)) - write (unit=100, fmt='("ERR ",I6,F10.5)') err_count, err - - close (unit=100) - -end subroutine print_gp - -subroutine eval_func(pos, func) - real(dp), intent(in) :: pos(:) - real(dp), intent(out) :: func - - real(dp) :: r0(size(pos)), r1(size(pos)) - - r0 = 0.0_dp - r1 = 0.0_dp; r1(1) = 3.0_dp - - func = -exp(-normsq(pos-r0)) - exp(-normsq(pos-r1)) - -end subroutine eval_func - -subroutine eval_grad(pos, grad, noise) - real(dp), intent(in) :: pos(:) - real(dp), intent(out) :: grad(:), noise(:) - - integer :: i_dim - real(dp) :: r0(size(pos)), r1(size(pos)) - - n_dim = size(pos) - - if (size(grad) /= n_dim ) then - call system_abort("eval_grad got grad with bad dimensions "//shape(grad)) - endif - if (size(noise) /= n_dim ) then - call system_abort("eval_grad got noise with bad dimensions "//shape(noise)) - endif - - r0 = 0.0_dp - r1 = 0.0_dp; r1(1) = 3.0_dp - - grad = exp(-normsq(pos-r0))*2.0_dp*(pos-r0) + exp(-normsq(pos-r1))*2.0_dp*(pos-r1) - do i_dim=1, n_dim - grad(i_dim) = grad(i_dim) + 0.01_dp*ran_normal() - end do - noise = 0.01_dp**2 - -end subroutine eval_grad - -subroutine create_simplex(pos) - real(dp) :: pos(:, :) - - integer :: n_dim, i_dim - real(dp) :: target_dot, cur_dot - - n_dim = size(pos, 1) - if (size(pos, 2) /= n_dim + 1) then - call system_abort("create_simple got pos with bad dimensions "//shape(pos)) - endif - - target_dot = -1.0_dp / real(n_dim, dp) - - pos = 0.0_dp - ! first vector - pos(:,1) = 0.0_dp; pos(1,1) = 1.0_dp - ! all others - do i_dim=2, n_dim+1 - if (i_dim == 2) then - cur_dot = 0.0_dp - else - cur_dot = pos(1:i_dim-2, i_dim) .dot. pos(1:i_dim-2, i_dim-1) - endif - pos(i_dim-1, i_dim:n_dim+1) = (target_dot - cur_dot)/pos(i_dim-1,i_dim-1) - pos(i_dim, i_dim) = sqrt(1.0_dp-normsq(pos(1:i_dim-1,i_dim))) - end do - - pos = pos / norm(pos(:,1)-pos(:,2)) -end subroutine create_simplex - -end program diff --git a/src/Programs/bulktest.f95 b/src/Programs/bulktest.f95 deleted file mode 100644 index 1633ced496..0000000000 --- a/src/Programs/bulktest.f95 +++ /dev/null @@ -1,322 +0,0 @@ -! HJ XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! HJ X -! HJ X libAtoms+QUIP: atomistic simulation library -! HJ X -! HJ X Portions of this code were written by -! HJ X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! HJ X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! HJ X -! HJ X Copyright 2006-2010. -! HJ X -! HJ X These portions of the source code are released under the GNU General -! HJ X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! HJ X -! HJ X If you would like to license the source code under different terms, -! HJ X please contact Gabor Csanyi, gabor@csanyi.net -! HJ X -! HJ X Portions of this code were written by Noam Bernstein as part of -! HJ X his employment for the U.S. Government, and are not subject -! HJ X to copyright in the USA. -! HJ X -! HJ X -! HJ X When using this software, please cite the following reference: -! HJ X -! HJ X http://www.libatoms.org -! HJ X -! HJ X Additional contributions by -! HJ X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! HJ X -! HJ XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!X -!X Learn-on-the-fly (LOTF) hybrid molecular dynamics code -!X -!X When using this software, the following should be referenced: -!X -!X Gabor Csanyi, Tristan Albaret, Mike C. Payne and Alessandro De Vita -!X "Learn on the fly": a hybrid classical and quantum-mechanical -!X molecular dynamics simulation -!X Physical Review Letters 93 p. 175503 (2004) >>PDF [626 KB] -!X -!X Gabor Csanyi, T. Albaret, G. Moras, M. C. Payne, A. De Vita -!X Multiscale hybrid simulation methods for material systems -!X J. Phys. Cond. Mat. 17 R691-R703 Topical Review (2005) -!X -!X -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program bulktest - - use libAtoms_module - use LOTF_module - - implicit none - - ! Parameters for the program (we should probably put a nice command line argument - ! reader in System...) - - logical, parameter :: do_lots_of_little_clusters = .true. - integer, parameter :: n_pc_iter = 1 ! number of predictor/corrector iterations in each cycle - integer, parameter :: n_interp_steps = 10 ! number of steps to extrapolate/interpolate for - integer, parameter :: n_lotf_cycles = 100000 ! number of extrap/interp cycles to do - real(dp), parameter :: dt = 1.0_dp ! time step - real(dp), parameter :: init_temp = 300.0_dp - integer, pointer ::qm(:) - - !local variables - type(DynamicalSystem)::ds, ds_saved - type(Atoms)::at, dia - type(inoutput)::movie, datafile - type(table)::embedlist, fitlist, fitforce - real(dp), allocatable::f0(:,:), f1(:,:), f(:,:), df(:,:), f_hyb(:,:), data(:,:) - integer::i, j, n - character(5)::prefix - - ! initialise program - call system_initialise(PRINT_NORMAL,1) - call initialise(movie, "movie.xyz") - !call initialise(datafile, 'forcediff.dat') - - ! create some atoms - call diamond(dia, 5.44_dp) - call supercell(at, dia, 5,5,5) - at%Z = 14 - call set_cutoff(at, 4.0_dp) - call randomise(at%pos, 0.01_dp) - call calc_connect(at) - - - ! allocate some force arrays - allocate( f0(3,at%N), f1(3,at%N), f(3,at%N), f_hyb(3,at%N) ) - - ! initialise dynamics - call ds_initialise(ds, at) - call rescale_velo(ds, init_temp) - call zero_momentum(ds) - - !allocate space for the test data array - allocate(data(3,n_interp_steps+1)) - - - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! X - ! X bootstrap the adjustable potential - ! X - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! create list of embedded atoms - call append(embedlist, (/1,0,0,0/)) - call BFS_grow(ds%atoms, embedlist, 2) - - call Add_Property(ds%atoms, 'QM', 0) - if (.not. assign_pointer(ds%atoms, 'QM', qm)) & - call system_abort('error assigning pointer to QM property') - qm(int_part(embedlist,1)) = 1 - - ! compute default forces - ! with no embedded atoms - call hybrid_force(ds%atoms, f0, classical_force=SW_Force_noopt) - - ! compute hybrid forces - call hybrid_force(ds%atoms, f1, embedlist, qm_force=SWeps_force, & - classical_force=SW_force_noopt, buf_grow_hops=3, & - little_clusters=.true.,terminate=.true., & - periodic_clusters=(/.false.,.false.,.false./), randomise_buffer=.true.) - - - ! grow the embed list to include a fit zone - fitlist = embedlist - call BFS_grow(ds%atoms, fitlist, 3) - - ! copy force differences for the embedding zone... - call reallocate(df, 3, fitlist%N, zero=.true.) - df(:,1:embedlist%N) = f1(:,int_part(embedlist,1))-f0(:,int_part(embedlist,1)) - call wipe(fitforce) - call append(fitforce, int_part(fitlist), df) - - call adjustable_potential_init(ds%atoms, fitlist, embedlist%N) - call adjustable_potential_optimise(ds%atoms, real_part(fitforce)) - - call wipe(fitlist) - call wipe(fitforce) - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! X - ! X main LOTF loop - ! X - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - ! Operation parameters saved parameters - ! - ! P1 P0 - ! set up new structure for parameters - ! P1 P1 - ! Extrapolate using P1 - ! P1 P1 - ! Optimise parameters, get P2 - ! P2 P1 - ! Interpolate - ! P2 P1 - ! calcConnect - ! P2 P1 - - do n=1,n_lotf_cycles - - call Print('') - call print('==================== Quantum Selection ====================') - call Print('') - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! X - ! X Code could go here to set up new embedlist - ! X - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - write(line,'(i0,a)') embedlist%N,' atoms flagged for quantum treatment' - call Print(line) - - call Print('Building fit zone...') - fitlist = embedlist - call BFS_grow(ds%atoms, fitlist, 3) - - write(line,'(a,i0,a)') 'Fitting on ',fitlist%N,' atoms in total' - call Print(line) - - call adjustable_potential_init(ds%atoms, fitlist, embedlist%N, map=.true.) - - call Print('') - call print('==================== Extrapolation ====================') - call Print('') - - - - !only reallocate df if needed - call reallocate(df,3,fitlist%N) - - ds_saved = ds - - do i = 1, n_interp_steps - - ! get force from optimised adjustable potential - call adjustable_potential_force(ds%atoms, df) - - ! add it onto default forces - call hybrid_force(ds%atoms, f, classical_force=SW_Force_noopt) - f(:,int_part(fitlist,1)) = f(:,int_part(fitlist,1)) + df - - ! ********** TESTING *********** - ! Get the 'actual' force - !call hybrid_force(ds%atoms, f_hyb, embedlist, SW_Force_noopt, SWeps_force,do_lots_of_little_clusters) - !data(1,i) = ds%t ! time - !data(2,i) = RMS_diff(f_hyb,f,fitlist) ! RMS force differences - ! ****************************** - - ! advance the dynamics - call advance_verlet(ds, dt, f) - call ds_print_status(ds, 'E') - - end do - - - do j = 1, n_pc_iter - call Print('') - call print('==================== Computation of forces ====================') - call Print('') - - call Print('Computing new forces') - !compute default force - call hybrid_force(ds%atoms, f0, classical_force=SW_Force_noopt) - ! compute hybrid forces - call hybrid_force(ds%atoms, f1, embedlist, qm_force=SWeps_force, & - classical_force=SW_force_noopt, buf_grow_hops=3, & - little_clusters=.true.,terminate=.true., & - periodic_clusters=(/.false., .false.,.false./),randomise_buffer=.true.) - - call Print('') - call print('==================== Optimisation of parameters ====================') - call Print('') - - ! copy new force differences for the same embedding zone as before... - df = 0.0_dp - df(:,1:embedlist%N) = f1(:,int_part(embedlist,1))-f0(:,int_part(embedlist,1)) - call wipe(fitforce) - call append(fitforce, int_part(fitlist), df) - - ! now optimise the parameters for these forces at the new positions - call adjustable_potential_optimise(ds%atoms, real_part(fitforce)) - - ! ********** TESTING *********** - !call adjustable_potential_force(ds%atoms, df) - !f = f0; - !f(:,int_part(fitlist,1)) = f(:,int_part(fitlist,1)) + df - !data(1,i) = ds%t ! time - !data(2,i) = RMS_diff(f1,f,fitlist) ! RMS force differences - !data(3,i) = RMS_diff(real_part(fitforce), df) - ! ****************************** - - - call Print('') - call print('==================== Interpolation ====================') - call Print('') - - ! revert to the saved dynamical system - ds = ds_saved - - do i = 1, n_interp_steps - - ! get force differences from interpolated parameters - call adjustable_potential_force(ds%atoms, df, interp=real(i-1,dp)/real(n_interp_steps,dp)) - !call adjustable_potential_force(ds%atoms, df, interp_space=.true.) - - ! add it onto default forces - call hybrid_force(ds%atoms, f, classical_force=SW_Force_noopt) - f(:,int_part(fitlist,1)) = f(:,int_part(fitlist,1))+df - - !*********** TESTING ************* - !get the actual force - !call hybrid_force(ds%atoms, f_hyb, embedlist, SW_Force_noopt, SWeps_force,do_lots_of_little_clusters) - !data(3,i) = RMS_diff(f_hyb,f,fitlist) - !********************************* - - ! advance the dynamics - call advance_verlet(ds, dt, f) - write(prefix, '(a1,i1)') 'I', j - call ds_print_status(ds, prefix) - - end do - end do - - !Write the data to the data file - !do i = 1, n_interp_steps+1 - ! write(line,'(3(f0.18,tr2))') data(:,i) - ! call Print(datafile,line) - !end do - - call Print('') - call print('==================== Recalculate Connectivity ====================') - call Print('') - - ! print movie and recompute connectivity - call calc_connect(ds%atoms) - call print_xyz(ds%atoms, movie, properties='pos:QM:avg_ke') - - end do - - - call adjustable_potential_finalise - call Atoms_Finalise(at) - call Atoms_Finalise(dia) - call DS_Finalise(ds) - call DS_Finalise(ds_saved) - call finalise(movie) - call finalise(embedlist) - call finalise(fitlist) - call finalise(fitforce) - deallocate(f0,f1,f,f_hyb,df) - - call system_finalise() - -end program bulktest diff --git a/src/Programs/calc_n_poles.f95 b/src/Programs/calc_n_poles.f95 deleted file mode 100644 index c8ede4ecd6..0000000000 --- a/src/Programs/calc_n_poles.f95 +++ /dev/null @@ -1,59 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program est_n_poles -use libatoms_module -use approxfermi_module -implicit none - - type(ApproxFermi) :: af - character(len=1024) :: arg - real(dp) :: fermi_T, band_width - - call system_initialise() - - if (cmd_arg_count() /= 2) then - call system_abort("Usage: est_n_poles fermi_T band_width") - endif - - call get_cmd_arg(1, arg) - fermi_T = string_to_real(arg) - call get_cmd_arg(2, arg) - band_width = string_to_real(arg) - - call Initialise(af, 0.0_dp, fermi_T, band_width) - - call verbosity_push(PRINT_VERBOSE) - call print(af) - call verbosity_pop() - - call system_finalise() - -end program diff --git a/src/Programs/callback_test.f95 b/src/Programs/callback_test.f95 deleted file mode 100644 index daee29894b..0000000000 --- a/src/Programs/callback_test.f95 +++ /dev/null @@ -1,125 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -! Demonstration of the use of CallbackPot Potential type. - -! my_callback() is an example callback routine which calculates -! energies, forces and virial given an atoms object. After the -! potential has been constructed with args_str "CallbackPot" and then -! callback routine has been assigned with set_callback(), it can be -! used like any other Potential object. - -! James Kermode -! 12 April 2010. - -module callback_module - - use libAtoms_module - use Potential_module - implicit None - -contains - - subroutine my_callback(at) - type(Atoms), intent(inout) :: at - - logical :: calc_energy, calc_local_e, calc_force, calc_virial, dummy - real(dp), pointer, dimension(:,:) :: force - real(dp) :: virial(3,3) - - calc_energy = .false. - calc_local_e = .false. - calc_force = .false. - calc_virial = .false. - dummy = get_value(at%params, 'calc_energy', calc_energy) - dummy = get_value(at%params, 'calc_local_e', calc_local_e) - dummy = get_value(at%params, 'calc_force', calc_force) - dummy = get_value(at%params, 'calc_virial', calc_virial) - - if (calc_energy) then - call set_value(at%params, 'energy', 1.0_dp) - end if - - if (calc_force) then - call add_property(at, 'force', 0.0_dp, n_cols=3) - dummy = assign_pointer(at, 'force', force) - force = 1.0_dp - end if - - if (calc_virial) then - virial = 1.0_dp - call set_value(at%params, 'virial', virial) - end if - - end subroutine my_callback - -end module callback_module - -program callback_test - - use libAtoms_module - use Potential_module - use callback_module - - implicit none - - type(Atoms) :: at - type(Potential) :: pot - real(dp) :: energy, virial(3,3) - real(dp), allocatable, dimension(:,:) :: force - real(dp), pointer, dimension(:,:) :: force_ptr - logical :: dummy - - call system_initialise - - call diamond(at, 5.44_dp, (/14/)) - call calc_connect(at) - call initialise(pot, 'CallbackPot') - call set_callback(pot, my_callback) - - call calc(pot, at, e=energy) - call print('energy = '//energy) - - allocate(force(3,at%N)) - call calc(pot, at, f=force) - call print('force =') - call print(force) - deallocate(force) - - call calc(pot, at, args_str="calc_force=T calc_virial=T") - dummy = assign_pointer(at, 'force', force_ptr) - call print('virial=') - call print(virial) - call print('force_ptr=') - call print(force_ptr) - - call system_finalise - -end program callback_test diff --git a/src/Programs/crack.f95 b/src/Programs/crack.f95 deleted file mode 100644 index 472b704d28..0000000000 --- a/src/Programs/crack.f95 +++ /dev/null @@ -1,1532 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program crack - - - !% The 'crack' program can either load a crack configuration that has - !% previosuly been created with 'makecrack' or continue a previous - !% simulation, either from an XYZ file or from a binary checkpoint file. - !% - !% There are several distinct modes of operation for the crack code, - !% corresponding to different simulation tasks, as listed in the table - !% below. Each of these is described below. - !% - !% =================== ================================ - !% 'simulation_task' Description - !% =================== ================================ - !% 'md' Molecular dynamics - !% 'minim' Hybrid structural relaxation - !% 'force_integraion' Hybrid force integration - !% 'quasi_static' Quasi-static loading - !% =================== ================================ - !% - !% Molecular Dynamics - !% - !% We start with a relaxed configuration at a load $G$ below the critical - !% Griffith load $G_c$. - !% Depending on the range of lattice trapping, it should be possible to - !% find a load that satisfies $G_{-} < G < G_c$ so the relaxed crack is - !% lattice trapped and will not move until the load is increased above - !% $G_+$. - !% - !% Molecular dynamics is then carried out at a temperature of 300~K, with - !% a weak Langevin thermostat to correct for the energy drift caused by - !% the time dependence of the LOTF Hamiltonian. - !% The dynamics can be accelerated using the predictor-corrector scheme. - !% This is specified using the 'md_time_step' and 'md_extrapolate_steps' - !% parameters; if the latter is set to one then no extrapolation is carried - !% out. - !% As an example, extrapolation for 10 steps of $\Delta t=1$~fs is possible for - !% silicon crack systems. - !% - !% .. figure:: flow-chart - !% - !% Flow chart illustrating molecular dynamics methodology used - !% for the fracture simulations. See text for a description of - !% each state and the conditions that have to met for - !% transitions to take place. - !% - !% Unfortunately it is not possible to run dynamics for long enough to - !% fully explore the environment at each load and to cross barriers which - !% the real system would have sufficient thermal energy to pass over at - !% 300~K. - !% % - !% Instead we allow the dynamics to proceed for some fixed amount of time - !% 'md_wait_time', and then periodically check for rebonding near the - !% crack tip using the time-averaged coordinates with an averaging time of - !% 'md_avg_time'. - !% - !% Fig.~\ref{fig:flow-chart} schematically illustrates the details of the - !% molecular dynamics methodology used for the fracture simulations. - !% If no rebonding occurs for some time then we increase the load. - !% After each loading increment there is a thermalisation period in which - !% a stronger thermostat is used to dissipate the energy produced by the - !% rescaling. - !% The thermalisation continues until the fluctuations in temperature - !% are small, defined by the inequality - !% - !% .. math:: - !% - !% \frac{T - \left}{T} < \frac{1}{\sqrt{N}} - !% - !% where $T$ and $\left$ are the instantaneous and average - !% temperatures and $N$ is the total number of atoms in the simulation. - !% Once this condition is satisfied the thermostat is turned down and we - !% return to almost microcanonical molecular dynamics. - !% After the crack has started to move, the rebonding is automatically - !% detected and the load is not increased further. - !% - !% Molecular Dynamics -- smooth loading - !% - !% There is now an alternative way to smoothly increase the load during - !% an MD simulation. To use this method set the 'md_smooth_loading_rate' - !% parameter to a non-zero value. This parameter causes the load to be - !% increased smoothly by an amount 'md_smooth_loading_rate*md_time_step' - !% after each Verlet integration step. Once the crack starts to move - !% (defined by the tip position changing by more than 'md_smooth_loading_tip_move_tol' - !% from the original position), then loading will stop. If the crack arrests - !% (defined by a movement of less than 'md_smooth_loading_tip_move_tol' in - !% a time 'md_smooth_loading_arrest_time' then loading will recommence. - !% - !% At the moment loading always uses the same 'load' field, but it is - !% planned to allow the loading field to be recomputed from time to time - !% if the crack moves and subsequently arrests. - !% - !% \subsection{QM Selection Algorithm} - !% - !% A major advantage of LOTF is that it allows us to keep the QM region - !% small. - !% This requires a robust selection algorithm to follow the crack tip as - !% it moves and identify the atoms that need to be treated with quantum - !% mechanical accuracy. - !% This is a difficultproblem since the timescales of thermal vibration - !% and crack motion are not well separated. - !% The hysteretic selection algorithm described in Section 4.6 of my thesis - !% \footnote{Available at 'http://www.srcf.ucam.org/\~jrk33/Publications'}. - !% provides an effective solution to this problem. - !% - !% We identify atoms as active when they change their bonding topology, - !% and then construct embedding ellipses around each active atom. - !% The set of active atoms is seeded with a few atoms near to the crack - !% tip at the start of the simulation. - !% Ellipses are used rather than spheres to allow the embedding region to be biased - !% forwards so that the QM region always extends ahead of the crack tip. - !% Fig.~\ref{fig:qm-selection-crack} illustrates how the algorithm works - !% in a simple case with only two active atoms --- in reality there could - !% be several hundred. - !% Ellipses with different radii are used to define inner and outer - !% selection regions, and then the hysteretic algorithm ensures that - !% atoms near the edges of the QM region do not oscillate in and out of - !% the active region. - !% - !% \begin{figure} - !% \centering - !% \includegraphics[width=120mm]{qm-selection-crack} - !% \caption[Hysteretic QM selection algorithm for crack tip]{ - !% \label{fig:qm-selection-crack} Hysteretic QM selection algorithm - !% applied to crack tip region. The red and blue atoms are considered - !% `active', and are used to define inner (left panel) and outer - !% (right panel) selection regions. The atom indicated with the black - !% arrow remains selected despite oscillating in and out of the inner - !% region providing that it stays inside the outer region. } - !% - !% \end{figure} - !% - !% As the crack moves on, we can stop treating atoms behind the crack tip - !% quantum mechanically. - !% We cap the size of the QM region at 'selection_max_qm_atoms' - !% based on our computational capability --- this can be several hundred - !% atoms for a tight binding simulation, or of the order of a hundred for - !% an \emph{ab initio} simulation. - !% By keeping track of the order in which atoms became active, we can - !% remove them from the QM region in a consistent fashion. - !% An additional condition prevents atoms further than a threshold - !% distance 'selection_cutoff_plane' away from the centre of mass of the - !% current QM region from becoming active. - !% - !% \subsection{Hybrid Structural Relaxation} - !% - !% Classical geometry optimisation can be performed rapidly using the - !% conjugate gradients algorithm, and this provides a good first - !% approximation to the hybrid relaxed geometry, which in turn - !% approximates the atomic configuration that would be found by a fully - !% quantum mechanical optimisation of the entire system. - !% Relaxation using the hybrid forces is slightly more involved. - !% Whenever forces are needed, a QM calculation is performed and the - !% adjustable potential parameters are optimised to reproduce the QM - !% forces. - !% The forces used for the geometry optimisation are the sum of the - !% classical and adjustable potential forces: as for MD, this ensures - !% that there is no mechanical incompatibility at the boundary between - !% classical and quantum regions. - !% - !% The standard formulation of the conjugate gradients algorithm requires - !% both an objective function and its derivative. - !% For geometry optimisation, the former is the total energy. - !% In the LOTF hybrid scheme, there is no well defined total energy, so - !% this approach is not possible. - !% It is possible to modify the line minimisation step of the - !% conjugate gradient algorithm to work with derivative information only. - !% This is done by extrapolating the projection of the derivative along - !% the search direction to zero. This is invoked by setting 'minim_linmin_routine' - !% to 'LINMIN_DERIV'. - !% To avoid errors associated with large extrapolation lengths, a maximum - !% step size is specified and then the procedure is iterated until the - !% projected derivative is zero. - !% - !% \subsection{Quasi-static loading} - !% - !% As well as MD, the 'crack' code can perform quasi-static - !% simulations where the system is fully relaxed after each increment of - !% load. - !% This approach can be used to estimate the fracture toughness $G\_+$, - !% the load at which the lattice trapping barrier first falls to zero. - !% For this purpose, we consider fracture to have occured when the - !% crack tip moves more than 'quasi_static_tip_move_tol' from its - !% original position. - !% - !% \subsection{Hybrid Force Integration} - !% - !% Within the LOTF scheme, there is not a meaningful total energy for the - !% hybrid classical/quantum system; the method matches forces between the - !% QM and classical regions, rather than energies, so the solution is to - !% use these accurate forces to evaluate the energy difference between - !% two configurations by force integration: - !% \begin{equation} \label{eq:force-integration} - !% \Delta E = \int_{\gamma} \mathbf{F}\left(\mathbf{R}\right)\cdot\mathrm{d}\mathbf{R} - !% \end{equation} - !% where $\mathbf{R}$ denotes all atomic positions and the integration - !% contour $\gamma$ can be any path between the two configurations of - !% interest. - !% The start and end configurations should be obtained by hybrid minimisation, - !% so that $\mathbf{F} = 0$ at both integration limits. - !% The ending configuation is taken from the file specified in the - !% 'force_integration_end_file' parameter. - !% - !% The simplest contour connecting the two minima is used: linear interpolation - !% between the relaxed unreconstructed state with atomic coordinates $\mathbf{R}_U$ and - !% the reconstructed state with coordinates $\mathbf{R}_R$. - !% The QM region is fixed during the integration process. - !% The forces $\mathbf{F}(\mathbf{R})$ are calculated in the standard - !% LOTF fashion: classical and quantum forces are evaluated for the two - !% regions, then the adjustable potential is optimised to reproduce the - !% quantum forces. - !% The forces used for the integration are the sum of the classical and - !% corrective forces to ensure that there is no mechanical mismatch at - !% the boundary. - !% The integration path is discretised into $N+1$ samples according to - !% \begin{eqnarray} - !% \Delta \mathbf{R} & = & \frac{1}{N}\left(\mathbf{R}_R - \mathbf{R}_U\right) - !% \\ \mathbf{F}_i & = & \mathbf{F}(\mathbf{R}_U + i\,\Delta \mathbf{R}), \;\; 0 \le i \le N - !% \end{eqnarray} - !% and then Eq.~\ref{eq:force-integration} can be evaluated using - !% Simpson's Rule: - !% \begin{eqnarray} - !% \Delta E & \approx & \frac{\Delta \mathbf{R}}{3} \cdot \left[ - !% \mathbf{F}_0 + - !% 2 \sum_{j=1}^{N/2-1} \mathbf{F}_{2j} + - !% 4 \sum_{j=1}^{N/2} \mathbf{F}_{2j-1} + - !% \mathbf{F}_N \right] - !% \end{eqnarray} - !% The step-size $\Delta \mathbf{R}$ required for accurate integration of - !% the energy difference can be calibrated using force integration with the - !% classical potential alone, where the energy difference can be - !% calculated exactly --- typically $N=20$ gives good results. - !% The method has been validated by confirming that perturbing the integration - !% path does not affect the value of $\Delta E$ obtained. - !% $N$ is specified using the 'force_integration_n_steps' parameter. - - - use libAtoms_module - use Potential_module - - ! Crack includes - use CrackTools_module - use CrackParams_module -#ifdef HAVE_CP2K - use cp2k_driver_module -#endif - - implicit none - - ! Constantsmic - integer, parameter :: STATE_THERMALISE = 1 - integer, parameter :: STATE_MD = 2 - integer, parameter :: STATE_MD_LOADING = 3 - integer, parameter :: STATE_MD_CRACKING = 4 - integer, parameter :: STATE_DAMPED_MD = 5 - integer, parameter :: STATE_MD_CONSTANT = 6 - character(len=14), dimension(6), parameter :: STATE_NAMES = & - (/"THERMALISE ", "MD ", "MD_LOADING ", "MD_CRACKING ", "DAMPED_MD ", "MD_CONSTANT "/) - - ! Objects - type(InOutput) :: xmlfile - type(CInOutput) :: movie, crackin, movie_backup - type(DynamicalSystem), target :: ds, ds_save - type(Atoms) :: crack_slab, fd_start, fd_end, bulk_cell - type(CrackParams) :: params - type(Potential) :: classicalpot, qmpot - type(Potential) :: hybrid_pot, forcemix_pot - type(Dictionary) :: pot_params - type(mpi_context) :: mpi_glob - type(Table) :: crack_tips, old_crack_tips - - ! Pointers into Atoms data table - real(dp), pointer, dimension(:,:) :: load, force - integer, pointer, dimension(:) :: move_mask, nn, changed_nn, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark - integer :: n_per_atom_tau - real(dp), pointer, dimension(:) :: per_atom_tau - real(dp), allocatable, dimension(:) :: per_atom_tau_a - - ! Big arrays - real(dp), allocatable, dimension(:,:) :: f_fm, dr - real(dp), pointer :: dr_prop(:,:) - - ! Scalars - integer :: movie_n, nargs, i, j, state, steps, iunit, k, md_stanza_idx, random_seed, i_thermostat - logical :: mismatch, movie_exist, periodic_clusters(3), dummy, texist - real(dp) :: fd_e0, f_dr, integral, energy, last_state_change_time, last_print_time, & - last_checkpoint_time, last_calc_connect_time, & - last_md_interval_time, time, temp, crack_pos(2), orig_crack_pos, & - G, last_update_selection_time, last_stanza_change_time, last_update_crack_tip_time - character(STRING_LENGTH) :: stem, movie_name, xmlfilename, suffix, checkfile_name - character(STRING_LENGTH) :: state_string, qm_args_str, mm_args_str, extra_qm_args, extra_mm_args, extra_args - - real(dp) :: time_elapsed, total_time_elapsed - - integer :: CRACK_TIP_CURVATURE_FUNC, CRACK_TIP_POSITION_FUNC, CRACK_TIP_GRADIENT_FUNC - logical, pointer :: constraint_mask(:) - integer, allocatable :: constraint_list(:) - - logical :: do_parallel_verlet = .true. ! FIXME get this working - - !** Initialisation Code ** - - nargs = cmd_arg_count() - - call initialise(mpi_glob) - - if (mpi_glob%active) then - ! Same random seed for each process, otherwise velocites will differ - call system_initialise (common_seed=.true., mpi_all_inoutput=.false.) - call print('MPI run with '//mpi_glob%n_procs//' processes') - else - call system_initialise() - call print('Serial run') - end if - - call system_timer('initialisation') - call initialise(params) - - if (.not. mpi_glob%active) then - ! Print usage information if no arguments given - if (nargs /= 1) then - call print('Usage: crack ') - call print('') - call print('Where stem.xyz and stem.xml are the crack slab XYZ file') - call print('and parameter file respectively') - call print('') - call print('Available parameters and their default values are:') - call print('') - call print(params) - - call system_finalise - stop - end if - end if - - ! 1st argument contains stem for input xyz or binary checkfile and parameter files - if (.not. mpi_glob%active) then - call get_cmd_arg(1, stem) - else - stem = 'crack' ! Some MPIs can't handle command line arguments - end if - - xmlfilename = trim(stem)//'.xml' - - call print_title('Initialisation') - call print('Reading parameters from file '//trim(xmlfilename)) - call initialise(xmlfile,xmlfilename,INPUT) - call read_xml(params,xmlfile) - call verbosity_push(params%io_verbosity) ! Set base verbosity - call print(params) - - if (params%io_mpi_print_all) then - mainlog%mpi_all_inoutput_flag = .true. - mainlog%mpi_print_id = .true. - end if - - if (params%io_timing) call enable_timing() - - call Print('Reading bulk cell from file '//trim(stem)//'_bulk.xyz') - call read(bulk_cell, trim(stem)//'_bulk.xyz', mpi=mpi_glob) - - call print ("Initialising classical potential with args " // trim(params%classical_args) & - // " from file " // trim(xmlfilename)) - call rewind(xmlfile) - call initialise(classicalpot, params%classical_args, xmlfile, mpi_obj=mpi_glob, bulk_scale=bulk_cell) - call Print(classicalpot) - - if (.not. params%simulation_classical) then - call print ("Initialising QM potential with args " // trim(params%qm_args) & - // " from file " // trim(xmlfilename)) - call rewind(xmlfile) - call initialise(qmpot, trim(params%qm_args)//' little_clusters='//params%qm_little_clusters, & - xmlfile, mpi_obj=mpi_glob, bulk_scale=bulk_cell) - call finalise(xmlfile) - call Print(qmpot) - end if - - periodic_clusters = (/ .false., .false., params%qm_force_periodic /) - - mm_args_str = params%classical_args_str - extra_mm_args = '' - qm_args_str = '' - extra_qm_args = '' - extra_args = '' - if (.not. params%simulation_classical) then - - call initialise(pot_params) - call set_value(pot_params, 'method', trim(params%fit_method)) - call set_value(pot_params, 'buffer_hops', params%qm_buffer_hops) - call set_value(pot_params, 'transition_hops', params%qm_transition_hops) - call set_value(pot_params, 'fit_hops', params%fit_hops) - call set_value(pot_params, 'minimise_mm', params%minim_minimise_mm) - call set_value(pot_params, 'randomise_buffer', params%qm_randomise_buffer) - call set_value(pot_params, 'mm_reweight', params%classical_force_reweight) - call set_value(pot_params, 'minim_mm_method', trim(params%minim_mm_method)) - call set_value(pot_params, 'minim_mm_tol', params%minim_mm_tol) - call set_value(pot_params, 'minim_mm_eps_guess', params%minim_mm_eps_guess) - call set_value(pot_params, 'minim_mm_max_steps', params%minim_mm_max_steps) - call set_value(pot_params, 'minim_mm_linminroutine', trim(params%minim_mm_linminroutine)) - call set_value(pot_params, 'minim_mm_args_str', trim(params%minim_mm_args_str) ) - call set_value(pot_params, 'lotf_spring_hops', params%fit_spring_hops) - call set_value(pot_params, 'do_rescale_r', params%qm_rescale_r) - call set_value(pot_params, 'minimise_bulk', params%qm_rescale_r) - call set_value(pot_params, 'min_images_only', periodic_clusters(3)) - call set_value(pot_params, 'hysteretic_buffer', params%qm_hysteretic_buffer) - call set_value(pot_params, 'hysteretic_buffer_inner_radius', params%qm_hysteretic_buffer_inner_radius) - call set_value(pot_params, 'hysteretic_buffer_outer_radius', params%qm_hysteretic_buffer_outer_radius) - call set_value(pot_params, 'hysteretic_buffer_nneighb_only', params%qm_hysteretic_buffer_nneighb_only) - - call set_value(pot_params, 'hysteretic_connect', params%qm_hysteretic_connect) - call set_value(pot_params, 'nneighb_only', (.not. params%qm_hysteretic_connect)) - call set_value(pot_params, 'hysteretic_connect_cluster_radius', params%qm_hysteretic_connect_cluster_radius) - call set_value(pot_params, 'hysteretic_connect_inner_factor', params%qm_hysteretic_connect_inner_factor) - call set_value(pot_params, 'hysteretic_connect_outer_factor', params%qm_hysteretic_connect_outer_factor) - - call initialise(hybrid_pot, 'ForceMixing '//write_string(pot_params), & - pot1=classicalpot, pot2=qmpot, bulk_scale=bulk_cell, mpi_obj=mpi_glob) - - call print_title('Hybrid Potential') - call print(hybrid_pot) - - ! calc_args - qm_args_str=' little_clusters='//(params%qm_clusters .and. params%qm_little_clusters)// & - ' single_cluster='//(params%qm_clusters .and. .not. params%qm_little_clusters)// & - ' terminate='//params%qm_terminate// & - ' even_electrons='//params%qm_even_electrons// & - ' cluster_vacuum='//params%qm_vacuum_size// & - ' cluster_periodic_x=F cluster_periodic_y=F cluster_periodic_z='//periodic_clusters(3)// & - ' cluster_calc_connect='//(cutoff(qmpot) /= 0.0_dp)// & - ' buffer_hops='//params%qm_buffer_hops//& - ' transition_hops='//params%qm_transition_hops//& - ' randomise_buffer='//params%qm_randomise_buffer//& - ' hysteretic_connect='//params%qm_hysteretic_connect//& - ' nneighb_only='//(.not. params%qm_hysteretic_connect)//& - ' cluster_hopping_nneighb_only='//(.not. params%qm_hysteretic_connect)//& - ' '//trim(params%qm_args_str) - extra_qm_args = '' - extra_args = params%qm_extra_args_str - - if (params%qm_calc_force_error) then - call set_value(pot_params, 'method', 'force_mixing') - if (params%qm_rescale_r) then - call initialise(forcemix_pot, 'ForceMixing '//write_string(pot_params), & - pot1=classicalpot, pot2=qmpot, bulk_scale=bulk_cell, mpi_obj=mpi_glob) - else - call initialise(forcemix_pot, 'ForceMixing '//write_string(pot_params), & - pot1=classicalpot, pot2=qmpot, mpi_obj=mpi_glob) - end if - call finalise(pot_params) - end if - end if - call print('mm_args_str = '//trim(mm_args_str)) - call print('qm_args_str = '//trim(qm_args_str)) - call print('extra_qm_args = '//trim(extra_qm_args)) - call print('extra_mm_args = '//trim(extra_mm_args)) - call print('extra_args = '//trim(extra_args)) - - call finalise(bulk_cell) - - ! Look for input file. Check for the following, in order - ! _check.nc - ! _check.xyz - ! .nc - ! .xyz - - texist=.false. - if (params%io_netcdf) then - inquire(file=trim(stem)//'_check.nc', exist=texist) - if (texist) then - call print('Reading atoms from input file '//trim(stem)//'_check.nc') - call initialise(crackin, trim(stem)//'_check.nc', action=INPUT, mpi=mpi_glob) - call read(crackin, crack_slab) - call finalise(crackin) - endif - end if - - if (.not. texist) then - inquire(file=trim(stem)//'_check.xyz', exist=texist) - if (texist) then - call print('Reading atoms from input file '//trim(stem)//'_check.xyz') - call initialise(crackin, trim(stem)//'_check.xyz', action=INPUT, mpi=mpi_glob) - call read(crackin, crack_slab) - call finalise(crackin) - endif - end if - - if (params%io_netcdf .and. .not. texist) then - inquire(file=trim(stem)//'.nc', exist=texist) - if (texist) then - call print('Reading atoms from input file '//trim(stem)//'.nc') - call initialise(crackin, trim(stem)//'.nc', action=INPUT, mpi=mpi_glob) - call read(crackin, crack_slab) - call finalise(crackin) - endif - end if - - if (.not. texist) then - inquire(file=trim(stem)//'.xyz', exist=texist) - if (texist) then - call print('Reading atoms from input file '//trim(stem)//'.xyz') - call initialise(crackin, trim(stem)//'.xyz', action=INPUT, mpi=mpi_glob) - call read(crackin, crack_slab) - call finalise(crackin) - endif - end if - - if (.not. texist) call system_abort('No input file found - checked for _check.nc, _check.xyz, .nc and .xyz with stem="'//trim(stem)//'"') - - call initialise(ds, crack_slab, constraints=count((/params%constraint_fix_bond, & - params%constraint_fix_position, params%constraint_fix_gradient, params%constraint_fix_curvature /))) - if (any(params%md(1:params%num_md_stanza)%extrapolate_steps /= 1)) & - call initialise(ds_save, crack_slab, constraints=count((/params%constraint_fix_bond, & - params%constraint_fix_position,params%constraint_fix_gradient,params%constraint_fix_curvature /))) - call finalise(crack_slab) - - call print('Initialised dynamical system with '//ds%N//' atoms') - - - call crack_fix_pointers(ds%atoms, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - ! Set number of degrees of freedom correctly - ds%Ndof = 3*count(ds%atoms%move_mask == 1) - - ! Reseed random number generator if necessary - if (get_value(ds%atoms%params, 'random_seed', random_seed)) then - call system_reseed_rng(random_seed) - else if (params%simulation_seed /= 0) then - call system_reseed_rng(params%simulation_seed) - end if - - ! add constraints - if (params%constraint_fix_bond) then - call print("Constraining bond "//params%constraint_bond_i//"--"//params%constraint_bond_j//" to length "//params%constraint_bond_length) - call constrain_bondlength(ds, params%constraint_bond_i, params%constraint_bond_j, params%constraint_bond_length) - end if - - if (params%constraint_fix_position .or. params%constraint_fix_gradient .or. params%constraint_fix_curvature) then - CRACK_TIP_CURVATURE_FUNC = register_constraint(CRACK_TIP_CURVATURE) - CRACK_TIP_POSITION_FUNC = register_constraint(CRACK_TIP_POSITION) - CRACK_TIP_GRADIENT_FUNC = register_constraint(CRACK_TIP_GRADIENT) - call assign_property_pointer(ds%atoms, "constraint_mask", constraint_mask) - allocate(constraint_list(count(constraint_mask))) - j = 1 - do i=1,ds%atoms%n - if (.not. constraint_mask(i)) cycle - constraint_list(j) = i - j = j + 1 - end do - - if (params%constraint_fix_curvature) then - call print("Constraining "//count(constraint_mask)//" tip atoms to fix curvature "//params%constraint_curvature) - call ds_add_constraint(ds, constraint_list, CRACK_TIP_CURVATURE_FUNC, (/params%constraint_curvature/)) - end if - - if (params%constraint_fix_gradient) then - call print("Constraining "//count(constraint_mask)//" tip atoms to fix gradient "//params%constraint_gradient) - call ds_add_constraint(ds, constraint_list, CRACK_TIP_GRADIENT_FUNC, (/params%constraint_gradient/)) - end if - - if (params%constraint_fix_position) then - call print("Constraining "//count(constraint_mask)//" tip atoms to fix position "//params%constraint_position) - call ds_add_constraint(ds, constraint_list, CRACK_TIP_POSITION_FUNC, (/params%constraint_position/)) - end if - deallocate(constraint_list) - end if - - -#ifndef HAVE_NETCDF4 - if (params%io_netcdf) & - call system_abort('io_netcdf = .true. but NetCDF support not compiled in') -#endif - - if (params%io_netcdf) then - suffix = '.nc' - else - suffix = '.xyz' - end if - - if (.not. mpi_glob%active .or. (mpi_glob%active .and.mpi_glob%my_proc == 0)) then - ! Avoid overwriting movie file from previous runs by suffixing a number - movie_n = 1 - movie_exist = .true. - do while (movie_exist) - write (movie_name, '(a,i0,a)') trim(stem)//'_movie_', movie_n, trim(suffix) - inquire (file=movie_name, exist=movie_exist) - movie_n = movie_n + 1 - end do - - call print('Setting up movie output file '//movie_name) - call initialise(movie, movie_name, action=OUTPUT) - if (params%io_backup) then - write (movie_name, '(a,i0,a)') trim(stem)//'_movie_backup_', movie_n, trim(suffix) - call initialise(movie_backup, movie_name, action=OUTPUT) - end if - endif - - call Print('Setting neighbour cutoff to '//(cutoff(classicalpot)+params%md(params%md_stanza)%crust)//' A.') - call set_cutoff(ds%atoms, cutoff(classicalpot)+params%md(params%md_stanza)%crust) - call print('Neighbour crust is '//params%md(params%md_stanza)%crust// ' A.') - - call calc_connect(ds%atoms, store_is_min_image=.true.) - - if (params%qm_calc_force_error) allocate(f_fm(3,ds%atoms%N)) - - ! Allocate various flags - - call Print('Setting nneightol to '//params%md(params%md_stanza)%nneigh_tol) - ds%atoms%nneightol = params%md(params%md_stanza)%nneigh_tol - - call crack_update_connect(ds%atoms, params) - ! Initialise QM region - if (.not. params%simulation_classical) then - if (trim(params%selection_method) /= 'static') then - call print('Initialising dynamic QM region') - - ! See if we read changed_nn from file - if (trim(params%selection_method) == 'coordination' .and. all(changed_nn == 0)) & - call system_abort('No seed atoms found - rerun makecrack') - call print('count(changed_nn /= 0) = '//count(changed_nn /= 0)) - call crack_update_selection(ds%atoms, params) - else - call print('Static QM region') - ! Load QM mask from file, then fix it for entire simulation - - call print('Loaded hybrid mask from XYZ file') -!!$ call crack_update_selection(ds%atoms, params, embedlist=embedlist, fitlist=fitlist, & -!!$ update_embed=.false., num_directionality=directionN) - end if - end if - - ! Print a frame before we start - if (.not. mpi_glob%active .or. (mpi_glob%active .and.mpi_glob%my_proc == 0)) then - call crack_print(ds%atoms, movie, params) - if (params%io_backup) & - call crack_print(ds%atoms, movie_backup, params) - end if - - if (.not. params%simulation_classical) then - if (count(hybrid == 1) == 0) call system_abort('Zero QM atoms selected') - end if - - call setup_parallel(classicalpot, ds%atoms, args_str=trim(params%classical_args_str)//" energy force") - - call crack_fix_pointers(ds%atoms, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - if (all(abs(load) < 1.0e-7_dp)) then - call print_title('Applying Initial Load') - call crack_calc_load_field(ds%atoms, params, classicalpot, params%crack_loading, & - .true., mpi_glob) - - call crack_fix_pointers(ds%atoms, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - end if - - if (params%simulation_force_initial_load_step) then - if (.not. has_property(ds%atoms, 'load')) & - call system_abort('simulation_force_initial_load_step is true but crack slab has no load field - set crack_apply_initial_load = T to regenerate load') - call print_title('Force_load_step is true, applying load') - call crack_apply_load_increment(ds%atoms, params%crack_G_increment) - end if - - call system_timer('initialisation', time_elapsed=time_elapsed) - total_time_elapsed = time_elapsed - - !** End of initialisation ** - - !**************************************************************** - !* * - !* MOLECULAR DYNAMICS * - !* * - !* * - !**************************************************************** - if (trim(params%simulation_task) == 'md' .or. trim(params%simulation_task) == 'damped_md') then - - md_stanza: do md_stanza_idx = 1, params%num_md_stanza - params%md_stanza = md_stanza_idx - - call system_timer('md_initialisation') - - call print_title('Molecular Dynamics (md_stanza='//params%md_stanza//')') - - if (.not. get_value(ds%atoms%params, 'Temp', temp)) temp = 2.0_dp*params%md(params%md_stanza)%sim_temp - - ! If velocities are zero, randomise them at correct temperature - if (maxval(abs(ds%atoms%velo)) < 1e-5_dp) then - call rescale_velo(ds, temp) - call zero_momentum(ds) - ds%cur_temp = temperature(ds, instantaneous=.true.) - ds%avg_temp = temperature(ds) - end if - - if (.not. get_value(ds%atoms%params, 'Time', time)) time = 0.0_dp - ds%t = time - - if (.not. get_value(ds%atoms%params, 'LastStateChangeTime', last_state_change_time)) & - last_state_change_time = ds%t - - if (.not. get_value(ds%atoms%params, 'LastMDIntervalTime', last_md_interval_time)) & - last_md_interval_time = ds%t - - if (.not. get_value(ds%atoms%params, 'LastPrintTime', last_print_time)) & - last_print_time = ds%t - - if (.not. get_value(ds%atoms%params, 'LastCheckpointTime', last_checkpoint_time)) & - last_checkpoint_time = ds%t - - if (.not. get_value(ds%atoms%params, 'LastCalcConnectTime', last_calc_connect_time)) & - last_calc_connect_time = ds%t - - last_stanza_change_time = ds%t - last_update_selection_time = ds%t - last_update_crack_tip_time = ds%t - - ! Special cases for first time - if (all(md_old_changed_nn == 0)) md_old_changed_nn = changed_nn - if (all(old_nn == 0)) old_nn = nn - - ds%avg_time = params%md(params%md_stanza)%avg_time - - state_string = '' - if (trim(params%simulation_task) == 'md') then - if (.not. get_value(ds%atoms%params, "State", state_string)) then - if (params%md(params%md_stanza)%smooth_loading_rate .fne. 0.0_dp) then - state_string = 'MD_LOADING' - else - state_string = 'THERMALISE' - end if - end if - else - state_string = 'DAMPED_MD' - end if - - ! Allow initial state to be overridden in XML file - if (trim(params%simulation_initial_state) /= '') state_string = params%simulation_initial_state - - if (trim(state_string) == "MD" .and. (params%md(params%md_stanza)%smooth_loading_rate .fne. 0.0_dp)) state_string = 'MD_LOADING' - - if (params%md(params%md_stanza)%ensemble /= 'NVE' .and. & - params%md(params%md_stanza)%ensemble /= 'NVT') then - call system_abort('MD ensemble must be either "NVT" or "NVE"') - end if - - - ! Remove any existing thermostats prior to re-adding them - call finalise(ds%thermostat) - - ! Special thermostat for damping - allocate(ds%thermostat(0:0)); call initialise(ds%thermostat(0),THERMOSTAT_NONE,0.0_dp) - ! set damp mask, just in case we'll be doing damping - ds%atoms%damp_mask = 1 - where (ds%atoms%move_mask == 0) - ds%atoms%damp_mask = 0 - end where - - ! if DAMPED_MD, override this below - call disable_damping(ds) - - select case(trim(state_string)) - case ('THERMALISE') - state = STATE_THERMALISE - - case ('MD') - state = STATE_MD - - case ('MD_LOADING') - state = STATE_MD_LOADING - call crack_find_tip(ds%atoms, params, old_crack_tips) - crack_tips = old_crack_tips - - case ('MD_CRACKING') - state = STATE_MD_CRACKING - call crack_find_tip(ds%atoms, params, old_crack_tips) - crack_tips = old_crack_tips - - case ('MD_CONSTANT') - state = STATE_MD_CONSTANT - - case ('DAMPED_MD') - state = STATE_DAMPED_MD - call enable_damping(ds, params%md(params%md_stanza)%damping_time) - - case default - call system_abort("Don't know how to resume in molecular dynamics state "//trim(state_string)) - - end select - - if (state /= STATE_DAMPED_MD) then - ! default thermostat - if (params%md(params%md_stanza)%ensemble == 'NVT') then - if (state == STATE_THERMALISE) then - call add_thermostat(ds, THERMOSTAT_LANGEVIN, T=params%md(params%md_stanza)%sim_temp, tau=params%md(params%md_stanza)%thermalise_tau,region_i=i_thermostat) - else - call add_thermostat(ds, THERMOSTAT_LANGEVIN, T=params%md(params%md_stanza)%sim_temp, tau=params%md(params%md_stanza)%tau,region_i=i_thermostat) - endif - ds%atoms%thermostat_region = i_thermostat - endif - ! per-atom thermostats - if (params%md(params%md_stanza)%per_atom_tau) then - call assign_property_pointer(ds%atoms, 'per_atom_tau', per_atom_tau) - n_per_atom_tau = count(per_atom_tau > 0.0_dp) - allocate(per_atom_tau_a(n_per_atom_tau)) - per_atom_tau_a = pack(per_atom_tau, per_atom_tau > 0.0_dp) - call add_thermostats(ds, THERMOSTAT_LANGEVIN, n=n_per_atom_tau, T=params%md(params%md_stanza)%sim_temp, tau_a=per_atom_tau_a, & - region_i=i_thermostat) - do i=1, ds%atoms%N - if (per_atom_tau(i) > 0.0_dp) then - ds%atoms%thermostat_region(i) = i_thermostat - i_thermostat = i_thermostat + 1 - endif - end do - endif ! per_atom_tau - endif ! state /= STATE_DAMPED_MD - ! never thermostat atoms with move_mask == 0 - where (ds%atoms%move_mask == 0) - ds%atoms%thermostat_region = 0 - end where - - call print('Thermostats') - call print(ds%thermostat) - - call print('Starting in state '//STATE_NAMES(state)) - - ! Bootstrap the adjustable potential if we're doing predictor/corrector dynamics - if (params%md(params%md_stanza)%extrapolate_steps /= 1 .and. .not. params%simulation_classical) then - if (trim(params%fit_method) /= 'lotf_adj_pot_svd' .and. trim(params%fit_method) /= 'lotf_adj_pot_minim') then - call system_abort('extrapolate_steps /= 1 and fit_method is not lotf_adj_pot_{svd, minim}') - end if - - if (params%qm_cp2k) then - extra_args = trim(params%qm_extra_args_str)//" run_suffix=_lotf" - extra_qm_args = "run_suffix=_lotf" - call add_property(ds%atoms, 'hybrid_lotf', hybrid, overwrite=.true.) - end if - call calc(hybrid_pot, ds%atoms, args_str="force=force "//& - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - end if - - call system_timer('md_initialisation', time_elapsed=time_elapsed) - total_time_elapsed = total_time_elapsed + time_elapsed - - !**************************************************************** - !* Main MD Loop * - !* * - !**************************************************************** - do - call system_timer('step') - call crack_fix_pointers(ds%atoms, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - - select case(state) - case(STATE_THERMALISE) - if (ds%t - last_state_change_time >= params%md(params%md_stanza)%thermalise_wait_time .and. & - abs(ds%avg_temp - temperature(ds))/temperature(ds) < params%md(params%md_stanza)%thermalise_wait_factor/sqrt(real(ds%atoms%N,dp))) then - ! Change to state MD - call print('STATE changing THERMALISE -> MD') - state = STATE_MD - last_state_change_time = ds%t - call disable_damping(ds) - call initialise(ds%thermostat(1), THERMOSTAT_LANGEVIN, params%md(params%md_stanza)%sim_temp, & - gamma=1.0_dp/params%md(params%md_stanza)%tau) - md_old_changed_nn = changed_nn - end if - - case(STATE_MD) - if ((ds%t - last_state_change_time >= params%md(params%md_stanza)%wait_time) .and. & - (ds%t - last_md_interval_time >= params%md(params%md_stanza)%interval_time)) then - - mismatch = .false. - do i = 1,ds%atoms%N - if ((changed_nn(i) == 0 .and. md_old_changed_nn(i) /= 0) .or. & - (changed_nn(i) /= 0 .and. md_old_changed_nn(i) == 0)) then - mismatch = .true. - exit - end if - end do - - if (.not. mismatch) then - ! changed_nn hasn't changed for a while so we can increase strain - ! Rescale and change to state THERMALISE - call print('STATE changing MD -> THERMALISE') - state = STATE_THERMALISE - last_state_change_time = ds%t - - call disable_damping(ds) - call initialise(ds%thermostat(1), THERMOSTAT_LANGEVIN, params%md(params%md_stanza)%sim_temp, & - gamma=1.0_dp/params%md(params%md_stanza)%thermalise_tau) - end if - - ! Apply loading field - if (has_property(ds%atoms, 'load')) then - call print_title('Applying load') - call crack_apply_load_increment(ds%atoms, params%crack_G_increment) - else - call print('No load field found - not increasing load.') - end if - - md_old_changed_nn = changed_nn - last_md_interval_time = ds%t - end if - - case(STATE_DAMPED_MD) - - case(STATE_MD_LOADING) - ! If tip has moved by more than smooth_loading_tip_move_tol then - ! turn off loading. - call crack_find_tip(ds%atoms, params, crack_tips) - if (crack_tips%N /= old_crack_tips%N) & - call system_abort('State MD_LOADING: number of crack tips changed from '//old_crack_tips%N//' to '//crack_tips%N) - - if (crack_tips%real(1,crack_tips%N) - old_crack_tips%real(1,crack_tips%N) > params%md(params%md_stanza)%smooth_loading_tip_move_tol) then - call print_title('Crack Moving') - call print('STATE changing MD_LOADING -> MD_CRACKING') - state = STATE_MD_CRACKING - last_state_change_time = ds%t - old_crack_tips = crack_tips - else - call print('STATE: crack is not moving (crack_pos='//crack_tips%real(1,crack_tips%N)//')') - - end if - - case(STATE_MD_CRACKING) - ! Monitor tip and if it doesn't move by more than smooth_loading_tip_move_tol in - ! time smooth_loading_arrest_time then switch back to loading - if (ds%t - last_state_change_time >= params%md(params%md_stanza)%smooth_loading_arrest_time) then - - call crack_find_tip(ds%atoms, params, crack_tips) - - if (crack_tips%N == 0) then - call print_title('Cracked Through') - exit - end if - - if (crack_tips%real(1,crack_tips%N) - old_crack_tips%real(1,crack_tips%N) < params%md(params%md_stanza)%smooth_loading_tip_move_tol) then - call print_title('Crack Arrested') - call crack_calc_load_field(ds%atoms, params, classicalpot, params%crack_loading, & - .false., mpi_glob) - call print('STATE changing MD_CRACKING -> MD_LOADING') - state = STATE_MD_LOADING - else - call print('STATE: crack is moving, crack_tips=') - call print(crack_tips) - end if - - last_state_change_time = ds%t - old_crack_tips = crack_tips - end if - - case(STATE_MD_CONSTANT) - - case default - call system_abort('Unknown molecular dynamics state!') - end select - - ! Are we doing predictor/corrector dynamics? - if (params%md(params%md_stanza)%extrapolate_steps /= 1) then - - !**************************************************************** - !* Quantum Selection * - !* * - !**************************************************************** - call system_timer('selection') - call print_title('Quantum Selection') - if (trim(params%selection_method) /= 'static') call crack_update_selection(ds%atoms, params) - call system_timer('selection') - - !**************************************************************** - !* Extrapolation * - !* * - !**************************************************************** - if (.not. params%simulation_classical) then - call print_title('Extrapolation') - call system_timer('extrapolation') - call ds_save_state(ds_save, ds) - else - call system_timer('md_time') - end if - - - if (params%qm_cp2k) then - extra_args = trim(params%qm_extra_args_str)//" run_suffix=_extrap" - extra_qm_args = "run_suffix=_extrap" -#ifdef HAVE_CP2K - call cp2k_state_change(ds%atoms, '_extrap', (/'_interp', '_lotf '/)) -#else - call system_abort('qm_cp2k=T but CP2K support not compiled in!') -#endif - call add_property(ds%atoms, 'hybrid_extrap', hybrid, overwrite=.true.) - end if - - do i = 1, params%md(params%md_stanza)%extrapolate_steps - - if (params%simulation_classical) then - call calc(classicalpot, ds%atoms, energy=energy, args_str='energy=energy force=force '//& - crack_mm_calc_args(mm_args_str, extra_mm_args, extra_args)) - else - if (i == 1) then - call calc(hybrid_pot, ds%atoms, args_str="force=force calc_weights=T lotf_do_qm=F lotf_do_init=T lotf_do_map=T "// & - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - else - call calc(hybrid_pot, ds%atoms, args_str="force=force calc_weights=F lotf_do_qm=F lotf_do_init=F "// & - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - end if - if (params%qm_calc_force_error) & - call calc(forcemix_pot, ds%atoms, force=f_fm, args_str= & - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - if (params%hack_qm_zero_z_force) then - ! Zero z forces in embed region - force(3,find(hybrid == 1)) = 0.0_dp - if (params%qm_calc_force_error) f_fm(3, find(hybrid == 1)) = 0.0_dp - end if - end if - - ! advance the dynamics - call system_timer('advance_verlet') - call advance_verlet(ds, params%md(params%md_stanza)%time_step, force, do_calc_dists=(state /= STATE_MD_LOADING), parallel=do_parallel_verlet) - call system_timer('advance_verlet') - if (params%simulation_classical) then - call ds_print_status(ds, 'E', epot=energy) - else - call ds_print_status(ds, 'E') - end if - if (params%qm_calc_force_error) call print('E err '//ds%t//' '// & - rms_diff(force(:, find(hybrid == 1)), f_fm(:, find(hybrid == 1)))//' '// & - maxval(abs(f_fm(:, find(hybrid == 1)) - force(:, find(hybrid == 1))))) - - if (state == STATE_MD_LOADING) then - ! increment the load - call system_timer('apply_load_increment') - if (has_property(ds%atoms, 'load')) then - call system_timer('load_increment') - call crack_apply_load_increment(ds%atoms, params%md(params%md_stanza)%smooth_loading_rate*params%md(params%md_stanza)%time_step) - call system_timer('load_increment') - if (.not. get_value(ds%atoms%params, 'G', G)) call system_abort('No G in ds%atoms%params') - else - call print('No load field found - not increasing load.') - end if - call system_timer('apply_load_increment') - end if - - end do - - if (.not. params%simulation_classical) then - call system_timer('extrapolation') - else - call system_timer('md_time') - endif - - if (.not. params%simulation_classical) then - - !**************************************************************** - !* QM Force Computation * - !* and optimisation of Adjustable Potential * - !* * - !**************************************************************** - - call print_title('Computation of forces') - call system_timer('force computation') - - if (params%qm_cp2k) then - extra_qm_args = "run_suffix=_lotf" - extra_args = trim(params%qm_extra_args_str)//" run_suffix=_lotf" - call add_property(ds%atoms, 'hybrid_lotf', hybrid, overwrite=.true.) - end if - - call calc(hybrid_pot, ds%atoms, args_str="force=force calc_weights=T lotf_do_qm=T lotf_do_init=F lotf_do_fit=T "//& - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - call system_timer('force computation') - - - !**************************************************************** - !* Interpolation * - !* * - !**************************************************************** - call print_title('Interpolation') - call system_timer('interpolation') - - ! revert to the saved positions etc. - call ds_restore_state(ds, ds_save) - call crack_fix_pointers(ds%atoms, nn, changed_nn, load, move_mask, edge_mask, load_mask, md_old_changed_nn, & - old_nn, hybrid, hybrid_mark, force) - - if (params%qm_cp2k) then - extra_qm_args = 'run_suffix=_interp' - extra_args = trim(params%qm_extra_args_str)//" run_suffix=_interp" - call add_property(ds%atoms, 'hybrid_interp', hybrid, overwrite=.true.) - end if - - do i = 1, params%md(params%md_stanza)%extrapolate_steps - - if (i == 1) then - call calc(hybrid_pot, ds%atoms, args_str="force=force calc_weights=T lotf_do_qm=F lotf_do_init=F lotf_do_interp=T lotf_interp="& - //(real(i-1,dp)/real(params%md(params%md_stanza)%extrapolate_steps,dp))//' '// & - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - else - call calc(hybrid_pot, ds%atoms, args_str="force=force calc_weights=F lotf_do_qm=F lotf_do_init=F lotf_do_interp=T lotf_interp="& - //(real(i-1,dp)/real(params%md(params%md_stanza)%extrapolate_steps,dp))//' '// & - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - end if - - if (params%qm_calc_force_error) then - call calc(forcemix_pot, ds%atoms, force=f_fm, args_str= & - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - end if - - if (params%hack_qm_zero_z_force) then - ! Zero z forces in embed region - force(3,find(hybrid == 1)) = 0.0_dp - if (params%qm_calc_force_error) f_fm(3, find(hybrid == 1)) = 0.0_dp - end if - - ! advance the dynamics - call advance_verlet(ds, params%md(params%md_stanza)%time_step, force, do_calc_dists=(state /= STATE_MD_LOADING), parallel=do_parallel_verlet) - call ds_print_status(ds, 'I') - if (params%qm_calc_force_error) call print('I err '//ds%t//' '// & - rms_diff(force(:, find(hybrid == 1)), f_fm(:, find(hybrid == 1)))//' '// & - maxval(abs(f_fm(:, find(hybrid == 1)) - force(:, find(hybrid == 1))))) - - if (trim(params%simulation_task) == 'damped_md') then - do j=1,ds%atoms%n - if (move_mask(j) == 0) force(:,j) = 0.0_dp - end do - call print('Damped MD: normsq(force) = '//normsq(reshape(force,(/3*ds%N/)))//& - ' max(abs(force)) = '//maxval(abs(force))) - end if - - if (state == STATE_MD_LOADING) then - ! increment the load - if (has_property(ds%atoms, 'load')) then - call crack_apply_load_increment(ds%atoms, params%md(params%md_stanza)%smooth_loading_rate*params%md(params%md_stanza)%time_step) - if (.not. get_value(ds%atoms%params, 'G', G)) call system_abort('No G in ds%atoms%params') - else - call print('No load field found - not increasing load.') - end if - end if - - end do - call system_timer('interpolation') - - end if ! .not. params%simulation_classical - - else ! params%md(params%md_stanza)%extrapolate_steps /= 1 - - !**************************************************************** - !* Non-Predictor/Corrector Dynamics * - !* * - !**************************************************************** - - if (ds%t - last_update_selection_time >= params%selection_update_interval) then - last_update_selection_time = ds%t - call print_title('Quantum Selection') - call system_timer('selection') - if (trim(params%selection_method) /= 'static') call crack_update_selection(ds%atoms, params) - call system_timer('selection') - end if - - if (ds%t - last_update_crack_tip_time >= params%md(params%md_stanza)%crack_find_tip_interval) then - call system_timer('crack_find_tip') - last_update_crack_tip_time = ds%t - mainlog%prefix = 'CRACK_TIP' - call crack_find_tip(ds%atoms, params, crack_tips) - call print('time '//ds%t) - call print(crack_tips) - mainlog%prefix = '' - call system_timer('crack_find_tip') - end if - - call print_title('Force Computation') - call system_timer('force computation/optimisation') - if (params%simulation_classical) then - call calc(classicalpot, ds%atoms, energy=energy, args_str='energy=energy force=force '//& - crack_mm_calc_args(mm_args_str, extra_mm_args, extra_args)) - else - call calc(hybrid_pot, ds%atoms, args_str="force=force "//& - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - end if - call system_timer('force computation/optimisation') - - if (params%hack_qm_zero_z_force) then - ! Zero z forces in embed region - force(3,find(hybrid == 1)) = 0.0_dp - end if - - call print_title('Advance Verlet') - call system_timer('advance_verlet') - call advance_verlet(ds, params%md(params%md_stanza)%time_step, force, do_calc_dists=(state /= STATE_MD_LOADING), parallel=do_parallel_verlet) - call system_timer('advance_verlet') - if (params%simulation_classical) then - call ds_print_status(ds, 'D', epot=energy) - else - call ds_print_status(ds, 'D') - end if - - if (trim(params%simulation_task) == 'damped_md') & - call print('Damped MD: normsq(force) = '//normsq(reshape(force,(/3*ds%N/)))//& - ' max(abs(force)) = '//maxval(abs(force))) - - call system_timer('load_increment') - if (state == STATE_MD_LOADING) then - ! increment the load - if (has_property(ds%atoms, 'load')) then - call crack_apply_load_increment(ds%atoms, params%md(params%md_stanza)%smooth_loading_rate*params%md(params%md_stanza)%time_step) - if (.not. get_value(ds%atoms%params, 'G', G)) call system_abort('No G in ds%atoms%params') - else - call print('No load field found - not increasing load.') - end if - end if - call system_timer('load_increment') - - end if ! params%extrapolate_steps /= 1 - - - ! Do I/O only on master node - if (.not. mpi_glob%active .or. (mpi_glob%active .and.mpi_glob%my_proc == 0)) then - - call set_value(ds%atoms%params, 'Time', ds%t) - call set_value(ds%atoms%params, 'Temp', temperature(ds)) - call set_value(ds%atoms%params, 'LastStateChangeTime', last_state_change_time) - call set_value(ds%atoms%params, 'LastMDIntervalTime', last_md_interval_time) - call set_value(ds%atoms%params, 'LastCalcConnectTime', last_calc_connect_time) - call set_value(ds%atoms%params, 'State', STATE_NAMES(state)) - - ! Print movie - if (ds%t - last_print_time >= params%io_print_interval) then - call system_timer('write_movie') - last_print_time = ds%t - call set_value(ds%atoms%params, 'LastPrintTime', last_print_time) - - if (params%io_backup) then - k=k+1 - if (mod(k,2).eq.0) then - call crack_print(ds%atoms, movie, params) - call print('writing .nc file '//trim(stem)//'.nc') - else - call crack_print(ds%atoms, movie_backup, params) - call print('writing .nc file '//trim(stem)//'_backup.nc') - endif - else - call crack_print(ds%atoms, movie, params) - end if - call system_timer('write_movie') - end if - - ! Write checkpoint file - if (ds%t - last_checkpoint_time >= params%io_checkpoint_interval) then - last_checkpoint_time = ds%t - call set_value(ds%atoms%params, 'LastCheckpointTime', last_checkpoint_time) - call set_value(ds%atoms%params, 'random_seed', system_get_random_seed()) - - checkfile_name = trim(params%io_checkpoint_path)//trim(stem)//'_check'//suffix - inquire (file=checkfile_name,exist=texist) - if (texist) then - call system_command('mv '//trim(checkfile_name)//' '//trim(checkfile_name)//'.backup') - end if - call write(ds%atoms, checkfile_name) - endif - end if - - ! Recalculate connectivity and nearest neighbour tables - if (ds%t - last_calc_connect_time >= params%md(params%md_stanza)%calc_connect_interval) then - last_calc_connect_time = ds%t - call crack_update_connect(ds%atoms, params) - end if - if (count(changed_nn == 1) /= 0) then - call crack_find_tip(ds%atoms, params, crack_tips) - call print('BOND BREAKING EVENT: Time '//ds%t) - endif - ! check if time exceeds time for this MD stanza - if (params%md(params%md_stanza)%stanza_time >= 0.0_dp) then - if (ds%t - last_stanza_change_time >= params%md(params%md_stanza)%stanza_time) cycle md_stanza - end if - - ! Exit cleanly if file 'stop_run' exists - inquire (file='stop_run',exist=texist) - if (texist) then - iunit = pick_up_unit() - open (iunit,file='stop_run',status='old') - close (iunit,status='delete') - exit md_stanza - endif - - ! exit cleanly if we exceeded the max run time - call system_timer('step', time_elapsed=time_elapsed) - total_time_elapsed = total_time_elapsed + time_elapsed - if (params%md(params%md_stanza)%max_runtime >= 0.0_dp) then - call print("elapsed time="//total_time_elapsed//" max_runtime="//params%md(params%md_stanza)%max_runtime) - if (total_time_elapsed >= params%md(params%md_stanza)%max_runtime) then - call print("Exceeded max_runtime, exiting cleanly", PRINT_ALWAYS) - exit md_stanza - endif - endif - - call flush(mainlog%unit) - - end do - - end do md_stanza - - - !**************************************************************** - !* * - !* FORCE INTEGRATION * - !* * - !* * - !**************************************************************** - else if (trim(params%simulation_task) == 'force_integration') then - -!!$ params%io_print_properties = trim(params%io_print_properties) // ":dr:forces" - - call print_title('Force Integration') - - fd_start = ds%atoms - call read(fd_end, params%force_integration_end_file) - - allocate (dr(3,ds%atoms%N)) - dr = (fd_end%pos - fd_start%pos)/real(params%force_integration_n_steps,dp) - - call add_property(ds%atoms, 'dr', 0.0_dp, 3) - if (.not. assign_pointer(ds%atoms, 'dr', dr_prop)) & - call system_abort("failed to add dr property to ds%atoms in force_integration task") - dr_prop = (fd_end%pos - fd_start%pos) - - integral = 0.0_dp - - call print('Force.dr integration') - write (line, '(a15,a15,a15,a15)') 'Step', 'Energy', 'F.dr', 'Integral(F.dr)' - call print(line) - - do i=0,params%force_integration_n_steps - - ds%atoms%pos = fd_start%pos + dr*real(i,dp) - call calc_connect(ds%atoms, store_is_min_image=.true.) - if (params%simulation_classical) then - call calc(classicalpot, ds%atoms, args_str='energy=energy force=force '//& - crack_mm_calc_args(mm_args_str, extra_mm_args, extra_args)) - if (.not. get_value(ds%atoms%params, "energy", energy)) & - call system_abort("missing energy!") - if (i == 0) fd_e0 = energy - else - if (i == 0) then - call calc(hybrid_pot, ds%atoms, args_str='force=force calc_weights=T '//& - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - else - ! ensure QM cluster is the same for each step by not recalculating the weights - call calc(hybrid_pot, ds%atoms, args_str='force=force calc_weights=F '//& - crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args)) - end if - end if - - f_dr = force .dot. dr - - ! Simpson's rule - if (i == 0 .or. i == params%force_integration_n_steps) then - integral = integral + f_dr/3.0_dp - else if (mod(i,2) == 0) then - integral = integral + 2.0_dp/3.0_dp*f_dr - else - integral = integral + 4.0_dp/3.0_dp*f_dr - end if - - if (params%simulation_classical) then - write (line, '(i15,e15.4,f15.4,f15.4)') i, energy, f_dr, integral - else - write (line, '(i15,a15,f15.4,f15.4)') i, '----', f_dr, integral - end if - call print(line) - call system_timer('write_movie') - call crack_print(ds%atoms, movie, params) - call system_timer('write_movie') - end do - - write (line, '(a,f15.8,a)') 'Change in energy = ', energy - fd_e0, ' eV' - call print(line) - write (line, '(a,f15.8,a)') '- Integral F.dr = ', -integral, ' eV' - call print(line) - - deallocate(dr) - call finalise(fd_start, fd_end) - - - !**************************************************************** - !* * - !* GEOMETRY OPTIMISATION * - !* * - !* * - !**************************************************************** - else if (trim(params%simulation_task) == 'minim') then - - call print_title('Geometry Optimisation') - - call print('Starting geometry optimisation...') - - if (params%simulation_classical) then - steps = minim(classicalpot, ds%atoms, method=params%minim_method, convergence_tol=params%minim_tol, & - max_steps=params%minim_max_steps, linminroutine=params%minim_linminroutine, & - do_pos=.true., do_lat=.false., do_print=.true., & - print_cinoutput=movie, eps_guess=params%minim_eps_guess, hook_print_interval=params%minim_print_output, & - args_str=crack_mm_calc_args(mm_args_str, extra_mm_args, extra_args), & - fire_minim_dt0=params%minim_fire_dt0, fire_minim_dt_max=params%minim_fire_dt_max) - else - steps = minim(hybrid_pot, ds%atoms, method=params%minim_method, convergence_tol=params%minim_tol, & - max_steps=params%minim_max_steps, linminroutine=params%minim_linminroutine, & - do_pos=.true., do_lat=.false., do_print=.true., & - print_cinoutput=movie, & - eps_guess=params%minim_eps_guess, hook_print_interval=params%minim_print_output, & - args_str=crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args), & - fire_minim_dt0=params%minim_fire_dt0, fire_minim_dt_max=params%minim_fire_dt_max) - end if - - if (.not. mpi_glob%active .or. (mpi_glob%active .and.mpi_glob%my_proc == 0)) then - call crack_update_connect(ds%atoms, params) - if (params%simulation_classical) then - call crack_find_tip(ds%atoms, params, crack_tips) - else - call crack_update_selection(ds%atoms, params) - end if - call system_timer('write_movie') - call crack_print(ds%atoms, movie, params) - call system_timer('write_movie') - end if - - !**************************************************************** - !* * - !* QUASI-STATIC LOADING * - !* * - !* * - !**************************************************************** - else if (trim(params%simulation_task) == 'quasi_static') then - - call print_title('Quasi Static Loading') - - if (.not. has_property(ds%atoms, 'load')) then - call print('No load field found. Regenerating load.') - call crack_calc_load_field(ds%atoms, params, classicalpot, params%crack_loading, & - .true., mpi_glob) - end if - - call crack_update_connect(ds%atoms, params) - - dummy = get_value(ds%atoms%params, 'CrackPosx', orig_crack_pos) - crack_pos(1) = orig_crack_pos - - do while (abs(crack_pos(1) - orig_crack_pos) < params%quasi_static_tip_move_tol) - - if (params%simulation_classical) then - steps = minim(classicalpot, ds%atoms, method=params%minim_method, convergence_tol=params%minim_tol, & - max_steps=params%minim_max_steps, linminroutine=params%minim_linminroutine, & - do_pos=.true., do_lat=.false., do_print=.true., & - print_cinoutput=movie, & - args_str=crack_mm_calc_args(mm_args_str, extra_mm_args, extra_args), & - eps_guess=params%minim_eps_guess, hook_print_interval=params%minim_print_output, & - fire_minim_dt0=params%minim_fire_dt0, fire_minim_dt_max=params%minim_fire_dt_max) - else - steps = minim(hybrid_pot, ds%atoms, method=params%minim_method, convergence_tol=params%minim_tol, & - max_steps=params%minim_max_steps, linminroutine=params%minim_linminroutine, & - do_pos=.true., do_lat=.false., do_print=.true., & - print_cinoutput=movie, eps_guess=params%minim_eps_guess, & - hook_print_interval=params%minim_print_output, & - args_str=crack_hybrid_calc_args(qm_args_str, extra_qm_args, mm_args_str, extra_mm_args, extra_args), & - fire_minim_dt0=params%minim_fire_dt0, fire_minim_dt_max=params%minim_fire_dt_max) - end if - - call crack_update_connect(ds%atoms, params) - if (params%simulation_classical) then - call crack_find_tip(ds%atoms, params, crack_tips) - else - call crack_update_selection(ds%atoms, params) - dummy = get_value(ds%atoms%params, 'CrackPosx', crack_pos(1)) - end if - - ! Apply loading field - call print_title('Applying load') - call crack_apply_load_increment(ds%atoms, params%crack_G_increment) - - call system_timer('write_movie') - call crack_print(ds%atoms, movie, params) - call system_timer('write_movie') - end do - - else - - call system_abort('Unknown task: '//trim(params%simulation_task)) - - end if ! switch on simulation_task - - - !** Finalisation Code ** - - call finalise(movie) - call finalise(ds) - - call finalise(hybrid_pot) - call finalise(forcemix_pot) - call finalise(classicalpot) - call finalise(qmpot) - if (allocated(f_fm)) deallocate(f_fm) - call system_finalise() - -end program crack diff --git a/src/Programs/create_hybrid_cluster.f95 b/src/Programs/create_hybrid_cluster.f95 deleted file mode 100644 index 5cac135d33..0000000000 --- a/src/Programs/create_hybrid_cluster.f95 +++ /dev/null @@ -1,120 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program test -use libatoms_module -use potential_module -use vacancy_map_module - -implicit none - type(Atoms) at, cluster - - type(Dictionary) :: cli_params - real(dp) :: sphere_qm_center(3), sphere_qm_rad - real(dp) :: cyl_qm_center(3), cyl_qm_vec(3), cyl_qm_rad - logical :: terminate - integer :: qm_hops, buffer_hops, transition_hops - type(Table) :: core_list, full_list - real(dp) :: r2, dr(3) - integer, pointer :: hybrid_mark(:) - integer :: i - - call system_initialise(enable_timing=.true.,verbosity=PRINT_SILENT) - - call initialise(cli_params) - call param_register(cli_params, "buffer_hops", "1", buffer_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "transition_hops", "1", transition_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "qm_hops", "0", qm_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "sphere_qm_center", "0 0 0", sphere_qm_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "sphere_qm_rad", "0", sphere_qm_rad, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "cyl_qm_center", "0 0 0", cyl_qm_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "cyl_qm_vec", "0 0 1", cyl_qm_vec, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "cyl_qm_rad", "0", cyl_qm_rad, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "terminate", "F", terminate, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - call print("Usage: vacancy_map_hybrid_generate [buffer_hops=i(1)] [transition_hops=i(1)]", PRINT_ALWAYS) - call print(" [qm_hops=i(1)] sphere_qm_center={x y z}(0 0 0) sphere_qm_rad=r(1)", PRINT_ALWAYS) - call print(" cyl_qm_center={x y z}(0 0 0) cyl_qm_vec={x y z}(0 0 0) cyl_qm_rad=r(1)", PRINT_ALWAYS) - call print(" terminate=L(F)", PRINT_ALWAYS) - call system_abort("Confused by CLI arguments") - end if - call finalise(cli_params) - - call print("Using buffer_hops " // buffer_hops // " transition_hops " // transition_hops // " qm_hops " // qm_hops) - call print("Using sphere_qm_center " // sphere_qm_center // " qm_rad " // sphere_qm_rad) - call print("Using cyl_qm_center " // cyl_qm_center // " cyl_qm_vec " // cyl_qm_vec // " cyl_qm_rad " // cyl_qm_rad // "terminate " // terminate) - - ! read initial config - call read_xyz(at, "stdin") - call set_cutoff(at, 3.2_dp) - call calc_connect(at) - - call add_property(at, 'hybrid_mark', 0) - call add_property(at, 'weight_region1', 0.0_dp) - - if (.not. assign_pointer(at, 'hybrid_mark', hybrid_mark)) & - call system_abort("Couldn't find hybrid_mark in at") - - ! core qm region - call wipe(core_list) - cyl_qm_vec = cyl_qm_vec / norm(cyl_qm_vec) - do i=1,at%N - if (sphere_qm_rad > 0) then - r2 = sum(((at%pos(:,i)-sphere_qm_center)/sphere_qm_rad)**2) - if (r2 < 1.0_dp) call append(core_list, (/i, 0, 0 ,0 /) ) - endif - if (cyl_qm_rad > 0) then - dr = at%pos(:,i) - cyl_qm_center - dr = dr - cyl_qm_vec*(cyl_qm_vec .dot. dr) - r2 = sum((dr/cyl_qm_rad)**2) - if (r2 < 1.0_dp) call append(core_list, (/i, 0, 0, 0 /) ) - endif - end do - - if (qm_hops > 0) call bfs_grow(at, core_list, qm_hops, nneighb_only = .false.) - - call print(core_list, PRINT_VERBOSE) - - hybrid_mark = HYBRID_NO_MARK - - hybrid_mark(int_part(core_list, 1)) = HYBRID_REGION1_MARK - - call create_local_energy_weights(at, transition_hops, buffer_hops) - - call initialise(full_list, 1 ,0, 0, 0) - call append(full_list, find(hybrid_mark /= HYBRID_NO_MARK)) - cluster = create_cluster(at, full_list, terminate, allow_cluster_modification = .false., periodic=(/.true.,.true.,.true./)) - - call verbosity_push(PRINT_NORMAL) - call print_xyz(cluster, mainlog, properties="pos:Z:hybrid_mark:weight_region1") - call verbosity_pop() - - call system_finalise() -end program diff --git a/src/Programs/descriptors_wrapper_example.f95 b/src/Programs/descriptors_wrapper_example.f95 deleted file mode 100644 index 5ed935e343..0000000000 --- a/src/Programs/descriptors_wrapper_example.f95 +++ /dev/null @@ -1,58 +0,0 @@ -program descriptors_wrapper_example - - implicit none - - integer, parameter :: n = 8 - real(8), dimension(3,3) :: lattice - character(len=3), dimension(n) :: symbol - real(8), dimension(3,n) :: coord - character(len=10240) :: descriptor_str, calc_args_str - - real(8), dimension(n,n) :: distances - - lattice(1,1) = 5.34224017d0; lattice(1,2) = 0.0d0; lattice(1,3) = 0.0d0; - lattice(2,1) = 0.0d0; lattice(2,2) = 5.34224017d0; lattice(2,3) = 0.0d0; - lattice(3,1) = 0.0d0; lattice(3,2) = 0.0d0; lattice(3,3) = 5.34224017d0; - - symbol = "Si " - - coord(1,1) = -0.52654131d0; coord(2,1) = -2.00406449d0; coord(3,1) = 1.19474806d0; - coord(1,2) = 1.99352351d0; coord(2,2) = 0.42020741d0; coord(3,2) = 1.15114713d0; - coord(1,3) = 1.21646828d0; coord(2,3) = 2.61257833d0; coord(3,3) = -1.34327040d0; - coord(1,4) = -1.42817712d0; coord(2,4) = -1.89404678d0; coord(3,4) = -1.94681516d0; - coord(1,5) = 0.10104488d0; coord(2,5) = -0.15357825d0; coord(3,5) = -0.33804307d0; - coord(1,6) = 2.08539850d0; coord(2,6) = -0.02403592d0; coord(3,6) = -1.84183528d0; - coord(1,7) = 1.79283079d0; coord(2,7) = -2.48879868d0; coord(3,7) = 1.55589928d0; - coord(1,8) = -1.54238274d0; coord(2,8) = 1.54656737d0; coord(3,8) = -0.12887274d0; - - descriptor_str ="soap n_max=10 l_max=10 atom_sigma=0.5 cutoff=3.0 cutoff_transition_width=0.5" - calc_args_str = "" - -#ifdef HAVE_GAP - call descriptors_wrapper_distances(n,lattice,symbol,coord,descriptor_str,len(descriptor_str),calc_args_str,len(calc_args_str),0,.false.,.true.,distances) - print*,'initial calc, Distances' - print*, sum(distances)/n - - coord(:,4) = coord(:,4) + (/-0.0221501781132952d0,0.00468815192049838d0,0.0457506835434298d0/) - call descriptors_wrapper_distances(n,lattice,symbol,coord,descriptor_str,len(descriptor_str),calc_args_str,len(calc_args_str),4,.false.,.true.,distances) - print*,'moving atom 4, Distances' - print*, sum(distances)/n - - coord(:,2) = coord(:,2) + (/0.03002804688888d0,-0.0358113661372785d0,-0.0078238717373725d0/) - call descriptors_wrapper_distances(n,lattice,symbol,coord,descriptor_str,len(descriptor_str),calc_args_str,len(calc_args_str),2,.false.,.true.,distances) - print*,'moving atom 2, accepted previous, Distances' - print*, sum(distances)/n - - coord(:,2) = coord(:,2) - (/0.03002804688888d0,-0.0358113661372785d0,-0.0078238717373725d0/) - coord(:,8) = coord(:,8) + (/0.0292207329559554d0,0.0459492426392903d0,0.0155740699156587d0/) - call descriptors_wrapper_distances(n,lattice,symbol,coord,descriptor_str,len(descriptor_str),calc_args_str,len(calc_args_str),8,.false.,.false.,distances) - print*,'moving atom 8, rejecting previous, Distances' - print*, sum(distances)/n - - call descriptors_wrapper_distances(n,lattice,symbol,coord,descriptor_str,len(descriptor_str),calc_args_str,len(calc_args_str),0,.false.,.true.,distances) - - print*,'Distances' - print*, sum(distances)/n -#endif - -endprogram descriptors_wrapper_example diff --git a/src/Programs/fgp.f95 b/src/Programs/fgp.f95 deleted file mode 100644 index 15cecd7d2e..0000000000 --- a/src/Programs/fgp.f95 +++ /dev/null @@ -1,690 +0,0 @@ -! This Fortran95 Code/Module performs Machine Learning Force prediction based on XYZ structural Files; -! Sorting/Selecting Algorithms are used to construct sub training database during heavy machine learning task; -! Database can be updated according to an error_threshold, e.g. pred_err; -! Internal Vector representation is used for describing the atomic structures; -! Any issues or bugs regarding this code please contact Zhenwei Li (zhenwei.li@unibas.ch) -! Reference article : Molecular Dynamics with On-the-Fly Machine Learning of Quantum-Mechanical Forces, Zhenwei Li, James Kermode, Alessandro De Vita, PRL, 114, 096405 (2015) -program force_gaussian_prediction - - use potential_module - use libatoms_module - use force_machine_learning_module - - implicit none - - type(Atoms) :: at_in - type(Potential) :: pot - type(CInOutput) :: in - type(Dictionary) :: params - real(dp) :: r_cut, feature_len, thresh, sigma_error, error_ls, error_gp, error_gp_sq, time, error_ls_max - real(dp) :: sigma_covariance, sigma_cov, dist_shift_factor, dim_tol, error_frame, force_magntd_pred, dist - real(dp), dimension(:), allocatable :: r_grid, m_grid, sigma, covariance_pred,force_magntd_data,force_magntd_data_select - real(dp), dimension(:), allocatable :: force_proj_test, force_proj_ivs_pred, distance_confs_unsorted - real(dp), parameter :: TOL_REAL=1e-7_dp, SCALE_IVS=100.0_dp - real(dp) :: force(3), variance_xyz(3), feature_inner_matrix(3,3), feature_inv(3,3), kappa, tmp - real(dp), dimension(:,:,:), allocatable :: ivs_set_norm, ivs_set, ivs_set_pred, nearest_data - real(dp), dimension(:,:), allocatable :: force_proj_ivs, force_proj_ivs_select, inv_covariance, out_u, out_vt, geometry_matrix - real(dp), dimension(:,:), allocatable, target :: covariance, distance_matrix, distance_matrix_dij, force_covariance_matrix, covariance_tiny - real(dp), dimension(:,:), allocatable :: ivs_set_norm_pred, ivs_set_norm_pred_t - real(dp), dimension(:,:), pointer :: force_ptr, force_ptr_mm, force_ptr_tff, pred_err - integer :: i,j, k, n, n_0, t, n_center_atom, n_loop, error - integer :: add_vector, n_teach, func_type, weight_index, temp_integer, ii, do_atz_index - integer :: local_ml_optim_size, dimension_mark(3) - integer, dimension(:), allocatable :: distance_index, mark_zero_ivs, species - logical :: top_teach, top_pred, do_gp, do_sigma, least_sq, print_at, do_svd, print_data,do_teach, do_read, print_verbosity, update_data, do_insert, do_dynamic_x, write_data_dij, read_data_dij - character(STRING_LENGTH) :: teach_file, test_file, out_file, data_dir - - call system_initialise(enable_timing=.true.) - - call initialise(params) - call param_register(params, 'r_cut', '8.0', r_cut, "the cutoff radius for the spherical atomic environment") - call param_register(params, 'thresh', '10.0', thresh, "the threshold for doing the Singular Value Decompostion of the Covariance Matrix") - call param_register(params, 'weight_index', '0', weight_index, "Type of weight function in deriving IVs, zero stands for the form of $exp(r/rcut)^m$") - call param_register(params, 'sigma_error', '0.05', sigma_error, "the noise assumed on the teaching data") - call param_register(params, 'do_atz_index', '0', do_atz_index, "0: charge-weight disabled; 1: using at%Z, 2: using ionic charge instead") - call param_register(params, 'func_type', '0', func_type, "which kernel function is used to build the covariance matrix") - call param_register(params, 'do_gp', 'T', do_gp, "true for doing a gaussian processes") - call param_register(params, 'n_teach', '1000', n_teach, "the number of relevant confs you would like to do machine learning with") - call param_register(params, 'do_sigma', 'F', do_sigma, "set true to print out the distance on every single dimension of the IVs space") - call param_register(params, 'do_dynamic_x', 'F', do_dynamic_x, "true for updating sigma.dat every test configuration based on nearest data points") - call param_register(params, 'top_teach', 'T', top_teach, "only the first configuration is considered when doing teaching") - call param_register(params, 'top_pred', 'T', top_pred, "only the first configuration is considered when doing predicting") - call param_register(params, 'least_sq', 'T', least_sq, "if true, the internal force components will be tranformed to real force using least squares") - call param_register(params, 'do_svd', 'F', do_svd, "if true, doing inverting the feature_inner_matrix by SVD") - call param_register(params, 'sigma_cov', '1.0', sigma_cov, "correlation length for pairs of data points") - call param_register(params, 'dist_shift_factor', '0.2', dist_shift_factor, "distance shifted with a given factor") - call param_register(params, 'dim_tol', '0.005', dim_tol, "threshold for determing the dimensionality of the group of IVs") - call param_register(params, 'teach_file', 'data.xyz', teach_file, "file to read teaching configurations from") - call param_register(params, 'test_file', 'test.xyz', test_file, "file to read the testing configurations from") - call param_register(params, 'print_data', 'F', print_data, "if true, print out the information for the database" ) - call param_register(params, 'data_dir', './info/', data_dir, "the directory where data files locate") - call param_register(params, 'do_teach', 'T', do_teach, "if false, the teaching part will be skipped") - call param_register(params, 'do_read', 'F', do_read, "if true, reading data file from the database") - call param_register(params, 'do_insert', 'F', do_insert, "INsert any addiitional vector as force_plus") - call param_register(params, 'print_verbosity', 'F', print_verbosity, "if true, print out verbosity stuff") - call param_register(params, 'out_file', 'out.xyz', out_file, "output configuration file containing the predicted forces") - call param_register(params, 'print_at', 'F', print_at, "true for print out the testing configuration with predicted forces") - call param_register(params, 'update_data', 'F', update_data, "whether or not updating the database") - call param_register(params, 'read_data_dij', 'F', read_data_dij, 'whether or not writing the distance file') - call param_register(params, 'write_data_dij', 'F', write_data_dij, 'whether or not reading the pair distnace matrix') - call param_register(params, 'local_ml_optim_size', '0', local_ml_optim_size, "Optimise sigma_error and sigma_cov using local_ml_optim_size LS confs. If 0, no optimisation is performed") - - if (.not. param_read_args(params, task="fgp command line params")) then - call print("Usage: fgp [options]") - call system_abort("Confused by command line arguments") - end if - - call print_title('params') - call param_print(params) - call finalise(params) - -if (do_teach) then - ! - call load_iv_params(data_dir, r_grid, m_grid, species, k, add_vector, n_data=n_0) - ! the current k is number of defined internal vectors - if (add_vector > 0) k=k+add_vector - call print('The number of valid Feature Vectors (inc. f_mm): '//k) - allocate(sigma(k)) ! knowing k, sigma canbe assigned - - ! to know the total number of teaching confs: n - call initialise(in, teach_file, INPUT) - n = 0 - do i=1, in%n_frame - call read(in, at_in) - if (top_teach) then - n = n + 1 - else - n = n + at_in%N - endif - enddo - call finalise(in) - call print("The total number of teaching configurations: "//n) - - - call print_title('starting the teaching process') - call system_timer('Preparing Information from the DATABASE') - - ! the main work starts - call initialise(in, teach_file, INPUT) - call print('Got '//in%n_frame//' input frames.') - - allocate(ivs_set(k,3,n)) - allocate(ivs_set_norm(k,3,n)) - allocate(force_proj_ivs(k, n)) - allocate(force_magntd_data(n)) - - t=0 ! counter for loop the atomic configurations - do i=1, in%n_frame - call read(in, at_in) - call assign_property_pointer(at_in, 'force', ptr=force_ptr) - if (add_vector > 0) then - if (do_insert) then - call assign_property_pointer(at_in, 'force_plus', ptr=force_ptr_mm) !treat the plus Force as mm - else - call Potential_Filename_Initialise(pot, args_str='IP SW', param_filename='SW.xml') - call calc(pot, at_in, args_str='force=force_mm', error=error) - call assign_property_pointer(at_in, 'force_mm', ptr=force_ptr_mm) - call finalise(pot) - endif - endif - ! the first vector is labelled force_mm in the input file, and is usually the SW force - if (add_vector > 1) call assign_property_pointer(at_in, 'force_i', ptr=force_ptr_tff) - ! the second vector is labelled force_i - ! call print('the frame: '//i) - - ! Including the symmetry images - call set_cutoff(at_in, r_cut) - call calc_connect(at_in) - - if (top_teach) then - n_loop = 1 - else - n_loop = at_in%N - endif - - do n_center_atom =1, n_loop - t = t + 1 - force = force_ptr(:,n_center_atom) - !call print("atomic force in real space : "//norm(force)) - !call print("The atom:"//n_center_atom) - - do j=1, k-add_vector - ivs_set(j,:,t) = internal_vector(at_in, r_grid(j), m_grid(j), species(j), n_center_atom, weight_index, do_atz_index) *SCALE_IVS - feature_len = norm(ivs_set(j,:, t)) - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - call print("WARNING: TEACHING, encountered the numerical limit in getting the unit direction of IVs") - endif - - ivs_set_norm(j,:,t) = ivs_set(j,:, t)/feature_len - if (print_verbosity) call print("internal vectors ( "//r_grid(j)//" "//m_grid(j)//" "//species(j)//" )"//ivs_set(j,1,t)//" "//ivs_set(j,2,t)//" "//ivs_set(j,3,t)) - enddo - - if (add_vector > 0 ) then - do j=k-add_vector+1, k - temp_integer=k-j - select case (temp_integer) - case (0) - ivs_set(j,:,t) = force_ptr_mm(:,n_center_atom) - case (1) - ivs_set(j,:,t) = force_ptr_tff(:,n_center_atom) - end select - - feature_len = norm(ivs_set(j,:,t)) - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - call print("WARNING: TEACHING, encountered the numerical limit in getting the unit direction of IVs") - endif - - ivs_set_norm(j,:,t) = ivs_set(j,:,t)/feature_len - !call print("added internal vectors :"//ivs_set(j,1,t)//" "//ivs_set(j,2,t)//" "//ivs_set(j,3,t)) - enddo - endif - - ! store the force info for every configuration - force_magntd_data(t) = norm(force) - do j=1, k - force_proj_ivs(j,t) = dot_product(ivs_set_norm(j,:,t), force) - enddo - - enddo ! loop over the atoms -enddo ! loop over the frames - -call finalise(in) -call system_timer('Preparing Information from the DATABASE') - -if (do_sigma) then - call sigma_factor_from_single_dimension(ivs_set(:,:,:), sigma, print_verbosity, TOL_REAL, data_dir) -endif - -!--------------------------------------------------------------------------------------------------------------------------------- -! WRITTING OUT THE DATAFILES -!--------------------------------------------------------------------------------------------------------------------------------- - -if (print_data) then - call system_timer('Writing Data File: Grid, Force and IV') - ! for updating database, initial value taken into account - call write_iv_params(data_dir, r_grid, m_grid, species, k-add_vector, add_vector, n) - if (.not. update_data ) call write_distance(0.0_dp, data_dir) - ! - OPEN(2,status='replace',file=trim(data_dir)//'Force.dat', form='UNFORMATTED') - OPEN(3,status='replace',file=trim(data_dir)//'IV.dat', form='UNFORMATTED') - - do t=1, n - write(2) force_proj_ivs(:, t), force_magntd_data(t) - do i=1,3 - write(3) ivs_set(:,i,t) - enddo - enddo ! for n configuration to augument the existing DATABASE - close(2) - close(3) - call system_timer('Writing Data File: Grid, Force and IV') - -endif ! print_data or not -end if ! do_teach, otherwise skipped - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! if do_read, teaching information to be collected from data files -if (do_read) then - - call print_title('READING TEACHING INFORMATION') - call system_timer('Collecting Information From Files') - call load_iv_params(data_dir, r_grid, m_grid, species, k, add_vector, n_data=n) - k = k + add_vector ! adding the Classical Force Vectors - - allocate(force_proj_ivs(k,n)) - allocate(ivs_set(k,3,n)) - allocate(ivs_set_norm(k,3,n)) - allocate(force_magntd_data(n)) - allocate(sigma(k)) - - OPEN(2,status='old',file=trim(data_dir)//'Force.dat',form='UNFORMATTED') - OPEN(3,status='old',file=trim(data_dir)//'IV.dat',form='UNFORMATTED') - - do t=1, n - read(2) force_proj_ivs(:, t), force_magntd_data(t) - !write(*,*) "%", force_proj_ivs(:, t), force_magntd_data(t) - do i=1, 3 - read(3) ivs_set(:,i,t) - enddo - !write(*,*) "$", ivs_set(:,:,t) - enddo - close(2) - close(3) - - ! calculating the normalised vectors - do t=1, n - do j=1, k - feature_len = norm(ivs_set(j,:, t)) - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - call print("WARNING: TEACHING, encountered the numerical limit in getting the unit direction of IVs") - endif - ivs_set_norm(j,:,t)=ivs_set(j,:, t)/feature_len - enddo - enddo - - ! reading sigma file - open(unit=1, status='old', file=trim(data_dir)//'sigma.dat', form='formatted') - read(1, *) sigma - close(unit=1) - call system_timer('Collecting Information From Files') - call print('sigma is: '//sigma) -endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -if ((do_teach) .and. (.not. do_read)) then - open(unit=1, status='old', file=trim(data_dir)//'sigma.dat', form='formatted') - read(1, *) sigma - close(unit=1) - call system_timer('Collecting Information From Files') - call print('sigma is: '//sigma) -endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! the following part can be changed to a subroutine -call print_title('starting the predicting process') -! -if (n_teach > n) then - n_teach = n - call print("the Actual Number of Configs for Prediction: "//n_teach) - call print("WARNNING: Trying to select more configurations than the database has") -endif -! -allocate(covariance_pred(n_teach)) -allocate(force_proj_ivs_pred(k)) -allocate(mark_zero_ivs(k)) -allocate(geometry_matrix(3,k)) -allocate(covariance(n_teach,n_teach)) -allocate(distance_confs_unsorted(n), distance_index(n)) -if (local_ml_optim_size > 0) then -allocate(distance_matrix(local_ml_optim_size,local_ml_optim_size), force_covariance_matrix(local_ml_optim_size,local_ml_optim_size), covariance_tiny(local_ml_optim_size,local_ml_optim_size)) -endif -allocate(inv_covariance(n_teach,n_teach)) -allocate(force_proj_ivs_select(k, n_teach)) -allocate(force_magntd_data_select(n_teach)) -allocate(ivs_set_norm_pred(k,3)) -if (read_data_dij) allocate(distance_matrix_dij(n, n)) - -if (read_data_dij) then - call system_timer('Read Pair Distance and Bulid Covariance') - call read_distance_file(distance_matrix_dij(:,:), data_dir) - !write(*,*) 'Distance Read', distance_matrix_dij - call system_timer('Read Pair Distance and Bulid Covariance') -endif - -call initialise(in, test_file, INPUT) -do i=1, in%n_frame - call read(in, at_in) - if (.not. get_value(at_in%params, 'time', time)) then - call print("TIME of FRAME : UNKOWN") - else - call print("TIME of FRAME :"//time) - endif - call add_property(at_in, 'force', 0.0_dp, n_cols=3, overwrite=.false.) ! how do you know dont want overwrite - call assign_property_pointer(at_in, 'force', ptr=force_ptr) - - ! for writing out the predicted error - call add_property(at_in, 'pred_err', 0.0_dp, n_cols=3, overwrite=.true.) - call assign_property_pointer(at_in, 'pred_err', ptr=pred_err) - - if (add_vector > 0) then - if (do_insert) then - call assign_property_pointer(at_in, 'force_plus', ptr=force_ptr_mm) - else - call Potential_Filename_Initialise(pot, args_str='IP SW', param_filename='SW.xml') - call calc(pot, at_in, args_str='force=force_mm', error=error) - call assign_property_pointer(at_in, 'force_mm', ptr=force_ptr_mm) - call finalise(pot) - endif - endif - if (add_vector>1) call assign_property_pointer(at_in, 'force_i', ptr=force_ptr_tff) - - call set_cutoff(at_in, r_cut) - call calc_connect(at_in) - if (top_pred) then - n_loop = 1 - else - n_loop = at_in%N - endif - - allocate(ivs_set_pred(k,3,n_loop)) - - error_frame=0.0_dp ! for calculating the average error of the system. - - do n_center_atom=1, n_loop ! loop over atoms in the Frame, make prediction (incl. error) - - do j=1, k ! reset the mark for zero internal vectors - mark_zero_ivs(j)=1 - enddo - - do j= 1, k-add_vector - ivs_set_pred(j,:,n_center_atom) = internal_vector(at_in, r_grid(j), m_grid(j), species(j), n_center_atom, weight_index, do_atz_index) *SCALE_IVS - if (print_verbosity) call print("internal vectors ( "//r_grid(j)//" "//m_grid(j)//" "//species(j)//" ): "//ivs_set_pred(j,1,n_center_atom)//" "//ivs_set_pred(j,2,n_center_atom)//" "//ivs_set_pred(j,3,n_center_atom)) - feature_len = norm(ivs_set_pred(j,:,n_center_atom)) - - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - mark_zero_ivs(j)=0 - call print("WARNING: PREDICTION, encountered the numerical limit in getting the unit direction of IVs") - endif - - ivs_set_norm_pred(j,:) = ivs_set_pred(j,:,n_center_atom)/feature_len - enddo - - if (add_vector>0) then - do j = k-add_vector+1, k - temp_integer=k-j - select case (temp_integer) - case (0) - ivs_set_pred(j,:,n_center_atom)=force_ptr_mm(:, n_center_atom) - case (1) - ivs_set_pred(j,:,n_center_atom)=force_ptr_tff(:, n_center_atom) - end select - feature_len = norm(ivs_set_pred(j,:,n_center_atom)) - - if (feature_len < TOL_REAL) then - feature_len=1.0_dp - mark_zero_ivs(j)=0 - call print("WARNING: PREDICTION, encountered the numerical limit in getting the unit direction of IVs") - endif - - ivs_set_norm_pred(j,:) = ivs_set_pred(j,:,n_center_atom)/feature_len - if (print_verbosity) call print("added internal vectors : "//ivs_set_pred(j,1,n_center_atom)//" "//ivs_set_pred(j,2,n_center_atom)//" "//ivs_set_pred(j,3,n_center_atom)) - enddo - endif - - - if (print_verbosity) then - do j=1, k - do ii=1, k - if(print_verbosity) then - call print("ATOM : "//n_center_atom//" ivs_set: ("//j//" "//ii//") "//dot_product(ivs_set_pred(j,:,n_center_atom), ivs_set_norm_pred(ii,:)) ) - endif - enddo - enddo - endif - - - ! initialise distance_index(:) - do t=1, n - distance_index(t) =t - enddo - - ! do the sorting and selection - call sorting_configuration(ivs_set_pred(:,:,n_center_atom), ivs_set, ivs_set_norm_pred, ivs_set_norm, sigma, distance_confs_unsorted, distance_index) - call print("The First 20 Closest data Configurations are :"//distance_index(:20)) - call print("Min and Max DISTANCE with Index after Sorting: "//distance_confs_unsorted(distance_index(1))//" and "// & - distance_confs_unsorted(distance_index(n_teach))//" the INDEX: "//distance_index(1)//" and "//distance_index(n_teach)) - !!!!!!!!!!!!! - if (do_dynamic_x) then - allocate(nearest_data(k,3,n_teach)) - do ii=1, n_teach - nearest_data(:,:,ii)=ivs_set(:,:,distance_index(ii)) - enddo - call sigma_factor_from_single_dimension(nearest_data, sigma, print_verbosity, TOL_REAL, data_dir) - ! update 'sigma.dat' - deallocate(nearest_data) - endif - - if ( distance_confs_unsorted( distance_index(1) ) > dist_shift_factor) then - ! distance_confs_unsorted: the pair distance betwen test and database. - ! sigma_cov: the original input for covariance length - sigma_covariance = sigma_cov*distance_confs_unsorted(distance_index(1))/dist_shift_factor - ! this intrinsically changes the value of SIGMA_COVARIANCE and enters next loop - call print("sigma_covariance are shifted by a factor of :"//distance_confs_unsorted(distance_index(1))/dist_shift_factor) - call print("Modified sigma_covariance :"//sigma_covariance) - else - sigma_covariance = sigma_cov - ! the sigma_covariance used in GP - endif - - if (.false.) then - ! massive output, only for testing use - call print("Detail on the teaching information") - do ii = 1, n_teach - call print("Index: "//distance_index(ii)//" Distance: "//distance_confs_unsorted(ii)) - call print("Force in IVs space: "//force_proj_ivs(:,distance_index(ii))) - enddo - endif - - ! max marginal likelihood - if (local_ml_optim_size > 0) call print("Optimise: "//local_ml_optim_size) - !!! ML optimisation here: first calculates the necessary input matrices, then optimises - if (local_ml_optim_size > 0) then - call print("Local Maximum Likelihood selected") - do t = 1, local_ml_optim_size ! loop to generate the force_cov_mat and the distance_matrix of the restricted subset of the LS - do j = t, local_ml_optim_size - force_covariance_matrix(t,j) = dot_product(force_proj_ivs(:,distance_index(t)), force_proj_ivs(:,distance_index(j))) - ! check if possible, may be a wreck because IVs make absolute representation of the force impossible - force_covariance_matrix(j,t) = force_covariance_matrix(t,j) - covariance_tiny(t,j) = cov(ivs_set(:,:,distance_index(t)), ivs_set(:,:,distance_index(j)), & - ivs_set_norm(:,:,distance_index(t)), ivs_set_norm(:,:,distance_index(j)), sigma, sigma_covariance, func_type=func_type, & - distance=distance_matrix(t,j)) - covariance_tiny(j,t) = covariance_tiny(t,j) - distance_matrix(j,t) = distance_matrix(t,j) - enddo - enddo - call do_optimise_likelihood(sigma_error, sigma_covariance) - endif - - if (read_data_dij) then - do t = 1, n_teach ! loop to generate the covariance matrix of the learning set - dist=distance_matrix_dij(distance_index(t), distance_index(t)) - covariance(t,t) = cov_dij(sigma_covariance, dist, func_type) - ! write(*,*) 'diagoanl value', covariance(t,t) - if (do_gp) covariance(t,t) = covariance(t,t) + sigma_error**2 - do j = t+1, n_teach ! above diagonal - dist=distance_matrix_dij(distance_index(t),distance_index(j)) - covariance(t,j) = cov_dij(sigma_covariance, dist, func_type) - covariance(j,t) = covariance(t,j) - enddo - enddo - else - call system_timer('Evaluating the Cov') - !Generate covariance matrix - !$omp parallel default(none) shared(covariance, n_teach, ivs_set, ivs_set_norm, distance_index, sigma, sigma_error, sigma_covariance, do_gp, func_type), private(j) - !$omp do - do t = 1, n_teach ! loop to generate the covariance matrix of the learning set - covariance(t,t) = cov(ivs_set(:,:,distance_index(t)), ivs_set(:,:,distance_index(t)), & - ivs_set_norm(:,:,distance_index(t)), ivs_set_norm(:,:,distance_index(t)), sigma, sigma_covariance, func_type=func_type) - if (do_gp) covariance(t,t) = covariance(t,t) + sigma_error**2 - do j = t+1, n_teach ! above diagonal - covariance(t,j) = cov(ivs_set(:,:,distance_index(t)), ivs_set(:,:,distance_index(j)), & - ivs_set_norm(:,:,distance_index(t)), ivs_set_norm(:,:,distance_index(j)), sigma, sigma_covariance, func_type=func_type) - covariance(j,t) = covariance(t,j) - enddo - enddo - !$omp end parallel - call system_timer('Evaluating the Cov') - endif ! not read_data_dij - - call system_timer('Inverting the Covariance Matrix') - if (do_gp) then - call inverse(covariance, inv_covariance) - else - ! To Do Sigular Value Decomposition (SVD): A = U*SIGMA*VT - call inverse_svd_threshold(covariance, thresh, result_inv=inv_covariance) - endif - call system_timer('Inverting the Covariance Matrix') - - - do t=1, n_teach - force_proj_ivs_select(:,t)=force_proj_ivs(:,distance_index(t)) - force_magntd_data_select(t) = force_magntd_data(distance_index(t)) - enddo - - ! the test configuration covariance vector - do t= 1, n_teach - covariance_pred(t) = cov(ivs_set_pred(:,:,n_center_atom), ivs_set(:,:,distance_index(t)), ivs_set_norm_pred, & - ivs_set_norm(:,:,distance_index(t)), sigma, sigma_covariance, func_type=func_type) - enddo - - ! the predicted force components on each of the internal directions - force_proj_ivs_pred(:) = matmul(covariance_pred, matmul(inv_covariance, transpose(force_proj_ivs_select(:,:)) )) - - ! Predict the Force Magnitude - force_magntd_pred = dot_product(covariance_pred, matmul(inv_covariance, force_magntd_data_select)) - - ! we need to mannually set the force components to be zero, projected on the zero internal-vector directions - do j=1, k - force_proj_ivs_pred(j)=force_proj_ivs_pred(j)*real(mark_zero_ivs(j), dp) - enddo - - if (print_verbosity) then - do j=1, k - call print("ivs_set_norm_pred"//ivs_set_norm_pred(j,:)) - enddo - endif - - allocate(out_u(3,3), out_vt(3,3)) ! to obtain the transformation matrix with the principal axis - call inverse_svd_threshold(transpose(ivs_set_norm_pred) .mult. ivs_set_norm_pred, thresh, u_out=out_u, vt_out=out_vt) - - allocate(ivs_set_norm_pred_t(k,3)) - - call internal_dimension_mark(ivs_set_pred(:,:,n_center_atom) .mult. out_u, dim_tol, dimension_mark) - - ivs_set_norm_pred_t = ivs_set_norm_pred .mult. out_u - - ! ivs_set_pred_t contains the Internal-directions after PCA transformation. - if (print_verbosity) then - do j=1, k - write(*,*) "ivs_set_norm_pred_t : ", ivs_set_norm_pred_t(j, :) - enddo - endif - - select case (sum(dimension_mark(:))) - case(0) - force= 0.0_dp - case(1) - force=(transpose(ivs_set_norm_pred) .mult. force_proj_ivs_pred )/real(sum(mark_zero_ivs),dp) - case(2) - feature_inner_matrix=transpose(ivs_set_norm_pred_t) .mult. ivs_set_norm_pred_t - call rank_lowered_inverse(feature_inner_matrix, feature_inv) - force = out_u .mult. feature_inv .mult. transpose(ivs_set_norm_pred_t) .mult. force_proj_ivs_pred - case(3) - - feature_inner_matrix=transpose(ivs_set_norm_pred) .mult. ivs_set_norm_pred - if (do_svd) then - if (print_verbosity) write(*,*) "feature inner matrix :", feature_inner_matrix - call inverse_svd_threshold(feature_inner_matrix, thresh, result_inv=feature_inv) - if (print_verbosity) write(*,*) "inverse feature inner matrix :", feature_inv - else - if (print_verbosity) write(*,*) "feature_inner_matrix :", feature_inner_matrix - call inverse(feature_inner_matrix, feature_inv) - if (print_verbosity) write(*,*) "inverse feature inner matrix :", feature_inv - endif - - if (least_sq) then - force = feature_inv .mult. transpose(ivs_set_norm_pred) .mult. force_proj_ivs_pred - else - call real_expection_sampling_components(ivs_set_norm_pred, force_proj_ivs_pred, force) - endif - end select - - deallocate(out_u) - deallocate(out_vt) - deallocate(ivs_set_norm_pred_t) - - call print("Predicted Force Magnitude: "//force_magntd_pred) - call print("force in external space : "//force//" Magnitude: "//norm(force)) - call print("the original force:"//force_ptr(:, n_center_atom)//" Magnitude: "//norm(force_ptr(:, n_center_atom))) - call print("max error : "//maxval(abs(force_ptr(:,n_center_atom)-force))//" norm error : "//norm(force_ptr(:,n_center_atom)-force)) - if (norm(force_ptr(:,n_center_atom)) > TOL_REAL) then - call print("Relative Error : "//norm(force_ptr(:,n_center_atom)-force)/norm(force_ptr(:,n_center_atom)) ) - else - call print("Relative Error : "//" ZERO Magnititude ") - endif - ! measure the consistence between the least-square inference and the components obtained from GP processes - if (least_sq) then - error_ls=0.0_dp - do j=1, k - error_ls = error_ls + (dot_product(ivs_set_norm_pred(j,:), force(:)) - force_proj_ivs_pred(j))**2 - enddo - error_ls = sqrt(error_ls / real(k,dp)) - call print("deviation of least-square inference : "//error_ls) - error_ls_max=maxval(abs( matmul(ivs_set_norm_pred, force) - force_proj_ivs_pred(:) )) - call print("Max deviation Component of LS : "//error_ls_max) - endif - - kappa = cov(ivs_set_pred(:,:,n_center_atom), ivs_set_pred(:,:,n_center_atom), ivs_set_norm_pred, ivs_set_norm_pred, sigma, sigma_covariance, func_type=func_type) + sigma_error**2 - ! the passing of uncertainty from Gaussian Processes to the Force Vector - error_gp_sq = kappa - covariance_pred .dot. matmul(inv_covariance, covariance_pred) - error_gp = sqrt(abs(error_gp_sq)) - geometry_matrix = feature_inv .mult. transpose(ivs_set_norm_pred) - - do j=1, 3 ! Deviation in External Cartesian Coordinate - variance_xyz(j)= sqrt(dot_product(geometry_matrix(j,:), geometry_matrix(j,:))) * (error_gp) - !call print("Predicted Error Factor :"//sum(abs(geometry_matrix(j,:)))//" Dimension :"//j) - enddo - - call print("GP Uncertainty in Cartesian Coordinate: "//variance_xyz//" GP variance: "//error_gp//" variance Squre :"//error_gp_sq) - pred_err(1, n_center_atom)=norm(variance_xyz) - pred_err(2, n_center_atom)=abs(force_magntd_pred - norm(force)) - pred_err(3, n_center_atom)=error_ls - if (update_data) then - call system_timer('Updating the DATABSE : dist.dat force.dat ivs.dat') - allocate(force_proj_test(k)) ! the projection of real force on test conf - do j = 1, k - force_proj_test(j) = dot_product(force_ptr(:,n_center_atom), ivs_set_norm_pred(j,:) ) - enddo - call write_iv_params(data_dir, r_grid, m_grid, species, k-add_vector, add_vector, n+1) - if (write_data_dij) call write_distance(distance_confs_unsorted, data_dir) - ! append distance file - if (print_verbosity) then - write(*,*) 'Distance', distance_confs_unsorted(:) - endif - OPEN(2,status='old',file=trim(data_dir)//'Force.dat', form='UNFORMATTED', position='APPEND') - OPEN(3,status='old',file=trim(data_dir)//'IV.dat', form='UNFORMATTED', position='APPEND') - write(2) force_proj_test(:), norm(force_ptr(:,n_center_atom)) - do j=1, 3 - write(3) ivs_set_pred(:,j,n_center_atom) - enddo - close(2) - close(3) - deallocate(force_proj_test) - call system_timer('Updating the DATABSE : dist.dat force.dat ivs.dat') - endif - if (print_at) force_ptr(:,n_center_atom)=force - enddo ! loop over positions - - deallocate(ivs_set_pred) - - error_frame = maxval( pred_err) - call print("Error Bar of the Frame :"//error_frame) - - if (print_at) then - ! write the output configurations with predicted force, we dont want appending practically - call write(at_in, out_file, append=.False.) - endif - -enddo ! loop over frames - -call finalise(in) - -deallocate(ivs_set_norm_pred) ! because it is defined within the loop - -deallocate(geometry_matrix) -deallocate(r_grid, m_grid, species, sigma) -deallocate(force_proj_ivs_pred) -deallocate(ivs_set_norm) -deallocate(force_magntd_data, force_magntd_data_select) -deallocate(ivs_set) -deallocate(mark_zero_ivs) -deallocate(force_proj_ivs) -deallocate(force_proj_ivs_select) -deallocate(covariance, inv_covariance) -deallocate(covariance_pred) -deallocate(distance_index, distance_confs_unsorted) -if(allocated(force_covariance_matrix)) deallocate(force_covariance_matrix) -if(allocated(covariance_tiny)) deallocate(covariance_tiny) -if(allocated(distance_matrix)) deallocate(distance_matrix) -if (allocated(distance_matrix_dij)) deallocate(distance_matrix_dij) -call system_finalise() -call print('-------------END OF FGP----------------') - -end program force_gaussian_prediction diff --git a/src/Programs/fix_traj_latest.f95 b/src/Programs/fix_traj_latest.f95 deleted file mode 100644 index 62a8483ab6..0000000000 --- a/src/Programs/fix_traj_latest.f95 +++ /dev/null @@ -1,98 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program fix_traj -use libatoms_module - type(atoms) :: at - integer, pointer :: cluster_mark(:), t_i(:) - character(len=1), pointer :: t_s(:,:) - real(dp), pointer :: t_d(:) - - call system_initialise() - - call read(at, "stdin") - - call add_property(at, 'Z', 0) - call add_property(at, 'mass', 0.0_dp) - call add_property(at, 'travel', 0, 3) - call add_property(at, 'move_mask', 1) - call add_property(at, 'damp_mask', 0) - call add_property(at, 'thermostat_region', 0) - call add_property(at, 'avg_ke', 0.0_dp) - call add_property(at, 'acc', 0.0_dp, 3) - call add_property(at, 'avgpos', 0.0_dp, 3) - call add_property(at, 'oldpos', 0.0_dp, 3) - call add_property(at, 'pot', 0.0_dp) - call add_property(at, 'hybrid', 1) - call add_property(at, 'hybrid_mark', 1) - call add_property(at, 'old_hybrid_mark', 1) - call add_property(at, 'old_cluster_mark', 1) - call add_property(at, 'cut_bonds', 0, 4) - call add_property(at, 'atom_type', '') - call add_property(at, 'atom_res_name', '') - call add_property(at, 'atom_mol_name', '') - call add_property(at, 'atom_res_number', 0) - call add_property(at, 'atom_charge', 0.0_dp) - call add_property(at, 'weight_region1', 0.0_dp) - call add_property(at, 'qm_force', 0.0_dp, 3) - call add_property(at, 'mm_force', 0.0_dp, 3) - call add_property(at, 'force', 0.0_dp, 3) - - - if (.not. assign_pointer(at, 'cluster_mark', cluster_mark)) call system_abort("no cluster_mark") - - if (.not. assign_pointer(at, 'Z', t_i)) call system_abort("no Z") - if (.not. assign_pointer(at, 'species', t_s)) call system_abort("no species") - do i=1, at%N - t_i(i) = atomic_number_from_symbol(trim(a2s(t_s(:,i)))) - end do - - if (.not. assign_pointer(at, 'mass', t_d)) call system_abort("no mass") - do i=1, at%N - t_d(i) = ElementMass(at%Z(i)) - end do - - if (.not. assign_pointer(at, 'hybrid', t_i)) call system_abort("no hybrid") - where (cluster_mark == HYBRID_ACTIVE_MARK) - t_i = 1 - else where - t_i = 0 - end where - if (.not. assign_pointer(at, 'hybrid_mark', t_i)) call system_abort("no hybrid_mark") - t_i = cluster_mark - if (.not. assign_pointer(at, 'old_hybrid_mark', t_i)) call system_abort("no old_hybrid_mark") - t_i = cluster_mark - if (.not. assign_pointer(at, 'old_cluster_mark', t_i)) call system_abort("no cluster_mark") - t_i = cluster_mark - - call write(at, "stdout", prefix="OUT") - - call system_finalise() -end program diff --git a/src/Programs/get_qw.f95 b/src/Programs/get_qw.f95 deleted file mode 100644 index 0871d5d755..0000000000 --- a/src/Programs/get_qw.f95 +++ /dev/null @@ -1,138 +0,0 @@ -program get_qw - - use libatoms_module - use steinhardt_nelson_qw_module -#ifdef NO_FORTRAN_ISNAN - use system_module, only: isnan -#endif - - - implicit none - - !local variables - type(Dictionary) :: params - type(Atoms) :: at - type(Cinoutput) :: infile, outfile - character(STRING_LENGTH) :: atfile_in - character(STRING_LENGTH) :: central_mask, neighbour_mask - integer :: stat, n_string - real(dp) :: r_cut, r_cut_min, summa_q, summa_w, q_global, w_glob - real(dp), dimension(:), pointer :: q, w - integer :: l, i , error, i_config, iat - logical :: calc_QWave, print_QWxyz - logical, allocatable, dimension(:) :: c_mask, n_mask - - call system_initialise(PRINT_NORMAL) - call verbosity_push(PRINT_NORMAL) - - call initialise(params) - call param_register(params, 'atfile_in', PARAM_MANDATORY, atfile_in,'') ! xyz input filename - call param_register(params, 'r_cut', PARAM_MANDATORY, r_cut,'') ! cutoff for neighbours taken into account - call param_register(params, 'l', PARAM_MANDATORY, l,'') ! l=2, 4, 6, 8, .... - call param_register(params, 'r_cut_min', '0.0', r_cut_min,'') ! minimum cutoff within which atoms are not considered - call param_register(params, 'calc_QWave', 'F', calc_QWave,'') ! average bond order params over the configuration - call param_register(params, 'print_QWxyz', 'F', print_QWxyz,'') ! print an xyz with all QW as properties - call param_register(params, 'central_mask', 'all', central_mask,'') ! which type of atom can be central - call param_register(params, 'neighbour_mask', 'all', neighbour_mask,'') ! which type of atoms are neighbours - - if (.not. param_read_args(params, check_mandatory = .true.)) then - call print("Usage: get_qw [atfile_in] [r_cut] [l] [r_cut_min=0.0] [calc_QWave=F] [print_QWxyz=F] & - &[central_mask=all] [neighbour_mask=all]" ,PRINT_SILENT) - call system_abort('Exit: Mandatory argument(s) missing...') - endif - call finalise(params) - - call initialise(infile,atfile_in) - -! read(COMMAND_ARG(4),*) averageL -! read(COMMAND_ARG(5),*) maximalQ -! read(COMMAND_ARG(6),*) atom_mask -! read(COMMAND_ARG(7),*) print_qw - - if (print_QWxyz) then - if (central_mask /= 'all' .or. neighbour_mask /= 'all') & - & call system_abort("if qw to be printed to an xyz file, no mask should be used. Use 'all' option (default)") - call initialise(outfile,"qw"//l//"_"//trim(atfile_in),action=output) - endif - - - i_config = 0 - do - call read(at, infile, error=error) - if (error /= 0) then - exit - endif - i_config = i_config + 1 - - if (i_config == 1) then ! do the mask initialisation for the first config. - - allocate(c_mask(at%N), n_mask(at%N)) - c_mask = .true. ! default: all atoms taken into account - n_mask = .true. ! default: all atoms taken into account - if (central_mask /= 'all') then - !call print('Selecting all '//trim(ElementName(at%Z(iat)))//' atoms (Z = '//at%Z(iat)//') as the central atom') - do iat = 1,at%N - if (central_mask /= trim(ElementName(at%Z(iat)))) c_mask(iat)=.false. - enddo - endif - !write(*,*) c_mask - if (neighbour_mask /= 'all') then - !call print('Selecting all '//trim(ElementName(at%Z(iat)))//' atoms (Z = '//at%Z(iat)//') as the central atom') - do iat = 1,at%N - if (neighbour_mask /= trim(ElementName(at%Z(iat)))) n_mask(iat)=.false. - enddo - endif - !write(*,*) n_mask - - endif - - call set_cutoff(at,r_cut) - call calc_connect(at) - call calc_qw(at,l,do_q=.true.,do_w=.true.,cutoff=r_cut,min_cutoff=r_cut_min,mask=c_mask, & - & mask_neighbour=n_mask,cutoff_transition_width=0.0_dp) ! l optional, default 4 (q4 es w4) - - if( .not. assign_pointer(at, 'q'//l, q) ) & - & call system_abort('could not assign pointer to atoms object') - if( .not. assign_pointer(at, 'w'//l, w) ) & - & call system_abort('could not assign pointer to atoms object') - - do i = 1,size(w) - if (isnan(w(i))) w(i) = 0.0_dp - enddo - do i = 1,size(q) - if (isnan(q(i))) q(i) = 0.0_dp - enddo - - if (calc_QWave) then ! print average QW parameters - - summa_q = 0.0_dp - summa_w = 0.0_dp - do iat = 1,at%N - ! average only atoms with atom_mask true - if (c_mask(iat)) then - summa_q = summa_q + q(iat) - summa_w = summa_w + w(iat) - endif - enddo - write(*,*) summa_q/count(c_mask) , summa_w/count(c_mask) - - else - do iat = 1,at%N - if (c_mask(iat) ) then - write(*,*) i_config, q(iat), w(iat) - endif - enddo - write(*,*) - write(*,*) - - endif - - if (print_QWxyz) call write(at,outfile, properties="species:pos:q"//l//":w"//l) - call finalise(at) - enddo - - if (print_QWxyz) call finalise(outfile) - call system_finalise() - - -end program get_qw diff --git a/src/Programs/local_E_fd.f95 b/src/Programs/local_E_fd.f95 deleted file mode 100644 index e034ad2b3f..0000000000 --- a/src/Programs/local_E_fd.f95 +++ /dev/null @@ -1,145 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program test_potential - -use libAtoms_module -use potential_module -use libatoms_misc_utils_module -use elasticity_module -use phonons_module - - -implicit none - - type(Potential) pot - type(MPI_context) mpi_glob - type(Atoms) at - - type(Dictionary) :: cli_params - - character(len=100) verbosity - character(len=STRING_LENGTH) init_args, calc_args, at_file, param_file - - real(dp) :: E0 - real(dp), allocatable :: local_E_p(:), local_E_m(:), local_N_p(:), local_N_m(:) - real(dp), pointer :: local_E_fd(:), local_N(:), local_N_fd(:) - integer :: fd_index - real(dp) :: fd_vec(3), p0(3) - - call system_initialise() - - init_args = '' - calc_args = '' - call initialise(cli_params) - call param_register(cli_params, 'fd_index', PARAM_MANDATORY, fd_index, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'fd_vec', PARAM_MANDATORY, fd_vec, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'init_args', PARAM_MANDATORY, init_args, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'at_file', 'stdin', at_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'param_file', 'quip_params.xml', param_file, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'calc_args', '', calc_args, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, 'verbosity', 'NORMAL', verbosity, help_string="No help yet. This source file was $LastChangedBy$") - - call print("n_args " // cmd_arg_count()) - - if (.not. param_read_args(cli_params)) then - call print("Usage: eval fd_index=i fd_vec='x y z'", PRINT_ALWAYS) - call print(" init_args='str' [at_file=file(stdin)] [param_file=file(quip_parms.xml)]",PRINT_ALWAYS) - call print(" [calc_args='str'] [verbosity=VERBOSITY(PRINT_NORMAL)]", PRINT_ALWAYS) - call system_abort("Confused by CLI arguments") - end if - call finalise(cli_params) - - call print ("Using init args " // trim(init_args)) - call print ("Using calc args " // trim(calc_args)) - - call Initialise(mpi_glob) - - call read(at, at_file, mpi=mpi_glob) - call Potential_Filename_Initialise(pot, init_args, param_file, mpi_obj=mpi_glob) - - select case(verbosity) - case ("NORMAL") - call verbosity_push(PRINT_NORMAL) - case ("VERBOSE") - call verbosity_push(PRINT_VERBOSE) - case ("NERD") - call verbosity_push(PRINT_NERD) - case ("ANALYSIS") - call verbosity_push(PRINT_ANALYSIS) - case default - call system_abort("confused by verbosity " // trim(verbosity)) - end select - - call set_cutoff(at, cutoff(pot)+0.5_dp) - call calc_connect(at) - - - call calc(pot, at, energy = E0, args_str = calc_args) - - allocate(local_E_p(at%N)) - allocate(local_E_m(at%N)) - allocate(local_N_p(at%N)) - allocate(local_N_m(at%N)) - - call add_property(at, 'local_E_fd', 0.0_dp) - call add_property(at, 'local_N', 0.0_dp) - call add_property(at, 'local_N_fd', 0.0_dp) - - p0 = at%pos(:,fd_index) - - at%pos(:,fd_index) = p0 + fd_vec - call calc_connect(at) - call calc(pot, at, local_energy = local_E_p, args_str = trim(calc_args) // " do_at_local_N") - if (.not. assign_pointer(at, "local_N", local_N)) & - call system_abort("Impossible: Failed to assign pointer for local_N") - local_N_p = local_N - - at%pos(:,fd_index) = p0 - fd_vec - call calc_connect(at) - call calc(pot, at, local_energy = local_E_m, args_str = trim(calc_args) // " do_at_local_N") - if (.not. assign_pointer(at, "local_N", local_N)) & - call system_abort("Impossible: Failed to assign pointer for local_N") - local_N_m = local_N - - if (.not. assign_pointer(at, 'local_E_fd', local_E_fd)) & - call system_abort("Impossible failure to assign pointer for local_E_fd") - if (.not. assign_pointer(at, 'local_N_fd', local_N_fd)) & - call system_abort("Impossible failure to assign pointer for local_N_fd") - - local_E_fd = (local_E_p-local_E_m)/(2.0_dp*norm(fd_vec)) - local_N_fd = (local_N_p-local_N_m)/(2.0_dp*norm(fd_vec)) - - call write(at, "stdout", prefix="LOCAL_E_FD") - - call system_finalise() - stop - -end program diff --git a/src/Programs/local_random_search.f95 b/src/Programs/local_random_search.f95 deleted file mode 100644 index 482a4deddc..0000000000 --- a/src/Programs/local_random_search.f95 +++ /dev/null @@ -1,300 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -!%%%%%%%%%%%%%%%%%% custom fast LJ -module mylj -use libAtoms_module - -implicit none - -contains - -pure function lj(x, data) - real(dp), intent(in) :: x(:) - character,optional, intent(in)::data(:) - real(dp) :: lj - real(dp) r2, tmp - integer i,j - - lj = 0.0_dp - - do i=1,size(x)/3 - do j=i+1,size(x)/3 - r2 = sum((x((i-1)*3+1:(i-1)*3+3)-x((j-1)*3+1:(j-1)*3+3))**2) - tmp = (1/r2)**3 - lj = lj+tmp*tmp-tmp - end do - end do -end function lj - -pure function dlj(x, data) - real(dp), intent(in) :: x(:) - character,optional, intent(in)::data(:) - real(dp) :: dlj(size(x)) - real(dp) r2, tmp, dr(3), r - integer i,j - - - dlj = 0.0_dp - - do i=1,size(x)/3 - do j=i+1,size(x)/3 - r2 = sum((x((i-1)*3+1:(i-1)*3+3)-x((j-1)*3+1:(j-1)*3+3))**2) - r = sqrt(r2) - dr = (x((i-1)*3+1:(i-1)*3+3)-x((j-1)*3+1:(j-1)*3+3))/r - tmp = (1/r2)**3 - dlj((i-1)*3+1:(i-1)*3+3) = dlj((i-1)*3+1:(i-1)*3+3)+(-12.0_dp*tmp*tmp+6.0_dp*tmp)/r*dr - dlj((j-1)*3+1:(j-1)*3+3) = dlj((j-1)*3+1:(j-1)*3+3)-(-12.0_dp*tmp*tmp+6.0_dp*tmp)/r*dr - end do - end do - -end function dlj - -pure function elj(x) - real(dp), intent(in) :: x(:) - real(dp) :: elj(size(x)/3) - real(dp) r2, tmp - integer i,j - - elj = 0.0_dp - - do i=1,size(x)/3 - do j=1,size(x)/3 - if(i==j) cycle - r2 = sum((x((i-1)*3+1:(i-1)*3+3)-x((j-1)*3+1:(j-1)*3+3))**2) - tmp = (1/r2)**3 - elj(i) = elj(i)+0.5*(tmp*tmp-tmp) - end do - end do -end function elj - - - -end module mylj -!%%%%%%%%%%%%%%%%%% end of custom fast LJ - -program local_random_search - -use libAtoms_module -use Potential_module -use mylj - -implicit none - - type(Potential) mpot - type(inoutput) params - type(cinoutput) movie - type(Atoms), target:: at - - - integer, parameter :: N = 13 - real, parameter :: SIGMA = 2.35_dp - - real(dp) :: r(3), r0(3), etmp(N), e(N), v, eold, rr - real(dp), pointer :: atlocale(:) - real(dp), allocatable :: x(:), x0(:), rrr(:) - logical :: allok, status - integer :: i, jj, j, k, niter, count, nrand, idx(N) - - - - call system_initialise() - -! call Initialise(params, "quip_params.xml") -! call Initialise(mpot, 'IP LJ', params) -! call Initialise(mpot, 'IP LJ', '') - - call Initialise(mpot, 'FilePot command=./castep_driver.sh') - - call initialise(at, N, reshape((/10.0_dp,0.0_dp,0.0_dp,0.0_dp,10.0_dp,0.0_dp,0.0_dp,0.0_dp, 10.0_dp/), (/3,3/))) - call set_cutoff(at, cutoff(mpot)+0.2) - call initialise(movie, 'movie.xyz', OUTPUT) - call set_atoms(at, 14) - - call add_property(at, "local_e", 0.0_dp); - status = assign_pointer(at, 'local_e', atlocale) - - - allocate(x(N*3), x0(N*3), rrr(N*3)) - - do k=1,1000 - - call random_initial_pos_chris(at, 5.0_dp) - - ! TIMING TEST - - !x = reshape(at%pos, (/at%N*3/)) - !eold = 0.0_dp - !do i=1,1000000 - ! !call random_number(rrr) - ! !call randomise(x, 1e-6_dp) - ! x = x + 1.0e-10_dp - ! eold = eold+lj(x) - !end do - !call print(eold) - !stop - - - !x0 = reshape(at%pos, (/at%N*3/)) - !atlocale = elj(x0) - !call print_xyz(at, movie, ('ljenergy='//sum(atlocale)), all_properties=.true.) - - do i=1,10 -! niter = minim(mpot, at, 'cg', 1.0e-10_dp, 5000, & -! do_pos=.true., do_print=.false., print_inoutput=movie) -! call calc_connect(at) -! call calc(mpot, at, local_energy=atlocale) - - !x = x0 - !niter = minim(x, lj, dlj, 'cg', 1.0e-10_dp, 5000) - !call print('Relaxation finished after '//niter//' iterations') - !atlocale = elj(x) - !at%pos = reshape(x, (/3,at%N/)) - !call print_xyz(at, movie, ('comment="quipcg" Energy='//sum(atlocale)), all_properties=.true.) - - - !at%pos = reshape(x0, (/3,at%N/)) - - call Calc(mpot, at, energy=eold) - call read(at, 'filepot.0.out') - call zero_sum(at%pos) - call add_property(at, "local_e", 0.0_dp); - status = assign_pointer(at, 'local_e', atlocale) - x = reshape(at%pos, (/at%N*3/)) - atlocale = elj(x) - call set_value(at%properties, "comment", "castepbfgs") - call set_value(at%properties, "ljenergy", sum(atlocale)) - call write(at, movie) - - !r = 0 - !call randomise(r, 0.7_dp) - !at%pos(:,maxloc(e)) = at%pos(:,maxloc(e)) + r - - - !do j=1,N - ! if(e(j) > minv+(maxv-minv)*0.7) then - ! r = 0 - ! call randomise(r, 1.0_dp) - ! at%pos(:,maxloc(e)) = at%pos(:,maxloc(e)) + r - ! end if - !end do - - !find highest energy atoms - etmp = elj(x) - idx = (/ (i, i=1,size(etmp)) /) - call sort_array(etmp, i_data=idx) - rr = 3.0_dp ! randomize by max this amount - - do j=1,1 - jj = idx(N-j+1) - call print('Randomising '//jj) - r0 = x((jj-1)*3+1:(jj-1)*3+3) - atlocale(jj) = 1.0_dp - do while (atlocale(jj) > 0.0_dp) - r = 0 - call randomise(r, rr) - x((jj-1)*3+1:(jj-1)*3+3) = r0 + r - atlocale = elj(x) - end do - enddo - - at%pos = reshape(x, (/3,at%N/)) - - - end do - end do - - call system_finalise() - -contains - -subroutine random_initial_pos(at, rad) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: rad - logical :: bad - real(dp), allocatable :: x(:) - real(dp), pointer :: atlocale(:) - integer :: i - - allocate(x(at%N*3)) - - at%pos = 0.0_dp - call randomise(at%pos, rad) - ! at%pos = at%pos+50.0_dp - - bad = .true. - do while(bad) - x = reshape(at%pos, (/at%N*3/)) - atlocale = elj(x) - ! call calc(mpot, at, local_energy=e) - call print (atlocale) - bad = .false. - do i=1,at%N - if(atlocale(i) > 10.0_dp) then - call randomise(at%pos(:,i), 2.0_dp) - bad = .true. - end if - end do - end do - -end subroutine random_initial_pos - -subroutine random_initial_pos_chris(at, rad) - type(Atoms), intent(inout) :: at - real(dp), intent(in) :: rad - logical :: bad - real(dp) :: cut - - cut = rad/(real(at%N)**0.3333333_dp)*0.6_dp - - at%pos = 0.0_dp - do i=1,at%N - bad = .true. - do while(bad) - r = 0.0_dp - call randomise(r, rad) - if(norm(r) > rad) then - bad = .true. - cycle - end if - - bad = .false. - do j=1,i-1 - if(norm(at%pos(:,j)-r) < cut) bad = .true. - end do - end do - at%pos(:,i) = r - end do - -end subroutine random_initial_pos_chris - -end program local_random_search - - diff --git a/src/Programs/mark_hybrid.f95 b/src/Programs/mark_hybrid.f95 deleted file mode 100644 index 7059bd41b9..0000000000 --- a/src/Programs/mark_hybrid.f95 +++ /dev/null @@ -1,112 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program test -use libatoms_module -use potential_module -use vacancy_map_module - -implicit none - type(Atoms) at - - type(Dictionary) :: cli_params - real(dp) :: sphere_qm_center(3), sphere_qm_rad - real(dp) :: cyl_qm_center(3), cyl_qm_vec(3), cyl_qm_rad - integer :: qm_hops, buffer_hops, transition_hops - type(Table) :: core_list - real(dp) :: r2, dr(3) - integer, pointer :: hybrid_mark(:) - integer :: i - - call system_initialise(enable_timing=.true.,verbosity=PRINT_SILENT) - - call initialise(cli_params) - call param_register(cli_params, "buffer_hops", "1", buffer_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "transition_hops", "1", transition_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "qm_hops", "0", qm_hops, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "sphere_qm_center", "0 0 0", sphere_qm_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "sphere_qm_rad", "0", sphere_qm_rad, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "cyl_qm_center", "0 0 0", cyl_qm_center, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "cyl_qm_vec", "0 0 1", cyl_qm_vec, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "cyl_qm_rad", "0", cyl_qm_rad, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - call print("Usage: vacancy_map_hybrid_generate [buffer_hops=i(1)] [transition_hops=i(1)]", PRINT_ALWAYS) - call print(" [qm_hops=i(1)] sphere_qm_center={x y z}(0 0 0) sphere_qm_rad=r(1)", PRINT_ALWAYS) - call print(" cyl_qm_center={x y z}(0 0 0) cyl_qm_vec={x y z}(0 0 0) cyl_qm_rad=r(1)", PRINT_ALWAYS) - call system_abort("Confused by CLI arguments") - end if - call finalise(cli_params) - - call print("Using buffer_hops " // buffer_hops // " transition_hops " // transition_hops // " qm_hops " // qm_hops) - call print("Using sphere_qm_center " // sphere_qm_center // " qm_rad " // sphere_qm_rad) - call print("Using cyl_qm_center " // cyl_qm_center // " cyl_qm_vec " // cyl_qm_vec // " cyl_qm_rad " // cyl_qm_rad) - - ! read initial config - call read_xyz(at, "stdin") - call set_cutoff(at, 3.2_dp) - call calc_connect(at) - - call add_property(at, 'hybrid_mark', 0) - call add_property(at, 'weight_region1', 0.0_dp) - - if (.not. assign_pointer(at, 'hybrid_mark', hybrid_mark)) & - call system_abort("Couldn't find hybrid_mark in at") - - ! core qm region - call wipe(core_list) - cyl_qm_vec = cyl_qm_vec / norm(cyl_qm_vec) - do i=1,at%N - if (sphere_qm_rad > 0) then - r2 = sum(((at%pos(:,i)-sphere_qm_center)/sphere_qm_rad)**2) - if (r2 < 1.0_dp) call append(core_list, (/i, 0, 0 ,0/)) - endif - if (cyl_qm_rad > 0) then - dr = at%pos(:,i) - cyl_qm_center - dr = dr - cyl_qm_vec*(cyl_qm_vec .dot. dr) - r2 = sum((dr/cyl_qm_rad)**2) - if (r2 < 1.0_dp) call append(core_list, (/i, 0, 0 ,0/)) - endif - end do - - if (qm_hops > 0) call bfs_grow(at, core_list, qm_hops, nneighb_only = .false.) - - call print(core_list, PRINT_VERBOSE) - - hybrid_mark = HYBRID_NO_MARK - hybrid_mark(int_part(core_list, 1)) = HYBRID_ACTIVE_MARK - - call create_local_energy_weights(at, transition_hops, buffer_hops) ! trans_width, buffer_width - - call verbosity_push(PRINT_NORMAL) - call print_xyz(at, mainlog, properties="pos:Z:hybrid_mark:weight_region1") - call verbosity_pop() - - call system_finalise() -end program diff --git a/src/Programs/md.f95 b/src/Programs/md.f95 deleted file mode 100644 index 3c1dd760f5..0000000000 --- a/src/Programs/md.f95 +++ /dev/null @@ -1,1001 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" -module md_module -use libatoms_module -use potential_module -implicit none -private - - public :: md_params - type md_params - character(len=STRING_LENGTH) :: atoms_filename, param_filename, trajectory_filename, flux_filename - integer :: N_steps - real(dp) :: max_time - real(dp) :: dt, T_increment_time, damping_tau - real(dp) :: T_initial, T_cur, T_hold, T_slope, T_increment, langevin_tau, adaptive_langevin_NH_tau, p_ext, barostat_tau, nose_hoover_tau, barostat_mass_factor, barostat_timescale_T - logical :: hydrostatic_strain, diagonal_strain, finite_strain_formulation - logical :: langevin_OU - real(dp) :: cutoff_skin - integer :: velocity_rescaling_freq - logical :: calc_virial, calc_energy, const_T, const_P, all_purpose_thermostat, all_purpose_thermostat_massive, nose_hoover_thermostat, barostat_const_T - real(dp) :: all_purpose_thermostat_NHL_tau, all_purpose_thermostat_NHL_NH_tau - character(len=STRING_LENGTH) :: pot_init_args, pot_calc_args, first_pot_calc_args - integer :: summary_interval, params_print_interval, trajectory_print_interval, pot_print_interval - real(dp) :: flux_print_interval - real(dp) :: extra_calc_interval - character(len=STRING_LENGTH), allocatable :: print_property_list(:) - integer :: rng_seed - logical :: damping, rescale_initial_velocity - logical :: calc_local_ke - real(dp) :: rescale_initial_velocity_T - logical :: variable_T, zero_momentum, zero_angular_momentum - logical :: quiet_calc, do_timing - integer :: advance_md_substeps - logical :: v_dep_quants_extra_calc - real(dp) :: extra_heat - logical :: continuation - logical :: use_fortran_random - character(len=STRING_LENGTH) :: verbosity - logical :: netcdf4 - real(dp):: avgtime - logical :: NPT_NB - logical :: print_restraints - end type md_params - -public :: get_params, print_params, do_prints, initialise_md_thermostat, update_md_thermostat - -integer, parameter, public :: uflux = 110 - -contains - -subroutine get_params(params, mpi_glob) - type(md_params), intent(inout) :: params - type(MPI_context), intent(inout) :: mpi_glob - - type(Dictionary) :: md_params_dict - type(Extendable_Str) :: es - logical :: md_params_exist - character(len=STRING_LENGTH) :: print_property_list_str - integer :: n_print_property_list - logical :: has_N_steps - logical p_ext_is_present - - type(MPI_Context) :: mpi_loc - integer :: n_procs_per_task, n_param_strings - character(len=10240) :: param_strings(64) - - call initialise(md_params_dict) - call param_register(md_params_dict, 'atoms_filename', 'stdin', params%atoms_filename, help_string="Initial atomic data file name") - call param_register(md_params_dict, 'trajectory_filename', 'traj.xyz', params%trajectory_filename, help_string="Trajectory output file name ") - call param_register(md_params_dict, 'param_filename', 'quip_params.xml', params%param_filename, help_string="QUIP XML parameter file name") - call param_register(md_params_dict, 'flux_filename', 'flux.dat', params%flux_filename, help_string="Name of output file for heat flux") - call param_register(md_params_dict, 'rng_seed', '-1', params%rng_seed, help_string="Random seed") - call param_register(md_params_dict, 'N_steps', '1', params%N_steps, has_value_target=has_N_steps, help_string="Number of MD steps to perform") - call param_register(md_params_dict, 'max_time', '-1.0', params%max_time, help_string="Maximum simulation time (femtoseconds)") - call param_register(md_params_dict, 'dt', '1.0', params%dt, help_string="Time step of the verlet iteration (femtoseconds)") - call param_register(md_params_dict, 'avgtime', '100.0', params%avgtime, help_string="time constant used to calculate running average of positions") - call param_register(md_params_dict, 'all_purpose_thermostat', 'F', params%all_purpose_thermostat, help_string="if true, use new all purpose thermostat") - call param_register(md_params_dict, 'all_purpose_thermostat_massive', 'F', params%all_purpose_thermostat_massive, help_string="if true, use massive N-H in all purpose thermostat") - call param_register(md_params_dict, 'all_purpose_thermostat_NHL_tau', '0.0', params%all_purpose_thermostat_NHL_tau, help_string="tau of Langevin part of NHL in all purpose thermostat") - call param_register(md_params_dict, 'all_purpose_thermostat_NHL_NH_tau', '0.0', params%all_purpose_thermostat_NHL_NH_tau, help_string="tau of N-H part of NHL in all purpose thermostat") - call param_register(md_params_dict, 'nose_hoover_thermostat', 'F', params%nose_hoover_thermostat, help_string="if true, use new plain Nose Hoover for const T") - call param_register(md_params_dict, 'barostat_const_T', 'T', params%barostat_const_T, help_string="if true and running const_T, thermalize barostat for const T") - call param_register(md_params_dict, 'barostat_timescale_T', '-1.0', params%barostat_timescale_T, help_string="T used to set barostat timescale when barostat_const_T=F") - ! call param_register(md_params_dict, 'const_T', 'F', params%const_T, help_string="if true, do constant T, set automatically when T >= 0.0") - ! call param_register(md_params_dict, 'const_P', 'F', params%const_P, help_string="is true, do constant P") - ! call param_register(md_params_dict, 'variable_T', 'F', params%variable_T, help_string="set automatically when T_final >= 0") - call param_register(md_params_dict, 'T', '-1.0', params%T_initial, help_string="Initial simulation temperature (Kelvin), enables const_T if >= 0.0") - call param_register(md_params_dict, 'T_hold', '-1.0', params%T_hold, help_string="Simulation temperature at end of ramp stage (enables variable_T if >= 0.0)") - call param_register(md_params_dict, 'T_slope', '0.01', params%T_slope, help_string="Temperature slope for ramp stage of variable_T") - call param_register(md_params_dict, 'T_increment_time', '10.0', params%T_increment_time, help_string="time to wait between increments of T") - call param_register(md_params_dict, 'p_ext', '0.0', params%p_ext, help_string="External pressure (GPa), enables const_P if set explicitly", has_value_target=p_ext_is_present) - call param_register(md_params_dict, 'hydrostatic_strain', 'T', params%hydrostatic_strain, help_string="If true, and using all purpose thermostat/barostat, force hydrostatic strain only") - call param_register(md_params_dict, 'diagonal_strain', 'T', params%diagonal_strain, help_string="If true, and using all purpose thermostat/barostat, force diagonal strain only") - call param_register(md_params_dict, 'finite_strain_formulation', 'F', params%finite_strain_formulation, help_string="If true, use finite strain formulation from Tadmor & Miller book") -call param_register(md_params_dict, 'NPT_NB', 'F', params%NPT_NB, help_string="use NPT_NB algorithm for constant P") - call param_register(md_params_dict, 'damping', 'F', params%damping, help_string="if true, do damping") - call param_register(md_params_dict, 'damping_tau', '10.0', params%damping_tau, help_string="time constant for damped MD") - call param_register(md_params_dict, 'rescale_initial_velocity', 'F', params%rescale_initial_velocity, help_string="if true, rescale initial velocity so T=rescale_initial_velocity_T") - call param_register(md_params_dict, 'rescale_initial_velocity_T', '-1.0', params%rescale_initial_velocity_T, help_string="T for rescale_initial_velocity") - call param_register(md_params_dict, 'langevin_tau', '100.0', params%langevin_tau, help_string="time constant for Langevin thermostat") - call param_register(md_params_dict, 'nose_hoover_tau', '100.0', params%nose_hoover_tau, help_string="time constant for nose_hoover thermostat") - call param_register(md_params_dict, 'adaptive_langevin_NH_tau', '0.0', params%adaptive_langevin_NH_tau, help_string="tau for Nose-Hoover part of open Langevin thermostat, active if > 0") - call param_register(md_params_dict, 'barostat_tau', '10.0', params%barostat_tau, help_string="time constant for barostat Langevin") - call param_register(md_params_dict, 'barostat_mass_factor', '1.0', params%barostat_mass_factor, help_string="factor to multiply barostat mass by, if default leads to overly fast dynamics") - call param_register(md_params_dict, 'langevin_OU', 'F', params%langevin_OU, help_string="If true, do Ornstein-Uhlenbeck Langevin dynamics") - call param_register(md_params_dict, 'calc_virial', 'F', params%calc_virial, help_string="if true, calculate virial each step") - call param_register(md_params_dict, 'calc_energy', 'T', params%calc_energy, help_string="if true, calculate energy each step") - call param_register(md_params_dict, 'pot_init_args', "", params%pot_init_args, help_string="args string to initialise potential") - call param_register(md_params_dict, 'cutoff_skin', '0.5', params%cutoff_skin, help_string="extra distance to calculate neighbors (added to potential cutoff) so that list doesn't have to be recalculated every step") - call param_register(md_params_dict, 'summary_interval', '1', params%summary_interval, help_string="how often to print summary line") - call param_register(md_params_dict, 'params_print_interval', '-1', params%params_print_interval, help_string="how often to print atoms%params") - call param_register(md_params_dict, 'trajectory_print_interval', '100', params%trajectory_print_interval, help_string="how often to print atomic config to traj file") - call param_register(md_params_dict, 'flux_print_interval', '-1', params%flux_print_interval, help_string="how often to print heat flux (fs)") - call param_register(md_params_dict, 'extra_calc_interval', '-1.0', params%extra_calc_interval, help_string="how often to do extra calcs (e.g. flux)") - call param_register(md_params_dict, 'print_property_list', '', print_property_list_str, help_string="list of properties to print for atoms") - call param_register(md_params_dict, 'pot_print_interval', '-1', params%pot_print_interval, help_string="how often to print potential object") - call param_register(md_params_dict, 'zero_momentum', 'F', params%zero_momentum, help_string="zero total momentum before starting") - call param_register(md_params_dict, 'zero_angular_momentum', 'F', params%zero_angular_momentum, help_string="zero total angular momentum (about CoM) before starting") - call param_register(md_params_dict, 'pot_calc_args', '', params%pot_calc_args, help_string="args string for potential calc") - call param_register(md_params_dict, 'first_pot_calc_args', '', params%first_pot_calc_args, help_string="args string for first potential calc") - call param_register(md_params_dict, 'quiet_calc', 'T', params%quiet_calc, help_string="do calc() quietly") - call param_register(md_params_dict, 'do_timing', 'F', params%do_timing, help_string="if true, do timing") - call param_register(md_params_dict, 'advance_md_substeps', '-1', params%advance_md_substeps, help_string="how many actual MD steps for each apparent steps, for things like hybrid MC") - call param_register(md_params_dict, 'v_dep_quants_extra_calc', 'F', params%v_dep_quants_extra_calc, help_string="do extra call to calc for velocity dependent quantities (like heat flux)") - call param_register(md_params_dict, 'continuation', 'F', params%continuation, help_string="if true, this is a continuation of an old run, read initial time and i_step from input config") - call param_register(md_params_dict, 'extra_heat', '0.0', params%extra_heat, help_string="If > 0, add extra heating of this magnitude to atoms with field extra_heat_mask /= 0, for testing thermostats") - call param_register(md_params_dict, 'use_fortran_random', 'F', params%use_fortran_random, help_string="if true, use fortran builtin random_number() routine") - call param_register(md_params_dict, 'verbosity', 'NORMAL', params%verbosity, help_string="verbosity level of run") - call param_register(md_params_dict, 'calc_local_ke', 'F', params%calc_local_ke, help_string="if true, calculate local ke") - call param_register(md_params_dict, 'netcdf4', 'F', params%netcdf4, help_string="if true, write trajectories in NetCDF4 (HDF5, compressed) format") - call param_register(md_params_dict, 'print_restraints', 'F', params%print_restraints, help_string="if true, print restraint stuff for PMF sampling") - - inquire(file='md_params', exist=md_params_exist) - if (md_params_exist) then - call print("WARNING: md reading parameters from 'md_params' file, ignoring anything on command line", PRINT_ALWAYS) - call initialise(es) - call read(es, 'md_params', convert_to_string=.true., mpi_comm=mpi_glob%communicator, mpi_id=mpi_glob%my_proc) - if (any(es%s(1:es%len) == '^')) then ! multiple independent runs - call split_string_simple(string(es), param_strings, n_param_strings, '^') - if (mpi_glob%my_proc == 0) call print ("Multiple runs " // n_param_strings) - n_procs_per_task=mpi_glob%n_procs/n_param_strings - call split_context(mpi_glob, mpi_glob%my_proc/n_procs_per_task, mpi_loc) - es = param_strings(mpi_glob%my_proc/n_procs_per_task+1) - mpi_glob = mpi_loc - endif - if (.not. param_read_line(md_params_dict, string(es))) then - call param_print_help(md_params_dict) - call system_abort("Error reading params from md_params file") - endif - call finalise(es) - else - if (.not. param_read_args(md_params_dict)) then - call param_print_help(md_params_dict) - call system_abort("Error reading params from command line") - endif - end if - - call finalise(md_params_dict) - - params%const_P = .false. - params%const_T = .false. - params%variable_T = .false. - if (p_ext_is_present) params%const_P = .true. - if (params%T_initial >= 0.0_dp) params%const_T = .true. - if (params%T_hold >= 0.0_dp) params%variable_T = .true. - - system_use_fortran_random = params%use_fortran_random - - if (len_trim(params%first_pot_calc_args) == 0) params%first_pot_calc_args = params%pot_calc_args - - - if (has_N_steps .and. params%N_steps >= 0 .and. params%max_time > 0.0_dp) then - call system_abort("get_params got both N_steps="//params%N_steps//" >= 0 and max_time="//params%max_time//" > 0.0") - endif - if (params%max_time <= 0.0_dp .and. params%N_steps < 0) call system_abort("get_params got max_time="//params%max_time//" <= 0.0 and N_steps=" // params%N_steps // " < 0") - if (params%dt <= 0.0_dp) call system_abort("get_params got dt " // params%dt // " <= 0.0") - if (params%rescale_initial_velocity .and. params%rescale_initial_velocity_T < 0.0_dp) then - call system_abort("Got rescale_initial_velocity, but rescale_initial_velocity_T="//params%rescale_initial_velocity_T//" < 0.0") - endif - if (params%const_T) then - if (params%langevin_tau <= 0.0_dp .and. params%adaptive_langevin_NH_tau <= 0.0_dp) & - call system_abort("get_params got const_T, but langevin_tau=" // params%langevin_tau // " and adaptive_langevin_NH_tau="//params%adaptive_langevin_NH_tau//" <= 0.0") - endif - - if (len_trim(print_property_list_str) > 0) then - allocate(params%print_property_list(500)) - call split_string_simple(trim(print_property_list_str), params%print_property_list, n_print_property_list, ':') - deallocate(params%print_property_list) - allocate(params%print_property_list(n_print_property_list)) - call split_string_simple(trim(print_property_list_str), params%print_property_list, n_print_property_list, ':') - else - if (allocated(params%print_property_list)) deallocate(params%print_property_list) - endif - - params%T_cur = params%T_initial - params%T_increment = params%T_slope * params%T_increment_time - -end subroutine get_params - -subroutine print_params(params) - type(md_params), intent(in) :: params - - integer :: i - - call print("md_params%pot_init_args='" // trim(params%pot_init_args) // "'") - call print("md_params%pot_calc_args='" // trim(params%pot_calc_args) // "'") - call print("md_params%first_pot_calc_args='" // trim(params%first_pot_calc_args) // "'") - call print("md_params%atoms_filename='" // trim(params%atoms_filename) // "'") - call print("md_params%param_filename='" // trim(params%param_filename) // "'") - call print("md_params%trajectory_filename='" // trim(params%trajectory_filename) // "'") - call print("md_params%flux_filename='" // trim(params%flux_filename) // "'") - call print("md_params%cutoff_skin='" // params%cutoff_skin // "'") - call print("md_params%rng_seed=" // params%rng_seed) - call print("md_params%N_steps=" // params%N_steps) - call print("md_params%max_time=" // params%max_time) - call print("md_params%dt=" // params%dt) - - call print("md_params%all_purpose_thermostat=" // params%all_purpose_thermostat) - call print("md_params%all_purpose_thermostat_massive=" // params%all_purpose_thermostat_massive) - call print("md_params%const_T=" // params%const_T) - if (params%const_T) then - call print("md_params%T_initial=" // params%T_initial) - call print("md_params%T_hold=" // params%T_hold) - if (params%T_hold >= 0.0_dp) then - call print("md_params%T_slope=" // params%T_slope) - call print("md_params%T_increment=" // params%T_increment) - call print("md_params%T_increment_time=" // params%T_increment_time) - endif - call print("md_params%langevin_OU=" // params%langevin_OU) - call print("md_params%langevin_tau=" // params%langevin_tau) - call print("md_params%adaptive_langevin_NH_tau=" // params%adaptive_langevin_NH_tau) - end if - call print("md_params%rescale_initial_velocity=" // params%rescale_initial_velocity) - call print("md_params%rescale_initial_velocity_T=" // params%rescale_initial_velocity_T) - call print("md_params%variable_T=" // params%variable_T) - call print("md_params%damping=" // params%damping) - if(params%damping) then - call print("md_params%damping_tau=" // params%damping_tau) - endif - - call print("md_params%const_P=" // params%const_P) - call print("md_params%p_ext=" // params%p_ext) - call print("md_params%hydrostatic_strain=" // params%hydrostatic_strain) - call print("md_params%diagonal_strain=" // params%diagonal_strain) - call print("md_params%finite_strain_formulation=" // params%finite_strain_formulation) - call print("md_params%barostat_tau=" // params%barostat_tau) - call print("md_params%barostat_const_T=" // params%barostat_const_T) - call print("md_params%barostat_timescale_T=" // params%barostat_timescale_T) - call print("md_params%barostat_mass_factor=" // params%barostat_mass_factor) - - call print("md_params%calc_virial=" // params%calc_virial) - call print("md_params%calc_energy=" // params%calc_energy) - call print("md_params%summary_interval=" // params%summary_interval) - call print("md_params%params_print_interval=" // params%params_print_interval) - call print("md_params%trajectory_print_interval=" // params%trajectory_print_interval) - call print("md_params%flux_print_interval=" // params%flux_print_interval) - call print("md_params%print_property_list=", nocr=.true.) - if (allocated(params%print_property_list)) then - if (size(params%print_property_list) > 0) then - call print(trim(params%print_property_list(1)), nocr=.true.) - do i=2, size(params%print_property_list) - call print(":"//trim(params%print_property_list(i)), nocr=.true.) - end do - endif - endif - call print("", nocr=.false.) - call print("md_params%pot_print_interval=" // params%pot_print_interval) - call print("md_params%zero_momentum=" // params%zero_momentum) - call print("md_params%zero_angular_momentum=" // params%zero_angular_momentum) - call print("md_params%quiet_calc=" // params%quiet_calc) - call print("md_params%do_timing=" // params%do_timing) - call print("md_params%advance_md_substeps=" // params%advance_md_substeps) - call print("md_params%v_dep_quants_extra_calc=" // params%v_dep_quants_extra_calc) - call print("md_params%extra_calc_interval=" // params%extra_calc_interval) - call print("md_params%extra_heat=" // params%extra_heat) - call print("md_params%continuation=" // params%continuation) - call print("md_params%calc_local_ke=" // params%calc_local_ke) - call print("md_params%print_restraints=" // params%print_restraints) -end subroutine print_params - -subroutine print_usage() - call Print('Usage: md ', PRINT_ALWAYS) - call Print('available parameters (in md_params file or on command line):', PRINT_ALWAYS) - call Print(' [pot_init_args="args"] [pot_calc_args="args"] [first_pot_calc_args="args"]', PRINT_ALWAYS) - call Print(' [atoms_filename=file(stdin)] [param_filename=file(quip_params.xml)]', PRINT_ALWAYS) - call Print(' [trajectory_filename=file(traj.xyz)] [cutoff_skin=(0.5)] [rng_seed=n(none)]', PRINT_ALWAYS) - call Print(' [N_steps=n(1)] [max_time=t(-1.0)] [dt=dt(1.0)] [const_T=logical(F)] [T=T(0.0)] [langevin_tau=tau(100.0)]', PRINT_ALWAYS) - call Print(' [calc_virial=logical(F)]', PRINT_ALWAYS) - call Print(' [summary_interval=n(1)] [params_print_interval=n(-1)] [trajectory_print_interval=n(100)]', PRINT_ALWAYS) - call Print(' [print_property_list=prop1:prop2:...()] [pot_print_interval=n(-1)]', PRINT_ALWAYS) - call Print(' [zero_momentum=T/F(F)] [zero_angular_momentum=T/F(F)]', PRINT_ALWAYS) - call Print(' [quiet_calc=T/F(T)] [do_timing=T/F(F)] [advance_md_substeps=N(-1)] [v_dep_quants_extra_calc=T/F(F)]', PRINT_ALWAYS) - call Print(' [extra_calc_interval=t(10.0) [continuation=T/F(F)]', PRINT_ALWAYS) -end subroutine print_usage - -subroutine do_prints(params, ds, e, pot, restraint_stuff, restraint_stuff_timeavg, traj_out, i_step, override_intervals) - type(md_params), intent(in) :: params - type(DynamicalSystem), intent(inout) :: ds - real(dp), intent(in) :: e - type(potential), intent(in) :: pot - real(dp), allocatable, intent(in) :: restraint_stuff(:,:), restraint_stuff_timeavg(:,:) - type(Cinoutput), optional, intent(inout) :: traj_out - integer, intent(in) :: i_step - logical, optional :: override_intervals - real(dp) :: flux(3), tprin - - logical my_override_intervals - integer at_i_step - - my_override_intervals = optional_default(.false., override_intervals) - - if (params%summary_interval > 0) then - if (my_override_intervals .or. mod(i_step,params%summary_interval) == 0) call print_summary(params, ds, e) - endif - if (params%print_restraints) then - if (allocated(restraint_stuff)) then - if (params%summary_interval > 0) then - if (my_override_intervals .or. mod(i_step, params%summary_interval) == 0) & - call print_restraint_stuff(params, ds, restraint_stuff, restraint_stuff_timeavg) - endif - endif - endif - - if (params%params_print_interval > 0) then - if (my_override_intervals .or. mod(i_step,params%params_print_interval) == 0) call print_atoms_params(params, ds%atoms) - endif - - if (params%pot_print_interval > 0) then - if (my_override_intervals .or. mod(i_step,params%pot_print_interval) == 0) call print_pot(params, pot) - endif - - if (params%trajectory_print_interval > 0) then - if (my_override_intervals .or. mod(i_step,params%trajectory_print_interval) == 0) & - call print_at(params, ds, e, pot, traj_out) - endif - - if (params%flux_print_interval > 0.0_dp) then - ! just a short alias - tprin = params%flux_print_interval - ! if the time is close to a - if (abs(modulo(ds%t + 0.5_dp*tprin, tprin) - 0.5_dp*tprin).le.1e-7) then - call get_param_value(ds%atoms, "flux", flux) - call get_param_value(ds%atoms, "i_step", at_i_step) - write (uflux,'(I12,F16.3,F12.4,3E24.12)') at_i_step, ds%t, temperature(ds,instantaneous=.true.), flux - end if - end if - -end subroutine do_prints - -subroutine print_restraint_stuff(params, ds, restraint_stuff, restraint_stuff_timeavg) - type(md_params), intent(in) :: params - type(DynamicalSystem), intent(in) :: ds - real(dp), intent(in) :: restraint_stuff(:,:), restraint_stuff_timeavg(:,:) - - logical, save :: firstcall = .true. - - if (firstcall) then - call print("#RI t target_v C E dE/dcoll dE/dk ....") - call print("#R t target_v C E dE/dcoll dE/dk ....") - firstcall = .false. - endif - call print("RI " // ds%t // " " // reshape( restraint_stuff, (/ size(restraint_stuff) /) )) - call print("R " // ds%t // " " // reshape( restraint_stuff_timeavg, (/ size(restraint_stuff_timeavg) /) )) -end subroutine - -subroutine print_summary(params, ds, e) - type(md_params), intent(in) :: params - type(DynamicalSystem), intent(inout) :: ds - real(dp), intent(in) :: e - - real(dp) :: mu(3), virial(3,3) - real(dp) :: lat0_inv(3,3), F(3,3), strain(3,3) - - if (params%extra_heat > 0.0_dp) then - call print("EH "//ds%t//" "//temperature(ds, property="extra_heat_mask", value=1, instantaneous=.true.)//" "//temperature(ds, property="extra_heat_mask", value=0, instantaneous=.true.)) - endif - call ds_print_status(ds, "STAT", e) - if (get_value(ds%atoms%params, 'Dipole_Moment', mu)) then - call print("MU " // ds%t // " " // mu) - endif - if (params%calc_virial) then - if (.not. get_value(ds%atoms%params, "orig_lattice_inv", lat0_inv)) then - call matrix3x3_inverse(ds%atoms%lattice, lat0_inv) - call set_value(ds%atoms%params, "orig_lattice_inv", lat0_inv) - endif - F = matmul(ds%atoms%lattice, lat0_inv) - strain = matmul(transpose(F),F) - strain(1,1) = strain(1,1) - 1.0_dp - strain(2,2) = strain(2,2) - 1.0_dp - strain(3,3) = strain(3,3) - 1.0_dp - strain = 0.5_dp*strain - call get_param_value(ds%atoms, "virial", virial) - call print("STRESS " // ds%t // " " // (reshape(virial+ds%Wkin,(/9/))/cell_volume(ds%atoms)*EV_A3_IN_GPA) // " GPa "//& - "VOL " // cell_volume(ds%atoms)// " A^3 "// & - "STRAIN "//reshape(strain, (/9/))) - endif - -end subroutine print_summary - -subroutine print_atoms_params(params, at) - type(md_params), intent(in) :: params - type(Atoms), intent(in) :: at - call print("PA " // write_string(at%params, real_format='f18.10')) -end subroutine print_atoms_params - -subroutine print_pot(params, pot) - type(md_params), intent(in) :: params - type(potential), intent(in) :: pot - - mainlog%prefix="MD_POT" -#ifdef HAVE_TB - if (pot%is_simple) then - if (associated(pot%simple%tb)) then - call print(pot%simple%tb) - endif - endif -#endif - mainlog%prefix="" -end subroutine print_pot - -subroutine print_at(params, ds, e, pot, out) - type(md_params), intent(in) :: params - type(DynamicalSystem), intent(inout) :: ds - real(dp), intent(in) :: e - type(Potential), intent(in) :: pot - type(CInOutput), intent(inout) :: out - - real(dp) :: ke - - if (params%calc_local_ke) then - if (.not. has_property(ds%atoms, 'local_ke')) then - call add_property(ds%atoms, 'local_ke', 0.0_dp, n_cols=1) - endif - ke = kinetic_energy(ds, local_ke=.true.) - endif - - if (allocated(params%print_property_list)) then - call write(out, ds%atoms, properties_array=params%print_property_list, real_format='%26.18f') - else - call write(out, ds%atoms, real_format='%26.18f') - endif - !call print_xyz(ds%atoms, out, all_properties=.true., comment="t="//ds%t//" e="//(kinetic_energy(ds)+e), real_format='f18.10') -end subroutine print_at - -subroutine initialise_md_thermostat(ds, params) - type(md_params), intent(inout) :: params - type(DynamicalSystem), intent(inout) :: ds - - params%T_increment = sign(params%T_increment, params%T_hold-params%T_initial) - params%variable_T = params%T_hold >= 0.0_dp - - if(params%rescale_initial_velocity) then - call print('Rescaling initial velocities to T='//params%rescale_initial_velocity_T) - call rescale_velo(ds, params%rescale_initial_velocity_T, mass_weighted=.true., zero_L=params%zero_angular_momentum) - endif - - params%T_cur = cur_temp(params, ds%t) - - if (params%damping) then - call print('MD damping') - call enable_damping(ds, params%damping_tau) - else if (params%const_T .or. params%const_P) then - if (params%const_P) then - if (.not.params%calc_virial) then - params%calc_virial = .true. - call print('WARNING: Doing const P, setting calc_virial option to true') - endif - endif - - if (params%all_purpose_thermostat) then - if (params%const_P) then - if (params%const_T .and. params%barostat_const_T) then - call set_barostat(ds, type=BAROSTAT_HOOVER_LANGEVIN, p_ext=params%p_ext/EV_A3_IN_GPA, hydrostatic_strain=params%hydrostatic_strain, & - diagonal_strain=params%diagonal_strain, finite_strain_formulation=params%finite_strain_formulation, tau_epsilon=params%barostat_tau, T=params%T_cur, W_epsilon_factor=params%barostat_mass_factor, thermalise=.true.) - else - call set_barostat(ds, type=BAROSTAT_HOOVER_LANGEVIN, p_ext=params%p_ext/EV_A3_IN_GPA, hydrostatic_strain=params%hydrostatic_strain, & - diagonal_strain=params%diagonal_strain, finite_strain_formulation=params%finite_strain_formulation, tau_epsilon=params%barostat_tau, T=params%barostat_timescale_T, W_epsilon_factor=params%barostat_mass_factor, thermalise=.false.) - endif - endif - if (params%const_T) then - if (params%all_purpose_thermostat_massive) then - call add_thermostat(ds, type=THERMOSTAT_ALL_PURPOSE, T=params%T_cur, tau=params%langevin_tau, Q=nose_hoover_mass(3.0_dp, params%T_cur, params%adaptive_langevin_NH_tau), & - NHL_tau = params%all_purpose_thermostat_NHL_tau, NHL_mu = nose_hoover_mass(3.0_dp, params%T_cur, params%all_purpose_thermostat_NHL_NH_tau), & - massive=params%all_purpose_thermostat_massive) - else - call add_thermostat(ds, type=THERMOSTAT_ALL_PURPOSE, T=params%T_cur, tau=params%langevin_tau, Q=nose_hoover_mass(3.0_dp*ds%atoms%N, params%T_cur, params%adaptive_langevin_NH_tau), & - NHL_tau = params%all_purpose_thermostat_NHL_tau, NHL_mu = nose_hoover_mass(3.0_dp*ds%atoms%N, params%T_cur, params%all_purpose_thermostat_NHL_NH_tau), & - massive=params%all_purpose_thermostat_massive) - endif - ds%atoms%thermostat_region=1 - endif - - else ! old thermostat - - if (params%const_T.and..not.params%const_P) then - call print('Running NVT at T = ' // params%T_cur // " K") - if (params%nose_hoover_thermostat) then - call add_thermostat(ds, THERMOSTAT_NOSE_HOOVER, params%T_cur, Q=nose_hoover_mass(3*ds%atoms%N, params%T_cur, tau=params%nose_hoover_tau)) - else - if (params%adaptive_langevin_NH_tau > 0) then - call print("Using open Langevin Q="//nose_hoover_mass(3*ds%atoms%N, params%T_cur, tau=params%adaptive_langevin_NH_tau)) - if (params%langevin_OU) then - call add_thermostat(ds, THERMOSTAT_LANGEVIN_OU, params%T_cur, tau=params%langevin_tau, Q=nose_hoover_mass(3*ds%atoms%N, params%T_cur, tau=params%adaptive_langevin_NH_tau)) - else - call add_thermostat(ds, THERMOSTAT_LANGEVIN, params%T_cur, tau=params%langevin_tau, Q=nose_hoover_mass(3*ds%atoms%N, params%T_cur, tau=params%adaptive_langevin_NH_tau)) - endif - else - if (params%langevin_OU) then - call add_thermostat(ds, THERMOSTAT_LANGEVIN_OU, params%T_cur, tau=params%langevin_tau) - else - call add_thermostat(ds, THERMOSTAT_LANGEVIN, params%T_cur, tau=params%langevin_tau) - endif - endif - endif - ds%atoms%thermostat_region = 1 - else if (params%const_T.and.params%const_P) then - call print('Running NPT at T = '// params%T_cur // " K and external p = " // params%p_ext/EV_A3_IN_GPA ) - if (params%adaptive_langevin_NH_tau > 0) then - call print("Using open Langevin Q="//nose_hoover_mass(3*ds%atoms%N, params%T_cur, tau=params%adaptive_langevin_NH_tau)) - call add_thermostat(ds, THERMOSTAT_LANGEVIN_NPT, params%T_cur, tau=params%langevin_tau, p=params%p_ext/EV_A3_IN_GPA, Q=nose_hoover_mass(3*ds%atoms%N, params%T_cur, tau=params%adaptive_langevin_NH_tau)) - else - if (params%NPT_NB) then - call add_thermostat(ds, THERMOSTAT_LANGEVIN_NPT_NB, params%T_cur, tau=params%langevin_tau, p=params%p_ext/EV_A3_IN_GPA) - else - call add_thermostat(ds, THERMOSTAT_LANGEVIN_NPT, params%T_cur, tau=params%langevin_tau, p=params%p_ext/EV_A3_IN_GPA) - endif - endif - ds%atoms%thermostat_region = 1 - else if (params%const_P.and..not.params%const_T) then - call system_abort('No const_P and not const_T') - endif - - endif ! all_purpose vs. old thermostat - - else ! not constP or const_T - call print('Running NVE') - endif - -end subroutine initialise_md_thermostat - -subroutine update_md_thermostat(ds, params) - type(md_params), intent(inout) :: params - type(DynamicalSystem), intent(inout) :: ds - - real(dp) :: T_new - - T_new = cur_temp(params, ds%t) - if (T_new /= params%T_cur) then - params%T_cur = T_new - if (params%const_T.and..not.params%const_P) then - call print('Running NVT at new T = ' // params%T_cur // " K") - else - call print('Running NPT at new T = '// params%T_cur // " K and external p = " // params%p_ext ) - endif - endif - - ds%thermostat%T = params%T_cur - -end subroutine update_md_thermostat - -function cur_temp(params, ds_t) result(T_cur) - type(md_params), intent(in) :: params - real(dp), intent(in) :: ds_t - real(dp) :: T_cur - - integer :: i_increment - - if (params%T_hold >= 0.0_dp) then - i_increment = ds_t/params%T_increment_time - T_cur = params%T_initial + i_increment*params%T_increment - ! check for hold stage - if ((params%T_increment > 0.0 .and. T_cur > params%T_hold) .or. & - (params%T_increment < 0.0 .and. T_cur < params%T_hold)) T_cur = params%T_hold - else - T_cur = params%T_initial - endif - -end function cur_temp - -end module md_module - -program md -use libatoms_module -use potential_module -use md_module -use libatoms_misc_utils_module -use restraints_constraints_xml_module - -implicit none - type (Potential) :: pot - type(MPI_context) :: mpi_glob, mpi_glob_orig - type(Cinoutput) :: traj_out, atoms_in_cio - type(Atoms) :: at_in - type(DynamicalSystem) :: ds - - real(dp) :: E, virial(3,3) - real(dp), pointer :: force_p(:,:) - real(dp) :: max_moved - - integer :: i, i_step, initial_i_step - type(md_params) :: params - integer :: error = ERROR_NONE - type(extendable_str) :: params_es - - logical :: store_constraint_force - real(dp), allocatable :: restraint_stuff(:,:), restraint_stuff_timeavg(:,:) - character(STRING_LENGTH) :: extra_calc_args - integer :: l_error - integer, pointer :: extra_heat_mask(:) - - call system_initialise() - - call initialise(mpi_glob) - mpi_glob_orig = mpi_glob - - call get_params(params, mpi_glob) - - call verbosity_push(verbosity_of_str(trim(params%verbosity))) - - if (params%do_timing) call enable_timing() - call system_timer("md_prep") - - call print_params(params) - - if (params%rng_seed >= 0) call system_reseed_rng(params%rng_seed) - - call initialise(atoms_in_cio, params%atoms_filename, INPUT, mpi=mpi_glob) - call read(at_in, atoms_in_cio, error=error) - HANDLE_ERROR(error) - - if (len_trim(params%param_filename) > 0) then - call read(params_es, params%param_filename, convert_to_string=.true., mpi_comm=mpi_glob%communicator, mpi_id=mpi_glob%my_proc) - else - call initialise(params_es) - endif - - call initialise(pot, args_str=params%pot_init_args, param_str=string(params_es), mpi_obj=mpi_glob) - - call print(pot) - - call initialise(ds, at_in) - - - ! set some initial values, in particular if this run is a continuation - initial_i_step = 1 - if (params%continuation) then - call get_param_value(ds%atoms, 'time', ds%t, l_error) - call get_param_value(ds%atoms, 'i_step', initial_i_step, l_error) - CLEAR_ERROR(error) - if(has_property(at_in, 'velo')) then - ds%atoms%velo=at_in%velo - call print("Initialising velocities from input file") - endif - endif - - ds%avg_time = params%avgtime - - call finalise(at_in) - - call init_restraints_constraints(ds, string(params_es)) - store_constraint_force = has_property(ds%atoms, "constraint_force") - - call finalise(params_es) - - call initialise(traj_out, params%trajectory_filename, OUTPUT, mpi=mpi_glob, netcdf4=params%netcdf4) - if (params%flux_print_interval > 0.0_dp) then - open(uflux, file=params%flux_filename, position='append') - endif - - call initialise_md_thermostat(ds, params) - - if (params%zero_momentum) call zero_momentum(ds) - if (params%zero_angular_momentum) call zero_angular_momentum(ds%atoms) - - ! add properties - call add_property(ds%atoms, 'force', 0.0_dp, n_cols=3, ptr2=force_p) - - call set_cutoff(ds%atoms, cutoff(pot), cutoff_skin=params%cutoff_skin) - - - ! start with p(t), v(t) - ! calculate f(t) - call calc_connect(ds%atoms) - if (params%quiet_calc) call verbosity_push_decrement() - - if (params%extra_heat > 0.0_dp .and. .not. assign_pointer(ds%atoms, 'extra_heat_mask', extra_heat_mask)) & - call system_abort("md: extra_heat="//params%extra_heat//" > 0, but no extra_heat_mask integer field found") - - extra_calc_args="force" - if (params%calc_energy) extra_calc_args = trim(extra_calc_args) // " energy" - if (params%calc_virial) extra_calc_args = trim(extra_calc_args) // " virial" - call calc(pot, ds%atoms, args_str=trim(params%first_pot_calc_args)//" "//trim(extra_calc_args)) - call do_v_dep_calcs(ds, params, pot, override_interval=.true.) - if (params%calc_energy) call get_param_value(ds%atoms, "energy", E) - if (params%calc_virial) call get_param_value(ds%atoms, "virial", virial) - if (params%quiet_calc) call verbosity_pop() - call set_value(ds%atoms%params, 'time', ds%t) - - if (params%extra_heat > 0.0_dp .and. mod(floor(ds%t/1000.0_dp),2) == 0) call add_extra_heat(force_p, params%extra_heat, extra_heat_mask) - - ! calculate a(t) from f(t) - forall(i = 1:ds%N) ds%atoms%acc(:,i) = force_p(:,i) / ElementMass(ds%atoms%Z(i)) - - if (ds%Nrestraints > 0) then - ! first get_restraint_stuff allocates to right size - call get_restraint_stuff(ds, restraint_stuff) - allocate(restraint_stuff_timeavg(size(restraint_stuff,1),size(restraint_stuff,2))) - restraint_stuff_timeavg = restraint_stuff - end if - call do_prints(params, ds, e, pot, restraint_stuff, restraint_stuff_timeavg, traj_out, 0, override_intervals = .true.) - - call calc_connect(ds%atoms) - max_moved = 0.0_dp - - call system_timer("md_prep") - - ! on entry, we have p(t), v(t), a(t), like advance verlet 1 wants - call system_timer("md_loop") - i_step = initial_i_step - do while ((params%N_steps >= 0 .and. i_step <= params%N_steps) .or. (params%max_time > 0.0_dp .and. ds%t <= params%max_time)) - - call update_md_thermostat(ds, params) - - call advance_md(ds, params, pot, store_constraint_force) - if (ds%Nrestraints > 0) then - call get_restraint_stuff(ds, restraint_stuff) - call update_exponential_average(restraint_stuff_timeavg, params%dt/ds%avg_time, restraint_stuff) - end if - if (params%calc_energy) call get_param_value(ds%atoms, "energy", E) - - ! now we have p(t+dt), v(t+dt), a(t+dt) - - call system_timer("md/print") - call set_value(ds%atoms%params, 'time', ds%t) - call set_value(ds%atoms%params, 'i_step', i_step) - call do_prints(params, ds, e, pot, restraint_stuff, restraint_stuff_timeavg, traj_out, i_step) - - call system_timer("md/print") - - i_step = i_step + 1 - end do - call system_timer("md_loop") - - call do_v_dep_calcs(ds, params, pot, override_interval=.true.) - call do_prints(params, ds, e, pot, restraint_stuff, restraint_stuff_timeavg, traj_out, params%N_steps, override_intervals = .true.) - - call system_finalise() - -contains - - subroutine get_restraint_stuff(ds, restraint_stuff) - type(DynamicalSystem), intent(in) :: ds - real(dp), allocatable, intent(inout) :: restraint_stuff(:,:) - - integer :: i_r, n_s - - ! count number to print in summary n_s - n_s = 0 - do i_r = 1, ds%Nrestraints - if (ds%restraint(i_r)%print_summary) n_s=n_s + 1 - end do - - ! (re)allocate array - if (allocated(restraint_stuff)) then - if (size(restraint_stuff,1) /= 5 .or. size(restraint_stuff,2) /= n_s) deallocate(restraint_stuff) - endif - if (.not. allocated(restraint_stuff)) then - allocate(restraint_stuff(5,n_s)) - endif - - ! fill in data - n_s = 0 - do i_r = 1, ds%Nrestraints - if (ds%restraint(i_r)%print_summary) then - n_s = n_s + 1 - restraint_stuff(1,n_s) = ds%restraint(i_r)%target_v - restraint_stuff(2,n_s) = ds%restraint(i_r)%C - restraint_stuff(3,n_s) = ds%restraint(i_r)%E - restraint_stuff(4,n_s) = -ds%restraint(i_r)%dE_dcoll - restraint_stuff(5,n_s) = -ds%restraint(i_r)%dE_dk - end if - end do - end subroutine get_restraint_stuff - - subroutine advance_md(ds, params, pot, store_constraint_force) - type(DynamicalSystem), intent(inout) :: ds - type(md_params), intent(in) :: params - type(Potential), intent(inout) :: pot - logical, intent(in) :: store_constraint_force - - integer :: i_substep - real(dp), pointer :: new_pos(:,:), new_velo(:,:), new_forces(:,:), force_p(:,:) - real(dp) :: new_E - logical :: has_new_pos, has_new_velo, has_new_forces, has_new_E - character(STRING_LENGTH) :: extra_calc_args - - if (params%advance_md_substeps > 0) then - call calc_connect(ds%atoms) - if (params%quiet_calc) call verbosity_push_decrement() - - extra_calc_args="force" - if (params%calc_energy) extra_calc_args = trim(extra_calc_args) // " energy" - if (params%calc_virial) extra_calc_args = trim(extra_calc_args) // " virial" - call calc(pot, ds%atoms, args_str=trim(params%pot_calc_args)//" "//trim(extra_calc_args)) - - if (params%extra_heat > 0.0_dp .and. mod(floor(ds%t/1000.0_dp),2) == 0) call add_extra_heat(force_p, params%extra_heat, extra_heat_mask) - - if (params%quiet_calc) call verbosity_pop() - has_new_pos = assign_pointer(ds%atoms, 'new_pos', new_pos) - has_new_velo = assign_pointer(ds%atoms, 'new_velo', new_velo) - has_new_forces = assign_pointer(ds%atoms, 'new_forces', new_forces) - has_new_E = get_value(ds%atoms%params, 'New_Energy', new_E) - if (count ( (/ has_new_pos, has_new_velo, has_new_forces /) ) > 0) then - if (count ( (/ has_new_pos, has_new_velo, has_new_forces /) ) /= 3) then - call system_abort("advance_md tried to do md within driver, got only some of " // & - "has_new_pos=" // has_new_pos // " has_new_velo="//has_new_velo//" has_new_forces="//has_new_forces) - endif - ds%atoms%pos = new_pos - ds%atoms%velo = new_velo - if (.not. assign_pointer(ds%atoms, "force", force_p)) then - call system_abort("advance_md failed to assign pointer for force") - endif - force_p = new_forces - if (has_new_E) call set_param_value(ds%atoms, "energy", new_E) - ds%t = ds%t + params%dt*params%advance_md_substeps - ds%nSteps = ds%nSteps + params%advance_md_substeps - call calc_connect(ds%atoms) - max_moved = 0.0_dp - else ! failed to find new_pos - do i_substep=1, params%advance_md_substeps - call advance_md_one(ds, params, pot, store_constraint_force) - end do - endif - else - call advance_md_one(ds, params, pot, store_constraint_force) - endif - end subroutine advance_md - - subroutine advance_md_one(ds, params, pot, store_constraint_force) - type(DynamicalSystem), intent(inout) :: ds - type(md_params), intent(in) :: params - type(Potential), intent(inout) :: pot - logical, intent(in) :: store_constraint_force - - real(dp), pointer :: force_p(:,:) - integer :: i, j - integer, pointer :: move_mask_p(:), move_mask_3_p(:,:) - real(dp) :: E, virial(3,3) - character(STRING_LENGTH) :: extra_calc_args - - real(dp) :: tprin - - ! start with have p(t), v(t), a(t) - - ! first Verlet half-step - call system_timer("md/advance_verlet1") - if(params%const_P) then - call get_param_value(ds%atoms, "virial", virial) - call advance_verlet1(ds, params%dt, virial=virial, store_constraint_force=store_constraint_force) - else - call advance_verlet1(ds, params%dt, store_constraint_force=store_constraint_force) - endif - call system_timer("md/advance_verlet1") - ! now we have p(t+dt), v(t+dt/2), a(t) - - max_moved = max_moved + params%dt*maxval(abs(ds%atoms%velo))*sqrt(3.0_dp) - call system_timer("md/calc_connect") - if (max_moved > 0.9_dp*params%cutoff_skin) then - call calc_connect(ds%atoms) - max_moved = 0.0_dp - else - call calc_dists(ds%atoms) - endif - call system_timer("md/calc_connect") - - ! calc f(t+dt) - call system_timer("md/calc") - if (params%quiet_calc) call verbosity_push_decrement() - - extra_calc_args="force" - if (params%calc_energy) extra_calc_args = trim(extra_calc_args) // " energy" - if (params%calc_virial) extra_calc_args = trim(extra_calc_args) // " virial" - call calc(pot, ds%atoms, args_str=trim(params%pot_calc_args)//" "//trim(extra_calc_args)) - if (params%calc_energy) call get_param_value(ds%atoms, "energy", E) - if (params%calc_virial) call get_param_value(ds%atoms, "virial", virial) - if (.not. assign_pointer(ds%atoms, "force", force_p)) call system_abort("md failed to get force") - if (assign_pointer(ds%atoms, "move_mask", move_mask_p)) then - do i=1, ds%atoms%N - if (move_mask_p(i) == 0) force_p(:,i) = 0.0_dp - end do - endif - if (assign_pointer(ds%atoms, "move_mask_3", move_mask_3_p)) then - do i=1, ds%atoms%N - do j=1, 3 - if (move_mask_3_p(j,i) == 0) force_p(j,i) = 0.0_dp - end do - end do - endif - - if (params%extra_heat > 0.0_dp .and. mod(floor(ds%t/1000.0_dp),2) == 0) call add_extra_heat(force_p, params%extra_heat, extra_heat_mask) - - if (params%quiet_calc) call verbosity_pop() - call system_timer("md/calc") - ! now we have a(t+dt) - - ! second Verlet half-step - call system_timer("md/advance_verlet2") - if(params%const_P) then - call advance_verlet2(ds, params%dt, force_p, virial=virial, E=E, store_constraint_force=store_constraint_force) - else - call advance_verlet2(ds, params%dt, force_p, E=E, store_constraint_force=store_constraint_force) - endif - call system_timer("md/advance_verlet2") - - ! now we have p(t+dt), v(t+dt), a(t+dt) - - call do_v_dep_calcs(ds, params, pot) - - end subroutine advance_md_one - - subroutine do_v_dep_calcs(ds, params, pot, override_interval) - type(DynamicalSystem), intent(inout) :: ds - type(md_params), intent(in) :: params - type(Potential), intent(inout) :: pot - logical, optional :: override_interval - - logical :: use_override_interval - real(dp) :: tprin - logical :: do_extra_calc - - use_override_interval = optional_default(.false., override_interval) - - ! call calc again if needed for v dep. forces - if (params%v_dep_quants_extra_calc) then - do_extra_calc = .true. - if (params%extra_calc_interval > 0.0_dp) then - do_extra_calc = .false. - ! just a short alias - tprin = params%extra_calc_interval - ! if the time is close to a - if (abs(modulo(ds%t + 0.5_dp*tprin, tprin) - 0.5_dp*tprin).le.1e-7) do_extra_calc = .true. - end if - - if (do_extra_calc) then - call system_timer("md/extra_calc") - if (params%quiet_calc) call verbosity_push_decrement() - call calc(pot, ds%atoms, args_str=trim(params%pot_calc_args)//" "//trim(extra_calc_args)) - if (params%quiet_calc) call verbosity_pop() - - if (params%extra_heat > 0.0_dp .and. mod(floor(ds%t/1000.0_dp),2) == 0) call add_extra_heat(force_p, params%extra_heat, extra_heat_mask) - call system_timer("md/extra_calc") - endif - end if - end subroutine do_v_dep_calcs - - subroutine add_extra_heat(force, extra_heat_mag, extra_heat_mask) - real(dp), intent(inout) :: force(:,:) - real(dp), intent(in) :: extra_heat_mag - integer, intent(in) :: extra_heat_mask(:) - - integer i - - do i=1, size(force,2) - if (extra_heat_mask(i) /= 0) then - force(1,i) = force(1,i) + extra_heat_mag*ran_normal() - force(2,i) = force(2,i) + extra_heat_mag*ran_normal() - force(3,i) = force(3,i) + extra_heat_mag*ran_normal() - endif - end do - end subroutine add_extra_heat - -end program diff --git a/src/Programs/md_gid.f95 b/src/Programs/md_gid.f95 deleted file mode 100644 index c4f7d1208c..0000000000 --- a/src/Programs/md_gid.f95 +++ /dev/null @@ -1,254 +0,0 @@ -program md_gid - - use libatoms_module - use potential_module - implicit none - - type(Dictionary) :: params - - type(MPI_context) :: mpi_glob - type(Potential) :: pot - type(Atoms) :: at1, at2 - type(DynamicalSystem) :: ds1, ds2 - type(CInoutput) :: savexyz - - real(dp) :: p0, p_init, p, temp_init, temp, dt, deltaTemp, deltaBeta, & - lnP0, lnP, beta0, beta, deltaV, deltaH, f0, f1, tau, tau_cell, cell_oscillation_time, & - bulk_modulus_estimate1, bulk_modulus_estimate2 - integer :: nTotal, nSteps, nCorrector, nSmooth, nPrint - logical :: iso1, iso2, restart, has_trajectory_file - character(STRING_LENGTH) :: at_file1, at_file2, param_file, init_args - integer :: i, j - real(dp), dimension(:,:), allocatable :: vol, kine, pote, enth, tp - character(STRING_LENGTH) :: trajectory_file - - call system_initialise(verbosity=PRINT_NORMAL, enable_timing=.false.) - - call initialise(params) - call param_register(params, 'at_file1', PARAM_MANDATORY,at_file1,"Phase 1 input configuration") - call param_register(params, 'at_file2', PARAM_MANDATORY,at_file2,"Phase 2 input configuration") - call param_register(params, 'param_file', PARAM_MANDATORY,param_file,"XML file") - call param_register(params, 'init_args', PARAM_MANDATORY,init_args,"Init args") - call param_register(params, 'p_init', PARAM_MANDATORY,p_init,"Initial pressure (GPa) at a coexistence point") - call param_register(params, 'temp_init', PARAM_MANDATORY,temp_init,"Initial temperature at a coexistence point") - call param_register(params, 'iso1', "false",iso1,"Allow only isotropic lattice deformation in phase 1") - call param_register(params, 'iso2', "false",iso2,"Allow only isotropic lattice deformation in phase 2") - call param_register(params, 'tau', "100.0",tau,"Thermostat time constant") - call param_register(params, 'tau_cell', "2000.0",tau_cell,"Barostat time constant") - call param_register(params, 'cell_oscillation_time', "1000.0",cell_oscillation_time,"Cell vibration time period") - call param_register(params, 'bulk_modulus_estimate1', "150.0",bulk_modulus_estimate1,"Estimated bulk modulus (GPa) for phase 1") - call param_register(params, 'bulk_modulus_estimate2', "150.0",bulk_modulus_estimate2,"Estimated bulk modulus (GPa) for phase 2") - call param_register(params, 'restart', "false",restart,"Do not rescale velocities") - call param_register(params, 'nsteps', "30",nsteps,"GD integration time steps") - call param_register(params, 'ncorrector', "6",ncorrector,"GD integration corrector steps") - call param_register(params, 'ntotal', "15000",ntotal,"MD steps per GD integration iteration") - call param_register(params, 'nsmooth', "5000",nSmooth,"Time constant (in steps) for averaging") - call param_register(params, 'nprint', "100",nPrint,"Status print") - call param_register(params, 'dt', "1.0",dt,"MD time step") - call param_register(params, 'deltatemp', "25",deltatemp,"temperature step in GD integration") - call param_register(params, 'trajectory_file', "",trajectory_file,"file to save trajectory along integration",has_value_target=has_trajectory_file) - - if (.not. param_read_args(params, check_mandatory = .true.)) then - call print("Usage: md_gid ") - call system_abort('Exit: Mandatory argument(s) missing...') - endif - - call print("==================== Input parameters ====================") - call param_print(params) - call print("==========================================================") - - call finalise(params) - - call initialise(mpi_glob) - call Potential_Filename_Initialise(pot, args_str=trim(init_args), param_filename=trim(param_file), mpi_obj=mpi_glob) - - if(has_trajectory_file) call initialise(savexyz,trim(trajectory_file),action=OUTPUT,append=.true.,mpi=mpi_glob) - - p = p_init/EV_A3_IN_GPA - temp = temp_init - - ! System 1 - call read(at1,trim(at_file1),mpi=mpi_glob) - call set_cutoff(at1,cutoff(pot),1.0_dp) - call initialise(ds1, at1) - - if(iso1) then - call add_thermostat(ds1,THERMOSTAT_LANGEVIN_NPT,t=temp,p=p,tau=tau,tau_cell=tau_cell, & - bulk_modulus_estimate=bulk_modulus_estimate1/EV_A3_IN_GPA,cell_oscillation_time=cell_oscillation_time) - else - call add_thermostat(ds1,THERMOSTAT_LANGEVIN_PR,t=temp,p=p,tau=tau,tau_cell=tau_cell, & - bulk_modulus_estimate=bulk_modulus_estimate1/EV_A3_IN_GPA,cell_oscillation_time=cell_oscillation_time) - endif - if( .not. restart) call rescale_velo(ds1,2*temp_init) - - ! System 1 - call read(at2,trim(at_file2),mpi=mpi_glob) - call set_cutoff(at2,cutoff(pot),1.0_dp) - call initialise(ds2, at2) - - if(iso2) then - call add_thermostat(ds2,THERMOSTAT_LANGEVIN_NPT,t=temp,p=p,tau=tau,tau_cell=tau_cell, & - bulk_modulus_estimate=bulk_modulus_estimate2/EV_A3_IN_GPA,cell_oscillation_time=cell_oscillation_time) - else - call add_thermostat(ds2,THERMOSTAT_LANGEVIN_PR,t=temp,p=p,tau=tau,tau_cell=tau_cell, & - bulk_modulus_estimate=bulk_modulus_estimate2/EV_A3_IN_GPA,cell_oscillation_time=cell_oscillation_time) - endif - if( .not. restart) call rescale_velo(ds2,2*temp_init) - - allocate(vol(2,nTotal),kine(2,nTotal),pote(2,nTotal)) - allocate(tp(2,nSteps)) - - do j = 1, nSteps - lnP0 = log(p) - p0 = p - beta0=1.0_dp/(BOLTZMANN_K*temp) - beta=beta0 - - vol=0.0_dp - kine=0.0_dp - pote=0.0_dp - - call runMD(ds1, ds2, pot, temp,p,vol,kine,pote,nTotal) - enth = kine + pote + p*vol - - !deltaV = expav(vol(1,:),dt*nSmooth) - expav(vol(2,:),dt*nSmooth) - !deltaH = expav(enth(1,:),dt*nSmooth) - expav(enth(2,:),dt*nSmooth) - deltaV = runav(vol(1,:),nSmooth) / ds1%atoms%n - runav(vol(2,:),nSmooth) / ds2%atoms%n - deltaH = runav(enth(1,:),nSmooth) / ds1%atoms%n - runav(enth(2,:),nSmooth) / ds2%atoms%n - - !f0=-deltaH/(beta*p*deltaV) - f0=-deltaH/(beta*deltaV) - call print("delta in predictor "//deltaV//" "//deltaH//" "//f0) - - temp = temp + deltaTemp - beta=1.0_dp/(BOLTZMANN_K*temp) - deltaBeta=beta-beta0 - - p = p0 + f0*deltaBeta - lnP = log(p) - !lnP = lnP0+f0*deltaBeta - !p = exp(lnP) - call print("temperature "//temp) - call print("pressure in predictor step "//p*EV_A3_IN_GPA//" "//lnP) - - do i = 1, nCorrector - call runMD(ds1, ds2, pot,temp,p,vol,kine,pote,nTotal) - enth = kine + pote + p*vol - - !deltaV = expav(vol(1,:),dt*nSmooth) - expav(vol(2,:),dt*nSmooth) - !deltaH = expav(enth(1,:),dt*nSmooth) - expav(enth(2,:),dt*nSmooth) - deltaV = runav(vol(1,:),nSmooth) / ds1%atoms%n - runav(vol(2,:),nSmooth) / ds2%atoms%n - deltaH = runav(enth(1,:),nSmooth) / ds1%atoms%n - runav(enth(2,:),nSmooth) / ds2%atoms%n - - !f1=-deltaH/(beta*p*deltaV) - f1=-deltaH/(beta*deltaV) - call print("delta in predictor "//i//" "//deltaV//" "//deltaH//" "//f0) - p = p0 + (f0+f1)*deltaBeta/2.0_dp - lnP = log(p) - !lnP = lnP0 + (f0+f1)*deltaBeta/2.0_dp - !p = exp(lnP) - call print("pressure in corrector step "//p*EV_A3_IN_GPA//" "//lnP) - tp(:,j) = (/temp,p*EV_A3_IN_GPA/) - enddo - if(has_trajectory_file) then - call set_value(ds1%atoms%params, 'temperature', "" // temp) - call set_value(ds2%atoms%params, 'temperature', "" // temp) - call set_value(ds1%atoms%params, 'pressure', "" // p) - call set_value(ds2%atoms%params, 'pressure', "" // p) - call write(ds1%atoms,savexyz,properties="species:pos:velo:travel:force") - call write(ds2%atoms,savexyz,properties="species:pos:velo:travel:force") - endif - enddo - - call print("final coexistence (T,p)") - call print(tp) - - call finalise(ds1) - call finalise(ds2) - call finalise(at1, at2) - deallocate(vol,kine,pote,tp) - call system_finalise() - - contains - - subroutine runMD(ds1, ds2, pot, t,p,vol,kine,pote,nTotal) - type(DynamicalSystem), intent(inout) :: ds1, ds2 - type(Potential), intent(inout) :: pot - - real(dp), intent(in) :: t, p - real(dp), dimension(:,:), intent(out) :: vol, kine, pote - integer, intent(in) :: nTotal - - integer :: i - real(dp), dimension(3,3) :: virial1, virial2 - real(dp) :: energy1, energy2 - real(dp), dimension(:,:), pointer :: force1, force2 - - call add_property(ds1%atoms,'force',n_cols=3,value=0.0_dp,ptr2=force1) - call add_property(ds2%atoms,'force',n_cols=3,value=0.0_dp,ptr2=force2) - - call update_thermostat(ds1,t=t,p=p) - call update_thermostat(ds2,t=t,p=p) - - call calc(pot,ds1%atoms, virial=virial1) - call calc(pot,ds2%atoms, virial=virial2) - - do i = 1, nTotal - call advance_verlet1(ds1,dt,virial=virial1) - call calc(pot,ds1%atoms, force=force1, energy=energy1, virial=virial1) - call advance_verlet2(ds1, dt, force1,virial=virial1) - - call advance_verlet1(ds2,dt,virial=virial2) - call calc(pot,ds2%atoms, force=force2, energy=energy2, virial=virial2) - call advance_verlet2(ds2, dt, force2,virial=virial2) - - vol(:,i) = (/cell_volume(ds1%atoms),cell_volume(ds2%atoms)/) - kine(:,i) = (/[kinetic_energy(ds1),kinetic_energy(ds2)]/) - pote(:,i) = (/energy1,energy2/) - if(mod(i,nPrint)==0) then - call ds_print_status(ds1,label="SYS1",epot=energy1,instantaneous=.true.,mpi_obj=mpi_glob) - call ds_print_status(ds2,label="SYS2",epot=energy2,instantaneous=.true.,mpi_obj=mpi_glob) - endif - enddo - call map_into_cell(ds1%atoms) - call map_into_cell(ds2%atoms) - - call set_value(ds1%atoms%params, 'Energy', "" // energy1) - call set_value(ds2%atoms%params, 'Energy', "" // energy2) - call set_value(ds1%atoms%params, 'Virial', "" // reshape(virial1,(/9/)) ) - call set_value(ds2%atoms%params, 'Virial', "" // reshape(virial2,(/9/)) ) - endsubroutine runMD - - function expav(x,time) - real(dp), dimension(:), intent(in) :: x - real(dp), intent(in) :: time - real(dp) :: expav - - real(dp) :: f1, f2 - real(dp) :: ave - integer :: i - - f1=exp(-1.0_dp/time) - f2=1.0_dp-f1 - ave=x(1) - - do i = 2, size(x) - ave = f1*ave + f2*x(i) - enddo - - expav = ave - endfunction expav - - function runav(x,time) - real(dp), dimension(:), intent(in) :: x - integer, intent(in) :: time - real(dp) :: runav - - integer :: n - - n = min(size(x,1), time) - runav = sum(x(size(x,1)-n+1:)) / n - - endfunction runav - -endprogram md_gid diff --git a/src/Programs/metapot_test.f95 b/src/Programs/metapot_test.f95 deleted file mode 100644 index 5e0f5c9e8f..0000000000 --- a/src/Programs/metapot_test.f95 +++ /dev/null @@ -1,137 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program pot_test - - use libAtoms_module - use system_module, only : rewind - use Potential_Module - - implicit None - - type(Atoms) :: dia, at - type(Table) :: embedlist - type(Potential) :: pot - type(InOutput) :: xml - type(Potential) :: pot1, pot2 - real(dp), allocatable :: f1(:,:), f2(:,:) - integer, pointer :: hybrid(:), hybrid_mark(:) - - call system_initialise(PRINT_VERBOSE,seed=2) - call initialise(xml, 'pot_test_params.xml') - call initialise(pot1, 'IP SW label="PRB_31_plus_H"', xml) - call rewind(xml) - call initialise(pot2, 'IP SW label="eps_2.6"', xml) - - call diamond(dia, 5.44_dp, (/14/)) - call supercell(at, dia, 4, 4, 4) - call randomise(at%pos, 0.1_dp) - - allocate(f1(3,at%N),f2(3,at%N)) - - call set_cutoff(at, cutoff(pot1)+2.0_dp) - call calc_connect(at) - - ! Mark some atoms for embedding - call set_value(at%params, 'mode', 'embedding') - call add_property(at, 'hybrid', 0) - if (.not. assign_pointer(at, 'hybrid', hybrid)) call system_abort('Cannot assign hybrid pointer') - call append(embedlist, (/1,0,0,0/)) - call bfs_grow(at, embedlist, 2, nneighb_only=.true.) - hybrid(int_part(embedlist,1)) = 1 - - call print('embed list') - call print(embedlist) - - ! Test embedding methods in Potential calc() - call add_property(at, 'hybrid_mark', HYBRID_NO_MARK) - if (.not. assign_pointer(at, 'hybrid_mark', hybrid_mark)) call system_abort('Cannot assign hybrid_mark pointer') - if (.not. assign_pointer(at, 'hybrid', hybrid)) call system_abort('Cannot assign hybrid pointer') - where (hybrid /= 0) hybrid_mark = HYBRID_ACTIVE_MARK - - call print('single_cluster') - call create_hybrid_weights(at, 'buffer_hops=3') - call calc(pot2, at, force=f1, args_str='single_cluster=T cluster_calc_connect=T') - call print(f1) - - call print('little_clusters') - call calc(pot2, at, force=f2, args_str='little_clusters=T cluster_calc_connect=T buffer_hops=3') - call print(f2) - - ! buffering is perfect, forces should be equal - call print('embedding test force error '//rms_diff(f1, f2)//' '//maxval(abs(f1-f2))) - - ! Now test all the (non-LOTF) force mixing methods - - call set_value(at%params, 'mode', 'force_mixing') - call print('force_mixing') - call initialise(pot, 'ForceMixing method=force_mixing buffer_hops=3 qm_args_str={single_cluster=T cluster_calc_connect=T}', pot1, pot2) - call print(pot) - call calc(pot, at, force=f1) - call print(f1) - call finalise(pot) - - call set_value(at%params, 'mode', 'force_mixing_smooth') - call print('force_mixing_smooth') - call initialise(pot, 'ForceMixing method=force_mixing_smooth buffer_hops=1 qm_args_str={single_cluster=T cluster_calc_connect=T}', pot1, pot2) - call print(pot) - call calc(pot, at, force=f2) - call print(f2) - call print('force_mixing_smooth force error '//rms_diff(f1, f2)//' '//maxval(abs(f1-f2))) - call finalise(pot) - - call set_value(at%params, 'mode', 'force_mixing_super_smooth') - call print('force_mixing_super_smooth') - call initialise(pot, 'ForceMixing method=force_mixing_super_smooth buffer_hops=1 qm_args_str={single_cluster=T cluster_calc_connect=T}', pot1, pot2) - call print(pot) - call calc(pot, at, force=f2) - call print(f2) - call print('force_mixing_super_smooth force error '//rms_diff(f1, f2)//' '//maxval(abs(f1-f2))) - call finalise(pot) - - call set_value(at%params, 'mode', 'conserve_momentum') - call print('conserve_momentum') - call initialise(pot, 'ForceMixing method=conserve_momentum fit_hops=2 buffer_hops=1 qm_args_str={single_cluster=T cluster_calc_connect=T}', pot1, pot2) - call print(pot) - call calc(pot, at, force=f2) - call print(f2) - call print('conserve_momentum force error '//rms_diff(f1, f2)//' '//maxval(abs(f1-f2))) - call finalise(pot) - - - deallocate(f1, f2) - call finalise(xml) - call finalise(pot1) - call finalise(pot2) - call finalise(at) - call finalise(dia) - call system_finalise - -end program pot_test diff --git a/src/Programs/order_atoms_as_molecules.f95 b/src/Programs/order_atoms_as_molecules.f95 deleted file mode 100644 index 3f3e44af16..0000000000 --- a/src/Programs/order_atoms_as_molecules.f95 +++ /dev/null @@ -1,94 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -program order - -use libAtoms_module -use libatoms_misc_utils_module - -implicit none - - type(Atoms) at, at2 - logical, dimension(:), allocatable :: atomdone - integer error, i, j, k, jj, nn - - - call system_initialise(verbosity=PRINT_SILENT) - - do - call read(at, 'stdin', error=error) - if (error /= 0) then - if (error == ERROR_IO_EOF) then - exit - else - HANDLE_ERROR(error) - endif - endif - - call set_cutoff(at, 1.2_dp) - call calc_connect(at) - - call initialise(at2, at%N, at%lattice) - allocate(atomdone(at%N)) - atomdone = .false. - k = 1 - call print(at) - - do i=1,at%N - if(atomdone(i) .eqv. .true.) cycle - at2%species(:,k) = at%species(:,i) - at2%pos(:,k) = at%pos(:,i) - k = k+1 - atomdone(i) = .true. - nn = n_neighbours(at, i) - if(nn > 0) then - do j=1,nn - jj = neighbour(at, i, j) - if(atomdone(jj) .eqv. .true.) cycle - at2%species(:,k) = at%species(:,jj) - at2%pos(:,k) = at%pos(:,jj) - k = k+1 - atomdone(jj) = .true. - end do - endif - end do - deallocate(atomdone) - - call verbosity_push(PRINT_NORMAL) - call write(at2, 'stdout') - call verbosity_pop() - call finalise(at2) - - enddo - call system_finalise() - -end program order diff --git a/src/Programs/parallel_io_test.f95 b/src/Programs/parallel_io_test.f95 deleted file mode 100644 index b63bb25b34..0000000000 --- a/src/Programs/parallel_io_test.f95 +++ /dev/null @@ -1,104 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program parallel_io_test - - use libAtoms_module - implicit none - - type(InOutput) :: init - type(CInOutput) :: in, out - type(Atoms) :: at - type(Dictionary) :: dict - type(MPI_Context) :: mpi - type(Table) :: tab - logical :: texist - integer :: iunit - - call system_initialise(mpi_all_inoutput=.true.) - - call initialise(mpi) - - call print_title('Test dict_bcast') - call initialise(dict) - if (mpi%my_proc == 0) then - call set_value(dict, 'a', 0) - call set_value(dict, 'b', 1.0_dp) - call set_value(dict, 'c', (/.false., .false., .false./)) - call set_value(dict, 'd', (/3, 1, 4, 1, 5, 9/)) - call set_value(dict, 'e', (/3.141459_dp/)) - call set_value(dict, 'f', (1.0_dp, 2.0_dp)) - end if - call bcast(mpi, dict) - call print(dict) - - call print_title('Test table_bcast') - call initialise(tab, 1, 0, 0, 0) - if (mpi%my_proc == 0) then - call append(tab, (/1, 2, 3, 4/)) - end if - call bcast(mpi, tab) - call print(tab) - - if (mpi%my_proc == 0) then - ! Write input file - call initialise(init, 'input.xyz', OUTPUT) - call print('8', file=init) - call print('Lattice="5.440000 0.000000 0.000000 0.000000 5.440000 0.000000 0.000000 0.000000 5.440000" Properties=species:S:1:pos:R:3:Z:I:1:log:L:1', file=init) - call print('Si 0.00000000 0.00000000 0.00000000 14 F', file=init) - call print('Si 1.36000000 1.36000000 1.36000000 14 F', file=init) - call print('Si 2.72000000 2.72000000 0.00000000 14 F', file=init) - call print('Si 4.08000000 4.08000000 1.36000000 14 F', file=init) - call print('Si 2.72000000 0.00000000 2.72000000 14 F', file=init) - call print('Si 4.08000000 1.36000000 4.08000000 14 F', file=init) - call print('Si 0.00000000 2.72000000 2.72000000 14 F', file=init) - call print('Si 1.36000000 4.08000000 4.08000000 14 F', file=init) - call finalise(init) - - ! Remove index if present - inquire (file='input.xyz.idx',exist=texist) - if (texist) then - iunit = pick_up_unit() - open (iunit,file='input.xyz.idx',status='old') - close (iunit,status='delete') - endif - end if - - call print_title('Test atoms_bcast') - call initialise(in, 'input.xyz', INPUT, mpi=mpi) - call initialise(out, 'output.xyz', OUTPUT, mpi=mpi) - - call read(in, at) - call print(at) - call write(out, at) - - call system_finalise - -end program parallel_io_test diff --git a/src/Programs/quip.f95 b/src/Programs/quip.f95 deleted file mode 100644 index 566dd3d560..0000000000 --- a/src/Programs/quip.f95 +++ /dev/null @@ -1,834 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -program quip - -use libAtoms_module -use system_module, only : verbosity_unset_minimum, verbosity_set_minimum -#ifdef HAVE_TB -use tb_module -#endif -use potential_module -use libatoms_misc_utils_module -use elasticity_module -use phonons_module -#ifdef HAVE_GAP -use descriptors_module -#endif -#ifdef HAVE_PRECON -use Potential_Precon_Minim_module -#endif - -implicit none - - type(Potential) pot - type(MPI_context) mpi_glob - type(Atoms) at, bulk_scale, dimer_at - - type(Dictionary) :: cli_params - - character(len=STRING_LENGTH) verbosity, test_dir_field - logical :: do_E, do_F, do_V, do_cij, do_c0ij, do_local, do_test, do_n_test, do_relax, & - & do_phonons, do_frozen_phonons, do_phonons_zero_rotation, do_force_const_mat, do_phonopy_force_const_mat, & - & do_parallel_phonons, do_dipole_moment, do_absorption, & - & do_fine_phonons, do_EvsV, do_cij_relax_initial, relax_hydrostatic_strain ! , relax_constant_volume - integer :: EvsV_NdVsteps - real(dp) :: EvsV_dVfactor - real(dp) :: relax_lattice_fix(9) - real(dp) :: mu(3) - real(dp), pointer :: local_dn(:) - real(dp) :: phonons_dx - real(dp) :: phonons_path_start(3), phonons_path_end(3) - integer :: phonons_path_steps - logical :: do_torque, do_cg_n_precond - real(dp) :: fire_minim_dt0 - real(dp) :: fire_minim_dt_max - character(len=STRING_LENGTH) precond_minim_method, precond_method, precond_e_method, precond_conv_method - real(dp) :: precond_e_scale, precond_len_scale, precond_cutoff, precond_res2, precond_infoverride, precond_bulk_modulus,precond_number_density - logical::precond_auto_mu - real(dp) :: tau(3) - character(len=STRING_LENGTH) :: relax_print_filename, linmin_method, minim_method - character(len=STRING_LENGTH) init_args, calc_args, atoms_filename, param_filename, extra_calc_args, pre_relax_calc_args, bulk_scale_filename, dimer_atoms_filename - integer relax_iter, relax_print_interval - real(dp) :: relax_tol, relax_eps, relax_rattle - type(CInOutput) :: relax_io - type(CInOutput) :: infile - real(dp) :: absorption_polarization_in(6) - complex(dp) :: absorption_polarization(3) - real(dp) :: absorption_freq_range(3), absorption_gamma - real(dp), allocatable :: absorption_freqs(:), absorption_v(:) - integer :: freq_i - integer, dimension(3) :: phonon_supercell, phonon_supercell_fine - - real(dp) :: E0 - real(dp), pointer :: local_E0(:) - real(dp), pointer :: local_v0(:,:) - real(dp), pointer :: F0(:,:) - real(dp) :: V0(3,3), P0(3,3) - real(dp) :: c(6,6), c0(6,6), cij_dx - - real(dp) :: iso_pressure - real(dp), dimension(3) :: diag_pressure - real(dp), dimension(9) :: pressure - real(dp), dimension(3,3) :: external_pressure - logical :: has_iso_pressure, has_diag_pressure, has_pressure, has_bulk_scale - logical :: has_dimer_at - logical :: has_phonons_path_start, has_phonons_path_end, has_phonons_path_steps, has_phonon_supercell_fine - - real(dp), pointer :: phonon(:,:) - real(dp), allocatable :: phonon_evals(:), phonon_evecs(:,:), IR_intensities(:), phonon_masses(:) - real(dp), allocatable :: force_const_mat(:,:) - real(dp) :: eval_froz - real(dp) :: mycutoff, mycutoff_skin - logical :: do_create_residue_labels, fill_in_mass - -#ifdef HAVE_GAP - type(descriptor) :: eval_descriptor -#endif - real(dp), dimension(:,:), allocatable :: descriptor_array, grad_descriptor_pos - real(dp), dimension(:,:,:), allocatable :: grad_descriptor_array - integer, dimension(:,:), allocatable :: grad_descriptor_index - character(STRING_LENGTH) :: descriptor_str - logical :: has_descriptor_str, do_grad_descriptor - - logical do_calc, did_anything, did_help, param_file_exists, do_timing, do_print_pot - logical test_ok - integer error, eval_port_status, eval_port - character(STRING_LENGTH) :: eval_port_str, output_file, real_format - logical :: output_flush - - integer i, n_iter, j, n_descriptors, n_cross - logical netcdf4 - - call system_initialise() - - call initialise(cli_params) - call param_register(cli_params, 'verbosity', 'NORMAL', verbosity, help_string="verbosity level") - if (.not. param_read_args(cli_params, ignore_unknown=.true., task="preliminary quip CLI arguments")) then - call system_abort("Nearly impossible failure to look for verbosity argument in preliminary parse") - end if - call verbosity_push(verbosity_of_str(trim(verbosity))) - call finalise(cli_params) - - - call initialise(cli_params) - call param_register(cli_params, 'timing', 'F', do_timing, help_string="Enable system timer") - call param_register(cli_params, 'atoms_filename', 'stdin', atoms_filename, help_string="input file for atoms, xyz or nc format") - call param_register(cli_params, 'param_filename', 'quip_params.xml', param_filename, help_string="input file for potential xml parameters") - call param_register(cli_params, 'E', 'F', do_E, help_string="Calculate energy") - call param_register(cli_params, 'energy', 'F', do_E, help_string="Calculate energy") - call param_register(cli_params, 'F', 'F', do_F, help_string="Calculate forces") - call param_register(cli_params, 'forces', 'F', do_F, help_string="Calculate forces") - call param_register(cli_params, 'V', 'F', do_V, help_string="Calculate virial (stress)") - call param_register(cli_params, 'virial', 'F', do_V, help_string="Calculate virial (stress)") - call param_register(cli_params, 'L', 'F', do_local, help_string="Calculate local quantities, e.g. local energy") - call param_register(cli_params, 'local', 'F', do_local, help_string="Calculate local quantities, e.g. local energy") - call param_register(cli_params, 'cij', 'F', do_cij, help_string="Calculate relaxed elastic constants") - call param_register(cli_params, 'c0ij', 'F', do_c0ij, help_string="Calculate unrelaxed elastic constants") - call param_register(cli_params, 'cij_dx', '0.01', cij_dx, help_string="Cartesian displacement size to use for elastic constant calculations") - call param_register(cli_params, 'cij_relax_initial', 'F', do_cij_relax_initial, help_string="Relax initial configuration for elastic constant calculations") - call param_register(cli_params, 'torque', 'F', do_torque, help_string="Calculate torque") - call param_register(cli_params, 'phonons', 'F', do_phonons, help_string="Calculate phonons") - call param_register(cli_params, 'phonons_path_start', '0.0 0.0 0.0', phonons_path_start, help_string="phonons path start", has_value_target=has_phonons_path_start) - call param_register(cli_params, 'phonons_path_end', '0.0 0.0 0.0', phonons_path_end, help_string="phonons path end", has_value_target=has_phonons_path_end) - call param_register(cli_params, 'phonons_path_steps', '3', phonons_path_steps, help_string="phonons path steps", has_value_target=has_phonons_path_steps) - call param_register(cli_params, 'frozen_phonons', 'F', do_frozen_phonons, help_string="Refine phonon frequencies by displacing along computed phonon vectors?") - call param_register(cli_params, 'phonons_zero_rotation', 'F', do_phonons_zero_rotation, help_string="project out rotation components from phonons?") - call param_register(cli_params, 'force_const_mat', 'F', do_force_const_mat, help_string="print out force constant matrix from phonon calculation?") - call param_register(cli_params, 'phonopy_force_const_mat', 'F', do_phonopy_force_const_mat, help_string="Print out force constant matrix and atomic positions in phonopy 1.12.4 format. Atomic positions and force constants are the ones resulting from the (fine) supercell. WARNING: It is not guaranteed to work with versions different from phonopy 1.12.4 and does only support a single atomic species at a time (no alloys).") - call param_register(cli_params, 'parallel_phonons', 'F', do_parallel_phonons, help_string="compute phonons in parallel?") - call param_register(cli_params, 'dipole_moment', 'F', do_dipole_moment, help_string="compute dipole moment?") - call param_register(cli_params, 'absorption', 'F', do_absorption, help_string="compute absorption spectrum (electronic, TB only)?") - call param_register(cli_params, 'absorption_polarization', '0.0 0.0 0.0 0.0 1.0 0.0', absorption_polarization_in, help_string="polarization vector along with to compute absorption spectrum") - call param_register(cli_params, 'absorption_freq_range', '0.1 1.0 0.1', absorption_freq_range, help_string="frequency range in which to compute absorption spectrum") - call param_register(cli_params, 'absorption_gamma', '0.01', absorption_gamma, help_string="energy broadening for absorption calculation") - call param_register(cli_params, 'phonons_dx', '0.01', phonons_dx, help_string="Cartesian displacement size to use for phonon calculations") - call param_register(cli_params, 'phonon_supercell', '1 1 1', phonon_supercell,help_string="Supercell in which to do the force calculations in a phonon computation", has_value_target=do_fine_phonons) - call param_register(cli_params, 'phonon_supercell_fine', '1 1 1', phonon_supercell_fine,help_string="Supercell in which to compute phonons. It should be greater or equal to phonon_supercell.", has_value_target=has_phonon_supercell_fine) - call param_register(cli_params, 'test', 'F', do_test, help_string="test consistency of forces/virial by comparing to finite differences") - call param_register(cli_params, 'n_test', 'F', do_n_test, help_string="test consistency of forces/virial by comparing to finite differences using Noam's method") - call param_register(cli_params, 'test_dir_field', '', test_dir_field, help_string="field containing vectors along which to displace atoms for gradient test") - call param_register(cli_params, 'relax', 'F', do_relax, help_string="relax configuration with respect to positions (if F/forces is set) and unit cell vectors (if V/virial is set)") - call param_register(cli_params, 'relax_print_filename', '', relax_print_filename, help_string="file to print positions along relaxation trajectory, xyz or nc format") - call param_register(cli_params, 'relax_iter', '1000', relax_iter, help_string="max number of iterations for relaxation") - call param_register(cli_params, 'relax_tol', '0.001', relax_tol, help_string="tolerance for convergence of relaxation") - call param_register(cli_params, 'relax_eps', '0.0001', relax_eps, help_string="estimate of energy reduction for first step of relaxation") - call param_register(cli_params, 'relax_rattle', '0.0', relax_rattle, help_string="rattle the atomic positions with a uniform random variate of this magnitude before relaxing") - call param_register(cli_params, 'relax_print_interval', '1', relax_print_interval, help_string="Frequency for printing trajectory") - call param_register(cli_params, 'init_args', '', init_args, help_string="string arguments for initializing potential") - call param_register(cli_params, 'bulk_scale_filename', '', bulk_scale_filename, help_string="optional bulk structure for calculating space and energy rescaling", has_value_target=has_bulk_scale) - call param_register(cli_params, 'calc_args', '', calc_args, help_string="string arguments for potential calculation") - call param_register(cli_params, 'pre_relax_calc_args', '', pre_relax_calc_args, help_string="string arguments for call to potential_calc that happens before relax. Useful if first call should generate something like PSF file, but later calls should use the previously generated file") - ! call param_register(cli_params, 'relax_constant_volume', 'F', relax_constant_volume, help_string="if virial and relax are set, constrain to constant volume") - call param_register(cli_params, 'relax_hydrostatic_strain', 'F', relax_hydrostatic_strain, help_string="if virial and relax are set, constrain to hydrostatic strain") - call param_register(cli_params, 'relax_lattice_fix', '0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0', relax_lattice_fix, help_string="if virial and relax are set, constrain lattice parameter matrix where this is /= 0. Doesn't work as expected in general, although definitely OK for orthogonal lattice vectors aligned with coordinate axes") - call param_register(cli_params, 'verbosity', 'NORMAL', verbosity, help_string="verbosity level - SILENT, NORMAL, VERBOSE, NERD, ANALYSIS") - call param_register(cli_params, 'fire_minim_dt0', '1.0', fire_minim_dt0, help_string="if using FIRE minim, initial value of time step ") - call param_register(cli_params, 'fire_minim_dt_max', '20.0', fire_minim_dt_max, help_string="if using FIRE minim, maximum value of time step ") - call param_register(cli_params, 'cg_n_precond', 'F', do_cg_n_precond, help_string="activate preconditioner for cg_n minim routine. Probably a bad idea if you have many atoms or a cheap IP, because it inverts a dense 3N x 3N matrix") - call param_register(cli_params, 'precond_minim_method', 'preconLBFGS', precond_minim_method, help_string="preconditioner minimization method for minim_method=precon, preconLBFGS or preconCG") - call param_register(cli_params, 'precond_method', 'ID', precond_method, help_string="preconditioner method for preconditioner, right now ID or LJ or C1") - call param_register(cli_params, 'precond_e_method', 'basic', precond_e_method, help_string="preconditioner method for summing energy: basic, kahan, doublekahan (kahan type only when local energy is available).") - call param_register(cli_params, 'precond_cutoff', '-1.0', precond_cutoff, help_string="cutoff distance for sparse preconditioner, cutoff(pot) if < 0.0") - call param_register(cli_params, 'precond_len_scale', '-1.0', precond_len_scale, help_string="len scale for preconditioner, cutoff(pot) if <= 0.0") - call param_register(cli_params, 'precond_bulk_modulus', '0.625', precond_bulk_modulus, help_string="bulk modulus for preconditioner scaling") - call param_register(cli_params, 'precond_number_density', '0.1', precond_number_density, help_string="number density for preconditioner scaling") - call param_register(cli_params, 'precond_auto_mu', 'F', precond_auto_mu, help_string="use auto mu") - call param_register(cli_params, 'precond_e_scale', '5.0', precond_e_scale, help_string="energy scale for preconditioner") - call param_register(cli_params, 'precond_res2', '1e-5', precond_res2, help_string="residual^2 error for preconditioner inversion") - call param_register(cli_params, 'precond_infoverride', '0.5', precond_infoverride, help_string="override the max inf norm of the step in precon_minim, can be decreased to avoid stepping into non-physical configurations if necessary") - call param_register(cli_params, 'precond_conv_method', '2norm', precond_conv_method, help_string="Switch to 'infnorm' if desired") - call param_register(cli_params, 'dimer_at', '', dimer_atoms_filename, help_string="second endpoint for dimer initialization", has_value_target=has_dimer_at) - call param_register(cli_params, 'minim_method', 'cg', minim_method, help_string="method for relaxation: sd, sd2, cg, pcg, lbfgs, cg_n, fire, precond") - call param_register(cli_params, 'linmin_method', 'default', linmin_method, help_string="linmin method for relaxation (NR_LINMIN, FAST_LINMIN, LINMIN_DERIV for minim_method=cg, standard or basic for minim_method=precon)") - call param_register(cli_params, 'iso_pressure', '0.0', iso_pressure, help_string="hydrostatic pressure for relaxation", has_value_target=has_iso_pressure) - call param_register(cli_params, 'diag_pressure', '0.0 0.0 0.0', diag_pressure, help_string="diagonal but nonhydrostatic stress for relaxation", has_value_target=has_diag_pressure) - call param_register(cli_params, 'pressure', '0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0', pressure, help_string="general off-diagonal stress for relaxation", has_value_target=has_pressure) - call param_register(cli_params, 'cutoff', '-1.0', mycutoff, help_string="if >= 0, value of cutoff to use, overriding value given by potential. Useful when neighbor calculations are needed for calculating a PSF file, even though FilePot claims to need cutoff=0") - call param_register(cli_params, 'cutoff_skin', '0.5', mycutoff_skin, help_string="Amount to add to potential cutoff when calculating connectivity. Default 0.5.") - call param_register(cli_params, 'create_residue_labels', 'F', do_create_residue_labels, help_string="if true, create residue labels (for CP2K) before calling calc") - call param_register(cli_params, 'fill_in_mass', 'F', fill_in_mass, help_string="if true, fill in mass property") - - call param_register(cli_params, 'hack_restraint_i', '0 0', hack_restraint_i, help_string="indices of 2 atom to apply restraint potential to") - call param_register(cli_params, 'hack_restraint_k', '0.0', hack_restraint_k, help_string="strength of restraint potential") - call param_register(cli_params, 'hack_restraint_r', '0.0', hack_restraint_r, help_string="mininum energy distance of restraint potential") - - call param_register(cli_params, 'descriptor_str', '', descriptor_str, help_string="Descriptor initialisation string", has_value_target=has_descriptor_str) - call param_register(cli_params, 'do_grad_descriptor', 'F', do_grad_descriptor, help_string="Evaluate derivative of descriptors?") - - call param_register(cli_params, 'EvsV', 'F', do_EvsV, help_string="compute energy vs volume curve") - call param_register(cli_params, 'EvsV_dVfactor', '1.1', EvsV_dVfactor, help_string="multiplier to use when increasing the volume at each step of EvsV") - call param_register(cli_params, 'EvsV_NdVsteps', '1', EvsV_NdVsteps, help_string="number of times to increase the volume when doing EvsV") - call param_register(cli_params, 'netcdf4', 'F', netcdf4, help_string="if true, write trajectories in NetCDF4 (HDF5, compressed) format") - call param_register(cli_params, 'output_file', 'stdout', output_file, help_string="file to send output to") - call param_register(cli_params, 'output_flush', 'F', output_flush, help_string="if true, always flush output") - call param_register(cli_params, 'real_format', '%16.8f', real_format, help_string="real format in XYZ file") - - - if (.not. param_read_args(cli_params, task="quip CLI arguments", did_help=did_help)) then - call print("Usage: quip [atoms_filename=file(stdin)] [param_filename=file(quip_params.xml)]",PRINT_ALWAYS) - call print(" [E|energy] [F|forces] [V|virial] ...", PRINT_ALWAYS) - call print("", PRINT_ALWAYS) - call print("There are lots of other options, type `quip --help' for a full list.", PRINT_ALWAYS) - call system_abort("") - end if - call finalise(cli_params) - - if (trim(output_file) /= "stdout") then - call finalise(mainlog) - call initialise(mainlog, filename=trim(output_file), action=OUTPUT) - end if - system_always_flush = output_flush - - if(did_help) call system_abort("Run without --help") - - if(do_timing) call enable_timing() - - call get_env_var("EVAL_PORT",eval_port_str, eval_port_status) - if(eval_port_status == 0) then - eval_port = string_to_int(trim(eval_port_str)) - else - eval_port = 32768 - endif - - - call Initialise(mpi_glob) - - ! are we calculating descriptors or potentials? - if ( has_descriptor_str ) then -#ifdef HAVE_GAP - call initialise(eval_descriptor, trim(descriptor_str)) - call print("Using descriptor string: "// trim(descriptor_str)) - if( mycutoff < 0.0_dp ) then - mycutoff = cutoff(eval_descriptor) - elseif( mycutoff < cutoff(eval_descriptor) ) then - call system_abort("mycutoff = "//mycutoff//" which is less than the descriptor cutoff "//cutoff(eval_descriptor)) - endif -#else - call system_abort("To print descriptors, HAVE_GAP must be enabled") -#endif - else - ! we are calculating potentials, so lets try to open the XML file - inquire(file=trim(param_filename), exist=param_file_exists) - if( .not. param_file_exists ) call system_abort(trim(param_filename)//" does not exist") - - call print ("Using calc args: " // trim(calc_args)) - call print ("Using pre-relax calc args: " // trim(pre_relax_calc_args)) - call print ("Using param_filename: " // trim(param_filename)) - call print ("Using init args: " // trim(init_args)) - if(has_bulk_scale) then - call initialise(infile, trim(bulk_scale_filename)) - call read(bulk_scale, infile, error=error) - call finalise(infile) - call Potential_Filename_Initialise(pot, args_str=init_args, param_filename=param_filename, mpi_obj=mpi_glob, bulk_scale=bulk_scale) - call finalise(bulk_scale) - else - call Potential_Filename_Initialise(pot, args_str=init_args, param_filename=param_filename, mpi_obj=mpi_glob) - end if - end if - if(has_dimer_at) then - call initialise(infile, trim(dimer_atoms_filename)) - call read(dimer_at, infile, error=error) - call finalise(infile) - else - if(trim(minim_method) == 'precond_dimer') then - call print("precond_dimer specified but no additional at file given,& - aborting",PRINT_VERBOSE) - call exit() - end if - end if - - call initialise(infile, trim(atoms_filename), mpi=mpi_glob) - - if( count( (/has_iso_pressure, has_diag_pressure, has_pressure/) ) > 1 ) call system_abort('External pressure specified in an ambiguous way') - external_pressure = 0.0_dp - if(has_iso_pressure) then - external_pressure(1,1) = iso_pressure - external_pressure(2,2) = iso_pressure - external_pressure(3,3) = iso_pressure - endif - if(has_diag_pressure) then - external_pressure(1,1) = diag_pressure(1) - external_pressure(2,2) = diag_pressure(2) - external_pressure(3,3) = diag_pressure(3) - endif - if(has_pressure) external_pressure = reshape(pressure, (/3,3/)) - -#ifndef BGQ - if( eval_port_status == 0 ) call system_command('echo 0 | nc 127.0.0.1 '//eval_port) ! send a signal that eval is ready to evaluate -#endif - - ! main loop over frames - do_print_pot = .true. ! print the pot on the first iteration - do - call read(at, infile, error=error) - if (error /= 0) then - if (error == ERROR_IO_EOF) then - exit - else - HANDLE_ERROR(error) - endif - endif - - if (mycutoff >= 0.0_dp) then - call set_cutoff(at, mycutoff, cutoff_skin=mycutoff_skin) - else - call set_cutoff(at, cutoff(pot), cutoff_skin=mycutoff_skin) - endif - - if(at%cutoff > 0.0_dp) then - call calc_connect(at) - endif - - if (do_create_residue_labels) then - call create_residue_labels_arb_pos(at, do_CHARMM=.true., pos_field_for_connectivity="pos", error=error) - HANDLE_ERROR(error) - endif - - if (fill_in_mass) then - if (.not. associated(at%mass)) then - call add_property(at, 'mass', 0.0_dp, 1) - endif - at%mass = ElementMass(at%Z) - endif - - did_anything=.false. - do_calc = .false. - - if( do_test .and. do_V .and. do_local ) then - did_anything = .true. - call test_local_virial(pot,at,trim(calc_args)) - endif - - if (do_test .or. do_n_test) then - did_anything = .true. - if (do_test) then - call verbosity_set_minimum(PRINT_NERD) - if (len_trim(test_dir_field) > 0) then - test_ok = test_gradient(pot, at, do_F, do_V, args_str = calc_args, dir_field=trim(test_dir_field)) - else - test_ok = test_gradient(pot, at, do_F, do_V, args_str = calc_args) - endif - call verbosity_unset_minimum() - call print ("test is OK? " // test_ok) - endif - if (do_n_test) then - if (len_trim(test_dir_field) > 0) then - call n_test_gradient(pot, at, do_F, do_V, args_str = calc_args, dir_field=trim(test_dir_field)) - else - call n_test_gradient(pot, at, do_F, do_V, args_str = calc_args) - endif - end if - call finalise(at) - cycle - end if ! do_test - - if (trim(linmin_method) == 'default') then - if(trim(minim_method) == 'precond') then - linmin_method = 'standard' - else - linmin_method = 'FAST_LINMIN' - endif - endif - - if (do_relax) then - did_anything = .true. - do_calc = .true. - call set_param_value(at, "Minim_Hydrostatic_Strain", relax_hydrostatic_strain) -! call set_param_value(at, "Minim_Constant_Volume", relax_constant_volume) - call set_param_value(at, "Minim_Lattice_Fix", reshape(relax_lattice_fix, (/ 3, 3 /)) ) - if(relax_rattle > 0.0) then - call randomise(at%pos, relax_rattle) - if(do_V) then - call randomise(at%lattice, relax_rattle) - end if - end if - if (len_trim(pre_relax_calc_args) > 0) then - extra_calc_args = "" - if (do_E) extra_calc_args = trim(extra_calc_args)//" energy" - if (do_F) extra_calc_args = trim(extra_calc_args)//" force" - if (do_V) extra_calc_args = trim(extra_calc_args)//" virial" - if (do_local) then - if (do_E) extra_calc_args = trim(extra_calc_args)//" local_energy" - if (do_V) extra_calc_args = trim(extra_calc_args)//" local_virial" - endif - call calc(pot, at, args_str = trim(pre_relax_calc_args)//" "//trim(extra_calc_args), error=error) - HANDLE_ERROR(error) - endif - if (precond_cutoff < 0.0) precond_cutoff=cutoff(pot) - if (precond_len_scale <= 0.0) precond_len_scale=cutoff(pot) - - if (len_trim(relax_print_filename) > 0) then - call initialise(relax_io, relax_print_filename, OUTPUT, netcdf4=netcdf4) - if(trim(minim_method) == 'precond') then -#ifdef HAVE_PRECON - call system_timer('quip/precon_minim') - n_iter = precon_minim(pot, at, trim(precond_minim_method), relax_tol, relax_iter, & - efuncroutine=trim(precond_e_method), linminroutine=trim(linmin_method), & - do_print = .true., print_cinoutput=relax_io, & - do_pos = do_F, do_lat = do_V, args_str = calc_args, external_pressure = external_pressure/EV_A3_IN_GPA, hook=print_hook, hook_print_interval=relax_print_interval, & - length_scale=precond_len_scale, energy_scale=precond_e_scale, precon_cutoff=precond_cutoff, precon_id=trim(precond_method),& - res2=precond_res2, infoverride = precond_infoverride,bulk_modulus=precond_bulk_modulus,number_density=precond_number_density,auto_mu=precond_auto_mu) - call system_timer('quip/precon_minim') -#else - call system_abort('minim_method=precond but HAVE_PRECON=0') -#endif - elseif(trim(minim_method) == 'precond_dimer') then -#ifdef HAVE_PRECON - call system_timer('quip/precon_dimer') - - n_iter = Precon_Dimer(pot, at, dimer_at,trim(precond_minim_method),relax_tol,relax_iter,efuncroutine=trim(precond_e_method), & - linminroutine=trim(linmin_method),do_print = .false.,do_pos = do_F, do_lat = do_V, args_str = calc_args, & - external_pressure = external_pressure/EV_A3_IN_GPA, hook=print_hook, hook_print_interval=relax_print_interval, & - length_scale=precond_len_scale, energy_scale=precond_e_scale, precon_cutoff=precond_cutoff, & - precon_id=trim(precond_method), res2=precond_res2, infoverride = precond_infoverride, & - bulk_modulus=precond_bulk_modulus,number_density=precond_number_density,auto_mu=precond_auto_mu) - call system_timer('quip/precon_dimer') - - call finalise(dimer_at) -#else - call system_abort('minim_method=precond_dimer but HAVE_PRECON=0') -#endif - else - call system_timer('quip/minim') - n_iter = minim(pot, at, trim(minim_method), relax_tol, relax_iter, trim(linmin_method), do_print = .true., & - print_cinoutput = relax_io, do_pos = do_F, do_lat = do_V, args_str = calc_args, eps_guess=relax_eps, & - fire_minim_dt0=fire_minim_dt0, fire_minim_dt_max=fire_minim_dt_max, external_pressure=external_pressure/EV_A3_IN_GPA, & - use_precond=do_cg_n_precond, hook_print_interval=relax_print_interval) - call system_timer('quip/minim') - endif - call finalise(relax_io) - else - if(trim(minim_method) == 'precond') then -#ifdef HAVE_PRECON - call system_timer('quip/precon_minim') - n_iter = precon_minim(pot, at, trim(precond_minim_method), relax_tol, relax_iter, & - efuncroutine=trim(precond_e_method), linminroutine=trim(linmin_method), & - do_print = .false., & - do_pos = do_F, do_lat = do_V, args_str = calc_args, external_pressure = external_pressure/EV_A3_IN_GPA, hook=print_hook, hook_print_interval=relax_print_interval, & - length_scale=precond_len_scale, energy_scale=precond_e_scale, precon_cutoff=precond_cutoff, precon_id=trim(precond_method),& - res2=precond_res2, infoverride=precond_infoverride,convchoice=precond_conv_method,bulk_modulus=precond_bulk_modulus,number_density=precond_number_density,auto_mu=precond_auto_mu) - call system_timer('quip/precon_minim') -#else - call system_abort('minim_method=precond but HAVE_PRECON=0') -#endif - elseif(trim(minim_method) == 'precond_dimer') then -#ifdef HAVE_PRECON - call system_timer('quip/precon_dimer') - - n_iter = Precon_Dimer(pot, at, dimer_at,trim(precond_minim_method),relax_tol,relax_iter,efuncroutine=trim(precond_e_method), & - linminroutine=trim(linmin_method),do_print = .false.,do_pos = do_F, do_lat = do_V, args_str = calc_args, & - external_pressure = external_pressure/EV_A3_IN_GPA, hook=print_hook, hook_print_interval=relax_print_interval, & - length_scale=precond_len_scale, energy_scale=precond_e_scale, precon_cutoff=precond_cutoff, & - precon_id=trim(precond_method), res2=precond_res2,infoverride=precond_infoverride,auto_mu=precond_auto_mu) - call system_timer('quip/precon_dimer') - call finalise(dimer_at) -#else - call system_abort('minim_method=precond but HAVE_PRECON=0') -#endif - else - call system_timer('quip/minim') - n_iter = minim(pot, at, trim(minim_method), relax_tol, relax_iter, trim(linmin_method), do_print = .false., & - do_pos = do_F, do_lat = do_V, args_str = calc_args, eps_guess=relax_eps, & - fire_minim_dt0=fire_minim_dt0, fire_minim_dt_max=fire_minim_dt_max, external_pressure=external_pressure/EV_A3_IN_GPA, & - use_precond=do_cg_n_precond, hook_print_interval=relax_print_interval) - call system_timer('quip/minim') - end if - endif - !! call write(at,'stdout', prefix='RELAXED_POS', properties='species:pos') - call print('Cell Volume: '//cell_volume(at)//' A^3') - if (at%cutoff > 0.0_dp) then - call calc_connect(at) - end if - end if - - if (do_c0ij .or. do_cij) then - if (trim(minim_method) == 'precond') & - call system_abort("Cannot use precond minim_method with cij yet") - did_anything = .true. - call print("Elastic constants in GPa") - call print("Using finite difference = "//cij_dx) - if (do_c0ij .and. do_cij) then - call calc_elastic_constants(pot, at, cij_dx, calc_args, c=c, c0=c0, relax_initial=do_cij_relax_initial, relax_tol=relax_tol, relax_method=minim_method, linmin_method=linmin_method) - else if (do_c0ij) then - call calc_elastic_constants(pot, at, cij_dx, calc_args, c0=c0, relax_initial=do_cij_relax_initial, relax_tol=relax_tol, relax_method=minim_method, linmin_method=linmin_method) - else - call calc_elastic_constants(pot, at, cij_dx, calc_args, c=c, relax_initial=do_cij_relax_initial, relax_tol=relax_tol, relax_method=minim_method, linmin_method=linmin_method) - endif - if (do_c0ij) then - mainlog%prefix="C0IJ" - call print(c0*EV_A3_IN_GPA) - mainlog%prefix="" - endif - if (do_cij) then - mainlog%prefix="CIJ" - call print(c*EV_A3_IN_GPA) - mainlog%prefix="" - endif - call print("") - endif ! do_cij - - if (do_dipole_moment) then - call add_property(at, 'local_dn', 0.0_dp, 1) - endif ! do_dipole_moment - - if (do_phonons) then - did_anything = .true. - if (do_force_const_mat) then - allocate(force_const_mat(at%N*3,at%N*3)) - endif - - allocate(phonon_evals(at%N*3)) - allocate(phonon_masses(at%N*3)) - allocate(phonon_evecs(at%N*3,at%N*3)) - if (do_dipole_moment) then - allocate(IR_intensities(at%N*3)) - if (do_force_const_mat) then - call phonons_all(pot, at, phonons_dx, phonon_evals, phonon_evecs, phonon_masses, calc_args = calc_args, & - IR_intensities=IR_intensities, do_parallel=do_parallel_phonons, zero_rotation=do_phonons_zero_rotation, & - force_const_mat=force_const_mat) - else - call phonons_all(pot, at, phonons_dx, phonon_evals, phonon_evecs, phonon_masses, calc_args = calc_args, & - IR_intensities=IR_intensities, zero_rotation=do_phonons_zero_rotation, & - do_parallel=do_parallel_phonons) - endif - else - if (do_force_const_mat) then - call phonons_all(pot, at, phonons_dx, phonon_evals, phonon_evecs, phonon_masses, calc_args = calc_args, & - do_parallel=do_parallel_phonons, zero_rotation=do_phonons_zero_rotation, & - force_const_mat=force_const_mat) - else - call phonons_all(pot, at, phonons_dx, phonon_evals, phonon_evecs, phonon_masses, calc_args = calc_args, & - do_parallel=do_parallel_phonons, zero_rotation=do_phonons_zero_rotation) - endif - endif - - if (do_force_const_mat) then - call print ("Force constants are usually in eV/A^2") - mainlog%prefix="FORCE_CONST_MAT" - do i=1, size(force_const_mat,1) - do j=1, size(force_const_mat,2) - call print( ((i-1)/3+1) // " " // (mod(i-1,3)+1) // " " // ((j-1)/3+1) // " " // (mod(j-1,3)+1) // " " // force_const_mat(i,j)) - end do - end do - mainlog%prefix="" - deallocate(force_const_mat) - endif - - call print ("Phonons frequencies are \omega usually in fs^-1") - - call add_property(at,"phonon", 0.0_dp, 3) - if (.not. assign_pointer(at,"phonon", phonon)) & - call system_abort("Failed to assign pointer for phonon property") - do i=1, at%N*3 - phonon = reshape(phonon_evecs(:,i), (/ 3, at%N /)) - call set_value(at%params, "phonon_i", i) - if (phonon_evals(i) > 0.0_dp) then - call set_value(at%params, "phonon_freq", sqrt(phonon_evals(i))) - else - call set_value(at%params, "phonon_freq", "I*"//sqrt(-phonon_evals(i))) - endif - call set_value(at%params, "phonon_eff_mass", phonon_masses(i)) - if (do_dipole_moment) then - call set_value(at%params, "IR_intensity", 10**6*IR_intensities(i)) - endif - - if (do_frozen_phonons) then - call verbosity_push(PRINT_VERBOSE) - eval_froz = eval_frozen_phonon(pot, at, phonons_dx, phonon_evecs(:,i), calc_args)/phonon_masses(i) - if (eval_froz > 0.0_dp) then - call set_value(at%params, "frozen_phonon_freq", sqrt(eval_froz)) - else - call set_value(at%params, "frozen_phonon_freq", "I*"//sqrt(-eval_froz)) - endif - call verbosity_pop() - endif - - ! set prefix to PHONON - if (do_dipole_moment) then - call write(at,'stdout',properties='pos:phonon:local_dn') - else - call write(at,'stdout',properties='pos:phonon') - endif - - if (do_frozen_phonons) call remove_value(at%params, "frozen_phonon_freq") - - end do - if (do_dipole_moment) then - deallocate(IR_intensities) - endif - deallocate(phonon_evals) - deallocate(phonon_masses) - deallocate(phonon_evecs) - call remove_property(at,"phonon") - call remove_value(at%params, 'phonon_i') - call remove_value(at%params, 'phonon_freq') - call remove_value(at%params, 'phonon_eff_mass') - if (do_dipole_moment) call remove_value(at%params, 'IR_intensity') - endif ! do phonons - - if (do_fine_phonons) then - did_anything = .true. - - if( .not. has_phonon_supercell_fine ) phonon_supercell_fine = phonon_supercell - - if (has_phonons_path_start .and. has_phonons_path_end) then - call Phonon_fine_calc_print(pot, at, phonons_dx, calc_args = calc_args, do_parallel=do_parallel_phonons, & - & phonon_supercell=phonon_supercell, phonon_supercell_fine=phonon_supercell_fine, & - & phonons_path_start=phonons_path_start, phonons_path_end=phonons_path_end, & - & phonons_path_steps=phonons_path_steps, do_phonopy_force_const_mat=do_phonopy_force_const_mat) - else - call Phonon_fine_calc_print(pot, at, phonons_dx, calc_args = calc_args, do_parallel=do_parallel_phonons, & - & phonon_supercell=phonon_supercell, phonon_supercell_fine=phonon_supercell_fine, & - & do_phonopy_force_const_mat=do_phonopy_force_const_mat) - endif - endif ! do_fine_phonons - - if(do_EvsV) then - did_anything = .true. - - extra_calc_args = "" - if (do_E) extra_calc_args = trim(extra_calc_args)//" energy" - if (do_F) extra_calc_args = trim(extra_calc_args)//" force" - if (do_V) extra_calc_args = trim(extra_calc_args)//" virial" - if (do_local) then - if (do_E) extra_calc_args = trim(extra_calc_args)//" local_energy" - if (do_v) extra_calc_args = trim(extra_calc_args)//" local_virial" - endif - - if(.not. do_E) then - call print("Cannot do E vs V without E calculation being requested", PRINT_ALWAYS) - else - call print("EVSV dV factor = "//EvsV_dVfactor) - call print("EVSV linear factor = "//(EvsV_dVfactor**(1.0_dp/3.0_dp))) - call print("EVSV number of steps = "//EvsV_NdVsteps) - call print("EVSV Volume Energy Max force component") - call print("EVSV --------------------------------------") - do i=1,EvsV_NdVsteps - call set_lattice(at, at%lattice*(EvsV_dVfactor**(1.0_dp/3.0_dp)), scale_positions=.true.) - - call calc(pot, at, args_str = trim(calc_args)//" "//trim(extra_calc_args), error=error) - HANDLE_ERROR(error) - call get_param_value(at, 'energy', E0) - if (do_F) call assign_property_pointer(at, "force", F0) - call print("EVSV "//cell_volume(at)//" "//E0//" "//maxval(F0)) - end do - end if - end if - -#ifdef HAVE_TB - if (do_absorption) do_calc = .true. -#endif - if ( has_descriptor_str ) do_calc = .true. - if(do_grad_descriptor) then - mainlog%prefix = "GRAD_DSC" - call print("descriptor index | derivative w.r.t. atom index | derivative w.r.t. Cartesian dimension | difference vector component | descriptor derivative") - mainlog%prefix = "" - endif - - if ((.not. did_anything .or. do_calc) .and. (do_E .or. do_F .or. do_V .or. do_local)) then - did_anything = .true. - extra_calc_args = "" - if (do_E) extra_calc_args = trim(extra_calc_args)//" energy" - if (do_F) extra_calc_args = trim(extra_calc_args)//" force" - if (do_V) extra_calc_args = trim(extra_calc_args)//" virial" - if (do_local) then - if (do_E) extra_calc_args = trim(extra_calc_args)//" local_energy" - if (do_v) extra_calc_args = trim(extra_calc_args)//" local_virial" - endif - - call calc(pot, at, args_str = trim(calc_args)//" "//trim(extra_calc_args), error=error) - HANDLE_ERROR(error) - if (do_E) call get_param_value(at, 'energy', E0) - if (do_F) call assign_property_pointer(at, "force", F0) - if (do_V) call get_param_value(at, "virial", V0) - if (do_local) then - if (do_E) call assign_property_pointer(at, "local_energy", local_E0) - if (do_v) call assign_property_pointer(at, "local_virial", local_v0) - endif - - if(do_print_pot) then - call print(pot) - do_print_pot = .false. - end if - - if (do_E) then - call print ("Energy=" // E0) - call set_value(at%params, 'Energy', "" // E0) - endif - - if (do_dipole_moment) then - if (.not. assign_pointer(at, "local_dn", local_dn)) & - call system_abort("impossible failure to assign pointer for local_dn") - mu = dipole_moment(at%pos, local_dn) - call print ("Dipole moment " // mu) - call set_value(at%params, 'Dipole_Moment', ""//mu) - endif - - if (do_V) then - P0 = V0/cell_volume(at) - do i=1, 3 - call print ("Virial " // V0(i,:)) - end do - do i=1, 3 - call print ("Pressure eV/A^3 " // P0(i,:) // " GPa " // (P0(i,:)*EV_A3_IN_GPA)) - end do - end if - - if (do_torque) then - if (.not. do_F) then - call print("ERROR: Can't do torque without forces", PRINT_ALWAYS) - else - tau = torque(at%pos, F0) - call print("Torque " // tau) - endif - endif - call print('Cell Volume: '//cell_volume(at)//' A^3') - endif ! do_E, F, V, local - -#ifdef HAVE_TB - if (do_absorption) then - if (.not. associated (pot%simple%tb)) & - call system_abort("Can only do absorption of TB model") - - absorption_polarization = (/ cmplx(absorption_polarization_in(1), absorption_polarization_in(2), dp), & - cmplx(absorption_polarization_in(3), absorption_polarization_in(4), dp), & - cmplx(absorption_polarization_in(5), absorption_polarization_in(6), dp) /) - call print("do absorption: polarization " // absorption_polarization) - call print("do absorption: freq_range " // absorption_freq_range) - call print("do absorption: gamma " // absorption_gamma) - - allocate(absorption_freqs(floor((absorption_freq_range(2)-absorption_freq_range(1))/absorption_freq_range(3)+1.5_dp))) - allocate(absorption_v(floor((absorption_freq_range(2)-absorption_freq_range(1))/absorption_freq_range(3)+1.5_dp))) - do freq_i=1, size(absorption_freqs) - absorption_freqs(freq_i) = absorption_freq_range(1) +(freq_i-1)*absorption_freq_range(3) - end do - - call absorption(pot%simple%tb, absorption_polarization, absorption_freqs, absorption_gamma, absorption_v) - do freq_i=1, size(absorption_freqs) - call print("absorption i " // freq_i // " freq " // absorption_freqs(freq_i) // " a " // absorption_v(freq_i)) - end do - deallocate(absorption_freqs) - deallocate(absorption_v) - endif -#endif - -#ifdef HAVE_GAP - if ( has_descriptor_str ) then - did_anything = .true. - call descriptor_sizes(eval_descriptor,at,n_descriptors,n_cross) - allocate(descriptor_array(descriptor_dimensions(eval_descriptor),n_descriptors)) - if(do_grad_descriptor) & - allocate(grad_descriptor_array(descriptor_dimensions(eval_descriptor),3,n_cross), & - grad_descriptor_index(2, n_cross), grad_descriptor_pos(3,n_cross) ) - - if(do_grad_descriptor) then - call calc(eval_descriptor,at,descriptor_out=descriptor_array,& - grad_descriptor_out=grad_descriptor_array,grad_descriptor_index=grad_descriptor_index,grad_descriptor_pos=grad_descriptor_pos,args_str=trim(calc_args)) - else - call calc(eval_descriptor,at,descriptor_out=descriptor_array,args_str=trim(calc_args)) - endif - mainlog%prefix = "DESC" - do i = 1, n_descriptors - call print(""//descriptor_array(:,i), PRINT_ALWAYS, mainlog) - end do - if(do_grad_descriptor) then - mainlog%prefix = "GRAD_DSC" - do i = 1, n_cross - do j = 1, 3 - call print(""//grad_descriptor_index(:,i)//" "//grad_descriptor_pos(j,i)//" "//grad_descriptor_array(:,j,i), PRINT_ALWAYS, mainlog) - enddo - enddo - endif - mainlog%prefix = "" - deallocate(descriptor_array) - if(allocated(grad_descriptor_array)) deallocate(grad_descriptor_array) - if(allocated(grad_descriptor_index)) deallocate(grad_descriptor_index) - if(allocated(grad_descriptor_pos)) deallocate(grad_descriptor_pos) - end if -#endif - - if (.not. did_anything) call system_abort("Nothing to be calculated") - - call write(at, 'stdout', prefix='AT',real_format=trim(real_format)) - - call finalise(at) - - enddo - -#ifdef HAVE_GAP - call finalise(eval_descriptor) -#endif - - call system_finalise() - -end program diff --git a/src/Programs/quip_wrapper_example.f95 b/src/Programs/quip_wrapper_example.f95 deleted file mode 100644 index 5ad6fee334..0000000000 --- a/src/Programs/quip_wrapper_example.f95 +++ /dev/null @@ -1,40 +0,0 @@ -program quip_wrapper_example - - implicit none - - integer, parameter :: n = 6 - real(8), dimension(3,3) :: lattice - character(len=3), dimension(n) :: symbol - real(8), dimension(3,n) :: coord - character(len=1023) :: args_str - integer :: args_str_length - - real(8) :: energy - real(8), dimension(3,n) :: force - real(8), dimension(3,3) :: virial - - lattice(1,1) = 20.0d0; lattice(1,2) = 0.0d0; lattice(1,3) = 0.0d0; - lattice(2,1) = 0.0d0; lattice(2,2) = 20.0d0; lattice(2,3) = 0.0d0; - lattice(3,1) = 0.0d0; lattice(3,2) = 0.0d0; lattice(3,3) = 20.0d0; - - symbol = (/"O ","H ","H ","O ","H ","H "/) - - coord(1,1) = -7.110371d0; coord(2,1) = -3.533572d0; coord(3,1) = 2.147261d0; - coord(1,2) = -7.933029d0; coord(2,2) = -3.234956d0; coord(3,2) = 2.573383d0; - coord(1,3) = -6.492180d0; coord(2,3) = -3.628907d0; coord(3,3) = 2.852075d0; - coord(1,4) = -8.691981d0; coord(2,4) = -6.070463d0; coord(3,4) = -0.236430d0; - coord(1,5) = -8.188371d0; coord(2,5) = -5.684074d0; coord(3,5) = -0.942021d0; - coord(1,6) = -8.927810d0; coord(2,6) = -6.879853d0; coord(3,6) = -0.621913d0; - - args_str="IP PartridgeSchwenke force_using_fd" - args_str_length = len_trim(args_str) - - - call quip_wrapper(n,lattice,symbol,coord,args_str,args_str_length,energy,force,virial,.true.,.true.,.false.) - - - print*,'Energy = ', energy - print*, "forces:" - print*, force - -endprogram quip_wrapper_example diff --git a/src/Programs/quip_wrapper_simple_example.f95 b/src/Programs/quip_wrapper_simple_example.f95 deleted file mode 100644 index b76c0f0623..0000000000 --- a/src/Programs/quip_wrapper_simple_example.f95 +++ /dev/null @@ -1,35 +0,0 @@ -program quip_wrapper_simple_example - - implicit none - - integer, parameter :: n = 2 - real(8), dimension(3,3) :: lattice - integer, dimension(n) :: Z - real(8), dimension(3,n) :: coord - - - real(8) :: energy - real(8), dimension(3,n) :: force - real(8), dimension(3,3) :: virial - - - - lattice(1,1) = 20.0d0; lattice(1,2) = 0.0d0; lattice(1,3) = 0.0d0; - lattice(2,1) = 0.0d0; lattice(2,2) = 20.0d0; lattice(2,3) = 0.0d0; - lattice(3,1) = 0.0d0; lattice(3,2) = 0.0d0; lattice(3,3) = 20.0d0; - - Z = (/29,29/) - - coord(1,1) = -7.110371d0; coord(2,1) = -3.533572d0; coord(3,1) = 2.147261d0; - coord(1,2) = -7.933029d0; coord(2,2) = -3.234956d0; coord(3,2) = 2.573383d0; - - - call quip_wrapper_simple(n,lattice,Z,coord,energy,force,virial) - - - print*,'Energy = ', energy - print*, "forces:" - print*, force - print*, "virial:" - print*, virial -endprogram quip_wrapper_simple_example diff --git a/src/Programs/randomise_calc.f95 b/src/Programs/randomise_calc.f95 deleted file mode 100644 index 3964bc4706..0000000000 --- a/src/Programs/randomise_calc.f95 +++ /dev/null @@ -1,161 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program randomise_calc - -use libAtoms_module -use Potential_module - -implicit none - - type(Potential) pot - type(Atoms):: at, at2 - real(dp)::e - real(dp):: lat(3,3), v(3,3), strain(3,3) - real(dp), allocatable::f(:,:) - real(dp):: pos_delta, lattice_delta, normal_strain_delta, shear_strain_delta, strain_vector(6) - logical:: lattice_pull, lattice_pull1, lattice_pull2, lattice_pull3, scale_positions, dryrun, no_11, no_12, no_13, no_22, no_23, no_33 - integer :: i - type(Dictionary) :: cli - character(len=STRING_LENGTH) :: infile, outfile, pot_init_args - integer :: rng_seed, n_configs - - call system_initialise(enable_timing=.true.) - - call initialise(cli) - call param_register(cli, "pot_init_args", PARAM_MANDATORY, pot_init_args, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "infile", "stdin", infile, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "outfile", "stdout", outfile, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "rng_seed", "-1", rng_seed, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "n_configs", "10", n_configs, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "positions_delta", "0.2", pos_delta, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "lattice_delta", "0.2", lattice_delta, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "lattice_pull1", "F", lattice_pull1, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "lattice_pull2", "F", lattice_pull2, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "lattice_pull3", "F", lattice_pull3, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "scale_positions", "T", scale_positions, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "dryrun", "F", dryrun, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "normal_strain_delta", "0.0", normal_strain_delta, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "shear_strain_delta", "0.0", shear_strain_delta, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "strain_vector", "0.0 0.0 0.0 0.0 0.0 0.0", strain_vector, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "no_11", "F", no_11, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "no_12", "F", no_12, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "no_13", "F", no_13, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "no_22", "F", no_22, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "no_23", "F", no_23, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli, "no_33", "F", no_33, help_string="No help yet. This source file was $LastChangedBy$") - - if (.not. param_read_args(cli, ignore_unknown=.false.)) & - call system_abort ("Failed to parse command line arguments") - call finalise(cli) - - if (rng_seed >= 0) call system_set_random_seeds(rng_seed) - - if(.not. dryrun) call Initialise(pot, trim(pot_init_args)) - - call read(at2, trim(infile)) - if(.not. dryrun) allocate(f(3,at2%N)) - - lattice_pull = .false. - if(lattice_pull1 .or. lattice_pull2 .or. lattice_pull3) lattice_pull = .true. - - at=at2 - do i=1,n_configs - if(.not. lattice_pull) at=at2 - - if(pos_delta /= 0.0_dp) call randomise(at%pos, pos_delta) - - if(lattice_delta /= 0.0_dp) then - if(lattice_pull) then - lat = at%lattice - if(lattice_pull1) lat(:,1) = lat(:,1)*(1.0_dp+lattice_delta) - if(lattice_pull2) lat(:,2) = lat(:,2)*(1.0_dp+lattice_delta) - if(lattice_pull3) lat(:,3) = lat(:,3)*(1.0_dp+lattice_delta) - else - lat = at%lattice - call randomise(lat, lattice_delta) - end if - - call set_lattice(at, lat, scale_positions=scale_positions) - end if - - if ((normal_strain_delta .fne. 0.0_dp) .or. (shear_strain_delta .fne. 0.0_dp) .or. (strain_vector .fne. (/0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp/))) then - strain = 0.0_dp - call add_identity(strain) - - if (normal_strain_delta .fne. 0.0_dp) then - if (.not. no_11) strain(1,1) = strain(1,1) + (ran_uniform()-0.5_dp)*normal_strain_delta - if (.not. no_22) strain(2,2) = strain(2,2) + (ran_uniform()-0.5_dp)*normal_strain_delta - if (.not. no_33) strain(3,3) = strain(3,3) + (ran_uniform()-0.5_dp)*normal_strain_delta - end if - - if (shear_strain_delta .fne. 0.0_dp) then - if (.not. no_12) strain(1,2) = strain(1,2) + (ran_uniform()-0.5_dp)*shear_strain_delta - if (.not. no_13) strain(1,3) = strain(1,3) + (ran_uniform()-0.5_dp)*shear_strain_delta - if (.not. no_23) strain(2,3) = strain(2,3) + (ran_uniform()-0.5_dp)*shear_strain_delta - end if - - if (strain_vector .fne. (/0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp,0.0_dp/)) then - if (.not. no_11) strain(1,1) = strain(1,1) + strain_vector(1) - if (.not. no_22) strain(2,2) = strain(2,2) + strain_vector(2) - if (.not. no_33) strain(3,3) = strain(3,3) + strain_vector(3) - if (.not. no_12) strain(1,2) = strain(1,2) + strain_vector(4) - if (.not. no_13) strain(1,3) = strain(1,3) + strain_vector(5) - if (.not. no_23) strain(2,3) = strain(2,3) + strain_vector(6) - end if - - call print("configuration: " // i) - call print("strain matrix:") - call print(strain) - - call set_lattice(at, strain .mult. at%lattice, scale_positions = .true., remap = .true.) - end if - - if(.not. dryrun) then - call system_timer("calc") - call calc(pot, at, energy=e, force=f, virial=v) - call system_timer("calc") - call add_property(at, 'f', f) - call set_value(at%properties,'Energy', e) - call set_value(at%properties,'virial', reshape(v, (/9 /))) - call write(at, outfile, properties='species:pos:f', append=.true.) - else - call write(at, outfile, properties='species:pos', append=.true.) - end if - end do - if(.not. dryrun) deallocate(f) - - call finalise(at) - call finalise(at2) - call finalise(pot) - - call system_finalise() - -end program randomise_calc diff --git a/src/Programs/rotate.f95 b/src/Programs/rotate.f95 deleted file mode 100644 index 6d92ba00b1..0000000000 --- a/src/Programs/rotate.f95 +++ /dev/null @@ -1,62 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -program do_rotate -use libatoms_module -use frametools_module -implicit none - type(atoms) :: at - integer stat - real(dp) :: axis(3), theta, origin(3) - type(dictionary) :: cli_params - - call system_initialise(PRINT_SILENT) - - call initialise(cli_params) - call param_register(cli_params, "axis", PARAM_MANDATORY, axis, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "angle", PARAM_MANDATORY, theta, help_string="No help yet. This source file was $LastChangedBy$") - call param_register(cli_params, "origin", "0 0 0", origin, help_string="No help yet. This source file was $LastChangedBy$") - if (.not. param_read_args(cli_params)) then - call print('Usage: rotate axis="x y z" angle=theta [ origin="0 0 0" ]', PRINT_ALWAYS) - call system_abort("Failed to parse cli args") - endif - call finalise(cli_params) - - call read(at, "stdin", error=stat) - do while (stat == ERROR_NONE) - call rotate(at%pos, axis, theta, origin) - call verbosity_push(PRINT_NORMAL) - call write(at, 'stdout') - call verbosity_pop() - call read(at, "stdin", error=stat) - end do - - call system_finalise() -end program diff --git a/src/Programs/slice_sample.f95 b/src/Programs/slice_sample.f95 deleted file mode 100644 index 7bb7b3ca10..0000000000 --- a/src/Programs/slice_sample.f95 +++ /dev/null @@ -1,371 +0,0 @@ -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -! H0 X -! H0 X libAtoms+QUIP: atomistic simulation library -! H0 X -! H0 X Portions of this code were written by -! H0 X Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode, -! H0 X Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield. -! H0 X -! H0 X Copyright 2006-2010. -! H0 X -! H0 X These portions of the source code are released under the GNU General -! H0 X Public License, version 2, http://www.gnu.org/copyleft/gpl.html -! H0 X -! H0 X If you would like to license the source code under different terms, -! H0 X please contact Gabor Csanyi, gabor@csanyi.net -! H0 X -! H0 X Portions of this code were written by Noam Bernstein as part of -! H0 X his employment for the U.S. Government, and are not subject -! H0 X to copyright in the USA. -! H0 X -! H0 X -! H0 X When using this software, please cite the following reference: -! H0 X -! H0 X http://www.libatoms.org -! H0 X -! H0 X Additional contributions by -! H0 X Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras -! H0 X -! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - -#include "error.inc" - -program slice_sample - -use libAtoms_module -use Potential_module - -implicit none - - type(Dictionary) :: cli_params - type(Potential) :: pot - type(Atoms) :: at - real(dp) :: lattice_vec(9), atom_1(3), atom_2(3) - integer :: Z_1, Z_2 - logical :: has_atom_2 - character(len=STRING_LENGTH) :: param_file, init_args - integer :: n_configs, m_max, rng_seed, init_d - real(dp) :: lattice_delta, atom_delta, e0, t, pressure, aa, bb, cc, cell_alpha, cell_beta, cell_gamma - integer :: n, d - real(dp) :: lattice(3,3), old_lattice_inv(3,3), theta - real(dp), allocatable :: x(:), x_dash(:) - - call system_initialise() - - call enable_timing() - - call initialise(cli_params) - call param_register(cli_params, "lattice", PARAM_MANDATORY, lattice_vec, help_string = "No help yet.") - call param_register(cli_params, "atom_1", "0.0 0.0 0.0", atom_1, help_string = "No help yet.") - call param_register(cli_params, "atom_2", "0.0 0.0 0.0", atom_2, help_string = "No help yet.", has_value_target=has_atom_2) - call param_register(cli_params, "Z_1", PARAM_MANDATORY, Z_1, help_string = "No help yet.") - call param_register(cli_params, "Z_2", "0", Z_2, help_string = "No help yet.", has_value_target=has_atom_2) - call param_register(cli_params, 'param_file', 'quip_params.xml', param_file, help_string="No help yet.") - call param_register(cli_params, 'init_args', '', init_args, help_string="No help yet.") - call param_register(cli_params, "n_configs", "60", n_configs, help_string = "No help yet.") - call param_register(cli_params, "e0", PARAM_MANDATORY, e0, help_string = "No help yet.") - call param_register(cli_params, "temp", PARAM_MANDATORY, t, help_string = "No help yet.") - call param_register(cli_params, "pressure", "0.0", pressure, help_string = "Pressure in GPA") - call param_register(cli_params, "lattice_delta", PARAM_MANDATORY, lattice_delta, help_string = "No help yet.") - call param_register(cli_params, "atom_delta", "0.0", atom_delta, help_string = "No help yet.") - call param_register(cli_params, "m_max", PARAM_MANDATORY, m_max, help_string = "No help yet.") - call param_register(cli_params, "rng_seed", "-1", rng_seed, help_string = "No help yet.") - call param_register(cli_params, "init_d", "1", init_d, help_string = "No help yet.") - - if (.not. param_read_args(cli_params, task="slice_sample CLI arguments")) then - call print("Usage: slice_sample lattice='{r r r r r r r r r}' [atom_1={0.0 0.0 0.0}] [atom_2='{r r r}']",PRINT_ALWAYS) - call print(" Z_1='i' [Z_2='i'] [param_file='file'] [init_args='str']", PRINT_ALWAYS) - call print(" [n_configs=60] e0='r' temp='r' lattice_delta='r' [atom_delta='r'] m_max=i", PRINT_ALWAYS) - call print(" [rng_seed=i] [init_d=1]", PRINT_ALWAYS) - call system_abort("Confused by CLI arguments.") - end if - call finalise(cli_params) - - pressure = pressure / EV_A3_IN_GPA ! Pressure is now in eV/A^3 - - if (rng_seed >= 0) call system_set_random_seeds(rng_seed) - - if (trim(init_args) .ne. '') then - if (trim(param_file) .ne. '') then - call potential_filename_initialise(pot, args_str=init_args, param_filename=param_file) - else - call initialise(pot, args_str=init_args) - end if - else - call system_abort("Potential not initialised.") - end if - - lattice = reshape(lattice_vec, (/ 3, 3 /)) - - call print("Input lattice:") - call print(lattice) - - if (has_atom_2) atom_2 = atom_2 - atom_1 - atom_1 = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - - !if (lattice(2,1) .fne. 0.0_dp) then - ! theta = - atan2(lattice(2,1), lattice(1,1)) - ! lattice = matmul(reshape((/ cos(theta), sin(theta), 0.0_dp, -sin(theta), cos(theta), 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp /), (/ 3, 3 /)), lattice) - ! if (has_atom_2) atom_2 = matmul(reshape((/ cos(theta), sin(theta), 0.0_dp, -sin(theta), cos(theta), 0.0_dp, 0.0_dp, 0.0_dp, 1.0_dp /), (/ 3, 3 /)), atom_2) - !end if - - !if (lattice(3,1) .fne. 0.0_dp) then - ! theta = - atan2(lattice(3,1), lattice(1,1)) - ! lattice = matmul(reshape((/ cos(theta), 0.0_dp, -sin(theta), 0.0_dp, 1.0_dp, 0.0_dp, sin(theta), 0.0_dp, cos(theta) /), (/ 3, 3 /)), lattice) - ! if (has_atom_2) atom_2 = matmul(reshape((/ cos(theta), 0.0_dp, -sin(theta), 0.0_dp, 1.0_dp, 0.0_dp, sin(theta), 0.0_dp, cos(theta) /), (/ 3, 3 /)), atom_2) - !end if - - !if (lattice(3,2) .fne. 0.0_dp) then - ! theta = - atan2(lattice(3,2), lattice(2,2)) - ! lattice = matmul(reshape((/ 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, cos(theta), sin(theta), 0.0_dp, -sin(theta), cos(theta) /), (/ 3, 3 /)), lattice) - ! if (has_atom_2) atom_2 = matmul(reshape((/ 1.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, cos(theta), sin(theta), 0.0_dp, -sin(theta), cos(theta) /), (/ 3, 3 /)), atom_2) - !end if - - call matrix3x3_inverse(lattice,old_lattice_inv) - call get_lattice_params(lattice, aa, bb, cc, cell_alpha, cell_beta, cell_gamma) - lattice = make_lattice(aa, bb, cc, cell_alpha, cell_beta, cell_gamma) - atom_2 = matmul(lattice,matmul(old_lattice_inv,atom_2)) - - call print("Rotated lattice:") - call print(lattice) - - if (has_atom_2) then - allocate(x(0:9), x_dash(0:9)) - else - allocate(x(0:6), x_dash(0:6)) - end if - - x(1:6) = (/ lattice(1,1), lattice(1,2), lattice(2,2), lattice(1,3), lattice(2,3), lattice(3,3) /) - if (has_atom_2) x(7:9) = (/ atom_2(1), atom_2(2), atom_2(3) /) - - x(0) = density_function(x(1:)) - - ! hack to output castep data - !if (associated(pot%simple%filepot)) then - ! if (has_atom_2) then - ! call system_command("tail -n 4 " // trim(pot%simple%filepot%filename) // "/" // trim(pot%simple%filepot%filename) // "_output >> slice_sample.xyz") - ! else - ! call system_command("tail -n 3 " // trim(pot%simple%filepot%filename) // "/" // trim(pot%simple%filepot%filename) // "_output >> slice_sample.xyz") - ! end if - !else - if (has_atom_2) then - call initialise(at, 2, reshape((/ x(1), 0.0_dp, 0.0_dp, x(2), x(3), 0.0_dp, x(4), x(5), x(6) /), (/3, 3/))) - at%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - at%pos(:,2) = (/ x(7), x(8), x(9) /) - call set_atoms(at, (/ Z_1, Z_2 /)) - call map_into_cell(at) - else - call initialise(at, 1, reshape((/ x(1), 0.0_dp, 0.0_dp, x(2), x(3), 0.0_dp, x(4), x(5), x(6) /), (/3, 3/))) - at%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - call set_atoms(at, Z_1) - end if - call write(at, 'stdout', prefix='AT') - call finalise(at) - !endif - - call print("SLICE_SAMPLE " // x) - - n = 1 - d = init_d - - do - x_dash = x - x = x_new(x_dash(1:), d, lattice_delta, atom_delta, m_max, f_0 = x_dash(0)) - - ! hack to output castep data - !if (associated(pot%simple%filepot)) then - ! if (has_atom_2) then - ! call system_command("tail -n 4 " // trim(pot%simple%filepot%filename) // "/" // trim(pot%simple%filepot%filename) // "_output >> slice_sample.xyz") - ! else - ! call system_command("tail -n 3 " // trim(pot%simple%filepot%filename) // "/" // trim(pot%simple%filepot%filename) // "_output >> slice_sample.xyz") - ! end if - !else - if (has_atom_2) then - call initialise(at, 2, reshape((/ x(1), 0.0_dp, 0.0_dp, x(2), x(3), 0.0_dp, x(4), x(5), x(6) /), (/3, 3/))) - at%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - at%pos(:,2) = (/ x(7), x(8), x(9) /) - call set_atoms(at, (/ Z_1, Z_2 /)) - call map_into_cell(at) - else - call initialise(at, 1, reshape((/ x(1), 0.0_dp, 0.0_dp, x(2), x(3), 0.0_dp, x(4), x(5), x(6) /), (/3, 3/))) - at%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - call set_atoms(at, Z_1) - end if - call write(at, 'stdout', prefix='AT') - call finalise(at) - !endif - - call print("SLICE_SAMPLE " // x) - - if (n >= n_configs) then - exit - else - n = n + 1 - d = d + 1 - if (has_atom_2) then - if (d == 10) d = 1 - else - if (d == 7) d = 1 - end if - end if - end do - - deallocate(x, x_dash) - - call finalise(pot) - - call system_finalise() - -contains - - function density_function(x) - real(dp), intent(in) :: x(:) - real(dp) :: density_function - - type(Atoms) :: at - real(dp) :: E, volume - integer :: error - - if (size(x) == 9) then - call initialise(at, 2, reshape((/ x(1), 0.0_dp, 0.0_dp, x(2), x(3), 0.0_dp, x(4), x(5), x(6) /), (/3, 3/))) - at%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - at%pos(:,2) = (/ x(7), x(8), x(9) /) - call set_atoms(at, (/ Z_1, Z_2 /)) - call map_into_cell(at) - else - call initialise(at, 1, reshape((/ x(1), 0.0_dp, 0.0_dp, x(2), x(3), 0.0_dp, x(4), x(5), x(6) /), (/3, 3/))) - at%pos(:,1) = (/ 0.0_dp, 0.0_dp, 0.0_dp /) - call set_atoms(at, Z_1) - end if - - call set_cutoff(at, cutoff(pot)) - call calc_connect(at) - call calc(pot, at, energy = E, error = error) - - if (error /= ERROR_NONE) E = e0 + 1000000000000.0_dp - volume = cell_volume(at) - - call finalise(at) - - density_function = exp( - (E - e0 + pressure*volume) / (t * 0.00008617343_dp) ) - - end function density_function - - function x_new(x_0, d, w_1, w_2, m, f_0) - real(dp), intent(in) :: x_0(:) - integer, intent(in) :: d - real(dp), intent(in) :: w_1, w_2 - integer, intent(in) :: m - real(dp), intent(in), optional :: f_0 - real(dp) :: x_new(0:size(x_0)) - - real(dp) :: x(size(x_0)) - real(dp) :: f_slice - real(dp) :: x_new_L, x_new_R, f_x_new_L, f_x_new_R, f_x_new - logical :: increase_slice, f_x_new_L_up_to_date, f_x_new_R_up_to_date - integer :: J, K - - x_new(0) = 0.0_dp - x_new(1:size(x_0)) = x_0 - x = x_0 - - if (present(f_0)) then - f_slice = ran_uniform() * f_0 - else - f_slice = ran_uniform() * density_function(x_0) - end if - - if (d < 7) then - x_new_L = x_0(d) - (w_1 * ran_uniform()) - x_new_R = x_new_L + w_1 - else - x_new_L = x_0(d) - (w_2 * ran_uniform()) - x_new_R = x_new_L + w_2 - end if - - J = floor(real(m, dp) * ran_uniform()) - K = m - 1 - J - - f_x_new_L = 0.0_dp - f_x_new_R = 0.0_dp - f_x_new_L_up_to_date = .false. - f_x_new_R_up_to_date = .false. - - do - if (J > 0) then - increase_slice = .false. - - if (.not. f_x_new_L_up_to_date) then - x(d) = x_new_L - f_x_new_L = density_function(x) - f_x_new_L_up_to_date = .true. - end if - - if (f_x_new_L > f_slice) increase_slice = .true. - - if (increase_slice) then - if (d < 7) then - x_new_L = x_new_L - w_1 - else - x_new_L = x_new_L - w_2 - end if - f_x_new_L_up_to_date = .false. - - J = J - 1 - else - exit - end if - else - exit - end if - end do - - do - if (K > 0) then - increase_slice = .false. - - if (.not. f_x_new_R_up_to_date) then - x(d) = x_new_R - f_x_new_R = density_function(x) - f_x_new_R_up_to_date = .true. - end if - - if (f_x_new_R > f_slice) increase_slice = .true. - - if (increase_slice) then - if (d < 7) then - x_new_R = x_new_R + w_1 - else - x_new_R = x_new_R + w_2 - end if - f_x_new_R_up_to_date = .false. - - K = K - 1 - else - exit - end if - else - exit - end if - end do - - do - x_new(d) = x_new_L + (ran_uniform() * (x_new_R - x_new_L)) - - f_x_new = density_function(x_new(1:)) - - if (f_x_new > f_slice) then - x_new(0) = f_x_new - exit - end if - - if (x_new(d) < x_0(d)) then - x_new_L = x_new(d) - else - x_new_R = x_new(d) - end if - end do - - end function x_new - -end program slice_sample diff --git a/src/Programs/socktest.f95 b/src/Programs/socktest.f95 deleted file mode 100644 index 6bb17e7d2d..0000000000 --- a/src/Programs/socktest.f95 +++ /dev/null @@ -1,81 +0,0 @@ -program socktest - - use libAtoms_module - use Potential_module - use SocketTools_module - - implicit none - - type(Atoms) :: at - type(Potential) :: pot - type(MPI_context) :: mpi - - character(STRING_LENGTH) :: ip, tmp - integer :: port, client_id, buffsize, n_atoms, i, n, label - real(dp) :: e, v(3,3), lattice(3,3) - real(dp), allocatable :: frac_pos(:,:), f(:,:) - - call system_initialise - - call initialise(mpi) - - if (mpi%my_proc == 0) then - - call get_cmd_arg(1, ip) - call get_cmd_arg(2, tmp) - port = string_to_int(tmp) - call get_cmd_arg(3, tmp) - client_id = string_to_int(tmp) - buffsize = 1000000 - call get_cmd_arg(4, tmp) - label = string_to_int(tmp) - - mainlog%prefix = 'CLIENT '//client_id - - ! Read initial structure from .xyz - call read(at, 'atoms.'//client_id//'.xyz') - - allocate(frac_pos(3, at%n)) - - call potential_filename_initialise(pot, 'IP SW', 'params.xml') - - call print('Connecting to QUIP server on host '//trim(ip)//':'//port//' as client '//client_id) - - n = 0 - do while (.true.) - - allocate(f(3,at%n)) - - call set_cutoff(at, cutoff(pot)) - call calc_connect(at) - call calc(pot, at, energy=e, force=f, virial=v) - - call print('completed calculation n='//n//' label= '//label//' on '//at%n//' atoms. energy='//e) - call socket_send_reftraj(ip, port, client_id, label, at%n, e, f, v) - - n = n + 1 - - deallocate(f) - - call socket_recv_reftraj(ip, port, client_id, buffsize, label, n_atoms, lattice, frac_pos) - - if (n_atoms == 0 .or. n_atoms /= at%n) then - call print('n_atoms='//n_atoms//', at%n='//at%n//' - shutting down QUIP server') - exit - end if - - do i=1, at%n - at%pos(:,i) = at%lattice .mult. frac_pos(:, i) - end do - - end do - - call finalise(at) - call finalise(pot) - - deallocate(frac_pos) - - end if - call system_finalise - -end program socktest diff --git a/src/Programs/socktest2.f95 b/src/Programs/socktest2.f95 deleted file mode 100644 index d8a2ae11bc..0000000000 --- a/src/Programs/socktest2.f95 +++ /dev/null @@ -1,86 +0,0 @@ -program socktest2 - - use libAtoms_module - use Potential_module - use SocketTools_module - - implicit none - - type(Atoms) :: at, cluster, qm_cluster - type(DynamicalSystem) :: ds - type(Potential) :: mmpot, sockpot, fmpot - type(MPI_context) :: mpi - - character(STRING_LENGTH) :: ip, tmp, cluster_args - integer :: port, client_id, n_atoms, i, n, label - real(dp) :: dt = 1.0_dp - real(dp), pointer :: force(:,:) - - cluster_args = 'cluster_calc_connect=F min_images_only hysteretic_connect_cluster_radius=10.0 hysteretic_buffer cluster_periodic_z hysteretic_buffer_inner_radius=6.0 single_cluster=T hysteretic_connect=F cluster_hopping=F randomise_buffer=F hysteretic_connect_outer_factor=1.5 hysteretic_buffer_outer_radius=8.0 cluster_hopping_nneighb_only=F hysteretic_connect_inner_factor=1.3' - - call system_initialise(PRINT_NORMAL, enable_timing=.true.) - - call initialise(mpi) - - if (mpi%my_proc == 0) then - ! usage: socktest2